OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-stable/] [gcc-4.5.1/] [gcc/] [fortran/] [io.c] - Blame information for rev 816

Go to most recent revision | Details | Compare with Previous | View Log

Line No. Rev Author Line
1 285 jeremybenn
/* Deal with I/O statements & related stuff.
2
   Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
3
   Free Software Foundation, Inc.
4
   Contributed by Andy Vaught
5
 
6
This file is part of GCC.
7
 
8
GCC is free software; you can redistribute it and/or modify it under
9
the terms of the GNU General Public License as published by the Free
10
Software Foundation; either version 3, or (at your option) any later
11
version.
12
 
13
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14
WARRANTY; without even the implied warranty of MERCHANTABILITY or
15
FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
16
for more details.
17
 
18
You should have received a copy of the GNU General Public License
19
along with GCC; see the file COPYING3.  If not see
20
<http://www.gnu.org/licenses/>.  */
21
 
22
#include "config.h"
23
#include "system.h"
24
#include "flags.h"
25
#include "gfortran.h"
26
#include "match.h"
27
#include "parse.h"
28
 
29
gfc_st_label
30
format_asterisk = {0, NULL, NULL, -1, ST_LABEL_FORMAT, ST_LABEL_FORMAT, NULL,
31
                   0, {NULL, NULL}};
32
 
33
typedef struct
34
{
35
  const char *name, *spec, *value;
36
  bt type;
37
}
38
io_tag;
39
 
40
static const io_tag
41
        tag_file        = {"FILE", " file =", " %e", BT_CHARACTER },
42
        tag_status      = {"STATUS", " status =", " %e", BT_CHARACTER},
43
        tag_e_access    = {"ACCESS", " access =", " %e", BT_CHARACTER},
44
        tag_e_form      = {"FORM", " form =", " %e", BT_CHARACTER},
45
        tag_e_recl      = {"RECL", " recl =", " %e", BT_INTEGER},
46
        tag_e_blank     = {"BLANK", " blank =", " %e", BT_CHARACTER},
47
        tag_e_position  = {"POSITION", " position =", " %e", BT_CHARACTER},
48
        tag_e_action    = {"ACTION", " action =", " %e", BT_CHARACTER},
49
        tag_e_delim     = {"DELIM", " delim =", " %e", BT_CHARACTER},
50
        tag_e_pad       = {"PAD", " pad =", " %e", BT_CHARACTER},
51
        tag_e_decimal   = {"DECIMAL", " decimal =", " %e", BT_CHARACTER},
52
        tag_e_encoding  = {"ENCODING", " encoding =", " %e", BT_CHARACTER},
53
        tag_e_async     = {"ASYNCHRONOUS", " asynchronous =", " %e", BT_CHARACTER},
54
        tag_e_round     = {"ROUND", " round =", " %e", BT_CHARACTER},
55
        tag_e_sign      = {"SIGN", " sign =", " %e", BT_CHARACTER},
56
        tag_unit        = {"UNIT", " unit =", " %e", BT_INTEGER},
57
        tag_advance     = {"ADVANCE", " advance =", " %e", BT_CHARACTER},
58
        tag_rec         = {"REC", " rec =", " %e", BT_INTEGER},
59
        tag_spos        = {"POSITION", " pos =", " %e", BT_INTEGER},
60
        tag_format      = {"FORMAT", NULL, NULL, BT_CHARACTER},
61
        tag_iomsg       = {"IOMSG", " iomsg =", " %e", BT_CHARACTER},
62
        tag_iostat      = {"IOSTAT", " iostat =", " %v", BT_INTEGER},
63
        tag_size        = {"SIZE", " size =", " %v", BT_INTEGER},
64
        tag_exist       = {"EXIST", " exist =", " %v", BT_LOGICAL},
65
        tag_opened      = {"OPENED", " opened =", " %v", BT_LOGICAL},
66
        tag_named       = {"NAMED", " named =", " %v", BT_LOGICAL},
67
        tag_name        = {"NAME", " name =", " %v", BT_CHARACTER},
68
        tag_number      = {"NUMBER", " number =", " %v", BT_INTEGER},
69
        tag_s_access    = {"ACCESS", " access =", " %v", BT_CHARACTER},
70
        tag_sequential  = {"SEQUENTIAL", " sequential =", " %v", BT_CHARACTER},
71
        tag_direct      = {"DIRECT", " direct =", " %v", BT_CHARACTER},
72
        tag_s_form      = {"FORM", " form =", " %v", BT_CHARACTER},
73
        tag_formatted   = {"FORMATTED", " formatted =", " %v", BT_CHARACTER},
74
        tag_unformatted = {"UNFORMATTED", " unformatted =", " %v", BT_CHARACTER},
75
        tag_s_recl      = {"RECL", " recl =", " %v", BT_INTEGER},
76
        tag_nextrec     = {"NEXTREC", " nextrec =", " %v", BT_INTEGER},
77
        tag_s_blank     = {"BLANK", " blank =", " %v", BT_CHARACTER},
78
        tag_s_position  = {"POSITION", " position =", " %v", BT_CHARACTER},
79
        tag_s_action    = {"ACTION", " action =", " %v", BT_CHARACTER},
80
        tag_read        = {"READ", " read =", " %v", BT_CHARACTER},
81
        tag_write       = {"WRITE", " write =", " %v", BT_CHARACTER},
82
        tag_readwrite   = {"READWRITE", " readwrite =", " %v", BT_CHARACTER},
83
        tag_s_delim     = {"DELIM", " delim =", " %v", BT_CHARACTER},
84
        tag_s_pad       = {"PAD", " pad =", " %v", BT_CHARACTER},
85
        tag_s_decimal   = {"DECIMAL", " decimal =", " %v", BT_CHARACTER},
86
        tag_s_encoding  = {"ENCODING", " encoding =", " %v", BT_CHARACTER},
87
        tag_s_async     = {"ASYNCHRONOUS", " asynchronous =", " %v", BT_CHARACTER},
88
        tag_s_round     = {"ROUND", " round =", " %v", BT_CHARACTER},
89
        tag_s_sign      = {"SIGN", " sign =", " %v", BT_CHARACTER},
90
        tag_iolength    = {"IOLENGTH", " iolength =", " %v", BT_INTEGER},
91
        tag_convert     = {"CONVERT", " convert =", " %e", BT_CHARACTER},
92
        tag_strm_out    = {"POS", " pos =", " %v", BT_INTEGER},
93
        tag_err         = {"ERR", " err =", " %l", BT_UNKNOWN},
94
        tag_end         = {"END", " end =", " %l", BT_UNKNOWN},
95
        tag_eor         = {"EOR", " eor =", " %l", BT_UNKNOWN},
96
        tag_id          = {"ID", " id =", " %v", BT_INTEGER},
97
        tag_pending     = {"PENDING", " pending =", " %v", BT_LOGICAL},
98
        tag_newunit     = {"NEWUNIT", " newunit =", " %v", BT_INTEGER};
99
 
100
static gfc_dt *current_dt;
101
 
102
#define RESOLVE_TAG(x, y) if (resolve_tag(x, y) == FAILURE) return FAILURE;
103
 
104
 
105
/**************** Fortran 95 FORMAT parser  *****************/
106
 
107
/* FORMAT tokens returned by format_lex().  */
108
typedef enum
109
{
110
  FMT_NONE, FMT_UNKNOWN, FMT_SIGNED_INT, FMT_ZERO, FMT_POSINT, FMT_PERIOD,
111
  FMT_COMMA, FMT_COLON, FMT_SLASH, FMT_DOLLAR, FMT_LPAREN,
112
  FMT_RPAREN, FMT_X, FMT_SIGN, FMT_BLANK, FMT_CHAR, FMT_P, FMT_IBOZ, FMT_F,
113
  FMT_E, FMT_EN, FMT_ES, FMT_G, FMT_L, FMT_A, FMT_D, FMT_H, FMT_END,
114
  FMT_ERROR, FMT_DC, FMT_DP, FMT_T, FMT_TR, FMT_TL, FMT_STAR, FMT_RC,
115
  FMT_RD, FMT_RN, FMT_RP, FMT_RU, FMT_RZ
116
}
117
format_token;
118
 
119
/* Local variables for checking format strings.  The saved_token is
120
   used to back up by a single format token during the parsing
121
   process.  */
122
static gfc_char_t *format_string;
123
static int format_string_pos;
124
static int format_length, use_last_char;
125
static char error_element;
126
static locus format_locus;
127
 
128
static format_token saved_token;
129
 
130
static enum
131
{ MODE_STRING, MODE_FORMAT, MODE_COPY }
132
mode;
133
 
134
 
135
/* Return the next character in the format string.  */
136
 
137
static char
138
next_char (int in_string)
139
{
140
  static gfc_char_t c;
141
 
142
  if (use_last_char)
143
    {
144
      use_last_char = 0;
145
      return c;
146
    }
147
 
148
  format_length++;
149
 
150
  if (mode == MODE_STRING)
151
    c = *format_string++;
152
  else
153
    {
154
      c = gfc_next_char_literal (in_string);
155
      if (c == '\n')
156
        c = '\0';
157
    }
158
 
159
  if (gfc_option.flag_backslash && c == '\\')
160
    {
161
      locus old_locus = gfc_current_locus;
162
 
163
      if (gfc_match_special_char (&c) == MATCH_NO)
164
        gfc_current_locus = old_locus;
165
 
166
      if (!(gfc_option.allow_std & GFC_STD_GNU) && !inhibit_warnings)
167
        gfc_warning ("Extension: backslash character at %C");
168
    }
169
 
170
  if (mode == MODE_COPY)
171
    *format_string++ = c;
172
 
173
  if (mode != MODE_STRING)
174
    format_locus = gfc_current_locus;
175
 
176
  format_string_pos++;
177
 
178
  c = gfc_wide_toupper (c);
179
  return c;
180
}
181
 
182
 
183
/* Back up one character position.  Only works once.  */
184
 
185
static void
186
unget_char (void)
187
{
188
  use_last_char = 1;
189
}
190
 
191
/* Eat up the spaces and return a character.  */
192
 
193
static char
194
next_char_not_space (bool *error)
195
{
196
  char c;
197
  do
198
    {
199
      error_element = c = next_char (0);
200
      if (c == '\t')
201
        {
202
          if (gfc_option.allow_std & GFC_STD_GNU)
203
            gfc_warning ("Extension: Tab character in format at %C");
204
          else
205
            {
206
              gfc_error ("Extension: Tab character in format at %C");
207
              *error = true;
208
              return c;
209
            }
210
        }
211
    }
212
  while (gfc_is_whitespace (c));
213
  return c;
214
}
215
 
216
static int value = 0;
217
 
218
/* Simple lexical analyzer for getting the next token in a FORMAT
219
   statement.  */
220
 
221
static format_token
222
format_lex (void)
223
{
224
  format_token token;
225
  char c, delim;
226
  int zflag;
227
  int negative_flag;
228
  bool error = false;
229
 
230
  if (saved_token != FMT_NONE)
231
    {
232
      token = saved_token;
233
      saved_token = FMT_NONE;
234
      return token;
235
    }
236
 
237
  c = next_char_not_space (&error);
238
 
239
  negative_flag = 0;
240
  switch (c)
241
    {
242
    case '-':
243
      negative_flag = 1;
244
    case '+':
245
      c = next_char_not_space (&error);
246
      if (!ISDIGIT (c))
247
        {
248
          token = FMT_UNKNOWN;
249
          break;
250
        }
251
 
252
      value = c - '0';
253
 
254
      do
255
        {
256
          c = next_char_not_space (&error);
257
          if (ISDIGIT (c))
258
            value = 10 * value + c - '0';
259
        }
260
      while (ISDIGIT (c));
261
 
262
      unget_char ();
263
 
264
      if (negative_flag)
265
        value = -value;
266
 
267
      token = FMT_SIGNED_INT;
268
      break;
269
 
270
    case '0':
271
    case '1':
272
    case '2':
273
    case '3':
274
    case '4':
275
    case '5':
276
    case '6':
277
    case '7':
278
    case '8':
279
    case '9':
280
      zflag = (c == '0');
281
 
282
      value = c - '0';
283
 
284
      do
285
        {
286
          c = next_char_not_space (&error);
287
          if (ISDIGIT (c))
288
            {
289
              value = 10 * value + c - '0';
290
              if (c != '0')
291
                zflag = 0;
292
            }
293
        }
294
      while (ISDIGIT (c));
295
 
296
      unget_char ();
297
      token = zflag ? FMT_ZERO : FMT_POSINT;
298
      break;
299
 
300
    case '.':
301
      token = FMT_PERIOD;
302
      break;
303
 
304
    case ',':
305
      token = FMT_COMMA;
306
      break;
307
 
308
    case ':':
309
      token = FMT_COLON;
310
      break;
311
 
312
    case '/':
313
      token = FMT_SLASH;
314
      break;
315
 
316
    case '$':
317
      token = FMT_DOLLAR;
318
      break;
319
 
320
    case 'T':
321
      c = next_char_not_space (&error);
322
      switch (c)
323
        {
324
        case 'L':
325
          token = FMT_TL;
326
          break;
327
        case 'R':
328
          token = FMT_TR;
329
          break;
330
        default:
331
          token = FMT_T;
332
          unget_char ();
333
        }
334
      break;
335
 
336
    case '(':
337
      token = FMT_LPAREN;
338
      break;
339
 
340
    case ')':
341
      token = FMT_RPAREN;
342
      break;
343
 
344
    case 'X':
345
      token = FMT_X;
346
      break;
347
 
348
    case 'S':
349
      c = next_char_not_space (&error);
350
      if (c != 'P' && c != 'S')
351
        unget_char ();
352
 
353
      token = FMT_SIGN;
354
      break;
355
 
356
    case 'B':
357
      c = next_char_not_space (&error);
358
      if (c == 'N' || c == 'Z')
359
        token = FMT_BLANK;
360
      else
361
        {
362
          unget_char ();
363
          token = FMT_IBOZ;
364
        }
365
 
366
      break;
367
 
368
    case '\'':
369
    case '"':
370
      delim = c;
371
 
372
      value = 0;
373
 
374
      for (;;)
375
        {
376
          c = next_char (1);
377
          if (c == '\0')
378
            {
379
              token = FMT_END;
380
              break;
381
            }
382
 
383
          if (c == delim)
384
            {
385
              c = next_char (1);
386
 
387
              if (c == '\0')
388
                {
389
                  token = FMT_END;
390
                  break;
391
                }
392
 
393
              if (c != delim)
394
                {
395
                  unget_char ();
396
                  token = FMT_CHAR;
397
                  break;
398
                }
399
            }
400
          value++;
401
        }
402
      break;
403
 
404
    case 'P':
405
      token = FMT_P;
406
      break;
407
 
408
    case 'I':
409
    case 'O':
410
    case 'Z':
411
      token = FMT_IBOZ;
412
      break;
413
 
414
    case 'F':
415
      token = FMT_F;
416
      break;
417
 
418
    case 'E':
419
      c = next_char_not_space (&error);
420
      if (c == 'N' )
421
        token = FMT_EN;
422
      else if (c == 'S')
423
        token = FMT_ES;
424
      else
425
        {
426
          token = FMT_E;
427
          unget_char ();
428
        }
429
 
430
      break;
431
 
432
    case 'G':
433
      token = FMT_G;
434
      break;
435
 
436
    case 'H':
437
      token = FMT_H;
438
      break;
439
 
440
    case 'L':
441
      token = FMT_L;
442
      break;
443
 
444
    case 'A':
445
      token = FMT_A;
446
      break;
447
 
448
    case 'D':
449
      c = next_char_not_space (&error);
450
      if (c == 'P')
451
        {
452
          if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DP format "
453
              "specifier not allowed at %C") == FAILURE)
454
            return FMT_ERROR;
455
          token = FMT_DP;
456
        }
457
      else if (c == 'C')
458
        {
459
          if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DC format "
460
              "specifier not allowed at %C") == FAILURE)
461
            return FMT_ERROR;
462
          token = FMT_DC;
463
        }
464
      else
465
        {
466
          token = FMT_D;
467
          unget_char ();
468
        }
469
      break;
470
 
471
    case 'R':
472
      c = next_char_not_space (&error);
473
      switch (c)
474
        {
475
        case 'C':
476
          token = FMT_RC;
477
          break;
478
        case 'D':
479
          token = FMT_RD;
480
          break;
481
        case 'N':
482
          token = FMT_RN;
483
          break;
484
        case 'P':
485
          token = FMT_RP;
486
          break;
487
        case 'U':
488
          token = FMT_RU;
489
          break;
490
        case 'Z':
491
          token = FMT_RZ;
492
          break;
493
        default:
494
          token = FMT_UNKNOWN;
495
          unget_char ();
496
          break;
497
        }
498
      break;
499
 
500
    case '\0':
501
      token = FMT_END;
502
      break;
503
 
504
    case '*':
505
      token = FMT_STAR;
506
      break;
507
 
508
    default:
509
      token = FMT_UNKNOWN;
510
      break;
511
    }
512
 
513
  if (error)
514
    return FMT_ERROR;
515
 
516
  return token;
517
}
518
 
519
 
520
static const char *
521
token_to_string (format_token t)
522
{
523
  switch (t)
524
    {
525
      case FMT_D:
526
        return "D";
527
      case FMT_G:
528
        return "G";
529
      case FMT_E:
530
        return "E";
531
      case FMT_EN:
532
        return "EN";
533
      case FMT_ES:
534
        return "ES";
535
      default:
536
        return "";
537
    }
538
}
539
 
540
/* Check a format statement.  The format string, either from a FORMAT
541
   statement or a constant in an I/O statement has already been parsed
542
   by itself, and we are checking it for validity.  The dual origin
543
   means that the warning message is a little less than great.  */
544
 
