1/* target.c -- Implementation File (module.c template V1.0) 2 Copyright (C) 1995, 1996, 1997, 1998, 2002 Free Software Foundation, Inc. 3 Contributed by James Craig Burley. 4 5This file is part of GNU Fortran. 6 7GNU Fortran is free software; you can redistribute it and/or modify 8it under the terms of the GNU General Public License as published by 9the Free Software Foundation; either version 2, or (at your option) 10any later version. 11 12GNU Fortran is distributed in the hope that it will be useful, 13but WITHOUT ANY WARRANTY; without even the implied warranty of 14MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15GNU General Public License for more details. 16 17You should have received a copy of the GNU General Public License 18along with GNU Fortran; see the file COPYING. If not, write to 19the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA 2002111-1307, USA. 21 22 Related Modules: 23 None 24 25 Description: 26 Implements conversion of lexer tokens to machine-dependent numerical 27 form and accordingly issues diagnostic messages when necessary. 28 29 Also, this module, especially its .h file, provides nearly all of the 30 information on the target machine's data type, kind type, and length 31 type capabilities. The idea is that by carefully going through 32 target.h and changing things properly, one can accomplish much 33 towards the porting of the FFE to a new machine. There are limits 34 to how much this can accomplish towards that end, however. For one 35 thing, the ffeexpr_collapse_convert function doesn't contain all the 36 conversion cases necessary, because the text file would be 37 enormous (even though most of the function would be cut during the 38 cpp phase because of the absence of the types), so when adding to 39 the number of supported kind types for a given type, one must look 40 to see if ffeexpr_collapse_convert needs modification in this area, 41 in addition to providing the appropriate macros and functions in 42 ffetarget. Note that if combinatorial explosion actually becomes a 43 problem for a given machine, one might have to modify the way conversion 44 expressions are built so that instead of just one conversion expr, a 45 series of conversion exprs are built to make a path from one type to 46 another that is not a "near neighbor". For now, however, with a handful 47 of each of the numeric types and only one character type, things appear 48 manageable. 49 50 A nonobvious change to ffetarget would be if the target machine was 51 not a 2's-complement machine. Any item with the word "magical" (case- 52 insensitive) in the FFE's source code (at least) indicates an assumption 53 that a 2's-complement machine is the target, and thus that there exists 54 a magnitude that can be represented as a negative number but not as 55 a positive number. It is possible that this situation can be dealt 56 with by changing only ffetarget, for example, on a 1's-complement 57 machine, perhaps #defineing ffetarget_constant_is_magical to simply 58 FALSE along with making the appropriate changes in ffetarget's number 59 parsing functions would be sufficient to effectively "comment out" code 60 in places like ffeexpr that do certain magical checks. But it is 61 possible there are other 2's-complement dependencies lurking in the 62 FFE (as possibly is true of any large program); if you find any, please 63 report them so we can replace them with dependencies on ffetarget 64 instead. 65 66 Modifications: 67*/ 68 69/* Include files. */ 70 71#include "proj.h" 72#include "target.h" 73#include "diagnostic.h" 74#include "bad.h" 75#include "info.h" 76#include "lex.h" 77#include "malloc.h" 78#include "real.h" 79 80/* Externals defined here. */ 81 82char ffetarget_string_[40]; /* Temp for ascii-to-double (atof). */ 83HOST_WIDE_INT ffetarget_long_val_; 84HOST_WIDE_INT ffetarget_long_junk_; 85 86/* Simple definitions and enumerations. */ 87 88 89/* Internal typedefs. */ 90 91 92/* Private include files. */ 93 94 95/* Internal structure definitions. */ 96 97 98/* Static objects accessed by functions in this module. */ 99 100 101/* Static functions (internal). */ 102 103static void ffetarget_print_char_ (FILE *f, unsigned char c); 104 105/* Internal macros. */ 106 107#ifdef REAL_VALUE_ATOF 108#define FFETARGET_ATOF_(p,m) REAL_VALUE_ATOF ((p),(m)) 109#else 110#define FFETARGET_ATOF_(p,m) atof ((p)) 111#endif 112 113 114/* ffetarget_print_char_ -- Print a single character (in apostrophe context) 115 116 See prototype. 117 118 Outputs char so it prints or is escaped C style. */ 119 120static void 121ffetarget_print_char_ (FILE *f, unsigned char c) 122{ 123 switch (c) 124 { 125 case '\\': 126 fputs ("\\\\", f); 127 break; 128 129 case '\'': 130 fputs ("\\\'", f); 131 break; 132 133 default: 134 if (ISPRINT (c)) 135 fputc (c, f); 136 else 137 fprintf (f, "\\%03o", (unsigned int) c); 138 break; 139 } 140} 141 142/* ffetarget_aggregate_info -- Determine type for aggregate storage area 143 144 See prototype. 145 146 If aggregate type is distinct, just return it. Else return a type 147 representing a common denominator for the nondistinct type (for now, 148 just return default character, since that'll work on almost all target 149 machines). 150 151 The rules for abt/akt are (as implemented by ffestorag_update): 152 153 abt == FFEINFO_basictypeANY (akt == FFEINFO_kindtypeANY also, by 154 definition): CHARACTER and non-CHARACTER types mixed. 155 156 abt == FFEINFO_basictypeNONE (akt == FFEINFO_kindtypeNONE also, by 157 definition): More than one non-CHARACTER type mixed, but no CHARACTER 158 types mixed in. 159 160 abt some other value, akt == FFEINFO_kindtypeNONE: abt indicates the 161 only basic type mixed in, but more than one kind type is mixed in. 162 163 abt some other value, akt some other value: abt and akt indicate the 164 only type represented in the aggregation. */ 165 166void 167ffetarget_aggregate_info (ffeinfoBasictype *ebt, ffeinfoKindtype *ekt, 168 ffetargetAlign *units, ffeinfoBasictype abt, 169 ffeinfoKindtype akt) 170{ 171 ffetype type; 172 173 if ((abt == FFEINFO_basictypeNONE) || (abt == FFEINFO_basictypeANY) 174 || (akt == FFEINFO_kindtypeNONE)) 175 { 176 *ebt = FFEINFO_basictypeCHARACTER; 177 *ekt = FFEINFO_kindtypeCHARACTERDEFAULT; 178 } 179 else 180 { 181 *ebt = abt; 182 *ekt = akt; 183 } 184 185 type = ffeinfo_type (*ebt, *ekt); 186 assert (type != NULL); 187 188 *units = ffetype_size (type); 189} 190 191/* ffetarget_align -- Align one storage area to superordinate, update super 192 193 See prototype. 194 195 updated_alignment/updated_modulo contain the already existing 196 alignment requirements for the storage area at whose offset the 197 object with alignment requirements alignment/modulo is to be placed. 198 Find the smallest pad such that the requirements are maintained and 199 return it, but only after updating the updated_alignment/_modulo 200 requirements as necessary to indicate the placement of the new object. */ 201 202ffetargetAlign 203ffetarget_align (ffetargetAlign *updated_alignment, 204 ffetargetAlign *updated_modulo, ffetargetOffset offset, 205 ffetargetAlign alignment, ffetargetAlign modulo) 206{ 207 ffetargetAlign pad; 208 ffetargetAlign min_pad; /* Minimum amount of padding needed. */ 209 ffetargetAlign min_m = 0; /* Minimum-padding m. */ 210 ffetargetAlign ua; /* Updated alignment. */ 211 ffetargetAlign um; /* Updated modulo. */ 212 ffetargetAlign ucnt; /* Multiplier applied to ua. */ 213 ffetargetAlign m; /* Copy of modulo. */ 214 ffetargetAlign cnt; /* Multiplier applied to alignment. */ 215 ffetargetAlign i; 216 ffetargetAlign j; 217 218 assert (alignment > 0); 219 assert (*updated_alignment > 0); 220 221 assert (*updated_modulo < *updated_alignment); 222 assert (modulo < alignment); 223 224 /* The easy case: similar alignment requirements. */ 225 if (*updated_alignment == alignment) 226 { 227 if (modulo > *updated_modulo) 228 pad = alignment - (modulo - *updated_modulo); 229 else 230 pad = *updated_modulo - modulo; 231 if (offset < 0) 232 /* De-negatize offset, since % wouldn't do the expected thing. */ 233 offset = alignment - ((- offset) % alignment); 234 pad = (offset + pad) % alignment; 235 if (pad != 0) 236 pad = alignment - pad; 237 return pad; 238 } 239 240 /* Sigh, find LCM (Least Common Multiple) for the two alignment factors. */ 241 242 for (ua = *updated_alignment, ucnt = 1; 243 ua % alignment != 0; 244 ua += *updated_alignment) 245 ++ucnt; 246 247 cnt = ua / alignment; 248 249 if (offset < 0) 250 /* De-negatize offset, since % wouldn't do the expected thing. */ 251 offset = ua - ((- offset) % ua); 252 253 /* Set to largest value. */ 254 min_pad = ~(ffetargetAlign) 0; 255 256 /* Find all combinations of modulo values the two alignment requirements 257 have; pick the combination that results in the smallest padding 258 requirement. Of course, if a zero-pad requirement is encountered, just 259 use that one. */ 260 261 for (um = *updated_modulo, i = 0; i < ucnt; um += *updated_alignment, ++i) 262 { 263 for (m = modulo, j = 0; j < cnt; m += alignment, ++j) 264 { 265 /* This code is similar to the "easy case" code above. */ 266 if (m > um) 267 pad = ua - (m - um); 268 else 269 pad = um - m; 270 pad = (offset + pad) % ua; 271 if (pad == 0) 272 { 273 /* A zero pad means we've got something useful. */ 274 *updated_alignment = ua; 275 *updated_modulo = um; 276 return 0; 277 } 278 pad = ua - pad; 279 if (pad < min_pad) 280 { /* New minimum padding value. */ 281 min_pad = pad; 282 min_m = um; 283 } 284 } 285 } 286 287 *updated_alignment = ua; 288 *updated_modulo = min_m; 289 return min_pad; 290} 291 292/* Always append a null byte to the end, in case this is wanted in 293 a special case such as passing a string as a FORMAT or %REF. 294 Done to save a bit of hassle, nothing more, but it's a kludge anyway, 295 because it isn't a "feature" that is self-documenting. Use the 296 string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature 297 in the code. */ 298 299#if FFETARGET_okCHARACTER1 300bool 301ffetarget_character1 (ffetargetCharacter1 *val, ffelexToken character, 302 mallocPool pool) 303{ 304 val->length = ffelex_token_length (character); 305 if (val->length == 0) 306 val->text = NULL; 307 else 308 { 309 val->text = malloc_new_kp (pool, "ffetargetCharacter1", val->length + 1); 310 memcpy (val->text, ffelex_token_text (character), val->length); 311 val->text[val->length] = '\0'; 312 } 313 314 return TRUE; 315} 316 317#endif 318/* Produce orderable comparison between two constants 319 320 Compare lengths, if equal then use memcmp. */ 321 322#if FFETARGET_okCHARACTER1 323int 324ffetarget_cmp_character1 (ffetargetCharacter1 l, ffetargetCharacter1 r) 325{ 326 if (l.length < r.length) 327 return -1; 328 if (l.length > r.length) 329 return 1; 330 if (l.length == 0) 331 return 0; 332 return memcmp (l.text, r.text, l.length); 333} 334 335#endif 336/* ffetarget_concatenate_character1 -- Perform CONCAT op on two constants 337 338 Always append a null byte to the end, in case this is wanted in 339 a special case such as passing a string as a FORMAT or %REF. 340 Done to save a bit of hassle, nothing more, but it's a kludge anyway, 341 because it isn't a "feature" that is self-documenting. Use the 342 string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature 343 in the code. */ 344 345#if FFETARGET_okCHARACTER1 346ffebad 347ffetarget_concatenate_character1 (ffetargetCharacter1 *res, 348 ffetargetCharacter1 l, ffetargetCharacter1 r, mallocPool pool, 349 ffetargetCharacterSize *len) 350{ 351 res->length = *len = l.length + r.length; 352 if (*len == 0) 353 res->text = NULL; 354 else 355 { 356 res->text = malloc_new_kp (pool, "ffetargetCharacter1(CONCAT)", *len + 1); 357 if (l.length != 0) 358 memcpy (res->text, l.text, l.length); 359 if (r.length != 0) 360 memcpy (res->text + l.length, r.text, r.length); 361 res->text[*len] = '\0'; 362 } 363 364 return FFEBAD; 365} 366 367#endif 368/* ffetarget_eq_character1 -- Perform relational comparison on char constants 369 370 Compare lengths, if equal then use memcmp. */ 371 372#if FFETARGET_okCHARACTER1 373ffebad 374ffetarget_eq_character1 (bool *res, ffetargetCharacter1 l, 375 ffetargetCharacter1 r) 376{ 377 assert (l.length == r.length); 378 *res = (memcmp (l.text, r.text, l.length) == 0); 379 return FFEBAD; 380} 381 382#endif 383/* ffetarget_le_character1 -- Perform relational comparison on char constants 384 385 Compare lengths, if equal then use memcmp. */ 386 387#if FFETARGET_okCHARACTER1 388ffebad 389ffetarget_le_character1 (bool *res, ffetargetCharacter1 l, 390 ffetargetCharacter1 r) 391{ 392 assert (l.length == r.length); 393 *res = (memcmp (l.text, r.text, l.length) <= 0); 394 return FFEBAD; 395} 396 397#endif 398/* ffetarget_lt_character1 -- Perform relational comparison on char constants 399 400 Compare lengths, if equal then use memcmp. */ 401 402#if FFETARGET_okCHARACTER1 403ffebad 404ffetarget_lt_character1 (bool *res, ffetargetCharacter1 l, 405 ffetargetCharacter1 r) 406{ 407 assert (l.length == r.length); 408 *res = (memcmp (l.text, r.text, l.length) < 0); 409 return FFEBAD; 410} 411 412#endif 413/* ffetarget_ge_character1 -- Perform relational comparison on char constants 414 415 Compare lengths, if equal then use memcmp. */ 416 417#if FFETARGET_okCHARACTER1 418ffebad 419ffetarget_ge_character1 (bool *res, ffetargetCharacter1 l, 420 ffetargetCharacter1 r) 421{ 422 assert (l.length == r.length); 423 *res = (memcmp (l.text, r.text, l.length) >= 0); 424 return FFEBAD; 425} 426 427#endif 428/* ffetarget_gt_character1 -- Perform relational comparison on char constants 429 430 Compare lengths, if equal then use memcmp. */ 431 432#if FFETARGET_okCHARACTER1 433ffebad 434ffetarget_gt_character1 (bool *res, ffetargetCharacter1 l, 435 ffetargetCharacter1 r) 436{ 437 assert (l.length == r.length); 438 *res = (memcmp (l.text, r.text, l.length) > 0); 439 return FFEBAD; 440} 441#endif 442 443#if FFETARGET_okCHARACTER1 444bool 445ffetarget_iszero_character1 (ffetargetCharacter1 constant) 446{ 447 ffetargetCharacterSize i; 448 449 for (i = 0; i < constant.length; ++i) 450 if (constant.text[i] != 0) 451 return FALSE; 452 return TRUE; 453} 454#endif 455 456bool 457ffetarget_iszero_hollerith (ffetargetHollerith constant) 458{ 459 ffetargetHollerithSize i; 460 461 for (i = 0; i < constant.length; ++i) 462 if (constant.text[i] != 0) 463 return FALSE; 464 return TRUE; 465} 466 467/* ffetarget_layout -- Do storage requirement analysis for entity 468 469 Return the alignment/modulo requirements along with the size, given the 470 data type info and the number of elements an array (1 for a scalar). */ 471 472void 473ffetarget_layout (const char *error_text UNUSED, ffetargetAlign *alignment, 474 ffetargetAlign *modulo, ffetargetOffset *size, 475 ffeinfoBasictype bt, ffeinfoKindtype kt, 476 ffetargetCharacterSize charsize, 477 ffetargetIntegerDefault num_elements) 478{ 479 bool ok; /* For character type. */ 480 ffetargetOffset numele; /* Converted from num_elements. */ 481 ffetype type; 482 483 type = ffeinfo_type (bt, kt); 484 assert (type != NULL); 485 486 *alignment = ffetype_alignment (type); 487 *modulo = ffetype_modulo (type); 488 if (bt == FFEINFO_basictypeCHARACTER) 489 { 490 ok = ffetarget_offset_charsize (size, charsize, ffetype_size (type)); 491#ifdef ffetarget_offset_overflow 492 if (!ok) 493 ffetarget_offset_overflow (error_text); 494#endif 495 } 496 else 497 *size = ffetype_size (type); 498 499 if ((num_elements < 0) 500 || !ffetarget_offset (&numele, num_elements) 501 || !ffetarget_offset_multiply (size, *size, numele)) 502 { 503 ffetarget_offset_overflow (error_text); 504 *alignment = 1; 505 *modulo = 0; 506 *size = 0; 507 } 508} 509 510/* ffetarget_ne_character1 -- Perform relational comparison on char constants 511 512 Compare lengths, if equal then use memcmp. */ 513 514#if FFETARGET_okCHARACTER1 515ffebad 516ffetarget_ne_character1 (bool *res, ffetargetCharacter1 l, 517 ffetargetCharacter1 r) 518{ 519 assert (l.length == r.length); 520 *res = (memcmp (l.text, r.text, l.length) != 0); 521 return FFEBAD; 522} 523 524#endif 525/* ffetarget_substr_character1 -- Perform SUBSTR op on three constants 526 527 Always append a null byte to the end, in case this is wanted in 528 a special case such as passing a string as a FORMAT or %REF. 529 Done to save a bit of hassle, nothing more, but it's a kludge anyway, 530 because it isn't a "feature" that is self-documenting. Use the 531 string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature 532 in the code. */ 533 534#if FFETARGET_okCHARACTER1 535ffebad 536ffetarget_substr_character1 (ffetargetCharacter1 *res, 537 ffetargetCharacter1 l, 538 ffetargetCharacterSize first, 539 ffetargetCharacterSize last, mallocPool pool, 540 ffetargetCharacterSize *len) 541{ 542 if (last < first) 543 { 544 res->length = *len = 0; 545 res->text = NULL; 546 } 547 else 548 { 549 res->length = *len = last - first + 1; 550 res->text = malloc_new_kp (pool, "ffetargetCharacter1(SUBSTR)", *len + 1); 551 memcpy (res->text, l.text + first - 1, *len); 552 res->text[*len] = '\0'; 553 } 554 555 return FFEBAD; 556} 557 558#endif 559/* ffetarget_cmp_hollerith -- Produce orderable comparison between two 560 constants 561 562 Compare lengths, if equal then use memcmp. */ 563 564int 565ffetarget_cmp_hollerith (ffetargetHollerith l, ffetargetHollerith r) 566{ 567 if (l.length < r.length) 568 return -1; 569 if (l.length > r.length) 570 return 1; 571 return memcmp (l.text, r.text, l.length); 572} 573 574ffebad 575ffetarget_convert_any_character1_ (char *res, size_t size, 576 ffetargetCharacter1 l) 577{ 578 if (size <= (size_t) l.length) 579 { 580 char *p; 581 ffetargetCharacterSize i; 582 583 memcpy (res, l.text, size); 584 for (p = &l.text[0] + size, i = l.length - size; 585 i > 0; 586 ++p, --i) 587 if (*p != ' ') 588 return FFEBAD_TRUNCATING_CHARACTER; 589 } 590 else 591 { 592 memcpy (res, l.text, size); 593 memset (res + l.length, ' ', size - l.length); 594 } 595 596 return FFEBAD; 597} 598 599ffebad 600ffetarget_convert_any_hollerith_ (char *res, size_t size, 601 ffetargetHollerith l) 602{ 603 if (size <= (size_t) l.length) 604 { 605 char *p; 606 ffetargetCharacterSize i; 607 608 memcpy (res, l.text, size); 609 for (p = &l.text[0] + size, i = l.length - size; 610 i > 0; 611 ++p, --i) 612 if (*p != ' ') 613 return FFEBAD_TRUNCATING_HOLLERITH; 614 } 615 else 616 { 617 memcpy (res, l.text, size); 618 memset (res + l.length, ' ', size - l.length); 619 } 620 621 return FFEBAD; 622} 623 624ffebad 625ffetarget_convert_any_typeless_ (char *res, size_t size, 626 ffetargetTypeless l) 627{ 628 unsigned long long int l1; 629 unsigned long int l2; 630 unsigned int l3; 631 unsigned short int l4; 632 unsigned char l5; 633 size_t size_of; 634 char *p; 635 636 if (size >= sizeof (l1)) 637 { 638 l1 = l; 639 p = (char *) &l1; 640 size_of = sizeof (l1); 641 } 642 else if (size >= sizeof (l2)) 643 { 644 l2 = l; 645 p = (char *) &l2; 646 size_of = sizeof (l2); 647 l1 = l2; 648 } 649 else if (size >= sizeof (l3)) 650 { 651 l3 = l; 652 p = (char *) &l3; 653 size_of = sizeof (l3); 654 l1 = l3; 655 } 656 else if (size >= sizeof (l4)) 657 { 658 l4 = l; 659 p = (char *) &l4; 660 size_of = sizeof (l4); 661 l1 = l4; 662 } 663 else if (size >= sizeof (l5)) 664 { 665 l5 = l; 666 p = (char *) &l5; 667 size_of = sizeof (l5); 668 l1 = l5; 669 } 670 else 671 { 672 assert ("stumped by conversion from typeless!" == NULL); 673 abort (); 674 } 675 676 if (size <= size_of) 677 { 678 int i = size_of - size; 679 680 memcpy (res, p + i, size); 681 for (; i > 0; ++p, --i) 682 if (*p != '\0') 683 return FFEBAD_TRUNCATING_TYPELESS; 684 } 685 else 686 { 687 int i = size - size_of; 688 689 memset (res, 0, i); 690 memcpy (res + i, p, size_of); 691 } 692 693 if (l1 != l) 694 return FFEBAD_TRUNCATING_TYPELESS; 695 return FFEBAD; 696} 697 698/* Always append a null byte to the end, in case this is wanted in 699 a special case such as passing a string as a FORMAT or %REF. 700 Done to save a bit of hassle, nothing more, but it's a kludge anyway, 701 because it isn't a "feature" that is self-documenting. Use the 702 string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature 703 in the code. */ 704 705#if FFETARGET_okCHARACTER1 706ffebad 707ffetarget_convert_character1_character1 (ffetargetCharacter1 *res, 708 ffetargetCharacterSize size, 709 ffetargetCharacter1 l, 710 mallocPool pool) 711{ 712 res->length = size; 713 if (size == 0) 714 res->text = NULL; 715 else 716 { 717 res->text = malloc_new_kp (pool, "FFETARGET cvt char1", size + 1); 718 if (size <= l.length) 719 memcpy (res->text, l.text, size); 720 else 721 { 722 memcpy (res->text, l.text, l.length); 723 memset (res->text + l.length, ' ', size - l.length); 724 } 725 res->text[size] = '\0'; 726 } 727 728 return FFEBAD; 729} 730 731#endif 732 733/* Always append a null byte to the end, in case this is wanted in 734 a special case such as passing a string as a FORMAT or %REF. 735 Done to save a bit of hassle, nothing more, but it's a kludge anyway, 736 because it isn't a "feature" that is self-documenting. Use the 737 string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature 738 in the code. */ 739 740#if FFETARGET_okCHARACTER1 741ffebad 742ffetarget_convert_character1_hollerith (ffetargetCharacter1 *res, 743 ffetargetCharacterSize size, 744 ffetargetHollerith l, mallocPool pool) 745{ 746 res->length = size; 747 if (size == 0) 748 res->text = NULL; 749 else 750 { 751 res->text = malloc_new_kp (pool, "FFETARGET cvt char1", size + 1); 752 res->text[size] = '\0'; 753 if (size <= l.length) 754 { 755 char *p; 756 ffetargetCharacterSize i; 757 758 memcpy (res->text, l.text, size); 759 for (p = &l.text[0] + size, i = l.length - size; 760 i > 0; 761 ++p, --i) 762 if (*p != ' ') 763 return FFEBAD_TRUNCATING_HOLLERITH; 764 } 765 else 766 { 767 memcpy (res->text, l.text, l.length); 768 memset (res->text + l.length, ' ', size - l.length); 769 } 770 } 771 772 return FFEBAD; 773} 774 775#endif 776/* ffetarget_convert_character1_integer4 -- Raw conversion. 777 778 Always append a null byte to the end, in case this is wanted in 779 a special case such as passing a string as a FORMAT or %REF. 780 Done to save a bit of hassle, nothing more, but it's a kludge anyway, 781 because it isn't a "feature" that is self-documenting. Use the 782 string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature 783 in the code. */ 784 785#if FFETARGET_okCHARACTER1 786ffebad 787ffetarget_convert_character1_integer4 (ffetargetCharacter1 *res, 788 ffetargetCharacterSize size, 789 ffetargetInteger4 l, mallocPool pool) 790{ 791 long long int l1; 792 long int l2; 793 int l3; 794 short int l4; 795 char l5; 796 size_t size_of; 797 char *p; 798 799 if (((size_t) size) >= sizeof (l1)) 800 { 801 l1 = l; 802 p = (char *) &l1; 803 size_of = sizeof (l1); 804 } 805 else if (((size_t) size) >= sizeof (l2)) 806 { 807 l2 = l; 808 p = (char *) &l2; 809 size_of = sizeof (l2); 810 l1 = l2; 811 } 812 else if (((size_t) size) >= sizeof (l3)) 813 { 814 l3 = l; 815 p = (char *) &l3; 816 size_of = sizeof (l3); 817 l1 = l3; 818 } 819 else if (((size_t) size) >= sizeof (l4)) 820 { 821 l4 = l; 822 p = (char *) &l4; 823 size_of = sizeof (l4); 824 l1 = l4; 825 } 826 else if (((size_t) size) >= sizeof (l5)) 827 { 828 l5 = l; 829 p = (char *) &l5; 830 size_of = sizeof (l5); 831 l1 = l5; 832 } 833 else 834 { 835 assert ("stumped by conversion from integer1!" == NULL); 836 abort (); 837 } 838 839 res->length = size; 840 if (size == 0) 841 res->text = NULL; 842 else 843 { 844 res->text = malloc_new_kp (pool, "FFETARGET cvt char1", size + 1); 845 res->text[size] = '\0'; 846 if (((size_t) size) <= size_of) 847 { 848 int i = size_of - size; 849 850 memcpy (res->text, p + i, size); 851 for (; i > 0; ++p, --i) 852 if (*p != 0) 853 return FFEBAD_TRUNCATING_NUMERIC; 854 } 855 else 856 { 857 int i = size - size_of; 858 859 memset (res->text, 0, i); 860 memcpy (res->text + i, p, size_of); 861 } 862 } 863 864 if (l1 != l) 865 return FFEBAD_TRUNCATING_NUMERIC; 866 return FFEBAD; 867} 868 869#endif 870/* ffetarget_convert_character1_logical4 -- Raw conversion. 871 872 Always append a null byte to the end, in case this is wanted in 873 a special case such as passing a string as a FORMAT or %REF. 874 Done to save a bit of hassle, nothing more, but it's a kludge anyway, 875 because it isn't a "feature" that is self-documenting. Use the 876 string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature 877 in the code. */ 878 879#if FFETARGET_okCHARACTER1 880ffebad 881ffetarget_convert_character1_logical4 (ffetargetCharacter1 *res, 882 ffetargetCharacterSize size, 883 ffetargetLogical4 l, mallocPool pool) 884{ 885 long long int l1; 886 long int l2; 887 int l3; 888 short int l4; 889 char l5; 890 size_t size_of; 891 char *p; 892 893 if (((size_t) size) >= sizeof (l1)) 894 { 895 l1 = l; 896 p = (char *) &l1; 897 size_of = sizeof (l1); 898 } 899 else if (((size_t) size) >= sizeof (l2)) 900 { 901 l2 = l; 902 p = (char *) &l2; 903 size_of = sizeof (l2); 904 l1 = l2; 905 } 906 else if (((size_t) size) >= sizeof (l3)) 907 { 908 l3 = l; 909 p = (char *) &l3; 910 size_of = sizeof (l3); 911 l1 = l3; 912 } 913 else if (((size_t) size) >= sizeof (l4)) 914 { 915 l4 = l; 916 p = (char *) &l4; 917 size_of = sizeof (l4); 918 l1 = l4; 919 } 920 else if (((size_t) size) >= sizeof (l5)) 921 { 922 l5 = l; 923 p = (char *) &l5; 924 size_of = sizeof (l5); 925 l1 = l5; 926 } 927 else 928 { 929 assert ("stumped by conversion from logical1!" == NULL); 930 abort (); 931 } 932 933 res->length = size; 934 if (size == 0) 935 res->text = NULL; 936 else 937 { 938 res->text = malloc_new_kp (pool, "FFETARGET cvt char1", size + 1); 939 res->text[size] = '\0'; 940 if (((size_t) size) <= size_of) 941 { 942 int i = size_of - size; 943 944 memcpy (res->text, p + i, size); 945 for (; i > 0; ++p, --i) 946 if (*p != 0) 947 return FFEBAD_TRUNCATING_NUMERIC; 948 } 949 else 950 { 951 int i = size - size_of; 952 953 memset (res->text, 0, i); 954 memcpy (res->text + i, p, size_of); 955 } 956 } 957 958 if (l1 != l) 959 return FFEBAD_TRUNCATING_NUMERIC; 960 return FFEBAD; 961} 962 963#endif 964/* ffetarget_convert_character1_typeless -- Raw conversion. 965 966 Always append a null byte to the end, in case this is wanted in 967 a special case such as passing a string as a FORMAT or %REF. 968 Done to save a bit of hassle, nothing more, but it's a kludge anyway, 969 because it isn't a "feature" that is self-documenting. Use the 970 string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature 971 in the code. */ 972 973#if FFETARGET_okCHARACTER1 974ffebad 975ffetarget_convert_character1_typeless (ffetargetCharacter1 *res, 976 ffetargetCharacterSize size, 977 ffetargetTypeless l, mallocPool pool) 978{ 979 unsigned long long int l1; 980 unsigned long int l2; 981 unsigned int l3; 982 unsigned short int l4; 983 unsigned char l5; 984 size_t size_of; 985 char *p; 986 987 if (((size_t) size) >= sizeof (l1)) 988 { 989 l1 = l; 990 p = (char *) &l1; 991 size_of = sizeof (l1); 992 } 993 else if (((size_t) size) >= sizeof (l2)) 994 { 995 l2 = l; 996 p = (char *) &l2; 997 size_of = sizeof (l2); 998 l1 = l2; 999 } 1000 else if (((size_t) size) >= sizeof (l3)) 1001 { 1002 l3 = l; 1003 p = (char *) &l3; 1004 size_of = sizeof (l3); 1005 l1 = l3; 1006 } 1007 else if (((size_t) size) >= sizeof (l4)) 1008 { 1009 l4 = l; 1010 p = (char *) &l4; 1011 size_of = sizeof (l4); 1012 l1 = l4; 1013 } 1014 else if (((size_t) size) >= sizeof (l5)) 1015 { 1016 l5 = l; 1017 p = (char *) &l5; 1018 size_of = sizeof (l5); 1019 l1 = l5; 1020 } 1021 else 1022 { 1023 assert ("stumped by conversion from typeless!" == NULL); 1024 abort (); 1025 } 1026 1027 res->length = size; 1028 if (size == 0) 1029 res->text = NULL; 1030 else 1031 { 1032 res->text = malloc_new_kp (pool, "FFETARGET cvt char1", size + 1); 1033 res->text[size] = '\0'; 1034 if (((size_t) size) <= size_of) 1035 { 1036 int i = size_of - size; 1037 1038 memcpy (res->text, p + i, size); 1039 for (; i > 0; ++p, --i) 1040 if (*p != 0) 1041 return FFEBAD_TRUNCATING_TYPELESS; 1042 } 1043 else 1044 { 1045 int i = size - size_of; 1046 1047 memset (res->text, 0, i); 1048 memcpy (res->text + i, p, size_of); 1049 } 1050 } 1051 1052 if (l1 != l) 1053 return FFEBAD_TRUNCATING_TYPELESS; 1054 return FFEBAD; 1055} 1056 1057#endif 1058/* ffetarget_divide_complex1 -- Divide function 1059 1060 See prototype. */ 1061 1062#if FFETARGET_okCOMPLEX1 1063ffebad 1064ffetarget_divide_complex1 (ffetargetComplex1 *res, ffetargetComplex1 l, 1065 ffetargetComplex1 r) 1066{ 1067 ffebad bad; 1068 ffetargetReal1 tmp1, tmp2, tmp3, tmp4; 1069 1070 bad = ffetarget_multiply_real1 (&tmp1, r.real, r.real); 1071 if (bad != FFEBAD) 1072 return bad; 1073 bad = ffetarget_multiply_real1 (&tmp2, r.imaginary, r.imaginary); 1074 if (bad != FFEBAD) 1075 return bad; 1076 bad = ffetarget_add_real1 (&tmp3, tmp1, tmp2); 1077 if (bad != FFEBAD) 1078 return bad; 1079 1080 if (ffetarget_iszero_real1 (tmp3)) 1081 { 1082 ffetarget_real1_zero (&(res)->real); 1083 ffetarget_real1_zero (&(res)->imaginary); 1084 return FFEBAD_DIV_BY_ZERO; 1085 } 1086 1087 bad = ffetarget_multiply_real1 (&tmp1, l.real, r.real); 1088 if (bad != FFEBAD) 1089 return bad; 1090 bad = ffetarget_multiply_real1 (&tmp2, l.imaginary, r.imaginary); 1091 if (bad != FFEBAD) 1092 return bad; 1093 bad = ffetarget_add_real1 (&tmp4, tmp1, tmp2); 1094 if (bad != FFEBAD) 1095 return bad; 1096 bad = ffetarget_divide_real1 (&res->real, tmp4, tmp3); 1097 if (bad != FFEBAD) 1098 return bad; 1099 1100 bad = ffetarget_multiply_real1 (&tmp1, r.real, l.imaginary); 1101 if (bad != FFEBAD) 1102 return bad; 1103 bad = ffetarget_multiply_real1 (&tmp2, l.real, r.imaginary); 1104 if (bad != FFEBAD) 1105 return bad; 1106 bad = ffetarget_subtract_real1 (&tmp4, tmp1, tmp2); 1107 if (bad != FFEBAD) 1108 return bad; 1109 bad = ffetarget_divide_real1 (&res->imaginary, tmp4, tmp3); 1110 1111 return FFEBAD; 1112} 1113 1114#endif 1115/* ffetarget_divide_complex2 -- Divide function 1116 1117 See prototype. */ 1118 1119#if FFETARGET_okCOMPLEX2 1120ffebad 1121ffetarget_divide_complex2 (ffetargetComplex2 *res, ffetargetComplex2 l, 1122 ffetargetComplex2 r) 1123{ 1124 ffebad bad; 1125 ffetargetReal2 tmp1, tmp2, tmp3, tmp4; 1126 1127 bad = ffetarget_multiply_real2 (&tmp1, r.real, r.real); 1128 if (bad != FFEBAD) 1129 return bad; 1130 bad = ffetarget_multiply_real2 (&tmp2, r.imaginary, r.imaginary); 1131 if (bad != FFEBAD) 1132 return bad; 1133 bad = ffetarget_add_real2 (&tmp3, tmp1, tmp2); 1134 if (bad != FFEBAD) 1135 return bad; 1136 1137 if (ffetarget_iszero_real2 (tmp3)) 1138 { 1139 ffetarget_real2_zero (&(res)->real); 1140 ffetarget_real2_zero (&(res)->imaginary); 1141 return FFEBAD_DIV_BY_ZERO; 1142 } 1143 1144 bad = ffetarget_multiply_real2 (&tmp1, l.real, r.real); 1145 if (bad != FFEBAD) 1146 return bad; 1147 bad = ffetarget_multiply_real2 (&tmp2, l.imaginary, r.imaginary); 1148 if (bad != FFEBAD) 1149 return bad; 1150 bad = ffetarget_add_real2 (&tmp4, tmp1, tmp2); 1151 if (bad != FFEBAD) 1152 return bad; 1153 bad = ffetarget_divide_real2 (&res->real, tmp4, tmp3); 1154 if (bad != FFEBAD) 1155 return bad; 1156 1157 bad = ffetarget_multiply_real2 (&tmp1, r.real, l.imaginary); 1158 if (bad != FFEBAD) 1159 return bad; 1160 bad = ffetarget_multiply_real2 (&tmp2, l.real, r.imaginary); 1161 if (bad != FFEBAD) 1162 return bad; 1163 bad = ffetarget_subtract_real2 (&tmp4, tmp1, tmp2); 1164 if (bad != FFEBAD) 1165 return bad; 1166 bad = ffetarget_divide_real2 (&res->imaginary, tmp4, tmp3); 1167 1168 return FFEBAD; 1169} 1170 1171#endif 1172/* ffetarget_hollerith -- Convert token to a hollerith constant 1173 1174 Always append a null byte to the end, in case this is wanted in 1175 a special case such as passing a string as a FORMAT or %REF. 1176 Done to save a bit of hassle, nothing more, but it's a kludge anyway, 1177 because it isn't a "feature" that is self-documenting. Use the 1178 string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature 1179 in the code. */ 1180 1181bool 1182ffetarget_hollerith (ffetargetHollerith *val, ffelexToken integer, 1183 mallocPool pool) 1184{ 1185 val->length = ffelex_token_length (integer); 1186 val->text = malloc_new_kp (pool, "ffetargetHollerith", val->length + 1); 1187 memcpy (val->text, ffelex_token_text (integer), val->length); 1188 val->text[val->length] = '\0'; 1189 1190 return TRUE; 1191} 1192 1193/* ffetarget_integer_bad_magical -- Complain about a magical number 1194 1195 Just calls ffebad with the arguments. */ 1196 1197void 1198ffetarget_integer_bad_magical (ffelexToken t) 1199{ 1200 ffebad_start (FFEBAD_BAD_MAGICAL); 1201 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); 1202 ffebad_finish (); 1203} 1204 1205/* ffetarget_integer_bad_magical_binary -- Complain about a magical number 1206 1207 Just calls ffebad with the arguments. */ 1208 1209void 1210ffetarget_integer_bad_magical_binary (ffelexToken integer, 1211 ffelexToken minus) 1212{ 1213 ffebad_start (FFEBAD_BAD_MAGICAL_BINARY); 1214 ffebad_here (0, ffelex_token_where_line (integer), 1215 ffelex_token_where_column (integer)); 1216 ffebad_here (1, ffelex_token_where_line (minus), 1217 ffelex_token_where_column (minus)); 1218 ffebad_finish (); 1219} 1220 1221/* ffetarget_integer_bad_magical_precedence -- Complain about a magical 1222 number 1223 1224 Just calls ffebad with the arguments. */ 1225 1226void 1227ffetarget_integer_bad_magical_precedence (ffelexToken integer, 1228 ffelexToken uminus, 1229 ffelexToken higher_op) 1230{ 1231 ffebad_start (FFEBAD_BAD_MAGICAL_PRECEDENCE); 1232 ffebad_here (0, ffelex_token_where_line (integer), 1233 ffelex_token_where_column (integer)); 1234 ffebad_here (1, ffelex_token_where_line (uminus), 1235 ffelex_token_where_column (uminus)); 1236 ffebad_here (2, ffelex_token_where_line (higher_op), 1237 ffelex_token_where_column (higher_op)); 1238 ffebad_finish (); 1239} 1240 1241/* ffetarget_integer_bad_magical_precedence_binary -- Complain... 1242 1243 Just calls ffebad with the arguments. */ 1244 1245void 1246ffetarget_integer_bad_magical_precedence_binary (ffelexToken integer, 1247 ffelexToken minus, 1248 ffelexToken higher_op) 1249{ 1250 ffebad_start (FFEBAD_BAD_MAGICAL_PRECEDENCE_BINARY); 1251 ffebad_here (0, ffelex_token_where_line (integer), 1252 ffelex_token_where_column (integer)); 1253 ffebad_here (1, ffelex_token_where_line (minus), 1254 ffelex_token_where_column (minus)); 1255 ffebad_here (2, ffelex_token_where_line (higher_op), 1256 ffelex_token_where_column (higher_op)); 1257 ffebad_finish (); 1258} 1259 1260/* ffetarget_integer1 -- Convert token to an integer 1261 1262 See prototype. 1263 1264 Token use count not affected overall. */ 1265 1266#if FFETARGET_okINTEGER1 1267bool 1268ffetarget_integer1 (ffetargetInteger1 *val, ffelexToken integer) 1269{ 1270 ffetargetInteger1 x; 1271 char *p; 1272 char c; 1273 1274 assert (ffelex_token_type (integer) == FFELEX_typeNUMBER); 1275 1276 p = ffelex_token_text (integer); 1277 x = 0; 1278 1279 /* Skip past leading zeros. */ 1280 1281 while (((c = *p) != '\0') && (c == '0')) 1282 ++p; 1283 1284 /* Interpret rest of number. */ 1285 1286 while (c != '\0') 1287 { 1288 if ((x == FFETARGET_integerALMOST_BIG_MAGICAL) 1289 && (c == '0' + FFETARGET_integerFINISH_BIG_MAGICAL) 1290 && (*(p + 1) == '\0')) 1291 { 1292 *val = (ffetargetInteger1) FFETARGET_integerBIG_MAGICAL; 1293 return TRUE; 1294 } 1295 else if (x == FFETARGET_integerALMOST_BIG_MAGICAL) 1296 { 1297 if ((c > '0' + FFETARGET_integerFINISH_BIG_MAGICAL) 1298 || (*(p + 1) != '\0')) 1299 { 1300 ffebad_start (FFEBAD_INTEGER_TOO_LARGE); 1301 ffebad_here (0, ffelex_token_where_line (integer), 1302 ffelex_token_where_column (integer)); 1303 ffebad_finish (); 1304 *val = 0; 1305 return FALSE; 1306 } 1307 } 1308 else if (x > FFETARGET_integerALMOST_BIG_MAGICAL) 1309 { 1310 ffebad_start (FFEBAD_INTEGER_TOO_LARGE); 1311 ffebad_here (0, ffelex_token_where_line (integer), 1312 ffelex_token_where_column (integer)); 1313 ffebad_finish (); 1314 *val = 0; 1315 return FALSE; 1316 } 1317 x = x * 10 + c - '0'; 1318 c = *(++p); 1319 }; 1320 1321 *val = x; 1322 return TRUE; 1323} 1324 1325#endif 1326/* ffetarget_integerbinary -- Convert token to a binary integer 1327 1328 ffetarget_integerbinary x; 1329 if (ffetarget_integerdefault_8(&x,integer_token)) 1330 // conversion ok. 1331 1332 Token use count not affected overall. */ 1333 1334bool 1335ffetarget_integerbinary (ffetargetIntegerDefault *val, ffelexToken integer) 1336{ 1337 ffetargetIntegerDefault x; 1338 char *p; 1339 char c; 1340 bool bad_digit; 1341 1342 assert ((ffelex_token_type (integer) == FFELEX_typeNAME) 1343 || (ffelex_token_type (integer) == FFELEX_typeNUMBER)); 1344 1345 p = ffelex_token_text (integer); 1346 x = 0; 1347 1348 /* Skip past leading zeros. */ 1349 1350 while (((c = *p) != '\0') && (c == '0')) 1351 ++p; 1352 1353 /* Interpret rest of number. */ 1354 1355 bad_digit = FALSE; 1356 while (c != '\0') 1357 { 1358 if ((c >= '0') && (c <= '1')) 1359 c -= '0'; 1360 else 1361 { 1362 bad_digit = TRUE; 1363 c = 0; 1364 } 1365 1366#if 0 /* Don't complain about signed overflow; just 1367 unsigned overflow. */ 1368 if ((x == FFETARGET_integerALMOST_BIG_OVERFLOW_BINARY) 1369 && (c == FFETARGET_integerFINISH_BIG_OVERFLOW_BINARY) 1370 && (*(p + 1) == '\0')) 1371 { 1372 *val = FFETARGET_integerBIG_OVERFLOW_BINARY; 1373 return TRUE; 1374 } 1375 else 1376#endif 1377#if FFETARGET_integerFINISH_BIG_OVERFLOW_BINARY == 0 1378 if ((x & FFETARGET_integerALMOST_BIG_OVERFLOW_BINARY) != 0) 1379#else 1380 if (x == FFETARGET_integerALMOST_BIG_OVERFLOW_BINARY) 1381 { 1382 if ((c > FFETARGET_integerFINISH_BIG_OVERFLOW_BINARY) 1383 || (*(p + 1) != '\0')) 1384 { 1385 ffebad_start (FFEBAD_INTEGER_TOO_LARGE); 1386 ffebad_here (0, ffelex_token_where_line (integer), 1387 ffelex_token_where_column (integer)); 1388 ffebad_finish (); 1389 *val = 0; 1390 return FALSE; 1391 } 1392 } 1393 else if (x > FFETARGET_integerALMOST_BIG_OVERFLOW_BINARY) 1394#endif 1395 { 1396 ffebad_start (FFEBAD_INTEGER_TOO_LARGE); 1397 ffebad_here (0, ffelex_token_where_line (integer), 1398 ffelex_token_where_column (integer)); 1399 ffebad_finish (); 1400 *val = 0; 1401 return FALSE; 1402 } 1403 x = (x << 1) + c; 1404 c = *(++p); 1405 }; 1406 1407 if (bad_digit) 1408 { 1409 ffebad_start (FFEBAD_INVALID_BINARY_DIGIT); 1410 ffebad_here (0, ffelex_token_where_line (integer), 1411 ffelex_token_where_column (integer)); 1412 ffebad_finish (); 1413 } 1414 1415 *val = x; 1416 return !bad_digit; 1417} 1418 1419/* ffetarget_integerhex -- Convert token to a hex integer 1420 1421 ffetarget_integerhex x; 1422 if (ffetarget_integerdefault_8(&x,integer_token)) 1423 // conversion ok. 1424 1425 Token use count not affected overall. */ 1426 1427bool 1428ffetarget_integerhex (ffetargetIntegerDefault *val, ffelexToken integer) 1429{ 1430 ffetargetIntegerDefault x; 1431 char *p; 1432 char c; 1433 bool bad_digit; 1434 1435 assert ((ffelex_token_type (integer) == FFELEX_typeNAME) 1436 || (ffelex_token_type (integer) == FFELEX_typeNUMBER)); 1437 1438 p = ffelex_token_text (integer); 1439 x = 0; 1440 1441 /* Skip past leading zeros. */ 1442 1443 while (((c = *p) != '\0') && (c == '0')) 1444 ++p; 1445 1446 /* Interpret rest of number. */ 1447 1448 bad_digit = FALSE; 1449 while (c != '\0') 1450 { 1451 if (hex_p (c)) 1452 c = hex_value (c); 1453 else 1454 { 1455 bad_digit = TRUE; 1456 c = 0; 1457 } 1458 1459#if 0 /* Don't complain about signed overflow; just 1460 unsigned overflow. */ 1461 if ((x == FFETARGET_integerALMOST_BIG_OVERFLOW_HEX) 1462 && (c == FFETARGET_integerFINISH_BIG_OVERFLOW_HEX) 1463 && (*(p + 1) == '\0')) 1464 { 1465 *val = FFETARGET_integerBIG_OVERFLOW_HEX; 1466 return TRUE; 1467 } 1468 else 1469#endif 1470#if FFETARGET_integerFINISH_BIG_OVERFLOW_HEX == 0 1471 if (x >= FFETARGET_integerALMOST_BIG_OVERFLOW_HEX) 1472#else 1473 if (x == FFETARGET_integerALMOST_BIG_OVERFLOW_HEX) 1474 { 1475 if ((c > FFETARGET_integerFINISH_BIG_OVERFLOW_HEX) 1476 || (*(p + 1) != '\0')) 1477 { 1478 ffebad_start (FFEBAD_INTEGER_TOO_LARGE); 1479 ffebad_here (0, ffelex_token_where_line (integer), 1480 ffelex_token_where_column (integer)); 1481 ffebad_finish (); 1482 *val = 0; 1483 return FALSE; 1484 } 1485 } 1486 else if (x > FFETARGET_integerALMOST_BIG_OVERFLOW_HEX) 1487#endif 1488 { 1489 ffebad_start (FFEBAD_INTEGER_TOO_LARGE); 1490 ffebad_here (0, ffelex_token_where_line (integer), 1491 ffelex_token_where_column (integer)); 1492 ffebad_finish (); 1493 *val = 0; 1494 return FALSE; 1495 } 1496 x = (x << 4) + c; 1497 c = *(++p); 1498 }; 1499 1500 if (bad_digit) 1501 { 1502 ffebad_start (FFEBAD_INVALID_HEX_DIGIT); 1503 ffebad_here (0, ffelex_token_where_line (integer), 1504 ffelex_token_where_column (integer)); 1505 ffebad_finish (); 1506 } 1507 1508 *val = x; 1509 return !bad_digit; 1510} 1511 1512/* ffetarget_integeroctal -- Convert token to an octal integer 1513 1514 ffetarget_integeroctal x; 1515 if (ffetarget_integerdefault_8(&x,integer_token)) 1516 // conversion ok. 1517 1518 Token use count not affected overall. */ 1519 1520bool 1521ffetarget_integeroctal (ffetargetIntegerDefault *val, ffelexToken integer) 1522{ 1523 ffetargetIntegerDefault x; 1524 char *p; 1525 char c; 1526 bool bad_digit; 1527 1528 assert ((ffelex_token_type (integer) == FFELEX_typeNAME) 1529 || (ffelex_token_type (integer) == FFELEX_typeNUMBER)); 1530 1531 p = ffelex_token_text (integer); 1532 x = 0; 1533 1534 /* Skip past leading zeros. */ 1535 1536 while (((c = *p) != '\0') && (c == '0')) 1537 ++p; 1538 1539 /* Interpret rest of number. */ 1540 1541 bad_digit = FALSE; 1542 while (c != '\0') 1543 { 1544 if ((c >= '0') && (c <= '7')) 1545 c -= '0'; 1546 else 1547 { 1548 bad_digit = TRUE; 1549 c = 0; 1550 } 1551 1552#if 0 /* Don't complain about signed overflow; just 1553 unsigned overflow. */ 1554 if ((x == FFETARGET_integerALMOST_BIG_OVERFLOW_OCTAL) 1555 && (c == FFETARGET_integerFINISH_BIG_OVERFLOW_OCTAL) 1556 && (*(p + 1) == '\0')) 1557 { 1558 *val = FFETARGET_integerBIG_OVERFLOW_OCTAL; 1559 return TRUE; 1560 } 1561 else 1562#endif 1563#if FFETARGET_integerFINISH_BIG_OVERFLOW_OCTAL == 0 1564 if (x >= FFETARGET_integerALMOST_BIG_OVERFLOW_OCTAL) 1565#else 1566 if (x == FFETARGET_integerALMOST_BIG_OVERFLOW_OCTAL) 1567 { 1568 if ((c > FFETARGET_integerFINISH_BIG_OVERFLOW_OCTAL) 1569 || (*(p + 1) != '\0')) 1570 { 1571 ffebad_start (FFEBAD_INTEGER_TOO_LARGE); 1572 ffebad_here (0, ffelex_token_where_line (integer), 1573 ffelex_token_where_column (integer)); 1574 ffebad_finish (); 1575 *val = 0; 1576 return FALSE; 1577 } 1578 } 1579 else if (x > FFETARGET_integerALMOST_BIG_OVERFLOW_OCTAL) 1580#endif 1581 { 1582 ffebad_start (FFEBAD_INTEGER_TOO_LARGE); 1583 ffebad_here (0, ffelex_token_where_line (integer), 1584 ffelex_token_where_column (integer)); 1585 ffebad_finish (); 1586 *val = 0; 1587 return FALSE; 1588 } 1589 x = (x << 3) + c; 1590 c = *(++p); 1591 }; 1592 1593 if (bad_digit) 1594 { 1595 ffebad_start (FFEBAD_INVALID_OCTAL_DIGIT); 1596 ffebad_here (0, ffelex_token_where_line (integer), 1597 ffelex_token_where_column (integer)); 1598 ffebad_finish (); 1599 } 1600 1601 *val = x; 1602 return !bad_digit; 1603} 1604 1605/* ffetarget_multiply_complex1 -- Multiply function 1606 1607 See prototype. */ 1608 1609#if FFETARGET_okCOMPLEX1 1610ffebad 1611ffetarget_multiply_complex1 (ffetargetComplex1 *res, ffetargetComplex1 l, 1612 ffetargetComplex1 r) 1613{ 1614 ffebad bad; 1615 ffetargetReal1 tmp1, tmp2; 1616 1617 bad = ffetarget_multiply_real1 (&tmp1, l.real, r.real); 1618 if (bad != FFEBAD) 1619 return bad; 1620 bad = ffetarget_multiply_real1 (&tmp2, l.imaginary, r.imaginary); 1621 if (bad != FFEBAD) 1622 return bad; 1623 bad = ffetarget_subtract_real1 (&res->real, tmp1, tmp2); 1624 if (bad != FFEBAD) 1625 return bad; 1626 bad = ffetarget_multiply_real1 (&tmp1, l.imaginary, r.real); 1627 if (bad != FFEBAD) 1628 return bad; 1629 bad = ffetarget_multiply_real1 (&tmp2, l.real, r.imaginary); 1630 if (bad != FFEBAD) 1631 return bad; 1632 bad = ffetarget_add_real1 (&res->imaginary, tmp1, tmp2); 1633 1634 return bad; 1635} 1636 1637#endif 1638/* ffetarget_multiply_complex2 -- Multiply function 1639 1640 See prototype. */ 1641 1642#if FFETARGET_okCOMPLEX2 1643ffebad 1644ffetarget_multiply_complex2 (ffetargetComplex2 *res, ffetargetComplex2 l, 1645 ffetargetComplex2 r) 1646{ 1647 ffebad bad; 1648 ffetargetReal2 tmp1, tmp2; 1649 1650 bad = ffetarget_multiply_real2 (&tmp1, l.real, r.real); 1651 if (bad != FFEBAD) 1652 return bad; 1653 bad = ffetarget_multiply_real2 (&tmp2, l.imaginary, r.imaginary); 1654 if (bad != FFEBAD) 1655 return bad; 1656 bad = ffetarget_subtract_real2 (&res->real, tmp1, tmp2); 1657 if (bad != FFEBAD) 1658 return bad; 1659 bad = ffetarget_multiply_real2 (&tmp1, l.imaginary, r.real); 1660 if (bad != FFEBAD) 1661 return bad; 1662 bad = ffetarget_multiply_real2 (&tmp2, l.real, r.imaginary); 1663 if (bad != FFEBAD) 1664 return bad; 1665 bad = ffetarget_add_real2 (&res->imaginary, tmp1, tmp2); 1666 1667 return bad; 1668} 1669 1670#endif 1671/* ffetarget_power_complexdefault_integerdefault -- Power function 1672 1673 See prototype. */ 1674 1675ffebad 1676ffetarget_power_complexdefault_integerdefault (ffetargetComplexDefault *res, 1677 ffetargetComplexDefault l, 1678 ffetargetIntegerDefault r) 1679{ 1680 ffebad bad; 1681 ffetargetRealDefault tmp; 1682 ffetargetRealDefault tmp1; 1683 ffetargetRealDefault tmp2; 1684 ffetargetRealDefault two; 1685 1686 if (ffetarget_iszero_real1 (l.real) 1687 && ffetarget_iszero_real1 (l.imaginary)) 1688 { 1689 ffetarget_real1_zero (&res->real); 1690 ffetarget_real1_zero (&res->imaginary); 1691 return FFEBAD; 1692 } 1693 1694 if (r == 0) 1695 { 1696 ffetarget_real1_one (&res->real); 1697 ffetarget_real1_zero (&res->imaginary); 1698 return FFEBAD; 1699 } 1700 1701 if (r < 0) 1702 { 1703 r = -r; 1704 bad = ffetarget_multiply_real1 (&tmp1, l.real, l.real); 1705 if (bad != FFEBAD) 1706 return bad; 1707 bad = ffetarget_multiply_real1 (&tmp2, l.imaginary, l.imaginary); 1708 if (bad != FFEBAD) 1709 return bad; 1710 bad = ffetarget_add_real1 (&tmp, tmp1, tmp2); 1711 if (bad != FFEBAD) 1712 return bad; 1713 bad = ffetarget_divide_real1 (&l.real, l.real, tmp); 1714 if (bad != FFEBAD) 1715 return bad; 1716 bad = ffetarget_divide_real1 (&l.imaginary, l.imaginary, tmp); 1717 if (bad != FFEBAD) 1718 return bad; 1719 bad = ffetarget_uminus_real1 (&l.imaginary, l.imaginary); 1720 if (bad != FFEBAD) 1721 return bad; 1722 } 1723 1724 ffetarget_real1_two (&two); 1725 1726 while ((r & 1) == 0) 1727 { 1728 bad = ffetarget_multiply_real1 (&tmp1, l.real, l.real); 1729 if (bad != FFEBAD) 1730 return bad; 1731 bad = ffetarget_multiply_real1 (&tmp2, l.imaginary, l.imaginary); 1732 if (bad != FFEBAD) 1733 return bad; 1734 bad = ffetarget_subtract_real1 (&tmp, tmp1, tmp2); 1735 if (bad != FFEBAD) 1736 return bad; 1737 bad = ffetarget_multiply_real1 (&l.imaginary, l.real, l.imaginary); 1738 if (bad != FFEBAD) 1739 return bad; 1740 bad = ffetarget_multiply_real1 (&l.imaginary, l.imaginary, two); 1741 if (bad != FFEBAD) 1742 return bad; 1743 l.real = tmp; 1744 r >>= 1; 1745 } 1746 1747 *res = l; 1748 r >>= 1; 1749 1750 while (r != 0) 1751 { 1752 bad = ffetarget_multiply_real1 (&tmp1, l.real, l.real); 1753 if (bad != FFEBAD) 1754 return bad; 1755 bad = ffetarget_multiply_real1 (&tmp2, l.imaginary, l.imaginary); 1756 if (bad != FFEBAD) 1757 return bad; 1758 bad = ffetarget_subtract_real1 (&tmp, tmp1, tmp2); 1759 if (bad != FFEBAD) 1760 return bad; 1761 bad = ffetarget_multiply_real1 (&l.imaginary, l.real, l.imaginary); 1762 if (bad != FFEBAD) 1763 return bad; 1764 bad = ffetarget_multiply_real1 (&l.imaginary, l.imaginary, two); 1765 if (bad != FFEBAD) 1766 return bad; 1767 l.real = tmp; 1768 if ((r & 1) == 1) 1769 { 1770 bad = ffetarget_multiply_real1 (&tmp1, res->real, l.real); 1771 if (bad != FFEBAD) 1772 return bad; 1773 bad = ffetarget_multiply_real1 (&tmp2, res->imaginary, 1774 l.imaginary); 1775 if (bad != FFEBAD) 1776 return bad; 1777 bad = ffetarget_subtract_real1 (&tmp, tmp1, tmp2); 1778 if (bad != FFEBAD) 1779 return bad; 1780 bad = ffetarget_multiply_real1 (&tmp1, res->imaginary, l.real); 1781 if (bad != FFEBAD) 1782 return bad; 1783 bad = ffetarget_multiply_real1 (&tmp2, res->real, l.imaginary); 1784 if (bad != FFEBAD) 1785 return bad; 1786 bad = ffetarget_add_real1 (&res->imaginary, tmp1, tmp2); 1787 if (bad != FFEBAD) 1788 return bad; 1789 res->real = tmp; 1790 } 1791 r >>= 1; 1792 } 1793 1794 return FFEBAD; 1795} 1796 1797/* ffetarget_power_complexdouble_integerdefault -- Power function 1798 1799 See prototype. */ 1800 1801#if FFETARGET_okCOMPLEXDOUBLE 1802ffebad 1803ffetarget_power_complexdouble_integerdefault (ffetargetComplexDouble *res, 1804 ffetargetComplexDouble l, ffetargetIntegerDefault r) 1805{ 1806 ffebad bad; 1807 ffetargetRealDouble tmp; 1808 ffetargetRealDouble tmp1; 1809 ffetargetRealDouble tmp2; 1810 ffetargetRealDouble two; 1811 1812 if (ffetarget_iszero_real2 (l.real) 1813 && ffetarget_iszero_real2 (l.imaginary)) 1814 { 1815 ffetarget_real2_zero (&res->real); 1816 ffetarget_real2_zero (&res->imaginary); 1817 return FFEBAD; 1818 } 1819 1820 if (r == 0) 1821 { 1822 ffetarget_real2_one (&res->real); 1823 ffetarget_real2_zero (&res->imaginary); 1824 return FFEBAD; 1825 } 1826 1827 if (r < 0) 1828 { 1829 r = -r; 1830 bad = ffetarget_multiply_real2 (&tmp1, l.real, l.real); 1831 if (bad != FFEBAD) 1832 return bad; 1833 bad = ffetarget_multiply_real2 (&tmp2, l.imaginary, l.imaginary); 1834 if (bad != FFEBAD) 1835 return bad; 1836 bad = ffetarget_add_real2 (&tmp, tmp1, tmp2); 1837 if (bad != FFEBAD) 1838 return bad; 1839 bad = ffetarget_divide_real2 (&l.real, l.real, tmp); 1840 if (bad != FFEBAD) 1841 return bad; 1842 bad = ffetarget_divide_real2 (&l.imaginary, l.imaginary, tmp); 1843 if (bad != FFEBAD) 1844 return bad; 1845 bad = ffetarget_uminus_real2 (&l.imaginary, l.imaginary); 1846 if (bad != FFEBAD) 1847 return bad; 1848 } 1849 1850 ffetarget_real2_two (&two); 1851 1852 while ((r & 1) == 0) 1853 { 1854 bad = ffetarget_multiply_real2 (&tmp1, l.real, l.real); 1855 if (bad != FFEBAD) 1856 return bad; 1857 bad = ffetarget_multiply_real2 (&tmp2, l.imaginary, l.imaginary); 1858 if (bad != FFEBAD) 1859 return bad; 1860 bad = ffetarget_subtract_real2 (&tmp, tmp1, tmp2); 1861 if (bad != FFEBAD) 1862 return bad; 1863 bad = ffetarget_multiply_real2 (&l.imaginary, l.real, l.imaginary); 1864 if (bad != FFEBAD) 1865 return bad; 1866 bad = ffetarget_multiply_real2 (&l.imaginary, l.imaginary, two); 1867 if (bad != FFEBAD) 1868 return bad; 1869 l.real = tmp; 1870 r >>= 1; 1871 } 1872 1873 *res = l; 1874 r >>= 1; 1875 1876 while (r != 0) 1877 { 1878 bad = ffetarget_multiply_real2 (&tmp1, l.real, l.real); 1879 if (bad != FFEBAD) 1880 return bad; 1881 bad = ffetarget_multiply_real2 (&tmp2, l.imaginary, l.imaginary); 1882 if (bad != FFEBAD) 1883 return bad; 1884 bad = ffetarget_subtract_real2 (&tmp, tmp1, tmp2); 1885 if (bad != FFEBAD) 1886 return bad; 1887 bad = ffetarget_multiply_real2 (&l.imaginary, l.real, l.imaginary); 1888 if (bad != FFEBAD) 1889 return bad; 1890 bad = ffetarget_multiply_real2 (&l.imaginary, l.imaginary, two); 1891 if (bad != FFEBAD) 1892 return bad; 1893 l.real = tmp; 1894 if ((r & 1) == 1) 1895 { 1896 bad = ffetarget_multiply_real2 (&tmp1, res->real, l.real); 1897 if (bad != FFEBAD) 1898 return bad; 1899 bad = ffetarget_multiply_real2 (&tmp2, res->imaginary, 1900 l.imaginary); 1901 if (bad != FFEBAD) 1902 return bad; 1903 bad = ffetarget_subtract_real2 (&tmp, tmp1, tmp2); 1904 if (bad != FFEBAD) 1905 return bad; 1906 bad = ffetarget_multiply_real2 (&tmp1, res->imaginary, l.real); 1907 if (bad != FFEBAD) 1908 return bad; 1909 bad = ffetarget_multiply_real2 (&tmp2, res->real, l.imaginary); 1910 if (bad != FFEBAD) 1911 return bad; 1912 bad = ffetarget_add_real2 (&res->imaginary, tmp1, tmp2); 1913 if (bad != FFEBAD) 1914 return bad; 1915 res->real = tmp; 1916 } 1917 r >>= 1; 1918 } 1919 1920 return FFEBAD; 1921} 1922 1923#endif 1924/* ffetarget_power_integerdefault_integerdefault -- Power function 1925 1926 See prototype. */ 1927 1928ffebad 1929ffetarget_power_integerdefault_integerdefault (ffetargetIntegerDefault *res, 1930 ffetargetIntegerDefault l, ffetargetIntegerDefault r) 1931{ 1932 if (l == 0) 1933 { 1934 *res = 0; 1935 return FFEBAD; 1936 } 1937 1938 if (r == 0) 1939 { 1940 *res = 1; 1941 return FFEBAD; 1942 } 1943 1944 if (r < 0) 1945 { 1946 if (l == 1) 1947 *res = 1; 1948 else if (l == 0) 1949 *res = 1; 1950 else if (l == -1) 1951 *res = ((-r) & 1) == 0 ? 1 : -1; 1952 else 1953 *res = 0; 1954 return FFEBAD; 1955 } 1956 1957 while ((r & 1) == 0) 1958 { 1959 l *= l; 1960 r >>= 1; 1961 } 1962 1963 *res = l; 1964 r >>= 1; 1965 1966 while (r != 0) 1967 { 1968 l *= l; 1969 if ((r & 1) == 1) 1970 *res *= l; 1971 r >>= 1; 1972 } 1973 1974 return FFEBAD; 1975} 1976 1977/* ffetarget_power_realdefault_integerdefault -- Power function 1978 1979 See prototype. */ 1980 1981ffebad 1982ffetarget_power_realdefault_integerdefault (ffetargetRealDefault *res, 1983 ffetargetRealDefault l, ffetargetIntegerDefault r) 1984{ 1985 ffebad bad; 1986 1987 if (ffetarget_iszero_real1 (l)) 1988 { 1989 ffetarget_real1_zero (res); 1990 return FFEBAD; 1991 } 1992 1993 if (r == 0) 1994 { 1995 ffetarget_real1_one (res); 1996 return FFEBAD; 1997 } 1998 1999 if (r < 0) 2000 { 2001 ffetargetRealDefault one; 2002 2003 ffetarget_real1_one (&one); 2004 r = -r; 2005 bad = ffetarget_divide_real1 (&l, one, l); 2006 if (bad != FFEBAD) 2007 return bad; 2008 } 2009 2010 while ((r & 1) == 0) 2011 { 2012 bad = ffetarget_multiply_real1 (&l, l, l); 2013 if (bad != FFEBAD) 2014 return bad; 2015 r >>= 1; 2016 } 2017 2018 *res = l; 2019 r >>= 1; 2020 2021 while (r != 0) 2022 { 2023 bad = ffetarget_multiply_real1 (&l, l, l); 2024 if (bad != FFEBAD) 2025 return bad; 2026 if ((r & 1) == 1) 2027 { 2028 bad = ffetarget_multiply_real1 (res, *res, l); 2029 if (bad != FFEBAD) 2030 return bad; 2031 } 2032 r >>= 1; 2033 } 2034 2035 return FFEBAD; 2036} 2037 2038/* ffetarget_power_realdouble_integerdefault -- Power function 2039 2040 See prototype. */ 2041 2042ffebad 2043ffetarget_power_realdouble_integerdefault (ffetargetRealDouble *res, 2044 ffetargetRealDouble l, 2045 ffetargetIntegerDefault r) 2046{ 2047 ffebad bad; 2048 2049 if (ffetarget_iszero_real2 (l)) 2050 { 2051 ffetarget_real2_zero (res); 2052 return FFEBAD; 2053 } 2054 2055 if (r == 0) 2056 { 2057 ffetarget_real2_one (res); 2058 return FFEBAD; 2059 } 2060 2061 if (r < 0) 2062 { 2063 ffetargetRealDouble one; 2064 2065 ffetarget_real2_one (&one); 2066 r = -r; 2067 bad = ffetarget_divide_real2 (&l, one, l); 2068 if (bad != FFEBAD) 2069 return bad; 2070 } 2071 2072 while ((r & 1) == 0) 2073 { 2074 bad = ffetarget_multiply_real2 (&l, l, l); 2075 if (bad != FFEBAD) 2076 return bad; 2077 r >>= 1; 2078 } 2079 2080 *res = l; 2081 r >>= 1; 2082 2083 while (r != 0) 2084 { 2085 bad = ffetarget_multiply_real2 (&l, l, l); 2086 if (bad != FFEBAD) 2087 return bad; 2088 if ((r & 1) == 1) 2089 { 2090 bad = ffetarget_multiply_real2 (res, *res, l); 2091 if (bad != FFEBAD) 2092 return bad; 2093 } 2094 r >>= 1; 2095 } 2096 2097 return FFEBAD; 2098} 2099 2100/* ffetarget_print_binary -- Output typeless binary integer 2101 2102 ffetargetTypeless val; 2103 ffetarget_typeless_binary(dmpout,val); */ 2104 2105void 2106ffetarget_print_binary (FILE *f, ffetargetTypeless value) 2107{ 2108 char *p; 2109 char digits[sizeof (value) * CHAR_BIT + 1]; 2110 2111 if (f == NULL) 2112 f = dmpout; 2113 2114 p = &digits[ARRAY_SIZE (digits) - 1]; 2115 *p = '\0'; 2116 do 2117 { 2118 *--p = (value & 1) + '0'; 2119 value >>= 1; 2120 } while (value == 0); 2121 2122 fputs (p, f); 2123} 2124 2125/* ffetarget_print_character1 -- Output character string 2126 2127 ffetargetCharacter1 val; 2128 ffetarget_print_character1(dmpout,val); */ 2129 2130void 2131ffetarget_print_character1 (FILE *f, ffetargetCharacter1 value) 2132{ 2133 unsigned char *p; 2134 ffetargetCharacterSize i; 2135 2136 fputc ('\'', dmpout); 2137 for (i = 0, p = value.text; i < value.length; ++i, ++p) 2138 ffetarget_print_char_ (f, *p); 2139 fputc ('\'', dmpout); 2140} 2141 2142/* ffetarget_print_hollerith -- Output hollerith string 2143 2144 ffetargetHollerith val; 2145 ffetarget_print_hollerith(dmpout,val); */ 2146 2147void 2148ffetarget_print_hollerith (FILE *f, ffetargetHollerith value) 2149{ 2150 unsigned char *p; 2151 ffetargetHollerithSize i; 2152 2153 fputc ('\'', dmpout); 2154 for (i = 0, p = value.text; i < value.length; ++i, ++p) 2155 ffetarget_print_char_ (f, *p); 2156 fputc ('\'', dmpout); 2157} 2158 2159/* ffetarget_print_octal -- Output typeless octal integer 2160 2161 ffetargetTypeless val; 2162 ffetarget_print_octal(dmpout,val); */ 2163 2164void 2165ffetarget_print_octal (FILE *f, ffetargetTypeless value) 2166{ 2167 char *p; 2168 char digits[sizeof (value) * CHAR_BIT / 3 + 1]; 2169 2170 if (f == NULL) 2171 f = dmpout; 2172 2173 p = &digits[ARRAY_SIZE (digits) - 3]; 2174 *p = '\0'; 2175 do 2176 { 2177 *--p = (value & 3) + '0'; 2178 value >>= 3; 2179 } while (value == 0); 2180 2181 fputs (p, f); 2182} 2183 2184/* ffetarget_print_hex -- Output typeless hex integer 2185 2186 ffetargetTypeless val; 2187 ffetarget_print_hex(dmpout,val); */ 2188 2189void 2190ffetarget_print_hex (FILE *f, ffetargetTypeless value) 2191{ 2192 char *p; 2193 char digits[sizeof (value) * CHAR_BIT / 4 + 1]; 2194 static const char hexdigits[16] = "0123456789ABCDEF"; 2195 2196 if (f == NULL) 2197 f = dmpout; 2198 2199 p = &digits[ARRAY_SIZE (digits) - 3]; 2200 *p = '\0'; 2201 do 2202 { 2203 *--p = hexdigits[value & 4]; 2204 value >>= 4; 2205 } while (value == 0); 2206 2207 fputs (p, f); 2208} 2209 2210/* ffetarget_real1 -- Convert token to a single-precision real number 2211 2212 See prototype. 2213 2214 Pass NULL for any token not provided by the user, but a valid Fortran 2215 real number must be provided somehow. For example, it is ok for 2216 exponent_sign_token and exponent_digits_token to be NULL as long as 2217 exponent_token not only starts with "E" or "e" but also contains at least 2218 one digit following it. Token use counts not affected overall. */ 2219 2220#if FFETARGET_okREAL1 2221bool 2222ffetarget_real1 (ffetargetReal1 *value, ffelexToken integer, 2223 ffelexToken decimal, ffelexToken fraction, 2224 ffelexToken exponent, ffelexToken exponent_sign, 2225 ffelexToken exponent_digits) 2226{ 2227 size_t sz = 1; /* Allow room for '\0' byte at end. */ 2228 char *ptr = &ffetarget_string_[0]; 2229 char *p = ptr; 2230 char *q; 2231 2232#define dotok(x) if (x != NULL) ++sz; 2233#define dotoktxt(x) if (x != NULL) sz += ffelex_token_length(x) 2234 2235 dotoktxt (integer); 2236 dotok (decimal); 2237 dotoktxt (fraction); 2238 dotoktxt (exponent); 2239 dotok (exponent_sign); 2240 dotoktxt (exponent_digits); 2241 2242#undef dotok 2243#undef dotoktxt 2244 2245 if (sz > ARRAY_SIZE (ffetarget_string_)) 2246 p = ptr = (char *) malloc_new_ks (malloc_pool_image (), "ffetarget_real1", 2247 sz); 2248 2249#define dotoktxt(x) if (x != NULL) \ 2250 { \ 2251 for (q = ffelex_token_text(x); *q != '\0'; ++q) \ 2252 *p++ = *q; \ 2253 } 2254 2255 dotoktxt (integer); 2256 2257 if (decimal != NULL) 2258 *p++ = '.'; 2259 2260 dotoktxt (fraction); 2261 dotoktxt (exponent); 2262 2263 if (exponent_sign != NULL) 2264 { 2265 if (ffelex_token_type (exponent_sign) == FFELEX_typePLUS) 2266 *p++ = '+'; 2267 else 2268 { 2269 assert (ffelex_token_type (exponent_sign) == FFELEX_typeMINUS); 2270 *p++ = '-'; 2271 } 2272 } 2273 2274 dotoktxt (exponent_digits); 2275 2276#undef dotoktxt 2277 2278 *p = '\0'; 2279 2280 { 2281 REAL_VALUE_TYPE rv; 2282 rv = FFETARGET_ATOF_ (ptr, SFmode); 2283 ffetarget_make_real1 (value, rv); 2284 } 2285 2286 if (sz > ARRAY_SIZE (ffetarget_string_)) 2287 malloc_kill_ks (malloc_pool_image (), ptr, sz); 2288 2289 return TRUE; 2290} 2291 2292#endif 2293/* ffetarget_real2 -- Convert token to a single-precision real number 2294 2295 See prototype. 2296 2297 Pass NULL for any token not provided by the user, but a valid Fortran 2298 real number must be provided somehow. For example, it is ok for 2299 exponent_sign_token and exponent_digits_token to be NULL as long as 2300 exponent_token not only starts with "E" or "e" but also contains at least 2301 one digit following it. Token use counts not affected overall. */ 2302 2303#if FFETARGET_okREAL2 2304bool 2305ffetarget_real2 (ffetargetReal2 *value, ffelexToken integer, 2306 ffelexToken decimal, ffelexToken fraction, 2307 ffelexToken exponent, ffelexToken exponent_sign, 2308 ffelexToken exponent_digits) 2309{ 2310 size_t sz = 1; /* Allow room for '\0' byte at end. */ 2311 char *ptr = &ffetarget_string_[0]; 2312 char *p = ptr; 2313 char *q; 2314 2315#define dotok(x) if (x != NULL) ++sz; 2316#define dotoktxt(x) if (x != NULL) sz += ffelex_token_length(x) 2317 2318 dotoktxt (integer); 2319 dotok (decimal); 2320 dotoktxt (fraction); 2321 dotoktxt (exponent); 2322 dotok (exponent_sign); 2323 dotoktxt (exponent_digits); 2324 2325#undef dotok 2326#undef dotoktxt 2327 2328 if (sz > ARRAY_SIZE (ffetarget_string_)) 2329 p = ptr = (char *) malloc_new_ks (malloc_pool_image (), "ffetarget_real1", sz); 2330 2331#define dotoktxt(x) if (x != NULL) \ 2332 { \ 2333 for (q = ffelex_token_text(x); *q != '\0'; ++q) \ 2334 *p++ = *q; \ 2335 } 2336#define dotoktxtexp(x) if (x != NULL) \ 2337 { \ 2338 *p++ = 'E'; \ 2339 for (q = ffelex_token_text(x) + 1; *q != '\0'; ++q) \ 2340 *p++ = *q; \ 2341 } 2342 2343 dotoktxt (integer); 2344 2345 if (decimal != NULL) 2346 *p++ = '.'; 2347 2348 dotoktxt (fraction); 2349 dotoktxtexp (exponent); 2350 2351 if (exponent_sign != NULL) 2352 { 2353 if (ffelex_token_type (exponent_sign) == FFELEX_typePLUS) 2354 *p++ = '+'; 2355 else 2356 { 2357 assert (ffelex_token_type (exponent_sign) == FFELEX_typeMINUS); 2358 *p++ = '-'; 2359 } 2360 } 2361 2362 dotoktxt (exponent_digits); 2363 2364#undef dotoktxt 2365 2366 *p = '\0'; 2367 2368 { 2369 REAL_VALUE_TYPE rv; 2370 rv = FFETARGET_ATOF_ (ptr, DFmode); 2371 ffetarget_make_real2 (value, rv); 2372 } 2373 2374 if (sz > ARRAY_SIZE (ffetarget_string_)) 2375 malloc_kill_ks (malloc_pool_image (), ptr, sz); 2376 2377 return TRUE; 2378} 2379 2380#endif 2381bool 2382ffetarget_typeless_binary (ffetargetTypeless *xvalue, ffelexToken token) 2383{ 2384 char *p; 2385 char c; 2386 ffetargetTypeless value = 0; 2387 ffetargetTypeless new_value = 0; 2388 bool bad_digit = FALSE; 2389 bool overflow = FALSE; 2390 2391 p = ffelex_token_text (token); 2392 2393 for (c = *p; c != '\0'; c = *++p) 2394 { 2395 new_value <<= 1; 2396 if ((new_value >> 1) != value) 2397 overflow = TRUE; 2398 if (ISDIGIT (c)) 2399 new_value += c - '0'; 2400 else 2401 bad_digit = TRUE; 2402 value = new_value; 2403 } 2404 2405 if (bad_digit) 2406 { 2407 ffebad_start (FFEBAD_INVALID_TYPELESS_BINARY_DIGIT); 2408 ffebad_here (0, ffelex_token_where_line (token), 2409 ffelex_token_where_column (token)); 2410 ffebad_finish (); 2411 } 2412 else if (overflow) 2413 { 2414 ffebad_start (FFEBAD_TYPELESS_OVERFLOW); 2415 ffebad_here (0, ffelex_token_where_line (token), 2416 ffelex_token_where_column (token)); 2417 ffebad_finish (); 2418 } 2419 2420 *xvalue = value; 2421 2422 return !bad_digit && !overflow; 2423} 2424 2425bool 2426ffetarget_typeless_octal (ffetargetTypeless *xvalue, ffelexToken token) 2427{ 2428 char *p; 2429 char c; 2430 ffetargetTypeless value = 0; 2431 ffetargetTypeless new_value = 0; 2432 bool bad_digit = FALSE; 2433 bool overflow = FALSE; 2434 2435 p = ffelex_token_text (token); 2436 2437 for (c = *p; c != '\0'; c = *++p) 2438 { 2439 new_value <<= 3; 2440 if ((new_value >> 3) != value) 2441 overflow = TRUE; 2442 if (ISDIGIT (c)) 2443 new_value += c - '0'; 2444 else 2445 bad_digit = TRUE; 2446 value = new_value; 2447 } 2448 2449 if (bad_digit) 2450 { 2451 ffebad_start (FFEBAD_INVALID_TYPELESS_OCTAL_DIGIT); 2452 ffebad_here (0, ffelex_token_where_line (token), 2453 ffelex_token_where_column (token)); 2454 ffebad_finish (); 2455 } 2456 else if (overflow) 2457 { 2458 ffebad_start (FFEBAD_TYPELESS_OVERFLOW); 2459 ffebad_here (0, ffelex_token_where_line (token), 2460 ffelex_token_where_column (token)); 2461 ffebad_finish (); 2462 } 2463 2464 *xvalue = value; 2465 2466 return !bad_digit && !overflow; 2467} 2468 2469bool 2470ffetarget_typeless_hex (ffetargetTypeless *xvalue, ffelexToken token) 2471{ 2472 char *p; 2473 char c; 2474 ffetargetTypeless value = 0; 2475 ffetargetTypeless new_value = 0; 2476 bool bad_digit = FALSE; 2477 bool overflow = FALSE; 2478 2479 p = ffelex_token_text (token); 2480 2481 for (c = *p; c != '\0'; c = *++p) 2482 { 2483 new_value <<= 4; 2484 if ((new_value >> 4) != value) 2485 overflow = TRUE; 2486 if (hex_p (c)) 2487 new_value += hex_value (c); 2488 else 2489 bad_digit = TRUE; 2490 value = new_value; 2491 } 2492 2493 if (bad_digit) 2494 { 2495 ffebad_start (FFEBAD_INVALID_TYPELESS_HEX_DIGIT); 2496 ffebad_here (0, ffelex_token_where_line (token), 2497 ffelex_token_where_column (token)); 2498 ffebad_finish (); 2499 } 2500 else if (overflow) 2501 { 2502 ffebad_start (FFEBAD_TYPELESS_OVERFLOW); 2503 ffebad_here (0, ffelex_token_where_line (token), 2504 ffelex_token_where_column (token)); 2505 ffebad_finish (); 2506 } 2507 2508 *xvalue = value; 2509 2510 return !bad_digit && !overflow; 2511} 2512 2513void 2514ffetarget_verify_character1 (mallocPool pool, ffetargetCharacter1 val) 2515{ 2516 if (val.length != 0) 2517 malloc_verify_kp (pool, val.text, val.length); 2518} 2519 2520/* This is like memcpy. It is needed because some systems' header files 2521 don't declare memcpy as a function but instead 2522 "#define memcpy(to,from,len) something". */ 2523 2524void * 2525ffetarget_memcpy_ (void *dst, void *src, size_t len) 2526{ 2527#ifdef CROSS_COMPILE 2528 /* HOST_WORDS_BIG_ENDIAN corresponds to both WORDS_BIG_ENDIAN and 2529 BYTES_BIG_ENDIAN (i.e. there are no HOST_ macros to represent a 2530 difference in the two latter). */ 2531 int host_words_big_endian = 2532#ifndef HOST_WORDS_BIG_ENDIAN 2533 0 2534#else 2535 HOST_WORDS_BIG_ENDIAN 2536#endif 2537 ; 2538 2539 /* This is just hands thrown up in the air over bits coming through this 2540 function representing a number being memcpy:d as-is from host to 2541 target. We can't generally adjust endianness here since we don't 2542 know whether it's an integer or floating point number; they're passed 2543 differently. Better to not emit code at all than to emit wrong code. 2544 We will get some false hits because some data coming through here 2545 seems to be just character vectors, but often enough it's numbers, 2546 for instance in g77.f-torture/execute/980628-[4-6].f and alpha2.f. 2547 Still, we compile *some* code. FIXME: Rewrite handling of numbers. */ 2548 if (!WORDS_BIG_ENDIAN != !host_words_big_endian 2549 || !BYTES_BIG_ENDIAN != !host_words_big_endian) 2550 sorry ("data initializer on host with different endianness"); 2551 2552#endif /* CROSS_COMPILE */ 2553 2554 return (void *) memcpy (dst, src, len); 2555} 2556 2557/* ffetarget_num_digits_ -- Determine number of non-space characters in token 2558 2559 ffetarget_num_digits_(token); 2560 2561 All non-spaces are assumed to be binary, octal, or hex digits. */ 2562 2563int 2564ffetarget_num_digits_ (ffelexToken token) 2565{ 2566 int i; 2567 char *c; 2568 2569 switch (ffelex_token_type (token)) 2570 { 2571 case FFELEX_typeNAME: 2572 case FFELEX_typeNUMBER: 2573 return ffelex_token_length (token); 2574 2575 case FFELEX_typeCHARACTER: 2576 i = 0; 2577 for (c = ffelex_token_text (token); *c != '\0'; ++c) 2578 { 2579 if (*c != ' ') 2580 ++i; 2581 } 2582 return i; 2583 2584 default: 2585 assert ("weird token" == NULL); 2586 return 1; 2587 } 2588} 2589