COMPILATION LISTING OF SEGMENT apl_comma_operators_ Compiled by: Multics PL/I Compiler, Release 28d, of October 4, 1983 Compiled at: Honeywell LCPD Phoenix, System M Compiled on: 11/29/83 1558.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 apl_comma_operators_: 11 procedure; 12 13 /* 14* * This module implements the following APL operators: 15* * ravel ,A 16* * scalar laminate 1,2 17* * catenate A,B 18* * laminate A,[1.5]B 19* * 20* * written 73.7.08 by DAM 21* * modified to take advantage of EIS, 73.7.31 by DAM 22* * modified to fix a bug causing catenate of a scalar and a null 23* * vector (either way) to fail due to setting of total_data_elements 24* * field incorrectly, and to slightly decrease size of object code 25* * by G. Gordon Benedict, June 15, 1974 26* * Modified 770307 by PG to fix bug 195 (+_1 bug in checking rank subscript for laminate). 27* Modified 790305 by William M. York to fix part of bug 278 (some programs 28* do not double-word align value beads). 29* * 30* */ 31 32 33 dcl result_vb ptr, /* -> result value_bead on stack */ 34 result ptr, /* -> data array of result value_bead */ 35 rhorho fixed bin, /* rhorho of result */ 36 kludge_rhorho fixed binary defined (rhorho), /* to get around name conflict in 37* calculate_result_bead_laminate */ 38 left ptr, /* -> data array of left operand value_bead */ 39 right ptr, /* -> data array of right operand value_bead */ 40 left_rr fixed bin, /* rhorho of left operand */ 41 right_rr fixed bin, /* rhorho of right operand */ 42 43 /* variables used to control scanning through the arguments in the inner loop */ 44 (left_pos, right_pos) fixed bin(21), /* index in datum array of left or right operand */ 45 46 (left_scalar, right_scalar) bit(1), /* "1"b if left (right) operand is a scalar */ 47 48 outersize fixed bin(21), /* total number of result elements */ 49 jointsize fixed bin(21), /* number of result elements between joints */ 50 innersize fixed bin(21), /* number of result elements in dimensions to right (in rho vector) 51* of the dimension in which the joints occur */ 52 53 joint fixed bin(21), /* number of elements in a column before you get to the joint */ 54 I fixed bin, /* dimension along which joining is to occur */ 55 J fixed bin(21), /* = result.rho[I] */ 56 characters bit(1), /* 1 => do in character mode, 0 => do in numeric mode */ 57 resulting_type bit(18), /* type field for result, needed for null-vector hacks */ 58 59 (i, j, n) fixed bin(21), /* for do loops, etc. */ 60 61 (right_vb, left_vb) ptr; /* -> value_bead of left & right args irrespectively */ 62 63 dcl left_size fixed bin(21), /* number of things taken at a time from left argument */ 64 right_size fixed bin(21), /* number of things taken at a time from right argument */ 65 result_pos fixed bin(21), /* base of column currently being generated in result */ 66 67 left_numbers(left_size) float aligned based, /* because you can't use substr on arrays in PL/I */ 68 right_numbers(right_size) float based aligned; 69 70 71 dcl apl_number float; /* for size builtin */ 72 dcl n_words fixed bin(18), /* for moving things around */ 73 words (n_words) bit(36) aligned based, 74 data_elements fixed bin(21) def(outersize); /* satisfy include file - allow use of size builtin */ 75 76 declare (addr, addrel, fixed, rel, size, string, substr) builtin; 77 78 dcl (left_char, right_char) char(1), 79 (left_num, right_num) float; 80 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 ---------------------------------- */ 81 2 1 /* ====== BEGIN INCLUDE SEGMENT apl_bead_format.incl.pl1 ================================== */ 2 2 2 3 declare 1 general_bead aligned based, /* The Venerable Bead */ 2 4 2 type unaligned, 2 5 3 bead_type unaligned, 2 6 4 operator bit (1), /* ON if operator bead */ 2 7 4 symbol bit (1), /* ON if symbol bead */ 2 8 4 value bit (1), /* ON if value bead */ 2 9 4 function bit (1), /* ON if function bead */ 2 10 4 group bit (1), /* ON if group bead */ 2 11 4 label bit (1), /* ON if label bead */ 2 12 4 shared_variable bit (1), /* ON if shared variable bead */ 2 13 4 lexed_function bit (1), /* ON if lexed function bead */ 2 14 3 data_type unaligned, 2 15 4 list_value bit (1), /* ON if a list value bead */ 2 16 4 character_value bit (1), /* ON if a character value bead */ 2 17 4 numeric_value bit (1), /* ON if a numeric value bead */ 2 18 4 integral_value bit (1), /* ON if an integral value bead */ 2 19 4 zero_or_one_value bit (1), /* ON if a boolean value bead */ 2 20 4 complex_value bit (1), /* ON if a complex, numeric value bead */ 2 21 3 unused_bits bit (4) unaligned, /* pad to 18 bits (for future use) */ 2 22 2 size bit (18) unaligned, /* Number of words this bead occupies 2 23* (used by bead storage manager) */ 2 24 2 reference_count fixed binary (29); /* Number of pointers which point 2 25* to this bead (used by bead manager) */ 2 26 2 27 2 28 /* constant strings for initing type field in various beads */ 2 29 2 30 declare ( 2 31 operator_type init("100000000000000000"b), 2 32 symbol_type init("010000000000000000"b), 2 33 value_type init("001000000000000000"b), 2 34 function_type init("000100000000000000"b), 2 35 group_type init("000010000000000000"b), 2 36 label_type init("001001000011000000"b), 2 37 shared_variable_type init("001000100000000000"b), 2 38 lexed_function_type init("000000010000000000"b), 2 39 2 40 list_value_type init("000000001000000000"b), 2 41 character_value_type init("001000000100000000"b), 2 42 numeric_value_type init("001000000010000000"b), 2 43 integral_value_type init("001000000011000000"b), 2 44 zero_or_one_value_type init("001000000011100000"b), 2 45 complex_value_type init("001000000000010000"b), 2 46 2 47 not_integer_mask init("111111111110011111"b), /* to clear integral, zero_or_one bits */ 2 48 not_zero_or_one_mask init("111111111111011111"b) /* to clear zero_or_one bit */ 2 49 ) bit(18) internal static; 2 50 2 51 /* ------ END INCLUDE SEGMENT apl_bead_format.incl.pl1 ---------------------------------- */ 82 3 1 /* ====== BEGIN INCLUDE SEGMENT apl_value_bead.incl.pl1 =================================== */ 3 2 3 3 declare 3 4 number_of_dimensions fixed bin, 3 5 3 6 1 value_bead aligned based, 3 7 2 header aligned like general_bead, 3 8 2 total_data_elements fixed binary (21), /* length of ,[value] in APL */ 3 9 2 rhorho fixed binary, /* number of dimensions of value */ 3 10 2 data_pointer pointer unaligned, /* packed pointer to the data in value */ 3 11 2 rho fixed binary (21) dimension (number_of_dimensions refer (value_bead.rhorho)); 3 12 /* dimensions of value (zero-origin) */ 3 13 3 14 3 15 declare 1 character_data_structure aligned based, /* alignment trick for PL/I compiler */ 3 16 2 character_datum character (1) unaligned dimension (0:data_elements - 1); 3 17 /* actual elements of character array */ 3 18 3 19 declare character_string_overlay character (data_elements) aligned based; 3 20 /* to overlay on above structure */ 3 21 3 22 3 23 declare numeric_datum float aligned dimension (0:data_elements - 1) based; 3 24 /* actual elements of numeric array */ 3 25 3 26 declare complex_datum complex float aligned dimension (0:data_elements -1) based; 3 27 3 28 declare MAX_VALUE_BEAD_SIZE fixed bin (19) init (261120) int static options (constant); 3 29 3 30 /* ------ END INCLUDE SEGMENT apl_value_bead.incl.pl1 ----------------------------------- */ 83 4 1 /* ====== BEGIN INCLUDE SEGEMENT apl_operators_argument.incl.pl1 =========================== */ 4 2 4 3 declare 1 operators_argument aligned, 4 4 2 operands (2) aligned, /* these are the operands to the operator to be executed. 4 5* if operand (1).value is null, operator is monadic */ 4 6 3 value pointer unaligned, /* a pointer to the value bead for this operand */ 4 7 3 on_stack bit (1) aligned, /* ON if this value resides on the value stack */ 4 8 2 operator aligned, /* information about the operator to be executed */ 4 9 3 dimension fixed bin, /* (optional) dimension along which to operate */ 4 10 3 padding bit (18) unaligned, /* unused part of operator bead */ 4 11 3 op2 fixed bin (8) unal, /* a modifier for op1, or a 2nd operator if inner product */ 4 12 3 op1 fixed bin (8) unal, /* code for the actual operator to be executed */ 4 13 2 result pointer unal, /* (output) set by operator to point to result bead in stack */ 4 14 2 error_code fixed bin (35), /* (output) set before signaling apl_operator_error_ */ 4 15 2 where_error fixed bin; /* parseme index of where error was - parse sets to operator */ 4 16 4 17 /* ------ END INCLUDE SEGMENT apl_operators_argument.incl.pl1 --------------------------- */ 84 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 -------------------------------------- */ 85 86 87 apl_catenate_: entry(operators_argument); 88 89 90 call determine_conformability; 91 92 /* check ranks, find which case, set up various parameters */ 93 94 if left_scalar then if right_scalar then go to comma_two_scalars; 95 else /* scalar,array */ 96 call calculate_result_bead (right_vb); /*since right is array, calculate 97* all result bead fields from right */ 98 else if right_scalar then do; /* array,scalar */ 99 call calculate_result_bead (left_vb); /* however now left is array */ 100 joint = left_vb -> value_bead.rho (I) * joint; 101 end; 102 103 else /* array,array */ 104 if left_rr = right_rr then do; /* same ranks is OK */ 105 106 rhorho = left_rr; 107 if rhorho < I then go to rank_subsc_error; 108 do j = 1 by 1 while (j <= rhorho); 109 if j ^= I then if left_vb->value_bead.rho(j) ^= 110 right_vb->value_bead.rho(j) then go to length_error; 111 end; 112 J = left_vb->value_bead.rho(I) + right_vb->value_bead.rho(I); 113 114 innersize = 1; 115 do j = I by 1 while(j < rhorho); 116 innersize = left_vb->value_bead.rho(j + 1) * innersize; 117 end; 118 119 joint = innersize*left_vb->value_bead.rho(I); 120 121 outersize = left_vb->value_bead.total_data_elements + 122 right_vb->value_bead.total_data_elements; 123 124 /* allocate result and set rho vector */ 125 126 call stack_allocate; 127 do j = 1 by 1 while(j <= rhorho); 128 result_vb->value_bead.rho(j) = left_vb->value_bead.rho(j); 129 if j = I then result_vb->value_bead.rho(j) = result_vb->value_bead.rho(j) + 130 right_vb->value_bead.rho(j); 131 end; 132 end; 133 134 else if right_rr+1 = left_rr then do; /* right arg has one less rank is allowed too */ 135 call calculate_result_bead_vector (left_vb, right_vb); /* left is 1st cause it has more dims */ 136 joint = left_vb->value_bead.rho(I) * joint; 137 end; 138 else if left_rr+1 = right_rr then /* left arg with one less rank is also allowed */ 139 call calculate_result_bead_vector (right_vb, left_vb); /* right has more than left */ 140 141 else go to rank_error; /* but any other case is not allowed */ 142 143 144 145 146 catenate_laminate_join: 147 148 149 jointsize = J * innersize; 150 151 left_pos, right_pos = 0; /* set up control variables for scanning through arguments */ 152 left_size = joint; /* number of things at a time to take from left */ 153 right_size = jointsize - left_size; /* number of things at a time to take from the right */ 154 155 /** All stuff has been set up. Do the actual operation **/ 156 157 158 do result_pos = 0 repeat (result_pos + jointsize) while(result_pos < outersize); 159 160 /* part of column before a joint is moved in from left argument */ 161 162 if ^left_scalar then do; /* use EIS to copy in from vector */ 163 if characters then substr(result -> character_string_overlay, result_pos+1, left_size) = 164 substr(left -> character_string_overlay, left_pos+1, left_size); 165 else addr(result -> numeric_datum(result_pos)) -> left_numbers = 166 addr(left -> numeric_datum(left_pos)) -> left_numbers; 167 left_pos = left_pos + left_size; 168 end; 169 170 else /* assign scalar to vector row of result */ 171 if characters then do n = 0 by 1 while (n < left_size); /* use copy builtin if and when it */ 172 result -> character_datum(n+result_pos) = left -> character_datum(0); /* ever works. */ 173 end; 174 else do n = 0 by 1 while (n < left_size); /* use assignment of scalar to aggregate */ 175 result -> numeric_datum(n+result_pos) = left -> numeric_datum(0); /* if and when it ever generates */ 176 end; /* as good or better code than do-loop */ 177 178 /* part of column after a joint is moved in from right argument */ 179 180 if ^right_scalar then do; /* use EIS to copy in from vector */ 181 if characters then substr(result -> character_string_overlay, result_pos+left_size+1, right_size) = 182 substr(right -> character_string_overlay, right_pos+1, right_size); 183 else addr(result -> numeric_datum(result_pos+left_size)) -> right_numbers = 184 addr(right -> numeric_datum(right_pos)) -> right_numbers; 185 right_pos = right_pos + right_size; 186 end; 187 188 else /* assign to scalar to a vector row of result */ 189 if characters then do n = 0 by 1 while (n < right_size); /* use copy builtin if and when */ 190 result -> character_datum(n+result_pos+left_size) = right -> character_datum(0); 191 end; /* it ever works */ 192 else do n = 0 by 1 while (n < right_size); /* use assignment of a scalar to an aggregate */ 193 result -> numeric_datum(n+result_pos+left_size) = right -> numeric_datum(0); 194 end; /* if and when it ever generates as good or 195* better code than the do loop */ 196 197 end; 198 199 /* maybe copy result down */ 200 201 if ^ operands(2).on_stack 202 then if ^operands(1).on_stack 203 then do; /* result is already at right place since nothing else on stack */ 204 operators_argument.result = result_vb; 205 return; 206 end; 207 else operators_argument.result = left_vb; /* only left on stack, over-write it */ 208 else operators_argument.result = right_vb; /* right or both on stack, over-write right */ 209 210 /* yes, copy result down */ 211 212 number_of_dimensions = rhorho; /* for taking size, base of refer option */ 213 n_words = size(value_bead); /* first copy bead header stuff + rho vector */ 214 operators_argument.result -> words = result_vb -> words; 215 216 /* adjust value_bead.data_pointer */ 217 218 left, operators_argument.result -> value_bead.data_pointer 219 = addr(operators_argument.result->value_bead.rho(rhorho+1)); 220 221 if characters then n_words = size(character_string_overlay); 222 else do; 223 n_words = size(numeric_datum); 224 if substr(rel(left), 18, 1) then do; 225 left = addrel(left, 1); /* double-word align */ 226 operators_argument.result -> value_bead.data_pointer = left; 227 end; 228 end; 229 230 if n_words ^= 0 then /* avoid illegal_procedure faults from kludge EIS hardware */ 231 left -> words = result -> words; /* move in the data */ 232 233 value_stack_ptr = addrel(left, n_words); /* set ptr to first word above data */ 234 235 return; 236 237 comma_two_scalars: 238 239 rhorho = 1; 240 outersize = 2; 241 if characters then do; 242 left_char = left -> character_datum(0); 243 right_char = right -> character_datum(0); 244 call stack_allocate_0; 245 result -> character_datum(0) = left_char; 246 result -> character_datum(1) = right_char; 247 end; 248 else do; 249 left_num = left -> numeric_datum(0); 250 right_num = right -> numeric_datum(0); 251 call stack_allocate_0; 252 result -> numeric_datum(0) = left_num; 253 result -> numeric_datum(1) = right_num; 254 end; 255 result_vb -> value_bead.rho(1) = 2; 256 operators_argument.result = result_vb; 257 return; 258 259 /*** routines to make a bead on the value stack, given rhorho and outersize. 260* returns result_vb, result. Sets value_bead.type, .rhorho, .data_pointer. 261* Sets value_stack_ptr ***/ 262 263 stack_allocate_0: proc; /* this entry flushes operands before allocating */ 264 265 if operands(2).on_stack then value_stack_ptr = right_vb; 266 else if operands(1).on_stack then value_stack_ptr = left_vb; 267 268 stack_allocate: entry; /* this entry allocates on top of stack */ 269 270 dcl words_needed_in_bead fixed bin(19), 271 words_needed fixed bin(19), 272 data_words_needed fixed bin(19); 273 274 if characters then data_words_needed = size(character_string_overlay); 275 else data_words_needed = size(numeric_datum); 276 277 number_of_dimensions = rhorho; 278 words_needed_in_bead = size(value_bead); 279 words_needed = words_needed_in_bead + data_words_needed; 280 if ^ characters then words_needed = words_needed + 1; /* double word alignment hack */ 281 282 result_vb = apl_push_stack_ (words_needed); 283 284 result = addrel(result_vb, words_needed_in_bead); /* -> data area */ 285 string(result_vb -> value_bead.type) = resulting_type; 286 if ^ characters then if substr(rel(result), 18, 1) then result = addrel(result, 1); /* double word align */ 287 288 result_vb -> value_bead.reference_count = -1; 289 result_vb -> value_bead.total_data_elements = outersize; 290 result_vb -> value_bead.rhorho = rhorho; 291 result_vb -> value_bead.data_pointer = result; 292 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 ------------------------------- */ 293 294 end; 295 296 /* This subroutine calculates information about the result bead from either 297* the left or right bead (whichever one arg ptr points to) for the 298* apl_catenate_ entry. */ 299 300 calculate_result_bead: 301 procedure (a_info_bead_ptr); 302 303 declare a_info_bead_ptr pointer parameter; /* ptr to which bead is array */ 304 declare info_bead_ptr pointer initial (a_info_bead_ptr); /* for efficiency */ 305 306 307 kludge_rhorho = info_bead_ptr -> value_bead.rhorho; 308 if I > kludge_rhorho then go to rank_subsc_error; 309 310 J = info_bead_ptr -> value_bead.rho(I) + 1; 311 312 innersize = 1; 313 do i = I by 1 while (i < kludge_rhorho); 314 innersize = info_bead_ptr -> value_bead.rho(i + 1) * innersize; 315 end; 316 317 outersize, /* init to product of all dims 318* of greater rank than I */ 319 joint = innersize; /* left member is a scalar, so only take 1 at a time from it */ 320 321 /* Multiply outersize by all dimensions of lesser rank than I so that it 322* will be product of all dimensions but that of I */ 323 324 do i = 0 to I -2; 325 outersize = info_bead_ptr -> value_bead.rho (i + 1) * outersize; 326 end; 327 328 outersize = outersize + info_bead_ptr -> value_bead.total_data_elements; 329 330 /* allocate result and set rho vector */ 331 332 call stack_allocate; 333 do j = 1 by 1 while (j <= kludge_rhorho); 334 result_vb->value_bead.rho(j) = info_bead_ptr -> value_bead.rho(j); 335 if j = I then result_vb->value_bead.rho(j) = result_vb->value_bead.rho(j) + 1; 336 end; 337 end calculate_result_bead; 338 339 /* This subroutine calculates data in the result bead for 340* apl_catenate_ for vector arguments, when one vector has 341* one less dimension than the other */ 342 343 calculate_result_bead_vector: 344 procedure (a_greater_ptr, a_less_ptr); 345 346 declare (a_greater_ptr, /* ptr to value bead with greater rhorho */ 347 a_less_ptr) ptr parameter; /* pointer to other one, dummy */ 348 349 declare (greater_ptr initial (a_greater_ptr), /* is it really more efficient? */ 350 less_ptr initial (a_less_ptr)) pointer automatic; 351 352 353 kludge_rhorho = greater_ptr -> value_bead.rhorho; 354 if kludge_rhorho < I then go to rank_subsc_error; 355 356 do j = 1 by 1 while (j < I); /* check that rho vectors match */ 357 if greater_ptr -> value_bead.rho(j) ^= less_ptr -> value_bead.rho(j) then go to length_error; 358 end; 359 do j = I+1 by 1 while(j <= kludge_rhorho); 360 if greater_ptr -> value_bead.rho(j) ^= less_ptr -> value_bead.rho (j-1) then 361 go to length_error; 362 end; 363 364 J = greater_ptr -> value_bead.rho(I)+1; 365 innersize = 1; 366 do j = I by 1 while(j < kludge_rhorho); 367 innersize = greater_ptr -> value_bead.rho(j + 1) * innersize; 368 end; 369 370 joint = innersize; 371 outersize = greater_ptr -> value_bead.total_data_elements + 372 less_ptr -> value_bead.total_data_elements; 373 374 /* allocate result and set rho vector */ 375 376 call stack_allocate; 377 do j = 1 by 1 while(j <= kludge_rhorho); 378 result_vb->value_bead.rho(j) = greater_ptr -> value_bead.rho(j); 379 if j = I then result_vb->value_bead.rho(j) = result_vb->value_bead.rho(j) + 1; 380 end; 381 382 end calculate_result_bead_vector; 383 384 385 386 determine_conformability: proc; 387 388 left_vb = operands(1).value; 389 right_vb = operands(2).value; /* copy arg ptrs for efficiency (?) */ 390 if left_vb->value_bead.data_type.character_value 391 then if right_vb->value_bead.data_type.character_value 392 then do; 393 characters = "1"b; 394 resulting_type = character_value_type; 395 end; 396 else call null_vector_hacks; 397 else if left_vb->value_bead.data_type.numeric_value 398 then if right_vb->value_bead.data_type.numeric_value 399 then do; 400 characters = "0"b; 401 resulting_type = string(left_vb -> value_bead.type) & string(right_vb -> value_bead.type); 402 end; 403 else call null_vector_hacks; 404 else go to domain_error; 405 406 407 /* types conform, set up variables so that rank/shape checking can be done */ 408 409 left = left_vb->value_bead.data_pointer; 410 right = right_vb->value_bead.data_pointer; 411 left_rr = left_vb->value_bead.rhorho; 412 left_scalar = (left_rr = 0); /* comma only accepts true scalars as scalars */ 413 right_rr = right_vb->value_bead.rhorho; 414 right_scalar = (right_rr = 0); 415 I = operators_argument.dimension; 416 417 418 null_vector_hacks: proc; 419 420 /* 421* * this routine is called when there is a mismatch in types. 422* * normally, this would be a domain error, but for compatibility with 423* * some apparently undocumented features in APL/360 the following special 424* * cases are recognized: 425* * 1) both arguments are null 426* * the type of the right-hand argument is used. 427* * 2) one is null, but not both 428* * the type of the non-null argument is used. 429* * 3) otherwise 430* * it is a domain error 431* */ 432 433 if left_vb -> value_bead.total_data_elements = 0 434 then if right_vb -> value_bead.total_data_elements = 0 435 then /* case 1 */ 436 resulting_type = string(right_vb -> value_bead.type); 437 else /* case 2, right is non-null */ 438 resulting_type = string(right_vb -> value_bead.type); /* not optimized - clarity */ 439 else if right_vb -> value_bead.total_data_elements = 0 440 then /* case 2, left is non-null */ 441 resulting_type = string(left_vb -> value_bead.type); 442 else go to domain_error; /* case 3, not allowed */ 443 444 characters = (resulting_type = character_value_type); 445 end null_vector_hacks; 446 447 448 end determine_conformability; 449 450 apl_ravel_: 451 entry (operators_argument); 452 453 right_vb = operands(2).value; 454 resulting_type = string(right_vb -> value_bead.type); 455 if ^operands (2).on_stack /* copy into stack */ 456 then do; 457 if right_vb -> value_bead.data_type.character_value 458 then characters = "1"b; 459 else if right_vb -> value_bead.data_type.numeric_value 460 then characters = "0"b; 461 else go to domain_error_right; 462 463 rhorho = 1; 464 outersize = right_vb -> value_bead.total_data_elements; 465 left_vb = right_vb; /* hack type-field !! */ 466 call stack_allocate; 467 468 /* having set up the bead header, now copy the data values */ 469 470 if outersize ^= 0 /* avoid IPR fault from EIS hardware */ 471 then if characters 472 then result -> character_string_overlay = right_vb -> value_bead.data_pointer -> character_string_overlay; 473 else result -> numeric_datum (*) = right_vb -> value_bead.data_pointer -> numeric_datum (*); 474 end; 475 else if right_vb -> value_bead.rhorho = 0 /* special handling for scalar on stack, because */ 476 then do; /* it cannot be done in place */ 477 rhorho = 1; 478 outersize = 1; 479 if right_vb -> value_bead.data_type.character_value /* save value and type of scalar */ 480 then do; 481 characters = "1"b; 482 right_char = right_vb -> value_bead.data_pointer -> character_datum(0); 483 end; 484 else do; 485 characters = "0"b; 486 right_num = right_vb -> value_bead.data_pointer -> numeric_datum(0); 487 end; 488 left_vb, value_stack_ptr = right_vb; /* get rid of the old value bead, and ... */ 489 /* set left_vb to hack the type field */ 490 call stack_allocate; /* get a new bead with room for rho vector */ 491 if characters 492 then result -> character_datum (0) = right_char; 493 else result -> numeric_datum(0) = right_num; /* fill in data from saved scalar */ 494 end; 495 else result_vb = right_vb; /* a non-scalar on the stack may always be overlayed */ 496 497 /* now just mung the rho vector */ 498 499 operators_argument.result = result_vb; 500 result_vb -> value_bead.rhorho = 1; 501 result_vb -> value_bead.rho(1) = result_vb -> value_bead.total_data_elements; 502 return; 503 504 apl_laminate_: entry(operators_argument); 505 506 call determine_conformability; 507 508 /* check ranks, find which case, set up parameters */ 509 510 if left_scalar 511 then if right_scalar 512 then go to comma_two_scalars; 513 else /* scalar,array */ 514 call calculate_result_bead_laminate (right_vb); /* because right is array it dominates */ 515 else if right_scalar /* array,scalar */ 516 then call calculate_result_bead_laminate (left_vb); /* left is array */ 517 else if right_rr = left_rr /* arrays of the same rank */ 518 then do; 519 if I > right_rr 520 then go to rank_subsc_error; 521 522 rhorho = right_rr + 1; 523 524 do j = 0 by 1 while (j < right_rr); /* make sure rho vectors are equal */ 525 if left_vb->value_bead.rho(j + 1) ^= right_vb->value_bead.rho(j + 1) 526 then go to length_error; 527 end; 528 529 outersize = 2 * left_vb->value_bead.total_data_elements; 530 531 innersize = 1; 532 do j = I by 1 while (j < left_rr); 533 innersize = left_vb->value_bead.rho(j + 1) * innersize; 534 end; 535 joint = innersize; 536 537 /* allocate and fill rho */ 538 539 call stack_allocate; 540 do j = 0 by 1 while (j < I); /* part of rho before joint */ 541 result_vb->value_bead.rho(j + 1) = left_vb->value_bead.rho(j + 1); 542 end; 543 do j = I by 1 while (j < right_rr); /* part of rho after joint */ 544 result_vb->value_bead.rho(j+2) = left_vb->value_bead.rho(j + 1); 545 end; 546 result_vb->value_bead.rho(I+1) = 2; /* part of rho for joint */ 547 end; 548 else go to rank_error; 549 550 J = 2; 551 552 go to catenate_laminate_join; 553 554 /* Subroutine to calculate bead info and sizes, etc. for laminate when one operand 555* is scalar and the other is vector */ 556 557 calculate_result_bead_laminate: 558 procedure (a_array_bead_ptr); 559 560 declare a_array_bead_ptr pointer parameter; /* which bead is array */ 561 declare array_bead_ptr pointer initial /* for efficiency */ 562 (a_array_bead_ptr); 563 564 if I > array_bead_ptr -> value_bead.rhorho 565 then go to rank_subsc_error; 566 567 kludge_rhorho = array_bead_ptr -> value_bead.rhorho + 1; 568 569 outersize = 2 * array_bead_ptr -> value_bead.total_data_elements; 570 innersize = 1; 571 do j = I by 1 while (j < array_bead_ptr -> value_bead.rhorho); 572 innersize = array_bead_ptr -> value_bead.rho(j + 1) * innersize; 573 end; 574 joint = innersize; /* since joining two things of equal size */ 575 576 /* allocate and fill rho */ 577 578 call stack_allocate; 579 do j = 0 by 1 while ( j < kludge_rhorho); 580 if j < I then result_vb->value_bead.rho(j + 1) = array_bead_ptr -> value_bead.rho(j + 1); 581 else if j = I then result_vb->value_bead.rho(j + 1) = 2; /* the lamination dimension */ 582 else result_vb->value_bead.rho(j + 1) = array_bead_ptr -> value_bead.rho(j); 583 end; 584 end calculate_result_bead_laminate; 585 586 /*** errors ***/ 587 588 dcl (apl_error_table_$operator_subscript_range, 589 apl_error_table_$length, 590 apl_error_table_$rank, 591 apl_error_table_$domain) fixed bin(35) external; 592 593 rank_subsc_error: 594 operators_argument.error_code = apl_error_table_$operator_subscript_range; 595 return; 596 597 rank_error: 598 operators_argument.error_code = apl_error_table_$rank; 599 return; 600 601 length_error: 602 operators_argument.error_code = apl_error_table_$length; 603 return; 604 605 domain_error_right: 606 operators_argument.where_error = operators_argument.where_error - 1; 607 608 domain_error: 609 operators_argument.error_code = apl_error_table_$domain; 610 return; 611 612 end /* apl_comma_operators */; SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 11/29/83 1346.2 apl_comma_operators_.pl1 >special_ldd>on>apl.1129>apl_comma_operators_.pl1 81 1 03/27/82 0429.8 apl_number_data.incl.pl1 >ldd>include>apl_number_data.incl.pl1 82 2 03/27/82 0438.5 apl_bead_format.incl.pl1 >ldd>include>apl_bead_format.incl.pl1 83 3 03/27/82 0439.2 apl_value_bead.incl.pl1 >ldd>include>apl_value_bead.incl.pl1 84 4 03/27/82 0439.0 apl_operators_argument.incl.pl1 >ldd>include>apl_operators_argument.incl.pl1 85 5 03/27/82 0439.2 apl_ws_info.incl.pl1 >ldd>include>apl_ws_info.incl.pl1 293 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. I 000124 automatic fixed bin(17,0) dcl 33 set ref 100 107 109 112 112 115 119 129 136 308 310 313 324 335 354 356 359 364 366 379 415* 519 532 540 543 546 564 571 580 581 J 000125 automatic fixed bin(21,0) dcl 33 set ref 112* 146 310* 364* 550* P_n_words parameter fixed bin(19,0) dcl 6-16 ref 6-4 6-35 a_array_bead_ptr parameter pointer dcl 560 ref 557 561 a_greater_ptr parameter pointer dcl 346 ref 343 349 a_info_bead_ptr parameter pointer dcl 303 ref 300 304 a_less_ptr parameter pointer dcl 346 ref 343 349 addr builtin function dcl 76 ref 165 165 183 183 218 addrel builtin function dcl 76 in procedure "apl_comma_operators_" ref 225 233 284 286 addrel builtin function dcl 6-25 in procedure "apl_push_stack_" ref 6-44 apl_error_table_$domain 000020 external static fixed bin(35,0) dcl 588 ref 608 apl_error_table_$length 000014 external static fixed bin(35,0) dcl 588 ref 601 apl_error_table_$operator_subscript_range 000012 external static fixed bin(35,0) dcl 588 ref 593 apl_error_table_$rank 000016 external static fixed bin(35,0) dcl 588 ref 597 apl_get_value_stack_ 000022 constant entry external dcl 6-30 ref 6-40 apl_static_$ws_info_ptr 000010 external static structure level 1 dcl 5-11 array_bead_ptr 000250 automatic pointer initial dcl 561 set ref 561* 564 567 569 571 572 580 582 binary builtin function dcl 6-25 ref 6-40 block_ptr 000176 automatic pointer dcl 6-20 set ref 6-43* 6-45 character_data_structure based structure level 1 dcl 3-15 character_datum based char(1) array level 2 packed unaligned dcl 3-15 set ref 172* 172 190* 190 242 243 245* 246* 482 491* character_string_overlay based char dcl 3-19 set ref 163* 163 181* 181 221 274 470* 470 character_value 0(09) based bit(1) level 5 packed unaligned dcl 3-3 set ref 390 390 457 479 character_value_type constant bit(18) initial unaligned dcl 2-30 ref 394 444 characters 000126 automatic bit(1) unaligned dcl 33 set ref 163 170 181 188 221 241 274 280 286 393* 400* 444* 457* 459* 470 481* 485* 491 data_elements defined fixed bin(21,0) dcl 72 ref 163 163 181 181 221 221 223 274 274 275 470 470 473 data_pointer 4 based pointer level 2 packed unaligned dcl 3-3 set ref 218* 226* 291* 409 410 470 473 482 486 data_type 0(08) based structure level 4 packed unaligned dcl 3-3 data_words_needed 000166 automatic fixed bin(19,0) dcl 270 set ref 274* 275* 279 dimension 4 parameter fixed bin(17,0) level 3 dcl 4-3 ref 415 error_code 7 parameter fixed bin(35,0) level 2 dcl 4-3 set ref 593* 597* 601* 608* general_bead based structure level 1 dcl 2-3 greater_ptr 000222 automatic pointer initial dcl 349 set ref 349* 353 357 360 364 367 371 378 header based structure level 2 dcl 3-3 i 000130 automatic fixed bin(21,0) dcl 33 set ref 313* 313* 314* 324* 325* info_bead_ptr 000210 automatic pointer initial dcl 304 set ref 304* 307 310 314 325 328 334 innersize 000122 automatic fixed bin(21,0) dcl 33 set ref 114* 116* 116 119 146 312* 314* 314 317 365* 367* 367 370 531* 533* 533 535 570* 572* 572 574 j 000131 automatic fixed bin(21,0) dcl 33 set ref 108* 108* 109 109 109* 115* 115* 116* 127* 127* 128 128 129 129 129 129* 333* 333* 334 334 335 335 335* 356* 356* 357 357* 359* 359* 360 360* 366* 366* 367* 377* 377* 378 378 379 379 379* 524* 524* 525 525* 532* 532* 533* 540* 540* 541 541* 543* 543* 544 544* 571* 571* 572* 579* 579* 580 580 580 581 581 582 582* joint 000123 automatic fixed bin(21,0) dcl 33 set ref 100* 100 119* 136* 136 152 317* 370* 535* 574* jointsize 000121 automatic fixed bin(21,0) dcl 33 set ref 146* 153 197 kludge_rhorho defined fixed bin(17,0) dcl 33 set ref 307* 308 313 333 353* 354 359 366 377 567* 579 left 000106 automatic pointer dcl 33 set ref 163 165 172 175 218* 224 225* 225 226 230 233 242 249 409* left_char 000144 automatic char(1) unaligned dcl 78 set ref 242* 245 left_num 000146 automatic float bin(63) dcl 78 set ref 249* 252 left_numbers based float bin(63) array dcl 63 set ref 165* 165 left_pos 000114 automatic fixed bin(21,0) dcl 33 set ref 151* 163 165 167* 167 left_rr 000112 automatic fixed bin(17,0) dcl 33 set ref 103 106 134 138 411* 412 517 532 left_scalar 000116 automatic bit(1) unaligned dcl 33 set ref 94 162 412* 510 left_size 000140 automatic fixed bin(21,0) dcl 63 set ref 152* 153 163 163 165 167 170 174 181 183 190 193 left_vb 000136 automatic pointer dcl 33 set ref 99* 100 109 112 116 119 121 128 135* 136 138* 207 266 388* 390 397 401 409 411 433 439 465* 488* 515* 525 529 533 541 544 less_ptr 000224 automatic pointer initial dcl 349 set ref 349* 357 360 371 maximum_value_stack_size 13 based fixed bin(18,0) level 3 dcl 5-16 ref 6-40 n 000132 automatic fixed bin(21,0) dcl 33 set ref 170* 170* 172* 174* 174* 175* 188* 188* 190* 192* 192* 193* n_words 000143 automatic fixed bin(18,0) dcl 72 set ref 213* 214 221* 223* 230 230 233 num_words 000200 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 000152 automatic fixed bin(17,0) dcl 3-3 set ref 212* 213 277* 278 numeric_datum based float bin(63) array dcl 3-23 set ref 165 165 175* 175 183 183 193* 193 223 249 250 252* 253* 275 473* 473 486 493* numeric_value 0(10) based bit(1) level 5 packed unaligned dcl 3-3 set ref 397 397 459 on_stack 1 parameter bit(1) array level 3 dcl 4-3 ref 201 201 265 266 455 operands parameter structure array level 2 dcl 4-3 operator 4 parameter structure level 2 dcl 4-3 operators_argument parameter structure level 1 dcl 4-3 set ref 87 450 504 outersize 000120 automatic fixed bin(21,0) dcl 33 set ref 121* 158 163 163 163 163 181 181 181 181 221 221 221 221 223 223 240* 274 274 274 274 275 275 289 317* 325* 325 328* 328 371* 464* 470 470 470 470 470 473 473 478* 529* 569* pointers 14 based structure level 2 dcl 5-16 reference_count 1 based fixed bin(29,0) level 3 dcl 3-3 set ref 288* rel builtin function dcl 76 in procedure "apl_comma_operators_" ref 224 286 rel builtin function dcl 6-25 in procedure "apl_push_stack_" ref 6-40 result 6 parameter pointer level 2 in structure "operators_argument" packed unaligned dcl 4-3 in procedure "apl_comma_operators_" set ref 204* 207* 208* 214 218 218 226 256* 499* result 000102 automatic pointer dcl 33 in procedure "apl_comma_operators_" set ref 163 165 172 175 181 183 190 193 230 245 246 252 253 284* 286 286* 286 291 470 473 491 493 result_pos 000142 automatic fixed bin(21,0) dcl 63 set ref 158* 158* 163 165 172 175 181 183 190 193* 197 result_vb 000100 automatic pointer dcl 33 set ref 128 129 129 204 214 255 256 282* 284 285 288 289 290 291 334 335 335 378 379 379 495* 499 500 501 501 541 544 546 580 581 582 resulting_type 000127 automatic bit(18) unaligned dcl 33 set ref 285 394* 401* 433* 437* 439* 444 454* rho 5 based fixed bin(21,0) array level 2 dcl 3-3 set ref 100 109 109 112 112 116 119 128* 128 129* 129 129 136 218 255* 310 314 325 334* 334 335* 335 357 357 360 360 364 367 378* 378 379* 379 501* 525 525 533 541* 541 544* 544 546* 572 580* 580 581* 582* 582 rhorho 3 based fixed bin(17,0) level 2 in structure "value_bead" dcl 3-3 in procedure "apl_comma_operators_" set ref 290* 307 353 411 413 475 500* 564 567 571 rhorho 000104 automatic fixed bin(17,0) dcl 33 in procedure "apl_comma_operators_" set ref 106* 107 108 115 127 212 218 237* 277 290 307* 307 308 308 313 313 333 333 353* 353 354 354 359 359 366 366 377 377 463* 477* 522* 567* 567 579 579 right 000110 automatic pointer dcl 33 set ref 181 183 190 193 243 250 410* right_char 000145 automatic char(1) unaligned dcl 78 set ref 243* 246 482* 491 right_num 000150 automatic float bin(63) dcl 78 set ref 250* 253 486* 493 right_numbers based float bin(63) array dcl 63 set ref 183* 183 right_pos 000115 automatic fixed bin(21,0) dcl 33 set ref 151* 181 183 185* 185 right_rr 000113 automatic fixed bin(17,0) dcl 33 set ref 103 134 138 413* 414 517 519 522 524 543 right_scalar 000117 automatic bit(1) unaligned dcl 33 set ref 94 98 180 414* 510 515 right_size 000141 automatic fixed bin(21,0) dcl 63 set ref 153* 181 181 183 185 188 192 right_vb 000134 automatic pointer dcl 33 set ref 95* 109 112 121 129 135* 138* 208 265 389* 390 397 401 410 413 433 433 437 439 453* 454 457 459 464 465 470 473 475 479 482 486 488 495 513* 525 size builtin function dcl 76 ref 213 221 223 274 275 278 static_ws_info_ptr 000010 external static pointer level 2 packed unaligned dcl 5-11 ref 5-7 string builtin function dcl 76 set ref 285* 401 401 433 437 439 454 substr builtin function dcl 6-25 in procedure "apl_push_stack_" ref 6-37 substr builtin function dcl 76 in procedure "apl_comma_operators_" set ref 163* 163 181* 181 224 286 total_data_elements 2 based fixed bin(21,0) level 2 dcl 3-3 set ref 121 121 289* 328 371 371 433 433 439 464 501 529 569 type based structure level 3 packed unaligned dcl 3-3 set ref 285* 401 401 433 437 439 454 unspec builtin function dcl 6-25 ref 6-37 value parameter pointer array level 3 packed unaligned dcl 4-3 ref 388 389 453 value_bead based structure level 1 dcl 3-3 set ref 213 278 value_stack_ptr 16 based pointer level 3 packed unaligned dcl 5-16 set ref 233* 265* 266* 488* 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 4-3 set ref 605* 605 words based bit(36) array dcl 72 set ref 214* 214 230* 230 words_needed 000165 automatic fixed bin(19,0) dcl 270 set ref 279* 280* 280 282* words_needed_in_bead 000164 automatic fixed bin(19,0) dcl 270 set ref 278* 279 284 ws_info based structure level 1 dcl 5-16 ws_info_ptr 000154 automatic pointer initial dcl 5-7 set ref 233 488 5-7* 265 266 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 3-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_number automatic float bin(63) dcl 71 complex_datum based complex float bin(63) array dcl 3-26 complex_value_type internal static bit(18) initial unaligned dcl 2-30 fixed builtin function dcl 76 function_type internal static bit(18) initial unaligned dcl 2-30 group_type internal static bit(18) initial unaligned dcl 2-30 integral_value_type internal static bit(18) initial unaligned dcl 2-30 label_type internal static bit(18) initial unaligned dcl 2-30 lexed_function_type internal static bit(18) initial unaligned dcl 2-30 list_value_type internal static bit(18) initial unaligned dcl 2-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 2-30 not_zero_or_one_mask internal static bit(18) initial unaligned dcl 2-30 numeric_value_type internal static bit(18) initial unaligned dcl 2-30 operator_type internal static bit(18) initial unaligned dcl 2-30 output_buffer based char unaligned dcl 5-94 shared_variable_type internal static bit(18) initial unaligned dcl 2-30 symbol_type internal static bit(18) initial unaligned dcl 2-30 value_type internal static bit(18) initial unaligned dcl 2-30 zero_or_one_value_type internal static bit(18) initial unaligned dcl 2-30 NAMES DECLARED BY EXPLICIT CONTEXT. apl_catenate_ 000050 constant entry external dcl 87 apl_comma_operators_ 000036 constant entry external dcl 10 apl_laminate_ 000757 constant entry external dcl 504 apl_push_stack_ 001242 constant entry internal dcl 6-4 ref 282 apl_ravel_ 000615 constant entry external dcl 450 calculate_result_bead 001305 constant entry internal dcl 300 ref 95 99 calculate_result_bead_laminate 001653 constant entry internal dcl 557 ref 513 515 calculate_result_bead_vector 001405 constant entry internal dcl 343 ref 135 138 catenate_laminate_join 000231 constant label dcl 146 ref 552 comma_two_scalars 000545 constant label dcl 237 ref 94 510 determine_conformability 001531 constant entry internal dcl 386 ref 90 506 domain_error 001135 constant label dcl 608 ref 397 439 domain_error_right 001133 constant label dcl 605 ref 459 length_error 001125 constant label dcl 601 ref 109 357 360 525 null_vector_hacks 001622 constant entry internal dcl 418 ref 396 403 rank_error 001117 constant label dcl 597 ref 138 517 rank_subsc_error 001111 constant label dcl 593 ref 107 308 354 519 564 stack_allocate 001164 constant entry internal dcl 268 ref 126 332 376 466 490 539 578 stack_allocate_0 001143 constant entry internal dcl 263 ref 244 251 THERE WERE NO NAMES DECLARED BY CONTEXT OR IMPLICATION. STORAGE REQUIREMENTS FOR THIS PROGRAM. Object Text Link Symbol Defs Static Start 0 0 2134 2160 2000 2144 Length 2470 2000 24 273 133 0 BLOCK NAME STACK SIZE TYPE WHY NONQUICK/WHO SHARES STACK FRAME apl_comma_operators_ 188 external procedure is an external procedure. stack_allocate_0 internal procedure shares stack frame of external procedure apl_comma_operators_. apl_push_stack_ internal procedure shares stack frame of external procedure apl_comma_operators_. calculate_result_bead internal procedure shares stack frame of external procedure apl_comma_operators_. calculate_result_bead_vector internal procedure shares stack frame of external procedure apl_comma_operators_. determine_conformability internal procedure shares stack frame of external procedure apl_comma_operators_. null_vector_hacks internal procedure shares stack frame of external procedure apl_comma_operators_. calculate_result_bead_laminate internal procedure shares stack frame of external procedure apl_comma_operators_. STORAGE FOR AUTOMATIC VARIABLES. STACK FRAME LOC IDENTIFIER BLOCK NAME apl_comma_operators_ 000100 result_vb apl_comma_operators_ 000102 result apl_comma_operators_ 000104 rhorho apl_comma_operators_ 000106 left apl_comma_operators_ 000110 right apl_comma_operators_ 000112 left_rr apl_comma_operators_ 000113 right_rr apl_comma_operators_ 000114 left_pos apl_comma_operators_ 000115 right_pos apl_comma_operators_ 000116 left_scalar apl_comma_operators_ 000117 right_scalar apl_comma_operators_ 000120 outersize apl_comma_operators_ 000121 jointsize apl_comma_operators_ 000122 innersize apl_comma_operators_ 000123 joint apl_comma_operators_ 000124 I apl_comma_operators_ 000125 J apl_comma_operators_ 000126 characters apl_comma_operators_ 000127 resulting_type apl_comma_operators_ 000130 i apl_comma_operators_ 000131 j apl_comma_operators_ 000132 n apl_comma_operators_ 000134 right_vb apl_comma_operators_ 000136 left_vb apl_comma_operators_ 000140 left_size apl_comma_operators_ 000141 right_size apl_comma_operators_ 000142 result_pos apl_comma_operators_ 000143 n_words apl_comma_operators_ 000144 left_char apl_comma_operators_ 000145 right_char apl_comma_operators_ 000146 left_num apl_comma_operators_ 000150 right_num apl_comma_operators_ 000152 number_of_dimensions apl_comma_operators_ 000154 ws_info_ptr apl_comma_operators_ 000164 words_needed_in_bead stack_allocate_0 000165 words_needed stack_allocate_0 000166 data_words_needed stack_allocate_0 000176 block_ptr apl_push_stack_ 000200 num_words apl_push_stack_ 000210 info_bead_ptr calculate_result_bead 000222 greater_ptr calculate_result_bead_vector 000224 less_ptr calculate_result_bead_vector 000250 array_bead_ptr calculate_result_bead_laminate THE FOLLOWING EXTERNAL OPERATORS ARE USED BY THIS PROGRAM. r_e_as 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_$length apl_error_table_$operator_subscript_range apl_error_table_$rank apl_static_$ws_info_ptr LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC 5 7 000030 10 000035 87 000044 90 000056 94 000057 95 000063 98 000066 99 000070 100 000072 101 000077 103 000100 106 000103 107 000104 108 000106 109 000113 111 000123 112 000125 114 000133 115 000135 116 000143 117 000147 119 000151 121 000156 126 000162 127 000163 128 000171 129 000176 131 000204 132 000206 134 000207 135 000213 136 000215 137 000222 138 000223 146 000231 151 000234 152 000236 153 000240 158 000243 162 000247 163 000251 165 000265 167 000303 168 000305 170 000306 172 000315 173 000323 174 000326 175 000333 176 000340 180 000342 181 000344 183 000362 185 000402 186 000404 188 000405 190 000413 191 000422 192 000425 193 000431 194 000437 197 000441 201 000444 204 000454 205 000456 207 000457 208 000462 212 000464 213 000466 214 000470 218 000476 221 000503 223 000512 224 000515 225 000521 226 000524 230 000527 233 000537 235 000544 237 000545 240 000547 241 000551 242 000553 243 000556 244 000561 245 000562 246 000565 247 000571 249 000572 250 000574 251 000576 252 000577 253 000601 255 000604 256 000607 257 000612 450 000613 453 000623 454 000627 455 000632 457 000635 459 000643 463 000647 464 000651 465 000653 466 000654 470 000655 473 000671 474 000701 475 000702 477 000704 478 000706 479 000710 481 000713 482 000715 483 000721 485 000722 486 000723 488 000726 490 000731 491 000732 493 000740 494 000742 495 000743 499 000744 500 000750 501 000752 502 000754 504 000755 506 000765 510 000766 513 000772 515 000775 517 001002 519 001005 522 001007 524 001011 525 001015 527 001023 529 001025 531 001031 532 001033 533 001041 534 001045 535 001047 539 001051 540 001052 541 001057 542 001064 543 001066 544 001073 545 001100 546 001102 550 001106 552 001110 593 001111 595 001116 597 001117 599 001124 601 001125 603 001132 605 001133 608 001135 610 001142 263 001143 265 001144 266 001155 268 001163 274 001165 275 001174 277 001177 278 001201 279 001203 280 001205 282 001210 284 001212 285 001216 286 001221 288 001231 289 001234 290 001236 291 001240 294 001241 6 4 001242 6 35 001244 6 37 001246 6 40 001253 6 43 001270 6 44 001273 6 45 001302 300 001305 304 001307 307 001312 308 001314 310 001317 312 001322 313 001324 314 001331 315 001335 317 001337 324 001342 325 001351 326 001355 328 001357 332 001362 333 001363 334 001371 335 001376 336 001402 337 001404 343 001405 349 001407 353 001415 354 001417 356 001422 357 001427 358 001435 359 001437 360 001445 362 001453 364 001455 365 001462 366 001464 367 001471 368 001475 370 001477 371 001501 376 001506 377 001507 378 001515 379 001522 380 001526 382 001530 386 001531 388 001532 389 001535 390 001540 393 001546 394 001550 395 001552 396 001553 397 001555 400 001563 401 001564 402 001573 403 001574 409 001575 410 001600 411 001603 412 001606 413 001610 414 001613 415 001615 448 001621 418 001622 433 001623 437 001635 439 001641 444 001647 445 001652 557 001653 561 001655 564 001660 567 001663 569 001666 570 001671 571 001673 572 001702 573 001705 574 001707 578 001711 579 001712 580 001717 581 001727 582 001735 583 001742 584 001744 ----------------------------------------------------------- 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