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