OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [libgfortran/] [io/] [unit.c] - Blame information for rev 867

Go to most recent revision | Details | Compare with Previous | View Log

Line No. Rev Author Line
1 733 jeremybenn
/* Copyright (C) 2002, 2003, 2005, 2007, 2008, 2009, 2010, 2011
2
   Free Software Foundation, Inc.
3
   Contributed by Andy Vaught
4
   F2003 I/O support contributed by Jerry DeLisle
5
 
6
This file is part of the GNU Fortran runtime library (libgfortran).
7
 
8
Libgfortran is free software; you can redistribute it and/or modify
9
it under the terms of the GNU General Public License as published by
10
the Free Software Foundation; either version 3, or (at your option)
11
any later version.
12
 
13
Libgfortran is distributed in the hope that it will be useful,
14
but WITHOUT ANY WARRANTY; without even the implied warranty of
15
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16
GNU General Public License for more details.
17
 
18
Under Section 7 of GPL version 3, you are granted additional
19
permissions described in the GCC Runtime Library Exception, version
20
3.1, as published by the Free Software Foundation.
21
 
22
You should have received a copy of the GNU General Public License and
23
a copy of the GCC Runtime Library Exception along with this program;
24
see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
25
<http://www.gnu.org/licenses/>.  */
26
 
27
#include "io.h"
28
#include "fbuf.h"
29
#include "format.h"
30
#include "unix.h"
31
#include <stdlib.h>
32
#include <string.h>
33
 
34
 
35
/* IO locking rules:
36
   UNIT_LOCK is a master lock, protecting UNIT_ROOT tree and UNIT_CACHE.
37
   Concurrent use of different units should be supported, so
38
   each unit has its own lock, LOCK.
39
   Open should be atomic with its reopening of units and list_read.c
40
   in several places needs find_unit another unit while holding stdin
41
   unit's lock, so it must be possible to acquire UNIT_LOCK while holding
42
   some unit's lock.  Therefore to avoid deadlocks, it is forbidden
43
   to acquire unit's private locks while holding UNIT_LOCK, except
44
   for freshly created units (where no other thread can get at their
45
   address yet) or when using just trylock rather than lock operation.
46
   In addition to unit's private lock each unit has a WAITERS counter
47
   and CLOSED flag.  WAITERS counter must be either only
48
   atomically incremented/decremented in all places (if atomic builtins
49
   are supported), or protected by UNIT_LOCK in all places (otherwise).
50
   CLOSED flag must be always protected by unit's LOCK.
51
   After finding a unit in UNIT_CACHE or UNIT_ROOT with UNIT_LOCK held,
52
   WAITERS must be incremented to avoid concurrent close from freeing
53
   the unit between unlocking UNIT_LOCK and acquiring unit's LOCK.
54
   Unit freeing is always done under UNIT_LOCK.  If close_unit sees any
55
   WAITERS, it doesn't free the unit but instead sets the CLOSED flag
56
   and the thread that decrements WAITERS to zero while CLOSED flag is
57
   set is responsible for freeing it (while holding UNIT_LOCK).
58
   flush_all_units operation is iterating over the unit tree with
59
   increasing UNIT_NUMBER while holding UNIT_LOCK and attempting to
60
   flush each unit (and therefore needs the unit's LOCK held as well).
61
   To avoid deadlocks, it just trylocks the LOCK and if unsuccessful,
62
   remembers the current unit's UNIT_NUMBER, unlocks UNIT_LOCK, acquires
63
   unit's LOCK and after flushing reacquires UNIT_LOCK and restarts with
64
   the smallest UNIT_NUMBER above the last one flushed.
65
 
66
   If find_unit/find_or_create_unit/find_file/get_unit routines return
67
   non-NULL, the returned unit has its private lock locked and when the
68
   caller is done with it, it must call either unlock_unit or close_unit
69
   on it.  unlock_unit or close_unit must be always called only with the
70
   private lock held.  */
71
 
72
/* Subroutines related to units */
73
 
74
/* Unit number to be assigned when NEWUNIT is used in an OPEN statement.  */
75
#define GFC_FIRST_NEWUNIT -10
76
static GFC_INTEGER_4 next_available_newunit = GFC_FIRST_NEWUNIT;
77
 
