1/* bld.c -- Implementation File (module.c template V1.0) 2 Copyright (C) 1995, 1996 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 The primary "output" of the FFE includes ffebld objects, which 27 connect expressions, operators, and operands together, along with 28 connecting lists of expressions together for argument or dimension 29 lists. 30 31 Modifications: 32 30-Aug-92 JCB 1.1 33 Change names of some things for consistency. 34*/ 35 36/* Include files. */ 37 38#include "proj.h" 39#include "bld.h" 40#include "bit.h" 41#include "info.h" 42#include "lex.h" 43#include "malloc.h" 44#include "target.h" 45#include "where.h" 46 47/* Externals defined here. */ 48 49ffebldArity ffebld_arity_op_[] 50= 51{ 52#define FFEBLD_OP(KWD,NAME,ARITY) ARITY, 53#include "bld-op.def" 54#undef FFEBLD_OP 55}; 56struct _ffebld_pool_stack_ ffebld_pool_stack_; 57 58/* Simple definitions and enumerations. */ 59 60 61/* Internal typedefs. */ 62 63 64/* Private include files. */ 65 66 67/* Internal structure definitions. */ 68 69 70/* Static objects accessed by functions in this module. */ 71 72#if FFEBLD_BLANK_ 73static struct _ffebld_ ffebld_blank_ 74= 75{ 76 0, 77 {FFEINFO_basictypeNONE, FFEINFO_kindtypeNONE, 0, FFEINFO_kindNONE, 78 FFEINFO_whereNONE, FFETARGET_charactersizeNONE}, 79 {NULL, NULL} 80}; 81#endif 82#if FFETARGET_okCHARACTER1 83static ffebldConstant ffebld_constant_character1_; 84#endif 85#if FFETARGET_okCHARACTER2 86static ffebldConstant ffebld_constant_character2_; 87#endif 88#if FFETARGET_okCHARACTER3 89static ffebldConstant ffebld_constant_character3_; 90#endif 91#if FFETARGET_okCHARACTER4 92static ffebldConstant ffebld_constant_character4_; 93#endif 94#if FFETARGET_okCHARACTER5 95static ffebldConstant ffebld_constant_character5_; 96#endif 97#if FFETARGET_okCHARACTER6 98static ffebldConstant ffebld_constant_character6_; 99#endif 100#if FFETARGET_okCHARACTER7 101static ffebldConstant ffebld_constant_character7_; 102#endif 103#if FFETARGET_okCHARACTER8 104static ffebldConstant ffebld_constant_character8_; 105#endif 106#if FFETARGET_okCOMPLEX1 107static ffebldConstant ffebld_constant_complex1_; 108#endif 109#if FFETARGET_okCOMPLEX2 110static ffebldConstant ffebld_constant_complex2_; 111#endif 112#if FFETARGET_okCOMPLEX3 113static ffebldConstant ffebld_constant_complex3_; 114#endif 115#if FFETARGET_okCOMPLEX4 116static ffebldConstant ffebld_constant_complex4_; 117#endif 118#if FFETARGET_okCOMPLEX5 119static ffebldConstant ffebld_constant_complex5_; 120#endif 121#if FFETARGET_okCOMPLEX6 122static ffebldConstant ffebld_constant_complex6_; 123#endif 124#if FFETARGET_okCOMPLEX7 125static ffebldConstant ffebld_constant_complex7_; 126#endif 127#if FFETARGET_okCOMPLEX8 128static ffebldConstant ffebld_constant_complex8_; 129#endif 130#if FFETARGET_okINTEGER1 131static ffebldConstant ffebld_constant_integer1_; 132#endif 133#if FFETARGET_okINTEGER2 134static ffebldConstant ffebld_constant_integer2_; 135#endif 136#if FFETARGET_okINTEGER3 137static ffebldConstant ffebld_constant_integer3_; 138#endif 139#if FFETARGET_okINTEGER4 140static ffebldConstant ffebld_constant_integer4_; 141#endif 142#if FFETARGET_okINTEGER5 143static ffebldConstant ffebld_constant_integer5_; 144#endif 145#if FFETARGET_okINTEGER6 146static ffebldConstant ffebld_constant_integer6_; 147#endif 148#if FFETARGET_okINTEGER7 149static ffebldConstant ffebld_constant_integer7_; 150#endif 151#if FFETARGET_okINTEGER8 152static ffebldConstant ffebld_constant_integer8_; 153#endif 154#if FFETARGET_okLOGICAL1 155static ffebldConstant ffebld_constant_logical1_; 156#endif 157#if FFETARGET_okLOGICAL2 158static ffebldConstant ffebld_constant_logical2_; 159#endif 160#if FFETARGET_okLOGICAL3 161static ffebldConstant ffebld_constant_logical3_; 162#endif 163#if FFETARGET_okLOGICAL4 164static ffebldConstant ffebld_constant_logical4_; 165#endif 166#if FFETARGET_okLOGICAL5 167static ffebldConstant ffebld_constant_logical5_; 168#endif 169#if FFETARGET_okLOGICAL6 170static ffebldConstant ffebld_constant_logical6_; 171#endif 172#if FFETARGET_okLOGICAL7 173static ffebldConstant ffebld_constant_logical7_; 174#endif 175#if FFETARGET_okLOGICAL8 176static ffebldConstant ffebld_constant_logical8_; 177#endif 178#if FFETARGET_okREAL1 179static ffebldConstant ffebld_constant_real1_; 180#endif 181#if FFETARGET_okREAL2 182static ffebldConstant ffebld_constant_real2_; 183#endif 184#if FFETARGET_okREAL3 185static ffebldConstant ffebld_constant_real3_; 186#endif 187#if FFETARGET_okREAL4 188static ffebldConstant ffebld_constant_real4_; 189#endif 190#if FFETARGET_okREAL5 191static ffebldConstant ffebld_constant_real5_; 192#endif 193#if FFETARGET_okREAL6 194static ffebldConstant ffebld_constant_real6_; 195#endif 196#if FFETARGET_okREAL7 197static ffebldConstant ffebld_constant_real7_; 198#endif 199#if FFETARGET_okREAL8 200static ffebldConstant ffebld_constant_real8_; 201#endif 202static ffebldConstant ffebld_constant_hollerith_; 203static ffebldConstant ffebld_constant_typeless_[FFEBLD_constTYPELESS_LAST 204 - FFEBLD_constTYPELESS_FIRST + 1]; 205 206static const char *ffebld_op_string_[] 207= 208{ 209#define FFEBLD_OP(KWD,NAME,ARITY) NAME, 210#include "bld-op.def" 211#undef FFEBLD_OP 212}; 213 214/* Static functions (internal). */ 215 216 217/* Internal macros. */ 218 219#define integerdefault_ CATX(integer,FFETARGET_ktINTEGERDEFAULT) 220#define logicaldefault_ CATX(logical,FFETARGET_ktLOGICALDEFAULT) 221#define realdefault_ CATX(real,FFETARGET_ktREALDEFAULT) 222#define realdouble_ CATX(real,FFETARGET_ktREALDOUBLE) 223#define realquad_ CATX(real,FFETARGET_ktREALQUAD) 224 225/* ffebld_constant_cmp -- Compare two constants a la strcmp 226 227 ffebldConstant c1, c2; 228 if (ffebld_constant_cmp(c1,c2) == 0) 229 // they're equal, else they're not. 230 231 Returns -1 if c1 < c2, 0 if c1 == c2, +1 if c1 == c2. */ 232 233int 234ffebld_constant_cmp (ffebldConstant c1, ffebldConstant c2) 235{ 236 if (c1 == c2) 237 return 0; 238 239 assert (ffebld_constant_type (c1) == ffebld_constant_type (c2)); 240 241 switch (ffebld_constant_type (c1)) 242 { 243#if FFETARGET_okINTEGER1 244 case FFEBLD_constINTEGER1: 245 return ffetarget_cmp_integer1 (ffebld_constant_integer1 (c1), 246 ffebld_constant_integer1 (c2)); 247#endif 248 249#if FFETARGET_okINTEGER2 250 case FFEBLD_constINTEGER2: 251 return ffetarget_cmp_integer2 (ffebld_constant_integer2 (c1), 252 ffebld_constant_integer2 (c2)); 253#endif 254 255#if FFETARGET_okINTEGER3 256 case FFEBLD_constINTEGER3: 257 return ffetarget_cmp_integer3 (ffebld_constant_integer3 (c1), 258 ffebld_constant_integer3 (c2)); 259#endif 260 261#if FFETARGET_okINTEGER4 262 case FFEBLD_constINTEGER4: 263 return ffetarget_cmp_integer4 (ffebld_constant_integer4 (c1), 264 ffebld_constant_integer4 (c2)); 265#endif 266 267#if FFETARGET_okINTEGER5 268 case FFEBLD_constINTEGER5: 269 return ffetarget_cmp_integer5 (ffebld_constant_integer5 (c1), 270 ffebld_constant_integer5 (c2)); 271#endif 272 273#if FFETARGET_okINTEGER6 274 case FFEBLD_constINTEGER6: 275 return ffetarget_cmp_integer6 (ffebld_constant_integer6 (c1), 276 ffebld_constant_integer6 (c2)); 277#endif 278 279#if FFETARGET_okINTEGER7 280 case FFEBLD_constINTEGER7: 281 return ffetarget_cmp_integer7 (ffebld_constant_integer7 (c1), 282 ffebld_constant_integer7 (c2)); 283#endif 284 285#if FFETARGET_okINTEGER8 286 case FFEBLD_constINTEGER8: 287 return ffetarget_cmp_integer8 (ffebld_constant_integer8 (c1), 288 ffebld_constant_integer8 (c2)); 289#endif 290 291#if FFETARGET_okLOGICAL1 292 case FFEBLD_constLOGICAL1: 293 return ffetarget_cmp_logical1 (ffebld_constant_logical1 (c1), 294 ffebld_constant_logical1 (c2)); 295#endif 296 297#if FFETARGET_okLOGICAL2 298 case FFEBLD_constLOGICAL2: 299 return ffetarget_cmp_logical2 (ffebld_constant_logical2 (c1), 300 ffebld_constant_logical2 (c2)); 301#endif 302 303#if FFETARGET_okLOGICAL3 304 case FFEBLD_constLOGICAL3: 305 return ffetarget_cmp_logical3 (ffebld_constant_logical3 (c1), 306 ffebld_constant_logical3 (c2)); 307#endif 308 309#if FFETARGET_okLOGICAL4 310 case FFEBLD_constLOGICAL4: 311 return ffetarget_cmp_logical4 (ffebld_constant_logical4 (c1), 312 ffebld_constant_logical4 (c2)); 313#endif 314 315#if FFETARGET_okLOGICAL5 316 case FFEBLD_constLOGICAL5: 317 return ffetarget_cmp_logical5 (ffebld_constant_logical5 (c1), 318 ffebld_constant_logical5 (c2)); 319#endif 320 321#if FFETARGET_okLOGICAL6 322 case FFEBLD_constLOGICAL6: 323 return ffetarget_cmp_logical6 (ffebld_constant_logical6 (c1), 324 ffebld_constant_logical6 (c2)); 325#endif 326 327#if FFETARGET_okLOGICAL7 328 case FFEBLD_constLOGICAL7: 329 return ffetarget_cmp_logical7 (ffebld_constant_logical7 (c1), 330 ffebld_constant_logical7 (c2)); 331#endif 332 333#if FFETARGET_okLOGICAL8 334 case FFEBLD_constLOGICAL8: 335 return ffetarget_cmp_logical8 (ffebld_constant_logical8 (c1), 336 ffebld_constant_logical8 (c2)); 337#endif 338 339#if FFETARGET_okREAL1 340 case FFEBLD_constREAL1: 341 return ffetarget_cmp_real1 (ffebld_constant_real1 (c1), 342 ffebld_constant_real1 (c2)); 343#endif 344 345#if FFETARGET_okREAL2 346 case FFEBLD_constREAL2: 347 return ffetarget_cmp_real2 (ffebld_constant_real2 (c1), 348 ffebld_constant_real2 (c2)); 349#endif 350 351#if FFETARGET_okREAL3 352 case FFEBLD_constREAL3: 353 return ffetarget_cmp_real3 (ffebld_constant_real3 (c1), 354 ffebld_constant_real3 (c2)); 355#endif 356 357#if FFETARGET_okREAL4 358 case FFEBLD_constREAL4: 359 return ffetarget_cmp_real4 (ffebld_constant_real4 (c1), 360 ffebld_constant_real4 (c2)); 361#endif 362 363#if FFETARGET_okREAL5 364 case FFEBLD_constREAL5: 365 return ffetarget_cmp_real5 (ffebld_constant_real5 (c1), 366 ffebld_constant_real5 (c2)); 367#endif 368 369#if FFETARGET_okREAL6 370 case FFEBLD_constREAL6: 371 return ffetarget_cmp_real6 (ffebld_constant_real6 (c1), 372 ffebld_constant_real6 (c2)); 373#endif 374 375#if FFETARGET_okREAL7 376 case FFEBLD_constREAL7: 377 return ffetarget_cmp_real7 (ffebld_constant_real7 (c1), 378 ffebld_constant_real7 (c2)); 379#endif 380 381#if FFETARGET_okREAL8 382 case FFEBLD_constREAL8: 383 return ffetarget_cmp_real8 (ffebld_constant_real8 (c1), 384 ffebld_constant_real8 (c2)); 385#endif 386 387#if FFETARGET_okCHARACTER1 388 case FFEBLD_constCHARACTER1: 389 return ffetarget_cmp_character1 (ffebld_constant_character1 (c1), 390 ffebld_constant_character1 (c2)); 391#endif 392 393#if FFETARGET_okCHARACTER2 394 case FFEBLD_constCHARACTER2: 395 return ffetarget_cmp_character2 (ffebld_constant_character2 (c1), 396 ffebld_constant_character2 (c2)); 397#endif 398 399#if FFETARGET_okCHARACTER3 400 case FFEBLD_constCHARACTER3: 401 return ffetarget_cmp_character3 (ffebld_constant_character3 (c1), 402 ffebld_constant_character3 (c2)); 403#endif 404 405#if FFETARGET_okCHARACTER4 406 case FFEBLD_constCHARACTER4: 407 return ffetarget_cmp_character4 (ffebld_constant_character4 (c1), 408 ffebld_constant_character4 (c2)); 409#endif 410 411#if FFETARGET_okCHARACTER5 412 case FFEBLD_constCHARACTER5: 413 return ffetarget_cmp_character5 (ffebld_constant_character5 (c1), 414 ffebld_constant_character5 (c2)); 415#endif 416 417#if FFETARGET_okCHARACTER6 418 case FFEBLD_constCHARACTER6: 419 return ffetarget_cmp_character6 (ffebld_constant_character6 (c1), 420 ffebld_constant_character6 (c2)); 421#endif 422 423#if FFETARGET_okCHARACTER7 424 case FFEBLD_constCHARACTER7: 425 return ffetarget_cmp_character7 (ffebld_constant_character7 (c1), 426 ffebld_constant_character7 (c2)); 427#endif 428 429#if FFETARGET_okCHARACTER8 430 case FFEBLD_constCHARACTER8: 431 return ffetarget_cmp_character8 (ffebld_constant_character8 (c1), 432 ffebld_constant_character8 (c2)); 433#endif 434 435 default: 436 assert ("bad constant type" == NULL); 437 return 0; 438 } 439} 440 441/* ffebld_constant_dump -- Display summary of constant's contents 442 443 ffebldConstant c; 444 ffebld_constant_dump(c); 445 446 Displays the constant in summary form. */ 447 448#if FFECOM_targetCURRENT == FFECOM_targetFFE 449void 450ffebld_constant_dump (ffebldConstant c) 451{ 452 switch (ffebld_constant_type (c)) 453 { 454#if FFETARGET_okINTEGER1 455 case FFEBLD_constINTEGER1: 456 ffebld_dump_prefix (dmpout, FFEINFO_basictypeINTEGER, 457 FFEINFO_kindtypeINTEGER1); 458 ffebld_constantunion_dump (ffebld_constant_union (c), 459 FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER1); 460 break; 461#endif 462 463#if FFETARGET_okINTEGER2 464 case FFEBLD_constINTEGER2: 465 ffebld_dump_prefix (dmpout, FFEINFO_basictypeINTEGER, 466 FFEINFO_kindtypeINTEGER2); 467 ffebld_constantunion_dump (ffebld_constant_union (c), 468 FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER2); 469 break; 470#endif 471 472#if FFETARGET_okINTEGER3 473 case FFEBLD_constINTEGER3: 474 ffebld_dump_prefix (dmpout, FFEINFO_basictypeINTEGER, 475 FFEINFO_kindtypeINTEGER3); 476 ffebld_constantunion_dump (ffebld_constant_union (c), 477 FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER3); 478 break; 479#endif 480 481#if FFETARGET_okINTEGER4 482 case FFEBLD_constINTEGER4: 483 ffebld_dump_prefix (dmpout, FFEINFO_basictypeINTEGER, 484 FFEINFO_kindtypeINTEGER4); 485 ffebld_constantunion_dump (ffebld_constant_union (c), 486 FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER4); 487 break; 488#endif 489 490#if FFETARGET_okINTEGER5 491 case FFEBLD_constINTEGER5: 492 ffebld_dump_prefix (dmpout, FFEINFO_basictypeINTEGER, 493 FFEINFO_kindtypeINTEGER5); 494 ffebld_constantunion_dump (ffebld_constant_union (c), 495 FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER5); 496 break; 497#endif 498 499#if FFETARGET_okINTEGER6 500 case FFEBLD_constINTEGER6: 501 ffebld_dump_prefix (dmpout, FFEINFO_basictypeINTEGER, 502 FFEINFO_kindtypeINTEGER6); 503 ffebld_constantunion_dump (ffebld_constant_union (c), 504 FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER6); 505 break; 506#endif 507 508#if FFETARGET_okINTEGER7 509 case FFEBLD_constINTEGER7: 510 ffebld_dump_prefix (dmpout, FFEINFO_basictypeINTEGER, 511 FFEINFO_kindtypeINTEGER7); 512 ffebld_constantunion_dump (ffebld_constant_union (c), 513 FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER7); 514 break; 515#endif 516 517#if FFETARGET_okINTEGER8 518 case FFEBLD_constINTEGER8: 519 ffebld_dump_prefix (dmpout, FFEINFO_basictypeINTEGER, 520 FFEINFO_kindtypeINTEGER8); 521 ffebld_constantunion_dump (ffebld_constant_union (c), 522 FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER8); 523 break; 524#endif 525 526#if FFETARGET_okLOGICAL1 527 case FFEBLD_constLOGICAL1: 528 ffebld_dump_prefix (dmpout, FFEINFO_basictypeLOGICAL, 529 FFEINFO_kindtypeLOGICAL1); 530 ffebld_constantunion_dump (ffebld_constant_union (c), 531 FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL1); 532 break; 533#endif 534 535#if FFETARGET_okLOGICAL2 536 case FFEBLD_constLOGICAL2: 537 ffebld_dump_prefix (dmpout, FFEINFO_basictypeLOGICAL, 538 FFEINFO_kindtypeLOGICAL2); 539 ffebld_constantunion_dump (ffebld_constant_union (c), 540 FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL2); 541 break; 542#endif 543 544#if FFETARGET_okLOGICAL3 545 case FFEBLD_constLOGICAL3: 546 ffebld_dump_prefix (dmpout, FFEINFO_basictypeLOGICAL, 547 FFEINFO_kindtypeLOGICAL3); 548 ffebld_constantunion_dump (ffebld_constant_union (c), 549 FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL3); 550 break; 551#endif 552 553#if FFETARGET_okLOGICAL4 554 case FFEBLD_constLOGICAL4: 555 ffebld_dump_prefix (dmpout, FFEINFO_basictypeLOGICAL, 556 FFEINFO_kindtypeLOGICAL4); 557 ffebld_constantunion_dump (ffebld_constant_union (c), 558 FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL4); 559 break; 560#endif 561 562#if FFETARGET_okLOGICAL5 563 case FFEBLD_constLOGICAL5: 564 ffebld_dump_prefix (dmpout, FFEINFO_basictypeLOGICAL, 565 FFEINFO_kindtypeLOGICAL5); 566 ffebld_constantunion_dump (ffebld_constant_union (c), 567 FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL5); 568 break; 569#endif 570 571#if FFETARGET_okLOGICAL6 572 case FFEBLD_constLOGICAL6: 573 ffebld_dump_prefix (dmpout, FFEINFO_basictypeLOGICAL, 574 FFEINFO_kindtypeLOGICAL6); 575 ffebld_constantunion_dump (ffebld_constant_union (c), 576 FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL6); 577 break; 578#endif 579 580#if FFETARGET_okLOGICAL7 581 case FFEBLD_constLOGICAL7: 582 ffebld_dump_prefix (dmpout, FFEINFO_basictypeLOGICAL, 583 FFEINFO_kindtypeLOGICAL7); 584 ffebld_constantunion_dump (ffebld_constant_union (c), 585 FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL7); 586 break; 587#endif 588 589#if FFETARGET_okLOGICAL8 590 case FFEBLD_constLOGICAL8: 591 ffebld_dump_prefix (dmpout, FFEINFO_basictypeLOGICAL, 592 FFEINFO_kindtypeLOGICAL8); 593 ffebld_constantunion_dump (ffebld_constant_union (c), 594 FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL8); 595 break; 596#endif 597 598#if FFETARGET_okREAL1 599 case FFEBLD_constREAL1: 600 ffebld_dump_prefix (dmpout, FFEINFO_basictypeREAL, 601 FFEINFO_kindtypeREAL1); 602 ffebld_constantunion_dump (ffebld_constant_union (c), 603 FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL1); 604 break; 605#endif 606 607#if FFETARGET_okREAL2 608 case FFEBLD_constREAL2: 609 ffebld_dump_prefix (dmpout, FFEINFO_basictypeREAL, 610 FFEINFO_kindtypeREAL2); 611 ffebld_constantunion_dump (ffebld_constant_union (c), 612 FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL2); 613 break; 614#endif 615 616#if FFETARGET_okREAL3 617 case FFEBLD_constREAL3: 618 ffebld_dump_prefix (dmpout, FFEINFO_basictypeREAL, 619 FFEINFO_kindtypeREAL3); 620 ffebld_constantunion_dump (ffebld_constant_union (c), 621 FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL3); 622 break; 623#endif 624 625#if FFETARGET_okREAL4 626 case FFEBLD_constREAL4: 627 ffebld_dump_prefix (dmpout, FFEINFO_basictypeREAL, 628 FFEINFO_kindtypeREAL4); 629 ffebld_constantunion_dump (ffebld_constant_union (c), 630 FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL4); 631 break; 632#endif 633 634#if FFETARGET_okREAL5 635 case FFEBLD_constREAL5: 636 ffebld_dump_prefix (dmpout, FFEINFO_basictypeREAL, 637 FFEINFO_kindtypeREAL5); 638 ffebld_constantunion_dump (ffebld_constant_union (c), 639 FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL5); 640 break; 641#endif 642 643#if FFETARGET_okREAL6 644 case FFEBLD_constREAL6: 645 ffebld_dump_prefix (dmpout, FFEINFO_basictypeREAL, 646 FFEINFO_kindtypeREAL6); 647 ffebld_constantunion_dump (ffebld_constant_union (c), 648 FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL6); 649 break; 650#endif 651 652#if FFETARGET_okREAL7 653 case FFEBLD_constREAL7: 654 ffebld_dump_prefix (dmpout, FFEINFO_basictypeREAL, 655 FFEINFO_kindtypeREAL7); 656 ffebld_constantunion_dump (ffebld_constant_union (c), 657 FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL7); 658 break; 659#endif 660 661#if FFETARGET_okREAL8 662 case FFEBLD_constREAL8: 663 ffebld_dump_prefix (dmpout, FFEINFO_basictypeREAL, 664 FFEINFO_kindtypeREAL8); 665 ffebld_constantunion_dump (ffebld_constant_union (c), 666 FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL8); 667 break; 668#endif 669 670#if FFETARGET_okCOMPLEX1 671 case FFEBLD_constCOMPLEX1: 672 ffebld_dump_prefix (dmpout, FFEINFO_basictypeCOMPLEX, 673 FFEINFO_kindtypeREAL1); 674 ffebld_constantunion_dump (ffebld_constant_union (c), 675 FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL1); 676 break; 677#endif 678 679#if FFETARGET_okCOMPLEX2 680 case FFEBLD_constCOMPLEX2: 681 ffebld_dump_prefix (dmpout, FFEINFO_basictypeCOMPLEX, 682 FFEINFO_kindtypeREAL2); 683 ffebld_constantunion_dump (ffebld_constant_union (c), 684 FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL2); 685 break; 686#endif 687 688#if FFETARGET_okCOMPLEX3 689 case FFEBLD_constCOMPLEX3: 690 ffebld_dump_prefix (dmpout, FFEINFO_basictypeCOMPLEX, 691 FFEINFO_kindtypeREAL3); 692 ffebld_constantunion_dump (ffebld_constant_union (c), 693 FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL3); 694 break; 695#endif 696 697#if FFETARGET_okCOMPLEX4 698 case FFEBLD_constCOMPLEX4: 699 ffebld_dump_prefix (dmpout, FFEINFO_basictypeCOMPLEX, 700 FFEINFO_kindtypeREAL4); 701 ffebld_constantunion_dump (ffebld_constant_union (c), 702 FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL4); 703 break; 704#endif 705 706#if FFETARGET_okCOMPLEX5 707 case FFEBLD_constCOMPLEX5: 708 ffebld_dump_prefix (dmpout, FFEINFO_basictypeCOMPLEX, 709 FFEINFO_kindtypeREAL5); 710 ffebld_constantunion_dump (ffebld_constant_union (c), 711 FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL5); 712 break; 713#endif 714 715#if FFETARGET_okCOMPLEX6 716 case FFEBLD_constCOMPLEX6: 717 ffebld_dump_prefix (dmpout, FFEINFO_basictypeCOMPLEX, 718 FFEINFO_kindtypeREAL6); 719 ffebld_constantunion_dump (ffebld_constant_union (c), 720 FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL6); 721 break; 722#endif 723 724#if FFETARGET_okCOMPLEX7 725 case FFEBLD_constCOMPLEX7: 726 ffebld_dump_prefix (dmpout, FFEINFO_basictypeCOMPLEX, 727 FFEINFO_kindtypeREAL7); 728 ffebld_constantunion_dump (ffebld_constant_union (c), 729 FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL7); 730 break; 731#endif 732 733#if FFETARGET_okCOMPLEX8 734 case FFEBLD_constCOMPLEX8: 735 ffebld_dump_prefix (dmpout, FFEINFO_basictypeCOMPLEX, 736 FFEINFO_kindtypeREAL8); 737 ffebld_constantunion_dump (ffebld_constant_union (c), 738 FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL8); 739 break; 740#endif 741 742#if FFETARGET_okCHARACTER1 743 case FFEBLD_constCHARACTER1: 744 ffebld_dump_prefix (dmpout, FFEINFO_basictypeCHARACTER, 745 FFEINFO_kindtypeCHARACTER1); 746 ffebld_constantunion_dump (ffebld_constant_union (c), 747 FFEINFO_basictypeCHARACTER, FFEINFO_kindtypeCHARACTER1); 748 break; 749#endif 750 751#if FFETARGET_okCHARACTER2 752 case FFEBLD_constCHARACTER2: 753 ffebld_dump_prefix (dmpout, FFEINFO_basictypeCHARACTER, 754 FFEINFO_kindtypeCHARACTER2); 755 ffebld_constantunion_dump (ffebld_constant_union (c), 756 FFEINFO_basictypeCHARACTER, FFEINFO_kindtypeCHARACTER2); 757 break; 758#endif 759 760#if FFETARGET_okCHARACTER3 761 case FFEBLD_constCHARACTER3: 762 ffebld_dump_prefix (dmpout, FFEINFO_basictypeCHARACTER, 763 FFEINFO_kindtypeCHARACTER3); 764 ffebld_constantunion_dump (ffebld_constant_union (c), 765 FFEINFO_basictypeCHARACTER, FFEINFO_kindtypeCHARACTER3); 766 break; 767#endif 768 769#if FFETARGET_okCHARACTER4 770 case FFEBLD_constCHARACTER4: 771 ffebld_dump_prefix (dmpout, FFEINFO_basictypeCHARACTER, 772 FFEINFO_kindtypeCHARACTER4); 773 ffebld_constantunion_dump (ffebld_constant_union (c), 774 FFEINFO_basictypeCHARACTER, FFEINFO_kindtypeCHARACTER4); 775 break; 776#endif 777 778#if FFETARGET_okCHARACTER5 779 case FFEBLD_constCHARACTER5: 780 ffebld_dump_prefix (dmpout, FFEINFO_basictypeCHARACTER, 781 FFEINFO_kindtypeCHARACTER5); 782 ffebld_constantunion_dump (ffebld_constant_union (c), 783 FFEINFO_basictypeCHARACTER, FFEINFO_kindtypeCHARACTER5); 784 break; 785#endif 786 787#if FFETARGET_okCHARACTER6 788 case FFEBLD_constCHARACTER6: 789 ffebld_dump_prefix (dmpout, FFEINFO_basictypeCHARACTER, 790 FFEINFO_kindtypeCHARACTER6); 791 ffebld_constantunion_dump (ffebld_constant_union (c), 792 FFEINFO_basictypeCHARACTER, FFEINFO_kindtypeCHARACTER6); 793 break; 794#endif 795 796#if FFETARGET_okCHARACTER7 797 case FFEBLD_constCHARACTER7: 798 ffebld_dump_prefix (dmpout, FFEINFO_basictypeCHARACTER, 799 FFEINFO_kindtypeCHARACTER7); 800 ffebld_constantunion_dump (ffebld_constant_union (c), 801 FFEINFO_basictypeCHARACTER, FFEINFO_kindtypeCHARACTER7); 802 break; 803#endif 804 805#if FFETARGET_okCHARACTER8 806 case FFEBLD_constCHARACTER8: 807 ffebld_dump_prefix (dmpout, FFEINFO_basictypeCHARACTER, 808 FFEINFO_kindtypeCHARACTER8); 809 ffebld_constantunion_dump (ffebld_constant_union (c), 810 FFEINFO_basictypeCHARACTER, FFEINFO_kindtypeCHARACTER8); 811 break; 812#endif 813 814 case FFEBLD_constHOLLERITH: 815 fprintf (dmpout, "H%" ffetargetHollerithSize_f "u/", 816 ffebld_constant_hollerith (c).length); 817 ffetarget_print_hollerith (dmpout, ffebld_constant_hollerith (c)); 818 break; 819 820 case FFEBLD_constBINARY_MIL: 821 fprintf (dmpout, "BM/"); 822 ffetarget_print_binarymil (dmpout, ffebld_constant_typeless (c)); 823 break; 824 825 case FFEBLD_constBINARY_VXT: 826 fprintf (dmpout, "BV/"); 827 ffetarget_print_binaryvxt (dmpout, ffebld_constant_typeless (c)); 828 break; 829 830 case FFEBLD_constOCTAL_MIL: 831 fprintf (dmpout, "OM/"); 832 ffetarget_print_octalmil (dmpout, ffebld_constant_typeless (c)); 833 break; 834 835 case FFEBLD_constOCTAL_VXT: 836 fprintf (dmpout, "OV/"); 837 ffetarget_print_octalvxt (dmpout, ffebld_constant_typeless (c)); 838 break; 839 840 case FFEBLD_constHEX_X_MIL: 841 fprintf (dmpout, "XM/"); 842 ffetarget_print_hexxmil (dmpout, ffebld_constant_typeless (c)); 843 break; 844 845 case FFEBLD_constHEX_X_VXT: 846 fprintf (dmpout, "XV/"); 847 ffetarget_print_hexxvxt (dmpout, ffebld_constant_typeless (c)); 848 break; 849 850 case FFEBLD_constHEX_Z_MIL: 851 fprintf (dmpout, "ZM/"); 852 ffetarget_print_hexzmil (dmpout, ffebld_constant_typeless (c)); 853 break; 854 855 case FFEBLD_constHEX_Z_VXT: 856 fprintf (dmpout, "ZV/"); 857 ffetarget_print_hexzvxt (dmpout, ffebld_constant_typeless (c)); 858 break; 859 860 default: 861 assert ("bad constant type" == NULL); 862 fprintf (dmpout, "?/?"); 863 break; 864 } 865} 866#endif 867 868/* ffebld_constant_is_magical -- Determine if integer is "magical" 869 870 ffebldConstant c; 871 if (ffebld_constant_is_magical(c)) 872 // it is 2**(n-1), where n is # bits in ffetargetIntegerDefault type 873 // (this test is important for 2's-complement machines only). */ 874 875bool 876ffebld_constant_is_magical (ffebldConstant c) 877{ 878 switch (ffebld_constant_type (c)) 879 { 880 case FFEBLD_constINTEGERDEFAULT: 881 return ffetarget_integerdefault_is_magical (ffebld_constant_integer1 (c)); 882 883 default: 884 return FALSE; 885 } 886} 887 888/* Determine if constant is zero. Used to ensure step count 889 for DO loops isn't zero, also to determine if values will 890 be binary zeros, so not entirely portable at this point. */ 891 892bool 893ffebld_constant_is_zero (ffebldConstant c) 894{ 895 switch (ffebld_constant_type (c)) 896 { 897#if FFETARGET_okINTEGER1 898 case FFEBLD_constINTEGER1: 899 return ffebld_constant_integer1 (c) == 0; 900#endif 901 902#if FFETARGET_okINTEGER2 903 case FFEBLD_constINTEGER2: 904 return ffebld_constant_integer2 (c) == 0; 905#endif 906 907#if FFETARGET_okINTEGER3 908 case FFEBLD_constINTEGER3: 909 return ffebld_constant_integer3 (c) == 0; 910#endif 911 912#if FFETARGET_okINTEGER4 913 case FFEBLD_constINTEGER4: 914 return ffebld_constant_integer4 (c) == 0; 915#endif 916 917#if FFETARGET_okINTEGER5 918 case FFEBLD_constINTEGER5: 919 return ffebld_constant_integer5 (c) == 0; 920#endif 921 922#if FFETARGET_okINTEGER6 923 case FFEBLD_constINTEGER6: 924 return ffebld_constant_integer6 (c) == 0; 925#endif 926 927#if FFETARGET_okINTEGER7 928 case FFEBLD_constINTEGER7: 929 return ffebld_constant_integer7 (c) == 0; 930#endif 931 932#if FFETARGET_okINTEGER8 933 case FFEBLD_constINTEGER8: 934 return ffebld_constant_integer8 (c) == 0; 935#endif 936 937#if FFETARGET_okLOGICAL1 938 case FFEBLD_constLOGICAL1: 939 return ffebld_constant_logical1 (c) == 0; 940#endif 941 942#if FFETARGET_okLOGICAL2 943 case FFEBLD_constLOGICAL2: 944 return ffebld_constant_logical2 (c) == 0; 945#endif 946 947#if FFETARGET_okLOGICAL3 948 case FFEBLD_constLOGICAL3: 949 return ffebld_constant_logical3 (c) == 0; 950#endif 951 952#if FFETARGET_okLOGICAL4 953 case FFEBLD_constLOGICAL4: 954 return ffebld_constant_logical4 (c) == 0; 955#endif 956 957#if FFETARGET_okLOGICAL5 958 case FFEBLD_constLOGICAL5: 959 return ffebld_constant_logical5 (c) == 0; 960#endif 961 962#if FFETARGET_okLOGICAL6 963 case FFEBLD_constLOGICAL6: 964 return ffebld_constant_logical6 (c) == 0; 965#endif 966 967#if FFETARGET_okLOGICAL7 968 case FFEBLD_constLOGICAL7: 969 return ffebld_constant_logical7 (c) == 0; 970#endif 971 972#if FFETARGET_okLOGICAL8 973 case FFEBLD_constLOGICAL8: 974 return ffebld_constant_logical8 (c) == 0; 975#endif 976 977#if FFETARGET_okREAL1 978 case FFEBLD_constREAL1: 979 return ffetarget_iszero_real1 (ffebld_constant_real1 (c)); 980#endif 981 982#if FFETARGET_okREAL2 983 case FFEBLD_constREAL2: 984 return ffetarget_iszero_real2 (ffebld_constant_real2 (c)); 985#endif 986 987#if FFETARGET_okREAL3 988 case FFEBLD_constREAL3: 989 return ffetarget_iszero_real3 (ffebld_constant_real3 (c)); 990#endif 991 992#if FFETARGET_okREAL4 993 case FFEBLD_constREAL4: 994 return ffetarget_iszero_real4 (ffebld_constant_real4 (c)); 995#endif 996 997#if FFETARGET_okREAL5 998 case FFEBLD_constREAL5: 999 return ffetarget_iszero_real5 (ffebld_constant_real5 (c)); 1000#endif 1001 1002#if FFETARGET_okREAL6 1003 case FFEBLD_constREAL6: 1004 return ffetarget_iszero_real6 (ffebld_constant_real6 (c)); 1005#endif 1006 1007#if FFETARGET_okREAL7 1008 case FFEBLD_constREAL7: 1009 return ffetarget_iszero_real7 (ffebld_constant_real7 (c)); 1010#endif 1011 1012#if FFETARGET_okREAL8 1013 case FFEBLD_constREAL8: 1014 return ffetarget_iszero_real8 (ffebld_constant_real8 (c)); 1015#endif 1016 1017#if FFETARGET_okCOMPLEX1 1018 case FFEBLD_constCOMPLEX1: 1019 return ffetarget_iszero_real1 (ffebld_constant_complex1 (c).real) 1020 && ffetarget_iszero_real1 (ffebld_constant_complex1 (c).imaginary); 1021#endif 1022 1023#if FFETARGET_okCOMPLEX2 1024 case FFEBLD_constCOMPLEX2: 1025 return ffetarget_iszero_real2 (ffebld_constant_complex2 (c).real) 1026 && ffetarget_iszero_real2 (ffebld_constant_complex2 (c).imaginary); 1027#endif 1028 1029#if FFETARGET_okCOMPLEX3 1030 case FFEBLD_constCOMPLEX3: 1031 return ffetarget_iszero_real3 (ffebld_constant_complex3 (c).real) 1032 && ffetarget_iszero_real3 (ffebld_constant_complex3 (c).imaginary); 1033#endif 1034 1035#if FFETARGET_okCOMPLEX4 1036 case FFEBLD_constCOMPLEX4: 1037 return ffetarget_iszero_real4 (ffebld_constant_complex4 (c).real) 1038 && ffetarget_iszero_real4 (ffebld_constant_complex4 (c).imaginary); 1039#endif 1040 1041#if FFETARGET_okCOMPLEX5 1042 case FFEBLD_constCOMPLEX5: 1043 return ffetarget_iszero_real5 (ffebld_constant_complex5 (c).real) 1044 && ffetarget_iszero_real5 (ffebld_constant_complex5 (c).imaginary); 1045#endif 1046 1047#if FFETARGET_okCOMPLEX6 1048 case FFEBLD_constCOMPLEX6: 1049 return ffetarget_iszero_real6 (ffebld_constant_complex6 (c).real) 1050 && ffetarget_iszero_real6 (ffebld_constant_complex6 (c).imaginary); 1051#endif 1052 1053#if FFETARGET_okCOMPLEX7 1054 case FFEBLD_constCOMPLEX7: 1055 return ffetarget_iszero_real7 (ffebld_constant_complex7 (c).real) 1056 && ffetarget_iszero_real7 (ffebld_constant_complex7 (c).imaginary); 1057#endif 1058 1059#if FFETARGET_okCOMPLEX8 1060 case FFEBLD_constCOMPLEX8: 1061 return ffetarget_iszero_real8 (ffebld_constant_complex8 (c).real) 1062 && ffetarget_iszero_real8 (ffebld_constant_complex8 (c).imaginary); 1063#endif 1064 1065#if FFETARGET_okCHARACTER1 1066 case FFEBLD_constCHARACTER1: 1067 return ffetarget_iszero_character1 (ffebld_constant_character1 (c)); 1068#endif 1069 1070#if FFETARGET_okCHARACTER2 || FFETARGET_okCHARACTER3 /* ... */ 1071#error "no support for these!!" 1072#endif 1073 1074 case FFEBLD_constHOLLERITH: 1075 return ffetarget_iszero_hollerith (ffebld_constant_hollerith (c)); 1076 1077 case FFEBLD_constBINARY_MIL: 1078 case FFEBLD_constBINARY_VXT: 1079 case FFEBLD_constOCTAL_MIL: 1080 case FFEBLD_constOCTAL_VXT: 1081 case FFEBLD_constHEX_X_MIL: 1082 case FFEBLD_constHEX_X_VXT: 1083 case FFEBLD_constHEX_Z_MIL: 1084 case FFEBLD_constHEX_Z_VXT: 1085 return ffetarget_iszero_typeless (ffebld_constant_typeless (c)); 1086 1087 default: 1088 return FALSE; 1089 } 1090} 1091 1092/* ffebld_constant_new_character1 -- Return character1 constant object from token 1093 1094 See prototype. */ 1095 1096#if FFETARGET_okCHARACTER1 1097ffebldConstant 1098ffebld_constant_new_character1 (ffelexToken t) 1099{ 1100 ffetargetCharacter1 val; 1101 1102 ffetarget_character1 (&val, t, ffebld_constant_pool()); 1103 return ffebld_constant_new_character1_val (val); 1104} 1105 1106#endif 1107/* ffebld_constant_new_character1_val -- Return an character1 constant object 1108 1109 See prototype. */ 1110 1111#if FFETARGET_okCHARACTER1 1112ffebldConstant 1113ffebld_constant_new_character1_val (ffetargetCharacter1 val) 1114{ 1115 ffebldConstant c; 1116 ffebldConstant nc; 1117 int cmp; 1118 1119 ffetarget_verify_character1 (ffebld_constant_pool(), val); 1120 1121 for (c = (ffebldConstant) &ffebld_constant_character1_; 1122 c->next != NULL; 1123 c = c->next) 1124 { 1125 malloc_verify_kp (ffebld_constant_pool(), 1126 c->next, 1127 sizeof (*(c->next))); 1128 ffetarget_verify_character1 (ffebld_constant_pool(), 1129 ffebld_constant_character1 (c->next)); 1130 cmp = ffetarget_cmp_character1 (val, 1131 ffebld_constant_character1 (c->next)); 1132 if (cmp == 0) 1133 return c->next; 1134 if (cmp > 0) 1135 break; 1136 } 1137 1138 nc = malloc_new_kp (ffebld_constant_pool(), 1139 "FFEBLD_constCHARACTER1", 1140 sizeof (*nc)); 1141 nc->next = c->next; 1142 nc->consttype = FFEBLD_constCHARACTER1; 1143 nc->u.character1 = val; 1144#ifdef FFECOM_constantHOOK 1145 nc->hook = FFECOM_constantNULL; 1146#endif 1147 c->next = nc; 1148 1149 return nc; 1150} 1151 1152#endif 1153/* ffebld_constant_new_complex1 -- Return complex1 constant object from token 1154 1155 See prototype. */ 1156 1157#if FFETARGET_okCOMPLEX1 1158ffebldConstant 1159ffebld_constant_new_complex1 (ffebldConstant real, 1160 ffebldConstant imaginary) 1161{ 1162 ffetargetComplex1 val; 1163 1164 val.real = ffebld_constant_real1 (real); 1165 val.imaginary = ffebld_constant_real1 (imaginary); 1166 return ffebld_constant_new_complex1_val (val); 1167} 1168 1169#endif 1170/* ffebld_constant_new_complex1_val -- Return a complex1 constant object 1171 1172 See prototype. */ 1173 1174#if FFETARGET_okCOMPLEX1 1175ffebldConstant 1176ffebld_constant_new_complex1_val (ffetargetComplex1 val) 1177{ 1178 ffebldConstant c; 1179 ffebldConstant nc; 1180 int cmp; 1181 1182 for (c = (ffebldConstant) &ffebld_constant_complex1_; 1183 c->next != NULL; 1184 c = c->next) 1185 { 1186 cmp = ffetarget_cmp_real1 (val.real, ffebld_constant_complex1 (c->next).real); 1187 if (cmp == 0) 1188 cmp = ffetarget_cmp_real1 (val.imaginary, 1189 ffebld_constant_complex1 (c->next).imaginary); 1190 if (cmp == 0) 1191 return c->next; 1192 if (cmp > 0) 1193 break; 1194 } 1195 1196 nc = malloc_new_kp (ffebld_constant_pool(), 1197 "FFEBLD_constCOMPLEX1", 1198 sizeof (*nc)); 1199 nc->next = c->next; 1200 nc->consttype = FFEBLD_constCOMPLEX1; 1201 nc->u.complex1 = val; 1202#ifdef FFECOM_constantHOOK 1203 nc->hook = FFECOM_constantNULL; 1204#endif 1205 c->next = nc; 1206 1207 return nc; 1208} 1209 1210#endif 1211/* ffebld_constant_new_complex2 -- Return complex2 constant object from token 1212 1213 See prototype. */ 1214 1215#if FFETARGET_okCOMPLEX2 1216ffebldConstant 1217ffebld_constant_new_complex2 (ffebldConstant real, 1218 ffebldConstant imaginary) 1219{ 1220 ffetargetComplex2 val; 1221 1222 val.real = ffebld_constant_real2 (real); 1223 val.imaginary = ffebld_constant_real2 (imaginary); 1224 return ffebld_constant_new_complex2_val (val); 1225} 1226 1227#endif 1228/* ffebld_constant_new_complex2_val -- Return a complex2 constant object 1229 1230 See prototype. */ 1231 1232#if FFETARGET_okCOMPLEX2 1233ffebldConstant 1234ffebld_constant_new_complex2_val (ffetargetComplex2 val) 1235{ 1236 ffebldConstant c; 1237 ffebldConstant nc; 1238 int cmp; 1239 1240 for (c = (ffebldConstant) &ffebld_constant_complex2_; 1241 c->next != NULL; 1242 c = c->next) 1243 { 1244 cmp = ffetarget_cmp_real2 (val.real, ffebld_constant_complex2 (c->next).real); 1245 if (cmp == 0) 1246 cmp = ffetarget_cmp_real2 (val.imaginary, 1247 ffebld_constant_complex2 (c->next).imaginary); 1248 if (cmp == 0) 1249 return c->next; 1250 if (cmp > 0) 1251 break; 1252 } 1253 1254 nc = malloc_new_kp (ffebld_constant_pool(), 1255 "FFEBLD_constCOMPLEX2", 1256 sizeof (*nc)); 1257 nc->next = c->next; 1258 nc->consttype = FFEBLD_constCOMPLEX2; 1259 nc->u.complex2 = val; 1260#ifdef FFECOM_constantHOOK 1261 nc->hook = FFECOM_constantNULL; 1262#endif 1263 c->next = nc; 1264 1265 return nc; 1266} 1267 1268#endif 1269/* ffebld_constant_new_hollerith -- Return hollerith constant object from token 1270 1271 See prototype. */ 1272 1273ffebldConstant 1274ffebld_constant_new_hollerith (ffelexToken t) 1275{ 1276 ffetargetHollerith val; 1277 1278 ffetarget_hollerith (&val, t, ffebld_constant_pool()); 1279 return ffebld_constant_new_hollerith_val (val); 1280} 1281 1282/* ffebld_constant_new_hollerith_val -- Return an hollerith constant object 1283 1284 See prototype. */ 1285 1286ffebldConstant 1287ffebld_constant_new_hollerith_val (ffetargetHollerith val) 1288{ 1289 ffebldConstant c; 1290 ffebldConstant nc; 1291 int cmp; 1292 1293 for (c = (ffebldConstant) &ffebld_constant_hollerith_; 1294 c->next != NULL; 1295 c = c->next) 1296 { 1297 cmp = ffetarget_cmp_hollerith (val, ffebld_constant_hollerith (c->next)); 1298 if (cmp == 0) 1299 return c->next; 1300 if (cmp > 0) 1301 break; 1302 } 1303 1304 nc = malloc_new_kp (ffebld_constant_pool(), 1305 "FFEBLD_constHOLLERITH", 1306 sizeof (*nc)); 1307 nc->next = c->next; 1308 nc->consttype = FFEBLD_constHOLLERITH; 1309 nc->u.hollerith = val; 1310#ifdef FFECOM_constantHOOK 1311 nc->hook = FFECOM_constantNULL; 1312#endif 1313 c->next = nc; 1314 1315 return nc; 1316} 1317 1318/* ffebld_constant_new_integer1 -- Return integer1 constant object from token 1319 1320 See prototype. 1321 1322 Parses the token as a decimal integer constant, thus it must be an 1323 FFELEX_typeNUMBER. */ 1324 1325#if FFETARGET_okINTEGER1 1326ffebldConstant 1327ffebld_constant_new_integer1 (ffelexToken t) 1328{ 1329 ffetargetInteger1 val; 1330 1331 assert (ffelex_token_type (t) == FFELEX_typeNUMBER); 1332 1333 ffetarget_integer1 (&val, t); 1334 return ffebld_constant_new_integer1_val (val); 1335} 1336 1337#endif 1338/* ffebld_constant_new_integer1_val -- Return an integer1 constant object 1339 1340 See prototype. */ 1341 1342#if FFETARGET_okINTEGER1 1343ffebldConstant 1344ffebld_constant_new_integer1_val (ffetargetInteger1 val) 1345{ 1346 ffebldConstant c; 1347 ffebldConstant nc; 1348 int cmp; 1349 1350 for (c = (ffebldConstant) &ffebld_constant_integer1_; 1351 c->next != NULL; 1352 c = c->next) 1353 { 1354 cmp = ffetarget_cmp_integer1 (val, ffebld_constant_integer1 (c->next)); 1355 if (cmp == 0) 1356 return c->next; 1357 if (cmp > 0) 1358 break; 1359 } 1360 1361 nc = malloc_new_kp (ffebld_constant_pool(), 1362 "FFEBLD_constINTEGER1", 1363 sizeof (*nc)); 1364 nc->next = c->next; 1365 nc->consttype = FFEBLD_constINTEGER1; 1366 nc->u.integer1 = val; 1367#ifdef FFECOM_constantHOOK 1368 nc->hook = FFECOM_constantNULL; 1369#endif 1370 c->next = nc; 1371 1372 return nc; 1373} 1374 1375#endif 1376/* ffebld_constant_new_integer2_val -- Return an integer2 constant object 1377 1378 See prototype. */ 1379 1380#if FFETARGET_okINTEGER2 1381ffebldConstant 1382ffebld_constant_new_integer2_val (ffetargetInteger2 val) 1383{ 1384 ffebldConstant c; 1385 ffebldConstant nc; 1386 int cmp; 1387 1388 for (c = (ffebldConstant) &ffebld_constant_integer2_; 1389 c->next != NULL; 1390 c = c->next) 1391 { 1392 cmp = ffetarget_cmp_integer2 (val, ffebld_constant_integer2 (c->next)); 1393 if (cmp == 0) 1394 return c->next; 1395 if (cmp > 0) 1396 break; 1397 } 1398 1399 nc = malloc_new_kp (ffebld_constant_pool(), 1400 "FFEBLD_constINTEGER2", 1401 sizeof (*nc)); 1402 nc->next = c->next; 1403 nc->consttype = FFEBLD_constINTEGER2; 1404 nc->u.integer2 = val; 1405#ifdef FFECOM_constantHOOK 1406 nc->hook = FFECOM_constantNULL; 1407#endif 1408 c->next = nc; 1409 1410 return nc; 1411} 1412 1413#endif 1414/* ffebld_constant_new_integer3_val -- Return an integer3 constant object 1415 1416 See prototype. */ 1417 1418#if FFETARGET_okINTEGER3 1419ffebldConstant 1420ffebld_constant_new_integer3_val (ffetargetInteger3 val) 1421{ 1422 ffebldConstant c; 1423 ffebldConstant nc; 1424 int cmp; 1425 1426 for (c = (ffebldConstant) &ffebld_constant_integer3_; 1427 c->next != NULL; 1428 c = c->next) 1429 { 1430 cmp = ffetarget_cmp_integer3 (val, ffebld_constant_integer3 (c->next)); 1431 if (cmp == 0) 1432 return c->next; 1433 if (cmp > 0) 1434 break; 1435 } 1436 1437 nc = malloc_new_kp (ffebld_constant_pool(), 1438 "FFEBLD_constINTEGER3", 1439 sizeof (*nc)); 1440 nc->next = c->next; 1441 nc->consttype = FFEBLD_constINTEGER3; 1442 nc->u.integer3 = val; 1443#ifdef FFECOM_constantHOOK 1444 nc->hook = FFECOM_constantNULL; 1445#endif 1446 c->next = nc; 1447 1448 return nc; 1449} 1450 1451#endif 1452/* ffebld_constant_new_integer4_val -- Return an integer4 constant object 1453 1454 See prototype. */ 1455 1456#if FFETARGET_okINTEGER4 1457ffebldConstant 1458ffebld_constant_new_integer4_val (ffetargetInteger4 val) 1459{ 1460 ffebldConstant c; 1461 ffebldConstant nc; 1462 int cmp; 1463 1464 for (c = (ffebldConstant) &ffebld_constant_integer4_; 1465 c->next != NULL; 1466 c = c->next) 1467 { 1468 cmp = ffetarget_cmp_integer4 (val, ffebld_constant_integer4 (c->next)); 1469 if (cmp == 0) 1470 return c->next; 1471 if (cmp > 0) 1472 break; 1473 } 1474 1475 nc = malloc_new_kp (ffebld_constant_pool(), 1476 "FFEBLD_constINTEGER4", 1477 sizeof (*nc)); 1478 nc->next = c->next; 1479 nc->consttype = FFEBLD_constINTEGER4; 1480 nc->u.integer4 = val; 1481#ifdef FFECOM_constantHOOK 1482 nc->hook = FFECOM_constantNULL; 1483#endif 1484 c->next = nc; 1485 1486 return nc; 1487} 1488 1489#endif 1490/* ffebld_constant_new_integerbinary -- Return binary constant object from token 1491 1492 See prototype. 1493 1494 Parses the token as a binary integer constant, thus it must be an 1495 FFELEX_typeNUMBER. */ 1496 1497ffebldConstant 1498ffebld_constant_new_integerbinary (ffelexToken t) 1499{ 1500 ffetargetIntegerDefault val; 1501 1502 assert ((ffelex_token_type (t) == FFELEX_typeNAME) 1503 || (ffelex_token_type (t) == FFELEX_typeNUMBER)); 1504 1505 ffetarget_integerbinary (&val, t); 1506 return ffebld_constant_new_integerdefault_val (val); 1507} 1508 1509/* ffebld_constant_new_integerhex -- Return hex constant object from token 1510 1511 See prototype. 1512 1513 Parses the token as a hex integer constant, thus it must be an 1514 FFELEX_typeNUMBER. */ 1515 1516ffebldConstant 1517ffebld_constant_new_integerhex (ffelexToken t) 1518{ 1519 ffetargetIntegerDefault val; 1520 1521 assert ((ffelex_token_type (t) == FFELEX_typeNAME) 1522 || (ffelex_token_type (t) == FFELEX_typeNUMBER)); 1523 1524 ffetarget_integerhex (&val, t); 1525 return ffebld_constant_new_integerdefault_val (val); 1526} 1527 1528/* ffebld_constant_new_integeroctal -- Return octal constant object from token 1529 1530 See prototype. 1531 1532 Parses the token as a octal integer constant, thus it must be an 1533 FFELEX_typeNUMBER. */ 1534 1535ffebldConstant 1536ffebld_constant_new_integeroctal (ffelexToken t) 1537{ 1538 ffetargetIntegerDefault val; 1539 1540 assert ((ffelex_token_type (t) == FFELEX_typeNAME) 1541 || (ffelex_token_type (t) == FFELEX_typeNUMBER)); 1542 1543 ffetarget_integeroctal (&val, t); 1544 return ffebld_constant_new_integerdefault_val (val); 1545} 1546 1547/* ffebld_constant_new_logical1 -- Return logical1 constant object from token 1548 1549 See prototype. 1550 1551 Parses the token as a decimal logical constant, thus it must be an 1552 FFELEX_typeNUMBER. */ 1553 1554#if FFETARGET_okLOGICAL1 1555ffebldConstant 1556ffebld_constant_new_logical1 (bool truth) 1557{ 1558 ffetargetLogical1 val; 1559 1560 ffetarget_logical1 (&val, truth); 1561 return ffebld_constant_new_logical1_val (val); 1562} 1563 1564#endif 1565/* ffebld_constant_new_logical1_val -- Return a logical1 constant object 1566 1567 See prototype. */ 1568 1569#if FFETARGET_okLOGICAL1 1570ffebldConstant 1571ffebld_constant_new_logical1_val (ffetargetLogical1 val) 1572{ 1573 ffebldConstant c; 1574 ffebldConstant nc; 1575 int cmp; 1576 1577 for (c = (ffebldConstant) &ffebld_constant_logical1_; 1578 c->next != NULL; 1579 c = c->next) 1580 { 1581 cmp = ffetarget_cmp_logical1 (val, ffebld_constant_logical1 (c->next)); 1582 if (cmp == 0) 1583 return c->next; 1584 if (cmp > 0) 1585 break; 1586 } 1587 1588 nc = malloc_new_kp (ffebld_constant_pool(), 1589 "FFEBLD_constLOGICAL1", 1590 sizeof (*nc)); 1591 nc->next = c->next; 1592 nc->consttype = FFEBLD_constLOGICAL1; 1593 nc->u.logical1 = val; 1594#ifdef FFECOM_constantHOOK 1595 nc->hook = FFECOM_constantNULL; 1596#endif 1597 c->next = nc; 1598 1599 return nc; 1600} 1601 1602#endif 1603/* ffebld_constant_new_logical2_val -- Return a logical2 constant object 1604 1605 See prototype. */ 1606 1607#if FFETARGET_okLOGICAL2 1608ffebldConstant 1609ffebld_constant_new_logical2_val (ffetargetLogical2 val) 1610{ 1611 ffebldConstant c; 1612 ffebldConstant nc; 1613 int cmp; 1614 1615 for (c = (ffebldConstant) &ffebld_constant_logical2_; 1616 c->next != NULL; 1617 c = c->next) 1618 { 1619 cmp = ffetarget_cmp_logical2 (val, ffebld_constant_logical2 (c->next)); 1620 if (cmp == 0) 1621 return c->next; 1622 if (cmp > 0) 1623 break; 1624 } 1625 1626 nc = malloc_new_kp (ffebld_constant_pool(), 1627 "FFEBLD_constLOGICAL2", 1628 sizeof (*nc)); 1629 nc->next = c->next; 1630 nc->consttype = FFEBLD_constLOGICAL2; 1631 nc->u.logical2 = val; 1632#ifdef FFECOM_constantHOOK 1633 nc->hook = FFECOM_constantNULL; 1634#endif 1635 c->next = nc; 1636 1637 return nc; 1638} 1639 1640#endif 1641/* ffebld_constant_new_logical3_val -- Return a logical3 constant object 1642 1643 See prototype. */ 1644 1645#if FFETARGET_okLOGICAL3 1646ffebldConstant 1647ffebld_constant_new_logical3_val (ffetargetLogical3 val) 1648{ 1649 ffebldConstant c; 1650 ffebldConstant nc; 1651 int cmp; 1652 1653 for (c = (ffebldConstant) &ffebld_constant_logical3_; 1654 c->next != NULL; 1655 c = c->next) 1656 { 1657 cmp = ffetarget_cmp_logical3 (val, ffebld_constant_logical3 (c->next)); 1658 if (cmp == 0) 1659 return c->next; 1660 if (cmp > 0) 1661 break; 1662 } 1663 1664 nc = malloc_new_kp (ffebld_constant_pool(), 1665 "FFEBLD_constLOGICAL3", 1666 sizeof (*nc)); 1667 nc->next = c->next; 1668 nc->consttype = FFEBLD_constLOGICAL3; 1669 nc->u.logical3 = val; 1670#ifdef FFECOM_constantHOOK 1671 nc->hook = FFECOM_constantNULL; 1672#endif 1673 c->next = nc; 1674 1675 return nc; 1676} 1677 1678#endif 1679/* ffebld_constant_new_logical4_val -- Return a logical4 constant object 1680 1681 See prototype. */ 1682 1683#if FFETARGET_okLOGICAL4 1684ffebldConstant 1685ffebld_constant_new_logical4_val (ffetargetLogical4 val) 1686{ 1687 ffebldConstant c; 1688 ffebldConstant nc; 1689 int cmp; 1690 1691 for (c = (ffebldConstant) &ffebld_constant_logical4_; 1692 c->next != NULL; 1693 c = c->next) 1694 { 1695 cmp = ffetarget_cmp_logical4 (val, ffebld_constant_logical4 (c->next)); 1696 if (cmp == 0) 1697 return c->next; 1698 if (cmp > 0) 1699 break; 1700 } 1701 1702 nc = malloc_new_kp (ffebld_constant_pool(), 1703 "FFEBLD_constLOGICAL4", 1704 sizeof (*nc)); 1705 nc->next = c->next; 1706 nc->consttype = FFEBLD_constLOGICAL4; 1707 nc->u.logical4 = val; 1708#ifdef FFECOM_constantHOOK 1709 nc->hook = FFECOM_constantNULL; 1710#endif 1711 c->next = nc; 1712 1713 return nc; 1714} 1715 1716#endif 1717/* ffebld_constant_new_real1 -- Return real1 constant object from token 1718 1719 See prototype. */ 1720 1721#if FFETARGET_okREAL1 1722ffebldConstant 1723ffebld_constant_new_real1 (ffelexToken integer, ffelexToken decimal, 1724 ffelexToken fraction, ffelexToken exponent, ffelexToken exponent_sign, 1725 ffelexToken exponent_digits) 1726{ 1727 ffetargetReal1 val; 1728 1729 ffetarget_real1 (&val, 1730 integer, decimal, fraction, exponent, exponent_sign, exponent_digits); 1731 return ffebld_constant_new_real1_val (val); 1732} 1733 1734#endif 1735/* ffebld_constant_new_real1_val -- Return an real1 constant object 1736 1737 See prototype. */ 1738 1739#if FFETARGET_okREAL1 1740ffebldConstant 1741ffebld_constant_new_real1_val (ffetargetReal1 val) 1742{ 1743 ffebldConstant c; 1744 ffebldConstant nc; 1745 int cmp; 1746 1747 for (c = (ffebldConstant) &ffebld_constant_real1_; 1748 c->next != NULL; 1749 c = c->next) 1750 { 1751 cmp = ffetarget_cmp_real1 (val, ffebld_constant_real1 (c->next)); 1752 if (cmp == 0) 1753 return c->next; 1754 if (cmp > 0) 1755 break; 1756 } 1757 1758 nc = malloc_new_kp (ffebld_constant_pool(), 1759 "FFEBLD_constREAL1", 1760 sizeof (*nc)); 1761 nc->next = c->next; 1762 nc->consttype = FFEBLD_constREAL1; 1763 nc->u.real1 = val; 1764#ifdef FFECOM_constantHOOK 1765 nc->hook = FFECOM_constantNULL; 1766#endif 1767 c->next = nc; 1768 1769 return nc; 1770} 1771 1772#endif 1773/* ffebld_constant_new_real2 -- Return real2 constant object from token 1774 1775 See prototype. */ 1776 1777#if FFETARGET_okREAL2 1778ffebldConstant 1779ffebld_constant_new_real2 (ffelexToken integer, ffelexToken decimal, 1780 ffelexToken fraction, ffelexToken exponent, ffelexToken exponent_sign, 1781 ffelexToken exponent_digits) 1782{ 1783 ffetargetReal2 val; 1784 1785 ffetarget_real2 (&val, 1786 integer, decimal, fraction, exponent, exponent_sign, exponent_digits); 1787 return ffebld_constant_new_real2_val (val); 1788} 1789 1790#endif 1791/* ffebld_constant_new_real2_val -- Return an real2 constant object 1792 1793 See prototype. */ 1794 1795#if FFETARGET_okREAL2 1796ffebldConstant 1797ffebld_constant_new_real2_val (ffetargetReal2 val) 1798{ 1799 ffebldConstant c; 1800 ffebldConstant nc; 1801 int cmp; 1802 1803 for (c = (ffebldConstant) &ffebld_constant_real2_; 1804 c->next != NULL; 1805 c = c->next) 1806 { 1807 cmp = ffetarget_cmp_real2 (val, ffebld_constant_real2 (c->next)); 1808 if (cmp == 0) 1809 return c->next; 1810 if (cmp > 0) 1811 break; 1812 } 1813 1814 nc = malloc_new_kp (ffebld_constant_pool(), 1815 "FFEBLD_constREAL2", 1816 sizeof (*nc)); 1817 nc->next = c->next; 1818 nc->consttype = FFEBLD_constREAL2; 1819 nc->u.real2 = val; 1820#ifdef FFECOM_constantHOOK 1821 nc->hook = FFECOM_constantNULL; 1822#endif 1823 c->next = nc; 1824 1825 return nc; 1826} 1827 1828#endif 1829/* ffebld_constant_new_typeless_bm -- Return typeless constant object from token 1830 1831 See prototype. 1832 1833 Parses the token as a decimal integer constant, thus it must be an 1834 FFELEX_typeNUMBER. */ 1835 1836ffebldConstant 1837ffebld_constant_new_typeless_bm (ffelexToken t) 1838{ 1839 ffetargetTypeless val; 1840 1841 ffetarget_binarymil (&val, t); 1842 return ffebld_constant_new_typeless_val (FFEBLD_constBINARY_MIL, val); 1843} 1844 1845/* ffebld_constant_new_typeless_bv -- Return typeless constant object from token 1846 1847 See prototype. 1848 1849 Parses the token as a decimal integer constant, thus it must be an 1850 FFELEX_typeNUMBER. */ 1851 1852ffebldConstant 1853ffebld_constant_new_typeless_bv (ffelexToken t) 1854{ 1855 ffetargetTypeless val; 1856 1857 ffetarget_binaryvxt (&val, t); 1858 return ffebld_constant_new_typeless_val (FFEBLD_constBINARY_VXT, val); 1859} 1860 1861/* ffebld_constant_new_typeless_hxm -- Return typeless constant object from token 1862 1863 See prototype. 1864 1865 Parses the token as a decimal integer constant, thus it must be an 1866 FFELEX_typeNUMBER. */ 1867 1868ffebldConstant 1869ffebld_constant_new_typeless_hxm (ffelexToken t) 1870{ 1871 ffetargetTypeless val; 1872 1873 ffetarget_hexxmil (&val, t); 1874 return ffebld_constant_new_typeless_val (FFEBLD_constHEX_X_MIL, val); 1875} 1876 1877/* ffebld_constant_new_typeless_hxv -- Return typeless constant object from token 1878 1879 See prototype. 1880 1881 Parses the token as a decimal integer constant, thus it must be an 1882 FFELEX_typeNUMBER. */ 1883 1884ffebldConstant 1885ffebld_constant_new_typeless_hxv (ffelexToken t) 1886{ 1887 ffetargetTypeless val; 1888 1889 ffetarget_hexxvxt (&val, t); 1890 return ffebld_constant_new_typeless_val (FFEBLD_constHEX_X_VXT, val); 1891} 1892 1893/* ffebld_constant_new_typeless_hzm -- Return typeless constant object from token 1894 1895 See prototype. 1896 1897 Parses the token as a decimal integer constant, thus it must be an 1898 FFELEX_typeNUMBER. */ 1899 1900ffebldConstant 1901ffebld_constant_new_typeless_hzm (ffelexToken t) 1902{ 1903 ffetargetTypeless val; 1904 1905 ffetarget_hexzmil (&val, t); 1906 return ffebld_constant_new_typeless_val (FFEBLD_constHEX_Z_MIL, val); 1907} 1908 1909/* ffebld_constant_new_typeless_hzv -- Return typeless constant object from token 1910 1911 See prototype. 1912 1913 Parses the token as a decimal integer constant, thus it must be an 1914 FFELEX_typeNUMBER. */ 1915 1916ffebldConstant 1917ffebld_constant_new_typeless_hzv (ffelexToken t) 1918{ 1919 ffetargetTypeless val; 1920 1921 ffetarget_hexzvxt (&val, t); 1922 return ffebld_constant_new_typeless_val (FFEBLD_constHEX_Z_VXT, val); 1923} 1924 1925/* ffebld_constant_new_typeless_om -- Return typeless constant object from token 1926 1927 See prototype. 1928 1929 Parses the token as a decimal integer constant, thus it must be an 1930 FFELEX_typeNUMBER. */ 1931 1932ffebldConstant 1933ffebld_constant_new_typeless_om (ffelexToken t) 1934{ 1935 ffetargetTypeless val; 1936 1937 ffetarget_octalmil (&val, t); 1938 return ffebld_constant_new_typeless_val (FFEBLD_constOCTAL_MIL, val); 1939} 1940 1941/* ffebld_constant_new_typeless_ov -- Return typeless constant object from token 1942 1943 See prototype. 1944 1945 Parses the token as a decimal integer constant, thus it must be an 1946 FFELEX_typeNUMBER. */ 1947 1948ffebldConstant 1949ffebld_constant_new_typeless_ov (ffelexToken t) 1950{ 1951 ffetargetTypeless val; 1952 1953 ffetarget_octalvxt (&val, t); 1954 return ffebld_constant_new_typeless_val (FFEBLD_constOCTAL_VXT, val); 1955} 1956 1957/* ffebld_constant_new_typeless_val -- Return a typeless constant object 1958 1959 See prototype. */ 1960 1961ffebldConstant 1962ffebld_constant_new_typeless_val (ffebldConst type, ffetargetTypeless val) 1963{ 1964 ffebldConstant c; 1965 ffebldConstant nc; 1966 int cmp; 1967 1968 for (c = (ffebldConstant) &ffebld_constant_typeless_[type 1969 - FFEBLD_constTYPELESS_FIRST]; 1970 c->next != NULL; 1971 c = c->next) 1972 { 1973 cmp = ffetarget_cmp_typeless (val, ffebld_constant_typeless (c->next)); 1974 if (cmp == 0) 1975 return c->next; 1976 if (cmp > 0) 1977 break; 1978 } 1979 1980 nc = malloc_new_kp (ffebld_constant_pool(), 1981 "FFEBLD_constTYPELESS", 1982 sizeof (*nc)); 1983 nc->next = c->next; 1984 nc->consttype = type; 1985 nc->u.typeless = val; 1986#ifdef FFECOM_constantHOOK 1987 nc->hook = FFECOM_constantNULL; 1988#endif 1989 c->next = nc; 1990 1991 return nc; 1992} 1993 1994/* ffebld_constantarray_dump -- Display summary of array's contents 1995 1996 ffebldConstantArray a; 1997 ffeinfoBasictype bt; 1998 ffeinfoKindtype kt; 1999 ffetargetOffset size; 2000 ffebld_constant_dump(a,bt,kt,size,NULL); 2001 2002 Displays the constant array in summary form. The fifth argument, if 2003 supplied, is an ffebit object that is consulted as to whether the 2004 constant at a particular offset is valid. */ 2005 2006#if FFECOM_targetCURRENT == FFECOM_targetFFE 2007void 2008ffebld_constantarray_dump (ffebldConstantArray array, ffeinfoBasictype bt, 2009 ffeinfoKindtype kt, ffetargetOffset size, ffebit bits) 2010{ 2011 ffetargetOffset i; 2012 ffebitCount j; 2013 2014 ffebld_dump_prefix (dmpout, bt, kt); 2015 2016 fprintf (dmpout, "\\("); 2017 2018 if (bits == NULL) 2019 { 2020 for (i = 0; i < size; ++i) 2021 { 2022 ffebld_constantunion_dump (ffebld_constantarray_get (array, bt, kt, i), bt, 2023 kt); 2024 if (i != size - 1) 2025 fputc (',', dmpout); 2026 } 2027 } 2028 else 2029 { 2030 bool value; 2031 ffebitCount length; 2032 ffetargetOffset offset = 0; 2033 2034 do 2035 { 2036 ffebit_test (bits, offset, &value, &length); 2037 if (value && (length != 0)) 2038 { 2039 if (length == 1) 2040 fprintf (dmpout, "[%" ffetargetOffset_f "d]:", offset); 2041 else 2042 fprintf (dmpout, 2043 "[%" ffetargetOffset_f "u..%" ffetargetOffset_f "d]:", 2044 offset, offset + (ffetargetOffset) length - 1); 2045 for (j = 0; j < length; ++j, ++offset) 2046 { 2047 ffebld_constantunion_dump (ffebld_constantarray_get (array, bt, kt, 2048 offset), bt, kt); 2049 if (j != length - 1) 2050 fputc (',', dmpout); 2051 } 2052 fprintf (dmpout, ";"); 2053 } 2054 else 2055 offset += length; 2056 } 2057 while (length != 0); 2058 } 2059 fprintf (dmpout, "\\)"); 2060 2061} 2062#endif 2063 2064/* ffebld_constantarray_get -- Get a value from an array of constants 2065 2066 See prototype. */ 2067 2068ffebldConstantUnion 2069ffebld_constantarray_get (ffebldConstantArray array, ffeinfoBasictype bt, 2070 ffeinfoKindtype kt, ffetargetOffset offset) 2071{ 2072 ffebldConstantUnion u; 2073 2074 switch (bt) 2075 { 2076 case FFEINFO_basictypeINTEGER: 2077 switch (kt) 2078 { 2079#if FFETARGET_okINTEGER1 2080 case FFEINFO_kindtypeINTEGER1: 2081 u.integer1 = *(array.integer1 + offset); 2082 break; 2083#endif 2084 2085#if FFETARGET_okINTEGER2 2086 case FFEINFO_kindtypeINTEGER2: 2087 u.integer2 = *(array.integer2 + offset); 2088 break; 2089#endif 2090 2091#if FFETARGET_okINTEGER3 2092 case FFEINFO_kindtypeINTEGER3: 2093 u.integer3 = *(array.integer3 + offset); 2094 break; 2095#endif 2096 2097#if FFETARGET_okINTEGER4 2098 case FFEINFO_kindtypeINTEGER4: 2099 u.integer4 = *(array.integer4 + offset); 2100 break; 2101#endif 2102 2103#if FFETARGET_okINTEGER5 2104 case FFEINFO_kindtypeINTEGER5: 2105 u.integer5 = *(array.integer5 + offset); 2106 break; 2107#endif 2108 2109#if FFETARGET_okINTEGER6 2110 case FFEINFO_kindtypeINTEGER6: 2111 u.integer6 = *(array.integer6 + offset); 2112 break; 2113#endif 2114 2115#if FFETARGET_okINTEGER7 2116 case FFEINFO_kindtypeINTEGER7: 2117 u.integer7 = *(array.integer7 + offset); 2118 break; 2119#endif 2120 2121#if FFETARGET_okINTEGER8 2122 case FFEINFO_kindtypeINTEGER8: 2123 u.integer8 = *(array.integer8 + offset); 2124 break; 2125#endif 2126 2127 default: 2128 assert ("bad INTEGER kindtype" == NULL); 2129 break; 2130 } 2131 break; 2132 2133 case FFEINFO_basictypeLOGICAL: 2134 switch (kt) 2135 { 2136#if FFETARGET_okLOGICAL1 2137 case FFEINFO_kindtypeLOGICAL1: 2138 u.logical1 = *(array.logical1 + offset); 2139 break; 2140#endif 2141 2142#if FFETARGET_okLOGICAL2 2143 case FFEINFO_kindtypeLOGICAL2: 2144 u.logical2 = *(array.logical2 + offset); 2145 break; 2146#endif 2147 2148#if FFETARGET_okLOGICAL3 2149 case FFEINFO_kindtypeLOGICAL3: 2150 u.logical3 = *(array.logical3 + offset); 2151 break; 2152#endif 2153 2154#if FFETARGET_okLOGICAL4 2155 case FFEINFO_kindtypeLOGICAL4: 2156 u.logical4 = *(array.logical4 + offset); 2157 break; 2158#endif 2159 2160#if FFETARGET_okLOGICAL5 2161 case FFEINFO_kindtypeLOGICAL5: 2162 u.logical5 = *(array.logical5 + offset); 2163 break; 2164#endif 2165 2166#if FFETARGET_okLOGICAL6 2167 case FFEINFO_kindtypeLOGICAL6: 2168 u.logical6 = *(array.logical6 + offset); 2169 break; 2170#endif 2171 2172#if FFETARGET_okLOGICAL7 2173 case FFEINFO_kindtypeLOGICAL7: 2174 u.logical7 = *(array.logical7 + offset); 2175 break; 2176#endif 2177 2178#if FFETARGET_okLOGICAL8 2179 case FFEINFO_kindtypeLOGICAL8: 2180 u.logical8 = *(array.logical8 + offset); 2181 break; 2182#endif 2183 2184 default: 2185 assert ("bad LOGICAL kindtype" == NULL); 2186 break; 2187 } 2188 break; 2189 2190 case FFEINFO_basictypeREAL: 2191 switch (kt) 2192 { 2193#if FFETARGET_okREAL1 2194 case FFEINFO_kindtypeREAL1: 2195 u.real1 = *(array.real1 + offset); 2196 break; 2197#endif 2198 2199#if FFETARGET_okREAL2 2200 case FFEINFO_kindtypeREAL2: 2201 u.real2 = *(array.real2 + offset); 2202 break; 2203#endif 2204 2205#if FFETARGET_okREAL3 2206 case FFEINFO_kindtypeREAL3: 2207 u.real3 = *(array.real3 + offset); 2208 break; 2209#endif 2210 2211#if FFETARGET_okREAL4 2212 case FFEINFO_kindtypeREAL4: 2213 u.real4 = *(array.real4 + offset); 2214 break; 2215#endif 2216 2217#if FFETARGET_okREAL5 2218 case FFEINFO_kindtypeREAL5: 2219 u.real5 = *(array.real5 + offset); 2220 break; 2221#endif 2222 2223#if FFETARGET_okREAL6 2224 case FFEINFO_kindtypeREAL6: 2225 u.real6 = *(array.real6 + offset); 2226 break; 2227#endif 2228 2229#if FFETARGET_okREAL7 2230 case FFEINFO_kindtypeREAL7: 2231 u.real7 = *(array.real7 + offset); 2232 break; 2233#endif 2234 2235#if FFETARGET_okREAL8 2236 case FFEINFO_kindtypeREAL8: 2237 u.real8 = *(array.real8 + offset); 2238 break; 2239#endif 2240 2241 default: 2242 assert ("bad REAL kindtype" == NULL); 2243 break; 2244 } 2245 break; 2246 2247 case FFEINFO_basictypeCOMPLEX: 2248 switch (kt) 2249 { 2250#if FFETARGET_okCOMPLEX1 2251 case FFEINFO_kindtypeREAL1: 2252 u.complex1 = *(array.complex1 + offset); 2253 break; 2254#endif 2255 2256#if FFETARGET_okCOMPLEX2 2257 case FFEINFO_kindtypeREAL2: 2258 u.complex2 = *(array.complex2 + offset); 2259 break; 2260#endif 2261 2262#if FFETARGET_okCOMPLEX3 2263 case FFEINFO_kindtypeREAL3: 2264 u.complex3 = *(array.complex3 + offset); 2265 break; 2266#endif 2267 2268#if FFETARGET_okCOMPLEX4 2269 case FFEINFO_kindtypeREAL4: 2270 u.complex4 = *(array.complex4 + offset); 2271 break; 2272#endif 2273 2274#if FFETARGET_okCOMPLEX5 2275 case FFEINFO_kindtypeREAL5: 2276 u.complex5 = *(array.complex5 + offset); 2277 break; 2278#endif 2279 2280#if FFETARGET_okCOMPLEX6 2281 case FFEINFO_kindtypeREAL6: 2282 u.complex6 = *(array.complex6 + offset); 2283 break; 2284#endif 2285 2286#if FFETARGET_okCOMPLEX7 2287 case FFEINFO_kindtypeREAL7: 2288 u.complex7 = *(array.complex7 + offset); 2289 break; 2290#endif 2291 2292#if FFETARGET_okCOMPLEX8 2293 case FFEINFO_kindtypeREAL8: 2294 u.complex8 = *(array.complex8 + offset); 2295 break; 2296#endif 2297 2298 default: 2299 assert ("bad COMPLEX kindtype" == NULL); 2300 break; 2301 } 2302 break; 2303 2304 case FFEINFO_basictypeCHARACTER: 2305 switch (kt) 2306 { 2307#if FFETARGET_okCHARACTER1 2308 case FFEINFO_kindtypeCHARACTER1: 2309 u.character1.length = 1; 2310 u.character1.text = array.character1 + offset; 2311 break; 2312#endif 2313 2314#if FFETARGET_okCHARACTER2 2315 case FFEINFO_kindtypeCHARACTER2: 2316 u.character2.length = 1; 2317 u.character2.text = array.character2 + offset; 2318 break; 2319#endif 2320 2321#if FFETARGET_okCHARACTER3 2322 case FFEINFO_kindtypeCHARACTER3: 2323 u.character3.length = 1; 2324 u.character3.text = array.character3 + offset; 2325 break; 2326#endif 2327 2328#if FFETARGET_okCHARACTER4 2329 case FFEINFO_kindtypeCHARACTER4: 2330 u.character4.length = 1; 2331 u.character4.text = array.character4 + offset; 2332 break; 2333#endif 2334 2335#if FFETARGET_okCHARACTER5 2336 case FFEINFO_kindtypeCHARACTER5: 2337 u.character5.length = 1; 2338 u.character5.text = array.character5 + offset; 2339 break; 2340#endif 2341 2342#if FFETARGET_okCHARACTER6 2343 case FFEINFO_kindtypeCHARACTER6: 2344 u.character6.length = 1; 2345 u.character6.text = array.character6 + offset; 2346 break; 2347#endif 2348 2349#if FFETARGET_okCHARACTER7 2350 case FFEINFO_kindtypeCHARACTER7: 2351 u.character7.length = 1; 2352 u.character7.text = array.character7 + offset; 2353 break; 2354#endif 2355 2356#if FFETARGET_okCHARACTER8 2357 case FFEINFO_kindtypeCHARACTER8: 2358 u.character8.length = 1; 2359 u.character8.text = array.character8 + offset; 2360 break; 2361#endif 2362 2363 default: 2364 assert ("bad CHARACTER kindtype" == NULL); 2365 break; 2366 } 2367 break; 2368 2369 default: 2370 assert ("bad basictype" == NULL); 2371 break; 2372 } 2373 2374 return u; 2375} 2376 2377/* ffebld_constantarray_new -- Make an array of constants 2378 2379 See prototype. */ 2380 2381ffebldConstantArray 2382ffebld_constantarray_new (ffeinfoBasictype bt, 2383 ffeinfoKindtype kt, ffetargetOffset size) 2384{ 2385 ffebldConstantArray ptr; 2386 2387 switch (bt) 2388 { 2389 case FFEINFO_basictypeINTEGER: 2390 switch (kt) 2391 { 2392#if FFETARGET_okINTEGER1 2393 case FFEINFO_kindtypeINTEGER1: 2394 ptr.integer1 = malloc_new_zkp (ffebld_constant_pool(), 2395 "ffebldConstantArray", 2396 size *= sizeof (ffetargetInteger1), 2397 0); 2398 break; 2399#endif 2400 2401#if FFETARGET_okINTEGER2 2402 case FFEINFO_kindtypeINTEGER2: 2403 ptr.integer2 = malloc_new_zkp (ffebld_constant_pool(), 2404 "ffebldConstantArray", 2405 size *= sizeof (ffetargetInteger2), 2406 0); 2407 break; 2408#endif 2409 2410#if FFETARGET_okINTEGER3 2411 case FFEINFO_kindtypeINTEGER3: 2412 ptr.integer3 = malloc_new_zkp (ffebld_constant_pool(), 2413 "ffebldConstantArray", 2414 size *= sizeof (ffetargetInteger3), 2415 0); 2416 break; 2417#endif 2418 2419#if FFETARGET_okINTEGER4 2420 case FFEINFO_kindtypeINTEGER4: 2421 ptr.integer4 = malloc_new_zkp (ffebld_constant_pool(), 2422 "ffebldConstantArray", 2423 size *= sizeof (ffetargetInteger4), 2424 0); 2425 break; 2426#endif 2427 2428#if FFETARGET_okINTEGER5 2429 case FFEINFO_kindtypeINTEGER5: 2430 ptr.integer5 = malloc_new_zkp (ffebld_constant_pool(), 2431 "ffebldConstantArray", 2432 size *= sizeof (ffetargetInteger5), 2433 0); 2434 break; 2435#endif 2436 2437#if FFETARGET_okINTEGER6 2438 case FFEINFO_kindtypeINTEGER6: 2439 ptr.integer6 = malloc_new_zkp (ffebld_constant_pool(), 2440 "ffebldConstantArray", 2441 size *= sizeof (ffetargetInteger6), 2442 0); 2443 break; 2444#endif 2445 2446#if FFETARGET_okINTEGER7 2447 case FFEINFO_kindtypeINTEGER7: 2448 ptr.integer7 = malloc_new_zkp (ffebld_constant_pool(), 2449 "ffebldConstantArray", 2450 size *= sizeof (ffetargetInteger7), 2451 0); 2452 break; 2453#endif 2454 2455#if FFETARGET_okINTEGER8 2456 case FFEINFO_kindtypeINTEGER8: 2457 ptr.integer8 = malloc_new_zkp (ffebld_constant_pool(), 2458 "ffebldConstantArray", 2459 size *= sizeof (ffetargetInteger8), 2460 0); 2461 break; 2462#endif 2463 2464 default: 2465 assert ("bad INTEGER kindtype" == NULL); 2466 break; 2467 } 2468 break; 2469 2470 case FFEINFO_basictypeLOGICAL: 2471 switch (kt) 2472 { 2473#if FFETARGET_okLOGICAL1 2474 case FFEINFO_kindtypeLOGICAL1: 2475 ptr.logical1 = malloc_new_zkp (ffebld_constant_pool(), 2476 "ffebldConstantArray", 2477 size *= sizeof (ffetargetLogical1), 2478 0); 2479 break; 2480#endif 2481 2482#if FFETARGET_okLOGICAL2 2483 case FFEINFO_kindtypeLOGICAL2: 2484 ptr.logical2 = malloc_new_zkp (ffebld_constant_pool(), 2485 "ffebldConstantArray", 2486 size *= sizeof (ffetargetLogical2), 2487 0); 2488 break; 2489#endif 2490 2491#if FFETARGET_okLOGICAL3 2492 case FFEINFO_kindtypeLOGICAL3: 2493 ptr.logical3 = malloc_new_zkp (ffebld_constant_pool(), 2494 "ffebldConstantArray", 2495 size *= sizeof (ffetargetLogical3), 2496 0); 2497 break; 2498#endif 2499 2500#if FFETARGET_okLOGICAL4 2501 case FFEINFO_kindtypeLOGICAL4: 2502 ptr.logical4 = malloc_new_zkp (ffebld_constant_pool(), 2503 "ffebldConstantArray", 2504 size *= sizeof (ffetargetLogical4), 2505 0); 2506 break; 2507#endif 2508 2509#if FFETARGET_okLOGICAL5 2510 case FFEINFO_kindtypeLOGICAL5: 2511 ptr.logical5 = malloc_new_zkp (ffebld_constant_pool(), 2512 "ffebldConstantArray", 2513 size *= sizeof (ffetargetLogical5), 2514 0); 2515 break; 2516#endif 2517 2518#if FFETARGET_okLOGICAL6 2519 case FFEINFO_kindtypeLOGICAL6: 2520 ptr.logical6 = malloc_new_zkp (ffebld_constant_pool(), 2521 "ffebldConstantArray", 2522 size *= sizeof (ffetargetLogical6), 2523 0); 2524 break; 2525#endif 2526 2527#if FFETARGET_okLOGICAL7 2528 case FFEINFO_kindtypeLOGICAL7: 2529 ptr.logical7 = malloc_new_zkp (ffebld_constant_pool(), 2530 "ffebldConstantArray", 2531 size *= sizeof (ffetargetLogical7), 2532 0); 2533 break; 2534#endif 2535 2536#if FFETARGET_okLOGICAL8 2537 case FFEINFO_kindtypeLOGICAL8: 2538 ptr.logical8 = malloc_new_zkp (ffebld_constant_pool(), 2539 "ffebldConstantArray", 2540 size *= sizeof (ffetargetLogical8), 2541 0); 2542 break; 2543#endif 2544 2545 default: 2546 assert ("bad LOGICAL kindtype" == NULL); 2547 break; 2548 } 2549 break; 2550 2551 case FFEINFO_basictypeREAL: 2552 switch (kt) 2553 { 2554#if FFETARGET_okREAL1 2555 case FFEINFO_kindtypeREAL1: 2556 ptr.real1 = malloc_new_zkp (ffebld_constant_pool(), 2557 "ffebldConstantArray", 2558 size *= sizeof (ffetargetReal1), 2559 0); 2560 break; 2561#endif 2562 2563#if FFETARGET_okREAL2 2564 case FFEINFO_kindtypeREAL2: 2565 ptr.real2 = malloc_new_zkp (ffebld_constant_pool(), 2566 "ffebldConstantArray", 2567 size *= sizeof (ffetargetReal2), 2568 0); 2569 break; 2570#endif 2571 2572#if FFETARGET_okREAL3 2573 case FFEINFO_kindtypeREAL3: 2574 ptr.real3 = malloc_new_zkp (ffebld_constant_pool(), 2575 "ffebldConstantArray", 2576 size *= sizeof (ffetargetReal3), 2577 0); 2578 break; 2579#endif 2580 2581#if FFETARGET_okREAL4 2582 case FFEINFO_kindtypeREAL4: 2583 ptr.real4 = malloc_new_zkp (ffebld_constant_pool(), 2584 "ffebldConstantArray", 2585 size *= sizeof (ffetargetReal4), 2586 0); 2587 break; 2588#endif 2589 2590#if FFETARGET_okREAL5 2591 case FFEINFO_kindtypeREAL5: 2592 ptr.real5 = malloc_new_zkp (ffebld_constant_pool(), 2593 "ffebldConstantArray", 2594 size *= sizeof (ffetargetReal5), 2595 0); 2596 break; 2597#endif 2598 2599#if FFETARGET_okREAL6 2600 case FFEINFO_kindtypeREAL6: 2601 ptr.real6 = malloc_new_zkp (ffebld_constant_pool(), 2602 "ffebldConstantArray", 2603 size *= sizeof (ffetargetReal6), 2604 0); 2605 break; 2606#endif 2607 2608#if FFETARGET_okREAL7 2609 case FFEINFO_kindtypeREAL7: 2610 ptr.real7 = malloc_new_zkp (ffebld_constant_pool(), 2611 "ffebldConstantArray", 2612 size *= sizeof (ffetargetReal7), 2613 0); 2614 break; 2615#endif 2616 2617#if FFETARGET_okREAL8 2618 case FFEINFO_kindtypeREAL8: 2619 ptr.real8 = malloc_new_zkp (ffebld_constant_pool(), 2620 "ffebldConstantArray", 2621 size *= sizeof (ffetargetReal8), 2622 0); 2623 break; 2624#endif 2625 2626 default: 2627 assert ("bad REAL kindtype" == NULL); 2628 break; 2629 } 2630 break; 2631 2632 case FFEINFO_basictypeCOMPLEX: 2633 switch (kt) 2634 { 2635#if FFETARGET_okCOMPLEX1 2636 case FFEINFO_kindtypeREAL1: 2637 ptr.complex1 = malloc_new_zkp (ffebld_constant_pool(), 2638 "ffebldConstantArray", 2639 size *= sizeof (ffetargetComplex1), 2640 0); 2641 break; 2642#endif 2643 2644#if FFETARGET_okCOMPLEX2 2645 case FFEINFO_kindtypeREAL2: 2646 ptr.complex2 = malloc_new_zkp (ffebld_constant_pool(), 2647 "ffebldConstantArray", 2648 size *= sizeof (ffetargetComplex2), 2649 0); 2650 break; 2651#endif 2652 2653#if FFETARGET_okCOMPLEX3 2654 case FFEINFO_kindtypeREAL3: 2655 ptr.complex3 = malloc_new_zkp (ffebld_constant_pool(), 2656 "ffebldConstantArray", 2657 size *= sizeof (ffetargetComplex3), 2658 0); 2659 break; 2660#endif 2661 2662#if FFETARGET_okCOMPLEX4 2663 case FFEINFO_kindtypeREAL4: 2664 ptr.complex4 = malloc_new_zkp (ffebld_constant_pool(), 2665 "ffebldConstantArray", 2666 size *= sizeof (ffetargetComplex4), 2667 0); 2668 break; 2669#endif 2670 2671#if FFETARGET_okCOMPLEX5 2672 case FFEINFO_kindtypeREAL5: 2673 ptr.complex5 = malloc_new_zkp (ffebld_constant_pool(), 2674 "ffebldConstantArray", 2675 size *= sizeof (ffetargetComplex5), 2676 0); 2677 break; 2678#endif 2679 2680#if FFETARGET_okCOMPLEX6 2681 case FFEINFO_kindtypeREAL6: 2682 ptr.complex6 = malloc_new_zkp (ffebld_constant_pool(), 2683 "ffebldConstantArray", 2684 size *= sizeof (ffetargetComplex6), 2685 0); 2686 break; 2687#endif 2688 2689#if FFETARGET_okCOMPLEX7 2690 case FFEINFO_kindtypeREAL7: 2691 ptr.complex7 = malloc_new_zkp (ffebld_constant_pool(), 2692 "ffebldConstantArray", 2693 size *= sizeof (ffetargetComplex7), 2694 0); 2695 break; 2696#endif 2697 2698#if FFETARGET_okCOMPLEX8 2699 case FFEINFO_kindtypeREAL8: 2700 ptr.complex8 = malloc_new_zkp (ffebld_constant_pool(), 2701 "ffebldConstantArray", 2702 size *= sizeof (ffetargetComplex8), 2703 0); 2704 break; 2705#endif 2706 2707 default: 2708 assert ("bad COMPLEX kindtype" == NULL); 2709 break; 2710 } 2711 break; 2712 2713 case FFEINFO_basictypeCHARACTER: 2714 switch (kt) 2715 { 2716#if FFETARGET_okCHARACTER1 2717 case FFEINFO_kindtypeCHARACTER1: 2718 ptr.character1 = malloc_new_zkp (ffebld_constant_pool(), 2719 "ffebldConstantArray", 2720 size 2721 *= sizeof (ffetargetCharacterUnit1), 2722 0); 2723 break; 2724#endif 2725 2726#if FFETARGET_okCHARACTER2 2727 case FFEINFO_kindtypeCHARACTER2: 2728 ptr.character2 = malloc_new_zkp (ffebld_constant_pool(), 2729 "ffebldConstantArray", 2730 size 2731 *= sizeof (ffetargetCharacterUnit2), 2732 0); 2733 break; 2734#endif 2735 2736#if FFETARGET_okCHARACTER3 2737 case FFEINFO_kindtypeCHARACTER3: 2738 ptr.character3 = malloc_new_zkp (ffebld_constant_pool(), 2739 "ffebldConstantArray", 2740 size 2741 *= sizeof (ffetargetCharacterUnit3), 2742 0); 2743 break; 2744#endif 2745 2746#if FFETARGET_okCHARACTER4 2747 case FFEINFO_kindtypeCHARACTER4: 2748 ptr.character4 = malloc_new_zkp (ffebld_constant_pool(), 2749 "ffebldConstantArray", 2750 size 2751 *= sizeof (ffetargetCharacterUnit4), 2752 0); 2753 break; 2754#endif 2755 2756#if FFETARGET_okCHARACTER5 2757 case FFEINFO_kindtypeCHARACTER5: 2758 ptr.character5 = malloc_new_zkp (ffebld_constant_pool(), 2759 "ffebldConstantArray", 2760 size 2761 *= sizeof (ffetargetCharacterUnit5), 2762 0); 2763 break; 2764#endif 2765 2766#if FFETARGET_okCHARACTER6 2767 case FFEINFO_kindtypeCHARACTER6: 2768 ptr.character6 = malloc_new_zkp (ffebld_constant_pool(), 2769 "ffebldConstantArray", 2770 size 2771 *= sizeof (ffetargetCharacterUnit6), 2772 0); 2773 break; 2774#endif 2775 2776#if FFETARGET_okCHARACTER7 2777 case FFEINFO_kindtypeCHARACTER7: 2778 ptr.character7 = malloc_new_zkp (ffebld_constant_pool(), 2779 "ffebldConstantArray", 2780 size 2781 *= sizeof (ffetargetCharacterUnit7), 2782 0); 2783 break; 2784#endif 2785 2786#if FFETARGET_okCHARACTER8 2787 case FFEINFO_kindtypeCHARACTER8: 2788 ptr.character8 = malloc_new_zkp (ffebld_constant_pool(), 2789 "ffebldConstantArray", 2790 size 2791 *= sizeof (ffetargetCharacterUnit8), 2792 0); 2793 break; 2794#endif 2795 2796 default: 2797 assert ("bad CHARACTER kindtype" == NULL); 2798 break; 2799 } 2800 break; 2801 2802 default: 2803 assert ("bad basictype" == NULL); 2804 break; 2805 } 2806 2807 return ptr; 2808} 2809 2810/* ffebld_constantarray_preparray -- Prepare for copy between arrays 2811 2812 See prototype. 2813 2814 Like _prepare, but the source is an array instead of a single-value 2815 constant. */ 2816 2817void 2818ffebld_constantarray_preparray (void **aptr, void **cptr, size_t *size, 2819 ffebldConstantArray array, ffeinfoBasictype abt, ffeinfoKindtype akt, 2820 ffetargetOffset offset, ffebldConstantArray source_array, 2821 ffeinfoBasictype cbt, ffeinfoKindtype ckt) 2822{ 2823 switch (abt) 2824 { 2825 case FFEINFO_basictypeINTEGER: 2826 switch (akt) 2827 { 2828#if FFETARGET_okINTEGER1 2829 case FFEINFO_kindtypeINTEGER1: 2830 *aptr = array.integer1 + offset; 2831 break; 2832#endif 2833 2834#if FFETARGET_okINTEGER2 2835 case FFEINFO_kindtypeINTEGER2: 2836 *aptr = array.integer2 + offset; 2837 break; 2838#endif 2839 2840#if FFETARGET_okINTEGER3 2841 case FFEINFO_kindtypeINTEGER3: 2842 *aptr = array.integer3 + offset; 2843 break; 2844#endif 2845 2846#if FFETARGET_okINTEGER4 2847 case FFEINFO_kindtypeINTEGER4: 2848 *aptr = array.integer4 + offset; 2849 break; 2850#endif 2851 2852#if FFETARGET_okINTEGER5 2853 case FFEINFO_kindtypeINTEGER5: 2854 *aptr = array.integer5 + offset; 2855 break; 2856#endif 2857 2858#if FFETARGET_okINTEGER6 2859 case FFEINFO_kindtypeINTEGER6: 2860 *aptr = array.integer6 + offset; 2861 break; 2862#endif 2863 2864#if FFETARGET_okINTEGER7 2865 case FFEINFO_kindtypeINTEGER7: 2866 *aptr = array.integer7 + offset; 2867 break; 2868#endif 2869 2870#if FFETARGET_okINTEGER8 2871 case FFEINFO_kindtypeINTEGER8: 2872 *aptr = array.integer8 + offset; 2873 break; 2874#endif 2875 2876 default: 2877 assert ("bad INTEGER akindtype" == NULL); 2878 break; 2879 } 2880 break; 2881 2882 case FFEINFO_basictypeLOGICAL: 2883 switch (akt) 2884 { 2885#if FFETARGET_okLOGICAL1 2886 case FFEINFO_kindtypeLOGICAL1: 2887 *aptr = array.logical1 + offset; 2888 break; 2889#endif 2890 2891#if FFETARGET_okLOGICAL2 2892 case FFEINFO_kindtypeLOGICAL2: 2893 *aptr = array.logical2 + offset; 2894 break; 2895#endif 2896 2897#if FFETARGET_okLOGICAL3 2898 case FFEINFO_kindtypeLOGICAL3: 2899 *aptr = array.logical3 + offset; 2900 break; 2901#endif 2902 2903#if FFETARGET_okLOGICAL4 2904 case FFEINFO_kindtypeLOGICAL4: 2905 *aptr = array.logical4 + offset; 2906 break; 2907#endif 2908 2909#if FFETARGET_okLOGICAL5 2910 case FFEINFO_kindtypeLOGICAL5: 2911 *aptr = array.logical5 + offset; 2912 break; 2913#endif 2914 2915#if FFETARGET_okLOGICAL6 2916 case FFEINFO_kindtypeLOGICAL6: 2917 *aptr = array.logical6 + offset; 2918 break; 2919#endif 2920 2921#if FFETARGET_okLOGICAL7 2922 case FFEINFO_kindtypeLOGICAL7: 2923 *aptr = array.logical7 + offset; 2924 break; 2925#endif 2926 2927#if FFETARGET_okLOGICAL8 2928 case FFEINFO_kindtypeLOGICAL8: 2929 *aptr = array.logical8 + offset; 2930 break; 2931#endif 2932 2933 default: 2934 assert ("bad LOGICAL akindtype" == NULL); 2935 break; 2936 } 2937 break; 2938 2939 case FFEINFO_basictypeREAL: 2940 switch (akt) 2941 { 2942#if FFETARGET_okREAL1 2943 case FFEINFO_kindtypeREAL1: 2944 *aptr = array.real1 + offset; 2945 break; 2946#endif 2947 2948#if FFETARGET_okREAL2 2949 case FFEINFO_kindtypeREAL2: 2950 *aptr = array.real2 + offset; 2951 break; 2952#endif 2953 2954#if FFETARGET_okREAL3 2955 case FFEINFO_kindtypeREAL3: 2956 *aptr = array.real3 + offset; 2957 break; 2958#endif 2959 2960#if FFETARGET_okREAL4 2961 case FFEINFO_kindtypeREAL4: 2962 *aptr = array.real4 + offset; 2963 break; 2964#endif 2965 2966#if FFETARGET_okREAL5 2967 case FFEINFO_kindtypeREAL5: 2968 *aptr = array.real5 + offset; 2969 break; 2970#endif 2971 2972#if FFETARGET_okREAL6 2973 case FFEINFO_kindtypeREAL6: 2974 *aptr = array.real6 + offset; 2975 break; 2976#endif 2977 2978#if FFETARGET_okREAL7 2979 case FFEINFO_kindtypeREAL7: 2980 *aptr = array.real7 + offset; 2981 break; 2982#endif 2983 2984#if FFETARGET_okREAL8 2985 case FFEINFO_kindtypeREAL8: 2986 *aptr = array.real8 + offset; 2987 break; 2988#endif 2989 2990 default: 2991 assert ("bad REAL akindtype" == NULL); 2992 break; 2993 } 2994 break; 2995 2996 case FFEINFO_basictypeCOMPLEX: 2997 switch (akt) 2998 { 2999#if FFETARGET_okCOMPLEX1 3000 case FFEINFO_kindtypeREAL1: 3001 *aptr = array.complex1 + offset; 3002 break; 3003#endif 3004 3005#if FFETARGET_okCOMPLEX2 3006 case FFEINFO_kindtypeREAL2: 3007 *aptr = array.complex2 + offset; 3008 break; 3009#endif 3010 3011#if FFETARGET_okCOMPLEX3 3012 case FFEINFO_kindtypeREAL3: 3013 *aptr = array.complex3 + offset; 3014 break; 3015#endif 3016 3017#if FFETARGET_okCOMPLEX4 3018 case FFEINFO_kindtypeREAL4: 3019 *aptr = array.complex4 + offset; 3020 break; 3021#endif 3022 3023#if FFETARGET_okCOMPLEX5 3024 case FFEINFO_kindtypeREAL5: 3025 *aptr = array.complex5 + offset; 3026 break; 3027#endif 3028 3029#if FFETARGET_okCOMPLEX6 3030 case FFEINFO_kindtypeREAL6: 3031 *aptr = array.complex6 + offset; 3032 break; 3033#endif 3034 3035#if FFETARGET_okCOMPLEX7 3036 case FFEINFO_kindtypeREAL7: 3037 *aptr = array.complex7 + offset; 3038 break; 3039#endif 3040 3041#if FFETARGET_okCOMPLEX8 3042 case FFEINFO_kindtypeREAL8: 3043 *aptr = array.complex8 + offset; 3044 break; 3045#endif 3046 3047 default: 3048 assert ("bad COMPLEX akindtype" == NULL); 3049 break; 3050 } 3051 break; 3052 3053 case FFEINFO_basictypeCHARACTER: 3054 switch (akt) 3055 { 3056#if FFETARGET_okCHARACTER1 3057 case FFEINFO_kindtypeCHARACTER1: 3058 *aptr = array.character1 + offset; 3059 break; 3060#endif 3061 3062#if FFETARGET_okCHARACTER2 3063 case FFEINFO_kindtypeCHARACTER2: 3064 *aptr = array.character2 + offset; 3065 break; 3066#endif 3067 3068#if FFETARGET_okCHARACTER3 3069 case FFEINFO_kindtypeCHARACTER3: 3070 *aptr = array.character3 + offset; 3071 break; 3072#endif 3073 3074#if FFETARGET_okCHARACTER4 3075 case FFEINFO_kindtypeCHARACTER4: 3076 *aptr = array.character4 + offset; 3077 break; 3078#endif 3079 3080#if FFETARGET_okCHARACTER5 3081 case FFEINFO_kindtypeCHARACTER5: 3082 *aptr = array.character5 + offset; 3083 break; 3084#endif 3085 3086#if FFETARGET_okCHARACTER6 3087 case FFEINFO_kindtypeCHARACTER6: 3088 *aptr = array.character6 + offset; 3089 break; 3090#endif 3091 3092#if FFETARGET_okCHARACTER7 3093 case FFEINFO_kindtypeCHARACTER7: 3094 *aptr = array.character7 + offset; 3095 break; 3096#endif 3097 3098#if FFETARGET_okCHARACTER8 3099 case FFEINFO_kindtypeCHARACTER8: 3100 *aptr = array.character8 + offset; 3101 break; 3102#endif 3103 3104 default: 3105 assert ("bad CHARACTER akindtype" == NULL); 3106 break; 3107 } 3108 break; 3109 3110 default: 3111 assert ("bad abasictype" == NULL); 3112 break; 3113 } 3114 3115 switch (cbt) 3116 { 3117 case FFEINFO_basictypeINTEGER: 3118 switch (ckt) 3119 { 3120#if FFETARGET_okINTEGER1 3121 case FFEINFO_kindtypeINTEGER1: 3122 *cptr = source_array.integer1; 3123 *size = sizeof (*source_array.integer1); 3124 break; 3125#endif 3126 3127#if FFETARGET_okINTEGER2 3128 case FFEINFO_kindtypeINTEGER2: 3129 *cptr = source_array.integer2; 3130 *size = sizeof (*source_array.integer2); 3131 break; 3132#endif 3133 3134#if FFETARGET_okINTEGER3 3135 case FFEINFO_kindtypeINTEGER3: 3136 *cptr = source_array.integer3; 3137 *size = sizeof (*source_array.integer3); 3138 break; 3139#endif 3140 3141#if FFETARGET_okINTEGER4 3142 case FFEINFO_kindtypeINTEGER4: 3143 *cptr = source_array.integer4; 3144 *size = sizeof (*source_array.integer4); 3145 break; 3146#endif 3147 3148#if FFETARGET_okINTEGER5 3149 case FFEINFO_kindtypeINTEGER5: 3150 *cptr = source_array.integer5; 3151 *size = sizeof (*source_array.integer5); 3152 break; 3153#endif 3154 3155#if FFETARGET_okINTEGER6 3156 case FFEINFO_kindtypeINTEGER6: 3157 *cptr = source_array.integer6; 3158 *size = sizeof (*source_array.integer6); 3159 break; 3160#endif 3161 3162#if FFETARGET_okINTEGER7 3163 case FFEINFO_kindtypeINTEGER7: 3164 *cptr = source_array.integer7; 3165 *size = sizeof (*source_array.integer7); 3166 break; 3167#endif 3168 3169#if FFETARGET_okINTEGER8 3170 case FFEINFO_kindtypeINTEGER8: 3171 *cptr = source_array.integer8; 3172 *size = sizeof (*source_array.integer8); 3173 break; 3174#endif 3175 3176 default: 3177 assert ("bad INTEGER ckindtype" == NULL); 3178 break; 3179 } 3180 break; 3181 3182 case FFEINFO_basictypeLOGICAL: 3183 switch (ckt) 3184 { 3185#if FFETARGET_okLOGICAL1 3186 case FFEINFO_kindtypeLOGICAL1: 3187 *cptr = source_array.logical1; 3188 *size = sizeof (*source_array.logical1); 3189 break; 3190#endif 3191 3192#if FFETARGET_okLOGICAL2 3193 case FFEINFO_kindtypeLOGICAL2: 3194 *cptr = source_array.logical2; 3195 *size = sizeof (*source_array.logical2); 3196 break; 3197#endif 3198 3199#if FFETARGET_okLOGICAL3 3200 case FFEINFO_kindtypeLOGICAL3: 3201 *cptr = source_array.logical3; 3202 *size = sizeof (*source_array.logical3); 3203 break; 3204#endif 3205 3206#if FFETARGET_okLOGICAL4 3207 case FFEINFO_kindtypeLOGICAL4: 3208 *cptr = source_array.logical4; 3209 *size = sizeof (*source_array.logical4); 3210 break; 3211#endif 3212 3213#if FFETARGET_okLOGICAL5 3214 case FFEINFO_kindtypeLOGICAL5: 3215 *cptr = source_array.logical5; 3216 *size = sizeof (*source_array.logical5); 3217 break; 3218#endif 3219 3220#if FFETARGET_okLOGICAL6 3221 case FFEINFO_kindtypeLOGICAL6: 3222 *cptr = source_array.logical6; 3223 *size = sizeof (*source_array.logical6); 3224 break; 3225#endif 3226 3227#if FFETARGET_okLOGICAL7 3228 case FFEINFO_kindtypeLOGICAL7: 3229 *cptr = source_array.logical7; 3230 *size = sizeof (*source_array.logical7); 3231 break; 3232#endif 3233 3234#if FFETARGET_okLOGICAL8 3235 case FFEINFO_kindtypeLOGICAL8: 3236 *cptr = source_array.logical8; 3237 *size = sizeof (*source_array.logical8); 3238 break; 3239#endif 3240 3241 default: 3242 assert ("bad LOGICAL ckindtype" == NULL); 3243 break; 3244 } 3245 break; 3246 3247 case FFEINFO_basictypeREAL: 3248 switch (ckt) 3249 { 3250#if FFETARGET_okREAL1 3251 case FFEINFO_kindtypeREAL1: 3252 *cptr = source_array.real1; 3253 *size = sizeof (*source_array.real1); 3254 break; 3255#endif 3256 3257#if FFETARGET_okREAL2 3258 case FFEINFO_kindtypeREAL2: 3259 *cptr = source_array.real2; 3260 *size = sizeof (*source_array.real2); 3261 break; 3262#endif 3263 3264#if FFETARGET_okREAL3 3265 case FFEINFO_kindtypeREAL3: 3266 *cptr = source_array.real3; 3267 *size = sizeof (*source_array.real3); 3268 break; 3269#endif 3270 3271#if FFETARGET_okREAL4 3272 case FFEINFO_kindtypeREAL4: 3273 *cptr = source_array.real4; 3274 *size = sizeof (*source_array.real4); 3275 break; 3276#endif 3277 3278#if FFETARGET_okREAL5 3279 case FFEINFO_kindtypeREAL5: 3280 *cptr = source_array.real5; 3281 *size = sizeof (*source_array.real5); 3282 break; 3283#endif 3284 3285#if FFETARGET_okREAL6 3286 case FFEINFO_kindtypeREAL6: 3287 *cptr = source_array.real6; 3288 *size = sizeof (*source_array.real6); 3289 break; 3290#endif 3291 3292#if FFETARGET_okREAL7 3293 case FFEINFO_kindtypeREAL7: 3294 *cptr = source_array.real7; 3295 *size = sizeof (*source_array.real7); 3296 break; 3297#endif 3298 3299#if FFETARGET_okREAL8 3300 case FFEINFO_kindtypeREAL8: 3301 *cptr = source_array.real8; 3302 *size = sizeof (*source_array.real8); 3303 break; 3304#endif 3305 3306 default: 3307 assert ("bad REAL ckindtype" == NULL); 3308 break; 3309 } 3310 break; 3311 3312 case FFEINFO_basictypeCOMPLEX: 3313 switch (ckt) 3314 { 3315#if FFETARGET_okCOMPLEX1 3316 case FFEINFO_kindtypeREAL1: 3317 *cptr = source_array.complex1; 3318 *size = sizeof (*source_array.complex1); 3319 break; 3320#endif 3321 3322#if FFETARGET_okCOMPLEX2 3323 case FFEINFO_kindtypeREAL2: 3324 *cptr = source_array.complex2; 3325 *size = sizeof (*source_array.complex2); 3326 break; 3327#endif 3328 3329#if FFETARGET_okCOMPLEX3 3330 case FFEINFO_kindtypeREAL3: 3331 *cptr = source_array.complex3; 3332 *size = sizeof (*source_array.complex3); 3333 break; 3334#endif 3335 3336#if FFETARGET_okCOMPLEX4 3337 case FFEINFO_kindtypeREAL4: 3338 *cptr = source_array.complex4; 3339 *size = sizeof (*source_array.complex4); 3340 break; 3341#endif 3342 3343#if FFETARGET_okCOMPLEX5 3344 case FFEINFO_kindtypeREAL5: 3345 *cptr = source_array.complex5; 3346 *size = sizeof (*source_array.complex5); 3347 break; 3348#endif 3349 3350#if FFETARGET_okCOMPLEX6 3351 case FFEINFO_kindtypeREAL6: 3352 *cptr = source_array.complex6; 3353 *size = sizeof (*source_array.complex6); 3354 break; 3355#endif 3356 3357#if FFETARGET_okCOMPLEX7 3358 case FFEINFO_kindtypeREAL7: 3359 *cptr = source_array.complex7; 3360 *size = sizeof (*source_array.complex7); 3361 break; 3362#endif 3363 3364#if FFETARGET_okCOMPLEX8 3365 case FFEINFO_kindtypeREAL8: 3366 *cptr = source_array.complex8; 3367 *size = sizeof (*source_array.complex8); 3368 break; 3369#endif 3370 3371 default: 3372 assert ("bad COMPLEX ckindtype" == NULL); 3373 break; 3374 } 3375 break; 3376 3377 case FFEINFO_basictypeCHARACTER: 3378 switch (ckt) 3379 { 3380#if FFETARGET_okCHARACTER1 3381 case FFEINFO_kindtypeCHARACTER1: 3382 *cptr = source_array.character1; 3383 *size = sizeof (*source_array.character1); 3384 break; 3385#endif 3386 3387#if FFETARGET_okCHARACTER2 3388 case FFEINFO_kindtypeCHARACTER2: 3389 *cptr = source_array.character2; 3390 *size = sizeof (*source_array.character2); 3391 break; 3392#endif 3393 3394#if FFETARGET_okCHARACTER3 3395 case FFEINFO_kindtypeCHARACTER3: 3396 *cptr = source_array.character3; 3397 *size = sizeof (*source_array.character3); 3398 break; 3399#endif 3400 3401#if FFETARGET_okCHARACTER4 3402 case FFEINFO_kindtypeCHARACTER4: 3403 *cptr = source_array.character4; 3404 *size = sizeof (*source_array.character4); 3405 break; 3406#endif 3407 3408#if FFETARGET_okCHARACTER5 3409 case FFEINFO_kindtypeCHARACTER5: 3410 *cptr = source_array.character5; 3411 *size = sizeof (*source_array.character5); 3412 break; 3413#endif 3414 3415#if FFETARGET_okCHARACTER6 3416 case FFEINFO_kindtypeCHARACTER6: 3417 *cptr = source_array.character6; 3418 *size = sizeof (*source_array.character6); 3419 break; 3420#endif 3421 3422#if FFETARGET_okCHARACTER7 3423 case FFEINFO_kindtypeCHARACTER7: 3424 *cptr = source_array.character7; 3425 *size = sizeof (*source_array.character7); 3426 break; 3427#endif 3428 3429#if FFETARGET_okCHARACTER8 3430 case FFEINFO_kindtypeCHARACTER8: 3431 *cptr = source_array.character8; 3432 *size = sizeof (*source_array.character8); 3433 break; 3434#endif 3435 3436 default: 3437 assert ("bad CHARACTER ckindtype" == NULL); 3438 break; 3439 } 3440 break; 3441 3442 default: 3443 assert ("bad cbasictype" == NULL); 3444 break; 3445 } 3446} 3447 3448/* ffebld_constantarray_prepare -- Prepare for copy between value and array 3449 3450 See prototype. 3451 3452 Like _put, but just returns the pointers to the beginnings of the 3453 array and the constant and returns the size (the amount of info to 3454 copy). The idea is that the caller can use memcpy to accomplish the 3455 same thing as _put (though slower), or the caller can use a different 3456 function that swaps bytes, words, etc for a different target machine. 3457 Also, the type of the array may be different from the type of the 3458 constant; the array type is used to determine the meaning (scale) of 3459 the offset field (to calculate the array pointer), the constant type is 3460 used to determine the constant pointer and the size (amount of info to 3461 copy). */ 3462 3463void 3464ffebld_constantarray_prepare (void **aptr, void **cptr, size_t *size, 3465 ffebldConstantArray array, ffeinfoBasictype abt, ffeinfoKindtype akt, 3466 ffetargetOffset offset, ffebldConstantUnion *constant, 3467 ffeinfoBasictype cbt, ffeinfoKindtype ckt) 3468{ 3469 switch (abt) 3470 { 3471 case FFEINFO_basictypeINTEGER: 3472 switch (akt) 3473 { 3474#if FFETARGET_okINTEGER1 3475 case FFEINFO_kindtypeINTEGER1: 3476 *aptr = array.integer1 + offset; 3477 break; 3478#endif 3479 3480#if FFETARGET_okINTEGER2 3481 case FFEINFO_kindtypeINTEGER2: 3482 *aptr = array.integer2 + offset; 3483 break; 3484#endif 3485 3486#if FFETARGET_okINTEGER3 3487 case FFEINFO_kindtypeINTEGER3: 3488 *aptr = array.integer3 + offset; 3489 break; 3490#endif 3491 3492#if FFETARGET_okINTEGER4 3493 case FFEINFO_kindtypeINTEGER4: 3494 *aptr = array.integer4 + offset; 3495 break; 3496#endif 3497 3498#if FFETARGET_okINTEGER5 3499 case FFEINFO_kindtypeINTEGER5: 3500 *aptr = array.integer5 + offset; 3501 break; 3502#endif 3503 3504#if FFETARGET_okINTEGER6 3505 case FFEINFO_kindtypeINTEGER6: 3506 *aptr = array.integer6 + offset; 3507 break; 3508#endif 3509 3510#if FFETARGET_okINTEGER7 3511 case FFEINFO_kindtypeINTEGER7: 3512 *aptr = array.integer7 + offset; 3513 break; 3514#endif 3515 3516#if FFETARGET_okINTEGER8 3517 case FFEINFO_kindtypeINTEGER8: 3518 *aptr = array.integer8 + offset; 3519 break; 3520#endif 3521 3522 default: 3523 assert ("bad INTEGER akindtype" == NULL); 3524 break; 3525 } 3526 break; 3527 3528 case FFEINFO_basictypeLOGICAL: 3529 switch (akt) 3530 { 3531#if FFETARGET_okLOGICAL1 3532 case FFEINFO_kindtypeLOGICAL1: 3533 *aptr = array.logical1 + offset; 3534 break; 3535#endif 3536 3537#if FFETARGET_okLOGICAL2 3538 case FFEINFO_kindtypeLOGICAL2: 3539 *aptr = array.logical2 + offset; 3540 break; 3541#endif 3542 3543#if FFETARGET_okLOGICAL3 3544 case FFEINFO_kindtypeLOGICAL3: 3545 *aptr = array.logical3 + offset; 3546 break; 3547#endif 3548 3549#if FFETARGET_okLOGICAL4 3550 case FFEINFO_kindtypeLOGICAL4: 3551 *aptr = array.logical4 + offset; 3552 break; 3553#endif 3554 3555#if FFETARGET_okLOGICAL5 3556 case FFEINFO_kindtypeLOGICAL5: 3557 *aptr = array.logical5 + offset; 3558 break; 3559#endif 3560 3561#if FFETARGET_okLOGICAL6 3562 case FFEINFO_kindtypeLOGICAL6: 3563 *aptr = array.logical6 + offset; 3564 break; 3565#endif 3566 3567#if FFETARGET_okLOGICAL7 3568 case FFEINFO_kindtypeLOGICAL7: 3569 *aptr = array.logical7 + offset; 3570 break; 3571#endif 3572 3573#if FFETARGET_okLOGICAL8 3574 case FFEINFO_kindtypeLOGICAL8: 3575 *aptr = array.logical8 + offset; 3576 break; 3577#endif 3578 3579 default: 3580 assert ("bad LOGICAL akindtype" == NULL); 3581 break; 3582 } 3583 break; 3584 3585 case FFEINFO_basictypeREAL: 3586 switch (akt) 3587 { 3588#if FFETARGET_okREAL1 3589 case FFEINFO_kindtypeREAL1: 3590 *aptr = array.real1 + offset; 3591 break; 3592#endif 3593 3594#if FFETARGET_okREAL2 3595 case FFEINFO_kindtypeREAL2: 3596 *aptr = array.real2 + offset; 3597 break; 3598#endif 3599 3600#if FFETARGET_okREAL3 3601 case FFEINFO_kindtypeREAL3: 3602 *aptr = array.real3 + offset; 3603 break; 3604#endif 3605 3606#if FFETARGET_okREAL4 3607 case FFEINFO_kindtypeREAL4: 3608 *aptr = array.real4 + offset; 3609 break; 3610#endif 3611 3612#if FFETARGET_okREAL5 3613 case FFEINFO_kindtypeREAL5: 3614 *aptr = array.real5 + offset; 3615 break; 3616#endif 3617 3618#if FFETARGET_okREAL6 3619 case FFEINFO_kindtypeREAL6: 3620 *aptr = array.real6 + offset; 3621 break; 3622#endif 3623 3624#if FFETARGET_okREAL7 3625 case FFEINFO_kindtypeREAL7: 3626 *aptr = array.real7 + offset; 3627 break; 3628#endif 3629 3630#if FFETARGET_okREAL8 3631 case FFEINFO_kindtypeREAL8: 3632 *aptr = array.real8 + offset; 3633 break; 3634#endif 3635 3636 default: 3637 assert ("bad REAL akindtype" == NULL); 3638 break; 3639 } 3640 break; 3641 3642 case FFEINFO_basictypeCOMPLEX: 3643 switch (akt) 3644 { 3645#if FFETARGET_okCOMPLEX1 3646 case FFEINFO_kindtypeREAL1: 3647 *aptr = array.complex1 + offset; 3648 break; 3649#endif 3650 3651#if FFETARGET_okCOMPLEX2 3652 case FFEINFO_kindtypeREAL2: 3653 *aptr = array.complex2 + offset; 3654 break; 3655#endif 3656 3657#if FFETARGET_okCOMPLEX3 3658 case FFEINFO_kindtypeREAL3: 3659 *aptr = array.complex3 + offset; 3660 break; 3661#endif 3662 3663#if FFETARGET_okCOMPLEX4 3664 case FFEINFO_kindtypeREAL4: 3665 *aptr = array.complex4 + offset; 3666 break; 3667#endif 3668 3669#if FFETARGET_okCOMPLEX5 3670 case FFEINFO_kindtypeREAL5: 3671 *aptr = array.complex5 + offset; 3672 break; 3673#endif 3674 3675#if FFETARGET_okCOMPLEX6 3676 case FFEINFO_kindtypeREAL6: 3677 *aptr = array.complex6 + offset; 3678 break; 3679#endif 3680 3681#if FFETARGET_okCOMPLEX7 3682 case FFEINFO_kindtypeREAL7: 3683 *aptr = array.complex7 + offset; 3684 break; 3685#endif 3686 3687#if FFETARGET_okCOMPLEX8 3688 case FFEINFO_kindtypeREAL8: 3689 *aptr = array.complex8 + offset; 3690 break; 3691#endif 3692 3693 default: 3694 assert ("bad COMPLEX akindtype" == NULL); 3695 break; 3696 } 3697 break; 3698 3699 case FFEINFO_basictypeCHARACTER: 3700 switch (akt) 3701 { 3702#if FFETARGET_okCHARACTER1 3703 case FFEINFO_kindtypeCHARACTER1: 3704 *aptr = array.character1 + offset; 3705 break; 3706#endif 3707 3708#if FFETARGET_okCHARACTER2 3709 case FFEINFO_kindtypeCHARACTER2: 3710 *aptr = array.character2 + offset; 3711 break; 3712#endif 3713 3714#if FFETARGET_okCHARACTER3 3715 case FFEINFO_kindtypeCHARACTER3: 3716 *aptr = array.character3 + offset; 3717 break; 3718#endif 3719 3720#if FFETARGET_okCHARACTER4 3721 case FFEINFO_kindtypeCHARACTER4: 3722 *aptr = array.character4 + offset; 3723 break; 3724#endif 3725 3726#if FFETARGET_okCHARACTER5 3727 case FFEINFO_kindtypeCHARACTER5: 3728 *aptr = array.character5 + offset; 3729 break; 3730#endif 3731 3732#if FFETARGET_okCHARACTER6 3733 case FFEINFO_kindtypeCHARACTER6: 3734 *aptr = array.character6 + offset; 3735 break; 3736#endif 3737 3738#if FFETARGET_okCHARACTER7 3739 case FFEINFO_kindtypeCHARACTER7: 3740 *aptr = array.character7 + offset; 3741 break; 3742#endif 3743 3744#if FFETARGET_okCHARACTER8 3745 case FFEINFO_kindtypeCHARACTER8: 3746 *aptr = array.character8 + offset; 3747 break; 3748#endif 3749 3750 default: 3751 assert ("bad CHARACTER akindtype" == NULL); 3752 break; 3753 } 3754 break; 3755 3756 default: 3757 assert ("bad abasictype" == NULL); 3758 break; 3759 } 3760 3761 switch (cbt) 3762 { 3763 case FFEINFO_basictypeINTEGER: 3764 switch (ckt) 3765 { 3766#if FFETARGET_okINTEGER1 3767 case FFEINFO_kindtypeINTEGER1: 3768 *cptr = &constant->integer1; 3769 *size = sizeof (constant->integer1); 3770 break; 3771#endif 3772 3773#if FFETARGET_okINTEGER2 3774 case FFEINFO_kindtypeINTEGER2: 3775 *cptr = &constant->integer2; 3776 *size = sizeof (constant->integer2); 3777 break; 3778#endif 3779 3780#if FFETARGET_okINTEGER3 3781 case FFEINFO_kindtypeINTEGER3: 3782 *cptr = &constant->integer3; 3783 *size = sizeof (constant->integer3); 3784 break; 3785#endif 3786 3787#if FFETARGET_okINTEGER4 3788 case FFEINFO_kindtypeINTEGER4: 3789 *cptr = &constant->integer4; 3790 *size = sizeof (constant->integer4); 3791 break; 3792#endif 3793 3794#if FFETARGET_okINTEGER5 3795 case FFEINFO_kindtypeINTEGER5: 3796 *cptr = &constant->integer5; 3797 *size = sizeof (constant->integer5); 3798 break; 3799#endif 3800 3801#if FFETARGET_okINTEGER6 3802 case FFEINFO_kindtypeINTEGER6: 3803 *cptr = &constant->integer6; 3804 *size = sizeof (constant->integer6); 3805 break; 3806#endif 3807 3808#if FFETARGET_okINTEGER7 3809 case FFEINFO_kindtypeINTEGER7: 3810 *cptr = &constant->integer7; 3811 *size = sizeof (constant->integer7); 3812 break; 3813#endif 3814 3815#if FFETARGET_okINTEGER8 3816 case FFEINFO_kindtypeINTEGER8: 3817 *cptr = &constant->integer8; 3818 *size = sizeof (constant->integer8); 3819 break; 3820#endif 3821 3822 default: 3823 assert ("bad INTEGER ckindtype" == NULL); 3824 break; 3825 } 3826 break; 3827 3828 case FFEINFO_basictypeLOGICAL: 3829 switch (ckt) 3830 { 3831#if FFETARGET_okLOGICAL1 3832 case FFEINFO_kindtypeLOGICAL1: 3833 *cptr = &constant->logical1; 3834 *size = sizeof (constant->logical1); 3835 break; 3836#endif 3837 3838#if FFETARGET_okLOGICAL2 3839 case FFEINFO_kindtypeLOGICAL2: 3840 *cptr = &constant->logical2; 3841 *size = sizeof (constant->logical2); 3842 break; 3843#endif 3844 3845#if FFETARGET_okLOGICAL3 3846 case FFEINFO_kindtypeLOGICAL3: 3847 *cptr = &constant->logical3; 3848 *size = sizeof (constant->logical3); 3849 break; 3850#endif 3851 3852#if FFETARGET_okLOGICAL4 3853 case FFEINFO_kindtypeLOGICAL4: 3854 *cptr = &constant->logical4; 3855 *size = sizeof (constant->logical4); 3856 break; 3857#endif 3858 3859#if FFETARGET_okLOGICAL5 3860 case FFEINFO_kindtypeLOGICAL5: 3861 *cptr = &constant->logical5; 3862 *size = sizeof (constant->logical5); 3863 break; 3864#endif 3865 3866#if FFETARGET_okLOGICAL6 3867 case FFEINFO_kindtypeLOGICAL6: 3868 *cptr = &constant->logical6; 3869 *size = sizeof (constant->logical6); 3870 break; 3871#endif 3872 3873#if FFETARGET_okLOGICAL7 3874 case FFEINFO_kindtypeLOGICAL7: 3875 *cptr = &constant->logical7; 3876 *size = sizeof (constant->logical7); 3877 break; 3878#endif 3879 3880#if FFETARGET_okLOGICAL8 3881 case FFEINFO_kindtypeLOGICAL8: 3882 *cptr = &constant->logical8; 3883 *size = sizeof (constant->logical8); 3884 break; 3885#endif 3886 3887 default: 3888 assert ("bad LOGICAL ckindtype" == NULL); 3889 break; 3890 } 3891 break; 3892 3893 case FFEINFO_basictypeREAL: 3894 switch (ckt) 3895 { 3896#if FFETARGET_okREAL1 3897 case FFEINFO_kindtypeREAL1: 3898 *cptr = &constant->real1; 3899 *size = sizeof (constant->real1); 3900 break; 3901#endif 3902 3903#if FFETARGET_okREAL2 3904 case FFEINFO_kindtypeREAL2: 3905 *cptr = &constant->real2; 3906 *size = sizeof (constant->real2); 3907 break; 3908#endif 3909 3910#if FFETARGET_okREAL3 3911 case FFEINFO_kindtypeREAL3: 3912 *cptr = &constant->real3; 3913 *size = sizeof (constant->real3); 3914 break; 3915#endif 3916 3917#if FFETARGET_okREAL4 3918 case FFEINFO_kindtypeREAL4: 3919 *cptr = &constant->real4; 3920 *size = sizeof (constant->real4); 3921 break; 3922#endif 3923 3924#if FFETARGET_okREAL5 3925 case FFEINFO_kindtypeREAL5: 3926 *cptr = &constant->real5; 3927 *size = sizeof (constant->real5); 3928 break; 3929#endif 3930 3931#if FFETARGET_okREAL6 3932 case FFEINFO_kindtypeREAL6: 3933 *cptr = &constant->real6; 3934 *size = sizeof (constant->real6); 3935 break; 3936#endif 3937 3938#if FFETARGET_okREAL7 3939 case FFEINFO_kindtypeREAL7: 3940 *cptr = &constant->real7; 3941 *size = sizeof (constant->real7); 3942 break; 3943#endif 3944 3945#if FFETARGET_okREAL8 3946 case FFEINFO_kindtypeREAL8: 3947 *cptr = &constant->real8; 3948 *size = sizeof (constant->real8); 3949 break; 3950#endif 3951 3952 default: 3953 assert ("bad REAL ckindtype" == NULL); 3954 break; 3955 } 3956 break; 3957 3958 case FFEINFO_basictypeCOMPLEX: 3959 switch (ckt) 3960 { 3961#if FFETARGET_okCOMPLEX1 3962 case FFEINFO_kindtypeREAL1: 3963 *cptr = &constant->complex1; 3964 *size = sizeof (constant->complex1); 3965 break; 3966#endif 3967 3968#if FFETARGET_okCOMPLEX2 3969 case FFEINFO_kindtypeREAL2: 3970 *cptr = &constant->complex2; 3971 *size = sizeof (constant->complex2); 3972 break; 3973#endif 3974 3975#if FFETARGET_okCOMPLEX3 3976 case FFEINFO_kindtypeREAL3: 3977 *cptr = &constant->complex3; 3978 *size = sizeof (constant->complex3); 3979 break; 3980#endif 3981 3982#if FFETARGET_okCOMPLEX4 3983 case FFEINFO_kindtypeREAL4: 3984 *cptr = &constant->complex4; 3985 *size = sizeof (constant->complex4); 3986 break; 3987#endif 3988 3989#if FFETARGET_okCOMPLEX5 3990 case FFEINFO_kindtypeREAL5: 3991 *cptr = &constant->complex5; 3992 *size = sizeof (constant->complex5); 3993 break; 3994#endif 3995 3996#if FFETARGET_okCOMPLEX6 3997 case FFEINFO_kindtypeREAL6: 3998 *cptr = &constant->complex6; 3999 *size = sizeof (constant->complex6); 4000 break; 4001#endif 4002 4003#if FFETARGET_okCOMPLEX7 4004 case FFEINFO_kindtypeREAL7: 4005 *cptr = &constant->complex7; 4006 *size = sizeof (constant->complex7); 4007 break; 4008#endif 4009 4010#if FFETARGET_okCOMPLEX8 4011 case FFEINFO_kindtypeREAL8: 4012 *cptr = &constant->complex8; 4013 *size = sizeof (constant->complex8); 4014 break; 4015#endif 4016 4017 default: 4018 assert ("bad COMPLEX ckindtype" == NULL); 4019 break; 4020 } 4021 break; 4022 4023 case FFEINFO_basictypeCHARACTER: 4024 switch (ckt) 4025 { 4026#if FFETARGET_okCHARACTER1 4027 case FFEINFO_kindtypeCHARACTER1: 4028 *cptr = ffetarget_text_character1 (constant->character1); 4029 *size = ffetarget_length_character1 (constant->character1); 4030 break; 4031#endif 4032 4033#if FFETARGET_okCHARACTER2 4034 case FFEINFO_kindtypeCHARACTER2: 4035 *cptr = ffetarget_text_character2 (constant->character2); 4036 *size = ffetarget_length_character2 (constant->character2); 4037 break; 4038#endif 4039 4040#if FFETARGET_okCHARACTER3 4041 case FFEINFO_kindtypeCHARACTER3: 4042 *cptr = ffetarget_text_character3 (constant->character3); 4043 *size = ffetarget_length_character3 (constant->character3); 4044 break; 4045#endif 4046 4047#if FFETARGET_okCHARACTER4 4048 case FFEINFO_kindtypeCHARACTER4: 4049 *cptr = ffetarget_text_character4 (constant->character4); 4050 *size = ffetarget_length_character4 (constant->character4); 4051 break; 4052#endif 4053 4054#if FFETARGET_okCHARACTER5 4055 case FFEINFO_kindtypeCHARACTER5: 4056 *cptr = ffetarget_text_character5 (constant->character5); 4057 *size = ffetarget_length_character5 (constant->character5); 4058 break; 4059#endif 4060 4061#if FFETARGET_okCHARACTER6 4062 case FFEINFO_kindtypeCHARACTER6: 4063 *cptr = ffetarget_text_character6 (constant->character6); 4064 *size = ffetarget_length_character6 (constant->character6); 4065 break; 4066#endif 4067 4068#if FFETARGET_okCHARACTER7 4069 case FFEINFO_kindtypeCHARACTER7: 4070 *cptr = ffetarget_text_character7 (constant->character7); 4071 *size = ffetarget_length_character7 (constant->character7); 4072 break; 4073#endif 4074 4075#if FFETARGET_okCHARACTER8 4076 case FFEINFO_kindtypeCHARACTER8: 4077 *cptr = ffetarget_text_character8 (constant->character8); 4078 *size = ffetarget_length_character8 (constant->character8); 4079 break; 4080#endif 4081 4082 default: 4083 assert ("bad CHARACTER ckindtype" == NULL); 4084 break; 4085 } 4086 break; 4087 4088 default: 4089 assert ("bad cbasictype" == NULL); 4090 break; 4091 } 4092} 4093 4094/* ffebld_constantarray_put -- Put a value into an array of constants 4095 4096 See prototype. */ 4097 4098void 4099ffebld_constantarray_put (ffebldConstantArray array, ffeinfoBasictype bt, 4100 ffeinfoKindtype kt, ffetargetOffset offset, ffebldConstantUnion constant) 4101{ 4102 switch (bt) 4103 { 4104 case FFEINFO_basictypeINTEGER: 4105 switch (kt) 4106 { 4107#if FFETARGET_okINTEGER1 4108 case FFEINFO_kindtypeINTEGER1: 4109 *(array.integer1 + offset) = constant.integer1; 4110 break; 4111#endif 4112 4113#if FFETARGET_okINTEGER2 4114 case FFEINFO_kindtypeINTEGER2: 4115 *(array.integer2 + offset) = constant.integer2; 4116 break; 4117#endif 4118 4119#if FFETARGET_okINTEGER3 4120 case FFEINFO_kindtypeINTEGER3: 4121 *(array.integer3 + offset) = constant.integer3; 4122 break; 4123#endif 4124 4125#if FFETARGET_okINTEGER4 4126 case FFEINFO_kindtypeINTEGER4: 4127 *(array.integer4 + offset) = constant.integer4; 4128 break; 4129#endif 4130 4131#if FFETARGET_okINTEGER5 4132 case FFEINFO_kindtypeINTEGER5: 4133 *(array.integer5 + offset) = constant.integer5; 4134 break; 4135#endif 4136 4137#if FFETARGET_okINTEGER6 4138 case FFEINFO_kindtypeINTEGER6: 4139 *(array.integer6 + offset) = constant.integer6; 4140 break; 4141#endif 4142 4143#if FFETARGET_okINTEGER7 4144 case FFEINFO_kindtypeINTEGER7: 4145 *(array.integer7 + offset) = constant.integer7; 4146 break; 4147#endif 4148 4149#if FFETARGET_okINTEGER8 4150 case FFEINFO_kindtypeINTEGER8: 4151 *(array.integer8 + offset) = constant.integer8; 4152 break; 4153#endif 4154 4155 default: 4156 assert ("bad INTEGER kindtype" == NULL); 4157 break; 4158 } 4159 break; 4160 4161 case FFEINFO_basictypeLOGICAL: 4162 switch (kt) 4163 { 4164#if FFETARGET_okLOGICAL1 4165 case FFEINFO_kindtypeLOGICAL1: 4166 *(array.logical1 + offset) = constant.logical1; 4167 break; 4168#endif 4169 4170#if FFETARGET_okLOGICAL2 4171 case FFEINFO_kindtypeLOGICAL2: 4172 *(array.logical2 + offset) = constant.logical2; 4173 break; 4174#endif 4175 4176#if FFETARGET_okLOGICAL3 4177 case FFEINFO_kindtypeLOGICAL3: 4178 *(array.logical3 + offset) = constant.logical3; 4179 break; 4180#endif 4181 4182#if FFETARGET_okLOGICAL4 4183 case FFEINFO_kindtypeLOGICAL4: 4184 *(array.logical4 + offset) = constant.logical4; 4185 break; 4186#endif 4187 4188#if FFETARGET_okLOGICAL5 4189 case FFEINFO_kindtypeLOGICAL5: 4190 *(array.logical5 + offset) = constant.logical5; 4191 break; 4192#endif 4193 4194#if FFETARGET_okLOGICAL6 4195 case FFEINFO_kindtypeLOGICAL6: 4196 *(array.logical6 + offset) = constant.logical6; 4197 break; 4198#endif 4199 4200#if FFETARGET_okLOGICAL7 4201 case FFEINFO_kindtypeLOGICAL7: 4202 *(array.logical7 + offset) = constant.logical7; 4203 break; 4204#endif 4205 4206#if FFETARGET_okLOGICAL8 4207 case FFEINFO_kindtypeLOGICAL8: 4208 *(array.logical8 + offset) = constant.logical8; 4209 break; 4210#endif 4211 4212 default: 4213 assert ("bad LOGICAL kindtype" == NULL); 4214 break; 4215 } 4216 break; 4217 4218 case FFEINFO_basictypeREAL: 4219 switch (kt) 4220 { 4221#if FFETARGET_okREAL1 4222 case FFEINFO_kindtypeREAL1: 4223 *(array.real1 + offset) = constant.real1; 4224 break; 4225#endif 4226 4227#if FFETARGET_okREAL2 4228 case FFEINFO_kindtypeREAL2: 4229 *(array.real2 + offset) = constant.real2; 4230 break; 4231#endif 4232 4233#if FFETARGET_okREAL3 4234 case FFEINFO_kindtypeREAL3: 4235 *(array.real3 + offset) = constant.real3; 4236 break; 4237#endif 4238 4239#if FFETARGET_okREAL4 4240 case FFEINFO_kindtypeREAL4: 4241 *(array.real4 + offset) = constant.real4; 4242 break; 4243#endif 4244 4245#if FFETARGET_okREAL5 4246 case FFEINFO_kindtypeREAL5: 4247 *(array.real5 + offset) = constant.real5; 4248 break; 4249#endif 4250 4251#if FFETARGET_okREAL6 4252 case FFEINFO_kindtypeREAL6: 4253 *(array.real6 + offset) = constant.real6; 4254 break; 4255#endif 4256 4257#if FFETARGET_okREAL7 4258 case FFEINFO_kindtypeREAL7: 4259 *(array.real7 + offset) = constant.real7; 4260 break; 4261#endif 4262 4263#if FFETARGET_okREAL8 4264 case FFEINFO_kindtypeREAL8: 4265 *(array.real8 + offset) = constant.real8; 4266 break; 4267#endif 4268 4269 default: 4270 assert ("bad REAL kindtype" == NULL); 4271 break; 4272 } 4273 break; 4274 4275 case FFEINFO_basictypeCOMPLEX: 4276 switch (kt) 4277 { 4278#if FFETARGET_okCOMPLEX1 4279 case FFEINFO_kindtypeREAL1: 4280 *(array.complex1 + offset) = constant.complex1; 4281 break; 4282#endif 4283 4284#if FFETARGET_okCOMPLEX2 4285 case FFEINFO_kindtypeREAL2: 4286 *(array.complex2 + offset) = constant.complex2; 4287 break; 4288#endif 4289 4290#if FFETARGET_okCOMPLEX3 4291 case FFEINFO_kindtypeREAL3: 4292 *(array.complex3 + offset) = constant.complex3; 4293 break; 4294#endif 4295 4296#if FFETARGET_okCOMPLEX4 4297 case FFEINFO_kindtypeREAL4: 4298 *(array.complex4 + offset) = constant.complex4; 4299 break; 4300#endif 4301 4302#if FFETARGET_okCOMPLEX5 4303 case FFEINFO_kindtypeREAL5: 4304 *(array.complex5 + offset) = constant.complex5; 4305 break; 4306#endif 4307 4308#if FFETARGET_okCOMPLEX6 4309 case FFEINFO_kindtypeREAL6: 4310 *(array.complex6 + offset) = constant.complex6; 4311 break; 4312#endif 4313 4314#if FFETARGET_okCOMPLEX7 4315 case FFEINFO_kindtypeREAL7: 4316 *(array.complex7 + offset) = constant.complex7; 4317 break; 4318#endif 4319 4320#if FFETARGET_okCOMPLEX8 4321 case FFEINFO_kindtypeREAL8: 4322 *(array.complex8 + offset) = constant.complex8; 4323 break; 4324#endif 4325 4326 default: 4327 assert ("bad COMPLEX kindtype" == NULL); 4328 break; 4329 } 4330 break; 4331 4332 case FFEINFO_basictypeCHARACTER: 4333 switch (kt) 4334 { 4335#if FFETARGET_okCHARACTER1 4336 case FFEINFO_kindtypeCHARACTER1: 4337 memcpy (array.character1 + offset, 4338 ffetarget_text_character1 (constant.character1), 4339 ffetarget_length_character1 (constant.character1)); 4340 break; 4341#endif 4342 4343#if FFETARGET_okCHARACTER2 4344 case FFEINFO_kindtypeCHARACTER2: 4345 memcpy (array.character2 + offset, 4346 ffetarget_text_character2 (constant.character2), 4347 ffetarget_length_character2 (constant.character2)); 4348 break; 4349#endif 4350 4351#if FFETARGET_okCHARACTER3 4352 case FFEINFO_kindtypeCHARACTER3: 4353 memcpy (array.character3 + offset, 4354 ffetarget_text_character3 (constant.character3), 4355 ffetarget_length_character3 (constant.character3)); 4356 break; 4357#endif 4358 4359#if FFETARGET_okCHARACTER4 4360 case FFEINFO_kindtypeCHARACTER4: 4361 memcpy (array.character4 + offset, 4362 ffetarget_text_character4 (constant.character4), 4363 ffetarget_length_character4 (constant.character4)); 4364 break; 4365#endif 4366 4367#if FFETARGET_okCHARACTER5 4368 case FFEINFO_kindtypeCHARACTER5: 4369 memcpy (array.character5 + offset, 4370 ffetarget_text_character5 (constant.character5), 4371 ffetarget_length_character5 (constant.character5)); 4372 break; 4373#endif 4374 4375#if FFETARGET_okCHARACTER6 4376 case FFEINFO_kindtypeCHARACTER6: 4377 memcpy (array.character6 + offset, 4378 ffetarget_text_character6 (constant.character6), 4379 ffetarget_length_character6 (constant.character6)); 4380 break; 4381#endif 4382 4383#if FFETARGET_okCHARACTER7 4384 case FFEINFO_kindtypeCHARACTER7: 4385 memcpy (array.character7 + offset, 4386 ffetarget_text_character7 (constant.character7), 4387 ffetarget_length_character7 (constant.character7)); 4388 break; 4389#endif 4390 4391#if FFETARGET_okCHARACTER8 4392 case FFEINFO_kindtypeCHARACTER8: 4393 memcpy (array.character8 + offset, 4394 ffetarget_text_character8 (constant.character8), 4395 ffetarget_length_character8 (constant.character8)); 4396 break; 4397#endif 4398 4399 default: 4400 assert ("bad CHARACTER kindtype" == NULL); 4401 break; 4402 } 4403 break; 4404 4405 default: 4406 assert ("bad basictype" == NULL); 4407 break; 4408 } 4409} 4410 4411/* ffebld_constantunion_dump -- Dump a constant 4412 4413 See prototype. */ 4414 4415#if FFECOM_targetCURRENT == FFECOM_targetFFE 4416void 4417ffebld_constantunion_dump (ffebldConstantUnion u, ffeinfoBasictype bt, 4418 ffeinfoKindtype kt) 4419{ 4420 switch (bt) 4421 { 4422 case FFEINFO_basictypeINTEGER: 4423 switch (kt) 4424 { 4425#if FFETARGET_okINTEGER1 4426 case FFEINFO_kindtypeINTEGER1: 4427 ffetarget_print_integer1 (dmpout, u.integer1); 4428 break; 4429#endif 4430 4431#if FFETARGET_okINTEGER2 4432 case FFEINFO_kindtypeINTEGER2: 4433 ffetarget_print_integer2 (dmpout, u.integer2); 4434 break; 4435#endif 4436 4437#if FFETARGET_okINTEGER3 4438 case FFEINFO_kindtypeINTEGER3: 4439 ffetarget_print_integer3 (dmpout, u.integer3); 4440 break; 4441#endif 4442 4443#if FFETARGET_okINTEGER4 4444 case FFEINFO_kindtypeINTEGER4: 4445 ffetarget_print_integer4 (dmpout, u.integer4); 4446 break; 4447#endif 4448 4449#if FFETARGET_okINTEGER5 4450 case FFEINFO_kindtypeINTEGER5: 4451 ffetarget_print_integer5 (dmpout, u.integer5); 4452 break; 4453#endif 4454 4455#if FFETARGET_okINTEGER6 4456 case FFEINFO_kindtypeINTEGER6: 4457 ffetarget_print_integer6 (dmpout, u.integer6); 4458 break; 4459#endif 4460 4461#if FFETARGET_okINTEGER7 4462 case FFEINFO_kindtypeINTEGER7: 4463 ffetarget_print_integer7 (dmpout, u.integer7); 4464 break; 4465#endif 4466 4467#if FFETARGET_okINTEGER8 4468 case FFEINFO_kindtypeINTEGER8: 4469 ffetarget_print_integer8 (dmpout, u.integer8); 4470 break; 4471#endif 4472 4473 default: 4474 assert ("bad INTEGER kindtype" == NULL); 4475 break; 4476 } 4477 break; 4478 4479 case FFEINFO_basictypeLOGICAL: 4480 switch (kt) 4481 { 4482#if FFETARGET_okLOGICAL1 4483 case FFEINFO_kindtypeLOGICAL1: 4484 ffetarget_print_logical1 (dmpout, u.logical1); 4485 break; 4486#endif 4487 4488#if FFETARGET_okLOGICAL2 4489 case FFEINFO_kindtypeLOGICAL2: 4490 ffetarget_print_logical2 (dmpout, u.logical2); 4491 break; 4492#endif 4493 4494#if FFETARGET_okLOGICAL3 4495 case FFEINFO_kindtypeLOGICAL3: 4496 ffetarget_print_logical3 (dmpout, u.logical3); 4497 break; 4498#endif 4499 4500#if FFETARGET_okLOGICAL4 4501 case FFEINFO_kindtypeLOGICAL4: 4502 ffetarget_print_logical4 (dmpout, u.logical4); 4503 break; 4504#endif 4505 4506#if FFETARGET_okLOGICAL5 4507 case FFEINFO_kindtypeLOGICAL5: 4508 ffetarget_print_logical5 (dmpout, u.logical5); 4509 break; 4510#endif 4511 4512#if FFETARGET_okLOGICAL6 4513 case FFEINFO_kindtypeLOGICAL6: 4514 ffetarget_print_logical6 (dmpout, u.logical6); 4515 break; 4516#endif 4517 4518#if FFETARGET_okLOGICAL7 4519 case FFEINFO_kindtypeLOGICAL7: 4520 ffetarget_print_logical7 (dmpout, u.logical7); 4521 break; 4522#endif 4523 4524#if FFETARGET_okLOGICAL8 4525 case FFEINFO_kindtypeLOGICAL8: 4526 ffetarget_print_logical8 (dmpout, u.logical8); 4527 break; 4528#endif 4529 4530 default: 4531 assert ("bad LOGICAL kindtype" == NULL); 4532 break; 4533 } 4534 break; 4535 4536 case FFEINFO_basictypeREAL: 4537 switch (kt) 4538 { 4539#if FFETARGET_okREAL1 4540 case FFEINFO_kindtypeREAL1: 4541 ffetarget_print_real1 (dmpout, u.real1); 4542 break; 4543#endif 4544 4545#if FFETARGET_okREAL2 4546 case FFEINFO_kindtypeREAL2: 4547 ffetarget_print_real2 (dmpout, u.real2); 4548 break; 4549#endif 4550 4551#if FFETARGET_okREAL3 4552 case FFEINFO_kindtypeREAL3: 4553 ffetarget_print_real3 (dmpout, u.real3); 4554 break; 4555#endif 4556 4557#if FFETARGET_okREAL4 4558 case FFEINFO_kindtypeREAL4: 4559 ffetarget_print_real4 (dmpout, u.real4); 4560 break; 4561#endif 4562 4563#if FFETARGET_okREAL5 4564 case FFEINFO_kindtypeREAL5: 4565 ffetarget_print_real5 (dmpout, u.real5); 4566 break; 4567#endif 4568 4569#if FFETARGET_okREAL6 4570 case FFEINFO_kindtypeREAL6: 4571 ffetarget_print_real6 (dmpout, u.real6); 4572 break; 4573#endif 4574 4575#if FFETARGET_okREAL7 4576 case FFEINFO_kindtypeREAL7: 4577 ffetarget_print_real7 (dmpout, u.real7); 4578 break; 4579#endif 4580 4581#if FFETARGET_okREAL8 4582 case FFEINFO_kindtypeREAL8: 4583 ffetarget_print_real8 (dmpout, u.real8); 4584 break; 4585#endif 4586 4587 default: 4588 assert ("bad REAL kindtype" == NULL); 4589 break; 4590 } 4591 break; 4592 4593 case FFEINFO_basictypeCOMPLEX: 4594 switch (kt) 4595 { 4596#if FFETARGET_okCOMPLEX1 4597 case FFEINFO_kindtypeREAL1: 4598 fprintf (dmpout, "("); 4599 ffetarget_print_real1 (dmpout, u.complex1.real); 4600 fprintf (dmpout, ","); 4601 ffetarget_print_real1 (dmpout, u.complex1.imaginary); 4602 fprintf (dmpout, ")"); 4603 break; 4604#endif 4605 4606#if FFETARGET_okCOMPLEX2 4607 case FFEINFO_kindtypeREAL2: 4608 fprintf (dmpout, "("); 4609 ffetarget_print_real2 (dmpout, u.complex2.real); 4610 fprintf (dmpout, ","); 4611 ffetarget_print_real2 (dmpout, u.complex2.imaginary); 4612 fprintf (dmpout, ")"); 4613 break; 4614#endif 4615 4616#if FFETARGET_okCOMPLEX3 4617 case FFEINFO_kindtypeREAL3: 4618 fprintf (dmpout, "("); 4619 ffetarget_print_real3 (dmpout, u.complex3.real); 4620 fprintf (dmpout, ","); 4621 ffetarget_print_real3 (dmpout, u.complex3.imaginary); 4622 fprintf (dmpout, ")"); 4623 break; 4624#endif 4625 4626#if FFETARGET_okCOMPLEX4 4627 case FFEINFO_kindtypeREAL4: 4628 fprintf (dmpout, "("); 4629 ffetarget_print_real4 (dmpout, u.complex4.real); 4630 fprintf (dmpout, ","); 4631 ffetarget_print_real4 (dmpout, u.complex4.imaginary); 4632 fprintf (dmpout, ")"); 4633 break; 4634#endif 4635 4636#if FFETARGET_okCOMPLEX5 4637 case FFEINFO_kindtypeREAL5: 4638 fprintf (dmpout, "("); 4639 ffetarget_print_real5 (dmpout, u.complex5.real); 4640 fprintf (dmpout, ","); 4641 ffetarget_print_real5 (dmpout, u.complex5.imaginary); 4642 fprintf (dmpout, ")"); 4643 break; 4644#endif 4645 4646#if FFETARGET_okCOMPLEX6 4647 case FFEINFO_kindtypeREAL6: 4648 fprintf (dmpout, "("); 4649 ffetarget_print_real6 (dmpout, u.complex6.real); 4650 fprintf (dmpout, ","); 4651 ffetarget_print_real6 (dmpout, u.complex6.imaginary); 4652 fprintf (dmpout, ")"); 4653 break; 4654#endif 4655 4656#if FFETARGET_okCOMPLEX7 4657 case FFEINFO_kindtypeREAL7: 4658 fprintf (dmpout, "("); 4659 ffetarget_print_real7 (dmpout, u.complex7.real); 4660 fprintf (dmpout, ","); 4661 ffetarget_print_real7 (dmpout, u.complex7.imaginary); 4662 fprintf (dmpout, ")"); 4663 break; 4664#endif 4665 4666#if FFETARGET_okCOMPLEX8 4667 case FFEINFO_kindtypeREAL8: 4668 fprintf (dmpout, "("); 4669 ffetarget_print_real8 (dmpout, u.complex8.real); 4670 fprintf (dmpout, ","); 4671 ffetarget_print_real8 (dmpout, u.complex8.imaginary); 4672 fprintf (dmpout, ")"); 4673 break; 4674#endif 4675 4676 default: 4677 assert ("bad COMPLEX kindtype" == NULL); 4678 break; 4679 } 4680 break; 4681 4682 case FFEINFO_basictypeCHARACTER: 4683 switch (kt) 4684 { 4685#if FFETARGET_okCHARACTER1 4686 case FFEINFO_kindtypeCHARACTER1: 4687 ffetarget_print_character1 (dmpout, u.character1); 4688 break; 4689#endif 4690 4691#if FFETARGET_okCHARACTER2 4692 case FFEINFO_kindtypeCHARACTER2: 4693 ffetarget_print_character2 (dmpout, u.character2); 4694 break; 4695#endif 4696 4697#if FFETARGET_okCHARACTER3 4698 case FFEINFO_kindtypeCHARACTER3: 4699 ffetarget_print_character3 (dmpout, u.character3); 4700 break; 4701#endif 4702 4703#if FFETARGET_okCHARACTER4 4704 case FFEINFO_kindtypeCHARACTER4: 4705 ffetarget_print_character4 (dmpout, u.character4); 4706 break; 4707#endif 4708 4709#if FFETARGET_okCHARACTER5 4710 case FFEINFO_kindtypeCHARACTER5: 4711 ffetarget_print_character5 (dmpout, u.character5); 4712 break; 4713#endif 4714 4715#if FFETARGET_okCHARACTER6 4716 case FFEINFO_kindtypeCHARACTER6: 4717 ffetarget_print_character6 (dmpout, u.character6); 4718 break; 4719#endif 4720 4721#if FFETARGET_okCHARACTER7 4722 case FFEINFO_kindtypeCHARACTER7: 4723 ffetarget_print_character7 (dmpout, u.character7); 4724 break; 4725#endif 4726 4727#if FFETARGET_okCHARACTER8 4728 case FFEINFO_kindtypeCHARACTER8: 4729 ffetarget_print_character8 (dmpout, u.character8); 4730 break; 4731#endif 4732 4733 default: 4734 assert ("bad CHARACTER kindtype" == NULL); 4735 break; 4736 } 4737 break; 4738 4739 default: 4740 assert ("bad basictype" == NULL); 4741 break; 4742 } 4743} 4744#endif 4745 4746/* ffebld_dump -- Dump expression tree in concise form 4747 4748 ffebld b; 4749 ffebld_dump(b); */ 4750 4751#if FFECOM_targetCURRENT == FFECOM_targetFFE 4752void 4753ffebld_dump (ffebld b) 4754{ 4755 ffeinfoKind k; 4756 ffeinfoWhere w; 4757 4758 if (b == NULL) 4759 { 4760 fprintf (dmpout, "(null)"); 4761 return; 4762 } 4763 4764 switch (ffebld_op (b)) 4765 { 4766 case FFEBLD_opITEM: 4767 fputs ("[", dmpout); 4768 while (b != NULL) 4769 { 4770 ffebld_dump (ffebld_head (b)); 4771 if ((b = ffebld_trail (b)) != NULL) 4772 fputs (",", dmpout); 4773 } 4774 fputs ("]", dmpout); 4775 return; 4776 4777 case FFEBLD_opSTAR: 4778 case FFEBLD_opBOUNDS: 4779 case FFEBLD_opREPEAT: 4780 case FFEBLD_opLABTER: 4781 case FFEBLD_opLABTOK: 4782 case FFEBLD_opIMPDO: 4783 fputs (ffebld_op_string (ffebld_op (b)), dmpout); 4784 break; 4785 4786 default: 4787 if (ffeinfo_size (ffebld_info (b)) != FFETARGET_charactersizeNONE) 4788 fprintf (dmpout, "%s%d%s%s*%" ffetargetCharacterSize_f "u", 4789 ffebld_op_string (ffebld_op (b)), 4790 (int) ffeinfo_rank (ffebld_info (b)), 4791 ffeinfo_basictype_string (ffeinfo_basictype (ffebld_info (b))), 4792 ffeinfo_kindtype_string (ffeinfo_kindtype (ffebld_info (b))), 4793 ffeinfo_size (ffebld_info (b))); 4794 else 4795 fprintf (dmpout, "%s%d%s%s", ffebld_op_string (ffebld_op (b)), 4796 (int) ffeinfo_rank (ffebld_info (b)), 4797 ffeinfo_basictype_string (ffeinfo_basictype (ffebld_info (b))), 4798 ffeinfo_kindtype_string (ffeinfo_kindtype (ffebld_info (b)))); 4799 if ((k = ffeinfo_kind (ffebld_info (b))) != FFEINFO_kindNONE) 4800 fprintf (dmpout, "/%s", ffeinfo_kind_string (k)); 4801 if ((w = ffeinfo_where (ffebld_info (b))) != FFEINFO_whereNONE) 4802 fprintf (dmpout, "@%s", ffeinfo_where_string (w)); 4803 break; 4804 } 4805 4806 switch (ffebld_arity (b)) 4807 { 4808 case 2: 4809 fputs ("(", dmpout); 4810 ffebld_dump (ffebld_left (b)); 4811 fputs (",", dmpout); 4812 ffebld_dump (ffebld_right (b)); 4813 fputs (")", dmpout); 4814 break; 4815 4816 case 1: 4817 fputs ("(", dmpout); 4818 ffebld_dump (ffebld_left (b)); 4819 fputs (")", dmpout); 4820 break; 4821 4822 default: 4823 switch (ffebld_op (b)) 4824 { 4825 case FFEBLD_opCONTER: 4826 fprintf (dmpout, "<"); 4827 ffebld_constant_dump (b->u.conter.expr); 4828 fprintf (dmpout, ">"); 4829 break; 4830 4831 case FFEBLD_opACCTER: 4832 fprintf (dmpout, "<"); 4833 ffebld_constantarray_dump (b->u.accter.array, 4834 ffeinfo_basictype (ffebld_info (b)), 4835 ffeinfo_kindtype (ffebld_info (b)), 4836 ffebit_size (b->u.accter.bits), b->u.accter.bits); 4837 fprintf (dmpout, ">"); 4838 break; 4839 4840 case FFEBLD_opARRTER: 4841 fprintf (dmpout, "<"); 4842 ffebld_constantarray_dump (b->u.arrter.array, 4843 ffeinfo_basictype (ffebld_info (b)), 4844 ffeinfo_kindtype (ffebld_info (b)), 4845 b->u.arrter.size, NULL); 4846 fprintf (dmpout, ">"); 4847 break; 4848 4849 case FFEBLD_opLABTER: 4850 if (b->u.labter == NULL) 4851 fprintf (dmpout, "<>"); 4852 else 4853 fprintf (dmpout, "<%" ffelabValue_f "u>", ffelab_value (b->u.labter)); 4854 break; 4855 4856 case FFEBLD_opLABTOK: 4857 fprintf (dmpout, "<%s>", ffelex_token_text (b->u.labtok)); 4858 break; 4859 4860 case FFEBLD_opSYMTER: 4861 fprintf (dmpout, "<"); 4862 ffesymbol_dump (b->u.symter.symbol); 4863 if ((b->u.symter.generic != FFEINTRIN_genNONE) 4864 || (b->u.symter.specific != FFEINTRIN_specNONE)) 4865 fprintf (dmpout, "{%s:%s:%s}", 4866 ffeintrin_name_generic (b->u.symter.generic), 4867 ffeintrin_name_specific (b->u.symter.specific), 4868 ffeintrin_name_implementation (b->u.symter.implementation)); 4869 if (b->u.symter.do_iter) 4870 fprintf (dmpout, "{/do-iter}"); 4871 fprintf (dmpout, ">"); 4872 break; 4873 4874 default: 4875 break; 4876 } 4877 } 4878} 4879#endif 4880 4881/* ffebld_dump_prefix -- Dump the prefix for a constant of a given type 4882 4883 ffebld_dump_prefix(dmpout,FFEINFO_basictypeINTEGER, 4884 FFEINFO_kindtypeINTEGER1); */ 4885 4886#if FFECOM_targetCURRENT == FFECOM_targetFFE 4887void 4888ffebld_dump_prefix (FILE *out, ffeinfoBasictype bt, ffeinfoKindtype kt) 4889{ 4890 switch (bt) 4891 { 4892 case FFEINFO_basictypeINTEGER: 4893 switch (kt) 4894 { 4895#if FFETARGET_okINTEGER1 4896 case FFEINFO_kindtypeINTEGER1: 4897 fprintf (out, "I" STRX (FFETARGET_kindINTEGER1) "/"); 4898 break; 4899#endif 4900 4901#if FFETARGET_okINTEGER2 4902 case FFEINFO_kindtypeINTEGER2: 4903 fprintf (out, "I" STRX (FFETARGET_kindINTEGER2) "/"); 4904 break; 4905#endif 4906 4907#if FFETARGET_okINTEGER3 4908 case FFEINFO_kindtypeINTEGER3: 4909 fprintf (out, "I" STRX (FFETARGET_kindINTEGER3) "/"); 4910 break; 4911#endif 4912 4913#if FFETARGET_okINTEGER4 4914 case FFEINFO_kindtypeINTEGER4: 4915 fprintf (out, "I" STRX (FFETARGET_kindINTEGER4) "/"); 4916 break; 4917#endif 4918 4919#if FFETARGET_okINTEGER5 4920 case FFEINFO_kindtypeINTEGER5: 4921 fprintf (out, "I" STRX (FFETARGET_kindINTEGER5) "/"); 4922 break; 4923#endif 4924 4925#if FFETARGET_okINTEGER6 4926 case FFEINFO_kindtypeINTEGER6: 4927 fprintf (out, "I" STRX (FFETARGET_kindINTEGER6) "/"); 4928 break; 4929#endif 4930 4931#if FFETARGET_okINTEGER7 4932 case FFEINFO_kindtypeINTEGER7: 4933 fprintf (out, "I" STRX (FFETARGET_kindINTEGER7) "/"); 4934 break; 4935#endif 4936 4937#if FFETARGET_okINTEGER8 4938 case FFEINFO_kindtypeINTEGER8: 4939 fprintf (out, "I" STRX (FFETARGET_kindINTEGER8) "/"); 4940 break; 4941#endif 4942 4943 default: 4944 assert ("bad INTEGER kindtype" == NULL); 4945 break; 4946 } 4947 break; 4948 4949 case FFEINFO_basictypeLOGICAL: 4950 switch (kt) 4951 { 4952#if FFETARGET_okLOGICAL1 4953 case FFEINFO_kindtypeLOGICAL1: 4954 fprintf (out, "L" STRX (FFETARGET_kindLOGICAL1) "/"); 4955 break; 4956#endif 4957 4958#if FFETARGET_okLOGICAL2 4959 case FFEINFO_kindtypeLOGICAL2: 4960 fprintf (out, "L" STRX (FFETARGET_kindLOGICAL2) "/"); 4961 break; 4962#endif 4963 4964#if FFETARGET_okLOGICAL3 4965 case FFEINFO_kindtypeLOGICAL3: 4966 fprintf (out, "L" STRX (FFETARGET_kindLOGICAL3) "/"); 4967 break; 4968#endif 4969 4970#if FFETARGET_okLOGICAL4 4971 case FFEINFO_kindtypeLOGICAL4: 4972 fprintf (out, "L" STRX (FFETARGET_kindLOGICAL4) "/"); 4973 break; 4974#endif 4975 4976#if FFETARGET_okLOGICAL5 4977 case FFEINFO_kindtypeLOGICAL5: 4978 fprintf (out, "L" STRX (FFETARGET_kindLOGICAL5) "/"); 4979 break; 4980#endif 4981 4982#if FFETARGET_okLOGICAL6 4983 case FFEINFO_kindtypeLOGICAL6: 4984 fprintf (out, "L" STRX (FFETARGET_kindLOGICAL6) "/"); 4985 break; 4986#endif 4987 4988#if FFETARGET_okLOGICAL7 4989 case FFEINFO_kindtypeLOGICAL7: 4990 fprintf (out, "L" STRX (FFETARGET_kindLOGICAL7) "/"); 4991 break; 4992#endif 4993 4994#if FFETARGET_okLOGICAL8 4995 case FFEINFO_kindtypeLOGICAL8: 4996 fprintf (out, "L" STRX (FFETARGET_kindLOGICAL8) "/"); 4997 break; 4998#endif 4999 5000 default: 5001 assert ("bad LOGICAL kindtype" == NULL); 5002 break; 5003 } 5004 break; 5005 5006 case FFEINFO_basictypeREAL: 5007 switch (kt) 5008 { 5009#if FFETARGET_okREAL1 5010 case FFEINFO_kindtypeREAL1: 5011 fprintf (out, "R" STRX (FFETARGET_kindREAL1) "/"); 5012 break; 5013#endif 5014 5015#if FFETARGET_okREAL2 5016 case FFEINFO_kindtypeREAL2: 5017 fprintf (out, "R" STRX (FFETARGET_kindREAL2) "/"); 5018 break; 5019#endif 5020 5021#if FFETARGET_okREAL3 5022 case FFEINFO_kindtypeREAL3: 5023 fprintf (out, "R" STRX (FFETARGET_kindREAL3) "/"); 5024 break; 5025#endif 5026 5027#if FFETARGET_okREAL4 5028 case FFEINFO_kindtypeREAL4: 5029 fprintf (out, "R" STRX (FFETARGET_kindREAL4) "/"); 5030 break; 5031#endif 5032 5033#if FFETARGET_okREAL5 5034 case FFEINFO_kindtypeREAL5: 5035 fprintf (out, "R" STRX (FFETARGET_kindREAL5) "/"); 5036 break; 5037#endif 5038 5039#if FFETARGET_okREAL6 5040 case FFEINFO_kindtypeREAL6: 5041 fprintf (out, "R" STRX (FFETARGET_kindREAL6) "/"); 5042 break; 5043#endif 5044 5045#if FFETARGET_okREAL7 5046 case FFEINFO_kindtypeREAL7: 5047 fprintf (out, "R" STRX (FFETARGET_kindREAL7) "/"); 5048 break; 5049#endif 5050 5051#if FFETARGET_okREAL8 5052 case FFEINFO_kindtypeREAL8: 5053 fprintf (out, "R" STRX (FFETARGET_kindREAL8) "/"); 5054 break; 5055#endif 5056 5057 default: 5058 assert ("bad REAL kindtype" == NULL); 5059 break; 5060 } 5061 break; 5062 5063 case FFEINFO_basictypeCOMPLEX: 5064 switch (kt) 5065 { 5066#if FFETARGET_okCOMPLEX1 5067 case FFEINFO_kindtypeREAL1: 5068 fprintf (out, "C" STRX (FFETARGET_kindCOMPLEX1) "/"); 5069 break; 5070#endif 5071 5072#if FFETARGET_okCOMPLEX2 5073 case FFEINFO_kindtypeREAL2: 5074 fprintf (out, "C" STRX (FFETARGET_kindCOMPLEX2) "/"); 5075 break; 5076#endif 5077 5078#if FFETARGET_okCOMPLEX3 5079 case FFEINFO_kindtypeREAL3: 5080 fprintf (out, "C" STRX (FFETARGET_kindCOMPLEX3) "/"); 5081 break; 5082#endif 5083 5084#if FFETARGET_okCOMPLEX4 5085 case FFEINFO_kindtypeREAL4: 5086 fprintf (out, "C" STRX (FFETARGET_kindCOMPLEX4) "/"); 5087 break; 5088#endif 5089 5090#if FFETARGET_okCOMPLEX5 5091 case FFEINFO_kindtypeREAL5: 5092 fprintf (out, "C" STRX (FFETARGET_kindCOMPLEX5) "/"); 5093 break; 5094#endif 5095 5096#if FFETARGET_okCOMPLEX6 5097 case FFEINFO_kindtypeREAL6: 5098 fprintf (out, "C" STRX (FFETARGET_kindCOMPLEX6) "/"); 5099 break; 5100#endif 5101 5102#if FFETARGET_okCOMPLEX7 5103 case FFEINFO_kindtypeREAL7: 5104 fprintf (out, "C" STRX (FFETARGET_kindCOMPLEX7) "/"); 5105 break; 5106#endif 5107 5108#if FFETARGET_okCOMPLEX8 5109 case FFEINFO_kindtypeREAL8: 5110 fprintf (out, "C" STRX (FFETARGET_kindCOMPLEX8) "/"); 5111 break; 5112#endif 5113 5114 default: 5115 assert ("bad COMPLEX kindtype" == NULL); 5116 break; 5117 } 5118 break; 5119 5120 case FFEINFO_basictypeCHARACTER: 5121 switch (kt) 5122 { 5123#if FFETARGET_okCHARACTER1 5124 case FFEINFO_kindtypeCHARACTER1: 5125 fprintf (out, "A" STRX (FFETARGET_kindCHARACTER1) "/"); 5126 break; 5127#endif 5128 5129#if FFETARGET_okCHARACTER2 5130 case FFEINFO_kindtypeCHARACTER2: 5131 fprintf (out, "A" STRX (FFETARGET_kindCHARACTER2) "/"); 5132 break; 5133#endif 5134 5135#if FFETARGET_okCHARACTER3 5136 case FFEINFO_kindtypeCHARACTER3: 5137 fprintf (out, "A" STRX (FFETARGET_kindCHARACTER3) "/"); 5138 break; 5139#endif 5140 5141#if FFETARGET_okCHARACTER4 5142 case FFEINFO_kindtypeCHARACTER4: 5143 fprintf (out, "A" STRX (FFETARGET_kindCHARACTER4) "/"); 5144 break; 5145#endif 5146 5147#if FFETARGET_okCHARACTER5 5148 case FFEINFO_kindtypeCHARACTER5: 5149 fprintf (out, "A" STRX (FFETARGET_kindCHARACTER5) "/"); 5150 break; 5151#endif 5152 5153#if FFETARGET_okCHARACTER6 5154 case FFEINFO_kindtypeCHARACTER6: 5155 fprintf (out, "A" STRX (FFETARGET_kindCHARACTER6) "/"); 5156 break; 5157#endif 5158 5159#if FFETARGET_okCHARACTER7 5160 case FFEINFO_kindtypeCHARACTER7: 5161 fprintf (out, "A" STRX (FFETARGET_kindCHARACTER7) "/"); 5162 break; 5163#endif 5164 5165#if FFETARGET_okCHARACTER8 5166 case FFEINFO_kindtypeCHARACTER8: 5167 fprintf (out, "A" STRX (FFETARGET_kindCHARACTER8) "/"); 5168 break; 5169#endif 5170 5171 default: 5172 assert ("bad CHARACTER kindtype" == NULL); 5173 break; 5174 } 5175 break; 5176 5177 default: 5178 assert ("bad basictype" == NULL); 5179 fprintf (out, "?/?"); 5180 break; 5181 } 5182} 5183#endif 5184 5185/* ffebld_init_0 -- Initialize the module 5186 5187 ffebld_init_0(); */ 5188 5189void 5190ffebld_init_0 () 5191{ 5192 assert (FFEBLD_op == ARRAY_SIZE (ffebld_op_string_)); 5193 assert (FFEBLD_op == ARRAY_SIZE (ffebld_arity_op_)); 5194} 5195 5196/* ffebld_init_1 -- Initialize the module for a file 5197 5198 ffebld_init_1(); */ 5199 5200void 5201ffebld_init_1 () 5202{ 5203#if FFEBLD_whereconstCURRENT_ == FFEBLD_whereconstFILE_ 5204 int i; 5205 5206#if FFETARGET_okCHARACTER1 5207 ffebld_constant_character1_ = NULL; 5208#endif 5209#if FFETARGET_okCHARACTER2 5210 ffebld_constant_character2_ = NULL; 5211#endif 5212#if FFETARGET_okCHARACTER3 5213 ffebld_constant_character3_ = NULL; 5214#endif 5215#if FFETARGET_okCHARACTER4 5216 ffebld_constant_character4_ = NULL; 5217#endif 5218#if FFETARGET_okCHARACTER5 5219 ffebld_constant_character5_ = NULL; 5220#endif 5221#if FFETARGET_okCHARACTER6 5222 ffebld_constant_character6_ = NULL; 5223#endif 5224#if FFETARGET_okCHARACTER7 5225 ffebld_constant_character7_ = NULL; 5226#endif 5227#if FFETARGET_okCHARACTER8 5228 ffebld_constant_character8_ = NULL; 5229#endif 5230#if FFETARGET_okCOMPLEX1 5231 ffebld_constant_complex1_ = NULL; 5232#endif 5233#if FFETARGET_okCOMPLEX2 5234 ffebld_constant_complex2_ = NULL; 5235#endif 5236#if FFETARGET_okCOMPLEX3 5237 ffebld_constant_complex3_ = NULL; 5238#endif 5239#if FFETARGET_okCOMPLEX4 5240 ffebld_constant_complex4_ = NULL; 5241#endif 5242#if FFETARGET_okCOMPLEX5 5243 ffebld_constant_complex5_ = NULL; 5244#endif 5245#if FFETARGET_okCOMPLEX6 5246 ffebld_constant_complex6_ = NULL; 5247#endif 5248#if FFETARGET_okCOMPLEX7 5249 ffebld_constant_complex7_ = NULL; 5250#endif 5251#if FFETARGET_okCOMPLEX8 5252 ffebld_constant_complex8_ = NULL; 5253#endif 5254#if FFETARGET_okINTEGER1 5255 ffebld_constant_integer1_ = NULL; 5256#endif 5257#if FFETARGET_okINTEGER2 5258 ffebld_constant_integer2_ = NULL; 5259#endif 5260#if FFETARGET_okINTEGER3 5261 ffebld_constant_integer3_ = NULL; 5262#endif 5263#if FFETARGET_okINTEGER4 5264 ffebld_constant_integer4_ = NULL; 5265#endif 5266#if FFETARGET_okINTEGER5 5267 ffebld_constant_integer5_ = NULL; 5268#endif 5269#if FFETARGET_okINTEGER6 5270 ffebld_constant_integer6_ = NULL; 5271#endif 5272#if FFETARGET_okINTEGER7 5273 ffebld_constant_integer7_ = NULL; 5274#endif 5275#if FFETARGET_okINTEGER8 5276 ffebld_constant_integer8_ = NULL; 5277#endif 5278#if FFETARGET_okLOGICAL1 5279 ffebld_constant_logical1_ = NULL; 5280#endif 5281#if FFETARGET_okLOGICAL2 5282 ffebld_constant_logical2_ = NULL; 5283#endif 5284#if FFETARGET_okLOGICAL3 5285 ffebld_constant_logical3_ = NULL; 5286#endif 5287#if FFETARGET_okLOGICAL4 5288 ffebld_constant_logical4_ = NULL; 5289#endif 5290#if FFETARGET_okLOGICAL5 5291 ffebld_constant_logical5_ = NULL; 5292#endif 5293#if FFETARGET_okLOGICAL6 5294 ffebld_constant_logical6_ = NULL; 5295#endif 5296#if FFETARGET_okLOGICAL7 5297 ffebld_constant_logical7_ = NULL; 5298#endif 5299#if FFETARGET_okLOGICAL8 5300 ffebld_constant_logical8_ = NULL; 5301#endif 5302#if FFETARGET_okREAL1 5303 ffebld_constant_real1_ = NULL; 5304#endif 5305#if FFETARGET_okREAL2 5306 ffebld_constant_real2_ = NULL; 5307#endif 5308#if FFETARGET_okREAL3 5309 ffebld_constant_real3_ = NULL; 5310#endif 5311#if FFETARGET_okREAL4 5312 ffebld_constant_real4_ = NULL; 5313#endif 5314#if FFETARGET_okREAL5 5315 ffebld_constant_real5_ = NULL; 5316#endif 5317#if FFETARGET_okREAL6 5318 ffebld_constant_real6_ = NULL; 5319#endif 5320#if FFETARGET_okREAL7 5321 ffebld_constant_real7_ = NULL; 5322#endif 5323#if FFETARGET_okREAL8 5324 ffebld_constant_real8_ = NULL; 5325#endif 5326 ffebld_constant_hollerith_ = NULL; 5327 for (i = FFEBLD_constTYPELESS_FIRST; i <= FFEBLD_constTYPELESS_LAST; ++i) 5328 ffebld_constant_typeless_[i - FFEBLD_constTYPELESS_FIRST] = NULL; 5329#endif 5330} 5331 5332/* ffebld_init_2 -- Initialize the module 5333 5334 ffebld_init_2(); */ 5335 5336void 5337ffebld_init_2 () 5338{ 5339#if FFEBLD_whereconstCURRENT_ == FFEBLD_whereconstPROGUNIT_ 5340 int i; 5341#endif 5342 5343 ffebld_pool_stack_.next = NULL; 5344 ffebld_pool_stack_.pool = ffe_pool_program_unit (); 5345#if FFEBLD_whereconstCURRENT_ == FFEBLD_whereconstPROGUNIT_ 5346#if FFETARGET_okCHARACTER1 5347 ffebld_constant_character1_ = NULL; 5348#endif 5349#if FFETARGET_okCHARACTER2 5350 ffebld_constant_character2_ = NULL; 5351#endif 5352#if FFETARGET_okCHARACTER3 5353 ffebld_constant_character3_ = NULL; 5354#endif 5355#if FFETARGET_okCHARACTER4 5356 ffebld_constant_character4_ = NULL; 5357#endif 5358#if FFETARGET_okCHARACTER5 5359 ffebld_constant_character5_ = NULL; 5360#endif 5361#if FFETARGET_okCHARACTER6 5362 ffebld_constant_character6_ = NULL; 5363#endif 5364#if FFETARGET_okCHARACTER7 5365 ffebld_constant_character7_ = NULL; 5366#endif 5367#if FFETARGET_okCHARACTER8 5368 ffebld_constant_character8_ = NULL; 5369#endif 5370#if FFETARGET_okCOMPLEX1 5371 ffebld_constant_complex1_ = NULL; 5372#endif 5373#if FFETARGET_okCOMPLEX2 5374 ffebld_constant_complex2_ = NULL; 5375#endif 5376#if FFETARGET_okCOMPLEX3 5377 ffebld_constant_complex3_ = NULL; 5378#endif 5379#if FFETARGET_okCOMPLEX4 5380 ffebld_constant_complex4_ = NULL; 5381#endif 5382#if FFETARGET_okCOMPLEX5 5383 ffebld_constant_complex5_ = NULL; 5384#endif 5385#if FFETARGET_okCOMPLEX6 5386 ffebld_constant_complex6_ = NULL; 5387#endif 5388#if FFETARGET_okCOMPLEX7 5389 ffebld_constant_complex7_ = NULL; 5390#endif 5391#if FFETARGET_okCOMPLEX8 5392 ffebld_constant_complex8_ = NULL; 5393#endif 5394#if FFETARGET_okINTEGER1 5395 ffebld_constant_integer1_ = NULL; 5396#endif 5397#if FFETARGET_okINTEGER2 5398 ffebld_constant_integer2_ = NULL; 5399#endif 5400#if FFETARGET_okINTEGER3 5401 ffebld_constant_integer3_ = NULL; 5402#endif 5403#if FFETARGET_okINTEGER4 5404 ffebld_constant_integer4_ = NULL; 5405#endif 5406#if FFETARGET_okINTEGER5 5407 ffebld_constant_integer5_ = NULL; 5408#endif 5409#if FFETARGET_okINTEGER6 5410 ffebld_constant_integer6_ = NULL; 5411#endif 5412#if FFETARGET_okINTEGER7 5413 ffebld_constant_integer7_ = NULL; 5414#endif 5415#if FFETARGET_okINTEGER8 5416 ffebld_constant_integer8_ = NULL; 5417#endif 5418#if FFETARGET_okLOGICAL1 5419 ffebld_constant_logical1_ = NULL; 5420#endif 5421#if FFETARGET_okLOGICAL2 5422 ffebld_constant_logical2_ = NULL; 5423#endif 5424#if FFETARGET_okLOGICAL3 5425 ffebld_constant_logical3_ = NULL; 5426#endif 5427#if FFETARGET_okLOGICAL4 5428 ffebld_constant_logical4_ = NULL; 5429#endif 5430#if FFETARGET_okLOGICAL5 5431 ffebld_constant_logical5_ = NULL; 5432#endif 5433#if FFETARGET_okLOGICAL6 5434 ffebld_constant_logical6_ = NULL; 5435#endif 5436#if FFETARGET_okLOGICAL7 5437 ffebld_constant_logical7_ = NULL; 5438#endif 5439#if FFETARGET_okLOGICAL8 5440 ffebld_constant_logical8_ = NULL; 5441#endif 5442#if FFETARGET_okREAL1 5443 ffebld_constant_real1_ = NULL; 5444#endif 5445#if FFETARGET_okREAL2 5446 ffebld_constant_real2_ = NULL; 5447#endif 5448#if FFETARGET_okREAL3 5449 ffebld_constant_real3_ = NULL; 5450#endif 5451#if FFETARGET_okREAL4 5452 ffebld_constant_real4_ = NULL; 5453#endif 5454#if FFETARGET_okREAL5 5455 ffebld_constant_real5_ = NULL; 5456#endif 5457#if FFETARGET_okREAL6 5458 ffebld_constant_real6_ = NULL; 5459#endif 5460#if FFETARGET_okREAL7 5461 ffebld_constant_real7_ = NULL; 5462#endif 5463#if FFETARGET_okREAL8 5464 ffebld_constant_real8_ = NULL; 5465#endif 5466 ffebld_constant_hollerith_ = NULL; 5467 for (i = FFEBLD_constTYPELESS_FIRST; i <= FFEBLD_constTYPELESS_LAST; ++i) 5468 ffebld_constant_typeless_[i - FFEBLD_constTYPELESS_FIRST] = NULL; 5469#endif 5470} 5471 5472/* ffebld_list_length -- Return # of opITEMs in list 5473 5474 ffebld list; // Must be NULL or opITEM 5475 ffebldListLength length; 5476 length = ffebld_list_length(list); 5477 5478 Returns 0 if list is NULL, 1 if it's ffebld_trail is NULL, and so on. */ 5479 5480ffebldListLength 5481ffebld_list_length (ffebld list) 5482{ 5483 ffebldListLength length; 5484 5485 for (length = 0; list != NULL; ++length, list = ffebld_trail (list)) 5486 ; 5487 5488 return length; 5489} 5490 5491/* ffebld_new_accter -- Create an ffebld object that is an array 5492 5493 ffebld x; 5494 ffebldConstantArray a; 5495 ffebit b; 5496 x = ffebld_new_accter(a,b); */ 5497 5498ffebld 5499ffebld_new_accter (ffebldConstantArray a, ffebit b) 5500{ 5501 ffebld x; 5502 5503 x = ffebld_new (); 5504#if FFEBLD_BLANK_ 5505 *x = ffebld_blank_; 5506#endif 5507 x->op = FFEBLD_opACCTER; 5508 x->u.accter.array = a; 5509 x->u.accter.bits = b; 5510 x->u.accter.pad = 0; 5511 return x; 5512} 5513 5514/* ffebld_new_arrter -- Create an ffebld object that is an array 5515 5516 ffebld x; 5517 ffebldConstantArray a; 5518 ffetargetOffset size; 5519 x = ffebld_new_arrter(a,size); */ 5520 5521ffebld 5522ffebld_new_arrter (ffebldConstantArray a, ffetargetOffset size) 5523{ 5524 ffebld x; 5525 5526 x = ffebld_new (); 5527#if FFEBLD_BLANK_ 5528 *x = ffebld_blank_; 5529#endif 5530 x->op = FFEBLD_opARRTER; 5531 x->u.arrter.array = a; 5532 x->u.arrter.size = size; 5533 x->u.arrter.pad = 0; 5534 return x; 5535} 5536 5537/* ffebld_new_conter_with_orig -- Create an ffebld object that is a constant 5538 5539 ffebld x; 5540 ffebldConstant c; 5541 x = ffebld_new_conter_with_orig(c,NULL); */ 5542 5543ffebld 5544ffebld_new_conter_with_orig (ffebldConstant c, ffebld o) 5545{ 5546 ffebld x; 5547 5548 x = ffebld_new (); 5549#if FFEBLD_BLANK_ 5550 *x = ffebld_blank_; 5551#endif 5552 x->op = FFEBLD_opCONTER; 5553 x->u.conter.expr = c; 5554 x->u.conter.orig = o; 5555 x->u.conter.pad = 0; 5556 return x; 5557} 5558 5559/* ffebld_new_item -- Create an ffebld item object 5560 5561 ffebld x,y,z; 5562 x = ffebld_new_item(y,z); */ 5563 5564ffebld 5565ffebld_new_item (ffebld head, ffebld trail) 5566{ 5567 ffebld x; 5568 5569 x = ffebld_new (); 5570#if FFEBLD_BLANK_ 5571 *x = ffebld_blank_; 5572#endif 5573 x->op = FFEBLD_opITEM; 5574 x->u.item.head = head; 5575 x->u.item.trail = trail; 5576#ifdef FFECOM_itemHOOK 5577 x->u.item.hook = FFECOM_itemNULL; 5578#endif 5579 return x; 5580} 5581 5582/* ffebld_new_labter -- Create an ffebld object that is a label 5583 5584 ffebld x; 5585 ffelab l; 5586 x = ffebld_new_labter(c); */ 5587 5588ffebld 5589ffebld_new_labter (ffelab l) 5590{ 5591 ffebld x; 5592 5593 x = ffebld_new (); 5594#if FFEBLD_BLANK_ 5595 *x = ffebld_blank_; 5596#endif 5597 x->op = FFEBLD_opLABTER; 5598 x->u.labter = l; 5599 return x; 5600} 5601 5602/* ffebld_new_labtok -- Create object that is a label's NUMBER token 5603 5604 ffebld x; 5605 ffelexToken t; 5606 x = ffebld_new_labter(c); 5607 5608 Like the other ffebld_new_ functions, the 5609 supplied argument is stored exactly as is: ffelex_token_use is NOT 5610 called, so the token is "consumed", if one is indeed supplied (it may 5611 be NULL). */ 5612 5613ffebld 5614ffebld_new_labtok (ffelexToken t) 5615{ 5616 ffebld x; 5617 5618 x = ffebld_new (); 5619#if FFEBLD_BLANK_ 5620 *x = ffebld_blank_; 5621#endif 5622 x->op = FFEBLD_opLABTOK; 5623 x->u.labtok = t; 5624 return x; 5625} 5626 5627/* ffebld_new_none -- Create an ffebld object with no arguments 5628 5629 ffebld x; 5630 x = ffebld_new_none(FFEBLD_opWHATEVER); */ 5631 5632ffebld 5633ffebld_new_none (ffebldOp o) 5634{ 5635 ffebld x; 5636 5637 x = ffebld_new (); 5638#if FFEBLD_BLANK_ 5639 *x = ffebld_blank_; 5640#endif 5641 x->op = o; 5642 return x; 5643} 5644 5645/* ffebld_new_one -- Create an ffebld object with one argument 5646 5647 ffebld x,y; 5648 x = ffebld_new_one(FFEBLD_opWHATEVER,y); */ 5649 5650ffebld 5651ffebld_new_one (ffebldOp o, ffebld left) 5652{ 5653 ffebld x; 5654 5655 x = ffebld_new (); 5656#if FFEBLD_BLANK_ 5657 *x = ffebld_blank_; 5658#endif 5659 x->op = o; 5660 x->u.nonter.left = left; 5661#ifdef FFECOM_nonterHOOK 5662 x->u.nonter.hook = FFECOM_nonterNULL; 5663#endif 5664 return x; 5665} 5666 5667/* ffebld_new_symter -- Create an ffebld object that is a symbol 5668 5669 ffebld x; 5670 ffesymbol s; 5671 ffeintrinGen gen; // Generic intrinsic id, if any 5672 ffeintrinSpec spec; // Specific intrinsic id, if any 5673 ffeintrinImp imp; // Implementation intrinsic id, if any 5674 x = ffebld_new_symter (s, gen, spec, imp); */ 5675 5676ffebld 5677ffebld_new_symter (ffesymbol s, ffeintrinGen gen, ffeintrinSpec spec, 5678 ffeintrinImp imp) 5679{ 5680 ffebld x; 5681 5682 x = ffebld_new (); 5683#if FFEBLD_BLANK_ 5684 *x = ffebld_blank_; 5685#endif 5686 x->op = FFEBLD_opSYMTER; 5687 x->u.symter.symbol = s; 5688 x->u.symter.generic = gen; 5689 x->u.symter.specific = spec; 5690 x->u.symter.implementation = imp; 5691 x->u.symter.do_iter = FALSE; 5692 return x; 5693} 5694 5695/* ffebld_new_two -- Create an ffebld object with two arguments 5696 5697 ffebld x,y,z; 5698 x = ffebld_new_two(FFEBLD_opWHATEVER,y,z); */ 5699 5700ffebld 5701ffebld_new_two (ffebldOp o, ffebld left, ffebld right) 5702{ 5703 ffebld x; 5704 5705 x = ffebld_new (); 5706#if FFEBLD_BLANK_ 5707 *x = ffebld_blank_; 5708#endif 5709 x->op = o; 5710 x->u.nonter.left = left; 5711 x->u.nonter.right = right; 5712#ifdef FFECOM_nonterHOOK 5713 x->u.nonter.hook = FFECOM_nonterNULL; 5714#endif 5715 return x; 5716} 5717 5718/* ffebld_pool_pop -- Pop ffebld's pool stack 5719 5720 ffebld_pool_pop(); */ 5721 5722void 5723ffebld_pool_pop () 5724{ 5725 ffebldPoolstack_ ps; 5726 5727 assert (ffebld_pool_stack_.next != NULL); 5728 ps = ffebld_pool_stack_.next; 5729 ffebld_pool_stack_.next = ps->next; 5730 ffebld_pool_stack_.pool = ps->pool; 5731 malloc_kill_ks (malloc_pool_image (), ps, sizeof (*ps)); 5732} 5733 5734/* ffebld_pool_push -- Push ffebld's pool stack 5735 5736 ffebld_pool_push(); */ 5737 5738void 5739ffebld_pool_push (mallocPool pool) 5740{ 5741 ffebldPoolstack_ ps; 5742 5743 ps = malloc_new_ks (malloc_pool_image (), "Pool stack", sizeof (*ps)); 5744 ps->next = ffebld_pool_stack_.next; 5745 ps->pool = ffebld_pool_stack_.pool; 5746 ffebld_pool_stack_.next = ps; 5747 ffebld_pool_stack_.pool = pool; 5748} 5749 5750/* ffebld_op_string -- Return short string describing op 5751 5752 ffebldOp o; 5753 ffebld_op_string(o); 5754 5755 Returns a short string (uppercase) containing the name of the op. */ 5756 5757const char * 5758ffebld_op_string (ffebldOp o) 5759{ 5760 if (o >= ARRAY_SIZE (ffebld_op_string_)) 5761 return "?\?\?"; 5762 return ffebld_op_string_[o]; 5763} 5764 5765/* ffebld_size_max -- Return maximum possible size of CHARACTER-type expr 5766 5767 ffetargetCharacterSize sz; 5768 ffebld b; 5769 sz = ffebld_size_max (b); 5770 5771 Like ffebld_size_known, but if that would return NONE and the expression 5772 is opSUBSTR, opCONVERT, opPAREN, or opCONCATENATE, returns ffebld_size_max 5773 of the subexpression(s). */ 5774 5775ffetargetCharacterSize 5776ffebld_size_max (ffebld b) 5777{ 5778 ffetargetCharacterSize sz; 5779 5780recurse: /* :::::::::::::::::::: */ 5781 5782 sz = ffebld_size_known (b); 5783 5784 if (sz != FFETARGET_charactersizeNONE) 5785 return sz; 5786 5787 switch (ffebld_op (b)) 5788 { 5789 case FFEBLD_opSUBSTR: 5790 case FFEBLD_opCONVERT: 5791 case FFEBLD_opPAREN: 5792 b = ffebld_left (b); 5793 goto recurse; /* :::::::::::::::::::: */ 5794 5795 case FFEBLD_opCONCATENATE: 5796 sz = ffebld_size_max (ffebld_left (b)) 5797 + ffebld_size_max (ffebld_right (b)); 5798 return sz; 5799 5800 default: 5801 return sz; 5802 } 5803} 5804