COMPILATION LISTING OF SEGMENT apl_system_functions_ Compiled by: Multics PL/I Compiler, Release 28d, of October 4, 1983 Compiled at: Honeywell LCPD Phoenix, System M Compiled on: 11/29/83 1617.9 mst Tue Options: optimize map 1 /* *********************************************************** 2* * * 3* * Copyright, (C) Honeywell Information Systems Inc., 1982 * 4* * * 5* * Copyright (c) 1972 by Massachusetts Institute of * 6* * Technology and Honeywell Information Systems, Inc. * 7* * * 8* *********************************************************** */ 9 10 11 12 apl_system_functions_: 13 procedure (operators_argument); 14 15 /* 16* * this routine implements those functions of APL whose names begin with a Quad: 17* * QuadCR, QuadDL, QuadEX, QuadFX, QuadNC, QuadNL, QuadEC, QuadAF. 18* * 19* * Written 73.8.22 by DAM 20* * Modified 740909 by PG for new value bead declaration, and to finish QuadEC and some of QuadAF. 21* Modified 781208 by PG to switch to new clock builtin 22* Modified 790308 by William M. York to double-word align all value beads 23* and implement qAF. 24* Modified 791219 by PG to fix 430 (qEC and qAF return invalid value_beads when no error occurs). 25* Modified 800130 by PG to fix 441 (qAF returns with ws_info.vsp one word too low). 26* Modified 800814 by WMY to fix 469 (qAF does not trap active_function_error). 27* Modified: 8 July 1982 by GMP to use cu_$evaluate_active_string rather than cu_$af 28* */ 29 30 31 /* pick up right operand and dispatch to routine for the particular function */ 32 33 right_vb = operands (2).value; 34 right = right_vb -> value_bead.data_pointer; 35 36 go to fcn (operators_argument.op1); 37 38 fcn (63): /* QuadDL - delay n seconds, return number of seconds of actual delay */ 39 number_type = numeric_value_type; 40 if ^right_vb -> value_bead.data_type.numeric_value 41 then go to domain_error_right; 42 if right_vb -> value_bead.total_data_elements ^= 1 43 then go to domain_error_right; 44 45 if right -> numeric_datum (0) <= 0 46 then do; /* don't delay */ 47 apl_number = 0; 48 go to return_apl_number_monadic; 49 end; 50 51 start_of_sleep_time = clock (); 52 on apl_quit_ go to quat_out_of_delay; /* set up handler so loser can terminate the delay */ 53 call timer_manager_$sleep (fixed (right -> numeric_datum (0) * 1e6, 71), "10"b); 54 quat_out_of_delay: 55 revert apl_quit_; 56 57 apl_number = float (clock () - start_of_sleep_time) / 1e6; 58 /* actual length of delay */ 59 60 return_apl_number_monadic: 61 if operands (2).on_stack 62 then value_stack_ptr = right_vb; 63 64 number_of_dimensions = 0; 65 n_words = size (value_bead) + size (apl_number) + 1; 66 result_vb = apl_push_stack_ (n_words); 67 operators_argument.result = result_vb; 68 69 string (result_vb -> value_bead.type) = number_type; 70 result_vb -> value_bead.total_data_elements = 1; 71 result_vb -> value_bead.rhorho = 0; 72 result = addr (result_vb -> value_bead.rho (1)); 73 if substr (rel (result), 18, 1) 74 then result = addrel (result, 1); 75 result_vb -> value_bead.data_pointer = result; 76 result -> numeric_datum (0) = apl_number; 77 return; 78 79 fcn (58): /* QuadCR - return character representation of function */ 80 if ^right_vb -> value_bead.data_type.character_value 81 then go to domain_error_right; 82 if right_vb -> value_bead.rhorho > 1 83 then go to quad_cr_lose; 84 data_elements = right_vb -> value_bead.total_data_elements; 85 name_len = data_elements; 86 name_pos = 0; 87 call check_name; 88 if name_no_good 89 then go to quad_cr_lose; 90 91 if sbp -> symbol_bead.meaning_pointer = null 92 then go to quad_cr_lose_and_wash_sbp; 93 if ^sbp -> symbol_bead.meaning_pointer -> general_bead.type.function 94 then go to quad_cr_lose_and_wash_sbp; 95 if sbp -> symbol_bead.meaning_pointer -> function_bead.class ^= 0 96 then go to quad_cr_lose_and_wash_sbp; 97 98 /* got text of function. In order to convert to matrix form, must first find number 99* of lines and maximum line length */ 100 101 max_line_length = 0; 102 number_of_lines = 0; 103 do line_pos = 0 repeat (line_pos + this_line_length) 104 while (line_pos < sbp -> symbol_bead.meaning_pointer -> function_bead.text_length); 105 this_line_length = 106 index (substr (sbp -> symbol_bead.meaning_pointer -> function_bead.text, line_pos + 1), QNewLine); 107 if this_line_length > max_line_length 108 then max_line_length = this_line_length; 109 number_of_lines = number_of_lines + 1; 110 end; 111 112 max_line_length = max_line_length - 1; /* because we will throw away the newlines */ 113 114 data_elements = number_of_lines * max_line_length; 115 if operands (2).on_stack 116 then value_stack_ptr = right_vb; /* no longer need operand */ 117 118 call alloc_chars_on_stack (2); 119 120 result_vb -> value_bead.rho (1) = number_of_lines; 121 result_vb -> value_bead.rho (2) = max_line_length; 122 123 /* now copy in the lines of the function, stripping newlines and padding with spaces on the right */ 124 125 line_pos = 0; 126 do line_number = 0 by 1 while (line_number < number_of_lines); 127 128 this_line_length = 129 index (substr (sbp -> symbol_bead.meaning_pointer -> function_bead.text, line_pos + 1), QNewLine); 130 substr (result -> character_string_overlay, line_number * max_line_length + 1, max_line_length) = 131 substr (sbp -> symbol_bead.meaning_pointer -> function_bead.text, line_pos + 1, this_line_length - 1); 132 line_pos = line_pos + this_line_length; 133 end; 134 135 call wash_sbp; 136 return; 137 138 139 quad_cr_lose_and_wash_sbp: 140 call wash_sbp; 141 142 quad_cr_lose: /* name is not unlocked function, return a 0 by 0 character matrix */ 143 data_elements = 0; 144 if operands (2).on_stack 145 then value_stack_ptr = right_vb; 146 call alloc_chars_on_stack (2); 147 result_vb -> value_bead.rho (1), result_vb -> value_bead.rho (2) = 0; 148 return; 149 150 151 152 wash_sbp: 153 proc; 154 155 sbp -> symbol_bead.reference_count = sbp -> symbol_bead.reference_count - 1; 156 if sbp -> symbol_bead.reference_count <= 0 157 then call apl_free_bead_ (sbp); 158 end wash_sbp; 159 160 /* here we insert some stack allocation routines */ 161 162 alloc_chars_on_stack: /* scalar/vector/matrix of chars */ 163 procedure (n_dims); 164 165 /* parameters */ 166 167 declare n_dims fixed bin; 168 169 /* program */ 170 171 number_of_dimensions = n_dims; 172 n_words = size (value_bead) + size (character_string_overlay); 173 174 result_vb = apl_push_stack_ (n_words); 175 operators_argument.result = result_vb; 176 177 value_stack_ptr = addrel (result_vb, n_words); 178 string (result_vb -> value_bead.type) = character_value_type; 179 result_vb -> value_bead.rhorho = number_of_dimensions; 180 result_vb -> value_bead.total_data_elements = data_elements; 181 result_vb -> value_bead.data_pointer, result = addrel (result_vb, size (value_bead)); 182 183 end alloc_chars_on_stack; 184 185 186 alloc_numbers_on_stack: 187 proc; /* vector of numbers */ 188 189 number_of_dimensions = 1; 190 n_words = size (value_bead) + size (numeric_datum) + 1; 191 192 result_vb = apl_push_stack_ (n_words); 193 operators_argument.result = result_vb; 194 195 string (result_vb -> value_bead.type) = numeric_value_type; 196 result_vb -> value_bead.total_data_elements, result_vb -> value_bead.rho (1) = data_elements; 197 result_vb -> value_bead.rhorho = 1; 198 result = addrel (result_vb, size (value_bead)); 199 200 if substr (rel (result), 18, 1) 201 then result = addrel (result, 1); 202 203 result_vb -> value_bead.data_pointer = result; 204 205 end alloc_numbers_on_stack; 206 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 ------------------------------- */ 207 208 209 fcn (62): /* QuadNC - returns type of use of names */ 210 number_type = integral_value_type; 211 if ^right_vb -> value_bead.data_type.character_value 212 then go to domain_error_right; 213 if right_vb -> value_bead.rhorho = 2 214 then do; 215 216 /* arg is matrix, process multiple names and return vector */ 217 218 data_elements = right_vb -> value_bead.rho (1); 219 call alloc_numbers_on_stack; 220 221 name_len = right_vb -> value_bead.rho (2); 222 do which_name = 0 by 1 while (which_name < right_vb -> value_bead.rho (1)); 223 name_pos = name_len * which_name; 224 call compute_name_usage; 225 result -> numeric_datum (which_name) = apl_number; 226 end; 227 228 /* now do copy-up if necessary */ 229 230 copy_up_numbers: 231 if ^operands (2).on_stack 232 then return; /* if no need to copy up */ 233 234 value_stack_ptr = right_vb; 235 final_result_vb = apl_push_stack_ (n_words); 236 /* n_words is already set */ 237 238 string (final_result_vb -> value_bead.type) = string (result_vb -> value_bead.type); 239 final_result_vb -> value_bead.total_data_elements = result_vb -> value_bead.total_data_elements; 240 final_result_vb -> value_bead.rhorho = result_vb -> value_bead.rhorho; 241 if final_result_vb -> value_bead.rhorho ^= 0 242 then final_result_vb -> value_bead.rho (*) = result_vb -> value_bead.rho (*); 243 244 final_result = addr (final_result_vb -> value_bead.rho (final_result_vb -> value_bead.rhorho + 1)); 245 if substr (rel (final_result), 18, 1) 246 then final_result = addrel (final_result, 1); 247 final_result_vb -> value_bead.data_pointer = final_result; 248 249 if data_elements ^= 0 250 then /* EIS bug */ 251 final_result -> numeric_datum (*) = result -> numeric_datum (*); 252 253 operators_argument.result = final_result_vb; 254 return; 255 end; 256 257 /* continuation of QuadNC */ 258 259 else if right_vb -> value_bead.rhorho > 2 260 then go to domain_error_right; 261 262 else do; 263 264 /* arg is vector (or scalar, which is length-1 vector) */ 265 266 name_len = right_vb -> value_bead.total_data_elements; 267 name_pos = 0; 268 call compute_name_usage; 269 go to return_apl_number_monadic; 270 end; 271 272 273 274 compute_name_usage: 275 proc; 276 277 call check_name; 278 if name_no_good 279 then apl_number = 4; 280 else do; 281 282 283 if sbp -> symbol_bead.meaning_pointer = null 284 then apl_number = 0; 285 else if sbp -> symbol_bead.meaning_pointer -> general_bead.type.label 286 then apl_number = 1; 287 else if sbp -> symbol_bead.meaning_pointer -> general_bead.type.value 288 then apl_number = 2; 289 else if sbp -> symbol_bead.meaning_pointer -> general_bead.type.function 290 then apl_number = 3; 291 else apl_number = 4; 292 293 call wash_sbp; 294 end; 295 end compute_name_usage; 296 297 298 check_name: 299 proc; 300 301 dcl name_string char (name_pos + name_len) aligned based (right); 302 /* portion of right -> character_string_overlay 303* which does not go too far past name */ 304 305 call apl_scan_ (name_string, name_pos + 1, token_pos, token_len, token_type, null); 306 if token_type ^= 2 307 then do; 308 name_no_good = "1"b; 309 return; 310 end; 311 call apl_scan_ (name_string, token_pos + token_len, (0), (1), token_type, null); 312 if token_type ^= 0 313 then do; 314 name_no_good = "1"b; 315 return; 316 end; /* the "name" actually consists of a name and nothing else (except maybe white space) */ 317 318 call apl_get_symbol_ (substr (right -> character_string_overlay, token_pos, token_len), sbp, (0)); 319 name_no_good = "0"b; 320 return; 321 end check_name; 322 323 fcn (61): /* QuadNL - list names of specified type */ 324 left_vb = operands (1).value; 325 if left_vb ^= null 326 then do; 327 328 /* dyadic QuadNL */ 329 330 if ^left_vb -> value_bead.data_type.character_value 331 then go to domain_error_left; 332 if left_vb -> value_bead.rhorho > 1 333 then go to domain_error_left; 334 335 left = left_vb -> value_bead.data_pointer; 336 left_size = left_vb -> value_bead.total_data_elements; 337 end; 338 339 /* process right arg */ 340 341 do_labels, do_variables, do_functions = "0"b; 342 if ^right_vb -> value_bead.data_type.numeric_value 343 then go to domain_error_right; 344 if right_vb -> value_bead.rhorho > 1 345 then go to domain_error_right; 346 347 do i = 0 by 1 while (i < right_vb -> value_bead.total_data_elements); 348 float_temp = floor (right -> numeric_datum (i) + 0.5); 349 if abs (float_temp - right -> numeric_datum (i)) > integer_fuzz 350 then go to domain_error_right; 351 if abs (float_temp) >= 1e17b 352 then go to domain_error_right; 353 fixnum = fixed (float_temp, 17); 354 if fixnum = 1 355 then do_labels = "1"b; 356 else if fixnum = 2 357 then do_variables = "1"b; 358 else if fixnum = 3 359 then do_functions = "1"b; 360 else go to domain_error_right; 361 end; 362 363 /* right arg no longer needed, pop it off stack */ 364 365 if operands (2).on_stack 366 then if left_vb = null 367 then value_stack_ptr = right_vb; 368 else if ^operands (1).on_stack 369 then value_stack_ptr = right_vb; 370 371 /* set up to compute size of result */ 372 373 n_rows, n_cols = 0; 374 do pass = 1, 2; /* first pass computes dimensions of result, second fills it in */ 375 376 /* scan through all the symbol beads in the world */ 377 378 do htpos = lbound (symbol_table.hash_bucket_ptr, 1) to hbound (symbol_table.hash_bucket_ptr, 1); 379 380 do sbp = symbol_table.hash_bucket_ptr (htpos) repeat (sbp -> symbol_bead.hash_link_pointer) 381 while (sbp ^= null); 382 383 /* check alphabetic category */ 384 385 if left_vb ^= null 386 then if index (substr (left -> character_string_overlay, 1, left_size), 387 substr (sbp -> symbol_bead.name, 1, 1)) = 0 388 then go to skip_this_symbol; 389 390 /* check meaning category */ 391 392 if sbp -> symbol_bead.meaning_pointer ^= null 393 then if sbp -> symbol_bead.meaning_pointer -> general_bead.type.label 394 then if do_labels 395 then call do_this_symbol; 396 else ; 397 else if sbp -> symbol_bead.meaning_pointer -> general_bead.type.value 398 then if do_variables 399 then call do_this_symbol; 400 else ; 401 else if sbp -> symbol_bead.meaning_pointer -> general_bead.type.function 402 then if do_functions 403 then call do_this_symbol; 404 else ; 405 406 skip_this_symbol: 407 end; 408 409 end; 410 411 do_this_symbol: 412 proc; 413 414 if pass = 1 415 then do; 416 n_rows = n_rows + 1; 417 if sbp -> symbol_bead.name_length > n_cols 418 then n_cols = sbp -> symbol_bead.name_length; 419 end; 420 else do; 421 substr (result -> character_string_overlay, line_pos + 1, n_cols) = sbp -> symbol_bead.name; 422 line_pos = line_pos + n_cols; 423 end; 424 end do_this_symbol; 425 426 if pass = 1 427 then do; 428 429 /* end of pass 1, allocate result */ 430 431 data_elements = n_rows * n_cols; 432 433 /* reuse left arg space if on stack */ 434 435 if left_vb ^= null 436 then if operands (1).on_stack 437 then if operands (2).on_stack 438 then value_stack_ptr = right_vb; 439 else value_stack_ptr = left_vb; 440 441 call alloc_chars_on_stack (2); 442 443 result_vb -> value_bead.rho (1) = n_rows; 444 result_vb -> value_bead.rho (2) = n_cols; 445 446 line_pos = 0; /* initialize for next pass */ 447 448 /* special kludge to allow doing in place - move left arg up if necc */ 449 450 if left_vb ^= null 451 then if operands (1).on_stack 452 then do; 453 454 data_elements = left_size; 455 n_words = size (character_string_overlay); 456 457 final_result = apl_push_stack_ (n_words); 458 459 if data_elements ^= 0 460 then /* EIS bug */ 461 final_result -> character_string_overlay = left -> character_string_overlay; 462 left = final_result; 463 end; 464 465 end; 466 467 end; 468 return; 469 470 fcn (60): /* QuadEX - expunge a name */ 471 number_type = zero_or_one_value_type; 472 if ^right_vb -> value_bead.data_type.character_value 473 then go to domain_error_right; 474 if right_vb -> value_bead.rhorho = 2 475 then do; 476 477 /* matrix of names is arg */ 478 479 data_elements = right_vb -> value_bead.rho (1); 480 /* number of names */ 481 call alloc_numbers_on_stack; 482 name_len = right_vb -> value_bead.rho (2); 483 do which_name = 0 by 1 while (which_name < right_vb -> value_bead.rho (1)); 484 name_pos = name_len * which_name; 485 call expunge_name; 486 result -> numeric_datum (which_name) = apl_number; 487 end; 488 go to copy_up_numbers; 489 end; 490 491 else if right_vb -> value_bead.rhorho > 2 492 then go to domain_error_right; 493 else do; 494 495 /* arg is 1 name (vector) */ 496 497 name_len = right_vb -> value_bead.total_data_elements; 498 name_pos = 0; 499 call expunge_name; 500 go to return_apl_number_monadic; 501 end; 502 expunge_name: 503 proc; 504 505 call check_name; 506 if name_no_good 507 then apl_number = 0; 508 509 else if sbp -> symbol_bead.meaning_pointer = null 510 then apl_number = 1; 511 else if sbp -> symbol_bead.meaning_pointer -> general_bead.type.label 512 then apl_number = 0; 513 else if sbp -> symbol_bead.meaning_pointer -> general_bead.type.value 514 then do; 515 516 /* expunge a non-label value */ 517 518 expunge_meaning: 519 sbp -> symbol_bead.meaning_pointer -> general_bead.reference_count = 520 sbp -> symbol_bead.meaning_pointer -> general_bead.reference_count - 1; 521 if sbp -> symbol_bead.meaning_pointer -> general_bead.reference_count <= 0 522 then call apl_free_bead_ (sbp -> symbol_bead.meaning_pointer); 523 sbp -> symbol_bead.meaning_pointer = null; 524 apl_number = 1; 525 end; 526 else if sbp -> symbol_bead.meaning_pointer -> general_bead.type.function 527 then /* expunging a function, first check if allowed to */ 528 if apl_pendant_function_check_ (sbp -> symbol_bead.meaning_pointer) = "0"b 529 then go to expunge_meaning; 530 else apl_number = 0; /* not allowed, return 0 */ 531 532 else apl_number = 0; /* other cruft cannot be expunged */ 533 534 end expunge_name; 535 536 fcn (59): /* QuadFX - fix definition of function */ 537 if ^right_vb -> value_bead.data_type.character_value 538 then go to domain_error_right; 539 if right_vb -> value_bead.rhorho ^= 2 540 then go to domain_error_right; 541 542 n_rows = right_vb -> value_bead.rho (1); 543 n_cols = right_vb -> value_bead.rho (2); 544 545 /* first step is to put in NewLines and strip off trailing spaces */ 546 547 value_stack_popper = value_stack_ptr; 548 fcn_text_ptr = value_stack_ptr; 549 space_left_in_stack = 4 * (maximum_value_stack_size - fixed (rel (fcn_text_ptr), 18)); 550 551 out_pos = 0; 552 do in_row = 0 by 1 while (in_row < n_rows); 553 row_pos = in_row * n_cols; 554 do row_length = n_cols by -1 while (row_length > 0); 555 /* strip trailing Spaces */ 556 if substr (right -> character_string_overlay, row_pos + row_length - 1 + 1, 1) ^= QSpace 557 then go to exitloop; 558 end; 559 exitloop: 560 space_left_in_stack = space_left_in_stack - (row_length + 1); 561 if space_left_in_stack < 0 562 then do; /* stack full, switch segs */ 563 call apl_get_next_value_stack_seg_ (divide (out_pos + row_length + 1 + 3, 4, 18, 0)); 564 value_stack_ptr -> fcn_text = fcn_text_ptr -> fcn_text; 565 fcn_text_ptr = value_stack_ptr; 566 space_left_in_stack = 4 * (maximum_value_stack_size - fixed (rel (fcn_text_ptr), 18)); 567 end; 568 substr (fcn_text_ptr -> fcn_text, out_pos + 1, row_length) = 569 substr (right -> character_string_overlay, row_pos + 1, row_length); 570 substr (fcn_text_ptr -> fcn_text, out_pos + row_length + 1, 1) = QNewLine; 571 out_pos = out_pos + (row_length + 1); 572 end; 573 574 /* second step is to construct function bead, set fbp */ 575 576 data_elements = out_pos; 577 call apl_allocate_words_ (size (function_bead), fbp); 578 string (fbp -> function_bead.type) = function_type; 579 fbp -> function_bead.lexed_function_bead_pointer = null; 580 fbp -> function_bead.class = 0; 581 fbp -> function_bead.stop_control_pointer, fbp -> function_bead.trace_control_pointer = null; 582 fbp -> function_bead.text_length = data_elements; 583 fbp -> function_bead.text = fcn_text_ptr -> fcn_text; 584 value_stack_ptr = value_stack_popper; 585 586 call apl_function_lex_no_messages_ (fbp -> function_bead.text, lfbp, errors_occurred, 0, 587 addr (current_parse_frame_ptr -> parse_frame.reduction_stack_ptr 588 -> reduction_stack (current_parse_frame_ptr -> parse_frame.current_parseme + 1)), error_line); 589 590 if errors_occurred 591 then do; /* syntax error */ 592 apl_number = error_line + index_origin; 593 call wash_fbp; 594 number_type = integral_value_type; 595 go to return_apl_number_monadic; 596 end; 597 598 fbp -> function_bead.lexed_function_bead_pointer = lfbp; 599 sbp = lfbp -> lexed_function_bead.name; /* name of function being fixed */ 600 if sbp -> symbol_bead.meaning_pointer = null 601 then sbp -> symbol_bead.meaning_pointer = fbp; 602 else if sbp -> symbol_bead.meaning_pointer -> general_bead.type.function 603 then if apl_pendant_function_check_ (sbp -> symbol_bead.meaning_pointer) 604 then go to cant_fix; 605 else do; 606 sbp -> symbol_bead.meaning_pointer -> general_bead.reference_count = 607 sbp -> symbol_bead.meaning_pointer -> general_bead.reference_count - 1; 608 if sbp -> symbol_bead.meaning_pointer -> general_bead.reference_count <= 0 609 then call apl_free_bead_ (sbp -> symbol_bead.meaning_pointer); 610 sbp -> symbol_bead.meaning_pointer = fbp; 611 end; 612 else go to cant_fix; 613 614 /* return name of function, as character vector */ 615 616 data_elements = sbp -> symbol_bead.name_length; 617 if operands (2).on_stack 618 then value_stack_ptr = right_vb; 619 if data_elements = 1 620 then call alloc_chars_on_stack (0); 621 else do; 622 call alloc_chars_on_stack (1); 623 result_vb -> value_bead.rho (1) = data_elements; 624 end; 625 626 result -> character_string_overlay = sbp -> symbol_bead.name; 627 628 return; 629 630 631 wash_fbp: 632 proc; 633 634 fbp -> function_bead.reference_count = fbp -> function_bead.reference_count - 1; 635 if fbp -> function_bead.reference_count <= 0 636 then call apl_free_bead_ (fbp); 637 end wash_fbp; 638 639 640 641 cant_fix: 642 apl_number = float_index_origin; /* name error is attributed to header line */ 643 call wash_fbp; 644 number_type = integral_value_type; 645 go to return_apl_number_monadic; 646 647 fcn (64): 648 fcn (65): 649 fcn (66): /* unimplmented shared-variable functions */ 650 call apl_system_error_ (apl_error_table_$no_sv); 651 return; /* just in case */ 652 653 fcn (70): /* QuadEC - Execute Multics command line */ 654 fcn (71): /* QuadAF - Evaluate Multics active function expression */ 655 if ^right_vb -> value_bead.character_value 656 then go to domain_error_right; 657 658 if right_vb -> value_bead.rhorho > 1 659 then go to domain_error_right; 660 661 /* at this point we have a character vector or scalar */ 662 /* copy operand because command processor clobbers it! */ 663 664 data_elements = right_vb -> value_bead.total_data_elements; 665 n_words = size (character_string_overlay); 666 667 result = apl_push_stack_ (n_words); 668 669 result -> character_string_overlay = right -> character_string_overlay; 670 671 if ws_info.switches.restrict_exec_command /* oops */ 672 then do; 673 operators_argument.error_code = apl_error_table_$exec_restricted; 674 return; 675 end; 676 else if operators_argument.op1 = 70 /* QuadEC */ 677 then do; 678 call cu_$cp ((result), data_elements, code); 679 680 data_elements = 0; 681 end; 682 else do; /* QuadAF */ 683 call apl_segment_manager_$get (final_result); 684 685 on active_function_error 686 begin; 687 688 if code = 0 689 then code = error_table_$badcall; 690 691 goto return_error_message; 692 end; 693 694 call cu_$evaluate_active_string (null (), (result -> character_string_overlay), NORMAL_ACTIVE_STRING, 695 final_result -> return_string, code); 696 697 revert active_function_error; 698 699 data_elements = length (final_result -> return_string); 700 end; 701 702 /* allocate result (on top of copy of operand) */ 703 704 ws_info.value_stack_ptr = result; 705 706 if code ^= 0 707 then do; 708 return_error_message: 709 call convert_status_code_ (code, "xxxxxxxx", long_message); 710 data_elements = length (rtrim (long_message)); 711 end; 712 713 call alloc_chars_on_stack (1); /* result is always a vector */ 714 715 if code = 0 716 then if data_elements ^= 0 717 then do; 718 result -> character_string_overlay = final_result -> return_string; 719 call apl_segment_manager_$free (final_result); 720 end; 721 else ; 722 else result -> character_string_overlay = long_message; 723 724 result_vb -> value_bead.rho (1) = data_elements; 725 result_vb -> value_bead.total_data_elements = data_elements; 726 727 return; 728 729 domain_error_right: 730 operators_argument.where_error = operators_argument.where_error - 1; 731 domain_error: 732 operators_argument.error_code = apl_error_table_$domain; 733 return; 734 735 domain_error_left: 736 operators_argument.where_error = operators_argument.where_error + 1; 737 go to domain_error; 738 739 /* Declarations */ 740 741 declare code fixed bin (35), 742 long_message char (100) aligned, 743 return_string char (4 * 65535) varying based; 744 745 dcl right_vb unaligned pointer, 746 right unaligned pointer, 747 number_type bit (18), 748 apl_number float, 749 start_of_sleep_time fixed bin (71), 750 n_words fixed bin (19), 751 result_vb unaligned pointer, 752 result pointer, 753 final_result pointer, 754 final_result_vb unaligned pointer, 755 data_elements fixed bin (21), 756 name_len fixed bin (21), 757 name_pos fixed bin (21), 758 name_no_good bit (1), 759 sbp unaligned pointer, 760 fbp unaligned pointer, 761 lfbp unaligned pointer, 762 max_line_length fixed bin (21), 763 number_of_lines fixed bin (21), 764 line_pos fixed bin (21), 765 this_line_length fixed bin (21), 766 line_number fixed bin (21), 767 which_name fixed bin (21), 768 i fixed bin (21), 769 token_pos fixed bin (21), 770 token_len fixed bin (21), 771 token_type fixed bin, 772 left_vb unaligned pointer, 773 left unaligned pointer, 774 left_size fixed bin (21), 775 (do_labels, do_variables, do_functions) 776 bit (1), 777 fixnum fixed bin (17), 778 float_temp float, 779 n_rows fixed bin (21), 780 n_cols fixed bin (21), 781 pass fixed bin (2), 782 htpos fixed bin, 783 value_stack_popper unaligned pointer, 784 fcn_text_ptr unaligned pointer, 785 fcn_text char (out_pos) aligned based (fcn_text_ptr), 786 out_pos fixed bin (21), 787 space_left_in_stack fixed bin (21), 788 in_row fixed bin (21), 789 row_pos fixed bin (21), 790 row_length fixed bin (21), 791 errors_occurred bit (1) aligned, 792 error_line fixed bin; 793 794 795 /* Multics entries */ 796 797 declare convert_status_code_ 798 entry (fixed bin (35), char (8) aligned, char (100) aligned), 799 cu_$cp entry (ptr, fixed bin (21), fixed bin (35)), 800 /* cu_$evaluate_active_function entry (ptr, fixed bin (21), ptr, fixed bin (35)), */ 801 timer_manager_$sleep 802 entry (fixed bin (71), bit (2)); 803 804 /* APL entries */ 805 806 declare apl_free_bead_ entry (unaligned pointer), 807 apl_get_next_value_stack_seg_ 808 entry (fixed bin (18)), 809 ( 810 apl_segment_manager_$get, 811 apl_segment_manager_$free 812 ) entry (ptr), 813 apl_scan_ entry (char (*) aligned, fixed bin (21), fixed bin (21), fixed bin (21), fixed bin, 814 unaligned pointer), 815 apl_get_symbol_ entry (char (*), unaligned pointer, fixed bin), 816 apl_pendant_function_check_ 817 entry (unaligned pointer) returns (bit (1) aligned), 818 apl_allocate_words_ entry (fixed bin (18), unaligned pointer), 819 apl_function_lex_no_messages_ 820 entry (char (*) aligned, unaligned pointer, bit (1) aligned, fixed bin, aligned pointer, 821 fixed bin), 822 apl_system_error_ entry (fixed bin (35)), 823 cu_$evaluate_active_string 824 entry (ptr, char (*), fixed bin, char (*) var, fixed bin (35)); 825 826 /* external static */ 827 828 declare ( 829 error_table_$badcall, 830 apl_error_table_$domain, 831 apl_error_table_$not_implemented, 832 apl_error_table_$exec_restricted, 833 apl_error_table_$no_sv 834 ) fixed bin (35) external; 835 836 /* builtin */ 837 838 dcl (abs, addr, addrel, clock, divide, fixed, float, floor, hbound, index, lbound, null, rel, reverse, size, string, 839 substr, verify) builtin; 840 841 /* conditions */ 842 843 declare apl_quit_ condition; 844 declare active_function_error condition; 845 /* include files */ 846 2 1 /* ====== BEGIN INCLUDE SEGMENT apl_number_data.incl.pl1 ================================== */ 2 2 2 3 /* 2 4* This include file contains information about the machine representation of numbers. 2 5* In all programs numbers should simply be declared 'float'. 2 6* All default statements should be in this include file. 2 7* 2 8* This is the binary version. The manifest constant Binary should be used by programs 2 9* that need to know whether we are using binary or decimal. 2 10* */ 2 11 2 12 /* format: style3,initlm0,idind30 */ 2 13 2 14 default (float & ^decimal & ^binary & ^precision & ^constant) float binary (63); 2 15 2 16 declare ( 2 17 TheBiggestNumberWeveGot float initial (0.1701411834604692317e+39), 2 18 TheSmallestNumberWeveGot float initial (.1469367938527859385e-38), 2 19 Binary bit (1) aligned initial ("1"b) 2 20 ) internal static options (constant); 2 21 2 22 /* Number of characters in a number datum entry; used for copying float number arrays as strings. 2 23* (Obsolete! use array copies!) */ 2 24 2 25 declare NumberSize fixed binary precision (4) internal static initial (8); 2 26 2 27 /* ------ END INCLUDE SEGMENT apl_number_data.incl.pl1 ---------------------------------- */ 847 3 1 /* ====== BEGIN INCLUDE SEGMENT apl_ws_info.incl.pl1 ====================================== */ 3 2 3 3 /* This structure contains all of the global data (or pointers to it) for the APL subsystem */ 3 4 3 5 /* automatic */ 3 6 3 7 declare ws_info_ptr ptr initial (apl_static_$ws_info_ptr.static_ws_info_ptr); 3 8 3 9 /* external static */ 3 10 3 11 declare 1 apl_static_$ws_info_ptr external static aligned structure, 3 12 2 static_ws_info_ptr unaligned pointer; 3 13 3 14 /* based */ 3 15 3 16 declare 1 ws_info aligned based (ws_info_ptr), 3 17 2 version_number fixed bin, /* version of this structure (3) */ 3 18 2 switches unaligned, /* mainly ws parameters */ 3 19 3 long_error_mode bit, /* if 1, long Multics format, else APL/360 format */ 3 20 3 debug_mode bit, /* if 1, system error causes escape to command level */ 3 21 3 canonicalize_mode bit, /* if 1, the editor canonicalizes user input */ 3 22 3 restrict_exec_command bit, /* if 1, the )EXEC command may not be used */ 3 23 3 restrict_debug_command bit, /* if 1, the )DEBUG command may not be used */ 3 24 3 restrict_external_functions 3 25 bit, /* if 1, the )ZFN, )MFN, and )DFN commands may not be used */ 3 26 3 restrict_load bit, /* if 1, the )LOAD and )COPY commands may not be used */ 3 27 3 restrict_load_directory bit, /* if 1, no directory allowed in )LOAD or )COPY pathnames */ 3 28 3 restrict_save bit, /* if 1, the )SAVE command may not be used */ 3 29 3 restrict_save_directory bit, /* if 1, no directory allowed in )SAVE pathnames */ 3 30 3 off_hold bit, /* if 1, )OFF HOLD was typed, else just )OFF */ 3 31 3 transparent_to_signals bit, /* if 1, any conditions slip right past APL */ 3 32 3 meter_mode bit, /* if 1, metering may be done, else speed is all-important */ 3 33 3 restrict_msg_command bit, /* if 1, the )MSG command may not be used. */ 3 34 3 compatibility_check_mode 3 35 bit, /* if 1, check for incompatible operators */ 3 36 3 no_quit_handler bit, /* if 1, do not trap QUITs. */ 3 37 /* remaining 20 bits not presently used */ 3 38 3 39 2 values, /* attributes of the workspace */ 3 40 3 digits fixed bin, /* number of digits of precision printed on output */ 3 41 3 width fixed bin, /* line length for formatted output */ 3 42 3 index_origin fixed bin, /* the index origin (0 or 1) */ 3 43 3 random_link fixed bin(35), /* seed for random number generator */ 3 44 3 fuzz float, /* comparison tolerance (relative fuzz) */ 3 45 3 float_index_origin float, /* the index origin in floating point */ 3 46 3 number_of_symbols fixed bin, /* the number of symbol_beads currently in existence */ 3 47 3 maximum_value_stack_size 3 48 fixed bin (18), /* maximum number of words in one segment of value stack */ 3 49 3 50 2 pointers, /* pointers to various internal tables */ 3 51 3 symbol_table_ptr unaligned pointer, /* -> symbol_table (apl_symbol_table.incl.pl1) */ 3 52 3 current_parse_frame_ptr unaligned pointer, /* -> topmost parse frame */ 3 53 3 value_stack_ptr unaligned pointer, /* -> next free location on value stack */ 3 54 3 alloc_free_info_ptr unaligned pointer, /* -> apl_storage_mngr_ data (apl_storage_system_data.incl.pl1) */ 3 55 3 56 2 time_invoked fixed bin(71), /* clock time that APL was entered */ 3 57 2 integer_fuzz float, /* the absolute fuzz used in checking for integers */ 3 58 2 user_number fixed bin(35), /* number under which the user is signed on */ 3 59 2 latent_expression unaligned pointer, /* -> value_bead for QuadLX */ 3 60 2 lock char(32), /* the lock currently set on this workspace (password) */ 3 61 2 wsid char(100), /* the workspace identification: name, number name, or clear ws */ 3 62 2 last_error_code fixed bin(35), /* last code passed to apl_error_ */ 3 63 2 signoff_lock character (32), 3 64 3 65 2 interrupt_info aligned, /* bits used by apl_interpreter_ to tell when to abort */ 3 66 3 dont_interrupt_parse bit, /* if 1, don't do a dirty stop because the parser is running */ 3 67 3 dont_interrupt_operator bit, /* if 1, don't do a dirty stop because an operator is running */ 3 68 3 dont_interrupt_storage_manager /* if 1, don't stop because apl_storage_mngr_ is */ 3 69 bit, /* munging his tables */ 3 70 3 unused_interrupt_bit bit, /* not presently used */ 3 71 3 dont_interrupt_command bit, 3 72 3 can_be_interrupted bit, /* if 1, OK to do a clean stop (we are between lines, reading) */ 3 73 3 clean_interrupt_pending bit, /* interrupt occured, break cleanly (between lines) */ 3 74 3 dirty_interrupt_pending bit, /* interrupt occured, break as soon as not inhibited */ 3 75 3 76 2 user_name char (32), /* process group id of user */ 3 77 2 immediate_input_prompt char (32) varying, /* normal input */ 3 78 2 evaluated_input_prompt char (32) varying, /* quad input */ 3 79 2 character_input_prompt char (32) varying, /* quad-quote input */ 3 80 2 vcpu_time aligned, 3 81 3 total fixed bin (71), 3 82 3 setup fixed bin (71), 3 83 3 parse fixed bin (71), 3 84 3 lex fixed bin (71), 3 85 3 operator fixed bin (71), 3 86 3 storage_manager fixed bin (71), 3 87 2 output_info aligned, /* data pertaining to output buffer */ 3 88 3 output_buffer_ptr unal ptr, /* ptr to output buffer */ 3 89 3 output_buffer_len fixed bin (21), /* length (bytes) of output buffer */ 3 90 3 output_buffer_pos fixed bin (21), /* index of next byte to write in */ 3 91 3 output_buffer_ll fixed bin (21), /* print positions used up so far */ 3 92 2 tab_width fixed bin (21); /* number of columns a tabs moves cursor */ 3 93 3 94 declare output_buffer char (ws_info.output_buffer_len) based (ws_info.output_buffer_ptr); 3 95 3 96 /* internal static */ 3 97 3 98 declare max_parse_stack_depth fixed bin int static init(64536); 3 99 3 100 /* ------ END INCLUDE SEGMENT apl_ws_info.incl.pl1 -------------------------------------- */ 848 4 1 /* ====== BEGIN INCLUDE SEGMENT apl_bead_format.incl.pl1 ================================== */ 4 2 4 3 declare 1 general_bead aligned based, /* The Venerable Bead */ 4 4 2 type unaligned, 4 5 3 bead_type unaligned, 4 6 4 operator bit (1), /* ON if operator bead */ 4 7 4 symbol bit (1), /* ON if symbol bead */ 4 8 4 value bit (1), /* ON if value bead */ 4 9 4 function bit (1), /* ON if function bead */ 4 10 4 group bit (1), /* ON if group bead */ 4 11 4 label bit (1), /* ON if label bead */ 4 12 4 shared_variable bit (1), /* ON if shared variable bead */ 4 13 4 lexed_function bit (1), /* ON if lexed function bead */ 4 14 3 data_type unaligned, 4 15 4 list_value bit (1), /* ON if a list value bead */ 4 16 4 character_value bit (1), /* ON if a character value bead */ 4 17 4 numeric_value bit (1), /* ON if a numeric value bead */ 4 18 4 integral_value bit (1), /* ON if an integral value bead */ 4 19 4 zero_or_one_value bit (1), /* ON if a boolean value bead */ 4 20 4 complex_value bit (1), /* ON if a complex, numeric value bead */ 4 21 3 unused_bits bit (4) unaligned, /* pad to 18 bits (for future use) */ 4 22 2 size bit (18) unaligned, /* Number of words this bead occupies 4 23* (used by bead storage manager) */ 4 24 2 reference_count fixed binary (29); /* Number of pointers which point 4 25* to this bead (used by bead manager) */ 4 26 4 27 4 28 /* constant strings for initing type field in various beads */ 4 29 4 30 declare ( 4 31 operator_type init("100000000000000000"b), 4 32 symbol_type init("010000000000000000"b), 4 33 value_type init("001000000000000000"b), 4 34 function_type init("000100000000000000"b), 4 35 group_type init("000010000000000000"b), 4 36 label_type init("001001000011000000"b), 4 37 shared_variable_type init("001000100000000000"b), 4 38 lexed_function_type init("000000010000000000"b), 4 39 4 40 list_value_type init("000000001000000000"b), 4 41 character_value_type init("001000000100000000"b), 4 42 numeric_value_type init("001000000010000000"b), 4 43 integral_value_type init("001000000011000000"b), 4 44 zero_or_one_value_type init("001000000011100000"b), 4 45 complex_value_type init("001000000000010000"b), 4 46 4 47 not_integer_mask init("111111111110011111"b), /* to clear integral, zero_or_one bits */ 4 48 not_zero_or_one_mask init("111111111111011111"b) /* to clear zero_or_one bit */ 4 49 ) bit(18) internal static; 4 50 4 51 /* ------ END INCLUDE SEGMENT apl_bead_format.incl.pl1 ---------------------------------- */ 849 5 1 /* ====== BEGIN INCLUDE SEGEMENT apl_operators_argument.incl.pl1 =========================== */ 5 2 5 3 declare 1 operators_argument aligned, 5 4 2 operands (2) aligned, /* these are the operands to the operator to be executed. 5 5* if operand (1).value is null, operator is monadic */ 5 6 3 value pointer unaligned, /* a pointer to the value bead for this operand */ 5 7 3 on_stack bit (1) aligned, /* ON if this value resides on the value stack */ 5 8 2 operator aligned, /* information about the operator to be executed */ 5 9 3 dimension fixed bin, /* (optional) dimension along which to operate */ 5 10 3 padding bit (18) unaligned, /* unused part of operator bead */ 5 11 3 op2 fixed bin (8) unal, /* a modifier for op1, or a 2nd operator if inner product */ 5 12 3 op1 fixed bin (8) unal, /* code for the actual operator to be executed */ 5 13 2 result pointer unal, /* (output) set by operator to point to result bead in stack */ 5 14 2 error_code fixed bin (35), /* (output) set before signaling apl_operator_error_ */ 5 15 2 where_error fixed bin; /* parseme index of where error was - parse sets to operator */ 5 16 5 17 /* ------ END INCLUDE SEGMENT apl_operators_argument.incl.pl1 --------------------------- */ 850 6 1 /* ====== BEGIN INCLUDE SEGMENT apl_operator_bead.incl.pl1 ================================ */ 6 2 6 3 declare 6 4 1 operator_bead aligned based, 6 5 6 6 2 type unaligned like general_bead.type, 6 7 6 8 2 bits_for_lex unaligned, 6 9 3 allow_brackets bit(1), /* operator may have dimension info in brackets */ 6 10 3 allow_product bit(1), /* operator may be used in inner and outer product */ 6 11 3 allow_reduction bit(1), /* operator may be used in reduction and scan */ 6 12 3 special_assignment bit(1), /* doesn't use standard assignment operator */ 6 13 3 ignores_assignment bit(1), /* assignment has no effect */ 6 14 3 allow_subscripted_assignment 6 15 bit(1), /* system variable that can be subscripted assigned */ 6 16 3 pad bit(12), 6 17 6 18 2 bits_for_parse unaligned, 6 19 3 stop_trace_control bit(1), /* next lexeme is function being stopped/traced 6 20* (op1 tells which) */ 6 21 3 quad bit(1), /* this is a quad type */ 6 22 3 system_variable bit(1), /* this is a system variable, not an op */ 6 23 3 dyadic bit(1), /* operator may be dyadic */ 6 24 3 monadic bit(1), /* operator may be monadic */ 6 25 3 function bit(1), /* operator is a user defined function */ 6 26 3 semantics_valid bit(1), /* if semantics has been set */ 6 27 3 has_list bit(1), /* semantics is a list */ 6 28 3 inner_product bit(1), /* op2 is valid */ 6 29 3 semantics_on_stack bit(1), /* semantics points to value stack */ 6 30 3 is_external_function bit(1), /* semantics points to function bead for ext function */ 6 31 3 pad bit(7), 6 32 3 op2 fixed bin(8) unaligned, /* secondary operator code */ 6 33 3 op1 fixed bin(8) unaligned, /* primary operator code */ 6 34 2 type_code fixed bin; /* for parse */ 6 35 6 36 /* ------ END INCLUDE SEGMENT apl_operator_bead.incl.pl1 -------------------------------- */ 851 7 1 /* ====== BEGIN INCLUDE SEGMENT apl_value_bead.incl.pl1 =================================== */ 7 2 7 3 declare 7 4 number_of_dimensions fixed bin, 7 5 7 6 1 value_bead aligned based, 7 7 2 header aligned like general_bead, 7 8 2 total_data_elements fixed binary (21), /* length of ,[value] in APL */ 7 9 2 rhorho fixed binary, /* number of dimensions of value */ 7 10 2 data_pointer pointer unaligned, /* packed pointer to the data in value */ 7 11 2 rho fixed binary (21) dimension (number_of_dimensions refer (value_bead.rhorho)); 7 12 /* dimensions of value (zero-origin) */ 7 13 7 14 7 15 declare 1 character_data_structure aligned based, /* alignment trick for PL/I compiler */ 7 16 2 character_datum character (1) unaligned dimension (0:data_elements - 1); 7 17 /* actual elements of character array */ 7 18 7 19 declare character_string_overlay character (data_elements) aligned based; 7 20 /* to overlay on above structure */ 7 21 7 22 7 23 declare numeric_datum float aligned dimension (0:data_elements - 1) based; 7 24 /* actual elements of numeric array */ 7 25 7 26 declare complex_datum complex float aligned dimension (0:data_elements -1) based; 7 27 7 28 declare MAX_VALUE_BEAD_SIZE fixed bin (19) init (261120) int static options (constant); 7 29 7 30 /* ------ END INCLUDE SEGMENT apl_value_bead.incl.pl1 ----------------------------------- */ 852 8 1 /* ====== BEGIN INCLUDE SEGMENT apl_function_bead.incl.pl1 ================================ */ 8 2 8 3 /* This bead is used by apl to store the source code for user-defined functions */ 8 4 8 5 declare 1 function_bead aligned based, 8 6 8 7 2 header aligned like general_bead, 8 8 8 9 2 lexed_function_bead_pointer unaligned pointer, /* null if unlexed or has errors, else -> lexed code */ 8 10 2 class fixed bin, /* 0=normal, 1=locked, 2=external zfn, 3=mfn, 4=dfn */ 8 11 2 stop_control_pointer unaligned ptr, /* points to stop value bead, or null (no stop control) */ 8 12 2 trace_control_pointer unaligned ptr, /* points to trace value bead, or null (no trace control) */ 8 13 2 text_length fixed bin(21), /* length of function text */ 8 14 2 text aligned char(data_elements refer (function_bead.text_length)); 8 15 /* the user's code exactly as typed in */ 8 16 8 17 /* ------ END INCLUDE SEGMENT apl_function_bead.incl.pl1 -------------------------------- */ 853 9 1 /* ====== BEGIN INCLUDE SEGMENT apl_lexed_function_bead.incl.pl1 ========================== */ 9 2 9 3 /* this is the format of a user-defined function after it has been run 9 4* through apl_lex_, the first (left to right) parsing phase. */ 9 5 9 6 dcl 1 lexed_function_bead based aligned, 9 7 2 header like general_bead, /* type bits, etc. */ 9 8 9 9 2 name pointer unaligned, /* -> symbol bead which names the function */ 9 10 2 bits_for_parse unaligned like operator_bead.bits_for_parse, /* so can treat like system function */ 9 11 2 number_of_statements fixed bin, 9 12 2 number_of_localized_symbols fixed bin, /* including labels and parameter variables, return var */ 9 13 /* even if they aren't there, thus >_ 3 */ 9 14 2 number_of_labels fixed bin, 9 15 2 label_values_ptr pointer unaligned, /* -> label_values below */ 9 16 2 statement_map_ptr pointer unaligned, /* -> statement_map below */ 9 17 2 lexeme_array_ptr pointer unaligned, /* -> lexeme_array below */ 9 18 9 19 /* the first 3 localized symbols are always reserved for ReturnSymbol, LeftArgSymbol, RighArgSymbol respectively. 9 20* If some of these symbols are not present (e.g. monadic or value-less function), null pointers are used. 9 21* So beware!, there can be null ptrs in the localized_symbols array. */ 9 22 9 23 2 localized_symbols( (0) refer (lexed_function_bead.number_of_localized_symbols)) pointer unaligned, 9 24 /* first localized vars from header line, then labels */ 9 25 2 label_values ( (0) refer (lexed_function_bead.number_of_labels)) pointer unaligned, 9 26 /* ptrs to label-value beads for labels */ 9 27 2 statement_map ( (0) refer (lexed_function_bead.number_of_statements)) fixed bin(18), 9 28 /* index in lexeme_array of rightmost lexeme of each stmt */ 9 29 2 lexeme_array ( (0) refer (lexed_function_bead.number_of_labels) /* not really, but fake out compiler */ ) pointer unaligned; 9 30 /* the actual lexemes. Length of array is 9 31* statement_map(number_of_statements) */ 9 32 9 33 9 34 /* manifest constants for first 3 localized symbols */ 9 35 9 36 dcl (ReturnSymbol init(1), 9 37 LeftArgSymbol init(2), 9 38 RightArgSymbol init(3) 9 39 ) fixed binary static; 9 40 9 41 9 42 /* the last three parts of this bead are referenced separately, though ptrs earlier in the bead. 9 43* Here are declarations for them as level-1 structures */ 9 44 9 45 dcl 1 lexed_function_label_values_structure based aligned, 9 46 2 lexed_function_label_values ( 500 /* or so */ ) pointer unaligned, 9 47 9 48 statement_count fixed bin, 9 49 lexed_function_statement_map (statement_count) fixed bin(18) aligned based, 9 50 9 51 1 lexed_function_lexemes_structure based aligned, 9 52 2 lexed_function_lexeme_array ( 500 /* or so */ ) pointer unaligned; 9 53 9 54 /* ------ END INCLUDE SEGMENT apl_lexed_function_bead.incl.pl1 -------------------------- */ 854 10 1 /* ====== BEGIN INCLUDE SEGMENT apl_parse_frame.incl.pl1 ================================== */ 10 2 10 3 declare 1 parse_frame aligned based (parse_frame_ptr), 10 4 2 last_parse_frame_ptr ptr unaligned, /* pointer to last parse frame, or null */ 10 5 2 parse_frame_type fixed bin, /* suspended, function, eval input, etc. */ 10 6 2 function_bead_ptr ptr unaligned, /* ptr to function bead */ 10 7 2 lexed_function_bead_ptr ptr unaligned, /* ptr to lexed function bead */ 10 8 2 reduction_stack_ptr ptr unaligned, /* ptr to reduction stack for this frame */ 10 9 2 current_parseme fixed bin, /* element of reduction stack that is top of stack */ 10 10 2 current_lexeme fixed bin, /* element number of current lexeme */ 10 11 2 current_line_number fixed bin, /* line number being executed */ 10 12 2 return_point fixed bin, /* where to join the reductions on return */ 10 13 2 put_result fixed bin, /* where to put the value when returning to this frame */ 10 14 2 print_final_value bit(1) aligned, /* if true, print final value on line */ 10 15 2 initial_value_stack_ptr ptr unaligned, /* for cleaning up the value stack */ 10 16 2 number_of_ptrs fixed bin, /* number of old meaning ptrs */ 10 17 2 old_meaning_ptrs dim (number_of_ptrs refer (parse_frame.number_of_ptrs)) ptr unaligned; 10 18 /* old meanings for local variables. */ 10 19 10 20 declare number_of_ptrs fixed bin; 10 21 10 22 declare (suspended_frame_type init (1), /* for comparison with parse frame type */ 10 23 function_frame_type init (2), 10 24 evaluated_frame_type init (3), 10 25 execute_frame_type init (4), 10 26 save_frame_type init (5) 10 27 ) fixed bin internal static options (constant); 10 28 10 29 declare reductions_pointer pointer; 10 30 10 31 declare 10 32 1 reduction_stack aligned dim (1000) based (reductions_pointer), 10 33 2 type fixed bin, /* type of parseme */ 10 34 2 bits unaligned like operator_bead.bits_for_parse, 10 35 2 semantics ptr unaligned, 10 36 2 lexeme fixed bin, 10 37 10 38 1 reduction_stack_for_op aligned dim (1000) based (reductions_pointer), 10 39 2 type fixed bin, 10 40 2 bits unaligned like operator_bead.bits_for_parse, 10 41 2 semantics fixed bin, 10 42 2 lexeme fixed bin, 10 43 10 44 (eol_type init(0), /* parseme types - end of line */ 10 45 bol_type init(1), /* begining of line */ 10 46 val_type init(2), /* value */ 10 47 op_type init(3), /* op */ 10 48 open_paren_type init(4), 10 49 close_paren_type init(5), 10 50 open_bracket_type init(6), 10 51 close_subscript_type init(7), 10 52 close_rank_type init(8), 10 53 semi_colon_type init(9), 10 54 diamond_type init (10), 10 55 subscript_type init (11)) fixed bin internal static options (constant); 10 56 10 57 /* ------ END INCLUDE SEGMENT apl_parse_frame.incl.pl1 ---------------------------------- */ 855 856 857 dcl parse_frame_ptr ptr; /* crock */ 858 11 1 /* ====== BEGIN INCLUDE SEGMENT apl_characters.incl.pl1 =================================== */ 11 2 11 3 /* 11 4* * This include file contains all the characters in the APL character set, 11 5* * declared char(1) [Instead of fixed bin as in the apl_character_codes.incl.pl1 file] 11 6* * 11 7* Modified 780913 by PG to add CentSign 11 8* Modified 790319 by PG to add CommaHyphen 11 9* */ 11 10 11 11 declare ( 11 12 QBell init(""), 11 13 QBackSpace init(""), 11 14 QTab init(" "), 11 15 QNewLine init(" 11 16 "), 11 17 QSpace init(" "), 11 18 QExclamation init("!"), 11 19 QDollar init("$"), 11 20 QApostrophe init("'"), 11 21 QLeftParen init("("), 11 22 QRightParen init(")"), 11 23 QStar init("*"), 11 24 QPlus init("+"), 11 25 QComma init(","), 11 26 QMinus init("-"), 11 27 QPeriod init("."), 11 28 QSlash init("/"), 11 29 QZero init("0"), 11 30 QOne init("1"), 11 31 QTwo init("2"), 11 32 QThree init("3"), 11 33 QFour init("4"), 11 34 QFive init("5"), 11 35 QSix init("6"), 11 36 QSeven init("7"), 11 37 QEight init("8"), 11 38 QNine init("9"), 11 39 QColon init(":"), 11 40 QSemiColon init(";"), 11 41 QLessThan init("<"), 11 42 QEqual init("="), 11 43 QGreaterThan init(">"), 11 44 QQuestion init("?"), 11 45 QLetterA_ init("A"), 11 46 QLetterB_ init("B"), 11 47 QLetterC_ init("C"), 11 48 QLetterD_ init("D"), 11 49 QLetterE_ init("E"), 11 50 QLetterF_ init("F"), 11 51 QLetterG_ init("G"), 11 52 QLetterH_ init("H"), 11 53 QLetterI_ init("I"), 11 54 QLetterJ_ init("J"), 11 55 QLetterK_ init("K"), 11 56 QLetterL_ init("L"), 11 57 QLetterM_ init("M"), 11 58 QLetterN_ init("N"), 11 59 QLetterO_ init("O"), 11 60 QLetterP_ init("P"), 11 61 QLetterQ_ init("Q"), 11 62 QLetterR_ init("R"), 11 63 QLetterS_ init("S"), 11 64 QLetterT_ init("T"), 11 65 QLetterU_ init("U"), 11 66 QLetterV_ init("V"), 11 67 QLetterW_ init("W"), 11 68 QLetterX_ init("X"), 11 69 QLetterY_ init("Y"), 11 70 QLetterZ_ init("Z"), 11 71 QLeftBracket init("["), 11 72 QBackSlash init("\"), 11 73 QRightBracket init("]"), 11 74 QUnderLine init("_"), 11 75 QLetterA init("a"), 11 76 QLetterB init("b"), 11 77 QLetterC init("c"), 11 78 QLetterD init("d"), 11 79 QLetterE init("e"), 11 80 QLetterF init("f"), 11 81 QLetterG init("g"), 11 82 QLetterH init("h"), 11 83 QLetterI init("i"), 11 84 QLetterJ init("j"), 11 85 QLetterK init("k"), 11 86 QLetterL init("l"), 11 87 QLetterM init("m"), 11 88 QLetterN init("n"), 11 89 QLetterO init("o"), 11 90 QLetterP init("p"), 11 91 QLetterQ init("q"), 11 92 QLetterR init("r"), 11 93 QLetterS init("s"), 11 94 QLetterT init("t"), 11 95 QLetterU init("u"), 11 96 QLetterV init("v"), 11 97 QLetterW init("w"), 11 98 QLetterX init("x"), 11 99 QLetterY init("y"), 11 100 QLetterZ init("z"), 11 101 QLeftBrace init("{"), 11 102 QVerticalBar init("|"), 11 103 QRightBrace init("}"), 11 104 QTilde init("~"), 11 105 QLessOrEqual init("€"), 11 106 QGreaterOrEqual init(""), 11 107 QNotEqual init("‚"), 11 108 QOrSign init("ƒ"), 11 109 QAndSign init("„"), 11 110 QDivision init("…"), 11 111 QEpsilon init("†"), 11 112 QUpArrow init("‡"), 11 113 QDownArrow init("ˆ"), 11 114 QCircle init("‰"), 11 115 QCeiling init("Š"), 11 116 QFloor init("‹"), 11 117 QDelta init("Œ"), 11 118 QSmallCircle init(""), 11 119 QQuad init("Ž"), 11 120 QCap init(""), 11 121 QDeCode init(""), 11 122 QEnCode init("‘"), 11 123 QLeftLump init("’"), 11 124 QRightLump init("“"), 11 125 QCup init("”"), 11 126 QNorSign init("•"), 11 127 QNandSign init("–"), 11 128 QCircleHyphen init("—"), 11 129 QSlashHyphen init("˜"), 11 130 QDelTilde init("™"), 11 131 QCircleStar init("š"), 11 132 QCircleBar init("›"), 11 133 QCircleBackSlash init("œ"), 11 134 QCircleSlash init(""), 11 135 QGradeDown init("ž"), 11 136 QGradeUp init("Ÿ"), 11 137 QLamp init(" "), 11 138 QQuadQuote init("¡"), 11 139 QIBeam init("¢"), 11 140 QBackSlashHyphen init("£"), 11 141 QDomino init("¤"), 11 142 QDiaresis init("¥"), 11 143 QOmega init("¦"), 11 144 QIota init("§"), 11 145 QRho init("¨"), 11 146 QTimes init("©"), 11 147 QAlpha init("ª"), 11 148 QUpperMinus init("«"), 11 149 QDel init("¬"), 11 150 QLeftArrow init("­"), 11 151 QRightArrow init("®"), 11 152 QDiamond init("¯"), 11 153 QZero_ init("°"), 11 154 QOne_ init("±"), 11 155 QTwo_ init("²"), 11 156 QThree_ init("³"), 11 157 QFour_ init("´"), 11 158 QFive_ init("µ"), 11 159 QSix_ init("¶"), 11 160 QSeven_ init("·"), 11 161 QEight_ init("¸"), 11 162 QNine_ init("¹"), 11 163 QDelta_ init("º"), 11 164 QMarkError init("»"), 11 165 QExecuteSign init("¼"), 11 166 QFormatSign init("½"), 11 167 QLeftTack init("¾"), 11 168 QRightTack init("¿"), 11 169 QLineFeed init("À"), 11 170 QConditionalNewLine init("Á"), 11 171 QCentSign init("Â"), 11 172 QCommaHyphen init("Ã") 11 173 ) char(1) internal static options (constant); 11 174 11 175 /* ------ END INCLUDE SEGMENT apl_characters.incl.pl1 ----------------------------------- */ 859 12 1 /* BEGIN INCLUDE FILE apl_symbol_table.incl.pl1 12 2* 12 3* initially written 20 June 1973 by Dan Bricklin */ 12 4 12 5 declare 12 6 initial_size fixed bin int static init(17), /* initial size of hash table */ 12 7 12 8 1 symbol_table aligned based(ws_info.symbol_table_ptr), 12 9 2 table_size fixed bin, /* how many buckets */ 12 10 2 hash_bucket_ptr(initial_size refer(table_size)) ptr unaligned; /* the buckets */ 12 11 12 12 /* END INCLUDE FILE apl_symbol_table.incl.pl1 */ 860 13 1 /* ====== BEGIN INCLUDE SEGMENT apl_symbol_bead.incl.pl1 ================================== */ 13 2 13 3 /* Explanation of fields: 13 4* symbol_bead.hash_link_pointer points to next symbol in same hash bucket in the symbol table. 13 5* symbol_bead.meaning_pointer points to current "value" of this name: 13 6* = null => unused (e.g. undefined variable) 13 7* -> group bead => group name 13 8* -> value bead => variable with a value 13 9* -> function bead => function name 13 10* -> label bead => localized label value 13 11* -> shared var bead => shared variable */ 13 12 13 13 declare 1 symbol_bead aligned based, 13 14 2 header aligned like general_bead, 13 15 2 hash_link_pointer pointer unaligned, 13 16 2 meaning_pointer pointer unaligned, 13 17 2 name_length fixed binary, 13 18 2 name character (0 refer (symbol_bead.name_length)) unaligned; 13 19 13 20 /* ------ END INCLUDE SEGMENT apl_symbol_bead.incl.pl1 ---------------------------------- */ 861 14 1 /* BEGIN INCLUDE FILE ... cp_active_string_types.incl.pl1 */ 14 2 /* Created: 5 May 1980 by G. Palter */ 14 3 14 4 /* Types of active strings recognized by active string evaluation entries of the Multics command processor */ 14 5 14 6 dcl (DEFAULT_ACTIVE_STRING initial (0), /* default type: same as NORMAL_ACTIVE_STRING */ 14 7 NORMAL_ACTIVE_STRING initial (1), /* normal active string: [...] */ 14 8 TOKENS_ONLY_ACTIVE_STRING initial (2), /* rescan active string for whitespace and quotes: |[...] */ 14 9 ATOMIC_ACTIVE_STRING initial (3)) /* do not rescan anything in value: ||[...] */ 14 10 fixed binary static options (constant); 14 11 14 12 /* END INCLUDE FILE ... cp_active_string_types.incl.pl1 */ 862 863 864 865 866 end apl_system_functions_; SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 11/29/83 1347.3 apl_system_functions_.pl1 >special_ldd>on>apl.1129>apl_system_functions_.pl1 207 1 03/27/82 0429.8 apl_push_stack_fcn.incl.pl1 >ldd>include>apl_push_stack_fcn.incl.pl1 847 2 03/27/82 0429.8 apl_number_data.incl.pl1 >ldd>include>apl_number_data.incl.pl1 848 3 03/27/82 0439.2 apl_ws_info.incl.pl1 >ldd>include>apl_ws_info.incl.pl1 849 4 03/27/82 0438.5 apl_bead_format.incl.pl1 >ldd>include>apl_bead_format.incl.pl1 850 5 03/27/82 0439.0 apl_operators_argument.incl.pl1 >ldd>include>apl_operators_argument.incl.pl1 851 6 03/27/82 0439.0 apl_operator_bead.incl.pl1 >ldd>include>apl_operator_bead.incl.pl1 852 7 03/27/82 0439.2 apl_value_bead.incl.pl1 >ldd>include>apl_value_bead.incl.pl1 853 8 03/27/82 0438.7 apl_function_bead.incl.pl1 >ldd>include>apl_function_bead.incl.pl1 854 9 03/27/82 0438.7 apl_lexed_function_bead.incl.pl1 >ldd>include>apl_lexed_function_bead.incl.pl1 855 10 03/27/82 0439.0 apl_parse_frame.incl.pl1 >ldd>include>apl_parse_frame.incl.pl1 859 11 03/27/82 0438.6 apl_characters.incl.pl1 >ldd>include>apl_characters.incl.pl1 860 12 03/27/82 0439.2 apl_symbol_table.incl.pl1 >ldd>include>apl_symbol_table.incl.pl1 861 13 03/27/82 0439.2 apl_symbol_bead.incl.pl1 >ldd>include>apl_symbol_bead.incl.pl1 862 14 09/22/80 1256.7 cp_active_string_types.incl.pl1 >ldd>include>cp_active_string_types.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. NORMAL_ACTIVE_STRING 000026 constant fixed bin(17,0) initial dcl 14-6 set ref 694* P_n_words parameter fixed bin(19,0) dcl 1-16 ref 1-4 1-35 QNewLine constant char(1) initial unaligned dcl 11-11 ref 105 128 570 QSpace 003034 constant char(1) initial unaligned dcl 11-11 ref 556 abs builtin function dcl 838 ref 349 351 active_function_error 000230 stack reference condition dcl 844 ref 685 697 addr builtin function dcl 838 ref 72 244 586 586 addrel builtin function dcl 838 in procedure "apl_system_functions_" ref 73 177 181 198 200 245 addrel builtin function dcl 1-25 in procedure "apl_push_stack_" ref 1-44 apl_allocate_words_ 000034 constant entry external dcl 806 ref 577 apl_error_table_$domain 000046 external static fixed bin(35,0) dcl 828 ref 731 apl_error_table_$exec_restricted 000050 external static fixed bin(35,0) dcl 828 ref 673 apl_error_table_$no_sv 000052 external static fixed bin(35,0) dcl 828 set ref 647* apl_free_bead_ 000016 constant entry external dcl 806 ref 156 521 608 635 apl_function_lex_no_messages_ 000036 constant entry external dcl 806 ref 586 apl_get_next_value_stack_seg_ 000020 constant entry external dcl 806 ref 563 apl_get_symbol_ 000030 constant entry external dcl 806 ref 318 apl_get_value_stack_ 000056 constant entry external dcl 1-30 ref 1-40 apl_number 000136 automatic float bin(63) dcl 745 set ref 47* 57* 65 76 225 278* 283* 285* 287* 289* 291* 486 506* 509* 511* 524* 530* 532* 592* 641* apl_pendant_function_check_ 000032 constant entry external dcl 806 ref 526 602 apl_quit_ 000222 stack reference condition dcl 843 ref 52 54 apl_scan_ 000026 constant entry external dcl 806 ref 305 311 apl_segment_manager_$free 000024 constant entry external dcl 806 ref 719 apl_segment_manager_$get 000022 constant entry external dcl 806 ref 683 apl_static_$ws_info_ptr 000054 external static structure level 1 dcl 3-11 apl_system_error_ 000040 constant entry external dcl 806 ref 647 bead_type based structure level 3 packed unaligned dcl 4-3 binary builtin function dcl 1-25 ref 1-40 bits_for_parse 1 based structure level 2 packed unaligned dcl 6-3 block_ptr 000276 automatic pointer dcl 1-20 set ref 1-43* 1-45 character_string_overlay based char dcl 7-19 set ref 130* 172 318 318 385 421* 455 459* 459 556 568 626* 665 669* 669 694 718* 722* character_value 0(09) based bit(1) level 5 packed unaligned dcl 7-3 set ref 79 211 330 472 536 653 character_value_type constant bit(18) initial unaligned dcl 4-30 ref 178 class 3 based fixed bin(17,0) level 2 dcl 8-5 set ref 95 580* clock builtin function dcl 838 ref 51 57 code 000100 automatic fixed bin(35,0) dcl 741 set ref 678* 688 688* 694* 706 708* 715 convert_status_code_ 000010 constant entry external dcl 797 ref 708 cu_$cp 000012 constant entry external dcl 797 ref 678 cu_$evaluate_active_string 000042 constant entry external dcl 806 ref 694 current_parse_frame_ptr 15 based pointer level 3 packed unaligned dcl 3-16 ref 586 586 586 586 current_parseme 5 based fixed bin(17,0) level 2 dcl 10-3 ref 586 586 data_elements 000151 automatic fixed bin(21,0) dcl 745 set ref 84* 85 114* 130 142* 172 172 180 190 196 218* 249 249 318 318 385 421 431* 454* 455 455 459 459 459 479* 556 568 576* 577 577 582 616* 619 623 626 664* 665 665 669 669 678* 680* 694 699* 710* 715 718 722 724 725 data_pointer 4 based pointer level 2 packed unaligned dcl 7-3 set ref 34 75* 181* 203* 247* 335 data_type 0(08) based structure level 4 packed unaligned dcl 7-3 divide builtin function dcl 838 ref 563 563 do_functions 000177 automatic bit(1) unaligned dcl 745 set ref 341* 358* 401 do_labels 000175 automatic bit(1) unaligned dcl 745 set ref 341* 354* 392 do_variables 000176 automatic bit(1) unaligned dcl 745 set ref 341* 356* 397 error_code 7 parameter fixed bin(35,0) level 2 dcl 5-3 set ref 673* 731* error_line 000220 automatic fixed bin(17,0) dcl 745 set ref 586* 592 error_table_$badcall 000044 external static fixed bin(35,0) dcl 828 ref 688 errors_occurred 000217 automatic bit(1) dcl 745 set ref 586* 590 fbp 000156 automatic pointer unaligned dcl 745 set ref 577* 578 579 580 581 581 582 583 586 598 600 610 634 634 635 635* fcn_text based char dcl 745 set ref 564* 564 568* 570* 583 fcn_text_ptr 000211 automatic pointer unaligned dcl 745 set ref 548* 549 564 565* 566 568 570 583 final_result 000146 automatic pointer dcl 745 set ref 244* 245 245* 245 247 249 457* 459 462 683* 694 699 718 719* final_result_vb 000150 automatic pointer unaligned dcl 745 set ref 235* 238 239 240 241 241 244 244 247 253 fixed builtin function dcl 838 ref 53 53 353 549 566 fixnum 000200 automatic fixed bin(17,0) dcl 745 set ref 353* 354 356 358 float builtin function dcl 838 ref 57 float_index_origin 10 based float bin(63) level 3 dcl 3-16 ref 641 float_temp 000202 automatic float bin(63) dcl 745 set ref 348* 349 351 353 floor builtin function dcl 838 ref 348 function 0(03) based bit(1) level 4 packed unaligned dcl 4-3 ref 93 289 401 526 602 function_bead based structure level 1 dcl 8-5 set ref 577 577 function_type constant bit(18) initial unaligned dcl 4-30 ref 578 general_bead based structure level 1 dcl 4-3 hash_bucket_ptr 1 based pointer array level 2 packed unaligned dcl 12-5 ref 378 378 380 hash_link_pointer 2 based pointer level 2 packed unaligned dcl 13-13 ref 406 hbound builtin function dcl 838 ref 378 header based structure level 2 in structure "value_bead" dcl 7-3 in procedure "apl_system_functions_" header based structure level 2 in structure "symbol_bead" dcl 13-13 in procedure "apl_system_functions_" header based structure level 2 in structure "function_bead" dcl 8-5 in procedure "apl_system_functions_" htpos 000207 automatic fixed bin(17,0) dcl 745 set ref 378* 380* i 000166 automatic fixed bin(21,0) dcl 745 set ref 347* 347* 348 349* in_row 000214 automatic fixed bin(21,0) dcl 745 set ref 552* 552* 553* index builtin function dcl 838 ref 105 128 385 index_origin 4 based fixed bin(17,0) level 3 dcl 3-16 ref 592 integer_fuzz 22 based float bin(63) level 2 dcl 3-16 ref 349 integral_value_type constant bit(18) initial unaligned dcl 4-30 ref 209 594 644 label 0(05) based bit(1) level 4 packed unaligned dcl 4-3 ref 285 392 511 lbound builtin function dcl 838 ref 378 left 000173 automatic pointer unaligned dcl 745 set ref 335* 385 459 462* left_size 000174 automatic fixed bin(21,0) dcl 745 set ref 336* 385 454 left_vb 000172 automatic pointer unaligned dcl 745 set ref 323* 325 330 332 335 336 365 385 435 439 450 lexed_function_bead based structure level 1 dcl 9-6 lexed_function_bead_pointer 2 based pointer level 2 packed unaligned dcl 8-5 set ref 579* 598* lfbp 000157 automatic pointer unaligned dcl 745 set ref 586* 598 599 line_number 000164 automatic fixed bin(21,0) dcl 745 set ref 126* 126* 130* line_pos 000162 automatic fixed bin(21,0) dcl 745 set ref 103* 103* 105* 110 125* 128 130 132* 132 421 422* 422 446* long_message 000101 automatic char(100) dcl 741 set ref 708* 710 722 max_line_length 000160 automatic fixed bin(21,0) dcl 745 set ref 101* 107 107* 112* 112 114 121 130 130 maximum_value_stack_size 13 based fixed bin(18,0) level 3 dcl 3-16 ref 549 566 1-40 meaning_pointer 3 based pointer level 2 packed unaligned dcl 13-13 set ref 91 93 95 103 105 128 130 283 285 287 289 392 392 397 401 509 511 513 518 518 521 521* 523* 526 526* 600 600* 602 602* 606 606 608 608* 610* n_cols 000205 automatic fixed bin(21,0) dcl 745 set ref 373* 417 417* 421 422 431 444 543* 553 554 n_dims parameter fixed bin(17,0) dcl 167 ref 162 171 n_rows 000204 automatic fixed bin(21,0) dcl 745 set ref 373* 416* 416 431 443 542* 552 n_words 000142 automatic fixed bin(19,0) dcl 745 set ref 65* 66* 172* 174* 177 190* 192* 235* 455* 457* 665* 667* name 2 based pointer level 2 in structure "lexed_function_bead" packed unaligned dcl 9-6 in procedure "apl_system_functions_" ref 599 name 5 based char level 2 in structure "symbol_bead" packed unaligned dcl 13-13 in procedure "apl_system_functions_" ref 385 421 626 name_len 000152 automatic fixed bin(21,0) dcl 745 set ref 85* 221* 223 266* 305 305 311 311 482* 484 497* name_length 4 based fixed bin(17,0) level 2 dcl 13-13 ref 385 417 417 421 616 626 name_no_good 000154 automatic bit(1) unaligned dcl 745 set ref 88 278 308* 314* 319* 506 name_pos 000153 automatic fixed bin(21,0) dcl 745 set ref 86* 223* 267* 305 305 305 311 311 484* 498* name_string based char dcl 301 set ref 305* 311* null builtin function dcl 838 ref 91 283 305 305 311 311 325 365 380 385 392 435 450 509 523 579 581 600 694 694 num_words 000300 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 000240 automatic fixed bin(17,0) dcl 7-3 set ref 64* 65 171* 172 179 181 189* 190 198 number_of_lines 000161 automatic fixed bin(21,0) dcl 745 set ref 102* 109* 109 114 120 126 number_type 000134 automatic bit(18) unaligned dcl 745 set ref 38* 69 209* 470* 594* 644* numeric_datum based float bin(63) array dcl 7-23 set ref 45 53 53 76* 190 225* 249* 249 348 349 486* numeric_value 0(10) based bit(1) level 5 packed unaligned dcl 7-3 set ref 40 342 numeric_value_type constant bit(18) initial unaligned dcl 4-30 ref 38 195 on_stack 1 parameter bit(1) array level 3 dcl 5-3 ref 60 115 144 230 365 368 435 435 450 617 op1 5(27) parameter fixed bin(8,0) level 3 packed unaligned dcl 5-3 ref 36 676 operands parameter structure array level 2 dcl 5-3 operator 4 parameter structure level 2 dcl 5-3 operator_bead based structure level 1 dcl 6-3 operators_argument parameter structure level 1 dcl 5-3 set ref 12 out_pos 000212 automatic fixed bin(21,0) dcl 745 set ref 551* 563 563 564 564 568 568 570 570 571* 571 576 583 parse_frame based structure level 1 dcl 10-3 pass 000206 automatic fixed bin(2,0) dcl 745 set ref 374* 414 426* pointers 14 based structure level 2 dcl 3-16 reduction_stack based structure array level 1 dcl 10-31 set ref 586 586 reduction_stack_ptr 4 based pointer level 2 packed unaligned dcl 10-3 ref 586 586 reference_count 1 based fixed bin(29,0) level 2 in structure "general_bead" dcl 4-3 in procedure "apl_system_functions_" set ref 518* 518 521 606* 606 608 reference_count 1 based fixed bin(29,0) level 3 in structure "function_bead" dcl 8-5 in procedure "apl_system_functions_" set ref 634* 634 635 reference_count 1 based fixed bin(29,0) level 3 in structure "symbol_bead" dcl 13-13 in procedure "apl_system_functions_" set ref 155* 155 156 rel builtin function dcl 838 in procedure "apl_system_functions_" ref 73 200 245 549 566 rel builtin function dcl 1-25 in procedure "apl_push_stack_" ref 1-40 restrict_exec_command 1(03) based bit(1) level 3 packed unaligned dcl 3-16 ref 671 result 000144 automatic pointer dcl 745 in procedure "apl_system_functions_" set ref 72* 73 73* 73 75 76 130 181* 198* 200 200* 200 203 225 249 421 486 626 667* 669 678 694 704 718 722 result 6 parameter pointer level 2 in structure "operators_argument" packed unaligned dcl 5-3 in procedure "apl_system_functions_" set ref 67* 175* 193* 253* result_vb 000143 automatic pointer unaligned dcl 745 set ref 66* 67 69 70 71 72 75 120 121 147 147 174* 175 177 178 179 180 181 181 192* 193 195 196 196 197 198 203 238 239 240 241 443 444 623 724 725 return_string based varying char(262140) dcl 741 set ref 694* 699 718 rho 5 based fixed bin(21,0) array level 2 dcl 7-3 set ref 72 120* 121* 147* 147* 196* 218 221 222 241* 241 244 443* 444* 479 482 483 542 543 623* 724* rhorho 3 based fixed bin(17,0) level 2 dcl 7-3 set ref 71* 82 179* 197* 213 240* 240 241 241 244 259 332 344 474 491 539 658 right 000133 automatic pointer unaligned dcl 745 set ref 34* 45 53 53 305 311 318 318 348 349 556 568 669 right_vb 000132 automatic pointer unaligned dcl 745 set ref 33* 34 40 42 60 79 82 84 115 144 211 213 218 221 222 234 259 266 342 344 347 365 368 435 472 474 479 482 483 491 497 536 539 542 543 617 653 658 664 row_length 000216 automatic fixed bin(21,0) dcl 745 set ref 554* 554* 556* 559 563 563 568 568 570 571 row_pos 000215 automatic fixed bin(21,0) dcl 745 set ref 553* 556 568 sbp 000155 automatic pointer unaligned dcl 745 set ref 91 93 95 103 105 128 130 155 155 156 156* 283 285 287 289 318* 380* 380* 385 392 392 397 401* 406 417 417 421 509 511 513 518 518 521 521 523 526 526 599* 600 600 602 602 606 606 608 608 610 616 626 size builtin function dcl 838 ref 65 65 172 172 181 190 190 198 455 577 577 665 space_left_in_stack 000213 automatic fixed bin(21,0) dcl 745 set ref 549* 559* 559 561 566* start_of_sleep_time 000140 automatic fixed bin(71,0) dcl 745 set ref 51* 57 static_ws_info_ptr 000054 external static pointer level 2 packed unaligned dcl 3-11 ref 3-7 stop_control_pointer 4 based pointer level 2 packed unaligned dcl 8-5 set ref 581* string builtin function dcl 838 set ref 69* 178* 195* 238* 238 578* substr builtin function dcl 838 in procedure "apl_system_functions_" set ref 73 105 128 130* 130 200 245 318 318 385 385 421* 556 568* 568 570* substr builtin function dcl 1-25 in procedure "apl_push_stack_" ref 1-37 switches 1 based structure level 2 packed unaligned dcl 3-16 symbol_bead based structure level 1 dcl 13-13 symbol_table based structure level 1 dcl 12-5 symbol_table_ptr 14 based pointer level 3 packed unaligned dcl 3-16 ref 378 378 380 table_size based fixed bin(17,0) level 2 dcl 12-5 ref 378 text 7 based char level 2 dcl 8-5 set ref 105 128 130 583* 586* text_length 6 based fixed bin(21,0) level 2 dcl 8-5 set ref 103 105 128 130 582* 583 586 586 this_line_length 000163 automatic fixed bin(21,0) dcl 745 set ref 105* 107 107 110 128* 130 132 timer_manager_$sleep 000014 constant entry external dcl 797 ref 53 token_len 000170 automatic fixed bin(21,0) dcl 745 set ref 305* 311 318 318 token_pos 000167 automatic fixed bin(21,0) dcl 745 set ref 305* 311 318 318 token_type 000171 automatic fixed bin(17,0) dcl 745 set ref 305* 306 311* 312 total_data_elements 2 based fixed bin(21,0) level 2 dcl 7-3 set ref 42 70* 84 180* 196* 239* 239 266 336 347 497 664 725* trace_control_pointer 5 based pointer level 2 packed unaligned dcl 8-5 set ref 581* type based structure level 2 in structure "general_bead" packed unaligned dcl 4-3 in procedure "apl_system_functions_" type based structure level 3 in structure "lexed_function_bead" packed unaligned dcl 9-6 in procedure "apl_system_functions_" type based structure level 3 in structure "symbol_bead" packed unaligned dcl 13-13 in procedure "apl_system_functions_" type based structure level 3 in structure "function_bead" packed unaligned dcl 8-5 in procedure "apl_system_functions_" set ref 578* type based structure level 3 in structure "value_bead" packed unaligned dcl 7-3 in procedure "apl_system_functions_" set ref 69* 178* 195* 238* 238 unspec builtin function dcl 1-25 ref 1-37 value 0(02) based bit(1) level 4 in structure "general_bead" packed unaligned dcl 4-3 in procedure "apl_system_functions_" ref 287 397 513 value parameter pointer array level 3 in structure "operators_argument" packed unaligned dcl 5-3 in procedure "apl_system_functions_" ref 33 323 value_bead based structure level 1 dcl 7-3 set ref 65 172 181 190 198 value_stack_popper 000210 automatic pointer unaligned dcl 745 set ref 547* 584 value_stack_ptr 16 based pointer level 3 packed unaligned dcl 3-16 set ref 60* 115* 144* 177* 234* 365* 368* 435* 439* 547 548 564 565 584* 617* 704* 1-40 1-43 1-44* 1-44 values 2 based structure level 2 dcl 3-16 where_error 10 parameter fixed bin(17,0) level 2 dcl 5-3 set ref 729* 729 735* 735 which_name 000165 automatic fixed bin(21,0) dcl 745 set ref 222* 222* 223 225* 483* 483* 484 486* ws_info based structure level 1 dcl 3-16 ws_info_ptr 000236 automatic pointer initial dcl 3-7 set ref 60 115 144 234 349 365 368 378 378 380 435 439 547 548 549 564 565 566 584 586 586 586 586 592 617 641 671 704 3-7* 177 1-40 1-40 1-43 1-44 1-44 zero_or_one_value_type constant bit(18) initial unaligned dcl 4-30 ref 470 NAMES DECLARED BY DECLARE STATEMENT AND NEVER REFERENCED. ATOMIC_ACTIVE_STRING internal static fixed bin(17,0) initial dcl 14-6 Binary internal static bit(1) initial dcl 2-16 DEFAULT_ACTIVE_STRING internal static fixed bin(17,0) initial dcl 14-6 LeftArgSymbol internal static fixed bin(17,0) initial dcl 9-36 MAX_VALUE_BEAD_SIZE internal static fixed bin(19,0) initial dcl 7-28 NumberSize internal static fixed bin(4,0) initial dcl 2-25 QAlpha internal static char(1) initial unaligned dcl 11-11 QAndSign internal static char(1) initial unaligned dcl 11-11 QApostrophe internal static char(1) initial unaligned dcl 11-11 QBackSlash internal static char(1) initial unaligned dcl 11-11 QBackSlashHyphen internal static char(1) initial unaligned dcl 11-11 QBackSpace internal static char(1) initial unaligned dcl 11-11 QBell internal static char(1) initial unaligned dcl 11-11 QCap internal static char(1) initial unaligned dcl 11-11 QCeiling internal static char(1) initial unaligned dcl 11-11 QCentSign internal static char(1) initial unaligned dcl 11-11 QCircle internal static char(1) initial unaligned dcl 11-11 QCircleBackSlash internal static char(1) initial unaligned dcl 11-11 QCircleBar internal static char(1) initial unaligned dcl 11-11 QCircleHyphen internal static char(1) initial unaligned dcl 11-11 QCircleSlash internal static char(1) initial unaligned dcl 11-11 QCircleStar internal static char(1) initial unaligned dcl 11-11 QColon internal static char(1) initial unaligned dcl 11-11 QComma internal static char(1) initial unaligned dcl 11-11 QCommaHyphen internal static char(1) initial unaligned dcl 11-11 QConditionalNewLine internal static char(1) initial unaligned dcl 11-11 QCup internal static char(1) initial unaligned dcl 11-11 QDeCode internal static char(1) initial unaligned dcl 11-11 QDel internal static char(1) initial unaligned dcl 11-11 QDelTilde internal static char(1) initial unaligned dcl 11-11 QDelta internal static char(1) initial unaligned dcl 11-11 QDelta_ internal static char(1) initial unaligned dcl 11-11 QDiamond internal static char(1) initial unaligned dcl 11-11 QDiaresis internal static char(1) initial unaligned dcl 11-11 QDivision internal static char(1) initial unaligned dcl 11-11 QDollar internal static char(1) initial unaligned dcl 11-11 QDomino internal static char(1) initial unaligned dcl 11-11 QDownArrow internal static char(1) initial unaligned dcl 11-11 QEight internal static char(1) initial unaligned dcl 11-11 QEight_ internal static char(1) initial unaligned dcl 11-11 QEnCode internal static char(1) initial unaligned dcl 11-11 QEpsilon internal static char(1) initial unaligned dcl 11-11 QEqual internal static char(1) initial unaligned dcl 11-11 QExclamation internal static char(1) initial unaligned dcl 11-11 QExecuteSign internal static char(1) initial unaligned dcl 11-11 QFive internal static char(1) initial unaligned dcl 11-11 QFive_ internal static char(1) initial unaligned dcl 11-11 QFloor internal static char(1) initial unaligned dcl 11-11 QFormatSign internal static char(1) initial unaligned dcl 11-11 QFour internal static char(1) initial unaligned dcl 11-11 QFour_ internal static char(1) initial unaligned dcl 11-11 QGradeDown internal static char(1) initial unaligned dcl 11-11 QGradeUp internal static char(1) initial unaligned dcl 11-11 QGreaterOrEqual internal static char(1) initial unaligned dcl 11-11 QGreaterThan internal static char(1) initial unaligned dcl 11-11 QIBeam internal static char(1) initial unaligned dcl 11-11 QIota internal static char(1) initial unaligned dcl 11-11 QLamp internal static char(1) initial unaligned dcl 11-11 QLeftArrow internal static char(1) initial unaligned dcl 11-11 QLeftBrace internal static char(1) initial unaligned dcl 11-11 QLeftBracket internal static char(1) initial unaligned dcl 11-11 QLeftLump internal static char(1) initial unaligned dcl 11-11 QLeftParen internal static char(1) initial unaligned dcl 11-11 QLeftTack internal static char(1) initial unaligned dcl 11-11 QLessOrEqual internal static char(1) initial unaligned dcl 11-11 QLessThan internal static char(1) initial unaligned dcl 11-11 QLetterA internal static char(1) initial unaligned dcl 11-11 QLetterA_ internal static char(1) initial unaligned dcl 11-11 QLetterB internal static char(1) initial unaligned dcl 11-11 QLetterB_ internal static char(1) initial unaligned dcl 11-11 QLetterC internal static char(1) initial unaligned dcl 11-11 QLetterC_ internal static char(1) initial unaligned dcl 11-11 QLetterD internal static char(1) initial unaligned dcl 11-11 QLetterD_ internal static char(1) initial unaligned dcl 11-11 QLetterE internal static char(1) initial unaligned dcl 11-11 QLetterE_ internal static char(1) initial unaligned dcl 11-11 QLetterF internal static char(1) initial unaligned dcl 11-11 QLetterF_ internal static char(1) initial unaligned dcl 11-11 QLetterG internal static char(1) initial unaligned dcl 11-11 QLetterG_ internal static char(1) initial unaligned dcl 11-11 QLetterH internal static char(1) initial unaligned dcl 11-11 QLetterH_ internal static char(1) initial unaligned dcl 11-11 QLetterI internal static char(1) initial unaligned dcl 11-11 QLetterI_ internal static char(1) initial unaligned dcl 11-11 QLetterJ internal static char(1) initial unaligned dcl 11-11 QLetterJ_ internal static char(1) initial unaligned dcl 11-11 QLetterK internal static char(1) initial unaligned dcl 11-11 QLetterK_ internal static char(1) initial unaligned dcl 11-11 QLetterL internal static char(1) initial unaligned dcl 11-11 QLetterL_ internal static char(1) initial unaligned dcl 11-11 QLetterM internal static char(1) initial unaligned dcl 11-11 QLetterM_ internal static char(1) initial unaligned dcl 11-11 QLetterN internal static char(1) initial unaligned dcl 11-11 QLetterN_ internal static char(1) initial unaligned dcl 11-11 QLetterO internal static char(1) initial unaligned dcl 11-11 QLetterO_ internal static char(1) initial unaligned dcl 11-11 QLetterP internal static char(1) initial unaligned dcl 11-11 QLetterP_ internal static char(1) initial unaligned dcl 11-11 QLetterQ internal static char(1) initial unaligned dcl 11-11 QLetterQ_ internal static char(1) initial unaligned dcl 11-11 QLetterR internal static char(1) initial unaligned dcl 11-11 QLetterR_ internal static char(1) initial unaligned dcl 11-11 QLetterS internal static char(1) initial unaligned dcl 11-11 QLetterS_ internal static char(1) initial unaligned dcl 11-11 QLetterT internal static char(1) initial unaligned dcl 11-11 QLetterT_ internal static char(1) initial unaligned dcl 11-11 QLetterU internal static char(1) initial unaligned dcl 11-11 QLetterU_ internal static char(1) initial unaligned dcl 11-11 QLetterV internal static char(1) initial unaligned dcl 11-11 QLetterV_ internal static char(1) initial unaligned dcl 11-11 QLetterW internal static char(1) initial unaligned dcl 11-11 QLetterW_ internal static char(1) initial unaligned dcl 11-11 QLetterX internal static char(1) initial unaligned dcl 11-11 QLetterX_ internal static char(1) initial unaligned dcl 11-11 QLetterY internal static char(1) initial unaligned dcl 11-11 QLetterY_ internal static char(1) initial unaligned dcl 11-11 QLetterZ internal static char(1) initial unaligned dcl 11-11 QLetterZ_ internal static char(1) initial unaligned dcl 11-11 QLineFeed internal static char(1) initial unaligned dcl 11-11 QMarkError internal static char(1) initial unaligned dcl 11-11 QMinus internal static char(1) initial unaligned dcl 11-11 QNandSign internal static char(1) initial unaligned dcl 11-11 QNine internal static char(1) initial unaligned dcl 11-11 QNine_ internal static char(1) initial unaligned dcl 11-11 QNorSign internal static char(1) initial unaligned dcl 11-11 QNotEqual internal static char(1) initial unaligned dcl 11-11 QOmega internal static char(1) initial unaligned dcl 11-11 QOne internal static char(1) initial unaligned dcl 11-11 QOne_ internal static char(1) initial unaligned dcl 11-11 QOrSign internal static char(1) initial unaligned dcl 11-11 QPeriod internal static char(1) initial unaligned dcl 11-11 QPlus internal static char(1) initial unaligned dcl 11-11 QQuad internal static char(1) initial unaligned dcl 11-11 QQuadQuote internal static char(1) initial unaligned dcl 11-11 QQuestion internal static char(1) initial unaligned dcl 11-11 QRho internal static char(1) initial unaligned dcl 11-11 QRightArrow internal static char(1) initial unaligned dcl 11-11 QRightBrace internal static char(1) initial unaligned dcl 11-11 QRightBracket internal static char(1) initial unaligned dcl 11-11 QRightLump internal static char(1) initial unaligned dcl 11-11 QRightParen internal static char(1) initial unaligned dcl 11-11 QRightTack internal static char(1) initial unaligned dcl 11-11 QSemiColon internal static char(1) initial unaligned dcl 11-11 QSeven internal static char(1) initial unaligned dcl 11-11 QSeven_ internal static char(1) initial unaligned dcl 11-11 QSix internal static char(1) initial unaligned dcl 11-11 QSix_ internal static char(1) initial unaligned dcl 11-11 QSlash internal static char(1) initial unaligned dcl 11-11 QSlashHyphen internal static char(1) initial unaligned dcl 11-11 QSmallCircle internal static char(1) initial unaligned dcl 11-11 QStar internal static char(1) initial unaligned dcl 11-11 QTab internal static char(1) initial unaligned dcl 11-11 QThree internal static char(1) initial unaligned dcl 11-11 QThree_ internal static char(1) initial unaligned dcl 11-11 QTilde internal static char(1) initial unaligned dcl 11-11 QTimes internal static char(1) initial unaligned dcl 11-11 QTwo internal static char(1) initial unaligned dcl 11-11 QTwo_ internal static char(1) initial unaligned dcl 11-11 QUnderLine internal static char(1) initial unaligned dcl 11-11 QUpArrow internal static char(1) initial unaligned dcl 11-11 QUpperMinus internal static char(1) initial unaligned dcl 11-11 QVerticalBar internal static char(1) initial unaligned dcl 11-11 QZero internal static char(1) initial unaligned dcl 11-11 QZero_ internal static char(1) initial unaligned dcl 11-11 ReturnSymbol internal static fixed bin(17,0) initial dcl 9-36 RightArgSymbol internal static fixed bin(17,0) initial dcl 9-36 TOKENS_ONLY_ACTIVE_STRING internal static fixed bin(17,0) initial dcl 14-6 TheBiggestNumberWeveGot internal static float bin(63) initial dcl 2-16 TheSmallestNumberWeveGot internal static float bin(63) initial dcl 2-16 apl_error_table_$not_implemented external static fixed bin(35,0) dcl 828 bol_type internal static fixed bin(17,0) initial dcl 10-31 character_data_structure based structure level 1 dcl 7-15 close_paren_type internal static fixed bin(17,0) initial dcl 10-31 close_rank_type internal static fixed bin(17,0) initial dcl 10-31 close_subscript_type internal static fixed bin(17,0) initial dcl 10-31 complex_datum based complex float bin(63) array dcl 7-26 complex_value_type internal static bit(18) initial unaligned dcl 4-30 diamond_type internal static fixed bin(17,0) initial dcl 10-31 eol_type internal static fixed bin(17,0) initial dcl 10-31 evaluated_frame_type internal static fixed bin(17,0) initial dcl 10-22 execute_frame_type internal static fixed bin(17,0) initial dcl 10-22 function_frame_type internal static fixed bin(17,0) initial dcl 10-22 group_type internal static bit(18) initial unaligned dcl 4-30 initial_size internal static fixed bin(17,0) initial dcl 12-5 label_type internal static bit(18) initial unaligned dcl 4-30 lexed_function_label_values_structure based structure level 1 dcl 9-45 lexed_function_lexemes_structure based structure level 1 dcl 9-45 lexed_function_statement_map based fixed bin(18,0) array dcl 9-45 lexed_function_type internal static bit(18) initial unaligned dcl 4-30 list_value_type internal static bit(18) initial unaligned dcl 4-30 max_parse_stack_depth internal static fixed bin(17,0) initial dcl 3-98 not_integer_mask internal static bit(18) initial unaligned dcl 4-30 not_zero_or_one_mask internal static bit(18) initial unaligned dcl 4-30 number_of_ptrs automatic fixed bin(17,0) dcl 10-20 op_type internal static fixed bin(17,0) initial dcl 10-31 open_bracket_type internal static fixed bin(17,0) initial dcl 10-31 open_paren_type internal static fixed bin(17,0) initial dcl 10-31 operator_type internal static bit(18) initial unaligned dcl 4-30 output_buffer based char unaligned dcl 3-94 parse_frame_ptr automatic pointer dcl 857 reduction_stack_for_op based structure array level 1 dcl 10-31 reductions_pointer automatic pointer dcl 10-29 reverse builtin function dcl 838 save_frame_type internal static fixed bin(17,0) initial dcl 10-22 semi_colon_type internal static fixed bin(17,0) initial dcl 10-31 shared_variable_type internal static bit(18) initial unaligned dcl 4-30 statement_count automatic fixed bin(17,0) dcl 9-45 subscript_type internal static fixed bin(17,0) initial dcl 10-31 suspended_frame_type internal static fixed bin(17,0) initial dcl 10-22 symbol_type internal static bit(18) initial unaligned dcl 4-30 val_type internal static fixed bin(17,0) initial dcl 10-31 value_type internal static bit(18) initial unaligned dcl 4-30 verify builtin function dcl 838 NAMES DECLARED BY EXPLICIT CONTEXT. alloc_chars_on_stack 002167 constant entry internal dcl 162 ref 118 146 441 619 622 713 alloc_numbers_on_stack 002240 constant entry internal dcl 186 ref 219 481 apl_push_stack_ 002311 constant entry internal dcl 1-4 ref 66 174 192 235 457 667 apl_system_functions_ 000111 constant entry external dcl 12 cant_fix 001636 constant label dcl 641 ref 602 602 check_name 002423 constant entry internal dcl 298 ref 87 277 505 compute_name_usage 002354 constant entry internal dcl 274 ref 224 268 copy_up_numbers 000536 constant label dcl 230 ref 488 do_this_symbol 002614 constant entry internal dcl 411 ref 392 397 401 domain_error 002141 constant label dcl 731 ref 737 domain_error_left 002147 constant label dcl 735 set ref 330 332 domain_error_right 002135 constant label dcl 729 set ref 40 42 79 211 259 342 344 349 351 358 472 491 536 539 653 658 exitloop 001303 constant label dcl 559 ref 556 expunge_meaning 002673 constant label dcl 518 ref 526 expunge_name 002641 constant entry internal dcl 502 ref 485 499 fcn 000000 constant label array(58:71) dcl 38 ref 36 quad_cr_lose 000460 constant label dcl 142 ref 82 88 quad_cr_lose_and_wash_sbp 000457 constant label dcl 139 ref 91 93 95 quat_out_of_delay 000213 constant label dcl 54 set ref 52 return_apl_number_monadic 000224 constant label dcl 60 ref 48 269 500 595 645 return_error_message 002046 constant label dcl 708 ref 691 skip_this_symbol 001057 constant label dcl 406 ref 385 wash_fbp 002743 constant entry internal dcl 631 ref 593 643 wash_sbp 002151 constant entry internal dcl 152 ref 135 139 293 NAMES DECLARED BY CONTEXT OR IMPLICATION. length builtin function ref 699 710 rtrim builtin function ref 710 STORAGE REQUIREMENTS FOR THIS PROGRAM. Object Text Link Symbol Defs Static Start 0 0 3350 3430 3035 3360 Length 4154 3035 60 507 312 0 BLOCK NAME STACK SIZE TYPE WHY NONQUICK/WHO SHARES STACK FRAME apl_system_functions_ 350 external procedure is an external procedure. on unit on line 52 64 on unit wash_sbp internal procedure shares stack frame of external procedure apl_system_functions_. alloc_chars_on_stack internal procedure shares stack frame of external procedure apl_system_functions_. alloc_numbers_on_stack internal procedure shares stack frame of external procedure apl_system_functions_. apl_push_stack_ internal procedure shares stack frame of external procedure apl_system_functions_. compute_name_usage internal procedure shares stack frame of external procedure apl_system_functions_. check_name internal procedure shares stack frame of external procedure apl_system_functions_. do_this_symbol internal procedure shares stack frame of external procedure apl_system_functions_. expunge_name internal procedure shares stack frame of external procedure apl_system_functions_. wash_fbp internal procedure shares stack frame of external procedure apl_system_functions_. on unit on line 685 64 on unit STORAGE FOR AUTOMATIC VARIABLES. STACK FRAME LOC IDENTIFIER BLOCK NAME apl_system_functions_ 000100 code apl_system_functions_ 000101 long_message apl_system_functions_ 000132 right_vb apl_system_functions_ 000133 right apl_system_functions_ 000134 number_type apl_system_functions_ 000136 apl_number apl_system_functions_ 000140 start_of_sleep_time apl_system_functions_ 000142 n_words apl_system_functions_ 000143 result_vb apl_system_functions_ 000144 result apl_system_functions_ 000146 final_result apl_system_functions_ 000150 final_result_vb apl_system_functions_ 000151 data_elements apl_system_functions_ 000152 name_len apl_system_functions_ 000153 name_pos apl_system_functions_ 000154 name_no_good apl_system_functions_ 000155 sbp apl_system_functions_ 000156 fbp apl_system_functions_ 000157 lfbp apl_system_functions_ 000160 max_line_length apl_system_functions_ 000161 number_of_lines apl_system_functions_ 000162 line_pos apl_system_functions_ 000163 this_line_length apl_system_functions_ 000164 line_number apl_system_functions_ 000165 which_name apl_system_functions_ 000166 i apl_system_functions_ 000167 token_pos apl_system_functions_ 000170 token_len apl_system_functions_ 000171 token_type apl_system_functions_ 000172 left_vb apl_system_functions_ 000173 left apl_system_functions_ 000174 left_size apl_system_functions_ 000175 do_labels apl_system_functions_ 000176 do_variables apl_system_functions_ 000177 do_functions apl_system_functions_ 000200 fixnum apl_system_functions_ 000202 float_temp apl_system_functions_ 000204 n_rows apl_system_functions_ 000205 n_cols apl_system_functions_ 000206 pass apl_system_functions_ 000207 htpos apl_system_functions_ 000210 value_stack_popper apl_system_functions_ 000211 fcn_text_ptr apl_system_functions_ 000212 out_pos apl_system_functions_ 000213 space_left_in_stack apl_system_functions_ 000214 in_row apl_system_functions_ 000215 row_pos apl_system_functions_ 000216 row_length apl_system_functions_ 000217 errors_occurred apl_system_functions_ 000220 error_line apl_system_functions_ 000236 ws_info_ptr apl_system_functions_ 000240 number_of_dimensions apl_system_functions_ 000276 block_ptr apl_push_stack_ 000300 num_words apl_push_stack_ THE FOLLOWING EXTERNAL OPERATORS ARE USED BY THIS PROGRAM. fx1_to_fl2 alloc_cs call_ext_out_desc call_ext_out return fl2_to_fx1 fl2_to_fx2 tra_ext enable shorten_stack ext_entry int_entry floor_fl clock THE FOLLOWING EXTERNAL ENTRIES ARE CALLED BY THIS PROGRAM. apl_allocate_words_ apl_free_bead_ apl_function_lex_no_messages_ apl_get_next_value_stack_seg_ apl_get_symbol_ apl_get_value_stack_ apl_pendant_function_check_ apl_scan_ apl_segment_manager_$free apl_segment_manager_$get apl_system_error_ convert_status_code_ cu_$cp cu_$evaluate_active_string timer_manager_$sleep THE FOLLOWING EXTERNAL VARIABLES ARE USED BY THIS PROGRAM. apl_error_table_$domain apl_error_table_$exec_restricted apl_error_table_$no_sv apl_static_$ws_info_ptr error_table_$badcall LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC 12 000106 3 7 000116 33 000120 34 000124 36 000127 38 000134 40 000136 42 000141 45 000144 47 000150 48 000152 51 000153 52 000155 53 000174 54 000213 57 000214 60 000224 64 000234 65 000235 66 000240 67 000244 69 000250 70 000253 71 000255 72 000256 73 000260 75 000267 76 000270 77 000272 79 000273 82 000276 84 000301 85 000303 86 000304 87 000305 88 000306 91 000310 93 000315 95 000321 101 000323 102 000324 103 000325 105 000334 107 000350 109 000353 110 000354 112 000356 114 000360 115 000363 118 000373 120 000377 121 000402 125 000404 126 000405 128 000411 130 000427 132 000451 133 000453 135 000455 136 000456 139 000457 142 000460 144 000461 146 000471 147 000475 148 000500 209 000501 211 000503 213 000506 218 000511 219 000513 221 000514 222 000517 223 000524 224 000526 225 000527 226 000534 230 000536 234 000543 235 000546 238 000552 239 000556 240 000560 241 000562 244 000572 245 000575 247 000603 249 000604 253 000613 254 000617 259 000620 266 000621 267 000623 268 000624 269 000625 323 000626 325 000630 330 000632 332 000637 335 000642 336 000644 341 000646 342 000651 344 000654 347 000657 348 000664 349 000673 351 000701 353 000710 354 000713 356 000720 358 000725 361 000731 365 000733 368 000747 373 000755 374 000757 378 000763 380 000775 385 001005 392 001025 396 001041 397 001042 400 001050 401 001051 406 001057 409 001063 426 001065 431 001070 435 001073 439 001112 441 001114 443 001120 444 001123 446 001125 450 001126 454 001136 455 001140 457 001143 459 001145 462 001154 467 001156 468 001164 470 001165 472 001167 474 001172 479 001175 481 001177 482 001200 483 001203 484 001210 485 001212 486 001213 487 001220 488 001222 491 001223 497 001224 498 001226 499 001227 500 001230 536 001231 539 001234 542 001237 543 001241 547 001243 548 001245 549 001246 551 001256 552 001257 553 001263 554 001265 556 001272 558 001300 559 001303 561 001310 563 001312 564 001326 565 001335 566 001340 568 001350 570 001362 571 001366 572 001371 576 001373 577 001375 578 001412 579 001415 580 001417 581 001420 582 001423 583 001425 584 001432 586 001435 590 001503 592 001506 593 001513 594 001514 595 001516 598 001517 599 001522 600 001525 602 001535 606 001555 608 001561 610 001572 616 001575 617 001600 619 001610 622 001617 623 001623 626 001626 628 001635 641 001636 643 001641 644 001642 645 001644 647 001645 651 001653 653 001654 658 001657 664 001662 665 001664 667 001667 669 001671 671 001677 673 001703 674 001710 676 001711 678 001720 680 001734 681 001735 683 001736 685 001745 688 001761 691 001766 694 001771 697 002035 699 002037 704 002041 706 002044 708 002046 710 002063 713 002075 715 002101 718 002105 719 002113 721 002122 722 002123 724 002130 725 002133 727 002134 729 002135 731 002141 733 002146 735 002147 737 002150 152 002151 155 002152 156 002155 158 002166 162 002167 171 002171 172 002173 174 002203 175 002207 177 002213 178 002221 179 002223 180 002225 181 002227 183 002237 186 002240 189 002241 190 002243 192 002253 193 002257 195 002263 196 002266 197 002271 198 002273 200 002300 203 002307 205 002310 1 4 002311 1 35 002313 1 37 002315 1 40 002322 1 43 002337 1 44 002342 1 45 002351 274 002354 277 002355 278 002356 283 002363 285 002373 287 002403 289 002411 291 002417 293 002421 295 002422 298 002423 305 002424 306 002472 308 002475 309 002477 311 002500 312 002551 314 002553 315 002555 318 002556 319 002611 320 002613 411 002614 414 002615 416 002620 417 002621 419 002626 421 002627 422 002637 424 002640 502 002641 505 002642 506 002643 509 002650 511 002660 513 002670 518 002673 521 002677 523 002710 524 002713 525 002715 526 002716 530 002735 532 002740 534 002742 631 002743 634 002744 635 002747 637 002760 ----------------------------------------------------------- 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