78
#define CACHE_SIZE 3
79
static gfc_unit *unit_cache[CACHE_SIZE];
80
gfc_offset max_offset;
81
gfc_unit *unit_root;
82
#ifdef __GTHREAD_MUTEX_INIT
83
__gthread_mutex_t unit_lock = __GTHREAD_MUTEX_INIT;
84
#else
85
__gthread_mutex_t unit_lock;
86
#endif
87
 
88
/* We use these filenames for error reporting.  */
89
 
90
static char stdin_name[] = "stdin";
91
static char stdout_name[] = "stdout";
92
static char stderr_name[] = "stderr";
93
 
94
/* This implementation is based on Stefan Nilsson's article in the
95
 * July 1997 Doctor Dobb's Journal, "Treaps in Java". */
96
 
97
/* pseudo_random()-- Simple linear congruential pseudorandom number
98
 * generator.  The period of this generator is 44071, which is plenty
99
 * for our purposes.  */
100
 
101
static int
102
pseudo_random (void)
103
{
104
  static int x0 = 5341;
105
 
106
  x0 = (22611 * x0 + 10) % 44071;
107
  return x0;
108
}
109
 
110
 
111
/* rotate_left()-- Rotate the treap left */
112
 
113
static gfc_unit *
114
rotate_left (gfc_unit * t)
115
{
116
  gfc_unit *temp;
117
 
118
  temp = t->right;
119
  t->right = t->right->left;
120
  temp->left = t;
121
 
122
  return temp;
123
}
124
 
125
 
126
/* rotate_right()-- Rotate the treap right */
127
 
128
static gfc_unit *
129
rotate_right (gfc_unit * t)
130
{
131
  gfc_unit *temp;
132
 
133
  temp = t->left;
134
  t->left = t->left->right;
135
  temp->right = t;
136
 
137
  return temp;
138
}
139
 
140
 
141
static int
142
compare (int a, int b)
143
{
144
  if (a < b)
145
    return -1;
146
  if (a > b)
147
    return 1;
148
 
149
  return 0;
150
}
151
 
152
 
153
/* insert()-- Recursive insertion function.  Returns the updated treap. */
154
 
155
static gfc_unit *
156
insert (gfc_unit *new, gfc_unit *t)
157
{
158
  int c;
159
 
160
  if (t == NULL)
161
    return new;
162
 
163
  c = compare (new->unit_number, t->unit_number);
164
 
165
  if (c < 0)
166
    {
167
      t->left = insert (new, t->left);
168
      if (t->priority < t->left->priority)
169
        t = rotate_right (t);
170
    }
171
 
172
  if (c > 0)
173
    {
174
      t->right = insert (new, t->right);
175
      if (t->priority < t->right->priority)
176
        t = rotate_left (t);
177
    }
178
 
179
  if (c == 0)
180
    internal_error (NULL, "insert(): Duplicate key found!");
181
 
182
  return t;
183
}
184
 
185
 
186
/* insert_unit()-- Create a new node, insert it into the treap.  */
187
 
188
static gfc_unit *
189
insert_unit (int n)
190
{
191
  gfc_unit *u = get_mem (sizeof (gfc_unit));
192
  memset (u, '\0', sizeof (gfc_unit));
193
  u->unit_number = n;
194
#ifdef __GTHREAD_MUTEX_INIT
195
  {
196
    __gthread_mutex_t tmp = __GTHREAD_MUTEX_INIT;
197
    u->lock = tmp;
198
  }
199
#else
200
  __GTHREAD_MUTEX_INIT_FUNCTION (&u->lock);
201
#endif
202
  __gthread_mutex_lock (&u->lock);
203
  u->priority = pseudo_random ();
204
  unit_root = insert (u, unit_root);
205
  return u;
206
}
207
 
208
 
209
/* destroy_unit_mutex()-- Destroy the mutex and free memory of unit.  */
210
 
211
static void
212
destroy_unit_mutex (gfc_unit * u)
213
{
214
  __gthread_mutex_destroy (&u->lock);
215
  free (u);
216
}
217
 
