void
s_abort(int32 errno)
{
char *dumpflag, *getenv();
int32 coredump=0;
#ifndef FTN90_IO
void _cleanup();
#endif
if (dumpflag = getenv("f77_dump_flag")) {
coredump = up_low(*dumpflag) == 'y' ? 1 : 0;
}
if (coredump) {
#ifndef FTN90_IO
_cleanup();
#endif
abort(); /* cause a core dump */
} else {
#ifndef FTN90_IO
_cleanup();
#endif
fprintf(stderr,"*** Execution Terminated (%d) ***\n",errno);
exit(errno);
}
}
int main(void)
{
char str[100] = "I like programming!";
int len;
len = show(str);
reverse(str, len);
up_low(str);
printf("%s\n", str);
return 0;
}
void main()
{
clrscr();
char string[50];
cout<<"Enter a string: ";
gets(string);
int l=stringlength(string);
cout<<"The length of the string is: "<<l ;
cout<<endl<<endl;
cout<<"The new string is: ";
for(int i=0; i<=l;i++)
up_low(string[i]);
getch();
}
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);
}
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