545
static gfc_try
546
check_format (bool is_input)
547
{
548
  const char *posint_required     = _("Positive width required");
549
  const char *nonneg_required     = _("Nonnegative width required");
550
  const char *unexpected_element  = _("Unexpected element '%c' in format string"
551
                                      " at %L");
552
  const char *unexpected_end      = _("Unexpected end of format string");
553
  const char *zero_width          = _("Zero width in format descriptor");
554
 
555
  const char *error;
556
  format_token t, u;
557
  int level;
558
  int repeat;
559
  gfc_try rv;
560
 
561
  use_last_char = 0;
562
  saved_token = FMT_NONE;
563
  level = 0;
564
  repeat = 0;
565
  rv = SUCCESS;
566
  format_string_pos = 0;
567
 
568
  t = format_lex ();
569
  if (t == FMT_ERROR)
570
    goto fail;
571
  if (t != FMT_LPAREN)
572
    {
573
      error = _("Missing leading left parenthesis");
574
      goto syntax;
575
    }
576
 
577
  t = format_lex ();
578
  if (t == FMT_ERROR)
579
    goto fail;
580
  if (t == FMT_RPAREN)
581
    goto finished;              /* Empty format is legal */
582
  saved_token = t;
583
 
584
format_item:
585
  /* In this state, the next thing has to be a format item.  */
586
  t = format_lex ();
587
  if (t == FMT_ERROR)
588
    goto fail;
589
format_item_1:
590
  switch (t)
591
    {
592
    case FMT_STAR:
593
      repeat = -1;
594
      t = format_lex ();
595
      if (t == FMT_ERROR)
596
        goto fail;
597
      if (t == FMT_LPAREN)
598
        {
599
          level++;
600
          goto format_item;
601
        }
602
      error = _("Left parenthesis required after '*'");
603
      goto syntax;
604
 
605
    case FMT_POSINT:
606
      repeat = value;
607
      t = format_lex ();
608
      if (t == FMT_ERROR)
609
        goto fail;
610
      if (t == FMT_LPAREN)
611
        {
612
          level++;
613
          goto format_item;
614
        }
615
 
616
      if (t == FMT_SLASH)
617
        goto optional_comma;
618
 
619
      goto data_desc;
620
 
621
    case FMT_LPAREN:
622
      level++;
623
      goto format_item;
624
 
625
    case FMT_SIGNED_INT:
626
    case FMT_ZERO:
627
      /* Signed integer can only precede a P format.  */
628
      t = format_lex ();
629
      if (t == FMT_ERROR)
630
        goto fail;
631
      if (t != FMT_P)
632
        {
633
          error = _("Expected P edit descriptor");
634
          goto syntax;
635
        }
636
 
637
      goto data_desc;
638
 
639
    case FMT_P:
640
      /* P requires a prior number.  */
641
      error = _("P descriptor requires leading scale factor");
642
      goto syntax;
643
 
644
    case FMT_X:
645
      /* X requires a prior number if we're being pedantic.  */
646
      if (mode != MODE_FORMAT)
647
        format_locus.nextc += format_string_pos;
648
      if (gfc_notify_std (GFC_STD_GNU, "Extension: X descriptor "
649
                          "requires leading space count at %L", &format_locus)
650
          == FAILURE)
651
        return FAILURE;
652
      goto between_desc;
653
 
654
    case FMT_SIGN:
655
    case FMT_BLANK:
656
    case FMT_DP:
657
    case FMT_DC:
658
    case FMT_RC:
659
    case FMT_RD:
660
    case FMT_RN:
661
    case FMT_RP:
662
    case FMT_RU:
663
    case FMT_RZ:
664
      goto between_desc;
665
 
666
    case FMT_CHAR:
667
      goto extension_optional_comma;
668
 
669
    case FMT_COLON:
670
    case FMT_SLASH:
671
      goto optional_comma;
672
 
673
    case FMT_DOLLAR:
674
      t = format_lex ();
675
      if (t == FMT_ERROR)
676
        goto fail;
677
 
678
      if (gfc_notify_std (GFC_STD_GNU, "Extension: $ descriptor at %L",
679
          &format_locus) == FAILURE)
680
        return FAILURE;
681
      if (t != FMT_RPAREN || level > 0)
682
        {
683
          gfc_warning ("$ should be the last specifier in format at %L",
684
                       &format_locus);
685
          goto optional_comma_1;
686
        }
687
 
688
      goto finished;
689
 
690
    case FMT_T:
691
    case FMT_TL:
692
    case FMT_TR:
693
    case FMT_IBOZ:
694
    case FMT_F:
695
    case FMT_E:
696
    case FMT_EN:
697
    case FMT_ES:
698
    case FMT_G:
699
    case FMT_L:
700
    case FMT_A:
701
    case FMT_D:
702
    case FMT_H:
703
      goto data_desc;
704
 
705
    case FMT_END:
706
      error = unexpected_end;
707
      goto syntax;
708
 
709
    default:
710
      error = unexpected_element;
711
      goto syntax;
712
    }
713
 
714
data_desc:
715
  /* In this state, t must currently be a data descriptor.
716
     Deal with things that can/must follow the descriptor.  */
717
  switch (t)
718
    {
719
    case FMT_SIGN:
720
    case FMT_BLANK:
721
    case FMT_DP:
722
    case FMT_DC:
723
    case FMT_X:
724
      break;
725
 
726
    case FMT_P:
727
      /* No comma after P allowed only for F, E, EN, ES, D, or G.
728
         10.1.1 (1).  */
729
      t = format_lex ();
730
      if (t == FMT_ERROR)
731
        goto fail;
732
      if (gfc_option.allow_std < GFC_STD_F2003 && t != FMT_COMMA
733
          && t != FMT_F && t != FMT_E && t != FMT_EN && t != FMT_ES
734
          && t != FMT_D && t != FMT_G && t != FMT_RPAREN && t != FMT_SLASH)
735
        {
736
          error = _("Comma required after P descriptor");
737
          goto syntax;
738
        }
739
      if (t != FMT_COMMA)
740
        {
741
          if (t == FMT_POSINT)
742
            {
743
              t = format_lex ();
744
              if (t == FMT_ERROR)
745
                goto fail;
746
            }
747
          if (t != FMT_F && t != FMT_E && t != FMT_EN && t != FMT_ES && t != FMT_D
748
              && t != FMT_G && t != FMT_RPAREN && t != FMT_SLASH)
749
            {
750
              error = _("Comma required after P descriptor");
751
              goto syntax;
752
            }
753
        }
754
 
755
      saved_token = t;
756
      goto optional_comma;
757
 
758
    case FMT_T:
759
    case FMT_TL:
760
    case FMT_TR:
761
      t = format_lex ();
762
      if (t != FMT_POSINT)
763
        {
764
          error = _("Positive width required with T descriptor");
765
          goto syntax;
766
        }
767
      break;
768
 
769
    case FMT_L:
770
      t = format_lex ();
771
      if (t == FMT_ERROR)
772
        goto fail;
773
      if (t == FMT_POSINT)
774
        break;
775
 
776
      switch (gfc_notification_std (GFC_STD_GNU))
777
        {
778
          case WARNING:
779
            if (mode != MODE_FORMAT)
780
              format_locus.nextc += format_string_pos;
781
            gfc_warning ("Extension: Missing positive width after L "
782
                         "descriptor at %L", &format_locus);
783
            saved_token = t;
784
            break;
785
 
786
          case ERROR:
787
            error = posint_required;
788
            goto syntax;
789
 
790
          case SILENT:
791
            saved_token = t;
792
            break;
793
 
794
          default:
795
            gcc_unreachable ();
796
        }
797
      break;
798
 
799
    case FMT_A:
800
      t = format_lex ();
801
      if (t == FMT_ERROR)
802
        goto fail;
803
      if (t == FMT_ZERO)
804
        {
805
          error = zero_width;
806
          goto syntax;
807
        }
808
      if (t != FMT_POSINT)
809
        saved_token = t;
810
      break;
811
 
812
    case FMT_D:
813
    case FMT_E:
814
    case FMT_G:
815
    case FMT_EN:
816
    case FMT_ES:
817
      u = format_lex ();
818
      if (t == FMT_G && u == FMT_ZERO)
819
        {
820
          if (is_input)
821
            {
822
              error = zero_width;
823
              goto syntax;
824
            }
825
          if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: 'G0' in "
826
                              "format at %L", &format_locus) == FAILURE)
827
            return FAILURE;
828
          u = format_lex ();
829
          if (u != FMT_PERIOD)
830
            {
831
              saved_token = u;
832
              break;
833
            }
834
          u = format_lex ();
835
          if (u != FMT_POSINT)
836
            {
837
              error = posint_required;
838
              goto syntax;
839
            }
840
          u = format_lex ();
841
          if (u == FMT_E)
842
            {
843
              error = _("E specifier not allowed with g0 descriptor");
844
              goto syntax;
845
            }
846
          saved_token = u;
847
          break;
848
        }
849
 
850
      if (u != FMT_POSINT)
851
        {
852
          format_locus.nextc += format_string_pos;
853
          gfc_error_now ("Positive width required in format "
854
                         "specifier %s at %L", token_to_string (t),
855
                         &format_locus);
856
          saved_token = u;
857
          goto finished;
858
        }
859
 
860
      u = format_lex ();
861
      if (u == FMT_ERROR)
862
        goto fail;
863
      if (u != FMT_PERIOD)
864
        {
865
          /* Warn if -std=legacy, otherwise error.  */
866
          format_locus.nextc += format_string_pos;
867
          if (gfc_option.warn_std != 0)
868
            {
869
              gfc_error_now ("Period required in format "
870
                             "specifier %s at %L", token_to_string (t),
871
                             &format_locus);
872
              saved_token = u;
873
              goto finished;
874
            }
875
          else
876
            gfc_warning ("Period required in format "
877
                         "specifier %s at %L", token_to_string (t),
878
                          &format_locus);
879
          /* If we go to finished, we need to unwind this
880
             before the next round.  */
881
          format_locus.nextc -= format_string_pos;
882
          saved_token = u;
883
          break;
884
        }
885
 
886
      u = format_lex ();
887
      if (u == FMT_ERROR)
888
        goto fail;
889
      if (u != FMT_ZERO && u != FMT_POSINT)
890
        {
891
          error = nonneg_required;
892
          goto syntax;
893
        }
894
 
895
      if (t == FMT_D)
896
        break;
897
 
898
      /* Look for optional exponent.  */
899
      u = format_lex ();
900
      if (u == FMT_ERROR)
901
        goto fail;
902
      if (u != FMT_E)
903
        {
904
          saved_token = u;
905
        }
906
      else
907
        {
908
          u = format_lex ();
909
          if (u == FMT_ERROR)
910
            goto fail;
911
          if (u != FMT_POSINT)
912
            {
913
              error = _("Positive exponent width required");
914
              goto syntax;
915
            }
916
        }
917
 
918
      break;
919
 
920
    case FMT_F:
921
      t = format_lex ();
922
      if (t == FMT_ERROR)
923
        goto fail;
924
      if (t != FMT_ZERO && t != FMT_POSINT)
925
        {
926
          error = nonneg_required;
927
          goto syntax;
928
        }
929
      else if (is_input && t == FMT_ZERO)
930
        {
931
          error = posint_required;
932
          goto syntax;
933
        }
934
 
935
      t = format_lex ();
936
      if (t == FMT_ERROR)
937
        goto fail;
938
      if (t != FMT_PERIOD)
939
        {
940
          /* Warn if -std=legacy, otherwise error.  */
941
          if (gfc_option.warn_std != 0)
942
            {
943
              error = _("Period required in format specifier");
944
              goto syntax;
945
            }
946
          if (mode != MODE_FORMAT)
947
            format_locus.nextc += format_string_pos;
948
          gfc_warning ("Period required in format specifier at %L",
949
                       &format_locus);
950
          saved_token = t;
951
          break;
952
        }
953
 
954
      t = format_lex ();
955
      if (t == FMT_ERROR)
956
        goto fail;
957
      if (t != FMT_ZERO && t != FMT_POSINT)
958
        {
959
          error = nonneg_required;
960
          goto syntax;
961
        }
962
 
963
      break;
964
 
965
    case FMT_H:
966
      if (!(gfc_option.allow_std & GFC_STD_GNU) && !inhibit_warnings)
967
        {
968
          if (mode != MODE_FORMAT)
969
            format_locus.nextc += format_string_pos;
970
          gfc_warning ("The H format specifier at %L is"
971
                       " a Fortran 95 deleted feature", &format_locus);
972
        }
973
 
974
      if (mode == MODE_STRING)
975
        {
976
          format_string += value;
977
          format_length -= value;
978
        }
979
      else
980
        {
981
          while (repeat >0)
982
           {
983
             next_char (1);
984
             repeat -- ;
985
           }
986
        }
987
     break;
988
 
989
    case FMT_IBOZ:
990
      t = format_lex ();
991
      if (t == FMT_ERROR)
992
        goto fail;
993
      if (t != FMT_ZERO && t != FMT_POSINT)
994
        {
995
          error = nonneg_required;
996
          goto syntax;
997
        }
998
      else if (is_input && t == FMT_ZERO)
999
        {
1000
          error = posint_required;
1001
          goto syntax;
1002
        }
1003
 
1004
      t = format_lex ();
1005
      if (t == FMT_ERROR)
1006
        goto fail;
1007
      if (t != FMT_PERIOD)
1008
        {
1009
          saved_token = t;
1010
        }
1011
      else
1012
        {
1013
          t = format_lex ();
1014
          if (t == FMT_ERROR)
1015
            goto fail;
1016
          if (t != FMT_ZERO && t != FMT_POSINT)
1017
            {
1018
              error = nonneg_required;
1019
              goto syntax;
1020
            }
1021
        }
1022
 
1023
      break;
1024
 
1025
    default:
1026
      error = unexpected_element;
1027
      goto syntax;
1028
    }
1029
 
1030
between_desc:
1031
  /* Between a descriptor and what comes next.  */
1032
  t = format_lex ();
1033
  if (t == FMT_ERROR)
1034
    goto fail;
1035
  switch (t)
1036
    {
1037
 
1038
    case FMT_COMMA:
1039
      goto format_item;
1040
 
1041
    case FMT_RPAREN:
1042
      level--;
1043
      if (level < 0)
1044
        goto finished;
1045
      goto between_desc;
1046
 
1047
    case FMT_COLON:
1048
    case FMT_SLASH:
1049
      goto optional_comma;
1050
 
1051
    case FMT_END:
1052
      error = unexpected_end;
1053
      goto syntax;
1054
 
1055
    default:
1056
      if (mode != MODE_FORMAT)
1057
        format_locus.nextc += format_string_pos - 1;
1058
      if (gfc_notify_std (GFC_STD_GNU, "Extension: Missing comma at %L",
1059
          &format_locus) == FAILURE)
1060
        return FAILURE;
1061
      /* If we do not actually return a failure, we need to unwind this
1062
         before the next round.  */
1063
      if (mode != MODE_FORMAT)
1064
        format_locus.nextc -= format_string_pos;
1065
      goto format_item_1;
1066
    }
1067
 
1068
optional_comma:
1069
  /* Optional comma is a weird between state where we've just finished
1070
     reading a colon, slash, dollar or P descriptor.  */
1071
  t = format_lex ();
1072
  if (t == FMT_ERROR)
1073
    goto fail;
1074
optional_comma_1:
1075
  switch (t)
1076
    {
1077
    case FMT_COMMA:
1078
      break;
1079
 
1080
    case FMT_RPAREN:
1081
      level--;
1082
      if (level < 0)
1083
        goto finished;
1084
      goto between_desc;
1085
 
1086
    default:
1087
      /* Assume that we have another format item.  */
1088
      saved_token = t;
1089
      break;
1090
    }
1091
 
1092
  goto format_item;
1093
 
1094
extension_optional_comma:
1095
  /* As a GNU extension, permit a missing comma after a string literal.  */
1096
  t = format_lex ();
1097
  if (t == FMT_ERROR)
1098
    goto fail;
1099
  switch (t)
1100
    {
1101
    case FMT_COMMA:
1102
      break;
1103
 
1104
    case FMT_RPAREN:
1105
      level--;
1106
      if (level < 0)
1107
        goto finished;
1108
      goto between_desc;
1109
 
1110
    case FMT_COLON:
1111
    case FMT_SLASH:
1112
      goto optional_comma;
1113
 
1114
    case FMT_END:
1115
      error = unexpected_end;
1116
      goto syntax;
1117
 
1118
    default:
1119
      if (mode != MODE_FORMAT)
1120
        format_locus.nextc += format_string_pos;
1121
      if (gfc_notify_std (GFC_STD_GNU, "Extension: Missing comma at %L",
1122
          &format_locus) == FAILURE)
1123
        return FAILURE;
1124
      /* If we do not actually return a failure, we need to unwind this
1125
         before the next round.  */
1126
      if (mode != MODE_FORMAT)
1127
        format_locus.nextc -= format_string_pos;
1128
      saved_token = t;
1129
      break;
1130
    }
1131
 
1132
  goto format_item;
1133
 
1134
syntax:
1135
  if (mode != MODE_FORMAT)
1136
    format_locus.nextc += format_string_pos;
1137
  if (error == unexpected_element)
1138
    gfc_error (error, error_element, &format_locus);
1139
  else
1140
    gfc_error ("%s in format string at %L", error, &format_locus);
1141
fail:
1142
  rv = FAILURE;
1143
 
1144
finished:
1145
  return rv;
1146
}
1147
 
1148
 
1149
/* Given an expression node that is a constant string, see if it looks
1150
   like a format string.  */
1151
 
1152
static gfc_try
1153
check_format_string (gfc_expr *e, bool is_input)
1154
{
1155
  if (!e || e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT)
1156
    return SUCCESS;
1157
 
1158
  mode = MODE_STRING;
1159
  format_string = e->value.character.string;
1160
 
1161
  /* More elaborate measures are needed to show where a problem is within a
1162
     format string that has been calculated, but that's probably not worth the
1163
     effort.  */
1164
  format_locus = e->where;
1165
 
1166
  return check_format (is_input);
1167
}
1168
 
1169
 
1170
/************ Fortran 95 I/O statement matchers *************/
1171
 
1172
/* Match a FORMAT statement.  This amounts to actually parsing the
1173
   format descriptors in order to correctly locate the end of the
1174
   format string.  */
1175
 