218
 
219
static gfc_unit *
220
delete_root (gfc_unit * t)
221
{
222
  gfc_unit *temp;
223
 
224
  if (t->left == NULL)
225
    return t->right;
226
  if (t->right == NULL)
227
    return t->left;
228
 
229
  if (t->left->priority > t->right->priority)
230
    {
231
      temp = rotate_right (t);
232
      temp->right = delete_root (t);
233
    }
234
  else
235
    {
236
      temp = rotate_left (t);
237
      temp->left = delete_root (t);
238
    }
239
 
240
  return temp;
241
}
242
 
243
 
244
/* delete_treap()-- Delete an element from a tree.  The 'old' value
245
 * does not necessarily have to point to the element to be deleted, it
246
 * must just point to a treap structure with the key to be deleted.
247
 * Returns the new root node of the tree. */
248
 
249
static gfc_unit *
250
delete_treap (gfc_unit * old, gfc_unit * t)
251
{
252
  int c;
253
 
254
  if (t == NULL)
255
    return NULL;
256
 
257
  c = compare (old->unit_number, t->unit_number);
258
 
259
  if (c < 0)
260
    t->left = delete_treap (old, t->left);
261
  if (c > 0)
262
    t->right = delete_treap (old, t->right);
263
  if (c == 0)
264
    t = delete_root (t);
265
 
266
  return t;
267
}
268
 
269
 
270
/* delete_unit()-- Delete a unit from a tree */
271
 
272
static void
273
delete_unit (gfc_unit * old)
274
{
275
  unit_root = delete_treap (old, unit_root);
276
}
277
 
278
 
279
/* get_external_unit()-- Given an integer, return a pointer to the unit
280
 * structure.  Returns NULL if the unit does not exist,
281
 * otherwise returns a locked unit. */
282
 
283
static gfc_unit *
284
get_external_unit (int n, int do_create)
285
{
286
  gfc_unit *p;
287
  int c, created = 0;
288
 
289
  __gthread_mutex_lock (&unit_lock);
290
retry:
291
  for (c = 0; c < CACHE_SIZE; c++)
292
    if (unit_cache[c] != NULL && unit_cache[c]->unit_number == n)
293
      {
294
        p = unit_cache[c];
295
        goto found;
296
      }
297
 
298
  p = unit_root;
299
  while (p != NULL)
300
    {
301
      c = compare (n, p->unit_number);
302
      if (c < 0)
303
        p = p->left;
304
      if (c > 0)
305
        p = p->right;
306
      if (c == 0)
307
        break;
308
    }
309
 
310
  if (p == NULL && do_create)
311
    {
312
      p = insert_unit (n);
313
      created = 1;
314
    }
315
 
316
  if (p != NULL)
317
    {
318
      for (c = 0; c < CACHE_SIZE - 1; c++)
319
        unit_cache[c] = unit_cache[c + 1];
320
 
321
      unit_cache[CACHE_SIZE - 1] = p;
322
    }
323
 
324
  if (created)
325
    {
326
      /* Newly created units have their lock held already
327
         from insert_unit.  Just unlock UNIT_LOCK and return.  */
328
      __gthread_mutex_unlock (&unit_lock);
329
      return p;
330
    }
331
 
332
found:
333
  if (p != NULL)
334
    {
335
      /* Fast path.  */
336
      if (! __gthread_mutex_trylock (&p->lock))
337
        {
338
          /* assert (p->closed == 0); */
339
          __gthread_mutex_unlock (&unit_lock);
340
          return p;
341
        }
342
 
343
      inc_waiting_locked (p);
344
    }
345
 
346
  __gthread_mutex_unlock (&unit_lock);
347
 
348
  if (p != NULL)
349
    {
350
      __gthread_mutex_lock (&p->lock);
351
      if (p->closed)
352
        {
353
          __gthread_mutex_lock (&unit_lock);
354
          __gthread_mutex_unlock (&p->lock);
355
          if (predec_waiting_locked (p) == 0)
356
            destroy_unit_mutex (p);
357
          goto retry;
358
        }
359
 
360
      dec_waiting_unlocked (p);
361
    }
362
  return p;
363
}
364
 
