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