1176
match
1177
gfc_match_format (void)
1178
{
1179
  gfc_expr *e;
1180
  locus start;
1181
 
1182
  if (gfc_current_ns->proc_name
1183
      && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
1184
    {
1185
      gfc_error ("Format statement in module main block at %C");
1186
      return MATCH_ERROR;
1187
    }
1188
 
1189
  if (gfc_statement_label == NULL)
1190
    {
1191
      gfc_error ("Missing format label at %C");
1192
      return MATCH_ERROR;
1193
    }
1194
  gfc_gobble_whitespace ();
1195
 
1196
  mode = MODE_FORMAT;
1197
  format_length = 0;
1198
 
1199
  start = gfc_current_locus;
1200
 
1201
  if (check_format (false) == FAILURE)
1202
    return MATCH_ERROR;
1203
 
1204
  if (gfc_match_eos () != MATCH_YES)
1205
    {
1206
      gfc_syntax_error (ST_FORMAT);
1207
      return MATCH_ERROR;
1208
    }
1209
 
1210
  /* The label doesn't get created until after the statement is done
1211
     being matched, so we have to leave the string for later.  */
1212
 
1213
  gfc_current_locus = start;    /* Back to the beginning */
1214
 
1215
  new_st.loc = start;
1216
  new_st.op = EXEC_NOP;
1217
 
1218
  e = gfc_get_expr();
1219
  e->expr_type = EXPR_CONSTANT;
1220
  e->ts.type = BT_CHARACTER;
1221
  e->ts.kind = gfc_default_character_kind;
1222
  e->where = start;
1223
  e->value.character.string = format_string
1224
                            = gfc_get_wide_string (format_length + 1);
1225
  e->value.character.length = format_length;
1226
  gfc_statement_label->format = e;
1227
 
1228
  mode = MODE_COPY;
1229
  check_format (false);         /* Guaranteed to succeed */
1230
  gfc_match_eos ();             /* Guaranteed to succeed */
1231
 
1232
  return MATCH_YES;
1233
}
1234
 
1235
 
1236
/* Match an expression I/O tag of some sort.  */
1237
 
1238
static match
1239
match_etag (const io_tag *tag, gfc_expr **v)
1240
{
1241
  gfc_expr *result;
1242
  match m;
1243
 
1244
  m = gfc_match (tag->spec);
1245
  if (m != MATCH_YES)
1246
    return m;
1247
 
1248
  m = gfc_match (tag->value, &result);
1249
  if (m != MATCH_YES)
1250
    {
1251
      gfc_error ("Invalid value for %s specification at %C", tag->name);
1252
      return MATCH_ERROR;
1253
    }
1254
 
1255
  if (*v != NULL)
1256
    {
1257
      gfc_error ("Duplicate %s specification at %C", tag->name);
1258
      gfc_free_expr (result);
1259
      return MATCH_ERROR;
1260
    }
1261
 
1262
  *v = result;
1263
  return MATCH_YES;
1264
}
1265
 
1266
 
1267
/* Match a variable I/O tag of some sort.  */
1268
 
1269
static match
1270
match_vtag (const io_tag *tag, gfc_expr **v)
1271
{
1272
  gfc_expr *result;
1273
  match m;
1274
 
1275
  m = gfc_match (tag->spec);
1276
  if (m != MATCH_YES)
1277
    return m;
1278
 
1279
  m = gfc_match (tag->value, &result);
1280
  if (m != MATCH_YES)
1281
    {
1282
      gfc_error ("Invalid value for %s specification at %C", tag->name);
1283
      return MATCH_ERROR;
1284
    }
1285
 
1286
  if (*v != NULL)
1287
    {
1288
      gfc_error ("Duplicate %s specification at %C", tag->name);
1289
      gfc_free_expr (result);
1290
      return MATCH_ERROR;
1291
    }
1292
 
1293
  if (result->symtree->n.sym->attr.intent == INTENT_IN)
1294
    {
1295
      gfc_error ("Variable %s cannot be INTENT(IN) at %C", tag->name);
1296
      gfc_free_expr (result);
1297
      return MATCH_ERROR;
1298
    }
1299
 
1300
  if (gfc_pure (NULL) && gfc_impure_variable (result->symtree->n.sym))
1301
    {
1302
      gfc_error ("Variable %s cannot be assigned in PURE procedure at %C",
1303
                 tag->name);
1304
      gfc_free_expr (result);
1305
      return MATCH_ERROR;
1306
    }
1307
 
1308
  *v = result;
1309
  return MATCH_YES;
1310
}
1311
 
1312
 
1313
/* Match I/O tags that cause variables to become redefined.  */
1314
 
1315
static match
1316
match_out_tag (const io_tag *tag, gfc_expr **result)
1317
{
1318
  match m;
1319
 
1320
  m = match_vtag (tag, result);
1321
  if (m == MATCH_YES)
1322
    gfc_check_do_variable ((*result)->symtree);
1323
 
1324
  return m;
1325
}
1326
 
1327
 
1328
/* Match a label I/O tag.  */
1329
 
1330
static match
1331
match_ltag (const io_tag *tag, gfc_st_label ** label)
1332
{
1333
  match m;
1334
  gfc_st_label *old;
1335
 
1336
  old = *label;
1337
  m = gfc_match (tag->spec);
1338
  if (m != MATCH_YES)
1339
    return m;
1340
 
1341
  m = gfc_match (tag->value, label);
1342
  if (m != MATCH_YES)
1343
    {
1344
      gfc_error ("Invalid value for %s specification at %C", tag->name);
1345
      return MATCH_ERROR;
1346
    }
1347
 
1348
  if (old)
1349
    {
1350
      gfc_error ("Duplicate %s label specification at %C", tag->name);
1351
      return MATCH_ERROR;
1352
    }
1353
 
1354
  if (gfc_reference_st_label (*label, ST_LABEL_TARGET) == FAILURE)
1355
    return MATCH_ERROR;
1356
 
1357
  return m;
1358
}
1359
 
1360
 
1361
/* Resolution of the FORMAT tag, to be called from resolve_tag.  */
1362
 
1363
static gfc_try
1364
resolve_tag_format (const gfc_expr *e)
1365
{
1366
  if (e->expr_type == EXPR_CONSTANT
1367
      && (e->ts.type != BT_CHARACTER
1368
          || e->ts.kind != gfc_default_character_kind))
1369
    {
1370
      gfc_error ("Constant expression in FORMAT tag at %L must be "
1371
                 "of type default CHARACTER", &e->where);
1372
      return FAILURE;
1373
    }
1374
 
1375
  /* If e's rank is zero and e is not an element of an array, it should be
1376
     of integer or character type.  The integer variable should be
1377
     ASSIGNED.  */
1378
  if (e->rank == 0
1379
      && (e->expr_type != EXPR_VARIABLE
1380
          || e->symtree == NULL
1381
          || e->symtree->n.sym->as == NULL
1382
          || e->symtree->n.sym->as->rank == 0))
1383
    {
1384
      if (e->ts.type != BT_CHARACTER && e->ts.type != BT_INTEGER)
1385
        {
1386
          gfc_error ("FORMAT tag at %L must be of type CHARACTER or INTEGER",
1387
                     &e->where);
1388
          return FAILURE;
1389
        }
1390
      else if (e->ts.type == BT_INTEGER && e->expr_type == EXPR_VARIABLE)
1391
        {
1392
          if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: ASSIGNED "
1393
                              "variable in FORMAT tag at %L", &e->where)
1394
              == FAILURE)
1395
            return FAILURE;
1396
          if (e->symtree->n.sym->attr.assign != 1)
1397
            {
1398
              gfc_error ("Variable '%s' at %L has not been assigned a "
1399
                         "format label", e->symtree->n.sym->name, &e->where);
1400
              return FAILURE;
1401
            }
1402
        }
1403
      else if (e->ts.type == BT_INTEGER)
1404
        {
1405
          gfc_error ("Scalar '%s' in FORMAT tag at %L is not an ASSIGNED "
1406
                     "variable", gfc_basic_typename (e->ts.type), &e->where);
1407
          return FAILURE;
1408
        }
1409
 
1410
      return SUCCESS;
1411
    }
1412
 
1413
  /* If rank is nonzero and type is not character, we allow it under GFC_STD_LEGACY.
1414
     It may be assigned an Hollerith constant.  */
1415
  if (e->ts.type != BT_CHARACTER)
1416
    {
1417
      if (gfc_notify_std (GFC_STD_LEGACY, "Extension: Non-character "
1418
                          "in FORMAT tag at %L", &e->where) == FAILURE)
1419
        return FAILURE;
1420
 
1421
      if (e->rank == 0 && e->symtree->n.sym->as->type == AS_ASSUMED_SHAPE)
1422
        {
1423
          gfc_error ("Non-character assumed shape array element in FORMAT"
1424
                     " tag at %L", &e->where);
1425
          return FAILURE;
1426
        }
1427
 
1428
      if (e->rank == 0 && e->symtree->n.sym->as->type == AS_ASSUMED_SIZE)
1429
        {
1430
          gfc_error ("Non-character assumed size array element in FORMAT"
1431
                     " tag at %L", &e->where);
1432
          return FAILURE;
1433
        }
1434
 
1435
      if (e->rank == 0 && e->symtree->n.sym->attr.pointer)
1436
        {
1437
          gfc_error ("Non-character pointer array element in FORMAT tag at %L",
1438
                     &e->where);
1439
          return FAILURE;
1440
        }
1441
    }
1442
 
1443
  return SUCCESS;
1444
}
1445
 
1446
 
1447
/* Do expression resolution and type-checking on an expression tag.  */
1448
 
1449
static gfc_try
1450
resolve_tag (const io_tag *tag, gfc_expr *e)
1451
{
1452
  if (e == NULL)
1453
    return SUCCESS;
1454
 
1455
  if (gfc_resolve_expr (e) == FAILURE)
1456
    return FAILURE;
1457
 
1458
  if (tag == &tag_format)
1459
    return resolve_tag_format (e);
1460
 
1461
  if (e->ts.type != tag->type)
1462
    {
1463
      gfc_error ("%s tag at %L must be of type %s", tag->name,
1464
                 &e->where, gfc_basic_typename (tag->type));
1465
      return FAILURE;
1466
    }
1467
 
1468
  if (e->rank != 0)
1469
    {
1470
      gfc_error ("%s tag at %L must be scalar", tag->name, &e->where);
1471
      return FAILURE;
1472
    }
1473
 
1474
  if (tag == &tag_iomsg)
1475
    {
1476
      if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: IOMSG tag at %L",
1477
                          &e->where) == FAILURE)
1478
        return FAILURE;
1479
    }
1480
 
1481
  if ((tag == &tag_iostat || tag == &tag_size || tag == &tag_iolength)
1482
      && e->ts.kind != gfc_default_integer_kind)
1483
    {
1484
      if (gfc_notify_std (GFC_STD_F2003, "Fortran 95 requires default "
1485
                          "INTEGER in %s tag at %L", tag->name, &e->where)
1486
          == FAILURE)
1487
        return FAILURE;
1488
    }
1489
 
1490
  if (tag == &tag_convert)
1491
    {
1492
      if (gfc_notify_std (GFC_STD_GNU, "Extension: CONVERT tag at %L",
1493
                          &e->where) == FAILURE)
1494
        return FAILURE;
1495
    }
1496
 
1497
  return SUCCESS;
1498
}
1499
 
1500
 
1501
/* Match a single tag of an OPEN statement.  */
1502
 
1503
static match
1504
match_open_element (gfc_open *open)
1505
{
1506
  match m;
1507
 
1508
  m = match_etag (&tag_e_async, &open->asynchronous);
1509
  if (m != MATCH_NO)
1510
    return m;
1511
  m = match_etag (&tag_unit, &open->unit);
1512
  if (m != MATCH_NO)
1513
    return m;
1514
  m = match_out_tag (&tag_iomsg, &open->iomsg);
1515
  if (m != MATCH_NO)
1516
    return m;
1517
  m = match_out_tag (&tag_iostat, &open->iostat);
1518
  if (m != MATCH_NO)
1519
    return m;
1520
  m = match_etag (&tag_file, &open->file);
1521
  if (m != MATCH_NO)
1522
    return m;
1523
  m = match_etag (&tag_status, &open->status);
1524
  if (m != MATCH_NO)
1525
    return m;
1526
  m = match_etag (&tag_e_access, &open->access);
1527
  if (m != MATCH_NO)
1528
    return m;
1529
  m = match_etag (&tag_e_form, &open->form);
1530
  if (m != MATCH_NO)
1531
    return m;
1532
  m = match_etag (&tag_e_recl, &open->recl);
1533
  if (m != MATCH_NO)
1534
    return m;
1535
  m = match_etag (&tag_e_blank, &open->blank);
1536
  if (m != MATCH_NO)
1537
    return m;
1538
  m = match_etag (&tag_e_position, &open->position);
1539
  if (m != MATCH_NO)
1540
    return m;
1541
  m = match_etag (&tag_e_action, &open->action);
1542
  if (m != MATCH_NO)
1543
    return m;
1544
  m = match_etag (&tag_e_delim, &open->delim);
1545
  if (m != MATCH_NO)
1546
    return m;
1547
  m = match_etag (&tag_e_pad, &open->pad);
1548
  if (m != MATCH_NO)
1549
    return m;
1550
  m = match_etag (&tag_e_decimal, &open->decimal);
1551
  if (m != MATCH_NO)
1552
    return m;
1553
  m = match_etag (&tag_e_encoding, &open->encoding);
1554
  if (m != MATCH_NO)
1555
    return m;
1556
  m = match_etag (&tag_e_round, &open->round);
1557
  if (m != MATCH_NO)
1558
    return m;
1559
  m = match_etag (&tag_e_sign, &open->sign);
1560
  if (m != MATCH_NO)
1561
    return m;
1562
  m = match_ltag (&tag_err, &open->err);
1563
  if (m != MATCH_NO)
1564
    return m;
1565
  m = match_etag (&tag_convert, &open->convert);
1566
  if (m != MATCH_NO)
1567
    return m;
1568
  m = match_out_tag (&tag_newunit, &open->newunit);
1569
  if (m != MATCH_NO)
1570
    return m;
1571
 
1572
  return MATCH_NO;
1573
}
1574
 
1575
 
1576
/* Free the gfc_open structure and all the expressions it contains.  */
1577
 
1578
void
1579
gfc_free_open (gfc_open *open)
1580
{
1581
  if (open == NULL)
1582
    return;
1583
 
1584
  gfc_free_expr (open->unit);
1585
  gfc_free_expr (open->iomsg);
1586
  gfc_free_expr (open->iostat);
1587
  gfc_free_expr (open->file);
1588
  gfc_free_expr (open->status);
1589
  gfc_free_expr (open->access);
1590
  gfc_free_expr (open->form);
1591
  gfc_free_expr (open->recl);
1592
  gfc_free_expr (open->blank);
1593
  gfc_free_expr (open->position);
1594
  gfc_free_expr (open->action);
1595
  gfc_free_expr (open->delim);
1596
  gfc_free_expr (open->pad);
1597
  gfc_free_expr (open->decimal);
1598
  gfc_free_expr (open->encoding);
1599
  gfc_free_expr (open->round);
1600
  gfc_free_expr (open->sign);
1601
  gfc_free_expr (open->convert);
1602
  gfc_free_expr (open->asynchronous);
1603
  gfc_free_expr (open->newunit);
1604
  gfc_free (open);
1605
}
1606
 
1607
 
1608
/* Resolve everything in a gfc_open structure.  */
1609
 
1610
gfc_try
1611
gfc_resolve_open (gfc_open *open)
1612
{
1613
 
1614
  RESOLVE_TAG (&tag_unit, open->unit);
1615
  RESOLVE_TAG (&tag_iomsg, open->iomsg);
1616
  RESOLVE_TAG (&tag_iostat, open->iostat);
1617
  RESOLVE_TAG (&tag_file, open->file);
1618
  RESOLVE_TAG (&tag_status, open->status);
1619
  RESOLVE_TAG (&tag_e_access, open->access);
1620
  RESOLVE_TAG (&tag_e_form, open->form);
1621
  RESOLVE_TAG (&tag_e_recl, open->recl);
1622
  RESOLVE_TAG (&tag_e_blank, open->blank);
1623
  RESOLVE_TAG (&tag_e_position, open->position);
1624
  RESOLVE_TAG (&tag_e_action, open->action);
1625
  RESOLVE_TAG (&tag_e_delim, open->delim);
1626
  RESOLVE_TAG (&tag_e_pad, open->pad);
1627
  RESOLVE_TAG (&tag_e_decimal, open->decimal);
1628
  RESOLVE_TAG (&tag_e_encoding, open->encoding);
1629
  RESOLVE_TAG (&tag_e_async, open->asynchronous);
1630
  RESOLVE_TAG (&tag_e_round, open->round);
1631
  RESOLVE_TAG (&tag_e_sign, open->sign);
1632
  RESOLVE_TAG (&tag_convert, open->convert);
1633
  RESOLVE_TAG (&tag_newunit, open->newunit);
1634
 
1635
  if (gfc_reference_st_label (open->err, ST_LABEL_TARGET) == FAILURE)
1636
    return FAILURE;
1637
 
1638
  return SUCCESS;
1639
}
1640
 
1641
 
1642
/* Check if a given value for a SPECIFIER is either in the list of values
1643
   allowed in F95 or F2003, issuing an error message and returning a zero
1644
   value if it is not allowed.  */
1645
 
1646
static int
1647
compare_to_allowed_values (const char *specifier, const char *allowed[],
1648
                           const char *allowed_f2003[],
1649
                           const char *allowed_gnu[], gfc_char_t *value,
1650
                           const char *statement, bool warn)