365
 
366
gfc_unit *
367
find_unit (int n)
368
{
369
  return get_external_unit (n, 0);
370
}
371
 
372
 
373
gfc_unit *
374
find_or_create_unit (int n)
375
{
376
  return get_external_unit (n, 1);
377
}
378
 
379
 
380
gfc_unit *
381
get_internal_unit (st_parameter_dt *dtp)
382
{
383
  gfc_unit * iunit;
384
  gfc_offset start_record = 0;
385
 
386
  /* Allocate memory for a unit structure.  */
387
 
388
  iunit = get_mem (sizeof (gfc_unit));
389
  if (iunit == NULL)
390
    {
391
      generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
392
      return NULL;
393
    }
394
 
395
  memset (iunit, '\0', sizeof (gfc_unit));
396
#ifdef __GTHREAD_MUTEX_INIT
397
  {
398
    __gthread_mutex_t tmp = __GTHREAD_MUTEX_INIT;
399
    iunit->lock = tmp;
400
  }
401
#else
402
  __GTHREAD_MUTEX_INIT_FUNCTION (&iunit->lock);
403
#endif
404
  __gthread_mutex_lock (&iunit->lock);
405
 
406
  iunit->recl = dtp->internal_unit_len;
407
 
408
  /* For internal units we set the unit number to -1.
409
     Otherwise internal units can be mistaken for a pre-connected unit or
410
     some other file I/O unit.  */
411
  iunit->unit_number = -1;
412
 
413
  /* Set up the looping specification from the array descriptor, if any.  */
414
 
415
  if (is_array_io (dtp))
416
    {
417
      iunit->rank = GFC_DESCRIPTOR_RANK (dtp->internal_unit_desc);
418
      iunit->ls = (array_loop_spec *)
419
        get_mem (iunit->rank * sizeof (array_loop_spec));
420
      dtp->internal_unit_len *=
421
        init_loop_spec (dtp->internal_unit_desc, iunit->ls, &start_record);
422
 
423
      start_record *= iunit->recl;
424
    }
425
 
426
  /* Set initial values for unit parameters.  */
427
  if (dtp->common.unit)
428
    {
429
      iunit->s = open_internal4 (dtp->internal_unit - start_record,
430
                                 dtp->internal_unit_len, -start_record);
431
      fbuf_init (iunit, 256);
432
    }
433
  else
434
    iunit->s = open_internal (dtp->internal_unit - start_record,
435
                              dtp->internal_unit_len, -start_record);
436
 
437
  iunit->bytes_left = iunit->recl;
438
  iunit->last_record=0;
439
  iunit->maxrec=0;
440
  iunit->current_record=0;
441
  iunit->read_bad = 0;
442
  iunit->endfile = NO_ENDFILE;
443
 
444
  /* Set flags for the internal unit.  */
445
 
446
  iunit->flags.access = ACCESS_SEQUENTIAL;
447
  iunit->flags.action = ACTION_READWRITE;
448
  iunit->flags.blank = BLANK_NULL;
449
  iunit->flags.form = FORM_FORMATTED;
450
  iunit->flags.pad = PAD_YES;
451
  iunit->flags.status = STATUS_UNSPECIFIED;
452
  iunit->flags.sign = SIGN_SUPPRESS;
453
  iunit->flags.decimal = DECIMAL_POINT;
454
  iunit->flags.encoding = ENCODING_DEFAULT;
455
  iunit->flags.async = ASYNC_NO;
456
  iunit->flags.round = ROUND_COMPATIBLE;
457
 
458
  /* Initialize the data transfer parameters.  */
459
 
460
  dtp->u.p.advance_status = ADVANCE_YES;
461
  dtp->u.p.seen_dollar = 0;
462
  dtp->u.p.skips = 0;
463
  dtp->u.p.pending_spaces = 0;
464
  dtp->u.p.max_pos = 0;
465
  dtp->u.p.at_eof = 0;
466
 
467
  /* This flag tells us the unit is assigned to internal I/O.  */
468
 
469
  dtp->u.p.unit_is_internal = 1;
470
 
471
  return iunit;
472
}
473
 
