COMPILATION LISTING OF SEGMENT apl_grade_up_ Compiled by: Multics PL/I Compiler, Release 28d, of October 4, 1983 Compiled at: Honeywell LCPD Phoenix, System M Compiled on: 11/29/83 1607.1 mst Tue Options: optimize map 1 /* ****************************************************** 2* * * 3* * * 4* * Copyright (c) 1972 by Massachusetts Institute of * 5* * Technology and Honeywell Information Systems, Inc. * 6* * * 7* * * 8* ****************************************************** */ 9 10 /* This module implements the APL grade-up and grade-down operators. Each column is sorted in the sense that 11* indices that would sort that column were they used as subscripts are returned. The result is thus an array 12* of integers which conforms with the operand. The Singleton sort algorithm is used. (CACM 12, #3, March 1969, p185-187) 13* 14* Created Oct 3, 1973 by G. Gordon Benedict 15* 16* Modified December 19, 1973 by PG to really use the Singleton sort. 17* Modified December 30, 1973 by PG to be able to sort maximum-sized value. 18* Modified 760922 by PG to split apl_grade_up_ from apl_grade_down_. 19* Modified 780209 by PG to use apl_push_stack_ (bug 278) 20**/ 21 22 apl_grade_up_: 23 procedure (operators_argument); /* implements grade up */ 24 25 declare numeric_datum_or1 float dimension (data_elements) based;/* for efficiently getting "size" */ 26 27 declare (apl_error_table_$rank, 28 apl_error_table_$domain) static external fixed binary (35); /* naughty */ 29 30 declare (operand_vb, /* pointer to value bead of operand (argument) */ 31 operand_array, /* pointer to operand array */ 32 result_vb, /* result value bead ptr */ 33 result_array, /* pointer to result array */ 34 data_pointer, /* return argument of push_value_stack */ 35 index_base) pointer; /* pointer to base of indices for this column */ 36 37 declare (rhorho, /* number of dimensions in operand and result */ 38 data_elements, /* no of numbers in operand and result */ 39 dimension, /* the dimension along which to perform the grade */ 40 rho_sub_dimension, /* the length of that dimension */ 41 interval_between_elements, /* no of elements inbetween each element of a column */ 42 plane_base, /* subscript which indicates the base of a plane */ 43 column_base, /* subscript which indicates the base of a column */ 44 column_skip_interval, /* interval between base of columns */ 45 rho_subscript, /* random subscript */ 46 last_column_on_this_plane, /* offset to last column before plane_base must be changed */ 47 first, /* used in actual sort. lowest element in a partition */ 48 swap_temp, /* used for swapping index entries */ 49 last, /* highest element in a partition */ 50 median, /* index of middle datum */ 51 low, /* moves up from first, looking for elements > median_value */ 52 high, /* moves down from last, looking for elements < median_value */ 53 median_index, /* temporary used to hold indices (median) in loops */ 54 depth) /* depth in recursion (partition count) */ 55 fixed binary; 56 57 declare swap_em /* flag used to eliminate goto's in comparison code */ 58 bit (1) aligned; 59 60 declare bubble_is_ok initial (13) /* how short a vector must be to bubble sort it */ 61 fixed binary internal static; 62 63 declare total_words_needed /* words to allocate for allocate subroutine */ 64 fixed bin (19); 65 66 declare 1 stack (0 : 18) aligned, /* holds bounds of partitions as we "recurse" */ 67 2 first fixed binary, /* lower bound */ 68 2 last fixed binary; /* upper bound */ 69 70 declare (float_index, /* used in converting from indices values to APL subscripts */ 71 index_origin, /* a copy of ws_info.float_index_origin for efficiency */ 72 median_value) float; /* a guess of mean value of array */ 73 74 declare (addr, 75 addrel, 76 divide, 77 fixed, 78 float, 79 hbound, 80 rel, 81 size, 82 string, 83 substr) builtin; 84 85 declare indices (0 : rho_sub_dimension - 1) fixed binary based (index_base); /* these are permuted rather than 86* actual argument array; they tell where that element would be */ 87 88 declare rho_copy_overlay (rhorho) fixed binary (34) based; /* used for copying rho vectors quickly */ 89 90 declare apl_get_next_value_stack_seg_ entry (fixed binary (18)); /* subroutine to allocate new value stack */ 91 92 /* include files */ 93 1 1 /* ====== BEGIN INCLUDE SEGMENT apl_number_data.incl.pl1 ================================== */ 1 2 1 3 /* 1 4* This include file contains information about the machine representation of numbers. 1 5* In all programs numbers should simply be declared 'float'. 1 6* All default statements should be in this include file. 1 7* 1 8* This is the binary version. The manifest constant Binary should be used by programs 1 9* that need to know whether we are using binary or decimal. 1 10* */ 1 11 1 12 /* format: style3,initlm0,idind30 */ 1 13 1 14 default (float & ^decimal & ^binary & ^precision & ^constant) float binary (63); 1 15 1 16 declare ( 1 17 TheBiggestNumberWeveGot float initial (0.1701411834604692317e+39), 1 18 TheSmallestNumberWeveGot float initial (.1469367938527859385e-38), 1 19 Binary bit (1) aligned initial ("1"b) 1 20 ) internal static options (constant); 1 21 1 22 /* Number of characters in a number datum entry; used for copying float number arrays as strings. 1 23* (Obsolete! use array copies!) */ 1 24 1 25 declare NumberSize fixed binary precision (4) internal static initial (8); 1 26 1 27 /* ------ END INCLUDE SEGMENT apl_number_data.incl.pl1 ---------------------------------- */ 94 2 1 /* ====== BEGIN INCLUDE SEGEMENT apl_operators_argument.incl.pl1 =========================== */ 2 2 2 3 declare 1 operators_argument aligned, 2 4 2 operands (2) aligned, /* these are the operands to the operator to be executed. 2 5* if operand (1).value is null, operator is monadic */ 2 6 3 value pointer unaligned, /* a pointer to the value bead for this operand */ 2 7 3 on_stack bit (1) aligned, /* ON if this value resides on the value stack */ 2 8 2 operator aligned, /* information about the operator to be executed */ 2 9 3 dimension fixed bin, /* (optional) dimension along which to operate */ 2 10 3 padding bit (18) unaligned, /* unused part of operator bead */ 2 11 3 op2 fixed bin (8) unal, /* a modifier for op1, or a 2nd operator if inner product */ 2 12 3 op1 fixed bin (8) unal, /* code for the actual operator to be executed */ 2 13 2 result pointer unal, /* (output) set by operator to point to result bead in stack */ 2 14 2 error_code fixed bin (35), /* (output) set before signaling apl_operator_error_ */ 2 15 2 where_error fixed bin; /* parseme index of where error was - parse sets to operator */ 2 16 2 17 /* ------ END INCLUDE SEGMENT apl_operators_argument.incl.pl1 --------------------------- */ 95 3 1 /* ====== BEGIN INCLUDE SEGMENT apl_bead_format.incl.pl1 ================================== */ 3 2 3 3 declare 1 general_bead aligned based, /* The Venerable Bead */ 3 4 2 type unaligned, 3 5 3 bead_type unaligned, 3 6 4 operator bit (1), /* ON if operator bead */ 3 7 4 symbol bit (1), /* ON if symbol bead */ 3 8 4 value bit (1), /* ON if value bead */ 3 9 4 function bit (1), /* ON if function bead */ 3 10 4 group bit (1), /* ON if group bead */ 3 11 4 label bit (1), /* ON if label bead */ 3 12 4 shared_variable bit (1), /* ON if shared variable bead */ 3 13 4 lexed_function bit (1), /* ON if lexed function bead */ 3 14 3 data_type unaligned, 3 15 4 list_value bit (1), /* ON if a list value bead */ 3 16 4 character_value bit (1), /* ON if a character value bead */ 3 17 4 numeric_value bit (1), /* ON if a numeric value bead */ 3 18 4 integral_value bit (1), /* ON if an integral value bead */ 3 19 4 zero_or_one_value bit (1), /* ON if a boolean value bead */ 3 20 4 complex_value bit (1), /* ON if a complex, numeric value bead */ 3 21 3 unused_bits bit (4) unaligned, /* pad to 18 bits (for future use) */ 3 22 2 size bit (18) unaligned, /* Number of words this bead occupies 3 23* (used by bead storage manager) */ 3 24 2 reference_count fixed binary (29); /* Number of pointers which point 3 25* to this bead (used by bead manager) */ 3 26 3 27 3 28 /* constant strings for initing type field in various beads */ 3 29 3 30 declare ( 3 31 operator_type init("100000000000000000"b), 3 32 symbol_type init("010000000000000000"b), 3 33 value_type init("001000000000000000"b), 3 34 function_type init("000100000000000000"b), 3 35 group_type init("000010000000000000"b), 3 36 label_type init("001001000011000000"b), 3 37 shared_variable_type init("001000100000000000"b), 3 38 lexed_function_type init("000000010000000000"b), 3 39 3 40 list_value_type init("000000001000000000"b), 3 41 character_value_type init("001000000100000000"b), 3 42 numeric_value_type init("001000000010000000"b), 3 43 integral_value_type init("001000000011000000"b), 3 44 zero_or_one_value_type init("001000000011100000"b), 3 45 complex_value_type init("001000000000010000"b), 3 46 3 47 not_integer_mask init("111111111110011111"b), /* to clear integral, zero_or_one bits */ 3 48 not_zero_or_one_mask init("111111111111011111"b) /* to clear zero_or_one bit */ 3 49 ) bit(18) internal static; 3 50 3 51 /* ------ END INCLUDE SEGMENT apl_bead_format.incl.pl1 ---------------------------------- */ 96 4 1 /* ====== BEGIN INCLUDE SEGMENT apl_value_bead.incl.pl1 =================================== */ 4 2 4 3 declare 4 4 number_of_dimensions fixed bin, 4 5 4 6 1 value_bead aligned based, 4 7 2 header aligned like general_bead, 4 8 2 total_data_elements fixed binary (21), /* length of ,[value] in APL */ 4 9 2 rhorho fixed binary, /* number of dimensions of value */ 4 10 2 data_pointer pointer unaligned, /* packed pointer to the data in value */ 4 11 2 rho fixed binary (21) dimension (number_of_dimensions refer (value_bead.rhorho)); 4 12 /* dimensions of value (zero-origin) */ 4 13 4 14 4 15 declare 1 character_data_structure aligned based, /* alignment trick for PL/I compiler */ 4 16 2 character_datum character (1) unaligned dimension (0:data_elements - 1); 4 17 /* actual elements of character array */ 4 18 4 19 declare character_string_overlay character (data_elements) aligned based; 4 20 /* to overlay on above structure */ 4 21 4 22 4 23 declare numeric_datum float aligned dimension (0:data_elements - 1) based; 4 24 /* actual elements of numeric array */ 4 25 4 26 declare complex_datum complex float aligned dimension (0:data_elements -1) based; 4 27 4 28 declare MAX_VALUE_BEAD_SIZE fixed bin (19) init (261120) int static options (constant); 4 29 4 30 /* ------ END INCLUDE SEGMENT apl_value_bead.incl.pl1 ----------------------------------- */ 97 5 1 /* ====== BEGIN INCLUDE SEGMENT apl_ws_info.incl.pl1 ====================================== */ 5 2 5 3 /* This structure contains all of the global data (or pointers to it) for the APL subsystem */ 5 4 5 5 /* automatic */ 5 6 5 7 declare ws_info_ptr ptr initial (apl_static_$ws_info_ptr.static_ws_info_ptr); 5 8 5 9 /* external static */ 5 10 5 11 declare 1 apl_static_$ws_info_ptr external static aligned structure, 5 12 2 static_ws_info_ptr unaligned pointer; 5 13 5 14 /* based */ 5 15 5 16 declare 1 ws_info aligned based (ws_info_ptr), 5 17 2 version_number fixed bin, /* version of this structure (3) */ 5 18 2 switches unaligned, /* mainly ws parameters */ 5 19 3 long_error_mode bit, /* if 1, long Multics format, else APL/360 format */ 5 20 3 debug_mode bit, /* if 1, system error causes escape to command level */ 5 21 3 canonicalize_mode bit, /* if 1, the editor canonicalizes user input */ 5 22 3 restrict_exec_command bit, /* if 1, the )EXEC command may not be used */ 5 23 3 restrict_debug_command bit, /* if 1, the )DEBUG command may not be used */ 5 24 3 restrict_external_functions 5 25 bit, /* if 1, the )ZFN, )MFN, and )DFN commands may not be used */ 5 26 3 restrict_load bit, /* if 1, the )LOAD and )COPY commands may not be used */ 5 27 3 restrict_load_directory bit, /* if 1, no directory allowed in )LOAD or )COPY pathnames */ 5 28 3 restrict_save bit, /* if 1, the )SAVE command may not be used */ 5 29 3 restrict_save_directory bit, /* if 1, no directory allowed in )SAVE pathnames */ 5 30 3 off_hold bit, /* if 1, )OFF HOLD was typed, else just )OFF */ 5 31 3 transparent_to_signals bit, /* if 1, any conditions slip right past APL */ 5 32 3 meter_mode bit, /* if 1, metering may be done, else speed is all-important */ 5 33 3 restrict_msg_command bit, /* if 1, the )MSG command may not be used. */ 5 34 3 compatibility_check_mode 5 35 bit, /* if 1, check for incompatible operators */ 5 36 3 no_quit_handler bit, /* if 1, do not trap QUITs. */ 5 37 /* remaining 20 bits not presently used */ 5 38 5 39 2 values, /* attributes of the workspace */ 5 40 3 digits fixed bin, /* number of digits of precision printed on output */ 5 41 3 width fixed bin, /* line length for formatted output */ 5 42 3 index_origin fixed bin, /* the index origin (0 or 1) */ 5 43 3 random_link fixed bin(35), /* seed for random number generator */ 5 44 3 fuzz float, /* comparison tolerance (relative fuzz) */ 5 45 3 float_index_origin float, /* the index origin in floating point */ 5 46 3 number_of_symbols fixed bin, /* the number of symbol_beads currently in existence */ 5 47 3 maximum_value_stack_size 5 48 fixed bin (18), /* maximum number of words in one segment of value stack */ 5 49 5 50 2 pointers, /* pointers to various internal tables */ 5 51 3 symbol_table_ptr unaligned pointer, /* -> symbol_table (apl_symbol_table.incl.pl1) */ 5 52 3 current_parse_frame_ptr unaligned pointer, /* -> topmost parse frame */ 5 53 3 value_stack_ptr unaligned pointer, /* -> next free location on value stack */ 5 54 3 alloc_free_info_ptr unaligned pointer, /* -> apl_storage_mngr_ data (apl_storage_system_data.incl.pl1) */ 5 55 5 56 2 time_invoked fixed bin(71), /* clock time that APL was entered */ 5 57 2 integer_fuzz float, /* the absolute fuzz used in checking for integers */ 5 58 2 user_number fixed bin(35), /* number under which the user is signed on */ 5 59 2 latent_expression unaligned pointer, /* -> value_bead for QuadLX */ 5 60 2 lock char(32), /* the lock currently set on this workspace (password) */ 5 61 2 wsid char(100), /* the workspace identification: name, number name, or clear ws */ 5 62 2 last_error_code fixed bin(35), /* last code passed to apl_error_ */ 5 63 2 signoff_lock character (32), 5 64 5 65 2 interrupt_info aligned, /* bits used by apl_interpreter_ to tell when to abort */ 5 66 3 dont_interrupt_parse bit, /* if 1, don't do a dirty stop because the parser is running */ 5 67 3 dont_interrupt_operator bit, /* if 1, don't do a dirty stop because an operator is running */ 5 68 3 dont_interrupt_storage_manager /* if 1, don't stop because apl_storage_mngr_ is */ 5 69 bit, /* munging his tables */ 5 70 3 unused_interrupt_bit bit, /* not presently used */ 5 71 3 dont_interrupt_command bit, 5 72 3 can_be_interrupted bit, /* if 1, OK to do a clean stop (we are between lines, reading) */ 5 73 3 clean_interrupt_pending bit, /* interrupt occured, break cleanly (between lines) */ 5 74 3 dirty_interrupt_pending bit, /* interrupt occured, break as soon as not inhibited */ 5 75 5 76 2 user_name char (32), /* process group id of user */ 5 77 2 immediate_input_prompt char (32) varying, /* normal input */ 5 78 2 evaluated_input_prompt char (32) varying, /* quad input */ 5 79 2 character_input_prompt char (32) varying, /* quad-quote input */ 5 80 2 vcpu_time aligned, 5 81 3 total fixed bin (71), 5 82 3 setup fixed bin (71), 5 83 3 parse fixed bin (71), 5 84 3 lex fixed bin (71), 5 85 3 operator fixed bin (71), 5 86 3 storage_manager fixed bin (71), 5 87 2 output_info aligned, /* data pertaining to output buffer */ 5 88 3 output_buffer_ptr unal ptr, /* ptr to output buffer */ 5 89 3 output_buffer_len fixed bin (21), /* length (bytes) of output buffer */ 5 90 3 output_buffer_pos fixed bin (21), /* index of next byte to write in */ 5 91 3 output_buffer_ll fixed bin (21), /* print positions used up so far */ 5 92 2 tab_width fixed bin (21); /* number of columns a tabs moves cursor */ 5 93 5 94 declare output_buffer char (ws_info.output_buffer_len) based (ws_info.output_buffer_ptr); 5 95 5 96 /* internal static */ 5 97 5 98 declare max_parse_stack_depth fixed bin int static init(64536); 5 99 5 100 /* ------ END INCLUDE SEGMENT apl_ws_info.incl.pl1 -------------------------------------- */ 98 99 100 /* Look at arguments, check rank, get storage, etc. */ 101 102 operand_vb = operators_argument.operands (2).value; 103 if ^ operand_vb -> value_bead.header.type.data_type.numeric_value then goto domain_error; 104 105 data_elements = operand_vb -> value_bead.total_data_elements; /* no. of entries in array */ 106 operand_array = operand_vb -> value_bead.data_pointer; /* ptr to the array */ 107 dimension = operators_argument.dimension; /* dimension along which to sort */ 108 rhorho = operand_vb -> value_bead.rhorho; /* extract dimensionality */ 109 110 if rhorho = 0 then goto rank_error; /* cannot be scalar */ 111 112 if rhorho < dimension then goto rank_error; 113 114 /* Calculate interval between elements and interval between column bases */ 115 116 interval_between_elements = 1; 117 do rho_subscript = dimension by 1 while (rho_subscript < rhorho); 118 interval_between_elements = interval_between_elements * 119 operand_vb -> value_bead.rho (rho_subscript + 1); 120 end; 121 122 rho_sub_dimension = operand_vb -> value_bead.rho (dimension); 123 column_skip_interval = rho_sub_dimension * interval_between_elements; /* column base separation */ 124 125 /* A temporary operand of indices are needed. If the operand is on the stack the final result can be stored 126* there column by column as it is generated (since a column once referenced is never referenced again). 127* Therefore only the table of indices will be allocated, which has one element for each element in a 128* column to reduce. If operand is not on the stack, then a result bead, a result array, and a table 129* of indices will be allocated */ 130 131 index_origin = ws_info.float_index_origin; 132 133 if operators_argument.operands (2).on_stack /* overlay operand with result */ 134 then do; 135 operators_argument.result, /* result will be returned in same place as operand */ 136 result_vb = operand_vb; 137 result_array = operand_array; /* store result over operand */ 138 end; 139 else do; /* not on stack. Must allocate new bead, new array, and indices */ 140 number_of_dimensions = rhorho; 141 total_words_needed = size (value_bead) + size (numeric_datum_or1) + 1; 142 operators_argument.result, 143 result_vb = apl_push_stack_ (total_words_needed); /* set result pointers to allocated area */ 144 result_array = addr (result_vb -> value_bead.rho (rhorho + 1)); 145 146 if substr (rel (result_array), 18, 1) /* if odd data boundary */ 147 then result_array = addrel (result_array, 1); 148 149 result_vb -> value_bead.rhorho = rhorho; 150 result_vb -> value_bead.total_data_elements = data_elements; 151 result_vb -> value_bead.data_pointer = result_array; 152 if rhorho > 0 /* copy rho vector */ 153 then addr (result_vb -> value_bead.rho) -> rho_copy_overlay = 154 addr (operand_vb -> value_bead.rho) -> rho_copy_overlay; 155 end; 156 157 total_words_needed = rho_sub_dimension; /* allocate indices. Must do it separately so that 158* we can sort maximum-sized value, which will need 159* a whole value stack for operand, in that case 160* this temporary will go in a new segment. */ 161 index_base = apl_push_stack_ (total_words_needed); 162 163 string (result_vb -> value_bead.header.type) = /* subscripts are always integers */ 164 integral_value_type; 165 166 /* If operand is scalar just return the index origin */ 167 168 if data_elements = 1 /* effective scalar */ 169 then do; 170 result_array -> numeric_datum (0) = index_origin; 171 return; 172 end; 173 174 /* Main loop. The two outer loops find the offset of the base of the column to sort */ 175 176 do plane_base = 0 repeat (plane_base + column_skip_interval) while (plane_base < data_elements); 177 178 last_column_on_this_plane = plane_base + interval_between_elements; /* offset to last column, plus 1 */ 179 180 do column_base = plane_base by 1 while (column_base < last_column_on_this_plane); 181 182 /* Into the indices insert index values which point to the elements in the 183* operand array that are in this column. */ 184 185 indices (0) = column_base; /* point to first data element in column to sort */ 186 187 do rho_subscript = 1 by 1 while (rho_subscript < rho_sub_dimension); 188 indices (rho_subscript) = indices (rho_subscript - 1) + interval_between_elements; 189 end; 190 191 /* This loop actually sorts the column contained in the indices vector. 192* Note that the data is never moved, only the subscripts. */ 193 194 first = 0; /* lowest subscript into indices starts out at bottom */ 195 last = rho_sub_dimension - 1; /* Believe me, this is last one */ 196 depth = -1; /* no recursion yet */ 197 198 repeat_sort: /* comes back here to process each partition */ 199 if last - first <= bubble_is_ok 200 then if first ^= 0 | last <= 0 /* true unless this is first partition, and it has */ 201 then do; /* some elements. We can't bubble that one case */ 202 call bubble_sort (); 203 go to pop_stack; 204 end; 205 206 low = first; 207 median = divide (first + last, 2, 18, 0); 208 high = last; 209 210 /* first step is to sort the first, median, and last values of the data 211* such that first <= median <= last. This causes the upward and downward 212* scans to be "data limited" so that they are guaranteed not to run 213* off the end of the array. Grade up & grade down are not totally 214* symmetrical, since equal elements always have their indices 215* in ascending order. */ 216 217 swap_em = "0"b; 218 219 if operand_array -> numeric_datum (indices (first)) > 220 operand_array -> numeric_datum (indices (median)) 221 then swap_em = "1"b; 222 else if operand_array -> numeric_datum (indices (first)) = 223 operand_array -> numeric_datum (indices (median)) 224 then if indices (first) > indices (median) 225 then swap_em = "1"b; 226 227 if swap_em 228 then do; 229 swap_temp = indices (median); 230 indices (median) = indices (first); 231 indices (first) = swap_temp; 232 swap_em = "0"b; 233 end; 234 235 if operand_array -> numeric_datum (indices (last)) < 236 operand_array -> numeric_datum (indices (median)) 237 then swap_em = "1"b; 238 else if operand_array -> numeric_datum (indices (last)) = 239 operand_array -> numeric_datum (indices (median)) 240 then if indices (last) < indices (median) 241 then swap_em = "1"b; 242 243 if swap_em 244 then do; 245 swap_temp = indices (median); 246 indices (median) = indices (last); 247 indices (last) = swap_temp; 248 249 swap_em = "0"b; 250 251 if operand_array -> numeric_datum (indices (first)) > 252 operand_array -> numeric_datum (indices (median)) 253 then swap_em = "1"b; 254 else if operand_array -> numeric_datum (indices (first)) = 255 operand_array -> numeric_datum (indices (median)) 256 then if indices (first) > indices (median) 257 then swap_em = "1"b; 258 259 if swap_em 260 then do; 261 swap_temp = indices (median); 262 indices (median) = indices (first); 263 indices (first) = swap_temp; 264 end; 265 end; 266 267 /* Now we can actually select the value which will be used to partition 268* the data into two sublists. The "low" sublist will be all values, starting 269* from the lower end of the array, which are less than the median value. 270* The "high" sublist will be all values, starting from the upper end of the 271* array, which are greater than the median value. */ 272 273 median_index = indices (median); 274 median_value = operand_array -> numeric_datum (median_index); 275 276 grade_repeat: 277 do high = high - 1 by -1 while (operand_array -> numeric_datum (indices (high)) > median_value); 278 end; 279 280 if operand_array -> numeric_datum (indices (high)) = median_value 281 then if indices (high) > median_index 282 then go to grade_repeat; 283 284 grade_repeat_up: 285 do low = low + 1 by 1 while (operand_array -> numeric_datum (indices (low)) < median_value); 286 end; 287 288 if operand_array -> numeric_datum (indices (low)) = median_value 289 then if indices (low) < median_index 290 then go to grade_repeat_up; 291 292 if low <= high 293 then do; 294 swap_temp = indices (high); 295 indices (high) = indices (low); 296 indices (low) = swap_temp; 297 go to grade_repeat; 298 end; 299 300 /* recursion occurs here in sense that the file is partitioned and the partition indices are stacked */ 301 302 /* This algorithm can sort up to ^1+2*K+1 elements, according to Knuth 303* and Singleton (In PL/I notation, (2**(k+1))-1), where K = dimension (stack, 1). 304* Since the largest APL value must fit in one 256K segment (2*18 words), 305* K = 17 is sufficient. */ 306 307 /* The reason we can sort so many items, in place, with so little storage, is that 308* Singleton's algorithm saves the larger of the two sublists, and then recurses 309* on the smaller list. Should it do it in the other order, no stack 310* less in size than the original list would be good enough (more or less). 311* By saving the larger list, the worst case for recursion is when the smaller list 312* is consistently just less than 1/2 of the combined sizes. The reader will quickly 313* note that this implies that the size of the stack need only be logarithmically 314* as large as the number of items to be sorted. */ 315 316 depth = depth + 1; /* push a new frame */ 317 318 if (high - first) > (last - low) 319 then do; 320 stack (depth).first = first; /* lower sublist is bigger */ 321 stack (depth).last = high; 322 first = low; /* so sort the upper one */ 323 end; 324 else do; 325 stack (depth).first = low; /* upper sublist is bigger */ 326 stack (depth).last = last; 327 last = high; /* so sort the lower one */ 328 end; 329 330 go to repeat_sort; 331 332 pop_stack: /* sort partition whose bounds are now stacked at end */ 333 if depth >= 0 /* not done with this column, nor is stack all popped */ 334 then do; 335 first = stack (depth).first; /* extract bounds of this partition */ 336 last = stack (depth).last; 337 depth = depth - 1; /* reduce "stack pointer" to previous frame */ 338 go to repeat_sort; /* sort previous partition */ 339 end; 340 341 /* Now have produced a permutation vector for an entire column. Convert this vector into a vector of subscripts and 342* store it into the result array. This is done by having a subscript increment from the index origin, each 343* time storing it into an element of the result vector specified by the corresponding element of the indices */ 344 345 swap_temp = column_base; 346 do rho_subscript = 0 by 1 while (rho_subscript < rho_sub_dimension); /* thru whole index vector */ 347 result_array -> numeric_datum (swap_temp) = 348 float (divide (indices (rho_subscript) - column_base, interval_between_elements, 17, 0)) 349 + index_origin; 350 swap_temp = swap_temp + interval_between_elements; /* next subscript */ 351 end; 352 end; 353 end; 354 355 ws_info.value_stack_ptr = index_base; /* pop index array */ 356 return; 357 358 /* Various types of errors */ 359 360 rank_error: 361 operators_argument.error_code = apl_error_table_$rank; 362 operators_argument.where_error = operators_argument.where_error - 1; /* right operand */ 363 return; 364 365 domain_error: 366 operators_argument.error_code = apl_error_table_$domain; 367 operators_argument.where_error = operators_argument.where_error - 1; /* right operand */ 368 return; 369 370 /* Internal procedure to perform a data-limited bubble sort on the vector from "first" to "last". */ 371 372 bubble_sort: 373 procedure (); 374 375 do first = first + 1 to last; 376 median_index = indices (first); 377 median_value = operand_array -> numeric_datum (median_index); 378 379 low = first; 380 bubble_repeat: 381 do low = low - 1 by -1 while (operand_array -> numeric_datum (indices (low)) > median_value); 382 indices (low + 1) = indices (low); 383 end; 384 if operand_array -> numeric_datum (indices (low)) = median_value 385 then if indices (low) > median_index 386 then do; 387 indices (low + 1) = indices (low); 388 go to bubble_repeat; 389 end; 390 391 indices (low + 1) = median_index; 392 end; 393 394 return; 395 396 end bubble_sort; 397 6 1 /* ====== BEGIN INCLUDE SEGMENT apl_push_stack_fcn.incl.pl1 =============================== */ 6 2 6 3 /* format: style3 */ 6 4 apl_push_stack_: 6 5 procedure (P_n_words) returns (ptr); 6 6 6 7 /* Function to (1) double-word align ws_info.value_stack_ptr, and 6 8* (2) make sure allocation request will fit on current value stack. 6 9* 6 10* Written 770413 by PG 6 11* Modified 780210 by PG to round allocations up to an even number of words. 6 12**/ 6 13 6 14 /* parameters */ 6 15 6 16 declare P_n_words fixed bin (19) parameter; 6 17 6 18 /* automatic */ 6 19 6 20 declare block_ptr ptr, 6 21 num_words fixed bin (19); 6 22 6 23 /* builtins */ 6 24 6 25 declare (addrel, binary, rel, substr, unspec) 6 26 builtin; 6 27 6 28 /* entries */ 6 29 6 30 declare apl_get_value_stack_ 6 31 entry (fixed bin (19)); 6 32 6 33 /* program */ 6 34 6 35 num_words = P_n_words; 6 36 6 37 if substr (unspec (num_words), 36, 1) = "1"b /* num_words odd */ 6 38 then num_words = num_words + 1; 6 39 6 40 if binary (rel (ws_info.value_stack_ptr), 18) + num_words > ws_info.maximum_value_stack_size 6 41 then call apl_get_value_stack_ (num_words); 6 42 6 43 block_ptr = ws_info.value_stack_ptr; 6 44 ws_info.value_stack_ptr = addrel (ws_info.value_stack_ptr, num_words); 6 45 return (block_ptr); 6 46 6 47 end apl_push_stack_; 6 48 6 49 /* ------ END INCLUDE SEGMENT apl_push_stack_fcn.incl.pl1 ------------------------------- */ 398 399 end /* apl_grade_up_ */; SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 11/29/83 1346.4 apl_grade_up_.pl1 >special_ldd>on>apl.1129>apl_grade_up_.pl1 94 1 03/27/82 0429.8 apl_number_data.incl.pl1 >ldd>include>apl_number_data.incl.pl1 95 2 03/27/82 0439.0 apl_operators_argument.incl.pl1 >ldd>include>apl_operators_argument.incl.pl1 96 3 03/27/82 0438.5 apl_bead_format.incl.pl1 >ldd>include>apl_bead_format.incl.pl1 97 4 03/27/82 0439.2 apl_value_bead.incl.pl1 >ldd>include>apl_value_bead.incl.pl1 98 5 03/27/82 0439.2 apl_ws_info.incl.pl1 >ldd>include>apl_ws_info.incl.pl1 398 6 03/27/82 0429.8 apl_push_stack_fcn.incl.pl1 >ldd>include>apl_push_stack_fcn.incl.pl1 NAMES DECLARED IN THIS COMPILATION. IDENTIFIER OFFSET LOC STORAGE CLASS DATA TYPE ATTRIBUTES AND REFERENCES (* indicates a set context) NAMES DECLARED BY DECLARE STATEMENT. P_n_words parameter fixed bin(19,0) dcl 6-16 ref 6-4 6-35 addr builtin function dcl 74 ref 144 152 152 addrel builtin function dcl 6-25 in procedure "apl_push_stack_" ref 6-44 addrel builtin function dcl 74 in procedure "apl_grade_up_" ref 146 apl_error_table_$domain 000012 external static fixed bin(35,0) dcl 27 ref 365 apl_error_table_$rank 000010 external static fixed bin(35,0) dcl 27 ref 360 apl_get_value_stack_ 000016 constant entry external dcl 6-30 ref 6-40 apl_static_$ws_info_ptr 000014 external static structure level 1 dcl 5-11 binary builtin function dcl 6-25 ref 6-40 block_ptr 000232 automatic pointer dcl 6-20 set ref 6-43* 6-45 bubble_is_ok constant fixed bin(17,0) initial dcl 60 ref 198 column_base 000120 automatic fixed bin(17,0) dcl 37 set ref 180* 180* 185 345 347* column_skip_interval 000121 automatic fixed bin(17,0) dcl 37 set ref 123* 353 data_elements 000113 automatic fixed bin(17,0) dcl 37 set ref 105* 141 150 168 176 data_pointer 4 based pointer level 2 packed unaligned dcl 4-3 set ref 106 151* data_type 0(08) based structure level 4 packed unaligned dcl 4-3 depth 000133 automatic fixed bin(17,0) dcl 37 set ref 196* 316* 316 320 321 325 326 332 335 336 337* 337 dimension 000114 automatic fixed bin(17,0) dcl 37 in procedure "apl_grade_up_" set ref 107* 112 117 122 dimension 4 parameter fixed bin(17,0) level 3 in structure "operators_argument" dcl 2-3 in procedure "apl_grade_up_" ref 107 divide builtin function dcl 74 ref 207 347 error_code 7 parameter fixed bin(35,0) level 2 dcl 2-3 set ref 360* 365* first 000136 automatic fixed bin(17,0) array level 2 in structure "stack" dcl 66 in procedure "apl_grade_up_" set ref 320* 325* 335 first 000124 automatic fixed bin(17,0) dcl 37 in procedure "apl_grade_up_" set ref 194* 198 198 206 207 219 222 222 230 231 251 254 254 262 263 318 320 322* 335* 375* 375* 376 379* float builtin function dcl 74 ref 347 float_index_origin 10 based float bin(63) level 3 dcl 5-16 ref 131 general_bead based structure level 1 dcl 3-3 header based structure level 2 dcl 4-3 high 000131 automatic fixed bin(17,0) dcl 37 set ref 208* 276* 276 276* 280 280 292 294 295 318 321 327 index_base 000110 automatic pointer dcl 30 set ref 161* 185 188 188 219 219 222 222 222 222 229 230 230 231 235 235 238 238 238 238 245 246 246 247 251 251 254 254 254 254 261 262 262 263 273 276 280 280 284 288 288 294 295 295 296 347 355 376 380 382 382 384 384 387 387 391 index_origin 000204 automatic float bin(63) dcl 70 set ref 131* 170 347 indices based fixed bin(17,0) array dcl 85 set ref 185* 188* 188 219 219 222 222 222 222 229 230* 230 231* 235 235 238 238 238 238 245 246* 246 247* 251 251 254 254 254 254 261 262* 262 263* 273 276 280 280 284 288 288 294 295* 295 296* 347 376 380 382* 382 384 384 387* 387 391* integral_value_type constant bit(18) initial unaligned dcl 3-30 ref 163 interval_between_elements 000116 automatic fixed bin(17,0) dcl 37 set ref 116* 118* 118 123 178 188 347 350 last 000126 automatic fixed bin(17,0) dcl 37 in procedure "apl_grade_up_" set ref 195* 198 198 207 208 235 238 238 246 247 318 326 327* 336* 375 last 1 000136 automatic fixed bin(17,0) array level 2 in structure "stack" dcl 66 in procedure "apl_grade_up_" set ref 321* 326* 336 last_column_on_this_plane 000123 automatic fixed bin(17,0) dcl 37 set ref 178* 180 low 000130 automatic fixed bin(17,0) dcl 37 set ref 206* 284* 284 284* 288 288 292 295 296 318 322 325 379* 380* 380 380* 382 382* 384 384 387 387 391 maximum_value_stack_size 13 based fixed bin(18,0) level 3 dcl 5-16 ref 6-40 median 000127 automatic fixed bin(17,0) dcl 37 set ref 207* 219 222 222 229 230 235 238 238 245 246 251 254 254 261 262 273 median_index 000132 automatic fixed bin(17,0) dcl 37 set ref 273* 274 280 288 376* 377 384 391 median_value 000206 automatic float bin(63) dcl 70 set ref 274* 276 280 284 288 377* 380 384 num_words 000234 automatic fixed bin(19,0) dcl 6-20 set ref 6-35* 6-37 6-37* 6-37 6-40 6-40* 6-44 number_of_dimensions 000210 automatic fixed bin(17,0) dcl 4-3 set ref 140* 141 numeric_datum based float bin(63) array dcl 4-23 set ref 170* 219 219 222 222 235 235 238 238 251 251 254 254 274 276 280 284 288 347* 377 380 384 numeric_datum_or1 based float bin(63) array dcl 25 ref 141 numeric_value 0(10) based bit(1) level 5 packed unaligned dcl 4-3 set ref 103 on_stack 1 parameter bit(1) array level 3 dcl 2-3 ref 133 operand_array 000102 automatic pointer dcl 30 set ref 106* 137 219 219 222 222 235 235 238 238 251 251 254 254 274 276 280 284 288 377 380 384 operand_vb 000100 automatic pointer dcl 30 set ref 102* 103 105 106 108 118 122 135 152 operands parameter structure array level 2 dcl 2-3 operator 4 parameter structure level 2 dcl 2-3 operators_argument parameter structure level 1 dcl 2-3 set ref 22 plane_base 000117 automatic fixed bin(17,0) dcl 37 set ref 176* 176* 178 180* 353 pointers 14 based structure level 2 dcl 5-16 rel builtin function dcl 6-25 in procedure "apl_push_stack_" ref 6-40 rel builtin function dcl 74 in procedure "apl_grade_up_" ref 146 result 6 parameter pointer level 2 packed unaligned dcl 2-3 set ref 135* 142* result_array 000106 automatic pointer dcl 30 set ref 137* 144* 146 146* 146 151 170 347 result_vb 000104 automatic pointer dcl 30 set ref 135* 142* 144 149 150 151 152 163 rho 5 based fixed bin(21,0) array level 2 dcl 4-3 set ref 118 122 144 152 152 rho_copy_overlay based fixed bin(34,0) array dcl 88 set ref 152* 152 rho_sub_dimension 000115 automatic fixed bin(17,0) dcl 37 set ref 122* 123 157 187 195 346 rho_subscript 000122 automatic fixed bin(17,0) dcl 37 set ref 117* 117* 118* 187* 187* 188 188* 346* 346* 347* rhorho 3 based fixed bin(17,0) level 2 in structure "value_bead" dcl 4-3 in procedure "apl_grade_up_" set ref 108 149* rhorho 000112 automatic fixed bin(17,0) dcl 37 in procedure "apl_grade_up_" set ref 108* 110 112 117 140 144 149 152 152 size builtin function dcl 74 ref 141 141 stack 000136 automatic structure array level 1 dcl 66 static_ws_info_ptr 000014 external static pointer level 2 packed unaligned dcl 5-11 ref 5-7 string builtin function dcl 74 set ref 163* substr builtin function dcl 74 in procedure "apl_grade_up_" ref 146 substr builtin function dcl 6-25 in procedure "apl_push_stack_" ref 6-37 swap_em 000134 automatic bit(1) dcl 57 set ref 217* 219* 222* 227 232* 235* 238* 243 249* 251* 254* 259 swap_temp 000125 automatic fixed bin(17,0) dcl 37 set ref 229* 231 245* 247 261* 263 294* 296 345* 347 350* 350 total_data_elements 2 based fixed bin(21,0) level 2 dcl 4-3 set ref 105 150* total_words_needed 000135 automatic fixed bin(19,0) dcl 63 set ref 141* 142* 157* 161* type based structure level 3 packed unaligned dcl 4-3 set ref 163* unspec builtin function dcl 6-25 ref 6-37 value parameter pointer array level 3 packed unaligned dcl 2-3 ref 102 value_bead based structure level 1 dcl 4-3 set ref 141 value_stack_ptr 16 based pointer level 3 packed unaligned dcl 5-16 set ref 355* 6-40 6-43 6-44* 6-44 values 2 based structure level 2 dcl 5-16 where_error 10 parameter fixed bin(17,0) level 2 dcl 2-3 set ref 362* 362 367* 367 ws_info based structure level 1 dcl 5-16 ws_info_ptr 000212 automatic pointer initial dcl 5-7 set ref 131 355 5-7* 6-40 6-40 6-43 6-44 6-44 NAMES DECLARED BY DECLARE STATEMENT AND NEVER REFERENCED. Binary internal static bit(1) initial dcl 1-16 MAX_VALUE_BEAD_SIZE internal static fixed bin(19,0) initial dcl 4-28 NumberSize internal static fixed bin(4,0) initial dcl 1-25 TheBiggestNumberWeveGot internal static float bin(63) initial dcl 1-16 TheSmallestNumberWeveGot internal static float bin(63) initial dcl 1-16 apl_get_next_value_stack_seg_ 000000 constant entry external dcl 90 character_data_structure based structure level 1 dcl 4-15 character_string_overlay based char dcl 4-19 character_value_type internal static bit(18) initial unaligned dcl 3-30 complex_datum based complex float bin(63) array dcl 4-26 complex_value_type internal static bit(18) initial unaligned dcl 3-30 data_pointer automatic pointer dcl 30 fixed builtin function dcl 74 float_index automatic float bin(63) dcl 70 function_type internal static bit(18) initial unaligned dcl 3-30 group_type internal static bit(18) initial unaligned dcl 3-30 hbound builtin function dcl 74 label_type internal static bit(18) initial unaligned dcl 3-30 lexed_function_type internal static bit(18) initial unaligned dcl 3-30 list_value_type internal static bit(18) initial unaligned dcl 3-30 max_parse_stack_depth internal static fixed bin(17,0) initial dcl 5-98 not_integer_mask internal static bit(18) initial unaligned dcl 3-30 not_zero_or_one_mask internal static bit(18) initial unaligned dcl 3-30 numeric_value_type internal static bit(18) initial unaligned dcl 3-30 operator_type internal static bit(18) initial unaligned dcl 3-30 output_buffer based char unaligned dcl 5-94 shared_variable_type internal static bit(18) initial unaligned dcl 3-30 symbol_type internal static bit(18) initial unaligned dcl 3-30 value_type internal static bit(18) initial unaligned dcl 3-30 zero_or_one_value_type internal static bit(18) initial unaligned dcl 3-30 NAMES DECLARED BY EXPLICIT CONTEXT. apl_grade_up_ 000032 constant entry external dcl 22 apl_push_stack_ 000674 constant entry internal dcl 6-4 ref 142 161 bubble_repeat 000640 constant label dcl 380 ref 388 bubble_sort 000622 constant entry internal dcl 372 ref 202 domain_error 000615 constant label dcl 365 ref 103 grade_repeat 000432 constant label dcl 276 ref 280 297 grade_repeat_up 000452 constant label dcl 284 ref 288 pop_stack 000540 constant label dcl 332 ref 203 rank_error 000610 constant label dcl 360 ref 110 112 repeat_sort 000252 constant label dcl 198 ref 330 338 THERE WERE NO NAMES DECLARED BY CONTEXT OR IMPLICATION. STORAGE REQUIREMENTS FOR THIS PROGRAM. Object Text Link Symbol Defs Static Start 0 0 1042 1062 754 1052 Length 1356 754 20 260 66 0 BLOCK NAME STACK SIZE TYPE WHY NONQUICK/WHO SHARES STACK FRAME apl_grade_up_ 168 external procedure is an external procedure. bubble_sort internal procedure shares stack frame of external procedure apl_grade_up_. apl_push_stack_ internal procedure shares stack frame of external procedure apl_grade_up_. STORAGE FOR AUTOMATIC VARIABLES. STACK FRAME LOC IDENTIFIER BLOCK NAME apl_grade_up_ 000100 operand_vb apl_grade_up_ 000102 operand_array apl_grade_up_ 000104 result_vb apl_grade_up_ 000106 result_array apl_grade_up_ 000110 index_base apl_grade_up_ 000112 rhorho apl_grade_up_ 000113 data_elements apl_grade_up_ 000114 dimension apl_grade_up_ 000115 rho_sub_dimension apl_grade_up_ 000116 interval_between_elements apl_grade_up_ 000117 plane_base apl_grade_up_ 000120 column_base apl_grade_up_ 000121 column_skip_interval apl_grade_up_ 000122 rho_subscript apl_grade_up_ 000123 last_column_on_this_plane apl_grade_up_ 000124 first apl_grade_up_ 000125 swap_temp apl_grade_up_ 000126 last apl_grade_up_ 000127 median apl_grade_up_ 000130 low apl_grade_up_ 000131 high apl_grade_up_ 000132 median_index apl_grade_up_ 000133 depth apl_grade_up_ 000134 swap_em apl_grade_up_ 000135 total_words_needed apl_grade_up_ 000136 stack apl_grade_up_ 000204 index_origin apl_grade_up_ 000206 median_value apl_grade_up_ 000210 number_of_dimensions apl_grade_up_ 000212 ws_info_ptr apl_grade_up_ 000232 block_ptr apl_push_stack_ 000234 num_words apl_push_stack_ THE FOLLOWING EXTERNAL OPERATORS ARE USED BY THIS PROGRAM. fx1_to_fl2 call_ext_out return ext_entry THE FOLLOWING EXTERNAL ENTRIES ARE CALLED BY THIS PROGRAM. apl_get_value_stack_ THE FOLLOWING EXTERNAL VARIABLES ARE USED BY THIS PROGRAM. apl_error_table_$domain apl_error_table_$rank apl_static_$ws_info_ptr LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC 22 000027 5 7 000037 102 000041 103 000045 105 000050 106 000052 107 000054 108 000056 110 000060 112 000061 116 000063 117 000065 118 000073 120 000100 122 000102 123 000106 131 000110 133 000113 135 000120 137 000122 138 000124 140 000125 141 000127 142 000137 144 000146 146 000152 149 000160 150 000163 151 000165 152 000166 157 000175 161 000177 163 000201 168 000204 170 000207 171 000211 176 000212 178 000217 180 000221 185 000227 187 000230 188 000235 189 000242 194 000244 195 000245 196 000250 198 000252 202 000262 203 000263 206 000264 207 000266 208 000271 217 000273 219 000274 222 000314 227 000322 229 000324 230 000326 231 000330 232 000332 235 000333 238 000352 243 000360 245 000362 246 000364 247 000366 249 000370 251 000371 254 000407 259 000415 261 000417 262 000421 263 000423 273 000425 274 000427 276 000432 278 000443 280 000446 284 000452 286 000463 288 000465 292 000471 294 000474 295 000477 296 000501 297 000503 316 000504 318 000505 320 000514 321 000521 322 000523 323 000525 325 000526 326 000533 327 000535 330 000537 332 000540 335 000542 336 000546 337 000550 338 000552 345 000553 346 000555 347 000561 350 000573 351 000575 352 000577 353 000601 355 000604 356 000607 360 000610 362 000612 363 000614 365 000615 367 000617 368 000621 372 000622 375 000623 376 000631 377 000633 379 000636 380 000640 382 000651 383 000654 384 000657 387 000663 388 000665 391 000666 392 000671 394 000673 6 4 000674 6 35 000676 6 37 000700 6 40 000705 6 43 000722 6 44 000725 6 45 000734 ----------------------------------------------------------- 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