COMPILATION LISTING OF SEGMENT mu_compare_values Compiled by: Multics PL/I Compiler, Release 28e, of February 14, 1985 Compiled at: Honeywell Multics Op. - System M Compiled on: 04/18/85 1039.0 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 mu_compare_values: compare_data_values: proc (value1_ptr, desc1_ptr, value2_ptr, desc2_ptr, operator, result, code); 19 20 /* DESCRIPTION */ 21 22 /* 23* This routine accepts two pointers to some data values and two pointers to the 24* Multics descriptors describing those values, it compares them with respect 25* to the input relational operator. Eithr a result ("1"b or "0"b) or an error code 26* is returned. Character strings may be compared only against other character 27* strings either or both of which may be varying. The same for bit strings. Complex 28* numeric data types may be compared only against other complex data types, also 29* only the operators equal and not_equal may be used, any other operator will 30* cause an error. Real numeric data types may be compared only against other real 31* numeric data types. Any other combination of data types will generate an error. 32* Numeric comparisons are performed by converting the operands into complex/real 33* float decimal (59). 34* 35* All errors are reported to the user via sub_err_ as well as in the returned 36* error code. 37* 38* The internal procedure error performs a non-local goto to compare_values_exit 39* to exit this routine. 40* 41* 42* 43* 44* HISTORY: 45* 46* 16-aug_79 NSDavids Original coding 47* 48* Modified by Jim Gray - - Dec. 1979, to add packed decimal data 49* type capability 50* 51* Modified March 25, 1980 by R. Lackey to remove calls to 52* mdbm_util_ 53* 54* Modified November 24, 1980 by M. Pierret to align result for 55* efficiency 56* 57* 81-05-19 Jim Gray : changed the "&" to "|" in the complex and 58* real data type cases, so that any complex or real number 59* comparisons can be handled. 60* 61* 81-05-20 Jim Gray : added a case for doing bit-char type compares 62* by converting the bit operand to char, and doing a char-char 63* compare. Also added data type to error message for conversion 64* errors. 65* 66* 81-05-23 Jim Gray : added special case for fixed bin, equal 67* scale, comaprisons, for performance improvment, by avoiding calls 68* to mu_convert for this case. This was originally coded by M. 69* Pierret. I adopted it, and made some corrections to the original 70* code, and put it in the subroutine compare_fb_fb. 71* 72* 81-05-23 B Jim Gray : added special case for float bin 73* comparisons, done in a manner similar to the fixed bin case 74* above. 75* 76* 83-06-13 Ron Harvey : changed addrel (addr (char_temp), 1) to be 77* addrel (char_temp_ptr, 1) instead. This alleviates a compiler bug 78* (phx15402). 79* 80**/ 81 82 /* PARAMETERS */ 83 84 dcl value1_ptr ptr; /* (input) pointer to first operand */ 85 dcl desc1_ptr ptr; /* (input) pointer to descriptor of first operand */ 86 dcl value2_ptr ptr; /* (input) ditto for the second operand */ 87 dcl desc2_ptr ptr; /* (input) ditto ditto */ 88 dcl operator fixed bin; /* (input) the relational operator */ 89 /* 1 = */ 90 /* 2 ^= */ 91 /* 3 < */ 92 /* 4 <= */ 93 /* 5 > */ 94 /* 6 >= */ 95 dcl result bit (1) aligned; /* (output) true if comparison was true */ 96 dcl code fixed bin (35); /* (output) error code */ 97 98 /* BASED */ 99 100 dcl 01 varying_string based, 101 02 size bit (36), /* first word is length */ 102 02 data bit (36); /* rest is data */ 103 104 dcl 01 desc based, /* a multics descriptor */ 105 02 version bit (1) unal, 106 02 type bit (6) unal, 107 02 packed bit (1) unal, 108 02 dims bit (4) unal, 109 02 size, 110 03 scale bit (12) unal, 111 03 precision bit (12) unal; 112 113 dcl desc1_type unsigned fixed bin (6) based (addr (desc1.type)) unal; 114 dcl desc2_type unsigned fixed bin (6) based (addr (desc2.type)) unal; 115 116 declare bit_temp bit (bit_temp_size) based; /* overlay for doing bit-char compares */ 117 118 declare 1 overlay based, /* overlay for count field of varying string */ 119 2 unused bit (12), 120 2 fb24 bit (24); /* only need 24 bits worth */ 121 122 /* CONSTANTS */ 123 124 dcl CHAR bit (6) init ("010101"b) internal static options (constant); 125 dcl CHAR_VAR bit (6) init ("010110"b) internal static options (constant); 126 dcl BIT bit (6) init ("010011"b) internal static options (constant); 127 dcl BIT_VAR bit (6) init ("010100"b) internal static options (constant); 128 dcl CFLD59A_DESC bit (36) init ("100110000000000000000000000000111011"b) internal static options (constant); 129 dcl RFLD59A_DESC bit (36) init ("100101000000000000000000000000111011"b) internal static options (constant); 130 dcl REAL (63) bit (1) internal static options (constant) /* true if tuple is real */ 131 init ((4) ("1"b), (4) ("0"b), (2) ("1"b), (2) ("0"b), (30) ("0"b), (2) ("1"b), (19) ("0"b)); 132 dcl COMPLEX (63) bit (1) internal static options (constant) /* true if type is complex */ 133 init ((4) ("0"b), (4) ("1"b), (2) ("0"b), (2) ("1"b), (32) ("0"b), (2) ("1"b), (17) ("0"b)); 134 declare FIXED_BIN (63) bit (1) int static options (constant) /* true if fixed bin value */ 135 init ((2) ("1"b), (61) ("0"b)); 136 declare FLOAT_BIN (63) bit (1) int static options (constant) /* true if float bin value */ 137 init ((2) ("0"b), (2) ("1"b), (59) ("0"b)); 138 declare mu_display_descriptor entry (ptr) returns (char (120) varying); 139 dcl mrds_error_$inv_comparison fixed bin (35) external static; 140 dcl mrds_error_$inv_operator fixed bin (35) external static; 141 142 /* AUTOMATIC */ 143 144 dcl 01 desc1 like desc; 145 dcl 01 desc2 like desc; 146 dcl operand1_ptr ptr; /* pointer toward what will be used as first operand */ 147 dcl operand2_ptr ptr; /* pointer toward what will be used as second operand */ 148 dcl cfld59a1 complex float decimal (59) aligned; /* place for the first operand if its complex */ 149 dcl cfld59a2 complex float decimal (59) aligned; /* ditto for the second operand */ 150 dcl rfld59a1 real float decimal (59) aligned; /* place for the first operand if its real */ 151 dcl rfld59a2 real float decimal (59) aligned; /* ditto for the second operand */ 152 declare bit_temp_size fixed bin (24); /* bit length of overlay for bit_char compare */ 153 declare char_temp char (4096) varying; /* place for char version of bit string */ 154 declare char_temp_ptr ptr; /* will be address of char_temp */ 155 declare char_temp_size bit (24); /* temp for char-char compare routine parameter */ 156 157 /* MRDS ROUTINES */ 158 159 dcl mu_convert entry (ptr, ptr, ptr, ptr, fixed bin (35)); 160 161 declare (addr, addrel, bin, char, copy, ltrim, null, string, substr, unspec) builtin; 162 163 code = 0; /* make sure we don't return garbage */ 164 result = "0"b; 165 166 167 desc1 = desc1_ptr -> desc; /* get our own copy of the descriptors */ 168 desc2 = desc2_ptr -> desc; 169 170 if desc1.type = CHAR_VAR | desc1.type = BIT_VAR /* make varying strings look like non-varying */ 171 then do; 172 operand1_ptr = addr (value1_ptr -> varying_string.data); /* move operand pointer over one word */ 173 string (desc1.size) = substr (value1_ptr -> varying_string.size, 13); 174 /* modify descriptor to show accutal string length */ 175 desc1_type = desc1_type - 1; /* modify type to non-varying */ 176 end; 177 else operand1_ptr = value1_ptr; 178 179 if desc2.type = CHAR_VAR | desc2.type = BIT_VAR 180 then do; 181 operand2_ptr = addr (value2_ptr -> varying_string.data); 182 string (desc2.size) = substr (value2_ptr -> varying_string.size, 13); 183 desc2_type = desc2_type - 1; 184 end; 185 else operand2_ptr = value2_ptr; 186 187 if operator < 1 | operator > 6 /* make sure we have a legal operator */ 188 then call error (mrds_error_$inv_operator, ltrim (char (operator)) || " is not a valid operator code"); 189 190 191 192 /* Do the comparison */ 193 194 195 if desc1.type = CHAR & desc2.type = CHAR 196 then call compare_char_char (operand1_ptr, string (desc1.size), operand2_ptr, string (desc2.size), 197 operator, result); 198 199 200 else 201 if desc1.type = BIT & desc2.type = BIT 202 then call compare_bit_bit (operand1_ptr, string (desc1.size), operand2_ptr, string (desc2.size), operator, result); 203 204 205 else 206 if COMPLEX (desc1_type) | COMPLEX (desc2_type) /* CHANGE 81-05-19 : allow any complex number comparison */ 207 then do; 208 call mu_convert (operand1_ptr, addr (desc1), addr (cfld59a1), addr (CFLD59A_DESC), code); 209 if code ^= 0 210 then call error (code, "Could not convert a " || mu_display_descriptor (desc1_ptr) || 211 " value to a complex float decimal (59) data type"); 212 call mu_convert (operand2_ptr, addr (desc2), addr (cfld59a2), addr (CFLD59A_DESC), code); 213 if code ^= 0 214 then call error (code, "Could not convert a " || 215 mu_display_descriptor (desc2_ptr) || " value to a complex float decimal (59) data type"); 216 call compare_c59_c59 (cfld59a1, cfld59a2, operator, result); 217 end; 218 219 220 else 221 if REAL (desc1_type) | REAL (desc2_type) /* CHANGE 81-05-19 : allow any real number comparison */ 222 then do; 223 224 /* BEGIN CHANGE 81-05-23 ********************************************** */ 225 226 if FIXED_BIN (desc1_type) & FIXED_BIN (desc2_type) & 227 desc1.scale = desc2.scale then 228 call compare_fb_fb (); 229 else if FLOAT_BIN (desc1_type) & FLOAT_BIN (desc2_type) then 230 call compare_flb_flb (); 231 232 /* END CHANGE 81-05-23 ************************************************ */ 233 234 else do; 235 call mu_convert (operand1_ptr, addr (desc1), addr (rfld59a1), addr (RFLD59A_DESC), code); 236 if code ^= 0 237 then call error (code, "Could not convert a " || mu_display_descriptor (desc1_ptr) || 238 " value to a real float decimal (59) data type"); 239 call mu_convert (operand2_ptr, addr (desc2), addr (rfld59a2), addr (RFLD59A_DESC), code); 240 if code ^= 0 241 then call error (code, "Could not convert a " || 242 mu_display_descriptor (desc2_ptr) || " value to a real float decimal (59) data type"); 243 call compare_r59_r59 (rfld59a1, rfld59a2, operator, result); 244 end; 245 end; 246 247 248 /* BEGIN CHANGE 81-05-20 ******************************************** */ 249 250 else if (desc1.type = BIT & desc2.type = CHAR) | (desc1.type = CHAR & desc2.type = BIT) then do; 251 252 /* do bit-char comparisons as char-char comaprisons, 253* after converting the bit oeprand to character */ 254 255 if desc1.type = BIT then do; 256 bit_temp_size = bin (string (desc1.size)); 257 char_temp = char (operand1_ptr -> bit_temp); 258 char_temp_size = addr (char_temp) -> overlay.fb24; 259 char_temp_ptr = addr (char_temp); 260 call compare_char_char (addrel (char_temp_ptr, 1), char_temp_size, 261 operand2_ptr, string (desc2.size), 262 operator, result); 263 end; 264 else do; 265 bit_temp_size = bin (string (desc2.size)); 266 char_temp = char (operand2_ptr -> bit_temp); 267 char_temp_size = addr (char_temp) -> overlay.fb24; 268 char_temp_ptr = addr (char_temp); 269 call compare_char_char (operand1_ptr, string (desc1.size), 270 addrel (char_temp_ptr, 1), char_temp_size, 271 operator, result); 272 end; 273 end; 274 275 /* END CHANGE 81-05-20 *********************************************** */ 276 277 278 else call error (mrds_error_$inv_comparison, "The data types " || mu_display_descriptor (desc1_ptr) || 279 " and " || mu_display_descriptor (desc2_ptr) || " cannot be compared"); 280 281 282 compare_values_exit: 283 return; 284 285 compare_char_char: proc (c_operand1_ptr, c_operand1_size, c_operand2_ptr, c_operand2_size, c_operator, c_result); 286 287 /* PARAMETERS */ 288 289 dcl c_operand1_ptr ptr; 290 dcl c_operand1_size bit (24); 291 dcl c_operand2_ptr ptr; 292 dcl c_operand2_size bit (24); 293 dcl c_operator fixed bin; 294 dcl c_result bit (1) aligned; 295 296 /* BASED */ 297 298 dcl c_operand1 char (bin (c_operand1_size)) based (c_operand1_ptr); 299 dcl c_operand2 char (bin (c_operand2_size)) based (c_operand2_ptr); 300 301 302 goto c_compare (c_operator); /* value of c_operator was checked when 303* compare_values was entered */ 304 305 306 c_compare (1): /* operator: = */ 307 if c_operand1 = c_operand2 308 then c_result = "1"b; 309 else c_result = "0"b; 310 goto c_exit; 311 312 c_compare (2): /* operator: ^= */ 313 if c_operand1 ^= c_operand2 314 then c_result = "1"b; 315 else c_result = "0"b; 316 goto c_exit; 317 318 c_compare (3): /* operator: < */ 319 if c_operand1 < c_operand2 320 then c_result = "1"b; 321 else c_result = "0"b; 322 goto c_exit; 323 324 c_compare (4): /* operator: <= */ 325 if c_operand1 <= c_operand2 326 then c_result = "1"b; 327 else c_result = "0"b; 328 goto c_exit; 329 330 c_compare (5): /* operator: > */ 331 if c_operand1 > c_operand2 332 then c_result = "1"b; 333 else c_result = "0"b; 334 goto c_exit; 335 336 c_compare (6): /* operator: >= */ 337 if c_operand1 >= c_operand2 338 then c_result = "1"b; 339 else c_result = "0"b; 340 goto c_exit; 341 342 343 c_exit: return; 344 345 end /* compare_char_char */; 346 347 compare_bit_bit: proc (b_operand1_ptr, b_operand1_size, b_operand2_ptr, b_operand2_size, b_operator, b_result); 348 349 /* PARAMETERS */ 350 351 dcl b_operand1_ptr ptr; 352 dcl b_operand1_size bit (24); 353 dcl b_operand2_ptr ptr; 354 dcl b_operand2_size bit (24); 355 dcl b_operator fixed bin; 356 dcl b_result bit (1) aligned; 357 358 /* BASED */ 359 360 dcl b_operand1 bit (bin (b_operand1_size)) based (b_operand1_ptr); 361 dcl b_operand2 bit (bin (b_operand2_size)) based (b_operand2_ptr); 362 363 364 goto b_compare (b_operator); /* value of b_operator was checked when 365* compare_values was entered */ 366 367 368 b_compare (1): /* operator: = */ 369 if b_operand1 = b_operand2 370 then b_result = "1"b; 371 else b_result = "0"b; 372 goto b_exit; 373 374 b_compare (2): /* operator: ^= */ 375 if b_operand1 ^= b_operand2 376 then b_result = "1"b; 377 else b_result = "0"b; 378 goto b_exit; 379 380 b_compare (3): /* operator: < */ 381 if b_operand1 < b_operand2 382 then b_result = "1"b; 383 else b_result = "0"b; 384 goto b_exit; 385 386 b_compare (4): /* operator: <= */ 387 if b_operand1 <= b_operand2 388 then b_result = "1"b; 389 else b_result = "0"b; 390 goto b_exit; 391 392 b_compare (5): /* operator: > */ 393 if b_operand1 > b_operand2 394 then b_result = "1"b; 395 else b_result = "0"b; 396 goto b_exit; 397 398 b_compare (6): /* operator: >= */ 399 if b_operand1 >= b_operand2 400 then b_result = "1"b; 401 else b_result = "0"b; 402 goto b_exit; 403 404 405 b_exit: return; 406 407 end /* compare_bit_bit */; 408 409 compare_c59_c59: proc (cx_operand1, cx_operand2, cx_operator, cx_result); 410 411 /* PARAMETERS */ 412 413 dcl cx_operand1 complex float decimal (59) aligned; 414 dcl cx_operand2 complex float decimal (59) aligned; 415 dcl cx_operator fixed bin; 416 dcl cx_result bit (1) aligned; 417 418 419 420 goto cx_compare (cx_operator); /* value of cx_operator was checked when 421* compare_values was entered */ 422 423 424 cx_compare (1): /* operator: = */ 425 if cx_operand1 = cx_operand2 426 then cx_result = "1"b; 427 else cx_result = "0"b; 428 goto cx_exit; 429 430 cx_compare (2): /* operator: ^= */ 431 if cx_operand1 ^= cx_operand2 432 then cx_result = "1"b; 433 else cx_result = "0"b; 434 goto cx_exit; 435 436 cx_compare (3): /* operator: < */ 437 call error (mrds_error_$inv_operator, "The relational operator < is not allowed for complex data types"); 438 goto cx_exit; 439 440 cx_compare (4): /* operator: <= */ 441 call error (mrds_error_$inv_operator, "The relational operator <= is not allowed for complex data types"); 442 goto cx_exit; 443 444 cx_compare (5): /* operator: > */ 445 call error (mrds_error_$inv_operator, "The relational operator > is not allowed for complex data types"); 446 goto cx_exit; 447 448 cx_compare (6): /* operator: >= */ 449 call error (mrds_error_$inv_operator, "The relational operator >= is not allowed for complex data types"); 450 goto cx_exit; 451 452 453 cx_exit: return; 454 455 end /* compare_c59_c59 */; 456 457 compare_r59_r59: proc (r_operand1, r_operand2, r_operator, r_result); 458 459 /* PARAMETERS */ 460 461 dcl r_operand1 real float decimal (59) aligned; 462 dcl r_operand2 real float decimal (59) aligned; 463 dcl r_operator fixed bin; 464 dcl r_result bit (1) aligned; 465 466 467 468 goto r_compare (r_operator); /* value of r_operator was checked when 469* compare_values was entered */ 470 471 472 r_compare (1): /* operator: = */ 473 if r_operand1 = r_operand2 474 then r_result = "1"b; 475 else r_result = "0"b; 476 goto r_exit; 477 478 r_compare (2): /* operator: ^= */ 479 if r_operand1 ^= r_operand2 480 then r_result = "1"b; 481 else r_result = "0"b; 482 goto r_exit; 483 484 r_compare (3): /* operator: < */ 485 if r_operand1 < r_operand2 486 then r_result = "1"b; 487 else r_result = "0"b; 488 goto r_exit; 489 490 r_compare (4): /* operator: <= */ 491 if r_operand1 <= r_operand2 492 then r_result = "1"b; 493 else r_result = "0"b; 494 goto r_exit; 495 496 r_compare (5): /* operator: > */ 497 if r_operand1 > r_operand2 498 then r_result = "1"b; 499 else r_result = "0"b; 500 goto r_exit; 501 502 r_compare (6): /* operator: >= */ 503 if r_operand1 >= r_operand2 504 then r_result = "1"b; 505 else r_result = "0"b; 506 goto r_exit; 507 508 509 r_exit: return; 510 511 end /* compare_r59_r59 */; 512 513 /* BEGIN CHANGE 81-05-23 **************************************************** */ 514 515 compare_fb_fb: procedure (); 516 517 /* Comparison of special cased fixed binary values, with equal scales */ 518 519 declare fb35a fixed bin (35) aligned based; /* for picking up packed, with prec < 36 */ 520 declare fb71a fixed bin (71) aligned based; /* for picking up packed, with prec < 71, but >= 36 */ 521 declare fixed_bin_operand1 fixed bin (71); /* first value to compare */ 522 declare fixed_bin_operand2 fixed bin (71); /* second value to compare */ 523 declare bit_operand1 bit (bit_operand1_len) based (operand1_ptr); /* gets significant digits */ 524 declare bit_operand2 bit (bit_operand2_len) based (operand2_ptr); /* gets significant digits */ 525 declare bit_operand1_len fixed bin; /* length of significant digit portion */ 526 declare bit_operand2_len fixed bin; /* length of significant digit portion */ 527 528 if desc1.packed 529 then do; 530 bit_operand1_len = bin (desc1.precision) + 1; 531 if substr (bit_operand1, 1, 1) 532 then unspec (fixed_bin_operand1) = copy ("1"b, 71 - bin (desc1.precision)) || bit_operand1; 533 else unspec (fixed_bin_operand1) = copy ("0"b, 71 - bin (desc1.precision)) || bit_operand1; 534 end; 535 else if bin (desc1.precision) < 36 536 then fixed_bin_operand1 = operand1_ptr -> fb35a; 537 else fixed_bin_operand1 = operand1_ptr -> fb71a; 538 539 if desc2.packed 540 then do; 541 bit_operand2_len = bin (desc2.precision) + 1; 542 if substr (bit_operand2, 1, 1) 543 then unspec (fixed_bin_operand2) = copy ("1"b, 71 - bin (desc2.precision)) || bit_operand2; 544 else unspec (fixed_bin_operand2) = copy ("0"b, 71 - bin (desc2.precision)) || bit_operand2; 545 end; 546 else if bin (desc2.precision) < 36 547 then fixed_bin_operand2 = operand2_ptr -> fb35a; 548 else fixed_bin_operand2 = operand2_ptr -> fb71a; 549 550 551 552 goto FB_COMPARE (operator); 553 554 FB_COMPARE (1): /* operator: = */ 555 if fixed_bin_operand1 = fixed_bin_operand2 556 then result = "1"b; 557 else result = "0"b; 558 goto END_FB_COMPARE; 559 560 FB_COMPARE (2): /* operator: ^= */ 561 if fixed_bin_operand1 ^= fixed_bin_operand2 562 then result = "1"b; 563 else result = "0"b; 564 goto END_FB_COMPARE; 565 566 FB_COMPARE (3): /* operator: < */ 567 if fixed_bin_operand1 < fixed_bin_operand2 568 then result = "1"b; 569 else result = "0"b; 570 goto END_FB_COMPARE; 571 572 FB_COMPARE (4): /* operator: <= */ 573 if fixed_bin_operand1 <= fixed_bin_operand2 574 then result = "1"b; 575 else result = "0"b; 576 goto END_FB_COMPARE; 577 578 FB_COMPARE (5): /* operator: > */ 579 if fixed_bin_operand1 > fixed_bin_operand2 580 then result = "1"b; 581 else result = "0"b; 582 goto END_FB_COMPARE; 583 584 FB_COMPARE (6): /* operator: >= */ 585 if fixed_bin_operand1 >= fixed_bin_operand2 586 then result = "1"b; 587 else result = "0"b; 588 goto END_FB_COMPARE; 589 590 END_FB_COMPARE: 591 592 end; 593 594 /* END CHANGE 81-05-23 ************************************************** */ 595 596 /* BEGIN CHANGE 81-05-23 B **************************************************** */ 597 598 compare_flb_flb: procedure (); 599 600 /* Comparison of special cased float binary values, with equal scales */ 601 602 declare flb27a float bin (27) aligned based; /* for picking up packed, with prec <= 27 */ 603 declare flb63a float bin (63) aligned based; /* for picking up packed, with prec < 63, but >= 27 */ 604 declare float_bin_operand1 float bin (63); /* first value to compare */ 605 declare float_bin_operand2 float bin (63); /* second value to compare */ 606 declare 1 bit_operand1 unal based (operand1_ptr), /* gets significant digits */ 607 2 exponent bit (8) unal, 608 2 mantissa bit (bit_operand1_len); 609 declare 1 bit_operand2 unal based (operand2_ptr), /* gets significant digits */ 610 2 exponent bit (8) unal, 611 2 mantissa bit (bit_operand2_len); 612 declare bit_operand1_len float bin; /* length of significant digit portion */ 613 declare bit_operand2_len float bin; /* length of significant digit portion */ 614 615 if desc1.packed 616 then do; 617 bit_operand1_len = bin (desc1.precision) + 1; 618 if substr (bit_operand1.mantissa, 1, 1) 619 then unspec (float_bin_operand1) = string (bit_operand1) || copy ("1"b, 63 - bin (desc1.precision)); 620 else unspec (float_bin_operand1) = string (bit_operand1) || copy ("0"b, 63 - bin (desc1.precision)); 621 end; 622 else if bin (desc1.precision) <= 27 623 then float_bin_operand1 = operand1_ptr -> flb27a; 624 else float_bin_operand1 = operand1_ptr -> flb63a; 625 626 if desc2.packed 627 then do; 628 bit_operand2_len = bin (desc2.precision) + 1; 629 if substr (bit_operand2.mantissa, 1, 1) 630 then unspec (float_bin_operand2) = string (bit_operand2) || copy ("1"b, 63 - bin (desc2.precision)); 631 else unspec (float_bin_operand2) = string (bit_operand2) || copy ("0"b, 63 - bin (desc2.precision)); 632 end; 633 else if bin (desc2.precision) <= 27 634 then float_bin_operand2 = operand2_ptr -> flb27a; 635 else float_bin_operand2 = operand2_ptr -> flb63a; 636 637 638 639 goto FLB_COMPARE (operator); 640 641 FLB_COMPARE (1): /* operator: = */ 642 if float_bin_operand1 = float_bin_operand2 643 then result = "1"b; 644 else result = "0"b; 645 goto END_FLB_COMPARE; 646 647 FLB_COMPARE (2): /* operator: ^= */ 648 if float_bin_operand1 ^= float_bin_operand2 649 then result = "1"b; 650 else result = "0"b; 651 goto END_FLB_COMPARE; 652 653 FLB_COMPARE (3): /* operator: < */ 654 if float_bin_operand1 < float_bin_operand2 655 then result = "1"b; 656 else result = "0"b; 657 goto END_FLB_COMPARE; 658 659 FLB_COMPARE (4): /* operator: <= */ 660 if float_bin_operand1 <= float_bin_operand2 661 then result = "1"b; 662 else result = "0"b; 663 goto END_FLB_COMPARE; 664 665 FLB_COMPARE (5): /* operator: > */ 666 if float_bin_operand1 > float_bin_operand2 667 then result = "1"b; 668 else result = "0"b; 669 goto END_FLB_COMPARE; 670 671 FLB_COMPARE (6): /* operator: >= */ 672 if float_bin_operand1 >= float_bin_operand2 673 then result = "1"b; 674 else result = "0"b; 675 goto END_FLB_COMPARE; 676 677 END_FLB_COMPARE: 678 679 end; 680 681 /* END CHANGE 81-05-23 B ************************************************** */ 682 683 error: proc (error_code, message); 684 685 /* PARAMETERS */ 686 687 dcl error_code fixed bin (35); 688 dcl message char (*); 689 690 691 /* MULTICS ROUTINES */ 692 693 dcl sub_err_ entry options (variable); 694 695 696 /* AUTOMATIC */ 697 698 dcl retval fixed bin (35); /* needed to make sub_err_ happy */ 699 700 701 702 code = error_code; /* code is global */ 703 704 call sub_err_ (error_code, "compare_value", "c", null (), retval, message); 705 706 goto compare_values_exit; /* NON LOCAL GOTO TO EXIT COMPARE_VALUES */ 707 708 end /* error */; 709 710 711 712 713 714 715 end /* mu_compare_values */; SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 04/18/85 0908.0 mu_compare_values.pl1 >special_ldd>online>mrds.pbf-04/18/85>mu_compare_values.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 bit(6) initial unaligned dcl 126 ref 200 200 250 250 255 BIT_VAR constant bit(6) initial unaligned dcl 127 ref 170 179 CFLD59A_DESC 000062 constant bit(36) initial unaligned dcl 128 set ref 208 208 212 212 CHAR constant bit(6) initial unaligned dcl 124 ref 195 195 250 250 CHAR_VAR constant bit(6) initial unaligned dcl 125 ref 170 179 COMPLEX 000050 constant bit(1) initial array unaligned dcl 132 ref 205 205 FIXED_BIN 000046 constant bit(1) initial array unaligned dcl 134 ref 226 226 FLOAT_BIN 000044 constant bit(1) initial array unaligned dcl 136 ref 229 229 REAL 000052 constant bit(1) initial array unaligned dcl 130 ref 220 220 RFLD59A_DESC 000057 constant bit(36) initial unaligned dcl 129 set ref 235 235 239 239 addr builtin function dcl 161 ref 172 175 175 181 183 183 205 205 208 208 208 208 208 208 212 212 212 212 212 212 220 220 226 226 229 229 235 235 235 235 235 235 239 239 239 239 239 239 258 259 267 268 addrel builtin function dcl 161 ref 260 260 269 269 b_operand1 based bit unaligned dcl 360 ref 368 374 380 386 392 398 b_operand1_ptr parameter pointer dcl 351 ref 347 368 374 380 386 392 398 b_operand1_size parameter bit(24) unaligned dcl 352 ref 347 368 374 380 386 392 398 b_operand2 based bit unaligned dcl 361 ref 368 374 380 386 392 398 b_operand2_ptr parameter pointer dcl 353 ref 347 368 374 380 386 392 398 b_operand2_size parameter bit(24) unaligned dcl 354 ref 347 368 374 380 386 392 398 b_operator parameter fixed bin(17,0) dcl 355 ref 347 364 b_result parameter bit(1) dcl 356 set ref 347 368* 371* 374* 377* 380* 383* 386* 389* 392* 395* 398* 401* bin builtin function dcl 161 ref 256 265 306 306 312 312 318 318 324 324 330 330 336 336 368 368 374 374 380 380 386 386 392 392 398 398 530 531 533 535 541 542 544 546 617 618 620 622 628 629 631 633 bit_operand1 based structure level 1 packed unaligned dcl 606 in procedure "compare_flb_flb" ref 618 620 bit_operand1 based bit unaligned dcl 523 in procedure "compare_fb_fb" ref 531 531 533 bit_operand1_len 002314 automatic fixed bin(17,0) dcl 525 in procedure "compare_fb_fb" set ref 530* 531 531 533 bit_operand1_len 002330 automatic float bin(27) dcl 612 in procedure "compare_flb_flb" set ref 617* 618 618 620 bit_operand2 based structure level 1 packed unaligned dcl 609 in procedure "compare_flb_flb" ref 629 631 bit_operand2 based bit unaligned dcl 524 in procedure "compare_fb_fb" ref 542 542 544 bit_operand2_len 002331 automatic float bin(27) dcl 613 in procedure "compare_flb_flb" set ref 628* 629 629 631 bit_operand2_len 002315 automatic fixed bin(17,0) dcl 526 in procedure "compare_fb_fb" set ref 541* 542 542 544 bit_temp based bit unaligned dcl 116 ref 257 266 bit_temp_size 000244 automatic fixed bin(24,0) dcl 152 set ref 256* 257 265* 266 c_operand1 based char unaligned dcl 298 ref 306 312 318 324 330 336 c_operand1_ptr parameter pointer dcl 289 ref 285 306 312 318 324 330 336 c_operand1_size parameter bit(24) unaligned dcl 290 ref 285 306 312 318 324 330 336 c_operand2 based char unaligned dcl 299 ref 306 312 318 324 330 336 c_operand2_ptr parameter pointer dcl 291 ref 285 306 312 318 324 330 336 c_operand2_size parameter bit(24) unaligned dcl 292 ref 285 306 312 318 324 330 336 c_operator parameter fixed bin(17,0) dcl 293 ref 285 302 c_result parameter bit(1) dcl 294 set ref 285 306* 309* 312* 315* 318* 321* 324* 327* 330* 333* 336* 339* cfld59a1 000106 automatic complex float dec(59) dcl 148 set ref 208 208 216* cfld59a2 000145 automatic complex float dec(59) dcl 149 set ref 212 212 216* char builtin function dcl 161 ref 187 257 266 char_temp 000245 automatic varying char(4096) dcl 153 set ref 257* 258 259 266* 267 268 char_temp_ptr 002246 automatic pointer dcl 154 set ref 259* 260 260 268* 269 269 char_temp_size 002250 automatic bit(24) unaligned dcl 155 set ref 258* 260* 267* 269* code parameter fixed bin(35,0) dcl 96 set ref 18 18 163* 208* 209 209* 212* 213 213* 235* 236 236* 239* 240 240* 702* copy builtin function dcl 161 ref 531 533 542 544 618 620 629 631 cx_operand1 parameter complex float dec(59) dcl 413 ref 409 424 430 cx_operand2 parameter complex float dec(59) dcl 414 ref 409 424 430 cx_operator parameter fixed bin(17,0) dcl 415 ref 409 420 cx_result parameter bit(1) dcl 416 set ref 409 424* 427* 430* 433* data 1 based bit(36) level 2 packed unaligned dcl 100 set ref 172 181 desc based structure level 1 packed unaligned dcl 104 ref 167 168 desc1 000100 automatic structure level 1 packed unaligned dcl 144 set ref 167* 208 208 235 235 desc1_ptr parameter pointer dcl 85 set ref 18 18 167 209* 236* 278* desc1_type based fixed bin(6,0) unsigned unaligned dcl 113 set ref 175* 175 205 220 226 229 desc2 000101 automatic structure level 1 packed unaligned dcl 145 set ref 168* 212 212 239 239 desc2_ptr parameter pointer dcl 87 set ref 18 18 168 213* 240* 278* desc2_type based fixed bin(6,0) unsigned unaligned dcl 114 set ref 183* 183 205 220 226 229 error_code parameter fixed bin(35,0) dcl 687 set ref 683 702 704* fb24 0(12) based bit(24) level 2 packed unaligned dcl 118 ref 258 267 fb35a based fixed bin(35,0) dcl 519 ref 535 546 fb71a based fixed bin(71,0) dcl 520 ref 537 548 fixed_bin_operand1 002310 automatic fixed bin(71,0) dcl 521 set ref 531* 533* 535* 537* 554 560 566 572 578 584 fixed_bin_operand2 002312 automatic fixed bin(71,0) dcl 522 set ref 542* 544* 546* 548* 554 560 566 572 578 584 flb27a based float bin(27) dcl 602 ref 622 633 flb63a based float bin(63) dcl 603 ref 624 635 float_bin_operand1 002324 automatic float bin(63) dcl 604 set ref 618* 620* 622* 624* 641 647 653 659 665 671 float_bin_operand2 002326 automatic float bin(63) dcl 605 set ref 629* 631* 633* 635* 641 647 653 659 665 671 ltrim builtin function dcl 161 ref 187 mantissa 0(08) based bit level 2 in structure "bit_operand1" packed unaligned dcl 606 in procedure "compare_flb_flb" ref 618 mantissa 0(08) based bit level 2 in structure "bit_operand2" packed unaligned dcl 609 in procedure "compare_flb_flb" ref 629 message parameter char unaligned dcl 688 set ref 683 704* mrds_error_$inv_comparison 000012 external static fixed bin(35,0) dcl 139 set ref 278* mrds_error_$inv_operator 000014 external static fixed bin(35,0) dcl 140 set ref 187* 436* 440* 444* 448* mu_convert 000016 constant entry external dcl 159 ref 208 212 235 239 mu_display_descriptor 000010 constant entry external dcl 138 ref 209 213 236 240 278 278 null builtin function dcl 161 ref 704 704 operand1_ptr 000102 automatic pointer dcl 146 set ref 172* 177* 195* 200* 208* 235* 257 269* 531 531 533 535 537 618 618 620 622 624 operand2_ptr 000104 automatic pointer dcl 147 set ref 181* 185* 195* 200* 212* 239* 260* 266 542 542 544 546 548 629 629 631 633 635 operator parameter fixed bin(17,0) dcl 88 set ref 18 18 187 187 187 195* 200* 216* 243* 260* 269* 552 639 overlay based structure level 1 packed unaligned dcl 118 packed 0(07) 000101 automatic bit(1) level 2 in structure "desc2" packed unaligned dcl 145 in procedure "compare_data_values" set ref 539 626 packed 0(07) 000100 automatic bit(1) level 2 in structure "desc1" packed unaligned dcl 144 in procedure "compare_data_values" set ref 528 615 precision 0(24) 000100 automatic bit(12) level 3 in structure "desc1" packed unaligned dcl 144 in procedure "compare_data_values" set ref 530 531 533 535 617 618 620 622 precision 0(24) 000101 automatic bit(12) level 3 in structure "desc2" packed unaligned dcl 145 in procedure "compare_data_values" set ref 541 542 544 546 628 629 631 633 r_operand1 parameter float dec(59) dcl 461 ref 457 472 478 484 490 496 502 r_operand2 parameter float dec(59) dcl 462 ref 457 472 478 484 490 496 502 r_operator parameter fixed bin(17,0) dcl 463 ref 457 468 r_result parameter bit(1) dcl 464 set ref 457 472* 475* 478* 481* 484* 487* 490* 493* 496* 499* 502* 505* result parameter bit(1) dcl 95 set ref 18 18 164* 195* 200* 216* 243* 260* 269* 554* 557* 560* 563* 566* 569* 572* 575* 578* 581* 584* 587* 641* 644* 647* 650* 653* 656* 659* 662* 665* 668* 671* 674* retval 000100 automatic fixed bin(35,0) dcl 698 set ref 704* rfld59a1 000204 automatic float dec(59) dcl 150 set ref 235 235 243* rfld59a2 000224 automatic float dec(59) dcl 151 set ref 239 239 243* scale 0(12) 000101 automatic bit(12) level 3 in structure "desc2" packed unaligned dcl 145 in procedure "compare_data_values" set ref 226 scale 0(12) 000100 automatic bit(12) level 3 in structure "desc1" packed unaligned dcl 144 in procedure "compare_data_values" set ref 226 size based bit(36) level 2 in structure "varying_string" packed unaligned dcl 100 in procedure "compare_data_values" ref 173 182 size 0(12) 000101 automatic structure level 2 in structure "desc2" packed unaligned dcl 145 in procedure "compare_data_values" set ref 182* 195 195 200 200 260 260 265 size 0(12) 000100 automatic structure level 2 in structure "desc1" packed unaligned dcl 144 in procedure "compare_data_values" set ref 173* 195 195 200 200 256 269 269 string builtin function dcl 161 set ref 173* 182* 195 195 195 195 200 200 200 200 256 260 260 265 269 269 618 620 629 631 sub_err_ 000020 constant entry external dcl 693 ref 704 substr builtin function dcl 161 ref 173 182 531 542 618 629 type 0(01) 000100 automatic bit(6) level 2 in structure "desc1" packed unaligned dcl 144 in procedure "compare_data_values" set ref 170 170 175 175 195 200 205 220 226 229 250 250 255 type 0(01) 000101 automatic bit(6) level 2 in structure "desc2" packed unaligned dcl 145 in procedure "compare_data_values" set ref 179 179 183 183 195 200 205 220 226 229 250 250 unspec builtin function dcl 161 set ref 531* 533* 542* 544* 618* 620* 629* 631* value1_ptr parameter pointer dcl 84 ref 18 18 172 173 177 value2_ptr parameter pointer dcl 86 ref 18 18 181 182 185 varying_string based structure level 1 packed unaligned dcl 100 NAMES DECLARED BY EXPLICIT CONTEXT. END_FB_COMPARE 003202 constant label dcl 590 ref 558 564 570 576 582 588 END_FLB_COMPARE 003561 constant label dcl 677 ref 645 651 657 663 669 675 FB_COMPARE 000030 constant label array(6) dcl 554 ref 552 FLB_COMPARE 000036 constant label array(6) dcl 641 ref 639 b_compare 000006 constant label array(6) dcl 368 ref 364 b_exit 002417 constant label dcl 405 ref 372 378 384 390 396 402 c_compare 000000 constant label array(6) dcl 306 ref 302 c_exit 002132 constant label dcl 343 ref 310 316 322 328 334 340 compare_bit_bit 002133 constant entry internal dcl 347 ref 200 compare_c59_c59 002420 constant entry internal dcl 409 ref 216 compare_char_char 001646 constant entry internal dcl 285 ref 195 260 269 compare_data_values 000266 constant entry external dcl 18 compare_fb_fb 002676 constant entry internal dcl 515 ref 226 compare_flb_flb 003203 constant entry internal dcl 598 ref 229 compare_r59_r59 002567 constant entry internal dcl 457 ref 243 compare_values_exit 001644 constant label dcl 282 ref 706 cx_compare 000014 constant label array(6) dcl 424 ref 420 cx_exit 002566 constant label dcl 453 ref 428 434 438 442 446 450 error 003563 constant entry internal dcl 683 ref 187 209 213 236 240 278 436 440 444 448 mu_compare_values 000276 constant entry external dcl 18 r_compare 000022 constant label array(6) dcl 472 ref 468 r_exit 002675 constant label dcl 509 ref 476 482 488 494 500 506 THERE WERE NO NAMES DECLARED BY CONTEXT OR IMPLICATION. STORAGE REQUIREMENTS FOR THIS PROGRAM. Object Text Link Symbol Defs Static Start 0 0 3766 4010 3654 3776 Length 4212 3654 22 165 111 0 BLOCK NAME STACK SIZE TYPE WHY NONQUICK/WHO SHARES STACK FRAME compare_data_values 1540 external procedure is an external procedure. compare_char_char internal procedure shares stack frame of external procedure compare_data_values. compare_bit_bit internal procedure shares stack frame of external procedure compare_data_values. compare_c59_c59 internal procedure shares stack frame of external procedure compare_data_values. compare_r59_r59 internal procedure shares stack frame of external procedure compare_data_values. compare_fb_fb internal procedure shares stack frame of external procedure compare_data_values. compare_flb_flb internal procedure shares stack frame of external procedure compare_data_values. error 100 internal procedure is called during a stack extension. STORAGE FOR AUTOMATIC VARIABLES. STACK FRAME LOC IDENTIFIER BLOCK NAME compare_data_values 000100 desc1 compare_data_values 000101 desc2 compare_data_values 000102 operand1_ptr compare_data_values 000104 operand2_ptr compare_data_values 000106 cfld59a1 compare_data_values 000145 cfld59a2 compare_data_values 000204 rfld59a1 compare_data_values 000224 rfld59a2 compare_data_values 000244 bit_temp_size compare_data_values 000245 char_temp compare_data_values 002246 char_temp_ptr compare_data_values 002250 char_temp_size compare_data_values 002310 fixed_bin_operand1 compare_fb_fb 002312 fixed_bin_operand2 compare_fb_fb 002314 bit_operand1_len compare_fb_fb 002315 bit_operand2_len compare_fb_fb 002324 float_bin_operand1 compare_flb_flb 002326 float_bin_operand2 compare_flb_flb 002330 bit_operand1_len compare_flb_flb 002331 bit_operand2_len compare_flb_flb error 000100 retval error THE FOLLOWING EXTERNAL OPERATORS ARE USED BY THIS PROGRAM. fx1_to_fl2 r_e_as alloc_cs alloc_bs cat_realloc_cs cat_realloc_bs call_ext_out_desc call_ext_out call_int_this_desc return fl2_to_fx1 tra_ext shorten_stack ext_entry int_entry_desc any_to_any_tr THE FOLLOWING EXTERNAL ENTRIES ARE CALLED BY THIS PROGRAM. mu_convert mu_display_descriptor sub_err_ THE FOLLOWING EXTERNAL VARIABLES ARE USED BY THIS PROGRAM. mrds_error_$inv_comparison mrds_error_$inv_operator LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC 18 000260 163 000303 164 000305 167 000306 168 000314 170 000321 172 000331 173 000335 175 000340 176 000350 177 000351 179 000354 181 000364 182 000370 183 000373 184 000403 185 000404 187 000407 195 000467 200 000542 205 000605 208 000626 209 000654 212 000732 213 000761 216 001037 217 001055 220 001056 226 001066 229 001111 235 001124 236 001152 239 001230 240 001257 243 001335 245 001353 250 001354 255 001364 256 001367 257 001372 258 001414 259 001420 260 001422 263 001451 265 001452 266 001455 267 001477 268 001503 269 001505 273 001534 278 001535 282 001644 285 001646 302 001650 306 001652 309 001705 310 001706 312 001707 315 001742 316 001743 318 001744 321 001777 322 002000 324 002001 327 002035 328 002036 330 002037 333 002073 334 002074 336 002075 339 002130 340 002131 343 002132 347 002133 364 002135 368 002137 371 002172 372 002173 374 002174 377 002227 378 002230 380 002231 383 002264 384 002265 386 002266 389 002322 390 002323 392 002324 395 002360 396 002361 398 002362 401 002415 402 002416 405 002417 409 002420 420 002422 424 002424 427 002441 428 002442 430 002443 433 002460 434 002461 436 002462 438 002502 440 002503 442 002523 444 002524 446 002544 448 002545 450 002565 453 002566 457 002567 468 002571 472 002573 475 002604 476 002605 478 002606 481 002617 482 002620 484 002621 487 002632 488 002633 490 002634 493 002645 494 002646 496 002647 499 002660 500 002661 502 002662 505 002673 506 002674 509 002675 515 002676 528 002677 530 002702 531 002707 533 002742 534 002770 535 002772 537 003005 539 003007 541 003012 542 003017 544 003052 545 003100 546 003102 548 003115 552 003117 554 003122 557 003130 558 003131 560 003132 563 003140 564 003141 566 003142 569 003150 570 003151 572 003152 575 003160 576 003161 578 003162 581 003170 582 003171 584 003172 587 003200 588 003201 590 003202 598 003203 615 003204 617 003207 618 003216 620 003263 621 003323 622 003325 624 003337 626 003341 628 003344 629 003353 631 003420 632 003460 633 003462 635 003474 639 003476 641 003501 644 003507 645 003510 647 003511 650 003517 651 003520 653 003521 656 003527 657 003530 659 003531 662 003537 663 003540 665 003541 668 003547 669 003550 671 003551 674 003557 675 003560 677 003561 683 003562 702 003576 704 003603 706 003647 ----------------------------------------------------------- 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