474
 
475
/* free_internal_unit()-- Free memory allocated for internal units if any.  */
476
void
477
free_internal_unit (st_parameter_dt *dtp)
478
{
479
  if (!is_internal_unit (dtp))
480
    return;
481
 
482
  if (unlikely (is_char4_unit (dtp)))
483
    fbuf_destroy (dtp->u.p.current_unit);
484
 
485
  if (dtp->u.p.current_unit != NULL)
486
    {
487
      free (dtp->u.p.current_unit->ls);
488
 
489
      free (dtp->u.p.current_unit->s);
490
 
491
      destroy_unit_mutex (dtp->u.p.current_unit);
492
    }
493
}
494
 
495
 
496
 
497
/* get_unit()-- Returns the unit structure associated with the integer
498
   unit or the internal file.  */
499
 
500
gfc_unit *
501
get_unit (st_parameter_dt *dtp, int do_create)
502
{
503
 
504
  if ((dtp->common.flags & IOPARM_DT_HAS_INTERNAL_UNIT) != 0)
505
    return get_internal_unit (dtp);
506
 
507
  /* Has to be an external unit.  */
508
 
509
  dtp->u.p.unit_is_internal = 0;
510
  dtp->internal_unit_desc = NULL;
511
 
512
  return get_external_unit (dtp->common.unit, do_create);
513
}
514
 
515
 
516
/*************************/
517
/* Initialize everything.  */
518
 
519
void
520
init_units (void)
521
{
522
  gfc_unit *u;
523
  unsigned int i;
524
 
525
#ifndef __GTHREAD_MUTEX_INIT
526
  __GTHREAD_MUTEX_INIT_FUNCTION (&unit_lock);
527
#endif
528
 
529
  if (options.stdin_unit >= 0)
530
    {                           /* STDIN */
531
      u = insert_unit (options.stdin_unit);
532
      u->s = input_stream ();
533
 
534
      u->flags.action = ACTION_READ;
535
 
536
      u->flags.access = ACCESS_SEQUENTIAL;
537
      u->flags.form = FORM_FORMATTED;
538
      u->flags.status = STATUS_OLD;
539
      u->flags.blank = BLANK_NULL;
540
      u->flags.pad = PAD_YES;
541
      u->flags.position = POSITION_ASIS;
542
      u->flags.sign = SIGN_SUPPRESS;
543
      u->flags.decimal = DECIMAL_POINT;
544
      u->flags.encoding = ENCODING_DEFAULT;
545
      u->flags.async = ASYNC_NO;
546
      u->flags.round = ROUND_COMPATIBLE;
547
 
548
      u->recl = options.default_recl;
549
      u->endfile = NO_ENDFILE;
550
 
551
      u->file_len = strlen (stdin_name);
552
      u->file = get_mem (u->file_len);
553
      memmove (u->file, stdin_name, u->file_len);
554
 
555
      fbuf_init (u, 0);
556
 
557
      __gthread_mutex_unlock (&u->lock);
558
    }
559
 
560
  if (options.stdout_unit >= 0)
561
    {                           /* STDOUT */
562
      u = insert_unit (options.stdout_unit);
563
      u->s = output_stream ();
564
 
565
      u->flags.action = ACTION_WRITE;
566
 
567
      u->flags.access = ACCESS_SEQUENTIAL;
568
      u->flags.form = FORM_FORMATTED;
569
      u->flags.status = STATUS_OLD;
570
      u->flags.blank = BLANK_NULL;
571
      u->flags.position = POSITION_ASIS;
572
      u->flags.sign = SIGN_SUPPRESS;
573
      u->flags.decimal = DECIMAL_POINT;
574
      u->flags.encoding = ENCODING_DEFAULT;
575
      u->flags.async = ASYNC_NO;
576
      u->flags.round = ROUND_COMPATIBLE;
577
 
578
      u->recl = options.default_recl;
579
      u->endfile = AT_ENDFILE;
580
 
581
      u->file_len = strlen (stdout_name);
582
      u->file = get_mem (u->file_len);
583
      memmove (u->file, stdout_name, u->file_len);
584
 
585
      fbuf_init (u, 0);
586
 
587
      __gthread_mutex_unlock (&u->lock);
588
    }
589
 
590
  if (options.stderr_unit >= 0)
591
    {                           /* STDERR */
592
      u = insert_unit (options.stderr_unit);
593
      u->s = error_stream ();
594
 
595
      u->flags.action = ACTION_WRITE;
596
 
597
      u->flags.access = ACCESS_SEQUENTIAL;
598
      u->flags.form = FORM_FORMATTED;
599
      u->flags.status = STATUS_OLD;
600
      u->flags.blank = BLANK_NULL;
601
      u->flags.position = POSITION_ASIS;
602
      u->flags.sign = SIGN_SUPPRESS;
603
      u->flags.decimal = DECIMAL_POINT;
604
      u->flags.encoding = ENCODING_DEFAULT;
605
      u->flags.async = ASYNC_NO;
606
      u->flags.round = ROUND_COMPATIBLE;
607
 
608
      u->recl = options.default_recl;
609
      u->endfile = AT_ENDFILE;
610
 
611
      u->file_len = strlen (stderr_name);
612
      u->file = get_mem (u->file_len);
613
      memmove (u->file, stderr_name, u->file_len);
614
 
615
      fbuf_init (u, 256);  /* 256 bytes should be enough, probably not doing
616
                              any kind of exotic formatting to stderr.  */
617
 
618
      __gthread_mutex_unlock (&u->lock);
619
    }
620
 
621
  /* Calculate the maximum file offset in a portable manner.
622
     max will be the largest signed number for the type gfc_offset.
623
     set a 1 in the LSB and keep a running sum, stopping at MSB-1 bit.  */
624
  max_offset = 0;
625
  for (i = 0; i < sizeof (max_offset) * 8 - 1; i++)
626
    max_offset = max_offset + ((gfc_offset) 1 << i);
627
}
628
 
