



		    access_.pl1                     10/06/88  1103.1rew 10/06/88  1102.8       78174



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1988                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(88-07-05,TLNguyen), approve(88-06-13,MCR7919),
     audit(88-07-26,RBarstad), install(88-08-08,MR12.2-1078):
     fix bug which fails to set the desired access mode on MSFs.
                                                   END HISTORY COMMENTS */


access_:	proc;
	return;

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* Name: access_								*/
	/*									*/
	/*      This subroutine can be called by subsystems to temporarily set the ACL of a	*/
	/* particular segment, directory or MSF, and then to restore the ACL to its original	*/
	/* state.  Only ACLs are affected.  AIM classification and ring brackets are not changed. */
	/*									*/
	/* Status:								*/
	/* 0) Created by:  G. C. Dixon, May, 1982					*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */



    dcl	dir			char(*),		/* dir part of path whose access sb set. (In)	*/
	ent			char(*),		/* entry part of path whose access sb set. (In)	*/
	type			fixed bin(2),	/* type of entry:	(In)			*/
						/*   1 = SEGMENT				*/
						/*   2 = DIRECTORY				*/
						/*   3 = MSF or SEGMENT			*/
	mode			bit(*),		/* mode to be set. Must be a file mode or a 	*/
						/*   directory mode, depending upon type.  (In)	*/
	Paccess			ptr,		/* ptr to access_$reset info. (Out)		*/
	code			fixed bin(35);	/* status code from setting/reseting (Out)	*/

    dcl	Pfcb			ptr,
	1 acle			aligned,
	  2 access_name		char(32),
	  2 mode			bit(36),
	  2 xmode			bit(36),
	  2 code			fixed bin(35),
	1 delete_acle		aligned,
	  2 access_name		char(32),
	  2 code			fixed bin(35),
	1 dir_acle		aligned,
	  2 access_name		char(32),
	  2 mode			bit(36),
	  2 code			fixed bin(35);

    dcl	1 access			aligned based (Paccess),
	  2 version		char(8) init("access_1"),
	  2 set			fixed bin init(0),	/* has access been set:			*/
						/*   0 = NO				*/
						/*   1 = ACL_ADDED				*/
						/*   2 = ACL_REPLACED			*/
	  2 type			fixed bin(2),	/* entry type (SEGMENT, DIRECTORY or MSF)	*/
	  2 old_mode		bit(36),		/* mode to be reset when ACL_REPLACED.		*/
	  2 dir			char(168) unal,	/* dir/ent of path whose access was changed.	*/
	  2 ent			char(32) unal,
	area			area based(Parea);

    dcl  (addr, null)		builtin;

    dcl	cleanup			condition;

    dcl	get_group_id_		entry() returns(char(32)),
	get_system_free_area_	entry() returns(ptr),
	hcs_$add_acl_entries	entry (char(*), char(*), ptr, fixed bin, fixed bin(35)),
	hcs_$add_dir_acl_entries	entry (char(*), char(*), ptr, fixed bin, fixed bin(35)),
	hcs_$delete_acl_entries	entry (char(*), char(*), ptr, fixed bin, fixed bin(35)),
	hcs_$delete_dir_acl_entries	entry (char(*), char(*), ptr, fixed bin, fixed bin(35)),
	hcs_$list_acl		entry (char(*), char(*), ptr, ptr, ptr, fixed bin, fixed bin(35)),
	hcs_$list_dir_acl		entry (char(*), char(*), ptr, ptr, ptr, fixed bin, fixed bin(35)),
	msf_manager_$acl_add	entry (ptr, ptr, fixed bin, fixed bin(35)),
	msf_manager_$acl_delete	entry (ptr, ptr, fixed bin, fixed bin(35)),
	msf_manager_$acl_list	entry (ptr, ptr, ptr, ptr, fixed bin, fixed bin(35)),
	msf_manager_$close		entry (ptr),
	msf_manager_$open		entry (char(*), char(*), ptr, fixed bin(35));

    dcl   Parea			ptr int static init(null),
         (NO			init(0),		/* access.set values			*/
	ACL_ADDED			init(1),
	ACL_REPLACED		init(2),
	SEGMENT			init(1),		/* access.type values			*/
	MSF			init(3)) fixed bin int static options(constant),
	access_name		char(32) int static init(""),
         (error_table_$out_of_bounds,
	error_table_$unimplemented_version,
	error_table_$user_not_found)	fixed bin(35) ext static;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


set_temporarily:
	entry (dir, ent, type, mode, Paccess, code);

	Paccess = null;
	if Parea = null then do;
	   Parea = get_system_free_area_();
	   access_name = get_group_id_();
	   end;

          if type < SEGMENT | type > MSF then do;
	   code = error_table_$out_of_bounds;
	   go to EXIT;
	   end;

	allocate access in (area);
	access.dir = dir;
	access.ent = ent;
	access.type = type;
	go to SET(access.type);

SET(1):	acle.access_name = access_name;		/* Handle segment ACL.			*/
	acle.mode = ""b;
	acle.xmode = ""b;
	call hcs_$list_acl (dir, ent, null, null, addr(acle), 1, code);
	if code ^= 0 then go to EXIT;
	if acle.code = error_table_$user_not_found then do;
	   access.old_mode = ""b;
	   access.set = ACL_ADDED;
	   end;
	else if acle.mode = mode then go to EXIT;
	else do;
	   access.old_mode = acle.mode;
	   access.set = ACL_REPLACED;
	   end;
	acle.mode = mode;
	call hcs_$add_acl_entries (dir, ent, addr(acle), 1, code);
	if code ^= 0 then go to EXIT;
	return;

SET(2):	dir_acle.access_name = access_name;
	dir_acle.mode = ""b;
	call hcs_$list_dir_acl (dir, ent, null, null, addr(dir_acle), 1, code);
	if code ^= 0 then  go to EXIT;
	if dir_acle.code = error_table_$user_not_found then do;
	   access.old_mode = ""b;
	   access.set = ACL_ADDED;
	   end;
	else if dir_acle.mode = mode then go to EXIT;
	else do;
	   access.old_mode = dir_acle.mode;
	   access.set = ACL_REPLACED;
	   end;
	dir_acle.mode = mode;
	call hcs_$add_dir_acl_entries (dir, ent, addr(dir_acle), 1, code);
	if code ^= 0 then go to EXIT;
	return;

SET(3):	Pfcb = null;
	on cleanup begin;
	   call msf_manager_$close (Pfcb);
	   end;
	call msf_manager_$open (dir, ent, Pfcb, code);
	if code ^= 0 then go to EXIT;
	acle.access_name = access_name;
	acle.mode = ""b;
	acle.xmode = ""b;
	call msf_manager_$acl_list (Pfcb, null, null, addr(acle), 1, code);
	if code ^= 0 then go to MSF_EXIT;
	if acle.code = error_table_$user_not_found then do;
	   access.old_mode = ""b;
	   access.set = ACL_ADDED;
	   end;
	else if acle.mode = mode then go to MSF_EXIT;
	else do;
	   access.old_mode = acle.mode;
	   access.set = ACL_REPLACED;
	   end;
          acle.mode = mode;                              /* fill in the desired mode */
	call msf_manager_$acl_add (Pfcb, addr(acle), 1, code);
	if code ^= 0 then  go to MSF_EXIT;
	call msf_manager_$close (Pfcb);
	return;

MSF_EXIT: call msf_manager_$close(Pfcb);
	Pfcb = null;

EXIT:	if Paccess ^= null then do;
	   free access in (area);
	   Paccess = null;
	   end;
	return;

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


reset:	entry (Paccess, code);

	code = 0;
	if Paccess = null then return;
	if access.version ^= "access_1" then do;
	   code = error_table_$unimplemented_version;
	   go to EXIT;
	   end;
	if access.set = NO then go to EXIT;
	go to RESET(access.type);

RESET(1):	go to SEG_RESET(access.set);			/* Reset segment ACL.			*/

SEG_RESET(1):					/*   Delete ACL entry previously added.		*/
	delete_acle.access_name = access_name;
	call hcs_$delete_acl_entries (access.dir, access.ent, addr(delete_acle), 1, code);
	go to EXIT;

SEG_RESET(2):					/*   Replace ACL entry with previous mode value.	*/
	acle.access_name = access_name;
	acle.mode = access.old_mode;
	acle.xmode = ""b;
	call hcs_$add_acl_entries (access.dir, access.ent, addr(acle), 1, code);
	go to EXIT;


RESET(2):	go to DIR_RESET(access.set);

DIR_RESET(1):
	delete_acle.access_name = access_name;
	call hcs_$delete_dir_acl_entries (access.dir, access.ent, addr(delete_acle), 1, code);
	go to EXIT;
	
DIR_RESET(2):
	dir_acle.access_name = access_name;
	dir_acle.mode = access.old_mode;
	call hcs_$add_dir_acl_entries (access.dir, access.ent, addr(dir_acle), 1, code);
	go to EXIT;

RESET(3): Pfcb = null;
	on cleanup begin;
	   call msf_manager_$close (Pfcb);
	   end;
	call msf_manager_$open (access.dir, access.ent, Pfcb, code);
	if code ^= 0 then go to EXIT;
	go to MSF_RESET(access.set);

MSF_RESET(1):
	delete_acle.access_name = access_name;
	call msf_manager_$acl_delete (Pfcb, addr(delete_acle), 1, code);
	go to MSF_EXIT;

MSF_RESET(2):
	acle.access_name = access_name;
	acle.mode = access.old_mode;
	acle.xmode = ""b;
	call msf_manager_$acl_add (Pfcb, addr(acle), 1, code);
	go to MSF_EXIT;

	end access_;




		    sort_items_.alm                 11/05/86  1304.4r w 11/04/86  1037.8      247194



" **********************************************************************
" *                                                                    *
" * This is in the PUBLIC DOMAIN and may be copied without permission. *
" *                                                                    *
" **********************************************************************
sort_items_:				"just a program label

	name sort_items_			"define objectname

""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
"This is an ALM version of sort_items_.pl1, written at AFDSC/CMMS.  The
"   program provides a generalized sorting facility for several unique data
"   types.  It uses a vector of unaligned pointers to the items to be sorted.
"   The program then sorts the pointers, leaving the data untouched.  This
"   program is written to replace the system program sort_items_.  Entry
"   points are identical, with only the algorithm changed.
"The outstanding feature of sort_items_.alm is its heavy dependence on
"   hardware registers as program storage.  This reduces the necessity
"   to access main memory and allows the program to operate more directly
"   on the hardware.
"The algorithm used by the program is the heapsort algorithm as stated by
"   Knuth's "The Art of Computer Programming", (vol. 3, pp 146-147) with
"   the modification suggested in Exercise 18 (problem pg 158, answer pg 618).
"There are three major coding sections: init, fix_heap, and sort_heap.
"   Each section will document current register usage.
"The maximum number of data items is 261119!!

"Converted from PL/I March 1982  @ AFDSC/CMMS by LT F. Patrick Clark,
"   USAF and Lee A. Newcomb, HISI.
"Modified April, 1983 by LT F. Patrick Clark (AFDSC/CMMS) to change
"   sub_err_ flag parameter and clean up documentation.
""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
"
""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
"ENTRIES:
"   1) sort_items_$fixed_bin - sorts fixed bin (35) numbers
"   declaration --> declare sort_items_$fixed_bin entry (ptr);
"   usage --> call sort_items_$fixed_bin (vec_ptr);
"
"   2) sort_items_$float_bin - sorts float bin (63) numbers
"   declaration --> declare sort_items_$float_bin entry (ptr);
"   usage --> call sort_items_$float_bin (vec_ptr);
"
"   3) sort_items_$char - sorts nonvarying character strings
"   declaration --> declare sort_items_$char entry (ptr, fixed bin (24));
"   usage --> call sort_items_$char (vec_ptr, str_length);
"
"   4) sort_items_$bit - sorts nonvarying bit strings
"   declaration --> declare sort_items_$bit entry (ptr, fixed bin (24));
"   usage --> call sort_items_$bit (vec_ptr, str_length);
"
"   5) sort_items_$varying_char -- sorts varying character strings
"   declaration --> declare sort_items_$varying_char entry (ptr);
"   usage --> call sort_items_$varying_char (vec_ptr);
"
"   6) sort_items_$general -- sorts items based on a user defined function
"   declaration --> declare sort_items_$general entry (ptr, entry);
"   usage --> call sort_items_$general (vec_ptr, function_name);
"
"   where:
"      vec_ptr - points to a structure of pointers of items to be sorted.  It has
"	the form:
"		dcl 01 vec aligned,
"		       02 n fixed bin (24),
"		       02 vector (vec.n) ptr unaligned;
"      str_length - data string length for $bit or $char entries.
"      function_name - name of a user defined function which states the
"	relationship between two data items.  It must have the following
"	format:
"	declaration --> declare function entry (ptr unaligned, ptr unaligned)
"			returns (fixed bin (1));
"	usage --> value = function (ptr_1st_item, ptr_2nd_item);
"
"	where:
"	   ptr_1st_item - is an unaligned ptr to the first data item
"	   ptr_2nd_item - is an unaligned ptr to the second data item
"	   value - is the result of comparing the two items.  It can be:
"	      < 0 => first item < second item
"	      >=0 => first item >= second item
""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
"
"the six entries
	 entry fixed_bin,float_bin,char,bit,varying_char,general

"define stack frame temporaries, largest first
	temp8	arg_list_1,arg_list_2,arg_list_3	"area for arg lists
	tempd	arg_list_4		"arg list area, connected to temp8's above
	temp	general_pptr_1,general_pptr_2,general_value	"$general function args
	temp	N_in_upper		"loop index temporary
	temp	error_value		"error value for sub_err_

"define constants for sub_err_ call
total_items_err_msg:
	aci	/Item count outside legal bounds./

string_length_err_msg:
	aci	/Data length ouside legal bounds./

program_name:
	aci	/sort_items_/

sub_err_flag:
	oct	000000000000

fixed_35_desc:
	oct	404000000043

program_name_desc:
	oct	526000000013

sub_err_flag_desc:
	oct	516000000044

ptr_desc:
	oct	464000000000

err_msg_desc:
	oct	526000000040
"
	include	stack_header
"
	include	stack_frame
"
"We use label arrays similar to those used by PL/1 in code generation.
label_vec_A:				"for 1st case statement
	tra  	compare0_A
	tra	compare1_A
	tra	compare2_A
	tra	compare3_A
	tra	compare4_A
	tra	compare5_A

label_vec_B:				"for 2nd case statement
	tra	compare0_B
	tra	compare1_B
	tra	compare2_B
	tra	compare3_B
	tra	compare4_B
	tra	compare5_B

label_vec_C:				"for 3rd case statement
	tra	compare0_C
	tra	compare1_C
	tra	compare2_C
	tra	compare3_C
	tra	compare4_C
	tra	compare5_C

label_vec_D:				"for 4th case statemtent
	tra	compare0_D
	tra	compare1_D
	tra	compare2_D
	tra	compare3_D
	tra	compare4_D
	tra	compare5_D
"
init:					"just a section label
""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
"This is the init section of sort_items_.  Each of the six possible entries
"   pushes a stack frame and sets registers as needed.  The parameters
"   of the entry points are found and put in registers or local storage
"   in order to eliminate the parameter passing mechanisms usually needed
"   for each reference.
"This section also gets and verifies the second parameter of the entries
"   that have one.  The $char and $bit entries put the parameter
"   in $A, WHICH MUST NOT BE CHANGED BY ANY OTHER PART OF THOSE ENTRIES!!
"   The $general entry creates the function argument list and sets $PR0 to
"   point to it, and set $PR2 to point to the function entry value.
"   Register usage is as follows:
"   PR0 -- initially is addr (agrument list)
"	 later has addr (arg_list) {$general entry ONLY!!}
"   PR2 -- function entry ptr {$general entry ONLY!!}
"   PR4 -- addr (linkage section)
"   PR5 -- addr (ptr array base)
"   PR6 -- addr (stack frame)
"   PR7 -- addr (stack base)
"   X7 -- data type as defined by entry point called
"   A -- data string length {$char, $bit entries ONLY!!}
""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
"
"* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
fixed_bin:				"entry (vec_ptr)
	push
	ldx7	1,du			"data type by definition
	tra	common-*,ic		"go get parameter
"* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
float_bin:				"entry (vec_ptr)
	push
	ldx7	2,du			"data type by definition
	tra	common-*,ic		"go get parameter
"* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
char:					"entry (vec_ptr, str_length)
	push
	ldx7	3,du			"data type by definition
	epp1	pr0|4,*			"addr (data string length)
	ldq	pr1|0			"data string length
	tmi	string_length_err-*,ic	"if < 0, got bad arg
	qrs	2			"convert characters to words
	tra	string_length_compare-*,ic	"validate arg
"* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
bit:					"entry (vec_ptr, str_length)
	push
	ldx7	4,du			"data type by definition
	epp1	pr0|4,*			"addr (data string length)
	ldq	pr1|0			"data string length
	tmi	string_length_err-*,ic	"if < 0, got bad arg
	div	36,dl			"convert bits to words
	tra	string_length_compare-*,ic	"validate arg
"* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
varying_char:				"entry (vec_ptr)
	push
	ldx7	5,du			"data type by definition
	tra	common-*,ic		"go get parameter
"* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
general:					"entry (vec_ptr, function)
	push
	ldx7	0,du			"data type by definition
	epp1	pr0|4,*			"addr (addr (entry pair))
	epp2	pr1|2,*			"environment ptr
	spri2	arg_list_2		"store in arg list
	epp2	pr1|0,*			"addr (user function)
	fld	6144,dl			"get arg list header
	ora	8,dl			"call type where environment ptr is used
	staq	arg_list_1		"store arg list header
	epp1	general_value		"addr (return value)
	spri1	arg_list_1+6		"store as 3rd parameter
	epp1	general_pptr_1		"addr (1st packed ptr)
	spri1	arg_list_1+2		"store as 1st parameter
	epp1	general_pptr_2		"addr (2nd packed ptr)
	spri1	arg_list_1+4		"store as 2nd parameter
	tra	common-*,ic		"go get parameter
"
string_length_compare:			"verify string length
	cmpq	sys_info$max_seg_size	"larger than a segment??
	tmoz	length_good-*,ic		"no, set data length

string_length_err:
	epp3	string_length_err_msg-*,ic	"get error message
	spri3	arg_list_2+4		"store in arg list

sub_err_call:
	ldq	error_table_$out_of_bounds	"get error value
	stq	error_value		"save for sub_err_ call
	lda	12,du			"get number of args
	ora	4,dl			"get call type
	ldq	12,du			"get number of descriptors
	staq	arg_list_1		"store arg list header
	epp3	error_value		"addr (error value)
	spri3	arg_list_1+2		"store in arg list
	epp3	program_name-*,ic		"addr (program name)
	spri3	arg_list_1+4		"store in arg list
	epp3	sub_err_flag-*,ic		"addr (sub_err_ flag)
	spri3	arg_list_1+6		"store in arg list
	epp3	pr7|stack_header.parent_ptr	"addr (null ptr)
	spri3	arg_list_2		"store in arg list
	epp3	general_value		"addr (return value)
	stz	pr3|0			"zero return value
	spri3	arg_list_2+2		"store in arg list
	epp3	fixed_35_desc-*,ic		"addr (fixed bin (35) descriptor))
	spri3	arg_list_2+6		"store in arg list
	spri3	arg_list_3+6		"store again for return value
	epp3	program_name_desc-*,ic	"addr (character string descriptor)
	spri3	arg_list_3		"store in arg list
	epp3	sub_err_flag_desc-*,ic	"addr (character string descriptor)
	spri3	arg_list_3+2		"store in arg list
	epp3	ptr_desc-*,ic		"addr (ptr descriptor)
	spri3	arg_list_3+4		"store in arg list
	epp3	err_msg_desc-*,ic		"get error message descriptor
	spri3	arg_list_4		"store in arg list
	call	sub_err_$sub_err_(arg_list_1)	"call sub_err_
	return				"leave program
"
length_good:				"set data length in $A!!
	lda	pr1|0			"get data length

common:					"verify array ptr size is in bounds
	epp5	pr0|2,*			"addr (addr (ptr array base))
	epp5	pr5|0,*			"addr (ptr array base)
	ldq	pr5|0			"number of items to sort
	tmi	items_err-*,ic		"if < 0, got bad arg
	cmpq	sys_info$max_seg_size	"larger than a segment??
	tmi	n_elems_ok-*,ic		"no, continue processing

items_err:				"have error, can't go on
	epp3	total_items_err_msg-*,ic	"get error message
	spri3	arg_list_2+4		"put in arg list
	tra	sub_err_call-*,ic		"report problems

n_elems_ok:
	cmpq	2,dl			"0 or 1 item in array??
	trc	store_vars-*,ic		"no, have to do sort
	return				"yes, sort finished

store_vars: 
	qls	18			"move total items to $QU
	stq	N_in_upper		"store total items count
	cmpx7	0,du			"is it $general entry??
	tnz	fix_heap-*,ic		"no, start sort
	epp0	arg_list_1		"yes, set $PR0 to arg list
"
fix_heap:					"just a section label
""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
"This is the fix_heap section of sort_items_indirect_.  It creates a
"   heap, which is an almost complete binary tree in which each node is
"   less than or equal to its father.  Register usage is as follows:
"   PR0 -- addr (arg_list) {$general entry ONLY!!}
"   PR1 -- right son ptr (if one exists)
"   PR2 -- function entry ptr {$general entry ONLY!!}
"   PR3 -- larger son ptr (initially assumed to be left son)
"   PR4 -- parent ptr
"   PR5 -- addr (ptr array base)
"   PR6 -- addr (stack frame)
"   PR7 -- addr (stack base)
"   X4 -- larger child index (initially assumed to be left son index)
"   X5 -- parent index
"   X6 -- FH_do_i loop control variable
"   X7 -- data type as defined by entry point
"   A -- data string length {$char, $bit entries ONLY!!}
""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""

	ldq	pr5|0			"put total items in $Q
	qrl	1			"divide by shifting bits right
	eax6	0,ql			"load loop start value from $Q
	tra	FH_loop_start-*,ic		"goto loop start

FH_do_i:					"start of do i loop, or
compareB_else:				"no switch was made this time, or
FH_do_while_end:				"do while done, try do i again
	sprp4	pr5|0,x5			"son ptr = parent ptr
	sblx6	1,du			"decrement loop index by 1

FH_loop_start:
	tze	sort_heap-*,ic		"loop finished, go to sort_heap
	eax5	0,x6			"loop index is parent index
	lprp4	pr5|0,x5			"get parent ptr

FH_do_while:				"walk parent branch, swap up if son > parent
	eaq	0,x5			"put parent index in $Q
	qls	1			"*2, gives left son index
	eax4	0,qu			"assume left son is larger
	cmpx4	N_in_upper		"is left son index <= ptr array bound??
	tnc	FH_two_sons-*,ic		"have two sons
	tnz	FH_do_while_end-*,ic	"too big, try do i loop again
	lprp3	pr5|0,x4			"get left son ptr
	tra	label_vec_B,x7*		"find larger of son and parent

FH_two_sons:
	lprp3	pr5|0,x4			"get left son ptr
	lprp1	pr5|1,x4			"get right son ptr
	tra	label_vec_A,x7*		"find larger of sons
"
compare0_A:				"for $general entry
	sprp3	general_pptr_1		"store left son ptr
	sprp1	general_pptr_2		"store right son ptr
	"call pseudo-op simulated to call function
	spri	pr6|0			"save all PR's
	sreg	pr6|stack_frame.regs	"save rest of registers
	tsp4	pr7|stack_header.call_op_ptr,*     "use stack header ptr to call
	lpri	pr6|0			"reclaim our PR's
	lreg	pr6|stack_frame.regs	"reclaim rest of registers
	"test function return value
	szn	general_value		"is left son data < right son data??
	tpl	compare0_B-*,ic		"no, left son is larger
	adlx4	1,du			"larger son index = right son index
	epp3	pr1|0			"larger son ptr = right son ptr

compare0_B:				"for $general entry
	sprp4	general_pptr_1		"store parent ptr
	sprp3	general_pptr_2		"store son ptr
	"call pseudo-op simulated to call function
	spri	pr6|0			"save all PR's
	sreg	pr6|stack_frame.regs	"save rest of registers
	tsp4	pr7|stack_header.call_op_ptr,*     "use stack header ptr to call
	lpri	pr6|0			"reclaim our PR's
	lreg	pr6|stack_frame.regs	"reclaim rest of registers
	"test function return value
	szn	general_value		"is parent data < son data??
	tpl	compareB_else-*,ic		"no, parent is larger
	sprp3	pr5|0,x5			"parent ptr = son ptr
	eax5	0,x4			"parent index = son index
	tpl	FH_do_while-*,ic		"compare parent with new sons
	tra	FH_do_while_end-*,ic	"if bit 0 on, parent index *2 BIG, quit
"
compare1_A:				"for $fixed_bin entry
	ldq	pr3|0			"left son data
	cmpq	pr1|0			"is left son data < right son data??
	tpl	compare1_B-*,ic		"no, left son is larger
	adlx4	1,du			"larger son index = right son index
	epp3	pr1|0			"larger son ptr = right son ptr

compare1_B:				"for $fixed_bin entry
	ldq	pr4|0			"parent data
	cmpq	pr3|0			"is parent data < son data??
	tpl	compareB_else-*,ic		"no, parent is larger
	sprp3	pr5|0,x5			"parent ptr = son ptr
	eax5	0,x4			"parent index = son index
	tpl	FH_do_while-*,ic		"compare parent with new sons
	tra	FH_do_while_end-*,ic	"if bit 0 on, parent index *2 BIG, quit
"
compare2_A:				"for $float_bin entry
	dfld	pr3|0			"left son data
	dfcmp	pr1|0			"is left son data < right son data??
	tpl	compare2_B-*,ic		"no, left son is larger
	adlx4	1,du			"larger son index = right son index
	epp3	pr1|0			"larger son ptr = right son ptr

compare2_B:				"for $float_bin entry
	dfld	pr4|0			"parent data
	dfcmp	pr3|0			"is parent data < son data??
	tpl	compareB_else-*,ic		"no, parent is larger
	sprp3	pr5|0,x5			"parent ptr = son ptr
	eax5	0,x4			"parent index = son index
	tpl	FH_do_while-*,ic		"compare parent with new sons
	tra	FH_do_while_end-*,ic	"if bit 0 on, parent index *2 BIG, quit
"
compare3_A:				"for $char entry
	"N. B. data string length is in $A, DO NOT DESTROY!!
	cmpc	(pr,rl),(pr,rl),fill(040)	"compare two strings
	  desc9a	pr3|0,al			"left son data
	  desc9a	pr1|0,al			"right son data
	trc	compare3_B-*,ic		"left son is larger
	adlx4	1,du			"larger son index = right son index
	epp3	pr1|0			"larger son ptr = right son ptr

compare3_B:				"for $char entry
	"N. B. data string length is in $A, DO NOT DESTROY!!
	cmpc	(pr,rl),(pr,rl),fill(040)	"compare two strings
	  desc9a	pr4|0,al			"parent data
	  desc9a	pr3|0,al			"son data
	trc	compareB_else-*,ic		"parent is larger
	sprp3	pr5|0,x5			"parent ptr = son ptr
	eax5	0,x4			"parent index = son index
	tpl	FH_do_while-*,ic		"compare parent with new sons
	tra	FH_do_while_end-*,ic	"if bit 0 on, parent index *2 BIG, quit
"
compare4_A:				"for $bit entry
	"N. B. data string length is in $A, DO NOT DESTROY!!
	cmpb	(pr,rl),(pr,rl),fill(0)	"compare two bit strings
	  descb	pr3|0,al			"left son data
	  descb	pr1|0,al			"right son data
	trc	compare4_B-*,ic		"left son is larger
	adlx4	1,du			"larger son index = right son index
	epp3	pr1|0			"larger son ptr = right son ptr

compare4_B:				"for $bit entry
	"N. B. data string length is in $A, DO NOT DESTROY!!
	cmpb	(pr,rl),(pr,rl),fill(0)	"compare two bit strings
	  descb	pr4|0,al			"parent data
	  descb	pr3|0,al			"son data
	trc	compareB_else-*,ic		"parent is larger
	sprp3	pr5|0,x5			"parent ptr = son ptr
	eax5	0,x4			"parent index = son index
	tpl	FH_do_while-*,ic		"compare parent with new sons
	tra	FH_do_while_end-*,ic	"if bit 0 on, parent index *2 BIG, quit
"
compare5_A:				"for $varying_char entry
	lda	pr3|0			"left son data length
	ldq	pr1|0			"right son data length
	cmpc	(pr,rl),(pr,rl),fill(040)	"compare two strings
	  desc9a	pr3|1,al			"left son data
	  desc9a	pr1|1,ql			"right son data
	trc	compare5_B-*,ic		"left son is larger
	adlx4	1,du			"larger son index = right son index
	epp3	pr1|0			"larger son ptr = right son ptr

compare5_B:				"for $varying_char entry
	lda	pr4|0			"parent data length
	ldq	pr3|0			"son data length
	cmpc	(pr,rl),(pr,rl),fill(040)	"compare the two strings
	  desc9a	pr4|1,al			"parent data
	  desc9a	pr3|1,ql			"son data
	trc	compareB_else-*,ic		"parent is larger
	sprp3	pr5|0,x5			"parent ptr = son ptr
	eax5	0,x4			"parent index = son index
	tpl	FH_do_while-*,ic		"compare parent with new sons
	tra	FH_do_while_end-*,ic	"if bit 0 on, parent index *2 BIG, quit