1651
{
1652
  int i;
1653
  unsigned int len;
1654
 
1655
  len = gfc_wide_strlen (value);
1656
  if (len > 0)
1657
  {
1658
    for (len--; len > 0; len--)
1659
      if (value[len] != ' ')
1660
        break;
1661
    len++;
1662
  }
1663
 
1664
  for (i = 0; allowed[i]; i++)
1665
    if (len == strlen (allowed[i])
1666
        && gfc_wide_strncasecmp (value, allowed[i], strlen (allowed[i])) == 0)
1667
      return 1;
1668
 
1669
  for (i = 0; allowed_f2003 && allowed_f2003[i]; i++)
1670
    if (len == strlen (allowed_f2003[i])
1671
        && gfc_wide_strncasecmp (value, allowed_f2003[i],
1672
                                 strlen (allowed_f2003[i])) == 0)
1673
      {
1674
        notification n = gfc_notification_std (GFC_STD_F2003);
1675
 
1676
        if (n == WARNING || (warn && n == ERROR))
1677
          {
1678
            gfc_warning ("Fortran 2003: %s specifier in %s statement at %C "
1679
                         "has value '%s'", specifier, statement,
1680
                         allowed_f2003[i]);
1681
            return 1;
1682
          }
1683
        else
1684
          if (n == ERROR)
1685
            {
1686
              gfc_notify_std (GFC_STD_F2003, "Fortran 2003: %s specifier in "
1687
                              "%s statement at %C has value '%s'", specifier,
1688
                              statement, allowed_f2003[i]);
1689
              return 0;
1690
            }
1691
 
1692
        /* n == SILENT */
1693
        return 1;
1694
      }
1695
 
1696
  for (i = 0; allowed_gnu && allowed_gnu[i]; i++)
1697
    if (len == strlen (allowed_gnu[i])
1698
        && gfc_wide_strncasecmp (value, allowed_gnu[i],
1699
                                 strlen (allowed_gnu[i])) == 0)
1700
      {
1701
        notification n = gfc_notification_std (GFC_STD_GNU);
1702
 
1703
        if (n == WARNING || (warn && n == ERROR))
1704
          {
1705
            gfc_warning ("Extension: %s specifier in %s statement at %C "
1706
                         "has value '%s'", specifier, statement,
1707
                         allowed_gnu[i]);
1708
            return 1;
1709
          }
1710
        else
1711
          if (n == ERROR)
1712
            {
1713
              gfc_notify_std (GFC_STD_GNU, "Extension: %s specifier in "
1714
                              "%s statement at %C has value '%s'", specifier,
1715
                              statement, allowed_gnu[i]);
1716
              return 0;
1717
            }
1718
 
1719
        /* n == SILENT */
1720
        return 1;
1721
      }
1722
 
1723
  if (warn)
1724
    {
1725
      char *s = gfc_widechar_to_char (value, -1);
1726
      gfc_warning ("%s specifier in %s statement at %C has invalid value '%s'",
1727
                   specifier, statement, s);
1728
      gfc_free (s);
1729
      return 1;
1730
    }
1731
  else
1732
    {
1733
      char *s = gfc_widechar_to_char (value, -1);
1734
      gfc_error ("%s specifier in %s statement at %C has invalid value '%s'",
1735
                 specifier, statement, s);
1736
      gfc_free (s);
1737
      return 0;
1738
    }
1739
}
1740
 
1741
 
1742
/* Match an OPEN statement.  */
1743
 
1744
match
1745
gfc_match_open (void)
1746
{
1747
  gfc_open *open;
1748
  match m;
1749
  bool warn;
1750
 
1751
  m = gfc_match_char ('(');
1752
  if (m == MATCH_NO)
1753
    return m;
1754
 
1755
  open = XCNEW (gfc_open);
1756
 
1757
  m = match_open_element (open);
1758
 
1759
  if (m == MATCH_ERROR)
1760
    goto cleanup;
1761
  if (m == MATCH_NO)
1762
    {
1763
      m = gfc_match_expr (&open->unit);
1764
      if (m == MATCH_NO)
1765
        goto syntax;
1766
      if (m == MATCH_ERROR)
1767
        goto cleanup;
1768
    }
1769
 
1770
  for (;;)
1771
    {
1772
      if (gfc_match_char (')') == MATCH_YES)
1773
        break;
1774
      if (gfc_match_char (',') != MATCH_YES)
1775
        goto syntax;
1776
 
1777
      m = match_open_element (open);
1778
      if (m == MATCH_ERROR)
1779
        goto cleanup;
1780
      if (m == MATCH_NO)
1781
        goto syntax;
1782
    }
1783
 
1784
  if (gfc_match_eos () == MATCH_NO)
1785
    goto syntax;
1786
 
1787
  if (gfc_pure (NULL))
1788
    {
1789
      gfc_error ("OPEN statement not allowed in PURE procedure at %C");
1790
      goto cleanup;
1791
    }
1792
 
1793
  warn = (open->err || open->iostat) ? true : false;
1794
 
1795
  /* Checks on NEWUNIT specifier.  */
1796
  if (open->newunit)
1797
    {
1798
      if (open->unit)
1799
        {
1800
          gfc_error ("UNIT specifier not allowed with NEWUNIT at %C");
1801
          goto cleanup;
1802
        }
1803
 
1804
      if (!(open->file || (open->status
1805
          && gfc_wide_strncasecmp (open->status->value.character.string,
1806
                                   "scratch", 7) == 0)))
1807
        {
1808
          gfc_error ("NEWUNIT specifier must have FILE= "
1809
                     "or STATUS='scratch' at %C");
1810
          goto cleanup;
1811
        }
1812
    }
1813
 
1814
  /* Checks on the ACCESS specifier.  */
1815
  if (open->access && open->access->expr_type == EXPR_CONSTANT)
1816
    {
1817
      static const char *access_f95[] = { "SEQUENTIAL", "DIRECT", NULL };
1818
      static const char *access_f2003[] = { "STREAM", NULL };
1819
      static const char *access_gnu[] = { "APPEND", NULL };
1820
 
1821
      if (!compare_to_allowed_values ("ACCESS", access_f95, access_f2003,
1822
                                      access_gnu,
1823
                                      open->access->value.character.string,
1824
                                      "OPEN", warn))
1825
        goto cleanup;
1826
    }
1827
 
1828
  /* Checks on the ACTION specifier.  */
1829
  if (open->action && open->action->expr_type == EXPR_CONSTANT)
1830
    {
1831
      static const char *action[] = { "READ", "WRITE", "READWRITE", NULL };
1832
 
1833
      if (!compare_to_allowed_values ("ACTION", action, NULL, NULL,
1834
                                      open->action->value.character.string,
1835
                                      "OPEN", warn))
1836
        goto cleanup;
1837
    }
1838
 
1839
  /* Checks on the ASYNCHRONOUS specifier.  */
1840
  if (open->asynchronous)
1841
    {
1842
      if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ASYNCHRONOUS= at %C "
1843
          "not allowed in Fortran 95") == FAILURE)
1844
        goto cleanup;
1845
 
1846
      if (open->asynchronous->expr_type == EXPR_CONSTANT)
1847
        {
1848
          static const char * asynchronous[] = { "YES", "NO", NULL };
1849
 
1850
          if (!compare_to_allowed_values ("ASYNCHRONOUS", asynchronous,
1851
                        NULL, NULL, open->asynchronous->value.character.string,
1852
                        "OPEN", warn))
1853
            goto cleanup;
1854
        }
1855
    }
1856
 
1857
  /* Checks on the BLANK specifier.  */
1858
  if (open->blank)
1859
    {
1860
      if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: BLANK= at %C "
1861
          "not allowed in Fortran 95") == FAILURE)
1862
        goto cleanup;
1863
 
1864
      if (open->blank->expr_type == EXPR_CONSTANT)
1865
        {
1866
          static const char *blank[] = { "ZERO", "NULL", NULL };
1867
 
1868
          if (!compare_to_allowed_values ("BLANK", blank, NULL, NULL,
1869
                                          open->blank->value.character.string,
1870
                                          "OPEN", warn))
1871
            goto cleanup;
1872
        }
1873
    }
1874
 
1875
  /* Checks on the DECIMAL specifier.  */
1876
  if (open->decimal)
1877
    {
1878
      if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DECIMAL= at %C "
1879
          "not allowed in Fortran 95") == FAILURE)
1880
        goto cleanup;
1881
 
1882
      if (open->decimal->expr_type == EXPR_CONSTANT)
1883
        {
1884
          static const char * decimal[] = { "COMMA", "POINT", NULL };
1885
 
1886
          if (!compare_to_allowed_values ("DECIMAL", decimal, NULL, NULL,
1887
                                          open->decimal->value.character.string,
1888
                                          "OPEN", warn))
1889
            goto cleanup;
1890
        }
1891
    }
1892
 
1893
  /* Checks on the DELIM specifier.  */
1894
  if (open->delim)
1895
    {
1896
      if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DELIM= at %C "
1897
          "not allowed in Fortran 95") == FAILURE)
1898
        goto cleanup;
1899
 
1900
      if (open->delim->expr_type == EXPR_CONSTANT)
1901
        {
1902
          static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL };
1903
 
1904
          if (!compare_to_allowed_values ("DELIM", delim, NULL, NULL,
1905
                                          open->delim->value.character.string,
1906
                                          "OPEN", warn))
1907
          goto cleanup;
1908
        }
1909
    }
1910
 
1911
  /* Checks on the ENCODING specifier.  */
1912
  if (open->encoding)
1913
    {
1914
      if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ENCODING= at %C "
1915
          "not allowed in Fortran 95") == FAILURE)
1916
        goto cleanup;
1917
 
1918
      if (open->encoding->expr_type == EXPR_CONSTANT)
1919
        {
1920
          static const char * encoding[] = { "DEFAULT", "UTF-8", NULL };
1921
 
1922
          if (!compare_to_allowed_values ("ENCODING", encoding, NULL, NULL,
1923
                                          open->encoding->value.character.string,
1924
                                          "OPEN", warn))
1925
          goto cleanup;
1926
        }
1927
    }
1928
 
1929
  /* Checks on the FORM specifier.  */
1930
  if (open->form && open->form->expr_type == EXPR_CONSTANT)
1931
    {
1932
      static const char *form[] = { "FORMATTED", "UNFORMATTED", NULL };
1933
 
1934
      if (!compare_to_allowed_values ("FORM", form, NULL, NULL,
1935
                                      open->form->value.character.string,
1936
                                      "OPEN", warn))
1937
        goto cleanup;
1938
    }
1939
 
1940
  /* Checks on the PAD specifier.  */
1941
  if (open->pad && open->pad->expr_type == EXPR_CONSTANT)
1942
    {
1943
      static const char *pad[] = { "YES", "NO", NULL };
1944
 
1945
      if (!compare_to_allowed_values ("PAD", pad, NULL, NULL,
1946
                                      open->pad->value.character.string,
1947
                                      "OPEN", warn))
1948
        goto cleanup;
1949
    }
1950
 
1951
  /* Checks on the POSITION specifier.  */
1952
  if (open->position && open->position->expr_type == EXPR_CONSTANT)
1953
    {
1954
      static const char *position[] = { "ASIS", "REWIND", "APPEND", NULL };
1955
 
1956
      if (!compare_to_allowed_values ("POSITION", position, NULL, NULL,
1957
                                      open->position->value.character.string,
1958
                                      "OPEN", warn))
1959
        goto cleanup;
1960
    }
1961
 
1962
  /* Checks on the ROUND specifier.  */
1963
  if (open->round)
1964
    {
1965
      if (gfc_notify_std (GFC_STD_F2003, "Fortran F2003: ROUND= at %C "
1966
          "not allowed in Fortran 95") == FAILURE)
1967
      goto cleanup;
1968
 
1969
      if (open->round->expr_type == EXPR_CONSTANT)
1970
        {
1971
          static const char * round[] = { "UP", "DOWN", "ZERO", "NEAREST",
1972
                                          "COMPATIBLE", "PROCESSOR_DEFINED",
1973
                                           NULL };
1974
 
1975
          if (!compare_to_allowed_values ("ROUND", round, NULL, NULL,
1976
                                          open->round->value.character.string,
1977
                                          "OPEN", warn))
1978
          goto cleanup;
1979
        }
1980
    }
1981
 
1982
  /* Checks on the SIGN specifier.  */
1983
  if (open->sign)
1984
    {
1985
      if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: SIGN= at %C "
1986
          "not allowed in Fortran 95") == FAILURE)
1987
        goto cleanup;
1988
 
1989
      if (open->sign->expr_type == EXPR_CONSTANT)
1990
        {
1991
          static const char * sign[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED",
1992
                                          NULL };
1993
 
1994
          if (!compare_to_allowed_values ("SIGN", sign, NULL, NULL,
1995
                                          open->sign->value.character.string,
1996
                                          "OPEN", warn))
1997
          goto cleanup;
1998
        }
1999
    }
2000
 
2001
#define warn_or_error(...) \
2002
{ \
2003
  if (warn) \
2004
    gfc_warning (__VA_ARGS__); \
2005
  else \
2006
    { \
2007
      gfc_error (__VA_ARGS__); \
2008
      goto cleanup; \
2009
    } \
2010
}
2011
 
2012
  /* Checks on the RECL specifier.  */
2013
  if (open->recl && open->recl->expr_type == EXPR_CONSTANT
2014
      && open->recl->ts.type == BT_INTEGER
2015
      && mpz_sgn (open->recl->value.integer) != 1)
2016
    {
2017
      warn_or_error ("RECL in OPEN statement at %C must be positive");
2018
    }
2019
 
2020
  /* Checks on the STATUS specifier.  */
2021
  if (open->status && open->status->expr_type == EXPR_CONSTANT)
2022
    {
2023
      static const char *status[] = { "OLD", "NEW", "SCRATCH",
2024
        "REPLACE", "UNKNOWN", NULL };
2025
 
2026
      if (!compare_to_allowed_values ("STATUS", status, NULL, NULL,
2027
                                      open->status->value.character.string,
2028
                                      "OPEN", warn))
2029
        goto cleanup;
2030
 
2031
      /* F2003, 9.4.5: If the STATUS= specifier has the value NEW or REPLACE,
2032
         the FILE= specifier shall appear.  */
2033
      if (open->file == NULL
2034
          && (gfc_wide_strncasecmp (open->status->value.character.string,
2035
                                    "replace", 7) == 0
2036
              || gfc_wide_strncasecmp (open->status->value.character.string,
2037
                                       "new", 3) == 0))
2038
        {
2039
          char *s = gfc_widechar_to_char (open->status->value.character.string,
2040
                                          -1);
2041
          warn_or_error ("The STATUS specified in OPEN statement at %C is "
2042
                         "'%s' and no FILE specifier is present", s);
2043
          gfc_free (s);
2044
        }
2045
 
2046
      /* F2003, 9.4.5: If the STATUS= specifier has the value SCRATCH,
2047
         the FILE= specifier shall not appear.  */
2048
      if (gfc_wide_strncasecmp (open->status->value.character.string,
2049
                                "scratch", 7) == 0 && open->file)
2050
        {
2051
          warn_or_error ("The STATUS specified in OPEN statement at %C "
2052
                         "cannot have the value SCRATCH if a FILE specifier "
2053
                         "is present");
2054
        }
2055
    }
2056
 
2057
  /* Things that are not allowed for unformatted I/O.  */
2058
  if (open->form && open->form->expr_type == EXPR_CONSTANT
2059
      && (open->delim || open->decimal || open->encoding || open->round
2060
          || open->sign || open->pad || open->blank)
2061
      && gfc_wide_strncasecmp (open->form->value.character.string,
2062
                               "unformatted", 11) == 0)
2063
    {
2064
      const char *spec = (open->delim ? "DELIM "
2065
                                      : (open->pad ? "PAD " : open->blank
2066
                                                            ? "BLANK " : ""));
2067
 
2068
      warn_or_error ("%s specifier at %C not allowed in OPEN statement for "
2069
                     "unformatted I/O", spec);
2070
    }
2071
 
2072
  if (open->recl && open->access && open->access->expr_type == EXPR_CONSTANT
2073
      && gfc_wide_strncasecmp (open->access->value.character.string,
2074
                               "stream", 6) == 0)
2075
    {
2076
      warn_or_error ("RECL specifier not allowed in OPEN statement at %C for "
2077
                     "stream I/O");
2078
    }
2079
 
2080
  if (open->position
2081
      && open->access && open->access->expr_type == EXPR_CONSTANT
2082
      && !(gfc_wide_strncasecmp (open->access->value.character.string,
2083
                                 "sequential", 10) == 0
2084
           || gfc_wide_strncasecmp (open->access->value.character.string,
2085
                                    "stream", 6) == 0
2086
           || gfc_wide_strncasecmp (open->access->value.character.string,
2087
                                    "append", 6) == 0))
2088
    {
2089
      warn_or_error ("POSITION specifier in OPEN statement at %C only allowed "
2090
                     "for stream or sequential ACCESS");
2091
    }
2092
 
2093
#undef warn_or_error
2094
 
2095
  new_st.op = EXEC_OPEN;
2096
  new_st.ext.open = open;
2097
  return MATCH_YES;
2098
 
2099
syntax:
2100
  gfc_syntax_error (ST_OPEN);
2101
 
2102
cleanup:
2103
  gfc_free_open (open);
2104
  return MATCH_ERROR;
2105
}
2106
 
2107
 
2108
/* Free a gfc_close structure an all its expressions.  */
2109
 
2110
void
2111
gfc_free_close (gfc_close *close)
2112
{
2113
  if (close == NULL)
2114
    return;
2115
 
2116
  gfc_free_expr (close->unit);
2117
  gfc_free_expr (close->iomsg);
2118
  gfc_free_expr (close->iostat);
2119
  gfc_free_expr (close->status);
2120
  gfc_free (close);
2121
}
2122
 
2123
 
2124
/* Match elements of a CLOSE statement.  */
2125
 
2126
static match
2127
match_close_element (gfc_close *close)
2128
{
2129
  match m;
2130
 
2131
  m = match_etag (&tag_unit, &close->unit);
2132
  if (m != MATCH_NO)
2133
    return m;
2134
  m = match_etag (&tag_status, &close->status);
2135
  if (m != MATCH_NO)
2136
    return m;
2137
  m = match_out_tag (&tag_iomsg, &close->iomsg);
2138
  if (m != MATCH_NO)
2139
    return m;
2140
  m = match_out_tag (&tag_iostat, &close->iostat);
2141
  if (m != MATCH_NO)
2142
    return m;
2143
  m = match_ltag (&tag_err, &close->err);
2144
  if (m != MATCH_NO)
2145
    return m;
2146
 
2147
  return MATCH_NO;
2148
}
2149
 
