COMPILATION LISTING OF SEGMENT apl_coded_ Compiled by: Multics PL/I Compiler, Release 28d, of October 4, 1983 Compiled at: Honeywell LCPD Phoenix, System M Compiled on: 11/29/83 1619.5 mst Tue Options: optimize map 1 /* *********************************************************** 2* * * 3* * Copyright, (C) Honeywell Information Systems Inc., 1983 * 4* * * 5* *********************************************************** */ 6 apl_coded_: procedure (operators_argument); 7 8 /* Adapted from apl_coded_file_routines_ by Mike Bonham, 80-02-15 */ 9 /* Modified 81-12-21 by H. Hoover to tidy up. */ 10 /* Modified 83-11-21 by A. Dewar to change handling of long_record error, */ 11 /* to continue untie loop until entire vector tried, */ 12 /* to use pathname_$component_check to construct absolute pathnames. */ 13 14 /* external static */ 15 16 dcl apl_error_table_$domain fixed bin (35) ext, 17 apl_error_table_$length fixed bin (35) ext, 18 apl_error_table_$rank fixed bin (35) ext, 19 apl_error_table_$system_error fixed bin (35) ext, 20 error_table_$end_of_info fixed bin (35) ext, 21 error_table_$long_record fixed bin (35) ext, 22 error_table_$noentry fixed bin (35) ext, 23 error_table_$short_record fixed bin (35) ext; 24 25 /* entries */ 26 27 dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)), 28 hcs_$status_minf entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35)), 29 ioa_ entry options (variable), 30 iox_$attach_name entry (char (*), ptr, char (*), ptr, fixed bin (35)), 31 iox_$close entry (ptr, fixed bin (35)), 32 iox_$detach_iocb entry (ptr, fixed bin (35)), 33 iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)), 34 iox_$open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35)), 35 iox_$position entry (ptr, fixed bin, fixed bin (21), fixed bin (35)), 36 iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)), 37 pathname_$component_check entry (char (*), char (*), char (*), char (*), fixed bin (35)), 38 unique_chars_ entry (bit (*)) returns (char (15)); 39 40 /* builtins */ 41 42 dcl addrel builtin, 43 ceil builtin, 44 hbound builtin, 45 lbound builtin, 46 ltrim builtin, 47 null builtin, 48 rel builtin, 49 rtrim builtin, 50 size builtin, 51 string builtin, 52 substr builtin; 53 54 /* internal static */ 55 56 dcl 1 tcb (100) aligned internal static, 57 2 iocb_ptr ptr init ((100) null), 58 2 switch char (15) unaligned, 59 2 eof bit (1) init ((100) (1)"0"b); 60 61 dcl max_line_length fixed bin internal static options (constant) init (256), 62 time_iofns_invoked fixed bin (71) internal static init (0); 63 64 /* automatic */ 65 66 dcl attach_desc char (256), 67 b_ptr ptr, 68 buf_line_ptr ptr, 69 code fixed bin (35), 70 data_elements fixed bin (21), 71 file_dname char (168), 72 file_ename char (32), 73 file_pathname char (168), 74 file_tie_error_occurred bit (1), 75 left ptr, 76 left_vb ptr, 77 lines_read fixed bin, 78 longest fixed bin, 79 message char (100) aligned, 80 n_read fixed bin (21), 81 n_words fixed bin (19), 82 no_of_lines fixed bin, 83 pos_request_type fixed bin, 84 pos_skip_count fixed bin (21), 85 record_length fixed bin (21), 86 result ptr, 87 result_vb ptr, 88 right ptr, 89 right_vb ptr, 90 subscript fixed bin (21), 91 tcbx fixed bin, 92 tie_num fixed bin; 93 94 /* based */ 95 96 dcl buffer (no_of_lines) char (max_line_length) based (b_ptr) init ((no_of_lines) (1)" "), 97 minimum_buffer (lines_read) char (longest) based; 98 99 /* 'file_name' CREATE file_number */ 100 101 create: entry (operators_argument); 102 if time_iofns_invoked < ws_info.time_invoked then do; 103 call close_files; 104 time_iofns_invoked = ws_info.time_invoked; 105 end; 106 call decode_file_id; 107 call decode_tie_num; 108 109 call hcs_$status_minf (file_dname, file_ename, 1, (0), (0), code); 110 if code ^= error_table_$noentry /* If file already exists... */ 111 then goto file_name_error; 112 113 if operators_argument.operands (2).on_stack /* Pop input args, if necessary */ 114 then ws_info.value_stack_ptr = right_vb; 115 else if operators_argument.operands (1).on_stack 116 then ws_info.value_stack_ptr = left_vb; 117 118 call open_file; 119 return; 120 121 /* R -< EOF file-number-vector 122* 123* Returns bit_vector of 'end-of-file status' for all files specified */ 124 125 eof: entry (operators_argument); 126 if time_iofns_invoked < ws_info.time_invoked then do; 127 call close_files; 128 time_iofns_invoked = ws_info.time_invoked; 129 end; 130 131 right_vb = operators_argument.operands (2).value; 132 133 if ^right_vb -> general_bead.value 134 then go to domain_error_right; 135 136 if ^right_vb -> value_bead.numeric_value 137 then go to domain_error_right; 138 139 if (right_vb -> value_bead.total_data_elements > 1) & (right_vb -> value_bead.rhorho ^= 1) 140 then go to rank_error_right; 141 142 /* Temporarily insist that args must be integers */ 143 144 if ^right_vb -> value_bead.integral_value 145 then go to domain_error_right; 146 147 right = right_vb -> value_bead.data_pointer; 148 149 data_elements = right_vb -> value_bead.total_data_elements; 150 if operators_argument.on_stack (2) 151 then do; /* Overlay result on right arg. */ 152 result_vb = right_vb; 153 string (result_vb -> value_bead.type) = zero_or_one_value_type; 154 result = right; 155 end; 156 else do; /* Allocate result of same shape as right arg. */ 157 number_of_dimensions = right_vb -> value_bead.rhorho; 158 n_words = size (value_bead) + size (numeric_datum) + 1; 159 result_vb = apl_push_stack_ (n_words); 160 string (result_vb -> value_bead.type) = zero_or_one_value_type; 161 result_vb -> value_bead.total_data_elements = data_elements; 162 result_vb -> value_bead.rhorho = number_of_dimensions; 163 result_vb -> value_bead.rho (1) = data_elements; 164 result = addrel (result_vb, size (value_bead)); 165 if substr (rel (result), 18, 1) 166 then result = addrel (result, 1); 167 result_vb -> value_bead.data_pointer = result; 168 end; 169 170 do subscript = 0 by 1 while (subscript < right_vb -> value_bead.total_data_elements); 171 tie_num = right -> numeric_datum (subscript); 172 173 if tcb.iocb_ptr (tie_num) ^= null 174 then 175 if tcb.eof (tie_num) 176 then result -> numeric_datum (subscript) = 1; 177 else result -> numeric_datum (subscript) = 0; 178 else goto file_tie_error; 179 end; 180 181 operators_argument.result = result_vb; 182 return; 183 184 /* R -< NUMS 185* 186* Returns a numeric vector holding the file numbers of all tied files. 187**/ 188 189 nums: entry (operators_argument); 190 if time_iofns_invoked < ws_info.time_invoked then do; 191 call close_files; 192 time_iofns_invoked = ws_info.time_invoked; 193 end; 194 195 data_elements = 0; /* Count number of open files */ 196 do tcbx = lbound (tcb, 1) to hbound (tcb, 1); 197 if tcb.iocb_ptr (tcbx) ^= null 198 then data_elements = data_elements + 1; 199 end; 200 201 number_of_dimensions = 1; /* Get size of result bead */ 202 n_words = size (value_bead) + size (numeric_datum) + 1; 203 result_vb = apl_push_stack_ (n_words); 204 205 string (result_vb -> value_bead.type) = integral_value_type; /* Fill in result bead */ 206 result_vb -> value_bead.total_data_elements = data_elements; 207 result_vb -> value_bead.rhorho = number_of_dimensions; 208 result_vb -> value_bead.rho (1) = data_elements; 209 result = addrel (result_vb, size (value_bead)); 210 if substr (rel (result), 18, 1) 211 then result = addrel (result, 1); 212 213 result_vb -> value_bead.data_pointer = result; 214 215 subscript = -1; /* Fill in vector of file numbers */ 216 do tcbx = lbound (tcb, 1) to hbound (tcb, 1); 217 if tcb.iocb_ptr (tcbx) ^= null 218 then do; 219 subscript = subscript + 1; 220 result -> numeric_datum (subscript) = tcbx; 221 end; 222 end; 223 224 operators_argument.result = result_vb; 225 return; 226 227 /* position-code [,skip-count] POSITION file-number */ 228 229 position: entry (operators_argument); 230 if time_iofns_invoked < ws_info.time_invoked then do; 231 call close_files; 232 time_iofns_invoked = ws_info.time_invoked; 233 end; 234 235 call decode_tie_num; 236 if tcb.iocb_ptr (tie_num) = null 237 then goto file_not_tied; 238 left_vb = operators_argument (1).value; 239 if ^left_vb -> general_bead.value then goto domain_error_left; 240 if ^left_vb -> value_bead.integral_value then goto domain_error_left; 241 data_elements = left_vb -> value_bead.total_data_elements; 242 if data_elements < 1 | data_elements > 2 243 then goto length_error_left; 244 245 left = left_vb -> value_bead.data_pointer; 246 pos_request_type = left -> numeric_datum (0); 247 if data_elements < 2 248 then pos_skip_count = 1; 249 else pos_skip_count = left -> numeric_datum (1); 250 251 if operators_argument (2).on_stack then ws_info.value_stack_ptr = right_vb; 252 else if operators_argument (1).on_stack then ws_info.value_stack_ptr = left_vb; 253 254 if (pos_request_type < -1) | (pos_request_type > 3) then goto domain_error_left; 255 call iox_$position (tcb.iocb_ptr (tie_num), pos_request_type, pos_skip_count, code); 256 if code = 0 257 then if pos_request_type = 1 258 then tcb.eof (tie_num) = "1"b; 259 else tcb.eof (tie_num) = "0"b; 260 else if code = error_table_$end_of_info 261 then if pos_skip_count > 0 262 then tcb.eof (tie_num) = "1"b; 263 else tcb.eof (tie_num) = "0"b; 264 else goto position_out_of_bounds; 265 operators_argument.result = null; 266 return; 267 268 /* R <- no_of_lines READ file_number */ 269 270 read: entry (operators_argument); 271 if time_iofns_invoked < ws_info.time_invoked then do; 272 call close_files; 273 time_iofns_invoked = ws_info.time_invoked; 274 end; 275 276 call decode_tie_num; 277 if tcb.iocb_ptr (tie_num) = null then goto file_not_tied; 278 left_vb = operators_argument (1).value; 279 if left_vb = null then no_of_lines = 1; 280 else do; 281 if ^left_vb -> general_bead.value then goto domain_error_left; 282 if ^left_vb -> value_bead.integral_value then goto domain_error_left; 283 if left_vb -> value_bead.total_data_elements ^= 1 then goto length_error_left; 284 left = left_vb -> value_bead.data_pointer; 285 no_of_lines = left -> numeric_datum (0); 286 if no_of_lines < 1 then goto domain_error_left; 287 end; 288 if operators_argument (2).on_stack then ws_info.value_stack_ptr = right_vb; 289 else if operators_argument (1).on_stack then ws_info.value_stack_ptr = left_vb; 290 291 allocate buffer set (b_ptr); 292 tcb.eof (tie_num) = "0"b; 293 lines_read = 0; 294 longest = 0; 295 do subscript = 1 to no_of_lines while (^tcb.eof (tie_num)); 296 buf_line_ptr = addrel (b_ptr, lines_read * ceil (max_line_length/4.0)); 297 call iox_$get_line (tcb.iocb_ptr (tie_num), buf_line_ptr, (max_line_length), n_read, code); 298 if code = error_table_$long_record 299 then go to cant_read_record; 300 else if (code = error_table_$end_of_info)| (code = error_table_$short_record) 301 then tcb.eof (tie_num) = "1"b; 302 else if code = 0 then do; 303 substr (buffer (lines_read + 1), n_read, 1) = " "; 304 n_read = n_read -1; 305 end; 306 if n_read > longest then longest = n_read; 307 lines_read = lines_read + 1; 308 end; 309 310 if (lines_read = 1) & (longest = 0) then lines_read = 0; 311 312 /* allocate char_matrix bead with minimum dimension */ 313 if lines_read <= 1 314 then number_of_dimensions = 1; 315 else number_of_dimensions = 2; 316 data_elements = lines_read * longest; 317 n_words = size (value_bead) + ceil (data_elements / 4.0); 318 result_vb = apl_push_stack_ (n_words); 319 string (result_vb -> value_bead.type) = character_value_type; 320 result_vb -> value_bead.total_data_elements = data_elements; 321 result_vb -> value_bead.rhorho = number_of_dimensions; 322 result_vb -> value_bead.rho (1) = lines_read; 323 result_vb -> value_bead.rho (number_of_dimensions) = longest; 324 result = addrel (result_vb, size (value_bead)); 325 result_vb -> value_bead.data_pointer = result; 326 327 if longest > 0 then 328 do subscript = 1 to lines_read; 329 result -> minimum_buffer (subscript) = buffer (subscript); 330 end; 331 332 free buffer; 333 operators_argument.result = result_vb; 334 return; 335 336 /* REWIND file-number-vector 337* 338* Rewinds all files specified in the vector argument. */ 339 340 rewind: entry (operators_argument); 341 if time_iofns_invoked < ws_info.time_invoked then do; 342 call close_files; 343 time_iofns_invoked = ws_info.time_invoked; 344 end; 345 346 right_vb = operators_argument.operands (2).value; 347 348 if operators_argument.operands (2).on_stack 349 then ws_info.value_stack_ptr = right_vb; 350 351 if ^right_vb -> general_bead.value 352 then go to domain_error_right; 353 354 if ^right_vb -> value_bead.numeric_value 355 then go to domain_error_right; 356 357 if (right_vb -> value_bead.total_data_elements > 1) & (right_vb -> value_bead.rhorho ^= 1) 358 then go to rank_error_right; 359 360 /* Temporarily insist that args must be integers */ 361 362 if ^right_vb -> value_bead.integral_value 363 then go to domain_error_right; 364 365 right = right_vb -> value_bead.data_pointer; 366 367 do subscript = 0 by 1 while (subscript < right_vb -> value_bead.total_data_elements); 368 tie_num = right -> numeric_datum (subscript); 369 370 if tcb.iocb_ptr (tie_num) ^= null 371 then do; 372 call iox_$position (tcb.iocb_ptr (tie_num), -1, 0, code); 373 tcb.eof (tie_num) = "0"b; 374 end; 375 else goto file_tie_error; 376 end; 377 378 operators_argument.result = null; 379 return; 380 381 /* 'file_name' TIE file_number */ 382 383 tie: entry (operators_argument); 384 if time_iofns_invoked < ws_info.time_invoked then do; 385 call close_files; 386 time_iofns_invoked = ws_info.time_invoked; 387 end; 388 389 call decode_file_id; 390 call decode_tie_num; 391 392 if operators_argument.operands (2).on_stack /* Pop input args, if necessary */ 393 then ws_info.value_stack_ptr = right_vb; 394 else if operators_argument.operands (1).on_stack 395 then ws_info.value_stack_ptr = left_vb; 396 397 call open_file; 398 return; 399 400 /* UNTIE file-number-vector 401* 402* Unties all files specified in the vector argument. */ 403 404 untie: entry (operators_argument); 405 if time_iofns_invoked < ws_info.time_invoked then do; 406 call close_files; 407 time_iofns_invoked = ws_info.time_invoked; 408 end; 409 410 right_vb = operators_argument.operands (2).value; 411 412 if operators_argument.operands (2).on_stack 413 then ws_info.value_stack_ptr = right_vb; 414 415 if ^right_vb -> general_bead.value 416 then go to domain_error_right; 417 418 if ^right_vb -> value_bead.numeric_value 419 then go to domain_error_right; 420 421 if (right_vb -> value_bead.total_data_elements > 1) & (right_vb -> value_bead.rhorho ^= 1) 422 then go to rank_error_right; 423 424 /* Temporarily insist that args must be integers */ 425 426 if ^right_vb -> value_bead.integral_value 427 then go to domain_error_right; 428 429 right = right_vb -> value_bead.data_pointer; 430 431 file_tie_error_occurred = "0"b; 432 433 do subscript = 0 by 1 while (subscript < right_vb -> value_bead.total_data_elements); 434 tie_num = right -> numeric_datum (subscript); 435 436 if tcb.iocb_ptr (tie_num) ^= null 437 then do; 438 call iox_$close (tcb.iocb_ptr (tie_num), code); 439 call iox_$detach_iocb (tcb.iocb_ptr (tie_num), code); 440 tcb.iocb_ptr (tie_num) = null; 441 end; 442 else file_tie_error_occurred = "1"b; 443 end; 444 445 if file_tie_error_occurred 446 then go to file_tie_error; 447 448 operators_argument.result = null; 449 return; 450 451 452 /* 'char_string' WRITE file_number */ 453 454 write: entry (operators_argument); 455 if time_iofns_invoked < ws_info.time_invoked then do; 456 call close_files; 457 time_iofns_invoked = ws_info.time_invoked; 458 end; 459 460 call decode_tie_num; 461 462 if tcb.iocb_ptr (tie_num) = null 463 then go to file_not_tied; 464 465 466 left_vb = operators_argument (1).value; 467 if ^left_vb -> value_bead.character_value then goto domain_error_left; 468 469 if (left_vb -> value_bead.rhorho > 1) & (left_vb -> value_bead.total_data_elements > 1) 470 then goto rank_error_left; 471 472 if operators_argument (2).on_stack 473 then ws_info.value_stack_ptr = right_vb; /* pop arg off stack */ 474 else if operators_argument.operands (1).on_stack 475 then ws_info.value_stack_ptr = left_vb; 476 477 record_length = left_vb -> value_bead.total_data_elements; 478 479 left = left_vb -> value_bead.data_pointer; 480 call iox_$put_chars (tcb.iocb_ptr (tie_num), left, record_length, code); 481 if code ^= 0 then goto cant_write_record; 482 483 operators_argument.result = null; 484 return; 485 486 already_tied: 487 call ioa_ ("file ^d already tied", tie_num); 488 go to system_error; 489 490 cant_attach: 491 call expand_code; 492 call ioa_ ("cant attach file: ^a", message); 493 go to system_error; 494 495 cant_open: 496 call expand_code; 497 call ioa_ ("cant open file: ^a", message); 498 go to system_error; 499 500 cant_read_record: 501 call expand_code; 502 call ioa_ ("cant read record: ^a", message); 503 go to system_error; 504 505 cant_write_record: 506 call expand_code; 507 call ioa_ ("cant write record: ^a", message); 508 509 file_name_error: 510 call ioa_ ("file name error"); 511 go to system_error; 512 513 file_not_tied: 514 call ioa_ ("file ^d not tied", tie_num); 515 go to system_error; 516 517 file_tie_error: 518 call ioa_ ("file tie error"); 519 go to system_error; 520 521 position_out_of_bounds: 522 call ioa_ ("position out of bounds."); 523 goto system_error; 524 525 526 527 528 529 domain_error_left: 530 domain_error_right: 531 operators_argument.error_code = apl_error_table_$domain; 532 return; 533 534 length_error_left: 535 length_error_right: 536 operators_argument.error_code = apl_error_table_$length; 537 return; 538 539 rank_error_left: 540 rank_error_right: 541 operators_argument.error_code = apl_error_table_$rank; 542 return; 543 544 system_error: 545 operators_argument.error_code = apl_error_table_$system_error; 546 return; 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 ------------------------------- */ 547 548 close_files: proc; 549 do subscript = 1 to 100; 550 tcb.eof (subscript) = "0"b; 551 tcb.switch (subscript) = ""; 552 if tcb.iocb_ptr (subscript) ^= null () then do; 553 call iox_$close (tcb.iocb_ptr (subscript), code); 554 call iox_$detach_iocb (tcb.iocb_ptr (subscript), code); 555 tcb.iocb_ptr (subscript) = null (); 556 end; 557 end; 558 end close_files; 559 decode_file_id: procedure; 560 561 left_vb = operators_argument.operands (1).value; 562 563 if ^left_vb -> general_bead.value 564 then go to domain_error_left; 565 566 if ^left_vb -> value_bead.character_value 567 then go to domain_error_left; 568 569 data_elements = left_vb -> value_bead.total_data_elements; 570 if data_elements < 1 571 then go to length_error_left; 572 573 if data_elements > 1 & left_vb -> value_bead.rhorho ^= 1 574 then go to rank_error_left; 575 576 left = left_vb -> value_bead.data_pointer; 577 578 call expand_pathname_ (ltrim (left -> character_string_overlay), file_dname, file_ename, code); 579 if code ^= 0 580 then goto file_name_error; 581 return; 582 583 end decode_file_id; 584 decode_tie_num: procedure; 585 586 right_vb = operators_argument.operands (2).value; 587 588 if ^right_vb -> general_bead.value 589 then go to domain_error_right; 590 591 if ^right_vb -> value_bead.integral_value /* TEMP...insist on integers */ 592 then go to domain_error_right; 593 594 data_elements = right_vb -> value_bead.total_data_elements; 595 596 if (right_vb -> value_bead.rhorho > 1) & (data_elements ^= 1) 597 then go to rank_error_right; 598 599 if data_elements ^= 1 600 then go to length_error_right; 601 602 right = right_vb -> value_bead.data_pointer; 603 604 tie_num = right -> numeric_datum (0); 605 606 if (tie_num < lbound (tcb.iocb_ptr, 1)) | (tie_num > hbound (tcb.iocb_ptr, 1)) 607 then go to file_tie_error; 608 609 end decode_tie_num; 610 611 expand_code: procedure; 612 613 dcl convert_status_code_ entry (fixed bin (35), char (8) aligned, char (100) aligned); 614 615 call convert_status_code_ (code, "", message); 616 return; 617 618 end expand_code; 619 open_file: procedure; 620 621 if tcb.iocb_ptr (tie_num) ^= null 622 then go to already_tied; 623 624 call pathname_$component_check (file_dname, file_ename, "", file_pathname, code); 625 if code ^= 0 626 then go to cant_attach; 627 attach_desc = "vfile_ " || rtrim (file_pathname) || " -extend"; 628 tcb.switch (tie_num) = unique_chars_ (""b); 629 630 call iox_$attach_name (tcb.switch (tie_num), tcb.iocb_ptr (tie_num), attach_desc, null, code); 631 if code ^= 0 632 then go to cant_attach; 633 634 call iox_$open (tcb.iocb_ptr (tie_num), 3, "0"b, code); 635 if code ^= 0 636 then go to cant_open; 637 638 call iox_$position (tcb.iocb_ptr (tie_num), -1, 0, code); 639 tcb.eof (tie_num) = "0"b; 640 641 operators_argument.result = null; 642 return; 643 644 end open_file; 645 2 1 /* ====== BEGIN INCLUDE SEGMENT apl_bead_format.incl.pl1 ================================== */ 2 2 2 3 declare 1 general_bead aligned based, /* The Venerable Bead */ 2 4 2 type unaligned, 2 5 3 bead_type unaligned, 2 6 4 operator bit (1), /* ON if operator bead */ 2 7 4 symbol bit (1), /* ON if symbol bead */ 2 8 4 value bit (1), /* ON if value bead */ 2 9 4 function bit (1), /* ON if function bead */ 2 10 4 group bit (1), /* ON if group bead */ 2 11 4 label bit (1), /* ON if label bead */ 2 12 4 shared_variable bit (1), /* ON if shared variable bead */ 2 13 4 lexed_function bit (1), /* ON if lexed function bead */ 2 14 3 data_type unaligned, 2 15 4 list_value bit (1), /* ON if a list value bead */ 2 16 4 character_value bit (1), /* ON if a character value bead */ 2 17 4 numeric_value bit (1), /* ON if a numeric value bead */ 2 18 4 integral_value bit (1), /* ON if an integral value bead */ 2 19 4 zero_or_one_value bit (1), /* ON if a boolean value bead */ 2 20 4 complex_value bit (1), /* ON if a complex, numeric value bead */ 2 21 3 unused_bits bit (4) unaligned, /* pad to 18 bits (for future use) */ 2 22 2 size bit (18) unaligned, /* Number of words this bead occupies 2 23* (used by bead storage manager) */ 2 24 2 reference_count fixed binary (29); /* Number of pointers which point 2 25* to this bead (used by bead manager) */ 2 26 2 27 2 28 /* constant strings for initing type field in various beads */ 2 29 2 30 declare ( 2 31 operator_type init("100000000000000000"b), 2 32 symbol_type init("010000000000000000"b), 2 33 value_type init("001000000000000000"b), 2 34 function_type init("000100000000000000"b), 2 35 group_type init("000010000000000000"b), 2 36 label_type init("001001000011000000"b), 2 37 shared_variable_type init("001000100000000000"b), 2 38 lexed_function_type init("000000010000000000"b), 2 39 2 40 list_value_type init("000000001000000000"b), 2 41 character_value_type init("001000000100000000"b), 2 42 numeric_value_type init("001000000010000000"b), 2 43 integral_value_type init("001000000011000000"b), 2 44 zero_or_one_value_type init("001000000011100000"b), 2 45 complex_value_type init("001000000000010000"b), 2 46 2 47 not_integer_mask init("111111111110011111"b), /* to clear integral, zero_or_one bits */ 2 48 not_zero_or_one_mask init("111111111111011111"b) /* to clear zero_or_one bit */ 2 49 ) bit(18) internal static; 2 50 2 51 /* ------ END INCLUDE SEGMENT apl_bead_format.incl.pl1 ---------------------------------- */ 646 3 1 /* ====== BEGIN INCLUDE SEGMENT apl_number_data.incl.pl1 ================================== */ 3 2 3 3 /* 3 4* This include file contains information about the machine representation of numbers. 3 5* In all programs numbers should simply be declared 'float'. 3 6* All default statements should be in this include file. 3 7* 3 8* This is the binary version. The manifest constant Binary should be used by programs 3 9* that need to know whether we are using binary or decimal. 3 10* */ 3 11 3 12 /* format: style3,initlm0,idind30 */ 3 13 3 14 default (float & ^decimal & ^binary & ^precision & ^constant) float binary (63); 3 15 3 16 declare ( 3 17 TheBiggestNumberWeveGot float initial (0.1701411834604692317e+39), 3 18 TheSmallestNumberWeveGot float initial (.1469367938527859385e-38), 3 19 Binary bit (1) aligned initial ("1"b) 3 20 ) internal static options (constant); 3 21 3 22 /* Number of characters in a number datum entry; used for copying float number arrays as strings. 3 23* (Obsolete! use array copies!) */ 3 24 3 25 declare NumberSize fixed binary precision (4) internal static initial (8); 3 26 3 27 /* ------ END INCLUDE SEGMENT apl_number_data.incl.pl1 ---------------------------------- */ 647 4 1 /* ====== BEGIN INCLUDE SEGEMENT apl_operators_argument.incl.pl1 =========================== */ 4 2 4 3 declare 1 operators_argument aligned, 4 4 2 operands (2) aligned, /* these are the operands to the operator to be executed. 4 5* if operand (1).value is null, operator is monadic */ 4 6 3 value pointer unaligned, /* a pointer to the value bead for this operand */ 4 7 3 on_stack bit (1) aligned, /* ON if this value resides on the value stack */ 4 8 2 operator aligned, /* information about the operator to be executed */ 4 9 3 dimension fixed bin, /* (optional) dimension along which to operate */ 4 10 3 padding bit (18) unaligned, /* unused part of operator bead */ 4 11 3 op2 fixed bin (8) unal, /* a modifier for op1, or a 2nd operator if inner product */ 4 12 3 op1 fixed bin (8) unal, /* code for the actual operator to be executed */ 4 13 2 result pointer unal, /* (output) set by operator to point to result bead in stack */ 4 14 2 error_code fixed bin (35), /* (output) set before signaling apl_operator_error_ */ 4 15 2 where_error fixed bin; /* parseme index of where error was - parse sets to operator */ 4 16 4 17 /* ------ END INCLUDE SEGMENT apl_operators_argument.incl.pl1 --------------------------- */ 648 5 1 /* ====== BEGIN INCLUDE SEGMENT apl_value_bead.incl.pl1 =================================== */ 5 2 5 3 declare 5 4 number_of_dimensions fixed bin, 5 5 5 6 1 value_bead aligned based, 5 7 2 header aligned like general_bead, 5 8 2 total_data_elements fixed binary (21), /* length of ,[value] in APL */ 5 9 2 rhorho fixed binary, /* number of dimensions of value */ 5 10 2 data_pointer pointer unaligned, /* packed pointer to the data in value */ 5 11 2 rho fixed binary (21) dimension (number_of_dimensions refer (value_bead.rhorho)); 5 12 /* dimensions of value (zero-origin) */ 5 13 5 14 5 15 declare 1 character_data_structure aligned based, /* alignment trick for PL/I compiler */ 5 16 2 character_datum character (1) unaligned dimension (0:data_elements - 1); 5 17 /* actual elements of character array */ 5 18 5 19 declare character_string_overlay character (data_elements) aligned based; 5 20 /* to overlay on above structure */ 5 21 5 22 5 23 declare numeric_datum float aligned dimension (0:data_elements - 1) based; 5 24 /* actual elements of numeric array */ 5 25 5 26 declare complex_datum complex float aligned dimension (0:data_elements -1) based; 5 27 5 28 declare MAX_VALUE_BEAD_SIZE fixed bin (19) init (261120) int static options (constant); 5 29 5 30 /* ------ END INCLUDE SEGMENT apl_value_bead.incl.pl1 ----------------------------------- */ 649 6 1 /* ====== BEGIN INCLUDE SEGMENT apl_ws_info.incl.pl1 ====================================== */ 6 2 6 3 /* This structure contains all of the global data (or pointers to it) for the APL subsystem */ 6 4 6 5 /* automatic */ 6 6 6 7 declare ws_info_ptr ptr initial (apl_static_$ws_info_ptr.static_ws_info_ptr); 6 8 6 9 /* external static */ 6 10 6 11 declare 1 apl_static_$ws_info_ptr external static aligned structure, 6 12 2 static_ws_info_ptr unaligned pointer; 6 13 6 14 /* based */ 6 15 6 16 declare 1 ws_info aligned based (ws_info_ptr), 6 17 2 version_number fixed bin, /* version of this structure (3) */ 6 18 2 switches unaligned, /* mainly ws parameters */ 6 19 3 long_error_mode bit, /* if 1, long Multics format, else APL/360 format */ 6 20 3 debug_mode bit, /* if 1, system error causes escape to command level */ 6 21 3 canonicalize_mode bit, /* if 1, the editor canonicalizes user input */ 6 22 3 restrict_exec_command bit, /* if 1, the )EXEC command may not be used */ 6 23 3 restrict_debug_command bit, /* if 1, the )DEBUG command may not be used */ 6 24 3 restrict_external_functions 6 25 bit, /* if 1, the )ZFN, )MFN, and )DFN commands may not be used */ 6 26 3 restrict_load bit, /* if 1, the )LOAD and )COPY commands may not be used */ 6 27 3 restrict_load_directory bit, /* if 1, no directory allowed in )LOAD or )COPY pathnames */ 6 28 3 restrict_save bit, /* if 1, the )SAVE command may not be used */ 6 29 3 restrict_save_directory bit, /* if 1, no directory allowed in )SAVE pathnames */ 6 30 3 off_hold bit, /* if 1, )OFF HOLD was typed, else just )OFF */ 6 31 3 transparent_to_signals bit, /* if 1, any conditions slip right past APL */ 6 32 3 meter_mode bit, /* if 1, metering may be done, else speed is all-important */ 6 33 3 restrict_msg_command bit, /* if 1, the )MSG command may not be used. */ 6 34 3 compatibility_check_mode 6 35 bit, /* if 1, check for incompatible operators */ 6 36 3 no_quit_handler bit, /* if 1, do not trap QUITs. */ 6 37 /* remaining 20 bits not presently used */ 6 38 6 39 2 values, /* attributes of the workspace */ 6 40 3 digits fixed bin, /* number of digits of precision printed on output */ 6 41 3 width fixed bin, /* line length for formatted output */ 6 42 3 index_origin fixed bin, /* the index origin (0 or 1) */ 6 43 3 random_link fixed bin(35), /* seed for random number generator */ 6 44 3 fuzz float, /* comparison tolerance (relative fuzz) */ 6 45 3 float_index_origin float, /* the index origin in floating point */ 6 46 3 number_of_symbols fixed bin, /* the number of symbol_beads currently in existence */ 6 47 3 maximum_value_stack_size 6 48 fixed bin (18), /* maximum number of words in one segment of value stack */ 6 49 6 50 2 pointers, /* pointers to various internal tables */ 6 51 3 symbol_table_ptr unaligned pointer, /* -> symbol_table (apl_symbol_table.incl.pl1) */ 6 52 3 current_parse_frame_ptr unaligned pointer, /* -> topmost parse frame */ 6 53 3 value_stack_ptr unaligned pointer, /* -> next free location on value stack */ 6 54 3 alloc_free_info_ptr unaligned pointer, /* -> apl_storage_mngr_ data (apl_storage_system_data.incl.pl1) */ 6 55 6 56 2 time_invoked fixed bin(71), /* clock time that APL was entered */ 6 57 2 integer_fuzz float, /* the absolute fuzz used in checking for integers */ 6 58 2 user_number fixed bin(35), /* number under which the user is signed on */ 6 59 2 latent_expression unaligned pointer, /* -> value_bead for QuadLX */ 6 60 2 lock char(32), /* the lock currently set on this workspace (password) */ 6 61 2 wsid char(100), /* the workspace identification: name, number name, or clear ws */ 6 62 2 last_error_code fixed bin(35), /* last code passed to apl_error_ */ 6 63 2 signoff_lock character (32), 6 64 6 65 2 interrupt_info aligned, /* bits used by apl_interpreter_ to tell when to abort */ 6 66 3 dont_interrupt_parse bit, /* if 1, don't do a dirty stop because the parser is running */ 6 67 3 dont_interrupt_operator bit, /* if 1, don't do a dirty stop because an operator is running */ 6 68 3 dont_interrupt_storage_manager /* if 1, don't stop because apl_storage_mngr_ is */ 6 69 bit, /* munging his tables */ 6 70 3 unused_interrupt_bit bit, /* not presently used */ 6 71 3 dont_interrupt_command bit, 6 72 3 can_be_interrupted bit, /* if 1, OK to do a clean stop (we are between lines, reading) */ 6 73 3 clean_interrupt_pending bit, /* interrupt occured, break cleanly (between lines) */ 6 74 3 dirty_interrupt_pending bit, /* interrupt occured, break as soon as not inhibited */ 6 75 6 76 2 user_name char (32), /* process group id of user */ 6 77 2 immediate_input_prompt char (32) varying, /* normal input */ 6 78 2 evaluated_input_prompt char (32) varying, /* quad input */ 6 79 2 character_input_prompt char (32) varying, /* quad-quote input */ 6 80 2 vcpu_time aligned, 6 81 3 total fixed bin (71), 6 82 3 setup fixed bin (71), 6 83 3 parse fixed bin (71), 6 84 3 lex fixed bin (71), 6 85 3 operator fixed bin (71), 6 86 3 storage_manager fixed bin (71), 6 87 2 output_info aligned, /* data pertaining to output buffer */ 6 88 3 output_buffer_ptr unal ptr, /* ptr to output buffer */ 6 89 3 output_buffer_len fixed bin (21), /* length (bytes) of output buffer */ 6 90 3 output_buffer_pos fixed bin (21), /* index of next byte to write in */ 6 91 3 output_buffer_ll fixed bin (21), /* print positions used up so far */ 6 92 2 tab_width fixed bin (21); /* number of columns a tabs moves cursor */ 6 93 6 94 declare output_buffer char (ws_info.output_buffer_len) based (ws_info.output_buffer_ptr); 6 95 6 96 /* internal static */ 6 97 6 98 declare max_parse_stack_depth fixed bin int static init(64536); 6 99 6 100 /* ------ END INCLUDE SEGMENT apl_ws_info.incl.pl1 -------------------------------------- */ 650 7 1 /* Begin include file ..... iox_modes.incl.pl1 */ 7 2 7 3 /* Written by C. D. Tavares, 03/17/75 */ 7 4 /* Updated 10/31/77 by CDT to include short iox mode strings */ 7 5 7 6 dcl iox_modes (13) char (24) int static options (constant) aligned initial 7 7 ("stream_input", "stream_output", "stream_input_output", 7 8 "sequential_input", "sequential_output", "sequential_input_output", "sequential_update", 7 9 "keyed_sequential_input", "keyed_sequential_output", "keyed_sequential_update", 7 10 "direct_input", "direct_output", "direct_update"); 7 11 7 12 dcl short_iox_modes (13) char (4) int static options (constant) aligned initial 7 13 ("si", "so", "sio", "sqi", "sqo", "sqio", "squ", "ksqi", "ksqo", "ksqu", "di", "do", "du"); 7 14 7 15 dcl (Stream_input initial (1), 7 16 Stream_output initial (2), 7 17 Stream_input_output initial (3), 7 18 Sequential_input initial (4), 7 19 Sequential_output initial (5), 7 20 Sequential_input_output initial (6), 7 21 Sequential_update initial (7), 7 22 Keyed_sequential_input initial (8), 7 23 Keyed_sequential_output initial (9), 7 24 Keyed_sequential_update initial (10), 7 25 Direct_input initial (11), 7 26 Direct_output initial (12), 7 27 Direct_update initial (13)) fixed bin int static options (constant); 7 28 7 29 /* End include file ..... iox_modes.incl.pl1 */ 651 652 end apl_coded_; SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 11/29/83 1558.2 apl_coded_.pl1 >special_ldd>on>apl.1129>apl_coded_.pl1 547 1 03/27/82 0429.8 apl_push_stack_fcn.incl.pl1 >ldd>include>apl_push_stack_fcn.incl.pl1 646 2 03/27/82 0438.5 apl_bead_format.incl.pl1 >ldd>include>apl_bead_format.incl.pl1 647 3 03/27/82 0429.8 apl_number_data.incl.pl1 >ldd>include>apl_number_data.incl.pl1 648 4 03/27/82 0439.0 apl_operators_argument.incl.pl1 >ldd>include>apl_operators_argument.incl.pl1 649 5 03/27/82 0439.2 apl_value_bead.incl.pl1 >ldd>include>apl_value_bead.incl.pl1 650 6 03/27/82 0439.2 apl_ws_info.incl.pl1 >ldd>include>apl_ws_info.incl.pl1 651 7 02/02/78 1229.7 iox_modes.incl.pl1 >ldd>include>iox_modes.incl.pl1 NAMES DECLARED IN THIS COMPILATION. IDENTIFIER OFFSET LOC STORAGE CLASS DATA TYPE ATTRIBUTES AND REFERENCES (* indicates a set context) NAMES DECLARED BY DECLARE STATEMENT. P_n_words parameter fixed bin(19,0) dcl 1-16 ref 1-4 1-35 addrel builtin function dcl 1-25 in procedure "apl_push_stack_" ref 1-44 addrel builtin function dcl 42 in procedure "apl_coded_" ref 164 165 209 210 296 324 apl_error_table_$domain 001452 external static fixed bin(35,0) dcl 16 ref 529 apl_error_table_$length 001454 external static fixed bin(35,0) dcl 16 ref 534 apl_error_table_$rank 001456 external static fixed bin(35,0) dcl 16 ref 539 apl_error_table_$system_error 001460 external static fixed bin(35,0) dcl 16 ref 544 apl_get_value_stack_ 001524 constant entry external dcl 1-30 ref 1-40 apl_static_$ws_info_ptr 001522 external static structure level 1 dcl 6-11 attach_desc 000100 automatic char(256) unaligned dcl 66 set ref 627* 630* b_ptr 000200 automatic pointer dcl 66 set ref 291* 296 303 329 332 bead_type based structure level 3 packed unaligned dcl 2-3 binary builtin function dcl 1-25 ref 1-40 block_ptr 000442 automatic pointer dcl 1-20 set ref 1-43* 1-45 buf_line_ptr 000202 automatic pointer dcl 66 set ref 296* 297* buffer based char initial array unaligned dcl 96 set ref 291 291* 303* 329 332 ceil builtin function dcl 42 ref 296 317 character_string_overlay based char dcl 5-19 ref 578 578 character_value 0(09) based bit(1) level 5 packed unaligned dcl 5-3 set ref 467 566 character_value_type constant bit(18) initial unaligned dcl 2-30 ref 319 code 000204 automatic fixed bin(35,0) dcl 66 set ref 109* 110 255* 256 260 297* 298 300 300 302 372* 438* 439* 480* 481 553* 554* 578* 579 615* 624* 625 630* 631 634* 635 638* convert_status_code_ 001526 constant entry external dcl 613 ref 615 data_elements 000205 automatic fixed bin(21,0) dcl 66 set ref 149* 158 161 163 195* 197* 197 202 206 208 241* 242 242 247 316* 317 320 569* 570 573 578 578 594* 596 599 data_pointer 4 based pointer level 2 packed unaligned dcl 5-3 set ref 147 167* 213* 245 284 325* 365 429 479 576 602 data_type 0(08) based structure level 4 packed unaligned dcl 5-3 eof 6 000010 internal static bit(1) initial array level 2 dcl 56 set ref 173 256* 259* 260* 263* 292* 295 300* 373* 550* 639* error_code 7 parameter fixed bin(35,0) level 2 dcl 4-3 set ref 529* 534* 539* 544* error_table_$end_of_info 001462 external static fixed bin(35,0) dcl 16 ref 260 300 error_table_$long_record 001464 external static fixed bin(35,0) dcl 16 ref 298 error_table_$noentry 001466 external static fixed bin(35,0) dcl 16 ref 110 error_table_$short_record 001470 external static fixed bin(35,0) dcl 16 ref 300 expand_pathname_ 001472 constant entry external dcl 27 ref 578 file_dname 000206 automatic char(168) unaligned dcl 66 set ref 109* 578* 624* file_ename 000260 automatic char(32) unaligned dcl 66 set ref 109* 578* 624* file_pathname 000270 automatic char(168) unaligned dcl 66 set ref 624* 627 file_tie_error_occurred 000342 automatic bit(1) unaligned dcl 66 set ref 431* 442* 445 general_bead based structure level 1 dcl 2-3 hbound builtin function dcl 42 ref 196 216 606 hcs_$status_minf 001474 constant entry external dcl 27 ref 109 header based structure level 2 dcl 5-3 integral_value 0(11) based bit(1) level 5 packed unaligned dcl 5-3 set ref 144 240 282 362 426 591 integral_value_type constant bit(18) initial unaligned dcl 2-30 ref 205 ioa_ 001476 constant entry external dcl 27 ref 486 492 497 502 507 509 513 517 521 iocb_ptr 000010 internal static pointer initial array level 2 dcl 56 set ref 173 197 217 236 255* 277 297* 370 372* 436 438* 439* 440* 462 480* 552 553* 554* 555* 606 606 621 630* 634* 638* iox_$attach_name 001500 constant entry external dcl 27 ref 630 iox_$close 001502 constant entry external dcl 27 ref 438 553 iox_$detach_iocb 001504 constant entry external dcl 27 ref 439 554 iox_$get_line 001506 constant entry external dcl 27 ref 297 iox_$open 001510 constant entry external dcl 27 ref 634 iox_$position 001512 constant entry external dcl 27 ref 255 372 638 iox_$put_chars 001514 constant entry external dcl 27 ref 480 lbound builtin function dcl 42 ref 196 216 606 left 000344 automatic pointer dcl 66 set ref 245* 246 249 284* 285 479* 480* 576* 578 578 left_vb 000346 automatic pointer dcl 66 set ref 115 238* 239 240 241 245 252 278* 279 281 282 283 284 289 394 466* 467 469 469 474 477 479 561* 563 566 569 573 576 lines_read 000350 automatic fixed bin(17,0) dcl 66 set ref 293* 296 303 307* 307 310 310* 313 316 322 327 longest 000351 automatic fixed bin(17,0) dcl 66 set ref 294* 306 306* 310 316 323 327 329 329 329 ltrim builtin function dcl 42 ref 578 578 max_line_length constant fixed bin(17,0) initial dcl 61 ref 291 291 291 291 291 296 297 303 303 303 329 329 329 332 332 maximum_value_stack_size 13 based fixed bin(18,0) level 3 dcl 6-16 ref 1-40 message 000352 automatic char(100) dcl 66 set ref 492* 497* 502* 507* 615* minimum_buffer based char array unaligned dcl 96 set ref 329* n_read 000403 automatic fixed bin(21,0) dcl 66 set ref 297* 303 304* 304 306 306 n_words 000404 automatic fixed bin(19,0) dcl 66 set ref 158* 159* 202* 203* 317* 318* no_of_lines 000405 automatic fixed bin(17,0) dcl 66 set ref 279* 285* 286 291 291 295 332 null builtin function dcl 42 ref 173 197 217 236 265 277 279 370 378 436 440 448 462 483 552 555 621 630 630 641 num_words 000444 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 000425 automatic fixed bin(17,0) dcl 5-3 set ref 157* 158 162 164 201* 202 207 209 313* 315* 317 321 323 324 numeric_datum based float bin(63) array dcl 5-23 set ref 158 171 173* 177* 202 220* 246 249 285 368 434 604 numeric_value 0(10) based bit(1) level 5 packed unaligned dcl 5-3 set ref 136 354 418 on_stack 1 parameter bit(1) array level 3 dcl 4-3 ref 113 115 150 251 252 288 289 348 392 394 412 472 474 operands parameter structure array level 2 dcl 4-3 operators_argument parameter structure level 1 dcl 4-3 set ref 6 101 125 189 229 270 340 383 404 454 pathname_$component_check 001516 constant entry external dcl 27 ref 624 pointers 14 based structure level 2 dcl 6-16 pos_request_type 000406 automatic fixed bin(17,0) dcl 66 set ref 246* 254 254 255* 256 pos_skip_count 000407 automatic fixed bin(21,0) dcl 66 set ref 247* 249* 255* 260 record_length 000410 automatic fixed bin(21,0) dcl 66 set ref 477* 480* rel builtin function dcl 42 in procedure "apl_coded_" ref 165 210 rel builtin function dcl 1-25 in procedure "apl_push_stack_" ref 1-40 result 000412 automatic pointer dcl 66 in procedure "apl_coded_" set ref 154* 164* 165 165* 165 167 173 177 209* 210 210* 210 213 220 324* 325 329 result 6 parameter pointer level 2 in structure "operators_argument" packed unaligned dcl 4-3 in procedure "apl_coded_" set ref 181* 224* 265* 333* 378* 448* 483* 641* result_vb 000414 automatic pointer dcl 66 set ref 152* 153 159* 160 161 162 163 164 167 181 203* 205 206 207 208 209 213 224 318* 319 320 321 322 323 324 325 333 rho 5 based fixed bin(21,0) array level 2 dcl 5-3 set ref 163* 208* 322* 323* rhorho 3 based fixed bin(17,0) level 2 dcl 5-3 set ref 139 157 162* 207* 321* 357 421 469 573 596 right 000416 automatic pointer dcl 66 set ref 147* 154 171 365* 368 429* 434 602* 604 right_vb 000420 automatic pointer dcl 66 set ref 113 131* 133 136 139 139 144 147 149 152 157 170 251 288 346* 348 351 354 357 357 362 365 367 392 410* 412 415 418 421 421 426 429 433 472 586* 588 591 594 596 602 rtrim builtin function dcl 42 ref 627 size builtin function dcl 42 ref 158 158 164 202 202 209 317 324 static_ws_info_ptr 001522 external static pointer level 2 packed unaligned dcl 6-11 ref 6-7 string builtin function dcl 42 set ref 153* 160* 205* 319* subscript 000422 automatic fixed bin(21,0) dcl 66 set ref 170* 170* 171 173 177* 215* 219* 219 220 295* 327* 329 329* 367* 367* 368* 433* 433* 434* 549* 550 551 552 553 554 555* substr builtin function dcl 42 in procedure "apl_coded_" set ref 165 210 303* substr builtin function dcl 1-25 in procedure "apl_push_stack_" ref 1-37 switch 2 000010 internal static char(15) array level 2 packed unaligned dcl 56 set ref 551* 628* 630* tcb 000010 internal static structure array level 1 dcl 56 set ref 196 196 216 216 tcbx 000423 automatic fixed bin(17,0) dcl 66 set ref 196* 197* 216* 217 220* tie_num 000424 automatic fixed bin(17,0) dcl 66 set ref 171* 173 173 236 255 256 259 260 263 277 292 295 297 300 368* 370 372 373 434* 436 438 439 440 462 480 486* 513* 604* 606 606 621 628 630 630 634 638 639 time_invoked 20 based fixed bin(71,0) level 2 dcl 6-16 ref 102 104 126 128 190 192 230 232 271 273 341 343 384 386 405 407 455 457 time_iofns_invoked 001450 internal static fixed bin(71,0) initial dcl 61 set ref 102 104* 126 128* 190 192* 230 232* 271 273* 341 343* 384 386* 405 407* 455 457* total_data_elements 2 based fixed bin(21,0) level 2 dcl 5-3 set ref 139 149 161* 170 206* 241 283 320* 357 367 421 433 469 477 569 594 type based structure level 3 in structure "value_bead" packed unaligned dcl 5-3 in procedure "apl_coded_" set ref 153* 160* 205* 319* type based structure level 2 in structure "general_bead" packed unaligned dcl 2-3 in procedure "apl_coded_" unique_chars_ 001520 constant entry external dcl 27 ref 628 unspec builtin function dcl 1-25 ref 1-37 value parameter pointer array level 3 in structure "operators_argument" packed unaligned dcl 4-3 in procedure "apl_coded_" ref 131 238 278 346 410 466 561 586 value 0(02) based bit(1) level 4 in structure "general_bead" packed unaligned dcl 2-3 in procedure "apl_coded_" ref 133 239 281 351 415 563 588 value_bead based structure level 1 dcl 5-3 set ref 158 164 202 209 317 324 value_stack_ptr 16 based pointer level 3 packed unaligned dcl 6-16 set ref 113* 115* 251* 252* 288* 289* 348* 392* 394* 412* 472* 474* 1-40 1-43 1-44* 1-44 values 2 based structure level 2 dcl 6-16 ws_info based structure level 1 dcl 6-16 ws_info_ptr 000426 automatic pointer initial dcl 6-7 set ref 102 104 113 115 126 128 190 192 230 232 251 252 271 273 288 289 341 343 348 384 386 392 394 405 407 412 455 457 472 474 6-7* 1-40 1-40 1-43 1-44 1-44 zero_or_one_value_type constant bit(18) initial unaligned dcl 2-30 ref 153 160 NAMES DECLARED BY DECLARE STATEMENT AND NEVER REFERENCED. Binary internal static bit(1) initial dcl 3-16 Direct_input internal static fixed bin(17,0) initial dcl 7-15 Direct_output internal static fixed bin(17,0) initial dcl 7-15 Direct_update internal static fixed bin(17,0) initial dcl 7-15 Keyed_sequential_input internal static fixed bin(17,0) initial dcl 7-15 Keyed_sequential_output internal static fixed bin(17,0) initial dcl 7-15 Keyed_sequential_update internal static fixed bin(17,0) initial dcl 7-15 MAX_VALUE_BEAD_SIZE internal static fixed bin(19,0) initial dcl 5-28 NumberSize internal static fixed bin(4,0) initial dcl 3-25 Sequential_input internal static fixed bin(17,0) initial dcl 7-15 Sequential_input_output internal static fixed bin(17,0) initial dcl 7-15 Sequential_output internal static fixed bin(17,0) initial dcl 7-15 Sequential_update internal static fixed bin(17,0) initial dcl 7-15 Stream_input internal static fixed bin(17,0) initial dcl 7-15 Stream_input_output internal static fixed bin(17,0) initial dcl 7-15 Stream_output internal static fixed bin(17,0) initial dcl 7-15 TheBiggestNumberWeveGot internal static float bin(63) initial dcl 3-16 TheSmallestNumberWeveGot internal static float bin(63) initial dcl 3-16 character_data_structure based structure level 1 dcl 5-15 complex_datum based complex float bin(63) array dcl 5-26 complex_value_type internal static bit(18) initial unaligned dcl 2-30 function_type internal static bit(18) initial unaligned dcl 2-30 group_type internal static bit(18) initial unaligned dcl 2-30 iox_modes internal static char(24) initial array dcl 7-6 label_type internal static bit(18) initial unaligned dcl 2-30 lexed_function_type internal static bit(18) initial unaligned dcl 2-30 list_value_type internal static bit(18) initial unaligned dcl 2-30 max_parse_stack_depth internal static fixed bin(17,0) initial dcl 6-98 not_integer_mask internal static bit(18) initial unaligned dcl 2-30 not_zero_or_one_mask internal static bit(18) initial unaligned dcl 2-30 numeric_value_type internal static bit(18) initial unaligned dcl 2-30 operator_type internal static bit(18) initial unaligned dcl 2-30 output_buffer based char unaligned dcl 6-94 shared_variable_type internal static bit(18) initial unaligned dcl 2-30 short_iox_modes internal static char(4) initial array dcl 7-12 symbol_type internal static bit(18) initial unaligned dcl 2-30 value_type internal static bit(18) initial unaligned dcl 2-30 NAMES DECLARED BY EXPLICIT CONTEXT. already_tied 002063 constant label dcl 486 ref 621 apl_coded_ 000154 constant entry external dcl 6 apl_push_stack_ 002350 constant entry internal dcl 1-4 ref 159 203 318 cant_attach 002104 constant label dcl 490 ref 625 631 cant_open 002131 constant label dcl 495 ref 635 cant_read_record 002153 constant label dcl 500 ref 298 cant_write_record 002200 constant label dcl 505 set ref 481 close_files 002413 constant entry internal dcl 548 ref 103 127 191 231 272 342 385 406 456 create 000165 constant entry external dcl 101 decode_file_id 002467 constant entry internal dcl 559 ref 106 389 decode_tie_num 002566 constant entry internal dcl 584 ref 107 235 276 390 460 domain_error_left 002320 constant label dcl 529 ref 239 240 254 281 282 286 467 563 566 domain_error_right 002320 constant label dcl 529 ref 133 136 144 351 354 362 415 418 426 588 591 eof 000277 constant entry external dcl 125 expand_code 002626 constant entry internal dcl 611 ref 490 495 500 505 file_name_error 002224 constant label dcl 509 ref 110 579 file_not_tied 002242 constant label dcl 513 ref 236 277 462 file_tie_error 002263 constant label dcl 517 ref 173 370 445 606 length_error_left 002326 constant label dcl 534 ref 242 283 570 length_error_right 002326 constant label dcl 534 ref 599 nums 000467 constant entry external dcl 189 open_file 002645 constant entry internal dcl 619 ref 118 397 position 000625 constant entry external dcl 229 position_out_of_bounds 002301 constant label dcl 521 ref 260 rank_error_left 002334 constant label dcl 539 ref 469 573 rank_error_right 002334 constant label dcl 539 ref 139 357 421 596 read 001012 constant entry external dcl 270 rewind 001416 constant entry external dcl 340 system_error 002342 constant label dcl 544 ref 488 493 498 503 511 515 519 523 tie 001543 constant entry external dcl 383 untie 001610 constant entry external dcl 404 write 001750 constant entry external dcl 454 THERE WERE NO NAMES DECLARED BY CONTEXT OR IMPLICATION. STORAGE REQUIREMENTS FOR THIS PROGRAM. Object Text Link Symbol Defs Static Start 0 0 3456 5206 3116 3466 Length 5630 3116 1530 405 337 1442 BLOCK NAME STACK SIZE TYPE WHY NONQUICK/WHO SHARES STACK FRAME apl_coded_ 441 external procedure is an external procedure. apl_push_stack_ internal procedure shares stack frame of external procedure apl_coded_. close_files internal procedure shares stack frame of external procedure apl_coded_. decode_file_id internal procedure shares stack frame of external procedure apl_coded_. decode_tie_num internal procedure shares stack frame of external procedure apl_coded_. expand_code internal procedure shares stack frame of external procedure apl_coded_. open_file internal procedure shares stack frame of external procedure apl_coded_. STORAGE FOR INTERNAL STATIC VARIABLES. LOC IDENTIFIER BLOCK NAME 000010 tcb apl_coded_ 001450 time_iofns_invoked apl_coded_ STORAGE FOR AUTOMATIC VARIABLES. STACK FRAME LOC IDENTIFIER BLOCK NAME apl_coded_ 000100 attach_desc apl_coded_ 000200 b_ptr apl_coded_ 000202 buf_line_ptr apl_coded_ 000204 code apl_coded_ 000205 data_elements apl_coded_ 000206 file_dname apl_coded_ 000260 file_ename apl_coded_ 000270 file_pathname apl_coded_ 000342 file_tie_error_occurred apl_coded_ 000344 left apl_coded_ 000346 left_vb apl_coded_ 000350 lines_read apl_coded_ 000351 longest apl_coded_ 000352 message apl_coded_ 000403 n_read apl_coded_ 000404 n_words apl_coded_ 000405 no_of_lines apl_coded_ 000406 pos_request_type apl_coded_ 000407 pos_skip_count apl_coded_ 000410 record_length apl_coded_ 000412 result apl_coded_ 000414 result_vb apl_coded_ 000416 right apl_coded_ 000420 right_vb apl_coded_ 000422 subscript apl_coded_ 000423 tcbx apl_coded_ 000424 tie_num apl_coded_ 000425 number_of_dimensions apl_coded_ 000426 ws_info_ptr apl_coded_ 000442 block_ptr apl_push_stack_ 000444 num_words apl_push_stack_ THE FOLLOWING EXTERNAL OPERATORS ARE USED BY THIS PROGRAM. fx1_to_fl2 alloc_cs cat_realloc_cs call_ext_out_desc call_ext_out return fl2_to_fx1 mpfx2 shorten_stack ext_entry ceil_fx2 divide_fx1 alloc_based_storage free_based THE FOLLOWING EXTERNAL ENTRIES ARE CALLED BY THIS PROGRAM. apl_get_value_stack_ convert_status_code_ expand_pathname_ hcs_$status_minf ioa_ iox_$attach_name iox_$close iox_$detach_iocb iox_$get_line iox_$open iox_$position iox_$put_chars pathname_$component_check unique_chars_ THE FOLLOWING EXTERNAL VARIABLES ARE USED BY THIS PROGRAM. apl_error_table_$domain apl_error_table_$length apl_error_table_$rank apl_error_table_$system_error apl_static_$ws_info_ptr error_table_$end_of_info error_table_$long_record error_table_$noentry error_table_$short_record LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC 6 7 000144 6 000151 101 000162 102 000173 103 000200 104 000201 106 000205 107 000206 109 000207 110 000250 113 000254 115 000265 118 000273 119 000274 125 000275 126 000305 127 000312 128 000313 131 000317 133 000323 136 000326 139 000331 144 000337 147 000342 149 000344 150 000346 152 000351 153 000352 154 000355 155 000357 157 000360 158 000362 159 000372 160 000374 161 000377 162 000402 163 000404 164 000406 165 000413 167 000421 170 000422 171 000430 173 000435 177 000453 179 000456 181 000460 182 000464 189 000465 190 000475 191 000502 192 000503 195 000507 196 000510 197 000515 199 000524 201 000526 202 000530 203 000540 205 000542 206 000545 207 000550 208 000552 209 000554 210 000561 213 000567 215 000570 216 000572 217 000577 219 000605 220 000606 222 000614 224 000616 225 000622 229 000623 230 000633 231 000640 232 000641 235 000645 236 000646 238 000656 239 000661 240 000664 241 000667 242 000671 245 000675 246 000677 247 000702 249 000710 251 000713 252 000723 254 000730 255 000735 256 000752 259 000764 260 000770 263 001001 265 001003 266 001007 270 001010 271 001020 272 001025 273 001026 276 001032 277 001033 278 001043 279 001046 281 001055 282 001060 283 001063 284 001066 285 001070 286 001073 288 001075 289 001105 291 001112 292 001147 293 001152 294 001153 295 001154 296 001170 297 001204 298 001225 300 001231 302 001241 303 001243 304 001255 306 001257 307 001263 308 001264 310 001266 313 001274 315 001302 316 001304 317 001307 318 001322 319 001324 320 001327 321 001332 322 001334 323 001336 324 001341 325 001346 327 001347 329 001361 330 001377 332 001401 333 001407 334 001413 340 001414 341 001424 342 001431 343 001432 346 001436 348 001442 351 001446 354 001451 357 001454 362 001462 365 001465 367 001467 368 001474 370 001500 372 001507 373 001527 376 001532 378 001534 379 001540 383 001541 384 001551 385 001556 386 001557 389 001563 390 001564 392 001565 394 001576 397 001604 398 001605 404 001606 405 001616 406 001623 407 001624 410 001630 412 001634 415 001640 418 001643 421 001646 426 001654 429 001657 431 001661 433 001662 434 001670 436 001674 438 001703 439 001714 440 001726 441 001732 442 001733 443 001735 445 001737 448 001741 449 001745 454 001746 455 001756 456 001763 457 001764 460 001770 462 001771 466 002001 467 002004 469 002007 472 002015 474 002025 477 002032 479 002035 480 002037 481 002054 483 002056 484 002062 486 002063 488 002103 490 002104 492 002105 493 002130 495 002131 497 002132 498 002152 500 002153 502 002154 503 002177 505 002200 507 002201 509 002224 511 002241 513 002242 515 002262 517 002263 519 002300 521 002301 523 002317 529 002320 532 002325 534 002326 537 002333 539 002334 542 002341 544 002342 546 002347 1 4 002350 1 35 002352 1 37 002354 1 40 002361 1 43 002376 1 44 002401 1 45 002410 548 002413 549 002414 550 002421 551 002424 552 002430 553 002435 554 002446 555 002460 557 002464 558 002466 559 002467 561 002470 563 002473 566 002476 569 002501 570 002503 573 002505 576 002511 578 002513 579 002562 581 002565 584 002566 586 002567 588 002573 591 002576 594 002601 596 002603 599 002611 602 002614 604 002616 606 002621 609 002625 611 002626 615 002627 616 002644 619 002645 621 002646 624 002655 625 002704 627 002706 628 002745 630 002766 631 003021 634 003023 635 003047 638 003051 639 003074 641 003100 642 003104 ----------------------------------------------------------- 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