COMPILATION LISTING OF SEGMENT apl_compression_ Compiled by: Multics PL/I Compiler, Release 28d, of October 4, 1983 Compiled at: Honeywell LCPD Phoenix, System M Compiled on: 11/29/83 1559.2 mst Tue Options: optimize map 1 /* ****************************************************** 2* * * 3* * * 4* * Copyright (c) 1972 by Massachusetts Institute of * 5* * Technology and Honeywell Information Systems, Inc. * 6* * * 7* * * 8* ****************************************************** */ 9 10 /* This module implements the two APL mixed operators compression and expansion. 11* 12* Created by Richard S. Lamson on an unknown date 13* Essentially completely recoded by G. Gordon Benedict on 11/17/73 to: 14* fix bugs in stack allocation and copy up code 15* fix a slight bug in algorithm 16* make more efficient. 17* Modified 770223 by PG to fix bug 192 (handling of 0\i0 and 1\i0). 18* Modified 770224 by PG to fix unnumbered bug whereby 19* operators_argument.result did not always get set if right arg 20* was on stack. Also fixed operators to extend scalar arg on 21* rhs. 22* Modified 770228 by PG to fix bug 272 (1 0\4 fails...770224 change 23* wasn't quite right), and bug 274 (operations on characters set 24* value_stack_ptr one word too high). 25* Modified 790308 by William M. York to double-word align all value beads. 26* Modified 800226 by BIM and PG for bug 445 (0\'X' should be '/b'). 27* Modified 800226 by PG to fix 454 (expand and compress failed if qCT=0). We should never 28* have used qCT here, anyway, so I changed it to use the qIT (with the new algorithm, 29* to avoid bug 358). 30**/ 31 32 /* format: style3 */ 33 apl_compression_: 34 procedure (operators_argument); 35 36 internal_op_code = compression; 37 go to joined_code; 38 39 apl_expansion_: 40 entry (operators_argument); 41 42 internal_op_code = expansion; 43 44 joined_code: 45 integer_fuzz = ws_info.integer_fuzz; 46 47 right_vb = operators_argument.operands (2).value; 48 if right_vb -> value_bead.numeric_value 49 then do; 50 copy_zero = copy_zero_num (internal_op_code); 51 copy_one = copy_one_num (internal_op_code); 52 end; 53 else if right_vb -> value_bead.character_value 54 then do; 55 copy_zero = copy_zero_char (internal_op_code); 56 copy_one = copy_one_char (internal_op_code); 57 end; 58 else go to domain_error_right; 59 60 if right_vb -> value_bead.rhorho = 0 61 then dimension, result_rhorho = 1; 62 else do; 63 result_rhorho = right_vb -> value_bead.rhorho; 64 dimension = operators_argument.dimension; 65 end; 66 67 right_data_elements = right_vb -> value_bead.total_data_elements; 68 69 if right_data_elements = 1 70 then do; 71 dim_to_compress = right_data_elements; /* is 1 of course */ 72 from_increment = 0; /* right is scalar so do not increment index to non-existent next element */ 73 end; 74 else do; 75 dim_to_compress = right_vb -> value_bead.rho (dimension); 76 if dimension > right_vb -> value_bead.rhorho 77 then goto operator_subscript_range_error; 78 from_increment = 1; /* next element of right will be 1 element ahead of last */ 79 end; 80 left_vb = operators_argument.operands (1).value; 81 left_data_elements = left_vb -> value_bead.total_data_elements; 82 83 left = left_vb -> value_bead.data_pointer; 84 right = right_vb -> value_bead.data_pointer; 85 86 skip, times = 1; 87 88 do subscript = 1 by 1 while (subscript < dimension); 89 times = right_vb -> value_bead.rho (subscript) * times; 90 end; 91 do subscript = dimension + 1 to right_vb -> value_bead.rhorho; 92 skip = right_vb -> value_bead.rho (subscript) * skip; 93 end; 94 95 /* left arg is not null, check that it is numeric */ 96 97 if left_data_elements ^= 0 98 then if ^left_vb -> value_bead.numeric_value 99 then go to domain_error_left; 100 101 if left_data_elements = 1 102 then if internal_op_code = compression 103 then do; 104 if abs (left_numeric_datum (0)) <= integer_fuzz 105 then go to create_null_value; 106 107 if abs (left_numeric_datum (0) - 1e0) <= integer_fuzz 108 then go to return_right_argument; 109 110 goto domain_error_left; 111 end; 112 else ; /* no special cases for expansion */ 113 else if left_vb -> value_bead.rhorho ^= 1 114 then go to rank_error; 115 116 ones_count = 0; 117 118 if left_data_elements ^= 0 119 then if left_vb -> value_bead.zero_or_one_value 120 then ones_count = fixed (sum (left_numeric_datum), 35); 121 /* add up and convert to fixed */ 122 else do this_subscript = 0 by 1 while (this_subscript < left_data_elements); 123 value = floor (left_numeric_datum (this_subscript) + .5e0); 124 125 if abs (value) > integer_fuzz /* not equal to zero */ 126 then if abs (value - 1e0) <= integer_fuzz 127 then ones_count = ones_count + 1; 128 /* equal to one */ 129 else go to domain_error_left; /* not equal to zero or one */ 130 end; 131 132 /* Calculate the length of the result */ 133 134 if internal_op_code = compression 135 then if (left_data_elements = dim_to_compress) | (right_data_elements = 1) 136 then result_length = ones_count; 137 else goto length_error; 138 else if (ones_count = dim_to_compress) | (right_data_elements = 1) 139 then result_length = left_data_elements; 140 else go to incomplete_expansion; 141 142 /* Handle special cases & optimizations. */ 143 144 if /* tree */ result_length = dim_to_compress 145 then if internal_op_code = compression 146 then go to return_right_argument; /* compression won't shorten arg */ 147 else if (right_data_elements = 1) & (ones_count = 0) 148 then ; /* 0\ */ 149 else go to return_right_argument; /* expansion won't lengthen arg */ 150 151 if left_data_elements = 0 152 then go to create_null_value; 153 154 call allocate_result; 155 156 from_subscript, to_subscript = 0; 157 158 do time = 0 by 1 while (time < times); /* this loop controls how often left array is looped thru */ 159 160 do position = 0 by 1 while (position < left_data_elements); 161 /* loop thru left arg */ 162 163 if abs (left_numeric_datum (position)) <= integer_fuzz 164 then copy_site = copy_zero; 165 else copy_site = copy_one; 166 167 do subscript = 0 by 1 while (subscript < skip); 168 /* loop across dim to be reduced */ 169 170 go to copy_site; 171 172 copy_zero_char (0): 173 result_value_char (to_subscript) = Blank; 174 to_subscript = to_subscript + 1; 175 go to exeunt; 176 177 copy_zero_num (0): 178 result_numeric_datum (to_subscript) = 0.0e0; 179 to_subscript = to_subscript + 1; 180 go to exeunt; 181 182 copy_one_char (0): 183 copy_one_char (1): 184 result_value_char (to_subscript) = right_argument_char (from_subscript); 185 to_subscript = to_subscript + 1; 186 goto increment_from_subscript; 187 188 copy_one_num (0): 189 copy_one_num (1): 190 result_numeric_datum (to_subscript) = right_numeric_datum (from_subscript); 191 to_subscript = to_subscript + 1; 192 193 copy_zero_char (1): 194 copy_zero_num (1): 195 increment_from_subscript: 196 from_subscript = from_subscript + from_increment; 197 198 exeunt: 199 end; 200 end; 201 end; 202 203 if ^operators_argument.operands (2).on_stack 204 then do; /* right not on stack, see if can move to left */ 205 if ^operators_argument.operands (1).on_stack 206 then do; /* cannot, just return it whereever it is */ 207 call fill_in_bead (); /* finalize bead contents */ 208 return; 209 end; 210 211 final_result_vb = left_vb; 212 end; 213 else /* right is on stack */ 214 final_result_vb = right_vb; 215 216 if fixed (rel (final_result_vb), 18, 0) + total_words_wanted > ws_info.maximum_value_stack_size 217 then return; /* copy-up wouldn't fit on stack... */ 218 219 ws_info.pointers.value_stack_ptr = final_result_vb; 220 /* put result here */ 221 previous_result_array_pointer = result; /* save because allocate_again will smash */ 222 223 call allocate_again (); /* allocate at this new spot */ 224 call fill_in_bead (); /* fill in bead values */ 225 226 if data_words_wanted = 0 227 then return; /* avoid IPR */ 228 result -> word_copy_overlay = /* copy up stack */ previous_result_array_pointer -> word_copy_overlay; 229 return; 230 231 create_null_value: 232 result_length = 0; 233 goto return_same; 234 235 return_right_argument: /* no change; left arg must be all 1s */ 236 if operators_argument.operands (2).on_stack 237 then do; /* how lucky -- just return it */ 238 operators_argument.result = right_vb; 239 data_elements = right_vb -> value_bead.total_data_elements; 240 number_of_dimensions = right_vb -> value_bead.rhorho; 241 total_words_wanted = size (value_bead) + size (numeric_datum) + 1; 242 ws_info.value_stack_ptr = addrel (right_vb, total_words_wanted); 243 /* protect result */ 244 return; 245 end; 246 247 result_length = dim_to_compress; 248 249 return_same: 250 if operators_argument.operands (2).on_stack 251 then ws_info.value_stack_ptr = right_vb; 252 else if operators_argument.operands (1).on_stack 253 then ws_info.value_stack_ptr = left_vb; 254 255 call allocate_result (); 256 call fill_in_bead (); 257 258 result -> word_copy_overlay = /* copy entire right array onto stack */ right -> word_copy_overlay; 259 260 return; 261 262 rank_error: 263 operators_argument.error_code = apl_error_table_$rank; 264 return; 265 266 incomplete_expansion: 267 operators_argument.error_code = apl_error_table_$incomplete_expansion; 268 return; 269 270 length_error: 271 operators_argument.error_code = apl_error_table_$length; 272 return; 273 274 domain_error_right: 275 operators_argument.where_error = operators_argument.where_error - 2; 276 277 domain_error_left: 278 operators_argument.where_error = operators_argument.where_error + 1; 279 operators_argument.error_code = apl_error_table_$domain; 280 return; 281 operator_subscript_range_error: 282 operators_argument.error_code = apl_error_table_$operator_subscript_range; 283 return; 284 285 allocate_result: 286 procedure (); 287 288 data_elements = multiply (multiply (times, skip, 21, 0), result_length, 21, 0); 289 number_of_dimensions = result_rhorho; 290 bead_words_wanted = size (value_bead); /* words to be in result value bead */ 291 292 if right_vb -> value_bead.numeric_value /* numbers we want */ 293 then data_words_wanted = size (numeric_datum) + 1; 294 else data_words_wanted = size (character_string_overlay); 295 296 allocate_again: /* entry point for moving final result up stack */ 297 entry (); 298 299 /* bead_words_wanted and data_words_wanted have either been set by 300* caller, or by falling through from allocate_result above. */ 301 302 total_words_wanted = bead_words_wanted + data_words_wanted; 303 304 result_vb = apl_push_stack_ (total_words_wanted); 305 306 result = addrel (result_vb, bead_words_wanted); 307 308 if right_vb -> value_bead.numeric_value 309 then if substr (rel (result), 18, 1) 310 then result = addrel (result, 1); 311 312 operators_argument.result = result_vb; 313 end allocate_result; 314 315 fill_in_bead: 316 procedure (); 317 318 result_vb -> value_bead.data_pointer = result; 319 string (result_vb -> value_bead.type) = string (right_vb -> value_bead.type); 320 result_vb -> value_bead.total_data_elements = data_elements; 321 322 do subscript = 1 to right_vb -> value_bead.rhorho; 323 result_vb -> value_bead.rho (subscript) = right_vb -> value_bead.rho (subscript); 324 end; 325 326 result_vb -> value_bead.rho (dimension) = result_length; 327 result_vb -> value_bead.rhorho = result_rhorho; 328 329 end fill_in_bead; 330 1 1 /* ====== BEGIN INCLUDE SEGMENT apl_push_stack_fcn.incl.pl1 =============================== */ 1 2 1 3 /* format: style3 */ 1 4 apl_push_stack_: 1 5 procedure (P_n_words) returns (ptr); 1 6 1 7 /* Function to (1) double-word align ws_info.value_stack_ptr, and 1 8* (2) make sure allocation request will fit on current value stack. 1 9* 1 10* Written 770413 by PG 1 11* Modified 780210 by PG to round allocations up to an even number of words. 1 12**/ 1 13 1 14 /* parameters */ 1 15 1 16 declare P_n_words fixed bin (19) parameter; 1 17 1 18 /* automatic */ 1 19 1 20 declare block_ptr ptr, 1 21 num_words fixed bin (19); 1 22 1 23 /* builtins */ 1 24 1 25 declare (addrel, binary, rel, substr, unspec) 1 26 builtin; 1 27 1 28 /* entries */ 1 29 1 30 declare apl_get_value_stack_ 1 31 entry (fixed bin (19)); 1 32 1 33 /* program */ 1 34 1 35 num_words = P_n_words; 1 36 1 37 if substr (unspec (num_words), 36, 1) = "1"b /* num_words odd */ 1 38 then num_words = num_words + 1; 1 39 1 40 if binary (rel (ws_info.value_stack_ptr), 18) + num_words > ws_info.maximum_value_stack_size 1 41 then call apl_get_value_stack_ (num_words); 1 42 1 43 block_ptr = ws_info.value_stack_ptr; 1 44 ws_info.value_stack_ptr = addrel (ws_info.value_stack_ptr, num_words); 1 45 return (block_ptr); 1 46 1 47 end apl_push_stack_; 1 48 1 49 /* ------ END INCLUDE SEGMENT apl_push_stack_fcn.incl.pl1 ------------------------------- */ 331 332 333 /* automatic */ 334 335 declare (dimension, dim_to_compress, internal_op_code, times, skip, ones_count, result_length, from_subscript, to_subscript, 336 position, subscript, data_elements, time, this_subscript, left_data_elements, right_data_elements, result_rhorho) 337 fixed binary (21); 338 339 declare (total_words_wanted, bead_words_wanted, data_words_wanted, from_increment) 340 fixed binary precision (19); 341 declare integer_fuzz float, 342 value float; 343 344 declare (copy_site, copy_zero, copy_one) 345 label local; 346 347 declare (left_vb, left, right_vb, right, result_vb, result, previous_result_array_pointer, final_result_vb) 348 pointer; 349 350 /* based */ 351 352 declare word_copy_overlay dimension (data_words_wanted) based fixed binary (35); 353 /* for rapid data copying */ 354 355 declare left_numeric_datum (0:left_data_elements - 1) float based (left), 356 result_numeric_datum 357 (0:data_elements - 1) float based (result), 358 right_numeric_datum (0:right_data_elements - 1) float based (right); 359 declare 1 right_argument_char_structure 360 based (right) aligned, 361 2 right_argument_char 362 character (1) unaligned dimension (0:right_data_elements - 1); 363 364 declare 1 result_value_char_structure 365 based (result) aligned, 366 2 result_value_char 367 character (1) unaligned dimension (0:data_elements - 1); 368 369 /* external static */ 370 371 declare ( 372 apl_error_table_$length, 373 apl_error_table_$rank, 374 apl_error_table_$domain, 375 apl_error_table_$operator_subscript_range, 376 apl_error_table_$incomplete_expansion 377 ) fixed binary (35) external static; 378 379 /* internal static */ 380 381 declare ( 382 compression initial (1), 383 expansion initial (0) 384 ) fixed binary internal static; 385 386 declare Blank character (1) aligned internal static initial (" "); 387 388 /* builtins */ 389 390 declare (abs, addrel, fixed, floor, rel, size, multiply, sum, string, substr) 391 builtin; 392 393 /* include files */ 394 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 ---------------------------------- */ 395 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 ----------------------------------- */ 396 4 1 /* ====== BEGIN INCLUDE SEGMENT apl_ws_info.incl.pl1 ====================================== */ 4 2 4 3 /* This structure contains all of the global data (or pointers to it) for the APL subsystem */ 4 4 4 5 /* automatic */ 4 6 4 7 declare ws_info_ptr ptr initial (apl_static_$ws_info_ptr.static_ws_info_ptr); 4 8 4 9 /* external static */ 4 10 4 11 declare 1 apl_static_$ws_info_ptr external static aligned structure, 4 12 2 static_ws_info_ptr unaligned pointer; 4 13 4 14 /* based */ 4 15 4 16 declare 1 ws_info aligned based (ws_info_ptr), 4 17 2 version_number fixed bin, /* version of this structure (3) */ 4 18 2 switches unaligned, /* mainly ws parameters */ 4 19 3 long_error_mode bit, /* if 1, long Multics format, else APL/360 format */ 4 20 3 debug_mode bit, /* if 1, system error causes escape to command level */ 4 21 3 canonicalize_mode bit, /* if 1, the editor canonicalizes user input */ 4 22 3 restrict_exec_command bit, /* if 1, the )EXEC command may not be used */ 4 23 3 restrict_debug_command bit, /* if 1, the )DEBUG command may not be used */ 4 24 3 restrict_external_functions 4 25 bit, /* if 1, the )ZFN, )MFN, and )DFN commands may not be used */ 4 26 3 restrict_load bit, /* if 1, the )LOAD and )COPY commands may not be used */ 4 27 3 restrict_load_directory bit, /* if 1, no directory allowed in )LOAD or )COPY pathnames */ 4 28 3 restrict_save bit, /* if 1, the )SAVE command may not be used */ 4 29 3 restrict_save_directory bit, /* if 1, no directory allowed in )SAVE pathnames */ 4 30 3 off_hold bit, /* if 1, )OFF HOLD was typed, else just )OFF */ 4 31 3 transparent_to_signals bit, /* if 1, any conditions slip right past APL */ 4 32 3 meter_mode bit, /* if 1, metering may be done, else speed is all-important */ 4 33 3 restrict_msg_command bit, /* if 1, the )MSG command may not be used. */ 4 34 3 compatibility_check_mode 4 35 bit, /* if 1, check for incompatible operators */ 4 36 3 no_quit_handler bit, /* if 1, do not trap QUITs. */ 4 37 /* remaining 20 bits not presently used */ 4 38 4 39 2 values, /* attributes of the workspace */ 4 40 3 digits fixed bin, /* number of digits of precision printed on output */ 4 41 3 width fixed bin, /* line length for formatted output */ 4 42 3 index_origin fixed bin, /* the index origin (0 or 1) */ 4 43 3 random_link fixed bin(35), /* seed for random number generator */ 4 44 3 fuzz float, /* comparison tolerance (relative fuzz) */ 4 45 3 float_index_origin float, /* the index origin in floating point */ 4 46 3 number_of_symbols fixed bin, /* the number of symbol_beads currently in existence */ 4 47 3 maximum_value_stack_size 4 48 fixed bin (18), /* maximum number of words in one segment of value stack */ 4 49 4 50 2 pointers, /* pointers to various internal tables */ 4 51 3 symbol_table_ptr unaligned pointer, /* -> symbol_table (apl_symbol_table.incl.pl1) */ 4 52 3 current_parse_frame_ptr unaligned pointer, /* -> topmost parse frame */ 4 53 3 value_stack_ptr unaligned pointer, /* -> next free location on value stack */ 4 54 3 alloc_free_info_ptr unaligned pointer, /* -> apl_storage_mngr_ data (apl_storage_system_data.incl.pl1) */ 4 55 4 56 2 time_invoked fixed bin(71), /* clock time that APL was entered */ 4 57 2 integer_fuzz float, /* the absolute fuzz used in checking for integers */ 4 58 2 user_number fixed bin(35), /* number under which the user is signed on */ 4 59 2 latent_expression unaligned pointer, /* -> value_bead for QuadLX */ 4 60 2 lock char(32), /* the lock currently set on this workspace (password) */ 4 61 2 wsid char(100), /* the workspace identification: name, number name, or clear ws */ 4 62 2 last_error_code fixed bin(35), /* last code passed to apl_error_ */ 4 63 2 signoff_lock character (32), 4 64 4 65 2 interrupt_info aligned, /* bits used by apl_interpreter_ to tell when to abort */ 4 66 3 dont_interrupt_parse bit, /* if 1, don't do a dirty stop because the parser is running */ 4 67 3 dont_interrupt_operator bit, /* if 1, don't do a dirty stop because an operator is running */ 4 68 3 dont_interrupt_storage_manager /* if 1, don't stop because apl_storage_mngr_ is */ 4 69 bit, /* munging his tables */ 4 70 3 unused_interrupt_bit bit, /* not presently used */ 4 71 3 dont_interrupt_command bit, 4 72 3 can_be_interrupted bit, /* if 1, OK to do a clean stop (we are between lines, reading) */ 4 73 3 clean_interrupt_pending bit, /* interrupt occured, break cleanly (between lines) */ 4 74 3 dirty_interrupt_pending bit, /* interrupt occured, break as soon as not inhibited */ 4 75 4 76 2 user_name char (32), /* process group id of user */ 4 77 2 immediate_input_prompt char (32) varying, /* normal input */ 4 78 2 evaluated_input_prompt char (32) varying, /* quad input */ 4 79 2 character_input_prompt char (32) varying, /* quad-quote input */ 4 80 2 vcpu_time aligned, 4 81 3 total fixed bin (71), 4 82 3 setup fixed bin (71), 4 83 3 parse fixed bin (71), 4 84 3 lex fixed bin (71), 4 85 3 operator fixed bin (71), 4 86 3 storage_manager fixed bin (71), 4 87 2 output_info aligned, /* data pertaining to output buffer */ 4 88 3 output_buffer_ptr unal ptr, /* ptr to output buffer */ 4 89 3 output_buffer_len fixed bin (21), /* length (bytes) of output buffer */ 4 90 3 output_buffer_pos fixed bin (21), /* index of next byte to write in */ 4 91 3 output_buffer_ll fixed bin (21), /* print positions used up so far */ 4 92 2 tab_width fixed bin (21); /* number of columns a tabs moves cursor */ 4 93 4 94 declare output_buffer char (ws_info.output_buffer_len) based (ws_info.output_buffer_ptr); 4 95 4 96 /* internal static */ 4 97 4 98 declare max_parse_stack_depth fixed bin int static init(64536); 4 99 4 100 /* ------ END INCLUDE SEGMENT apl_ws_info.incl.pl1 -------------------------------------- */ 397 5 1 /* ====== BEGIN INCLUDE SEGMENT apl_number_data.incl.pl1 ================================== */ 5 2 5 3 /* 5 4* This include file contains information about the machine representation of numbers. 5 5* In all programs numbers should simply be declared 'float'. 5 6* All default statements should be in this include file. 5 7* 5 8* This is the binary version. The manifest constant Binary should be used by programs 5 9* that need to know whether we are using binary or decimal. 5 10* */ 5 11 5 12 /* format: style3,initlm0,idind30 */ 5 13 5 14 default (float & ^decimal & ^binary & ^precision & ^constant) float binary (63); 5 15 5 16 declare ( 5 17 TheBiggestNumberWeveGot float initial (0.1701411834604692317e+39), 5 18 TheSmallestNumberWeveGot float initial (.1469367938527859385e-38), 5 19 Binary bit (1) aligned initial ("1"b) 5 20 ) internal static options (constant); 5 21 5 22 /* Number of characters in a number datum entry; used for copying float number arrays as strings. 5 23* (Obsolete! use array copies!) */ 5 24 5 25 declare NumberSize fixed binary precision (4) internal static initial (8); 5 26 5 27 /* ------ END INCLUDE SEGMENT apl_number_data.incl.pl1 ---------------------------------- */ 398 6 1 /* ====== BEGIN INCLUDE SEGEMENT apl_operators_argument.incl.pl1 =========================== */ 6 2 6 3 declare 1 operators_argument aligned, 6 4 2 operands (2) aligned, /* these are the operands to the operator to be executed. 6 5* if operand (1).value is null, operator is monadic */ 6 6 3 value pointer unaligned, /* a pointer to the value bead for this operand */ 6 7 3 on_stack bit (1) aligned, /* ON if this value resides on the value stack */ 6 8 2 operator aligned, /* information about the operator to be executed */ 6 9 3 dimension fixed bin, /* (optional) dimension along which to operate */ 6 10 3 padding bit (18) unaligned, /* unused part of operator bead */ 6 11 3 op2 fixed bin (8) unal, /* a modifier for op1, or a 2nd operator if inner product */ 6 12 3 op1 fixed bin (8) unal, /* code for the actual operator to be executed */ 6 13 2 result pointer unal, /* (output) set by operator to point to result bead in stack */ 6 14 2 error_code fixed bin (35), /* (output) set before signaling apl_operator_error_ */ 6 15 2 where_error fixed bin; /* parseme index of where error was - parse sets to operator */ 6 16 6 17 /* ------ END INCLUDE SEGMENT apl_operators_argument.incl.pl1 --------------------------- */ 399 400 end apl_compression_; SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 11/29/83 1346.2 apl_compression_.pl1 >special_ldd>on>apl.1129>apl_compression_.pl1 331 1 03/27/82 0429.8 apl_push_stack_fcn.incl.pl1 >ldd>include>apl_push_stack_fcn.incl.pl1 395 2 03/27/82 0438.5 apl_bead_format.incl.pl1 >ldd>include>apl_bead_format.incl.pl1 396 3 03/27/82 0439.2 apl_value_bead.incl.pl1 >ldd>include>apl_value_bead.incl.pl1 397 4 03/27/82 0439.2 apl_ws_info.incl.pl1 >ldd>include>apl_ws_info.incl.pl1 398 5 03/27/82 0429.8 apl_number_data.incl.pl1 >ldd>include>apl_number_data.incl.pl1 399 6 03/27/82 0439.0 apl_operators_argument.incl.pl1 >ldd>include>apl_operators_argument.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. Blank constant char(1) initial dcl 386 ref 172 P_n_words parameter fixed bin(19,0) dcl 1-16 ref 1-4 1-35 abs builtin function dcl 390 ref 104 107 125 125 163 addrel builtin function dcl 1-25 in procedure "apl_push_stack_" ref 1-44 addrel builtin function dcl 390 in procedure "apl_compression_" ref 242 306 308 apl_error_table_$domain 000014 external static fixed bin(35,0) dcl 371 ref 279 apl_error_table_$incomplete_expansion 000020 external static fixed bin(35,0) dcl 371 ref 266 apl_error_table_$length 000010 external static fixed bin(35,0) dcl 371 ref 270 apl_error_table_$operator_subscript_range 000016 external static fixed bin(35,0) dcl 371 ref 281 apl_error_table_$rank 000012 external static fixed bin(35,0) dcl 371 ref 262 apl_get_value_stack_ 000024 constant entry external dcl 1-30 ref 1-40 apl_static_$ws_info_ptr 000022 external static structure level 1 dcl 4-11 bead_words_wanted 000122 automatic fixed bin(19,0) dcl 339 set ref 290* 302 306 binary builtin function dcl 1-25 ref 1-40 block_ptr 000222 automatic pointer dcl 1-20 set ref 1-43* 1-45 character_string_overlay based char dcl 3-19 ref 294 character_value 0(09) based bit(1) level 5 packed unaligned dcl 3-3 set ref 53 compression constant fixed bin(17,0) initial dcl 381 ref 36 101 134 144 copy_one 000142 automatic label variable local dcl 344 set ref 51* 56* 165 copy_site 000132 automatic label variable local dcl 344 set ref 163* 165* 170 copy_zero 000136 automatic label variable local dcl 344 set ref 50* 55* 163 data_elements 000113 automatic fixed bin(21,0) dcl 335 set ref 239* 241 288* 292 294 294 320 data_pointer 4 based pointer level 2 packed unaligned dcl 3-3 set ref 83 84 318* data_type 0(08) based structure level 4 packed unaligned dcl 3-3 data_words_wanted 000123 automatic fixed bin(19,0) dcl 339 set ref 226 228 258 292* 294* 302 dim_to_compress 000101 automatic fixed bin(21,0) dcl 335 set ref 71* 75* 134 138 144 247 dimension 000100 automatic fixed bin(21,0) dcl 335 in procedure "apl_compression_" set ref 60* 64* 75 76 88 91 326 dimension 4 parameter fixed bin(17,0) level 3 in structure "operators_argument" dcl 6-3 in procedure "apl_compression_" ref 64 error_code 7 parameter fixed bin(35,0) level 2 dcl 6-3 set ref 262* 266* 270* 279* 281* expansion constant fixed bin(17,0) initial dcl 381 ref 42 final_result_vb 000164 automatic pointer dcl 347 set ref 211* 213* 216 219 fixed builtin function dcl 390 ref 118 216 floor builtin function dcl 390 ref 123 from_increment 000124 automatic fixed bin(19,0) dcl 339 set ref 72* 78* 193 from_subscript 000107 automatic fixed bin(21,0) dcl 335 set ref 156* 182 188 193* 193 general_bead based structure level 1 dcl 2-3 header based structure level 2 dcl 3-3 integer_fuzz 22 based float bin(63) level 2 in structure "ws_info" dcl 4-16 in procedure "apl_compression_" ref 44 integer_fuzz 000126 automatic float bin(63) dcl 341 in procedure "apl_compression_" set ref 44* 104 107 125 125 163 internal_op_code 000102 automatic fixed bin(21,0) dcl 335 set ref 36* 42* 50 51 55 56 101 134 144 left 000150 automatic pointer dcl 347 set ref 83* 104 107 118 123 163 left_data_elements 000116 automatic fixed bin(21,0) dcl 335 set ref 81* 97 101 118 118 122 134 138 151 160 left_numeric_datum based float bin(63) array dcl 355 ref 104 107 118 123 163 left_vb 000146 automatic pointer dcl 347 set ref 80* 81 83 97 113 118 211 252 maximum_value_stack_size 13 based fixed bin(18,0) level 3 dcl 4-16 ref 216 1-40 multiply builtin function dcl 390 ref 288 288 num_words 000224 automatic fixed bin(19,0) dcl 1-20 set ref 1-35* 1-37 1-37* 1-37 1-40 1-40* 1-44 number_of_dimensions 000166 automatic fixed bin(17,0) dcl 3-3 set ref 240* 241 289* 290 numeric_datum based float bin(63) array dcl 3-23 ref 241 292 numeric_value 0(10) based bit(1) level 5 packed unaligned dcl 3-3 set ref 48 97 292 308 on_stack 1 parameter bit(1) array level 3 dcl 6-3 ref 203 205 235 249 252 ones_count 000105 automatic fixed bin(21,0) dcl 335 set ref 116* 118* 125* 125 134 138 147 operands parameter structure array level 2 dcl 6-3 operator 4 parameter structure level 2 dcl 6-3 operators_argument parameter structure level 1 dcl 6-3 set ref 33 39 pointers 14 based structure level 2 dcl 4-16 position 000111 automatic fixed bin(21,0) dcl 335 set ref 160* 160* 163* previous_result_array_pointer 000162 automatic pointer dcl 347 set ref 221* 228 rel builtin function dcl 1-25 in procedure "apl_push_stack_" ref 1-40 rel builtin function dcl 390 in procedure "apl_compression_" ref 216 308 result 6 parameter pointer level 2 in structure "operators_argument" packed unaligned dcl 6-3 in procedure "apl_compression_" set ref 238* 312* result 000160 automatic pointer dcl 347 in procedure "apl_compression_" set ref 172 177 182 188 221 228 258 306* 308 308* 308 318 result_length 000106 automatic fixed bin(21,0) dcl 335 set ref 134* 138* 144 231* 247* 288 326 result_numeric_datum based float bin(63) array dcl 355 set ref 177* 188* result_rhorho 000120 automatic fixed bin(21,0) dcl 335 set ref 60* 63* 289 327 result_value_char based char(1) array level 2 packed unaligned dcl 364 set ref 172* 182* result_value_char_structure based structure level 1 dcl 364 result_vb 000156 automatic pointer dcl 347 set ref 304* 306 312 318 319 320 323 326 327 rho 5 based fixed bin(21,0) array level 2 dcl 3-3 set ref 75 89 92 323* 323 326* rhorho 3 based fixed bin(17,0) level 2 dcl 3-3 set ref 60 63 76 91 113 240 322 327* right 000154 automatic pointer dcl 347 set ref 84* 182 188 258 right_argument_char based char(1) array level 2 packed unaligned dcl 359 ref 182 right_argument_char_structure based structure level 1 dcl 359 right_data_elements 000117 automatic fixed bin(21,0) dcl 335 set ref 67* 69 71 134 138 147 right_numeric_datum based float bin(63) array dcl 355 ref 188 right_vb 000152 automatic pointer dcl 347 set ref 47* 48 53 60 63 67 75 76 84 89 91 92 213 238 239 240 242 249 292 308 319 322 323 size builtin function dcl 390 ref 241 241 290 292 294 skip 000104 automatic fixed bin(21,0) dcl 335 set ref 86* 92* 92 167 288 static_ws_info_ptr 000022 external static pointer level 2 packed unaligned dcl 4-11 ref 4-7 string builtin function dcl 390 set ref 319* 319 subscript 000112 automatic fixed bin(21,0) dcl 335 set ref 88* 88* 89* 91* 92* 167* 167* 322* 323 323* substr builtin function dcl 1-25 in procedure "apl_push_stack_" ref 1-37 substr builtin function dcl 390 in procedure "apl_compression_" ref 308 sum builtin function dcl 390 ref 118 this_subscript 000115 automatic fixed bin(21,0) dcl 335 set ref 122* 122* 123* time 000114 automatic fixed bin(21,0) dcl 335 set ref 158* 158* times 000103 automatic fixed bin(21,0) dcl 335 set ref 86* 89* 89 158 288 to_subscript 000110 automatic fixed bin(21,0) dcl 335 set ref 156* 172 174* 174 177 179* 179 182 185* 185 188 191* 191 total_data_elements 2 based fixed bin(21,0) level 2 dcl 3-3 set ref 67 81 239 320* total_words_wanted 000121 automatic fixed bin(19,0) dcl 339 set ref 216 241* 242 302* 304* type based structure level 3 packed unaligned dcl 3-3 set ref 319* 319 unspec builtin function dcl 1-25 ref 1-37 value parameter pointer array level 3 in structure "operators_argument" packed unaligned dcl 6-3 in procedure "apl_compression_" ref 47 80 value 000130 automatic float bin(63) dcl 341 in procedure "apl_compression_" set ref 123* 125 125 value_bead based structure level 1 dcl 3-3 set ref 241 290 value_stack_ptr 16 based pointer level 3 packed unaligned dcl 4-16 set ref 219* 242* 249* 252* 1-40 1-43 1-44* 1-44 values 2 based structure level 2 dcl 4-16 where_error 10 parameter fixed bin(17,0) level 2 dcl 6-3 set ref 274* 274 277* 277 word_copy_overlay based fixed bin(35,0) array dcl 352 set ref 228* 228 258* 258 ws_info based structure level 1 dcl 4-16 ws_info_ptr 000170 automatic pointer initial dcl 4-7 set ref 44 216 219 242 249 252 4-7* 1-40 1-40 1-43 1-44 1-44 zero_or_one_value 0(12) based bit(1) level 5 packed unaligned dcl 3-3 set ref 118 NAMES DECLARED BY DECLARE STATEMENT AND NEVER REFERENCED. Binary internal static bit(1) initial dcl 5-16 MAX_VALUE_BEAD_SIZE internal static fixed bin(19,0) initial dcl 3-28 NumberSize internal static fixed bin(4,0) initial dcl 5-25 TheBiggestNumberWeveGot internal static float bin(63) initial dcl 5-16 TheSmallestNumberWeveGot internal static float bin(63) initial dcl 5-16 character_data_structure based structure level 1 dcl 3-15 character_value_type internal static bit(18) initial unaligned dcl 2-30 complex_datum based complex float bin(63) array dcl 3-26 complex_value_type internal static bit(18) initial unaligned dcl 2-30 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 4-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 4-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. allocate_again 000731 constant entry internal dcl 296 ref 223 allocate_result 000703 constant entry internal dcl 285 ref 154 255 apl_compression_ 000052 constant entry external dcl 33 apl_expansion_ 000065 constant entry external dcl 39 apl_push_stack_ 001017 constant entry internal dcl 1-4 ref 304 copy_one_char 000004 constant label array(0:1) dcl 182 set ref 56 copy_one_num 000006 constant label array(0:1) dcl 188 ref 51 copy_zero_char 000000 constant label array(0:1) dcl 172 ref 55 copy_zero_num 000002 constant label array(0:1) dcl 177 ref 50 create_null_value 000557 constant label dcl 231 ref 104 151 domain_error_left 000670 constant label dcl 277 set ref 97 110 125 domain_error_right 000666 constant label dcl 274 set ref 53 exeunt 000505 constant label dcl 198 ref 175 180 fill_in_bead 000761 constant entry internal dcl 315 ref 207 224 256 incomplete_expansion 000652 constant label dcl 266 ref 138 increment_from_subscript 000503 constant label dcl 193 ref 186 joined_code 000075 constant label dcl 44 ref 37 length_error 000660 constant label dcl 270 ref 134 operator_subscript_range_error 000677 constant label dcl 281 ref 76 rank_error 000644 constant label dcl 262 ref 113 return_right_argument 000561 constant label dcl 235 ref 107 144 147 return_same 000613 constant label dcl 249 ref 233 THERE WERE NO NAMES DECLARED BY CONTEXT OR IMPLICATION. STORAGE REQUIREMENTS FOR THIS PROGRAM. Object Text Link Symbol Defs Static Start 0 0 1216 1244 1070 1226 Length 1550 1070 26 270 126 0 BLOCK NAME STACK SIZE TYPE WHY NONQUICK/WHO SHARES STACK FRAME apl_compression_ 160 external procedure is an external procedure. allocate_result internal procedure shares stack frame of external procedure apl_compression_. fill_in_bead internal procedure shares stack frame of external procedure apl_compression_. apl_push_stack_ internal procedure shares stack frame of external procedure apl_compression_. STORAGE FOR AUTOMATIC VARIABLES. STACK FRAME LOC IDENTIFIER BLOCK NAME apl_compression_ 000100 dimension apl_compression_ 000101 dim_to_compress apl_compression_ 000102 internal_op_code apl_compression_ 000103 times apl_compression_ 000104 skip apl_compression_ 000105 ones_count apl_compression_ 000106 result_length apl_compression_ 000107 from_subscript apl_compression_ 000110 to_subscript apl_compression_ 000111 position apl_compression_ 000112 subscript apl_compression_ 000113 data_elements apl_compression_ 000114 time apl_compression_ 000115 this_subscript apl_compression_ 000116 left_data_elements apl_compression_ 000117 right_data_elements apl_compression_ 000120 result_rhorho apl_compression_ 000121 total_words_wanted apl_compression_ 000122 bead_words_wanted apl_compression_ 000123 data_words_wanted apl_compression_ 000124 from_increment apl_compression_ 000126 integer_fuzz apl_compression_ 000130 value apl_compression_ 000132 copy_site apl_compression_ 000136 copy_zero apl_compression_ 000142 copy_one apl_compression_ 000146 left_vb apl_compression_ 000150 left apl_compression_ 000152 right_vb apl_compression_ 000154 right apl_compression_ 000156 result_vb apl_compression_ 000160 result apl_compression_ 000162 previous_result_array_pointer apl_compression_ 000164 final_result_vb apl_compression_ 000166 number_of_dimensions apl_compression_ 000170 ws_info_ptr apl_compression_ 000222 block_ptr apl_push_stack_ 000224 num_words apl_push_stack_ THE FOLLOWING EXTERNAL OPERATORS ARE USED BY THIS PROGRAM. call_ext_out return fl2_to_fx1 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_$incomplete_expansion 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 4 7 000042 33 000047 36 000060 37 000062 39 000063 42 000073 44 000075 47 000100 48 000104 50 000107 51 000113 52 000116 53 000117 55 000122 56 000126 60 000131 63 000137 64 000140 67 000142 69 000144 71 000146 72 000147 73 000150 75 000151 76 000154 78 000157 80 000161 81 000163 83 000165 84 000167 86 000171 88 000174 89 000201 90 000205 91 000207 92 000221 93 000225 97 000227 101 000234 104 000241 107 000246 110 000254 112 000255 113 000256 116 000262 118 000263 122 000315 123 000321 125 000326 130 000341 134 000343 138 000357 144 000367 147 000374 151 000401 154 000403 156 000404 158 000406 160 000413 163 000417 165 000432 167 000436 170 000443 172 000444 174 000451 175 000452 177 000453 179 000460 180 000461 182 000462 185 000471 186 000472 188 000473 191 000502 193 000503 198 000505 200 000507 201 000511 203 000513 205 000520 207 000523 208 000524 211 000525 212 000527 213 000530 216 000532 219 000540 221 000542 223 000544 224 000545 226 000546 228 000550 229 000556 231 000557 233 000560 235 000561 238 000566 239 000570 240 000572 241 000574 242 000604 244 000610 247 000611 249 000613 252 000624 255 000632 256 000633 258 000634 260 000643 262 000644 264 000651 266 000652 268 000657 270 000660 272 000665 274 000666 277 000670 279 000673 280 000676 281 000677 283 000702 285 000703 288 000704 289 000710 290 000712 292 000714 294 000724 296 000730 302 000732 304 000735 306 000737 308 000743 312 000754 313 000760 315 000761 318 000762 319 000765 320 000767 322 000771 323 001001 324 001006 326 001010 327 001014 329 001016 1 4 001017 1 35 001021 1 37 001023 1 40 001030 1 43 001045 1 44 001050 1 45 001057 ----------------------------------------------------------- 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