2150
 
2151
/* Match a CLOSE statement.  */
2152
 
2153
match
2154
gfc_match_close (void)
2155
{
2156
  gfc_close *close;
2157
  match m;
2158
  bool warn;
2159
 
2160
  m = gfc_match_char ('(');
2161
  if (m == MATCH_NO)
2162
    return m;
2163
 
2164
  close = XCNEW (gfc_close);
2165
 
2166
  m = match_close_element (close);
2167
 
2168
  if (m == MATCH_ERROR)
2169
    goto cleanup;
2170
  if (m == MATCH_NO)
2171
    {
2172
      m = gfc_match_expr (&close->unit);
2173
      if (m == MATCH_NO)
2174
        goto syntax;
2175
      if (m == MATCH_ERROR)
2176
        goto cleanup;
2177
    }
2178
 
2179
  for (;;)
2180
    {
2181
      if (gfc_match_char (')') == MATCH_YES)
2182
        break;
2183
      if (gfc_match_char (',') != MATCH_YES)
2184
        goto syntax;
2185
 
2186
      m = match_close_element (close);
2187
      if (m == MATCH_ERROR)
2188
        goto cleanup;
2189
      if (m == MATCH_NO)
2190
        goto syntax;
2191
    }
2192
 
2193
  if (gfc_match_eos () == MATCH_NO)
2194
    goto syntax;
2195
 
2196
  if (gfc_pure (NULL))
2197
    {
2198
      gfc_error ("CLOSE statement not allowed in PURE procedure at %C");
2199
      goto cleanup;
2200
    }
2201
 
2202
  warn = (close->iostat || close->err) ? true : false;
2203
 
2204
  /* Checks on the STATUS specifier.  */
2205
  if (close->status && close->status->expr_type == EXPR_CONSTANT)
2206
    {
2207
      static const char *status[] = { "KEEP", "DELETE", NULL };
2208
 
2209
      if (!compare_to_allowed_values ("STATUS", status, NULL, NULL,
2210
                                      close->status->value.character.string,
2211
                                      "CLOSE", warn))
2212
        goto cleanup;
2213
    }
2214
 
2215
  new_st.op = EXEC_CLOSE;
2216
  new_st.ext.close = close;
2217
  return MATCH_YES;
2218
 
2219
syntax:
2220
  gfc_syntax_error (ST_CLOSE);
2221
 
2222
cleanup:
2223
  gfc_free_close (close);
2224
  return MATCH_ERROR;
2225
}
2226
 
2227
 
2228
/* Resolve everything in a gfc_close structure.  */
2229
 
2230
gfc_try
2231
gfc_resolve_close (gfc_close *close)
2232
{
2233
  RESOLVE_TAG (&tag_unit, close->unit);
2234
  RESOLVE_TAG (&tag_iomsg, close->iomsg);
2235
  RESOLVE_TAG (&tag_iostat, close->iostat);
2236
  RESOLVE_TAG (&tag_status, close->status);
2237
 
2238
  if (gfc_reference_st_label (close->err, ST_LABEL_TARGET) == FAILURE)
2239
    return FAILURE;
2240
 
2241
  if (close->unit->expr_type == EXPR_CONSTANT
2242
      && close->unit->ts.type == BT_INTEGER
2243
      && mpz_sgn (close->unit->value.integer) < 0)
2244
    {
2245
      gfc_error ("UNIT number in CLOSE statement at %L must be non-negative",
2246
                 &close->unit->where);
2247
    }
2248
 
2249
  return SUCCESS;
2250
}
2251
 
2252
 
2253
/* Free a gfc_filepos structure.  */
2254
 
2255
void
2256
gfc_free_filepos (gfc_filepos *fp)
2257
{
2258
  gfc_free_expr (fp->unit);
2259
  gfc_free_expr (fp->iomsg);
2260
  gfc_free_expr (fp->iostat);
2261
  gfc_free (fp);
2262
}
2263
 
2264
 
2265
/* Match elements of a REWIND, BACKSPACE, ENDFILE, or FLUSH statement.  */
2266
 
2267
static match
2268
match_file_element (gfc_filepos *fp)
2269
{
2270
  match m;
2271
 
2272
  m = match_etag (&tag_unit, &fp->unit);
2273
  if (m != MATCH_NO)
2274
    return m;
2275
  m = match_out_tag (&tag_iomsg, &fp->iomsg);
2276
  if (m != MATCH_NO)
2277
    return m;
2278
  m = match_out_tag (&tag_iostat, &fp->iostat);
2279
  if (m != MATCH_NO)
2280
    return m;
2281
  m = match_ltag (&tag_err, &fp->err);
2282
  if (m != MATCH_NO)
2283
    return m;
2284
 
2285
  return MATCH_NO;
2286
}
2287
 
2288
 
2289
/* Match the second half of the file-positioning statements, REWIND,
2290
   BACKSPACE, ENDFILE, or the FLUSH statement.  */
2291
 
2292
static match
2293
match_filepos (gfc_statement st, gfc_exec_op op)
2294
{
2295
  gfc_filepos *fp;
2296
  match m;
2297
 
2298
  fp = XCNEW (gfc_filepos);
2299
 
2300
  if (gfc_match_char ('(') == MATCH_NO)
2301
    {
2302
      m = gfc_match_expr (&fp->unit);
2303
      if (m == MATCH_ERROR)
2304
        goto cleanup;
2305
      if (m == MATCH_NO)
2306
        goto syntax;
2307
 
2308
      goto done;
2309
    }
2310
 
2311
  m = match_file_element (fp);
2312
  if (m == MATCH_ERROR)
2313
    goto done;
2314
  if (m == MATCH_NO)
2315
    {
2316
      m = gfc_match_expr (&fp->unit);
2317
      if (m == MATCH_ERROR)
2318
        goto done;
2319
      if (m == MATCH_NO)
2320
        goto syntax;
2321
    }
2322
 
2323
  for (;;)
2324
    {
2325
      if (gfc_match_char (')') == MATCH_YES)
2326
        break;
2327
      if (gfc_match_char (',') != MATCH_YES)
2328
        goto syntax;
2329
 
2330
      m = match_file_element (fp);
2331
      if (m == MATCH_ERROR)
2332
        goto cleanup;
2333
      if (m == MATCH_NO)
2334
        goto syntax;
2335
    }
2336
 
2337
done:
2338
  if (gfc_match_eos () != MATCH_YES)
2339
    goto syntax;
2340
 
2341
  if (gfc_pure (NULL))
2342
    {
2343
      gfc_error ("%s statement not allowed in PURE procedure at %C",
2344
                 gfc_ascii_statement (st));
2345
 
2346
      goto cleanup;
2347
    }
2348
 
2349
  new_st.op = op;
2350
  new_st.ext.filepos = fp;
2351
  return MATCH_YES;
2352
 
2353
syntax:
2354
  gfc_syntax_error (st);
2355
 
2356
cleanup:
2357
  gfc_free_filepos (fp);
2358
  return MATCH_ERROR;
2359
}
2360
 
2361
 
2362
gfc_try
2363
gfc_resolve_filepos (gfc_filepos *fp)
2364
{
2365
  RESOLVE_TAG (&tag_unit, fp->unit);
2366
  RESOLVE_TAG (&tag_iostat, fp->iostat);
2367
  RESOLVE_TAG (&tag_iomsg, fp->iomsg);
2368
  if (gfc_reference_st_label (fp->err, ST_LABEL_TARGET) == FAILURE)
2369
    return FAILURE;
2370
 
2371
  if (fp->unit->expr_type == EXPR_CONSTANT
2372
      && fp->unit->ts.type == BT_INTEGER
2373
      && mpz_sgn (fp->unit->value.integer) < 0)
2374
    {
2375
      gfc_error ("UNIT number in statement at %L must be non-negative",
2376
                 &fp->unit->where);
2377
    }
2378
 
2379
  return SUCCESS;
2380
}
2381
 
2382
 
2383
/* Match the file positioning statements: ENDFILE, BACKSPACE, REWIND,
2384
   and the FLUSH statement.  */
2385
 
2386
match
2387
gfc_match_endfile (void)
2388
{
2389
  return match_filepos (ST_END_FILE, EXEC_ENDFILE);
2390
}
2391
 
2392
match
2393
gfc_match_backspace (void)
2394
{
2395
  return match_filepos (ST_BACKSPACE, EXEC_BACKSPACE);
2396
}
2397
 
2398
match
2399
gfc_match_rewind (void)
2400
{
2401
  return match_filepos (ST_REWIND, EXEC_REWIND);
2402
}
2403
 
2404
match
2405
gfc_match_flush (void)
2406
{
2407
  if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: FLUSH statement at %C")
2408
      == FAILURE)
2409
    return MATCH_ERROR;
2410
 
2411
  return match_filepos (ST_FLUSH, EXEC_FLUSH);
2412
}
2413
 
2414
/******************** Data Transfer Statements *********************/
2415
 
2416
/* Return a default unit number.  */
2417
 
2418
static gfc_expr *
2419
default_unit (io_kind k)
2420
{
2421
  int unit;
2422
 
2423
  if (k == M_READ)
2424
    unit = 5;
2425
  else
2426
    unit = 6;
2427
 
2428
  return gfc_int_expr (unit);
2429
}
2430
 
2431
 
2432
/* Match a unit specification for a data transfer statement.  */
2433
 
2434
static match
2435
match_dt_unit (io_kind k, gfc_dt *dt)
2436
{
2437
  gfc_expr *e;
2438
 
2439
  if (gfc_match_char ('*') == MATCH_YES)
2440
    {
2441
      if (dt->io_unit != NULL)
2442
        goto conflict;
2443
 
2444
      dt->io_unit = default_unit (k);
2445
      return MATCH_YES;
2446
    }
2447
 
2448
  if (gfc_match_expr (&e) == MATCH_YES)
2449
    {
2450
      if (dt->io_unit != NULL)
2451
        {
2452
          gfc_free_expr (e);
2453
          goto conflict;
2454
        }
2455
 
2456
      dt->io_unit = e;
2457
      return MATCH_YES;
2458
    }
2459
 
2460
  return MATCH_NO;
2461
 
2462
conflict:
2463
  gfc_error ("Duplicate UNIT specification at %C");
2464
  return MATCH_ERROR;
2465
}
2466
 
2467
 
2468
/* Match a format specification.  */
2469
 
2470
static match
2471
match_dt_format (gfc_dt *dt)
2472
{
2473
  locus where;
2474
  gfc_expr *e;
2475
  gfc_st_label *label;
2476
  match m;
2477
 
2478
  where = gfc_current_locus;
2479
 
2480
  if (gfc_match_char ('*') == MATCH_YES)
2481
    {
2482
      if (dt->format_expr != NULL || dt->format_label != NULL)
2483
        goto conflict;
2484
 
2485
      dt->format_label = &format_asterisk;
2486
      return MATCH_YES;
2487
    }
2488
 
2489
  if ((m = gfc_match_st_label (&label)) == MATCH_YES)
2490
    {
2491
      if (dt->format_expr != NULL || dt->format_label != NULL)
2492
        {
2493
          gfc_free_st_label (label);
2494
          goto conflict;
2495
        }
2496
 
2497
      if (gfc_reference_st_label (label, ST_LABEL_FORMAT) == FAILURE)
2498
        return MATCH_ERROR;
2499
 
2500
      dt->format_label = label;
2501
      return MATCH_YES;
2502
    }
2503
  else if (m == MATCH_ERROR)
2504
    /* The label was zero or too large.  Emit the correct diagnosis.  */
2505
    return MATCH_ERROR;
2506
 
2507
  if (gfc_match_expr (&e) == MATCH_YES)
2508
    {
2509
      if (dt->format_expr != NULL || dt->format_label != NULL)
2510
        {
2511
          gfc_free_expr (e);
2512
          goto conflict;
2513
        }
2514
      dt->format_expr = e;
2515
      return MATCH_YES;
2516
    }
2517
 
2518
  gfc_current_locus = where;    /* The only case where we have to restore */
2519
 
2520
  return MATCH_NO;
2521
 
2522
conflict:
2523
  gfc_error ("Duplicate format specification at %C");
2524
  return MATCH_ERROR;
2525
}
2526
 
2527
 
2528
/* Traverse a namelist that is part of a READ statement to make sure
2529
   that none of the variables in the namelist are INTENT(IN).  Returns
2530
   nonzero if we find such a variable.  */
2531
 
2532
static int
2533
check_namelist (gfc_symbol *sym)
2534
{
2535
  gfc_namelist *p;
2536
 
2537
  for (p = sym->namelist; p; p = p->next)
2538
    if (p->sym->attr.intent == INTENT_IN)
2539
      {
2540
        gfc_error ("Symbol '%s' in namelist '%s' is INTENT(IN) at %C",
2541
                   p->sym->name, sym->name);
2542
        return 1;
2543
      }
2544
 
2545
  return 0;
2546
}
2547
 
2548
 
2549
/* Match a single data transfer element.  */
2550
 
2551
static match
2552
match_dt_element (io_kind k, gfc_dt *dt)
2553
{
2554
  char name[GFC_MAX_SYMBOL_LEN + 1];
2555
  gfc_symbol *sym;
2556
  match m;
2557
 
2558
  if (gfc_match (" unit =") == MATCH_YES)
2559
    {
2560
      m = match_dt_unit (k, dt);
2561
      if (m != MATCH_NO)
2562
        return m;
2563
    }
2564
 
2565
  if (gfc_match (" fmt =") == MATCH_YES)
2566
    {
2567
      m = match_dt_format (dt);
2568
      if (m != MATCH_NO)
2569
        return m;
2570
    }
2571
 
2572
  if (gfc_match (" nml = %n", name) == MATCH_YES)
2573
    {
2574
      if (dt->namelist != NULL)
2575
        {
2576
          gfc_error ("Duplicate NML specification at %C");
2577
          return MATCH_ERROR;
2578
        }
2579
 
2580
      if (gfc_find_symbol (name, NULL, 1, &sym))
2581
        return MATCH_ERROR;
2582
 
2583
      if (sym == NULL || sym->attr.flavor != FL_NAMELIST)
2584
        {
2585
          gfc_error ("Symbol '%s' at %C must be a NAMELIST group name",
2586
                     sym != NULL ? sym->name : name);
2587
          return MATCH_ERROR;
2588
        }
2589
 
2590
      dt->namelist = sym;
2591
      if (k == M_READ && check_namelist (sym))
2592
        return MATCH_ERROR;
2593
 
2594
      return MATCH_YES;
2595
    }
2596
 
2597
  m = match_etag (&tag_e_async, &dt->asynchronous);
2598
  if (m != MATCH_NO)
2599
    return m;
2600
  m = match_etag (&tag_e_blank, &dt->blank);
2601
  if (m != MATCH_NO)
2602
    return m;
2603
  m = match_etag (&tag_e_delim, &dt->delim);
2604
  if (m != MATCH_NO)
2605
    return m;
2606
  m = match_etag (&tag_e_pad, &dt->pad);
2607
  if (m != MATCH_NO)
2608
    return m;
2609
  m = match_etag (&tag_e_sign, &dt->sign);
2610
  if (m != MATCH_NO)
2611
    return m;
2612
  m = match_etag (&tag_e_round, &dt->round);
2613
  if (m != MATCH_NO)
2614
    return m;
2615
  m = match_out_tag (&tag_id, &dt->id);
2616
  if (m != MATCH_NO)
2617
    return m;
2618
  m = match_etag (&tag_e_decimal, &dt->decimal);
2619
  if (m != MATCH_NO)
2620
    return m;
2621
  m = match_etag (&tag_rec, &dt->rec);
2622
  if (m != MATCH_NO)
2623
    return m;
2624
  m = match_etag (&tag_spos, &dt->pos);
2625
  if (m != MATCH_NO)
2626
    return m;
2627
  m = match_out_tag (&tag_iomsg, &dt->iomsg);
2628
  if (m != MATCH_NO)
2629
    return m;
2630
  m = match_out_tag (&tag_iostat, &dt->iostat);
2631
  if (m != MATCH_NO)
2632
    return m;
2633
  m = match_ltag (&tag_err, &dt->err);
2634
  if (m == MATCH_YES)
2635
    dt->err_where = gfc_current_locus;
2636
  if (m != MATCH_NO)
2637
    return m;
2638
  m = match_etag (&tag_advance, &dt->advance);
2639
  if (m != MATCH_NO)
2640
    return m;
2641
  m = match_out_tag (&tag_size, &dt->size);
2642
  if (m != MATCH_NO)
2643
    return m;
2644
 
2645
  m = match_ltag (&tag_end, &dt->end);
2646
  if (m == MATCH_YES)
2647
    {
2648
      if (k == M_WRITE)
2649
       {
2650
         gfc_error ("END tag at %C not allowed in output statement");
2651
         return MATCH_ERROR;
2652
       }
2653
      dt->end_where = gfc_current_locus;
2654
    }
2655
  if (m != MATCH_NO)
2656
    return m;
2657
 
2658
  m = match_ltag (&tag_eor, &dt->eor);
2659
  if (m == MATCH_YES)
2660
    dt->eor_where = gfc_current_locus;
2661
  if (m != MATCH_NO)
2662
    return m;
2663
 
2664
  return MATCH_NO;
2665
}
2666
 
2667
 
2668
/* Free a data transfer structure and everything below it.  */
2669
 
2670
void
2671
gfc_free_dt (gfc_dt *dt)
2672
{
2673
  if (dt == NULL)
2674
    return;
2675
 
2676
  gfc_free_expr (dt->io_unit);
2677
  gfc_free_expr (dt->format_expr);
2678
  gfc_free_expr (dt->rec);
2679
  gfc_free_expr (dt->advance);
2680
  gfc_free_expr (dt->iomsg);
2681
  gfc_free_expr (dt->iostat);
2682
  gfc_free_expr (dt->size);
2683
  gfc_free_expr (dt->pad);
2684
  gfc_free_expr (dt->delim);
2685
  gfc_free_expr (dt->sign);
2686
  gfc_free_expr (dt->round);
2687
  gfc_free_expr (dt->blank);
2688
  gfc_free_expr (dt->decimal);
2689
  gfc_free_expr (dt->extra_comma);
2690
  gfc_free_expr (dt->pos);
2691
  gfc_free (dt);
2692
}
2693
 