629
 
630
static int
631
close_unit_1 (gfc_unit *u, int locked)
632
{
633
  int i, rc;
634
 
635
  /* If there are previously written bytes from a write with ADVANCE="no"
636
     Reposition the buffer before closing.  */
637
  if (u->previous_nonadvancing_write)
638
    finish_last_advance_record (u);
639
 
640
  rc = (u->s == NULL) ? 0 : sclose (u->s) == -1;
641
 
642
  u->closed = 1;
643
  if (!locked)
644
    __gthread_mutex_lock (&unit_lock);
645
 
646
  for (i = 0; i < CACHE_SIZE; i++)
647
    if (unit_cache[i] == u)
648
      unit_cache[i] = NULL;
649
 
650
  delete_unit (u);
651
 
652
  free (u->file);
653
  u->file = NULL;
654
  u->file_len = 0;
655
 
656
  free_format_hash_table (u);
657
  fbuf_destroy (u);
658
 
659
  if (!locked)
660
    __gthread_mutex_unlock (&u->lock);
661
 
662
  /* If there are any threads waiting in find_unit for this unit,
663
     avoid freeing the memory, the last such thread will free it
664
     instead.  */
665
  if (u->waiting == 0)
666
    destroy_unit_mutex (u);
667
 
668
  if (!locked)
669
    __gthread_mutex_unlock (&unit_lock);
670
 
671
  return rc;
672
}
673
 
674
void
675
unlock_unit (gfc_unit *u)
676
{
677
  __gthread_mutex_unlock (&u->lock);
678
}
679
 
680
/* close_unit()-- Close a unit.  The stream is closed, and any memory
681
   associated with the stream is freed.  Returns nonzero on I/O error.
682
   Should be called with the u->lock locked. */
683
 
684
int
685
close_unit (gfc_unit *u)
686
{
687
  return close_unit_1 (u, 0);
688
}
689
 
690
 
691
/* close_units()-- Delete units on completion.  We just keep deleting
692
   the root of the treap until there is nothing left.
693
   Not sure what to do with locking here.  Some other thread might be
694
   holding some unit's lock and perhaps hold it indefinitely
695
   (e.g. waiting for input from some pipe) and close_units shouldn't
696
   delay the program too much.  */
