COMPILATION LISTING OF SEGMENT apl_transpose_ Compiled by: Multics PL/I Compiler, Release 28d, of October 4, 1983 Compiled at: Honeywell LCPD Phoenix, System M Compiled on: 11/29/83 1618.8 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 apl_transpose_: proc(operators_argument); 11 12 /* 13* * apl_transpose_ does the monadic and dyadic \o operators. 14* * the way it tells monadic from dyadic is by operands(1).value being null 15* * 16* * written 7/29/73 by DAM (during titanic thunderstorm) 17* * Modified 740201 by PG for compatibility check error 18* Modified 770610 by PG to fix bug 282 (dyadic transpose failed in origin 0), and bug 194 (can't transpose empty arrays). 19* * 20* * I don't even attempt to do it in place, or to have a special fast EIS case, 21* * because it's just too hard. I hope no one wants a super-fast transpose 22* */ 23 24 dcl right_vb pointer, /* -> value_bead of right operand */ 25 right pointer, /* -> value array of right operand */ 26 characters bit(1), /* "1"b if right & result are character, "0"b if numeric */ 27 rhorho_right fixed bin, /* number of dimensions of right operand */ 28 29 integer_fuzz float, /* copy of ws_info.integer_fuzz */ 30 index_origin fixed bin, /* copy of ws_info.index_origin */ 31 32 left_vb pointer, /* -> value_bead of left operand */ 33 left pointer, /* -> value array for left operand */ 34 left_is_integral bit(1), /* "1"b if left operand is known to contain only integers */ 35 36 rhorho_result fixed bin, /* number of dimensions in the result */ 37 data_elements fixed bin(21), /* number of elements in the result */ 38 result_vb pointer, /* -> value bead of result */ 39 result pointer, /* value array for result */ 40 final_result_vb pointer, /* -> value_bead of result after moved down in stack */ 41 final_result pointer, /* -> value array for result after moved down in stack */ 42 43 (left_index, right_index, result_index) fixed bin(21), /* indices into respective value arrays */ 44 rhorho_result_float float, /* temporary for computing rhorho_result */ 45 n_words fixed bin (19), /* number of words to be pushed onto value stack */ 46 permute_ptr pointer, /* address of permute table declared below */ 47 48 right_mult fixed bin(21), /* multplier for subscripts in current right dimension 49* (used in computing the permute table) */ 50 fixnum fixed bin, /* fixed-point binary version of element of left operand */ 51 float_temp float, 52 (i, j) fixed bin, /* random do-loop indices */ 53 cur_rho fixed bin; /* index into array of do-loops (see code below at bump_rho) */ 54 55 /* based */ 56 57 declare word_copy_overlay fixed bin (35) dim (n_words) based aligned; 58 59 60 /* permute table derived from left operand */ 61 62 dcl 1 permute (rhorho_result) aligned based(permute_ptr), 63 2 multiplier fixed bin(21), /* subscript-multiplier for extracting elements from operand */ 64 2 result_rho fixed bin(21); /* at first, corresponding element of rho of result is stored here, 65* later is current index into result along this dimension, i.e. control 66* variable for array of do-loops (see code near bump_rho) */ 67 68 69 dcl (apl_error_table_$domain, 70 apl_error_table_$rank, 71 apl_error_table_$compatibility_error, 72 apl_error_table_$length 73 ) fixed bin(35) external; 74 75 76 dcl (abs, addr, addrel, divide, fixed, floor, min, max, null, rel, size, string, substr, unspec) builtin; 77 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 ---------------------------------- */ 78 2 1 /* ====== BEGIN INCLUDE SEGMENT apl_ws_info.incl.pl1 ====================================== */ 2 2 2 3 /* This structure contains all of the global data (or pointers to it) for the APL subsystem */ 2 4 2 5 /* automatic */ 2 6 2 7 declare ws_info_ptr ptr initial (apl_static_$ws_info_ptr.static_ws_info_ptr); 2 8 2 9 /* external static */ 2 10 2 11 declare 1 apl_static_$ws_info_ptr external static aligned structure, 2 12 2 static_ws_info_ptr unaligned pointer; 2 13 2 14 /* based */ 2 15 2 16 declare 1 ws_info aligned based (ws_info_ptr), 2 17 2 version_number fixed bin, /* version of this structure (3) */ 2 18 2 switches unaligned, /* mainly ws parameters */ 2 19 3 long_error_mode bit, /* if 1, long Multics format, else APL/360 format */ 2 20 3 debug_mode bit, /* if 1, system error causes escape to command level */ 2 21 3 canonicalize_mode bit, /* if 1, the editor canonicalizes user input */ 2 22 3 restrict_exec_command bit, /* if 1, the )EXEC command may not be used */ 2 23 3 restrict_debug_command bit, /* if 1, the )DEBUG command may not be used */ 2 24 3 restrict_external_functions 2 25 bit, /* if 1, the )ZFN, )MFN, and )DFN commands may not be used */ 2 26 3 restrict_load bit, /* if 1, the )LOAD and )COPY commands may not be used */ 2 27 3 restrict_load_directory bit, /* if 1, no directory allowed in )LOAD or )COPY pathnames */ 2 28 3 restrict_save bit, /* if 1, the )SAVE command may not be used */ 2 29 3 restrict_save_directory bit, /* if 1, no directory allowed in )SAVE pathnames */ 2 30 3 off_hold bit, /* if 1, )OFF HOLD was typed, else just )OFF */ 2 31 3 transparent_to_signals bit, /* if 1, any conditions slip right past APL */ 2 32 3 meter_mode bit, /* if 1, metering may be done, else speed is all-important */ 2 33 3 restrict_msg_command bit, /* if 1, the )MSG command may not be used. */ 2 34 3 compatibility_check_mode 2 35 bit, /* if 1, check for incompatible operators */ 2 36 3 no_quit_handler bit, /* if 1, do not trap QUITs. */ 2 37 /* remaining 20 bits not presently used */ 2 38 2 39 2 values, /* attributes of the workspace */ 2 40 3 digits fixed bin, /* number of digits of precision printed on output */ 2 41 3 width fixed bin, /* line length for formatted output */ 2 42 3 index_origin fixed bin, /* the index origin (0 or 1) */ 2 43 3 random_link fixed bin(35), /* seed for random number generator */ 2 44 3 fuzz float, /* comparison tolerance (relative fuzz) */ 2 45 3 float_index_origin float, /* the index origin in floating point */ 2 46 3 number_of_symbols fixed bin, /* the number of symbol_beads currently in existence */ 2 47 3 maximum_value_stack_size 2 48 fixed bin (18), /* maximum number of words in one segment of value stack */ 2 49 2 50 2 pointers, /* pointers to various internal tables */ 2 51 3 symbol_table_ptr unaligned pointer, /* -> symbol_table (apl_symbol_table.incl.pl1) */ 2 52 3 current_parse_frame_ptr unaligned pointer, /* -> topmost parse frame */ 2 53 3 value_stack_ptr unaligned pointer, /* -> next free location on value stack */ 2 54 3 alloc_free_info_ptr unaligned pointer, /* -> apl_storage_mngr_ data (apl_storage_system_data.incl.pl1) */ 2 55 2 56 2 time_invoked fixed bin(71), /* clock time that APL was entered */ 2 57 2 integer_fuzz float, /* the absolute fuzz used in checking for integers */ 2 58 2 user_number fixed bin(35), /* number under which the user is signed on */ 2 59 2 latent_expression unaligned pointer, /* -> value_bead for QuadLX */ 2 60 2 lock char(32), /* the lock currently set on this workspace (password) */ 2 61 2 wsid char(100), /* the workspace identification: name, number name, or clear ws */ 2 62 2 last_error_code fixed bin(35), /* last code passed to apl_error_ */ 2 63 2 signoff_lock character (32), 2 64 2 65 2 interrupt_info aligned, /* bits used by apl_interpreter_ to tell when to abort */ 2 66 3 dont_interrupt_parse bit, /* if 1, don't do a dirty stop because the parser is running */ 2 67 3 dont_interrupt_operator bit, /* if 1, don't do a dirty stop because an operator is running */ 2 68 3 dont_interrupt_storage_manager /* if 1, don't stop because apl_storage_mngr_ is */ 2 69 bit, /* munging his tables */ 2 70 3 unused_interrupt_bit bit, /* not presently used */ 2 71 3 dont_interrupt_command bit, 2 72 3 can_be_interrupted bit, /* if 1, OK to do a clean stop (we are between lines, reading) */ 2 73 3 clean_interrupt_pending bit, /* interrupt occured, break cleanly (between lines) */ 2 74 3 dirty_interrupt_pending bit, /* interrupt occured, break as soon as not inhibited */ 2 75 2 76 2 user_name char (32), /* process group id of user */ 2 77 2 immediate_input_prompt char (32) varying, /* normal input */ 2 78 2 evaluated_input_prompt char (32) varying, /* quad input */ 2 79 2 character_input_prompt char (32) varying, /* quad-quote input */ 2 80 2 vcpu_time aligned, 2 81 3 total fixed bin (71), 2 82 3 setup fixed bin (71), 2 83 3 parse fixed bin (71), 2 84 3 lex fixed bin (71), 2 85 3 operator fixed bin (71), 2 86 3 storage_manager fixed bin (71), 2 87 2 output_info aligned, /* data pertaining to output buffer */ 2 88 3 output_buffer_ptr unal ptr, /* ptr to output buffer */ 2 89 3 output_buffer_len fixed bin (21), /* length (bytes) of output buffer */ 2 90 3 output_buffer_pos fixed bin (21), /* index of next byte to write in */ 2 91 3 output_buffer_ll fixed bin (21), /* print positions used up so far */ 2 92 2 tab_width fixed bin (21); /* number of columns a tabs moves cursor */ 2 93 2 94 declare output_buffer char (ws_info.output_buffer_len) based (ws_info.output_buffer_ptr); 2 95 2 96 /* internal static */ 2 97 2 98 declare max_parse_stack_depth fixed bin int static init(64536); 2 99 2 100 /* ------ END INCLUDE SEGMENT apl_ws_info.incl.pl1 -------------------------------------- */ 79 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 ---------------------------------- */ 80 4 1 /* ====== BEGIN INCLUDE SEGMENT apl_operator_bead.incl.pl1 ================================ */ 4 2 4 3 declare 4 4 1 operator_bead aligned based, 4 5 4 6 2 type unaligned like general_bead.type, 4 7 4 8 2 bits_for_lex unaligned, 4 9 3 allow_brackets bit(1), /* operator may have dimension info in brackets */ 4 10 3 allow_product bit(1), /* operator may be used in inner and outer product */ 4 11 3 allow_reduction bit(1), /* operator may be used in reduction and scan */ 4 12 3 special_assignment bit(1), /* doesn't use standard assignment operator */ 4 13 3 ignores_assignment bit(1), /* assignment has no effect */ 4 14 3 allow_subscripted_assignment 4 15 bit(1), /* system variable that can be subscripted assigned */ 4 16 3 pad bit(12), 4 17 4 18 2 bits_for_parse unaligned, 4 19 3 stop_trace_control bit(1), /* next lexeme is function being stopped/traced 4 20* (op1 tells which) */ 4 21 3 quad bit(1), /* this is a quad type */ 4 22 3 system_variable bit(1), /* this is a system variable, not an op */ 4 23 3 dyadic bit(1), /* operator may be dyadic */ 4 24 3 monadic bit(1), /* operator may be monadic */ 4 25 3 function bit(1), /* operator is a user defined function */ 4 26 3 semantics_valid bit(1), /* if semantics has been set */ 4 27 3 has_list bit(1), /* semantics is a list */ 4 28 3 inner_product bit(1), /* op2 is valid */ 4 29 3 semantics_on_stack bit(1), /* semantics points to value stack */ 4 30 3 is_external_function bit(1), /* semantics points to function bead for ext function */ 4 31 3 pad bit(7), 4 32 3 op2 fixed bin(8) unaligned, /* secondary operator code */ 4 33 3 op1 fixed bin(8) unaligned, /* primary operator code */ 4 34 2 type_code fixed bin; /* for parse */ 4 35 4 36 /* ------ END INCLUDE SEGMENT apl_operator_bead.incl.pl1 -------------------------------- */ 81 5 1 /* ====== BEGIN INCLUDE SEGMENT apl_value_bead.incl.pl1 =================================== */ 5 2 5 3 declare 5 4 number_of_dimensions fixed bin, 5 5 5 6 1 value_bead aligned based, 5 7 2 header aligned like general_bead, 5 8 2 total_data_elements fixed binary (21), /* length of ,[value] in APL */ 5 9 2 rhorho fixed binary, /* number of dimensions of value */ 5 10 2 data_pointer pointer unaligned, /* packed pointer to the data in value */ 5 11 2 rho fixed binary (21) dimension (number_of_dimensions refer (value_bead.rhorho)); 5 12 /* dimensions of value (zero-origin) */ 5 13 5 14 5 15 declare 1 character_data_structure aligned based, /* alignment trick for PL/I compiler */ 5 16 2 character_datum character (1) unaligned dimension (0:data_elements - 1); 5 17 /* actual elements of character array */ 5 18 5 19 declare character_string_overlay character (data_elements) aligned based; 5 20 /* to overlay on above structure */ 5 21 5 22 5 23 declare numeric_datum float aligned dimension (0:data_elements - 1) based; 5 24 /* actual elements of numeric array */ 5 25 5 26 declare complex_datum complex float aligned dimension (0:data_elements -1) based; 5 27 5 28 declare MAX_VALUE_BEAD_SIZE fixed bin (19) init (261120) int static options (constant); 5 29 5 30 /* ------ END INCLUDE SEGMENT apl_value_bead.incl.pl1 ----------------------------------- */ 82 6 1 /* ====== BEGIN INCLUDE SEGEMENT apl_operators_argument.incl.pl1 =========================== */ 6 2 6 3 declare 1 operators_argument aligned, 6 4 2 operands (2) aligned, /* these are the operands to the operator to be executed. 6 5* if operand (1).value is null, operator is monadic */ 6 6 3 value pointer unaligned, /* a pointer to the value bead for this operand */ 6 7 3 on_stack bit (1) aligned, /* ON if this value resides on the value stack */ 6 8 2 operator aligned, /* information about the operator to be executed */ 6 9 3 dimension fixed bin, /* (optional) dimension along which to operate */ 6 10 3 padding bit (18) unaligned, /* unused part of operator bead */ 6 11 3 op2 fixed bin (8) unal, /* a modifier for op1, or a 2nd operator if inner product */ 6 12 3 op1 fixed bin (8) unal, /* code for the actual operator to be executed */ 6 13 2 result pointer unal, /* (output) set by operator to point to result bead in stack */ 6 14 2 error_code fixed bin (35), /* (output) set before signaling apl_operator_error_ */ 6 15 2 where_error fixed bin; /* parseme index of where error was - parse sets to operator */ 6 16 6 17 /* ------ END INCLUDE SEGMENT apl_operators_argument.incl.pl1 --------------------------- */ 83 84 85 /* do the usual picking up of addresses and attributes of arguments and error checking */ 86 87 right_vb = operands(2).value; 88 characters = right_vb -> value_bead.data_type.character_value; 89 right = right_vb -> value_bead.data_pointer; 90 rhorho_right = right_vb -> value_bead.rhorho; 91 92 integer_fuzz = ws_info.integer_fuzz; 93 index_origin = ws_info.index_origin; /* copy for spurious efficiency */ 94 95 left_vb = operands(1).value; 96 if left_vb = null then go to monadic_transpose; /* fake up the left operand if monadic */ 97 if ^ left_vb -> value_bead.data_type.numeric_value then go to domain_error_left; 98 else left_is_integral = left_vb -> value_bead.data_type.integral_value; 99 left = left_vb -> value_bead.data_pointer; 100 if left_vb -> value_bead.rhorho >= 2 then go to rank_error_left; 101 if left_vb -> value_bead.total_data_elements ^= rhorho_right then go to length_error_left; 102 103 104 /* first allocate a space in the stack for the permute table, which gives the permutation 105* from operand to result in the convenient form of a set of subscript multipliers. 106* The permute table also holds the rho vector of the result until we get a chance 107* to allocate a result value bead in which to put it */ 108 109 rhorho_result_float = 0.0e0; /* rhorho_result = max reduction of left operand */ 110 do left_index = 0 by 1 while (left_index < rhorho_right); 111 rhorho_result_float = max(rhorho_result_float, left -> numeric_datum(left_index)); 112 end; 113 rhorho_result = fixed (rhorho_result_float) + (1 - index_origin); 114 115 n_words = size(permute); 116 permute_ptr = apl_push_stack_ (n_words); 117 118 permute.multiplier (*) = -1; 119 permute.result_rho(*) = 1048577; /* identity for min of rho-vector entries contributing */ 120 121 /* process left operand into permute table */ 122 123 right_mult = 1; 124 do left_index = rhorho_right-1 by -1 while(left_index >= 0); /* process left operand backwards */ 125 if left_is_integral then fixnum = fixed(left -> numeric_datum(left_index)); 126 else do; 127 float_temp = floor(left -> numeric_datum(left_index) + 0.5); 128 if abs(float_temp - left -> numeric_datum(left_index)) > integer_fuzz 129 then go to domain_error_left; 130 131 if abs(float_temp) >= 1e21b then go to domain_error_left; 132 fixnum = fixed(float_temp, 21); 133 end; 134 fixnum = fixnum + (1 - index_origin); 135 if fixnum <= 0 then go to domain_error_left; 136 /* needn't check upper bound since rhorho_result was derived from max of these */ 137 138 /* compute fixnum'th permute.multiplier from left_index'th multiplier of operand */ 139 140 if permute.multiplier (fixnum) = -1 /* not yet set */ 141 then permute.multiplier (fixnum) = right_mult; 142 else permute.multiplier (fixnum) = permute.multiplier (fixnum) + right_mult; 143 144 permute.result_rho (fixnum) = min (permute.result_rho (fixnum), 145 right_vb -> value_bead.rho (left_index + 1)); /* compute length of diagonal */ 146 right_mult = right_mult * right_vb -> value_bead.rho (left_index + 1); /* compute multiplier for next 147* dimension (to left) of opnd */ 148 end; 149 150 /* check for gap errors */ 151 152 do i = 0 by 1 while (i < rhorho_result); 153 if permute.multiplier (i + 1) = -1 154 then go to domain_error_left; 155 end; 156 157 /* compute size of result and allocate it */ 158 159 monadic_dyadic_join: 160 data_elements = 1; 161 do i = 0 by 1 while (i < rhorho_result); 162 data_elements = data_elements * permute.result_rho(i+1); 163 end; 164 165 if characters then n_words = size(character_string_overlay); 166 else n_words = size(numeric_datum)+1; 167 number_of_dimensions = rhorho_result; 168 n_words = n_words + size (value_bead); 169 result_vb = apl_push_stack_ (n_words); 170 /* no need to update value_stack_ptr, will be set before returning and not referenced before then */ 171 172 result = addr(result_vb -> value_bead.rho(rhorho_result+1)); 173 if ^characters then if substr(rel(result), 18, 1) then result = addrel(result, 1); 174 175 /* fill result value_bead header */ 176 177 result_vb -> value_bead.data_pointer = result; 178 string(result_vb -> value_bead.type) = string(right_vb -> value_bead.type); 179 result_vb -> value_bead.total_data_elements = data_elements; 180 result_vb -> value_bead.rhorho = rhorho_result; 181 do i = 0 by 1 while (i < rhorho_result); 182 result_vb -> value_bead.rho(i+1) = permute.result_rho(i+1); 183 end; 184 185 if data_elements = 0 /* transposing empty array */ 186 then go to finish; 187 188 /* now generate the result according to the permute table */ 189 190 permute.result_rho(*) = 0; /* use these as an array of do-loops, a control structure 191* not permitted in standard PL/I for implementation reasons */ 192 do result_index = 0 by 1; /* index in result steps linrrly through */ 193 /* the loop is terminated by the go to finish below */ 194 right_index = 0; /* compute index in operand */ 195 do i = 0 by 1 while (i < rhorho_result); 196 right_index = right_index + permute.result_rho(i+1)*permute.multiplier(i+1); 197 end; 198 if characters 199 then result -> character_datum(result_index) = right -> character_datum(right_index); 200 else result -> numeric_datum(result_index) = right -> numeric_datum(right_index); 201 202 /* now bump the array of do loops */ 203 204 cur_rho = rhorho_result; 205 bump_rho: cur_rho = cur_rho-1; /* zero-origin index into permute.result_rho */ 206 if cur_rho < 0 then go to finish; 207 permute.result_rho(cur_rho+1) = permute.result_rho(cur_rho+1) + 1; 208 if permute.result_rho(cur_rho+1) >= result_vb -> value_bead.rho(cur_rho+1) then do; /* carry into 209* enclosing 210* do-loop */ 211 permute.result_rho(cur_rho+1) = 0; 212 go to bump_rho; 213 end; 214 end; /* end do result_index = ... */ 215 finish: 216 217 /* move result down and set value_stack_ptr to point past it */ 218 219 if operands(2).on_stack then value_stack_ptr = right_vb; /* find lowest place on stack, = where to move to */ 220 else if operands(1).on_stack then value_stack_ptr = left_vb; 221 else value_stack_ptr = permute_ptr; 222 223 /* n_words is still set from before */ 224 final_result_vb = apl_push_stack_ (n_words); 225 number_of_dimensions = rhorho_result; 226 n_words = size (value_bead); /* number of words to copy */ 227 final_result_vb -> word_copy_overlay = result_vb -> word_copy_overlay; 228 final_result = addr(final_result_vb -> value_bead.rho(rhorho_result+1)); 229 if ^characters then if substr(rel(final_result), 18, 1) then final_result = addrel(final_result, 1); 230 final_result_vb -> value_bead.data_pointer = final_result; 231 if characters then final_result -> character_string_overlay = result -> character_string_overlay; 232 else final_result -> numeric_datum(*) = result -> numeric_datum(*); 233 234 operators_argument.result = final_result_vb; 235 return; 236 237 /* monadic case comes here to fake up left argument */ 238 239 monadic_transpose: 240 if ws_info.compatibility_check_mode 241 then if rhorho_right > 2 242 then go to compatibility_error; /* \oA used to mean interchange last 2 dims, now 243* means reverse all dims */ 244 rhorho_result = rhorho_right; 245 n_words = size(permute); 246 permute_ptr = apl_push_stack_ (n_words); 247 248 right_mult = 1; 249 do left_index = 0 by 1 while(left_index < rhorho_result); 250 right_index = rhorho_right - left_index; /* right dimension is complement of left dim */ 251 permute.multiplier(left_index+1) = right_mult; 252 permute.result_rho(left_index+1) = right_vb -> value_bead.rho(right_index); 253 right_mult = right_mult * right_vb -> value_bead.rho(right_index); 254 end; 255 256 operands (1).on_stack = "0"b; /* no left opnd... */ 257 go to monadic_dyadic_join; 258 259 /* error labels */ 260 261 domain_error_left: 262 operators_argument.error_code = apl_error_table_$domain; 263 go to mark_left_operand; 264 265 rank_error_left: 266 operators_argument.error_code = apl_error_table_$rank; 267 go to mark_left_operand; 268 269 length_error_left: 270 operators_argument.error_code = apl_error_table_$length; 271 return; 272 273 compatibility_error: 274 operators_argument.error_code = apl_error_table_$compatibility_error; 275 go to mark_left_operand; 276 277 mark_left_operand: 278 operators_argument.where_error = operators_argument.where_error + 1; 279 return; 280 7 1 /* ====== BEGIN INCLUDE SEGMENT apl_push_stack_fcn.incl.pl1 =============================== */ 7 2 7 3 /* format: style3 */ 7 4 apl_push_stack_: 7 5 procedure (P_n_words) returns (ptr); 7 6 7 7 /* Function to (1) double-word align ws_info.value_stack_ptr, and 7 8* (2) make sure allocation request will fit on current value stack. 7 9* 7 10* Written 770413 by PG 7 11* Modified 780210 by PG to round allocations up to an even number of words. 7 12**/ 7 13 7 14 /* parameters */ 7 15 7 16 declare P_n_words fixed bin (19) parameter; 7 17 7 18 /* automatic */ 7 19 7 20 declare block_ptr ptr, 7 21 num_words fixed bin (19); 7 22 7 23 /* builtins */ 7 24 7 25 declare (addrel, binary, rel, substr, unspec) 7 26 builtin; 7 27 7 28 /* entries */ 7 29 7 30 declare apl_get_value_stack_ 7 31 entry (fixed bin (19)); 7 32 7 33 /* program */ 7 34 7 35 num_words = P_n_words; 7 36 7 37 if substr (unspec (num_words), 36, 1) = "1"b /* num_words odd */ 7 38 then num_words = num_words + 1; 7 39 7 40 if binary (rel (ws_info.value_stack_ptr), 18) + num_words > ws_info.maximum_value_stack_size 7 41 then call apl_get_value_stack_ (num_words); 7 42 7 43 block_ptr = ws_info.value_stack_ptr; 7 44 ws_info.value_stack_ptr = addrel (ws_info.value_stack_ptr, num_words); 7 45 return (block_ptr); 7 46 7 47 end apl_push_stack_; 7 48 7 49 /* ------ END INCLUDE SEGMENT apl_push_stack_fcn.incl.pl1 ------------------------------- */ 281 282 end /* apl_transpose_ */; SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 11/29/83 1347.3 apl_transpose_.pl1 >special_ldd>on>apl.1129>apl_transpose_.pl1 78 1 03/27/82 0429.8 apl_number_data.incl.pl1 >ldd>include>apl_number_data.incl.pl1 79 2 03/27/82 0439.2 apl_ws_info.incl.pl1 >ldd>include>apl_ws_info.incl.pl1 80 3 03/27/82 0438.5 apl_bead_format.incl.pl1 >ldd>include>apl_bead_format.incl.pl1 81 4 03/27/82 0439.0 apl_operator_bead.incl.pl1 >ldd>include>apl_operator_bead.incl.pl1 82 5 03/27/82 0439.2 apl_value_bead.incl.pl1 >ldd>include>apl_value_bead.incl.pl1 83 6 03/27/82 0439.0 apl_operators_argument.incl.pl1 >ldd>include>apl_operators_argument.incl.pl1 281 7 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 7-16 ref 7-4 7-35 abs builtin function dcl 76 ref 128 131 addr builtin function dcl 76 ref 172 228 addrel builtin function dcl 7-25 in procedure "apl_push_stack_" ref 7-44 addrel builtin function dcl 76 in procedure "apl_transpose_" ref 173 229 apl_error_table_$compatibility_error 000014 external static fixed bin(35,0) dcl 69 ref 273 apl_error_table_$domain 000010 external static fixed bin(35,0) dcl 69 ref 261 apl_error_table_$length 000016 external static fixed bin(35,0) dcl 69 ref 269 apl_error_table_$rank 000012 external static fixed bin(35,0) dcl 69 ref 265 apl_get_value_stack_ 000022 constant entry external dcl 7-30 ref 7-40 apl_static_$ws_info_ptr 000020 external static structure level 1 dcl 2-11 binary builtin function dcl 7-25 ref 7-40 block_ptr 000164 automatic pointer dcl 7-20 set ref 7-43* 7-45 character_data_structure based structure level 1 dcl 5-15 character_datum based char(1) array level 2 packed unaligned dcl 5-15 set ref 198* 198 character_string_overlay based char dcl 5-19 set ref 165 231* 231 character_value 0(09) based bit(1) level 5 packed unaligned dcl 5-3 set ref 88 characters 000104 automatic bit(1) unaligned dcl 24 set ref 88* 165 173 198 229 231 compatibility_check_mode 1(14) based bit(1) level 3 packed unaligned dcl 2-16 ref 239 cur_rho 000151 automatic fixed bin(17,0) dcl 24 set ref 204* 205* 205 206 207 207 208 208 211 data_elements 000120 automatic fixed bin(21,0) dcl 24 set ref 159* 162* 162 165 165 166 179 185 231 231 232 data_pointer 4 based pointer level 2 packed unaligned dcl 5-3 set ref 89 99 177* 230* data_type 0(08) based structure level 4 packed unaligned dcl 5-3 error_code 7 parameter fixed bin(35,0) level 2 dcl 6-3 set ref 261* 265* 269* 273* final_result 000130 automatic pointer dcl 24 set ref 228* 229 229* 229 230 231 232 final_result_vb 000126 automatic pointer dcl 24 set ref 224* 227 228 230 234 fixed builtin function dcl 76 ref 113 125 132 fixnum 000145 automatic fixed bin(17,0) dcl 24 set ref 125* 132* 134* 134 135 140 140 142 142 144 144 float_temp 000146 automatic float bin(63) dcl 24 set ref 127* 128 131 132 floor builtin function dcl 76 ref 127 general_bead based structure level 1 dcl 3-3 header based structure level 2 dcl 5-3 i 000150 automatic fixed bin(17,0) dcl 24 set ref 152* 152* 153* 161* 161* 162* 181* 181* 182 182* 195* 195* 196 196* index_origin 000110 automatic fixed bin(17,0) dcl 24 in procedure "apl_transpose_" set ref 93* 113 134 index_origin 4 based fixed bin(17,0) level 3 in structure "ws_info" dcl 2-16 in procedure "apl_transpose_" ref 93 integer_fuzz 000106 automatic float bin(63) dcl 24 in procedure "apl_transpose_" set ref 92* 128 integer_fuzz 22 based float bin(63) level 2 in structure "ws_info" dcl 2-16 in procedure "apl_transpose_" ref 92 integral_value 0(11) based bit(1) level 5 packed unaligned dcl 5-3 set ref 98 left 000114 automatic pointer dcl 24 set ref 99* 111 125 127 128 left_index 000132 automatic fixed bin(21,0) dcl 24 set ref 110* 110* 111* 124* 124* 125 127 128 144 146* 249* 249* 250 251 252* left_is_integral 000116 automatic bit(1) unaligned dcl 24 set ref 98* 125 left_vb 000112 automatic pointer dcl 24 set ref 95* 96 97 98 99 100 101 220 max builtin function dcl 76 ref 111 maximum_value_stack_size 13 based fixed bin(18,0) level 3 dcl 2-16 ref 7-40 min builtin function dcl 76 ref 144 multiplier based fixed bin(21,0) array level 2 dcl 62 set ref 118* 140 140* 142* 142 153 196 251* n_words 000140 automatic fixed bin(19,0) dcl 24 set ref 115* 116* 165* 166* 168* 168 169* 224* 226* 227 245* 246* null builtin function dcl 76 ref 96 num_words 000166 automatic fixed bin(19,0) dcl 7-20 set ref 7-35* 7-37 7-37* 7-37 7-40 7-40* 7-44 number_of_dimensions 000154 automatic fixed bin(17,0) dcl 5-3 set ref 167* 168 225* 226 numeric_datum based float bin(63) array dcl 5-23 set ref 111 125 127 128 166 200* 200 232* 232 numeric_value 0(10) based bit(1) level 5 packed unaligned dcl 5-3 set ref 97 on_stack 1 parameter bit(1) array level 3 dcl 6-3 set ref 215 220 256* operands parameter structure array level 2 dcl 6-3 operators_argument parameter structure level 1 dcl 6-3 set ref 10 permute based structure array level 1 dcl 62 set ref 115 245 permute_ptr 000142 automatic pointer dcl 24 set ref 115 116* 118 119 140 140 142 142 144 144 153 162 182 190 196 196 207 207 208 211 221 245 246* 251 252 pointers 14 based structure level 2 dcl 2-16 rel builtin function dcl 76 in procedure "apl_transpose_" ref 173 229 rel builtin function dcl 7-25 in procedure "apl_push_stack_" ref 7-40 result 6 parameter pointer level 2 in structure "operators_argument" packed unaligned dcl 6-3 in procedure "apl_transpose_" set ref 234* result 000124 automatic pointer dcl 24 in procedure "apl_transpose_" set ref 172* 173 173* 173 177 198 200 231 232 result_index 000134 automatic fixed bin(21,0) dcl 24 set ref 192* 198 200* result_rho 1 based fixed bin(21,0) array level 2 dcl 62 set ref 119* 144* 144 162 182 190* 196 207* 207 208 211* 252* result_vb 000122 automatic pointer dcl 24 set ref 169* 172 177 178 179 180 182 208 227 rho 5 based fixed bin(21,0) array level 2 dcl 5-3 set ref 144 146 172 182* 208 228 252 253 rhorho 3 based fixed bin(17,0) level 2 dcl 5-3 set ref 90 100 180* rhorho_result 000117 automatic fixed bin(17,0) dcl 24 set ref 113* 115 118 119 152 161 167 172 180 181 190 195 204 225 228 244* 245 249 rhorho_result_float 000136 automatic float bin(63) dcl 24 set ref 109* 111* 111 113 rhorho_right 000105 automatic fixed bin(17,0) dcl 24 set ref 90* 101 110 124 239 244 250 right 000102 automatic pointer dcl 24 set ref 89* 198 200 right_index 000133 automatic fixed bin(21,0) dcl 24 set ref 194* 196* 196 198 200 250* 252 253 right_mult 000144 automatic fixed bin(21,0) dcl 24 set ref 123* 140 142 146* 146 248* 251 253* 253 right_vb 000100 automatic pointer dcl 24 set ref 87* 88 89 90 144 146 178 215 252 253 size builtin function dcl 76 ref 115 165 166 168 226 245 static_ws_info_ptr 000020 external static pointer level 2 packed unaligned dcl 2-11 ref 2-7 string builtin function dcl 76 set ref 178* 178 substr builtin function dcl 7-25 in procedure "apl_push_stack_" ref 7-37 substr builtin function dcl 76 in procedure "apl_transpose_" ref 173 229 switches 1 based structure level 2 packed unaligned dcl 2-16 total_data_elements 2 based fixed bin(21,0) level 2 dcl 5-3 set ref 101 179* type based structure level 2 in structure "general_bead" packed unaligned dcl 3-3 in procedure "apl_transpose_" type based structure level 3 in structure "value_bead" packed unaligned dcl 5-3 in procedure "apl_transpose_" set ref 178* 178 unspec builtin function dcl 7-25 ref 7-37 value parameter pointer array level 3 packed unaligned dcl 6-3 ref 87 95 value_bead based structure level 1 dcl 5-3 set ref 168 226 value_stack_ptr 16 based pointer level 3 packed unaligned dcl 2-16 set ref 215* 220* 221* 7-40 7-43 7-44* 7-44 values 2 based structure level 2 dcl 2-16 where_error 10 parameter fixed bin(17,0) level 2 dcl 6-3 set ref 277* 277 word_copy_overlay based fixed bin(35,0) array dcl 57 set ref 227* 227 ws_info based structure level 1 dcl 2-16 ws_info_ptr 000152 automatic pointer initial dcl 2-7 set ref 92 93 215 220 221 239 2-7* 7-40 7-40 7-43 7-44 7-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 5-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 character_value_type internal static bit(18) initial unaligned dcl 3-30 complex_datum based complex float bin(63) array dcl 5-26 complex_value_type internal static bit(18) initial unaligned dcl 3-30 divide builtin function dcl 76 function_type internal static bit(18) initial unaligned dcl 3-30 group_type internal static bit(18) initial unaligned dcl 3-30 integral_value_type internal static bit(18) initial unaligned dcl 3-30 j automatic fixed bin(17,0) dcl 24 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 2-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_bead based structure level 1 dcl 4-3 operator_type internal static bit(18) initial unaligned dcl 3-30 output_buffer based char unaligned dcl 2-94 shared_variable_type internal static bit(18) initial unaligned dcl 3-30 symbol_type internal static bit(18) initial unaligned dcl 3-30 unspec builtin function dcl 76 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_push_stack_ 000713 constant entry internal dcl 7-4 ref 116 169 224 246 apl_transpose_ 000040 constant entry external dcl 10 bump_rho 000475 constant label dcl 205 ref 212 compatibility_error 000703 constant label dcl 273 set ref 239 domain_error_left 000665 constant label dcl 261 ref 97 128 131 135 153 finish 000517 constant label dcl 215 ref 185 206 length_error_left 000677 constant label dcl 269 ref 101 mark_left_operand 000707 constant label dcl 277 set ref 263 267 275 monadic_dyadic_join 000315 constant label dcl 159 ref 257 monadic_transpose 000614 constant label dcl 239 ref 96 rank_error_left 000673 constant label dcl 265 ref 100 THERE WERE NO NAMES DECLARED BY CONTEXT OR IMPLICATION. STORAGE REQUIREMENTS FOR THIS PROGRAM. Object Text Link Symbol Defs Static Start 0 0 1104 1130 1001 1114 Length 1444 1001 24 300 103 0 BLOCK NAME STACK SIZE TYPE WHY NONQUICK/WHO SHARES STACK FRAME apl_transpose_ 128 external procedure is an external procedure. apl_push_stack_ internal procedure shares stack frame of external procedure apl_transpose_. STORAGE FOR AUTOMATIC VARIABLES. STACK FRAME LOC IDENTIFIER BLOCK NAME apl_transpose_ 000100 right_vb apl_transpose_ 000102 right apl_transpose_ 000104 characters apl_transpose_ 000105 rhorho_right apl_transpose_ 000106 integer_fuzz apl_transpose_ 000110 index_origin apl_transpose_ 000112 left_vb apl_transpose_ 000114 left apl_transpose_ 000116 left_is_integral apl_transpose_ 000117 rhorho_result apl_transpose_ 000120 data_elements apl_transpose_ 000122 result_vb apl_transpose_ 000124 result apl_transpose_ 000126 final_result_vb apl_transpose_ 000130 final_result apl_transpose_ 000132 left_index apl_transpose_ 000133 right_index apl_transpose_ 000134 result_index apl_transpose_ 000136 rhorho_result_float apl_transpose_ 000140 n_words apl_transpose_ 000142 permute_ptr apl_transpose_ 000144 right_mult apl_transpose_ 000145 fixnum apl_transpose_ 000146 float_temp apl_transpose_ 000150 i apl_transpose_ 000151 cur_rho apl_transpose_ 000152 ws_info_ptr apl_transpose_ 000154 number_of_dimensions apl_transpose_ 000164 block_ptr apl_push_stack_ 000166 num_words apl_push_stack_ THE FOLLOWING EXTERNAL OPERATORS ARE USED BY THIS PROGRAM. call_ext_out return fl2_to_fx1 fl2_to_fx2 ext_entry floor_fl 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_$compatibility_error apl_error_table_$domain apl_error_table_$length apl_error_table_$rank apl_static_$ws_info_ptr LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC 10 000035 2 7 000045 87 000047 88 000053 89 000057 90 000061 92 000063 93 000066 95 000070 96 000072 97 000076 98 000101 99 000105 100 000107 101 000112 109 000115 110 000117 111 000123 112 000132 113 000134 115 000143 116 000145 118 000147 119 000164 123 000200 124 000202 125 000210 127 000217 128 000225 131 000232 132 000241 134 000244 135 000247 140 000251 142 000263 144 000266 146 000275 148 000300 152 000303 153 000307 155 000313 159 000315 161 000317 162 000323 163 000331 165 000333 166 000342 167 000346 168 000350 169 000352 172 000354 173 000360 177 000370 178 000372 179 000374 180 000376 181 000400 182 000405 183 000413 185 000415 190 000417 192 000432 194 000434 195 000435 196 000441 197 000450 198 000452 200 000464 204 000473 205 000475 206 000477 207 000501 208 000504 211 000512 212 000514 214 000515 215 000517 220 000530 221 000537 224 000542 225 000544 226 000546 227 000550 228 000556 229 000561 230 000571 231 000572 232 000602 234 000610 235 000613 239 000614 244 000622 245 000624 246 000626 248 000630 249 000632 250 000637 251 000642 252 000647 253 000654 254 000657 256 000661 257 000664 261 000665 263 000672 265 000673 267 000676 269 000677 271 000702 273 000703 275 000706 277 000707 279 000712 7 4 000713 7 35 000715 7 37 000717 7 40 000724 7 43 000741 7 44 000744 7 45 000753 ----------------------------------------------------------- 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