2694
 
2695
/* Resolve everything in a gfc_dt structure.  */
2696
 
2697
gfc_try
2698
gfc_resolve_dt (gfc_dt *dt, locus *loc)
2699
{
2700
  gfc_expr *e;
2701
 
2702
  RESOLVE_TAG (&tag_format, dt->format_expr);
2703
  RESOLVE_TAG (&tag_rec, dt->rec);
2704
  RESOLVE_TAG (&tag_spos, dt->pos);
2705
  RESOLVE_TAG (&tag_advance, dt->advance);
2706
  RESOLVE_TAG (&tag_id, dt->id);
2707
  RESOLVE_TAG (&tag_iomsg, dt->iomsg);
2708
  RESOLVE_TAG (&tag_iostat, dt->iostat);
2709
  RESOLVE_TAG (&tag_size, dt->size);
2710
  RESOLVE_TAG (&tag_e_pad, dt->pad);
2711
  RESOLVE_TAG (&tag_e_delim, dt->delim);
2712
  RESOLVE_TAG (&tag_e_sign, dt->sign);
2713
  RESOLVE_TAG (&tag_e_round, dt->round);
2714
  RESOLVE_TAG (&tag_e_blank, dt->blank);
2715
  RESOLVE_TAG (&tag_e_decimal, dt->decimal);
2716
  RESOLVE_TAG (&tag_e_async, dt->asynchronous);
2717
 
2718
  e = dt->io_unit;
2719
  if (e == NULL)
2720
    {
2721
      gfc_error ("UNIT not specified at %L", loc);
2722
      return FAILURE;
2723
    }
2724
 
2725
  if (gfc_resolve_expr (e) == SUCCESS
2726
      && (e->ts.type != BT_INTEGER
2727
          && (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_VARIABLE)))
2728
    {
2729
      /* If there is no extra comma signifying the "format" form of the IO
2730
         statement, then this must be an error.  */
2731
      if (!dt->extra_comma)
2732
        {
2733
          gfc_error ("UNIT specification at %L must be an INTEGER expression "
2734
                     "or a CHARACTER variable", &e->where);
2735
          return FAILURE;
2736
        }
2737
      else
2738
        {
2739
          /* At this point, we have an extra comma.  If io_unit has arrived as
2740
             type character, we assume its really the "format" form of the I/O
2741
             statement.  We set the io_unit to the default unit and format to
2742
             the character expression.  See F95 Standard section 9.4.  */
2743
          io_kind k;
2744
          k = dt->extra_comma->value.iokind;
2745
          if (e->ts.type == BT_CHARACTER && (k == M_READ || k == M_PRINT))
2746
            {
2747
              dt->format_expr = dt->io_unit;
2748
              dt->io_unit = default_unit (k);
2749
 
2750
              /* Free this pointer now so that a warning/error is not triggered
2751
                 below for the "Extension".  */
2752
              gfc_free_expr (dt->extra_comma);
2753
              dt->extra_comma = NULL;
2754
            }
2755
 
2756
          if (k == M_WRITE)
2757
            {
2758
              gfc_error ("Invalid form of WRITE statement at %L, UNIT required",
2759
                         &dt->extra_comma->where);
2760
              return FAILURE;
2761
            }
2762
        }
2763
    }
2764
 
2765
  if (e->ts.type == BT_CHARACTER)
2766
    {
2767
      if (gfc_has_vector_index (e))
2768
        {
2769
          gfc_error ("Internal unit with vector subscript at %L", &e->where);
2770
          return FAILURE;
2771
        }
2772
    }
2773
 
2774
  if (e->rank && e->ts.type != BT_CHARACTER)
2775
    {
2776
      gfc_error ("External IO UNIT cannot be an array at %L", &e->where);
2777
      return FAILURE;
2778
    }
2779
 
2780
  if (e->expr_type == EXPR_CONSTANT && e->ts.type == BT_INTEGER
2781
      && mpz_sgn (e->value.integer) < 0)
2782
    {
2783
      gfc_error ("UNIT number in statement at %L must be non-negative", &e->where);
2784
      return FAILURE;
2785
    }
2786
 
2787
  if (dt->extra_comma
2788
      && gfc_notify_std (GFC_STD_GNU, "Extension: Comma before i/o "
2789
                         "item list at %L", &dt->extra_comma->where) == FAILURE)
2790
    return FAILURE;
2791
 
2792
  if (dt->err)
2793
    {
2794
      if (gfc_reference_st_label (dt->err, ST_LABEL_TARGET) == FAILURE)
2795
        return FAILURE;
2796
      if (dt->err->defined == ST_LABEL_UNKNOWN)
2797
        {
2798
          gfc_error ("ERR tag label %d at %L not defined",
2799
                      dt->err->value, &dt->err_where);
2800
          return FAILURE;
2801
        }
2802
    }
2803
 
2804
  if (dt->end)
2805
    {
2806
      if (gfc_reference_st_label (dt->end, ST_LABEL_TARGET) == FAILURE)
2807
        return FAILURE;
2808
      if (dt->end->defined == ST_LABEL_UNKNOWN)
2809
        {
2810
          gfc_error ("END tag label %d at %L not defined",
2811
                      dt->end->value, &dt->end_where);
2812
          return FAILURE;
2813
        }
2814
    }
2815
 
2816
  if (dt->eor)
2817
    {
2818
      if (gfc_reference_st_label (dt->eor, ST_LABEL_TARGET) == FAILURE)
2819
        return FAILURE;
2820
      if (dt->eor->defined == ST_LABEL_UNKNOWN)
2821
        {
2822
          gfc_error ("EOR tag label %d at %L not defined",
2823
                      dt->eor->value, &dt->eor_where);
2824
          return FAILURE;
2825
        }
2826
    }
2827
 
2828
  /* Check the format label actually exists.  */
2829
  if (dt->format_label && dt->format_label != &format_asterisk
2830
      && dt->format_label->defined == ST_LABEL_UNKNOWN)
2831
    {
2832
      gfc_error ("FORMAT label %d at %L not defined", dt->format_label->value,
2833
                 &dt->format_label->where);
2834
      return FAILURE;
2835
    }
2836
  return SUCCESS;
2837
}
2838
 
2839
 
2840
/* Given an io_kind, return its name.  */
2841
 
2842
static const char *
2843
io_kind_name (io_kind k)
2844
{
2845
  const char *name;
2846
 
2847
  switch (k)
2848
    {
2849
    case M_READ:
2850
      name = "READ";
2851
      break;
2852
    case M_WRITE:
2853
      name = "WRITE";
2854
      break;
2855
    case M_PRINT:
2856
      name = "PRINT";
2857
      break;
2858
    case M_INQUIRE:
2859
      name = "INQUIRE";
2860
      break;
2861
    default:
2862
      gfc_internal_error ("io_kind_name(): bad I/O-kind");
2863
    }
2864
 
2865
  return name;
2866
}
2867
 
2868
 
2869
/* Match an IO iteration statement of the form:
2870
 
2871
   ( [<IO element> ,] <IO element>, I = <expr>, <expr> [, <expr> ] )
2872
 
2873
   which is equivalent to a single IO element.  This function is
2874
   mutually recursive with match_io_element().  */
2875
 
2876
static match match_io_element (io_kind, gfc_code **);
2877
 
2878
static match
2879
match_io_iterator (io_kind k, gfc_code **result)
2880
{
2881
  gfc_code *head, *tail, *new_code;
2882
  gfc_iterator *iter;
2883
  locus old_loc;
2884
  match m;
2885
  int n;
2886
 
2887
  iter = NULL;
2888
  head = NULL;
2889
  old_loc = gfc_current_locus;
2890
 
2891
  if (gfc_match_char ('(') != MATCH_YES)
2892
    return MATCH_NO;
2893
 
2894
  m = match_io_element (k, &head);
2895
  tail = head;
2896
 
2897
  if (m != MATCH_YES || gfc_match_char (',') != MATCH_YES)
2898
    {
2899
      m = MATCH_NO;
2900
      goto cleanup;
2901
    }
2902
 
2903
  /* Can't be anything but an IO iterator.  Build a list.  */
2904
  iter = gfc_get_iterator ();
2905
 
2906
  for (n = 1;; n++)
2907
    {
2908
      m = gfc_match_iterator (iter, 0);
2909
      if (m == MATCH_ERROR)
2910
        goto cleanup;
2911
      if (m == MATCH_YES)
2912
        {
2913
          gfc_check_do_variable (iter->var->symtree);
2914
          break;
2915
        }
2916
 
2917
      m = match_io_element (k, &new_code);
2918
      if (m == MATCH_ERROR)
2919
        goto cleanup;
2920
      if (m == MATCH_NO)
2921
        {
2922
          if (n > 2)
2923
            goto syntax;
2924
          goto cleanup;
2925
        }
2926
 
2927
      tail = gfc_append_code (tail, new_code);
2928
 
2929
      if (gfc_match_char (',') != MATCH_YES)
2930
        {
2931
          if (n > 2)
2932
            goto syntax;
2933
          m = MATCH_NO;
2934
          goto cleanup;
2935
        }
2936
    }
2937
 
2938
  if (gfc_match_char (')') != MATCH_YES)
2939
    goto syntax;
2940
 
2941
  new_code = gfc_get_code ();
2942
  new_code->op = EXEC_DO;
2943
  new_code->ext.iterator = iter;
2944
 
2945
  new_code->block = gfc_get_code ();
2946
  new_code->block->op = EXEC_DO;
2947
  new_code->block->next = head;
2948
 
2949
  *result = new_code;
2950
  return MATCH_YES;
2951
 
2952
syntax:
2953
  gfc_error ("Syntax error in I/O iterator at %C");
2954
  m = MATCH_ERROR;
2955
 
2956
cleanup:
2957
  gfc_free_iterator (iter, 1);
2958
  gfc_free_statements (head);
2959
  gfc_current_locus = old_loc;
2960
  return m;
2961
}
2962
 
2963
 
2964
/* Match a single element of an IO list, which is either a single
2965
   expression or an IO Iterator.  */
2966
 
2967
static match
2968
match_io_element (io_kind k, gfc_code **cpp)
2969
{
2970
  gfc_expr *expr;
2971
  gfc_code *cp;
2972
  match m;
2973
 
2974
  expr = NULL;
2975
 
2976
  m = match_io_iterator (k, cpp);
2977
  if (m == MATCH_YES)
2978
    return MATCH_YES;
2979
 
2980
  if (k == M_READ)
2981
    {
2982
      m = gfc_match_variable (&expr, 0);
2983
      if (m == MATCH_NO)
2984
        gfc_error ("Expected variable in READ statement at %C");
2985
    }
2986
  else
2987
    {
2988
      m = gfc_match_expr (&expr);
2989
      if (m == MATCH_NO)
2990
        gfc_error ("Expected expression in %s statement at %C",
2991
                   io_kind_name (k));
2992
    }
2993
 
2994
  if (m == MATCH_YES)
2995
    switch (k)
2996
      {
2997
      case M_READ:
2998
        if (expr->symtree->n.sym->attr.intent == INTENT_IN)
2999
          {
3000
            gfc_error ("Variable '%s' in input list at %C cannot be "
3001
                       "INTENT(IN)", expr->symtree->n.sym->name);
3002
            m = MATCH_ERROR;
3003
          }
3004
 
3005
        if (gfc_pure (NULL)
3006
            && gfc_impure_variable (expr->symtree->n.sym)
3007
            && current_dt->io_unit
3008
            && current_dt->io_unit->ts.type == BT_CHARACTER)
3009
          {
3010
            gfc_error ("Cannot read to variable '%s' in PURE procedure at %C",
3011
                       expr->symtree->n.sym->name);
3012
            m = MATCH_ERROR;
3013
          }
3014
 
3015
        if (gfc_check_do_variable (expr->symtree))
3016
          m = MATCH_ERROR;
3017
 
3018
        break;
3019
 
3020
      case M_WRITE:
3021
        if (current_dt->io_unit
3022
            && current_dt->io_unit->ts.type == BT_CHARACTER
3023
            && gfc_pure (NULL)
3024
            && current_dt->io_unit->expr_type == EXPR_VARIABLE
3025
            && gfc_impure_variable (current_dt->io_unit->symtree->n.sym))
3026
          {
3027
            gfc_error ("Cannot write to internal file unit '%s' at %C "
3028
                       "inside a PURE procedure",
3029
                       current_dt->io_unit->symtree->n.sym->name);
3030
            m = MATCH_ERROR;
3031
          }
3032
 
3033
        break;
3034
 
3035
      default:
3036
        break;
3037
      }
3038
 
3039
  if (m != MATCH_YES)
3040
    {
3041
      gfc_free_expr (expr);
3042
      return MATCH_ERROR;
3043
    }
3044
 
3045
  cp = gfc_get_code ();
3046
  cp->op = EXEC_TRANSFER;
3047
  cp->expr1 = expr;
3048
 
3049
  *cpp = cp;
3050
  return MATCH_YES;
3051
}
3052
 
3053
 
3054
/* Match an I/O list, building gfc_code structures as we go.  */
3055
 
3056
static match
3057
match_io_list (io_kind k, gfc_code **head_p)
3058
{
3059
  gfc_code *head, *tail, *new_code;
3060
  match m;
3061
 
3062
  *head_p = head = tail = NULL;
3063
  if (gfc_match_eos () == MATCH_YES)
3064
    return MATCH_YES;
3065
 
3066
  for (;;)
3067
    {
3068
      m = match_io_element (k, &new_code);
3069
      if (m == MATCH_ERROR)
3070
        goto cleanup;
3071
      if (m == MATCH_NO)
3072
        goto syntax;
3073
 
3074
      tail = gfc_append_code (tail, new_code);
3075
      if (head == NULL)
3076
        head = new_code;
3077
 
3078
      if (gfc_match_eos () == MATCH_YES)
3079
        break;
3080
      if (gfc_match_char (',') != MATCH_YES)
3081
        goto syntax;
3082
    }
3083
 
3084
  *head_p = head;
3085
  return MATCH_YES;
3086
 
3087
syntax:
3088
  gfc_error ("Syntax error in %s statement at %C", io_kind_name (k));
3089
 
3090
cleanup:
3091
  gfc_free_statements (head);
3092
  return MATCH_ERROR;
3093
}
3094
 
3095
 
3096
/* Attach the data transfer end node.  */
3097
 
3098
static void
3099
terminate_io (gfc_code *io_code)
3100
{
3101
  gfc_code *c;
3102
 
3103
  if (io_code == NULL)
3104
    io_code = new_st.block;
3105
 
3106
  c = gfc_get_code ();
3107
  c->op = EXEC_DT_END;
3108
 
3109
  /* Point to structure that is already there */
3110
  c->ext.dt = new_st.ext.dt;
3111
  gfc_append_code (io_code, c);
3112
}
3113
 
3114
 
3115
/* Check the constraints for a data transfer statement.  The majority of the
3116
   constraints appearing in 9.4 of the standard appear here.  Some are handled
3117
   in resolve_tag and others in gfc_resolve_dt.  */
3118
 
3119
static match
3120
check_io_constraints (io_kind k, gfc_dt *dt, gfc_code *io_code,
3121
                      locus *spec_end)
3122
{
3123
#define io_constraint(condition,msg,arg)\
3124
if (condition) \
3125
  {\
3126
    gfc_error(msg,arg);\
3127
    m = MATCH_ERROR;\
3128
  }
3129
 
3130
  match m;
3131
  gfc_expr *expr;
3132
  gfc_symbol *sym = NULL;
3133
  bool warn, unformatted;
3134
 
3135
  warn = (dt->err || dt->iostat) ? true : false;
3136
  unformatted = dt->format_expr == NULL && dt->format_label == NULL
3137
                && dt->namelist == NULL;
3138
 
3139
  m = MATCH_YES;
3140
 
3141
  expr = dt->io_unit;
3142
  if (expr && expr->expr_type == EXPR_VARIABLE
3143
      && expr->ts.type == BT_CHARACTER)
3144
    {
3145
      sym = expr->symtree->n.sym;
3146
 
3147
      io_constraint (k == M_WRITE && sym->attr.intent == INTENT_IN,
3148
                     "Internal file at %L must not be INTENT(IN)",
3149
                     &expr->where);
3150
 
3151
      io_constraint (gfc_has_vector_index (dt->io_unit),
3152
                     "Internal file incompatible with vector subscript at %L",
3153
                     &expr->where);
3154
 
3155
      io_constraint (dt->rec != NULL,
3156
                     "REC tag at %L is incompatible with internal file",
3157
                     &dt->rec->where);
3158
 
3159
      io_constraint (dt->pos != NULL,
3160
                     "POS tag at %L is incompatible with internal file",
3161
                     &dt->pos->where);
3162
 
3163
      io_constraint (unformatted,
3164
                     "Unformatted I/O not allowed with internal unit at %L",
3165
                     &dt->io_unit->where);
3166
 
3167
      io_constraint (dt->asynchronous != NULL,
3168
                     "ASYNCHRONOUS tag at %L not allowed with internal file",
3169
                     &dt->asynchronous->where);
3170
 
3171
      if (dt->namelist != NULL)
3172
        {
3173
          if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Internal file "
3174
                              "at %L with namelist", &expr->where)
3175
              == FAILURE)
3176
            m = MATCH_ERROR;
3177
        }
3178
 
3179
      io_constraint (dt->advance != NULL,
3180
                     "ADVANCE tag at %L is incompatible with internal file",
3181
                     &dt->advance->where);
3182
    }
3183
 
3184
  if (expr && expr->ts.type != BT_CHARACTER)
3185
    {
3186
 
3187
      io_constraint (gfc_pure (NULL) && (k == M_READ || k == M_WRITE),
3188
                     "IO UNIT in %s statement at %C must be "
3189
                     "an internal file in a PURE procedure",
3190
                     io_kind_name (k));
3191
    }
3192
 
3193
  if (k != M_READ)