697
 
698
void
699
close_units (void)
700
{
701
  __gthread_mutex_lock (&unit_lock);
702
  while (unit_root != NULL)
703
    close_unit_1 (unit_root, 1);
704
  __gthread_mutex_unlock (&unit_lock);
705
}
706
 
707
 
708
/* High level interface to truncate a file, i.e. flush format buffers,
709
   and generate an error or set some flags.  Just like POSIX
710
   ftruncate, returns 0 on success, -1 on failure.  */
711
 
712
int
713
unit_truncate (gfc_unit * u, gfc_offset pos, st_parameter_common * common)
714
{
715
  int ret;
716
 
717
  /* Make sure format buffer is flushed.  */
718
  if (u->flags.form == FORM_FORMATTED)
719
    {
720
      if (u->mode == READING)
721
        pos += fbuf_reset (u);
722
      else
723
        fbuf_flush (u, u->mode);
724
    }
725
 
726
  /* struncate() should flush the stream buffer if necessary, so don't
727
     bother calling sflush() here.  */
728
  ret = struncate (u->s, pos);
729
 
730
  if (ret != 0)
731
    generate_error (common, LIBERROR_OS, NULL);
732
  else
733
    {
734
      u->endfile = AT_ENDFILE;
735
      u->flags.position = POSITION_APPEND;
736
    }
737
 
738
  return ret;
739
}
740
 
741
 
742
/* filename_from_unit()-- If the unit_number exists, return a pointer to the
743
   name of the associated file, otherwise return the empty string.  The caller
744
   must free memory allocated for the filename string.  */
745
 
746
char *
747
filename_from_unit (int n)
748
{
749
  char *filename;
750
  gfc_unit *u;
751
  int c;
752
 
753
  /* Find the unit.  */
754
  u = unit_root;
755
  while (u != NULL)
756
    {
757
      c = compare (n, u->unit_number);
758
      if (c < 0)
759
        u = u->left;
760
      if (c > 0)
761
        u = u->right;
762
      if (c == 0)
763
        break;
764
    }
765
 
766
  /* Get the filename.  */
767
  if (u != NULL)
768
    {
769
      filename = (char *) get_mem (u->file_len + 1);
770
      unpack_filename (filename, u->file, u->file_len);
771
      return filename;
772
    }
773
  else
774
    return (char *) NULL;
775
}
776
 
777
void
778
finish_last_advance_record (gfc_unit *u)
779
{
780
 
781
  if (u->saved_pos > 0)
782
    fbuf_seek (u, u->saved_pos, SEEK_CUR);
783
 
784
  if (!(u->unit_number == options.stdout_unit
785
        || u->unit_number == options.stderr_unit))
786
    {
787
#ifdef HAVE_CRLF
788
      const int len = 2;
789
#else
790
      const int len = 1;
791
#endif
792
      char *p = fbuf_alloc (u, len);
793
      if (!p)
794
        os_error ("Completing record after ADVANCE_NO failed");
795
#ifdef HAVE_CRLF
796
      *(p++) = '\r';
797
#endif
798
      *p = '\n';
799
    }
800
 
801
  fbuf_flush (u, u->mode);
802
}
803
 
804
/* Assign a negative number for NEWUNIT in OPEN statements.  */
805
GFC_INTEGER_4
806
get_unique_unit_number (st_parameter_open *opp)
807
{
808
  GFC_INTEGER_4 num;
809
 
810
#ifdef HAVE_SYNC_FETCH_AND_ADD
811
  num = __sync_fetch_and_add (&next_available_newunit, -1);
812
#else
813
  __gthread_mutex_lock (&unit_lock);
814
  num = next_available_newunit--;
815
  __gthread_mutex_unlock (&unit_lock);
816
#endif
817
 
818
  /* Do not allow NEWUNIT numbers to wrap.  */
819
  if (num > GFC_FIRST_NEWUNIT)
820
    {
821
      generate_error (&opp->common, LIBERROR_INTERNAL, "NEWUNIT exhausted");
822
      return 0;
823
    }
824
  return num;
825
}

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.