"
sort_heap:				"just a program label
""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
"This is the sort_heap section of sort_items_.  It sorts the heap by
"   putting the root node value in its proper place and adjusting the
"   remaining heap, producing a new root node value.  Register
"   usage is as follows:
"   PR0 -- addr (arg_list) {$general entry ONLY!!}
"   PR1 -- right son ptr (if one exists)
"   PR2 -- function entry ptr {$general entry ONLY!!}
"   PR3 -- larger son ptr for compare C (initially assumed to be left son)
"	 parent ptr for compare D
"   PR3 -- larger son ptr (initially assumed to be left son)
"   PR4 -- last leaf ptr
"   PR5 -- addr (ptr array base)
"   PR6 -- addr (stack frame)
"   PR7 -- addr (stack base)
"   X4 -- larger child index (initially assumed to be left son index)
"   X5 -- parent index
"   X6 -- SH_do_i loop control variable
"   X7 -- data type as defined by entry point
"   A -- data string length {$char, $bit entries ONLY!!}
""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
"
	ldx6	N_in_upper		"put total items in loop counter
	tra	SH_loop_start-*,ic		"goto loop start

SH_do_i:					"start of do i loop, or
compareD_then:				"finished backing up tree, or
SH_do_while_end:				"do while done, try do i again
	sprp4	pr5|0,x4			"son ptr = last leaf ptr

SH_loop_start:
	sblx6	1,du			"decrement loop index by 1
	tze	sort_end-*,ic		"loop done, goto sort_end
	stx6	N_in_upper		"store counter index bound
	lprp4	pr5|1,x6			"get last leaf ptr
	ldq	pr5|1			"get root ptr
	stq	pr5|1,x6			"last leaf storage = root ptr
	ldx5	1,du			"parent index = 1

SH_do_while:				"walk tree, swap up if son > last leaf
	eaq	0,x5			"put parent index in $Q
	qls	1			"multiply by 2
	eax4	0,qu			"put in larger child index
	cmpx4	N_in_upper		"is larger son index <= loop index??
	tnc	SH_two_sons-*,ic		"have two sons
	tze	SH_one_son-*,ic		"have one son
	eax4	0,x5			"too big, get old value
	tra	label_vec_D,x7*		"go back up tree

SH_two_sons:
	lprp3	pr5|0,x4			"get left son ptr
	lprp1	pr5|1,x4			"get right son ptr
	tra	label_vec_C,x7*		"find larger of sons

SH_one_son:
	lprp3	pr5|0,x4			"get larger son ptr
	sprp3	pr5|0,x5			"parent ptr = son ptr
	eax5	0,x4			"parent index = son index
	tpl	SH_do_while-*,ic		"compare parent with new sons
	tra	label_vec_D,x7*		"else go back up tree
"
compare0_C:				"for $general entry
	sprp3	general_pptr_1		"left son ptr
	sprp1	general_pptr_2		"right son ptr
	"call pseudo-op simulated to call function
	spri	pr6|0			"save all PR's
	sreg	pr6|stack_frame.regs	"save rest of registers
	tsp4	pr7|stack_header.call_op_ptr,*     "use stack header ptr to call
	lpri	pr6|0			"reclaim our PR's
	lreg	pr6|stack_frame.regs	"reclaim rest of registers
	"test function return value
	szn	general_value		"is left son data < right son data??
	tpl	assignment0_C-*,ic		"no, left son is larger
	adlx4	1,du			"larger son index = right son index
	epp3	pr1|0			"larger son ptr = right son ptr

assignment0_C:
	sprp3	pr5|0,x5			"parent ptr = son ptr
	eax5	0,x4			"parent index = son index
	tpl	SH_do_while-*,ic		"compare parent with new sons

compare0_D:				"for $general entry
	eaq	0,x4			"put son index in $Q
	qrl	1			"divide by shifting bits right
	eax5	0,qu			"put in parent index
	tze	compareD_then-*,ic		"if = 0, try do i loop again
	lprp3	pr5|0,x5			"get parent ptr
	sprp3	general_pptr_1		"set parent ptr
	sprp4	general_pptr_2		"set last leaf ptr
	"call pseudo-op simulated to call function
	spri	pr6|0			"save all PR's
	sreg	pr6|stack_frame.regs	"save rest of registers
	tsp4	pr7|stack_header.call_op_ptr,*     "use stack header ptr to call
	lpri	pr6|0			"reclaim our PR's
	lreg	pr6|stack_frame.regs	"reclaim rest of registers
	"test function return value
	szn	general_value		"is parent data < last leaf data??
	tpl	compareD_then-*,ic		"no, parent is larger
	sprp3	pr5|0,x4			"son ptr = parent ptr
	eax4	0,x5			"son index = parent index
	tra	compare0_D-*,ic		"go back up tree
"
compare1_C:				"for $fixed_bin entry
	ldq	pr3|0			"left son data
	cmpq	pr1|0			"is left son data < right son data??
	tpl	assignment1_C-*,ic		"left son is larger
	adlx4	1,du			"larger son index = right son index
	epp3	pr1|0			"larger son ptr = right son ptr

assignment1_C:
	sprp3	pr5|0,x5			"parent ptr = son ptr
	eax5	0,x4			"parent index = son index
	tpl	SH_do_while-*,ic		"compare parent with new sons

compare1_D:				"for $fixed_bin entry
	eaq	0,x4			"put son index in $Q
	qrl	1			"divide by shifting bits right
	eax5	0,qu			"put in parent index
	tze	compareD_then-*,ic		"if = 0, try do i loop again
	lprp3	pr5|0,x5			"get parent ptr
	ldq	pr3|0			"parent data
	cmpq	pr4|0			"is parent data < last leaf data??
	tpl	compareD_then-*,ic		"no, parent is larger
	sprp3	pr5|0,x4			"son ptr = parent ptr
	eax4	0,x5			"son index = parent index
	tra	compare1_D-*,ic		"go back up tree
"
compare2_C:				"for $float_bin entry
	dfld	pr3|0			"left son data
	dfcmp	pr1|0			"is left son data < right son data??
	tpl	assignment2_C-*,ic		"no, left son is larger
	adlx4	1,du			"larger son index = right son index
	epp3	pr1|0			"larger son ptr = right son ptr

assignment2_C:
	sprp3	pr5|0,x5			"parent ptr = son ptr
	eax5	0,x4			"parent index = son index
	tpl	SH_do_while-*,ic		"compare parent with new sons

compare2_D:				"for $float_bin entry
	eaq	0,x4			"put son index in $Q
	qrl	1			"divide by shifting bits right
	eax5	0,qu			"put in parent index
	tze	compareD_then-*,ic		"if = 0, try do i loop again
	lprp3	pr5|0,x5			"get parent ptr
	dfld	pr3|0			"parent data
	dfcmp	pr4|0			"is parent data < last leaf data??
	tpl	compareD_then-*,ic		"no, parent is larger
	sprp3	pr5|0,x4			"son index = parent index
	eax4	0,x5			"son index = parent index
	tra	compare2_D-*,ic		"go back up tree
"
compare3_C:				"for $char entry
	"N. B. data string length is in $A, DO NOT DESTROY!!
	cmpc	(pr,rl),(pr,rl),fill(040)	"compare two strings
	  desc9a	pr3|0,al			"left son data
	  desc9a	pr1|0,al			"right son data
	trc	assignment3_C-*,ic		"left son is larger
	adlx4	1,du			"larger son index = right son index
	epp3	pr1|0			"larger son ptr = right son ptr

assignment3_C:
	sprp3	pr5|0,x5			"parent ptr = son ptr
	eax5	0,x4			"parent index = son index
	tpl	SH_do_while-*,ic		"compare parent with new sons

compare3_D:				"for $char entry
	eaq	0,x4			"put son index in $Q
	qrl	1			"divide by shifting bits right
	eax5	0,qu			"put in parent index
	tze	compareD_then-*,ic		"if = 0, try do i loop again
	lprp3	pr5|0,x5			"get parent ptr
	"N. B. data string length is in $A, DO NOT DESTROY!!
	cmpc	(pr,rl),(pr,rl),fill(040)	"compare two strings
	  desc9a	pr3|0,al			"parent data
	  desc9a	pr4|0,al			"last leaf data
	trc	compareD_then-*,ic		"parent is larger
	sprp3	pr5|0,x4			"son ptr = parent ptr
	eax4	0,x5			"son index = parent index
	tra	compare3_D-*,ic		"go back up tree
"
compare4_C:				"for $bit entry
	"N. B. data string length is in $A, DO NOT DESTROY!!
	cmpb	(pr,rl),(pr,rl),fill(0)	"compare two bit strings
	  descb	pr3|0,al			"left son data
	  descb	pr1|0,al			"right son data
	trc	assignment4_C-*,ic		"left son is larger
	adlx4	1,du			"larger son index = right son index
	epp3	pr1|0			"larger son ptr = right son ptr

assignment4_C:
	sprp3	pr5|0,x5			"parent ptr = son ptr
	eax5	0,x4			"parent index = son index
	tpl	SH_do_while-*,ic		"compare parent with new sons

compare4_D:				"for $bit entry
	eaq	0,x4			"put son index in $Q
	qrl	1			"divide by shifting bits right
	eax5	0,qu			"put in parent index
	tze	compareD_then-*,ic		"if = 0, try do i loop again
	lprp3	pr5|0,x5			"get parent ptr
	"N. B. data string length is in $A, DO NOT DESTROY!!
	cmpb	(pr,rl),(pr,rl),fill(0)	"compare two bit strings
	  descb	pr3|0,al			"parent data
	  descb	pr4|0,al			"last leaf data
	trc	compareD_then-*,ic		"parent is larger
	sprp3	pr5|0,x4			"son ptr = parent ptr
	eax4	0,x5			"son index = parent index
	tra	compare4_D-*,ic		"go back up tree
"
compare5_C:				"for $varying_char entry
	lda	pr3|0			"left son data length
	ldq	pr1|0			"right son data length
	cmpc	(pr,rl),(pr,rl),fill(040)	"compare two strings
	  desc9a	pr3|1,al			"left son data
	  desc9a	pr1|1,ql			"right son data
	trc	assignment5_C-*,ic		"left son is larger
	adlx4	1,du			"larger son index = right son index
	epp3	pr1|0			"larger son ptr = right son ptr

assignment5_C:
	sprp3	pr5|0,x5			"parent ptr = son ptr
	eax5	0,x4			"parent index = son index
	tpl	SH_do_while-*,ic		"compare parent with new sons

compare5_D:				"for $varying_char entry
	eaq	0,x4			"put son index in $Q
	qrl	1			"divide by shifting bits right
	eax5	0,qu			"put in parent index
	tze	compareD_then-*,ic		"if = 0, try do i loop again
	lprp3	pr5|0,x5			"get parent ptr
	lda	pr3|0			"parent data length
	ldq	pr4|0			"last leaf data length
	cmpc	(pr,rl),(pr,rl),fill(040)	"compare two strings
	  desc9a	pr3|1,al			"parent data
	  desc9a	pr4|1,ql			"last leaf data
	trc	compareD_then-*,ic		"parent is larger
	sprp3	pr5|0,x4			"son ptr = parent ptr
	eax4	0,x5			"son index = parent index
	tra	compare5_D-*,ic		"go back up tree

sort_end:					"sort finished, go home
	return
	end				"program done




		    sort_items_indirect_.alm        11/05/86  1304.4r w 11/04/86  1037.9      303750



" **********************************************************************
" *                                                                    *
" * This is in the PUBLIC DOMAIN and may be copied without permission. *
" *                                                                    *
" **********************************************************************
sort_items_indirect_:			"just a program label

	name sort_items_indirect_		"define objectname

""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
"sort_items_indirect_.alm is an adapted descendant of sort_items_.alm,
"   written at AFDSC/CMMS.  The program provides a generalized facility for
"   sorting data items based on a field that resides at varying offsets
"   from the beginning of the item.  It uses a vector of indices of the
"   items to be sorted and a vector of unaligned pointers to the fields
"   on which to perform the sort.  The program sorts the indices,
"   leaving the pointers and information untouched.  This program is
"   written to replace the system program sort_items_indirect_.  Entry
"   points are identical, with only the algorithm changed.
"The outstanding feature of sort_items_indirect_.alm is its heavy dependence
"   on hardware registers as program storage.  This reduces the necessity
"   to access main memory and allows the program to operate more directly
"   on the hardware.
"The algorithm used by the program is the heapsort algorithm as stated by
"   Knuth's "The Art of Computer Programming", (vol. 3, pp 146-147) with
"   the modification suggested in Exercise 18 (problem pg 158, answer pg 618).
"There are three major coding sections: init, fix_heap, and sort_heap.
"   Each section will document current register usage.
"The maximum number of data items is 261119!!

"Written March 1982 @ AFDSC/CMMS by LT F. Patrick Clark, USAF and
"   Lee A. Newcomb, HISI.
"Modified April, 1983 by LT F. Patrick Clark (AFDSC/CMMS) to change
"   sub_err_ flag parameter, fix bugs in $general entry handling and
"   index array initialization and clean up documentation.
""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
"
""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
"ENTRIES:
"   1) sort_items_indirect_$fixed_bin - sorts fixed bin (35) numbers
"   declaration --> declare sort_items_indirect_$fixed_bin entry (ptr, ptr);
"   usage --> call sort_items_indirect_$fixed_bin (vec_ptr, ind_ptr);
"
"   2) sort_items_indirect_$float_bin - sorts float bin (63) numbers
"   declaration --> declare sort_items_indirect_$float_bin entry (ptr, ptr);
"   usage --> call sort_items_indirect_$float_bin (vec_ptr, ind_ptr);
"
"   3) sort_items_indirect_$char - sorts nonvarying character strings
"   declaration --> declare sort_items_indirect_$char entry (ptr, ptr, fixed bin (24));
"   usage --> call sort_items_indirect_$char (vec_ptr, ind_ptr, str_length);
"
"   4) sort_items_indirect_$bit - sorts nonvarying bit strings
"   declaration --> declare sort_items_indirect_$bit entry (ptr, ptr, fixed bin (24));
"   usage --> call sort_items_indirect_$bit (vec_ptr, ind_ptr, str_length);
"
"   5) sort_items_indirect_$varying_char -- sorts varying character strings
"   declaration --> declare sort_items_indirect_$varying_char entry (ptr, ptr);
"   usage --> call sort_items_indirect_$varying_char (vec_ptr, ind_ptr);
"
"   6) sort_items_indirect_$adj_char -- sorts varying length character strings based
"		on array of string lengths
"   declaration --> declare sort_items_indirect_$adj_char entry (ptr, ptr, ptr);
"   usage --> call sort_items_indirect_$adj_char (vec_ptr, ind_ptr, len_ptr);
"
"   7) sort_items_indirect_$general -- sorts items based on a user defined function
"   declaration --> declare sort_items_indirect_$general entry (ptr, ptr, entry);
"   usage --> call sort_items_indirect_$general (vec_ptr, ind_ptr, function_name);
"
"   where:
"      vec_ptr - points to a structure of pointers of items to be sorted.  It has
"	the form:
"		dcl 01 vec aligned,
"		       02 n fixed bin (24),
"		       02 vector (vec.n) ptr unaligned;
"      ind_ptr - points to a structure of indices of the items to be sorted.  It has
"	the form:
"		dcl 01 ind aligned,
"		       02 n fixed bin (24),
"		       02 index (vec.n) fixed bin (24);
"      len_ptr - points to a structure of lengths of unaligned character strings to be sorted.
"	It has the form:
"		dcl 01 len aligned,
"		       02 n fixed bin (24),
"		       02 length (vec.n) fixed bin (24);
"      str_length - data string length for $bit or $char entries.
"      function_name - name of a user defined function which states the
"	relationship between two data items.  It must have the following
"	format:
"	declaration --> declare function entry (ptr unaligned, ptr unaligned)
"			returns (fixed bin (1));
"	usage --> value = function (ptr_1st_item, ptr_2nd_item);
"
"	where:
"	   ptr_1st_item - is an unaligned ptr to the first data item
"	   ptr_2nd_item - is an unaligned ptr to the second data item
"	   value - is the result of comparing the two items.  It can be:
"	      < 0 => first item < second item
"	      >=0 => first item >= second item
""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
"
"the seven entries
	 entry fixed_bin,float_bin,char,bit,varying_char,adj_char,general

"define stack frame temporaries, largest first
	temp8	arg_list_1,arg_list_2,arg_list_3	"area for arg lists
	tempd	arg_list_4		"arg list area, connected to temp8's above
	temp	general_pptr_1,general_pptr_2,general_value	"$general function args
	temp	N_in_upper,N_in_lower	"temporaries
	temp	error_value		"error value for sub_err_

"define constants for sub_err_ call
total_items_err_msg:
	aci	/Item count outside legal bounds./

string_length_err_msg:
	aci	/Data length ouside legal bounds./

program_name:
	aci	/sort_items_/

sub_err_flag:
	oct	000000000000

fixed_35_desc:
	oct	404000000043

program_name_desc:
	oct	526000000013

sub_err_flag_desc:
	oct	516000000044

ptr_desc:
	oct	464000000000

err_msg_desc:
	oct	526000000040
"
	include	stack_header
"
	include	stack_frame
"
"We use label arrays similar to those used by PL/1 in code generation.
label_vec_A:				"for 1st case statement
	tra  	compare0_A
	tra	compare1_A
	tra	compare2_A
	tra	compare3_A
	tra	compare4_A
	tra	compare5_A
	tra	compare6_A

label_vec_B:				"for 2nd case statement
	tra	compare0_B
	tra	compare1_B
	tra	compare2_B
	tra	compare3_B
	tra	compare4_B
	tra	compare5_B
	tra	compare6_B

label_vec_C:				"for 3rd case statement
	tra	compare0_C
	tra	compare1_C
	tra	compare2_C
	tra	compare3_C
	tra	compare4_C
	tra	compare5_C
	tra	compare6_C

label_vec_D:				"for 4th case statemtent
	tra	compare0_D
	tra	compare1_D
	tra	compare2_D
	tra	compare3_D
	tra	compare4_D
	tra	compare5_D
	tra	compare6_D
"
init:					"just a section label
""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
"This is the init section of sort_items_indirect_.  Each of the seven entries
"   pushes a stack frame and sets registers as needed.  The parameters
"   of the entry points are found and put in registers or local storage
"   in order to eliminate the parameter passing mechanisms usually needed
"   for each reference.
"This section also gets and verifies the third parameter of the entries
"   that have one.  The $char and $bit entries put the parameter in $A,
"   WHICH MUST NOT BE CHANGED BY ANY OTHER PART OF THOSE ENTRIES!!  The
"   $general entry creates the function argument list and sets $PR0 to
"   point to it, and sets $PR2 to point to the function entry value.  The
"   $adj_char entry sets $PR2 to point to the character string length base.
"   Register usage is as follows:
"   PR0 -- initially is addr (agrument list)
"	 later has addr (arg_list) {$general entry ONLY!!}
"   PR2 -- function entry ptr {$general entry ONLY!!}
"	 addr (adjustable length array base) {$adj_char entry ONLY!!}
"   PR4 -- addr (linkage section)
"   PR5 -- addr (ptr array base)
"   PR6 -- addr (stack frame)
"   PR7 -- initially is addr (stack base)
"	 later has addr (vector array base)
"   X7 -- data type as defined by entry point called
"   A -- data string length {$char, $bit entries ONLY!!}
""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""

"* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
fixed_bin:				"entry (vec_ptr, index_ptr)
	push
	ldx7	1,du			"data type by definition
	tra	common-*,ic		"go get parameters
"* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
float_bin:				"entry (vec_ptr, index_ptr)
	push
	ldx7	2,du			"data type by definition
	tra	common-*,ic		"go get parameters
"* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
char:					"entry (vec_ptr, index_ptr, str_length)
	push
	ldx7	3,du			"data type by definition
	epp1	pr0|6,*			"addr (data string length)
	ldq	pr1|0			"data string length
	tmi	string_length_err-*,ic	"if < 0, got bad arg
	qrs	2			"convert characters to words
	tra	string_length_compare-*,ic	"validate arg
"* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
"
bit:					"entry (vec_ptr, index_ptr, str_length)
	push
	ldx7	4,du			"data type by definition
	epp1	pr0|6,*			"addr (data string length)
	ldq	pr1|0			"data string length
	tmi	string_length_err-*,ic	"if < 0, got bad arg
	div	36,dl			"convert bits to words
	tra	string_length_compare-*,ic	"validate arg
"* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
varying_char:				"entry (vec_ptr, index_ptr)
	push
	ldx7	5,du			"data type by definition
	tra	common-*,ic		"go get parameters
"* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
adj_char:					"entry (vec_ptr, index_ptr, length_ptr)
	push
	ldx7	6,du			"data type by definition
	epp1	pr0|6,*			"addr (addr (adjustable length array base))
	epp2	pr1|0,*			"addr (adjustable length array base)
	tra	common-*,ic		"go get parameters
"* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
general:					"entry (vec_ptr, index_ptr, function)
	push
	ldx7	0,du			"data type by definition
	epp1	pr0|6,*			"addr (addr (entry pair))
	epp2	pr1|2,*			"environment ptr
	spri2	arg_list_2		"store in arg list
	epp2	pr1|0,*			"addr (user function)
	fld	6144,dl			"get arg list header
	ora	8,dl			"call type where environment ptr is used
	staq	arg_list_1		"store arg list header
	epp1	general_value		"addr (return value)
	spri1	arg_list_1+6		"store as 3rd parameter
	epp1	general_pptr_1		"addr (1st packed ptr)
	spri1	arg_list_1+2		"store as 1st parameter
	epp1	general_pptr_2		"addr (2nd packed ptr)
	spri1	arg_list_1+4		"store as 2nd parameter
	tra	common-*,ic		"go get parameter
"
string_length_compare:			"verify string length
	cmpq	sys_info$max_seg_size	"larger than a segment??
	tmoz	length_good-*,ic		"no, set data length

string_length_err:
	epp3	string_length_err_msg-*,ic	"get error message
	spri3	arg_list_2+4		"store in arg list

sub_err_call:
	ldq	error_table_$out_of_bounds	"get error value
	stq	error_value		"save for sub_err_ call
	lda	12,du			"get number of args
	ora	4,dl			"get call type
	ldq	12,du			"get number of descriptors
	staq	arg_list_1		"store arg list header
	epp3	error_value		"addr (error value)
	spri3	arg_list_1+2		"store in arg list
	epp3	program_name-*,ic		"addr (program name)
	spri3	arg_list_1+4		"store in arg list
	epp3	sub_err_flag-*,ic		"addr (sub_err_ flag)
	spri3	arg_list_1+6		"store in arg list
	epp3	pr7|stack_header.parent_ptr	"addr (null ptr)
	spri3	arg_list_2		"store in arg list
	epp3	general_value		"addr (return value)
	stz	pr3|0			"zero return value
	spri3	arg_list_2+2		"store in arg list
	epp3	fixed_35_desc-*,ic		"addr (fixed bin (35) descriptor))
	spri3	arg_list_2+6		"store in arg list
	spri3	arg_list_3+6		"store again for return value
	epp3	program_name_desc-*,ic	"addr (character string descriptor)
	spri3	arg_list_3		"store in arg list
	epp3	sub_err_flag_desc-*,ic	"addr (character string descriptor)
	spri3	arg_list_3+2		"store in arg list
	epp3	ptr_desc-*,ic		"addr (ptr descriptor)
	spri3	arg_list_3+4		"store in arg list
	epp3	err_msg_desc-*,ic		"get error message descriptor
	spri3	arg_list_4		"store in arg list
	call	sub_err_$sub_err_(arg_list_1)	"call sub_err_
	return				"leave program
"
length_good:				"set data length in $A!!
	lda	pr1|0			"get data length

common:					"verify array ptr size is in bounds
	epp5	pr0|2,*			"addr (addr (ptr array base))
	epp5	pr5|0,*			"addr (ptr array base)
	ldq	pr5|0			"number of items to sort
	tmi	items_err-*,ic		"if < 0, got bad arg
	cmpq	sys_info$max_seg_size	"larger than a segment??
	tmi	n_elems_ok-*,ic		"no, continue processing

items_err:				"have error, can't go on
	epp3	total_items_err_msg-*,ic	"get error message
	spri3	arg_list_2+4		"put in arg list
	tra	sub_err_call-*,ic		"report problems

n_elems_ok:
	stq	N_in_lower		"store total items count
	epp7	pr0|4,*			"addr (addr (vector array base))
	epp7	pr7|0,*			"addr (vector array base)
	stq	pr7|0			"total indices = total items
	cmpx7	6,du			"is it $adj_char entry??
	tnz	reset_count-*,ic		"no, initialize index array
	stq	pr2|0			"total adjustable lengths = total items

reset_count:
	ldq	N_in_lower		"set indicators
	tze	no_sort-*,ic		"if = 0, done

init_index_array:
	stq	pr7|0,ql			"set sort index
	sbq	1,dl			"decrement index by 1
	tnz	init_index_array-*,ic	"try again
	ldq	N_in_lower		"set item count
	cmpq	2,dl			"0 or 1 item in array??
	trc	store_vars-*,ic		"no, have to do sort

no_sort:					"see if we need to do sort
	epbp7	pr6|0			"set $PR7 for return
	return				"yes, sort finished

store_vars: 
	qls	18			"move total items to $QU
	stq	N_in_upper		"store total items count
	cmpx7	0,du			"is it $general entry??
	tnz	fix_heap-*,ic		"no, start sort
	epp0	arg_list_1		"yes, set $PR0 to arg list
"
fix_heap:					"just a section label
""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
"This is the fix_heap section of sort_items_indirect_.  It creates a
"   heap, which is an almost complete binary tree in which each node is
"   less than or equal to its father.  Register usage is as follows:
"   PR0 -- addr (arg_list) {$general entry ONLY!!}
"   PR1 -- right son ptr (if one exists)
"   PR2 -- function entry ptr {$general entry ONLY!!}
"	 addr (adjustable length array base) {$adj_char entry ONLY!!}
"   PR3 -- larger son ptr (initially assumed to be left son)
"   PR4 -- parent ptr
"   PR5 -- addr (ptr array base)
"   PR6 -- addr (stack frame)
"   PR7 -- addr (vector array base)
"	 is temporarily set to addr (stack base) for calls {$general ONLY!!}
"   X1 -- right son vector (if one exists)
"   X2 -- larger son vector (initially assumed to be left son)
"   X3 -- parent vector
"   X4 -- larger child index (initially assumed to be left son index)
"   X5 -- parent index
"   X6 -- FH_do_i loop control variable
"   X7 -- data type as defined by entry point
"   A -- data string length {$char, $bit entries ONLY!!}
""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
"
	ldq	N_in_lower		"put total items in $Q
	qrl	1			"divide by shifting bits right
	eax6	0,ql			"load loop start value from $Q
	tra	FH_loop_start-*,ic		"goto loop start

FH_do_i:					"start of do i loop, or
compareB_else:				"no switch was made this time, or
FH_do_while_end:				"do while done, try do i again
	sxl3	pr7|0,x5			"son vector = parent vector
	sblx6	1,du			"decrement loop index by 1

FH_loop_start:
	tze	sort_heap-*,ic		"loop finished, go to sort_heap
	eax5	0,x6			"loop index is parent index
	lxl3	pr7|0,x5			"get parent vector
	lprp4	pr5|0,x3			"get parent ptr

FH_do_while:				"walk parent branch, swap up if son > parent
	eaq	0,x5			"put parent index in $Q
	qls	1			"*2, gives left son index
	eax4	0,qu			"assume left son is larger
	cmpx4	N_in_upper		"is left son index <= ptr array bound??
	tnc	FH_two_sons-*,ic		"have two sons
	tnz	FH_do_while_end-*,ic	"too big, try do i again
	lxl2	pr7|0,x4			"get left son vector
	lprp3	pr5|0,x2			"get left son ptr
	tra	label_vec_B,x7*		"find larger of son and parent

FH_two_sons:
	lxl2	pr7|0,x4			"get left son vector
	lprp3	pr5|0,x2			"get left son ptr
	lxl1	pr7|1,x4			"get right son vector
	lprp1	pr5|0,x1			"get right son ptr
	tra	label_vec_A,x7*		"find larger of sons
"
compare0_A:				"for $general entry
	sprp3	general_pptr_1		"store left son ptr
	sprp1	general_pptr_2		"store right son ptr
	"call pseudo-op simulated to call function
	spri	pr6|0			"save all PR's
	sreg	pr6|stack_frame.regs	"save rest of registers
	epbp7	pr6|0			"make $PR7 point to stack base
	tsp4	pr7|stack_header.call_op_ptr,*     "use stack header ptr to call
	lpri	pr6|0			"reclaim our PR's
	lreg	pr6|stack_frame.regs	"reclaim rest of registers
	"test function return value
	szn	general_value		"is left son data < right son data??
	tpl	compare0_B-*,ic		"no, left son is larger
	adlx4	1,du			"larger son index = right son index
	eax2	0,x1			"larger son vector = right son vector
	epp3	pr1|0			"larger son ptr = right son ptr

compare0_B:				"for $general entry
	sprp4	general_pptr_1		"store parent ptr
	sprp3	general_pptr_2		"store son ptr
	"call pseudo-op simulated to call function
	spri	pr6|0			"save all PR's
	sreg	pr6|stack_frame.regs	"save rest of registers
	epbp7	pr6|0			"make $PR7 point to stack base
	tsp4	pr7|stack_header.call_op_ptr,*     "use stack header ptr to call
	lpri	pr6|0			"reclaim our PR's
	lreg	pr6|stack_frame.regs	"reclaim rest of registers
	"test function return value
	szn	general_value		"is parent data < son data??
	tpl	compareB_else-*,ic		"no, parent is larger
	sxl2	pr7|0,x5			"parent vector = son vector
	eax5	0,x4			"parent index = son index
	tpl	FH_do_while-*,ic		"compare parent with new sons
	tra	FH_do_while_end-*,ic	"if bit 0 on, parent index *2 BIG, quit
