1 /* Copyright (C) 2002, 2003, 2005, 2007, 2008 Free Software Foundation, Inc.
2 Contributed by Andy Vaught
3 F2003 I/O support contributed by Jerry DeLisle
5 This file is part of the GNU Fortran 95 runtime library (libgfortran).
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)
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
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.
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. */
37 UNIT_LOCK is a master lock, protecting UNIT_ROOT tree and UNIT_CACHE.
38 Concurrent use of different units should be supported, so
39 each unit has its own lock, LOCK.
40 Open should be atomic with its reopening of units and list_read.c
41 in several places needs find_unit another unit while holding stdin
42 unit's lock, so it must be possible to acquire UNIT_LOCK while holding
43 some unit's lock. Therefore to avoid deadlocks, it is forbidden
44 to acquire unit's private locks while holding UNIT_LOCK, except
45 for freshly created units (where no other thread can get at their
46 address yet) or when using just trylock rather than lock operation.
47 In addition to unit's private lock each unit has a WAITERS counter
48 and CLOSED flag. WAITERS counter must be either only
49 atomically incremented/decremented in all places (if atomic builtins
50 are supported), or protected by UNIT_LOCK in all places (otherwise).
51 CLOSED flag must be always protected by unit's LOCK.
52 After finding a unit in UNIT_CACHE or UNIT_ROOT with UNIT_LOCK held,
53 WAITERS must be incremented to avoid concurrent close from freeing
54 the unit between unlocking UNIT_LOCK and acquiring unit's LOCK.
55 Unit freeing is always done under UNIT_LOCK. If close_unit sees any
56 WAITERS, it doesn't free the unit but instead sets the CLOSED flag
57 and the thread that decrements WAITERS to zero while CLOSED flag is
58 set is responsible for freeing it (while holding UNIT_LOCK).
59 flush_all_units operation is iterating over the unit tree with
60 increasing UNIT_NUMBER while holding UNIT_LOCK and attempting to
61 flush each unit (and therefore needs the unit's LOCK held as well).
62 To avoid deadlocks, it just trylocks the LOCK and if unsuccessful,
63 remembers the current unit's UNIT_NUMBER, unlocks UNIT_LOCK, acquires
64 unit's LOCK and after flushing reacquires UNIT_LOCK and restarts with
65 the smallest UNIT_NUMBER above the last one flushed.
67 If find_unit/find_or_create_unit/find_file/get_unit routines return
68 non-NULL, the returned unit has its private lock locked and when the
69 caller is done with it, it must call either unlock_unit or close_unit
70 on it. unlock_unit or close_unit must be always called only with the
73 /* Subroutines related to units */
77 static gfc_unit
*unit_cache
[CACHE_SIZE
];
78 gfc_offset max_offset
;
80 #ifdef __GTHREAD_MUTEX_INIT
81 __gthread_mutex_t unit_lock
= __GTHREAD_MUTEX_INIT
;
83 __gthread_mutex_t unit_lock
;
86 /* We use these filenames for error reporting. */
88 static char stdin_name
[] = "stdin";
89 static char stdout_name
[] = "stdout";
90 static char stderr_name
[] = "stderr";
92 /* This implementation is based on Stefan Nilsson's article in the
93 * July 1997 Doctor Dobb's Journal, "Treaps in Java". */
95 /* pseudo_random()-- Simple linear congruential pseudorandom number
96 * generator. The period of this generator is 44071, which is plenty
97 * for our purposes. */
102 static int x0
= 5341;
104 x0
= (22611 * x0
+ 10) % 44071;
109 /* rotate_left()-- Rotate the treap left */
112 rotate_left (gfc_unit
* t
)
117 t
->right
= t
->right
->left
;
124 /* rotate_right()-- Rotate the treap right */
127 rotate_right (gfc_unit
* t
)
132 t
->left
= t
->left
->right
;
141 compare (int a
, int b
)
152 /* insert()-- Recursive insertion function. Returns the updated treap. */
155 insert (gfc_unit
*new, gfc_unit
*t
)
162 c
= compare (new->unit_number
, t
->unit_number
);
166 t
->left
= insert (new, t
->left
);
167 if (t
->priority
< t
->left
->priority
)
168 t
= rotate_right (t
);
173 t
->right
= insert (new, t
->right
);
174 if (t
->priority
< t
->right
->priority
)
179 internal_error (NULL
, "insert(): Duplicate key found!");
185 /* insert_unit()-- Create a new node, insert it into the treap. */
190 gfc_unit
*u
= get_mem (sizeof (gfc_unit
));
191 memset (u
, '\0', sizeof (gfc_unit
));
193 #ifdef __GTHREAD_MUTEX_INIT
195 __gthread_mutex_t tmp
= __GTHREAD_MUTEX_INIT
;
199 __GTHREAD_MUTEX_INIT_FUNCTION (&u
->lock
);
201 __gthread_mutex_lock (&u
->lock
);
202 u
->priority
= pseudo_random ();
203 unit_root
= insert (u
, unit_root
);
208 /* destroy_unit_mutex()-- Destroy the mutex and free memory of unit. */
211 destroy_unit_mutex (gfc_unit
* u
)
213 __gthread_mutex_destroy (&u
->lock
);
219 delete_root (gfc_unit
* t
)
225 if (t
->right
== NULL
)
228 if (t
->left
->priority
> t
->right
->priority
)
230 temp
= rotate_right (t
);
231 temp
->right
= delete_root (t
);
235 temp
= rotate_left (t
);
236 temp
->left
= delete_root (t
);
243 /* delete_treap()-- Delete an element from a tree. The 'old' value
244 * does not necessarily have to point to the element to be deleted, it
245 * must just point to a treap structure with the key to be deleted.
246 * Returns the new root node of the tree. */
249 delete_treap (gfc_unit
* old
, gfc_unit
* t
)
256 c
= compare (old
->unit_number
, t
->unit_number
);
259 t
->left
= delete_treap (old
, t
->left
);
261 t
->right
= delete_treap (old
, t
->right
);
269 /* delete_unit()-- Delete a unit from a tree */
272 delete_unit (gfc_unit
* old
)
274 unit_root
= delete_treap (old
, unit_root
);
278 /* get_external_unit()-- Given an integer, return a pointer to the unit
279 * structure. Returns NULL if the unit does not exist,
280 * otherwise returns a locked unit. */
283 get_external_unit (int n
, int do_create
)
288 __gthread_mutex_lock (&unit_lock
);
290 for (c
= 0; c
< CACHE_SIZE
; c
++)
291 if (unit_cache
[c
] != NULL
&& unit_cache
[c
]->unit_number
== n
)
300 c
= compare (n
, p
->unit_number
);
309 if (p
== NULL
&& do_create
)
317 for (c
= 0; c
< CACHE_SIZE
- 1; c
++)
318 unit_cache
[c
] = unit_cache
[c
+ 1];
320 unit_cache
[CACHE_SIZE
- 1] = p
;
325 /* Newly created units have their lock held already
326 from insert_unit. Just unlock UNIT_LOCK and return. */
327 __gthread_mutex_unlock (&unit_lock
);
335 if (! __gthread_mutex_trylock (&p
->lock
))
337 /* assert (p->closed == 0); */
338 __gthread_mutex_unlock (&unit_lock
);
342 inc_waiting_locked (p
);
345 __gthread_mutex_unlock (&unit_lock
);
349 __gthread_mutex_lock (&p
->lock
);
352 __gthread_mutex_lock (&unit_lock
);
353 __gthread_mutex_unlock (&p
->lock
);
354 if (predec_waiting_locked (p
) == 0)
355 destroy_unit_mutex (p
);
359 dec_waiting_unlocked (p
);
368 return get_external_unit (n
, 0);
373 find_or_create_unit (int n
)
375 return get_external_unit (n
, 1);
380 get_internal_unit (st_parameter_dt
*dtp
)
383 gfc_offset start_record
= 0;
385 /* Allocate memory for a unit structure. */
387 iunit
= get_mem (sizeof (gfc_unit
));
390 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
394 memset (iunit
, '\0', sizeof (gfc_unit
));
395 #ifdef __GTHREAD_MUTEX_INIT
397 __gthread_mutex_t tmp
= __GTHREAD_MUTEX_INIT
;
401 __GTHREAD_MUTEX_INIT_FUNCTION (&iunit
->lock
);
403 __gthread_mutex_lock (&iunit
->lock
);
405 iunit
->recl
= dtp
->internal_unit_len
;
407 /* For internal units we set the unit number to -1.
408 Otherwise internal units can be mistaken for a pre-connected unit or
409 some other file I/O unit. */
410 iunit
->unit_number
= -1;
412 /* Set up the looping specification from the array descriptor, if any. */
414 if (is_array_io (dtp
))
416 iunit
->rank
= GFC_DESCRIPTOR_RANK (dtp
->internal_unit_desc
);
417 iunit
->ls
= (array_loop_spec
*)
418 get_mem (iunit
->rank
* sizeof (array_loop_spec
));
419 dtp
->internal_unit_len
*=
420 init_loop_spec (dtp
->internal_unit_desc
, iunit
->ls
, &start_record
);
422 start_record
*= iunit
->recl
;
425 /* Set initial values for unit parameters. */
427 iunit
->s
= open_internal (dtp
->internal_unit
- start_record
,
428 dtp
->internal_unit_len
, -start_record
);
429 iunit
->bytes_left
= iunit
->recl
;
430 iunit
->last_record
=0;
432 iunit
->current_record
=0;
434 iunit
->endfile
= NO_ENDFILE
;
436 /* Set flags for the internal unit. */
438 iunit
->flags
.access
= ACCESS_SEQUENTIAL
;
439 iunit
->flags
.action
= ACTION_READWRITE
;
440 iunit
->flags
.blank
= BLANK_UNSPECIFIED
;
441 iunit
->flags
.form
= FORM_FORMATTED
;
442 iunit
->flags
.pad
= PAD_YES
;
443 iunit
->flags
.status
= STATUS_UNSPECIFIED
;
444 iunit
->flags
.sign
= SIGN_SUPPRESS
;
445 iunit
->flags
.decimal
= DECIMAL_POINT
;
446 iunit
->flags
.encoding
= ENCODING_DEFAULT
;
447 iunit
->flags
.async
= ASYNC_NO
;
449 /* Initialize the data transfer parameters. */
451 dtp
->u
.p
.advance_status
= ADVANCE_YES
;
452 dtp
->u
.p
.seen_dollar
= 0;
454 dtp
->u
.p
.pending_spaces
= 0;
455 dtp
->u
.p
.max_pos
= 0;
458 /* This flag tells us the unit is assigned to internal I/O. */
460 dtp
->u
.p
.unit_is_internal
= 1;
466 /* free_internal_unit()-- Free memory allocated for internal units if any. */
468 free_internal_unit (st_parameter_dt
*dtp
)
470 if (!is_internal_unit (dtp
))
473 if (dtp
->u
.p
.current_unit
!= NULL
)
475 if (dtp
->u
.p
.current_unit
->ls
!= NULL
)
476 free_mem (dtp
->u
.p
.current_unit
->ls
);
478 if (dtp
->u
.p
.current_unit
->s
)
479 free_mem (dtp
->u
.p
.current_unit
->s
);
481 destroy_unit_mutex (dtp
->u
.p
.current_unit
);
487 /* get_unit()-- Returns the unit structure associated with the integer
488 * unit or the internal file. */
491 get_unit (st_parameter_dt
*dtp
, int do_create
)
494 if ((dtp
->common
.flags
& IOPARM_DT_HAS_INTERNAL_UNIT
) != 0)
495 return get_internal_unit(dtp
);
497 /* Has to be an external unit */
499 dtp
->u
.p
.unit_is_internal
= 0;
500 dtp
->internal_unit_desc
= NULL
;
502 return get_external_unit (dtp
->common
.unit
, do_create
);
506 /*************************/
507 /* Initialize everything */
515 #ifndef __GTHREAD_MUTEX_INIT
516 __GTHREAD_MUTEX_INIT_FUNCTION (&unit_lock
);
519 if (options
.stdin_unit
>= 0)
521 u
= insert_unit (options
.stdin_unit
);
522 u
->s
= input_stream ();
524 u
->flags
.action
= ACTION_READ
;
526 u
->flags
.access
= ACCESS_SEQUENTIAL
;
527 u
->flags
.form
= FORM_FORMATTED
;
528 u
->flags
.status
= STATUS_OLD
;
529 u
->flags
.blank
= BLANK_NULL
;
530 u
->flags
.pad
= PAD_YES
;
531 u
->flags
.position
= POSITION_ASIS
;
532 u
->flags
.sign
= SIGN_SUPPRESS
;
533 u
->flags
.decimal
= DECIMAL_POINT
;
534 u
->flags
.encoding
= ENCODING_DEFAULT
;
535 u
->flags
.async
= ASYNC_NO
;
537 u
->recl
= options
.default_recl
;
538 u
->endfile
= NO_ENDFILE
;
540 u
->file_len
= strlen (stdin_name
);
541 u
->file
= get_mem (u
->file_len
);
542 memmove (u
->file
, stdin_name
, u
->file_len
);
544 __gthread_mutex_unlock (&u
->lock
);
547 if (options
.stdout_unit
>= 0)
549 u
= insert_unit (options
.stdout_unit
);
550 u
->s
= output_stream ();
552 u
->flags
.action
= ACTION_WRITE
;
554 u
->flags
.access
= ACCESS_SEQUENTIAL
;
555 u
->flags
.form
= FORM_FORMATTED
;
556 u
->flags
.status
= STATUS_OLD
;
557 u
->flags
.blank
= BLANK_NULL
;
558 u
->flags
.position
= POSITION_ASIS
;
559 u
->flags
.sign
= SIGN_SUPPRESS
;
560 u
->flags
.decimal
= DECIMAL_POINT
;
561 u
->flags
.encoding
= ENCODING_DEFAULT
;
562 u
->flags
.async
= ASYNC_NO
;
564 u
->recl
= options
.default_recl
;
565 u
->endfile
= AT_ENDFILE
;
567 u
->file_len
= strlen (stdout_name
);
568 u
->file
= get_mem (u
->file_len
);
569 memmove (u
->file
, stdout_name
, u
->file_len
);
573 __gthread_mutex_unlock (&u
->lock
);
576 if (options
.stderr_unit
>= 0)
578 u
= insert_unit (options
.stderr_unit
);
579 u
->s
= error_stream ();
581 u
->flags
.action
= ACTION_WRITE
;
583 u
->flags
.access
= ACCESS_SEQUENTIAL
;
584 u
->flags
.form
= FORM_FORMATTED
;
585 u
->flags
.status
= STATUS_OLD
;
586 u
->flags
.blank
= BLANK_NULL
;
587 u
->flags
.position
= POSITION_ASIS
;
588 u
->flags
.sign
= SIGN_SUPPRESS
;
589 u
->flags
.decimal
= DECIMAL_POINT
;
590 u
->flags
.encoding
= ENCODING_DEFAULT
;
591 u
->flags
.async
= ASYNC_NO
;
593 u
->recl
= options
.default_recl
;
594 u
->endfile
= AT_ENDFILE
;
596 u
->file_len
= strlen (stderr_name
);
597 u
->file
= get_mem (u
->file_len
);
598 memmove (u
->file
, stderr_name
, u
->file_len
);
600 fbuf_init (u
, 256); /* 256 bytes should be enough, probably not doing
601 any kind of exotic formatting to stderr. */
603 __gthread_mutex_unlock (&u
->lock
);
606 /* Calculate the maximum file offset in a portable manner.
607 * max will be the largest signed number for the type gfc_offset.
609 * set a 1 in the LSB and keep a running sum, stopping at MSB-1 bit. */
612 for (i
= 0; i
< sizeof (max_offset
) * 8 - 1; i
++)
613 max_offset
= max_offset
+ ((gfc_offset
) 1 << i
);
618 close_unit_1 (gfc_unit
*u
, int locked
)
622 /* If there are previously written bytes from a write with ADVANCE="no"
623 Reposition the buffer before closing. */
624 if (u
->previous_nonadvancing_write
)
625 finish_last_advance_record (u
);
627 rc
= (u
->s
== NULL
) ? 0 : sclose (u
->s
) == FAILURE
;
631 __gthread_mutex_lock (&unit_lock
);
633 for (i
= 0; i
< CACHE_SIZE
; i
++)
634 if (unit_cache
[i
] == u
)
635 unit_cache
[i
] = NULL
;
647 __gthread_mutex_unlock (&u
->lock
);
649 /* If there are any threads waiting in find_unit for this unit,
650 avoid freeing the memory, the last such thread will free it
653 destroy_unit_mutex (u
);
656 __gthread_mutex_unlock (&unit_lock
);
662 unlock_unit (gfc_unit
*u
)
664 __gthread_mutex_unlock (&u
->lock
);
667 /* close_unit()-- Close a unit. The stream is closed, and any memory
668 * associated with the stream is freed. Returns nonzero on I/O error.
669 * Should be called with the u->lock locked. */
672 close_unit (gfc_unit
*u
)
674 return close_unit_1 (u
, 0);
678 /* close_units()-- Delete units on completion. We just keep deleting
679 * the root of the treap until there is nothing left.
680 * Not sure what to do with locking here. Some other thread might be
681 * holding some unit's lock and perhaps hold it indefinitely
682 * (e.g. waiting for input from some pipe) and close_units shouldn't
683 * delay the program too much. */
688 __gthread_mutex_lock (&unit_lock
);
689 while (unit_root
!= NULL
)
690 close_unit_1 (unit_root
, 1);
691 __gthread_mutex_unlock (&unit_lock
);
695 /* update_position()-- Update the flags position for later use by inquire. */
698 update_position (gfc_unit
*u
)
700 if (file_position (u
->s
) == 0)
701 u
->flags
.position
= POSITION_REWIND
;
702 else if (file_length (u
->s
) == file_position (u
->s
))
703 u
->flags
.position
= POSITION_APPEND
;
705 u
->flags
.position
= POSITION_ASIS
;
709 /* filename_from_unit()-- If the unit_number exists, return a pointer to the
710 name of the associated file, otherwise return the empty string. The caller
711 must free memory allocated for the filename string. */
714 filename_from_unit (int n
)
724 c
= compare (n
, u
->unit_number
);
733 /* Get the filename. */
736 filename
= (char *) get_mem (u
->file_len
+ 1);
737 unpack_filename (filename
, u
->file
, u
->file_len
);
741 return (char *) NULL
;
745 finish_last_advance_record (gfc_unit
*u
)
748 if (u
->saved_pos
> 0)
749 fbuf_seek (u
, u
->saved_pos
);
753 if (!(u
->unit_number
== options
.stdout_unit
754 || u
->unit_number
== options
.stderr_unit
))
758 const char crlf
[] = "\r\n";
764 if (swrite (u
->s
, &crlf
[2-len
], &len
) != 0)
765 os_error ("Completing record after ADVANCE_NO failed");