diff options
| author | joerg <joerg@FreeBSD.org> | 1999-02-03 17:23:49 +0000 |
|---|---|---|
| committer | joerg <joerg@FreeBSD.org> | 1999-02-03 17:23:49 +0000 |
| commit | 38d2602fc10af68938b30ae204bbdd4ea9fdb506 (patch) | |
| tree | 2340d0a1cae271336fb29c80c560f5c3b9d2211b | |
| parent | 4176c26a7a1c550e3ef04ef8c9734bfc83ae9f11 (diff) | |
| download | FreeBSD-src-38d2602fc10af68938b30ae204bbdd4ea9fdb506.zip FreeBSD-src-38d2602fc10af68938b30ae204bbdd4ea9fdb506.tar.gz | |
Update to the most recent version. Among other things, this also solves
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>
55 files changed, 813 insertions, 679 deletions
diff --git a/lib/libF77/Notice b/lib/libF77/Notice index 64af9f1..261b719 100644 --- a/lib/libF77/Notice +++ b/lib/libF77/Notice @@ -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. ****************************************************************/ diff --git a/lib/libF77/README b/lib/libF77/README index 7668215..5e532ee 100644 --- a/lib/libF77/README +++ b/lib/libF77/README @@ -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. diff --git a/lib/libF77/Version.c b/lib/libF77/Version.c index eb4fa2d..64de577 100644 --- a/lib/libF77/Version.c +++ b/lib/libF77/Version.c @@ -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. */ diff --git a/lib/libF77/c_div.c b/lib/libF77/c_div.c index 57139a0..ac96307 100644 --- a/lib/libF77/c_div.c +++ b/lib/libF77/c_div.c @@ -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; } diff --git a/lib/libF77/d_lg10.c b/lib/libF77/d_lg10.c index 3135881..f03ff00 100644 --- a/lib/libF77/d_lg10.c +++ b/lib/libF77/d_lg10.c @@ -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) ); } diff --git a/lib/libF77/h_dnnt.c b/lib/libF77/h_dnnt.c index 9fbeb5c..6ffae98 100644 --- a/lib/libF77/h_dnnt.c +++ b/lib/libF77/h_dnnt.c @@ -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)); } diff --git a/lib/libF77/h_nint.c b/lib/libF77/h_nint.c index bf63df1..1cd87df 100644 --- a/lib/libF77/h_nint.c +++ b/lib/libF77/h_nint.c @@ -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)); } diff --git a/lib/libF77/i_dnnt.c b/lib/libF77/i_dnnt.c index 9d46c4b..b5d5006 100644 --- a/lib/libF77/i_dnnt.c +++ b/lib/libF77/i_dnnt.c @@ -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)); } diff --git a/lib/libF77/i_nint.c b/lib/libF77/i_nint.c index ccde785..676f9b3 100644 --- a/lib/libF77/i_nint.c +++ b/lib/libF77/i_nint.c @@ -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)); } diff --git a/lib/libF77/main.c b/lib/libF77/main.c index d6ff84a..9654805 100644 --- a/lib/libF77/main.c +++ b/lib/libF77/main.c @@ -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 diff --git a/lib/libF77/r_lg10.c b/lib/libF77/r_lg10.c index c40138e..4ea02f4 100644 --- a/lib/libF77/r_lg10.c +++ b/lib/libF77/r_lg10.c @@ -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) ); } diff --git a/lib/libF77/s_paus.c b/lib/libF77/s_paus.c index 2501cb5a..796300b 100644 --- a/lib/libF77/s_paus.c +++ b/lib/libF77/s_paus.c @@ -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; } diff --git a/lib/libF77/signal1.h b/lib/libF77/signal1.h index 8800a18..662cae4 100644 --- a/lib/libF77/signal1.h +++ b/lib/libF77/signal1.h @@ -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 diff --git a/lib/libF77/signal_.c b/lib/libF77/signal_.c index 9b31f5a..9f243d8 100644 --- a/lib/libF77/signal_.c +++ b/lib/libF77/signal_.c @@ -1,15 +1,11 @@ #include "f2c.h" +#include "signal1.h" + ftnint #ifdef KR_headers -typedef VOID (*sig_pf)(); -extern sig_pf signal(); -#define signal1 signal - -ftnint signal_(sigp, proc) integer *sigp; sig_pf proc; +signal_(sigp, proc) integer *sigp; sig_pf proc; #else -#include "signal1.h" - -ftnint signal_(integer *sigp, sig_pf proc) +signal_(integer *sigp, sig_pf proc) #endif { int sig; diff --git a/lib/libF77/z_div.c b/lib/libF77/z_div.c index ed7ee66..22153fa 100644 --- a/lib/libF77/z_div.c +++ b/lib/libF77/z_div.c @@ -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; } diff --git a/lib/libI77/Notice b/lib/libI77/Notice index 8db1d7b..261b719 100644 --- a/lib/libI77/Notice +++ b/lib/libI77/Notice @@ -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. ****************************************************************/ diff --git a/lib/libI77/Version.c b/lib/libI77/Version.c index b73ae67..031c975 100644 --- a/lib/libI77/Version.c +++ b/lib/libI77/Version.c @@ -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? */ diff --git a/lib/libI77/backspace.c b/lib/libI77/backspace.c index 3771cd9..c3fa545 100644 --- a/lib/libI77/backspace.c +++ b/lib/libI77/backspace.c @@ -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); + 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; + } + err(a->aerr,(EOF),"backspace") } -#ifdef MSDOS break2: -#endif - if(x==0) - { - (void) fseek(b->ufd, 0L, SEEK_SET); - return(0); - } - else if(n<=0) err(a->aerr,(EOF),"backspace") - (void) fseek(b->ufd, x, SEEK_SET); - } + fseek(f, z, SEEK_SET); + return 0; } diff --git a/lib/libI77/close.c b/lib/libI77/close.c index 29a7af5..5810059 100644 --- a/lib/libI77/close.c +++ b/lib/libI77/close.c @@ -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); } diff --git a/lib/libI77/dfe.c b/lib/libI77/dfe.c index 51023d5..6963d5a 100644 --- a/lib/libI77/dfe.c +++ b/lib/libI77/dfe.c @@ -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) { diff --git a/lib/libI77/due.c b/lib/libI77/due.c index 670b0f1..83f4dc0 100644 --- a/lib/libI77/due.c +++ b/lib/libI77/due.c @@ -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; diff --git a/lib/libI77/endfile.c b/lib/libI77/endfile.c index f5990e3..d28b6c4 100644 --- a/lib/libI77/endfile.c +++ b/lib/libI77/endfile.c @@ -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; diff --git a/lib/libI77/err.c b/lib/libI77/err.c index 29747ff..e25d19f 100644 --- a/lib/libI77/err.c +++ b/lib/libI77/err.c @@ -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 diff --git a/lib/libI77/fio.h b/lib/libI77/fio.h index e8c693b..bb20dd2 100644 --- a/lib/libI77/fio.h +++ b/lib/libI77/fio.h @@ -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 diff --git a/lib/libI77/fmt.c b/lib/libI77/fmt.c index 12792fc..364210c 100644 --- a/lib/libI77/fmt.c +++ b/lib/libI77/fmt.c @@ -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 diff --git a/lib/libI77/fmt.h b/lib/libI77/fmt.h index 509746e..19065a2 100644 --- a/lib/libI77/fmt.h +++ b/lib/libI77/fmt.h @@ -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; diff --git a/lib/libI77/iio.c b/lib/libI77/iio.c index 4c8eb9d..58b2a75 100644 --- a/lib/libI77/iio.c +++ b/lib/libI77/iio.c @@ -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; } diff --git a/lib/libI77/ilnw.c b/lib/libI77/ilnw.c index b415686..aff38315 100644 --- a/lib/libI77/ilnw.c +++ b/lib/libI77/ilnw.c @@ -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 diff --git a/lib/libI77/inquire.c b/lib/libI77/inquire.c index ec98b22..2949165 100644 --- a/lib/libI77/inquire.c +++ b/lib/libI77/inquire.c @@ -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) diff --git a/lib/libI77/lread.c b/lib/libI77/lread.c index 76d84f7..6f537a7 100644 --- a/lib/libI77/lread.c +++ b/lib/libI77/lread.c @@ -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 @@ retry: 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 @@ retry: 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 @@ bad: 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; diff --git a/lib/libI77/lwrite.c b/lib/libI77/lwrite.c index 5da7dfb..bf209f4 100644 --- a/lib/libI77/lwrite.c +++ b/lib/libI77/lwrite.c @@ -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); } diff --git a/lib/libI77/open.c b/lib/libI77/open.c index 75386b9..4ef58af 100644 --- a/lib/libI77/open.c +++ b/lib/libI77/open.c @@ -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 -#else - Help! How does stat work on this system? -#endif +x_putc(int c) #endif - return(1); +{ + 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 +opn_err(int m, char *s, olist *a) #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 diff --git a/lib/libI77/rawio.h b/lib/libI77/rawio.h index 4cbd847..fd36a48 100644 --- a/lib/libI77/rawio.h +++ b/lib/libI77/rawio.h @@ -1,6 +1,4 @@ -#ifdef KR_headers -extern FILE *fdopen(); -#else +#ifndef KR_headers #ifdef MSDOS #include "io.h" #ifndef WATCOM diff --git a/lib/libI77/rdfmt.c b/lib/libI77/rdfmt.c index 03b325e..3de3e49 100644 --- a/lib/libI77/rdfmt.c +++ b/lib/libI77/rdfmt.c @@ -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; diff --git a/lib/libI77/rsfe.c b/lib/libI77/rsfe.c index 41ff257..c6e7f95 100644 --- a/lib/libI77/rsfe.c +++ b/lib/libI77/rsfe.c @@ -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; diff --git a/lib/libI77/sfe.c b/lib/libI77/sfe.c index eea9078..cade56a 100644 --- a/lib/libI77/sfe.c +++ b/lib/libI77/sfe.c @@ -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 } diff --git a/lib/libI77/sue.c b/lib/libI77/sue.c index b1b8bc3..d2a7c34 100644 --- a/lib/libI77/sue.c +++ b/lib/libI77/sue.c @@ -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"); diff --git a/lib/libI77/util.c b/lib/libI77/util.c index 5275499..6468db0 100644 --- a/lib/libI77/util.c +++ b/lib/libI77/util.c @@ -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 diff --git a/lib/libI77/wref.c b/lib/libI77/wref.c index 5e4871d..2f3fce8 100644 --- a/lib/libI77/wref.c +++ b/lib/libI77/wref.c @@ -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 @@ nogood: /* 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 */ diff --git a/lib/libI77/wrtfmt.c b/lib/libI77/wrtfmt.c index f261ec3..477c40f 100644 --- a/lib/libI77/wrtfmt.c +++ b/lib/libI77/wrtfmt.c @@ -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)); } } diff --git a/lib/libI77/wsfe.c b/lib/libI77/wsfe.c index 7c7f014..a74e2d5 100644 --- a/lib/libI77/wsfe.c +++ b/lib/libI77/wsfe.c @@ -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; diff --git a/lib/libI77/wsle.c b/lib/libI77/wsle.c index 44b6972..4bb862f 100644 --- a/lib/libI77/wsle.c +++ b/lib/libI77/wsle.c @@ -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); } diff --git a/lib/libI77/wsne.c b/lib/libI77/wsne.c index 0febd52..ae3f817 100644 --- a/lib/libI77/wsne.c +++ b/lib/libI77/wsne.c @@ -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)) diff --git a/usr.bin/f2c/Notice b/usr.bin/f2c/Notice index 8db1d7b..261b719 100644 --- a/usr.bin/f2c/Notice +++ b/usr.bin/f2c/Notice @@ -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. ****************************************************************/ diff --git a/usr.bin/f2c/README b/usr.bin/f2c/README index 8267bea..6b0d2b2 100644 --- a/usr.bin/f2c/README +++ b/usr.bin/f2c/README @@ -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: diff --git a/usr.bin/f2c/format.c b/usr.bin/f2c/format.c index bcd9b99..1e92d3b 100644 --- a/usr.bin/f2c/format.c +++ b/usr.bin/f2c/format.c @@ -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]); } diff --git a/usr.bin/f2c/formatdata.c b/usr.bin/f2c/formatdata.c index 501463a..56507be 100644 --- a/usr.bin/f2c/formatdata.c +++ b/usr.bin/f2c/formatdata.c @@ -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) diff --git a/usr.bin/f2c/gram.dcl b/usr.bin/f2c/gram.dcl index b30a45c..e5c5df0 100644 --- a/usr.bin/f2c/gram.dcl +++ b/usr.bin/f2c/gram.dcl @@ -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; diff --git a/usr.bin/f2c/intr.c b/usr.bin/f2c/intr.c index c83325f..3fc177a 100644 --- a/usr.bin/f2c/intr.c +++ b/usr.bin/f2c/intr.c @@ -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 }, diff --git a/usr.bin/f2c/lex.c b/usr.bin/f2c/lex.c index 6e779e1..900128e 100644 --- a/usr.bin/f2c/lex.c +++ b/usr.bin/f2c/lex.c @@ -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; diff --git a/usr.bin/f2c/malloc.c b/usr.bin/f2c/malloc.c index 3f5cb2a..7bd54bc 100644 --- a/usr.bin/f2c/malloc.c +++ b/usr.bin/f2c/malloc.c @@ -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 diff --git a/usr.bin/f2c/niceprintf.c b/usr.bin/f2c/niceprintf.c index 0d5f5cc..e2d3825 100644 --- a/usr.bin/f2c/niceprintf.c +++ b/usr.bin/f2c/niceprintf.c @@ -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++) { diff --git a/usr.bin/f2c/output.c b/usr.bin/f2c/output.c index 03d0ed0..5f650e7 100644 --- a/usr.bin/f2c/output.c +++ b/usr.bin/f2c/output.c @@ -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, ")"); diff --git a/usr.bin/f2c/putpcc.c b/usr.bin/f2c/putpcc.c index c104098..87d4550 100644 --- a/usr.bin/f2c/putpcc.c +++ b/usr.bin/f2c/putpcc.c @@ -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), diff --git a/usr.bin/f2c/version.c b/usr.bin/f2c/version.c index 87a0922..90392f1 100644 --- a/usr.bin/f2c/version.c +++ b/usr.bin/f2c/version.c @@ -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"; |
