OSDN Git Service

./:
[pf3gnuchains/gcc-fork.git] / libgfortran / io / open.c
1 /* Copyright (C) 2002, 2003, 2004, 2005
2    Free Software Foundation, Inc.
3    Contributed by Andy Vaught
4
5 This file is part of the GNU Fortran 95 runtime library (libgfortran).
6
7 Libgfortran is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
10 any later version.
11
12 In addition to the permissions in the GNU General Public License, the
13 Free Software Foundation gives you unlimited permission to link the
14 compiled version of this file into combinations with other programs,
15 and to distribute those combinations without any restriction coming
16 from the use of this file.  (The General Public License restrictions
17 do apply in other respects; for example, they cover modification of
18 the file, and distribution when not linked into a combine
19 executable.)
20
21 Libgfortran is distributed in the hope that it will be useful,
22 but WITHOUT ANY WARRANTY; without even the implied warranty of
23 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
24 GNU General Public License for more details.
25
26 You should have received a copy of the GNU General Public License
27 along with Libgfortran; see the file COPYING.  If not, write to
28 the Free Software Foundation, 51 Franklin Street, Fifth Floor,
29 Boston, MA 02110-1301, USA.  */
30
31 #include "config.h"
32 #include <unistd.h>
33 #include <stdio.h>
34 #include <string.h>
35 #include <errno.h>
36 #include "libgfortran.h"
37 #include "io.h"
38
39
40 static const st_option access_opt[] = {
41   {"sequential", ACCESS_SEQUENTIAL},
42   {"direct", ACCESS_DIRECT},
43   {"append", ACCESS_APPEND},
44   {"stream", ACCESS_STREAM},
45   {NULL, 0}
46 };
47
48 static const st_option action_opt[] =
49 {
50   { "read", ACTION_READ},
51   { "write", ACTION_WRITE},
52   { "readwrite", ACTION_READWRITE},
53   { NULL, 0}
54 };
55
56 static const st_option blank_opt[] =
57 {
58   { "null", BLANK_NULL},
59   { "zero", BLANK_ZERO},
60   { NULL, 0}
61 };
62
63 static const st_option delim_opt[] =
64 {
65   { "none", DELIM_NONE},
66   { "apostrophe", DELIM_APOSTROPHE},
67   { "quote", DELIM_QUOTE},
68   { NULL, 0}
69 };
70
71 static const st_option form_opt[] =
72 {
73   { "formatted", FORM_FORMATTED},
74   { "unformatted", FORM_UNFORMATTED},
75   { NULL, 0}
76 };
77
78 static const st_option position_opt[] =
79 {
80   { "asis", POSITION_ASIS},
81   { "rewind", POSITION_REWIND},
82   { "append", POSITION_APPEND},
83   { NULL, 0}
84 };
85
86 static const st_option status_opt[] =
87 {
88   { "unknown", STATUS_UNKNOWN},
89   { "old", STATUS_OLD},
90   { "new", STATUS_NEW},
91   { "replace", STATUS_REPLACE},
92   { "scratch", STATUS_SCRATCH},
93   { NULL, 0}
94 };
95
96 static const st_option pad_opt[] =
97 {
98   { "yes", PAD_YES},
99   { "no", PAD_NO},
100   { NULL, 0}
101 };
102
103 static const st_option convert_opt[] =
104 {
105   { "native", CONVERT_NATIVE},
106   { "swap", CONVERT_SWAP},
107   { "big_endian", CONVERT_BIG},
108   { "little_endian", CONVERT_LITTLE},
109   { NULL, 0}
110 };
111
112 /* Given a unit, test to see if the file is positioned at the terminal
113    point, and if so, change state from NO_ENDFILE flag to AT_ENDFILE.
114    This prevents us from changing the state from AFTER_ENDFILE to
115    AT_ENDFILE.  */
116
117 void
118 test_endfile (gfc_unit * u)
119 {
120   if (u->endfile == NO_ENDFILE && file_length (u->s) == file_position (u->s))
121     u->endfile = AT_ENDFILE;
122 }
123
124
125 /* Change the modes of a file, those that are allowed * to be
126    changed.  */
127
128 static void
129 edit_modes (st_parameter_open *opp, gfc_unit * u, unit_flags * flags)
130 {
131   /* Complain about attempts to change the unchangeable.  */
132
133   if (flags->status != STATUS_UNSPECIFIED && flags->status != STATUS_OLD && 
134       u->flags.status != flags->status)
135     generate_error (&opp->common, ERROR_BAD_OPTION,
136                     "Cannot change STATUS parameter in OPEN statement");
137
138   if (flags->access != ACCESS_UNSPECIFIED && u->flags.access != flags->access)
139     generate_error (&opp->common, ERROR_BAD_OPTION,
140                     "Cannot change ACCESS parameter in OPEN statement");
141
142   if (flags->form != FORM_UNSPECIFIED && u->flags.form != flags->form)
143     generate_error (&opp->common, ERROR_BAD_OPTION,
144                     "Cannot change FORM parameter in OPEN statement");
145
146   if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN)
147       && opp->recl_in != u->recl)
148     generate_error (&opp->common, ERROR_BAD_OPTION,
149                     "Cannot change RECL parameter in OPEN statement");
150
151   if (flags->action != ACTION_UNSPECIFIED && u->flags.action != flags->action)
152     generate_error (&opp->common, ERROR_BAD_OPTION,
153                     "Cannot change ACTION parameter in OPEN statement");
154
155   /* Status must be OLD if present.  */
156
157   if (flags->status != STATUS_UNSPECIFIED && flags->status != STATUS_OLD &&
158       flags->status != STATUS_UNKNOWN)
159     {
160       if (flags->status == STATUS_SCRATCH)
161         notify_std (&opp->common, GFC_STD_GNU,
162                     "OPEN statement must have a STATUS of OLD or UNKNOWN");
163       else
164         generate_error (&opp->common, ERROR_BAD_OPTION,
165                     "OPEN statement must have a STATUS of OLD or UNKNOWN");
166     }
167
168   if (u->flags.form == FORM_UNFORMATTED)
169     {
170       if (flags->delim != DELIM_UNSPECIFIED)
171         generate_error (&opp->common, ERROR_OPTION_CONFLICT,
172                         "DELIM parameter conflicts with UNFORMATTED form in "
173                         "OPEN statement");
174
175       if (flags->blank != BLANK_UNSPECIFIED)
176         generate_error (&opp->common, ERROR_OPTION_CONFLICT,
177                         "BLANK parameter conflicts with UNFORMATTED form in "
178                         "OPEN statement");
179
180       if (flags->pad != PAD_UNSPECIFIED)
181         generate_error (&opp->common, ERROR_OPTION_CONFLICT,
182                         "PAD parameter conflicts with UNFORMATTED form in "
183                         "OPEN statement");
184     }
185
186   if ((opp->common.flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_OK)
187     {
188       /* Change the changeable:  */
189       if (flags->blank != BLANK_UNSPECIFIED)
190         u->flags.blank = flags->blank;
191       if (flags->delim != DELIM_UNSPECIFIED)
192         u->flags.delim = flags->delim;
193       if (flags->pad != PAD_UNSPECIFIED)
194         u->flags.pad = flags->pad;
195     }
196
197   /* Reposition the file if necessary.  */
198
199   switch (flags->position)
200     {
201     case POSITION_UNSPECIFIED:
202     case POSITION_ASIS:
203       break;
204
205     case POSITION_REWIND:
206       if (sseek (u->s, 0) == FAILURE)
207         goto seek_error;
208
209       u->current_record = 0;
210       u->last_record = 0;
211
212       test_endfile (u);         /* We might be at the end.  */
213       break;
214
215     case POSITION_APPEND:
216       if (sseek (u->s, file_length (u->s)) == FAILURE)
217         goto seek_error;
218
219       if (flags->access != ACCESS_STREAM)
220         u->current_record = 0;
221
222       u->endfile = AT_ENDFILE;  /* We are at the end.  */
223       break;
224
225     seek_error:
226       generate_error (&opp->common, ERROR_OS, NULL);
227       break;
228     }
229
230   unlock_unit (u);
231 }
232
233
234 /* Open an unused unit.  */
235
236 gfc_unit *
237 new_unit (st_parameter_open *opp, gfc_unit *u, unit_flags * flags)
238 {
239   gfc_unit *u2;
240   stream *s;
241   char tmpname[5 /* fort. */ + 10 /* digits of unit number */ + 1 /* 0 */];
242
243   /* Change unspecifieds to defaults.  Leave (flags->action ==
244      ACTION_UNSPECIFIED) alone so open_external() can set it based on
245      what type of open actually works.  */
246
247   if (flags->access == ACCESS_UNSPECIFIED)
248     flags->access = ACCESS_SEQUENTIAL;
249
250   if (flags->form == FORM_UNSPECIFIED)
251     flags->form = (flags->access == ACCESS_SEQUENTIAL)
252       ? FORM_FORMATTED : FORM_UNFORMATTED;
253
254
255   if (flags->delim == DELIM_UNSPECIFIED)
256     flags->delim = DELIM_NONE;
257   else
258     {
259       if (flags->form == FORM_UNFORMATTED)
260         {
261           generate_error (&opp->common, ERROR_OPTION_CONFLICT,
262                           "DELIM parameter conflicts with UNFORMATTED form in "
263                           "OPEN statement");
264           goto fail;
265         }
266     }
267
268   if (flags->blank == BLANK_UNSPECIFIED)
269     flags->blank = BLANK_NULL;
270   else
271     {
272       if (flags->form == FORM_UNFORMATTED)
273         {
274           generate_error (&opp->common, ERROR_OPTION_CONFLICT,
275                           "BLANK parameter conflicts with UNFORMATTED form in "
276                           "OPEN statement");
277           goto fail;
278         }
279     }
280
281   if (flags->pad == PAD_UNSPECIFIED)
282     flags->pad = PAD_YES;
283   else
284     {
285       if (flags->form == FORM_UNFORMATTED)
286         {
287           generate_error (&opp->common, ERROR_OPTION_CONFLICT,
288                           "PAD parameter conflicts with UNFORMATTED form in "
289                           "OPEN statement");
290           goto fail;
291         }
292     }
293
294   if (flags->position != POSITION_ASIS && flags->access == ACCESS_DIRECT)
295    {
296      generate_error (&opp->common, ERROR_OPTION_CONFLICT,
297                      "ACCESS parameter conflicts with SEQUENTIAL access in "
298                      "OPEN statement");
299      goto fail;
300    }
301   else
302    if (flags->position == POSITION_UNSPECIFIED)
303      flags->position = POSITION_ASIS;
304
305
306   if (flags->status == STATUS_UNSPECIFIED)
307     flags->status = STATUS_UNKNOWN;
308
309   /* Checks.  */
310
311   if (flags->access == ACCESS_DIRECT
312       && (opp->common.flags & IOPARM_OPEN_HAS_RECL_IN) == 0)
313     {
314       generate_error (&opp->common, ERROR_MISSING_OPTION,
315                       "Missing RECL parameter in OPEN statement");
316       goto fail;
317     }
318
319   if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN) && opp->recl_in <= 0)
320     {
321       generate_error (&opp->common, ERROR_BAD_OPTION,
322                       "RECL parameter is non-positive in OPEN statement");
323       goto fail;
324     }
325
326   switch (flags->status)
327     {
328     case STATUS_SCRATCH:
329       if ((opp->common.flags & IOPARM_OPEN_HAS_FILE) == 0)
330         {
331           opp->file = NULL;
332           break;
333         }
334
335       generate_error (&opp->common, ERROR_BAD_OPTION,
336                       "FILE parameter must not be present in OPEN statement");
337       goto fail;
338
339     case STATUS_OLD:
340     case STATUS_NEW:
341     case STATUS_REPLACE:
342     case STATUS_UNKNOWN:
343       if ((opp->common.flags & IOPARM_OPEN_HAS_FILE))
344         break;
345
346       opp->file = tmpname;
347       opp->file_len = sprintf(opp->file, "fort.%d", (int) opp->common.unit);
348       break;
349
350     default:
351       internal_error (&opp->common, "new_unit(): Bad status");
352     }
353
354   /* Make sure the file isn't already open someplace else.
355      Do not error if opening file preconnected to stdin, stdout, stderr.  */
356
357   u2 = NULL;
358   if ((opp->common.flags & IOPARM_OPEN_HAS_FILE) != 0)
359     u2 = find_file (opp->file, opp->file_len);
360   if (u2 != NULL
361       && (options.stdin_unit < 0 || u2->unit_number != options.stdin_unit)
362       && (options.stdout_unit < 0 || u2->unit_number != options.stdout_unit)
363       && (options.stderr_unit < 0 || u2->unit_number != options.stderr_unit))
364     {
365       unlock_unit (u2);
366       generate_error (&opp->common, ERROR_ALREADY_OPEN, NULL);
367       goto cleanup;
368     }
369
370   if (u2 != NULL)
371     unlock_unit (u2);
372
373   /* Open file.  */
374
375   s = open_external (opp, flags);
376   if (s == NULL)
377     {
378       char *path, *msg;
379       path = (char *) gfc_alloca (opp->file_len + 1);
380       msg = (char *) gfc_alloca (opp->file_len + 51);
381       unpack_filename (path, opp->file, opp->file_len);
382
383       switch (errno)
384         {
385         case ENOENT: 
386           st_sprintf (msg, "File '%s' does not exist", path);
387           break;
388
389         case EEXIST:
390           st_sprintf (msg, "File '%s' already exists", path);
391           break;
392
393         case EACCES:
394           st_sprintf (msg, "Permission denied trying to open file '%s'", path);
395           break;
396
397         case EISDIR:
398           st_sprintf (msg, "'%s' is a directory", path);
399           break;
400
401         default:
402           msg = NULL;
403         }
404
405       generate_error (&opp->common, ERROR_OS, msg);
406       goto cleanup;
407     }
408
409   if (flags->status == STATUS_NEW || flags->status == STATUS_REPLACE)
410     flags->status = STATUS_OLD;
411
412   /* Create the unit structure.  */
413
414   u->file = get_mem (opp->file_len);
415   if (u->unit_number != opp->common.unit)
416     internal_error (&opp->common, "Unit number changed");
417   u->s = s;
418   u->flags = *flags;
419   u->read_bad = 0;
420   u->endfile = NO_ENDFILE;
421   u->last_record = 0;
422   u->current_record = 0;
423   u->mode = READING;
424   u->maxrec = 0;
425   u->bytes_left = 0;
426
427   if (flags->position == POSITION_APPEND)
428     {
429       if (sseek (u->s, file_length (u->s)) == FAILURE)
430         generate_error (&opp->common, ERROR_OS, NULL);
431       u->endfile = AT_ENDFILE;
432     }
433
434   /* Unspecified recl ends up with a processor dependent value.  */
435
436   if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN))
437     {
438       u->flags.has_recl = 1;
439       u->recl = opp->recl_in;
440     }
441   else
442     {
443       u->flags.has_recl = 0;
444       u->recl = max_offset;
445       if (compile_options.max_subrecord_length)
446         {
447           u->recl_subrecord = compile_options.max_subrecord_length;
448         }
449       else
450         {
451           switch (compile_options.record_marker)
452             {
453             case 0:
454               /* Fall through */
455             case sizeof (GFC_INTEGER_4):
456               u->recl_subrecord = GFC_MAX_SUBRECORD_LENGTH;
457               break;
458
459             case sizeof (GFC_INTEGER_8):
460               u->recl_subrecord = max_offset - 16;
461               break;
462
463             default:
464               runtime_error ("Illegal value for record marker");
465               break;
466             }
467         }
468     }
469
470   /* If the file is direct access, calculate the maximum record number
471      via a division now instead of letting the multiplication overflow
472      later.  */
473
474   if (flags->access == ACCESS_DIRECT)
475     u->maxrec = max_offset / u->recl;
476   
477   if (flags->access == ACCESS_STREAM)
478     {
479       u->maxrec = max_offset;
480       u->recl = 1;
481       u->strm_pos = 1;
482     }
483
484   memmove (u->file, opp->file, opp->file_len);
485   u->file_len = opp->file_len;
486
487   /* Curiously, the standard requires that the
488      position specifier be ignored for new files so a newly connected
489      file starts out that the initial point.  We still need to figure
490      out if the file is at the end or not.  */
491
492   test_endfile (u);
493
494   if (flags->status == STATUS_SCRATCH && opp->file != NULL)
495     free_mem (opp->file);
496   return u;
497
498  cleanup:
499
500   /* Free memory associated with a temporary filename.  */
501
502   if (flags->status == STATUS_SCRATCH && opp->file != NULL)
503     free_mem (opp->file);
504
505  fail:
506
507   close_unit (u);
508   return NULL;
509 }
510
511
512 /* Open a unit which is already open.  This involves changing the
513    modes or closing what is there now and opening the new file.  */
514
515 static void
516 already_open (st_parameter_open *opp, gfc_unit * u, unit_flags * flags)
517 {
518   if ((opp->common.flags & IOPARM_OPEN_HAS_FILE) == 0)
519     {
520       edit_modes (opp, u, flags);
521       return;
522     }
523
524   /* If the file is connected to something else, close it and open a
525      new unit.  */
526
527   if (!compare_file_filename (u, opp->file, opp->file_len))
528     {
529 #if !HAVE_UNLINK_OPEN_FILE
530       char *path = NULL;
531       if (u->file && u->flags.status == STATUS_SCRATCH)
532         {
533           path = (char *) gfc_alloca (u->file_len + 1);
534           unpack_filename (path, u->file, u->file_len);
535         }
536 #endif
537
538       if (sclose (u->s) == FAILURE)
539         {
540           unlock_unit (u);
541           generate_error (&opp->common, ERROR_OS,
542                           "Error closing file in OPEN statement");
543           return;
544         }
545
546       u->s = NULL;
547       if (u->file)
548         free_mem (u->file);
549       u->file = NULL;
550       u->file_len = 0;
551
552 #if !HAVE_UNLINK_OPEN_FILE
553       if (path != NULL)
554         unlink (path);
555 #endif
556
557       u = new_unit (opp, u, flags);
558       if (u != NULL)
559         unlock_unit (u);
560       return;
561     }
562
563   edit_modes (opp, u, flags);
564 }
565
566
567 /* Open file.  */
568
569 extern void st_open (st_parameter_open *opp);
570 export_proto(st_open);
571
572 void
573 st_open (st_parameter_open *opp)
574 {
575   unit_flags flags;
576   gfc_unit *u = NULL;
577   GFC_INTEGER_4 cf = opp->common.flags;
578   unit_convert conv;
579  
580   library_start (&opp->common);
581
582   /* Decode options.  */
583
584   flags.access = !(cf & IOPARM_OPEN_HAS_ACCESS) ? ACCESS_UNSPECIFIED :
585     find_option (&opp->common, opp->access, opp->access_len,
586                  access_opt, "Bad ACCESS parameter in OPEN statement");
587
588   flags.action = !(cf & IOPARM_OPEN_HAS_ACTION) ? ACTION_UNSPECIFIED :
589     find_option (&opp->common, opp->action, opp->action_len,
590                  action_opt, "Bad ACTION parameter in OPEN statement");
591
592   flags.blank = !(cf & IOPARM_OPEN_HAS_BLANK) ? BLANK_UNSPECIFIED :
593     find_option (&opp->common, opp->blank, opp->blank_len,
594                  blank_opt, "Bad BLANK parameter in OPEN statement");
595
596   flags.delim = !(cf & IOPARM_OPEN_HAS_DELIM) ? DELIM_UNSPECIFIED :
597     find_option (&opp->common, opp->delim, opp->delim_len,
598                  delim_opt, "Bad DELIM parameter in OPEN statement");
599
600   flags.pad = !(cf & IOPARM_OPEN_HAS_PAD) ? PAD_UNSPECIFIED :
601     find_option (&opp->common, opp->pad, opp->pad_len,
602                  pad_opt, "Bad PAD parameter in OPEN statement");
603
604   flags.form = !(cf & IOPARM_OPEN_HAS_FORM) ? FORM_UNSPECIFIED :
605     find_option (&opp->common, opp->form, opp->form_len,
606                  form_opt, "Bad FORM parameter in OPEN statement");
607
608   flags.position = !(cf & IOPARM_OPEN_HAS_POSITION) ? POSITION_UNSPECIFIED :
609     find_option (&opp->common, opp->position, opp->position_len,
610                  position_opt, "Bad POSITION parameter in OPEN statement");
611
612   flags.status = !(cf & IOPARM_OPEN_HAS_STATUS) ? STATUS_UNSPECIFIED :
613     find_option (&opp->common, opp->status, opp->status_len,
614                  status_opt, "Bad STATUS parameter in OPEN statement");
615
616   /* First, we check wether the convert flag has been set via environment
617      variable.  This overrides the convert tag in the open statement.  */
618
619   conv = get_unformatted_convert (opp->common.unit);
620
621   if (conv == CONVERT_NONE)
622     {
623       /* Nothing has been set by environment variable, check the convert tag.  */
624       if (cf & IOPARM_OPEN_HAS_CONVERT)
625         conv = find_option (&opp->common, opp->convert, opp->convert_len,
626                             convert_opt,
627                             "Bad CONVERT parameter in OPEN statement");
628       else
629         conv = compile_options.convert;
630     }
631   
632   /* We use l8_to_l4_offset, which is 0 on little-endian machines
633      and 1 on big-endian machines.  */
634   switch (conv)
635     {
636     case CONVERT_NATIVE:
637     case CONVERT_SWAP:
638       break;
639       
640     case CONVERT_BIG:
641       conv = l8_to_l4_offset ? CONVERT_NATIVE : CONVERT_SWAP;
642       break;
643       
644     case CONVERT_LITTLE:
645       conv = l8_to_l4_offset ? CONVERT_SWAP : CONVERT_NATIVE;
646       break;
647       
648     default:
649       internal_error (&opp->common, "Illegal value for CONVERT");
650       break;
651     }
652
653   flags.convert = conv;
654
655   if (opp->common.unit < 0)
656     generate_error (&opp->common, ERROR_BAD_OPTION,
657                     "Bad unit number in OPEN statement");
658
659   if (flags.position != POSITION_UNSPECIFIED
660       && flags.access == ACCESS_DIRECT)
661     generate_error (&opp->common, ERROR_BAD_OPTION,
662                     "Cannot use POSITION with direct access files");
663
664   if (flags.access == ACCESS_APPEND)
665     {
666       if (flags.position != POSITION_UNSPECIFIED
667           && flags.position != POSITION_APPEND)
668         generate_error (&opp->common, ERROR_BAD_OPTION,
669                         "Conflicting ACCESS and POSITION flags in"
670                         " OPEN statement");
671
672       notify_std (&opp->common, GFC_STD_GNU,
673                   "Extension: APPEND as a value for ACCESS in OPEN statement");
674       flags.access = ACCESS_SEQUENTIAL;
675       flags.position = POSITION_APPEND;
676     }
677
678   if (flags.position == POSITION_UNSPECIFIED)
679     flags.position = POSITION_ASIS;
680
681   if ((opp->common.flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_OK)
682     {
683       u = find_or_create_unit (opp->common.unit);
684
685       if (u->s == NULL)
686         {
687           u = new_unit (opp, u, &flags);
688           if (u != NULL)
689             unlock_unit (u);
690         }
691       else
692         already_open (opp, u, &flags);
693     }
694
695   library_end ();
696 }