3194
    {
3195
      io_constraint (dt->end, "END tag not allowed with output at %L",
3196
                     &dt->end_where);
3197
 
3198
      io_constraint (dt->eor, "EOR tag not allowed with output at %L",
3199
                     &dt->eor_where);
3200
 
3201
      io_constraint (dt->blank, "BLANK= specifier not allowed with output at %L",
3202
                     &dt->blank->where);
3203
 
3204
      io_constraint (dt->pad, "PAD= specifier not allowed with output at %L",
3205
                     &dt->pad->where);
3206
 
3207
      io_constraint (dt->size, "SIZE= specifier not allowed with output at %L",
3208
                     &dt->size->where);
3209
    }
3210
  else
3211
    {
3212
      io_constraint (dt->size && dt->advance == NULL,
3213
                     "SIZE tag at %L requires an ADVANCE tag",
3214
                     &dt->size->where);
3215
 
3216
      io_constraint (dt->eor && dt->advance == NULL,
3217
                     "EOR tag at %L requires an ADVANCE tag",
3218
                     &dt->eor_where);
3219
    }
3220
 
3221
  if (dt->asynchronous)
3222
    {
3223
      static const char * asynchronous[] = { "YES", "NO", NULL };
3224
 
3225
      if (gfc_reduce_init_expr (dt->asynchronous) != SUCCESS)
3226
        {
3227
          gfc_error ("ASYNCHRONOUS= specifier at %L must be an initialization "
3228
                     "expression", &dt->asynchronous->where);
3229
          return MATCH_ERROR;
3230
        }
3231
 
3232
      if (!compare_to_allowed_values
3233
                ("ASYNCHRONOUS", asynchronous, NULL, NULL,
3234
                 dt->asynchronous->value.character.string,
3235
                 io_kind_name (k), warn))
3236
        return MATCH_ERROR;
3237
    }
3238
 
3239
  if (dt->id)
3240
    {
3241
      bool not_yes
3242
        = !dt->asynchronous
3243
          || gfc_wide_strlen (dt->asynchronous->value.character.string) != 3
3244
          || gfc_wide_strncasecmp (dt->asynchronous->value.character.string,
3245
                                   "yes", 3) != 0;
3246
      io_constraint (not_yes,
3247
                     "ID= specifier at %L must be with ASYNCHRONOUS='yes' "
3248
                     "specifier", &dt->id->where);
3249
    }
3250
 
3251
  if (dt->decimal)
3252
    {
3253
      if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DECIMAL= at %C "
3254
          "not allowed in Fortran 95") == FAILURE)
3255
        return MATCH_ERROR;
3256
 
3257
      if (dt->decimal->expr_type == EXPR_CONSTANT)
3258
        {
3259
          static const char * decimal[] = { "COMMA", "POINT", NULL };
3260
 
3261
          if (!compare_to_allowed_values ("DECIMAL", decimal, NULL, NULL,
3262
                                          dt->decimal->value.character.string,
3263
                                          io_kind_name (k), warn))
3264
            return MATCH_ERROR;
3265
 
3266
          io_constraint (unformatted,
3267
                         "the DECIMAL= specifier at %L must be with an "
3268
                         "explicit format expression", &dt->decimal->where);
3269
        }
3270
    }
3271
 
3272
  if (dt->blank)
3273
    {
3274
      if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: BLANK= at %C "
3275
          "not allowed in Fortran 95") == FAILURE)
3276
        return MATCH_ERROR;
3277
 
3278
      if (dt->blank->expr_type == EXPR_CONSTANT)
3279
        {
3280
          static const char * blank[] = { "NULL", "ZERO", NULL };
3281
 
3282
          if (!compare_to_allowed_values ("BLANK", blank, NULL, NULL,
3283
                                          dt->blank->value.character.string,
3284
                                          io_kind_name (k), warn))
3285
            return MATCH_ERROR;
3286
 
3287
          io_constraint (unformatted,
3288
                         "the BLANK= specifier at %L must be with an "
3289
                         "explicit format expression", &dt->blank->where);
3290
        }
3291
    }
3292
 
3293
  if (dt->pad)
3294
    {
3295
      if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PAD= at %C "
3296
          "not allowed in Fortran 95") == FAILURE)
3297
        return MATCH_ERROR;
3298
 
3299
      if (dt->pad->expr_type == EXPR_CONSTANT)
3300
        {
3301
          static const char * pad[] = { "YES", "NO", NULL };
3302
 
3303
          if (!compare_to_allowed_values ("PAD", pad, NULL, NULL,
3304
                                          dt->pad->value.character.string,
3305
                                          io_kind_name (k), warn))
3306
            return MATCH_ERROR;
3307
 
3308
          io_constraint (unformatted,
3309
                         "the PAD= specifier at %L must be with an "
3310
                         "explicit format expression", &dt->pad->where);
3311
        }
3312
    }
3313
 
3314
  if (dt->round)
3315
    {
3316
      if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ROUND= at %C "
3317
          "not allowed in Fortran 95") == FAILURE)
3318
        return MATCH_ERROR;
3319
 
3320
      if (dt->round->expr_type == EXPR_CONSTANT)
3321
        {
3322
          static const char * round[] = { "UP", "DOWN", "ZERO", "NEAREST",
3323
                                          "COMPATIBLE", "PROCESSOR_DEFINED",
3324
                                          NULL };
3325
 
3326
          if (!compare_to_allowed_values ("ROUND", round, NULL, NULL,
3327
                                          dt->round->value.character.string,
3328
                                          io_kind_name (k), warn))
3329
            return MATCH_ERROR;
3330
        }
3331
    }
3332
 
3333
  if (dt->sign)
3334
    {
3335
      /* When implemented, change the following to use gfc_notify_std F2003.
3336
      if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: SIGN= at %C "
3337
          "not allowed in Fortran 95") == FAILURE)
3338
        return MATCH_ERROR;  */
3339
      if (dt->sign->expr_type == EXPR_CONSTANT)
3340
        {
3341
          static const char * sign[] = { "PLUS", "SUPPRESS", "PROCESSOR_DEFINED",
3342
                                         NULL };
3343
 
3344
          if (!compare_to_allowed_values ("SIGN", sign, NULL, NULL,
3345
                                      dt->sign->value.character.string,
3346
                                      io_kind_name (k), warn))
3347
            return MATCH_ERROR;
3348
 
3349
          io_constraint (unformatted,
3350
                         "SIGN= specifier at %L must be with an "
3351
                         "explicit format expression", &dt->sign->where);
3352
 
3353
          io_constraint (k == M_READ,
3354
                         "SIGN= specifier at %L not allowed in a "
3355
                         "READ statement", &dt->sign->where);
3356
        }
3357
    }
3358
 
3359
  if (dt->delim)
3360
    {
3361
      if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DELIM= at %C "
3362
          "not allowed in Fortran 95") == FAILURE)
3363
        return MATCH_ERROR;
3364
 
3365
      if (dt->delim->expr_type == EXPR_CONSTANT)
3366
        {
3367
          static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL };
3368
 
3369
          if (!compare_to_allowed_values ("DELIM", delim, NULL, NULL,
3370
                                          dt->delim->value.character.string,
3371
                                          io_kind_name (k), warn))
3372
            return MATCH_ERROR;
3373
 
3374
          io_constraint (k == M_READ,
3375
                         "DELIM= specifier at %L not allowed in a "
3376
                         "READ statement", &dt->delim->where);
3377
 
3378
          io_constraint (dt->format_label != &format_asterisk
3379
                         && dt->namelist == NULL,
3380
                         "DELIM= specifier at %L must have FMT=*",
3381
                         &dt->delim->where);
3382
 
3383
          io_constraint (unformatted && dt->namelist == NULL,
3384
                         "DELIM= specifier at %L must be with FMT=* or "
3385
                         "NML= specifier ", &dt->delim->where);
3386
        }
3387
    }
3388
 
3389
  if (dt->namelist)
3390
    {
3391
      io_constraint (io_code && dt->namelist,
3392
                     "NAMELIST cannot be followed by IO-list at %L",
3393
                     &io_code->loc);
3394
 
3395
      io_constraint (dt->format_expr,
3396
                     "IO spec-list cannot contain both NAMELIST group name "
3397
                     "and format specification at %L",
3398
                     &dt->format_expr->where);
3399
 
3400
      io_constraint (dt->format_label,
3401
                     "IO spec-list cannot contain both NAMELIST group name "
3402
                     "and format label at %L", spec_end);
3403
 
3404
      io_constraint (dt->rec,
3405
                     "NAMELIST IO is not allowed with a REC= specifier "
3406
                     "at %L", &dt->rec->where);
3407
 
3408
      io_constraint (dt->advance,
3409
                     "NAMELIST IO is not allowed with a ADVANCE= specifier "
3410
                     "at %L", &dt->advance->where);
3411
    }
3412
 
3413
  if (dt->rec)
3414
    {
3415
      io_constraint (dt->end,
3416
                     "An END tag is not allowed with a "
3417
                     "REC= specifier at %L", &dt->end_where);
3418
 
3419
      io_constraint (dt->format_label == &format_asterisk,
3420
                     "FMT=* is not allowed with a REC= specifier "
3421
                     "at %L", spec_end);
3422
 
3423
      io_constraint (dt->pos,
3424
                     "POS= is not allowed with REC= specifier "
3425
                     "at %L", &dt->pos->where);
3426
    }
3427
 
3428
  if (dt->advance)
3429
    {
3430
      int not_yes, not_no;
3431
      expr = dt->advance;
3432
 
3433
      io_constraint (dt->format_label == &format_asterisk,
3434
                     "List directed format(*) is not allowed with a "
3435
                     "ADVANCE= specifier at %L.", &expr->where);
3436
 
3437
      io_constraint (unformatted,
3438
                     "the ADVANCE= specifier at %L must appear with an "
3439
                     "explicit format expression", &expr->where);
3440
 
3441
      if (expr->expr_type == EXPR_CONSTANT && expr->ts.type == BT_CHARACTER)
3442
        {
3443
          const gfc_char_t *advance = expr->value.character.string;
3444
          not_no = gfc_wide_strlen (advance) != 2
3445
                   || gfc_wide_strncasecmp (advance, "no", 2) != 0;
3446
          not_yes = gfc_wide_strlen (advance) != 3
3447
                    || gfc_wide_strncasecmp (advance, "yes", 3) != 0;
3448
        }
3449
      else
3450
        {
3451
          not_no = 0;
3452
          not_yes = 0;
3453
        }
3454
 
3455
      io_constraint (not_no && not_yes,
3456
                     "ADVANCE= specifier at %L must have value = "
3457
                     "YES or NO.", &expr->where);
3458
 
3459
      io_constraint (dt->size && not_no && k == M_READ,
3460
                     "SIZE tag at %L requires an ADVANCE = 'NO'",
3461
                     &dt->size->where);
3462
 
3463
      io_constraint (dt->eor && not_no && k == M_READ,
3464
                     "EOR tag at %L requires an ADVANCE = 'NO'",
3465
                     &dt->eor_where);
3466
    }
3467
 
3468
  expr = dt->format_expr;
3469
  if (gfc_simplify_expr (expr, 0) == FAILURE
3470
      || check_format_string (expr, k == M_READ) == FAILURE)
3471
    return MATCH_ERROR;
3472
 
3473
  return m;
3474
}
3475
#undef io_constraint
3476
 
3477
 
3478
/* Match a READ, WRITE or PRINT statement.  */
3479
 
3480
static match
3481
match_io (io_kind k)
3482
{
3483
  char name[GFC_MAX_SYMBOL_LEN + 1];
3484
  gfc_code *io_code;
3485
  gfc_symbol *sym;
3486
  int comma_flag;
3487
  locus where;
3488
  locus spec_end;
3489
  gfc_dt *dt;
3490
  match m;
3491
 
3492
  where = gfc_current_locus;
3493
  comma_flag = 0;
3494
  current_dt = dt = XCNEW (gfc_dt);
3495
  m = gfc_match_char ('(');
3496
  if (m == MATCH_NO)
3497
    {
3498
      where = gfc_current_locus;
3499
      if (k == M_WRITE)
3500
        goto syntax;
3501
      else if (k == M_PRINT)
3502
        {
3503
          /* Treat the non-standard case of PRINT namelist.  */
3504
          if ((gfc_current_form == FORM_FIXED || gfc_peek_ascii_char () == ' ')
3505
              && gfc_match_name (name) == MATCH_YES)
3506
            {
3507
              gfc_find_symbol (name, NULL, 1, &sym);
3508
              if (sym && sym->attr.flavor == FL_NAMELIST)
3509
                {
3510
                  if (gfc_notify_std (GFC_STD_GNU, "PRINT namelist at "
3511
                                      "%C is an extension") == FAILURE)
3512
                    {
3513
                      m = MATCH_ERROR;
3514
                      goto cleanup;
3515
                    }
3516
 
3517
                  dt->io_unit = default_unit (k);
3518
                  dt->namelist = sym;
3519
                  goto get_io_list;
3520
                }
3521
              else
3522
                gfc_current_locus = where;
3523
            }
3524
        }
3525
 
3526
      if (gfc_current_form == FORM_FREE)
3527
        {
3528
          char c = gfc_peek_ascii_char ();
3529
          if (c != ' ' && c != '*' && c != '\'' && c != '"')
3530
            {
3531
              m = MATCH_NO;
3532
              goto cleanup;
3533
            }
3534
        }
3535
 
3536
      m = match_dt_format (dt);
3537
      if (m == MATCH_ERROR)
3538
        goto cleanup;
3539
      if (m == MATCH_NO)
3540
        goto syntax;
3541
 
3542
      comma_flag = 1;
3543
      dt->io_unit = default_unit (k);
3544
      goto get_io_list;
3545
    }
3546
  else
3547
    {
3548
      /* Before issuing an error for a malformed 'print (1,*)' type of
3549
         error, check for a default-char-expr of the form ('(I0)').  */
3550
      if (k == M_PRINT && m == MATCH_YES)
3551
        {
3552
          /* Reset current locus to get the initial '(' in an expression.  */
3553
          gfc_current_locus = where;
3554
          dt->format_expr = NULL;
3555
          m = match_dt_format (dt);
3556
 
3557
          if (m == MATCH_ERROR)
3558
            goto cleanup;
3559
          if (m == MATCH_NO || dt->format_expr == NULL)
3560
            goto syntax;
3561
 
3562
          comma_flag = 1;
3563
          dt->io_unit = default_unit (k);
3564
          goto get_io_list;
3565
        }
3566
    }
3567
 
3568
  /* Match a control list */
3569
  if (match_dt_element (k, dt) == MATCH_YES)
3570
    goto next;
3571
  if (match_dt_unit (k, dt) != MATCH_YES)
3572
    goto loop;
3573
 
3574
  if (gfc_match_char (')') == MATCH_YES)
3575
    goto get_io_list;
3576
  if (gfc_match_char (',') != MATCH_YES)
3577
    goto syntax;
3578
 
3579
  m = match_dt_element (k, dt);
3580
  if (m == MATCH_YES)
3581
    goto next;
3582
  if (m == MATCH_ERROR)
3583
    goto cleanup;
3584
 
3585
  m = match_dt_format (dt);
3586
  if (m == MATCH_YES)
3587
    goto next;
3588
  if (m == MATCH_ERROR)
3589
    goto cleanup;
3590
 
3591
  where = gfc_current_locus;
3592
 
3593
  m = gfc_match_name (name);
3594
  if (m == MATCH_YES)
3595
    {
3596
      gfc_find_symbol (name, NULL, 1, &sym);
3597
      if (sym && sym->attr.flavor == FL_NAMELIST)
3598
        {
3599
          dt->namelist = sym;
3600
          if (k == M_READ && check_namelist (sym))
3601
            {
3602
              m = MATCH_ERROR;
3603
              goto cleanup;
3604
            }
3605
          goto next;
3606
        }
3607
    }
3608
 
3609
  gfc_current_locus = where;
3610
 
3611
  goto loop;                    /* No matches, try regular elements */
3612
 
3613
next:
3614
  if (gfc_match_char (')') == MATCH_YES)
3615
    goto get_io_list;
3616
  if (gfc_match_char (',') != MATCH_YES)
3617
    goto syntax;
3618
 
3619
loop:
3620
  for (;;)
3621
    {
3622
      m = match_dt_element (k, dt);
3623
      if (m == MATCH_NO)
3624
        goto syntax;
3625
      if (m == MATCH_ERROR)
3626
        goto cleanup;
3627
 
3628
      if (gfc_match_char (')') == MATCH_YES)
3629
        break;
3630
      if (gfc_match_char (',') != MATCH_YES)
3631
        goto syntax;
3632
    }
3633
 
3634
get_io_list:
3635
 
3636
  /* Used in check_io_constraints, where no locus is available.  */
3637
  spec_end = gfc_current_locus;
3638
 
3639
  /* Optional leading comma (non-standard).  We use a gfc_expr structure here
3640
     to save the locus.  This is used later when resolving transfer statements
3641
     that might have a format expression without unit number.  */
3642
  if (!comma_flag && gfc_match_char (',') == MATCH_YES)
3643
    {
3644
      dt->extra_comma = gfc_get_expr ();
3645
 
3646
      /* Set the types to something compatible with iokind. This is needed to
3647
         get through gfc_free_expr later since iokind really has no Basic Type,
3648
         BT, of its own.  */
3649
      dt->extra_comma->expr_type = EXPR_CONSTANT;
3650
      dt->extra_comma->ts.type = BT_LOGICAL;
3651
 
3652
      /* Save the iokind and locus for later use in resolution.  */
3653
      dt->extra_comma->value.iokind = k;
3654
      dt->extra_comma->where = gfc_current_locus;
3655
    }
3656
 
3657
  io_code = NULL;
3658
  if (gfc_match_eos () != MATCH_YES)
3659
    {
3660
      if (comma_flag && gfc_match_char (',') != MATCH_YES)
3661
        {
3662
          gfc_error ("Expected comma in I/O list at %C");
3663
          m = MATCH_ERROR;
3664
          goto cleanup;
3665
        }
3666
 
3667
      m = match_io_list (k, &io_code);
3668
      if (m == MATCH_ERROR)
3669
        goto cleanup;
3670
      if (m == MATCH_NO)
3671
        goto syntax;
3672
    }
3673
 
3674
  /* A full IO statement has been matched.  Check the constraints.  spec_end is
3675
     supplied for cases where no locus is supplied.  */
3676
  m = check_io_constraints (k, dt, io_code, &spec_end);
3677
 
3678
  if (m == MATCH_ERROR)
3679
    goto cleanup;
3680
 
3681
  new_st.op = (k == M_READ) ? EXEC_READ : EXEC_WRITE;
3682
  new_st.ext.dt = dt;
3683
  new_st.block = gfc_get_code ();
3684
  new_st.block->op = new_st.op;
3685
  new_st.block->next = io_code;
3686
 
3687
  terminate_io (io_code);
3688
 
3689
  return MATCH_YES;
3690
 
3691
syntax:
3692
  gfc_error ("Syntax error in %s statement at %C", io_kind_name (k));
3693
  m = MATCH_ERROR;
3694
 
3695
cleanup:
3696
  gfc_free_dt (dt);
3697
  return m;
3698
}
3699
 
