OSDN Git Service

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