COMPILATION LISTING OF SEGMENT mrds_builtin_ Compiled by: Multics PL/I Compiler, Release 28e, of February 14, 1985 Compiled at: Honeywell Multics Op. - System M Compiled on: 04/18/85 1014.8 mst Thu Options: optimize map 1 /* *********************************************************** 2* * * 3* * * 4* * Copyright, (C) Honeywell Information Systems Inc., 1981 * 5* * * 6* * * 7* *********************************************************** */ 8 9 /* ****************************************************** 10* * * 11* * * 12* * Copyright (c) 1972 by Massachusetts Institute of * 13* * Technology and Honeywell Information Systems, Inc. * 14* * * 15* * * 16* ****************************************************** */ 17 18 mrds_builtin_: 19 proc; 20 21 /* DESCRIPTION: 22* 23* This procedure contains entries to implement all MRDS and LINUS scalar 24* builtin functions. No error codes are returned from this modules but two 25* kinds of conditions call be signaled function_err and fatal_func_err. 26* function_err is signaled when a stringsize condition is encountered 27* fatal_func_err is signaled for all other errors detected. 28* 29* 30* 31* HISTORY: 32* 33* 77-06-01 J. A. Weeldreyer: Initially written. 34* 35* 77-07-01 R. D. Lackey: Modified to complete implemetation of mrds builtin 36* functions. 37* 38* 77-12-01 R. D. Lackey: Modified to correct round builtin. 39* 40* 78-03-01 R. D. Lackey: Modified to correct size in concat descriptor. 41* 42* 78-04-01 R. D. Lackey: Modified to add fatal_func_err condition. 43* 44* 79-12-13 Davids: Modified rnd to take log10 (abs (in_val)) rather then 45* log10 (in_val) in_val = 0 is a special case and returns 0. 46* 47* 79-12-20 Davids: Modified value of CHAR_VAR_DESC so that it shows an 48* unpacked varying char desc. Modified value of BIT_VAR_DESC so that its 49* unpacked and really varying. 50* 51* 79-12-21 Davids: Took the condition handling out of the substr function and 52* explicitly check for those things that can cause the stringrange condition 53* to be signaled. Also modified the assignment of the lengths of varying 54* character and bit strings in canon_bit and canon_char to use the actual 55* length not the declared length. The length of the return string in the 56* reverse function is now taken from the descriptor pointed to by the third 57* pointer in arg_list rather than the first. 58* 59* 79-12-26 Davids: Modified canon_char so that the internal pointer pointing 60* at a bit varying data type points to the length word. 61* 62* 79-12-27 Davids: bnv in canon_bit is now based on a_ptr rather than b_ptr. 63* 64* 80-01-01 Jim Gray : Modified to add calls to mu_data_class$xxxx_data_class 65* so that packed decimal data types could be handled. Also the structure 66* rslt_cfld_59 had its float decimal(59) members changed to aligned, so that 67* it looks like a complex float decimal(59) aligned, which the new unaligned 68* decimal would not imitate. 69* 70* 80-01-07 Rickie E. Brinegar: Modified to make substr check of descriptor 71* class types work properly. 72* 73* 80-02-01 Jim Gray : Modified to make use of extensible non-freeing area for 74* temp storage rather than system_free. 75* 76* 81-08-14 Roger Lackey : Removed init and tidy_up internal procedures and 77* replaced allocation in connoize procedures to use automatice variables for 78* buffering instead of allocation. 79* 80* 81-09-21 Davids: added a line of code to all entries that use 81* arg_list to set the value of num_ptrs to prevent a subscriptrange 82* condition from occuring. 83* 84* 81-09-23 Davids: modified substr so that if the requested length 85* of the substring would cause a reference beyond the end of the 86* original string, the length of the substring returned is shorted 87* so that it references up to the last character (bit) of the 88* original string. 89* 90* 81-09-24 Davids: Removed all references to the variables t1 and 91* t2. These variables were being set but never referenced. It looks 92* like a past change removed their usefullness but they were not 93* removed at that time. Since they were declared fixed bin (5) and 94* they were being set to the descriptor type which is fixed bin (6) 95* unsigned a size condition was possible and in fact was occurring 96* in floor_info when used with a data type of real float decimal 97* unaligned. 98**/ 99 100 return; /* should never use mrds_builtin_ entry */ 101 102 abs: 103 entry; 104 105 /* This entry impliments the MRDS/LINUS "abs" builtin function. 106* This is an arithmetic function, so only an arithmetic argument is accepted. 107* If the argument is non-complex the input value is converted to float decimal (59) 108* prior to calling the abs builtin function. 109* The returned result is float decimal (59). 110* The PL/I "abs" builtin is used to actually perform the function. */ 111 112 on size call fatal_func_error; 113 on conversion call fatal_func_error; 114 115 /* BEGIN CHANGE 81-08-14 RDL ********************************************** */ 116 117 num_ptrs = 0; /* to aviod a compiler warning */ 118 119 /* END CHANGE 81-08-14 RDL ********************************************** */ 120 121 call cu_$arg_list_ptr (al_ptr); /* Get the argument list pointer */ 122 num_ptrs = arg_list.arg_count; /* CHANGE 81-09-21 */ 123 r_ptr = arg_list.arg_des_ptr (2); /* Points to place to store result */ 124 125 call 126 conv_to_float_dec_59 (arg_list.arg_des_ptr (1), 127 arg_list.arg_des_ptr (3), fld_val_1); /* Convert to 128* float decimal (59) */ 129 (size, conversion): 130 rslt_fld_59 = abs (fld_val_1); 131 132 return; /* End of abs entry */ 133 134 135 136 abs_info: 137 entry (ad_ptr, rslt_desc); 138 139 /* Info entry for the "abs" builtin */ 140 /* rslt_desc = 0 or float decimal (59) */ 141 142 if arg_descs.ndescs ^= 1 then 143 rslt_desc = "0"b; /* Must have only one arg */ 144 145 else if mu_data_class$convertible_data_class (addr (arg_descs.desc (1))) 146 then rslt_desc = FLD59_DESC; 147 148 else rslt_desc = "0"b; 149 150 return; /* End of abs info entry */ 151 152 after: 153 entry; 154 155 /* This entry implements the MRDS/LINUS "after" builtin function. This is 156* a string function, so arithmetic arguments are not accepted. If there is a 157* mixture of character and bit arguments, an attempt is made to convert the bit 158* argument to a character string. The PL/I "after" builtin is used to actualy perform 159* the function. Returned result is either a bit or char varying string. */ 160 161 162 /* BEGIN CHANGE 81-08-14 RDL ********************************************** */ 163 164 a1_ptr = addr (buffer1); 165 a2_ptr = addr (buffer2); 166 167 /* END CHANGE 81-08-14 RDL ********************************************** */ 168 169 call cu_$arg_list_ptr (al_ptr); /* get pointer to arg list */ 170 num_ptrs = arg_list.arg_count; /* CHANGE 81-09-21 */ 171 r_ptr = addrel (arg_list.arg_des_ptr (3), -1); /* point to place to store result */ 172 173 r_len = fixed (string (arg_list.arg_des_ptr (6) -> descriptor.size), 24); 174 /* Max length of return string 175* can be no longer then length of input string (arg (1)) */ 176 177 if mu_data_class$bit_data_class (arg_list.arg_des_ptr (4)) 178 & mu_data_class$bit_data_class (arg_list.arg_des_ptr (5)) then do; 179 /* will canonize to bit var */ 180 call canon_bit (1, a1_ptr, a1_len); 181 call canon_bit (2, a2_ptr, a2_len); 182 rslt_bit_string = after (b1, b2); /* do bit string after */ 183 end; 184 else do; /* canonize to char. var. */ 185 call canon_char (1, a1_ptr, a1_len); 186 call canon_char (2, a2_ptr, a2_len); 187 rslt_char_string = after (c1, c2); /* Do char string after */ 188 end; 189 190 191 192 return; /* End of after entry */ 193 194 after_info: 195 entry (ad_ptr, rslt_desc); 196 197 /* Info entry for the "after" builtin */ 198 /* rslt_desc = 0 or BIT_VAR_DESC or CHAR_VAR_DESC */ 199 200 rslt_desc = arg_descs.desc (1); /* Init to non-zero value */ 201 202 if arg_descs.ndescs ^= 2 then 203 rslt_desc = "0"b; /* Exactly 2 arguments required */ 204 205 else /* Check for string args */ 206 if ^(mu_data_class$string_data_class (addr (arg_descs.desc (1))) 207 & mu_data_class$string_data_class (addr (arg_descs.desc (2)))) 208 then rslt_desc = "0"b; 209 210 if rslt_desc ^= "0"b then do; /* Everything OK so set rslt_desc */ 211 212 rslt_desc = "0"b; /* Zero all the bits in the rslt_desc */ 213 214 if addr (arg_descs.desc (1)) -> descriptor.type = /* If both string types are the same */ 215 addr (arg_descs.desc (2)) -> descriptor.type then do; 216 if addr (arg_descs.desc (1)) -> descriptor.type < 21 then 217 rslt_desc = BIT_VAR_DESC;/* Bit varying */ 218 else rslt_desc = CHAR_VAR_DESC; /* Char varying */ 219 end; 220 221 else /* String types are different */ 222 rslt_desc = CHAR_VAR_DESC; /* So make it char varying */ 223 224 addr (rslt_desc) -> descriptor.size = 225 addr (arg_descs.desc (1)) -> descriptor.size; /* Size can be no larger 226* then that of the input string */ 227 228 end; 229 230 return; /* End of after_info entry */ 231 232 before: 233 entry; 234 235 /* This entry implements the MRDS/LINUS "before" builtin function. This is 236* a string function, so arithmetic arguments are not accepted. If there is a 237* mixture of character and bit arguments, an attempt is made to convert the bit 238* argument to a character string. The PL/I "before" builtin is used to actualy perform 239* the function. Returned result is either a bit or char varying string. */ 240 241 242 /* BEGIN CHANGE 81-08-14 RDL ********************************************** */ 243 244 a1_ptr = addr (buffer1); 245 a2_ptr = addr (buffer2); 246 247 /* END CHANGE 81-08-14 RDL ********************************************** */ 248 249 call cu_$arg_list_ptr (al_ptr); /* get pointer to arg list */ 250 num_ptrs = arg_list.arg_count; /* CHANGE 81-09-21 */ 251 r_ptr = addrel (arg_list.arg_des_ptr (3), -1); /* point to place to store result */ 252 253 r_len = fixed (string (arg_list.arg_des_ptr (6) -> descriptor.size), 24); 254 /* Max length of return string 255* can be no longer then length of input string (arg (1)) */ 256 257 if mu_data_class$bit_data_class (arg_list.arg_des_ptr (4)) 258 & mu_data_class$bit_data_class (arg_list.arg_des_ptr (5)) then do; 259 /* will canonize to bit var */ 260 call canon_bit (1, a1_ptr, a1_len); 261 call canon_bit (2, a2_ptr, a2_len); 262 rslt_bit_string = before (b1, b2); /* do bit string before */ 263 end; 264 else do; /* canonize to char. var. */ 265 call canon_char (1, a1_ptr, a1_len); 266 call canon_char (2, a2_ptr, a2_len); 267 rslt_char_string = before (c1, c2); /* Do char string before */ 268 end; 269 270 271 return; /* End of before entry */ 272 273 before_info: 274 entry (ad_ptr, rslt_desc); 275 276 /* Info entry for the "before" builtin */ 277 /* rslt_desc = 0 or BIT_VAR_DESC or CHAR_VAR_DESC */ 278 279 rslt_desc = arg_descs.desc (1); /* Init to non-zero value */ 280 281 if arg_descs.ndescs ^= 2 then 282 rslt_desc = "0"b; /* Exactly 2 arguments required */ 283 284 else /* Check for string args */ 285 if ^(mu_data_class$string_data_class (addr (arg_descs.desc (1))) 286 & mu_data_class$string_data_class (addr (arg_descs.desc (2)))) 287 then rslt_desc = "0"b; 288 289 if rslt_desc ^= "0"b then do; /* Everything OK so set rslt_desc */ 290 291 rslt_desc = "0"b; /* Zero all the bits in the rslt_desc */ 292 293 if addr (arg_descs.desc (1)) -> descriptor.type = /* If both string types are the same */ 294 addr (arg_descs.desc (2)) -> descriptor.type then do; 295 296 if addr (arg_descs.desc (1)) -> descriptor.type < 21 then 297 rslt_desc = BIT_VAR_DESC;/* Bit varying */ 298 else rslt_desc = CHAR_VAR_DESC; /* Char varying */ 299 end; 300 301 else /* String types are different */ 302 rslt_desc = CHAR_VAR_DESC; /* So make it char varying */ 303 304 addr (rslt_desc) -> descriptor.size = 305 addr (arg_descs.desc (1)) -> descriptor.size; /* Size can be no larger 306* then that of the input string */ 307 308 end; 309 310 return; /* End of before_info entry */ 311 312 ceil: 313 entry; 314 315 /* This entry impliments the MRDS/LINUS "ceil" builtin function. 316* This is an arithmetic function, so only an arithmetic argument is accepted. 317* The argument is converted to float decimal (59) prior to calling the ceil builtin function. 318* The returned result is float decimal (59). 319* The PL/i "ceil" builtin is used to actually perform the function. */ 320 321 on size call fatal_func_error; 322 on conversion call fatal_func_error; 323 call cu_$arg_list_ptr (al_ptr); /* Get the argument list pointer */ 324 num_ptrs = arg_list.arg_count; /* CHANGE 81-09-21 */ 325 r_ptr = arg_list.arg_des_ptr (2); /* Points to place to store result */ 326 327 call 328 conv_to_float_dec_59 (arg_list.arg_des_ptr (1), 329 arg_list.arg_des_ptr (3), fld_val_1); /* Convert to 330* float decimal (59) */ 331 (size, conversion): 332 rslt_fld_59 = ceil (fld_val_1); 333 334 return; /* End of ceil entry */ 335 336 337 338 ceil_info: 339 entry (ad_ptr, rslt_desc); 340 341 /* Info entry for the "ceil" builtin */ 342 /* rslt_desc = 0 or float decimal (59) */ 343 344 if arg_descs.ndescs ^= 1 then 345 rslt_desc = "0"b; /* Must have only one arg */ 346 347 else if mu_data_class$convertible_data_class (addr (arg_descs.desc (1))) 348 then rslt_desc = FLD59_DESC; 349 350 else rslt_desc = "0"b; 351 352 return; /* End of ceil info entry */ 353 354 concat: 355 entry; 356 357 /* This entry implements the MRDS/LINUS "concat" builtin function. This is 358* a string function, so arithmetic arguments are not accepted. If there is a 359* mixture of character and bit arguments, an attempt is made to convert the bit 360* argument to a character string. Returned result is either a bit or char varying string. */ 361 362 363 /* BEGIN CHANGE 81-08-14 RDL ********************************************** */ 364 365 a1_ptr = addr (buffer1); 366 a2_ptr = addr (buffer2); 367 368 /* END CHANGE 81-08-14 RDL ********************************************** */ 369 370 call cu_$arg_list_ptr (al_ptr); /* get pointer to arg list */ 371 num_ptrs = arg_list.arg_count; /* CHANGE 81-09-21 */ 372 r_ptr = addrel (arg_list.arg_des_ptr (3), -1); /* point to place to store result */ 373 374 r_len = fixed (string (arg_list.arg_des_ptr (6) -> descriptor.size), 26); 375 /* Max length of return string */ 376 377 if mu_data_class$bit_data_class (arg_list.arg_des_ptr (4)) 378 & mu_data_class$bit_data_class (arg_list.arg_des_ptr (5)) then do; 379 /* will canonize to bit var */ 380 call canon_bit (1, a1_ptr, a1_len); 381 call canon_bit (2, a2_ptr, a2_len); 382 rslt_bit_string = b1 || b2; /* do bit string concatination */ 383 end; 384 else do; /* canonize to char. var. */ 385 call canon_char (1, a1_ptr, a1_len); 386 call canon_char (2, a2_ptr, a2_len); 387 rslt_char_string = c1 || c2; /* Do char string concat */ 388 end; 389 390 391 return; /* End of concat entry */ 392 393 394 concat_info: 395 entry (ad_ptr, rslt_desc); 396 397 /* Info entry for the "concat" builtin */ 398 /* rslt_desc = 0 or BIT_VAR_DESC or CHAR_VAR_DESC */ 399 400 if arg_descs.ndescs ^= 2 then 401 rslt_desc = "0"b; /* Must have exactly two args */ 402 403 else /* Check for string args */ 404 if ^(mu_data_class$string_data_class (addr (arg_descs.desc (1))) 405 & mu_data_class$string_data_class (addr (arg_descs.desc (2)))) 406 then rslt_desc = "0"b; 407 408 else do; /* If everything OK then build the descriptor */ 409 410 rslt_desc = "0"b; 411 412 if addr (arg_descs.desc (1)) -> descriptor.type = /* If both string types are the same */ 413 addr (arg_descs.desc (2)) -> descriptor.type then do; 414 if addr (arg_descs.desc (1)) -> descriptor.type < 21 then 415 rslt_desc = BIT_VAR_DESC;/* Bit varying */ 416 else rslt_desc = CHAR_VAR_DESC; /* Char varying */ 417 end; 418 419 else /* String types are different */ 420 rslt_desc = CHAR_VAR_DESC; /* So make it char varying */ 421 422 423 s1 = fixed (string (addr (arg_descs.desc (1)) -> descriptor.size), 24); 424 s2 = fixed (string (addr (arg_descs.desc (2)) -> descriptor.size), 24); 425 426 desc_ptr = addr (rslt_desc); 427 n = s1 + s2; /* Max size = sum tow input sizes */ 428 string (descriptor.size) = bit (n); /* New size = sum of two input sizes */ 429 430 end; 431 432 return; /* End of concat_info entry */ 433 434 435 floor: 436 entry; 437 438 /* This entry impliments the MRDS/LINUS "floor" builtin function. 439* This is an arithmetic function, only an arithmetic non-complex argument is accepted. 440* The argument is converted to float decimal (59) prior to calling the floor builtin function. 441* The returned result is a float decimal (59). 442* The PL/I "floor" builtin is used to actually perform the function. */ 443 444 on size call fatal_func_error; 445 on conversion call fatal_func_error; 446 447 call cu_$arg_list_ptr (al_ptr); /* Get the argument list pointer */ 448 num_ptrs = arg_list.arg_count; /* CHANGE 81-09-21 */ 449 r_ptr = arg_list.arg_des_ptr (2); /* Points to place to store result */ 450 451 call 452 conv_to_float_dec_59 (arg_list.arg_des_ptr (1), 453 arg_list.arg_des_ptr (3), fld_val_1); /* Convert to 454* float decimal (59) */ 455 (size, conversion): 456 rslt_fld_59 = floor (fld_val_1); /* Find the floor */ 457 458 return; /* End of floor entry */ 459 460 461 462 floor_info: 463 entry (ad_ptr, rslt_desc); 464 465 /* Info entry for the "floor" builtin */ 466 /* rslt_desc = 0 or float decimal (59) */ 467 468 if arg_descs.ndescs ^= 1 then 469 rslt_desc = "0"b; /* Must have only one arg */ 470 471 else if mu_data_class$convertible_data_class (addr (arg_descs.desc (1))) 472 then rslt_desc = FLD59_DESC; 473 474 else rslt_desc = "0"b; 475 476 return; /* End of floor info entry */ 477 478 index: 479 entry; 480 481 /* This entry implements the MRDS/LINUS "index" builtin function. This is 482* a string function, so arithmetic arguments are not accepted. If there is a 483* mixture of character and bit arguments, an attempt is made to convert the bit 484* argument to a character string. The PL/I "index" builtin is used to actualy perform 485* the function. Returned result is a fixed bin (24). */ 486 487 488 call cu_$arg_list_ptr (al_ptr); /* get pointer to arg list */ 489 num_ptrs = arg_list.arg_count; /* CHANGE 81-09-21 */ 490 r_ptr = arg_list.arg_des_ptr (3); /* point to place to store result */ 491 492 a1_ptr = addr (buffer1); 493 a2_ptr = addr (buffer2); 494 495 if mu_data_class$bit_data_class (arg_list.arg_des_ptr (4)) 496 & mu_data_class$bit_data_class (arg_list.arg_des_ptr (5)) then do; 497 /* will canonize to bit var */ 498 call canon_bit (1, a1_ptr, a1_len); 499 call canon_bit (2, a2_ptr, a2_len); 500 rslt_bin = index (b1, b2); /* do bit string index */ 501 end; 502 else do; /* canonize to char. var. */ 503 call canon_char (1, a1_ptr, a1_len); 504 call canon_char (2, a2_ptr, a2_len); 505 rslt_bin = index (c1, c2); /* Do char string index */ 506 end; 507 508 509 return; /* end of index */ 510 511 512 513 514 515 index_info: 516 entry (ad_ptr, rslt_desc); 517 518 /* Info entry for the "index" builtin */ 519 /* rslt_desc = 0 or FIXED_BIN_24 */ 520 521 if arg_descs.ndescs ^= 2 then 522 rslt_desc = "0"b; /* need exactly 2 args */ 523 else /* check for string args */ 524 if ^(mu_data_class$string_data_class (addr (arg_descs.desc (1))) 525 & mu_data_class$string_data_class (addr (arg_descs.desc (2)))) 526 then rslt_desc = "0"b; 527 else rslt_desc = FIB24_DESC; /* have 2 string args */ 528 529 return; /* end of index info entry */ 530 531 mod: 532 entry; 533 534 /* This entry implements the MRDS/LINUS "mod" builtin function. 535* This is an arithmetic function, so only arithmetic arguments are allowed. 536* The input arguments are converted to float decimal (59) and the 537* returned result is a float decimal (59). 538* The PL/I "mod" builtin is used to actually perform the function. */ 539 540 on size call fatal_func_error; 541 on conversion call fatal_func_error; 542 543 call cu_$arg_list_ptr (al_ptr); /* Get the argument list pointer */ 544 num_ptrs = arg_list.arg_count; /* CHANGE 81-09-21 */ 545 r_ptr = arg_list.arg_des_ptr (3); /* Points to the place to store result */ 546 547 call 548 conv_to_float_dec_59 (arg_list.arg_des_ptr (1), 549 arg_list.arg_des_ptr (4), fld_val_1); /* Convert to 550* float decimal (59) */ 551 call 552 conv_to_float_dec_59 (arg_list.arg_des_ptr (2), 553 arg_list.arg_des_ptr (5), fld_val_2); /* Convert second arg 554* to float decimal (59) */ 555 (size, conversion): 556 rslt_fld_59 = mod (fld_val_1, fld_val_2); /* Do the mod function */ 557 558 return; /* End of mod entry */ 559 560 561 562 mod_info: 563 entry (ad_ptr, rslt_desc); 564 565 /* Info entry for the "mod" builtin 566* rslt_desc = 0 or float_decimal (59) */ 567 568 if arg_descs.ndescs ^= 2 then 569 rslt_desc = "0"b; /* Must have only two args */ 570 571 else if mu_data_class$convertible_data_class (addr (arg_descs.desc (1))) 572 & mu_data_class$convertible_data_class (addr (arg_descs.desc (2))) 573 /* If both args can be converted */ 574 then rslt_desc = FLD59_DESC; 575 576 else rslt_desc = "0"b; 577 578 return; /* End of mod_info entry */ 579 580 reverse: 581 entry; 582 583 /* This entry implements the MRDS/LINUS "reverse" builtin function. This is 584* a string function, so arithmetic arguments are not accepted. 585* The PL/I "reverse" builtin is used to actualy perform 586* the function. Returned result is a bit or char varying string. */ 587 588 589 /* BEGIN CHANGE 81-08-14 RDL ********************************************** */ 590 591 a1_ptr = addr (buffer1); 592 593 /* END CHANGE 81-08-14 RDL ********************************************** */ 594 595 call cu_$arg_list_ptr (al_ptr); /* get pointer to arg list */ 596 num_ptrs = arg_list.arg_count; /* CHANGE 81-09-21 */ 597 r_ptr = addrel (arg_list.arg_des_ptr (2), -1); /* point to place to store result */ 598 599 r_len = fixed (string (arg_list.arg_des_ptr (3) -> descriptor.size), 24); 600 /* Max length of return string 601* can be no larger then input string */ 602 603 if mu_data_class$bit_data_class (arg_list.arg_des_ptr (3)) then do; 604 /* String type is bit */ 605 call canon_bit (1, a1_ptr, a1_len); 606 rslt_bit_string = reverse (b1); /* do bit string reverse */ 607 end; 608 else do; /* canonize to char. var. */ 609 call canon_char (1, a1_ptr, a1_len); 610 rslt_char_string = reverse (c1); /* Do char string reverse */ 611 end; 612 613 614 return; /* End of reverse */ 615 616 617 618 619 reverse_info: 620 entry (ad_ptr, rslt_desc); 621 622 /* Info entry for the "reverse" builtin */ 623 624 if arg_descs.ndescs ^= 1 then 625 rslt_desc = "0"b; /* Can only accept one arg */ 626 627 else if ^mu_data_class$string_data_class (addr (arg_descs.desc (1))) then 628 rslt_desc = "0"b; /* Got to be a 629* string of some kind */ 630 631 else do; /* If everything OK then build the rslt desc */ 632 633 rslt_desc = "0"b; /* Start with it all zeros */ 634 635 if addr (arg_descs.desc (1)) -> descriptor.type < 21 then 636 rslt_desc = BIT_VAR_DESC; /* Bit varying */ 637 else rslt_desc = CHAR_VAR_DESC; /* Char varying */ 638 639 addr (rslt_desc) -> descriptor.size = 640 addr (arg_descs.desc (1)) -> descriptor.size; /* size = input size */ 641 642 end; 643 644 return; /* End of reverse_info entry */ 645 646 round: 647 entry; 648 649 /* This entry implements the MRDS/LINUS "round" builtin function. 650* This is an arithmetic function so only arithmentic arguments are accepted. 651* The input value is canonized to a float decimal (59) before rounding and the returned 652* value is a float decimal (59). */ 653 654 on size call fatal_func_error; 655 on conversion call fatal_func_error; 656 657 call cu_$arg_list_ptr (al_ptr); 658 num_ptrs = arg_list.arg_count; /* CHANGE 81-09-21 */ 659 r_ptr = arg_list.arg_des_ptr (3); /* Place to store result */ 660 661 call 662 conv_to_float_dec_59 (arg_list.arg_des_ptr (2), 663 arg_list.arg_des_ptr (5), q); 664 665 if mu_data_class$complex_data_class (arg_list.arg_des_ptr (4)) then do; 666 /* If input is complex */ 667 call 668 conv_to_complex_float_dec_59 (arg_list.arg_des_ptr (1), 669 arg_list.arg_des_ptr (4), cmplx_fld_59_val); 670 call 671 rnd (real (cmplx_fld_59_val), q, arg_list.arg_des_ptr (4), 672 fld_val_1); /* Round the real part */ 673 call 674 rnd (imag (cmplx_fld_59_val), q, arg_list.arg_des_ptr (4), 675 fld_val_2); /* Round the imaginary part */ 676 rslt_cfld_59.real = fld_val_1; /* Stuff the real and imag parts in returned result */ 677 rslt_cfld_59.imag = fld_val_2; 678 end; 679 else do; /* If input was not complex */ 680 call 681 conv_to_float_dec_59 (arg_list.arg_des_ptr (1), 682 arg_list.arg_des_ptr (4), fld_val_1); 683 call rnd (fld_val_1, q, arg_list.arg_des_ptr (4), rslt_fld_59); 684 end; 685 686 687 return; /* End of round entry */ 688 689 690 round_info: 691 entry (ad_ptr, rslt_desc); 692 693 /* Info entry for the "round" builtin 694* rslt_desc = 0 or FLD59_DESC */ 695 696 697 if arg_descs.ndescs ^= 2 then 698 rslt_desc = "0"b; /* Must have only two args */ 699 700 else if mu_data_class$complex_data_class (addr (arg_descs.desc (1))) 701 & mu_data_class$convertible_data_class (addr (arg_descs.desc (2))) 702 then rslt_desc = CFLD59_DESC; 703 else if mu_data_class$convertible_data_class (addr (arg_descs.desc (1))) 704 & mu_data_class$convertible_data_class (addr (arg_descs.desc (2))) 705 /* If both args can be converted */ 706 then rslt_desc = FLD59_DESC; 707 708 else rslt_desc = "0"b; 709 710 return; /* End of round_info entry */ 711 712 (size, conversion): 713 rnd: 714 proc (in_val, q, type, r_val); 715 716 /* This procedure accepts a float decimal (59) input value and rounds it 717* returning the result in r_val. The type indicates if the original input was fixed or float. */ 718 719 dcl in_val float decimal (59);/* (INPUT) */ 720 dcl q float decimal (59);/* (INPUT) */ 721 dcl type ptr; /* (INPUT) Descriptor pointer */ 722 dcl r_val float decimal (59);/* (OUTPUT) */ 723 724 if abs (in_val) > 0.000001 then do; 725 if mu_data_class$fixed_data_class (type) then 726 n = q; /* If input type is fixed */ 727 else do; /* Floating number */ 728 if sign (q) = -1. then 729 call fatal_func_error; 730 n = q - (floor (log10 (abs (in_val)) + 1)); 731 end; 732 733 r_val = sign (in_val) * floor (abs (in_val) * 10.0 ** n + 0.5); 734 r_val = divide (r_val, (10.0 ** n), 59); 735 end; 736 else r_val = 0; 737 738 return; 739 740 end rnd; 741 742 search: 743 entry; 744 745 /* This entry implements the MRDS/LINUS "search" builtin function. This is 746* a string function, so arithmetic arguments are not accepted. If there is a 747* mixture of character and bit arguments, an attempt is made to convert the bit 748* argument to a character string. The PL/I "search" builtin is used to actualy perform 749* the function. The returned result will be a fixed bin (24). */ 750 751 752 /* BEGIN CHANGE 81-08-14 RDL ********************************************** */ 753 754 a1_ptr = addr (buffer1); 755 a2_ptr = addr (buffer2); 756 757 /* END CHANGE 81-08-14 RDL ********************************************** */ 758 759 call cu_$arg_list_ptr (al_ptr); /* get pointer to arg list */ 760 num_ptrs = arg_list.arg_count; /* CHANGE 81-09-21 */ 761 r_ptr = arg_list.arg_des_ptr (3); /* point to place to store result */ 762 763 call canon_char (1, a1_ptr, a1_len); 764 call canon_char (2, a2_ptr, a2_len); 765 rslt_bin = search (c1, c2); /* Do char string search */ 766 767 return; /* End of search */ 768 769 770 771 search_info: 772 entry (ad_ptr, rslt_desc); 773 774 /* Info entry for the "search" builtin */ 775 /* rslt_desc = 0 or FIXED_BIN_24 */ 776 777 if arg_descs.ndescs ^= 2 then 778 rslt_desc = "0"b; /* need exactly 2 args */ 779 else /* check for string args */ 780 if ^mu_data_class$character_data_class (addr (arg_descs.desc (1))) | 781 /* If arg types are not char */ 782 ^mu_data_class$character_data_class (addr (arg_descs.desc (2))) 783 then rslt_desc = "0"b; 784 else rslt_desc = FIB24_DESC; /* have 2 string args */ 785 786 return; /* end of search info entry */ 787 788 substr: 789 entry; 790 791 /* This entry implements the MRDS/LINUS "substr" builtin function. This function 792* accepts either the two argument form "substr (string, starting_pos)" or the three 793* argument form "substr (string, starting_pos, len)" of sub-string. 794* If the input string is a bit string the returned value is a varying bit string. 795* If the input string is a character string the returned value is a 796* varying character string. Returned result is either bit varying or char varying string. 797* The PL/I "substr" builtin is used to actually perform the function. */ 798 799 800 /* BEGIN CHANGE 81-08-14 RDL ********************************************** */ 801 802 a1_ptr = addr (buffer1); 803 804 /* END CHANGE 81-08-14 RDL ********************************************** */ 805 806 call cu_$arg_list_ptr (al_ptr); /* Get pointer to argument list */ 807 num_ptrs = arg_list.arg_count; /* CHANGE 81-09-21 */ 808 nargs = arg_list.arg_count / 2; /* Number of arguments passed */ 809 /* If nargs = 3 form is substr (string, starting_pos) 810* If nargs = 4 form is substr (string, starting_pos, len) */ 811 r_ptr = addrel (arg_list.arg_des_ptr (nargs), -1);/* Set return value pointer to last argument */ 812 r_len = 813 fixed (string (arg_list.arg_des_ptr (nargs + 1) -> descriptor.size), 814 24); /* Max length of return string 815* can be no longer then length of input string (arg (1)) */ 816 817 if mu_data_class$bit_data_class (arg_list.arg_des_ptr (nargs + 1)) then 818 /* String type is bit */ 819 call canon_bit (1, a1_ptr, a1_len); /* Canonize to bit. var. */ 820 else /* String type is character */ 821 call canon_char (1, a1_ptr, a1_len); /* Canonize to char. var. */ 822 823 call 824 conv_to_fixed_bin_24 (arg_list.arg_des_ptr (2), 825 arg_list.arg_des_ptr (nargs + 2), starting_pos); /* Convert 826* starting position to fixed bin (24,0) */ 827 828 /* BEGIN CHANGE 81-09-23 ****************************** */ 829 830 if nargs = 4 then do; 831 call conv_to_fixed_bin_24 /* Convert len to fixed bin (24, 0) */ 832 (arg_list.arg_des_ptr (3), 833 arg_list.arg_des_ptr (nargs + 3), len); 834 if len > a1_len - starting_pos + 1 /* if too many characters are */ 835 then len = a1_len - starting_pos + 1; /* requested cut it down */ 836 end; 837 838 /* END CHANGE 81-09-23 ****************************** */ 839 840 else len = a1_len - starting_pos + 1; 841 if starting_pos > a1_len | starting_pos < 1 | len < 1 then do; 842 if mu_data_class$bit_data_class (arg_list.arg_des_ptr (nargs + 1)) then 843 rslt_bit_string = ""b; 844 else rslt_char_string = ""; 845 end; 846 else do; 847 if mu_data_class$bit_data_class (arg_list.arg_des_ptr (nargs + 1)) then 848 rslt_bit_string = substr (b1, starting_pos, len); 849 /* Do the SUBSTR */ 850 else rslt_char_string = substr (c1, starting_pos, len); 851 /* Do the SUBSTR */ 852 end; 853 854 return; /* End of substr */ 855 856 substr_info: 857 entry (ad_ptr, rslt_desc); 858 859 /* Info entry for the "substr" builtin */ 860 /* rslt_desc = 0 or BIT_VAR_DESC or CHAR_VAR_DESC */ 861 862 rslt_desc = arg_descs.desc (1); /* Initialize it to a non-zero value */ 863 864 if arg_descs.ndescs < 2 | arg_descs.ndescs > 3 then 865 rslt_desc = "0"b; /* Wrong number of argsuments */ 866 867 else 868 do j = 2 to (arg_descs.ndescs); /* Are the lengths valid for converstion? */ 869 /* descritors will be character unless argument */ 870 /* is result of another expression */ 871 if ^mu_data_class$real_data_class (addr (arg_descs.desc (j))) 872 & ^mu_data_class$string_data_class (addr (arg_descs.desc (j))) then 873 rslt_desc = "0"b; 874 end; 875 876 if ^(mu_data_class$string_data_class (addr (arg_descs.desc (1)))) 877 /* First arg must be a string */ 878 then rslt_desc = "0"b; 879 880 if rslt_desc ^= "0"b then do; /* If everything was ok then set the rslt desc */ 881 882 if addr (arg_descs.desc (1)) -> descriptor.type < 21 then 883 rslt_desc = BIT_VAR_DESC; /* Bit varying */ 884 else rslt_desc = CHAR_VAR_DESC; /* Char varying */ 885 886 addr (rslt_desc) -> descriptor.size = 887 addr (arg_descs.desc (1)) -> descriptor.size; /* Result cannot 888* be any larger then input string length */ 889 end; 890 891 return; /* end of substr info entry */ 892 893 verify: 894 entry; 895 896 /* This entry implements the MRDS/LINUS "verify" builtin function. This is 897* a string function, so arithmetic arguments are not accepted. 898* The PL/I "verify" builtin is used to actualy perform the function. 899* Returned result is a fixed bin (24). */ 900 901 902 /* BEGIN CHANGE 81-08-14 RDL ********************************************** */ 903 904 a1_ptr = addr (buffer1); 905 a2_ptr = addr (buffer2); 906 907 /* END CHANGE 81-08-14 RDL ********************************************** */ 908 909 call cu_$arg_list_ptr (al_ptr); /* get pointer to arg list */ 910 num_ptrs = arg_list.arg_count; /* CHANGE 81-09-21 */ 911 r_ptr = arg_list.arg_des_ptr (3); /* point to place to store result */ 912 913 call canon_char (1, a1_ptr, a1_len); 914 call canon_char (2, a2_ptr, a2_len); 915 rslt_bin = verify (c1, c2); /* Do char string verify */ 916 917 918 return; /* End of verify */ 919 920 921 922 verify_info: 923 entry (ad_ptr, rslt_desc); 924 925 /* Info entry for the "verify" builtin */ 926 /* rslt_desc = 0 or fixed bin (24) */ 927 928 if arg_descs.ndescs ^= 2 then 929 rslt_desc = "0"b; /* need exactly 2 args */ 930 else /* check for string args */ 931 if ^mu_data_class$character_data_class (addr (arg_descs.desc (1))) | 932 /* If arg types are not char */ 933 ^mu_data_class$character_data_class (addr (arg_descs.desc (2))) 934 then rslt_desc = "0"b; 935 936 else rslt_desc = FIB24_DESC; /* have 2 string args */ 937 938 return; /* end of verify info entry */ 939 940 fatal_func_error: 941 proc; 942 943 signal fatal_func_err; 944 945 end fatal_func_error; 946 947 canon_bit: 948 proc (arg_index, b_ptr, b_len); 949 950 /* Procedure to canonize bit args into bit varying */ 951 952 dcl arg_index fixed bin; 953 dcl b_len fixed bin (35); 954 dcl ( 955 b_ptr, 956 a_ptr init (null), 957 d_ptr init (null) 958 ) ptr; 959 dcl bnv bit (b_len) based (a_ptr); 960 dcl bv bit (b_len) var based (b_ptr); 961 dcl fb35 fixed bin (35) based; 962 963 a_ptr = arg_list.arg_des_ptr (arg_index); /* pick up arg and desc ptrs */ 964 d_ptr = arg_list.arg_des_ptr (arg_index + arg_list.arg_count / 2); 965 966 if d_ptr -> descriptor.type = BIT_VAR then do; /* no conv., merely set ptrs */ 967 b_ptr = addrel (a_ptr, -1); /* Include length field */ 968 b_len = b_ptr -> fb35; 969 end; 970 else do; /* must convert to var. */ 971 b_len = fixed (string (d_ptr -> descriptor.size)); 972 bv = bnv; /* convert */ 973 end; 974 975 end canon_bit; 976 977 canon_char: 978 proc (arg_index, c_ptr, c_len); 979 980 /* procedure to canonize character or bit string arguments into char. varying */ 981 982 dcl arg_index fixed bin; 983 dcl c_len fixed bin (35); 984 dcl ( 985 c_ptr, 986 a_ptr init (null), 987 d_ptr init (null) 988 ) ptr; 989 dcl bnv bit (c_len) based (a_ptr); 990 dcl bv bit (c_len) var based (bv_ptr); 991 dcl bv_ptr ptr init (null); 992 dcl cnv char (c_len) based (a_ptr); 993 dcl cv char (c_len) var based (c_ptr); 994 dcl fb35 fixed bin (35) based; 995 996 a_ptr = arg_list.arg_des_ptr (arg_index); /* pick up arg and desc ptrs */ 997 d_ptr = arg_list.arg_des_ptr (arg_index + arg_list.arg_count / 2); 998 999 if d_ptr -> descriptor.type = CHAR_VAR then do; /* already char var, merely set pointers */ 1000 c_ptr = addrel (a_ptr, -1); /* Include length field */ 1001 c_len = c_ptr -> fb35; 1002 end; 1003 else do; /* must convert */ 1004 c_len = fixed (string (d_ptr -> descriptor.size)); 1005 if d_ptr -> descriptor.type = CHAR then 1006 cv = cnv; 1007 else if d_ptr -> descriptor.type = BIT then 1008 cv = char (bnv); 1009 else do; 1010 bv_ptr = addrel (a_ptr, -1); 1011 cv = char (bv); 1012 end; 1013 end; 1014 1015 end canon_char; 1016 1017 (size, conversion): 1018 conv_to_fixed_bin_24: 1019 proc (s_ptr, s_desc_ptr, val); 1020 1021 /* This procedure converts a non-complex value to 1022* a fixed binary (24,0) value returned as val. The input parameters are a pointer to 1023* the source value (s_ptr), a pointer to the source descriptor (s_desc_ptr), and the 1024* returned value (val). 1025**/ 1026 1027 /* PARAMETERS */ 1028 1029 dcl s_ptr ptr; /* Pointer to the source item */ 1030 dcl s_desc_ptr ptr; /* Pointer to the source item descriptor */ 1031 dcl val fixed bin (24, 0); /* Returned value */ 1032 1033 /* OTHERS */ 1034 1035 dcl assign_ 1036 entry (ptr, fixed bin, fixed bin (35), ptr, fixed bin, fixed bin (35)); 1037 dcl s_type fixed bin; /* Source item type for assign_ */ 1038 dcl s_len fixed bin (35); /* Source item length for assign_ */ 1039 dcl t_ptr ptr init (null); /* Pointer to target item for assign_ */ 1040 dcl t_type fixed bin; /* Target item type for assign_ */ 1041 dcl t_len fixed bin (35); /* Target item lenth for assigh_ */ 1042 1043 Start: 1044 t_ptr = addr (val); 1045 t_len = 24; /* Scale = 0 precision = 24 */ 1046 t_type = 2; /* 2*M + P where M = 1 and P = 0 */ 1047 1048 s_type = 1049 (2 * s_desc_ptr -> descriptor.type) 1050 + fixed (s_desc_ptr -> descriptor.packed); 1051 s_len = 1052 fixed (s_desc_ptr -> descriptor.size.scale || "000000"b 1053 || s_desc_ptr -> descriptor.size.precision); 1054 1055 call assign_ (t_ptr, t_type, t_len, s_ptr, s_type, s_len); 1056 1057 return; 1058 1059 end conv_to_fixed_bin_24; 1060 1061 (size, conversion): 1062 conv_to_float_dec_59: 1063 proc (s_ptr, s_desc_ptr, val); 1064 1065 /* This procedure canonizes non-complex arithmetic values to float decimal (59). 1066* The input parameters are a pointer to the source value (s_ptr), a pointer to the source descriptor (s_desc_ptr), 1067* and the returned value (val). */ 1068 1069 /* PARAMETERS */ 1070 1071 dcl s_ptr ptr; /* Pointer to the source item */ 1072 dcl s_desc_ptr ptr; /* Pointer to the source item descriptor */ 1073 dcl val float decimal (59);/* Returned value */ 1074 1075 /* OTHERS */ 1076 1077 dcl assign_ 1078 entry (ptr, fixed bin, fixed bin (35), ptr, fixed bin, fixed bin (35)); 1079 dcl s_type fixed bin; /* Source item type for assign_ */ 1080 dcl s_len fixed bin (35); /* Source item length for assign_ */ 1081 dcl t_ptr ptr init (null); /* Pointer to target item for assign_ */ 1082 dcl t_type fixed bin; /* Target item type for assign_ */ 1083 dcl t_len fixed bin (35); /* Target item lenth for assigh_ */ 1084 1085 Start: 1086 t_ptr = addr (val); 1087 t_len = 59; 1088 t_type = 20; /* 2*M + P where M = 10 and P = 0 */ 1089 1090 s_type = 1091 (2 * s_desc_ptr -> descriptor.type) 1092 + fixed (s_desc_ptr -> descriptor.packed); 1093 s_len = 1094 fixed (s_desc_ptr -> descriptor.size.scale || "000000"b 1095 || s_desc_ptr -> descriptor.size.precision); 1096 1097 call assign_ (t_ptr, t_type, t_len, s_ptr, s_type, s_len); 1098 1099 return; 1100 1101 end conv_to_float_dec_59; 1102 1103 (size, conversion): 1104 conv_to_complex_float_dec_59: 1105 proc (s_ptr, s_desc_ptr, val); 1106 1107 /* This procedure canonizes complex arithmetic values to complex float decimal (59). 1108* The input parameters are a pointer to the source value (s_ptr), a pointer to the source descriptor (s_desc_ptr), 1109* and the returned value (val). */ 1110 1111 /* PARAMETERS */ 1112 1113 dcl s_ptr ptr; /* Pointer to the source item */ 1114 dcl s_desc_ptr ptr; /* Pointer to the source item descriptor */ 1115 dcl val complex float decimal (59); /* Returned value */ 1116 1117 /* OTHERS */ 1118 1119 dcl assign_ 1120 entry (ptr, fixed bin, fixed bin (35), ptr, fixed bin, fixed bin (35)); 1121 dcl s_type fixed bin; /* Source item type for assign_ */ 1122 dcl s_len fixed bin (35); /* Source item length for assign_ */ 1123 dcl t_ptr ptr init (null); /* Pointer to target item for assign_ */ 1124 dcl t_type fixed bin; /* Target item type for assign_ */ 1125 dcl t_len fixed bin (35); /* Target item lenth for assigh_ */ 1126 1127 Start: 1128 t_ptr = addr (val); 1129 t_len = 59; 1130 t_type = 24; /* 2*M + P where M = 12 and P = 0 */ 1131 1132 s_type = 1133 (2 * s_desc_ptr -> descriptor.type) 1134 + fixed (s_desc_ptr -> descriptor.packed); 1135 s_len = 1136 fixed (s_desc_ptr -> descriptor.size.scale || "000000"b 1137 || s_desc_ptr -> descriptor.size.precision); 1138 1139 call assign_ (t_ptr, t_type, t_len, s_ptr, s_type, s_len); 1140 1141 return; 1142 1143 end conv_to_complex_float_dec_59; 1144 1 1 /* BEGIN mdbm_arg_list.incl.pl1 -- jaw 5/31/78 */ 1 2 /* the duplicate mrds_arg_list.incl.pl1 was eliminated by Jim Gray, Nov. 1979 */ 1 3 1 4 /* layout of argument list for IDS and DBM entries with options (variable) */ 1 5 1 6 dcl 1 arg_list based (al_ptr), 1 7 2 arg_count fixed bin (17) unal, /* 2 * no. of args. */ 1 8 2 code fixed bin (17) unal, /* 4 => normal, 8 => special */ 1 9 2 desc_count fixed bin (17) unal, /* 2 * no. of descriptors */ 1 10 2 pad fixed bin (17) unal, /* must be 0 */ 1 11 2 arg_des_ptr (num_ptrs) ptr; /* argument/descriptor pointer */ 1 12 1 13 dcl al_ptr ptr; 1 14 dcl num_ptrs fixed bin; 1 15 1 16 /* END mdbm_arg_list.incl.pl1 */ 1 17 1145 1146 2 1 /* BEGIN mdbm_descriptor.incl.pl1 -- jaw 5/31/78 */ 2 2 /* modified by Jim Gray - - Nov. 1979, to change type from fixed bin(5) to 2 3* unsigned fixed bin(6), so new packed decimal data types could be handled. 2 4* also the duplicate mrds_descriptor.incl.pl1 was eliminated. */ 2 5 2 6 dcl 1 descriptor based (desc_ptr), /* map of Multics descriptor */ 2 7 2 version bit (1) unal, /* DBM handles vers. 1 only */ 2 8 2 type unsigned fixed bin (6) unal, /* data type */ 2 9 2 packed bit (1) unal, /* on if data item is packed */ 2 10 2 number_dims bit (4) unal, /* dimensions */ 2 11 2 size, /* size for string data */ 2 12 3 scale bit (12) unal, /* scale for num. data */ 2 13 3 precision bit (12) unal, /* prec. for num. data */ 2 14 2 array_info (num_dims), 2 15 3 lower_bound fixed bin (35), /* lower bound of dimension */ 2 16 3 upper_bound fixed bin (35), /* upper bound of dimension */ 2 17 3 multiplier fixed bin (35); /* element separation */ 2 18 2 19 dcl desc_ptr ptr; 2 20 dcl num_dims fixed bin init (0) ; /* more useful form of number_dims */ 2 21 2 22 /* END mdbm_descriptor.incl.pl1 */ 2 23 2 24 1147 1148 1149 dcl ( 1150 a1_ptr init (null), /* arg pointers */ 1151 a2_ptr init (null), 1152 r_ptr init (null), /* pointer to function result */ 1153 ad_ptr /* Input: points to structure containing input descrips. */ 1154 ) ptr; /* pointer to work area */ 1155 1156 dcl ( 1157 a1_len, /* string lengths for args */ 1158 a2_len 1159 ) fixed bin (35); 1160 1161 dcl ( 1162 starting_pos, /* Starting position for substr */ 1163 r_len, /* Length of bit or char resultant string */ 1164 s1, 1165 s2, 1166 n, 1167 len 1168 ) fixed bin (24); /* Length or extent of substr */ 1169 1170 dcl c1 char (a1_len) var based (a1_ptr); /* canonized char args */ 1171 dcl c2 char (a2_len) var based (a2_ptr); 1172 dcl b1 bit (a1_len) var based (a1_ptr); /* canonized bit args */ 1173 dcl b2 bit (a2_len) var based (a2_ptr); 1174 dcl (fld_val_1, fld_val_2, q) float decimal (59); 1175 dcl rslt_desc bit (36) aligned; /* Output: result descriptor */ 1176 dcl rslt_bin fixed bin (24) based (r_ptr); /* fixed bin results */ 1177 dcl rslt_bit_string bit (r_len) varying based (r_ptr); /* Bit string result */ 1178 dcl rslt_char_string char (r_len) varying based (r_ptr); /* Char string result */ 1179 dcl rslt_fld_59 float decimal (59) based (r_ptr); 1180 dcl 1 rslt_cfld_59 based (r_ptr), 1181 2 real float decimal (59) aligned, 1182 2 imag float decimal (59) aligned; 1183 1184 dcl alloc_array (mrds_data_$max_builtin_args) ptr 1185 init ((mrds_data_$max_builtin_args) null); /* place to store pointers to allocated items */ 1186 dcl (nargs, j) fixed bin; 1187 1188 1189 dcl 1 arg_descs aligned based (ad_ptr), /* input descriptors for info entries */ 1190 2 ndescs fixed bin, 1191 2 desc (0 refer (arg_descs.ndescs)) bit (36); 1192 1193 1194 1195 dcl FIB24_DESC bit (36) aligned int static options (constant) 1196 init ("100000100000000000000000000000011000"b); /* Fixed bin (24) descriptor */ 1197 dcl CHAR_VAR_DESC bit (36) aligned int static options (constant) 1198 init ("101011000000000000000000000000000000"b); /* Character varying descriptor */ 1199 dcl BIT_VAR_DESC bit (36) aligned int static options (constant) 1200 init ("101010000000000000000000000000000000"b); /* Bit varying descriptor */ 1201 dcl FLD59_DESC bit (36) aligned int static options (constant) 1202 init ("100101000000000000000000000000111011"b); /* Float decimal (59) descriptor */ 1203 dcl CFLD59_DESC bit (36) aligned int static options (constant) 1204 init ("100110010000000000000000000000111011"b); /* Complex Float decimal (59) descriptor */ 1205 1206 dcl cmplx_fld_59_val complex float decimal (59); 1207 1208 dcl ( 1209 CHAR init (21), 1210 BIT init (19), 1211 CHAR_VAR init (22), 1212 BIT_VAR init (20) 1213 ) fixed bin (5) int static options (constant); 1214 1215 dcl ( 1216 mrds_data_$max_builtin_args, 1217 mrds_data_$max_string_size 1218 ) fixed bin (35) ext; 1219 1220 dcl (conversion, size, fatal_func_err) condition; 1221 1222 1223 dcl (abs, addr, addrel, after, before, bit, ceil, char, divide, fixed, floor, 1224 imag, index, log10, mod, null, real, reverse, search, sign, string, substr, 1225 verify) builtin; 1226 1227 dcl cu_$arg_list_ptr entry (ptr); 1228 1229 1230 dcl ( 1231 mu_data_class$real_data_class, 1232 mu_data_class$complex_data_class, 1233 mu_data_class$fixed_data_class, 1234 mu_data_class$string_data_class, 1235 mu_data_class$convertible_data_class, 1236 mu_data_class$bit_data_class, 1237 mu_data_class$character_data_class 1238 ) entry (ptr) returns (bit (1) aligned); /* determines if descriptor pointed to 1239* describes a data item in the class 1240* that the entry point refers to */ 1241 1242 1243 1244 dcl area_ptr ptr init (null ()); 1245 dcl (buffer1, buffer2) char (2 * mrds_data_$max_string_size + 4); 1246 1247 1248 1249 end mrds_builtin_; SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 04/18/85 0906.3 mrds_builtin_.pl1 >special_ldd>online>mrds.pbf-04/18/85>mrds_builtin_.pl1 1145 1 10/14/83 1609.0 mdbm_arg_list.incl.pl1 >ldd>include>mdbm_arg_list.incl.pl1 1147 2 10/14/83 1608.6 mdbm_descriptor.incl.pl1 >ldd>include>mdbm_descriptor.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. BIT constant fixed bin(5,0) initial dcl 1208 ref 1007 BIT_VAR constant fixed bin(5,0) initial dcl 1208 ref 966 BIT_VAR_DESC constant bit(36) initial dcl 1199 ref 216 296 414 635 882 CFLD59_DESC 000000 constant bit(36) initial dcl 1203 ref 700 CHAR constant fixed bin(5,0) initial dcl 1208 ref 1005 CHAR_VAR constant fixed bin(5,0) initial dcl 1208 ref 999 CHAR_VAR_DESC constant bit(36) initial dcl 1197 ref 218 221 298 301 416 419 637 884 FIB24_DESC 000002 constant bit(36) initial dcl 1195 ref 527 784 936 FLD59_DESC 000006 constant bit(36) initial dcl 1201 ref 145 347 471 571 703 a1_len 000116 automatic fixed bin(35,0) dcl 1156 set ref 180* 185* 260* 265* 380* 385* 498* 503* 605* 609* 763* 817* 820* 834 834 840 841 913* a1_ptr 000110 automatic pointer initial dcl 1149 set ref 164* 180* 182 185* 187 244* 260* 262 265* 267 365* 380* 382 385* 387 492* 498* 500 503* 505 591* 605* 606 609* 610 754* 763* 765 802* 817* 820* 847 850 904* 913* 915 1149* a2_len 000117 automatic fixed bin(35,0) dcl 1156 set ref 181* 186* 261* 266* 381* 386* 499* 504* 764* 914* a2_ptr 000112 automatic pointer initial dcl 1149 set ref 165* 181* 182 186* 187 245* 261* 262 266* 267 366* 381* 382 386* 387 493* 499* 500 504* 505 755* 764* 765 905* 914* 915 1149* a_ptr 000334 automatic pointer initial dcl 984 in procedure "canon_char" set ref 984* 996* 1000 1005 1007 1010 a_ptr 000322 automatic pointer initial dcl 954 in procedure "canon_bit" set ref 954* 963* 967 972 abs builtin function dcl 1223 ref 129 724 730 733 ad_ptr parameter pointer dcl 1149 ref 136 142 145 145 194 200 202 205 205 205 205 214 214 216 224 273 279 281 284 284 284 284 293 293 296 304 338 344 347 347 394 400 403 403 403 403 412 412 414 423 424 462 468 471 471 515 521 523 523 523 523 562 568 571 571 571 571 619 624 627 627 635 639 690 697 700 700 700 700 703 703 703 703 771 777 779 779 779 779 856 862 864 864 867 871 871 871 871 876 876 882 886 922 928 930 930 930 930 addr builtin function dcl 1223 ref 145 145 164 165 205 205 205 205 214 214 216 224 224 244 245 284 284 284 284 293 293 296 304 304 347 347 365 366 403 403 403 403 412 412 414 423 424 426 471 471 492 493 523 523 523 523 571 571 571 571 591 627 627 635 639 639 700 700 700 700 703 703 703 703 754 755 779 779 779 779 802 871 871 871 871 876 876 882 886 886 904 905 930 930 930 930 1043 1085 1127 addrel builtin function dcl 1223 ref 171 251 372 597 811 967 1000 1010 after builtin function dcl 1223 ref 182 187 al_ptr 000100 automatic pointer dcl 1-13 set ref 121* 122 123 125 125 169* 170 171 173 177 177 249* 250 251 253 257 257 323* 324 325 327 327 370* 371 372 374 377 377 447* 448 449 451 451 488* 489 490 495 495 543* 544 545 547 547 551 551 595* 596 597 599 603 657* 658 659 661 661 665 667 667 670 673 680 680 683 759* 760 761 806* 807 808 811 812 817 823 823 831 831 842 847 909* 910 911 963 964 964 996 997 997 alloc_array 000206 automatic pointer initial array dcl 1184 set ref 1184* area_ptr 000264 automatic pointer initial dcl 1244 set ref 1244* arg_count based fixed bin(17,0) level 2 packed unaligned dcl 1-6 ref 122 170 250 324 371 448 489 544 596 658 760 807 808 910 964 997 arg_des_ptr 2 based pointer array level 2 dcl 1-6 set ref 123 125* 125* 171 173 177* 177* 251 253 257* 257* 325 327* 327* 372 374 377* 377* 449 451* 451* 490 495* 495* 545 547* 547* 551* 551* 597 599 603* 659 661* 661* 665* 667* 667* 670* 673* 680* 680* 683* 761 811 812 817* 823* 823* 831* 831* 842* 847* 911 963 964 996 997 arg_descs based structure level 1 dcl 1189 arg_index parameter fixed bin(17,0) dcl 952 in procedure "canon_bit" ref 947 963 964 arg_index parameter fixed bin(17,0) dcl 982 in procedure "canon_char" ref 977 996 997 arg_list based structure level 1 unaligned dcl 1-6 assign_ 000036 constant entry external dcl 1035 in procedure "conv_to_fixed_bin_24" ref 1055 assign_ 000042 constant entry external dcl 1119 in procedure "conv_to_complex_float_dec_59" ref 1139 assign_ 000040 constant entry external dcl 1077 in procedure "conv_to_float_dec_59" ref 1097 b1 based varying bit dcl 1172 ref 182 262 382 500 606 847 b2 based varying bit dcl 1173 ref 182 262 382 500 b_len parameter fixed bin(35,0) dcl 953 set ref 947 968* 971* 972 972 b_ptr parameter pointer dcl 954 set ref 947 967* 968 972 before builtin function dcl 1223 ref 262 267 bit builtin function dcl 1223 ref 428 bnv based bit unaligned dcl 959 in procedure "canon_bit" ref 972 bnv based bit unaligned dcl 989 in procedure "canon_char" ref 1007 buffer1 000266 automatic char unaligned dcl 1245 set ref 164 244 365 492 591 754 802 904 buffer2 000266 automatic char unaligned dcl 1245 set ref 165 245 366 493 755 905 bv based varying bit dcl 990 in procedure "canon_char" ref 1011 bv based varying bit dcl 960 in procedure "canon_bit" set ref 972* bv_ptr 000340 automatic pointer initial dcl 991 set ref 991* 1010* 1011 c1 based varying char dcl 1170 ref 187 267 387 505 610 765 850 915 c2 based varying char dcl 1171 ref 187 267 387 505 765 915 c_len parameter fixed bin(35,0) dcl 983 set ref 977 1001* 1004* 1005 1005 1007 1007 1011 c_ptr parameter pointer dcl 984 set ref 977 1000* 1001 1005 1007 1011 ceil builtin function dcl 1223 ref 331 char builtin function dcl 1223 ref 1007 1011 cmplx_fld_59_val 000210 automatic complex float dec(59) dcl 1206 set ref 667* 670 670 673 673 cnv based char unaligned dcl 992 ref 1005 conversion 000250 stack reference condition dcl 1220 ref 113 322 445 541 655 cu_$arg_list_ptr 000016 constant entry external dcl 1227 ref 121 169 249 323 370 447 488 543 595 657 759 806 909 cv based varying char dcl 993 set ref 1005* 1007* 1011* d_ptr 000336 automatic pointer initial dcl 984 in procedure "canon_char" set ref 984* 997* 999 1004 1005 1007 d_ptr 000324 automatic pointer initial dcl 954 in procedure "canon_bit" set ref 954* 964* 966 971 desc 1 based bit(36) array level 2 dcl 1189 set ref 145 145 200 205 205 205 205 214 214 216 224 279 284 284 284 284 293 293 296 304 347 347 403 403 403 403 412 412 414 423 424 471 471 523 523 523 523 571 571 571 571 627 627 635 639 700 700 700 700 703 703 703 703 779 779 779 779 862 871 871 871 871 876 876 882 886 930 930 930 930 desc_ptr 000104 automatic pointer dcl 2-19 set ref 426* 428 descriptor based structure level 1 unaligned dcl 2-6 divide builtin function dcl 1223 ref 734 fatal_func_err 000000 stack reference condition dcl 1220 ref 943 fb35 based fixed bin(35,0) dcl 961 in procedure "canon_bit" ref 968 fb35 based fixed bin(35,0) dcl 994 in procedure "canon_char" ref 1001 fixed builtin function dcl 1223 ref 173 253 374 423 424 599 812 971 1004 1048 1051 1090 1093 1132 1135 fld_val_1 000126 automatic float dec(59) dcl 1174 set ref 125* 129 327* 331 451* 455 547* 555 670* 676 680* 683* fld_val_2 000146 automatic float dec(59) dcl 1174 set ref 551* 555 673* 677 floor builtin function dcl 1223 ref 455 730 733 imag builtin function dcl 1223 in procedure "mrds_builtin_" ref 673 673 imag 20 based float dec(59) level 2 in structure "rslt_cfld_59" dcl 1180 in procedure "mrds_builtin_" set ref 677* in_val parameter float dec(59) dcl 719 ref 712 724 730 733 733 index builtin function dcl 1223 ref 500 505 j 000207 automatic fixed bin(17,0) dcl 1186 set ref 867* 871 871 871 871* len 000125 automatic fixed bin(24,0) dcl 1161 set ref 831* 834 834* 840* 841 847 850 log10 builtin function dcl 1223 ref 730 mod builtin function dcl 1223 ref 555 mrds_data_$max_builtin_args 000012 external static fixed bin(35,0) dcl 1215 ref 1184 1184 mrds_data_$max_string_size 000014 external static fixed bin(35,0) dcl 1215 ref 1245 1245 mu_data_class$bit_data_class 000032 constant entry external dcl 1230 ref 177 177 257 257 377 377 495 495 603 817 842 847 mu_data_class$character_data_class 000034 constant entry external dcl 1230 ref 779 779 930 930 mu_data_class$complex_data_class 000022 constant entry external dcl 1230 ref 665 700 mu_data_class$convertible_data_class 000030 constant entry external dcl 1230 ref 145 347 471 571 571 700 703 703 mu_data_class$fixed_data_class 000024 constant entry external dcl 1230 ref 725 mu_data_class$real_data_class 000020 constant entry external dcl 1230 ref 871 mu_data_class$string_data_class 000026 constant entry external dcl 1230 ref 205 205 284 284 403 403 523 523 627 871 876 n 000124 automatic fixed bin(24,0) dcl 1161 set ref 427* 428 725* 730* 733 734 nargs 000206 automatic fixed bin(17,0) dcl 1186 set ref 808* 811 812 817 823 830 831 842 847 ndescs based fixed bin(17,0) level 2 dcl 1189 ref 142 202 281 344 400 468 521 568 624 697 777 864 864 867 928 null builtin function dcl 1223 ref 954 954 984 984 991 1039 1081 1123 1149 1149 1149 1184 1244 num_dims 000106 automatic fixed bin(17,0) initial dcl 2-20 set ref 2-20* num_ptrs 000102 automatic fixed bin(17,0) dcl 1-14 set ref 117* 122* 170* 250* 324* 371* 448* 489* 544* 596* 658* 760* 807* 910* packed 0(07) based bit(1) level 2 packed unaligned dcl 2-6 ref 1048 1090 1132 precision 0(24) based bit(12) level 3 packed unaligned dcl 2-6 set ref 1051 1093 1135 q 000166 automatic float dec(59) dcl 1174 in procedure "mrds_builtin_" set ref 661* 670* 673* 683* q parameter float dec(59) dcl 720 in procedure "rnd" ref 712 725 728 730 r_len 000121 automatic fixed bin(24,0) dcl 1161 set ref 173* 182 187 253* 262 267 374* 382 387 599* 606 610 812* 842 844 847 850 r_ptr 000114 automatic pointer initial dcl 1149 set ref 123* 129 171* 182 187 251* 262 267 325* 331 372* 382 387 449* 455 490* 500 505 545* 555 597* 606 610 659* 676 677 683 761* 765 811* 842 844 847 850 911* 915 1149* r_val parameter float dec(59) dcl 722 set ref 712 733* 734* 734 736* real based float dec(59) level 2 in structure "rslt_cfld_59" dcl 1180 in procedure "mrds_builtin_" set ref 676* real builtin function dcl 1223 in procedure "mrds_builtin_" ref 670 670 reverse builtin function dcl 1223 ref 606 610 rslt_bin based fixed bin(24,0) dcl 1176 set ref 500* 505* 765* 915* rslt_bit_string based varying bit dcl 1177 set ref 182* 262* 382* 606* 842* 847* rslt_cfld_59 based structure level 1 unaligned dcl 1180 rslt_char_string based varying char dcl 1178 set ref 187* 267* 387* 610* 844* 850* rslt_desc parameter bit(36) dcl 1175 set ref 136 142* 145* 148* 194 200* 202* 205* 210 212* 216* 218* 221* 224 273 279* 281* 284* 289 291* 296* 298* 301* 304 338 344* 347* 350* 394 400* 403* 410* 414* 416* 419* 426 462 468* 471* 474* 515 521* 523* 527* 562 568* 571* 576* 619 624* 627* 633* 635* 637* 639 690 697* 700* 703* 708* 771 777* 779* 784* 856 862* 864* 871* 876* 880 882* 884* 886 922 928* 930* 936* rslt_fld_59 based float dec(59) dcl 1179 set ref 129* 331* 455* 555* 683* s1 000122 automatic fixed bin(24,0) dcl 1161 set ref 423* 427 s2 000123 automatic fixed bin(24,0) dcl 1161 set ref 424* 427 s_desc_ptr parameter pointer dcl 1114 in procedure "conv_to_complex_float_dec_59" ref 1103 1132 1132 1135 1135 s_desc_ptr parameter pointer dcl 1072 in procedure "conv_to_float_dec_59" ref 1061 1090 1090 1093 1093 s_desc_ptr parameter pointer dcl 1030 in procedure "conv_to_fixed_bin_24" ref 1017 1048 1048 1051 1051 s_len 000351 automatic fixed bin(35,0) dcl 1038 in procedure "conv_to_fixed_bin_24" set ref 1051* 1055* s_len 000401 automatic fixed bin(35,0) dcl 1122 in procedure "conv_to_complex_float_dec_59" set ref 1135* 1139* s_len 000365 automatic fixed bin(35,0) dcl 1080 in procedure "conv_to_float_dec_59" set ref 1093* 1097* s_ptr parameter pointer dcl 1113 in procedure "conv_to_complex_float_dec_59" set ref 1103 1139* s_ptr parameter pointer dcl 1029 in procedure "conv_to_fixed_bin_24" set ref 1017 1055* s_ptr parameter pointer dcl 1071 in procedure "conv_to_float_dec_59" set ref 1061 1097* s_type 000364 automatic fixed bin(17,0) dcl 1079 in procedure "conv_to_float_dec_59" set ref 1090* 1097* s_type 000350 automatic fixed bin(17,0) dcl 1037 in procedure "conv_to_fixed_bin_24" set ref 1048* 1055* s_type 000400 automatic fixed bin(17,0) dcl 1121 in procedure "conv_to_complex_float_dec_59" set ref 1132* 1139* scale 0(12) based bit(12) level 3 packed unaligned dcl 2-6 set ref 1051 1093 1135 search builtin function dcl 1223 ref 765 sign builtin function dcl 1223 ref 728 733 size 000256 stack reference condition dcl 1220 in procedure "mrds_builtin_" ref 112 321 444 540 654 size 0(12) based structure level 2 in structure "descriptor" packed unaligned dcl 2-6 in procedure "mrds_builtin_" set ref 173 224* 224 253 304* 304 374 423 424 428* 599 639* 639 812 886* 886 971 1004 starting_pos 000120 automatic fixed bin(24,0) dcl 1161 set ref 823* 834 834 840 841 841 847 850 string builtin function dcl 1223 set ref 173 253 374 423 424 428* 599 812 971 1004 substr builtin function dcl 1223 ref 847 850 t_len 000371 automatic fixed bin(35,0) dcl 1083 in procedure "conv_to_float_dec_59" set ref 1087* 1097* t_len 000355 automatic fixed bin(35,0) dcl 1041 in procedure "conv_to_fixed_bin_24" set ref 1045* 1055* t_len 000405 automatic fixed bin(35,0) dcl 1125 in procedure "conv_to_complex_float_dec_59" set ref 1129* 1139* t_ptr 000366 automatic pointer initial dcl 1081 in procedure "conv_to_float_dec_59" set ref 1081* 1085* 1097* t_ptr 000352 automatic pointer initial dcl 1039 in procedure "conv_to_fixed_bin_24" set ref 1039* 1043* 1055* t_ptr 000402 automatic pointer initial dcl 1123 in procedure "conv_to_complex_float_dec_59" set ref 1123* 1127* 1139* t_type 000370 automatic fixed bin(17,0) dcl 1082 in procedure "conv_to_float_dec_59" set ref 1088* 1097* t_type 000354 automatic fixed bin(17,0) dcl 1040 in procedure "conv_to_fixed_bin_24" set ref 1046* 1055* t_type 000404 automatic fixed bin(17,0) dcl 1124 in procedure "conv_to_complex_float_dec_59" set ref 1130* 1139* type 0(01) based fixed bin(6,0) level 2 in structure "descriptor" packed unsigned unaligned dcl 2-6 in procedure "mrds_builtin_" ref 214 214 216 293 293 296 412 412 414 635 882 966 999 1005 1007 1048 1090 1132 type parameter pointer dcl 721 in procedure "rnd" set ref 712 725* val parameter float dec(59) dcl 1073 in procedure "conv_to_float_dec_59" set ref 1061 1085 val parameter fixed bin(24,0) dcl 1031 in procedure "conv_to_fixed_bin_24" set ref 1017 1043 val parameter complex float dec(59) dcl 1115 in procedure "conv_to_complex_float_dec_59" set ref 1103 1127 verify builtin function dcl 1223 ref 915 NAMES DECLARED BY EXPLICIT CONTEXT. Start 005145 constant label dcl 1127 in procedure "conv_to_complex_float_dec_59" Start 004743 constant label dcl 1043 in procedure "conv_to_fixed_bin_24" Start 005044 constant label dcl 1085 in procedure "conv_to_float_dec_59" abs 000124 constant entry external dcl 102 abs_info 000246 constant entry external dcl 136 after 000312 constant entry external dcl 152 after_info 000473 constant entry external dcl 194 before 000623 constant entry external dcl 232 before_info 000774 constant entry external dcl 273 canon_bit 004505 constant entry internal dcl 947 ref 180 181 260 261 380 381 498 499 605 817 canon_char 004565 constant entry internal dcl 977 ref 185 186 265 266 385 386 503 504 609 763 764 820 913 914 ceil 001124 constant entry external dcl 312 ceil_info 001240 constant entry external dcl 338 concat 001304 constant entry external dcl 354 concat_info 001477 constant entry external dcl 394 conv_to_complex_float_dec_59 005141 constant entry internal dcl 1103 ref 667 conv_to_fixed_bin_24 004737 constant entry internal dcl 1017 ref 823 831 conv_to_float_dec_59 005040 constant entry internal dcl 1061 ref 125 327 451 547 551 661 680 fatal_func_error 004474 constant entry internal dcl 940 ref 112 113 321 322 444 445 540 541 654 655 728 floor 001632 constant entry external dcl 435 floor_info 001746 constant entry external dcl 462 index 002012 constant entry external dcl 478 index_info 002142 constant entry external dcl 515 mod 002231 constant entry external dcl 531 mod_info 002357 constant entry external dcl 562 mrds_builtin_ 000114 constant entry external dcl 18 reverse 002446 constant entry external dcl 580 reverse_info 002565 constant entry external dcl 619 rnd 004205 constant entry internal dcl 712 ref 670 673 683 round 002654 constant entry external dcl 646 round_info 003111 constant entry external dcl 690 search 003247 constant entry external dcl 742 search_info 003321 constant entry external dcl 771 substr 003412 constant entry external dcl 788 substr_info 003667 constant entry external dcl 856 verify 004043 constant entry external dcl 893 verify_info 004115 constant entry external dcl 922 THERE WERE NO NAMES DECLARED BY CONTEXT OR IMPLICATION. STORAGE REQUIREMENTS FOR THIS PROGRAM. Object Text Link Symbol Defs Static Start 0 0 6040 6104 5320 6050 Length 6454 5320 44 334 517 0 BLOCK NAME STACK SIZE TYPE WHY NONQUICK/WHO SHARES STACK FRAME mrds_builtin_ 636 external procedure is an external procedure. on unit on line 112 64 on unit on unit on line 113 64 on unit on unit on line 321 64 on unit on unit on line 322 64 on unit on unit on line 444 64 on unit on unit on line 445 64 on unit on unit on line 540 64 on unit on unit on line 541 64 on unit on unit on line 654 64 on unit on unit on line 655 64 on unit rnd internal procedure shares stack frame of external procedure mrds_builtin_. fatal_func_error 70 internal procedure is called by several nonquick procedures. canon_bit internal procedure shares stack frame of external procedure mrds_builtin_. canon_char internal procedure shares stack frame of external procedure mrds_builtin_. conv_to_fixed_bin_24 internal procedure shares stack frame of external procedure mrds_builtin_. conv_to_float_dec_59 internal procedure shares stack frame of external procedure mrds_builtin_. conv_to_complex_float_dec_59 internal procedure shares stack frame of external procedure mrds_builtin_. STORAGE FOR AUTOMATIC VARIABLES. STACK FRAME LOC IDENTIFIER BLOCK NAME mrds_builtin_ 000100 al_ptr mrds_builtin_ 000102 num_ptrs mrds_builtin_ 000104 desc_ptr mrds_builtin_ 000106 num_dims mrds_builtin_ 000110 a1_ptr mrds_builtin_ 000112 a2_ptr mrds_builtin_ 000114 r_ptr mrds_builtin_ 000116 a1_len mrds_builtin_ 000117 a2_len mrds_builtin_ 000120 starting_pos mrds_builtin_ 000121 r_len mrds_builtin_ 000122 s1 mrds_builtin_ 000123 s2 mrds_builtin_ 000124 n mrds_builtin_ 000125 len mrds_builtin_ 000126 fld_val_1 mrds_builtin_ 000146 fld_val_2 mrds_builtin_ 000166 q mrds_builtin_ 000206 alloc_array mrds_builtin_ 000206 nargs mrds_builtin_ 000207 j mrds_builtin_ 000210 cmplx_fld_59_val mrds_builtin_ 000264 area_ptr mrds_builtin_ 000266 buffer1 mrds_builtin_ 000266 buffer2 mrds_builtin_ 000322 a_ptr canon_bit 000324 d_ptr canon_bit 000334 a_ptr canon_char 000336 d_ptr canon_char 000340 bv_ptr canon_char 000350 s_type conv_to_fixed_bin_24 000351 s_len conv_to_fixed_bin_24 000352 t_ptr conv_to_fixed_bin_24 000354 t_type conv_to_fixed_bin_24 000355 t_len conv_to_fixed_bin_24 000364 s_type conv_to_float_dec_59 000365 s_len conv_to_float_dec_59 000366 t_ptr conv_to_float_dec_59 000370 t_type conv_to_float_dec_59 000371 t_len conv_to_float_dec_59 000400 s_type conv_to_complex_float_dec_59 000401 s_len conv_to_complex_float_dec_59 000402 t_ptr conv_to_complex_float_dec_59 000404 t_type conv_to_complex_float_dec_59 000405 t_len conv_to_complex_float_dec_59 THE FOLLOWING EXTERNAL OPERATORS ARE USED BY THIS PROGRAM. fx1_to_fl2 alloc_cs alloc_bs call_ext_out call_int_this call_int_other return alloc_auto_adj signal enable shorten_stack ext_entry int_entry trunc_fx2 reverse_cs reverse_bs size_check_fx1 size_check_fx2 set_cs_eis set_bs_eis index_cs_eis index_bs_eis verify_eis search_eis real_to_real_rd real_to_real_tr any_to_any_tr divide_fx1 dlog10 ceil_dec floor_dec sign_dec mod_dec index_before_cs index_before_bs index_after_cs index_after_bs THE FOLLOWING EXTERNAL ENTRIES ARE CALLED BY THIS PROGRAM. assign_ assign_ assign_ cu_$arg_list_ptr decimal_exp_ mu_data_class$bit_data_class mu_data_class$character_data_class mu_data_class$complex_data_class mu_data_class$convertible_data_class mu_data_class$fixed_data_class mu_data_class$real_data_class mu_data_class$string_data_class THE FOLLOWING EXTERNAL VARIABLES ARE USED BY THIS PROGRAM. mrds_data_$max_builtin_args mrds_data_$max_string_size LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC 2 20 000032 1149 000033 1184 000037 1244 000066 1245 000070 18 000113 100 000122 102 000123 112 000132 113 000154 117 000176 121 000177 122 000206 123 000211 125 000214 129 000227 132 000241 136 000242 142 000254 145 000263 148 000306 150 000310 152 000311 164 000320 165 000322 169 000324 170 000333 171 000336 173 000342 177 000345 180 000377 181 000403 182 000407 183 000433 185 000434 186 000440 187 000444 192 000470 194 000471 200 000501 202 000506 205 000513 210 000557 212 000562 214 000563 216 000576 218 000604 219 000606 221 000607 224 000611 230 000621 232 000622 244 000631 245 000633 249 000635 250 000644 251 000647 253 000653 257 000656 260 000710 261 000714 262 000720 263 000740 265 000741 266 000745 267 000751 271 000771 273 000772 279 001002 281 001007 284 001014 289 001060 291 001063 293 001064 296 001077 298 001105 299 001107 301 001110 304 001112 310 001122 312 001123 321 001132 322 001154 323 001176 324 001205 325 001210 327 001213 331 001226 334 001235 338 001236 344 001246 347 001255 350 001300 352 001302 354 001303 365 001312 366 001314 370 001316 371 001325 372 001330 374 001334 377 001337 380 001371 381 001375 382 001401 383 001431 385 001433 386 001437 387 001443 388 001473 391 001474 394 001475 400 001505 403 001514 410 001561 412 001563 414 001576 416 001604 417 001606 419 001607 423 001611 424 001614 426 001617 427 001621 428 001623 432 001630 435 001631 444 001640 445 001662 447 001704 448 001713 449 001716 451 001721 455 001734 458 001743 462 001744 468 001754 471 001763 474 002006 476 002010 478 002011 488 002020 489 002027 490 002032 492 002035 493 002037 495 002041 498 002074 499 002100 500 002104 501 002115 503 002116 504 002122 505 002126 509 002137 515 002140 521 002150 523 002157 527 002224 529 002227 531 002230 540 002237 541 002261 543 002303 544 002312 545 002315 547 002320 551 002333 555 002346 558 002354 562 002355 568 002365 571 002374 576 002442 578 002444 580 002445 591 002454 595 002456 596 002465 597 002470 599 002474 603 002477 605 002513 606 002517 607 002535 609 002537 610 002543 611 002561 614 002562 619 002563 624 002573 627 002602 633 002624 635 002626 637 002640 639 002642 644 002652 646 002653 654 002662 655 002704 657 002726 658 002735 659 002740 661 002743 665 002756 667 002773 670 003006 673 003026 676 003046 677 003052 678 003055 680 003056 683 003071 687 003106 690 003107 697 003117 700 003126 703 003174 708 003243 710 003245 742 003246 754 003255 755 003257 759 003261 760 003270 761 003273 763 003276 764 003302 765 003306 767 003316 771 003317 777 003327 779 003336 784 003405 786 003410 788 003411 802 003420 806 003422 807 003431 808 003434 811 003442 812 003447 817 003455 820 003476 823 003502 830 003517 831 003522 834 003536 836 003553 840 003554 841 003563 842 003573 844 003614 845 003615 847 003616 850 003651 854 003664 856 003665 862 003675 864 003702 867 003711 871 003717 874 003765 876 003767 880 004012 882 004015 884 004027 886 004031 891 004041 893 004042 904 004051 905 004053 909 004055 910 004064 911 004067 913 004072 914 004076 915 004102 918 004112 922 004113 928 004123 930 004132 936 004201 938 004204 712 004205 724 004207 725 004222 728 004250 730 004262 733 004343 734 004433 735 004465 736 004466 738 004472 940 004473 943 004501 945 004504 947 004505 954 004507 963 004512 964 004517 966 004536 967 004543 968 004547 969 004551 971 004552 972 004556 975 004564 977 004565 984 004567 991 004572 996 004573 997 004600 999 004617 1000 004625 1001 004631 1002 004633 1004 004634 1005 004640 1007 004653 1009 004702 1010 004703 1011 004706 1012 004735 1015 004736 1017 004737 1039 004741 1043 004743 1045 004745 1046 004751 1048 004755 1051 004774 1055 005015 1057 005037 1061 005040 1081 005042 1085 005044 1087 005046 1088 005052 1090 005056 1093 005075 1097 005116 1099 005140 1103 005141 1123 005143 1127 005145 1129 005147 1130 005153 1132 005157 1135 005176 1139 005217 1141 005241 ----------------------------------------------------------- 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