COMPILATION LISTING OF SEGMENT apl_arrow_operators_ Compiled by: Multics PL/I Compiler, Release 33e, of October 6, 1992 Compiled at: CGI Compiled on: 2000-05-04_1647.67_Thu_mdt 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_arrow_operators_: procedure; 11 12 /* 13* * apl_arrow_operators_ 14* * 15* * this module contains the 'take' and 'drop' operators for APL. 16* * 17* * fast vector case written 7/20/73 by DAM 18* * general case added 7/27/73 by DAM 19* * modified 73.9.26 by DAM to avoid bugs in size builtin 20* * (Note: this program should be rewritten to avoid the present excessive duplication of code.) 21* * Modified 770207 by PG to fix case(2) to set value_bead.data_pointer if right arg is on stack (bug 266). 22* * Modified 770222 by PG to fix case(3) so that overtaking of a numeric vector works (bug 268). 23* Modified 780209 by PG to use apl_push_stack_ (bug 278). 24* Modified 781118 by PG to fix bug 281 (overtaking a scalar failed because 25* result characters overwrote rho vector!) 26* */ 27 28 29 dcl result_vb pointer, /* -> value_bead for result */ 30 result pointer, /* -> value array for result */ 31 right_vb pointer, /* -> value_bead of right operand */ 32 right pointer, /* -> value array of right operand */ 33 rhorho fixed bin, /* rhorho of the result, also of the right operand */ 34 right_rho fixed bin(21), /* when right opnd is a vector, this is its length */ 35 left_vb pointer, /* -> value_bead for left operand */ 36 left pointer, /* -> value array for left operand */ 37 data_elements fixed bin(21); /* total_data_elements of the result, used by aggregate moves */ 38 39 dcl characters bit (1) aligned, /* "1"b if right opnd and result are character, 40* "0"b if they are numeric */ 41 numeric_data (data_elements) float aligned based, /* used for aggregate moves -- numeric_datum generates lousy code */ 42 fixnum fixed bin(21), /* random fixed-binary number, usually derives from left opnd */ 43 float_temp float; 44 45 dcl (apl_error_table_$rank, apl_error_table_$length, apl_error_table_$domain) fixed bin(35) external; 46 47 dcl i fixed bin; /* do-loop index (only) */ 48 dcl case fixed bin; 49 50 dcl character_string_overlay_right char(right_rho) aligned based, /* used for aggregate moves */ 51 numeric_datum_right (right_rho) aligned float based; /* .. */ 52 53 dcl special_character char(1) aligned, /* used by special scalar hacks as a buffer */ 54 special_number float aligned; /* .. */ 55 56 dcl (abs, addr, addrel, fixed, floor, rel, size, substr, string, unspec) builtin; 57 58 59 dcl take_not_drop bit(1) aligned, /* "1"b => take operator, "0"b => drop operator (entry switch) */ 60 n_words fixed bin(19), /* number of words to push on stack */ 61 Some_Words (n_words) bit(36) aligned based; /* used to move value bead header */ 62 63 64 /* declarations for the general case (loop algorithm instead of EIS algorithm) */ 65 66 dcl cur_in_pos fixed bin(21), /* current position in input operand */ 67 cur_out_pos fixed bin(21), /* current position in result */ 68 cur_rho fixed bin, /* current dimension being worked on: index into orders */ 69 orders_ptr pointer, 70 71 1 orders(rhorho) aligned based(orders_ptr), /* this stuff controls execution of the general case */ 72 2 pre_skip_or_pad fixed bin(21), /* -=skip this many from input, +=pad this many of output */ 73 2 take_amount fixed bin(21), /* then take this many from next dimension or data if last */ 74 2 post_skip_or_pad fixed bin(21), /* then skip this many or pad as above */ 75 2 repeat_count fixed bin(21), /* number of times left to do this dimension */ 76 2 rho fixed bin (21); /* rho of result */ 77 78 79 dcl padskip fixed bin(21), /* -=skip, +=pad on this dimension, has to be multiplied 80* by times reduction of rhos to the right. */ 81 prodp pointer, /* -> value bead whose rho has to get times-reduced */ 82 pre_not_post bit(1), /* "1"b pre-pad or skip, "0"b post-pad or skip */ 83 take_amt fixed bin(21), /* number of things to take on this dimension */ 84 j fixed bin; 85 86 /* bunch of stupid declarations needed because PL/I does not allow substr on arrays as well as strings */ 87 88 dcl numeric_data_for_take(orders(cur_rho).take_amount) float aligned based, 89 numeric_data_for_pre_pad(orders(cur_rho).pre_skip_or_pad) float aligned based, 90 numeric_data_for_post_pad(orders(cur_rho).post_skip_or_pad) float aligned based; 91 92 /* include files */ 93 1 1 /* ====== BEGIN INCLUDE SEGMENT apl_number_data.incl.pl1 ================================== */ 1 2 1 3 /* 1 4* This include file contains information about the machine representation of numbers. 1 5* In all programs numbers should simply be declared 'float'. 1 6* All default statements should be in this include file. 1 7* 1 8* This is the binary version. The manifest constant Binary should be used by programs 1 9* that need to know whether we are using binary or decimal. 1 10* */ 1 11 1 12 /* format: style3,initlm0,idind30 */ 1 13 1 14 default (float & ^decimal & ^binary & ^precision & ^constant) float binary (63); 1 15 1 16 declare ( 1 17 TheBiggestNumberWeveGot float initial (0.1701411834604692317e+39), 1 18 TheSmallestNumberWeveGot float initial (.1469367938527859385e-38), 1 19 Binary bit (1) aligned initial ("1"b) 1 20 ) internal static options (constant); 1 21 1 22 /* Number of characters in a number datum entry; used for copying float number arrays as strings. 1 23* (Obsolete! use array copies!) */ 1 24 1 25 declare NumberSize fixed binary precision (4) internal static initial (8); 1 26 1 27 /* ------ END INCLUDE SEGMENT apl_number_data.incl.pl1 ---------------------------------- */ 94 2 1 /* ====== BEGIN INCLUDE 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 ---------------------------------- */ 95 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 ----------------------------------- */ 96 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 --------------------------- */ 97 5 1 /* ====== BEGIN INCLUDE SEGMENT apl_ws_info.incl.pl1 ====================================== */ 5 2 5 3 /* This structure contains all of the global data (or pointers to it) for the APL subsystem */ 5 4 5 5 /* automatic */ 5 6 5 7 declare ws_info_ptr ptr initial (apl_static_$ws_info_ptr.static_ws_info_ptr); 5 8 5 9 /* external static */ 5 10 5 11 declare 1 apl_static_$ws_info_ptr external static aligned structure, 5 12 2 static_ws_info_ptr unaligned pointer; 5 13 5 14 /* based */ 5 15 5 16 declare 1 ws_info aligned based (ws_info_ptr), 5 17 2 version_number fixed bin, /* version of this structure (3) */ 5 18 2 switches unaligned, /* mainly ws parameters */ 5 19 3 long_error_mode bit, /* if 1, long Multics format, else APL/360 format */ 5 20 3 debug_mode bit, /* if 1, system error causes escape to command level */ 5 21 3 canonicalize_mode bit, /* if 1, the editor canonicalizes user input */ 5 22 3 restrict_exec_command bit, /* if 1, the )EXEC command may not be used */ 5 23 3 restrict_debug_command bit, /* if 1, the )DEBUG command may not be used */ 5 24 3 restrict_external_functions 5 25 bit, /* if 1, the )ZFN, )MFN, and )DFN commands may not be used */ 5 26 3 restrict_load bit, /* if 1, the )LOAD and )COPY commands may not be used */ 5 27 3 restrict_load_directory bit, /* if 1, no directory allowed in )LOAD or )COPY pathnames */ 5 28 3 restrict_save bit, /* if 1, the )SAVE command may not be used */ 5 29 3 restrict_save_directory bit, /* if 1, no directory allowed in )SAVE pathnames */ 5 30 3 off_hold bit, /* if 1, )OFF HOLD was typed, else just )OFF */ 5 31 3 transparent_to_signals bit, /* if 1, any conditions slip right past APL */ 5 32 3 meter_mode bit, /* if 1, metering may be done, else speed is all-important */ 5 33 3 restrict_msg_command bit, /* if 1, the )MSG command may not be used. */ 5 34 3 compatibility_check_mode 5 35 bit, /* if 1, check for incompatible operators */ 5 36 3 no_quit_handler bit, /* if 1, do not trap QUITs. */ 5 37 /* remaining 20 bits not presently used */ 5 38 5 39 2 values, /* attributes of the workspace */ 5 40 3 digits fixed bin, /* number of digits of precision printed on output */ 5 41 3 width fixed bin, /* line length for formatted output */ 5 42 3 index_origin fixed bin, /* the index origin (0 or 1) */ 5 43 3 random_link fixed bin(35), /* seed for random number generator */ 5 44 3 fuzz float, /* comparison tolerance (relative fuzz) */ 5 45 3 float_index_origin float, /* the index origin in floating point */ 5 46 3 number_of_symbols fixed bin, /* the number of symbol_beads currently in existence */ 5 47 3 maximum_value_stack_size 5 48 fixed bin (18), /* maximum number of words in one segment of value stack */ 5 49 5 50 2 pointers, /* pointers to various internal tables */ 5 51 3 symbol_table_ptr unaligned pointer, /* -> symbol_table (apl_symbol_table.incl.pl1) */ 5 52 3 current_parse_frame_ptr unaligned pointer, /* -> topmost parse frame */ 5 53 3 value_stack_ptr unaligned pointer, /* -> next free location on value stack */ 5 54 3 alloc_free_info_ptr unaligned pointer, /* -> apl_storage_mngr_ data (apl_storage_system_data.incl.pl1) */ 5 55 5 56 2 time_invoked fixed bin(71), /* clock time that APL was entered */ 5 57 2 integer_fuzz float, /* the absolute fuzz used in checking for integers */ 5 58 2 user_number fixed bin(35), /* number under which the user is signed on */ 5 59 2 latent_expression unaligned pointer, /* -> value_bead for QuadLX */ 5 60 2 lock char(32), /* the lock currently set on this workspace (password) */ 5 61 2 wsid char(100), /* the workspace identification: name, number name, or clear ws */ 5 62 2 last_error_code fixed bin(35), /* last code passed to apl_error_ */ 5 63 2 signoff_lock character (32), 5 64 5 65 2 interrupt_info aligned, /* bits used by apl_interpreter_ to tell when to abort */ 5 66 3 dont_interrupt_parse bit, /* if 1, don't do a dirty stop because the parser is running */ 5 67 3 dont_interrupt_operator bit, /* if 1, don't do a dirty stop because an operator is running */ 5 68 3 dont_interrupt_storage_manager /* if 1, don't stop because apl_storage_mngr_ is */ 5 69 bit, /* munging his tables */ 5 70 3 unused_interrupt_bit bit, /* not presently used */ 5 71 3 dont_interrupt_command bit, 5 72 3 can_be_interrupted bit, /* if 1, OK to do a clean stop (we are between lines, reading) */ 5 73 3 clean_interrupt_pending bit, /* interrupt occured, break cleanly (between lines) */ 5 74 3 dirty_interrupt_pending bit, /* interrupt occured, break as soon as not inhibited */ 5 75 5 76 2 user_name char (32), /* process group id of user */ 5 77 2 immediate_input_prompt char (32) varying, /* normal input */ 5 78 2 evaluated_input_prompt char (32) varying, /* quad input */ 5 79 2 character_input_prompt char (32) varying, /* quad-quote input */ 5 80 2 vcpu_time aligned, 5 81 3 total fixed bin (71), 5 82 3 setup fixed bin (71), 5 83 3 parse fixed bin (71), 5 84 3 lex fixed bin (71), 5 85 3 operator fixed bin (71), 5 86 3 storage_manager fixed bin (71), 5 87 2 output_info aligned, /* data pertaining to output buffer */ 5 88 3 output_buffer_ptr unal ptr, /* ptr to output buffer */ 5 89 3 output_buffer_len fixed bin (21), /* length (bytes) of output buffer */ 5 90 3 output_buffer_pos fixed bin (21), /* index of next byte to write in */ 5 91 3 output_buffer_ll fixed bin (21), /* print positions used up so far */ 5 92 2 tab_width fixed bin (21); /* number of columns a tabs moves cursor */ 5 93 5 94 declare output_buffer char (ws_info.output_buffer_len) based (ws_info.output_buffer_ptr); 5 95 5 96 /* internal static */ 5 97 5 98 declare max_parse_stack_depth fixed bin int static init(64536); 5 99 5 100 /* ------ END INCLUDE SEGMENT apl_ws_info.incl.pl1 -------------------------------------- */ 98 99 100 /* program */ 101 102 apl_take_: entry(operators_argument); 103 104 take_not_drop = "1"b; 105 go to join; 106 107 apl_drop_: entry(operators_argument); 108 109 take_not_drop = "0"b; 110 join: 111 112 113 /* pick up pointers to args, set variables in auto, and check types */ 114 115 116 left_vb = operands(1).value; 117 left = left_vb -> value_bead.data_pointer; 118 if left_vb -> value_bead.rhorho >= 2 119 then go to rank_error_left; /* left arg is vector (or scalar coerced to vector ) */ 120 121 right_vb = operands(2).value; 122 rhorho = right_vb -> value_bead.rhorho; 123 right = right_vb -> value_bead.data_pointer; 124 125 if right_vb -> value_bead.data_type.character_value then characters = "1"b; 126 else characters = "0"b; 127 128 if left_vb -> value_bead.data_type.numeric_value then; /* left arg must be number */ 129 else go to domain_error_left; 130 131 /* find which case it is */ 132 133 if left_vb -> value_bead.total_data_elements = 1 134 then if rhorho = 0 135 then case = 1; /* left scalar, right scalar */ 136 else if rhorho > 1 137 then go to length_error_left; /* right arg must be vector */ 138 else case = 2; 139 else if left_vb -> value_bead.total_data_elements ^= rhorho 140 then go to length_error_left; 141 else case = 3; /* left vector (general case) */ 142 143 go to arrow_op (case); /* dispatch */ 144 145 arrow_op (1): 146 /* case of vector, but right arg is scalar so coerce it to a vector */ 147 148 if operands(2).on_stack /* if not on stack, will work. but if on stack need room for rho */ 149 then if characters 150 then do; 151 special_character = right -> character_datum(0); 152 right = addr(special_character); 153 end; 154 else do; /* numeric scalar */ 155 special_number = right -> numeric_datum(0); 156 right = addr(special_number); 157 end; 158 159 /* pretend right arg was really a vector */ 160 161 /* vector case - left arg is of length 1 and right arg is vector or scalar 162* this is handled as a seperate case so that code can be used which compiles into 163* EIS instructions, making the vector case (most used) much faster than the general case */ 164 165 166 /* first get a copy of left arg as an integer in the variable 'fixnum' */ 167 168 arrow_op (2): 169 if left_vb -> value_bead.data_type.integral_value then fixnum = fixed(left -> numeric_datum(0)); 170 else do; 171 float_temp = floor(left -> numeric_datum(0) + 0.5); 172 if abs(float_temp - left -> numeric_datum(0)) > integer_fuzz 173 then go to domain_error_left; /* barf if not integer */ 174 if abs(float_temp) >= 1e21b then go to domain_error_left; 175 fixnum = fixed(float_temp, 21); 176 end; 177 178 /* compute size of result */ 179 180 right_rho = right_vb -> value_bead.total_data_elements; 181 data_elements = abs(fixnum); 182 if ^take_not_drop then do; 183 data_elements = right_rho - data_elements; /* ssq for drop */ 184 if data_elements < 0 then data_elements = 0; /* if dropping all, produce empty */ 185 end; 186 187 /* if left opnd is on stack, flush it now, leaving just right opnd or nothing */ 188 189 if operands(1).on_stack then value_stack_ptr = left_vb; 190 191 /* Allocate result value_bead. Result can overlay right operand. */ 192 193 if operators_argument.operands (2).on_stack /* right arg on stack */ 194 then ws_info.value_stack_ptr = right_vb; /* pop it & overlay */ 195 196 number_of_dimensions = 1; 197 n_words = size (value_bead); 198 if characters then n_words = n_words + size (character_string_overlay); 199 else n_words = n_words + size (numeric_datum) + 1; 200 result_vb = apl_push_stack_ (n_words); 201 string(result_vb -> value_bead.type) = string(right_vb -> value_bead.type); 202 result_vb -> value_bead.rhorho = number_of_dimensions; 203 result = addrel (result_vb, size (value_bead)); 204 if ^ characters then if substr(rel(result), 18, 1) then result = addrel(result, 1); 205 result_vb -> value_bead.data_pointer = result; 206 207 /* now set up rho of result -- since rho of right opnd is saved in right_rho, is OK to overlay */ 208 209 result_vb -> value_bead.rho(1) = data_elements; 210 result_vb -> value_bead.total_data_elements = data_elements; 211 if data_elements = 0 then go to exit; /* there is nothing to move in */ 212 213 /* now do the actual operation for take or drop in the scalar,vector case */ 214 215 if fixnum > 0 216 then if take_not_drop /* TAKE */ 217 then if result ^= right /* not overlay, must move data in */ 218 then if characters 219 then result -> character_string_overlay = right -> character_string_overlay_right; 220 /* truncates or pads automatically */ 221 else if data_elements <= right_rho 222 then result -> numeric_data(*) = right -> numeric_data(*); /* move & truncate */ 223 else do; 224 if right_rho > 0 then /* avoid EIS bug */ 225 result -> numeric_datum_right(*) = right -> numeric_datum_right(*); /* move... */ 226 pos_take_num_pad: do i = right_rho by 1 while (i <= data_elements); /* then pad */ 227 result -> numeric_datum(i) = 0e0; 228 end; 229 end; 230 else if data_elements > right_rho /* overlaying, the data is already there so just pad if necc. */ 231 then if characters 232 then substr(result -> character_string_overlay, right_rho+1, data_elements-right_rho) = ""; 233 else go to pos_take_num_pad; 234 else; 235 236 else /* DROP */ 237 if characters then result -> character_string_overlay = 238 substr(right -> character_string_overlay_right, fixnum+1, right_rho-fixnum); 239 else result -> numeric_data(*) = 240 addr(right -> numeric_datum(fixnum)) -> numeric_data(*); 241 242 243 else /* fixnum < 0 */ 244 if take_not_drop /* TAKE */ 245 then if -fixnum <= right_rho /* if no padding required */ 246 then if characters 247 then result -> character_string_overlay = 248 substr(right -> character_string_overlay_right, right_rho+fixnum+1, data_elements); 249 else result -> numeric_data(*) = 250 addr(right -> numeric_datum(right_rho+fixnum)) -> numeric_data(*); 251 else /* padding required - is MRL so use do loop to move */ 252 if characters then do; 253 do i = data_elements-1 by -1 to -fixnum-right_rho; /* move chars up to make room for pad */ 254 result -> character_datum(i) = right -> character_datum(i+fixnum+right_rho); 255 end; 256 substr(result -> character_string_overlay, 1, -fixnum-right_rho) = ""; /* then pad */ 257 end; 258 else do; 259 do i = data_elements-1 by -1 to -fixnum-right_rho; /* move numbers up to make room for pad */ 260 result -> numeric_datum(i) = right -> numeric_datum(i+fixnum+right_rho); 261 end; 262 do i = i by -1 to 0; 263 result -> numeric_datum(i) = 0e0; /* then pad */ 264 end; 265 end; 266 else /* DROP, with fixnum < 0 */ 267 if right_vb ^= result /* if not yet copied in, copy it in */ 268 then if characters then result -> character_string_overlay = right -> character_string_overlay; 269 else result -> numeric_data(*) = right -> numeric_data(*); 270 else; /* already copied in, just mung vb. but that's already been done */ 271 272 go to exit; 273 274 275 /* 276* * left opnd has more than one element, this is the general (array) case 277* */ 278 arrow_op (3): 279 280 /* allocate space for array of orders to be executed later, 281* and for result value_bead header */ 282 283 n_words = size (orders); 284 orders_ptr = apl_push_stack_ (n_words); 285 286 /* fill orders from left operand */ 287 288 do i = rhorho by -1 while (i > 0); 289 if left_vb -> value_bead.integral_value then float_temp = left -> numeric_datum(i-1); 290 else do; 291 float_temp = floor(left -> numeric_datum(i-1) + 0.5); 292 if abs(float_temp - left -> numeric_datum(i-1)) > integer_fuzz then go to domain_error_left; /* check for integer */ 293 end; 294 if abs(float_temp) >= 1e21b then go to domain_error_left; 295 fixnum = fixed(float_temp, 21); 296 297 if take_not_drop 298 then do; 299 if fixnum >= 0 300 then do; 301 pre_not_post = "0"b; 302 padskip = fixnum - right_vb -> value_bead.rho(i); /* - => skip, + => pad */ 303 if padskip <= 0 then take_amt = fixnum; 304 else take_amt = right_vb -> value_bead.rho(i); 305 end; 306 else do; /* fixnum < 0 */ 307 pre_not_post = "1"b; 308 padskip = -fixnum - right_vb -> value_bead.rho(i); /* - => skip, + => pad */ 309 if padskip < 0 then take_amt = -fixnum; 310 else take_amt = right_vb -> value_bead.rho(i); 311 end; 312 313 314 orders(i).take_amount = take_amt; 315 orders (i).rho = abs (fixnum); 316 end; 317 318 else do; /* DROP */ 319 /* padskip = -min(abs(fixnum), right_vb -> value_bead.rho(i)); */ 320 /* - => skip, amount to be dropped but not more than there is */ 321 322 323 /* due to bad code, the following statement is substituted instead */ 324 325 if abs(fixnum) < right_vb -> value_bead.rho(i) then padskip = -abs(fixnum); 326 else padskip = - right_vb -> value_bead.rho(i); 327 328 329 take_amt = right_vb -> value_bead.rho(i) + padskip; 330 pre_not_post = (fixnum >= 0); 331 332 orders (i).rho, orders (i).take_amount = take_amt; 333 end; 334 335 336 if padskip < 0 /* compute amount to pad or skip */ 337 then do j = i by 1 while (j < rhorho); 338 padskip = padskip * right_vb -> value_bead.rho(j+1); 339 end; 340 else do j = i by 1 while (j < rhorho); 341 padskip = padskip * orders (j + 1).rho; 342 end; 343 344 if pre_not_post then do; 345 orders(i).pre_skip_or_pad = padskip; 346 orders(i).post_skip_or_pad = 0; 347 end; 348 else do; 349 orders(i).pre_skip_or_pad = 0; 350 orders(i).post_skip_or_pad = padskip; 351 end; 352 353 end; 354 355 /* now fill the rest of the result value bead header (rho was just computed) */ 356 357 data_elements = 1; 358 do j = 0 by 1 while (j < rhorho); 359 data_elements = data_elements * orders (j+1).rho; 360 end; 361 362 /* allocate space for the result value bead */ 363 364 number_of_dimensions = rhorho; 365 n_words = size (value_bead); 366 367 if characters 368 then n_words = n_words + size (character_string_overlay); 369 else n_words = n_words + size (numeric_datum) + 1; 370 result_vb = apl_push_stack_ (n_words); 371 372 string(result_vb -> value_bead.type) = string(right_vb -> value_bead.type); 373 result_vb -> value_bead.rhorho = rhorho; 374 result_vb -> value_bead.total_data_elements = data_elements; 375 do j = 0 by 1 while (j < rhorho); 376 result_vb -> value_bead.rho (j + 1) = orders (j + 1).rho; 377 end; 378 379 result = addrel (result_vb, size (value_bead)); 380 if ^characters 381 then if substr (rel (result), 18, 1) 382 then result = addrel (result, 1); 383 384 result_vb -> value_bead.data_pointer = result; 385 386 /* proceed to compute the result by following the orders */ 387 388 cur_in_pos, cur_out_pos = 0; 389 cur_rho = 1; 390 orders(1).repeat_count = 1; 391 enter_new_rho: 392 continue_this_rho: 393 394 /* do any pre padding or skipping */ 395 396 if orders(cur_rho).pre_skip_or_pad < 0 then cur_in_pos = cur_in_pos + 397 (-orders(cur_rho).pre_skip_or_pad); 398 else if orders(cur_rho).pre_skip_or_pad > 0 then do; 399 if characters then 400 substr(result -> character_string_overlay, cur_out_pos + 1, orders(cur_rho).pre_skip_or_pad) = ""; 401 /* else addr(result -> numeric_datum(cur_out_pos)) -> numeric_data_for_pre_pad = 0.0e0; */ 402 403 /* due to poor code for the preceding statement, the following has been substitued */ 404 405 else do j = 0 by 1 while (j < orders(cur_rho).pre_skip_or_pad); 406 result -> numeric_datum(cur_out_pos + j) = 0.0e0; 407 end; 408 409 cur_out_pos = cur_out_pos + orders(cur_rho).pre_skip_or_pad; 410 end; 411 412 /* take */ 413 414 if cur_rho = rhorho 415 then do; 416 if characters 417 then substr(result -> character_string_overlay, cur_out_pos+1, orders(cur_rho).take_amount) = 418 substr(right -> character_string_overlay, cur_in_pos+1, orders(cur_rho).take_amount); 419 else addr(result -> numeric_datum(cur_out_pos)) -> numeric_data_for_take = 420 addr(right -> numeric_datum(cur_in_pos)) -> numeric_data_for_take; 421 cur_out_pos = cur_out_pos + orders(cur_rho).take_amount; 422 cur_in_pos = cur_in_pos + orders(cur_rho).take_amount; 423 end; 424 425 else do; /* take from next dimension to the right */ 426 cur_rho = cur_rho + 1; 427 orders(cur_rho).repeat_count = orders(cur_rho-1).take_amount; 428 go to enter_new_rho; 429 end; 430 431 leave_old_rho: 432 /* do any post padding or skipping */ 433 434 if orders(cur_rho).post_skip_or_pad < 0 435 then cur_in_pos = cur_in_pos + (-orders(cur_rho).post_skip_or_pad); 436 else if orders(cur_rho).post_skip_or_pad > 0 437 then do; 438 if characters 439 then substr (result -> character_string_overlay, cur_out_pos + 1, orders(cur_rho).post_skip_or_pad) = ""; 440 /* else addr(result -> numeric_datum(cur_out_pos)) -> numeric_data_for_post_pad = 0.0e0; */ 441 442 /* due to poor code generated for the preceding statement, the following has been substituted */ 443 444 else do j = 0 by 1 while (j < orders(cur_rho).post_skip_or_pad); 445 result -> numeric_datum(cur_out_pos + j) = 0.0e0; 446 end; 447 448 cur_out_pos = cur_out_pos + orders(cur_rho).post_skip_or_pad; 449 end; 450 451 orders(cur_rho).repeat_count = orders(cur_rho).repeat_count - 1; 452 if orders(cur_rho).repeat_count > 0 then go to continue_this_rho; 453 454 /* done with this rho, move left to preceding one */ 455 456 cur_rho = cur_rho-1; 457 if cur_rho ^= 0 then go to leave_old_rho; 458 459 /* all done, move result down */ 460 461 if operands(2).on_stack then value_stack_ptr = right_vb; 462 else if operands(1).on_stack then value_stack_ptr = left_vb; 463 else value_stack_ptr = orders_ptr; 464 465 number_of_dimensions = rhorho; 466 n_words = size (value_bead); 467 if characters then n_words = n_words + size(character_string_overlay); 468 else n_words = n_words + (1+size(numeric_data)); 469 left_vb = apl_push_stack_ (n_words); /* result = old posn on stack, left = new posn on stack */ 470 471 number_of_dimensions = rhorho; 472 n_words = size (value_bead); /* move bead header with overlay */ 473 left_vb -> Some_Words = result_vb -> Some_Words; 474 475 left = addr(left_vb -> value_bead.rho(rhorho+1)); /* set up address of data */ 476 if ^ characters then if substr(rel(left), 18, 1) then left = addrel(left, 1); 477 left_vb -> value_bead.data_pointer = left; 478 if characters then left -> character_string_overlay = result -> character_string_overlay; 479 else left -> numeric_data = result -> numeric_data; 480 481 operators_argument.result = left_vb; 482 return; 483 484 /**** come here to depart ****/ 485 486 exit: 487 operators_argument.result = result_vb; 488 return; 489 490 491 492 493 /**** errors *****/ 494 495 rank_error_left: 496 operators_argument.error_code = apl_error_table_$rank; 497 go to signal_error; 498 499 domain_error_left: 500 operators_argument.error_code = apl_error_table_$domain; 501 go to signal_error; 502 503 length_error_left: 504 operators_argument.error_code = apl_error_table_$length; 505 go to signal_error; 506 507 signal_error: 508 operators_argument.where_error = operators_argument.where_error + 1; 509 return; 510 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 ------------------------------- */ 511 512 end; SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 05/04/00 1647.6 apl_arrow_operators_.pl1 >udd>sm>ds>w>ml>apl_arrow_operators_.pl1 94 1 03/27/82 0529.8 apl_number_data.incl.pl1 >ldd>incl>apl_number_data.incl.pl1 95 2 03/27/82 0538.5 apl_bead_format.incl.pl1 >ldd>incl>apl_bead_format.incl.pl1 96 3 03/27/82 0539.2 apl_value_bead.incl.pl1 >ldd>incl>apl_value_bead.incl.pl1 97 4 03/27/82 0539.0 apl_operators_argument.incl.pl1 >ldd>incl>apl_operators_argument.incl.pl1 98 5 03/27/82 0539.2 apl_ws_info.incl.pl1 >ldd>incl>apl_ws_info.incl.pl1 511 6 03/27/82 0529.8 apl_push_stack_fcn.incl.pl1 >ldd>incl>apl_push_stack_fcn.incl.pl1 NAMES DECLARED IN THIS COMPILATION. IDENTIFIER OFFSET LOC STORAGE CLASS DATA TYPE ATTRIBUTES AND REFERENCES (* indicates a set context) NAMES DECLARED BY DECLARE STATEMENT. P_n_words parameter fixed bin(19,0) dcl 6-16 ref 6-4 6-35 Some_Words based bit(36) array dcl 59 set ref 473* 473 abs builtin function dcl 56 ref 172 174 181 292 294 315 325 325 addr builtin function dcl 56 ref 152 156 239 249 419 419 475 addrel builtin function dcl 56 in procedure "apl_arrow_operators_" ref 203 204 379 380 476 addrel builtin function dcl 6-25 in procedure "apl_push_stack_" ref 6-44 apl_error_table_$domain 000014 external static fixed bin(35,0) dcl 45 ref 499 apl_error_table_$length 000012 external static fixed bin(35,0) dcl 45 ref 503 apl_error_table_$rank 000010 external static fixed bin(35,0) dcl 45 ref 495 apl_get_value_stack_ 000020 constant entry external dcl 6-30 ref 6-40 apl_static_$ws_info_ptr 000016 external static structure level 1 dcl 5-11 binary builtin function dcl 6-25 ref 6-40 block_ptr 000162 automatic pointer dcl 6-20 set ref 6-43* 6-45 case 000125 automatic fixed bin(17,0) dcl 48 set ref 133* 138* 141* 143 character_data_structure based structure level 1 dcl 3-15 character_datum based char(1) array level 2 packed packed unaligned dcl 3-15 set ref 151 254* 254 character_string_overlay based char dcl 3-19 set ref 198 215* 230* 236* 243* 256* 266* 266 367 399* 416* 416 438* 467 478* 478 character_string_overlay_right based char dcl 50 ref 215 236 243 character_value 0(09) based bit(1) level 5 packed packed unaligned dcl 3-3 set ref 125 characters 000117 automatic bit(1) dcl 39 set ref 125* 126* 145 198 204 215 230 236 243 251 266 367 380 399 416 438 467 476 478 cur_in_pos 000134 automatic fixed bin(21,0) dcl 66 set ref 388* 391* 391 416 419 422* 422 431* 431 cur_out_pos 000135 automatic fixed bin(21,0) dcl 66 set ref 388* 399 406 409* 409 416 419 421* 421 438 445 448* 448 cur_rho 000136 automatic fixed bin(17,0) dcl 66 set ref 389* 391 391 398 399 405 409 414 416 416 419 421 422 426* 426 427 427 431 431 436 438 444 448 451 451 452 456* 456 457 data_elements 000116 automatic fixed bin(21,0) dcl 29 set ref 181* 183* 183 184 184* 198 198 199 209 210 211 215 221 221 226 230 230 230 236 239 243 243 249 253 256 259 266 266 269 357* 359* 359 367 367 369 374 399 416 416 438 467 467 468 478 478 479 data_pointer 4 based pointer level 2 packed packed unaligned dcl 3-3 set ref 117 123 205* 384* 477* data_type 0(08) based structure level 4 packed packed unaligned dcl 3-3 error_code 7 parameter fixed bin(35,0) level 2 dcl 4-3 set ref 495* 499* 503* fixed builtin function dcl 56 ref 168 175 295 fixnum 000120 automatic fixed bin(21,0) dcl 39 set ref 168* 175* 181 215 236 236 239 243 243 249 253 254 256 259 260 295* 299 302 303 308 309 315 325 325 330 float_temp 000122 automatic float bin(63) dcl 39 set ref 171* 172 174 175 289* 291* 292 294 295 floor builtin function dcl 56 ref 171 291 general_bead based structure level 1 dcl 2-3 header based structure level 2 dcl 3-3 i 000124 automatic fixed bin(17,0) dcl 47 set ref 226* 226* 227* 253* 254 254* 259* 260 260* 262* 262* 263* 288* 288* 289 291 292 302 304 308 310 314 315 325 326 329 332 332 336 340 345 346 349 350* integer_fuzz 22 based float bin(63) level 2 dcl 5-16 ref 172 292 integral_value 0(11) based bit(1) level 5 packed packed unaligned dcl 3-3 set ref 168 289 j 000145 automatic fixed bin(17,0) dcl 79 set ref 336* 336* 338* 340* 340* 341* 358* 358* 359* 375* 375* 376 376* 405* 405* 406* 444* 444* 445* left 000114 automatic pointer dcl 29 set ref 117* 168 171 172 289 291 292 475* 476 476* 476 477 478 479 left_vb 000112 automatic pointer dcl 29 set ref 110* 117 118 128 133 139 168 189 289 462 469* 473 475 477 481 maximum_value_stack_size 13 based fixed bin(18,0) level 3 dcl 5-16 ref 6-40 n_words 000133 automatic fixed bin(19,0) dcl 59 set ref 197* 198* 198 199* 199 200* 278* 284* 365* 367* 367 369* 369 370* 466* 467* 467 468* 468 469* 472* 473 num_words 000164 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 000146 automatic fixed bin(17,0) dcl 3-3 set ref 196* 197 202 203 364* 365 379 465* 466 471* 472 numeric_data based float bin(63) array dcl 39 set ref 221* 221 239* 239 249* 249 269* 269 468 479* 479 numeric_data_for_take based float bin(63) array dcl 88 set ref 419* 419 numeric_datum based float bin(63) array dcl 3-23 set ref 155 168 171 172 199 227* 239 249 260* 260 263* 289 291 292 369 406* 419 419 445* numeric_datum_right based float bin(63) array dcl 50 set ref 224* 224 numeric_value 0(10) based bit(1) level 5 packed packed unaligned dcl 3-3 set ref 128 on_stack 1 parameter bit(1) array level 3 dcl 4-3 ref 145 189 193 461 462 operands parameter structure array level 2 dcl 4-3 operators_argument parameter structure level 1 dcl 4-3 set ref 102 107 orders based structure array level 1 dcl 66 set ref 278 orders_ptr 000140 automatic pointer dcl 66 set ref 278 284* 314 315 332 332 341 345 346 349 350 359 376 390 391 391 398 399 405 409 416 416 419 421 422 427 427 431 431 436 438 444 448 451 451 452 463 padskip 000142 automatic fixed bin(21,0) dcl 79 set ref 302* 303 308* 309 325* 326* 329 336 338* 338 341* 341 345 350 pointers 14 based structure level 2 dcl 5-16 post_skip_or_pad 2 based fixed bin(21,0) array level 2 dcl 66 set ref 346* 350* 431 431 436 438 444 448 pre_not_post 000143 automatic bit(1) packed unaligned dcl 79 set ref 301* 307* 330* 344 pre_skip_or_pad based fixed bin(21,0) array level 2 dcl 66 set ref 345* 349* 391 391 398 399 405 409 rel builtin function dcl 56 in procedure "apl_arrow_operators_" ref 204 380 476 rel builtin function dcl 6-25 in procedure "apl_push_stack_" ref 6-40 repeat_count 3 based fixed bin(21,0) array level 2 dcl 66 set ref 390* 427* 451* 451 452 result 6 parameter pointer level 2 in structure "operators_argument" packed packed unaligned dcl 4-3 in procedure "apl_arrow_operators_" set ref 481* 486* result 000102 automatic pointer dcl 29 in procedure "apl_arrow_operators_" set ref 203* 204 204* 204 205 215 215 221 224 227 230 236 239 243 249 254 256 260 263 266 266 269 379* 380 380* 380 384 399 406 416 419 438 445 478 479 result_vb 000100 automatic pointer dcl 29 set ref 200* 201 202 203 205 209 210 370* 372 373 374 376 379 384 473 486 rho 5 based fixed bin(21,0) array level 2 in structure "value_bead" dcl 3-3 in procedure "apl_arrow_operators_" set ref 209* 302 304 308 310 325 326 329 338 376* 475 rho 4 based fixed bin(21,0) array level 2 in structure "orders" dcl 66 in procedure "apl_arrow_operators_" set ref 315* 332* 341 359 376 rhorho 000110 automatic fixed bin(17,0) dcl 29 in procedure "apl_arrow_operators_" set ref 122* 133 136 139 278 288 336 340 358 364 373 375 414 465 471 475 rhorho 3 based fixed bin(17,0) level 2 in structure "value_bead" dcl 3-3 in procedure "apl_arrow_operators_" set ref 118 122 202* 373* right 000106 automatic pointer dcl 29 set ref 123* 151 152* 155 156* 215 215 221 224 236 239 243 249 254 260 266 269 416 419 right_rho 000111 automatic fixed bin(21,0) dcl 29 set ref 180* 183 215 221 224 224 226 230 230 230 236 236 243 243 243 249 253 254 256 259 260 right_vb 000104 automatic pointer dcl 29 set ref 121* 122 123 125 180 193 201 266 302 304 308 310 325 326 329 338 372 461 size builtin function dcl 56 ref 197 198 199 203 278 365 367 369 379 466 467 468 472 special_character 000126 automatic char(1) dcl 53 set ref 151* 152 special_number 000130 automatic float bin(63) dcl 53 set ref 155* 156 static_ws_info_ptr 000016 external static pointer level 2 packed packed unaligned dcl 5-11 ref 5-7 string builtin function dcl 56 set ref 201* 201 372* 372 substr builtin function dcl 56 in procedure "apl_arrow_operators_" set ref 204 230* 236 243 256* 380 399* 416* 416 438* 476 substr builtin function dcl 6-25 in procedure "apl_push_stack_" ref 6-37 take_amount 1 based fixed bin(21,0) array level 2 dcl 66 set ref 314* 332* 416 416 419 421 422 427 take_amt 000144 automatic fixed bin(21,0) dcl 79 set ref 303* 304* 309* 310* 314 329* 332 take_not_drop 000132 automatic bit(1) dcl 59 set ref 104* 109* 182 215 243 297 total_data_elements 2 based fixed bin(21,0) level 2 dcl 3-3 set ref 133 139 180 210* 374* type based structure level 3 packed packed unaligned dcl 3-3 set ref 201* 201 372* 372 unspec builtin function dcl 6-25 ref 6-37 value parameter pointer array level 3 packed packed unaligned dcl 4-3 ref 110 121 value_bead based structure level 1 dcl 3-3 set ref 197 203 365 379 466 472 value_stack_ptr 16 based pointer level 3 packed packed unaligned dcl 5-16 set ref 189* 193* 461* 462* 463* 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 507* 507 ws_info based structure level 1 dcl 5-16 ws_info_ptr 000150 automatic pointer initial dcl 5-7 set ref 172 189 193 292 461 462 463 5-7* 6-40 6-40 6-43 6-44 6-44 NAMES DECLARED BY DECLARE STATEMENT AND NEVER REFERENCED. Binary internal static bit(1) initial dcl 1-16 MAX_VALUE_BEAD_SIZE internal static fixed bin(19,0) initial dcl 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 character_value_type internal static bit(18) initial packed unaligned dcl 2-30 complex_datum based complex float bin(63) array dcl 3-26 complex_value_type internal static bit(18) initial packed unaligned dcl 2-30 function_type internal static bit(18) initial packed unaligned dcl 2-30 group_type internal static bit(18) initial packed unaligned dcl 2-30 integral_value_type internal static bit(18) initial packed unaligned dcl 2-30 label_type internal static bit(18) initial packed unaligned dcl 2-30 lexed_function_type internal static bit(18) initial packed unaligned dcl 2-30 list_value_type internal static bit(18) initial packed 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 packed unaligned dcl 2-30 not_zero_or_one_mask internal static bit(18) initial packed unaligned dcl 2-30 numeric_data_for_post_pad based float bin(63) array dcl 88 numeric_data_for_pre_pad based float bin(63) array dcl 88 numeric_value_type internal static bit(18) initial packed unaligned dcl 2-30 operator_type internal static bit(18) initial packed unaligned dcl 2-30 output_buffer based char packed unaligned dcl 5-94 prodp automatic pointer dcl 79 shared_variable_type internal static bit(18) initial packed unaligned dcl 2-30 symbol_type internal static bit(18) initial packed unaligned dcl 2-30 unspec builtin function dcl 56 value_type internal static bit(18) initial packed unaligned dcl 2-30 zero_or_one_value_type internal static bit(18) initial packed unaligned dcl 2-30 NAMES DECLARED BY EXPLICIT CONTEXT. apl_arrow_operators_ 000044 constant entry external dcl 10 apl_drop_ 000071 constant entry external dcl 107 apl_push_stack_ 001552 constant entry internal dcl 6-4 ref 200 284 370 469 apl_take_ 000056 constant entry external dcl 102 arrow_op 000000 constant label array(3) dcl 145 ref 143 continue_this_rho 001175 constant label dcl 391 ref 452 domain_error_left 001534 constant label dcl 499 ref 128 172 174 292 294 enter_new_rho 001175 constant label dcl 391 ref 428 exit 001522 constant label dcl 486 ref 211 272 join 000100 constant label dcl 110 ref 105 leave_old_rho 001325 constant label dcl 431 ref 457 length_error_left 001542 constant label dcl 503 set ref 136 139 pos_take_num_pad 000374 constant label dcl 226 ref 230 rank_error_left 001527 constant label dcl 495 ref 118 signal_error 001547 constant label dcl 507 set ref 497 501 505 THERE WERE NO NAMES DECLARED BY CONTEXT OR IMPLICATION. STORAGE REQUIREMENTS FOR THIS PROGRAM. Object Text Link Symbol Defs Static Start 0 0 1752 1774 1640 1762 Length 2272 1640 22 262 111 0 BLOCK NAME STACK SIZE TYPE WHY NONQUICK/WHO SHARES STACK FRAME apl_arrow_operators_ 130 external procedure is an external procedure. apl_push_stack_ internal procedure shares stack frame of external procedure apl_arrow_operators_. STORAGE FOR AUTOMATIC VARIABLES. STACK FRAME LOC IDENTIFIER BLOCK NAME apl_arrow_operators_ 000100 result_vb apl_arrow_operators_ 000102 result apl_arrow_operators_ 000104 right_vb apl_arrow_operators_ 000106 right apl_arrow_operators_ 000110 rhorho apl_arrow_operators_ 000111 right_rho apl_arrow_operators_ 000112 left_vb apl_arrow_operators_ 000114 left apl_arrow_operators_ 000116 data_elements apl_arrow_operators_ 000117 characters apl_arrow_operators_ 000120 fixnum apl_arrow_operators_ 000122 float_temp apl_arrow_operators_ 000124 i apl_arrow_operators_ 000125 case apl_arrow_operators_ 000126 special_character apl_arrow_operators_ 000130 special_number apl_arrow_operators_ 000132 take_not_drop apl_arrow_operators_ 000133 n_words apl_arrow_operators_ 000134 cur_in_pos apl_arrow_operators_ 000135 cur_out_pos apl_arrow_operators_ 000136 cur_rho apl_arrow_operators_ 000140 orders_ptr apl_arrow_operators_ 000142 padskip apl_arrow_operators_ 000143 pre_not_post apl_arrow_operators_ 000144 take_amt apl_arrow_operators_ 000145 j apl_arrow_operators_ 000146 number_of_dimensions apl_arrow_operators_ 000150 ws_info_ptr apl_arrow_operators_ 000162 block_ptr apl_push_stack_ 000164 num_words apl_push_stack_ THE FOLLOWING EXTERNAL OPERATORS ARE USED BY THIS PROGRAM. r_ge_a call_ext_out return_mac 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_$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 5 7 000036 10 000043 102 000052 104 000064 105 000066 107 000067 109 000077 110 000100 117 000103 118 000105 121 000110 122 000113 123 000115 125 000117 126 000125 128 000126 133 000131 136 000142 138 000144 139 000147 141 000151 143 000153 145 000154 151 000162 152 000165 153 000167 155 000170 156 000172 168 000174 171 000203 172 000207 174 000215 175 000224 180 000227 181 000232 182 000237 183 000241 184 000243 189 000246 193 000254 196 000262 197 000264 198 000266 199 000275 200 000302 201 000304 202 000307 203 000312 204 000316 205 000326 209 000327 210 000331 211 000332 215 000333 221 000354 224 000365 226 000374 227 000401 228 000405 229 000407 230 000410 234 000422 236 000423 239 000442 243 000453 249 000473 251 000506 253 000510 254 000521 255 000531 256 000534 257 000542 259 000543 260 000553 261 000563 262 000566 263 000572 264 000576 265 000601 266 000602 269 000616 272 000624 278 000625 284 000630 288 000632 289 000636 291 000646 292 000655 294 000663 295 000672 297 000675 299 000677 301 000701 302 000702 303 000706 304 000712 305 000714 307 000715 308 000717 309 000724 310 000730 314 000732 315 000740 316 000745 325 000746 326 000762 329 000764 330 000766 332 000771 336 001002 338 001011 339 001016 340 001021 341 001027 342 001035 344 001037 345 001041 346 001047 347 001050 349 001051 350 001055 353 001060 357 001063 358 001065 359 001071 360 001077 364 001101 365 001103 367 001105 369 001114 370 001121 372 001123 373 001126 374 001131 375 001133 376 001137 377 001145 379 001147 380 001154 384 001164 388 001166 389 001170 390 001172 391 001175 398 001207 399 001210 405 001220 406 001231 407 001236 409 001240 414 001244 416 001247 419 001266 421 001307 422 001314 423 001315 426 001316 427 001317 428 001324 431 001325 436 001337 438 001340 444 001350 445 001361 446 001366 448 001370 451 001374 452 001401 456 001403 457 001405 461 001407 462 001420 463 001427 465 001431 466 001433 467 001435 468 001444 469 001450 471 001452 472 001454 473 001456 475 001464 476 001467 477 001477 478 001500 479 001510 481 001516 482 001521 486 001522 488 001526 495 001527 497 001533 499 001534 501 001541 503 001542 505 001546 507 001547 509 001551 6 4 001552 6 35 001554 6 37 001556 6 40 001563 6 43 001600 6 44 001603 6 45 001612 ----------------------------------------------------------- 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