int s_wsfi64_mp (icilist64 *a, unit** fu)
{
int n;
unit *ftnunit;
if (!f77init)
f_init ();
ftnunit = *fu = Internal_File;
while (fu != &f77curunit && test_and_set( &ftnunit->lock_unit, 1L ))
;
#ifdef I90
ftnunit->f90sw = 0;
#endif
if (n = c_si (a, ftnunit)) {
return (n);
}
ftnunit->uwrt |= WR_OP;
ftnunit->f77doed = w_ed;
ftnunit->f77doned = w_ned;
ftnunit->f77putn = z_putc;
ftnunit->f77ungetn = z_ungetc;
ftnunit->f77donewrec = z_wSL;
ftnunit->f77dorevert = ftnunit->f77doend = z_wnew;
return (0);
}
int __s_rsfi_com (icilist64 *a, unit **fu, int f90sw)
{
int n;
unit *ftnunit;
if (!f77init)
f_init ();
ftnunit = *fu = Internal_File;
while (fu != &f77curunit && test_and_set( &ftnunit->lock_unit, 1L ))
;
#ifdef I90
ftnunit->f90sw = f90sw;
#endif
if (n = c_si (a, ftnunit))
return (n);
ftnunit->uwrt &= ~WR_OP;
ftnunit->f77doed = rd_ed;
ftnunit->f77doned = rd_ned;
ftnunit->f77getn = z_getc;
ftnunit->f77gets = z_gets;
ftnunit->f77ungetn = z_ungetc;
ftnunit->f77donewrec = z_rSL;
ftnunit->f77dorevert = ftnunit->f77doend = z_rnew;
ftnunit->f77recend = ftnunit->f77errlist.icirlen;
return (0);
}
int
c_sue (cilist64 *a, unit **fu)
{
unit *ftnunit;
if ((ftnunit = map_luno (a->ciunit)) == NULL)
errret(a->cierr, 101, "startio");
while (fu != &f77curunit && test_and_set( &ftnunit->lock_unit, 1L ))
;
*fu = ftnunit;
if (ftnunit->uconn <= 0 && fk_open (SEQ, UNF, a->ciunit)) {
ftnunit->uconn = 0;
errret(a->cierr, 114, "sue");
}
ftnunit->f77errlist.cierr = a->cierr;
ftnunit->f77errlist.ciend = a->ciend;
ftnunit->f77errlist.cieor = a->cieor;
ftnunit->f77errlist.cisize = a->cisize;
ftnunit->f77errlist.iciunit = 0;
if (ftnunit->ufmt > 0) {
if ((ftnunit->ufd == stdin || ftnunit->ufd == stdout ||
ftnunit->ufd == stderr) && ftnunit->useek)
/* these guys can be redirected so it might not be an error,
** let's assume it is correct here. If there is any error
** it can be caught later
*/
ftnunit->ufmt = 1;
else
errret(a->cierr, 103, "sue");
}
if (!ftnunit->useek && ftnunit->uacc == SEQUENTIAL)
errret(a->cierr, 103, "sue");
return (0);
}
void *dec (void *parameter) {
long int cont, aux;
for (cont = 0; cont < REPETITIONS; cont = cont + 1) {
while(test_and_set(&key));
V = V - 1;
key = 0;
}
printf("-------> dec end (V = %ld)\n", V);
pthread_exit(0);
}
int sthread_sem_try_down(sthread_sem_t *sem) //should obtain the semaphore and return 0 if the semaphore is available, otherwise return non-zero immediately. This function does not cause the caller to block.
{
while (test_and_set(sem->mutex))
sched_yield();
if (sem->count > 0) {
sem->count--;
*(sem->mutex) = 0;
return 0;
}
*(sem->mutex) = 0;
return -1;
}
int sthread_mutex_lock(sthread_mutex_t *mutex)
{
sthread_t ptr_this_thread = sthread_self();
//fighting for the right to modify Q
while(test_and_set(&mutex->M)){}
//after this I am now the only one
//to modify the passed in mutex
//therefore I should go ahead and
//modify the lock and Q if needed
//check if I should go into critical
//section
struct queue *pQ = &mutex->Q;
if(Q_empty(pQ))
{
//lock available
Q_push(pQ, ptr_this_thread);
mutex->M = 0; // I am done with Q; others can come and look / change Q.
return 0; //this_thread will go into critical section
}
else
{
//lock not available
//there are someone or myself before me in the Q
//if it is myself in criticle section
//I shoud not wait for myself to wake myself up
//I will increment counter and keep running in criticle seciton
//else
//someone else is before me in the Q
//either he is sleeping (he is not the 1st)
//or he is in the critical section now (he is the 1st and
//I am the 2nd in Q)
//either way I should go to bed and wait for him to wake me up
if(Q_first(pQ)->ptr_thread == ptr_this_thread)
{
Q_first(pQ)->count++; //Trying to acquire the lock own by myself
//take down this attempt and keep myself in
//criticle section
mutex->M = 0; //I am done with lock; others can now check / modify lock.
}
else
{
Q_push(pQ, ptr_this_thread);
mutex->M = 0;
sthread_suspend(); //Other thread is in criticle section
//I should go to bed and sleep
return 0; //the moment I am woken up will
//return 0 to caller
}
}
}
int
f77nowreading (unit *x)
{
XINT64 loc;
FILE *nfd;
if (x->uacc == KEYED) goto read_mode;
if (!(x->uwrt & WR_OP))
return(0);
if (x->uwrt == WR_OP) {
/* write-only file */
loc = FTELL (x->ufd);
if (!loc) {
/* obtain exclusive lock for special I/O operation */
while (test_and_set( &io_lock, 1L ))
;
nfd = freopen (x->ufnm, "r", x->ufd);
io_lock = 0;
if (!nfd)
return(1);
} else {
/* obtain exclusive lock for special I/O operation */
while (test_and_set( &io_lock, 1L ))
;
nfd = freopen (x->ufnm, "r+", x->ufd);
io_lock = 0;
if (!nfd)
return (1);
x->uwrt = WR_READY;
FSEEK (x->ufd, loc, SEEK_SET);
}
}
else
fseek (x->ufd, 0L, SEEK_CUR); /* dummy seek to reset FILE structure */
read_mode:
x->uwrt &= ~WR_OP;
return (0);
}
int sthread_sem_down(sthread_sem_t *sem)//will decrement the semaphore by 1 if the value of which is greater than 0 (these two steps must be atomic), or it will block until another thread releases the semaphore and wakes it up.
{
while (test_and_set(sem->mutex))
sched_yield();
if(sem->count == 0){
push(sem->sem_queue, sthread_self());
*(sem->mutex) = 0;
sthread_suspend();
} else {
sem->count--;
*(sem->mutex) = 0;
}
return 0;
}
void *resta (void *argumento) {
long int cont;
long int aux;
while(test_and_set(&llave));
for (cont = 0; cont < REPETICIONES; cont = cont + 1) {
V = V - 1;
}
llave = 0;
printf("-------> Fin RESTA (V = %ld)\n", V);
pthread_exit(0);
}
int sthread_mutex_destroy(sthread_mutex_t *mutex)
{
struct queue *pQ = &mutex->Q;
//fighting for the right to own lock
while(test_and_set(&mutex->M)){}
if(Q_empty(pQ))
{
free(mutex);
return 0;
}
else
{
//destroy mutex error: Q is not empty;
return -1;
}
}
int _mtx_trylock(mtx_t * mtx, char * whr)
#endif
{
int ticket;
int retval;
if (MTX_OPT(mtx, MTX_OPT_DINT)) {
cpu_istate = get_interrupt_state();
disable_interrupt();
}
switch (mtx->mtx_type) {
case MTX_TYPE_SPIN:
retval = test_and_set((int *)(&mtx->mtx_lock));
break;
case MTX_TYPE_TICKET:
ticket = atomic_inc(&mtx->ticket.queue);
if (atomic_read(&mtx->ticket.dequeue) == ticket) {
mtx->mtx_lock = 1;
return 0; /* Got it */
} else {
atomic_dec(&mtx->ticket.queue);
if (MTX_OPT(mtx, MTX_OPT_DINT))
set_interrupt_state(cpu_istate);
return 1; /* No luck */
}
break;
default:
MTX_TYPE_NOTSUP();
if (MTX_OPT(mtx, MTX_OPT_DINT))
set_interrupt_state(cpu_istate);
return -ENOTSUP;
}
/* Handle priority ceiling. */
priceil_set(mtx);
#ifdef configLOCK_DEBUG
mtx->mtx_ldebug = whr;
#endif
return retval;
}
int sthread_sem_up(sthread_sem_t *sem)//will increment the value of semaphore by 1 if nobody is being blocked on it; if there are threads waiting for the semaphore, it should wake up one of the waiting threads; these two steps must also be atomic.
{
while (test_and_set(sem->mutex))
sched_yield();
sthread_t thread = pop(sem->sem_queue);
if (thread) {
sthread_wake(thread);
}
else {
sem->count++;
}
*(sem->mutex) = 0;
return 0;
}
static int
f_unl_com (alist *a, int lock)
#endif
{
unit *ftnunit = find_luno(a->aunit);
if (ftnunit == NULL)
err (a->aerr, 101, "unlock");
while (lock && test_and_set( &ftnunit->lock_unit, 1L ))
;
if (ftnunit->uconn > 0) {
if (ftnunit->uacc != KEYED)
errret(a->aerr, 163, "unlock");
if (isrelease (ftnunit->isfd) < SUCCESS)
ierrret(a->aerr, iserrno, "unlock");
}
else
err (a->aerr, 101, "delete");
if (lock) ftnunit->lock_unit = 0;
return 0;
}
static int
c_dfe (cilist64 *a, unit **fu)
{
unit *ftnunit;
extern FILE *debugfile;
if ((ftnunit = *fu = find_luno (a->ciunit)) == NULL)
if (fk_open (DIR, FMT, a->ciunit))
err(a->cierr, 104, "dfe");
while (fu != &f77curunit && test_and_set( &ftnunit->lock_unit, 1L ))
;
ftnunit->f77errlist.cierr = a->cierr;
ftnunit->f77errlist.ciend = a->ciend;
ftnunit->f77errlist.cieor = a->cieor;
ftnunit->f77errlist.cisize = a->cisize;
ftnunit->f77errlist.iciunit = 0;
ftnunit->f77cursor = ftnunit->f77recpos = ftnunit->f77recend = 0;
ftnunit->f77scale = 0;
ftnunit->ufd = ftnunit->ufd;
if (!ftnunit->ufmt)
err(a->cierr, 102, "dfe")
if (!ftnunit->useek)
err(a->cierr, 104, "dfe")
if (a->cirec < 1)
err(a->cierr, 168, "dfe");
ftnunit->f77fmtbuf = a->cifmt;
/* fprintf( debugfile, "At position %d for thread %d, oldrec = %d, newrec = %d\n", ftell( ftnunit->ufd ), mp_my_threadnum_(), ftnunit->uirec, a->cirec ); */
if (FSEEK (ftnunit->ufd, (ftnll)ftnunit->url * (a->cirec - 1), 0))
err( a->cierr, errno, "Direct formatted");
if (ftnunit->uassocv)
set_var ((ftnintu *)ftnunit->uassocv,
ftnunit->umask, ASSOCV, a->cirec);
ftnunit->uend = 0;
return (0);
}
int sthread_mutex_trylock(sthread_mutex_t *mutex)
{
sthread_t ptr_this_thread = sthread_self();
//fighting for the right to modify Q
while(test_and_set(&mutex->M)){}
//after this I am now the only one
//to modify the passed in mutex
//therefore I should go ahead and
//modify the lock and Q if needed
//check if I should go into critical
//section
struct queue *pQ = &mutex->Q;
if(Q_empty(pQ))
{
//lock available
Q_push(pQ, ptr_this_thread);
mutex->M = 0; // I am done with Q; others can come and look / change Q.
//this_thread will go into critical section
return 0;
}
else
{
//lock not available
if(Q_first(pQ)->ptr_thread == ptr_this_thread)
{
Q_first(pQ)->count++;//Trying to acquire the lock own by myself
//take down this attempt and keep myself in
//criticle section
mutex->M = 0; //I am done with lock; others can now check / modify lock.
}
//do not block caller
//return non-zero indication lock not available
return -1;
}
}
int sthread_mutex_unlock(sthread_mutex_t *mutex)
{
//fighting for the right to modify Q
while(test_and_set(&mutex->M) == 1){}
//I am the only one checking mutex
//can modify Q
struct queue *pQ = &mutex->Q;
if(Q_first(pQ)->count == 1)
{
Q_pop(pQ);
if(Q_empty(pQ) == 0)
{
//Queue is not empty
//there are other threads sleeping
//int the Q
sthread_wake(Q_first(pQ)->ptr_thread);
}
else
{
//I am the last one int the Q
//Do nothing
}
return 0;
}
else if( Q_first(pQ)->count > 1)
{
//I have acquired the lock owned by me
//more than once need to unlock
Q_first(pQ)->count--;
}
else
{
// printf("Bad!! count is 0 or less\n");
return -1;
}
}
unit *
map_luno(ftnint luno)
{
register int i, space_available;
register unit *a;
static unit *f77curunit = 0;
unit *ftnunit;
static unsigned long expand_table_lock = 0;
if (!f77init)
f_init ();
/* THe following region is critical in terms of performance. A lock
should not be here at all else it would effect every single READ/WRITE
operation */
if (f77curunit) {
ftnunit = f77curunit;
if (ftnunit->luno == luno && ftnunit->uconn) {
return (ftnunit); /* has just been mapped */
}
}
/* Find unit if it has been opened/connected */
for (i = 0, a = f77units; i < space_assigned; i++, a++) {
if (a->luno == luno && a->uconn) {
return (a);
}
}
/* The unit has not been opened. The following regionis a critical
region and a lock must be obtained before entering it
*/
while (test_and_set( &expand_table_lock, 1L ))
;
/* Look for a slot which has been disconnected. We try to use every
single available slot upfront so that the value of space_assigned
is small and speed up the search in the loop above
*/
for (i = 0, a = f77units; i < space_assigned; i++, a++)
if (a->uconn == 0) {
space_available = i;
goto unused_slot;
}
if (space_assigned >= mxunit) {
int old_mxunit = mxunit;
int ii, nthreads;
/* Open new file in case there is no disconnected slot available */
/* Enlarge the table */
/* This is done only when the table needs to be enlarged, i.e.
very rarely, so we can afford to have test_and_set() called for
single process I/O here with almost no performance penalty
*/
nthreads = prctl( PR_GETNSHARE );
if (nthreads > 1) {
/* cannot do reallow while multiple threads are running as some
of the thread might be using pointers to the old f77units
*/
fprintf( stderr, "Exceeding %d opened files while running in MP I/O mode, please set the environment FORTRAN_OPENED_UNITS to a higher number then rerun the program\n", mxunit );
abort();
}
i = mxunit;
f77curunit = f77units = (unit *) realloc (f77units, (mxunit <<= 1) *
(sizeof (unit)));
memset( &f77units[i], 0, (size_t) i*(sizeof (unit)) );
if (f77units == 0) {
expand_table_lock = 0;
return (NULL);
}
/* Resetting Internal_File value to the new realloc'ed table */
for (ii = 0, a = f77units; ii < old_mxunit; ii++, a++)
if (a->luno == -1) {
Internal_File = a;
break;
}
space_assigned = old_mxunit;
}
space_available = space_assigned++;
unused_slot:
/* fprintf(stderr, "Assigning slot %d to unit %d\n", space_available, luno ); */
a = f77units + space_available;
/* Clear unit control block everytime a new one is assigned to
* avoid having garbage in it. */
memset (a, '\0', sizeof (unit));
a->luno = luno;
a->uconn = -1; /* make sure no other threads take this slot
without really marking it as connected */
a->ualias = a;
f77curunit = a;
expand_table_lock = 0; /* unlock */
return (a);
}
int
f77nowwriting (unit *x)
{
XINT64 loc;
FILE *nfd;
#ifdef I90
if (x->ureadonly || x->uaction == READONLY) {
#else
if (x->ureadonly) {
#endif
x->uwrt |= WR_OP;
return (1);
}
if (x->uacc == KEYED) goto write_mode;
if (x->uwrt & WR_OP)
return(0);
if ((x->uwrt & RW_FILE) == 0) {
loc = FTELL (x->ufd);
if (!loc && x->uacc == SEQUENTIAL) {
/* obtain exclusive lock for special I/O operation */
while (test_and_set( &io_lock, 1L ))
;
nfd = freopen (x->ufnm, "w", x->ufd);
io_lock = 0;
if (!nfd)
return(1);
} else {
/* obtain exclusive lock for special I/O operation */
while (test_and_set( &io_lock, 1L ))
;
nfd = freopen (x->ufnm, "r+", x->ufd);
io_lock = 0;
if (nfd)
x->uwrt = WR_READY;
else {
/* obtain exclusive lock for special I/O operation */
while (test_and_set( &io_lock, 1L ))
;
nfd = freopen (x->ufnm, "w+", x->ufd);
io_lock = 0;
if (!nfd)
return (1);
}
#ifdef I90
/* When doing a write after a nonadvancing read the file pointer needs *
* to be changed to the correct position. */
if ( x->f90sw == 1 && x->f90nadv == 1 ) {
loc = loc - (long)(x->f77recend + 1) + (long)x->f77recpos;
}
#endif
FSEEK (x->ufd, loc, SEEK_SET);
}
} else {
fseek (x->ufd, 0L, SEEK_CUR); /* dummy seek to reset FILE structure */
}
write_mode:
x->uwrt |= WR_OP;
return (0);
}
Helping_lock::Status NO_INSTRUMENT
Helping_lock::lock ()
{
return test_and_set();
}
void mutex_lock(int *mutex) {
while(test_and_set(*mutex));
// printf("locked\n");
*mutex =LOCKED;
}
static ftnint
f_clos_com (cllist *a, int lock)
{
unit *ftnunit;
char *cbuf, c, buf[256], tbuf[12];
int n, istat;
if ((ftnunit = find_luno (a->cunit)) == NULL) {
return 0;
}
while (lock && test_and_set( &ftnunit->lock_unit, 1L ))
;
if (ftnunit->uconn <= 0) {
/* could be disconnected by other threads */
ftnunit->uconn = 0;
ftnunit->lock_unit = 0;
return(0);
}
ftnunit->uend = 0;
if (cbuf = a->csta)
switch (up_low (*cbuf++)) {
case 'd':
ftnunit->udisp = DELETE;
break;
case 'p':
ftnunit->udisp = PRINT;
goto checkdelete;
/*
* Fix BN 7869.
* This is very sloppy code for checking the specifiers to close. Currently
* both DISP and STATUS cannot be used as specifiers to close. This is a kludge
* that allows SAVE to be passed and treats it like KEEP instead of SUBMIT.
* ---ravi--- 10/30/91
* case 's': ftnunit->udisp = SUBMIT;
*/
case 's':
ftnunit->udisp = up_low (*cbuf) == 'a' ? KEEP : SUBMIT;
checkdelete:
while (c = (*cbuf++))
if ((c == '/') && (c = (*cbuf)) && (up_low (c) == 'd'))
ftnunit->udisp |= DELETE;
break;
case 'k':
if (ftnunit->uscrtch == 1)
err(a->cerr, F_ERKEEPSCRATCH, "close");
default:
ftnunit->udisp = KEEP;
}
if (ftnunit->uscrtch == 1)
ftnunit->udisp |= DELETE;
if (ftnunit->uacc == KEYED) {
n = idxclose(ftnunit, a->cerr);
ftnunit->lock_unit = 0;
return (n);
}
#ifdef I90
/* If in Fortran-90 nonadvancing mode, write endfile record (\n only). */
if ( (ftnunit->f90sw == 1) && (ftnunit->f90nadv == 1) && (ftnunit->uwrt & WR_OP) ) {
putc ('\n', ftnunit->ufd);
ftnunit->f90nadv = 0;
}
#endif
if (ftnunit->ucc == CC_FORTRAN && ftnunit->ucchar)
putc (ftnunit->ucchar, ftnunit->ufd);
if (ftnunit->ufd == stdin || ftnunit->ufd == stdout || ftnunit->ufd == stderr) {
/*
* Don't close stdin, stdout, and stderr otherwise other files
* can be opened using those pointers and caused a lot of confusion
*/
fflush(ftnunit->ufd);
goto cont;
}
if (ftnunit->uwrt & WR_OP)
(void) t_runc (ftnunit, a->cerr);
/* Close the file. */
if ((ftnunit->uacc == DIRECT) && (ftnunit->ufmt == 0)) { /* direct unformatted */
while (lock && test_and_set( &io_lock, 1L ))
;
if (ftnunit->uistty) {
_fio_du_close ((int) ftnunit->ufd); /* no error */
} else if (((int)ftnunit->ufd) != _fio_du_close ((int) ftnunit->ufd)) {
io_lock = 0;
if (lock) ftnunit->lock_unit = 0;
err (a->cerr, errno, "close");
}
io_lock = 0;
} else {
if (ftnunit->uistty) { /* have to call isatty() first to get
* correct result */
/* obtain exclusive lock for special I/O operation */
while (lock && test_and_set( &io_lock, 1L ))
;
istat = fclose (ftnunit->ufd);
io_lock = 0;
} else {
/* obtain exclusive lock for special I/O operation */
while (lock && test_and_set( &io_lock, 1L ))
;
istat = fclose (ftnunit->ufd);
io_lock = 0;
if (istat) {
if (lock) ftnunit->lock_unit = 0;
err (a->cerr, errno, "close");
}
}
}
if (ftnunit->ufnm) {
if (ftnunit->udisp & SUBMIT) {
(void) strcpy (tbuf, "tmp.FXXXXXX");
(void) mktemp (tbuf);
sprintf (buf, "cp %s %s", ftnunit->ufnm, tbuf);
system (buf);
sprintf (buf, "( chmod +x %s; %s; rm %s ) &",
tbuf, tbuf, tbuf);
system (buf);
} else if (ftnunit->udisp & PRINT) {
sprintf (buf, "lpr %s", ftnunit->ufnm);
system (buf);
}
if (ftnunit->udisp & DELETE)
(void) unlink (ftnunit->ufnm); /* SYSDEP */
free (ftnunit->ufnm);
ftnunit->ufnm = NULL;
}
cont:
/*
The following fixes bug #231656. The pointers involved are initialized
to zero (both when originally allocated in f_init() and when reallocated
in map_luno()). So, if non-zero, the buffers must have been allocated,
and we should free them.
*/
if (ftnunit->f77syl) {
free(ftnunit->f77syl);
ftnunit->f77syl = NULL;
}
if (ftnunit->f77fio_buf) {
free(ftnunit->f77fio_buf);
ftnunit->f77fio_buf = NULL;
ftnunit->f77fio_size = 0;
}
if (ftnunit->ukeys) {
free(ftnunit->ukeys);
ftnunit->ukeys = NULL;
}
ftnunit->ufd = NULL;
ftnunit->uconn = 0;
ftnunit->luno = 0;
if (lock) ftnunit->lock_unit = 0;
/* added in MIPS version 2.20 fix bug 6084 BN-8077. Undo 6084 fix */
return (0);
}
int _mtx_lock(mtx_t * mtx, char * whr)
#endif
{
int ticket;
const int sleep_mode = MTX_OPT(mtx, MTX_OPT_SLEEP);
#ifdef configLOCK_DEBUG
unsigned deadlock_cnt = 0;
#endif
if (mtx->mtx_type == MTX_TYPE_TICKET) {
ticket = atomic_inc(&mtx->ticket.queue);
}
if (MTX_OPT(mtx, MTX_OPT_DINT)) {
cpu_istate = get_interrupt_state();
disable_interrupt();
}
while (1) {
#ifdef configLOCK_DEBUG
/*
* TODO Deadlock detection threshold should depend on lock type and
* current priorities.
*/
if (++deadlock_cnt >= configSCHED_HZ * (configKLOCK_DLTHRES + 1)) {
char * lwhr = (mtx->mtx_ldebug) ? mtx->mtx_ldebug : "?";
KERROR(KERROR_DEBUG,
"Deadlock detected:\n%s WAITING\n%s LOCKED\n",
whr, lwhr);
deadlock_cnt = 0;
}
#endif
if (sleep_mode && (current_thread->wait_tim == -2))
return -EWOULDBLOCK;
switch (mtx->mtx_type) {
case MTX_TYPE_SPIN:
if (!test_and_set((int *)(&mtx->mtx_lock)))
goto out;
break;
case MTX_TYPE_TICKET:
if (atomic_read(&mtx->ticket.dequeue) == ticket) {
mtx->mtx_lock = 1;
goto out;
}
thread_yield(THREAD_YIELD_LAZY);
break;
default:
MTX_TYPE_NOTSUP();
if (MTX_OPT(mtx, MTX_OPT_DINT))
set_interrupt_state(cpu_istate);
return -ENOTSUP;
}
#ifdef configMP
cpu_wfe(); /* Sleep until event. */
#endif
}
out:
/* Handle priority ceiling. */
priceil_set(mtx);
#ifdef configLOCK_DEBUG
mtx->mtx_ldebug = whr;
#endif
return 0;
}
static int
f_rew_com (alist *a, int lock)
{
unit *ftnunit;
if ((ftnunit = find_luno (a->aunit)) == NULL)
return(0);
while (lock && test_and_set( &ftnunit->lock_unit, 1L ))
;
if (ftnunit->uacc == KEYED)
errret(a->aerr, 164, "rewind");
if (ftnunit->uconn <= 0) {
ftnunit->lock_unit = 0;
return (0);
}
if (!ftnunit->useek && !ftnunit->uistty)
errret(a->aerr, 106, "rewind");
ftnunit->uend = 0;
/* Need to reset the associate variable to 1 if exists */
if (ftnunit->uassocv)
set_var (ftnunit->uassocv, ftnunit->umask, ASSOCV, (ftnll) 1);
/* Rewind of a direct unformatted file. */
if ((ftnunit->uacc == DIRECT) && (ftnunit->ufmt == 0)) {
if (-1 == lseek ((int) ftnunit->ufd, 0, SEEK_SET)) {
errret(a->aerr, 106, "rewind");
}
/* need to change the internal buffer position in fio_direct_io as well */
_fio_set_seek((int) ftnunit->ufd, (ftnll) 0, 0);
ftnunit->uirec = 0;
ftnunit->lock_unit = 0;
return (1);
}
#ifdef I90
/* Make sure these variables are zeroed out to allow record to be reread. */
ftnunit->f77recpos = 0;
ftnunit->f77recend = 0;
#endif
if (f77vms_flag_[VMS_EF]) { /* rewind to the last endfile record
* or beginning of file */
char buf[513];
XINT64 y, x;
int i, n;
char ch;
/* If last operation was a WRITE, truncate the file and then make
sure that the file mode is switched to READ so the the next
REWIND/BACKSPACE won't truncate the file again
*/
if (ftnunit->uwrt & WR_OP) {
#ifdef I90
/* If in Fortran-90 nonadvancing mode, write endfile record (\n only). */
if (ftnunit->f90sw == 1 && ftnunit->f90nadv == 1 ) {
putc ('\n', ftnunit->ufd);
ftnunit->f90nadv = 0;
}
#endif
(void) t_runc (ftnunit, a->aerr);
/* If the file is in write-only mode make sure that it is readable */
if (f77nowreading(ftnunit))
errret(a->aerr, 106, "rewind");
}
if (ftnunit->ufmt != 1) {
if (ftell (ftnunit->ufd) == 0) {
ftnunit->lock_unit = 0;
return (0); /* already at beginning of file */
}
if (fseek (ftnunit->ufd, (long) (-sizeof (int)), 1) < 0)
errret(a->aerr, 106, "rewind");
for (i = 0;; i++) {
(void) fread ((char *) &n, sizeof (int), 1, ftnunit->ufd);
if (n != 1 || i == 0) {
if (fseek (ftnunit->ufd, (long) (-n - 3 * sizeof (int)), 1)) {
rewind (ftnunit->ufd);
ftnunit->lock_unit = 0;
return (0);
}
} else {
if (fseek (ftnunit->ufd, -(sizeof (int) + 1), 1)) {
rewind (ftnunit->ufd);
ftnunit->lock_unit = 0;
return (0);
}
(void) fread ((char *) &ch, 1, 1, ftnunit->ufd);
if (ch == '\032') {
fseek (ftnunit->ufd, sizeof (int), 1);
ftnunit->lock_unit = 0;
return (0);
}
fseek (ftnunit->ufd, -(2 * sizeof (int) + 1), 1);
}
}
}
y = x = FTELL (ftnunit->ufd) - 2; /* skip the last endfile
* record */
if (y < 0) {
(void) fseek(ftnunit->ufd, 0L, 0);
ftnunit->lock_unit = 0;
return(0);
}
ch = '\0';
for (;;) {
if (x < sizeof (buf) - 1)
x = 0;
else
x -= sizeof (buf) - 1;
(void) FSEEK (ftnunit->ufd, x, 0);
n = (int) fread (buf, 1, (int) (y - x), ftnunit->ufd);
buf[n] = ch;
for (i = n - 1; i >= 1; i--) {
if (buf[i] != '\032' || buf[i + 1] != '\n')
continue;
(void) fseek (ftnunit->ufd, (long) (i + 2 - n), 1);
ftnunit->lock_unit = 0;
return (0);
}
if (x == 0) {
(void) fseek (ftnunit->ufd, 0L, 0);
ftnunit->lock_unit = 0;
return (0);
}
y = x;
ch = buf[0];
}
}
/* If last operation was a WRITE, truncate the file and then make
sure that the file mode is switched to READ so the the next
REWIND/BACKSPACE won't truncate the file again
*/
if (ftnunit->uwrt & WR_OP) {
#ifdef I90
/* If in Fortran-90 nonadvancing mode, write endfile record (\n only). */
if (ftnunit->f90sw == 1 && ftnunit->f90nadv == 1 ) {
putc ('\n', ftnunit->ufd);
ftnunit->f90nadv = 0;
}
#endif
(void) t_runc (ftnunit, a->aerr);
/* If the file is in write-only mode make sure that it is readable */
if (f77nowreading(ftnunit))
errret(a->aerr, 106, "backspace");
}
rewind (ftnunit->ufd);
ftnunit->lock_unit = 0;
return (0);
}
boolean_t simple_lock_try(simple_lock_t l)
{
return (!test_and_set((boolean_t *)l));
}
atomic_flag () : std::atomic_flag(ATOMIC_FLAG_INIT)
{
test_and_set();
}
static ftnint
__f77_f_back_com (alist *a, int lock)
{
unit *ftnunit;
int n, i;
ftnll x, y;
char buf[512];
if ((ftnunit = find_luno (a->aunit)) == NULL)
err(a->aerr, 114, "backspace");
while (lock && test_and_set( &ftnunit->lock_unit, 1L ))
;
if (ftnunit->uacc == APPEND || ftnunit->uacc == KEYED)
errret(a->aerr, 165, "backspace");
if (ftnunit->useek == 0 || ftnunit->url == 1)
errret(a->aerr, 106, "backspace");
if (ftnunit->uend == 1) {
ftnunit->uend = 0;
ftnunit->lock_unit = 0;
return (0);
}
if (ftnunit->uwrt & WR_OP) {
#ifdef I90
/* If in Fortran-90 nonadvancing mode, write endfile record (\n only). */
if (ftnunit->f90sw == 1 && ftnunit->f90nadv == 1 ) {
putc ('\n', ftnunit->ufd);
ftnunit->f90nadv = 0;
}
#endif
/* Just completed a write operation, a backspace would force
the truncation of the file at the current position.
*/
(void) t_runc (ftnunit, a->aerr);
/* make sure it gets switched back to reading mode so the
file won't get truncated again if it gets backspace/rewind again
*/
if (f77nowreading(ftnunit))
errret(a->aerr, 106, "backspace");
}
/* Backspace a direct unformatted file. */
if ((ftnunit->uacc == DIRECT) && (ftnunit->ufmt == 0)) {
if (ftnunit->uirec != 0)
ftnunit->uirec--;
ftnunit->lock_unit = 0;
return (0);
}
if (ftnunit->ufmt != 1) {
if (ftnunit->uerror)
unf_position (ftnunit->ufd, ftnunit);
if (fseek (ftnunit->ufd, -(long) sizeof (int), 1)) {
fseek(ftnunit->ufd, 0L, 0);
ftnunit->lock_unit = 0;
return(0);
}
/* NEED TO CHANGE HERE DLAI */
(void) fread ((char *) &n, sizeof (int), 1, ftnunit->ufd);
(void) fseek (ftnunit->ufd, (long) (-n - 2 * sizeof (int)), 1);
ftnunit->lock_unit = 0;
return (0);
}
y = x = FTELL (ftnunit->ufd) - 1; /* skip the last CR */
/* If already at the beginning of file, ignore the backspace */
if (x < 0) {
ftnunit->lock_unit = 0;
return (0);
}
#ifdef I90
/* Make sure these variables are zeroed out to allow record to be reread. */
ftnunit->f77recpos = 0;
ftnunit->f77recend = 0;
#endif
for (;;) {
if (x < sizeof (buf))
x = 0;
else
x -= sizeof (buf);
(void) FSEEK (ftnunit->ufd, x, 0);
/* n should be ll for 64 bit records */
n = (int) fread (buf, 1, (int) (y - x), ftnunit->ufd);
for (i = n - 1; i >= 0; i--) {
if (buf[i] != '\n')
continue;
(void) fseek (ftnunit->ufd, (long) (i + 1 - n), 1);
ftnunit->lock_unit = 0;
return (0);
}
if (x == 0) {
(void) fseek (ftnunit->ufd, 0L, 0);
ftnunit->lock_unit = 0;
return (0);
} else if (n <= 0)
errret (a->aerr, (EOF), "backspace")
(void) FSEEK (ftnunit->ufd, x, 0);
y = x;
}
}
f_open_com (olist *a, ftnint *mask, char **mode_, char **buf_, unit **fu)
#endif
{
unit *b;
ino_t inod;
int n, org;
char *mode = "r";
char *abuf, c, *cbuf, errstr[80];
char buf[PATH_MAX]; /* temp buffer */
char ubuf[PATH_MAX]; /* temp buffer */
unsigned int need;
#if 00
cllist64 x;
#else
cllist x;
#endif
struct stat sbuf;
static char seed[] = "aa";
char *q = seed;
char ch;
unit *dupunit;
int dupopen;
int istty = 0; /* Flag to indicate whether file
* being opened is /dev/tty */
/*
extern FILE *debugfile;
*/
struct stat stat_struct;
unit *ftnunit;
/* bug fix 12787 : need to initialize to zero */
/* sjc #1827: The cretin who coded this originally assumed that an
* 80-byte temporary string would always be enough. We dynamically
* allocate it to be 80 bytes plus whatever we can easily find out
* about the length of the filename being passed to us. That may
* not be enough (the string gets passed all over creation, so
* it's hard to know) but it's better than before. Note that this
* relies on f_open continuing not to be recursive. */
if (a->ofnm)
istty = !strncmp ("/dev/tty", a->ofnm, 8);
need = a->odfnm ? a->odfnmlen : 0;
need += a->ofnm ? a->ofnmlen : 0;
need += 40;
if ((*fu = ftnunit = b = map_luno (a->ounit)) == NULL)
err(a->oerr, 101, "open");
while (fu != &f77curunit && test_and_set( &ftnunit->lock_unit, 1L )) {
sginap(0);
}
/* obtain exclusive lock for special I/O operation, this should always
be done after the lock onthe unit has been done to avoid deadlock */
while (test_and_set( &io_lock, 1L ))
sginap(0);
* buf_ = buf;
/* Fix BN 9310 . If the the terminal is being opened do not test to see if this
* file is already connected to a fortran unit since the terminal should be
* able to be connected to various fortran units simultaneously
* ---ravi---1/7/91
*/
/* From the ANSI standard: to make this clear once and for all:
** If a unit is connnected to a file that exists, execution of an OPEN
** statement for that unit is permitted. If the FILE= specifier is not
** included in the OPEN statement, the file to be connected to the unit is
** the same as the file to which the unit is connected.
** If the file to be connected to the unit does not exist, but is the
** same as the file to which the unit is preconnected, the properties
** specifies by the OPEN statement become a part of the connection.
** If the file to be connected to the unit is not the same as the
** file to which the unit is conencted, the effect is as if a CLOSE
** statement without a STATUS= specifier had been executed for the unit
** immediately to the execution of the OPEN statement.
** If the file to be connected to the unit is the same as the file
** to which the unit is connected, only the BLANK= specifier may have a
** value different from the one currently in effect. The position of
** the file is unaffected.
** If a file is connected to a unit, execution of an OPEN statement
** on that file and a different unit is not permitted
*/
if (!istty) {
if (dupopen = f_duped (a, ftnunit, &dupunit))
if (!a->oshared)
return(dupopen);
}
else
dupopen = 0;
if (a->odfnm) {
g_char (a->odfnm, a->odfnmlen, buf);
abuf = &buf[strlen(buf)];
} else
abuf = buf;
if (b->uconn > 0 && (!a->osta || up_low (*a->osta) != 's')) {
if (a->ofnm == 0) {
same:if (a->oblnk != 0)
b->ublnk = up_low (*a->oblnk) == 'z' ? 1 : 0;
/* Ignore this open statement if it is not a preconnected unit
** otherwise redefine the unit characteristics
*/
if ((b->ufd == stdin || b->ufd == stdout || b->ufd == stderr)
&& b->ufnm == NULL)
dupopen = 1;
else
return (0);
}
if (a->ofnm) {
g_char (a->ofnm, a->ofnmlen, abuf);
if (b->uacc == KEYED)
mkidxname (buf, buf);
f77inode (buf, &inod);
if ((inod == b->uinode) && inod)
goto same;
buf[a->ofnmlen] = '\0';
}
x.cunit = a->ounit;
x.csta = 0;
x.cerr = a->oerr;
/* fix bug 6084 */
/* BN-8077 */
/* Leave the stdin, stdout, stderr alone without closing them,
* since if that is done a normal file will be opened which will
* have the ufd value of stdin, stdout, or stderr and mess up all
* the conditional testing for stdin, stdout, and stderr */
if (b->ufd == stdin || b->ufd == stdout || b->ufd == stderr) {
if (!dupopen) {
b->uconn = 0;
b->ufd = NULL;
}
#if 00
#define NAMEf_clos f_clos64
#else
#define NAMEf_clos f_clos
#endif
} else if ((n = NAMEf_clos (&x)) != 0)
return (n);
b->luno = a->ounit;
#undef NAMEf_clos
}
org = a->oorg ? up_low (*a->oorg) : 0;
b->umask = *mask;
if (a->oacc == 0)
switch (org) {
case 'r':
b->uacc = DIRECT;
break;
case 'i':
if (dupopen)
err(a->oerr, 186, "open")
b->uacc = KEYED;
break;
default:
b->uacc = SEQUENTIAL;
}
else
switch (up_low (*a->oacc)) {
case 'd':
b->uacc = DIRECT;
if (org == 'i')
err(a->oerr, 149, "open")
break;
case 'k':
b->uacc = KEYED;
if (org == 's')
err(a->oerr, 150, "open")
if (org == 'r')
err(a->oerr, 151, "open")
break;
case 'a':
b->uacc = APPEND;
if (org == 'i')
err(a->oerr, 152, "open")
break;
/* Fix BN 11769
* Currently if the access parameter is not a keywords, it
* sets it to the default ,sequential. Generate error instead.
* ---ravi---2/21/92
*
case 's':
default: b->uacc = org == 'i' ? KEYED : SEQUENTIAL;
*/
case 's':
b->uacc = org == 'i' ? KEYED : SEQUENTIAL;
break;
default:
err(a->oerr, 130, "open");
}
if (a->oassocv && b->uacc == DIRECT)
set_var ((ftnintu *)(b->uassocv = a->oassocv), b->umask, ASSOCV, 1);
else
b->uassocv = NULL;
if (a->omaxrec && b->uacc == DIRECT)
b->umaxrec = a->omaxrec;
else
b->umaxrec = 0;
if (cbuf = a->odisp)
switch (up_low (*cbuf++)) {
case 'd':
b->udisp = DELETE;
break;
case 'p':
b->udisp = PRINT;
goto checkdelete;
case 's':
if (up_low (*cbuf) == 'a')
goto keep;
b->udisp = SUBMIT;
checkdelete:
while (c = (*cbuf++))
if ((c == '/') && (c = (*cbuf)) && (up_low (c) == 'd'))
b->udisp |= DELETE;
break;
keep:
default:
b->udisp = KEEP;
}
else
b->udisp = KEEP;
b->ushared = a->oshared;
b->ureadonly = a->oreadonly;
if (a->oblnk && up_low (*a->oblnk) == 'z')
b->ublnk = 1;
else
b->ublnk = 0;
#ifdef I90
b->uaction = b->ureadonly ? READONLY : READWRITE;
b->unpad = 0;
b->udelim = DELIM_NONE;
#endif
b->url = a->orl;
if (a->ofm == 0) {
if (b->uacc == DIRECT || b->uacc == KEYED) {
b->ufmt = 0;
if (!f77vms_flag_[OLD_RL])
b->url *= sizeof (int);
} else
b->ufmt = 1;
} else if (up_low (*a->ofm) == 'f')
b->ufmt = 1;
else if (up_low (*a->ofm) == 'b')
b->ufmt = 2;
else if (up_low (*a->ofm) == 's') {
/* system file = direct unformatted file with record length = 1 */
b->ufmt = 0;
b->url = 1;
b->uacc = DIRECT;
} else {
b->ufmt = 0;
if (!f77vms_flag_[OLD_RL])
b->url *= sizeof (int);
/* all sequential unformatted must need a minimum of 1K buffer to
avoid fseek() operations when reading which causes data to be
read from the disk each time and cause a 12X performance loss.
*/
check_buflen( b, 1024 );
}
if (a->orectype)
switch (up_low (*a->orectype)) {
case 'f':
if (b->uacc != DIRECT && b->uacc != KEYED)
err(a->oerr, 156, "open")
break;
case 'v':
if (b->uacc == DIRECT || b->uacc == KEYED ||
b->ufmt == 1)
err(a->oerr, 157, "open")
break;
case 's':
if (b->uacc == DIRECT || b->uacc == KEYED ||
b->ufmt != 1)
err(a->oerr, 158, "open")
default:
break;
}
if (a->occ == 0)
b->ucc = (char) (b->ufmt ? ((b->luno == 6 && f77vms_flag_[VMS_CC]) ?
CC_FORTRAN : CC_LIST) : CC_NONE);
else
switch (up_low (*a->occ)) {
case 'l':
b->ucc = CC_LIST;
break;
case 'f':
b->ucc = CC_FORTRAN;
b->ucchar = '\0';
break;
case 'n':
b->ucc = CC_NONE;
break;
default:
b->ucc = (char) (b->ufmt ? ((b->luno == 6 && f77vms_flag_[VMS_CC]) ?
CC_FORTRAN : CC_LIST) : CC_NONE);
}
if (!b->ufmt && b->ucc != CC_NONE)
err(a->oerr, 162, "open");
if (a->ofnm == 0)
#ifdef SIZEOF_LUNO_IS_64
(void) sprintf (abuf, "fort.%lld", a->ounit);
#else
(void) sprintf (abuf, "fort.%d", a->ounit);
#endif
else
void simple_lock(simple_lock_t l)
{
while (test_and_set((boolean_t *)l))
continue;
}
void lock() //Its a spin lock used to lock the semaphore implementation
{
while (test_and_set(&flag));
}