"
compare1_A:				"for $fixed_bin entry
	ldq	pr3|0			"left son data
	cmpq	pr1|0			"is left son data < right son data??
	tpl	compare1_B-*,ic		"no, left son is larger
	adlx4	1,du			"larger son index = right son index
	eax2	0,x1			"larger son vector = right son vector
	epp3	pr1|0			"larger son ptr = right son ptr

compare1_B:				"for $fixed_bin entry
	ldq	pr4|0			"parent data
	cmpq	pr3|0			"is parent data < son data??
	tpl	compareB_else-*,ic		"no, parent is larger
	sxl2	pr7|0,x5			"parent vector = son vector
	eax5	0,x4			"parent index = son index
	tpl	FH_do_while-*,ic		"compare parent with new sons
	tra	FH_do_while_end-*,ic	"if bit 0 on, parent index *2 BIG, quit
"
compare2_A:				"for $float_bin entry
	dfld	pr3|0			"left son data
	dfcmp	pr1|0			"is left son data < right son data??
	tpl	compare2_B-*,ic		"no, left son is larger
	adlx4	1,du			"larger son index = right son index
	eax2	0,x1			"larger son vector = right son vector
	epp3	pr1|0			"larger son ptr = right son ptr

compare2_B:				"for $float_bin entry
	dfld	pr4|0			"parent data
	dfcmp	pr3|0			"is parent data < son data??
	tpl	compareB_else-*,ic		"no, parent is larger
	sxl2	pr7|0,x5			"parent vector = son vector
	eax5	0,x4			"parent index = son index
	tpl	FH_do_while-*,ic		"compare parent with new sons
	tra	FH_do_while_end-*,ic	"if bit 0 on, parent index *2 BIG, quit
"
compare3_A:				"for $char entry
	"N. B. data string length is in $A, DO NOT DESTROY!!
	cmpc	(pr,rl),(pr,rl),fill(040)	"compare two strings
	  desc9a	pr3|0,al			"left son data
	  desc9a	pr1|0,al			"right son data
	trc	compare3_B-*,ic		"left son is larger
	adlx4	1,du			"larger son index = right son index
	eax2	0,x1			"larger son vector = right son vector
	epp3	pr1|0			"larger son ptr = right son ptr

compare3_B:				"for $char entry
	"N. B. data string length is in $A, DO NOT DESTROY!!
	cmpc	(pr,rl),(pr,rl),fill(040)	"compare two strings
	  desc9a	pr4|0,al			"parent data
	  desc9a	pr3|0,al			"son data
	trc	compareB_else-*,ic		"parent is larger
	sxl2	pr7|0,x5			"parent vector = son vector
	eax5	0,x4			"parent index = son index
	tpl	FH_do_while-*,ic		"compare parent with new sons
	tra	FH_do_while_end-*,ic	"if bit 0 on, parent index *2 BIG, quit
"
compare4_A:				"for $bit entry
	"N. B. data string length is in $A, DO NOT DESTROY!!
	cmpb	(pr,rl),(pr,rl),fill(0)	"compare two bit strings
	  descb	pr3|0,al			"left son data
	  descb	pr1|0,al			"right son data
	trc	compare4_B-*,ic		"left son is larger
	adlx4	1,du			"larger son index = right son index
	eax2	0,x1			"larger son vector = right son vector
	epp3	pr1|0			"larger son ptr = right son ptr

compare4_B:				"for $bit entry
	"N. B. data string length is in $A, DO NOT DESTROY!!
	cmpb	(pr,rl),(pr,rl),fill(0)	"compare two bit strings
	  descb	pr4|0,al			"parent data
	  descb	pr3|0,al			"son data
	trc	compareB_else-*,ic		"parent is larger
	sxl2	pr7|0,x5			"parent vector = son vector
	eax5	0,x4			"parent index = son index
	tpl	FH_do_while-*,ic		"compare parent with new sons
	tra	FH_do_while_end-*,ic	"if bit 0 on, parent index *2 BIG, quit
"
compare5_A:				"for $varying_char entry
	lda	pr3|0			"left son data length
	ldq	pr1|0			"right son data length
	cmpc	(pr,rl),(pr,rl),fill(040)	"compare two strings
	  desc9a	pr3|1,al			"left son data
	  desc9a	pr1|1,ql			"right son data
	trc	compare5_B-*,ic		"left son is larger
	adlx4	1,du			"larger son index = right son index
	eax2	0,x1			"larger son vector = right son vector
	epp3	pr1|0			"larger son ptr = right son ptr

compare5_B:				"for $varying_char entry
	lda	pr4|0			"parent data length
	ldq	pr3|0			"son data length
	cmpc	(pr,rl),(pr,rl),fill(040)	"compare the two strings
	  desc9a	pr4|1,al			"parent data
	  desc9a	pr3|1,ql			"son data
	trc	compareB_else-*,ic		"parent is larger
	sxl2	pr7|0,x5			"parent vector = son vector
	eax5	0,x4			"parent index = son index
	tpl	FH_do_while-*,ic		"compare parent with new sons
	tra	FH_do_while_end-*,ic	"if bit 0 on, parent index *2 BIG, quit
"
compare6_A:				"for $adj_char entry
	lda	pr2|0,x2			"left son data length
	ldq	pr2|0,x1			"right son data length
	cmpc	(pr,rl),(pr,rl),fill(040)	"compare two strings
	  desc9a	pr3|0,al			"left son data
	  desc9a	pr1|0,ql			"right son data
	trc	compare6_B-*,ic		"left son is larger
	adlx4	1,du			"larger son index = right son index
	eax2	0,x1			"larger son vector = right son vector
	epp3	pr1|0			"larger son ptr = right son ptr

compare6_B:				"for $adj_char entry
	lda	pr2|0,x3			"parent data length
	ldq	pr2|0,x2			"son data length
	cmpc	(pr,rl),(pr,rl),fill(040)	"compare two strings
	  desc9a	pr4|0,al			"parent data
	  desc9a	pr3|0,ql			"son data
	trc	compareB_else-*,ic		"parent is larger
	sxl2	pr7|0,x5			"parent vector = son vector
	eax5	0,x4			"parent index = son index
	tpl	FH_do_while-*,ic		"compare parent with new sons
	tra	FH_do_while_end-*,ic	"if bit 0 on, parent index *2 BIG, quit
"
sort_heap:				"just a program label
""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
"This is the sort_heap section of sort_items_indirect_.  It sorts the
"   heap by putting the root node value in its proper place and
"   adjusting the remaining heap, producing a new root node value.
"   Register usage is as follows:
"   PR0 -- addr (arg_list) {$general entry ONLY!!}
"   PR1 -- right son ptr (if one exists)
"   PR2 -- function entry ptr {$general entry ONLY!!}
"	 addr (adjustable length array base) {$adj_char ONLY!!}
"   PR3 -- larger son ptr for compare C (initially assumed to be left son)
"	 parent ptr for compare D
"   PR4 -- last leaf ptr
"   PR5 -- addr (ptr array base)
"   PR6 -- addr (stack frame)
"   PR7 -- addr (vector array base)
"	 is temporarily set to addr (stack base) for calls {$general ONLY!!}
"   X1 -- right son vector (if on exists)
"   X2 -- larger son vector for compare C (initially assumed to be left son)
"         parent vector for compare D
"   X3 -- last leaf vector
"   X4 -- larger child index (initially assumed to be left son index)
"   X5 -- parent index
"   X6 -- SH_do_i loop control variable
"   X7 -- data type as defined by entry point
"   A -- data string length {$char, $bit entries ONLY!!}
""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
"
	ldx6	N_in_upper		"put total items in loop counter
	tra	SH_loop_start-*,ic		"goto loop start

SH_do_i:					"start of do i loop, or
compareD_then:				"finished backing up tree, or
SH_do_while_end:				"do while done, try do i again
	sxl3	pr7|0,x4			"son vector = last leaf vector

SH_loop_start:
	sblx6	1,du			"decrement loop index by 1
	tze	sort_end-*,ic		"loop done, goto sort_end
	stx6	N_in_upper		"store counter index bound
	lxl3	pr7|1,x6			"get last leaf vector
	lprp4	pr5|0,x3			"get last leaf ptr
	ldq	pr7|1			"get root vector
	stq	pr7|1,x6			"last leaf vector = root vector
	ldx5	1,du			"parent index = 1

SH_do_while:				"walk tree, swap up if son > last leaf
	eaq	0,x5			"put parent index in $Q
	qls	1			"multiply by 2
	eax4	0,qu			"put in larger child index
	cmpx4	N_in_upper		"is larger son index <= loop index??
	tnc	SH_two_sons-*,ic		"have two sons
	tze	SH_one_son-*,ic		"have one son
	eax4	0,x5			"too big, get old value
	tra	label_vec_D,x7*		"go back up tree

SH_two_sons:
	lxl2	pr7|0,x4			"get left son vector
	lprp3	pr5|0,x2			"get left son ptr
	lxl1	pr7|1,x4			"get right son vector
	lprp1	pr5|0,x1			"get right son ptr
	tra	label_vec_C,x7*		"find larger of sons

SH_one_son:
	lxl2	pr7|0,x4			"get larger son vector
	sxl2	pr7|0,x5			"parent vector = son vector
	eax5	0,x4			"parent index = son index
	tpl	SH_do_while-*,ic		"compare parent with new sons
	tra	label_vec_D,x7*		"else go back up tree
"
compare0_C:				"for $general entry
	sprp3	general_pptr_1		"left son ptr
	sprp1	general_pptr_2		"right son ptr
	"call pseudo-op simulated to call function
	spri	pr6|0			"save all PR's
	sreg	pr6|stack_frame.regs	"save rest of registers
	epbp7	pr6|0			"make $PR7 point to stack base
	tsp4	pr7|stack_header.call_op_ptr,*     "use stack header ptr to call
	lpri	pr6|0			"reclaim our PR's
	lreg	pr6|stack_frame.regs	"reclaim rest of registers
	"test function return value
	szn	general_value		"is left son data < right son data??
	tpl	assignment0_C-*,ic		"no, left son is larger
	adlx4	1,du			"larger son index = right son index
	eax2	0,x1			"larger son vector = right son vector

assignment0_C:
	sxl2	pr7|0,x5			"parent vector = son vector
	eax5	0,x4			"parent index = son index
	tpl	SH_do_while-*,ic		"compare parent with new sons

compare0_D:				"for $general entry
	eaq	0,x4			"put son index in $Q
	qrl	1			"divide by shifting bits right
	eax5	0,qu			"put in parent index
	tze	compareD_then-*,ic		"if = 0, try do i loop again
	lxl2	pr7|0,x5			"get parent vector
	lprp3	pr5|0,x2			"get parent ptr
	sprp3	general_pptr_1		"set parent ptr
	sprp4	general_pptr_2		"set last leaf ptr
	"call pseudo-op simulated to call function
	spri	pr6|0			"save all PR's
	sreg	pr6|stack_frame.regs	"save rest of registers
	epbp7	pr6|0			"make $PR7 point to stack base
	tsp4	pr7|stack_header.call_op_ptr,*     "use stack header ptr to call
	lpri	pr6|0			"reclaim our PR's
	lreg	pr6|stack_frame.regs	"reclaim rest of registers
	"test function return value
	szn	general_value		"is parent data < last leaf data??
	tpl	compareD_then-*,ic		"no, parent is larger
	sxl2	pr7|0,x4			"son vector = parent vector
	eax4	0,x5			"son index = parent index
	tra	compare0_D-*,ic		"go back up tree
"
compare1_C:				"for $fixed_bin entry
	ldq	pr3|0			"left son data
	cmpq	pr1|0			"is left son data < right son data??
	tpl	assignment1_C-*,ic		"no, left son is larger
	adlx4	1,du			"larger son index = right son index
	eax2	0,x1			"larger son vector = right son vector

assignment1_C:
	sxl2	pr7|0,x5			"parent vector = son vector
	eax5	0,x4			"parent index = son index
	tpl	SH_do_while-*,ic		"compare parent with new sons

compare1_D:				"for $fixed_bin entry
	eaq	0,x4			"put son index in $Q
	qrl	1			"divide by shifting bits right
	eax5	0,qu			"put in parent index
	tze	compareD_then-*,ic		"if = 0, try do i loop again
	lxl2	pr7|0,x5			"get parent vector
	lprp3	pr5|0,x2			"get parent ptr
	ldq	pr3|0			"parent data
	cmpq	pr4|0			"is parent data < last leaf data??
	tpl	compareD_then-*,ic		"no, parent is larger
	sxl2	pr7|0,x4			"son vector = parent vector
	eax4	0,x5			"son index = parent index
	tra	compare1_D-*,ic		"go back up tree
"
compare2_C:				"for $float_bin entry
	dfld	pr3|0			"left son data
	dfcmp	pr1|0			"is left son data < right son data??
	tpl	assignment2_C-*,ic		"no, left son is larger
	adlx4	1,du			"larger son index = right son index
	eax2	0,x1			"larger son vector = right son vector

assignment2_C:
	sxl2	pr7|0,x5			"parent vector = son vector
	eax5	0,x4			"parent index = son index
	tpl	SH_do_while-*,ic		"compare parent with new sons

compare2_D:				"for $float_bin entry
	eaq	0,x4			"put son index in $Q
	qrl	1			"divide by shifting bits right
	eax5	0,qu			"put in parent index
	tze	compareD_then-*,ic		"if = 0, try do i loop again
	lxl2	pr7|0,x5			"get parent vector
	lprp3	pr5|0,x2			"get parent ptr
	dfld	pr3|0			"parent data
	dfcmp	pr4|0			"is parent data < last leaf data??
	tpl	compareD_then-*,ic		"no, parent is larger
	sxl2	pr7|0,x4			"son vector = parent vector
	eax4	0,x5			"son index = parent index
	tra	compare2_D-*,ic		"go back up tree
"
compare3_C:				"for $char entry
	"N. B. data string length is in $A, DO NOT DESTROY!!
	cmpc	(pr,rl),(pr,rl),fill(040)	"compare two strings
	  desc9a	pr3|0,al			"left son data
	  desc9a	pr1|0,al			"right son data
	trc	assignment3_C-*,ic		"left son is larger
	adlx4	1,du			"larger son index = right son index
	eax2	0,x1			"larger son vector = right son vector

assignment3_C:
	sxl2	pr7|0,x5			"parent vector = son vector
	eax5	0,x4			"parent index = son index
	tpl	SH_do_while-*,ic		"compare parent with new sons

compare3_D:				"for $char entry
	eaq	0,x4			"put son index in $Q
	qrl	1			"divide by shifting bits right
	eax5	0,qu			"put in parent index
	tze	compareD_then-*,ic		"if = 0, try do i loop again
	lxl2	pr7|0,x5			"get parent vector
	lprp3	pr5|0,x2			"get parent ptr
	"N. B. data string length is in $A, DO NOT DESTROY!!
	cmpc	(pr,rl),(pr,rl),fill(040)	"compare two strings
	  desc9a	pr3|0,al			"parent data
	  desc9a	pr4|0,al			"last leaf data
	trc	compareD_then-*,ic		"parent is larger
	sxl2	pr7|0,x4			"son vector = parent vector
	eax4	0,x5			"son index = parent index
	tra	compare3_D-*,ic		"go back up tree
"
compare4_C:				"for $bit entry
	"N. B. data string length is in $A, DO NOT DESTROY!!
	cmpb	(pr,rl),(pr,rl),fill(0)	"compare two bit strings
	  descb	pr3|0,al			"left son data
	  descb	pr1|0,al			"right son data
	trc	assignment4_C-*,ic		"left son is larger
	adlx4	1,du			"larger son index = right son index
	eax2	0,x1			"larger son vector = right son vector

assignment4_C:
	sxl2	pr7|0,x5			"parent vector = son vector
	eax5	0,x4			"parent index = son index
	tpl	SH_do_while-*,ic		"compare parent with new sons

compare4_D:				"for $bit entry
	eaq	0,x4			"put son index in $Q
	qrl	1			"divide by shifting bits right
	eax5	0,qu			"put in parent index
	tze	compareD_then-*,ic		"if = 0, try do i loop again
	lxl2	pr7|0,x5			"get parent vector
	lprp3	pr5|0,x2			"get parent ptr
	"N. B. data string length is in $A, DO NOT DESTROY!!
	cmpb	(pr,rl),(pr,rl),fill(0)	"compare two bit strings
	  descb	pr3|0,al			"parent data
	  descb	pr4|0,al			"last leaf data
	trc	compareD_then-*,ic		"parent is larger
	sxl2	pr7|0,x4			"son vector = parent vector
	eax4	0,x5			"son index = parent index
	tra	compare4_D-*,ic		"go back up tree
"
compare5_C:				"for $varying_char entry
	lda	pr3|0			"left son data length
	ldq	pr1|0			"right son data length
	cmpc	(pr,rl),(pr,rl),fill(040)	"compare two strings
	  desc9a	pr3|1,al			"left son data
	  desc9a	pr1|1,ql			"right son data
	trc	assignment5_C-*,ic		"left son is larger
	adlx4	1,du			"larger son index = right son index
	eax2	0,x1			"larger son vector = right son vector

assignment5_C:
	sxl2	pr7|0,x5			"parent vector = son vector
	eax5	0,x4			"parent index = son index
	tpl	SH_do_while-*,ic		"compare parent with new sons

compare5_D:				"for $varying_char entry
	eaq	0,x4			"put son index in $Q
	qrl	1			"divide by shifting bits right
	eax5	0,qu			"put in parent index
	tze	compareD_then-*,ic		"if = 0, try do i loop again
	lxl2	pr7|0,x5			"get parent vector
	lprp3	pr5|0,x2			"get parent ptr
	lda	pr3|0			"parent data length
	ldq	pr4|0			"last leaf data length
	cmpc	(pr,rl),(pr,rl),fill(040)	"compare two strings
	  desc9a	pr3|1,al			"parent data
	  desc9a	pr4|1,ql			"last leaf data
	trc	compareD_then-*,ic		"parent is larger
	sxl2	pr7|0,x4			"son vector = parent vector
	eax4	0,x5			"son index = parent index
	tra	compare5_D-*,ic		"go back up tree
"
compare6_C:				"for $adj_char entry
	lda	pr2|0,x2			"left son data length
	ldq	pr2|0,x1			"right son data length
	cmpc	(pr,rl),(pr,rl),fill(040)	"compare two strings
	  desc9a	pr3|0,al			"left son data
	  desc9a	pr1|0,ql			"right son data
	trc	assignment6_C-*,ic		"left son is larger
	adlx4	1,du			"larger son index = right son index
	eax2	0,x1			"larger son vector = right son vector

assignment6_C:
	sxl2	pr7|0,x5			"parent vector = son vector
	eax5	0,x4			"parent index = son index
	tpl	SH_do_while-*,ic		"compare parent with new sons

compare6_D:				"for $adj_char entry
	eaq	0,x4			"put son index in $Q
	qrl	1			"divide by shifting bits right
	eax5	0,qu			"put in parent index
	tze	compareD_then-*,ic		"if = 0, try do i loop again
	lxl2	pr7|0,x5			"get parent vector
	lprp3	pr5|0,x2			"get parent ptr
	lda	pr2|0,x2			"parent data length
	ldq	pr2|0,x3			"last leaf data length
	cmpc	(pr,rl),(pr,rl),fill(040)	"compare two strings
	  desc9a	pr3|0,al			"parent data
	  desc9a	pr4|0,ql			"last leaf data
	trc	compareD_then-*,ic		"parent is larger
	sxl2	pr7|0,x4			"son vector = parent vector
	eax4	0,x5			"son index = parent index
	tra	compare6_D-*,ic		"go back up tree

sort_end:					"sort finished, go home
	epbp7	pr6|0			"set $PR7 for return
	return
	end				"program done




		    sort_seg.pl1                    04/19/90  1525.3rew 04/19/90  1519.4      427221



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


/****^  HISTORY COMMENTS:
  1) change(74-01-01,Klinger), approve(85-01-14,MCR7139),
     audit(85-12-16,GDixon), install(85-12-19,MR12.0-1003):
      Written 1974 by Ross Klinger.
  2) change(75-08-16,Grady), approve(85-01-14,MCR7139), audit(85-12-16,GDixon),
     install(85-12-19,MR12.0-1003):
      Modified by Mike Grady to add -ordered_fields.
  3) change(82-05-11,GDixon), approve(85-01-14,MCR7139),
     audit(85-12-16,Unknown), install(85-12-19,MR12.0-1003):
      Modified by Gary Dixon to generalize -field, allow
      non_case_sensitive sorting, greater control over handling of
      duplicates, use of regular expression sort unit/field
      delimiters, etc.
  4) change(83-06-01,Schimke), approve(85-01-14,MCR7139),
     audit(85-12-16,GDixon), install(85-12-19,MR12.0-1003):
      Modified to fix an error in the -to regular expression handling code
      which was not stripping off the delimiters.
  5) change(83-08-01,Schimke), approve(85-01-14,MCR7139),
     audit(85-12-16,GDixon), install(85-12-19,MR12.0-1003):
      Modified by Dave Schimke to add -numeric and -integer global
      sort modes.  Renamed the -segment and -sm control args to
      -output_file and -of.
  6) change(84-04-05,GDixon), approve(85-01-14,MCR7139),
     audit(85-12-16,Unknown), install(85-12-19,MR12.0-1003):
      Modified by Gary Dixon to add the sort_strings (sstr) entrypoint.
  7) change(84-12-12,Lippard), approve(85-01-16,MCR7139),
     audit(85-12-16,GDixon), install(85-12-17,MR12.0-1001):
      Modified by Jim Lippard to prevent sub_error_handler from
      terminating execution (sort_seg_ takes care of it) and make
      multiple -field and -ordered_field control args aggregate
      instead of overriding.
  8) change(85-12-18,Lippard), approve(85-12-19,PBF7139),
     audit(85-12-19,GDixon), install(85-12-19,MR12.0-1003):
      Modified to keep proper field count when multiple fields are specified
      after one -field control arg.
  9) change(90-03-15,Vu), approve(90-03-15,MCR8162), audit(90-03-21,Kallstrom):
      The sstr command fails when one of the strings to be sorted contains a
      newline character.
                                                   END HISTORY COMMENTS */


	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/*									*/
	/* Name: sort_seg								*/
	/*									*/
	/* Command for sorting segments or strings, based upon one or more sort fields within	*/
	/* sort units.								*/
	/*									*/

