d/freebsd-skq
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Update to the most recent version. Among other things, this also solves

Browse Source 
the function naming problem for complex double function i've recently
aksed for in -committers.  (The recently committed rev 1.5 of proc.c
was actually also part of this update.)

Should the mailing lists come to an agreement that f2c better belongs
into the ports, this could be done nevertheless.  For the time being,
we've at least got a current version now.

Thanks, Steve!

Submitted by:	Steve Kargl <sgk@troutmask.apl.washington.edu>
This commit is contained in:
joerg 1999-02-03 17:23:49 +00:00
parent 4176c26a7a
commit 38d2602fc1
55 changed files with 815 additions and 681 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
lib/libF77/Notice
View File

@ -1,23 +1,23 @@
/****************************************************************
Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
Copyright 1990 - 1997 by AT&T, Lucent Technologies and Bellcore.
Permission to use, copy, modify, and distribute this software
and its documentation for any purpose and without fee is hereby
granted, provided that the above copyright notice appear in all
copies and that both that the copyright notice and this
permission notice and warranty disclaimer appear in supporting
documentation, and that the names of AT&T Bell Laboratories or
Bellcore or any of their entities not be used in advertising or
publicity pertaining to distribution of the software without
specific, written prior permission.
documentation, and that the names of AT&T, Bell Laboratories,
Lucent or Bellcore or any of their entities not be used in
advertising or publicity pertaining to distribution of the
software without specific, written prior permission.
AT&T and Bellcore disclaim all warranties with regard to this
software, including all implied warranties of merchantability
and fitness. In no event shall AT&T or Bellcore be liable for
any special, indirect or consequential damages or any damages
whatsoever resulting from loss of use, data or profits, whether
in an action of contract, negligence or other tortious action,
arising out of or in connection with the use or performance of
this software.
AT&T, Lucent and Bellcore disclaim all warranties with regard to
this software, including all implied warranties of
merchantability and fitness. In no event shall AT&T, Lucent or
Bellcore be liable for any special, indirect or consequential
damages or any damages whatsoever resulting from loss of use,
data or profits, whether in an action of contract, negligence or
other tortious action, arising out of or in connection with the
use or performance of this software.
****************************************************************/

4
lib/libF77/README
View File

@ -106,3 +106,7 @@ one-line shell script
or (on some systems)
exec /usr/bin/ar lts $1 >/dev/null
If your compiler complains about the signal calls in main.c, s_paus.c,
and signal_.c, you may need to adjust signal1.h suitably. See the
comments in signal1.h.

6
lib/libF77/Version.c
View File

@ -1,4 +1,4 @@
static char junk[] = "\n@(#)LIBF77 VERSION 19970226\n";
static char junk[] = "\n@(#)LIBF77 VERSION 19970919\n";
/*
2.00 11 June 1980. File version.c added to library.
@ -46,4 +46,8 @@ static char junk[] = "\n@(#)LIBF77 VERSION 19970226\n";
to permit aliasing it with input arguments.
(For now, at least, this is just for possible
benefit of g77.)
4 April 1997: [cz]_div.c: tweaks invisible on most systems (that may
affect systems using gratuitous extra precision).
19 Sept. 1997: [de]time_.c (Unix systems only): change return
type to double.
*/

24
lib/libF77/c_div.c
View File

@ -10,28 +10,28 @@ void c_div(complex *c, complex *a, complex *b)
#endif
{
double ratio, den;
double abr, abi;
double ai = a->i, ar = a->r, bi = b->i, br = b->r;
double abr, abi, cr;
if( (abr = br) < 0.)
if( (abr = b->r) < 0.)
abr = - abr;
if( (abi = bi) < 0.)
if( (abi = b->i) < 0.)
abi = - abi;
if( abr <= abi )
{
if(abi == 0)
sig_die("complex division by zero", 1);
ratio = (double)br / bi ;
den = bi * (1 + ratio*ratio);
c->r = (ar*ratio + ai) / den;
c->i = (ai*ratio - ar) / den;
ratio = (double)b->r / b->i ;
den = b->i * (1 + ratio*ratio);
cr = (a->r*ratio + a->i) / den;
c->i = (a->i*ratio - a->r) / den;
}
else
{
ratio = (double)bi / br ;
den = br * (1 + ratio*ratio);
c->r = (ar + ai*ratio) / den;
c->i = (ai - ar*ratio) / den;
ratio = (double)b->i / b->r ;
den = b->r * (1 + ratio*ratio);
cr = (a->r + a->i*ratio) / den;
c->i = (a->i - a->r*ratio) / den;
}
c->r = cr;
}

6
lib/libF77/d_lg10.c
View File

@ -1,7 +1,9 @@
#include "f2c.h"
#define log10e 0.43429448190325182765
#ifdef KR_headers
double log10();
double log();
double d_lg10(x) doublereal *x;
#else
#undef abs
@ -9,5 +11,5 @@ double d_lg10(x) doublereal *x;
double d_lg10(doublereal *x)
#endif
{
return( log10(*x) );
return( log10e * log(*x) );
}

3
lib/libF77/h_dnnt.c
View File

@ -9,6 +9,5 @@ shortint h_dnnt(x) doublereal *x;
shortint h_dnnt(doublereal *x)
#endif
{
return( (*x)>=0 ?
floor(*x + .5) : -floor(.5 - *x) );
return (shortint)(*x >= 0. ? floor(*x + .5) : -floor(.5 - *x));
}

3
lib/libF77/h_nint.c
View File

@ -9,6 +9,5 @@ shortint h_nint(x) real *x;
shortint h_nint(real *x)
#endif
{
return( (*x)>=0 ?
floor(*x + .5) : -floor(.5 - *x) );
return (shortint)(*x >= 0 ? floor(*x + .5) : -floor(.5 - *x));
}

3
lib/libF77/i_dnnt.c
View File

@ -9,6 +9,5 @@ integer i_dnnt(x) doublereal *x;
integer i_dnnt(doublereal *x)
#endif
{
return( (*x)>=0 ?
floor(*x + .5) : -floor(.5 - *x) );
return (integer)(*x >= 0. ? floor(*x + .5) : -floor(.5 - *x));
}

3
lib/libF77/i_nint.c
View File

@ -9,6 +9,5 @@ integer i_nint(x) real *x;
integer i_nint(real *x)
#endif
{
return( (*x)>=0 ?
floor(*x + .5) : -floor(.5 - *x) );
return (integer)(*x >= 0 ? floor(*x + .5) : -floor(.5 - *x));
}

18
lib/libF77/main.c
View File

@ -50,38 +50,44 @@ extern int MAIN__(void);
#define Int int
#endif
static VOID sigfdie(Int n)
static VOID sigfdie(Sigarg)
{
Use_Sigarg;
sig_die("Floating Exception", 1);
}
static VOID sigidie(Int n)
static VOID sigidie(Sigarg)
{
Use_Sigarg;
sig_die("IOT Trap", 1);
}
#ifdef SIGQUIT
static VOID sigqdie(Int n)
static VOID sigqdie(Sigarg)
{
Use_Sigarg;
sig_die("Quit signal", 1);
}
#endif
static VOID sigindie(Int n)
static VOID sigindie(Sigarg)
{
Use_Sigarg;
sig_die("Interrupt", 0);
}
static VOID sigtdie(Int n)
static VOID sigtdie(Sigarg)
{
Use_Sigarg;
sig_die("Killed", 0);
}
#ifdef SIGTRAP
static VOID sigtrdie(Int n)
static VOID sigtrdie(Sigarg)
{
Use_Sigarg;
sig_die("Trace trap", 1);
}
#endif

6
lib/libF77/r_lg10.c
View File

@ -1,7 +1,9 @@
#include "f2c.h"
#define log10e 0.43429448190325182765
#ifdef KR_headers
float log10f();
double log();
double r_lg10(x) real *x;
#else
#undef abs
@ -9,5 +11,5 @@ double r_lg10(x) real *x;
double r_lg10(real *x)
#endif
{
return( log10f(*x) );
return( log10e * log(*x) );
}

6
lib/libF77/s_paus.c
View File

