From c3ad4b45831254b407f78f61ad43d524af6e428f Mon Sep 17 00:00:00 2001 From: Joerg Wunsch Date: Wed, 3 Feb 1999 17:23:49 +0000 Subject: [PATCH] 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 --- lib/libF77/Notice | 26 ++--- lib/libF77/README | 4 + lib/libF77/Version.c | 6 +- lib/libF77/c_div.c | 24 ++--- lib/libF77/d_lg10.c | 6 +- lib/libF77/h_dnnt.c | 3 +- lib/libF77/h_nint.c | 3 +- lib/libF77/i_dnnt.c | 3 +- lib/libF77/i_nint.c | 3 +- lib/libF77/main.c | 18 ++-- lib/libF77/r_lg10.c | 6 +- lib/libF77/s_paus.c | 6 +- lib/libF77/signal1.h | 12 +++ lib/libF77/signal_.c | 14 +-- lib/libF77/z_div.c | 26 ++--- lib/libI77/Notice | 26 ++--- lib/libI77/Version.c | 50 ++++++++- lib/libI77/backspace.c | 93 ++++++---------- lib/libI77/close.c | 9 +- lib/libI77/dfe.c | 47 ++++---- lib/libI77/due.c | 4 +- lib/libI77/endfile.c | 116 ++++---------------- lib/libI77/err.c | 78 ++++++-------- lib/libI77/fio.h | 13 ++- lib/libI77/fmt.c | 104 +++++++++++------- lib/libI77/fmt.h | 7 +- lib/libI77/iio.c | 30 +++--- lib/libI77/ilnw.c | 6 +- lib/libI77/inquire.c | 2 +- lib/libI77/lread.c | 85 +++++++++++---- lib/libI77/lwrite.c | 16 +-- lib/libI77/open.c | 227 ++++++++++++++++++++++++--------------- lib/libI77/rawio.h | 4 +- lib/libI77/rdfmt.c | 13 +-- lib/libI77/rsfe.c | 3 +- lib/libI77/sfe.c | 17 +-- lib/libI77/sue.c | 4 +- lib/libI77/util.c | 2 + lib/libI77/wref.c | 15 +-- lib/libI77/wrtfmt.c | 46 +++----- lib/libI77/wsfe.c | 59 +++++----- lib/libI77/wsle.c | 14 +-- lib/libI77/wsne.c | 2 +- usr.bin/f2c/Notice | 26 ++--- usr.bin/f2c/README | 26 +++-- usr.bin/f2c/format.c | 9 +- usr.bin/f2c/formatdata.c | 112 +++++++++++++++---- usr.bin/f2c/gram.dcl | 2 +- usr.bin/f2c/intr.c | 3 +- usr.bin/f2c/lex.c | 11 +- usr.bin/f2c/malloc.c | 17 +++ usr.bin/f2c/niceprintf.c | 12 ++- usr.bin/f2c/output.c | 18 ++-- usr.bin/f2c/putpcc.c | 4 + usr.bin/f2c/version.c | 4 +- 55 files changed, 815 insertions(+), 681 deletions(-) diff --git a/lib/libF77/Notice b/lib/libF77/Notice index 64af9f12dc4e..261b719bc57e 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 766821525517..5e532ee09902 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 eb4fa2d5cf82..64de577df1f7 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 57139a008ae1..ac963079ba29 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 3135881c56a6..f03ff0043f86 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 9fbeb5ce6244..6ffae9877bba 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 bf63df128d89..1cd87df34f05 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 9d46c4b6ad9d..b5d5006f6623 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 ccde78548880..676f9b347445 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 d6ff84a7df7c..965480531afa 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 c40138ec5ce8..4ea02f451003 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 2501cb5aebe1..796300bf7cd4 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 8800a18d77b4..662cae450dc4 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 9b31f5a87be2..9f243d86e60a 100644 --- a/lib/libF77/signal_.c +++ b/lib/libF77/signal_.c @@ -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; diff --git a/lib/libF77/z_div.c b/lib/libF77/z_div.c index ed7ee665751a..22153fa4514a 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 8db1d7b45e5f..261b719bc57e 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 b73ae67acc36..031c975708f8 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 3771cd961571..c3fa545df2e3 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); - } -#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; } diff --git a/lib/libI77/close.c b/lib/libI77/close.c index 29a7af54c1f8..58100593f75b 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 51023d586321..6963d5a011ab 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__recposurl) - (*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 670b0f1a88ee..83f4dc00a4e5 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 f5990e3b8d1e..d28b6c411d86 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 29747ffec55d..e25d19f20b33 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 e8c693b1f752..bb20dd2ca043 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 12792fcf1ddb..364210c26240 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 509746e13b9e..19065a2f0452 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 4c8eb9de4b6b..58b2a75cdddb 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 b4156861eeb8..aff383153448 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 ec98b22f8401..29491659a674 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 76d84f769936..6f537a7ebffe 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 @@ 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; diff --git a/lib/libI77/lwrite.c b/lib/libI77/lwrite.c index 5da7dfbb972a..bf209f47ed20 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 75386b9ca9f5..4ef58afbb4d6 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 +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 diff --git a/lib/libI77/rawio.h b/lib/libI77/rawio.h index 4cbd847e57db..fd36a482602c 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 03b325efc6ce..3de3e494ca64 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 41ff25731144..c6e7f954a949 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 eea9078eee42..cade56a48822 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 b1b8bc385489..d2a7c34f12e5 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 5275499e76ee..6468db0cd2a7 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 5e4871d0ecbb..2f3fce89dd31 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 @@ 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 */ diff --git a/lib/libI77/wrtfmt.c b/lib/libI77/wrtfmt.c index f261ec32ee37..477c40f5d3ba 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 7c7f0145a476..a74e2d5c2aa7 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 44b69729761c..4bb862f43dec 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 0febd52634fd..ae3f8178949c 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 8db1d7b45e5f..261b719bc57e 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 8267bea4ec56..6b0d2b2cfc29 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 bcd9b99156a4..1e92d3bb5301 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 501463a877b4..56507bed19e4 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 b30a45cfae3f..e5c5df0d5cd6 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 c83325fbe19e..3fc177ad0ea0 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 6e779e1b9924..900128e501ef 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 3f5cb2a9a84f..7bd54bcea73f 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 0d5f5ccf5ffa..e2d3825e4aae 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 03d0ed0cb00c..5f650e7d9795 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 c104098e030f..87d4550fff1e 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 87a09227efe1..90392f19f997 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";