libgfortran/io/unit.c

   1 /* Copyright (C) 2002, 2003, 2005 Free Software Foundation, Inc.
   2    Contributed by Andy Vaught
   3
   4 This file is part of the GNU Fortran 95 runtime library (libgfortran).
   5
   6 Libgfortran is free software; you can redistribute it and/or modify
   7 it under the terms of the GNU General Public License as published by
   8 the Free Software Foundation; either version 2, or (at your option)
   9 any later version.
  10
  11 In addition to the permissions in the GNU General Public License, the
  12 Free Software Foundation gives you unlimited permission to link the
  13 compiled version of this file into combinations with other programs,
  14 and to distribute those combinations without any restriction coming
  15 from the use of this file.  (The General Public License restrictions
  16 do apply in other respects; for example, they cover modification of
  17 the file, and distribution when not linked into a combine
  18 executable.)
  19
  20 Libgfortran is distributed in the hope that it will be useful,
  21 but WITHOUT ANY WARRANTY; without even the implied warranty of
  22 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  23 GNU General Public License for more details.
  24
  25 You should have received a copy of the GNU General Public License
  26 along with Libgfortran; see the file COPYING.  If not, write to
  27 the Free Software Foundation, 51 Franklin Street, Fifth Floor,
  28 Boston, MA 02110-1301, USA.  */
  29
  30 #include "config.h"
  31 #include <stdlib.h>
  32 #include <string.h>
  33 #include "libgfortran.h"
  34 #include "io.h"
  35
  36
  37 /* Subroutines related to units */
  38
  39
  40 #define CACHE_SIZE 3
  41 static gfc_unit internal_unit, *unit_cache[CACHE_SIZE];
  42
  43
  44 /* This implementation is based on Stefan Nilsson's article in the
  45  * July 1997 Doctor Dobb's Journal, "Treaps in Java". */
  46
  47 /* pseudo_random()-- Simple linear congruential pseudorandom number
  48  * generator.  The period of this generator is 44071, which is plenty
  49  * for our purposes.  */
  50
  51 static int
  52 pseudo_random (void)
  53 {
  54   static int x0 = 5341;
  55
  56   x0 = (22611 * x0 + 10) % 44071;
  57   return x0;
  58 }
  59
  60
  61 /* rotate_left()-- Rotate the treap left */
  62
  63 static gfc_unit *
  64 rotate_left (gfc_unit * t)
  65 {
  66   gfc_unit *temp;
  67
  68   temp = t->right;
  69   t->right = t->right->left;
  70   temp->left = t;
  71
  72   return temp;
  73 }
  74
  75
  76 /* rotate_right()-- Rotate the treap right */
  77
  78 static gfc_unit *
  79 rotate_right (gfc_unit * t)
  80 {
  81   gfc_unit *temp;
  82
  83   temp = t->left;
  84   t->left = t->left->right;
  85   temp->right = t;
  86
  87   return temp;
  88 }
  89
  90
  91
  92 static int
  93 compare (int a, int b)
  94 {
  95   if (a < b)
  96     return -1;
  97   if (a > b)
  98     return 1;
  99
 100   return 0;
 101 }
 102
 103
 104 /* insert()-- Recursive insertion function.  Returns the updated treap. */
 105
 106 static gfc_unit *
 107 insert (gfc_unit * new, gfc_unit * t)
 108 {
 109   int c;
 110
 111   if (t == NULL)
 112     return new;
 113
 114   c = compare (new->unit_number, t->unit_number);
 115
 116   if (c < 0)
 117     {
 118       t->left = insert (new, t->left);
 119       if (t->priority < t->left->priority)
 120         t = rotate_right (t);
 121     }
 122
 123   if (c > 0)
 124     {
 125       t->right = insert (new, t->right);
 126       if (t->priority < t->right->priority)
 127         t = rotate_left (t);
 128     }
 129
 130   if (c == 0)
 131     internal_error ("insert(): Duplicate key found!");
 132
 133   return t;
 134 }
 135
 136
 137 /* insert_unit()-- Given a new node, insert it into the treap.  It is
 138  * an error to insert a key that already exists. */
 139
 140 void
 141 insert_unit (gfc_unit * new)
 142 {
 143   new->priority = pseudo_random ();
 144   g.unit_root = insert (new, g.unit_root);
 145 }
 146
 147
 148 static gfc_unit *
 149 delete_root (gfc_unit * t)
 150 {
 151   gfc_unit *temp;
 152
 153   if (t->left == NULL)
 154     return t->right;
 155   if (t->right == NULL)
 156     return t->left;
 157
 158   if (t->left->priority > t->right->priority)
 159     {
 160       temp = rotate_right (t);
 161       temp->right = delete_root (t);
 162     }
 163   else
 164     {
 165       temp = rotate_left (t);
 166       temp->left = delete_root (t);
 167     }
 168
 169   return temp;
 170 }
 171
 172
 173 /* delete_treap()-- Delete an element from a tree.  The 'old' value
 174  * does not necessarily have to point to the element to be deleted, it
 175  * must just point to a treap structure with the key to be deleted.
 176  * Returns the new root node of the tree. */
 177
 178 static gfc_unit *
 179 delete_treap (gfc_unit * old, gfc_unit * t)
 180 {
 181   int c;
 182
 183   if (t == NULL)
 184     return NULL;
 185
 186   c = compare (old->unit_number, t->unit_number);
 187
 188   if (c < 0)
 189     t->left = delete_treap (old, t->left);
 190   if (c > 0)
 191     t->right = delete_treap (old, t->right);
 192   if (c == 0)
 193     t = delete_root (t);
 194
 195   return t;
 196 }
 197
 198
 199 /* delete_unit()-- Delete a unit from a tree */
 200
 201 static void
 202 delete_unit (gfc_unit * old)
 203 {
 204   g.unit_root = delete_treap (old, g.unit_root);
 205 }
 206
 207
 208 /* find_unit()-- Given an integer, return a pointer to the unit
 209  * structure.  Returns NULL if the unit does not exist. */
 210
 211 gfc_unit *
 212 find_unit (int n)
 213 {
 214   gfc_unit *p;
 215   int c;
 216
 217   for (c = 0; c < CACHE_SIZE; c++)
 218     if (unit_cache[c] != NULL && unit_cache[c]->unit_number == n)
 219       {
 220         p = unit_cache[c];
 221         return p;
 222       }
 223
 224   p = g.unit_root;
 225   while (p != NULL)
 226     {
 227       c = compare (n, p->unit_number);
 228       if (c < 0)
 229         p = p->left;
 230       if (c > 0)
 231         p = p->right;
 232       if (c == 0)
 233         break;
 234     }
 235
 236   if (p != NULL)
 237     {
 238       for (c = 0; c < CACHE_SIZE - 1; c++)
 239         unit_cache[c] = unit_cache[c + 1];
 240
 241       unit_cache[CACHE_SIZE - 1] = p;
 242     }
 243
 244   return p;
 245 }
 246
 247
 248 /* get_array_unit_len()-- return the number of records in the array. */
 249
 250 gfc_offset
 251 get_array_unit_len (gfc_array_char *desc)
 252 {
 253   gfc_offset record_count;
 254   int i, rank, stride;
 255   rank = GFC_DESCRIPTOR_RANK(desc);
 256   record_count = stride = 1;
 257   for (i=0;i<rank;++i)
 258     {
 259       /* Check that array is contiguous */
 260
 261       if (desc->dim[i].stride != stride)
 262         {
 263           generate_error (ERROR_ARRAY_STRIDE, NULL);
 264           return 0;
 265         }
 266       stride *= desc->dim[i].ubound;
 267       record_count *= desc->dim[i].ubound;
 268     }
 269   return record_count;
 270 }
 271
 272
 273 /* get_unit()-- Returns the unit structure associated with the integer
 274  * unit or the internal file. */
 275
 276 gfc_unit *
 277 get_unit (int read_flag __attribute__ ((unused)))
 278 {
 279   if (ioparm.internal_unit != NULL)
 280     {
 281       internal_unit.recl = ioparm.internal_unit_len;
 282       if (is_array_io()) ioparm.internal_unit_len *=
 283                            get_array_unit_len(ioparm.internal_unit_desc);
 284       internal_unit.s =
 285         open_internal (ioparm.internal_unit, ioparm.internal_unit_len);
 286       internal_unit.bytes_left = internal_unit.recl;
 287       internal_unit.last_record=0;
 288       internal_unit.maxrec=0;
 289       internal_unit.current_record=0;
 290
 291       if (g.mode==WRITING && !is_array_io())
 292         empty_internal_buffer (internal_unit.s);
 293
 294       /* Set flags for the internal unit */
 295
 296       internal_unit.flags.access = ACCESS_SEQUENTIAL;
 297       internal_unit.flags.action = ACTION_READWRITE;
 298       internal_unit.flags.form = FORM_FORMATTED;
 299       internal_unit.flags.delim = DELIM_NONE;
 300
 301       return &internal_unit;
 302     }
 303
 304   /* Has to be an external unit */
 305
 306   return find_unit (ioparm.unit);
 307 }
 308
 309
 310 /* is_internal_unit()-- Determine if the current unit is internal or not */
 311
 312 int
 313 is_internal_unit (void)
 314 {
 315   return current_unit == &internal_unit;
 316 }
 317
 318
 319 /* is_array_io ()-- Determine if the I/O is to/from an array */
 320
 321 int
 322 is_array_io (void)
 323 {
 324   return (ioparm.internal_unit_desc != NULL);
 325 }
 326
 327
 328 /*************************/
 329 /* Initialize everything */
 330
 331 void
 332 init_units (void)
 333 {
 334   gfc_unit *u;
 335   unsigned int i;
 336
 337   if (options.stdin_unit >= 0)
 338     {                           /* STDIN */
 339       u = get_mem (sizeof (gfc_unit));
 340       memset (u, '\0', sizeof (gfc_unit));
 341
 342       u->unit_number = options.stdin_unit;
 343       u->s = input_stream ();
 344
 345       u->flags.action = ACTION_READ;
 346
 347       u->flags.access = ACCESS_SEQUENTIAL;
 348       u->flags.form = FORM_FORMATTED;
 349       u->flags.status = STATUS_OLD;
 350       u->flags.blank = BLANK_UNSPECIFIED;
 351       u->flags.position = POSITION_ASIS;
 352
 353       u->recl = options.default_recl;
 354       u->endfile = NO_ENDFILE;
 355
 356       insert_unit (u);
 357     }
 358
 359   if (options.stdout_unit >= 0)
 360     {                           /* STDOUT */
 361       u = get_mem (sizeof (gfc_unit));
 362       memset (u, '\0', sizeof (gfc_unit));
 363
 364       u->unit_number = options.stdout_unit;
 365       u->s = output_stream ();
 366
 367       u->flags.action = ACTION_WRITE;
 368
 369       u->flags.access = ACCESS_SEQUENTIAL;
 370       u->flags.form = FORM_FORMATTED;
 371       u->flags.status = STATUS_OLD;
 372       u->flags.blank = BLANK_UNSPECIFIED;
 373       u->flags.position = POSITION_ASIS;
 374
 375       u->recl = options.default_recl;
 376       u->endfile = AT_ENDFILE;
 377
 378       insert_unit (u);
 379     }
 380
 381   if (options.stderr_unit >= 0)
 382     {                           /* STDERR */
 383       u = get_mem (sizeof (gfc_unit));
 384       memset (u, '\0', sizeof (gfc_unit));
 385
 386       u->unit_number = options.stderr_unit;
 387       u->s = error_stream ();
 388
 389       u->flags.action = ACTION_WRITE;
 390
 391       u->flags.access = ACCESS_SEQUENTIAL;
 392       u->flags.form = FORM_FORMATTED;
 393       u->flags.status = STATUS_OLD;
 394       u->flags.blank = BLANK_UNSPECIFIED;
 395       u->flags.position = POSITION_ASIS;
 396
 397       u->recl = options.default_recl;
 398       u->endfile = AT_ENDFILE;
 399
 400       insert_unit (u);
 401     }
 402
 403   /* Calculate the maximum file offset in a portable manner.
 404    * max will be the largest signed number for the type gfc_offset.
 405    *
 406    * set a 1 in the LSB and keep a running sum, stopping at MSB-1 bit. */
 407
 408   g.max_offset = 0;
 409   for (i = 0; i < sizeof (g.max_offset) * 8 - 1; i++)
 410     g.max_offset = g.max_offset + ((gfc_offset) 1 << i);
 411
 412 }
 413
 414
 415 /* close_unit()-- Close a unit.  The stream is closed, and any memory
 416  * associated with the stream is freed.  Returns nonzero on I/O error. */
 417
 418 int
 419 close_unit (gfc_unit * u)
 420 {
 421   int i, rc;
 422
 423   for (i = 0; i < CACHE_SIZE; i++)
 424     if (unit_cache[i] == u)
 425       unit_cache[i] = NULL;
 426
 427   rc = (u->s == NULL) ? 0 : sclose (u->s) == FAILURE;
 428
 429   delete_unit (u);
 430   free_mem (u);
 431
 432   return rc;
 433 }
 434
 435
 436 /* close_units()-- Delete units on completion.  We just keep deleting
 437  * the root of the treap until there is nothing left. */
 438
 439 void
 440 close_units (void)
 441 {
 442   while (g.unit_root != NULL)
 443     close_unit (g.unit_root);
 444 }