@ -2,6 +2,7 @@
#include "f2c.h"
#define PAUSESIG 15
#include "signal1.h"
#ifdef KR_headers
#define Void /* void */
#define Int /* int */
@ -12,7 +13,6 @@
#undef min
#undef max
#include "stdlib.h"
#include "signal1.h"
#ifdef __cplusplus
extern "C" {
#endif
@ -22,8 +22,8 @@ extern int getpid(void), isatty(int), pause(void);
extern VOID f_exit(Void);
static VOID
waitpause(Int n)
{ n = n; /* shut up compiler warning */
waitpause(Sigarg)
{ Use_Sigarg;
return;
}

12
lib/libF77/signal1.h
View File

@ -12,8 +12,12 @@
#ifdef KR_headers
#define Sigarg_t
#else
#ifdef __cplusplus
#define Sigarg_t ...
#else
#define Sigarg_t int
#endif
#endif
#endif /*Sigarg_t*/
#ifdef USE_SIG_PF /* compile with -DUSE_SIG_PF under IRIX */
@ -23,3 +27,11 @@ typedef Sigret_t (*sig_pf)(Sigarg_t);
#endif
#define signal1(a,b) signal(a,(sig_pf)b)
#ifdef __cplusplus
#define Sigarg ...
#define Use_Sigarg
#else
#define Sigarg Int n
#define Use_Sigarg n = n /* shut up compiler warning */
#endif

14
lib/libF77/signal_.c
View File

@ -1,15 +1,11 @@
#include "f2c.h"
#ifdef KR_headers
typedef VOID (*sig_pf)();
extern sig_pf signal();
#define signal1 signal
ftnint signal_(sigp, proc) integer *sigp; sig_pf proc;
#else
#include "signal1.h"
ftnint signal_(integer *sigp, sig_pf proc)
ftnint
#ifdef KR_headers
signal_(sigp, proc) integer *sigp; sig_pf proc;
#else
signal_(integer *sigp, sig_pf proc)
#endif
{
int sig;

26
lib/libF77/z_div.c
View File

@ -1,7 +1,7 @@
#include "f2c.h"
#ifdef KR_headers
extern void sig_die();
extern VOID sig_die();
VOID z_div(c, a, b) doublecomplex *a, *b, *c;
#else
extern void sig_die(char*, int);
@ -9,28 +9,28 @@ void z_div(doublecomplex *c, doublecomplex *a, doublecomplex *b)
#endif
{
double ratio, den;
double abr, abi;
double ai = a->i, ar = a->r, bi = b->i, br = b->r;
double abr, abi, cr;
if( (abr = br) < 0.)
if( (abr = b->r) < 0.)
abr = - abr;
if( (abi = bi) < 0.)
if( (abi = b->i) < 0.)
abi = - abi;
if( abr <= abi )
{
if(abi == 0)
sig_die("complex division by zero", 1);
ratio = br / bi ;
den = bi * (1 + ratio*ratio);
c->r = (ar*ratio + ai) / den;
c->i = (ai*ratio - ar) / den;
ratio = b->r / b->i ;
den = b->i * (1 + ratio*ratio);
cr = (a->r*ratio + a->i) / den;
c->i = (a->i*ratio - a->r) / den;
}
else
{
ratio = bi / br ;
den = br * (1 + ratio*ratio);
c->r = (ar + ai*ratio) / den;
c->i = (ai - ar*ratio) / den;
ratio = b->i / b->r ;
den = b->r * (1 + ratio*ratio);
cr = (a->r + a->i*ratio) / den;
c->i = (a->i - a->r*ratio) / den;
}
c->r = cr;
}

26
lib/libI77/Notice
View File

@ -1,23 +1,23 @@
/****************************************************************
Copyright 1990 - 1997 by AT&T Bell Laboratories and Bellcore.
Copyright 1990 - 1997 by AT&T, Lucent Technologies and Bellcore.
Permission to use, copy, modify, and distribute this software
and its documentation for any purpose and without fee is hereby
granted, provided that the above copyright notice appear in all
copies and that both that the copyright notice and this
permission notice and warranty disclaimer appear in supporting
documentation, and that the names of AT&T Bell Laboratories or
Bellcore or any of their entities not be used in advertising or
publicity pertaining to distribution of the software without
specific, written prior permission.
documentation, and that the names of AT&T, Bell Laboratories,
Lucent or Bellcore or any of their entities not be used in
advertising or publicity pertaining to distribution of the
software without specific, written prior permission.
AT&T and Bellcore disclaim all warranties with regard to this
software, including all implied warranties of merchantability
and fitness. In no event shall AT&T or Bellcore be liable for
any special, indirect or consequential damages or any damages
whatsoever resulting from loss of use, data or profits, whether
in an action of contract, negligence or other tortious action,
arising out of or in connection with the use or performance of
this software.
AT&T, Lucent and Bellcore disclaim all warranties with regard to
this software, including all implied warranties of
merchantability and fitness. In no event shall AT&T, Lucent or
Bellcore be liable for any special, indirect or consequential
damages or any damages whatsoever resulting from loss of use,
data or profits, whether in an action of contract, negligence or
other tortious action, arising out of or in connection with the
use or performance of this software.
****************************************************************/

50
lib/libI77/Version.c
View File

@ -1,4 +1,4 @@
static char junk[] = "\n@(#) LIBI77 VERSION pjw,dmg-mods 19970226\n";
static char junk[] = "\n@(#) LIBI77 VERSION pjw,dmg-mods 19980907\n";
/*
2.01 $ format added
@ -242,3 +242,51 @@ wrtfmt.c:
ftell_.c: change param "unit" to "Unit" for -DKR_headers. */
/* 26 Feb. 1997: ftell_.c: on systems that define SEEK_SET, etc., use
SEEK_SET, SEEK_CUR, SEEK_END for *whence = 0, 1, 2. */
/* 7 Apr. 1997: fmt.c: adjust to complain at missing numbers in formats
(but still treat missing ".nnn" as ".0"). */
/* 11 Apr. 1997: err.c: attempt to make stderr line buffered rather
than fully buffered. (Buffering is needed for format
items T and TR.) */
/* 27 May 1997: ftell_.c: fix typo (that caused the third argument to be
treated as 2 on some systems). */
/* 5 Aug. 1997: lread.c: adjust to accord with a change to the Fortran 8X
draft (in 1990 or 1991) that rescinded permission to elide
quote marks in namelist input of character data; compile
with -DF8X_NML_ELIDE_QUOTES to get the old behavior.
wrtfmt.o: wrt_G: tweak to print the right number of 0's
for zero under G format. */
/* 16 Aug. 1997: iio.c: fix bug in internal writes to an array of character
strings that sometimes caused one more array element than
required by the format to be blank-filled. Example:
format(1x). */
/* 16 Sept. 1997:fmt.[ch] rdfmt.c wrtfmt.c: tweak struct syl for machines
with 64-bit pointers and 32-bit ints that did not 64-bit
align struct syl (e.g., Linux on the DEC Alpha). */
/* 19 Jan. 1998: backspace.c: for b->ufmt==0, change sizeof(int) to
sizeof(uiolen). On machines where this would make a
difference, it is best for portability to compile libI77 with
-DUIOLEN_int (which will render the change invisible). */
/* 4 March 1998: open.c: fix glitch in comparing file names under
-DNON_UNIX_STDIO */
/* 17 March 1998: endfile.c, open.c: acquire temporary files from tmpfile(),
unless compiled with -DNON_ANSI_STDIO, which uses mktemp().
New buffering scheme independent of NON_UNIX_STDIO for
handling T format items. Now -DNON_UNIX_STDIO is no
longer be necessary for Linux, and libf2c no longer
causes stderr to be buffered -- the former setbuf or
setvbuf call for stderr was to make T format items work.
open.c: use the Posix access() function to check existence
or nonexistence of files, except under -DNON_POSIX_STDIO,
where trial fopen calls are used. */
/* 5 April 1998: wsfe.c: make $ format item work: this was lost in the
changes of 17 March 1998. */
/* 28 May 1998: backspace.c dfe.c due.c iio.c lread.c rsfe.c sue.c wsfe.c:
set f__curunit sooner so various error messages will
correctly identify the I/O unit involved. */
/* 17 June 1998: lread.c: unless compiled with
ALLOW_FLOAT_IN_INTEGER_LIST_INPUT #defined, treat
floating-point numbers (containing either a decimal point
or an exponent field) as errors when they appear as list
input for integer data. */
/* 7 Sept. 1998: move e_wdfe from sfe.c to dfe.c, where it was originally.
Why did it ever move to sfe.c? */

93
lib/libI77/backspace.c
View File

@ -6,18 +6,15 @@ integer f_back(a) alist *a;
integer f_back(alist *a)
#endif
{ unit *b;
int i, n, ndec;
#ifdef MSDOS
int j, k;
long w, z;
#endif
long x, y;
char buf[32];
long v, w, x, y, z;
uiolen n;
FILE *f;
f__curunit = b = &f__units[a->aunit]; /* curunit for error messages */
if(a->aunit >= MXUNIT || a->aunit < 0)
err(a->aerr,101,"backspace")
b= &f__units[a->aunit];
if(b->useek==0) err(a->aerr,106,"backspace")
if(b->ufd==NULL) {
if((f = b->ufd) == NULL) {
fk_open(1, 1, a->aunit);
return(0);
}
@ -32,67 +29,41 @@ integer f_back(alist *a)
}
if(b->url>0)
{
x=ftell(b->ufd);
x=ftell(f);
y = x % b->url;
if(y == 0) x--;
x /= b->url;
x *= b->url;
(void) fseek(b->ufd,x,SEEK_SET);
(void) fseek(f,x,SEEK_SET);
return(0);
}
if(b->ufmt==0)
{ (void) fseek(b->ufd,-(long)sizeof(int),SEEK_CUR);
(void) fread((char *)&n,sizeof(int),1,b->ufd);
(void) fseek(b->ufd,-(long)n-2*sizeof(int),SEEK_CUR);
{ fseek(f,-(long)sizeof(uiolen),SEEK_CUR);
fread((char *)&n,sizeof(uiolen),1,f);
fseek(f,-(long)n-2*sizeof(uiolen),SEEK_CUR);
return(0);
}
#ifdef MSDOS
w = -1;
#endif
for(ndec = 1;; ndec = 0)
{
y = x = ftell(b->ufd);
if(x < sizeof(buf))
x = 0;
else
x -= sizeof(buf);
(void) fseek(b->ufd,x,SEEK_SET);
n=fread(buf,1,(int)(y-x), b->ufd);
for(i = n - ndec; --i >= 0; )
{
if(buf[i]!='\n') continue;
#ifdef MSDOS
for(j = k = 0; j <= i; j++)
if (buf[j] == '\n')
k++;
fseek(b->ufd,x,SEEK_SET);
for(;;)
if (getc(b->ufd) == '\n') {
if ((z = ftell(b->ufd)) >= y && ndec) {
if (w == -1)
goto break2;
break;
}
if (--k <= 0)
return 0;
w = z;
}
fseek(b->ufd, w, SEEK_SET);
#else
fseek(b->ufd,(long)(i+1-n),SEEK_CUR);
#endif
return(0);
}
#ifdef MSDOS
break2:
#endif
if(x==0)
{
(void) fseek(b->ufd, 0L, SEEK_SET);
return(0);
w = x = ftell(f);
z = 0;
loop:
while(x) {
x -= x < 64 ? x : 64;
fseek(f,x,SEEK_SET);
for(y = x; y < w; y++) {
if (getc(f) != '\n')
continue;
v = ftell(f);
if (v == w) {
if (z)
goto break2;
goto loop;
}
z = v;
}
else if(n<=0) err(a->aerr,(EOF),"backspace")
(void) fseek(b->ufd, x, SEEK_SET);
}
err(a->aerr,(EOF),"backspace")
}
break2:
fseek(f, z, SEEK_SET);
return 0;
}

9
lib/libI77/close.c
View File

@ -31,11 +31,10 @@ integer f_clos(cllist *a)
b= &f__units[a->cunit];
if(b->ufd==NULL)
goto done;
if (b->uscrtch == 1)
goto Delete;
if (!a->csta)
if (b->uscrtch == 1)
goto Delete;
else
goto Keep;
goto Keep;
switch(*a->csta) {
default:
Keep:
@ -51,8 +50,8 @@ integer f_clos(cllist *a)
case 'd':
case 'D':
Delete:
fclose(b->ufd);
if(b->ufnm) {
fclose(b->ufd);
unlink(b->ufnm); /*SYSDEP*/
free(b->ufnm);
}

47
lib/libI77/dfe.c
View File

@ -31,41 +31,30 @@ y_getc(Void)
}
err(f__elist->cierr,errno,"readingd");
}
#ifdef KR_headers
y_putc(c)
#else
y_putc(int c)
#endif
{
f__recpos++;
if(f__recpos <= f__curunit->url || f__curunit->url==1)
putc(c,f__cf);
else
err(f__elist->cierr,110,"dout");
return(0);
}
static int
y_rev(Void)
{ /*what about work done?*/
if(f__curunit->url==1 || f__recpos==f__curunit->url)
return(0);
while(f__recpos<f__curunit->url)
(*f__putn)(' ');
f__recpos=0;
{
if (f__recpos < f__hiwater)
f__recpos = f__hiwater;
if (f__curunit->url > 1)
while(f__recpos < f__curunit->url)
(*f__putn)(' ');
if (f__recpos)
f__putbuf(0);
f__recpos = 0;
return(0);
}
static int
y_err(Void)
{
err(f__elist->cierr, 110, "dfe");
}
static int
y_newrec(Void)
{
if(f__curunit->url == 1 || f__recpos == f__curunit->url) {
f__hiwater = f__recpos = f__cursor = 0;
return(1);
}
if(f__hiwater > f__recpos)
f__recpos = f__hiwater;
y_rev();
f__hiwater = f__cursor = 0;
return(1);
@ -81,9 +70,9 @@ c_dfe(cilist *a)
f__formatted=f__external=1;
f__elist=a;
f__cursor=f__scale=f__recpos=0;
f__curunit = &f__units[a->ciunit];
if(a->ciunit>MXUNIT || a->ciunit<0)
err(a->cierr,101,"startchk");
f__curunit = &f__units[a->ciunit];
if(f__curunit->ufd==NULL && fk_open(DIR,FMT,a->ciunit))
err(a->cierr,104,"dfe");
f__cf=f__curunit->ufd;
@ -130,7 +119,7 @@ integer s_wdfe(cilist *a)
if(n=c_dfe(a)) return(n);
if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit))
err(a->cierr,errno,"startwrt");
f__putn = y_putc;
f__putn = x_putc;
f__doed = w_ed;
f__doned= w_ned;
f__dorevert = y_err;
@ -143,8 +132,8 @@ integer s_wdfe(cilist *a)
}
integer e_rdfe(Void)
{
(void) en_fio();
return(0);
en_fio();
return 0;
}
integer e_wdfe(Void)
{

4
lib/libI77/due.c
View File

@ -8,11 +8,11 @@ c_due(cilist *a)
#endif
{
if(!f__init) f_init();
if(a->ciunit>=MXUNIT || a->ciunit<0)
err(a->cierr,101,"startio");
f__sequential=f__formatted=f__recpos=0;
f__external=1;
f__curunit = &f__units[a->ciunit];
if(a->ciunit>=MXUNIT || a->ciunit<0)
err(a->cierr,101,"startio");
f__elist=a;
if(f__curunit->ufd==NULL && fk_open(DIR,UNF,a->ciunit) ) err(a->cierr,104,"due");
f__cf=f__curunit->ufd;

116
lib/libI77/endfile.c
View File

@ -1,12 +1,9 @@
#include "f2c.h"
#include "fio.h"
#ifndef NON_UNIX_STDIO
#include "sys/types.h"
#endif
#include "rawio.h"
#ifdef KR_headers
extern char *strcpy();
extern FILE *tmpfile();
#else
#undef abs
#undef min
@ -15,19 +12,7 @@ extern char *strcpy();
#include "string.h"
#endif
#ifdef NON_UNIX_STDIO
#ifndef unlink
#define unlink remove
#endif
#else
#ifdef MSDOS
#include "io.h"
#endif
#endif
#ifdef NON_UNIX_STDIO
extern char *f__r_mode[], *f__w_mode[];
#endif
#ifdef KR_headers
integer f_end(a) alist *a;
@ -36,19 +21,15 @@ integer f_end(alist *a)
#endif
{
unit *b;
FILE *tf;
if(a->aunit>=MXUNIT || a->aunit<0) err(a->aerr,101,"endfile");
b = &f__units[a->aunit];
if(b->ufd==NULL) {
char nbuf[10];
(void) sprintf(nbuf,"fort.%ld",a->aunit);
#ifdef NON_UNIX_STDIO
{ FILE *tf;
if (tf = fopen(nbuf, f__w_mode[0]))
fclose(tf);
}
#else
close(creat(nbuf, 0666));
#endif
sprintf(nbuf,"fort.%ld",a->aunit);
if (tf = fopen(nbuf, f__w_mode[0]))
fclose(tf);
return(0);
}
b->uend=1;
@ -56,14 +37,13 @@ integer f_end(alist *a)
}
static int
#ifdef NON_UNIX_STDIO
#ifdef KR_headers
copy(from, len, to) char *from, *to; register long len;
copy(from, len, to) FILE *from, *to; register long len;
#else
copy(FILE *from, register long len, FILE *to)
#endif
{
int k, len1;
int len1;
char buf[BUFSIZ];
while(fread(buf, len1 = len > BUFSIZ ? BUFSIZ : (int)len, 1, from)) {
@ -74,36 +54,6 @@ copy(FILE *from, register long len, FILE *to)
}
return 0;
}
#else
#ifdef KR_headers
copy(from, len, to) char *from, *to; register long len;
#else
copy(char *from, register long len, char *to)
#endif
{
register int n;
int k, rc = 0, tmp;
char buf[BUFSIZ];
if ((k = open(from, O_RDONLY)) < 0)
return 1;
if ((tmp = creat(to,0666)) < 0)
return 1;
while((n = read(k, buf, len > BUFSIZ ? BUFSIZ : (int)len)) > 0) {
if (write(tmp, buf, n) != n)
{ rc = 1; break; }
if ((len -= n) <= 0)
break;
}
close(k);
close(tmp);
return n < 0 ? 1 : rc;
}
#endif
#ifndef L_tmpnam
#define L_tmpnam 16
#endif
int
#ifdef KR_headers
@ -112,14 +62,9 @@ t_runc(a) alist *a;
t_runc(alist *a)
#endif
{
char nm[L_tmpnam+12]; /* extra space in case L_tmpnam is tiny */
long loc, len;
unit *b;
#ifdef NON_UNIX_STDIO
FILE *bf, *tf;
#else
FILE *bf;
#endif
int rc = 0;
b = &f__units[a->aunit];
@ -130,36 +75,20 @@ t_runc(alist *a)
len=ftell(bf);
if (loc >= len || b->useek == 0 || b->ufnm == NULL)
return(0);
#ifdef NON_UNIX_STDIO
fclose(b->ufd);
#else
rewind(b->ufd); /* empty buffer */
#endif
if (!loc) {
#ifdef NON_UNIX_STDIO
if (!(bf = fopen(b->ufnm, f__w_mode[b->ufmt])))
#else
if (close(creat(b->ufnm,0666)))
#endif
rc = 1;
if (b->uwrt)
b->uwrt = 1;
goto done;
}
#ifdef _POSIX_SOURCE
tmpnam(nm);
#else
strcpy(nm,"tmp.FXXXXXX");
mktemp(nm);
#endif
#ifdef NON_UNIX_STDIO
if (!(bf = fopen(b->ufnm, f__r_mode[0]))) {
if (!(bf = fopen(b->ufnm, f__r_mode[0]))
|| !(tf = tmpfile())) {
bad:
rc = 1;
goto done;
}
if (!(tf = fopen(nm, f__w_mode[0])))
goto bad;
if (copy(bf, loc, tf)) {
bad1:
rc = 1;
@ -167,28 +96,23 @@ t_runc(alist *a)
}
if (!(bf = freopen(b->ufnm, f__w_mode[0], bf)))
goto bad1;
if (!(tf = freopen(nm, f__r_mode[0], tf)))
goto bad1;
rewind(tf);
if (copy(tf, loc, bf))
goto bad1;
if (f__w_mode[0] != f__w_mode[b->ufmt]) {
if (!(bf = freopen(b->ufnm, f__w_mode[b->ufmt|2], bf)))
goto bad1;
fseek(bf, loc, SEEK_SET);
b->urw = 2;
#ifdef NON_UNIX_STDIO
if (b->ufmt) {
fclose(bf);
if (!(bf = fopen(b->ufnm, f__w_mode[3])))
goto bad;
fseek(bf,0L,SEEK_END);
b->urw = 3;
}
#endif
done1:
fclose(tf);
unlink(nm);
done:
f__cf = b->ufd = bf;
#else
if (copy(b->ufnm, loc, nm)
|| copy(nm, loc, b->ufnm))
rc = 1;
unlink(nm);
fseek(b->ufd, loc, SEEK_SET);
done:
#endif
if (rc)
err(a->aerr,111,"endfile");
return 0;

78
lib/libI77/err.c
View File

@ -1,12 +1,10 @@
#ifndef NON_UNIX_STDIO
#define _INCLUDE_POSIX_SOURCE /* for HP-UX */
#define _INCLUDE_XOPEN_SOURCE /* for HP-UX */
#include "sys/types.h"
#include "sys/stat.h"
#endif
#include "f2c.h"
#include "fio.h"
#include "fmt.h" /* for struct syl */
#include "rawio.h" /* for fcntl.h, fdopen */
#ifdef NON_UNIX_STDIO
#ifdef KR_headers
extern char *malloc();
#else
@ -15,7 +13,8 @@ extern char *malloc();
#undef max
#include "stdlib.h"
#endif
#endif
#include "fio.h"
#include "fmt.h" /* for struct syl */
/*global definitions*/
unit f__units[MXUNIT]; /*unit table*/
@ -29,9 +28,11 @@ flag f__external; /*1 if external io, 0 if internal */
#ifdef KR_headers
int (*f__doed)(),(*f__doned)();
int (*f__doend)(),(*f__donewrec)(),(*f__dorevert)();
int (*f__getn)(),(*f__putn)(); /*for formatted io*/
int (*f__getn)(); /* for formatted input */
void (*f__putn)(); /* for formatted output */
#else
int (*f__getn)(void),(*f__putn)(int); /*for formatted io*/
int (*f__getn)(void); /* for formatted input */
void (*f__putn)(int); /* for formatted output */
int (*f__doed)(struct syl*, char*, ftnlen),(*f__doned)(struct syl*);
int (*f__dorevert)(void),(*f__donewrec)(void),(*f__doend)(void);
#endif
@ -171,11 +172,6 @@ f_init(Void)
p= &f__units[0];
p->ufd=stderr;
p->useek=f__canseek(stderr);
#ifdef NON_UNIX_STDIO
setbuf(stderr, (char *)malloc(BUFSIZ));
#else
stderr->_flag &= ~_IONBF;
#endif
p->ufmt=1;
p->uwrt=1;
p = &f__units[5];
@ -196,21 +192,29 @@ f__nowreading(unit *x)
#endif
{
long loc;
int ufmt;
extern char *f__r_mode[];
int ufmt, urw;
extern char *f__r_mode[], *f__w_mode[];
if (x->urw & 1)
goto done;
if (!x->ufnm)
goto cantread;
ufmt = x->ufmt;
loc=ftell(x->ufd);
if(freopen(x->ufnm,f__r_mode[ufmt],x->ufd) == NULL) {
ufmt = x->url ? 0 : x->ufmt;
loc = ftell(x->ufd);
urw = 3;
if (!freopen(x->ufnm, f__w_mode[ufmt|2], x->ufd)) {
urw = 1;
if(!freopen(x->ufnm, f__r_mode[ufmt], x->ufd)) {
cantread:
errno = 126;
return(1);
errno = 126;
return 1;
}
}
x->uwrt=0;
(void) fseek(x->ufd,loc,SEEK_SET);
return(0);
fseek(x->ufd,loc,SEEK_SET);
x->urw = urw;
done:
x->uwrt = 0;
return 0;
}
#ifdef KR_headers
f__nowwriting(x) unit *x;
@ -221,46 +225,34 @@ f__nowwriting(unit *x)
long loc;
int ufmt;
extern char *f__w_mode[];
#ifndef NON_UNIX_STDIO
int k;
#endif
if (x->urw & 2)
goto done;
if (!x->ufnm)
goto cantwrite;
ufmt = x->ufmt;
#ifdef NON_UNIX_STDIO
ufmt |= 2;
#endif
ufmt = x->url ? 0 : x->ufmt;
if (x->uwrt == 3) { /* just did write, rewind */
#ifdef NON_UNIX_STDIO
if (!(f__cf = x->ufd =
freopen(x->ufnm,f__w_mode[ufmt],x->ufd)))
#else
if (close(creat(x->ufnm,0666)))
#endif
goto cantwrite;
x->urw = 2;
}
else {
loc=ftell(x->ufd);
#ifdef NON_UNIX_STDIO
if (!(f__cf = x->ufd =
freopen(x->ufnm, f__w_mode[ufmt], x->ufd)))
#else
if (fclose(x->ufd) < 0
|| (k = x->uwrt == 2 ? creat(x->ufnm,0666)
: open(x->ufnm,O_WRONLY)) < 0
|| (f__cf = x->ufd = fdopen(k,f__w_mode[ufmt])) == NULL)
#endif
freopen(x->ufnm, f__w_mode[ufmt |= 2], x->ufd)))
{
x->ufd = NULL;
cantwrite:
errno = 127;
return(1);
}
(void) fseek(x->ufd,loc,SEEK_SET);
x->urw = 3;
fseek(x->ufd,loc,SEEK_SET);
}
done:
x->uwrt = 1;
return(0);
return 0;
}
int

13
lib/libI77/fio.h
View File

@ -34,7 +34,7 @@ typedef struct
int url; /*0=sequential*/
flag useek; /*true=can backspace, use dir, ...*/
flag ufmt;
flag uprnt;
flag urw; /* (1 for can read) | (2 for can write) */
flag ublnk;
flag uend;
flag uwrt; /*last io was write*/
@ -47,17 +47,21 @@ extern flag f__reading,f__external,f__sequential,f__formatted;
#undef Void
#ifdef KR_headers
#define Void /*void*/
extern int (*f__getn)(),(*f__putn)(); /*for formatted io*/
extern int (*f__getn)(); /* for formatted input */
extern void (*f__putn)(); /* for formatted output */
extern void x_putc();
extern long f__inode();
extern VOID sig_die();
extern int (*f__donewrec)(), t_putc(), x_wSL();
extern int c_sfe(), err__fl(), xrd_SL();
extern int c_sfe(), err__fl(), xrd_SL(), f__putbuf();
#else
#define Void void
#ifdef __cplusplus
extern "C" {
#endif
extern int (*f__getn)(void),(*f__putn)(int); /*for formatted io*/
extern int (*f__getn)(void); /* for formatted input */
extern void (*f__putn)(int); /* for formatted output */
extern void x_putc(int);
extern long f__inode(char*,int*);
extern void sig_die(char*,int);
extern void f__fatal(int,char*);
@ -72,6 +76,7 @@ extern int c_sfe(cilist*), z_rnew(void);
extern int isatty(int);
extern int err__fl(int,int,char*);
extern int xrd_SL(void);
extern int f__putbuf(int);
#ifdef __cplusplus
}
#endif

104
lib/libI77/fmt.c
View File

@ -18,9 +18,10 @@
/* special quote character for stu */
extern int f__cursor,f__scale;
extern flag f__cblank,f__cplus; /*blanks in I and compulsory plus*/
struct syl f__syl[SYLMX];
static struct syl f__syl[SYLMX];
int f__parenlvl,f__pc,f__revloc;
static
#ifdef KR_headers
char *ap_end(s) char *s;
#else
@ -39,6 +40,7 @@ char *ap_end(char *s)
f__fatal(100, "bad string");
/*NOTREACHED*/ return 0;
}
static
#ifdef KR_headers
op_gen(a,b,c,d)
#else
@ -51,16 +53,16 @@ op_gen(int a, int b, int c, int d)
}
p->op=a;
p->p1=b;
p->p2=c;
p->p3=d;
p->p2.i[0]=c;
p->p2.i[1]=d;
return(f__pc++);
}
#ifdef KR_headers
char *f_list();
char *gt_num(s,n) char *s; int *n;
static char *f_list();
static char *gt_num(s,n,n1) char *s; int *n, n1;
#else
char *f_list(char*);
char *gt_num(char *s, int *n)
static char *f_list(char*);
static char *gt_num(char *s, int *n, int n1)
#endif
{ int m=0,f__cnt=0;
char c;
@ -74,10 +76,16 @@ char *gt_num(char *s, int *n)
f__cnt++;
s++;
}
if(f__cnt==0) *n=1;
if(f__cnt==0) {
if (!n1)
s = 0;
*n=n1;
}
else *n=m;
return(s);
}
static
#ifdef KR_headers
char *f_s(s,curloc) char *s;
#else
@ -98,6 +106,8 @@ char *f_s(char *s, int curloc)
skip(s);
return(s);
}
static
#ifdef KR_headers
ne_d(s,p) char *s,**p;
#else
@ -135,7 +145,10 @@ ne_d(char *s, char **p)
case '+': s++; /*OUTRAGEOUS CODING TRICK*/
case '0': case '1': case '2': case '3': case '4':
case '5': case '6': case '7': case '8': case '9':
s=gt_num(s,&n);
if (!(s=gt_num(s,&n,0))) {
bad: *p = 0;
return 1;
}
switch(*s)
{
default:
@ -147,7 +160,7 @@ ne_d(char *s, char **p)
case 'H':
case 'h':
sp = &f__syl[op_gen(H,n,0,0)];
*(char **)&sp->p2 = s + 1;
sp->p2.s = s + 1;
s+=n;
break;
}
@ -156,7 +169,7 @@ ne_d(char *s, char **p)
case '"':
case '\'':
sp = &f__syl[op_gen(APOS,0,0,0)];
*(char **)&sp->p2 = s;
sp->p2.s = s;
if((*p = ap_end(s)) == NULL)
return(0);
return(1);
@ -171,7 +184,8 @@ ne_d(char *s, char **p)
s++;
}
else x=T;
s=gt_num(s+1,&n);
if (!(s=gt_num(s+1,&n,0)))
goto bad;
s--;
(void) op_gen(x,n,0,0);
break;
@ -184,6 +198,8 @@ ne_d(char *s, char **p)
*p=s;
return(1);
}
static
#ifdef KR_headers
e_d(s,p) char *s,**p;
#else
@ -191,7 +207,7 @@ e_d(char *s, char **p)
#endif
{ int i,im,n,w,d,e,found=0,x=0;
char *sv=s;
s=gt_num(s,&n);
s=gt_num(s,&n,1);
(void) op_gen(STACK,n,0,0);
switch(*s++)
{
@ -201,20 +217,24 @@ e_d(char *s, char **p)
case 'G':
case 'g':
found=1;
s=gt_num(s,&w);
if (!(s=gt_num(s,&w,0))) {
bad:
*p = 0;
return 1;
}
if(w==0) break;
if(*s=='.')
{ s++;
s=gt_num(s,&d);
}
if(*s=='.') {
if (!(s=gt_num(s+1,&d,0)))
goto bad;
}
else d=0;
if(*s!='E' && *s != 'e')
(void) op_gen(x==1?E:G,w,d,0); /* default is Ew.dE2 */
else
{ s++;
s=gt_num(s,&e);
else {
if (!(s=gt_num(s+1,&e,0)))
goto bad;
(void) op_gen(x==1?EE:GE,w,d,e);
}
}
break;
case 'O':
case 'o':
@ -229,7 +249,8 @@ e_d(char *s, char **p)
case 'L':
case 'l':
found=1;
s=gt_num(s,&w);
if (!(s=gt_num(s,&w,0)))
goto bad;
if(w==0) break;
(void) op_gen(L,w,0,0);
break;
@ -238,7 +259,7 @@ e_d(char *s, char **p)
found=1;
skip(s);
if(*s>='0' && *s<='9')
{ s=gt_num(s,&w);
{ s=gt_num(s,&w,1);
if(w==0) break;
(void) op_gen(AW,w,0,0);
break;
@ -247,25 +268,27 @@ e_d(char *s, char **p)
break;
case 'F':
case 'f':
if (!(s=gt_num(s,&w,0)))
goto bad;
found=1;
s=gt_num(s,&w);
if(w==0) break;
if(*s=='.')
{ s++;
s=gt_num(s,&d);
}
if(*s=='.') {
if (!(s=gt_num(s+1,&d,0)))
goto bad;
}
else d=0;
(void) op_gen(F,w,d,0);
break;
case 'D':
case 'd':
found=1;
s=gt_num(s,&w);
if (!(s=gt_num(s,&w,0)))
goto bad;
if(w==0) break;
if(*s=='.')
{ s++;
s=gt_num(s,&d);
}
if(*s=='.') {
if (!(s=gt_num(s+1,&d,0)))
goto bad;
}
else d=0;
(void) op_gen(D,w,d,0);
break;
@ -274,15 +297,16 @@ e_d(char *s, char **p)
i = I;
im = IM;
finish_I:
if (!(s=gt_num(s,&w,0)))
goto bad;
found=1;
s=gt_num(s,&w);
if(w==0) break;
if(*s!='.')
{ (void) op_gen(i,w,0,0);
break;
}
s++;
s=gt_num(s,&d);
if (!(s=gt_num(s+1,&d,0)))
goto bad;
(void) op_gen(im,w,d,0);
break;
}
@ -294,6 +318,7 @@ e_d(char *s, char **p)
*p=s;
return(1);
}
static
#ifdef KR_headers
char *i_tem(s) char *s;
#else
@ -304,10 +329,12 @@ char *i_tem(char *s)
if(*s==')') return(s);
if(ne_d(s,&t)) return(t);
if(e_d(s,&t)) return(t);
s=gt_num(s,&n);
s=gt_num(s,&n,1);
if((curloc=op_gen(STACK,n,0,0))<0) return(NULL);
return(f_s(s,curloc));
}
static
#ifdef KR_headers
char *f_list(s) char *s;
#else
@ -349,6 +376,7 @@ pars_f(char *s)
int f__cnt[STKSZ],f__ret[STKSZ],f__cp,f__rp;
flag f__workdone, f__nonl;
static
#ifdef KR_headers
type_f(n)
#else

7
lib/libI77/fmt.h
View File

@ -1,6 +1,8 @@
struct syl
{ int op,p1,p2,p3;
};
{ int op;
int p1;
union { int i[2]; char *s;} p2;
};
#define RET1 1
#define REVERT 2
#define GOTO 3
@ -37,7 +39,6 @@ struct syl
#define OM 34
#define Z 35
#define ZM 36
extern struct syl f__syl[];
extern int f__pc,f__parenlvl,f__revloc;
typedef union
{ real pf;

30
lib/libI77/iio.c
View File

@ -14,17 +14,16 @@ z_getc(Void)
}
return '\n';
}
void
#ifdef KR_headers
z_putc(c)
#else
z_putc(int c)
#endif
{
if(f__icptr >= f__icend) err(f__svic->icierr,110,"inwrite");
if(f__recpos++ < f__svic->icirlen)
if (f__icptr < f__icend && f__recpos++ < f__svic->icirlen)
*f__icptr++ = c;
else err(f__svic->icierr,110,"recend");
return 0;
}
z_rnew(Void)
{
@ -50,11 +49,12 @@ c_si(icilist *a)
{
f__elist = (cilist *)a;
f__fmtbuf=a->icifmt;
f__curunit = 0;
f__sequential=f__formatted=1;
f__external=0;
if(pars_f(f__fmtbuf)<0)
err(a->icierr,100,"startint");
fmt_bg();
f__sequential=f__formatted=1;
f__external=0;
f__cblank=f__cplus=f__scale=0;
f__svic=a;
f__icnum=f__recpos=0;
@ -62,7 +62,6 @@ c_si(icilist *a)
f__hiwater = 0;
f__icptr = a->iciunit;
f__icend = f__icptr + a->icirlen*a->icirnum;
f__curunit = 0;
f__cf = 0;
return(0);
}
@ -124,8 +123,7 @@ integer s_wsfi(icilist *a)
return(0);
}
integer e_rsfi(Void)
{ int n;
n = en_fio();
{ int n = en_fio();
f__fmtbuf = NULL;
return(n);
}
@ -134,9 +132,17 @@ integer e_wsfi(Void)
int n;
n = en_fio();
f__fmtbuf = NULL;
if(f__icnum >= f__svic->icirnum)
return(n);
if(f__svic->icirnum != 1
&& (f__icnum > f__svic->icirnum
|| (f__icnum == f__svic->icirnum && (f__recpos | f__hiwater))))
err(f__svic->icierr,110,"inwrite");
if (f__recpos < f__hiwater)
f__recpos = f__hiwater;
if (f__recpos >= f__svic->icirlen)
err(f__svic->icierr,110,"recend");
if (!f__recpos && f__icnum)
return n;
while(f__recpos++ < f__svic->icirlen)
*f__icptr++ = ' ';
return(n);
return n;
}