3700
 
3701
match
3702
gfc_match_read (void)
3703
{
3704
  return match_io (M_READ);
3705
}
3706
 
3707
 
3708
match
3709
gfc_match_write (void)
3710
{
3711
  return match_io (M_WRITE);
3712
}
3713
 
3714
 
3715
match
3716
gfc_match_print (void)
3717
{
3718
  match m;
3719
 
3720
  m = match_io (M_PRINT);
3721
  if (m != MATCH_YES)
3722
    return m;
3723
 
3724
  if (gfc_pure (NULL))
3725
    {
3726
      gfc_error ("PRINT statement at %C not allowed within PURE procedure");
3727
      return MATCH_ERROR;
3728
    }
3729
 
3730
  return MATCH_YES;
3731
}
3732
 
3733
 
3734
/* Free a gfc_inquire structure.  */
3735
 
3736
void
3737
gfc_free_inquire (gfc_inquire *inquire)
3738
{
3739
 
3740
  if (inquire == NULL)
3741
    return;
3742
 
3743
  gfc_free_expr (inquire->unit);
3744
  gfc_free_expr (inquire->file);
3745
  gfc_free_expr (inquire->iomsg);
3746
  gfc_free_expr (inquire->iostat);
3747
  gfc_free_expr (inquire->exist);
3748
  gfc_free_expr (inquire->opened);
3749
  gfc_free_expr (inquire->number);
3750
  gfc_free_expr (inquire->named);
3751
  gfc_free_expr (inquire->name);
3752
  gfc_free_expr (inquire->access);
3753
  gfc_free_expr (inquire->sequential);
3754
  gfc_free_expr (inquire->direct);
3755
  gfc_free_expr (inquire->form);
3756
  gfc_free_expr (inquire->formatted);
3757
  gfc_free_expr (inquire->unformatted);
3758
  gfc_free_expr (inquire->recl);
3759
  gfc_free_expr (inquire->nextrec);
3760
  gfc_free_expr (inquire->blank);
3761
  gfc_free_expr (inquire->position);
3762
  gfc_free_expr (inquire->action);
3763
  gfc_free_expr (inquire->read);
3764
  gfc_free_expr (inquire->write);
3765
  gfc_free_expr (inquire->readwrite);
3766
  gfc_free_expr (inquire->delim);
3767
  gfc_free_expr (inquire->encoding);
3768
  gfc_free_expr (inquire->pad);
3769
  gfc_free_expr (inquire->iolength);
3770
  gfc_free_expr (inquire->convert);
3771
  gfc_free_expr (inquire->strm_pos);
3772
  gfc_free_expr (inquire->asynchronous);
3773
  gfc_free_expr (inquire->decimal);
3774
  gfc_free_expr (inquire->pending);
3775
  gfc_free_expr (inquire->id);
3776
  gfc_free_expr (inquire->sign);
3777
  gfc_free_expr (inquire->size);
3778
  gfc_free_expr (inquire->round);
3779
  gfc_free (inquire);
3780
}
3781
 
3782
 
3783
/* Match an element of an INQUIRE statement.  */
3784
 
3785
#define RETM   if (m != MATCH_NO) return m;
3786
 
3787
static match
3788
match_inquire_element (gfc_inquire *inquire)
3789
{
3790
  match m;
3791
 
3792
  m = match_etag (&tag_unit, &inquire->unit);
3793
  RETM m = match_etag (&tag_file, &inquire->file);
3794
  RETM m = match_ltag (&tag_err, &inquire->err);
3795
  RETM m = match_out_tag (&tag_iomsg, &inquire->iomsg);
3796
  RETM m = match_out_tag (&tag_iostat, &inquire->iostat);
3797
  RETM m = match_vtag (&tag_exist, &inquire->exist);
3798
  RETM m = match_vtag (&tag_opened, &inquire->opened);
3799
  RETM m = match_vtag (&tag_named, &inquire->named);
3800
  RETM m = match_vtag (&tag_name, &inquire->name);
3801
  RETM m = match_out_tag (&tag_number, &inquire->number);
3802
  RETM m = match_vtag (&tag_s_access, &inquire->access);
3803
  RETM m = match_vtag (&tag_sequential, &inquire->sequential);
3804
  RETM m = match_vtag (&tag_direct, &inquire->direct);
3805
  RETM m = match_vtag (&tag_s_form, &inquire->form);
3806
  RETM m = match_vtag (&tag_formatted, &inquire->formatted);
3807
  RETM m = match_vtag (&tag_unformatted, &inquire->unformatted);
3808
  RETM m = match_out_tag (&tag_s_recl, &inquire->recl);
3809
  RETM m = match_out_tag (&tag_nextrec, &inquire->nextrec);
3810
  RETM m = match_vtag (&tag_s_blank, &inquire->blank);
3811
  RETM m = match_vtag (&tag_s_position, &inquire->position);
3812
  RETM m = match_vtag (&tag_s_action, &inquire->action);
3813
  RETM m = match_vtag (&tag_read, &inquire->read);
3814
  RETM m = match_vtag (&tag_write, &inquire->write);
3815
  RETM m = match_vtag (&tag_readwrite, &inquire->readwrite);
3816
  RETM m = match_vtag (&tag_s_async, &inquire->asynchronous);
3817
  RETM m = match_vtag (&tag_s_delim, &inquire->delim);
3818
  RETM m = match_vtag (&tag_s_decimal, &inquire->decimal);
3819
  RETM m = match_vtag (&tag_size, &inquire->size);
3820
  RETM m = match_vtag (&tag_s_encoding, &inquire->encoding);
3821
  RETM m = match_vtag (&tag_s_round, &inquire->round);
3822
  RETM m = match_vtag (&tag_s_sign, &inquire->sign);
3823
  RETM m = match_vtag (&tag_s_pad, &inquire->pad);
3824
  RETM m = match_vtag (&tag_iolength, &inquire->iolength);
3825
  RETM m = match_vtag (&tag_convert, &inquire->convert);
3826
  RETM m = match_out_tag (&tag_strm_out, &inquire->strm_pos);
3827
  RETM m = match_vtag (&tag_pending, &inquire->pending);
3828
  RETM m = match_vtag (&tag_id, &inquire->id);
3829
  RETM return MATCH_NO;
3830
}
3831
 
3832
#undef RETM
3833
 
3834
 
3835
match
3836
gfc_match_inquire (void)
3837
{
3838
  gfc_inquire *inquire;
3839
  gfc_code *code;
3840
  match m;
3841
  locus loc;
3842
 
3843
  m = gfc_match_char ('(');
3844
  if (m == MATCH_NO)
3845
    return m;
3846
 
3847
  inquire = XCNEW (gfc_inquire);
3848
 
3849
  loc = gfc_current_locus;
3850
 
3851
  m = match_inquire_element (inquire);
3852
  if (m == MATCH_ERROR)
3853
    goto cleanup;
3854
  if (m == MATCH_NO)
3855
    {
3856
      m = gfc_match_expr (&inquire->unit);
3857
      if (m == MATCH_ERROR)
3858
        goto cleanup;
3859
      if (m == MATCH_NO)
3860
        goto syntax;
3861
    }
3862
 
3863
  /* See if we have the IOLENGTH form of the inquire statement.  */
3864
  if (inquire->iolength != NULL)
3865
    {
3866
      if (gfc_match_char (')') != MATCH_YES)
3867
        goto syntax;
3868
 
3869
      m = match_io_list (M_INQUIRE, &code);
3870
      if (m == MATCH_ERROR)
3871
        goto cleanup;
3872
      if (m == MATCH_NO)
3873
        goto syntax;
3874
 
3875
      new_st.op = EXEC_IOLENGTH;
3876
      new_st.expr1 = inquire->iolength;
3877
      new_st.ext.inquire = inquire;
3878
 
3879
      if (gfc_pure (NULL))
3880
        {
3881
          gfc_free_statements (code);
3882
          gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
3883
          return MATCH_ERROR;
3884
        }
3885
 
3886
      new_st.block = gfc_get_code ();
3887
      new_st.block->op = EXEC_IOLENGTH;
3888
      terminate_io (code);
3889
      new_st.block->next = code;
3890
      return MATCH_YES;
3891
    }
3892
 
3893
  /* At this point, we have the non-IOLENGTH inquire statement.  */
3894
  for (;;)
3895
    {
3896
      if (gfc_match_char (')') == MATCH_YES)
3897
        break;
3898
      if (gfc_match_char (',') != MATCH_YES)
3899
        goto syntax;
3900
 
3901
      m = match_inquire_element (inquire);
3902
      if (m == MATCH_ERROR)
3903
        goto cleanup;
3904
      if (m == MATCH_NO)
3905
        goto syntax;
3906
 
3907
      if (inquire->iolength != NULL)
3908
        {
3909
          gfc_error ("IOLENGTH tag invalid in INQUIRE statement at %C");
3910
          goto cleanup;
3911
        }
3912
    }
3913
 
3914
  if (gfc_match_eos () != MATCH_YES)
3915
    goto syntax;
3916
 
3917
  if (inquire->unit != NULL && inquire->file != NULL)
3918
    {
3919
      gfc_error ("INQUIRE statement at %L cannot contain both FILE and "
3920
                 "UNIT specifiers", &loc);
3921
      goto cleanup;
3922
    }
3923
 
3924
  if (inquire->unit == NULL && inquire->file == NULL)
3925
    {
3926
      gfc_error ("INQUIRE statement at %L requires either FILE or "
3927
                 "UNIT specifier", &loc);
3928
      goto cleanup;
3929
    }
3930
 
3931
  if (gfc_pure (NULL))
3932
    {
3933
      gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
3934
      goto cleanup;
3935
    }
3936
 
3937
  if (inquire->id != NULL && inquire->pending == NULL)
3938
    {
3939
      gfc_error ("INQUIRE statement at %L requires a PENDING= specifier with "
3940
                 "the ID= specifier", &loc);
3941
      goto cleanup;
3942
    }
3943
 
3944
  new_st.op = EXEC_INQUIRE;
3945
  new_st.ext.inquire = inquire;
3946
  return MATCH_YES;
3947
 
3948
syntax:
3949
  gfc_syntax_error (ST_INQUIRE);
3950
 
3951
cleanup:
3952
  gfc_free_inquire (inquire);
3953
  return MATCH_ERROR;
3954
}
3955
 
3956
 
3957
/* Resolve everything in a gfc_inquire structure.  */
3958
 
3959
gfc_try
3960
gfc_resolve_inquire (gfc_inquire *inquire)
3961
{
3962
  RESOLVE_TAG (&tag_unit, inquire->unit);
3963
  RESOLVE_TAG (&tag_file, inquire->file);
3964
  RESOLVE_TAG (&tag_iomsg, inquire->iomsg);
3965
  RESOLVE_TAG (&tag_iostat, inquire->iostat);
3966
  RESOLVE_TAG (&tag_exist, inquire->exist);
3967
  RESOLVE_TAG (&tag_opened, inquire->opened);
3968
  RESOLVE_TAG (&tag_number, inquire->number);
3969
  RESOLVE_TAG (&tag_named, inquire->named);
3970
  RESOLVE_TAG (&tag_name, inquire->name);
3971
  RESOLVE_TAG (&tag_s_access, inquire->access);
3972
  RESOLVE_TAG (&tag_sequential, inquire->sequential);
3973
  RESOLVE_TAG (&tag_direct, inquire->direct);
3974
  RESOLVE_TAG (&tag_s_form, inquire->form);
3975
  RESOLVE_TAG (&tag_formatted, inquire->formatted);
3976
  RESOLVE_TAG (&tag_unformatted, inquire->unformatted);
3977
  RESOLVE_TAG (&tag_s_recl, inquire->recl);
3978
  RESOLVE_TAG (&tag_nextrec, inquire->nextrec);
3979
  RESOLVE_TAG (&tag_s_blank, inquire->blank);
3980
  RESOLVE_TAG (&tag_s_position, inquire->position);
3981
  RESOLVE_TAG (&tag_s_action, inquire->action);
3982
  RESOLVE_TAG (&tag_read, inquire->read);
3983
  RESOLVE_TAG (&tag_write, inquire->write);
3984
  RESOLVE_TAG (&tag_readwrite, inquire->readwrite);
3985
  RESOLVE_TAG (&tag_s_delim, inquire->delim);
3986
  RESOLVE_TAG (&tag_s_pad, inquire->pad);
3987
  RESOLVE_TAG (&tag_s_encoding, inquire->encoding);
3988
  RESOLVE_TAG (&tag_s_round, inquire->round);
3989
  RESOLVE_TAG (&tag_iolength, inquire->iolength);
3990
  RESOLVE_TAG (&tag_convert, inquire->convert);
3991
  RESOLVE_TAG (&tag_strm_out, inquire->strm_pos);
3992
  RESOLVE_TAG (&tag_s_async, inquire->asynchronous);
3993
  RESOLVE_TAG (&tag_s_sign, inquire->sign);
3994
  RESOLVE_TAG (&tag_s_round, inquire->round);
3995
  RESOLVE_TAG (&tag_pending, inquire->pending);
3996
  RESOLVE_TAG (&tag_size, inquire->size);
3997
  RESOLVE_TAG (&tag_id, inquire->id);
3998
 
3999
  if (gfc_reference_st_label (inquire->err, ST_LABEL_TARGET) == FAILURE)
4000
    return FAILURE;
4001
 
4002
  return SUCCESS;
4003
}
4004
 
4005
 
4006
void
4007
gfc_free_wait (gfc_wait *wait)
4008
{
4009
  if (wait == NULL)
4010
    return;
4011
 
4012
  gfc_free_expr (wait->unit);
4013
  gfc_free_expr (wait->iostat);
4014
  gfc_free_expr (wait->iomsg);
4015
  gfc_free_expr (wait->id);
4016
}
4017
 
4018
 
4019
gfc_try
4020
gfc_resolve_wait (gfc_wait *wait)
4021
{
4022
  RESOLVE_TAG (&tag_unit, wait->unit);
4023
  RESOLVE_TAG (&tag_iomsg, wait->iomsg);
4024
  RESOLVE_TAG (&tag_iostat, wait->iostat);
4025
  RESOLVE_TAG (&tag_id, wait->id);
4026
 
4027
  if (gfc_reference_st_label (wait->err, ST_LABEL_TARGET) == FAILURE)
4028
    return FAILURE;
4029
 
4030
  if (gfc_reference_st_label (wait->end, ST_LABEL_TARGET) == FAILURE)
4031
    return FAILURE;
4032
 
4033
  return SUCCESS;
4034
}
4035
 
4036
/* Match an element of a WAIT statement.  */
4037
 
4038
#define RETM   if (m != MATCH_NO) return m;
4039
 
4040
static match
4041
match_wait_element (gfc_wait *wait)
4042
{
4043
  match m;
4044
 
4045
  m = match_etag (&tag_unit, &wait->unit);
4046
  RETM m = match_ltag (&tag_err, &wait->err);
4047
  RETM m = match_ltag (&tag_end, &wait->eor);
4048
  RETM m = match_ltag (&tag_eor, &wait->end);
4049
  RETM m = match_out_tag (&tag_iomsg, &wait->iomsg);
4050
  RETM m = match_out_tag (&tag_iostat, &wait->iostat);
4051
  RETM m = match_etag (&tag_id, &wait->id);
4052
  RETM return MATCH_NO;
4053
}
4054
 
4055
#undef RETM
4056
 
4057
 
4058
match
4059
gfc_match_wait (void)
4060
{
4061
  gfc_wait *wait;
4062
  match m;
4063
 
4064
  m = gfc_match_char ('(');
4065
  if (m == MATCH_NO)
4066
    return m;
4067
 
4068
  wait = XCNEW (gfc_wait);
4069
 
4070
  m = match_wait_element (wait);
4071
  if (m == MATCH_ERROR)
4072
    goto cleanup;
4073
  if (m == MATCH_NO)
4074
    {
4075
      m = gfc_match_expr (&wait->unit);
4076
      if (m == MATCH_ERROR)
4077
        goto cleanup;
4078
      if (m == MATCH_NO)
4079
        goto syntax;
4080
    }
4081
 
4082
  for (;;)
4083
    {
4084
      if (gfc_match_char (')') == MATCH_YES)
4085
        break;
4086
      if (gfc_match_char (',') != MATCH_YES)
4087
        goto syntax;
4088
 
4089
      m = match_wait_element (wait);
4090
      if (m == MATCH_ERROR)
4091
        goto cleanup;
4092
      if (m == MATCH_NO)
4093
        goto syntax;
4094
    }
4095
 
4096
  if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: WAIT at %C "
4097
          "not allowed in Fortran 95") == FAILURE)
4098
    goto cleanup;
4099
 
4100
  if (gfc_pure (NULL))
4101
    {
4102
      gfc_error ("WAIT statement not allowed in PURE procedure at %C");
4103
      goto cleanup;
4104
    }
4105
 
4106
  new_st.op = EXEC_WAIT;
4107
  new_st.ext.wait = wait;
4108
 
4109
  return MATCH_YES;
4110
 
4111
syntax:
4112
  gfc_syntax_error (ST_WAIT);
4113
 
4114
cleanup:
4115
  gfc_free_wait (wait);
4116
  return MATCH_ERROR;
4117
}

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.