libgfortran/io/unit.c

   1 /* Copyright (C) 2002-2003 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 Libgfortran is distributed in the hope that it will be useful,
  12 but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 GNU General Public License for more details.
  15
  16 You should have received a copy of the GNU General Public License
  17 along with Libgfortran; see the file COPYING.  If not, write to
  18 the Free Software Foundation, 59 Temple Place - Suite 330,
  19 Boston, MA 02111-1307, USA.  */
  20
  21 #include "config.h"
  22 #include <stdlib.h>
  23 #include <string.h>
  24 #include "libgfortran.h"
  25 #include "io.h"
  26
  27
  28 /* Subroutines related to units */
  29
  30
  31 #define CACHE_SIZE 3
  32 static gfc_unit internal_unit, *unit_cache[CACHE_SIZE];
  33
  34
  35 /* This implementation is based on Stefan Nilsson's article in the
  36  * July 1997 Doctor Dobb's Journal, "Treaps in Java". */
  37
  38 /* pseudo_random()-- Simple linear congruential pseudorandom number
  39  * generator.  The period of this generator is 44071, which is plenty
  40  * for our purposes.  */
  41
  42 static int
  43 pseudo_random (void)
  44 {
  45   static int x0 = 5341;
  46
  47   x0 = (22611 * x0 + 10) % 44071;
  48   return x0;
  49 }
  50
  51
  52 /* rotate_left()-- Rotate the treap left */
  53
  54 static gfc_unit *
  55 rotate_left (gfc_unit * t)
  56 {
  57   gfc_unit *temp;
  58
  59   temp = t->right;
  60   t->right = t->right->left;
  61   temp->left = t;
  62
  63   return temp;
  64 }
  65
  66
  67 /* rotate_right()-- Rotate the treap right */
  68
  69 static gfc_unit *
  70 rotate_right (gfc_unit * t)
  71 {
  72   gfc_unit *temp;
  73
  74   temp = t->left;
  75   t->left = t->left->right;
  76   temp->right = t;
  77
  78   return temp;
  79 }
  80
  81
  82
  83 static int
  84 compare (int a, int b)
  85 {
  86
  87   if (a < b)
  88     return -1;
  89   if (a > b)
  90     return 1;
  91
  92   return 0;
  93 }
  94
  95
  96 /* insert()-- Recursive insertion function.  Returns the updated treap. */
  97
  98 static gfc_unit *
  99 insert (gfc_unit * new, gfc_unit * t)
 100 {
 101   int c;
 102
 103   if (t == NULL)
 104     return new;
 105
 106   c = compare (new->unit_number, t->unit_number);
 107
 108   if (c < 0)
 109     {
 110       t->left = insert (new, t->left);
 111       if (t->priority < t->left->priority)
 112         t = rotate_right (t);
 113     }
 114
 115   if (c > 0)
 116     {
 117       t->right = insert (new, t->right);
 118       if (t->priority < t->right->priority)
 119         t = rotate_left (t);
 120     }
 121
 122   if (c == 0)
 123     internal_error ("insert(): Duplicate key found!");
 124
 125   return t;
 126 }
 127
 128
 129 /* insert_unit()-- Given a new node, insert it into the treap.  It is
 130  * an error to insert a key that already exists. */
 131
 132 void
 133 insert_unit (gfc_unit * new)
 134 {
 135
 136   new->priority = pseudo_random ();
 137   g.unit_root = insert (new, g.unit_root);
 138 }
 139
 140
 141 static gfc_unit *
 142 delete_root (gfc_unit * t)
 143 {
 144   gfc_unit *temp;
 145
 146   if (t->left == NULL)
 147     return t->right;
 148   if (t->right == NULL)
 149     return t->left;
 150
 151   if (t->left->priority > t->right->priority)
 152     {
 153       temp = rotate_right (t);
 154       temp->right = delete_root (t);
 155     }
 156   else
 157     {
 158       temp = rotate_left (t);
 159       temp->left = delete_root (t);
 160     }
 161
 162   return temp;
 163 }
 164
 165
 166 /* delete_treap()-- Delete an element from a tree.  The 'old' value
 167  * does not necessarily have to point to the element to be deleted, it
 168  * must just point to a treap structure with the key to be deleted.
 169  * Returns the new root node of the tree. */
 170
 171 static gfc_unit *
 172 delete_treap (gfc_unit * old, gfc_unit * t)
 173 {
 174   int c;
 175
 176   if (t == NULL)
 177     return NULL;
 178
 179   c = compare (old->unit_number, t->unit_number);
 180
 181   if (c < 0)
 182     t->left = delete_treap (old, t->left);
 183   if (c > 0)
 184     t->right = delete_treap (old, t->right);
 185   if (c == 0)
 186     t = delete_root (t);
 187
 188   return t;
 189 }
 190
 191
 192 /* delete_unit()-- Delete a unit from a tree */
 193
 194 static void
 195 delete_unit (gfc_unit * old)
 196 {
 197
 198   g.unit_root = delete_treap (old, g.unit_root);
 199 }
 200
 201
 202 /* find_unit()-- Given an integer, return a pointer to the unit
 203  * structure.  Returns NULL if the unit does not exist. */
 204
 205 gfc_unit *
 206 find_unit (int n)
 207 {
 208   gfc_unit *p;
 209   int c;
 210
 211   for (c = 0; c < CACHE_SIZE; c++)
 212     if (unit_cache[c] != NULL && unit_cache[c]->unit_number == n)
 213       {
 214         p = unit_cache[c];
 215         return p;
 216       }
 217
 218   p = g.unit_root;
 219   while (p != NULL)
 220     {
 221       c = compare (n, p->unit_number);
 222       if (c < 0)
 223         p = p->left;
 224       if (c > 0)
 225         p = p->right;
 226       if (c == 0)
 227         break;
 228     }
 229
 230   if (p != NULL)
 231     {
 232       for (c = 0; c < CACHE_SIZE - 1; c++)
 233         unit_cache[c] = unit_cache[c + 1];
 234
 235       unit_cache[CACHE_SIZE - 1] = p;
 236     }
 237
 238   return p;
 239 }
 240
 241 /* get_unit()-- Returns the unit structure associated with the integer
 242  * unit or the internal file. */
 243
 244 gfc_unit *
 245 get_unit (int read_flag)
 246 {
 247   gfc_unit *u;
 248
 249   if (ioparm.internal_unit != NULL)
 250     {
 251       internal_unit.s =
 252         open_internal (ioparm.internal_unit, ioparm.internal_unit_len);
 253
 254       /* Set flags for the internal unit */
 255
 256       internal_unit.flags.access = ACCESS_SEQUENTIAL;
 257       internal_unit.flags.action = ACTION_READWRITE;
 258       internal_unit.flags.form = FORM_FORMATTED;
 259       internal_unit.flags.delim = DELIM_NONE;
 260
 261       return &internal_unit;
 262     }
 263
 264   /* Has to be an external unit */
 265
 266   u = find_unit (ioparm.unit);
 267   if (u != NULL)
 268     return u;
 269
 270   return NULL;
 271 }
 272
 273
 274 /* is_internal_unit()-- Determine if the current unit is internal or
 275  * not */
 276
 277 int
 278 is_internal_unit ()
 279 {
 280
 281   return current_unit == &internal_unit;
 282 }
 283
 284
 285
 286 /*************************/
 287 /* Initialize everything */
 288
 289 void
 290 init_units (void)
 291 {
 292   gfc_offset m, n;
 293   gfc_unit *u;
 294   int i;
 295
 296   if (options.stdin_unit >= 0)
 297     {                           /* STDIN */
 298       u = get_mem (sizeof (gfc_unit));
 299
 300       u->unit_number = options.stdin_unit;
 301       u->s = input_stream ();
 302
 303       u->flags.action = ACTION_READ;
 304
 305       u->flags.access = ACCESS_SEQUENTIAL;
 306       u->flags.form = FORM_FORMATTED;
 307       u->flags.status = STATUS_OLD;
 308       u->flags.blank = BLANK_ZERO;
 309       u->flags.position = POSITION_ASIS;
 310
 311       u->recl = options.default_recl;
 312       u->endfile = NO_ENDFILE;
 313
 314       insert_unit (u);
 315     }
 316
 317   if (options.stdout_unit >= 0)
 318     {                           /* STDOUT */
 319       u = get_mem (sizeof (gfc_unit));
 320
 321       u->unit_number = options.stdout_unit;
 322       u->s = output_stream ();
 323
 324       u->flags.action = ACTION_WRITE;
 325
 326       u->flags.access = ACCESS_SEQUENTIAL;
 327       u->flags.form = FORM_FORMATTED;
 328       u->flags.status = STATUS_OLD;
 329       u->flags.blank = BLANK_ZERO;
 330       u->flags.position = POSITION_ASIS;
 331
 332       u->recl = options.default_recl;
 333       u->endfile = AT_ENDFILE;
 334
 335       insert_unit (u);
 336     }
 337
 338   /* Calculate the maximum file offset in a portable manner.
 339    * max will be the largest signed number for the type gfc_offset.
 340    *
 341    * set a 1 in the LSB and keep a running sum, stopping at MSB-1 bit. */
 342
 343   g.max_offset = 0;
 344   for (i=0; i < sizeof(g.max_offset) * 8 - 1; i++)
 345     g.max_offset = g.max_offset + ((gfc_offset) 1 << i);
 346
 347 }
 348
 349
 350 /* close_unit()-- Close a unit.  The stream is closed, and any memory
 351  * associated with the stream is freed.  Returns nonzero on I/O error. */
 352
 353 int
 354 close_unit (gfc_unit * u)
 355 {
 356   int i, rc;
 357
 358   for (i = 0; i < CACHE_SIZE; i++)
 359     if (unit_cache[i] == u)
 360       unit_cache[i] = NULL;
 361
 362   rc = (u->s == NULL) ? 0 : sclose (u->s) == FAILURE;
 363
 364   delete_unit (u);
 365   free_mem (u);
 366
 367   return rc;
 368 }
 369
 370
 371 /* close_units()-- Delete units on completion.  We just keep deleting
 372  * the root of the treap until there is nothing left. */
 373
 374 void
 375 close_units (void)
 376 {
 377
 378   while (g.unit_root != NULL)
 379     close_unit (g.unit_root);
 380 }