From 5d60853225c64c88883ca805bfc61ff0fa082567 Mon Sep 17 00:00:00 2001 From: Jean-Marc Zucconi Date: Thu, 28 Sep 1995 20:36:16 +0000 Subject: Update to the 1995/09/20 version. Previous version was 1993/12/17 The diffs are large mainly because of prototyping changes. --- usr.bin/f2c/Notice | 2 +- usr.bin/f2c/README | 81 ++++-- usr.bin/f2c/cds.c | 11 +- usr.bin/f2c/data.c | 109 +++++--- usr.bin/f2c/defines.h | 6 - usr.bin/f2c/defs.h | 359 ++++++++++++++++++++++---- usr.bin/f2c/equiv.c | 61 +++-- usr.bin/f2c/error.c | 205 +++++++++++---- usr.bin/f2c/exec.c | 217 +++++++++++----- usr.bin/f2c/expr.c | 658 +++++++++++++++++++++++++++++++++++------------ usr.bin/f2c/f2c.1 | 30 ++- usr.bin/f2c/f2c.h | 8 +- usr.bin/f2c/format.c | 638 ++++++++++++++++++++++++++++++++------------- usr.bin/f2c/format.h | 10 +- usr.bin/f2c/formatdata.c | 247 ++++++++++++------ usr.bin/f2c/gram.dcl | 10 + usr.bin/f2c/gram.head | 14 +- usr.bin/f2c/index | 26 +- usr.bin/f2c/index.html | 140 +++++----- usr.bin/f2c/init.c | 35 ++- usr.bin/f2c/intr.c | 67 +++-- usr.bin/f2c/io.c | 201 ++++++++++----- usr.bin/f2c/iob.h | 6 +- usr.bin/f2c/lex.c | 199 ++++++++++---- usr.bin/f2c/main.c | 128 ++++++--- usr.bin/f2c/malloc.c | 132 ++++++---- usr.bin/f2c/mem.c | 68 +++-- usr.bin/f2c/misc.c | 536 ++++++++++++++++++++++++++++---------- usr.bin/f2c/names.c | 238 +++++++++++------ usr.bin/f2c/names.h | 17 +- usr.bin/f2c/niceprintf.c | 113 +++++--- usr.bin/f2c/notice | 2 +- usr.bin/f2c/output.c | 367 +++++++++++++++++++------- usr.bin/f2c/output.h | 15 +- usr.bin/f2c/p1defs.h | 38 ++- usr.bin/f2c/p1output.c | 306 ++++++++++++++++------ usr.bin/f2c/parse.h | 10 +- usr.bin/f2c/parse_args.c | 148 +++++++---- usr.bin/f2c/permission | 18 -- usr.bin/f2c/pread.c | 172 +++++++++---- usr.bin/f2c/proc.c | 419 ++++++++++++++++++++++-------- usr.bin/f2c/put.c | 107 +++++--- usr.bin/f2c/putpcc.c | 367 +++++++++++++++++++------- usr.bin/f2c/readme | 81 ++++-- usr.bin/f2c/sysdep.c | 105 +++++++- usr.bin/f2c/sysdep.h | 25 +- usr.bin/f2c/tokens | 1 + usr.bin/f2c/vax.c | 131 +++++++--- usr.bin/f2c/version.c | 4 +- usr.bin/f2c/xsum.c | 6 +- 50 files changed, 4984 insertions(+), 1910 deletions(-) (limited to 'usr.bin/f2c') diff --git a/usr.bin/f2c/Notice b/usr.bin/f2c/Notice index 64af9f12dc4ee..9715a192abf4f 100644 --- a/usr.bin/f2c/Notice +++ b/usr.bin/f2c/Notice @@ -1,5 +1,5 @@ /**************************************************************** -Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore. +Copyright 1990 - 1995 by AT&T Bell Laboratories and Bellcore. Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby diff --git a/usr.bin/f2c/README b/usr.bin/f2c/README index ed88aaa81c75a..b8e5a67d73b8d 100644 --- a/usr.bin/f2c/README +++ b/usr.bin/f2c/README @@ -1,10 +1,10 @@ Type "make" to check the validity of the f2c source and compile f2c. On a PC, you may need to compile xsum.c with -DMSDOS (i.e., with -MSDOS #defined). If your system does not understand ANSI/ISO C -syntax (i.e., if you have a K&R C compiler), compile xsum.c with --DKR_headers. (Eventually this will also be required of the f2c -source proper.) +MSDOS #defined). + +If your compiler does not understand ANSI/ISO C syntax (i.e., if +you have a K&R C compiler), compile with -DKR_headers . On non-Unix systems where files have separate binary and text modes, you may need to "make xsumr.out" rather than "make xsum.out". @@ -20,15 +20,21 @@ You may need to modify usignal.h if you are not running f2c on a UNIX system. Should you get the message "xsum0.out xsum1.out differ", see what lines -are different (`diff xsum0.out xsum1.out`) and ask netlib to send you -the files in question "from f2c/src". For example, if exec.c and -expr.c have incorrect check sums, you would send netlib the message - send exec.c expr.c from f2c/src +are different (`diff xsum0.out xsum1.out`) and ask netlib +(e.g., netlib@research.att.com) to send you the files in question, +plus the current xsum0.out (which may have changed) "from f2c/src". +For example, if exec.c and expr.c have incorrect check sums, you would +send netlib the message + send exec.c expr.c xsum0.out from f2c/src +You can also ftp these files from netlib.att.com; for more details, ask +netlib@research.att.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 cannot tolerate -redefinition of malloc and free. If yours is such a system, you may -either modify the makefile appropriately, or simply execute +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 @@ -66,9 +72,21 @@ message of the form Compiler error ... cannot open intermediate file ... On many systems, it is best to combine libF77 and libI77 into a single -library, say libf2c, as suggested in "readme from f2c". If you do this, -then you should adjust the definition of link_msg in sysdep.c -appropriately (e.g., replacing "-lF77 -lI77" by "-lf2c"). +library, say libf2c, as suggested in "readme from f2c". If you do not +do this, then you should adjust the definition of link_msg in sysdep.c +appropriately (e.g., replacing "-lf2c" by "-lF77 -lI77"). On Unix +systems, the easiest way to create libf2c.a is to make libF77/libF77.a +and libI77/libI77.a (after reading and heeding libF77/README and +libI77/README), and then to say + + cp libF77/libF77.a libf2c.a + ar ruv libf2c.a libI77/*.o + ranlib libf2c.a + +The last step, ranlib, may not be necessary on your system. On +other systems, just compile all the .c files in libF77 and libI77, +and put the resulting objects (except one or both of the Version +objects) into a library, called perhaps f2c.lib . Some older C compilers object to typedef void (*foo)(); @@ -85,10 +103,43 @@ test by compiling lex.c with NO_EOF_CHAR_CHECK #defined, or can change control-Z to some other character by #defining EOF_CHAR to be the desired value. + +If your machine has IEEE, VAX, or IBM-mainframe arithmetic, but your +printf is inaccurate (e.g., with Symantec C++ version 6.0, +printf("%.17g",12.) prints 12.000000000000001), you can make f2c print +correctly rounded numbers by compiling with -DUSE_DTOA and adding +dtoa.o g_fmt.o to the makefile's OBJECTS = line, so it becomes + + OBJECTS = $(OBJECTSd) malloc.o dtoa.o g_fmt.o + +Also add the rule + + dtoa.o: dtoa.c + $(CC) -c $(CFLAGS) -DMALLOC=ckalloc -DIEEE... dtoa.c + +(without the initial tab) to the makefile, where IEEE... is one of +IEEE_MC68k, IEEE_8087, VAX, or IBM, depending on your machine's +arithmetic. See the comments near the start of dtoa.c. + +The relevant source files, dtoa.c and g_fmt.c, are available +separately from netlib's fp directory. For example, you could +send the E-mail message + + send dtoa.c g_fmt.c from fp + +to netlib@research.att.com (or use anonymous ftp from netlib.att.com +and look in directory /netlib/fp). + +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. + + Please send bug reports to dmg@research.att.com . The old index file (now called "readme" due to unfortunate changes in netlib conventions: "send readme from f2c") will report recent changes in the recent-change log at its end; all changes will be shown in the "changes" file ("send changes from f2c"). To keep current source, you will need to request xsum0.out and version.c, in addition to the changed source -files. +files. Changes first appear on netlib@research.att.com, and in due +time propagate to the other netlib sites that are kept current. diff --git a/usr.bin/f2c/cds.c b/usr.bin/f2c/cds.c index 3a9a9dc0288dd..80e91ae7f1977 100644 --- a/usr.bin/f2c/cds.c +++ b/usr.bin/f2c/cds.c @@ -1,5 +1,5 @@ /**************************************************************** -Copyright 1990, 1993 by AT&T Bell Laboratories and Bellcore. +Copyright 1990, 1993, 1994 by AT&T Bell Laboratories and Bellcore. Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby @@ -31,11 +31,16 @@ this software. * Arrange that the return value, rv, satisfies rv[0] == '-' || rv[-1] == '-' . */ -#include "sysdep.h" +#include "defs.h" char * +#ifdef KR_headers cds(s, z0) - char *s, *z0; + char *s; + char *z0; +#else +cds(char *s, char *z0) +#endif { int ea, esign, et, i, k, nd = 0, sign = 0, tz; char c, *z; diff --git a/usr.bin/f2c/data.c b/usr.bin/f2c/data.c index 5d112163086f2..44b84ef87820d 100644 --- a/usr.bin/f2c/data.c +++ b/usr.bin/f2c/data.c @@ -1,5 +1,5 @@ /**************************************************************** -Copyright 1990, 1993 by AT&T Bell Laboratories and Bellcore. +Copyright 1990, 1993 - 1995 by AT&T Bell Laboratories and Bellcore. Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby @@ -29,13 +29,18 @@ static char datafmt[] = "%s\t%09ld\t%d"; static char *cur_varname; /* another initializer, called from parser */ + void +#ifdef KR_headers dataval(repp, valp) -register expptr repp, valp; + register expptr repp; + register expptr valp; +#else +dataval(register expptr repp, register expptr valp) +#endif { int i, nrep; ftnint elen; register Addrp p; - Addrp nextdata(); if (parstate < INDATA) { frexpr(repp); @@ -53,11 +58,18 @@ register expptr repp, valp; } frexpr(repp); - if( ! ISCONST(valp) ) - { - err("non-constant initializer"); - goto ret; - } + if( ! ISCONST(valp) ) { + if (valp->tag == TADDR + && valp->addrblock.uname_tag == UNAM_CONST) { + /* kludge */ + frexpr(valp->addrblock.memoffset); + valp->tag = TCONST; + } + else { + err("non-constant initializer"); + goto ret; + } + } if(toomanyinit) goto ret; for(i = 0 ; i < nrep ; ++i) @@ -78,8 +90,13 @@ ret: } -Addrp nextdata(elenp) -ftnint *elenp; + Addrp +#ifdef KR_headers +nextdata(elenp) + ftnint *elenp; +#else +nextdata(ftnint *elenp) +#endif { register struct Impldoblock *ip; struct Primblock *pp; @@ -220,17 +237,21 @@ next: LOCAL FILEP dfile; - + void +#ifdef KR_headers setdata(varp, valp, elen) -register Addrp varp; -ftnint elen; -register Constp valp; + register Addrp varp; + register Constp valp; + ftnint elen; +#else +setdata(register Addrp varp, register Constp valp, ftnint elen) +#endif { struct Constblock con; register int type; int i, k, valtype; ftnint offset; - char *dataname(), *varname; + char *varname; static Addrp badvar; register unsigned char *s; static int last_lineno; @@ -291,8 +312,6 @@ register Constp valp; switch(type) { case TYLOGICAL: - if (tylogical != TYLONG) - type = tylogical; case TYINT1: case TYLOGICAL1: case TYLOGICAL2: @@ -347,13 +366,18 @@ register Constp valp; output form of name is padded with blanks and preceded with a storage class digit */ -char *dataname(stg,memno) - int stg; - long memno; + char* +#ifdef KR_headers +dataname(stg, memno) + int stg; + long memno; +#else +dataname(int stg, long memno) +#endif { static char varname[64]; register char *s, *t; - char buf[16], *memname(); + char buf[16]; if (stg == STGCOMMON) { varname[0] = '2'; @@ -372,9 +396,13 @@ char *dataname(stg,memno) - + void +#ifdef KR_headers frdata(p0) -chainp p0; + chainp p0; +#else +frdata(chainp p0) +#endif { register struct Chain *p; register tagptr q; @@ -398,28 +426,49 @@ chainp p0; } - + void +#ifdef KR_headers dataline(varname, offset, type) -char *varname; -ftnint offset; -int type; + char *varname; + ftnint offset; + int type; +#else +dataline(char *varname, ftnint offset, int type) +#endif { fprintf(dfile, datafmt, varname, offset, type); } void +#ifdef KR_headers make_param(p, e) - register struct Paramblock *p; - expptr e; + register struct Paramblock *p; + expptr e; +#else +make_param(register struct Paramblock *p, expptr e) +#endif { register expptr q; + struct Constblock qc; + if (p->vstg == STGARG) + errstr("Dummy argument %.50s appears in a parameter statement.", + p->fvarname); p->vclass = CLPARAM; impldcl((Namep)p); + if (e->headblock.vtype != TYCHAR) + e = putx(fixtype(e)); p->paramval = q = mkconv(p->vtype, e); if (p->vtype == TYCHAR) { if (q->tag == TEXPR) - p->paramval = q = fixexpr(q); + p->paramval = q = fixexpr((Exprp)q); + if (q->tag == TADDR && q->addrblock.uname_tag == UNAM_CONST) { + qc.Const = q->addrblock.user.Const; + qc.tag = TCONST; + qc.vtype = q->addrblock.vtype; + qc.vleng = q->addrblock.vleng; + q = (expptr)&qc; + } if (!ISCONST(q) || q->constblock.vtype != TYCHAR) { errstr("invalid value for character parameter %s", p->fvarname); diff --git a/usr.bin/f2c/defines.h b/usr.bin/f2c/defines.h index fc7eb1834fe50..db23ade7ad242 100644 --- a/usr.bin/f2c/defines.h +++ b/usr.bin/f2c/defines.h @@ -288,9 +288,3 @@ typedef long int ftnint; #define NO66(s) if(no66flag) err66(s) #define NOEXT(s) if(noextflag) errext(s) - -/* round a up to the nearest multiple of b: - - a = b * floor ( (a + (b - 1)) / b )*/ - -#define roundup(a,b) ( b * ( (a+b-1)/b) ) diff --git a/usr.bin/f2c/defs.h b/usr.bin/f2c/defs.h index 6bb2ca27bc2d1..3404f14a223fb 100644 --- a/usr.bin/f2c/defs.h +++ b/usr.bin/f2c/defs.h @@ -1,5 +1,5 @@ /**************************************************************** -Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories, Bellcore. +Copyright 1990 - 1995 by AT&T Bell Laboratories, Bellcore. Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby @@ -31,7 +31,6 @@ this software. #define MAXINCLUDES 10 #define MAXLITERALS 200 /* Max number of constants in the literal pool */ -#define MAXTOKENLEN 502 /* length of longest token */ #define MAXCTL 20 #define MAXHASH 401 #define MAXSTNO 801 @@ -50,7 +49,6 @@ typedef struct Constblock *Constp; typedef struct Exprblock *Exprp; typedef struct Nameblock *Namep; -extern FILEP opf(); extern FILEP infile; extern FILEP diagfile; extern FILEP textfile; @@ -67,7 +65,7 @@ extern int current_ftn_file; extern int maxcontin; extern char *blkdfname, *initfname, *sortfname; -extern long int headoffset; /* Since the header block requires data we +extern long headoffset; /* Since the header block requires data we don't know about until AFTER each function has been processed, we keep a pointer to the current (dummy) header @@ -75,8 +73,8 @@ extern long int headoffset; /* Since the header block requires data we here */ extern char main_alias[]; /* name given to PROGRAM psuedo-op */ -extern char token [ ]; -extern int toklen; +extern char *token; +extern int maxtoklen, toklen; extern long lineno; extern char *infname; extern int needkwd; @@ -301,7 +299,7 @@ extern int complex_seen, dcomplex_seen; struct Labelblock { int labelno; /* Internal label */ - unsigned blklevel:8; /* level of nesting , for branch-in-loop + unsigned blklevel:8; /* level of nesting, for branch-in-loop checking */ unsigned labused:1; unsigned fmtlabused:1; @@ -488,6 +486,7 @@ struct Exprblock unsigned opcode; expptr leftp; expptr rightp; + int typefixed; }; @@ -497,7 +496,7 @@ union Constant char *ccp0; ftnint blanks; } ccp1; - ftnint ci; /* Constant long integer */ + ftnint ci; /* Constant longeger */ double cd[2]; char *cds[2]; }; @@ -680,8 +679,8 @@ struct Equivblock struct Eqvchain *equivs; /* List (Eqvchain) of primblocks holding variable identifiers */ flag eqvinit; - long int eqvtop; - long int eqvbottom; + long eqvtop; + long eqvbottom; int eqvtype; } ; #define eqvleng eqvtop @@ -697,7 +696,7 @@ struct Eqvchain struct Primblock *eqvlhs; Namep eqvname; } eqvitem; - long int eqvoffset; + long eqvoffset; } ; @@ -733,52 +732,322 @@ extern char Letters[]; struct Dims { expptr lb, ub; }; - -/* popular functions with non integer return values */ - - -int *ckalloc(); -char *varstr(), *nounder(), *addunder(); -char *copyn(), *copys(); -chainp hookup(), mkchain(), revchain(); -ftnint convci(); -char *convic(); -char *setdoto(); -double convcd(); -Namep mkname(); -struct Labelblock *mklabel(), *execlab(); -Extsym *mkext(), *newentry(); -expptr addrof(), call1(), call2(), call3(), call4(); -Addrp builtin(), mktmp(), mktmp0(), mktmpn(), autovar(); -Addrp mkplace(), mkaddr(), putconst(), memversion(); -expptr mkprim(), mklhs(), mkexpr(), mkconv(), mkfunct(), fixexpr(), fixtype(); -expptr errnode(), mkaddcon(), mkintcon(), putcxop(); -tagptr cpexpr(); -ftnint lmin(), lmax(), iarrlen(); -char *dbconst(), *flconst(); - -void puteq (), putex1 (); -expptr putx (), putsteq (), putassign (); - extern int forcedouble; /* force real functions to double */ extern int doin_setbound; /* special handling for array bounds */ extern int Ansi; -extern char *cds(), *cpstring(), *dtos(), *string_num(); -extern char *c_type_decl(); extern char hextoi_tab[]; #define hextoi(x) hextoi_tab[(x) & 0xff] extern char *casttypes[], *ftn_types[], *protorettypes[], *usedcasts[]; extern int Castargs, infertypes; extern FILE *protofile; -extern void exit(), inferdcl(), protowrite(), save_argtypes(); extern char binread[], binwrite[], textread[], textwrite[]; extern char *ei_first, *ei_last, *ei_next; extern char *wh_first, *wh_last, *wh_next; -extern void putwhile(); -extern char *halign; +extern char *halign, *outbuf, *outbtail; extern flag keepsubs; #ifdef TYQUAD extern flag use_tyquad; #endif -extern int n_keywords, n_st_fields; -extern char *c_keywords[], *st_fields[]; +extern int n_keywords; +extern char *c_keywords[]; + +#ifdef KR_headers +#define Argdcl(x) () +#define Void /* void */ +#else +#define Argdcl(x) x +#define Void void +#endif + +char* Alloc Argdcl((int)); +char* Argtype Argdcl((int, char*)); +void Fatal Argdcl((char*)); +struct Impldoblock* mkiodo Argdcl((chainp, chainp)); +tagptr Inline Argdcl((int, int, chainp)); +struct Labelblock* execlab Argdcl((long)); +struct Labelblock* mklabel Argdcl((long)); +struct Listblock* mklist Argdcl((chainp)); +void Un_link_all Argdcl((int)); +void add_extern_to_list Argdcl((Addrp, chainp*)); +int addressable Argdcl((tagptr)); +tagptr addrof Argdcl((tagptr)); +char* addunder Argdcl((char*)); +Addrp autovar Argdcl((int, int, tagptr, char*)); +void backup Argdcl((char*, char*)); +void bad_atypes Argdcl((Argtypes*, char*, int, int, int, char*, char*)); +int badchleng Argdcl((tagptr)); +void badop Argdcl((char*, int)); +void badstg Argdcl((char*, int)); +void badtag Argdcl((char*, int)); +void badthing Argdcl((char*, char*, int)); +void badtype Argdcl((char*, int)); +Addrp builtin Argdcl((int, char*, int)); +char* c_name Argdcl((char*, int)); +tagptr call0 Argdcl((int, char*)); +tagptr call1 Argdcl((int, char*, tagptr)); +tagptr call2 Argdcl((int, char*, tagptr, tagptr)); +tagptr call3 Argdcl((int, char*, tagptr, tagptr, tagptr)); +tagptr call4 Argdcl((int, char*, tagptr, tagptr, tagptr, tagptr)); +tagptr callk Argdcl((int, char*, chainp)); +void cast_args Argdcl((int, chainp)); +char* cds Argdcl((char*, char*)); +void changedtype Argdcl((Namep)); +ptr ckalloc Argdcl((int)); +int cktype Argdcl((int, int, int)); +void clf Argdcl((FILEP*, char*, int)); +int cmpstr Argdcl((char*, char*, long, long)); +char* c_type_decl Argdcl((int, int)); +Extsym* comblock Argdcl((char*)); +char* comm_union_name Argdcl((int)); +void consconv Argdcl((int, Constp, Constp)); +void consnegop Argdcl((Constp)); +int conssgn Argdcl((tagptr)); +char* convic Argdcl((long)); +void copy_data Argdcl((chainp)); +char* copyn Argdcl((int, char*)); +char* copys Argdcl((char*)); +tagptr cpblock Argdcl((int, char*)); +tagptr cpexpr Argdcl((tagptr)); +void cpn Argdcl((int, char*, char*)); +char* cpstring Argdcl((char*)); +void dataline Argdcl((char*, long, int)); +char* dataname Argdcl((int, long)); +void dataval Argdcl((tagptr, tagptr)); +void dclerr Argdcl((char*, Namep)); +void def_commons Argdcl((FILEP)); +void def_start Argdcl((FILEP, char*, char*, char*)); +void deregister Argdcl((Namep)); +void do_uninit_equivs Argdcl((FILEP, ptr)); +void doequiv(Void); +int dofork(Void); +void doinclude Argdcl((char*)); +void doio Argdcl((chainp)); +void done Argdcl((int)); +void donmlist(Void); +int dsort Argdcl((char*, char*)); +char* dtos Argdcl((double)); +void elif_out Argdcl((FILEP, tagptr)); +void end_else_out Argdcl((FILEP)); +void enddcl(Void); +void enddo Argdcl((int)); +void endio(Void); +void endioctl(Void); +void endproc(Void); +void entrypt Argdcl((int, int, long, Extsym*, chainp)); +int eqn Argdcl((int, char*, char*)); +char* equiv_name Argdcl((int, char*)); +void err Argdcl((char*)); +void err66 Argdcl((char*)); +void errext Argdcl((char*)); +void erri Argdcl((char*, int)); +void errl Argdcl((char*, long)); +tagptr errnode(Void); +void errstr Argdcl((char*, char*)); +void exarif Argdcl((tagptr, struct Labelblock*, struct Labelblock*, struct Labelblock*)); +void exasgoto Argdcl((Namep)); +void exassign Argdcl((Namep, struct Labelblock*)); +void excall Argdcl((Namep, struct Listblock*, int, struct Labelblock**)); +void exdo Argdcl((int, Namep, chainp)); +void execerr Argdcl((char*, char*)); +void exelif Argdcl((tagptr)); +void exelse(Void); +void exenddo Argdcl((Namep)); +void exendif(Void); +void exequals Argdcl((struct Primblock*, tagptr)); +void exgoto Argdcl((struct Labelblock*)); +void exif Argdcl((tagptr)); +void exreturn Argdcl((tagptr)); +void exstop Argdcl((int, tagptr)); +void extern_out Argdcl((FILEP, Extsym*)); +void fatali Argdcl((char*, int)); +void fatalstr Argdcl((char*, char*)); +void ffilecopy Argdcl((FILEP, FILEP)); +void fileinit(Void); +int fixargs Argdcl((int, struct Listblock*)); +tagptr fixexpr Argdcl((Exprp)); +tagptr fixtype Argdcl((tagptr)); +char* flconst Argdcl((char*, char*)); +void flline(Void); +void fmt_init(Void); +void fmtname Argdcl((Namep, Addrp)); +int fmtstmt Argdcl((struct Labelblock*)); +tagptr fold Argdcl((tagptr)); +void frchain Argdcl((chainp*)); +void frdata Argdcl((chainp)); +void freetemps(Void); +void freqchain Argdcl((struct Equivblock*)); +void frexchain Argdcl((chainp*)); +void frexpr Argdcl((tagptr)); +void frrpl(Void); +void frtemp Argdcl((Addrp)); +char* gmem Argdcl((int, int)); +void hashclear(Void); +chainp hookup Argdcl((chainp, chainp)); +expptr imagpart Argdcl((Addrp)); +void impldcl Argdcl((Namep)); +int in_vector Argdcl((char*, char**, int)); +void incomm Argdcl((Extsym*, Namep)); +void inferdcl Argdcl((Namep, int)); +int inilex Argdcl((char*)); +void initkey(Void); +int inregister Argdcl((Namep)); +long int commlen Argdcl((chainp)); +long int convci Argdcl((int, char*)); +long int iarrlen Argdcl((Namep)); +long int lencat Argdcl((expptr)); +long int lmax Argdcl((long, long)); +long int lmin Argdcl((long, long)); +long int wr_char_len Argdcl((FILEP, struct Dimblock*, int, int)); +Addrp intraddr Argdcl((Namep)); +tagptr intrcall Argdcl((Namep, struct Listblock*, int)); +int intrfunct Argdcl((char*)); +void ioclause Argdcl((int, expptr)); +int iocname(Void); +int is_negatable Argdcl((Constp)); +int isaddr Argdcl((tagptr)); +int isnegative_const Argdcl((Constp)); +int isstatic Argdcl((tagptr)); +chainp length_comp Argdcl((struct Entrypoint*, int)); +int lengtype Argdcl((int, long)); +char* lexline Argdcl((ptr)); +void list_arg_types Argdcl((FILEP, struct Entrypoint*, chainp, int, char*)); +void list_decls Argdcl((FILEP)); +void list_init_data Argdcl((FILE **, char *, FILE *)); +void listargs Argdcl((FILEP, struct Entrypoint*, int, chainp)); +char* lit_name Argdcl((struct Literal*)); +int log_2 Argdcl((long)); +char* lower_string Argdcl((char*, char*)); +int main Argdcl((int, char**)); +expptr make_int_expr Argdcl((expptr)); +void make_param Argdcl((struct Paramblock*, tagptr)); +void many Argdcl((char*, char, int)); +void margin_printf Argdcl((FILEP, char*, ...)); +int maxtype Argdcl((int, int)); +char* mem Argdcl((int, int)); +void mem_init(Void); +char* memname Argdcl((int, long)); +Addrp memversion Argdcl((Namep)); +tagptr mkaddcon Argdcl((long)); +Addrp mkaddr Argdcl((Namep)); +Addrp mkarg Argdcl((int, int)); +tagptr mkbitcon Argdcl((int, int, char*)); +chainp mkchain Argdcl((char*, chainp)); +Constp mkconst Argdcl((int)); +tagptr mkconv Argdcl((int, tagptr)); +tagptr mkcxcon Argdcl((tagptr, tagptr)); +tagptr mkexpr Argdcl((int, tagptr, tagptr)); +Extsym* mkext Argdcl((char*, char*)); +Extsym* mkext1 Argdcl((char*, char*)); +Addrp mkfield Argdcl((Addrp, char*, int)); +tagptr mkfunct Argdcl((tagptr)); +tagptr mkintcon Argdcl((long)); +tagptr mklhs Argdcl((struct Primblock*, int)); +tagptr mklogcon Argdcl((int)); +Namep mkname Argdcl((char*)); +Addrp mkplace Argdcl((Namep)); +tagptr mkprim Argdcl((Namep, struct Listblock*, chainp)); +tagptr mkrealcon Argdcl((int, char*)); +Addrp mkscalar Argdcl((Namep)); +void mkstfunct Argdcl((struct Primblock*, tagptr)); +tagptr mkstrcon Argdcl((int, char*)); +Addrp mktmp Argdcl((int, tagptr)); +Addrp mktmp0 Argdcl((int, tagptr)); +Addrp mktmpn Argdcl((int, int, tagptr)); +void namelist Argdcl((Namep)); +int ncat Argdcl((expptr)); +void negate_const Argdcl((Constp)); +void new_endif(Void); +Extsym* newentry Argdcl((Namep, int)); +int newlabel(Void); +void newproc(Void); +Addrp nextdata Argdcl((long*)); +void nice_printf Argdcl((FILEP, char*, ...)); +void not_both Argdcl((char*)); +void np_init(Void); +int oneof_stg Argdcl((Namep, int, int)); +int op_assign Argdcl((int)); +tagptr opconv Argdcl((tagptr, int)); +FILEP opf Argdcl((char*, char*)); +void out_addr Argdcl((FILEP, Addrp)); +void out_asgoto Argdcl((FILEP, tagptr)); +void out_call Argdcl((FILEP, int, int, tagptr, tagptr, tagptr)); +void out_const Argdcl((FILEP, Constp)); +void out_else Argdcl((FILEP)); +void out_for Argdcl((FILEP, tagptr, tagptr, tagptr)); +void out_init(Void); +void outbuf_adjust(Void); +void p1_label Argdcl((long)); +void prcona Argdcl((FILEP, long)); +void prconi Argdcl((FILEP, long)); +void prconr Argdcl((FILEP, Constp, int)); +void procinit(Void); +void procode Argdcl((FILEP)); +void prolog Argdcl((FILEP, chainp)); +void protowrite Argdcl((FILEP, int, char*, struct Entrypoint*, chainp)); +expptr prune_left_conv Argdcl((expptr)); +int put_one_arg Argdcl((int, char*, char**, char*, char*)); +expptr putassign Argdcl((expptr, expptr)); +Addrp putchop Argdcl((tagptr)); +void putcmgo Argdcl((tagptr, int, struct Labelblock**)); +Addrp putconst Argdcl((Constp)); +tagptr putcxop Argdcl((tagptr)); +void puteq Argdcl((expptr, expptr)); +void putexpr Argdcl((expptr)); +void puthead Argdcl((char*, int)); +void putif Argdcl((tagptr, int)); +void putout Argdcl((tagptr)); +expptr putsteq Argdcl((Addrp, Addrp)); +void putwhile Argdcl((tagptr)); +tagptr putx Argdcl((tagptr)); +void r8fix(Void); +int rdlong Argdcl((FILEP, long*)); +int rdname Argdcl((FILEP, ptr, char*)); +void read_Pfiles Argdcl((char**)); +Addrp realpart Argdcl((Addrp)); +chainp revchain Argdcl((chainp)); +int same_expr Argdcl((tagptr, tagptr)); +int same_ident Argdcl((tagptr, tagptr)); +void save_argtypes Argdcl((chainp, Argtypes**, Argtypes**, int, char*, int, int, int, int)); +void saveargtypes Argdcl((Exprp)); +void set_externs(Void); +void set_tmp_names(Void); +void setbound Argdcl((Namep, int, struct Dims*)); +void setdata Argdcl((Addrp, Constp, long)); +void setext Argdcl((Namep)); +void setfmt Argdcl((struct Labelblock*)); +void setimpl Argdcl((int, long, int, int)); +void setintr Argdcl((Namep)); +void settype Argdcl((Namep, int, long)); +void sigcatch Argdcl((int)); +void start_formatting(Void); +void startioctl(Void); +void startproc Argdcl((Extsym*, int)); +void startrw(Void); +char* string_num Argdcl((char*, long)); +int struct_eq Argdcl((chainp, chainp)); +tagptr subcheck Argdcl((Namep, tagptr)); +tagptr suboffset Argdcl((struct Primblock*)); +int type_fixup Argdcl((Argtypes*, Atype*, int)); +void unamstring Argdcl((Addrp, char*)); +void unclassifiable(Void); +void vardcl Argdcl((Namep)); +void warn Argdcl((char*)); +void warn1 Argdcl((char*, char*)); +void warni Argdcl((char*, int)); +void wr_abbrevs Argdcl((FILEP, int, chainp)); +char* wr_ardecls Argdcl((FILE*, struct Dimblock*, long)); +void wr_array_init Argdcl((FILEP, int, chainp)); +void wr_common_decls Argdcl((FILEP)); +void wr_equiv_init Argdcl((FILEP, int, chainp*, int)); +void wr_globals Argdcl((FILEP)); +void wr_nv_ident_help Argdcl((FILEP, Addrp)); +void wr_struct Argdcl((FILEP, chainp)); +void wronginf Argdcl((Namep)); +void yyerror Argdcl((char*)); +int yylex(Void); +int yyparse(Void); + +#ifdef USE_DTOA +#define atof(x) strtod(x,0) +void g_fmt Argdcl((char*, double)); +#endif diff --git a/usr.bin/f2c/equiv.c b/usr.bin/f2c/equiv.c index 019e206d26e50..645a77a852d26 100644 --- a/usr.bin/f2c/equiv.c +++ b/usr.bin/f2c/equiv.c @@ -1,5 +1,5 @@ /**************************************************************** -Copyright 1990, 1993 by AT&T Bell Laboratories and Bellcore. +Copyright 1990, 1993-5 by AT&T Bell Laboratories and Bellcore. Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby @@ -23,14 +23,17 @@ this software. #include "defs.h" -LOCAL eqvcommon(), eqveqv(), nsubs(); +static void eqvcommon Argdcl((struct Equivblock*, int, long int)); +static void eqveqv Argdcl((int, int, long int)); +static int nsubs Argdcl((struct Listblock*)); /* ROUTINES RELATED TO EQUIVALENCE CLASS PROCESSING */ /* called at end of declarations section to process chains created by EQUIVALENCE statements */ -doequiv() + void +doequiv(Void) { register int i; int inequiv; /* True if one namep occurs in @@ -69,7 +72,7 @@ doequiv() vardcl(np = primp->namep); if(primp->argsp || primp->fcharp) { - expptr offp, suboffset(); + expptr offp; /* Pad ones onto the end of an array declaration when needed */ @@ -114,14 +117,6 @@ doequiv() case STGUNKNOWN: case STGBSS: case STGEQUIV: - if (in_vector(np->cvarname, st_fields, - n_st_fields) >= 0) { - k = strlen(np->cvarname); - strcpy(s = mem(k+2,0), np->cvarname); - s[k] = '_'; - s[k+1] = 0; - np->cvarname = s; - } break; case STGCOMMON: @@ -239,10 +234,15 @@ doequiv() /* put equivalence chain p at common block comno + comoffset */ -LOCAL eqvcommon(p, comno, comoffset) -struct Equivblock *p; -int comno; -ftnint comoffset; + LOCAL void +#ifdef KR_headers +eqvcommon(p, comno, comoffset) + struct Equivblock *p; + int comno; + ftnint comoffset; +#else +eqvcommon(struct Equivblock *p, int comno, ftnint comoffset) +#endif { int ovarno; ftnint k, offq; @@ -315,9 +315,15 @@ ftnint comoffset; * adjust offsets of ovarno elements and top and bottom of nvarno chain */ -LOCAL eqveqv(nvarno, ovarno, delta) -int ovarno, nvarno; -ftnint delta; + LOCAL void +#ifdef KR_headers +eqveqv(nvarno, ovarno, delta) + int nvarno; + int ovarno; + ftnint delta; +#else +eqveqv(int nvarno, int ovarno, ftnint delta) +#endif { register struct Equivblock *neweqv, *oldeqv; register Namep np; @@ -347,9 +353,13 @@ ftnint delta; - + void +#ifdef KR_headers freqchain(p) -register struct Equivblock *p; + register struct Equivblock *p; +#else +freqchain(register struct Equivblock *p) +#endif { register struct Eqvchain *q, *oq; @@ -368,8 +378,13 @@ register struct Equivblock *p; /* nsubs -- number of subscripts in this arglist (just the length of the list) */ -LOCAL nsubs(p) -register struct Listblock *p; + LOCAL int +#ifdef KR_headers +nsubs(p) + register struct Listblock *p; +#else +nsubs(register struct Listblock *p) +#endif { register int n; register chainp q; diff --git a/usr.bin/f2c/error.c b/usr.bin/f2c/error.c index fd68d144d49ac..049008ee0be80 100644 --- a/usr.bin/f2c/error.c +++ b/usr.bin/f2c/error.c @@ -1,5 +1,5 @@ /**************************************************************** -Copyright 1990, 1993 by AT&T Bell Laboratories and Bellcore. +Copyright 1990, 1993, 1994 by AT&T Bell Laboratories and Bellcore. Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby @@ -23,26 +23,41 @@ this software. #include "defs.h" -warni(s,t) - char *s; - int t; + void +#ifdef KR_headers +warni(s, t) + char *s; + int t; +#else +warni(char *s, int t) +#endif { char buf[100]; sprintf(buf,s,t); warn(buf); } -warn1(s,t) -char *s, *t; + void +#ifdef KR_headers +warn1(s, t) + char *s; + char *t; +#else +warn1(char *s, char *t) +#endif { char buff[100]; sprintf(buff, s, t); warn(buff); } - + void +#ifdef KR_headers warn(s) -char *s; + char *s; +#else +warn(char *s) +#endif { if(nowarnflag) return; @@ -55,9 +70,14 @@ char *s; ++nwarn; } - + void +#ifdef KR_headers errstr(s, t) -char *s, *t; + char *s; + char *t; +#else +errstr(char *s, char *t) +#endif { char buff[100]; sprintf(buff, s, t); @@ -65,19 +85,28 @@ char *s, *t; } - -erri(s,t) -char *s; -int t; + void +#ifdef KR_headers +erri(s, t) + char *s; + int t; +#else +erri(char *s, int t) +#endif { char buff[100]; sprintf(buff, s, t); err(buff); } -errl(s,t) -char *s; -long t; + void +#ifdef KR_headers +errl(s, t) + char *s; + long t; +#else +errl(char *s, long t) +#endif { char buff[100]; sprintf(buff, s, t); @@ -86,8 +115,13 @@ long t; char *err_proc = 0; + void +#ifdef KR_headers err(s) -char *s; + char *s; +#else +err(char *s) +#endif { if (err_proc) fprintf(diagfile, @@ -102,18 +136,26 @@ char *s; ++nerr; } - + void +#ifdef KR_headers yyerror(s) -char *s; + char *s; +#else +yyerror(char *s) +#endif { err(s); } - + void +#ifdef KR_headers dclerr(s, v) -char *s; -Namep v; + char *s; + Namep v; +#else +dclerr(char *s, Namep v) +#endif { char buff[100]; @@ -127,9 +169,14 @@ Namep v; } - + void +#ifdef KR_headers execerr(s, n) -char *s, *n; + char *s; + char *n; +#else +execerr(char *s, char *n) +#endif { char buf1[100], buf2[100]; @@ -139,8 +186,13 @@ char *s, *n; } + void +#ifdef KR_headers Fatal(t) -char *t; + char *t; +#else +Fatal(char *t) +#endif { fprintf(diagfile, "Compiler error line %ld", lineno); if (infname) @@ -151,9 +203,14 @@ char *t; - -fatalstr(t,s) -char *t, *s; + void +#ifdef KR_headers +fatalstr(t, s) + char *t; + char *s; +#else +fatalstr(char *t, char *s) +#endif { char buff[100]; sprintf(buff, t, s); @@ -161,10 +218,14 @@ char *t, *s; } - -fatali(t,d) -char *t; -int d; + void +#ifdef KR_headers +fatali(t, d) + char *t; + int d; +#else +fatali(char *t, int d) +#endif { char buff[100]; sprintf(buff, t, d); @@ -172,10 +233,15 @@ int d; } - + void +#ifdef KR_headers badthing(thing, r, t) -char *thing, *r; -int t; + char *thing; + char *r; + int t; +#else +badthing(char *thing, char *r, int t) +#endif { char buff[50]; sprintf(buff, "Impossible %s %d in routine %s", thing, t, r); @@ -183,19 +249,27 @@ int t; } - + void +#ifdef KR_headers badop(r, t) -char *r; -int t; + char *r; + int t; +#else +badop(char *r, int t) +#endif { badthing("opcode", r, t); } - + void +#ifdef KR_headers badtag(r, t) -char *r; -int t; + char *r; + int t; +#else +badtag(char *r, int t) +#endif { badthing("tag", r, t); } @@ -203,28 +277,41 @@ int t; - + void +#ifdef KR_headers badstg(r, t) -char *r; -int t; + char *r; + int t; +#else +badstg(char *r, int t) +#endif { badthing("storage class", r, t); } - + void +#ifdef KR_headers badtype(r, t) -char *r; -int t; + char *r; + int t; +#else +badtype(char *r, int t) +#endif { badthing("type", r, t); } - + void +#ifdef KR_headers many(s, c, n) -char *s, c; -int n; + char *s; + char c; + int n; +#else +many(char *s, char c, int n) +#endif { char buff[250]; @@ -234,18 +321,26 @@ int n; Fatal(buff); } - + void +#ifdef KR_headers err66(s) -char *s; + char *s; +#else +err66(char *s) +#endif { errstr("Fortran 77 feature used: %s", s); --nerr; } - + void +#ifdef KR_headers errext(s) -char *s; + char *s; +#else +errext(char *s) +#endif { errstr("f2c extension used: %s", s); --nerr; diff --git a/usr.bin/f2c/exec.c b/usr.bin/f2c/exec.c index b986492ebc10d..bcd1e08521710 100644 --- a/usr.bin/f2c/exec.c +++ b/usr.bin/f2c/exec.c @@ -1,5 +1,5 @@ /**************************************************************** -Copyright 1990, 1993 by AT&T Bell Laboratories and Bellcore. +Copyright 1990, 1993 - 1995 by AT&T Bell Laboratories and Bellcore. Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby @@ -25,23 +25,33 @@ this software. #include "p1defs.h" #include "names.h" -LOCAL void exar2(), popctl(), pushctl(); +static void exar2 Argdcl((int, tagptr, struct Labelblock*, struct Labelblock*)); +static void popctl Argdcl((void)); +static void pushctl Argdcl((int)); /* Logical IF codes */ - + void +#ifdef KR_headers exif(p) -expptr p; + expptr p; +#else +exif(expptr p) +#endif { pushctl(CTLIF); putif(p, 0); /* 0 => if, not elseif */ } - + void +#ifdef KR_headers exelif(p) -expptr p; + expptr p; +#else +exelif(expptr p) +#endif { if (ctlstack->ctltype == CTLIF || ctlstack->ctltype == CTLIFX) putif(p, 1); /* 1 ==> elseif */ @@ -52,8 +62,8 @@ expptr p; - -exelse() + void +exelse(Void) { register struct Ctlframe *c; @@ -66,8 +76,12 @@ exelse() execerr("else out of place", CNULL); } - + void +#ifdef KR_headers exendif() +#else +exendif() +#endif { while(ctlstack->ctltype == CTLIFX) { popctl(); @@ -86,7 +100,12 @@ exendif() } + void +#ifdef KR_headers +new_endif() +#else new_endif() +#endif { if (ctlstack->ctltype == CTLIF || ctlstack->ctltype == CTLIFX) pushctl(CTLIFX); @@ -98,8 +117,12 @@ new_endif() zero) */ LOCAL void +#ifdef KR_headers pushctl(code) - int code; + int code; +#else +pushctl(int code) +#endif { register int i; @@ -109,12 +132,13 @@ pushctl(code) for(i = 0 ; i < 4 ; ++i) ctlstack->ctlabels[i] = 0; ctlstack->dowhile = 0; + ctlstack->domax = ctlstack->dostep = 0; /* in case of errors */ ++blklevel; } LOCAL void -popctl() +popctl(Void) { if( ctlstack-- < ctls ) Fatal("control stack empty"); @@ -125,7 +149,8 @@ popctl() /* poplab -- update the flags in labeltab */ -LOCAL poplab() + LOCAL void +poplab(Void) { register struct Labelblock *lp; @@ -146,9 +171,13 @@ LOCAL poplab() /* BRANCHING CODE */ - + void +#ifdef KR_headers exgoto(lab) -struct Labelblock *lab; + struct Labelblock *lab; +#else +exgoto(struct Labelblock *lab) +#endif { lab->labused = 1; p1_goto (lab -> stateno); @@ -159,10 +188,14 @@ struct Labelblock *lab; - + void +#ifdef KR_headers exequals(lp, rp) -register struct Primblock *lp; -register expptr rp; + register struct Primblock *lp; + register expptr rp; +#else +exequals(register struct Primblock *lp, register expptr rp) +#endif { if(lp->tag != TPRIM) { @@ -173,9 +206,12 @@ register expptr rp; else if(lp->namep->vclass!=CLVAR && lp->argsp) { if(parstate >= INEXEC) - err("statement function amid executables"); + errstr("statement function %.62s amid executables.", + lp->namep->fvarname); mkstfunct(lp, rp); } + else if (lp->vtype == TYSUBR) + err("illegal use of subroutine name"); else { expptr new_lp, new_rp; @@ -195,9 +231,14 @@ register expptr rp; long laststfcn = -1, thisstno; int doing_stmtfcn; + void +#ifdef KR_headers mkstfunct(lp, rp) -struct Primblock *lp; -expptr rp; + struct Primblock *lp; + expptr rp; +#else +mkstfunct(struct Primblock *lp, expptr rp) +#endif { register struct Primblock *p; register Namep np; @@ -230,8 +271,10 @@ expptr rp; if( ((tagptr)(args->datap))->tag!=TPRIM || (p = (struct Primblock *)(args->datap) )->argsp || - p->fcharp || p->lcharp ) + p->fcharp || p->lcharp ) { err("non-variable argument in statement function definition"); + args->datap = 0; + } else { @@ -245,8 +288,12 @@ expptr rp; } static void +#ifdef KR_headers mixed_type(np) - Namep np; + Namep np; +#else +mixed_type(Namep np) +#endif { char buf[128]; sprintf(buf, "%s function %.90s invoked as subroutine", @@ -254,12 +301,16 @@ mixed_type(np) warn(buf); } - + void +#ifdef KR_headers excall(name, args, nstars, labels) -Namep name; -struct Listblock *args; -int nstars; -struct Labelblock *labels[ ]; + Namep name; + struct Listblock *args; + int nstars; + struct Labelblock **labels; +#else +excall(Namep name, struct Listblock *args, int nstars, struct Labelblock **labels) +#endif { register expptr p; @@ -275,6 +326,8 @@ struct Labelblock *labels[ ]; settype(name, TYSUBR, (ftnint)0); } p = mkfunct( mkprim(name, args, CHNULL) ); + if (p->tag == TERROR) + return; /* Subroutines and their identifiers acquire the type INT */ @@ -289,14 +342,17 @@ struct Labelblock *labels[ ]; } - + void +#ifdef KR_headers exstop(stop, p) -int stop; -register expptr p; + int stop; + register expptr p; +#else +exstop(int stop, register expptr p) +#endif { char *str; int n; - expptr mkstrcon(); if(p) { @@ -354,10 +410,17 @@ register expptr p; positive increment tests are placed above the body, negative increment tests are placed below (see enddo() ) */ + void +#ifdef KR_headers exdo(range, loopname, spec) -int range; /* end label */ -Namep loopname; -chainp spec; /* input spec must have at least 2 exprs */ + int range; + Namep loopname; + chainp spec; +#else +exdo(int range, Namep loopname, chainp spec) +#endif + /* range = end label */ + /* input spec must have at least 2 exprs */ { register expptr p; register Namep np; @@ -555,8 +618,13 @@ chainp spec; /* input spec must have at least 2 exprs */ p1_for (init, test, inc); } + void +#ifdef KR_headers exenddo(np) - Namep np; + Namep np; +#else +exenddo(Namep np) +#endif { Namep np1; int here; @@ -585,9 +653,13 @@ exenddo(np) enddo(here); } - + void +#ifdef KR_headers enddo(here) -int here; + int here; +#else +enddo(int here) +#endif { register struct Ctlframe *q; Namep np; /* name of the current DO index */ @@ -613,16 +685,18 @@ int here; ctlstack->ctlabels[i] = 0; deregister(ctlstack->donamep); ctlstack->donamep->vdovar = NO; - e = ctlstack->dostep; - if (e->tag == TADDR && e->addrblock.istemp) - frtemp((Addrp)e); - else - frexpr(e); - e = ctlstack->domax; - if (e->tag == TADDR && e->addrblock.istemp) - frtemp((Addrp)e); - else - frexpr(e); + /* ctlstack->dostep and ctlstack->domax can be zero */ + /* with sufficiently bizarre (erroneous) syntax */ + if (e = ctlstack->dostep) + if (e->tag == TADDR && e->addrblock.istemp) + frtemp((Addrp)e); + else + frexpr(e); + if (e = ctlstack->domax) + if (e->tag == TADDR && e->addrblock.istemp) + frtemp((Addrp)e); + else + frexpr(e); } else if (ctlstack->dowhile) p1for_end (); @@ -642,12 +716,16 @@ int here; } } + void +#ifdef KR_headers exassign(vname, labelval) - register Namep vname; -struct Labelblock *labelval; + register Namep vname; + struct Labelblock *labelval; +#else +exassign(register Namep vname, struct Labelblock *labelval) +#endif { Addrp p; - expptr mkaddcon(); register Addrp q; char *fs; register chainp cp, cpprev; @@ -698,7 +776,6 @@ struct Labelblock *labelval; /* Code for FORMAT label... */ if (!labelval->labdefined || fs) { - extern void fmtname(); labelval->fmtlabused = 1; p = ALLOC(Addrblock); @@ -721,10 +798,16 @@ struct Labelblock *labelval; } /* exassign */ - + void +#ifdef KR_headers exarif(expr, neglab, zerlab, poslab) -expptr expr; -struct Labelblock *neglab, *zerlab, *poslab; + expptr expr; + struct Labelblock *neglab; + struct Labelblock *zerlab; + struct Labelblock *poslab; +#else +exarif(expptr expr, struct Labelblock *neglab, struct Labelblock *zerlab, struct Labelblock *poslab) +#endif { register int lm, lz, lp; @@ -775,10 +858,15 @@ struct Labelblock *neglab, *zerlab, *poslab; in order to make the 1 pass algorithm work. */ LOCAL void +#ifdef KR_headers exar2(op, e, l1, l2) - int op; - expptr e; - struct Labelblock *l1, *l2; + int op; + expptr e; + struct Labelblock *l1; + struct Labelblock *l2; +#else +exar2(int op, expptr e, struct Labelblock *l1, struct Labelblock *l2) +#endif { expptr comp; @@ -794,8 +882,13 @@ exar2(op, e, l1, l2) /* exreturn -- return the value in p from a SUBROUTINE call -- used to implement the alternate return mechanism */ + void +#ifdef KR_headers exreturn(p) -register expptr p; + register expptr p; +#else +exreturn(register expptr p) +#endif { if(procclass != CLPROC) warn("RETURN statement in main or block data"); @@ -815,11 +908,15 @@ register expptr p; } + void +#ifdef KR_headers exasgoto(labvar) -Namep labvar; + Namep labvar; +#else +exasgoto(Namep labvar) +#endif { register Addrp p; - void p1_asgoto(); p = mkplace(labvar); if( ! ISINT(p->vtype) ) diff --git a/usr.bin/f2c/expr.c b/usr.bin/f2c/expr.c index eeccf42de50d6..258faccb01d20 100644 --- a/usr.bin/f2c/expr.c +++ b/usr.bin/f2c/expr.c @@ -1,5 +1,5 @@ /**************************************************************** -Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore. +Copyright 1990 - 1995 by AT&T Bell Laboratories and Bellcore. Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby @@ -25,21 +25,26 @@ this software. #include "output.h" #include "names.h" -LOCAL void conspower(), consbinop(), zdiv(); -LOCAL expptr fold(), mkpower(), stfcall(); -#ifndef stfcall_MAX -#define stfcall_MAX 144 -#endif - typedef struct { double dreal, dimag; } dcomplex; +static void consbinop Argdcl((int, int, Constp, Constp, Constp)); +static void conspower Argdcl((Constp, Constp, long int)); +static void zdiv Argdcl((dcomplex*, dcomplex*, dcomplex*)); +static tagptr mkpower Argdcl((tagptr)); +static tagptr stfcall Argdcl((Namep, struct Listblock*)); + extern char dflttype[26]; extern int htype; /* little routines to create constant blocks */ -Constp mkconst(t) -register int t; + Constp +#ifdef KR_headers +mkconst(t) + register int t; +#else +mkconst(register int t) +#endif { register Constp p; @@ -52,8 +57,13 @@ register int t; /* mklogcon -- Make Logical Constant */ -expptr mklogcon(l) -register int l; + expptr +#ifdef KR_headers +mklogcon(l) + register int l; +#else +mklogcon(register int l) +#endif { register Constp p; @@ -66,8 +76,13 @@ register int l; /* mkintcon -- Make Integer Constant */ -expptr mkintcon(l) -ftnint l; + expptr +#ifdef KR_headers +mkintcon(l) + ftnint l; +#else +mkintcon(ftnint l) +#endif { register Constp p; @@ -81,8 +96,13 @@ ftnint l; /* mkaddcon -- Make Address Constant, given integer value */ -expptr mkaddcon(l) -register long l; + expptr +#ifdef KR_headers +mkaddcon(l) + register long l; +#else +mkaddcon(register long l) +#endif { register Constp p; @@ -96,9 +116,14 @@ register long l; /* mkrealcon -- Make Real Constant. The type t is assumed to be TYREAL or TYDREAL */ -expptr mkrealcon(t, d) - register int t; - char *d; + expptr +#ifdef KR_headers +mkrealcon(t, d) + register int t; + char *d; +#else +mkrealcon(register int t, char *d) +#endif { register Constp p; @@ -115,24 +140,46 @@ expptr mkrealcon(t, d) quad, octal and hex bases may be input. Constants may not exceed 32 bits, or whatever the size of (struct Constblock).ci may be. */ -expptr mkbitcon(shift, leng, s) -int shift; -int leng; -char *s; + expptr +#ifdef KR_headers +mkbitcon(shift, leng, s) + int shift; + int leng; + char *s; +#else +mkbitcon(int shift, int leng, char *s) +#endif { register Constp p; - register long x; + register long x, y, z; + int len; + char buff[100], *fmt, *s0 = s; + static char *kind[3] = { "Binary", "Hex", "Octal" }; p = mkconst(TYLONG); - x = 0; + x = y = 0; while(--leng >= 0) - if(*s != ' ') + if(*s != ' ') { + z = x; x = (x << shift) | hextoi(*s++); - /* mwm wanted to change the type to short for short constants, - * but this is dangerous -- there is no syntax for long constants + y |= (((unsigned long)x) >> shift) - z; + } + /* Don't change the type to short for short constants, as + * that is dangerous -- there is no syntax for long constants * with small values. */ p->Const.ci = x; + if (y) { + if (--shift == 3) + shift = 1; + if ((len = (int)leng) > 60) + sprintf(buff, "%s constant '%.60s' truncated.", + kind[shift], s0); + else + sprintf(buff, "%s constant '%.*s' truncated.", + kind[shift], len, s0); + err(buff); + } return( (expptr) p ); } @@ -143,9 +190,14 @@ char *s; /* mkstrcon -- Make string constant. Allocates storage and initializes the memory for a copy of the input Fortran-string. */ -expptr mkstrcon(l,v) -int l; -register char *v; + expptr +#ifdef KR_headers +mkstrcon(l, v) + int l; + register char *v; +#else +mkstrcon(int l, register char *v) +#endif { register Constp p; register char *s; @@ -165,12 +217,17 @@ register char *v; /* mkcxcon -- Make complex contsant. A complex number is a pair of values, each of which may be integer, real or double. */ -expptr mkcxcon(realp,imagp) -register expptr realp, imagp; + expptr +#ifdef KR_headers +mkcxcon(realp, imagp) + register expptr realp; + register expptr imagp; +#else +mkcxcon(register expptr realp, register expptr imagp) +#endif { int rtype, itype; register Constp p; - expptr errnode(); rtype = realp->headblock.vtype; itype = imagp->headblock.vtype; @@ -215,7 +272,8 @@ register expptr realp, imagp; /* errnode -- Allocate a new error block */ -expptr errnode() + expptr +errnode(Void) { struct Errorblock *p; p = ALLOC(Errorblock); @@ -232,13 +290,17 @@ expptr errnode() Note that casting to a character copies only the first sizeof(char) bytes. */ -expptr mkconv(t, p) -register int t; -register expptr p; + expptr +#ifdef KR_headers +mkconv(t, p) + register int t; + register expptr p; +#else +mkconv(register int t, register expptr p) +#endif { register expptr q; register int pt, charwarn = 1; - expptr opconv(); if (t >= 100) { t -= 100; @@ -285,9 +347,14 @@ register expptr p; /* opconv -- Convert expression p to type t using the main expression evaluator; returns an OPCONV expression, I think 14-jun-88 mwm */ -expptr opconv(p, t) -expptr p; -int t; + expptr +#ifdef KR_headers +opconv(p, t) + expptr p; + int t; +#else +opconv(expptr p, int t) +#endif { register expptr q; @@ -302,8 +369,13 @@ int t; /* addrof -- Create an ADDR expression operation */ -expptr addrof(p) -expptr p; + expptr +#ifdef KR_headers +addrof(p) + expptr p; +#else +addrof(expptr p) +#endif { return( mkexpr(OPADDR, p, ENULL) ); } @@ -312,13 +384,17 @@ expptr p; /* cpexpr - Returns a new copy of input expression p */ -tagptr cpexpr(p) -register tagptr p; + tagptr +#ifdef KR_headers +cpexpr(p) + register tagptr p; +#else +cpexpr(register tagptr p) +#endif { register tagptr e; int tag; register chainp ep, pp; - tagptr cpblock(); /* This table depends on the ordering of the T macros, e.g. TNAME */ @@ -399,8 +475,13 @@ register tagptr p; /* frexpr -- Free expression -- frees up memory used by expression p */ + void +#ifdef KR_headers frexpr(p) -register tagptr p; + register tagptr p; +#else +frexpr(register tagptr p) +#endif { register chainp q; @@ -459,8 +540,12 @@ register tagptr p; } void +#ifdef KR_headers wronginf(np) - Namep np; + Namep np; +#else +wronginf(Namep np) +#endif { int c, k; warn1("fixing wrong type inferred for %.65s", np->fvarname); @@ -474,8 +559,13 @@ wronginf(np) /* fix up types in expression; replace subtrees and convert names to address blocks */ -expptr fixtype(p) -register tagptr p; + expptr +#ifdef KR_headers +fixtype(p) + register tagptr p; +#else +fixtype(register tagptr p) +#endif { if(p == 0) @@ -504,6 +594,8 @@ register tagptr p; only a subexpr of its parameter. */ case TEXPR: + if (((Exprp)p)->typefixed) + return (expptr)p; return( fixexpr((Exprp)p) ); case TLIST: @@ -533,7 +625,12 @@ register tagptr p; int -badchleng(p) register expptr p; +#ifdef KR_headers +badchleng(p) + register expptr p; +#else +badchleng(register expptr p) +#endif { if (!p->headblock.vleng) { if (p->headblock.tag == TADDR @@ -549,8 +646,12 @@ badchleng(p) register expptr p; static expptr +#ifdef KR_headers cplenexpr(p) - expptr p; + expptr p; +#else +cplenexpr(expptr p) +#endif { expptr rv; @@ -567,15 +668,21 @@ cplenexpr(p) Parameter p should have a TEXPR tag at its root, else an error is returned */ -expptr fixexpr(p) -register Exprp p; + expptr +#ifdef KR_headers +fixexpr(p) + register Exprp p; +#else +fixexpr(register Exprp p) +#endif { expptr lp; register expptr rp; register expptr q; + char *hsave; int opcode, ltype, rtype, ptype, mtype; - if( ISERROR(p) ) + if( ISERROR(p) || p->typefixed ) return( (expptr) p ); else if(p->tag != TEXPR) badtag("fixexpr", p->tag); @@ -591,6 +698,7 @@ register Exprp p; if(opcode==OPASSIGN && lp->tag!=TADDR) { err("left side of assignment must be variable"); + eret: frexpr((expptr)p); return( errnode() ); } @@ -605,10 +713,7 @@ register Exprp p; rtype = 0; if(ltype==TYERROR || rtype==TYERROR) - { - frexpr((expptr)p); - return( errnode() ); - } + goto eret; /* Now work on the whole expression */ @@ -630,13 +735,19 @@ register Exprp p; } if( (ptype = cktype(opcode, ltype, rtype)) == TYERROR) - { - frexpr((expptr)p); - return( errnode() ); - } - - if (ltype == TYCHAR && ISCONST(lp)) - p->leftp = lp = (expptr)putconst((Constp)lp); + goto eret; + + if (ltype == TYCHAR && ISCONST(lp)) { + if (opcode == OPCONV) { + hsave = halign; + halign = 0; + lp = (expptr)putconst((Constp)lp); + halign = hsave; + } + else + lp = (expptr)putconst((Constp)lp); + p->leftp = lp; + } if (rtype == TYCHAR && ISCONST(rp)) p->rightp = rp = (expptr)putconst((Constp)rp); @@ -649,7 +760,8 @@ register Exprp p; break; case OPASSIGN: - if (rtype == TYREAL || ISLOGICAL(ptype)) + if (rtype == TYREAL || ISLOGICAL(ptype) + || rtype == TYDREAL && ltype == TYREAL && !ISCONST(rp)) break; case OPPLUSEQ: case OPSTAREQ: @@ -699,7 +811,10 @@ register Exprp p; break; case OPPOWER: - return( mkpower((expptr)p) ); + rp = mkpower((expptr)p); + if (rp->tag == TEXPR) + rp->exprblock.typefixed = 1; + return rp; case OPLT: case OPLE: @@ -720,8 +835,7 @@ register Exprp p; } } mtype = cktype(OPMINUS, ltype, rtype); - if(mtype==TYDREAL && ( (ltype==TYREAL && ! ISCONST(lp)) || - (rtype==TYREAL && ! ISCONST(rp)) )) + if(mtype==TYDREAL && (ltype==TYREAL || rtype==TYREAL)) break; if( ISCOMPLEX(mtype) ) break; @@ -769,21 +883,27 @@ register Exprp p; } p->vtype = ptype; + p->typefixed = 1; return((expptr) p); } /* fix an argument list, taking due care for special first level cases */ + int +#ifdef KR_headers fixargs(doput, p0) -int doput; /* doput is true if constants need to be passed by reference */ -struct Listblock *p0; + int doput; + struct Listblock *p0; +#else +fixargs(int doput, struct Listblock *p0) +#endif + /* doput is true if constants need to be passed by reference */ { register chainp p; register tagptr q, t; register int qtag; int nargs; - Addrp mkscalar(); nargs = 0; if(p0) @@ -830,8 +950,13 @@ struct Listblock *p0; /* mkscalar -- only called by fixargs above, and by some routines in io.c */ -Addrp mkscalar(np) -register Namep np; + Addrp +#ifdef KR_headers +mkscalar(np) + register Namep np; +#else +mkscalar(register Namep np) +#endif { register Addrp ap; @@ -857,10 +982,15 @@ register Namep np; static void -adjust_arginfo(np) /* adjust arginfo to omit the length arg for the +#ifdef KR_headers +adjust_arginfo(np) + register Namep np; +#else +adjust_arginfo(register Namep np) +#endif + /* adjust arginfo to omit the length arg for the arg that we now know to be a character-valued function */ - register Namep np; { struct Entrypoint *ep; register chainp args; @@ -875,8 +1005,13 @@ adjust_arginfo(np) /* adjust arginfo to omit the length arg for the -expptr mkfunct(p0) - expptr p0; + expptr +#ifdef KR_headers +mkfunct(p0) + expptr p0; +#else +mkfunct(expptr p0) +#endif { register struct Primblock *p = (struct Primblock *)p0; struct Entrypoint *ep; @@ -884,7 +1019,6 @@ expptr mkfunct(p0) Extsym *extp; register Namep np; register expptr q; - expptr intrcall(); extern chainp new_procs; int k, nargs; int class; @@ -943,7 +1077,8 @@ expptr mkfunct(p0) fatalstr( "Cannot invoke common variable %.50s as a function.", np->fvarname); - fatali("invalid class code %d for function", class); + errstr("%.80s cannot be called.", np->fvarname); + goto error; } /* F77 doesn't allow subscripting of function calls */ @@ -1016,9 +1151,14 @@ error: -LOCAL expptr stfcall(np, actlist) -Namep np; -struct Listblock *actlist; + static expptr +#ifdef KR_headers +stfcall(np, actlist) + Namep np; + struct Listblock *actlist; +#else +stfcall(Namep np, struct Listblock *actlist) +#endif { register chainp actuals; int nargs; @@ -1028,10 +1168,13 @@ struct Listblock *actlist; Namep tnp; register struct Rplblock *rp; struct Rplblock *tlist; - static int inv_count; - if (++inv_count > stfcall_MAX) - Fatal("Loop invoking recursive statement function?"); + if (np->arginfo) { + errstr("statement function %.66s calls itself.", + np->fvarname); + return ICON(0); + } + np->arginfo = (Argtypes *)np; /* arbitrary nonzero value */ if(actlist) { actuals = actlist->listp; @@ -1054,8 +1197,13 @@ struct Listblock *actlist; /* copy actual arguments into temporaries */ while(actuals!=NULL && formals!=NULL) { + if (!(tnp = (Namep) formals->datap)) { + /* buggy statement function declaration */ + q = ICON(1); + goto done; + } rp = ALLOC(Rplblock); - rp->rplnp = tnp = (Namep) formals->datap; + rp->rplnp = tnp; ap = fixtype((tagptr)actuals->datap); if(tnp->vtype==ap->headblock.vtype && tnp->vtype!=TYCHAR && (ap->tag==TCONST || ap->tag==TADDR) ) @@ -1123,8 +1271,9 @@ struct Listblock *actlist; free((char *)rpllist); rpllist = rp; } + done: frchain( &oactp ); - --inv_count; + np->arginfo = 0; return(q); } @@ -1134,8 +1283,13 @@ static int replaced; /* mkplace -- Figure out the proper storage class for the input name and return an addrp with the appropriate stuff */ -Addrp mkplace(np) -register Namep np; + Addrp +#ifdef KR_headers +mkplace(np) + register Namep np; +#else +mkplace(register Namep np) +#endif { register Addrp s; register struct Rplblock *rp; @@ -1182,9 +1336,13 @@ register Namep np; } static expptr -subskept(p,a) -struct Primblock *p; -Addrp a; +#ifdef KR_headers +subskept(p, a) + struct Primblock *p; + Addrp a; +#else +subskept(struct Primblock *p, Addrp a) +#endif { expptr ep; struct Listblock *Lb; @@ -1212,10 +1370,15 @@ Addrp a; for array subscripts, stack offset, and substring offsets. The f -> C translator will need this only to worry about the subscript stuff */ -expptr mklhs(p, subkeep) -register struct Primblock *p; int subkeep; + expptr +#ifdef KR_headers +mklhs(p, subkeep) + register struct Primblock *p; + int subkeep; +#else +mklhs(register struct Primblock *p, int subkeep) +#endif { - expptr suboffset(); register Addrp s; Namep np; @@ -1280,8 +1443,13 @@ register struct Primblock *p; int subkeep; /* deregister -- remove a register allocation from the list; assumes that names are deregistered in stack order (LIFO order - Last In First Out) */ + void +#ifdef KR_headers deregister(np) -Namep np; + Namep np; +#else +deregister(Namep np) +#endif { if(nregvar>0 && regnamep[nregvar-1]==np) { @@ -1295,8 +1463,13 @@ Namep np; /* memversion -- moves a DO index REGISTER into a memory location; other objects are passed through untouched */ -Addrp memversion(np) -register Namep np; + Addrp +#ifdef KR_headers +memversion(np) + register Namep np; +#else +memversion(register Namep np) +#endif { register Addrp s; @@ -1312,8 +1485,13 @@ register Namep np; /* inregister -- looks for the input name in the global list regnamep */ + int +#ifdef KR_headers inregister(np) -register Namep np; + register Namep np; +#else +inregister(register Namep np) +#endif { register int i; @@ -1328,14 +1506,18 @@ register Namep np; /* suboffset -- Compute the offset from the start of the array, given the subscripts as arguments */ -expptr suboffset(p) -register struct Primblock *p; + expptr +#ifdef KR_headers +suboffset(p) + register struct Primblock *p; +#else +suboffset(register struct Primblock *p) +#endif { int n; expptr si, size; chainp cp; expptr e, e1, offp, prod; - expptr subcheck(); struct Dimblock *dimp; expptr sub[MAXDIM+1]; register Namep np; @@ -1402,9 +1584,14 @@ register struct Primblock *p; -expptr subcheck(np, p) -Namep np; -register expptr p; + expptr +#ifdef KR_headers +subcheck(np, p) + Namep np; + register expptr p; +#else +subcheck(Namep np, register expptr p) +#endif { struct Dimblock *dimp; expptr t, checkvar, checkcond, badcall; @@ -1469,12 +1656,16 @@ badsub: -Addrp mkaddr(p) -register Namep p; + Addrp +#ifdef KR_headers +mkaddr(p) + register Namep p; +#else +mkaddr(register Namep p) +#endif { Extsym *extp; register Addrp t; - Addrp intraddr(); int k; switch( p->vstg) @@ -1532,6 +1723,11 @@ register Namep p; case STGINTR: return ( intraddr (p)); + + case STGSTFUNCT: + + errstr("invalid use of statement function %.64s.", p->fvarname); + return putconst((Constp)ICON(0)); } badstg("mkaddr", p->vstg); /* NOT REACHED */ return 0; @@ -1544,8 +1740,14 @@ register Namep p; function returns a string (for the return value, which is the first parameter), or when a variable-length string is passed to a function. */ -Addrp mkarg(type, argno) -int type, argno; + Addrp +#ifdef KR_headers +mkarg(type, argno) + int type; + int argno; +#else +mkarg(int type, int argno) +#endif { register Addrp p; @@ -1570,10 +1772,15 @@ int type, argno; extra (uninitialized) storage, since it could be a paramblock or nameblock */ -expptr mkprim(v0, args, substr) - Namep v0; - struct Listblock *args; - chainp substr; + expptr +#ifdef KR_headers +mkprim(v0, args, substr) + Namep v0; + struct Listblock *args; + chainp substr; +#else +mkprim(Namep v0, struct Listblock *args, chainp substr) +#endif { typedef union { struct Paramblock paramblock; @@ -1628,8 +1835,13 @@ expptr mkprim(v0, args, substr) This function is called on identifiers known to be variables or recursive references to the same function */ + void +#ifdef KR_headers vardcl(v) -register Namep v; + register Namep v; +#else +vardcl(register Namep v) +#endif { struct Dimblock *t; expptr neltp; @@ -1697,8 +1909,13 @@ register Namep v; /* Set the implicit type declaration of parameter p based on its first letter */ + void +#ifdef KR_headers impldcl(p) -register Namep p; + register Namep p; +#else +impldcl(register Namep p) +#endif { register int k; int type; @@ -1725,9 +1942,13 @@ register Namep p; } void -inferdcl(np,type) - Namep np; - int type; +#ifdef KR_headers +inferdcl(np, type) + Namep np; + int type; +#else +inferdcl(Namep np, int type) +#endif { int k = impltype[letter(np->fvarname[0])]; if (k != type) { @@ -1740,25 +1961,65 @@ inferdcl(np,type) np->vinfproc = 1; } + LOCAL int +#ifdef KR_headers +zeroconst(e) + expptr e; +#else +zeroconst(expptr e) +#endif +{ + register Constp c = (Constp) e; + if (c->tag == TCONST) + switch(c->vtype) { + case TYINT1: + case TYSHORT: + case TYLONG: +#ifdef TYQUAD + case TYQUAD: +#endif + return c->Const.ci == 0; -#define ICONEQ(z, c) (ISICON(z) && z->constblock.Const.ci==c) -#define COMMUTE { e = lp; lp = rp; rp = e; } + case TYREAL: + case TYDREAL: + if (c->vstg == 1) + return !strcmp(c->Const.cds[0],"0."); + return c->Const.cd[0] == 0.; + case TYCOMPLEX: + case TYDCOMPLEX: + if (c->vstg == 1) + return !strcmp(c->Const.cds[0],"0.") + && !strcmp(c->Const.cds[1],"0."); + return c->Const.cd[0] == 0. && c->Const.cd[1] == 0.; + } + return 0; + } +#define ICONEQ(z, c) (ISICON(z) && z->constblock.Const.ci==c) +#define COMMUTE { e = lp; lp = rp; rp = e; } + /* mkexpr -- Make expression, and simplify constant subcomponents (tree order is not preserved). Assumes that lp is nonempty, and uses fold() to simplify adjacent constants */ -expptr mkexpr(opcode, lp, rp) -int opcode; -register expptr lp, rp; + expptr +#ifdef KR_headers +mkexpr(opcode, lp, rp) + int opcode; + register expptr lp; + register expptr rp; +#else +mkexpr(int opcode, register expptr lp, register expptr rp) +#endif { register expptr e, e1; int etype; int ltype, rtype; int ltag, rtag; long L; + static long divlineno; ltype = lp->headblock.vtype; ltag = lp->tag; @@ -1781,7 +2042,7 @@ register expptr lp, rp; if( ISCONST(lp) ) COMMUTE - if( ISICON(rp) ) + if( ISICON(rp) ) { if(rp->constblock.Const.ci == 0) goto retright; @@ -1791,12 +2052,10 @@ register expptr lp, rp; case OPSLASH: case OPMOD: - if( ICONEQ(rp, 0) ) - { - err("attempted division by zero"); - rp = ICON(1); - break; - } + if( zeroconst(rp) && lineno != divlineno ) { + warn("attempted division by zero"); + divlineno = lineno; + } if(opcode == OPMOD) break; @@ -1821,7 +2080,7 @@ mulop: (x * CONST1) / CONST2 ==> x * (CONST1 / CONST2) */ - if (lp->tag != TEXPR || !lp->exprblock.rightp + if (!ISINT(etype) || lp->tag != TEXPR || !lp->exprblock.rightp || !ISICON(lp->exprblock.rightp)) break; @@ -2070,8 +2329,14 @@ error: /* cktype -- Check and return the type of the expression */ +#ifdef KR_headers cktype(op, lt, rt) -register int op, lt, rt; + register int op; + register int lt; + register int rt; +#else +cktype(register int op, register int lt, register int rt) +#endif { char *errs; @@ -2218,7 +2483,6 @@ register int op, lt, rt; case OPDOT: case OPARROW: return (lt); - break; default: badop("cktype", op); } @@ -2228,12 +2492,20 @@ error1: return(TYERROR); } + static void +intovfl(Void) +{ err("overflow simplifying integer constants."); } + /* fold -- simplifies constant expressions; it assumes that e -> leftp and e -> rightp are TCONST or NULL */ - LOCAL expptr + expptr +#ifdef KR_headers fold(e) - register expptr e; + register expptr e; +#else +fold(register expptr e) +#endif { Constp p; register expptr lp, rp; @@ -2241,7 +2513,7 @@ fold(e) int i, bl, ll, lr; char *q, *s; struct Constblock lcon, rcon; - long L; + ftnint L; double d; opcode = e->exprblock.opcode; @@ -2283,8 +2555,11 @@ fold(e) #ifdef TYQUAD case TYQUAD: #endif - if ((L = lp->constblock.Const.ci) < 0) + if ((L = lp->constblock.Const.ci) < 0) { lp->constblock.Const.ci = -L; + if (L != -lp->constblock.Const.ci) + intovfl(); + } goto retlp; case TYREAL: case TYDREAL: @@ -2317,7 +2592,7 @@ fold(e) case OPCOMMA_ARG: case OPQUEST: case OPCOLON: - return(e); + goto ereturn; case OPAND: p->Const.ci = lp->constblock.Const.ci && @@ -2357,6 +2632,9 @@ fold(e) case OPLSHIFT: p->Const.ci = lp->constblock.Const.ci << rp->constblock.Const.ci; + if ((((unsigned long)p->Const.ci) >> rp->constblock.Const.ci) + != lp->constblock.Const.ci) + intovfl(); break; case OPRSHIFT: @@ -2383,11 +2661,16 @@ fold(e) case OPPOWER: - if( ! ISINT(rtype) ) - return(e); + if( !ISINT(rtype) + || rp->constblock.Const.ci < 0 && zeroconst(lp)) + goto ereturn; conspower(p, (Constp)lp, rp->constblock.Const.ci); break; + case OPSLASH: + if (zeroconst(rp)) + goto ereturn; + /* no break */ default: if(ltype == TYCHAR) @@ -2410,15 +2693,24 @@ fold(e) frexpr(e); return( (expptr) p ); + ereturn: + free((char *)p); + return e; } /* assign constant l = r , doing coercion */ + void +#ifdef KR_headers consconv(lt, lc, rc) - int lt; - register Constp lc, rc; + int lt; + register Constp lc; + register Constp rc; +#else +consconv(int lt, register Constp lc, register Constp rc) +#endif { int rt = rc->vtype; register union Constant *lv = &lc->Const, *rv = &rc->Const; @@ -2485,10 +2777,16 @@ consconv(lt, lc, rc) /* Negate constant value -- changes the input node's value */ + void +#ifdef KR_headers consnegop(p) -register Constp p; + register Constp p; +#else +consnegop(register Constp p) +#endif { register char *s; + ftnint L; if (p->vstg) { if (ISCOMPLEX(p->vtype)) { @@ -2509,7 +2807,9 @@ register Constp p; #ifdef TYQUAD case TYQUAD: #endif - p->Const.ci = - p->Const.ci; + p->Const.ci = -(L = p->Const.ci); + if (L != -p->Const.ci) + intovfl(); break; case TYCOMPLEX: @@ -2530,9 +2830,14 @@ register Constp p; /* conspower -- Expand out an exponentiation */ LOCAL void +#ifdef KR_headers conspower(p, ap, n) - Constp p, ap; - ftnint n; + Constp p; + Constp ap; + ftnint n; +#else +conspower(Constp p, Constp ap, ftnint n) +#endif { register union Constant *powp = &p->Const; register int type; @@ -2623,19 +2928,23 @@ conspower(p, ap, n) matching the input type */ LOCAL void -zerodiv() -{ Fatal("division by zero during constant evaluation; cannot recover"); } - - LOCAL void +#ifdef KR_headers consbinop(opcode, type, cpp, app, bpp) - int opcode, type; - Constp cpp, app, bpp; + int opcode; + int type; + Constp cpp; + Constp app; + Constp bpp; +#else +consbinop(int opcode, int type, Constp cpp, Constp app, Constp bpp) +#endif { register union Constant *ap = &app->Const, *bp = &bpp->Const, *cp = &cpp->Const; int k; double ad[2], bd[2], temp; + ftnint a, b; cpp->vstg = 0; @@ -2659,6 +2968,8 @@ consbinop(opcode, type, cpp, app, bpp) case TYQUAD: #endif cp->ci = ap->ci + bp->ci; + if (ap->ci != cp->ci - bp->ci) + intovfl(); break; case TYCOMPLEX: case TYDCOMPLEX: @@ -2680,6 +2991,8 @@ consbinop(opcode, type, cpp, app, bpp) case TYQUAD: #endif cp->ci = ap->ci - bp->ci; + if (ap->ci != bp->ci + cp->ci) + intovfl(); break; case TYCOMPLEX: case TYDCOMPLEX: @@ -2700,7 +3013,9 @@ consbinop(opcode, type, cpp, app, bpp) #ifdef TYQUAD case TYQUAD: #endif - cp->ci = ap->ci * bp->ci; + cp->ci = (a = ap->ci) * (b = bp->ci); + if (a && cp->ci / a != b) + intovfl(); break; case TYREAL: case TYDREAL: @@ -2723,20 +3038,14 @@ consbinop(opcode, type, cpp, app, bpp) #ifdef TYQUAD case TYQUAD: #endif - if (!bp->ci) - zerodiv(); cp->ci = ap->ci / bp->ci; break; case TYREAL: case TYDREAL: - if (!bd[0]) - zerodiv(); cp->cd[0] = ad[0] / bd[0]; break; case TYCOMPLEX: case TYDCOMPLEX: - if (!bd[0] && !bd[1]) - zerodiv(); zdiv((dcomplex*)cp, (dcomplex*)ad, (dcomplex*)bd); break; } @@ -2854,8 +3163,12 @@ consbinop(opcode, type, cpp, app, bpp) /* conssgn - returns the sign of a Fortran constant */ +#ifdef KR_headers conssgn(p) -register expptr p; + register expptr p; +#else +conssgn(register expptr p) +#endif { register char *s; @@ -2907,12 +3220,17 @@ register expptr p; char *powint[ ] = { "pow_ii", #ifdef TYQUAD - "pow_qi", + "pow_qq", #endif "pow_ri", "pow_di", "pow_ci", "pow_zi" }; -LOCAL expptr mkpower(p) -register expptr p; + LOCAL expptr +#ifdef KR_headers +mkpower(p) + register expptr p; +#else +mkpower(register expptr p) +#endif { register expptr q, lp, rp; int ltype, rtype, mtype, tyi; @@ -3012,8 +3330,14 @@ register expptr p; LOCAL void +#ifdef KR_headers zdiv(c, a, b) - register dcomplex *a, *b, *c; + register dcomplex *c; + register dcomplex *a; + register dcomplex *b; +#else +zdiv(register dcomplex *c, register dcomplex *a, register dcomplex *b) +#endif { double ratio, den; double abr, abi; diff --git a/usr.bin/f2c/f2c.1 b/usr.bin/f2c/f2c.1 index 2a59dff8f7a50..241fd98ce9480 100644 --- a/usr.bin/f2c/f2c.1 +++ b/usr.bin/f2c/f2c.1 @@ -21,7 +21,10 @@ .TH F2C 1 .CT 1 prog_other .SH NAME -f\^2c \(mi Convert Fortran 77 to C or C++ +f2c \- Convert Fortran 77 to C or C++ +. \" f\^2c changed to f2c in the previous line for the benefit of +. \" people on systems (e.g. Sun systems) whose makewhatis cannot +. \" cope with troff formatting commands. .SH SYNOPSIS .B f\^2c [ @@ -72,6 +75,14 @@ variables in INQUIREs. Option .L -I4 confirms the default rendering of INTEGER as long int. .TP +.BI -I dir +Look for a non-absolute include file first in the directory of the +current input file, then in directories specified by \f(CW-I\fP +options (one directory per option). Options +\f(CW-I2\fP and \f(CW-I4\fP +have precedence, so, e.g., a directory named \f(CW2\fP +should be specified by \f(CW-I./2\fP . +.TP .B -onetrip Compile DO loops that are performed at least once if reached. (Fortran 77 DO loops are not performed at all if the upper limit is smaller than the lower limit.) @@ -86,10 +97,9 @@ case. Make the default type of a variable `undefined' rather than using the default Fortran rules. .TP .B -w -Suppress all warning messages. -If the option is +Suppress all warning messages, or, if the option is .LR -w66 , -only Fortran 66 compatibility warnings are suppressed. +just Fortran 66 compatibility warnings. .PP The following options are peculiar to .IR f\^2c . @@ -114,6 +124,13 @@ Output C++ code. .B -c Include original Fortran source as comments. .TP +.BI -d dir +Write +.L .c +files in directory +.I dir +instead of the current directory. +.TP .B -E Declare uninitialized .SM COMMON @@ -226,7 +243,9 @@ to .SM DOUBLE COMPLEX. .TP .B -s -Preserve multidimensional subscripts. +Preserve multidimensional subscripts. Suppressed by option +.L -C +\&. .TP .BI -T dir Put temporary files in directory @@ -296,6 +315,7 @@ see the reference below. .br .SH FILES .TP +.nr )I 1.75i .IB file .[fF] input file .TP diff --git a/usr.bin/f2c/f2c.h b/usr.bin/f2c/f2c.h index fc1e9791fbc72..8f18f6c7a6d29 100644 --- a/usr.bin/f2c/f2c.h +++ b/usr.bin/f2c/f2c.h @@ -36,9 +36,9 @@ typedef short flag; typedef short ftnlen; typedef short ftnint; #else -typedef long flag; -typedef long ftnlen; -typedef long ftnint; +typedef long int flag; +typedef long int ftnlen; +typedef long int ftnint; #endif /*external read, write*/ @@ -131,7 +131,7 @@ union Multitype { /* for multiple entry points */ typedef union Multitype Multitype; -typedef long Long; /* No longer used; formerly in Namelist */ +/*typedef long int Long;*/ /* No longer used; formerly in Namelist */ struct Vardesc { /* for Namelist */ char *name; diff --git a/usr.bin/f2c/format.c b/usr.bin/f2c/format.c index 80faacceeb41d..10aa39d8f1f6c 100644 --- a/usr.bin/f2c/format.c +++ b/usr.bin/f2c/format.c @@ -1,5 +1,5 @@ /**************************************************************** -Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore. +Copyright 1990 - 1995 by AT&T Bell Laboratories and Bellcore. Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby @@ -40,29 +40,51 @@ static char this_proc_name[52]; /* Name of the current procedure. This is probably too simplistic to handle multiple entry points */ -static int p1getd(), p1gets(), p1getf(), get_p1_token(); -static int p1get_const(), p1getn(); -static expptr do_format(), do_p1_name_pointer(), do_p1_const(); -static expptr do_p1_expr(), do_p1_ident(), do_p1_charp(), do_p1_extern(); -static expptr do_p1_head(), do_p1_list(), do_p1_literal(); -static void do_p1_label(), do_p1_asgoto(), do_p1_goto(); -static void do_p1_if(), do_p1_else(), do_p1_elif(), do_p1_endif(); -static void do_p1_endelse(), do_p1_subr_ret(), do_p1_comp_goto(); -static void do_p1_for(), do_p1_end_for(), do_p1_fortran(); -static void do_p1_1while(), do_p1_2while(), do_p1_elseifstart(); -static void do_p1_comment(), do_p1_set_line(); -static expptr do_p1_addr(); -static void proto(); -void list_arg_types(); -chainp length_comp(); -void listargs(); +static tagptr do_format Argdcl((FILEP, FILEP)); +static void do_p1_1while Argdcl((FILEP)); +static void do_p1_2while Argdcl((FILEP, FILEP)); +static tagptr do_p1_addr Argdcl((FILEP, FILEP)); +static void do_p1_asgoto Argdcl((FILEP, FILEP)); +static tagptr do_p1_charp Argdcl((FILEP)); +static void do_p1_comment Argdcl((FILEP, FILEP)); +static void do_p1_comp_goto Argdcl((FILEP, FILEP)); +static tagptr do_p1_const Argdcl((FILEP)); +static void do_p1_elif Argdcl((FILEP, FILEP)); +static void do_p1_else Argdcl((FILEP)); +static void do_p1_elseifstart Argdcl((FILEP)); +static void do_p1_end_for Argdcl((FILEP)); +static void do_p1_endelse Argdcl((FILEP)); +static void do_p1_endif Argdcl((FILEP)); +static tagptr do_p1_expr Argdcl((FILEP, FILEP)); +static tagptr do_p1_extern Argdcl((FILEP)); +static void do_p1_for Argdcl((FILEP, FILEP)); +static void do_p1_fortran Argdcl((FILEP, FILEP)); +static void do_p1_goto Argdcl((FILEP, FILEP)); +static tagptr do_p1_head Argdcl((FILEP, FILEP)); +static tagptr do_p1_ident Argdcl((FILEP)); +static void do_p1_if Argdcl((FILEP, FILEP)); +static void do_p1_label Argdcl((FILEP, FILEP)); +static tagptr do_p1_list Argdcl((FILEP, FILEP)); +static tagptr do_p1_literal Argdcl((FILEP)); +static tagptr do_p1_name_pointer Argdcl((FILEP)); +static void do_p1_set_line Argdcl((FILEP)); +static void do_p1_subr_ret Argdcl((FILEP, FILEP)); +static int get_p1_token Argdcl((FILEP)); +static int p1get_const Argdcl((FILEP, int, Constp*)); +static int p1getd Argdcl((FILEP, long int*)); +static int p1getf Argdcl((FILEP, char**)); +static int p1getn Argdcl((FILEP, int, char**)); +static int p1gets Argdcl((FILEP, char*, int)); +static void proto Argdcl((FILEP, Argtypes*, char*)); + extern chainp assigned_fmts; -static char filename[P1_FILENAME_MAX]; -extern int gflag; +char filename[P1_FILENAME_MAX]; +extern int gflag, sharp_line; int gflag1; extern char *parens; -start_formatting () + void +start_formatting(Void) { FILE *infile; static int wrote_one = 0; @@ -96,7 +118,7 @@ start_formatting () nice_printf (c_file, ";\n"); prev_tab (c_file); - gflag1 = 0; + gflag1 = sharp_line = 0; if (this_proc_name[0]) nice_printf (c_file, "} /* %s */\n", this_proc_name); @@ -145,8 +167,12 @@ start_formatting () static void +#ifdef KR_headers put_semi(outfile) - FILE *outfile; + FILE *outfile; +#else +put_semi(FILE *outfile) +#endif { nice_printf (outfile, ";\n"); last_was_label = 0; @@ -158,8 +184,14 @@ put_semi(outfile) the appropriate C code to outfile when possible. When reading an expression, the expression tree is returned instead. */ -static expptr do_format (infile, outfile) -FILE *infile, *outfile; + static expptr +#ifdef KR_headers +do_format(infile, outfile) + FILE *infile; + FILE *outfile; +#else +do_format(FILE *infile, FILE *outfile) +#endif { int token_type, was_c_token; expptr retval = ENULL; @@ -198,9 +230,9 @@ FILE *infile, *outfile; retval = do_p1_extern (infile); break; case P1_HEAD: - gflag1 = 0; + gflag1 = sharp_line = 0; retval = do_p1_head (infile, outfile); - gflag1 = gflag; + gflag1 = sharp_line = gflag; break; case P1_LIST: retval = do_p1_list (infile, outfile); @@ -288,8 +320,13 @@ FILE *infile, *outfile; static void -do_p1_comment (infile, outfile) -FILE *infile, *outfile; +#ifdef KR_headers +do_p1_comment(infile, outfile) + FILE *infile; + FILE *outfile; +#else +do_p1_comment(FILE *infile, FILE *outfile) +#endif { extern int c_output_line_length, in_comment; @@ -301,19 +338,23 @@ FILE *infile, *outfile; length = strlen (storage); - gflag1 = 0; + gflag1 = sharp_line = 0; in_comment = 1; if (length > c_output_line_length - 6) - margin_printf (outfile, "/*%s*/\n", storage); + 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 = gflag; + gflag1 = sharp_line = gflag; } /* do_p1_comment */ static void -do_p1_set_line (infile) -FILE *infile; +#ifdef KR_headers +do_p1_set_line(infile) + FILE *infile; +#else +do_p1_set_line(FILE *infile) +#endif { int status; long new_line_number = -1; @@ -331,8 +372,13 @@ FILE *infile; } /* do_p1_set_line */ -static expptr do_p1_name_pointer (infile) -FILE *infile; + static expptr +#ifdef KR_headers +do_p1_name_pointer(infile) + FILE *infile; +#else +do_p1_name_pointer(FILE *infile) +#endif { Namep namep = (Namep) NULL; int status; @@ -350,8 +396,13 @@ FILE *infile; -static expptr do_p1_const (infile) -FILE *infile; + static expptr +#ifdef KR_headers +do_p1_const(infile) + FILE *infile; +#else +do_p1_const(FILE *infile) +#endif { struct Constblock *c = (struct Constblock *) NULL; long type = -1; @@ -377,9 +428,36 @@ FILE *infile; return (expptr) c; } /* do_p1_const */ + void +#ifdef KR_headers +addrlit(addrp) + Addrp addrp; +#else +addrlit(Addrp addrp) +#endif +{ + int memno = addrp->memno; + struct Literal *litp, *lastlit; + + lastlit = litpool + nliterals; + for (litp = litpool; litp < lastlit; litp++) + if (litp->litnum == memno) { + addrp->vtype = litp->littype; + *((union Constant *) &(addrp->user)) = + *((union Constant *) &(litp->litval)); + addrp->vstg = STGMEMNO; + return; + } + err("addrlit failure!"); + } -static expptr do_p1_literal (infile) -FILE *infile; + static expptr +#ifdef KR_headers +do_p1_literal(infile) + FILE *infile; +#else +do_p1_literal(FILE *infile) +#endif { int status; long memno; @@ -392,24 +470,12 @@ FILE *infile; else if (status == 0) err ("do_p1_literal: Missing memno in p1 file"); else { - struct Literal *litp, *lastlit; - addrp = ALLOC (Addrblock); addrp -> tag = TADDR; addrp -> vtype = TYUNKNOWN; addrp -> Field = NULL; - - lastlit = litpool + nliterals; - for (litp = litpool; litp < lastlit; litp++) - if (litp -> litnum == memno) { - addrp -> vtype = litp -> littype; - *((union Constant *) &(addrp -> user)) = - *((union Constant *) &(litp -> litval)); - break; - } /* if litp -> litnum == memno */ - addrp -> memno = memno; - addrp -> vstg = STGMEMNO; + addrlit(addrp); addrp -> uname_tag = UNAM_CONST; } /* else */ @@ -417,12 +483,17 @@ FILE *infile; } /* do_p1_literal */ -static void do_p1_label (infile, outfile) -FILE *infile, *outfile; + static void +#ifdef KR_headers +do_p1_label(infile, outfile) + FILE *infile; + FILE *outfile; +#else +do_p1_label(FILE *infile, FILE *outfile) +#endif { int status; ftnint stateno; - char *user_label (); struct Labelblock *L; char *fmt; @@ -450,8 +521,14 @@ FILE *infile, *outfile; -static void do_p1_asgoto (infile, outfile) -FILE *infile, *outfile; + static void +#ifdef KR_headers +do_p1_asgoto(infile, outfile) + FILE *infile; + FILE *outfile; +#else +do_p1_asgoto(FILE *infile, FILE *outfile) +#endif { expptr expr; @@ -461,12 +538,17 @@ FILE *infile, *outfile; } /* do_p1_asgoto */ -static void do_p1_goto (infile, outfile) -FILE *infile, *outfile; + static void +#ifdef KR_headers +do_p1_goto(infile, outfile) + FILE *infile; + FILE *outfile; +#else +do_p1_goto(FILE *infile, FILE *outfile) +#endif { int status; long stateno; - char *user_label (); status = p1getd (infile, &stateno); @@ -480,8 +562,14 @@ FILE *infile, *outfile; } /* do_p1_goto */ -static void do_p1_if (infile, outfile) -FILE *infile, *outfile; + static void +#ifdef KR_headers +do_p1_if(infile, outfile) + FILE *infile; + FILE *outfile; +#else +do_p1_if(FILE *infile, FILE *outfile) +#endif { expptr cond; @@ -493,15 +581,26 @@ FILE *infile, *outfile; } /* do_p1_if */ -static void do_p1_else (outfile) -FILE *outfile; + static void +#ifdef KR_headers +do_p1_else(outfile) + FILE *outfile; +#else +do_p1_else(FILE *outfile) +#endif { out_else (outfile); } /* do_p1_else */ -static void do_p1_elif (infile, outfile) -FILE *infile, *outfile; + static void +#ifdef KR_headers +do_p1_elif(infile, outfile) + FILE *infile; + FILE *outfile; +#else +do_p1_elif(FILE *infile, FILE *outfile) +#endif { expptr cond; @@ -512,22 +611,38 @@ FILE *infile, *outfile; elif_out (outfile, cond); } /* do_p1_elif */ -static void do_p1_endif (outfile) -FILE *outfile; + static void +#ifdef KR_headers +do_p1_endif(outfile) + FILE *outfile; +#else +do_p1_endif(FILE *outfile) +#endif { endif_out (outfile); } /* do_p1_endif */ -static void do_p1_endelse (outfile) -FILE *outfile; + static void +#ifdef KR_headers +do_p1_endelse(outfile) + FILE *outfile; +#else +do_p1_endelse(FILE *outfile) +#endif { end_else_out (outfile); } /* do_p1_endelse */ -static expptr do_p1_addr (infile, outfile) -FILE *infile, *outfile; + static expptr +#ifdef KR_headers +do_p1_addr(infile, outfile) + FILE *infile; + FILE *outfile; +#else +do_p1_addr(FILE *infile, FILE *outfile) +#endif { Addrp addrp = (Addrp) NULL; int status; @@ -552,8 +667,14 @@ FILE *infile, *outfile; -static void do_p1_subr_ret (infile, outfile) -FILE *infile, *outfile; + static void +#ifdef KR_headers +do_p1_subr_ret(infile, outfile) + FILE *infile; + FILE *outfile; +#else +do_p1_subr_ret(FILE *infile, FILE *outfile) +#endif { expptr retval; @@ -568,8 +689,14 @@ FILE *infile, *outfile; -static void do_p1_comp_goto (infile, outfile) -FILE *infile, *outfile; + static void +#ifdef KR_headers +do_p1_comp_goto(infile, outfile) + FILE *infile; + FILE *outfile; +#else +do_p1_comp_goto(FILE *infile, FILE *outfile) +#endif { expptr index; expptr labels; @@ -590,8 +717,14 @@ FILE *infile, *outfile; } /* do_p1_comp_goto */ -static void do_p1_for (infile, outfile) -FILE *infile, *outfile; + static void +#ifdef KR_headers +do_p1_for(infile, outfile) + FILE *infile; + FILE *outfile; +#else +do_p1_for(FILE *infile, FILE *outfile) +#endif { expptr init, test, inc; @@ -602,16 +735,26 @@ FILE *infile, *outfile; out_for (outfile, init, test, inc); } /* do_p1_for */ -static void do_p1_end_for (outfile) -FILE *outfile; + static void +#ifdef KR_headers +do_p1_end_for(outfile) + FILE *outfile; +#else +do_p1_end_for(FILE *outfile) +#endif { out_end_for (outfile); } /* do_p1_end_for */ static void +#ifdef KR_headers do_p1_fortran(infile, outfile) - FILE *infile, *outfile; + FILE *infile; + FILE *outfile; +#else +do_p1_fortran(FILE *infile, FILE *outfile) +#endif { char buf[P1_STMTBUFSIZE]; if (!p1gets(infile, buf, P1_STMTBUFSIZE)) @@ -621,8 +764,14 @@ do_p1_fortran(infile, outfile) } -static expptr do_p1_expr (infile, outfile) -FILE *infile, *outfile; + static expptr +#ifdef KR_headers +do_p1_expr(infile, outfile) + FILE *infile; + FILE *outfile; +#else +do_p1_expr(FILE *infile, FILE *outfile) +#endif { int status; long opcode, type; @@ -666,8 +815,13 @@ FILE *infile, *outfile; } /* do_p1_expr */ -static expptr do_p1_ident(infile) -FILE *infile; + static expptr +#ifdef KR_headers +do_p1_ident(infile) + FILE *infile; +#else +do_p1_ident(FILE *infile) +#endif { Addrp addrp; int status; @@ -702,8 +856,13 @@ FILE *infile; return (expptr) addrp; } /* do_p1_ident */ -static expptr do_p1_charp(infile) -FILE *infile; + static expptr +#ifdef KR_headers +do_p1_charp(infile) + FILE *infile; +#else +do_p1_charp(FILE *infile) +#endif { Addrp addrp; int status; @@ -741,8 +900,13 @@ FILE *infile; } -static expptr do_p1_extern (infile) -FILE *infile; + static expptr +#ifdef KR_headers +do_p1_extern(infile) + FILE *infile; +#else +do_p1_extern(FILE *infile) +#endif { Addrp addrp; @@ -767,8 +931,14 @@ FILE *infile; -static expptr do_p1_head (infile, outfile) -FILE *infile, *outfile; + static expptr +#ifdef KR_headers +do_p1_head(infile, outfile) + FILE *infile; + FILE *outfile; +#else +do_p1_head(FILE *infile, FILE *outfile) +#endif { int status; int add_n_; @@ -822,8 +992,14 @@ FILE *infile, *outfile; } /* do_p1_head */ -static expptr do_p1_list (infile, outfile) -FILE *infile, *outfile; + static expptr +#ifdef KR_headers +do_p1_list(infile, outfile) + FILE *infile; + FILE *outfile; +#else +do_p1_list(FILE *infile, FILE *outfile) +#endif { long tag, type, count; int status; @@ -873,9 +1049,15 @@ FILE *infile, *outfile; } /* do_p1_list */ -chainp length_comp(e, add_n) /* get lengths of characters args */ - struct Entrypoint *e; - int add_n; + chainp +#ifdef KR_headers +length_comp(e, add_n) + struct Entrypoint *e; + int add_n; +#else +length_comp(struct Entrypoint *e, int add_n) +#endif + /* get lengths of characters args */ { chainp lengths; chainp args, args1; @@ -924,11 +1106,16 @@ chainp length_comp(e, add_n) /* get lengths of characters args */ return revchain(lengths); } -void listargs(outfile, entryp, add_n_, lengths) - FILE *outfile; - struct Entrypoint *entryp; - int add_n_; - chainp lengths; + void +#ifdef KR_headers +listargs(outfile, entryp, add_n_, lengths) + FILE *outfile; + struct Entrypoint *entryp; + int add_n_; + chainp lengths; +#else +listargs(FILE *outfile, struct Entrypoint *entryp, int add_n_, chainp lengths) +#endif { chainp args; char *s; @@ -977,12 +1164,17 @@ void listargs(outfile, entryp, add_n_, lengths) } /* listargs */ -void list_arg_types(outfile, entryp, lengths, add_n_, finalnl) -FILE *outfile; -struct Entrypoint *entryp; -chainp lengths; -int add_n_; -char *finalnl; + void +#ifdef KR_headers +list_arg_types(outfile, entryp, lengths, add_n_, finalnl) + FILE *outfile; + struct Entrypoint *entryp; + chainp lengths; + int add_n_; + char *finalnl; +#else +list_arg_types(FILE *outfile, struct Entrypoint *entryp, chainp lengths, int add_n_, char *finalnl) +#endif { chainp args; int last_type = -1, last_class = -1; @@ -1084,8 +1276,12 @@ char *finalnl; } /* list_arg_types */ static void +#ifdef KR_headers write_formats(outfile) - FILE *outfile; + FILE *outfile; +#else +write_formats(FILE *outfile) +#endif { register struct Labelblock *lp; int first = 1; @@ -1108,8 +1304,12 @@ write_formats(outfile) } static void +#ifdef KR_headers write_ioblocks(outfile) - FILE *outfile; + FILE *outfile; +#else +write_ioblocks(FILE *outfile) +#endif { register iob_data *L; register char *f, **s, *sep; @@ -1138,8 +1338,12 @@ write_ioblocks(outfile) } static void +#ifdef KR_headers write_assigned_fmts(outfile) - FILE *outfile; + FILE *outfile; +#else +write_assigned_fmts(FILE *outfile) +#endif { register chainp cp; Namep np; @@ -1159,8 +1363,12 @@ write_assigned_fmts(outfile) } static char * +#ifdef KR_headers to_upper(s) - register char *s; + register char *s; +#else +to_upper(register char *s) +#endif { static char buf[64]; register char *t = buf; @@ -1201,9 +1409,13 @@ to_upper(s) */ static void +#ifdef KR_headers write_namelists(nmch, outfile) - chainp nmch; - FILE *outfile; + chainp nmch; + FILE *outfile; +#else +write_namelists(chainp nmch, FILE *outfile) +#endif { Namep var; struct Hashentry *entry; @@ -1274,12 +1486,15 @@ write_namelists(nmch, outfile) */ static int +#ifdef KR_headers fixexttype(var) - Namep var; + Namep var; +#else +fixexttype(Namep var) +#endif { Extsym *e; int type, type1; - extern void changedtype(); type = var->vtype; e = &extsymtab[var->vardesc.varno]; @@ -1295,17 +1510,22 @@ fixexttype(var) } static void -ref_defs(outfile, refdefs) FILE *outfile; chainp refdefs; +#ifdef KR_headers +ref_defs(outfile, refdefs) + FILE *outfile; + chainp refdefs; +#else +ref_defs(FILE *outfile, chainp refdefs) +#endif { chainp cp; int eb, i, j, n; struct Dimblock *dimp; - long L; expptr b, vl; Namep var; char *amp, *comma; - ind_printf(0, outfile, "\n"); + margin_printf(outfile, "\n"); for(cp = refdefs = revchain(refdefs); cp; cp = cp->nextp) { var = (Namep)cp->datap; cp->datap = 0; @@ -1353,7 +1573,8 @@ ref_defs(outfile, refdefs) FILE *outfile; chainp refdefs; } nice_printf(outfile, " + a_0"); } - if (var->vstg != STGARG && (b = dimp->baseoffset)) { + if ((var->vstg != STGARG /* || checksubs */ ) + && (b = dimp->baseoffset)) { b = cpexpr(b); if (var->vtype == TYCHAR) b = mkexpr(OPSTAR, cpexpr(var->vleng), b); @@ -1361,7 +1582,7 @@ ref_defs(outfile, refdefs) FILE *outfile; chainp refdefs; expr_out(outfile, b); } if (ISCOMPLEX(var->vtype)) { - ind_printf(0, outfile, "\n"); + margin_printf(outfile, "\n"); def_start(outfile, var->cvarname, "_ref", CNULL); comma = "("; for(i = 1; i <= n; i++, comma = ",") @@ -1373,18 +1594,22 @@ ref_defs(outfile, refdefs) FILE *outfile; chainp refdefs; nice_printf(outfile, "%sa_%d", comma, i); nice_printf(outfile, ")"); } - ind_printf(0, outfile, "]\n" + eb); + margin_printf(outfile, "]\n" + eb); } nice_printf(outfile, "\n"); frchain(&refdefs); } -list_decls (outfile) -FILE *outfile; + void +#ifdef KR_headers +list_decls(outfile) + FILE *outfile; +#else +list_decls(FILE *outfile) +#endif { extern chainp used_builtins; extern struct Hashentry *hashtab; - extern ftnint wr_char_len(); struct Hashentry *entry; int write_header = 1; int last_class = -1, last_stg = -1; @@ -1686,7 +1911,7 @@ FILE *outfile; hsize - x); nice_printf(outfile, "; } %s_st;\n", var->cvarname); def_start(outfile, var->cvarname, CNULL, var->cvarname); - ind_printf(0, outfile, "_st.val\n"); + margin_printf(outfile, "_st.val\n"); last_type = -1; write_header = 2; continue; @@ -1724,7 +1949,6 @@ FILE *outfile; Alias1: if (Alias) { char *amp, *lp, *name, *rp; - char *equiv_name (); ftnint voff = var -> voffset; int et0, expr_type, k; Extsym *E; @@ -1806,7 +2030,7 @@ FILE *outfile; last_type = last_class = last_stg = -1; write_header = 0; if (Define) { - ind_printf(0, outfile, ")\n"); + margin_printf(outfile, ")\n"); write_header = 2; } continue; @@ -1841,9 +2065,14 @@ FILE *outfile; } /* list_decls */ -do_uninit_equivs (outfile, did_one) -FILE *outfile; -int *did_one; + void +#ifdef KR_headers +do_uninit_equivs(outfile, did_one) + FILE *outfile; + int *did_one; +#else +do_uninit_equivs(FILE *outfile, int *did_one) +#endif { extern int nequiv; struct Equivblock *eqv, *lasteqv = eqvclass + nequiv; @@ -1878,12 +2107,18 @@ int *did_one; dimension is greater than 1, a string comment about the original size is returned */ -char *wr_ardecls(outfile, dimp, size) -FILE *outfile; -struct Dimblock *dimp; -long size; + char * +#ifdef KR_headers +wr_ardecls(outfile, dimp, size) + FILE *outfile; + struct Dimblock *dimp; + long size; +#else +wr_ardecls(FILE *outfile, struct Dimblock *dimp, long size) +#endif { int i, k; + ftnint j; static char buf[1000]; if (dimp == (struct Dimblock *) NULL) @@ -1895,13 +2130,22 @@ long size; for (i = 0; i < dimp -> ndim; i++) { expptr this_size = dimp -> dims[i].dimsize; - if (!ISICON (this_size)) - err ("wr_ardecls: nonconstant array size"); + if (ISCONST(this_size)) { + if (ISINT(this_size->constblock.vtype)) + j = this_size -> constblock.Const.ci; + else if (ISREAL(this_size->constblock.vtype)) + j = (ftnint)this_size -> constblock.Const.cd[0]; + else + goto non_const; + size *= j; + sprintf(buf+k, "[%ld]", j); + k += strlen(buf+k); + /* BSD prevents getting strlen from sprintf */ + } else { - size *= this_size -> constblock.Const.ci; - sprintf(buf+k, "[%ld]", this_size -> constblock.Const.ci); - k += strlen(buf+k); /* BSD prevents combining this with prev stmt */ - } /* else */ + non_const: + err ("wr_ardecls: nonconstant array size"); + } } /* for i = 0 */ nice_printf (outfile, "[%ld]", size); @@ -1919,8 +2163,13 @@ long size; ---------------------------------------------------------------------- */ -static int get_p1_token (infile) -FILE *infile; + static int +#ifdef KR_headers +get_p1_token(infile) + FILE *infile; +#else +get_p1_token(FILE *infile) +#endif { int token = P1_UNKNOWN; @@ -1941,12 +2190,16 @@ FILE *infile; /* Returns a (null terminated) string from the input file */ -static int p1gets (fp, str, size) -FILE *fp; -char *str; -int size; + static int +#ifdef KR_headers +p1gets(fp, str, size) + FILE *fp; + char *str; + int size; +#else +p1gets(FILE *fp, char *str, int size) +#endif { - char *fgets (); char c; if (str == NULL) @@ -1974,10 +2227,15 @@ int size; } /* p1gets */ -static int p1get_const (infile, type, resultp) -FILE *infile; -int type; -struct Constblock **resultp; + static int +#ifdef KR_headers +p1get_const(infile, type, resultp) + FILE *infile; + int type; + struct Constblock **resultp; +#else +p1get_const(FILE *infile, int type, struct Constblock **resultp) +#endif { int status; struct Constblock *result; @@ -2024,17 +2282,26 @@ struct Constblock **resultp; return status; } /* p1get_const */ -static int p1getd (infile, result) -FILE *infile; -long *result; + static int +#ifdef KR_headers +p1getd(infile, result) + FILE *infile; + long *result; +#else +p1getd(FILE *infile, long *result) +#endif { return fscanf (infile, "%ld", result); } /* p1getd */ static int +#ifdef KR_headers p1getf(infile, result) - FILE *infile; - char **result; + FILE *infile; + char **result; +#else +p1getf(FILE *infile, char **result) +#endif { char buf[1324]; @@ -2048,14 +2315,18 @@ p1getf(infile, result) return k; } -static int p1getn (infile, count, result) -FILE *infile; -int count; -char **result; + static int +#ifdef KR_headers +p1getn(infile, count, result) + FILE *infile; + int count; + char **result; +#else +p1getn(FILE *infile, int count, char **result) +#endif { char *bufptr; - extern ptr ckalloc (); bufptr = (char *) ckalloc (count); @@ -2069,17 +2340,20 @@ char **result; } /* p1getn */ static void +#ifdef KR_headers proto(outfile, at, fname) - FILE *outfile; - Argtypes *at; - char *fname; + FILE *outfile; + Argtypes *at; + char *fname; +#else +proto(FILE *outfile, Argtypes *at, char *fname) +#endif { int i, j, k, n; char *comma; Atype *atypes; Namep np; chainp cp; - extern void bad_atypes(); if (at) { /* Correct types that we learn on the fly, e.g. @@ -2163,11 +2437,16 @@ proto(outfile, at, fname) } void +#ifdef KR_headers protowrite(protofile, type, name, e, lengths) - FILE *protofile; - char *name; - struct Entrypoint *e; - chainp lengths; + FILE *protofile; + int type; + char *name; + struct Entrypoint *e; + chainp lengths; +#else +protowrite(FILE *protofile, int type, char *name, struct Entrypoint *e, chainp lengths) +#endif { extern char used_rets[]; int asave; @@ -2182,8 +2461,12 @@ protowrite(protofile, type, name, e, lengths) } static void +#ifdef KR_headers do_p1_1while(outfile) - FILE *outfile; + FILE *outfile; +#else +do_p1_1while(FILE *outfile) +#endif { if (*wh_next) { nice_printf(outfile, @@ -2195,8 +2478,13 @@ do_p1_1while(outfile) } static void +#ifdef KR_headers do_p1_2while(infile, outfile) - FILE *infile, *outfile; + FILE *infile; + FILE *outfile; +#else +do_p1_2while(FILE *infile, FILE *outfile) +#endif { expptr test; @@ -2213,8 +2501,12 @@ do_p1_2while(infile, outfile) } static void +#ifdef KR_headers do_p1_elseifstart(outfile) - FILE *outfile; + FILE *outfile; +#else +do_p1_elseifstart(FILE *outfile) +#endif { if (*ei_next++) { prev_tab(outfile); diff --git a/usr.bin/f2c/format.h b/usr.bin/f2c/format.h index a88c038929f56..3de97f6f89f38 100644 --- a/usr.bin/f2c/format.h +++ b/usr.bin/f2c/format.h @@ -4,7 +4,9 @@ extern int c_output_line_length; /* max # chars per line in C source code */ -char *wr_ardecls (/* FILE *, struct Dimblock * */); -void list_init_data (), wr_one_init (), wr_output_values (); -int do_init_data (); -chainp data_value (); +chainp data_value Argdcl((FILEP, long int, int)); +int do_init_data Argdcl((FILEP, FILEP)); +void list_init_data Argdcl((FILEP*, char*, FILEP)); +char* wr_ardecls Argdcl((FILEP, struct Dimblock*, long int)); +void wr_one_init Argdcl((FILEP, char*, chainp*, int)); +void wr_output_values Argdcl((FILEP, Namep, chainp)); diff --git a/usr.bin/f2c/formatdata.c b/usr.bin/f2c/formatdata.c index 541472a9400ed..690ee10cb421a 100644 --- a/usr.bin/f2c/formatdata.c +++ b/usr.bin/f2c/formatdata.c @@ -1,5 +1,5 @@ /**************************************************************** -Copyright 1990, 1991, 1993 by AT&T Bell Laboratories and Bellcore. +Copyright 1990, 1991, 1993-5 by AT&T Bell Laboratories and Bellcore. Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby @@ -29,14 +29,19 @@ this software. #define MAX_INIT_LINE 100 #define NAME_MAX 64 -static int memno2info(); +static int memno2info Argdcl((int, Namep*)); -extern char *initbname; -extern void def_start(); + extern char *initbname; -void list_init_data(Infile, Inname, outfile) - FILE **Infile, *outfile; - char *Inname; + void +#ifdef KR_headers +list_init_data(Infile, Inname, outfile) + FILE **Infile; + char *Inname; + FILE *outfile; +#else +list_init_data(FILE **Infile, char *Inname, FILE *outfile) +#endif { FILE *sortfp; int status; @@ -70,8 +75,14 @@ void list_init_data(Infile, Inname, outfile) /* do_init_data -- returns YES when at least one declaration has been written */ -int do_init_data(outfile, infile) -FILE *outfile, *infile; + int +#ifdef KR_headers +do_init_data(outfile, infile) + FILE *outfile; + FILE *infile; +#else +do_init_data(FILE *outfile, FILE *infile) +#endif { char varname[NAME_MAX], ovarname[NAME_MAX]; ftnint offset; @@ -129,15 +140,19 @@ FILE *outfile, *infile; ftnint +#ifdef KR_headers wr_char_len(outfile, dimp, n, extra1) - FILE *outfile; - int n; - struct Dimblock *dimp; - int extra1; + FILE *outfile; + struct Dimblock *dimp; + int n; + int extra1; +#else +wr_char_len(FILE *outfile, struct Dimblock *dimp, int n, int extra1) +#endif { int i, nd; expptr e; - ftnint rv; + ftnint j, rv; if (!dimp) { nice_printf (outfile, extra1 ? "[%d+1]" : "[%d]", n); @@ -148,11 +163,19 @@ wr_char_len(outfile, dimp, n, extra1) rv = n; for(i = 0; i < nd; i++) { e = dimp->dims[i].dimsize; - if (!ISICON (e)) - err ("wr_char_len: nonconstant array size"); + if (ISCONST(e)) { + if (ISINT(e->constblock.vtype)) + j = e->constblock.Const.ci; + else if (ISREAL(e->constblock.vtype)) + j = (ftnint)e->constblock.Const.cd[0]; + else + goto non_const; + nice_printf(outfile, "*%ld", j); + rv *= j; + } else { - nice_printf(outfile, "*%ld", e->constblock.Const.ci); - rv *= e->constblock.Const.ci; + non_const: + err ("wr_char_len: nonconstant array size"); } } /* extra1 allows for stupid C compilers that complain about @@ -167,15 +190,20 @@ wr_char_len(outfile, dimp, n, extra1) static int eqvmemno; /* kludge */ static void +#ifdef KR_headers write_char_init(outfile, Values, namep) - FILE *outfile; - chainp *Values; - Namep namep; + FILE *outfile; + chainp *Values; + Namep namep; +#else +write_char_init(FILE *outfile, chainp *Values, Namep namep) +#endif { struct Equivblock *eqv; long size; struct Dimblock *dimp; int i, nd, type; + ftnint j; expptr ds; if (!namep) @@ -191,10 +219,19 @@ write_char_init(outfile, Values, namep) if (dimp = namep->vdim) for(i = 0, nd = dimp->ndim; i < nd; i++) { ds = dimp->dims[i].dimsize; - if (!ISICON(ds)) + if (ISCONST(ds)) { + if (ISINT(ds->constblock.vtype)) + j = ds->constblock.Const.ci; + else if (ISREAL(ds->constblock.vtype)) + j = (ftnint)ds->constblock.Const.cd[0]; + else + goto non_const; + size *= j; + } + else { + non_const: err("write_char_values: nonconstant array size"); - else - size *= ds->constblock.Const.ci; + } } *Values = revchain(*Values); eqv->eqvtop = size; @@ -203,9 +240,9 @@ write_char_init(outfile, Values, namep) wr_equiv_init(outfile, nequiv, Values, 0); def_start(outfile, namep->cvarname, CNULL, ""); if (type == TYCHAR) - ind_printf(0, outfile, "((char *)&equiv_%d)\n\n", eqvmemno); + margin_printf(outfile, "((char *)&equiv_%d)\n\n", eqvmemno); else - ind_printf(0, outfile, dimp + margin_printf(outfile, dimp ? "((%s *)&equiv_%d)\n\n" : "(*(%s *)&equiv_%d)\n\n", c_type_decl(type,0), eqvmemno); } @@ -214,11 +251,16 @@ write_char_init(outfile, Values, namep) by info. When is_addr is true, info is an Addrp; otherwise, treat it as a Namep */ -void wr_one_init (outfile, varname, Values, keepit) -FILE *outfile; -char *varname; -chainp *Values; -int keepit; + void +#ifdef KR_headers +wr_one_init(outfile, varname, Values, keepit) + FILE *outfile; + char *varname; + chainp *Values; + int keepit; +#else +wr_one_init(FILE *outfile, char *varname, chainp *Values, int keepit) +#endif { static int memno; static union { @@ -310,7 +352,7 @@ int keepit; nice_printf(outfile, " };\n"); ch_ar_dim = -1; def_start(outfile, name, CNULL, name); - ind_printf(0, outfile, "_st.val\n"); + margin_printf(outfile, "_st.val\n"); goto done; } } @@ -371,16 +413,18 @@ int keepit; -chainp data_value (infile, offset, type) -FILE *infile; -ftnint offset; -int type; + chainp +#ifdef KR_headers +data_value(infile, offset, type) + FILE *infile; + ftnint offset; + int type; +#else +data_value(FILE *infile, ftnint offset, int type) +#endif { char line[MAX_INIT_LINE + 1], *pointer; chainp vals, prev_val; -#ifndef atol - long atol(); -#endif char *newval; if (fgets (line, MAX_INIT_LINE, infile) == NULL) { @@ -436,7 +480,7 @@ int type; } /* data_value */ static void -overlapping() +overlapping(Void) { extern char *filename0; static int warned = 0; @@ -452,13 +496,18 @@ overlapping() nerr++; } - static void make_one_const(); + static void make_one_const Argdcl((int, union Constant*, chainp)); static long charlen; -void wr_output_values (outfile, namep, values) -FILE *outfile; -Namep namep; -chainp values; + void +#ifdef KR_headers +wr_output_values(outfile, namep, values) + FILE *outfile; + Namep namep; + chainp values; +#else +wr_output_values(FILE *outfile, Namep namep, chainp values) +#endif { int type = TYUNKNOWN; struct Constblock Const; @@ -493,10 +542,15 @@ chainp values; } -wr_array_init (outfile, type, values) -FILE *outfile; -int type; -chainp values; + void +#ifdef KR_headers +wr_array_init(outfile, type, values) + FILE *outfile; + int type; + chainp values; +#else +wr_array_init(FILE *outfile, int type, chainp values) +#endif { int size = typesize[type]; long index, main_index = 0; @@ -602,10 +656,14 @@ chainp values; static void +#ifdef KR_headers make_one_const(type, storage, values) - int type; - union Constant *storage; - chainp values; + int type; + union Constant *storage; + chainp values; +#else +make_one_const(int type, union Constant *storage, chainp values) +#endif { union Constant *Const; register char **L; @@ -661,11 +719,15 @@ make_one_const(type, storage, values) } /* make_one_const */ - -rdname (infile, vargroupp, name) -FILE *infile; -int *vargroupp; -char *name; + int +#ifdef KR_headers +rdname(infile, vargroupp, name) + FILE *infile; + int *vargroupp; + char *name; +#else +rdname(FILE *infile, int *vargroupp, char *name) +#endif { register int i, c; @@ -689,9 +751,14 @@ char *name; return YES; } /* rdname */ -rdlong (infile, n) -FILE *infile; -ftnint *n; + int +#ifdef KR_headers +rdlong(infile, n) + FILE *infile; + ftnint *n; +#else +rdlong(FILE *infile, ftnint *n) +#endif { register int c; @@ -708,9 +775,13 @@ ftnint *n; static int -memno2info (memno, info) - int memno; - Namep *info; +#ifdef KR_headers +memno2info(memno, info) + int memno; + Namep *info; +#else +memno2info(int memno, Namep *info) +#endif { chainp this_var; extern chainp new_vars; @@ -744,10 +815,14 @@ memno2info (memno, info) } /* memno2info */ static chainp +#ifdef KR_headers do_string(outfile, v, nloc) - FILEP outfile; - register chainp v; - ftnint *nloc; + FILE *outfile; + register chainp v; + ftnint *nloc; +#else +do_string(FILE *outfile, register chainp v, ftnint *nloc) +#endif { register chainp cp, v0; ftnint dloc, k, loc; @@ -779,9 +854,8 @@ do_string(outfile, v, nloc) goto done; } v0 = v; - if (!(v = v->nextp)) + if (!(v = v->nextp) || !(cp = (chainp)v->datap)) break; - cp = (chainp)v->datap; dloc = (ftnint)cp->datap; if (loc != dloc) break; @@ -793,10 +867,14 @@ do_string(outfile, v, nloc) } static chainp +#ifdef KR_headers Ado_string(outfile, v, nloc) - FILEP outfile; - register chainp v; - ftnint *nloc; + FILE *outfile; + register chainp v; + ftnint *nloc; +#else +Ado_string(FILE *outfile, register chainp v, ftnint *nloc) +#endif { register chainp cp, v0; ftnint dloc, k, loc; @@ -821,9 +899,8 @@ Ado_string(outfile, v, nloc) goto done; } v0 = v; - if (!(v = v->nextp)) + if (!(v = v->nextp) || !(cp = (chainp)v->datap)) break; - cp = (chainp)v->datap; dloc = (ftnint)cp->datap; if (loc != dloc) break; @@ -835,9 +912,13 @@ Ado_string(outfile, v, nloc) } static char * -Len(L,type) - long L; - int type; +#ifdef KR_headers +Len(L, type) + long L; + int type; +#else +Len(long L, int type) +#endif { static char buf[24]; if (L == 1 && type != TYCHAR) @@ -846,14 +927,18 @@ Len(L,type) return buf; } + void +#ifdef KR_headers wr_equiv_init(outfile, memno, Values, iscomm) - FILE *outfile; - int memno; - chainp *Values; - int iscomm; + FILE *outfile; + int memno; + chainp *Values; + int iscomm; +#else +wr_equiv_init(FILE *outfile, int memno, chainp *Values, int iscomm) +#endif { struct Equivblock *eqv; - char *equiv_name (); int btype, curtype, dtype, filltype, filltype1, j, k, wasblank, xtype; static char Blank[] = ""; register char *comma = Blank; diff --git a/usr.bin/f2c/gram.dcl b/usr.bin/f2c/gram.dcl index 9a25c25afe27f..fadbb5b6b7e4c 100644 --- a/usr.bin/f2c/gram.dcl +++ b/usr.bin/f2c/gram.dcl @@ -56,6 +56,7 @@ typename: SINTEGER { $$ = TYLONG; } | SDIMENSION { $$ = TYUNKNOWN; } | SAUTOMATIC { NOEXT("AUTOMATIC statement"); $$ = - STGAUTO; } | SSTATIC { NOEXT("STATIC statement"); $$ = - STGBSS; } + | SBYTE { $$ = TYINT1; } ; lengspec: @@ -228,6 +229,15 @@ var: name dims datavar: lhs { Namep np; + int tt = $1->tag; + if (tt != TPRIM) { + if (tt == TCONST) + err("parameter in data statement"); + else + erri("tag %d in data statement",tt); + $$ = 0; + break; + } np = ( (struct Primblock *) $1) -> namep; vardcl(np); if(np->vstg == STGCOMMON) diff --git a/usr.bin/f2c/gram.head b/usr.bin/f2c/gram.head index 4af7dc7a1a99c..dd822fd16480b 100644 --- a/usr.bin/f2c/gram.head +++ b/usr.bin/f2c/gram.head @@ -49,21 +49,12 @@ static chainp datastack; extern long laststfcn, thisstno; extern int can_include; /* for netlib */ -ftnint convci(); -Addrp nextdata(); -expptr mklogcon(), mkaddcon(), mkrealcon(), mkstrcon(), mkbitcon(); -expptr mkcxcon(); -struct Listblock *mklist(); -struct Listblock *mklist(); -struct Impldoblock *mkiodo(); -Extsym *comblock(); #define ESNULL (Extsym *)0 #define NPNULL (Namep)0 #define LBNULL (struct Listblock *)0 -extern void freetemps(), make_param(); static void -pop_datastack() { +pop_datastack(Void) { chainp d0 = datastack; if (d0->datap) curdtp = (chainp)d0->datap; @@ -163,8 +154,7 @@ stat: thislabel entry endproc(); /* lastwasbranch = NO; -- set in endproc() */ } | thislabel SUNKNOWN - { extern void unclassifiable(); - unclassifiable(); + { unclassifiable(); /* flline flushes the current line, ignoring the rest of the text there */ diff --git a/usr.bin/f2c/index b/usr.bin/f2c/index index 09422b31ccb7d..5212535c923f5 100644 --- a/usr.bin/f2c/index +++ b/usr.bin/f2c/index @@ -1,23 +1,12 @@ -# ====== index for f2c/src ====== - -file f2c/src/all -for bundle of complete f2c source - -# NOTE: "all from f2c/src" is the complete f2c source (sans libraries). +# ====== index for f2c/src ====== +# NOTE: "all from f2c/src" is the complete f2c source (sans libraries). # The remaining files in this directory are the component modules # of "all from f2c/src", so you can request just the modules that # have changed since last you updated your f2c source. You can # tell what has changed by looking at the timestamps at the end # of "readme from f2c". - -file f2c/src/notice - -file f2c/src/readme - file f2c/src/cds.c -file f2c/src/changes - file f2c/src/data.c file f2c/src/defines.h @@ -38,8 +27,6 @@ file f2c/src/f2c.1t file f2c/src/f2c.h -file f2c/src/fc - file f2c/src/format.c file f2c/src/format.h @@ -116,8 +103,6 @@ file f2c/src/put.c file f2c/src/putpcc.c -file f2c/src/readme - file f2c/src/sysdep.c file f2c/src/sysdep.h @@ -133,3 +118,10 @@ file f2c/src/version.c file f2c/src/xsum.c file f2c/src/xsum0.out + +file f2c/src/Notice + +file f2c/src/README + +file f2c/src/readme + diff --git a/usr.bin/f2c/index.html b/usr.bin/f2c/index.html index f93c66cc8f65c..2265f2ab1064b 100644 --- a/usr.bin/f2c/index.html +++ b/usr.bin/f2c/index.html @@ -1,11 +1,10 @@ -f2c/src/index