129088Smarkm/* Copyright (C) 2002-2022 Free Software Foundation, Inc. 229088Smarkm Contributed by Andy Vaught 329088Smarkm Namelist input contributed by Paul Thomas 429088Smarkm F2003 I/O support contributed by Jerry DeLisle 529088Smarkm 629088SmarkmThis file is part of the GNU Fortran runtime library (libgfortran). 729088Smarkm 829088SmarkmLibgfortran is free software; you can redistribute it and/or modify 929088Smarkmit under the terms of the GNU General Public License as published by 1029088Smarkmthe Free Software Foundation; either version 3, or (at your option) 1129088Smarkmany later version. 1229088Smarkm 1329088SmarkmLibgfortran is distributed in the hope that it will be useful, 1429088Smarkmbut WITHOUT ANY WARRANTY; without even the implied warranty of 1529088SmarkmMERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 1629088SmarkmGNU General Public License for more details. 1729088Smarkm 1829088SmarkmUnder Section 7 of GPL version 3, you are granted additional 1929088Smarkmpermissions described in the GCC Runtime Library Exception, version 2029088Smarkm3.1, as published by the Free Software Foundation. 2129088Smarkm 2229088SmarkmYou should have received a copy of the GNU General Public License and 2329088Smarkma copy of the GCC Runtime Library Exception along with this program; 2429088Smarkmsee the files COPYING3 and COPYING.RUNTIME respectively. If not, see 2529088Smarkm<http://www.gnu.org/licenses/>. */ 2629088Smarkm 2729088Smarkm 2829088Smarkm#include "io.h" 2929088Smarkm#include "fbuf.h" 3029088Smarkm#include "unix.h" 3129088Smarkm#include <string.h> 3229088Smarkm 3329088Smarkmtypedef unsigned char uchar; 34114630Sobrien 3529088Smarkm 3629181Smarkm/* List directed input. Several parsing subroutines are practically 3763248Speter reimplemented from formatted input, the reason being that there are 38114630Sobrien all kinds of small differences between formatted and list directed 39114630Sobrien parsing. */ 40114630Sobrien 4129088Smarkm 4229088Smarkm/* Subroutines for reading characters from the input. Because a 4329088Smarkm repeat count is ambiguous with an integer, we have to read the 4429088Smarkm whole digit string before seeing if there is a '*' which signals 4529088Smarkm the repeat count. Since we can have a lot of potential leading 4629088Smarkm zeros, we have to be able to back up by arbitrary amount. Because 4729088Smarkm the input might not be seekable, we have to buffer the data 4829088Smarkm ourselves. */ 4929088Smarkm 5029088Smarkm#define CASE_DIGITS case '0': case '1': case '2': case '3': case '4': \ 5129088Smarkm case '5': case '6': case '7': case '8': case '9' 5229088Smarkm 5381965Smarkm#define CASE_SEPARATORS /* Fall through. */ \ 5429088Smarkm case ' ': case ',': case '/': case '\n': \ 5529181Smarkm case '\t': case '\r': case ';' 5629088Smarkm 5729088Smarkm/* This macro assumes that we're operating on a variable. */ 5829088Smarkm 5929088Smarkm#define is_separator(c) (c == '/' || c == ',' || c == '\n' || c == ' ' \ 6029088Smarkm || c == '\t' || c == '\r' || c == ';' || \ 6129088Smarkm (dtp->u.p.namelist_mode && c == '!')) 6229088Smarkm 6329088Smarkm/* Maximum repeat count. Less than ten times the maximum signed int32. */ 6429088Smarkm 6529088Smarkm#define MAX_REPEAT 200000000 6629088Smarkm 6729088Smarkm 6829088Smarkm#define MSGLEN 100 6929088Smarkm 7029088Smarkm 7129088Smarkm/* Wrappers for calling the current worker functions. */ 7229088Smarkm 7329088Smarkm#define next_char(dtp) ((dtp)->u.p.current_unit->next_char_fn_ptr (dtp)) 7429088Smarkm#define push_char(dtp, c) ((dtp)->u.p.current_unit->push_char_fn_ptr (dtp, c)) 7529088Smarkm 7629088Smarkm/* Worker function to save a default KIND=1 character to a string 7729088Smarkm buffer, enlarging it as necessary. */ 7829088Smarkm 7929088Smarkmstatic void 8029088Smarkmpush_char_default (st_parameter_dt *dtp, int c) 8129088Smarkm{ 8229088Smarkm 8329088Smarkm 8429088Smarkm if (dtp->u.p.saved_string == NULL) 8529088Smarkm { 8629088Smarkm /* Plain malloc should suffice here, zeroing not needed? */ 8729088Smarkm dtp->u.p.saved_string = xcalloc (SCRATCH_SIZE, 1); 8829088Smarkm dtp->u.p.saved_length = SCRATCH_SIZE; 8929088Smarkm dtp->u.p.saved_used = 0; 9029088Smarkm } 9129088Smarkm 9229088Smarkm if (dtp->u.p.saved_used >= dtp->u.p.saved_length) 9329088Smarkm { 9429088Smarkm dtp->u.p.saved_length = 2 * dtp->u.p.saved_length; 9529088Smarkm dtp->u.p.saved_string = 9629088Smarkm xrealloc (dtp->u.p.saved_string, dtp->u.p.saved_length); 9729088Smarkm } 9829088Smarkm 9929088Smarkm dtp->u.p.saved_string[dtp->u.p.saved_used++] = (char) c; 10029088Smarkm} 10129088Smarkm 10229088Smarkm 10387139Smarkm/* Worker function to save a KIND=4 character to a string buffer, 10487139Smarkm enlarging the buffer as necessary. */ 10529088Smarkmstatic void 10629088Smarkmpush_char4 (st_parameter_dt *dtp, int c) 10729088Smarkm{ 10829088Smarkm gfc_char4_t *p = (gfc_char4_t *) dtp->u.p.saved_string; 10929088Smarkm 11029088Smarkm if (p == NULL) 11129088Smarkm { 11229088Smarkm dtp->u.p.saved_string = xcalloc (SCRATCH_SIZE, sizeof (gfc_char4_t)); 11329088Smarkm dtp->u.p.saved_length = SCRATCH_SIZE; 11429088Smarkm dtp->u.p.saved_used = 0; 11529088Smarkm p = (gfc_char4_t *) dtp->u.p.saved_string; 11629088Smarkm } 11729088Smarkm 11829088Smarkm if (dtp->u.p.saved_used >= dtp->u.p.saved_length) 11929088Smarkm { 12029088Smarkm dtp->u.p.saved_length = 2 * dtp->u.p.saved_length; 12129088Smarkm dtp->u.p.saved_string = 12229088Smarkm xrealloc (dtp->u.p.saved_string, 12329088Smarkm dtp->u.p.saved_length * sizeof (gfc_char4_t)); 12429088Smarkm p = (gfc_char4_t *) dtp->u.p.saved_string; 12529088Smarkm } 12629088Smarkm 12787139Smarkm p[dtp->u.p.saved_used++] = c; 12887139Smarkm} 12929088Smarkm 13029088Smarkm 13129088Smarkm/* Free the input buffer if necessary. */ 13229088Smarkm 13329088Smarkmstatic void 13429088Smarkmfree_saved (st_parameter_dt *dtp) 13529088Smarkm{ 13629088Smarkm if (dtp->u.p.saved_string == NULL) 13787139Smarkm return; 13887139Smarkm 13929088Smarkm free (dtp->u.p.saved_string); 14029088Smarkm 14129088Smarkm dtp->u.p.saved_string = NULL; 14229088Smarkm dtp->u.p.saved_used = 0; 14329088Smarkm} 14429088Smarkm 14529088Smarkm 14629088Smarkm/* Free the line buffer if necessary. */ 14729088Smarkm 14829088Smarkmstatic void 14929088Smarkmfree_line (st_parameter_dt *dtp) 15029088Smarkm{ 15187139Smarkm dtp->u.p.line_buffer_pos = 0; 15287139Smarkm dtp->u.p.line_buffer_enabled = 0; 15329088Smarkm 15429088Smarkm if (dtp->u.p.line_buffer == NULL) 15529088Smarkm return; 15629088Smarkm 15729088Smarkm free (dtp->u.p.line_buffer); 15829088Smarkm dtp->u.p.line_buffer = NULL; 15929088Smarkm} 16087139Smarkm 16187139Smarkm 16229088Smarkm/* Unget saves the last character so when reading the next character, 16329088Smarkm we need to check to see if there is a character waiting. Similar, 16429088Smarkm if the line buffer is being used to read_logical, check it too. */ 16529088Smarkm 16629088Smarkmstatic int 16729088Smarkmcheck_buffers (st_parameter_dt *dtp) 16829088Smarkm{ 16929088Smarkm int c; 17087139Smarkm 17187139Smarkm c = '\0'; 17229088Smarkm if (dtp->u.p.current_unit->last_char != EOF - 1) 17329088Smarkm { 17429088Smarkm dtp->u.p.at_eol = 0; 17529088Smarkm c = dtp->u.p.current_unit->last_char; 17629088Smarkm dtp->u.p.current_unit->last_char = EOF - 1; 17729088Smarkm goto done; 17829088Smarkm } 17929088Smarkm 18029088Smarkm /* Read from line_buffer if enabled. */ 18129088Smarkm 18229088Smarkm if (dtp->u.p.line_buffer_enabled) 18329088Smarkm { 18429088Smarkm dtp->u.p.at_eol = 0; 18529088Smarkm 18629088Smarkm c = dtp->u.p.line_buffer[dtp->u.p.line_buffer_pos]; 18729088Smarkm if (c != '\0' && dtp->u.p.line_buffer_pos < 64) 18829088Smarkm { 18929088Smarkm dtp->u.p.line_buffer[dtp->u.p.line_buffer_pos] = '\0'; 19029088Smarkm dtp->u.p.line_buffer_pos++; 19129088Smarkm goto done; 19229088Smarkm } 19329088Smarkm 19429088Smarkm dtp->u.p.line_buffer_pos = 0; 19529088Smarkm dtp->u.p.line_buffer_enabled = 0; 19629088Smarkm } 19729088Smarkm 19829088Smarkmdone: 19929088Smarkm dtp->u.p.at_eol = (c == '\n' || c == '\r' || c == EOF); 20029088Smarkm return c; 20129088Smarkm} 20229088Smarkm 20329088Smarkm 20429088Smarkm/* Worker function for default character encoded file. */ 20587139Smarkmstatic int 20687139Smarkmnext_char_default (st_parameter_dt *dtp) 20729088Smarkm{ 20829088Smarkm int c; 20929088Smarkm 21029088Smarkm /* Always check the unget and line buffer first. */ 21129088Smarkm if ((c = check_buffers (dtp))) 21229088Smarkm return c; 21329088Smarkm 21429088Smarkm c = fbuf_getc (dtp->u.p.current_unit); 21529088Smarkm if (c != EOF && is_stream_io (dtp)) 21687139Smarkm dtp->u.p.current_unit->strm_pos++; 21787139Smarkm 21829088Smarkm dtp->u.p.at_eol = (c == '\n' || c == EOF); 21929088Smarkm return c; 22029088Smarkm} 22129088Smarkm 22229088Smarkm 22329088Smarkm/* Worker function for internal and array I/O units. */ 22429088Smarkmstatic int 22529088Smarkmnext_char_internal (st_parameter_dt *dtp) 22629088Smarkm{ 22729088Smarkm ssize_t length; 22829088Smarkm gfc_offset record; 22929088Smarkm int c; 23029088Smarkm 23129088Smarkm /* Always check the unget and line buffer first. */ 23229088Smarkm if ((c = check_buffers (dtp))) 23329088Smarkm return c; 23429088Smarkm 23529088Smarkm /* Handle the end-of-record and end-of-file conditions for 23629088Smarkm internal array unit. */ 23787139Smarkm if (is_array_io (dtp)) 23887139Smarkm { 23929088Smarkm if (dtp->u.p.at_eof) 24029088Smarkm return EOF; 24129088Smarkm 24229088Smarkm /* Check for "end-of-record" condition. */ 24329088Smarkm if (dtp->u.p.current_unit->bytes_left == 0) 24429088Smarkm { 24529088Smarkm int finished; 24629088Smarkm 24729088Smarkm c = '\n'; 24829088Smarkm record = next_array_record (dtp, dtp->u.p.current_unit->ls, 24929088Smarkm &finished); 25029088Smarkm 25129088Smarkm /* Check for "end-of-file" condition. */ 25229088Smarkm if (finished) 25329088Smarkm { 25429088Smarkm dtp->u.p.at_eof = 1; 25587139Smarkm goto done; 25687139Smarkm } 25729088Smarkm 25829088Smarkm record *= dtp->u.p.current_unit->recl; 25929088Smarkm if (sseek (dtp->u.p.current_unit->s, record, SEEK_SET) < 0) 26029088Smarkm return EOF; 26129088Smarkm 26229088Smarkm dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl; 26329088Smarkm goto done; 26429088Smarkm } 26529088Smarkm } 26629088Smarkm 26729088Smarkm /* Get the next character and handle end-of-record conditions. */ 26829088Smarkm if (likely (dtp->u.p.current_unit->bytes_left > 0)) 26929088Smarkm { 27029088Smarkm if (unlikely (is_char4_unit(dtp))) /* Check for kind=4 internal unit. */ 27129088Smarkm length = sread (dtp->u.p.current_unit->s, &c, 1); 27229088Smarkm else 27329088Smarkm { 27429088Smarkm char cc; 27529088Smarkm length = sread (dtp->u.p.current_unit->s, &cc, 1); 27687139Smarkm c = cc; 27787139Smarkm } 27829088Smarkm } 27929088Smarkm else 28029088Smarkm length = 0; 28129088Smarkm 28229088Smarkm if (unlikely (length < 0)) 28381965Smarkm { 28429088Smarkm generate_error (&dtp->common, LIBERROR_OS, NULL); 28529088Smarkm return '\0'; 28629088Smarkm } 28729088Smarkm 28829088Smarkm if (is_array_io (dtp)) 28929088Smarkm { 29029088Smarkm /* Check whether we hit EOF. */ 29187139Smarkm if (unlikely (length == 0)) 29287139Smarkm { 29329088Smarkm generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL); 29429088Smarkm return '\0'; 29529088Smarkm } 29629088Smarkm } 29729088Smarkm else 29829088Smarkm { 29929088Smarkm if (dtp->u.p.at_eof) 30029088Smarkm return EOF; 30129088Smarkm if (length == 0) 30229088Smarkm { 30329088Smarkm c = '\n'; 30429088Smarkm dtp->u.p.at_eof = 1; 30529088Smarkm } 30629088Smarkm } 30729088Smarkm dtp->u.p.current_unit->bytes_left--; 30829088Smarkm 30929088Smarkmdone: 31029088Smarkm dtp->u.p.at_eol = (c == '\n' || c == EOF); 31129088Smarkm return c; 31229088Smarkm} 31329088Smarkm 31429088Smarkm 31529088Smarkm/* Worker function for UTF encoded files. */ 31629088Smarkmstatic int 31729088Smarkmnext_char_utf8 (st_parameter_dt *dtp) 31829088Smarkm{ 31929088Smarkm static const uchar masks[6] = { 0x7F, 0x1F, 0x0F, 0x07, 0x02, 0x01 }; 32029088Smarkm static const uchar patns[6] = { 0x00, 0xC0, 0xE0, 0xF0, 0xF8, 0xFC }; 32129088Smarkm int i, nb; 32229088Smarkm gfc_char4_t c; 323 324 /* Always check the unget and line buffer first. */ 325 if (!(c = check_buffers (dtp))) 326 c = fbuf_getc (dtp->u.p.current_unit); 327 328 if (c < 0x80) 329 goto utf_done; 330 331 /* The number of leading 1-bits in the first byte indicates how many 332 bytes follow. */ 333 for (nb = 2; nb < 7; nb++) 334 if ((c & ~masks[nb-1]) == patns[nb-1]) 335 goto found; 336 goto invalid; 337 338 found: 339 c = (c & masks[nb-1]); 340 341 /* Decode the bytes read. */ 342 for (i = 1; i < nb; i++) 343 { 344 gfc_char4_t n = fbuf_getc (dtp->u.p.current_unit); 345 if ((n & 0xC0) != 0x80) 346 goto invalid; 347 c = ((c << 6) + (n & 0x3F)); 348 } 349 350 /* Make sure the shortest possible encoding was used. */ 351 if (c <= 0x7F && nb > 1) goto invalid; 352 if (c <= 0x7FF && nb > 2) goto invalid; 353 if (c <= 0xFFFF && nb > 3) goto invalid; 354 if (c <= 0x1FFFFF && nb > 4) goto invalid; 355 if (c <= 0x3FFFFFF && nb > 5) goto invalid; 356 357 /* Make sure the character is valid. */ 358 if (c > 0x7FFFFFFF || (c >= 0xD800 && c <= 0xDFFF)) 359 goto invalid; 360 361utf_done: 362 dtp->u.p.at_eol = (c == '\n' || c == (gfc_char4_t) EOF); 363 return (int) c; 364 365 invalid: 366 generate_error (&dtp->common, LIBERROR_READ_VALUE, "Invalid UTF-8 encoding"); 367 return (gfc_char4_t) '?'; 368} 369 370/* Push a character back onto the input. */ 371 372static void 373unget_char (st_parameter_dt *dtp, int c) 374{ 375 dtp->u.p.current_unit->last_char = c; 376} 377 378 379/* Skip over spaces in the input. Returns the nonspace character that 380 terminated the eating and also places it back on the input. */ 381 382static int 383eat_spaces (st_parameter_dt *dtp) 384{ 385 int c; 386 387 /* If internal character array IO, peak ahead and seek past spaces. 388 This is an optimization unique to character arrays with large 389 character lengths (PR38199). This code eliminates numerous calls 390 to next_character. */ 391 if (is_array_io (dtp) && (dtp->u.p.current_unit->last_char == EOF - 1)) 392 { 393 gfc_offset offset = stell (dtp->u.p.current_unit->s); 394 gfc_offset i; 395 396 if (is_char4_unit(dtp)) /* kind=4 */ 397 { 398 for (i = 0; i < dtp->u.p.current_unit->bytes_left; i++) 399 { 400 if (dtp->internal_unit[(offset + i) * sizeof (gfc_char4_t)] 401 != (gfc_char4_t)' ') 402 break; 403 } 404 } 405 else 406 { 407 for (i = 0; i < dtp->u.p.current_unit->bytes_left; i++) 408 { 409 if (dtp->internal_unit[offset + i] != ' ') 410 break; 411 } 412 } 413 414 if (i != 0) 415 { 416 sseek (dtp->u.p.current_unit->s, offset + i, SEEK_SET); 417 dtp->u.p.current_unit->bytes_left -= i; 418 } 419 } 420 421 /* Now skip spaces, EOF and EOL are handled in next_char. */ 422 do 423 c = next_char (dtp); 424 while (c != EOF && (c == ' ' || c == '\r' || c == '\t')); 425 426 unget_char (dtp, c); 427 return c; 428} 429 430 431/* This function reads characters through to the end of the current 432 line and just ignores them. Returns 0 for success and LIBERROR_END 433 if it hit EOF. */ 434 435static int 436eat_line (st_parameter_dt *dtp) 437{ 438 int c; 439 440 do 441 c = next_char (dtp); 442 while (c != EOF && c != '\n'); 443 if (c == EOF) 444 return LIBERROR_END; 445 return 0; 446} 447 448 449/* Skip over a separator. Technically, we don't always eat the whole 450 separator. This is because if we've processed the last input item, 451 then a separator is unnecessary. Plus the fact that operating 452 systems usually deliver console input on a line basis. 453 454 The upshot is that if we see a newline as part of reading a 455 separator, we stop reading. If there are more input items, we 456 continue reading the separator with finish_separator() which takes 457 care of the fact that we may or may not have seen a comma as part 458 of the separator. 459 460 Returns 0 for success, and non-zero error code otherwise. */ 461 462static int 463eat_separator (st_parameter_dt *dtp) 464{ 465 int c, n; 466 int err = 0; 467 468 eat_spaces (dtp); 469 dtp->u.p.comma_flag = 0; 470 471 if ((c = next_char (dtp)) == EOF) 472 return LIBERROR_END; 473 switch (c) 474 { 475 case ',': 476 if (dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA) 477 { 478 unget_char (dtp, c); 479 break; 480 } 481 /* Fall through. */ 482 case ';': 483 dtp->u.p.comma_flag = 1; 484 eat_spaces (dtp); 485 break; 486 487 case '/': 488 dtp->u.p.input_complete = 1; 489 break; 490 491 case '\r': 492 if ((n = next_char(dtp)) == EOF) 493 return LIBERROR_END; 494 if (n != '\n') 495 { 496 unget_char (dtp, n); 497 break; 498 } 499 /* Fall through. */ 500 case '\n': 501 dtp->u.p.at_eol = 1; 502 if (dtp->u.p.namelist_mode) 503 { 504 do 505 { 506 if ((c = next_char (dtp)) == EOF) 507 return LIBERROR_END; 508 if (c == '!') 509 { 510 err = eat_line (dtp); 511 if (err) 512 return err; 513 c = '\n'; 514 } 515 } 516 while (c == '\n' || c == '\r' || c == ' ' || c == '\t'); 517 unget_char (dtp, c); 518 } 519 break; 520 521 case '!': 522 /* Eat a namelist comment. */ 523 if (dtp->u.p.namelist_mode) 524 { 525 err = eat_line (dtp); 526 if (err) 527 return err; 528 529 break; 530 } 531 532 /* Fall Through... */ 533 534 default: 535 unget_char (dtp, c); 536 break; 537 } 538 return err; 539} 540 541 542/* Finish processing a separator that was interrupted by a newline. 543 If we're here, then another data item is present, so we finish what 544 we started on the previous line. Return 0 on success, error code 545 on failure. */ 546 547static int 548finish_separator (st_parameter_dt *dtp) 549{ 550 int c; 551 int err = LIBERROR_OK; 552 553 restart: 554 eat_spaces (dtp); 555 556 if ((c = next_char (dtp)) == EOF) 557 return LIBERROR_END; 558 switch (c) 559 { 560 case ',': 561 if (dtp->u.p.comma_flag) 562 unget_char (dtp, c); 563 else 564 { 565 if ((c = eat_spaces (dtp)) == EOF) 566 return LIBERROR_END; 567 if (c == '\n' || c == '\r') 568 goto restart; 569 } 570 571 break; 572 573 case '/': 574 dtp->u.p.input_complete = 1; 575 if (!dtp->u.p.namelist_mode) 576 return err; 577 break; 578 579 case '\n': 580 case '\r': 581 goto restart; 582 583 case '!': 584 if (dtp->u.p.namelist_mode) 585 { 586 err = eat_line (dtp); 587 if (err) 588 return err; 589 goto restart; 590 } 591 /* Fall through. */ 592 default: 593 unget_char (dtp, c); 594 break; 595 } 596 return err; 597} 598 599 600/* This function is needed to catch bad conversions so that namelist can 601 attempt to see if dtp->u.p.saved_string contains a new object name rather 602 than a bad value. */ 603 604static int 605nml_bad_return (st_parameter_dt *dtp, char c) 606{ 607 if (dtp->u.p.namelist_mode) 608 { 609 dtp->u.p.nml_read_error = 1; 610 unget_char (dtp, c); 611 return 1; 612 } 613 return 0; 614} 615 616/* Convert an unsigned string to an integer. The length value is -1 617 if we are working on a repeat count. Returns nonzero if we have a 618 range problem. As a side effect, frees the dtp->u.p.saved_string. */ 619 620static int 621convert_integer (st_parameter_dt *dtp, int length, int negative) 622{ 623 char c, *buffer, message[MSGLEN]; 624 int m; 625 GFC_UINTEGER_LARGEST v, max, max10; 626 GFC_INTEGER_LARGEST value; 627 628 buffer = dtp->u.p.saved_string; 629 v = 0; 630 631 if (length == -1) 632 max = MAX_REPEAT; 633 else 634 { 635 max = si_max (length); 636 if (negative) 637 max++; 638 } 639 max10 = max / 10; 640 641 for (;;) 642 { 643 c = *buffer++; 644 if (c == '\0') 645 break; 646 c -= '0'; 647 648 if (v > max10) 649 goto overflow; 650 v = 10 * v; 651 652 if (v > max - c) 653 goto overflow; 654 v += c; 655 } 656 657 m = 0; 658 659 if (length != -1) 660 { 661 if (negative) 662 value = -v; 663 else 664 value = v; 665 set_integer (dtp->u.p.value, value, length); 666 } 667 else 668 { 669 dtp->u.p.repeat_count = v; 670 671 if (dtp->u.p.repeat_count == 0) 672 { 673 snprintf (message, MSGLEN, "Zero repeat count in item %d of list input", 674 dtp->u.p.item_count); 675 676 generate_error (&dtp->common, LIBERROR_READ_VALUE, message); 677 m = 1; 678 } 679 } 680 681 free_saved (dtp); 682 return m; 683 684 overflow: 685 if (length == -1) 686 snprintf (message, MSGLEN, "Repeat count overflow in item %d of list input", 687 dtp->u.p.item_count); 688 else 689 snprintf (message, MSGLEN, "Integer overflow while reading item %d", 690 dtp->u.p.item_count); 691 692 free_saved (dtp); 693 generate_error (&dtp->common, LIBERROR_READ_VALUE, message); 694 695 return 1; 696} 697 698 699/* Parse a repeat count for logical and complex values which cannot 700 begin with a digit. Returns nonzero if we are done, zero if we 701 should continue on. */ 702 703static int 704parse_repeat (st_parameter_dt *dtp) 705{ 706 char message[MSGLEN]; 707 int c, repeat; 708 709 if ((c = next_char (dtp)) == EOF) 710 goto bad_repeat; 711 switch (c) 712 { 713 CASE_DIGITS: 714 repeat = c - '0'; 715 break; 716 717 CASE_SEPARATORS: 718 unget_char (dtp, c); 719 eat_separator (dtp); 720 return 1; 721 722 default: 723 unget_char (dtp, c); 724 return 0; 725 } 726 727 for (;;) 728 { 729 c = next_char (dtp); 730 switch (c) 731 { 732 CASE_DIGITS: 733 repeat = 10 * repeat + c - '0'; 734 735 if (repeat > MAX_REPEAT) 736 { 737 snprintf (message, MSGLEN, 738 "Repeat count overflow in item %d of list input", 739 dtp->u.p.item_count); 740 741 generate_error (&dtp->common, LIBERROR_READ_VALUE, message); 742 return 1; 743 } 744 745 break; 746 747 case '*': 748 if (repeat == 0) 749 { 750 snprintf (message, MSGLEN, 751 "Zero repeat count in item %d of list input", 752 dtp->u.p.item_count); 753 754 generate_error (&dtp->common, LIBERROR_READ_VALUE, message); 755 return 1; 756 } 757 758 goto done; 759 760 default: 761 goto bad_repeat; 762 } 763 } 764 765 done: 766 dtp->u.p.repeat_count = repeat; 767 return 0; 768 769 bad_repeat: 770 771 free_saved (dtp); 772 if (c == EOF) 773 { 774 free_line (dtp); 775 hit_eof (dtp); 776 return 1; 777 } 778 else 779 eat_line (dtp); 780 snprintf (message, MSGLEN, "Bad repeat count in item %d of list input", 781 dtp->u.p.item_count); 782 generate_error (&dtp->common, LIBERROR_READ_VALUE, message); 783 return 1; 784} 785 786 787/* To read a logical we have to look ahead in the input stream to make sure 788 there is not an equal sign indicating a variable name. To do this we use 789 line_buffer to point to a temporary buffer, pushing characters there for 790 possible later reading. */ 791 792static void 793l_push_char (st_parameter_dt *dtp, char c) 794{ 795 if (dtp->u.p.line_buffer == NULL) 796 dtp->u.p.line_buffer = xcalloc (SCRATCH_SIZE, 1); 797 798 dtp->u.p.line_buffer[dtp->u.p.line_buffer_pos++] = c; 799} 800 801 802/* Read a logical character on the input. */ 803 804static void 805read_logical (st_parameter_dt *dtp, int length) 806{ 807 char message[MSGLEN]; 808 int c, i, v; 809 810 if (parse_repeat (dtp)) 811 return; 812 813 c = safe_tolower (next_char (dtp)); 814 l_push_char (dtp, c); 815 switch (c) 816 { 817 case 't': 818 v = 1; 819 c = next_char (dtp); 820 l_push_char (dtp, c); 821 822 if (!is_separator(c) && c != EOF) 823 goto possible_name; 824 825 unget_char (dtp, c); 826 break; 827 case 'f': 828 v = 0; 829 c = next_char (dtp); 830 l_push_char (dtp, c); 831 832 if (!is_separator(c) && c != EOF) 833 goto possible_name; 834 835 unget_char (dtp, c); 836 break; 837 838 case '.': 839 c = safe_tolower (next_char (dtp)); 840 switch (c) 841 { 842 case 't': 843 v = 1; 844 break; 845 case 'f': 846 v = 0; 847 break; 848 default: 849 goto bad_logical; 850 } 851 852 break; 853 854 case '!': 855 if (!dtp->u.p.namelist_mode) 856 goto bad_logical; 857 858 CASE_SEPARATORS: 859 case EOF: 860 unget_char (dtp, c); 861 eat_separator (dtp); 862 return; /* Null value. */ 863 864 default: 865 /* Save the character in case it is the beginning 866 of the next object name. */ 867 unget_char (dtp, c); 868 goto bad_logical; 869 } 870 871 dtp->u.p.saved_type = BT_LOGICAL; 872 dtp->u.p.saved_length = length; 873 874 /* Eat trailing garbage. */ 875 do 876 c = next_char (dtp); 877 while (c != EOF && !is_separator (c)); 878 879 unget_char (dtp, c); 880 eat_separator (dtp); 881 set_integer ((int *) dtp->u.p.value, v, length); 882 free_line (dtp); 883 884 return; 885 886 possible_name: 887 888 for(i = 0; i < 63; i++) 889 { 890 c = next_char (dtp); 891 if (is_separator(c)) 892 { 893 /* All done if this is not a namelist read. */ 894 if (!dtp->u.p.namelist_mode) 895 goto logical_done; 896 897 unget_char (dtp, c); 898 eat_separator (dtp); 899 c = next_char (dtp); 900 if (c != '=') 901 { 902 unget_char (dtp, c); 903 goto logical_done; 904 } 905 } 906 907 l_push_char (dtp, c); 908 if (c == '=') 909 { 910 dtp->u.p.nml_read_error = 1; 911 dtp->u.p.line_buffer_enabled = 1; 912 dtp->u.p.line_buffer_pos = 0; 913 return; 914 } 915 916 } 917 918 bad_logical: 919 920 if (nml_bad_return (dtp, c)) 921 { 922 free_line (dtp); 923 return; 924 } 925 926 927 free_saved (dtp); 928 if (c == EOF) 929 { 930 free_line (dtp); 931 hit_eof (dtp); 932 return; 933 } 934 else if (c != '\n') 935 eat_line (dtp); 936 snprintf (message, MSGLEN, "Bad logical value while reading item %d", 937 dtp->u.p.item_count); 938 free_line (dtp); 939 generate_error (&dtp->common, LIBERROR_READ_VALUE, message); 940 return; 941 942 logical_done: 943 944 dtp->u.p.saved_type = BT_LOGICAL; 945 dtp->u.p.saved_length = length; 946 set_integer ((int *) dtp->u.p.value, v, length); 947 free_saved (dtp); 948 free_line (dtp); 949} 950 951 952/* Reading integers is tricky because we can actually be reading a 953 repeat count. We have to store the characters in a buffer because 954 we could be reading an integer that is larger than the default int 955 used for repeat counts. */ 956 957static void 958read_integer (st_parameter_dt *dtp, int length) 959{ 960 char message[MSGLEN]; 961 int c, negative; 962 963 negative = 0; 964 965 c = next_char (dtp); 966 switch (c) 967 { 968 case '-': 969 negative = 1; 970 /* Fall through... */ 971 972 case '+': 973 if ((c = next_char (dtp)) == EOF) 974 goto bad_integer; 975 goto get_integer; 976 977 case '!': 978 if (!dtp->u.p.namelist_mode) 979 goto bad_integer; 980 981 CASE_SEPARATORS: /* Single null. */ 982 unget_char (dtp, c); 983 eat_separator (dtp); 984 return; 985 986 CASE_DIGITS: 987 push_char (dtp, c); 988 break; 989 990 default: 991 goto bad_integer; 992 } 993 994 /* Take care of what may be a repeat count. */ 995 996 for (;;) 997 { 998 c = next_char (dtp); 999 switch (c) 1000 { 1001 CASE_DIGITS: 1002 push_char (dtp, c); 1003 break; 1004 1005 case '*': 1006 push_char (dtp, '\0'); 1007 goto repeat; 1008 1009 case '!': 1010 if (!dtp->u.p.namelist_mode) 1011 goto bad_integer; 1012 1013 CASE_SEPARATORS: /* Not a repeat count. */ 1014 case EOF: 1015 goto done; 1016 1017 default: 1018 goto bad_integer; 1019 } 1020 } 1021 1022 repeat: 1023 if (convert_integer (dtp, -1, 0)) 1024 return; 1025 1026 /* Get the real integer. */ 1027 1028 if ((c = next_char (dtp)) == EOF) 1029 goto bad_integer; 1030 switch (c) 1031 { 1032 CASE_DIGITS: 1033 break; 1034 1035 case '!': 1036 if (!dtp->u.p.namelist_mode) 1037 goto bad_integer; 1038 1039 CASE_SEPARATORS: 1040 unget_char (dtp, c); 1041 eat_separator (dtp); 1042 return; 1043 1044 case '-': 1045 negative = 1; 1046 /* Fall through... */ 1047 1048 case '+': 1049 c = next_char (dtp); 1050 break; 1051 } 1052 1053 get_integer: 1054 if (!safe_isdigit (c)) 1055 goto bad_integer; 1056 push_char (dtp, c); 1057 1058 for (;;) 1059 { 1060 c = next_char (dtp); 1061 switch (c) 1062 { 1063 CASE_DIGITS: 1064 push_char (dtp, c); 1065 break; 1066 1067 case '!': 1068 if (!dtp->u.p.namelist_mode) 1069 goto bad_integer; 1070 1071 CASE_SEPARATORS: 1072 case EOF: 1073 goto done; 1074 1075 default: 1076 goto bad_integer; 1077 } 1078 } 1079 1080 bad_integer: 1081 1082 if (nml_bad_return (dtp, c)) 1083 return; 1084 1085 free_saved (dtp); 1086 if (c == EOF) 1087 { 1088 free_line (dtp); 1089 hit_eof (dtp); 1090 return; 1091 } 1092 else if (c != '\n') 1093 eat_line (dtp); 1094 1095 snprintf (message, MSGLEN, "Bad integer for item %d in list input", 1096 dtp->u.p.item_count); 1097 free_line (dtp); 1098 generate_error (&dtp->common, LIBERROR_READ_VALUE, message); 1099 1100 return; 1101 1102 done: 1103 unget_char (dtp, c); 1104 eat_separator (dtp); 1105 1106 push_char (dtp, '\0'); 1107 if (convert_integer (dtp, length, negative)) 1108 { 1109 free_saved (dtp); 1110 return; 1111 } 1112 1113 free_saved (dtp); 1114 dtp->u.p.saved_type = BT_INTEGER; 1115} 1116 1117 1118/* Read a character variable. */ 1119 1120static void 1121read_character (st_parameter_dt *dtp, int length __attribute__ ((unused))) 1122{ 1123 char quote, message[MSGLEN]; 1124 int c; 1125 1126 quote = ' '; /* Space means no quote character. */ 1127 1128 if ((c = next_char (dtp)) == EOF) 1129 goto eof; 1130 switch (c) 1131 { 1132 CASE_DIGITS: 1133 push_char (dtp, c); 1134 break; 1135 1136 CASE_SEPARATORS: 1137 case EOF: 1138 unget_char (dtp, c); /* NULL value. */ 1139 eat_separator (dtp); 1140 return; 1141 1142 case '"': 1143 case '\'': 1144 quote = c; 1145 goto get_string; 1146 1147 default: 1148 if (dtp->u.p.namelist_mode) 1149 { 1150 unget_char (dtp, c); 1151 return; 1152 } 1153 push_char (dtp, c); 1154 goto get_string; 1155 } 1156 1157 /* Deal with a possible repeat count. */ 1158 1159 for (;;) 1160 { 1161 c = next_char (dtp); 1162 switch (c) 1163 { 1164 CASE_DIGITS: 1165 push_char (dtp, c); 1166 break; 1167 1168 CASE_SEPARATORS: 1169 case EOF: 1170 unget_char (dtp, c); 1171 goto done; /* String was only digits! */ 1172 1173 case '*': 1174 push_char (dtp, '\0'); 1175 goto got_repeat; 1176 1177 default: 1178 push_char (dtp, c); 1179 goto get_string; /* Not a repeat count after all. */ 1180 } 1181 } 1182 1183 got_repeat: 1184 if (convert_integer (dtp, -1, 0)) 1185 return; 1186 1187 /* Now get the real string. */ 1188 1189 if ((c = next_char (dtp)) == EOF) 1190 goto eof; 1191 switch (c) 1192 { 1193 CASE_SEPARATORS: 1194 unget_char (dtp, c); /* Repeated NULL values. */ 1195 eat_separator (dtp); 1196 return; 1197 1198 case '"': 1199 case '\'': 1200 quote = c; 1201 break; 1202 1203 default: 1204 push_char (dtp, c); 1205 break; 1206 } 1207 1208 get_string: 1209 1210 for (;;) 1211 { 1212 if ((c = next_char (dtp)) == EOF) 1213 goto done_eof; 1214 switch (c) 1215 { 1216 case '"': 1217 case '\'': 1218 if (c != quote) 1219 { 1220 push_char (dtp, c); 1221 break; 1222 } 1223 1224 /* See if we have a doubled quote character or the end of 1225 the string. */ 1226 1227 if ((c = next_char (dtp)) == EOF) 1228 goto done_eof; 1229 if (c == quote) 1230 { 1231 push_char (dtp, quote); 1232 break; 1233 } 1234 1235 unget_char (dtp, c); 1236 goto done; 1237 1238 CASE_SEPARATORS: 1239 if (quote == ' ') 1240 { 1241 unget_char (dtp, c); 1242 goto done; 1243 } 1244 1245 if (c != '\n' && c != '\r') 1246 push_char (dtp, c); 1247 break; 1248 1249 default: 1250 push_char (dtp, c); 1251 break; 1252 } 1253 } 1254 1255 /* At this point, we have to have a separator, or else the string is 1256 invalid. */ 1257 done: 1258 c = next_char (dtp); 1259 done_eof: 1260 if (is_separator (c) || c == EOF) 1261 { 1262 unget_char (dtp, c); 1263 eat_separator (dtp); 1264 dtp->u.p.saved_type = BT_CHARACTER; 1265 } 1266 else 1267 { 1268 free_saved (dtp); 1269 snprintf (message, MSGLEN, "Invalid string input in item %d", 1270 dtp->u.p.item_count); 1271 generate_error (&dtp->common, LIBERROR_READ_VALUE, message); 1272 } 1273 free_line (dtp); 1274 return; 1275 1276 eof: 1277 free_saved (dtp); 1278 free_line (dtp); 1279 hit_eof (dtp); 1280} 1281 1282 1283/* Parse a component of a complex constant or a real number that we 1284 are sure is already there. This is a straight real number parser. */ 1285 1286static int 1287parse_real (st_parameter_dt *dtp, void *buffer, int length) 1288{ 1289 char message[MSGLEN]; 1290 int c, m, seen_dp; 1291 1292 if ((c = next_char (dtp)) == EOF) 1293 goto bad; 1294 1295 if (c == '-' || c == '+') 1296 { 1297 push_char (dtp, c); 1298 if ((c = next_char (dtp)) == EOF) 1299 goto bad; 1300 } 1301 1302 if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA) 1303 c = '.'; 1304 1305 if (!safe_isdigit (c) && c != '.') 1306 { 1307 if (c == 'i' || c == 'I' || c == 'n' || c == 'N') 1308 goto inf_nan; 1309 else 1310 goto bad; 1311 } 1312 1313 push_char (dtp, c); 1314 1315 seen_dp = (c == '.') ? 1 : 0; 1316 1317 for (;;) 1318 { 1319 if ((c = next_char (dtp)) == EOF) 1320 goto bad; 1321 if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA) 1322 c = '.'; 1323 switch (c) 1324 { 1325 CASE_DIGITS: 1326 push_char (dtp, c); 1327 break; 1328 1329 case '.': 1330 if (seen_dp) 1331 goto bad; 1332 1333 seen_dp = 1; 1334 push_char (dtp, c); 1335 break; 1336 1337 case 'e': 1338 case 'E': 1339 case 'd': 1340 case 'D': 1341 case 'q': 1342 case 'Q': 1343 push_char (dtp, 'e'); 1344 goto exp1; 1345 1346 case '-': 1347 case '+': 1348 push_char (dtp, 'e'); 1349 push_char (dtp, c); 1350 if ((c = next_char (dtp)) == EOF) 1351 goto bad; 1352 goto exp2; 1353 1354 case '!': 1355 if (!dtp->u.p.namelist_mode) 1356 goto bad; 1357 1358 CASE_SEPARATORS: 1359 case EOF: 1360 goto done; 1361 1362 default: 1363 goto done; 1364 } 1365 } 1366 1367 exp1: 1368 if ((c = next_char (dtp)) == EOF) 1369 goto bad; 1370 if (c != '-' && c != '+') 1371 push_char (dtp, '+'); 1372 else 1373 { 1374 push_char (dtp, c); 1375 c = next_char (dtp); 1376 } 1377 1378 exp2: 1379 if (!safe_isdigit (c)) 1380 { 1381 /* Extension: allow default exponent of 0 when omitted. */ 1382 if (dtp->common.flags & IOPARM_DT_DEC_EXT) 1383 { 1384 push_char (dtp, '0'); 1385 goto done; 1386 } 1387 else 1388 goto bad_exponent; 1389 } 1390 1391 push_char (dtp, c); 1392 1393 for (;;) 1394 { 1395 if ((c = next_char (dtp)) == EOF) 1396 goto bad; 1397 switch (c) 1398 { 1399 CASE_DIGITS: 1400 push_char (dtp, c); 1401 break; 1402 1403 case '!': 1404 if (!dtp->u.p.namelist_mode) 1405 goto bad; 1406 1407 CASE_SEPARATORS: 1408 case EOF: 1409 unget_char (dtp, c); 1410 goto done; 1411 1412 default: 1413 goto done; 1414 } 1415 } 1416 1417 done: 1418 unget_char (dtp, c); 1419 push_char (dtp, '\0'); 1420 1421 m = convert_real (dtp, buffer, dtp->u.p.saved_string, length); 1422 free_saved (dtp); 1423 1424 return m; 1425 1426 done_infnan: 1427 unget_char (dtp, c); 1428 push_char (dtp, '\0'); 1429 1430 m = convert_infnan (dtp, buffer, dtp->u.p.saved_string, length); 1431 free_saved (dtp); 1432 1433 return m; 1434 1435 inf_nan: 1436 /* Match INF and Infinity. */ 1437 if ((c == 'i' || c == 'I') 1438 && ((c = next_char (dtp)) == 'n' || c == 'N') 1439 && ((c = next_char (dtp)) == 'f' || c == 'F')) 1440 { 1441 c = next_char (dtp); 1442 if ((c != 'i' && c != 'I') 1443 || ((c == 'i' || c == 'I') 1444 && ((c = next_char (dtp)) == 'n' || c == 'N') 1445 && ((c = next_char (dtp)) == 'i' || c == 'I') 1446 && ((c = next_char (dtp)) == 't' || c == 'T') 1447 && ((c = next_char (dtp)) == 'y' || c == 'Y') 1448 && (c = next_char (dtp)))) 1449 { 1450 if (is_separator (c) || (c == EOF)) 1451 unget_char (dtp, c); 1452 push_char (dtp, 'i'); 1453 push_char (dtp, 'n'); 1454 push_char (dtp, 'f'); 1455 goto done_infnan; 1456 } 1457 } /* Match NaN. */ 1458 else if (((c = next_char (dtp)) == 'a' || c == 'A') 1459 && ((c = next_char (dtp)) == 'n' || c == 'N') 1460 && (c = next_char (dtp))) 1461 { 1462 if (is_separator (c) || (c == EOF)) 1463 unget_char (dtp, c); 1464 push_char (dtp, 'n'); 1465 push_char (dtp, 'a'); 1466 push_char (dtp, 'n'); 1467 1468 /* Match "NAN(alphanum)". */ 1469 if (c == '(') 1470 { 1471 for ( ; c != ')'; c = next_char (dtp)) 1472 if (is_separator (c)) 1473 goto bad; 1474 1475 c = next_char (dtp); 1476 if (is_separator (c) || (c == EOF)) 1477 unget_char (dtp, c); 1478 } 1479 goto done_infnan; 1480 } 1481 1482 bad: 1483 1484 if (nml_bad_return (dtp, c)) 1485 return 0; 1486 1487 bad_exponent: 1488 1489 free_saved (dtp); 1490 if (c == EOF) 1491 { 1492 free_line (dtp); 1493 hit_eof (dtp); 1494 return 1; 1495 } 1496 else if (c != '\n') 1497 eat_line (dtp); 1498 1499 snprintf (message, MSGLEN, "Bad complex floating point " 1500 "number for item %d", dtp->u.p.item_count); 1501 free_line (dtp); 1502 generate_error (&dtp->common, LIBERROR_READ_VALUE, message); 1503 1504 return 1; 1505} 1506 1507 1508/* Reading a complex number is straightforward because we can tell 1509 what it is right away. */ 1510 1511static void 1512read_complex (st_parameter_dt *dtp, void *dest, int kind, size_t size) 1513{ 1514 char message[MSGLEN]; 1515 int c; 1516 1517 if (parse_repeat (dtp)) 1518 return; 1519 1520 c = next_char (dtp); 1521 switch (c) 1522 { 1523 case '(': 1524 break; 1525 1526 case '!': 1527 if (!dtp->u.p.namelist_mode) 1528 goto bad_complex; 1529 1530 CASE_SEPARATORS: 1531 case EOF: 1532 unget_char (dtp, c); 1533 eat_separator (dtp); 1534 return; 1535 1536 default: 1537 goto bad_complex; 1538 } 1539 1540eol_1: 1541 eat_spaces (dtp); 1542 c = next_char (dtp); 1543 if (c == '\n' || c== '\r') 1544 goto eol_1; 1545 else 1546 unget_char (dtp, c); 1547 1548 if (parse_real (dtp, dest, kind)) 1549 return; 1550 1551eol_2: 1552 eat_spaces (dtp); 1553 c = next_char (dtp); 1554 if (c == '\n' || c== '\r') 1555 goto eol_2; 1556 else 1557 unget_char (dtp, c); 1558 1559 if (next_char (dtp) 1560 != (dtp->u.p.current_unit->decimal_status == DECIMAL_POINT ? ',' : ';')) 1561 goto bad_complex; 1562 1563eol_3: 1564 eat_spaces (dtp); 1565 c = next_char (dtp); 1566 if (c == '\n' || c== '\r') 1567 goto eol_3; 1568 else 1569 unget_char (dtp, c); 1570 1571 if (parse_real (dtp, dest + size / 2, kind)) 1572 return; 1573 1574eol_4: 1575 eat_spaces (dtp); 1576 c = next_char (dtp); 1577 if (c == '\n' || c== '\r') 1578 goto eol_4; 1579 else 1580 unget_char (dtp, c); 1581 1582 if (next_char (dtp) != ')') 1583 goto bad_complex; 1584 1585 c = next_char (dtp); 1586 if (!is_separator (c) && (c != EOF)) 1587 goto bad_complex; 1588 1589 unget_char (dtp, c); 1590 eat_separator (dtp); 1591 1592 free_saved (dtp); 1593 dtp->u.p.saved_type = BT_COMPLEX; 1594 return; 1595 1596 bad_complex: 1597 1598 if (nml_bad_return (dtp, c)) 1599 return; 1600 1601 free_saved (dtp); 1602 if (c == EOF) 1603 { 1604 free_line (dtp); 1605 hit_eof (dtp); 1606 return; 1607 } 1608 else if (c != '\n') 1609 eat_line (dtp); 1610 1611 snprintf (message, MSGLEN, "Bad complex value in item %d of list input", 1612 dtp->u.p.item_count); 1613 free_line (dtp); 1614 generate_error (&dtp->common, LIBERROR_READ_VALUE, message); 1615} 1616 1617 1618/* Parse a real number with a possible repeat count. */ 1619 1620static void 1621read_real (st_parameter_dt *dtp, void *dest, int length) 1622{ 1623 char message[MSGLEN]; 1624 int c; 1625 int seen_dp; 1626 int is_inf; 1627 1628 seen_dp = 0; 1629 1630 c = next_char (dtp); 1631 if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA) 1632 c = '.'; 1633 switch (c) 1634 { 1635 CASE_DIGITS: 1636 push_char (dtp, c); 1637 break; 1638 1639 case '.': 1640 push_char (dtp, c); 1641 seen_dp = 1; 1642 break; 1643 1644 case '+': 1645 case '-': 1646 goto got_sign; 1647 1648 case '!': 1649 if (!dtp->u.p.namelist_mode) 1650 goto bad_real; 1651 1652 CASE_SEPARATORS: 1653 unget_char (dtp, c); /* Single null. */ 1654 eat_separator (dtp); 1655 return; 1656 1657 case 'i': 1658 case 'I': 1659 case 'n': 1660 case 'N': 1661 goto inf_nan; 1662 1663 default: 1664 goto bad_real; 1665 } 1666 1667 /* Get the digit string that might be a repeat count. */ 1668 1669 for (;;) 1670 { 1671 c = next_char (dtp); 1672 if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA) 1673 c = '.'; 1674 switch (c) 1675 { 1676 CASE_DIGITS: 1677 push_char (dtp, c); 1678 break; 1679 1680 case '.': 1681 if (seen_dp) 1682 goto bad_real; 1683 1684 seen_dp = 1; 1685 push_char (dtp, c); 1686 goto real_loop; 1687 1688 case 'E': 1689 case 'e': 1690 case 'D': 1691 case 'd': 1692 case 'Q': 1693 case 'q': 1694 goto exp1; 1695 1696 case '+': 1697 case '-': 1698 push_char (dtp, 'e'); 1699 push_char (dtp, c); 1700 c = next_char (dtp); 1701 goto exp2; 1702 1703 case '*': 1704 push_char (dtp, '\0'); 1705 goto got_repeat; 1706 1707 case '!': 1708 if (!dtp->u.p.namelist_mode) 1709 goto bad_real; 1710 1711 CASE_SEPARATORS: 1712 case EOF: 1713 if (c != '\n' && c != ',' && c != '\r' && c != ';') 1714 unget_char (dtp, c); 1715 goto done; 1716 1717 default: 1718 goto bad_real; 1719 } 1720 } 1721 1722 got_repeat: 1723 if (convert_integer (dtp, -1, 0)) 1724 return; 1725 1726 /* Now get the number itself. */ 1727 1728 if ((c = next_char (dtp)) == EOF) 1729 goto bad_real; 1730 if (is_separator (c)) 1731 { /* Repeated null value. */ 1732 unget_char (dtp, c); 1733 eat_separator (dtp); 1734 return; 1735 } 1736 1737 if (c != '-' && c != '+') 1738 push_char (dtp, '+'); 1739 else 1740 { 1741 got_sign: 1742 push_char (dtp, c); 1743 if ((c = next_char (dtp)) == EOF) 1744 goto bad_real; 1745 } 1746 1747 if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA) 1748 c = '.'; 1749 1750 if (!safe_isdigit (c) && c != '.') 1751 { 1752 if (c == 'i' || c == 'I' || c == 'n' || c == 'N') 1753 goto inf_nan; 1754 else 1755 goto bad_real; 1756 } 1757 1758 if (c == '.') 1759 { 1760 if (seen_dp) 1761 goto bad_real; 1762 else 1763 seen_dp = 1; 1764 } 1765 1766 push_char (dtp, c); 1767 1768 real_loop: 1769 for (;;) 1770 { 1771 c = next_char (dtp); 1772 if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA) 1773 c = '.'; 1774 switch (c) 1775 { 1776 CASE_DIGITS: 1777 push_char (dtp, c); 1778 break; 1779 1780 case '!': 1781 if (!dtp->u.p.namelist_mode) 1782 goto bad_real; 1783 1784 CASE_SEPARATORS: 1785 case EOF: 1786 goto done; 1787 1788 case '.': 1789 if (seen_dp) 1790 goto bad_real; 1791 1792 seen_dp = 1; 1793 push_char (dtp, c); 1794 break; 1795 1796 case 'E': 1797 case 'e': 1798 case 'D': 1799 case 'd': 1800 case 'Q': 1801 case 'q': 1802 goto exp1; 1803 1804 case '+': 1805 case '-': 1806 push_char (dtp, 'e'); 1807 push_char (dtp, c); 1808 c = next_char (dtp); 1809 goto exp2; 1810 1811 default: 1812 goto bad_real; 1813 } 1814 } 1815 1816 exp1: 1817 push_char (dtp, 'e'); 1818 1819 if ((c = next_char (dtp)) == EOF) 1820 goto bad_real; 1821 if (c != '+' && c != '-') 1822 push_char (dtp, '+'); 1823 else 1824 { 1825 push_char (dtp, c); 1826 c = next_char (dtp); 1827 } 1828 1829 exp2: 1830 if (!safe_isdigit (c)) 1831 { 1832 /* Extension: allow default exponent of 0 when omitted. */ 1833 if (dtp->common.flags & IOPARM_DT_DEC_EXT) 1834 { 1835 push_char (dtp, '0'); 1836 goto done; 1837 } 1838 else 1839 goto bad_exponent; 1840 } 1841 1842 push_char (dtp, c); 1843 1844 for (;;) 1845 { 1846 c = next_char (dtp); 1847 1848 switch (c) 1849 { 1850 CASE_DIGITS: 1851 push_char (dtp, c); 1852 break; 1853 1854 case '!': 1855 if (!dtp->u.p.namelist_mode) 1856 goto bad_real; 1857 1858 CASE_SEPARATORS: 1859 case EOF: 1860 goto done; 1861 1862 default: 1863 goto bad_real; 1864 } 1865 } 1866 1867 done: 1868 unget_char (dtp, c); 1869 eat_separator (dtp); 1870 push_char (dtp, '\0'); 1871 if (convert_real (dtp, dest, dtp->u.p.saved_string, length)) 1872 { 1873 free_saved (dtp); 1874 return; 1875 } 1876 1877 free_saved (dtp); 1878 dtp->u.p.saved_type = BT_REAL; 1879 return; 1880 1881 inf_nan: 1882 l_push_char (dtp, c); 1883 is_inf = 0; 1884 1885 /* Match INF and Infinity. */ 1886 if (c == 'i' || c == 'I') 1887 { 1888 c = next_char (dtp); 1889 l_push_char (dtp, c); 1890 if (c != 'n' && c != 'N') 1891 goto unwind; 1892 c = next_char (dtp); 1893 l_push_char (dtp, c); 1894 if (c != 'f' && c != 'F') 1895 goto unwind; 1896 c = next_char (dtp); 1897 l_push_char (dtp, c); 1898 if (!is_separator (c) && (c != EOF)) 1899 { 1900 if (c != 'i' && c != 'I') 1901 goto unwind; 1902 c = next_char (dtp); 1903 l_push_char (dtp, c); 1904 if (c != 'n' && c != 'N') 1905 goto unwind; 1906 c = next_char (dtp); 1907 l_push_char (dtp, c); 1908 if (c != 'i' && c != 'I') 1909 goto unwind; 1910 c = next_char (dtp); 1911 l_push_char (dtp, c); 1912 if (c != 't' && c != 'T') 1913 goto unwind; 1914 c = next_char (dtp); 1915 l_push_char (dtp, c); 1916 if (c != 'y' && c != 'Y') 1917 goto unwind; 1918 c = next_char (dtp); 1919 l_push_char (dtp, c); 1920 } 1921 is_inf = 1; 1922 } /* Match NaN. */ 1923 else 1924 { 1925 c = next_char (dtp); 1926 l_push_char (dtp, c); 1927 if (c != 'a' && c != 'A') 1928 goto unwind; 1929 c = next_char (dtp); 1930 l_push_char (dtp, c); 1931 if (c != 'n' && c != 'N') 1932 goto unwind; 1933 c = next_char (dtp); 1934 l_push_char (dtp, c); 1935 1936 /* Match NAN(alphanum). */ 1937 if (c == '(') 1938 { 1939 for (c = next_char (dtp); c != ')'; c = next_char (dtp)) 1940 if (is_separator (c)) 1941 goto unwind; 1942 else 1943 l_push_char (dtp, c); 1944 1945 l_push_char (dtp, ')'); 1946 c = next_char (dtp); 1947 l_push_char (dtp, c); 1948 } 1949 } 1950 1951 if (!is_separator (c) && (c != EOF)) 1952 goto unwind; 1953 1954 if (dtp->u.p.namelist_mode) 1955 { 1956 if (c == ' ' || c =='\n' || c == '\r') 1957 { 1958 do 1959 { 1960 if ((c = next_char (dtp)) == EOF) 1961 goto bad_real; 1962 } 1963 while (c == ' ' || c =='\n' || c == '\r'); 1964 1965 l_push_char (dtp, c); 1966 1967 if (c == '=') 1968 goto unwind; 1969 } 1970 } 1971 1972 if (is_inf) 1973 { 1974 push_char (dtp, 'i'); 1975 push_char (dtp, 'n'); 1976 push_char (dtp, 'f'); 1977 } 1978 else 1979 { 1980 push_char (dtp, 'n'); 1981 push_char (dtp, 'a'); 1982 push_char (dtp, 'n'); 1983 } 1984 1985 free_line (dtp); 1986 unget_char (dtp, c); 1987 eat_separator (dtp); 1988 push_char (dtp, '\0'); 1989 if (convert_infnan (dtp, dest, dtp->u.p.saved_string, length)) 1990 return; 1991 1992 free_saved (dtp); 1993 dtp->u.p.saved_type = BT_REAL; 1994 return; 1995 1996 unwind: 1997 if (dtp->u.p.namelist_mode) 1998 { 1999 dtp->u.p.nml_read_error = 1; 2000 dtp->u.p.line_buffer_enabled = 1; 2001 dtp->u.p.line_buffer_pos = 0; 2002 return; 2003 } 2004 2005 bad_real: 2006 2007 if (nml_bad_return (dtp, c)) 2008 return; 2009 2010 bad_exponent: 2011 2012 free_saved (dtp); 2013 if (c == EOF) 2014 { 2015 free_line (dtp); 2016 hit_eof (dtp); 2017 return; 2018 } 2019 else if (c != '\n') 2020 eat_line (dtp); 2021 2022 snprintf (message, MSGLEN, "Bad real number in item %d of list input", 2023 dtp->u.p.item_count); 2024 free_line (dtp); 2025 generate_error (&dtp->common, LIBERROR_READ_VALUE, message); 2026} 2027 2028 2029/* Check the current type against the saved type to make sure they are 2030 compatible. Returns nonzero if incompatible. */ 2031 2032static int 2033check_type (st_parameter_dt *dtp, bt type, int kind) 2034{ 2035 char message[MSGLEN]; 2036 2037 if (dtp->u.p.saved_type != BT_UNKNOWN && dtp->u.p.saved_type != type) 2038 { 2039 snprintf (message, MSGLEN, "Read type %s where %s was expected for item %d", 2040 type_name (dtp->u.p.saved_type), type_name (type), 2041 dtp->u.p.item_count); 2042 free_line (dtp); 2043 generate_error (&dtp->common, LIBERROR_READ_VALUE, message); 2044 return 1; 2045 } 2046 2047 if (dtp->u.p.saved_type == BT_UNKNOWN || dtp->u.p.saved_type == BT_CHARACTER) 2048 return 0; 2049 2050 if ((type != BT_COMPLEX && dtp->u.p.saved_length != kind) 2051 || (type == BT_COMPLEX && dtp->u.p.saved_length != kind*2)) 2052 { 2053 snprintf (message, MSGLEN, 2054 "Read kind %d %s where kind %d is required for item %d", 2055 type == BT_COMPLEX ? dtp->u.p.saved_length / 2 2056 : dtp->u.p.saved_length, 2057 type_name (dtp->u.p.saved_type), kind, 2058 dtp->u.p.item_count); 2059 free_line (dtp); 2060 generate_error (&dtp->common, LIBERROR_READ_VALUE, message); 2061 return 1; 2062 } 2063 2064 return 0; 2065} 2066 2067 2068/* Initialize the function pointers to select the correct versions of 2069 next_char and push_char depending on what we are doing. */ 2070 2071static void 2072set_workers (st_parameter_dt *dtp) 2073{ 2074 if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8) 2075 { 2076 dtp->u.p.current_unit->next_char_fn_ptr = &next_char_utf8; 2077 dtp->u.p.current_unit->push_char_fn_ptr = &push_char4; 2078 } 2079 else if (is_internal_unit (dtp)) 2080 { 2081 dtp->u.p.current_unit->next_char_fn_ptr = &next_char_internal; 2082 dtp->u.p.current_unit->push_char_fn_ptr = &push_char_default; 2083 } 2084 else 2085 { 2086 dtp->u.p.current_unit->next_char_fn_ptr = &next_char_default; 2087 dtp->u.p.current_unit->push_char_fn_ptr = &push_char_default; 2088 } 2089 2090} 2091 2092/* Top level data transfer subroutine for list reads. Because we have 2093 to deal with repeat counts, the data item is always saved after 2094 reading, usually in the dtp->u.p.value[] array. If a repeat count is 2095 greater than one, we copy the data item multiple times. */ 2096 2097static int 2098list_formatted_read_scalar (st_parameter_dt *dtp, bt type, void *p, 2099 int kind, size_t size) 2100{ 2101 gfc_char4_t *q, *r; 2102 size_t m; 2103 int c; 2104 int err = 0; 2105 2106 /* Set the next_char and push_char worker functions. */ 2107 set_workers (dtp); 2108 2109 if (dtp->u.p.first_item) 2110 { 2111 dtp->u.p.first_item = 0; 2112 dtp->u.p.input_complete = 0; 2113 dtp->u.p.repeat_count = 1; 2114 dtp->u.p.at_eol = 0; 2115 2116 if ((c = eat_spaces (dtp)) == EOF) 2117 { 2118 err = LIBERROR_END; 2119 goto cleanup; 2120 } 2121 if (is_separator (c)) 2122 { 2123 /* Found a null value. */ 2124 dtp->u.p.repeat_count = 0; 2125 eat_separator (dtp); 2126 2127 /* Set end-of-line flag. */ 2128 if (c == '\n' || c == '\r') 2129 { 2130 dtp->u.p.at_eol = 1; 2131 if (finish_separator (dtp) == LIBERROR_END) 2132 { 2133 err = LIBERROR_END; 2134 goto cleanup; 2135 } 2136 } 2137 else 2138 goto cleanup; 2139 } 2140 } 2141 else 2142 { 2143 if (dtp->u.p.repeat_count > 0) 2144 { 2145 if (check_type (dtp, type, kind)) 2146 return err; 2147 goto set_value; 2148 } 2149 2150 if (dtp->u.p.input_complete) 2151 goto cleanup; 2152 2153 if (dtp->u.p.at_eol) 2154 finish_separator (dtp); 2155 else 2156 { 2157 eat_spaces (dtp); 2158 /* Trailing spaces prior to end of line. */ 2159 if (dtp->u.p.at_eol) 2160 finish_separator (dtp); 2161 } 2162 2163 dtp->u.p.saved_type = BT_UNKNOWN; 2164 dtp->u.p.repeat_count = 1; 2165 } 2166 2167 switch (type) 2168 { 2169 case BT_INTEGER: 2170 read_integer (dtp, kind); 2171 break; 2172 case BT_LOGICAL: 2173 read_logical (dtp, kind); 2174 break; 2175 case BT_CHARACTER: 2176 read_character (dtp, kind); 2177 break; 2178 case BT_REAL: 2179 read_real (dtp, p, kind); 2180 /* Copy value back to temporary if needed. */ 2181 if (dtp->u.p.repeat_count > 0) 2182 memcpy (dtp->u.p.value, p, size); 2183 break; 2184 case BT_COMPLEX: 2185 read_complex (dtp, p, kind, size); 2186 /* Copy value back to temporary if needed. */ 2187 if (dtp->u.p.repeat_count > 0) 2188 memcpy (dtp->u.p.value, p, size); 2189 break; 2190 case BT_CLASS: 2191 { 2192 int unit = dtp->u.p.current_unit->unit_number; 2193 char iotype[] = "LISTDIRECTED"; 2194 gfc_charlen_type iotype_len = 12; 2195 char tmp_iomsg[IOMSG_LEN] = ""; 2196 char *child_iomsg; 2197 gfc_charlen_type child_iomsg_len; 2198 int noiostat; 2199 int *child_iostat = NULL; 2200 gfc_full_array_i4 vlist; 2201 2202 GFC_DESCRIPTOR_DATA(&vlist) = NULL; 2203 GFC_DIMENSION_SET(vlist.dim[0],1, 0, 0); 2204 2205 /* Set iostat, intent(out). */ 2206 noiostat = 0; 2207 child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ? 2208 dtp->common.iostat : &noiostat; 2209 2210 /* Set iomsge, intent(inout). */ 2211 if (dtp->common.flags & IOPARM_HAS_IOMSG) 2212 { 2213 child_iomsg = dtp->common.iomsg; 2214 child_iomsg_len = dtp->common.iomsg_len; 2215 } 2216 else 2217 { 2218 child_iomsg = tmp_iomsg; 2219 child_iomsg_len = IOMSG_LEN; 2220 } 2221 2222 /* Call the user defined formatted READ procedure. */ 2223 dtp->u.p.current_unit->child_dtio++; 2224 dtp->u.p.fdtio_ptr (p, &unit, iotype, &vlist, 2225 child_iostat, child_iomsg, 2226 iotype_len, child_iomsg_len); 2227 dtp->u.p.child_saved_iostat = *child_iostat; 2228 dtp->u.p.current_unit->child_dtio--; 2229 } 2230 break; 2231 default: 2232 internal_error (&dtp->common, "Bad type for list read"); 2233 } 2234 2235 if (dtp->u.p.saved_type != BT_CHARACTER && dtp->u.p.saved_type != BT_UNKNOWN) 2236 dtp->u.p.saved_length = size; 2237 2238 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK) 2239 goto cleanup; 2240 2241 set_value: 2242 switch (dtp->u.p.saved_type) 2243 { 2244 case BT_COMPLEX: 2245 case BT_REAL: 2246 if (dtp->u.p.repeat_count > 0) 2247 memcpy (p, dtp->u.p.value, size); 2248 break; 2249 2250 case BT_INTEGER: 2251 case BT_LOGICAL: 2252 memcpy (p, dtp->u.p.value, size); 2253 break; 2254 2255 case BT_CHARACTER: 2256 if (dtp->u.p.saved_string) 2257 { 2258 m = (size < (size_t) dtp->u.p.saved_used) 2259 ? size : (size_t) dtp->u.p.saved_used; 2260 2261 q = (gfc_char4_t *) p; 2262 r = (gfc_char4_t *) dtp->u.p.saved_string; 2263 if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8) 2264 for (size_t i = 0; i < m; i++) 2265 *q++ = *r++; 2266 else 2267 { 2268 if (kind == 1) 2269 memcpy (p, dtp->u.p.saved_string, m); 2270 else 2271 for (size_t i = 0; i < m; i++) 2272 *q++ = *r++; 2273 } 2274 } 2275 else 2276 /* Just delimiters encountered, nothing to copy but SPACE. */ 2277 m = 0; 2278 2279 if (m < size) 2280 { 2281 if (kind == 1) 2282 memset (((char *) p) + m, ' ', size - m); 2283 else 2284 { 2285 q = (gfc_char4_t *) p; 2286 for (size_t i = m; i < size; i++) 2287 q[i] = (unsigned char) ' '; 2288 } 2289 } 2290 break; 2291 2292 case BT_UNKNOWN: 2293 break; 2294 2295 default: 2296 internal_error (&dtp->common, "Bad type for list read"); 2297 } 2298 2299 if (--dtp->u.p.repeat_count <= 0) 2300 free_saved (dtp); 2301 2302cleanup: 2303 /* err may have been set above from finish_separator, so if it is set 2304 trigger the hit_eof. The hit_eof will set bits in common.flags. */ 2305 if (err == LIBERROR_END) 2306 { 2307 free_line (dtp); 2308 hit_eof (dtp); 2309 } 2310 /* Now we check common.flags for any errors that could have occurred in 2311 a READ elsewhere such as in read_integer. */ 2312 err = dtp->common.flags & IOPARM_LIBRETURN_MASK; 2313 fbuf_flush_list (dtp->u.p.current_unit, LIST_READING); 2314 return err; 2315} 2316 2317 2318void 2319list_formatted_read (st_parameter_dt *dtp, bt type, void *p, int kind, 2320 size_t size, size_t nelems) 2321{ 2322 size_t elem; 2323 char *tmp; 2324 size_t stride = type == BT_CHARACTER ? 2325 size * GFC_SIZE_OF_CHAR_KIND(kind) : size; 2326 int err; 2327 2328 tmp = (char *) p; 2329 2330 /* Big loop over all the elements. */ 2331 for (elem = 0; elem < nelems; elem++) 2332 { 2333 dtp->u.p.item_count++; 2334 err = list_formatted_read_scalar (dtp, type, tmp + stride*elem, 2335 kind, size); 2336 if (err) 2337 break; 2338 } 2339} 2340 2341 2342/* Finish a list read. */ 2343 2344void 2345finish_list_read (st_parameter_dt *dtp) 2346{ 2347 free_saved (dtp); 2348 2349 fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode); 2350 2351 if (dtp->u.p.at_eol) 2352 { 2353 dtp->u.p.at_eol = 0; 2354 return; 2355 } 2356 2357 if (!is_internal_unit (dtp)) 2358 { 2359 int c; 2360 2361 /* Set the next_char and push_char worker functions. */ 2362 set_workers (dtp); 2363 2364 if (likely (dtp->u.p.child_saved_iostat == LIBERROR_OK)) 2365 { 2366 c = next_char (dtp); 2367 if (c == EOF) 2368 { 2369 free_line (dtp); 2370 hit_eof (dtp); 2371 return; 2372 } 2373 if (c != '\n') 2374 eat_line (dtp); 2375 } 2376 } 2377 2378 free_line (dtp); 2379 2380} 2381 2382/* NAMELIST INPUT 2383 2384void namelist_read (st_parameter_dt *dtp) 2385calls: 2386 static void nml_match_name (char *name, int len) 2387 static int nml_query (st_parameter_dt *dtp) 2388 static int nml_get_obj_data (st_parameter_dt *dtp, 2389 namelist_info **prev_nl, char *, size_t) 2390calls: 2391 static void nml_untouch_nodes (st_parameter_dt *dtp) 2392 static namelist_info *find_nml_node (st_parameter_dt *dtp, 2393 char *var_name) 2394 static int nml_parse_qualifier(descriptor_dimension *ad, 2395 array_loop_spec *ls, int rank, char *) 2396 static void nml_touch_nodes (namelist_info *nl) 2397 static int nml_read_obj (namelist_info *nl, index_type offset, 2398 namelist_info **prev_nl, char *, size_t, 2399 index_type clow, index_type chigh) 2400calls: 2401 -itself- */ 2402 2403/* Inputs a rank-dimensional qualifier, which can contain 2404 singlets, doublets, triplets or ':' with the standard meanings. */ 2405 2406static bool 2407nml_parse_qualifier (st_parameter_dt *dtp, descriptor_dimension *ad, 2408 array_loop_spec *ls, int rank, bt nml_elem_type, 2409 char *parse_err_msg, size_t parse_err_msg_size, 2410 int *parsed_rank) 2411{ 2412 int dim; 2413 int indx; 2414 int neg; 2415 int null_flag; 2416 int is_array_section, is_char; 2417 int c; 2418 2419 is_char = 0; 2420 is_array_section = 0; 2421 dtp->u.p.expanded_read = 0; 2422 2423 /* See if this is a character substring qualifier we are looking for. */ 2424 if (rank == -1) 2425 { 2426 rank = 1; 2427 is_char = 1; 2428 } 2429 2430 /* The next character in the stream should be the '('. */ 2431 2432 if ((c = next_char (dtp)) == EOF) 2433 goto err_ret; 2434 2435 /* Process the qualifier, by dimension and triplet. */ 2436 2437 for (dim=0; dim < rank; dim++ ) 2438 { 2439 for (indx=0; indx<3; indx++) 2440 { 2441 free_saved (dtp); 2442 eat_spaces (dtp); 2443 neg = 0; 2444 2445 /* Process a potential sign. */ 2446 if ((c = next_char (dtp)) == EOF) 2447 goto err_ret; 2448 switch (c) 2449 { 2450 case '-': 2451 neg = 1; 2452 break; 2453 2454 case '+': 2455 break; 2456 2457 default: 2458 unget_char (dtp, c); 2459 break; 2460 } 2461 2462 /* Process characters up to the next ':' , ',' or ')'. */ 2463 for (;;) 2464 { 2465 c = next_char (dtp); 2466 switch (c) 2467 { 2468 case EOF: 2469 goto err_ret; 2470 2471 case ':': 2472 is_array_section = 1; 2473 break; 2474 2475 case ',': case ')': 2476 if ((c==',' && dim == rank -1) 2477 || (c==')' && dim < rank -1)) 2478 { 2479 if (is_char) 2480 snprintf (parse_err_msg, parse_err_msg_size, 2481 "Bad substring qualifier"); 2482 else 2483 snprintf (parse_err_msg, parse_err_msg_size, 2484 "Bad number of index fields"); 2485 goto err_ret; 2486 } 2487 break; 2488 2489 CASE_DIGITS: 2490 push_char (dtp, c); 2491 continue; 2492 2493 case ' ': case '\t': case '\r': case '\n': 2494 eat_spaces (dtp); 2495 break; 2496 2497 default: 2498 if (is_char) 2499 snprintf (parse_err_msg, parse_err_msg_size, 2500 "Bad character in substring qualifier"); 2501 else 2502 snprintf (parse_err_msg, parse_err_msg_size, 2503 "Bad character in index"); 2504 goto err_ret; 2505 } 2506 2507 if ((c == ',' || c == ')') && indx == 0 2508 && dtp->u.p.saved_string == 0) 2509 { 2510 if (is_char) 2511 snprintf (parse_err_msg, parse_err_msg_size, 2512 "Null substring qualifier"); 2513 else 2514 snprintf (parse_err_msg, parse_err_msg_size, 2515 "Null index field"); 2516 goto err_ret; 2517 } 2518 2519 if ((c == ':' && indx == 1 && dtp->u.p.saved_string == 0) 2520 || (indx == 2 && dtp->u.p.saved_string == 0)) 2521 { 2522 if (is_char) 2523 snprintf (parse_err_msg, parse_err_msg_size, 2524 "Bad substring qualifier"); 2525 else 2526 snprintf (parse_err_msg, parse_err_msg_size, 2527 "Bad index triplet"); 2528 goto err_ret; 2529 } 2530 2531 if (is_char && !is_array_section) 2532 { 2533 snprintf (parse_err_msg, parse_err_msg_size, 2534 "Missing colon in substring qualifier"); 2535 goto err_ret; 2536 } 2537 2538 /* If '( : ? )' or '( ? : )' break and flag read failure. */ 2539 null_flag = 0; 2540 if ((c == ':' && indx == 0 && dtp->u.p.saved_string == 0) 2541 || (indx==1 && dtp->u.p.saved_string == 0)) 2542 { 2543 null_flag = 1; 2544 break; 2545 } 2546 2547 /* Now read the index. */ 2548 if (convert_integer (dtp, sizeof(index_type), neg)) 2549 { 2550 if (is_char) 2551 snprintf (parse_err_msg, parse_err_msg_size, 2552 "Bad integer substring qualifier"); 2553 else 2554 snprintf (parse_err_msg, parse_err_msg_size, 2555 "Bad integer in index"); 2556 goto err_ret; 2557 } 2558 break; 2559 } 2560 2561 /* Feed the index values to the triplet arrays. */ 2562 if (!null_flag) 2563 { 2564 if (indx == 0) 2565 memcpy (&ls[dim].start, dtp->u.p.value, sizeof(index_type)); 2566 if (indx == 1) 2567 memcpy (&ls[dim].end, dtp->u.p.value, sizeof(index_type)); 2568 if (indx == 2) 2569 memcpy (&ls[dim].step, dtp->u.p.value, sizeof(index_type)); 2570 } 2571 2572 /* Singlet or doublet indices. */ 2573 if (c==',' || c==')') 2574 { 2575 if (indx == 0) 2576 { 2577 memcpy (&ls[dim].start, dtp->u.p.value, sizeof(index_type)); 2578 2579 /* If -std=f95/2003 or an array section is specified, 2580 do not allow excess data to be processed. */ 2581 if (is_array_section == 1 2582 || !(compile_options.allow_std & GFC_STD_GNU) 2583 || nml_elem_type == BT_DERIVED) 2584 ls[dim].end = ls[dim].start; 2585 else 2586 dtp->u.p.expanded_read = 1; 2587 } 2588 2589 /* Check for non-zero rank. */ 2590 if (is_array_section == 1 && ls[dim].start != ls[dim].end) 2591 *parsed_rank = 1; 2592 2593 break; 2594 } 2595 } 2596 2597 if (is_array_section == 1 && dtp->u.p.expanded_read == 1) 2598 { 2599 int i; 2600 dtp->u.p.expanded_read = 0; 2601 for (i = 0; i < dim; i++) 2602 ls[i].end = ls[i].start; 2603 } 2604 2605 /* Check the values of the triplet indices. */ 2606 if ((ls[dim].start > GFC_DIMENSION_UBOUND(ad[dim])) 2607 || (ls[dim].start < GFC_DIMENSION_LBOUND(ad[dim])) 2608 || (ls[dim].end > GFC_DIMENSION_UBOUND(ad[dim])) 2609 || (ls[dim].end < GFC_DIMENSION_LBOUND(ad[dim]))) 2610 { 2611 if (is_char) 2612 snprintf (parse_err_msg, parse_err_msg_size, 2613 "Substring out of range"); 2614 else 2615 snprintf (parse_err_msg, parse_err_msg_size, 2616 "Index %d out of range", dim + 1); 2617 goto err_ret; 2618 } 2619 2620 if (((ls[dim].end - ls[dim].start ) * ls[dim].step < 0) 2621 || (ls[dim].step == 0)) 2622 { 2623 snprintf (parse_err_msg, parse_err_msg_size, 2624 "Bad range in index %d", dim + 1); 2625 goto err_ret; 2626 } 2627 2628 /* Initialise the loop index counter. */ 2629 ls[dim].idx = ls[dim].start; 2630 } 2631 eat_spaces (dtp); 2632 return true; 2633 2634err_ret: 2635 2636 /* The EOF error message is issued by hit_eof. Return true so that the 2637 caller does not use parse_err_msg and parse_err_msg_size to generate 2638 an unrelated error message. */ 2639 if (c == EOF) 2640 { 2641 hit_eof (dtp); 2642 dtp->u.p.input_complete = 1; 2643 return true; 2644 } 2645 return false; 2646} 2647 2648 2649static bool 2650extended_look_ahead (char *p, char *q) 2651{ 2652 char *r, *s; 2653 2654 /* Scan ahead to find a '%' in the p string. */ 2655 for(r = p, s = q; *r && *s; s++) 2656 if ((*s == '%' || *s == '+') && strcmp (r + 1, s + 1) == 0) 2657 return true; 2658 return false; 2659} 2660 2661 2662static bool 2663strcmp_extended_type (char *p, char *q) 2664{ 2665 char *r, *s; 2666 2667 for (r = p, s = q; *r && *s; r++, s++) 2668 { 2669 if (*r != *s) 2670 { 2671 if (*r == '%' && *s == '+' && extended_look_ahead (r, s)) 2672 return true; 2673 break; 2674 } 2675 } 2676 return false; 2677} 2678 2679 2680static namelist_info * 2681find_nml_node (st_parameter_dt *dtp, char *var_name) 2682{ 2683 namelist_info *t = dtp->u.p.ionml; 2684 while (t != NULL) 2685 { 2686 if (strcmp (var_name, t->var_name) == 0) 2687 { 2688 t->touched = 1; 2689 return t; 2690 } 2691 if (strcmp_extended_type (var_name, t->var_name)) 2692 { 2693 t->touched = 1; 2694 return t; 2695 } 2696 t = t->next; 2697 } 2698 return NULL; 2699} 2700 2701/* Visits all the components of a derived type that have 2702 not explicitly been identified in the namelist input. 2703 touched is set and the loop specification initialised 2704 to default values */ 2705 2706static void 2707nml_touch_nodes (namelist_info *nl) 2708{ 2709 index_type len = strlen (nl->var_name) + 1; 2710 int dim; 2711 char *ext_name = xmalloc (len + 1); 2712 memcpy (ext_name, nl->var_name, len-1); 2713 memcpy (ext_name + len - 1, "%", 2); 2714 for (nl = nl->next; nl; nl = nl->next) 2715 { 2716 if (strncmp (nl->var_name, ext_name, len) == 0) 2717 { 2718 nl->touched = 1; 2719 for (dim=0; dim < nl->var_rank; dim++) 2720 { 2721 nl->ls[dim].step = 1; 2722 nl->ls[dim].end = GFC_DESCRIPTOR_UBOUND(nl,dim); 2723 nl->ls[dim].start = GFC_DESCRIPTOR_LBOUND(nl,dim); 2724 nl->ls[dim].idx = nl->ls[dim].start; 2725 } 2726 } 2727 else 2728 break; 2729 } 2730 free (ext_name); 2731 return; 2732} 2733 2734/* Resets touched for the entire list of nml_nodes, ready for a 2735 new object. */ 2736 2737static void 2738nml_untouch_nodes (st_parameter_dt *dtp) 2739{ 2740 namelist_info *t; 2741 for (t = dtp->u.p.ionml; t; t = t->next) 2742 t->touched = 0; 2743 return; 2744} 2745 2746/* Attempts to input name to namelist name. Returns 2747 dtp->u.p.nml_read_error = 1 on no match. */ 2748 2749static void 2750nml_match_name (st_parameter_dt *dtp, const char *name, index_type len) 2751{ 2752 index_type i; 2753 int c; 2754 2755 dtp->u.p.nml_read_error = 0; 2756 for (i = 0; i < len; i++) 2757 { 2758 c = next_char (dtp); 2759 if (c == EOF || (safe_tolower (c) != safe_tolower (name[i]))) 2760 { 2761 dtp->u.p.nml_read_error = 1; 2762 break; 2763 } 2764 } 2765} 2766 2767/* If the namelist read is from stdin, output the current state of the 2768 namelist to stdout. This is used to implement the non-standard query 2769 features, ? and =?. If c == '=' the full namelist is printed. Otherwise 2770 the names alone are printed. */ 2771 2772static void 2773nml_query (st_parameter_dt *dtp, char c) 2774{ 2775 gfc_unit *temp_unit; 2776 namelist_info *nl; 2777 index_type len; 2778 char *p; 2779#ifdef HAVE_CRLF 2780 static const index_type endlen = 2; 2781 static const char endl[] = "\r\n"; 2782 static const char nmlend[] = "&end\r\n"; 2783#else 2784 static const index_type endlen = 1; 2785 static const char endl[] = "\n"; 2786 static const char nmlend[] = "&end\n"; 2787#endif 2788 2789 if (dtp->u.p.current_unit->unit_number != options.stdin_unit) 2790 return; 2791 2792 /* Store the current unit and transfer to stdout. */ 2793 2794 temp_unit = dtp->u.p.current_unit; 2795 dtp->u.p.current_unit = find_unit (options.stdout_unit); 2796 2797 if (dtp->u.p.current_unit) 2798 { 2799 dtp->u.p.mode = WRITING; 2800 next_record (dtp, 0); 2801 2802 /* Write the namelist in its entirety. */ 2803 2804 if (c == '=') 2805 namelist_write (dtp); 2806 2807 /* Or write the list of names. */ 2808 2809 else 2810 { 2811 /* "&namelist_name\n" */ 2812 2813 len = dtp->namelist_name_len; 2814 p = write_block (dtp, len - 1 + endlen); 2815 if (!p) 2816 goto query_return; 2817 memcpy (p, "&", 1); 2818 memcpy ((char*)(p + 1), dtp->namelist_name, len); 2819 memcpy ((char*)(p + len + 1), &endl, endlen); 2820 for (nl = dtp->u.p.ionml; nl; nl = nl->next) 2821 { 2822 /* " var_name\n" */ 2823 2824 len = strlen (nl->var_name); 2825 p = write_block (dtp, len + endlen); 2826 if (!p) 2827 goto query_return; 2828 memcpy (p, " ", 1); 2829 memcpy ((char*)(p + 1), nl->var_name, len); 2830 memcpy ((char*)(p + len + 1), &endl, endlen); 2831 } 2832 2833 /* "&end\n" */ 2834 2835 p = write_block (dtp, endlen + 4); 2836 if (!p) 2837 goto query_return; 2838 memcpy (p, &nmlend, endlen + 4); 2839 } 2840 2841 /* Flush the stream to force immediate output. */ 2842 2843 fbuf_flush (dtp->u.p.current_unit, WRITING); 2844 sflush (dtp->u.p.current_unit->s); 2845 unlock_unit (dtp->u.p.current_unit); 2846 } 2847 2848query_return: 2849 2850 /* Restore the current unit. */ 2851 2852 dtp->u.p.current_unit = temp_unit; 2853 dtp->u.p.mode = READING; 2854 return; 2855} 2856 2857/* Reads and stores the input for the namelist object nl. For an array, 2858 the function loops over the ranges defined by the loop specification. 2859 This default to all the data or to the specification from a qualifier. 2860 nml_read_obj recursively calls itself to read derived types. It visits 2861 all its own components but only reads data for those that were touched 2862 when the name was parsed. If a read error is encountered, an attempt is 2863 made to return to read a new object name because the standard allows too 2864 little data to be available. On the other hand, too much data is an 2865 error. */ 2866 2867static bool 2868nml_read_obj (st_parameter_dt *dtp, namelist_info *nl, index_type offset, 2869 namelist_info **pprev_nl, char *nml_err_msg, 2870 size_t nml_err_msg_size, index_type clow, index_type chigh) 2871{ 2872 namelist_info *cmp; 2873 char *obj_name; 2874 int nml_carry; 2875 int len; 2876 int dim; 2877 index_type dlen; 2878 index_type m; 2879 size_t obj_name_len; 2880 void *pdata; 2881 gfc_class list_obj; 2882 2883 /* If we have encountered a previous read error or this object has not been 2884 touched in name parsing, just return. */ 2885 if (dtp->u.p.nml_read_error || !nl->touched) 2886 return true; 2887 2888 dtp->u.p.item_count++; /* Used in error messages. */ 2889 dtp->u.p.repeat_count = 0; 2890 eat_spaces (dtp); 2891 2892 len = nl->len; 2893 switch (nl->type) 2894 { 2895 case BT_INTEGER: 2896 case BT_LOGICAL: 2897 dlen = len; 2898 break; 2899 2900 case BT_REAL: 2901 dlen = size_from_real_kind (len); 2902 break; 2903 2904 case BT_COMPLEX: 2905 dlen = size_from_complex_kind (len); 2906 break; 2907 2908 case BT_CHARACTER: 2909 dlen = chigh ? (chigh - clow + 1) : nl->string_length; 2910 break; 2911 2912 default: 2913 dlen = 0; 2914 } 2915 2916 do 2917 { 2918 /* Update the pointer to the data, using the current index vector */ 2919 2920 if ((nl->type == BT_DERIVED || nl->type == BT_CLASS) 2921 && nl->dtio_sub != NULL) 2922 { 2923 pdata = NULL; /* Not used under these conidtions. */ 2924 if (nl->type == BT_CLASS) 2925 list_obj.data = ((gfc_class*)nl->mem_pos)->data; 2926 else 2927 list_obj.data = (void *)nl->mem_pos; 2928 2929 for (dim = 0; dim < nl->var_rank; dim++) 2930 list_obj.data = list_obj.data + (nl->ls[dim].idx 2931 - GFC_DESCRIPTOR_LBOUND(nl,dim)) 2932 * GFC_DESCRIPTOR_STRIDE(nl,dim) * nl->size; 2933 } 2934 else 2935 { 2936 pdata = (void*)(nl->mem_pos + offset); 2937 for (dim = 0; dim < nl->var_rank; dim++) 2938 pdata = (void*)(pdata + (nl->ls[dim].idx 2939 - GFC_DESCRIPTOR_LBOUND(nl,dim)) 2940 * GFC_DESCRIPTOR_STRIDE(nl,dim) * nl->size); 2941 } 2942 2943 /* If we are finished with the repeat count, try to read next value. */ 2944 2945 nml_carry = 0; 2946 if (--dtp->u.p.repeat_count <= 0) 2947 { 2948 if (dtp->u.p.input_complete) 2949 return true; 2950 if (dtp->u.p.at_eol) 2951 finish_separator (dtp); 2952 if (dtp->u.p.input_complete) 2953 return true; 2954 2955 dtp->u.p.saved_type = BT_UNKNOWN; 2956 free_saved (dtp); 2957 2958 switch (nl->type) 2959 { 2960 case BT_INTEGER: 2961 read_integer (dtp, len); 2962 break; 2963 2964 case BT_LOGICAL: 2965 read_logical (dtp, len); 2966 break; 2967 2968 case BT_CHARACTER: 2969 read_character (dtp, len); 2970 break; 2971 2972 case BT_REAL: 2973 /* Need to copy data back from the real location to the temp in 2974 order to handle nml reads into arrays. */ 2975 read_real (dtp, pdata, len); 2976 memcpy (dtp->u.p.value, pdata, dlen); 2977 break; 2978 2979 case BT_COMPLEX: 2980 /* Same as for REAL, copy back to temp. */ 2981 read_complex (dtp, pdata, len, dlen); 2982 memcpy (dtp->u.p.value, pdata, dlen); 2983 break; 2984 2985 case BT_DERIVED: 2986 case BT_CLASS: 2987 /* If this object has a User Defined procedure, call it. */ 2988 if (nl->dtio_sub != NULL) 2989 { 2990 int unit = dtp->u.p.current_unit->unit_number; 2991 char iotype[] = "NAMELIST"; 2992 gfc_charlen_type iotype_len = 8; 2993 char tmp_iomsg[IOMSG_LEN] = ""; 2994 char *child_iomsg; 2995 gfc_charlen_type child_iomsg_len; 2996 int noiostat; 2997 int *child_iostat = NULL; 2998 gfc_full_array_i4 vlist; 2999 formatted_dtio dtio_ptr = (formatted_dtio)nl->dtio_sub; 3000 3001 GFC_DESCRIPTOR_DATA(&vlist) = NULL; 3002 GFC_DIMENSION_SET(vlist.dim[0],1, 0, 0); 3003 3004 list_obj.vptr = nl->vtable; 3005 list_obj.len = 0; 3006 3007 /* Set iostat, intent(out). */ 3008 noiostat = 0; 3009 child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ? 3010 dtp->common.iostat : &noiostat; 3011 3012 /* Set iomsg, intent(inout). */ 3013 if (dtp->common.flags & IOPARM_HAS_IOMSG) 3014 { 3015 child_iomsg = dtp->common.iomsg; 3016 child_iomsg_len = dtp->common.iomsg_len; 3017 } 3018 else 3019 { 3020 child_iomsg = tmp_iomsg; 3021 child_iomsg_len = IOMSG_LEN; 3022 } 3023 3024 /* Call the user defined formatted READ procedure. */ 3025 dtp->u.p.current_unit->child_dtio++; 3026 dtio_ptr ((void *)&list_obj, &unit, iotype, &vlist, 3027 child_iostat, child_iomsg, 3028 iotype_len, child_iomsg_len); 3029 dtp->u.p.child_saved_iostat = *child_iostat; 3030 dtp->u.p.current_unit->child_dtio--; 3031 goto incr_idx; 3032 } 3033 3034 /* Must be default derived type namelist read. */ 3035 obj_name_len = strlen (nl->var_name) + 1; 3036 obj_name = xmalloc (obj_name_len+1); 3037 memcpy (obj_name, nl->var_name, obj_name_len-1); 3038 memcpy (obj_name + obj_name_len - 1, "%", 2); 3039 3040 /* If reading a derived type, disable the expanded read warning 3041 since a single object can have multiple reads. */ 3042 dtp->u.p.expanded_read = 0; 3043 3044 /* Now loop over the components. */ 3045 3046 for (cmp = nl->next; 3047 cmp && 3048 !strncmp (cmp->var_name, obj_name, obj_name_len); 3049 cmp = cmp->next) 3050 { 3051 /* Jump over nested derived type by testing if the potential 3052 component name contains '%'. */ 3053 if (strchr (cmp->var_name + obj_name_len, '%')) 3054 continue; 3055 3056 if (!nml_read_obj (dtp, cmp, (index_type)(pdata - nl->mem_pos), 3057 pprev_nl, nml_err_msg, nml_err_msg_size, 3058 clow, chigh)) 3059 { 3060 free (obj_name); 3061 return false; 3062 } 3063 3064 if (dtp->u.p.input_complete) 3065 { 3066 free (obj_name); 3067 return true; 3068 } 3069 } 3070 3071 free (obj_name); 3072 goto incr_idx; 3073 3074 default: 3075 snprintf (nml_err_msg, nml_err_msg_size, 3076 "Bad type for namelist object %s", nl->var_name); 3077 internal_error (&dtp->common, nml_err_msg); 3078 goto nml_err_ret; 3079 } 3080 } 3081 3082 /* The standard permits array data to stop short of the number of 3083 elements specified in the loop specification. In this case, we 3084 should be here with dtp->u.p.nml_read_error != 0. Control returns to 3085 nml_get_obj_data and an attempt is made to read object name. */ 3086 3087 *pprev_nl = nl; 3088 if (dtp->u.p.nml_read_error) 3089 { 3090 dtp->u.p.expanded_read = 0; 3091 return true; 3092 } 3093 3094 if (dtp->u.p.saved_type == BT_UNKNOWN) 3095 { 3096 dtp->u.p.expanded_read = 0; 3097 goto incr_idx; 3098 } 3099 3100 switch (dtp->u.p.saved_type) 3101 { 3102 3103 case BT_COMPLEX: 3104 case BT_REAL: 3105 case BT_INTEGER: 3106 case BT_LOGICAL: 3107 memcpy (pdata, dtp->u.p.value, dlen); 3108 break; 3109 3110 case BT_CHARACTER: 3111 if (dlen < dtp->u.p.saved_used) 3112 { 3113 if (compile_options.bounds_check) 3114 { 3115 snprintf (nml_err_msg, nml_err_msg_size, 3116 "Namelist object '%s' truncated on read.", 3117 nl->var_name); 3118 generate_warning (&dtp->common, nml_err_msg); 3119 } 3120 m = dlen; 3121 } 3122 else 3123 m = dtp->u.p.saved_used; 3124 3125 if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8) 3126 { 3127 gfc_char4_t *q4, *p4 = pdata; 3128 int i; 3129 3130 q4 = (gfc_char4_t *) dtp->u.p.saved_string; 3131 p4 += clow -1; 3132 for (i = 0; i < m; i++) 3133 *p4++ = *q4++; 3134 if (m < dlen) 3135 for (i = 0; i < dlen - m; i++) 3136 *p4++ = (gfc_char4_t) ' '; 3137 } 3138 else 3139 { 3140 pdata = (void*)( pdata + clow - 1 ); 3141 memcpy (pdata, dtp->u.p.saved_string, m); 3142 if (m < dlen) 3143 memset ((void*)( pdata + m ), ' ', dlen - m); 3144 } 3145 break; 3146 3147 default: 3148 break; 3149 } 3150 3151 /* Warn if a non-standard expanded read occurs. A single read of a 3152 single object is acceptable. If a second read occurs, issue a warning 3153 and set the flag to zero to prevent further warnings. */ 3154 if (dtp->u.p.expanded_read == 2) 3155 { 3156 notify_std (&dtp->common, GFC_STD_GNU, "Non-standard expanded namelist read."); 3157 dtp->u.p.expanded_read = 0; 3158 } 3159 3160 /* If the expanded read warning flag is set, increment it, 3161 indicating that a single read has occurred. */ 3162 if (dtp->u.p.expanded_read >= 1) 3163 dtp->u.p.expanded_read++; 3164 3165 /* Break out of loop if scalar. */ 3166 if (!nl->var_rank) 3167 break; 3168 3169 /* Now increment the index vector. */ 3170 3171incr_idx: 3172 3173 nml_carry = 1; 3174 for (dim = 0; dim < nl->var_rank; dim++) 3175 { 3176 nl->ls[dim].idx += nml_carry * nl->ls[dim].step; 3177 nml_carry = 0; 3178 if (((nl->ls[dim].step > 0) && (nl->ls[dim].idx > nl->ls[dim].end)) 3179 || 3180 ((nl->ls[dim].step < 0) && (nl->ls[dim].idx < nl->ls[dim].end))) 3181 { 3182 nl->ls[dim].idx = nl->ls[dim].start; 3183 nml_carry = 1; 3184 } 3185 } 3186 } while (!nml_carry); 3187 3188 if (dtp->u.p.repeat_count > 1) 3189 { 3190 snprintf (nml_err_msg, nml_err_msg_size, 3191 "Repeat count too large for namelist object %s", nl->var_name); 3192 goto nml_err_ret; 3193 } 3194 return true; 3195 3196nml_err_ret: 3197 3198 return false; 3199} 3200 3201/* Parses the object name, including array and substring qualifiers. It 3202 iterates over derived type components, touching those components and 3203 setting their loop specifications, if there is a qualifier. If the 3204 object is itself a derived type, its components and subcomponents are 3205 touched. nml_read_obj is called at the end and this reads the data in 3206 the manner specified by the object name. */ 3207 3208static bool 3209nml_get_obj_data (st_parameter_dt *dtp, namelist_info **pprev_nl, 3210 char *nml_err_msg, size_t nml_err_msg_size) 3211{ 3212 int c; 3213 namelist_info *nl; 3214 namelist_info *first_nl = NULL; 3215 namelist_info *root_nl = NULL; 3216 int dim, parsed_rank; 3217 int component_flag, qualifier_flag; 3218 index_type clow, chigh; 3219 int non_zero_rank_count; 3220 3221 /* Look for end of input or object name. If '?' or '=?' are encountered 3222 in stdin, print the node names or the namelist to stdout. */ 3223 3224 eat_separator (dtp); 3225 if (dtp->u.p.input_complete) 3226 return true; 3227 3228 if (dtp->u.p.at_eol) 3229 finish_separator (dtp); 3230 if (dtp->u.p.input_complete) 3231 return true; 3232 3233 if ((c = next_char (dtp)) == EOF) 3234 goto nml_err_ret; 3235 switch (c) 3236 { 3237 case '=': 3238 if ((c = next_char (dtp)) == EOF) 3239 goto nml_err_ret; 3240 if (c != '?') 3241 { 3242 snprintf (nml_err_msg, nml_err_msg_size, 3243 "namelist read: misplaced = sign"); 3244 goto nml_err_ret; 3245 } 3246 nml_query (dtp, '='); 3247 return true; 3248 3249 case '?': 3250 nml_query (dtp, '?'); 3251 return true; 3252 3253 case '$': 3254 case '&': 3255 nml_match_name (dtp, "end", 3); 3256 if (dtp->u.p.nml_read_error) 3257 { 3258 snprintf (nml_err_msg, nml_err_msg_size, 3259 "namelist not terminated with / or &end"); 3260 goto nml_err_ret; 3261 } 3262 /* Fall through. */ 3263 case '/': 3264 dtp->u.p.input_complete = 1; 3265 return true; 3266 3267 default : 3268 break; 3269 } 3270 3271 /* Untouch all nodes of the namelist and reset the flags that are set for 3272 derived type components. */ 3273 3274 nml_untouch_nodes (dtp); 3275 component_flag = 0; 3276 qualifier_flag = 0; 3277 non_zero_rank_count = 0; 3278 3279 /* Get the object name - should '!' and '\n' be permitted separators? */ 3280 3281get_name: 3282 3283 free_saved (dtp); 3284 3285 do 3286 { 3287 if (!is_separator (c)) 3288 push_char_default (dtp, safe_tolower(c)); 3289 if ((c = next_char (dtp)) == EOF) 3290 goto nml_err_ret; 3291 } 3292 while (!( c=='=' || c==' ' || c=='\t' || c =='(' || c =='%' )); 3293 3294 unget_char (dtp, c); 3295 3296 /* Check that the name is in the namelist and get pointer to object. 3297 Three error conditions exist: (i) An attempt is being made to 3298 identify a non-existent object, following a failed data read or 3299 (ii) The object name does not exist or (iii) Too many data items 3300 are present for an object. (iii) gives the same error message 3301 as (i) */ 3302 3303 push_char_default (dtp, '\0'); 3304 3305 if (component_flag) 3306 { 3307#define EXT_STACK_SZ 100 3308 char ext_stack[EXT_STACK_SZ]; 3309 char *ext_name; 3310 size_t var_len = strlen (root_nl->var_name); 3311 size_t saved_len 3312 = dtp->u.p.saved_string ? strlen (dtp->u.p.saved_string) : 0; 3313 size_t ext_size = var_len + saved_len + 1; 3314 3315 if (ext_size > EXT_STACK_SZ) 3316 ext_name = xmalloc (ext_size); 3317 else 3318 ext_name = ext_stack; 3319 3320 memcpy (ext_name, root_nl->var_name, var_len); 3321 if (dtp->u.p.saved_string) 3322 memcpy (ext_name + var_len, dtp->u.p.saved_string, saved_len); 3323 ext_name[var_len + saved_len] = '\0'; 3324 nl = find_nml_node (dtp, ext_name); 3325 3326 if (ext_size > EXT_STACK_SZ) 3327 free (ext_name); 3328 } 3329 else 3330 nl = find_nml_node (dtp, dtp->u.p.saved_string); 3331 3332 if (nl == NULL) 3333 { 3334 if (dtp->u.p.nml_read_error && *pprev_nl) 3335 snprintf (nml_err_msg, nml_err_msg_size, 3336 "Bad data for namelist object %s", (*pprev_nl)->var_name); 3337 3338 else 3339 snprintf (nml_err_msg, nml_err_msg_size, 3340 "Cannot match namelist object name %s", 3341 dtp->u.p.saved_string); 3342 3343 goto nml_err_ret; 3344 } 3345 3346 /* Get the length, data length, base pointer and rank of the variable. 3347 Set the default loop specification first. */ 3348 3349 for (dim=0; dim < nl->var_rank; dim++) 3350 { 3351 nl->ls[dim].step = 1; 3352 nl->ls[dim].end = GFC_DESCRIPTOR_UBOUND(nl,dim); 3353 nl->ls[dim].start = GFC_DESCRIPTOR_LBOUND(nl,dim); 3354 nl->ls[dim].idx = nl->ls[dim].start; 3355 } 3356 3357/* Check to see if there is a qualifier: if so, parse it.*/ 3358 3359 if (c == '(' && nl->var_rank) 3360 { 3361 parsed_rank = 0; 3362 if (!nml_parse_qualifier (dtp, nl->dim, nl->ls, nl->var_rank, 3363 nl->type, nml_err_msg, nml_err_msg_size, 3364 &parsed_rank)) 3365 { 3366 char *nml_err_msg_end = strchr (nml_err_msg, '\0'); 3367 snprintf (nml_err_msg_end, 3368 nml_err_msg_size - (nml_err_msg_end - nml_err_msg), 3369 " for namelist variable %s", nl->var_name); 3370 goto nml_err_ret; 3371 } 3372 if (parsed_rank > 0) 3373 non_zero_rank_count++; 3374 3375 qualifier_flag = 1; 3376 3377 if ((c = next_char (dtp)) == EOF) 3378 goto nml_err_ret; 3379 unget_char (dtp, c); 3380 } 3381 else if (nl->var_rank > 0) 3382 non_zero_rank_count++; 3383 3384 /* Now parse a derived type component. The root namelist_info address 3385 is backed up, as is the previous component level. The component flag 3386 is set and the iteration is made by jumping back to get_name. */ 3387 3388 if (c == '%') 3389 { 3390 if (nl->type != BT_DERIVED) 3391 { 3392 snprintf (nml_err_msg, nml_err_msg_size, 3393 "Attempt to get derived component for %s", nl->var_name); 3394 goto nml_err_ret; 3395 } 3396 3397 /* Don't move first_nl further in the list if a qualifier was found. */ 3398 if ((*pprev_nl == NULL && !qualifier_flag) || !component_flag) 3399 first_nl = nl; 3400 3401 root_nl = nl; 3402 3403 component_flag = 1; 3404 if ((c = next_char (dtp)) == EOF) 3405 goto nml_err_ret; 3406 goto get_name; 3407 } 3408 3409 /* Parse a character qualifier, if present. chigh = 0 is a default 3410 that signals that the string length = string_length. */ 3411 3412 clow = 1; 3413 chigh = 0; 3414 3415 if (c == '(' && nl->type == BT_CHARACTER) 3416 { 3417 descriptor_dimension chd[1] = { {1, clow, nl->string_length} }; 3418 array_loop_spec ind[1] = { {1, clow, nl->string_length, 1} }; 3419 3420 if (!nml_parse_qualifier (dtp, chd, ind, -1, nl->type, 3421 nml_err_msg, nml_err_msg_size, &parsed_rank)) 3422 { 3423 char *nml_err_msg_end = strchr (nml_err_msg, '\0'); 3424 snprintf (nml_err_msg_end, 3425 nml_err_msg_size - (nml_err_msg_end - nml_err_msg), 3426 " for namelist variable %s", nl->var_name); 3427 goto nml_err_ret; 3428 } 3429 3430 clow = ind[0].start; 3431 chigh = ind[0].end; 3432 3433 if (ind[0].step != 1) 3434 { 3435 snprintf (nml_err_msg, nml_err_msg_size, 3436 "Step not allowed in substring qualifier" 3437 " for namelist object %s", nl->var_name); 3438 goto nml_err_ret; 3439 } 3440 3441 if ((c = next_char (dtp)) == EOF) 3442 goto nml_err_ret; 3443 unget_char (dtp, c); 3444 } 3445 3446 /* Make sure no extraneous qualifiers are there. */ 3447 3448 if (c == '(') 3449 { 3450 snprintf (nml_err_msg, nml_err_msg_size, 3451 "Qualifier for a scalar or non-character namelist object %s", 3452 nl->var_name); 3453 goto nml_err_ret; 3454 } 3455 3456 /* Make sure there is no more than one non-zero rank object. */ 3457 if (non_zero_rank_count > 1) 3458 { 3459 snprintf (nml_err_msg, nml_err_msg_size, 3460 "Multiple sub-objects with non-zero rank in namelist object %s", 3461 nl->var_name); 3462 non_zero_rank_count = 0; 3463 goto nml_err_ret; 3464 } 3465 3466/* According to the standard, an equal sign MUST follow an object name. The 3467 following is possibly lax - it allows comments, blank lines and so on to 3468 intervene. eat_spaces (dtp); c = next_char (dtp); would be compliant*/ 3469 3470 free_saved (dtp); 3471 3472 eat_separator (dtp); 3473 if (dtp->u.p.input_complete) 3474 return true; 3475 3476 if (dtp->u.p.at_eol) 3477 finish_separator (dtp); 3478 if (dtp->u.p.input_complete) 3479 return true; 3480 3481 if ((c = next_char (dtp)) == EOF) 3482 goto nml_err_ret; 3483 3484 if (c != '=') 3485 { 3486 snprintf (nml_err_msg, nml_err_msg_size, 3487 "Equal sign must follow namelist object name %s", 3488 nl->var_name); 3489 goto nml_err_ret; 3490 } 3491 3492 /* If a derived type, touch its components and restore the root 3493 namelist_info if we have parsed a qualified derived type 3494 component. */ 3495 3496 if (nl->type == BT_DERIVED && nl->dtio_sub == NULL) 3497 nml_touch_nodes (nl); 3498 3499 if (first_nl) 3500 { 3501 if (first_nl->var_rank == 0) 3502 { 3503 if (component_flag && qualifier_flag) 3504 nl = first_nl; 3505 } 3506 else 3507 nl = first_nl; 3508 } 3509 3510 dtp->u.p.nml_read_error = 0; 3511 if (!nml_read_obj (dtp, nl, 0, pprev_nl, nml_err_msg, nml_err_msg_size, 3512 clow, chigh)) 3513 goto nml_err_ret; 3514 3515 return true; 3516 3517nml_err_ret: 3518 3519 /* The EOF error message is issued by hit_eof. Return true so that the 3520 caller does not use nml_err_msg and nml_err_msg_size to generate 3521 an unrelated error message. */ 3522 if (c == EOF) 3523 { 3524 dtp->u.p.input_complete = 1; 3525 unget_char (dtp, c); 3526 hit_eof (dtp); 3527 return true; 3528 } 3529 return false; 3530} 3531 3532/* Entry point for namelist input. Goes through input until namelist name 3533 is matched. Then cycles through nml_get_obj_data until the input is 3534 completed or there is an error. */ 3535 3536void 3537namelist_read (st_parameter_dt *dtp) 3538{ 3539 int c; 3540 char nml_err_msg[200]; 3541 3542 /* Initialize the error string buffer just in case we get an unexpected fail 3543 somewhere and end up at nml_err_ret. */ 3544 strcpy (nml_err_msg, "Internal namelist read error"); 3545 3546 /* Pointer to the previously read object, in case attempt is made to read 3547 new object name. Should this fail, error message can give previous 3548 name. */ 3549 namelist_info *prev_nl = NULL; 3550 3551 dtp->u.p.input_complete = 0; 3552 dtp->u.p.expanded_read = 0; 3553 3554 /* Set the next_char and push_char worker functions. */ 3555 set_workers (dtp); 3556 3557 /* Look for &namelist_name . Skip all characters, testing for $nmlname. 3558 Exit on success or EOF. If '?' or '=?' encountered in stdin, print 3559 node names or namelist on stdout. */ 3560 3561find_nml_name: 3562 c = next_char (dtp); 3563 switch (c) 3564 { 3565 case '$': 3566 case '&': 3567 break; 3568 3569 case '!': 3570 eat_line (dtp); 3571 goto find_nml_name; 3572 3573 case '=': 3574 c = next_char (dtp); 3575 if (c == '?') 3576 nml_query (dtp, '='); 3577 else 3578 unget_char (dtp, c); 3579 goto find_nml_name; 3580 3581 case '?': 3582 nml_query (dtp, '?'); 3583 goto find_nml_name; 3584 3585 case EOF: 3586 return; 3587 3588 default: 3589 goto find_nml_name; 3590 } 3591 3592 /* Match the name of the namelist. */ 3593 3594 nml_match_name (dtp, dtp->namelist_name, dtp->namelist_name_len); 3595 3596 if (dtp->u.p.nml_read_error) 3597 goto find_nml_name; 3598 3599 /* A trailing space is required, we give a little latitude here, 10.9.1. */ 3600 c = next_char (dtp); 3601 if (!is_separator(c) && c != '!') 3602 { 3603 unget_char (dtp, c); 3604 goto find_nml_name; 3605 } 3606 3607 unget_char (dtp, c); 3608 eat_separator (dtp); 3609 3610 /* Ready to read namelist objects. If there is an error in input 3611 from stdin, output the error message and continue. */ 3612 3613 while (!dtp->u.p.input_complete) 3614 { 3615 if (!nml_get_obj_data (dtp, &prev_nl, nml_err_msg, sizeof nml_err_msg)) 3616 goto nml_err_ret; 3617 3618 /* Reset the previous namelist pointer if we know we are not going 3619 to be doing multiple reads within a single namelist object. */ 3620 if (prev_nl && prev_nl->var_rank == 0) 3621 prev_nl = NULL; 3622 } 3623 3624 free_saved (dtp); 3625 free_line (dtp); 3626 return; 3627 3628 3629nml_err_ret: 3630 3631 /* All namelist error calls return from here */ 3632 free_saved (dtp); 3633 free_line (dtp); 3634 generate_error (&dtp->common, LIBERROR_READ_VALUE, nml_err_msg); 3635 return; 3636} 3637