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 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, 59 Temple Place - Suite 330,
  28 Boston, MA 02111-1307, 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 /* get_unit()-- Returns the unit structure associated with the integer
 248  * unit or the internal file. */
 249
 250 gfc_unit *
 251 get_unit (int read_flag)
 252 {
 253   if (ioparm.internal_unit != NULL)
 254     {
 255       internal_unit.s =
 256         open_internal (ioparm.internal_unit, ioparm.internal_unit_len);
 257
 258       /* Set flags for the internal unit */
 259
 260       internal_unit.flags.access = ACCESS_SEQUENTIAL;
 261       internal_unit.flags.action = ACTION_READWRITE;
 262       internal_unit.flags.form = FORM_FORMATTED;
 263       internal_unit.flags.delim = DELIM_NONE;
 264
 265       return &internal_unit;
 266     }
 267
 268   /* Has to be an external unit */
 269
 270   return find_unit (ioparm.unit);
 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   return current_unit == &internal_unit;
 281 }
 282
 283
 284
 285 /*************************/
 286 /* Initialize everything */
 287
 288 void
 289 init_units (void)
 290 {
 291   gfc_offset m, n;
 292   gfc_unit *u;
 293   int i;
 294
 295   if (options.stdin_unit >= 0)
 296     {                           /* STDIN */
 297       u = get_mem (sizeof (gfc_unit));
 298
 299       u->unit_number = options.stdin_unit;
 300       u->s = input_stream ();
 301
 302       u->flags.action = ACTION_READ;
 303
 304       u->flags.access = ACCESS_SEQUENTIAL;
 305       u->flags.form = FORM_FORMATTED;
 306       u->flags.status = STATUS_OLD;
 307       u->flags.blank = BLANK_ZERO;
 308       u->flags.position = POSITION_ASIS;
 309
 310       u->recl = options.default_recl;
 311       u->endfile = NO_ENDFILE;
 312
 313       insert_unit (u);
 314     }
 315
 316   if (options.stdout_unit >= 0)
 317     {                           /* STDOUT */
 318       u = get_mem (sizeof (gfc_unit));
 319
 320       u->unit_number = options.stdout_unit;
 321       u->s = output_stream ();
 322
 323       u->flags.action = ACTION_WRITE;
 324
 325       u->flags.access = ACCESS_SEQUENTIAL;
 326       u->flags.form = FORM_FORMATTED;
 327       u->flags.status = STATUS_OLD;
 328       u->flags.blank = BLANK_ZERO;
 329       u->flags.position = POSITION_ASIS;
 330
 331       u->recl = options.default_recl;
 332       u->endfile = AT_ENDFILE;
 333
 334       insert_unit (u);
 335     }
 336
 337   if (options.stderr_unit >= 0)
 338     {                           /* STDERR */
 339       u = get_mem (sizeof (gfc_unit));
 340
 341       u->unit_number = options.stderr_unit;
 342       u->s = error_stream ();
 343
 344       u->flags.action = ACTION_WRITE;
 345
 346       u->flags.access = ACCESS_SEQUENTIAL;
 347       u->flags.form = FORM_FORMATTED;
 348       u->flags.status = STATUS_OLD;
 349       u->flags.blank = BLANK_ZERO;
 350       u->flags.position = POSITION_ASIS;
 351
 352       u->recl = options.default_recl;
 353       u->endfile = AT_ENDFILE;
 354
 355       insert_unit (u);
 356     }
 357
 358   /* Calculate the maximum file offset in a portable manner.
 359    * max will be the largest signed number for the type gfc_offset.
 360    *
 361    * set a 1 in the LSB and keep a running sum, stopping at MSB-1 bit. */
 362
 363   g.max_offset = 0;
 364   for (i=0; i < sizeof(g.max_offset) * 8 - 1; i++)
 365     g.max_offset = g.max_offset + ((gfc_offset) 1 << i);
 366
 367 }
 368
 369
 370 /* close_unit()-- Close a unit.  The stream is closed, and any memory
 371  * associated with the stream is freed.  Returns nonzero on I/O error. */
 372
 373 int
 374 close_unit (gfc_unit * u)
 375 {
 376   int i, rc;
 377
 378   for (i = 0; i < CACHE_SIZE; i++)
 379     if (unit_cache[i] == u)
 380       unit_cache[i] = NULL;
 381
 382   rc = (u->s == NULL) ? 0 : sclose (u->s) == FAILURE;
 383
 384   delete_unit (u);
 385   free_mem (u);
 386
 387   return rc;
 388 }
 389
 390
 391 /* close_units()-- Delete units on completion.  We just keep deleting
 392  * the root of the treap until there is nothing left. */
 393
 394 void
 395 close_units (void)
 396 {
 397   while (g.unit_root != NULL)
 398     close_unit (g.unit_root);
 399 }