6
lib/libI77/ilnw.c
View File

@ -6,9 +6,9 @@ extern char *f__icend;
extern icilist *f__svic;
extern int f__icnum;
#ifdef KR_headers
extern int z_putc();
extern void z_putc();
#else
extern int z_putc(int);
extern void z_putc(int);
#endif
static int
@ -19,7 +19,7 @@ z_wSL(Void)
return z_rnew();
}
VOID
static void
#ifdef KR_headers
c_liw(a) icilist *a;
#else

2
lib/libI77/inquire.c
View File

@ -1,5 +1,6 @@
#include "f2c.h"
#include "fio.h"
#include "string.h"
#ifdef KR_headers
integer f_inqu(a) inlist *a;
#else
@ -7,7 +8,6 @@ integer f_inqu(a) inlist *a;
#undef abs
#undef min
#undef max
#include "string.h"
#include "io.h"
#endif
integer f_inqu(inlist *a)

85
lib/libI77/lread.c
View File

@ -1,15 +1,15 @@
#include "f2c.h"
#include "fio.h"
#include "fmt.h"
#include "lio.h"
#include "ctype.h"
#include "fp.h"
/* Compile with -DF8X_NML_ELIDE_QUOTES to permit eliding quotation */
/* marks in namelist input a la the Fortran 8X Draft published in */
/* the May 1989 issue of Fortran Forum. */
extern char *f__fmtbuf;
#ifdef Allow_TYQUAD
static longint f__llx;
static int quad_read;
#endif
#ifdef KR_headers
@ -24,6 +24,12 @@ int (*f__lioproc)(), (*l_getc)(), (*l_ungetc)();
int (*f__lioproc)(ftnint*, char*, ftnlen, ftnint), (*l_getc)(void),
(*l_ungetc)(int,FILE*);
#endif
#include "fmt.h"
#include "lio.h"
#include "ctype.h"
#include "fp.h"
int l_eof;
#define isblnk(x) (f__ltab[x+1]&B)
@ -96,10 +102,11 @@ double f__lx,f__ly;
#define GETC(x) (x=(*l_getc)())
#define Ungetc(x,y) (*l_ungetc)(x,y)
static int
#ifdef KR_headers
l_R(poststar) int poststar;
l_R(poststar, reqint) int poststar, reqint;
#else
l_R(int poststar)
l_R(int poststar, int reqint)
#endif
{
char s[FMAX+EXPMAXDIGS+4];
@ -148,6 +155,10 @@ l_R(int poststar)
goto retry;
}
if (ch == '.') {
#ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT
if (reqint)
errfl(f__elist->cierr,115,"invalid integer");
#endif
GETC(ch);
if (sp == sp1)
while(ch == '0') {
@ -166,6 +177,10 @@ l_R(int poststar)
if (issign(ch))
goto signonly;
if (havenum && isexp(ch)) {
#ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT
if (reqint)
errfl(f__elist->cierr,115,"invalid integer");
#endif
GETC(ch);
if (issign(ch)) {
signonly:
@ -199,7 +214,7 @@ l_R(int poststar)
sp[1] = 0;
f__lx = atof(s);
#ifdef Allow_TYQUAD
if (quad_read && (se = sp - sp1 + exp) > 14 && se < 20) {
if (reqint&2 && (se = sp - sp1 + exp) > 14 && se < 20) {
/* Assuming 64-bit longint and 32-bit long. */
if (exp < 0)
sp += exp;
@ -254,6 +269,7 @@ rd_count(register int ch)
return f__lcount <= 0;
}
static int
l_C(Void)
{ int ch, nml_save;
double lz;
@ -290,7 +306,7 @@ l_C(Void)
Ungetc(ch,f__cf);
nml_save = nml_read;
nml_read = 0;
if (ch = l_R(1))
if (ch = l_R(1,0))
return ch;
if (!f__ltype)
errfl(f__elist->cierr,112,"no real part");
@ -302,7 +318,7 @@ l_C(Void)
}
while(iswhit(GETC(ch)));
(void) Ungetc(ch,f__cf);
if (ch = l_R(1))
if (ch = l_R(1,0))
return ch;
if (!f__ltype)
errfl(f__elist->cierr,112,"no imaginary part");
@ -316,6 +332,8 @@ l_C(Void)
nml_read = nml_save;
return(0);
}
static int
l_L(Void)
{
int ch;
@ -361,7 +379,10 @@ l_L(Void)
(void) Ungetc(ch, f__cf);
return(0);
}
#define BUFSIZE 128
static int
l_CHAR(Void)
{ int ch,size,i;
static char rafail[] = "realloc failure";
@ -385,6 +406,10 @@ l_CHAR(Void)
case '*':
if (f__lcount == 0) {
f__lcount = 1;
#ifndef F8X_NML_ELIDE_QUOTES
if (nml_read)
goto no_quote;
#endif
goto noquote;
}
p = f__lchar;
@ -403,12 +428,19 @@ l_CHAR(Void)
}
if (!isdigit(ch)) {
f__lcount = 1;
#ifndef F8X_NML_ELIDE_QUOTES
if (nml_read) {
no_quote:
errfl(f__elist->cierr,112,
"undelimited character string");
}
#endif
goto noquote;
}
*p++ = ch;
f__lcount = 10*f__lcount + ch - '0';
if (++i == size) {
f__lchar = (char *)reallocf(f__lchar,
f__lchar = (char *)realloc(f__lchar,
(unsigned int)(size += BUFSIZE));
if(f__lchar == NULL)
errfl(f__elist->cierr,113,rafail);
@ -419,10 +451,17 @@ l_CHAR(Void)
else (void) Ungetc(ch,f__cf);
have_lcount:
if(GETC(ch)=='\'' || ch=='"') quote=ch;
else if(isblnk(ch) || (issep(ch) && ch != '\n') || ch==EOF)
{ (void) Ungetc(ch,f__cf);
return(0);
}
else if(isblnk(ch) || (issep(ch) && ch != '\n') || ch==EOF) {
Ungetc(ch,f__cf);
return 0;
}
#ifndef F8X_NML_ELIDE_QUOTES
else if (nml_read > 1) {
Ungetc(ch,f__cf);
f__lquit = 2;
return 0;
}
#endif
else {
/* Fortran 8x-style unquoted string */
*p++ = ch;
@ -492,11 +531,11 @@ c_le(cilist *a)
if(!f__init)
f_init();
f__fmtbuf="list io";
f__curunit = &f__units[a->ciunit];
if(a->ciunit>=MXUNIT || a->ciunit<0)
err(a->cierr,101,"stler");
f__scale=f__recpos=0;
f__elist=a;
f__curunit = &f__units[a->ciunit];
if(f__curunit->ufd==NULL && fk_open(SEQ,FMT,a->ciunit))
err(a->cierr,102,"lio");
f__cf=f__curunit->ufd;
@ -547,15 +586,17 @@ l_read(ftnint *number, char *ptr, ftnlen len, ftnint type)
case TYINT1:
case TYSHORT:
case TYLONG:
#ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT
ERR(l_R(0,1));
break;
#endif
case TYREAL:
case TYDREAL:
ERR(l_R(0));
ERR(l_R(0,0));
break;
#ifdef TYQUAD
case TYQUAD:
quad_read = 1;
n = l_R(0);
quad_read = 0;
n = l_R(0,2);
if (n)
return n;
break;
@ -595,7 +636,7 @@ l_read(ftnint *number, char *ptr, ftnlen len, ftnint type)
break;
case TYLOGICAL:
case TYLONG:
Ptr->flint=f__lx;
Ptr->flint = (ftnint)f__lx;
break;
#ifdef Allow_TYQUAD
case TYQUAD:
@ -640,10 +681,10 @@ integer s_rsle(cilist *a)
{
int n;
if(n=c_le(a)) return(n);
f__reading=1;
f__external=1;
f__formatted=1;
if(n=c_le(a)) return(n);
f__lioproc = l_read;
f__lquit = 0;
f__lcount = 0;

16
lib/libI77/lwrite.c
View File

@ -13,16 +13,6 @@ donewrec(Void)
(*f__donewrec)();
}
#ifdef KR_headers
t_putc(c)
#else
t_putc(int c)
#endif
{
f__recpos++;
putc(c,f__cf);
return(0);
}
static VOID
#ifdef KR_headers
lwrt_I(n) longint n;
@ -184,10 +174,12 @@ l_put(register char *s)
#endif
{
#ifdef KR_headers
register int c, (*pn)() = f__putn;
register void (*pn)() = f__putn;
#else
register int c, (*pn)(int) = f__putn;
register void (*pn)(int) = f__putn;
#endif
register int c;
while(c = *s++)
(*pn)(c);
}

227
lib/libI77/open.c
View File

@ -1,14 +1,19 @@
#ifndef NON_UNIX_STDIO
#include "sys/types.h"
#include "sys/stat.h"
#endif
#include "f2c.h"
#include "fio.h"
#include "string.h"
#include "rawio.h"
#ifndef NON_POSIX_STDIO
#ifdef MSDOS
#include "io.h"
#else
#include "unistd.h" /* for access */
#endif
#endif
#ifdef KR_headers
extern char *malloc(), *mktemp();
extern char *malloc();
#ifdef NON_ANSI_STDIO
extern char *mktemp();
#endif
extern integer f_clos();
#else
#undef abs
@ -27,44 +32,96 @@ char *f__r_mode[2] = {"rb", "r"};
char *f__w_mode[4] = {"wb", "w", "r+b", "r+"};
#endif
static char f__buf0[400], *f__buf = f__buf0;
int f__buflen = (int)sizeof(f__buf0);
static void
#ifdef KR_headers
f__isdev(s) char *s;
f__bufadj(n, c) int n, c;
#else
f__isdev(char *s)
f__bufadj(int n, int c)
#endif
{
#ifdef NON_UNIX_STDIO
int i, j;
unsigned int len;
char *nbuf, *s, *t, *te;
i = open(s,O_RDONLY);
if (i == -1)
return 0;
j = isatty(i);
close(i);
return j;
if (f__buf == f__buf0)
f__buflen = 1024;
while(f__buflen <= n)
f__buflen <<= 1;
len = (unsigned int)f__buflen;
if (len != f__buflen || !(nbuf = (char*)malloc(len)))
f__fatal(113, "malloc failure");
s = nbuf;
t = f__buf;
te = t + c;
while(t < te)
*s++ = *t++;
if (f__buf != f__buf0)
free(f__buf);
f__buf = nbuf;
}
int
#ifdef KR_headers
f__putbuf(c) int c;
#else
struct stat x;
f__putbuf(int c)
#endif
{
char *s, *se;
int n;
if(stat(s, &x) == -1) return(0);
#ifdef S_IFMT
switch(x.st_mode&S_IFMT) {
case S_IFREG:
case S_IFDIR:
return(0);
if (f__hiwater > f__recpos)
f__recpos = f__hiwater;
n = f__recpos + 1;
if (n >= f__buflen)
f__bufadj(n, f__recpos);
s = f__buf;
se = s + f__recpos;
if (c)
*se++ = c;
*se = 0;
for(;;) {
fputs(s, f__cf);
s += strlen(s);
if (s >= se)
break; /* normally happens the first time */
putc(*s++, f__cf);
}
return 0;
}
void
#ifdef KR_headers
x_putc(c)
#else
#ifdef S_ISREG
/* POSIX version */
if(S_ISREG(x.st_mode) || S_ISDIR(x.st_mode))
return(0);
else
x_putc(int c)
#endif
{
if (f__recpos >= f__buflen)
f__bufadj(f__recpos, f__buflen);
f__buf[f__recpos++] = c;
}
#define opnerr(f,m,s) {if(f) errno= m; else opn_err(m,s,a); return(m);}
static void
#ifdef KR_headers
opn_err(m, s, a) int m; char *s; olist *a;
#else
Help! How does stat work on this system?
opn_err(int m, char *s, olist *a)
#endif
#endif
return(1);
#endif
}
{
if (a->ofnm) {
/* supply file name to error message */
if (a->ofnmlen >= f__buflen)
f__bufadj((int)a->ofnmlen, 0);
g_char(a->ofnm, a->ofnmlen, f__curunit->ufnm = f__buf);
}
f__fatal(m, s);
}
#ifdef KR_headers
integer f_open(a) olist *a;
#else
@ -75,11 +132,9 @@ integer f_open(olist *a)
char buf[256], *s;
cllist x;
int ufmt;
#ifdef NON_UNIX_STDIO
FILE *tf;
#else
#ifndef NON_UNIX_STDIO
int n;
struct stat stb;
#endif
if(a->ounit>=MXUNIT || a->ounit<0)
err(a->oerr,101,"open")
@ -96,7 +151,7 @@ integer f_open(olist *a)
#ifdef NON_UNIX_STDIO
if (b->ufnm
&& strlen(b->ufnm) == a->ofnmlen
&& !strncmp(b->ufnm, b->ufnm, (unsigned)a->ofnmlen))
&& !strncmp(b->ufnm, a->ofnm, (unsigned)a->ofnmlen))
goto same;
#else
g_char(a->ofnm,a->ofnmlen,buf);
@ -125,97 +180,93 @@ integer f_open(olist *a)
if (a->ofnm) {
g_char(a->ofnm,a->ofnmlen,buf);
if (!buf[0])
err(a->oerr,107,"open")
opnerr(a->oerr,107,"open")
}
else
sprintf(buf, "fort.%ld", a->ounit);
b->uscrtch = 0;
b->uend=0;
b->uwrt = 0;
b->ufd = 0;
b->urw = 3;
switch(a->osta ? *a->osta : 'u')
{
case 'o':
case 'O':
#ifdef NON_UNIX_STDIO
if(access(buf,0))
#ifdef NON_POSIX_STDIO
if (!(tf = fopen(buf,"r")))
opnerr(a->oerr,errno,"open")
fclose(tf);
#else
if(stat(buf,&stb))
if (access(buf,0))
opnerr(a->oerr,errno,"open")
#endif
err(a->oerr,errno,"open")
break;
case 's':
case 'S':
b->uscrtch=1;
#ifdef _POSIX_SOURCE
tmpnam(buf);
#else
#ifdef NON_ANSI_STDIO
(void) strcpy(buf,"tmp.FXXXXXX");
(void) mktemp(buf);
#endif
goto replace;
#else
if (!(b->ufd = tmpfile()))
opnerr(a->oerr,errno,"open")
b->ufnm = 0;
#ifndef NON_UNIX_STDIO
b->uinode = b->udev = -1;
#endif
b->useek = 1;
return 0;
#endif
case 'n':
case 'N':
#ifdef NON_UNIX_STDIO
if(!access(buf,0))
#ifdef NON_POSIX_STDIO
if ((tf = fopen(buf,"r")) || (tf = fopen(buf,"a"))) {
fclose(tf);
opnerr(a->oerr,128,"open")
}
#else
if(!stat(buf,&stb))
if (!access(buf,0))
opnerr(a->oerr,128,"open")
#endif
err(a->oerr,128,"open")
/* no break */
case 'r': /* Fortran 90 replace option */
case 'R':
#ifdef NON_ANSI_STDIO
replace:
#ifdef NON_UNIX_STDIO
#endif
if (tf = fopen(buf,f__w_mode[0]))
fclose(tf);
#else
(void) close(creat(buf, 0666));
#endif
}
b->ufnm=(char *) malloc((unsigned int)(strlen(buf)+1));
if(b->ufnm==NULL) err(a->oerr,113,"no space");
if(b->ufnm==NULL) opnerr(a->oerr,113,"no space");
(void) strcpy(b->ufnm,buf);
b->uend=0;
b->uwrt = 0;
#ifdef NON_UNIX_STDIO
if ((s = a->oacc) && (*s == 'd' || *s == 'D'))
if ((s = a->oacc) && b->url)
ufmt = 0;
#endif
if(f__isdev(buf))
{ b->ufd = fopen(buf,f__r_mode[ufmt]);
if(b->ufd==NULL) err(a->oerr,errno,buf)
}
else {
if(!(b->ufd = fopen(buf, f__r_mode[ufmt]))) {
#ifdef NON_UNIX_STDIO
if (b->ufd = fopen(buf, f__w_mode[ufmt|2]))
b->uwrt = 2;
else if (b->ufd = fopen(buf, f__w_mode[ufmt]))
b->uwrt = 1;
else
#else
if ((n = open(buf,O_WRONLY)) >= 0)
b->uwrt = 2;
else {
n = creat(buf, 0666);
b->uwrt = 1;
}
if (n < 0
|| (b->ufd = fdopen(n, f__w_mode[ufmt])) == NULL)
#endif
err(a->oerr, errno, "open");
if(!(tf = fopen(buf, f__w_mode[ufmt|2]))) {
if (tf = fopen(buf, f__r_mode[ufmt]))
b->urw = 1;
else if (tf = fopen(buf, f__w_mode[ufmt])) {
b->uwrt = 1;
b->urw = 2;
}
}
b->useek=f__canseek(b->ufd);
else
err(a->oerr, errno, "open");
}
b->useek = f__canseek(b->ufd = tf);
#ifndef NON_UNIX_STDIO
if((b->uinode=f__inode(buf,&b->udev))==-1)
err(a->oerr,108,"open")
if((b->uinode = f__inode(buf,&b->udev)) == -1)
opnerr(a->oerr,108,"open")
#endif
if(b->useek)
if (a->orl)
rewind(b->ufd);
else if ((s = a->oacc) && (*s == 'a' || *s == 'A')
&& fseek(b->ufd, 0L, SEEK_END))
err(a->oerr,129,"open");
opnerr(a->oerr,129,"open");
return(0);
}
#ifdef KR_headers

4
lib/libI77/rawio.h
View File

@ -1,6 +1,4 @@
#ifdef KR_headers
extern FILE *fdopen();
#else
#ifndef KR_headers
#ifdef MSDOS
#include "io.h"
#ifndef WATCOM

13
lib/libI77/rdfmt.c
View File

@ -1,8 +1,5 @@
#include "f2c.h"
#include "fio.h"
#include "fmt.h"
#include "fp.h"
#include "ctype.h"
extern int f__cursor;
#ifdef KR_headers
@ -14,6 +11,10 @@ extern double atof();
#include "stdlib.h"
#endif
#include "fmt.h"
#include "fp.h"
#include "ctype.h"
static int
#ifdef KR_headers
rd_Z(n,w,len) Uint *n; ftnlen len;
@ -432,7 +433,7 @@ rd_ed(struct syl *p, char *ptr, ftnlen len)
case D:
case G:
case GE:
case F: ch = rd_F((ufloat *)ptr,p->p1,p->p2,len);
case F: ch = rd_F((ufloat *)ptr,p->p1,p->p2.i[0],len);
break;
/* Z and ZM assume 8-bit bytes. */
@ -459,8 +460,8 @@ rd_ned(struct syl *p)
default: fprintf(stderr,"rd_ned, unexpected code: %d\n", p->op);
sig_die(f__fmtbuf, 1);
case APOS:
return(rd_POS(*(char **)&p->p2));
case H: return(rd_H(p->p1,*(char **)&p->p2));
return(rd_POS(p->p2.s));
case H: return(rd_H(p->p1,p->p2.s));
case SLASH: return((*f__donewrec)());
case TR:
case X: f__cursor += p->p1;

3
lib/libI77/rsfe.c
View File

@ -50,16 +50,15 @@ integer s_rsfe(cilist *a) /* start */
#endif
{ int n;
if(!f__init) f_init();
if(n=c_sfe(a)) return(n);
f__reading=1;
f__sequential=1;
f__formatted=1;
f__external=1;
if(n=c_sfe(a)) return(n);
f__elist=a;
f__cursor=f__recpos=0;
f__scale=0;
f__fmtbuf=a->cifmt;
f__curunit= &f__units[a->ciunit];
f__cf=f__curunit->ufd;
if(pars_f(f__fmtbuf)<0) err(a->cierr,100,"startio");
f__getn= x_getc;

17
lib/libI77/sfe.c
View File

@ -7,10 +7,6 @@ extern char *f__fmtbuf;
integer e_rsfe(Void)
{ int n;
n=en_fio();
if (f__cf == stdout)
fflush(stdout);
else if (f__cf == stderr)
fflush(stderr);
f__fmtbuf=NULL;
return(n);
}
@ -20,23 +16,16 @@ c_sfe(a) cilist *a; /* check */
c_sfe(cilist *a) /* check */
#endif
{ unit *p;
f__curunit = p = &f__units[a->ciunit];
if(a->ciunit >= MXUNIT || a->ciunit<0)
err(a->cierr,101,"startio");
p = &f__units[a->ciunit];
if(p->ufd==NULL && fk_open(SEQ,FMT,a->ciunit)) err(a->cierr,114,"sfe")
if(!p->ufmt) err(a->cierr,102,"sfe")
return(0);
}
integer e_wsfe(Void)
{
#ifdef ALWAYS_FLUSH
int n;
n = en_fio();
f__fmtbuf=NULL;
if (!n && fflush(f__cf))
err(f__elist->cierr, errno, "write end");
int n = en_fio();
f__fmtbuf = NULL;
return n;
#else
return(e_rsfe());
#endif
}

4
lib/libI77/sue.c
View File

@ -9,11 +9,11 @@ c_sue(a) cilist *a;
c_sue(cilist *a)
#endif
{
if(a->ciunit >= MXUNIT || a->ciunit < 0)
err(a->cierr,101,"startio");
f__external=f__sequential=1;
f__formatted=0;
f__curunit = &f__units[a->ciunit];
if(a->ciunit >= MXUNIT || a->ciunit < 0)
err(a->cierr,101,"startio");
f__elist=a;
if(f__curunit->ufd==NULL && fk_open(SEQ,UNF,a->ciunit))
err(a->cierr,114,"sue");

2
lib/libI77/util.c
View File

@ -1,4 +1,6 @@
#ifndef NON_UNIX_STDIO
#define _INCLUDE_POSIX_SOURCE /* for HP-UX */
#define _INCLUDE_XOPEN_SOURCE /* for HP-UX */
#include "sys/types.h"
#include "sys/stat.h"
#endif

15
lib/libI77/wref.c
View File

@ -1,10 +1,5 @@
#include "f2c.h"
#include "fio.h"
#include "fmt.h"
#include "fp.h"
#ifndef VAX
#include "ctype.h"
#endif
#ifndef KR_headers
#undef abs
@ -14,6 +9,12 @@
#include "string.h"
#endif
#include "fmt.h"
#include "fp.h"
#ifndef VAX
#include "ctype.h"
#endif
#ifdef KR_headers
wrt_E(p,w,d,e,len) ufloat *p; ftnlen len;
#else
@ -117,8 +118,8 @@ wrt_E(ufloat *p, int w, int d, int e, ftnlen len)
/* accommodate 3 significant digits in exponent */
if (s[2]) {
#ifdef Pedantic
if (!e0 && !s[3])
e1 = 2;/* for(s -= 2, e1 = 2; s[0] = s[1]; s++);
if (!e0 && !s[3])
for(s -= 2, e1 = 2; s[0] = s[1]; s++);
/* Pedantic gives the behavior that Fortran 77 specifies, */
/* i.e., requires that E be specified for exponent fields */

46
lib/libI77/wrtfmt.c
View File

@ -40,43 +40,23 @@ mv_cur(Void) /* shouldn't use fseek because it insists on calling fflush */
}
return(0);
}
if(cursor > 0) {
if (cursor > 0) {
if(f__hiwater <= f__recpos)
for(;cursor>0;cursor--) (*f__putn)(' ');
else if(f__hiwater <= f__recpos + cursor) {
#ifndef NON_UNIX_STDIO
if(f__cf->_ptr + f__hiwater - f__recpos < buf_end(f__cf))
f__cf->_ptr += f__hiwater - f__recpos;
else
#endif
(void) fseek(f__cf, (long) (f__hiwater - f__recpos), SEEK_CUR);
cursor -= f__hiwater - f__recpos;
f__recpos = f__hiwater;
for(; cursor > 0; cursor--)
(*f__putn)(' ');
}
else {
#ifndef NON_UNIX_STDIO
if(f__cf->_ptr + cursor < buf_end(f__cf))
f__cf->_ptr += cursor;
else
#endif
(void) fseek(f__cf, (long)cursor, SEEK_CUR);
f__recpos += cursor;
}
}
if(cursor<0)
else if (cursor < 0)
{
if(cursor+f__recpos<0) err(f__elist->cierr,110,"left off");
#ifndef NON_UNIX_STDIO
if(f__cf->_ptr + cursor >= f__cf->_base)
f__cf->_ptr += cursor;
else
#endif
if(f__curunit && f__curunit->useek)
(void) fseek(f__cf,(long)cursor,SEEK_CUR);
else
err(f__elist->cierr,106,"fmt");
if(cursor + f__recpos < 0)
err(f__elist->cierr,110,"left off");
if(f__hiwater < f__recpos)
f__hiwater = f__recpos;
f__recpos += cursor;
@ -292,9 +272,7 @@ wrt_G(ufloat *p, int w, int d, int e, ftnlen len)
if(x<.1) {
if (x != 0.)
return(wrt_E(p,w,d,e,len));
#ifdef WANT_LEAD_0
i = 1;
#endif
goto have_i;
}
for(;i<=d;i++,up*=10)
@ -328,7 +306,7 @@ w_ed(struct syl *p, char *ptr, ftnlen len)
sig_die(f__fmtbuf, 1);
case I: return(wrt_I((Uint *)ptr,p->p1,len, 10));
case IM:
return(wrt_IM((Uint *)ptr,p->p1,p->p2,len,10));
return(wrt_IM((Uint *)ptr,p->p1,p->p2.i[0],len,10));
/* O and OM don't work right for character, double, complex, */
/* or doublecomplex, and they differ from Fortran 90 in */
@ -336,7 +314,7 @@ w_ed(struct syl *p, char *ptr, ftnlen len)
case O: return(wrt_I((Uint *)ptr, p->p1, len, 8));
case OM:
return(wrt_IM((Uint *)ptr,p->p1,p->p2,len,8));
return(wrt_IM((Uint *)ptr,p->p1,p->p2.i[0],len,8));
case L: return(wrt_L((Uint *)ptr,p->p1, len));
case A: return(wrt_A(ptr,len));
case AW:
@ -344,17 +322,17 @@ w_ed(struct syl *p, char *ptr, ftnlen len)
case D:
case E:
case EE:
return(wrt_E((ufloat *)ptr,p->p1,p->p2,p->p3,len));
return(wrt_E((ufloat *)ptr,p->p1,p->p2.i[0],p->p2.i[1],len));
case G:
case GE:
return(wrt_G((ufloat *)ptr,p->p1,p->p2,p->p3,len));
case F: return(wrt_F((ufloat *)ptr,p->p1,p->p2,len));
return(wrt_G((ufloat *)ptr,p->p1,p->p2.i[0],p->p2.i[1],len));
case F: return(wrt_F((ufloat *)ptr,p->p1,p->p2.i[0],len));
/* Z and ZM assume 8-bit bytes. */
case Z: return(wrt_Z((Uint *)ptr,p->p1,0,len));
case ZM:
return(wrt_Z((Uint *)ptr,p->p1,p->p2,len));
return(wrt_Z((Uint *)ptr,p->p1,p->p2.i[0],len));
}
}
#ifdef KR_headers
@ -380,8 +358,8 @@ w_ned(struct syl *p)
f__cursor += p->p1;
return(1);
case APOS:
return(wrt_AP(*(char **)&p->p2));
return(wrt_AP(p->p2.s));
case H:
return(wrt_H(p->p1,*(char **)&p->p2));
return(wrt_H(p->p1,p->p2.s));
}
}

59
lib/libI77/wsfe.c
View File

@ -4,49 +4,39 @@
#include "fmt.h"
extern int f__hiwater;
#ifdef KR_headers
x_putc(c)
#else
x_putc(int c)
#endif
{
/* this uses \n as an indicator of record-end */
if(c == '\n' && f__recpos < f__hiwater) { /* fseek calls fflush, a loss */
#ifndef NON_UNIX_STDIO
if(f__cf->_ptr + f__hiwater - f__recpos < buf_end(f__cf))
f__cf->_ptr += f__hiwater - f__recpos;
else
#endif
(void) fseek(f__cf, (long)(f__hiwater - f__recpos), SEEK_CUR);
}
#ifdef OMIT_BLANK_CC
if (!f__recpos++ && c == ' ')
return c;
#else
f__recpos++;
#endif
return putc(c,f__cf);
}
int
x_wSL(Void)
{
(*f__putn)('\n');
f__recpos=0;
f__cursor = 0;
f__hiwater = 0;
return(1);
int n = f__putbuf('\n');
f__hiwater = f__recpos = f__cursor = 0;
return(n == 0);
}
static int
xw_end(Void)
{
if(f__nonl == 0)
(*f__putn)('\n');
int n;
if(f__nonl) {
f__putbuf(n = 0);
fflush(f__cf);
}
else
n = f__putbuf('\n');
f__hiwater = f__recpos = f__cursor = 0;
return(0);
return n;
}
static int
xw_rev(Void)
{
if(f__workdone) (*f__putn)('\n');
int n = 0;
if(f__workdone) {
n = f__putbuf('\n');
f__workdone = 0;
}
f__hiwater = f__recpos = f__cursor = 0;
return(f__workdone=0);
return n;
}
#ifdef KR_headers
@ -56,17 +46,16 @@ integer s_wsfe(cilist *a) /*start*/
#endif
{ int n;
if(!f__init) f_init();
if(n=c_sfe(a)) return(n);
f__reading=0;
f__sequential=1;
f__formatted=1;
f__external=1;
if(n=c_sfe(a)) return(n);
f__elist=a;
f__hiwater = f__cursor=f__recpos=0;
f__nonl = 0;
f__scale=0;
f__fmtbuf=a->cifmt;
f__curunit = &f__units[a->ciunit];
f__cf=f__curunit->ufd;
if(pars_f(f__fmtbuf)<0) err(a->cierr,100,"startio");
f__putn= x_putc;

14
lib/libI77/wsle.c
View File

@ -2,6 +2,7 @@
#include "fio.h"
#include "fmt.h"
#include "lio.h"
#include "string.h"
#ifdef KR_headers
integer s_wsle(a) cilist *a;
@ -14,7 +15,7 @@ integer s_wsle(cilist *a)
f__reading=0;
f__external=1;
f__formatted=1;
f__putn = t_putc;
f__putn = x_putc;
f__lioproc = l_write;
L_len = LINE;
f__donewrec = x_wSL;
@ -25,16 +26,11 @@ integer s_wsle(cilist *a)
integer e_wsle(Void)
{
t_putc('\n');
int n = f__putbuf('\n');
f__recpos=0;
#ifdef ALWAYS_FLUSH
if (fflush(f__cf))
if (!n && fflush(f__cf))
err(f__elist->cierr, errno, "write end");
#else
if (f__cf == stdout)
fflush(stdout);
else if (f__cf == stderr)
fflush(stderr);
#endif
return(0);
return(n);
}

2
lib/libI77/wsne.c
View File

@ -16,7 +16,7 @@ s_wsne(cilist *a)
f__reading=0;
f__external=1;
f__formatted=1;
f__putn = t_putc;
f__putn = x_putc;
L_len = LINE;
f__donewrec = x_wSL;
if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit))

26
usr.bin/f2c/Notice
View File

@ -1,23 +1,23 @@
/****************************************************************
Copyright 1990 - 1997 by AT&T Bell Laboratories and Bellcore.
Copyright 1990 - 1997 by AT&T, Lucent Technologies and Bellcore.
Permission to use, copy, modify, and distribute this software
and its documentation for any purpose and without fee is hereby
granted, provided that the above copyright notice appear in all
copies and that both that the copyright notice and this
permission notice and warranty disclaimer appear in supporting
documentation, and that the names of AT&T Bell Laboratories or
Bellcore or any of their entities not be used in advertising or
publicity pertaining to distribution of the software without
specific, written prior permission.
documentation, and that the names of AT&T, Bell Laboratories,
Lucent or Bellcore or any of their entities not be used in
advertising or publicity pertaining to distribution of the
software without specific, written prior permission.
AT&T and Bellcore disclaim all warranties with regard to this
software, including all implied warranties of merchantability
and fitness. In no event shall AT&T or Bellcore be liable for
any special, indirect or consequential damages or any damages
whatsoever resulting from loss of use, data or profits, whether
in an action of contract, negligence or other tortious action,
arising out of or in connection with the use or performance of
this software.
AT&T, Lucent and Bellcore disclaim all warranties with regard to
this software, including all implied warranties of
merchantability and fitness. In no event shall AT&T, Lucent or
Bellcore be liable for any special, indirect or consequential
damages or any damages whatsoever resulting from loss of use,
data or profits, whether in an action of contract, negligence or
other tortious action, arising out of or in connection with the
use or performance of this software.
****************************************************************/

26
usr.bin/f2c/README
View File

@ -32,16 +32,17 @@ details, ask netlib@netlib.bell-labs.com to "send readme from f2c".
On some systems, the malloc and free in malloc.c let f2c run faster
than do the standard malloc and free. Other systems may not tolerate
redefinition of malloc and free (though changes of 8 Nov. 1994 may
render this less of a problem than hitherto). If yours is such a
system, you may either modify the makefile appropriately (remove
"malloc.o" from the "OBJECTS =" assignment), or simply execute
cc -c -DCRAY malloc.c
before typing "make". Still other systems have a -lmalloc that
provides performance competitive with that from malloc.c; you may
wish to compare the two on your system. In general, if f2c faults
when you first try to run it, try compiling malloc.c with -DCRAY;
this is necessary with at least one version of Linux (but not with
others).
render this less of a problem than hitherto). If your system permits
use of a user-supplied malloc, you may wish to change the MALLOC =
line in the makefile to "MALLOC = malloc.o", or to type
make MALLOC=malloc.o
instead of
make
Still other systems have a -lmalloc that provides performance
competitive with that from malloc.c; you may wish to compare the two
on your system. If your system does not permit user-supplied malloc
routines, then f2c may fault with "MALLOC=malloc.o", or may display
other untoward behavior.
On some BSD systems, you may need to create a file named "string.h"
whose single line is
@ -157,6 +158,11 @@ The makefile has a rule for creating tokdefs.h. If you cannot use the
makefile, an alternative is to extract tokdefs.h from the beginning of
gram.c: it's the first 100 lines.
File mem.c has #ifdef CRAY lines that are appropriate for machines
with the conventional CRAY architecture, but not for "Cray" machines
based on DEC Alpha chips, such as the T3E; on such machines, you may
need to make a suitable adjustment, e.g., add #undef CRAY to sysdep.h.
Please send bug reports to dmg@bell-labs.com . The old index file
(now called "readme" due to unfortunate changes in netlib conventions:

9
usr.bin/f2c/format.c
View File

@ -328,7 +328,7 @@ do_p1_comment(infile, outfile)
do_p1_comment(FILE *infile, FILE *outfile)
#endif
{
extern int c_output_line_length, in_comment;
extern int in_comment;
char storage[COMMENT_BUFFER_SIZE + 1];
int length;
@ -340,10 +340,7 @@ do_p1_comment(FILE *infile, FILE *outfile)
gflag1 = sharp_line = 0;
in_comment = 1;
if (length > c_output_line_length - 6)
margin_printf(outfile, "/*%s*/\n", storage);
else
margin_printf(outfile, length ? "/* %s */\n" : "\n", storage);
margin_printf(outfile, length ? "/* %s */\n" : "\n", storage);
in_comment = 0;
gflag1 = sharp_line = gflag;
} /* do_p1_comment */
@ -2428,6 +2425,8 @@ proto(FILE *outfile, Argtypes *at, char *fname)
nice_printf(outfile, "%schar **", comma);
else if (k >= 200) {
k -= 200;
if (k >= 100)
k -= 100;
nice_printf(outfile, "%s%s", comma,
usedcasts[k] = casttypes[k]);
}

112
usr.bin/f2c/formatdata.c
View File

@ -927,6 +927,63 @@ Len(long L, int type)
return buf;
}
static void
#ifdef KR_headers
fill_dcl(outfile, t, k, L) FILE *outfile; int t; int k; ftnint L;
#else
fill_dcl(FILE *outfile, int t, int k, ftnint L)
#endif
{
nice_printf(outfile, "%s fill_%d[%ld];\n", typename[t], k, L);
}
static int
#ifdef KR_headers
fill_type(L, loc, xtype) ftnint L; ftnint loc; int xtype;
#else
fill_type(ftnint L, ftnint loc, int xtype)
#endif
{
int ft, ft1, szshort;
if (xtype == TYCHAR)
return xtype;
szshort = typesize[TYSHORT];
ft = L % szshort ? TYCHAR : type_choice[L/szshort % 4];
ft1 = loc % szshort ? TYCHAR : type_choice[loc/szshort % 4];
if (typesize[ft] > typesize[ft1])
ft = ft1;
return ft;
}
static ftnint
#ifdef KR_headers
get_fill(dloc, loc, t0, t1, L0, L1, xtype) ftnint dloc; ftnint loc; int *t0; int *t1; ftnint *L0; ftnint *L1; int xtype;
#else
get_fill(ftnint dloc, ftnint loc, int *t0, int *t1, ftnint *L0, ftnint *L1, int xtype)
#endif
{
ftnint L, L2, loc0;
if (L = loc % typesize[xtype]) {
loc0 = loc;
loc += L = typesize[xtype] - L;
if (L % typesize[TYSHORT])
*t0 = TYCHAR;
else
L /= typesize[*t0 = fill_type(L, loc0, xtype)];
}
if (dloc < loc + typesize[xtype])
return 0;
*L0 = L;
L2 = (dloc - loc) / typesize[xtype];
loc += L2*typesize[xtype];
if (dloc -= loc)
dloc /= typesize[*t1 = fill_type(dloc, loc, xtype)];
*L1 = dloc;
return L2;
}
void
#ifdef KR_headers
wr_equiv_init(outfile, memno, Values, iscomm)
@ -939,12 +996,13 @@ wr_equiv_init(FILE *outfile, int memno, chainp *Values, int iscomm)
#endif
{
struct Equivblock *eqv;
int btype, curtype, dtype, filltype, filltype1, j, k, wasblank, xtype;
int btype, curtype, dtype, filltype, j, k, n, t0, t1;
int wasblank, xfilled, xtype;
static char Blank[] = "";
register char *comma = Blank;
register chainp cp, v;
chainp sentinel, values, v1, vlast;
ftnint L, L1, dL, dloc, loc, loc0;
ftnint L, L0, L1, L2, dL, dloc, loc, loc0;
union Constant Const;
char imag_buf[50], real_buf[50];
int szshort = typesize[TYSHORT];
@ -978,8 +1036,10 @@ wr_equiv_init(FILE *outfile, int memno, chainp *Values, int iscomm)
if (halign && typealign[typepref[xtype]] < typealign[htype])
xtype = htype;
xtype = typepref[xtype];
*Values = values = revchain(vlast = *Values);
xfilled = 2;
if (xtype != TYCHAR) {
/* unless the data include a value of the appropriate
@ -1007,6 +1067,10 @@ wr_equiv_init(FILE *outfile, int memno, chainp *Values, int iscomm)
if (basetype[(int)cp->nextp->datap] == btype)
break;
dloc = (ftnint)cp->datap;
if (get_fill(dloc, loc, &t0, &t1, &L0, &L1, xtype)) {
xfilled = 0;
break;
}
L1 = dloc - loc;
if (L1 > 0
&& !(L1 % szshort)
@ -1015,9 +1079,9 @@ wr_equiv_init(FILE *outfile, int memno, chainp *Values, int iscomm)
&& btype <= type_choice[loc/szshort % 4])
break;
dtype = (int)cp->nextp->datap;
loc = dloc + dtype == TYBLANK
loc = dloc + (dtype == TYBLANK
? (ftnint)cp->nextp->nextp->datap
: typesize[dtype];
: typesize[dtype]);
}
}
sentinel = mkchain((char *)L, mkchain((char *)TYERROR,CHNULL));
@ -1069,19 +1133,19 @@ wr_equiv_init(FILE *outfile, int memno, chainp *Values, int iscomm)
loc0 = dloc;
}
if (L > 0) {
if (xtype == TYCHAR)
filltype = TYCHAR;
else {
filltype = L % szshort ? TYCHAR
: type_choice[L/szshort % 4];
filltype1 = loc % szshort ? TYCHAR
: type_choice[loc/szshort % 4];
if (typesize[filltype] > typesize[filltype1])
filltype = filltype1;
}
filltype = fill_type(L, loc, xtype);
L1 = L / typesize[filltype];
nice_printf(outfile, "%s fill_%d[%ld];\n",
typename[filltype], ++k, L1);
if (!xfilled && (L2 = get_fill(dloc, loc, &t0, &t1,
&L0, &L1, xtype))) {
xfilled = 1;
if (L0)
fill_dcl(outfile, t0, ++k, L0);
fill_dcl(outfile, xtype, ++k, L2);
if (L1)
fill_dcl(outfile, t1, ++k, L1);
}
else
fill_dcl(outfile, filltype, ++k, L1);
loc = dloc;
}
if (wasblank) {
@ -1097,6 +1161,7 @@ wr_equiv_init(FILE *outfile, int memno, chainp *Values, int iscomm)
? extsymtab[memno].cextname
: equiv_name(eqvmemno, CNULL));
loc = 0;
xfilled &= 2;
for(v = values; ; v = v->nextp) {
cp = (chainp)v->datap;
if (!cp)
@ -1106,8 +1171,19 @@ wr_equiv_init(FILE *outfile, int memno, chainp *Values, int iscomm)
break;
dloc = (ftnint)cp->datap;
if (dloc > loc) {
nice_printf(outfile, "%s{0}", comma);
comma = ", ";
n = 1;
if (!xfilled && (L2 = get_fill(dloc, loc, &t0, &t1,
&L0, &L1, xtype))) {
xfilled = 1;
if (L0)
n = 2;
if (L1)
n++;
}
while(n--) {
nice_printf(outfile, "%s{0}", comma);
comma = ", ";
}
loc = dloc;
}
if (comma != Blank)

2
usr.bin/f2c/gram.dcl
View File

@ -243,7 +243,7 @@ datavar: lhs
np = pp -> namep;
vardcl(np);
if ((pp->fcharp || pp->lcharp)
&& (np->vtype != TYCHAR || np->vdim))
&& (np->vtype != TYCHAR || np->vdim && !pp->argsp))
sserr(np);
if(np->vstg == STGCOMMON)
extsymtab[np->vardesc.varno].extinit = YES;

3
usr.bin/f2c/intr.c
View File

@ -1,5 +1,5 @@
/****************************************************************
Copyright 1990, 1992, 1994-6 by AT&T, Lucent Technologies and Bellcore.
Copyright 1990, 1992, 1994-6, 1998 by AT&T, Lucent Technologies and Bellcore.
Permission to use, copy, modify, and distribute this software
and its documentation for any purpose and without fee is hereby
@ -52,6 +52,7 @@ LOCAL struct Intrblock
"real", { INTRCONV, TYREAL, 1 },
/* 1 ==> real(TYDCOMPLEX) yields TYDREAL */
"dble", { INTRCONV, TYDREAL },
"dreal", { INTRCONV, TYDREAL, 0, 0, 0, 1 },
"cmplx", { INTRCONV, TYCOMPLEX },
"dcmplx", { INTRCONV, TYDCOMPLEX, 0, 1 },
"ifix", { INTRCONV, TYLONG },

11
usr.bin/f2c/lex.c
View File

@ -1642,12 +1642,15 @@ store_comment(char *str)
}
len = strlen(str) + 1;
if (cbnext + len > cblast) {
if (!cbcur || !(ncb = cbcur->next)) {
ncb = 0;
if (cbcur) {
cbcur->last = cbnext;
ncb = cbcur->next;
}
if (!ncb) {
ncb = (comment_buf *) Alloc(sizeof(comment_buf));
if (cbcur) {
cbcur->last = cbnext;
if (cbcur)
cbcur->next = ncb;
}
else {
cbfirst = ncb;
cbinit = ncb->buf;

17
usr.bin/f2c/malloc.c
View File

@ -162,4 +162,21 @@ realloc(Char *f, Unsigned size)
memcpy(q, f, s1);
return q;
}
/* The following (calloc) should really be in a separate file, */
/* but defining it here sometimes avoids confusion on systems */
/* that do not provide calloc in its own file. */
Char *
#ifdef KR_headers
calloc(n, m) Unsigned m, n;
#else
calloc(Unsigned n, Unsigned m)
#endif
{
Char *rv = malloc(n *= m);
if (n && rv)
memset(rv, 0, n);
return rv;
}
#endif

12
usr.bin/f2c/niceprintf.c
View File

@ -229,7 +229,7 @@ fwd_strcpy(register char *t, register char *s)
extern FILEP c_file;
extern char tr_tab[]; /* in output.c */
register char *Tr = tr_tab;
int ch, inc, ind;
int ch, cmax, inc, ind;
static int extra_indent, last_indent, set_cursor = 1;
cursor_pos += indent - last_indent;
@ -250,13 +250,17 @@ fwd_strcpy(register char *t, register char *s)
ind = indent <= MAX_INDENT
? indent
: MIN_INDENT + indent % (MAX_INDENT - MIN_INDENT);
cursor_pos = ind + extra_indent;
cursor_pos = extra_indent;
if (use_indent)
cursor_pos += ind;
set_cursor = 0;
}
if (in_comment)
if (in_comment) {
cmax = max_line_len + 32; /* let comments be wider */
for (pointer = next_slot; *pointer && *pointer != '\n' &&
cursor_pos <= max_line_len; pointer++)
cursor_pos <= cmax; pointer++)
cursor_pos++;
}
else
for (pointer = next_slot; *pointer && *pointer != '\n' &&
cursor_pos <= max_line_len; pointer++) {

18
usr.bin/f2c/output.c
View File

@ -443,8 +443,6 @@ out_name(FILE *fp, Namep namep)
} /* out_name */
static char *Longfmt = "%ld";
#define cpd(n) cp->vstg ? cp->Const.cds[n] : dtos(cp->Const.cd[n])
void
@ -469,7 +467,7 @@ out_const(FILE *fp, register Constp cp)
#ifdef TYQUAD
case TYQUAD:
#endif
nice_printf (fp, Longfmt, cp->Const.ci); /* don't cast ci! */
nice_printf (fp, "%ld", cp->Const.ci); /* don't cast ci! */
break;
case TYREAL:
nice_printf(fp, "%s", flconst(real_buf, cpd(0)));
@ -1315,10 +1313,11 @@ out_call(FILE *outfile, int op, int ftype, expptr len, expptr name, expptr args)
/* Might be a Constant expression, e.g. string length, character constants */
else if (q -> tag == TCONST) {
if (tyioint == TYLONG)
Longfmt = "%ldL";
out_const(outfile, &q->constblock);
Longfmt = "%ld";
if (q->constblock.vtype == TYLONG)
nice_printf(outfile, "(ftnlen)%ld",
q->constblock.Const.ci);
else
out_const(outfile, &q->constblock);
}
/* Must be some other kind of expression, or register var, or constant.
@ -1329,7 +1328,10 @@ out_call(FILE *outfile, int op, int ftype, expptr len, expptr name, expptr args)
int use_paren = q -> tag == TEXPR &&
op_precedence (q -> exprblock.opcode) <=
op_precedence (OPCOMMA);
if (q->headblock.vtype == TYREAL && forcereal) {
nice_printf(outfile, "(real)");
use_paren = 1;
}
if (use_paren) nice_printf (outfile, "(");
expr_out (outfile, q);
if (use_paren) nice_printf (outfile, ")");

4
usr.bin/f2c/putpcc.c
View File

@ -559,6 +559,10 @@ putpower(expptr p)
/* Write the power computation out immediately */
putout (p);
p = putx( mkexpr(OPSTAR, cpexpr((expptr)t1), cpexpr((expptr)t1)));
} else if (k == 3) {
putout(p);
p = putx( mkexpr(OPSTAR, cpexpr((expptr)t1),
mkexpr(OPSTAR, cpexpr((expptr)t1), cpexpr((expptr)t1))));
} else {
t2 = mktmp(type, ENULL);
p = mkexpr (OPCOMMA, p, putassign(cpexpr((expptr)t2),

4
usr.bin/f2c/version.c
View File

@ -1,2 +1,2 @@
char F2C_version[] = "19970219";
char xxxvers[] = "\n@(#) FORTRAN 77 to C Translator, VERSION 19970219\n";
char F2C_version[] = "19980913";
char xxxvers[] = "\n@(#) FORTRAN 77 to C Translator, VERSION 19980913\n";