sort_seg:
ss:	
sort_file:
sf:	procedure options(variable);

    dcl	Ifl			fixed bin,	/* index into si.field array.			*/
	Itriple			fixed bin,
	Sdescending		bit(1),		/* on if -descending ctl_arg was given.		*/
	Sinteger 		          bit(1),		/* on if -integer ctl_arg given.           	*/
	Snon_case_sensitive		bit(1),		/* on if -non_case_sensitive ctl_arg given.	*/
	Snumeric   		bit(1),		/* on if -numeric ctl_arg given.        	*/
	Syes			bit(1),
	bc			fixed bin(24),
	code			fixed bin(35),
	descending_sort		fixed bin,	/* detect whether -dsc or -asc ctl_args appear.	*/
						/*   values: SS_unset, ASCENDING, DESCENDING	*/
	equal_ent			char(32),
	field_sort		fixed bin,	/* type of sort: -all, -field or -ordered_field	*/
						/*   values: ALL, FIELD, ORDERED_FIELD		*/
	in_dir			char(168),
	in_ent			char(32),
	number			fixed bin,	/* temporary to hold a converted number.	*/
	op_list			char(256) varying,
	out_dir			char(168),
	out_ent			char(32),
	out_len			fixed bin(21),
	q			fixed bin,
	1 si			aligned,
	  2 header		like ss_info.header,
	  2 field (estimate_fields()) like ss_info.field,
	sort_output		fixed bin,	/* Type of output: -replace or -output_file	*/
						/*   values: SS_unset, REPLACE, SEGMENT		*/
	type			fixed bin(2),
	undelim_char_index		fixed bin(21);

    dcl  (addcharno, addr, convert, divide, index, length,
          max, null, search, substr)
				builtin;

    dcl	cleanup			condition,
	sub_error_		condition;

    dcl	command_query_$yes_no	entry() options (variable),
	expand_pathname_		entry (char(*), char(*), char(*), fixed bin(35)),
	get_equal_name_		entry (char(*), char(*), char(*), fixed bin(35)),
	hcs_$status_minf		entry (char(*), char(*), fixed bin(1), fixed bin(2), fixed bin(24),
				     fixed bin(35)),
	requote_string_		entry (char(*)) returns(char(*)),
	sort_seg_$seg		entry (char(*), ptr, char(*), char(*), char(*), char(*), fixed bin(21),
				     fixed bin(21), fixed bin(35)),
	sort_seg_$string		entry (char(*), ptr, char(*), char(*), fixed bin(21), fixed bin(21),
				     fixed bin(35)),
	user_info_$absentee_queue	entry (fixed bin);

    dcl  (ALL			init(1),
	FIELD			init(2),
	ORDERED_FIELD		init(3)) fixed bin int static options(constant),
         (ASCENDING			init(1),
	DESCENDING		init(2)) fixed bin int static options(constant),
	CHASE			init(1) fixed bin(1) int static options(constant),
         (CHECK_NULLS		init("1"b),
          NO_CHECK_NULLS		init("0"b)) bit(1) int static options(constant),
         (FALSE			init("0"b),
	TRUE			init("1"b)) bit(1) int static options(constant),
	NL			char(1) int static options(constant) init("
"),
         (REPLACE			init(2),
	SEGMENT			init(1)) fixed bin int static options(constant),
         (error_table_$bad_arg,
	error_table_$badopt,
	error_table_$data_seq_error,
	error_table_$dirseg,
	error_table_$noarg,
	error_table_$out_of_bounds,
	error_table_$too_many_args,
	error_table_$too_many_names,
	error_table_$wrong_no_of_args,
	error_table_$zero_length_seg)
				fixed bin(35) ext static;

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* STATIC ERROR MESSAGE TEXT							*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

    dcl	BAD_DELIM_LENGTH		char(153) int static options(constant) init(
"^a ^a
The delimited string length must be an integer from 1 to 131071.
If you wish ^a to be treated as a character string delimiter, use:
  ^a -string ^a"),
	BAD_FIELD_START_INDEX	char(152) int static options(constant) init(
"^a ^a
The field_start index must be an integer from 1 to 131071.
If you wish ^a to be treated as a character field delimiter, use:
  ^a ^a -string ^a"),
	BAD_FIELD_LENGTH		char(121) int static options(constant) init(
"The field_end length must be an integer from 1 to 131071, or -1 to use a length
equal to the remainder of the sort unit."),
	BAD_FIELD_END_INDEX		char(150) int static options(constant) init(
"^a ^a
The field_end index must be an integer from 1 to 131071.
If you wish -a to be treated as a character field delimiter, use:
  ^a ^a -string -a"),
	DELIM_SYNTAX		char(95) int static options(constant) init(
"Allowed syntax is:	-delimiter L
		-delimiter STR
		-delimiter /REGEXP/
		-delimiter -string STR"),
	FIELD_LENGTH_SYNTAX		char(191) int static options(constant) init(
"Allowed syntax is:  ^a field_start field_length {sort_controls}
field_length can be: L (an integer length)
		 -for L
		 -to E (a field end index)
		 -to STR
		 -to /REGEXP/
		 -to -string STR"),
	FIELD_MODES_SYNTAX		char(224) int static options(constant) init(
"Allowed syntax is:   ^a field_start field_length {sort_controls}
sort_controls can be: ascending, asc
		  descending, dsc
		  case_sensitive, cs
		  non_case_sensitive, ncs
		  character, ch
		  numeric, num
		  integer, int"),
	FIELD_START_SYNTAX		char(163) int static options(constant) init(
"Allowed syntax is:	^a field_start field_length {sort_controls}
field_start can be:	S (field start index)
		-from S
		-from STR
		-from /REGEXP/
		-from -string STR"),
	OFL_SYNTAX		char(83) int static options(constant) init(
"Allowed syntax is:	^a start_index field_length direction
direction can be:	asc, dsc");

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* ENTRYPOINT: sort_seg, ss, sort_file, sf					*/
	/* 1) Get arg count, make sure sort_seg is only invoked as a command.			*/
	/* 2) Prepare to handle in/out pathnames (sort_seg) or input strings (sort_strings).	*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	call get_invocation_type ("sort_seg", Saf, Nargs, code);
	if Saf then do;
	   call ck_err (code, ep);
	   return;
	   end;
	if Nargs = 0 then do;
	   call ck_err (error_table_$wrong_no_of_args, ep, "
Usage:	ss sort_input_pathname {-control_args}");
	   return;
	   end;

	in_dir = "";				/* No input or output pathnames given  so far.	*/
	in_ent = "";
	out_dir = "";
	out_ent = "";

	go to COMMON;



	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* ENTRYPOINT: sort_strings, sstr						*/
	/* 1) Get arg count.							*/
	/* 2) Get and initialize storage for the strings to be sorted.			*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

sort_strings:
sstr:	entry options(variable);

	call get_invocation_type ("sort_strings", Saf, Nargs, code);
	if Nargs = 0 then do;
	   call ck_err (error_table_$wrong_no_of_args, ep, "
Usage:	^[[^]sstr {-control_args} strings^[]^]", Saf, Saf);
	   return;
	   end;
	Pstring = null;
	on cleanup begin;
	   call release_temp_segment_ (ep, Pstring, code);
	   end;
	call add_to_string$init();

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* 1) Initialize argument-holding variables prior to parsing arguments.		*/
	/* 2) Set defaults for control arguments.					*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

COMMON:	si.version = SS_info_version_1;		/* Initialize structure passed to sort_seg_ which */
	si.block_size = 1;				/*   defines how sorting will be done.		*/
	si.duplicate_mode = SS_unset;
	si.mbz1(*) = 0;
	si.delim.type = SS_unset;
	si.delim.number = 0;
	si.delim.string = "";
	si.field_count = 0;
	si.field(*).from.type = SS_unset;
	si.field(*).from.number = 0;
	si.field(*).from.string = "";
	si.field(*).to.type = SS_unset;
	si.field(*).to.number = 0;
	si.field(*).to.string = "";
	si.field(*).modes = FALSE;

	field_sort = SS_unset;			/* Neither -all, -field or old -order_field given */
	sort_output = SS_unset;			/* Neither -replace nor -output_file given yet.	*/
	descending_sort = SS_unset;			/* Neither -ascending nor -descending given yet.	*/

	Snon_case_sensitive = FALSE;			/* Initial default settings: -case_sensitive and  */
	Sdescending = FALSE;			/*   -ascending				*/
          Snumeric = FALSE;				/* Also, -character				*/
          Sinteger = FALSE;				

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* ARGUMENT PROCESSING:							*/
	/* Pass 1) Pre-scan all arguments first to determine whether -ascending/-descending and	*/
	/*	 -case_sensitive/-non_case_sensitive have been specified.  The last specified	*/
	/*	 of either pair will be used as the default setting when setting sort fields.	*/
	/*         This pass is only necessary if -field is given.  If -field isn't given, then	*/
	/*	 the arguments are only scanned once, equivalent to pass 2.			*/
	/* Pass 2) Actually process control arguments, include the old -ordered_field control	*/
	/*	 argument.  -ofl was made obsolete when its functionality was added to -field.	*/
	/*	 The syntax for -ofl is:						*/
	/*	     -ofl field_start field_length sort_direction				*/
	/* 	 where field_start is a character index, field_length is a character string	*/
	/*	 length, and sort_direction is asc or dsc.				*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

REPROCESS_ARGS:
	do while (get_arg());			/* Process control arguments			*/
(nostringsize):
	   if index(arg, "-") ^= 1 then do;		/* process non-control args.			*/
	      if ep = "sort_seg" then do;		/*   for sort_seg, it is sort_input_pathname	*/
	         if in_dir ^= "" then
		  call ck_err (error_table_$too_many_names, ep, "^a
Only one input pathname allowed.  To give output path, use: -of out_path", arg);
	         call expand_pathname_ (arg, in_dir, in_ent, code);
	         call ck_err (code, ep, arg);
	         end;

	      else do;				/*   for sort_strings, it is a string.		*/
	         call add_to_string (arg);		/*   All remaining args are strings to be sorted. */
STRING_ARGS:       do while (get_arg());
		  call add_to_string (arg);
		  end;
	         end;
	      end;

	   else if (arg = "-string" | arg = "-str") & ep = "sort_strings" then
	      go to STRING_ARGS;

	   else if arg = "-all" | arg = "-a" then	/* process -all				*/
	      field_sort = ALL;

	   else if arg = "-field" | arg = "-fl" then do;	/* process -field				*/
	      field_sort = FIELD;

	      do Itriple = 1 to 3;			/* Operands of -field come in triples:		*/
	         go to FL(Itriple);			/*   field_start field_length {sort_controls}	*/

FL(1):	         if get_op (FIELD_START_SYNTAX, arg) then do;
		  Ifl = si.field_count + 1;		/*   process field_start operands		*/
		  if op = "-from" | op = "-fm" then do;
		     if get_op2 (FIELD_START_SYNTAX, arg, NO_CHECK_NULLS) then do;
		        if op2 = "-string" | op2 = "-str" then do;
			 if get_op2 ("Allowed syntax is:	^a -from -string STR",
			    arg, NO_CHECK_NULLS) then do;
			    si.field(Ifl).from.type = SS_string;
			    si.field(Ifl).from.string = op2;
			    end;
			 else Itriple = 4;
			 end;
		        else do;
			 number = cv_num_no_errors (op2, code);
			 if number >= 1 then do;
			    si.field(Ifl).from.type = SS_index;
			    si.field(Ifl).from.number = number;
			    end;
			 else if code = error_table_$out_of_bounds then do;
			    call ck_err (code, ep, BAD_FIELD_START_INDEX,
			       arg, op_list, op2, arg, op, op2);
			    end;
			 else if substr(op2,1,1) = "/" & substr(op2,length(op2),1) = "/" & length(op2)>2 then do;
			    si.field(Ifl).from.type = SS_reg_exp;
			    si.field(Ifl).from.string = substr(op2,2,length(op2)-2);
			    end;
			 else do;
			    si.field(Ifl).from.type = SS_string;
			    si.field(Ifl).from.string = op2;
			    end;
			 end;
		        end;
		     else Itriple = 4;
		     end;
		  else do;
		     number = cv_num_no_errors (op, code);
		     if code = 0 then do;
		        si.field(Ifl).from.type = SS_index;
		        si.field(Ifl).from.number = number;
		        end;
		     else if code = error_table_$out_of_bounds then
		        call ck_err (code, ep, BAD_FIELD_START_INDEX,
			 arg, op_list, op, arg, "-from", op);
		     else
		        call ck_err (code, ep, "^a ^a^/" ||
			 FIELD_START_SYNTAX, arg, op_list, arg);
		     end;
		  end;
	         else Itriple = 4;
	         go to END_FL;

FL(2):	         if get_op1 (FIELD_LENGTH_SYNTAX, arg) then do;
		  if op = "-for" then do;		/*   process field_length operands		*/
		     if get_op2 (FIELD_LENGTH_SYNTAX, arg, NO_CHECK_NULLS) then do;
		        number = cv_num_no_errors (op2, code);
		        if code = 0 then do;
			 si.field(Ifl).to.number = number;
			 si.field(Ifl).to.type = SS_length;
			 end;
		        else if code = error_table_$out_of_bounds then
			 if number = -1 then do;	/* -1 means use rest of sort unit as field.	*/
			    si.field(Ifl).to.number = number;
			    si.field(Ifl).to.type = SS_length;
			    end;
			 else
			    call ck_err (code, ep, "^a ^a^/" ||
			       BAD_FIELD_LENGTH, arg, op_list);
		        else 
			 call ck_err (code, ep, "^a ^a^/" ||
			    FIELD_LENGTH_SYNTAX, arg, op_list, arg);
		        end;
		     else Itriple = 4;
		     end;
		  else if op = "-to" then do;
		     if get_op2 (FIELD_LENGTH_SYNTAX, arg, NO_CHECK_NULLS) then do;
		        if op2 = "-string" | op2 = "-str" then do;
			 if get_op2 ("Allowed syntax is:	-a -to -string STR",
			    arg, NO_CHECK_NULLS) then do;
			    si.field(Ifl).to.type = SS_string;
			    si.field(Ifl).to.string = op2;
			    end;
			 else Itriple = 4;
			 end;
		        else do;
			 number = cv_num_no_errors (op2, code);
			 if number >= 1 then do;
			    si.field(Ifl).to.type = SS_index;
			    si.field(Ifl).to.number = number;
			    end;
			 else if code = error_table_$out_of_bounds then do;
			    call ck_err (code, ep, BAD_FIELD_END_INDEX,
			       arg, op_list, op2, arg, op, op2);
			    end;
			 else if substr(op2,1,1)="/" & substr(op2,length(op2),1)="/" & length(op2)>2 then do;
			    si.field(Ifl).to.type = SS_reg_exp;
			    si.field(Ifl).to.string = substr(op2,2,length(op2)-2);
			    end;
			 else do;
			    si.field(Ifl).to.type = SS_string;
			    si.field(Ifl).to.string = op2;
			    end;
			 end;
		        end;
		     else Itriple = 4;
		     end;
		  else do;
		     number = cv_num_no_errors (op, code);
		     if code = 0 then do;
		        si.field(Ifl).to.number = number;
		        si.field(Ifl).to.type = SS_length;
		        end;
		     else if code = error_table_$out_of_bounds then
		        if number = -1 then do;	/* -1 means use rest of sort unit as field.	*/
			 si.field(Ifl).to.number = number;
			 si.field(Ifl).to.type = SS_length;
			 end;
		        else
		           call ck_err (code, ep, "^a ^a^/" ||
			    BAD_FIELD_LENGTH, arg, op_list);
		     else
		        call  ck_err (code, ep, "^a ^a^/" ||
			 FIELD_LENGTH_SYNTAX, arg, op_list, arg);
		     end;
		  end;
	         else Itriple = 4;

	         go to END_FL;

FL(3):	         si.field(Ifl).modes.descending = Sdescending;
	         si.field(Ifl).modes.non_case_sensitive = Snon_case_sensitive;
	         si.field(Ifl).modes.numeric = Snumeric;
	         si.field(Ifl).modes.integer = Sinteger;

/*   process sort_controls			*/
FL3_OP:	         if get_op1 ("", "") then do;
		  if op = "ascending" | op = "asc" then do;
		     si.field(Ifl).modes.descending = FALSE;
		     go to FL3_OP;
		     end;
		  else if op = "descending" | op = "dsc" then do;
		     si.field(Ifl).modes.descending = TRUE;
		     go to FL3_OP;
		     end;
		  else if op = "case_sensitive" | op = "cs" then do;
		     si.field(Ifl).modes.non_case_sensitive = FALSE;
		     go to FL3_OP;
		     end;
		  else if op = "non_case_sensitive" | op = "ncs" then do;
		     si.field(Ifl).modes.non_case_sensitive = TRUE;
		     go to FL3_OP;
		     end;
		  else if op = "character" | op = "ch" then do;
		     si.field(Ifl).modes.numeric = FALSE;
		     si.field(Ifl).modes.integer = FALSE;
		     go to FL3_OP;
		     end;
		  else if op = "numeric" | op = "num" then do;
		     si.field(Ifl).modes.numeric = TRUE;
		     si.field(Ifl).modes.integer = FALSE;
		     go to FL3_OP;
		     end;
		  else if op = "integer" | op = "int" then do;
		     si.field(Ifl).modes.integer = TRUE;
		     si.field(Ifl).modes.numeric = FALSE;
		     go to FL3_OP;
		     end;
		  else if cv_num_no_errors (op, code) >= 1 then do;
		     Iarg = Iarg - 1;
		     Itriple = 0;
		     si.field_count = Ifl;
		     end;
		  else if op = "-from" | op = "-fm" then do;
		     Iarg = Iarg - 1;
		     Itriple = 0;
		     si.field_count = Ifl;
		     end;
		  else if op = "-for" | op = "-to" then do;
		     if get_op2 ("^a requires an operand.", op, NO_CHECK_NULLS) then do;
		        call ck_err (error_table_$data_seq_error, ep, "^a ^a
The operands of ^a must be in the order:  
   field_start field_length {sort_controls}", arg, op_list, arg);
		        Iarg = Iarg - 2;
		        Itriple = 1;
		        si.field_count = Ifl;
		        end;
		     else do;
		        call ck_err (error_table_$data_seq_error, ep, "^a ^a
The operands of ^a must be in the order:
  field_start field_length {sort_controls}", arg, op_list, arg);
		        Itriple = 4;
		        end;
		     end;
		  else if index(op,"-") = 1 then do;
		     Iarg = Iarg - 1;
		     Itriple = 4;
		     end;
		  else do;
		     call ck_err (error_table_$bad_arg, ep, "^a ^a
" || FIELD_MODES_SYNTAX, arg, op_list, arg);
		     Itriple = 4;
		     end;
		  end;
	         else Itriple = 4;
END_FL:	         end;
	      si.field_count = Ifl;
	      end;

	   else if (arg = "-ordered_field" | arg = "-ofl") &
		  ep = "sort_seg" then do;
	      field_sort = ORDERED_FIELD;		/* process -ordered_field			*/

	      do Itriple = 1 to 3;			/* Operands of -ordered_field come in triples:	*/
	         go to OFL(Itriple);			/*   field_start field_length sort_direction	*/

OFL(1):	         if get_op (OFL_SYNTAX, arg) then do;	/*   process field_start operand		*/
		  Ifl = si.field_count + 1;
		  si.field(Ifl).from.number =
		     cv_num (op, "The first operand of ^a is a character index from 1 to 131071.", arg);
		  si.field(Ifl).from.type = SS_index;
		  end;
	         else Itriple = 4;
	         go to END_OFL;

OFL(2):	         if get_op2 (OFL_SYNTAX, arg, CHECK_NULLS) then do;
		  si.field(Ifl).to.number =		/*   process field_length operand		*/
		     cv_num (op2, "The second operand of ^a is a field length from 1 to 131071.", arg);
		  si.field(Ifl).to.type = SS_length;
		  end;
	         else Itriple = 4;
	         go to END_OFL;

OFL(3):	         si.field(Ifl).modes = FALSE;		/*   process sort_direction operand		*/
	         if get_op2 (OFL_SYNTAX, arg, CHECK_NULLS) then do;
		  if op2 = "dsc" then
		     si.field(Ifl).modes.descending = TRUE;
		  else if op2 = "asc" then;
		  else 
		     call ck_err (error_table_$bad_arg, ep, "^a ^a
The third operand of ^a must be asc (for ascending) or dsc (for descending).",
		        arg, op_list, arg);
		  end;
	         if get_op ("", "") then do;
		  Iarg = Iarg - 1;
		  if cv_num_no_errors (op, code) >= 1 then
		     Itriple = 0;
		     si.field_count = Ifl;
		  end;
END_OFL:	         end;
	      si.field_count = Ifl;
	      end;

	   else if arg = "-ascending" | arg = "-asc" then do;
	      descending_sort = ASCENDING;		/*  process sort direction/case-sensitivity args	*/
	      Sdescending = FALSE;
	      end;
	   else if arg = "-descending" | arg = "-dsc" then do;
	      descending_sort = DESCENDING;
	      Sdescending = TRUE;
	      end;

	   else if arg = "-case_sensitive" | arg = "-cs" then
	      Snon_case_sensitive = FALSE;
	   else if arg = "-non_case_sensitive" | arg = "-ncs" then
	      Snon_case_sensitive = TRUE;

	   else if arg = "-character" | arg = "-ch" then do;
	      Snumeric = FALSE;
	      Sinteger = FALSE;
	      end;
	   else if arg = "-numeric" | arg = "-num" then do
	      Snumeric = TRUE;
	      Sinteger = FALSE;
	      end;
	   else if arg = "-integer" | arg = "-int" then do
	      Sinteger = TRUE;
	      Snumeric = FALSE;
	      end;

	   else if arg = "-duplicates" | arg = "-dup" then
	      si.duplicate_mode = SS_duplicates;	/* process duplicate-handling control args.	*/

	   else if arg = "-only_duplicates" | arg = "-odup" then
	      si.duplicate_mode = SS_only_duplicates;

	   else if arg = "-only_duplicate_keys" | arg = "-odupk" then
	      si.duplicate_mode = SS_only_duplicate_keys;

	   else if arg = "-unique" | arg = "-uq" then
	      si.duplicate_mode = SS_unique;

	   else if arg = "-unique_keys" | arg = "-uqk" then
	      si.duplicate_mode = SS_unique_keys;

	   else if arg = "-only_unique" | arg = "-ouq" then
	      si.duplicate_mode = SS_only_unique;

	   else if arg = "-only_unique_keys" | arg = "-ouqk" then
	      si.duplicate_mode = SS_only_unique_keys;

	   else if arg = "-block" | arg = "-bk" then do;	/* process sort string blocking factor arg.	*/
	      if get_op ("^a requires a block size operand from 1 to 131071.", arg) then
	         si.block_size = cv_num (op, "^a requires a block size operand from 1 to 131071.", arg);
	      end;

	   else if (arg = "-delimiter" | arg = "-dm") & 
		  ep = "sort_seg" then do;
	      if get_op (DELIM_SYNTAX, arg) then do;	/* process sort string delimiter control arg.	*/
	         if op = "-string" | op = "-str" then do;
		  if get_op ("Allowed syntax is:	^a -string STR", arg) then do;
		     si.delim.type = SS_string;
		     si.delim.string = op || NL;
		     end;
		  end;
	         else do;
		  si.delim.number = cv_num_no_errors (op, code);
		  if code = 0 then 
		     si.delim.type = SS_length;
		  else if code = error_table_$out_of_bounds then do;
		     call ck_err (code, ep, BAD_DELIM_LENGTH, arg, op, op, arg, op);
		     end;
		  else if substr(op,1,1) = "/" & substr(op,length(op),1) = "/" & length(op)>2 then do;
		     si.delim.type = SS_reg_exp;
		     si.delim.string = substr(op,2,length(op)-2);
		     end;
		  else do;
		     si.delim.type = SS_string;
		     si.delim.string = op || NL;
		     end;
		  end;
	         end;
	      end;

	   else if (arg = "-replace" | arg = "-rp") &	/* process sort_output_pathname control args.	*/
		  ep = "sort_seg" then
	      sort_output = REPLACE;
	      
	   else if (arg = "-output_file" | arg = "-of" |
		  arg = "-segment" | arg = "-sm") &
		  ep = "sort_seg" then do;
	      sort_output = SEGMENT;
	      if get_op ("^a requires pathname of output segment as an operand.", arg) then do;
	         call expand_pathname_ (op, out_dir, out_ent, code);
	         call ck_err (code, ep, "^a ^a", arg, op);
	         end;
	      end;

	   else					/* bad control argument.			*/
	      call ck_err (error_table_$badopt, ep, arg);
	   end;

	if Iarg_pass = 1 then do;			/* Must reprocess args to correctly apply the	*/
	   if Serror then go to RETURN;		/*   defaults for -asc/-dsc, -cs/-ncs, and	*/
	   if field_sort = ALL | si.field_count = 0 |	/*   -ch/-num/-int to field structure.		*/
	      field_sort = ORDERED_FIELD then;		/* Of course, if no field structure was built in	*/
	   else do;				/*   first pass, then a second pass isn't needed. */
	      in_dir = "";
	      Lstring = 0;
	      call prepare_to_reprocess_args();
	      si.field_count = 0;			/* or else we end up with twice as many */
	      go to REPROCESS_ARGS;
	      end;
	   end;

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* FINAL STEPS:								*/
	/* 1) Set defaults for args not given by user.					*/
	/* 2) Check consistency of all arguments.  Make sure needed info was supplied.		*/
	/* FOR sort_seg:								*/
	/* 3) If neither -replace nor -output_file was given, query user to overwrite segment.	*/
	/* 4) Call sort_seg_ to do the actual sorting.  It will report any errors encountered	*/
	/*    during the sorting process.  It checks access to the segments, creates the output	*/
	/*    seg if needed, validates qedx regular expressions, etc.			*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	if si.duplicate_mode = SS_unset then		/* Set default duplicate mode if user gave none.	*/
	   si.duplicate_mode = SS_duplicates;

	if ep = "sort_strings" then do;		/* Set delimiter chosen by add_to_string rtn.	*/
	   si.delim.type = SS_string;
	   si.delim.string = delimiter;
	   end;
	else if si.delim.type = SS_unset then do;	/* Set default sort string delimiter, a NL	*/
	   si.delim.type = SS_string;
	   si.delim.string = NL;
	   end;

	if field_sort = ALL then			/* If -all given, or none of -all/-field/-ofl	*/
	   si.field_count = 0;			/*   given, mark that no sort fields were defined.*/
	if si.field_count = 0 then do;		/* When no sort fields are defined, make one which*/
	   si.field_count = 1;			/*   encompasses the entire sort unit.		*/
	   si.field(1).from.type = SS_index;
	   si.field(1).from.number = 1;
	   si.field(1).to.type = SS_length;
	   si.field(1).to.number = -1;
	   si.field(1).modes = FALSE;
	   si.field(1).modes.descending = Sdescending;
	   si.field(1).modes.non_case_sensitive = Snon_case_sensitive;
	   si.field(1).modes.numeric = Snumeric;
	   si.field(1).modes.integer = Sinteger;
	   end;
	else if field_sort = ORDERED_FIELD then do;	/* For old -order_field, if -descending is given	*/
	   if descending_sort = DESCENDING then		/*   then invert meaning of all sort_direction	*/
	      si.field(*).modes.descending = ^si.field(*).modes.descending;
	   if Snon_case_sensitive then		/*   switches in sort_info struc, and apply -ncs. */
	      si.field(*).modes.non_case_sensitive = TRUE;
	   end;

	Serrors_are_fatal = TRUE;			/* From this point on, any error aborts command.	*/
	if ep = "sort_strings" then			/* Branch to code below for rest of sort_strings	*/
	   go to SORT_STRINGS;			/*   processing.				*/

	if in_dir = "" then				/* Complain if no sort_input_pathname given.	*/
	   call ck_err (error_table_$noarg, ep, "Input pathname required.
Usage:	ss sort_input_pathname {-control_args}");
	call hcs_$status_minf (in_dir, in_ent, CHASE, type, bc, code);
	if code ^= 0 then 
	   call ck_err (code, ep, "^a^[>^]^a", in_dir, in_dir^=">", in_ent);
	else if type ^= SEGMENT then 
	   call ck_err (error_table_$dirseg, ep, "^a^[>^]^a",
	      in_dir, in_dir^=">", in_ent);
	else if bc = 0 then 
	   call ck_err (error_table_$zero_length_seg, ep, "Sort input segment is empty
(^a^[>^]^a).", in_dir, in_dir^=">", in_ent);

	if sort_output = REPLACE then do;		/* If -replace, sort_output_path = sort_input_path*/
	   out_dir = in_dir;
	   out_ent = in_ent;
	   end;
	else if sort_output = SS_unset & ^Serror then do; /* Neither -rp nor -of given?  Query to overwrite */
	   call user_info_$absentee_queue  (q);		/* if this is an interactive invocation.	*/
	   if q = -1 then
	      call command_query_$yes_no (Syes, 0, ep, 
"If you want to sort ^a^[>^]^a
and overwrite the segment with the sorted results, reply yes.
Otherwise, reply no.  Overwrite the segment?", "Do you want to overwrite segment ^a^[>^]^a?",
	         in_dir, in_dir^=">", in_ent);
	   else Syes = TRUE;			/* if absentee, assume user wants to overwrite.	*/
	   if ^Syes then				/* Don't overwrite?  An error has occurred.	*/
	      Serror = TRUE;
	   else do;				/* Do overwrite?  Equate input and output paths.	*/
	      out_dir = in_dir;
	      out_ent = in_ent;
	      end;
	   end;
	else if ^Serror then do;			/* If -output_file,  apply equal convention to	*/
	   call get_equal_name_ (in_ent, out_ent, equal_ent, code);
						/*    make sort_output_pathname.		*/
	   call ck_err (code, ep, "^a applied to ^a",
	      out_ent, in_ent);
	   out_ent = equal_ent;
	   end;

	if Serror then go to RETURN;			/* An error occurred.  Don't do sorting.	*/

	on sub_error_ call sub_error_handler;

	call sort_seg_$seg (ep, addr(si), in_dir, in_ent, out_dir, out_ent,
	   out_len, undelim_char_index, code);		/* This subr does the work.			*/

RETURN:	if ep = "sort_strings" then
	   call release_temp_segment_ (ep, Pstring, code);
	return;					/* Simple, huh?				*/

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* FOR sort_strings:							*/
	/* 1) Be sure that an input string was provided.					*/
	/* 2) Create space for output string.  If the input string currently fills more than	*/
	/*    half of the temp segment, then the output string will overlay the input string and	*/
	/*    sort_seg_$string will handle the overlay by sorting into a second temp string and	*/
	/*    then copying the sorted result back.					*/
	/* 3) Establish sub_error_ handler to intercept error reports from sort_seg_.		*/
	/* 4) Call sort_seg_$string to process the input string.				*/
	/* 5) For active function output, add sorted string components to AF return arg,	*/
	/*    requoting each one to be sure it is treated as an individual value.		*/
	/* 6) For command output, output the sorted string components on a many-per-line basis,	*/
	/*    using multiple lines to prevent lines from overflowing.  Also,  requote components	*/
	/*    which contain a SPACE or TAB to prevent them from appearing as multiple components	*/
	/*    in the sorted list.							*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

SORT_STRINGS:
	if Lstring = 0 then 
	   call ck_err (-1, ep, "No input strings were given.");

	Lout_string = divide (length(string)+3, 4, 21, 0) * 4;
	if Lout_string + Lout_string <= MLstring then 
	   Pout_string = addcharno (Pstring, Lout_string);
	else do;
	   Pout_string = Pstring;
	   Lout_string = Lstring;
	   end;

	on sub_error_ call sub_error_handler;

	call sort_seg_$string (ep, addr(si), string, out_string, Lout_string,
	   undelim_char_index, code);

	if code = 0 then do;
	   if Saf then do;
	      do while (get_out_string_component());
	         call add_to_return_arg (out_string_component);
	         end;
	      end;
	   else do;
	      call output_string$init();
	      do while (get_out_string_component());
	         call output_string (out_string_component);
	         end;
	      call output_string$term();
	      end;
	   end;
	go to RETURN;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* 		I  N  T  E  R  N  A  L        P  R  O  C  E  D  U  R  E  S		*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

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

    dcl	Lout_string		fixed bin(21),
       	Lstring			fixed bin(21),
	Lout_string_component	fixed bin(21),
	MLstring			fixed bin(21),
	Pout_string		ptr,
	Pout_string_component	ptr,
	Pstring			ptr,
	delimiter			char(1),
         (get_temp_segment_, 
	release_temp_segment_)	entry (char(*), ptr, fixed bin(35)),
	possible_delimiters		char(512) varying,
	out_string		char(Lout_string) based(Pout_string),
	out_string_ch (Lout_string)	char(1) based(Pout_string),
	out_string_component	char(Lout_string_component) based(Pout_string_component),
	string			char(Lstring) based(Pstring),
	sys_info$max_seg_size	fixed bin(35) ext static;

add_to_string:
	proc (arg);

    dcl	arg			char(*);

    dcl	Istring_new		fixed bin(21),
	new_delimiter		char(1);

    dcl  (collate9, reverse, translate) builtin;

	if index(arg, delimiter) > 0 then do;		/* Insure string delimiter does not appear in any */
NEED_NEW_DELIMITER:					/*   string.				*/
	   if possible_delimiters = "" then do;
	      Serrors_are_fatal = TRUE;
	      call ck_err (-1, ep,
"The strings to be sorted use every character in the collate9 sequence.
Therefore the strings cannot be sorted.");
	      end;
	   new_delimiter = substr(possible_delimiters,1,length(delimiter));
	   possible_delimiters = substr(possible_delimiters,length(delimiter)+1);
	   if index(string,new_delimiter) + index(arg,new_delimiter) > 0 then
	      go to NEED_NEW_DELIMITER;
	   string = translate (string, new_delimiter, delimiter);
             delimiter = new_delimiter;
	   end;
	if length(string) + length(arg) + length(delimiter) > MLstring then do;
	   Serrors_are_fatal = TRUE;
	   call ck_err (error_table_$too_many_args, ep, 
"The temp segment holding strings to be sorted has overflowed.");
	   end;
	Istring_new = length(string) + 1;
	Lstring = length(string) + length(arg) + length(delimiter);
	substr(string, Istring_new) = arg;
	substr(string, length(string), 1) = delimiter;
	return;


add_to_string$init:
	entry;

	delimiter = NL;
	possible_delimiters = reverse(collate9());
	Lstring = 0;
	MLstring = sys_info$max_seg_size * 4;
	call get_temp_segment_ (ep, Pstring, code);
	if code ^= 0 then do;
	   Serrors_are_fatal = TRUE;
	   call ck_err (code, ep, "Getting a temp segment.");
	   end;
	return;

get_out_string_component:
	entry returns(bit(1));

	if length(out_string) = 0 then
	   return (FALSE);
	Lout_string_component = index(out_string, delimiter);
	Pout_string_component = addr(out_string);
	if length(out_string) > length(out_string_component) then
	   Pout_string = addr(out_string_ch(length(out_string_component)+1));
	Lout_string = length(out_string) - length(out_string_component);
	Lout_string_component = Lout_string_component - length(delimiter);
	return (TRUE);

	end add_to_string;

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


    dcl	Serror			bit(1),		/* On if fatal error has occurred.		*/
       	Serrors_are_fatal		bit(1);		/* On if errors are fatal.			*/

ck_err: 	proc options(variable);			/* Procedure to report errors via com_err_ or	*/
						/*   active_fnc_err_, as appropriate.  This proc	*/
						/*   has same calling sequence as com_err_.	*/

    dcl	code			fixed bin(35) based (Pcode),
	Pcode			ptr;

    dcl	cu_$arg_list_ptr		entry returns(ptr),
	cu_$arg_ptr		entry (fixed bin, ptr, fixed bin(21), fixed bin(35)),
	cu_$generate_call		entry (entry, ptr);

	call cu_$arg_ptr (1, Pcode, 0, 0);		/* Access error table code argument.		*/
	if code = 0 then return;			/* If non-zero, this ISN'T an error.		*/
	if code = -1 then code = 0;			/* No error table code fits the desired err msg.	*/
	Serror = TRUE;				/* Record fact that an error occurred.		*/
	call cu_$generate_call (err, cu_$arg_list_ptr()); /* Actually call com_err_ or active_fnc_err_.	*/
	if Serrors_are_fatal then
	   go to RETURN;

	end ck_err;

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


cv_num:	proc (op, err_msg, arg) returns(fixed bin);	/* Number conversion  internal proc.  Main 	*/
						/* entry point calls ck_err if an error occurs.	*/

    dcl	op			char(*),
	err_msg			char(*),
	arg			char(*);

    dcl	Ssuppress_error		bit(1),
	code			fixed bin(35),
	conversion		condition,
	n			fixed bin,
	size			condition;

	Ssuppress_error = FALSE;
	go to COMMON;

cv_num_no_errors:					/* Special entry point returns -2 if an error	*/
	entry (op, Acode) returns(fixed bin);		/* occurs in conversion, or actual value	*/
						/* if a non-positive number is given.		*/

    dcl	Acode			fixed bin(35);

	Ssuppress_error = TRUE;
	Acode = 0;
	if op = "" then do;
	   code = error_table_$bad_arg;
	   go to OP_NOT_NUMERIC;
	   end;

COMMON:	on conversion begin;
	   code = error_table_$bad_arg;
	   n = -2;				/* Use PL/I to do conversion, check for errors.	*/
	   go to OP_NOT_NUMERIC;
	   end;
	on size begin;
	   code = error_table_$out_of_bounds;
	   n = -2;
	   go to OP_NOT_NUMERIC;
	   end;
	n = convert(n, op);
	revert conversion, size;
	if n < 1 then do;
	   code = error_table_$out_of_bounds;
OP_NOT_NUMERIC:
	   if Ssuppress_error then
	      Acode = code;
	   else
	      call ck_err (code, ep, "^a ^a^/" || err_msg, arg, op_list, arg);
	   end;
	return (n);

	end cv_num;

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


estimate_fields:					/* Internal proc to estimate number of fields	*/
	proc returns(fixed bin);			/* needed in sort info structure, based upon	*/
						/* number of arguments given  to sort_seg command.*/
						/* It never under-estimates.			*/

    dcl	Nargs			fixed bin,	/* Use of this procedure allows use to get	*/
	Nfields			fixed bin;	/* generation of storage for structure in 	*/
						/* automatic storage of main procedure.		*/

    dcl	cu_$af_arg_count		entry (fixed bin, fixed bin(35));

	call cu_$af_arg_count (Nargs, 0);
	Nfields = divide(Nargs-2, 2, 17, 0);
	Nfields = max (Nfields, 1);
	return (Nfields);

	end estimate_fields;

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


    dcl	Iarg			fixed bin,	/* Current argument being processed.		*/
       	Iarg_pass			fixed bin,	/* Number of time arg list has been processed.	*/
	Larg			fixed bin(21),	/* Length of current argument.		*/
	Lop			fixed bin(21),	/* Length of current ctl arg operand.		*/
	Lop2			fixed bin(21),
	Lret			fixed bin(21),	/* Max length of AF return value.		*/
	Nargs			fixed bin,	/* Number of arguments.			*/
	Parg			ptr,		/* Ptr to current argument.			*/
	Parg_list			ptr,		/* Ptr to command/af's argument list.		*/
	Pop			ptr,		/* Ptr to current operand.			*/
	Pop2			ptr,
	Pret			ptr,		/* Ptr to AF return value.			*/
	Saf			bit(1),		/* On if invoked as an active function.		*/
	arg			char(Larg) based(Parg),
	ep			char(12),
	op			char(Lop) based(Pop),
	op2			char(Lop2) based(Pop2),
	ret			char(Lret) varying based(Pret),
         (arg_ptr			variable,
	cu_$af_arg_ptr_rel,
	cu_$arg_ptr_rel)		entry (fixed bin, ptr, fixed bin(21), fixed bin(35), ptr),
	cu_$af_return_arg		entry (fixed bin, ptr, fixed bin(21), fixed bin(35)),
       	cu_$arg_list_ptr		entry returns(ptr),
         (err			variable,
	active_fnc_err_,		
	com_err_)			entry() options(variable);
	

get_invocation_type:				/* Were we invoked as command or af?  Arg count?	*/
	proc (entrypoint, Saf, Nargs, code);

    dcl	entrypoint		char(*),
	Saf			bit(1),
	Nargs			fixed bin,
	code			fixed bin(35);

	ep = entrypoint;
	Serrors_are_fatal = FALSE;
	call cu_$af_return_arg (Nargs, Pret, Lret, code);
	if code = 0 then do;
	   Saf = TRUE;
	   arg_ptr = cu_$af_arg_ptr_rel;
	   err = active_fnc_err_;
	   ret = "";
	   end;
	else do;
	   Saf = FALSE;
	   arg_ptr = cu_$arg_ptr_rel;
	   err = com_err_;
	   end;
	Serror = FALSE;				/* No errors so far.			*/
	Parg_list =  cu_$arg_list_ptr();		/* Remember arg list ptr for subrs below.	*/
	Iarg_pass = 0;


prepare_to_reprocess_args:
	entry;

	Iarg = 0;					/* No args processed so far.			*/
	Iarg_pass = Iarg_pass + 1;

	end get_invocation_type;
       

get_arg:	proc returns(bit(1));			/* Returns TRUE if another argument exists.	*/
						/*   Its value is accessible via arg variable.	*/

	if Iarg+1 > Nargs then
	   return(FALSE);
	Iarg = Iarg + 1;
	call arg_ptr (Iarg, Parg, Larg, code, Parg_list);
	return(TRUE);

get_op:	entry (err_msg, arg) returns(bit(1));		/* Internal proc to get control arg operands.	*/
						/* Besides getting the operands, (in op or op2	*/
    dcl	err_msg			char(*),		/* variables), it catenates them together in the	*/
	arg			char(*);		/* op_list variable for use in error msgs.	*/

	op_list = "";				/* First operand of a control arg, or first of a	*/
						/* triplet of operands assoc with -field or -ofl. */

get_op1:	entry (err_msg, arg) returns(bit(1));		/* First of operand group forming second element	*/
						/* of a -field triplet.			*/

	if Iarg = Nargs then do;
	   if err_msg ^= "" then 
	      call ck_err (error_table_$noarg, ep, "^a ^a^/" ||
	         err_msg, arg, op_list, arg);
	   return (FALSE);
	   end;
	else do;
	   Iarg = Iarg + 1;
	   call arg_ptr (Iarg, Pop, Lop, code, Parg_list);
	   if op = "" then do;
	      if err_msg ^= "" then
	         call ck_err (error_table_$bad_arg, ep, "^a^[ ^a^;^s^] ""^va""^/" ||
		  err_msg, arg, op_list^="", op_list, length(op), op, arg);
	      return (FALSE);
	      end;
	   call add_op_to_list (op);
	   return (TRUE);
	   end;


get_op2:	entry (err_msg, arg, Scheck_nulls) returns(bit(1));
						/* Next of operand group.			*/

    dcl	Scheck_nulls		bit(1);

	if Iarg = Nargs then do;
	   call ck_err (error_table_$noarg, ep, "^a ^a^/" ||
	      err_msg, arg, op_list, arg);
	   return (FALSE);
	   end;
	else do;
	   Iarg = Iarg + 1;
	   call arg_ptr (Iarg, Pop2, Lop2, code, Parg_list);
	   if Scheck_nulls & op2 = "" then do;
	      call ck_err (error_table_$bad_arg, ep, "^a ^a ""^va""^/" ||
	         err_msg, arg, op_list, length(op), op, arg);
	      return (FALSE);
	      end;
	   call add_op_to_list (op2);
	   return (TRUE);
	   end;

add_op_to_list:					/* Internal proc of get_op to add new operand to	*/
	proc (op);				/* op_list variable.			*/

    dcl	op			char(*);

	if length(op) = 0 | search(op, " ""()[];	") > 0 then
	   op_list = op_list || requote_string_ (op);
	else
	   op_list = op_list || op;
	op_list = op_list || " ";

	end add_op_to_list;


add_to_return_arg:
       	entry (arg);

	if ret ^= "" then
	   ret = ret || " ";
	ret = ret || requote_string_ (arg);

	end get_arg;

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


    dcl	Loutput_line		fixed bin,
	MLoutput_line		fixed bin,
	get_line_length_$switch	entry (ptr, fixed bin(35)) returns(fixed bin);

output_string:
       	proc (arg);

    dcl	arg			char(*);

    dcl	IHT_SP			fixed bin(21),
	HT_SP			char(2) int static options(constant) init("	 "),
	Lrq_arg			fixed bin(21),
	SP			char(1) int static options(constant) init(" "),
	ioa_$nnl			entry() options(variable);

	IHT_SP = search(arg, HT_SP);
	if IHT_SP > 0 then
	   Lrq_arg = length(requote_string_(arg));
	else
	   Lrq_arg = length(arg);

	if Loutput_line = 0 then do;
OUTPUT_AT_BEGINNING_OF_LINE:
	   if IHT_SP > 0 then 
	      call ioa_$nnl ("^a", requote_string_(arg));
	   else 
	      call ioa_$nnl ("^a", arg);
	   Loutput_line = Lrq_arg;
	   end;

	else if Loutput_line + length(SP) + Lrq_arg <= MLoutput_line then do;
	   if IHT_SP > 0 then
	      call ioa_$nnl (" ^a", requote_string_(arg));
	   else
	      call ioa_$nnl (" ^a", arg);
	   Loutput_line = Loutput_line + length(SP) + Lrq_arg;
	   end;

	else do;
	   call ioa_$nnl ("^/");
	   go to OUTPUT_AT_BEGINNING_OF_LINE;
	   end;
	return;


output_string$init:
	entry;

	MLoutput_line = get_line_length_$switch (null, code);
	if code ^= 0 then MLoutput_line = 136;
	Loutput_line = 0;


output_string$term:
	entry;

	if Loutput_line > 0 then
	   call ioa_$nnl ("^/");

	end output_string;

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

sub_error_handler:
     proc;

/* Sub_error procedure, prints a message and cleans up */

     dcl   code                         fixed bin(35);
     dcl 1 cond_info                    like condition_info;
     dcl   find_condition_info_	entry (ptr, ptr, fixed bin (35));
     dcl   null                         builtin;
     dcl 1 sub_err_info                 like sub_error_info based (cond_info.info_ptr);

     call find_condition_info_ (null(), addr (cond_info), code);

     Serrors_are_fatal = FALSE;

     call ck_err (sub_err_info.header.status_code, ep, sub_err_info.info_string);

     end sub_error_handler;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

%include sort_seg_info;
%page;
%include condition_info;
%page;
%include sub_error_info;
%page;
%include condition_info_header;

	end sort_seg;




		    sort_seg_.pl1                   10/24/88  1658.1r w 10/24/88  1359.2      924300



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


/****^  HISTORY COMMENTS:
  1) change(74-01-01,Klinger), approve(), audit(), install():
      Written 1974 by Ross Klinger.
  2) change(75-08-16,Grady), approve(), audit(), install():
      Modified by Mike Grady to process -ordered_fields.
  3) change(82-05-05,GDixon), approve(), audit(), install():
      Modified by Gary Dixon to greatly extend and document the
      interface.
  4) change(83-04-17,Schimke), approve(), audit(), install():
      Modified by Dave Schimke to add linus_table entrypoint
      reorganizing the code into several internal procedures and
      add numeric sort mode.
  5) change(83-07-22,Schimke), approve(), audit(), install():
      Modified by Dave Schimke to fix bug in -to regular expression
      handling, add integer sort and replace calls to search_file_
      with calls to search_file_$silent.
  6) change(84-12-14,Lippard), approve(85-01-16,MCR7139),
     audit(85-12-16,GDixon), install(85-12-17,MR12.0-1001):
      Modified by Jim Lippard to properly initialize case_regexp
      array and properly sort numeric fields.
  7) change(86-09-16,Lippard), approve(86-09-29,MCR7551),
     audit(86-10-13,Dickson), install(86-10-17,MR12.0-1188):
      Modified to make sort_seg_$string clean up its temp segments on
      normal exit.
  8) change(87-05-08,Hergert), approve(87-05-08,MCR7671),
     audit(87-05-08,Dupuis), install(87-05-20),MR12.1-1032):
      Modified to not miss the last tuple of each component of an MSF.
                                                   END HISTORY COMMENTS */



	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* Name: sort_seg_								*/
	/*									*/
	/* Subroutine for sorting segments or strings, based upon one or more sort fields within	*/
	/* sort units.								*/
	/*									*/


	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* OVERVIEW OF THE SORTING PROCESS:						*/
	/*									*/
	/* Overview: Sorting is performed by dividing the input up into delimited sort strings,	*/
	/* and then blocking some number of strings (1 or more, EXCLUDING the delimiters)	*/
	/* together to form sort units.  Sorting is done by comparing these sort units, and then	*/
	/* reordering the delimited sort strings based upon the sort results.  The sort units	*/
	/* are compared by identifying one or more sort fields within each sort unit, and then	*/
	/* comparing the contents of sort fields in one unit with corresponding fields in	*/
	/* another unit.  A single sort field may encompass the entire sort unit, or only a part	*/
	/* of it.  Fields may be compared in ascending or descending order, with or without	*/
	/* sensitivity to letter case.						*/
	/*									*/
	/* To begin the sorting process, the input is divided into delimited strings, and the	*/
	/* strings are blocked into delimited units (du's), which are the sort strings and	*/
	/* delimiters blocked to form the du.  It is these delimited units which are reordered 	*/
	/* in the sorted output.						          */
	/*									*/
	/* In order to perform a comparison, the delimiter(s) must be removed from the du to	*/
	/* form an undelimited unit (uu).  Finally, the sort fields are identified in the uu,	*/
	/* and copied with optional translation to implement non_case_sensitive and descending	*/
	/* sorts.									*/
	/*									*/
	/* The du's are identified by pointer/length pairs (dup/dul) which overlay the actual	*/
	/* input.  These are stored in a pair of structures.  The uu's (du's with the delimiters	*/
	/* removed) are constructed in a temp seg (uu_str), and identified by pointer/length	*/
	/* pairs (uup/uul).  Sort fields from each uu are copied in field order into a temp	*/
	/* segment (sf_str) identified by a pointer (sfp) and a fixed length (Lall_fields).	*/
	/* Each field is translated to lowercase/inverted to implement			*/
	/* non_case_sensitive/descending comparison of a field.  Numeric fields are converted to  */
	/* float dec(59) values, then encoded as character strings for sorting.  Similarly,       */
	/* integer fields are converted to fixed bin(71) values, and then encoded as character    */
	/* strings for sorting.  This grouping of fields allows a single pass sort to perform     */
	/* multi-field comparison operations.  A stability field is added to the end of each      */
	/* group of sort fields to insure that groups having the same value appear in the output  */
	/* in their original order.           	                                                  */
          /*                                                                                        */
	/* Of course, in special cases, some of the steps above can be bypassed for efficiency.	*/
	/* In fact, the most common types of sorts can be special-cased to improve efficiency.	*/
	/* For example, when sort string delimiters are fixed-length and the blocking factor is	*/
	/* 1, there is no need to determine the dul values.  These can be computed from uul	*/
	/* plus the length of the fixed delimiter.  When blocking factor is 1, copying the	*/
	/* undelimited unit into uu_str can be avoided by treating each du minus the delimiter	*/
	/* as the undelimited unit.  Thus dup = uup, so uup need not be set.  Several other,	*/
	/* similar special cases are used to further improve efficiency when possible.		*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

sort_seg_:
	procedure;
	return;

    dcl	lcb_ptr                       ptr,                /* linus control block ptr for table entry (In)   */
          caller			char(*),		/* name of calling command. (In)		*/
	desc_array                    (*) ptr,            /* descriptors (or place holders) for each sort   */
						/* field for numeric sort on table entrypoint     */

	in_dir			char(*),		/* dir part of input seg pathname. (In)		*/
	in_ent			char(*),		/* entry part of input seg pathname (In)	*/
	in_ptr                        ptr,                /* pointer to the table rows structure (In)       */
	in_string			char(*),		/* input string to be sorted. (In)		*/
	out_dir			char(*),		/* dir part of output seg pathname (In)		*/
	out_ent			char(*),		/* entry part of output seg pathname (In)	*/
          out_ptr                       ptr,                /* ptr to the sorted table structure (In)         */
	out_string		char(*),		/* output string in which sorted results go. (Out)*/
	out_len			fixed bin(21),	/* length (in chars) of sorted output seg. (Out)	*/
	temp_dir                      char (*),           /* pathname of dir to be used for temp segs (In)  */
	temp_seg_mgr$get		entry (ptr, char(*), char(*), ptr, fixed bin(35)),
	temp_seg_mgr$release	entry (ptr, char(*), ptr, fixed bin(35)),
	undelim_char_index		fixed bin(21),	/* index in output of first char of an undelimited*/
						/*   string.  Any string not followed by a	*/
						/*   delimiter is treated as such an undelimited	*/
						/*   string. (Out)				*/
	code			fixed bin(35);	/* status code. (Out)			*/

    dcl	Ibk			fixed bin(21),	/* number of sort strings in this sort unit so far*/
	Ichar			fixed bin(21),
          Icomp        	          fixed bin(21),	/* index of components being sorted.              */
	Idu			fixed bin(21),	/* index in input of start of delimited sort unit	*/
	Iend			fixed bin(21),	/* index in a sort unit of last char of a field.	*/
	If			fixed bin,	/* index into field specification array.	*/
	Iline_end			fixed bin(21),
	Imatch			fixed bin(21),	/* index in input of first char matching delimiter*/
	Imatch_end		fixed bin(21),	/* index in input of last char matching delimiter */
          Imerge                        fixed bin,          /* index of the table component to be merged      */
          Iptr                          fixed bin(21),      /* row ptr index in table ptr seg                 */
	Inl			fixed bin(21),
          Iseg                          fixed bin,          /* index in array of ptr segs of table structure  */
	Isf_str			fixed bin(21),	/* index of next, unsused char in sf_str string.	*/
	Iss			fixed bin(21),	/* index in input of start of next sort string.	*/
	Istart			fixed bin(21),	/* index in a sort unit of start char of a field. */
	Its                           fixed bin,          /* index in array of saved temp segs              */
	Iu			fixed bin(21),	/* index of a sort unit.			*/
	Iu_prev			fixed bin(21),	/* index of sort unit prior to Iu (in sorted ord) */
	Iuss			fixed bin(21),	/* index in input of start of this sort string.	*/
	Iuu			fixed bin(21),	/* index in uu_str of start of next sort unit.	*/
	Iuu_str			fixed bin(21),	/* index in uu_str of next, unused character.	*/
	Ix			fixed bin(21),	/* index into idx array of sorted unit indices.	*/
	Lall_fields		fixed bin(24),	/* combined length of all sort unit fields.	*/
	Ldelim			fixed bin(21),	/* length of fixed-sized sort string delims.	*/
	Ldss			fixed bin(21),	/* length of sort string with its delimiter.	*/
	Ldu			fixed bin(21),	/* length of delimited sort unit.		*/
	Ldu_prev			fixed bin(21),	/* length of prior delimited sort unit.		*/
         (Lin, Lout)	          fixed bin(21),
	Lmatch			fixed bin(21),	/* length of part of input matching delimter.	*/
	Luss			fixed bin(21),	/* length of sort string without its delimiter.	*/
	Luu			fixed bin(21),	/* length of undelimited sort unit		*/
	Luu_str			fixed bin(21),	/* length of used portion of uu_str.		*/
	Luu_temp			fixed bin(21),	/* length of uu_temp (temp copy of uu + NL).	*/
	Ndups			fixed bin(21),	/* number of duplicate sort units in a row.	*/
	Ndups_prev		fixed bin(21),	/* value of Ndups when prev sort unit was examined*/
						/*   0 = no duplicates			*/
						/*   1 = 1 duplicate, etc			*/
	Nlines			fixed bin(21),
	Nsf_str_array		fixed bin,
    	Nu			fixed bin(24),	/* number of sort units.                          */
         (Oin, Oout)		fixed bin(21),	/* offsets of input/output strings from start of	*/
						/*   their containing segments.		*/
         (Paccess, Pin, Pout)	          ptr,
         (Pdul, Pdup, Pidx, Pout_real, Pout_temp, Psf_str, Psfa(64), Psfl, Psfp, Puu_str, Puu_temp, Puul, Puup)
				ptr,		/* ptrs to temp segments.			*/
         (Psave, Pspp, Psup, Psupo, Psppo)
                                        ptr,		/* ptrs to linus_table structures.                */
         (Pidx1, Pidx_merge, Psfp1, Psfp_merge, Psf1, Psf_merge)  
                                        ptr,		/* ptrs to merge overlays and sort fields         */

	Psf_str_array (Nsf_str_array) ptr based (addr(Psfa)),
	Screated_output_seg		bit(1),
	Sblocked			bit(1),		/* sort strings are blocked several to a sort unit*/
	Sdescending_sort		bit(1),		/* If only one sort field spanning entire unit is */
						/*   given, descending sort can be implemented	*/
						/*   most efficiently as a special case.	*/
	Sfield			bit(1),		/* sort field(s) include only part of each sort 	*/
						/*   unit, not 1 field spanning entire unit.	*/
	Snon_case_sensitive_sort	bit(1),		/* If only one sort field spanning entire unit is */
						/*   given, non_case_sensitive translating must be*/
						/*   done as special case.			*/
          Snumeric                      bit(1),             /* Are any sort modes numeric?                    */
	Soverlap			bit(1),		/* Input and output overlaps, forcing placement	*/
						/*   of sort output in a temp seg.		*/
	Stemp_dir			bit(1),		/* If temp dir is to be used for temp segs.       */
	Svarying_delimiters		bit(1),		/* A regular expression delimits records.  Since	*/
						/*   the strings matching regexp are of varying	*/
						/*   length, we must record total length of each	*/
						/*   sort unit, including its delimiters.	*/
	Svarying_fields		bit(1),		/* sort fields have varying widths.		*/
	Syes			bit(1),
         (bc_in, bc_out)		fixed bin(24),
	component_number              fixed bin,	/* index of table components                      */
          comp_base_number              bit(18),
	encd_len                      fixed bin(21),
	encd_str                      char(256),
	id			char(15) varying,
          max_Lout                      fixed bin(21);
    dcl	stable			char(4) based(addr(Iu));

    dcl	in			char(Lin) based(Pin),
	in_char (Lin)		char(1) based(Pin),
	out			char(max_Lout) based(Pout);

    dcl	1 idx			aligned based(Pidx),
	  2 N			fixed bin(24),	/* array of sorted sort unit indices.		*/
	  2 I (Nu)		fixed bin(24),
	du			char(Ldu) based(dup.P(Iu)),
	du_prev			char(Ldu_prev) based(dup.P(Iu_prev)),
	1 dup			aligned based(Pdup),/* delimited units - (as in original input)	*/
	  2 N			fixed bin(24),	/*   ptrs to original sort units including their	*/
	  2 P (Nu)		ptr unal,		/*   delimiters.				*/
	1 dul			aligned based(Pdul),/*   lengths of original sort units, including	*/
	  2 N			fixed bin(24),	/*   their delimiters.			*/
	  2 L (Nu)		fixed bin(24);
	


						/* LINUS_TABLE structures                         */
    dcl	1 idx1			aligned based (Pidx1), 
	  2 N			fixed bin(24),	/* merge sort indices                             */
	  2 I (idx1.N)
	                              fixed bin(24),

	1 idx_merge		aligned based (Pidx_merge),
	  2 N			fixed bin(24),	/* merge sort indices                             */
	  2 I (idx_merge.N)
	                              fixed bin(24),

	1 sfp1			aligned based (Psfp1),
	  2 N			fixed bin(24),	/* merge sort field overlay                       */
	  2 P (sfp1.N)
	                              ptr unal,

	1 sfp_merge		aligned based (Psfp_merge),
	  2 N			fixed bin(24),	/* merge sort field overlay                       */
	  2 P (sfp_merge.N)
	                              ptr unal,

          sf1                           char(Lall_fields) based (Psf1),
          sf_merge                      char(Lall_fields) based (Psf_merge),

          1 supo                        aligned based (Psupo),
            2 N                         fixed bin (21),	/* ptrs to the table rows.                        */
            2 P (supo.N)                ptr unal,
          1 sppo                        based (Psppo),
            2 N                         fixed bin,
            2 P (sppo.N)                ptr unal,
          1 save                        aligned based (Psave),
            2 N                         fixed bin,	/* saved ptrs for merging.                        */
            2 Nsf_strs                  fixed bin,          
            2 dup_ptr (save.N)          ptr,		/* row ptrs                                       */
            2 idx_ptr (save.N)          ptr,		/* sorted indices                                 */
            2 sfp_ptr (save.N)          ptr,		/* sort fields                                    */
            2 sf_str_ptr (save.Nsf_strs)
                                        ptr,		/* sort strings                                   */

          1 spp                         aligned based(Pspp),/* ptrs to the sup segments and msf components.   */
            2 N                         fixed bin,
	  2 M                         fixed bin,
	  2 sorted                    bit (1),     
	  2 P (spp.N)                 ptr unal,
	  2 C (spp.M)                 ptr unal,

          1 sup                         aligned based (Psup),/* ptrs to the table rows                        */
            2 N                         fixed bin (21),
            2 P (sup.N)                 ptr unal;		

	
						/* undelimited units			*/
    dcl	uu			char(uul.L(Iu)) based(uup.P(Iu)),
	uu_str			char(Luu_str) based(Puu_str),
	uu_str_char (Luu_str)	char(1) based(Puu_str),
	uu_temp                       char(Luu_temp) based (Puu_temp),
	1 uup			aligned based(Puup),/*   ptrs to blocked sort units containing 	*/
	  2 N			fixed bin(24),	/*   several sort strings without their delimiters*/
	  2 P (Nu)		ptr unal,
	1 uul			aligned based(Puul),/*   lengths of undelimited units.		*/
	  2 N			fixed bin(24),
	  2 L (Nu)		fixed bin(24),

						/* sort fields				*/
	sf			char(Lall_fields) based(sfp.P(Iu)),
	sf_ncs			char(sfl.L(Iu)) based(sfp.P(Iu)),
	sf_prev			char(Lall_fields) based(sfp.P(Iu_prev)),
	sf_str			char(max_seg_size) based(Psf_str),
						/*   string containing ordered sort fields built	*/
						/*   from all sort units.  Field groups from all	*/
						/*   units have the same length.		*/
	sf_str_char (max_seg_size)	char(1) based(Psf_str),
	1 sfp			aligned based(Psfp),/*   ptrs to sort fields from each unit.	*/
	  2 N			fixed bin(24),
	  2 P (Nu)		ptr unal,
	1 sfl			aligned based(Psfl),
	  2 N			fixed bin(24),
	  2 L (Nu)		fixed bin(24);

    dcl	search_file_$silent		entry (ptr, fixed bin(21), fixed bin(21), ptr, fixed bin(21),
				     fixed bin(21), fixed bin(21), fixed bin(21), fixed bin(35)),
	sort_items_indirect_$adj_char	entry (ptr, ptr, ptr),
	sort_items_indirect_$char	entry (ptr, ptr, fixed bin(24));

    dcl	AZ			char(26) int static options(constant)
				     init("ABCDEFGHIJKLMNOPQRSTUVWXYZ"),
	NL			char(1) int static options(constant) init("
"),
	ZERO			char(1) int static options(constant) init("0"),
	az			char(26) int static options(constant)
				     init("abcdefghijklmnopqrstuvwxyz");

    dcl  (addr, baseno, bin, charno, currentsize, dim, divide, fixed, floor, index,
	length, max, min, mod, null, rtrim, substr, sum, translate, unspec)
				builtin,
	cleanup			condition,
	conversion	          condition;

    dcl	access_$reset		entry (ptr, fixed bin(35)),
	access_$set_temporarily	entry (char(*), char(*), fixed bin(2), bit(*), ptr, fixed bin(35)),
	command_query_$yes_no	entry() options (variable),
	hcs_$delentry_seg		entry (ptr, fixed bin(35)),
	hcs_$make_seg		entry (char(*), char(*), char(*), fixed bin(5), ptr, fixed bin(35)),
	initiate_file_		entry (char(*), char(*), bit(*), ptr, fixed bin(24), fixed bin(35)),
	ioa_			entry options(variable),
	sub_err_			entry() options(variable),
	terminate_file_		entry (ptr, fixed bin(24), bit(*), fixed bin(35));

    dcl  (FALSE			init("0"b),
	TRUE			init("1"b)) bit(1) int static options(constant),
          1 FIXED_BIN_71_DESC	          aligned int static options (constant),
	  2 version 	          bit(1) unal init("1"b),
	  2 type		          fixed bin(6) unsigned unal init(1),
	  2 packed	          bit(1) unal init("0"b),
	  2 dimension	          bit(4) unal init("0"b),
	  2 scale		          fixed bin(11) unal init(0),
	  2 precision	          fixed bin(11) unal init(71),
    	1 FLOAT_DEC_59_DESC	          aligned int static options (constant),
	  2 version 	          bit(1) unal init("1"b),
	  2 type		          fixed bin(6) unsigned unal init(10),
	  2 packed	          bit(1) unal init("0"b),
	  2 dimension	          bit(4) unal init("0"b),
	  2 scale		          fixed bin(11) unal init(0),
	  2 precision	          fixed bin(11) unal init(59),
	SEGMENT			fixed bin(2) int static options(constant) init(1),
          STRING                        fixed bin(2) int static options (constant) init(2),
          TABLE                         fixed bin(2) int static options (constant) init(3),
	Sdebug			bit(1) int static init("0"b),
         (error_table_$bad_conversion,
	error_table_$chars_after_delim,
	error_table_$file_is_full,
	error_table_$moderr,
	error_table_$no_delimiter,
	error_table_$nomatch,	
	error_table_$no_w_permission,
	error_table_$noentry,
	error_table_$out_of_bounds,
	error_table_$unimplemented_version,
	error_table_$zero_length_seg) fixed bin(35) ext static,
          max_ptrs_per_seg              fixed bin(21) int static init(0),
	max_seg_size		fixed bin(21) int static init(0),
	sys_info$max_seg_size	fixed bin(35) ext static;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


seg:	entry (caller, ss_info_ptr, in_dir, in_ent, out_dir, out_ent,
	       out_len, undelim_char_index, code);

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* This entry point sorts segments.						*/
	/*									*/
	/* Overview:								*/
	/* 1) Initialize output arguments.						*/
	/* 2) Establish cleanup on unit to terminate segments, restore any changed ACLs, etc.	*/
	/* ORDER OF REMAINING OPERATIONS IS IMPORTANT---					*/
	/* 3) Try to initiate an existing output segment.  If found without access, ask user if	*/
	/*    access should be temporarily changed to allow the sort to occur.  If segment not	*/
	/*    found, create it but mark it for possible deletion should sort fail for other	*/
	/*    reasons.  Note that, when the output seg replaces the input seg, forcing access	*/
	/*    may make it easier to sort the input segment to which you normally have no access.	*/
	/*    In this case, it is important to initiate the output segment first, because we only	*/
	/*    change access for output segment, never for input segment.			*/
	/* 4) Initiate the input segment.						*/
	/* 5) Invoke internal procedures prepare_to_sort and sort to do the actual sorting.       */
          /* 6) If sort succeeds, invoke internal procedure output to prepare the output segment.   */
	/* 7) If sort succeeds, truncate, set bit count and terminate output segment.  If it      */
          /*    fails, terminate (or delete if we created) the output segment.  Also, terminate     */
          /*    input and restore any ACL changes.                                        	*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	out_len = 0;				/* Initialize output args.			*/
	undelim_char_index = 0;

	Pin = null;				/* Handle unexpected release.			*/
	Pout = null;
	Paccess = null;
	Screated_output_seg = FALSE;
	Stemp_dir = FALSE;

	Pidx = null;				/* Be prepared to cleanup temp segments.           */
          Soverlap = FALSE;
	Pdup, Pdul = null;
	Nsf_str_array = dim(Psfa,1);
	Psf_str_array(*), Psf_str, Psfp, Psfl = null;
	Nsf_str_array = 1;
	Puu_str, Puup, Puul, Puu_temp = null;
	Pout_temp = null;
	Pout_real = null;
	on cleanup call seg_janitor(TERM_FILE_TERM, Screated_output_seg);

RE_INIT_OUTPUT:					/* Initiate output segment.			*/
	call initiate_file_ (out_dir, out_ent, W_ACCESS, Pout, bc_out, code);

	if code = error_table_$no_w_permission |
	   code = error_table_$moderr then do;		/*   It exists, but caller cannot access it.	*/
	   call command_query_$yes_no (Syes, code, caller,
"Should ^a temporarily set read/write access on the sort output segment
^s(^a^[>^]^a)^[^/^; ^]to allow sorting to proceed?", "^sDo you want to set write access
on sort output segment^[^/^; ^](^a^[>^]^a)^s?", caller,
	      length("to allow sorting to proceed") + length(rtrim(out_dir)) +
	      length(">") + length(rtrim(out_ent)) + length("()?") > 76,
	      out_dir, out_dir^=">", out_ent,
	      length("to allow sorting to proceed") + length(rtrim(out_dir)) +
	      length(">") + length(rtrim(out_ent)) + length("()?") > 76);
	   if ^Syes then go to SEG_EXIT;
	   call access_$set_temporarily (out_dir, out_ent, SEGMENT, RW_ACCESS, Paccess, code);
	   if code = 0 then go to RE_INIT_OUTPUT;
	   call sub_err_ (code, caller, ACTION_DEFAULT_RESTART, null, 0,
	      "While temporarily setting access on output segment^/(^a^[>^]^a).", out_dir, out_dir^=">", out_ent);
	   go to SEG_EXIT;
	   end;

	if code = error_table_$noentry then do;		/*   It does not exist.  Create it.		*/
	   Screated_output_seg = TRUE;
	   call hcs_$make_seg (out_dir, out_ent, "", RW_ACCESS_BIN, Pout, code);
	   if Pout ^= null then code = 0;
	   end;
	if code ^= 0 then do;			/*   Error during creation/initiation.		*/
	   call sub_err_ (code, caller, ACTION_DEFAULT_RESTART, null, 0,
	      "While ^[creating^;initiating^] the sort output segment^/(^a^[>^]^a).",
	      Screated_output_seg,  out_dir, out_dir^=">", out_ent);
	   go to SEG_EXIT;
	   end;
	max_Lout = sys_info$max_seg_size * 4;

	call initiate_file_ (in_dir, in_ent, R_ACCESS, Pin, bc_in, code);
	if code ^= 0 then do;			/* Initiate input segment.			*/
	   call sub_err_ (code, caller, ACTION_DEFAULT_RESTART, null, 0,
	      "While initiating input segment^/(^a^[>^]^a).", in_dir, in_dir^=">", in_ent);
	   go to SEG_EXIT;
	   end;
	Lin = divide(bc_in, 9, 21, 0);

	call prepare_to_sort(SEGMENT);		/* This internal procedure does the scan work.	*/
	if code ^= 0 then goto SEG_EXIT;

	call sort(SEGMENT);				/* This internal procedure does the sort work.	*/
	if code ^= 0 then goto SEG_EXIT;

	call output();				/* This internal procedure prepares the output.   */
	if code ^= 0 then goto SEG_EXIT;
	call seg_janitor (TERM_FILE_TRUNC_BC_TERM, FALSE);
	return;

SEG_EXIT:	call seg_janitor(TERM_FILE_TERM, Screated_output_seg);
	return;

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


sort_seg_$string:
	entry (caller, ss_info_ptr, in_string, out_string, out_len,
	       undelim_char_index, code);

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* This entry point sorts strings.						*/
	/*									*/
	/* Overview:								*/
	/* 1) Initialize output arguments.						*/
	/* 2) Set input and output pointers to identify the input/output character strings parms. */
          /* 3) Establish cleanup on unit to release temp segments used for sorting.                */
	/* 4) Invoke internal prepare_to_sort procedure to scan the input string.		*/
	/* 5) Invoke internal sort procedure to do actual sorting.				*/
	/* 6) Invoke internal output procedure to prepare the output.			*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	out_len = 0;
	undelim_char_index = 0;
	code = 0;

	Pin = addr(in_string);
	Lin = length(in_string);
	Pout = addr(out_string);
	max_Lout = length(out_string);
	Stemp_dir = FALSE;

	Pidx = null;				/* Be prepared to cleanup temp segments.	*/
          Soverlap = FALSE;
	Pdup, Pdul = null;
	Nsf_str_array = dim(Psfa,1);
	Psf_str_array(*), Psf_str, Psfp, Psfl = null;
	Nsf_str_array = 1;
	Puu_str, Puup, Puul, Puu_temp = null;
	Pout_temp = null;
	Pout_real = null;
	on cleanup call sort_janitor();

	call prepare_to_sort (STRING);
	if code ^= 0 then goto STRING_EXIT;
	call sort (STRING);
	if code ^= 0 then goto STRING_EXIT;
	call output;

STRING_EXIT:
	call sort_janitor();
	return;

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

linus_table:
	entry (lcb_ptr, caller, ss_info_ptr, temp_seg_mgr$get, temp_seg_mgr$release, 
               temp_dir, in_ptr, desc_array, out_ptr, code);

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* This entry point sorts the linus table structure.				*/
	/*									*/
	/* Overview:								*/
	/* 1) Scan input into individual components to be sorted.                                 */
	/* 2) Establish cleanup on unit to release saved sort results used for merging.           */
	/* 3) Sort the individual components.                                                     */
	/* 4) Merge the resulting sorted components.                                              */
          /* 5) Cleanup.                                                                            */
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	code = 0;
	if temp_dir = "" then Stemp_dir = FALSE;
	else Stemp_dir = TRUE;

	Pout, Pin = null;				/* Just to keep the common code happy.            */
	Psave = null;				/* Handle unexpected release.			*/

	component_number = 0;
	Pidx = null;				/* Be prepared to cleanup temp segments.          */
          Soverlap = FALSE;
	Pdup, Pdul = null;
	Nsf_str_array = dim(Psfa,1);
	Psf_str_array(*), Psf_str, Psfp, Psfl = null;
	Nsf_str_array = 1;
	Puu_str, Puup, Puul, Puu_temp = null;
	Pout_temp = null;
	Pout_real = null;
 	on cleanup call table_janitor ();
	
	Pspp = in_ptr;
	Psppo = out_ptr;
	id = rtrim(caller) || " ";
	if ^get_temp_seg (id, "saved sort ptrs", Psave) then goto TABLE_EXIT;
						/* save temp seg                                  */ 
  	save.N = spp.M;				
	save.Nsf_strs = 0;

	do Icomp = 1 to spp.M;
	   save.idx_ptr(Icomp) = null;
	   save.sfp_ptr(Icomp) = null;
	   save.dup_ptr(Icomp) = null;
	   component_number = Icomp;
	   call prepare_to_sort (TABLE);
	   if code ^= 0 then goto TABLE_EXIT;
	   call sort (TABLE);			/* This internal procedure does the sort           */
	   if code ^= 0 then goto TABLE_EXIT;		/* work for one segment's worth of rows.           */

	   save.dup_ptr(Icomp) = Pdup;		/* save sort info for merging                      */
	   Puup = null;
	   Pdup = null;
	   save.idx_ptr(Icomp) = Pidx;
 	   Pidx = null;
	   save.sfp_ptr(Icomp) = Psfp;
	   Psfp = null;
	   addr(save.sf_str_ptr(save.Nsf_strs +1)) -> Psf_str_array = Psf_str_array;
	   save.Nsf_strs = save.Nsf_strs + dim(Psf_str_array, 1);
	   Psf_str_array = null;
	   Psf_str = null;
	   call sort_janitor();
	   end;
        
	if spp.M = 1 then do;			/* short cut if we don't have an msf               */
	   Psupo = sppo.P(1);
	   Pdup = save.dup_ptr(1);
	   Pidx = save.idx_ptr(1);
	   supo.N, Nu = dup.N;
	   do Iu = 1 to supo.N;
	      supo.P (Iu) = dup.P (idx.I(Iu));
	      end;
	   end;

	else call merge;				/* Here is the work of merging the                 */
						/* sorted components                               */

TABLE_EXIT:
	call table_janitor;

	return;


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


	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* These two entry points turn special debugging code on/off.  It is off by default.	*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

debug_on:
dbn:	entry();

	Sdebug = TRUE;
	return;

debug_off:
dbf:	entry();

	Sdebug = FALSE;
	return;

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


	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
	/*								        */
	/* I N T E R N A L   P R O C E D U R E S				        */
	/*								        */
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


prepare_to_sort:	proc (type );

    dcl   type                          fixed bin (2);	/* 1=seg,2=string,3=linus_table                   */
    dcl   found                         bit(1);

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* INITIALIZATION:								*/
	/* 1) Check version of sort_seg_info structure.					*/
	/* 2) Check for empty input string.						*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	if max_seg_size = 0 then max_seg_size = sys_info$max_seg_size*4; 

	if ss_info.version ^= SS_info_version_1 then do;	/* Validate info structure version.		*/
	   code = error_table_$unimplemented_version;
	   call sub_err_ (code, caller, ACTION_DEFAULT_RESTART, null, 0,
	      "sort_seg_ does not implement version ^a of the ss_info structure
(see sort_seg_info.incl.pl1).  It expects version ^a instead.",
	      ss_info.version, SS_info_version_1);
	   return;
	   end;

          if type ^= TABLE then if length (in) = 0 then do;	/* Check for no input to be sorted.		*/
	   if type  = SEGMENT then do;		
	      code = error_table_$zero_length_seg;
	      call sub_err_ (code, caller, ACTION_DEFAULT_RESTART, null, 0,
	         "The sort input segment is empty^/(^a^[>^]^a).",
	         in_dir, in_dir^=">", in_ent);
	      end;
	   return;
	   end;


	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* CHECK INPUTS:								*/
	/* 1) Check for input string/seg overlapping output string/seg.  This condition requires	*/
	/*    that a temp seg be used for preparing the output.  The output is then  copied from	*/
	/*    the temp seg into the output string/seg.					*/
	/* 2) Examine ss_info to determine various sorting cases, including--			*/
	/*    Svarying_delimiters = are sort string delimiters varying length or fixed length?	*/
	/*    Sblocked = do sort units consist of several sort strings, or just one?		*/
	/*    Snumeric = is any sort field a numeric sort?			          */
	/*    Sfield = are one or more specific sort fields identified, or is each sort unit	*/
	/*	     treated as the only sort field?					*/
	/*    Sdescending_sort = if each sort unit is the sort field, is the sort a descending	*/
	/*		     sort?						*/
	/*    Snon_case_sensitive_sort = if each sort unit is the sort field, is the sort	*/
	/*			   non_case_sensitive?				*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	if type = TABLE then Soverlap = FALSE;
	else if baseno(addr(in)) = baseno(addr(out)) then do;
	   Oin = charno (addr(in));			/* Check for input overlapping output storage.	*/
	   Oout = charno (addr(out));
	   if Oin < Oout then 
	      Soverlap = Oin + length(in) > Oout;
	   else if Oin > Oout then
	      Soverlap = Oout + length(out) > Oin;
	   else
	      Soverlap = TRUE;
	   end;
	else  Soverlap = FALSE;

	Svarying_delimiters = (ss_info.delim.type = SS_reg_exp);
						/* Do sort string delimiters have varying length? */
	Sblocked = ss_info.block_size > 1;		/* Is each sort unit composed of several strings? */
          Snumeric = FALSE;
	do If = 1 to ss_info.field_count;		/* Is any field a numeric sort field?             */
	   if ss_info.field(If).modes.numeric | ss_info.field(If).modes.integer then Snumeric = TRUE;
	   end;
	Sfield = TRUE;				/* Is the only field composed of the entire sort  */
	Sdescending_sort = FALSE;			/*   unit?  If so, descending and 		*/
	Snon_case_sensitive_sort = FALSE;		/*   non_case_sensitive sorts must be 		*/
	if ^Snumeric then				/*   special-cased, unless the sort is numeric or */
	   if ss_info.field_count = 1 then		/*   integer.				*/
	      if ss_info.field(1).from.type = SS_index &
	         ss_info.field(1).from.number = 1 &
	         ss_info.field(1).to.type = SS_length &
	         ss_info.field(1).to.number = -1 then do;
	         Sfield = FALSE;
	         Sdescending_sort = ss_info.field(1).modes.descending;
	         Snon_case_sensitive_sort = ss_info.field(1).modes.non_case_sensitive;
	         end;


	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
	/*								        */
	/* GET TEMP SEGMENTS:						        */
	/*								        */
	/* Obtain temp segments to hold the various arrays described in the "OVERVIEW OF THE    */
	/* SORTING PROCESS" comment.						        */
	/*								        */
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

	   
	id = rtrim(caller) || " ";			/* Get necessary temp segments.		*/
						/* required temp segments.			*/
	if ^get_temp_seg (id, "sort indices", Pidx) then goto PREPARE_EXIT;
	if ^get_temp_seg (id, "delim unit ptrs", Pdup) then goto PREPARE_EXIT;
	if ^get_temp_seg (id, "undelim unit lths", Puul) then goto PREPARE_EXIT;

	if Sblocked | Svarying_delimiters then 
	   if ^get_temp_seg (id, "delim unit lths", Pdul) then goto PREPARE_EXIT;
	if Sblocked then do;			/*   sort units without string delimiters	*/
	   if ^get_temp_seg (id, "undelim unit strs", Puu_str) then goto PREPARE_EXIT;
	   if ^get_temp_seg (id, "undelim unit ptrs", Puup) then goto PREPARE_EXIT;
	   end;

	if Sfield | Snon_case_sensitive_sort then do;	/*   combined sort fields for each unit		*/
	   if ^get_temp_seg (id, "sort field strs", Psf_str) then goto PREPARE_EXIT;
	   Psf_str_array(Nsf_str_array) = Psf_str;
	   if ^get_temp_seg (id, "sort field ptrs", Psfp) then goto PREPARE_EXIT;
	   end;

	if Snon_case_sensitive_sort then do;
	   if ^get_temp_seg (id, "sort field lths", Psfl) then goto PREPARE_EXIT;
	   end;
        

	if Soverlap then do;
	   if ^get_temp_seg (id, "temp output seg", Pout_temp) then goto PREPARE_EXIT;
	   Pout_real = Pout;
	   Pout = Pout_temp;
	   end;

	if type = TABLE then do;			/* Instead of SCANNING                            */


	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
	/*								        */
	/* PREPARE COMPONENT:						        */
	/* 1) Step through the row ptrs looking for segment changes.		        */
	/* 2) Put row ptrs into dup.p and set uul.l				        */
	/*								        */
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

	   code = 0;
	   Nu = 0; 
	   comp_base_number = baseno (spp.C(component_number));
	   if spp.sorted then do;			/* NORMAL CASE: search all ptrs for matches        */
	      do Iseg = 1 to spp.N;
	         Psup = spp.P(Iseg);
	         do Iptr = 1 to sup.N;
		  if comp_base_number = baseno (sup.P(Iptr)) then do;
		     Nu = Nu + 1;
		     dup.P(Nu) = sup.P(Iptr);
		     uul.L(Nu) = ss_info.delim.number;
		     end;
		  end;
	         end;
	      end;

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
	/*								        */
	/*  SPECIAL CASE: If the table wasn't previously sorted we can	                  */
	/*                expect all component ptrs to be contiguous.		        */
	/*								        */
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

	   else do;				/* SPECIAL CASE: contiguous ptrs                   */
	      found = FALSE;
	      do Iseg = 1 to spp.N;
	         Psup = spp.P(Iseg);
	         do Iptr = 1 to sup.N;
		  if comp_base_number = baseno (sup.P (Iptr)) then do;
		     Nu = Nu + 1;
		     dup.P(Nu) = sup.P(Iptr);
		     uul.L(Nu) = ss_info.delim.number;
		     found = TRUE;
		     end;
		  else if found then goto LOOP_EXIT;
		  end;
	         end;
LOOP_EXIT:      end;

	   dup.N, uul.N = Nu;
	   return;
	   end;					/* TABLE                                          */

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* SCANNING:								*/
	/* 1) Scan input into sort strings.						*/
	/* 2) Block strings into sort units						*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	Nu = 0;					/* No sort units found so far.		*/
	Iss = 1;					/* First sort string begins a char 1 of input.	*/

	Idu = 1;					/* Initialize index/length pairs for du and uu.	*/
	Ldu = 0;
	Iuu = 1;
	Luu = 0;

	Iuu_str = 1;				/* Initialize index/length pair for uu_str temp	*/
	Luu_str = max_seg_size;

	do while (Iss <= length(in));			/* Scan until input is exhausted.		*/
	   do Ibk = 1 to ss_info.block_size while (Iss <= length(in));
						/* Block scanned sort strings into sort units.	*/
	      Iuss = Iss;
	      go to FIND_DELIM(ss_info.delim.type);	/* Do scanning by delimiter type.		*/

FIND_DELIM(1):  if (Iss-1)+ss_info.delim.number > length(in) then
	         go to UNDELIM_CHARS;			/* Fixed length sort strings.  Check for last	*/
	      Ldss, Luss = ss_info.delim.number;	/*   sort string being too short.		*/
	      Iss = Iss + ss_info.delim.number;
	      go to END_FIND_DELIM;
						
FIND_DELIM(3):  Imatch = index (substr(in, Iss), ss_info.delim.string);
	      if Imatch = 0 then go to UNDELIM_CHARS;	/* Sort strings delimited by char strings.	*/
	      Luss = Imatch-1;
	      Ldss = Luss + length(ss_info.delim.string);
	      Iss = (Iss-1) + Imatch + length(ss_info.delim.string);
	      go to END_FIND_DELIM;

FIND_DELIM(4):  call search_file_$silent (addr(substr(ss_info.delim.string,1)), 1,
	         length(ss_info.delim.string),		/* Sort strings delimited by reg exp.		*/
	         addr(in), Iss, length(in),
	         Imatch, Imatch_end, code);
	      if code = 0 then do;
	         Lmatch = Imatch_end - Imatch + 1;
	         if substr(ss_info.delim.string, length(ss_info.delim.string),1) = "$" then
		   Lmatch = Lmatch + 1;
	         Luss = Imatch - Iss;
	         Ldss = Luss + Lmatch;
	         Iss = Imatch + Lmatch;
	         go to END_FIND_DELIM;
	         end;
	      else if code = error_table_$nomatch then do;
	         code = 0;
	         go to UNDELIM_CHARS;
	         end;
	      else do;
	         call sub_err_ (code, caller, ACTION_DEFAULT_RESTART, null, 0,
		  "Invalid syntax in regular expression:  -delimiter /^a/",
		  ss_info.delim.string);
	         go to PREPARE_EXIT;
	         end;

END_FIND_DELIM: Ldu = Ldu + Ldss;
	      Luu = Luu + Luss;
	      if Sblocked then do;
	         substr(uu_str, Iuu_str, Luss) = substr(in, Iuss, Luss);
	         Iuu_str = Iuu_str + Luss;
	         end;
	      end;
	   
	   Nu = Nu + 1;
	   dup.P(Nu) = addr(in_char(Idu));
	   uul.L(Nu) = Luu;
	   if Sblocked | Svarying_delimiters then
	      dul.L(Nu) = Ldu;
	   if Sblocked then do;
	      uup.P(Nu) = addr(uu_str_char(Iuu));
	      Iuu = Iuu + Luu;
	      end;
	   Idu = Idu + Ldu;
	   Ldu, Luu = 0;
	   end;

UNDELIM_CHARS:					/* Check for input chars beyond last sort string. */
	if Iss ^= length(in) + 1 then do;		/* This is undelimited input which will remain	*/
	   undelim_char_index = Iss;			/* at end of sorted results.			*/
	   Iline_end = 0;
	   do Nlines = 0 by 1 while (Iline_end < Iss);
	      Inl = index(substr(in,Iline_end+1), NL);
	      if Inl = 0 then
	         Inl = length(in) - Iline_end;
	      Iline_end = Iline_end  + Inl;
	      end;
	   Ichar = Iss - (Iline_end - Inl);
	   if Soverlap then do;
	      call command_query_$yes_no (Syes, error_table_$chars_after_delim,
	         caller, "The sort input ^[segment^;string^] does not end with a sort delimiter.
Instead, characters beginning on line ^d^[ (character ^d)^;^s^] follow
the final delimiter in the sort ^[segment
(^a^[>^]^a)^;string^3s^]." || "
Answer yes if you want to proceed with the sort.  The characters
following the final delimiter will remain at the end of the sorted results.
Proceed with the sort?", "
^sCharacters on line ^d^[ (character ^d)^;^s^] follow final sort delimiter.
Do you still want to sort the ^[segment^;string^]?", (type  = SEGMENT), Nlines,
	         Ichar>1, Ichar, (type  = SEGMENT), in_dir, in_dir^=">", in_ent);
	      if ^Syes then do;
	         code = error_table_$chars_after_delim;
	         go to PREPARE_EXIT;
	         end;
	      end;
	   else do;
	      call sub_err_ (error_table_$chars_after_delim, caller, ACTION_DEFAULT_RESTART, null, 0, "
Warning: Characters on line ^d^[ (character ^d)^;^s^] follow final sort delimiter.
These characters will appear at end of sorted results.  Sorting continues^[
(^a^[>^]^a)^;^3s^].",
	         Nlines, Ichar>1, Ichar, (type  = SEGMENT),
	         in_dir, in_dir^=">", in_ent);
	      end;
	   end;
	if Nu = 0 then do;
	   code = error_table_$no_delimiter;
	   call sub_err_ (code, caller, ACTION_DEFAULT_RESTART, null, 0,
	      "No sorting delimiters were found in sort input ^[segment
(^a^[>^]^a).^;string.^]", (type  = SEGMENT), in_dir, in_dir^=">", in_ent);
	   go to PREPARE_EXIT;
	   end;

PREPARE_EXIT:
        if code ^= 0 then call sort_janitor;
        return;
        end prepare_to_sort;

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

sort:	proc (type);
    dcl	Lfield (ss_info.field_count+1)		/* length of each field in the sort unit.	*/
				fixed bin(21),
	case_regexp (ss_info.field_count)		/* regexp case for -to regexpr handling           */
				fixed bin,
	case_field (ss_info.field_count)		/* sort type case for sort mode handling           */
				fixed bin,
          type                          fixed bin (2);	/* 1=seg,2=string,3=linus_table                   */

		
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* GENERALIZING THE SPECIAL CASES:						*/
	/* 1) When not blocked (ie, block_count = 1), the uu ptrs = the du ptrs and the uu_str	*/
	/*    overlays the input.							*/
	/* 2) When not blocked and fixed-length delimiters, the du lengths = the uu lengths plus	*/
	/*    the fixed-length of the delimiter.					*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	if ^Sblocked then Puup = Pdup;
	else Luu_str = Iuu_str - 1;

	if ^(Sblocked | Svarying_delimiters) then do;	/* This code can never be entered for SS_regexp	*/
	   Pdul = Puul;				/*   type delimiters			*/
	   if ss_info.delim.type = SS_length then	/* For fixed-length sort strings, there is no	*/
	      Ldelim = 0;				/*   special delimiting character.		*/
	   else					/* For fixed string delimiter (SS_string type),	*/
	      Ldelim = length (ss_info.delim.string);	/*   length of delimiter is fixed and must be	*/
	   end;					/*   added to dul.L values.			*/
	else Ldelim = 0;				/* For regular expression delimiters (SS_reg_exp	*/
						/*   type), the length of delimiter is already	*/
						/*   included in dul values.			*/


	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* SPECIAL-CASED FIELD PROCESSING:						*/
	/* 1 field, which equals the entire sort unit, with non_case_sensitive sorting--	*/
	/* 1) Copy each uu into the sf_str temp, translating to lowercase as you go.		*/
	/* 2) Add a sort stability field to the end of each copied unit.  The stability field is	*/
	/*    simply the unit number, treated as a character string.			*/
	/* 3) Set sf ptr/len pair (sfp/sfl)						*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	if Snon_case_sensitive_sort then do;
	   Isf_str = 1;
	   do Iu = 1 to Nu;
	      sfl.L(Iu) = length(uu) + length(stable);
	      if (Isf_str-1) + sfl.L(Iu) > max_seg_size then do;
	         Nsf_str_array = Nsf_str_array + 1;
	         if ^get_temp_seg (id, "sort field strs", Psf_str) then goto SORT_EXIT;
	         Psf_str_array(Nsf_str_array) = Psf_str;
	         Isf_str = 1;
	         end;
(nostrz,nostrg,nosize,nosubrg):			/* prefixes due to bug in PL/I                     */
	      sfp.P(Iu) = addr(sf_str_char(Isf_str));
	      substr(sf_ncs,1,length(uu)) = translate (uu, az, AZ);
	      substr(sf_ncs, length(uu)+1) = stable;
	      Isf_str = Isf_str + length(sf_ncs);
	      end;
	   end;

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* NORMAL FIELD PROCESSING:							*/
	/* Several fields, or 1 field which does NOT span the entire sort unit--		*/
	/* 1) Determine whether all of the sort fields are fixed length.			*/
	/* 2) If so, compute the length of all sort fields, including a stability field.	*/
          /*    (For numeric/integer fields, call encode numeric to determine the field length.)    */
	/*    Store in  Lall_fields.							*/
	/* 3) If not, scan each sort unit to compute length of sort fields for that unit.  For    */
          /*    numeric fields, call encode numeric to determine the encoded length of the field.   */
	/*    Then length of all sort fields is sum of max of sort field lengths for each unit.   */
	/*    Put in Lall_fields.							*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

/* Initialize case_regexp array. */
	do If = 1 to ss_info.field_count;
	     if ss_info.field(If).to.string = "$" then
		case_regexp(If) = 1;
	     else if length (ss_info.field(If).to.string) = 0 then
		case_regexp(If) = 4;
	     else if substr(ss_info.field(If).to.string, length(ss_info.field(If).to.string), length("$")) = "$"
		then do;
		     if ^Sblocked & ss_info.delim.type = SS_string
			& ss_info.delim.string = NL then
			case_regexp(If) = 2;
		     else do;
			case_regexp(If) = 3;
			if Puu_temp = null then if ^get_temp_seg (id, "undelim temp strs", Puu_temp) then goto SORT_EXIT;
		     end;
		end;
		else 
		     case_regexp(If) = 4;
	     end;

	if Sfield then do;
	   Svarying_fields = FALSE;
	   do If = 1 to ss_info.field_count while (^Svarying_fields);
	      if ss_info.field(If).to.type = SS_length then
	         if ss_info.field(If).to.number = -1 then Svarying_fields = TRUE;
	         else;
	      else if ss_info.field(If).to.type = SS_index then
	         if ss_info.field(If).from.type = SS_index then;
	         else Svarying_fields = TRUE;
	      else Svarying_fields = TRUE;
	      end;
	   if ^Svarying_fields then do;
	      do If = 1 to ss_info.field_count;		/* compute length of each sort field in units.	*/
	         if ss_info.field(If).modes.numeric then do;
 		  if type  = TABLE then call encode_numeric (addr(ZERO), length(ZERO), desc_array(If),
		     addr(encd_str), Lfield(If), code);
		  else call encode_numeric (addr(ZERO), length(ZERO), addr(FLOAT_DEC_59_DESC),
		     addr(encd_str), Lfield(If), code);
		  end;
	         else if ss_info.field(If).modes.integer
		  then call encode_numeric (addr(ZERO), length(ZERO), addr(FIXED_BIN_71_DESC),
		  addr(encd_str), Lfield(If), code);
	         else if ss_info.field(If).to.type = SS_length then
		  Lfield(If) = ss_info.field(If).to.number;
	         else
		  Lfield(If) = ss_info.field(If).to.number -
		     ss_info.field(If).from.number + 1;
	         end;
	      Lfield(If) = length(stable);		/* Include 4 char field for a sort unit number	*/
	      Lall_fields = sum(Lfield);		/*   to force the sort to be stable.		*/
	      end;
	   else do;				/* Because some sort fields have varying lengths	*/
						/* depending upon sort unit contents, we must go	*/
						/* to the expense of pre-scanning all sort units	*/
						/* to determine longest instance of each field.	*/
	      Lfield(*) = 0;
	      do Iu = 1 to Nu;
	         do If = 1 to ss_info.field_count;
		  if ss_info.field(If).modes.numeric then do;
		     if type = TABLE then call encode_numeric (addr(ZERO), length(ZERO), desc_array(If),
		        addr(encd_str), Lfield(If), code);
		     else call encode_numeric (addr(ZERO), length(ZERO), addr(FLOAT_DEC_59_DESC),
		        addr(encd_str), Lfield(If), code);
		     if case_regexp (If) = 2 then uul.L(Iu) = uul.L(Iu) + length(NL);
		     go to LTH_EMPTY_FIELD;
		     end;
		  else if ss_info.field(If).modes.integer then do;
		     call encode_numeric (addr(ZERO), length(ZERO), addr(FIXED_BIN_71_DESC),
		        addr(encd_str), Lfield(If), code);
		     if case_regexp (If) = 2 then uul.L(Iu) = uul.L(Iu) + length(NL);
		     go to LTH_EMPTY_FIELD;
		     end;
		  else go to LTH_FROM_FIELD(ss_info.field(If).from.type);

LTH_FROM_FIELD(2):	  Istart = ss_info.field(If).from.number;
		  go to END_LTH_FROM_FIELD;

LTH_FROM_FIELD(3):	  Istart = index (uu, ss_info.field(If).from.string);
		  if Istart = 0 then go to LTH_EMPTY_FIELD;
		  Istart = Istart + length(ss_info.field(If).from.string);
		  go to END_LTH_FROM_FIELD;

LTH_FROM_FIELD(4):	  call search_file_$silent (addr(substr(ss_info.field(If).from.string,1)),
		     1, length(ss_info.field(If).from.string),
		     addr(uu), 1, length(uu),
		     Istart, Imatch_end, code);
		  if code = 0 then do;
		     Lmatch = Imatch_end - Istart + 1;
		     Istart = Istart + Lmatch;
		     go to END_LTH_FROM_FIELD;
		     end;
		  else if code = error_table_$nomatch then do;
		     code = 0;
		     go to LTH_EMPTY_FIELD;
		     end;
		  else do;
		     call sub_err_ (code, caller, ACTION_DEFAULT_RESTART, null, 0,
		        "Invalid syntax in regular expression:  -field -from /^a/",
		        ss_info.field(If).from.string);
		     go to SORT_EXIT;
		     end;

END_LTH_FROM_FIELD:	  if Istart > length(uu) then go to LTH_EMPTY_FIELD;
		  go to LTH_TO_FIELD(ss_info.field(If).to.type);

LTH_TO_FIELD(1):	  if ss_info.field(If).to.number = -1 then
		     Iend = length(uu);
		  else
		     Iend = min (length(uu), (Istart-1) + ss_info.field(If).to.number);
		  go to END_LTH_TO_FIELD;

LTH_TO_FIELD(2):	  Iend = min(ss_info.field(If).to.number, length(uu));
		  go to END_LTH_TO_FIELD;

LTH_TO_FIELD(3):	  Iend = index (substr(uu,Istart), ss_info.field(If).to.string);
		  if Iend = 0 then go to LTH_EMPTY_FIELD;
		  Iend = Iend + (Istart-1) - 1;
		  go to END_LTH_TO_FIELD;

LTH_TO_FIELD(4):	  go to LTH_TO_REGEXP (case_regexp(If));

LTH_TO_REGEXP(1):	  Iend = length(uu);
		  go to END_LTH_TO_FIELD;

LTH_TO_REGEXP(3):     Luu_temp = uul.L(If);
		  uu_temp = uu;
		  Luu_temp = Luu_temp + length(NL);
		  substr (uu_temp, length(uu_temp), length(NL)) = NL;
		  call search_file_$silent (addr(substr(ss_info.field(If).to.string,1)),
		     1, length(ss_info.field(If).to.string), addr(uu_temp),
		     Istart, length(uu_temp), Iend, Imatch_end, code);
		  go to END_LTH_TO_REGEXP;
  	  
LTH_TO_REGEXP(2):     uul.L(Iu) = uul.L(Iu) + length(NL);
LTH_TO_REGEXP(4):	  call search_file_$silent (addr(substr(ss_info.field(If).to.string,1)),
		     1, length(ss_info.field(If).to.string), addr(uu),
		     Istart, length(uu), Iend, Imatch_end, code);

END_LTH_TO_REGEXP:	  if code = 0 then do;
		     Iend = Iend - 1;
		     go to END_LTH_TO_FIELD;
		     end;
		  else if code = error_table_$nomatch then do;
		     code = 0;
		     go to LTH_EMPTY_FIELD;
		     end;
		  else do;
		     call sub_err_ (code, caller, ACTION_DEFAULT_RESTART, null, 0,
		        "Invalid syntax in regular expression:  -field -to /^a/",
		        ss_info.field(If).to.string);
		     go to SORT_EXIT;
		     end;

END_LTH_TO_FIELD:	  Lfield(If) = max(Lfield(If), Iend-Istart+1);
LTH_EMPTY_FIELD:	  end;
	         end;
	      Lfield(ss_info.field_count+1) = length(stable);
	      Lall_fields = sum(Lfield);
	      end;

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* NORMAL FIELD PROCESSING (cont):						*/
	/* 4) Copy each sort field from the uu into sf_str temp seg.			*/
	/* 5) For non_case_sensitive fields, translate to lowercase as copied.		*/
	/* 6) For descending fields, invert the bit string representation of the field copy.	*/
	/* 7) For numeric fields, encode the character string representation of the field copy.	*/
	/* 8) Set the sfp to point to the field.  Fields for all units are the same length,	*/
	/*    Lall_fields, as computed above.						*/
	/* 9) Add a stability field to the end of each copied unit.			          */
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	   if Snumeric then do;			/* setup to handle a bad numeric conversion.      */
	      on conversion begin;			
	         code = error_table_$bad_conversion;
	         call sub_err_ (code, caller, ACTION_DEFAULT_RESTART, null, 0,
		  "^/While encoding field ^d of ^[row^;block^] ^d: ^a^[^/(^a^[>^]^a)^]", If, (type=TABLE), Iu,
		  substr(uu,Istart,Lmatch), (type = SEGMENT), in_dir, in_dir^=">", in_ent);
	         go to SORT_EXIT;
	         end;

	      on size begin;			
	         code = error_table_$out_of_bounds;
	         call sub_err_ (code, caller, ACTION_DEFAULT_RESTART, null, 0,
		  "^/While encoding field ^d of ^[row^;block^] ^d: ^a^[^/(^a^[>^]^a)^]", If, (type = TABLE), Iu,
		  substr(uu,Istart,Lmatch), (type = SEGMENT), in_dir, in_dir^=">", in_ent);
	         go to SORT_EXIT;
	         end;
	      end;   

	   Isf_str = 1;
	   case_field(*) = 0;
	   do Iu = 1 to Nu;	      
	      if (Isf_str-1) + Lall_fields > max_seg_size then do;
	         Nsf_str_array = Nsf_str_array + 1;
	         if ^get_temp_seg (id, "sort field strs", Psf_str) then goto SORT_EXIT;
	         Psf_str_array(Nsf_str_array) = Psf_str;
	         Isf_str = 1;
	         end;
(nostrz,nostrg,nosize,nosubrg):			/* prefixes due to bug in PL/I                     */
	      sfp.P(Iu) = addr(sf_str_char(Isf_str));
	      do If = 1 to ss_info.field_count;
	         go to SET_FROM_FIELD(ss_info.field(If).from.type);
	         
SET_FROM_FIELD(2): Istart = ss_info.field(If).from.number;
	         go to END_SET_FROM_FIELD;
	         
SET_FROM_FIELD(3): Istart = index(uu, ss_info.field(If).from.string);
	         if Istart = 0 then go to SET_EMPTY_FIELD;
	         Istart = Istart + length(ss_info.field(If).from.string);
	         go to END_SET_FROM_FIELD;

SET_FROM_FIELD(4): call search_file_$silent (addr(substr(ss_info.field(If).from.string,1)),
		  1, length(ss_info.field(If).from.string),
		  addr(uu), 1, length(uu),
		  Istart, Imatch_end, code);
	         if code = 0 then do;
		  Lmatch = Imatch_end - Istart + 1;
		  Istart = Istart + Lmatch;
		  go to END_SET_FROM_FIELD;
		  end;
	         else if code = error_table_$nomatch then do;
		  code = 0;
		  go to SET_EMPTY_FIELD;
		  end;
	         else do;
		  call sub_err_ (code, caller, ACTION_DEFAULT_RESTART, null, 0,
		     "Invalid syntax in regular expression:  -field -from /^a/",
		     ss_info.field(If).from.string);
		  go to SORT_EXIT;
		  end;

END_SET_FROM_FIELD:
	         if Istart > length(uu) then go to SET_EMPTY_FIELD;
	         go to SET_TO_FIELD(ss_info.field(If).to.type);

SET_TO_FIELD(1):   if ss_info.field(If).to.number = -1 then
		  Iend = length(uu);
	         else
		  Iend = min(length(uu), (Istart-1) + ss_info.field(If).to.number);
	         go to END_SET_TO_FIELD;

SET_TO_FIELD(2):   Iend = min(ss_info.field(If).to.number, length(uu));
	         go to END_SET_TO_FIELD;

SET_TO_FIELD(3):   Iend = index (substr(uu,Istart), ss_info.field(If).to.string);
	         if Iend = 0 then go to SET_EMPTY_FIELD;
	         Iend = Iend + (Istart-1) - 1;
	         go to END_SET_TO_FIELD;

SET_TO_FIELD(4):   go to SET_TO_REGEXP(case_regexp(If));

SET_TO_REGEXP(1):  Iend = length(uu);
	         go to END_SET_TO_FIELD;

SET_TO_REGEXP(2):  call search_file_$silent (addr(substr(ss_info.field(If).to.string,1)),
		  1, length(ss_info.field(If).to.string),
		  addr(uu), Istart, length(uu),
		  Iend, Imatch_end, code);
	         uul.L(Iu) = uul.L(Iu) - 1;
	         go to END_SET_TO_REGEXP;

SET_TO_REGEXP(3):  Luu_temp = uul.L(If);
	         uu_temp = uu;
	         Luu_temp = Luu_temp + length(NL);
	         substr (uu_temp, length(uu_temp), length(NL)) = NL;
	         call search_file_$silent (addr(substr(ss_info.field(If).to.string,1)),
		  1, length(ss_info.field(If).to.string), addr(uu_temp),
		  Istart, length(uu_temp), Iend, Imatch_end, code);
	         go to END_SET_TO_REGEXP;

SET_TO_REGEXP(4):  call search_file_$silent (addr(substr(ss_info.field(If).to.string,1)),
		  1, length(ss_info.field(If).to.string), addr(uu),
		  Istart, length(uu), Iend, Imatch_end, code);

END_SET_TO_REGEXP: if code = 0 then do;
		  Iend = Iend - 1;
		  go to END_SET_TO_FIELD;
		  end;
	         else if code = error_table_$nomatch then do;
		  code = 0;
		  go to SET_EMPTY_FIELD;
		  end;
	         else do;
		  call sub_err_ (code, caller, ACTION_DEFAULT_RESTART, null, 0,
		     "Invalid syntax in regular expression:  -field -to /^a/",
		     ss_info.field(If).to.string);
		  go to SORT_EXIT;
		  end;

END_SET_TO_FIELD:  Lmatch = Iend-Istart+1;
	         if Lmatch <= 0 then go to SET_EMPTY_FIELD;
	         go to FIELD_TYPE(case_field(If));

FIELD_TYPE(0):      if  ss_info.field(If).modes.non_case_sensitive &
		  ^ss_info.field(If).modes.numeric &
		  ^ss_info.field(If).modes.integer &
		  ^ss_info.field(If).modes.descending then case_field(If) = 1;
	         else
	         if ^ss_info.field(If).modes.non_case_sensitive &
		  ^ss_info.field(If).modes.numeric &
		  ^ss_info.field(If).modes.integer &
		   ss_info.field(If).modes.descending then case_field(If) = 2;
	         else
	         if  ss_info.field(If).modes.non_case_sensitive &
		  ^ss_info.field(If).modes.numeric &
		  ^ss_info.field(If).modes.integer &
		   ss_info.field(If).modes.descending then case_field(If) = 3;
	         else
	         if  ss_info.field(If).modes.numeric &
		  ^ss_info.field(If).modes.integer &
		  ^ss_info.field(If).modes.descending then case_field(If) = 4;
	         else
	         if  ss_info.field(If).modes.numeric &
 		  ^ss_info.field(If).modes.integer &
 		   ss_info.field(If).modes.descending then case_field(If) = 5;
	         else
	         if  ss_info.field(If).modes.integer &
		  ^ss_info.field(If).modes.numeric &
		  ^ss_info.field(If).modes.descending then case_field(If) = 6;
	         else
	         if  ss_info.field(If).modes.integer &
		  ^ss_info.field(If).modes.numeric &
	 	   ss_info.field(If).modes.descending then case_field(If) = 7;
	         else case_field(If) = 8;
	         go to FIELD_TYPE(case_field(If));

FIELD_TYPE(1):     substr(sf_str,Isf_str,Lfield(If)) = translate(substr(uu,Istart,Lmatch),az,AZ);
                   go to NEXT_FIELD;

FIELD_TYPE(2):     unspec(substr(sf_str,Isf_str,Lfield(If))) = ^unspec(substr(uu,Istart,Lmatch));
                   go to NEXT_FIELD;

FIELD_TYPE(3):     substr(sf_str,Isf_str,Lfield(If)) = translate(substr(uu,Istart,Lmatch),az,AZ);
	         unspec(substr(sf_str,Isf_str,Lfield(If))) = ^unspec(substr(sf_str,Isf_str,Lfield(If)));
                   go to NEXT_FIELD;

FIELD_TYPE(4):     if type  = TABLE then call encode_numeric (addr(substr(uu,Istart,Lmatch)), (Lmatch),
		  desc_array(If), addr(substr(sf_str, Isf_str, Lfield(If))), encd_len, code);
	         else call encode_numeric (addr(substr(uu,Istart,Lmatch)), (Lmatch),
		  addr(FLOAT_DEC_59_DESC), addr(substr(sf_str, Isf_str, Lfield(If))), encd_len, code);
	         if code ^= 0 then do;
		  call sub_err_ (code, caller, ACTION_DEFAULT_RESTART, null, 0,
		     "^/While encoding field ^d of ^[row^;block^] ^d: ^a^[^/(^a^[>^]^a)^]", If, (type = TABLE), Iu,
		     substr(uu,Istart,Lmatch), (type = SEGMENT), in_dir, in_dir^=">", in_ent);
		  go to SORT_EXIT;
		  end;
                   go to NEXT_FIELD;

FIELD_TYPE(5):     if type  = TABLE then call encode_numeric (addr(substr(uu,Istart,Lmatch)), (Lmatch),
		  desc_array(If), addr(encd_str), encd_len, code);
	         else call encode_numeric (addr(substr(uu,Istart,Lmatch)), (Lmatch),
		  addr(FLOAT_DEC_59_DESC), addr(encd_str), encd_len, code);
	         if code ^= 0 then do;
		  call sub_err_ (code, caller, ACTION_DEFAULT_RESTART, null, 0,
		     "^/While encoding field ^d of ^[row^;block^] ^d: ^a^[^/(^a^[>^]^a)^]", If, (type = TABLE), Iu,
		     substr(uu,Istart,Lmatch), (type = SEGMENT), in_dir, in_dir^=">", in_ent);
		  go to SORT_EXIT;
		  end;
	         unspec(substr(sf_str,Isf_str,Lfield(If))) = ^unspec(substr(encd_str, 1, encd_len));
	         go to NEXT_FIELD;

FIELD_TYPE(6):     call encode_numeric (addr(substr(uu,Istart,Lmatch)), (Lmatch),
		  addr(FIXED_BIN_71_DESC), addr(substr(sf_str, Isf_str, Lfield(If))), encd_len, code);
	         if code ^= 0 then do;
		  call sub_err_ (code, caller, ACTION_DEFAULT_RESTART, null, 0,
		     "^/While encoding field ^d of ^[row^;block^] ^d: ^a^[^/(^a^[>^]^a)^]", If, (type = TABLE), Iu,
		     substr(uu,Istart,Lmatch), (type = SEGMENT), in_dir, in_dir^=">", in_ent);
		  go to SORT_EXIT;
		  end;
	         go to NEXT_FIELD;

FIELD_TYPE(7):     call encode_numeric (addr(substr(uu,Istart,Lmatch)), (Lmatch),
		  addr(FIXED_BIN_71_DESC), addr(encd_str), encd_len, code);
	         if code ^= 0 then do;
		  call sub_err_ (code, caller, ACTION_DEFAULT_RESTART, null, 0,
		     "^/While encoding field ^d of ^[row^;block^] ^d: ^a^[^/(^a^[>^]^a)^]", If, (type = TABLE), Iu,
		     substr(uu,Istart,Lmatch), (type = SEGMENT), in_dir, in_dir^=">", in_ent);
		  go to SORT_EXIT;
		  end;
	         unspec(substr(sf_str,Isf_str,Lfield(If))) = ^unspec(substr(encd_str, 1, encd_len));
	         go to NEXT_FIELD;

FIELD_TYPE(8):     substr(sf_str,Isf_str,Lfield(If)) = substr(uu,Istart,Lmatch);
	         go to NEXT_FIELD;

SET_EMPTY_FIELD:   if ss_info.field(If).modes.numeric then do;
		  if type  = TABLE then call encode_numeric (addr(ZERO), length(ZERO), desc_array(If),
		     addr(substr(sf_str,Isf_str,Lfield(If))), Lfield(If), code);
		  else call encode_numeric (addr(ZERO), length(ZERO), addr(FLOAT_DEC_59_DESC),
		     addr(substr(sf_str,Isf_str,Lfield(If))), Lfield(If), code);
		  end;
	         else if ss_info.field(If).modes.integer then call encode_numeric (addr(ZERO), length(ZERO),
		  addr(FIXED_BIN_71_DESC), addr(substr(sf_str,Isf_str,Lfield(If))), Lfield(If), code);
	         else substr(sf_str,Isf_str,Lfield(If)) = "";
	         if ss_info.field(If).modes.descending then 
		  unspec(substr(sf_str,Isf_str,Lfield(If))) = ^unspec(substr(sf_str,Isf_str,Lfield(If)));

NEXT_FIELD:        Isf_str = Isf_str + Lfield(If);
	         end;
	      substr(sf_str,Isf_str,Lfield(If)) = stable;
	      Isf_str = Isf_str + Lfield(If);
	      end;
	   end;
	if Snumeric then revert conversion, size;	/* threat of a bad numeric conversion is over.    */

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* SORT:									*/
	/* 1) Let sort_items_indirect_ compare sort fields or units, and rearrange unit indices	*/
	/*    (idx).								*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	if Sfield then do;				/* Sort with fields.			*/
	   sfp.N = Nu;
	   call sort_items_indirect_$char (addr(sfp), addr(idx), Lall_fields);
	   end;
	else if Snon_case_sensitive_sort then do;	/* Simple sort with translation to lower case.	*/
	   sfp.N = Nu;
	   sfl.N = Nu;
	   call sort_items_indirect_$adj_char (addr(sfp), addr(idx), addr(sfl));
	   end;
	else do;					/* Sblocked or ^Sblocked (simple sort)		*/
	   uup.N = Nu;
	   uul.N = Nu;
	   call sort_items_indirect_$adj_char (addr(uup), addr(idx), addr(uul));
	   end;


	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* DEBUGGING CODE:								*/
	/* For each sort unit, print:  sort index, unit number, du, uu and sf (if different from	*/
	/* uu).									*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	if Sdebug then do;
	   if Sfield then do;
	      call ioa_ ("Lall_fields = ^d, Lfields =^( ^d^)", Lall_fields, Lfield);
	      Luu_longest = 0;
	      do Iu = 1 to Nu;
	         Puu_text = addr(uu);
	         Luu_text = length(uu);
	         do while (find_uu_line());
		  Luu_longest = max(Luu_longest, length(uu_line));
		  end;
	         end;
	      end;
	   Ldu_longest = 0;
	   do Iu = 1 to Nu;
	      Ldu = dul.L(Iu) + Ldelim;
	      if substr(du,Ldu,1) = NL then
	         Ldu = Ldu - 1;
	      Pdu_text = addr(du);
	      Ldu_text = Ldu;
	      do while (find_du_line());
	         Ldu_longest = max(Ldu_longest, length(du_line));
	         end;
	      end;
	   do Iu = 1 to Nu;
	      do Ix = 1 to Nu while(idx.I(Ix) ^= Iu);
	         end;
	      Ldu = dul.L(Iu) + Ldelim;
	      if substr(du,Ldu,1) = NL then
	         Ldu = Ldu - 1;
	      Idu_nl = index(du, NL);
	      Iuu_nl = index(uu, NL);
	      if Sfield then do;
	         Isf_nl = index(sf, NL);
	         if Idu_nl + Iuu_nl + Isf_nl = 0 then
		  call ioa_ ("^4d - ^4d| ""^a""^vx | ""^a""^vx | ""^a""",
		     Ix, Iu, du, Ldu_longest-Ldu,
		     uu, Luu_longest-length(uu),
		     substr(sf,1,Lall_fields-4));
	         else do;
		  Pdu_text = addr(du);
		  Ldu_text = Ldu;
		  Puu_text = addr(uu);
		  Luu_text = length(uu);
		  Psf_text = addr(sf);
		  Lsf_text = Lall_fields-4;
		  Idu, Iuu, Iss = 1;
		  do while (find_du_line() | find_uu_line() | find_sf_line());
		     call ioa_ ("^[^4d - ^4d^;^12t^2s^]^2(| ^[""^; ^]^[^s^a""^vx^;^va ^s^] ^)| ^[""^; ^]^a^[""^]",
		        Idu = 1, Ix, Iu,
		        Idu = 1, length(du_line)>0 & length(du_text)=0,
		        Ldu_longest, du_line, Ldu_longest-length(du_line),
		        Iuu = 1, length(uu_line)>0 & length(uu_text)=0,
		        Luu_longest, uu_line, Luu_longest-length(uu_line),
		        Iss=1, sf_line, length(sf_line)>0 & length(sf_text)=0);
		     Idu, Iuu, Iss = 0;
		     end;
		  end;
	         end;
	      else do;
	         if Idu_nl + Iuu_nl = 0 then
		  call ioa_ ("^4d - ^4d| ""^a""^vx | ""^a""",
		     Ix, Iu, du, Ldu_longest - Ldu, uu);
	         else do;
		  Pdu_text = addr(du);
		  Ldu_text = Ldu;
		  Puu_text = addr(uu);
		  Luu_text = length(uu);
		  Idu, Iuu = 1;
		  do while (find_du_line() | find_uu_line());
		     call ioa_ ("^[^4d - ^4d| ""^;^12t|  ^2s^]^[^s^a""^vx^;^va ^s^] | ^[""^; ^]^a^[""^]",
		        Idu = 1, Ix, Iu,
		        length(du_line)>0 & length(du_text)=0,
		        Ldu_longest, du_line, Ldu_longest-length(du_line),
		        Iuu = 1, uu_line, length(uu_line)>0 & length(uu_text)=0);
		     Idu, Iuu = 0;
		     end;
		  end;
	         end;
	      end;
	   end;
SORT_EXIT:
        if code ^= 0 then call sort_janitor();
        return;
        end sort;

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

merge:   proc ();

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
	/*								        */
	/* MERGE THE SORTED COMPONENTS:					        */
	/*								        */
	/* Initialize Imerge and component_idx array to 1.			        */
	/* Then until merging is complete (all components are exhausted):		        */
	/*    1) Compare the sort field at current component_idx for each component to that of  */
	/*       the Imerge component.  Set Imerge to the component number of the lowest.       */
	/*    2) Add the row ptr of this component's current component_idx to the output.       */
	/*    3) Increment this component's component_idx.			        */
	/*    4) Find the lowest component which isn't completely merged. Set Imerge.	        */
	/*    5) Repeat.							        */
	/*								        */
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


    dcl component_idx (spp.M) fixed bin(21);

         Iseg = 1;					/* init to first output seg                       */
         Psupo = sppo.P(1);
         supo.N = 0;				/* this output seg is empty                       */

         max_ptrs_per_seg = sys_info$max_seg_size - currentsize(supo);
         component_idx(*) = 1;			/* set all indices to 1                           */
         Imerge = 1;				/* assume the first component is lowest to start  */
         do while (Imerge <= spp.M);
	  Pidx_merge = save.idx_ptr(Imerge);
	  Psfp_merge = save.sfp_ptr(Imerge);
	  Psf_merge = sfp_merge.P(idx_merge.I(component_idx(Imerge)));

	  do Iu = Imerge + 1 to spp.M;		/* find the next lowest component to merge        */
	     Pidx1 = save.idx_ptr(Iu);
	     if (component_idx(Iu) <= idx1.N) then do;
	        Psfp1 = save.sfp_ptr(Iu);
	        Psf1 = sfp1.P (idx1.I (component_idx(Iu)));
	        if sf1 < sf_merge then do;
		 Pidx_merge = Pidx1;
		 Psfp_merge = Psfp1;
		 Psf_merge = Psf1;
		 Imerge = Iu;
		 end;
	        end;
	     end;
	  
	  if supo.N = max_ptrs_per_seg then do;		/* this output seg is full                        */
	     if Iseg = sppo.N then do;		/* whoops, can't have more than we're given       */
	        code = error_table_$file_is_full;
	        goto MERGE_EXIT;
	        end;
	     Iseg = Iseg + 1;			/* start a new output seg                         */
	     Psupo = sppo.P(Iseg);
	     supo.N = 0;				/* this seg is empty                              */
	     end;
	  
	  supo.N = supo.N + 1;			/* put this row in output                         */
	  Pdup = save.dup_ptr(Imerge);
	  supo.P(supo.N) = dup.P(idx_merge.I(component_idx(Imerge)));
	  
	  if Sdebug then 
	     call ioa_ ("^2d, ^6d: ^a", Imerge, component_idx(Imerge),sf_merge);
	  
	  component_idx (Imerge) =
	     component_idx (Imerge) + 1;		/* mark this row as used                          */


	  do Imerge = 1 to spp.M			/* find a component which isn't done              */
	     while (component_idx(Imerge) > save.idx_ptr(Imerge) -> idx_merge.N); 
	     end;

	  end;
MERGE_EXIT:
         end merge;

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
output:   proc ();

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* COPY SORTED INPUT TO OUTPUT						*/
	/* 1) Copy du's in sort order into output string.					*/
	/* 2) As part of copying, take duplicate_mode into account.  The mode can be--		*/
	/*    -duplicates = copy all units in sort order					*/
	/*    -unique = copy all unique units and first copy of each duplicated unit, in sort	*/
	/*	      order							*/
	/*    -only_duplicates = copy only first of each set of duplicate units, in sort order.	*/
	/*		     Unique units are NOT copied.				*/
	/*    -only_duplicate_keys = copy only units whose sort fields duplicate those of	*/
	/*		         another unit.  Units with unique sort fields are NOT copied. */
	/*    -unique_keys = copy only units whose sort fields do NOT duplicate those oo any	*/
	/*		 other unit.						*/
	/*    -only_unique = copy only units which are not duplicated.			*/
	/*    -only_unique_keys = copy only units whose keys are not duplicated in other units.	*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	Lout = 0;
	Iu_prev = 0;
	Ndups = 0;
	Ndups_prev = 0;
	if Sfield then
	   Lall_fields = Lall_fields - 4;		/* Remove stability indicator.		*/
	do Ix = 1 to idx.N by 1  while (^Sdescending_sort),
	        idx.N to 1 by -1 while (Sdescending_sort);
	   Iu = idx.I(Ix);
	   Ldu = dul.L(Iu) + Ldelim;
	   go to DUP(ss_info.duplicate_mode);

DUP(1):	   substr(out, Lout+1, Ldu) = du;		/* SS_duplicate				*/
	   Lout = Lout + Ldu;
	   go to END_DUP;

DUP(2):	   if Iu_prev > 0 then			/* SS_unique				*/
	      if Ldu_prev = Ldu then
	         if du_prev = du then go to END_DUP_SET_PREV;
	   substr(out, Lout+1, Ldu) = du;
	   Lout = Lout + Ldu;
	   go to END_DUP_SET_PREV;

DUP(3):	   if Iu_prev > 0 then do;			/* SS_only_duplicates			*/
	      if Snon_case_sensitive_sort then do;
	         if Ldu_prev = Ldu then
		  if sfp.P(Iu_prev)->du_prev = sfp.P(Iu)->du then
		     Ndups = Ndups + 1;
		  else Ndups = 0;
	         else Ndups = 0;
	         end;
	      else do;
	         if Ldu_prev = Ldu then
		  if du_prev = du then Ndups = Ndups + 1;
		  else Ndups = 0;
	         else Ndups = 0;
	         end;
	      if Ndups = 1 then do;
	         substr(out, Lout+1, Ldu_prev) = du_prev;
	         Lout = Lout + Ldu_prev;
	         end;
	      end;
	   go to END_DUP_SET_PREV;

DUP(4):	   if ^Sfield then go to DUP(3);		/* SS_only_duplicate_keys			*/
	   if Iu_prev > 0 then do;
	      if Sfield then 
	         if sf_prev = sf then Ndups = Ndups + 1;
	         else Ndups = 0;
	      else do;
	         if Snon_case_sensitive_sort then do;
		  if Ldu_prev = Ldu then
		     if sfp.P(Iu_prev)->du_prev = sfp.P(Iu)->du then
		        Ndups = Ndups + 1;
		     else Ndups = 0;
		  else Ndups = 0;
		  end;
	         else do;
		  if Ldu_prev = Ldu then
		     if du_prev = du then Ndups = Ndups + 1;
		     else Ndups = 0;
		  else Ndups = 0;
		  end;
	         end;
	      if Ndups = 1 then do;
	         substr(out, Lout+1, Ldu_prev) = du_prev;
	         Lout = Lout + Ldu_prev;
	         end;
	      if Ndups > 0 then do;
	         substr(out, Lout+1, Ldu) = du;
	         Lout = Lout + Ldu;
	         end;
	      end;
	   go to END_DUP_SET_PREV;

DUP(5):	   if ^Sfield & ^Snon_case_sensitive_sort then go to DUP(2);
	   if Iu_prev > 0 then do;			/* SS_unique_keys				*/
	      if Snon_case_sensitive_sort then do;
	         if Ldu_prev = Ldu then
		  if sfp.P(Iu_prev)->du_prev = sfp.P(Iu)->du then
		     Ndups = Ndups + 1;
		  else Ndups = 0;
	         else Ndups = 0;
	         end;
	      else do;
	         if sf_prev = sf then Ndups = Ndups + 1;
	         else Ndups = 0;
	         end;
	      end;
	   if Ndups = 0 then do;
	      substr(out, Lout+1, Ldu) = du;
	      Lout = Lout + Ldu;
	      end;
	   go to END_DUP_SET_PREV;

DUP(6):	   if Iu_prev > 0 then do;			/* SS_only_unique				*/
	      if Snon_case_sensitive_sort then do;
	         if Ldu_prev = Ldu then
		  if sfp.P(Iu_prev)->du_prev = sfp.P(Iu)->du then
		     Ndups = Ndups + 1;
		  else Ndups = 0;
	         else Ndups = 0;
	         end;
	      else do;
	         if Ldu_prev = Ldu then
		  if du_prev = du then Ndups = Ndups + 1;
		  else Ndups = 0;
	         else Ndups = 0;
	         end;
	      if Ndups = 0 & Ndups_prev = 0 then do;
	         substr(out, Lout+1, Ldu_prev) = du_prev;
	         Lout = Lout + Ldu_prev;
	         end;
	      end;
	   if Ndups = 0 & ((Ix = idx.N & ^Sdescending_sort) | (Ix = 1 & Sdescending_sort)) then do;
	      substr(out, Lout+1, Ldu) = du;
	      Lout = Lout + Ldu;
	      end;
	   Ndups_prev = Ndups;
	   go to END_DUP_SET_PREV;

DUP(7):	   if ^Sfield then go to DUP(6);		/* SS_only_unique_keys			*/
	   if Iu_prev > 0 then do;
	      if Sfield then 
	         if sf_prev = sf then Ndups = Ndups + 1;
	         else Ndups = 0;
	      else do;
	         if Snon_case_sensitive_sort then do;
		  if Ldu_prev = Ldu then
		     if sfp.P(Iu_prev)->du_prev = sfp.P(Iu)->du then
		        Ndups = Ndups + 1;
		     else Ndups = 0;
		  else Ndups = 0;
		  end;
	         else do;
		  if Ldu_prev = Ldu then
		     if du_prev = du then Ndups = Ndups + 1;
		     else Ndups = 0;
		  else Ndups = 0;
		  end;
	         end;
	      if Ndups = 0 & Ndups_prev = 0 then do;
	         substr(out, Lout+1, Ldu_prev) = du_prev;
	         Lout = Lout + Ldu_prev;
	         end;
	      end;
	   if Ndups = 0 & ((Ix = idx.N & ^Sdescending_sort) | (Ix = 1 & Sdescending_sort)) then do;
	      substr(out, Lout+1, Ldu) = du;
	      Lout = Lout + Ldu;
	      end;
	   Ndups_prev = Ndups;
	   go to END_DUP_SET_PREV;

END_DUP_SET_PREV:
	   Iu_prev = Iu;
	   Ldu_prev = Ldu;

END_DUP:	   end;

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* FINISH PROCESSING:							*/
	/* 1) If undelimited chars appeared at end of input, copy them exactly to end of output	*/
	/*    segment.  Adjust undelimited char index because length of output may be less than	*/
	/*    length of input (due to -unique, etc).					*/
	/* 2) If input and output strings are overlapping, copy output from temp seg in which we	*/
	/*    placed it originally into the final output string.				*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	if undelim_char_index > 0 then do;
	   substr(out, Lout+1, length(in)-(undelim_char_index-1)) =
	      substr(in, undelim_char_index);
	   Lout = Lout + length(in)-(undelim_char_index-1);
	   undelim_char_index = Lout + 1 - (length(in)-(undelim_char_index-1));
	   end;

	if Soverlap then do;
	   substr(Pout_real -> out, 1, Lout) = substr(out, 1, Lout);
	   Pout = Pout_real;
	   end;
	out_len = Lout;
	end output;

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

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* DEBUGGING DECLARATIONS AND FUNCTIONS						*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

    dcl  (Idu_nl, Iuu_nl, Isf_nl)	fixed bin(21),
	Ldu_line			fixed bin(21),
	Ldu_longest		fixed bin(21),
	Ldu_text			fixed bin(21),
	Lsf_line			fixed bin(21),
	Lsf_text			fixed bin(21),
	Luu_line			fixed bin(21),
	Luu_longest		fixed bin(21),
	Luu_text			fixed bin(21),
	Pdu_line			ptr,
	Pdu_text			ptr,
	Psf_line			ptr,
	Psf_text			ptr,
	Puu_line			ptr,
	Puu_text			ptr,
	du_line			char(Ldu_line) based(Pdu_line),
	du_text			char(Ldu_text) based(Pdu_text),
	du_text_char (Ldu_text)	char(1) based(Pdu_text),
	sf_line			char(Lsf_line) based(Psf_line),
	sf_text			char(Lsf_text) based(Psf_text),
	sf_text_char (Lsf_text)	char(1) based(Psf_text),
	uu_line			char(Luu_line) based(Puu_line),
	uu_text			char(Luu_text) based(Puu_text),
	uu_text_char (Luu_text)	char(1) based(Puu_text);

find_du_line:
	proc returns(bit(1));

	Pdu_line = addr(du_text);
	Ldu_line = index(du_text, NL);
	if Ldu_line = 0 then Ldu_line = length(du_text);
	if length(du_line) > 0 then do;
	   Pdu_text = addr(du_text_char(Ldu_line+1));
	   Ldu_text = Ldu_text - Ldu_line;
	   if substr(du_line,length(du_line),1) = NL then
	      Ldu_line = Ldu_line - 1;
	   return(TRUE);
	   end;
	else
	   return(FALSE);

find_uu_line:
	entry returns(bit(1));

	Puu_line = addr(uu_text);
	Luu_line = index(uu_text, NL);
	if Luu_line = 0 then Luu_line = length(uu_text);
	if length(uu_line) > 0 then do;
	   Puu_text = addr(uu_text_char(Luu_line+1));
	   Luu_text = Luu_text - Luu_line;
	   if substr(uu_line,length(uu_line),1) = NL then
	      Luu_line = Luu_line - 1;
	   return(TRUE);
	   end;
	else
	   return(FALSE);

find_sf_line:
	entry returns(bit(1));

	Psf_line = addr(sf_text);
	Lsf_line = index(sf_text, NL);
	if Lsf_line = 0 then Lsf_line = length(sf_text);
	if length(sf_line) > 0 then do;
	   Psf_text = addr(sf_text_char(Lsf_line+1));
	   Lsf_text = Lsf_text - Lsf_line;
	   if substr(sf_line,length(sf_line),1) = NL then
	      Lsf_line = Lsf_line - 1;
	   return(TRUE);
	   end;
	else
	   return(FALSE);

	end find_du_line;

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


get_temp_seg:
	proc (caller, seg_id, Ptemp) returns (bit(1) aligned);

    dcl	caller			char(*) varying,
          code                          fixed bin(35),
	seg_id			char(*),
	Ptemp			ptr;

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

	if Stemp_dir then call temp_seg_mgr$get (lcb_ptr, caller || "(" || seg_id || ")", temp_dir, Ptemp, code);
	else call get_temp_segment_ (caller || "(" || seg_id || ")", Ptemp, code);

	if code ^= 0 then call sub_err_ (code,  caller, ACTION_DEFAULT_RESTART, null, 0,
	     "While getting temporary segments for sort workspace.");
	return (code = 0);

release_temp_seg:
	entry (caller, seg_id, Ptemp);

	if Stemp_dir then call temp_seg_mgr$release (lcb_ptr, caller || "(" || seg_id || ")", Ptemp, 0);
	else call release_temp_segment_ (caller || "(" || seg_id || ")", Ptemp, 0);
	end get_temp_seg;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/
seg_janitor:
	proc(termination_mode, Sdelete_output_file);

    dcl	termination_mode		bit(*),
	Sdelete_output_file		bit(1);

    dcl	code			fixed bin(35);

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* ORDER OF OPERATION IN CLEANUP IS CRITICAL:					*/
	/* 1) Must first terminate input segment.  Since input and output segments may have been	*/
	/*    the same, forcing access to the output segment may have given us r access to input.	*/
	/*    So therefore, input must be terminated before any forced access is removed.	*/
	/* 2) Then terminate (or delete) output segment, since successful setting of bit count	*/
	/*    and truncation depend upon any forced access.				*/
	/* 3) Finally, restore any ACL changes made by forcing access.			*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	call sort_janitor();

	if Pin ^= null then
	   call terminate_file_ (Pin, 0, TERM_FILE_TERM, code);
	if Pout ^= null then do;
	   if Sdelete_output_file then		/* We created output file and sort failed, so	*/
	      call hcs_$delentry_seg (Pout, code);	/*   we must delete it.			*/
	   else
	      call terminate_file_ (Pout, out_len*9, termination_mode, code);
	   end;
	if Paccess ^= null then			/* If we created output file and sort failed, 	*/
	   call access_$reset (Paccess, code);		/*   access will never have been forced.	*/

	end seg_janitor;

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


sort_janitor:
	proc();

	if Soverlap then do;
	   if Pout = Pout_temp then
	      Pout = Pout_real;
	   call release_temp_seg (id, "temp output seg", Pout_temp);
	   end;
	if Puup = Pdup then
	   Puup = null;
	if Puu_str = addr(in) then
	   Puu_str = null;
	if Pdul = Puul then
	   Pdul = null;
	call release_temp_seg (id, "sort indices", Pidx);
	call release_temp_seg (id, "delim unit ptrs", Pdup);
	call release_temp_seg (id, "delim unit lths", Pdul);
	if Psf_str_array(Nsf_str_array) = null then
	   Psf_str_array(Nsf_str_array) = Psf_str;
	do Isf_str = 1 to Nsf_str_array;
	   Psf_str = Psf_str_array(Isf_str);
	   call release_temp_seg (id, "sort field strs", Psf_str);
	   end;
	call release_temp_seg (id, "sort field ptrs", Psfp);
	call release_temp_seg (id, "sort field lths", Psfl);
	call release_temp_seg (id, "undelim unit strs", Puu_str);
	call release_temp_seg (id, "undelim unit ptrs", Puup);
	call release_temp_seg (id, "undelim unit lths", Puul);
	call release_temp_seg (id, "undelim temp strs", Puu_temp);

	end sort_janitor;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/
table_janitor:
     proc();

         if Psave ^= null & component_number > 0 then do;
	  if Pdup = save.dup_ptr(component_number) then
	     save.dup_ptr (component_number) = null;
	  if Pidx = save.idx_ptr(component_number) then
	     save.idx_ptr (component_number) = null;
	  if Psfp = save.sfp_ptr(component_number) then
	     save.sfp_ptr (component_number) = null;
	  do Its = 1 to save.Nsf_strs;
	     do Isf_str = 1 to Nsf_str_array;
	        if save.sf_str_ptr(Its) = Psf_str_array(Isf_str) then
		 save.sf_str_ptr(Its) = null;
	        end;
	     end;
	  end;

         call sort_janitor();

         if Psave = null then return;
         do Its = 1 to component_number;				/* cleanup */
	    Pdup = save.dup_ptr(Its);
	    Pidx = save.idx_ptr(Its);
	    Psfp = save.sfp_ptr(Its);
	    call release_temp_seg (id, "delim unit ptrs", Pdup);
	    call release_temp_seg (id, "sort indices", Pidx);
	    call release_temp_seg (id, "sort field ptrs", Psfp);
	    end;

         do Its = 1 to save.Nsf_strs;
	    Psf_str = save.sf_str_ptr(Its);
	    call release_temp_seg (id, "sort field strs", Psf_str);
	    end;

         call release_temp_seg (id, "saved sort ptrs", Psave);

end table_janitor;
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

encode_numeric: proc (src_ptr, src_len, dp, encd_ptr, encd_len, code);


	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
	/*								        */
	/* This procedure encodes a source value to form a key. All supported data types are    */
	/* encoded in such a fashion that order is preserved. This allows true numeric sorting  */
	/* on the resulting key. This code was "borrowed" from mrds mu_encd_key.pl1.            */
	/*								        */
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

	      
          dcl     dp                     ptr parm;	/* Input: original data descriptor ptr */
          dcl    (bit_length, pad_length)fixed bin (35);
 	dcl     code		 fixed bin (35) parm;/* Output: status code */

						/* max bits allowed in encoded string */

	dcl     (src_ptr,				/* ptr to a source value */
	        cp_ptr)                ptr;               /* pointer to current position in key */

	dcl     (j,				/* index */
	        offset,				/* current bit position in key */
	        p)		 fixed bin;	/* precision of value */

	dcl     encd_len		 fixed bin (21);    /* char. length of key */
	dcl     encd_ptr		 ptr;		/* Output: ptr to  encoded value  */
	dcl     (power_delta,			/* increase in exp. for normaliz. */
	        shift_delta)	 fixed bin (7);	/* no chars to shift for norm. */
	dcl     fb7		 fixed bin (7) based unal; /* template */
	dcl     fb8		 fixed bin (8) based unal unsigned; /* template */
	dcl     1 fxb		 unal based (src_ptr), /* fixed bin template */
		2 sign		 bit (1) unal,
		2 val		 bit (p) unal;

	dcl     1 flb_src		 unal based (src_ptr), /* template for source float bin */
		2 esign		 bit (1) unal,
		2 eval		 bit (7) unal,
		2 msign		 bit (1) unal,
		2 mval		 bit (p) unal;

	dcl     1 flb_enc		 unal based (cp_ptr), /* template for encoded float bin */
		2 msign		 bit (1) unal,
		2 esign		 bit (1) unal,
		2 eval		 bit (7) unal,
		2 mval		 bit (p) unal;

	dcl     1 fxd		 unal based (src_ptr), /* template for fixed dec. */
		2 sign		 char (1) unal,
		2 digit		 (p) pic "9" unal;

	dcl     1 fld_src		 unal based (src_ptr), /* template for float dec source */
		2 msign		 char (1) unal,
		2 digit		 (p) pic "9" unal,
		2 epad		 bit (1) unal,
		2 esign		 bit (1) unal,
		2 eval		 bit (7) unal;

	dcl     1 fld_enc		 unal based (cp_ptr), /* template for float dec encoded */
		2 msign		 char (1) unal,
		2 epad		 bit (1) unal,
		2 esign		 bit (1) unal,
		2 eval		 bit (7) unal,
		2 digit		 (p) pic "9" unal;

	dcl     01 odd_fxd4_src	 based (src_ptr),
		02 pad1		 bit (1) unal,
		02 sign		 bit (4) unal,
		02 digits		 bit (digit_len) unal;

	dcl     01 even_fxd4_src	 based (src_ptr),
		02 pad1		 bit (1) unal,
		02 sign		 bit (4) unal,
		02 digits		 bit (digit_len) unal,
		02 pad2		 bit (4) unal;

	dcl     01 odd_fxd4_enc	 based (cp_ptr),
		02 pad1		 bit (1) unal init ("0"b),
		02 sign		 bit (4) unal,
		02 digits		 bit (digit_len) unal;

	dcl     01 even_fxd4_enc	 based (cp_ptr),
		02 pad1		 bit (1) unal init ("0"b),
		02 pad2		 bit (4) unal init ("0"b),
		02 sign		 bit (4) unal,
		02 digits		 bit (digit_len) unal;

	dcl     01 even_fld4_src	 based (src_ptr),
		02 pad1		 bit (1) unal,
		02 sign		 bit (4) unal,
		02 digits		 bit (digit_len) unal,
		02 exp,
		  03 sign		 bit (1) unal,
		  03 high		 bit (3) unal,
		  03 pad2		 bit (1) unal,
		  03 low		 bit (4) unal,
		  03 pad3		 bit (4) unal;

	dcl     01 odd_fld4_src	 based (src_ptr),
		02 pad1		 bit (1) unal,
		02 sign		 bit (4) unal,
		02 digits		 bit (digit_len) unal,
		02 exp,
		  03 pad2		 bit (1) unal,
		  03 sign		 bit (1) unal,
		  03 exp		 bit (7) unal;

	dcl     01 odd_fld4_enc	 based (cp_ptr),
		02 pad1		 bit (1) unal init ("0"b),
		02 pad2		 bit (1) unal init ("0"b),
		02 sign		 bit (4) unal,
		02 esign		 bit (1) unal,
		02 exp		 bit (7) unal,
		02 digits		 bit (digit_len) unal;

	dcl     01 even_fld4_enc	 based (cp_ptr),
		02 pad1		 bit (1) unal init ("0"b),
		02 pad2		 bit (1) unal init ("0"b),
		02 pad3		 bit (4) unal init ("0"b),
		02 sign		 bit (4) unal,
		02 esign		 bit (1) unal,
		02 exp		 bit (7) unal,
		02 digits		 bit (digit_len) unal;

	dcl     digit_len		 fixed bin;

	dcl     (mdbm_error_$unsup_type,
	        mdbm_error_$key_encd_ovfl) fixed bin (35) ext;

	dcl     valid_decimal_	 entry (fixed bin, ptr, fixed bin) returns (bit (1));
	dcl     mdbm_error_$invalid_dec_data fixed bin (35) ext;

          dcl     assign_                entry (ptr, fixed bin, fixed bin(35), ptr, fixed bin, fixed bin(35));
          dcl     org_ptr                ptr;
	dcl     org_data               fixed dec(59);
	dcl     org_type               fixed bin;
	dcl     char_type              fixed bin init(42) int static options (constant);   /* char_dtype * 2 */

          dcl     org_len                fixed bin (35);
          dcl     src_len                fixed bin (21);
	dcl     target_len_ptr         ptr;
	dcl     1 target_len aligned based (target_len_ptr),
	          2 scale              fixed bin(17) unaligned,
	          2 prec               fixed bin(18) unsigned unaligned;

	cp_ptr = encd_ptr;
	desc_ptr = dp;
	
	/* since we are given only character values,
	   we must convert back to the original type */
	org_ptr = addr(org_data);
	org_type = descriptor.type * 2;
	if descriptor.packed then org_type = org_type + 1;
	
	target_len_ptr = addr(org_len);
	target_len.prec = fixed(descriptor.size.precision);
	target_len.scale = fixed(descriptor.size.scale);
	
	call assign_ (org_ptr, org_type, org_len,
	   src_ptr, char_type, (src_len));
	
	src_ptr = org_ptr;
	go to encode (descriptor.type);		/* go encode this value */
	
encode (1):					/* fixed bin short */
	if descriptor.packed then p = fixed (descriptor.size.precision);
	else p = 35;
	call encode_fxb;
	go to next;
	
encode (2):					/* fixed bin long */
	if descriptor.packed then p = fixed (descriptor.size.precision);
	else p = 71;
	call encode_fxb;
	go to next;
	
encode (3):					/* float bin short */
	if descriptor.packed then p = fixed (descriptor.size.precision);
	else p = 27;
	call encode_flb;
	go to next;

encode (4):					/* float bin long */
	if descriptor.packed then p = fixed (descriptor.size.precision);
	else p = 63;
	call encode_flb;
	go to next;

encode (5):					/* complex fixed bin short */
encode (6):					/* complex fixed bin long */
encode (7):					/* complex float bin short */
encode (8):					/* complex float bin long */
	call error (mdbm_error_$unsup_type);

encode (9):					/* real fixed decimal */
	p = fixed (descriptor.size.precision);		/* will always pack */
	if fxd.sign = "+" then cp_ptr -> fxd.sign = "p";	/* change sign to preserve order */
	else cp_ptr -> fxd.sign = "n";
	if fxd.sign = "-" then /* if negative no, take 9's compl. */
	   do j = 1 to p;
	   cp_ptr -> fxd.digit (j) = 9 - fxd.digit (j);
	   end;
	else do j = 1 to p;				/* if positive, just copy digits */
	   cp_ptr -> fxd.digit (j) = fxd.digit (j);
	   end;
	offset = 9 * (p + 1);
	go to next;

encode (10):					/* real float decimal */
	p = fixed (descriptor.size.precision);
	call encode_fld;
	offset = 9 * (p + 2);
	go to next;

encode (11):					/* complex fixed decimal */
encode (12):					/* complex float decimal */
encode (13):					/* unsupported types */
encode (14):
encode (15):
encode (16):
encode (17):
encode (18):
encode (19):					/* bit string */
encode (21):					/* char. string */
encode (22):					/* varying char. string */
encode (23):
encode (24):
encode (25):
encode (26):
encode (27):
encode (28):
encode (29):
encode (30):
encode (31):
encode (32):
encode (33):
encode (34):
encode (35):
encode (36):
encode (37):
encode (38):
encode (39):
encode (40):
encode (41):
encode (42):
	call error (mdbm_error_$unsup_type);

encode (43):					/* fixed dec 4 */
	call encode_fxd4;
	bit_length = 9 * floor ((fixed (descriptor.size.precision) + 2) / 2);
	if ^descriptor.packed then if mod (bit_length, 36) ^= 0 then do;
	   pad_length = (36 - mod (bit_length, 36));
	   bit_length = bit_length + pad_length;
	   end;
	offset = bit_length;
	go to next;

encode (44):					/* float dec 4 */
	call encode_fld4;
	bit_length = 9 * floor ((fixed (descriptor.size.precision) + 4) / 2);
	if ^descriptor.packed then if mod (bit_length, 36) ^= 0 then do;
	   pad_length = (36 - mod (bit_length, 36));
	   bit_length = bit_length + pad_length;
	   end;
	offset =  bit_length;
	go to next;

encode (45):					/* cmplx float dec packed */
encode (46):					/* cmplx fixed dec packed */
	call error (mdbm_error_$unsup_type);

next:
	encd_len = divide (offset + 8, 9, 17, 0);
	code = 0;
exit:	
	return;


encode_fxb: proc;

/* Procedure to encode fixed bin, merely flips sign bit */

	cp_ptr -> fxb.sign = ^fxb.sign;
	cp_ptr -> fxb.val = fxb.val;
	offset = p + 1;

     end encode_fxb;


encode_flb: proc;

/* Procedure to encode float bin, merely transforms so that bit sort will
   order correctly. */

	flb_enc.msign = ^flb_src.msign;
	flb_enc.mval = flb_src.mval;
	if flb_src.msign = "1"b then /* if is neg. no */
	   addr (flb_enc.esign) -> fb8 = 128 - addr (flb_src.esign) -> fb8; /* compl. exp. */
						/* CHANGE 81-09-19 */
	else do;					/* positive, merely flip sign bit */
	   flb_enc.esign = ^flb_src.esign;
	   flb_enc.eval = flb_src.eval;
	   end;
	offset = p + 9;

     end encode_flb;

encode_fld: proc;
	if ^valid_decimal_ (bin (descriptor.type), src_ptr, bin (descriptor.size.precision))
	then call error (mdbm_error_$invalid_dec_data);
	do j = 1 to p while (fld_src.digit (j) = 0);	/* scan for first non-zero digit */
	end;
	if j > p then do;				/* have zero value */
	   fld_enc.msign = "p";
	   fld_enc.esign,
	      fld_enc.epad,
	      fld_enc.eval = "0"b;
	   do j = 1 to p;
	      fld_enc.digit (j) = 0;
	      end;
	   end;					/* if have zero value */
	else do;					/* for non-zero values */
	   power_delta = p - j + 1;			/* number to add to exponent */
	   shift_delta = j - 1;			/* no. characters to shift */
	   if addr (fld_src.esign) -> fb7 
	      + power_delta > 127 then		/* if will overflow */
	      call error (mdbm_error_$key_encd_ovfl);
	   addr (fld_enc.esign) -> fb7 = addr (fld_src.esign) -> fb7 + power_delta;
	   fld_enc.epad = "0"b;
	   if fld_src.msign = "-" then do;		/* if negative no. */
	      fld_enc.msign = "n";
	      do j = 1 to p - shift_delta;		/* 9's compl. of signif. digits to front */
	         fld_enc.digit (j) = 9 - fld_src.digit (j + shift_delta);
	         end;
	      do j = p - shift_delta + 1 to p;		/* fill in trailing 9's */
	         fld_enc.digit (j) = 9;
	         end;
	      addr (fld_enc.esign) -> fb7 =
	         128 - addr (fld_enc.esign) -> fb7;	/* complement exp. so will sort right */
	      end;				/* if negative no. */
	   else do;				/* if positive no. */
	      fld_enc.msign = "p";
	      do j = 1 to p - shift_delta;		/* move signif. digits to front */
	         fld_enc.digit (j) = fld_src.digit (j + shift_delta);
	         end;
	      do j = p - shift_delta + 1 to p;		/* put in trailing 0's */
	         fld_enc.digit (j) = 0;
	         end;
	      fld_enc.esign = ^fld_enc.esign;		/* flip sign bit so will sort right */
	      end;				/* if positive no. */
	   end;					/* if non-zero */
	end encode_fld;

/* Encoding algorithm for fixed and float decimal unaligned

   for a fixed data type just ignore rules about exponent.

   For negative numbers (sign = "1101"b)
   1. set sign to "0000"b
   2. copy sign of exponent
   3. copy complement of exponent
   4. copy complement of number

   For positive numbers (sign = "1101"b)
   1. set sign to "1111"b
   2. copy number
   3. if number is zero
   a. set exponent to "0000000"b
   b. set sign of exponent to "0"b
   4. if number is not zero
   a. copy exponent
   b. copy sign of exponent

   Note: zero is normally stored as a positive number with the maximum possible
   exponent.
*/

encode_fxd4: proc;
	p = fixed (descriptor.size.precision);
	if mod (p, 2) = 1
	   then do;
	   digit_len = ((p - 1) / 2 * 9) + 4;
	   if odd_fxd4_src.sign = "1101"b
	      then do;
	      odd_fxd4_enc.sign = "0000"b;
	      odd_fxd4_enc.digits = ^(odd_fxd4_src.digits);
	      end;
	   else do;
	      odd_fxd4_enc.sign = "1111"b;
	      odd_fxd4_enc.digits = odd_fxd4_src.digits;
	      end;
	   end;
	else do;
	   digit_len = (p / 2) * 9;
	   if even_fxd4_src.sign = "1101"b
	      then do;
	      even_fxd4_enc.sign = "0000"b;
	      even_fxd4_enc.digits = ^(even_fxd4_src.digits);
	      end;
	   else do;
	      even_fxd4_enc.sign = "1111"b;
	      even_fxd4_enc.digits = even_fxd4_src.digits;
	      end;
	   end;
	end encode_fxd4;

encode_fld4: proc;
	p = fixed (descriptor.size.precision);
	if mod (p, 2) = 1
	   then do;
	   digit_len = (((p - 1) / 2) * 9) + 4;
	   if odd_fld4_src.sign = "1101"b
	      then do;
	      odd_fld4_enc.sign = "0000"b;
	      odd_fld4_enc.esign = odd_fld4_src.exp.sign;
	      odd_fld4_enc.exp = ^(odd_fld4_src.exp.exp);
	      odd_fld4_enc.digits = ^(odd_fld4_src.digits);
	      end;
	   else do;
	      odd_fld4_enc.sign = "1111"b;
	      odd_fld4_enc.digits = odd_fld4_src.digits;
	      if odd_fld4_src.digits = "0"b
	         then do;
	         odd_fld4_enc.esign = "0"b;
	         odd_fld4_enc.exp = "0"b;
	         end;
	      else do;
	         odd_fld4_enc.esign = ^(odd_fld4_src.exp.sign);
	         odd_fld4_enc.exp = odd_fld4_src.exp.exp;
	         end;
	      end;
	   end;
	else do;
	   digit_len = (p / 2) * 9;
	   if even_fld4_src.sign = "1101"b
	      then do;
	      even_fld4_enc.sign = "0000"b;
	      even_fld4_enc.esign = even_fld4_src.exp.sign;
	      even_fld4_enc.exp = ^(even_fld4_src.exp.high) || ^(even_fld4_src.exp.low);
	      even_fld4_enc.digits = ^(even_fld4_src.digits);
	      end;
	   else do;
	      even_fld4_enc.sign = "1111"b;
	      even_fld4_enc.digits = even_fld4_src.digits;
	      if even_fld4_src.digits = "0"b
	         then do;
	         even_fld4_enc.esign = "0"b;
	         even_fld4_enc.exp = "0"b;
	         end;
	      else do;
	         even_fld4_enc.esign = ^(even_fld4_src.exp.sign);
	         even_fld4_enc.exp = even_fld4_src.exp.high || even_fld4_src.exp.low;
	         end;
	      end;
	   end;
	end encode_fld4;

error: proc (cd);

/* error procedure */

	dcl     cd		 fixed bin (35);

	code = cd;
	go to exit;

	end error;
       end encode_numeric;
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

%include access_mode_values;

%include sort_seg_info;

%include mdbm_descriptor;

%include terminate_file;

%include std_descriptor_types;

%include sub_err_flags;

	end sort_seg_;
     



		    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
