1/* data.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 24 Description: 25 Do the tough things for DATA statement (and INTEGER FOO/.../-style 26 initializations), like implied-DO and suchlike. 27 28 Modifications: 29*/ 30 31/* Include files. */ 32 33#include "proj.h" 34#include "data.h" 35#include "bit.h" 36#include "bld.h" 37#include "com.h" 38#include "expr.h" 39#include "global.h" 40#include "malloc.h" 41#include "st.h" 42#include "storag.h" 43#include "top.h" 44 45/* Externals defined here. */ 46 47 48/* Simple definitions and enumerations. */ 49 50/* I picked this value as one that, when plugged into a couple of small 51 but nearly identical test cases I have called BIG-0.f and BIG-1.f, 52 causes BIG-1.f to take about 10 times as long (elapsed) to compile 53 (in f771 only) as BIG-0.f. These test cases differ in that BIG-0.f 54 doesn't put the one initialized variable in a common area that has 55 a large uninitialized array in it, while BIG-1.f does. The size of 56 the array is this many elements, as long as they all are INTEGER 57 type. Note that, as of 0.5.18, sparse cases are better handled, 58 so BIG-2.f now is used; it provides nonzero initial 59 values for all elements of the same array BIG-0 has. */ 60#ifndef FFEDATA_sizeTOO_BIG_INIT_ 61#define FFEDATA_sizeTOO_BIG_INIT_ 75*1024 62#endif 63 64/* Internal typedefs. */ 65 66typedef struct _ffedata_convert_cache_ *ffedataConvertCache_; 67typedef struct _ffedata_impdo_ *ffedataImpdo_; 68 69/* Private include files. */ 70 71 72/* Internal structure definitions. */ 73 74struct _ffedata_convert_cache_ 75 { 76 ffebld converted; /* Results of converting expr to following 77 type. */ 78 ffeinfoBasictype basic_type; 79 ffeinfoKindtype kind_type; 80 ffetargetCharacterSize size; 81 ffeinfoRank rank; 82 }; 83 84struct _ffedata_impdo_ 85 { 86 ffedataImpdo_ outer; /* Enclosing IMPDO construct. */ 87 ffebld outer_list; /* Item after my IMPDO on the outer list. */ 88 ffebld my_list; /* Beginning of list in my IMPDO. */ 89 ffesymbol itervar; /* Iteration variable. */ 90 ffetargetIntegerDefault increment; 91 ffetargetIntegerDefault final; 92 }; 93 94/* Static objects accessed by functions in this module. */ 95 96static ffedataImpdo_ ffedata_stack_ = NULL; 97static ffebld ffedata_list_ = NULL; 98static bool ffedata_reinit_; /* value_ should report REINIT error. */ 99static bool ffedata_reported_error_; /* Error has been reported. */ 100static ffesymbol ffedata_symbol_ = NULL; /* Symbol being initialized. */ 101static ffeinfoBasictype ffedata_basictype_; /* Info on symbol. */ 102static ffeinfoKindtype ffedata_kindtype_; 103static ffestorag ffedata_storage_; /* If non-NULL, inits go into this parent. */ 104static ffeinfoBasictype ffedata_storage_bt_; /* Info on storage. */ 105static ffeinfoKindtype ffedata_storage_kt_; 106static ffetargetOffset ffedata_storage_size_; /* Size of entire storage. */ 107static ffetargetAlign ffedata_storage_units_; /* #units per storage unit. */ 108static ffetargetOffset ffedata_arraysize_; /* Size of array being 109 inited. */ 110static ffetargetOffset ffedata_expected_; /* Number of elements to 111 init. */ 112static ffetargetOffset ffedata_number_; /* #elements inited so far. */ 113static ffetargetOffset ffedata_offset_; /* Offset of next element. */ 114static ffetargetOffset ffedata_symbolsize_; /* Size of entire sym. */ 115static ffetargetCharacterSize ffedata_size_; /* Size of an element. */ 116static ffetargetCharacterSize ffedata_charexpected_; /* #char to init. */ 117static ffetargetCharacterSize ffedata_charnumber_; /* #chars inited. */ 118static ffetargetCharacterSize ffedata_charoffset_; /* Offset of next char. */ 119static ffedataConvertCache_ ffedata_convert_cache_; /* Fewer conversions. */ 120static int ffedata_convert_cache_max_ = 0; /* #entries available. */ 121static int ffedata_convert_cache_use_ = 0; /* #entries in use. */ 122 123/* Static functions (internal). */ 124 125static bool ffedata_advance_ (void); 126static ffebld ffedata_convert_ (ffebld source, ffelexToken source_token, 127 ffelexToken dest_token, ffeinfoBasictype bt, ffeinfoKindtype kt, 128 ffeinfoRank rk, ffetargetCharacterSize sz); 129static ffetargetInteger1 ffedata_eval_integer1_ (ffebld expr); 130static ffetargetOffset ffedata_eval_offset_ (ffebld subscripts, 131 ffebld dims); 132static ffetargetCharacterSize ffedata_eval_substr_begin_ (ffebld expr); 133static ffetargetCharacterSize ffedata_eval_substr_end_ (ffebld expr, 134 ffetargetCharacterSize min, ffetargetCharacterSize max); 135static void ffedata_gather_ (ffestorag mst, ffestorag st); 136static void ffedata_pop_ (void); 137static void ffedata_push_ (void); 138static bool ffedata_value_ (ffebld value, ffelexToken token); 139 140/* Internal macros. */ 141 142 143/* ffedata_begin -- Initialize with list of targets 144 145 ffebld list; 146 ffedata_begin(list); // ITEM... list of SYMTERs, ARRAYs, SUBSTRs, ... 147 148 Remember the list. After this call, 0...n calls to ffedata_value must 149 follow, and then a single call to ffedata_end. */ 150 151void 152ffedata_begin (ffebld list) 153{ 154 assert (ffedata_list_ == NULL); 155 ffedata_list_ = list; 156 ffedata_symbol_ = NULL; 157 ffedata_reported_error_ = FALSE; 158 ffedata_reinit_ = FALSE; 159 ffedata_advance_ (); 160} 161 162/* ffedata_end -- End of initialization sequence 163 164 if (ffedata_end(FALSE)) 165 // everything's ok 166 167 Make sure the end of the list is valid here. */ 168 169bool 170ffedata_end (bool reported_error, ffelexToken t) 171{ 172 reported_error |= ffedata_reported_error_; 173 174 /* If still targets to initialize, too few initializers, so complain. */ 175 176 if ((ffedata_symbol_ != NULL) && !reported_error) 177 { 178 reported_error = TRUE; 179 ffebad_start (FFEBAD_DATA_TOOFEW); 180 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); 181 ffebad_string (ffesymbol_text (ffedata_symbol_)); 182 ffebad_finish (); 183 } 184 185 /* Pop off any impdo stacks (present only if ffedata_symbol_ != NULL). */ 186 187 while (ffedata_stack_ != NULL) 188 ffedata_pop_ (); 189 190 if (ffedata_list_ != NULL) 191 { 192 assert (reported_error); 193 ffedata_list_ = NULL; 194 } 195 196 return TRUE; 197} 198 199/* ffedata_gather -- Gather previously disparate initializations into one place 200 201 ffestorag st; // A typeCBLOCK or typeLOCAL aggregate. 202 ffedata_gather(st); 203 204 Prior to this call, st has no init or accretion info, but (presumably 205 at least one of) its subordinate storage areas has init or accretion 206 info. After this call, none of the subordinate storage areas has inits, 207 because they've all been moved into the newly created init/accretion 208 info for st. During this call, conflicting inits produce only one 209 error message. */ 210 211void 212ffedata_gather (ffestorag st) 213{ 214 ffesymbol s; 215 ffebld b; 216 217 /* Prepare info on the storage area we're putting init info into. */ 218 219 ffetarget_aggregate_info (&ffedata_storage_bt_, &ffedata_storage_kt_, 220 &ffedata_storage_units_, ffestorag_basictype (st), 221 ffestorag_kindtype (st)); 222 ffedata_storage_size_ = ffestorag_size (st) / ffedata_storage_units_; 223 assert (ffestorag_size (st) % ffedata_storage_units_ == 0); 224 225 /* If a CBLOCK, gather all the init info for its explicit members. */ 226 227 if ((ffestorag_type (st) == FFESTORAG_typeCBLOCK) 228 && (ffestorag_symbol (st) != NULL)) 229 { 230 s = ffestorag_symbol (st); 231 for (b = ffesymbol_commonlist (s); b != NULL; b = ffebld_trail (b)) 232 ffedata_gather_ (st, 233 ffesymbol_storage (ffebld_symter (ffebld_head (b)))); 234 } 235 236 /* For CBLOCK or LOCAL, gather all the init info for equivalenced members. */ 237 238 ffestorag_drive (ffestorag_list_equivs (st), ffedata_gather_, st); 239} 240 241/* ffedata_value -- Provide some number of initial values 242 243 ffebld value; 244 ffelexToken t; // Points to the value. 245 if (ffedata_value(1,value,t)) 246 // Everything's ok 247 248 Makes sure the value is ok, then remembers it according to the list 249 provided to ffedata_begin. As many instances of the value may be 250 supplied as desired, as indicated by the first argument. */ 251 252bool 253ffedata_value (ffetargetIntegerDefault rpt, ffebld value, ffelexToken token) 254{ 255 ffetargetIntegerDefault i; 256 257 /* Maybe ignore zero values, to speed up compiling, even though we lose 258 checking for multiple initializations for now. */ 259 260 if (!ffe_is_zeros () 261 && (value != NULL) 262 && (ffebld_op (value) == FFEBLD_opCONTER) 263 && ffebld_constant_is_zero (ffebld_conter (value))) 264 value = NULL; 265 else if ((value != NULL) 266 && (ffebld_op (value) == FFEBLD_opANY)) 267 value = NULL; 268 else 269 { 270 /* Must be a constant. */ 271 assert (value != NULL); 272 assert (ffebld_op (value) == FFEBLD_opCONTER); 273 } 274 275 /* Later we can optimize certain cases by seeing that the target array can 276 take some number of values, and provide this number to _value_. */ 277 278 if (rpt == 1) 279 ffedata_convert_cache_use_ = -1; /* Don't bother caching. */ 280 else 281 ffedata_convert_cache_use_ = 0; /* Maybe use the cache. */ 282 283 for (i = 0; i < rpt; ++i) 284 { 285 if ((ffedata_symbol_ != NULL) 286 && !ffesymbol_is_init (ffedata_symbol_)) 287 { 288 ffesymbol_signal_change (ffedata_symbol_); 289 ffesymbol_update_init (ffedata_symbol_); 290 if (1 || ffe_is_90 ()) 291 ffesymbol_update_save (ffedata_symbol_); 292#if FFEGLOBAL_ENABLED 293 if (ffesymbol_common (ffedata_symbol_) != NULL) 294 ffeglobal_init_common (ffesymbol_common (ffedata_symbol_), 295 token); 296#endif 297 ffesymbol_signal_unreported (ffedata_symbol_); 298 } 299 if (!ffedata_value_ (value, token)) 300 return FALSE; 301 } 302 303 return TRUE; 304} 305 306/* ffedata_advance_ -- Advance initialization target to next item in list 307 308 if (ffedata_advance_()) 309 // everything's ok 310 311 Sets common info to characterize the next item in the list. Handles 312 IMPDO constructs accordingly. Does not handle advances within a single 313 item, as in the common extension "DATA CHARTYPE/33,34,35/", where 314 CHARTYPE is CHARACTER*3, for example. */ 315 316static bool 317ffedata_advance_ () 318{ 319 ffebld next; 320 321 /* Come here after handling an IMPDO. */ 322 323tail_recurse: /* :::::::::::::::::::: */ 324 325 /* Assume we're not going to find a new target for now. */ 326 327 ffedata_symbol_ = NULL; 328 329 /* If at the end of the list, we're done. */ 330 331 if (ffedata_list_ == NULL) 332 { 333 ffetargetIntegerDefault newval; 334 335 if (ffedata_stack_ == NULL) 336 return TRUE; /* No IMPDO in progress, we is done! */ 337 338 /* Iterate the IMPDO. */ 339 340 newval = ffesymbol_value (ffedata_stack_->itervar) 341 + ffedata_stack_->increment; 342 343 /* See if we're still in the loop. */ 344 345 if (((ffedata_stack_->increment > 0) 346 ? newval > ffedata_stack_->final 347 : newval < ffedata_stack_->final) 348 || (((ffesymbol_value (ffedata_stack_->itervar) < 0) 349 == (ffedata_stack_->increment < 0)) 350 && ((ffesymbol_value (ffedata_stack_->itervar) < 0) 351 != (newval < 0)))) /* Overflow/underflow? */ 352 { /* Done with the loop. */ 353 ffedata_list_ = ffedata_stack_->outer_list; /* Restore list. */ 354 ffedata_pop_ (); /* Pop me off the impdo stack. */ 355 } 356 else 357 { /* Still in the loop, reset the list and 358 update the iter var. */ 359 ffedata_list_ = ffedata_stack_->my_list; /* Reset list. */ 360 ffesymbol_set_value (ffedata_stack_->itervar, newval); 361 } 362 goto tail_recurse; /* :::::::::::::::::::: */ 363 } 364 365 /* Move to the next item in the list. */ 366 367 next = ffebld_head (ffedata_list_); 368 ffedata_list_ = ffebld_trail (ffedata_list_); 369 370 /* Really shouldn't happen. */ 371 372 if (next == NULL) 373 return TRUE; 374 375 /* See what kind of target this is. */ 376 377 switch (ffebld_op (next)) 378 { 379 case FFEBLD_opSYMTER: /* Simple reference to scalar or array. */ 380 ffedata_symbol_ = ffebld_symter (next); 381 ffedata_storage_ = (ffesymbol_storage (ffedata_symbol_) == NULL) ? NULL 382 : ffestorag_parent (ffesymbol_storage (ffedata_symbol_)); 383 if (ffedata_storage_ != NULL) 384 { 385 ffetarget_aggregate_info (&ffedata_storage_bt_, &ffedata_storage_kt_, 386 &ffedata_storage_units_, 387 ffestorag_basictype (ffedata_storage_), 388 ffestorag_kindtype (ffedata_storage_)); 389 ffedata_storage_size_ = ffestorag_size (ffedata_storage_) 390 / ffedata_storage_units_; 391 assert (ffestorag_size (ffedata_storage_) % ffedata_storage_units_ == 0); 392 } 393 394 if ((ffesymbol_init (ffedata_symbol_) != NULL) 395 || (ffesymbol_accretion (ffedata_symbol_) != NULL) 396 || ((ffedata_storage_ != NULL) 397 && (ffestorag_init (ffedata_storage_) != NULL))) 398 { 399#if 0 400 ffebad_start (FFEBAD_DATA_REINIT); 401 ffest_ffebad_here_current_stmt (0); 402 ffebad_string (ffesymbol_text (ffedata_symbol_)); 403 ffebad_finish (); 404 ffedata_reported_error_ = TRUE; 405 return FALSE; 406#else 407 ffedata_reinit_ = TRUE; 408 return TRUE; 409#endif 410 } 411 ffedata_basictype_ = ffesymbol_basictype (ffedata_symbol_); 412 ffedata_kindtype_ = ffesymbol_kindtype (ffedata_symbol_); 413 if (ffesymbol_rank (ffedata_symbol_) == 0) 414 ffedata_arraysize_ = 1; 415 else 416 { 417 ffebld size = ffesymbol_arraysize (ffedata_symbol_); 418 419 assert (size != NULL); 420 assert (ffebld_op (size) == FFEBLD_opCONTER); 421 assert (ffeinfo_basictype (ffebld_info (size)) 422 == FFEINFO_basictypeINTEGER); 423 assert (ffeinfo_kindtype (ffebld_info (size)) 424 == FFEINFO_kindtypeINTEGERDEFAULT); 425 ffedata_arraysize_ = ffebld_constant_integerdefault (ffebld_conter 426 (size)); 427 } 428 ffedata_expected_ = ffedata_arraysize_; 429 ffedata_number_ = 0; 430 ffedata_offset_ = 0; 431 ffedata_size_ = (ffedata_basictype_ == FFEINFO_basictypeCHARACTER) 432 ? ffesymbol_size (ffedata_symbol_) : 1; 433 ffedata_symbolsize_ = ffedata_size_ * ffedata_arraysize_; 434 ffedata_charexpected_ = ffedata_size_; 435 ffedata_charnumber_ = 0; 436 ffedata_charoffset_ = 0; 437 break; 438 439 case FFEBLD_opARRAYREF: /* Reference to element of array. */ 440 ffedata_symbol_ = ffebld_symter (ffebld_left (next)); 441 ffedata_storage_ = (ffesymbol_storage (ffedata_symbol_) == NULL) ? NULL 442 : ffestorag_parent (ffesymbol_storage (ffedata_symbol_)); 443 if (ffedata_storage_ != NULL) 444 { 445 ffetarget_aggregate_info (&ffedata_storage_bt_, &ffedata_storage_kt_, 446 &ffedata_storage_units_, 447 ffestorag_basictype (ffedata_storage_), 448 ffestorag_kindtype (ffedata_storage_)); 449 ffedata_storage_size_ = ffestorag_size (ffedata_storage_) 450 / ffedata_storage_units_; 451 assert (ffestorag_size (ffedata_storage_) % ffedata_storage_units_ == 0); 452 } 453 454 if ((ffesymbol_init (ffedata_symbol_) != NULL) 455 || ((ffedata_storage_ != NULL) 456 && (ffestorag_init (ffedata_storage_) != NULL))) 457 { 458#if 0 459 ffebad_start (FFEBAD_DATA_REINIT); 460 ffest_ffebad_here_current_stmt (0); 461 ffebad_string (ffesymbol_text (ffedata_symbol_)); 462 ffebad_finish (); 463 ffedata_reported_error_ = TRUE; 464 return FALSE; 465#else 466 ffedata_reinit_ = TRUE; 467 return TRUE; 468#endif 469 } 470 ffedata_basictype_ = ffesymbol_basictype (ffedata_symbol_); 471 ffedata_kindtype_ = ffesymbol_kindtype (ffedata_symbol_); 472 if (ffesymbol_rank (ffedata_symbol_) == 0) 473 ffedata_arraysize_ = 1; /* Shouldn't happen in this case... */ 474 else 475 { 476 ffebld size = ffesymbol_arraysize (ffedata_symbol_); 477 478 assert (size != NULL); 479 assert (ffebld_op (size) == FFEBLD_opCONTER); 480 assert (ffeinfo_basictype (ffebld_info (size)) 481 == FFEINFO_basictypeINTEGER); 482 assert (ffeinfo_kindtype (ffebld_info (size)) 483 == FFEINFO_kindtypeINTEGERDEFAULT); 484 ffedata_arraysize_ = ffebld_constant_integerdefault (ffebld_conter 485 (size)); 486 } 487 ffedata_expected_ = 1; 488 ffedata_number_ = 0; 489 ffedata_offset_ = ffedata_eval_offset_ (ffebld_right (next), 490 ffesymbol_dims (ffedata_symbol_)); 491 ffedata_size_ = (ffedata_basictype_ == FFEINFO_basictypeCHARACTER) 492 ? ffesymbol_size (ffedata_symbol_) : 1; 493 ffedata_symbolsize_ = ffedata_size_ * ffedata_arraysize_; 494 ffedata_charexpected_ = ffedata_size_; 495 ffedata_charnumber_ = 0; 496 ffedata_charoffset_ = 0; 497 break; 498 499 case FFEBLD_opSUBSTR: /* Substring reference to scalar or array 500 element. */ 501 { 502 bool arrayref = ffebld_op (ffebld_left (next)) == FFEBLD_opARRAYREF; 503 ffebld colon = ffebld_right (next); 504 505 assert (colon != NULL); 506 507 ffedata_symbol_ = ffebld_symter (ffebld_left (arrayref 508 ? ffebld_left (next) : next)); 509 ffedata_storage_ = (ffesymbol_storage (ffedata_symbol_) == NULL) ? NULL 510 : ffestorag_parent (ffesymbol_storage (ffedata_symbol_)); 511 if (ffedata_storage_ != NULL) 512 { 513 ffetarget_aggregate_info (&ffedata_storage_bt_, &ffedata_storage_kt_, 514 &ffedata_storage_units_, 515 ffestorag_basictype (ffedata_storage_), 516 ffestorag_kindtype (ffedata_storage_)); 517 ffedata_storage_size_ = ffestorag_size (ffedata_storage_) 518 / ffedata_storage_units_; 519 assert (ffestorag_size (ffedata_storage_) % ffedata_storage_units_ == 0); 520 } 521 522 if ((ffesymbol_init (ffedata_symbol_) != NULL) 523 || ((ffedata_storage_ != NULL) 524 && (ffestorag_init (ffedata_storage_) != NULL))) 525 { 526#if 0 527 ffebad_start (FFEBAD_DATA_REINIT); 528 ffest_ffebad_here_current_stmt (0); 529 ffebad_string (ffesymbol_text (ffedata_symbol_)); 530 ffebad_finish (); 531 ffedata_reported_error_ = TRUE; 532 return FALSE; 533#else 534 ffedata_reinit_ = TRUE; 535 return TRUE; 536#endif 537 } 538 ffedata_basictype_ = ffesymbol_basictype (ffedata_symbol_); 539 ffedata_kindtype_ = ffesymbol_kindtype (ffedata_symbol_); 540 if (ffesymbol_rank (ffedata_symbol_) == 0) 541 ffedata_arraysize_ = 1; 542 else 543 { 544 ffebld size = ffesymbol_arraysize (ffedata_symbol_); 545 546 assert (size != NULL); 547 assert (ffebld_op (size) == FFEBLD_opCONTER); 548 assert (ffeinfo_basictype (ffebld_info (size)) 549 == FFEINFO_basictypeINTEGER); 550 assert (ffeinfo_kindtype (ffebld_info (size)) 551 == FFEINFO_kindtypeINTEGERDEFAULT); 552 ffedata_arraysize_ = ffebld_constant_integerdefault (ffebld_conter 553 (size)); 554 } 555 ffedata_expected_ = arrayref ? 1 : ffedata_arraysize_; 556 ffedata_number_ = 0; 557 ffedata_offset_ = arrayref ? ffedata_eval_offset_ (ffebld_right 558 (ffebld_left (next)), ffesymbol_dims (ffedata_symbol_)) : 0; 559 ffedata_size_ = ffesymbol_size (ffedata_symbol_); 560 ffedata_symbolsize_ = ffedata_size_ * ffedata_arraysize_; 561 ffedata_charnumber_ = 0; 562 ffedata_charoffset_ = ffedata_eval_substr_begin_ (ffebld_head (colon)); 563 ffedata_charexpected_ = ffedata_eval_substr_end_ (ffebld_head 564 (ffebld_trail (colon)), ffedata_charoffset_, 565 ffedata_size_) - ffedata_charoffset_ + 1; 566 } 567 break; 568 569 case FFEBLD_opIMPDO: /* Implied-DO construct. */ 570 { 571 ffebld itervar; 572 ffebld start; 573 ffebld end; 574 ffebld incr; 575 ffebld item = ffebld_right (next); 576 577 itervar = ffebld_head (item); 578 item = ffebld_trail (item); 579 start = ffebld_head (item); 580 item = ffebld_trail (item); 581 end = ffebld_head (item); 582 item = ffebld_trail (item); 583 incr = ffebld_head (item); 584 585 ffedata_push_ (); 586 ffedata_stack_->outer_list = ffedata_list_; 587 ffedata_stack_->my_list = ffedata_list_ = ffebld_left (next); 588 589 assert (ffeinfo_basictype (ffebld_info (itervar)) 590 == FFEINFO_basictypeINTEGER); 591 assert (ffeinfo_kindtype (ffebld_info (itervar)) 592 == FFEINFO_kindtypeINTEGERDEFAULT); 593 ffedata_stack_->itervar = ffebld_symter (itervar); 594 595 assert (ffeinfo_basictype (ffebld_info (start)) 596 == FFEINFO_basictypeINTEGER); 597 assert (ffeinfo_kindtype (ffebld_info (start)) 598 == FFEINFO_kindtypeINTEGERDEFAULT); 599 ffesymbol_set_value (ffedata_stack_->itervar, ffedata_eval_integer1_ (start)); 600 601 assert (ffeinfo_basictype (ffebld_info (end)) 602 == FFEINFO_basictypeINTEGER); 603 assert (ffeinfo_kindtype (ffebld_info (end)) 604 == FFEINFO_kindtypeINTEGERDEFAULT); 605 ffedata_stack_->final = ffedata_eval_integer1_ (end); 606 607 if (incr == NULL) 608 ffedata_stack_->increment = 1; 609 else 610 { 611 assert (ffeinfo_basictype (ffebld_info (incr)) 612 == FFEINFO_basictypeINTEGER); 613 assert (ffeinfo_kindtype (ffebld_info (incr)) 614 == FFEINFO_kindtypeINTEGERDEFAULT); 615 ffedata_stack_->increment = ffedata_eval_integer1_ (incr); 616 if (ffedata_stack_->increment == 0) 617 { 618 ffebad_start (FFEBAD_DATA_ZERO); 619 ffest_ffebad_here_current_stmt (0); 620 ffebad_string (ffesymbol_text (ffedata_stack_->itervar)); 621 ffebad_finish (); 622 ffedata_pop_ (); 623 ffedata_reported_error_ = TRUE; 624 return FALSE; 625 } 626 } 627 628 if ((ffedata_stack_->increment > 0) 629 ? ffesymbol_value (ffedata_stack_->itervar) 630 > ffedata_stack_->final 631 : ffesymbol_value (ffedata_stack_->itervar) 632 < ffedata_stack_->final) 633 { 634 ffedata_reported_error_ = TRUE; 635 ffebad_start (FFEBAD_DATA_EMPTY); 636 ffest_ffebad_here_current_stmt (0); 637 ffebad_string (ffesymbol_text (ffedata_stack_->itervar)); 638 ffebad_finish (); 639 ffedata_pop_ (); 640 return FALSE; 641 } 642 } 643 goto tail_recurse; /* :::::::::::::::::::: */ 644 645 case FFEBLD_opANY: 646 ffedata_reported_error_ = TRUE; 647 return FALSE; 648 649 default: 650 assert ("bad op" == NULL); 651 break; 652 } 653 654 return TRUE; 655} 656 657/* ffedata_convert_ -- Convert source expression to given type using cache 658 659 ffebld source; 660 ffelexToken source_token; 661 ffelexToken dest_token; // Any appropriate token for "destination". 662 ffeinfoBasictype bt; 663 ffeinfoKindtype kt; 664 ffetargetCharactersize sz; 665 source = ffedata_convert_(source,source_token,dest_token,bt,kt,sz); 666 667 Like ffeexpr_convert, but calls it only if necessary (if the converted 668 expression doesn't already exist in the cache) and then puts the result 669 in the cache. */ 670 671static ffebld 672ffedata_convert_ (ffebld source, ffelexToken source_token, 673 ffelexToken dest_token, ffeinfoBasictype bt, 674 ffeinfoKindtype kt, ffeinfoRank rk, 675 ffetargetCharacterSize sz) 676{ 677 ffebld converted; 678 int i; 679 int max; 680 ffedataConvertCache_ cache; 681 682 for (i = 0; i < ffedata_convert_cache_use_; ++i) 683 if ((bt == ffedata_convert_cache_[i].basic_type) 684 && (kt == ffedata_convert_cache_[i].kind_type) 685 && (sz == ffedata_convert_cache_[i].size) 686 && (rk == ffedata_convert_cache_[i].rank)) 687 return ffedata_convert_cache_[i].converted; 688 689 converted = ffeexpr_convert (source, source_token, dest_token, bt, kt, rk, 690 sz, FFEEXPR_contextDATA); 691 692 if (ffedata_convert_cache_use_ >= ffedata_convert_cache_max_) 693 { 694 if (ffedata_convert_cache_max_ == 0) 695 max = 4; 696 else 697 max = ffedata_convert_cache_max_ << 1; 698 699 if (max > ffedata_convert_cache_max_) 700 { 701 cache = (ffedataConvertCache_) malloc_new_ks (malloc_pool_image (), 702 "FFEDATA cache", max * sizeof (*cache)); 703 if (ffedata_convert_cache_max_ != 0) 704 { 705 memcpy (cache, ffedata_convert_cache_, 706 ffedata_convert_cache_max_ * sizeof (*cache)); 707 malloc_kill_ks (malloc_pool_image (), ffedata_convert_cache_, 708 ffedata_convert_cache_max_ * sizeof (*cache)); 709 } 710 ffedata_convert_cache_ = cache; 711 ffedata_convert_cache_max_ = max; 712 } 713 else 714 return converted; /* In case int overflows! */ 715 } 716 717 i = ffedata_convert_cache_use_++; 718 719 ffedata_convert_cache_[i].converted = converted; 720 ffedata_convert_cache_[i].basic_type = bt; 721 ffedata_convert_cache_[i].kind_type = kt; 722 ffedata_convert_cache_[i].size = sz; 723 ffedata_convert_cache_[i].rank = rk; 724 725 return converted; 726} 727 728/* ffedata_eval_integer1_ -- Evaluate expression 729 730 ffetargetIntegerDefault result; 731 ffebld expr; // must be kindtypeINTEGER1. 732 733 result = ffedata_eval_integer1_(expr); 734 735 Evalues the expression (which yields a kindtypeINTEGER1 result) and 736 returns the result. */ 737 738static ffetargetIntegerDefault 739ffedata_eval_integer1_ (ffebld expr) 740{ 741 ffetargetInteger1 result; 742 ffebad error; 743 744 assert (expr != NULL); 745 746 switch (ffebld_op (expr)) 747 { 748 case FFEBLD_opCONTER: 749 return ffebld_constant_integer1 (ffebld_conter (expr)); 750 751 case FFEBLD_opSYMTER: 752 return ffesymbol_value (ffebld_symter (expr)); 753 754 case FFEBLD_opUPLUS: 755 return ffedata_eval_integer1_ (ffebld_left (expr)); 756 757 case FFEBLD_opUMINUS: 758 error = ffetarget_uminus_integer1 (&result, 759 ffedata_eval_integer1_ (ffebld_left (expr))); 760 break; 761 762 case FFEBLD_opADD: 763 error = ffetarget_add_integer1 (&result, 764 ffedata_eval_integer1_ (ffebld_left (expr)), 765 ffedata_eval_integer1_ (ffebld_right (expr))); 766 break; 767 768 case FFEBLD_opSUBTRACT: 769 error = ffetarget_subtract_integer1 (&result, 770 ffedata_eval_integer1_ (ffebld_left (expr)), 771 ffedata_eval_integer1_ (ffebld_right (expr))); 772 break; 773 774 case FFEBLD_opMULTIPLY: 775 error = ffetarget_multiply_integer1 (&result, 776 ffedata_eval_integer1_ (ffebld_left (expr)), 777 ffedata_eval_integer1_ (ffebld_right (expr))); 778 break; 779 780 case FFEBLD_opDIVIDE: 781 error = ffetarget_divide_integer1 (&result, 782 ffedata_eval_integer1_ (ffebld_left (expr)), 783 ffedata_eval_integer1_ (ffebld_right (expr))); 784 break; 785 786 case FFEBLD_opPOWER: 787 { 788 ffebld r = ffebld_right (expr); 789 790 if ((ffeinfo_basictype (ffebld_info (r)) != FFEINFO_basictypeINTEGER) 791 || (ffeinfo_kindtype (ffebld_info (r)) != FFEINFO_kindtypeINTEGERDEFAULT)) 792 error = FFEBAD_DATA_EVAL; 793 else 794 error = ffetarget_power_integerdefault_integerdefault (&result, 795 ffedata_eval_integer1_ (ffebld_left (expr)), 796 ffedata_eval_integer1_ (r)); 797 } 798 break; 799 800#if 0 /* Only for character basictype. */ 801 case FFEBLD_opCONCATENATE: 802 error =; 803 break; 804#endif 805 806 case FFEBLD_opNOT: 807 error = ffetarget_not_integer1 (&result, 808 ffedata_eval_integer1_ (ffebld_left (expr))); 809 break; 810 811#if 0 /* Only for logical basictype. */ 812 case FFEBLD_opLT: 813 error =; 814 break; 815 816 case FFEBLD_opLE: 817 error =; 818 break; 819 820 case FFEBLD_opEQ: 821 error =; 822 break; 823 824 case FFEBLD_opNE: 825 error =; 826 break; 827 828 case FFEBLD_opGT: 829 error =; 830 break; 831 832 case FFEBLD_opGE: 833 error =; 834 break; 835#endif 836 837 case FFEBLD_opAND: 838 error = ffetarget_and_integer1 (&result, 839 ffedata_eval_integer1_ (ffebld_left (expr)), 840 ffedata_eval_integer1_ (ffebld_right (expr))); 841 break; 842 843 case FFEBLD_opOR: 844 error = ffetarget_or_integer1 (&result, 845 ffedata_eval_integer1_ (ffebld_left (expr)), 846 ffedata_eval_integer1_ (ffebld_right (expr))); 847 break; 848 849 case FFEBLD_opXOR: 850 error = ffetarget_xor_integer1 (&result, 851 ffedata_eval_integer1_ (ffebld_left (expr)), 852 ffedata_eval_integer1_ (ffebld_right (expr))); 853 break; 854 855 case FFEBLD_opEQV: 856 error = ffetarget_eqv_integer1 (&result, 857 ffedata_eval_integer1_ (ffebld_left (expr)), 858 ffedata_eval_integer1_ (ffebld_right (expr))); 859 break; 860 861 case FFEBLD_opNEQV: 862 error = ffetarget_neqv_integer1 (&result, 863 ffedata_eval_integer1_ (ffebld_left (expr)), 864 ffedata_eval_integer1_ (ffebld_right (expr))); 865 break; 866 867 case FFEBLD_opPAREN: 868 return ffedata_eval_integer1_ (ffebld_left (expr)); 869 870#if 0 /* ~~ no idea how to do this */ 871 case FFEBLD_opPERCENT_LOC: 872 error =; 873 break; 874#endif 875 876#if 0 /* not allowed by ANSI, but perhaps as an 877 extension someday? */ 878 case FFEBLD_opCONVERT: 879 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr)))) 880 { 881 case FFEINFO_basictypeINTEGER: 882 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr)))) 883 { 884 default: 885 error = FFEBAD_DATA_EVAL; 886 break; 887 } 888 break; 889 890 case FFEINFO_basictypeREAL: 891 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr)))) 892 { 893 default: 894 error = FFEBAD_DATA_EVAL; 895 break; 896 } 897 break; 898 } 899 break; 900#endif 901 902#if 0 /* not valid ops */ 903 case FFEBLD_opREPEAT: 904 error =; 905 break; 906 907 case FFEBLD_opBOUNDS: 908 error =; 909 break; 910#endif 911 912#if 0 /* not allowed by ANSI, but perhaps as an 913 extension someday? */ 914 case FFEBLD_opFUNCREF: 915 error =; 916 break; 917#endif 918 919#if 0 /* not valid ops */ 920 case FFEBLD_opSUBRREF: 921 error =; 922 break; 923 924 case FFEBLD_opARRAYREF: 925 error =; 926 break; 927#endif 928 929#if 0 /* not valid for integer1 */ 930 case FFEBLD_opSUBSTR: 931 error =; 932 break; 933#endif 934 935 default: 936 error = FFEBAD_DATA_EVAL; 937 break; 938 } 939 940 if (error != FFEBAD) 941 { 942 ffebad_start (error); 943 ffest_ffebad_here_current_stmt (0); 944 ffebad_finish (); 945 result = 0; 946 } 947 948 return result; 949} 950 951/* ffedata_eval_offset_ -- Evaluate offset info array 952 953 ffetargetOffset offset; // 0...max-1. 954 ffebld subscripts; // an opITEM list of subscript exprs. 955 ffebld dims; // an opITEM list of opBOUNDS exprs. 956 957 result = ffedata_eval_offset_(expr); 958 959 Evalues the expression (which yields a kindtypeINTEGER1 result) and 960 returns the result. */ 961 962static ffetargetOffset 963ffedata_eval_offset_ (ffebld subscripts, ffebld dims) 964{ 965 ffetargetIntegerDefault offset = 0; 966 ffetargetIntegerDefault width = 1; 967 ffetargetIntegerDefault value; 968 ffetargetIntegerDefault lowbound; 969 ffetargetIntegerDefault highbound; 970 ffetargetOffset final; 971 ffebld subscript; 972 ffebld dim; 973 ffebld low; 974 ffebld high; 975 int rank = 0; 976 bool ok; 977 978 while (subscripts != NULL) 979 { 980 ++rank; 981 assert (dims != NULL); 982 983 subscript = ffebld_head (subscripts); 984 dim = ffebld_head (dims); 985 986 assert (ffeinfo_basictype (ffebld_info (subscript)) == FFEINFO_basictypeINTEGER); 987 assert (ffeinfo_kindtype (ffebld_info (subscript)) == FFEINFO_kindtypeINTEGER1); 988 value = ffedata_eval_integer1_ (subscript); 989 990 assert (ffebld_op (dim) == FFEBLD_opBOUNDS); 991 low = ffebld_left (dim); 992 high = ffebld_right (dim); 993 994 if (low == NULL) 995 lowbound = 1; 996 else 997 { 998 assert (ffeinfo_basictype (ffebld_info (low)) == FFEINFO_basictypeINTEGER); 999 assert (ffeinfo_kindtype (ffebld_info (low)) == FFEINFO_kindtypeINTEGERDEFAULT); 1000 lowbound = ffedata_eval_integer1_ (low); 1001 } 1002 1003 assert (ffeinfo_basictype (ffebld_info (high)) == FFEINFO_basictypeINTEGER); 1004 assert (ffeinfo_kindtype (ffebld_info (high)) == FFEINFO_kindtypeINTEGERDEFAULT); 1005 highbound = ffedata_eval_integer1_ (high); 1006 1007 if ((value < lowbound) || (value > highbound)) 1008 { 1009 char rankstr[10]; 1010 1011 sprintf (rankstr, "%d", rank); 1012 value = lowbound; 1013 ffebad_start (FFEBAD_DATA_SUBSCRIPT); 1014 ffebad_string (ffesymbol_text (ffedata_symbol_)); 1015 ffebad_string (rankstr); 1016 ffebad_finish (); 1017 } 1018 1019 subscripts = ffebld_trail (subscripts); 1020 dims = ffebld_trail (dims); 1021 1022 offset += width * (value - lowbound); 1023 if (subscripts != NULL) 1024 width *= highbound - lowbound + 1; 1025 } 1026 1027 assert (dims == NULL); 1028 1029 ok = ffetarget_offset (&final, offset); 1030 assert (ok); 1031 1032 return final; 1033} 1034 1035/* ffedata_eval_substr_begin_ -- Evaluate begin-point of substr reference 1036 1037 ffetargetCharacterSize beginpoint; 1038 ffebld endval; // head(colon). 1039 1040 beginpoint = ffedata_eval_substr_end_(endval); 1041 1042 If beginval is NULL, returns 0. Otherwise makes sure beginval is 1043 kindtypeINTEGERDEFAULT, makes sure its value is > 0, 1044 and returns its value minus one, or issues an error message. */ 1045 1046static ffetargetCharacterSize 1047ffedata_eval_substr_begin_ (ffebld expr) 1048{ 1049 ffetargetIntegerDefault val; 1050 1051 if (expr == NULL) 1052 return 0; 1053 1054 assert (ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeINTEGER); 1055 assert (ffeinfo_kindtype (ffebld_info (expr)) == FFEINFO_kindtypeINTEGERDEFAULT); 1056 1057 val = ffedata_eval_integer1_ (expr); 1058 1059 if (val < 1) 1060 { 1061 val = 1; 1062 ffebad_start (FFEBAD_DATA_RANGE); 1063 ffest_ffebad_here_current_stmt (0); 1064 ffebad_string (ffesymbol_text (ffedata_symbol_)); 1065 ffebad_finish (); 1066 ffedata_reported_error_ = TRUE; 1067 } 1068 1069 return val - 1; 1070} 1071 1072/* ffedata_eval_substr_end_ -- Evaluate end-point of substr reference 1073 1074 ffetargetCharacterSize endpoint; 1075 ffebld endval; // head(trail(colon)). 1076 ffetargetCharacterSize min; // beginpoint of substr reference. 1077 ffetargetCharacterSize max; // size of entity. 1078 1079 endpoint = ffedata_eval_substr_end_(endval,dflt); 1080 1081 If endval is NULL, returns max. Otherwise makes sure endval is 1082 kindtypeINTEGERDEFAULT, makes sure its value is > min and <= max, 1083 and returns its value minus one, or issues an error message. */ 1084 1085static ffetargetCharacterSize 1086ffedata_eval_substr_end_ (ffebld expr, ffetargetCharacterSize min, 1087 ffetargetCharacterSize max) 1088{ 1089 ffetargetIntegerDefault val; 1090 1091 if (expr == NULL) 1092 return max - 1; 1093 1094 assert (ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeINTEGER); 1095 assert (ffeinfo_kindtype (ffebld_info (expr)) == FFEINFO_kindtypeINTEGER1); 1096 1097 val = ffedata_eval_integer1_ (expr); 1098 1099 if ((val < (ffetargetIntegerDefault) min) 1100 || (val > (ffetargetIntegerDefault) max)) 1101 { 1102 val = 1; 1103 ffebad_start (FFEBAD_DATA_RANGE); 1104 ffest_ffebad_here_current_stmt (0); 1105 ffebad_string (ffesymbol_text (ffedata_symbol_)); 1106 ffebad_finish (); 1107 ffedata_reported_error_ = TRUE; 1108 } 1109 1110 return val - 1; 1111} 1112 1113/* ffedata_gather_ -- Gather initial values for sym into master sym inits 1114 1115 ffestorag mst; // A typeCBLOCK or typeLOCAL aggregate. 1116 ffestorag st; // A typeCOMMON or typeEQUIV member. 1117 ffedata_gather_(mst,st); 1118 1119 If st has any initialization info, transfer that info into mst and 1120 clear st's info. */ 1121 1122static void 1123ffedata_gather_ (ffestorag mst, ffestorag st) 1124{ 1125 ffesymbol s; 1126 ffesymbol s_whine; /* Symbol to complain about in diagnostics. */ 1127 ffebld b; 1128 ffetargetOffset offset; 1129 ffetargetOffset units_expected; 1130 ffebitCount actual; 1131 ffebldConstantArray array; 1132 ffebld accter; 1133 ffetargetCopyfunc fn; 1134 void *ptr1; 1135 void *ptr2; 1136 size_t size; 1137 ffeinfoBasictype bt; 1138 ffeinfoKindtype kt; 1139 ffeinfoBasictype ign_bt; 1140 ffeinfoKindtype ign_kt; 1141 ffetargetAlign units; 1142 ffebit bits; 1143 ffetargetOffset source_offset; 1144 bool whine = FALSE; 1145 1146 if (st == NULL) 1147 return; /* Nothing to do. */ 1148 1149 s = ffestorag_symbol (st); 1150 1151 assert (s != NULL); /* Must have a corresponding symbol (else how 1152 inited?). */ 1153 assert (ffestorag_init (st) == NULL); /* No init info on storage itself. */ 1154 assert (ffestorag_accretion (st) == NULL); 1155 1156 if ((((b = ffesymbol_init (s)) == NULL) 1157 && ((b = ffesymbol_accretion (s)) == NULL)) 1158 || (ffebld_op (b) == FFEBLD_opANY) 1159 || ((ffebld_op (b) == FFEBLD_opCONVERT) 1160 && (ffebld_op (ffebld_left (b)) == FFEBLD_opANY))) 1161 return; /* Nothing to do. */ 1162 1163 /* b now holds the init/accretion expr. */ 1164 1165 ffesymbol_set_init (s, NULL); 1166 ffesymbol_set_accretion (s, NULL); 1167 ffesymbol_set_accretes (s, 0); 1168 1169 s_whine = ffestorag_symbol (mst); 1170 if (s_whine == NULL) 1171 s_whine = s; 1172 1173 /* Make sure we haven't fully accreted during an array init. */ 1174 1175 if (ffestorag_init (mst) != NULL) 1176 { 1177 ffebad_start (FFEBAD_DATA_MULTIPLE); 1178 ffebad_here (0, ffewhere_line_unknown (), ffewhere_column_unknown ()); 1179 ffebad_string (ffesymbol_text (s_whine)); 1180 ffebad_finish (); 1181 return; 1182 } 1183 1184 bt = ffeinfo_basictype (ffebld_info (b)); 1185 kt = ffeinfo_kindtype (ffebld_info (b)); 1186 1187 /* Calculate offset for aggregate area. */ 1188 1189 ffedata_charexpected_ = (bt == FFEINFO_basictypeCHARACTER) 1190 ? ffebld_size (b) : 1; 1191 ffetarget_aggregate_info (&ign_bt, &ign_kt, &units, bt, 1192 kt);/* Find out unit size of source datum. */ 1193 assert (units % ffedata_storage_units_ == 0); 1194 units_expected = ffedata_charexpected_ * units / ffedata_storage_units_; 1195 offset = (ffestorag_offset (st) - ffestorag_offset (mst)) 1196 / ffedata_storage_units_; 1197 1198 /* Does an accretion array exist? If not, create it. */ 1199 1200 if (ffestorag_accretion (mst) == NULL) 1201 { 1202#if FFEDATA_sizeTOO_BIG_INIT_ != 0 1203 if (ffedata_storage_size_ >= FFEDATA_sizeTOO_BIG_INIT_) 1204 { 1205 char bignum[40]; 1206 1207 sprintf (&bignum[0], "%ld", (long) ffedata_storage_size_); 1208 ffebad_start (FFEBAD_TOO_BIG_INIT); 1209 ffebad_here (0, ffesymbol_where_line (s_whine), 1210 ffesymbol_where_column (s_whine)); 1211 ffebad_string (ffesymbol_text (s_whine)); 1212 ffebad_string (bignum); 1213 ffebad_finish (); 1214 } 1215#endif 1216 array = ffebld_constantarray_new (ffedata_storage_bt_, 1217 ffedata_storage_kt_, ffedata_storage_size_); 1218 accter = ffebld_new_accter (array, ffebit_new (ffe_pool_program_unit (), 1219 ffedata_storage_size_)); 1220 ffebld_set_info (accter, ffeinfo_new 1221 (ffedata_storage_bt_, 1222 ffedata_storage_kt_, 1223 1, 1224 FFEINFO_kindENTITY, 1225 FFEINFO_whereCONSTANT, 1226 (ffedata_basictype_ == FFEINFO_basictypeCHARACTER) 1227 ? 1 : FFETARGET_charactersizeNONE)); 1228 ffestorag_set_accretion (mst, accter); 1229 ffestorag_set_accretes (mst, ffedata_storage_size_); 1230 } 1231 else 1232 { 1233 accter = ffestorag_accretion (mst); 1234 assert (ffedata_storage_size_ == (ffetargetOffset) ffebld_accter_size (accter)); 1235 array = ffebld_accter (accter); 1236 } 1237 1238 /* Put value in accretion array at desired offset. */ 1239 1240 fn = ffetarget_aggregate_ptr_memcpy (ffedata_storage_bt_, ffedata_storage_kt_, 1241 bt, kt); 1242 1243 switch (ffebld_op (b)) 1244 { 1245 case FFEBLD_opCONTER: 1246 ffebld_constantarray_prepare (&ptr1, &ptr2, &size, array, ffedata_storage_bt_, 1247 ffedata_storage_kt_, offset, 1248 ffebld_constant_ptr_to_union (ffebld_conter (b)), 1249 bt, kt); 1250 (*fn) (ptr1, ptr2, size); /* Does the appropriate memcpy-like 1251 operation. */ 1252 ffebit_count (ffebld_accter_bits (accter), 1253 offset, FALSE, units_expected, &actual); /* How many FALSE? */ 1254 if (units_expected != (ffetargetOffset) actual) 1255 { 1256 ffebad_start (FFEBAD_DATA_MULTIPLE); 1257 ffebad_here (0, ffewhere_line_unknown (), ffewhere_column_unknown ()); 1258 ffebad_string (ffesymbol_text (s)); 1259 ffebad_finish (); 1260 } 1261 ffestorag_set_accretes (mst, 1262 ffestorag_accretes (mst) 1263 - actual); /* Decrement # of values 1264 actually accreted. */ 1265 ffebit_set (ffebld_accter_bits (accter), offset, 1, units_expected); 1266 1267 /* If done accreting for this storage area, establish as initialized. */ 1268 1269 if (ffestorag_accretes (mst) == 0) 1270 { 1271 ffestorag_set_init (mst, accter); 1272 ffestorag_set_accretion (mst, NULL); 1273 ffebit_kill (ffebld_accter_bits (ffestorag_init (mst))); 1274 ffebld_set_op (ffestorag_init (mst), FFEBLD_opARRTER); 1275 ffebld_set_arrter (ffestorag_init (mst), 1276 ffebld_accter (ffestorag_init (mst))); 1277 ffebld_arrter_set_size (ffestorag_init (mst), 1278 ffedata_storage_size_); 1279 ffebld_arrter_set_pad (ffestorag_init (mst), 0); 1280 ffecom_notify_init_storage (mst); 1281 } 1282 1283 return; 1284 1285 case FFEBLD_opARRTER: 1286 ffebld_constantarray_preparray (&ptr1, &ptr2, &size, array, ffedata_storage_bt_, 1287 ffedata_storage_kt_, offset, ffebld_arrter (b), 1288 bt, kt); 1289 size *= ffebld_arrter_size (b); 1290 units_expected *= ffebld_arrter_size (b); 1291 (*fn) (ptr1, ptr2, size); /* Does the appropriate memcpy-like 1292 operation. */ 1293 ffebit_count (ffebld_accter_bits (accter), 1294 offset, FALSE, units_expected, &actual); /* How many FALSE? */ 1295 if (units_expected != (ffetargetOffset) actual) 1296 { 1297 ffebad_start (FFEBAD_DATA_MULTIPLE); 1298 ffebad_here (0, ffewhere_line_unknown (), ffewhere_column_unknown ()); 1299 ffebad_string (ffesymbol_text (s)); 1300 ffebad_finish (); 1301 } 1302 ffestorag_set_accretes (mst, 1303 ffestorag_accretes (mst) 1304 - actual); /* Decrement # of values 1305 actually accreted. */ 1306 ffebit_set (ffebld_accter_bits (accter), offset, 1, units_expected); 1307 1308 /* If done accreting for this storage area, establish as initialized. */ 1309 1310 if (ffestorag_accretes (mst) == 0) 1311 { 1312 ffestorag_set_init (mst, accter); 1313 ffestorag_set_accretion (mst, NULL); 1314 ffebit_kill (ffebld_accter_bits (ffestorag_init (mst))); 1315 ffebld_set_op (ffestorag_init (mst), FFEBLD_opARRTER); 1316 ffebld_set_arrter (ffestorag_init (mst), 1317 ffebld_accter (ffestorag_init (mst))); 1318 ffebld_arrter_set_size (ffestorag_init (mst), 1319 ffedata_storage_size_); 1320 ffebld_arrter_set_pad (ffestorag_init (mst), 0); 1321 ffecom_notify_init_storage (mst); 1322 } 1323 1324 return; 1325 1326 case FFEBLD_opACCTER: 1327 ffebld_constantarray_preparray (&ptr1, &ptr2, &size, array, ffedata_storage_bt_, 1328 ffedata_storage_kt_, offset, ffebld_accter (b), 1329 bt, kt); 1330 bits = ffebld_accter_bits (b); 1331 source_offset = 0; 1332 1333 for (;;) 1334 { 1335 ffetargetOffset unexp; 1336 ffetargetOffset siz; 1337 ffebitCount length; 1338 bool value; 1339 1340 ffebit_test (bits, source_offset, &value, &length); 1341 if (length == 0) 1342 break; /* Exit the loop early. */ 1343 siz = size * length; 1344 unexp = units_expected * length; 1345 if (value) 1346 { 1347 (*fn) (ptr1, ptr2, siz); /* Does memcpy-like operation. */ 1348 ffebit_count (ffebld_accter_bits (accter), /* How many FALSE? */ 1349 offset, FALSE, unexp, &actual); 1350 if (!whine && (unexp != (ffetargetOffset) actual)) 1351 { 1352 whine = TRUE; /* Don't whine more than once for one gather. */ 1353 ffebad_start (FFEBAD_DATA_MULTIPLE); 1354 ffebad_here (0, ffewhere_line_unknown (), ffewhere_column_unknown ()); 1355 ffebad_string (ffesymbol_text (s)); 1356 ffebad_finish (); 1357 } 1358 ffestorag_set_accretes (mst, 1359 ffestorag_accretes (mst) 1360 - actual); /* Decrement # of values 1361 actually accreted. */ 1362 ffebit_set (ffebld_accter_bits (accter), offset, 1, unexp); 1363 } 1364 source_offset += length; 1365 offset += unexp; 1366 ptr1 = ((char *) ptr1) + siz; 1367 ptr2 = ((char *) ptr2) + siz; 1368 } 1369 1370 /* If done accreting for this storage area, establish as initialized. */ 1371 1372 if (ffestorag_accretes (mst) == 0) 1373 { 1374 ffestorag_set_init (mst, accter); 1375 ffestorag_set_accretion (mst, NULL); 1376 ffebit_kill (ffebld_accter_bits (ffestorag_init (mst))); 1377 ffebld_set_op (ffestorag_init (mst), FFEBLD_opARRTER); 1378 ffebld_set_arrter (ffestorag_init (mst), 1379 ffebld_accter (ffestorag_init (mst))); 1380 ffebld_arrter_set_size (ffestorag_init (mst), 1381 ffedata_storage_size_); 1382 ffebld_arrter_set_pad (ffestorag_init (mst), 0); 1383 ffecom_notify_init_storage (mst); 1384 } 1385 1386 return; 1387 1388 default: 1389 assert ("bad init op in gather_" == NULL); 1390 return; 1391 } 1392} 1393 1394/* ffedata_pop_ -- Pop an impdo stack entry 1395 1396 ffedata_pop_(); */ 1397 1398static void 1399ffedata_pop_ () 1400{ 1401 ffedataImpdo_ victim = ffedata_stack_; 1402 1403 assert (victim != NULL); 1404 1405 ffedata_stack_ = ffedata_stack_->outer; 1406 1407 malloc_kill_ks (ffe_pool_program_unit (), victim, sizeof (*victim)); 1408} 1409 1410/* ffedata_push_ -- Push an impdo stack entry 1411 1412 ffedata_push_(); */ 1413 1414static void 1415ffedata_push_ () 1416{ 1417 ffedataImpdo_ baby; 1418 1419 baby = malloc_new_ks (ffe_pool_program_unit (), "ffedataImpdo_", sizeof (*baby)); 1420 1421 baby->outer = ffedata_stack_; 1422 ffedata_stack_ = baby; 1423} 1424 1425/* ffedata_value_ -- Provide an initial value 1426 1427 ffebld value; 1428 ffelexToken t; // Points to the value. 1429 if (ffedata_value(value,t)) 1430 // Everything's ok 1431 1432 Makes sure the value is ok, then remembers it according to the list 1433 provided to ffedata_begin. */ 1434 1435static bool 1436ffedata_value_ (ffebld value, ffelexToken token) 1437{ 1438 1439 /* If already reported an error, don't do anything. */ 1440 1441 if (ffedata_reported_error_) 1442 return FALSE; 1443 1444 /* If the value is an error marker, remember we've seen one and do nothing 1445 else. */ 1446 1447 if ((value != NULL) 1448 && (ffebld_op (value) == FFEBLD_opANY)) 1449 { 1450 ffedata_reported_error_ = TRUE; 1451 return FALSE; 1452 } 1453 1454 /* If too many values (no more targets), complain. */ 1455 1456 if (ffedata_symbol_ == NULL) 1457 { 1458 ffebad_start (FFEBAD_DATA_TOOMANY); 1459 ffebad_here (0, ffelex_token_where_line (token), 1460 ffelex_token_where_column (token)); 1461 ffebad_finish (); 1462 ffedata_reported_error_ = TRUE; 1463 return FALSE; 1464 } 1465 1466 /* If ffedata_advance_ wanted to register a complaint, do it now 1467 that we have the token to point at instead of just the start 1468 of the whole statement. */ 1469 1470 if (ffedata_reinit_) 1471 { 1472 ffebad_start (FFEBAD_DATA_REINIT); 1473 ffebad_here (0, ffelex_token_where_line (token), 1474 ffelex_token_where_column (token)); 1475 ffebad_string (ffesymbol_text (ffedata_symbol_)); 1476 ffebad_finish (); 1477 ffedata_reported_error_ = TRUE; 1478 return FALSE; 1479 } 1480 1481#if FFEGLOBAL_ENABLED 1482 if (ffesymbol_common (ffedata_symbol_) != NULL) 1483 ffeglobal_init_common (ffesymbol_common (ffedata_symbol_), token); 1484#endif 1485 1486 /* Convert value to desired type. */ 1487 1488 if (value != NULL) 1489 { 1490 if (ffedata_convert_cache_use_ == -1) 1491 value = ffeexpr_convert 1492 (value, token, NULL, ffedata_basictype_, 1493 ffedata_kindtype_, 0, 1494 (ffedata_basictype_ == FFEINFO_basictypeCHARACTER) 1495 ? ffedata_charexpected_ : FFETARGET_charactersizeNONE, 1496 FFEEXPR_contextDATA); 1497 else /* Use the cache. */ 1498 value = ffedata_convert_ 1499 (value, token, NULL, ffedata_basictype_, 1500 ffedata_kindtype_, 0, 1501 (ffedata_basictype_ == FFEINFO_basictypeCHARACTER) 1502 ? ffedata_charexpected_ : FFETARGET_charactersizeNONE); 1503 } 1504 1505 /* If we couldn't, bug out. */ 1506 1507 if ((value != NULL) && (ffebld_op (value) == FFEBLD_opANY)) 1508 { 1509 ffedata_reported_error_ = TRUE; 1510 return FALSE; 1511 } 1512 1513 /* Handle the case where initializes go to a parent's storage area. */ 1514 1515 if (ffedata_storage_ != NULL) 1516 { 1517 ffetargetOffset offset; 1518 ffetargetOffset units_expected; 1519 ffebitCount actual; 1520 ffebldConstantArray array; 1521 ffebld accter; 1522 ffetargetCopyfunc fn; 1523 void *ptr1; 1524 void *ptr2; 1525 size_t size; 1526 ffeinfoBasictype ign_bt; 1527 ffeinfoKindtype ign_kt; 1528 ffetargetAlign units; 1529 1530 /* Make sure we haven't fully accreted during an array init. */ 1531 1532 if (ffestorag_init (ffedata_storage_) != NULL) 1533 { 1534 ffebad_start (FFEBAD_DATA_MULTIPLE); 1535 ffebad_here (0, ffelex_token_where_line (token), 1536 ffelex_token_where_column (token)); 1537 ffebad_string (ffesymbol_text (ffedata_symbol_)); 1538 ffebad_finish (); 1539 ffedata_reported_error_ = TRUE; 1540 return FALSE; 1541 } 1542 1543 /* Calculate offset. */ 1544 1545 offset = ffedata_offset_ * ffedata_size_ + ffedata_charoffset_; 1546 1547 /* Is offset within range? If not, whine, but don't do anything else. */ 1548 1549 if (offset + ffedata_charexpected_ - 1 > ffedata_symbolsize_) 1550 { 1551 ffebad_start (FFEBAD_DATA_RANGE); 1552 ffest_ffebad_here_current_stmt (0); 1553 ffebad_string (ffesymbol_text (ffedata_symbol_)); 1554 ffebad_finish (); 1555 ffedata_reported_error_ = TRUE; 1556 return FALSE; 1557 } 1558 1559 /* Now calculate offset for aggregate area. */ 1560 1561 ffetarget_aggregate_info (&ign_bt, &ign_kt, &units, ffedata_basictype_, 1562 ffedata_kindtype_); /* Find out unit size of 1563 source datum. */ 1564 assert (units % ffedata_storage_units_ == 0); 1565 units_expected = ffedata_charexpected_ * units / ffedata_storage_units_; 1566 offset *= units / ffedata_storage_units_; 1567 offset += (ffestorag_offset (ffesymbol_storage (ffedata_symbol_)) 1568 - ffestorag_offset (ffedata_storage_)) 1569 / ffedata_storage_units_; 1570 1571 assert (offset + units_expected - 1 <= ffedata_storage_size_); 1572 1573 /* Does an accretion array exist? If not, create it. */ 1574 1575 if (value != NULL) 1576 { 1577 if (ffestorag_accretion (ffedata_storage_) == NULL) 1578 { 1579#if FFEDATA_sizeTOO_BIG_INIT_ != 0 1580 if (ffedata_storage_size_ >= FFEDATA_sizeTOO_BIG_INIT_) 1581 { 1582 char bignum[40]; 1583 1584 sprintf (&bignum[0], "%ld", (long) ffedata_storage_size_); 1585 ffebad_start (FFEBAD_TOO_BIG_INIT); 1586 ffebad_here (0, ffelex_token_where_line (token), 1587 ffelex_token_where_column (token)); 1588 ffebad_string (ffesymbol_text (ffedata_symbol_)); 1589 ffebad_string (bignum); 1590 ffebad_finish (); 1591 } 1592#endif 1593 array = ffebld_constantarray_new 1594 (ffedata_storage_bt_, ffedata_storage_kt_, 1595 ffedata_storage_size_); 1596 accter = ffebld_new_accter (array, 1597 ffebit_new (ffe_pool_program_unit (), 1598 ffedata_storage_size_)); 1599 ffebld_set_info (accter, ffeinfo_new 1600 (ffedata_storage_bt_, 1601 ffedata_storage_kt_, 1602 1, 1603 FFEINFO_kindENTITY, 1604 FFEINFO_whereCONSTANT, 1605 (ffedata_basictype_ 1606 == FFEINFO_basictypeCHARACTER) 1607 ? 1 : FFETARGET_charactersizeNONE)); 1608 ffestorag_set_accretion (ffedata_storage_, accter); 1609 ffestorag_set_accretes (ffedata_storage_, ffedata_storage_size_); 1610 } 1611 else 1612 { 1613 accter = ffestorag_accretion (ffedata_storage_); 1614 assert (ffedata_storage_size_ == (ffetargetOffset) ffebld_accter_size (accter)); 1615 array = ffebld_accter (accter); 1616 } 1617 1618 /* Put value in accretion array at desired offset. */ 1619 1620 fn = ffetarget_aggregate_ptr_memcpy 1621 (ffedata_storage_bt_, ffedata_storage_kt_, 1622 ffedata_basictype_, ffedata_kindtype_); 1623 ffebld_constantarray_prepare 1624 (&ptr1, &ptr2, &size, array, ffedata_storage_bt_, 1625 ffedata_storage_kt_, offset, 1626 ffebld_constant_ptr_to_union (ffebld_conter (value)), 1627 ffedata_basictype_, ffedata_kindtype_); 1628 (*fn) (ptr1, ptr2, size); /* Does the appropriate memcpy-like 1629 operation. */ 1630 ffebit_count (ffebld_accter_bits (accter), 1631 offset, FALSE, units_expected, 1632 &actual); /* How many FALSE? */ 1633 if (units_expected != (ffetargetOffset) actual) 1634 { 1635 ffebad_start (FFEBAD_DATA_MULTIPLE); 1636 ffebad_here (0, ffelex_token_where_line (token), 1637 ffelex_token_where_column (token)); 1638 ffebad_string (ffesymbol_text (ffedata_symbol_)); 1639 ffebad_finish (); 1640 } 1641 ffestorag_set_accretes (ffedata_storage_, 1642 ffestorag_accretes (ffedata_storage_) 1643 - actual); /* Decrement # of values 1644 actually accreted. */ 1645 ffebit_set (ffebld_accter_bits (accter), offset, 1646 1, units_expected); 1647 1648 /* If done accreting for this storage area, establish as 1649 initialized. */ 1650 1651 if (ffestorag_accretes (ffedata_storage_) == 0) 1652 { 1653 ffestorag_set_init (ffedata_storage_, accter); 1654 ffestorag_set_accretion (ffedata_storage_, NULL); 1655 ffebit_kill (ffebld_accter_bits 1656 (ffestorag_init (ffedata_storage_))); 1657 ffebld_set_op (ffestorag_init (ffedata_storage_), 1658 FFEBLD_opARRTER); 1659 ffebld_set_arrter 1660 (ffestorag_init (ffedata_storage_), 1661 ffebld_accter (ffestorag_init (ffedata_storage_))); 1662 ffebld_arrter_set_size (ffestorag_init (ffedata_storage_), 1663 ffedata_storage_size_); 1664 ffebld_arrter_set_pad (ffestorag_init (ffedata_storage_), 1665 0); 1666 ffecom_notify_init_storage (ffedata_storage_); 1667 } 1668 } 1669 1670 /* If still accreting, adjust specs accordingly and return. */ 1671 1672 if (++ffedata_number_ < ffedata_expected_) 1673 { 1674 ++ffedata_offset_; 1675 return TRUE; 1676 } 1677 1678 return ffedata_advance_ (); 1679 } 1680 1681 /* Figure out where the value goes -- in an accretion array or directly 1682 into the final initial-value slot for the symbol. */ 1683 1684 if ((ffedata_number_ != 0) 1685 || (ffedata_arraysize_ > 1) 1686 || (ffedata_charnumber_ != 0) 1687 || (ffedata_size_ > ffedata_charexpected_)) 1688 { /* Accrete this value. */ 1689 ffetargetOffset offset; 1690 ffebitCount actual; 1691 ffebldConstantArray array; 1692 ffebld accter = NULL; 1693 1694 /* Calculate offset. */ 1695 1696 offset = ffedata_offset_ * ffedata_size_ + ffedata_charoffset_; 1697 1698 /* Is offset within range? If not, whine, but don't do anything else. */ 1699 1700 if (offset + ffedata_charexpected_ - 1 > ffedata_symbolsize_) 1701 { 1702 ffebad_start (FFEBAD_DATA_RANGE); 1703 ffest_ffebad_here_current_stmt (0); 1704 ffebad_string (ffesymbol_text (ffedata_symbol_)); 1705 ffebad_finish (); 1706 ffedata_reported_error_ = TRUE; 1707 return FALSE; 1708 } 1709 1710 /* Does an accretion array exist? If not, create it. */ 1711 1712 if (value != NULL) 1713 { 1714 if (ffesymbol_accretion (ffedata_symbol_) == NULL) 1715 { 1716#if FFEDATA_sizeTOO_BIG_INIT_ != 0 1717 if (ffedata_symbolsize_ >= FFEDATA_sizeTOO_BIG_INIT_ ) 1718 { 1719 char bignum[40]; 1720 1721 sprintf (&bignum[0], "%ld", (long) ffedata_symbolsize_); 1722 ffebad_start (FFEBAD_TOO_BIG_INIT); 1723 ffebad_here (0, ffelex_token_where_line (token), 1724 ffelex_token_where_column (token)); 1725 ffebad_string (ffesymbol_text (ffedata_symbol_)); 1726 ffebad_string (bignum); 1727 ffebad_finish (); 1728 } 1729#endif 1730 array = ffebld_constantarray_new 1731 (ffedata_basictype_, ffedata_kindtype_, 1732 ffedata_symbolsize_); 1733 accter = ffebld_new_accter (array, 1734 ffebit_new (ffe_pool_program_unit (), 1735 ffedata_symbolsize_)); 1736 ffebld_set_info (accter, ffeinfo_new 1737 (ffedata_basictype_, 1738 ffedata_kindtype_, 1739 1, 1740 FFEINFO_kindENTITY, 1741 FFEINFO_whereCONSTANT, 1742 (ffedata_basictype_ 1743 == FFEINFO_basictypeCHARACTER) 1744 ? 1 : FFETARGET_charactersizeNONE)); 1745 ffesymbol_set_accretion (ffedata_symbol_, accter); 1746 ffesymbol_set_accretes (ffedata_symbol_, ffedata_symbolsize_); 1747 } 1748 else 1749 { 1750 accter = ffesymbol_accretion (ffedata_symbol_); 1751 assert (ffedata_symbolsize_ 1752 == (ffetargetOffset) ffebld_accter_size (accter)); 1753 array = ffebld_accter (accter); 1754 } 1755 1756 /* Put value in accretion array at desired offset. */ 1757 1758 ffebld_constantarray_put 1759 (array, ffedata_basictype_, ffedata_kindtype_, 1760 offset, ffebld_constant_union (ffebld_conter (value))); 1761 ffebit_count (ffebld_accter_bits (accter), offset, FALSE, 1762 ffedata_charexpected_, 1763 &actual); /* How many FALSE? */ 1764 if (actual != (unsigned long int) ffedata_charexpected_) 1765 { 1766 ffebad_start (FFEBAD_DATA_MULTIPLE); 1767 ffebad_here (0, ffelex_token_where_line (token), 1768 ffelex_token_where_column (token)); 1769 ffebad_string (ffesymbol_text (ffedata_symbol_)); 1770 ffebad_finish (); 1771 } 1772 ffesymbol_set_accretes (ffedata_symbol_, 1773 ffesymbol_accretes (ffedata_symbol_) 1774 - actual); /* Decrement # of values 1775 actually accreted. */ 1776 ffebit_set (ffebld_accter_bits (accter), offset, 1777 1, ffedata_charexpected_); 1778 ffesymbol_signal_unreported (ffedata_symbol_); 1779 } 1780 1781 /* If still accreting, adjust specs accordingly and return. */ 1782 1783 if (++ffedata_number_ < ffedata_expected_) 1784 { 1785 ++ffedata_offset_; 1786 return TRUE; 1787 } 1788 1789 /* Else, if done accreting for this symbol, establish as initialized. */ 1790 1791 if ((value != NULL) 1792 && (ffesymbol_accretes (ffedata_symbol_) == 0)) 1793 { 1794 ffesymbol_set_init (ffedata_symbol_, accter); 1795 ffesymbol_set_accretion (ffedata_symbol_, NULL); 1796 ffebit_kill (ffebld_accter_bits (ffesymbol_init (ffedata_symbol_))); 1797 ffebld_set_op (ffesymbol_init (ffedata_symbol_), FFEBLD_opARRTER); 1798 ffebld_set_arrter (ffesymbol_init (ffedata_symbol_), 1799 ffebld_accter (ffesymbol_init (ffedata_symbol_))); 1800 ffebld_arrter_set_size (ffesymbol_init (ffedata_symbol_), 1801 ffedata_symbolsize_); 1802 ffebld_arrter_set_pad (ffestorag_init (ffedata_symbol_), 0); 1803 ffecom_notify_init_symbol (ffedata_symbol_); 1804 } 1805 } 1806 else if (value != NULL) 1807 { 1808 /* Simple, direct, one-shot assignment. */ 1809 ffesymbol_set_init (ffedata_symbol_, value); 1810 ffecom_notify_init_symbol (ffedata_symbol_); 1811 } 1812 1813 /* Call on advance function to get next target in list. */ 1814 1815 return ffedata_advance_ (); 1816} 1817