diff options
author | David E. O'Brien <obrien@FreeBSD.org> | 1999-08-08 17:08:30 +0000 |
---|---|---|
committer | David E. O'Brien <obrien@FreeBSD.org> | 1999-08-08 17:08:30 +0000 |
commit | ca08704ee4929297a1609b86d701b0d7655bef97 (patch) | |
tree | d02e080e520e6b8429e6f2156c0026742febe266 /usr.bin | |
parent | 5f3136d4ea1a441e2d585e261756991212bb057c (diff) | |
download | src-ca08704ee4929297a1609b86d701b0d7655bef97.tar.gz src-ca08704ee4929297a1609b86d701b0d7655bef97.zip |
Remove f2c as its libraries were tossed last April, and f2c has been replaced
with EGCS's f77.
Noticed still alive by: bde
Notes
Notes:
svn path=/head/; revision=49531
Diffstat (limited to 'usr.bin')
54 files changed, 0 insertions, 31525 deletions
diff --git a/usr.bin/f2c/Makefile b/usr.bin/f2c/Makefile deleted file mode 100644 index b71191626c5e..000000000000 --- a/usr.bin/f2c/Makefile +++ /dev/null @@ -1,35 +0,0 @@ -# Makefile for f2c, a Fortran 77 to C converter - -PROG= f2c - -CFLAGS += -DANSI_Libraries -I${.CURDIR} -I. -SHELL = /bin/sh - -SRCSd = main.c init.c gram.c lex.c proc.c equiv.c data.c format.c \ - expr.c exec.c intr.c io.c misc.c error.c mem.c names.c \ - output.c p1output.c pread.c put.c putpcc.c vax.c formatdata.c \ - parse_args.c niceprintf.c cds.c sysdep.c version.c -SRCS = $(SRCSd) tokdefs.h # malloc.c - -GRAMFILES = ${.CURDIR}/gram.head ${.CURDIR}/gram.dcl ${.CURDIR}/gram.expr\ - ${.CURDIR}/gram.exec ${.CURDIR}/gram.io - -gram.c: ${GRAMFILES} ${.CURDIR}/defs.h tokdefs.h - (sed < tokdefs.h "s/#define/%token/" ; \ - cat ${GRAMFILES}) > gram.in - $(YACC) $(YFLAGS) gram.in - echo "# expect 4 shift/reduce conflicts" - sed 's/^# line.*/\/* & *\//' y.tab.c >gram.c - rm -f gram.in y.tab.c - -tokdefs.h: ${.CURDIR}/tokens - grep -n . <${.CURDIR}/tokens | sed "s/\([^:]*\):\(.*\)/#define \2 \1/" >tokdefs.h - -CLEANFILES+=\ - gram.c tokdefs.h y.tab.h - -beforeinstall: - ${INSTALL} -C -o ${BINOWN} -g ${BINGRP} -m 444 ${.CURDIR}/f2c.h \ - ${DESTDIR}/usr/include - -.include <bsd.prog.mk> diff --git a/usr.bin/f2c/Notice b/usr.bin/f2c/Notice deleted file mode 100644 index 261b719bc57e..000000000000 --- a/usr.bin/f2c/Notice +++ /dev/null @@ -1,23 +0,0 @@ -/**************************************************************** -Copyright 1990 - 1997 by AT&T, Lucent Technologies and Bellcore. - -Permission to use, copy, modify, and distribute this software -and its documentation for any purpose and without fee is hereby -granted, provided that the above copyright notice appear in all -copies and that both that the copyright notice and this -permission notice and warranty disclaimer appear in supporting -documentation, and that the names of AT&T, Bell Laboratories, -Lucent or Bellcore or any of their entities not be used in -advertising or publicity pertaining to distribution of the -software without specific, written prior permission. - -AT&T, Lucent and Bellcore disclaim all warranties with regard to -this software, including all implied warranties of -merchantability and fitness. In no event shall AT&T, Lucent or -Bellcore be liable for any special, indirect or consequential -damages or any damages whatsoever resulting from loss of use, -data or profits, whether in an action of contract, negligence or -other tortious action, arising out of or in connection with the -use or performance of this software. -****************************************************************/ - diff --git a/usr.bin/f2c/README b/usr.bin/f2c/README deleted file mode 100644 index 6b0d2b2cfc29..000000000000 --- a/usr.bin/f2c/README +++ /dev/null @@ -1,174 +0,0 @@ -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 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". - -If (in accordance with what follows) you need to any of the source -files (excluding the makefile), first issue a "make xsum.out" (or, if -appropriate, "make xsumr.out") to check the validity of the f2c source, -then make your changes, then type "make f2c". - -The file usignal.h is for the benefit of strictly ANSI include files -on a UNIX system -- the ANSI signal.h does not define SIGHUP or SIGQUIT. -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 -(e.g., netlib@netlib.bell-labs.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.bell-labs.com; for more -details, ask netlib@netlib.bell-labs.com to "send readme from f2c". - -On some systems, the malloc and free in malloc.c let f2c run faster -than do the standard malloc and free. Other systems may not tolerate -redefinition of malloc and free (though changes of 8 Nov. 1994 may -render this less of a problem than hitherto). If your system permits -use of a user-supplied malloc, you may wish to change the MALLOC = -line in the makefile to "MALLOC = malloc.o", or to type - make MALLOC=malloc.o -instead of - make -Still other systems have a -lmalloc that provides performance -competitive with that from malloc.c; you may wish to compare the two -on your system. If your system does not permit user-supplied malloc -routines, then f2c may fault with "MALLOC=malloc.o", or may display -other untoward behavior. - -On some BSD systems, you may need to create a file named "string.h" -whose single line is -#include <strings.h> -you may need to add " -Dstrchr=index" to the "CFLAGS =" assignment -in the makefile, and you may need to add " memset.o" to the "OBJECTS =" -assignment in the makefile -- see the comments in memset.c . - -For non-UNIX systems, you may need to change some things in sysdep.c, -such as the choice of intermediate file names. - -On some systems, you may need to modify parts of sysdep.h (which is -included by defs.h). In particular, for Sun 4.1 systems and perhaps -some others, you need to comment out the typedef of size_t. For some -systems (e.g., IRIX 4.0.1 and AIX) it is better to add -#define ANSI_Libraries -to the beginning of sysdep.h (or to supply -DANSI_Libraries in the -makefile). - -Alas, some systems #define __STDC__ but do not provide a true standard -(ANSI or ISO) C environment, e.g. do not provide stdlib.h . If yours -is such a system, then (a) you should complain loudly to your vendor -about __STDC__ being erroneously defined, and (b) you should insert -#undef __STDC__ -at the beginning of sysdep.h . You may need to make other adjustments. - -For some non-ANSI versions of stdio, you must change the values given -to binread and binwrite in sysdep.c from "rb" and "wb" to "r" and "w". -You may need to make this change if you run f2c and get an error -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 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 . - -In general, under Linux it is necessary to compile libI77 with --DNON_UNIX_STDIO . Under at least one variant of Linux, you can make -and install a shared-library version of libf2c by compiling libI77 -with -DNON_UNIX_STDIO, creating libf2c.a as above, and then executing - - mkdir t - ln lib?77/*.o t - cd t; cc -shared -o ../libf2c.so -Wl,-soname,libf2c.so.1 *.o - cd .. - rm -r t - rm /usr/lib/libf2c* - mv libf2c.a libf2c.so /usr/lib - cd /usr/lib - ln libf2c.so libf2c.so.1 - ln libf2c.so libf2c.so.1.0.0 - -On some other systems, /usr/local/lib is the appropriate installation -directory. - - -Some older C compilers object to - typedef void (*foo)(); -or to - typedef void zap; - zap (*foo)(); -If yours is such a compiler, change the definition of VOID in -f2c.h from void to int. - -For convenience with systems that use control-Z to denote end-of-file, -f2c treats control-Z characters (ASCII 26, '\x1a') that appear at the -beginning of a line as an end-of-file indicator. You can disable this -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@netlib.bell-labs.com (or use anonymous ftp from -netlib.bell-labs.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. - -File mem.c has #ifdef CRAY lines that are appropriate for machines -with the conventional CRAY architecture, but not for "Cray" machines -based on DEC Alpha chips, such as the T3E; on such machines, you may -need to make a suitable adjustment, e.g., add #undef CRAY to sysdep.h. - - -Please send bug reports to dmg@bell-labs.com . The old index file -(now called "readme" due to unfortunate changes in netlib conventions: -"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. Changes first appear on netlib@netlib.bell-labs.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 deleted file mode 100644 index e5bacaafc837..000000000000 --- a/usr.bin/f2c/cds.c +++ /dev/null @@ -1,195 +0,0 @@ -/**************************************************************** -Copyright 1990, 1993, 1994 by AT&T, Lucent Technologies and Bellcore. - -Permission to use, copy, modify, and distribute this software -and its documentation for any purpose and without fee is hereby -granted, provided that the above copyright notice appear in all -copies and that both that the copyright notice and this -permission notice and warranty disclaimer appear in supporting -documentation, and that the names of AT&T, Bell Laboratories, -Lucent or Bellcore or any of their entities not be used in -advertising or publicity pertaining to distribution of the -software without specific, written prior permission. - -AT&T, Lucent and Bellcore disclaim all warranties with regard to -this software, including all implied warranties of -merchantability and fitness. In no event shall AT&T, Lucent or -Bellcore be liable for any special, indirect or consequential -damages or any damages whatsoever resulting from loss of use, -data or profits, whether in an action of contract, negligence or -other tortious action, arising out of or in connection with the -use or performance of this software. -****************************************************************/ - -/* Put strings representing decimal floating-point numbers - * into canonical form: always have a decimal point or - * exponent field; if using an exponent field, have the - * number before it start with a digit and decimal point - * (if the number has more than one digit); only have an - * exponent field if it saves space. - * - * Arrange that the return value, rv, satisfies rv[0] == '-' || rv[-1] == '-' . - */ - -#include "defs.h" - - char * -#ifdef KR_headers -cds(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; - char ebuf[24]; - long ex = 0; - static char etype[Table_size], *db; - static int dblen = 64; - - if (!db) { - etype['E'] = 1; - etype['e'] = 1; - etype['D'] = 1; - etype['d'] = 1; - etype['+'] = 2; - etype['-'] = 3; - db = Alloc(dblen); - } - - while((c = *s++) == '0'); - if (c == '-') - { sign = 1; c = *s++; } - else if (c == '+') - c = *s++; - k = strlen(s) + 2; - if (k >= dblen) { - do dblen <<= 1; - while(k >= dblen); - free(db); - db = Alloc(dblen); - } - if (etype[(unsigned char)c] >= 2) - while(c == '0') c = *s++; - tz = 0; - while(c >= '0' && c <= '9') { - if (c == '0') - tz++; - else { - if (nd) - for(; tz; --tz) - db[nd++] = '0'; - else - tz = 0; - db[nd++] = c; - } - c = *s++; - } - ea = -tz; - if (c == '.') { - while((c = *s++) >= '0' && c <= '9') { - if (c == '0') - tz++; - else { - if (tz) { - ea += tz; - if (nd) - for(; tz; --tz) - db[nd++] = '0'; - else - tz = 0; - } - db[nd++] = c; - ea++; - } - } - } - if (et = etype[(unsigned char)c]) { - esign = et == 3; - c = *s++; - if (et == 1) { - if(etype[(unsigned char)c] > 1) { - if (c == '-') - esign = 1; - c = *s++; - } - } - while(c >= '0' && c <= '9') { - ex = 10*ex + (c - '0'); - c = *s++; - } - if (esign) - ex = -ex; - } - switch(c) { - case 0: - break; -#ifndef VAX - case 'i': - case 'I': - Fatal("Overflow evaluating constant expression."); - case 'n': - case 'N': - Fatal("Constant expression yields NaN."); -#endif - default: - Fatal("unexpected character in cds."); - } - ex -= ea; - if (!nd) { - if (!z0) - z0 = mem(4,0); - strcpy(z0, "-0."); - sign = 0; - } - else if (ex > 2 || ex + nd < -2) { - sprintf(ebuf, "%ld", ex + nd - 1); - k = strlen(ebuf) + nd + 3; - if (nd > 1) - k++; - if (!z0) - z0 = mem(k,0); - z = z0; - *z++ = '-'; - *z++ = *db; - if (nd > 1) { - *z++ = '.'; - for(k = 1; k < nd; k++) - *z++ = db[k]; - } - *z++ = 'e'; - strcpy(z, ebuf); - } - else { - k = (int)(ex + nd); - i = nd + 3; - if (k < 0) - i -= k; - else if (ex > 0) - i += ex; - if (!z0) - z0 = mem(i,0); - z = z0; - *z++ = '-'; - if (ex >= 0) { - for(k = 0; k < nd; k++) - *z++ = db[k]; - while(--ex >= 0) - *z++ = '0'; - *z++ = '.'; - } - else { - for(i = 0; i < k;) - *z++ = db[i++]; - *z++ = '.'; - while(++k <= 0) - *z++ = '0'; - while(i < nd) - *z++ = db[i++]; - } - *z = 0; - } - return sign ? z0 : z0+1; - } diff --git a/usr.bin/f2c/data.c b/usr.bin/f2c/data.c deleted file mode 100644 index 74540399a2bc..000000000000 --- a/usr.bin/f2c/data.c +++ /dev/null @@ -1,493 +0,0 @@ -/**************************************************************** -Copyright 1990, 1993 - 1996 by AT&T, Lucent Technologies and Bellcore. - -Permission to use, copy, modify, and distribute this software -and its documentation for any purpose and without fee is hereby -granted, provided that the above copyright notice appear in all -copies and that both that the copyright notice and this -permission notice and warranty disclaimer appear in supporting -documentation, and that the names of AT&T, Bell Laboratories, -Lucent or Bellcore or any of their entities not be used in -advertising or publicity pertaining to distribution of the -software without specific, written prior permission. - -AT&T, Lucent and Bellcore disclaim all warranties with regard to -this software, including all implied warranties of -merchantability and fitness. In no event shall AT&T, Lucent or -Bellcore be liable for any special, indirect or consequential -damages or any damages whatsoever resulting from loss of use, -data or profits, whether in an action of contract, negligence or -other tortious action, arising out of or in connection with the -use or performance of this software. -****************************************************************/ - -#include "defs.h" - -/* ROUTINES CALLED DURING DATA AND PARAMETER STATEMENT PROCESSING */ - -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; - register expptr valp; -#else -dataval(register expptr repp, register expptr valp) -#endif -{ - int i, nrep; - ftnint elen; - register Addrp p; - - if (parstate < INDATA) { - frexpr(repp); - goto ret; - } - if(repp == NULL) - nrep = 1; - else if (ISICON(repp) && repp->constblock.Const.ci >= 0) - nrep = repp->constblock.Const.ci; - else - { - err("invalid repetition count in DATA statement"); - frexpr(repp); - goto ret; - } - frexpr(repp); - - 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) - { - p = nextdata(&elen); - if(p == NULL) - { - if (lineno != err_lineno) - err("too many initializers"); - toomanyinit = YES; - goto ret; - } - setdata((Addrp)p, (Constp)valp, elen); - frexpr((expptr)p); - } - -ret: - frexpr(valp); -} - - - Addrp -#ifdef KR_headers -nextdata(elenp) - ftnint *elenp; -#else -nextdata(ftnint *elenp) -#endif -{ - register struct Impldoblock *ip; - struct Primblock *pp; - register Namep np; - register struct Rplblock *rp; - tagptr p; - expptr neltp; - register expptr q; - int skip; - ftnint off, vlen; - - while(curdtp) - { - p = (tagptr)curdtp->datap; - if(p->tag == TIMPLDO) - { - ip = &(p->impldoblock); - if(ip->implb==NULL || ip->impub==NULL || ip->varnp==NULL) - fatali("bad impldoblock 0%o", (int) ip); - if(ip->isactive) - ip->varvp->Const.ci += ip->impdiff; - else - { - q = fixtype(cpexpr(ip->implb)); - if( ! ISICON(q) ) - goto doerr; - ip->varvp = (Constp) q; - - if(ip->impstep) - { - q = fixtype(cpexpr(ip->impstep)); - if( ! ISICON(q) ) - goto doerr; - ip->impdiff = q->constblock.Const.ci; - frexpr(q); - } - else - ip->impdiff = 1; - - q = fixtype(cpexpr(ip->impub)); - if(! ISICON(q)) - goto doerr; - ip->implim = q->constblock.Const.ci; - frexpr(q); - - ip->isactive = YES; - rp = ALLOC(Rplblock); - rp->rplnextp = rpllist; - rpllist = rp; - rp->rplnp = ip->varnp; - rp->rplvp = (expptr) (ip->varvp); - rp->rpltag = TCONST; - } - - if( (ip->impdiff>0 && (ip->varvp->Const.ci <= ip->implim)) - || (ip->impdiff<0 && (ip->varvp->Const.ci >= ip->implim)) ) - { /* start new loop */ - curdtp = ip->datalist; - goto next; - } - - /* clean up loop */ - - if(rpllist) - { - rp = rpllist; - rpllist = rpllist->rplnextp; - free( (charptr) rp); - } - else - Fatal("rpllist empty"); - - frexpr((expptr)ip->varvp); - ip->isactive = NO; - curdtp = curdtp->nextp; - goto next; - } - - pp = (struct Primblock *) p; - np = pp->namep; - cur_varname = np->fvarname; - skip = YES; - - if(p->primblock.argsp==NULL && np->vdim!=NULL) - { /* array initialization */ - q = (expptr) mkaddr(np); - off = typesize[np->vtype] * curdtelt; - if(np->vtype == TYCHAR) - off *= np->vleng->constblock.Const.ci; - q->addrblock.memoffset = - mkexpr(OPPLUS, q->addrblock.memoffset, mkintcon(off) ); - if( (neltp = np->vdim->nelt) && ISCONST(neltp)) - { - if(++curdtelt < neltp->constblock.Const.ci) - skip = NO; - } - else - err("attempt to initialize adjustable array"); - } - else - q = mklhs((struct Primblock *)cpexpr((expptr)pp), 0); - if(skip) - { - curdtp = curdtp->nextp; - curdtelt = 0; - } - if(q->headblock.vtype == TYCHAR) - if(ISICON(q->headblock.vleng)) - *elenp = q->headblock.vleng->constblock.Const.ci; - else { - err("initialization of string of nonconstant length"); - continue; - } - else *elenp = typesize[q->headblock.vtype]; - - if (np->vstg == STGBSS) { - vlen = np->vtype==TYCHAR - ? np->vleng->constblock.Const.ci - : typesize[np->vtype]; - if(vlen > 0) - np->vstg = STGINIT; - } - return( (Addrp) q ); - -doerr: - err("nonconstant implied DO parameter"); - frexpr(q); - curdtp = curdtp->nextp; - -next: - curdtelt = 0; - } - - return(NULL); -} - - - -LOCAL FILEP dfile; - - void -#ifdef KR_headers -setdata(varp, valp, elen) - 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 *varname; - static Addrp badvar; - register unsigned char *s; - static int last_lineno; - static char *last_varname; - - if (varp->vstg == STGCOMMON) { - if (!(dfile = blkdfile)) - dfile = blkdfile = opf(blkdfname, textwrite); - } - else { - if (procclass == CLBLOCK) { - if (varp != badvar) { - badvar = varp; - warn1("%s is not in a COMMON block", - varp->uname_tag == UNAM_NAME - ? varp->user.name->fvarname - : "???"); - } - return; - } - if (!(dfile = initfile)) - dfile = initfile = opf(initfname, textwrite); - } - varname = dataname(varp->vstg, varp->memno); - offset = varp->memoffset->constblock.Const.ci; - type = varp->vtype; - valtype = valp->vtype; - if(type!=TYCHAR && valtype==TYCHAR) - { - if(! ftn66flag - && (last_varname != cur_varname || last_lineno != lineno)) { - /* prevent multiple warnings */ - last_lineno = lineno; - warn1( - "non-character datum %.42s initialized with character string", - last_varname = cur_varname); - } - varp->vleng = ICON(typesize[type]); - varp->vtype = type = TYCHAR; - } - else if( (type==TYCHAR && valtype!=TYCHAR) || - (cktype(OPASSIGN,type,valtype) == TYERROR) ) - { - err("incompatible types in initialization"); - return; - } - if(type == TYADDR) - con.Const.ci = valp->Const.ci; - else if(type != TYCHAR) - { - if(valtype == TYUNKNOWN) - con.Const.ci = valp->Const.ci; - else consconv(type, &con, valp); - } - - k = 1; - - switch(type) - { - case TYLOGICAL: - case TYINT1: - case TYLOGICAL1: - case TYLOGICAL2: - case TYSHORT: - case TYLONG: -#ifdef TYQUAD - case TYQUAD: -#endif - dataline(varname, offset, type); - prconi(dfile, con.Const.ci); - break; - - case TYADDR: - dataline(varname, offset, type); - prcona(dfile, con.Const.ci); - break; - - case TYCOMPLEX: - case TYDCOMPLEX: - k = 2; - case TYREAL: - case TYDREAL: - dataline(varname, offset, type); - prconr(dfile, &con, k); - break; - - case TYCHAR: - k = valp -> vleng -> constblock.Const.ci; - if (elen < k) - k = elen; - s = (unsigned char *)valp->Const.ccp; - for(i = 0 ; i < k ; ++i) { - dataline(varname, offset++, TYCHAR); - fprintf(dfile, "\t%d\n", *s++); - } - k = elen - valp->vleng->constblock.Const.ci; - if(k > 0) { - dataline(varname, offset, TYBLANK); - fprintf(dfile, "\t%d\n", k); - } - break; - - default: - badtype("setdata", type); - } - -} - - - -/* - output form of name is padded with blanks and preceded - with a storage class digit -*/ - 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]; - - if (stg == STGCOMMON) { - varname[0] = '2'; - sprintf(s = buf, "Q.%ld", memno); - } - else { - varname[0] = stg==STGEQUIV ? '1' : '0'; - s = memname(stg, memno); - } - t = varname + 1; - while(*t++ = *s++); - *t = 0; - return(varname); -} - - - - - void -#ifdef KR_headers -frdata(p0) - chainp p0; -#else -frdata(chainp p0) -#endif -{ - register struct Chain *p; - register tagptr q; - - for(p = p0 ; p ; p = p->nextp) - { - q = (tagptr)p->datap; - if(q->tag == TIMPLDO) - { - if(q->impldoblock.isbusy) - return; /* circular chain completed */ - q->impldoblock.isbusy = YES; - frdata(q->impldoblock.datalist); - free( (charptr) q); - } - else - frexpr(q); - } - - frchain( &p0); -} - - - void -#ifdef KR_headers -dataline(varname, offset, 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; -#else -make_param(register struct Paramblock *p, expptr e) -#endif -{ - register expptr q; - Constp 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((Exprp)q); - if (q->tag == TADDR && q->addrblock.uname_tag == UNAM_CONST) { - qc = mkconst(TYCHAR); - qc->Const = q->addrblock.user.Const; - qc->vleng = q->addrblock.vleng; - q->addrblock.vleng = 0; - frexpr(q); - p->paramval = q = (expptr)qc; - } - if (!ISCONST(q) || q->constblock.vtype != TYCHAR) { - errstr("invalid value for character parameter %s", - p->fvarname); - return; - } - if (!(e = p->vleng)) - p->vleng = ICON(q->constblock.vleng->constblock.Const.ci - + q->constblock.Const.ccp1.blanks); - else if (q->constblock.vleng->constblock.Const.ci - > e->constblock.Const.ci) { - q->constblock.vleng->constblock.Const.ci - = e->constblock.Const.ci; - q->constblock.Const.ccp1.blanks = 0; - } - else - q->constblock.Const.ccp1.blanks - = e->constblock.Const.ci - - q->constblock.vleng->constblock.Const.ci; - } - } diff --git a/usr.bin/f2c/defines.h b/usr.bin/f2c/defines.h deleted file mode 100644 index 1ed4537eecab..000000000000 --- a/usr.bin/f2c/defines.h +++ /dev/null @@ -1,300 +0,0 @@ -#define PDP11 4 - -#define BIGGEST_CHAR 0x7f /* Assumes 32-bit arithmetic */ -#define BIGGEST_SHORT 0x7fff /* Assumes 32-bit arithmetic */ -#define BIGGEST_LONG 0x7fffffff /* Assumes 32-bit arithmetic */ - -#define M(x) (1<<x) /* Mask (x) returns 2^x */ - -#define ALLOC(x) (struct x *) ckalloc((int)sizeof(struct x)) -#define ALLEXPR (expptr) ckalloc((int)sizeof(union Expression) ) -typedef int *ptr; -typedef char *charptr; -typedef FILE *FILEP; -typedef int flag; -typedef char field; /* actually need only 4 bits */ -typedef long int ftnint; -#define LOCAL static - -#define NO 0 -#define YES 1 - -#define CNULL (char *) 0 /* Character string null */ -#define PNULL (ptr) 0 -#define CHNULL (chainp) 0 /* Chain null */ -#define ENULL (expptr) 0 - - -/* BAD_MEMNO - used to distinguish between long string constants and other - constants in the table */ - -#define BAD_MEMNO -32768 - - -/* block tag values -- syntactic stuff */ - -#define TNAME 1 -#define TCONST 2 -#define TEXPR 3 -#define TADDR 4 -#define TPRIM 5 /* Primitive datum - should not appear in an - expptr variable, it should have already been - identified */ -#define TLIST 6 -#define TIMPLDO 7 -#define TERROR 8 - - -/* parser states - order is important, since there are several tests for - state < INDATA */ - -#define OUTSIDE 0 -#define INSIDE 1 -#define INDCL 2 -#define INDATA 3 -#define INEXEC 4 - -/* procedure classes */ - -#define PROCMAIN 1 -#define PROCBLOCK 2 -#define PROCSUBR 3 -#define PROCFUNCT 4 - - -/* storage classes -- vstg values. BSS and INIT are used in the later - merge pass over identifiers; and they are entered differently into the - symbol table */ - -#define STGUNKNOWN 0 -#define STGARG 1 /* adjustable dimensions */ -#define STGAUTO 2 /* for stack references */ -#define STGBSS 3 /* uninitialized storage (normal variables) */ -#define STGINIT 4 /* initialized storage */ -#define STGCONST 5 -#define STGEXT 6 /* external storage */ -#define STGINTR 7 /* intrinsic (late decision) reference. See - chapter 5 of the Fortran 77 standard */ -#define STGSTFUNCT 8 -#define STGCOMMON 9 -#define STGEQUIV 10 -#define STGREG 11 /* register - the outermost DO loop index will be - in a register (because the compiler is one - pass, it can't know where the innermost loop is - */ -#define STGLENG 12 -#define STGNULL 13 -#define STGMEMNO 14 /* interemediate-file pointer to constant table */ - -/* name classes -- vclass values, also procclass values */ - -#define CLUNKNOWN 0 -#define CLPARAM 1 /* Parameter - macro definition */ -#define CLVAR 2 /* variable */ -#define CLENTRY 3 -#define CLMAIN 4 -#define CLBLOCK 5 -#define CLPROC 6 -#define CLNAMELIST 7 /* in data with this tag, the vdcldone flag should - be ignored (according to vardcl()) */ - - -/* vprocclass values -- there is some overlap with the vclass values given - above */ - -#define PUNKNOWN 0 -#define PEXTERNAL 1 -#define PINTRINSIC 2 -#define PSTFUNCT 3 -#define PTHISPROC 4 /* here to allow recursion - further distinction - is given in the CL tag (those just above). - This applies to the presence of the name of a - function used within itself. The function name - means either call the function again, or assign - some value to the storage allocated to the - function's return value. */ - -/* control stack codes - these are part of a state machine which handles - the nesting of blocks (i.e. what to do about the ELSE statement) */ - -#define CTLDO 1 -#define CTLIF 2 -#define CTLELSE 3 -#define CTLIFX 4 - - -/* operators for both Fortran input and C output. They are common because - so many are shared between the trees */ - -#define OPPLUS 1 -#define OPMINUS 2 -#define OPSTAR 3 -#define OPSLASH 4 -#define OPPOWER 5 -#define OPNEG 6 -#define OPOR 7 -#define OPAND 8 -#define OPEQV 9 -#define OPNEQV 10 -#define OPNOT 11 -#define OPCONCAT 12 -#define OPLT 13 -#define OPEQ 14 -#define OPGT 15 -#define OPLE 16 -#define OPNE 17 -#define OPGE 18 -#define OPCALL 19 -#define OPCCALL 20 -#define OPASSIGN 21 -#define OPPLUSEQ 22 -#define OPSTAREQ 23 -#define OPCONV 24 -#define OPLSHIFT 25 -#define OPMOD 26 -#define OPCOMMA 27 -#define OPQUEST 28 -#define OPCOLON 29 -#define OPABS 30 -#define OPMIN 31 -#define OPMAX 32 -#define OPADDR 33 -#define OPCOMMA_ARG 34 -#define OPBITOR 35 -#define OPBITAND 36 -#define OPBITXOR 37 -#define OPBITNOT 38 -#define OPRSHIFT 39 -#define OPWHATSIN 40 /* dereferencing operator */ -#define OPMINUSEQ 41 /* assignment operators */ -#define OPSLASHEQ 42 -#define OPMODEQ 43 -#define OPLSHIFTEQ 44 -#define OPRSHIFTEQ 45 -#define OPBITANDEQ 46 -#define OPBITXOREQ 47 -#define OPBITOREQ 48 -#define OPPREINC 49 /* Preincrement (++x) operator */ -#define OPPREDEC 50 /* Predecrement (--x) operator */ -#define OPDOT 51 /* structure field reference */ -#define OPARROW 52 /* structure pointer field reference */ -#define OPNEG1 53 /* simple negation under forcedouble */ -#define OPDMIN 54 /* min(a,b) macro under forcedouble */ -#define OPDMAX 55 /* max(a,b) macro under forcedouble */ -#define OPASSIGNI 56 /* assignment for inquire stmt */ -#define OPIDENTITY 57 /* for turning TADDR into TEXPR */ -#define OPCHARCAST 58 /* for casting to char * (in I/O stmts) */ -#define OPDABS 59 /* abs macro under forcedouble */ -#define OPMIN2 60 /* min(a,b) macro */ -#define OPMAX2 61 /* max(a,b) macro */ -#define OPBITTEST 62 /* btest */ -#define OPBITCLR 63 /* ibclr */ -#define OPBITSET 64 /* ibset */ -#define OPQBITCLR 65 /* ibclr, integer*8 */ -#define OPQBITSET 66 /* ibset, integer*8 */ -#define OPBITBITS 67 /* ibits */ -#define OPBITSH 68 /* ishft */ -#define OPBITSHC 69 /* ishftc */ - -/* label type codes -- used with the ASSIGN statement */ - -#define LABUNKNOWN 0 -#define LABEXEC 1 -#define LABFORMAT 2 -#define LABOTHER 3 - - -/* INTRINSIC function codes*/ - -#define INTREND 0 -#define INTRCONV 1 -#define INTRMIN 2 -#define INTRMAX 3 -#define INTRGEN 4 /* General intrinsic, e.g. cos v. dcos, zcos, ccos */ -#define INTRSPEC 5 -#define INTRBOOL 6 -#define INTRCNST 7 /* constants, e.g. bigint(1.0) v. bigint (1d0) */ -#define INTRBGEN 8 /* bit manipulation */ - - -/* I/O statement codes - these all form Integer Constants, and are always - reevaluated */ - -#define IOSTDIN ICON(5) -#define IOSTDOUT ICON(6) -#define IOSTDERR ICON(0) - -#define IOSBAD (-1) -#define IOSPOSITIONAL 0 -#define IOSUNIT 1 -#define IOSFMT 2 - -#define IOINQUIRE 1 -#define IOOPEN 2 -#define IOCLOSE 3 -#define IOREWIND 4 -#define IOBACKSPACE 5 -#define IOENDFILE 6 -#define IOREAD 7 -#define IOWRITE 8 - - -/* User name tags -- these identify the form of the original identifier - stored in a struct Addrblock structure (in the user field). */ - -#define UNAM_UNKNOWN 0 /* Not specified */ -#define UNAM_NAME 1 /* Local symbol, store in the hash table */ -#define UNAM_IDENT 2 /* Character string not stored elsewhere */ -#define UNAM_EXTERN 3 /* External reference; check symbol table - using memno as index */ -#define UNAM_CONST 4 /* Constant value */ -#define UNAM_CHARP 5 /* pointer to string */ -#define UNAM_REF 6 /* subscript reference with -s */ - - -#define IDENT_LEN 31 /* Maximum length user.ident */ -#define MAXNAMELEN 50 /* Maximum Fortran name length */ - -/* type masks - TYLOGICAL defined in ftypes */ - -#define MSKLOGICAL M(TYLOGICAL)|M(TYLOGICAL1)|M(TYLOGICAL2) -#define MSKADDR M(TYADDR) -#define MSKCHAR M(TYCHAR) -#ifdef TYQUAD -#define MSKINT M(TYINT1)|M(TYSHORT)|M(TYLONG)|M(TYQUAD) -#else -#define MSKINT M(TYINT1)|M(TYSHORT)|M(TYLONG) -#endif -#define MSKREAL M(TYREAL)|M(TYDREAL) /* DREAL means Double Real */ -#define MSKCOMPLEX M(TYCOMPLEX)|M(TYDCOMPLEX) -#define MSKSTATIC (M(STGINIT)|M(STGBSS)|M(STGCOMMON)|M(STGEQUIV)|M(STGCONST)) - -/* miscellaneous macros */ - -/* ONEOF (x, y) -- x is the number of one of the OR'ed masks in y (i.e., x is - the log of one of the OR'ed masks in y) */ - -#define ONEOF(x,y) (M(x) & (y)) -#define ISCOMPLEX(z) ONEOF(z, MSKCOMPLEX) -#define ISREAL(z) ONEOF(z, MSKREAL) -#define ISNUMERIC(z) ONEOF(z, MSKINT|MSKREAL|MSKCOMPLEX) -#define ISICON(z) (z->tag==TCONST && ISINT(z->constblock.vtype)) -#define ISLOGICAL(z) ONEOF(z, MSKLOGICAL) - -/* ISCHAR assumes that z has some kind of structure, i.e. is not null */ - -#define ISCHAR(z) (z->headblock.vtype==TYCHAR) -#define ISINT(z) ONEOF(z, MSKINT) /* z is a tag, i.e. a mask number */ -#define ISCONST(z) (z->tag==TCONST) -#define ISERROR(z) (z->tag==TERROR) -#define ISPLUSOP(z) (z->tag==TEXPR && z->exprblock.opcode==OPPLUS) -#define ISSTAROP(z) (z->tag==TEXPR && z->exprblock.opcode==OPSTAR) -#define ISONE(z) (ISICON(z) && z->constblock.Const.ci==1) -#define INT(z) ONEOF(z, MSKINT|MSKCHAR) /* has INT storage in real life */ -#define ICON(z) mkintcon( (ftnint)(z) ) - -/* NO66 -- F77 feature is being used - NOEXT -- F77 extension is being used */ - -#define NO66(s) if(no66flag) err66(s) -#define NOEXT(s) if(noextflag) errext(s) diff --git a/usr.bin/f2c/defs.h b/usr.bin/f2c/defs.h deleted file mode 100644 index 2d80862c6399..000000000000 --- a/usr.bin/f2c/defs.h +++ /dev/null @@ -1,1055 +0,0 @@ -/**************************************************************** -Copyright 1990 - 1996 by AT&T, Lucent Technologies and Bellcore. - -Permission to use, copy, modify, and distribute this software -and its documentation for any purpose and without fee is hereby -granted, provided that the above copyright notice appear in all -copies and that both that the copyright notice and this -permission notice and warranty disclaimer appear in supporting -documentation, and that the names of AT&T, Bell Laboratories, -Lucent or Bellcore or any of their entities not be used in -advertising or publicity pertaining to distribution of the -software without specific, written prior permission. - -AT&T, Lucent and Bellcore disclaim all warranties with regard to -this software, including all implied warranties of -merchantability and fitness. In no event shall AT&T, Lucent or -Bellcore be liable for any special, indirect or consequential -damages or any damages whatsoever resulting from loss of use, -data or profits, whether in an action of contract, negligence or -other tortious action, arising out of or in connection with the -use or performance of this software. -****************************************************************/ - -#include "sysdep.h" - -#include "ftypes.h" -#include "defines.h" -#include "machdefs.h" - -#define MAXDIM 20 -#define MAXINCLUDES 10 -#define MAXLITERALS 200 /* Max number of constants in the literal - pool */ -#define MAXCTL 20 -#define MAXHASH 401 -#define MAXSTNO 801 -#define MAXEXT 200 -#define MAXEQUIV 150 -#define MAXLABLIST 258 /* Max number of labels in an alternate - return CALL or computed GOTO */ -#define MAXCONTIN 99 /* Max continuation lines */ - -/* These are the primary pointer types used in the compiler */ - -typedef union Expression *expptr, *tagptr; -typedef struct Chain *chainp; -typedef struct Addrblock *Addrp; -typedef struct Constblock *Constp; -typedef struct Exprblock *Exprp; -typedef struct Nameblock *Namep; - -extern FILEP infile; -extern FILEP diagfile; -extern FILEP textfile; -extern FILEP asmfile; -extern FILEP c_file; /* output file for all functions; extern - declarations will have to be prepended */ -extern FILEP pass1_file; /* Temp file to hold the function bodies - read on pass 1 */ -extern FILEP expr_file; /* Debugging file */ -extern FILEP initfile; /* Intermediate data file pointer */ -extern FILEP blkdfile; /* BLOCK DATA file */ - -extern int current_ftn_file; -extern int maxcontin; - -extern char *blkdfname, *initfname, *sortfname; -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 - block (at the top of the assembly file) - here */ - -extern char main_alias[]; /* name given to PROGRAM psuedo-op */ -extern char *token; -extern int maxtoklen, toklen; -extern long err_lineno, lineno; -extern char *infname; -extern int needkwd; -extern struct Labelblock *thislabel; - -/* Used to allow runtime expansion of internal tables. In particular, - these values can exceed their associated constants */ - -extern int maxctl; -extern int maxequiv; -extern int maxstno; -extern int maxhash; -extern int maxext; - -extern flag nowarnflag; -extern flag ftn66flag; /* Generate warnings when weird f77 - features are used (undeclared dummy - procedure, non-char initialized with - string, 1-dim subscript in EQUIV) */ -extern flag no66flag; /* Generate an error when a generic - function (f77 feature) is used */ -extern flag noextflag; /* Generate an error when an extension to - Fortran 77 is used (hex/oct/bin - constants, automatic, static, double - complex types) */ -extern flag zflag; /* enable double complex intrinsics */ -extern flag shiftcase; -extern flag undeftype; -extern flag shortsubs; /* Use short subscripts on arrays? */ -extern flag onetripflag; /* if true, always execute DO loop body */ -extern flag checksubs; -extern flag debugflag; -extern int nerr; -extern int nwarn; - -extern int parstate; -extern flag headerdone; /* True iff the current procedure's header - data has been written */ -extern int blklevel; -extern flag saveall; -extern flag substars; /* True iff some formal parameter is an - asterisk */ -extern int impltype[ ]; -extern ftnint implleng[ ]; -extern int implstg[ ]; - -extern int tycomplex, tyint, tyioint, tyreal; -extern int tylog, tylogical; /* TY____ of the implementation of logical. - This will be LONG unless '-2' is given - on the command line */ -extern int type_choice[]; -extern char *typename[]; - -extern int typesize[]; /* size (in bytes) of an object of each - type. Indexed by TY___ macros */ -extern int typealign[]; -extern int proctype; /* Type of return value in this procedure */ -extern char * procname; /* External name of the procedure, or last ENTRY name */ -extern int rtvlabel[ ]; /* Return value labels, indexed by TY___ macros */ -extern Addrp retslot; -extern Addrp xretslot[]; -extern int cxslot; /* Complex return argument slot (frame pointer offset)*/ -extern int chslot; /* Character return argument slot (fp offset) */ -extern int chlgslot; /* Argument slot for length of character buffer */ -extern int procclass; /* Class of the current procedure: either CLPROC, - CLMAIN, CLBLOCK or CLUNKNOWN */ -extern ftnint procleng; /* Length of function return value (e.g. char - string length). If this is -1, then the length is - not known at compile time */ -extern int nentry; /* Number of entry points (other than the original - function call) into this procedure */ -extern flag multitype; /* YES iff there is more than one return value - possible */ -extern int blklevel; -extern long lastiolabno; -extern long lastlabno; -extern int lastvarno; -extern int lastargslot; /* integer offset pointing to the next free - location for an argument to the current routine */ -extern int argloc; -extern int autonum[]; /* for numbering - automatic variables, e.g. temporaries */ -extern int retlabel; -extern int ret0label; -extern int dorange; /* Number of the label which terminates - the innermost DO loop */ -extern int regnum[ ]; /* Numbers of DO indicies named in - regnamep (below) */ -extern Namep regnamep[ ]; /* List of DO indicies in registers */ -extern int maxregvar; /* number of elts in regnamep */ -extern int highregvar; /* keeps track of the highest register - number used by DO index allocator */ -extern int nregvar; /* count of DO indicies in registers */ - -extern chainp templist[]; -extern int maxdim; -extern chainp earlylabs; -extern chainp holdtemps; -extern struct Entrypoint *entries; -extern struct Rplblock *rpllist; -extern struct Chain *curdtp; -extern ftnint curdtelt; -extern chainp allargs; /* union of args in entries */ -extern int nallargs; /* total number of args */ -extern int nallchargs; /* total number of character args */ -extern flag toomanyinit; /* True iff too many initializers in a - DATA statement */ - -extern flag inioctl; -extern int iostmt; -extern Addrp ioblkp; -extern int nioctl; -extern int nequiv; -extern int eqvstart; /* offset to eqv number to guarantee uniqueness - and prevent <something> from going negative */ -extern int nintnames; - -/* Chain of tagged blocks */ - -struct Chain - { - chainp nextp; - char * datap; /* Tagged block */ - }; - -extern chainp chains; - -/* Recall that field is intended to hold four-bit characters */ - -/* This structure exists only to defeat the type checking */ - -struct Headblock - { - field tag; - field vtype; - field vclass; - field vstg; - expptr vleng; /* Expression for length of char string - - this may be a constant, or an argument - generated by mkarg() */ - } ; - -/* Control construct info (for do loops, else, etc) */ - -struct Ctlframe - { - unsigned ctltype:8; - unsigned dostepsign:8; /* 0 - variable, 1 - pos, 2 - neg */ - unsigned dowhile:1; - int ctlabels[4]; /* Control labels, defined below */ - int dolabel; /* label marking end of this DO loop */ - Namep donamep; /* DO index variable */ - expptr doinit; /* for use with -onetrip */ - expptr domax; /* constant or temp variable holding MAX - loop value; or expr of while(expr) */ - expptr dostep; /* expression */ - Namep loopname; - }; -#define endlabel ctlabels[0] -#define elselabel ctlabels[1] -#define dobodylabel ctlabels[1] -#define doposlabel ctlabels[2] -#define doneglabel ctlabels[3] -extern struct Ctlframe *ctls; /* Keeps info on DO and BLOCK IF - structures - this is the stack - bottom */ -extern struct Ctlframe *ctlstack; /* Pointer to current nesting - level */ -extern struct Ctlframe *lastctl; /* Point to end of - dynamically-allocated array */ - -typedef struct { - int type; - chainp cp; - } Atype; - -typedef struct { - int defined, dnargs, nargs, changes; - Atype atypes[1]; - } Argtypes; - -/* External Symbols */ - -struct Extsym - { - char *fextname; /* Fortran version of external name */ - char *cextname; /* C version of external name */ - field extstg; /* STG -- should be COMMON, UNKNOWN or EXT - */ - unsigned extype:4; /* for transmitting type to output routines */ - unsigned used_here:1; /* Boolean - true on the second pass - through a function if the block has - been referenced */ - unsigned exused:1; /* Has been used (for help with error msgs - about externals typed differently in - different modules) */ - unsigned exproto:1; /* type specified in a .P file */ - unsigned extinit:1; /* Procedure has been defined, - or COMMON has DATA */ - unsigned extseen:1; /* True if previously referenced */ - chainp extp; /* List of identifiers in the common - block for this function, stored as - Namep (hash table pointers) */ - chainp allextp; /* List of lists of identifiers; we keep one - list for each layout of this common block */ - int curno; /* current number for this common block, - used for constructing appending _nnn - to the common block name */ - int maxno; /* highest curno value for this common block */ - ftnint extleng; - ftnint maxleng; - Argtypes *arginfo; - }; -typedef struct Extsym Extsym; - -extern Extsym *extsymtab; /* External symbol table */ -extern Extsym *nextext; -extern Extsym *lastext; -extern int complex_seen, dcomplex_seen; - -/* Statement labels */ - -struct Labelblock - { - int labelno; /* Internal label */ - unsigned blklevel:8; /* level of nesting, for branch-in-loop - checking */ - unsigned labused:1; - unsigned fmtlabused:1; - unsigned labinacc:1; /* inaccessible? (i.e. has its scope - vanished) */ - unsigned labdefined:1; /* YES or NO */ - unsigned labtype:2; /* LAB{FORMAT,EXEC,etc} */ - ftnint stateno; /* Original label */ - char *fmtstring; /* format string */ - }; - -extern struct Labelblock *labeltab; /* Label table - keeps track of - all labels, including undefined */ -extern struct Labelblock *labtabend; -extern struct Labelblock *highlabtab; - -/* Entry point list */ - -struct Entrypoint - { - struct Entrypoint *entnextp; - Extsym *entryname; /* Name of this ENTRY */ - chainp arglist; - int typelabel; /* Label for function exit; this - will return the proper type of - object */ - Namep enamep; /* External name */ - }; - -/* Primitive block, or Primary block. This is a general template returned - by the parser, which will be interpreted in context. It is a template - for an identifier (variable name, function name), parenthesized - arguments (array subscripts, function parameters) and substring - specifications. */ - -struct Primblock - { - field tag; - field vtype; - unsigned parenused:1; /* distinguish (a) from a */ - Namep namep; /* Pointer to structure Nameblock */ - struct Listblock *argsp; - expptr fcharp; /* first-char-index-pointer (in - substring) */ - expptr lcharp; /* last-char-index-pointer (in - substring) */ - }; - - -struct Hashentry - { - int hashval; - Namep varp; - }; -extern struct Hashentry *hashtab; /* Hash table */ -extern struct Hashentry *lasthash; - -struct Intrpacked /* bits for intrinsic function description */ - { - unsigned f1:4; - unsigned f2:4; - unsigned f3:7; - unsigned f4:1; - }; - -struct Nameblock - { - field tag; - field vtype; - field vclass; - field vstg; - expptr vleng; /* length of character string, if applicable */ - char *fvarname; /* name in the Fortran source */ - char *cvarname; /* name in the resulting C */ - chainp vlastdim; /* datap points to new_vars entry for the */ - /* system variable, if any, storing the final */ - /* dimension; we zero the datap if this */ - /* variable is needed */ - unsigned vprocclass:3; /* P____ macros - selects the varxptr - field below */ - unsigned vdovar:1; /* "is it a DO variable?" for register - and multi-level loop checking */ - unsigned vdcldone:1; /* "do I think I'm done?" - set when the - context is sufficient to determine its - status */ - unsigned vadjdim:1; /* "adjustable dimension?" - needed for - information about copies */ - unsigned vsave:1; - unsigned vimpldovar:1; /* used to prevent erroneous error messages - for variables used only in DATA stmt - implicit DOs */ - unsigned vis_assigned:1;/* True if this variable has had some - label ASSIGNED to it; hence - varxptr.assigned_values is valid */ - unsigned vimplstg:1; /* True if storage type is assigned implicitly; - this allows a COMMON variable to participate - in a DIMENSION before the COMMON declaration. - */ - unsigned vcommequiv:1; /* True if EQUIVALENCEd onto STGCOMMON */ - unsigned vfmt_asg:1; /* True if char *var_fmt needed */ - unsigned vpassed:1; /* True if passed as a character-variable arg */ - unsigned vknownarg:1; /* True if seen in a previous entry point */ - unsigned visused:1; /* True if variable is referenced -- so we */ - /* can omit variables that only appear in DATA */ - unsigned vnamelist:1; /* Appears in a NAMELIST */ - unsigned vimpltype:1; /* True if implicitly typed and not - invoked as a function or subroutine - (so we can consistently type procedures - declared external and passed as args - but never invoked). - */ - unsigned vtypewarned:1; /* so we complain just once about - changed types of external procedures */ - unsigned vinftype:1; /* so we can restore implicit type to a - procedure if it is invoked as a function - after being given a different type by -it */ - unsigned vinfproc:1; /* True if -it infers this to be a procedure */ - unsigned vcalled:1; /* has been invoked */ - unsigned vdimfinish:1; /* need to invoke dim_finish() */ - unsigned vrefused:1; /* Need to #define name_ref (for -s) */ - unsigned vsubscrused:1; /* Need to #define name_subscr (for -2) */ - unsigned veqvadjust:1; /* voffset has been adjusted for equivalence */ - -/* The vardesc union below is used to store the number of an intrinsic - function (when vstg == STGINTR and vprocclass == PINTRINSIC), or to - store the index of this external symbol in extsymtab (when vstg == - STGEXT and vprocclass == PEXTERNAL) */ - - union { - int varno; /* Return variable for a function. - This is used when a function is - assigned a return value. Also - used to point to the COMMON - block, when this is a field of - that block. Also points to - EQUIV block when STGEQUIV */ - struct Intrpacked intrdesc; /* bits for intrinsic function*/ - } vardesc; - struct Dimblock *vdim; /* points to the dimensions if they exist */ - ftnint voffset; /* offset in a storage block (the variable - name will be "v.%d", voffset in a - common blck on the vax). Also holds - pointers for automatic variables. When - STGEQUIV, this is -(offset from array - base) */ - union { - chainp namelist; /* points to names in the NAMELIST, - if this is a NAMELIST name */ - chainp vstfdesc; /* points to (formals, expr) pair */ - chainp assigned_values; /* list of integers, each being a - statement label assigned to - this variable in the current function */ - } varxptr; - int argno; /* for multiple entries */ - Argtypes *arginfo; - }; - - -/* PARAMETER statements */ - -struct Paramblock - { - field tag; - field vtype; - field vclass; - field vstg; - expptr vleng; - char *fvarname; - char *cvarname; - expptr paramval; - } ; - - -/* Expression block */ - -struct Exprblock - { - field tag; - field vtype; - field vclass; - field vstg; - expptr vleng; /* in the case of a character expression, this - value is inherited from the children */ - unsigned opcode; - expptr leftp; - expptr rightp; - int typefixed; - }; - - -union Constant - { - struct { - char *ccp0; - ftnint blanks; - } ccp1; - ftnint ci; /* Constant longeger */ - double cd[2]; - char *cds[2]; - }; -#define ccp ccp1.ccp0 - -struct Constblock - { - field tag; - field vtype; - field vclass; - field vstg; /* vstg = 1 when using Const.cds */ - expptr vleng; - union Constant Const; - }; - - -struct Listblock - { - field tag; - field vtype; - chainp listp; - }; - - - -/* Address block - this is the FINAL form of identifiers before being - sent to pass 2. We'll want to add the original identifier here so that it can - be preserved in the translation. - - An example identifier is q.7. The "q" refers to the storage class - (field vstg), the 7 to the variable number (int memno). */ - -struct Addrblock - { - field tag; - field vtype; - field vclass; - field vstg; - expptr vleng; - /* put union...user here so the beginning of an Addrblock - * is the same as a Constblock. - */ - union { - Namep name; /* contains a pointer into the hash table */ - char ident[IDENT_LEN + 1]; /* C string form of identifier */ - char *Charp; - union Constant Const; /* Constant value */ - struct { - double dfill[2]; - field vstg1; - } kludge; /* so we can distinguish string vs binary - * floating-point constants */ - } user; - long memno; /* when vstg == STGCONST, this is the - numeric part of the assembler label - where the constant value is stored */ - expptr memoffset; /* used in subscript computations, usually */ - unsigned istemp:1; /* used in stack management of temporary - variables */ - unsigned isarray:1; /* used to show that memoffset is - meaningful, even if zero */ - unsigned ntempelt:10; /* for representing temporary arrays, as - in concatenation */ - unsigned dbl_builtin:1; /* builtin to be declared double */ - unsigned charleng:1; /* so saveargtypes can get i/o calls right */ - unsigned cmplx_sub:1; /* used in complex arithmetic under -s */ - unsigned skip_offset:1; /* used in complex arithmetic under -s */ - unsigned parenused:1; /* distinguish (a) from a */ - ftnint varleng; /* holds a copy of a constant length which - is stored in the vleng field (e.g. - a double is 8 bytes) */ - int uname_tag; /* Tag describing which of the unions() - below to use */ - char *Field; /* field name when dereferencing a struct */ -}; /* struct Addrblock */ - - -/* Errorbock - placeholder for errors, to allow the compilation to - continue */ - -struct Errorblock - { - field tag; - field vtype; - }; - - -/* Implicit DO block, especially related to DATA statements. This block - keeps track of the compiler's location in the implicit DO while it's - running. In particular, the isactive and isbusy flags tell where - it is */ - -struct Impldoblock - { - field tag; - unsigned isactive:1; - unsigned isbusy:1; - Namep varnp; - Constp varvp; - chainp impdospec; - expptr implb; - expptr impub; - expptr impstep; - ftnint impdiff; - ftnint implim; - struct Chain *datalist; - }; - - -/* Each of these components has a first field called tag. This union - exists just for allocation simplicity */ - -union Expression - { - field tag; - struct Addrblock addrblock; - struct Constblock constblock; - struct Errorblock errorblock; - struct Exprblock exprblock; - struct Headblock headblock; - struct Impldoblock impldoblock; - struct Listblock listblock; - struct Nameblock nameblock; - struct Paramblock paramblock; - struct Primblock primblock; - } ; - - - -struct Dimblock - { - int ndim; - expptr nelt; /* This is NULL if the array is unbounded */ - expptr baseoffset; /* a constant or local variable holding - the offset in this procedure */ - expptr basexpr; /* expression for comuting the offset, if - it's not constant. If this is - non-null, the register named in - baseoffset will get initialized to this - value in the procedure's prolog */ - struct - { - expptr dimsize; /* constant or register holding the size - of this dimension */ - expptr dimexpr; /* as above in basexpr, this is an - expression for computing a variable - dimension */ - } dims[1]; /* Dimblocks are allocated with enough - space for this to become dims[ndim] */ - }; - - -/* Statement function identifier stack - this holds the name and value of - the parameters in a statement function invocation. For example, - - f(x,y,z)=x+y+z - . - . - y = f(1,2,3) - - generates a stack of depth 3, with <x 1>, <y 2>, <z 3> AT THE INVOCATION, NOT - at the definition */ - -struct Rplblock /* name replacement block */ - { - struct Rplblock *rplnextp; - Namep rplnp; /* Name of the formal parameter */ - expptr rplvp; /* Value of the actual parameter */ - expptr rplxp; /* Initialization of temporary variable, - if required; else null */ - int rpltag; /* Tag on the value of the actual param */ - }; - - - -/* Equivalence block */ - -struct Equivblock - { - struct Eqvchain *equivs; /* List (Eqvchain) of primblocks - holding variable identifiers */ - flag eqvinit; - long eqvtop; - long eqvbottom; - int eqvtype; - } ; -#define eqvleng eqvtop - -extern struct Equivblock *eqvclass; - - -struct Eqvchain - { - struct Eqvchain *eqvnextp; - union - { - struct Primblock *eqvlhs; - Namep eqvname; - } eqvitem; - long eqvoffset; - } ; - - - -/* For allocation purposes only, and to keep lint quiet. In particular, - don't count on the tag being able to tell you which structure is used */ - - -/* There is a tradition in Fortran that the compiler not generate the same - bit pattern more than is necessary. This structure is used to do just - that; if two integer constants have the same bit pattern, just generate - it once. This could be expanded to optimize without regard to type, by - removing the type check in putconst() */ - -struct Literal - { - short littype; - short lituse; /* usage count */ - long litnum; /* numeric part of the assembler - label for this constant value */ - union { - ftnint litival; - double litdval[2]; - ftnint litival2[2]; /* length, nblanks for strings */ - } litval; - char *cds[2]; - }; - -extern struct Literal *litpool; -extern int maxliterals, nliterals; -extern char Letters[]; -#define letter(x) Letters[x] - -struct Dims { expptr lb, ub; }; - -extern int forcedouble; /* force real functions to double */ -extern int doin_setbound; /* special handling for array bounds */ -extern int Ansi; -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 char binread[], binwrite[], textread[], textwrite[]; -extern char *ei_first, *ei_last, *ei_next; -extern char *wh_first, *wh_last, *wh_next; -extern char *halign, *outbuf, *outbtail; -extern flag keepsubs; -#ifdef TYQUAD -extern flag use_tyquad; -#endif -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)); -long 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 sserr Argdcl((Namep)); -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 deleted file mode 100644 index 0b7c94ccc5cd..000000000000 --- a/usr.bin/f2c/equiv.c +++ /dev/null @@ -1,413 +0,0 @@ -/**************************************************************** -Copyright 1990, 1993-6 by AT&T, Lucent Technologies and Bellcore. - -Permission to use, copy, modify, and distribute this software -and its documentation for any purpose and without fee is hereby -granted, provided that the above copyright notice appear in all -copies and that both that the copyright notice and this -permission notice and warranty disclaimer appear in supporting -documentation, and that the names of AT&T, Bell Laboratories, -Lucent or Bellcore or any of their entities not be used in -advertising or publicity pertaining to distribution of the -software without specific, written prior permission. - -AT&T, Lucent and Bellcore disclaim all warranties with regard to -this software, including all implied warranties of -merchantability and fitness. In no event shall AT&T, Lucent or -Bellcore be liable for any special, indirect or consequential -damages or any damages whatsoever resulting from loss of use, -data or profits, whether in an action of contract, negligence or -other tortious action, arising out of or in connection with the -use or performance of this software. -****************************************************************/ - -#include "defs.h" - -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 - */ - void -doequiv(Void) -{ - register int i; - int inequiv; /* True if one namep occurs in - several EQUIV declarations */ - int comno; /* Index into Extsym table of the last - COMMON block seen (implicitly assuming - that only one will be given) */ - int ovarno; - ftnint comoffset; /* Index into the COMMON block */ - ftnint offset; /* Offset from array base */ - ftnint leng; - register struct Equivblock *equivdecl; - register struct Eqvchain *q; - struct Primblock *primp; - register Namep np; - int k, k1, ns, pref, t; - chainp cp; - extern int type_pref[]; - char *s; - - for(i = 0 ; i < nequiv ; ++i) - { - -/* Handle each equivalence declaration */ - - equivdecl = &eqvclass[i]; - equivdecl->eqvbottom = equivdecl->eqvtop = 0; - comno = -1; - - - - for(q = equivdecl->equivs ; q ; q = q->eqvnextp) - { - offset = 0; - if (!(primp = q->eqvitem.eqvlhs)) - continue; - vardcl(np = primp->namep); - if(primp->argsp || primp->fcharp) - { - expptr offp; - -/* Pad ones onto the end of an array declaration when needed */ - - if(np->vdim!=NULL && np->vdim->ndim>1 && - nsubs(primp->argsp)==1 ) - { - if(! ftn66flag) - warni - ("1-dim subscript in EQUIVALENCE, %d-dim declared", - np -> vdim -> ndim); - cp = NULL; - ns = np->vdim->ndim; - while(--ns > 0) - cp = mkchain((char *)ICON(1), cp); - primp->argsp->listp->nextp = cp; - } - - offp = suboffset(primp); - if(ISICON(offp)) - offset = offp->constblock.Const.ci; - else { - dclerr - ("nonconstant subscript in equivalence ", - np); - np = NULL; - } - frexpr(offp); - } - -/* Free up the primblock, since we now have a hash table (Namep) entry */ - - frexpr((expptr)primp); - - if(np && (leng = iarrlen(np))<0) - { - dclerr("adjustable in equivalence", np); - np = NULL; - } - - if(np) switch(np->vstg) - { - case STGUNKNOWN: - case STGBSS: - case STGEQUIV: - break; - - case STGCOMMON: - -/* The code assumes that all COMMON references in a given EQUIVALENCE will - be to the same COMMON block, and will all be consistent */ - - comno = np->vardesc.varno; - comoffset = np->voffset + offset; - break; - - default: - dclerr("bad storage class in equivalence", np); - np = NULL; - break; - } - - if(np) - { - q->eqvoffset = offset; - -/* eqvbottom gets the largest difference between the array base address - and the address specified in the EQUIV declaration */ - - equivdecl->eqvbottom = - lmin(equivdecl->eqvbottom, -offset); - -/* eqvtop gets the largest difference between the end of the array and - the address given in the EQUIVALENCE */ - - equivdecl->eqvtop = - lmax(equivdecl->eqvtop, leng-offset); - } - q->eqvitem.eqvname = np; - } - -/* Now all equivalenced variables are in the hash table with the proper - offset, and eqvtop and eqvbottom are set. */ - - if(comno >= 0) - -/* Get rid of all STGEQUIVS, they will be mapped onto STGCOMMON variables - */ - - eqvcommon(equivdecl, comno, comoffset); - else for(q = equivdecl->equivs ; q ; q = q->eqvnextp) - { - if(np = q->eqvitem.eqvname) - { - inequiv = NO; - if(np->vstg==STGEQUIV) - if( (ovarno = np->vardesc.varno) == i) - { - -/* Can't EQUIV different elements of the same array */ - - if(np->voffset + q->eqvoffset != 0) - dclerr - ("inconsistent equivalence", np); - } - else { - offset = np->voffset; - inequiv = YES; - } - - np->vstg = STGEQUIV; - np->vardesc.varno = i; - np->voffset = - q->eqvoffset; - - if(inequiv) - -/* Combine 2 equivalence declarations */ - - eqveqv(i, ovarno, q->eqvoffset + offset); - } - } - } - -/* Now each equivalence declaration is distinct (all connections have been - merged in eqveqv()), and some may be empty. */ - - for(i = 0 ; i < nequiv ; ++i) - { - equivdecl = & eqvclass[i]; - if(equivdecl->eqvbottom!=0 || equivdecl->eqvtop!=0) { - -/* a live chain */ - - k = TYCHAR; - pref = 1; - for(q = equivdecl->equivs ; q; q = q->eqvnextp) - if ((np = q->eqvitem.eqvname) - && !np->veqvadjust) { - np->veqvadjust = 1; - np->voffset -= equivdecl->eqvbottom; - t = typealign[k1 = np->vtype]; - if (pref < type_pref[k1]) { - k = k1; - pref = type_pref[k1]; - } - if(np->voffset % t != 0) { - dclerr("bad alignment forced by equivalence", np); - --nerr; /* don't give bad return code for this */ - } - } - equivdecl->eqvtype = k; - } - freqchain(equivdecl); - } -} - - - - - -/* put equivalence chain p at common block comno + 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; - register Namep np; - register struct Eqvchain *q; - - if(comoffset + p->eqvbottom < 0) - { - errstr("attempt to extend common %s backward", - extsymtab[comno].fextname); - freqchain(p); - return; - } - - if( (k = comoffset + p->eqvtop) > extsymtab[comno].extleng) - extsymtab[comno].extleng = k; - - - for(q = p->equivs ; q ; q = q->eqvnextp) - if(np = q->eqvitem.eqvname) - { - switch(np->vstg) - { - case STGUNKNOWN: - case STGBSS: - np->vstg = STGCOMMON; - np->vcommequiv = 1; - np->vardesc.varno = comno; - -/* np -> voffset will point to the base of the array */ - - np->voffset = comoffset - q->eqvoffset; - break; - - case STGEQUIV: - ovarno = np->vardesc.varno; - -/* offq will point to the current element, even if it's in an array */ - - offq = comoffset - q->eqvoffset - np->voffset; - np->vstg = STGCOMMON; - np->vcommequiv = 1; - np->vardesc.varno = comno; - -/* np -> voffset will point to the base of the array */ - - np->voffset += offq; - if(ovarno != (p - eqvclass)) - eqvcommon(&eqvclass[ovarno], comno, offq); - break; - - case STGCOMMON: - if(comno != np->vardesc.varno || - comoffset != np->voffset+q->eqvoffset) - dclerr("inconsistent common usage", np); - break; - - - default: - badstg("eqvcommon", np->vstg); - } - } - - freqchain(p); - p->eqvbottom = p->eqvtop = 0; -} - - -/* Move all items on ovarno chain to the front of nvarno chain. - * adjust offsets of ovarno elements and top and bottom of nvarno chain - */ - - 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; - struct Eqvchain *q, *q1; - - neweqv = eqvclass + nvarno; - oldeqv = eqvclass + ovarno; - neweqv->eqvbottom = lmin(neweqv->eqvbottom, oldeqv->eqvbottom - delta); - neweqv->eqvtop = lmax(neweqv->eqvtop, oldeqv->eqvtop - delta); - oldeqv->eqvbottom = oldeqv->eqvtop = 0; - - for(q = oldeqv->equivs ; q ; q = q1) - { - q1 = q->eqvnextp; - if( (np = q->eqvitem.eqvname) && np->vardesc.varno==ovarno) - { - q->eqvnextp = neweqv->equivs; - neweqv->equivs = q; - q->eqvoffset += delta; - np->vardesc.varno = nvarno; - np->voffset -= delta; - } - else free( (charptr) q); - } - oldeqv->equivs = NULL; -} - - - - void -#ifdef KR_headers -freqchain(p) - register struct Equivblock *p; -#else -freqchain(register struct Equivblock *p) -#endif -{ - register struct Eqvchain *q, *oq; - - for(q = p->equivs ; q ; q = oq) - { - oq = q->eqvnextp; - free( (charptr) q); - } - p->equivs = NULL; -} - - - - - -/* nsubs -- number of subscripts in this arglist (just the length of the - list) */ - - LOCAL int -#ifdef KR_headers -nsubs(p) - register struct Listblock *p; -#else -nsubs(register struct Listblock *p) -#endif -{ - register int n; - register chainp q; - - n = 0; - if(p) - for(q = p->listp ; q ; q = q->nextp) - ++n; - - return(n); -} - - struct Primblock * -#ifdef KR_headers -primchk(e) expptr e; -#else -primchk(expptr e) -#endif -{ - if (e->headblock.tag != TPRIM) { - err("Invalid name in EQUIVALENCE."); - return 0; - } - return &e->primblock; - } diff --git a/usr.bin/f2c/error.c b/usr.bin/f2c/error.c deleted file mode 100644 index 0899d82fb139..000000000000 --- a/usr.bin/f2c/error.c +++ /dev/null @@ -1,347 +0,0 @@ -/**************************************************************** -Copyright 1990, 1993, 1994 by AT&T, Lucent Technologies and Bellcore. - -Permission to use, copy, modify, and distribute this software -and its documentation for any purpose and without fee is hereby -granted, provided that the above copyright notice appear in all -copies and that both that the copyright notice and this -permission notice and warranty disclaimer appear in supporting -documentation, and that the names of AT&T, Bell Laboratories, -Lucent or Bellcore or any of their entities not be used in -advertising or publicity pertaining to distribution of the -software without specific, written prior permission. - -AT&T, Lucent and Bellcore disclaim all warranties with regard to -this software, including all implied warranties of -merchantability and fitness. In no event shall AT&T, Lucent or -Bellcore be liable for any special, indirect or consequential -damages or any damages whatsoever resulting from loss of use, -data or profits, whether in an action of contract, negligence or -other tortious action, arising out of or in connection with the -use or performance of this software. -****************************************************************/ - -#include "defs.h" - - 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); - } - - 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; -#else -warn(char *s) -#endif -{ - if(nowarnflag) - return; - if (infname && *infname) - fprintf(diagfile, "Warning on line %ld of %s: %s\n", - lineno, infname, s); - else - fprintf(diagfile, "Warning on line %ld: %s\n", lineno, s); - fflush(diagfile); - ++nwarn; -} - - void -#ifdef KR_headers -errstr(s, t) - char *s; - char *t; -#else -errstr(char *s, char *t) -#endif -{ - char buff[100]; - sprintf(buff, s, t); - err(buff); -} - - - 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); -} - - 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); - err(buff); -} - - char *err_proc = 0; - - void -#ifdef KR_headers -err(s) - char *s; -#else -err(char *s) -#endif -{ - if (err_proc) - fprintf(diagfile, - "Error processing %s before line %ld", - err_proc, lineno); - else - fprintf(diagfile, "Error on line %ld", lineno); - if (infname && *infname) - fprintf(diagfile, " of %s", infname); - fprintf(diagfile, ": %s\n", s); - fflush(diagfile); - ++nerr; -} - - void -#ifdef KR_headers -yyerror(s) - char *s; -#else -yyerror(char *s) -#endif -{ - err(s); -} - - - void -#ifdef KR_headers -dclerr(s, v) - char *s; - Namep v; -#else -dclerr(char *s, Namep v) -#endif -{ - char buff[100]; - - if(v) - { - sprintf(buff, "Declaration error for %s: %s", v->fvarname, s); - err(buff); - } - else - errstr("Declaration error %s", s); -} - - - void -#ifdef KR_headers -execerr(s, n) - char *s; - char *n; -#else -execerr(char *s, char *n) -#endif -{ - char buf1[100], buf2[100]; - - sprintf(buf1, "Execution error %s", s); - sprintf(buf2, buf1, n); - err(buf2); -} - - - void -#ifdef KR_headers -Fatal(t) - char *t; -#else -Fatal(char *t) -#endif -{ - fprintf(diagfile, "Compiler error line %ld", lineno); - if (infname) - fprintf(diagfile, " of %s", infname); - fprintf(diagfile, ": %s\n", t); - done(3); -} - - - - 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); - Fatal(buff); -} - - - 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); - Fatal(buff); -} - - - void -#ifdef KR_headers -badthing(thing, r, 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); - Fatal(buff); -} - - - void -#ifdef KR_headers -badop(r, 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; -#else -badtag(char *r, int t) -#endif -{ - badthing("tag", r, t); -} - - - - - void -#ifdef KR_headers -badstg(r, 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; -#else -badtype(char *r, int t) -#endif -{ - badthing("type", r, t); -} - - void -#ifdef KR_headers -many(s, c, n) - char *s; - char c; - int n; -#else -many(char *s, char c, int n) -#endif -{ - char buff[250]; - - sprintf(buff, - "Too many %s.\nTable limit now %d.\nTry rerunning with the -N%c%d option.\n", - s, n, c, 2*n); - Fatal(buff); -} - - void -#ifdef KR_headers -err66(s) - char *s; -#else -err66(char *s) -#endif -{ - errstr("Fortran 77 feature used: %s", s); - --nerr; -} - - - void -#ifdef KR_headers -errext(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 deleted file mode 100644 index 5e3d7b278180..000000000000 --- a/usr.bin/f2c/exec.c +++ /dev/null @@ -1,934 +0,0 @@ -/**************************************************************** -Copyright 1990, 1993 - 1996 by AT&T, Lucent Technologies and Bellcore. - -Permission to use, copy, modify, and distribute this software -and its documentation for any purpose and without fee is hereby -granted, provided that the above copyright notice appear in all -copies and that both that the copyright notice and this -permission notice and warranty disclaimer appear in supporting -documentation, and that the names of AT&T, Bell Laboratories, -Lucent or Bellcore or any of their entities not be used in -advertising or publicity pertaining to distribution of the -software without specific, written prior permission. - -AT&T, Lucent and Bellcore disclaim all warranties with regard to -this software, including all implied warranties of -merchantability and fitness. In no event shall AT&T, Lucent or -Bellcore be liable for any special, indirect or consequential -damages or any damages whatsoever resulting from loss of use, -data or profits, whether in an action of contract, negligence or -other tortious action, arising out of or in connection with the -use or performance of this software. -****************************************************************/ - -#include "defs.h" -#include "p1defs.h" -#include "names.h" - -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; -#else -exif(expptr p) -#endif -{ - pushctl(CTLIF); - putif(p, 0); /* 0 => if, not elseif */ -} - - - void -#ifdef KR_headers -exelif(p) - expptr p; -#else -exelif(expptr p) -#endif -{ - if (ctlstack->ctltype == CTLIF || ctlstack->ctltype == CTLIFX) - putif(p, 1); /* 1 ==> elseif */ - else - execerr("elseif out of place", CNULL); -} - - - - - void -exelse(Void) -{ - register struct Ctlframe *c; - - for(c = ctlstack; c->ctltype == CTLIFX; --c); - if(c->ctltype == CTLIF) { - p1_else (); - c->ctltype = CTLELSE; - } - else - execerr("else out of place", CNULL); - } - - void -#ifdef KR_headers -exendif() -#else -exendif() -#endif -{ - while(ctlstack->ctltype == CTLIFX) { - popctl(); - p1else_end(); - } - if(ctlstack->ctltype == CTLIF) { - popctl(); - p1_endif (); - } - else if(ctlstack->ctltype == CTLELSE) { - popctl(); - p1else_end (); - } - else - execerr("endif out of place", CNULL); - } - - - void -#ifdef KR_headers -new_endif() -#else -new_endif() -#endif -{ - if (ctlstack->ctltype == CTLIF || ctlstack->ctltype == CTLIFX) - pushctl(CTLIFX); - else - err("new_endif bug"); - } - -/* pushctl -- Start a new control construct, initialize the labels (to - zero) */ - - LOCAL void -#ifdef KR_headers -pushctl(code) - int code; -#else -pushctl(int code) -#endif -{ - register int i; - - if(++ctlstack >= lastctl) - many("loops or if-then-elses", 'c', maxctl); - ctlstack->ctltype = 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(Void) -{ - if( ctlstack-- < ctls ) - Fatal("control stack empty"); - --blklevel; -} - - - -/* poplab -- update the flags in labeltab */ - - LOCAL void -poplab(Void) -{ - register struct Labelblock *lp; - - for(lp = labeltab ; lp < highlabtab ; ++lp) - if(lp->labdefined) - { - /* mark all labels in inner blocks unreachable */ - if(lp->blklevel > blklevel) - lp->labinacc = YES; - } - else if(lp->blklevel > blklevel) - { - /* move all labels referred to in inner blocks out a level */ - lp->blklevel = blklevel; - } -} - - -/* BRANCHING CODE -*/ - void -#ifdef KR_headers -exgoto(lab) - struct Labelblock *lab; -#else -exgoto(struct Labelblock *lab) -#endif -{ - lab->labused = 1; - p1_goto (lab -> stateno); -} - - - - - - - void -#ifdef KR_headers -exequals(lp, rp) - register struct Primblock *lp; - register expptr rp; -#else -exequals(register struct Primblock *lp, register expptr rp) -#endif -{ - if(lp->tag != TPRIM) - { - err("assignment to a non-variable"); - frexpr((expptr)lp); - frexpr(rp); - } - else if(lp->namep->vclass!=CLVAR && lp->argsp) - { - if(parstate >= INEXEC) - 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; - - if(parstate < INDATA) - enddcl(); - new_lp = mklhs (lp, keepsubs); - new_rp = fixtype (rp); - puteq(new_lp, new_rp); - } -} - - - -/* Make Statement Function */ - -long laststfcn = -1, thisstno; -int doing_stmtfcn; - - void -#ifdef KR_headers -mkstfunct(lp, rp) - struct Primblock *lp; - expptr rp; -#else -mkstfunct(struct Primblock *lp, expptr rp) -#endif -{ - register struct Primblock *p; - register Namep np; - chainp args; - - laststfcn = thisstno; - np = lp->namep; - if(np->vclass == CLUNKNOWN) - np->vclass = CLPROC; - else - { - dclerr("redeclaration of statement function", np); - return; - } - np->vprocclass = PSTFUNCT; - np->vstg = STGSTFUNCT; - -/* Set the type of the function */ - - impldcl(np); - if (np->vtype == TYCHAR && !np->vleng) - err("character statement function with length (*)"); - args = (lp->argsp ? lp->argsp->listp : CHNULL); - np->varxptr.vstfdesc = mkchain((char *)args, (chainp)rp); - - for(doing_stmtfcn = 1 ; args ; args = args->nextp) - -/* It is an error for the formal parameters to have arguments or - subscripts */ - - if( ((tagptr)(args->datap))->tag!=TPRIM || - (p = (struct Primblock *)(args->datap) )->argsp || - p->fcharp || p->lcharp ) { - err("non-variable argument in statement function definition"); - args->datap = 0; - } - else - { - -/* Replace the name on the left-hand side */ - - args->datap = (char *)p->namep; - vardcl(p -> namep); - free((char *)p); - } - doing_stmtfcn = 0; -} - - static void -#ifdef KR_headers -mixed_type(np) - Namep np; -#else -mixed_type(Namep np) -#endif -{ - char buf[128]; - sprintf(buf, "%s function %.90s invoked as subroutine", - ftn_types[np->vtype], np->fvarname); - warn(buf); - } - - void -#ifdef KR_headers -excall(name, args, nstars, 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; - - if (name->vtype != TYSUBR) { - if (name->vinfproc && !name->vcalled) { - name->vtype = TYSUBR; - frexpr(name->vleng); - name->vleng = 0; - } - else if (!name->vimpltype && name->vtype != TYUNKNOWN) - mixed_type(name); - else - settype(name, TYSUBR, (ftnint)0); - } - p = mkfunct( mkprim(name, args, CHNULL) ); - if (p->tag == TERROR) - return; - -/* Subroutines and their identifiers acquire the type INT */ - - p->exprblock.vtype = p->exprblock.leftp->headblock.vtype = TYINT; - -/* Handle the alternate return mechanism */ - - if(nstars > 0) - putcmgo(putx(fixtype(p)), nstars, labels); - else - putexpr(p); -} - - - void -#ifdef KR_headers -exstop(stop, p) - int stop; - register expptr p; -#else -exstop(int stop, register expptr p) -#endif -{ - char *str; - int n; - - if(p) - { - if( ! ISCONST(p) ) - { - execerr("pause/stop argument must be constant", CNULL); - frexpr(p); - p = mkstrcon(0, CNULL); - } - else if( ISINT(p->constblock.vtype) ) - { - str = convic(p->constblock.Const.ci); - n = strlen(str); - if(n > 0) - { - p->constblock.Const.ccp = copyn(n, str); - p->constblock.Const.ccp1.blanks = 0; - p->constblock.vtype = TYCHAR; - p->constblock.vleng = (expptr) ICON(n); - } - else - p = (expptr) mkstrcon(0, CNULL); - } - else if(p->constblock.vtype != TYCHAR) - { - execerr("pause/stop argument must be integer or string", CNULL); - p = (expptr) mkstrcon(0, CNULL); - } - } - else p = (expptr) mkstrcon(0, CNULL); - - { - expptr subr_call; - - subr_call = call1(TYSUBR, (stop ? "s_stop" : "s_paus"), p); - putexpr( subr_call ); - } -} - -/* DO LOOP CODE */ - -#define DOINIT par[0] -#define DOLIMIT par[1] -#define DOINCR par[2] - - -/* Macros for ctlstack -> dostepsign */ - -#define VARSTEP 0 -#define POSSTEP 1 -#define NEGSTEP 2 - - -/* exdo -- generate DO loop code. In the case of a variable increment, - 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; - 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; - chainp cp; /* loops over the fields in spec */ - register int i; - int dotype; /* type of the index variable */ - int incsign; /* sign of the increment, if it's constant - */ - Addrp dovarp; /* loop index variable */ - expptr doinit; /* constant or register for init param */ - expptr par[3]; /* local specification parameters */ - - expptr init, test, inc; /* Expressions in the resulting FOR loop */ - - - test = ENULL; - - pushctl(CTLDO); - dorange = ctlstack->dolabel = range; - ctlstack->loopname = loopname; - -/* Declare the loop index */ - - np = (Namep)spec->datap; - ctlstack->donamep = NULL; - if (!np) { /* do while */ - ctlstack->dowhile = 1; -#if 0 - if (loopname) { - if (loopname->vtype == TYUNKNOWN) { - loopname->vdcldone = 1; - loopname->vclass = CLLABEL; - loopname->vprocclass = PLABEL; - loopname->vtype = TYLABEL; - } - if (loopname->vtype == TYLABEL) - if (loopname->vdovar) - dclerr("already in use as a loop name", - loopname); - else - loopname->vdovar = 1; - else - dclerr("already declared; cannot be a loop name", - loopname); - } -#endif - putwhile((expptr)spec->nextp); - NOEXT("do while"); - spec->nextp = 0; - frchain(&spec); - return; - } - if(np->vdovar) - { - errstr("nested loops with variable %s", np->fvarname); - ctlstack->donamep = NULL; - return; - } - -/* Create a memory-resident version of the index variable */ - - dovarp = mkplace(np); - if( ! ONEOF(dovarp->vtype, MSKINT|MSKREAL) ) - { - err("bad type on do variable"); - return; - } - ctlstack->donamep = np; - - np->vdovar = YES; - -/* Now dovarp points to the index to be used within the loop, dostgp - points to the one which may need to be stored */ - - dotype = dovarp->vtype; - -/* Count the input specifications and type-check each one independently; - this just eliminates non-numeric values from the specification */ - - for(i=0 , cp = spec->nextp ; cp!=NULL && i<3 ; cp = cp->nextp) - { - p = par[i++] = fixtype((tagptr)cp->datap); - if( ! ONEOF(p->headblock.vtype, MSKINT|MSKREAL) ) - { - err("bad type on DO parameter"); - return; - } - } - - frchain(&spec); - switch(i) - { - case 0: - case 1: - err("too few DO parameters"); - return; - - default: - err("too many DO parameters"); - return; - - case 2: - DOINCR = (expptr) ICON(1); - - case 3: - break; - } - - -/* Now all of the local specification fields are set, but their types are - not yet consistent */ - -/* Declare the loop initialization value, casting it properly and declaring a - register if need be */ - - ctlstack->doinit = 0; - if (ISCONST (DOINIT) || !onetripflag) -/* putx added 6-29-89 (mwm), not sure if fixtype is required, but I doubt it - since mkconv is called just before */ - doinit = putx (mkconv (dotype, DOINIT)); - else { - if (onetripflag) - ctlstack->doinit = doinit = (expptr) mktmp0(dotype, ENULL); - else - doinit = (expptr) mktmp(dotype, ENULL); - puteq (cpexpr (doinit), DOINIT); - } /* else */ - -/* Declare the loop ending value, casting it to the type of the index - variable */ - - if( ISCONST(DOLIMIT) ) - ctlstack->domax = mkconv(dotype, DOLIMIT); - else { - ctlstack->domax = (expptr) mktmp0(dotype, ENULL); - puteq (cpexpr (ctlstack -> domax), DOLIMIT); - } /* else */ - -/* Declare the loop increment value, casting it to the type of the index - variable */ - - if( ISCONST(DOINCR) ) - { - ctlstack->dostep = mkconv(dotype, DOINCR); - if( (incsign = conssgn(ctlstack->dostep)) == 0) - err("zero DO increment"); - ctlstack->dostepsign = (incsign > 0 ? POSSTEP : NEGSTEP); - } - else - { - ctlstack->dostep = (expptr) mktmp0(dotype, ENULL); - ctlstack->dostepsign = VARSTEP; - puteq (cpexpr (ctlstack -> dostep), DOINCR); - } - -/* All data is now properly typed and in the ctlstack, except for the - initial value. Assignments of temps have been generated already */ - - switch (ctlstack -> dostepsign) { - case VARSTEP: - test = mkexpr (OPQUEST, mkexpr (OPLT, - cpexpr (ctlstack -> dostep), ICON(0)), - mkexpr (OPCOLON, - mkexpr (OPGE, cpexpr((expptr)dovarp), - cpexpr (ctlstack -> domax)), - mkexpr (OPLE, cpexpr((expptr)dovarp), - cpexpr (ctlstack -> domax)))); - break; - case POSSTEP: - test = mkexpr (OPLE, cpexpr((expptr)dovarp), - cpexpr (ctlstack -> domax)); - break; - case NEGSTEP: - test = mkexpr (OPGE, cpexpr((expptr)dovarp), - cpexpr (ctlstack -> domax)); - break; - default: - erri ("exdo: bad dostepsign '%d'", ctlstack -> dostepsign); - break; - } /* switch (ctlstack -> dostepsign) */ - - if (onetripflag) - test = mkexpr (OPOR, test, - mkexpr (OPEQ, cpexpr((expptr)dovarp), cpexpr (doinit))); - init = mkexpr (OPASSIGN, cpexpr((expptr)dovarp), - ctlstack->doinit ? cpexpr(doinit) : doinit); - inc = mkexpr (OPPLUSEQ, (expptr)dovarp, cpexpr (ctlstack -> dostep)); - - if (!onetripflag && ISCONST (ctlstack -> domax) && ISCONST (doinit) - && ctlstack -> dostepsign != VARSTEP) { - expptr tester; - - tester = mkexpr (OPMINUS, cpexpr (doinit), - cpexpr (ctlstack -> domax)); - if (incsign == conssgn (tester)) - warn ("DO range never executed"); - frexpr (tester); - } /* if !onetripflag && */ - - p1_for (init, test, inc); -} - - void -#ifdef KR_headers -exenddo(np) - Namep np; -#else -exenddo(Namep np) -#endif -{ - Namep np1; - int here; - struct Ctlframe *cf; - - if( ctlstack < ctls ) - goto misplaced; - here = ctlstack->dolabel; - if (ctlstack->ctltype != CTLDO - || here >= 0 && (!thislabel || thislabel->labelno != here)) { - misplaced: - err("misplaced ENDDO"); - return; - } - if (np != ctlstack->loopname) { - if (np1 = ctlstack->loopname) - errstr("expected \"enddo %s\"", np1->fvarname); - else - err("expected unnamed ENDDO"); - for(cf = ctls; cf < ctlstack; cf++) - if (cf->ctltype == CTLDO && cf->loopname == np) { - here = cf->dolabel; - break; - } - } - enddo(here); - } - - void -#ifdef KR_headers -enddo(here) - int here; -#else -enddo(int here) -#endif -{ - register struct Ctlframe *q; - Namep np; /* name of the current DO index */ - Addrp ap; - register int i; - register expptr e; - -/* Many DO's can end at the same statement, so keep looping over all - nested indicies */ - - while(here == dorange) - { - if(np = ctlstack->donamep) - { - p1for_end (); - -/* Now we're done with all of the tests, and the loop has terminated. - Store the index value back in long-term memory */ - - if(ap = memversion(np)) - puteq((expptr)ap, (expptr)mkplace(np)); - for(i = 0 ; i < 4 ; ++i) - ctlstack->ctlabels[i] = 0; - deregister(ctlstack->donamep); - ctlstack->donamep->vdovar = NO; - /* 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); - if (e = ctlstack->doinit) - frtemp((Addrp)e); - } - else if (ctlstack->dowhile) - p1for_end (); - -/* Set dorange to the closing label of the next most enclosing DO loop - */ - - popctl(); - poplab(); - dorange = 0; - for(q = ctlstack ; q>=ctls ; --q) - if(q->ctltype == CTLDO) - { - dorange = q->dolabel; - break; - } - } -} - - void -#ifdef KR_headers -exassign(vname, labelval) - register Namep vname; - struct Labelblock *labelval; -#else -exassign(register Namep vname, struct Labelblock *labelval) -#endif -{ - Addrp p; - register Addrp q; - char *fs; - register chainp cp, cpprev; - register ftnint k, stno; - - p = mkplace(vname); - if( ! ONEOF(p->vtype, MSKINT|MSKADDR) ) { - err("noninteger assign variable"); - return; - } - - /* If the label hasn't been defined, then we do things twice: - * once for an executable stmt label, once for a format - */ - - /* code for executable label... */ - -/* Now store the assigned value in a list associated with this variable. - This will be used later to generate a switch() statement in the C output */ - - fs = labelval->fmtstring; - if (!labelval->labdefined || !fs) { - - if (vname -> vis_assigned == 0) { - vname -> varxptr.assigned_values = CHNULL; - vname -> vis_assigned = 1; - } - - /* don't duplicate labels... */ - - stno = labelval->stateno; - cpprev = 0; - for(k = 0, cp = vname->varxptr.assigned_values; - cp; cpprev = cp, cp = cp->nextp, k++) - if ((ftnint)cp->datap == stno) - break; - if (!cp) { - cp = mkchain((char *)stno, CHNULL); - if (cpprev) - cpprev->nextp = cp; - else - vname->varxptr.assigned_values = cp; - labelval->labused = 1; - } - putout(mkexpr(OPASSIGN, (expptr)p, mkintcon(k))); - } - - /* Code for FORMAT label... */ - - if (!labelval->labdefined || fs) { - - labelval->fmtlabused = 1; - p = ALLOC(Addrblock); - p->tag = TADDR; - p->vtype = TYCHAR; - p->vstg = STGAUTO; - p->memoffset = ICON(0); - fmtname(vname, p); - q = ALLOC(Addrblock); - q->tag = TADDR; - q->vtype = TYCHAR; - q->vstg = STGAUTO; - q->ntempelt = 1; - q->memoffset = ICON(0); - q->uname_tag = UNAM_IDENT; - sprintf(q->user.ident, "fmt_%ld", labelval->stateno); - putout(mkexpr(OPASSIGN, (expptr)p, (expptr)q)); - } - -} /* exassign */ - - - void -#ifdef KR_headers -exarif(expr, 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; - - lm = neglab->stateno; - lz = zerlab->stateno; - lp = poslab->stateno; - expr = fixtype(expr); - - if( ! ONEOF(expr->headblock.vtype, MSKINT|MSKREAL) ) - { - err("invalid type of arithmetic if expression"); - frexpr(expr); - } - else - { - if (lm == lz && lz == lp) - exgoto (neglab); - else if(lm == lz) - exar2(OPLE, expr, neglab, poslab); - else if(lm == lp) - exar2(OPNE, expr, neglab, zerlab); - else if(lz == lp) - exar2(OPGE, expr, zerlab, neglab); - else { - expptr t; - - if (!addressable (expr)) { - t = (expptr) mktmp(expr -> headblock.vtype, ENULL); - expr = mkexpr (OPASSIGN, cpexpr (t), expr); - } else - t = (expptr) cpexpr (expr); - - p1_if(putx(fixtype(mkexpr (OPLT, expr, ICON (0))))); - exgoto(neglab); - p1_elif (mkexpr (OPEQ, t, ICON (0))); - exgoto(zerlab); - p1_else (); - exgoto(poslab); - p1else_end (); - } /* else */ - } -} - - - -/* exar2 -- Do arithmetic IF for only 2 distinct labels; if !(e.op.0) - goto l2 else goto l1. If this seems backwards, that's because it is, - 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; - struct Labelblock *l2; -#else -exar2(int op, expptr e, struct Labelblock *l1, struct Labelblock *l2) -#endif -{ - expptr comp; - - comp = mkexpr (op, e, ICON (0)); - p1_if(putx(fixtype(comp))); - exgoto(l1); - p1_else (); - exgoto(l2); - p1else_end (); -} - - -/* 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; -#else -exreturn(register expptr p) -#endif -{ - if(procclass != CLPROC) - warn("RETURN statement in main or block data"); - if(p && (proctype!=TYSUBR || procclass!=CLPROC) ) - { - err("alternate return in nonsubroutine"); - p = 0; - } - - if (p || proctype == TYSUBR) { - if (p == ENULL) p = ICON (0); - p = mkconv (TYLONG, fixtype (p)); - p1_subr_ret (p); - } /* if p || proctype == TYSUBR */ - else - p1_subr_ret((expptr)retslot); -} - - - void -#ifdef KR_headers -exasgoto(labvar) - Namep labvar; -#else -exasgoto(Namep labvar) -#endif -{ - register Addrp p; - - p = mkplace(labvar); - if( ! ISINT(p->vtype) ) - err("assigned goto variable must be integer"); - else { - p1_asgoto (p); - } /* else */ -} diff --git a/usr.bin/f2c/expr.c b/usr.bin/f2c/expr.c deleted file mode 100644 index 59ea9b6b3c9e..000000000000 --- a/usr.bin/f2c/expr.c +++ /dev/null @@ -1,3436 +0,0 @@ -/**************************************************************** -Copyright 1990 - 1996 by AT&T, Lucent Technologies and Bellcore. - -Permission to use, copy, modify, and distribute this software -and its documentation for any purpose and without fee is hereby -granted, provided that the above copyright notice appear in all -copies and that both that the copyright notice and this -permission notice and warranty disclaimer appear in supporting -documentation, and that the names of AT&T, Bell Laboratories, -Lucent or Bellcore or any of their entities not be used in -advertising or publicity pertaining to distribution of the -software without specific, written prior permission. - -AT&T, Lucent and Bellcore disclaim all warranties with regard to -this software, including all implied warranties of -merchantability and fitness. In no event shall AT&T, Lucent or -Bellcore be liable for any special, indirect or consequential -damages or any damages whatsoever resulting from loss of use, -data or profits, whether in an action of contract, negligence or -other tortious action, arising out of or in connection with the -use or performance of this software. -****************************************************************/ - -#include "defs.h" -#include "output.h" -#include "names.h" - -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 -#ifdef KR_headers -mkconst(t) - register int t; -#else -mkconst(register int t) -#endif -{ - register Constp p; - - p = ALLOC(Constblock); - p->tag = TCONST; - p->vtype = t; - return(p); -} - - -/* mklogcon -- Make Logical Constant */ - - expptr -#ifdef KR_headers -mklogcon(l) - register int l; -#else -mklogcon(register int l) -#endif -{ - register Constp p; - - p = mkconst(tylog); - p->Const.ci = l; - return( (expptr) p ); -} - - - -/* mkintcon -- Make Integer Constant */ - - expptr -#ifdef KR_headers -mkintcon(l) - ftnint l; -#else -mkintcon(ftnint l) -#endif -{ - register Constp p; - - p = mkconst(tyint); - p->Const.ci = l; - return( (expptr) p ); -} - - - - -/* mkaddcon -- Make Address Constant, given integer value */ - - expptr -#ifdef KR_headers -mkaddcon(l) - register long l; -#else -mkaddcon(register long l) -#endif -{ - register Constp p; - - p = mkconst(TYADDR); - p->Const.ci = l; - return( (expptr) p ); -} - - - -/* mkrealcon -- Make Real Constant. The type t is assumed - to be TYREAL or TYDREAL */ - - expptr -#ifdef KR_headers -mkrealcon(t, d) - register int t; - char *d; -#else -mkrealcon(register int t, char *d) -#endif -{ - register Constp p; - - p = mkconst(t); - p->Const.cds[0] = cds(d,CNULL); - p->vstg = 1; - return( (expptr) p ); -} - - -/* mkbitcon -- Make bit constant. Reads the input string, which is - assumed to correctly specify a number in base 2^shift (where shift - is the input parameter). shift may not exceed 4, i.e. only binary, - 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 -#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, y, z; - int len; - char buff[100], *fmt, *s0 = s; - static char *kind[3] = { "Binary", "Hex", "Octal" }; - - p = mkconst(TYLONG); - x = y = 0; - while(--leng >= 0) - if(*s != ' ') { - z = x; - x = (x << shift) | hextoi(*s++); - 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 ); -} - - - - - -/* mkstrcon -- Make string constant. Allocates storage and initializes - the memory for a copy of the input Fortran-string. */ - - 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; - - p = mkconst(TYCHAR); - p->vleng = ICON(l); - p->Const.ccp = s = (char *) ckalloc(l+1); - p->Const.ccp1.blanks = 0; - while(--l >= 0) - *s++ = *v++; - *s = '\0'; - return( (expptr) p ); -} - - - -/* mkcxcon -- Make complex contsant. A complex number is a pair of - values, each of which may be integer, real or double. */ - - 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; - - rtype = realp->headblock.vtype; - itype = imagp->headblock.vtype; - - if( ISCONST(realp) && ISNUMERIC(rtype) && ISCONST(imagp) && ISNUMERIC(itype) ) - { - p = mkconst( (rtype==TYDREAL||itype==TYDREAL) - ? TYDCOMPLEX : tycomplex); - if (realp->constblock.vstg || imagp->constblock.vstg) { - p->vstg = 1; - p->Const.cds[0] = ISINT(rtype) - ? string_num("", realp->constblock.Const.ci) - : realp->constblock.vstg - ? realp->constblock.Const.cds[0] - : dtos(realp->constblock.Const.cd[0]); - p->Const.cds[1] = ISINT(itype) - ? string_num("", imagp->constblock.Const.ci) - : imagp->constblock.vstg - ? imagp->constblock.Const.cds[0] - : dtos(imagp->constblock.Const.cd[0]); - } - else { - p->Const.cd[0] = ISINT(rtype) - ? realp->constblock.Const.ci - : realp->constblock.Const.cd[0]; - p->Const.cd[1] = ISINT(itype) - ? imagp->constblock.Const.ci - : imagp->constblock.Const.cd[0]; - } - } - else - { - err("invalid complex constant"); - p = (Constp)errnode(); - } - - frexpr(realp); - frexpr(imagp); - return( (expptr) p ); -} - - -/* errnode -- Allocate a new error block */ - - expptr -errnode(Void) -{ - struct Errorblock *p; - p = ALLOC(Errorblock); - p->tag = TERROR; - p->vtype = TYERROR; - return( (expptr) p ); -} - - - - - -/* mkconv -- Make type conversion. Cast expression p into type t. - Note that casting to a character copies only the first sizeof(char) - bytes. */ - - 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; - - if (t >= 100) { - t -= 100; - charwarn = 0; - } - if(t==TYUNKNOWN || t==TYERROR) - badtype("mkconv", t); - pt = p->headblock.vtype; - -/* Casting to the same type is a no-op */ - - if(t == pt) - return(p); - -/* If we're casting a constant which is not in the literal table ... */ - - else if( ISCONST(p) && pt!=TYADDR && pt != TYCHAR - || p->tag == TADDR && p->addrblock.uname_tag == UNAM_CONST) - { - if (ISINT(t) && ISINT(pt) || ISREAL(t) && ISREAL(pt)) { - /* avoid trouble with -i2 */ - p->headblock.vtype = t; - return p; - } - q = (expptr) mkconst(t); - consconv(t, &q->constblock, &p->constblock ); - if (p->tag == TADDR) - q->constblock.vstg = p->addrblock.user.kludge.vstg1; - frexpr(p); - } - else { - if (pt == TYCHAR && t != TYADDR && charwarn - && (!halign || p->tag != TADDR - || p->addrblock.uname_tag != UNAM_CONST)) - warn( - "ichar([first char. of] char. string) assumed for conversion to numeric"); - q = opconv(p, t); - } - - if(t == TYCHAR) - q->constblock.vleng = ICON(1); - return(q); -} - - - -/* opconv -- Convert expression p to type t using the main - expression evaluator; returns an OPCONV expression, I think 14-jun-88 mwm */ - - expptr -#ifdef KR_headers -opconv(p, t) - expptr p; - int t; -#else -opconv(expptr p, int t) -#endif -{ - register expptr q; - - if (t == TYSUBR) - err("illegal use of subroutine name"); - q = mkexpr(OPCONV, p, ENULL); - q->headblock.vtype = t; - return(q); -} - - - -/* addrof -- Create an ADDR expression operation */ - - expptr -#ifdef KR_headers -addrof(p) - expptr p; -#else -addrof(expptr p) -#endif -{ - return( mkexpr(OPADDR, p, ENULL) ); -} - - - -/* cpexpr - Returns a new copy of input expression 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; - -/* This table depends on the ordering of the T macros, e.g. TNAME */ - - static int blksize[ ] = - { - 0, - sizeof(struct Nameblock), - sizeof(struct Constblock), - sizeof(struct Exprblock), - sizeof(struct Addrblock), - sizeof(struct Primblock), - sizeof(struct Listblock), - sizeof(struct Impldoblock), - sizeof(struct Errorblock) - }; - - if(p == NULL) - return(NULL); - -/* TNAMEs are special, and don't get copied. Each name in the current - symbol table has a unique TNAME structure. */ - - if( (tag = p->tag) == TNAME) - return(p); - - e = cpblock(blksize[p->tag], (char *)p); - - switch(tag) - { - case TCONST: - if(e->constblock.vtype == TYCHAR) - { - e->constblock.Const.ccp = - copyn((int)e->constblock.vleng->constblock.Const.ci+1, - e->constblock.Const.ccp); - e->constblock.vleng = - (expptr) cpexpr(e->constblock.vleng); - } - case TERROR: - break; - - case TEXPR: - e->exprblock.leftp = (expptr) cpexpr(p->exprblock.leftp); - e->exprblock.rightp = (expptr) cpexpr(p->exprblock.rightp); - break; - - case TLIST: - if(pp = p->listblock.listp) - { - ep = e->listblock.listp = - mkchain((char *)cpexpr((tagptr)pp->datap), CHNULL); - for(pp = pp->nextp ; pp ; pp = pp->nextp) - ep = ep->nextp = - mkchain((char *)cpexpr((tagptr)pp->datap), - CHNULL); - } - break; - - case TADDR: - e->addrblock.vleng = (expptr) cpexpr(e->addrblock.vleng); - e->addrblock.memoffset = (expptr)cpexpr(e->addrblock.memoffset); - e->addrblock.istemp = NO; - break; - - case TPRIM: - e->primblock.argsp = (struct Listblock *) - cpexpr((expptr)e->primblock.argsp); - e->primblock.fcharp = (expptr) cpexpr(e->primblock.fcharp); - e->primblock.lcharp = (expptr) cpexpr(e->primblock.lcharp); - break; - - default: - badtag("cpexpr", tag); - } - - return(e); -} - -/* frexpr -- Free expression -- frees up memory used by expression p */ - - void -#ifdef KR_headers -frexpr(p) - register tagptr p; -#else -frexpr(register tagptr p) -#endif -{ - register chainp q; - - if(p == NULL) - return; - - switch(p->tag) - { - case TCONST: - if( ISCHAR(p) ) - { - free( (charptr) (p->constblock.Const.ccp) ); - frexpr(p->constblock.vleng); - } - break; - - case TADDR: - if (p->addrblock.vtype > TYERROR) /* i/o block */ - break; - frexpr(p->addrblock.vleng); - frexpr(p->addrblock.memoffset); - break; - - case TERROR: - break; - -/* TNAME blocks don't get free'd - probably because they're pointed to in - the hash table. 14-Jun-88 -- mwm */ - - case TNAME: - return; - - case TPRIM: - frexpr((expptr)p->primblock.argsp); - frexpr(p->primblock.fcharp); - frexpr(p->primblock.lcharp); - break; - - case TEXPR: - frexpr(p->exprblock.leftp); - if(p->exprblock.rightp) - frexpr(p->exprblock.rightp); - break; - - case TLIST: - for(q = p->listblock.listp ; q ; q = q->nextp) - frexpr((tagptr)q->datap); - frchain( &(p->listblock.listp) ); - break; - - default: - badtag("frexpr", p->tag); - } - - free( (charptr) p ); -} - - void -#ifdef KR_headers -wronginf(np) - Namep np; -#else -wronginf(Namep np) -#endif -{ - int c, k; - warn1("fixing wrong type inferred for %.65s", np->fvarname); - np->vinftype = 0; - c = letter(np->fvarname[0]); - if ((np->vtype = impltype[c]) == TYCHAR - && (k = implleng[c])) - np->vleng = ICON(k); - } - -/* fix up types in expression; replace subtrees and convert - names to address blocks */ - - expptr -#ifdef KR_headers -fixtype(p) - register tagptr p; -#else -fixtype(register tagptr p) -#endif -{ - - if(p == 0) - return(0); - - switch(p->tag) - { - case TCONST: - if(ONEOF(p->constblock.vtype,MSKINT|MSKLOGICAL|MSKADDR| - MSKREAL) ) - return( (expptr) p); - - return( (expptr) putconst((Constp)p) ); - - case TADDR: - p->addrblock.memoffset = fixtype(p->addrblock.memoffset); - return( (expptr) p); - - case TERROR: - return( (expptr) p); - - default: - badtag("fixtype", p->tag); - -/* This case means that fixexpr can't call fixtype with any expr, - only a subexpr of its parameter. */ - - case TEXPR: - if (((Exprp)p)->typefixed) - return (expptr)p; - return( fixexpr((Exprp)p) ); - - case TLIST: - return( (expptr) p ); - - case TPRIM: - if(p->primblock.argsp && p->primblock.namep->vclass!=CLVAR) - { - if(p->primblock.namep->vtype == TYSUBR) - { - err("function invocation of subroutine"); - return( errnode() ); - } - else { - if (p->primblock.namep->vinftype) - wronginf(p->primblock.namep); - return( mkfunct(p) ); - } - } - -/* The lack of args makes p a function name, substring reference - or variable name. */ - - else return mklhs((struct Primblock *) p, keepsubs); - } -} - - - int -#ifdef KR_headers -badchleng(p) - register expptr p; -#else -badchleng(register expptr p) -#endif -{ - if (!p->headblock.vleng) { - if (p->headblock.tag == TADDR - && p->addrblock.uname_tag == UNAM_NAME) - errstr("bad use of character*(*) variable %.60s", - p->addrblock.user.name->fvarname); - else - err("Bad use of character*(*)"); - return 1; - } - return 0; - } - - - static expptr -#ifdef KR_headers -cplenexpr(p) - expptr p; -#else -cplenexpr(expptr p) -#endif -{ - expptr rv; - - if (badchleng(p)) - return ICON(1); - rv = cpexpr(p->headblock.vleng); - if (ISCONST(p) && p->constblock.vtype == TYCHAR) - rv->constblock.Const.ci += p->constblock.Const.ccp1.blanks; - return rv; - } - - -/* special case tree transformations and cleanups of expression trees. - Parameter p should have a TEXPR tag at its root, else an error is - returned */ - - 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) || p->typefixed ) - return( (expptr) p ); - else if(p->tag != TEXPR) - badtag("fixexpr", p->tag); - opcode = p->opcode; - -/* First set the types of the left and right subexpressions */ - - lp = p->leftp; - if (!ISCONST(lp) || lp->constblock.vtype != TYCHAR) - lp = p->leftp = fixtype(lp); - ltype = lp->headblock.vtype; - - if(opcode==OPASSIGN && lp->tag!=TADDR) - { - err("left side of assignment must be variable"); - eret: - frexpr((expptr)p); - return( errnode() ); - } - - if(rp = p->rightp) - { - if (!ISCONST(rp) || rp->constblock.vtype != TYCHAR) - rp = p->rightp = fixtype(rp); - rtype = rp->headblock.vtype; - } - else - rtype = 0; - - if(ltype==TYERROR || rtype==TYERROR) - goto eret; - -/* Now work on the whole expression */ - - /* force folding if possible */ - - if( ISCONST(lp) && (rp==NULL || ISCONST(rp)) ) - { - q = opcode == OPCONV && lp->constblock.vtype == p->vtype - ? lp : mkexpr(opcode, lp, rp); - -/* mkexpr is expected to reduce constant expressions */ - - if( ISCONST(q) ) { - p->leftp = p->rightp = 0; - frexpr((expptr)p); - return(q); - } - free( (charptr) q ); /* constants did not fold */ - } - - if( (ptype = cktype(opcode, ltype, rtype)) == TYERROR) - 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); - - switch(opcode) - { - case OPCONCAT: - if(p->vleng == NULL) - p->vleng = mkexpr(OPPLUS, cplenexpr(lp), - cplenexpr(rp) ); - break; - - case OPASSIGN: - if (rtype == TYREAL || ISLOGICAL(ptype) - || rtype == TYDREAL && ltype == TYREAL && !ISCONST(rp)) - break; - case OPPLUSEQ: - case OPSTAREQ: - if(ltype == rtype) - break; - if( ! ISCONST(rp) && ISREAL(ltype) && ISREAL(rtype) ) - break; - if( ISCOMPLEX(ltype) || ISCOMPLEX(rtype) ) - break; - if( ONEOF(ltype, MSKADDR|MSKINT) && ONEOF(rtype, MSKADDR|MSKINT) - && typesize[ltype]>=typesize[rtype] ) - break; - -/* Cast the right hand side to match the type of the expression */ - - p->rightp = fixtype( mkconv(ptype, rp) ); - break; - - case OPSLASH: - if( ISCOMPLEX(rtype) ) - { - p = (Exprp) call2(ptype, - -/* Handle double precision complex variables */ - - ptype == TYCOMPLEX ? "c_div" : "z_div", - mkconv(ptype, lp), mkconv(ptype, rp) ); - break; - } - case OPPLUS: - case OPMINUS: - case OPSTAR: - case OPMOD: - if(ptype==TYDREAL && ( (ltype==TYREAL && ! ISCONST(lp) ) || - (rtype==TYREAL && ! ISCONST(rp) ) )) - break; - if( ISCOMPLEX(ptype) ) - break; - -/* Cast both sides of the expression to match the type of the whole - expression. */ - - if(ltype != ptype && (ltype < TYINT1 || ptype > TYDREAL)) - p->leftp = fixtype(mkconv(ptype,lp)); - if(rtype != ptype && (rtype < TYINT1 || ptype > TYDREAL)) - p->rightp = fixtype(mkconv(ptype,rp)); - break; - - case OPPOWER: - rp = mkpower((expptr)p); - if (rp->tag == TEXPR) - rp->exprblock.typefixed = 1; - return rp; - - case OPLT: - case OPLE: - case OPGT: - case OPGE: - case OPEQ: - case OPNE: - if(ltype == rtype) - break; - if (htype) { - if (ltype == TYCHAR) { - p->leftp = fixtype(mkconv(rtype,lp)); - break; - } - if (rtype == TYCHAR) { - p->rightp = fixtype(mkconv(ltype,rp)); - break; - } - } - mtype = cktype(OPMINUS, ltype, rtype); - if(mtype==TYDREAL && (ltype==TYREAL || rtype==TYREAL)) - break; - if( ISCOMPLEX(mtype) ) - break; - if(ltype != mtype) - p->leftp = fixtype(mkconv(mtype,lp)); - if(rtype != mtype) - p->rightp = fixtype(mkconv(mtype,rp)); - break; - - case OPCONV: - ptype = cktype(OPCONV, p->vtype, ltype); - if(lp->tag==TEXPR && lp->exprblock.opcode==OPCOMMA - && !ISCOMPLEX(ptype)) - { - lp->exprblock.rightp = - fixtype( mkconv(ptype, lp->exprblock.rightp) ); - free( (charptr) p ); - p = (Exprp) lp; - } - break; - - case OPADDR: - if(lp->tag==TEXPR && lp->exprblock.opcode==OPADDR) - Fatal("addr of addr"); - break; - - case OPCOMMA: - case OPQUEST: - case OPCOLON: - break; - - case OPMIN: - case OPMAX: - case OPMIN2: - case OPMAX2: - case OPDMIN: - case OPDMAX: - case OPABS: - case OPDABS: - ptype = p->vtype; - break; - - default: - break; - } - - 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; - 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; - - nargs = 0; - if(p0) - for(p = p0->listp ; p ; p = p->nextp) - { - ++nargs; - q = (tagptr)p->datap; - qtag = q->tag; - if(qtag == TCONST) - { - -/* Call putconst() to store values in a constant table. Since even - constants must be passed by reference, this can optimize on the storage - required */ - - p->datap = doput ? (char *)putconst((Constp)q) - : (char *)q; - continue; - } - -/* Take a function name and turn it into an Addr. This only happens when - nothing else has figured out the function beforehand */ - - if (qtag == TPRIM && q->primblock.argsp == 0) { - if (q->primblock.namep->vclass==CLPROC - && q->primblock.namep->vprocclass != PTHISPROC) { - p->datap = (char *)mkaddr(q->primblock.namep); - continue; - } - - if (q->primblock.namep->vdim != NULL) { - p->datap = (char *)mkscalar(q->primblock.namep); - if ((q->primblock.fcharp||q->primblock.lcharp) - && (q->primblock.namep->vtype != TYCHAR - || q->primblock.namep->vdim)) - sserr(q->primblock.namep); - continue; - } - - if (q->primblock.namep->vdovar - && (t = (tagptr) memversion(q->primblock.namep))) { - p->datap = (char *)fixtype(t); - continue; - } - } - p->datap = (char *)fixtype(q); - } - return(nargs); -} - - - -/* mkscalar -- only called by fixargs above, and by some routines in - io.c */ - - Addrp -#ifdef KR_headers -mkscalar(np) - register Namep np; -#else -mkscalar(register Namep np) -#endif -{ - register Addrp ap; - - vardcl(np); - ap = mkaddr(np); - - /* The prolog causes array arguments to point to the - * (0,...,0) element, unless subscript checking is on. - */ - if( !checksubs && np->vstg==STGARG) - { - register struct Dimblock *dp; - dp = np->vdim; - frexpr(ap->memoffset); - ap->memoffset = mkexpr(OPSTAR, - (np->vtype==TYCHAR ? - cpexpr(np->vleng) : - (tagptr)ICON(typesize[np->vtype]) ), - cpexpr(dp->baseoffset) ); - } - return(ap); -} - - - static void -#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 */ -{ - struct Entrypoint *ep; - register chainp args; - Argtypes *at; - - for(ep = entries; ep; ep = ep->entnextp) - for(args = ep->arglist; args; args = args->nextp) - if (np == (Namep)args->datap - && (at = ep->entryname->arginfo)) - --at->nargs; - } - - - expptr -#ifdef KR_headers -mkfunct(p0) - expptr p0; -#else -mkfunct(expptr p0) -#endif -{ - register struct Primblock *p = (struct Primblock *)p0; - struct Entrypoint *ep; - Addrp ap; - Extsym *extp; - register Namep np; - register expptr q; - extern chainp new_procs; - int k, nargs; - int class; - - if(p->tag != TPRIM) - return( errnode() ); - - np = p->namep; - class = np->vclass; - - - if(class == CLUNKNOWN) - { - np->vclass = class = CLPROC; - if(np->vstg == STGUNKNOWN) - { - if(np->vtype!=TYSUBR && (k = intrfunct(np->fvarname)) - && (zflag || !(*(struct Intrpacked *)&k).f4 - || dcomplex_seen)) - { - np->vstg = STGINTR; - np->vardesc.varno = k; - np->vprocclass = PINTRINSIC; - } - else - { - extp = mkext(np->fvarname, - addunder(np->cvarname)); - extp->extstg = STGEXT; - np->vstg = STGEXT; - np->vardesc.varno = extp - extsymtab; - np->vprocclass = PEXTERNAL; - } - } - else if(np->vstg==STGARG) - { - if(np->vtype == TYCHAR) { - adjust_arginfo(np); - if (np->vpassed) { - char wbuf[160], *who; - who = np->fvarname; - sprintf(wbuf, "%s%s%s\n\t%s%s%s", - "Character-valued dummy procedure ", - who, " not declared EXTERNAL.", - "Code may be wrong for previous function calls having ", - who, " as a parameter."); - warn(wbuf); - } - } - np->vprocclass = PEXTERNAL; - } - } - - if(class != CLPROC) { - if (np->vstg == STGCOMMON) - fatalstr( - "Cannot invoke common variable %.50s as a function.", - np->fvarname); - errstr("%.80s cannot be called.", np->fvarname); - goto error; - } - -/* F77 doesn't allow subscripting of function calls */ - - if(p->fcharp || p->lcharp) - { - err("no substring of function call"); - goto error; - } - impldcl(np); - np->vimpltype = 0; /* invoking as function ==> inferred type */ - np->vcalled = 1; - nargs = fixargs( np->vprocclass!=PINTRINSIC, p->argsp); - - switch(np->vprocclass) - { - case PEXTERNAL: - if(np->vtype == TYUNKNOWN) - { - dclerr("attempt to use untyped function", np); - np->vtype = dflttype[letter(np->fvarname[0])]; - } - ap = mkaddr(np); - if (!extsymtab[np->vardesc.varno].extseen) { - new_procs = mkchain((char *)np, new_procs); - extsymtab[np->vardesc.varno].extseen = 1; - } -call: - q = mkexpr(OPCALL, (expptr)ap, (expptr)p->argsp); - q->exprblock.vtype = np->vtype; - if(np->vleng) - q->exprblock.vleng = (expptr) cpexpr(np->vleng); - break; - - case PINTRINSIC: - q = intrcall(np, p->argsp, nargs); - break; - - case PSTFUNCT: - q = stfcall(np, p->argsp); - break; - - case PTHISPROC: - warn("recursive call"); - -/* entries is the list of multiple entry points */ - - for(ep = entries ; ep ; ep = ep->entnextp) - if(ep->enamep == np) - break; - if(ep == NULL) - Fatal("mkfunct: impossible recursion"); - - ap = builtin(np->vtype, ep->entryname->cextname, -2); - /* the negative last arg prevents adding */ - /* this name to the list of used builtins */ - goto call; - - default: - fatali("mkfunct: impossible vprocclass %d", - (int) (np->vprocclass) ); - } - free( (charptr) p ); - return(q); - -error: - frexpr((expptr)p); - return( errnode() ); -} - - - - 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; - chainp oactp, formals; - int type; - expptr Ln, Lq, q, q1, rhs, ap; - Namep tnp; - register struct Rplblock *rp; - struct Rplblock *tlist; - - 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; - free( (charptr) actlist); - } - else - actuals = NULL; - oactp = actuals; - - nargs = 0; - tlist = NULL; - if( (type = np->vtype) == TYUNKNOWN) - { - dclerr("attempt to use untyped statement function", np); - type = np->vtype = dflttype[letter(np->fvarname[0])]; - } - formals = (chainp) np->varxptr.vstfdesc->datap; - rhs = (expptr) (np->varxptr.vstfdesc->nextp); - - /* 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; - ap = fixtype((tagptr)actuals->datap); - if(tnp->vtype==ap->headblock.vtype && tnp->vtype!=TYCHAR - && (ap->tag==TCONST || ap->tag==TADDR) ) - { - -/* If actuals are constants or variable names, no temporaries are required */ - rp->rplvp = (expptr) ap; - rp->rplxp = NULL; - rp->rpltag = ap->tag; - } - else { - rp->rplvp = (expptr) mktmp(tnp->vtype, tnp->vleng); - rp -> rplxp = NULL; - putexpr ( mkexpr(OPASSIGN, cpexpr(rp->rplvp), ap)); - if((rp->rpltag = rp->rplvp->tag) == TERROR) - err("disagreement of argument types in statement function call"); - } - rp->rplnextp = tlist; - tlist = rp; - actuals = actuals->nextp; - formals = formals->nextp; - ++nargs; - } - - if(actuals!=NULL || formals!=NULL) - err("statement function definition and argument list differ"); - - /* - now push down names involved in formal argument list, then - evaluate rhs of statement function definition in this environment -*/ - - if(tlist) /* put tlist in front of the rpllist */ - { - for(rp = tlist; rp->rplnextp; rp = rp->rplnextp) - ; - rp->rplnextp = rpllist; - rpllist = tlist; - } - -/* So when the expression finally gets evaled, that evaluator must read - from the globl rpllist 14-jun-88 mwm */ - - q = (expptr) mkconv(type, fixtype(cpexpr(rhs)) ); - - /* get length right of character-valued statement functions... */ - if (type == TYCHAR - && (Ln = np->vleng) - && q->tag != TERROR - && (Lq = q->exprblock.vleng) - && (Lq->tag != TCONST - || Ln->constblock.Const.ci != Lq->constblock.Const.ci)) { - q1 = (expptr) mktmp(type, Ln); - putexpr ( mkexpr(OPASSIGN, cpexpr(q1), q)); - q = q1; - } - - /* now generate the tree ( t1=a1, (t2=a2,... , f))))) */ - while(--nargs >= 0) - { - if(rpllist->rplxp) - q = mkexpr(OPCOMMA, rpllist->rplxp, q); - rp = rpllist->rplnextp; - frexpr(rpllist->rplvp); - free((char *)rpllist); - rpllist = rp; - } - done: - frchain( &oactp ); - np->arginfo = 0; - return(q); -} - - -static int replaced; - -/* mkplace -- Figure out the proper storage class for the input name and - return an addrp with the appropriate stuff */ - - Addrp -#ifdef KR_headers -mkplace(np) - register Namep np; -#else -mkplace(register Namep np) -#endif -{ - register Addrp s; - register struct Rplblock *rp; - int regn; - - /* is name on the replace list? */ - - for(rp = rpllist ; rp ; rp = rp->rplnextp) - { - if(np == rp->rplnp) - { - replaced = 1; - if(rp->rpltag == TNAME) - { - np = (Namep) (rp->rplvp); - break; - } - else return( (Addrp) cpexpr(rp->rplvp) ); - } - } - - /* is variable a DO index in a register ? */ - - if(np->vdovar && ( (regn = inregister(np)) >= 0) ) - if(np->vtype == TYERROR) - return((Addrp) errnode() ); - else - { - s = ALLOC(Addrblock); - s->tag = TADDR; - s->vstg = STGREG; - s->vtype = TYIREG; - s->memno = regn; - s->memoffset = ICON(0); - s -> uname_tag = UNAM_NAME; - s -> user.name = np; - return(s); - } - - if (np->vclass == CLPROC && np->vprocclass != PTHISPROC) - errstr("external %.60s used as a variable", np->fvarname); - vardcl(np); - return(mkaddr(np)); -} - - static expptr -#ifdef KR_headers -subskept(p, a) - struct Primblock *p; - Addrp a; -#else -subskept(struct Primblock *p, Addrp a) -#endif -{ - expptr ep; - struct Listblock *Lb; - chainp cp; - - if (a->uname_tag != UNAM_NAME) - erri("subskept: uname_tag %d", a->uname_tag); - a->user.name->vrefused = 1; - a->user.name->visused = 1; - a->uname_tag = UNAM_REF; - Lb = (struct Listblock *)cpexpr((tagptr)p->argsp); - for(cp = Lb->listp; cp; cp = cp->nextp) - cp->datap = (char *)putx(fixtype((tagptr)cp->datap)); - if (a->vtype == TYCHAR) { - ep = p->fcharp ? mkexpr(OPMINUS, cpexpr(p->fcharp), ICON(1)) - : ICON(0); - Lb->listp = mkchain((char *)ep, Lb->listp); - } - return (expptr)Lb; - } - - static int doing_vleng; - -/* mklhs -- Compute the actual address of the given expression; account - for array subscripts, stack offset, and substring offsets. The f -> C - translator will need this only to worry about the subscript stuff */ - - expptr -#ifdef KR_headers -mklhs(p, subkeep) - register struct Primblock *p; - int subkeep; -#else -mklhs(register struct Primblock *p, int subkeep) -#endif -{ - register Addrp s; - Namep np; - - if(p->tag != TPRIM) - return( (expptr) p ); - np = p->namep; - - replaced = 0; - s = mkplace(np); - if(s->tag!=TADDR || s->vstg==STGREG) - { - free( (charptr) p ); - return( (expptr) s ); - } - s->parenused = p->parenused; - - /* compute the address modified by subscripts */ - - if (!replaced) - s->memoffset = (subkeep && np->vdim - && (np->vdim->ndim > 1 || np->vtype == TYCHAR - && (!ISCONST(np->vleng) - || np->vleng->constblock.Const.ci != 1))) - ? subskept(p,s) - : mkexpr(OPPLUS, s->memoffset, suboffset(p) ); - frexpr((expptr)p->argsp); - p->argsp = NULL; - - /* now do substring part */ - - if(p->fcharp || p->lcharp) - { - if(np->vtype != TYCHAR) - sserr(np); - else { - if(p->lcharp == NULL) - p->lcharp = (expptr)( - /* s->vleng == 0 only with errors */ - s->vleng ? cpexpr(s->vleng) : ICON(1)); - if(p->fcharp) { - doing_vleng = 1; - s->vleng = fixtype(mkexpr(OPMINUS, - p->lcharp, - mkexpr(OPMINUS, p->fcharp, ICON(1) ))); - doing_vleng = 0; - } - else { - frexpr(s->vleng); - s->vleng = p->lcharp; - } - } - } - - s->vleng = fixtype( s->vleng ); - s->memoffset = fixtype( s->memoffset ); - free( (charptr) p ); - return( (expptr) s ); -} - - - - - -/* 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; -#else -deregister(Namep np) -#endif -{ - if(nregvar>0 && regnamep[nregvar-1]==np) - { - --nregvar; - } -} - - - - -/* memversion -- moves a DO index REGISTER into a memory location; other - objects are passed through untouched */ - - Addrp -#ifdef KR_headers -memversion(np) - register Namep np; -#else -memversion(register Namep np) -#endif -{ - register Addrp s; - - if(np->vdovar==NO || (inregister(np)<0) ) - return(NULL); - np->vdovar = NO; - s = mkplace(np); - np->vdovar = YES; - return(s); -} - - - -/* inregister -- looks for the input name in the global list regnamep */ - - int -#ifdef KR_headers -inregister(np) - register Namep np; -#else -inregister(register Namep np) -#endif -{ - register int i; - - for(i = 0 ; i < nregvar ; ++i) - if(regnamep[i] == np) - return( regnum[i] ); - return(-1); -} - - - -/* suboffset -- Compute the offset from the start of the array, given the - subscripts as arguments */ - - 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; - struct Dimblock *dimp; - expptr sub[MAXDIM+1]; - register Namep np; - - np = p->namep; - offp = ICON(0); - n = 0; - if(p->argsp) - for(cp = p->argsp->listp ; cp ; cp = cp->nextp) - { - si = fixtype(cpexpr((tagptr)cp->datap)); - if (!ISINT(si->headblock.vtype)) { - NOEXT("non-integer subscript"); - si = mkconv(TYLONG, si); - } - sub[n++] = si; - if(n > maxdim) - { - erri("more than %d subscripts", maxdim); - break; - } - } - - dimp = np->vdim; - if(n>0 && dimp==NULL) - errstr("subscripts on scalar variable %.68s", np->fvarname); - else if(dimp && dimp->ndim!=n) - errstr("wrong number of subscripts on %.68s", np->fvarname); - else if(n > 0) - { - prod = sub[--n]; - while( --n >= 0) - prod = mkexpr(OPPLUS, sub[n], - mkexpr(OPSTAR, prod, cpexpr(dimp->dims[n].dimsize)) ); - if(checksubs || np->vstg!=STGARG) - prod = mkexpr(OPMINUS, prod, cpexpr(dimp->baseoffset)); - -/* Add in the run-time bounds check */ - - if(checksubs) - prod = subcheck(np, prod); - size = np->vtype == TYCHAR ? - (expptr) cpexpr(np->vleng) : ICON(typesize[np->vtype]); - prod = mkexpr(OPSTAR, prod, size); - offp = mkexpr(OPPLUS, offp, prod); - } - -/* Check for substring indicator */ - - if(p->fcharp && np->vtype==TYCHAR) { - e = p->fcharp; - e1 = mkexpr(OPMINUS, cpexpr(e), ICON(1)); - if (!ISCONST(e) && (e->tag != TPRIM || e->primblock.argsp)) { - e = (expptr)mktmp(TYLONG, ENULL); - putout(putassign(cpexpr(e), e1)); - p->fcharp = mkexpr(OPPLUS, cpexpr(e), ICON(1)); - e1 = e; - } - offp = mkexpr(OPPLUS, offp, e1); - } - return(offp); -} - - - - - 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; - - dimp = np->vdim; - if(dimp->nelt == NULL) - return(p); /* don't check arrays with * bounds */ - np->vlastdim = 0; - if( ISICON(p) ) - { - -/* check for negative (constant) offset */ - - if(p->constblock.Const.ci < 0) - goto badsub; - if( ISICON(dimp->nelt) ) - -/* see if constant offset exceeds the array declaration */ - - if(p->constblock.Const.ci < dimp->nelt->constblock.Const.ci) - return(p); - else - goto badsub; - } - -/* We know that the subscript offset p or dimp -> nelt is not a constant. - Now find a register to use for run-time bounds checking */ - - if(p->tag==TADDR && p->addrblock.vstg==STGREG) - { - checkvar = (expptr) cpexpr(p); - t = p; - } - else { - checkvar = (expptr) mktmp(p->headblock.vtype, ENULL); - t = mkexpr(OPASSIGN, cpexpr(checkvar), p); - } - checkcond = mkexpr(OPLT, t, cpexpr(dimp->nelt) ); - if( ! ISICON(p) ) - checkcond = mkexpr(OPAND, checkcond, - mkexpr(OPLE, ICON(0), cpexpr(checkvar)) ); - -/* Construct the actual test */ - - badcall = call4(p->headblock.vtype, "s_rnge", - mkstrcon(strlen(np->fvarname), np->fvarname), - mkconv(TYLONG, cpexpr(checkvar)), - mkstrcon(strlen(procname), procname), - ICON(lineno) ); - badcall->exprblock.opcode = OPCCALL; - p = mkexpr(OPQUEST, checkcond, - mkexpr(OPCOLON, checkvar, badcall)); - - return(p); - -badsub: - frexpr(p); - errstr("subscript on variable %s out of range", np->fvarname); - return ( ICON(0) ); -} - - - - - Addrp -#ifdef KR_headers -mkaddr(p) - register Namep p; -#else -mkaddr(register Namep p) -#endif -{ - Extsym *extp; - register Addrp t; - int k; - - switch( p->vstg) - { - case STGAUTO: - if(p->vclass == CLPROC && p->vprocclass == PTHISPROC) - return (Addrp) cpexpr((expptr)xretslot[p->vtype]); - goto other; - - case STGUNKNOWN: - if(p->vclass != CLPROC) - break; /* Error */ - extp = mkext(p->fvarname, addunder(p->cvarname)); - extp->extstg = STGEXT; - p->vstg = STGEXT; - p->vardesc.varno = extp - extsymtab; - p->vprocclass = PEXTERNAL; - if ((extp->exproto || infertypes) - && (p->vtype == TYUNKNOWN || p->vimpltype) - && (k = extp->extype)) - inferdcl(p, k); - - - case STGCOMMON: - case STGEXT: - case STGBSS: - case STGINIT: - case STGEQUIV: - case STGARG: - case STGLENG: - other: - t = ALLOC(Addrblock); - t->tag = TADDR; - - t->vclass = p->vclass; - t->vtype = p->vtype; - t->vstg = p->vstg; - t->memno = p->vardesc.varno; - t->memoffset = ICON(p->voffset); - if (p->vdim) - t->isarray = 1; - if(p->vleng) - { - t->vleng = (expptr) cpexpr(p->vleng); - if( ISICON(t->vleng) ) - t->varleng = t->vleng->constblock.Const.ci; - } - -/* Keep the original name around for the C code generation */ - - t -> uname_tag = UNAM_NAME; - t -> user.name = p; - return(t); - - 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; -} - - - - -/* mkarg -- create storage for a new parameter. This is called when a - 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 -#ifdef KR_headers -mkarg(type, argno) - int type; - int argno; -#else -mkarg(int type, int argno) -#endif -{ - register Addrp p; - - p = ALLOC(Addrblock); - p->tag = TADDR; - p->vtype = type; - p->vclass = CLVAR; - -/* TYLENG is the type of the field holding the length of a character string */ - - p->vstg = (type==TYLENG ? STGLENG : STGARG); - p->memno = argno; - return(p); -} - - - - -/* mkprim -- Create a PRIM (primary/primitive) block consisting of a - Nameblock (or Paramblock), arguments (actual params or array - subscripts) and substring bounds. Requires that v have lots of - extra (uninitialized) storage, since it could be a paramblock or - nameblock */ - - 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; - struct Nameblock nameblock; - struct Headblock headblock; - } *Primu; - register Primu v = (Primu)v0; - register struct Primblock *p; - - if(v->headblock.vclass == CLPARAM) - { - -/* v is to be a Paramblock */ - - if(args || substr) - { - errstr("no qualifiers on parameter name %s", - v->paramblock.fvarname); - frexpr((expptr)args); - if(substr) - { - frexpr((tagptr)substr->datap); - frexpr((tagptr)substr->nextp->datap); - frchain(&substr); - } - frexpr((expptr)v); - return( errnode() ); - } - return( (expptr) cpexpr(v->paramblock.paramval) ); - } - - p = ALLOC(Primblock); - p->tag = TPRIM; - p->vtype = v->nameblock.vtype; - -/* v is to be a Nameblock */ - - p->namep = (Namep) v; - p->argsp = args; - if(substr) - { - p->fcharp = (expptr) substr->datap; - p->lcharp = (expptr) substr->nextp->datap; - frchain(&substr); - } - return( (expptr) p); -} - - - -/* vardcl -- attempt to fill out the Name template for variable v. - 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; -#else -vardcl(register Namep v) -#endif -{ - struct Dimblock *t; - expptr neltp; - extern int doing_stmtfcn; - - if(v->vclass == CLUNKNOWN) { - v->vclass = CLVAR; - if (v->vinftype) { - v->vtype = TYUNKNOWN; - if (v->vdcldone) { - v->vdcldone = 0; - impldcl(v); - } - } - } - if(v->vdcldone) - return; - if(v->vclass == CLNAMELIST) - return; - - if(v->vtype == TYUNKNOWN) - impldcl(v); - else if(v->vclass!=CLVAR && v->vprocclass!=PTHISPROC) - { - dclerr("used as variable", v); - return; - } - if(v->vstg==STGUNKNOWN) { - if (doing_stmtfcn) { - /* neither declare this variable if its only use */ - /* is in defining a stmt function, nor complain */ - /* that it is never used */ - v->vimpldovar = 1; - return; - } - v->vstg = implstg[ letter(v->fvarname[0]) ]; - v->vimplstg = 1; - } - -/* Compute the actual storage location, i.e. offsets from base addresses, - possibly the stack pointer */ - - switch(v->vstg) - { - case STGBSS: - v->vardesc.varno = ++lastvarno; - break; - case STGAUTO: - if(v->vclass==CLPROC && v->vprocclass==PTHISPROC) - break; - if(t = v->vdim) - if( (neltp = t->nelt) && ISCONST(neltp) ) ; - else - dclerr("adjustable automatic array", v); - break; - - default: - break; - } - v->vdcldone = YES; -} - - - -/* Set the implicit type declaration of parameter p based on its first - letter */ - - void -#ifdef KR_headers -impldcl(p) - register Namep p; -#else -impldcl(register Namep p) -#endif -{ - register int k; - int type; - ftnint leng; - - if(p->vdcldone || (p->vclass==CLPROC && p->vprocclass==PINTRINSIC) ) - return; - if(p->vtype == TYUNKNOWN) - { - k = letter(p->fvarname[0]); - type = impltype[ k ]; - leng = implleng[ k ]; - if(type == TYUNKNOWN) - { - if(p->vclass == CLPROC) - return; - dclerr("attempt to use undefined variable", p); - type = dflttype[k]; - leng = 0; - } - settype(p, type, leng); - p->vimpltype = 1; - } -} - - void -#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) { - np->vinftype = 1; - np->vtype = type; - frexpr(np->vleng); - np->vleng = 0; - } - np->vimpltype = 0; - 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; - - 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 -#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; - if(rp && opcode!=OPCALL && opcode!=OPCCALL) - { - rtype = rp->headblock.vtype; - rtag = rp->tag; - } - else rtype = 0; - - etype = cktype(opcode, ltype, rtype); - if(etype == TYERROR) - goto error; - - switch(opcode) - { - /* check for multiplication by 0 and 1 and addition to 0 */ - - case OPSTAR: - if( ISCONST(lp) ) - COMMUTE - - if( ISICON(rp) ) - { - if(rp->constblock.Const.ci == 0) - goto retright; - goto mulop; - } - break; - - case OPSLASH: - case OPMOD: - if( zeroconst(rp) && lineno != divlineno ) { - warn("attempted division by zero"); - divlineno = lineno; - } - if(opcode == OPMOD) - break; - -/* Handle multiplying or dividing by 1, -1 */ - -mulop: - if( ISICON(rp) ) - { - if(rp->constblock.Const.ci == 1) - goto retleft; - - if(rp->constblock.Const.ci == -1) - { - frexpr(rp); - return( mkexpr(OPNEG, lp, ENULL) ); - } - } - -/* Group all constants together. In particular, - - (x * CONST1) * CONST2 ==> x * (CONST1 * CONST2) - (x * CONST1) / CONST2 ==> x * (CONST1 / CONST2) -*/ - - if (!ISINT(etype) || lp->tag != TEXPR || !lp->exprblock.rightp - || !ISICON(lp->exprblock.rightp)) - break; - - if (lp->exprblock.opcode == OPLSHIFT) { - L = 1 << lp->exprblock.rightp->constblock.Const.ci; - if (opcode == OPSTAR || ISICON(rp) && - !(L % rp->constblock.Const.ci)) { - lp->exprblock.opcode = OPSTAR; - lp->exprblock.rightp->constblock.Const.ci = L; - } - } - - if (lp->exprblock.opcode == OPSTAR) { - if(opcode == OPSTAR) - e = mkexpr(OPSTAR, lp->exprblock.rightp, rp); - else if(ISICON(rp) && - (lp->exprblock.rightp->constblock.Const.ci % - rp->constblock.Const.ci) == 0) - e = mkexpr(OPSLASH, lp->exprblock.rightp, rp); - else break; - - e1 = lp->exprblock.leftp; - free( (charptr) lp ); - return( mkexpr(OPSTAR, e1, e) ); - } - break; - - - case OPPLUS: - if( ISCONST(lp) ) - COMMUTE - goto addop; - - case OPMINUS: - if( ICONEQ(lp, 0) ) - { - frexpr(lp); - return( mkexpr(OPNEG, rp, ENULL) ); - } - - if( ISCONST(rp) && is_negatable((Constp)rp)) - { - opcode = OPPLUS; - consnegop((Constp)rp); - } - -/* Group constants in an addition expression (also subtraction, since the - subtracted value was negated above). In particular, - - (x + CONST1) + CONST2 ==> x + (CONST1 + CONST2) -*/ - -addop: - if( ISICON(rp) ) - { - if(rp->constblock.Const.ci == 0) - goto retleft; - if( ISPLUSOP(lp) && ISICON(lp->exprblock.rightp) ) - { - e = mkexpr(OPPLUS, lp->exprblock.rightp, rp); - e1 = lp->exprblock.leftp; - free( (charptr) lp ); - return( mkexpr(OPPLUS, e1, e) ); - } - } - if (opcode == OPMINUS && (ISINT(etype) || doing_vleng)) { - /* check for (i [+const]) - (i [+const]) */ - if (lp->tag == TPRIM) - e = lp; - else if (lp->tag == TEXPR && lp->exprblock.opcode == OPPLUS - && lp->exprblock.rightp->tag == TCONST) { - e = lp->exprblock.leftp; - if (e->tag != TPRIM) - break; - } - else - break; - if (e->primblock.argsp) - break; - if (rp->tag == TPRIM) - e1 = rp; - else if (rp->tag == TEXPR && rp->exprblock.opcode == OPPLUS - && rp->exprblock.rightp->tag == TCONST) { - e1 = rp->exprblock.leftp; - if (e1->tag != TPRIM) - break; - } - else - break; - if (e->primblock.namep != e1->primblock.namep - || e1->primblock.argsp) - break; - L = e == lp ? 0 : lp->exprblock.rightp->constblock.Const.ci; - if (e1 != rp) - L -= rp->exprblock.rightp->constblock.Const.ci; - frexpr(lp); - frexpr(rp); - return ICON(L); - } - - break; - - - case OPPOWER: - break; - -/* Eliminate outermost double negations */ - - case OPNEG: - case OPNEG1: - if(ltag==TEXPR && lp->exprblock.opcode==OPNEG) - { - e = lp->exprblock.leftp; - free( (charptr) lp ); - return(e); - } - break; - -/* Eliminate outermost double NOTs */ - - case OPNOT: - if(ltag==TEXPR && lp->exprblock.opcode==OPNOT) - { - e = lp->exprblock.leftp; - free( (charptr) lp ); - return(e); - } - break; - - case OPCALL: - case OPCCALL: - etype = ltype; - if(rp!=NULL && rp->listblock.listp==NULL) - { - free( (charptr) rp ); - rp = NULL; - } - break; - - case OPAND: - case OPOR: - if( ISCONST(lp) ) - COMMUTE - - if( ISCONST(rp) ) - { - if(rp->constblock.Const.ci == 0) - if(opcode == OPOR) - goto retleft; - else - goto retright; - else if(opcode == OPOR) - goto retright; - else - goto retleft; - } - case OPEQV: - case OPNEQV: - - case OPBITAND: - case OPBITOR: - case OPBITXOR: - case OPBITNOT: - case OPLSHIFT: - case OPRSHIFT: - case OPBITTEST: - case OPBITCLR: - case OPBITSET: -#ifdef TYQUAD - case OPQBITCLR: - case OPQBITSET: -#endif - - case OPLT: - case OPGT: - case OPLE: - case OPGE: - case OPEQ: - case OPNE: - - case OPCONCAT: - break; - case OPMIN: - case OPMAX: - case OPMIN2: - case OPMAX2: - case OPDMIN: - case OPDMAX: - - case OPASSIGN: - case OPASSIGNI: - case OPPLUSEQ: - case OPSTAREQ: - case OPMINUSEQ: - case OPSLASHEQ: - case OPMODEQ: - case OPLSHIFTEQ: - case OPRSHIFTEQ: - case OPBITANDEQ: - case OPBITXOREQ: - case OPBITOREQ: - - case OPCONV: - case OPADDR: - case OPWHATSIN: - - case OPCOMMA: - case OPCOMMA_ARG: - case OPQUEST: - case OPCOLON: - case OPDOT: - case OPARROW: - case OPIDENTITY: - case OPCHARCAST: - case OPABS: - case OPDABS: - break; - - default: - badop("mkexpr", opcode); - } - - e = (expptr) ALLOC(Exprblock); - e->exprblock.tag = TEXPR; - e->exprblock.opcode = opcode; - e->exprblock.vtype = etype; - e->exprblock.leftp = lp; - e->exprblock.rightp = rp; - if(ltag==TCONST && (rp==0 || rtag==TCONST) ) - e = fold(e); - return(e); - -retleft: - frexpr(rp); - if (lp->tag == TPRIM) - lp->primblock.parenused = 1; - return(lp); - -retright: - frexpr(lp); - if (rp->tag == TPRIM) - rp->primblock.parenused = 1; - return(rp); - -error: - frexpr(lp); - if(rp && opcode!=OPCALL && opcode!=OPCCALL) - frexpr(rp); - return( errnode() ); -} - -#define ERR(s) { errs = s; goto error; } - -/* cktype -- Check and return the type of the expression */ - -#ifdef KR_headers -cktype(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; - - if(lt==TYERROR || rt==TYERROR) - goto error1; - - if(lt==TYUNKNOWN) - return(TYUNKNOWN); - if(rt==TYUNKNOWN) - -/* If not unary operation, return UNKNOWN */ - - if(!is_unary_op (op) && op != OPCALL && op != OPCCALL) - return(TYUNKNOWN); - - switch(op) - { - case OPPLUS: - case OPMINUS: - case OPSTAR: - case OPSLASH: - case OPPOWER: - case OPMOD: - if( ISNUMERIC(lt) && ISNUMERIC(rt) ) - return( maxtype(lt, rt) ); - ERR("nonarithmetic operand of arithmetic operator") - - case OPNEG: - case OPNEG1: - if( ISNUMERIC(lt) ) - return(lt); - ERR("nonarithmetic operand of negation") - - case OPNOT: - if(ISLOGICAL(lt)) - return(lt); - ERR("NOT of nonlogical") - - case OPAND: - case OPOR: - case OPEQV: - case OPNEQV: - if(ISLOGICAL(lt) && ISLOGICAL(rt)) - return( maxtype(lt, rt) ); - ERR("nonlogical operand of logical operator") - - case OPLT: - case OPGT: - case OPLE: - case OPGE: - case OPEQ: - case OPNE: - if(lt==TYCHAR || rt==TYCHAR || ISLOGICAL(lt) || ISLOGICAL(rt)) - { - if(lt != rt){ - if (htype - && (lt == TYCHAR && ISNUMERIC(rt) - || rt == TYCHAR && ISNUMERIC(lt))) - return TYLOGICAL; - ERR("illegal comparison") - } - } - - else if( ISCOMPLEX(lt) || ISCOMPLEX(rt) ) - { - if(op!=OPEQ && op!=OPNE) - ERR("order comparison of complex data") - } - - else if( ! ISNUMERIC(lt) || ! ISNUMERIC(rt) ) - ERR("comparison of nonarithmetic data") - case OPBITTEST: - return(TYLOGICAL); - - case OPCONCAT: - if(lt==TYCHAR && rt==TYCHAR) - return(TYCHAR); - ERR("concatenation of nonchar data") - - case OPCALL: - case OPCCALL: - case OPIDENTITY: - return(lt); - - case OPADDR: - case OPCHARCAST: - return(TYADDR); - - case OPCONV: - if(rt == 0) - return(0); - if(lt==TYCHAR && ISINT(rt) ) - return(TYCHAR); - if (ISLOGICAL(lt) && ISLOGICAL(rt)) - return lt; - case OPASSIGN: - case OPASSIGNI: - case OPMINUSEQ: - case OPPLUSEQ: - case OPSTAREQ: - case OPSLASHEQ: - case OPMODEQ: - case OPLSHIFTEQ: - case OPRSHIFTEQ: - case OPBITANDEQ: - case OPBITXOREQ: - case OPBITOREQ: - if( ISINT(lt) && rt==TYCHAR) - return(lt); - if (ISLOGICAL(lt) && ISLOGICAL(rt) && op == OPASSIGN) - return lt; - if(lt==TYCHAR || rt==TYCHAR || ISLOGICAL(lt) || ISLOGICAL(rt)) - if((op!=OPASSIGN && op != OPPLUSEQ && op != OPMINUSEQ) - || (lt!=rt)) - { - ERR("impossible conversion") - } - return(lt); - - case OPMIN: - case OPMAX: - case OPDMIN: - case OPDMAX: - case OPMIN2: - case OPMAX2: - case OPBITOR: - case OPBITAND: - case OPBITXOR: - case OPBITNOT: - case OPLSHIFT: - case OPRSHIFT: - case OPWHATSIN: - case OPABS: - case OPDABS: - return(lt); - - case OPBITCLR: - case OPBITSET: - if (lt < TYLONG) - lt = TYLONG; - return(lt); -#ifdef TYQUAD - case OPQBITCLR: - case OPQBITSET: - return TYQUAD; -#endif - - case OPCOMMA: - case OPCOMMA_ARG: - case OPQUEST: - case OPCOLON: /* Only checks the rightmost type because - of C language definition (rightmost - comma-expr is the value of the expr) */ - return(rt); - - case OPDOT: - case OPARROW: - return (lt); - default: - badop("cktype", op); - } -error: - err(errs); -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 */ - - expptr -#ifdef KR_headers -fold(e) - register expptr e; -#else -fold(register expptr e) -#endif -{ - Constp p; - register expptr lp, rp; - int etype, mtype, ltype, rtype, opcode; - int i, bl, ll, lr; - char *q, *s; - struct Constblock lcon, rcon; - ftnint L; - double d; - - opcode = e->exprblock.opcode; - etype = e->exprblock.vtype; - - lp = e->exprblock.leftp; - ltype = lp->headblock.vtype; - rp = e->exprblock.rightp; - - if(rp == 0) - switch(opcode) - { - case OPNOT: - lp->constblock.Const.ci = ! lp->constblock.Const.ci; - retlp: - e->exprblock.leftp = 0; - frexpr(e); - return(lp); - - case OPBITNOT: - lp->constblock.Const.ci = ~ lp->constblock.Const.ci; - goto retlp; - - case OPNEG: - case OPNEG1: - consnegop((Constp)lp); - goto retlp; - - case OPCONV: - case OPADDR: - return(e); - - case OPABS: - case OPDABS: - switch(ltype) { - case TYINT1: - case TYSHORT: - case TYLONG: -#ifdef TYQUAD - case TYQUAD: -#endif - 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: - if (lp->constblock.vstg) { - s = lp->constblock.Const.cds[0]; - if (*s == '-') - lp->constblock.Const.cds[0] = s + 1; - goto retlp; - } - if ((d = lp->constblock.Const.cd[0]) < 0.) - lp->constblock.Const.cd[0] = -d; - case TYCOMPLEX: - case TYDCOMPLEX: - return e; /* lazy way out */ - } - default: - badop("fold", opcode); - } - - rtype = rp->headblock.vtype; - - p = ALLOC(Constblock); - p->tag = TCONST; - p->vtype = etype; - p->vleng = e->exprblock.vleng; - - switch(opcode) - { - case OPCOMMA: - case OPCOMMA_ARG: - case OPQUEST: - case OPCOLON: - goto ereturn; - - case OPAND: - p->Const.ci = lp->constblock.Const.ci && - rp->constblock.Const.ci; - break; - - case OPOR: - p->Const.ci = lp->constblock.Const.ci || - rp->constblock.Const.ci; - break; - - case OPEQV: - p->Const.ci = lp->constblock.Const.ci == - rp->constblock.Const.ci; - break; - - case OPNEQV: - p->Const.ci = lp->constblock.Const.ci != - rp->constblock.Const.ci; - break; - - case OPBITAND: - p->Const.ci = lp->constblock.Const.ci & - rp->constblock.Const.ci; - break; - - case OPBITOR: - p->Const.ci = lp->constblock.Const.ci | - rp->constblock.Const.ci; - break; - - case OPBITXOR: - p->Const.ci = lp->constblock.Const.ci ^ - rp->constblock.Const.ci; - break; - - 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: - p->Const.ci = (unsigned long)lp->constblock.Const.ci >> - rp->constblock.Const.ci; - break; - - case OPBITTEST: - p->Const.ci = (lp->constblock.Const.ci & - 1L << rp->constblock.Const.ci) != 0; - break; - - case OPBITCLR: - p->Const.ci = lp->constblock.Const.ci & - ~(1L << rp->constblock.Const.ci); - break; - - case OPBITSET: - p->Const.ci = lp->constblock.Const.ci | - 1L << rp->constblock.Const.ci; - break; - - case OPCONCAT: - ll = lp->constblock.vleng->constblock.Const.ci; - lr = rp->constblock.vleng->constblock.Const.ci; - bl = lp->constblock.Const.ccp1.blanks; - p->Const.ccp = q = (char *) ckalloc(ll+lr+bl); - p->Const.ccp1.blanks = rp->constblock.Const.ccp1.blanks; - p->vleng = ICON(ll+lr+bl); - s = lp->constblock.Const.ccp; - for(i = 0 ; i < ll ; ++i) - *q++ = *s++; - for(i = 0 ; i < bl ; i++) - *q++ = ' '; - s = rp->constblock.Const.ccp; - for(i = 0; i < lr; ++i) - *q++ = *s++; - break; - - - case OPPOWER: - 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) - { - lcon.Const.ci = cmpstr(lp->constblock.Const.ccp, - rp->constblock.Const.ccp, - lp->constblock.vleng->constblock.Const.ci, - rp->constblock.vleng->constblock.Const.ci); - rcon.Const.ci = 0; - mtype = tyint; - } - else { - mtype = maxtype(ltype, rtype); - consconv(mtype, &lcon, &lp->constblock); - consconv(mtype, &rcon, &rp->constblock); - } - consbinop(opcode, mtype, p, &lcon, &rcon); - break; - } - - 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; - 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; - - lc->vtype = lt; - if (ONEOF(lt, MSKREAL|MSKCOMPLEX) && ONEOF(rt, MSKREAL|MSKCOMPLEX)) { - memcpy((char *)lv, (char *)rv, sizeof(union Constant)); - lc->vstg = rc->vstg; - if (ISCOMPLEX(lt) && ISREAL(rt)) { - if (rc->vstg) - lv->cds[1] = cds("0",CNULL); - else - lv->cd[1] = 0.; - } - return; - } - lc->vstg = 0; - - switch(lt) - { - -/* Casting to character means just copying the first sizeof (character) - bytes into a new 1 character string. This is weird. */ - - case TYCHAR: - *(lv->ccp = (char *) ckalloc(1)) = rv->ci; - lv->ccp1.blanks = 0; - break; - - case TYINT1: - case TYSHORT: - case TYLONG: -#ifdef TYQUAD - case TYQUAD: -#endif - if(rt == TYCHAR) - lv->ci = rv->ccp[0]; - else if( ISINT(rt) ) - lv->ci = rv->ci; - else lv->ci = rc->vstg ? atof(rv->cds[0]) : rv->cd[0]; - - break; - - case TYCOMPLEX: - case TYDCOMPLEX: - lv->cd[1] = 0.; - lv->cd[0] = rv->ci; - break; - - case TYREAL: - case TYDREAL: - lv->cd[0] = rv->ci; - break; - - case TYLOGICAL: - case TYLOGICAL1: - case TYLOGICAL2: - lv->ci = rv->ci; - break; - } -} - - - -/* Negate constant value -- changes the input node's value */ - - void -#ifdef KR_headers -consnegop(p) - register Constp p; -#else -consnegop(register Constp p) -#endif -{ - register char *s; - ftnint L; - - if (p->vstg) { - if (ISCOMPLEX(p->vtype)) { - s = p->Const.cds[1]; - p->Const.cds[1] = *s == '-' ? s+1 - : *s == '0' ? s : s-1; - } - s = p->Const.cds[0]; - p->Const.cds[0] = *s == '-' ? s+1 - : *s == '0' ? s : s-1; - return; - } - switch(p->vtype) - { - case TYINT1: - case TYSHORT: - case TYLONG: -#ifdef TYQUAD - case TYQUAD: -#endif - p->Const.ci = -(L = p->Const.ci); - if (L != -p->Const.ci) - intovfl(); - break; - - case TYCOMPLEX: - case TYDCOMPLEX: - p->Const.cd[1] = - p->Const.cd[1]; - /* fall through and do the real parts */ - case TYREAL: - case TYDREAL: - p->Const.cd[0] = - p->Const.cd[0]; - break; - default: - badtype("consnegop", p->vtype); - } -} - - - -/* conspower -- Expand out an exponentiation */ - - LOCAL void -#ifdef KR_headers -conspower(p, ap, 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; - struct Constblock x, x0; - - if (n == 1) { - memcpy((char *)powp, (char *)&ap->Const, sizeof(ap->Const)); - return; - } - - switch(type = ap->vtype) /* pow = 1 */ - { - case TYINT1: - case TYSHORT: - case TYLONG: -#ifdef TYQUAD - case TYQUAD: -#endif - powp->ci = 1; - break; - case TYCOMPLEX: - case TYDCOMPLEX: - powp->cd[1] = 0; - case TYREAL: - case TYDREAL: - powp->cd[0] = 1; - break; - default: - badtype("conspower", type); - } - - if(n == 0) - return; - switch(type) /* x0 = ap */ - { - case TYINT1: - case TYSHORT: - case TYLONG: -#ifdef TYQUAD - case TYQUAD: -#endif - x0.Const.ci = ap->Const.ci; - break; - case TYCOMPLEX: - case TYDCOMPLEX: - x0.Const.cd[1] = - ap->vstg ? atof(ap->Const.cds[1]) : ap->Const.cd[1]; - case TYREAL: - case TYDREAL: - x0.Const.cd[0] = - ap->vstg ? atof(ap->Const.cds[0]) : ap->Const.cd[0]; - break; - } - x0.vtype = type; - x0.vstg = 0; - if(n < 0) - { - n = -n; - if( ISINT(type) ) - { - switch(ap->Const.ci) { - case 0: - err("0 ** negative number"); - return; - case 1: - case -1: - goto mult; - } - err("integer ** negative number"); - return; - } - else if (!x0.Const.cd[0] - && (!ISCOMPLEX(type) || !x0.Const.cd[1])) { - err("0.0 ** negative number"); - return; - } - consbinop(OPSLASH, type, &x, p, &x0); - } - else - mult: consbinop(OPSTAR, type, &x, p, &x0); - - for( ; ; ) - { - if(n & 01) - consbinop(OPSTAR, type, p, p, &x); - if(n >>= 1) - consbinop(OPSTAR, type, &x, &x, &x); - else - break; - } -} - - - -/* do constant operation cp = a op b -- assumes that ap and bp have data - matching the input type */ - - LOCAL void -#ifdef KR_headers -consbinop(opcode, type, 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; - - if (ONEOF(type, MSKREAL|MSKCOMPLEX)) { - ad[0] = app->vstg ? atof(ap->cds[0]) : ap->cd[0]; - bd[0] = bpp->vstg ? atof(bp->cds[0]) : bp->cd[0]; - if (ISCOMPLEX(type)) { - ad[1] = app->vstg ? atof(ap->cds[1]) : ap->cd[1]; - bd[1] = bpp->vstg ? atof(bp->cds[1]) : bp->cd[1]; - } - } - switch(opcode) - { - case OPPLUS: - switch(type) - { - case TYINT1: - case TYSHORT: - case TYLONG: -#ifdef TYQUAD - case TYQUAD: -#endif - cp->ci = ap->ci + bp->ci; - if (ap->ci != cp->ci - bp->ci) - intovfl(); - break; - case TYCOMPLEX: - case TYDCOMPLEX: - cp->cd[1] = ad[1] + bd[1]; - case TYREAL: - case TYDREAL: - cp->cd[0] = ad[0] + bd[0]; - break; - } - break; - - case OPMINUS: - switch(type) - { - case TYINT1: - case TYSHORT: - case TYLONG: -#ifdef TYQUAD - case TYQUAD: -#endif - cp->ci = ap->ci - bp->ci; - if (ap->ci != bp->ci + cp->ci) - intovfl(); - break; - case TYCOMPLEX: - case TYDCOMPLEX: - cp->cd[1] = ad[1] - bd[1]; - case TYREAL: - case TYDREAL: - cp->cd[0] = ad[0] - bd[0]; - break; - } - break; - - case OPSTAR: - switch(type) - { - case TYINT1: - case TYSHORT: - case TYLONG: -#ifdef TYQUAD - case TYQUAD: -#endif - cp->ci = (a = ap->ci) * (b = bp->ci); - if (a && cp->ci / a != b) - intovfl(); - break; - case TYREAL: - case TYDREAL: - cp->cd[0] = ad[0] * bd[0]; - break; - case TYCOMPLEX: - case TYDCOMPLEX: - temp = ad[0] * bd[0] - ad[1] * bd[1] ; - cp->cd[1] = ad[0] * bd[1] + ad[1] * bd[0] ; - cp->cd[0] = temp; - break; - } - break; - case OPSLASH: - switch(type) - { - case TYINT1: - case TYSHORT: - case TYLONG: -#ifdef TYQUAD - case TYQUAD: -#endif - cp->ci = ap->ci / bp->ci; - break; - case TYREAL: - case TYDREAL: - cp->cd[0] = ad[0] / bd[0]; - break; - case TYCOMPLEX: - case TYDCOMPLEX: - zdiv((dcomplex*)cp, (dcomplex*)ad, (dcomplex*)bd); - break; - } - break; - - case OPMOD: - if( ISINT(type) ) - { - cp->ci = ap->ci % bp->ci; - break; - } - else - Fatal("inline mod of noninteger"); - - case OPMIN2: - case OPDMIN: - switch(type) - { - case TYINT1: - case TYSHORT: - case TYLONG: -#ifdef TYQUAD - case TYQUAD: -#endif - cp->ci = ap->ci <= bp->ci ? ap->ci : bp->ci; - break; - case TYREAL: - case TYDREAL: - cp->cd[0] = ad[0] <= bd[0] ? ad[0] : bd[0]; - break; - default: - Fatal("inline min of exected type"); - } - break; - - case OPMAX2: - case OPDMAX: - switch(type) - { - case TYINT1: - case TYSHORT: - case TYLONG: -#ifdef TYQUAD - case TYQUAD: -#endif - cp->ci = ap->ci >= bp->ci ? ap->ci : bp->ci; - break; - case TYREAL: - case TYDREAL: - cp->cd[0] = ad[0] >= bd[0] ? ad[0] : bd[0]; - break; - default: - Fatal("inline max of exected type"); - } - break; - - default: /* relational ops */ - switch(type) - { - case TYINT1: - case TYSHORT: - case TYLONG: -#ifdef TYQUAD - case TYQUAD: -#endif - if(ap->ci < bp->ci) - k = -1; - else if(ap->ci == bp->ci) - k = 0; - else k = 1; - break; - case TYREAL: - case TYDREAL: - if(ad[0] < bd[0]) - k = -1; - else if(ad[0] == bd[0]) - k = 0; - else k = 1; - break; - case TYCOMPLEX: - case TYDCOMPLEX: - if(ad[0] == bd[0] && - ad[1] == bd[1] ) - k = 0; - else k = 1; - break; - case TYLOGICAL: - k = ap->ci - bp->ci; - } - - switch(opcode) - { - case OPEQ: - cp->ci = (k == 0); - break; - case OPNE: - cp->ci = (k != 0); - break; - case OPGT: - cp->ci = (k == 1); - break; - case OPLT: - cp->ci = (k == -1); - break; - case OPGE: - cp->ci = (k >= 0); - break; - case OPLE: - cp->ci = (k <= 0); - break; - } - break; - } -} - - - -/* conssgn - returns the sign of a Fortran constant */ - -#ifdef KR_headers -conssgn(p) - register expptr p; -#else -conssgn(register expptr p) -#endif -{ - register char *s; - - if( ! ISCONST(p) ) - Fatal( "sgn(nonconstant)" ); - - switch(p->headblock.vtype) - { - case TYINT1: - case TYSHORT: - case TYLONG: -#ifdef TYQUAD - case TYQUAD: -#endif - if(p->constblock.Const.ci > 0) return(1); - if(p->constblock.Const.ci < 0) return(-1); - return(0); - - case TYREAL: - case TYDREAL: - if (p->constblock.vstg) { - s = p->constblock.Const.cds[0]; - if (*s == '-') - return -1; - if (*s == '0') - return 0; - return 1; - } - if(p->constblock.Const.cd[0] > 0) return(1); - if(p->constblock.Const.cd[0] < 0) return(-1); - return(0); - - -/* The sign of a complex number is 0 iff the number is 0 + 0i, else it's 1 */ - - case TYCOMPLEX: - case TYDCOMPLEX: - if (p->constblock.vstg) - return *p->constblock.Const.cds[0] != '0' - && *p->constblock.Const.cds[1] != '0'; - return(p->constblock.Const.cd[0]!=0 || p->constblock.Const.cd[1]!=0); - - default: - badtype( "conssgn", p->constblock.vtype); - } - /* NOT REACHED */ return 0; -} - -char *powint[ ] = { - "pow_ii", -#ifdef TYQUAD - "pow_qq", -#endif - "pow_ri", "pow_di", "pow_ci", "pow_zi" }; - - 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; - - lp = p->exprblock.leftp; - rp = p->exprblock.rightp; - ltype = lp->headblock.vtype; - rtype = rp->headblock.vtype; - - if (lp->tag == TADDR) - lp->addrblock.parenused = 0; - - if (rp->tag == TADDR) - rp->addrblock.parenused = 0; - - if(ISICON(rp)) - { - if(rp->constblock.Const.ci == 0) - { - frexpr(p); - if( ISINT(ltype) ) - return( ICON(1) ); - else if (ISREAL (ltype)) - return mkconv (ltype, ICON (1)); - else - return( (expptr) putconst((Constp) - mkconv(ltype, ICON(1))) ); - } - if(rp->constblock.Const.ci < 0) - { - if( ISINT(ltype) ) - { - frexpr(p); - err("integer**negative"); - return( errnode() ); - } - rp->constblock.Const.ci = - rp->constblock.Const.ci; - p->exprblock.leftp = lp - = fixexpr((Exprp)mkexpr(OPSLASH, ICON(1), lp)); - } - if(rp->constblock.Const.ci == 1) - { - frexpr(rp); - free( (charptr) p ); - return(lp); - } - - if( ONEOF(ltype, MSKINT|MSKREAL) ) { - p->exprblock.vtype = ltype; - return(p); - } - } - if( ISINT(rtype) ) - { - if(ltype==TYSHORT && rtype==TYSHORT && (!ISCONST(lp) || tyint==TYSHORT) ) - q = call2(TYSHORT, "pow_hh", lp, rp); - else { - if(ONEOF(ltype,M(TYINT1)|M(TYSHORT))) - { - ltype = TYLONG; - lp = mkconv(TYLONG,lp); - } -#ifdef TYQUAD - if (ltype == TYQUAD) - rp = mkconv(TYQUAD,rp); - else -#endif - rp = mkconv(TYLONG,rp); - if (ISCONST(rp)) { - tyi = tyint; - tyint = TYLONG; - rp = (expptr)putconst((Constp)rp); - tyint = tyi; - } - q = call2(ltype, powint[ltype-TYLONG], lp, rp); - } - } - else if( ISREAL( (mtype = maxtype(ltype,rtype)) )) { - extern int callk_kludge; - callk_kludge = TYDREAL; - q = call2(mtype, "pow_dd", mkconv(TYDREAL,lp), mkconv(TYDREAL,rp)); - callk_kludge = 0; - } - else { - q = call2(TYDCOMPLEX, "pow_zz", - mkconv(TYDCOMPLEX,lp), mkconv(TYDCOMPLEX,rp)); - if(mtype == TYCOMPLEX) - q = mkconv(TYCOMPLEX, q); - } - free( (charptr) p ); - return(q); -} - - -/* Complex Division. Same code as in Runtime Library -*/ - - - LOCAL void -#ifdef KR_headers -zdiv(c, a, b) - 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; - - if( (abr = b->dreal) < 0.) - abr = - abr; - if( (abi = b->dimag) < 0.) - abi = - abi; - if( abr <= abi ) - { - if(abi == 0) - Fatal("complex division by zero"); - ratio = b->dreal / b->dimag ; - den = b->dimag * (1 + ratio*ratio); - c->dreal = (a->dreal*ratio + a->dimag) / den; - c->dimag = (a->dimag*ratio - a->dreal) / den; - } - - else - { - ratio = b->dimag / b->dreal ; - den = b->dreal * (1 + ratio*ratio); - c->dreal = (a->dreal + a->dimag*ratio) / den; - c->dimag = (a->dimag - a->dreal*ratio) / den; - } -} - - - void -#ifdef KR_headers -sserr(np) Namep np; -#else -sserr(Namep np) -#endif -{ - errstr(np->vtype == TYCHAR - ? "substring of character array %.70s" - : "substring of noncharacter %.73s", np->fvarname); - } diff --git a/usr.bin/f2c/f2c.1 b/usr.bin/f2c/f2c.1 deleted file mode 100644 index d068b60a8022..000000000000 --- a/usr.bin/f2c/f2c.1 +++ /dev/null @@ -1,305 +0,0 @@ -.\" mdoc translation of the f2c.1 manpage (deprecated -man format) supplied -.\" with f2c. The original manpage did not have a copyright statement, but -.\" the file /usr/src/bin/f2c/Notice states: -.\" -.\"/**************************************************************** -.\"Copyright 1990 - 1997 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 -.\"granted, provided that the above copyright notice appear in all -.\"copies and that both that the copyright notice and this -.\"permission notice and warranty disclaimer appear in supporting -.\"documentation, and that the names of AT&T Bell Laboratories or -.\"Bellcore or any of their entities not be used in advertising or -.\"publicity pertaining to distribution of the software without -.\"specific, written prior permission. -.\" -.\"AT&T and Bellcore disclaim all warranties with regard to this -.\"software, including all implied warranties of merchantability -.\"and fitness. In no event shall AT&T or Bellcore be liable for -.\"any special, indirect or consequential damages or any damages -.\"whatsoever resulting from loss of use, data or profits, whether -.\"in an action of contract, negligence or other tortious action, -.\"arising out of or in connection with the use or performance of -.\"this software. -.\"****************************************************************/ -.\" -.\" $Id$ -.\" -.Dd April 19, 1996 -.Os "AT&T Bell Lab and Bellcore" -.Dt F2C 1 -.Sh NAME -.Nm f2c -.Nd Convert Fortran 77 to C or C++ -.Sh SYNOPSIS -.Nm f2c -.Op Fl AaCcEfgpRrsUuvw -.Op Fl C++ -.Op Fl cd -.Op Fl d Ar dir -.Op Fl ec -.Op Fl e1c -.Op Fl ext -.Op Fl h Ns Op Cm d -.Op Fl \&I2 -.Op Fl \&i2 -.Op Fl i90 -.Op Fl kr Ns Op Cm d -.Op Fl o Ar name -.Op Fl onetrip -.Op Fl P Ns Op Cm s -.Op Fl r8 -.Op Fl 72 -.Op Fl T Ar dir -.Op Fl w8 -.Op Fl W Ns Ar n -.Op Fl z -.Op Fl !bs -.Op Fl !c -.Op Fl !I -.Op Fl !i8 -.Op Fl !it -.Op Fl !P -.Ar file ... -.Sh DESCRIPTION -.Nm F2c -converts Fortran 77 source code in -.Ar files -with names ending in -.So \&.f Sc -or -.So \&.F Sc -to C (or C++) source files in the current directory, with -.So \&.c Sc -substituted for the final -.So \&.f Sc -or -.So \&.F Sc . -If no Fortran files are named, -.Nm f2c -reads Fortran from standard input and writes C on standard output. -.Ar File -names that end with -.So \&.p Sc -or -.So \&.P Sc -are taken to be prototype files, as produced by option -.Fl P , -and are read first. -.Sh OPTIONS -.Bl -tag -width flag -.It Fl A -Produce ANSI C. Default is old-style C. -.It Fl a -Make local variables automatic rather than static unless they appear in a -DATA , EQUIVALENCE , NAMELIST , or SAVE statement. -.It Fl C -Compile code to check that subscripts are within declared array bounds. -.It Fl C++ -Output C++ code. -.It Fl c -Include original Fortran source as comments. -.It Fl cd -Do not recognize cdabs, cdcos, cdexp, cdlog, cdsin, and -cdsqrt as synonyms for the double complex intrinsics -zabs, zcos, zexp, zlog, zsin, and zsqrt, respectively. -.It Fl d Ar dir -Write `.c' files in directory -.Ar dir -instead of the current directory -.It Fl E -Declare uninitialized COMMON to be Extern (overridably defined in -.Pa f2c.h -as -.Em extern -). -.It Fl ec -Place uninitialized COMMON blocks in separate files: -COMMON ABC appears in file abc_com.c . -Option -.Fl e1c -bundles the separate files -into the output file, with comments that give an unbundling -.Xr sed 1 -script. -.It Fl e1c -See -.Fl ec . -.It Fl ext -Complain about Fortran 77 extensions. -.It Fl f -Assume free-format input: accept text after column 72 and do not -pad fixed-format lines shorter than 72 characters with blanks. -.It Fl 72 -Treat text appearing after column 72 as an error. -.It Fl g -Include original Fortran line numbers in -.Sy #line -lines. -.It Fl h Ns Op Cm d -Emulate Fortran 66's treatment of Hollerith: try to align character strings on -word (or, if the option is -.Fl hd , -on double-word) boundaries. -.It Fl \&I2 -Render INTEGER and LOGICAL as short, INTEGER*4 as long int. Assume the -default -.Em libF77 -and -.Em libI77 -allow only INTEGER*4 (and no LOGICAL) variables in INQUIREs. Option -.Fl \&I4 -confirms the default rendering of INTEGER as long int. -.It Fl \&i2 -Similar to -.Fl \&I2 , -but assume a modified -.Em libF77 -and -.Em libI77 -(compiled with -.Fl Df2c_i2 ), -so INTEGER and LOGICAL variables may be assigned by INQUIRE and array lengths -are stored in short ints -.It Fl i90 -Do not recognize the Fortran 90 bit-manipulation intrinsics btest, -iand, ibclr, ibits, ibset, ieor, ior, ishft, and ishftc. -.It Fl kr Ns Op Cm d -Use temporary values to enforce Fortran expression evaluation -where K&R (first edition) parenthesization rules allow rearrangement. -If the option is -.Fl krd , -use double precision temporaries even for single-precision operands. -.It Fl o Ar name -The C source code is written into file -.Ar name . -.It Fl 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.) -.It Fl P Ns Op Cm s -Write a -.Ar file Ns \&.P -of ANSI (or C++) prototypes for definitions in each input -.Ar file Ns \&.f -or -.Ar file Ns \&.F . -When reading Fortran from standard input, write prototypes at the beginning of -standard output. Option -.Fl Ps -implies -.Fl P -and gives exit status 4 if rerunning -.Nm f2c -may change prototypes or declarations. -.It Fl p -Supply preprocessor definitions to make common-block members look like local -variables. -.It Fl v -Echo the file name, program name, and procedure name(s) during compilation. -.It Fl R -Do not promote REAL functions and operations to DOUBLE PRECISION. Option -.Fl !R -confirms the default, which imitates Fortran 77. -.It Fl r -Cast values of REAL functions (including intrinsics) to REAL. -.It Fl r8 -Promote REAL to DOUBLE PRECISION, COMPLEX to DOUBLE COMPLEX. -.It Fl s -Preserve multidimensional subscripts. -.It Fl T Ar dir -Put temporary files in directory -.Ar dir . -.It Fl U -Honor the case of variable and external names. Fortran keywords must be in -.Em lower -case. -.It Fl u -Make the default type of a variable -.So undefined Sc -rather than using the default Fortran rules. -.It Fl w -Suppress all warning messages. If the option is -.Fl w66 , -only Fortran 66 compatibility warnings are suppressed. -.It Fl w8 -Suppress warnings when COMMON or EQUIVALENCE forces odd-word alignment of -doubles. -.It Fl W Ns Ar n -Assume -.Ar n -characters/word (default 4) when initializing numeric variables with character -data. -.It Fl z -Do not implicitly recognize DOUBLE COMPLEX. -.It Fl !bs -Do not recognize -.Em backslash -escapes -(\e", \e', \e0, \e\e, \eb, \ef, \en, \er, \et, \ev) in character strings. -.It Fl !c -Inhibit C output, but produce -.Fl P -output. -.It Fl !I -Reject -.Sy include -statements. -.It Fl !i8 -Disallow INTEGER*8. -.It Fl !it -Don't infer types of untyped EXTERNAL procedures from use as parameters to -previously defined or prototyped procedures. -.It Fl !P -Do not attempt to infer ANSI or C++ prototypes from usage. -.El -.Pp -Object code should be loaded by with -.Xr ld 1 -or -.Xr cc 1 -and the following libraries need to specified: -.Fl lf2c lm . -.Sh FILES -.Ar file Ns \&.[fF] -input file - -.Ar file Ns \&.c -output file - -.Pa /usr/include/f2c.h -header file - -.Pa /usr/lib/libf2c.a -intrinsic function library and Fortran 77 I/O library - -.Sh "SEE ALSO" -.Rs -.%A S. I. Feldman -.%A P. J. Weinberger -.%T A Portable Fortran 77 Compiler -.%B UNIX Time Sharing System Programmer's Manual -.%V Volume 2 -.%D 1990 -.%O AT&T Bell Laboratories -.%N Tenth Edition -.Re -.Sh DIAGNOSTICS -The diagnostics produced by -.Nm f2c -are intended to be -self-explanatory. -.Sh BUGS -Floating-point constant expressions are simplified in -the floating-point arithmetic of the machine running -.Nm f2c -so they are typically accurate to at most 16 or 17 decimal places. -.Pp -Untypable EXTERNAL functions are declared int. -.Pp -There are several undocumented valid options for -.Nm f2c . -These options are discussed at the top of -.Pa /usr/src/usr.bin/f2c/main.c . diff --git a/usr.bin/f2c/f2c.h b/usr.bin/f2c/f2c.h deleted file mode 100644 index 61f72aff4461..000000000000 --- a/usr.bin/f2c/f2c.h +++ /dev/null @@ -1,223 +0,0 @@ -/* f2c.h -- Standard Fortran to C header file */ - -/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." - - - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ - -#ifndef F2C_INCLUDE -#define F2C_INCLUDE - -typedef int integer; -typedef unsigned int uinteger; -typedef char *address; -typedef short int shortint; -typedef float real; -typedef double doublereal; -typedef struct { real r, i; } complex; -typedef struct { doublereal r, i; } doublecomplex; -typedef int logical; -typedef short int shortlogical; -typedef char logical1; -typedef char integer1; -#if 0 /* Adjust for integer*8. */ -typedef long long longint; /* system-dependent */ -typedef unsigned long long ulongint; /* system-dependent */ -#define qbit_clear(a,b) ((a) & ~((ulongint)1 << (b))) -#define qbit_set(a,b) ((a) | ((ulongint)1 << (b))) -#endif - -#define TRUE_ (1) -#define FALSE_ (0) - -/* Extern is for use with -E */ -#ifndef Extern -#define Extern extern -#endif - -/* I/O stuff */ - -#ifdef f2c_i2 -/* for -i2 */ -typedef short flag; -typedef short ftnlen; -typedef short ftnint; -#else -typedef int flag; -typedef int ftnlen; -typedef int ftnint; -#endif - -/*external read, write*/ -typedef struct -{ flag cierr; - ftnint ciunit; - flag ciend; - char *cifmt; - ftnint cirec; -} cilist; - -/*internal read, write*/ -typedef struct -{ flag icierr; - char *iciunit; - flag iciend; - char *icifmt; - ftnint icirlen; - ftnint icirnum; -} icilist; - -/*open*/ -typedef struct -{ flag oerr; - ftnint ounit; - char *ofnm; - ftnlen ofnmlen; - char *osta; - char *oacc; - char *ofm; - ftnint orl; - char *oblnk; -} olist; - -/*close*/ -typedef struct -{ flag cerr; - ftnint cunit; - char *csta; -} cllist; - -/*rewind, backspace, endfile*/ -typedef struct -{ flag aerr; - ftnint aunit; -} alist; - -/* inquire */ -typedef struct -{ flag inerr; - ftnint inunit; - char *infile; - ftnlen infilen; - ftnint *inex; /*parameters in standard's order*/ - ftnint *inopen; - ftnint *innum; - ftnint *innamed; - char *inname; - ftnlen innamlen; - char *inacc; - ftnlen inacclen; - char *inseq; - ftnlen inseqlen; - char *indir; - ftnlen indirlen; - char *infmt; - ftnlen infmtlen; - char *inform; - ftnint informlen; - char *inunf; - ftnlen inunflen; - ftnint *inrecl; - ftnint *innrec; - char *inblank; - ftnlen inblanklen; -} inlist; - -#define VOID void - -union Multitype { /* for multiple entry points */ - integer1 g; - shortint h; - integer i; - /* longint j; */ - real r; - doublereal d; - complex c; - doublecomplex z; - }; - -typedef union Multitype Multitype; - -/*typedef long int Long;*/ /* No longer used; formerly in Namelist */ - -struct Vardesc { /* for Namelist */ - char *name; - char *addr; - ftnlen *dims; - int type; - }; -typedef struct Vardesc Vardesc; - -struct Namelist { - char *name; - Vardesc **vars; - int nvars; - }; -typedef struct Namelist Namelist; - -#define abs(x) ((x) >= 0 ? (x) : -(x)) -#define dabs(x) (doublereal)abs(x) -#define min(a,b) ((a) <= (b) ? (a) : (b)) -#define max(a,b) ((a) >= (b) ? (a) : (b)) -#define dmin(a,b) (doublereal)min(a,b) -#define dmax(a,b) (doublereal)max(a,b) -#define bit_test(a,b) ((a) >> (b) & 1) -#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) -#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) - -/* procedure parameter types for -A and -C++ */ - -#define F2C_proc_par_types 1 -#ifdef __cplusplus -typedef int /* Unknown procedure type */ (*U_fp)(...); -typedef shortint (*J_fp)(...); -typedef integer (*I_fp)(...); -typedef real (*R_fp)(...); -typedef doublereal (*D_fp)(...), (*E_fp)(...); -typedef /* Complex */ VOID (*C_fp)(...); -typedef /* Double Complex */ VOID (*Z_fp)(...); -typedef logical (*L_fp)(...); -typedef shortlogical (*K_fp)(...); -typedef /* Character */ VOID (*H_fp)(...); -typedef /* Subroutine */ int (*S_fp)(...); -#else -typedef int /* Unknown procedure type */ (*U_fp)(); -typedef shortint (*J_fp)(); -typedef integer (*I_fp)(); -typedef real (*R_fp)(); -typedef doublereal (*D_fp)(), (*E_fp)(); -typedef /* Complex */ VOID (*C_fp)(); -typedef /* Double Complex */ VOID (*Z_fp)(); -typedef logical (*L_fp)(); -typedef shortlogical (*K_fp)(); -typedef /* Character */ VOID (*H_fp)(); -typedef /* Subroutine */ int (*S_fp)(); -#endif -/* E_fp is for real functions when -R is not specified */ -typedef VOID C_f; /* complex function */ -typedef VOID H_f; /* character function */ -typedef VOID Z_f; /* double complex function */ -typedef doublereal E_f; /* real function with -R not specified */ - -/* undef any lower-case symbols that your C compiler predefines, e.g.: */ - -#ifndef Skip_f2c_Undefs -#undef cray -#undef gcos -#undef mc68010 -#undef mc68020 -#undef mips -#undef pdp11 -#undef sgi -#undef sparc -#undef sun -#undef sun2 -#undef sun3 -#undef sun4 -#undef u370 -#undef u3b -#undef u3b2 -#undef u3b5 -#undef unix -#undef vax -#endif -#endif diff --git a/usr.bin/f2c/format.c b/usr.bin/f2c/format.c deleted file mode 100644 index 1e92d3bb5301..000000000000 --- a/usr.bin/f2c/format.c +++ /dev/null @@ -1,2523 +0,0 @@ -/**************************************************************** -Copyright 1990 - 1996 by AT&T, Lucent Technologies and Bellcore. - -Permission to use, copy, modify, and distribute this software -and its documentation for any purpose and without fee is hereby -granted, provided that the above copyright notice appear in all -copies and that both that the copyright notice and this -permission notice and warranty disclaimer appear in supporting -documentation, and that the names of AT&T, Bell Laboratories, -Lucent or Bellcore or any of their entities not be used in -advertising or publicity pertaining to distribution of the -software without specific, written prior permission. - -AT&T, Lucent and Bellcore disclaim all warranties with regard to -this software, including all implied warranties of -merchantability and fitness. In no event shall AT&T, Lucent or -Bellcore be liable for any special, indirect or consequential -damages or any damages whatsoever resulting from loss of use, -data or profits, whether in an action of contract, negligence or -other tortious action, arising out of or in connection with the -use or performance of this software. -****************************************************************/ - -/* Format.c -- this file takes an intermediate file (generated by pass 1 - of the translator) and some state information about the contents of that - file, and generates C program text. */ - -#include "defs.h" -#include "p1defs.h" -#include "format.h" -#include "output.h" -#include "names.h" -#include "iob.h" - -int c_output_line_length = DEF_C_LINE_LENGTH; - -int last_was_label; /* Boolean used to generate semicolons - when a label terminates a block */ -static char this_proc_name[52]; /* Name of the current procedure. This is - probably too simplistic to handle - multiple entry points */ - -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; -char filename[P1_FILENAME_MAX]; -extern int gflag, sharp_line; -int gflag1; -extern char *parens; - - void -start_formatting(Void) -{ - FILE *infile; - static int wrote_one = 0; - extern int usedefsforcommon; - extern char *p1_file, *p1_bakfile; - - this_proc_name[0] = '\0'; - last_was_label = 0; - ei_next = ei_first; - wh_next = wh_first; - - (void) fclose (pass1_file); - if ((infile = fopen (p1_file, binread)) == NULL) - Fatal("start_formatting: couldn't open the intermediate file\n"); - - if (wrote_one) - nice_printf (c_file, "\n"); - - while (!feof (infile)) { - expptr this_expr; - - this_expr = do_format (infile, c_file); - if (this_expr) { - out_and_free_statement (c_file, this_expr); - } /* if this_expr */ - } /* while !feof infile */ - - (void) fclose (infile); - - if (last_was_label) - nice_printf (c_file, ";\n"); - - prev_tab (c_file); - gflag1 = sharp_line = 0; - if (this_proc_name[0]) - nice_printf (c_file, "} /* %s */\n", this_proc_name); - - -/* Write the #undefs for common variable reference */ - - if (usedefsforcommon) { - Extsym *ext; - int did_one = 0; - - for (ext = extsymtab; ext < nextext; ext++) - if (ext -> extstg == STGCOMMON && ext -> used_here) { - ext -> used_here = 0; - if (!did_one) - nice_printf (c_file, "\n"); - wr_abbrevs(c_file, 0, ext->extp); - did_one = 1; - ext -> extp = CHNULL; - } /* if */ - - if (did_one) - nice_printf (c_file, "\n"); - } /* if usedefsforcommon */ - - other_undefs(c_file); - - wrote_one = 1; - -/* For debugging only */ - - if (debugflag && (pass1_file = fopen (p1_bakfile, binwrite))) - if (infile = fopen (p1_file, binread)) { - ffilecopy (infile, pass1_file); - fclose (infile); - fclose (pass1_file); - } /* if infile */ - -/* End of "debugging only" */ - - scrub(p1_file); /* optionally unlink */ - - if ((pass1_file = fopen (p1_file, binwrite)) == NULL) - err ("start_formatting: couldn't reopen the pass1 file"); - -} /* start_formatting */ - - - static void -#ifdef KR_headers -put_semi(outfile) - FILE *outfile; -#else -put_semi(FILE *outfile) -#endif -{ - nice_printf (outfile, ";\n"); - last_was_label = 0; - } - -#define SEM_CHECK(x) if (last_was_label) put_semi(x) - -/* do_format -- takes an input stream (a file in pass1 format) and writes - the appropriate C code to outfile when possible. When reading an - expression, the expression tree is returned instead. */ - - 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; - - token_type = get_p1_token (infile); - was_c_token = 1; - switch (token_type) { - case P1_COMMENT: - do_p1_comment (infile, outfile); - was_c_token = 0; - break; - case P1_SET_LINE: - do_p1_set_line (infile); - was_c_token = 0; - break; - case P1_FILENAME: - p1gets(infile, filename, P1_FILENAME_MAX); - was_c_token = 0; - break; - case P1_NAME_POINTER: - retval = do_p1_name_pointer (infile); - break; - case P1_CONST: - retval = do_p1_const (infile); - break; - case P1_EXPR: - retval = do_p1_expr (infile, outfile); - break; - case P1_IDENT: - retval = do_p1_ident(infile); - break; - case P1_CHARP: - retval = do_p1_charp(infile); - break; - case P1_EXTERN: - retval = do_p1_extern (infile); - break; - case P1_HEAD: - gflag1 = sharp_line = 0; - retval = do_p1_head (infile, outfile); - gflag1 = sharp_line = gflag; - break; - case P1_LIST: - retval = do_p1_list (infile, outfile); - break; - case P1_LITERAL: - retval = do_p1_literal (infile); - break; - case P1_LABEL: - do_p1_label (infile, outfile); - /* last_was_label = 1; -- now set in do_p1_label */ - was_c_token = 0; - break; - case P1_ASGOTO: - do_p1_asgoto (infile, outfile); - break; - case P1_GOTO: - do_p1_goto (infile, outfile); - break; - case P1_IF: - do_p1_if (infile, outfile); - break; - case P1_ELSE: - SEM_CHECK(outfile); - do_p1_else (outfile); - break; - case P1_ELIF: - SEM_CHECK(outfile); - do_p1_elif (infile, outfile); - break; - case P1_ENDIF: - SEM_CHECK(outfile); - do_p1_endif (outfile); - break; - case P1_ENDELSE: - SEM_CHECK(outfile); - do_p1_endelse (outfile); - break; - case P1_ADDR: - retval = do_p1_addr (infile, outfile); - break; - case P1_SUBR_RET: - do_p1_subr_ret (infile, outfile); - break; - case P1_COMP_GOTO: - do_p1_comp_goto (infile, outfile); - break; - case P1_FOR: - do_p1_for (infile, outfile); - break; - case P1_ENDFOR: - SEM_CHECK(outfile); - do_p1_end_for (outfile); - break; - case P1_WHILE1START: - do_p1_1while(outfile); - break; - case P1_WHILE2START: - do_p1_2while(infile, outfile); - break; - case P1_PROCODE: - procode(outfile); - break; - case P1_ELSEIFSTART: - SEM_CHECK(outfile); - do_p1_elseifstart(outfile); - break; - case P1_FORTRAN: - do_p1_fortran(infile, outfile); - /* no break; */ - case P1_EOF: - was_c_token = 0; - break; - case P1_UNKNOWN: - Fatal("do_format: Unknown token type in intermediate file"); - break; - default: - Fatal("do_format: Bad token type in intermediate file"); - break; - } /* switch */ - - if (was_c_token) - last_was_label = 0; - return retval; -} /* do_format */ - - - static void -#ifdef KR_headers -do_p1_comment(infile, outfile) - FILE *infile; - FILE *outfile; -#else -do_p1_comment(FILE *infile, FILE *outfile) -#endif -{ - extern int in_comment; - - char storage[COMMENT_BUFFER_SIZE + 1]; - int length; - - if (!p1gets(infile, storage, COMMENT_BUFFER_SIZE + 1)) - return; - - length = strlen (storage); - - gflag1 = sharp_line = 0; - in_comment = 1; - margin_printf(outfile, length ? "/* %s */\n" : "\n", storage); - in_comment = 0; - gflag1 = sharp_line = gflag; -} /* do_p1_comment */ - - static void -#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; - - status = p1getd (infile, &new_line_number); - - if (status == EOF) - err ("do_p1_set_line: Missing line number at end of file\n"); - else if (status == 0 || new_line_number == -1) - errl("do_p1_set_line: Illegal line number in intermediate file: %ld\n", - new_line_number); - else { - lineno = new_line_number; - } -} /* do_p1_set_line */ - - - 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; - - status = p1getd (infile, (long *) &namep); - - if (status == EOF) - err ("do_p1_name_pointer: Missing pointer at end of file\n"); - else if (status == 0 || namep == (Namep) NULL) - erri ("do_p1_name_pointer: Illegal name pointer in p1 file: '%x'\n", - (int) namep); - - return (expptr) namep; -} /* do_p1_name_pointer */ - - - - 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; - int status; - - status = p1getd (infile, &type); - - if (status == EOF) - err ("do_p1_const: Missing constant type at end of file\n"); - else if (status == 0) - errl("do_p1_const: Illegal constant type in p1 file: %ld\n", type); - else { - status = p1get_const (infile, (int)type, &c); - - if (status == EOF) { - err ("do_p1_const: Missing constant value at end of file\n"); - c = (struct Constblock *) NULL; - } else if (status == 0) { - err ("do_p1_const: Illegal constant value in p1 file\n"); - c = (struct Constblock *) NULL; - } /* else */ - } /* else */ - return (expptr) c; -} /* do_p1_const */ - - void -#ifdef KR_headers -addrlit(addrp) - Addrp addrp; -#else -addrlit(Addrp addrp) -#endif -{ - long 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 -#ifdef KR_headers -do_p1_literal(infile) - FILE *infile; -#else -do_p1_literal(FILE *infile) -#endif -{ - int status; - long memno; - Addrp addrp; - - status = p1getd (infile, &memno); - - if (status == EOF) - err ("do_p1_literal: Missing memno at end of file"); - else if (status == 0) - err ("do_p1_literal: Missing memno in p1 file"); - else { - addrp = ALLOC (Addrblock); - addrp -> tag = TADDR; - addrp -> vtype = TYUNKNOWN; - addrp -> Field = NULL; - addrp -> memno = memno; - addrlit(addrp); - addrp -> uname_tag = UNAM_CONST; - } /* else */ - - return (expptr) addrp; -} /* do_p1_literal */ - - - 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; - struct Labelblock *L; - char *fmt; - - status = p1getd (infile, &stateno); - - if (status == EOF) - err ("do_p1_label: Missing label at end of file"); - else if (status == 0) - err ("do_p1_label: Missing label in p1 file "); - else if (stateno < 0) { /* entry */ - margin_printf(outfile, "\n%s:\n", user_label(stateno)); - last_was_label = 1; - } - else { - L = labeltab + stateno; - if (L->labused) { - fmt = "%s:\n"; - last_was_label = 1; - } - else - fmt = "/* %s: */\n"; - margin_printf(outfile, fmt, user_label(L->stateno)); - } /* else */ -} /* do_p1_label */ - - - - 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; - - expr = do_format (infile, outfile); - out_asgoto (outfile, expr); - -} /* do_p1_asgoto */ - - - 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; - - status = p1getd (infile, &stateno); - - if (status == EOF) - err ("do_p1_goto: Missing goto label at end of file"); - else if (status == 0) - err ("do_p1_goto: Missing goto label in p1 file"); - else { - nice_printf (outfile, "goto %s;\n", user_label (stateno)); - } /* else */ -} /* do_p1_goto */ - - - 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; - - do { - cond = do_format (infile, outfile); - } while (cond == ENULL); - - out_if (outfile, cond); -} /* do_p1_if */ - - - 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 -#ifdef KR_headers -do_p1_elif(infile, outfile) - FILE *infile; - FILE *outfile; -#else -do_p1_elif(FILE *infile, FILE *outfile) -#endif -{ - expptr cond; - - do { - cond = do_format (infile, outfile); - } while (cond == ENULL); - - elif_out (outfile, cond); -} /* do_p1_elif */ - - 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 -#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 -#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; - - status = p1getn (infile, (int)sizeof(struct Addrblock), (char **) &addrp); - - if (status == EOF) - err ("do_p1_addr: Missing Addrp at end of file"); - else if (status == 0) - err ("do_p1_addr: Missing Addrp in p1 file"); - else if (addrp == (Addrp) NULL) - err ("do_p1_addr: Null addrp in p1 file"); - else if (addrp -> tag != TADDR) - erri ("do_p1_addr: bad tag in p1 file '%d'", addrp -> tag); - else { - addrp -> vleng = do_format (infile, outfile); - addrp -> memoffset = do_format (infile, outfile); - } - - return (expptr) addrp; -} /* do_p1_addr */ - - - - 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; - - nice_printf (outfile, "return "); - retval = do_format (infile, outfile); - if (!multitype) - if (retval) - expr_out (outfile, retval); - - nice_printf (outfile, ";\n"); -} /* do_p1_subr_ret */ - - - - 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; - - index = do_format (infile, outfile); - - if (index == ENULL) { - err ("do_p1_comp_goto: no expression for computed goto"); - return; - } /* if index == ENULL */ - - labels = do_format (infile, outfile); - - if (labels && labels -> tag != TLIST) - erri ("do_p1_comp_goto: expected list, got tag '%d'", labels -> tag); - else - compgoto_out (outfile, index, labels); -} /* do_p1_comp_goto */ - - - 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; - - init = do_format (infile, outfile); - test = do_format (infile, outfile); - inc = do_format (infile, outfile); - - out_for (outfile, init, test, inc); -} /* do_p1_for */ - - 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; - FILE *outfile; -#else -do_p1_fortran(FILE *infile, FILE *outfile) -#endif -{ - char buf[P1_STMTBUFSIZE]; - if (!p1gets(infile, buf, P1_STMTBUFSIZE)) - return; - /* bypass nice_printf nonsense */ - fprintf(outfile, "/*< %s >*/\n", buf+1); /* + 1 to skip by '$' */ - } - - - 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; - struct Exprblock *result = (struct Exprblock *) NULL; - - status = p1getd (infile, &opcode); - - if (status == EOF) - err ("do_p1_expr: Missing expr opcode at end of file"); - else if (status == 0) - err ("do_p1_expr: Missing expr opcode in p1 file"); - else { - - status = p1getd (infile, &type); - - if (status == EOF) - err ("do_p1_expr: Missing expr type at end of file"); - else if (status == 0) - err ("do_p1_expr: Missing expr type in p1 file"); - else if (opcode == 0) - return ENULL; - else { - result = ALLOC (Exprblock); - - result -> tag = TEXPR; - result -> vtype = type; - result -> opcode = opcode; - result -> vleng = do_format (infile, outfile); - - if (is_unary_op (opcode)) - result -> leftp = do_format (infile, outfile); - else if (is_binary_op (opcode)) { - result -> leftp = do_format (infile, outfile); - result -> rightp = do_format (infile, outfile); - } else - errl("do_p1_expr: Illegal opcode %ld", opcode); - } /* else */ - } /* else */ - - return (expptr) result; -} /* do_p1_expr */ - - - static expptr -#ifdef KR_headers -do_p1_ident(infile) - FILE *infile; -#else -do_p1_ident(FILE *infile) -#endif -{ - Addrp addrp; - int status; - long vtype, vstg; - - addrp = ALLOC (Addrblock); - addrp -> tag = TADDR; - - status = p1getd (infile, &vtype); - if (status == EOF) - err ("do_p1_ident: Missing identifier type at end of file\n"); - else if (status == 0 || vtype < 0 || vtype >= NTYPES) - errl("do_p1_ident: Bad type in intermediate file: %ld\n", vtype); - else - addrp -> vtype = vtype; - - status = p1getd (infile, &vstg); - if (status == EOF) - err ("do_p1_ident: Missing identifier storage at end of file\n"); - else if (status == 0 || vstg < 0 || vstg > STGNULL) - errl("do_p1_ident: Bad storage in intermediate file: %ld\n", vtype); - else - addrp -> vstg = vstg; - - status = p1gets(infile, addrp->user.ident, IDENT_LEN); - - if (status == EOF) - err ("do_p1_ident: Missing ident string at end of file"); - else if (status == 0) - err ("do_p1_ident: Missing ident string in intermediate file"); - addrp->uname_tag = UNAM_IDENT; - return (expptr) addrp; -} /* do_p1_ident */ - - static expptr -#ifdef KR_headers -do_p1_charp(infile) - FILE *infile; -#else -do_p1_charp(FILE *infile) -#endif -{ - Addrp addrp; - int status; - long vtype, vstg; - char buf[64]; - - addrp = ALLOC (Addrblock); - addrp -> tag = TADDR; - - status = p1getd (infile, &vtype); - if (status == EOF) - err ("do_p1_ident: Missing identifier type at end of file\n"); - else if (status == 0 || vtype < 0 || vtype >= NTYPES) - errl("do_p1_ident: Bad type in intermediate file: %ld\n", vtype); - else - addrp -> vtype = vtype; - - status = p1getd (infile, &vstg); - if (status == EOF) - err ("do_p1_ident: Missing identifier storage at end of file\n"); - else if (status == 0 || vstg < 0 || vstg > STGNULL) - errl("do_p1_ident: Bad storage in intermediate file: %ld\n", vtype); - else - addrp -> vstg = vstg; - - status = p1gets(infile, buf, (int)sizeof(buf)); - - if (status == EOF) - err ("do_p1_ident: Missing charp ident string at end of file"); - else if (status == 0) - err ("do_p1_ident: Missing charp ident string in intermediate file"); - addrp->uname_tag = UNAM_CHARP; - addrp->user.Charp = strcpy(mem(strlen(buf)+1,0), buf); - return (expptr) addrp; -} - - - static expptr -#ifdef KR_headers -do_p1_extern(infile) - FILE *infile; -#else -do_p1_extern(FILE *infile) -#endif -{ - Addrp addrp; - - addrp = ALLOC (Addrblock); - if (addrp) { - int status; - - addrp->tag = TADDR; - addrp->vstg = STGEXT; - addrp->uname_tag = UNAM_EXTERN; - status = p1getd (infile, &(addrp -> memno)); - if (status == EOF) - err ("do_p1_extern: Missing memno at end of file"); - else if (status == 0) - err ("do_p1_extern: Missing memno in intermediate file"); - if (addrp->vtype = extsymtab[addrp->memno].extype) - addrp->vclass = CLPROC; - } /* if addrp */ - - return (expptr) addrp; -} /* do_p1_extern */ - - - - 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_; - long class; - char storage[256]; - - status = p1getd (infile, &class); - if (status == EOF) - err ("do_p1_head: missing header class at end of file"); - else if (status == 0) - err ("do_p1_head: missing header class in p1 file"); - else { - status = p1gets (infile, storage, (int)sizeof(storage)); - if (status == EOF || status == 0) - storage[0] = '\0'; - } /* else */ - - if (class == CLPROC || class == CLMAIN) { - chainp lengths; - - add_n_ = nentry > 1; - lengths = length_comp(entries, add_n_); - - if (!add_n_ && protofile && class != CLMAIN) - protowrite(protofile, proctype, storage, entries, lengths); - - if (class == CLMAIN) - nice_printf (outfile, "/* Main program */ "); - else - nice_printf(outfile, "%s ", multitype ? "VOID" - : c_type_decl(proctype, 1)); - - nice_printf(outfile, add_n_ ? "%s0_" : "%s", storage); - if (!Ansi) { - listargs(outfile, entries, add_n_, lengths); - nice_printf (outfile, "\n"); - } - list_arg_types (outfile, entries, lengths, add_n_, "\n"); - nice_printf (outfile, "{\n"); - frchain(&lengths); - next_tab (outfile); - strcpy(this_proc_name, storage); - list_decls (outfile); - - } else if (class == CLBLOCK) - next_tab (outfile); - else - errl("do_p1_head: got class %ld", class); - - return NULL; -} /* do_p1_head */ - - - 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; - expptr result; - - status = p1getd (infile, &tag); - if (status == EOF) - err ("do_p1_list: missing list tag at end of file"); - else if (status == 0) - err ("do_p1_list: missing list tag in p1 file"); - else { - status = p1getd (infile, &type); - if (status == EOF) - err ("do_p1_list: missing list type at end of file"); - else if (status == 0) - err ("do_p1_list: missing list type in p1 file"); - else { - status = p1getd (infile, &count); - if (status == EOF) - err ("do_p1_list: missing count at end of file"); - else if (status == 0) - err ("do_p1_list: missing count in p1 file"); - } /* else */ - } /* else */ - - result = (expptr) ALLOC (Listblock); - if (result) { - chainp pointer; - - result -> tag = tag; - result -> listblock.vtype = type; - -/* Assume there will be enough data */ - - if (count--) { - pointer = result->listblock.listp = - mkchain((char *)do_format(infile, outfile), CHNULL); - while (count--) { - pointer -> nextp = - mkchain((char *)do_format(infile, outfile), CHNULL); - pointer = pointer -> nextp; - } /* while (count--) */ - } /* if (count) */ - } /* if (result) */ - - return result; -} /* do_p1_list */ - - - 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; - Namep arg, np; - int nchargs; - Argtypes *at; - Atype *a; - extern int init_ac[TYSUBR+1]; - - if (!e) - return 0; /* possible only with errors */ - args = args1 = add_n ? allargs : e->arglist; - nchargs = 0; - for (lengths = NULL; args; args = args -> nextp) - if (arg = (Namep)args->datap) { - if (arg->vclass == CLUNKNOWN) - arg->vclass = CLVAR; - if (arg->vtype == TYCHAR && arg->vclass != CLPROC) { - lengths = mkchain((char *)arg, lengths); - nchargs++; - } - } - if (!add_n && (np = e->enamep)) { - /* one last check -- by now we know all we ever will - * about external args... - */ - save_argtypes(e->arglist, &e->entryname->arginfo, - &np->arginfo, 0, np->fvarname, STGEXT, nchargs, - np->vtype, 1); - at = e->entryname->arginfo; - a = at->atypes + init_ac[np->vtype]; - for(; args1; a++, args1 = args1->nextp) { - frchain(&a->cp); - if (arg = (Namep)args1->datap) - switch(arg->vclass) { - case CLPROC: - if (arg->vimpltype - && a->type >= 300) - a->type = TYUNKNOWN + 200; - break; - case CLUNKNOWN: - a->type %= 100; - } - } - } - return revchain(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; - Namep arg; - int did_one = 0; - - nice_printf (outfile, "("); - - if (add_n_) { - nice_printf(outfile, "n__"); - did_one = 1; - args = allargs; - } - else { - if (!entryp) - return; /* possible only with errors */ - args = entryp->arglist; - } - - if (multitype) - { - nice_printf(outfile, ", ret_val"); - did_one = 1; - args = allargs; - } - else if (ONEOF(proctype, MSKCOMPLEX|MSKCHAR)) - { - s = xretslot[proctype]->user.ident; - nice_printf(outfile, did_one ? ", %s" : "%s", - *s == '(' /*)*/ ? "r_v" : s); - did_one = 1; - if (proctype == TYCHAR) - nice_printf (outfile, ", ret_val_len"); - } - for (; args; args = args -> nextp) - if (arg = (Namep)args->datap) { - nice_printf (outfile, "%s", did_one ? ", " : ""); - out_name (outfile, arg); - did_one = 1; - } - - for (args = lengths; args; args = args -> nextp) - nice_printf(outfile, ", %s", - new_arg_length((Namep)args->datap)); - nice_printf (outfile, ")"); -} /* listargs */ - - - 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; - int did_one = 0, done_one, is_ext; - char *s, *sep = "", *sep1; - - if (outfile == (FILE *) NULL) { - err ("list_arg_types: null output file"); - return; - } else if (entryp == (struct Entrypoint *) NULL) { - err ("list_arg_types: null procedure entry pointer"); - return; - } /* else */ - - if (Ansi) { - done_one = 0; - sep1 = ", "; - nice_printf(outfile, "(" /*)*/); - } - else { - done_one = 1; - sep1 = ";\n"; - } - args = entryp->arglist; - if (add_n_) { - nice_printf(outfile, "int n__"); - did_one = done_one; - sep = sep1; - args = allargs; - } - if (multitype) { - nice_printf(outfile, "%sMultitype *ret_val", sep); - did_one = done_one; - sep = sep1; - } - else if (ONEOF (proctype, MSKCOMPLEX|MSKCHAR)) { - s = xretslot[proctype]->user.ident; - nice_printf(outfile, "%s%s *%s", sep, c_type_decl(proctype, 0), - *s == '(' /*)*/ ? "r_v" : s); - did_one = done_one; - sep = sep1; - if (proctype == TYCHAR) - nice_printf (outfile, "%sftnlen ret_val_len", sep); - } /* if ONEOF proctype */ - for (; args; args = args -> nextp) { - Namep arg = (Namep) args->datap; - -/* Scalars are passed by reference, and arrays will have their lower bound - adjusted, so nearly everything is printed with a star in front. The - exception is character lengths, which are passed by value. */ - - if (arg) { - int type = arg -> vtype, class = arg -> vclass; - - if (class == CLPROC) - if (arg->vimpltype) - type = Castargs ? TYUNKNOWN : TYSUBR; - else if (type == TYREAL && forcedouble && !Castargs) - type = TYDREAL; - - if (type == last_type && class == last_class && did_one) - nice_printf (outfile, ", "); - else - if ((is_ext = class == CLPROC) && Castargs) - nice_printf(outfile, "%s%s ", sep, - usedcasts[type] = casttypes[type]); - else - nice_printf(outfile, "%s%s ", sep, - c_type_decl(type, is_ext)); - if (class == CLPROC) - if (Castargs) - out_name(outfile, arg); - else { - nice_printf(outfile, "(*"); - out_name(outfile, arg); - nice_printf(outfile, ") %s", parens); - } - else { - nice_printf (outfile, "*"); - out_name (outfile, arg); - } - - last_type = type; - last_class = class; - did_one = done_one; - sep = sep1; - } /* if (arg) */ - } /* for args = entryp -> arglist */ - - for (args = lengths; args; args = args -> nextp) - nice_printf(outfile, "%sftnlen %s", sep, - new_arg_length((Namep)args->datap)); - if (did_one) - nice_printf (outfile, ";\n"); - else if (Ansi) - nice_printf(outfile, - /*((*/ sep != sep1 && Ansi == 1 ? "void)%s" : ")%s", - finalnl); -} /* list_arg_types */ - - static void -#ifdef KR_headers -write_formats(outfile) - FILE *outfile; -#else -write_formats(FILE *outfile) -#endif -{ - register struct Labelblock *lp; - int first = 1; - char *fs; - - for(lp = labeltab ; lp < highlabtab ; ++lp) - if (lp->fmtlabused) { - if (first) { - first = 0; - nice_printf(outfile, "/* Format strings */\n"); - } - nice_printf(outfile, "static char fmt_%ld[] = \"", - lp->stateno); - if (!(fs = lp->fmtstring)) - fs = ""; - nice_printf(outfile, "%s\";\n", fs); - } - if (!first) - nice_printf(outfile, "\n"); - } - - static void -#ifdef KR_headers -write_ioblocks(outfile) - FILE *outfile; -#else -write_ioblocks(FILE *outfile) -#endif -{ - register iob_data *L; - register char *f, **s, *sep; - - nice_printf(outfile, "/* Fortran I/O blocks */\n"); - L = iob_list = (iob_data *)revchain((chainp)iob_list); - do { - nice_printf(outfile, "static %s %s = { ", - L->type, L->name); - sep = 0; - for(s = L->fields; f = *s; s++) { - if (sep) - nice_printf(outfile, sep); - sep = ", "; - if (*f == '"') { /* kludge */ - nice_printf(outfile, "\""); - nice_printf(outfile, "%s\"", f+1); - } - else - nice_printf(outfile, "%s", f); - } - nice_printf(outfile, " };\n"); - } - while(L = L->next); - nice_printf(outfile, "\n\n"); - } - - static void -#ifdef KR_headers -write_assigned_fmts(outfile) - FILE *outfile; -#else -write_assigned_fmts(FILE *outfile) -#endif -{ - register chainp cp; - Namep np; - char *comma, *type; - int did_one = 0; - - cp = assigned_fmts = revchain(assigned_fmts); - nice_printf(outfile, "/* Assigned format variables */\n"); - do { - np = (Namep)cp->datap; - if (did_one == np->vstg) { - comma = ", "; - type = ""; - } - else { - comma = did_one ? ";\n" : ""; - type = np->vstg == STGAUTO ? "char " : "static char "; - did_one = np->vstg; - } - nice_printf(outfile, "%s%s*%s_fmt", comma, type, np->fvarname); - } - while(cp = cp->nextp); - nice_printf(outfile, ";\n\n"); - } - - static char * -#ifdef KR_headers -to_upper(s) - register char *s; -#else -to_upper(register char *s) -#endif -{ - static char buf[64]; - register char *t = buf; - register int c; - while(*t++ = (c = *s++) >= 'a' && c <= 'z' ? c + 'A' - 'a' : c); - return buf; - } - - -/* This routine creates static structures representing a namelist. - Declarations of the namelist and related structures are: - - struct Vardesc { - char *name; - char *addr; - ftnlen *dims; /* laid out as struct dimensions below *//* - int type; - }; - typedef struct Vardesc Vardesc; - - struct Namelist { - char *name; - Vardesc **vars; - int nvars; - }; - - struct dimensions - { - ftnlen numberofdimensions; - ftnlen numberofelements - ftnlen baseoffset; - ftnlen span[numberofdimensions-1]; - }; - - If dims is not null, then the corner element of the array is at - addr. However, the element with subscripts (i1,...,in) is at - addr + sizeoftype * (i1+span[0]*(i2+span[1]*...) - dimp->baseoffset) -*/ - - static void -#ifdef KR_headers -write_namelists(nmch, outfile) - chainp nmch; - FILE *outfile; -#else -write_namelists(chainp nmch, FILE *outfile) -#endif -{ - Namep var; - struct Hashentry *entry; - struct Dimblock *dimp; - int i, nd, type; - char *comma, *name; - register chainp q; - register Namep v; - extern int typeconv[]; - - nice_printf(outfile, "/* Namelist stuff */\n\n"); - for (entry = hashtab; entry < lasthash; ++entry) { - if (!(v = entry->varp) || !v->vnamelist) - continue; - type = v->vtype; - name = v->cvarname; - if (dimp = v->vdim) { - nd = dimp->ndim; - nice_printf(outfile, - "static ftnlen %s_dims[] = { %d, %ld, %ld", - name, nd, - dimp->nelt->constblock.Const.ci, - dimp->baseoffset->constblock.Const.ci); - for(i = 0, --nd; i < nd; i++) - nice_printf(outfile, ", %ld", - dimp->dims[i].dimsize->constblock.Const.ci); - nice_printf(outfile, " };\n"); - } - nice_printf(outfile, "static Vardesc %s_dv = { \"%s\", %s", - name, to_upper(v->fvarname), - type == TYCHAR ? "" - : (dimp || oneof_stg(v,v->vstg, - M(STGEQUIV)|M(STGCOMMON))) - ? "(char *)" : "(char *)&"); - out_name(outfile, v); - nice_printf(outfile, dimp ? ", %s_dims" : ", (ftnlen *)0", name); - nice_printf(outfile, ", %ld };\n", - type != TYCHAR ? (long)typeconv[type] - : -v->vleng->constblock.Const.ci); - } - - do { - var = (Namep)nmch->datap; - name = var->cvarname; - nice_printf(outfile, "\nstatic Vardesc *%s_vl[] = ", name); - comma = "{"; - i = 0; - for(q = var->varxptr.namelist ; q ; q = q->nextp) { - v = (Namep)q->datap; - if (!v->vnamelist) - continue; - i++; - nice_printf(outfile, "%s &%s_dv", comma, v->cvarname); - comma = ","; - } - nice_printf(outfile, " };\n"); - nice_printf(outfile, - "static Namelist %s = { \"%s\", %s_vl, %d };\n", - name, to_upper(var->fvarname), name, i); - } - while(nmch = nmch->nextp); - nice_printf(outfile, "\n"); - } - -/* fixextype tries to infer from usage in previous procedures - the type of an external procedure declared - external and passed as an argument but never typed or invoked. - */ - - static int -#ifdef KR_headers -fixexttype(var) - Namep var; -#else -fixexttype(Namep var) -#endif -{ - Extsym *e; - int type, type1; - - type = var->vtype; - e = &extsymtab[var->vardesc.varno]; - if ((type1 = e->extype) && type == TYUNKNOWN) - return var->vtype = type1; - if (var->visused) { - if (e->exused && type != type1) - changedtype(var); - e->exused = 1; - e->extype = type; - } - return type; - } - - static void -#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; - expptr b, vl; - Namep var; - char *amp, *comma; - - margin_printf(outfile, "\n"); - for(cp = refdefs = revchain(refdefs); cp; cp = cp->nextp) { - var = (Namep)cp->datap; - cp->datap = 0; - amp = "_subscr"; - if (!(eb = var->vsubscrused)) { - var->vrefused = 0; - if (!ISCOMPLEX(var->vtype)) - amp = "_ref"; - } - def_start(outfile, var->cvarname, amp, CNULL); - dimp = var->vdim; - vl = 0; - comma = "("; - amp = ""; - if (var->vtype == TYCHAR) { - amp = "&"; - vl = var->vleng; - if (ISCONST(vl) && vl->constblock.Const.ci == 1) - vl = 0; - nice_printf(outfile, "%sa_0", comma); - comma = ","; - } - n = dimp->ndim; - for(i = 1; i <= n; i++, comma = ",") - nice_printf(outfile, "%sa_%d", comma, i); - nice_printf(outfile, ") %s", amp); - if (var->vsubscrused) - var->vsubscrused = 0; - else if (!ISCOMPLEX(var->vtype)) { - out_name(outfile, var); - nice_printf(outfile, "[%s", vl ? "(" : ""); - } - for(j = 2; j < n; j++) - nice_printf(outfile, "("); - while(--i > 1) { - nice_printf(outfile, "(a_%d)%s*", i, i == n ? "" : ")"); - expr_out(outfile, cpexpr(dimp->dims[i-2].dimsize)); - nice_printf(outfile, " + "); - } - nice_printf(outfile, "a_1"); - if (var->vtype == TYCHAR) { - if (vl) { - nice_printf(outfile, ")*"); - expr_out(outfile, cpexpr(vl)); - } - nice_printf(outfile, " + a_0"); - } - if ((var->vstg != STGARG /* || checksubs */ ) - && (b = dimp->baseoffset)) { - b = cpexpr(b); - if (var->vtype == TYCHAR) - b = mkexpr(OPSTAR, cpexpr(var->vleng), b); - nice_printf(outfile, " - "); - expr_out(outfile, b); - } - if (ISCOMPLEX(var->vtype)) { - margin_printf(outfile, "\n"); - def_start(outfile, var->cvarname, "_ref", CNULL); - comma = "("; - for(i = 1; i <= n; i++, comma = ",") - nice_printf(outfile, "%sa_%d", comma, i); - nice_printf(outfile, ") %s[%s_subscr", - var->cvarname, var->cvarname); - comma = "("; - for(i = 1; i <= n; i++, comma = ",") - nice_printf(outfile, "%sa_%d", comma, i); - nice_printf(outfile, ")"); - } - margin_printf(outfile, "]\n" + eb); - } - nice_printf(outfile, "\n"); - frchain(&refdefs); - } - - void -#ifdef KR_headers -list_decls(outfile) - FILE *outfile; -#else -list_decls(FILE *outfile) -#endif -{ - extern chainp used_builtins; - extern struct Hashentry *hashtab; - struct Hashentry *entry; - int write_header = 1; - int last_class = -1, last_stg = -1; - Namep var; - int Alias, Define, did_one, last_type, type; - extern int def_equivs, useauto; - extern chainp new_vars; /* Compiler-generated locals */ - chainp namelists = 0, refdefs = 0; - char *ctype; - int useauto1 = useauto && !saveall; - long x; - extern int hsize; - -/* First write out the statically initialized data */ - - if (initfile) - list_init_data(&initfile, initfname, outfile); - -/* Next come formats */ - write_formats(outfile); - -/* Now write out the system-generated identifiers */ - - if (new_vars || nequiv) { - chainp args, next_var, this_var; - chainp nv[TYVOID], nv1[TYVOID]; - int i, j; - Addrp Var; - Namep arg; - - /* zap unused dimension variables */ - - for(args = allargs; args; args = args->nextp) { - arg = (Namep)args->datap; - if (this_var = arg->vlastdim) { - frexpr((tagptr)this_var->datap); - this_var->datap = 0; - } - } - - /* sort new_vars by type, skipping entries just zapped */ - - for(i = TYADDR; i < TYVOID; i++) - nv[i] = 0; - for(this_var = new_vars; this_var; this_var = next_var) { - next_var = this_var->nextp; - if (Var = (Addrp)this_var->datap) { - if (!(this_var->nextp = nv[j = Var->vtype])) - nv1[j] = this_var; - nv[j] = this_var; - } - else { - this_var->nextp = 0; - frchain(&this_var); - } - } - new_vars = 0; - for(i = TYVOID; --i >= TYADDR;) - if (this_var = nv[i]) { - nv1[i]->nextp = new_vars; - new_vars = this_var; - } - - /* write the declarations */ - - did_one = 0; - last_type = -1; - - for (this_var = new_vars; this_var; this_var = this_var -> nextp) { - Var = (Addrp) this_var->datap; - - if (Var == (Addrp) NULL) - err ("list_decls: null variable"); - else if (Var -> tag != TADDR) - erri ("list_decls: bad tag on new variable '%d'", - Var -> tag); - - type = nv_type (Var); - if (Var->vstg == STGINIT - || Var->uname_tag == UNAM_IDENT - && *Var->user.ident == ' ' - && multitype) - continue; - if (!did_one) - nice_printf (outfile, "/* System generated locals */\n"); - - if (last_type == type && did_one) - nice_printf (outfile, ", "); - else { - if (did_one) - nice_printf (outfile, ";\n"); - nice_printf (outfile, "%s ", - c_type_decl (type, Var -> vclass == CLPROC)); - } /* else */ - -/* Character type is really a string type. Put out a '*' for parameters - with unknown length and functions returning character */ - - if (Var -> vtype == TYCHAR && (!ISICON ((Var -> vleng)) - || Var -> vclass == CLPROC)) - nice_printf (outfile, "*"); - - write_nv_ident(outfile, (Addrp)this_var->datap); - if (Var -> vtype == TYCHAR && Var->vclass != CLPROC && - ISICON((Var -> vleng)) - && (i = Var->vleng->constblock.Const.ci) > 0) - nice_printf (outfile, "[%d]", i); - - did_one = 1; - last_type = nv_type (Var); - } /* for this_var */ - -/* Handle the uninitialized equivalences */ - - do_uninit_equivs (outfile, &did_one); - - if (did_one) - nice_printf (outfile, ";\n\n"); - } /* if new_vars */ - -/* Write out builtin declarations */ - - if (used_builtins) { - chainp cp; - Extsym *es; - - last_type = -1; - did_one = 0; - - nice_printf (outfile, "/* Builtin functions */"); - - for (cp = used_builtins; cp; cp = cp -> nextp) { - Addrp e = (Addrp)cp->datap; - - switch(type = e->vtype) { - case TYDREAL: - case TYREAL: - /* if (forcedouble || e->dbl_builtin) */ - /* libF77 currently assumes everything double */ - type = TYDREAL; - ctype = "double"; - break; - case TYCOMPLEX: - case TYDCOMPLEX: - type = TYVOID; - /* no break */ - default: - ctype = c_type_decl(type, 0); - } - - if (did_one && last_type == type) - nice_printf(outfile, ", "); - else - nice_printf(outfile, "%s\n%s ", did_one ? ";" : "", ctype); - - extern_out(outfile, es = &extsymtab[e -> memno]); - proto(outfile, es->arginfo, es->fextname); - last_type = type; - did_one = 1; - } /* for cp = used_builtins */ - - nice_printf (outfile, ";\n\n"); - } /* if used_builtins */ - - last_type = -1; - for (entry = hashtab; entry < lasthash; ++entry) { - var = entry -> varp; - - if (var) { - int procclass = var -> vprocclass; - char *comment = NULL; - int stg = var -> vstg; - int class = var -> vclass; - type = var -> vtype; - - if (var->vrefused) - refdefs = mkchain((char *)var, refdefs); - if (var->vsubscrused) - if (ISCOMPLEX(var->vtype)) - var->vsubscrused = 0; - else - refdefs = mkchain((char *)var, refdefs); - if (ONEOF(stg, M(STGARG)|M(STGLENG)|M(STGINIT))) - continue; - - if (useauto1 && stg == STGBSS && !var->vsave) - stg = STGAUTO; - - switch (class) { - case CLVAR: - break; - case CLPROC: - switch(procclass) { - case PTHISPROC: - extsymtab[var->vardesc.varno].extype = type; - continue; - case PSTFUNCT: - case PINTRINSIC: - continue; - case PUNKNOWN: - err ("list_decls: unknown procedure class"); - continue; - case PEXTERNAL: - if (stg == STGUNKNOWN) { - warn1( - "%.64s declared EXTERNAL but never used.", - var->fvarname); - /* to retain names declared EXTERNAL */ - /* but not referenced, change */ - /* "continue" to "stg = STGEXT" */ - continue; - } - else - type = fixexttype(var); - } - break; - case CLUNKNOWN: - /* declared but never used */ - continue; - case CLPARAM: - continue; - case CLNAMELIST: - if (var->visused) - namelists = mkchain((char *)var, namelists); - continue; - default: - erri("list_decls: can't handle class '%d' yet", - class); - Fatal(var->fvarname); - continue; - } /* switch */ - - /* Might be equivalenced to a common. If not, don't process */ - if (stg == STGCOMMON && !var->vcommequiv) - continue; - -/* Only write the header if system-generated locals, builtins, or - uninitialized equivs were already output */ - - if (write_header == 1 && (new_vars || nequiv || used_builtins) - && oneof_stg ( var, stg, - M(STGBSS)|M(STGEXT)|M(STGAUTO)|M(STGCOMMON)|M(STGEQUIV))) { - nice_printf (outfile, "/* Local variables */\n"); - write_header = 2; - } - - - Alias = oneof_stg(var, stg, M(STGEQUIV)|M(STGCOMMON)); - if (Define = (Alias && def_equivs)) { - if (!write_header) - nice_printf(outfile, ";\n"); - def_start(outfile, var->cvarname, CNULL, "("); - goto Alias1; - } - else if (type == last_type && class == last_class && - stg == last_stg && !write_header) - nice_printf (outfile, ", "); - else { - if (!write_header && ONEOF(stg, M(STGBSS)| - M(STGEXT)|M(STGAUTO)|M(STGEQUIV)|M(STGCOMMON))) - nice_printf (outfile, ";\n"); - - switch (stg) { - case STGARG: - case STGLENG: - /* Part of the argument list, don't write them out - again */ - continue; /* Go back to top of the loop */ - case STGBSS: - case STGEQUIV: - case STGCOMMON: - nice_printf (outfile, "static "); - break; - case STGEXT: - nice_printf (outfile, "extern "); - break; - case STGAUTO: - break; - case STGINIT: - case STGUNKNOWN: - /* Don't want to touch the initialized data, that will - be handled elsewhere. Unknown data have - already been complained about, so skip them */ - continue; - default: - erri("list_decls: can't handle storage class %d", - stg); - continue; - } /* switch */ - - if (type == TYCHAR && halign && class != CLPROC - && ISICON(var->vleng)) { - nice_printf(outfile, "struct { %s fill; char val", - halign); - x = wr_char_len(outfile, var->vdim, - var->vleng->constblock.Const.ci, 1); - if (x %= hsize) - nice_printf(outfile, "; char fill2[%ld]", - hsize - x); - nice_printf(outfile, "; } %s_st;\n", var->cvarname); - def_start(outfile, var->cvarname, CNULL, var->cvarname); - margin_printf(outfile, "_st.val\n"); - last_type = -1; - write_header = 2; - continue; - } - nice_printf(outfile, "%s ", - c_type_decl(type, class == CLPROC)); - } /* else */ - -/* Character type is really a string type. Put out a '*' for variable - length strings, and also for equivalences */ - - if (type == TYCHAR && class != CLPROC - && (!var->vleng || !ISICON (var -> vleng)) - || oneof_stg(var, stg, M(STGEQUIV)|M(STGCOMMON))) - nice_printf (outfile, "*%s", var->cvarname); - else { - nice_printf (outfile, "%s", var->cvarname); - if (class == CLPROC) { - Argtypes *at; - if (!(at = var->arginfo) - && var->vprocclass == PEXTERNAL) - at = extsymtab[var->vardesc.varno].arginfo; - proto(outfile, at, var->fvarname); - } - else if (type == TYCHAR && ISICON ((var -> vleng))) - wr_char_len(outfile, var->vdim, - (int)var->vleng->constblock.Const.ci, 0); - else if (var -> vdim && - !oneof_stg (var, stg, M(STGEQUIV)|M(STGCOMMON))) - comment = wr_ardecls(outfile, var->vdim, 1L); - } - - if (comment) - nice_printf (outfile, "%s", comment); - Alias1: - if (Alias) { - char *amp, *lp, *name, *rp; - ftnint voff = var -> voffset; - int et0, expr_type, k; - Extsym *E; - struct Equivblock *eb; - char buf[16]; - -/* We DON'T want to use oneof_stg here, because we need to distinguish - between them */ - - if (stg == STGEQUIV) { - name = equiv_name(k = var->vardesc.varno, CNULL); - eb = eqvclass + k; - if (eb->eqvinit) { - amp = "&"; - et0 = TYERROR; - } - else { - amp = ""; - et0 = eb->eqvtype; - } - expr_type = et0; - } - else { - E = &extsymtab[var->vardesc.varno]; - sprintf(name = buf, "%s%d", E->cextname, E->curno); - expr_type = type; - et0 = -1; - amp = "&"; - } /* else */ - - if (!Define) - nice_printf (outfile, " = "); - if (voff) { - k = typesize[type]; - switch((int)(voff % k)) { - case 0: - voff /= k; - expr_type = type; - break; - case SZSHORT: - case SZSHORT+SZLONG: - expr_type = TYSHORT; - voff /= SZSHORT; - break; - case SZLONG: - expr_type = TYLONG; - voff /= SZLONG; - break; - default: - expr_type = TYCHAR; - } - } - - if (expr_type == type) { - lp = rp = ""; - if (et0 == -1 && !voff) - goto cast; - } - else { - lp = "("; - rp = ")"; - cast: - nice_printf(outfile, "(%s *)", c_type_decl(type, 0)); - } - -/* Now worry about computing the offset */ - - if (voff) { - if (expr_type == et0) - nice_printf (outfile, "%s%s + %ld%s", - lp, name, voff, rp); - else - nice_printf(outfile, "%s(%s *)%s%s + %ld%s", lp, - c_type_decl (expr_type, 0), amp, - name, voff, rp); - } else - nice_printf(outfile, "%s%s", amp, name); -/* Always put these at the end of the line */ - last_type = last_class = last_stg = -1; - write_header = 0; - if (Define) { - margin_printf(outfile, ")\n"); - write_header = 2; - } - continue; - } - write_header = 0; - last_type = type; - last_class = class; - last_stg = stg; - } /* if (var) */ - } /* for (entry = hashtab */ - - if (!write_header) - nice_printf (outfile, ";\n\n"); - else if (write_header == 2) - nice_printf(outfile, "\n"); - -/* Next, namelists, which may reference equivs */ - - if (namelists) { - write_namelists(namelists = revchain(namelists), outfile); - frchain(&namelists); - } - -/* Finally, ioblocks (which may reference equivs and namelists) */ - if (iob_list) - write_ioblocks(outfile); - if (assigned_fmts) - write_assigned_fmts(outfile); - - if (refdefs) - ref_defs(outfile, refdefs); - -} /* list_decls */ - - 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; - int k, last_type = -1, t; - - for (eqv = eqvclass; eqv < lasteqv; eqv++) - if (!eqv -> eqvinit && eqv -> eqvtop != eqv -> eqvbottom) { - if (!*did_one) - nice_printf (outfile, "/* System generated locals */\n"); - t = eqv->eqvtype; - if (last_type == t) - nice_printf (outfile, ", "); - else { - if (*did_one) - nice_printf (outfile, ";\n"); - nice_printf (outfile, "static %s ", c_type_decl(t, 0)); - k = typesize[t]; - } /* else */ - nice_printf(outfile, "%s", equiv_name((int)(eqv - eqvclass), CNULL)); - nice_printf(outfile, "[%ld]", - (eqv->eqvtop - eqv->eqvbottom + k - 1) / k); - last_type = t; - *did_one = 1; - } /* if !eqv -> eqvinit */ -} /* do_uninit_equivs */ - - -/* wr_ardecls -- Writes the brackets and size for an array - declaration. Because of the inner workings of the compiler, - multi-dimensional arrays get mapped directly into a one-dimensional - array, so we have to compute the size of the array here. When the - dimension is greater than 1, a string comment about the original size - is returned */ - - 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) - return NULL; - - sprintf(buf, "\t/* was "); /* would like to say k = sprintf(...), but */ - k = strlen(buf); /* BSD doesn't return char transmitted count */ - - for (i = 0; i < dimp -> ndim; i++) { - expptr this_size = dimp -> dims[i].dimsize; - - 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 { - non_const: - err ("wr_ardecls: nonconstant array size"); - } - } /* for i = 0 */ - - nice_printf (outfile, "[%ld]", size); - strcat(buf+k, " */"); - - return (i > 1) ? buf : NULL; -} /* wr_ardecls */ - - - -/* ---------------------------------------------------------------------- - - The following routines read from the p1 intermediate file. If - that format changes, only these routines need be changed - - ---------------------------------------------------------------------- */ - - static int -#ifdef KR_headers -get_p1_token(infile) - FILE *infile; -#else -get_p1_token(FILE *infile) -#endif -{ - int token = P1_UNKNOWN; - -/* NOT PORTABLE!! */ - - if (fscanf (infile, "%d", &token) == EOF) - return P1_EOF; - -/* Skip over the ": " */ - - if (getc (infile) != '\n') - getc (infile); - - return token; -} /* get_p1_token */ - - - -/* Returns a (null terminated) string from the input file */ - - 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 c; - - if (str == NULL) - return 0; - - if ((c = getc (fp)) != ' ') - ungetc (c, fp); - - if (fgets (str, size, fp)) { - int length; - - str[size - 1] = '\0'; - length = strlen (str); - -/* Get rid of the newline */ - - if (str[length - 1] == '\n') - str[length - 1] = '\0'; - return 1; - - } else if (feof (fp)) - return EOF; - else - return 0; -} /* p1gets */ - - - 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; - - if (type != TYCHAR) { - *resultp = result = ALLOC(Constblock); - result -> tag = TCONST; - result -> vtype = type; - } - - switch (type) { - case TYINT1: - case TYSHORT: - case TYLONG: - case TYLOGICAL: -#ifdef TYQUAD - case TYQUAD: -#endif - case TYLOGICAL1: - case TYLOGICAL2: - status = p1getd (infile, &(result -> Const.ci)); - break; - case TYREAL: - case TYDREAL: - status = p1getf(infile, &result->Const.cds[0]); - result->vstg = 1; - break; - case TYCOMPLEX: - case TYDCOMPLEX: - status = p1getf(infile, &result->Const.cds[0]); - if (status && status != EOF) - status = p1getf(infile, &result->Const.cds[1]); - result->vstg = 1; - break; - case TYCHAR: - status = fscanf(infile, "%lx", resultp); - break; - default: - erri ("p1get_const: bad constant type '%d'", type); - status = 0; - break; - } /* switch */ - - return status; -} /* p1get_const */ - - 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; -#else -p1getf(FILE *infile, char **result) -#endif -{ - - char buf[1324]; - register int k; - - k = fscanf (infile, "%s", buf); - if (k < 1) - k = EOF; - else - strcpy(*result = mem(strlen(buf)+1,0), buf); - return k; -} - - 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; - - bufptr = (char *) ckalloc (count); - - if (result) - *result = bufptr; - - for (; !feof (infile) && count > 0; count--) - *bufptr++ = getc (infile); - - return feof (infile) ? EOF : 1; -} /* p1getn */ - - static void -#ifdef KR_headers -proto(outfile, at, 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; - - if (at) { - /* Correct types that we learn on the fly, e.g. - subroutine gotcha(foo) - external foo - call zap(...,foo,...) - call foo(...) - */ - atypes = at->atypes; - n = at->defined ? at->dnargs : at->nargs; - for(i = 0; i++ < n; atypes++) { - if (!(cp = atypes->cp)) - continue; - j = atypes->type; - do { - np = (Namep)cp->datap; - k = np->vtype; - if (np->vclass == CLPROC) { - if (!np->vimpltype && k) - k += 200; - else { - if (j >= 300) - j = TYUNKNOWN + 200; - continue; - } - } - if (j == k) - continue; - if (j >= 300 - || j == 200 && k >= 200) - j = k; - else { - if (at->nargs >= 0) - bad_atypes(at,fname,i,j,k,""," and"); - goto break2; - } - } - while(cp = cp->nextp); - atypes->type = j; - frchain(&atypes->cp); - } - } - break2: - if (parens) { - nice_printf(outfile, parens); - return; - } - - if (!at || (n = at-> defined ? at->dnargs : at->nargs) < 0) { - nice_printf(outfile, Ansi == 1 ? "()" : "(...)"); - return; - } - - if (n == 0) { - nice_printf(outfile, Ansi == 1 ? "(void)" : "()"); - return; - } - - atypes = at->atypes; - nice_printf(outfile, "("); - comma = ""; - for(; --n >= 0; atypes++) { - k = atypes->type; - if (k == TYADDR) - nice_printf(outfile, "%schar **", comma); - else if (k >= 200) { - k -= 200; - if (k >= 100) - k -= 100; - nice_printf(outfile, "%s%s", comma, - usedcasts[k] = casttypes[k]); - } - else if (k >= 100) - nice_printf(outfile, - k == TYCHAR + 100 ? "%s%s *" : "%s%s", - comma, c_type_decl(k-100, 0)); - else - nice_printf(outfile, "%s%s *", comma, - c_type_decl(k, 0)); - comma = ", "; - } - nice_printf(outfile, ")"); - } - - void -#ifdef KR_headers -protowrite(protofile, type, name, e, 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; - - if (!(asave = Ansi)) - Castargs = Ansi = 1; - nice_printf(protofile, "extern %s %s", protorettypes[type], name); - list_arg_types(protofile, e, lengths, 0, ";\n"); - used_rets[type] = 1; - if (!(Ansi = asave)) - Castargs = 0; - } - - static void -#ifdef KR_headers -do_p1_1while(outfile) - FILE *outfile; -#else -do_p1_1while(FILE *outfile) -#endif -{ - if (*wh_next) { - nice_printf(outfile, - "for(;;) { /* while(complicated condition) */\n" /*}*/ ); - next_tab(outfile); - } - else - nice_printf(outfile, "while(" /*)*/ ); - } - - static void -#ifdef KR_headers -do_p1_2while(infile, outfile) - FILE *infile; - FILE *outfile; -#else -do_p1_2while(FILE *infile, FILE *outfile) -#endif -{ - expptr test; - - test = do_format(infile, outfile); - if (*wh_next) - nice_printf(outfile, "if (!("); - expr_out(outfile, test); - if (*wh_next++) - nice_printf(outfile, "))\n\tbreak;\n"); - else { - nice_printf(outfile, /*(*/ ") {\n"); - next_tab(outfile); - } - } - - static void -#ifdef KR_headers -do_p1_elseifstart(outfile) - FILE *outfile; -#else -do_p1_elseifstart(FILE *outfile) -#endif -{ /* with sufficiently illegal input, ei_next == ei_last == 0 is possible */ - if (ei_next < ei_last && *ei_next++) { - prev_tab(outfile); - nice_printf(outfile, /*{*/ - "} else /* if(complicated condition) */ {\n" /*}*/ ); - next_tab(outfile); - } - } diff --git a/usr.bin/f2c/format.h b/usr.bin/f2c/format.h deleted file mode 100644 index 3de97f6f89f3..000000000000 --- a/usr.bin/f2c/format.h +++ /dev/null @@ -1,12 +0,0 @@ -#define DEF_C_LINE_LENGTH 77 -/* actual max will be 79 */ - -extern int c_output_line_length; /* max # chars per line in C source - code */ - -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 deleted file mode 100644 index 56507bed19e4..000000000000 --- a/usr.bin/f2c/formatdata.c +++ /dev/null @@ -1,1242 +0,0 @@ -/**************************************************************** -Copyright 1990, 1991, 1993-6 by AT&T, Lucent Technologies and Bellcore. - -Permission to use, copy, modify, and distribute this software -and its documentation for any purpose and without fee is hereby -granted, provided that the above copyright notice appear in all -copies and that both that the copyright notice and this -permission notice and warranty disclaimer appear in supporting -documentation, and that the names of AT&T, Bell Laboratories, -Lucent or Bellcore or any of their entities not be used in -advertising or publicity pertaining to distribution of the -software without specific, written prior permission. - -AT&T, Lucent and Bellcore disclaim all warranties with regard to -this software, including all implied warranties of -merchantability and fitness. In no event shall AT&T, Lucent or -Bellcore be liable for any special, indirect or consequential -damages or any damages whatsoever resulting from loss of use, -data or profits, whether in an action of contract, negligence or -other tortious action, arising out of or in connection with the -use or performance of this software. -****************************************************************/ - -#include "defs.h" -#include "output.h" -#include "names.h" -#include "format.h" - -#define MAX_INIT_LINE 100 -#define NAME_MAX 64 - -static int memno2info Argdcl((int, Namep*)); - - extern char *initbname; - - 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; - - fclose(*Infile); - *Infile = 0; - - if (status = dsort(Inname, sortfname)) - fatali ("sort failed, status %d", status); - - scrub(Inname); /* optionally unlink Inname */ - - if ((sortfp = fopen(sortfname, textread)) == NULL) - Fatal("Couldn't open sorted initialization data"); - - do_init_data(outfile, sortfp); - fclose(sortfp); - scrub(sortfname); - -/* Insert a blank line after any initialized data */ - - nice_printf (outfile, "\n"); - - if (debugflag && infname) - /* don't back block data file up -- it won't be overwritten */ - backup(initfname, initbname); -} /* list_init_data */ - - - -/* do_init_data -- returns YES when at least one declaration has been - written */ - - 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; - ftnint type; - int vargroup; /* 0 --> init, 1 --> equiv, 2 --> common */ - int did_one = 0; /* True when one has been output */ - chainp values = CHNULL; /* Actual data values */ - int keepit = 0; - Namep np; - - ovarname[0] = '\0'; - - while (rdname (infile, &vargroup, varname) && rdlong (infile, &offset) - && rdlong (infile, &type)) { - if (strcmp (varname, ovarname)) { - - /* If this is a new variable name, the old initialization has been - completed */ - - wr_one_init(outfile, ovarname, &values, keepit); - - strcpy (ovarname, varname); - values = CHNULL; - if (vargroup == 0) { - if (memno2info(atoi(varname+2), &np)) { - if (((Addrp)np)->uname_tag != UNAM_NAME) { - err("do_init_data: expected NAME"); - goto Keep; - } - np = ((Addrp)np)->user.name; - } - if (!(keepit = np->visused) && !np->vimpldovar) - warn1("local variable %s never used", - np->fvarname); - } - else { - Keep: - keepit = 1; - } - if (keepit && !did_one) { - nice_printf (outfile, "/* Initialized data */\n\n"); - did_one = YES; - } - } /* if strcmp */ - - values = mkchain((char *)data_value(infile, offset, (int)type), values); - } /* while */ - -/* Write out the last declaration */ - - wr_one_init (outfile, ovarname, &values, keepit); - - return did_one; -} /* do_init_data */ - - - ftnint -#ifdef KR_headers -wr_char_len(outfile, dimp, n, 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 j, rv; - - if (!dimp) { - nice_printf (outfile, extra1 ? "[%d+1]" : "[%d]", n); - return n + extra1; - } - nice_printf(outfile, "[%d", n); - nd = dimp->ndim; - rv = n; - for(i = 0; i < nd; i++) { - e = dimp->dims[i].dimsize; - 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 { - non_const: - err ("wr_char_len: nonconstant array size"); - } - } - /* extra1 allows for stupid C compilers that complain about - * too many initializers in - * char x[2] = "ab"; - */ - nice_printf(outfile, extra1 ? "+1]" : "]"); - return extra1 ? rv+1 : rv; - } - - static int ch_ar_dim = -1; /* length of each element of char string array */ - static int eqvmemno; /* kludge */ - - static void -#ifdef KR_headers -write_char_init(outfile, Values, 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) - return; - if(nequiv >= maxequiv) - many("equivalences", 'q', maxequiv); - eqv = &eqvclass[nequiv]; - eqv->eqvbottom = 0; - type = namep->vtype; - size = type == TYCHAR - ? namep->vleng->constblock.Const.ci - : typesize[type]; - if (dimp = namep->vdim) - for(i = 0, nd = dimp->ndim; i < nd; i++) { - ds = dimp->dims[i].dimsize; - 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"); - } - } - *Values = revchain(*Values); - eqv->eqvtop = size; - eqvmemno = ++lastvarno; - eqv->eqvtype = type; - wr_equiv_init(outfile, nequiv, Values, 0); - def_start(outfile, namep->cvarname, CNULL, ""); - if (type == TYCHAR) - margin_printf(outfile, "((char *)&equiv_%d)\n\n", eqvmemno); - else - margin_printf(outfile, dimp - ? "((%s *)&equiv_%d)\n\n" : "(*(%s *)&equiv_%d)\n\n", - c_type_decl(type,0), eqvmemno); - } - -/* wr_one_init -- outputs the initialization of the variable pointed to - by info. When is_addr is true, info is an Addrp; otherwise, - treat it as a Namep */ - - 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 { - Namep name; - Addrp addr; - } info; - Namep namep; - int is_addr, size, type; - ftnint last, loc; - int is_scalar = 0; - char *array_comment = NULL, *name; - chainp cp, values; - extern char datachar[]; - static int e1[3] = {1, 0, 1}; - ftnint x; - extern int hsize; - - if (!keepit) - goto done; - if (varname == NULL || varname[1] != '.') - goto badvar; - -/* Get back to a meaningful representation; find the given memno in one - of the appropriate tables (user-generated variables in the hash table, - system-generated variables in a separate list */ - - memno = atoi(varname + 2); - switch(varname[0]) { - case 'q': - /* Must subtract eqvstart when the source file - * contains more than one procedure. - */ - wr_equiv_init(outfile, eqvmemno = memno - eqvstart, Values, 0); - goto done; - case 'Q': - /* COMMON initialization (BLOCK DATA) */ - wr_equiv_init(outfile, memno, Values, 1); - goto done; - case 'v': - break; - default: - badvar: - errstr("wr_one_init: unknown variable name '%s'", varname); - goto done; - } - - is_addr = memno2info (memno, &info.name); - if (info.name == (Namep) NULL) { - err ("wr_one_init -- unknown variable"); - return; - } - if (is_addr) { - if (info.addr -> uname_tag != UNAM_NAME) { - erri ("wr_one_init -- couldn't get name pointer; tag is %d", - info.addr -> uname_tag); - namep = (Namep) NULL; - nice_printf (outfile, " /* bad init data */"); - } else - namep = info.addr -> user.name; - } else - namep = info.name; - - /* check for character initialization */ - - *Values = values = revchain(*Values); - type = info.name->vtype; - if (type == TYCHAR) { - for(last = 0; values; values = values->nextp) { - cp = (chainp)values->datap; - loc = (ftnint)cp->datap; - if (loc > last) { - write_char_init(outfile, Values, namep); - goto done; - } - last = (int)cp->nextp->datap == TYBLANK - ? loc + (int)cp->nextp->nextp->datap - : loc + 1; - } - if (halign && info.name->tag == TNAME) { - nice_printf(outfile, "static struct { %s fill; char val", - halign); - x = wr_char_len(outfile, namep->vdim, ch_ar_dim = - info.name -> vleng -> constblock.Const.ci, 1); - if (x %= hsize) - nice_printf(outfile, "; char fill2[%ld]", hsize - x); - name = info.name->cvarname; - nice_printf(outfile, "; } %s_st = { 0,", name); - wr_output_values(outfile, namep, *Values); - nice_printf(outfile, " };\n"); - ch_ar_dim = -1; - def_start(outfile, name, CNULL, name); - margin_printf(outfile, "_st.val\n"); - goto done; - } - } - else { - size = typesize[type]; - loc = 0; - for(; values; values = values->nextp) { - if ((int)((chainp)values->datap)->nextp->datap == TYCHAR) { - write_char_init(outfile, Values, namep); - goto done; - } - last = ((long) ((chainp) values->datap)->datap) / size; - if (last - loc > 4) { - write_char_init(outfile, Values, namep); - goto done; - } - loc = last; - } - } - values = *Values; - - nice_printf (outfile, "static %s ", c_type_decl (type, 0)); - - if (is_addr) - write_nv_ident (outfile, info.addr); - else - out_name (outfile, info.name); - - if (namep) - is_scalar = namep -> vdim == (struct Dimblock *) NULL; - - if (namep && !is_scalar) - array_comment = type == TYCHAR - ? 0 : wr_ardecls(outfile, namep->vdim, 1L); - - if (type == TYCHAR) - if (ISICON (info.name -> vleng)) - -/* We'll make single strings one character longer, so that we can use the - standard C initialization. All this does is pad an extra zero onto the - end of the string */ - wr_char_len(outfile, namep->vdim, ch_ar_dim = - info.name -> vleng -> constblock.Const.ci, e1[Ansi]); - else - err ("variable length character initialization"); - - if (array_comment) - nice_printf (outfile, "%s", array_comment); - - nice_printf (outfile, " = "); - wr_output_values (outfile, namep, values); - ch_ar_dim = -1; - nice_printf (outfile, ";\n"); - done: - frchain(Values); -} /* wr_one_init */ - - - - - 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; - char *newval; - - if (fgets (line, MAX_INIT_LINE, infile) == NULL) { - err ("data_value: error reading from intermediate file"); - return CHNULL; - } /* if fgets */ - -/* Get rid of the trailing newline */ - - if (line[0]) - line[strlen (line) - 1] = '\0'; - -#define iswhite(x) (isspace (x) || (x) == ',') - - pointer = line; - prev_val = vals = CHNULL; - - while (*pointer) { - register char *end_ptr, old_val; - -/* Move pointer to the start of the next word */ - - while (*pointer && iswhite (*pointer)) - pointer++; - if (*pointer == '\0') - break; - -/* Move end_ptr to the end of the current word */ - - for (end_ptr = pointer + 1; *end_ptr && !iswhite (*end_ptr); - end_ptr++) - ; - - old_val = *end_ptr; - *end_ptr = '\0'; - -/* Add this value to the end of the list */ - - if (ONEOF(type, MSKREAL|MSKCOMPLEX)) - newval = cpstring(pointer); - else - newval = (char *)atol(pointer); - if (vals) { - prev_val->nextp = mkchain(newval, CHNULL); - prev_val = prev_val -> nextp; - } else - prev_val = vals = mkchain(newval, CHNULL); - *end_ptr = old_val; - pointer = end_ptr; - } /* while *pointer */ - - return mkchain((char *)offset, mkchain((char *)LONG_CAST type, vals)); -} /* data_value */ - - static void -overlapping(Void) -{ - extern char *filename0; - static int warned = 0; - - if (warned) - return; - warned = 1; - - fprintf(stderr, "Error"); - if (filename0) - fprintf(stderr, " in file %s", filename0); - fprintf(stderr, ": overlapping initializations\n"); - nerr++; - } - - static void make_one_const Argdcl((int, union Constant*, chainp)); - static long charlen; - - 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; - static expptr Vlen; - - if (namep) - type = namep -> vtype; - -/* Handle array initializations away from scalars */ - - if (namep && namep -> vdim) - wr_array_init (outfile, namep -> vtype, values); - - else if (values->nextp && type != TYCHAR) - overlapping(); - - else { - make_one_const(type, &Const.Const, values); - Const.vtype = type; - Const.vstg = ONEOF(type, MSKREAL|MSKCOMPLEX) != 0; - if (type== TYCHAR) { - if (!Vlen) - Vlen = ICON(0); - Const.vleng = Vlen; - Vlen->constblock.Const.ci = charlen; - out_const (outfile, &Const); - free (Const.Const.ccp); - } - else - out_const (outfile, &Const); - } - } - - - 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; - int k; - - if (type == TYCHAR) { - nice_printf(outfile, "\""); - k = 0; - if (Ansi != 1) - ch_ar_dim = -1; - } - else - nice_printf (outfile, "{ "); - while (values) { - struct Constblock Const; - - index = ((long) ((chainp) values->datap)->datap) / size; - while (index > main_index) { - -/* Fill with zeros. The structure shorthand works because the compiler - will expand the "0" in braces to fill the size of the entire structure - */ - - switch (type) { - case TYREAL: - case TYDREAL: - nice_printf (outfile, "0.0,"); - break; - case TYCOMPLEX: - case TYDCOMPLEX: - nice_printf (outfile, "{0},"); - break; - case TYCHAR: - nice_printf(outfile, " "); - break; - default: - nice_printf (outfile, "0,"); - break; - } /* switch */ - main_index++; - } /* while index > main_index */ - - if (index < main_index) - overlapping(); - else switch (type) { - case TYCHAR: - { int this_char; - - if (k == ch_ar_dim) { - nice_printf(outfile, "\" \""); - k = 0; - } - this_char = (int) ((chainp) values->datap)-> - nextp->nextp->datap; - if ((int)((chainp)values->datap)->nextp->datap == TYBLANK) { - main_index += this_char; - k += this_char; - while(--this_char >= 0) - nice_printf(outfile, " "); - values = values -> nextp; - continue; - } - nice_printf(outfile, str_fmt[this_char], this_char); - k++; - } /* case TYCHAR */ - break; - - case TYINT1: - case TYSHORT: - case TYLONG: -#ifdef TYQUAD - case TYQUAD: -#endif - case TYREAL: - case TYDREAL: - case TYLOGICAL: - case TYLOGICAL1: - case TYLOGICAL2: - case TYCOMPLEX: - case TYDCOMPLEX: - make_one_const(type, &Const.Const, values); - Const.vtype = type; - Const.vstg = ONEOF(type, MSKREAL|MSKCOMPLEX) != 0; - out_const(outfile, &Const); - break; - default: - erri("wr_array_init: bad type '%d'", type); - break; - } /* switch */ - values = values->nextp; - - main_index++; - if (values && type != TYCHAR) - nice_printf (outfile, ","); - } /* while values */ - - if (type == TYCHAR) { - nice_printf(outfile, "\""); - } - else - nice_printf (outfile, " }"); -} /* wr_array_init */ - - - static void -#ifdef KR_headers -make_one_const(type, storage, 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; - - if (type == TYCHAR) { - char *str, *str_ptr; - chainp v, prev; - int b = 0, k, main_index = 0; - -/* Find the max length of init string, by finding the highest offset - value stored in the list of initial values */ - - for(k = 1, prev = CHNULL, v = values; v; prev = v, v = v->nextp) - ; - if (prev != CHNULL) - k = ((int) (((chainp) prev->datap)->datap)) + 2; - /* + 2 above for null char at end */ - str = Alloc (k); - for (str_ptr = str; values; str_ptr++) { - int index = (int) (((chainp) values->datap)->datap); - - if (index < main_index) - overlapping(); - while (index > main_index++) - *str_ptr++ = ' '; - - k = (int) (((chainp) values->datap)->nextp->nextp->datap); - if ((int)((chainp)values->datap)->nextp->datap == TYBLANK) { - b = k; - break; - } - *str_ptr = k; - values = values -> nextp; - } /* for str_ptr */ - *str_ptr = '\0'; - Const = storage; - Const -> ccp = str; - Const -> ccp1.blanks = b; - charlen = str_ptr - str; - } else { - int i = 0; - chainp vals; - - vals = ((chainp)values->datap)->nextp->nextp; - if (vals) { - L = (char **)storage; - do L[i++] = vals->datap; - while(vals = vals->nextp); - } - - } /* else */ - -} /* make_one_const */ - - - 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; - - c = getc (infile); - - if (feof (infile)) - return NO; - - *vargroupp = c - '0'; - for (i = 1;; i++) { - if (i >= NAME_MAX) - Fatal("rdname: oversize name"); - c = getc (infile); - if (feof (infile)) - return NO; - if (c == '\t') - break; - *name++ = c; - } - *name = 0; - return YES; -} /* rdname */ - - int -#ifdef KR_headers -rdlong(infile, n) - FILE *infile; - ftnint *n; -#else -rdlong(FILE *infile, ftnint *n) -#endif -{ - register int c; - - for (c = getc (infile); !feof (infile) && isspace (c); c = getc (infile)) - ; - - if (feof (infile)) - return NO; - - for (*n = 0; isdigit (c); c = getc (infile)) - *n = 10 * (*n) + c - '0'; - return YES; -} /* rdlong */ - - - static int -#ifdef KR_headers -memno2info(memno, info) - int memno; - Namep *info; -#else -memno2info(int memno, Namep *info) -#endif -{ - chainp this_var; - extern chainp new_vars; - extern struct Hashentry *hashtab, *lasthash; - struct Hashentry *entry; - - for (this_var = new_vars; this_var; this_var = this_var -> nextp) { - Addrp var = (Addrp) this_var->datap; - - if (var == (Addrp) NULL) - Fatal("memno2info: null variable"); - else if (var -> tag != TADDR) - Fatal("memno2info: bad tag"); - if (memno == var -> memno) { - *info = (Namep) var; - return 1; - } /* if memno == var -> memno */ - } /* for this_var = new_vars */ - - for (entry = hashtab; entry < lasthash; ++entry) { - Namep var = entry -> varp; - - if (var && var -> vardesc.varno == memno && var -> vstg == STGINIT) { - *info = (Namep) var; - return 0; - } /* if entry -> vardesc.varno == memno */ - } /* for entry = hashtab */ - - Fatal("memno2info: couldn't find memno"); - return 0; -} /* memno2info */ - - static chainp -#ifdef KR_headers -do_string(outfile, v, 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; - unsigned long uk; - char buf[8], *comma; - - nice_printf(outfile, "{"); - cp = (chainp)v->datap; - loc = (ftnint)cp->datap; - comma = ""; - for(v0 = v;;) { - switch((int)cp->nextp->datap) { - case TYBLANK: - k = (ftnint)cp->nextp->nextp->datap; - loc += k; - while(--k >= 0) { - nice_printf(outfile, "%s' '", comma); - comma = ", "; - } - break; - case TYCHAR: - uk = (ftnint)cp->nextp->nextp->datap; - sprintf(buf, chr_fmt[uk], uk); - nice_printf(outfile, "%s'%s'", comma, buf); - comma = ", "; - loc++; - break; - default: - goto done; - } - v0 = v; - if (!(v = v->nextp) || !(cp = (chainp)v->datap)) - break; - dloc = (ftnint)cp->datap; - if (loc != dloc) - break; - } - done: - nice_printf(outfile, "}"); - *nloc = loc; - return v0; - } - - static chainp -#ifdef KR_headers -Ado_string(outfile, v, 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; - - nice_printf(outfile, "\""); - cp = (chainp)v->datap; - loc = (ftnint)cp->datap; - for(v0 = v;;) { - switch((int)cp->nextp->datap) { - case TYBLANK: - k = (ftnint)cp->nextp->nextp->datap; - loc += k; - while(--k >= 0) - nice_printf(outfile, " "); - break; - case TYCHAR: - k = (ftnint)cp->nextp->nextp->datap; - nice_printf(outfile, str_fmt[k], k); - loc++; - break; - default: - goto done; - } - v0 = v; - if (!(v = v->nextp) || !(cp = (chainp)v->datap)) - break; - dloc = (ftnint)cp->datap; - if (loc != dloc) - break; - } - done: - nice_printf(outfile, "\""); - *nloc = loc; - return v0; - } - - static char * -#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) - return ""; - sprintf(buf, "[%ld]", L); - return buf; - } - - static void -#ifdef KR_headers -fill_dcl(outfile, t, k, L) FILE *outfile; int t; int k; ftnint L; -#else -fill_dcl(FILE *outfile, int t, int k, ftnint L) -#endif -{ - nice_printf(outfile, "%s fill_%d[%ld];\n", typename[t], k, L); - } - - static int -#ifdef KR_headers -fill_type(L, loc, xtype) ftnint L; ftnint loc; int xtype; -#else -fill_type(ftnint L, ftnint loc, int xtype) -#endif -{ - int ft, ft1, szshort; - - if (xtype == TYCHAR) - return xtype; - szshort = typesize[TYSHORT]; - ft = L % szshort ? TYCHAR : type_choice[L/szshort % 4]; - ft1 = loc % szshort ? TYCHAR : type_choice[loc/szshort % 4]; - if (typesize[ft] > typesize[ft1]) - ft = ft1; - return ft; - } - - static ftnint -#ifdef KR_headers -get_fill(dloc, loc, t0, t1, L0, L1, xtype) ftnint dloc; ftnint loc; int *t0; int *t1; ftnint *L0; ftnint *L1; int xtype; -#else -get_fill(ftnint dloc, ftnint loc, int *t0, int *t1, ftnint *L0, ftnint *L1, int xtype) -#endif -{ - ftnint L, L2, loc0; - - if (L = loc % typesize[xtype]) { - loc0 = loc; - loc += L = typesize[xtype] - L; - if (L % typesize[TYSHORT]) - *t0 = TYCHAR; - else - L /= typesize[*t0 = fill_type(L, loc0, xtype)]; - } - if (dloc < loc + typesize[xtype]) - return 0; - *L0 = L; - L2 = (dloc - loc) / typesize[xtype]; - loc += L2*typesize[xtype]; - if (dloc -= loc) - dloc /= typesize[*t1 = fill_type(dloc, loc, xtype)]; - *L1 = dloc; - return L2; - } - - void -#ifdef KR_headers -wr_equiv_init(outfile, memno, Values, iscomm) - FILE *outfile; - int memno; - chainp *Values; - int iscomm; -#else -wr_equiv_init(FILE *outfile, int memno, chainp *Values, int iscomm) -#endif -{ - struct Equivblock *eqv; - int btype, curtype, dtype, filltype, j, k, n, t0, t1; - int wasblank, xfilled, xtype; - static char Blank[] = ""; - register char *comma = Blank; - register chainp cp, v; - chainp sentinel, values, v1, vlast; - ftnint L, L0, L1, L2, dL, dloc, loc, loc0; - union Constant Const; - char imag_buf[50], real_buf[50]; - int szshort = typesize[TYSHORT]; - static char typepref[] = {0, 0, TYINT1, TYSHORT, TYLONG, -#ifdef TYQUAD - TYQUAD, -#endif - TYREAL, TYDREAL, TYREAL, TYDREAL, - TYLOGICAL1, TYLOGICAL2, - TYLOGICAL, TYCHAR}; - static char basetype[] = {0, 0, TYCHAR, TYSHORT, TYLONG, -#ifdef TYQUAD - TYDREAL, -#endif - TYLONG, TYDREAL, TYLONG, TYDREAL, - TYCHAR, TYSHORT, - TYLONG, TYCHAR, 0 /* for TYBLANK */ }; - extern int htype; - char *z; - - /* add sentinel */ - if (iscomm) { - L = extsymtab[memno].maxleng; - xtype = extsymtab[memno].extype; - } - else { - eqv = &eqvclass[memno]; - L = eqv->eqvtop - eqv->eqvbottom; - xtype = eqv->eqvtype; - } - - if (halign && typealign[typepref[xtype]] < typealign[htype]) - xtype = htype; - xtype = typepref[xtype]; - *Values = values = revchain(vlast = *Values); - - xfilled = 2; - if (xtype != TYCHAR) { - - /* unless the data include a value of the appropriate - * type, we add an extra element in an attempt - * to force correct alignment */ - - btype = basetype[xtype]; - loc = 0; - for(v = *Values;;v = v->nextp) { - if (!v) { - dtype = typepref[xtype]; - z = ISREAL(dtype) ? cpstring("0.") : (char *)0; - k = typesize[dtype]; - if (j = L % k) - L += k - j; - v = mkchain((char *)L, - mkchain((char *)LONG_CAST dtype, - mkchain(z, CHNULL))); - vlast = vlast->nextp = - mkchain((char *)v, CHNULL); - L += k; - break; - } - cp = (chainp)v->datap; - if (basetype[(int)cp->nextp->datap] == btype) - break; - dloc = (ftnint)cp->datap; - if (get_fill(dloc, loc, &t0, &t1, &L0, &L1, xtype)) { - xfilled = 0; - break; - } - L1 = dloc - loc; - if (L1 > 0 - && !(L1 % szshort) - && !(loc % szshort) - && btype <= type_choice[L1/szshort % 4] - && btype <= type_choice[loc/szshort % 4]) - break; - dtype = (int)cp->nextp->datap; - loc = dloc + (dtype == TYBLANK - ? (ftnint)cp->nextp->nextp->datap - : typesize[dtype]); - } - } - sentinel = mkchain((char *)L, mkchain((char *)TYERROR,CHNULL)); - vlast->nextp = mkchain((char *)sentinel, CHNULL); - - /* use doublereal fillers only if there are doublereal values */ - - k = TYLONG; - for(v = values; v; v = v->nextp) - if (ONEOF((int)((chainp)v->datap)->nextp->datap, - M(TYDREAL)|M(TYDCOMPLEX))) { - k = TYDREAL; - break; - } - type_choice[0] = k; - - nice_printf(outfile, "%sstruct {\n", iscomm ? "" : "static "); - next_tab(outfile); - loc = loc0 = k = 0; - curtype = -1; - for(v = values; v; v = v->nextp) { - cp = (chainp)v->datap; - dloc = (ftnint)cp->datap; - L = dloc - loc; - if (L < 0) { - overlapping(); - if ((int)cp->nextp->datap != TYERROR) { - v1 = cp; - frchain(&v1); - v->datap = 0; - } - continue; - } - dtype = (int)cp->nextp->datap; - if (dtype == TYBLANK) { - dtype = TYCHAR; - wasblank = 1; - } - else - wasblank = 0; - if (curtype != dtype || L > 0) { - if (curtype != -1) { - L1 = (loc - loc0)/dL; - nice_printf(outfile, "%s e_%d%s;\n", - typename[curtype], ++k, - Len(L1,curtype)); - } - curtype = dtype; - loc0 = dloc; - } - if (L > 0) { - filltype = fill_type(L, loc, xtype); - L1 = L / typesize[filltype]; - if (!xfilled && (L2 = get_fill(dloc, loc, &t0, &t1, - &L0, &L1, xtype))) { - xfilled = 1; - if (L0) - fill_dcl(outfile, t0, ++k, L0); - fill_dcl(outfile, xtype, ++k, L2); - if (L1) - fill_dcl(outfile, t1, ++k, L1); - } - else - fill_dcl(outfile, filltype, ++k, L1); - loc = dloc; - } - if (wasblank) { - loc += (ftnint)cp->nextp->nextp->datap; - dL = 1; - } - else { - dL = typesize[dtype]; - loc += dL; - } - } - nice_printf(outfile, "} %s = { ", iscomm - ? extsymtab[memno].cextname - : equiv_name(eqvmemno, CNULL)); - loc = 0; - xfilled &= 2; - for(v = values; ; v = v->nextp) { - cp = (chainp)v->datap; - if (!cp) - continue; - dtype = (int)cp->nextp->datap; - if (dtype == TYERROR) - break; - dloc = (ftnint)cp->datap; - if (dloc > loc) { - n = 1; - if (!xfilled && (L2 = get_fill(dloc, loc, &t0, &t1, - &L0, &L1, xtype))) { - xfilled = 1; - if (L0) - n = 2; - if (L1) - n++; - } - while(n--) { - nice_printf(outfile, "%s{0}", comma); - comma = ", "; - } - loc = dloc; - } - if (comma != Blank) - nice_printf(outfile, ", "); - comma = ", "; - if (dtype == TYCHAR || dtype == TYBLANK) { - v = Ansi == 1 ? Ado_string(outfile, v, &loc) - : do_string(outfile, v, &loc); - continue; - } - make_one_const(dtype, &Const, v); - switch(dtype) { - case TYLOGICAL: - case TYLOGICAL2: - case TYLOGICAL1: - if (Const.ci < 0 || Const.ci > 1) - errl( - "wr_equiv_init: unexpected logical value %ld", - Const.ci); - nice_printf(outfile, - Const.ci ? "TRUE_" : "FALSE_"); - break; - case TYINT1: - case TYSHORT: - case TYLONG: -#ifdef TYQUAD - case TYQUAD: -#endif - nice_printf(outfile, "%ld", Const.ci); - break; - case TYREAL: - nice_printf(outfile, "%s", - flconst(real_buf, Const.cds[0])); - break; - case TYDREAL: - nice_printf(outfile, "%s", Const.cds[0]); - break; - case TYCOMPLEX: - nice_printf(outfile, "%s, %s", - flconst(real_buf, Const.cds[0]), - flconst(imag_buf, Const.cds[1])); - break; - case TYDCOMPLEX: - nice_printf(outfile, "%s, %s", - Const.cds[0], Const.cds[1]); - break; - default: - erri("unexpected type %d in wr_equiv_init", - dtype); - } - loc += typesize[dtype]; - } - nice_printf(outfile, " };\n\n"); - prev_tab(outfile); - frchain(&sentinel); - } diff --git a/usr.bin/f2c/ftypes.h b/usr.bin/f2c/ftypes.h deleted file mode 100644 index 80d2deba2db7..000000000000 --- a/usr.bin/f2c/ftypes.h +++ /dev/null @@ -1,51 +0,0 @@ - -/* variable types (stored in the vtype field of expptr) - * numeric assumptions: - * int < reals < complexes - * TYDREAL-TYREAL = TYDCOMPLEX-TYCOMPLEX - */ - -#ifdef NO_TYQUAD -#undef TYQUAD -#define TYQUAD_inc 0 -#else -#define TYQUAD 5 -#define TYQUAD_inc 1 -#endif - -#define TYUNKNOWN 0 -#define TYADDR 1 -#define TYINT1 2 -#define TYSHORT 3 -#define TYLONG 4 -/* #define TYQUAD 5 */ -#define TYREAL (5+TYQUAD_inc) -#define TYDREAL (6+TYQUAD_inc) -#define TYCOMPLEX (7+TYQUAD_inc) -#define TYDCOMPLEX (8+TYQUAD_inc) -#define TYLOGICAL1 (9+TYQUAD_inc) -#define TYLOGICAL2 (10+TYQUAD_inc) -#define TYLOGICAL (11+TYQUAD_inc) -#define TYCHAR (12+TYQUAD_inc) -#define TYSUBR (13+TYQUAD_inc) -#define TYERROR (14+TYQUAD_inc) -#define TYCILIST (15+TYQUAD_inc) -#define TYICILIST (16+TYQUAD_inc) -#define TYOLIST (17+TYQUAD_inc) -#define TYCLLIST (18+TYQUAD_inc) -#define TYALIST (19+TYQUAD_inc) -#define TYINLIST (20+TYQUAD_inc) -#define TYVOID (21+TYQUAD_inc) -#define TYLABEL (22+TYQUAD_inc) -#define TYFTNLEN (23+TYQUAD_inc) -/* TYVOID is not in any tables. */ - -/* NTYPES, NTYPES0 -- Total number of types, used to allocate tables indexed by - type. Such tables can include the size (in bytes) of objects of a given - type, or labels for returning objects of different types from procedures - (see array rtvlabels) */ - -#define NTYPES TYVOID -#define NTYPES0 TYCILIST -#define TYBLANK TYSUBR /* Huh? */ - diff --git a/usr.bin/f2c/gram.dcl b/usr.bin/f2c/gram.dcl deleted file mode 100644 index e5c5df0d5cd6..000000000000 --- a/usr.bin/f2c/gram.dcl +++ /dev/null @@ -1,416 +0,0 @@ -spec: dcl - | common - | external - | intrinsic - | equivalence - | data - | implicit - | namelist - | SSAVE - { NO66("SAVE statement"); - saveall = YES; } - | SSAVE savelist - { NO66("SAVE statement"); } - | SFORMAT - { fmtstmt(thislabel); setfmt(thislabel); } - | SPARAM in_dcl SLPAR paramlist SRPAR - { NO66("PARAMETER statement"); } - ; - -dcl: type opt_comma name in_dcl new_dcl dims lengspec - { settype($3, $1, $7); - if(ndim>0) setbound($3,ndim,dims); - } - | dcl SCOMMA name dims lengspec - { settype($3, $1, $5); - if(ndim>0) setbound($3,ndim,dims); - } - | dcl SSLASHD datainit vallist SSLASHD - { if (new_dcl == 2) { - err("attempt to give DATA in type-declaration"); - new_dcl = 1; - } - } - ; - -new_dcl: { new_dcl = 2; } ; - -type: typespec lengspec - { varleng = $2; } - ; - -typespec: typename - { varleng = ($1<0 || ONEOF($1,M(TYLOGICAL)|M(TYLONG)) - ? 0 : typesize[$1]); - vartype = $1; } - ; - -typename: SINTEGER { $$ = TYLONG; } - | SREAL { $$ = tyreal; } - | SCOMPLEX { ++complex_seen; $$ = tycomplex; } - | SDOUBLE { $$ = TYDREAL; } - | SDCOMPLEX { ++dcomplex_seen; NOEXT("DOUBLE COMPLEX statement"); $$ = TYDCOMPLEX; } - | SLOGICAL { $$ = TYLOGICAL; } - | SCHARACTER { NO66("CHARACTER statement"); $$ = TYCHAR; } - | SUNDEFINED { $$ = TYUNKNOWN; } - | SDIMENSION { $$ = TYUNKNOWN; } - | SAUTOMATIC { NOEXT("AUTOMATIC statement"); $$ = - STGAUTO; } - | SSTATIC { NOEXT("STATIC statement"); $$ = - STGBSS; } - | SBYTE { $$ = TYINT1; } - ; - -lengspec: - { $$ = varleng; } - | SSTAR intonlyon expr intonlyoff - { - expptr p; - p = $3; - NO66("length specification *n"); - if( ! ISICON(p) || p->constblock.Const.ci <= 0 ) - { - $$ = 0; - dclerr("length must be a positive integer constant", - NPNULL); - } - else { - if (vartype == TYCHAR) - $$ = p->constblock.Const.ci; - else switch((int)p->constblock.Const.ci) { - case 1: $$ = 1; break; - case 2: $$ = typesize[TYSHORT]; break; - case 4: $$ = typesize[TYLONG]; break; - case 8: $$ = typesize[TYDREAL]; break; - case 16: $$ = typesize[TYDCOMPLEX]; break; - default: - dclerr("invalid length",NPNULL); - $$ = varleng; - } - } - } - | SSTAR intonlyon SLPAR SSTAR SRPAR intonlyoff - { NO66("length specification *(*)"); $$ = -1; } - ; - -common: SCOMMON in_dcl var - { incomm( $$ = comblock("") , $3 ); } - | SCOMMON in_dcl comblock var - { $$ = $3; incomm($3, $4); } - | common opt_comma comblock opt_comma var - { $$ = $3; incomm($3, $5); } - | common SCOMMA var - { incomm($1, $3); } - ; - -comblock: SCONCAT - { $$ = comblock(""); } - | SSLASH SNAME SSLASH - { $$ = comblock(token); } - ; - -external: SEXTERNAL in_dcl name - { setext($3); } - | external SCOMMA name - { setext($3); } - ; - -intrinsic: SINTRINSIC in_dcl name - { NO66("INTRINSIC statement"); setintr($3); } - | intrinsic SCOMMA name - { setintr($3); } - ; - -equivalence: SEQUIV in_dcl equivset - | equivalence SCOMMA equivset - ; - -equivset: SLPAR equivlist SRPAR - { - struct Equivblock *p; - if(nequiv >= maxequiv) - many("equivalences", 'q', maxequiv); - p = & eqvclass[nequiv++]; - p->eqvinit = NO; - p->eqvbottom = 0; - p->eqvtop = 0; - p->equivs = $2; - } - ; - -equivlist: lhs - { $$=ALLOC(Eqvchain); - $$->eqvitem.eqvlhs = primchk($1); - } - | equivlist SCOMMA lhs - { $$=ALLOC(Eqvchain); - $$->eqvitem.eqvlhs = primchk($3); - $$->eqvnextp = $1; - } - ; - -data: SDATA in_data datalist - | data opt_comma datalist - ; - -in_data: - { if(parstate == OUTSIDE) - { - newproc(); - startproc(ESNULL, CLMAIN); - } - if(parstate < INDATA) - { - enddcl(); - parstate = INDATA; - datagripe = 1; - } - } - ; - -datalist: datainit datavarlist SSLASH datapop vallist SSLASH - { ftnint junk; - if(nextdata(&junk) != NULL) - err("too few initializers"); - frdata($2); - frrpl(); - } - ; - -datainit: /* nothing */ { frchain(&datastack); curdtp = 0; } ; - -datapop: /* nothing */ { pop_datastack(); } ; - -vallist: { toomanyinit = NO; } val - | vallist SCOMMA val - ; - -val: value - { dataval(ENULL, $1); } - | simple SSTAR value - { dataval($1, $3); } - ; - -value: simple - | addop simple - { if( $1==OPMINUS && ISCONST($2) ) - consnegop((Constp)$2); - $$ = $2; - } - | complex_const - ; - -savelist: saveitem - | savelist SCOMMA saveitem - ; - -saveitem: name - { int k; - $1->vsave = YES; - k = $1->vstg; - if( ! ONEOF(k, M(STGUNKNOWN)|M(STGBSS)|M(STGINIT)) ) - dclerr("can only save static variables", $1); - } - | comblock - ; - -paramlist: paramitem - | paramlist SCOMMA paramitem - ; - -paramitem: name SEQUALS expr - { if($1->vclass == CLUNKNOWN) - make_param((struct Paramblock *)$1, $3); - else dclerr("cannot make into parameter", $1); - } - ; - -var: name dims - { if(ndim>0) setbound($1, ndim, dims); } - ; - -datavar: lhs - { Namep np; - struct Primblock *pp = (struct Primblock *)$1; - int tt = $1->tag; - if (tt != TPRIM) { - if (tt == TCONST) - err("parameter in data statement"); - else - erri("tag %d in data statement",tt); - $$ = 0; - err_lineno = lineno; - break; - } - np = pp -> namep; - vardcl(np); - if ((pp->fcharp || pp->lcharp) - && (np->vtype != TYCHAR || np->vdim && !pp->argsp)) - sserr(np); - if(np->vstg == STGCOMMON) - extsymtab[np->vardesc.varno].extinit = YES; - else if(np->vstg==STGEQUIV) - eqvclass[np->vardesc.varno].eqvinit = YES; - else if(np->vstg!=STGINIT && np->vstg!=STGBSS) { - errstr(np->vstg == STGARG - ? "Dummy argument \"%.60s\" in data statement." - : "Cannot give data to \"%.75s\"", - np->fvarname); - $$ = 0; - err_lineno = lineno; - break; - } - $$ = mkchain((char *)$1, CHNULL); - } - | SLPAR datavarlist SCOMMA dospec SRPAR - { chainp p; struct Impldoblock *q; - pop_datastack(); - q = ALLOC(Impldoblock); - q->tag = TIMPLDO; - (q->varnp = (Namep) ($4->datap))->vimpldovar = 1; - p = $4->nextp; - if(p) { q->implb = (expptr)(p->datap); p = p->nextp; } - if(p) { q->impub = (expptr)(p->datap); p = p->nextp; } - if(p) { q->impstep = (expptr)(p->datap); } - frchain( & ($4) ); - $$ = mkchain((char *)q, CHNULL); - q->datalist = hookup($2, $$); - } - ; - -datavarlist: datavar - { if (!datastack) - curdtp = 0; - datastack = mkchain((char *)curdtp, datastack); - curdtp = $1; curdtelt = 0; - } - | datavarlist SCOMMA datavar - { $$ = hookup($1, $3); } - ; - -dims: - { ndim = 0; } - | SLPAR dimlist SRPAR - ; - -dimlist: { ndim = 0; } dim - | dimlist SCOMMA dim - ; - -dim: ubound - { - if(ndim == maxdim) - err("too many dimensions"); - else if(ndim < maxdim) - { dims[ndim].lb = 0; - dims[ndim].ub = $1; - } - ++ndim; - } - | expr SCOLON ubound - { - if(ndim == maxdim) - err("too many dimensions"); - else if(ndim < maxdim) - { dims[ndim].lb = $1; - dims[ndim].ub = $3; - } - ++ndim; - } - ; - -ubound: SSTAR - { $$ = 0; } - | expr - ; - -labellist: label - { nstars = 1; labarray[0] = $1; } - | labellist SCOMMA label - { if(nstars < maxlablist) labarray[nstars++] = $3; } - ; - -label: SICON - { $$ = execlab( convci(toklen, token) ); } - ; - -implicit: SIMPLICIT in_dcl implist - { NO66("IMPLICIT statement"); } - | implicit SCOMMA implist - ; - -implist: imptype SLPAR letgroups SRPAR - | imptype - { if (vartype != TYUNKNOWN) - dclerr("-- expected letter range",NPNULL); - setimpl(vartype, varleng, 'a', 'z'); } - ; - -imptype: { needkwd = 1; } type - /* { vartype = $2; } */ - ; - -letgroups: letgroup - | letgroups SCOMMA letgroup - ; - -letgroup: letter - { setimpl(vartype, varleng, $1, $1); } - | letter SMINUS letter - { setimpl(vartype, varleng, $1, $3); } - ; - -letter: SNAME - { if(toklen!=1 || token[0]<'a' || token[0]>'z') - { - dclerr("implicit item must be single letter", NPNULL); - $$ = 0; - } - else $$ = token[0]; - } - ; - -namelist: SNAMELIST - | namelist namelistentry - ; - -namelistentry: SSLASH name SSLASH namelistlist - { - if($2->vclass == CLUNKNOWN) - { - $2->vclass = CLNAMELIST; - $2->vtype = TYINT; - $2->vstg = STGBSS; - $2->varxptr.namelist = $4; - $2->vardesc.varno = ++lastvarno; - } - else dclerr("cannot be a namelist name", $2); - } - ; - -namelistlist: name - { $$ = mkchain((char *)$1, CHNULL); } - | namelistlist SCOMMA name - { $$ = hookup($1, mkchain((char *)$3, CHNULL)); } - ; - -in_dcl: - { switch(parstate) - { - case OUTSIDE: newproc(); - startproc(ESNULL, CLMAIN); - case INSIDE: parstate = INDCL; - case INDCL: break; - - case INDATA: - if (datagripe) { - errstr( - "Statement order error: declaration after DATA", - CNULL); - datagripe = 0; - } - break; - - default: - dclerr("declaration among executables", NPNULL); - } - } - ; diff --git a/usr.bin/f2c/gram.exec b/usr.bin/f2c/gram.exec deleted file mode 100644 index 39d7e427bbca..000000000000 --- a/usr.bin/f2c/gram.exec +++ /dev/null @@ -1,143 +0,0 @@ -exec: iffable - | SDO end_spec label opt_comma dospecw - { - if($3->labdefined) - execerr("no backward DO loops", CNULL); - $3->blklevel = blklevel+1; - exdo($3->labelno, NPNULL, $5); - } - | SDO end_spec opt_comma dospecw - { - exdo((int)(ctls - ctlstack - 2), NPNULL, $4); - NOEXT("DO without label"); - } - | SENDDO - { exenddo(NPNULL); } - | logif iffable - { exendif(); thiswasbranch = NO; } - | logif STHEN - | SELSEIF end_spec SLPAR expr SRPAR STHEN - { exelif($4); lastwasbranch = NO; } - | SELSE end_spec - { exelse(); lastwasbranch = NO; } - | SENDIF end_spec - { exendif(); lastwasbranch = NO; } - ; - -logif: SLOGIF end_spec SLPAR expr SRPAR - { exif($4); } - ; - -dospec: name SEQUALS exprlist - { $$ = mkchain((char *)$1, $3); } - ; - -dospecw: dospec - | SWHILE SLPAR expr SRPAR - { $$ = mkchain(CNULL, (chainp)$3); } - ; - -iffable: let lhs SEQUALS expr - { exequals((struct Primblock *)$2, $4); } - | SASSIGN end_spec assignlabel STO name - { exassign($5, $3); } - | SCONTINUE end_spec - | goto - | io - { inioctl = NO; } - | SARITHIF end_spec SLPAR expr SRPAR label SCOMMA label SCOMMA label - { exarif($4, $6, $8, $10); thiswasbranch = YES; } - | call - { excall($1, LBNULL, 0, labarray); } - | call SLPAR SRPAR - { excall($1, LBNULL, 0, labarray); } - | call SLPAR callarglist SRPAR - { if(nstars < maxlablist) - excall($1, mklist(revchain($3)), nstars, labarray); - else - many("alternate returns", 'l', maxlablist); - } - | SRETURN end_spec opt_expr - { exreturn($3); thiswasbranch = YES; } - | stop end_spec opt_expr - { exstop($1, $3); thiswasbranch = $1; } - ; - -assignlabel: SICON - { $$ = mklabel( convci(toklen, token) ); } - ; - -let: SLET - { if(parstate == OUTSIDE) - { - newproc(); - startproc(ESNULL, CLMAIN); - } - } - ; - -goto: SGOTO end_spec label - { exgoto($3); thiswasbranch = YES; } - | SASGOTO end_spec name - { exasgoto($3); thiswasbranch = YES; } - | SASGOTO end_spec name opt_comma SLPAR labellist SRPAR - { exasgoto($3); thiswasbranch = YES; } - | SCOMPGOTO end_spec SLPAR labellist SRPAR opt_comma expr - { if(nstars < maxlablist) - putcmgo(putx(fixtype($7)), nstars, labarray); - else - many("labels in computed GOTO list", 'l', maxlablist); - } - ; - -opt_comma: - | SCOMMA - ; - -call: SCALL end_spec name - { nstars = 0; $$ = $3; } - ; - -callarglist: callarg - { $$ = $1 ? mkchain((char *)$1,CHNULL) : CHNULL; } - | callarglist SCOMMA callarg - { $$ = $3 ? mkchain((char *)$3, $1) : $1; } - ; - -callarg: expr - | SSTAR label - { if(nstars < maxlablist) labarray[nstars++] = $2; $$ = 0; } - ; - -stop: SPAUSE - { $$ = 0; } - | SSTOP - { $$ = 2; } - ; - -exprlist: expr - { $$ = mkchain((char *)$1, CHNULL); } - | exprlist SCOMMA expr - { $$ = hookup($1, mkchain((char *)$3,CHNULL) ); } - ; - -end_spec: - { if(parstate == OUTSIDE) - { - newproc(); - startproc(ESNULL, CLMAIN); - } - -/* This next statement depends on the ordering of the state table encoding */ - - if(parstate < INDATA) enddcl(); - } - ; - -intonlyon: - { intonly = YES; } - ; - -intonlyoff: - { intonly = NO; } - ; diff --git a/usr.bin/f2c/gram.expr b/usr.bin/f2c/gram.expr deleted file mode 100644 index 1ef18e5022da..000000000000 --- a/usr.bin/f2c/gram.expr +++ /dev/null @@ -1,142 +0,0 @@ -funarglist: - { $$ = 0; } - | funargs - { $$ = revchain($1); } - ; - -funargs: expr - { $$ = mkchain((char *)$1, CHNULL); } - | funargs SCOMMA expr - { $$ = mkchain((char *)$3, $1); } - ; - - -expr: uexpr - | SLPAR expr SRPAR { $$ = $2; if ($$->tag == TPRIM) - $$->primblock.parenused = 1; } - | complex_const - ; - -uexpr: lhs - | simple_const - | expr addop expr %prec SPLUS - { $$ = mkexpr($2, $1, $3); } - | expr SSTAR expr - { $$ = mkexpr(OPSTAR, $1, $3); } - | expr SSLASH expr - { $$ = mkexpr(OPSLASH, $1, $3); } - | expr SPOWER expr - { $$ = mkexpr(OPPOWER, $1, $3); } - | addop expr %prec SSTAR - { if($1 == OPMINUS) - $$ = mkexpr(OPNEG, $2, ENULL); - else $$ = $2; - } - | expr relop expr %prec SEQ - { $$ = mkexpr($2, $1, $3); } - | expr SEQV expr - { NO66(".EQV. operator"); - $$ = mkexpr(OPEQV, $1,$3); } - | expr SNEQV expr - { NO66(".NEQV. operator"); - $$ = mkexpr(OPNEQV, $1, $3); } - | expr SOR expr - { $$ = mkexpr(OPOR, $1, $3); } - | expr SAND expr - { $$ = mkexpr(OPAND, $1, $3); } - | SNOT expr - { $$ = mkexpr(OPNOT, $2, ENULL); } - | expr SCONCAT expr - { NO66("concatenation operator //"); - $$ = mkexpr(OPCONCAT, $1, $3); } - ; - -addop: SPLUS { $$ = OPPLUS; } - | SMINUS { $$ = OPMINUS; } - ; - -relop: SEQ { $$ = OPEQ; } - | SGT { $$ = OPGT; } - | SLT { $$ = OPLT; } - | SGE { $$ = OPGE; } - | SLE { $$ = OPLE; } - | SNE { $$ = OPNE; } - ; - -lhs: name - { $$ = mkprim($1, LBNULL, CHNULL); } - | name substring - { NO66("substring operator :"); - $$ = mkprim($1, LBNULL, $2); } - | name SLPAR funarglist SRPAR - { $$ = mkprim($1, mklist($3), CHNULL); } - | name SLPAR funarglist SRPAR substring - { NO66("substring operator :"); - $$ = mkprim($1, mklist($3), $5); } - ; - -substring: SLPAR opt_expr SCOLON opt_expr SRPAR - { $$ = mkchain((char *)$2, mkchain((char *)$4,CHNULL)); } - ; - -opt_expr: - { $$ = 0; } - | expr - ; - -simple: name - { if($1->vclass == CLPARAM) - $$ = (expptr) cpexpr( - ( (struct Paramblock *) ($1) ) -> paramval); - } - | simple_const - ; - -simple_const: STRUE { $$ = mklogcon(1); } - | SFALSE { $$ = mklogcon(0); } - | SHOLLERITH { $$ = mkstrcon(toklen, token); } - | SICON = { $$ = mkintcon( convci(toklen, token) ); } - | SRCON = { $$ = mkrealcon(tyreal, token); } - | SDCON = { $$ = mkrealcon(TYDREAL, token); } - | bit_const - ; - -complex_const: SLPAR uexpr SCOMMA uexpr SRPAR - { $$ = mkcxcon($2,$4); } - ; - -bit_const: SHEXCON - { NOEXT("hex constant"); - $$ = mkbitcon(4, toklen, token); } - | SOCTCON - { NOEXT("octal constant"); - $$ = mkbitcon(3, toklen, token); } - | SBITCON - { NOEXT("binary constant"); - $$ = mkbitcon(1, toklen, token); } - ; - -fexpr: unpar_fexpr - | SLPAR fexpr SRPAR - { $$ = $2; } - ; - -unpar_fexpr: lhs - | simple_const - | fexpr addop fexpr %prec SPLUS - { $$ = mkexpr($2, $1, $3); } - | fexpr SSTAR fexpr - { $$ = mkexpr(OPSTAR, $1, $3); } - | fexpr SSLASH fexpr - { $$ = mkexpr(OPSLASH, $1, $3); } - | fexpr SPOWER fexpr - { $$ = mkexpr(OPPOWER, $1, $3); } - | addop fexpr %prec SSTAR - { if($1 == OPMINUS) - $$ = mkexpr(OPNEG, $2, ENULL); - else $$ = $2; - } - | fexpr SCONCAT fexpr - { NO66("concatenation operator //"); - $$ = mkexpr(OPCONCAT, $1, $3); } - ; diff --git a/usr.bin/f2c/gram.head b/usr.bin/f2c/gram.head deleted file mode 100644 index 183dfebbbdf9..000000000000 --- a/usr.bin/f2c/gram.head +++ /dev/null @@ -1,291 +0,0 @@ -/**************************************************************** -Copyright 1990, 1993 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 -granted, provided that the above copyright notice appear in all -copies and that both that the copyright notice and this -permission notice and warranty disclaimer appear in supporting -documentation, and that the names of AT&T Bell Laboratories or -Bellcore or any of their entities not be used in advertising or -publicity pertaining to distribution of the software without -specific, written prior permission. - -AT&T and Bellcore disclaim all warranties with regard to this -software, including all implied warranties of merchantability -and fitness. In no event shall AT&T or Bellcore be liable for -any special, indirect or consequential damages or any damages -whatsoever resulting from loss of use, data or profits, whether -in an action of contract, negligence or other tortious action, -arising out of or in connection with the use or performance of -this software. -****************************************************************/ - -%{ -#include "defs.h" -#include "p1defs.h" - -static int nstars; /* Number of labels in an - alternate return CALL */ -static int datagripe; -static int ndim; -static int vartype; -int new_dcl; -static ftnint varleng; -static struct Dims dims[MAXDIM+1]; -extern struct Labelblock **labarray; /* Labels in an alternate - return CALL */ -extern int maxlablist; - -/* The next two variables are used to verify that each statement might be reached - during runtime. lastwasbranch is tested only in the defintion of the - stat: nonterminal. */ - -int lastwasbranch = NO; -static int thiswasbranch = NO; -extern ftnint yystno; -extern flag intonly; -static chainp datastack; -extern long laststfcn, thisstno; -extern int can_include; /* for netlib */ -extern struct Primblock *primchk Argdcl((expptr)); - -#define ESNULL (Extsym *)0 -#define NPNULL (Namep)0 -#define LBNULL (struct Listblock *)0 - - static void -pop_datastack(Void) { - chainp d0 = datastack; - if (d0->datap) - curdtp = (chainp)d0->datap; - datastack = d0->nextp; - d0->nextp = 0; - frchain(&d0); - } - -%} - -/* Specify precedences and associativities. */ - -%union { - int ival; - ftnint lval; - char *charpval; - chainp chval; - tagptr tagval; - expptr expval; - struct Labelblock *labval; - struct Nameblock *namval; - struct Eqvchain *eqvval; - Extsym *extval; - } - -%left SCOMMA -%nonassoc SCOLON -%right SEQUALS -%left SEQV SNEQV -%left SOR -%left SAND -%left SNOT -%nonassoc SLT SGT SLE SGE SEQ SNE -%left SCONCAT -%left SPLUS SMINUS -%left SSTAR SSLASH -%right SPOWER - -%start program -%type <labval> thislabel label assignlabel -%type <tagval> other inelt -%type <ival> type typespec typename dcl letter addop relop stop nameeq -%type <lval> lengspec -%type <charpval> filename -%type <chval> datavar datavarlist namelistlist funarglist funargs -%type <chval> dospec dospecw -%type <chval> callarglist arglist args exprlist inlist outlist out2 substring -%type <namval> name arg call var -%type <expval> lhs expr uexpr opt_expr fexpr unpar_fexpr -%type <expval> ubound simple value callarg complex_const simple_const bit_const -%type <extval> common comblock entryname progname -%type <eqvval> equivlist - -%% - -program: - | program stat SEOS - ; - -stat: thislabel entry - { -/* stat: is the nonterminal for Fortran statements */ - - lastwasbranch = NO; } - | thislabel spec - | thislabel exec - { /* forbid further statement function definitions... */ - if (parstate == INDATA && laststfcn != thisstno) - parstate = INEXEC; - thisstno++; - if($1 && ($1->labelno==dorange)) - enddo($1->labelno); - if(lastwasbranch && thislabel==NULL) - warn("statement cannot be reached"); - lastwasbranch = thiswasbranch; - thiswasbranch = NO; - if($1) - { - if($1->labtype == LABFORMAT) - err("label already that of a format"); - else - $1->labtype = LABEXEC; - } - freetemps(); - } - | thislabel SINCLUDE filename - { if (can_include) - doinclude( $3 ); - else { - fprintf(diagfile, "Cannot open file %s\n", $3); - done(1); - } - } - | thislabel SEND end_spec - { if ($1) - lastwasbranch = NO; - endproc(); /* lastwasbranch = NO; -- set in endproc() */ - } - | thislabel SUNKNOWN - { unclassifiable(); - -/* flline flushes the current line, ignoring the rest of the text there */ - - flline(); } - | error - { flline(); needkwd = NO; inioctl = NO; - yyerrok; yyclearin; } - ; - -thislabel: SLABEL - { - if(yystno != 0) - { - $$ = thislabel = mklabel(yystno); - if( ! headerdone ) { - if (procclass == CLUNKNOWN) - procclass = CLMAIN; - puthead(CNULL, procclass); - } - if(thislabel->labdefined) - execerr("label %s already defined", - convic(thislabel->stateno) ); - else { - if(thislabel->blklevel!=0 && thislabel->blklevel<blklevel - && thislabel->labtype!=LABFORMAT) - warn1("there is a branch to label %s from outside block", - convic( (ftnint) (thislabel->stateno) ) ); - thislabel->blklevel = blklevel; - thislabel->labdefined = YES; - if(thislabel->labtype != LABFORMAT) - p1_label((long)(thislabel - labeltab)); - } - } - else $$ = thislabel = NULL; - } - ; - -entry: SPROGRAM new_proc progname - {startproc($3, CLMAIN); } - | SPROGRAM new_proc progname progarglist - { warn("ignoring arguments to main program"); - /* hashclear(); */ - startproc($3, CLMAIN); } - | SBLOCK new_proc progname - { if($3) NO66("named BLOCKDATA"); - startproc($3, CLBLOCK); } - | SSUBROUTINE new_proc entryname arglist - { entrypt(CLPROC, TYSUBR, (ftnint) 0, $3, $4); } - | SFUNCTION new_proc entryname arglist - { entrypt(CLPROC, TYUNKNOWN, (ftnint) 0, $3, $4); } - | type SFUNCTION new_proc entryname arglist - { entrypt(CLPROC, $1, varleng, $4, $5); } - | SENTRY entryname arglist - { if(parstate==OUTSIDE || procclass==CLMAIN - || procclass==CLBLOCK) - execerr("misplaced entry statement", CNULL); - entrypt(CLENTRY, 0, (ftnint) 0, $2, $3); - } - ; - -new_proc: - { newproc(); } - ; - -entryname: name - { $$ = newentry($1, 1); } - ; - -name: SNAME - { $$ = mkname(token); } - ; - -progname: { $$ = NULL; } - | entryname - ; - -progarglist: - SLPAR SRPAR - | SLPAR progargs SRPAR - ; - -progargs: progarg - | progargs SCOMMA progarg - ; - -progarg: SNAME - | SNAME SEQUALS SNAME - ; - -arglist: - { $$ = 0; } - | SLPAR SRPAR - { NO66(" () argument list"); - $$ = 0; } - | SLPAR args SRPAR - {$$ = $2; } - ; - -args: arg - { $$ = ($1 ? mkchain((char *)$1,CHNULL) : CHNULL ); } - | args SCOMMA arg - { if($3) $1 = $$ = mkchain((char *)$3, $1); } - ; - -arg: name - { if($1->vstg!=STGUNKNOWN && $1->vstg!=STGARG) - dclerr("name declared as argument after use", $1); - $1->vstg = STGARG; - } - | SSTAR - { NO66("altenate return argument"); - -/* substars means that '*'ed formal parameters should be replaced. - This is used to specify alternate return labels; in theory, only - parameter slots which have '*' should accept the statement labels. - This compiler chooses to ignore the '*'s in the formal declaration, and - always return the proper value anyway. - - This variable is only referred to in proc.c */ - - $$ = 0; substars = YES; } - ; - - - -filename: SHOLLERITH - { - char *s; - s = copyn(toklen+1, token); - s[toklen] = '\0'; - $$ = s; - } - ; diff --git a/usr.bin/f2c/gram.io b/usr.bin/f2c/gram.io deleted file mode 100644 index f1a6649aacd7..000000000000 --- a/usr.bin/f2c/gram.io +++ /dev/null @@ -1,173 +0,0 @@ - /* Input/Output Statements */ - -io: io1 - { endio(); } - ; - -io1: iofmove ioctl - | iofmove unpar_fexpr - { ioclause(IOSUNIT, $2); endioctl(); } - | iofmove SSTAR - { ioclause(IOSUNIT, ENULL); endioctl(); } - | iofmove SPOWER - { ioclause(IOSUNIT, IOSTDERR); endioctl(); } - | iofctl ioctl - | read ioctl - { doio(CHNULL); } - | read infmt - { doio(CHNULL); } - | read ioctl inlist - { doio(revchain($3)); } - | read infmt SCOMMA inlist - { doio(revchain($4)); } - | read ioctl SCOMMA inlist - { doio(revchain($4)); } - | write ioctl - { doio(CHNULL); } - | write ioctl outlist - { doio(revchain($3)); } - | print - { doio(CHNULL); } - | print SCOMMA outlist - { doio(revchain($3)); } - ; - -iofmove: fmkwd end_spec in_ioctl - ; - -fmkwd: SBACKSPACE - { iostmt = IOBACKSPACE; } - | SREWIND - { iostmt = IOREWIND; } - | SENDFILE - { iostmt = IOENDFILE; } - ; - -iofctl: ctlkwd end_spec in_ioctl - ; - -ctlkwd: SINQUIRE - { iostmt = IOINQUIRE; } - | SOPEN - { iostmt = IOOPEN; } - | SCLOSE - { iostmt = IOCLOSE; } - ; - -infmt: unpar_fexpr - { - ioclause(IOSUNIT, ENULL); - ioclause(IOSFMT, $1); - endioctl(); - } - | SSTAR - { - ioclause(IOSUNIT, ENULL); - ioclause(IOSFMT, ENULL); - endioctl(); - } - ; - -ioctl: SLPAR fexpr SRPAR - { - ioclause(IOSUNIT, $2); - endioctl(); - } - | SLPAR ctllist SRPAR - { endioctl(); } - ; - -ctllist: ioclause - | ctllist SCOMMA ioclause - ; - -ioclause: fexpr - { ioclause(IOSPOSITIONAL, $1); } - | SSTAR - { ioclause(IOSPOSITIONAL, ENULL); } - | SPOWER - { ioclause(IOSPOSITIONAL, IOSTDERR); } - | nameeq expr - { ioclause($1, $2); } - | nameeq SSTAR - { ioclause($1, ENULL); } - | nameeq SPOWER - { ioclause($1, IOSTDERR); } - ; - -nameeq: SNAMEEQ - { $$ = iocname(); } - ; - -read: SREAD end_spec in_ioctl - { iostmt = IOREAD; } - ; - -write: SWRITE end_spec in_ioctl - { iostmt = IOWRITE; } - ; - -print: SPRINT end_spec fexpr in_ioctl - { - iostmt = IOWRITE; - ioclause(IOSUNIT, ENULL); - ioclause(IOSFMT, $3); - endioctl(); - } - | SPRINT end_spec SSTAR in_ioctl - { - iostmt = IOWRITE; - ioclause(IOSUNIT, ENULL); - ioclause(IOSFMT, ENULL); - endioctl(); - } - ; - -inlist: inelt - { $$ = mkchain((char *)$1, CHNULL); } - | inlist SCOMMA inelt - { $$ = mkchain((char *)$3, $1); } - ; - -inelt: lhs - { $$ = (tagptr) $1; } - | SLPAR inlist SCOMMA dospec SRPAR - { $$ = (tagptr) mkiodo($4,revchain($2)); } - ; - -outlist: uexpr - { $$ = mkchain((char *)$1, CHNULL); } - | other - { $$ = mkchain((char *)$1, CHNULL); } - | out2 - ; - -out2: uexpr SCOMMA uexpr - { $$ = mkchain((char *)$3, mkchain((char *)$1, CHNULL) ); } - | uexpr SCOMMA other - { $$ = mkchain((char *)$3, mkchain((char *)$1, CHNULL) ); } - | other SCOMMA uexpr - { $$ = mkchain((char *)$3, mkchain((char *)$1, CHNULL) ); } - | other SCOMMA other - { $$ = mkchain((char *)$3, mkchain((char *)$1, CHNULL) ); } - | out2 SCOMMA uexpr - { $$ = mkchain((char *)$3, $1); } - | out2 SCOMMA other - { $$ = mkchain((char *)$3, $1); } - ; - -other: complex_const - { $$ = (tagptr) $1; } - | SLPAR expr SRPAR - { $$ = (tagptr) $2; } - | SLPAR uexpr SCOMMA dospec SRPAR - { $$ = (tagptr) mkiodo($4, mkchain((char *)$2, CHNULL) ); } - | SLPAR other SCOMMA dospec SRPAR - { $$ = (tagptr) mkiodo($4, mkchain((char *)$2, CHNULL) ); } - | SLPAR out2 SCOMMA dospec SRPAR - { $$ = (tagptr) mkiodo($4, revchain($2)); } - ; - -in_ioctl: - { startioctl(); } - ; diff --git a/usr.bin/f2c/init.c b/usr.bin/f2c/init.c deleted file mode 100644 index bc0dff40decb..000000000000 --- a/usr.bin/f2c/init.c +++ /dev/null @@ -1,517 +0,0 @@ -/**************************************************************** -Copyright 1990, 1992 - 1996 by AT&T, Lucent Technologies and Bellcore. - -Permission to use, copy, modify, and distribute this software -and its documentation for any purpose and without fee is hereby -granted, provided that the above copyright notice appear in all -copies and that both that the copyright notice and this -permission notice and warranty disclaimer appear in supporting -documentation, and that the names of AT&T, Bell Laboratories, -Lucent or Bellcore or any of their entities not be used in -advertising or publicity pertaining to distribution of the -software without specific, written prior permission. - -AT&T, Lucent and Bellcore disclaim all warranties with regard to -this software, including all implied warranties of -merchantability and fitness. In no event shall AT&T, Lucent or -Bellcore be liable for any special, indirect or consequential -damages or any damages whatsoever resulting from loss of use, -data or profits, whether in an action of contract, negligence or -other tortious action, arising out of or in connection with the -use or performance of this software. -****************************************************************/ - -#include "defs.h" -#include "output.h" -#include "iob.h" - -/* State required for the C output */ -char *fl_fmt_string; /* Float format string */ -char *db_fmt_string; /* Double format string */ -char *cm_fmt_string; /* Complex format string */ -char *dcm_fmt_string; /* Double complex format string */ - -chainp new_vars = CHNULL; /* List of newly created locals in this - function. These may have identifiers - which have underscores and more than VL - characters */ -chainp used_builtins = CHNULL; /* List of builtins used by this function. - These are all Addrps with UNAM_EXTERN - */ -chainp assigned_fmts = CHNULL; /* assigned formats */ -chainp allargs; /* union of args in all entry points */ -chainp earlylabs; /* labels seen before enddcl() */ -char main_alias[52]; /* PROGRAM name, if any is given */ -int tab_size = 4; - - -FILEP infile; -FILEP diagfile; - -FILEP c_file; -FILEP pass1_file; -FILEP initfile; -FILEP blkdfile; - - -char *token; -int maxtoklen, toklen; -long err_lineno; -long lineno; /* Current line in the input file, NOT the - Fortran statement label number */ -char *infname; -int needkwd; -struct Labelblock *thislabel = NULL; -int nerr; -int nwarn; - -flag saveall; -flag substars; -int parstate = OUTSIDE; -flag headerdone = NO; -int blklevel; -int doin_setbound; -int impltype[26]; -ftnint implleng[26]; -int implstg[26]; - -int tyint = TYLONG ; -int tylogical = TYLONG; -int tylog = TYLOGICAL; -int typesize[NTYPES] = { - 1, SZADDR, 1, SZSHORT, SZLONG, -#ifdef TYQUAD - 2*SZLONG, -#endif - SZLONG, 2*SZLONG, - 2*SZLONG, 4*SZLONG, 1, SZSHORT, SZLONG, 1, 1, 0, - 4*SZLONG + SZADDR, /* sizeof(cilist) */ - 4*SZLONG + 2*SZADDR, /* sizeof(icilist) */ - 4*SZLONG + 5*SZADDR, /* sizeof(olist) */ - 2*SZLONG + SZADDR, /* sizeof(cllist) */ - 2*SZLONG, /* sizeof(alist) */ - 11*SZLONG + 15*SZADDR /* sizeof(inlist) */ - }; - -int typealign[NTYPES] = { - 1, ALIADDR, 1, ALISHORT, ALILONG, -#ifdef TYQUAD - ALIDOUBLE, -#endif - ALILONG, ALIDOUBLE, - ALILONG, ALIDOUBLE, 1, ALISHORT, ALILONG, 1, 1, 1, - ALILONG, ALILONG, ALILONG, ALILONG, ALILONG, ALILONG}; - -int type_choice[4] = { TYDREAL, TYSHORT, TYLONG, TYSHORT }; - -char *typename[] = { - "<<unknown>>", - "address", - "integer1", - "shortint", - "integer", -#ifdef TYQUAD - "longint", -#endif - "real", - "doublereal", - "complex", - "doublecomplex", - "logical1", - "shortlogical", - "logical", - "char" /* character */ - }; - -int type_pref[NTYPES] = { 0, 0, 3, 5, 7, -#ifdef TYQUAD - 10, -#endif - 8, 11, 9, 12, 1, 4, 6, 2 }; - -char *protorettypes[] = { - "?", "??", "integer1", "shortint", "integer", -#ifdef TYQUAD - "longint", -#endif - "real", "doublereal", - "C_f", "Z_f", "logical1", "shortlogical", "logical", "H_f", "int" - }; - -char *casttypes[TYSUBR+1] = { - "U_fp", "??bug??", "I1_fp", - "J_fp", "I_fp", -#ifdef TYQUAD - "Q_fp", -#endif - "R_fp", "D_fp", "C_fp", "Z_fp", - "L1_fp", "L2_fp", "L_fp", "H_fp", "S_fp" - }; -char *usedcasts[TYSUBR+1]; - -char *dfltarg[] = { - 0, 0, "(integer1 *)0", - "(shortint *)0", "(integer *)0", -#ifdef TYQUAD - "(longint *)0", -#endif - "(real *)0", - "(doublereal *)0", "(complex *)0", "(doublecomplex *)0", - "(logical1 *)0","(shortlogical *)0", "(logical *)0", "(char *)0" - }; - -static char *dflt0proc[] = { - 0, 0, "(integer1 (*)())0", - "(shortint (*)())0", "(integer (*)())0", -#ifdef TYQUAD - "(longint (*)())0", -#endif - "(real (*)())0", - "(doublereal (*)())0", "(complex (*)())0", "(doublecomplex (*)())0", - "(logical1 (*)())0", "(shortlogical (*)())0", - "(logical (*)())0", "(char (*)())0", "(int (*)())0" - }; - -char *dflt1proc[] = { "(U_fp)0", "(??bug??)0", "(I1_fp)0", - "(J_fp)0", "(I_fp)0", -#ifdef TYQUAD - "(Q_fp)0", -#endif - "(R_fp)0", "(D_fp)0", "(C_fp)0", "(Z_fp)0", - "(L1_fp)0","(L2_fp)0", - "(L_fp)0", "(H_fp)0", "(S_fp)0" - }; - -char **dfltproc = dflt0proc; - -static char Bug[] = "bug"; - -char *ftn_types[] = { "external", "??", "integer*1", - "integer*2", "integer", -#ifdef TYQUAD - "integer*8", -#endif - "real", - "double precision", "complex", "double complex", - "logical*1", "logical*2", - "logical", "character", "subroutine", - Bug,Bug,Bug,Bug,Bug,Bug,Bug,Bug,Bug, "ftnlen" - }; - -int init_ac[TYSUBR+1] = { 0,0,0,0,0,0,0, -#ifdef TYQUAD - 0, -#endif - 1, 1, 0, 0, 0, 2}; - -int proctype = TYUNKNOWN; -char *procname; -int rtvlabel[NTYPES0]; -Addrp retslot; /* Holds automatic variable which was - allocated the function return value - */ -Addrp xretslot[NTYPES0]; /* for multiple entry points */ -int cxslot = -1; -int chslot = -1; -int chlgslot = -1; -int procclass = CLUNKNOWN; -int nentry; -int nallargs; -int nallchargs; -flag multitype; -ftnint procleng; -long lastiolabno; -long lastlabno; -int lastvarno; -int lastargslot; -int autonum[TYVOID]; -char *av_pfix[TYVOID] = {"??TYUNKNOWN??", "a","i1","s","i", -#ifdef TYQUAD - "i8", -#endif - "r","d","q","z","L1","L2","L","ch", - "??TYSUBR??", "??TYERROR??","ci", "ici", - "o", "cl", "al", "ioin" }; - -extern int maxctl; -struct Ctlframe *ctls; -struct Ctlframe *ctlstack; -struct Ctlframe *lastctl; - -Namep regnamep[MAXREGVAR]; -int highregvar; -int nregvar; - -extern int maxext; -Extsym *extsymtab; -Extsym *nextext; -Extsym *lastext; - -extern int maxequiv; -struct Equivblock *eqvclass; - -extern int maxhash; -struct Hashentry *hashtab; -struct Hashentry *lasthash; - -extern int maxstno; /* Maximum number of statement labels */ -struct Labelblock *labeltab; -struct Labelblock *labtabend; -struct Labelblock *highlabtab; - -int maxdim = MAXDIM; -struct Rplblock *rpllist = NULL; -struct Chain *curdtp = NULL; -flag toomanyinit; -ftnint curdtelt; -chainp templist[TYVOID]; -chainp holdtemps; -int dorange = 0; -struct Entrypoint *entries = NULL; - -chainp chains = NULL; - -flag inioctl; -int iostmt; -int nioctl; -int nequiv = 0; -int eqvstart = 0; -int nintnames = 0; -extern int maxlablist; -struct Labelblock **labarray; - -struct Literal *litpool; -int nliterals; - -char dflttype[26]; -char hextoi_tab[Table_size], Letters[Table_size]; -char *ei_first, *ei_next, *ei_last; -char *wh_first, *wh_next, *wh_last; - -#define ALLOCN(n,x) (struct x *) ckalloc((n)*sizeof(struct x)) - - void -fileinit(Void) -{ - register char *s; - register int i, j; - - lastiolabno = 100000; - lastlabno = 0; - lastvarno = 0; - nliterals = 0; - nerr = 0; - - infile = stdin; - - maxtoklen = 502; - token = (char *)ckalloc(maxtoklen+2); - memset(dflttype, tyreal, 26); - memset(dflttype + 'i' - 'a', tyint, 6); - memset(hextoi_tab, 16, sizeof(hextoi_tab)); - for(i = 0, s = "0123456789abcdef"; *s; i++, s++) - hextoi(*s) = i; - for(i = 10, s = "ABCDEF"; *s; i++, s++) - hextoi(*s) = i; - for(j = 0, s = "abcdefghijklmnopqrstuvwxyz"; i = *s++; j++) - Letters[i] = Letters[i+'A'-'a'] = j; - - ctls = ALLOCN(maxctl+1, Ctlframe); - extsymtab = ALLOCN(maxext, Extsym); - eqvclass = ALLOCN(maxequiv, Equivblock); - hashtab = ALLOCN(maxhash, Hashentry); - labeltab = ALLOCN(maxstno, Labelblock); - litpool = ALLOCN(maxliterals, Literal); - labarray = (struct Labelblock **)ckalloc(maxlablist* - sizeof(struct Labelblock *)); - fmt_init(); - mem_init(); - np_init(); - - ctlstack = ctls++; - lastctl = ctls + maxctl; - nextext = extsymtab; - lastext = extsymtab + maxext; - lasthash = hashtab + maxhash; - labtabend = labeltab + maxstno; - highlabtab = labeltab; - main_alias[0] = '\0'; - if (forcedouble) - dfltproc[TYREAL] = dfltproc[TYDREAL]; - -/* Initialize the routines for providing C output */ - - out_init (); -} - - void -hashclear(Void) /* clear hash table */ -{ - register struct Hashentry *hp; - register Namep p; - register struct Dimblock *q; - register int i; - - for(hp = hashtab ; hp < lasthash ; ++hp) - if(p = hp->varp) - { - frexpr(p->vleng); - if(q = p->vdim) - { - for(i = 0 ; i < q->ndim ; ++i) - { - frexpr(q->dims[i].dimsize); - frexpr(q->dims[i].dimexpr); - } - frexpr(q->nelt); - frexpr(q->baseoffset); - frexpr(q->basexpr); - free( (charptr) q); - } - if(p->vclass == CLNAMELIST) - frchain( &(p->varxptr.namelist) ); - free( (charptr) p); - hp->varp = NULL; - } - } - - void -procinit(Void) -{ - register struct Labelblock *lp; - struct Chain *cp; - int i; - struct memblock; - extern struct memblock *curmemblock, *firstmemblock; - extern char *mem_first, *mem_next, *mem_last, *mem0_last; - - curmemblock = firstmemblock; - mem_next = mem_first; - mem_last = mem0_last; - ei_next = ei_first = ei_last = 0; - wh_next = wh_first = wh_last = 0; - iob_list = 0; - for(i = 0; i < 9; i++) - io_structs[i] = 0; - - parstate = OUTSIDE; - headerdone = NO; - blklevel = 1; - saveall = NO; - substars = NO; - nwarn = 0; - thislabel = NULL; - needkwd = 0; - - proctype = TYUNKNOWN; - procname = "MAIN_"; - procclass = CLUNKNOWN; - nentry = 0; - nallargs = nallchargs = 0; - multitype = NO; - retslot = NULL; - for(i = 0; i < NTYPES0; i++) { - frexpr((expptr)xretslot[i]); - xretslot[i] = 0; - } - cxslot = -1; - chslot = -1; - chlgslot = -1; - procleng = 0; - blklevel = 1; - lastargslot = 0; - - for(lp = labeltab ; lp < labtabend ; ++lp) - lp->stateno = 0; - - hashclear(); - -/* Clear the list of newly generated identifiers from the previous - function */ - - frexchain(&new_vars); - frexchain(&used_builtins); - frchain(&assigned_fmts); - frchain(&allargs); - frchain(&earlylabs); - - nintnames = 0; - highlabtab = labeltab; - - ctlstack = ctls - 1; - for(i = TYADDR; i < TYVOID; i++) { - for(cp = templist[i]; cp ; cp = cp->nextp) - free( (charptr) (cp->datap) ); - frchain(templist + i); - autonum[i] = 0; - } - holdtemps = NULL; - dorange = 0; - nregvar = 0; - highregvar = 0; - entries = NULL; - rpllist = NULL; - inioctl = NO; - eqvstart += nequiv; - nequiv = 0; - dcomplex_seen = 0; - - for(i = 0 ; i<NTYPES0 ; ++i) - rtvlabel[i] = 0; - - if(undeftype) - setimpl(TYUNKNOWN, (ftnint) 0, 'a', 'z'); - else - { - setimpl(tyreal, (ftnint) 0, 'a', 'z'); - setimpl(tyint, (ftnint) 0, 'i', 'n'); - } - setimpl(-STGBSS, (ftnint) 0, 'a', 'z'); /* set class */ -} - - - - void -#ifdef KR_headers -setimpl(type, length, c1, c2) - int type; - ftnint length; - int c1; - int c2; -#else -setimpl(int type, ftnint length, int c1, int c2) -#endif -{ - int i; - char buff[100]; - - if(c1==0 || c2==0) - return; - - if(c1 > c2) { - sprintf(buff, "characters out of order in implicit:%c-%c", c1, c2); - err(buff); - } - else { - c1 = letter(c1); - c2 = letter(c2); - if(type < 0) - for(i = c1 ; i<=c2 ; ++i) - implstg[i] = - type; - else { - type = lengtype(type, length); - if(type == TYCHAR) { - if (length < 0) { - err("length (*) in implicit"); - length = 1; - } - } - else if (type != TYLONG) - length = 0; - for(i = c1 ; i<=c2 ; ++i) { - impltype[i] = type; - implleng[i] = length; - } - } - } - } diff --git a/usr.bin/f2c/intr.c b/usr.bin/f2c/intr.c deleted file mode 100644 index 3fc177ad0ea0..000000000000 --- a/usr.bin/f2c/intr.c +++ /dev/null @@ -1,978 +0,0 @@ -/**************************************************************** -Copyright 1990, 1992, 1994-6, 1998 by AT&T, Lucent Technologies and Bellcore. - -Permission to use, copy, modify, and distribute this software -and its documentation for any purpose and without fee is hereby -granted, provided that the above copyright notice appear in all -copies and that both that the copyright notice and this -permission notice and warranty disclaimer appear in supporting -documentation, and that the names of AT&T, Bell Laboratories, -Lucent or Bellcore or any of their entities not be used in -advertising or publicity pertaining to distribution of the -software without specific, written prior permission. - -AT&T, Lucent and Bellcore disclaim all warranties with regard to -this software, including all implied warranties of -merchantability and fitness. In no event shall AT&T, Lucent or -Bellcore be liable for any special, indirect or consequential -damages or any damages whatsoever resulting from loss of use, -data or profits, whether in an action of contract, negligence or -other tortious action, arising out of or in connection with the -use or performance of this software. -****************************************************************/ - -#include "defs.h" -#include "names.h" - -union - { - int ijunk; - struct Intrpacked bits; - } packed; - -struct Intrbits - { - char intrgroup /* :3 */; - char intrstuff /* result type or number of generics */; - char intrno /* :7 */; - char dblcmplx; - char dblintrno; /* for -r8 */ - char extflag; /* for -cd, -i90 */ - }; - -/* List of all intrinsic functions. */ - -LOCAL struct Intrblock - { - char intrfname[8]; - struct Intrbits intrval; - } intrtab[ ] = -{ -"int", { INTRCONV, TYLONG }, -"real", { INTRCONV, TYREAL, 1 }, - /* 1 ==> real(TYDCOMPLEX) yields TYDREAL */ -"dble", { INTRCONV, TYDREAL }, -"dreal", { INTRCONV, TYDREAL, 0, 0, 0, 1 }, -"cmplx", { INTRCONV, TYCOMPLEX }, -"dcmplx", { INTRCONV, TYDCOMPLEX, 0, 1 }, -"ifix", { INTRCONV, TYLONG }, -"idint", { INTRCONV, TYLONG }, -"float", { INTRCONV, TYREAL }, -"dfloat", { INTRCONV, TYDREAL }, -"sngl", { INTRCONV, TYREAL }, -"ichar", { INTRCONV, TYLONG }, -"iachar", { INTRCONV, TYLONG }, -"char", { INTRCONV, TYCHAR }, -"achar", { INTRCONV, TYCHAR }, - -/* any MAX or MIN can be used with any types; the compiler will cast them - correctly. So rules against bad syntax in these expressions are not - enforced */ - -"max", { INTRMAX, TYUNKNOWN }, -"max0", { INTRMAX, TYLONG }, -"amax0", { INTRMAX, TYREAL }, -"max1", { INTRMAX, TYLONG }, -"amax1", { INTRMAX, TYREAL }, -"dmax1", { INTRMAX, TYDREAL }, - -"and", { INTRBOOL, TYUNKNOWN, OPBITAND }, -"or", { INTRBOOL, TYUNKNOWN, OPBITOR }, -"xor", { INTRBOOL, TYUNKNOWN, OPBITXOR }, -"not", { INTRBOOL, TYUNKNOWN, OPBITNOT }, -"lshift", { INTRBOOL, TYUNKNOWN, OPLSHIFT }, -"rshift", { INTRBOOL, TYUNKNOWN, OPRSHIFT }, - -"min", { INTRMIN, TYUNKNOWN }, -"min0", { INTRMIN, TYLONG }, -"amin0", { INTRMIN, TYREAL }, -"min1", { INTRMIN, TYLONG }, -"amin1", { INTRMIN, TYREAL }, -"dmin1", { INTRMIN, TYDREAL }, - -"aint", { INTRGEN, 2, 0 }, -"dint", { INTRSPEC, TYDREAL, 1 }, - -"anint", { INTRGEN, 2, 2 }, -"dnint", { INTRSPEC, TYDREAL, 3 }, - -"nint", { INTRGEN, 4, 4 }, -"idnint", { INTRGEN, 2, 6 }, - -"abs", { INTRGEN, 6, 8 }, -"iabs", { INTRGEN, 2, 9 }, -"dabs", { INTRSPEC, TYDREAL, 11 }, -"cabs", { INTRSPEC, TYREAL, 12, 0, 13 }, -"zabs", { INTRSPEC, TYDREAL, 13, 1 }, - -"mod", { INTRGEN, 4, 14 }, -"amod", { INTRSPEC, TYREAL, 16, 0, 17 }, -"dmod", { INTRSPEC, TYDREAL, 17 }, - -"sign", { INTRGEN, 4, 18 }, -"isign", { INTRGEN, 2, 19 }, -"dsign", { INTRSPEC, TYDREAL, 21 }, - -"dim", { INTRGEN, 4, 22 }, -"idim", { INTRGEN, 2, 23 }, -"ddim", { INTRSPEC, TYDREAL, 25 }, - -"dprod", { INTRSPEC, TYDREAL, 26 }, - -"len", { INTRSPEC, TYLONG, 27 }, -"index", { INTRSPEC, TYLONG, 29 }, - -"imag", { INTRGEN, 2, 31 }, -"aimag", { INTRSPEC, TYREAL, 31, 0, 32 }, -"dimag", { INTRSPEC, TYDREAL, 32 }, - -"conjg", { INTRGEN, 2, 33 }, -"dconjg", { INTRSPEC, TYDCOMPLEX, 34, 1 }, - -"sqrt", { INTRGEN, 4, 35 }, -"dsqrt", { INTRSPEC, TYDREAL, 36 }, -"csqrt", { INTRSPEC, TYCOMPLEX, 37, 0, 38 }, -"zsqrt", { INTRSPEC, TYDCOMPLEX, 38, 1 }, - -"exp", { INTRGEN, 4, 39 }, -"dexp", { INTRSPEC, TYDREAL, 40 }, -"cexp", { INTRSPEC, TYCOMPLEX, 41, 0, 42 }, -"zexp", { INTRSPEC, TYDCOMPLEX, 42, 1 }, - -"log", { INTRGEN, 4, 43 }, -"alog", { INTRSPEC, TYREAL, 43, 0, 44 }, -"dlog", { INTRSPEC, TYDREAL, 44 }, -"clog", { INTRSPEC, TYCOMPLEX, 45, 0, 46 }, -"zlog", { INTRSPEC, TYDCOMPLEX, 46, 1 }, - -"log10", { INTRGEN, 2, 47 }, -"alog10", { INTRSPEC, TYREAL, 47, 0, 48 }, -"dlog10", { INTRSPEC, TYDREAL, 48 }, - -"sin", { INTRGEN, 4, 49 }, -"dsin", { INTRSPEC, TYDREAL, 50 }, -"csin", { INTRSPEC, TYCOMPLEX, 51, 0, 52 }, -"zsin", { INTRSPEC, TYDCOMPLEX, 52, 1 }, - -"cos", { INTRGEN, 4, 53 }, -"dcos", { INTRSPEC, TYDREAL, 54 }, -"ccos", { INTRSPEC, TYCOMPLEX, 55, 0, 56 }, -"zcos", { INTRSPEC, TYDCOMPLEX, 56, 1 }, - -"tan", { INTRGEN, 2, 57 }, -"dtan", { INTRSPEC, TYDREAL, 58 }, - -"asin", { INTRGEN, 2, 59 }, -"dasin", { INTRSPEC, TYDREAL, 60 }, - -"acos", { INTRGEN, 2, 61 }, -"dacos", { INTRSPEC, TYDREAL, 62 }, - -"atan", { INTRGEN, 2, 63 }, -"datan", { INTRSPEC, TYDREAL, 64 }, - -"atan2", { INTRGEN, 2, 65 }, -"datan2", { INTRSPEC, TYDREAL, 66 }, - -"sinh", { INTRGEN, 2, 67 }, -"dsinh", { INTRSPEC, TYDREAL, 68 }, - -"cosh", { INTRGEN, 2, 69 }, -"dcosh", { INTRSPEC, TYDREAL, 70 }, - -"tanh", { INTRGEN, 2, 71 }, -"dtanh", { INTRSPEC, TYDREAL, 72 }, - -"lge", { INTRSPEC, TYLOGICAL, 73}, -"lgt", { INTRSPEC, TYLOGICAL, 75}, -"lle", { INTRSPEC, TYLOGICAL, 77}, -"llt", { INTRSPEC, TYLOGICAL, 79}, - -#if 0 -"epbase", { INTRCNST, 4, 0 }, -"epprec", { INTRCNST, 4, 4 }, -"epemin", { INTRCNST, 2, 8 }, -"epemax", { INTRCNST, 2, 10 }, -"eptiny", { INTRCNST, 2, 12 }, -"ephuge", { INTRCNST, 4, 14 }, -"epmrsp", { INTRCNST, 2, 18 }, -#endif - -"fpexpn", { INTRGEN, 4, 81 }, -"fpabsp", { INTRGEN, 2, 85 }, -"fprrsp", { INTRGEN, 2, 87 }, -"fpfrac", { INTRGEN, 2, 89 }, -"fpmake", { INTRGEN, 2, 91 }, -"fpscal", { INTRGEN, 2, 93 }, - -"cdabs", { INTRSPEC, TYDREAL, 13, 1, 0, 1 }, -"cdsqrt", { INTRSPEC, TYDCOMPLEX, 38, 1, 0, 1 }, -"cdexp", { INTRSPEC, TYDCOMPLEX, 42, 1, 0, 1 }, -"cdlog", { INTRSPEC, TYDCOMPLEX, 46, 1, 0, 1 }, -"cdsin", { INTRSPEC, TYDCOMPLEX, 52, 1, 0, 1 }, -"cdcos", { INTRSPEC, TYDCOMPLEX, 56, 1, 0, 1 }, - -"iand", { INTRBOOL, TYUNKNOWN, OPBITAND, 0, 0, 2 }, -"ior", { INTRBOOL, TYUNKNOWN, OPBITOR, 0, 0, 2 }, -"ieor", { INTRBOOL, TYUNKNOWN, OPBITXOR, 0, 0, 2 }, - -"btest", { INTRBGEN, TYLOGICAL, OPBITTEST,0, 0, 2 }, -"ibclr", { INTRBGEN, TYUNKNOWN, OPBITCLR, 0, 0, 2 }, -"ibset", { INTRBGEN, TYUNKNOWN, OPBITSET, 0, 0, 2 }, -"ibits", { INTRBGEN, TYUNKNOWN, OPBITBITS,0, 0, 2 }, -"ishft", { INTRBGEN, TYUNKNOWN, OPBITSH, 0, 0, 2 }, -"ishftc", { INTRBGEN, TYUNKNOWN, OPBITSHC, 0, 0, 2 }, - -"" }; - - -LOCAL struct Specblock - { - char atype; /* Argument type; every arg must have - this type */ - char rtype; /* Result type */ - char nargs; /* Number of arguments */ - char spxname[8]; /* Name of the function in Fortran */ - char othername; /* index into callbyvalue table */ - } spectab[ ] = -{ - { TYREAL,TYREAL,1,"r_int" }, - { TYDREAL,TYDREAL,1,"d_int" }, - - { TYREAL,TYREAL,1,"r_nint" }, - { TYDREAL,TYDREAL,1,"d_nint" }, - - { TYREAL,TYSHORT,1,"h_nint" }, - { TYREAL,TYLONG,1,"i_nint" }, - - { TYDREAL,TYSHORT,1,"h_dnnt" }, - { TYDREAL,TYLONG,1,"i_dnnt" }, - - { TYREAL,TYREAL,1,"r_abs" }, - { TYSHORT,TYSHORT,1,"h_abs" }, - { TYLONG,TYLONG,1,"i_abs" }, - { TYDREAL,TYDREAL,1,"d_abs" }, - { TYCOMPLEX,TYREAL,1,"c_abs" }, - { TYDCOMPLEX,TYDREAL,1,"z_abs" }, - - { TYSHORT,TYSHORT,2,"h_mod" }, - { TYLONG,TYLONG,2,"i_mod" }, - { TYREAL,TYREAL,2,"r_mod" }, - { TYDREAL,TYDREAL,2,"d_mod" }, - - { TYREAL,TYREAL,2,"r_sign" }, - { TYSHORT,TYSHORT,2,"h_sign" }, - { TYLONG,TYLONG,2,"i_sign" }, - { TYDREAL,TYDREAL,2,"d_sign" }, - - { TYREAL,TYREAL,2,"r_dim" }, - { TYSHORT,TYSHORT,2,"h_dim" }, - { TYLONG,TYLONG,2,"i_dim" }, - { TYDREAL,TYDREAL,2,"d_dim" }, - - { TYREAL,TYDREAL,2,"d_prod" }, - - { TYCHAR,TYSHORT,1,"h_len" }, - { TYCHAR,TYLONG,1,"i_len" }, - - { TYCHAR,TYSHORT,2,"h_indx" }, - { TYCHAR,TYLONG,2,"i_indx" }, - - { TYCOMPLEX,TYREAL,1,"r_imag" }, - { TYDCOMPLEX,TYDREAL,1,"d_imag" }, - { TYCOMPLEX,TYCOMPLEX,1,"r_cnjg" }, - { TYDCOMPLEX,TYDCOMPLEX,1,"d_cnjg" }, - - { TYREAL,TYREAL,1,"r_sqrt", 1 }, - { TYDREAL,TYDREAL,1,"d_sqrt", 1 }, - { TYCOMPLEX,TYCOMPLEX,1,"c_sqrt" }, - { TYDCOMPLEX,TYDCOMPLEX,1,"z_sqrt" }, - - { TYREAL,TYREAL,1,"r_exp", 2 }, - { TYDREAL,TYDREAL,1,"d_exp", 2 }, - { TYCOMPLEX,TYCOMPLEX,1,"c_exp" }, - { TYDCOMPLEX,TYDCOMPLEX,1,"z_exp" }, - - { TYREAL,TYREAL,1,"r_log", 3 }, - { TYDREAL,TYDREAL,1,"d_log", 3 }, - { TYCOMPLEX,TYCOMPLEX,1,"c_log" }, - { TYDCOMPLEX,TYDCOMPLEX,1,"z_log" }, - - { TYREAL,TYREAL,1,"r_lg10" }, - { TYDREAL,TYDREAL,1,"d_lg10" }, - - { TYREAL,TYREAL,1,"r_sin", 4 }, - { TYDREAL,TYDREAL,1,"d_sin", 4 }, - { TYCOMPLEX,TYCOMPLEX,1,"c_sin" }, - { TYDCOMPLEX,TYDCOMPLEX,1,"z_sin" }, - - { TYREAL,TYREAL,1,"r_cos", 5 }, - { TYDREAL,TYDREAL,1,"d_cos", 5 }, - { TYCOMPLEX,TYCOMPLEX,1,"c_cos" }, - { TYDCOMPLEX,TYDCOMPLEX,1,"z_cos" }, - - { TYREAL,TYREAL,1,"r_tan", 6 }, - { TYDREAL,TYDREAL,1,"d_tan", 6 }, - - { TYREAL,TYREAL,1,"r_asin", 7 }, - { TYDREAL,TYDREAL,1,"d_asin", 7 }, - - { TYREAL,TYREAL,1,"r_acos", 8 }, - { TYDREAL,TYDREAL,1,"d_acos", 8 }, - - { TYREAL,TYREAL,1,"r_atan", 9 }, - { TYDREAL,TYDREAL,1,"d_atan", 9 }, - - { TYREAL,TYREAL,2,"r_atn2", 10 }, - { TYDREAL,TYDREAL,2,"d_atn2", 10 }, - - { TYREAL,TYREAL,1,"r_sinh", 11 }, - { TYDREAL,TYDREAL,1,"d_sinh", 11 }, - - { TYREAL,TYREAL,1,"r_cosh", 12 }, - { TYDREAL,TYDREAL,1,"d_cosh", 12 }, - - { TYREAL,TYREAL,1,"r_tanh", 13 }, - { TYDREAL,TYDREAL,1,"d_tanh", 13 }, - - { TYCHAR,TYLOGICAL,2,"hl_ge" }, - { TYCHAR,TYLOGICAL,2,"l_ge" }, - - { TYCHAR,TYLOGICAL,2,"hl_gt" }, - { TYCHAR,TYLOGICAL,2,"l_gt" }, - - { TYCHAR,TYLOGICAL,2,"hl_le" }, - { TYCHAR,TYLOGICAL,2,"l_le" }, - - { TYCHAR,TYLOGICAL,2,"hl_lt" }, - { TYCHAR,TYLOGICAL,2,"l_lt" }, - - { TYREAL,TYSHORT,1,"hr_expn" }, - { TYREAL,TYLONG,1,"ir_expn" }, - { TYDREAL,TYSHORT,1,"hd_expn" }, - { TYDREAL,TYLONG,1,"id_expn" }, - - { TYREAL,TYREAL,1,"r_absp" }, - { TYDREAL,TYDREAL,1,"d_absp" }, - - { TYREAL,TYDREAL,1,"r_rrsp" }, - { TYDREAL,TYDREAL,1,"d_rrsp" }, - - { TYREAL,TYREAL,1,"r_frac" }, - { TYDREAL,TYDREAL,1,"d_frac" }, - - { TYREAL,TYREAL,2,"r_make" }, - { TYDREAL,TYDREAL,2,"d_make" }, - - { TYREAL,TYREAL,2,"r_scal" }, - { TYDREAL,TYDREAL,2,"d_scal" }, - - { 0 } -} ; - -#if 0 -LOCAL struct Incstblock - { - char atype; - char rtype; - char constno; - } consttab[ ] = -{ - { TYSHORT, TYLONG, 0 }, - { TYLONG, TYLONG, 1 }, - { TYREAL, TYLONG, 2 }, - { TYDREAL, TYLONG, 3 }, - - { TYSHORT, TYLONG, 4 }, - { TYLONG, TYLONG, 5 }, - { TYREAL, TYLONG, 6 }, - { TYDREAL, TYLONG, 7 }, - - { TYREAL, TYLONG, 8 }, - { TYDREAL, TYLONG, 9 }, - - { TYREAL, TYLONG, 10 }, - { TYDREAL, TYLONG, 11 }, - - { TYREAL, TYREAL, 0 }, - { TYDREAL, TYDREAL, 1 }, - - { TYSHORT, TYLONG, 12 }, - { TYLONG, TYLONG, 13 }, - { TYREAL, TYREAL, 2 }, - { TYDREAL, TYDREAL, 3 }, - - { TYREAL, TYREAL, 4 }, - { TYDREAL, TYDREAL, 5 } -}; -#endif - -char *callbyvalue[ ] = - {0, - "sqrt", - "exp", - "log", - "sin", - "cos", - "tan", - "asin", - "acos", - "atan", - "atan2", - "sinh", - "cosh", - "tanh" - }; - - void -r8fix(Void) /* adjust tables for -r8 */ -{ - register struct Intrblock *I; - register struct Specblock *S; - - for(I = intrtab; I->intrfname[0]; I++) - if (I->intrval.intrgroup != INTRGEN) - switch(I->intrval.intrstuff) { - case TYREAL: - I->intrval.intrstuff = TYDREAL; - I->intrval.intrno = I->intrval.dblintrno; - break; - case TYCOMPLEX: - I->intrval.intrstuff = TYDCOMPLEX; - I->intrval.intrno = I->intrval.dblintrno; - I->intrval.dblcmplx = 1; - } - - for(S = spectab; S->atype; S++) - switch(S->atype) { - case TYCOMPLEX: - S->atype = TYDCOMPLEX; - if (S->rtype == TYREAL) - S->rtype = TYDREAL; - else if (S->rtype == TYCOMPLEX) - S->rtype = TYDCOMPLEX; - switch(S->spxname[0]) { - case 'r': - S->spxname[0] = 'd'; - break; - case 'c': - S->spxname[0] = 'z'; - break; - default: - Fatal("r8fix bug"); - } - break; - case TYREAL: - S->atype = TYDREAL; - switch(S->rtype) { - case TYREAL: - S->rtype = TYDREAL; - if (S->spxname[0] != 'r') - Fatal("r8fix bug"); - S->spxname[0] = 'd'; - case TYDREAL: /* d_prod */ - break; - - case TYSHORT: - if (!strcmp(S->spxname, "hr_expn")) - S->spxname[1] = 'd'; - else if (!strcmp(S->spxname, "h_nint")) - strcpy(S->spxname, "h_dnnt"); - else Fatal("r8fix bug"); - break; - - case TYLONG: - if (!strcmp(S->spxname, "ir_expn")) - S->spxname[1] = 'd'; - else if (!strcmp(S->spxname, "i_nint")) - strcpy(S->spxname, "i_dnnt"); - else Fatal("r8fix bug"); - break; - - default: - Fatal("r8fix bug"); - } - } - } - - - expptr -#ifdef KR_headers -intrcall(np, argsp, nargs) - Namep np; - struct Listblock *argsp; - int nargs; -#else -intrcall(Namep np, struct Listblock *argsp, int nargs) -#endif -{ - int i, rettype; - Addrp ap; - register struct Specblock *sp; - register struct Chain *cp; - expptr q, ep; - int mtype; - int op; - int f1field, f2field, f3field; - char *s; - static char bit_bits[] = "?bit_bits", - bit_shift[] = "?bit_shift", - bit_cshift[] = "?bit_cshift"; - static char *bitop[3] = { bit_bits, bit_shift, bit_cshift }; - static int t_pref[2] = { 'l', 'q' }; - - packed.ijunk = np->vardesc.varno; - f1field = packed.bits.f1; - f2field = packed.bits.f2; - f3field = packed.bits.f3; - if(nargs == 0) - goto badnargs; - - mtype = 0; - for(cp = argsp->listp ; cp ; cp = cp->nextp) - { - ep = (expptr)cp->datap; - if( ISCONST(ep) && ep->headblock.vtype==TYSHORT ) - cp->datap = (char *) mkconv(tyint, ep); - mtype = maxtype(mtype, ep->headblock.vtype); - } - - switch(f1field) - { - case INTRBGEN: - op = f3field; - if( ! ONEOF(mtype, MSKINT) ) - goto badtype; - if (op < OPBITBITS) { - if(nargs != 2) - goto badnargs; - if (op != OPBITTEST) { -#ifdef TYQUAD - if (mtype == TYQUAD) - op += 2; -#endif - goto intrbool2; - } - q = mkexpr(op, (expptr)argsp->listp->datap, - (expptr)argsp->listp->nextp->datap); - q->exprblock.vtype = TYLOGICAL; - goto intrbool2a; - } - if (nargs != 2 && (nargs != 3 || op == OPBITSH)) - goto badnargs; - cp = argsp->listp; - ep = (expptr)cp->datap; - if (ep->headblock.vtype < TYLONG) - cp->datap = (char *)mkconv(TYLONG, ep); - while(cp->nextp) { - cp = cp->nextp; - ep = (expptr)cp->datap; - if (ep->headblock.vtype != TYLONG) - cp->datap = (char *)mkconv(TYLONG, ep); - } - if (op == OPBITSH) { - ep = (expptr)argsp->listp->nextp->datap; - if (ISCONST(ep)) { - if ((i = ep->constblock.Const.ci) < 0) { - q = (expptr)argsp->listp->datap; - if (ISCONST(q)) { - ep->constblock.Const.ci = -i; - op = OPRSHIFT; - goto intrbool2; - } - } - else { - op = OPLSHIFT; - goto intrbool2; - } - } - } - else if (nargs == 2) { - if (op == OPBITBITS) - goto badnargs; - cp->nextp = mkchain((char*)ICON(-1), 0); - } - ep = (expptr)argsp->listp->datap; - i = ep->headblock.vtype; - s = bitop[op - OPBITBITS]; - *s = t_pref[i - TYLONG]; - ap = builtin(i, s, 1); - return fixexpr((Exprp) - mkexpr(OPCCALL, (expptr)ap, (expptr)argsp) ); - - case INTRBOOL: - op = f3field; - if( ! ONEOF(mtype, MSKINT|MSKLOGICAL) ) - goto badtype; - if(op == OPBITNOT) - { - if(nargs != 1) - goto badnargs; - q = mkexpr(OPBITNOT, (expptr)argsp->listp->datap, ENULL); - } - else - { - if(nargs != 2) - goto badnargs; - intrbool2: - q = mkexpr(op, (expptr)argsp->listp->datap, - (expptr)argsp->listp->nextp->datap); - } - intrbool2a: - frchain( &(argsp->listp) ); - free( (charptr) argsp); - return(q); - - case INTRCONV: - rettype = f2field; - switch(rettype) { - case TYLONG: - rettype = tyint; - break; - case TYLOGICAL: - rettype = tylog; - } - if( ISCOMPLEX(rettype) && nargs==2) - { - expptr qr, qi; - qr = (expptr) argsp->listp->datap; - qi = (expptr) argsp->listp->nextp->datap; - if (qr->headblock.vtype == TYDREAL - || qi->headblock.vtype == TYDREAL) - rettype = TYDCOMPLEX; - if(ISCONST(qr) && ISCONST(qi)) - q = mkcxcon(qr,qi); - else q = mkexpr(OPCONV,mkconv(rettype-2,qr), - mkconv(rettype-2,qi)); - } - else if(nargs == 1) { - if (f3field && ((Exprp)argsp->listp->datap)->vtype - == TYDCOMPLEX) - rettype = TYDREAL; - q = mkconv(rettype+100, (expptr)argsp->listp->datap); - if (q->tag == TADDR) - q->addrblock.parenused = 1; - } - else goto badnargs; - - q->headblock.vtype = rettype; - frchain(&(argsp->listp)); - free( (charptr) argsp); - return(q); - - -#if 0 - case INTRCNST: - -/* Machine-dependent f77 stuff that f2c omits: - -intcon contains - radix for short int - radix for long int - radix for single precision - radix for double precision - precision for short int - precision for long int - precision for single precision - precision for double precision - emin for single precision - emin for double precision - emax for single precision - emax for double prcision - largest short int - largest long int - -realcon contains - tiny for single precision - tiny for double precision - huge for single precision - huge for double precision - mrsp (epsilon) for single precision - mrsp (epsilon) for double precision -*/ - { register struct Incstblock *cstp; - extern ftnint intcon[14]; - extern double realcon[6]; - - cstp = consttab + f3field; - for(i=0 ; i<f2field ; ++i) - if(cstp->atype == mtype) - goto foundconst; - else - ++cstp; - goto badtype; - -foundconst: - switch(cstp->rtype) - { - case TYLONG: - return(mkintcon(intcon[cstp->constno])); - - case TYREAL: - case TYDREAL: - return(mkrealcon(cstp->rtype, - realcon[cstp->constno]) ); - - default: - Fatal("impossible intrinsic constant"); - } - } -#endif - - case INTRGEN: - sp = spectab + f3field; - if(no66flag) - if(sp->atype == mtype) - goto specfunct; - else err66("generic function"); - - for(i=0; i<f2field ; ++i) - if(sp->atype == mtype) - goto specfunct; - else - ++sp; - warn1 ("bad argument type to intrinsic %s", np->fvarname); - -/* Made this a warning rather than an error so things like "log (5) ==> - log (5.0)" can be accommodated. When none of these cases matches, the - argument is cast up to the first type in the spectab list; this first - type is assumed to be the "smallest" type, e.g. REAL before DREAL - before COMPLEX, before DCOMPLEX */ - - sp = spectab + f3field; - mtype = sp -> atype; - goto specfunct; - - case INTRSPEC: - sp = spectab + f3field; -specfunct: - if(tyint==TYLONG && ONEOF(sp->rtype,M(TYSHORT)|M(TYLOGICAL)) - && (sp+1)->atype==sp->atype) - ++sp; - - if(nargs != sp->nargs) - goto badnargs; - if(mtype != sp->atype) - goto badtype; - -/* NOTE!! I moved fixargs (YES) into the ELSE branch so that constants in - the inline expression wouldn't get put into the constant table */ - - fixargs (NO, argsp); - cast_args (mtype, argsp -> listp); - - if(q = Inline((int)(sp-spectab), mtype, argsp->listp)) - { - frchain( &(argsp->listp) ); - free( (charptr) argsp); - } else { - - if(sp->othername) { - /* C library routines that return double... */ - /* sp->rtype might be TYREAL */ - ap = builtin(sp->rtype, - callbyvalue[sp->othername], 1); - q = fixexpr((Exprp) - mkexpr(OPCCALL, (expptr)ap, (expptr)argsp) ); - } else { - fixargs(YES, argsp); - ap = builtin(sp->rtype, sp->spxname, 0); - q = fixexpr((Exprp) - mkexpr(OPCALL, (expptr)ap, (expptr)argsp) ); - } /* else */ - } /* else */ - return(q); - - case INTRMIN: - case INTRMAX: - if(nargs < 2) - goto badnargs; - if( ! ONEOF(mtype, MSKINT|MSKREAL) ) - goto badtype; - argsp->vtype = mtype; - q = mkexpr( (f1field==INTRMIN ? OPMIN : OPMAX), (expptr)argsp, ENULL); - - q->headblock.vtype = mtype; - rettype = f2field; - if(rettype == TYLONG) - rettype = tyint; - else if(rettype == TYUNKNOWN) - rettype = mtype; - return( mkconv(rettype, q) ); - - default: - fatali("intrcall: bad intrgroup %d", f1field); - } -badnargs: - errstr("bad number of arguments to intrinsic %s", np->fvarname); - goto bad; - -badtype: - errstr("bad argument type to intrinsic %s", np->fvarname); - -bad: - return( errnode() ); -} - - - - int -#ifdef KR_headers -intrfunct(s) - char *s; -#else -intrfunct(char *s) -#endif -{ - register struct Intrblock *p; - int i; - extern int intr_omit; - - for(p = intrtab; p->intrval.intrgroup!=INTREND ; ++p) - { - if( !strcmp(s, p->intrfname) ) - { - if (i = p->intrval.extflag) { - if (i & intr_omit) - return 0; - if (noextflag) - errext(s); - } - packed.bits.f1 = p->intrval.intrgroup; - packed.bits.f2 = p->intrval.intrstuff; - packed.bits.f3 = p->intrval.intrno; - packed.bits.f4 = p->intrval.dblcmplx; - return(packed.ijunk); - } - } - - return(0); -} - - - - - - Addrp -#ifdef KR_headers -intraddr(np) - Namep np; -#else -intraddr(Namep np) -#endif -{ - Addrp q; - register struct Specblock *sp; - int f3field; - - if(np->vclass!=CLPROC || np->vprocclass!=PINTRINSIC) - fatalstr("intraddr: %s is not intrinsic", np->fvarname); - packed.ijunk = np->vardesc.varno; - f3field = packed.bits.f3; - - switch(packed.bits.f1) - { - case INTRGEN: - /* imag, log, and log10 arent specific functions */ - if(f3field==31 || f3field==43 || f3field==47) - goto bad; - - case INTRSPEC: - sp = spectab + f3field; - if (tyint == TYLONG - && (sp->rtype == TYSHORT || sp->rtype == TYLOGICAL)) - ++sp; - q = builtin(sp->rtype, sp->spxname, - sp->othername ? 1 : 0); - return(q); - - case INTRCONV: - case INTRMIN: - case INTRMAX: - case INTRBOOL: - case INTRCNST: - case INTRBGEN: -bad: - errstr("cannot pass %s as actual", np->fvarname); - return((Addrp)errnode()); - } - fatali("intraddr: impossible f1=%d\n", (int) packed.bits.f1); - /* NOT REACHED */ return 0; -} - - - - void -#ifdef KR_headers -cast_args(maxtype, args) - int maxtype; - chainp args; -#else -cast_args(int maxtype, chainp args) -#endif -{ - for (; args; args = args -> nextp) { - expptr e = (expptr) args->datap; - if (e -> headblock.vtype != maxtype) - if (e -> tag == TCONST) - args->datap = (char *) mkconv(maxtype, e); - else { - Addrp temp = mktmp(maxtype, ENULL); - - puteq(cpexpr((expptr)temp), e); - args->datap = (char *)temp; - } /* else */ - } /* for */ -} /* cast_args */ - - - - expptr -#ifdef KR_headers -Inline(fno, type, args) - int fno; - int type; - struct Chain *args; -#else -Inline(int fno, int type, struct Chain *args) -#endif -{ - register expptr q, t, t1; - - switch(fno) - { - case 8: /* real abs */ - case 9: /* short int abs */ - case 10: /* long int abs */ - case 11: /* double precision abs */ - if( addressable(q = (expptr) args->datap) ) - { - t = q; - q = NULL; - } - else - t = (expptr) mktmp(type,ENULL); - t1 = mkexpr(type == TYREAL && forcedouble ? OPDABS : OPABS, - cpexpr(t), ENULL); - if(q) - t1 = mkexpr(OPCOMMA, mkexpr(OPASSIGN, cpexpr(t),q), t1); - frexpr(t); - return(t1); - - case 26: /* dprod */ - q = mkexpr(OPSTAR, mkconv(TYDREAL,(expptr)args->datap), - (expptr)args->nextp->datap); - return(q); - - case 27: /* len of character string */ - q = (expptr) cpexpr(((tagptr)args->datap)->headblock.vleng); - frexpr((expptr)args->datap); - return mkconv(tyioint, q); - - case 14: /* half-integer mod */ - case 15: /* mod */ - return mkexpr(OPMOD, (expptr) args->datap, - (expptr) args->nextp->datap); - } - return(NULL); -} diff --git a/usr.bin/f2c/io.c b/usr.bin/f2c/io.c deleted file mode 100644 index 12ecedd56986..000000000000 --- a/usr.bin/f2c/io.c +++ /dev/null @@ -1,1508 +0,0 @@ -/**************************************************************** -Copyright 1990, 1991, 1993, 1994, 1996 by AT&T, Lucent Technologies and Bellcore. - -Permission to use, copy, modify, and distribute this software -and its documentation for any purpose and without fee is hereby -granted, provided that the above copyright notice appear in all -copies and that both that the copyright notice and this -permission notice and warranty disclaimer appear in supporting -documentation, and that the names of AT&T, Bell Laboratories, -Lucent or Bellcore or any of their entities not be used in -advertising or publicity pertaining to distribution of the -software without specific, written prior permission. - -AT&T, Lucent and Bellcore disclaim all warranties with regard to -this software, including all implied warranties of -merchantability and fitness. In no event shall AT&T, Lucent or -Bellcore be liable for any special, indirect or consequential -damages or any damages whatsoever resulting from loss of use, -data or profits, whether in an action of contract, negligence or -other tortious action, arising out of or in connection with the -use or performance of this software. -****************************************************************/ - -/* Routines to generate code for I/O statements. - Some corrections and improvements due to David Wasley, U. C. Berkeley -*/ - -/* TEMPORARY */ -#define TYIOINT TYLONG -#define SZIOINT SZLONG - -#include "defs.h" -#include "names.h" -#include "iob.h" - -extern int byterev, inqmask; - -static void dofclose Argdcl((void)); -static void dofinquire Argdcl((void)); -static void dofmove Argdcl((char*)); -static void dofopen Argdcl((void)); -static void doiolist Argdcl((chainp)); -static void ioset Argdcl((int, int, expptr)); -static void ioseta Argdcl((int, Addrp)); -static void iosetc Argdcl((int, expptr)); -static void iosetip Argdcl((int, int)); -static void iosetlc Argdcl((int, int, int)); -static void putio Argdcl((expptr, expptr)); -static void putiocall Argdcl((expptr)); - -iob_data *iob_list; -Addrp io_structs[9]; - -LOCAL char ioroutine[12]; - -LOCAL long ioendlab; -LOCAL long ioerrlab; -LOCAL int endbit; -LOCAL int errbit; -LOCAL long jumplab; -LOCAL long skiplab; -LOCAL int ioformatted; -LOCAL int statstruct = NO; -LOCAL struct Labelblock *skiplabel; -Addrp ioblkp; - -#define UNFORMATTED 0 -#define FORMATTED 1 -#define LISTDIRECTED 2 -#define NAMEDIRECTED 3 - -#define V(z) ioc[z].iocval - -#define IOALL 07777 - -LOCAL struct Ioclist -{ - char *iocname; - int iotype; - expptr iocval; -} -ioc[ ] = -{ - { "", 0 }, - { "unit", IOALL }, - { "fmt", M(IOREAD) | M(IOWRITE) }, - { "err", IOALL }, - { "end", M(IOREAD) }, - { "iostat", IOALL }, - { "rec", M(IOREAD) | M(IOWRITE) }, - { "recl", M(IOOPEN) | M(IOINQUIRE) }, - { "file", M(IOOPEN) | M(IOINQUIRE) }, - { "status", M(IOOPEN) | M(IOCLOSE) }, - { "access", M(IOOPEN) | M(IOINQUIRE) }, - { "form", M(IOOPEN) | M(IOINQUIRE) }, - { "blank", M(IOOPEN) | M(IOINQUIRE) }, - { "exist", M(IOINQUIRE) }, - { "opened", M(IOINQUIRE) }, - { "number", M(IOINQUIRE) }, - { "named", M(IOINQUIRE) }, - { "name", M(IOINQUIRE) }, - { "sequential", M(IOINQUIRE) }, - { "direct", M(IOINQUIRE) }, - { "formatted", M(IOINQUIRE) }, - { "unformatted", M(IOINQUIRE) }, - { "nextrec", M(IOINQUIRE) }, - { "nml", M(IOREAD) | M(IOWRITE) } -}; - -#define NIOS (sizeof(ioc)/sizeof(struct Ioclist) - 1) - -/* #define IOSUNIT 1 */ -/* #define IOSFMT 2 */ -#define IOSERR 3 -#define IOSEND 4 -#define IOSIOSTAT 5 -#define IOSREC 6 -#define IOSRECL 7 -#define IOSFILE 8 -#define IOSSTATUS 9 -#define IOSACCESS 10 -#define IOSFORM 11 -#define IOSBLANK 12 -#define IOSEXISTS 13 -#define IOSOPENED 14 -#define IOSNUMBER 15 -#define IOSNAMED 16 -#define IOSNAME 17 -#define IOSSEQUENTIAL 18 -#define IOSDIRECT 19 -#define IOSFORMATTED 20 -#define IOSUNFORMATTED 21 -#define IOSNEXTREC 22 -#define IOSNML 23 - -#define IOSTP V(IOSIOSTAT) - - -/* offsets in generated structures */ - -#define SZFLAG SZIOINT - -/* offsets for external READ and WRITE statements */ - -#define XERR 0 -#define XUNIT SZFLAG -#define XEND SZFLAG + SZIOINT -#define XFMT 2*SZFLAG + SZIOINT -#define XREC 2*SZFLAG + SZIOINT + SZADDR - -/* offsets for internal READ and WRITE statements */ - -#define XIUNIT SZFLAG -#define XIEND SZFLAG + SZADDR -#define XIFMT 2*SZFLAG + SZADDR -#define XIRLEN 2*SZFLAG + 2*SZADDR -#define XIRNUM 2*SZFLAG + 2*SZADDR + SZIOINT -#define XIREC 2*SZFLAG + 2*SZADDR + 2*SZIOINT - -/* offsets for OPEN statements */ - -#define XFNAME SZFLAG + SZIOINT -#define XFNAMELEN SZFLAG + SZIOINT + SZADDR -#define XSTATUS SZFLAG + 2*SZIOINT + SZADDR -#define XACCESS SZFLAG + 2*SZIOINT + 2*SZADDR -#define XFORMATTED SZFLAG + 2*SZIOINT + 3*SZADDR -#define XRECLEN SZFLAG + 2*SZIOINT + 4*SZADDR -#define XBLANK SZFLAG + 3*SZIOINT + 4*SZADDR - -/* offset for CLOSE statement */ - -#define XCLSTATUS SZFLAG + SZIOINT - -/* offsets for INQUIRE statement */ - -#define XFILE SZFLAG + SZIOINT -#define XFILELEN SZFLAG + SZIOINT + SZADDR -#define XEXISTS SZFLAG + 2*SZIOINT + SZADDR -#define XOPEN SZFLAG + 2*SZIOINT + 2*SZADDR -#define XNUMBER SZFLAG + 2*SZIOINT + 3*SZADDR -#define XNAMED SZFLAG + 2*SZIOINT + 4*SZADDR -#define XNAME SZFLAG + 2*SZIOINT + 5*SZADDR -#define XNAMELEN SZFLAG + 2*SZIOINT + 6*SZADDR -#define XQACCESS SZFLAG + 3*SZIOINT + 6*SZADDR -#define XQACCLEN SZFLAG + 3*SZIOINT + 7*SZADDR -#define XSEQ SZFLAG + 4*SZIOINT + 7*SZADDR -#define XSEQLEN SZFLAG + 4*SZIOINT + 8*SZADDR -#define XDIRECT SZFLAG + 5*SZIOINT + 8*SZADDR -#define XDIRLEN SZFLAG + 5*SZIOINT + 9*SZADDR -#define XFORM SZFLAG + 6*SZIOINT + 9*SZADDR -#define XFORMLEN SZFLAG + 6*SZIOINT + 10*SZADDR -#define XFMTED SZFLAG + 7*SZIOINT + 10*SZADDR -#define XFMTEDLEN SZFLAG + 7*SZIOINT + 11*SZADDR -#define XUNFMT SZFLAG + 8*SZIOINT + 11*SZADDR -#define XUNFMTLEN SZFLAG + 8*SZIOINT + 12*SZADDR -#define XQRECL SZFLAG + 9*SZIOINT + 12*SZADDR -#define XNEXTREC SZFLAG + 9*SZIOINT + 13*SZADDR -#define XQBLANK SZFLAG + 9*SZIOINT + 14*SZADDR -#define XQBLANKLEN SZFLAG + 9*SZIOINT + 15*SZADDR - -LOCAL char *cilist_names[] = { - "cilist", - "cierr", - "ciunit", - "ciend", - "cifmt", - "cirec" - }; -LOCAL char *icilist_names[] = { - "icilist", - "icierr", - "iciunit", - "iciend", - "icifmt", - "icirlen", - "icirnum" - }; -LOCAL char *olist_names[] = { - "olist", - "oerr", - "ounit", - "ofnm", - "ofnmlen", - "osta", - "oacc", - "ofm", - "orl", - "oblnk" - }; -LOCAL char *cllist_names[] = { - "cllist", - "cerr", - "cunit", - "csta" - }; -LOCAL char *alist_names[] = { - "alist", - "aerr", - "aunit" - }; -LOCAL char *inlist_names[] = { - "inlist", - "inerr", - "inunit", - "infile", - "infilen", - "inex", - "inopen", - "innum", - "innamed", - "inname", - "innamlen", - "inacc", - "inacclen", - "inseq", - "inseqlen", - "indir", - "indirlen", - "infmt", - "infmtlen", - "inform", - "informlen", - "inunf", - "inunflen", - "inrecl", - "innrec", - "inblank", - "inblanklen" - }; - -LOCAL char **io_fields; - -#define zork(n,t) n, sizeof(n)/sizeof(char *) - 1, t - -LOCAL io_setup io_stuff[] = { - zork(cilist_names, TYCILIST), /* external read/write */ - zork(inlist_names, TYINLIST), /* inquire */ - zork(olist_names, TYOLIST), /* open */ - zork(cllist_names, TYCLLIST), /* close */ - zork(alist_names, TYALIST), /* rewind */ - zork(alist_names, TYALIST), /* backspace */ - zork(alist_names, TYALIST), /* endfile */ - zork(icilist_names,TYICILIST), /* internal read */ - zork(icilist_names,TYICILIST) /* internal write */ - }; - -#undef zork - - int -#ifdef KR_headers -fmtstmt(lp) - register struct Labelblock *lp; -#else -fmtstmt(register struct Labelblock *lp) -#endif -{ - if(lp == NULL) - { - execerr("unlabeled format statement" , CNULL); - return(-1); - } - if(lp->labtype == LABUNKNOWN) - { - lp->labtype = LABFORMAT; - lp->labelno = (int)newlabel(); - } - else if(lp->labtype != LABFORMAT) - { - execerr("bad format number", CNULL); - return(-1); - } - return(lp->labelno); -} - - - void -#ifdef KR_headers -setfmt(lp) - struct Labelblock *lp; -#else -setfmt(struct Labelblock *lp) -#endif -{ - int n, parity; - char *s0; - register char *s, *se, *t; - register k; - - s0 = s = lexline(&n); - se = t = s + n; - - /* warn of trivial errors, e.g. " 11 CONTINUE" (one too few spaces) */ - /* following FORMAT... */ - - if (n <= 0) - warn("No (...) after FORMAT"); - else if (*s != '(') - warni("%c rather than ( after FORMAT", *s); - else if (se[-1] != ')') { - *se = 0; - while(--t > s && *t != ')') ; - if (t <= s) - warn("No ) at end of FORMAT statement"); - else if (se - t > 30) - warn1("Extraneous text at end of FORMAT: ...%s", se-12); - else - warn1("Extraneous text at end of FORMAT: %s", t+1); - t = se; - } - - /* fix MYQUOTES (\002's) and \\'s */ - - parity = 1; - while(s < se) - switch(*s++) { - case 2: - if ((parity ^= 1) && *s == 2) { - t -= 2; - ++s; - } - else - t += 3; - break; - case '"': - case '\\': - t++; break; - } - s = s0; - parity = 1; - if (lp) { - lp->fmtstring = t = mem((int)(t - s + 1), 0); - while(s < se) - switch(k = *s++) { - case 2: - if ((parity ^= 1) && *s == 2) - s++; - else { - t[0] = '\\'; - t[1] = '0'; - t[2] = '0'; - t[3] = '2'; - t += 4; - } - break; - case '"': - case '\\': - *t++ = '\\'; - /* no break */ - default: - *t++ = k; - } - *t = 0; - } - flline(); -} - - - void -#ifdef KR_headers -startioctl() -#else -startioctl() -#endif -{ - register int i; - - inioctl = YES; - nioctl = 0; - ioformatted = UNFORMATTED; - for(i = 1 ; i<=NIOS ; ++i) - V(i) = NULL; -} - - static long -newiolabel(Void) { - long rv; - rv = ++lastiolabno; - skiplabel = mklabel(rv); - skiplabel->labdefined = 1; - return rv; - } - - void -endioctl(Void) -{ - int i; - expptr p; - struct io_setup *ios; - - inioctl = NO; - - /* set up for error recovery */ - - ioerrlab = ioendlab = skiplab = jumplab = 0; - - if(p = V(IOSEND)) - if(ISICON(p)) - execlab(ioendlab = p->constblock.Const.ci); - else - err("bad end= clause"); - - if(p = V(IOSERR)) - if(ISICON(p)) - execlab(ioerrlab = p->constblock.Const.ci); - else - err("bad err= clause"); - - if(IOSTP) - if(IOSTP->tag!=TADDR || ! ISINT(IOSTP->addrblock.vtype) ) - { - err("iostat must be an integer variable"); - frexpr(IOSTP); - IOSTP = NULL; - } - - if(iostmt == IOREAD) - { - if(IOSTP) - { - if(ioerrlab && ioendlab && ioerrlab==ioendlab) - jumplab = ioerrlab; - else - skiplab = jumplab = newiolabel(); - } - else { - if(ioerrlab && ioendlab && ioerrlab!=ioendlab) - { - IOSTP = (expptr) mktmp(TYINT, ENULL); - skiplab = jumplab = newiolabel(); - } - else - jumplab = (ioerrlab ? ioerrlab : ioendlab); - } - } - else if(iostmt == IOWRITE) - { - if(IOSTP && !ioerrlab) - skiplab = jumplab = newiolabel(); - else - jumplab = ioerrlab; - } - else - jumplab = ioerrlab; - - endbit = IOSTP!=NULL || ioendlab!=0; /* for use in startrw() */ - errbit = IOSTP!=NULL || ioerrlab!=0; - if (jumplab && !IOSTP) - IOSTP = (expptr) mktmp(TYINT, ENULL); - - if(iostmt!=IOREAD && iostmt!=IOWRITE) - { - ios = io_stuff + iostmt; - io_fields = ios->fields; - ioblkp = io_structs[iostmt]; - if(ioblkp == NULL) - io_structs[iostmt] = ioblkp = - autovar(1, ios->type, ENULL, ""); - ioset(TYIOINT, XERR, ICON(errbit)); - } - - switch(iostmt) - { - case IOOPEN: - dofopen(); - break; - - case IOCLOSE: - dofclose(); - break; - - case IOINQUIRE: - dofinquire(); - break; - - case IOBACKSPACE: - dofmove("f_back"); - break; - - case IOREWIND: - dofmove("f_rew"); - break; - - case IOENDFILE: - dofmove("f_end"); - break; - - case IOREAD: - case IOWRITE: - startrw(); - break; - - default: - fatali("impossible iostmt %d", iostmt); - } - for(i = 1 ; i<=NIOS ; ++i) - if(i!=IOSIOSTAT && V(i)!=NULL) - frexpr(V(i)); -} - - - int -iocname(Void) -{ - register int i; - int found, mask; - - found = 0; - mask = M(iostmt); - for(i = 1 ; i <= NIOS ; ++i) - if(!strcmp(ioc[i].iocname, token)) - if(ioc[i].iotype & mask) - return(i); - else { - found = i; - break; - } - if(found) { - if (iostmt == IOOPEN && !strcmp(ioc[i].iocname, "name")) { - NOEXT("open with \"name=\" treated as \"file=\""); - for(i = 1; strcmp(ioc[i].iocname, "file"); i++); - return i; - } - errstr("invalid control %s for statement", ioc[found].iocname); - } - else - errstr("unknown iocontrol %s", token); - return(IOSBAD); -} - - - void -#ifdef KR_headers -ioclause(n, p) - register int n; - register expptr p; -#else -ioclause(register int n, register expptr p) -#endif -{ - struct Ioclist *iocp; - - ++nioctl; - if(n == IOSBAD) - return; - if(n == IOSPOSITIONAL) - { - n = nioctl; - if (n == IOSFMT) { - if (iostmt == IOOPEN) { - n = IOSFILE; - NOEXT("file= specifier omitted from open"); - } - else if (iostmt < IOREAD) - goto illegal; - } - else if(n > IOSFMT) - { - illegal: - err("illegal positional iocontrol"); - return; - } - } - else if (n == IOSNML) - n = IOSFMT; - - if(p == NULL) - { - if(n == IOSUNIT) - p = (expptr) (iostmt==IOREAD ? IOSTDIN : IOSTDOUT); - else if(n != IOSFMT) - { - err("illegal * iocontrol"); - return; - } - } - if(n == IOSFMT) - ioformatted = (p==NULL ? LISTDIRECTED : FORMATTED); - - iocp = & ioc[n]; - if(iocp->iocval == NULL) - { - if(n!=IOSFMT && ( n!=IOSUNIT || (p && p->headblock.vtype!=TYCHAR) ) ) - p = fixtype(p); - else if (p && p->tag == TPRIM - && p->primblock.namep->vclass == CLUNKNOWN) { - /* kludge made necessary by attempt to infer types - * for untyped external parameters: given an error - * in calling sequences, an integer argument might - * tentatively be assumed TYCHAR; this would otherwise - * be corrected too late in startrw after startrw - * had decided this to be an internal file. - */ - vardcl(p->primblock.namep); - p->primblock.vtype = p->primblock.namep->vtype; - } - iocp->iocval = p; - } - else - errstr("iocontrol %s repeated", iocp->iocname); -} - -/* io list item */ - - void -#ifdef KR_headers -doio(list) - chainp list; -#else -doio(chainp list) -#endif -{ - if(ioformatted == NAMEDIRECTED) - { - if(list) - err("no I/O list allowed in NAMELIST read/write"); - } - else - { - doiolist(list); - ioroutine[0] = 'e'; - if (skiplab) - jumplab = 0; - putiocall( call0(TYINT, ioroutine) ); - } -} - - - - - - LOCAL void -#ifdef KR_headers -doiolist(p0) - chainp p0; -#else -doiolist(chainp p0) -#endif -{ - chainp p; - register tagptr q; - register expptr qe; - register Namep qn; - Addrp tp; - int range; - extern char *ohalign; - - for (p = p0 ; p ; p = p->nextp) - { - q = (tagptr)p->datap; - if(q->tag == TIMPLDO) - { - exdo(range = (int)newlabel(), (Namep)0, - q->impldoblock.impdospec); - doiolist(q->impldoblock.datalist); - enddo(range); - free( (charptr) q); - } - else { - if(q->tag==TPRIM && q->primblock.argsp==NULL - && q->primblock.namep->vdim!=NULL) - { - vardcl(qn = q->primblock.namep); - if(qn->vdim->nelt) { - putio( fixtype(cpexpr(qn->vdim->nelt)), - (expptr)mkscalar(qn) ); - qn->vlastdim = 0; - } - else - err("attempt to i/o array of unknown size"); - } - else if(q->tag==TPRIM && q->primblock.argsp==NULL && - (qe = (expptr) memversion(q->primblock.namep)) ) - putio(ICON(1),qe); - else if (ISCONST(q) && q->constblock.vtype == TYCHAR) { - halign = 0; - putio(ICON(1), qe = fixtype(cpexpr(q))); - halign = ohalign; - } - else if(((qe = fixtype(cpexpr(q)))->tag==TADDR && - (qe->addrblock.uname_tag != UNAM_CONST || - !ISCOMPLEX(qe -> addrblock.vtype))) || - (qe -> tag == TCONST && !ISCOMPLEX(qe -> - headblock.vtype))) { - if (qe -> tag == TCONST) - qe = (expptr) putconst((Constp)qe); - putio(ICON(1), qe); - } - else if(qe->headblock.vtype != TYERROR) - { - if(iostmt == IOWRITE) - { - expptr qvl; - qvl = NULL; - if( ISCHAR(qe) ) - { - qvl = (expptr) - cpexpr(qe->headblock.vleng); - tp = mktmp(qe->headblock.vtype, - ICON(lencat(qe))); - } - else - tp = mktmp(qe->headblock.vtype, - qe->headblock.vleng); - puteq( cpexpr((expptr)tp), qe); - if(qvl) /* put right length on block */ - { - frexpr(tp->vleng); - tp->vleng = qvl; - } - putio(ICON(1), (expptr)tp); - } - else - err("non-left side in READ list"); - } - frexpr(q); - } - } - frchain( &p0 ); -} - - int iocalladdr = TYADDR; /* for fixing TYADDR in saveargtypes */ - int typeconv[TYERROR+1] = { -#ifdef TYQUAD - 0, 1, 11, 2, 3, 14, 4, 5, 6, 7, 12, 13, 8, 9, 10, 15 -#else - 0, 1, 11, 2, 3, 4, 5, 6, 7, 12, 13, 8, 9, 10, 14 -#endif - }; - - LOCAL void -#ifdef KR_headers -putio(nelt, addr) - expptr nelt; - register expptr addr; -#else -putio(expptr nelt, register expptr addr) -#endif -{ - int type; - register expptr q; - register Addrp c = 0; - - type = addr->headblock.vtype; - if(ioformatted!=LISTDIRECTED && ISCOMPLEX(type) ) - { - nelt = mkexpr(OPSTAR, ICON(2), nelt); - type -= (TYCOMPLEX-TYREAL); - } - - /* pass a length with every item. for noncharacter data, fake one */ - if(type != TYCHAR) - { - - if( ISCONST(addr) ) - addr = (expptr) putconst((Constp)addr); - c = ALLOC(Addrblock); - c->tag = TADDR; - c->vtype = TYLENG; - c->vstg = STGAUTO; - c->ntempelt = 1; - c->isarray = 1; - c->memoffset = ICON(0); - c->uname_tag = UNAM_IDENT; - c->charleng = 1; - sprintf(c->user.ident, "(ftnlen)sizeof(%s)", typename[type]); - addr = mkexpr(OPCHARCAST, addr, ENULL); - } - - nelt = fixtype( mkconv(tyioint,nelt) ); - if(ioformatted == LISTDIRECTED) { - expptr mc = mkconv(tyioint, ICON(typeconv[type])); - q = c ? call4(TYINT, "do_lio", mc, nelt, addr, (expptr)c) - : call3(TYINT, "do_lio", mc, nelt, addr); - } - else { - char *s = ioformatted==FORMATTED ? "do_fio" - : !byterev ? "do_uio" - : ONEOF(type, M(TYCHAR)|M(TYINT1)|M(TYLOGICAL1)) - ? "do_ucio" : "do_unio"; - q = c ? call3(TYINT, s, nelt, addr, (expptr)c) - : call2(TYINT, s, nelt, addr); - } - iocalladdr = TYCHAR; - putiocall(q); - iocalladdr = TYADDR; -} - - - - void -endio(Void) -{ - if(skiplab) - { - if (ioformatted != NAMEDIRECTED) - p1_label((long)(skiplabel - labeltab)); - if(ioendlab) { - exif( mkexpr(OPLT, cpexpr(IOSTP), ICON(0))); - exgoto(execlab(ioendlab)); - exendif(); - } - if(ioerrlab) { - exif( mkexpr(iostmt==IOREAD||iostmt==IOWRITE - ? OPGT : OPNE, - cpexpr(IOSTP), ICON(0))); - exgoto(execlab(ioerrlab)); - exendif(); - } - } - - if(IOSTP) - frexpr(IOSTP); -} - - - - LOCAL void -#ifdef KR_headers -putiocall(q) - register expptr q; -#else -putiocall(register expptr q) -#endif -{ - int tyintsave; - - tyintsave = tyint; - tyint = tyioint; /* for -I2 and -i2 */ - - if(IOSTP) - { - q->headblock.vtype = TYINT; - q = fixexpr((Exprp)mkexpr(OPASSIGN, cpexpr(IOSTP), q)); - } - putexpr(q); - if(jumplab) { - exif(mkexpr(OPNE, cpexpr(IOSTP), ICON(0))); - exgoto(execlab(jumplab)); - exendif(); - } - tyint = tyintsave; -} - - void -#ifdef KR_headers -fmtname(np, q) - Namep np; - register Addrp q; -#else -fmtname(Namep np, register Addrp q) -#endif -{ - register int k; - register char *s, *t; - extern chainp assigned_fmts; - - if (!np->vfmt_asg) { - np->vfmt_asg = 1; - assigned_fmts = mkchain((char *)np, assigned_fmts); - } - k = strlen(s = np->fvarname); - if (k < IDENT_LEN - 4) { - q->uname_tag = UNAM_IDENT; - t = q->user.ident; - } - else { - q->uname_tag = UNAM_CHARP; - q->user.Charp = t = mem(k + 5,0); - } - sprintf(t, "%s_fmt", s); - } - - LOCAL Addrp -#ifdef KR_headers -asg_addr(p) - union Expression *p; -#else -asg_addr(union Expression *p) -#endif -{ - register Addrp q; - - if (p->tag != TPRIM) - badtag("asg_addr", p->tag); - q = ALLOC(Addrblock); - q->tag = TADDR; - q->vtype = TYCHAR; - q->vstg = STGAUTO; - q->ntempelt = 1; - q->isarray = 0; - q->memoffset = ICON(0); - fmtname(p->primblock.namep, q); - return q; - } - - void -startrw(Void) -{ - register expptr p; - register Namep np; - register Addrp unitp, fmtp, recp; - register expptr nump; - int iostmt1; - flag intfile, sequential, ok, varfmt; - struct io_setup *ios; - - /* First look at all the parameters and determine what is to be done */ - - ok = YES; - statstruct = YES; - - intfile = NO; - if(p = V(IOSUNIT)) - { - if( ISINT(p->headblock.vtype) ) { - int_unit: - unitp = (Addrp) cpexpr(p); - } - else if(p->headblock.vtype == TYCHAR) - { - if (nioctl == 1 && iostmt == IOREAD) { - /* kludge to recognize READ(format expr) */ - V(IOSFMT) = p; - V(IOSUNIT) = p = (expptr) IOSTDIN; - ioformatted = FORMATTED; - goto int_unit; - } - intfile = YES; - if(p->tag==TPRIM && p->primblock.argsp==NULL && - (np = p->primblock.namep)->vdim!=NULL) - { - vardcl(np); - if(nump = np->vdim->nelt) - { - nump = fixtype(cpexpr(nump)); - if( ! ISCONST(nump) ) { - statstruct = NO; - np->vlastdim = 0; - } - } - else - { - err("attempt to use internal unit array of unknown size"); - ok = NO; - nump = ICON(1); - } - unitp = mkscalar(np); - } - else { - nump = ICON(1); - unitp = (Addrp /*pjw */) fixtype(cpexpr(p)); - } - if(! isstatic((expptr)unitp) ) - statstruct = NO; - } - else { - err("unit specifier not of type integer or character"); - ok = NO; - } - } - else - { - err("bad unit specifier"); - ok = NO; - } - - sequential = YES; - if(p = V(IOSREC)) - if( ISINT(p->headblock.vtype) ) - { - recp = (Addrp) cpexpr(p); - sequential = NO; - } - else { - err("bad REC= clause"); - ok = NO; - } - else - recp = NULL; - - - varfmt = YES; - fmtp = NULL; - if(p = V(IOSFMT)) - { - if(p->tag==TPRIM && p->primblock.argsp==NULL) - { - np = p->primblock.namep; - if(np->vclass == CLNAMELIST) - { - ioformatted = NAMEDIRECTED; - fmtp = (Addrp) fixtype(p); - V(IOSFMT) = (expptr)fmtp; - if (skiplab) - jumplab = 0; - goto endfmt; - } - vardcl(np); - if(np->vdim) - { - if( ! ONEOF(np->vstg, MSKSTATIC) ) - statstruct = NO; - fmtp = mkscalar(np); - goto endfmt; - } - if( ISINT(np->vtype) ) /* ASSIGNed label */ - { - statstruct = NO; - varfmt = YES; - fmtp = asg_addr(p); - goto endfmt; - } - } - p = V(IOSFMT) = fixtype(p); - if(p->headblock.vtype == TYCHAR - /* Since we allow write(6,n) */ - /* we may as well allow write(6,n(2)) */ - || p->tag == TADDR && ISINT(p->addrblock.vtype)) - { - if( ! isstatic(p) ) - statstruct = NO; - fmtp = (Addrp) cpexpr(p); - } - else if( ISICON(p) ) - { - struct Labelblock *lp; - lp = mklabel(p->constblock.Const.ci); - if (fmtstmt(lp) > 0) - { - fmtp = (Addrp)mkaddcon(lp->stateno); - /* lp->stateno for names fmt_nnn */ - lp->fmtlabused = 1; - varfmt = NO; - } - else - ioformatted = UNFORMATTED; - } - else { - err("bad format descriptor"); - ioformatted = UNFORMATTED; - ok = NO; - } - } - else - fmtp = NULL; - -endfmt: - if(intfile) { - if (ioformatted==UNFORMATTED) { - err("unformatted internal I/O not allowed"); - ok = NO; - } - if (recp) { - err("direct internal I/O not allowed"); - ok = NO; - } - } - if(!sequential && ioformatted==LISTDIRECTED) - { - err("direct list-directed I/O not allowed"); - ok = NO; - } - if(!sequential && ioformatted==NAMEDIRECTED) - { - err("direct namelist I/O not allowed"); - ok = NO; - } - - if( ! ok ) { - statstruct = NO; - return; - } - - /* - Now put out the I/O structure, statically if all the clauses - are constants, dynamically otherwise -*/ - - if (intfile) { - ios = io_stuff + iostmt; - iostmt1 = IOREAD; - } - else { - ios = io_stuff; - iostmt1 = 0; - } - io_fields = ios->fields; - if(statstruct) - { - ioblkp = ALLOC(Addrblock); - ioblkp->tag = TADDR; - ioblkp->vtype = ios->type; - ioblkp->vclass = CLVAR; - ioblkp->vstg = STGINIT; - ioblkp->memno = ++lastvarno; - ioblkp->memoffset = ICON(0); - ioblkp -> uname_tag = UNAM_IDENT; - new_iob_data(ios, - temp_name("io_", lastvarno, ioblkp->user.ident)); } - else if(!(ioblkp = io_structs[iostmt1])) - io_structs[iostmt1] = ioblkp = - autovar(1, ios->type, ENULL, ""); - - ioset(TYIOINT, XERR, ICON(errbit)); - if(iostmt == IOREAD) - ioset(TYIOINT, (intfile ? XIEND : XEND), ICON(endbit) ); - - if(intfile) - { - ioset(TYIOINT, XIRNUM, nump); - ioset(TYIOINT, XIRLEN, cpexpr(unitp->vleng) ); - ioseta(XIUNIT, unitp); - } - else - ioset(TYIOINT, XUNIT, (expptr) unitp); - - if(recp) - ioset(TYIOINT, /* intfile ? XIREC : */ XREC, (expptr) recp); - - if(varfmt) - ioseta( intfile ? XIFMT : XFMT , fmtp); - else - ioset(TYADDR, intfile ? XIFMT : XFMT, (expptr) fmtp); - - ioroutine[0] = 's'; - ioroutine[1] = '_'; - ioroutine[2] = iostmt==IOREAD ? 'r' : 'w'; - ioroutine[3] = "ds"[sequential]; - ioroutine[4] = "ufln"[ioformatted]; - ioroutine[5] = "ei"[intfile]; - ioroutine[6] = '\0'; - - putiocall( call1(TYINT, ioroutine, cpexpr((expptr)ioblkp) )); - - if(statstruct) - { - frexpr((expptr)ioblkp); - statstruct = NO; - ioblkp = 0; /* unnecessary */ - } -} - - - - LOCAL void -dofopen(Void) -{ - register expptr p; - - if( (p = V(IOSUNIT)) && ISINT(p->headblock.vtype) ) - ioset(TYIOINT, XUNIT, cpexpr(p) ); - else - err("bad unit in open"); - if( (p = V(IOSFILE)) ) - if(p->headblock.vtype == TYCHAR) - ioset(TYIOINT, XFNAMELEN, cpexpr(p->headblock.vleng) ); - else - err("bad file in open"); - - iosetc(XFNAME, p); - - if(p = V(IOSRECL)) - if( ISINT(p->headblock.vtype) ) - ioset(TYIOINT, XRECLEN, cpexpr(p) ); - else - err("bad recl"); - else - ioset(TYIOINT, XRECLEN, ICON(0) ); - - iosetc(XSTATUS, V(IOSSTATUS)); - iosetc(XACCESS, V(IOSACCESS)); - iosetc(XFORMATTED, V(IOSFORM)); - iosetc(XBLANK, V(IOSBLANK)); - - putiocall( call1(TYINT, "f_open", cpexpr((expptr)ioblkp) )); -} - - - LOCAL void -dofclose(Void) -{ - register expptr p; - - if( (p = V(IOSUNIT)) && ISINT(p->headblock.vtype) ) - { - ioset(TYIOINT, XUNIT, cpexpr(p) ); - iosetc(XCLSTATUS, V(IOSSTATUS)); - putiocall( call1(TYINT, "f_clos", cpexpr((expptr)ioblkp)) ); - } - else - err("bad unit in close statement"); -} - - - LOCAL void -dofinquire(Void) -{ - register expptr p; - if(p = V(IOSUNIT)) - { - if( V(IOSFILE) ) - err("inquire by unit or by file, not both"); - ioset(TYIOINT, XUNIT, cpexpr(p) ); - } - else if( ! V(IOSFILE) ) - err("must inquire by unit or by file"); - iosetlc(IOSFILE, XFILE, XFILELEN); - iosetip(IOSEXISTS, XEXISTS); - iosetip(IOSOPENED, XOPEN); - iosetip(IOSNUMBER, XNUMBER); - iosetip(IOSNAMED, XNAMED); - iosetlc(IOSNAME, XNAME, XNAMELEN); - iosetlc(IOSACCESS, XQACCESS, XQACCLEN); - iosetlc(IOSSEQUENTIAL, XSEQ, XSEQLEN); - iosetlc(IOSDIRECT, XDIRECT, XDIRLEN); - iosetlc(IOSFORM, XFORM, XFORMLEN); - iosetlc(IOSFORMATTED, XFMTED, XFMTEDLEN); - iosetlc(IOSUNFORMATTED, XUNFMT, XUNFMTLEN); - iosetip(IOSRECL, XQRECL); - iosetip(IOSNEXTREC, XNEXTREC); - iosetlc(IOSBLANK, XQBLANK, XQBLANKLEN); - - putiocall( call1(TYINT, "f_inqu", cpexpr((expptr)ioblkp) )); -} - - - - LOCAL void -#ifdef KR_headers -dofmove(subname) - char *subname; -#else -dofmove(char *subname) -#endif -{ - register expptr p; - - if( (p = V(IOSUNIT)) && ISINT(p->headblock.vtype) ) - { - ioset(TYIOINT, XUNIT, cpexpr(p) ); - putiocall( call1(TYINT, subname, cpexpr((expptr)ioblkp) )); - } - else - err("bad unit in I/O motion statement"); -} - -static int ioset_assign = OPASSIGN; - - LOCAL void -#ifdef KR_headers -ioset(type, offset, p) - int type; - int offset; - register expptr p; -#else -ioset(int type, int offset, register expptr p) -#endif -{ - offset /= SZLONG; - if(statstruct && ISCONST(p)) { - register char *s; - switch(type) { - case TYADDR: /* stmt label */ - s = "fmt_"; - break; - case TYIOINT: - s = ""; - break; - default: - badtype("ioset", type); - } - iob_list->fields[offset] = - string_num(s, p->constblock.Const.ci); - frexpr(p); - } - else { - register Addrp q; - - q = ALLOC(Addrblock); - q->tag = TADDR; - q->vtype = type; - q->vstg = STGAUTO; - q->ntempelt = 1; - q->isarray = 0; - q->memoffset = ICON(0); - q->uname_tag = UNAM_IDENT; - sprintf(q->user.ident, "%s.%s", - statstruct ? iob_list->name : ioblkp->user.ident, - io_fields[offset + 1]); - if (type == TYADDR && p->tag == TCONST - && p->constblock.vtype == TYADDR) { - /* kludge */ - register Addrp p1; - p1 = ALLOC(Addrblock); - p1->tag = TADDR; - p1->vtype = type; - p1->vstg = STGAUTO; /* wrong, but who cares? */ - p1->ntempelt = 1; - p1->isarray = 0; - p1->memoffset = ICON(0); - p1->uname_tag = UNAM_IDENT; - sprintf(p1->user.ident, "fmt_%ld", - p->constblock.Const.ci); - frexpr(p); - p = (expptr)p1; - } - if (type == TYADDR && p->headblock.vtype == TYCHAR) - q->vtype = TYCHAR; - putexpr(mkexpr(ioset_assign, (expptr)q, p)); - } -} - - - - - LOCAL void -#ifdef KR_headers -iosetc(offset, p) - int offset; - register expptr p; -#else -iosetc(int offset, register expptr p) -#endif -{ - if(p == NULL) - ioset(TYADDR, offset, ICON(0) ); - else if(p->headblock.vtype == TYCHAR) { - p = putx(fixtype((expptr)putchop(cpexpr(p)))); - ioset(TYADDR, offset, addrof(p)); - } - else - err("non-character control clause"); -} - - - - LOCAL void -#ifdef KR_headers -ioseta(offset, p) - int offset; - register Addrp p; -#else -ioseta(int offset, register Addrp p) -#endif -{ - char *s, *s1; - static char who[] = "ioseta"; - expptr e, mo; - Namep np; - ftnint ci; - int k; - char buf[24], buf1[24]; - Extsym *comm; - extern int usedefsforcommon; - - if(statstruct) - { - if (!p) - return; - if (p->tag != TADDR) - badtag(who, p->tag); - offset /= SZLONG; - switch(p->uname_tag) { - case UNAM_NAME: - mo = p->memoffset; - if (mo->tag != TCONST) - badtag("ioseta/memoffset", mo->tag); - np = p->user.name; - np->visused = 1; - ci = mo->constblock.Const.ci - np->voffset; - if (np->vstg == STGCOMMON - && !np->vcommequiv - && !usedefsforcommon) { - comm = &extsymtab[np->vardesc.varno]; - sprintf(buf, "%d.", comm->curno); - k = strlen(buf) + strlen(comm->cextname) - + strlen(np->cvarname); - if (ci) { - sprintf(buf1, "+%ld", ci); - k += strlen(buf1); - } - else - buf1[0] = 0; - s = mem(k + 1, 0); - sprintf(s, "%s%s%s%s", comm->cextname, buf, - np->cvarname, buf1); - } - else if (ci) { - sprintf(buf,"%ld", ci); - s1 = p->user.name->cvarname; - k = strlen(buf) + strlen(s1); - sprintf(s = mem(k+2,0), "%s+%s", s1, buf); - } - else - s = cpstring(np->cvarname); - break; - case UNAM_CONST: - s = tostring(p->user.Const.ccp1.ccp0, - (int)p->vleng->constblock.Const.ci); - break; - default: - badthing("uname_tag", who, p->uname_tag); - } - /* kludge for Hollerith */ - if (p->vtype != TYCHAR) { - s1 = mem(strlen(s)+10,0); - sprintf(s1, "(char *)%s%s", p->isarray ? "" : "&", s); - s = s1; - } - iob_list->fields[offset] = s; - } - else { - if (!p) - e = ICON(0); - else if (p->vtype != TYCHAR) { - NOEXT("non-character variable as format or internal unit"); - e = mkexpr(OPCHARCAST, (expptr)p, ENULL); - } - else - e = addrof((expptr)p); - ioset(TYADDR, offset, e); - } -} - - - - - LOCAL void -#ifdef KR_headers -iosetip(i, offset) - int i; - int offset; -#else -iosetip(int i, int offset) -#endif -{ - register expptr p; - - if(p = V(i)) - if(p->tag==TADDR && - ONEOF(p->addrblock.vtype, inqmask) ) { - ioset_assign = OPASSIGNI; - ioset(TYADDR, offset, addrof(cpexpr(p)) ); - ioset_assign = OPASSIGN; - } - else - errstr("impossible inquire parameter %s", ioc[i].iocname); - else - ioset(TYADDR, offset, ICON(0) ); -} - - - - LOCAL void -#ifdef KR_headers -iosetlc(i, offp, offl) - int i; - int offp; - int offl; -#else -iosetlc(int i, int offp, int offl) -#endif -{ - register expptr p; - if( (p = V(i)) && p->headblock.vtype==TYCHAR) - ioset(TYIOINT, offl, cpexpr(p->headblock.vleng) ); - iosetc(offp, p); -} diff --git a/usr.bin/f2c/iob.h b/usr.bin/f2c/iob.h deleted file mode 100644 index 065d813aae10..000000000000 --- a/usr.bin/f2c/iob.h +++ /dev/null @@ -1,26 +0,0 @@ -struct iob_data { - struct iob_data *next; - char *type; - char *name; - char *fields[1]; - }; -struct io_setup { - char **fields; - int nelt, type; - }; - -struct defines { - struct defines *next; - char defname[1]; - }; - -typedef struct iob_data iob_data; -typedef struct io_setup io_setup; -typedef struct defines defines; - -extern iob_data *iob_list; -extern struct Addrblock *io_structs[9]; -void def_start Argdcl((FILEP, char*, char*, char*)); -void new_iob_data Argdcl((io_setup*, char*)); -void other_undefs Argdcl((FILEP)); -char* tostring Argdcl((char*, int)); diff --git a/usr.bin/f2c/lex.c b/usr.bin/f2c/lex.c deleted file mode 100644 index 900128e501ef..000000000000 --- a/usr.bin/f2c/lex.c +++ /dev/null @@ -1,1710 +0,0 @@ -/**************************************************************** -Copyright 1990, 1992 - 1997 by AT&T, Lucent Technologies and Bellcore. - -Permission to use, copy, modify, and distribute this software -and its documentation for any purpose and without fee is hereby -granted, provided that the above copyright notice appear in all -copies and that both that the copyright notice and this -permission notice and warranty disclaimer appear in supporting -documentation, and that the names of AT&T, Bell Laboratories, -Lucent or Bellcore or any of their entities not be used in -advertising or publicity pertaining to distribution of the -software without specific, written prior permission. - -AT&T, Lucent and Bellcore disclaim all warranties with regard to -this software, including all implied warranties of -merchantability and fitness. In no event shall AT&T, Lucent or -Bellcore be liable for any special, indirect or consequential -damages or any damages whatsoever resulting from loss of use, -data or profits, whether in an action of contract, negligence or -other tortious action, arising out of or in connection with the -use or performance of this software. -****************************************************************/ - -#include "defs.h" -#include "tokdefs.h" -#include "p1defs.h" - -#ifdef NO_EOF_CHAR_CHECK -#undef EOF_CHAR -#else -#ifndef EOF_CHAR -#define EOF_CHAR 26 /* ASCII control-Z */ -#endif -#endif - -#define BLANK ' ' -#define MYQUOTE (2) -#define SEOF 0 - -/* card types */ - -#define STEOF 1 -#define STINITIAL 2 -#define STCONTINUE 3 - -/* lex states */ - -#define NEWSTMT 1 -#define FIRSTTOKEN 2 -#define OTHERTOKEN 3 -#define RETEOS 4 - - -LOCAL int stkey; /* Type of the current statement (DO, END, IF, etc) */ -static int needwkey; -ftnint yystno; -flag intonly; -extern int new_dcl; -LOCAL long int stno; -LOCAL long int nxtstno; /* Statement label */ -LOCAL int parlev; /* Parentheses level */ -LOCAL int parseen; -LOCAL int expcom; -LOCAL int expeql; -LOCAL char *nextch; -LOCAL char *lastch; -LOCAL char *nextcd = NULL; -LOCAL char *endcd; -LOCAL long prevlin; -LOCAL long thislin; -LOCAL int code; /* Card type; INITIAL, CONTINUE or EOF */ -LOCAL int lexstate = NEWSTMT; -LOCAL char *sbuf; /* Main buffer for Fortran source input. */ -LOCAL char *send; /* Was = sbuf+20*66 with sbuf[1390]. */ -LOCAL int maxcont; -LOCAL int nincl = 0; /* Current number of include files */ -LOCAL long firstline; -LOCAL char *laststb, *stb0; -extern int addftnsrc; -static char **linestart; -LOCAL int ncont; -LOCAL char comstart[Table_size]; -#define USC (unsigned char *) - -static char anum_buf[Table_size]; -#define isalnum_(x) anum_buf[x] -#define isalpha_(x) (anum_buf[x] == 1) - -#define COMMENT_BUF_STORE 4088 - -typedef struct comment_buf { - struct comment_buf *next; - char *last; - char buf[COMMENT_BUF_STORE]; - } comment_buf; -static comment_buf *cbfirst, *cbcur; -static char *cbinit, *cbnext, *cblast; -static void flush_comments Argdcl((void)); -extern flag use_bs; -static char *lastfile = "??", *lastfile0 = "?"; -static char fbuf[P1_FILENAME_MAX]; -static long lastline; -static void putlineno(Void); - - -/* Comment buffering data - - Comments are kept in a list until the statement before them has - been parsed. This list is implemented with the above comment_buf - structure and the pointers cbnext and cblast. - - The comments are stored with terminating NULL, and no other - intervening space. The last few bytes of each block are likely to - remain unused. -*/ - -/* struct Inclfile holds the state information for each include file */ -struct Inclfile -{ - struct Inclfile *inclnext; - FILEP inclfp; - char *inclname; - int incllno; - char *incllinp; - int incllen; - int inclcode; - ftnint inclstno; -}; - -LOCAL struct Inclfile *inclp = NULL; -struct Keylist { - char *keyname; - int keyval; - char notinf66; -}; -struct Punctlist { - char punchar; - int punval; -}; -struct Fmtlist { - char fmtchar; - int fmtval; -}; -struct Dotlist { - char *dotname; - int dotval; - }; -LOCAL struct Keylist *keystart[26], *keyend[26]; - -/* KEYWORD AND SPECIAL CHARACTER TABLES -*/ - -static struct Punctlist puncts[ ] = -{ - '(', SLPAR, - ')', SRPAR, - '=', SEQUALS, - ',', SCOMMA, - '+', SPLUS, - '-', SMINUS, - '*', SSTAR, - '/', SSLASH, - '$', SCURRENCY, - ':', SCOLON, - '<', SLT, - '>', SGT, - 0, 0 }; - -LOCAL struct Dotlist dots[ ] = -{ - "and.", SAND, - "or.", SOR, - "not.", SNOT, - "true.", STRUE, - "false.", SFALSE, - "eq.", SEQ, - "ne.", SNE, - "lt.", SLT, - "le.", SLE, - "gt.", SGT, - "ge.", SGE, - "neqv.", SNEQV, - "eqv.", SEQV, - 0, 0 }; - -LOCAL struct Keylist keys[ ] = -{ - { "assign", SASSIGN }, - { "automatic", SAUTOMATIC, YES }, - { "backspace", SBACKSPACE }, - { "blockdata", SBLOCK }, - { "byte", SBYTE }, - { "call", SCALL }, - { "character", SCHARACTER, YES }, - { "close", SCLOSE, YES }, - { "common", SCOMMON }, - { "complex", SCOMPLEX }, - { "continue", SCONTINUE }, - { "data", SDATA }, - { "dimension", SDIMENSION }, - { "doubleprecision", SDOUBLE }, - { "doublecomplex", SDCOMPLEX, YES }, - { "elseif", SELSEIF, YES }, - { "else", SELSE, YES }, - { "endfile", SENDFILE }, - { "endif", SENDIF, YES }, - { "enddo", SENDDO, YES }, - { "end", SEND }, - { "entry", SENTRY, YES }, - { "equivalence", SEQUIV }, - { "external", SEXTERNAL }, - { "format", SFORMAT }, - { "function", SFUNCTION }, - { "goto", SGOTO }, - { "implicit", SIMPLICIT, YES }, - { "include", SINCLUDE, YES }, - { "inquire", SINQUIRE, YES }, - { "intrinsic", SINTRINSIC, YES }, - { "integer", SINTEGER }, - { "logical", SLOGICAL }, - { "namelist", SNAMELIST, YES }, - { "none", SUNDEFINED, YES }, - { "open", SOPEN, YES }, - { "parameter", SPARAM, YES }, - { "pause", SPAUSE }, - { "print", SPRINT }, - { "program", SPROGRAM, YES }, - { "punch", SPUNCH, YES }, - { "read", SREAD }, - { "real", SREAL }, - { "return", SRETURN }, - { "rewind", SREWIND }, - { "save", SSAVE, YES }, - { "static", SSTATIC, YES }, - { "stop", SSTOP }, - { "subroutine", SSUBROUTINE }, - { "then", STHEN, YES }, - { "undefined", SUNDEFINED, YES }, - { "while", SWHILE, YES }, - { "write", SWRITE }, - { 0, 0 } -}; - -static void analyz Argdcl((void)); -static void crunch Argdcl((void)); -static int getcd Argdcl((char*, int)); -static int getcds Argdcl((void)); -static int getkwd Argdcl((void)); -static int gettok Argdcl((void)); -static void store_comment Argdcl((char*)); -LOCAL char *stbuf[3]; - - int -#ifdef KR_headers -inilex(name) - char *name; -#else -inilex(char *name) -#endif -{ - stbuf[0] = Alloc(3*P1_STMTBUFSIZE); - stbuf[1] = stbuf[0] + P1_STMTBUFSIZE; - stbuf[2] = stbuf[1] + P1_STMTBUFSIZE; - nincl = 0; - inclp = NULL; - doinclude(name); - lexstate = NEWSTMT; - return(NO); -} - - - -/* throw away the rest of the current line */ - void -flline(Void) -{ - lexstate = RETEOS; -} - - - - char * -#ifdef KR_headers -lexline(n) - int *n; -#else -lexline(int *n) -#endif -{ - *n = (lastch - nextch) + 1; - return(nextch); -} - - - - - void -#ifdef KR_headers -doinclude(name) - char *name; -#else -doinclude(char *name) -#endif -{ - FILEP fp; - struct Inclfile *t; - char *name0, *lastslash, *s, *s0, *temp; - int j, k; - chainp I; - extern chainp Iargs; - - err_lineno = -1; - if(inclp) - { - inclp->incllno = thislin; - inclp->inclcode = code; - inclp->inclstno = nxtstno; - if(nextcd && (j = endcd - nextcd) > 0) - inclp->incllinp = copyn(inclp->incllen = j, nextcd); - else - inclp->incllinp = 0; - } - nextcd = NULL; - - if(++nincl >= MAXINCLUDES) - Fatal("includes nested too deep"); - if(name[0] == '\0') - fp = stdin; - else if(name[0] == '/' || inclp == NULL -#ifdef MSDOS - || name[0] == '\\' - || name[1] == ':' -#endif - ) - fp = fopen(name, textread); - else { - lastslash = NULL; - s = s0 = inclp->inclname; -#ifdef MSDOS - if (s[1] == ':') - lastslash = s + 1; -#endif - for(; *s ; ++s) - if(*s == '/' -#ifdef MSDOS - || *s == '\\' -#endif - ) - lastslash = s; - name0 = name; - if(lastslash) { - k = lastslash - s0 + 1; - temp = Alloc(k + strlen(name) + 1); - strncpy(temp, s0, k); - strcpy(temp+k, name); - name = temp; - } - fp = fopen(name, textread); - if (!fp && (I = Iargs)) { - k = strlen(name0) + 2; - for(; I; I = I->nextp) { - j = strlen(s = I->datap); - name = Alloc(j + k); - strcpy(name, s); - switch(s[j-1]) { - case '/': -#ifdef MSDOS - case ':': - case '\\': -#endif - break; - default: - name[j++] = '/'; - } - strcpy(name+j, name0); - if (fp = fopen(name, textread)) { - free(name0); - goto havefp; - } - free(name); - name = name0; - } - } - } - if (fp) - { - havefp: - t = inclp; - inclp = ALLOC(Inclfile); - inclp->inclnext = t; - prevlin = thislin = 0; - infname = inclp->inclname = name; - infile = inclp->inclfp = fp; - lastline = 0; - putlineno(); - lastline = 0; - } - else - { - fprintf(diagfile, "Cannot open file %s\n", name); - done(1); - } -} - - - - - LOCAL int -popinclude(Void) -{ - struct Inclfile *t; - register char *p; - register int k; - - if(infile != stdin) - clf(&infile, infname, 1); /* Close the input file */ - free(infname); - - --nincl; - err_lineno = -1; - t = inclp->inclnext; - free( (charptr) inclp); - inclp = t; - if(inclp == NULL) { - infname = 0; - return(NO); - } - - infile = inclp->inclfp; - infname = inclp->inclname; - lineno = prevlin = thislin = inclp->incllno; - code = inclp->inclcode; - stno = nxtstno = inclp->inclstno; - if(inclp->incllinp) - { - lastline = 0; - putlineno(); - lastline = lineno; - endcd = nextcd = sbuf; - k = inclp->incllen; - p = inclp->incllinp; - while(--k >= 0) - *endcd++ = *p++; - free( (charptr) (inclp->incllinp) ); - } - else - nextcd = NULL; - return(YES); -} - - - void -#ifdef KR_headers -p1_line_number(line_number) - long line_number; -#else -p1_line_number(long line_number) -#endif -{ - if (lastfile != lastfile0) { - p1puts(P1_FILENAME, fbuf); - lastfile0 = lastfile; - } - fprintf(pass1_file, "%d: %ld\n", P1_SET_LINE, line_number); - } - - static void -putlineno(Void) -{ - extern int gflag; - register char *s0, *s1; - - if (gflag) { - if (lastline) - p1_line_number(lastline); - lastline = firstline; - if (lastfile != infname) - if (lastfile = infname) { - strncpy(fbuf, lastfile, sizeof(fbuf)); - fbuf[sizeof(fbuf)-1] = 0; - } - else - fbuf[0] = 0; - } - if (addftnsrc) { - if (laststb && *laststb) { - for(s1 = laststb; *s1; s1++) { - for(s0 = s1; *s1 != '\n'; s1++) - if (*s1 == '*' && s1[1] == '/') - *s1 = '+'; - *s1 = 0; - p1puts(P1_FORTRAN, s0); - } - *laststb = 0; /* prevent trouble after EOF */ - } - laststb = stb0; - } - } - - int -yylex(Void) -{ - static int tokno; - int retval; - - switch(lexstate) - { - case NEWSTMT : /* need a new statement */ - retval = getcds(); - putlineno(); - if(retval == STEOF) { - retval = SEOF; - break; - } /* if getcds() == STEOF */ - crunch(); - tokno = 0; - lexstate = FIRSTTOKEN; - yystno = stno; - stno = nxtstno; - toklen = 0; - retval = SLABEL; - break; - -first: - case FIRSTTOKEN : /* first step on a statement */ - analyz(); - lexstate = OTHERTOKEN; - tokno = 1; - retval = stkey; - break; - - case OTHERTOKEN : /* return next token */ - if(nextch > lastch) - goto reteos; - ++tokno; - if( (stkey==SLOGIF || stkey==SELSEIF) && parlev==0 && tokno>3) - goto first; - - if(stkey==SASSIGN && tokno==3 && nextch<lastch && - nextch[0]=='t' && nextch[1]=='o') - { - nextch+=2; - retval = STO; - break; - } - if (tokno == 2 && stkey == SDO) { - intonly = 1; - retval = gettok(); - intonly = 0; - } - else - retval = gettok(); - break; - -reteos: - case RETEOS: - lexstate = NEWSTMT; - retval = SEOS; - break; - default: - fatali("impossible lexstate %d", lexstate); - break; - } - - if (retval == SEOF) - flush_comments (); - - return retval; -} - - LOCAL void -contmax(Void) -{ - lineno = thislin; - many("continuation lines", 'C', maxcontin); - } - -/* Get Cards. - - Returns STEOF or STINITIAL, never STCONTINUE. Any continuation cards get -merged into one long card (hence the size of the buffer named sbuf) */ - - LOCAL int -getcds(Void) -{ - register char *p, *q; - - flush_comments (); -top: - if(nextcd == NULL) - { - code = getcd( nextcd = sbuf, 1 ); - stno = nxtstno; - prevlin = thislin; - } - if(code == STEOF) - if( popinclude() ) - goto top; - else - return(STEOF); - - if(code == STCONTINUE) - { - lineno = thislin; - nextcd = NULL; - goto top; - } - -/* Get rid of unused space at the head of the buffer */ - - if(nextcd > sbuf) - { - q = nextcd; - p = sbuf; - while(q < endcd) - *p++ = *q++; - endcd = p; - } - -/* Be aware that the input (i.e. the string at the address nextcd) is NOT - NULL-terminated */ - -/* This loop merges all continuations into one long statement, AND puts the next - card to be read at the end of the buffer (i.e. it stores the look-ahead card - when there's room) */ - - ncont = 0; - for(;;) { - nextcd = endcd; - if (ncont >= maxcont || nextcd+66 > send) - contmax(); - linestart[ncont++] = nextcd; - if ((code = getcd(nextcd,0)) != STCONTINUE) - break; - if (ncont == 20 && noextflag) { - lineno = thislin; - errext("more than 19 continuation lines"); - } - } - nextch = sbuf; - lastch = nextcd - 1; - - lineno = prevlin; - prevlin = thislin; - return(STINITIAL); -} - - static void -#ifdef KR_headers -bang(a, b, c, d, e) - char *a; - char *b; - char *c; - register char *d; - register char *e; -#else -bang(char *a, char *b, char *c, register char *d, register char *e) -#endif - /* save ! comments */ -{ - char buf[COMMENT_BUFFER_SIZE + 1]; - register char *p, *pe; - - p = buf; - pe = buf + COMMENT_BUFFER_SIZE; - *pe = 0; - while(a < b) - if (!(*p++ = *a++)) - p[-1] = 0; - if (b < c) - *p++ = '\t'; - while(d < e) { - if (!(*p++ = *d++)) - p[-1] = ' '; - if (p == pe) { - store_comment(buf); - p = buf; - } - } - if (p > buf) { - while(--p >= buf && *p == ' '); - p[1] = 0; - store_comment(buf); - } - } - - -/* getcd - Get next input card - - This function reads the next input card from global file pointer infile. -It assumes that b points to currently empty storage somewhere in sbuf */ - - LOCAL int -#ifdef KR_headers -getcd(b, nocont) - register char *b; - int nocont; -#else -getcd(register char *b, int nocont) -#endif -{ - register int c; - register char *p, *bend; - int speclin; /* Special line - true when the line is allowed - to have more than 66 characters (e.g. the - "&" shorthand for continuation, use of a "\t" - to skip part of the label columns) */ - static char a[6]; /* Statement label buffer */ - static char *aend = a+6; - static char *stb, *stbend; - static int nst; - char *atend, *endcd0; - extern int warn72; - char buf72[24]; - int amp, i; - char storage[COMMENT_BUFFER_SIZE + 1]; - char *pointer; - long L; - -top: - endcd = b; - bend = b+66; - amp = speclin = NO; - atend = aend; - -/* Handle the continuation shorthand of "&" in the first column, which stands - for " x" */ - - if( (c = getc(infile)) == '&') - { - a[0] = c; - a[1] = 0; - a[5] = 'x'; - amp = speclin = YES; - bend = send; - p = aend; - } - -/* Handle the Comment cards (a 'C', 'c', '*', or '!' in the first column). */ - - else if(comstart[c & (Table_size-1)]) - { - if (feof (infile) -#ifdef EOF_CHAR - || c == EOF_CHAR -#endif - ) - return STEOF; - - if (c == '#') { - *endcd++ = c; - while((c = getc(infile)) != '\n') - if (c == EOF) - return STEOF; - else if (endcd < bend) - *endcd++ = c; - ++thislin; - *endcd = 0; - if (b[1] == ' ') - p = b + 2; - else if (!strncmp(b,"#line ",6)) - p = b + 6; - else { - bad_cpp: - errstr("Bad # line: \"%s\"", b); - goto top; - } - if (*p < '1' || *p > '9') - goto bad_cpp; - L = *p - '0'; - while((c = *++p) >= '0' && c <= '9') - L = 10*L + c - '0'; - if (c != ' ' || *++p != '"') - goto bad_cpp; - bend = p; - while(*++p != '"') - if (!*p) - goto bad_cpp; - *p = 0; - i = p - bend++; - thislin = L - 1; - if (!infname || strcmp(infname, bend)) { - if (infname) - free(infname); - lastfile = 0; - infname = Alloc(i); - strcpy(infname, bend); - if (inclp) - inclp->inclname = infname; - } - goto top; - } - - storage[COMMENT_BUFFER_SIZE] = c = '\0'; - pointer = storage; - while( !feof (infile) && (*pointer++ = c = getc(infile)) != '\n') { - -/* Handle obscure end of file conditions on many machines */ - - if (feof (infile) && (c == '\377' || c == EOF)) { - pointer--; - break; - } /* if (feof (infile)) */ - - if (c == '\0') - *(pointer - 1) = ' '; - - if (pointer == &storage[COMMENT_BUFFER_SIZE]) { - store_comment (storage); - pointer = storage; - } /* if (pointer == BUFFER_SIZE) */ - } /* while */ - - if (pointer > storage) { - if (c == '\n') - -/* Get rid of the newline */ - - pointer[-1] = 0; - else - *pointer = 0; - - store_comment (storage); - } /* if */ - - if (feof (infile)) - if (c != '\n') /* To allow the line index to - increment correctly */ - return STEOF; - - ++thislin; - goto top; - } - - else if(c != EOF) - { - -/* Load buffer a with the statement label */ - - /* a tab in columns 1-6 skips to column 7 */ - ungetc(c, infile); - for(p=a; p<aend && (c=getc(infile)) != '\n' && c!=EOF; ) - if(c == '\t') - -/* The tab character translates into blank characters in the statement label */ - - { - atend = p; - while(p < aend) - *p++ = BLANK; - speclin = YES; - bend = send; - } - else - *p++ = c; - } - -/* By now we've read either a continuation character or the statement label - field */ - - if(c == EOF) - return(STEOF); - -/* The next 'if' block handles lines that have fewer than 7 characters */ - - if(c == '\n') - { - while(p < aend) - *p++ = BLANK; - -/* Blank out the buffer on lines which are not longer than 66 characters */ - - endcd0 = endcd; - if( ! speclin ) - while(endcd < bend) - *endcd++ = BLANK; - } - else { /* read body of line */ - if (warn72 & 2) { - speclin = YES; - bend = send; - } - while( endcd<bend && (c=getc(infile)) != '\n' && c!=EOF ) - *endcd++ = c; - if(c == EOF) - return(STEOF); - -/* Drop any extra characters on the input card; this usually means those after - column 72 */ - - if(c != '\n') - { - i = 0; - while( (c=getc(infile)) != '\n' && c != EOF) - if (i < 23) - buf72[i++] = c; - if (warn72 && i && !speclin) { - buf72[i] = 0; - if (i >= 23) - strcpy(buf72+20, "..."); - lineno = thislin + 1; - errstr("text after column 72: %s", buf72); - } - if(c == EOF) - return(STEOF); - } - - endcd0 = endcd; - if( ! speclin ) - while(endcd < bend) - *endcd++ = BLANK; - } - -/* The flow of control usually gets to this line (unless an earlier RETURN has - been taken) */ - - ++thislin; - - /* Fortran 77 specifies that a 0 in column 6 */ - /* does not signify continuation */ - - if( !isspace(a[5]) && a[5]!='0') { - if (!amp) - for(p = a; p < aend;) - if (*p++ == '!' && p != aend) - goto initcheck; - if (addftnsrc && stb) { - if (stbend > stb + 7) { /* otherwise forget col 1-6 */ - /* kludge around funny p1gets behavior */ - *stb++ = '$'; - if (amp) - *stb++ = '&'; - else - for(p = a; p < atend;) - *stb++ = *p++; - } - if (endcd0 - b > stbend - stb) { - if (stb > stbend) - stb = stbend; - endcd0 = b + (stbend - stb); - } - for(p = b; p < endcd0;) - *stb++ = *p++; - *stb++ = '\n'; - *stb = 0; - } - if (nocont) { - lineno = thislin; - errstr("illegal continuation card (starts \"%.6s\")",a); - } - else if (!amp && strncmp(a," ",5)) { - lineno = thislin; - errstr("labeled continuation line (starts \"%.6s\")",a); - } - return(STCONTINUE); - } -initcheck: - for(p=a; p<atend; ++p) - if( !isspace(*p) ) { - if (*p++ != '!') - goto initline; - bang(p, atend, aend, b, endcd); - goto top; - } - for(p = b ; p<endcd ; ++p) - if( !isspace(*p) ) { - if (*p++ != '!') - goto initline; - bang(a, a, a, p, endcd); - goto top; - } - -/* Skip over blank cards by reading the next one right away */ - - goto top; - -initline: - if (!lastline) - lastline = thislin; - if (addftnsrc) { - nst = (nst+1)%3; - if (!laststb && stb0) - laststb = stb0; - stb0 = stb = stbuf[nst]; - *stb++ = '$'; /* kludge around funny p1gets behavior */ - stbend = stb + sizeof(stbuf[0])-2; - for(p = a; p < atend;) - *stb++ = *p++; - if (atend < aend) - *stb++ = '\t'; - for(p = b; p < endcd0;) - *stb++ = *p++; - *stb++ = '\n'; - *stb = 0; - } - -/* Set nxtstno equal to the integer value of the statement label */ - - nxtstno = 0; - bend = a + 5; - for(p = a ; p < bend ; ++p) - if( !isspace(*p) ) - if(isdigit(*p)) - nxtstno = 10*nxtstno + (*p - '0'); - else if (*p == '!') { - if (!addftnsrc) - bang(p+1,atend,aend,b,endcd); - endcd = b; - break; - } - else { - lineno = thislin; - errstr( - "nondigit in statement label field \"%.5s\"", a); - nxtstno = 0; - break; - } - firstline = thislin; - return(STINITIAL); -} - - LOCAL void -#ifdef KR_headers -adjtoklen(newlen) - int newlen; -#else -adjtoklen(int newlen) -#endif -{ - while(maxtoklen < newlen) - maxtoklen = 2*maxtoklen + 2; - if (token = (char *)realloc(token, maxtoklen)) - return; - fprintf(stderr, "adjtoklen: realloc(%d) failure!\n", maxtoklen); - exit(2); - } - -/* crunch -- deletes all space characters, folds the backslash chars and - Hollerith strings, quotes the Fortran strings */ - - LOCAL void -crunch(Void) -{ - register char *i, *j, *j0, *j1, *prvstr; - int k, ten, nh, nh0, quote; - - /* i is the next input character to be looked at - j is the next output character */ - - new_dcl = needwkey = parlev = parseen = 0; - expcom = 0; /* exposed ','s */ - expeql = 0; /* exposed equal signs */ - j = sbuf; - prvstr = sbuf; - k = 0; - for(i=sbuf ; i<=lastch ; ++i) - { - if(isspace(*i) ) - continue; - if (*i == '!') { - while(i >= linestart[k]) - if (++k >= maxcont) - contmax(); - j0 = linestart[k]; - if (!addftnsrc) - bang(sbuf,sbuf,sbuf,i+1,j0); - i = j0-1; - continue; - } - -/* Keep everything in a quoted string */ - - if(*i=='\'' || *i=='"') - { - int len = 0; - - quote = *i; - *j = MYQUOTE; /* special marker */ - for(;;) - { - if(++i > lastch) - { - err("unbalanced quotes; closing quote supplied"); - if (j >= lastch) - j = lastch - 1; - break; - } - if(*i == quote) - if(i<lastch && i[1]==quote) ++i; - else break; - else if(*i=='\\' && i<lastch && use_bs) { - ++i; - *i = escapes[*(unsigned char *)i]; - } - *++j = *i; - len++; - } /* for (;;) */ - - if ((len = j - sbuf) > maxtoklen) - adjtoklen(len); - j[1] = MYQUOTE; - j += 2; - prvstr = j; - } - else if( (*i=='h' || *i=='H') && j>prvstr) /* test for Hollerith strings */ - { - j0 = j - 1; - if( ! isdigit(*j0)) goto copychar; - nh = *j0 - '0'; - ten = 10; - j1 = prvstr; - if (j1 > sbuf && j1[-1] == MYQUOTE) - --j1; - if (j1+4 < j) - j1 = j-4; - for(;;) { - if (j0-- <= j1) - goto copychar; - if( ! isdigit(*j0 ) ) break; - nh += ten * (*j0-'0'); - ten*=10; - } -/* A Hollerith string must be preceded by a punctuation mark. - '*' is possible only as repetition factor in a data statement - not, in particular, in character*2h . - To avoid some confusion with missing commas in FORMAT statements, - treat a preceding string as a punctuation mark. - */ - - if( !(*j0=='*'&&sbuf[0]=='d') && *j0!='/' - && *j0!='(' && *j0!=',' && *j0!='=' && *j0!='.' - && *j0 != MYQUOTE) - goto copychar; - nh0 = nh; - if(i+nh > lastch) - { - erri("%dH too big", nh); - nh = lastch - i; - nh0 = -1; - } - if (nh > maxtoklen) - adjtoklen(nh); - j0[1] = MYQUOTE; /* special marker */ - j = j0 + 1; - while(nh-- > 0) - { - if (++i > lastch) { - hol_overflow: - if (nh0 >= 0) - erri("escapes make %dH too big", - nh0); - break; - } - if(*i == '\\' && use_bs) { - if (++i > lastch) - goto hol_overflow; - *i = escapes[*(unsigned char *)i]; - } - *++j = *i; - } - j[1] = MYQUOTE; - j+=2; - prvstr = j; - } - else { - if(*i == '(') parseen = ++parlev; - else if(*i == ')') --parlev; - else if(parlev == 0) - if(*i == '=') expeql = 1; - else if(*i == ',') expcom = 1; -copychar: /*not a string or space -- copy, shifting case if necessary */ - if(shiftcase && isupper(*i)) - *j++ = tolower(*i); - else *j++ = *i; - } - } - lastch = j - 1; - nextch = sbuf; -} - - LOCAL void -analyz(Void) -{ - register char *i; - - if(parlev != 0) - { - err("unbalanced parentheses, statement skipped"); - stkey = SUNKNOWN; - lastch = sbuf - 1; /* prevent double error msg */ - return; - } - if(nextch+2<=lastch && nextch[0]=='i' && nextch[1]=='f' && nextch[2]=='(') - { - /* assignment or if statement -- look at character after balancing paren */ - parlev = 1; - for(i=nextch+3 ; i<=lastch; ++i) - if(*i == (MYQUOTE)) - { - while(*++i != MYQUOTE) - ; - } - else if(*i == '(') - ++parlev; - else if(*i == ')') - { - if(--parlev == 0) - break; - } - if(i >= lastch) - stkey = SLOGIF; - else if(i[1] == '=') - stkey = SLET; - else if( isdigit(i[1]) ) - stkey = SARITHIF; - else stkey = SLOGIF; - if(stkey != SLET) - nextch += 2; - } - else if(expeql) /* may be an assignment */ - { - if(expcom && nextch<lastch && - nextch[0]=='d' && nextch[1]=='o') - { - stkey = SDO; - nextch += 2; - } - else stkey = SLET; - } - else if (parseen && nextch + 7 < lastch - && nextch[2] != 'u' /* screen out "double..." early */ - && nextch[0] == 'd' && nextch[1] == 'o' - && ((nextch[2] >= '0' && nextch[2] <= '9') - || nextch[2] == ',' - || nextch[2] == 'w')) - { - stkey = SDO; - nextch += 2; - needwkey = 1; - } - /* otherwise search for keyword */ - else { - stkey = getkwd(); - if(stkey==SGOTO && lastch>=nextch) - if(nextch[0]=='(') - stkey = SCOMPGOTO; - else if(isalpha_(* USC nextch)) - stkey = SASGOTO; - } - parlev = 0; -} - - - - LOCAL int -getkwd(Void) -{ - register char *i, *j; - register struct Keylist *pk, *pend; - int k; - - if(! isalpha_(* USC nextch) ) - return(SUNKNOWN); - k = letter(nextch[0]); - if(pk = keystart[k]) - for(pend = keyend[k] ; pk<=pend ; ++pk ) - { - i = pk->keyname; - j = nextch; - while(*++i==*++j && *i!='\0') - ; - if(*i=='\0' && j<=lastch+1) - { - nextch = j; - if(no66flag && pk->notinf66) - errstr("Not a Fortran 66 keyword: %s", - pk->keyname); - return(pk->keyval); - } - } - return(SUNKNOWN); -} - - void -initkey(Void) -{ - register struct Keylist *p; - register int i,j; - register char *s; - - for(i = 0 ; i<26 ; ++i) - keystart[i] = NULL; - - for(p = keys ; p->keyname ; ++p) { - j = letter(p->keyname[0]); - if(keystart[j] == NULL) - keystart[j] = p; - keyend[j] = p; - } - i = (maxcontin + 2) * 66; - sbuf = (char *)ckalloc(i + 70); - send = sbuf + i; - maxcont = maxcontin + 1; - linestart = (char **)ckalloc(maxcont*sizeof(char*)); - comstart['c'] = comstart['C'] = comstart['*'] = comstart['!'] = - comstart['#'] = 1; -#ifdef EOF_CHAR - comstart[EOF_CHAR] = 1; -#endif - s = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_"; - while(i = *s++) - anum_buf[i] = 1; - s = "0123456789"; - while(i = *s++) - anum_buf[i] = 2; - } - - LOCAL int -#ifdef KR_headers -hexcheck(key) - int key; -#else -hexcheck(int key) -#endif -{ - register int radix; - register char *p; - char *kind; - - switch(key) { - case 'z': - case 'Z': - case 'x': - case 'X': - radix = 16; - key = SHEXCON; - kind = "hexadecimal"; - break; - case 'o': - case 'O': - radix = 8; - key = SOCTCON; - kind = "octal"; - break; - case 'b': - case 'B': - radix = 2; - key = SBITCON; - kind = "binary"; - break; - default: - err("bad bit identifier"); - return(SNAME); - } - for(p = token; *p; p++) - if (hextoi(*p) >= radix) { - errstr("invalid %s character", kind); - break; - } - return key; - } - -/* gettok -- moves the right amount of text from nextch into the token - buffer. token initially contains garbage (leftovers from the prev token) */ - - LOCAL int -gettok(Void) -{ - int havdot, havexp, havdbl; - int radix, val; - struct Punctlist *pp; - struct Dotlist *pd; - register int ch; - static char Exp_mi[] = "X**-Y treated as X**(-Y)", - Exp_pl[] = "X**+Y treated as X**(+Y)"; - - char *i, *j, *n1, *p; - - ch = * USC nextch; - if(ch == (MYQUOTE)) - { - ++nextch; - p = token; - while(*nextch != MYQUOTE) - *p++ = *nextch++; - toklen = p - token; - *p = 0; - /* allow octal, binary, hex constants of the form 'abc'x (etc.) */ - if (++nextch <= lastch && isalpha_(val = * USC nextch)) { - ++nextch; - return hexcheck(val); - } - return (SHOLLERITH); - } - - if(needkwd) - { - needkwd = 0; - return( getkwd() ); - } - - for(pp=puncts; pp->punchar; ++pp) - if(ch == pp->punchar) { - val = pp->punval; - if (++nextch <= lastch) - switch(ch) { - case '/': - switch(*nextch) { - case '/': - nextch++; - val = SCONCAT; - break; - case '=': - goto sne; - default: - if (new_dcl && parlev == 0) - val = SSLASHD; - } - return val; - case '*': - if (*nextch == '*') { - nextch++; - if (noextflag - && nextch <= lastch) - switch(*nextch) { - case '-': - errext(Exp_mi); - break; - case '+': - errext(Exp_pl); - } - return SPOWER; - } - break; - case '<': - switch(*nextch) { - case '=': - nextch++; - val = SLE; - break; - case '>': - sne: - nextch++; - val = SNE; - } - goto extchk; - case '=': - if (*nextch == '=') { - nextch++; - val = SEQ; - goto extchk; - } - break; - case '>': - if (*nextch == '=') { - nextch++; - val = SGE; - } - extchk: - NOEXT("Fortran 8x comparison operator"); - return val; - } - else if (ch == '/' && new_dcl && parlev == 0) - return SSLASHD; - switch(val) { - case SLPAR: - ++parlev; - break; - case SRPAR: - --parlev; - } - return(val); - } - if(ch == '.') - if(nextch >= lastch) goto badchar; - else if(isdigit(nextch[1])) goto numconst; - else { - for(pd=dots ; (j=pd->dotname) ; ++pd) - { - for(i=nextch+1 ; i<=lastch ; ++i) - if(*i != *j) break; - else if(*i != '.') ++j; - else { - nextch = i+1; - return(pd->dotval); - } - } - goto badchar; - } - if( isalpha_(ch) ) - { - p = token; - *p++ = *nextch++; - while(nextch<=lastch) - if( isalnum_(* USC nextch) ) - *p++ = *nextch++; - else break; - toklen = p - token; - *p = 0; - if (needwkey) { - needwkey = 0; - if (toklen == 5 - && nextch <= lastch && *nextch == '(' /*)*/ - && !strcmp(token,"while")) - return(SWHILE); - } - if(inioctl && nextch<=lastch && *nextch=='=') - { - ++nextch; - return(SNAMEEQ); - } - if(toklen>8 && eqn(8,token,"function") - && isalpha_(* USC (token+8)) && - nextch<lastch && nextch[0]=='(' && - (nextch[1]==')' || isalpha_(* USC (nextch+1))) ) - { - nextch -= (toklen - 8); - return(SFUNCTION); - } - - if(toklen > MAXNAMELEN) - { - char buff[MAXNAMELEN+50]; - sprintf(buff, toklen >= MAXNAMELEN+10 - ? "name %.*s... too long, truncated to %.*s" - : "name %s too long, truncated to %.*s", - MAXNAMELEN+6, token, MAXNAMELEN, token); - err(buff); - toklen = MAXNAMELEN; - token[MAXNAMELEN] = '\0'; - } - if(toklen==1 && *nextch==MYQUOTE) { - val = token[0]; - ++nextch; - for(p = token ; *nextch!=MYQUOTE ; ) - *p++ = *nextch++; - ++nextch; - toklen = p - token; - *p = 0; - return hexcheck(val); - } - return(SNAME); - } - - if (isdigit(ch)) { - - /* Check for NAG's special hex constant */ - - if (nextch[1] == '#' && nextch < lastch - || nextch[2] == '#' && isdigit(nextch[1]) - && lastch - nextch >= 2) { - - radix = atoi (nextch); - if (*++nextch != '#') - nextch++; - if (radix != 2 && radix != 8 && radix != 16) { - erri("invalid base %d for constant, defaulting to hex", - radix); - radix = 16; - } /* if */ - if (++nextch > lastch) - goto badchar; - for (p = token; hextoi(*nextch) < radix;) { - *p++ = *nextch++; - if (nextch > lastch) - break; - } - toklen = p - token; - *p = 0; - return (radix == 16) ? SHEXCON : ((radix == 8) ? SOCTCON : - SBITCON); - } - } - else - goto badchar; -numconst: - havdot = NO; - havexp = NO; - havdbl = NO; - for(n1 = nextch ; nextch<=lastch ; ++nextch) - { - if(*nextch == '.') - if(havdot) break; - else if(nextch+2<=lastch && isalpha_(* USC (nextch+1)) - && isalpha_(* USC (nextch+2))) - break; - else havdot = YES; - else if( !intonly && (*nextch=='d' || *nextch=='e') ) - { - p = nextch; - havexp = YES; - if(*nextch == 'd') - havdbl = YES; - if(nextch<lastch) - if(nextch[1]=='+' || nextch[1]=='-') - ++nextch; - if( ! isdigit(*++nextch) ) - { - nextch = p; - havdbl = havexp = NO; - break; - } - for(++nextch ; - nextch<=lastch && isdigit(* USC nextch); - ++nextch); - break; - } - else if( ! isdigit(* USC nextch) ) - break; - } - p = token; - i = n1; - while(i < nextch) - *p++ = *i++; - toklen = p - token; - *p = 0; - if(havdbl) return(SDCON); - if(havdot || havexp) return(SRCON); - return(SICON); -badchar: - sbuf[0] = *nextch++; - return(SUNKNOWN); -} - -/* Comment buffering code */ - - static void -#ifdef KR_headers -store_comment(str) - char *str; -#else -store_comment(char *str) -#endif -{ - int len; - comment_buf *ncb; - - if (nextcd == sbuf) { - flush_comments(); - p1_comment(str); - return; - } - len = strlen(str) + 1; - if (cbnext + len > cblast) { - ncb = 0; - if (cbcur) { - cbcur->last = cbnext; - ncb = cbcur->next; - } - if (!ncb) { - ncb = (comment_buf *) Alloc(sizeof(comment_buf)); - if (cbcur) - cbcur->next = ncb; - else { - cbfirst = ncb; - cbinit = ncb->buf; - } - ncb->next = 0; - } - cbcur = ncb; - cbnext = ncb->buf; - cblast = cbnext + COMMENT_BUF_STORE; - } - strcpy(cbnext, str); - cbnext += len; - } - - static void -flush_comments(Void) -{ - register char *s, *s1; - register comment_buf *cb; - if (cbnext == cbinit) - return; - cbcur->last = cbnext; - for(cb = cbfirst;; cb = cb->next) { - for(s = cb->buf; s < cb->last; s = s1) { - /* compute s1 = new s value first, since */ - /* p1_comment may insert nulls into s */ - s1 = s + strlen(s) + 1; - p1_comment(s); - } - if (cb == cbcur) - break; - } - cbcur = cbfirst; - cbnext = cbinit; - cblast = cbnext + COMMENT_BUF_STORE; - } - - void -unclassifiable(Void) -{ - register char *s, *se; - - s = sbuf; - se = lastch; - if (se < sbuf) - return; - lastch = s - 1; - if (++se - s > 10) - se = s + 10; - for(; s < se; s++) - if (*s == MYQUOTE) { - se = s; - break; - } - *se = 0; - errstr("unclassifiable statement (starts \"%s\")", sbuf); - } diff --git a/usr.bin/f2c/machdefs.h b/usr.bin/f2c/machdefs.h deleted file mode 100644 index 3ab8961f0a2c..000000000000 --- a/usr.bin/f2c/machdefs.h +++ /dev/null @@ -1,31 +0,0 @@ -#define TYLENG TYLONG /* char string length field */ - -#define TYINT TYLONG -#define SZADDR 4 -#define SZSHORT 2 -#define SZINT 4 - -#define SZLONG 4 -#define SZLENG SZLONG - -#define SZDREAL 8 - -/* Alignment restrictions */ - -#define ALIADDR SZADDR -#define ALISHORT SZSHORT -#define ALILONG 4 -#define ALIDOUBLE 8 -#define ALIINT ALILONG -#define ALILENG ALILONG - -#define BLANKCOMMON "_BLNK__" /* Name for the unnamed - common block; this is unique - because of underscores */ - -#define LABELFMT "%s:\n" - -#define MAXREGVAR 4 -#define TYIREG TYLONG -#define MSKIREG (M(TYSHORT)|M(TYLONG)) /* allowed types of DO indicies - which can be put in registers */ diff --git a/usr.bin/f2c/main.c b/usr.bin/f2c/main.c deleted file mode 100644 index 7237905d29fb..000000000000 --- a/usr.bin/f2c/main.c +++ /dev/null @@ -1,710 +0,0 @@ -/**************************************************************** -Copyright 1990 - 1996 by AT&T, Lucent Technologies and Bellcore. - -Permission to use, copy, modify, and distribute this software -and its documentation for any purpose and without fee is hereby -granted, provided that the above copyright notice appear in all -copies and that both that the copyright notice and this -permission notice and warranty disclaimer appear in supporting -documentation, and that the names of AT&T, Bell Laboratories, -Lucent or Bellcore or any of their entities not be used in -advertising or publicity pertaining to distribution of the -software without specific, written prior permission. - -AT&T, Lucent and Bellcore disclaim all warranties with regard to -this software, including all implied warranties of -merchantability and fitness. In no event shall AT&T, Lucent or -Bellcore be liable for any special, indirect or consequential -damages or any damages whatsoever resulting from loss of use, -data or profits, whether in an action of contract, negligence or -other tortious action, arising out of or in connection with the -use or performance of this software. -****************************************************************/ - -extern char F2C_version[]; - -#include "defs.h" -#include "parse.h" - -int complex_seen, dcomplex_seen; - -LOCAL int Max_ftn_files; - -int badargs; -char **ftn_files; -int current_ftn_file = 0; - -flag ftn66flag = NO; -flag nowarnflag = NO; -flag noextflag = NO; -flag no66flag = NO; /* Must also set noextflag to this - same value */ -flag zflag = YES; /* recognize double complex intrinsics */ -flag debugflag = NO; -flag onetripflag = NO; -flag shiftcase = YES; -flag undeftype = NO; -flag checksubs = NO; -flag r8flag = NO; -flag use_bs = YES; -flag keepsubs = NO; -flag byterev = NO; -flag echo = NO; -int intr_omit; -static int no_cd, no_i90; -#ifdef TYQUAD -flag use_tyquad = YES; -#endif -int tyreal = TYREAL; -int tycomplex = TYCOMPLEX; - -int maxregvar = MAXREGVAR; /* if maxregvar > MAXREGVAR, error */ -int maxequiv = MAXEQUIV; -int maxext = MAXEXT; -int maxstno = MAXSTNO; -int maxctl = MAXCTL; -int maxhash = MAXHASH; -int maxliterals = MAXLITERALS; -int maxcontin = MAXCONTIN; -int maxlablist = MAXLABLIST; -int extcomm, ext1comm, useauto; -int can_include = YES; /* so we can disable includes for netlib */ - -static char *def_i2 = ""; - -static int useshortints = NO; /* YES => tyint = TYSHORT */ -static int uselongints = NO; /* YES => tyint = TYLONG */ -int addftnsrc = NO; /* Include ftn source in output */ -int usedefsforcommon = NO; /* Use #defines for common reference */ -int forcedouble = YES; /* force real functions to double */ -int dneg = NO; /* f77 treatment of unary minus */ -int Ansi = NO; -int def_equivs = YES; -int tyioint = TYLONG; -int szleng = SZLENG; -int inqmask = M(TYLONG)|M(TYLOGICAL); -int wordalign = NO; -int forcereal = NO; -int warn72 = NO; -static int skipC, skipversion; -char *file_name, *filename0, *parens; -int Castargs = 1; -static int Castargs1; -static int typedefs = 0; -int chars_per_wd, gflag, protostatus; -int infertypes = 1; -char used_rets[TYSUBR+1]; -extern char *tmpdir; -static int h0align = 0; -char *halign, *ohalign; -int krparens = NO; -int hsize; /* for padding under -h */ -int htype; /* for wr_equiv_init under -h */ -chainp Iargs; -char *o_coutput = 0; - -#define f2c_entry(swit,count,type,store,size) \ - p_entry ("-", swit, 0, count, type, store, size) - -static arg_info table[] = { - f2c_entry ("o", P_ONE_ARG, P_STRING, &o_coutput, YES), - f2c_entry ("w66", P_NO_ARGS, P_INT, &ftn66flag, YES), - f2c_entry ("w", P_NO_ARGS, P_INT, &nowarnflag, YES), - f2c_entry ("66", P_NO_ARGS, P_INT, &no66flag, YES), - f2c_entry ("1", P_NO_ARGS, P_INT, &onetripflag, YES), - f2c_entry ("onetrip", P_NO_ARGS, P_INT, &onetripflag, YES), - f2c_entry ("I2", P_NO_ARGS, P_INT, &useshortints, YES), - f2c_entry ("I4", P_NO_ARGS, P_INT, &uselongints, YES), - f2c_entry ("U", P_NO_ARGS, P_INT, &shiftcase, NO), - f2c_entry ("u", P_NO_ARGS, P_INT, &undeftype, YES), - f2c_entry ("O", P_ONE_ARG, P_INT, &maxregvar, 0), - f2c_entry ("C", P_NO_ARGS, P_INT, &checksubs, YES), - f2c_entry ("Nq", P_ONE_ARG, P_INT, &maxequiv, 0), - f2c_entry ("Nx", P_ONE_ARG, P_INT, &maxext, 0), - f2c_entry ("Ns", P_ONE_ARG, P_INT, &maxstno, 0), - f2c_entry ("Nc", P_ONE_ARG, P_INT, &maxctl, 0), - f2c_entry ("Nn", P_ONE_ARG, P_INT, &maxhash, 0), - f2c_entry ("NL", P_ONE_ARG, P_INT, &maxliterals, 0), - f2c_entry ("NC", P_ONE_ARG, P_INT, &maxcontin, 0), - f2c_entry ("Nl", P_ONE_ARG, P_INT, &maxlablist, 0), - f2c_entry ("c", P_NO_ARGS, P_INT, &addftnsrc, YES), - f2c_entry ("p", P_NO_ARGS, P_INT, &usedefsforcommon, YES), - f2c_entry ("v", P_NO_ARGS, P_INT, &echo, YES), - f2c_entry ("R", P_NO_ARGS, P_INT, &forcedouble, NO), - f2c_entry ("!R", P_NO_ARGS, P_INT, &forcedouble, YES), - f2c_entry ("A", P_NO_ARGS, P_INT, &Ansi, YES), - f2c_entry ("ext", P_NO_ARGS, P_INT, &noextflag, YES), - f2c_entry ("z", P_NO_ARGS, P_INT, &zflag, NO), - f2c_entry ("a", P_NO_ARGS, P_INT, &useauto, YES), - f2c_entry ("r8", P_NO_ARGS, P_INT, &r8flag, YES), - f2c_entry ("i2", P_NO_ARGS, P_INT, &tyioint, NO), - f2c_entry ("w8", P_NO_ARGS, P_INT, &wordalign, YES), - f2c_entry ("!I", P_NO_ARGS, P_INT, &can_include, NO), - f2c_entry ("W", P_ONE_ARG, P_INT, &chars_per_wd, 0), - f2c_entry ("g", P_NO_ARGS, P_INT, &gflag, YES), - f2c_entry ("T", P_ONE_ARG, P_STRING, &tmpdir, 0), - f2c_entry ("E", P_NO_ARGS, P_INT, &extcomm, 1), - f2c_entry ("e1c", P_NO_ARGS, P_INT, &ext1comm, 1), - f2c_entry ("ec", P_NO_ARGS, P_INT, &ext1comm, 2), - f2c_entry ("C++", P_NO_ARGS, P_INT, &Ansi, 2), - f2c_entry ("P", P_NO_ARGS, P_INT, &Castargs, 3), - f2c_entry ("Ps", P_NO_ARGS, P_INT, &protostatus, 1), - f2c_entry ("!P", P_NO_ARGS, P_INT, &Castargs, 0), - f2c_entry ("!c", P_NO_ARGS, P_INT, &skipC, 1), - f2c_entry ("!it", P_NO_ARGS, P_INT, &infertypes, 0), - f2c_entry ("h", P_NO_ARGS, P_INT, &h0align, 1), - f2c_entry ("hd", P_NO_ARGS, P_INT, &h0align, 2), - f2c_entry ("kr", P_NO_ARGS, P_INT, &krparens, 1), - f2c_entry ("krd", P_NO_ARGS, P_INT, &krparens, 2), - f2c_entry ("!bs", P_NO_ARGS, P_INT, &use_bs, NO), - f2c_entry ("r", P_NO_ARGS, P_INT, &forcereal, YES), - f2c_entry ("72", P_NO_ARGS, P_INT, &warn72, 1), - f2c_entry ("f", P_NO_ARGS, P_INT, &warn72, 2), - f2c_entry ("s", P_NO_ARGS, P_INT, &keepsubs, 1), - f2c_entry ("d", P_ONE_ARG, P_STRING, &outbuf, 0), - f2c_entry ("cd", P_NO_ARGS, P_INT, &no_cd, 1), - f2c_entry ("i90", P_NO_ARGS, P_INT, &no_i90, 2), -#ifdef TYQUAD - f2c_entry ("!i8", P_NO_ARGS, P_INT, &use_tyquad, NO), -#endif - - /* options omitted from man pages */ - - /* -b ==> for unformatted I/O, call do_unio (for noncharacter */ - /* data of length > 1 byte) and do_ucio (for the rest) rather */ - /* than do_uio. This permits modifying libI77 to byte-reverse */ - /* numeric data. */ - - f2c_entry ("b", P_NO_ARGS, P_INT, &byterev, YES), - - /* -ev ==> implement equivalence with initialized pointers */ - f2c_entry ("ev", P_NO_ARGS, P_INT, &def_equivs, NO), - - /* -!it used to be the default when -it was more agressive */ - - f2c_entry ("it", P_NO_ARGS, P_INT, &infertypes, 1), - - /* -Pd is similar to -P, but omits :ref: lines */ - f2c_entry ("Pd", P_NO_ARGS, P_INT, &Castargs, 2), - - /* -t ==> emit typedefs (under -A or -C++) for procedure - argument types used. This is meant for netlib's - f2c service, so -A and -C++ will work with older - versions of f2c.h - */ - f2c_entry ("t", P_NO_ARGS, P_INT, &typedefs, 1), - - /* -!V ==> omit version msg (to facilitate using diff in - regression testing) - */ - f2c_entry ("!V", P_NO_ARGS, P_INT, &skipversion, 1), - - /* -Dnnn = debug level nnn */ - - f2c_entry ("D", P_ONE_ARG, P_INT, &debugflag, YES), - - /* -dneg ==> under (default) -!R, imitate f77's bizarre */ - /* treatment of unary minus of REAL expressions by */ - /* promoting them to DOUBLE PRECISION . */ - - f2c_entry ("dneg", P_NO_ARGS, P_INT, &dneg, YES) -}; /* table */ - -extern char *c_functions; /* "c_functions" */ -extern char *coutput; /* "c_output" */ -extern char *initfname; /* "raw_data" */ -extern char *blkdfname; /* "block_data" */ -extern char *p1_file; /* "p1_file" */ -extern char *p1_bakfile; /* "p1_file.BAK" */ -extern char *sortfname; /* "init_file" */ -extern char *proto_fname; /* "proto_file" */ -FILE *protofile; - - void -set_externs(Void) -{ - static char *hset[3] = { 0, "integer", "doublereal" }; - -/* Adjust the global flags according to the command line parameters */ - - if (chars_per_wd > 0) { - typesize[TYADDR] = typesize[TYLONG] = typesize[TYREAL] = - typesize[TYLOGICAL] = chars_per_wd; - typesize[TYINT1] = typesize[TYLOGICAL1] = 1; - typesize[TYDREAL] = typesize[TYCOMPLEX] = chars_per_wd << 1; - typesize[TYDCOMPLEX] = chars_per_wd << 2; - typesize[TYSHORT] = typesize[TYLOGICAL2] = chars_per_wd >> 1; - typesize[TYCILIST] = 5*chars_per_wd; - typesize[TYICILIST] = 6*chars_per_wd; - typesize[TYOLIST] = 9*chars_per_wd; - typesize[TYCLLIST] = 3*chars_per_wd; - typesize[TYALIST] = 2*chars_per_wd; - typesize[TYINLIST] = 26*chars_per_wd; - } - - if (wordalign) - typealign[TYDREAL] = typealign[TYDCOMPLEX] = typealign[TYREAL]; - if (!tyioint) { - tyioint = TYSHORT; - szleng = typesize[TYSHORT]; - def_i2 = "#define f2c_i2 1\n"; - inqmask = M(TYSHORT)|M(TYLOGICAL2); - goto checklong; - } - else - szleng = typesize[TYLONG]; - if (useshortints) { - /* inqmask = M(TYLONG); */ - /* used to disallow LOGICAL in INQUIRE under -I2 */ - checklong: - protorettypes[TYLOGICAL] = "shortlogical"; - casttypes[TYLOGICAL] = "K_fp"; - if (uselongints) - err ("Can't use both long and short ints"); - else { - tyint = tylogical = TYSHORT; - tylog = TYLOGICAL2; - } - } - else if (uselongints) - tyint = TYLONG; - - if (h0align) { - if (tyint == TYLONG && wordalign) - h0align = 1; - ohalign = halign = hset[h0align]; - htype = h0align == 1 ? tyint : TYDREAL; - hsize = typesize[htype]; - } - - if (no66flag) - noextflag = no66flag; - if (noextflag) - zflag = 0; - - if (r8flag) { - tyreal = TYDREAL; - tycomplex = TYDCOMPLEX; - r8fix(); - } - if (forcedouble) { - protorettypes[TYREAL] = "E_f"; - casttypes[TYREAL] = "E_fp"; - } - else - dneg = 0; - - if (maxregvar > MAXREGVAR) { - warni("-O%d: too many register variables", maxregvar); - maxregvar = MAXREGVAR; - } /* if maxregvar > MAXREGVAR */ - -/* Check the list of input files */ - - { - int bad, i, cur_max = Max_ftn_files; - - for (i = bad = 0; i < cur_max && ftn_files[i]; i++) - if (ftn_files[i][0] == '-') { - errstr ("Invalid flag '%s'", ftn_files[i]); - bad++; - } - if (bad) - exit(1); - - } /* block */ -} /* set_externs */ - - - static int -comm2dcl(Void) -{ - Extsym *ext; - if (ext1comm) - for(ext = extsymtab; ext < nextext; ext++) - if (ext->extstg == STGCOMMON && !ext->extinit) - return ext1comm; - return 0; - } - - static void -#ifdef KR_headers -write_typedefs(outfile) - FILE *outfile; -#else -write_typedefs(FILE *outfile) -#endif -{ - register int i; - register char *s, *p = 0; - static char st[4] = { TYREAL, TYCOMPLEX, TYDCOMPLEX, TYCHAR }; - static char stl[4] = { 'E', 'C', 'Z', 'H' }; - - for(i = 0; i <= TYSUBR; i++) - if (s = usedcasts[i]) { - if (!p) { - p = Ansi == 1 ? "()" : "(...)"; - nice_printf(outfile, - "/* Types for casting procedure arguments: */\ -\n\n#ifndef F2C_proc_par_types\n"); - if (i == 0) { - nice_printf(outfile, - "typedef int /* Unknown procedure type */ (*%s)%s;\n", - s, p); - continue; - } - } - nice_printf(outfile, "typedef %s (*%s)%s;\n", - c_type_decl(i,1), s, p); - } - for(i = !forcedouble; i < 4; i++) - if (used_rets[st[i]]) - nice_printf(outfile, - "typedef %s %c_f; /* %s function */\n", - p = i ? "VOID" : "doublereal", - stl[i], ftn_types[st[i]]); - if (p) - nice_printf(outfile, "#endif\n\n"); - } - - static void -#ifdef KR_headers -commonprotos(outfile) - register FILE *outfile; -#else -commonprotos(register FILE *outfile) -#endif -{ - register Extsym *e, *ee; - register Argtypes *at; - Atype *a, *ae; - int k; - extern int proc_protochanges; - - if (!outfile) - return; - for (e = extsymtab, ee = nextext; e < ee; e++) - if (e->extstg == STGCOMMON && e->allextp) - nice_printf(outfile, "/* comlen %s %ld */\n", - e->cextname, e->maxleng); - if (Castargs1 < 3) - return; - - /* -Pr: special comments conveying current knowledge - of external references */ - - k = proc_protochanges; - for (e = extsymtab, ee = nextext; e < ee; e++) - if (e->extstg == STGEXT - && e->cextname != e->fextname) /* not a library function */ - if (at = e->arginfo) { - if ((!e->extinit || at->changes & 1) - /* not defined here or - changed since definition */ - && at->nargs >= 0) { - nice_printf(outfile, "/*:ref: %s %d %d", - e->cextname, e->extype, at->nargs); - a = at->atypes; - for(ae = a + at->nargs; a < ae; a++) - nice_printf(outfile, " %d", a->type); - nice_printf(outfile, " */\n"); - if (at->changes & 1) - k++; - } - } - else if (e->extype) - /* typed external, never invoked */ - nice_printf(outfile, "/*:ref: %s %d :*/\n", - e->cextname, e->extype); - if (k) { - nice_printf(outfile, - "/* Rerunning f2c -P may change prototypes or declarations. */\n"); - if (nerr) - return; - if (protostatus) - done(4); - if (protofile != stdout) { - fprintf(diagfile, - "Rerunning \"f2c -P ... %s %s\" may change prototypes or declarations.\n", - filename0, proto_fname); - fflush(diagfile); - } - } - } - - static int -#ifdef KR_headers -I_args(argc, a) - int argc; - char **a; -#else -I_args(int argc, char **a) -#endif -{ - char **a0, **a1, **ae, *s; - - ae = a + argc; - a0 = a; - for(a1 = ++a; a < ae; a++) { - if (!(s = *a)) - break; - if (*s == '-' && s[1] == 'I' && s[2] - && (s[3] || s[2] != '2' && s[2] != '4')) - Iargs = mkchain(s+2, Iargs); - else - *a1++ = s; - } - Iargs = revchain(Iargs); - *a1 = 0; - return a1 - a0; - } - - int retcode = 0; - - int -#ifdef KR_headers -main(argc, argv) - int argc; - char **argv; -#else -main(int argc, char **argv) -#endif -{ - int c2d, k; - FILE *c_output; - char *cdfilename; - static char stderrbuf[BUFSIZ]; - extern char **dfltproc, *dflt1proc[]; - extern char link_msg[]; - - diagfile = stderr; - setbuf(stderr, stderrbuf); /* arrange for fast error msgs */ - - argc = I_args(argc, argv); /* extract -I args */ - Max_ftn_files = argc - 1; - ftn_files = (char **)ckalloc((argc+1)*sizeof(char *)); - - parse_args (argc, argv, table, sizeof(table)/sizeof(arg_info), - ftn_files, Max_ftn_files); - if (badargs) - return 1; - intr_omit = no_cd | no_i90; - if (keepsubs && checksubs) { - warn("-C suppresses -s\n"); - keepsubs = 0; - } - if (!can_include && ext1comm == 2) - ext1comm = 1; - if (ext1comm && !extcomm) - extcomm = 2; - if (protostatus) - Castargs = 3; - Castargs1 = Castargs; - if (!Ansi) { - Castargs = 0; - parens = "()"; - } - else if (!Castargs) - parens = Ansi == 1 ? "()" : "(...)"; - else - dfltproc = dflt1proc; - - outbuf_adjust(); - set_externs(); - fileinit(); - read_Pfiles(ftn_files); - - for(k = 1; ftn_files[k]; k++) - if (dofork()) - break; - filename0 = file_name = ftn_files[current_ftn_file = k - 1]; - - set_tmp_names(); - sigcatch(0); - - c_file = opf(c_functions, textwrite); - pass1_file=opf(p1_file, binwrite); - initkey(); - if (file_name && *file_name) { - if (debugflag != 1) { - if (!o_coutput) - coutput = c_name(file_name,'c'); - else - coutput = o_coutput; - if (Castargs1 >= 2) - proto_fname = c_name(file_name,'P'); - } - cdfilename = coutput; - if (skipC) - coutput = 0; - if (coutput[0] == '-'){ - c_output = stdout; - coutput = 0; - } - else if (!(c_output = fopen(coutput, textwrite))) { - file_name = coutput; - coutput = 0; /* don't delete read-only .c file */ - fatalstr("can't open %.86s", file_name); - } - - if (Castargs1 >= 2 - && !(protofile = fopen(proto_fname, textwrite))) - fatalstr("Can't open %.84s\n", proto_fname); - } - else { - file_name = ""; - cdfilename = "f2c_out.c"; - c_output = stdout; - coutput = 0; - if (Castargs1 >= 2) { - protofile = stdout; - if (!skipC) - printf("#ifdef P_R_O_T_O_T_Y_P_E_S\n"); - } - } - - if(inilex( copys(file_name) )) - done(1); - if (filename0 && echo) { - fprintf(diagfile, "%s:\n", file_name); - fflush(diagfile); - } - - procinit(); - if(k = yyparse()) - { - fprintf(diagfile, "Bad parse, return code %d\n", k); - done(1); - } - - commonprotos(protofile); - if (protofile == stdout && !skipC) - printf("#endif\n\n"); - - if (nerr || skipC) - goto C_skipped; - - -/* Write out the declarations which are global to this file */ - - if ((c2d = comm2dcl()) == 1) - nice_printf(c_output, "/*>>>'/dev/null'<<<*/\n\n\ -/* Split this into several files by piping it through\n\n\ -sed \"s/^\\/\\*>>>'\\(.*\\)'<<<\\*\\/\\$/cat >'\\1' <<'\\/*<<<\\1>>>*\\/'/\" | /bin/sh\n\ - */\n\ -/*<<</dev/null>>>*/\n\ -/*>>>'%s'<<<*/\n", cdfilename); - if (gflag) - nice_printf (c_output, "#line 1 \"%s\"\n", file_name); - if (!skipversion) { - nice_printf (c_output, "/* %s -- translated by f2c ", file_name); - nice_printf (c_output, "(version %s).\n", F2C_version); - nice_printf (c_output, - " You must link the resulting object file with the libraries:\n\ - %s (in that order)\n*/\n\n", link_msg); - } - if (Ansi == 2) - nice_printf(c_output, - "#ifdef __cplusplus\nextern \"C\" {\n#endif\n"); - nice_printf (c_output, "%s#include \"f2c.h\"\n\n", def_i2); - if (gflag) - nice_printf (c_output, "#line 1 \"%s\"\n", file_name); - if (Castargs && typedefs) - write_typedefs(c_output); - nice_printf (c_file, "\n"); - fclose (c_file); - c_file = c_output; /* HACK to get the next indenting - to work */ - wr_common_decls (c_output); - if (blkdfile) - list_init_data(&blkdfile, blkdfname, c_output); - wr_globals (c_output); - if ((c_file = fopen (c_functions, textread)) == (FILE *) NULL) - Fatal("main - couldn't reopen c_functions"); - ffilecopy (c_file, c_output); - if (*main_alias) { - nice_printf (c_output, "/* Main program alias */ "); - nice_printf (c_output, "int %s () { MAIN__ ();%s }\n", - main_alias, Ansi ? " return 0;" : ""); - } - if (Ansi == 2) - nice_printf(c_output, - "#ifdef __cplusplus\n\t}\n#endif\n"); - if (c2d) { - if (c2d == 1) - fprintf(c_output, "/*<<<%s>>>*/\n", cdfilename); - else - fclose(c_output); - def_commons(c_output); - } - if (c2d != 2) - fclose (c_output); - - C_skipped: - if(parstate != OUTSIDE) - { - warn("missing final end statement"); - endproc(); - nerr = 1; - } - done(nerr ? 1 : 0); - /* NOT REACHED */ return 0; -} - - - FILEP -#ifdef KR_headers -opf(fn, mode) - char *fn; - char *mode; -#else -opf(char *fn, char *mode) -#endif -{ - FILEP fp; - if( fp = fopen(fn, mode) ) - return(fp); - - fatalstr("cannot open intermediate file %s", fn); - /* NOT REACHED */ return 0; -} - - - void -#ifdef KR_headers -clf(p, what, quit) - FILEP *p; - char *what; - int quit; -#else -clf(FILEP *p, char *what, int quit) -#endif -{ - if(p!=NULL && *p!=NULL && *p!=stdout) - { - if(ferror(*p)) { - fprintf(stderr, "I/O error on %s\n", what); - if (quit) - done(3); - retcode = 3; - } - fclose(*p); - } - *p = NULL; -} - - - void -#ifdef KR_headers -done(k) - int k; -#else -done(int k) -#endif -{ - clf(&initfile, "initfile", 0); - clf(&c_file, "c_file", 0); - clf(&pass1_file, "pass1_file", 0); - Un_link_all(k); - exit(k|retcode); -} diff --git a/usr.bin/f2c/malloc.c b/usr.bin/f2c/malloc.c deleted file mode 100644 index 7bd54bcea73f..000000000000 --- a/usr.bin/f2c/malloc.c +++ /dev/null @@ -1,182 +0,0 @@ -/**************************************************************** -Copyright 1990, 1994 by AT&T, Lucent Technologies and Bellcore. - -Permission to use, copy, modify, and distribute this software -and its documentation for any purpose and without fee is hereby -granted, provided that the above copyright notice appear in all -copies and that both that the copyright notice and this -permission notice and warranty disclaimer appear in supporting -documentation, and that the names of AT&T, Bell Laboratories, -Lucent or Bellcore or any of their entities not be used in -advertising or publicity pertaining to distribution of the -software without specific, written prior permission. - -AT&T, Lucent and Bellcore disclaim all warranties with regard to -this software, including all implied warranties of -merchantability and fitness. In no event shall AT&T, Lucent or -Bellcore be liable for any special, indirect or consequential -damages or any damages whatsoever resulting from loss of use, -data or profits, whether in an action of contract, negligence or -other tortious action, arising out of or in connection with the -use or performance of this software. -****************************************************************/ - -#ifndef CRAY -#define STACKMIN 512 -#define MINBLK (2*sizeof(struct mem) + 16) -#define F _malloc_free_ -#define SBGULP 8192 -#include "string.h" /* for memcpy */ - -#ifdef KR_headers -#define Char char -#define Unsigned unsigned -#define Int /*int*/ -#else -#define Char void -#define Unsigned size_t -#define Int int -#endif - -typedef struct mem { - struct mem *next; - Unsigned len; - } mem; - -mem *F; - - Char * -#ifdef KR_headers -malloc(size) - register Unsigned size; -#else -malloc(register Unsigned size) -#endif -{ - register mem *p, *q, *r, *s; - unsigned register k, m; - extern Char *sbrk(Int); - char *top, *top1; - - size = (size+7) & ~7; - r = (mem *) &F; - for (p = F, q = 0; p; r = p, p = p->next) { - if ((k = p->len) >= size && (!q || m > k)) { - m = k; - q = p; - s = r; - } - } - if (q) { - if (q->len - size >= MINBLK) { /* split block */ - p = (mem *) (((char *) (q+1)) + size); - p->next = q->next; - p->len = q->len - size - sizeof(mem); - s->next = p; - q->len = size; - } - else - s->next = q->next; - } - else { - top = (Char *)(((long)sbrk(0) + 7) & ~7); - if (F && (char *)(F+1) + F->len == top) { - q = F; - F = F->next; - } - else - q = (mem *) top; - top1 = (char *)(q+1) + size; - if (sbrk((int)(top1-top+SBGULP)) == (Char *) -1) - return 0; - r = (mem *)top1; - r->len = SBGULP - sizeof(mem); - r->next = F; - F = r; - q->len = size; - } - return (Char *) (q+1); - } - - void -#ifdef KR_headers -free(f) - Char *f; -#else -free(Char *f) -#endif -{ - mem *p, *q, *r; - char *pn, *qn; - - if (!f) return; - q = (mem *) ((char *)f - sizeof(mem)); - qn = (char *)f + q->len; - for (p = F, r = (mem *) &F; ; r = p, p = p->next) { - if (qn == (Char *) p) { - q->len += p->len + sizeof(mem); - p = p->next; - } - pn = p ? ((char *) (p+1)) + p->len : 0; - if (pn == (Char *) q) { - p->len += sizeof(mem) + q->len; - q->len = 0; - q->next = p; - r->next = p; - break; - } - if (pn < (char *) q) { - r->next = q; - q->next = p; - break; - } - } - } - - Char * -#ifdef KR_headers -realloc(f, size) - Char *f; - Unsigned size; -#else -realloc(Char *f, Unsigned size) -#endif -{ - mem *p; - Char *q, *f1; - Unsigned s1; - - if (!f) return malloc(size); - p = (mem *) ((char *)f - sizeof(mem)); - s1 = p->len; - free(f); - if (s1 > size) - s1 = size + 7 & ~7; - if (!p->len) { - f1 = (Char *)(p->next + 1); - memcpy(f1, f, s1); - f = f1; - } - q = malloc(size); - if (q && q != f) - memcpy(q, f, s1); - return q; - } - -/* The following (calloc) should really be in a separate file, */ -/* but defining it here sometimes avoids confusion on systems */ -/* that do not provide calloc in its own file. */ - - Char * -#ifdef KR_headers -calloc(n, m) Unsigned m, n; -#else -calloc(Unsigned n, Unsigned m) -#endif -{ - Char *rv = malloc(n *= m); - if (n && rv) - memset(rv, 0, n); - return rv; - } -#endif diff --git a/usr.bin/f2c/mem.c b/usr.bin/f2c/mem.c deleted file mode 100644 index 4e3d777dbb74..000000000000 --- a/usr.bin/f2c/mem.c +++ /dev/null @@ -1,268 +0,0 @@ -/**************************************************************** -Copyright 1990, 1991, 1994 by AT&T, Lucent Technologies and Bellcore. - -Permission to use, copy, modify, and distribute this software -and its documentation for any purpose and without fee is hereby -granted, provided that the above copyright notice appear in all -copies and that both that the copyright notice and this -permission notice and warranty disclaimer appear in supporting -documentation, and that the names of AT&T, Bell Laboratories, -Lucent or Bellcore or any of their entities not be used in -advertising or publicity pertaining to distribution of the -software without specific, written prior permission. - -AT&T, Lucent and Bellcore disclaim all warranties with regard to -this software, including all implied warranties of -merchantability and fitness. In no event shall AT&T, Lucent or -Bellcore be liable for any special, indirect or consequential -damages or any damages whatsoever resulting from loss of use, -data or profits, whether in an action of contract, negligence or -other tortious action, arising out of or in connection with the -use or performance of this software. -****************************************************************/ - -#include "defs.h" -#include "iob.h" - -#define MEMBSIZE 32000 -#define GMEMBSIZE 16000 - - char * -#ifdef KR_headers -gmem(n, round) - int n; - int round; -#else -gmem(int n, int round) -#endif -{ - static char *last, *next; - char *rv; - if (round) -#ifdef CRAY - if ((long)next & 0xe000000000000000) - next = (char *)(((long)next & 0x1fffffffffffffff) + 1); -#else -#ifdef MSDOS - if ((int)next & 1) - next++; -#else - next = (char *)(((long)next + sizeof(char *)-1) - & ~((long)sizeof(char *)-1)); -#endif -#endif - rv = next; - if ((next += n) > last) { - rv = Alloc(n + GMEMBSIZE); - - next = rv + n; - last = next + GMEMBSIZE; - } - return rv; - } - - struct memblock { - struct memblock *next; - char buf[MEMBSIZE]; - }; - typedef struct memblock memblock; - - static memblock *mem0; - memblock *curmemblock, *firstmemblock; - - char *mem_first, *mem_next, *mem_last, *mem0_last; - - void -mem_init(Void) -{ - curmemblock = firstmemblock = mem0 - = (memblock *)Alloc(sizeof(memblock)); - mem_first = mem0->buf; - mem_next = mem0->buf; - mem_last = mem0->buf + MEMBSIZE; - mem0_last = mem0->buf + MEMBSIZE; - mem0->next = 0; - } - - char * -#ifdef KR_headers -mem(n, round) - int n; - int round; -#else -mem(int n, int round) -#endif -{ - memblock *b; - register char *rv, *s; - - if (round) -#ifdef CRAY - if ((long)mem_next & 0xe000000000000000) - mem_next = (char *)(((long)mem_next & 0x1fffffffffffffff) + 1); -#else -#ifdef MSDOS - if ((int)mem_next & 1) - mem_next++; -#else - mem_next = (char *)(((long)mem_next + sizeof(char *)-1) - & ~((long)sizeof(char *)-1)); -#endif -#endif - rv = mem_next; - s = rv + n; - if (s >= mem_last) { - if (n > MEMBSIZE) { - fprintf(stderr, "mem(%d) failure!\n", n); - exit(1); - } - if (!(b = curmemblock->next)) { - b = (memblock *)Alloc(sizeof(memblock)); - curmemblock->next = b; - b->next = 0; - } - curmemblock = b; - rv = b->buf; - mem_last = rv + sizeof(b->buf); - s = rv + n; - } - mem_next = s; - return rv; - } - - char * -#ifdef KR_headers -tostring(s, n) - register char *s; - int n; -#else -tostring(register char *s, int n) -#endif -{ - register char *s1, *se, **sf; - char *rv, *s0; - register int k = n + 2, t; - - sf = str_fmt; - sf['%'] = "%"; - s0 = s; - se = s + n; - for(; s < se; s++) { - t = *(unsigned char *)s; - s1 = sf[t]; - while(*++s1) - k++; - } - sf['%'] = "%%"; - rv = s1 = mem(k,0); - *s1++ = '"'; - for(s = s0; s < se; s++) { - t = *(unsigned char *)s; - sprintf(s1, sf[t], t); - s1 += strlen(s1); - } - *s1 = 0; - return rv; - } - - char * -#ifdef KR_headers -cpstring(s) - register char *s; -#else -cpstring(register char *s) -#endif -{ - return strcpy(mem(strlen(s)+1,0), s); - } - - void -#ifdef KR_headers -new_iob_data(ios, name) - register io_setup *ios; - char *name; -#else -new_iob_data(register io_setup *ios, char *name) -#endif -{ - register iob_data *iod; - register char **s, **se; - - iod = (iob_data *) - mem(sizeof(iob_data) + ios->nelt*sizeof(char *), 1); - iod->next = iob_list; - iob_list = iod; - iod->type = ios->fields[0]; - iod->name = cpstring(name); - s = iod->fields; - se = s + ios->nelt; - while(s < se) - *s++ = "0"; - *s = 0; - } - - char * -#ifdef KR_headers -string_num(pfx, n) - char *pfx; - long n; -#else -string_num(char *pfx, long n) -#endif -{ - char buf[32]; - sprintf(buf, "%s%ld", pfx, n); - /* can't trust return type of sprintf -- BSD gets it wrong */ - return strcpy(mem(strlen(buf)+1,0), buf); - } - -static defines *define_list; - - void -#ifdef KR_headers -def_start(outfile, s1, s2, post) - FILE *outfile; - char *s1; - char *s2; - char *post; -#else -def_start(FILE *outfile, char *s1, char *s2, char *post) -#endif -{ - defines *d; - int n, n1; - extern int in_define; - - n = n1 = strlen(s1); - if (s2) - n += strlen(s2); - d = (defines *)mem(sizeof(defines)+n, 1); - d->next = define_list; - define_list = d; - strcpy(d->defname, s1); - if (s2) - strcpy(d->defname + n1, s2); - in_define = 1; - nice_printf(outfile, "#define %s", d->defname); - if (post) - nice_printf(outfile, " %s", post); - } - - void -#ifdef KR_headers -other_undefs(outfile) - FILE *outfile; -#else -other_undefs(FILE *outfile) -#endif -{ - defines *d; - if (d = define_list) { - define_list = 0; - nice_printf(outfile, "\n"); - do - nice_printf(outfile, "#undef %s\n", d->defname); - while(d = d->next); - nice_printf(outfile, "\n"); - } - } diff --git a/usr.bin/f2c/memset.c b/usr.bin/f2c/memset.c deleted file mode 100644 index 4d6ab4790349..000000000000 --- a/usr.bin/f2c/memset.c +++ /dev/null @@ -1,66 +0,0 @@ -/**************************************************************** -Copyright 1990 by AT&T, Lucent Technologies and Bellcore. - -Permission to use, copy, modify, and distribute this software -and its documentation for any purpose and without fee is hereby -granted, provided that the above copyright notice appear in all -copies and that both that the copyright notice and this -permission notice and warranty disclaimer appear in supporting -documentation, and that the names of AT&T, Bell Laboratories, -Lucent or Bellcore or any of their entities not be used in -advertising or publicity pertaining to distribution of the -software without specific, written prior permission. - -AT&T, Lucent and Bellcore disclaim all warranties with regard to -this software, including all implied warranties of -merchantability and fitness. In no event shall AT&T, Lucent or -Bellcore be liable for any special, indirect or consequential -damages or any damages whatsoever resulting from loss of use, -data or profits, whether in an action of contract, negligence or -other tortious action, arising out of or in connection with the -use or performance of this software. -****************************************************************/ - -/* This is for the benefit of people whose systems don't provide - * memset, memcpy, and memcmp. If yours is such a system, adjust - * the makefile by adding memset.o to the "OBJECTS =" assignment. - * WARNING: the memcpy below is adequate for f2c, but is not a - * general memcpy routine (which must correctly handle overlapping - * fields). - */ - - int -memcmp(s1, s2, n) - register char *s1, *s2; - int n; -{ - register char *se; - - for(se = s1 + n; s1 < se; s1++, s2++) - if (*s1 != *s2) - return *s1 - *s2; - return 0; - } - - char * -memcpy(s1, s2, n) - register char *s1, *s2; - int n; -{ - register char *s0 = s1, *se = s1 + n; - - while(s1 < se) - *s1++ = *s2++; - return s0; - } - -memset(s, c, n) - register char *s; - register int c; - int n; -{ - register char *se = s + n; - - while(s < se) - *s++ = c; - } diff --git a/usr.bin/f2c/misc.c b/usr.bin/f2c/misc.c deleted file mode 100644 index f5cca53f7556..000000000000 --- a/usr.bin/f2c/misc.c +++ /dev/null @@ -1,1329 +0,0 @@ -/**************************************************************** -Copyright 1990, 1992 - 1995 by AT&T, Lucent Technologies and Bellcore. - -Permission to use, copy, modify, and distribute this software -and its documentation for any purpose and without fee is hereby -granted, provided that the above copyright notice appear in all -copies and that both that the copyright notice and this -permission notice and warranty disclaimer appear in supporting -documentation, and that the names of AT&T, Bell Laboratories, -Lucent or Bellcore or any of their entities not be used in -advertising or publicity pertaining to distribution of the -software without specific, written prior permission. - -AT&T, Lucent and Bellcore disclaim all warranties with regard to -this software, including all implied warranties of -merchantability and fitness. In no event shall AT&T, Lucent or -Bellcore be liable for any special, indirect or consequential -damages or any damages whatsoever resulting from loss of use, -data or profits, whether in an action of contract, negligence or -other tortious action, arising out of or in connection with the -use or performance of this software. -****************************************************************/ - -#include "defs.h" -#include "limits.h" - - int -#ifdef KR_headers -oneof_stg(name, stg, mask) - Namep name; - int stg; - int mask; -#else -oneof_stg(Namep name, int stg, int mask) -#endif -{ - if (stg == STGCOMMON && name) { - if ((mask & M(STGEQUIV))) - return name->vcommequiv; - if ((mask & M(STGCOMMON))) - return !name->vcommequiv; - } - return ONEOF(stg, mask); - } - - -/* op_assign -- given a binary opcode, return the associated assignment - operator */ - - int -#ifdef KR_headers -op_assign(opcode) - int opcode; -#else -op_assign(int opcode) -#endif -{ - int retval = -1; - - switch (opcode) { - case OPPLUS: retval = OPPLUSEQ; break; - case OPMINUS: retval = OPMINUSEQ; break; - case OPSTAR: retval = OPSTAREQ; break; - case OPSLASH: retval = OPSLASHEQ; break; - case OPMOD: retval = OPMODEQ; break; - case OPLSHIFT: retval = OPLSHIFTEQ; break; - case OPRSHIFT: retval = OPRSHIFTEQ; break; - case OPBITAND: retval = OPBITANDEQ; break; - case OPBITXOR: retval = OPBITXOREQ; break; - case OPBITOR: retval = OPBITOREQ; break; - default: - erri ("op_assign: bad opcode '%d'", opcode); - break; - } /* switch */ - - return retval; -} /* op_assign */ - - - char * -#ifdef KR_headers -Alloc(n) - int n; -#else -Alloc(int n) -#endif - /* error-checking version of malloc */ - /* ckalloc initializes memory to 0; Alloc does not */ -{ - char errbuf[32]; - register char *rv; - - rv = malloc(n); - if (!rv) { - sprintf(errbuf, "malloc(%d) failure!", n); - Fatal(errbuf); - } - return rv; - } - - void -#ifdef KR_headers -cpn(n, a, b) - register int n; - register char *a; - register char *b; -#else -cpn(register int n, register char *a, register char *b) -#endif -{ - while(--n >= 0) - *b++ = *a++; -} - - - int -#ifdef KR_headers -eqn(n, a, b) - register int n; - register char *a; - register char *b; -#else -eqn(register int n, register char *a, register char *b) -#endif -{ - while(--n >= 0) - if(*a++ != *b++) - return(NO); - return(YES); -} - - - - - - - int -#ifdef KR_headers -cmpstr(a, b, la, lb) - register char *a; - register char *b; - ftnint la; - ftnint lb; -#else -cmpstr(register char *a, register char *b, ftnint la, ftnint lb) -#endif - /* compare two strings */ -{ - register char *aend, *bend; - aend = a + la; - bend = b + lb; - - - if(la <= lb) - { - while(a < aend) - if(*a != *b) - return( *a - *b ); - else - { - ++a; - ++b; - } - - while(b < bend) - if(*b != ' ') - return(' ' - *b); - else - ++b; - } - - else - { - while(b < bend) - if(*a != *b) - return( *a - *b ); - else - { - ++a; - ++b; - } - while(a < aend) - if(*a != ' ') - return(*a - ' '); - else - ++a; - } - return(0); -} - - -/* hookup -- Same as LISP NCONC, that is a destructive append of two lists */ - - chainp -#ifdef KR_headers -hookup(x, y) - register chainp x; - register chainp y; -#else -hookup(register chainp x, register chainp y) -#endif -{ - register chainp p; - - if(x == NULL) - return(y); - - for(p = x ; p->nextp ; p = p->nextp) - ; - p->nextp = y; - return(x); -} - - - - struct Listblock * -#ifdef KR_headers -mklist(p) - chainp p; -#else -mklist(chainp p) -#endif -{ - register struct Listblock *q; - - q = ALLOC(Listblock); - q->tag = TLIST; - q->listp = p; - return(q); -} - - - chainp -#ifdef KR_headers -mkchain(p, q) - register char * p; - register chainp q; -#else -mkchain(register char * p, register chainp q) -#endif -{ - register chainp r; - - if(chains) - { - r = chains; - chains = chains->nextp; - } - else - r = ALLOC(Chain); - - r->datap = p; - r->nextp = q; - return(r); -} - - chainp -#ifdef KR_headers -revchain(next) - register chainp next; -#else -revchain(register chainp next) -#endif -{ - register chainp p, prev = 0; - - while(p = next) { - next = p->nextp; - p->nextp = prev; - prev = p; - } - return prev; - } - - -/* addunder -- turn a cvarname into an external name */ -/* The cvarname may already end in _ (to avoid C keywords); */ -/* if not, it has room for appending an _. */ - - char * -#ifdef KR_headers -addunder(s) - register char *s; -#else -addunder(register char *s) -#endif -{ - register int c, i, j; - char *s0 = s; - - i = j = 0; - while(c = *s++) - if (c == '_') - i++, j++; - else - i = 0; - if (!i) { - *s-- = 0; - *s = '_'; - } - else if (j == 2) - s[-2] = 0; - return( s0 ); - } - - -/* copyn -- return a new copy of the input Fortran-string */ - - char * -#ifdef KR_headers -copyn(n, s) - register int n; - register char *s; -#else -copyn(register int n, register char *s) -#endif -{ - register char *p, *q; - - p = q = (char *) Alloc(n); - while(--n >= 0) - *q++ = *s++; - return(p); -} - - - -/* copys -- return a new copy of the input C-string */ - - char * -#ifdef KR_headers -copys(s) - char *s; -#else -copys(char *s) -#endif -{ - return( copyn( strlen(s)+1 , s) ); -} - - - -/* convci -- Convert Fortran-string to integer; assumes that input is a - legal number, with no trailing blanks */ - - ftnint -#ifdef KR_headers -convci(n, s) - register int n; - register char *s; -#else -convci(register int n, register char *s) -#endif -{ - ftnint sum, t; - char buff[100], *s0; - int n0; - - s0 = s; - n0 = n; - sum = 0; - while(n-- > 0) { - /* sum = 10*sum + (*s++ - '0'); */ - t = *s++ - '0'; - if (sum > LONG_MAX/10) { - ovfl: - if (n0 > 60) - n0 = 60; - sprintf(buff, "integer constant %.*s truncated.", - n0, s0); - err(buff); - return LONG_MAX; - } - sum *= 10; - if (sum > LONG_MAX - t) - goto ovfl; - sum += t; - } - return(sum); - } - -/* convic - Convert Integer constant to string */ - - char * -#ifdef KR_headers -convic(n) - ftnint n; -#else -convic(ftnint n) -#endif -{ - static char s[20]; - register char *t; - - s[19] = '\0'; - t = s+19; - - do { - *--t = '0' + n%10; - n /= 10; - } while(n > 0); - - return(t); -} - - - -/* mkname -- add a new identifier to the environment, including the closed - hash table. */ - - Namep -#ifdef KR_headers -mkname(s) - register char *s; -#else -mkname(register char *s) -#endif -{ - struct Hashentry *hp; - register Namep q; - register int c, hash, i; - register char *t; - char *s0; - char errbuf[64]; - - hash = i = 0; - s0 = s; - while(c = *s++) { - hash += c; - if (c == '_') - i = 2; - } - if (!i && in_vector(s0,c_keywords,n_keywords) >= 0) - i = 2; - hash %= maxhash; - -/* Add the name to the closed hash table */ - - hp = hashtab + hash; - - while(q = hp->varp) - if( hash == hp->hashval && !strcmp(s0,q->fvarname) ) - return(q); - else if(++hp >= lasthash) - hp = hashtab; - - if(++nintnames >= maxhash-1) - many("names", 'n', maxhash); /* Fatal error */ - hp->varp = q = ALLOC(Nameblock); - hp->hashval = hash; - q->tag = TNAME; /* TNAME means the tag type is NAME */ - c = s - s0; - if (c > 7 && noextflag) { - sprintf(errbuf, "\"%.35s%s\" over 6 characters long", s0, - c > 36 ? "..." : ""); - errext(errbuf); - } - q->fvarname = strcpy(mem(c,0), s0); - t = q->cvarname = mem(c + i + 1, 0); - s = s0; - /* add __ to the end of any name containing _ and to any C keyword */ - while(*t = *s++) - t++; - if (i) { - do *t++ = '_'; - while(--i > 0); - *t = 0; - } - return(q); -} - - - struct Labelblock * -#ifdef KR_headers -mklabel(l) - ftnint l; -#else -mklabel(ftnint l) -#endif -{ - register struct Labelblock *lp; - - if(l <= 0) - return(NULL); - - for(lp = labeltab ; lp < highlabtab ; ++lp) - if(lp->stateno == l) - return(lp); - - if(++highlabtab > labtabend) - many("statement labels", 's', maxstno); - - lp->stateno = l; - lp->labelno = (int)newlabel(); - lp->blklevel = 0; - lp->labused = NO; - lp->fmtlabused = NO; - lp->labdefined = NO; - lp->labinacc = NO; - lp->labtype = LABUNKNOWN; - lp->fmtstring = 0; - return(lp); -} - - long -newlabel(Void) -{ - return ++lastlabno; -} - - -/* this label appears in a branch context */ - - struct Labelblock * -#ifdef KR_headers -execlab(stateno) - ftnint stateno; -#else -execlab(ftnint stateno) -#endif -{ - register struct Labelblock *lp; - - if(lp = mklabel(stateno)) - { - if(lp->labinacc) - warn1("illegal branch to inner block, statement label %s", - convic(stateno) ); - else if(lp->labdefined == NO) - lp->blklevel = blklevel; - if(lp->labtype == LABFORMAT) - err("may not branch to a format"); - else - lp->labtype = LABEXEC; - } - else - execerr("illegal label %s", convic(stateno)); - - return(lp); -} - - -/* find or put a name in the external symbol table */ - - Extsym * -#ifdef KR_headers -mkext1(f, s) - char *f; - char *s; -#else -mkext1(char *f, char *s) -#endif -{ - Extsym *p; - - for(p = extsymtab ; p<nextext ; ++p) - if(!strcmp(s,p->cextname)) - return( p ); - - if(nextext >= lastext) - many("external symbols", 'x', maxext); - - nextext->fextname = strcpy(gmem(strlen(f)+1,0), f); - nextext->cextname = f == s - ? nextext->fextname - : strcpy(gmem(strlen(s)+1,0), s); - nextext->extstg = STGUNKNOWN; - nextext->extp = 0; - nextext->allextp = 0; - nextext->extleng = 0; - nextext->maxleng = 0; - nextext->extinit = 0; - nextext->curno = nextext->maxno = 0; - return( nextext++ ); -} - - - Extsym * -#ifdef KR_headers -mkext(f, s) - char *f; - char *s; -#else -mkext(char *f, char *s) -#endif -{ - Extsym *e = mkext1(f, s); - if (e->extstg == STGCOMMON) - errstr("%.52s cannot be a subprogram: it is a common block.",f); - return e; - } - - Addrp -#ifdef KR_headers -builtin(t, s, dbi) - int t; - char *s; - int dbi; -#else -builtin(int t, char *s, int dbi) -#endif -{ - register Extsym *p; - register Addrp q; - extern chainp used_builtins; - - p = mkext(s,s); - if(p->extstg == STGUNKNOWN) - p->extstg = STGEXT; - else if(p->extstg != STGEXT) - { - errstr("improper use of builtin %s", s); - return(0); - } - - q = ALLOC(Addrblock); - q->tag = TADDR; - q->vtype = t; - q->vclass = CLPROC; - q->vstg = STGEXT; - q->memno = p - extsymtab; - q->dbl_builtin = dbi; - -/* A NULL pointer here tells you to use memno to check the external - symbol table */ - - q -> uname_tag = UNAM_EXTERN; - -/* Add to the list of used builtins */ - - if (dbi >= 0) - add_extern_to_list (q, &used_builtins); - return(q); -} - - - void -#ifdef KR_headers -add_extern_to_list(addr, list_store) - Addrp addr; - chainp *list_store; -#else -add_extern_to_list(Addrp addr, chainp *list_store) -#endif -{ - chainp last = CHNULL; - chainp list; - int memno; - - if (list_store == (chainp *) NULL || addr == (Addrp) NULL) - return; - - list = *list_store; - memno = addr -> memno; - - for (;list; last = list, list = list -> nextp) { - Addrp this = (Addrp) (list -> datap); - - if (this -> tag == TADDR && this -> uname_tag == UNAM_EXTERN && - this -> memno == memno) - return; - } /* for */ - - if (*list_store == CHNULL) - *list_store = mkchain((char *)cpexpr((expptr)addr), CHNULL); - else - last->nextp = mkchain((char *)cpexpr((expptr)addr), CHNULL); - -} /* add_extern_to_list */ - - - void -#ifdef KR_headers -frchain(p) - register chainp *p; -#else -frchain(register chainp *p) -#endif -{ - register chainp q; - - if(p==0 || *p==0) - return; - - for(q = *p; q->nextp ; q = q->nextp) - ; - q->nextp = chains; - chains = *p; - *p = 0; -} - - void -#ifdef KR_headers -frexchain(p) - register chainp *p; -#else -frexchain(register chainp *p) -#endif -{ - register chainp q, r; - - if (q = *p) { - for(;;q = r) { - frexpr((expptr)q->datap); - if (!(r = q->nextp)) - break; - } - q->nextp = chains; - chains = *p; - *p = 0; - } - } - - - tagptr -#ifdef KR_headers -cpblock(n, p) - register int n; - register char *p; -#else -cpblock(register int n, register char *p) -#endif -{ - register ptr q; - - memcpy((char *)(q = ckalloc(n)), (char *)p, n); - return( (tagptr) q); -} - - - - ftnint -#ifdef KR_headers -lmax(a, b) - ftnint a; - ftnint b; -#else -lmax(ftnint a, ftnint b) -#endif -{ - return( a>b ? a : b); -} - - ftnint -#ifdef KR_headers -lmin(a, b) - ftnint a; - ftnint b; -#else -lmin(ftnint a, ftnint b) -#endif -{ - return(a < b ? a : b); -} - - - - -#ifdef KR_headers -maxtype(t1, t2) - int t1; - int t2; -#else -maxtype(int t1, int t2) -#endif -{ - int t; - - t = t1 >= t2 ? t1 : t2; - if(t==TYCOMPLEX && (t1==TYDREAL || t2==TYDREAL) ) - t = TYDCOMPLEX; - return(t); -} - - - -/* return log base 2 of n if n a power of 2; otherwise -1 */ - int -#ifdef KR_headers -log_2(n) - ftnint n; -#else -log_2(ftnint n) -#endif -{ - int k; - - /* trick based on binary representation */ - - if(n<=0 || (n & (n-1))!=0) - return(-1); - - for(k = 0 ; n >>= 1 ; ++k) - ; - return(k); -} - - - void -frrpl(Void) -{ - struct Rplblock *rp; - - while(rpllist) - { - rp = rpllist->rplnextp; - free( (charptr) rpllist); - rpllist = rp; - } -} - - - -/* Call a Fortran function with an arbitrary list of arguments */ - -int callk_kludge; - - expptr -#ifdef KR_headers -callk(type, name, args) - int type; - char *name; - chainp args; -#else -callk(int type, char *name, chainp args) -#endif -{ - register expptr p; - - p = mkexpr(OPCALL, - (expptr)builtin(callk_kludge ? callk_kludge : type, name, 0), - (expptr)args); - p->exprblock.vtype = type; - return(p); -} - - - - expptr -#ifdef KR_headers -call4(type, name, arg1, arg2, arg3, arg4) - int type; - char *name; - expptr arg1; - expptr arg2; - expptr arg3; - expptr arg4; -#else -call4(int type, char *name, expptr arg1, expptr arg2, expptr arg3, expptr arg4) -#endif -{ - struct Listblock *args; - args = mklist( mkchain((char *)arg1, - mkchain((char *)arg2, - mkchain((char *)arg3, - mkchain((char *)arg4, CHNULL)) ) ) ); - return( callk(type, name, (chainp)args) ); -} - - - - - expptr -#ifdef KR_headers -call3(type, name, arg1, arg2, arg3) - int type; - char *name; - expptr arg1; - expptr arg2; - expptr arg3; -#else -call3(int type, char *name, expptr arg1, expptr arg2, expptr arg3) -#endif -{ - struct Listblock *args; - args = mklist( mkchain((char *)arg1, - mkchain((char *)arg2, - mkchain((char *)arg3, CHNULL) ) ) ); - return( callk(type, name, (chainp)args) ); -} - - - - - - expptr -#ifdef KR_headers -call2(type, name, arg1, arg2) - int type; - char *name; - expptr arg1; - expptr arg2; -#else -call2(int type, char *name, expptr arg1, expptr arg2) -#endif -{ - struct Listblock *args; - - args = mklist( mkchain((char *)arg1, mkchain((char *)arg2, CHNULL) ) ); - return( callk(type,name, (chainp)args) ); -} - - - - - expptr -#ifdef KR_headers -call1(type, name, arg) - int type; - char *name; - expptr arg; -#else -call1(int type, char *name, expptr arg) -#endif -{ - return( callk(type,name, (chainp)mklist(mkchain((char *)arg,CHNULL)) )); -} - - - expptr -#ifdef KR_headers -call0(type, name) - int type; - char *name; -#else -call0(int type, char *name) -#endif -{ - return( callk(type, name, CHNULL) ); -} - - - - struct Impldoblock * -#ifdef KR_headers -mkiodo(dospec, list) - chainp dospec; - chainp list; -#else -mkiodo(chainp dospec, chainp list) -#endif -{ - register struct Impldoblock *q; - - q = ALLOC(Impldoblock); - q->tag = TIMPLDO; - q->impdospec = dospec; - q->datalist = list; - return(q); -} - - - - -/* ckalloc -- Allocate 1 memory unit of size n, checking for out of - memory error */ - - ptr -#ifdef KR_headers -ckalloc(n) - register int n; -#else -ckalloc(register int n) -#endif -{ - register ptr p; - p = (ptr)calloc(1, (unsigned) n); - if (p || !n) - return(p); - fprintf(stderr, "failing to get %d bytes\n",n); - Fatal("out of memory"); - /* NOT REACHED */ return 0; -} - - - int -#ifdef KR_headers -isaddr(p) - register expptr p; -#else -isaddr(register expptr p) -#endif -{ - if(p->tag == TADDR) - return(YES); - if(p->tag == TEXPR) - switch(p->exprblock.opcode) - { - case OPCOMMA: - return( isaddr(p->exprblock.rightp) ); - - case OPASSIGN: - case OPASSIGNI: - case OPPLUSEQ: - case OPMINUSEQ: - case OPSLASHEQ: - case OPMODEQ: - case OPLSHIFTEQ: - case OPRSHIFTEQ: - case OPBITANDEQ: - case OPBITXOREQ: - case OPBITOREQ: - return( isaddr(p->exprblock.leftp) ); - } - return(NO); -} - - - - int -#ifdef KR_headers -isstatic(p) - register expptr p; -#else -isstatic(register expptr p) -#endif -{ - extern int useauto; - if(p->headblock.vleng && !ISCONST(p->headblock.vleng)) - return(NO); - - switch(p->tag) - { - case TCONST: - return(YES); - - case TADDR: - if(ONEOF(p->addrblock.vstg,MSKSTATIC) && - ISCONST(p->addrblock.memoffset) && !useauto) - return(YES); - - default: - return(NO); - } -} - - - -/* addressable -- return True iff it is a constant value, or can be - referenced by constant values */ - - int -#ifdef KR_headers -addressable(p) - register expptr p; -#else -addressable(register expptr p) -#endif -{ - switch(p->tag) - { - case TCONST: - return(YES); - - case TADDR: - return( addressable(p->addrblock.memoffset) ); - - default: - return(NO); - } -} - - -/* isnegative_const -- returns true if the constant is negative. Returns - false for imaginary and nonnumeric constants */ - - int -#ifdef KR_headers -isnegative_const(cp) - struct Constblock *cp; -#else -isnegative_const(struct Constblock *cp) -#endif -{ - int retval; - - if (cp == NULL) - return 0; - - switch (cp -> vtype) { - case TYINT1: - case TYSHORT: - case TYLONG: -#ifdef TYQUAD - case TYQUAD: -#endif - retval = cp -> Const.ci < 0; - break; - case TYREAL: - case TYDREAL: - retval = cp->vstg ? *cp->Const.cds[0] == '-' - : cp->Const.cd[0] < 0.0; - break; - default: - - retval = 0; - break; - } /* switch */ - - return retval; -} /* isnegative_const */ - - void -#ifdef KR_headers -negate_const(cp) - Constp cp; -#else -negate_const(Constp cp) -#endif -{ - if (cp == (struct Constblock *) NULL) - return; - - switch (cp -> vtype) { - case TYINT1: - case TYSHORT: - case TYLONG: -#ifdef TYQUAD - case TYQUAD: -#endif - cp -> Const.ci = - cp -> Const.ci; - break; - case TYCOMPLEX: - case TYDCOMPLEX: - if (cp->vstg) - switch(*cp->Const.cds[1]) { - case '-': - ++cp->Const.cds[1]; - break; - case '0': - break; - default: - --cp->Const.cds[1]; - } - else - cp->Const.cd[1] = -cp->Const.cd[1]; - /* no break */ - case TYREAL: - case TYDREAL: - if (cp->vstg) - switch(*cp->Const.cds[0]) { - case '-': - ++cp->Const.cds[0]; - break; - case '0': - break; - default: - --cp->Const.cds[0]; - } - else - cp->Const.cd[0] = -cp->Const.cd[0]; - break; - case TYCHAR: - case TYLOGICAL1: - case TYLOGICAL2: - case TYLOGICAL: - erri ("negate_const: can't negate type '%d'", cp -> vtype); - break; - default: - erri ("negate_const: bad type '%d'", - cp -> vtype); - break; - } /* switch */ -} /* negate_const */ - - void -#ifdef KR_headers -ffilecopy(infp, outfp) - FILE *infp; - FILE *outfp; -#else -ffilecopy(FILE *infp, FILE *outfp) -#endif -{ - while (!feof (infp)) { - register c = getc (infp); - if (!feof (infp)) - putc (c, outfp); - } /* while */ -} /* ffilecopy */ - - -/* in_vector -- verifies whether str is in c_keywords. - If so, the index is returned else -1 is returned. - c_keywords must be in alphabetical order (as defined by strcmp). -*/ - - int -#ifdef KR_headers -in_vector(str, keywds, n) - char *str; - char **keywds; - register int n; -#else -in_vector(char *str, char **keywds, register int n) -#endif -{ - register char **K = keywds; - register int n1, t; - - do { - n1 = n >> 1; - if (!(t = strcmp(str, K[n1]))) - return K - keywds + n1; - if (t < 0) - n = n1; - else { - n -= ++n1; - K += n1; - } - } - while(n > 0); - - return -1; - } /* in_vector */ - - - int -#ifdef KR_headers -is_negatable(Const) - Constp Const; -#else -is_negatable(Constp Const) -#endif -{ - int retval = 0; - if (Const != (Constp) NULL) - switch (Const -> vtype) { - case TYINT1: - retval = Const -> Const.ci >= -BIGGEST_CHAR; - break; - case TYSHORT: - retval = Const -> Const.ci >= -BIGGEST_SHORT; - break; - case TYLONG: -#ifdef TYQUAD - case TYQUAD: -#endif - retval = Const -> Const.ci >= -BIGGEST_LONG; - break; - case TYREAL: - case TYDREAL: - case TYCOMPLEX: - case TYDCOMPLEX: - retval = 1; - break; - case TYLOGICAL1: - case TYLOGICAL2: - case TYLOGICAL: - case TYCHAR: - case TYSUBR: - default: - retval = 0; - break; - } /* switch */ - - return retval; -} /* is_negatable */ - - void -#ifdef KR_headers -backup(fname, bname) - char *fname; - char *bname; -#else -backup(char *fname, char *bname) -#endif -{ - FILE *b, *f; - static char couldnt[] = "Couldn't open %.80s"; - - if (!(f = fopen(fname, binread))) { - warn1(couldnt, fname); - return; - } - if (!(b = fopen(bname, binwrite))) { - warn1(couldnt, bname); - return; - } - ffilecopy(f, b); - fclose(f); - fclose(b); - } - - -/* struct_eq -- returns YES if structures have the same field names and - types, NO otherwise */ - - int -#ifdef KR_headers -struct_eq(s1, s2) - chainp s1; - chainp s2; -#else -struct_eq(chainp s1, chainp s2) -#endif -{ - struct Dimblock *d1, *d2; - Constp cp1, cp2; - - if (s1 == CHNULL && s2 == CHNULL) - return YES; - for(; s1 && s2; s1 = s1->nextp, s2 = s2->nextp) { - register Namep v1 = (Namep) s1 -> datap; - register Namep v2 = (Namep) s2 -> datap; - - if (v1 == (Namep) NULL || v1 -> tag != TNAME || - v2 == (Namep) NULL || v2 -> tag != TNAME) - return NO; - - if (v1->vtype != v2->vtype || v1->vclass != v2->vclass - || strcmp(v1->fvarname, v2->fvarname)) - return NO; - - /* compare dimensions (needed for comparing COMMON blocks) */ - - if (d1 = v1->vdim) { - if (!(cp1 = (Constp)d1->nelt) || cp1->tag != TCONST - || !(d2 = v2->vdim) - || !(cp2 = (Constp)d2->nelt) || cp2->tag != TCONST - || cp1->Const.ci != cp2->Const.ci) - return NO; - } - else if (v2->vdim) - return NO; - } /* while s1 != CHNULL && s2 != CHNULL */ - - return s1 == CHNULL && s2 == CHNULL; -} /* struct_eq */ diff --git a/usr.bin/f2c/names.c b/usr.bin/f2c/names.c deleted file mode 100644 index b0e1058b160a..000000000000 --- a/usr.bin/f2c/names.c +++ /dev/null @@ -1,835 +0,0 @@ -/**************************************************************** -Copyright 1990, 1992 - 1996 by AT&T, Lucent Technologies and Bellcore. - -Permission to use, copy, modify, and distribute this software -and its documentation for any purpose and without fee is hereby -granted, provided that the above copyright notice appear in all -copies and that both that the copyright notice and this -permission notice and warranty disclaimer appear in supporting -documentation, and that the names of AT&T, Bell Laboratories, -Lucent or Bellcore or any of their entities not be used in -advertising or publicity pertaining to distribution of the -software without specific, written prior permission. - -AT&T, Lucent and Bellcore disclaim all warranties with regard to -this software, including all implied warranties of -merchantability and fitness. In no event shall AT&T, Lucent or -Bellcore be liable for any special, indirect or consequential -damages or any damages whatsoever resulting from loss of use, -data or profits, whether in an action of contract, negligence or -other tortious action, arising out of or in connection with the -use or performance of this software. -****************************************************************/ - -#include "defs.h" -#include "output.h" -#include "names.h" -#include "iob.h" - - -/* Names generated by the translator are guaranteed to be unique from the - Fortan names because Fortran does not allow underscores in identifiers, - and all of the system generated names do have underscores. The various - naming conventions are outlined below: - - FORMAT APPLICATION - ---------------------------------------------------------------------- - io_# temporaries generated by IO calls; these will - contain the device number (e.g. 5, 6, 0) - ret_val function return value, required for complex and - character functions. - ret_val_len length of the return value in character functions - - ssss_len length of character argument "ssss" - - c_# member of the literal pool, where # is an - arbitrary label assigned by the system - cs_# short integer constant in the literal pool - t_# expression temporary, # is the depth of arguments - on the stack. - L# label "#", given by user in the Fortran program. - This is unique because Fortran labels are numeric - pad_# label on an init field required for alignment - xxx_init label on a common block union, if a block data - requires a separate declaration -*/ - -/* generate variable references */ - - char * -#ifdef KR_headers -c_type_decl(type, is_extern) - int type; - int is_extern; -#else -c_type_decl(int type, int is_extern) -#endif -{ - static char buff[100]; - - switch (type) { - case TYREAL: if (!is_extern || !forcedouble) - { strcpy (buff, "real");break; } - case TYDREAL: strcpy (buff, "doublereal"); break; - case TYCOMPLEX: if (is_extern) - strcpy (buff, "/* Complex */ VOID"); - else - strcpy (buff, "complex"); - break; - case TYDCOMPLEX:if (is_extern) - strcpy (buff, "/* Double Complex */ VOID"); - else - strcpy (buff, "doublecomplex"); - break; - case TYADDR: - case TYINT1: - case TYSHORT: - case TYLONG: -#ifdef TYQUAD - case TYQUAD: -#endif - case TYLOGICAL1: - case TYLOGICAL2: - case TYLOGICAL: strcpy(buff, typename[type]); - break; - case TYCHAR: if (is_extern) - strcpy (buff, "/* Character */ VOID"); - else - strcpy (buff, "char"); - break; - - case TYUNKNOWN: strcpy (buff, "UNKNOWN"); - -/* If a procedure's type is unknown, assume it's a subroutine */ - - if (!is_extern) - break; - -/* Subroutines must return an INT, because they might return a label - value. Even if one doesn't, the caller will EXPECT it to. */ - - case TYSUBR: strcpy (buff, "/* Subroutine */ int"); - break; - case TYERROR: strcpy (buff, "ERROR"); break; - case TYVOID: strcpy (buff, "void"); break; - case TYCILIST: strcpy (buff, "cilist"); break; - case TYICILIST: strcpy (buff, "icilist"); break; - case TYOLIST: strcpy (buff, "olist"); break; - case TYCLLIST: strcpy (buff, "cllist"); break; - case TYALIST: strcpy (buff, "alist"); break; - case TYINLIST: strcpy (buff, "inlist"); break; - case TYFTNLEN: strcpy (buff, "ftnlen"); break; - default: sprintf (buff, "BAD DECL '%d'", type); - break; - } /* switch */ - - return buff; -} /* c_type_decl */ - - - char * -new_func_length(Void) -{ return "ret_val_len"; } - - char * -#ifdef KR_headers -new_arg_length(arg) - Namep arg; -#else -new_arg_length(Namep arg) -#endif -{ - static char buf[64]; - char *fmt = "%s_len", *s = arg->fvarname; - switch(*s) { - case 'r': - if (!strcmp(s+1, "et_val")) - goto adjust_fmt; - break; - case 'h': - case 'i': - if (!s[1]) { - adjust_fmt: - fmt = "%s_length"; /* avoid conflict with libF77 */ - } - } - sprintf (buf, fmt, s); - return buf; -} /* new_arg_length */ - - -/* declare_new_addr -- Add a new local variable to the function, given a - pointer to an Addrblock structure (which must have the uname_tag set) - This list of idents will be printed in reverse (i.e., chronological) - order */ - - void -#ifdef KR_headers -declare_new_addr(addrp) - struct Addrblock *addrp; -#else -declare_new_addr(struct Addrblock *addrp) -#endif -{ - extern chainp new_vars; - - new_vars = mkchain((char *)cpexpr((expptr)addrp), new_vars); -} /* declare_new_addr */ - - - void -#ifdef KR_headers -wr_nv_ident_help(outfile, addrp) - FILE *outfile; - struct Addrblock *addrp; -#else -wr_nv_ident_help(FILE *outfile, struct Addrblock *addrp) -#endif -{ - int eltcount = 0; - - if (addrp == (struct Addrblock *) NULL) - return; - - if (addrp -> isarray) { - frexpr (addrp -> memoffset); - addrp -> memoffset = ICON(0); - eltcount = addrp -> ntempelt; - addrp -> ntempelt = 0; - addrp -> isarray = 0; - } /* if */ - out_addr (outfile, addrp); - if (eltcount) - nice_printf (outfile, "[%d]", eltcount); -} /* wr_nv_ident_help */ - - int -#ifdef KR_headers -nv_type_help(addrp) - struct Addrblock *addrp; -#else -nv_type_help(struct Addrblock *addrp) -#endif -{ - if (addrp == (struct Addrblock *) NULL) - return -1; - - return addrp -> vtype; -} /* nv_type_help */ - - -/* lit_name -- returns a unique identifier for the given literal. Make - the label useful, when possible. For example: - - 1 -> c_1 (constant 1) - 2 -> c_2 (constant 2) - 1000 -> c_1000 (constant 1000) - 1000000 -> c_b<memno> (big constant number) - 1.2 -> c_1_2 (constant 1.2) - 1.234345 -> c_b<memno> (big constant number) - -1 -> c_n1 (constant -1) - -1.0 -> c_n1_0 (constant -1.0) - .true. -> c_true (constant true) - .false. -> c_false (constant false) - default -> c_b<memno> (default label) -*/ - - char * -#ifdef KR_headers -lit_name(litp) - struct Literal *litp; -#else -lit_name(struct Literal *litp) -#endif -{ - static char buf[CONST_IDENT_MAX]; - ftnint val; - char *fmt; - - if (litp == (struct Literal *) NULL) - return NULL; - - switch (litp -> littype) { - case TYINT1: - val = litp -> litval.litival; - if (val >= 256 || val < -255) - sprintf (buf, "ci1_b%ld", litp -> litnum); - else if (val < 0) - sprintf (buf, "ci1_n%ld", -val); - else - sprintf(buf, "ci1__%ld", val); - break; - case TYSHORT: - val = litp -> litval.litival; - if (val >= 32768 || val <= -32769) - sprintf (buf, "cs_b%ld", litp -> litnum); - else if (val < 0) - sprintf (buf, "cs_n%ld", -val); - else - sprintf (buf, "cs__%ld", val); - break; - case TYLONG: -#ifdef TYQUAD - case TYQUAD: -#endif - val = litp -> litval.litival; - if (val >= 100000 || val <= -10000) - sprintf (buf, "c_b%ld", litp -> litnum); - else if (val < 0) - sprintf (buf, "c_n%ld", -val); - else - sprintf (buf, "c__%ld", val); - break; - case TYLOGICAL1: - fmt = "cl1_%s"; - goto spr_logical; - case TYLOGICAL2: - fmt = "cl2_%s"; - goto spr_logical; - case TYLOGICAL: - fmt = "c_%s"; - spr_logical: - sprintf (buf, fmt, (litp -> litval.litival - ? "true" : "false")); - break; - case TYREAL: - case TYDREAL: - /* Given a limit of 6 or 8 character on external names, */ - /* few f.p. values can be meaningfully encoded in the */ - /* constant name. Just going with the default cb_# */ - /* seems to be the best course for floating-point */ - /* constants. */ - case TYCHAR: - /* Shouldn't be any of these */ - case TYADDR: - case TYCOMPLEX: - case TYDCOMPLEX: - case TYSUBR: - default: - sprintf (buf, "c_b%ld", litp -> litnum); - } /* switch */ - return buf; -} /* lit_name */ - - - - char * -#ifdef KR_headers -comm_union_name(count) - int count; -#else -comm_union_name(int count) -#endif -{ - static char buf[12]; - - sprintf(buf, "%d", count); - return buf; - } - - - - -/* wr_globals -- after every function has been translated, we need to - output the global declarations, such as the static table of constant - values */ - - void -#ifdef KR_headers -wr_globals(outfile) - FILE *outfile; -#else -wr_globals(FILE *outfile) -#endif -{ - struct Literal *litp, *lastlit; - extern int hsize; - char *litname; - int did_one, t; - struct Constblock cb; - ftnint x, y; - - if (nliterals == 0) - return; - - lastlit = litpool + nliterals; - did_one = 0; - for (litp = litpool; litp < lastlit; litp++) { - if (!litp->lituse) - continue; - litname = lit_name(litp); - if (!did_one) { - margin_printf(outfile, "/* Table of constant values */\n\n"); - did_one = 1; - } - cb.vtype = litp->littype; - if (litp->littype == TYCHAR) { - x = litp->litval.litival2[0] + litp->litval.litival2[1]; - if (y = x % hsize) - x += y = hsize - y; - nice_printf(outfile, - "static struct { %s fill; char val[%ld+1];", halign, x); - nice_printf(outfile, " char fill2[%ld];", hsize - 1); - nice_printf(outfile, " } %s_st = { 0,", litname); - cb.vleng = ICON(litp->litval.litival2[0]); - cb.Const.ccp = litp->cds[0]; - cb.Const.ccp1.blanks = litp->litval.litival2[1] + y; - cb.vtype = TYCHAR; - out_const(outfile, &cb); - frexpr(cb.vleng); - nice_printf(outfile, " };\n"); - nice_printf(outfile, "#define %s %s_st.val\n", litname, litname); - continue; - } - nice_printf(outfile, "static %s %s = ", - c_type_decl(litp->littype,0), litname); - - t = litp->littype; - if (ONEOF(t, MSKREAL|MSKCOMPLEX)) { - cb.vstg = 1; - cb.Const.cds[0] = litp->cds[0]; - cb.Const.cds[1] = litp->cds[1]; - } - else { - memcpy((char *)&cb.Const, (char *)&litp->litval, - sizeof(cb.Const)); - cb.vstg = 0; - } - out_const(outfile, &cb); - - nice_printf (outfile, ";\n"); - } /* for */ - if (did_one) - nice_printf (outfile, "\n"); -} /* wr_globals */ - - ftnint -#ifdef KR_headers -commlen(vl) - register chainp vl; -#else -commlen(register chainp vl) -#endif -{ - ftnint size; - int type; - struct Dimblock *t; - Namep v; - - while(vl->nextp) - vl = vl->nextp; - v = (Namep)vl->datap; - type = v->vtype; - if (type == TYCHAR) - size = v->vleng->constblock.Const.ci; - else - size = typesize[type]; - if ((t = v->vdim) && ISCONST(t->nelt)) - size *= t->nelt->constblock.Const.ci; - return size + v->voffset; - } - - static void /* Pad common block if an EQUIVALENCE extended it. */ -#ifdef KR_headers -pad_common(c) - Extsym *c; -#else -pad_common(Extsym *c) -#endif -{ - register chainp cvl; - register Namep v; - long L = c->maxleng; - int type; - struct Dimblock *t; - int szshort = typesize[TYSHORT]; - - for(cvl = c->allextp; cvl; cvl = cvl->nextp) - if (commlen((chainp)cvl->datap) >= L) - return; - v = ALLOC(Nameblock); - v->vtype = type = L % szshort ? TYCHAR - : type_choice[L/szshort % 4]; - v->vstg = STGCOMMON; - v->vclass = CLVAR; - v->tag = TNAME; - v->vdim = t = ALLOC(Dimblock); - t->ndim = 1; - t->dims[0].dimsize = ICON(L / typesize[type]); - v->fvarname = v->cvarname = "eqv_pad"; - if (type == TYCHAR) - v->vleng = ICON(1); - c->allextp = mkchain((char *)mkchain((char *)v, CHNULL), c->allextp); - } - - -/* wr_common_decls -- outputs the common declarations in one of three - formats. If all references to a common block look the same (field - names and types agree), only one actual declaration will appear. - Otherwise, the same block will require many structs. If there is no - block data, these structs will be union'ed together (so the linker - knows the size of the largest one). If there IS a block data, only - that version will be associated with the variable, others will only be - defined as types, so the pointer can be cast to it. e.g. - - FORTRAN C ----------------------------------------------------------------------- - common /com1/ a, b, c struct { real a, b, c; } com1_; - - common /com1/ a, b, c union { - common /com1/ i, j, k struct { real a, b, c; } _1; - struct { integer i, j, k; } _2; - } com1_; - - common /com1/ a, b, c struct com1_1_ { real a, b, c; }; - block data struct { integer i, j, k; } com1_ = - common /com1/ i, j, k { 1, 2, 3 }; - data i/1/, j/2/, k/3/ - - - All of these versions will be followed by #defines, since the code in - the function bodies can't know ahead of time which of these options - will be taken */ - -/* Macros for deciding the output type */ - -#define ONE_STRUCT 1 -#define UNION_STRUCT 2 -#define INIT_STRUCT 3 - - void -#ifdef KR_headers -wr_common_decls(outfile) - FILE *outfile; -#else -wr_common_decls(FILE *outfile) -#endif -{ - Extsym *ext; - extern int extcomm; - static char *Extern[4] = {"", "Extern ", "extern "}; - char *E, *E0 = Extern[extcomm]; - int did_one = 0; - - for (ext = extsymtab; ext < nextext; ext++) { - if (ext -> extstg == STGCOMMON && ext->allextp) { - chainp comm; - int count = 1; - int which; /* which display to use; - ONE_STRUCT, UNION or INIT */ - - if (!did_one) - nice_printf (outfile, "/* Common Block Declarations */\n\n"); - - pad_common(ext); - -/* Construct the proper, condensed list of structs; eliminate duplicates - from the initial list ext -> allextp */ - - comm = ext->allextp = revchain(ext->allextp); - - if (ext -> extinit) - which = INIT_STRUCT; - else if (comm->nextp) { - which = UNION_STRUCT; - nice_printf (outfile, "%sunion {\n", E0); - next_tab (outfile); - E = ""; - } - else { - which = ONE_STRUCT; - E = E0; - } - - for (; comm; comm = comm -> nextp, count++) { - - if (which == INIT_STRUCT) - nice_printf (outfile, "struct %s%d_ {\n", - ext->cextname, count); - else - nice_printf (outfile, "%sstruct {\n", E); - - next_tab (c_file); - - wr_struct (outfile, (chainp) comm -> datap); - - prev_tab (c_file); - if (which == UNION_STRUCT) - nice_printf (outfile, "} _%d;\n", count); - else if (which == ONE_STRUCT) - nice_printf (outfile, "} %s;\n", ext->cextname); - else - nice_printf (outfile, "};\n"); - } /* for */ - - if (which == UNION_STRUCT) { - prev_tab (c_file); - nice_printf (outfile, "} %s;\n", ext->cextname); - } /* if */ - did_one = 1; - nice_printf (outfile, "\n"); - - for (count = 1, comm = ext -> allextp; comm; - comm = comm -> nextp, count++) { - def_start(outfile, ext->cextname, - comm_union_name(count), ""); - switch (which) { - case ONE_STRUCT: - extern_out (outfile, ext); - break; - case UNION_STRUCT: - nice_printf (outfile, "("); - extern_out (outfile, ext); - nice_printf(outfile, "._%d)", count); - break; - case INIT_STRUCT: - nice_printf (outfile, "(*(struct "); - extern_out (outfile, ext); - nice_printf (outfile, "%d_ *) &", count); - extern_out (outfile, ext); - nice_printf (outfile, ")"); - break; - } /* switch */ - nice_printf (outfile, "\n"); - } /* for count = 1, comm = ext -> allextp */ - nice_printf (outfile, "\n"); - } /* if ext -> extstg == STGCOMMON */ - } /* for ext = extsymtab */ -} /* wr_common_decls */ - - void -#ifdef KR_headers -wr_struct(outfile, var_list) - FILE *outfile; - chainp var_list; -#else -wr_struct(FILE *outfile, chainp var_list) -#endif -{ - int last_type = -1; - int did_one = 0; - chainp this_var; - - for (this_var = var_list; this_var; this_var = this_var -> nextp) { - Namep var = (Namep) this_var -> datap; - int type; - char *comment = NULL; - - if (var == (Namep) NULL) - err ("wr_struct: null variable"); - else if (var -> tag != TNAME) - erri ("wr_struct: bad tag on variable '%d'", - var -> tag); - - type = var -> vtype; - - if (last_type == type && did_one) - nice_printf (outfile, ", "); - else { - if (did_one) - nice_printf (outfile, ";\n"); - nice_printf (outfile, "%s ", - c_type_decl (type, var -> vclass == CLPROC)); - } /* else */ - -/* Character type is really a string type. Put out a '*' for parameters - with unknown length and functions returning character */ - - if (var -> vtype == TYCHAR && (!ISICON ((var -> vleng)) - || var -> vclass == CLPROC)) - nice_printf (outfile, "*"); - - var -> vstg = STGAUTO; - out_name (outfile, var); - if (var -> vclass == CLPROC) - nice_printf (outfile, "()"); - else if (var -> vdim) - comment = wr_ardecls(outfile, var->vdim, - var->vtype == TYCHAR && ISICON(var->vleng) - ? var->vleng->constblock.Const.ci : 1L); - else if (var -> vtype == TYCHAR && var -> vclass != CLPROC && - ISICON ((var -> vleng))) - nice_printf (outfile, "[%ld]", - var -> vleng -> constblock.Const.ci); - - if (comment) - nice_printf (outfile, "%s", comment); - did_one = 1; - last_type = type; - } /* for this_var */ - - if (did_one) - nice_printf (outfile, ";\n"); -} /* wr_struct */ - - - char * -#ifdef KR_headers -user_label(stateno) - ftnint stateno; -#else -user_label(ftnint stateno) -#endif -{ - static char buf[USER_LABEL_MAX + 1]; - static char *Lfmt[2] = { "L_%ld", "L%ld" }; - - if (stateno >= 0) - sprintf(buf, Lfmt[shiftcase], stateno); - else - sprintf(buf, "L_%s", extsymtab[-1-stateno].fextname); - return buf; -} /* user_label */ - - - char * -#ifdef KR_headers -temp_name(starter, num, storage) - char *starter; - int num; - char *storage; -#else -temp_name(char *starter, int num, char *storage) -#endif -{ - static char buf[IDENT_LEN]; - char *pointer = buf; - char *prefix = "t"; - - if (storage) - pointer = storage; - - if (starter && *starter) - prefix = starter; - - sprintf (pointer, "%s__%d", prefix, num); - return pointer; -} /* temp_name */ - - - char * -#ifdef KR_headers -equiv_name(memno, store) - int memno; - char *store; -#else -equiv_name(int memno, char *store) -#endif -{ - static char buf[IDENT_LEN]; - char *pointer = buf; - - if (store) - pointer = store; - - sprintf (pointer, "%s_%d", EQUIV_INIT_NAME, memno); - return pointer; -} /* equiv_name */ - - void -#ifdef KR_headers -def_commons(of) - FILE *of; -#else -def_commons(FILE *of) -#endif -{ - Extsym *ext; - int c, onefile, Union; - chainp comm; - extern int ext1comm; - FILE *c_filesave = c_file; - - if (ext1comm == 1) { - onefile = 1; - c_file = of; - fprintf(of, "/*>>>'/dev/null'<<<*/\n\ -#ifdef Define_COMMONs\n\ -/*<<</dev/null>>>*/\n"); - } - else - onefile = 0; - for(ext = extsymtab; ext < nextext; ext++) - if (ext->extstg == STGCOMMON - && !ext->extinit && (comm = ext->allextp)) { - sprintf(outbtail, "%scom.c", ext->cextname); - if (onefile) - fprintf(of, "/*>>>'%s'<<<*/\n", - outbtail); - else { - c_file = of = fopen(outbuf,textwrite); - if (!of) - fatalstr("can't open %s", outbuf); - } - fprintf(of, "#include \"f2c.h\"\n"); - if (Ansi == 2) - fprintf(of, - "\n#ifdef __cplusplus\nextern \"C\" {\n#endif\n\n"); - if (comm->nextp) { - Union = 1; - nice_printf(of, "union {\n"); - next_tab(of); - } - else - Union = 0; - for(c = 1; comm; comm = comm->nextp) { - nice_printf(of, "struct {\n"); - next_tab(of); - wr_struct(of, (chainp)comm->datap); - prev_tab(of); - if (Union) - nice_printf(of, "} _%d;\n", c++); - } - if (Union) - prev_tab(of); - nice_printf(of, "} %s;\n", ext->cextname); - if (Ansi == 2) - fprintf(of, - "\n#ifdef __cplusplus\n}\n#endif\n"); - if (onefile) - fprintf(of, "/*<<<%s>>>*/\n", outbtail); - else - fclose(of); - } - if (onefile) - fprintf(of, "/*>>>'/dev/null'<<<*/\n#endif\n\ -/*<<</dev/null>>>*/\n"); - c_file = c_filesave; - } - -/* C Language keywords. Needed to filter unwanted fortran identifiers like - * "int", etc. Source: Kernighan & Ritchie, eds. 1 and 2; Stroustrup. - * Also includes C++ keywords and types used for I/O in f2c.h . - * These keywords must be in alphabetical order (as defined by strcmp()). - */ - -char *c_keywords[] = { - "Long", "Multitype", "Namelist", "Vardesc", "abs", "acos", - "addr", "address", "aerr", "alist", "asin", "asm", "atan", - "atan2", "aunit", "auto", "break", "c", "case", "catch", "cerr", - "char", "ciend", "cierr", "cifmt", "cilist", "cirec", "ciunit", - "class", "cllist", "complex", "const", "continue", "cos", - "cosh", "csta", "cunit", "d", "dabs", "default", "defined", - "delete", "dims", "dmax", "dmin", "do", "double", - "doublecomplex", "doublereal", "else", "entry", "enum", "exp", - "extern", "far", "flag", "float", "for", "friend", "ftnint", - "ftnlen", "goto", "h", "huge", "i", "iciend", "icierr", - "icifmt", "icilist", "icirlen", "icirnum", "iciunit", "if", - "inacc", "inacclen", "inblank", "inblanklen", "include", - "indir", "indirlen", "inerr", "inex", "infile", "infilen", - "infmt", "infmtlen", "inform", "informlen", "inline", "inlist", - "inname", "innamed", "innamlen", "innrec", "innum", "inopen", - "inrecl", "inseq", "inseqlen", "int", "integer", "integer1", - "inunf", "inunflen", "inunit", "log", "logical", "logical1", - "long", "longint", "max", "min", "name", "near", "new", "nvars", - "oacc", "oblnk", "oerr", "ofm", "ofnm", "ofnmlen", "olist", - "operator", "orl", "osta", "ounit", "overload", "private", - "protected", "public", "r", "real", "register", "return", - "short", "shortint", "shortlogical", "signed", "sin", "sinh", - "sizeof", "sqrt", "static", "struct", "switch", "tan", "tanh", - "template", "this", "try", "type", "typedef", "uinteger", - "ulongint", "union", "unsigned", "vars", "virtual", "void", - "volatile", "while", "z" - }; /* c_keywords */ - -int n_keywords = sizeof(c_keywords)/sizeof(char *); diff --git a/usr.bin/f2c/names.h b/usr.bin/f2c/names.h deleted file mode 100644 index 16bcc0b4bad4..000000000000 --- a/usr.bin/f2c/names.h +++ /dev/null @@ -1,19 +0,0 @@ -#define CONST_IDENT_MAX 30 -#define IO_IDENT_MAX 30 -#define ARGUMENT_MAX 30 -#define USER_LABEL_MAX 30 - -#define EQUIV_INIT_NAME "equiv" - -#define write_nv_ident(fp,a) wr_nv_ident_help ((fp), (struct Addrblock *) (a)) -#define nv_type(x) nv_type_help ((struct Addrblock *) x) - -extern char *c_keywords[]; - -char* c_type_decl Argdcl((int, int)); -void declare_new_addr Argdcl((Addrp)); -char* new_arg_length Argdcl((Namep)); -char* new_func_length Argdcl((void)); -int nv_type_help Argdcl((Addrp)); -char* temp_name Argdcl((char*, int, char*)); -char* user_label Argdcl((long int)); diff --git a/usr.bin/f2c/niceprintf.c b/usr.bin/f2c/niceprintf.c deleted file mode 100644 index e2d3825e4aae..000000000000 --- a/usr.bin/f2c/niceprintf.c +++ /dev/null @@ -1,445 +0,0 @@ -/**************************************************************** -Copyright 1990, 1991, 1993, 1994 by AT&T, Lucent Technologies and Bellcore. - -Permission to use, copy, modify, and distribute this software -and its documentation for any purpose and without fee is hereby -granted, provided that the above copyright notice appear in all -copies and that both that the copyright notice and this -permission notice and warranty disclaimer appear in supporting -documentation, and that the names of AT&T, Bell Laboratories, -Lucent or Bellcore or any of their entities not be used in -advertising or publicity pertaining to distribution of the -software without specific, written prior permission. - -AT&T, Lucent and Bellcore disclaim all warranties with regard to -this software, including all implied warranties of -merchantability and fitness. In no event shall AT&T, Lucent or -Bellcore be liable for any special, indirect or consequential -damages or any damages whatsoever resulting from loss of use, -data or profits, whether in an action of contract, negligence or -other tortious action, arising out of or in connection with the -use or performance of this software. -****************************************************************/ - -#include "defs.h" -#include "names.h" -#include "output.h" -#ifndef KR_headers -#include "stdarg.h" -#endif - -#define TOO_LONG_INDENT (2 * tab_size) -#define MAX_INDENT 44 -#define MIN_INDENT 22 -static int last_was_newline = 0; -int sharp_line = 0; -int indent = 0; -int in_comment = 0; -int in_define = 0; - extern int gflag1; - extern char filename[]; - - static void ind_printf Argdcl((int, FILE*, char*, va_list)); - - static void -#ifdef KR_headers -write_indent(fp, use_indent, extra_indent, start, end) - FILE *fp; - int use_indent; - int extra_indent; - char *start; - char *end; -#else -write_indent(FILE *fp, int use_indent, int extra_indent, char *start, char *end) -#endif -{ - int ind, tab; - - if (sharp_line) { - fprintf(fp, "#line %ld \"%s\"\n", lineno, filename); - sharp_line = 0; - } - if (in_define == 1) { - in_define = 2; - use_indent = 0; - } - if (last_was_newline && use_indent) { - if (*start == '\n') do { - putc('\n', fp); - if (++start > end) - return; - } - while(*start == '\n'); - - ind = indent <= MAX_INDENT - ? indent - : MIN_INDENT + indent % (MAX_INDENT - MIN_INDENT); - - tab = ind + extra_indent; - - while (tab > 7) { - putc ('\t', fp); - tab -= 8; - } /* while */ - - while (tab-- > 0) - putc (' ', fp); - } /* if last_was_newline */ - - while (start <= end) - putc (*start++, fp); -} /* write_indent */ - -#ifdef KR_headers -/*VARARGS2*/ - void - margin_printf (fp, a, b, c, d, e, f, g) - FILE *fp; - char *a; - long b, c, d, e, f, g; -{ - ind_printf (0, fp, a, b, c, d, e, f, g); -} /* margin_printf */ - -/*VARARGS2*/ - void - nice_printf (fp, a, b, c, d, e, f, g) - FILE *fp; - char *a; - long b, c, d, e, f, g; -{ - ind_printf (1, fp, a, b, c, d, e, f, g); -} /* nice_printf */ -#define SPRINTF(x,a,b,c,d,e,f,g) sprintf(x,a,b,c,d,e,f,g) - -#else /* if (!defined(KR_HEADERS)) */ - -#define SPRINTF(x,a,b,c,d,e,f,g) vsprintf(x,a,ap) - - void - margin_printf(FILE *fp, char *fmt, ...) -{ - va_list ap; - va_start(ap,fmt); - ind_printf(0, fp, fmt, ap); - va_end(ap); - } - - void - nice_printf(FILE *fp, char *fmt, ...) -{ - va_list ap; - va_start(ap,fmt); - ind_printf(1, fp, fmt, ap); - va_end(ap); - } -#endif - -#define max_line_len c_output_line_length - /* 74Number of characters allowed on an output - line. This assumes newlines are handled - nicely, i.e. a newline after a full text - line on a terminal is ignored */ - -/* output_buf holds the text of the next line to be printed. It gets - flushed when a newline is printed. next_slot points to the next - available location in the output buffer, i.e. where the next call to - nice_printf will have its output stored */ - -static char *output_buf; -static char *next_slot; -static char *string_start; - -static char *word_start = NULL; -static int cursor_pos = 0; -static int In_string = 0; - - void -np_init(Void) -{ - next_slot = output_buf = Alloc(MAX_OUTPUT_SIZE); - memset(output_buf, 0, MAX_OUTPUT_SIZE); - } - - static char * -#ifdef KR_headers -adjust_pointer_in_string(pointer) - register char *pointer; -#else -adjust_pointer_in_string(register char *pointer) -#endif -{ - register char *s, *s1, *se, *s0; - - /* arrange not to break \002 */ - s1 = string_start ? string_start : output_buf; - for(s = s1; s < pointer; s++) { - s0 = s1; - s1 = s; - if (*s == '\\') { - se = s++ + 4; - if (se > pointer) - break; - if (*s < '0' || *s > '7') - continue; - while(++s < se) - if (*s < '0' || *s > '7') - break; - --s; - } - } - return s0 - 1; - } - -/* ANSI says strcpy's behavior is undefined for overlapping args, - * so we roll our own fwd_strcpy: */ - - static void -#ifdef KR_headers -fwd_strcpy(t, s) - register char *t; - register char *s; -#else -fwd_strcpy(register char *t, register char *s) -#endif -{ while(*t++ = *s++); } - -/* isident -- true iff character could belong to a unit. C allows - letters, numbers and underscores in identifiers. This also doubles as - a check for numeric constants, since we include the decimal point and - minus sign. The minus has to be here, since the constant "10e-2" - cannot be broken up. The '.' also prevents structure references from - being broken, which is a quite acceptable side effect */ - -#define isident(x) (Tr[x] & 1) -#define isntident(x) (!Tr[x]) - - static void -#ifdef KR_headers - ind_printf (use_indent, fp, a, b, c, d, e, f, g) - int use_indent; - FILE *fp; - char *a; - long b, c, d, e, f, g; -#else - ind_printf (int use_indent, FILE *fp, char *a, va_list ap) -#endif -{ - extern int max_line_len; - extern FILEP c_file; - extern char tr_tab[]; /* in output.c */ - register char *Tr = tr_tab; - int ch, cmax, inc, ind; - static int extra_indent, last_indent, set_cursor = 1; - - cursor_pos += indent - last_indent; - last_indent = indent; - SPRINTF (next_slot, a, b, c, d, e, f, g); - - if (fp != c_file) { - fprintf (fp,"%s", next_slot); - return; - } /* if fp != c_file */ - - do { - char *pointer; - -/* The for loop will parse one output line */ - - if (set_cursor) { - ind = indent <= MAX_INDENT - ? indent - : MIN_INDENT + indent % (MAX_INDENT - MIN_INDENT); - cursor_pos = extra_indent; - if (use_indent) - cursor_pos += ind; - set_cursor = 0; - } - if (in_comment) { - cmax = max_line_len + 32; /* let comments be wider */ - for (pointer = next_slot; *pointer && *pointer != '\n' && - cursor_pos <= cmax; pointer++) - cursor_pos++; - } - else - for (pointer = next_slot; *pointer && *pointer != '\n' && - cursor_pos <= max_line_len; pointer++) { - - /* Update state variables here */ - - if (In_string) { - switch(*pointer) { - case '\\': - if (++cursor_pos > max_line_len) { - cursor_pos -= 2; - --pointer; - goto overflow; - } - ++pointer; - break; - case '"': - In_string = 0; - word_start = 0; - } - } - else switch (*pointer) { - case '"': - if (cursor_pos + 5 > max_line_len) { - word_start = 0; - --pointer; - goto overflow; - } - In_string = 1; - string_start = word_start = pointer; - break; - case '\'': - if (pointer[1] == '\\') - if ((ch = pointer[2]) >= '0' && ch <= '7') - for(inc = 3; pointer[inc] != '\'' - && ++inc < 5;); - else - inc = 3; - else - inc = 2; - /*debug*/ if (pointer[inc] != '\'') - /*debug*/ fatalstr("Bad character constant %.10s", - pointer); - if ((cursor_pos += inc) > max_line_len) { - cursor_pos -= inc; - word_start = 0; - --pointer; - goto overflow; - } - word_start = pointer; - pointer += inc; - break; - case '\t': - cursor_pos = 8 * ((cursor_pos + 8) / 8) - 1; - break; - default: { - -/* HACK Assumes that all characters in an atomic C token will be written - at the same time. Must check for tokens first, since '-' is considered - part of an identifier; checking isident first would mean breaking up "->" */ - - if (word_start) { - if (isntident(*(unsigned char *)pointer)) - word_start = NULL; - } - else if (isident(*(unsigned char *)pointer)) - word_start = pointer; - break; - } /* default */ - } /* switch */ - cursor_pos++; - } /* for pointer = next_slot */ - overflow: - if (*pointer == '\0') { - -/* The output line is not complete, so break out and don't output - anything. The current line fragment will be stored in the buffer */ - - next_slot = pointer; - break; - } else { - char last_char; - int in_string0 = In_string; - -/* If the line was too long, move pointer back to the character before - the current word. This allows line breaking on word boundaries. Make - sure that 80 character comment lines get broken up somehow. We assume - that any non-string 80 character identifier must be in a comment. -*/ - - if (*pointer == '\n') - in_define = 0; - else if (word_start && word_start > output_buf) - if (In_string) - if (string_start && pointer - string_start < 5) - pointer = string_start - 1; - else { - pointer = adjust_pointer_in_string(pointer); - string_start = 0; - } - else if (word_start == string_start - && pointer - string_start >= 5) { - pointer = adjust_pointer_in_string(next_slot); - In_string = 1; - string_start = 0; - } - else - pointer = word_start - 1; - else if (cursor_pos > max_line_len) { -#ifndef ANSI_Libraries - extern char *strchr(); -#endif - if (In_string) { - pointer = adjust_pointer_in_string(pointer); - if (string_start && pointer > string_start) - string_start = 0; - } - else if (strchr("&*+-/<=>|", *pointer) - && strchr("!%&*+-/<=>^|", pointer[-1])) { - pointer -= 2; - if (strchr("<>", *pointer)) /* <<=, >>= */ - pointer--; - } - else { - if (word_start) - while(isident(*(unsigned char *)pointer)) - pointer++; - pointer--; - } - } - last_char = *pointer; - write_indent(fp, use_indent, extra_indent, output_buf, pointer); - next_slot = output_buf; - if (In_string && !string_start && Ansi == 1 && last_char != '\n') - *next_slot++ = '"'; - fwd_strcpy(next_slot, pointer + 1); - -/* insert a line break */ - - if (last_char == '\n') { - if (In_string) - last_was_newline = 0; - else { - last_was_newline = 1; - extra_indent = 0; - sharp_line = gflag1; - } - } - else { - extra_indent = TOO_LONG_INDENT; - if (In_string && !string_start) { - if (Ansi == 1) { - fprintf(fp, gflag1 ? "\"\\\n" : "\"\n"); - use_indent = 1; - last_was_newline = 1; - } - else { - fprintf(fp, "\\\n"); - last_was_newline = 0; - } - In_string = in_string0; - } - else { - if (in_define/* | gflag1*/) - putc('\\', fp); - putc ('\n', fp); - last_was_newline = 1; - } - } /* if *pointer != '\n' */ - - if (In_string && Ansi != 1 && !string_start) - cursor_pos = 0; - else - set_cursor = 1; - - string_start = word_start = NULL; - - } /* else */ - - } while (*next_slot); - -} /* ind_printf */ diff --git a/usr.bin/f2c/niceprintf.h b/usr.bin/f2c/niceprintf.h deleted file mode 100644 index 24c65d4db0c4..000000000000 --- a/usr.bin/f2c/niceprintf.h +++ /dev/null @@ -1,16 +0,0 @@ -/* niceprintf.h -- contains constants and macros from the output filter - for the generated C code. We use macros for increased speed, less - function overhead. */ - -#define MAX_OUTPUT_SIZE 6000 /* Number of chars on one output line PLUS - the length of the longest string - printed using nice_printf */ - - - -#define next_tab(fp) (indent += tab_size) - -#define prev_tab(fp) (indent -= tab_size) - - - diff --git a/usr.bin/f2c/output.c b/usr.bin/f2c/output.c deleted file mode 100644 index 5f650e7d9795..000000000000 --- a/usr.bin/f2c/output.c +++ /dev/null @@ -1,1711 +0,0 @@ -/**************************************************************** -Copyright 1990 - 1996 by AT&T, Lucent Technologies and Bellcore. - -Permission to use, copy, modify, and distribute this software -and its documentation for any purpose and without fee is hereby -granted, provided that the above copyright notice appear in all -copies and that both that the copyright notice and this -permission notice and warranty disclaimer appear in supporting -documentation, and that the names of AT&T, Bell Laboratories, -Lucent or Bellcore or any of their entities not be used in -advertising or publicity pertaining to distribution of the -software without specific, written prior permission. - -AT&T, Lucent and Bellcore disclaim all warranties with regard to -this software, including all implied warranties of -merchantability and fitness. In no event shall AT&T, Lucent or -Bellcore be liable for any special, indirect or consequential -damages or any damages whatsoever resulting from loss of use, -data or profits, whether in an action of contract, negligence or -other tortious action, arising out of or in connection with the -use or performance of this software. -****************************************************************/ - -#include "defs.h" -#include "names.h" -#include "output.h" - -#ifndef TRUE -#define TRUE 1 -#endif -#ifndef FALSE -#define FALSE 0 -#endif - -char _assoc_table[] = { 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0 }; - -/* Opcode table -- This array is indexed by the OP_____ macros defined in - defines.h; these macros are expected to be adjacent integers, so that - this table is as small as possible. */ - -table_entry opcode_table[] = { - { 0, 0, NULL }, - /* OPPLUS 1 */ { BINARY_OP, 12, "%l + %r" }, - /* OPMINUS 2 */ { BINARY_OP, 12, "%l - %r" }, - /* OPSTAR 3 */ { BINARY_OP, 13, "%l * %r" }, - /* OPSLASH 4 */ { BINARY_OP, 13, "%l / %r" }, - /* OPPOWER 5 */ { BINARY_OP, 0, "power (%l, %r)" }, - /* OPNEG 6 */ { UNARY_OP, 14, "-%l" }, - /* OPOR 7 */ { BINARY_OP, 4, "%l || %r" }, - /* OPAND 8 */ { BINARY_OP, 5, "%l && %r" }, - /* OPEQV 9 */ { BINARY_OP, 9, "%l == %r" }, - /* OPNEQV 10 */ { BINARY_OP, 9, "%l != %r" }, - /* OPNOT 11 */ { UNARY_OP, 14, "! %l" }, - /* OPCONCAT 12 */ { BINARY_OP, 0, "concat (%l, %r)" }, - /* OPLT 13 */ { BINARY_OP, 10, "%l < %r" }, - /* OPEQ 14 */ { BINARY_OP, 9, "%l == %r" }, - /* OPGT 15 */ { BINARY_OP, 10, "%l > %r" }, - /* OPLE 16 */ { BINARY_OP, 10, "%l <= %r" }, - /* OPNE 17 */ { BINARY_OP, 9, "%l != %r" }, - /* OPGE 18 */ { BINARY_OP, 10, "%l >= %r" }, - /* OPCALL 19 */ { BINARY_OP, 15, SPECIAL_FMT }, - /* OPCCALL 20 */ { BINARY_OP, 15, SPECIAL_FMT }, - -/* Left hand side of an assignment cannot have outermost parens */ - - /* OPASSIGN 21 */ { BINARY_OP, 2, "%l = %r" }, - /* OPPLUSEQ 22 */ { BINARY_OP, 2, "%l += %r" }, - /* OPSTAREQ 23 */ { BINARY_OP, 2, "%l *= %r" }, - /* OPCONV 24 */ { BINARY_OP, 14, "%l" }, - /* OPLSHIFT 25 */ { BINARY_OP, 11, "%l << %r" }, - /* OPMOD 26 */ { BINARY_OP, 13, "%l %% %r" }, - /* OPCOMMA 27 */ { BINARY_OP, 1, "%l, %r" }, - -/* Don't want to nest the colon operator in parens */ - - /* OPQUEST 28 */ { BINARY_OP, 3, "%l ? %r" }, - /* OPCOLON 29 */ { BINARY_OP, 3, "%l : %r" }, - /* OPABS 30 */ { UNARY_OP, 0, "abs(%l)" }, - /* OPMIN 31 */ { BINARY_OP, 0, SPECIAL_FMT }, - /* OPMAX 32 */ { BINARY_OP, 0, SPECIAL_FMT }, - /* OPADDR 33 */ { UNARY_OP, 14, "&%l" }, - - /* OPCOMMA_ARG 34 */ { BINARY_OP, 15, SPECIAL_FMT }, - /* OPBITOR 35 */ { BINARY_OP, 6, "%l | %r" }, - /* OPBITAND 36 */ { BINARY_OP, 8, "%l & %r" }, - /* OPBITXOR 37 */ { BINARY_OP, 7, "%l ^ %r" }, - /* OPBITNOT 38 */ { UNARY_OP, 14, "~ %l" }, - /* OPRSHIFT 39 */ { BINARY_OP, 11, "%l >> %r" }, - -/* This isn't quite right -- it doesn't handle arrays, for instance */ - - /* OPWHATSIN 40 */ { UNARY_OP, 14, "*%l" }, - /* OPMINUSEQ 41 */ { BINARY_OP, 2, "%l -= %r" }, - /* OPSLASHEQ 42 */ { BINARY_OP, 2, "%l /= %r" }, - /* OPMODEQ 43 */ { BINARY_OP, 2, "%l %%= %r" }, - /* OPLSHIFTEQ 44 */ { BINARY_OP, 2, "%l <<= %r" }, - /* OPRSHIFTEQ 45 */ { BINARY_OP, 2, "%l >>= %r" }, - /* OPBITANDEQ 46 */ { BINARY_OP, 2, "%l &= %r" }, - /* OPBITXOREQ 47 */ { BINARY_OP, 2, "%l ^= %r" }, - /* OPBITOREQ 48 */ { BINARY_OP, 2, "%l |= %r" }, - /* OPPREINC 49 */ { UNARY_OP, 14, "++%l" }, - /* OPPREDEC 50 */ { UNARY_OP, 14, "--%l" }, - /* OPDOT 51 */ { BINARY_OP, 15, "%l.%r" }, - /* OPARROW 52 */ { BINARY_OP, 15, "%l -> %r"}, - /* OPNEG1 53 */ { UNARY_OP, 14, "-%l" }, - /* OPDMIN 54 */ { BINARY_OP, 0, "dmin(%l,%r)" }, - /* OPDMAX 55 */ { BINARY_OP, 0, "dmax(%l,%r)" }, - /* OPASSIGNI 56 */ { BINARY_OP, 2, "%l = &%r" }, - /* OPIDENTITY 57 */ { UNARY_OP, 15, "%l" }, - /* OPCHARCAST 58 */ { UNARY_OP, 14, "(char *)&%l" }, - /* OPDABS 59 */ { UNARY_OP, 0, "dabs(%l)" }, - /* OPMIN2 60 */ { BINARY_OP, 0, "min(%l,%r)" }, - /* OPMAX2 61 */ { BINARY_OP, 0, "max(%l,%r)" }, - /* OPBITTEST 62 */ { BINARY_OP, 0, "bit_test(%l,%r)" }, - /* OPBITCLR 63 */ { BINARY_OP, 0, "bit_clear(%l,%r)" }, - /* OPBITSET 64 */ { BINARY_OP, 0, "bit_set(%l,%r)" }, -#ifdef TYQUAD - /* OPQBITCLR 65 */ { BINARY_OP, 0, "qbit_clear(%l,%r)" }, - /* OPQBITSET 66 */ { BINARY_OP, 0, "qbit_set(%l,%r)" }, -#endif - -/* kludge to imitate (under forcedouble) f77's bizarre treatement of OPNEG... */ - - /* OPNEG KLUDGE */ { UNARY_OP, 14, "-(doublereal)%l" } -}; /* opcode_table */ - -#define OPNEG_KLUDGE (sizeof(opcode_table)/sizeof(table_entry) - 1) - -extern int dneg; -static char opeqable[sizeof(opcode_table)/sizeof(table_entry)]; - - -static void output_arg_list Argdcl((FILEP, struct Listblock*)); -static void output_binary Argdcl((FILEP, Exprp)); -static void output_list Argdcl((FILEP, struct Listblock*)); -static void output_literal Argdcl((FILEP, long, Constp)); -static void output_prim Argdcl((FILEP, struct Primblock*)); -static void output_unary Argdcl((FILEP, Exprp)); - - - void -#ifdef KR_headers -expr_out(fp, e) - FILE *fp; - expptr e; -#else -expr_out(FILE *fp, expptr e) -#endif -{ - if (e == (expptr) NULL) - return; - - switch (e -> tag) { - case TNAME: out_name (fp, (struct Nameblock *) e); - return; - - case TCONST: out_const(fp, &e->constblock); - goto end_out; - case TEXPR: - break; - - case TADDR: out_addr (fp, &(e -> addrblock)); - goto end_out; - - case TPRIM: if (!nerr) - warn ("expr_out: got TPRIM"); - output_prim (fp, &(e -> primblock)); - return; - - case TLIST: output_list (fp, &(e -> listblock)); - end_out: frexpr(e); - return; - - case TIMPLDO: err ("expr_out: got TIMPLDO"); - return; - - case TERROR: - default: - erri ("expr_out: bad tag '%d'", e -> tag); - } /* switch */ - -/* Now we know that the tag is TEXPR */ - -/* Optimize on simple expressions, such as "a = a + b" ==> "a += b" */ - - if (e -> exprblock.opcode == OPASSIGN && e -> exprblock.rightp && - e -> exprblock.rightp -> tag == TEXPR) { - int opcode; - - opcode = e -> exprblock.rightp -> exprblock.opcode; - - if (opeqable[opcode]) { - expptr leftp, rightp; - - if ((leftp = e -> exprblock.leftp) && - (rightp = e -> exprblock.rightp -> exprblock.leftp)) { - - if (same_ident (leftp, rightp)) { - expptr temp = e -> exprblock.rightp; - - e -> exprblock.opcode = op_assign(opcode); - - e -> exprblock.rightp = temp -> exprblock.rightp; - temp->exprblock.rightp = 0; - frexpr(temp); - } /* if same_ident (leftp, rightp) */ - } /* if leftp && rightp */ - } /* if opcode == OPPLUS || */ - } /* if e -> exprblock.opcode == OPASSIGN */ - - -/* Optimize on increment or decrement by 1 */ - - { - int opcode = e -> exprblock.opcode; - expptr leftp = e -> exprblock.leftp; - expptr rightp = e -> exprblock.rightp; - - if (leftp && rightp && (leftp -> headblock.vstg == STGARG || - ISINT (leftp -> headblock.vtype)) && - (opcode == OPPLUSEQ || opcode == OPMINUSEQ) && - ISINT (rightp -> headblock.vtype) && - ISICON (e -> exprblock.rightp) && - (ISONE (e -> exprblock.rightp) || - e -> exprblock.rightp -> constblock.Const.ci == -1)) { - -/* Allow for the '-1' constant value */ - - if (!ISONE (e -> exprblock.rightp)) - opcode = (opcode == OPPLUSEQ) ? OPMINUSEQ : OPPLUSEQ; - -/* replace the existing opcode */ - - if (opcode == OPPLUSEQ) - e -> exprblock.opcode = OPPREINC; - else - e -> exprblock.opcode = OPPREDEC; - -/* Free up storage used by the right hand side */ - - frexpr (e -> exprblock.rightp); - e->exprblock.rightp = 0; - } /* if opcode == OPPLUS */ - } /* block */ - - - if (is_unary_op (e -> exprblock.opcode)) - output_unary (fp, &(e -> exprblock)); - else if (is_binary_op (e -> exprblock.opcode)) - output_binary (fp, &(e -> exprblock)); - else - erri ("expr_out: bad opcode '%d'", (int) e -> exprblock.opcode); - - free((char *)e); - -} /* expr_out */ - - - void -#ifdef KR_headers -out_and_free_statement(outfile, expr) - FILE *outfile; - expptr expr; -#else -out_and_free_statement(FILE *outfile, expptr expr) -#endif -{ - if (expr) - expr_out (outfile, expr); - - nice_printf (outfile, ";\n"); -} /* out_and_free_statement */ - - - - int -#ifdef KR_headers -same_ident(left, right) - expptr left; - expptr right; -#else -same_ident(expptr left, expptr right) -#endif -{ - if (!left || !right) - return 0; - - if (left -> tag == TNAME && right -> tag == TNAME && left == right) - return 1; - - if (left -> tag == TADDR && right -> tag == TADDR && - left -> addrblock.uname_tag == right -> addrblock.uname_tag) - switch (left -> addrblock.uname_tag) { - case UNAM_REF: - case UNAM_NAME: - -/* Check for array subscripts */ - - if (left -> addrblock.user.name -> vdim || - right -> addrblock.user.name -> vdim) - if (left -> addrblock.user.name != - right -> addrblock.user.name || - !same_expr (left -> addrblock.memoffset, - right -> addrblock.memoffset)) - return 0; - - return same_ident ((expptr) (left -> addrblock.user.name), - (expptr) right -> addrblock.user.name); - case UNAM_IDENT: - return strcmp(left->addrblock.user.ident, - right->addrblock.user.ident) == 0; - case UNAM_CHARP: - return strcmp(left->addrblock.user.Charp, - right->addrblock.user.Charp) == 0; - default: - return 0; - } /* switch */ - - if (left->tag == TEXPR && left->exprblock.opcode == OPWHATSIN - && right->tag == TEXPR && right->exprblock.opcode == OPWHATSIN) - return same_ident(left->exprblock.leftp, - right->exprblock.leftp); - - return 0; -} /* same_ident */ - - static int -#ifdef KR_headers -samefpconst(c1, c2, n) - register Constp c1; - register Constp c2; - register int n; -#else -samefpconst(register Constp c1, register Constp c2, register int n) -#endif -{ - char *s1, *s2; - if (!c1->vstg && !c2->vstg) - return c1->Const.cd[n] == c2->Const.cd[n]; - s1 = c1->vstg ? c1->Const.cds[n] : dtos(c1->Const.cd[n]); - s2 = c2->vstg ? c2->Const.cds[n] : dtos(c2->Const.cd[n]); - return !strcmp(s1, s2); - } - - static int -#ifdef KR_headers -sameconst(c1, c2) - register Constp c1; - register Constp c2; -#else -sameconst(register Constp c1, register Constp c2) -#endif -{ - switch(c1->vtype) { - case TYCOMPLEX: - case TYDCOMPLEX: - if (!samefpconst(c1,c2,1)) - return 0; - case TYREAL: - case TYDREAL: - return samefpconst(c1,c2,0); - case TYCHAR: - return c1->Const.ccp1.blanks == c2->Const.ccp1.blanks - && c1->vleng->constblock.Const.ci - == c2->vleng->constblock.Const.ci - && !memcmp(c1->Const.ccp, c2->Const.ccp, - (int)c1->vleng->constblock.Const.ci); - case TYSHORT: - case TYINT: - case TYLOGICAL: - return c1->Const.ci == c2->Const.ci; - } - err("unexpected type in sameconst"); - return 0; - } - -/* same_expr -- Returns true only if e1 and e2 match. This is - somewhat pessimistic, but can afford to be because it's just used to - optimize on the assignment operators (+=, -=, etc). */ - - int -#ifdef KR_headers -same_expr(e1, e2) - expptr e1; - expptr e2; -#else -same_expr(expptr e1, expptr e2) -#endif -{ - if (!e1 || !e2) - return !e1 && !e2; - - if (e1 -> tag != e2 -> tag || e1 -> headblock.vtype != e2 -> headblock.vtype) - return 0; - - switch (e1 -> tag) { - case TEXPR: - if (e1 -> exprblock.opcode != e2 -> exprblock.opcode) - return 0; - - return same_expr (e1 -> exprblock.leftp, e2 -> exprblock.leftp) && - same_expr (e1 -> exprblock.rightp, e2 -> exprblock.rightp); - case TNAME: - case TADDR: - return same_ident (e1, e2); - case TCONST: - return sameconst(&e1->constblock, &e2->constblock); - default: - return 0; - } /* switch */ -} /* same_expr */ - - - - void -#ifdef KR_headers -out_name(fp, namep) - FILE *fp; - Namep namep; -#else -out_name(FILE *fp, Namep namep) -#endif -{ - extern int usedefsforcommon; - Extsym *comm; - - if (namep == NULL) - return; - -/* DON'T want to use oneof_stg() here; need to find the right common name - */ - - if (namep->vstg == STGCOMMON && !namep->vcommequiv && !usedefsforcommon) { - comm = &extsymtab[namep->vardesc.varno]; - extern_out(fp, comm); - nice_printf(fp, "%d.", comm->curno); - } /* if namep -> vstg == STGCOMMON */ - - if (namep->vprocclass == PTHISPROC && namep->vtype != TYSUBR) - nice_printf(fp, xretslot[namep->vtype]->user.ident); - else - nice_printf (fp, "%s", namep->cvarname); -} /* out_name */ - - -#define cpd(n) cp->vstg ? cp->Const.cds[n] : dtos(cp->Const.cd[n]) - - void -#ifdef KR_headers -out_const(fp, cp) - FILE *fp; - register Constp cp; -#else -out_const(FILE *fp, register Constp cp) -#endif -{ - static char real_buf[50], imag_buf[50]; - unsigned int k; - int type = cp->vtype; - - switch (type) { - case TYINT1: - case TYSHORT: - nice_printf (fp, "%ld", cp->Const.ci); /* don't cast ci! */ - break; - case TYLONG: -#ifdef TYQUAD - case TYQUAD: -#endif - nice_printf (fp, "%ld", cp->Const.ci); /* don't cast ci! */ - break; - case TYREAL: - nice_printf(fp, "%s", flconst(real_buf, cpd(0))); - break; - case TYDREAL: - nice_printf(fp, "%s", cpd(0)); - break; - case TYCOMPLEX: - nice_printf(fp, cm_fmt_string, flconst(real_buf, cpd(0)), - flconst(imag_buf, cpd(1))); - break; - case TYDCOMPLEX: - nice_printf(fp, dcm_fmt_string, cpd(0), cpd(1)); - break; - case TYLOGICAL1: - case TYLOGICAL2: - case TYLOGICAL: - nice_printf (fp, "%s", cp->Const.ci ? "TRUE_" : "FALSE_"); - break; - case TYCHAR: { - char *c = cp->Const.ccp, *ce; - - if (c == NULL) { - nice_printf (fp, "\"\""); - break; - } /* if c == NULL */ - - nice_printf (fp, "\""); - ce = c + cp->vleng->constblock.Const.ci; - while(c < ce) { - k = *(unsigned char *)c++; - nice_printf(fp, str_fmt[k], k); - } - for(k = cp->Const.ccp1.blanks; k > 0; k--) - nice_printf(fp, " "); - nice_printf (fp, "\""); - break; - } /* case TYCHAR */ - default: - erri ("out_const: bad type '%d'", (int) type); - break; - } /* switch */ - -} /* out_const */ -#undef cpd - - static void -#ifdef KR_headers -out_args(fp, ep) - FILE *fp; - expptr ep; -#else -out_args(FILE *fp, expptr ep) -#endif -{ - chainp arglist; - - if(ep->tag != TLIST) - badtag("out_args", ep->tag); - for(arglist = ep->listblock.listp;;) { - expr_out(fp, (expptr)arglist->datap); - arglist->datap = 0; - if (!(arglist = arglist->nextp)) - break; - nice_printf(fp, ", "); - } - } - - -/* out_addr -- this routine isn't local because it is called by the - system-generated identifier printing routines */ - - void -#ifdef KR_headers -out_addr(fp, addrp) - FILE *fp; - struct Addrblock *addrp; -#else -out_addr(FILE *fp, struct Addrblock *addrp) -#endif -{ - extern Extsym *extsymtab; - int was_array = 0; - char *s; - - - if (addrp == NULL) - return; - if (doin_setbound - && addrp->vstg == STGARG - && addrp->vtype != TYCHAR - && ISICON(addrp->memoffset) - && !addrp->memoffset->constblock.Const.ci) - nice_printf(fp, "*"); - - switch (addrp -> uname_tag) { - case UNAM_REF: - nice_printf(fp, "%s_%s(", addrp->user.name->cvarname, - addrp->cmplx_sub ? "subscr" : "ref"); - out_args(fp, addrp->memoffset); - nice_printf(fp, ")"); - return; - case UNAM_NAME: - out_name (fp, addrp -> user.name); - break; - case UNAM_IDENT: - if (*(s = addrp->user.ident) == ' ') { - if (multitype) - nice_printf(fp, "%s", - xretslot[addrp->vtype]->user.ident); - else - nice_printf(fp, "%s", s+1); - } - else { - nice_printf(fp, "%s", s); - } - break; - case UNAM_CHARP: - nice_printf(fp, "%s", addrp->user.Charp); - break; - case UNAM_EXTERN: - extern_out (fp, &extsymtab[addrp -> memno]); - break; - case UNAM_CONST: - switch(addrp->vstg) { - case STGCONST: - out_const(fp, (Constp)addrp); - break; - case STGMEMNO: - output_literal (fp, addrp->memno, - (Constp)addrp); - break; - default: - Fatal("unexpected vstg in out_addr"); - } - break; - case UNAM_UNKNOWN: - default: - nice_printf (fp, "Unknown Addrp"); - break; - } /* switch */ - -/* It's okay to just throw in the brackets here because they have a - precedence level of 15, the highest value. */ - - if ((addrp->uname_tag == UNAM_NAME && addrp->user.name->vdim - || addrp->ntempelt > 1 || addrp->isarray) - && addrp->vtype != TYCHAR) { - expptr offset; - - was_array = 1; - - offset = addrp -> memoffset; - addrp->memoffset = 0; - if (ONEOF(addrp->vstg, M(STGCOMMON)|M(STGEQUIV)) - && addrp -> uname_tag == UNAM_NAME - && !addrp->skip_offset) - offset = mkexpr (OPMINUS, offset, mkintcon ( - addrp -> user.name -> voffset)); - - nice_printf (fp, "["); - - offset = mkexpr (OPSLASH, offset, - ICON (typesize[addrp -> vtype] * (addrp -> Field ? 2 : 1))); - expr_out (fp, offset); - nice_printf (fp, "]"); - } - -/* Check for structure field reference */ - - if (addrp -> Field && addrp -> uname_tag != UNAM_CONST && - addrp -> uname_tag != UNAM_UNKNOWN) { - if (oneof_stg((addrp -> uname_tag == UNAM_NAME ? addrp -> user.name : - (Namep) NULL), addrp -> vstg, M(STGARG)|M(STGEQUIV)) - && !was_array && (addrp->vclass != CLPROC || !multitype)) - nice_printf (fp, "->%s", addrp -> Field); - else - nice_printf (fp, ".%s", addrp -> Field); - } /* if */ - -/* Check for character subscripting */ - - if (addrp->vtype == TYCHAR && - (addrp->vclass != CLPROC || addrp->uname_tag == UNAM_NAME - && addrp->user.name->vprocclass == PTHISPROC) && - addrp -> memoffset && - (addrp -> uname_tag != UNAM_NAME || - addrp -> user.name -> vtype == TYCHAR) && - (!ISICON (addrp -> memoffset) || - (addrp -> memoffset -> constblock.Const.ci))) { - - int use_paren = 0; - expptr e = addrp -> memoffset; - - if (!e) - return; - addrp->memoffset = 0; - - if (ONEOF(addrp->vstg, M(STGCOMMON)|M(STGEQUIV)) - && addrp -> uname_tag == UNAM_NAME) { - e = mkexpr (OPMINUS, e, mkintcon (addrp -> user.name -> voffset)); - -/* mkexpr will simplify it to zero if possible */ - if (e->tag == TCONST && e->constblock.Const.ci == 0) - return; - } /* if addrp -> vstg == STGCOMMON */ - -/* In the worst case, parentheses might be needed OUTSIDE the expression, - too. But since I think this subscripting can only appear as a - parameter in a procedure call, I don't think outside parens will ever - be needed. INSIDE parens are handled below */ - - nice_printf (fp, " + "); - if (e -> tag == TEXPR) { - int arg_prec = op_precedence (e -> exprblock.opcode); - int prec = op_precedence (OPPLUS); - use_paren = arg_prec && (arg_prec < prec || (arg_prec == prec && - is_left_assoc (OPPLUS))); - } /* if e -> tag == TEXPR */ - if (use_paren) nice_printf (fp, "("); - expr_out (fp, e); - if (use_paren) nice_printf (fp, ")"); - } /* if */ -} /* out_addr */ - - - static void -#ifdef KR_headers -output_literal(fp, memno, cp) - FILE *fp; - long memno; - Constp cp; -#else -output_literal(FILE *fp, long memno, Constp cp) -#endif -{ - struct Literal *litp, *lastlit; - - lastlit = litpool + nliterals; - - for (litp = litpool; litp < lastlit; litp++) { - if (litp -> litnum == memno) - break; - } /* for litp */ - - if (litp >= lastlit) - out_const (fp, cp); - else { - nice_printf (fp, "%s", lit_name (litp)); - litp->lituse++; - } -} /* output_literal */ - - - static void -#ifdef KR_headers -output_prim(fp, primp) - FILE *fp; - struct Primblock *primp; -#else -output_prim(FILE *fp, struct Primblock *primp) -#endif -{ - if (primp == NULL) - return; - - out_name (fp, primp -> namep); - if (primp -> argsp) - output_arg_list (fp, primp -> argsp); - - if (primp -> fcharp != (expptr) NULL || primp -> lcharp != (expptr) NULL) - nice_printf (fp, "Sorry, no substrings yet"); -} - - - - static void -#ifdef KR_headers -output_arg_list(fp, listp) - FILE *fp; - struct Listblock *listp; -#else -output_arg_list(FILE *fp, struct Listblock *listp) -#endif -{ - chainp arg_list; - - if (listp == (struct Listblock *) NULL || listp -> listp == (chainp) NULL) - return; - - nice_printf (fp, "("); - - for (arg_list = listp -> listp; arg_list; arg_list = arg_list -> nextp) { - expr_out (fp, (expptr) arg_list -> datap); - if (arg_list -> nextp != (chainp) NULL) - -/* Might want to add a hook in here to accomodate the style setting which - wants spaces after commas */ - - nice_printf (fp, ","); - } /* for arg_list */ - - nice_printf (fp, ")"); -} /* output_arg_list */ - - - - static void -#ifdef KR_headers -output_unary(fp, e) - FILE *fp; - struct Exprblock *e; -#else -output_unary(FILE *fp, struct Exprblock *e) -#endif -{ - if (e == NULL) - return; - - switch (e -> opcode) { - case OPNEG: - if (e->vtype == TYREAL && dneg) { - e->opcode = OPNEG_KLUDGE; - output_binary(fp,e); - e->opcode = OPNEG; - break; - } - case OPNEG1: - case OPNOT: - case OPABS: - case OPBITNOT: - case OPWHATSIN: - case OPPREINC: - case OPPREDEC: - case OPADDR: - case OPIDENTITY: - case OPCHARCAST: - case OPDABS: - output_binary (fp, e); - break; - case OPCALL: - case OPCCALL: - nice_printf (fp, "Sorry, no OPCALL yet"); - break; - default: - erri ("output_unary: bad opcode", (int) e -> opcode); - break; - } /* switch */ -} /* output_unary */ - - - static char * -#ifdef KR_headers -findconst(m) - register long m; -#else -findconst(register long m) -#endif -{ - register struct Literal *litp, *litpe; - - litp = litpool; - for(litpe = litp + nliterals; litp < litpe; litp++) - if (litp->litnum == m) - return litp->cds[0]; - Fatal("findconst failure!"); - return 0; - } - - static int -#ifdef KR_headers -opconv_fudge(fp, e) - FILE *fp; - struct Exprblock *e; -#else -opconv_fudge(FILE *fp, struct Exprblock *e) -#endif -{ - /* special handling for conversions, ichar and character*1 */ - register expptr lp; - register union Expression *Offset; - register char *cp; - int lt; - char buf[8], *s; - unsigned int k; - Namep np; - Addrp ap; - - if (!(lp = e->leftp)) /* possible with erroneous Fortran */ - return 1; - lt = lp->headblock.vtype; - if (lt == TYCHAR) { - switch(lp->tag) { - case TNAME: - nice_printf(fp, "*(unsigned char *)"); - out_name(fp, (Namep)lp); - return 1; - case TCONST: - tconst: - cp = lp->constblock.Const.ccp; - tconst1: - k = *(unsigned char *)cp; - if (k < 128) { /* ASCII character */ - sprintf(buf, chr_fmt[k], k); - nice_printf(fp, "'%s'", buf); - } - else - nice_printf(fp, "%d", k); - return 1; - case TADDR: - switch(lp->addrblock.vstg) { - case STGMEMNO: - if (halign && e->vtype != TYCHAR) { - nice_printf(fp, "*(%s *)", - c_type_decl(e->vtype,0)); - expr_out(fp, lp); - return 1; - } - cp = findconst(lp->addrblock.memno); - goto tconst1; - case STGCONST: - goto tconst; - } - lp->addrblock.vtype = tyint; - Offset = lp->addrblock.memoffset; - switch(lp->addrblock.uname_tag) { - case UNAM_REF: - nice_printf(fp, "*(unsigned char *)"); - return 0; - case UNAM_NAME: - np = lp->addrblock.user.name; - if (ONEOF(np->vstg, - M(STGCOMMON)|M(STGEQUIV))) - Offset = mkexpr(OPMINUS, Offset, - ICON(np->voffset)); - } - lp->addrblock.memoffset = Offset ? - mkexpr(OPSTAR, Offset, - ICON(typesize[tyint])) - : ICON(0); - lp->addrblock.isarray = 1; - /* STGCOMMON or STGEQUIV would cause */ - /* voffset to be added in a second time */ - lp->addrblock.vstg = STGUNKNOWN; - nice_printf(fp, "*(unsigned char *)&"); - return 0; - default: - badtag("opconv_fudge", lp->tag); - } - } - if (lt != e->vtype) { - s = c_type_decl(e->vtype, 0); - if (ISCOMPLEX(lt)) { - tryagain: - np = (Namep)e->leftp; - switch(np->tag) { - case TNAME: - nice_printf(fp, "(%s) %s%sr", s, - np->cvarname, - np->vstg == STGARG ? "->" : "."); - return 1; - case TADDR: - ap = (Addrp)np; - switch(ap->uname_tag) { - case UNAM_IDENT: - nice_printf(fp, "(%s) %s.r", s, - ap->user.ident); - return 1; - case UNAM_NAME: - nice_printf(fp, "(%s) ", s); - out_addr(fp, ap); - nice_printf(fp, ".r"); - return 1; - } - case TEXPR: - e = (Exprp)np; - if (e->opcode == OPWHATSIN) - goto tryagain; - default: - fatali("Unexpected tag %d in opconv_fudge", - np->tag); - } - } - nice_printf(fp, "(%s) ", s); - } - return 0; - } - - - static void -#ifdef KR_headers -output_binary(fp, e) - FILE *fp; - struct Exprblock *e; -#else -output_binary(FILE *fp, struct Exprblock *e) -#endif -{ - char *format; - extern table_entry opcode_table[]; - int prec; - - if (e == NULL || e -> tag != TEXPR) - return; - -/* Instead of writing a huge switch, I've incorporated the output format - into a table. Things like "%l" and "%r" stand for the left and - right subexpressions. This should allow both prefix and infix - functions to be specified (e.g. "(%l * %r", "z_div (%l, %r"). Of - course, I should REALLY think out the ramifications of writing out - straight text, as opposed to some intermediate format, which could - figure out and optimize on the the number of required blanks (we don't - want "x - (-y)" to become "x --y", for example). Special cases (such as - incomplete implementations) could still be implemented as part of the - switch, they will just have some dummy value instead of the string - pattern. Another difficulty is the fact that the complex functions - will differ from the integer and real ones */ - -/* Handle a special case. We don't want to output "x + - 4", or "y - - 3" -*/ - if ((e -> opcode == OPPLUS || e -> opcode == OPMINUS) && - e -> rightp && e -> rightp -> tag == TCONST && - isnegative_const (&(e -> rightp -> constblock)) && - is_negatable (&(e -> rightp -> constblock))) { - - e -> opcode = (e -> opcode == OPPLUS) ? OPMINUS : OPPLUS; - negate_const (&(e -> rightp -> constblock)); - } /* if e -> opcode == PLUS or MINUS */ - - prec = op_precedence (e -> opcode); - format = op_format (e -> opcode); - - if (format != SPECIAL_FMT) { - while (*format) { - if (*format == '%') { - int arg_prec, use_paren = 0; - expptr lp, rp; - - switch (*(format + 1)) { - case 'l': - lp = e->leftp; - if (lp && lp->tag == TEXPR) { - arg_prec = op_precedence(lp->exprblock.opcode); - - use_paren = arg_prec && - (arg_prec < prec || (arg_prec == prec && - is_right_assoc (prec))); - } /* if e -> leftp */ - if (e->opcode == OPCONV && opconv_fudge(fp,e)) - break; - if (use_paren) - nice_printf (fp, "("); - expr_out(fp, lp); - if (use_paren) - nice_printf (fp, ")"); - break; - case 'r': - rp = e->rightp; - if (rp && rp->tag == TEXPR) { - arg_prec = op_precedence(rp->exprblock.opcode); - - use_paren = arg_prec && - (arg_prec < prec || (arg_prec == prec && - is_left_assoc (prec))); - use_paren = use_paren || - (rp->exprblock.opcode == OPNEG - && prec >= op_precedence(OPMINUS)); - } /* if e -> rightp */ - if (use_paren) - nice_printf (fp, "("); - expr_out(fp, rp); - if (use_paren) - nice_printf (fp, ")"); - break; - case '\0': - case '%': - nice_printf (fp, "%%"); - break; - default: - erri ("output_binary: format err: '%%%c' illegal", - (int) *(format + 1)); - break; - } /* switch */ - format += 2; - } else - nice_printf (fp, "%c", *format++); - } /* while *format */ - } else { - -/* Handle Special cases of formatting */ - - switch (e -> opcode) { - case OPCCALL: - case OPCALL: - out_call (fp, (int) e -> opcode, e -> vtype, - e -> vleng, e -> leftp, e -> rightp); - break; - - case OPCOMMA_ARG: - doin_setbound = 1; - nice_printf(fp, "("); - expr_out(fp, e->leftp); - nice_printf(fp, ", &"); - doin_setbound = 0; - expr_out(fp, e->rightp); - nice_printf(fp, ")"); - break; - - case OPADDR: - default: - nice_printf (fp, "Sorry, can't format OPCODE '%d'", - e -> opcode); - break; - } - - } /* else */ -} /* output_binary */ - - void -#ifdef KR_headers -out_call(outfile, op, ftype, len, name, args) - FILE *outfile; - int op; - int ftype; - expptr len; - expptr name; - expptr args; -#else -out_call(FILE *outfile, int op, int ftype, expptr len, expptr name, expptr args) -#endif -{ - chainp arglist; /* Pointer to any actual arguments */ - chainp cp; /* Iterator over argument lists */ - Addrp ret_val = (Addrp) NULL; - /* Function return value buffer, if any is - required */ - int byvalue; /* True iff we're calling a C library - routine */ - int done_once; /* Used for writing commas to outfile */ - int narg, t; - register expptr q; - long L; - Argtypes *at; - Atype *A, *Ac; - Namep np; - extern int forcereal; - -/* Don't use addresses if we're calling a C function */ - - byvalue = op == OPCCALL; - - if (args) - arglist = args -> listblock.listp; - else - arglist = CHNULL; - -/* If this is a CHARACTER function, the first argument is the result */ - - if (ftype == TYCHAR) - if (ISICON (len)) { - ret_val = (Addrp) (arglist -> datap); - arglist = arglist -> nextp; - } else { - err ("adjustable character function"); - return; - } /* else */ - -/* If this is a COMPLEX function, the first argument is the result */ - - else if (ISCOMPLEX (ftype)) { - ret_val = (Addrp) (arglist -> datap); - arglist = arglist -> nextp; - } /* if ISCOMPLEX */ - - /* prepare to cast procedure parameters -- set A if we know how */ - np = name->tag == TEXPR && name->exprblock.opcode == OPWHATSIN - ? (Namep)name->exprblock.leftp : (Namep)name; - - A = Ac = 0; - if (np->tag == TNAME && (at = np->arginfo)) { - if (at->nargs > 0) - A = at->atypes; - if (Ansi && (at->defined || at->nargs > 0)) - Ac = at->atypes; - } - -/* Now we can actually start to write out the function invocation */ - - if (ftype == TYREAL && forcereal) - nice_printf(outfile, "(real)"); - if (name -> tag == TEXPR && name -> exprblock.opcode == OPWHATSIN) { - nice_printf (outfile, "("); - expr_out (outfile, name); - nice_printf (outfile, ")"); - } - else - expr_out(outfile, name); - - nice_printf(outfile, "("); - - if (ret_val) { - if (ISCOMPLEX (ftype)) - nice_printf (outfile, "&"); - expr_out (outfile, (expptr) ret_val); - if (Ac) - Ac++; - -/* The length of the result of a character function is the second argument */ -/* It should be in place from putcall(), so we won't touch it explicitly */ - - } /* if ret_val */ - done_once = ret_val ? TRUE : FALSE; - -/* Now run through the named arguments */ - - narg = -1; - for (cp = arglist; cp; cp = cp -> nextp, done_once = TRUE) { - - if (done_once) - nice_printf (outfile, ", "); - narg++; - - if (!( q = (expptr)cp->datap) ) - continue; - - if (q->tag == TADDR) { - if (q->addrblock.vtype > TYERROR) { - /* I/O block */ - nice_printf(outfile, "&%s", q->addrblock.user.ident); - continue; - } - if (!byvalue && q->addrblock.isarray - && q->addrblock.vtype != TYCHAR - && q->addrblock.memoffset->tag == TCONST) { - - /* check for 0 offset -- after */ - /* correcting for equivalence. */ - L = q->addrblock.memoffset->constblock.Const.ci; - if (ONEOF(q->addrblock.vstg, M(STGCOMMON)|M(STGEQUIV)) - && q->addrblock.uname_tag == UNAM_NAME) - L -= q->addrblock.user.name->voffset; - if (L) - goto skip_deref; - - if (Ac && narg < at->dnargs - && q->headblock.vtype != (t = Ac[narg].type) - && t > TYADDR && t < TYSUBR) - nice_printf(outfile, "(%s*)", typename[t]); - - /* &x[0] == x */ - /* This also prevents &sizeof(doublereal)[0] */ - - switch(q->addrblock.uname_tag) { - case UNAM_NAME: - out_name(outfile, q->addrblock.user.name); - continue; - case UNAM_IDENT: - nice_printf(outfile, "%s", - q->addrblock.user.ident); - continue; - case UNAM_CHARP: - nice_printf(outfile, "%s", - q->addrblock.user.Charp); - continue; - case UNAM_EXTERN: - extern_out(outfile, - &extsymtab[q->addrblock.memno]); - continue; - } - } - } - -/* Skip over the dereferencing operator generated only for the - intermediate file */ - skip_deref: - if (q -> tag == TEXPR && q -> exprblock.opcode == OPWHATSIN) - q = q -> exprblock.leftp; - - if (q->headblock.vclass == CLPROC) { - if (Castargs && (q->tag != TNAME - || q->nameblock.vprocclass != PTHISPROC) - && (q->tag != TADDR - || q->addrblock.uname_tag != UNAM_NAME - || q->addrblock.user.name->vprocclass - != PTHISPROC)) - { - if (A && (t = A[narg].type) >= 200) - t %= 100; - else { - t = q->headblock.vtype; - if (q->tag == TNAME && q->nameblock.vimpltype) - t = TYUNKNOWN; - } - nice_printf(outfile, "(%s)", usedcasts[t] = casttypes[t]); - } - } - else if (Ac && narg < at->dnargs - && q->headblock.vtype != (t = Ac[narg].type) - && t > TYADDR && t < TYSUBR) - nice_printf(outfile, "(%s*)", typename[t]); - - if ((q -> tag == TADDR || q-> tag == TNAME) && - (byvalue || q -> headblock.vstg != STGREG)) { - if (q -> headblock.vtype != TYCHAR) - if (byvalue) { - - if (q -> tag == TADDR && - q -> addrblock.uname_tag == UNAM_NAME && - ! q -> addrblock.user.name -> vdim && - oneof_stg(q -> addrblock.user.name, q -> addrblock.vstg, - M(STGARG)|M(STGEQUIV)) && - ! ISCOMPLEX(q->addrblock.user.name->vtype)) - nice_printf (outfile, "*"); - else if (q -> tag == TNAME - && oneof_stg(&q->nameblock, q -> nameblock.vstg, - M(STGARG)|M(STGEQUIV)) - && !(q -> nameblock.vdim)) - nice_printf (outfile, "*"); - - } else { - expptr memoffset; - - if (q->tag == TADDR && ( - !ONEOF (q -> addrblock.vstg, M(STGEXT)|M(STGLENG)) - && (ONEOF(q->addrblock.vstg, - M(STGCOMMON)|M(STGEQUIV)|M(STGMEMNO)) - || ((memoffset = q->addrblock.memoffset) - && (!ISICON(memoffset) - || memoffset->constblock.Const.ci))) - || ONEOF(q->addrblock.vstg, - M(STGINIT)|M(STGAUTO)|M(STGBSS)) - && !q->addrblock.isarray)) - nice_printf (outfile, "&"); - else if (q -> tag == TNAME - && !oneof_stg(&q->nameblock, q -> nameblock.vstg, - M(STGARG)|M(STGEXT)|M(STGEQUIV))) - nice_printf (outfile, "&"); - } /* else */ - - expr_out (outfile, q); - } /* if q -> tag == TADDR || q -> tag == TNAME */ - -/* Might be a Constant expression, e.g. string length, character constants */ - - else if (q -> tag == TCONST) { - if (q->constblock.vtype == TYLONG) - nice_printf(outfile, "(ftnlen)%ld", - q->constblock.Const.ci); - else - out_const(outfile, &q->constblock); - } - -/* Must be some other kind of expression, or register var, or constant. - In particular, this is likely to be a temporary variable assignment - which was generated in p1put_call */ - - else if (!ISCOMPLEX (q -> headblock.vtype) && !ISCHAR (q)){ - int use_paren = q -> tag == TEXPR && - op_precedence (q -> exprblock.opcode) <= - op_precedence (OPCOMMA); - if (q->headblock.vtype == TYREAL && forcereal) { - nice_printf(outfile, "(real)"); - use_paren = 1; - } - if (use_paren) nice_printf (outfile, "("); - expr_out (outfile, q); - if (use_paren) nice_printf (outfile, ")"); - } /* if !ISCOMPLEX */ - else - err ("out_call: unknown parameter"); - - } /* for (cp = arglist */ - - if (arglist) - frchain (&arglist); - - nice_printf (outfile, ")"); - -} /* out_call */ - - - char * -#ifdef KR_headers -flconst(buf, x) - char *buf; - char *x; -#else -flconst(char *buf, char *x) -#endif -{ - sprintf(buf, fl_fmt_string, x); - return buf; - } - - char * -#ifdef KR_headers -dtos(x) - double x; -#else -dtos(double x) -#endif -{ - static char buf[64]; -#ifdef USE_DTOA - g_fmt(buf, x); -#else - sprintf(buf, db_fmt_string, x); -#endif - return strcpy(mem(strlen(buf)+1,0), buf); - } - -char tr_tab[Table_size]; - -/* out_init -- Initialize the data structures used by the routines in - output.c. These structures include the output format to be used for - Float, Double, Complex, and Double Complex constants. */ - - void -out_init(Void) -{ - extern int tab_size; - register char *s; - - s = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_+-."; - while(*s) - tr_tab[*s++] = 3; - tr_tab['>'] = 1; - - opeqable[OPPLUS] = 1; - opeqable[OPMINUS] = 1; - opeqable[OPSTAR] = 1; - opeqable[OPSLASH] = 1; - opeqable[OPMOD] = 1; - opeqable[OPLSHIFT] = 1; - opeqable[OPBITAND] = 1; - opeqable[OPBITXOR] = 1; - opeqable[OPBITOR ] = 1; - - -/* Set the output format for both types of floating point constants */ - - if (fl_fmt_string == NULL || *fl_fmt_string == '\0') - fl_fmt_string = Ansi == 1 ? "%sf" : "(float)%s"; - - if (db_fmt_string == NULL || *db_fmt_string == '\0') - db_fmt_string = "%.17g"; - -/* Set the output format for both types of complex constants. They will - have string parameters rather than float or double so that the decimal - point may be added to the strings generated by the {db,fl}_fmt_string - formats above */ - - if (cm_fmt_string == NULL || *cm_fmt_string == '\0') { - cm_fmt_string = "{%s,%s}"; - } /* if cm_fmt_string == NULL */ - - if (dcm_fmt_string == NULL || *dcm_fmt_string == '\0') { - dcm_fmt_string = "{%s,%s}"; - } /* if dcm_fmt_string == NULL */ - - tab_size = 4; -} /* out_init */ - - - void -#ifdef KR_headers -extern_out(fp, extsym) - FILE *fp; - Extsym *extsym; -#else -extern_out(FILE *fp, Extsym *extsym) -#endif -{ - if (extsym == (Extsym *) NULL) - return; - - nice_printf (fp, "%s", extsym->cextname); - -} /* extern_out */ - - - - static void -#ifdef KR_headers -output_list(fp, listp) - FILE *fp; - struct Listblock *listp; -#else -output_list(FILE *fp, struct Listblock *listp) -#endif -{ - int did_one = 0; - chainp elts; - - nice_printf (fp, "("); - if (listp) - for (elts = listp -> listp; elts; elts = elts -> nextp) { - if (elts -> datap) { - if (did_one) - nice_printf (fp, ", "); - expr_out (fp, (expptr) elts -> datap); - did_one = 1; - } /* if elts -> datap */ - } /* for elts */ - nice_printf (fp, ")"); -} /* output_list */ - - - void -#ifdef KR_headers -out_asgoto(outfile, expr) - FILE *outfile; - expptr expr; -#else -out_asgoto(FILE *outfile, expptr expr) -#endif -{ - chainp value; - Namep namep; - int k; - - if (expr == (expptr) NULL) { - err ("out_asgoto: NULL variable expr"); - return; - } /* if expr */ - - nice_printf (outfile, Ansi ? "switch (" : "switch ((int)"); /*)*/ - expr_out (outfile, expr); - nice_printf (outfile, ") {\n"); - next_tab (outfile); - -/* The initial addrp value will be stored as a namep pointer */ - - switch(expr->tag) { - case TNAME: - /* local variable */ - namep = &expr->nameblock; - break; - case TEXPR: - if (expr->exprblock.opcode == OPWHATSIN - && expr->exprblock.leftp->tag == TNAME) - /* argument */ - namep = &expr->exprblock.leftp->nameblock; - else - goto bad; - break; - case TADDR: - if (expr->addrblock.uname_tag == UNAM_NAME) { - /* initialized local variable */ - namep = expr->addrblock.user.name; - break; - } - default: - bad: - err("out_asgoto: bad expr"); - return; - } - - for(k = 0, value = namep -> varxptr.assigned_values; value; - value = value->nextp, k++) { - nice_printf (outfile, "case %d: goto %s;\n", k, - user_label((long)value->datap)); - } /* for value */ - prev_tab (outfile); - - nice_printf (outfile, "}\n"); -} /* out_asgoto */ - - void -#ifdef KR_headers -out_if(outfile, expr) - FILE *outfile; - expptr expr; -#else -out_if(FILE *outfile, expptr expr) -#endif -{ - nice_printf (outfile, "if ("); - expr_out (outfile, expr); - nice_printf (outfile, ") {\n"); - next_tab (outfile); -} /* out_if */ - - static void -#ifdef KR_headers -output_rbrace(outfile, s) - FILE *outfile; - char *s; -#else -output_rbrace(FILE *outfile, char *s) -#endif -{ - extern int last_was_label; - register char *fmt; - - if (last_was_label) { - last_was_label = 0; - fmt = ";%s"; - } - else - fmt = "%s"; - nice_printf(outfile, fmt, s); - } - - void -#ifdef KR_headers -out_else(outfile) - FILE *outfile; -#else -out_else(FILE *outfile) -#endif -{ - prev_tab (outfile); - output_rbrace(outfile, "} else {\n"); - next_tab (outfile); -} /* out_else */ - - void -#ifdef KR_headers -elif_out(outfile, expr) - FILE *outfile; - expptr expr; -#else -elif_out(FILE *outfile, expptr expr) -#endif -{ - prev_tab (outfile); - output_rbrace(outfile, "} else "); - out_if (outfile, expr); -} /* elif_out */ - - void -#ifdef KR_headers -endif_out(outfile) - FILE *outfile; -#else -endif_out(FILE *outfile) -#endif -{ - prev_tab (outfile); - output_rbrace(outfile, "}\n"); -} /* endif_out */ - - void -#ifdef KR_headers -end_else_out(outfile) - FILE *outfile; -#else -end_else_out(FILE *outfile) -#endif -{ - prev_tab (outfile); - output_rbrace(outfile, "}\n"); -} /* end_else_out */ - - - - void -#ifdef KR_headers -compgoto_out(outfile, index, labels) - FILE *outfile; - expptr index; - expptr labels; -#else -compgoto_out(FILE *outfile, expptr index, expptr labels) -#endif -{ - char *s1, *s2; - - if (index == ENULL) - err ("compgoto_out: null index for computed goto"); - else if (labels && labels -> tag != TLIST) - erri ("compgoto_out: expected label list, got tag '%d'", - labels -> tag); - else { - chainp elts; - int i = 1; - - s2 = /*(*/ ") {\n"; /*}*/ - if (Ansi) - s1 = "switch ("; /*)*/ - else if (index->tag == TNAME || index->tag == TEXPR - && index->exprblock.opcode == OPWHATSIN) - s1 = "switch ((int)"; /*)*/ - else { - s1 = "switch ((int)("; - s2 = ")) {\n"; /*}*/ - } - nice_printf(outfile, s1); - expr_out (outfile, index); - nice_printf (outfile, s2); - next_tab (outfile); - - for (elts = labels -> listblock.listp; elts; elts = elts -> nextp, i++) { - if (elts -> datap) { - if (ISICON(((expptr) (elts -> datap)))) - nice_printf (outfile, "case %d: goto %s;\n", i, - user_label(((expptr)(elts->datap))->constblock.Const.ci)); - else - err ("compgoto_out: bad label in label list"); - } /* if (elts -> datap) */ - } /* for elts */ - prev_tab (outfile); - nice_printf (outfile, /*{*/ "}\n"); - } /* else */ -} /* compgoto_out */ - - - void -#ifdef KR_headers -out_for(outfile, init, test, inc) - FILE *outfile; - expptr init; - expptr test; - expptr inc; -#else -out_for(FILE *outfile, expptr init, expptr test, expptr inc) -#endif -{ - nice_printf (outfile, "for ("); - expr_out (outfile, init); - nice_printf (outfile, "; "); - expr_out (outfile, test); - nice_printf (outfile, "; "); - expr_out (outfile, inc); - nice_printf (outfile, ") {\n"); - next_tab (outfile); -} /* out_for */ - - - void -#ifdef KR_headers -out_end_for(outfile) - FILE *outfile; -#else -out_end_for(FILE *outfile) -#endif -{ - prev_tab (outfile); - nice_printf (outfile, "}\n"); -} /* out_end_for */ diff --git a/usr.bin/f2c/output.h b/usr.bin/f2c/output.h deleted file mode 100644 index 97e3a0ad09b1..000000000000 --- a/usr.bin/f2c/output.h +++ /dev/null @@ -1,64 +0,0 @@ -/* nice_printf -- same arguments as fprintf. - - All output which is to become C code must be directed through this - function. For now, no buffering is done. Later on, every line of - output will be filtered to accomodate the style definitions (e.g. one - statement per line, spaces between function names and argument lists, - etc.) -*/ -#include "niceprintf.h" - - -/* Definitions for the opcode table. The table is indexed by the macros - which are #defined in defines.h */ - -#define UNARY_OP 01 -#define BINARY_OP 02 - -#define SPECIAL_FMT NULL - -#define is_unary_op(x) (opcode_table[x].type == UNARY_OP) -#define is_binary_op(x) (opcode_table[x].type == BINARY_OP) -#define op_precedence(x) (opcode_table[x].prec) -#define op_format(x) (opcode_table[x].format) - -/* _assoc_table -- encodes left-associativity and right-associativity - information; indexed by precedence level. Only 2, 3, 14 are - right-associative. Source: Kernighan & Ritchie, p. 49 */ - -extern char _assoc_table[]; - -#define is_right_assoc(x) (_assoc_table [x]) -#define is_left_assoc(x) (! _assoc_table [x]) - - -typedef struct { - int type; /* UNARY_OP or BINARY_OP */ - int prec; /* Precedence level, useful for adjusting - number of parens to insert. Zero is a - special level, and 2, 3, 14 are - right-associative */ - char *format; -} table_entry; - - -extern char *fl_fmt_string; /* Float constant format string */ -extern char *db_fmt_string; /* Double constant format string */ -extern char *cm_fmt_string; /* Complex constant format string */ -extern char *dcm_fmt_string; /* Double Complex constant format string */ - -extern int indent; /* Number of spaces to indent; this is a - temporary fix */ -extern int tab_size; /* Number of spaces in each tab */ -extern int in_string; - -extern table_entry opcode_table[]; - - -void compgoto_out Argdcl((FILEP, tagptr, tagptr)); -void endif_out Argdcl((FILEP)); -void expr_out Argdcl((FILEP, tagptr)); -void out_and_free_statement Argdcl((FILEP, tagptr)); -void out_end_for Argdcl((FILEP)); -void out_if Argdcl((FILEP, tagptr)); -void out_name Argdcl((FILEP, Namep)); diff --git a/usr.bin/f2c/p1defs.h b/usr.bin/f2c/p1defs.h deleted file mode 100644 index c76af2295740..000000000000 --- a/usr.bin/f2c/p1defs.h +++ /dev/null @@ -1,158 +0,0 @@ -#define P1_UNKNOWN 0 -#define P1_COMMENT 1 /* Fortan comment string */ -#define P1_EOF 2 /* End of file dummy token */ -#define P1_SET_LINE 3 /* Reset the line counter */ -#define P1_FILENAME 4 /* Name of current input file */ -#define P1_NAME_POINTER 5 /* Pointer to hash table entry */ -#define P1_CONST 6 /* Some constant value */ -#define P1_EXPR 7 /* Followed by opcode */ - -/* The next two tokens could be grouped together, since they always come - from an Addr structure */ - -#define P1_IDENT 8 /* Char string identifier in addrp->user - field */ -#define P1_EXTERN 9 /* Pointer to external symbol entry */ - -#define P1_HEAD 10 /* Function header info */ -#define P1_LIST 11 /* A list of data (e.g. arguments) will - follow the tag, type, and count */ -#define P1_LITERAL 12 /* Hold the index into the literal pool */ -#define P1_LABEL 13 /* label value */ -#define P1_ASGOTO 14 /* Store the hash table pointer of - variable used in assigned goto */ -#define P1_GOTO 15 /* Store the statement number */ -#define P1_IF 16 /* store the condition as an expression */ -#define P1_ELSE 17 /* No data */ -#define P1_ELIF 18 /* store the condition as an expression */ -#define P1_ENDIF 19 /* Marks the end of a block IF */ -#define P1_ENDELSE 20 /* Marks the end of a block ELSE */ -#define P1_ADDR 21 /* Addr data; used for arrays, common and - equiv addressing, NOT for names, idents - or externs */ -#define P1_SUBR_RET 22 /* Subroutine return; the return expression - follows */ -#define P1_COMP_GOTO 23 /* Computed goto; has expr, label list */ -#define P1_FOR 24 /* C FOR loop; three expressions follow */ -#define P1_ENDFOR 25 /* End of C FOR loop */ -#define P1_FORTRAN 26 /* original Fortran source */ -#define P1_CHARP 27 /* user.Charp field -- for long names */ -#define P1_WHILE1START 28 /* start of DO WHILE */ -#define P1_WHILE2START 29 /* rest of DO WHILE */ -#define P1_PROCODE 30 /* invoke procode() -- to adjust params */ -#define P1_ELSEIFSTART 31 /* handle extra code for abs, min, max - in else if() */ - -#define P1_FILENAME_MAX 256 /* max filename length to retain (for -g) */ -#define P1_STMTBUFSIZE 1400 - - - -#define COMMENT_BUFFER_SIZE 255 /* max number of chars in each comment */ -#define CONSTANT_STR_MAX 1000 /* max number of chars in string constant */ - -void p1_asgoto Argdcl((Addrp)); -void p1_comment Argdcl((char*)); -void p1_elif Argdcl((tagptr)); -void p1_else Argdcl((void)); -void p1_endif Argdcl((void)); -void p1_expr Argdcl((tagptr)); -void p1_for Argdcl((tagptr, tagptr, tagptr)); -void p1_goto Argdcl((long int)); -void p1_head Argdcl((int, char*)); -void p1_if Argdcl((tagptr)); -void p1_label Argdcl((long int)); -void p1_line_number Argdcl((long int)); -void p1_subr_ret Argdcl((tagptr)); -void p1comp_goto Argdcl((tagptr, int, struct Labelblock**)); -void p1else_end Argdcl((void)); -void p1for_end Argdcl((void)); -void p1put Argdcl((int)); -void p1puts Argdcl((int, char*)); - -/* The pass 1 intermediate file has the following format: - - <ascii-integer-rep> [ : [ <sp> [ <data> ]]] \n - - e.g. 1: This is a comment - - This format is destined to change in the future, but for now a readable - form is more desirable than a compact form. - - NOTES ABOUT THE P1 FORMAT - ---------------------------------------------------------------------- - - P1_COMMENT: The comment string (in <data>) may be at most - COMMENT_BUFFER_SIZE bytes long. It must contain no newlines - or null characters. A side effect of the way comments are - read in lex.c is that no '\377' chars may be in a - comment either. - - P1_SET_LINE: <data> holds the line number in the current source file. - - P1_INC_LINE: Increment the source line number; <data> is empty. - - P1_NAME_POINTER: <data> holds the integer representation of a - pointer into a hash table entry. - - P1_CONST: the first field in <data> is a type tag (one of the - TYxxxx macros), the next field holds the constant - value - - P1_EXPR: <data> holds the opcode number of the expression, - followed by the type of the expression (required for - OPCONV). Next is the value of vleng. - The type of operation represented by the - opcode determines how many of the following data items - are part of this expression. - - P1_IDENT: <data> holds the type, then storage, then the - char string identifier in the addrp->user field. - - P1_EXTERN: <data> holds an offset into the external symbol - table entry - - P1_HEAD: the first field in <data> is the procedure class, the - second is the name of the procedure - - P1_LIST: the first field in <data> is the tag, the second the - type of the list, the third the number of elements in - the list - - P1_LITERAL: <data> holds the litnum of a value in the - literal pool. - - P1_LABEL: <data> holds the statement number of the current - line - - P1_ASGOTO: <data> holds the hash table pointer of the variable - - P1_GOTO: <data> holds the statement number to jump to - - P1_IF: <data> is empty, the following expression is the IF - condition. - - P1_ELSE: <data> is empty. - - P1_ELIF: <data> is empty, the following expression is the IF - condition. - - P1_ENDIF: <data> is empty. - - P1_ENDELSE: <data> is empty. - - P1_ADDR: <data> holds a direct copy of the structure. The - next expression is a copy of vleng, and the next a - copy of memoffset. - - P1_SUBR_RET: The next token is an expression for the return value. - - P1_COMP_GOTO: The next token is an integer expression, the - following one a list of labels. - - P1_FOR: The next three expressions are the Init, Test, and - Increment expressions of a C FOR loop. - - P1_ENDFOR: Marks the end of the body of a FOR loop - -*/ diff --git a/usr.bin/f2c/p1output.c b/usr.bin/f2c/p1output.c deleted file mode 100644 index 93204abb1e20..000000000000 --- a/usr.bin/f2c/p1output.c +++ /dev/null @@ -1,723 +0,0 @@ -/**************************************************************** -Copyright 1990, 1991, 1993, 1994 by AT&T, Lucent Technologies and Bellcore. - -Permission to use, copy, modify, and distribute this software -and its documentation for any purpose and without fee is hereby -granted, provided that the above copyright notice appear in all -copies and that both that the copyright notice and this -permission notice and warranty disclaimer appear in supporting -documentation, and that the names of AT&T, Bell Laboratories, -Lucent or Bellcore or any of their entities not be used in -advertising or publicity pertaining to distribution of the -software without specific, written prior permission. - -AT&T, Lucent and Bellcore disclaim all warranties with regard to -this software, including all implied warranties of -merchantability and fitness. In no event shall AT&T, Lucent or -Bellcore be liable for any special, indirect or consequential -damages or any damages whatsoever resulting from loss of use, -data or profits, whether in an action of contract, negligence or -other tortious action, arising out of or in connection with the -use or performance of this software. -****************************************************************/ - -#include "defs.h" -#include "p1defs.h" -#include "output.h" -#include "names.h" - - -static void p1_addr Argdcl((Addrp)); -static void p1_big_addr Argdcl((Addrp)); -static void p1_binary Argdcl((Exprp)); -static void p1_const Argdcl((Constp)); -static void p1_list Argdcl((struct Listblock*)); -static void p1_literal Argdcl((long int)); -static void p1_name Argdcl((Namep)); -static void p1_unary Argdcl((Exprp)); -static void p1putd Argdcl((int, long int)); -static void p1putdd Argdcl((int, int, int)); -static void p1putddd Argdcl((int, int, int, int)); -static void p1putdds Argdcl((int, int, int, char*)); -static void p1putds Argdcl((int, int, char*)); -static void p1putn Argdcl((int, int, char*)); - - -/* p1_comment -- save the text of a Fortran comment in the intermediate - file. Make sure that there are no spurious "/ *" or "* /" characters by - mapping them onto "/+" and "+/". str is assumed to hold no newlines and be - null terminated; it may be modified by this function. */ - - void -#ifdef KR_headers -p1_comment(str) - char *str; -#else -p1_comment(char *str) -#endif -{ - register unsigned char *pointer, *ustr; - - if (!str) - return; - -/* Get rid of any open or close comment combinations that may be in the - Fortran input */ - - ustr = (unsigned char *)str; - for(pointer = ustr; *pointer; pointer++) - if (*pointer == '*' && (pointer[1] == '/' - || pointer > ustr && pointer[-1] == '/')) - *pointer = '+'; - /* trim trailing white space */ -#ifdef isascii - while(--pointer >= ustr && (!isascii(*pointer) || isspace(*pointer))); -#else - while(--pointer >= ustr && isspace(*pointer)); -#endif - pointer[1] = 0; - p1puts (P1_COMMENT, str); -} /* p1_comment */ - -/* p1_name -- Writes the address of a hash table entry into the - intermediate file */ - - static void -#ifdef KR_headers -p1_name(namep) - Namep namep; -#else -p1_name(Namep namep) -#endif -{ - p1putd (P1_NAME_POINTER, (long) namep); - namep->visused = 1; -} /* p1_name */ - - - - void -#ifdef KR_headers -p1_expr(expr) - expptr expr; -#else -p1_expr(expptr expr) -#endif -{ -/* An opcode of 0 means a null entry */ - - if (expr == ENULL) { - p1putdd (P1_EXPR, 0, TYUNKNOWN); /* Should this be TYERROR? */ - return; - } /* if (expr == ENULL) */ - - switch (expr -> tag) { - case TNAME: - p1_name ((Namep) expr); - return; - case TCONST: - p1_const(&expr->constblock); - return; - case TEXPR: - /* Fall through the switch */ - break; - case TADDR: - p1_addr (&(expr -> addrblock)); - goto freeup; - case TPRIM: - warn ("p1_expr: got TPRIM"); - return; - case TLIST: - p1_list (&(expr->listblock)); - frchain( &(expr->listblock.listp) ); - return; - case TERROR: - return; - default: - erri ("p1_expr: bad tag '%d'", (int) (expr -> tag)); - return; - } - -/* Now we know that the tag is TEXPR */ - - if (is_unary_op (expr -> exprblock.opcode)) - p1_unary (&(expr -> exprblock)); - else if (is_binary_op (expr -> exprblock.opcode)) - p1_binary (&(expr -> exprblock)); - else - erri ("p1_expr: bad opcode '%d'", (int) expr -> exprblock.opcode); - freeup: - free((char *)expr); - -} /* p1_expr */ - - - - static void -#ifdef KR_headers -p1_const(cp) - register Constp cp; -#else -p1_const(register Constp cp) -#endif -{ - int type = cp->vtype; - expptr vleng = cp->vleng; - union Constant *c = &cp->Const; - char cdsbuf0[64], cdsbuf1[64]; - char *cds0, *cds1; - - switch (type) { - case TYINT1: - case TYSHORT: - case TYLONG: -#ifdef TYQUAD - case TYQUAD: -#endif - case TYLOGICAL: - case TYLOGICAL1: - case TYLOGICAL2: - fprintf(pass1_file, "%d: %d %ld\n", P1_CONST, type, c->ci); - break; - case TYREAL: - case TYDREAL: - fprintf(pass1_file, "%d: %d %s\n", P1_CONST, type, - cp->vstg ? c->cds[0] : cds(dtos(c->cd[0]), cdsbuf0)); - break; - case TYCOMPLEX: - case TYDCOMPLEX: - if (cp->vstg) { - cds0 = c->cds[0]; - cds1 = c->cds[1]; - } - else { - cds0 = cds(dtos(c->cd[0]), cdsbuf0); - cds1 = cds(dtos(c->cd[1]), cdsbuf1); - } - fprintf(pass1_file, "%d: %d %s %s\n", P1_CONST, type, - cds0, cds1); - break; - case TYCHAR: - if (vleng && !ISICON (vleng)) - erri("p1_const: bad vleng '%d'\n", (int) vleng); - else - fprintf(pass1_file, "%d: %d %lx\n", P1_CONST, type, - cpexpr((expptr)cp)); - break; - default: - erri ("p1_const: bad constant type '%d'", type); - break; - } /* switch */ -} /* p1_const */ - - - void -#ifdef KR_headers -p1_asgoto(addrp) - Addrp addrp; -#else -p1_asgoto(Addrp addrp) -#endif -{ - p1put (P1_ASGOTO); - p1_addr (addrp); -} /* p1_asgoto */ - - - void -#ifdef KR_headers -p1_goto(stateno) - ftnint stateno; -#else -p1_goto(ftnint stateno) -#endif -{ - p1putd (P1_GOTO, stateno); -} /* p1_goto */ - - - static void -#ifdef KR_headers -p1_addr(addrp) - register struct Addrblock *addrp; -#else -p1_addr(register struct Addrblock *addrp) -#endif -{ - int stg; - - if (addrp == (struct Addrblock *) NULL) - return; - - stg = addrp -> vstg; - - if (ONEOF(stg, M(STGINIT)|M(STGREG)) - || ONEOF(stg, M(STGCOMMON)|M(STGEQUIV)) && - (!ISICON(addrp->memoffset) - || (addrp->uname_tag == UNAM_NAME - ? addrp->memoffset->constblock.Const.ci - != addrp->user.name->voffset - : addrp->memoffset->constblock.Const.ci)) - || ONEOF(stg, M(STGBSS)|M(STGINIT)|M(STGAUTO)|M(STGARG)) && - (!ISICON(addrp->memoffset) - || addrp->memoffset->constblock.Const.ci) - || addrp->Field || addrp->isarray || addrp->vstg == STGLENG) - { - p1_big_addr (addrp); - return; - } - -/* Write out a level of indirection for non-array arguments, which have - addrp -> memoffset set and are handled by p1_big_addr(). - Lengths are passed by value, so don't check STGLENG - 28-Jun-89 (dmg) Added the check for != TYCHAR - */ - - if (oneof_stg ( addrp -> uname_tag == UNAM_NAME ? addrp -> user.name : NULL, - stg, M(STGARG)|M(STGEQUIV)) && addrp->vtype != TYCHAR) { - p1putdd (P1_EXPR, OPWHATSIN, addrp -> vtype); - p1_expr (ENULL); /* Put dummy vleng */ - } /* if stg == STGARG */ - - switch (addrp -> uname_tag) { - case UNAM_NAME: - p1_name (addrp -> user.name); - break; - case UNAM_IDENT: - p1putdds(P1_IDENT, addrp->vtype, addrp->vstg, - addrp->user.ident); - break; - case UNAM_CHARP: - p1putdds(P1_CHARP, addrp->vtype, addrp->vstg, - addrp->user.Charp); - break; - case UNAM_EXTERN: - p1putd (P1_EXTERN, (long) addrp -> memno); - if (addrp->vclass == CLPROC) - extsymtab[addrp->memno].extype = addrp->vtype; - break; - case UNAM_CONST: - if (addrp -> memno != BAD_MEMNO) - p1_literal (addrp -> memno); - else - p1_const((struct Constblock *)addrp); - break; - case UNAM_UNKNOWN: - default: - erri ("p1_addr: unknown uname_tag '%d'", addrp -> uname_tag); - break; - } /* switch */ -} /* p1_addr */ - - - static void -#ifdef KR_headers -p1_list(listp) - struct Listblock *listp; -#else -p1_list(struct Listblock *listp) -#endif -{ - chainp lis; - int count = 0; - - if (listp == (struct Listblock *) NULL) - return; - -/* Count the number of parameters in the list */ - - for (lis = listp -> listp; lis; lis = lis -> nextp) - count++; - - p1putddd (P1_LIST, listp -> tag, listp -> vtype, count); - - for (lis = listp -> listp; lis; lis = lis -> nextp) - p1_expr ((expptr) lis -> datap); - -} /* p1_list */ - - - void -#ifdef KR_headers -p1_label(lab) - long lab; -#else -p1_label(long lab) -#endif -{ - if (parstate < INDATA) - earlylabs = mkchain((char *)lab, earlylabs); - else - p1putd (P1_LABEL, lab); - } - - - - static void -#ifdef KR_headers -p1_literal(memno) - long memno; -#else -p1_literal(long memno) -#endif -{ - p1putd (P1_LITERAL, memno); -} /* p1_literal */ - - - void -#ifdef KR_headers -p1_if(expr) - expptr expr; -#else -p1_if(expptr expr) -#endif -{ - p1put (P1_IF); - p1_expr (expr); -} /* p1_if */ - - - - - void -#ifdef KR_headers -p1_elif(expr) - expptr expr; -#else -p1_elif(expptr expr) -#endif -{ - p1put (P1_ELIF); - p1_expr (expr); -} /* p1_elif */ - - - - - void -p1_else(Void) -{ - p1put (P1_ELSE); -} /* p1_else */ - - - - - void -p1_endif(Void) -{ - p1put (P1_ENDIF); -} /* p1_endif */ - - - - - void -p1else_end(Void) -{ - p1put (P1_ENDELSE); -} /* p1else_end */ - - - static void -#ifdef KR_headers -p1_big_addr(addrp) - Addrp addrp; -#else -p1_big_addr(Addrp addrp) -#endif -{ - if (addrp == (Addrp) NULL) - return; - - p1putn (P1_ADDR, (int)sizeof(struct Addrblock), (char *) addrp); - p1_expr (addrp -> vleng); - p1_expr (addrp -> memoffset); - if (addrp->uname_tag == UNAM_NAME) - addrp->user.name->visused = 1; -} /* p1_big_addr */ - - - - static void -#ifdef KR_headers -p1_unary(e) - struct Exprblock *e; -#else -p1_unary(struct Exprblock *e) -#endif -{ - if (e == (struct Exprblock *) NULL) - return; - - p1putdd (P1_EXPR, (int) e -> opcode, e -> vtype); - p1_expr (e -> vleng); - - switch (e -> opcode) { - case OPNEG: - case OPNEG1: - case OPNOT: - case OPABS: - case OPBITNOT: - case OPPREINC: - case OPPREDEC: - case OPADDR: - case OPIDENTITY: - case OPCHARCAST: - case OPDABS: - p1_expr(e -> leftp); - break; - default: - erri ("p1_unary: bad opcode '%d'", (int) e -> opcode); - break; - } /* switch */ - -} /* p1_unary */ - - - static void -#ifdef KR_headers -p1_binary(e) - struct Exprblock *e; -#else -p1_binary(struct Exprblock *e) -#endif -{ - if (e == (struct Exprblock *) NULL) - return; - - p1putdd (P1_EXPR, e -> opcode, e -> vtype); - p1_expr (e -> vleng); - p1_expr (e -> leftp); - p1_expr (e -> rightp); -} /* p1_binary */ - - - void -#ifdef KR_headers -p1_head(class, name) - int class; - char *name; -#else -p1_head(int class, char *name) -#endif -{ - p1putds (P1_HEAD, class, name ? name : ""); -} /* p1_head */ - - - void -#ifdef KR_headers -p1_subr_ret(retexp) - expptr retexp; -#else -p1_subr_ret(expptr retexp) -#endif -{ - - p1put (P1_SUBR_RET); - p1_expr (cpexpr(retexp)); -} /* p1_subr_ret */ - - - - void -#ifdef KR_headers -p1comp_goto(index, count, labels) - expptr index; - int count; - struct Labelblock **labels; -#else -p1comp_goto(expptr index, int count, struct Labelblock **labels) -#endif -{ - struct Constblock c; - int i; - register struct Labelblock *L; - - p1put (P1_COMP_GOTO); - p1_expr (index); - -/* Write out a P1_LIST directly, to avoid the overhead of allocating a - list before it's needed HACK HACK HACK */ - - p1putddd (P1_LIST, TLIST, TYUNKNOWN, count); - c.vtype = TYLONG; - c.vleng = 0; - - for (i = 0; i < count; i++) { - L = labels[i]; - L->labused = 1; - c.Const.ci = L->stateno; - p1_const(&c); - } /* for i = 0 */ -} /* p1comp_goto */ - - - - void -#ifdef KR_headers -p1_for(init, test, inc) - expptr init; - expptr test; - expptr inc; -#else -p1_for(expptr init, expptr test, expptr inc) -#endif -{ - p1put (P1_FOR); - p1_expr (init); - p1_expr (test); - p1_expr (inc); -} /* p1_for */ - - - void -p1for_end(Void) -{ - p1put (P1_ENDFOR); -} /* p1for_end */ - - - - -/* ---------------------------------------------------------------------- - The intermediate file actually gets written ONLY by the routines below. - To change the format of the file, you need only change these routines. - ---------------------------------------------------------------------- -*/ - - -/* p1puts -- Put a typed string into the Pass 1 intermediate file. Assumes that - str contains no newlines and is null-terminated. */ - - void -#ifdef KR_headers -p1puts(type, str) - int type; - char *str; -#else -p1puts(int type, char *str) -#endif -{ - fprintf (pass1_file, "%d: %s\n", type, str); -} /* p1puts */ - - -/* p1putd -- Put a typed integer into the Pass 1 intermediate file. */ - - static void -#ifdef KR_headers -p1putd(type, value) - int type; - long value; -#else -p1putd(int type, long value) -#endif -{ - fprintf (pass1_file, "%d: %ld\n", type, value); -} /* p1_putd */ - - -/* p1putdd -- Put a typed pair of integers into the intermediate file. */ - - static void -#ifdef KR_headers -p1putdd(type, v1, v2) - int type; - int v1; - int v2; -#else -p1putdd(int type, int v1, int v2) -#endif -{ - fprintf (pass1_file, "%d: %d %d\n", type, v1, v2); -} /* p1putdd */ - - -/* p1putddd -- Put a typed triple of integers into the intermediate file. */ - - static void -#ifdef KR_headers -p1putddd(type, v1, v2, v3) - int type; - int v1; - int v2; - int v3; -#else -p1putddd(int type, int v1, int v2, int v3) -#endif -{ - fprintf (pass1_file, "%d: %d %d %d\n", type, v1, v2, v3); -} /* p1putddd */ - - union dL { - double d; - long L[2]; - }; - - static void -#ifdef KR_headers -p1putn(type, count, str) - int type; - int count; - char *str; -#else -p1putn(int type, int count, char *str) -#endif -{ - int i; - - fprintf (pass1_file, "%d: ", type); - - for (i = 0; i < count; i++) - putc (str[i], pass1_file); - - putc ('\n', pass1_file); -} /* p1putn */ - - - -/* p1put -- Put a type marker into the intermediate file. */ - - void -#ifdef KR_headers -p1put(type) - int type; -#else -p1put(int type) -#endif -{ - fprintf (pass1_file, "%d:\n", type); -} /* p1put */ - - - - static void -#ifdef KR_headers -p1putds(type, i, str) - int type; - int i; - char *str; -#else -p1putds(int type, int i, char *str) -#endif -{ - fprintf (pass1_file, "%d: %d %s\n", type, i, str); -} /* p1putds */ - - - static void -#ifdef KR_headers -p1putdds(token, type, stg, str) - int token; - int type; - int stg; - char *str; -#else -p1putdds(int token, int type, int stg, char *str) -#endif -{ - fprintf (pass1_file, "%d: %d %d %s\n", token, type, stg, str); -} /* p1putdds */ diff --git a/usr.bin/f2c/parse.h b/usr.bin/f2c/parse.h deleted file mode 100644 index 6de239944a9f..000000000000 --- a/usr.bin/f2c/parse.h +++ /dev/null @@ -1,47 +0,0 @@ -#ifndef PARSE_INCLUDE -#define PARSE_INCLUDE - -/* macros for the parse_args routine */ - -#define P_STRING 1 /* Macros for the result_type attribute */ -#define P_CHAR 2 -#define P_SHORT 3 -#define P_INT 4 -#define P_LONG 5 -#define P_FILE 6 -#define P_OLD_FILE 7 -#define P_NEW_FILE 8 -#define P_FLOAT 9 -#define P_DOUBLE 10 - -#define P_CASE_INSENSITIVE 01 /* Macros for the flags attribute */ -#define P_REQUIRED_PREFIX 02 - -#define P_NO_ARGS 0 /* Macros for the arg_count attribute */ -#define P_ONE_ARG 1 -#define P_INFINITE_ARGS 2 - -#define p_entry(pref,swit,flag,count,type,store,size) \ - { (pref), (swit), (flag), (count), (type), (int *) (store), (size) } - -typedef struct { - char *prefix; - char *string; - int flags; - int count; - int result_type; - int *result_ptr; - int table_size; -} arg_info; - -#ifdef KR_headers -#define Argdcl(x) () -#else -#define Argdcl(x) x -#endif -int arg_verify Argdcl((char**, arg_info*, int)); -void init_store Argdcl((arg_info*, int)); -int match_table Argdcl((char*, arg_info*, int, int, int*)); -int parse_args Argdcl((int, char**, arg_info*, int, char**, int)); - -#endif diff --git a/usr.bin/f2c/parse_args.c b/usr.bin/f2c/parse_args.c deleted file mode 100644 index b6dc75d14da3..000000000000 --- a/usr.bin/f2c/parse_args.c +++ /dev/null @@ -1,557 +0,0 @@ -/**************************************************************** -Copyright 1990, 1994-5 by AT&T, Lucent Technologies and Bellcore. - -Permission to use, copy, modify, and distribute this software -and its documentation for any purpose and without fee is hereby -granted, provided that the above copyright notice appear in all -copies and that both that the copyright notice and this -permission notice and warranty disclaimer appear in supporting -documentation, and that the names of AT&T, Bell Laboratories, -Lucent or Bellcore or any of their entities not be used in -advertising or publicity pertaining to distribution of the -software without specific, written prior permission. - -AT&T, Lucent and Bellcore disclaim all warranties with regard to -this software, including all implied warranties of -merchantability and fitness. In no event shall AT&T, Lucent or -Bellcore be liable for any special, indirect or consequential -damages or any damages whatsoever resulting from loss of use, -data or profits, whether in an action of contract, negligence or -other tortious action, arising out of or in connection with the -use or performance of this software. -****************************************************************/ - -/* parse_args - - This function will parse command line input into appropriate data - structures, output error messages when appropriate and provide some - minimal type conversion. - - Input to the function consists of the standard argc,argv - values, and a table which directs the parser. Each table entry has the - following components: - - prefix -- the (optional) switch character string, e.g. "-" "/" "=" - switch -- the command string, e.g. "o" "data" "file" "F" - flags -- control flags, e.g. CASE_INSENSITIVE, REQUIRED_PREFIX - arg_count -- number of arguments this command requires, e.g. 0 for - booleans, 1 for filenames, INFINITY for input files - result_type -- how to interpret the switch arguments, e.g. STRING, - CHAR, FILE, OLD_FILE, NEW_FILE - result_ptr -- pointer to storage for the result, be it a table or - a string or whatever - table_size -- if the arguments fill a table, the maximum number of - entries; if there are no arguments, the value to - load into the result storage - - Although the table can be used to hold a list of filenames, only - scalar values (e.g. pointers) can be stored in the table. No vector - processing will be done, only pointers to string storage will be moved. - - An example entry, which could be used to parse input filenames, is: - - "-", "o", 0, oo, OLD_FILE, infilenames, INFILE_TABLE_SIZE - -*/ - -#include <stdio.h> -#ifndef NULL -/* ANSI C */ -#include <stddef.h> -#endif -#ifdef KR_headers -extern double atof(); -#else -#include "stdlib.h" -#include "string.h" -#endif -#include "parse.h" -#include <math.h> /* For atof */ -#include <ctype.h> - -#define MAX_INPUT_SIZE 1000 - -#define arg_prefix(x) ((x).prefix) -#define arg_string(x) ((x).string) -#define arg_flags(x) ((x).flags) -#define arg_count(x) ((x).count) -#define arg_result_type(x) ((x).result_type) -#define arg_result_ptr(x) ((x).result_ptr) -#define arg_table_size(x) ((x).table_size) - -#ifndef TRUE -#define TRUE 1 -#endif -#ifndef FALSE -#define FALSE 0 -#endif -typedef int boolean; - - -static char *this_program = ""; - -static int arg_parse Argdcl((char*, arg_info*)); -static char *lower_string Argdcl((char*, char*)); -static int match Argdcl((char*, char*, arg_info*, boolean)); -static int put_one_arg Argdcl((int, char*, char**, char*, char*)); -extern int badargs; - - - boolean -#ifdef KR_headers -parse_args(argc, argv, table, entries, others, other_count) - int argc; - char **argv; - arg_info *table; - int entries; - char **others; - int other_count; -#else -parse_args(int argc, char **argv, arg_info *table, int entries, char **others, int other_count) -#endif -{ - boolean result; - - if (argv) - this_program = argv[0]; - -/* Check the validity of the table and its parameters */ - - result = arg_verify (argv, table, entries); - -/* Initialize the storage values */ - - init_store (table, entries); - - if (result) { - boolean use_prefix = TRUE; - char *argv0; - - argc--; - argv0 = *++argv; - while (argc) { - int index, length; - - index = match_table (*argv, table, entries, use_prefix, &length); - if (index < 0) { - -/* The argument doesn't match anything in the table */ - - if (others) { - - if (*argv > argv0) - *--*argv = '-'; /* complain at invalid flag */ - - if (other_count > 0) { - *others++ = *argv; - other_count--; - } else { - fprintf (stderr, "%s: too many parameters: ", - this_program); - fprintf (stderr, "'%s' ignored\n", *argv); - badargs++; - } /* else */ - } /* if (others) */ - argv0 = *++argv; - argc--; - } else { - -/* A match was found */ - - if (length >= strlen (*argv)) { - argc--; - argv0 = *++argv; - use_prefix = TRUE; - } else { - (*argv) += length; - use_prefix = FALSE; - } /* else */ - -/* Parse any necessary arguments */ - - if (arg_count (table[index]) != P_NO_ARGS) { - -/* Now length will be used to store the number of parsed characters */ - - length = arg_parse(*argv, &table[index]); - if (*argv == NULL) - argc = 0; - else if (length >= strlen (*argv)) { - argc--; - argv0 = *++argv; - use_prefix = TRUE; - } else { - (*argv) += length; - use_prefix = FALSE; - } /* else */ - } /* if (argv_count != P_NO_ARGS) */ - else - *arg_result_ptr(table[index]) = - arg_table_size(table[index]); - } /* else */ - } /* while (argc) */ - } /* if (result) */ - - return result; -} /* parse_args */ - - - boolean -#ifdef KR_headers -arg_verify(argv, table, entries) - char **argv; - arg_info *table; - int entries; -#else -arg_verify(char **argv, arg_info *table, int entries) -#endif -{ - int i; - char *this_program = ""; - - if (argv) - this_program = argv[0]; - - for (i = 0; i < entries; i++) { - arg_info *arg = &table[i]; - -/* Check the argument flags */ - - if (arg_flags (*arg) & ~(P_CASE_INSENSITIVE | P_REQUIRED_PREFIX)) { - fprintf (stderr, "%s [arg_verify]: too many ", this_program); - fprintf (stderr, "flags in entry %d: '%x' (hex)\n", i, - arg_flags (*arg)); - badargs++; - } /* if */ - -/* Check the argument count */ - - { int count = arg_count (*arg); - - if (count != P_NO_ARGS && count != P_ONE_ARG && count != - P_INFINITE_ARGS) { - fprintf (stderr, "%s [arg_verify]: invalid ", this_program); - fprintf (stderr, "argument count in entry %d: '%d'\n", i, - count); - badargs++; - } /* if count != P_NO_ARGS ... */ - -/* Check the result field; want to be able to store results */ - - else - if (arg_result_ptr (*arg) == (int *) NULL) { - fprintf (stderr, "%s [arg_verify]: ", this_program); - fprintf (stderr, "no argument storage given for "); - fprintf (stderr, "entry %d\n", i); - badargs++; - } /* if arg_result_ptr */ - } - -/* Check the argument type */ - - { int type = arg_result_type (*arg); - - if (type < P_STRING || type > P_DOUBLE) { - fprintf(stderr, - "%s [arg_verify]: bad arg type in entry %d: '%d'\n", - this_program, i, type); - badargs++; - } - } - -/* Check table size */ - - { int size = arg_table_size (*arg); - - if (arg_count (*arg) == P_INFINITE_ARGS && size < 1) { - fprintf (stderr, "%s [arg_verify]: bad ", this_program); - fprintf (stderr, "table size in entry %d: '%d'\n", i, - size); - badargs++; - } /* if (arg_count == P_INFINITE_ARGS && size < 1) */ - } - - } /* for i = 0 */ - - return TRUE; -} /* arg_verify */ - - -/* match_table -- returns the index of the best entry matching the input, - -1 if no match. The best match is the one of longest length which - appears lowest in the table. The length of the match will be returned - in length ONLY IF a match was found. */ - - int -#ifdef KR_headers -match_table(norm_input, table, entries, use_prefix, length) - register char *norm_input; - arg_info *table; - int entries; - boolean use_prefix; - int *length; -#else -match_table(register char *norm_input, arg_info *table, int entries, boolean use_prefix, int *length) -#endif -{ - char low_input[MAX_INPUT_SIZE]; - register int i; - int best_index = -1, best_length = 0; - -/* FUNCTION BODY */ - - (void) lower_string (low_input, norm_input); - - for (i = 0; i < entries; i++) { - int this_length = match(norm_input, low_input, &table[i], use_prefix); - - if (this_length > best_length) { - best_index = i; - best_length = this_length; - } /* if (this_length > best_length) */ - } /* for (i = 0) */ - - if (best_index > -1 && length != (int *) NULL) - *length = best_length; - - return best_index; -} /* match_table */ - - -/* match -- takes an input string and table entry, and returns the length - of the longer match. - - 0 ==> input doesn't match - - For example: - - INPUT PREFIX STRING RESULT ----------------------------------------------------------------------- - "abcd" "-" "d" 0 - "-d" "-" "d" 2 (i.e. "-d") - "dout" "-" "d" 1 (i.e. "d") - "-d" "" "-d" 2 (i.e. "-d") - "dd" "d" "d" 2 <= here's the weird one -*/ - - static int -#ifdef KR_headers -match(norm_input, low_input, entry, use_prefix) - char *norm_input; - char *low_input; - arg_info *entry; - boolean use_prefix; -#else -match(char *norm_input, char *low_input, arg_info *entry, boolean use_prefix) -#endif -{ - char *norm_prefix = arg_prefix (*entry); - char *norm_string = arg_string (*entry); - boolean prefix_match = FALSE, string_match = FALSE; - int result = 0; - -/* Buffers for the lowercased versions of the strings being compared. - These are used when the switch is to be case insensitive */ - - static char low_prefix[MAX_INPUT_SIZE]; - static char low_string[MAX_INPUT_SIZE]; - int prefix_length = strlen (norm_prefix); - int string_length = strlen (norm_string); - -/* Pointers for the required strings (lowered or nonlowered) */ - - register char *input, *prefix, *string; - -/* FUNCTION BODY */ - -/* Use the appropriate strings to handle case sensitivity */ - - if (arg_flags (*entry) & P_CASE_INSENSITIVE) { - input = low_input; - prefix = lower_string (low_prefix, norm_prefix); - string = lower_string (low_string, norm_string); - } else { - input = norm_input; - prefix = norm_prefix; - string = norm_string; - } /* else */ - -/* First, check the string formed by concatenating the prefix onto the - switch string, but only when the prefix is not being ignored */ - - if (use_prefix && prefix != NULL && *prefix != '\0') - prefix_match = (strncmp (input, prefix, prefix_length) == 0) && - (strncmp (input + prefix_length, string, string_length) == 0); - -/* Next, check just the switch string, if that's allowed */ - - if (!use_prefix && (arg_flags (*entry) & P_REQUIRED_PREFIX) == 0) - string_match = strncmp (input, string, string_length) == 0; - - if (prefix_match) - result = prefix_length + string_length; - else if (string_match) - result = string_length; - - return result; -} /* match */ - - - static char * -#ifdef KR_headers -lower_string(dest, src) - char *dest; - char *src; -#else -lower_string(char *dest, char *src) -#endif -{ - char *result = dest; - register int c; - - if (dest == NULL || src == NULL) - result = NULL; - else - while (*dest++ = (c = *src++) >= 'A' && c <= 'Z' ? tolower(c) : c); - - return result; -} /* lower_string */ - - -/* arg_parse -- returns the number of characters parsed for this entry */ - - static int -#ifdef KR_headers -arg_parse(str, entry) - char *str; - arg_info *entry; -#else -arg_parse(char *str, arg_info *entry) -#endif -{ - int length = 0; - - if (arg_count (*entry) == P_ONE_ARG) { - char **store = (char **) arg_result_ptr (*entry); - - length = put_one_arg (arg_result_type (*entry), str, store, - arg_prefix (*entry), arg_string (*entry)); - - } /* if (arg_count == P_ONE_ARG) */ - else { /* Must be a table of arguments */ - char **store = (char **) arg_result_ptr (*entry); - - if (store) { - while (*store) - store++; - - length = put_one_arg(arg_result_type (*entry), str, store++, - arg_prefix (*entry), arg_string (*entry)); - - *store = (char *) NULL; - } /* if (store) */ - } /* else */ - - return length; -} /* arg_parse */ - - - static int -#ifdef KR_headers -put_one_arg(type, str, store, prefix, string) - int type; - char *str; - char **store; - char *prefix; - char *string; -#else -put_one_arg(int type, char *str, char **store, char *prefix, char *string) -#endif -{ - int length = 0; - long L; - - if (store) { - switch (type) { - case P_STRING: - case P_FILE: - case P_OLD_FILE: - case P_NEW_FILE: - if (str == NULL) { - fprintf(stderr, "%s: Missing argument after '%s%s'\n", - this_program, prefix, string); - length = 0; - badargs++; - } - else - length = strlen(*store = str); - break; - case P_CHAR: - *((char *) store) = *str; - length = 1; - break; - case P_SHORT: - L = atol(str); - *(short *)store = (short) L; - if (L != *(short *)store) { - fprintf(stderr, - "%s%s parameter '%ld' is not a SHORT INT (truncating to %d)\n", - prefix, string, L, *(short *)store); - badargs++; - } - length = strlen (str); - break; - case P_INT: - L = atol(str); - *(int *)store = (int)L; - if (L != *(int *)store) { - fprintf(stderr, - "%s%s parameter '%ld' is not an INT (truncating to %d)\n", - prefix, string, L, *(int *)store); - badargs++; - } - length = strlen (str); - break; - case P_LONG: - *(long *)store = atol(str); - length = strlen (str); - break; - case P_FLOAT: - *((float *) store) = (float) atof(str); - length = strlen (str); - break; - case P_DOUBLE: - *((double *) store) = (double) atof(str); - length = strlen (str); - break; - default: - fprintf (stderr, "put_one_arg: bad type '%d'\n", type); - badargs++; - break; - } /* switch */ - } /* if (store) */ - - return length; -} /* put_one_arg */ - - - void -#ifdef KR_headers -init_store(table, entries) - arg_info *table; - int entries; -#else -init_store(arg_info *table, int entries) -#endif -{ - int index; - - for (index = 0; index < entries; index++) - if (arg_count (table[index]) == P_INFINITE_ARGS) { - char **place = (char **) arg_result_ptr (table[index]); - - if (place) - *place = (char *) NULL; - } /* if arg_count == P_INFINITE_ARGS */ - -} /* init_store */ diff --git a/usr.bin/f2c/pccdefs.h b/usr.bin/f2c/pccdefs.h deleted file mode 100644 index bde81177a7b1..000000000000 --- a/usr.bin/f2c/pccdefs.h +++ /dev/null @@ -1,64 +0,0 @@ -/* The following numbers are strange, and implementation-dependent */ - -#define P2BAD -1 -#define P2NAME 2 -#define P2ICON 4 /* Integer constant */ -#define P2PLUS 6 -#define P2PLUSEQ 7 -#define P2MINUS 8 -#define P2NEG 10 -#define P2STAR 11 -#define P2STAREQ 12 -#define P2INDIRECT 13 -#define P2BITAND 14 -#define P2BITOR 17 -#define P2BITXOR 19 -#define P2QUEST 21 -#define P2COLON 22 -#define P2ANDAND 23 -#define P2OROR 24 -#define P2GOTO 37 -#define P2LISTOP 56 -#define P2ASSIGN 58 -#define P2COMOP 59 -#define P2SLASH 60 -#define P2MOD 62 -#define P2LSHIFT 64 -#define P2RSHIFT 66 -#define P2CALL 70 -#define P2CALL0 72 - -#define P2NOT 76 -#define P2BITNOT 77 -#define P2EQ 80 -#define P2NE 81 -#define P2LE 82 -#define P2LT 83 -#define P2GE 84 -#define P2GT 85 -#define P2REG 94 -#define P2OREG 95 -#define P2CONV 104 -#define P2FORCE 108 -#define P2CBRANCH 109 - -/* special operators included only for fortran's use */ - -#define P2PASS 200 -#define P2STMT 201 -#define P2SWITCH 202 -#define P2LBRACKET 203 -#define P2RBRACKET 204 -#define P2EOF 205 -#define P2ARIF 206 -#define P2LABEL 207 - -#define P2SHORT 3 -#define P2INT 4 -#define P2LONG 4 - -#define P2CHAR 2 -#define P2REAL 6 -#define P2DREAL 7 -#define P2PTR 020 -#define P2FUNCT 040 diff --git a/usr.bin/f2c/pread.c b/usr.bin/f2c/pread.c deleted file mode 100644 index eb1576a8cfaf..000000000000 --- a/usr.bin/f2c/pread.c +++ /dev/null @@ -1,990 +0,0 @@ -/**************************************************************** -Copyright 1990, 1992, 1993, 1994 by AT&T, Lucent Technologies and Bellcore. - -Permission to use, copy, modify, and distribute this software -and its documentation for any purpose and without fee is hereby -granted, provided that the above copyright notice appear in all -copies and that both that the copyright notice and this -permission notice and warranty disclaimer appear in supporting -documentation, and that the names of AT&T, Bell Laboratories, -Lucent or Bellcore or any of their entities not be used in -advertising or publicity pertaining to distribution of the -software without specific, written prior permission. - -AT&T, Lucent and Bellcore disclaim all warranties with regard to -this software, including all implied warranties of -merchantability and fitness. In no event shall AT&T, Lucent or -Bellcore be liable for any special, indirect or consequential -damages or any damages whatsoever resulting from loss of use, -data or profits, whether in an action of contract, negligence or -other tortious action, arising out of or in connection with the -use or performance of this software. -****************************************************************/ - -#include "defs.h" - - static char Ptok[128], Pct[Table_size]; - static char *Pfname; - static long Plineno; - static int Pbad; - static int *tfirst, *tlast, *tnext, tmax; - -#define P_space 1 -#define P_anum 2 -#define P_delim 3 -#define P_slash 4 - -#define TGULP 100 - - static void -trealloc(Void) -{ - int k = tmax; - tfirst = (int *)realloc((char *)tfirst, - (tmax += TGULP)*sizeof(int)); - if (!tfirst) { - fprintf(stderr, - "Pfile: realloc failure!\n"); - exit(2); - } - tlast = tfirst + tmax; - tnext = tfirst + k; - } - - static void -#ifdef KR_headers -badchar(c) - int c; -#else -badchar(int c) -#endif -{ - fprintf(stderr, - "unexpected character 0x%.2x = '%c' on line %ld of %s\n", - c, c, Plineno, Pfname); - exit(2); - } - - static void -bad_type(Void) -{ - fprintf(stderr, - "unexpected type \"%s\" on line %ld of %s\n", - Ptok, Plineno, Pfname); - exit(2); - } - - static void -#ifdef KR_headers -badflag(tname, option) - char *tname; - char *option; -#else -badflag(char *tname, char *option) -#endif -{ - fprintf(stderr, "%s type from `f2c -%s` on line %ld of %s\n", - tname, option, Plineno, Pfname); - Pbad++; - } - - static void -#ifdef KR_headers -detected(msg) - char *msg; -#else -detected(char *msg) -#endif -{ - fprintf(stderr, - "%sdetected on line %ld of %s\n", msg, Plineno, Pfname); - Pbad++; - } - -#if 0 - static void -#ifdef KR_headers -checklogical(k) - int k; -#else -checklogical(int k) -#endif -{ - static int lastmsg = 0; - static int seen[2] = {0,0}; - - seen[k] = 1; - if (seen[1-k]) { - if (lastmsg < 3) { - lastmsg = 3; - detected( - "Illegal combination of LOGICAL types -- mixing -I4 with -I2 or -i2\n\t"); - } - return; - } - if (k) { - if (tylogical == TYLONG || lastmsg >= 2) - return; - if (!lastmsg) { - lastmsg = 2; - badflag("LOGICAL", "I4"); - } - } - else { - if (tylogical == TYSHORT || lastmsg & 1) - return; - if (!lastmsg) { - lastmsg = 1; - badflag("LOGICAL", "i2` or `f2c -I2"); - } - } - } -#else -#define checklogical(n) /* */ -#endif - - static void -#ifdef KR_headers -checkreal(k) - int k; -#else -checkreal(int k) -#endif -{ - static int warned = 0; - static int seen[2] = {0,0}; - - seen[k] = 1; - if (seen[1-k]) { - if (warned < 2) - detected("Illegal mixture of -R and -!R "); - warned = 2; - return; - } - if (k == forcedouble || warned) - return; - warned = 1; - badflag("REAL return", k ? "!R" : "R"); - } - - static void -#ifdef KR_headers -Pnotboth(e) - Extsym *e; -#else -Pnotboth(Extsym *e) -#endif -{ - if (e->curno) - return; - Pbad++; - e->curno = 1; - fprintf(stderr, - "%s cannot be both a procedure and a common block (line %ld of %s)\n", - e->fextname, Plineno, Pfname); - } - - static int -#ifdef KR_headers -numread(pf, n) - register FILE *pf; - int *n; -#else -numread(register FILE *pf, int *n) -#endif -{ - register int c, k; - - if ((c = getc(pf)) < '0' || c > '9') - return c; - k = c - '0'; - for(;;) { - if ((c = getc(pf)) == ' ') { - *n = k; - return c; - } - if (c < '0' || c > '9') - break; - k = 10*k + c - '0'; - } - return c; - } - - static void argverify Argdcl((int, Extsym*)); - static void Pbadret Argdcl((int ftype, Extsym *p)); - - static int -#ifdef KR_headers -readref(pf, e, ftype) - register FILE *pf; - Extsym *e; - int ftype; -#else -readref(register FILE *pf, Extsym *e, int ftype) -#endif -{ - register int c, *t; - int i, nargs, type; - Argtypes *at; - Atype *a, *ae; - - if (ftype > TYSUBR) - return 0; - if ((c = numread(pf, &nargs)) != ' ') { - if (c != ':') - return c == EOF; - /* just a typed external */ - if (e->extstg == STGUNKNOWN) { - at = 0; - goto justsym; - } - if (e->extstg == STGEXT) { - if (e->extype != ftype) - Pbadret(ftype, e); - } - else - Pnotboth(e); - return 0; - } - - tnext = tfirst; - for(i = 0; i < nargs; i++) { - if ((c = numread(pf, &type)) != ' ' - || type >= 500 - || type != TYFTNLEN + 100 && type % 100 > TYSUBR) - return c == EOF; - if (tnext >= tlast) - trealloc(); - *tnext++ = type; - } - - if (e->extstg == STGUNKNOWN) { - save_at: - at = (Argtypes *) - gmem(sizeof(Argtypes) + (nargs-1)*sizeof(Atype), 1); - at->dnargs = at->nargs = nargs; - at->changes = 0; - t = tfirst; - a = at->atypes; - for(ae = a + nargs; a < ae; a++) { - a->type = *t++; - a->cp = 0; - } - justsym: - e->extstg = STGEXT; - e->extype = ftype; - e->arginfo = at; - } - else if (e->extstg != STGEXT) { - Pnotboth(e); - } - else if (!e->arginfo) { - if (e->extype != ftype) - Pbadret(ftype, e); - else - goto save_at; - } - else - argverify(ftype, e); - return 0; - } - - static int -#ifdef KR_headers -comlen(pf) - register FILE *pf; -#else -comlen(register FILE *pf) -#endif -{ - register int c; - register char *s, *se; - char buf[128], cbuf[128]; - int refread; - long L; - Extsym *e; - - if ((c = getc(pf)) == EOF) - return 1; - if (c == ' ') { - refread = 0; - s = "comlen "; - } - else if (c == ':') { - refread = 1; - s = "ref: "; - } - else { - ret0: - if (c == '*') - ungetc(c,pf); - return 0; - } - while(*s) { - if ((c = getc(pf)) == EOF) - return 1; - if (c != *s++) - goto ret0; - } - s = buf; - se = buf + sizeof(buf) - 1; - for(;;) { - if ((c = getc(pf)) == EOF) - return 1; - if (c == ' ') - break; - if (s >= se || Pct[c] != P_anum) - goto ret0; - *s++ = c; - } - *s-- = 0; - if (s <= buf || *s != '_') - return 0; - strcpy(cbuf,buf); - *s-- = 0; - if (*s == '_') { - *s-- = 0; - if (s <= buf) - return 0; - } - for(L = 0;;) { - if ((c = getc(pf)) == EOF) - return 1; - if (c == ' ') - break; - if (c < '0' && c > '9') - goto ret0; - L = 10*L + c - '0'; - } - if (!L && !refread) - return 0; - e = mkext1(buf, cbuf); - if (refread) - return readref(pf, e, (int)L); - if (e->extstg == STGUNKNOWN) { - e->extstg = STGCOMMON; - e->maxleng = L; - } - else if (e->extstg != STGCOMMON) - Pnotboth(e); - else if (e->maxleng != L) { - fprintf(stderr, - "incompatible lengths for common block %s (line %ld of %s)\n", - buf, Plineno, Pfname); - if (e->maxleng < L) - e->maxleng = L; - } - return 0; - } - - static int -#ifdef KR_headers -Ptoken(pf, canend) - FILE *pf; - int canend; -#else -Ptoken(FILE *pf, int canend) -#endif -{ - register int c; - register char *s, *se; - - top: - for(;;) { - c = getc(pf); - if (c == EOF) { - if (canend) - return 0; - goto badeof; - } - if (Pct[c] != P_space) - break; - if (c == '\n') - Plineno++; - } - switch(Pct[c]) { - case P_anum: - if (c == '_') - badchar(c); - s = Ptok; - se = s + sizeof(Ptok) - 1; - do { - if (s < se) - *s++ = c; - if ((c = getc(pf)) == EOF) { - badeof: - fprintf(stderr, - "unexpected end of file in %s\n", - Pfname); - exit(2); - } - } - while(Pct[c] == P_anum); - ungetc(c,pf); - *s = 0; - return P_anum; - - case P_delim: - return c; - - case P_slash: - if ((c = getc(pf)) != '*') { - if (c == EOF) - goto badeof; - badchar('/'); - } - if (canend && comlen(pf)) - goto badeof; - for(;;) { - while((c = getc(pf)) != '*') { - if (c == EOF) - goto badeof; - if (c == '\n') - Plineno++; - } - slashseek: - switch(getc(pf)) { - case '/': - goto top; - case EOF: - goto badeof; - case '*': - goto slashseek; - } - } - default: - badchar(c); - } - /* NOT REACHED */ - return 0; - } - - static int -Pftype(Void) -{ - switch(Ptok[0]) { - case 'C': - if (!strcmp(Ptok+1, "_f")) - return TYCOMPLEX; - break; - case 'E': - if (!strcmp(Ptok+1, "_f")) { - /* TYREAL under forcedouble */ - checkreal(1); - return TYREAL; - } - break; - case 'H': - if (!strcmp(Ptok+1, "_f")) - return TYCHAR; - break; - case 'Z': - if (!strcmp(Ptok+1, "_f")) - return TYDCOMPLEX; - break; - case 'd': - if (!strcmp(Ptok+1, "oublereal")) - return TYDREAL; - break; - case 'i': - if (!strcmp(Ptok+1, "nt")) - return TYSUBR; - if (!strcmp(Ptok+1, "nteger")) - return TYLONG; - if (!strcmp(Ptok+1, "nteger1")) - return TYINT1; - break; - case 'l': - if (!strcmp(Ptok+1, "ogical")) { - checklogical(1); - return TYLOGICAL; - } - if (!strcmp(Ptok+1, "ogical1")) - return TYLOGICAL1; -#ifdef TYQUAD - if (!strcmp(Ptok+1, "ongint")) - return TYQUAD; -#endif - break; - case 'r': - if (!strcmp(Ptok+1, "eal")) { - checkreal(0); - return TYREAL; - } - break; - case 's': - if (!strcmp(Ptok+1, "hortint")) - return TYSHORT; - if (!strcmp(Ptok+1, "hortlogical")) { - checklogical(0); - return TYLOGICAL2; - } - break; - } - bad_type(); - /* NOT REACHED */ - return 0; - } - - static void -#ifdef KR_headers -wanted(i, what) - int i; - char *what; -#else -wanted(int i, char *what) -#endif -{ - if (i != P_anum) { - Ptok[0] = i; - Ptok[1] = 0; - } - fprintf(stderr,"Error: expected %s, not \"%s\" (line %ld of %s)\n", - what, Ptok, Plineno, Pfname); - exit(2); - } - - static int -#ifdef KR_headers -Ptype(pf) - FILE *pf; -#else -Ptype(FILE *pf) -#endif -{ - int i, rv; - - i = Ptoken(pf,0); - if (i == ')') - return 0; - if (i != P_anum) - badchar(i); - - rv = 0; - switch(Ptok[0]) { - case 'C': - if (!strcmp(Ptok+1, "_fp")) - rv = TYCOMPLEX+200; - break; - case 'D': - if (!strcmp(Ptok+1, "_fp")) - rv = TYDREAL+200; - break; - case 'E': - case 'R': - if (!strcmp(Ptok+1, "_fp")) - rv = TYREAL+200; - break; - case 'H': - if (!strcmp(Ptok+1, "_fp")) - rv = TYCHAR+200; - break; - case 'I': - if (!strcmp(Ptok+1, "_fp")) - rv = TYLONG+200; - else if (!strcmp(Ptok+1, "1_fp")) - rv = TYINT1+200; -#ifdef TYQUAD - else if (!strcmp(Ptok+1, "8_fp")) - rv = TYQUAD+200; -#endif - break; - case 'J': - if (!strcmp(Ptok+1, "_fp")) - rv = TYSHORT+200; - break; - case 'K': - checklogical(0); - goto Logical; - case 'L': - checklogical(1); - Logical: - if (!strcmp(Ptok+1, "_fp")) - rv = TYLOGICAL+200; - else if (!strcmp(Ptok+1, "1_fp")) - rv = TYLOGICAL1+200; - else if (!strcmp(Ptok+1, "2_fp")) - rv = TYLOGICAL2+200; - break; - case 'S': - if (!strcmp(Ptok+1, "_fp")) - rv = TYSUBR+200; - break; - case 'U': - if (!strcmp(Ptok+1, "_fp")) - rv = TYUNKNOWN+300; - break; - case 'Z': - if (!strcmp(Ptok+1, "_fp")) - rv = TYDCOMPLEX+200; - break; - case 'c': - if (!strcmp(Ptok+1, "har")) - rv = TYCHAR; - else if (!strcmp(Ptok+1, "omplex")) - rv = TYCOMPLEX; - break; - case 'd': - if (!strcmp(Ptok+1, "oublereal")) - rv = TYDREAL; - else if (!strcmp(Ptok+1, "oublecomplex")) - rv = TYDCOMPLEX; - break; - case 'f': - if (!strcmp(Ptok+1, "tnlen")) - rv = TYFTNLEN+100; - break; - case 'i': - if (!strncmp(Ptok+1, "nteger", 6)) { - if (!Ptok[7]) - rv = TYLONG; - else if (Ptok[7] == '1' && !Ptok[8]) - rv = TYINT1; - } - break; - case 'l': - if (!strncmp(Ptok+1, "ogical", 6)) { - if (!Ptok[7]) { - checklogical(1); - rv = TYLOGICAL; - } - else if (Ptok[7] == '1' && !Ptok[8]) - rv = TYLOGICAL1; - } -#ifdef TYQUAD - else if (!strcmp(Ptok+1,"ongint")) - rv = TYQUAD; -#endif - break; - case 'r': - if (!strcmp(Ptok+1, "eal")) - rv = TYREAL; - break; - case 's': - if (!strcmp(Ptok+1, "hortint")) - rv = TYSHORT; - else if (!strcmp(Ptok+1, "hortlogical")) { - checklogical(0); - rv = TYLOGICAL2; - } - break; - case 'v': - if (tnext == tfirst && !strcmp(Ptok+1, "oid")) { - if ((i = Ptoken(pf,0)) != /*(*/ ')') - wanted(i, /*(*/ "\")\""); - return 0; - } - } - if (!rv) - bad_type(); - if (rv < 100 && (i = Ptoken(pf,0)) != '*') - wanted(i, "\"*\""); - if ((i = Ptoken(pf,0)) == P_anum) - i = Ptoken(pf,0); /* skip variable name */ - switch(i) { - case ')': - ungetc(i,pf); - break; - case ',': - break; - default: - wanted(i, "\",\" or \")\""); - } - return rv; - } - - static char * -trimunder(Void) -{ - register char *s; - register int n; - static char buf[128]; - - s = Ptok + strlen(Ptok) - 1; - if (*s != '_') { - fprintf(stderr, - "warning: %s does not end in _ (line %ld of %s)\n", - Ptok, Plineno, Pfname); - return Ptok; - } - if (s[-1] == '_') - s--; - strncpy(buf, Ptok, n = s - Ptok); - buf[n] = 0; - return buf; - } - - static void -#ifdef KR_headers -Pbadmsg(msg, p) - char *msg; - Extsym *p; -#else -Pbadmsg(char *msg, Extsym *p) -#endif -{ - Pbad++; - fprintf(stderr, "%s for %s (line %ld of %s):\n\t", msg, - p->fextname, Plineno, Pfname); - p->arginfo->nargs = -1; - } - - static void -#ifdef KR_headers -Pbadret(ftype, p) - int ftype; - Extsym *p; -#else -Pbadret(int ftype, Extsym *p) -#endif -{ - char buf1[32], buf2[32]; - - Pbadmsg("inconsistent types",p); - fprintf(stderr, "here %s, previously %s\n", - Argtype(ftype+200,buf1), - Argtype(p->extype+200,buf2)); - } - - static void -#ifdef KR_headers -argverify(ftype, p) - int ftype; - Extsym *p; -#else -argverify(int ftype, Extsym *p) -#endif -{ - Argtypes *at; - register Atype *aty; - int i, j, k; - register int *t, *te; - char buf1[32], buf2[32]; - - at = p->arginfo; - if (at->nargs < 0) - return; - if (p->extype != ftype) { - Pbadret(ftype, p); - return; - } - t = tfirst; - te = tnext; - i = te - t; - if (at->nargs != i) { - j = at->nargs; - Pbadmsg("differing numbers of arguments",p); - fprintf(stderr, "here %d, previously %d\n", - i, j); - return; - } - for(aty = at->atypes; t < te; t++, aty++) { - if (*t == aty->type) - continue; - j = aty->type; - k = *t; - if (k >= 300 || k == j) - continue; - if (j >= 300) { - if (k >= 200) { - if (k == TYUNKNOWN + 200) - continue; - if (j % 100 != k - 200 - && k != TYSUBR + 200 - && j != TYUNKNOWN + 300 - && !type_fixup(at,aty,k)) - goto badtypes; - } - else if (j % 100 % TYSUBR != k % TYSUBR - && !type_fixup(at,aty,k)) - goto badtypes; - } - else if (k < 200 || j < 200) - goto badtypes; - else if (k == TYUNKNOWN+200) - continue; - else if (j != TYUNKNOWN+200) - { - badtypes: - Pbadmsg("differing calling sequences",p); - i = t - tfirst + 1; - fprintf(stderr, - "arg %d: here %s, prevously %s\n", - i, Argtype(k,buf1), Argtype(j,buf2)); - return; - } - /* We've subsequently learned the right type, - as in the call on zoo below... - - subroutine foo(x, zap) - external zap - call goo(zap) - x = zap(3) - call zoo(zap) - end - */ - aty->type = k; - at->changes = 1; - } - } - - static void -#ifdef KR_headers -newarg(ftype, p) - int ftype; - Extsym *p; -#else -newarg(int ftype, Extsym *p) -#endif -{ - Argtypes *at; - register Atype *aty; - register int *t, *te; - int i, k; - - if (p->extstg == STGCOMMON) { - Pnotboth(p); - return; - } - p->extstg = STGEXT; - p->extype = ftype; - p->exproto = 1; - t = tfirst; - te = tnext; - i = te - t; - k = sizeof(Argtypes) + (i-1)*sizeof(Atype); - at = p->arginfo = (Argtypes *)gmem(k,1); - at->dnargs = at->nargs = i; - at->defined = at->changes = 0; - for(aty = at->atypes; t < te; aty++) { - aty->type = *t++; - aty->cp = 0; - } - } - - static int -#ifdef KR_headers -Pfile(fname) - char *fname; -#else -Pfile(char *fname) -#endif -{ - char *s; - int ftype, i; - FILE *pf; - Extsym *p; - - for(s = fname; *s; s++); - if (s - fname < 2 - || s[-2] != '.' - || (s[-1] != 'P' && s[-1] != 'p')) - return 0; - - if (!(pf = fopen(fname, textread))) { - fprintf(stderr, "can't open %s\n", fname); - exit(2); - } - Pfname = fname; - Plineno = 1; - if (!Pct[' ']) { - for(s = " \t\n\r\v\f"; *s; s++) - Pct[*s] = P_space; - for(s = "*,();"; *s; s++) - Pct[*s] = P_delim; - for(i = '0'; i <= '9'; i++) - Pct[i] = P_anum; - for(s = "abcdefghijklmnopqrstuvwxyz"; i = *s; s++) - Pct[i] = Pct[i+'A'-'a'] = P_anum; - Pct['_'] = P_anum; - Pct['/'] = P_slash; - } - - for(;;) { - if (!(i = Ptoken(pf,1))) - break; - if (i != P_anum - || !strcmp(Ptok, "extern") && (i = Ptoken(pf,0)) != P_anum) - badchar(i); - ftype = Pftype(); - getname: - if ((i = Ptoken(pf,0)) != P_anum) - badchar(i); - p = mkext1(trimunder(), Ptok); - - if ((i = Ptoken(pf,0)) != '(') - badchar(i); - tnext = tfirst; - while(i = Ptype(pf)) { - if (tnext >= tlast) - trealloc(); - *tnext++ = i; - } - if (p->arginfo) { - argverify(ftype, p); - if (p->arginfo->nargs < 0) - newarg(ftype, p); - } - else - newarg(ftype, p); - p->arginfo->defined = 1; - i = Ptoken(pf,0); - switch(i) { - case ';': - break; - case ',': - goto getname; - default: - wanted(i, "\";\" or \",\""); - } - } - fclose(pf); - return 1; - } - - void -#ifdef KR_headers -read_Pfiles(ffiles) - char **ffiles; -#else -read_Pfiles(char **ffiles) -#endif -{ - char **f1files, **f1files0, *s; - int k; - register Extsym *e, *ee; - register Argtypes *at; - extern int retcode; - - f1files0 = f1files = ffiles; - while(s = *ffiles++) - if (!Pfile(s)) - *f1files++ = s; - if (Pbad) - retcode = 8; - if (tfirst) { - free((char *)tfirst); - /* following should be unnecessary, as we won't be back here */ - tfirst = tnext = tlast = 0; - tmax = 0; - } - *f1files = 0; - if (f1files == f1files0) - f1files[1] = 0; - - k = 0; - ee = nextext; - for (e = extsymtab; e < ee; e++) - if (e->extstg == STGEXT - && (at = e->arginfo)) { - if (at->nargs < 0 || at->changes) - k++; - at->changes = 2; - } - if (k) { - fprintf(diagfile, - "%d prototype%s updated while reading prototypes.\n", k, - k > 1 ? "s" : ""); - } - fflush(diagfile); - } diff --git a/usr.bin/f2c/proc.c b/usr.bin/f2c/proc.c deleted file mode 100644 index e3afb81ef5fd..000000000000 --- a/usr.bin/f2c/proc.c +++ /dev/null @@ -1,1829 +0,0 @@ -/**************************************************************** -Copyright 1990, 1994-6 by AT&T, Lucent Technologies and Bellcore. - -Permission to use, copy, modify, and distribute this software -and its documentation for any purpose and without fee is hereby -granted, provided that the above copyright notice appear in all -copies and that both that the copyright notice and this -permission notice and warranty disclaimer appear in supporting -documentation, and that the names of AT&T, Bell Laboratories, -Lucent or Bellcore or any of their entities not be used in -advertising or publicity pertaining to distribution of the -software without specific, written prior permission. - -AT&T, Lucent and Bellcore disclaim all warranties with regard to -this software, including all implied warranties of -merchantability and fitness. In no event shall AT&T, Lucent or -Bellcore be liable for any special, indirect or consequential -damages or any damages whatsoever resulting from loss of use, -data or profits, whether in an action of contract, negligence or -other tortious action, arising out of or in connection with the -use or performance of this software. -****************************************************************/ - -#include "defs.h" -#include "names.h" -#include "output.h" -#include "p1defs.h" - -/* round a up to the nearest multiple of b: - - a = b * floor ( (a + (b - 1)) / b )*/ - -#undef roundup -#define roundup(a,b) ( b * ( (a+b-1)/b) ) - -#define EXNULL (union Expression *)0 - -static void dobss Argdcl((void)); -static void docomleng Argdcl((void)); -static void docommon Argdcl((void)); -static void doentry Argdcl((struct Entrypoint*)); -static void epicode Argdcl((void)); -static int nextarg Argdcl((int)); -static void retval Argdcl((int)); - -static char Blank[] = BLANKCOMMON; - - static char *postfix[] = { "g", "h", "i", -#ifdef TYQUAD - "j", -#endif - "r", "d", "c", "z", "g", "h", "i" }; - - chainp new_procs; - int prev_proc, proc_argchanges, proc_protochanges; - - void -#ifdef KR_headers -changedtype(q) - Namep q; -#else -changedtype(Namep q) -#endif -{ - char buf[200]; - int qtype, type1; - register Extsym *e; - Argtypes *at; - - if (q->vtypewarned) - return; - q->vtypewarned = 1; - qtype = q->vtype; - e = &extsymtab[q->vardesc.varno]; - if (!(at = e->arginfo)) { - if (!e->exused) - return; - } - else if (at->changes & 2 && qtype != TYUNKNOWN && !at->defined) - proc_protochanges++; - type1 = e->extype; - if (type1 == TYUNKNOWN) - return; - if (qtype == TYUNKNOWN) - /* e.g., - subroutine foo - end - external foo - call goo(foo) - end - */ - return; - sprintf(buf, "%.90s: inconsistent declarations:\n\ - here %s%s, previously %s%s.", q->fvarname, ftn_types[qtype], - qtype == TYSUBR ? "" : " function", - ftn_types[type1], type1 == TYSUBR ? "" : " function"); - warn(buf); - } - - void -#ifdef KR_headers -unamstring(q, s) - register Addrp q; - register char *s; -#else -unamstring(register Addrp q, register char *s) -#endif -{ - register int k; - register char *t; - - k = strlen(s); - if (k < IDENT_LEN) { - q->uname_tag = UNAM_IDENT; - t = q->user.ident; - } - else { - q->uname_tag = UNAM_CHARP; - q->user.Charp = t = mem(k+1, 0); - } - strcpy(t, s); - } - - static void -fix_entry_returns(Void) /* for multiple entry points */ -{ - Addrp a; - int i; - struct Entrypoint *e; - Namep np; - - e = entries = (struct Entrypoint *)revchain((chainp)entries); - allargs = revchain(allargs); - if (!multitype) - return; - - /* TYLOGICAL should have been turned into TYLONG or TYSHORT by now */ - - for(i = TYINT1; i <= TYLOGICAL; i++) - if (a = xretslot[i]) - sprintf(a->user.ident, "(*ret_val).%s", - postfix[i-TYINT1]); - - do { - np = e->enamep; - switch(np->vtype) { - case TYINT1: - case TYSHORT: - case TYLONG: -#ifdef TYQUAD - case TYQUAD: -#endif - case TYREAL: - case TYDREAL: - case TYCOMPLEX: - case TYDCOMPLEX: - case TYLOGICAL1: - case TYLOGICAL2: - case TYLOGICAL: - np->vstg = STGARG; - } - } - while(e = e->entnextp); - } - - static void -#ifdef KR_headers -putentries(outfile) - FILE *outfile; -#else -putentries(FILE *outfile) -#endif - /* put out wrappers for multiple entries */ -{ - char base[MAXNAMELEN+4]; - struct Entrypoint *e; - Namep *A, *Ae, *Ae1, **Alp, *a, **a1, np; - chainp args, lengths; - int i, k, mt, nL, t, type; - extern char *dfltarg[], **dfltproc; - - e = entries; - if (!e->enamep) /* only possible with erroneous input */ - return; - nL = (nallargs + nallchargs) * sizeof(Namep *); - A = (Namep *)ckalloc(nL + nallargs*sizeof(Namep **)); - Ae = A + nallargs; - Alp = (Namep **)(Ae1 = Ae + nallchargs); - i = k = 0; - for(a1 = Alp, args = allargs; args; a1++, args = args->nextp) { - np = (Namep)args->datap; - if (np->vtype == TYCHAR && np->vclass != CLPROC) - *a1 = &Ae[i++]; - } - - mt = multitype; - multitype = 0; - sprintf(base, "%s0_", e->enamep->cvarname); - do { - np = e->enamep; - lengths = length_comp(e, 0); - proctype = type = np->vtype; - if (protofile) - protowrite(protofile, type, np->cvarname, e, lengths); - nice_printf(outfile, "\n%s ", c_type_decl(type, 1)); - nice_printf(outfile, "%s", np->cvarname); - if (!Ansi) { - listargs(outfile, e, 0, lengths); - nice_printf(outfile, "\n"); - } - list_arg_types(outfile, e, lengths, 0, "\n"); - nice_printf(outfile, "{\n"); - frchain(&lengths); - next_tab(outfile); - if (mt) - nice_printf(outfile, - "Multitype ret_val;\n%s(%d, &ret_val", - base, k); /*)*/ - else if (ISCOMPLEX(type)) - nice_printf(outfile, "%s(%d,%s", base, k, - xretslot[type]->user.ident); /*)*/ - else if (type == TYCHAR) - nice_printf(outfile, - "%s(%d, ret_val, ret_val_len", base, k); /*)*/ - else - nice_printf(outfile, "return %s(%d", base, k); /*)*/ - k++; - memset((char *)A, 0, nL); - for(args = e->arglist; args; args = args->nextp) { - np = (Namep)args->datap; - A[np->argno] = np; - if (np->vtype == TYCHAR && np->vclass != CLPROC) - *Alp[np->argno] = np; - } - args = allargs; - for(a = A; a < Ae; a++, args = args->nextp) { - t = ((Namep)args->datap)->vtype; - nice_printf(outfile, ", %s", (np = *a) - ? np->cvarname - : ((Namep)args->datap)->vclass == CLPROC - ? dfltproc[((Namep)args->datap)->vimpltype - ? (Castargs ? TYUNKNOWN : TYSUBR) - : t == TYREAL && forcedouble && !Castargs - ? TYDREAL : t] - : dfltarg[((Namep)args->datap)->vtype]); - } - for(; a < Ae1; a++) - if (np = *a) - nice_printf(outfile, ", %s", - new_arg_length(np)); - else - nice_printf(outfile, ", (ftnint)0"); - nice_printf(outfile, /*(*/ ");\n"); - if (mt) { - if (type == TYCOMPLEX) - nice_printf(outfile, - "r_v->r = ret_val.c.r; r_v->i = ret_val.c.i;\n"); - else if (type == TYDCOMPLEX) - nice_printf(outfile, - "r_v->r = ret_val.z.r; r_v->i = ret_val.z.i;\n"); - else if (type <= TYLOGICAL) - nice_printf(outfile, "return ret_val.%s;\n", - postfix[type-TYINT1]); - } - nice_printf(outfile, "}\n"); - prev_tab(outfile); - } - while(e = e->entnextp); - free((char *)A); - } - - static void -#ifdef KR_headers -entry_goto(outfile) - FILE *outfile; -#else -entry_goto(FILE *outfile) -#endif -{ - struct Entrypoint *e = entries; - int k = 0; - - nice_printf(outfile, "switch(n__) {\n"); - next_tab(outfile); - while(e = e->entnextp) - nice_printf(outfile, "case %d: goto %s;\n", ++k, - user_label((long)(extsymtab - e->entryname - 1))); - nice_printf(outfile, "}\n\n"); - prev_tab(outfile); - } - -/* start a new procedure */ - - void -newproc(Void) -{ - if(parstate != OUTSIDE) - { - execerr("missing end statement", CNULL); - endproc(); - } - - parstate = INSIDE; - procclass = CLMAIN; /* default */ -} - - static void -zap_changes(Void) -{ - register chainp cp; - register Argtypes *at; - - /* arrange to get correct count of prototypes that would - change by running f2c again */ - - if (prev_proc && proc_argchanges) - proc_protochanges++; - prev_proc = proc_argchanges = 0; - for(cp = new_procs; cp; cp = cp->nextp) - if (at = ((Namep)cp->datap)->arginfo) - at->changes &= ~1; - frchain(&new_procs); - } - -/* end of procedure. generate variables, epilogs, and prologs */ - - void -endproc(Void) -{ - struct Labelblock *lp; - Extsym *ext; - - if(parstate < INDATA) - enddcl(); - if(ctlstack >= ctls) - err("DO loop or BLOCK IF not closed"); - for(lp = labeltab ; lp < labtabend ; ++lp) - if(lp->stateno!=0 && lp->labdefined==NO) - errstr("missing statement label %s", - convic(lp->stateno) ); - -/* Save copies of the common variables in extptr -> allextp */ - - for (ext = extsymtab; ext < nextext; ext++) - if (ext -> extstg == STGCOMMON && ext -> extp) { - extern int usedefsforcommon; - -/* Write out the abbreviations for common block reference */ - - copy_data (ext -> extp); - if (usedefsforcommon) { - wr_abbrevs (c_file, 1, ext -> extp); - ext -> used_here = 1; - } - else - ext -> extp = CHNULL; - - } - - if (nentry > 1) - fix_entry_returns(); - epicode(); - donmlist(); - dobss(); - start_formatting (); - if (nentry > 1) - putentries(c_file); - - zap_changes(); - procinit(); /* clean up for next procedure */ -} - - - -/* End of declaration section of procedure. Allocate storage. */ - - void -enddcl(Void) -{ - register struct Entrypoint *ep; - struct Entrypoint *ep0; - chainp cp; - extern char *err_proc; - static char comblks[] = "common blocks"; - - err_proc = comblks; - docommon(); - -/* Now the hash table entries for fields of common blocks have STGCOMMON, - vdcldone, voffset, and varno. And the common blocks themselves have - their full sizes in extleng. */ - - err_proc = "equivalences"; - doequiv(); - - err_proc = comblks; - docomleng(); - -/* This implies that entry points in the declarations are buffered in - entries but not written out */ - - err_proc = "entries"; - if (ep = ep0 = (struct Entrypoint *)revchain((chainp)entries)) { - /* entries could be 0 in case of an error */ - do doentry(ep); - while(ep = ep->entnextp); - entries = (struct Entrypoint *)revchain((chainp)ep0); - } - - err_proc = 0; - parstate = INEXEC; - p1put(P1_PROCODE); - freetemps(); - if (earlylabs) { - for(cp = earlylabs = revchain(earlylabs); cp; cp = cp->nextp) - p1_label((long)cp->datap); - frchain(&earlylabs); - } - p1_line_number(lineno); /* for files that start with a MAIN program */ - /* that starts with an executable statement */ -} - -/* ROUTINES CALLED WHEN ENCOUNTERING ENTRY POINTS */ - -/* Main program or Block data */ - - void -#ifdef KR_headers -startproc(progname, class) - Extsym *progname; - int class; -#else -startproc(Extsym *progname, int class) -#endif -{ - extern flag echo; - - register struct Entrypoint *p; - - p = ALLOC(Entrypoint); - if(class == CLMAIN) { - puthead(CNULL, CLMAIN); - if (progname) - strcpy (main_alias, progname->cextname); - } else { - if (progname) { - /* Construct an empty subroutine with this name */ - /* in case the name is needed to force loading */ - /* of this block-data subprogram: the name can */ - /* appear elsewhere in an external statement. */ - entrypt(CLPROC, TYSUBR, (ftnint)0, progname, (chainp)0); - endproc(); - newproc(); - } - puthead(CNULL, CLBLOCK); - } - if(class == CLMAIN) - newentry( mkname(" MAIN"), 0 )->extinit = 1; - p->entryname = progname; - entries = p; - - procclass = class; - if (echo) { - fprintf(diagfile, " %s", (class==CLMAIN ? "MAIN" : "BLOCK DATA") ); - if(progname) { - fprintf(diagfile, " %s", progname->fextname); - procname = progname->cextname; - } - fprintf(diagfile, ":\n"); - fflush(diagfile); - } -} - -/* subroutine or function statement */ - - Extsym * -#ifdef KR_headers -newentry(v, substmsg) - register Namep v; - int substmsg; -#else -newentry(register Namep v, int substmsg) -#endif -{ - register Extsym *p; - char buf[128], badname[64]; - static int nbad = 0; - static char already[] = "external name already used"; - - p = mkext(v->fvarname, addunder(v->cvarname)); - - if(p->extinit || ! ONEOF(p->extstg, M(STGUNKNOWN)|M(STGEXT)) ) - { - sprintf(badname, "%s_bad%d", v->fvarname, ++nbad); - if (substmsg) { - sprintf(buf,"%s\n\tsubstituting \"%s\"", - already, badname); - dclerr(buf, v); - } - else - dclerr(already, v); - p = mkext(v->fvarname, badname); - } - v->vstg = STGAUTO; - v->vprocclass = PTHISPROC; - v->vclass = CLPROC; - if (p->extstg == STGEXT) - prev_proc = 1; - else - p->extstg = STGEXT; - p->extinit = YES; - v->vardesc.varno = p - extsymtab; - return(p); -} - - void -#ifdef KR_headers -entrypt(class, type, length, entry, args) - int class; - int type; - ftnint length; - Extsym *entry; - chainp args; -#else -entrypt(int class, int type, ftnint length, Extsym *entry, chainp args) -#endif -{ - extern flag echo; - - register Namep q; - register struct Entrypoint *p; - - if(class != CLENTRY) - puthead( procname = entry->cextname, class); - else if (echo) - fprintf(diagfile, " entry "); - if (echo){ - fprintf(diagfile, " %s:\n", entry->fextname); - fflush(diagfile); - } - q = mkname(entry->fextname); - if (type == TYSUBR) - q->vstg = STGEXT; - - type = lengtype(type, length); - if(class == CLPROC) - { - procclass = CLPROC; - proctype = type; - procleng = type == TYCHAR ? length : 0; - } - - p = ALLOC(Entrypoint); - - p->entnextp = entries; - entries = p; - - p->entryname = entry; - p->arglist = revchain(args); - p->enamep = q; - - if(class == CLENTRY) - { - class = CLPROC; - if(proctype == TYSUBR) - type = TYSUBR; - } - - q->vclass = class; - q->vprocclass = 0; - settype(q, type, length); - q->vprocclass = PTHISPROC; - /* hold all initial entry points till end of declarations */ - if(parstate >= INDATA) - doentry(p); -} - -/* generate epilogs */ - -/* epicode -- write out the proper function return mechanism at the end of - the procedure declaration. Handles multiple return value types, as - well as cooercion into the proper value */ - - LOCAL void -epicode(Void) -{ - extern int lastwasbranch; - - if(procclass==CLPROC) - { - if(proctype==TYSUBR) - { - -/* Return a zero only when the alternate return mechanism has been - specified in the function header */ - - if ((substars || Ansi) && lastwasbranch != YES) - p1_subr_ret (ICON(0)); - } - else if (!multitype && lastwasbranch != YES) - retval(proctype); - } - else if (procclass == CLMAIN && Ansi && lastwasbranch != YES) - p1_subr_ret (ICON(0)); - lastwasbranch = NO; -} - - -/* generate code to return value of type t */ - - LOCAL void -#ifdef KR_headers -retval(t) - register int t; -#else -retval(register int t) -#endif -{ - register Addrp p; - - switch(t) - { - case TYCHAR: - case TYCOMPLEX: - case TYDCOMPLEX: - break; - - case TYLOGICAL: - t = tylogical; - case TYINT1: - case TYADDR: - case TYSHORT: - case TYLONG: -#ifdef TYQUAD - case TYQUAD: -#endif - case TYREAL: - case TYDREAL: - case TYLOGICAL1: - case TYLOGICAL2: - p = (Addrp) cpexpr((expptr)retslot); - p->vtype = t; - p1_subr_ret (mkconv (t, fixtype((expptr)p))); - break; - - default: - badtype("retval", t); - } -} - - -/* Do parameter adjustments */ - - void -#ifdef KR_headers -procode(outfile) - FILE *outfile; -#else -procode(FILE *outfile) -#endif -{ - prolog(outfile, allargs); - - if (nentry > 1) - entry_goto(outfile); - } - - static void -#ifdef KR_headers -bad_dimtype(q) Namep q; -#else -bad_dimtype(Namep q) -#endif -{ - errstr("bad dimension type for %.70s", q->fvarname); - } - -/* Finish bound computations now that all variables are declared. - * This used to be in setbound(), but under -u the following incurred - * an erroneous error message: - * subroutine foo(x,n) - * real x(n) - * integer n - */ - - static void -#ifdef KR_headers -dim_finish(v) - Namep v; -#else -dim_finish(Namep v) -#endif -{ - register struct Dimblock *p; - register expptr q; - register int i, nd; - - p = v->vdim; - v->vdimfinish = 0; - nd = p->ndim; - doin_setbound = 1; - for(i = 0; i < nd; i++) - if (q = p->dims[i].dimexpr) { - q = p->dims[i].dimexpr = make_int_expr(putx(fixtype(q))); - if (!ONEOF(q->headblock.vtype, MSKINT|MSKREAL)) - bad_dimtype(v); - } - if (q = p->basexpr) - p->basexpr = make_int_expr(putx(fixtype(q))); - doin_setbound = 0; - } - - static void -#ifdef KR_headers -duparg(q) - Namep q; -#else -duparg(Namep q) -#endif -{ errstr("duplicate argument %.80s", q->fvarname); } - -/* - manipulate argument lists (allocate argument slot positions) - * keep track of return types and labels - */ - - LOCAL void -#ifdef KR_headers -doentry(ep) - struct Entrypoint *ep; -#else -doentry(struct Entrypoint *ep) -#endif -{ - register int type; - register Namep np; - chainp p, p1; - register Namep q; - Addrp rs; - int it, k; - extern char dflttype[26]; - Extsym *entryname = ep->entryname; - - if (++nentry > 1) - p1_label((long)(extsymtab - entryname - 1)); - -/* The main program isn't allowed to have parameters, so any given - parameters are ignored */ - - if(procclass == CLMAIN || procclass == CLBLOCK) - return; - -/* So now we're working with something other than CLMAIN or CLBLOCK. - Determine the type of its return value. */ - - impldcl( np = mkname(entryname->fextname) ); - type = np->vtype; - proc_argchanges = prev_proc && type != entryname->extype; - entryname->extseen = 1; - if(proctype == TYUNKNOWN) - if( (proctype = type) == TYCHAR) - procleng = np->vleng ? np->vleng->constblock.Const.ci - : (ftnint) (-1); - - if(proctype == TYCHAR) - { - if(type != TYCHAR) - err("noncharacter entry of character function"); - -/* Functions returning type char can only have multiple entries if all - entries return the same length */ - - else if( (np->vleng ? np->vleng->constblock.Const.ci : - (ftnint) (-1)) != procleng) - err("mismatched character entry lengths"); - } - else if(type == TYCHAR) - err("character entry of noncharacter function"); - else if(type != proctype) - multitype = YES; - if(rtvlabel[type] == 0) - rtvlabel[type] = (int)newlabel(); - ep->typelabel = rtvlabel[type]; - - if(type == TYCHAR) - { - if(chslot < 0) - { - chslot = nextarg(TYADDR); - chlgslot = nextarg(TYLENG); - } - np->vstg = STGARG; - -/* Put a new argument in the function, one which will hold the result of - a character function. This will have to be named sometime, probably in - mkarg(). */ - - if(procleng < 0) { - np->vleng = (expptr) mkarg(TYLENG, chlgslot); - np->vleng->addrblock.uname_tag = UNAM_IDENT; - strcpy (np -> vleng -> addrblock.user.ident, - new_func_length()); - } - if (!xretslot[TYCHAR]) { - xretslot[TYCHAR] = rs = - autovar(0, type, ISCONST(np->vleng) - ? np->vleng : ICON(0), ""); - strcpy(rs->user.ident, "ret_val"); - } - } - -/* Handle a complex return type -- declare a new parameter (pointer to - a complex value) */ - - else if( ISCOMPLEX(type) ) { - if (!xretslot[type]) - xretslot[type] = - autovar(0, type, EXNULL, " ret_val"); - /* the blank is for use in out_addr */ - np->vstg = STGARG; - if(cxslot < 0) - cxslot = nextarg(TYADDR); - } - else if (type != TYSUBR) { - if (type == TYUNKNOWN) { - dclerr("untyped function", np); - proctype = type = np->vtype = - dflttype[letter(np->fvarname[0])]; - } - if (!xretslot[type]) - xretslot[type] = retslot = - autovar(1, type, EXNULL, " ret_val"); - /* the blank is for use in out_addr */ - np->vstg = STGAUTO; - } - - for(p = ep->arglist ; p ; p = p->nextp) - if(! (( q = (Namep) (p->datap) )->vknownarg) ) { - q->vknownarg = 1; - q->vardesc.varno = nextarg(TYADDR); - allargs = mkchain((char *)q, allargs); - q->argno = nallargs++; - } - else if (nentry == 1) - duparg(q); - else for(p1 = ep->arglist ; p1 != p; p1 = p1->nextp) - if ((Namep)p1->datap == q) - duparg(q); - - k = 0; - for(p = ep->arglist ; p ; p = p->nextp) { - if(! (( q = (Namep) (p->datap) )->vdcldone) ) - { - impldcl(q); - q->vdcldone = YES; - if(q->vtype == TYCHAR) - { - -/* If we don't know the length of a char*(*) (i.e. a string), we must add - in this additional length argument. */ - - ++nallchargs; - if (q->vclass == CLPROC) - nallchargs--; - else if (q->vleng == NULL) { - /* character*(*) */ - q->vleng = (expptr) - mkarg(TYLENG, nextarg(TYLENG) ); - unamstring((Addrp)q->vleng, - new_arg_length(q)); - } - } - } - if (q->vdimfinish) - dim_finish(q); - if (q->vtype == TYCHAR && q->vclass != CLPROC) - k++; - } - - if (entryname->extype != type) - changedtype(np); - - /* save information for checking consistency of arg lists */ - - it = infertypes; - if (entryname->exproto) - infertypes = 1; - save_argtypes(ep->arglist, &entryname->arginfo, &np->arginfo, - 0, np->fvarname, STGEXT, k, np->vtype, 2); - infertypes = it; -} - - - - LOCAL int -#ifdef KR_headers -nextarg(type) - int type; -#else -nextarg(int type) -#endif -{ - type = type; /* shut up warning */ - return(lastargslot++); - } - - LOCAL void -#ifdef KR_headers -dim_check(q) - Namep q; -#else -dim_check(Namep q) -#endif -{ - register struct Dimblock *vdim = q->vdim; - register expptr nelt; - - if(!(nelt = vdim->nelt) || !ISCONST(nelt)) - dclerr("adjustable dimension on non-argument", q); - else if (!ONEOF(nelt->headblock.vtype, MSKINT|MSKREAL)) - bad_dimtype(q); - else if (ISINT(nelt->headblock.vtype) - ? nelt->constblock.Const.ci <= 0 - : nelt->constblock.Const.cd[0] <= 0.) - dclerr("nonpositive dimension", q); - } - - LOCAL void -dobss(Void) -{ - register struct Hashentry *p; - register Namep q; - int qstg, qclass, qtype; - Extsym *e; - - for(p = hashtab ; p<lasthash ; ++p) - if(q = p->varp) - { - qstg = q->vstg; - qtype = q->vtype; - qclass = q->vclass; - - if( (qclass==CLUNKNOWN && qstg!=STGARG) || - (qclass==CLVAR && qstg==STGUNKNOWN) ) { - if (!(q->vis_assigned | q->vimpldovar)) - warn1("local variable %s never used", - q->fvarname); - } - else if(qclass==CLVAR && qstg==STGBSS) - { ; } - -/* Give external procedures the proper storage class */ - - else if(qclass==CLPROC && q->vprocclass==PEXTERNAL - && qstg!=STGARG) { - e = mkext(q->fvarname,addunder(q->cvarname)); - e->extstg = STGEXT; - q->vardesc.varno = e - extsymtab; - if (e->extype != qtype) - changedtype(q); - } - if(qclass==CLVAR) { - if (qstg != STGARG && q->vdim) - dim_check(q); - } /* if qclass == CLVAR */ - } - -} - - - void -donmlist(Void) -{ - register struct Hashentry *p; - register Namep q; - - for(p=hashtab; p<lasthash; ++p) - if( (q = p->varp) && q->vclass==CLNAMELIST) - namelist(q); -} - - -/* iarrlen -- Returns the size of the array in bytes, or -1 */ - - ftnint -#ifdef KR_headers -iarrlen(q) - register Namep q; -#else -iarrlen(register Namep q) -#endif -{ - ftnint leng; - - leng = typesize[q->vtype]; - if(leng <= 0) - return(-1); - if(q->vdim) - if( ISICON(q->vdim->nelt) ) - leng *= q->vdim->nelt->constblock.Const.ci; - else return(-1); - if(q->vleng) - if( ISICON(q->vleng) ) - leng *= q->vleng->constblock.Const.ci; - else return(-1); - return(leng); -} - - void -#ifdef KR_headers -namelist(np) - Namep np; -#else -namelist(Namep np) -#endif -{ - register chainp q; - register Namep v; - int y; - - if (!np->visused) - return; - y = 0; - - for(q = np->varxptr.namelist ; q ; q = q->nextp) - { - vardcl( v = (Namep) (q->datap) ); - if( !ONEOF(v->vstg, MSKSTATIC) ) - dclerr("may not appear in namelist", v); - else { - v->vnamelist = 1; - v->visused = 1; - v->vsave = 1; - y = 1; - } - np->visused = y; - } -} - -/* docommon -- called at the end of procedure declarations, before - equivalences and the procedure body */ - - LOCAL void -docommon(Void) -{ - register Extsym *extptr; - register chainp q, q1; - struct Dimblock *t; - expptr neltp; - register Namep comvar; - ftnint size; - int i, k, pref, type; - extern int type_pref[]; - - for(extptr = extsymtab ; extptr<nextext ; ++extptr) - if (extptr->extstg == STGCOMMON && (q = extptr->extp)) { - -/* If a common declaration also had a list of variables ... */ - - q = extptr->extp = revchain(q); - pref = 1; - for(k = TYCHAR; q ; q = q->nextp) - { - comvar = (Namep) (q->datap); - - if(comvar->vdcldone == NO) - vardcl(comvar); - type = comvar->vtype; - if (pref < type_pref[type]) - pref = type_pref[k = type]; - if(extptr->extleng % typealign[type] != 0) { - dclerr("common alignment", comvar); - --nerr; /* don't give bad return code for this */ -#if 0 - extptr->extleng = roundup(extptr->extleng, typealign[type]); -#endif - } /* if extptr -> extleng % */ - -/* Set the offset into the common block */ - - comvar->voffset = extptr->extleng; - comvar->vardesc.varno = extptr - extsymtab; - if(type == TYCHAR) - if (comvar->vleng) - size = comvar->vleng->constblock.Const.ci; - else { - dclerr("character*(*) in common", comvar); - size = 1; - } - else - size = typesize[type]; - if(t = comvar->vdim) - if( (neltp = t->nelt) && ISCONST(neltp) ) - size *= neltp->constblock.Const.ci; - else - dclerr("adjustable array in common", comvar); - -/* Adjust the length of the common block so far */ - - extptr->extleng += size; - } /* for */ - - extptr->extype = k; - -/* Determine curno and, if new, save this identifier chain */ - - q1 = extptr->extp; - for (q = extptr->allextp, i = 0; q; i++, q = q->nextp) - if (struct_eq((chainp)q->datap, q1)) - break; - if (q) - extptr->curno = extptr->maxno - i; - else { - extptr->curno = ++extptr->maxno; - extptr->allextp = mkchain((char *)extptr->extp, - extptr->allextp); - } - } /* if extptr -> extstg == STGCOMMON */ - -/* Now the hash table entries have STGCOMMON, vdcldone, voffset, and - varno. And the common block itself has its full size in extleng. */ - -} /* docommon */ - - -/* copy_data -- copy the Namep entries so they are available even after - the hash table is empty */ - - void -#ifdef KR_headers -copy_data(list) - chainp list; -#else -copy_data(chainp list) -#endif -{ - for (; list; list = list -> nextp) { - Namep namep = ALLOC (Nameblock); - int size, nd, i; - struct Dimblock *dp; - - cpn(sizeof(struct Nameblock), list->datap, (char *)namep); - namep->fvarname = strcpy(gmem(strlen(namep->fvarname)+1,0), - namep->fvarname); - namep->cvarname = strcmp(namep->fvarname, namep->cvarname) - ? strcpy(gmem(strlen(namep->cvarname)+1,0), namep->cvarname) - : namep->fvarname; - if (namep -> vleng) - namep -> vleng = (expptr) cpexpr (namep -> vleng); - if (namep -> vdim) { - nd = namep -> vdim -> ndim; - size = sizeof(int) + (3 + 2 * nd) * sizeof (expptr); - dp = (struct Dimblock *) ckalloc (size); - cpn(size, (char *)namep->vdim, (char *)dp); - namep -> vdim = dp; - dp->nelt = (expptr)cpexpr(dp->nelt); - for (i = 0; i < nd; i++) { - dp -> dims[i].dimsize = (expptr) cpexpr (dp -> dims[i].dimsize); - } /* for */ - } /* if */ - list -> datap = (char *) namep; - } /* for */ -} /* copy_data */ - - - - LOCAL void -docomleng(Void) -{ - register Extsym *p; - - for(p = extsymtab ; p < nextext ; ++p) - if(p->extstg == STGCOMMON) - { - if(p->maxleng!=0 && p->extleng!=0 && p->maxleng!=p->extleng - && strcmp(Blank, p->cextname) ) - warn1("incompatible lengths for common block %.60s", - p->fextname); - if(p->maxleng < p->extleng) - p->maxleng = p->extleng; - p->extleng = 0; - } -} - - -/* ROUTINES DEALING WITH AUTOMATIC AND TEMPORARY STORAGE */ - - void -#ifdef KR_headers -frtemp(p) - Addrp p; -#else -frtemp(Addrp p) -#endif -{ - /* put block on chain of temps to be reclaimed */ - holdtemps = mkchain((char *)p, holdtemps); -} - - void -freetemps(Void) -{ - register chainp p, p1; - register Addrp q; - register int t; - - p1 = holdtemps; - while(p = p1) { - q = (Addrp)p->datap; - t = q->vtype; - if (t == TYCHAR && q->varleng != 0) { - /* restore clobbered character string lengths */ - frexpr(q->vleng); - q->vleng = ICON(q->varleng); - } - p1 = p->nextp; - p->nextp = templist[t]; - templist[t] = p; - } - holdtemps = 0; - } - -/* allocate an automatic variable slot for each of nelt variables */ - - Addrp -#ifdef KR_headers -autovar(nelt0, t, lengp, name) - register int nelt0; - register int t; - expptr lengp; - char *name; -#else -autovar(register int nelt0, register int t, expptr lengp, char *name) -#endif -{ - ftnint leng; - register Addrp q; - register int nelt = nelt0 > 0 ? nelt0 : 1; - extern char *av_pfix[]; - - if(t == TYCHAR) - if( ISICON(lengp) ) - leng = lengp->constblock.Const.ci; - else { - Fatal("automatic variable of nonconstant length"); - } - else - leng = typesize[t]; - - q = ALLOC(Addrblock); - q->tag = TADDR; - q->vtype = t; - if(t == TYCHAR) - { - q->vleng = ICON(leng); - q->varleng = leng; - } - q->vstg = STGAUTO; - q->ntempelt = nelt; - q->isarray = (nelt > 1); - q->memoffset = ICON(0); - - /* kludge for nls so we can have ret_val rather than ret_val_4 */ - if (*name == ' ') - unamstring(q, name); - else { - q->uname_tag = UNAM_IDENT; - temp_name(av_pfix[t], ++autonum[t], q->user.ident); - } - if (nelt0 > 0) - declare_new_addr (q); - return(q); -} - - -/* Returns a temporary of the appropriate type. Will reuse existing - temporaries when possible */ - - Addrp -#ifdef KR_headers -mktmpn(nelt, type, lengp) - int nelt; - register int type; - expptr lengp; -#else -mktmpn(int nelt, register int type, expptr lengp) -#endif -{ - ftnint leng; - chainp p, oldp; - register Addrp q; - extern int krparens; - - if(type==TYUNKNOWN || type==TYERROR) - badtype("mktmpn", type); - - if(type==TYCHAR) - if(lengp && ISICON(lengp) ) - leng = lengp->constblock.Const.ci; - else { - err("adjustable length"); - return( (Addrp) errnode() ); - } - else if (type > TYCHAR || type < TYADDR) { - erri("mktmpn: unexpected type %d", type); - exit(1); - } -/* - * if a temporary of appropriate shape is on the templist, - * remove it from the list and return it - */ - if (krparens == 2 && ONEOF(type,M(TYREAL)|M(TYCOMPLEX))) - type++; - for(oldp=CHNULL, p=templist[type]; p ; oldp=p, p=p->nextp) - { - q = (Addrp) (p->datap); - if(q->ntempelt==nelt && - (type!=TYCHAR || q->vleng->constblock.Const.ci==leng) ) - { - if(oldp) - oldp->nextp = p->nextp; - else - templist[type] = p->nextp; - free( (charptr) p); - return(q); - } - } - q = autovar(nelt, type, lengp, ""); - return(q); -} - - - - -/* mktmp -- create new local variable; call it something like name - lengp is taken directly, not copied */ - - Addrp -#ifdef KR_headers -mktmp(type, lengp) - int type; - expptr lengp; -#else -mktmp(int type, expptr lengp) -#endif -{ - Addrp rv; - /* arrange for temporaries to be recycled */ - /* at the end of this statement... */ - rv = mktmpn(1,type,lengp); - frtemp((Addrp)cpexpr((expptr)rv)); - return rv; -} - -/* mktmp0 omits frtemp() */ - Addrp -#ifdef KR_headers -mktmp0(type, lengp) - int type; - expptr lengp; -#else -mktmp0(int type, expptr lengp) -#endif -{ - Addrp rv; - /* arrange for temporaries to be recycled */ - /* when this Addrp is freed */ - rv = mktmpn(1,type,lengp); - rv->istemp = YES; - return rv; -} - -/* VARIOUS ROUTINES FOR PROCESSING DECLARATIONS */ - -/* comblock -- Declare a new common block. Input parameters name the block; - s will be NULL if the block is unnamed */ - - Extsym * -#ifdef KR_headers -comblock(s) - register char *s; -#else -comblock(register char *s) -#endif -{ - Extsym *p; - register char *t; - register int c, i; - char cbuf[256], *s0; - -/* Give the unnamed common block a unique name */ - - if(*s == 0) - p = mkext1(s0 = Blank, Blank); - else { - s0 = s; - t = cbuf; - for(i = 0; c = *t = *s++; t++) - if (c == '_') - i = 1; - if (i) - *t++ = '_'; - t[0] = '_'; - t[1] = 0; - p = mkext1(s0,cbuf); - } - if(p->extstg == STGUNKNOWN) - p->extstg = STGCOMMON; - else if(p->extstg != STGCOMMON) - { - errstr("%.52s cannot be a common block: it is a subprogram.", - s0); - return(0); - } - - return( p ); -} - - -/* incomm -- add a new variable to a common declaration */ - - void -#ifdef KR_headers -incomm(c, v) - Extsym *c; - Namep v; -#else -incomm(Extsym *c, Namep v) -#endif -{ - if (!c) - return; - if(v->vstg != STGUNKNOWN && !v->vimplstg) - dclerr(v->vstg == STGARG - ? "dummy arguments cannot be in common" - : "incompatible common declaration", v); - else - { - v->vstg = STGCOMMON; - c->extp = mkchain((char *)v, c->extp); - } -} - - - - -/* settype -- set the type or storage class of a Namep object. If - v -> vstg == STGUNKNOWN && type < 0, attempt to reset vstg to be - -type. This function will not change any earlier definitions in v, - in will only attempt to fill out more information give the other params */ - - void -#ifdef KR_headers -settype(v, type, length) - register Namep v; - register int type; - register ftnint length; -#else -settype(register Namep v, register int type, register ftnint length) -#endif -{ - int type1; - - if(type == TYUNKNOWN) - return; - - if(type==TYSUBR && v->vtype!=TYUNKNOWN && v->vstg==STGARG) - { - v->vtype = TYSUBR; - frexpr(v->vleng); - v->vleng = 0; - v->vimpltype = 0; - } - else if(type < 0) /* storage class set */ - { - if(v->vstg == STGUNKNOWN) - v->vstg = - type; - else if(v->vstg != -type) - dclerr("incompatible storage declarations", v); - } - else if(v->vtype == TYUNKNOWN - || v->vtype != type - && (v->vimpltype || v->vinftype || v->vinfproc)) - { - if( (v->vtype = lengtype(type, length))==TYCHAR ) - if (length>=0) - v->vleng = ICON(length); - else if (parstate >= INDATA) - v->vleng = ICON(1); /* avoid a memory fault */ - v->vimpltype = 0; - v->vinftype = 0; /* 19960709 */ - v->vinfproc = 0; /* 19960709 */ - - if (v->vclass == CLPROC) { - if (v->vstg == STGEXT - && (type1 = extsymtab[v->vardesc.varno].extype) - && type1 != v->vtype) - changedtype(v); - else if (v->vprocclass == PTHISPROC - && (parstate >= INDATA - || procclass == CLMAIN) - && !xretslot[type]) { - xretslot[type] = autovar(ONEOF(type, - MSKCOMPLEX|MSKCHAR) ? 0 : 1, type, - v->vleng, " ret_val"); - if (procclass == CLMAIN) - errstr( - "illegal use of %.60s (main program name)", - v->fvarname); - /* not completely right, but enough to */ - /* avoid memory faults; we won't */ - /* emit any C as we have illegal Fortran */ - } - } - } - else if(v->vtype != type && v->vtype != lengtype(type, length)) { - incompat: - dclerr("incompatible type declarations", v); - } - else if (type==TYCHAR) - if (v->vleng && v->vleng->constblock.Const.ci != length) - goto incompat; - else if (parstate >= INDATA) - v->vleng = ICON(1); /* avoid a memory fault */ -} - - - - - -/* lengtype -- returns the proper compiler type, given input of Fortran - type and length specifier */ - - int -#ifdef KR_headers -lengtype(type, len) - register int type; - ftnint len; -#else -lengtype(register int type, ftnint len) -#endif -{ - register int length = (int)len; - switch(type) - { - case TYREAL: - if(length == typesize[TYDREAL]) - return(TYDREAL); - if(length == typesize[TYREAL]) - goto ret; - break; - - case TYCOMPLEX: - if(length == typesize[TYDCOMPLEX]) - return(TYDCOMPLEX); - if(length == typesize[TYCOMPLEX]) - goto ret; - break; - - case TYINT1: - case TYSHORT: - case TYDREAL: - case TYDCOMPLEX: - case TYCHAR: - case TYLOGICAL1: - case TYLOGICAL2: - case TYUNKNOWN: - case TYSUBR: - case TYERROR: -#ifdef TYQUAD - case TYQUAD: -#endif - goto ret; - - case TYLOGICAL: - switch(length) { - case 0: return tylog; - case 1: return TYLOGICAL1; - case 2: return TYLOGICAL2; - case 4: goto ret; - } - break; - - case TYLONG: - if(length == 0) - return(tyint); - if (length == 1) - return TYINT1; - if(length == typesize[TYSHORT]) - return(TYSHORT); -#ifdef TYQUAD - if(length == typesize[TYQUAD] && use_tyquad) - return(TYQUAD); -#endif - if(length == typesize[TYLONG]) - goto ret; - break; - default: - badtype("lengtype", type); - } - - if(len != 0) - err("incompatible type-length combination"); - -ret: - return(type); -} - - - - - -/* setintr -- Set Intrinsic function */ - - void -#ifdef KR_headers -setintr(v) - register Namep v; -#else -setintr(register Namep v) -#endif -{ - int k; - - if(k = intrfunct(v->fvarname)) { - if ((*(struct Intrpacked *)&k).f4) - if (noextflag) - goto unknown; - else - dcomplex_seen++; - v->vardesc.varno = k; - } - else { - unknown: - dclerr("unknown intrinsic function", v); - return; - } - if(v->vstg == STGUNKNOWN) - v->vstg = STGINTR; - else if(v->vstg!=STGINTR) - dclerr("incompatible use of intrinsic function", v); - if(v->vclass==CLUNKNOWN) - v->vclass = CLPROC; - if(v->vprocclass == PUNKNOWN) - v->vprocclass = PINTRINSIC; - else if(v->vprocclass != PINTRINSIC) - dclerr("invalid intrinsic declaration", v); -} - - - -/* setext -- Set External declaration -- assume that unknowns will become - procedures */ - - void -#ifdef KR_headers -setext(v) - register Namep v; -#else -setext(register Namep v) -#endif -{ - if(v->vclass == CLUNKNOWN) - v->vclass = CLPROC; - else if(v->vclass != CLPROC) - dclerr("invalid external declaration", v); - - if(v->vprocclass == PUNKNOWN) - v->vprocclass = PEXTERNAL; - else if(v->vprocclass != PEXTERNAL) - dclerr("invalid external declaration", v); -} /* setext */ - - - - -/* create dimensions block for array variable */ - - void -#ifdef KR_headers -setbound(v, nd, dims) - register Namep v; - int nd; - struct Dims *dims; -#else -setbound(register Namep v, int nd, struct Dims *dims) -#endif -{ - register expptr q, t; - register struct Dimblock *p; - int i; - extern chainp new_vars; - char buf[256]; - - if(v->vclass == CLUNKNOWN) - v->vclass = CLVAR; - else if(v->vclass != CLVAR) - { - dclerr("only variables may be arrays", v); - return; - } - - v->vdim = p = (struct Dimblock *) - ckalloc( sizeof(int) + (3+2*nd)*sizeof(expptr) ); - p->ndim = nd--; - p->nelt = ICON(1); - doin_setbound = 1; - - if (noextflag) - for(i = 0; i <= nd; i++) - if (((q = dims[i].lb) && !ISINT(q->headblock.vtype)) - || ((q = dims[i].ub) && !ISINT(q->headblock.vtype))) { - sprintf(buf, "dimension %d of %s is not an integer.", - i+1, v->fvarname); - errext(buf); - break; - } - - for(i = 0; i <= nd; i++) { - if (((q = dims[i].lb) && !ISINT(q->headblock.vtype))) - dims[i].lb = mkconv(TYINT, q); - if (((q = dims[i].ub) && !ISINT(q->headblock.vtype))) - dims[i].ub = mkconv(TYINT, q); - } - - for(i = 0; i <= nd; ++i) - { - if( (q = dims[i].ub) == NULL) - { - if(i == nd) - { - frexpr(p->nelt); - p->nelt = NULL; - } - else - err("only last bound may be asterisk"); - p->dims[i].dimsize = ICON(1); - p->dims[i].dimexpr = NULL; - } - else - { - - if(dims[i].lb) - { - q = mkexpr(OPMINUS, q, cpexpr(dims[i].lb)); - q = mkexpr(OPPLUS, q, ICON(1) ); - } - if( ISCONST(q) ) - { - p->dims[i].dimsize = q; - p->dims[i].dimexpr = (expptr) PNULL; - } - else { - sprintf(buf, " %s_dim%d", v->fvarname, i+1); - p->dims[i].dimsize = (expptr) - autovar(1, tyint, EXNULL, buf); - p->dims[i].dimexpr = q; - if (i == nd) - v->vlastdim = new_vars; - v->vdimfinish = 1; - } - if(p->nelt) - p->nelt = mkexpr(OPSTAR, p->nelt, - cpexpr(p->dims[i].dimsize) ); - } - } - - q = dims[nd].lb; - if(q == NULL) - q = ICON(1); - - for(i = nd-1 ; i>=0 ; --i) - { - t = dims[i].lb; - if(t == NULL) - t = ICON(1); - if(p->dims[i].dimsize) - q = mkexpr(OPPLUS, t, - mkexpr(OPSTAR, cpexpr(p->dims[i].dimsize), q)); - } - - if( ISCONST(q) ) - { - p->baseoffset = q; - p->basexpr = NULL; - } - else - { - sprintf(buf, " %s_offset", v->fvarname); - p->baseoffset = (expptr) autovar(1, tyint, EXNULL, buf); - p->basexpr = q; - v->vdimfinish = 1; - } - doin_setbound = 0; -} - - - void -#ifdef KR_headers -wr_abbrevs(outfile, function_head, vars) - FILE *outfile; - int function_head; - chainp vars; -#else -wr_abbrevs(FILE *outfile, int function_head, chainp vars) -#endif -{ - for (; vars; vars = vars -> nextp) { - Namep name = (Namep) vars -> datap; - if (!name->visused) - continue; - - if (function_head) - nice_printf (outfile, "#define "); - else - nice_printf (outfile, "#undef "); - out_name (outfile, name); - - if (function_head) { - Extsym *comm = &extsymtab[name -> vardesc.varno]; - - nice_printf (outfile, " ("); - extern_out (outfile, comm); - nice_printf (outfile, "%d.", comm->curno); - nice_printf (outfile, "%s)", name->cvarname); - } /* if function_head */ - nice_printf (outfile, "\n"); - } /* for */ -} /* wr_abbrevs */ diff --git a/usr.bin/f2c/put.c b/usr.bin/f2c/put.c deleted file mode 100644 index 25425c57e6ed..000000000000 --- a/usr.bin/f2c/put.c +++ /dev/null @@ -1,441 +0,0 @@ -/**************************************************************** -Copyright 1990, 1991, 1993, 1994, 1996 by AT&T, Lucent Technologies and Bellcore. - -Permission to use, copy, modify, and distribute this software -and its documentation for any purpose and without fee is hereby -granted, provided that the above copyright notice appear in all -copies and that both that the copyright notice and this -permission notice and warranty disclaimer appear in supporting -documentation, and that the names of AT&T, Bell Laboratories, -Lucent or Bellcore or any of their entities not be used in -advertising or publicity pertaining to distribution of the -software without specific, written prior permission. - -AT&T, Lucent and Bellcore disclaim all warranties with regard to -this software, including all implied warranties of -merchantability and fitness. In no event shall AT&T, Lucent or -Bellcore be liable for any special, indirect or consequential -damages or any damages whatsoever resulting from loss of use, -data or profits, whether in an action of contract, negligence or -other tortious action, arising out of or in connection with the -use or performance of this software. -****************************************************************/ - -/* - * INTERMEDIATE CODE GENERATION PROCEDURES COMMON TO BOTH - * JOHNSON (PORTABLE) AND RITCHIE FAMILIES OF SECOND PASSES -*/ - -#include "defs.h" -#include "names.h" /* For LOCAL_CONST_NAME */ -#include "pccdefs.h" -#include "p1defs.h" - -/* Definitions for putconst() */ - -#define LIT_CHAR 1 -#define LIT_FLOAT 2 -#define LIT_INT 3 - - -/* -char *ops [ ] = - { - "??", "+", "-", "*", "/", "**", "-", - "OR", "AND", "EQV", "NEQV", "NOT", - "CONCAT", - "<", "==", ">", "<=", "!=", ">=", - " of ", " ofC ", " = ", " += ", " *= ", " CONV ", " << ", " % ", - " , ", " ? ", " : " - " abs ", " min ", " max ", " addr ", " indirect ", - " bitor ", " bitand ", " bitxor ", " bitnot ", " >> ", - }; -*/ - -/* Each of these values is defined in pccdefs */ - -int ops2 [ ] = -{ - P2BAD, P2PLUS, P2MINUS, P2STAR, P2SLASH, P2BAD, P2NEG, - P2OROR, P2ANDAND, P2EQ, P2NE, P2NOT, - P2BAD, - P2LT, P2EQ, P2GT, P2LE, P2NE, P2GE, - P2CALL, P2CALL, P2ASSIGN, P2PLUSEQ, P2STAREQ, P2CONV, P2LSHIFT, P2MOD, - P2COMOP, P2QUEST, P2COLON, - 1, P2BAD, P2BAD, P2BAD, P2BAD, - P2BITOR, P2BITAND, P2BITXOR, P2BITNOT, P2RSHIFT, - P2BAD, P2BAD, P2BAD, P2BAD, P2BAD, P2BAD, P2BAD, P2BAD, P2BAD, - P2BAD, P2BAD, P2BAD, P2BAD, - 1,1,1,1,1, /* OPNEG1, OPDMIN, OPDMAX, OPASSIGNI, OPIDENTITY */ - 1,1,1,1, /* OPCHARCAST, OPDABS, OPMIN2, OPMAX2 */ - 1,1,1,1,1 /* OPBITTEST, OPBITCLR, OPBITSET, OPQBIT{CLR,SET} */ -}; - - - void -#ifdef KR_headers -putexpr(p) - expptr p; -#else -putexpr(expptr p) -#endif -{ -/* Write the expression to the p1 file */ - - p = (expptr) putx (fixtype (p)); - p1_expr (p); -} - - - - - - expptr -#ifdef KR_headers -putassign(lp, rp) - expptr lp; - expptr rp; -#else -putassign(expptr lp, expptr rp) -#endif -{ - return putx(fixexpr((Exprp)mkexpr(OPASSIGN, lp, rp))); -} - - - - - void -#ifdef KR_headers -puteq(lp, rp) - expptr lp; - expptr rp; -#else -puteq(expptr lp, expptr rp) -#endif -{ - putexpr(mkexpr(OPASSIGN, lp, rp) ); -} - - - - -/* put code for a *= b */ - - expptr -#ifdef KR_headers -putsteq(a, b) - Addrp a; - Addrp b; -#else -putsteq(Addrp a, Addrp b) -#endif -{ - return putx( fixexpr((Exprp) - mkexpr(OPSTAREQ, cpexpr((expptr)a), cpexpr((expptr)b)))); -} - - - - - Addrp -#ifdef KR_headers -mkfield(res, f, ty) - register Addrp res; - char *f; - int ty; -#else -mkfield(register Addrp res, char *f, int ty) -#endif -{ - res -> vtype = ty; - res -> Field = f; - return res; -} /* mkfield */ - - - Addrp -#ifdef KR_headers -realpart(p) - register Addrp p; -#else -realpart(register Addrp p) -#endif -{ - register Addrp q; - - if (p->tag == TADDR - && p->uname_tag == UNAM_CONST - && ISCOMPLEX (p->vtype)) - return (Addrp)mkrealcon (p -> vtype + TYREAL - TYCOMPLEX, - p->user.kludge.vstg1 ? p->user.Const.cds[0] - : cds(dtos(p->user.Const.cd[0]),CNULL)); - - q = (Addrp) cpexpr((expptr) p); - if( ISCOMPLEX(p->vtype) ) - q = mkfield (q, "r", p -> vtype + TYREAL - TYCOMPLEX); - - return(q); -} - - - - - expptr -#ifdef KR_headers -imagpart(p) - register Addrp p; -#else -imagpart(register Addrp p) -#endif -{ - register Addrp q; - - if( ISCOMPLEX(p->vtype) ) - { - if (p->tag == TADDR && p->uname_tag == UNAM_CONST) - return mkrealcon (p -> vtype + TYREAL - TYCOMPLEX, - p->user.kludge.vstg1 ? p->user.Const.cds[1] - : cds(dtos(p->user.Const.cd[1]),CNULL)); - q = (Addrp) cpexpr((expptr) p); - q = mkfield (q, "i", p -> vtype + TYREAL - TYCOMPLEX); - return( (expptr) q ); - } - else - -/* Cast an integer type onto a Double Real type */ - - return( mkrealcon( ISINT(p->vtype) ? TYDREAL : p->vtype , "0")); -} - - - - - -/* ncat -- computes the number of adjacent concatenation operations */ - - int -#ifdef KR_headers -ncat(p) - register expptr p; -#else -ncat(register expptr p) -#endif -{ - if(p->tag==TEXPR && p->exprblock.opcode==OPCONCAT) - return( ncat(p->exprblock.leftp) + ncat(p->exprblock.rightp) ); - else return(1); -} - - - - -/* lencat -- returns the length of the concatenated string. Each - substring must have a static (i.e. compile-time) fixed length */ - - ftnint -#ifdef KR_headers -lencat(p) - register expptr p; -#else -lencat(register expptr p) -#endif -{ - if(p->tag==TEXPR && p->exprblock.opcode==OPCONCAT) - return( lencat(p->exprblock.leftp) + lencat(p->exprblock.rightp) ); - else if( p->headblock.vleng!=NULL && ISICON(p->headblock.vleng) ) - return(p->headblock.vleng->constblock.Const.ci); - else if(p->tag==TADDR && p->addrblock.varleng!=0) - return(p->addrblock.varleng); - else - { - err("impossible element in concatenation"); - return(0); - } -} - -/* putconst -- Creates a new Addrp value which maps onto the input - constant value. The Addrp doesn't retain the value of the constant, - instead that value is copied into a table of constants (called - litpool, for pool of literal values). The only way to retrieve the - actual value of the constant is to look at the memno field of the - Addrp result. You know that the associated literal is the one referred - to by q when (q -> memno == litp -> litnum). -*/ - - Addrp -#ifdef KR_headers -putconst(p) - register Constp p; -#else -putconst(register Constp p) -#endif -{ - register Addrp q; - struct Literal *litp, *lastlit; - int k, len, type; - int litflavor; - double cd[2]; - ftnint nblanks; - char *strp; - char cdsbuf0[64], cdsbuf1[64], *ds[2]; - - if (p->tag != TCONST) - badtag("putconst", p->tag); - - q = ALLOC(Addrblock); - q->tag = TADDR; - type = p->vtype; - q->vtype = ( type==TYADDR ? tyint : type ); - q->vleng = (expptr) cpexpr(p->vleng); - q->vstg = STGCONST; - -/* Create the new label for the constant. This is wasteful of labels - because when the constant value already exists in the literal pool, - this label gets thrown away and is never reclaimed. It might be - cleaner to move this down past the first switch() statement below */ - - q->memno = newlabel(); - q->memoffset = ICON(0); - q -> uname_tag = UNAM_CONST; - -/* Copy the constant info into the Addrblock; do this by copying the - largest storage elts */ - - q -> user.Const = p -> Const; - q->user.kludge.vstg1 = p->vstg; /* distinguish string from binary fp */ - - /* check for value in literal pool, and update pool if necessary */ - - k = 1; - switch(type) - { - case TYCHAR: - if (halign) { - strp = p->Const.ccp; - nblanks = p->Const.ccp1.blanks; - len = p->vleng->constblock.Const.ci; - litflavor = LIT_CHAR; - goto loop; - } - else - q->memno = BAD_MEMNO; - break; - case TYCOMPLEX: - case TYDCOMPLEX: - k = 2; - if (p->vstg) - cd[1] = atof(ds[1] = p->Const.cds[1]); - else - ds[1] = cds(dtos(cd[1] = p->Const.cd[1]), cdsbuf1); - case TYREAL: - case TYDREAL: - litflavor = LIT_FLOAT; - if (p->vstg) - cd[0] = atof(ds[0] = p->Const.cds[0]); - else - ds[0] = cds(dtos(cd[0] = p->Const.cd[0]), cdsbuf0); - goto loop; - - case TYLOGICAL1: - case TYLOGICAL2: - case TYLOGICAL: - case TYLONG: - case TYSHORT: - case TYINT1: -#ifdef TYQUAD - case TYQUAD: -#endif - lit_int_flavor: - litflavor = LIT_INT; - -/* Scan the literal pool for this constant value. If this same constant - has been assigned before, use the same label. Note that this routine - does NOT consider two differently-typed constants with the same bit - pattern to be the same constant */ - - loop: - lastlit = litpool + nliterals; - for(litp = litpool ; litp<lastlit ; ++litp) - -/* Remove this type checking to ensure that all bit patterns are reused */ - - if(type == litp->littype) switch(litflavor) - { - case LIT_CHAR: - if (len == (int)litp->litval.litival2[0] - && nblanks == litp->litval.litival2[1] - && !memcmp(strp, litp->cds[0], len)) { - q->memno = litp->litnum; - frexpr((expptr)p); - q->user.Const.ccp1.ccp0 = litp->cds[0]; - return(q); - } - break; - case LIT_FLOAT: - if(cd[0] == litp->litval.litdval[0] - && !strcmp(ds[0], litp->cds[0]) - && (k == 1 || - cd[1] == litp->litval.litdval[1] - && !strcmp(ds[1], litp->cds[1]))) { -ret: - q->memno = litp->litnum; - frexpr((expptr)p); - return(q); - } - break; - - case LIT_INT: - if(p->Const.ci == litp->litval.litival) - goto ret; - break; - } - -/* If there's room in the literal pool, add this new value to the pool */ - - if(nliterals < maxliterals) - { - ++nliterals; - - /* litp now points to the next free elt */ - - litp->littype = type; - litp->litnum = q->memno; - switch(litflavor) - { - case LIT_CHAR: - litp->litval.litival2[0] = len; - litp->litval.litival2[1] = nblanks; - q->user.Const.ccp = litp->cds[0] = - memcpy(gmem(len,0), strp, len); - break; - - case LIT_FLOAT: - litp->litval.litdval[0] = cd[0]; - litp->cds[0] = copys(ds[0]); - if (k == 2) { - litp->litval.litdval[1] = cd[1]; - litp->cds[1] = copys(ds[1]); - } - break; - - case LIT_INT: - litp->litval.litival = p->Const.ci; - break; - } /* switch (litflavor) */ - } - else - many("literal constants", 'L', maxliterals); - - break; - case TYADDR: - break; - default: - badtype ("putconst", p -> vtype); - break; - } /* switch */ - - if (type != TYCHAR || halign) - frexpr((expptr)p); - return( q ); -} diff --git a/usr.bin/f2c/putpcc.c b/usr.bin/f2c/putpcc.c deleted file mode 100644 index 87d4550fff1e..000000000000 --- a/usr.bin/f2c/putpcc.c +++ /dev/null @@ -1,2079 +0,0 @@ -/**************************************************************** -Copyright 1990 - 1996 by AT&T, Lucent Technologies and Bellcore. - -Permission to use, copy, modify, and distribute this software -and its documentation for any purpose and without fee is hereby -granted, provided that the above copyright notice appear in all -copies and that both that the copyright notice and this -permission notice and warranty disclaimer appear in supporting -documentation, and that the names of AT&T, Bell Laboratories, -Lucent or Bellcore or any of their entities not be used in -advertising or publicity pertaining to distribution of the -software without specific, written prior permission. - -AT&T, Lucent and Bellcore disclaim all warranties with regard to -this software, including all implied warranties of -merchantability and fitness. In no event shall AT&T, Lucent or -Bellcore be liable for any special, indirect or consequential -damages or any damages whatsoever resulting from loss of use, -data or profits, whether in an action of contract, negligence or -other tortious action, arising out of or in connection with the -use or performance of this software. -****************************************************************/ - -/* INTERMEDIATE CODE GENERATION FOR S. C. JOHNSON C COMPILERS */ -/* NEW VERSION USING BINARY POLISH POSTFIX INTERMEDIATE */ - -#include "defs.h" -#include "pccdefs.h" -#include "output.h" /* for nice_printf */ -#include "names.h" -#include "p1defs.h" - -static Addrp intdouble Argdcl((Addrp)); -static Addrp putcx1 Argdcl((tagptr)); -static tagptr putaddr Argdcl((tagptr)); -static tagptr putcall Argdcl((tagptr, Addrp*)); -static tagptr putcat Argdcl((tagptr, tagptr)); -static Addrp putch1 Argdcl((tagptr)); -static tagptr putchcmp Argdcl((tagptr)); -static tagptr putcheq Argdcl((tagptr)); -static void putct1 Argdcl((tagptr, Addrp, Addrp, ptr)); -static tagptr putcxcmp Argdcl((tagptr)); -static Addrp putcxeq Argdcl((tagptr)); -static tagptr putmnmx Argdcl((tagptr)); -static tagptr putop Argdcl((tagptr)); -static tagptr putpower Argdcl((tagptr)); - -extern int init_ac[TYSUBR+1]; -extern int ops2[]; -extern int proc_argchanges, proc_protochanges; -extern int krparens; - -#define P2BUFFMAX 128 - -/* Puthead -- output the header information about subroutines, functions - and entry points */ - - void -#ifdef KR_headers -puthead(s, class) - char *s; - int class; -#else -puthead(char *s, int class) -#endif -{ - if (headerdone == NO) { - if (class == CLMAIN) - s = "MAIN__"; - p1_head (class, s); - headerdone = YES; - } -} - - void -#ifdef KR_headers -putif(p, else_if_p) - register expptr p; - int else_if_p; -#else -putif(register expptr p, int else_if_p) -#endif -{ - register int k; - int n; - long where; - - if (else_if_p) { - p1put(P1_ELSEIFSTART); - where = ftell(pass1_file); - } - if( !ISLOGICAL((k = (p = fixtype(p))->headblock.vtype )) ) - { - if(k != TYERROR) - err("non-logical expression in IF statement"); - } - else { - if (else_if_p) { - if (ei_next >= ei_last) - { - k = ei_last - ei_first; - n = k + 100; - ei_next = mem(n,0); - ei_last = ei_first + n; - if (k) - memcpy(ei_next, ei_first, k); - ei_first = ei_next; - ei_next += k; - ei_last = ei_first + n; - } - p = putx(p); - if (*ei_next++ = ftell(pass1_file) > where) { - p1_if(p); - new_endif(); - } - else - p1_elif(p); - } - else { - p = putx(p); - p1_if(p); - } - } - } - - void -#ifdef KR_headers -putout(p) - expptr p; -#else -putout(expptr p) -#endif -{ - p1_expr (p); - -/* Used to make temporaries in holdtemps available here, but they */ -/* may be reused too soon (e.g. when multiple **'s are involved). */ -} - - - void -#ifdef KR_headers -putcmgo(index, nlab, labs) - expptr index; - int nlab; - struct Labelblock **labs; -#else -putcmgo(expptr index, int nlab, struct Labelblock **labs) -#endif -{ - if(! ISINT(index->headblock.vtype) ) - { - execerr("computed goto index must be integer", CNULL); - return; - } - - p1comp_goto (index, nlab, labs); -} - - static expptr -#ifdef KR_headers -krput(p) - register expptr p; -#else -krput(register expptr p) -#endif -{ - register expptr e, e1; - register unsigned op; - int t = krparens == 2 ? TYDREAL : p->exprblock.vtype; - - op = p->exprblock.opcode; - e = p->exprblock.leftp; - if (e->tag == TEXPR && e->exprblock.opcode == op) { - e1 = (expptr)mktmp(t, ENULL); - putout(putassign(cpexpr(e1), e)); - p->exprblock.leftp = e1; - } - else - p->exprblock.leftp = putx(e); - - e = p->exprblock.rightp; - if (e->tag == TEXPR && e->exprblock.opcode == op) { - e1 = (expptr)mktmp(t, ENULL); - putout(putassign(cpexpr(e1), e)); - p->exprblock.rightp = e1; - } - else - p->exprblock.rightp = putx(e); - return p; - } - - expptr -#ifdef KR_headers -putx(p) - register expptr p; -#else -putx(register expptr p) -#endif -{ - int opc; - int k; - - if (p) - switch(p->tag) - { - case TERROR: - break; - - case TCONST: - switch(p->constblock.vtype) - { - case TYLOGICAL1: - case TYLOGICAL2: - case TYLOGICAL: -#ifdef TYQUAD - case TYQUAD: -#endif - case TYLONG: - case TYSHORT: - case TYINT1: - break; - - case TYADDR: - break; - case TYREAL: - case TYDREAL: - -/* Don't write it out to the p2 file, since you'd need to call putconst, - which is just what we need to avoid in the translator */ - - break; - default: - p = putx( (expptr)putconst((Constp)p) ); - break; - } - break; - - case TEXPR: - switch(opc = p->exprblock.opcode) - { - case OPCALL: - case OPCCALL: - if( ISCOMPLEX(p->exprblock.vtype) ) - p = putcxop(p); - else p = putcall(p, (Addrp *)NULL); - break; - - case OPMIN: - case OPMAX: - p = putmnmx(p); - break; - - - case OPASSIGN: - if(ISCOMPLEX(p->exprblock.leftp->headblock.vtype) - || ISCOMPLEX(p->exprblock.rightp->headblock.vtype)) { - (void) putcxeq(p); - p = ENULL; - } else if( ISCHAR(p) ) - p = putcheq(p); - else - goto putopp; - break; - - case OPEQ: - case OPNE: - if( ISCOMPLEX(p->exprblock.leftp->headblock.vtype) || - ISCOMPLEX(p->exprblock.rightp->headblock.vtype) ) - { - p = putcxcmp(p); - break; - } - case OPLT: - case OPLE: - case OPGT: - case OPGE: - if(ISCHAR(p->exprblock.leftp)) - { - p = putchcmp(p); - break; - } - goto putopp; - - case OPPOWER: - p = putpower(p); - break; - - case OPSTAR: - /* m * (2**k) -> m<<k */ - if(INT(p->exprblock.leftp->headblock.vtype) && - ISICON(p->exprblock.rightp) && - ( (k = log_2(p->exprblock.rightp->constblock.Const.ci))>0) ) - { - p->exprblock.opcode = OPLSHIFT; - frexpr(p->exprblock.rightp); - p->exprblock.rightp = ICON(k); - goto putopp; - } - if (krparens && ISREAL(p->exprblock.vtype)) - return krput(p); - - case OPMOD: - goto putopp; - case OPPLUS: - if (krparens && ISREAL(p->exprblock.vtype)) - return krput(p); - case OPMINUS: - case OPSLASH: - case OPNEG: - case OPNEG1: - case OPABS: - case OPDABS: - if( ISCOMPLEX(p->exprblock.vtype) ) - p = putcxop(p); - else goto putopp; - break; - - case OPCONV: - if( ISCOMPLEX(p->exprblock.vtype) ) - p = putcxop(p); - else if( ISCOMPLEX(p->exprblock.leftp->headblock.vtype) ) - { - p = putx( mkconv(p->exprblock.vtype, - (expptr)realpart(putcx1(p->exprblock.leftp)))); - } - else goto putopp; - break; - - case OPNOT: - case OPOR: - case OPAND: - case OPEQV: - case OPNEQV: - case OPADDR: - case OPPLUSEQ: - case OPSTAREQ: - case OPCOMMA: - case OPQUEST: - case OPCOLON: - case OPBITOR: - case OPBITAND: - case OPBITXOR: - case OPBITNOT: - case OPLSHIFT: - case OPRSHIFT: - case OPASSIGNI: - case OPIDENTITY: - case OPCHARCAST: - case OPMIN2: - case OPMAX2: - case OPDMIN: - case OPDMAX: - case OPBITTEST: - case OPBITCLR: - case OPBITSET: -#ifdef TYQUAD - case OPQBITSET: - case OPQBITCLR: -#endif -putopp: - p = putop(p); - break; - - case OPCONCAT: - /* weird things like ichar(a//a) */ - p = (expptr)putch1(p); - break; - - default: - badop("putx", opc); - p = errnode (); - } - break; - - case TADDR: - p = putaddr(p); - break; - - default: - badtag("putx", p->tag); - p = errnode (); - } - - return p; -} - - - - LOCAL expptr -#ifdef KR_headers -putop(p) - expptr p; -#else -putop(expptr p) -#endif -{ - expptr lp, tp; - int pt, lt, lt1; - int comma; - char *hsave; - - switch(p->exprblock.opcode) /* check for special cases and rewrite */ - { - case OPCONV: - pt = p->exprblock.vtype; - lp = p->exprblock.leftp; - lt = lp->headblock.vtype; - -/* Simplify nested type casts */ - - while(p->tag==TEXPR && p->exprblock.opcode==OPCONV && - ( (ISREAL(pt)&&ONEOF(lt,MSKREAL|MSKCOMPLEX)) || - (INT(pt)&&(ONEOF(lt,MSKINT|MSKADDR|MSKCHAR|M(TYSUBR)))) )) - { - if(pt==TYDREAL && lt==TYREAL) - { - if(lp->tag==TEXPR - && lp->exprblock.opcode == OPCONV) { - lt1 = lp->exprblock.leftp->headblock.vtype; - if (lt1 == TYDREAL) { - lp->exprblock.leftp = - putx(lp->exprblock.leftp); - return p; - } - if (lt1 == TYDCOMPLEX) { - lp->exprblock.leftp = putx( - (expptr)realpart( - putcx1(lp->exprblock.leftp))); - return p; - } - } - break; - } - else if (ISREAL(pt) && ISCOMPLEX(lt)) { - p->exprblock.leftp = putx(mkconv(pt, - (expptr)realpart( - putcx1(p->exprblock.leftp)))); - break; - } - if(lt==TYCHAR && lp->tag==TEXPR && - lp->exprblock.opcode==OPCALL) - { - -/* May want to make a comma expression here instead. I had one, but took - it out for my convenience, not for the convenience of the end user */ - - putout (putcall (lp, (Addrp *) &(p -> - exprblock.leftp))); - return putop (p); - } - if (lt == TYCHAR) { - if (ISCONST(p->exprblock.leftp) - && ISNUMERIC(p->exprblock.vtype)) { - hsave = halign; - halign = 0; - p->exprblock.leftp = putx((expptr) - putconst((Constp) - p->exprblock.leftp)); - halign = hsave; - } - else - p->exprblock.leftp = - putx(p->exprblock.leftp); - return p; - } - if (pt < lt && ONEOF(lt,MSKINT|MSKREAL)) - break; - frexpr(p->exprblock.vleng); - free( (charptr) p ); - p = lp; - if (p->tag != TEXPR) - goto retputx; - pt = lt; - lp = p->exprblock.leftp; - lt = lp->headblock.vtype; - } /* while */ - if(p->tag==TEXPR && p->exprblock.opcode==OPCONV) - break; - retputx: - return putx(p); - - case OPADDR: - comma = NO; - lp = p->exprblock.leftp; - free( (charptr) p ); - if(lp->tag != TADDR) - { - tp = (expptr) - mktmp(lp->headblock.vtype,lp->headblock.vleng); - p = putx( mkexpr(OPASSIGN, cpexpr(tp), lp) ); - lp = tp; - comma = YES; - } - if(comma) - p = mkexpr(OPCOMMA, p, putaddr(lp)); - else - p = (expptr)putaddr(lp); - return p; - - case OPASSIGN: - case OPASSIGNI: - case OPLT: - case OPLE: - case OPGT: - case OPGE: - case OPEQ: - case OPNE: - ; - } - - if( ops2[p->exprblock.opcode] <= 0) - badop("putop", p->exprblock.opcode); - lp = p->exprblock.leftp = putx(p->exprblock.leftp); - if (p -> exprblock.rightp) { - tp = p->exprblock.rightp = putx(p->exprblock.rightp); - if (ISCONST(tp) && ISCONST(lp)) - p = fold(p); - } - return p; -} - - LOCAL expptr -#ifdef KR_headers -putpower(p) - expptr p; -#else -putpower(expptr p) -#endif -{ - expptr base; - Addrp t1, t2; - ftnint k; - int type; - char buf[80]; /* buffer for text of comment */ - - if(!ISICON(p->exprblock.rightp) || - (k = p->exprblock.rightp->constblock.Const.ci)<2) - Fatal("putpower: bad call"); - base = p->exprblock.leftp; - type = base->headblock.vtype; - t1 = mktmp(type, ENULL); - t2 = NULL; - - free ((charptr) p); - p = putassign (cpexpr((expptr) t1), base); - - sprintf (buf, "Computing %ld%s power", k, - k == 2 ? "nd" : k == 3 ? "rd" : "th"); - p1_comment (buf); - - for( ; (k&1)==0 && k>2 ; k>>=1 ) - { - p = mkexpr (OPCOMMA, p, putsteq(t1, t1)); - } - - if(k == 2) { - -/* Write the power computation out immediately */ - putout (p); - p = putx( mkexpr(OPSTAR, cpexpr((expptr)t1), cpexpr((expptr)t1))); - } else if (k == 3) { - putout(p); - p = putx( mkexpr(OPSTAR, cpexpr((expptr)t1), - mkexpr(OPSTAR, cpexpr((expptr)t1), cpexpr((expptr)t1)))); - } else { - t2 = mktmp(type, ENULL); - p = mkexpr (OPCOMMA, p, putassign(cpexpr((expptr)t2), - cpexpr((expptr)t1))); - - for(k>>=1 ; k>1 ; k>>=1) - { - p = mkexpr (OPCOMMA, p, putsteq(t1, t1)); - if(k & 1) - { - p = mkexpr (OPCOMMA, p, putsteq(t2, t1)); - } - } -/* Write the power computation out immediately */ - putout (p); - p = putx( mkexpr(OPSTAR, cpexpr((expptr)t2), - mkexpr(OPSTAR, cpexpr((expptr)t1), cpexpr((expptr)t1)))); - } - frexpr((expptr)t1); - if(t2) - frexpr((expptr)t2); - return p; -} - - - - - LOCAL Addrp -#ifdef KR_headers -intdouble(p) - Addrp p; -#else -intdouble(Addrp p) -#endif -{ - register Addrp t; - - t = mktmp(TYDREAL, ENULL); - putout (putassign(cpexpr((expptr)t), (expptr)p)); - return(t); -} - - - - - -/* Complex-type variable assignment */ - - LOCAL Addrp -#ifdef KR_headers -putcxeq(p) - register expptr p; -#else -putcxeq(register expptr p) -#endif -{ - register Addrp lp, rp; - expptr code; - - if(p->tag != TEXPR) - badtag("putcxeq", p->tag); - - lp = putcx1(p->exprblock.leftp); - rp = putcx1(p->exprblock.rightp); - code = putassign ( (expptr)realpart(lp), (expptr)realpart(rp)); - - if( ISCOMPLEX(p->exprblock.vtype) ) - { - code = mkexpr (OPCOMMA, code, putassign - (imagpart(lp), imagpart(rp))); - } - putout (code); - frexpr((expptr)rp); - free ((charptr) p); - return lp; -} - - - -/* putcxop -- used to write out embedded calls to complex functions, and - complex arguments to procedures */ - - expptr -#ifdef KR_headers -putcxop(p) - expptr p; -#else -putcxop(expptr p) -#endif -{ - return (expptr)putaddr((expptr)putcx1(p)); -} - -#define PAIR(x,y) mkexpr (OPCOMMA, (x), (y)) - - LOCAL Addrp -#ifdef KR_headers -putcx1(p) - register expptr p; -#else -putcx1(register expptr p) -#endif -{ - expptr q; - Addrp lp, rp; - register Addrp resp; - int opcode; - int ltype, rtype; - long ts, tskludge; - - if(p == NULL) - return(NULL); - - switch(p->tag) - { - case TCONST: - if( ISCOMPLEX(p->constblock.vtype) ) - p = (expptr) putconst((Constp)p); - return( (Addrp) p ); - - case TADDR: - resp = &p->addrblock; - if (addressable(p)) - return (Addrp) p; - ts = tskludge = 0; - if (q = resp->memoffset) { - if (resp->uname_tag == UNAM_REF) { - q = cpexpr((tagptr)resp); - q->addrblock.vtype = tyint; - q->addrblock.cmplx_sub = 1; - p->addrblock.skip_offset = 1; - resp->user.name->vsubscrused = 1; - resp->uname_tag = UNAM_NAME; - tskludge = typesize[resp->vtype] - * (resp->Field ? 2 : 1); - } - else if (resp->isarray - && resp->vtype != TYCHAR) { - if (ONEOF(resp->vstg, M(STGCOMMON)|M(STGEQUIV)) - && resp->uname_tag == UNAM_NAME) - q = mkexpr(OPMINUS, q, - mkintcon(resp->user.name->voffset)); - ts = typesize[resp->vtype] - * (resp->Field ? 2 : 1); - q = resp->memoffset = mkexpr(OPSLASH, q, - ICON(ts)); - } - } - resp = mktmp(tyint, ENULL); - putout(putassign(cpexpr((expptr)resp), q)); - p->addrblock.memoffset = tskludge - ? mkexpr(OPSTAR, (expptr)resp, ICON(tskludge)) - : (expptr)resp; - if (ts) { - resp = &p->addrblock; - q = mkexpr(OPSTAR, resp->memoffset, ICON(ts)); - if (ONEOF(resp->vstg, M(STGCOMMON)|M(STGEQUIV)) - && resp->uname_tag == UNAM_NAME) - q = mkexpr(OPPLUS, q, - mkintcon(resp->user.name->voffset)); - resp->memoffset = q; - } - return (Addrp) p; - - case TEXPR: - if( ISCOMPLEX(p->exprblock.vtype) ) - break; - resp = mktmp(p->exprblock.vtype, ENULL); - /*first arg of above mktmp call was TYDREAL before 19950102 */ - putout (putassign( cpexpr((expptr)resp), p)); - return(resp); - - case TERROR: - return NULL; - - default: - badtag("putcx1", p->tag); - } - - opcode = p->exprblock.opcode; - if(opcode==OPCALL || opcode==OPCCALL) - { - Addrp t; - p = putcall(p, &t); - putout(p); - return t; - } - else if(opcode == OPASSIGN) - { - return putcxeq (p); - } - -/* BUG (inefficient) Generates too many temporary variables */ - - resp = mktmp(p->exprblock.vtype, ENULL); - if(lp = putcx1(p->exprblock.leftp) ) - ltype = lp->vtype; - if(rp = putcx1(p->exprblock.rightp) ) - rtype = rp->vtype; - - switch(opcode) - { - case OPCOMMA: - frexpr((expptr)resp); - resp = rp; - rp = NULL; - break; - - case OPNEG: - case OPNEG1: - putout (PAIR ( - putassign( (expptr)realpart(resp), - mkexpr(OPNEG, (expptr)realpart(lp), ENULL)), - putassign( imagpart(resp), - mkexpr(OPNEG, imagpart(lp), ENULL)))); - break; - - case OPPLUS: - case OPMINUS: { expptr r; - r = putassign( (expptr)realpart(resp), - mkexpr(opcode, (expptr)realpart(lp), (expptr)realpart(rp) )); - if(rtype < TYCOMPLEX) - q = putassign( imagpart(resp), imagpart(lp) ); - else if(ltype < TYCOMPLEX) - { - if(opcode == OPPLUS) - q = putassign( imagpart(resp), imagpart(rp) ); - else - q = putassign( imagpart(resp), - mkexpr(OPNEG, imagpart(rp), ENULL) ); - } - else - q = putassign( imagpart(resp), - mkexpr(opcode, imagpart(lp), imagpart(rp) )); - r = PAIR (r, q); - putout (r); - break; - } /* case OPPLUS, OPMINUS: */ - case OPSTAR: - if(ltype < TYCOMPLEX) - { - if( ISINT(ltype) ) - lp = intdouble(lp); - putout (PAIR ( - putassign( (expptr)realpart(resp), - mkexpr(OPSTAR, cpexpr((expptr)lp), - (expptr)realpart(rp))), - putassign( imagpart(resp), - mkexpr(OPSTAR, cpexpr((expptr)lp), imagpart(rp))))); - } - else if(rtype < TYCOMPLEX) - { - if( ISINT(rtype) ) - rp = intdouble(rp); - putout (PAIR ( - putassign( (expptr)realpart(resp), - mkexpr(OPSTAR, cpexpr((expptr)rp), - (expptr)realpart(lp))), - putassign( imagpart(resp), - mkexpr(OPSTAR, cpexpr((expptr)rp), imagpart(lp))))); - } - else { - putout (PAIR ( - putassign( (expptr)realpart(resp), mkexpr(OPMINUS, - mkexpr(OPSTAR, (expptr)realpart(lp), - (expptr)realpart(rp)), - mkexpr(OPSTAR, imagpart(lp), imagpart(rp)))), - putassign( imagpart(resp), mkexpr(OPPLUS, - mkexpr(OPSTAR, (expptr)realpart(lp), imagpart(rp)), - mkexpr(OPSTAR, imagpart(lp), - (expptr)realpart(rp)))))); - } - break; - - case OPSLASH: - /* fixexpr has already replaced all divisions - * by a complex by a function call - */ - if( ISINT(rtype) ) - rp = intdouble(rp); - putout (PAIR ( - putassign( (expptr)realpart(resp), - mkexpr(OPSLASH, (expptr)realpart(lp), cpexpr((expptr)rp))), - putassign( imagpart(resp), - mkexpr(OPSLASH, imagpart(lp), cpexpr((expptr)rp))))); - break; - - case OPCONV: - if (!lp) - break; - if(ISCOMPLEX(lp->vtype) ) - q = imagpart(lp); - else if(rp != NULL) - q = (expptr) realpart(rp); - else - q = mkrealcon(TYDREAL, "0"); - putout (PAIR ( - putassign( (expptr)realpart(resp), (expptr)realpart(lp)), - putassign( imagpart(resp), q))); - break; - - default: - badop("putcx1", opcode); - } - - frexpr((expptr)lp); - frexpr((expptr)rp); - free( (charptr) p ); - return(resp); -} - - - - -/* Only .EQ. and .NE. may be performed on COMPLEX data, other relations - are not defined */ - - LOCAL expptr -#ifdef KR_headers -putcxcmp(p) - register expptr p; -#else -putcxcmp(register expptr p) -#endif -{ - int opcode; - register Addrp lp, rp; - expptr q; - - if(p->tag != TEXPR) - badtag("putcxcmp", p->tag); - - opcode = p->exprblock.opcode; - lp = putcx1(p->exprblock.leftp); - rp = putcx1(p->exprblock.rightp); - - q = mkexpr( opcode==OPEQ ? OPAND : OPOR , - mkexpr(opcode, (expptr)realpart(lp), (expptr)realpart(rp)), - mkexpr(opcode, imagpart(lp), imagpart(rp)) ); - - free( (charptr) lp); - free( (charptr) rp); - free( (charptr) p ); - if (ISCONST(q)) - return q; - return putx( fixexpr((Exprp)q) ); -} - -/* putch1 -- Forces constants into the literal pool, among other things */ - - LOCAL Addrp -#ifdef KR_headers -putch1(p) - register expptr p; -#else -putch1(register expptr p) -#endif -{ - Addrp t; - expptr e; - - switch(p->tag) - { - case TCONST: - return( putconst((Constp)p) ); - - case TADDR: - return( (Addrp) p ); - - case TEXPR: - switch(p->exprblock.opcode) - { - expptr q; - - case OPCALL: - case OPCCALL: - - p = putcall(p, &t); - putout (p); - break; - - case OPCONCAT: - t = mktmp(TYCHAR, ICON(lencat(p))); - q = (expptr) cpexpr(p->headblock.vleng); - p = putcat( cpexpr((expptr)t), p ); - /* put the correct length on the block */ - frexpr(t->vleng); - t->vleng = q; - putout (p); - break; - - case OPCONV: - if(!ISICON(p->exprblock.vleng) - || p->exprblock.vleng->constblock.Const.ci!=1 - || ! INT(p->exprblock.leftp->headblock.vtype) ) - Fatal("putch1: bad character conversion"); - t = mktmp(TYCHAR, ICON(1)); - e = mkexpr(OPCONV, (expptr)t, ENULL); - e->headblock.vtype = TYCHAR; - p = putop( mkexpr(OPASSIGN, cpexpr(e), p)); - putout (p); - break; - default: - badop("putch1", p->exprblock.opcode); - } - return(t); - - default: - badtag("putch1", p->tag); - } - /* NOT REACHED */ return 0; -} - - -/* putchop -- Write out a character actual parameter; that is, this is - part of a procedure invocation */ - - Addrp -#ifdef KR_headers -putchop(p) - expptr p; -#else -putchop(expptr p) -#endif -{ - p = putaddr((expptr)putch1(p)); - return (Addrp)p; -} - - - - - LOCAL expptr -#ifdef KR_headers -putcheq(p) - register expptr p; -#else -putcheq(register expptr p) -#endif -{ - expptr lp, rp; - int nbad; - - if(p->tag != TEXPR) - badtag("putcheq", p->tag); - - lp = p->exprblock.leftp; - rp = p->exprblock.rightp; - frexpr(p->exprblock.vleng); - free( (charptr) p ); - -/* If s = t // u, don't bother copying the result, write it directly into - this buffer */ - - nbad = badchleng(lp) + badchleng(rp); - if( rp->tag==TEXPR && rp->exprblock.opcode==OPCONCAT ) - p = putcat(lp, rp); - else if( !nbad - && ISONE(lp->headblock.vleng) - && ISONE(rp->headblock.vleng) ) { - lp = mkexpr(OPCONV, lp, ENULL); - rp = mkexpr(OPCONV, rp, ENULL); - lp->headblock.vtype = rp->headblock.vtype = TYCHAR; - p = putop(mkexpr(OPASSIGN, lp, rp)); - } - else - p = putx( call2(TYSUBR, "s_copy", lp, rp) ); - return p; -} - - - - - LOCAL expptr -#ifdef KR_headers -putchcmp(p) - register expptr p; -#else -putchcmp(register expptr p) -#endif -{ - expptr lp, rp; - - if(p->tag != TEXPR) - badtag("putchcmp", p->tag); - - lp = p->exprblock.leftp; - rp = p->exprblock.rightp; - - if(ISONE(lp->headblock.vleng) && ISONE(rp->headblock.vleng) ) { - lp = mkexpr(OPCONV, lp, ENULL); - rp = mkexpr(OPCONV, rp, ENULL); - lp->headblock.vtype = rp->headblock.vtype = TYCHAR; - } - else { - lp = call2(TYINT,"s_cmp", lp, rp); - rp = ICON(0); - } - p->exprblock.leftp = lp; - p->exprblock.rightp = rp; - p = putop(p); - return p; -} - - - - - -/* putcat -- Writes out a concatenation operation. Two temporary arrays - are allocated, putct1() is called to initialize them, and then a - call to runtime library routine s_cat() is inserted. - - This routine generates code which will perform an (nconc lhs rhs) - at runtime. The runtime funciton does not return a value, the routine - that calls this putcat must remember the name of lhs. -*/ - - - LOCAL expptr -#ifdef KR_headers -putcat(lhs0, rhs) - expptr lhs0; - register expptr rhs; -#else -putcat(expptr lhs0, register expptr rhs) -#endif -{ - register Addrp lhs = (Addrp)lhs0; - int n, tyi; - Addrp length_var, string_var; - expptr p; - static char Writing_concatenation[] = "Writing concatenation"; - -/* Create the temporary arrays */ - - n = ncat(rhs); - length_var = mktmpn(n, tyioint, ENULL); - string_var = mktmpn(n, TYADDR, ENULL); - frtemp((Addrp)cpexpr((expptr)length_var)); - frtemp((Addrp)cpexpr((expptr)string_var)); - -/* Initialize the arrays */ - - n = 0; - /* p1_comment scribbles on its argument, so we - * cannot safely pass a string literal here. */ - p1_comment(Writing_concatenation); - putct1(rhs, length_var, string_var, &n); - -/* Create the invocation */ - - tyi = tyint; - tyint = tyioint; /* for -I2 */ - p = putx (call4 (TYSUBR, "s_cat", - (expptr)lhs, - (expptr)string_var, - (expptr)length_var, - (expptr)putconst((Constp)ICON(n)))); - tyint = tyi; - - return p; -} - - - - - - LOCAL void -#ifdef KR_headers -putct1(q, length_var, string_var, ip) - register expptr q; - register Addrp length_var; - register Addrp string_var; - int *ip; -#else -putct1(register expptr q, register Addrp length_var, register Addrp string_var, int *ip) -#endif -{ - int i; - Addrp length_copy, string_copy; - expptr e; - extern int szleng; - - if(q->tag==TEXPR && q->exprblock.opcode==OPCONCAT) - { - putct1(q->exprblock.leftp, length_var, string_var, - ip); - putct1(q->exprblock.rightp, length_var, string_var, - ip); - frexpr (q -> exprblock.vleng); - free ((charptr) q); - } - else - { - i = (*ip)++; - e = cpexpr(q->headblock.vleng); - if (!e) - return; /* error -- character*(*) */ - length_copy = (Addrp) cpexpr((expptr)length_var); - length_copy->memoffset = - mkexpr(OPPLUS,length_copy->memoffset, ICON(i*szleng)); - string_copy = (Addrp) cpexpr((expptr)string_var); - string_copy->memoffset = - mkexpr(OPPLUS, string_copy->memoffset, - ICON(i*typesize[TYADDR])); - putout (PAIR (putassign((expptr)length_copy, e), - putassign((expptr)string_copy, addrof((expptr)putch1(q))))); - } -} - -/* putaddr -- seems to write out function invocation actual parameters */ - - LOCAL expptr -#ifdef KR_headers -putaddr(p0) - expptr p0; -#else -putaddr(expptr p0) -#endif -{ - register Addrp p; - chainp cp; - - if (!(p = (Addrp)p0)) - return ENULL; - - if( p->tag==TERROR || (p->memoffset!=NULL && ISERROR(p->memoffset)) ) - { - frexpr((expptr)p); - return ENULL; - } - if (p->isarray && p->memoffset) - if (p->uname_tag == UNAM_REF) { - cp = p->memoffset->listblock.listp; - for(; cp; cp = cp->nextp) - cp->datap = (char *)fixtype((tagptr)cp->datap); - } - else - p->memoffset = putx(p->memoffset); - return (expptr) p; -} - - LOCAL expptr -#ifdef KR_headers -addrfix(e) - expptr e; -#else -addrfix(expptr e) -#endif - /* fudge character string length if it's a TADDR */ -{ - return e->tag == TADDR ? mkexpr(OPIDENTITY, e, ENULL) : e; - } - - LOCAL int -#ifdef KR_headers -typekludge(ccall, q, at, j) - int ccall; - register expptr q; - Atype *at; - int j; -#else -typekludge(int ccall, register expptr q, Atype *at, int j) -#endif - /* j = alternate type */ -{ - register int i, k; - extern int iocalladdr; - register Namep np; - - /* Return value classes: - * < 100 ==> Fortran arg (pointer to type) - * < 200 ==> C arg - * < 300 ==> procedure arg - * < 400 ==> external, no explicit type - * < 500 ==> arg that may turn out to be - * either a variable or a procedure - */ - - k = q->headblock.vtype; - if (ccall) { - if (k == TYREAL) - k = TYDREAL; /* force double for library routines */ - return k + 100; - } - if (k == TYADDR) - return iocalladdr; - i = q->tag; - if ((i == TEXPR && q->exprblock.opcode != OPCOMMA_ARG) - || (i == TADDR && q->addrblock.charleng) - || i == TCONST) - k = TYFTNLEN + 100; - else if (i == TADDR) - switch(q->addrblock.vclass) { - case CLPROC: - if (q->addrblock.uname_tag != UNAM_NAME) - k += 200; - else if ((np = q->addrblock.user.name)->vprocclass - != PTHISPROC) { - if (k && !np->vimpltype) - k += 200; - else { - if (j > 200 && infertypes && j < 300) { - k = j; - inferdcl(np, j-200); - } - else k = (np->vstg == STGEXT - ? extsymtab[np->vardesc.varno].extype - : 0) + 200; - at->cp = mkchain((char *)np, at->cp); - } - } - else if (k == TYSUBR) - k += 200; - break; - - case CLUNKNOWN: - if (q->addrblock.vstg == STGARG - && q->addrblock.uname_tag == UNAM_NAME) { - k += 400; - at->cp = mkchain((char *)q->addrblock.user.name, - at->cp); - } - } - else if (i == TNAME && q->nameblock.vstg == STGARG) { - np = &q->nameblock; - switch(np->vclass) { - case CLPROC: - if (!np->vimpltype) - k += 200; - else if (j <= 200 || !infertypes || j >= 300) - k += 300; - else { - k = j; - inferdcl(np, j-200); - } - goto add2chain; - - case CLUNKNOWN: - /* argument may be a scalar variable or a function */ - if (np->vimpltype && j && infertypes - && j < 300) { - inferdcl(np, j % 100); - k = j; - } - else - k += 400; - - /* to handle procedure args only so far known to be - * external, save a pointer to the symbol table entry... - */ - add2chain: - at->cp = mkchain((char *)np, at->cp); - } - } - return k; - } - - char * -#ifdef KR_headers -Argtype(k, buf) - int k; - char *buf; -#else -Argtype(int k, char *buf) -#endif -{ - if (k < 100) { - sprintf(buf, "%s variable", ftn_types[k]); - return buf; - } - if (k < 200) { - k -= 100; - return ftn_types[k]; - } - if (k < 300) { - k -= 200; - if (k == TYSUBR) - return ftn_types[TYSUBR]; - sprintf(buf, "%s function", ftn_types[k]); - return buf; - } - if (k < 400) - return "external argument"; - k -= 400; - sprintf(buf, "%s argument", ftn_types[k]); - return buf; - } - - static void -#ifdef KR_headers -atype_squawk(at, msg) - Argtypes *at; - char *msg; -#else -atype_squawk(Argtypes *at, char *msg) -#endif -{ - register Atype *a, *ae; - warn(msg); - for(a = at->atypes, ae = a + at->nargs; a < ae; a++) - frchain(&a->cp); - at->nargs = -1; - if (at->changes & 2 && !at->defined) - proc_protochanges++; - } - - static char inconsist[] = "inconsistent calling sequences for "; - - void -#ifdef KR_headers -bad_atypes(at, fname, i, j, k, here, prev) - Argtypes *at; - char *fname; - int i; - int j; - int k; - char *here; - char *prev; -#else -bad_atypes(Argtypes *at, char *fname, int i, int j, int k, char *here, char *prev) -#endif -{ - char buf[208], buf1[32], buf2[32]; - - sprintf(buf, "%s%.90s,\n\targ %d: %s%s%s %s.", - inconsist, fname, i, here, Argtype(k, buf1), - prev, Argtype(j, buf2)); - atype_squawk(at, buf); - } - - int -#ifdef KR_headers -type_fixup(at, a, k) - Argtypes *at; - Atype *a; - int k; -#else -type_fixup(Argtypes *at, Atype *a, int k) -#endif -{ - register struct Entrypoint *ep; - if (!infertypes) - return 0; - for(ep = entries; ep; ep = ep->entnextp) - if (ep->entryname && at == ep->entryname->arginfo) { - a->type = k % 100; - return proc_argchanges = 1; - } - return 0; - } - - - void -#ifdef KR_headers -save_argtypes(arglist, at0, at1, ccall, fname, stg, nchargs, type, zap) - chainp arglist; - Argtypes **at0; - Argtypes **at1; - int ccall; - char *fname; - int stg; - int nchargs; - int type; - int zap; -#else -save_argtypes(chainp arglist, Argtypes **at0, Argtypes **at1, int ccall, char *fname, int stg, int nchargs, int type, int zap) -#endif -{ - Argtypes *at; - chainp cp; - int i, i0, j, k, nargs, nbad, *t, *te; - Atype *atypes; - expptr q; - char buf[208], buf1[32], buf2[32]; - static int initargs[4] = {TYCOMPLEX, TYDCOMPLEX, TYCHAR, TYFTNLEN+100}; - static int *init_ap[TYSUBR+1] = {0,0,0,0,0,0,0, -#ifdef TYQUAD - 0, -#endif - initargs, initargs+1,0,0,0,initargs+2}; - - i0 = init_ac[type]; - t = init_ap[type]; - te = t + i0; - if (at = *at0) { - *at1 = at; - nargs = at->nargs; - if (nargs < 0 && type && at->changes & 2 && !at->defined) - --proc_protochanges; - if (at->dnargs >= 0 && zap != 2) - type = 0; - if (nargs < 0) { /* inconsistent usage seen */ - if (type) - goto newlist; - return; - } - atypes = at->atypes; - i = nchargs; - for(nbad = 0; t < te; atypes++) { - if (++i > nargs) { - toomany: - i = nchargs + i0; - for(cp = arglist; cp; cp = cp->nextp) - i++; - toofew: - switch(zap) { - case 2: zap = 6; break; - case 1: if (at->defined & 4) - return; - } - sprintf(buf, - "%s%.90s:\n\there %d, previously %d args and string lengths.", - inconsist, fname, i, nargs); - atype_squawk(at, buf); - if (type) { - t = init_ap[type]; - goto newlist; - } - return; - } - j = atypes->type; - k = *t++; - if (j != k && j-400 != k) { - cp = 0; - goto badtypes; - } - } - for(cp = arglist; cp; atypes++, cp = cp->nextp) { - if (++i > nargs) - goto toomany; - j = atypes->type; - if (!(q = (expptr)cp->datap)) - continue; - k = typekludge(ccall, q, atypes, j); - if (k >= 300 || k == j) - continue; - if (j >= 300) { - if (k >= 200) { - if (k == TYUNKNOWN + 200) - continue; - if (j % 100 != k - 200 - && k != TYSUBR + 200 - && j != TYUNKNOWN + 300 - && !type_fixup(at,atypes,k)) - goto badtypes; - } - else if (j % 100 % TYSUBR != k % TYSUBR - && !type_fixup(at,atypes,k)) - goto badtypes; - } - else if (k < 200 || j < 200) - if (j) { - if (k == TYUNKNOWN - && q->tag == TNAME - && q->nameblock.vinfproc) { - q->nameblock.vdcldone = 0; - impldcl((Namep)q); - } - goto badtypes; - } - else ; /* fall through to update */ - else if (k == TYUNKNOWN+200) - continue; - else if (j != TYUNKNOWN+200) - { - badtypes: - if (++nbad == 1) - bad_atypes(at, fname, i - nchargs, - j, k, "here ", ", previously"); - else - fprintf(stderr, - "\targ %d: here %s, previously %s.\n", - i - nchargs, Argtype(k,buf1), - Argtype(j,buf2)); - if (!cp) - break; - continue; - } - /* We've subsequently learned the right type, - as in the call on zoo below... - - subroutine foo(x, zap) - external zap - call goo(zap) - x = zap(3) - call zoo(zap) - end - */ - if (!nbad) { - atypes->type = k; - at->changes |= 1; - } - } - if (i < nargs) - goto toofew; - if (nbad) { - if (type) { - /* we're defining the procedure */ - t = init_ap[type]; - te = t + i0; - proc_argchanges = 1; - goto newlist; - } - return; - } - if (zap == 1 && (at->changes & 5) != 5) - at->changes = 0; - return; - } - newlist: - i = i0 + nchargs; - for(cp = arglist; cp; cp = cp->nextp) - i++; - k = sizeof(Argtypes) + (i-1)*sizeof(Atype); - *at0 = *at1 = at = stg == STGEXT ? (Argtypes *)gmem(k,1) - : (Argtypes *) mem(k,1); - at->dnargs = at->nargs = i; - at->defined = zap & 6; - at->changes = type ? 0 : 4; - atypes = at->atypes; - for(; t < te; atypes++) { - atypes->type = *t++; - atypes->cp = 0; - } - for(cp = arglist; cp; atypes++, cp = cp->nextp) { - atypes->cp = 0; - atypes->type = (q = (expptr)cp->datap) - ? typekludge(ccall, q, atypes, 0) - : 0; - } - for(; --nchargs >= 0; atypes++) { - atypes->type = TYFTNLEN + 100; - atypes->cp = 0; - } - } - - static char* -#ifdef KR_headers -get_argtypes(p, pat0, pat1) Exprp p; Argtypes ***pat0, ***pat1; -#else -get_argtypes(Exprp p, Argtypes ***pat0, Argtypes ***pat1) -#endif -{ - Addrp a; - Argtypes **at0, **at1; - Namep np; - expptr rp; - Extsym *e; - char *fname; - - a = (Addrp)p->leftp; - switch(a->vstg) { - case STGEXT: - switch(a->uname_tag) { - case UNAM_EXTERN: /* e.g., sqrt() */ - e = extsymtab + a->memno; - at0 = at1 = &e->arginfo; - fname = e->fextname; - break; - case UNAM_NAME: - np = a->user.name; - at0 = &extsymtab[np->vardesc.varno].arginfo; - at1 = &np->arginfo; - fname = np->fvarname; - break; - default: - goto bug; - } - break; - case STGARG: - if (a->uname_tag != UNAM_NAME) - goto bug; - np = a->user.name; - at0 = at1 = &np->arginfo; - fname = np->fvarname; - break; - default: - bug: - Fatal("Confusion in saveargtypes"); - } - *pat0 = at0; - *pat1 = at1; - return fname; - } - - void -#ifdef KR_headers -saveargtypes(p) - register Exprp p; -#else -saveargtypes(register Exprp p) -#endif - /* for writing prototypes */ -{ - Argtypes **at0, **at1; - chainp arglist; - expptr rp; - char *fname; - - fname = get_argtypes(p, &at0, &at1); - rp = p->rightp; - arglist = rp && rp->tag == TLIST ? rp->listblock.listp : 0; - save_argtypes(arglist, at0, at1, p->opcode == OPCCALL, - fname, p->leftp->addrblock.vstg, 0, 0, 0); - } - -/* putcall - fix up the argument list, and write out the invocation. p - is expected to be initialized and point to an OPCALL or OPCCALL - expression. The return value is a pointer to a temporary holding the - result of a COMPLEX or CHARACTER operation, or NULL. */ - - LOCAL expptr -#ifdef KR_headers -putcall(p0, temp) - expptr p0; - Addrp *temp; -#else -putcall(expptr p0, Addrp *temp) -#endif -{ - register Exprp p = (Exprp)p0; - chainp arglist; /* Pointer to actual arguments, if any */ - chainp charsp; /* List of copies of the variables which - hold the lengths of character - parameters (other than procedure - parameters) */ - chainp cp; /* Iterator over argument lists */ - register expptr q; /* Pointer to the current argument */ - Addrp fval; /* Function return value */ - int type; /* type of the call - presumably this was - set elsewhere */ - int byvalue; /* True iff we don't want to massage the - parameter list, since we're calling a C - library routine */ - char *s; - Argtypes *at, **at0, **at1; - Atype *At, *Ate; - - type = p -> vtype; - charsp = NULL; - byvalue = (p->opcode == OPCCALL); - -/* Verify the actual parameters */ - - if (p == (Exprp) NULL) - err ("putcall: NULL call expression"); - else if (p -> tag != TEXPR) - erri ("putcall: expected TEXPR, got '%d'", p -> tag); - -/* Find the argument list */ - - if(p->rightp && p -> rightp -> tag == TLIST) - arglist = p->rightp->listblock.listp; - else - arglist = NULL; - -/* Count the number of explicit arguments, including lengths of character - variables */ - - if (!byvalue) { - get_argtypes(p, &at0, &at1); - At = Ate = 0; - if ((at = *at0) && at->nargs >= 0) { - At = at->atypes; - Ate = At + at->nargs; - At += init_ac[type]; - } - for(cp = arglist ; cp ; cp = cp->nextp) { - q = (expptr) cp->datap; - if( ISCONST(q) ) { - -/* Even constants are passed by reference, so we need to put them in the - literal table */ - - q = (expptr) putconst((Constp)q); - cp->datap = (char *) q; - } - -/* Save the length expression of character variables (NOT character - procedures) for the end of the argument list */ - - if( ISCHAR(q) && - (q->headblock.vclass != CLPROC - || q->headblock.vstg == STGARG - && q->tag == TADDR - && q->addrblock.uname_tag == UNAM_NAME - && q->addrblock.user.name->vprocclass == PTHISPROC) - && (!At || At->type % 100 % TYSUBR == TYCHAR)) - { - p0 = cpexpr(q->headblock.vleng); - charsp = mkchain((char *)p0, charsp); - if (q->headblock.vclass == CLUNKNOWN - && q->headblock.vstg == STGARG) - q->addrblock.user.name->vpassed = 1; - else if (q->tag == TADDR - && q->addrblock.uname_tag == UNAM_CONST) - p0->constblock.Const.ci - += q->addrblock.user.Const.ccp1.blanks; - } - if (At && ++At == Ate) - At = 0; - } - } - charsp = revchain(charsp); - -/* If the routine is a CHARACTER function ... */ - - if(type == TYCHAR) - { - if( ISICON(p->vleng) ) - { - -/* Allocate a temporary to hold the return value of the function */ - - fval = mktmp(TYCHAR, p->vleng); - } - else { - err("adjustable character function"); - if (temp) - *temp = 0; - return 0; - } - } - -/* If the routine is a COMPLEX function ... */ - - else if( ISCOMPLEX(type) ) - fval = mktmp(type, ENULL); - else - fval = NULL; - -/* Write the function name, without taking its address */ - - p -> leftp = putx(fixtype(putaddr(p->leftp))); - - if(fval) - { - chainp prepend; - -/* Prepend a copy of the function return value buffer out as the first - argument. */ - - prepend = mkchain((char *)putx(putaddr(cpexpr((expptr)fval))), arglist); - -/* If it's a character function, also prepend the length of the result */ - - if(type==TYCHAR) - { - - prepend->nextp = mkchain((char *)putx(mkconv(TYLENG, - p->vleng)), arglist); - } - if (!(q = p->rightp)) - p->rightp = q = (expptr)mklist(CHNULL); - q->listblock.listp = prepend; - } - -/* Scan through the fortran argument list */ - - for(cp = arglist ; cp ; cp = cp->nextp) - { - q = (expptr) (cp->datap); - if (q == ENULL) - err ("putcall: NULL argument"); - -/* call putaddr only when we've got a parameter for a C routine or a - memory resident parameter */ - - if (q -> tag == TCONST && !byvalue) - q = (expptr) putconst ((Constp)q); - - if(q->tag==TADDR && (byvalue || q->addrblock.vstg!=STGREG) ) { - if (q->addrblock.parenused - && !byvalue && q->headblock.vtype != TYCHAR) - goto make_copy; - cp->datap = (char *)putaddr(q); - } - else if( ISCOMPLEX(q->headblock.vtype) ) - cp -> datap = (char *) putx (fixtype(putcxop(q))); - else if (ISCHAR(q) ) - cp -> datap = (char *) putx (fixtype((expptr)putchop(q))); - else if( ! ISERROR(q) ) - { - if(byvalue) { - if (q->tag == TEXPR && q->exprblock.opcode == OPCONV) { - if (ISCOMPLEX(q->exprblock.leftp->headblock.vtype) - && q->exprblock.leftp->tag == TEXPR) - q->exprblock.leftp = putcxop(q->exprblock.leftp); - else - q->exprblock.leftp = putx(q->exprblock.leftp); - } - else - cp -> datap = (char *) putx(q); - } - else if (q->tag == TEXPR && q->exprblock.opcode == OPCHARCAST) - cp -> datap = (char *) putx(q); - else { - expptr t, t1; - -/* If we've got a register parameter, or (maybe?) a constant, save it in a - temporary first */ - make_copy: - t = (expptr) mktmp(q->headblock.vtype, q->headblock.vleng); - -/* Assign to temporary variables before invoking the subroutine or - function */ - - t1 = putassign( cpexpr(t), q ); - if (doin_setbound) - t = mkexpr(OPCOMMA_ARG, t1, t); - else - putout(t1); - cp -> datap = (char *) t; - } /* else */ - } /* if !ISERROR(q) */ - } - -/* Now adjust the lengths of the CHARACTER parameters */ - - for(cp = charsp ; cp ; cp = cp->nextp) - cp->datap = (char *)addrfix(putx( - /* in case MAIN has a character*(*)... */ - (s = cp->datap) ? mkconv(TYLENG,(expptr)s) - : ICON(0))); - -/* ... and add them to the end of the argument list */ - - hookup (arglist, charsp); - -/* Return the name of the temporary used to hold the results, if any was - necessary. */ - - if (temp) *temp = fval; - else frexpr ((expptr)fval); - - saveargtypes(p); - - return (expptr) p; -} - - - -/* putmnmx -- Put min or max. p must point to an EXPR, not just a - CONST */ - - LOCAL expptr -#ifdef KR_headers -putmnmx(p) - register expptr p; -#else -putmnmx(register expptr p) -#endif -{ - int op, op2, type; - expptr arg, qp, temp; - chainp p0, p1; - Addrp sp, tp; - char comment_buf[80]; - char *what; - - if(p->tag != TEXPR) - badtag("putmnmx", p->tag); - - type = p->exprblock.vtype; - op = p->exprblock.opcode; - op2 = op == OPMIN ? OPMIN2 : OPMAX2; - p0 = p->exprblock.leftp->listblock.listp; - free( (charptr) (p->exprblock.leftp) ); - free( (charptr) p ); - - /* special case for two addressable operands */ - - if (addressable((expptr)p0->datap) - && (p1 = p0->nextp) - && addressable((expptr)p1->datap) - && !p1->nextp) { - if (type == TYREAL && forcedouble) - op2 = op == OPMIN ? OPDMIN : OPDMAX; - p = mkexpr(op2, mkconv(type, cpexpr((expptr)p0->datap)), - mkconv(type, cpexpr((expptr)p1->datap))); - frchain(&p0); - return p; - } - - /* general case */ - - sp = mktmp(type, ENULL); - -/* We only need a second temporary if the arg list has an unaddressable - value */ - - tp = (Addrp) NULL; - qp = ENULL; - for (p1 = p0 -> nextp; p1; p1 = p1 -> nextp) - if (!addressable ((expptr) p1 -> datap)) { - tp = mktmp(type, ENULL); - qp = mkexpr(op2, cpexpr((expptr)sp), cpexpr((expptr)tp)); - qp = fixexpr((Exprp)qp); - break; - } /* if */ - -/* Now output the appropriate number of assignments and comparisons. Min - and max are implemented by the simple O(n) algorithm: - - min (a, b, c, d) ==> - { <type> t1, t2; - - t1 = a; - t2 = b; t1 = (t1 < t2) ? t1 : t2; - t2 = c; t1 = (t1 < t2) ? t1 : t2; - t2 = d; t1 = (t1 < t2) ? t1 : t2; - } -*/ - - if (!doin_setbound) { - switch(op) { - case OPLT: - case OPMIN: - case OPDMIN: - case OPMIN2: - what = "IN"; - break; - default: - what = "AX"; - } - sprintf (comment_buf, "Computing M%s", what); - p1_comment (comment_buf); - } - - p1 = p0->nextp; - temp = (expptr)p0->datap; - if (addressable(temp) && addressable((expptr)p1->datap)) { - p = mkconv(type, cpexpr(temp)); - arg = mkconv(type, cpexpr((expptr)p1->datap)); - temp = mkexpr(op2, p, arg); - if (!ISCONST(temp)) - temp = fixexpr((Exprp)temp); - p1 = p1->nextp; - } - p = putassign (cpexpr((expptr)sp), temp); - - for(; p1 ; p1 = p1->nextp) - { - if (addressable ((expptr) p1 -> datap)) { - arg = mkconv(type, cpexpr((expptr)p1->datap)); - temp = mkexpr(op2, cpexpr((expptr)sp), arg); - temp = fixexpr((Exprp)temp); - } else { - temp = (expptr) cpexpr (qp); - p = mkexpr(OPCOMMA, p, - putassign(cpexpr((expptr)tp), (expptr)p1->datap)); - } /* else */ - - if(p1->nextp) - p = mkexpr(OPCOMMA, p, - putassign(cpexpr((expptr)sp), temp)); - else { - if (type == TYREAL && forcedouble) - temp->exprblock.opcode = - op == OPMIN ? OPDMIN : OPDMAX; - if (doin_setbound) - p = mkexpr(OPCOMMA, p, temp); - else { - putout (p); - p = putx(temp); - } - if (qp) - frexpr (qp); - } /* else */ - } /* for */ - - frchain( &p0 ); - return p; -} - - - void -#ifdef KR_headers -putwhile(p) - expptr p; -#else -putwhile(expptr p) -#endif -{ - long where; - int k, n; - - if (wh_next >= wh_last) - { - k = wh_last - wh_first; - n = k + 100; - wh_next = mem(n,0); - wh_last = wh_first + n; - if (k) - memcpy(wh_next, wh_first, k); - wh_first = wh_next; - wh_next += k; - wh_last = wh_first + n; - } - p1put(P1_WHILE1START); - where = ftell(pass1_file); - if( !ISLOGICAL((k = (p = fixtype(p))->headblock.vtype))) - { - if(k != TYERROR) - err("non-logical expression in DO WHILE statement"); - } - else { - p = putx(p); - *wh_next++ = ftell(pass1_file) > where; - p1put(P1_WHILE2START); - p1_expr(p); - } - } diff --git a/usr.bin/f2c/sysdep.c b/usr.bin/f2c/sysdep.c deleted file mode 100644 index 54690345be8c..000000000000 --- a/usr.bin/f2c/sysdep.c +++ /dev/null @@ -1,519 +0,0 @@ -/**************************************************************** -Copyright 1990 - 1994 by AT&T, Lucent Technologies and Bellcore. - -Permission to use, copy, modify, and distribute this software -and its documentation for any purpose and without fee is hereby -granted, provided that the above copyright notice appear in all -copies and that both that the copyright notice and this -permission notice and warranty disclaimer appear in supporting -documentation, and that the names of AT&T, Bell Laboratories, -Lucent or Bellcore or any of their entities not be used in -advertising or publicity pertaining to distribution of the -software without specific, written prior permission. - -AT&T, Lucent and Bellcore disclaim all warranties with regard to -this software, including all implied warranties of -merchantability and fitness. In no event shall AT&T, Lucent or -Bellcore be liable for any special, indirect or consequential -damages or any damages whatsoever resulting from loss of use, -data or profits, whether in an action of contract, negligence or -other tortious action, arising out of or in connection with the -use or performance of this software. -****************************************************************/ -#include "defs.h" -#include "usignal.h" - -char binread[] = "rb", textread[] = "r"; -char binwrite[] = "wb", textwrite[] = "w"; -char *c_functions = "c_functions"; -char *coutput = "c_output"; -char *initfname = "raw_data"; -char *initbname = "raw_data.b"; -char *blkdfname = "block_data"; -char *p1_file = "p1_file"; -char *p1_bakfile = "p1_file.BAK"; -char *sortfname = "init_file"; -char *proto_fname = "proto_file"; - -char link_msg[] = "-lf2c -lm"; /* was "-lF77 -lI77 -lm -lc"; */ - -char *outbuf = "", *outbtail; - -#ifndef TMPDIR -#ifdef MSDOS -#define TMPDIR "" -#else -#define TMPDIR "/tmp" -#endif -#endif - -char *tmpdir = TMPDIR; -#ifndef MSDOS -#ifndef KR_headers -extern int getpid(void); -#endif -#endif - - void -#ifdef KR_headers -Un_link_all(cdelete) - int cdelete; -#else -Un_link_all(int cdelete) -#endif -{ -#ifndef KR_headers - extern int unlink(const char *); -#endif - if (!debugflag) { - unlink(c_functions); - unlink(initfname); - unlink(p1_file); - unlink(sortfname); - unlink(blkdfname); - if (cdelete && coutput) - unlink(coutput); - } - } - - void -set_tmp_names(Void) -{ - int k; - if (debugflag == 1) - return; - k = strlen(tmpdir) + 24; - c_functions = (char *)ckalloc(7*k); - initfname = c_functions + k; - initbname = initfname + k; - blkdfname = initbname + k; - p1_file = blkdfname + k; - p1_bakfile = p1_file + k; - sortfname = p1_bakfile + k; - { -#ifdef MSDOS - char buf[64], *s, *t; - if (!*tmpdir || *tmpdir == '.' && !tmpdir[1]) - t = ""; - else { - /* substitute \ for / to avoid confusion with a - * switch indicator in the system("sort ...") - * call in formatdata.c - */ - for(s = tmpdir, t = buf; *s; s++, t++) - if ((*t = *s) == '/') - *t = '\\'; - if (t[-1] != '\\') - *t++ = '\\'; - *t = 0; - t = buf; - } - sprintf(c_functions, "%sf2c_func", t); - sprintf(initfname, "%sf2c_rd", t); - sprintf(blkdfname, "%sf2c_blkd", t); - sprintf(p1_file, "%sf2c_p1f", t); - sprintf(p1_bakfile, "%sf2c_p1fb", t); - sprintf(sortfname, "%sf2c_sort", t); -#else - long pid = getpid(); - sprintf(c_functions, "%s/f2c%ld_func", tmpdir, pid); - sprintf(initfname, "%s/f2c%ld_rd", tmpdir, pid); - sprintf(blkdfname, "%s/f2c%ld_blkd", tmpdir, pid); - sprintf(p1_file, "%s/f2c%ld_p1f", tmpdir, pid); - sprintf(p1_bakfile, "%s/f2c%ld_p1fb", tmpdir, pid); - sprintf(sortfname, "%s/f2c%ld_sort", tmpdir, pid); -#endif - sprintf(initbname, "%s.b", initfname); - } - if (debugflag) - fprintf(diagfile, "%s %s %s %s %s %s\n", c_functions, - initfname, blkdfname, p1_file, p1_bakfile, sortfname); - } - - char * -#ifdef KR_headers -c_name(s, ft) - char *s; - int ft; -#else -c_name(char *s, int ft) -#endif -{ - char *b, *s0; - int c; - - b = s0 = s; - while(c = *s++) - if (c == '/') - b = s; - if (--s < s0 + 3 || s[-2] != '.' - || ((c = *--s) != 'f' && c != 'F')) { - infname = s0; - Fatal("file name must end in .f or .F"); - } - strcpy(outbtail, b); - outbtail[s-b] = ft; - b = copys(outbuf); - return b; - } - - static void -#ifdef KR_headers -killed(sig) - int sig; -#else -killed(int sig) -#endif -{ - sig = sig; /* shut up warning */ - signal(SIGINT, SIG_IGN); -#ifdef SIGQUIT - signal(SIGQUIT, SIG_IGN); -#endif -#ifdef SIGHUP - signal(SIGHUP, SIG_IGN); -#endif - signal(SIGTERM, SIG_IGN); - Un_link_all(1); - exit(126); - } - - static void -#ifdef KR_headers -sig1catch(sig) - int sig; -#else -sig1catch(int sig) -#endif -{ - sig = sig; /* shut up warning */ - if (signal(sig, SIG_IGN) != SIG_IGN) - signal(sig, killed); - } - - static void -#ifdef KR_headers -flovflo(sig) - int sig; -#else -flovflo(int sig) -#endif -{ - sig = sig; /* shut up warning */ - Fatal("floating exception during constant evaluation; cannot recover"); - /* vax returns a reserved operand that generates - an illegal operand fault on next instruction, - which if ignored causes an infinite loop. - */ - signal(SIGFPE, flovflo); -} - - void -#ifdef KR_headers -sigcatch(sig) - int sig; -#else -sigcatch(int sig) -#endif -{ - sig = sig; /* shut up warning */ - sig1catch(SIGINT); -#ifdef SIGQUIT - sig1catch(SIGQUIT); -#endif -#ifdef SIGHUP - sig1catch(SIGHUP); -#endif - sig1catch(SIGTERM); - signal(SIGFPE, flovflo); /* catch overflows */ - } - - -dofork(Void) -{ -#ifdef MSDOS - Fatal("Only one Fortran input file allowed under MS-DOS"); -#else -#ifndef KR_headers - extern int fork(void), wait(int*); -#endif - int pid, status, w; - extern int retcode; - - if (!(pid = fork())) - return 1; - if (pid == -1) - Fatal("bad fork"); - while((w = wait(&status)) != pid) - if (w == -1) - Fatal("bad wait code"); - retcode |= status >> 8; -#endif - return 0; - } - -/* Initialization of tables that change with the character set... */ - -char escapes[Table_size]; - -#ifdef non_ASCII -char *str_fmt[Table_size]; -static char *str0fmt[127] = { /*}*/ -#else -char *str_fmt[Table_size] = { -#endif - "\\000", "\\001", "\\002", "\\003", "\\004", "\\005", "\\006", "\\007", - "\\b", "\\t", "\\n", "\\013", "\\f", "\\r", "\\016", "\\017", - "\\020", "\\021", "\\022", "\\023", "\\024", "\\025", "\\026", "\\027", - "\\030", "\\031", "\\032", "\\033", "\\034", "\\035", "\\036", "\\037", - " ", "!", "\\\"", "#", "$", "%%", "&", "'", - "(", ")", "*", "+", ",", "-", ".", "/", - "0", "1", "2", "3", "4", "5", "6", "7", - "8", "9", ":", ";", "<", "=", ">", "?", - "@", "A", "B", "C", "D", "E", "F", "G", - "H", "I", "J", "K", "L", "M", "N", "O", - "P", "Q", "R", "S", "T", "U", "V", "W", - "X", "Y", "Z", "[", "\\\\", "]", "^", "_", - "`", "a", "b", "c", "d", "e", "f", "g", - "h", "i", "j", "k", "l", "m", "n", "o", - "p", "q", "r", "s", "t", "u", "v", "w", - "x", "y", "z", "{", "|", "}", "~" - }; - -#ifdef non_ASCII -char *chr_fmt[Table_size]; -static char *chr0fmt[127] = { /*}*/ -#else -char *chr_fmt[Table_size] = { -#endif - "\\0", "\\1", "\\2", "\\3", "\\4", "\\5", "\\6", "\\7", - "\\b", "\\t", "\\n", "\\13", "\\f", "\\r", "\\16", "\\17", - "\\20", "\\21", "\\22", "\\23", "\\24", "\\25", "\\26", "\\27", - "\\30", "\\31", "\\32", "\\33", "\\34", "\\35", "\\36", "\\37", - " ", "!", "\"", "#", "$", "%%", "&", "\\'", - "(", ")", "*", "+", ",", "-", ".", "/", - "0", "1", "2", "3", "4", "5", "6", "7", - "8", "9", ":", ";", "<", "=", ">", "?", - "@", "A", "B", "C", "D", "E", "F", "G", - "H", "I", "J", "K", "L", "M", "N", "O", - "P", "Q", "R", "S", "T", "U", "V", "W", - "X", "Y", "Z", "[", "\\\\", "]", "^", "_", - "`", "a", "b", "c", "d", "e", "f", "g", - "h", "i", "j", "k", "l", "m", "n", "o", - "p", "q", "r", "s", "t", "u", "v", "w", - "x", "y", "z", "{", "|", "}", "~" - }; - - void -fmt_init(Void) -{ - static char *str1fmt[6] = - { "\\b", "\\t", "\\n", "\\f", "\\r", "\\%03o" }; - register int i, j; - register char *s; - - /* str_fmt */ - -#ifdef non_ASCII - i = 0; -#else - i = 127; -#endif - for(; i < Table_size; i++) - str_fmt[i] = "\\%03o"; -#ifdef non_ASCII - for(i = 32; i < 127; i++) { - s = str0fmt[i]; - str_fmt[*(unsigned char *)s] = s; - } - str_fmt['"'] = "\\\""; -#else - if (Ansi == 1) - str_fmt[7] = chr_fmt[7] = "\\a"; -#endif - - /* chr_fmt */ - -#ifdef non_ASCII - for(i = 0; i < 32; i++) - chr_fmt[i] = chr0fmt[i]; -#else - i = 127; -#endif - for(; i < Table_size; i++) - chr_fmt[i] = "\\%o"; -#ifdef non_ASCII - for(i = 32; i < 127; i++) { - s = chr0fmt[i]; - j = *(unsigned char *)s; - if (j == '\\') - j = *(unsigned char *)(s+1); - chr_fmt[j] = s; - } -#endif - - /* escapes (used in lex.c) */ - - for(i = 0; i < Table_size; i++) - escapes[i] = i; - for(s = "btnfr0", i = 0; i < 6; i++) - escapes[*(unsigned char *)s++] = "\b\t\n\f\r"[i]; - /* finish str_fmt and chr_fmt */ - - if (Ansi) - str1fmt[5] = "\\v"; - if ('\v' == 'v') { /* ancient C compiler */ - str1fmt[5] = "v"; -#ifndef non_ASCII - escapes['v'] = 11; -#endif - } - else - escapes['v'] = '\v'; - for(s = "\b\t\n\f\r\v", i = 0; j = *(unsigned char *)s++;) - str_fmt[j] = chr_fmt[j] = str1fmt[i++]; - /* '\v' = 11 for both EBCDIC and ASCII... */ - chr_fmt[11] = Ansi ? "\\v" : "\\13"; - } - - void -outbuf_adjust(Void) -{ - int n, n1; - char *s; - - n = n1 = strlen(outbuf); - if (*outbuf && outbuf[n-1] != '/') - n1++; - s = Alloc(n+64); - outbtail = s + n1; - strcpy(s, outbuf); - if (n != n1) - strcpy(s+n, "/"); - outbuf = s; - } - - -/* Unless SYSTEM_SORT is defined, the following gives a simple - * in-core version of dsort(). On Fortran source with huge DATA - * statements, the in-core version may exhaust the available memory, - * in which case you might either recompile this source file with - * SYSTEM_SORT defined (if that's reasonable on your system), or - * replace the dsort below with a more elaborate version that - * does a merging sort with the help of auxiliary files. - */ - -#ifdef SYSTEM_SORT - - int -#ifdef KR_headers -dsort(from, to) - char *from; - char *to; -#else -dsort(char *from, char *to) -#endif -{ - char buf[200]; - sprintf(buf, "sort <%s >%s", from, to); - return system(buf) >> 8; - } -#else - - static int -#ifdef KR_headers - compare(a,b) - char *a, *b; -#else - compare(const void *a, const void *b) -#endif -{ return strcmp(*(char **)a, *(char **)b); } - -#ifdef KR_headers -dsort(from, to) - char *from; - char *to; -#else -dsort(char *from, char *to) -#endif -{ - struct Memb { - struct Memb *next; - int n; - char buf[32000]; - }; - typedef struct Memb memb; - memb *mb, *mb1; - register char *x, *x0, *xe; - register int c, n; - FILE *f; - char **z, **z0; - int nn = 0; - - f = opf(from, textread); - mb = (memb *)Alloc(sizeof(memb)); - mb->next = 0; - x0 = x = mb->buf; - xe = x + sizeof(mb->buf); - n = 0; - for(;;) { - c = getc(f); - if (x >= xe && (c != EOF || x != x0)) { - if (!n) - return 126; - nn += n; - mb->n = n; - mb1 = (memb *)Alloc(sizeof(memb)); - mb1->next = mb; - mb = mb1; - memcpy(mb->buf, x0, n = x-x0); - x0 = mb->buf; - x = x0 + n; - xe = x0 + sizeof(mb->buf); - n = 0; - } - if (c == EOF) - break; - if (c == '\n') { - ++n; - *x++ = 0; - x0 = x; - } - else - *x++ = c; - } - clf(&f, from, 1); - f = opf(to, textwrite); - if (x > x0) { /* shouldn't happen */ - *x = 0; - ++n; - } - mb->n = n; - nn += n; - if (!nn) /* shouldn't happen */ - goto done; - z = z0 = (char **)Alloc(nn*sizeof(char *)); - for(mb1 = mb; mb1; mb1 = mb1->next) { - x = mb1->buf; - n = mb1->n; - for(;;) { - *z++ = x; - if (--n <= 0) - break; - while(*x++); - } - } - qsort((char *)z0, nn, sizeof(char *), compare); - for(n = nn, z = z0; n > 0; n--) - fprintf(f, "%s\n", *z++); - free((char *)z0); - done: - clf(&f, to, 1); - do { - mb1 = mb->next; - free((char *)mb); - } - while(mb = mb1); - return 0; - } -#endif diff --git a/usr.bin/f2c/sysdep.h b/usr.bin/f2c/sysdep.h deleted file mode 100644 index e3a68ef0cb96..000000000000 --- a/usr.bin/f2c/sysdep.h +++ /dev/null @@ -1,98 +0,0 @@ -/**************************************************************** -Copyright 1990, 1991, 1994 by AT&T, Lucent Technologies and Bellcore. - -Permission to use, copy, modify, and distribute this software -and its documentation for any purpose and without fee is hereby -granted, provided that the above copyright notice appear in all -copies and that both that the copyright notice and this -permission notice and warranty disclaimer appear in supporting -documentation, and that the names of AT&T, Bell Laboratories, -Lucent or Bellcore or any of their entities not be used in -advertising or publicity pertaining to distribution of the -software without specific, written prior permission. - -AT&T, Lucent and Bellcore disclaim all warranties with regard to -this software, including all implied warranties of -merchantability and fitness. In no event shall AT&T, Lucent or -Bellcore be liable for any special, indirect or consequential -damages or any damages whatsoever resulting from loss of use, -data or profits, whether in an action of contract, negligence or -other tortious action, arising out of or in connection with the -use or performance of this software. -****************************************************************/ - -/* This file is included at the start of defs.h; this file - * is an initial attempt to gather in one place some declarations - * that may need to be tweaked on some systems. - */ - -#ifdef __STDC__ -#undef KR_headers -#endif - -#ifndef KR_headers -#ifndef ANSI_Libraries -#define ANSI_Libraries -#endif -#ifndef ANSI_Prototypes -#define ANSI_Prototypes -#endif -#endif - -#ifdef __BORLANDC__ -#define MSDOS -#endif - -#ifdef __ZTC__ /* Zortech */ -#define MSDOS -#endif - -#ifdef MSDOS -#define ANSI_Libraries -#define ANSI_Prototypes -#define LONG_CAST (long) -#else -#define LONG_CAST -#endif - -#include <stdio.h> - -#ifdef ANSI_Libraries -#include <stddef.h> -#include <stdlib.h> -#else -char *calloc(), *malloc(), *memcpy(), *memset(), *realloc(); -typedef int size_t; -#ifndef atol - long atol(); -#endif - -#ifdef ANSI_Prototypes -extern double atof(const char *); -extern double strtod(const char*, char**); -#else -extern double atof(), strtod(); -#endif -#endif - -/* On systems like VMS where fopen might otherwise create - * multiple versions of intermediate files, you may wish to - * #define scrub(x) unlink(x) - */ -#ifndef scrub -#define scrub(x) /* do nothing */ -#endif - -/* On systems that severely limit the total size of statically - * allocated arrays, you may need to change the following to - * extern char **chr_fmt, *escapes, **str_fmt; - * and to modify sysdep.c appropriately - */ -extern char *chr_fmt[], escapes[], *str_fmt[]; - -#include <string.h> - -#include "ctype.h" - -#define Bits_per_Byte 8 -#define Table_size (1 << Bits_per_Byte) diff --git a/usr.bin/f2c/tokens b/usr.bin/f2c/tokens deleted file mode 100644 index 07b188160efb..000000000000 --- a/usr.bin/f2c/tokens +++ /dev/null @@ -1,100 +0,0 @@ -SEOS -SCOMMENT -SLABEL -SUNKNOWN -SHOLLERITH -SICON -SRCON -SDCON -SBITCON -SOCTCON -SHEXCON -STRUE -SFALSE -SNAME -SNAMEEQ -SFIELD -SSCALE -SINCLUDE -SLET -SASSIGN -SAUTOMATIC -SBACKSPACE -SBLOCK -SCALL -SCHARACTER -SCLOSE -SCOMMON -SCOMPLEX -SCONTINUE -SDATA -SDCOMPLEX -SDIMENSION -SDO -SDOUBLE -SELSE -SELSEIF -SEND -SENDFILE -SENDIF -SENTRY -SEQUIV -SEXTERNAL -SFORMAT -SFUNCTION -SGOTO -SASGOTO -SCOMPGOTO -SARITHIF -SLOGIF -SIMPLICIT -SINQUIRE -SINTEGER -SINTRINSIC -SLOGICAL -SNAMELIST -SOPEN -SPARAM -SPAUSE -SPRINT -SPROGRAM -SPUNCH -SREAD -SREAL -SRETURN -SREWIND -SSAVE -SSTATIC -SSTOP -SSUBROUTINE -STHEN -STO -SUNDEFINED -SWRITE -SLPAR -SRPAR -SEQUALS -SCOLON -SCOMMA -SCURRENCY -SPLUS -SMINUS -SSTAR -SSLASH -SPOWER -SCONCAT -SAND -SOR -SNEQV -SEQV -SNOT -SEQ -SLT -SGT -SLE -SGE -SNE -SENDDO -SWHILE -SSLASHD -SBYTE diff --git a/usr.bin/f2c/usignal.h b/usr.bin/f2c/usignal.h deleted file mode 100644 index ba4ee6ad44c8..000000000000 --- a/usr.bin/f2c/usignal.h +++ /dev/null @@ -1,7 +0,0 @@ -#include <signal.h> -#ifndef SIGHUP -#define SIGHUP 1 /* hangup */ -#endif -#ifndef SIGQUIT -#define SIGQUIT 3 /* quit */ -#endif diff --git a/usr.bin/f2c/vax.c b/usr.bin/f2c/vax.c deleted file mode 100644 index fa788054f63b..000000000000 --- a/usr.bin/f2c/vax.c +++ /dev/null @@ -1,570 +0,0 @@ -/**************************************************************** -Copyright 1990, 1992, 1993, 1994 by AT&T, Lucent Technologies and Bellcore. - -Permission to use, copy, modify, and distribute this software -and its documentation for any purpose and without fee is hereby -granted, provided that the above copyright notice appear in all -copies and that both that the copyright notice and this -permission notice and warranty disclaimer appear in supporting -documentation, and that the names of AT&T, Bell Laboratories, -Lucent or Bellcore or any of their entities not be used in -advertising or publicity pertaining to distribution of the -software without specific, written prior permission. - -AT&T, Lucent and Bellcore disclaim all warranties with regard to -this software, including all implied warranties of -merchantability and fitness. In no event shall AT&T, Lucent or -Bellcore be liable for any special, indirect or consequential -damages or any damages whatsoever resulting from loss of use, -data or profits, whether in an action of contract, negligence or -other tortious action, arising out of or in connection with the -use or performance of this software. -****************************************************************/ - -#include "defs.h" -#include "pccdefs.h" -#include "output.h" - -int regnum[] = { - 11, 10, 9, 8, 7, 6 }; - -/* Put out a constant integer */ - - void -#ifdef KR_headers -prconi(fp, n) - FILEP fp; - ftnint n; -#else -prconi(FILEP fp, ftnint n) -#endif -{ - fprintf(fp, "\t%ld\n", n); -} - - - -/* Put out a constant address */ - - void -#ifdef KR_headers -prcona(fp, a) - FILEP fp; - ftnint a; -#else -prcona(FILEP fp, ftnint a) -#endif -{ - fprintf(fp, "\tL%ld\n", a); -} - - - void -#ifdef KR_headers -prconr(fp, x, k) - FILEP fp; - Constp x; - int k; -#else -prconr(FILEP fp, Constp x, int k) -#endif -{ - char *x0, *x1; - char cdsbuf0[64], cdsbuf1[64]; - - if (k > 1) { - if (x->vstg) { - x0 = x->Const.cds[0]; - x1 = x->Const.cds[1]; - } - else { - x0 = cds(dtos(x->Const.cd[0]), cdsbuf0); - x1 = cds(dtos(x->Const.cd[1]), cdsbuf1); - } - fprintf(fp, "\t%s %s\n", x0, x1); - } - else - fprintf(fp, "\t%s\n", x->vstg ? x->Const.cds[0] - : cds(dtos(x->Const.cd[0]), cdsbuf0)); -} - - - char * -#ifdef KR_headers -memname(stg, mem) - int stg; - long mem; -#else -memname(int stg, long mem) -#endif -{ - static char s[20]; - - switch(stg) - { - case STGCOMMON: - case STGEXT: - sprintf(s, "_%s", extsymtab[mem].cextname); - break; - - case STGBSS: - case STGINIT: - sprintf(s, "v.%ld", mem); - break; - - case STGCONST: - sprintf(s, "L%ld", mem); - break; - - case STGEQUIV: - sprintf(s, "q.%ld", mem+eqvstart); - break; - - default: - badstg("memname", stg); - } - return(s); -} - -extern void addrlit Argdcl((Addrp)); - -/* make_int_expr -- takes an arbitrary expression, and replaces all - occurrences of arguments with indirection */ - - expptr -#ifdef KR_headers -make_int_expr(e) - expptr e; -#else -make_int_expr(expptr e) -#endif -{ - chainp listp; - Addrp ap; - expptr e1; - - if (e != ENULL) - switch (e -> tag) { - case TADDR: - if (e->addrblock.isarray) { - if (e1 = e->addrblock.memoffset) - e->addrblock.memoffset = make_int_expr(e1); - } - else if (e->addrblock.vstg == STGARG) - e = mkexpr(OPWHATSIN, e, ENULL); - break; - case TEXPR: - e -> exprblock.leftp = make_int_expr (e -> exprblock.leftp); - e -> exprblock.rightp = make_int_expr (e -> exprblock.rightp); - break; - case TLIST: - for(listp = e->listblock.listp; listp; listp = listp->nextp) - if ((ap = (Addrp)listp->datap) - && ap->tag == TADDR - && ap->uname_tag == UNAM_CONST) - addrlit(ap); - break; - default: - break; - } /* switch */ - - return e; -} /* make_int_expr */ - - - -/* prune_left_conv -- used in prolog() to strip type cast away from - left-hand side of parameter adjustments. This is necessary to avoid - error messages from cktype() */ - - expptr -#ifdef KR_headers -prune_left_conv(e) - expptr e; -#else -prune_left_conv(expptr e) -#endif -{ - struct Exprblock *leftp; - - if (e && e -> tag == TEXPR && e -> exprblock.leftp && - e -> exprblock.leftp -> tag == TEXPR) { - leftp = &(e -> exprblock.leftp -> exprblock); - if (leftp -> opcode == OPCONV) { - e -> exprblock.leftp = leftp -> leftp; - free ((charptr) leftp); - } - } - - return e; -} /* prune_left_conv */ - - - static int wrote_comment; - static FILE *comment_file; - - static void -write_comment(Void) -{ - if (!wrote_comment) { - wrote_comment = 1; - nice_printf (comment_file, "/* Parameter adjustments */\n"); - } - } - - static int * -count_args(Void) -{ - register int *ac; - register chainp cp; - register struct Entrypoint *ep; - register Namep q; - - ac = (int *)ckalloc(nallargs*sizeof(int)); - - for(ep = entries; ep; ep = ep->entnextp) - for(cp = ep->arglist; cp; cp = cp->nextp) - if (q = (Namep)cp->datap) - ac[q->argno]++; - return ac; - } - - static int nu, *refs, *used; - static void awalk Argdcl((expptr)); - - static void -#ifdef KR_headers -aawalk(P) - struct Primblock *P; -#else -aawalk(struct Primblock *P) -#endif -{ - chainp p; - expptr q; - - if (P->argsp) - for(p = P->argsp->listp; p; p = p->nextp) { - q = (expptr)p->datap; - if (q->tag != TCONST) - awalk(q); - } - if (P->namep->vtype == TYCHAR) { - if (q = P->fcharp) - awalk(q); - if (q = P->lcharp) - awalk(q); - } - } - - static void -#ifdef KR_headers -afwalk(P) - struct Primblock *P; -#else -afwalk(struct Primblock *P) -#endif -{ - chainp p; - expptr q; - Namep np; - - for(p = P->argsp->listp; p; p = p->nextp) { - q = (expptr)p->datap; - switch(q->tag) { - case TPRIM: - np = q->primblock.namep; - if (np->vknownarg) - if (!refs[np->argno]++) - used[nu++] = np->argno; - if (q->primblock.argsp == 0) { - if (q->primblock.namep->vclass == CLPROC - && q->primblock.namep->vprocclass - != PTHISPROC - || q->primblock.namep->vdim != NULL) - continue; - } - default: - awalk(q); - /* no break */ - case TCONST: - continue; - } - } - } - - static void -#ifdef KR_headers -awalk(e) - expptr e; -#else -awalk(expptr e) -#endif -{ - Namep np; - top: - if (!e) - return; - switch(e->tag) { - default: - badtag("awalk", e->tag); - case TCONST: - case TERROR: - case TLIST: - return; - case TADDR: - if (e->addrblock.uname_tag == UNAM_NAME) { - np = e->addrblock.user.name; - if (np->vknownarg && !refs[np->argno]++) - used[nu++] = np->argno; - } - e = e->addrblock.memoffset; - goto top; - case TPRIM: - np = e->primblock.namep; - if (np->vknownarg && !refs[np->argno]++) - used[nu++] = np->argno; - if (e->primblock.argsp && np->vclass != CLVAR) - afwalk((struct Primblock *)e); - else - aawalk((struct Primblock *)e); - return; - case TEXPR: - awalk(e->exprblock.rightp); - e = e->exprblock.leftp; - goto top; - } - } - - static chainp -#ifdef KR_headers -argsort(p0) - chainp p0; -#else -argsort(chainp p0) -#endif -{ - Namep *args, q, *stack; - int i, nargs, nout, nst; - chainp *d, *da, p, rv, *rvp; - struct Dimblock *dp; - - if (!p0) - return p0; - for(nargs = 0, p = p0; p; p = p->nextp) - nargs++; - args = (Namep *)ckalloc(i = nargs*(sizeof(Namep) + 2*sizeof(chainp) - + 2*sizeof(int))); - memset((char *)args, 0, i); - stack = args + nargs; - d = (chainp *)(stack + nargs); - refs = (int *)(d + nargs); - used = refs + nargs; - - for(p = p0; p; p = p->nextp) { - q = (Namep) p->datap; - args[q->argno] = q; - } - for(p = p0; p; p = p->nextp) { - q = (Namep) p->datap; - if (!(dp = q->vdim)) - continue; - i = dp->ndim; - while(--i >= 0) - awalk(dp->dims[i].dimexpr); - awalk(dp->basexpr); - while(nu > 0) { - refs[i = used[--nu]] = 0; - d[i] = mkchain((char *)q, d[i]); - } - } - for(i = nst = 0; i < nargs; i++) - for(p = d[i]; p; p = p->nextp) - refs[((Namep)p->datap)->argno]++; - while(--i >= 0) - if (!refs[i]) - stack[nst++] = args[i]; - if (nst == nargs) { - rv = p0; - goto done; - } - nout = 0; - rv = 0; - rvp = &rv; - while(nst > 0) { - nout++; - q = stack[--nst]; - *rvp = p = mkchain((char *)q, CHNULL); - rvp = &p->nextp; - da = d + q->argno; - for(p = *da; p; p = p->nextp) - if (!--refs[(q = (Namep)p->datap)->argno]) - stack[nst++] = q; - frchain(da); - } - if (nout < nargs) - for(i = 0; i < nargs; i++) - if (refs[i]) { - q = args[i]; - errstr("Can't adjust %.38s correctly\n\ - due to dependencies among arguments.", - q->fvarname); - *rvp = p = mkchain((char *)q, CHNULL); - rvp = &p->nextp; - frchain(d+i); - } - done: - free((char *)args); - return rv; - } - - void -#ifdef KR_headers -prolog(outfile, p) - FILE *outfile; - register chainp p; -#else -prolog(FILE *outfile, register chainp p) -#endif -{ - int addif, addif0, i, nd, size; - int *ac; - register Namep q; - register struct Dimblock *dp; - chainp p0, p1; - - if(procclass == CLBLOCK) - return; - p0 = p; - p1 = p = argsort(p); - wrote_comment = 0; - comment_file = outfile; - ac = 0; - -/* Compute the base addresses and offsets for the array parameters, and - assign these values to local variables */ - - addif = addif0 = nentry > 1; - for(; p ; p = p->nextp) - { - q = (Namep) p->datap; - if(dp = q->vdim) /* if this param is an array ... */ - { - expptr Q, expr; - - /* See whether to protect the following with an if. */ - /* This only happens when there are multiple entries. */ - - nd = dp->ndim - 1; - if (addif0) { - if (!ac) - ac = count_args(); - if (ac[q->argno] == nentry) - addif = 0; - else if (dp->basexpr - || dp->baseoffset->constblock.Const.ci) - addif = 1; - else for(addif = i = 0; i <= nd; i++) - if (dp->dims[i].dimexpr - && (i < nd || !q->vlastdim)) { - addif = 1; - break; - } - if (addif) { - write_comment(); - nice_printf(outfile, "if (%s) {\n", /*}*/ - q->cvarname); - next_tab(outfile); - } - } - for(i = 0 ; i <= nd; ++i) - -/* Store the variable length of each dimension (which is fixed upon - runtime procedure entry) into a local variable */ - - if ((Q = dp->dims[i].dimexpr) - && (i < nd || !q->vlastdim)) { - expr = (expptr)cpexpr(Q); - write_comment(); - out_and_free_statement (outfile, mkexpr (OPASSIGN, - fixtype(cpexpr(dp->dims[i].dimsize)), expr)); - } /* if dp -> dims[i].dimexpr */ - -/* size will equal the size of a single element, or -1 if the type is - variable length character type */ - - size = typesize[ q->vtype ]; - if(q->vtype == TYCHAR) - if( ISICON(q->vleng) ) - size *= q->vleng->constblock.Const.ci; - else - size = -1; - - /* Fudge the argument pointers for arrays so subscripts - * are 0-based. Not done if array bounds are being checked. - */ - if(dp->basexpr) { - -/* Compute the base offset for this procedure */ - - write_comment(); - out_and_free_statement (outfile, mkexpr (OPASSIGN, - cpexpr(fixtype(dp->baseoffset)), - cpexpr(fixtype(dp->basexpr)))); - } /* if dp -> basexpr */ - - if(! checksubs) { - if(dp->basexpr) { - expptr tp; - -/* If the base of this array has a variable adjustment ... */ - - tp = (expptr) cpexpr (dp -> baseoffset); - if(size < 0 || q -> vtype == TYCHAR) - tp = mkexpr (OPSTAR, tp, cpexpr (q -> vleng)); - - write_comment(); - tp = mkexpr (OPMINUSEQ, - mkconv (TYADDR, (expptr)p->datap), - mkconv(TYINT, fixtype - (fixtype (tp)))); -/* Avoid type clash by removing the type conversion */ - tp = prune_left_conv (tp); - out_and_free_statement (outfile, tp); - } else if(dp->baseoffset->constblock.Const.ci != 0) { - -/* if the base of this array has a nonzero constant adjustment ... */ - - expptr tp; - - write_comment(); - if(size > 0 && q -> vtype != TYCHAR) { - tp = prune_left_conv (mkexpr (OPMINUSEQ, - mkconv (TYADDR, (expptr)p->datap), - mkconv (TYINT, fixtype - (cpexpr (dp->baseoffset))))); - out_and_free_statement (outfile, tp); - } else { - tp = prune_left_conv (mkexpr (OPMINUSEQ, - mkconv (TYADDR, (expptr)p->datap), - mkconv (TYINT, fixtype - (mkexpr (OPSTAR, cpexpr (dp -> baseoffset), - cpexpr (q -> vleng)))))); - out_and_free_statement (outfile, tp); - } /* else */ - } /* if dp -> baseoffset -> const */ - } /* if !checksubs */ - - if (addif) { - nice_printf(outfile, /*{*/ "}\n"); - prev_tab(outfile); - } - } - } - if (wrote_comment) - nice_printf (outfile, "\n/* Function Body */\n"); - if (ac) - free((char *)ac); - if (p0 != p1) - frchain(&p1); -} /* prolog */ diff --git a/usr.bin/f2c/version.c b/usr.bin/f2c/version.c deleted file mode 100644 index 90392f19f997..000000000000 --- a/usr.bin/f2c/version.c +++ /dev/null @@ -1,2 +0,0 @@ -char F2C_version[] = "19980913"; -char xxxvers[] = "\n@(#) FORTRAN 77 to C Translator, VERSION 19980913\n"; |