├── .gitignore ├── README ├── changes ├── debian ├── .gitignore ├── README.source ├── changelog ├── clean ├── control ├── copyright ├── f2c.docs ├── f2c.install ├── f2c.manpages ├── patches │ ├── 0001-make-tweaks.patch │ ├── 0002-prototype-rmdir.patch │ ├── 0003-struct-init-braces.patch │ ├── 0004-fc-script-path-and-tmpfile.patch │ ├── 0005-sysdep-tmpfiles.patch │ ├── 0006-man-dash-hyphen-slash.patch │ ├── 0007-fc-man-page.patch │ ├── 0008-typos.patch │ ├── 0009-redirect-URL.patch │ └── series ├── rules ├── source │ └── format └── watch ├── f2c.1 ├── f2c.1t ├── f2c.h ├── f2c.pdf ├── f2c.ps ├── fc ├── getopt.c └── src ├── Notice ├── README ├── cds.c ├── data.c ├── defines.h ├── defs.h ├── equiv.c ├── error.c ├── exec.c ├── expr.c ├── f2c.1 ├── f2c.1t ├── f2c.h ├── format.c ├── format.h ├── formatdata.c ├── ftypes.h ├── gram.c ├── gram.dcl ├── gram.exec ├── gram.expr ├── gram.head ├── gram.io ├── init.c ├── intr.c ├── io.c ├── iob.h ├── lex.c ├── machdefs.h ├── main.c ├── makefile.u ├── makefile.vc ├── malloc.c ├── mem.c ├── memset.c ├── misc.c ├── mkfile.plan9 ├── names.c ├── names.h ├── niceprintf.c ├── niceprintf.h ├── output.c ├── output.h ├── p1defs.h ├── p1output.c ├── parse.h ├── parse_args.c ├── pccdefs.h ├── pread.c ├── proc.c ├── put.c ├── putpcc.c ├── sysdep.c ├── sysdep.h ├── sysdeptest.c ├── tokens ├── usignal.h ├── vax.c ├── version.c ├── xsum.c └── xsum0.out /.gitignore: -------------------------------------------------------------------------------- 1 | *.o 2 | /src/f2c 3 | /src/sysdep.hd 4 | /src/tokdefs.h 5 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | To compile f2c on Linux or Unix systems, copy makefile.u to makefile, 2 | edit makefile if necessary (see the comments in it and below) and 3 | type "make" (or maybe "nmake", depending on your system). 4 | 5 | To compile f2c.exe on MS Windows systems with Microsoft Visual C++, 6 | 7 | copy makefile.vc makefile 8 | nmake 9 | 10 | With other PC compilers, you may need to compile xsum.c with -DMSDOS 11 | (i.e., with MSDOS #defined). 12 | 13 | If your compiler does not understand ANSI/ISO C syntax (i.e., if 14 | you have a K&R C compiler), compile with -DKR_headers . 15 | 16 | On non-Unix systems where files have separate binary and text modes, 17 | you may need to "make xsumr.out" rather than "make xsum.out". 18 | 19 | If (in accordance with what follows) you need to any of the source 20 | files (excluding the makefile), first issue a "make xsum.out" (or, if 21 | appropriate, "make xsumr.out") to check the validity of the f2c source, 22 | then make your changes, then type "make f2c". 23 | 24 | The file usignal.h is for the benefit of strictly ANSI include files 25 | on a UNIX system -- the ANSI signal.h does not define SIGHUP or SIGQUIT. 26 | You may need to modify usignal.h if you are not running f2c on a UNIX 27 | system. 28 | 29 | Should you get the message "xsum0.out xsum1.out differ", see what lines 30 | are different (`diff xsum0.out xsum1.out`) and ask netlib 31 | (e.g., netlib@netlib.org) to send you the files in question, 32 | plus the current xsum0.out (which may have changed) "from f2c/src". 33 | For example, if exec.c and expr.c have incorrect check sums, you would 34 | send netlib the message 35 | send exec.c expr.c xsum0.out from f2c/src 36 | You can also ftp these files from netlib.bell-labs.com; for more 37 | details, ask netlib@netlib.org to "send readme from f2c". 38 | 39 | On some systems, the malloc and free in malloc.c let f2c run faster 40 | than do the standard malloc and free. Other systems may not tolerate 41 | redefinition of malloc and free (though changes of 8 Nov. 1994 may 42 | render this less of a problem than hitherto). If your system permits 43 | use of a user-supplied malloc, you may wish to change the MALLOC = 44 | line in the makefile to "MALLOC = malloc.o", or to type 45 | make MALLOC=malloc.o 46 | instead of 47 | make 48 | Still other systems have a -lmalloc that provides performance 49 | competitive with that from malloc.c; you may wish to compare the two 50 | on your system. If your system does not permit user-supplied malloc 51 | routines, then f2c may fault with "MALLOC=malloc.o", or may display 52 | other untoward behavior. 53 | 54 | On some BSD systems, you may need to create a file named "string.h" 55 | whose single line is 56 | #include 57 | you may need to add " -Dstrchr=index" to the "CFLAGS =" assignment 58 | in the makefile, and you may need to add " memset.o" to the "OBJECTS =" 59 | assignment in the makefile -- see the comments in memset.c . 60 | 61 | For non-UNIX systems, you may need to change some things in sysdep.c, 62 | such as the choice of intermediate file names. 63 | 64 | On some systems, you may need to modify parts of sysdep.h (which is 65 | included by defs.h). In particular, for Sun 4.1 systems and perhaps 66 | some others, you need to comment out the typedef of size_t. For some 67 | systems (e.g., IRIX 4.0.1 and AIX) it is better to add 68 | #define ANSI_Libraries 69 | to the beginning of sysdep.h (or to supply -DANSI_Libraries in the 70 | makefile). 71 | 72 | Alas, some systems #define __STDC__ but do not provide a true standard 73 | (ANSI or ISO) C environment, e.g., do not provide stdlib.h . If yours 74 | is such a system, then (a) you should complain loudly to your vendor 75 | about __STDC__ being erroneously defined, and (b) you should insert 76 | #undef __STDC__ 77 | at the beginning of sysdep.h . You may need to make other adjustments. 78 | 79 | For some non-ANSI versions of stdio, you must change the values given 80 | to binread and binwrite in sysdep.c from "rb" and "wb" to "r" and "w". 81 | You may need to make this change if you run f2c and get an error 82 | message of the form 83 | Compiler error ... cannot open intermediate file ... 84 | 85 | In the days of yore, two libraries, libF77 and libI77, were used with 86 | f77 (the Fortran compiler on which f2c is based). Separate source for 87 | these libraries is still available from netlib, but it is more 88 | convenient to combine them into a single library, libf2c. Source for 89 | this combined library is also available from netlib in f2c/libf2c.zip, 90 | e.g., 91 | http://netlib.bell-labs.com/netlib/f2c/libf2c.zip 92 | or 93 | http://www.netlib.org/f2c/libf2c.zip 94 | 95 | (and similarly for other netlib mirrors). After unzipping libf2c.zip, 96 | copy the relevant makefile.* to makefile, edit makefile if necessary 97 | (see the comments in it and in libf2c/README) and invoke "make" or 98 | "nmake". The resulting library is called *f2c.lib on MS Windows 99 | systems and libf2c.a or libf2c.so on Linux and Unix systems; 100 | makefile.u just shows how to make libf2c.a. Details on creating the 101 | shared-library variant, libf2c.so, are system-dependent; some that 102 | have worked under Linux appear below. For some other systems, you can 103 | glean the details from the system-dependent makefile variants in 104 | directory http://www.netlib.org/ampl/solvers/funclink or 105 | http://netlib.bell-labs.com/netlib/ampl/solvers/funclink, etc. 106 | 107 | In general, under Linux it is necessary to compile libf2c (or libI77) 108 | with -DNON_UNIX_STDIO . Under at least one variant of Linux, you can 109 | make and install a shared-library version of libf2c by compiling 110 | libI77 with -DNON_UNIX_STDIO, creating libf2c.a as above, and then 111 | executing 112 | 113 | mkdir t 114 | ln lib?77/*.o t 115 | cd t; cc -shared -o ../libf2c.so -Wl,-soname,libf2c.so.1 *.o 116 | cd .. 117 | rm -r t 118 | rm /usr/lib/libf2c* 119 | mv libf2c.a libf2c.so /usr/lib 120 | cd /usr/lib 121 | ln libf2c.so libf2c.so.1 122 | ln libf2c.so libf2c.so.1.0.0 123 | 124 | On some other systems, /usr/local/lib is the appropriate installation 125 | directory. 126 | 127 | 128 | Some older C compilers object to 129 | typedef void (*foo)(); 130 | or to 131 | typedef void zap; 132 | zap (*foo)(); 133 | If yours is such a compiler, change the definition of VOID in 134 | f2c.h from void to int. 135 | 136 | For convenience with systems that use control-Z to denote end-of-file, 137 | f2c treats control-Z characters (ASCII 26, '\x1a') that appear at the 138 | beginning of a line as an end-of-file indicator. You can disable this 139 | test by compiling lex.c with NO_EOF_CHAR_CHECK #defined, or can 140 | change control-Z to some other character by #defining EOF_CHAR to 141 | be the desired value. 142 | 143 | 144 | If your machine has IEEE, VAX, or IBM-mainframe arithmetic, but your 145 | printf is inaccurate (e.g., with Symantec C++ version 6.0, 146 | printf("%.17g",12.) prints 12.000000000000001), you can make f2c print 147 | correctly rounded numbers by compiling with -DUSE_DTOA and adding 148 | dtoa.o g_fmt.o to the makefile's OBJECTS = line, so it becomes 149 | 150 | OBJECTS = $(OBJECTSd) malloc.o dtoa.o g_fmt.o 151 | 152 | Also add the rule 153 | 154 | dtoa.o: dtoa.c 155 | $(CC) -c $(CFLAGS) -DMALLOC=ckalloc -DIEEE... dtoa.c 156 | 157 | (without the initial tab) to the makefile, where IEEE... is one of 158 | IEEE_MC68k, IEEE_8087, VAX, or IBM, depending on your machine's 159 | arithmetic. See the comments near the start of dtoa.c. 160 | 161 | The relevant source files, dtoa.c and g_fmt.c, are available 162 | separately from netlib's fp directory. For example, you could 163 | send the E-mail message 164 | 165 | send dtoa.c g_fmt.c from fp 166 | 167 | to netlib@netlib.netlib.org (or use anonymous ftp from 168 | ftp.netlib.org and look in directory /netlib/fp). 169 | 170 | The makefile has a rule for creating tokdefs.h. If you cannot use the 171 | makefile, an alternative is to extract tokdefs.h from the beginning of 172 | gram.c: it's the first 100 lines. 173 | 174 | File mem.c has #ifdef CRAY lines that are appropriate for machines 175 | with the conventional CRAY architecture, but not for "Cray" machines 176 | based on DEC Alpha chips, such as the T3E; on such machines, you may 177 | need to make a suitable adjustment, e.g., add #undef CRAY to sysdep.h. 178 | 179 | Fortran 77 assumes variables of type INTEGER and REAL occupy the same 180 | storage and that a DOUBLE PRECISION or COMPLEX variable occupies twice 181 | this storage. The types in f2c.h need to reflect these assumptions, 182 | at least when EQUIVALENCE is involved. As of 2021, most modern C and 183 | C++ compilers make "int" a four-byte type, i.e., (in C notation) 184 | sizeof(int) == 4. Some make sizeof(long) == 4, others make 185 | sizeof(long) == 8. (With the compiler originally used for f2c, 186 | sizeof(int) == 2 and sizeof(long) == 4.) For compilers having 187 | sizeof(int) == 4 and sizeof(long) == 8, in f2c.h it suffices to change 188 | "long int" to "int" and is safe to change "#ifdef INTEGER_STAR_8" to 189 | "#if 1". 190 | 191 | 192 | Please send bug reports to dmg at acm.org (with " at " changed to "@"). 193 | The old index file (now called "readme" due to unfortunate changes in 194 | netlib conventions: "send readme from f2c") will report recent 195 | changes in the recent-change log at its end; all changes will be shown 196 | in the "changes" file ("send changes from f2c"). To keep current 197 | source, you will need to request xsum0.out and version.c, in addition 198 | to the changed source files. 199 | -------------------------------------------------------------------------------- /debian/.gitignore: -------------------------------------------------------------------------------- 1 | /*.debhelper.log 2 | /*.substvars 3 | /.debhelper/ 4 | /debhelper-build-stamp 5 | /f2c/ 6 | /files 7 | -------------------------------------------------------------------------------- /debian/README.source: -------------------------------------------------------------------------------- 1 | f2c 2 | --- 3 | 4 | The upstream sources are not in a nice tarball, and require some 5 | manual processing. 6 | 7 | To check for the latest upstream version: 8 | 9 | $ eval $(tail -4 debian/watch | sed 's/^#//' | sed 's/\\$//') 10 | 11 | To get a new version, downloaded manually: 12 | 13 | $ wget2 --mirror --no-parent https://netlib.org/f2c 14 | 15 | Then checkout the upstream branch, delete everything, move the new 16 | stuff into place, manually delete any extraneous files, e.g.: 17 | 18 | msdos/ 19 | mswin/ 20 | libf2c.zip 21 | src.tgz 22 | src/index.html 23 | src/notice # identical to src/Notice 24 | src/readme # identical to src/README 25 | 26 | commit, and tag. To generate *.orig.tar.gz, see git-deborig(1). 27 | 28 | -- Barak A. Pearlmutter , Wed, 8 Jul 2020 22:32:23 +0100 29 | -------------------------------------------------------------------------------- /debian/clean: -------------------------------------------------------------------------------- 1 | src/xsum src/xsum1.out src/xsum.out 2 | build build_f2c build_f2c_i2 3 | -------------------------------------------------------------------------------- /debian/control: -------------------------------------------------------------------------------- 1 | Source: f2c 2 | Maintainer: Barak A. Pearlmutter 3 | Section: devel 4 | Priority: optional 5 | Build-Depends: debhelper-compat (= 13) 6 | Standards-Version: 4.7.0 7 | Rules-Requires-Root: no 8 | Vcs-Browser: https://salsa.debian.org/debian/f2c 9 | Vcs-Git: https://salsa.debian.org/debian/f2c.git 10 | Homepage: https://netlib.org/f2c/ 11 | 12 | Package: f2c 13 | Architecture: any 14 | Depends: ${shlibs:Depends}, 15 | ${misc:Depends}, 16 | libf2c2-dev 17 | Recommends: gcc 18 | Suggests: fort77 19 | Description: FORTRAN 77 to C/C++ translator 20 | Translates FORTRAN 77 (with some extensions) into C, so that it can 21 | then be compiled and run on a system with no Fortran compiler. The C 22 | files must then be linked against the appropriate libraries. 23 | . 24 | This is an actively maintained FORTRAN to C translator and with the 25 | fort77 frontend provides an ideal way to compile FORTRAN routines 26 | as black boxes (for example for invocation from C). Source level 27 | debugging facilities are not available, and error messages are not as 28 | well developed as in g77. 29 | -------------------------------------------------------------------------------- /debian/copyright: -------------------------------------------------------------------------------- 1 | Format: https://www.debian.org/doc/packaging-manuals/copyright-format/1.0/ 2 | Upstream-Name: f2c 3 | Source: ftp://netlib.bell-labs.com/netlib/f2c 4 | 5 | Files: * 6 | Copyright: 1990-1995 AT&T Bell Laboratories and Bellcore 7 | License: ATT 8 | Permission to use, copy, modify, and distribute this software 9 | and its documentation for any purpose and without fee is hereby 10 | granted, provided that the above copyright notice appear in all 11 | copies and that both that the copyright notice and this 12 | permission notice and warranty disclaimer appear in supporting 13 | documentation, and that the names of AT&T Bell Laboratories or 14 | Bellcore or any of their entities not be used in advertising or 15 | publicity pertaining to distribution of the software without 16 | specific, written prior permission. 17 | . 18 | AT&T and Bellcore disclaim all warranties with regard to this 19 | software, including all implied warranties of merchantability 20 | and fitness. In no event shall AT&T or Bellcore be liable for 21 | any special, indirect or consequential damages or any damages 22 | whatsoever resulting from loss of use, data or profits, whether 23 | in an action of contract, negligence or other tortious action, 24 | arising out of or in connection with the use or performance of 25 | this software. 26 | 27 | Files: debian/* 28 | Copyright: 29 | 2008-2009 Alan Bain 30 | 2010-2016 Barak A. Pearlmutter 31 | License: Public-Domain 32 | This material is hereby released to the public domain. 33 | -------------------------------------------------------------------------------- /debian/f2c.docs: -------------------------------------------------------------------------------- 1 | f2c.ps 2 | README 3 | -------------------------------------------------------------------------------- /debian/f2c.install: -------------------------------------------------------------------------------- 1 | src/f2c /usr/bin 2 | fc /usr/bin 3 | -------------------------------------------------------------------------------- /debian/f2c.manpages: -------------------------------------------------------------------------------- 1 | fc.1 2 | f2c.1t 3 | -------------------------------------------------------------------------------- /debian/patches/0001-make-tweaks.patch: -------------------------------------------------------------------------------- 1 | From: "Barak A. Pearlmutter" 2 | Date: Wed, 18 Jul 2012 11:14:35 +0200 3 | Subject: make tweaks 4 | 5 | Tweak src/makefile.u: use default rules for .o object files and for 6 | f2c executable. 7 | Create stub f2c.c to allow f2c executable to depend on f2c.o which 8 | allows a default rule for f2c executable. 9 | Supply stub top-level Makefile. 10 | Set all target to not include xsum.out 11 | Make target distclean be very clean. 12 | --- 13 | Makefile | 4 ++++ 14 | src/f2c.c | 1 + 15 | src/makefile.u | 11 +++++++---- 16 | 3 files changed, 12 insertions(+), 4 deletions(-) 17 | create mode 100644 Makefile 18 | create mode 100644 src/f2c.c 19 | 20 | diff --git a/Makefile b/Makefile 21 | new file mode 100644 22 | index 0000000..dd4f903 23 | --- /dev/null 24 | +++ b/Makefile 25 | @@ -0,0 +1,4 @@ 26 | +all: 27 | + 28 | +%: 29 | + $(MAKE) -C src -f makefile.u $@ 30 | diff --git a/src/f2c.c b/src/f2c.c 31 | new file mode 100644 32 | index 0000000..17ca069 33 | --- /dev/null 34 | +++ b/src/f2c.c 35 | @@ -0,0 +1 @@ 36 | +/* stub to make default make rule for f2c happy */ 37 | diff --git a/src/makefile.u b/src/makefile.u 38 | index e9f9c5e..575ebc7 100644 39 | --- a/src/makefile.u 40 | +++ b/src/makefile.u 41 | @@ -7,8 +7,8 @@ SHELL = /bin/sh 42 | YACC = yacc 43 | YFLAGS = 44 | 45 | -.c.o: 46 | - $(CC) -c $(CFLAGS) $*.c 47 | +#.c.o: 48 | +# $(CC) -c $(CFLAGS) $*.c 49 | 50 | OBJECTSd = main.o init.o gram.o lex.o proc.o equiv.o data.o format.o \ 51 | expr.o exec.o intr.o io.o misc.o error.o mem.o names.o \ 52 | @@ -24,10 +24,11 @@ MALLOC = 53 | 54 | OBJECTS = $(OBJECTSd) $(MALLOC) 55 | 56 | -all: xsum.out f2c 57 | +all: f2c 58 | 59 | +f2c: f2c.o 60 | f2c: $(OBJECTS) 61 | - $(CC) $(LDFLAGS) $(OBJECTS) -o f2c 62 | +# $(CC) $(LDFLAGS) $^ $(LOADLIBES) $(LDLIBS) -o $@ 63 | 64 | # The following used to be a rule for gram.c rather than gram1.c, but 65 | # there are too many broken variants of yacc around, so now we 66 | @@ -91,6 +92,8 @@ clean: 67 | veryclean: clean 68 | rm -f xsum 69 | 70 | +distclean: veryclean 71 | + 72 | b = Notice README cds.c data.c defines.h defs.h equiv.c error.c \ 73 | exec.c expr.c f2c.1 f2c.1t f2c.h format.c format.h formatdata.c \ 74 | ftypes.h gram.c gram.dcl gram.exec gram.expr gram.head gram.io \ 75 | -------------------------------------------------------------------------------- /debian/patches/0002-prototype-rmdir.patch: -------------------------------------------------------------------------------- 1 | From: "Barak A. Pearlmutter" 2 | Date: Tue, 14 Feb 2012 14:52:48 +0000 3 | Subject: prototype rmdir 4 | 5 | --- 6 | src/sysdep.c | 2 ++ 7 | 1 file changed, 2 insertions(+) 8 | 9 | diff --git a/src/sysdep.c b/src/sysdep.c 10 | index 45ef4be..bca6ff2 100644 11 | --- a/src/sysdep.c 12 | +++ b/src/sysdep.c 13 | @@ -25,6 +25,8 @@ use or performance of this software. 14 | #endif 15 | #include "defs.h" 16 | #include "usignal.h" 17 | +#include 18 | +#include 19 | 20 | char binread[] = "rb", textread[] = "r"; 21 | char binwrite[] = "wb", textwrite[] = "w"; 22 | -------------------------------------------------------------------------------- /debian/patches/0004-fc-script-path-and-tmpfile.patch: -------------------------------------------------------------------------------- 1 | From: "Barak A. Pearlmutter" 2 | Date: Wed, 18 Jul 2012 11:14:01 +0200 3 | Subject: fc script path and tmpfile 4 | 5 | --- 6 | fc | 18 ++++++++---------- 7 | 1 file changed, 8 insertions(+), 10 deletions(-) 8 | 9 | diff --git a/fc b/fc 10 | index 1f71e59..46d13c7 100644 11 | --- a/fc 12 | +++ b/fc 13 | @@ -11,7 +11,7 @@ 14 | # may be useful as way to pass system-specific stuff to the C compiler. 15 | # The script below simply appends to the initial CFLAGS value. 16 | 17 | -PATH=/usr/local/bin:/bin:/usr/bin 18 | +PATH=/bin:/usr/bin 19 | 20 | # f77-style shell script to compile and load fortran, C, and assembly codes 21 | 22 | @@ -80,12 +80,13 @@ PATH=/usr/local/bin:/bin:/usr/bin 23 | 24 | # -U def passed to C compiler (for .c files) 25 | # or to cpp (for .F files) to remove def 26 | - 27 | # -v show current f2c version 28 | # --version same as -v 29 | 30 | -s=/tmp/stderr_$$ 31 | -t=/tmp/f77_$$.o 32 | +s=`tempfile --prefix=stderr` || { echo "$0: Cannot create temporary file" ; exit 1; } 33 | +t=`tempfile --suffix=.o --prefix=f77` || { echo "$0: Cannot create temporary file" ; exit 1; } 34 | +trap "rm -f $s $t; exit \$rc" 0 35 | + 36 | ### On some systems (e.g., IRIX), -common prevents complaints 37 | ### about multiple definitions of COMMON blocks. 38 | #CC=${CC_f2c:-'cc -common'} 39 | @@ -94,7 +95,7 @@ EFL=${EFL:-efl} 40 | EFLFLAGS=${EFLFLAGS:-'system=portable deltastno=10'} 41 | RATFOR=${RATFOR:-ratfor} 42 | RFLAGS=${RFLAGS:-'-6&'} 43 | -F2C=${F2C:-/usr/local/bin/f2c} 44 | +F2C=${F2C:-/usr/bin/f2c} 45 | show_fc_help=0 46 | case $1 in 47 | --help) show_fc_help=1;; 48 | @@ -116,14 +117,11 @@ case $show_fc_help in 49 | F2CFLAGS=${F2CFLAGS:='-ARw8 -Nn802 -Nq300 -Nx400'} 50 | CPP=${CPP:-/lib/cpp} 51 | rc=0 52 | -trap "rm -f $s $t; exit \$rc" 0 53 | OUTF=a.out 54 | OUTO= 55 | cOPT=1 56 | set -- `getopt acCD:gI:L:m:N:O:U:o:r:sSt:uw6 "$@"` 57 | case $? in 0);; *) rc=$?; exit;; esac 58 | -CPPFLAGS=${CPPFLAGS:-'-I/usr/local/include'} 59 | -CFLAGSF2C=${CFLAGSF2C:-'-I/usr/local/include'} 60 | OFILES= 61 | trapuv= 62 | strip= 63 | @@ -358,8 +356,8 @@ done 64 | 65 | case $cOPT in 2) 66 | # case $trapuv in 1) OFILES="$OFILES -lfpe";; esac 67 | -# $CC -Wl,-dont_warn_unused -o $OUTF -u MAIN__ -L/usr/local/lib $OFILES $LIBS 68 | - $CC -o $OUTF -u MAIN__ -L/usr/local/lib $OFILES $LIBS 69 | +# $CC -Wl,-dont_warn_unused -o $OUTF -u MAIN__ $OFILES $LIBS 70 | + $CC -o $OUTF -u MAIN__ $OFILES $LIBS 71 | case $strip in 1) strip $OUTF;; esac 72 | ;; esac 73 | rc=$? 74 | -------------------------------------------------------------------------------- /debian/patches/0005-sysdep-tmpfiles.patch: -------------------------------------------------------------------------------- 1 | From: "Barak A. Pearlmutter" 2 | Date: Wed, 18 Jul 2012 11:15:58 +0200 3 | Subject: sysdep tmpfiles 4 | 5 | --- 6 | src/sysdep.c | 5 +++++ 7 | 1 file changed, 5 insertions(+) 8 | 9 | diff --git a/src/sysdep.c b/src/sysdep.c 10 | index bca6ff2..01190c3 100644 11 | --- a/src/sysdep.c 12 | +++ b/src/sysdep.c 13 | @@ -98,7 +98,9 @@ Un_link_all(int cdelete) 14 | if (!debugflag) { 15 | unlink(c_functions); 16 | unlink(initfname); 17 | + unlink(initbname); 18 | unlink(p1_file); 19 | + unlink(p1_bakfile); 20 | unlink(sortfname); 21 | unlink(blkdfname); 22 | if (cdelete && coutput) 23 | @@ -237,6 +239,9 @@ set_tmp_names(Void) 24 | #endif /*NO_TEMPDIR*/ 25 | } 26 | alloc_names(); 27 | + /* What follows is safe if tmpdir is really 28 | + a private diectory created by us -- otherwise 29 | + the file could be a sym link somewhere else....*/ 30 | sprintf(c_functions, "%s/f2c%ld_func", tmpdir, pid); 31 | sprintf(initfname, "%s/f2c%ld_rd", tmpdir, pid); 32 | sprintf(blkdfname, "%s/f2c%ld_blkd", tmpdir, pid); 33 | -------------------------------------------------------------------------------- /debian/patches/0007-fc-man-page.patch: -------------------------------------------------------------------------------- 1 | From: "Barak A. Pearlmutter" 2 | Date: Wed, 18 Jul 2012 11:24:17 +0200 3 | Subject: fc man page 4 | 5 | --- 6 | fc.1 | 134 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 7 | 1 file changed, 134 insertions(+) 8 | create mode 100644 fc.1 9 | 10 | diff --git a/fc.1 b/fc.1 11 | new file mode 100644 12 | index 0000000..52a0971 13 | --- /dev/null 14 | +++ b/fc.1 15 | @@ -0,0 +1,134 @@ 16 | +'\" t 17 | +.\" Redistribution and use in source and binary forms of parts of or the 18 | +.\" whole original or derived work are permitted provided that the 19 | +.\" original work is properly attributed to the author. The name of the 20 | +.\" author may not be used to endorse or promote products derived from 21 | +.\" this software without specific prior written permission. This work 22 | +.\" is provided "as is" and without any express or implied warranties. 23 | +.\" 24 | +.\" Original version of this manpage: 25 | +.\" Peter Maydell (pmaydell@chiark.greenend.org.uk), 03/1998 26 | +.\" Updated by Alan Bain (afrb2@cam.ac.uk), 15/05/1999 27 | +.\" added reference to -o in command specification 28 | +.\" and to -U in options 29 | +.\" Updated by Alan Bain (afrb2@debian.org), 28/4/2008 30 | +.\" mention -v and --version options, change hyphens to minus signs 31 | +.\" 32 | +.TH FC 1 "May 1999" 33 | +.SH NAME 34 | +fc \- frontend script to the f2c fortran compiler 35 | +.SH SYNOPSIS 36 | +.B /usr/bin/fc 37 | +.RB [ \-o 38 | +.IR objfile ] 39 | +.RB [ \-c ] 40 | +.RB [ \-S ] 41 | +.RB [ \-C ] 42 | +.RB [ \-u ] 43 | +.RB [ \-w ] 44 | +.RB [ \-w66 ] 45 | +.RB [ \-D 46 | +.IR switch ] 47 | +.RB [ \-I 48 | +.IR includepath ] 49 | +.RB [ \-Ntnnn ] 50 | +.RB [ \-P ] 51 | +.I files 52 | +.RB [ \-l 53 | +.IR library ] 54 | +.SH DESCRIPTION 55 | +.LP 56 | +.B fc 57 | +is a script intended to be used as a front end to the 58 | +.B f2c 59 | +FORTRAN-to-C translator. It is supposed to make the whole 60 | +.B f2c 61 | +and C compiler setup look like a real Fortran compiler. 62 | + 63 | +File arguments with a 64 | +.B .f 65 | +suffix are compiled as Fortran source. 66 | +Files with a 67 | +.B .F 68 | +suffix are passed through the C preprocessor 69 | +.B cpp(1) 70 | +first. Files with 71 | +.B .c 72 | +(C source) or 73 | +.B .s 74 | +(assembly source) 75 | +suffixes are passed to the C compiler directly. 76 | +Files with a 77 | +.B .e 78 | +suffix are treated as efl source files, and 79 | +files with a 80 | +.B .r 81 | +suffix are treated as RATFOR source files. 82 | + 83 | +.SH OPTIONS 84 | +.TP 8 85 | +.I \-o objfile 86 | +Produce an output executable named 87 | +.I objfile 88 | +rather than using the default name a.out. 89 | +.TP 8 90 | +.I \-c 91 | +Do not call the linker; instead, leave relocatable object files 92 | +as *.o. 93 | +.TP 8 94 | +.I \-S 95 | +Produce assembly output as file.s 96 | +.TP 8 97 | +.I \-C 98 | +Compile in extra code to check that array subscripts are in bounds. 99 | +.TP 8 100 | +.I \-l library 101 | +Libraries specified with this option are passed to the linker. 102 | +.TP 8 103 | +.I \-U def 104 | +Definitions specified with this option are passed to C compiler (for .c files) 105 | +or to cpp (for .F files) to remove definition. 106 | +.TP 8 107 | +.I \-u 108 | +Complain about undeclared variables. 109 | +.TP 8 110 | +.I \-v, \-\-version 111 | +Print version of f2c in use 112 | +.TP 8 113 | +.I \-w 114 | +Omit all warning messages. 115 | +.TP 8 116 | +.I \-w66 117 | +Omit Fortran 66 (Fortran IV) compatibility warning messages. 118 | +.TP 8 119 | +.I \-D switch 120 | +The given switch is passed to the C compiler (for .c files), to cpp 121 | +(for .F files) and to f2c. 122 | +.TP 8 123 | +.I \-I includepath 124 | +Passed to the C compiler (for .c files), to cpp (for .F files) 125 | +and to f2c. 126 | +.TP 8 127 | +.I \-Ntnnn 128 | +Allow nnn entries in table t. 129 | +.TP 8 130 | +.I \-P 131 | +Emit .P files. 132 | +.SH BUGS 133 | +.B fc 134 | +isn't really very good -- try fort77 (1), which does a better job. 135 | +.br 136 | +This manual page isn't really very good either... 137 | +.SH AUTHOR 138 | +S. Feldman, D. Gay, M. Maimone, N, Schryer are all mentioned 139 | +in the paper on the conversion of Fortran to C. 140 | +.br 141 | +Peter Maydell (pmaydell@chiark.greenend.org.uk) wrote this manual page, 142 | +and Alan Bain (alanb@chiark.greenend.org.uk) made some minor 143 | +modifications. 144 | +.SH SEE ALSO 145 | +.BR f2c (1), 146 | +.BR fort77 (1), 147 | +.BR cc (1), 148 | +.BR cpp (1), 149 | +.BR ratfor (1) 150 | -------------------------------------------------------------------------------- /debian/patches/0008-typos.patch: -------------------------------------------------------------------------------- 1 | From: "Barak A. Pearlmutter" 2 | Date: Mon, 15 Aug 2016 15:09:28 +0200 3 | Subject: typos 4 | 5 | --- 6 | src/pread.c | 2 +- 7 | 1 file changed, 1 insertion(+), 1 deletion(-) 8 | 9 | diff --git a/src/pread.c b/src/pread.c 10 | index cd58513..57f5c7d 100644 11 | --- a/src/pread.c 12 | +++ b/src/pread.c 13 | @@ -809,7 +809,7 @@ argverify(int ftype, Extsym *p) 14 | Pbadmsg("differing calling sequences",p); 15 | i = t - tfirst + 1; 16 | fprintf(stderr, 17 | - "arg %d: here %s, prevously %s\n", 18 | + "arg %d: here %s, previously %s\n", 19 | i, Argtype(k,buf1), Argtype(j,buf2)); 20 | return; 21 | } 22 | -------------------------------------------------------------------------------- /debian/patches/0009-redirect-URL.patch: -------------------------------------------------------------------------------- 1 | From: "Barak A. Pearlmutter" 2 | Date: Mon, 8 May 2023 13:19:07 +0100 3 | Subject: redirect URL 4 | 5 | --- 6 | README | 4 ++-- 7 | src/README | 4 ++-- 8 | src/main.c | 4 ++-- 9 | src/sysdep.c | 2 +- 10 | 4 files changed, 7 insertions(+), 7 deletions(-) 11 | 12 | diff --git a/README b/README 13 | index 911e85c..76b4409 100644 14 | --- a/README 15 | +++ b/README 16 | @@ -90,7 +90,7 @@ this combined library is also available from netlib in f2c/libf2c.zip, 17 | e.g., 18 | http://netlib.bell-labs.com/netlib/f2c/libf2c.zip 19 | or 20 | - http://www.netlib.org/f2c/libf2c.zip 21 | + http://netlib.org/f2c/libf2c.zip 22 | 23 | (and similarly for other netlib mirrors). After unzipping libf2c.zip, 24 | copy the relevant makefile.* to makefile, edit makefile if necessary 25 | @@ -101,7 +101,7 @@ makefile.u just shows how to make libf2c.a. Details on creating the 26 | shared-library variant, libf2c.so, are system-dependent; some that 27 | have worked under Linux appear below. For some other systems, you can 28 | glean the details from the system-dependent makefile variants in 29 | -directory http://www.netlib.org/ampl/solvers/funclink or 30 | +directory http://netlib.org/ampl/solvers/funclink or 31 | http://netlib.bell-labs.com/netlib/ampl/solvers/funclink, etc. 32 | 33 | In general, under Linux it is necessary to compile libf2c (or libI77) 34 | diff --git a/src/README b/src/README 35 | index 911e85c..76b4409 100644 36 | --- a/src/README 37 | +++ b/src/README 38 | @@ -90,7 +90,7 @@ this combined library is also available from netlib in f2c/libf2c.zip, 39 | e.g., 40 | http://netlib.bell-labs.com/netlib/f2c/libf2c.zip 41 | or 42 | - http://www.netlib.org/f2c/libf2c.zip 43 | + http://netlib.org/f2c/libf2c.zip 44 | 45 | (and similarly for other netlib mirrors). After unzipping libf2c.zip, 46 | copy the relevant makefile.* to makefile, edit makefile if necessary 47 | @@ -101,7 +101,7 @@ makefile.u just shows how to make libf2c.a. Details on creating the 48 | shared-library variant, libf2c.so, are system-dependent; some that 49 | have worked under Linux appear below. For some other systems, you can 50 | glean the details from the system-dependent makefile variants in 51 | -directory http://www.netlib.org/ampl/solvers/funclink or 52 | +directory http://netlib.org/ampl/solvers/funclink or 53 | http://netlib.bell-labs.com/netlib/ampl/solvers/funclink, etc. 54 | 55 | In general, under Linux it is necessary to compile libf2c (or libI77) 56 | diff --git a/src/main.c b/src/main.c 57 | index 480863d..172b8db 100644 58 | --- a/src/main.c 59 | +++ b/src/main.c 60 | @@ -552,8 +552,8 @@ show_help(char *progname) 61 | "For usage details, see the man page, f2c.1.\n", 62 | "For technical details, see the f2c report.\n", 63 | "Both are available from netlib, e.g.,\n", 64 | - "\thttps://www.netlib.org/f2c/f2c.1\n", 65 | - "\thttps://www.netlib.org/f2c/f2c.pdf\nor\n", 66 | + "\thttps://netlib.org/f2c/f2c.1\n", 67 | + "\thttps://netlib.org/f2c/f2c.pdf\nor\n", 68 | "\thttps://ampl.com/netlib/f2c/f2c.1\n", 69 | "\thttps://ampl.com/netlib/f2c/f2c.pdf\n"); 70 | } 71 | diff --git a/src/sysdep.c b/src/sysdep.c 72 | index 01190c3..b9ee424 100644 73 | --- a/src/sysdep.c 74 | +++ b/src/sysdep.c 75 | @@ -46,7 +46,7 @@ char link_msg[] = "on Microsoft Windows system, link with libf2c.lib;\n\ 76 | -- in that order, at the end of the command line, as in\n\ 77 | cc *.o -lf2c -lm\n\ 78 | Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,\n\n\ 79 | - http://www.netlib.org/f2c/libf2c.zip"; 80 | + http://netlib.org/f2c/libf2c.zip"; 81 | 82 | char *outbuf = "", *outbtail; 83 | 84 | -------------------------------------------------------------------------------- /debian/patches/series: -------------------------------------------------------------------------------- 1 | 0001-make-tweaks.patch 2 | 0002-prototype-rmdir.patch 3 | 0003-struct-init-braces.patch 4 | 0004-fc-script-path-and-tmpfile.patch 5 | 0005-sysdep-tmpfiles.patch 6 | 0006-man-dash-hyphen-slash.patch 7 | 0007-fc-man-page.patch 8 | 0008-typos.patch 9 | 0009-redirect-URL.patch 10 | -------------------------------------------------------------------------------- /debian/rules: -------------------------------------------------------------------------------- 1 | #!/usr/bin/make -f 2 | 3 | # Uncomment this to turn on verbose mode. 4 | #export DH_VERBOSE=1 5 | 6 | export DEB_BUILD_MAINT_OPTIONS = hardening=+all 7 | 8 | %: 9 | dh $@ 10 | 11 | override_dh_auto_build: 12 | dh_auto_build -- $(shell dpkg-buildflags --export=configure) 13 | 14 | override_dh_auto_test: 15 | 16 | override_dh_auto_install: 17 | 18 | override_dh_installchangelogs: 19 | dh_installchangelogs changes 20 | -------------------------------------------------------------------------------- /debian/source/format: -------------------------------------------------------------------------------- 1 | 3.0 (quilt) 2 | -------------------------------------------------------------------------------- /debian/watch: -------------------------------------------------------------------------------- 1 | version=4 2 | 3 | # Netlib 4 | # Unfortunately it is not easy to determine the version 5 | # number from upstream. It is contained in a source code 6 | # file src/version.c 7 | # https://netlib.org/f2c/index.html 8 | # which can be directly accessed as 9 | # https://netlib.org/f2c/src/version.c 10 | 11 | ## This runs the check for the current version. 12 | # eval $(tail -4 debian/watch | sed 's/^#//' | sed 's/\\$//') 13 | 14 | ## This checks for the current version. 15 | # wget2 --quiet -O- https://netlib.org/f2c/src/version.c \ 16 | # | egrep F2C_version \ 17 | # | sed 's/^[^"]*"//' \ 18 | # | sed 's/".*$//' 19 | -------------------------------------------------------------------------------- /f2c.1: -------------------------------------------------------------------------------- 1 | 2 | F2C(1) UNIX System V F2C(1) 3 | 4 | NAME 5 | f2c - Convert Fortran 77 to C or C++ 6 | 7 | SYNOPSIS 8 | f2c [ option ... ] file ... 9 | 10 | DESCRIPTION 11 | F2c converts Fortran 77 source code in files with names end- 12 | ing in `.f' or `.F' to C (or C++) source files in the cur- 13 | rent directory, with `.c' substituted for the final `.f' or 14 | `.F'. If no Fortran files are named, f2c reads Fortran from 15 | standard input and writes C on standard output. File names 16 | that end with `.p' or `.P' are taken to be prototype files, 17 | as produced by option `-P', and are read first. 18 | 19 | The following options have the same meaning as in f77(1). 20 | 21 | -C Compile code to check that subscripts are within 22 | declared array bounds. 23 | 24 | -I2 Render INTEGER and LOGICAL as short, INTEGER*4 as long 25 | int. Assume the default libF77 and libI77: allow only 26 | INTEGER*4 (and no LOGICAL) variables in INQUIREs. 27 | Option `-I4' confirms the default rendering of INTEGER 28 | as long int. 29 | 30 | -I8 Assume 8-byte integer and logical, 4-byte REAL, 8-byte 31 | double precison and complex, and 16-byte double complex 32 | variables. Appropriate changes to f2c.h may be needed. 33 | 34 | -Idir 35 | Look for a non-absolute include file first in the 36 | directory of the current input file, then in directo- 37 | ries specified by -I options (one directory per 38 | option). Options -I2, -I4 and -I8 have precedence, so, 39 | e.g., a directory named 2 should be specified by -I./2 . 40 | 41 | -onetrip 42 | Compile DO loops that are performed at least once if 43 | reached. (Fortran 77 DO loops are not performed at all 44 | if the upper limit is smaller than the lower limit.) 45 | 46 | -U Honor the case of variable and external names. Fortran 47 | keywords must be in lower case. 48 | 49 | -u Make the default type of a variable `undefined' rather 50 | than using the default Fortran rules. 51 | 52 | -w Suppress all warning messages, or, if the option is 53 | `-w66', just Fortran 66 compatibility warnings. 54 | 55 | The following options are peculiar to f2c. 56 | 57 | -A Produce ANSI C (default, starting 20020621). For old- 58 | style C, use option -K. 59 | 60 | Page 1 (printed 1/23/24) 61 | 62 | F2C(1) UNIX System V F2C(1) 63 | 64 | -a Make local variables automatic rather than static 65 | unless they appear in a DATA, EQUIVALENCE, NAMELIST, or 66 | SAVE statement. 67 | 68 | -C++ Output C++ code. 69 | 70 | -c Include original Fortran source as comments. 71 | 72 | -cd Do not recognize cdabs, cdcos, cdexp, cdlog, cdsin, and 73 | cdsqrt as synonyms for the double complex intrinsics 74 | zabs, zcos, zexp, zlog, zsin, and zsqrt, respectively, 75 | nor dreal as a synonym for dble. 76 | 77 | -cf Do not report the current .f file except in error messages. 78 | 79 | -ddir 80 | Write `.c' files in directory dir instead of the cur- 81 | rent directory. 82 | 83 | -E Declare uninitialized COMMON to be Extern (overridably 84 | defined in f2c.h as extern). 85 | 86 | -ec Place uninitialized COMMON blocks in separate files: 87 | COMMON /ABC/ appears in file abc_com.c. Option `-e1c' 88 | bundles the separate files into the output file, with 89 | comments that give an unbundling sed(1) script. 90 | 91 | -ext Complain about f77(1) extensions. 92 | 93 | -f Assume free-format input: accept text after column 72 94 | and do not pad fixed-format lines shorter than 72 char- 95 | acters with blanks. 96 | 97 | -72 Treat text appearing after column 72 as an error. 98 | 99 | -g Include original Fortran line numbers in #line lines. 100 | 101 | -h Emulate Fortran 66's treatment of Hollerith: try to 102 | align character strings on word (or, if the option is 103 | `-hd', on double-word) boundaries. 104 | 105 | -i2 Similar to -I2, but assume a modified libF77 and libI77 106 | (compiled with -Df2c_i2), so INTEGER and LOGICAL vari- 107 | ables may be assigned by INQUIRE and array lengths are 108 | stored in short ints. 109 | 110 | -i90 Do not recognize the Fortran 90 bit-manipulation 111 | intrinsics btest, iand, ibclr, ibits, ibset, ieor, ior, 112 | ishft, and ishftc. 113 | 114 | -kr Use temporary values to enforce Fortran expression 115 | evaluation where K&R (first edition) parenthesization 116 | rules allow rearrangement. If the option is `-krd', 117 | use double precision temporaries even for single- 118 | 119 | Page 2 (printed 1/23/24) 120 | 121 | F2C(1) UNIX System V F2C(1) 122 | 123 | precision operands. 124 | 125 | -P Write a file.P of ANSI (or C++) prototypes for defini- 126 | tions in each input file.f or file.F. When reading 127 | Fortran from standard input, write prototypes at the 128 | beginning of standard output. Option -Ps implies -P 129 | and gives exit status 4 if rerunning f2c may change 130 | prototypes or declarations. 131 | 132 | -p Supply preprocessor definitions to make common-block 133 | members look like local variables. 134 | 135 | -R Do not promote REAL functions and operations to DOUBLE 136 | PRECISION. Option `-!R' confirms the default, which 137 | imitates f77. 138 | 139 | -r Cast REAL arguments of intrinsic functions and values 140 | of REAL functions (including intrinsics) to REAL. 141 | 142 | -r8 Promote REAL to DOUBLE PRECISION, COMPLEX to DOUBLE 143 | COMPLEX. 144 | 145 | -s Preserve multidimensional subscripts. Suppressed by 146 | option `-C' . 147 | 148 | -Tdir 149 | Put temporary files in directory dir. 150 | 151 | -trapuv 152 | Dynamically initialize local variables, except those 153 | appearing in SAVE or DATA statements, with values that 154 | may help find references to uninitialized variables. 155 | For example, with IEEE arithmetic, initialize local 156 | floating-point variables to signaling NaNs. 157 | 158 | -w8 Suppress warnings when COMMON or EQUIVALENCE forces 159 | odd-word alignment of doubles. 160 | 161 | -Wn Assume n characters/word (default 4) when initializing 162 | numeric variables with character data. 163 | 164 | -z Do not implicitly recognize DOUBLE COMPLEX. 165 | 166 | -!bs Do not recognize backslash escapes (\", \', \0, \\, \b, 167 | \f, \n, \r, \t, \v) in character strings. 168 | 169 | -!c Inhibit C output, but produce -P output. 170 | 171 | -!I Reject include statements. 172 | 173 | -!i8 Disallow INTEGER*8 , or, if the option is `-!i8const', 174 | permit INTEGER*8 but do not promote integer constants 175 | 176 | Page 3 (printed 1/23/24) 177 | 178 | F2C(1) UNIX System V F2C(1) 179 | 180 | to INTEGER*8 when they involve more than 32 bits. 181 | 182 | -!it Don't infer types of untyped EXTERNAL procedures from 183 | use as parameters to previously defined or prototyped 184 | procedures. 185 | 186 | -!P Do not attempt to infer ANSI or C++ prototypes from 187 | usage. 188 | 189 | The resulting C invokes the support routines of f77; object 190 | code should be loaded by f77 or with ld(1) or cc(1) options 191 | -lF77 -lI77 -lm. Calling conventions are those of f77: see 192 | the reference below. 193 | 194 | FILES 195 | file.[fF] input file 196 | 197 | *.c output file 198 | 199 | /usr/include/f2c.h 200 | header file 201 | 202 | /usr/lib/libF77.aintrinsic function library 203 | 204 | /usr/lib/libI77.aFortran I/O library 205 | 206 | /lib/libc.a C library, see section 3 207 | 208 | SEE ALSO 209 | S. I. Feldman and P. J. Weinberger, `A Portable Fortran 77 210 | Compiler', UNIX Time Sharing System Programmer's Manual, 211 | Tenth Edition, Volume 2, AT&T Bell Laboratories, 1990. 212 | 213 | DIAGNOSTICS 214 | The diagnostics produced by f2c are intended to be self- 215 | explanatory. 216 | 217 | BUGS 218 | Floating-point constant expressions are simplified in the 219 | floating-point arithmetic of the machine running f2c, so 220 | they are typically accurate to at most 16 or 17 decimal 221 | places. 222 | Untypable EXTERNAL functions are declared int. 223 | There is no notation for INTEGER*8 constants. 224 | Some intrinsic functions do not yet work with INTEGER*8 . 225 | 226 | Page 4 (printed 1/23/24) 227 | 228 | -------------------------------------------------------------------------------- /f2c.1t: -------------------------------------------------------------------------------- 1 | . \" Definitions of F, L and LR for the benefit of systems 2 | . \" whose -man lacks them... 3 | .de F 4 | .nh 5 | .if n \%\&\\$1 6 | .if t \%\&\f(CW\\$1\fR 7 | .hy 14 8 | .. 9 | .de L 10 | .nh 11 | .if n \%`\\$1' 12 | .if t \%\&\f(CW\\$1\fR 13 | .hy 14 14 | .. 15 | .de LR 16 | .nh 17 | .if n \%`\\$1'\\$2 18 | .if t \%\&\f(CW\\$1\fR\\$2 19 | .hy 14 20 | .. 21 | .TH F2C 1 22 | .CT 1 prog_other 23 | .SH NAME 24 | f2c \- Convert Fortran 77 to C or C++ 25 | . \" f\^2c changed to f2c in the previous line for the benefit of 26 | . \" people on systems (e.g. Sun systems) whose makewhatis cannot 27 | . \" cope with troff formatting commands. 28 | .SH SYNOPSIS 29 | .B f\^2c 30 | [ 31 | .I option ... 32 | ] 33 | .I file ... 34 | .SH DESCRIPTION 35 | .I F2c 36 | converts Fortran 77 source code in 37 | .I files 38 | with names ending in 39 | .L .f 40 | or 41 | .L .F 42 | to C (or C++) source files in the 43 | current directory, with 44 | .L .c 45 | substituted 46 | for the final 47 | .L .f 48 | or 49 | .LR .F . 50 | If no Fortran files are named, 51 | .I f\^2c 52 | reads Fortran from standard input and 53 | writes C on standard output. 54 | .I File 55 | names that end with 56 | .L .p 57 | or 58 | .L .P 59 | are taken to be prototype 60 | files, as produced by option 61 | .LR -P , 62 | and are read first. 63 | .PP 64 | The following options have the same meaning as in 65 | .IR f\^77 (1). 66 | .TP 67 | .B -C 68 | Compile code to check that subscripts are within declared array bounds. 69 | .TP 70 | .B -I2 71 | Render INTEGER and LOGICAL as short, 72 | INTEGER\(**4 as long int. Assume the default \fIlibF77\fR 73 | and \fIlibI77\fR: allow only INTEGER\(**4 (and no LOGICAL) 74 | variables in INQUIREs. Option 75 | .L -I4 76 | confirms the default rendering of INTEGER as long int. 77 | .TP 78 | .B -I8 79 | Assume 8-byte integer and logical, 4-byte REAL, 8-byte double precison 80 | and complex, and 16-byte double complex variables. Appropriate changes 81 | to f2c.h may be needed. 82 | .TP 83 | .BI -I dir 84 | Look for a non-absolute include file first in the directory of the 85 | current input file, then in directories specified by \f(CW-I\fP 86 | options (one directory per option). Options 87 | \f(CW-I2\fP, \f(CW-I4\fP, and \f(CW-I8\fP 88 | have precedence, so, e.g., a directory named \f(CW2\fP 89 | should be specified by \f(CW-I./2\fP . 90 | .TP 91 | .B -onetrip 92 | Compile DO loops that are performed at least once if reached. 93 | (Fortran 77 DO loops are not performed at all if the upper limit is smaller than the lower limit.) 94 | .TP 95 | .B -U 96 | Honor the case of variable and external names. Fortran keywords must be in 97 | .I 98 | lower 99 | case. 100 | .TP 101 | .B -u 102 | Make the default type of a variable `undefined' rather than using the default Fortran rules. 103 | .TP 104 | .B -w 105 | Suppress all warning messages, or, if the option is 106 | .LR -w66 , 107 | just Fortran 66 compatibility warnings. 108 | .PP 109 | The following options are peculiar to 110 | .IR f\^2c . 111 | .TP 112 | .B -A 113 | Produce 114 | .SM ANSI 115 | C (default, starting 20020621). 116 | For old-style C, use option \f(CW-K\fP. 117 | .TP 118 | .B -a 119 | Make local variables automatic rather than static 120 | unless they appear in a 121 | .SM "DATA, EQUIVALENCE, NAMELIST," 122 | or 123 | .SM SAVE 124 | statement. 125 | .TP 126 | .B -C++ 127 | Output C++ code. 128 | .TP 129 | .B -c 130 | Include original Fortran source as comments. 131 | .TP 132 | .B -cd 133 | Do not recognize cdabs, cdcos, cdexp, cdlog, cdsin, and cdsqrt 134 | as synonyms for the double complex intrinsics 135 | zabs, zcos, zexp, zlog, zsin, and zsqrt, respectively, 136 | nor dreal as a synonym for dble. 137 | .TP 138 | .B -cf 139 | Do not report the current \f(CW.f\fP file except in error messages. 140 | .TP 141 | .BI -d dir 142 | Write 143 | .L .c 144 | files in directory 145 | .I dir 146 | instead of the current directory. 147 | .TP 148 | .B -E 149 | Declare uninitialized 150 | .SM COMMON 151 | to be 152 | .B Extern 153 | (overridably defined in 154 | .F f2c.h 155 | as 156 | .B extern). 157 | .TP 158 | .B -ec 159 | Place uninitialized 160 | .SM COMMON 161 | blocks in separate files: 162 | .B COMMON /ABC/ 163 | appears in file 164 | .BR abc_com.c . 165 | Option 166 | .LR -e1c 167 | bundles the separate files 168 | into the output file, with comments that give an unbundling 169 | .IR sed (1) 170 | script. 171 | .TP 172 | .B -ext 173 | Complain about 174 | .IR f\^77 (1) 175 | extensions. 176 | .TP 177 | .B -f 178 | Assume free-format input: accept text after column 72 and do not 179 | pad fixed-format lines shorter than 72 characters with blanks. 180 | .TP 181 | .B -72 182 | Treat text appearing after column 72 as an error. 183 | .TP 184 | .B -g 185 | Include original Fortran line numbers in \f(CW#line\fR lines. 186 | .TP 187 | .B -h 188 | Emulate Fortran 66's treatment of Hollerith: try to align character strings on 189 | word (or, if the option is 190 | .LR -hd , 191 | on double-word) boundaries. 192 | .TP 193 | .B -i2 194 | Similar to 195 | .BR -I2 , 196 | but assume a modified 197 | .I libF77 198 | and 199 | .I libI77 200 | (compiled with 201 | .BR -Df\^2c_i2 ), 202 | so 203 | .SM INTEGER 204 | and 205 | .SM LOGICAL 206 | variables may be assigned by 207 | .SM INQUIRE 208 | and array lengths are stored in short ints. 209 | .TP 210 | .B -i90 211 | Do not recognize the Fortran 90 bit-manipulation intrinsics 212 | btest, iand, ibclr, ibits, ibset, ieor, ior, ishft, and ishftc. 213 | .TP 214 | .B -kr 215 | Use temporary values to enforce Fortran expression evaluation 216 | where K&R (first edition) parenthesization rules allow rearrangement. 217 | If the option is 218 | .LR -krd , 219 | use double precision temporaries even for single-precision operands. 220 | .TP 221 | .B -P 222 | Write a 223 | .IB file .P 224 | of ANSI (or C++) prototypes 225 | for definitions in each input 226 | .IB file .f 227 | or 228 | .IB file .F . 229 | When reading Fortran from standard input, write prototypes 230 | at the beginning of standard output. Option 231 | .B -Ps 232 | implies 233 | .B -P 234 | and gives exit status 4 if rerunning 235 | .I f\^2c 236 | may change prototypes or declarations. 237 | .TP 238 | .B -p 239 | Supply preprocessor definitions to make common-block members 240 | look like local variables. 241 | .TP 242 | .B -R 243 | Do not promote 244 | .SM REAL 245 | functions and operations to 246 | .SM DOUBLE PRECISION. 247 | Option 248 | .L -!R 249 | confirms the default, which imitates 250 | .IR f\^77 . 251 | .TP 252 | .B -r 253 | Cast REAL arguments of intrinsic functions and values of REAL 254 | functions (including intrinsics) to REAL. 255 | .TP 256 | .B -r8 257 | Promote 258 | .SM REAL 259 | to 260 | .SM DOUBLE PRECISION, COMPLEX 261 | to 262 | .SM DOUBLE COMPLEX. 263 | .TP 264 | .B -s 265 | Preserve multidimensional subscripts. Suppressed by option 266 | .L -C 267 | \&. 268 | .TP 269 | .BI -T dir 270 | Put temporary files in directory 271 | .I dir. 272 | .TP 273 | .B -trapuv 274 | Dynamically initialize local variables, except those appearing in 275 | .SM SAVE 276 | or 277 | .SM DATA 278 | statements, with values that may help find references to 279 | uninitialized variables. For example, with IEEE arithmetic, 280 | initialize local floating-point variables to signaling NaNs. 281 | .TP 282 | .B -w8 283 | Suppress warnings when 284 | .SM COMMON 285 | or 286 | .SM EQUIVALENCE 287 | forces odd-word alignment of doubles. 288 | .TP 289 | .BI -W n 290 | Assume 291 | .I n 292 | characters/word (default 4) 293 | when initializing numeric variables with character data. 294 | .TP 295 | .B -z 296 | Do not implicitly recognize 297 | .SM DOUBLE COMPLEX. 298 | .TP 299 | .B -!bs 300 | Do not recognize \fIb\fRack\fIs\fRlash escapes 301 | (\e", \e', \e0, \e\e, \eb, \ef, \en, \er, \et, \ev) in character strings. 302 | .TP 303 | .B -!c 304 | Inhibit C output, but produce 305 | .B -P 306 | output. 307 | .TP 308 | .B -!I 309 | Reject 310 | .B include 311 | statements. 312 | .TP 313 | .B -!i8 314 | Disallow 315 | .SM INTEGER*8 , 316 | or, if the option is 317 | .LR -!i8const , 318 | permit 319 | .SM INTEGER*8 320 | but do not promote integer 321 | constants to 322 | .SM INTEGER*8 323 | when they involve more than 32 bits. 324 | .TP 325 | .B -!it 326 | Don't infer types of untyped 327 | .SM EXTERNAL 328 | procedures from use as parameters to previously defined or prototyped 329 | procedures. 330 | .TP 331 | .B -!P 332 | Do not attempt to infer 333 | .SM ANSI 334 | or C++ 335 | prototypes from usage. 336 | .PP 337 | The resulting C invokes the support routines of 338 | .IR f\^77 ; 339 | object code should be loaded by 340 | .I f\^77 341 | or with 342 | .IR ld (1) 343 | or 344 | .IR cc (1) 345 | options 346 | .BR "-lF77 -lI77 -lm" . 347 | Calling conventions 348 | are those of 349 | .IR f\&77 : 350 | see the reference below. 351 | .br 352 | .SH FILES 353 | .TP 354 | .nr )I 1.75i 355 | .IB file .[fF] 356 | input file 357 | .TP 358 | .B *.c 359 | output file 360 | .TP 361 | .F /usr/include/f2c.h 362 | header file 363 | .TP 364 | .F /usr/lib/libF77.a 365 | intrinsic function library 366 | .TP 367 | .F /usr/lib/libI77.a 368 | Fortran I/O library 369 | .TP 370 | .F /lib/libc.a 371 | C library, see section 3 372 | .SH "SEE ALSO" 373 | S. I. Feldman and 374 | P. J. Weinberger, 375 | `A Portable Fortran 77 Compiler', 376 | \fIUNIX Time Sharing System Programmer's Manual\fR, 377 | Tenth Edition, Volume 2, AT&T Bell Laboratories, 1990. 378 | .SH DIAGNOSTICS 379 | The diagnostics produced by 380 | .I f\^2c 381 | are intended to be 382 | self-explanatory. 383 | .SH BUGS 384 | Floating-point constant expressions are simplified in 385 | the floating-point arithmetic of the machine running 386 | .IR f\^2c , 387 | so they are typically accurate to at most 16 or 17 decimal places. 388 | .br 389 | Untypable 390 | .SM EXTERNAL 391 | functions are declared 392 | .BR int . 393 | .br 394 | There is no notation for 395 | .SM INTEGER*8 396 | constants. 397 | .br 398 | Some intrinsic functions do not yet work with 399 | .SM INTEGER*8 . 400 | -------------------------------------------------------------------------------- /f2c.h: -------------------------------------------------------------------------------- 1 | /* f2c.h -- Standard Fortran to C header file */ 2 | 3 | /** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." 4 | 5 | - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ 6 | 7 | #ifndef F2C_INCLUDE 8 | #define F2C_INCLUDE 9 | 10 | typedef int integer; 11 | typedef unsigned int uinteger; 12 | typedef char *address; 13 | typedef short int shortint; 14 | typedef float real; 15 | typedef double doublereal; 16 | typedef struct { real r, i; } complex; 17 | typedef struct { doublereal r, i; } doublecomplex; 18 | typedef int logical; 19 | typedef short int shortlogical; 20 | typedef char logical1; 21 | typedef char integer1; 22 | #if 1 /*ifdef INTEGER_STAR_8*/ /* Adjust for integer*8. */ 23 | typedef long longint; /* system-dependent; long long on some systems */ 24 | typedef unsigned long ulongint; /* system-dependent; long long on some systems */ 25 | #define qbit_clear(a,b) ((a) & ~((ulongint)1 << (b))) 26 | #define qbit_set(a,b) ((a) | ((ulongint)1 << (b))) 27 | #endif 28 | 29 | #define TRUE_ (1) 30 | #define FALSE_ (0) 31 | 32 | /* Extern is for use with -E */ 33 | #ifndef Extern 34 | #define Extern extern 35 | #endif 36 | 37 | /* I/O stuff */ 38 | 39 | #ifdef f2c_i2 40 | /* for -i2 */ 41 | typedef short flag; 42 | typedef short ftnlen; 43 | typedef short ftnint; 44 | #else 45 | typedef int flag; 46 | typedef int ftnlen; 47 | typedef int ftnint; 48 | #endif 49 | 50 | /*external read, write*/ 51 | typedef struct 52 | { flag cierr; 53 | ftnint ciunit; 54 | flag ciend; 55 | char *cifmt; 56 | ftnint cirec; 57 | } cilist; 58 | 59 | /*internal read, write*/ 60 | typedef struct 61 | { flag icierr; 62 | char *iciunit; 63 | flag iciend; 64 | char *icifmt; 65 | ftnint icirlen; 66 | ftnint icirnum; 67 | } icilist; 68 | 69 | /*open*/ 70 | typedef struct 71 | { flag oerr; 72 | ftnint ounit; 73 | char *ofnm; 74 | ftnlen ofnmlen; 75 | char *osta; 76 | char *oacc; 77 | char *ofm; 78 | ftnint orl; 79 | char *oblnk; 80 | } olist; 81 | 82 | /*close*/ 83 | typedef struct 84 | { flag cerr; 85 | ftnint cunit; 86 | char *csta; 87 | } cllist; 88 | 89 | /*rewind, backspace, endfile*/ 90 | typedef struct 91 | { flag aerr; 92 | ftnint aunit; 93 | } alist; 94 | 95 | /* inquire */ 96 | typedef struct 97 | { flag inerr; 98 | ftnint inunit; 99 | char *infile; 100 | ftnlen infilen; 101 | ftnint *inex; /*parameters in standard's order*/ 102 | ftnint *inopen; 103 | ftnint *innum; 104 | ftnint *innamed; 105 | char *inname; 106 | ftnlen innamlen; 107 | char *inacc; 108 | ftnlen inacclen; 109 | char *inseq; 110 | ftnlen inseqlen; 111 | char *indir; 112 | ftnlen indirlen; 113 | char *infmt; 114 | ftnlen infmtlen; 115 | char *inform; 116 | ftnint informlen; 117 | char *inunf; 118 | ftnlen inunflen; 119 | ftnint *inrecl; 120 | ftnint *innrec; 121 | char *inblank; 122 | ftnlen inblanklen; 123 | } inlist; 124 | 125 | #define VOID void 126 | 127 | union Multitype { /* for multiple entry points */ 128 | integer1 g; 129 | shortint h; 130 | integer i; 131 | /* longint j; */ 132 | real r; 133 | doublereal d; 134 | complex c; 135 | doublecomplex z; 136 | }; 137 | 138 | typedef union Multitype Multitype; 139 | 140 | /*typedef int Long;*/ /* No longer used; formerly in Namelist */ 141 | 142 | struct Vardesc { /* for Namelist */ 143 | char *name; 144 | char *addr; 145 | ftnlen *dims; 146 | int type; 147 | }; 148 | typedef struct Vardesc Vardesc; 149 | 150 | struct Namelist { 151 | char *name; 152 | Vardesc **vars; 153 | int nvars; 154 | }; 155 | typedef struct Namelist Namelist; 156 | 157 | #define abs(x) ((x) >= 0 ? (x) : -(x)) 158 | #define dabs(x) (doublereal)abs(x) 159 | #define min(a,b) ((a) <= (b) ? (a) : (b)) 160 | #define max(a,b) ((a) >= (b) ? (a) : (b)) 161 | #define dmin(a,b) (doublereal)min(a,b) 162 | #define dmax(a,b) (doublereal)max(a,b) 163 | #define bit_test(a,b) ((a) >> (b) & 1) 164 | #define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) 165 | #define bit_set(a,b) ((a) | ((uinteger)1 << (b))) 166 | 167 | /* procedure parameter types for -A and -C++ */ 168 | 169 | #define F2C_proc_par_types 1 170 | #ifdef __cplusplus 171 | typedef int /* Unknown procedure type */ (*U_fp)(...); 172 | typedef shortint (*J_fp)(...); 173 | typedef integer (*I_fp)(...); 174 | typedef real (*R_fp)(...); 175 | typedef doublereal (*D_fp)(...), (*E_fp)(...); 176 | typedef /* Complex */ VOID (*C_fp)(...); 177 | typedef /* Double Complex */ VOID (*Z_fp)(...); 178 | typedef logical (*L_fp)(...); 179 | typedef shortlogical (*K_fp)(...); 180 | typedef /* Character */ VOID (*H_fp)(...); 181 | typedef /* Subroutine */ int (*S_fp)(...); 182 | #else 183 | typedef int /* Unknown procedure type */ (*U_fp)(); 184 | typedef shortint (*J_fp)(); 185 | typedef integer (*I_fp)(); 186 | typedef real (*R_fp)(); 187 | typedef doublereal (*D_fp)(), (*E_fp)(); 188 | typedef /* Complex */ VOID (*C_fp)(); 189 | typedef /* Double Complex */ VOID (*Z_fp)(); 190 | typedef logical (*L_fp)(); 191 | typedef shortlogical (*K_fp)(); 192 | typedef /* Character */ VOID (*H_fp)(); 193 | typedef /* Subroutine */ int (*S_fp)(); 194 | #endif 195 | /* E_fp is for real functions when -R is not specified */ 196 | typedef VOID C_f; /* complex function */ 197 | typedef VOID H_f; /* character function */ 198 | typedef VOID Z_f; /* double complex function */ 199 | typedef doublereal E_f; /* real function with -R not specified */ 200 | 201 | /* undef any lower-case symbols that your C compiler predefines, e.g.: */ 202 | 203 | #ifndef Skip_f2c_Undefs 204 | #undef cray 205 | #undef gcos 206 | #undef mc68010 207 | #undef mc68020 208 | #undef mips 209 | #undef pdp11 210 | #undef sgi 211 | #undef sparc 212 | #undef sun 213 | #undef sun2 214 | #undef sun3 215 | #undef sun4 216 | #undef u370 217 | #undef u3b 218 | #undef u3b2 219 | #undef u3b5 220 | #undef unix 221 | #undef vax 222 | #endif 223 | #endif 224 | -------------------------------------------------------------------------------- /f2c.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/barak/f2c/92d296bc389387ab83ec9b73dadebee7fbf5d10c/f2c.pdf -------------------------------------------------------------------------------- /fc: -------------------------------------------------------------------------------- 1 | #! /bin/sh 2 | 3 | # NOTE: you may need to adjust the references to /usr/local/... below 4 | # (or remove them if they're not needed on your system). 5 | # You may need to add something like "-Olimit 2000" to the -O 6 | # processing below or change it to something more suitable for your 7 | # system. See also the comments starting with ### below. 8 | 9 | # Note that with some shells, invocations of the form 10 | # CFLAGS='system-specific stuff' fc ... 11 | # may be useful as way to pass system-specific stuff to the C compiler. 12 | # The script below simply appends to the initial CFLAGS value. 13 | 14 | PATH=/usr/local/bin:/bin:/usr/bin 15 | 16 | # f77-style shell script to compile and load fortran, C, and assembly codes 17 | 18 | # usage: f77 [options] files [-l library] 19 | 20 | # Options: 21 | 22 | # -o objfile Override default executable name a.out. 23 | 24 | # -a use automatic variable storage (on the stack) 25 | # by default -- rather than static storage 26 | 27 | # -c Do not call linker, leave relocatables in *.o. 28 | 29 | # -C Check that subscripts are in bounds. 30 | 31 | # -S leave assembler output on file.s 32 | 33 | # -L libdir (passed to ld) 34 | 35 | # -l library (passed to ld) 36 | 37 | # -u complain about undeclared variables 38 | 39 | # -w omit all warning messages 40 | 41 | # -w66 omit Fortran 66 compatibility warning messages 42 | 43 | # files FORTRAN source files ending in .f . 44 | # FORTRAN with cpp preprocessor directives 45 | # ending in .F . 46 | # C source files ending in .c . 47 | # Assembly language files ending in .s . 48 | # efl source files ending in .e . 49 | # RATFOR files ending in .r . 50 | # Object files ending in .o . 51 | # Shared libraries ending in .so . 52 | 53 | # f2c prototype files ending in .P ; such 54 | # files only affect subsequent files. 55 | 56 | # -D def passed to C compiler (for .c files) 57 | # or to cpp (for .F files) 58 | 59 | # -I includepath passed to C compiler (for .c files) 60 | # or to cpp (for .F files), and to f2c 61 | 62 | # -m xxx passed to C compiler as -mxxx 63 | 64 | # -N tnnn allow nnn entries in table t 65 | 66 | # -P emit .P files 67 | 68 | # -r8 promote real to double precision and 69 | # complex to double complex 70 | 71 | # -s strip executable 72 | 73 | # -trapuv Initialize floating-point variables to 74 | # signaling NaNs (on machines with IEEE 75 | # arithmetic) unless they appear in save, 76 | # common, or data statements. Initialize 77 | # other kinds of variables to values that 78 | # may attract attention if used without 79 | # being assigned proper values. 80 | 81 | # -U def passed to C compiler (for .c files) 82 | # or to cpp (for .F files) to remove def 83 | 84 | # -v show current f2c version 85 | # --version same as -v 86 | 87 | s=/tmp/stderr_$$ 88 | t=/tmp/f77_$$.o 89 | ### On some systems (e.g., IRIX), -common prevents complaints 90 | ### about multiple definitions of COMMON blocks. 91 | #CC=${CC_f2c:-'cc -common'} 92 | CC=${CC_f2c:-'cc'} 93 | EFL=${EFL:-efl} 94 | EFLFLAGS=${EFLFLAGS:-'system=portable deltastno=10'} 95 | RATFOR=${RATFOR:-ratfor} 96 | RFLAGS=${RFLAGS:-'-6&'} 97 | F2C=${F2C:-/usr/local/bin/f2c} 98 | show_fc_help=0 99 | case $1 in 100 | --help) show_fc_help=1;; 101 | --version) show_fc_help=2;; 102 | '-?') show_fc_help=1;; 103 | -h) show_fc_help=1;; 104 | -v) show_fc_help=2;; 105 | esac 106 | case $show_fc_help in 107 | 1) 108 | echo 'f77 script based on f2c' 109 | echo 'For usage details, see comments at the beginning of' $0 . 110 | echo 'For pointers to f2c documentation, invoke' $F2C --help 111 | exit 0;; 112 | 2) 113 | echo $0 'script based on f2c:'; $F2C -v 114 | exit 0;; 115 | esac 116 | F2CFLAGS=${F2CFLAGS:='-ARw8 -Nn802 -Nq300 -Nx400'} 117 | CPP=${CPP:-/lib/cpp} 118 | rc=0 119 | trap "rm -f $s $t; exit \$rc" 0 120 | OUTF=a.out 121 | OUTO= 122 | cOPT=1 123 | set -- `getopt acCD:gI:L:m:N:O:U:o:r:sSt:uw6 "$@"` 124 | case $? in 0);; *) rc=$?; exit;; esac 125 | CPPFLAGS=${CPPFLAGS:-'-I/usr/local/include'} 126 | CFLAGSF2C=${CFLAGSF2C:-'-I/usr/local/include'} 127 | OFILES= 128 | trapuv= 129 | strip= 130 | LIBS="-lf2c -lm" 131 | while 132 | test X"$1" != X-- 133 | do 134 | case "$1" 135 | in 136 | -a) F2CFLAGS="$F2CFLAGS -a" 137 | shift;; 138 | 139 | -C) F2CFLAGS="$F2CFLAGS -C" 140 | shift;; 141 | 142 | -c) cOPT=0 143 | shift 144 | ;; 145 | 146 | -D) CPPFLAGS="$CPPFLAGS -D$2" 147 | shift 2 148 | ;; 149 | 150 | -g) CFLAGS="$CFLAGS -g" 151 | F2CFLAGS="$F2CFLAGS -g" 152 | shift;; 153 | 154 | -I) CPPFLAGS="$CPPFLAGS -I$2" 155 | F2CFLAGS="$F2CFLAGS -I$2" 156 | shift 2 157 | ;; 158 | 159 | -m) CC="$CC -m$2" 160 | shift 2 161 | ;; 162 | 163 | -U) CPPFLAGS="$CPPFLAGS -U$2" 164 | shift 2 165 | ;; 166 | 167 | -o) OUTF=$2 168 | OUTO=$2 169 | shift 2 170 | ;; 171 | 172 | -O) case $2 in 1) O=-O1;; 2) O=-O2;; 3) O=-O3;; *) O=-O;; esac 173 | case $O in -O);; *) shift;; esac 174 | CFLAGS="$CFLAGS $O" 175 | # CFLAGS="$CFLAGS $O -Olimit 2000" 176 | shift 177 | ;; 178 | 179 | -r) case $2 in 8) F2CFLAGS="$F2CFLAGS -r8";; 180 | *) echo "Ignoring -r$2";; esac 181 | shift; shift 182 | ;; 183 | 184 | -s) strip=1 185 | shift 186 | ;; 187 | 188 | -u) F2CFLAGS="$F2CFLAGS -u" 189 | shift 190 | ;; 191 | 192 | -w) F2CFLAGS="$F2CFLAGS -w" 193 | case $2 in -6) F2CFLAGS="$F2CFLAGS"66; shift 194 | case $2 in -6) shift;; esac;; esac 195 | shift 196 | ;; 197 | 198 | -L) OFILES="$OFILES $1$2" 199 | shift 2 200 | case $cOPT in 1) cOPT=2;; esac 201 | ;; 202 | 203 | -L*) OFILES="$OFILES $1" 204 | shift 205 | case $cOPT in 1) cOPT=2;; esac 206 | ;; 207 | 208 | -N) F2CFLAGS="$F2CFLAGS $1""$2" 209 | shift 2 210 | ;; 211 | 212 | -P) F2CFLAGS="$F2CFLAGS $1" 213 | shift 214 | ;; 215 | 216 | 217 | -S) CFLAGS="$CFLAGS -S" 218 | cOPT=0 219 | shift 220 | ;; 221 | 222 | -t) 223 | case $2 in 224 | rapuv) 225 | F2CFLAGS="$F2CFLAGS -trapuv" 226 | trapuv=1 227 | # LIBS="$LIBS -lfpe" 228 | shift 2;; 229 | *) 230 | echo "invalid parameter $1" 1>&2 231 | shift;; 232 | esac 233 | ;; 234 | 235 | '') echo $0: 'unexpected null argument'; exit 1;; 236 | 237 | *) 238 | echo "invalid parameter $1" 1>&2 239 | shift 240 | ;; 241 | esac 242 | done 243 | shift 244 | case $cOPT in 0) case $OUTO in '');; *) CFLAGS="$CFLAGS -o $OUTO";; esac;; esac 245 | while 246 | test -n "$1" 247 | do 248 | case "$1" 249 | in 250 | *.[fF]) 251 | case "$1" in *.f) f=".f";; *.F) f=".F";; esac 252 | case "$1" in 253 | *.f) b=`basename $1 .f` 254 | $F2C $F2CFLAGS $1 255 | rc=$? 256 | ;; 257 | *.F) b=`basename $1 .F` 258 | $CPP $CPPFLAGS $1 >$b.i 259 | rc=$? 260 | case $rc in 0) 261 | $F2C $F2CFLAGS <$b.i >$b.c 262 | rc=$? 263 | ;;esac 264 | rm $b.i 265 | ;; 266 | esac 267 | case $rc in 0);; *) exit;; esac 268 | $CC -c $CFLAGSF2C $CFLAGS $b.c 2>$s 269 | rc=$? 270 | sed '/parameter .* is not referenced/d;/warning: too many parameters/d' $s 1>&2 271 | case $rc in 0);; *) exit;; esac 272 | OFILES="$OFILES $b.o" 273 | rm $b.c 274 | case $cOPT in 1) cOPT=2;; esac 275 | shift 276 | ;; 277 | *.e) 278 | b=`basename $1 .e` 279 | $EFL $EFLFLAGS $1 >$b.f 280 | case $? in 0);; *) rc=$?; exit;; esac 281 | $F2C $F2CFLAGS $b.f 282 | case $? in 0);; *) rc=$?; exit;; esac 283 | $CC -c $CFLAGSF2C $CFLAGS $b.c 284 | case $? in 0);; *) rc=$?; exit;; esac 285 | OFILES="$OFILES $b.o" 286 | rm $b.[cf] 287 | case $cOPT in 1) cOPT=2;; esac 288 | shift 289 | ;; 290 | *.r) 291 | b=`basename $1 .r` 292 | $RATFOR $RFLAGS $1 >$b.f 293 | case $? in 0);; *) rc=$?; exit;; esac 294 | $F2C $F2CFLAGS $b.f 295 | case $? in 0);; *) rc=$?; exit;; esac 296 | $CC -c $CFLAGSF2C $CFLAGS $b.c 297 | case $? in 0);; *) rc=$?; exit;; esac 298 | OFILES="$OFILES $b.o" 299 | rm $b.[cf] 300 | case $cOPT in 1) cOPT=2;; esac 301 | shift 302 | ;; 303 | *.s) 304 | echo $1: 1>&2 305 | OFILE=`basename $1 .s`.o 306 | ${AS:-as} -o $OFILE $AFLAGS $1 307 | case $? in 0);; *) rc=$?; exit;; esac 308 | OFILES="$OFILES $OFILE" 309 | case $cOPT in 1) cOPT=2;; esac 310 | shift 311 | ;; 312 | *.c) 313 | echo $1: 1>&2 314 | OFILE=`basename $1 .c`.o 315 | $CC -c $CFLAGSF2C $CPPFLAGS $CFLAGS $1 316 | rc=$?; case $rc in 0);; *) rc=$?; exit;; esac 317 | OFILES="$OFILES $OFILE" 318 | case $cOPT in 1) cOPT=2;; esac 319 | shift 320 | ;; 321 | *.o) 322 | OFILES="$OFILES $1" 323 | case $cOPT in 1) cOPT=2;; esac 324 | shift 325 | ;; 326 | *.so) 327 | OFILES="$OFILES $1" 328 | case $cOPT in 1) cOPT=2;; esac 329 | shift 330 | ;; 331 | -[lL]) 332 | OFILES="$OFILES $1$2" 333 | shift 2 334 | case $cOPT in 1) cOPT=2;; esac 335 | ;; 336 | -[lL]*) 337 | OFILES="$OFILES $1" 338 | shift 339 | case $cOPT in 1) cOPT=2;; esac 340 | ;; 341 | -o) 342 | case $cOPT in 0) CFLAGS="$CFLAGS -o $2";; *) OUTF=$2;; esac 343 | shift 2;; 344 | *.P) 345 | F2CFLAGS="$F2CFLAGS $1" 346 | shift 347 | ;; 348 | *) 349 | OFILES="$OFILES $1" 350 | shift 351 | case $cOPT in 1) cOPT=2;; esac 352 | ;; 353 | esac 354 | done 355 | 356 | ### On some (IRIX) systems, -Wl,-dont_warn_unused prevents complaints 357 | ### about unnecessary -l options. 358 | 359 | case $cOPT in 2) 360 | # case $trapuv in 1) OFILES="$OFILES -lfpe";; esac 361 | # $CC -Wl,-dont_warn_unused -o $OUTF -u MAIN__ -L/usr/local/lib $OFILES $LIBS 362 | $CC -o $OUTF -u MAIN__ -L/usr/local/lib $OFILES $LIBS 363 | case $strip in 1) strip $OUTF;; esac 364 | ;; esac 365 | rc=$? 366 | exit $rc 367 | -------------------------------------------------------------------------------- /getopt.c: -------------------------------------------------------------------------------- 1 | /**************************************************************** 2 | Copyright 1996 by Lucent Technologies. 3 | 4 | Permission to use, copy, modify, and distribute this software and 5 | its documentation for any purpose and without fee is hereby 6 | granted, provided that the above copyright notice appear in all 7 | copies and that both that the copyright notice and this 8 | permission notice and warranty disclaimer appear in supporting 9 | documentation, and that the names of Bell Laboratories or Lucent 10 | Technologies or any of their entities not be used in advertising 11 | or publicity pertaining to distribution of the software without 12 | specific, written prior permission. 13 | 14 | Lucent disclaims all warranties with regard to this software, 15 | including all implied warranties of merchantability and fitness. 16 | In no event shall Lucent be liable for any special, indirect or 17 | consequential damages or any damages whatsoever resulting from 18 | loss of use, data or profits, whether in an action of contract, 19 | negligence or other tortious action, arising out of or in 20 | connection with the use or performance of this software. 21 | ****************************************************************/ 22 | 23 | /* Source for a "getopt" command, as invoked by the "fc" script. */ 24 | 25 | #include 26 | 27 | static char opts[256]; /* assume 8-bit bytes */ 28 | 29 | int 30 | #ifdef KR_headers 31 | main(argc, argv) int argc; char **argv; 32 | #else 33 | main(int argc, char **argv) 34 | #endif 35 | { 36 | char **av, *fmt, *s, *s0; 37 | int i; 38 | 39 | if (argc < 2) { 40 | fprintf(stderr, "Usage: getopt optstring arg1 arg2...\n"); 41 | return 1; 42 | } 43 | for(s = argv[1]; *s; ) { 44 | i = *(unsigned char *)s++; 45 | if (!opts[i]) 46 | opts[i] = 1; 47 | if (*s == ':') { 48 | s++; 49 | opts[i] = 2; 50 | } 51 | } 52 | /* scan for legal args */ 53 | av = argv + 2; 54 | nextarg: 55 | while(s = *av++) { 56 | if (*s++ != '-' || s[0] == '-' && s[1] == 0) 57 | break; 58 | while(i = *(unsigned char *)s++) { 59 | switch(opts[i]) { 60 | case 0: 61 | fprintf(stderr, 62 | "getopt: Illegal option -- %c\n", s[-1]); 63 | return 1; 64 | case 2: 65 | s0 = s - 1; 66 | if (*s || *av++) 67 | goto nextarg; 68 | fprintf(stderr, 69 | "getopt: Option requires an argument -- %c\n", 70 | *s0); 71 | return 1; 72 | } 73 | } 74 | } 75 | /* output modified args */ 76 | av = argv + 2; 77 | fmt = "-%c"; 78 | nextarg1: 79 | while(s = *av++) { 80 | if (s[0] != '-') 81 | break; 82 | if (*++s == '-' && !s[1]) { 83 | s = *av++; 84 | break; 85 | } 86 | while(*s) { 87 | printf(fmt, *s); 88 | fmt = " -%c"; 89 | if (opts[*(unsigned char *)s++] == 2) { 90 | if (!*s) 91 | s = *av++; 92 | printf(" %s", s); 93 | goto nextarg1; 94 | } 95 | } 96 | } 97 | printf(*fmt == ' ' ? " --" : "--"); 98 | for(; s; s = *av++) 99 | printf(" %s", s); 100 | printf("\n"); 101 | return 0; 102 | } 103 | -------------------------------------------------------------------------------- /src/Notice: -------------------------------------------------------------------------------- 1 | /**************************************************************** 2 | Copyright 1990 - 1997 by AT&T, Lucent Technologies and Bellcore. 3 | 4 | Permission to use, copy, modify, and distribute this software 5 | and its documentation for any purpose and without fee is hereby 6 | granted, provided that the above copyright notice appear in all 7 | copies and that both that the copyright notice and this 8 | permission notice and warranty disclaimer appear in supporting 9 | documentation, and that the names of AT&T, Bell Laboratories, 10 | Lucent or Bellcore or any of their entities not be used in 11 | advertising or publicity pertaining to distribution of the 12 | software without specific, written prior permission. 13 | 14 | AT&T, Lucent and Bellcore disclaim all warranties with regard to 15 | this software, including all implied warranties of 16 | merchantability and fitness. In no event shall AT&T, Lucent or 17 | Bellcore be liable for any special, indirect or consequential 18 | damages or any damages whatsoever resulting from loss of use, 19 | data or profits, whether in an action of contract, negligence or 20 | other tortious action, arising out of or in connection with the 21 | use or performance of this software. 22 | ****************************************************************/ 23 | 24 | -------------------------------------------------------------------------------- /src/README: -------------------------------------------------------------------------------- 1 | To compile f2c on Linux or Unix systems, copy makefile.u to makefile, 2 | edit makefile if necessary (see the comments in it and below) and 3 | type "make" (or maybe "nmake", depending on your system). 4 | 5 | To compile f2c.exe on MS Windows systems with Microsoft Visual C++, 6 | 7 | copy makefile.vc makefile 8 | nmake 9 | 10 | With other PC compilers, you may need to compile xsum.c with -DMSDOS 11 | (i.e., with MSDOS #defined). 12 | 13 | If your compiler does not understand ANSI/ISO C syntax (i.e., if 14 | you have a K&R C compiler), compile with -DKR_headers . 15 | 16 | On non-Unix systems where files have separate binary and text modes, 17 | you may need to "make xsumr.out" rather than "make xsum.out". 18 | 19 | If (in accordance with what follows) you need to any of the source 20 | files (excluding the makefile), first issue a "make xsum.out" (or, if 21 | appropriate, "make xsumr.out") to check the validity of the f2c source, 22 | then make your changes, then type "make f2c". 23 | 24 | The file usignal.h is for the benefit of strictly ANSI include files 25 | on a UNIX system -- the ANSI signal.h does not define SIGHUP or SIGQUIT. 26 | You may need to modify usignal.h if you are not running f2c on a UNIX 27 | system. 28 | 29 | Should you get the message "xsum0.out xsum1.out differ", see what lines 30 | are different (`diff xsum0.out xsum1.out`) and ask netlib 31 | (e.g., netlib@netlib.org) to send you the files in question, 32 | plus the current xsum0.out (which may have changed) "from f2c/src". 33 | For example, if exec.c and expr.c have incorrect check sums, you would 34 | send netlib the message 35 | send exec.c expr.c xsum0.out from f2c/src 36 | You can also ftp these files from netlib.bell-labs.com; for more 37 | details, ask netlib@netlib.org to "send readme from f2c". 38 | 39 | On some systems, the malloc and free in malloc.c let f2c run faster 40 | than do the standard malloc and free. Other systems may not tolerate 41 | redefinition of malloc and free (though changes of 8 Nov. 1994 may 42 | render this less of a problem than hitherto). If your system permits 43 | use of a user-supplied malloc, you may wish to change the MALLOC = 44 | line in the makefile to "MALLOC = malloc.o", or to type 45 | make MALLOC=malloc.o 46 | instead of 47 | make 48 | Still other systems have a -lmalloc that provides performance 49 | competitive with that from malloc.c; you may wish to compare the two 50 | on your system. If your system does not permit user-supplied malloc 51 | routines, then f2c may fault with "MALLOC=malloc.o", or may display 52 | other untoward behavior. 53 | 54 | On some BSD systems, you may need to create a file named "string.h" 55 | whose single line is 56 | #include 57 | you may need to add " -Dstrchr=index" to the "CFLAGS =" assignment 58 | in the makefile, and you may need to add " memset.o" to the "OBJECTS =" 59 | assignment in the makefile -- see the comments in memset.c . 60 | 61 | For non-UNIX systems, you may need to change some things in sysdep.c, 62 | such as the choice of intermediate file names. 63 | 64 | On some systems, you may need to modify parts of sysdep.h (which is 65 | included by defs.h). In particular, for Sun 4.1 systems and perhaps 66 | some others, you need to comment out the typedef of size_t. For some 67 | systems (e.g., IRIX 4.0.1 and AIX) it is better to add 68 | #define ANSI_Libraries 69 | to the beginning of sysdep.h (or to supply -DANSI_Libraries in the 70 | makefile). 71 | 72 | Alas, some systems #define __STDC__ but do not provide a true standard 73 | (ANSI or ISO) C environment, e.g., do not provide stdlib.h . If yours 74 | is such a system, then (a) you should complain loudly to your vendor 75 | about __STDC__ being erroneously defined, and (b) you should insert 76 | #undef __STDC__ 77 | at the beginning of sysdep.h . You may need to make other adjustments. 78 | 79 | For some non-ANSI versions of stdio, you must change the values given 80 | to binread and binwrite in sysdep.c from "rb" and "wb" to "r" and "w". 81 | You may need to make this change if you run f2c and get an error 82 | message of the form 83 | Compiler error ... cannot open intermediate file ... 84 | 85 | In the days of yore, two libraries, libF77 and libI77, were used with 86 | f77 (the Fortran compiler on which f2c is based). Separate source for 87 | these libraries is still available from netlib, but it is more 88 | convenient to combine them into a single library, libf2c. Source for 89 | this combined library is also available from netlib in f2c/libf2c.zip, 90 | e.g., 91 | http://netlib.bell-labs.com/netlib/f2c/libf2c.zip 92 | or 93 | http://www.netlib.org/f2c/libf2c.zip 94 | 95 | (and similarly for other netlib mirrors). After unzipping libf2c.zip, 96 | copy the relevant makefile.* to makefile, edit makefile if necessary 97 | (see the comments in it and in libf2c/README) and invoke "make" or 98 | "nmake". The resulting library is called *f2c.lib on MS Windows 99 | systems and libf2c.a or libf2c.so on Linux and Unix systems; 100 | makefile.u just shows how to make libf2c.a. Details on creating the 101 | shared-library variant, libf2c.so, are system-dependent; some that 102 | have worked under Linux appear below. For some other systems, you can 103 | glean the details from the system-dependent makefile variants in 104 | directory http://www.netlib.org/ampl/solvers/funclink or 105 | http://netlib.bell-labs.com/netlib/ampl/solvers/funclink, etc. 106 | 107 | In general, under Linux it is necessary to compile libf2c (or libI77) 108 | with -DNON_UNIX_STDIO . Under at least one variant of Linux, you can 109 | make and install a shared-library version of libf2c by compiling 110 | libI77 with -DNON_UNIX_STDIO, creating libf2c.a as above, and then 111 | executing 112 | 113 | mkdir t 114 | ln lib?77/*.o t 115 | cd t; cc -shared -o ../libf2c.so -Wl,-soname,libf2c.so.1 *.o 116 | cd .. 117 | rm -r t 118 | rm /usr/lib/libf2c* 119 | mv libf2c.a libf2c.so /usr/lib 120 | cd /usr/lib 121 | ln libf2c.so libf2c.so.1 122 | ln libf2c.so libf2c.so.1.0.0 123 | 124 | On some other systems, /usr/local/lib is the appropriate installation 125 | directory. 126 | 127 | 128 | Some older C compilers object to 129 | typedef void (*foo)(); 130 | or to 131 | typedef void zap; 132 | zap (*foo)(); 133 | If yours is such a compiler, change the definition of VOID in 134 | f2c.h from void to int. 135 | 136 | For convenience with systems that use control-Z to denote end-of-file, 137 | f2c treats control-Z characters (ASCII 26, '\x1a') that appear at the 138 | beginning of a line as an end-of-file indicator. You can disable this 139 | test by compiling lex.c with NO_EOF_CHAR_CHECK #defined, or can 140 | change control-Z to some other character by #defining EOF_CHAR to 141 | be the desired value. 142 | 143 | 144 | If your machine has IEEE, VAX, or IBM-mainframe arithmetic, but your 145 | printf is inaccurate (e.g., with Symantec C++ version 6.0, 146 | printf("%.17g",12.) prints 12.000000000000001), you can make f2c print 147 | correctly rounded numbers by compiling with -DUSE_DTOA and adding 148 | dtoa.o g_fmt.o to the makefile's OBJECTS = line, so it becomes 149 | 150 | OBJECTS = $(OBJECTSd) malloc.o dtoa.o g_fmt.o 151 | 152 | Also add the rule 153 | 154 | dtoa.o: dtoa.c 155 | $(CC) -c $(CFLAGS) -DMALLOC=ckalloc -DIEEE... dtoa.c 156 | 157 | (without the initial tab) to the makefile, where IEEE... is one of 158 | IEEE_MC68k, IEEE_8087, VAX, or IBM, depending on your machine's 159 | arithmetic. See the comments near the start of dtoa.c. 160 | 161 | The relevant source files, dtoa.c and g_fmt.c, are available 162 | separately from netlib's fp directory. For example, you could 163 | send the E-mail message 164 | 165 | send dtoa.c g_fmt.c from fp 166 | 167 | to netlib@netlib.netlib.org (or use anonymous ftp from 168 | ftp.netlib.org and look in directory /netlib/fp). 169 | 170 | The makefile has a rule for creating tokdefs.h. If you cannot use the 171 | makefile, an alternative is to extract tokdefs.h from the beginning of 172 | gram.c: it's the first 100 lines. 173 | 174 | File mem.c has #ifdef CRAY lines that are appropriate for machines 175 | with the conventional CRAY architecture, but not for "Cray" machines 176 | based on DEC Alpha chips, such as the T3E; on such machines, you may 177 | need to make a suitable adjustment, e.g., add #undef CRAY to sysdep.h. 178 | 179 | Fortran 77 assumes variables of type INTEGER and REAL occupy the same 180 | storage and that a DOUBLE PRECISION or COMPLEX variable occupies twice 181 | this storage. The types in f2c.h need to reflect these assumptions, 182 | at least when EQUIVALENCE is involved. As of 2021, most modern C and 183 | C++ compilers make "int" a four-byte type, i.e., (in C notation) 184 | sizeof(int) == 4. Some make sizeof(long) == 4, others make 185 | sizeof(long) == 8. (With the compiler originally used for f2c, 186 | sizeof(int) == 2 and sizeof(long) == 4.) For compilers having 187 | sizeof(int) == 4 and sizeof(long) == 8, in f2c.h it suffices to change 188 | "long int" to "int" and is safe to change "#ifdef INTEGER_STAR_8" to 189 | "#if 1". 190 | 191 | 192 | Please send bug reports to dmg at acm.org (with " at " changed to "@"). 193 | The old index file (now called "readme" due to unfortunate changes in 194 | netlib conventions: "send readme from f2c") will report recent 195 | changes in the recent-change log at its end; all changes will be shown 196 | in the "changes" file ("send changes from f2c"). To keep current 197 | source, you will need to request xsum0.out and version.c, in addition 198 | to the changed source files. 199 | -------------------------------------------------------------------------------- /src/cds.c: -------------------------------------------------------------------------------- 1 | /**************************************************************** 2 | Copyright 1990, 1993, 1994, 2000 by AT&T, Lucent Technologies and Bellcore. 3 | 4 | Permission to use, copy, modify, and distribute this software 5 | and its documentation for any purpose and without fee is hereby 6 | granted, provided that the above copyright notice appear in all 7 | copies and that both that the copyright notice and this 8 | permission notice and warranty disclaimer appear in supporting 9 | documentation, and that the names of AT&T, Bell Laboratories, 10 | Lucent or Bellcore or any of their entities not be used in 11 | advertising or publicity pertaining to distribution of the 12 | software without specific, written prior permission. 13 | 14 | AT&T, Lucent and Bellcore disclaim all warranties with regard to 15 | this software, including all implied warranties of 16 | merchantability and fitness. In no event shall AT&T, Lucent or 17 | Bellcore be liable for any special, indirect or consequential 18 | damages or any damages whatsoever resulting from loss of use, 19 | data or profits, whether in an action of contract, negligence or 20 | other tortious action, arising out of or in connection with the 21 | use or performance of this software. 22 | ****************************************************************/ 23 | 24 | /* Put strings representing decimal floating-point numbers 25 | * into canonical form: always have a decimal point or 26 | * exponent field; if using an exponent field, have the 27 | * number before it start with a digit and decimal point 28 | * (if the number has more than one digit); only have an 29 | * exponent field if it saves space. 30 | * 31 | * Arrange that the return value, rv, satisfies rv[0] == '-' || rv[-1] == '-' . 32 | */ 33 | 34 | #include "defs.h" 35 | 36 | char * 37 | #ifdef KR_headers 38 | cds(s, z0) 39 | char *s; 40 | char *z0; 41 | #else 42 | cds(char *s, char *z0) 43 | #endif 44 | { 45 | int ea, esign, et, i, k, nd = 0, sign = 0, tz; 46 | char c, *z; 47 | char ebuf[24]; 48 | long ex = 0; 49 | static char etype[Table_size], *db; 50 | static int dblen = 64; 51 | 52 | if (!db) { 53 | etype['E'] = 1; 54 | etype['e'] = 1; 55 | etype['D'] = 1; 56 | etype['d'] = 1; 57 | etype['+'] = 2; 58 | etype['-'] = 3; 59 | db = Alloc(dblen); 60 | } 61 | 62 | while((c = *s++) == '0'); 63 | if (c == '-') 64 | { sign = 1; c = *s++; } 65 | else if (c == '+') 66 | c = *s++; 67 | k = strlen(s) + 2; 68 | if (k >= dblen) { 69 | do dblen <<= 1; 70 | while(k >= dblen); 71 | free(db); 72 | db = Alloc(dblen); 73 | } 74 | if (etype[(unsigned char)c] >= 2) 75 | while(c == '0') c = *s++; 76 | tz = 0; 77 | while(c >= '0' && c <= '9') { 78 | if (c == '0') 79 | tz++; 80 | else { 81 | if (nd) 82 | for(; tz; --tz) 83 | db[nd++] = '0'; 84 | else 85 | tz = 0; 86 | db[nd++] = c; 87 | } 88 | c = *s++; 89 | } 90 | ea = -tz; 91 | if (c == '.') { 92 | while((c = *s++) >= '0' && c <= '9') { 93 | if (c == '0') 94 | tz++; 95 | else { 96 | if (tz) { 97 | ea += tz; 98 | if (nd) 99 | for(; tz; --tz) 100 | db[nd++] = '0'; 101 | else 102 | tz = 0; 103 | } 104 | db[nd++] = c; 105 | ea++; 106 | } 107 | } 108 | } 109 | if (et = etype[(unsigned char)c]) { 110 | esign = et == 3; 111 | c = *s++; 112 | if (et == 1) { 113 | if(etype[(unsigned char)c] > 1) { 114 | if (c == '-') 115 | esign = 1; 116 | c = *s++; 117 | } 118 | } 119 | while(c >= '0' && c <= '9') { 120 | ex = 10*ex + (c - '0'); 121 | c = *s++; 122 | } 123 | if (esign) 124 | ex = -ex; 125 | } 126 | switch(c) { 127 | case 0: 128 | break; 129 | #ifndef VAX 130 | case 'i': 131 | case 'I': 132 | Fatal("Overflow evaluating constant expression."); 133 | case 'n': 134 | case 'N': 135 | Fatal("Constant expression yields NaN."); 136 | #endif 137 | default: 138 | Fatal("unexpected character in cds."); 139 | } 140 | ex -= ea; 141 | if (!nd) { 142 | if (!z0) 143 | z0 = mem(4,0); 144 | strcpy(z0, "-0."); 145 | /* sign = 0; */ /* 20010820: preserve sign of 0. */ 146 | } 147 | else if (ex > 2 || ex + nd < -2) { 148 | sprintf(ebuf, "%ld", ex + nd - 1); 149 | k = strlen(ebuf) + nd + 3; 150 | if (nd > 1) 151 | k++; 152 | if (!z0) 153 | z0 = mem(k,0); 154 | z = z0; 155 | *z++ = '-'; 156 | *z++ = *db; 157 | if (nd > 1) { 158 | *z++ = '.'; 159 | for(k = 1; k < nd; k++) 160 | *z++ = db[k]; 161 | } 162 | *z++ = 'e'; 163 | strcpy(z, ebuf); 164 | } 165 | else { 166 | k = (int)(ex + nd); 167 | i = nd + 3; 168 | if (k < 0) 169 | i -= k; 170 | else if (ex > 0) 171 | i += (int)ex; 172 | if (!z0) 173 | z0 = mem(i,0); 174 | z = z0; 175 | *z++ = '-'; 176 | if (ex >= 0) { 177 | for(k = 0; k < nd; k++) 178 | *z++ = db[k]; 179 | while(--ex >= 0) 180 | *z++ = '0'; 181 | *z++ = '.'; 182 | } 183 | else { 184 | for(i = 0; i < k;) 185 | *z++ = db[i++]; 186 | *z++ = '.'; 187 | while(++k <= 0) 188 | *z++ = '0'; 189 | while(i < nd) 190 | *z++ = db[i++]; 191 | } 192 | *z = 0; 193 | } 194 | return sign ? z0 : z0+1; 195 | } 196 | -------------------------------------------------------------------------------- /src/defines.h: -------------------------------------------------------------------------------- 1 | #define PDP11 4 2 | 3 | #define BIGGEST_CHAR 0x7f /* Assumes 32-bit arithmetic */ 4 | #define BIGGEST_SHORT 0x7fff /* Assumes 32-bit arithmetic */ 5 | #define BIGGEST_LONG 0x7fffffff /* Assumes 32-bit arithmetic */ 6 | 7 | #define M(x) (1<tag==TCONST && ISINT(z->constblock.vtype)) 282 | #define ISLOGICAL(z) ONEOF(z, MSKLOGICAL) 283 | 284 | /* ISCHAR assumes that z has some kind of structure, i.e. is not null */ 285 | 286 | #define ISCHAR(z) (z->headblock.vtype==TYCHAR) 287 | #define ISINT(z) ONEOF(z, MSKINT) /* z is a tag, i.e. a mask number */ 288 | #define ISCONST(z) (z->tag==TCONST) 289 | #define ISERROR(z) (z->tag==TERROR) 290 | #define ISPLUSOP(z) (z->tag==TEXPR && z->exprblock.opcode==OPPLUS) 291 | #define ISSTAROP(z) (z->tag==TEXPR && z->exprblock.opcode==OPSTAR) 292 | #define ISONE(z) (ISICON(z) && z->constblock.Const.ci==1) 293 | #define INT(z) ONEOF(z, MSKINT|MSKCHAR) /* has INT storage in real life */ 294 | #define ICON(z) mkintcon( (ftnint)(z) ) 295 | 296 | /* NO66 -- F77 feature is being used 297 | NOEXT -- F77 extension is being used */ 298 | 299 | #define NO66(s) if(no66flag) err66(s) 300 | #define NOEXT(s) if(noextflag) errext(s) 301 | -------------------------------------------------------------------------------- /src/equiv.c: -------------------------------------------------------------------------------- 1 | /**************************************************************** 2 | Copyright 1990, 1993-6, 2000 by AT&T, Lucent Technologies and Bellcore. 3 | 4 | Permission to use, copy, modify, and distribute this software 5 | and its documentation for any purpose and without fee is hereby 6 | granted, provided that the above copyright notice appear in all 7 | copies and that both that the copyright notice and this 8 | permission notice and warranty disclaimer appear in supporting 9 | documentation, and that the names of AT&T, Bell Laboratories, 10 | Lucent or Bellcore or any of their entities not be used in 11 | advertising or publicity pertaining to distribution of the 12 | software without specific, written prior permission. 13 | 14 | AT&T, Lucent and Bellcore disclaim all warranties with regard to 15 | this software, including all implied warranties of 16 | merchantability and fitness. In no event shall AT&T, Lucent or 17 | Bellcore be liable for any special, indirect or consequential 18 | damages or any damages whatsoever resulting from loss of use, 19 | data or profits, whether in an action of contract, negligence or 20 | other tortious action, arising out of or in connection with the 21 | use or performance of this software. 22 | ****************************************************************/ 23 | 24 | #include "defs.h" 25 | 26 | static void eqvcommon Argdcl((struct Equivblock*, int, long int)); 27 | static void eqveqv Argdcl((int, int, long int)); 28 | static int nsubs Argdcl((struct Listblock*)); 29 | 30 | /* ROUTINES RELATED TO EQUIVALENCE CLASS PROCESSING */ 31 | 32 | /* called at end of declarations section to process chains 33 | created by EQUIVALENCE statements 34 | */ 35 | void 36 | doequiv(Void) 37 | { 38 | register int i; 39 | int inequiv; /* True if one namep occurs in 40 | several EQUIV declarations */ 41 | int comno; /* Index into Extsym table of the last 42 | COMMON block seen (implicitly assuming 43 | that only one will be given) */ 44 | int ovarno; 45 | ftnint comoffset; /* Index into the COMMON block */ 46 | ftnint offset; /* Offset from array base */ 47 | ftnint leng; 48 | register struct Equivblock *equivdecl; 49 | register struct Eqvchain *q; 50 | struct Primblock *primp; 51 | register Namep np; 52 | int k, k1, ns, pref, t; 53 | chainp cp; 54 | extern int type_pref[]; 55 | 56 | for(i = 0 ; i < nequiv ; ++i) 57 | { 58 | 59 | /* Handle each equivalence declaration */ 60 | 61 | equivdecl = &eqvclass[i]; 62 | equivdecl->eqvbottom = equivdecl->eqvtop = 0; 63 | comno = -1; 64 | 65 | 66 | 67 | for(q = equivdecl->equivs ; q ; q = q->eqvnextp) 68 | { 69 | offset = 0; 70 | if (!(primp = q->eqvitem.eqvlhs)) 71 | continue; 72 | vardcl(np = primp->namep); 73 | if(primp->argsp || primp->fcharp) 74 | { 75 | expptr offp; 76 | 77 | /* Pad ones onto the end of an array declaration when needed */ 78 | 79 | if(np->vdim!=NULL && np->vdim->ndim>1 && 80 | nsubs(primp->argsp)==1 ) 81 | { 82 | if(! ftn66flag) 83 | warni 84 | ("1-dim subscript in EQUIVALENCE, %d-dim declared", 85 | np -> vdim -> ndim); 86 | cp = NULL; 87 | ns = np->vdim->ndim; 88 | while(--ns > 0) 89 | cp = mkchain((char *)ICON(1), cp); 90 | primp->argsp->listp->nextp = cp; 91 | } 92 | 93 | offp = suboffset(primp); 94 | if(ISICON(offp)) 95 | offset = offp->constblock.Const.ci; 96 | else { 97 | dclerr 98 | ("nonconstant subscript in equivalence ", 99 | np); 100 | np = NULL; 101 | } 102 | frexpr(offp); 103 | } 104 | 105 | /* Free up the primblock, since we now have a hash table (Namep) entry */ 106 | 107 | frexpr((expptr)primp); 108 | 109 | if(np && (leng = iarrlen(np))<0) 110 | { 111 | dclerr("adjustable in equivalence", np); 112 | np = NULL; 113 | } 114 | 115 | if(np) switch(np->vstg) 116 | { 117 | case STGUNKNOWN: 118 | case STGBSS: 119 | case STGEQUIV: 120 | break; 121 | 122 | case STGCOMMON: 123 | 124 | /* The code assumes that all COMMON references in a given EQUIVALENCE will 125 | be to the same COMMON block, and will all be consistent */ 126 | 127 | comno = np->vardesc.varno; 128 | comoffset = np->voffset + offset; 129 | break; 130 | 131 | default: 132 | dclerr("bad storage class in equivalence", np); 133 | np = NULL; 134 | break; 135 | } 136 | 137 | if(np) 138 | { 139 | q->eqvoffset = offset; 140 | 141 | /* eqvbottom gets the largest difference between the array base address 142 | and the address specified in the EQUIV declaration */ 143 | 144 | equivdecl->eqvbottom = 145 | lmin(equivdecl->eqvbottom, -offset); 146 | 147 | /* eqvtop gets the largest difference between the end of the array and 148 | the address given in the EQUIVALENCE */ 149 | 150 | equivdecl->eqvtop = 151 | lmax(equivdecl->eqvtop, leng-offset); 152 | } 153 | q->eqvitem.eqvname = np; 154 | } 155 | 156 | /* Now all equivalenced variables are in the hash table with the proper 157 | offset, and eqvtop and eqvbottom are set. */ 158 | 159 | if(comno >= 0) 160 | 161 | /* Get rid of all STGEQUIVS, they will be mapped onto STGCOMMON variables 162 | */ 163 | 164 | eqvcommon(equivdecl, comno, comoffset); 165 | else for(q = equivdecl->equivs ; q ; q = q->eqvnextp) 166 | { 167 | if(np = q->eqvitem.eqvname) 168 | { 169 | inequiv = NO; 170 | if(np->vstg==STGEQUIV) 171 | if( (ovarno = np->vardesc.varno) == i) 172 | { 173 | 174 | /* Can't EQUIV different elements of the same array */ 175 | 176 | if(np->voffset + q->eqvoffset != 0) 177 | dclerr 178 | ("inconsistent equivalence", np); 179 | } 180 | else { 181 | offset = np->voffset; 182 | inequiv = YES; 183 | } 184 | 185 | np->vstg = STGEQUIV; 186 | np->vardesc.varno = i; 187 | np->voffset = - q->eqvoffset; 188 | 189 | if(inequiv) 190 | 191 | /* Combine 2 equivalence declarations */ 192 | 193 | eqveqv(i, ovarno, q->eqvoffset + offset); 194 | } 195 | } 196 | } 197 | 198 | /* Now each equivalence declaration is distinct (all connections have been 199 | merged in eqveqv()), and some may be empty. */ 200 | 201 | for(i = 0 ; i < nequiv ; ++i) 202 | { 203 | equivdecl = & eqvclass[i]; 204 | if(equivdecl->eqvbottom!=0 || equivdecl->eqvtop!=0) { 205 | 206 | /* a live chain */ 207 | 208 | k = TYCHAR; 209 | pref = 1; 210 | for(q = equivdecl->equivs ; q; q = q->eqvnextp) 211 | if ((np = q->eqvitem.eqvname) 212 | && !np->veqvadjust) { 213 | np->veqvadjust = 1; 214 | np->voffset -= equivdecl->eqvbottom; 215 | t = typealign[k1 = np->vtype]; 216 | if (pref < type_pref[k1]) { 217 | k = k1; 218 | pref = type_pref[k1]; 219 | } 220 | if(np->voffset % t != 0) { 221 | dclerr("bad alignment forced by equivalence", np); 222 | --nerr; /* don't give bad return code for this */ 223 | } 224 | } 225 | equivdecl->eqvtype = k; 226 | } 227 | freqchain(equivdecl); 228 | } 229 | } 230 | 231 | 232 | 233 | 234 | 235 | /* put equivalence chain p at common block comno + comoffset */ 236 | 237 | LOCAL void 238 | #ifdef KR_headers 239 | eqvcommon(p, comno, comoffset) 240 | struct Equivblock *p; 241 | int comno; 242 | ftnint comoffset; 243 | #else 244 | eqvcommon(struct Equivblock *p, int comno, ftnint comoffset) 245 | #endif 246 | { 247 | int ovarno; 248 | ftnint k, offq; 249 | register Namep np; 250 | register struct Eqvchain *q; 251 | 252 | if(comoffset + p->eqvbottom < 0) 253 | { 254 | errstr("attempt to extend common %s backward", 255 | extsymtab[comno].fextname); 256 | freqchain(p); 257 | return; 258 | } 259 | 260 | if( (k = comoffset + p->eqvtop) > extsymtab[comno].extleng) 261 | extsymtab[comno].extleng = k; 262 | 263 | 264 | for(q = p->equivs ; q ; q = q->eqvnextp) 265 | if(np = q->eqvitem.eqvname) 266 | { 267 | switch(np->vstg) 268 | { 269 | case STGUNKNOWN: 270 | case STGBSS: 271 | np->vstg = STGCOMMON; 272 | np->vcommequiv = 1; 273 | np->vardesc.varno = comno; 274 | 275 | /* np -> voffset will point to the base of the array */ 276 | 277 | np->voffset = comoffset - q->eqvoffset; 278 | break; 279 | 280 | case STGEQUIV: 281 | ovarno = np->vardesc.varno; 282 | 283 | /* offq will point to the current element, even if it's in an array */ 284 | 285 | offq = comoffset - q->eqvoffset - np->voffset; 286 | np->vstg = STGCOMMON; 287 | np->vcommequiv = 1; 288 | np->vardesc.varno = comno; 289 | 290 | /* np -> voffset will point to the base of the array */ 291 | 292 | np->voffset += offq; 293 | if(ovarno != (p - eqvclass)) 294 | eqvcommon(&eqvclass[ovarno], comno, offq); 295 | break; 296 | 297 | case STGCOMMON: 298 | if(comno != np->vardesc.varno || 299 | comoffset != np->voffset+q->eqvoffset) 300 | dclerr("inconsistent common usage", np); 301 | break; 302 | 303 | 304 | default: 305 | badstg("eqvcommon", np->vstg); 306 | } 307 | } 308 | 309 | freqchain(p); 310 | p->eqvbottom = p->eqvtop = 0; 311 | } 312 | 313 | 314 | /* Move all items on ovarno chain to the front of nvarno chain. 315 | * adjust offsets of ovarno elements and top and bottom of nvarno chain 316 | */ 317 | 318 | LOCAL void 319 | #ifdef KR_headers 320 | eqveqv(nvarno, ovarno, delta) 321 | int nvarno; 322 | int ovarno; 323 | ftnint delta; 324 | #else 325 | eqveqv(int nvarno, int ovarno, ftnint delta) 326 | #endif 327 | { 328 | register struct Equivblock *neweqv, *oldeqv; 329 | register Namep np; 330 | struct Eqvchain *q, *q1; 331 | 332 | neweqv = eqvclass + nvarno; 333 | oldeqv = eqvclass + ovarno; 334 | neweqv->eqvbottom = lmin(neweqv->eqvbottom, oldeqv->eqvbottom - delta); 335 | neweqv->eqvtop = lmax(neweqv->eqvtop, oldeqv->eqvtop - delta); 336 | oldeqv->eqvbottom = oldeqv->eqvtop = 0; 337 | 338 | for(q = oldeqv->equivs ; q ; q = q1) 339 | { 340 | q1 = q->eqvnextp; 341 | if( (np = q->eqvitem.eqvname) && np->vardesc.varno==ovarno) 342 | { 343 | q->eqvnextp = neweqv->equivs; 344 | neweqv->equivs = q; 345 | q->eqvoffset += delta; 346 | np->vardesc.varno = nvarno; 347 | np->voffset -= delta; 348 | } 349 | else free( (charptr) q); 350 | } 351 | oldeqv->equivs = NULL; 352 | } 353 | 354 | 355 | 356 | void 357 | #ifdef KR_headers 358 | freqchain(p) 359 | register struct Equivblock *p; 360 | #else 361 | freqchain(register struct Equivblock *p) 362 | #endif 363 | { 364 | register struct Eqvchain *q, *oq; 365 | 366 | for(q = p->equivs ; q ; q = oq) 367 | { 368 | oq = q->eqvnextp; 369 | free( (charptr) q); 370 | } 371 | p->equivs = NULL; 372 | } 373 | 374 | 375 | 376 | 377 | 378 | /* nsubs -- number of subscripts in this arglist (just the length of the 379 | list) */ 380 | 381 | LOCAL int 382 | #ifdef KR_headers 383 | nsubs(p) 384 | register struct Listblock *p; 385 | #else 386 | nsubs(register struct Listblock *p) 387 | #endif 388 | { 389 | register int n; 390 | register chainp q; 391 | 392 | n = 0; 393 | if(p) 394 | for(q = p->listp ; q ; q = q->nextp) 395 | ++n; 396 | 397 | return(n); 398 | } 399 | 400 | struct Primblock * 401 | #ifdef KR_headers 402 | primchk(e) expptr e; 403 | #else 404 | primchk(expptr e) 405 | #endif 406 | { 407 | if (e->headblock.tag != TPRIM) { 408 | err("Invalid name in EQUIVALENCE."); 409 | return 0; 410 | } 411 | return &e->primblock; 412 | } 413 | -------------------------------------------------------------------------------- /src/error.c: -------------------------------------------------------------------------------- 1 | /**************************************************************** 2 | Copyright 1990, 1993, 1994, 2000 by AT&T, Lucent Technologies and Bellcore. 3 | 4 | Permission to use, copy, modify, and distribute this software 5 | and its documentation for any purpose and without fee is hereby 6 | granted, provided that the above copyright notice appear in all 7 | copies and that both that the copyright notice and this 8 | permission notice and warranty disclaimer appear in supporting 9 | documentation, and that the names of AT&T, Bell Laboratories, 10 | Lucent or Bellcore or any of their entities not be used in 11 | advertising or publicity pertaining to distribution of the 12 | software without specific, written prior permission. 13 | 14 | AT&T, Lucent and Bellcore disclaim all warranties with regard to 15 | this software, including all implied warranties of 16 | merchantability and fitness. In no event shall AT&T, Lucent or 17 | Bellcore be liable for any special, indirect or consequential 18 | damages or any damages whatsoever resulting from loss of use, 19 | data or profits, whether in an action of contract, negligence or 20 | other tortious action, arising out of or in connection with the 21 | use or performance of this software. 22 | ****************************************************************/ 23 | 24 | #include "defs.h" 25 | 26 | void 27 | #ifdef KR_headers 28 | warni(s, t) 29 | char *s; 30 | int t; 31 | #else 32 | warni(char *s, int t) 33 | #endif 34 | { 35 | char buf[100]; 36 | sprintf(buf,s,t); 37 | warn(buf); 38 | } 39 | 40 | void 41 | #ifdef KR_headers 42 | warn1(s, t) 43 | char *s; 44 | char *t; 45 | #else 46 | warn1(const char *s, const char *t) 47 | #endif 48 | { 49 | char buff[100]; 50 | sprintf(buff, s, t); 51 | warn(buff); 52 | } 53 | 54 | void 55 | #ifdef KR_headers 56 | warn(s) 57 | char *s; 58 | #else 59 | warn(char *s) 60 | #endif 61 | { 62 | if(nowarnflag) 63 | return; 64 | if (infname && *infname) 65 | fprintf(diagfile, "Warning on line %ld of %s: %s\n", 66 | lineno, infname, s); 67 | else 68 | fprintf(diagfile, "Warning on line %ld: %s\n", lineno, s); 69 | fflush(diagfile); 70 | ++nwarn; 71 | } 72 | 73 | void 74 | #ifdef KR_headers 75 | errstr(s, t) 76 | char *s; 77 | char *t; 78 | #else 79 | errstr(const char *s, const char *t) 80 | #endif 81 | { 82 | char buff[100]; 83 | sprintf(buff, s, t); 84 | err(buff); 85 | } 86 | 87 | 88 | void 89 | #ifdef KR_headers 90 | erri(s, t) 91 | char *s; 92 | int t; 93 | #else 94 | erri(char *s, int t) 95 | #endif 96 | { 97 | char buff[100]; 98 | sprintf(buff, s, t); 99 | err(buff); 100 | } 101 | 102 | void 103 | #ifdef KR_headers 104 | errl(s, t) 105 | char *s; 106 | long t; 107 | #else 108 | errl(char *s, long t) 109 | #endif 110 | { 111 | char buff[100]; 112 | sprintf(buff, s, t); 113 | err(buff); 114 | } 115 | 116 | char *err_proc = 0; 117 | 118 | void 119 | #ifdef KR_headers 120 | err(s) 121 | char *s; 122 | #else 123 | err(char *s) 124 | #endif 125 | { 126 | if (err_proc) 127 | fprintf(diagfile, 128 | "Error processing %s before line %ld", 129 | err_proc, lineno); 130 | else 131 | fprintf(diagfile, "Error on line %ld", lineno); 132 | if (infname && *infname) 133 | fprintf(diagfile, " of %s", infname); 134 | fprintf(diagfile, ": %s\n", s); 135 | fflush(diagfile); 136 | ++nerr; 137 | } 138 | 139 | void 140 | #ifdef KR_headers 141 | yyerror(s) 142 | char *s; 143 | #else 144 | yyerror(char *s) 145 | #endif 146 | { 147 | err(s); 148 | } 149 | 150 | 151 | void 152 | #ifdef KR_headers 153 | dclerr(s, v) 154 | char *s; 155 | Namep v; 156 | #else 157 | dclerr(const char *s, Namep v) 158 | #endif 159 | { 160 | char buff[100]; 161 | 162 | if(v) 163 | { 164 | sprintf(buff, "Declaration error for %s: %s", v->fvarname, s); 165 | err(buff); 166 | } 167 | else 168 | errstr("Declaration error %s", s); 169 | } 170 | 171 | 172 | void 173 | #ifdef KR_headers 174 | execerr(s, n) 175 | char *s; 176 | char *n; 177 | #else 178 | execerr(char *s, char *n) 179 | #endif 180 | { 181 | char buf1[100], buf2[100]; 182 | 183 | sprintf(buf1, "Execution error %s", s); 184 | sprintf(buf2, buf1, n); 185 | err(buf2); 186 | } 187 | 188 | 189 | void 190 | #ifdef KR_headers 191 | Fatal(t) 192 | char *t; 193 | #else 194 | Fatal(char *t) 195 | #endif 196 | { 197 | fprintf(diagfile, "Compiler error line %ld", lineno); 198 | if (infname) 199 | fprintf(diagfile, " of %s", infname); 200 | fprintf(diagfile, ": %s\n", t); 201 | done(3); 202 | } 203 | 204 | 205 | 206 | void 207 | #ifdef KR_headers 208 | fatalstr(t, s) 209 | char *t; 210 | char *s; 211 | #else 212 | fatalstr(char *t, char *s) 213 | #endif 214 | { 215 | char buff[100]; 216 | sprintf(buff, t, s); 217 | Fatal(buff); 218 | } 219 | 220 | 221 | void 222 | #ifdef KR_headers 223 | fatali(t, d) 224 | char *t; 225 | int d; 226 | #else 227 | fatali(char *t, int d) 228 | #endif 229 | { 230 | char buff[100]; 231 | sprintf(buff, t, d); 232 | Fatal(buff); 233 | } 234 | 235 | 236 | void 237 | #ifdef KR_headers 238 | badthing(thing, r, t) 239 | char *thing; 240 | char *r; 241 | int t; 242 | #else 243 | badthing(char *thing, char *r, int t) 244 | #endif 245 | { 246 | char buff[50]; 247 | sprintf(buff, "Impossible %s %d in routine %s", thing, t, r); 248 | Fatal(buff); 249 | } 250 | 251 | 252 | void 253 | #ifdef KR_headers 254 | badop(r, t) 255 | char *r; 256 | int t; 257 | #else 258 | badop(char *r, int t) 259 | #endif 260 | { 261 | badthing("opcode", r, t); 262 | } 263 | 264 | 265 | void 266 | #ifdef KR_headers 267 | badtag(r, t) 268 | char *r; 269 | int t; 270 | #else 271 | badtag(char *r, int t) 272 | #endif 273 | { 274 | badthing("tag", r, t); 275 | } 276 | 277 | 278 | 279 | 280 | void 281 | #ifdef KR_headers 282 | badstg(r, t) 283 | char *r; 284 | int t; 285 | #else 286 | badstg(char *r, int t) 287 | #endif 288 | { 289 | badthing("storage class", r, t); 290 | } 291 | 292 | 293 | 294 | void 295 | #ifdef KR_headers 296 | badtype(r, t) 297 | char *r; 298 | int t; 299 | #else 300 | badtype(char *r, int t) 301 | #endif 302 | { 303 | badthing("type", r, t); 304 | } 305 | 306 | void 307 | #ifdef KR_headers 308 | many(s, c, n) 309 | char *s; 310 | char c; 311 | int n; 312 | #else 313 | many(char *s, char c, int n) 314 | #endif 315 | { 316 | char buff[250]; 317 | 318 | sprintf(buff, 319 | "Too many %s.\nTable limit now %d.\nTry rerunning with the -N%c%d option.\n", 320 | s, n, c, 2*n); 321 | Fatal(buff); 322 | } 323 | 324 | void 325 | #ifdef KR_headers 326 | err66(s) 327 | char *s; 328 | #else 329 | err66(char *s) 330 | #endif 331 | { 332 | errstr("Fortran 77 feature used: %s", s); 333 | --nerr; 334 | } 335 | 336 | 337 | void 338 | #ifdef KR_headers 339 | errext(s) 340 | char *s; 341 | #else 342 | errext(char *s) 343 | #endif 344 | { 345 | errstr("f2c extension used: %s", s); 346 | --nerr; 347 | } 348 | -------------------------------------------------------------------------------- /src/f2c.1: -------------------------------------------------------------------------------- 1 | 2 | F2C(1) UNIX System V F2C(1) 3 | 4 | NAME 5 | f2c - Convert Fortran 77 to C or C++ 6 | 7 | SYNOPSIS 8 | f2c [ option ... ] file ... 9 | 10 | DESCRIPTION 11 | F2c converts Fortran 77 source code in files with names end- 12 | ing in `.f' or `.F' to C (or C++) source files in the cur- 13 | rent directory, with `.c' substituted for the final `.f' or 14 | `.F'. If no Fortran files are named, f2c reads Fortran from 15 | standard input and writes C on standard output. File names 16 | that end with `.p' or `.P' are taken to be prototype files, 17 | as produced by option `-P', and are read first. 18 | 19 | The following options have the same meaning as in f77(1). 20 | 21 | -C Compile code to check that subscripts are within 22 | declared array bounds. 23 | 24 | -I2 Render INTEGER and LOGICAL as short, INTEGER*4 as long 25 | int. Assume the default libF77 and libI77: allow only 26 | INTEGER*4 (and no LOGICAL) variables in INQUIREs. 27 | Option `-I4' confirms the default rendering of INTEGER 28 | as long int. 29 | 30 | -I8 Assume 8-byte integer and logical, 4-byte REAL, 8-byte 31 | double precison and complex, and 16-byte double complex 32 | variables. Appropriate changes to f2c.h may be needed. 33 | 34 | -Idir 35 | Look for a non-absolute include file first in the 36 | directory of the current input file, then in directo- 37 | ries specified by -I options (one directory per 38 | option). Options -I2, -I4 and -I8 have precedence, so, 39 | e.g., a directory named 2 should be specified by -I./2 . 40 | 41 | -onetrip 42 | Compile DO loops that are performed at least once if 43 | reached. (Fortran 77 DO loops are not performed at all 44 | if the upper limit is smaller than the lower limit.) 45 | 46 | -U Honor the case of variable and external names. Fortran 47 | keywords must be in lower case. 48 | 49 | -u Make the default type of a variable `undefined' rather 50 | than using the default Fortran rules. 51 | 52 | -w Suppress all warning messages, or, if the option is 53 | `-w66', just Fortran 66 compatibility warnings. 54 | 55 | The following options are peculiar to f2c. 56 | 57 | -A Produce ANSI C (default, starting 20020621). For old- 58 | style C, use option -K. 59 | 60 | Page 1 (printed 1/23/24) 61 | 62 | F2C(1) UNIX System V F2C(1) 63 | 64 | -a Make local variables automatic rather than static 65 | unless they appear in a DATA, EQUIVALENCE, NAMELIST, or 66 | SAVE statement. 67 | 68 | -C++ Output C++ code. 69 | 70 | -c Include original Fortran source as comments. 71 | 72 | -cd Do not recognize cdabs, cdcos, cdexp, cdlog, cdsin, and 73 | cdsqrt as synonyms for the double complex intrinsics 74 | zabs, zcos, zexp, zlog, zsin, and zsqrt, respectively, 75 | nor dreal as a synonym for dble. 76 | 77 | -cf Do not report the current .f file except in error messages. 78 | 79 | -ddir 80 | Write `.c' files in directory dir instead of the cur- 81 | rent directory. 82 | 83 | -E Declare uninitialized COMMON to be Extern (overridably 84 | defined in f2c.h as extern). 85 | 86 | -ec Place uninitialized COMMON blocks in separate files: 87 | COMMON /ABC/ appears in file abc_com.c. Option `-e1c' 88 | bundles the separate files into the output file, with 89 | comments that give an unbundling sed(1) script. 90 | 91 | -ext Complain about f77(1) extensions. 92 | 93 | -f Assume free-format input: accept text after column 72 94 | and do not pad fixed-format lines shorter than 72 char- 95 | acters with blanks. 96 | 97 | -72 Treat text appearing after column 72 as an error. 98 | 99 | -g Include original Fortran line numbers in #line lines. 100 | 101 | -h Emulate Fortran 66's treatment of Hollerith: try to 102 | align character strings on word (or, if the option is 103 | `-hd', on double-word) boundaries. 104 | 105 | -i2 Similar to -I2, but assume a modified libF77 and libI77 106 | (compiled with -Df2c_i2), so INTEGER and LOGICAL vari- 107 | ables may be assigned by INQUIRE and array lengths are 108 | stored in short ints. 109 | 110 | -i90 Do not recognize the Fortran 90 bit-manipulation 111 | intrinsics btest, iand, ibclr, ibits, ibset, ieor, ior, 112 | ishft, and ishftc. 113 | 114 | -kr Use temporary values to enforce Fortran expression 115 | evaluation where K&R (first edition) parenthesization 116 | rules allow rearrangement. If the option is `-krd', 117 | use double precision temporaries even for single- 118 | 119 | Page 2 (printed 1/23/24) 120 | 121 | F2C(1) UNIX System V F2C(1) 122 | 123 | precision operands. 124 | 125 | -P Write a file.P of ANSI (or C++) prototypes for defini- 126 | tions in each input file.f or file.F. When reading 127 | Fortran from standard input, write prototypes at the 128 | beginning of standard output. Option -Ps implies -P 129 | and gives exit status 4 if rerunning f2c may change 130 | prototypes or declarations. 131 | 132 | -p Supply preprocessor definitions to make common-block 133 | members look like local variables. 134 | 135 | -R Do not promote REAL functions and operations to DOUBLE 136 | PRECISION. Option `-!R' confirms the default, which 137 | imitates f77. 138 | 139 | -r Cast REAL arguments of intrinsic functions and values 140 | of REAL functions (including intrinsics) to REAL. 141 | 142 | -r8 Promote REAL to DOUBLE PRECISION, COMPLEX to DOUBLE 143 | COMPLEX. 144 | 145 | -s Preserve multidimensional subscripts. Suppressed by 146 | option `-C' . 147 | 148 | -Tdir 149 | Put temporary files in directory dir. 150 | 151 | -trapuv 152 | Dynamically initialize local variables, except those 153 | appearing in SAVE or DATA statements, with values that 154 | may help find references to uninitialized variables. 155 | For example, with IEEE arithmetic, initialize local 156 | floating-point variables to signaling NaNs. 157 | 158 | -w8 Suppress warnings when COMMON or EQUIVALENCE forces 159 | odd-word alignment of doubles. 160 | 161 | -Wn Assume n characters/word (default 4) when initializing 162 | numeric variables with character data. 163 | 164 | -z Do not implicitly recognize DOUBLE COMPLEX. 165 | 166 | -!bs Do not recognize backslash escapes (\", \', \0, \\, \b, 167 | \f, \n, \r, \t, \v) in character strings. 168 | 169 | -!c Inhibit C output, but produce -P output. 170 | 171 | -!I Reject include statements. 172 | 173 | -!i8 Disallow INTEGER*8 , or, if the option is `-!i8const', 174 | permit INTEGER*8 but do not promote integer constants 175 | 176 | Page 3 (printed 1/23/24) 177 | 178 | F2C(1) UNIX System V F2C(1) 179 | 180 | to INTEGER*8 when they involve more than 32 bits. 181 | 182 | -!it Don't infer types of untyped EXTERNAL procedures from 183 | use as parameters to previously defined or prototyped 184 | procedures. 185 | 186 | -!P Do not attempt to infer ANSI or C++ prototypes from 187 | usage. 188 | 189 | The resulting C invokes the support routines of f77; object 190 | code should be loaded by f77 or with ld(1) or cc(1) options 191 | -lF77 -lI77 -lm. Calling conventions are those of f77: see 192 | the reference below. 193 | 194 | FILES 195 | file.[fF] input file 196 | 197 | *.c output file 198 | 199 | /usr/include/f2c.h 200 | header file 201 | 202 | /usr/lib/libF77.aintrinsic function library 203 | 204 | /usr/lib/libI77.aFortran I/O library 205 | 206 | /lib/libc.a C library, see section 3 207 | 208 | SEE ALSO 209 | S. I. Feldman and P. J. Weinberger, `A Portable Fortran 77 210 | Compiler', UNIX Time Sharing System Programmer's Manual, 211 | Tenth Edition, Volume 2, AT&T Bell Laboratories, 1990. 212 | 213 | DIAGNOSTICS 214 | The diagnostics produced by f2c are intended to be self- 215 | explanatory. 216 | 217 | BUGS 218 | Floating-point constant expressions are simplified in the 219 | floating-point arithmetic of the machine running f2c, so 220 | they are typically accurate to at most 16 or 17 decimal 221 | places. 222 | Untypable EXTERNAL functions are declared int. 223 | There is no notation for INTEGER*8 constants. 224 | Some intrinsic functions do not yet work with INTEGER*8 . 225 | 226 | Page 4 (printed 1/23/24) 227 | 228 | -------------------------------------------------------------------------------- /src/f2c.1t: -------------------------------------------------------------------------------- 1 | . \" Definitions of F, L and LR for the benefit of systems 2 | . \" whose -man lacks them... 3 | .de F 4 | .nh 5 | .if n \%\&\\$1 6 | .if t \%\&\f(CW\\$1\fR 7 | .hy 14 8 | .. 9 | .de L 10 | .nh 11 | .if n \%`\\$1' 12 | .if t \%\&\f(CW\\$1\fR 13 | .hy 14 14 | .. 15 | .de LR 16 | .nh 17 | .if n \%`\\$1'\\$2 18 | .if t \%\&\f(CW\\$1\fR\\$2 19 | .hy 14 20 | .. 21 | .TH F2C 1 22 | .CT 1 prog_other 23 | .SH NAME 24 | f2c \- Convert Fortran 77 to C or C++ 25 | . \" f\^2c changed to f2c in the previous line for the benefit of 26 | . \" people on systems (e.g. Sun systems) whose makewhatis cannot 27 | . \" cope with troff formatting commands. 28 | .SH SYNOPSIS 29 | .B f\^2c 30 | [ 31 | .I option ... 32 | ] 33 | .I file ... 34 | .SH DESCRIPTION 35 | .I F2c 36 | converts Fortran 77 source code in 37 | .I files 38 | with names ending in 39 | .L .f 40 | or 41 | .L .F 42 | to C (or C++) source files in the 43 | current directory, with 44 | .L .c 45 | substituted 46 | for the final 47 | .L .f 48 | or 49 | .LR .F . 50 | If no Fortran files are named, 51 | .I f\^2c 52 | reads Fortran from standard input and 53 | writes C on standard output. 54 | .I File 55 | names that end with 56 | .L .p 57 | or 58 | .L .P 59 | are taken to be prototype 60 | files, as produced by option 61 | .LR -P , 62 | and are read first. 63 | .PP 64 | The following options have the same meaning as in 65 | .IR f\^77 (1). 66 | .TP 67 | .B -C 68 | Compile code to check that subscripts are within declared array bounds. 69 | .TP 70 | .B -I2 71 | Render INTEGER and LOGICAL as short, 72 | INTEGER\(**4 as long int. Assume the default \fIlibF77\fR 73 | and \fIlibI77\fR: allow only INTEGER\(**4 (and no LOGICAL) 74 | variables in INQUIREs. Option 75 | .L -I4 76 | confirms the default rendering of INTEGER as long int. 77 | .TP 78 | .B -I8 79 | Assume 8-byte integer and logical, 4-byte REAL, 8-byte double precison 80 | and complex, and 16-byte double complex variables. Appropriate changes 81 | to f2c.h may be needed. 82 | .TP 83 | .BI -I dir 84 | Look for a non-absolute include file first in the directory of the 85 | current input file, then in directories specified by \f(CW-I\fP 86 | options (one directory per option). Options 87 | \f(CW-I2\fP, \f(CW-I4\fP, and \f(CW-I8\fP 88 | have precedence, so, e.g., a directory named \f(CW2\fP 89 | should be specified by \f(CW-I./2\fP . 90 | .TP 91 | .B -onetrip 92 | Compile DO loops that are performed at least once if reached. 93 | (Fortran 77 DO loops are not performed at all if the upper limit is smaller than the lower limit.) 94 | .TP 95 | .B -U 96 | Honor the case of variable and external names. Fortran keywords must be in 97 | .I 98 | lower 99 | case. 100 | .TP 101 | .B -u 102 | Make the default type of a variable `undefined' rather than using the default Fortran rules. 103 | .TP 104 | .B -w 105 | Suppress all warning messages, or, if the option is 106 | .LR -w66 , 107 | just Fortran 66 compatibility warnings. 108 | .PP 109 | The following options are peculiar to 110 | .IR f\^2c . 111 | .TP 112 | .B -A 113 | Produce 114 | .SM ANSI 115 | C (default, starting 20020621). 116 | For old-style C, use option \f(CW-K\fP. 117 | .TP 118 | .B -a 119 | Make local variables automatic rather than static 120 | unless they appear in a 121 | .SM "DATA, EQUIVALENCE, NAMELIST," 122 | or 123 | .SM SAVE 124 | statement. 125 | .TP 126 | .B -C++ 127 | Output C++ code. 128 | .TP 129 | .B -c 130 | Include original Fortran source as comments. 131 | .TP 132 | .B -cd 133 | Do not recognize cdabs, cdcos, cdexp, cdlog, cdsin, and cdsqrt 134 | as synonyms for the double complex intrinsics 135 | zabs, zcos, zexp, zlog, zsin, and zsqrt, respectively, 136 | nor dreal as a synonym for dble. 137 | .TP 138 | .B -cf 139 | Do not report the current \f(CW.f\fP file except in error messages. 140 | .TP 141 | .BI -d dir 142 | Write 143 | .L .c 144 | files in directory 145 | .I dir 146 | instead of the current directory. 147 | .TP 148 | .B -E 149 | Declare uninitialized 150 | .SM COMMON 151 | to be 152 | .B Extern 153 | (overridably defined in 154 | .F f2c.h 155 | as 156 | .B extern). 157 | .TP 158 | .B -ec 159 | Place uninitialized 160 | .SM COMMON 161 | blocks in separate files: 162 | .B COMMON /ABC/ 163 | appears in file 164 | .BR abc_com.c . 165 | Option 166 | .LR -e1c 167 | bundles the separate files 168 | into the output file, with comments that give an unbundling 169 | .IR sed (1) 170 | script. 171 | .TP 172 | .B -ext 173 | Complain about 174 | .IR f\^77 (1) 175 | extensions. 176 | .TP 177 | .B -f 178 | Assume free-format input: accept text after column 72 and do not 179 | pad fixed-format lines shorter than 72 characters with blanks. 180 | .TP 181 | .B -72 182 | Treat text appearing after column 72 as an error. 183 | .TP 184 | .B -g 185 | Include original Fortran line numbers in \f(CW#line\fR lines. 186 | .TP 187 | .B -h 188 | Emulate Fortran 66's treatment of Hollerith: try to align character strings on 189 | word (or, if the option is 190 | .LR -hd , 191 | on double-word) boundaries. 192 | .TP 193 | .B -i2 194 | Similar to 195 | .BR -I2 , 196 | but assume a modified 197 | .I libF77 198 | and 199 | .I libI77 200 | (compiled with 201 | .BR -Df\^2c_i2 ), 202 | so 203 | .SM INTEGER 204 | and 205 | .SM LOGICAL 206 | variables may be assigned by 207 | .SM INQUIRE 208 | and array lengths are stored in short ints. 209 | .TP 210 | .B -i90 211 | Do not recognize the Fortran 90 bit-manipulation intrinsics 212 | btest, iand, ibclr, ibits, ibset, ieor, ior, ishft, and ishftc. 213 | .TP 214 | .B -kr 215 | Use temporary values to enforce Fortran expression evaluation 216 | where K&R (first edition) parenthesization rules allow rearrangement. 217 | If the option is 218 | .LR -krd , 219 | use double precision temporaries even for single-precision operands. 220 | .TP 221 | .B -P 222 | Write a 223 | .IB file .P 224 | of ANSI (or C++) prototypes 225 | for definitions in each input 226 | .IB file .f 227 | or 228 | .IB file .F . 229 | When reading Fortran from standard input, write prototypes 230 | at the beginning of standard output. Option 231 | .B -Ps 232 | implies 233 | .B -P 234 | and gives exit status 4 if rerunning 235 | .I f\^2c 236 | may change prototypes or declarations. 237 | .TP 238 | .B -p 239 | Supply preprocessor definitions to make common-block members 240 | look like local variables. 241 | .TP 242 | .B -R 243 | Do not promote 244 | .SM REAL 245 | functions and operations to 246 | .SM DOUBLE PRECISION. 247 | Option 248 | .L -!R 249 | confirms the default, which imitates 250 | .IR f\^77 . 251 | .TP 252 | .B -r 253 | Cast REAL arguments of intrinsic functions and values of REAL 254 | functions (including intrinsics) to REAL. 255 | .TP 256 | .B -r8 257 | Promote 258 | .SM REAL 259 | to 260 | .SM DOUBLE PRECISION, COMPLEX 261 | to 262 | .SM DOUBLE COMPLEX. 263 | .TP 264 | .B -s 265 | Preserve multidimensional subscripts. Suppressed by option 266 | .L -C 267 | \&. 268 | .TP 269 | .BI -T dir 270 | Put temporary files in directory 271 | .I dir. 272 | .TP 273 | .B -trapuv 274 | Dynamically initialize local variables, except those appearing in 275 | .SM SAVE 276 | or 277 | .SM DATA 278 | statements, with values that may help find references to 279 | uninitialized variables. For example, with IEEE arithmetic, 280 | initialize local floating-point variables to signaling NaNs. 281 | .TP 282 | .B -w8 283 | Suppress warnings when 284 | .SM COMMON 285 | or 286 | .SM EQUIVALENCE 287 | forces odd-word alignment of doubles. 288 | .TP 289 | .BI -W n 290 | Assume 291 | .I n 292 | characters/word (default 4) 293 | when initializing numeric variables with character data. 294 | .TP 295 | .B -z 296 | Do not implicitly recognize 297 | .SM DOUBLE COMPLEX. 298 | .TP 299 | .B -!bs 300 | Do not recognize \fIb\fRack\fIs\fRlash escapes 301 | (\e", \e', \e0, \e\e, \eb, \ef, \en, \er, \et, \ev) in character strings. 302 | .TP 303 | .B -!c 304 | Inhibit C output, but produce 305 | .B -P 306 | output. 307 | .TP 308 | .B -!I 309 | Reject 310 | .B include 311 | statements. 312 | .TP 313 | .B -!i8 314 | Disallow 315 | .SM INTEGER*8 , 316 | or, if the option is 317 | .LR -!i8const , 318 | permit 319 | .SM INTEGER*8 320 | but do not promote integer 321 | constants to 322 | .SM INTEGER*8 323 | when they involve more than 32 bits. 324 | .TP 325 | .B -!it 326 | Don't infer types of untyped 327 | .SM EXTERNAL 328 | procedures from use as parameters to previously defined or prototyped 329 | procedures. 330 | .TP 331 | .B -!P 332 | Do not attempt to infer 333 | .SM ANSI 334 | or C++ 335 | prototypes from usage. 336 | .PP 337 | The resulting C invokes the support routines of 338 | .IR f\^77 ; 339 | object code should be loaded by 340 | .I f\^77 341 | or with 342 | .IR ld (1) 343 | or 344 | .IR cc (1) 345 | options 346 | .BR "-lF77 -lI77 -lm" . 347 | Calling conventions 348 | are those of 349 | .IR f\&77 : 350 | see the reference below. 351 | .br 352 | .SH FILES 353 | .TP 354 | .nr )I 1.75i 355 | .IB file .[fF] 356 | input file 357 | .TP 358 | .B *.c 359 | output file 360 | .TP 361 | .F /usr/include/f2c.h 362 | header file 363 | .TP 364 | .F /usr/lib/libF77.a 365 | intrinsic function library 366 | .TP 367 | .F /usr/lib/libI77.a 368 | Fortran I/O library 369 | .TP 370 | .F /lib/libc.a 371 | C library, see section 3 372 | .SH "SEE ALSO" 373 | S. I. Feldman and 374 | P. J. Weinberger, 375 | `A Portable Fortran 77 Compiler', 376 | \fIUNIX Time Sharing System Programmer's Manual\fR, 377 | Tenth Edition, Volume 2, AT&T Bell Laboratories, 1990. 378 | .SH DIAGNOSTICS 379 | The diagnostics produced by 380 | .I f\^2c 381 | are intended to be 382 | self-explanatory. 383 | .SH BUGS 384 | Floating-point constant expressions are simplified in 385 | the floating-point arithmetic of the machine running 386 | .IR f\^2c , 387 | so they are typically accurate to at most 16 or 17 decimal places. 388 | .br 389 | Untypable 390 | .SM EXTERNAL 391 | functions are declared 392 | .BR int . 393 | .br 394 | There is no notation for 395 | .SM INTEGER*8 396 | constants. 397 | .br 398 | Some intrinsic functions do not yet work with 399 | .SM INTEGER*8 . 400 | -------------------------------------------------------------------------------- /src/f2c.h: -------------------------------------------------------------------------------- 1 | /* f2c.h -- Standard Fortran to C header file */ 2 | 3 | /** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." 4 | 5 | - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ 6 | 7 | #ifndef F2C_INCLUDE 8 | #define F2C_INCLUDE 9 | 10 | typedef int integer; 11 | typedef unsigned int uinteger; 12 | typedef char *address; 13 | typedef short int shortint; 14 | typedef float real; 15 | typedef double doublereal; 16 | typedef struct { real r, i; } complex; 17 | typedef struct { doublereal r, i; } doublecomplex; 18 | typedef int logical; 19 | typedef short int shortlogical; 20 | typedef char logical1; 21 | typedef char integer1; 22 | #if 1 /*ifdef INTEGER_STAR_8*/ /* Adjust for integer*8. */ 23 | typedef long longint; /* system-dependent; long long on some systems */ 24 | typedef unsigned long ulongint; /* system-dependent; long long on some systems */ 25 | #define qbit_clear(a,b) ((a) & ~((ulongint)1 << (b))) 26 | #define qbit_set(a,b) ((a) | ((ulongint)1 << (b))) 27 | #endif 28 | 29 | #define TRUE_ (1) 30 | #define FALSE_ (0) 31 | 32 | /* Extern is for use with -E */ 33 | #ifndef Extern 34 | #define Extern extern 35 | #endif 36 | 37 | /* I/O stuff */ 38 | 39 | #ifdef f2c_i2 40 | /* for -i2 */ 41 | typedef short flag; 42 | typedef short ftnlen; 43 | typedef short ftnint; 44 | #else 45 | typedef int flag; 46 | typedef int ftnlen; 47 | typedef int ftnint; 48 | #endif 49 | 50 | /*external read, write*/ 51 | typedef struct 52 | { flag cierr; 53 | ftnint ciunit; 54 | flag ciend; 55 | char *cifmt; 56 | ftnint cirec; 57 | } cilist; 58 | 59 | /*internal read, write*/ 60 | typedef struct 61 | { flag icierr; 62 | char *iciunit; 63 | flag iciend; 64 | char *icifmt; 65 | ftnint icirlen; 66 | ftnint icirnum; 67 | } icilist; 68 | 69 | /*open*/ 70 | typedef struct 71 | { flag oerr; 72 | ftnint ounit; 73 | char *ofnm; 74 | ftnlen ofnmlen; 75 | char *osta; 76 | char *oacc; 77 | char *ofm; 78 | ftnint orl; 79 | char *oblnk; 80 | } olist; 81 | 82 | /*close*/ 83 | typedef struct 84 | { flag cerr; 85 | ftnint cunit; 86 | char *csta; 87 | } cllist; 88 | 89 | /*rewind, backspace, endfile*/ 90 | typedef struct 91 | { flag aerr; 92 | ftnint aunit; 93 | } alist; 94 | 95 | /* inquire */ 96 | typedef struct 97 | { flag inerr; 98 | ftnint inunit; 99 | char *infile; 100 | ftnlen infilen; 101 | ftnint *inex; /*parameters in standard's order*/ 102 | ftnint *inopen; 103 | ftnint *innum; 104 | ftnint *innamed; 105 | char *inname; 106 | ftnlen innamlen; 107 | char *inacc; 108 | ftnlen inacclen; 109 | char *inseq; 110 | ftnlen inseqlen; 111 | char *indir; 112 | ftnlen indirlen; 113 | char *infmt; 114 | ftnlen infmtlen; 115 | char *inform; 116 | ftnint informlen; 117 | char *inunf; 118 | ftnlen inunflen; 119 | ftnint *inrecl; 120 | ftnint *innrec; 121 | char *inblank; 122 | ftnlen inblanklen; 123 | } inlist; 124 | 125 | #define VOID void 126 | 127 | union Multitype { /* for multiple entry points */ 128 | integer1 g; 129 | shortint h; 130 | integer i; 131 | /* longint j; */ 132 | real r; 133 | doublereal d; 134 | complex c; 135 | doublecomplex z; 136 | }; 137 | 138 | typedef union Multitype Multitype; 139 | 140 | /*typedef int Long;*/ /* No longer used; formerly in Namelist */ 141 | 142 | struct Vardesc { /* for Namelist */ 143 | char *name; 144 | char *addr; 145 | ftnlen *dims; 146 | int type; 147 | }; 148 | typedef struct Vardesc Vardesc; 149 | 150 | struct Namelist { 151 | char *name; 152 | Vardesc **vars; 153 | int nvars; 154 | }; 155 | typedef struct Namelist Namelist; 156 | 157 | #define abs(x) ((x) >= 0 ? (x) : -(x)) 158 | #define dabs(x) (doublereal)abs(x) 159 | #define min(a,b) ((a) <= (b) ? (a) : (b)) 160 | #define max(a,b) ((a) >= (b) ? (a) : (b)) 161 | #define dmin(a,b) (doublereal)min(a,b) 162 | #define dmax(a,b) (doublereal)max(a,b) 163 | #define bit_test(a,b) ((a) >> (b) & 1) 164 | #define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) 165 | #define bit_set(a,b) ((a) | ((uinteger)1 << (b))) 166 | 167 | /* procedure parameter types for -A and -C++ */ 168 | 169 | #define F2C_proc_par_types 1 170 | #ifdef __cplusplus 171 | typedef int /* Unknown procedure type */ (*U_fp)(...); 172 | typedef shortint (*J_fp)(...); 173 | typedef integer (*I_fp)(...); 174 | typedef real (*R_fp)(...); 175 | typedef doublereal (*D_fp)(...), (*E_fp)(...); 176 | typedef /* Complex */ VOID (*C_fp)(...); 177 | typedef /* Double Complex */ VOID (*Z_fp)(...); 178 | typedef logical (*L_fp)(...); 179 | typedef shortlogical (*K_fp)(...); 180 | typedef /* Character */ VOID (*H_fp)(...); 181 | typedef /* Subroutine */ int (*S_fp)(...); 182 | #else 183 | typedef int /* Unknown procedure type */ (*U_fp)(); 184 | typedef shortint (*J_fp)(); 185 | typedef integer (*I_fp)(); 186 | typedef real (*R_fp)(); 187 | typedef doublereal (*D_fp)(), (*E_fp)(); 188 | typedef /* Complex */ VOID (*C_fp)(); 189 | typedef /* Double Complex */ VOID (*Z_fp)(); 190 | typedef logical (*L_fp)(); 191 | typedef shortlogical (*K_fp)(); 192 | typedef /* Character */ VOID (*H_fp)(); 193 | typedef /* Subroutine */ int (*S_fp)(); 194 | #endif 195 | /* E_fp is for real functions when -R is not specified */ 196 | typedef VOID C_f; /* complex function */ 197 | typedef VOID H_f; /* character function */ 198 | typedef VOID Z_f; /* double complex function */ 199 | typedef doublereal E_f; /* real function with -R not specified */ 200 | 201 | /* undef any lower-case symbols that your C compiler predefines, e.g.: */ 202 | 203 | #ifndef Skip_f2c_Undefs 204 | #undef cray 205 | #undef gcos 206 | #undef mc68010 207 | #undef mc68020 208 | #undef mips 209 | #undef pdp11 210 | #undef sgi 211 | #undef sparc 212 | #undef sun 213 | #undef sun2 214 | #undef sun3 215 | #undef sun4 216 | #undef u370 217 | #undef u3b 218 | #undef u3b2 219 | #undef u3b5 220 | #undef unix 221 | #undef vax 222 | #endif 223 | #endif 224 | -------------------------------------------------------------------------------- /src/format.h: -------------------------------------------------------------------------------- 1 | #define DEF_C_LINE_LENGTH 77 2 | /* actual max will be 79 */ 3 | 4 | extern int c_output_line_length; /* max # chars per line in C source 5 | code */ 6 | 7 | chainp data_value Argdcl((FILEP, long int, int)); 8 | int do_init_data Argdcl((FILEP, FILEP)); 9 | void list_init_data Argdcl((FILEP*, char*, FILEP)); 10 | char* wr_ardecls Argdcl((FILEP, struct Dimblock*, long int)); 11 | void wr_one_init Argdcl((FILEP, char*, chainp*, int)); 12 | void wr_output_values Argdcl((FILEP, Namep, chainp)); 13 | -------------------------------------------------------------------------------- /src/ftypes.h: -------------------------------------------------------------------------------- 1 | 2 | /* variable types (stored in the vtype field of expptr) 3 | * numeric assumptions: 4 | * int < reals < complexes 5 | * TYDREAL-TYREAL = TYDCOMPLEX-TYCOMPLEX 6 | */ 7 | 8 | #undef TYQUAD0 9 | #ifdef NO_TYQUAD 10 | #undef TYQUAD 11 | #define TYQUAD_inc 0 12 | #undef NO_LONG_LONG 13 | #define NO_LONG_LONG 14 | #else 15 | #define TYQUAD 5 16 | #define TYQUAD_inc 1 17 | #ifdef NO_LONG_LONG 18 | #define TYQUAD0 19 | #else 20 | #ifndef Llong 21 | typedef long long Llong; 22 | #endif 23 | #ifndef ULlong 24 | typedef unsigned long long ULlong; 25 | #endif 26 | #endif /*NO_LONG_LONG*/ 27 | #endif /*NO_TYQUAD*/ 28 | 29 | #ifdef _WIN64 30 | #define USE_LONGLONG 31 | #endif 32 | 33 | #ifdef USE_LONGLONG 34 | typedef unsigned long long Addr; 35 | #define Addrfmt "%llx" 36 | #define Atol atoll 37 | #else 38 | typedef unsigned long Addr; 39 | #define Addrfmt "%lx" 40 | #define Atol atol 41 | #endif 42 | 43 | #define TYUNKNOWN 0 44 | #define TYADDR 1 45 | #define TYINT1 2 46 | #define TYSHORT 3 47 | #define TYLONG 4 48 | /* #define TYQUAD 5 */ 49 | #define TYREAL (5+TYQUAD_inc) 50 | #define TYDREAL (6+TYQUAD_inc) 51 | #define TYCOMPLEX (7+TYQUAD_inc) 52 | #define TYDCOMPLEX (8+TYQUAD_inc) 53 | #define TYLOGICAL1 (9+TYQUAD_inc) 54 | #define TYLOGICAL2 (10+TYQUAD_inc) 55 | #define TYLOGICAL (11+TYQUAD_inc) 56 | #define TYCHAR (12+TYQUAD_inc) 57 | #define TYSUBR (13+TYQUAD_inc) 58 | #define TYERROR (14+TYQUAD_inc) 59 | #define TYCILIST (15+TYQUAD_inc) 60 | #define TYICILIST (16+TYQUAD_inc) 61 | #define TYOLIST (17+TYQUAD_inc) 62 | #define TYCLLIST (18+TYQUAD_inc) 63 | #define TYALIST (19+TYQUAD_inc) 64 | #define TYINLIST (20+TYQUAD_inc) 65 | #define TYVOID (21+TYQUAD_inc) 66 | #define TYLABEL (22+TYQUAD_inc) 67 | #define TYFTNLEN (23+TYQUAD_inc) 68 | /* TYVOID is not in any tables. */ 69 | 70 | /* NTYPES, NTYPES0 -- Total number of types, used to allocate tables indexed by 71 | type. Such tables can include the size (in bytes) of objects of a given 72 | type, or labels for returning objects of different types from procedures 73 | (see array rtvlabels) */ 74 | 75 | #define NTYPES TYVOID 76 | #define NTYPES0 TYCILIST 77 | #define TYBLANK TYSUBR /* Huh? */ 78 | 79 | -------------------------------------------------------------------------------- /src/gram.dcl: -------------------------------------------------------------------------------- 1 | spec: dcl 2 | | common 3 | | external 4 | | intrinsic 5 | | equivalence 6 | | data 7 | | implicit 8 | | namelist 9 | | SSAVE 10 | { NO66("SAVE statement"); 11 | saveall = YES; } 12 | | SSAVE savelist 13 | { NO66("SAVE statement"); } 14 | | SFORMAT 15 | { fmtstmt(thislabel); setfmt(thislabel); } 16 | | SPARAM in_dcl SLPAR paramlist SRPAR 17 | { NO66("PARAMETER statement"); } 18 | ; 19 | 20 | dcl: type opt_comma name in_dcl new_dcl dims lengspec 21 | { settype($3, $1, $7); 22 | if(ndim>0) setbound($3,ndim,dims); 23 | } 24 | | dcl SCOMMA name dims lengspec 25 | { settype($3, $1, $5); 26 | if(ndim>0) setbound($3,ndim,dims); 27 | } 28 | | dcl SSLASHD datainit vallist SSLASHD 29 | { if (new_dcl == 2) { 30 | err("attempt to give DATA in type-declaration"); 31 | new_dcl = 1; 32 | } 33 | } 34 | ; 35 | 36 | new_dcl: { new_dcl = 2; } ; 37 | 38 | type: typespec lengspec 39 | { varleng = $2; } 40 | ; 41 | 42 | typespec: typename 43 | { varleng = ($1<0 || ONEOF($1,M(TYLOGICAL)|M(TYLONG)) 44 | ? 0 : typesize[$1]); 45 | vartype = $1; } 46 | ; 47 | 48 | typename: SINTEGER { $$ = lasttype = TYLONG; } 49 | | SREAL { $$ = lasttype = tyreal; } 50 | | SCOMPLEX { ++complex_seen; $$ = lasttype = tycomplex; } 51 | | SDOUBLE { $$ = lasttype = TYDREAL; } 52 | | SDCOMPLEX { ++dcomplex_seen; NOEXT("DOUBLE COMPLEX statement"); $$ = lasttype = TYDCOMPLEX; } 53 | | SLOGICAL { $$ = lasttype = TYLOGICAL; } 54 | | SCHARACTER { NO66("CHARACTER statement"); $$ = lasttype = TYCHAR; } 55 | | SUNDEFINED { $$ = TYUNKNOWN; } 56 | | SDIMENSION { $$ = TYUNKNOWN; } 57 | | SAUTOMATIC { NOEXT("AUTOMATIC statement"); $$ = - STGAUTO; } 58 | | SSTATIC { NOEXT("STATIC statement"); $$ = - STGBSS; } 59 | | SBYTE { $$ = TYINT1; } 60 | ; 61 | 62 | lengspec: 63 | { $$ = varleng; } 64 | | SSTAR intonlyon expr intonlyoff 65 | { 66 | expptr p; 67 | p = $3; 68 | NO66("length specification *n"); 69 | if( ! ISICON(p) || p->constblock.Const.ci <= 0 ) 70 | { 71 | $$ = 0; 72 | dclerr("length must be a positive integer constant", 73 | NPNULL); 74 | } 75 | else { 76 | if (vartype == TYCHAR) 77 | $$ = p->constblock.Const.ci; 78 | else switch((int)p->constblock.Const.ci) { 79 | case 1: $$ = 1; break; 80 | case 2: $$ = typesize[TYSHORT]; break; 81 | case 4: $$ = lasttype == TYREAL ? typesize[TYREAL] : typesize[TYLONG]; 82 | break; 83 | case 8: $$ = typesize[TYDREAL]; break; 84 | case 16: $$ = typesize[TYDCOMPLEX]; break; 85 | default: 86 | dclerr("invalid length",NPNULL); 87 | $$ = varleng; 88 | } 89 | } 90 | } 91 | | SSTAR intonlyon SLPAR SSTAR SRPAR intonlyoff 92 | { NO66("length specification *(*)"); $$ = -1; } 93 | ; 94 | 95 | common: SCOMMON in_dcl var 96 | { incomm( $$ = comblock("") , $3 ); } 97 | | SCOMMON in_dcl comblock var 98 | { $$ = $3; incomm($3, $4); } 99 | | common opt_comma comblock opt_comma var 100 | { $$ = $3; incomm($3, $5); } 101 | | common SCOMMA var 102 | { incomm($1, $3); } 103 | ; 104 | 105 | comblock: SCONCAT 106 | { $$ = comblock(""); } 107 | | SSLASH SNAME SSLASH 108 | { $$ = comblock(token); } 109 | ; 110 | 111 | external: SEXTERNAL in_dcl name 112 | { setext($3); } 113 | | external SCOMMA name 114 | { setext($3); } 115 | ; 116 | 117 | intrinsic: SINTRINSIC in_dcl name 118 | { NO66("INTRINSIC statement"); setintr($3); } 119 | | intrinsic SCOMMA name 120 | { setintr($3); } 121 | ; 122 | 123 | equivalence: SEQUIV in_dcl equivset 124 | | equivalence SCOMMA equivset 125 | ; 126 | 127 | equivset: SLPAR equivlist SRPAR 128 | { 129 | struct Equivblock *p; 130 | if(nequiv >= maxequiv) 131 | many("equivalences", 'q', maxequiv); 132 | p = & eqvclass[nequiv++]; 133 | p->eqvinit = NO; 134 | p->eqvbottom = 0; 135 | p->eqvtop = 0; 136 | p->equivs = $2; 137 | } 138 | ; 139 | 140 | equivlist: lhs 141 | { $$=ALLOC(Eqvchain); 142 | $$->eqvitem.eqvlhs = primchk($1); 143 | } 144 | | equivlist SCOMMA lhs 145 | { $$=ALLOC(Eqvchain); 146 | $$->eqvitem.eqvlhs = primchk($3); 147 | $$->eqvnextp = $1; 148 | } 149 | ; 150 | 151 | data: SDATA in_data datalist 152 | | data opt_comma datalist 153 | ; 154 | 155 | in_data: 156 | { if(parstate == OUTSIDE) 157 | { 158 | newproc(); 159 | startproc(ESNULL, CLMAIN); 160 | } 161 | if(parstate < INDATA) 162 | { 163 | enddcl(); 164 | parstate = INDATA; 165 | datagripe = 1; 166 | } 167 | } 168 | ; 169 | 170 | datalist: datainit datavarlist SSLASH datapop vallist SSLASH 171 | { ftnint junk; 172 | if(nextdata(&junk) != NULL) 173 | err("too few initializers"); 174 | frdata($2); 175 | frrpl(); 176 | } 177 | ; 178 | 179 | datainit: /* nothing */ { frchain(&datastack); curdtp = 0; } ; 180 | 181 | datapop: /* nothing */ { pop_datastack(); } ; 182 | 183 | vallist: { toomanyinit = NO; } val 184 | | vallist SCOMMA val 185 | ; 186 | 187 | val: value 188 | { dataval(ENULL, $1); } 189 | | simple SSTAR value 190 | { dataval($1, $3); } 191 | ; 192 | 193 | value: simple 194 | | addop simple 195 | { if( $1==OPMINUS && ISCONST($2) ) 196 | consnegop((Constp)$2); 197 | $$ = $2; 198 | } 199 | | complex_const 200 | ; 201 | 202 | savelist: saveitem 203 | | savelist SCOMMA saveitem 204 | ; 205 | 206 | saveitem: name 207 | { int k; 208 | $1->vsave = YES; 209 | k = $1->vstg; 210 | if( ! ONEOF(k, M(STGUNKNOWN)|M(STGBSS)|M(STGINIT)) ) 211 | dclerr("can only save static variables", $1); 212 | } 213 | | comblock 214 | ; 215 | 216 | paramlist: paramitem 217 | | paramlist SCOMMA paramitem 218 | ; 219 | 220 | paramitem: name SEQUALS expr 221 | { if($1->vclass == CLUNKNOWN) 222 | make_param((struct Paramblock *)$1, $3); 223 | else dclerr("cannot make into parameter", $1); 224 | } 225 | ; 226 | 227 | var: name dims 228 | { if(ndim>0) setbound($1, ndim, dims); } 229 | ; 230 | 231 | datavar: lhs 232 | { Namep np; 233 | struct Primblock *pp = (struct Primblock *)$1; 234 | int tt = $1->tag; 235 | if (tt != TPRIM) { 236 | if (tt == TCONST) 237 | err("parameter in data statement"); 238 | else 239 | erri("tag %d in data statement",tt); 240 | $$ = 0; 241 | err_lineno = lineno; 242 | break; 243 | } 244 | np = pp -> namep; 245 | vardcl(np); 246 | if ((pp->fcharp || pp->lcharp) 247 | && (np->vtype != TYCHAR || np->vdim && !pp->argsp)) 248 | sserr(np); 249 | if(np->vstg == STGCOMMON) 250 | extsymtab[np->vardesc.varno].extinit = YES; 251 | else if(np->vstg==STGEQUIV) 252 | eqvclass[np->vardesc.varno].eqvinit = YES; 253 | else if(np->vstg!=STGINIT && np->vstg!=STGBSS) { 254 | errstr(np->vstg == STGARG 255 | ? "Dummy argument \"%.60s\" in data statement." 256 | : "Cannot give data to \"%.75s\"", 257 | np->fvarname); 258 | $$ = 0; 259 | err_lineno = lineno; 260 | break; 261 | } 262 | $$ = mkchain((char *)$1, CHNULL); 263 | } 264 | | SLPAR datavarlist SCOMMA dospec SRPAR 265 | { chainp p; struct Impldoblock *q; 266 | pop_datastack(); 267 | q = ALLOC(Impldoblock); 268 | q->tag = TIMPLDO; 269 | (q->varnp = (Namep) ($4->datap))->vimpldovar = 1; 270 | p = $4->nextp; 271 | if(p) { q->implb = (expptr)(p->datap); p = p->nextp; } 272 | if(p) { q->impub = (expptr)(p->datap); p = p->nextp; } 273 | if(p) { q->impstep = (expptr)(p->datap); } 274 | frchain( & ($4) ); 275 | $$ = mkchain((char *)q, CHNULL); 276 | q->datalist = hookup($2, $$); 277 | } 278 | ; 279 | 280 | datavarlist: datavar 281 | { if (!datastack) 282 | curdtp = 0; 283 | datastack = mkchain((char *)curdtp, datastack); 284 | curdtp = $1; curdtelt = 0; 285 | } 286 | | datavarlist SCOMMA datavar 287 | { $$ = hookup($1, $3); } 288 | ; 289 | 290 | dims: 291 | { ndim = 0; } 292 | | SLPAR dimlist SRPAR 293 | ; 294 | 295 | dimlist: { ndim = 0; } dim 296 | | dimlist SCOMMA dim 297 | ; 298 | 299 | dim: ubound 300 | { 301 | if(ndim == maxdim) 302 | err("too many dimensions"); 303 | else if(ndim < maxdim) 304 | { dims[ndim].lb = 0; 305 | dims[ndim].ub = $1; 306 | } 307 | ++ndim; 308 | } 309 | | expr SCOLON ubound 310 | { 311 | if(ndim == maxdim) 312 | err("too many dimensions"); 313 | else if(ndim < maxdim) 314 | { dims[ndim].lb = $1; 315 | dims[ndim].ub = $3; 316 | } 317 | ++ndim; 318 | } 319 | ; 320 | 321 | ubound: SSTAR 322 | { $$ = 0; } 323 | | expr 324 | ; 325 | 326 | labellist: label 327 | { nstars = 1; labarray[0] = $1; } 328 | | labellist SCOMMA label 329 | { if(nstars < maxlablist) labarray[nstars++] = $3; } 330 | ; 331 | 332 | label: SICON 333 | { $$ = execlab( convci(toklen, token) ); } 334 | ; 335 | 336 | implicit: SIMPLICIT in_dcl implist 337 | { NO66("IMPLICIT statement"); } 338 | | implicit SCOMMA implist 339 | ; 340 | 341 | implist: imptype SLPAR letgroups SRPAR 342 | | imptype 343 | { if (vartype != TYUNKNOWN) 344 | dclerr("-- expected letter range",NPNULL); 345 | setimpl(vartype, varleng, 'a', 'z'); } 346 | ; 347 | 348 | imptype: { needkwd = 1; } type 349 | /* { vartype = $2; } */ 350 | ; 351 | 352 | letgroups: letgroup 353 | | letgroups SCOMMA letgroup 354 | ; 355 | 356 | letgroup: letter 357 | { setimpl(vartype, varleng, $1, $1); } 358 | | letter SMINUS letter 359 | { setimpl(vartype, varleng, $1, $3); } 360 | ; 361 | 362 | letter: SNAME 363 | { if(toklen!=1 || token[0]<'a' || token[0]>'z') 364 | { 365 | dclerr("implicit item must be single letter", NPNULL); 366 | $$ = 0; 367 | } 368 | else $$ = token[0]; 369 | } 370 | ; 371 | 372 | namelist: SNAMELIST 373 | | namelist namelistentry 374 | ; 375 | 376 | namelistentry: SSLASH name SSLASH namelistlist 377 | { 378 | if($2->vclass == CLUNKNOWN) 379 | { 380 | $2->vclass = CLNAMELIST; 381 | $2->vtype = TYINT; 382 | $2->vstg = STGBSS; 383 | $2->varxptr.namelist = $4; 384 | $2->vardesc.varno = ++lastvarno; 385 | } 386 | else dclerr("cannot be a namelist name", $2); 387 | } 388 | ; 389 | 390 | namelistlist: name 391 | { $$ = mkchain((char *)$1, CHNULL); } 392 | | namelistlist SCOMMA name 393 | { $$ = hookup($1, mkchain((char *)$3, CHNULL)); } 394 | ; 395 | 396 | in_dcl: 397 | { switch(parstate) 398 | { 399 | case OUTSIDE: newproc(); 400 | startproc(ESNULL, CLMAIN); 401 | case INSIDE: parstate = INDCL; 402 | case INDCL: break; 403 | 404 | case INDATA: 405 | if (datagripe) { 406 | errstr( 407 | "Statement order error: declaration after DATA", 408 | CNULL); 409 | datagripe = 0; 410 | } 411 | break; 412 | 413 | default: 414 | dclerr("declaration among executables", NPNULL); 415 | } 416 | } 417 | ; 418 | -------------------------------------------------------------------------------- /src/gram.exec: -------------------------------------------------------------------------------- 1 | exec: iffable 2 | | SDO end_spec label opt_comma dospecw 3 | { 4 | if($3->labdefined) 5 | execerr("no backward DO loops", CNULL); 6 | $3->blklevel = blklevel+1; 7 | exdo($3->labelno, NPNULL, $5); 8 | } 9 | | SDO end_spec opt_comma dospecw 10 | { 11 | exdo((int)(ctls - ctlstack - 2), NPNULL, $4); 12 | NOEXT("DO without label"); 13 | } 14 | | SENDDO 15 | { exenddo(NPNULL); } 16 | | logif iffable 17 | { exendif(); thiswasbranch = NO; } 18 | | logif STHEN 19 | | SELSEIF end_spec SLPAR {westart(1);} expr SRPAR STHEN 20 | { exelif($5); lastwasbranch = NO; } 21 | | SELSE end_spec 22 | { exelse(); lastwasbranch = NO; } 23 | | SENDIF end_spec 24 | { exendif(); lastwasbranch = NO; } 25 | ; 26 | 27 | logif: SLOGIF end_spec SLPAR expr SRPAR 28 | { exif($4); } 29 | ; 30 | 31 | dospec: name SEQUALS exprlist 32 | { $$ = mkchain((char *)$1, $3); } 33 | ; 34 | 35 | dospecw: dospec 36 | | SWHILE {westart(0);} SLPAR expr SRPAR 37 | { $$ = mkchain(CNULL, (chainp)$4); } 38 | ; 39 | 40 | iffable: let lhs SEQUALS expr 41 | { exequals((struct Primblock *)$2, $4); } 42 | | SASSIGN end_spec assignlabel STO name 43 | { exassign($5, $3); } 44 | | SCONTINUE end_spec 45 | | goto 46 | | io 47 | { inioctl = NO; } 48 | | SARITHIF end_spec SLPAR expr SRPAR label SCOMMA label SCOMMA label 49 | { exarif($4, $6, $8, $10); thiswasbranch = YES; } 50 | | call 51 | { excall($1, LBNULL, 0, labarray); } 52 | | call SLPAR SRPAR 53 | { excall($1, LBNULL, 0, labarray); } 54 | | call SLPAR callarglist SRPAR 55 | { if(nstars < maxlablist) 56 | excall($1, mklist(revchain($3)), nstars, labarray); 57 | else 58 | many("alternate returns", 'l', maxlablist); 59 | } 60 | | SRETURN end_spec opt_expr 61 | { exreturn($3); thiswasbranch = YES; } 62 | | stop end_spec opt_expr 63 | { exstop($1, $3); thiswasbranch = $1; } 64 | ; 65 | 66 | assignlabel: SICON 67 | { $$ = mklabel( convci(toklen, token) ); } 68 | ; 69 | 70 | let: SLET 71 | { if(parstate == OUTSIDE) 72 | { 73 | newproc(); 74 | startproc(ESNULL, CLMAIN); 75 | } 76 | } 77 | ; 78 | 79 | goto: SGOTO end_spec label 80 | { exgoto($3); thiswasbranch = YES; } 81 | | SASGOTO end_spec name 82 | { exasgoto($3); thiswasbranch = YES; } 83 | | SASGOTO end_spec name opt_comma SLPAR labellist SRPAR 84 | { exasgoto($3); thiswasbranch = YES; } 85 | | SCOMPGOTO end_spec SLPAR labellist SRPAR opt_comma expr 86 | { if(nstars < maxlablist) 87 | putcmgo(putx(fixtype($7)), nstars, labarray); 88 | else 89 | many("labels in computed GOTO list", 'l', maxlablist); 90 | } 91 | ; 92 | 93 | opt_comma: 94 | | SCOMMA 95 | ; 96 | 97 | call: SCALL end_spec name 98 | { nstars = 0; $$ = $3; } 99 | ; 100 | 101 | callarglist: callarg 102 | { $$ = $1 ? mkchain((char *)$1,CHNULL) : CHNULL; } 103 | | callarglist SCOMMA callarg 104 | { $$ = $3 ? mkchain((char *)$3, $1) : $1; } 105 | ; 106 | 107 | callarg: expr 108 | | SSTAR label 109 | { if(nstars < maxlablist) labarray[nstars++] = $2; $$ = 0; } 110 | ; 111 | 112 | stop: SPAUSE 113 | { $$ = 0; } 114 | | SSTOP 115 | { $$ = 2; } 116 | ; 117 | 118 | exprlist: expr 119 | { $$ = mkchain((char *)$1, CHNULL); } 120 | | exprlist SCOMMA expr 121 | { $$ = hookup($1, mkchain((char *)$3,CHNULL) ); } 122 | ; 123 | 124 | end_spec: 125 | { if(parstate == OUTSIDE) 126 | { 127 | newproc(); 128 | startproc(ESNULL, CLMAIN); 129 | } 130 | 131 | /* This next statement depends on the ordering of the state table encoding */ 132 | 133 | if(parstate < INDATA) enddcl(); 134 | } 135 | ; 136 | 137 | intonlyon: 138 | { intonly = YES; } 139 | ; 140 | 141 | intonlyoff: 142 | { intonly = NO; } 143 | ; 144 | -------------------------------------------------------------------------------- /src/gram.expr: -------------------------------------------------------------------------------- 1 | funarglist: 2 | { $$ = 0; } 3 | | funargs 4 | { $$ = revchain($1); } 5 | ; 6 | 7 | funargs: expr 8 | { $$ = mkchain((char *)$1, CHNULL); } 9 | | funargs SCOMMA expr 10 | { $$ = mkchain((char *)$3, $1); } 11 | ; 12 | 13 | 14 | expr: uexpr 15 | | SLPAR expr SRPAR { $$ = $2; if ($$->tag == TPRIM) 16 | paren_used(&$$->primblock); } 17 | | complex_const 18 | ; 19 | 20 | uexpr: lhs 21 | | simple_const 22 | | expr addop expr %prec SPLUS 23 | { $$ = mkexpr($2, $1, $3); } 24 | | expr SSTAR expr 25 | { $$ = mkexpr(OPSTAR, $1, $3); } 26 | | expr SSLASH expr 27 | { $$ = mkexpr(OPSLASH, $1, $3); } 28 | | expr SPOWER expr 29 | { $$ = mkexpr(OPPOWER, $1, $3); } 30 | | addop expr %prec SSTAR 31 | { if($1 == OPMINUS) 32 | $$ = mkexpr(OPNEG, $2, ENULL); 33 | else { 34 | $$ = $2; 35 | if ($$->tag == TPRIM) 36 | paren_used(&$$->primblock); 37 | } 38 | } 39 | | expr relop expr %prec SEQ 40 | { $$ = mkexpr($2, $1, $3); } 41 | | expr SEQV expr 42 | { NO66(".EQV. operator"); 43 | $$ = mkexpr(OPEQV, $1,$3); } 44 | | expr SNEQV expr 45 | { NO66(".NEQV. operator"); 46 | $$ = mkexpr(OPNEQV, $1, $3); } 47 | | expr SOR expr 48 | { $$ = mkexpr(OPOR, $1, $3); } 49 | | expr SAND expr 50 | { $$ = mkexpr(OPAND, $1, $3); } 51 | | SNOT expr 52 | { $$ = mkexpr(OPNOT, $2, ENULL); } 53 | | expr SCONCAT expr 54 | { NO66("concatenation operator //"); 55 | $$ = mkexpr(OPCONCAT, $1, $3); } 56 | ; 57 | 58 | addop: SPLUS { $$ = OPPLUS; } 59 | | SMINUS { $$ = OPMINUS; } 60 | ; 61 | 62 | relop: SEQ { $$ = OPEQ; } 63 | | SGT { $$ = OPGT; } 64 | | SLT { $$ = OPLT; } 65 | | SGE { $$ = OPGE; } 66 | | SLE { $$ = OPLE; } 67 | | SNE { $$ = OPNE; } 68 | ; 69 | 70 | lhs: name 71 | { $$ = mkprim($1, LBNULL, CHNULL); } 72 | | name substring 73 | { NO66("substring operator :"); 74 | $$ = mkprim($1, LBNULL, $2); } 75 | | name SLPAR funarglist SRPAR 76 | { $$ = mkprim($1, mklist($3), CHNULL); } 77 | | name SLPAR funarglist SRPAR substring 78 | { NO66("substring operator :"); 79 | $$ = mkprim($1, mklist($3), $5); } 80 | ; 81 | 82 | substring: SLPAR opt_expr SCOLON opt_expr SRPAR 83 | { $$ = mkchain((char *)$2, mkchain((char *)$4,CHNULL)); } 84 | ; 85 | 86 | opt_expr: 87 | { $$ = 0; } 88 | | expr 89 | ; 90 | 91 | simple: name 92 | { if($1->vclass == CLPARAM) 93 | $$ = (expptr) cpexpr( 94 | ( (struct Paramblock *) ($1) ) -> paramval); 95 | } 96 | | simple_const 97 | ; 98 | 99 | simple_const: STRUE { $$ = mklogcon(1); } 100 | | SFALSE { $$ = mklogcon(0); } 101 | | SHOLLERITH { $$ = mkstrcon(toklen, token); } 102 | | SICON = { $$ = mkintqcon(toklen, token); } 103 | | SRCON = { $$ = mkrealcon(tyreal, token); } 104 | | SDCON = { $$ = mkrealcon(TYDREAL, token); } 105 | | bit_const 106 | ; 107 | 108 | complex_const: SLPAR uexpr SCOMMA uexpr SRPAR 109 | { $$ = mkcxcon($2,$4); } 110 | ; 111 | 112 | bit_const: SHEXCON 113 | { NOEXT("hex constant"); 114 | $$ = mkbitcon(4, toklen, token); } 115 | | SOCTCON 116 | { NOEXT("octal constant"); 117 | $$ = mkbitcon(3, toklen, token); } 118 | | SBITCON 119 | { NOEXT("binary constant"); 120 | $$ = mkbitcon(1, toklen, token); } 121 | ; 122 | 123 | fexpr: unpar_fexpr 124 | | SLPAR fexpr SRPAR 125 | { $$ = $2; } 126 | ; 127 | 128 | unpar_fexpr: lhs 129 | | simple_const 130 | | fexpr addop fexpr %prec SPLUS 131 | { $$ = mkexpr($2, $1, $3); } 132 | | fexpr SSTAR fexpr 133 | { $$ = mkexpr(OPSTAR, $1, $3); } 134 | | fexpr SSLASH fexpr 135 | { $$ = mkexpr(OPSLASH, $1, $3); } 136 | | fexpr SPOWER fexpr 137 | { $$ = mkexpr(OPPOWER, $1, $3); } 138 | | addop fexpr %prec SSTAR 139 | { if($1 == OPMINUS) 140 | $$ = mkexpr(OPNEG, $2, ENULL); 141 | else $$ = $2; 142 | } 143 | | fexpr SCONCAT fexpr 144 | { NO66("concatenation operator //"); 145 | $$ = mkexpr(OPCONCAT, $1, $3); } 146 | ; 147 | -------------------------------------------------------------------------------- /src/gram.head: -------------------------------------------------------------------------------- 1 | /**************************************************************** 2 | Copyright 1990, 1993 by AT&T Bell Laboratories, Bellcore. 3 | 4 | Permission to use, copy, modify, and distribute this software 5 | and its documentation for any purpose and without fee is hereby 6 | granted, provided that the above copyright notice appear in all 7 | copies and that both that the copyright notice and this 8 | permission notice and warranty disclaimer appear in supporting 9 | documentation, and that the names of AT&T Bell Laboratories or 10 | Bellcore or any of their entities not be used in advertising or 11 | publicity pertaining to distribution of the software without 12 | specific, written prior permission. 13 | 14 | AT&T and Bellcore disclaim all warranties with regard to this 15 | software, including all implied warranties of merchantability 16 | and fitness. In no event shall AT&T or Bellcore be liable for 17 | any special, indirect or consequential damages or any damages 18 | whatsoever resulting from loss of use, data or profits, whether 19 | in an action of contract, negligence or other tortious action, 20 | arising out of or in connection with the use or performance of 21 | this software. 22 | ****************************************************************/ 23 | 24 | %{ 25 | #include "defs.h" 26 | #include "p1defs.h" 27 | 28 | static int nstars; /* Number of labels in an 29 | alternate return CALL */ 30 | static int datagripe; 31 | static int lasttype; 32 | static int ndim; 33 | static int vartype; 34 | int new_dcl; 35 | static ftnint varleng; 36 | static struct Dims dims[MAXDIM+1]; 37 | extern struct Labelblock **labarray; /* Labels in an alternate 38 | return CALL */ 39 | extern int maxlablist; 40 | 41 | /* The next two variables are used to verify that each statement might be reached 42 | during runtime. lastwasbranch is tested only in the defintion of the 43 | stat: nonterminal. */ 44 | 45 | int lastwasbranch = NO; 46 | static int thiswasbranch = NO; 47 | extern ftnint yystno; 48 | extern flag intonly; 49 | static chainp datastack; 50 | extern long laststfcn, thisstno; 51 | extern int can_include; /* for netlib */ 52 | extern void endcheck Argdcl((void)); 53 | extern struct Primblock *primchk Argdcl((expptr)); 54 | 55 | #define ESNULL (Extsym *)0 56 | #define NPNULL (Namep)0 57 | #define LBNULL (struct Listblock *)0 58 | 59 | static void 60 | pop_datastack(Void) { 61 | chainp d0 = datastack; 62 | if (d0->datap) 63 | curdtp = (chainp)d0->datap; 64 | datastack = d0->nextp; 65 | d0->nextp = 0; 66 | frchain(&d0); 67 | } 68 | 69 | %} 70 | 71 | /* Specify precedences and associativities. */ 72 | 73 | %union { 74 | int ival; 75 | ftnint lval; 76 | char *charpval; 77 | chainp chval; 78 | tagptr tagval; 79 | expptr expval; 80 | struct Labelblock *labval; 81 | struct Nameblock *namval; 82 | struct Eqvchain *eqvval; 83 | Extsym *extval; 84 | } 85 | 86 | %left SCOMMA 87 | %nonassoc SCOLON 88 | %right SEQUALS 89 | %left SEQV SNEQV 90 | %left SOR 91 | %left SAND 92 | %left SNOT 93 | %nonassoc SLT SGT SLE SGE SEQ SNE 94 | %left SCONCAT 95 | %left SPLUS SMINUS 96 | %left SSTAR SSLASH 97 | %right SPOWER 98 | 99 | %start program 100 | %type thislabel label assignlabel 101 | %type other inelt 102 | %type type typespec typename dcl letter addop relop stop nameeq 103 | %type lengspec 104 | %type filename 105 | %type datavar datavarlist namelistlist funarglist funargs 106 | %type dospec dospecw 107 | %type callarglist arglist args exprlist inlist outlist out2 substring 108 | %type name arg call var 109 | %type lhs expr uexpr opt_expr fexpr unpar_fexpr 110 | %type ubound simple value callarg complex_const simple_const bit_const 111 | %type common comblock entryname progname 112 | %type equivlist 113 | 114 | %% 115 | 116 | program: 117 | | program stat SEOS 118 | ; 119 | 120 | stat: thislabel entry 121 | { 122 | /* stat: is the nonterminal for Fortran statements */ 123 | 124 | lastwasbranch = NO; } 125 | | thislabel spec 126 | | thislabel exec 127 | { /* forbid further statement function definitions... */ 128 | if (parstate == INDATA && laststfcn != thisstno) 129 | parstate = INEXEC; 130 | thisstno++; 131 | if($1 && ($1->labelno==dorange)) 132 | enddo($1->labelno); 133 | if(lastwasbranch && thislabel==NULL) 134 | warn("statement cannot be reached"); 135 | lastwasbranch = thiswasbranch; 136 | thiswasbranch = NO; 137 | if($1) 138 | { 139 | if($1->labtype == LABFORMAT) 140 | err("label already that of a format"); 141 | else 142 | $1->labtype = LABEXEC; 143 | } 144 | freetemps(); 145 | } 146 | | thislabel SINCLUDE filename 147 | { if (can_include) 148 | doinclude( $3 ); 149 | else { 150 | fprintf(diagfile, "Cannot open file %s\n", $3); 151 | done(1); 152 | } 153 | } 154 | | thislabel SEND end_spec 155 | { if ($1) 156 | lastwasbranch = NO; 157 | endcheck(); 158 | endproc(); /* lastwasbranch = NO; -- set in endproc() */ 159 | } 160 | | thislabel SUNKNOWN 161 | { unclassifiable(); 162 | 163 | /* flline flushes the current line, ignoring the rest of the text there */ 164 | 165 | flline(); } 166 | | error 167 | { flline(); needkwd = NO; inioctl = NO; 168 | yyerrok; yyclearin; } 169 | ; 170 | 171 | thislabel: SLABEL 172 | { 173 | if(yystno != 0) 174 | { 175 | $$ = thislabel = mklabel(yystno); 176 | if( ! headerdone ) { 177 | if (procclass == CLUNKNOWN) 178 | procclass = CLMAIN; 179 | puthead(CNULL, procclass); 180 | } 181 | if(thislabel->labdefined) 182 | execerr("label %s already defined", 183 | convic(thislabel->stateno) ); 184 | else { 185 | if(thislabel->blklevel!=0 && thislabel->blklevellabtype!=LABFORMAT) 187 | warn1("there is a branch to label %s from outside block", 188 | convic( (ftnint) (thislabel->stateno) ) ); 189 | thislabel->blklevel = blklevel; 190 | thislabel->labdefined = YES; 191 | if(thislabel->labtype != LABFORMAT) 192 | p1_label((long)(thislabel - labeltab)); 193 | } 194 | } 195 | else $$ = thislabel = NULL; 196 | } 197 | ; 198 | 199 | entry: SPROGRAM new_proc progname 200 | {startproc($3, CLMAIN); } 201 | | SPROGRAM new_proc progname progarglist 202 | { warn("ignoring arguments to main program"); 203 | /* hashclear(); */ 204 | startproc($3, CLMAIN); } 205 | | SBLOCK new_proc progname 206 | { if($3) NO66("named BLOCKDATA"); 207 | startproc($3, CLBLOCK); } 208 | | SSUBROUTINE new_proc entryname arglist 209 | { entrypt(CLPROC, TYSUBR, (ftnint) 0, $3, $4); } 210 | | SFUNCTION new_proc entryname arglist 211 | { entrypt(CLPROC, TYUNKNOWN, (ftnint) 0, $3, $4); } 212 | | type SFUNCTION new_proc entryname arglist 213 | { entrypt(CLPROC, $1, varleng, $4, $5); } 214 | | SENTRY entryname arglist 215 | { if(parstate==OUTSIDE || procclass==CLMAIN 216 | || procclass==CLBLOCK) 217 | execerr("misplaced entry statement", CNULL); 218 | entrypt(CLENTRY, 0, (ftnint) 0, $2, $3); 219 | } 220 | ; 221 | 222 | new_proc: 223 | { newproc(); } 224 | ; 225 | 226 | entryname: name 227 | { $$ = newentry($1, 1); } 228 | ; 229 | 230 | name: SNAME 231 | { $$ = mkname(token); } 232 | ; 233 | 234 | progname: { $$ = NULL; } 235 | | entryname 236 | ; 237 | 238 | progarglist: 239 | SLPAR SRPAR 240 | | SLPAR progargs SRPAR 241 | ; 242 | 243 | progargs: progarg 244 | | progargs SCOMMA progarg 245 | ; 246 | 247 | progarg: SNAME 248 | | SNAME SEQUALS SNAME 249 | ; 250 | 251 | arglist: 252 | { $$ = 0; } 253 | | SLPAR SRPAR 254 | { NO66(" () argument list"); 255 | $$ = 0; } 256 | | SLPAR args SRPAR 257 | {$$ = $2; } 258 | ; 259 | 260 | args: arg 261 | { $$ = ($1 ? mkchain((char *)$1,CHNULL) : CHNULL ); } 262 | | args SCOMMA arg 263 | { if($3) $1 = $$ = mkchain((char *)$3, $1); } 264 | ; 265 | 266 | arg: name 267 | { if($1->vstg!=STGUNKNOWN && $1->vstg!=STGARG) 268 | dclerr("name declared as argument after use", $1); 269 | $1->vstg = STGARG; 270 | } 271 | | SSTAR 272 | { NO66("altenate return argument"); 273 | 274 | /* substars means that '*'ed formal parameters should be replaced. 275 | This is used to specify alternate return labels; in theory, only 276 | parameter slots which have '*' should accept the statement labels. 277 | This compiler chooses to ignore the '*'s in the formal declaration, and 278 | always return the proper value anyway. 279 | 280 | This variable is only referred to in proc.c */ 281 | 282 | $$ = 0; substars = YES; } 283 | ; 284 | 285 | 286 | 287 | filename: SHOLLERITH 288 | { 289 | char *s; 290 | s = copyn(toklen+1, token); 291 | s[toklen] = '\0'; 292 | $$ = s; 293 | } 294 | ; 295 | -------------------------------------------------------------------------------- /src/gram.io: -------------------------------------------------------------------------------- 1 | /* Input/Output Statements */ 2 | 3 | io: io1 4 | { endio(); } 5 | ; 6 | 7 | io1: iofmove ioctl 8 | | iofmove unpar_fexpr 9 | { ioclause(IOSUNIT, $2); endioctl(); } 10 | | iofmove SSTAR 11 | { ioclause(IOSUNIT, ENULL); endioctl(); } 12 | | iofmove SPOWER 13 | { ioclause(IOSUNIT, IOSTDERR); endioctl(); } 14 | | iofctl ioctl 15 | | read ioctl 16 | { doio(CHNULL); } 17 | | read infmt 18 | { doio(CHNULL); } 19 | | read ioctl inlist 20 | { doio(revchain($3)); } 21 | | read infmt SCOMMA inlist 22 | { doio(revchain($4)); } 23 | | read ioctl SCOMMA inlist 24 | { doio(revchain($4)); } 25 | | write ioctl 26 | { doio(CHNULL); } 27 | | write ioctl outlist 28 | { doio(revchain($3)); } 29 | | write ioctl SCOMMA outlist 30 | { doio(revchain($4)); } 31 | | print 32 | { doio(CHNULL); } 33 | | print SCOMMA outlist 34 | { doio(revchain($3)); } 35 | ; 36 | 37 | iofmove: fmkwd end_spec in_ioctl 38 | ; 39 | 40 | fmkwd: SBACKSPACE 41 | { iostmt = IOBACKSPACE; } 42 | | SREWIND 43 | { iostmt = IOREWIND; } 44 | | SENDFILE 45 | { iostmt = IOENDFILE; } 46 | ; 47 | 48 | iofctl: ctlkwd end_spec in_ioctl 49 | ; 50 | 51 | ctlkwd: SINQUIRE 52 | { iostmt = IOINQUIRE; } 53 | | SOPEN 54 | { iostmt = IOOPEN; } 55 | | SCLOSE 56 | { iostmt = IOCLOSE; } 57 | ; 58 | 59 | infmt: unpar_fexpr 60 | { 61 | ioclause(IOSUNIT, ENULL); 62 | ioclause(IOSFMT, $1); 63 | endioctl(); 64 | } 65 | | SSTAR 66 | { 67 | ioclause(IOSUNIT, ENULL); 68 | ioclause(IOSFMT, ENULL); 69 | endioctl(); 70 | } 71 | ; 72 | 73 | ioctl: SLPAR fexpr SRPAR 74 | { 75 | ioclause(IOSUNIT, $2); 76 | endioctl(); 77 | } 78 | | SLPAR ctllist SRPAR 79 | { endioctl(); } 80 | ; 81 | 82 | ctllist: ioclause 83 | | ctllist SCOMMA ioclause 84 | ; 85 | 86 | ioclause: fexpr 87 | { ioclause(IOSPOSITIONAL, $1); } 88 | | SSTAR 89 | { ioclause(IOSPOSITIONAL, ENULL); } 90 | | SPOWER 91 | { ioclause(IOSPOSITIONAL, IOSTDERR); } 92 | | nameeq expr 93 | { ioclause($1, $2); } 94 | | nameeq SSTAR 95 | { ioclause($1, ENULL); } 96 | | nameeq SPOWER 97 | { ioclause($1, IOSTDERR); } 98 | ; 99 | 100 | nameeq: SNAMEEQ 101 | { $$ = iocname(); } 102 | ; 103 | 104 | read: SREAD end_spec in_ioctl 105 | { iostmt = IOREAD; } 106 | ; 107 | 108 | write: SWRITE end_spec in_ioctl 109 | { iostmt = IOWRITE; } 110 | ; 111 | 112 | print: SPRINT end_spec fexpr in_ioctl 113 | { 114 | iostmt = IOWRITE; 115 | ioclause(IOSUNIT, ENULL); 116 | ioclause(IOSFMT, $3); 117 | endioctl(); 118 | } 119 | | SPRINT end_spec SSTAR in_ioctl 120 | { 121 | iostmt = IOWRITE; 122 | ioclause(IOSUNIT, ENULL); 123 | ioclause(IOSFMT, ENULL); 124 | endioctl(); 125 | } 126 | ; 127 | 128 | inlist: inelt 129 | { $$ = mkchain((char *)$1, CHNULL); } 130 | | inlist SCOMMA inelt 131 | { $$ = mkchain((char *)$3, $1); } 132 | ; 133 | 134 | inelt: lhs 135 | { $$ = (tagptr) $1; } 136 | | SLPAR inlist SCOMMA dospec SRPAR 137 | { $$ = (tagptr) mkiodo($4,revchain($2)); } 138 | ; 139 | 140 | outlist: uexpr 141 | { $$ = mkchain((char *)$1, CHNULL); } 142 | | other 143 | { $$ = mkchain((char *)$1, CHNULL); } 144 | | out2 145 | ; 146 | 147 | out2: uexpr SCOMMA uexpr 148 | { $$ = mkchain((char *)$3, mkchain((char *)$1, CHNULL) ); } 149 | | uexpr SCOMMA other 150 | { $$ = mkchain((char *)$3, mkchain((char *)$1, CHNULL) ); } 151 | | other SCOMMA uexpr 152 | { $$ = mkchain((char *)$3, mkchain((char *)$1, CHNULL) ); } 153 | | other SCOMMA other 154 | { $$ = mkchain((char *)$3, mkchain((char *)$1, CHNULL) ); } 155 | | out2 SCOMMA uexpr 156 | { $$ = mkchain((char *)$3, $1); } 157 | | out2 SCOMMA other 158 | { $$ = mkchain((char *)$3, $1); } 159 | ; 160 | 161 | other: complex_const 162 | { $$ = (tagptr) $1; } 163 | | SLPAR expr SRPAR 164 | { $$ = (tagptr) $2; } 165 | | SLPAR uexpr SCOMMA dospec SRPAR 166 | { $$ = (tagptr) mkiodo($4, mkchain((char *)$2, CHNULL) ); } 167 | | SLPAR other SCOMMA dospec SRPAR 168 | { $$ = (tagptr) mkiodo($4, mkchain((char *)$2, CHNULL) ); } 169 | | SLPAR out2 SCOMMA dospec SRPAR 170 | { $$ = (tagptr) mkiodo($4, revchain($2)); } 171 | ; 172 | 173 | in_ioctl: 174 | { startioctl(); } 175 | ; 176 | -------------------------------------------------------------------------------- /src/iob.h: -------------------------------------------------------------------------------- 1 | struct iob_data { 2 | struct iob_data *next; 3 | char *type; 4 | char *name; 5 | char *fields[1]; 6 | }; 7 | struct io_setup { 8 | char **fields; 9 | int nelt, type; 10 | }; 11 | 12 | struct defines { 13 | struct defines *next; 14 | char defname[1]; 15 | }; 16 | 17 | typedef struct iob_data iob_data; 18 | typedef struct io_setup io_setup; 19 | typedef struct defines defines; 20 | 21 | extern iob_data *iob_list; 22 | extern struct Addrblock *io_structs[9]; 23 | void def_start Argdcl((FILEP, char*, char*, char*)); 24 | void new_iob_data Argdcl((io_setup*, char*)); 25 | void other_undefs Argdcl((FILEP)); 26 | char* tostring Argdcl((char*, int)); 27 | -------------------------------------------------------------------------------- /src/machdefs.h: -------------------------------------------------------------------------------- 1 | #define TYLENG TYLONG /* char string length field */ 2 | 3 | #define TYINT TYLONG 4 | #define SZADDR 4 5 | #define SZSHORT 2 6 | #define SZINT 4 7 | 8 | #define SZLONG 4 9 | #define SZLENG SZLONG 10 | 11 | #define SZDREAL 8 12 | 13 | /* Alignment restrictions */ 14 | 15 | #define ALIADDR SZADDR 16 | #define ALISHORT SZSHORT 17 | #define ALILONG 4 18 | #define ALIDOUBLE 8 19 | #define ALIINT ALILONG 20 | #define ALILENG ALILONG 21 | 22 | #define BLANKCOMMON "_BLNK__" /* Name for the unnamed 23 | common block; this is unique 24 | because of underscores */ 25 | 26 | #define LABELFMT "%s:\n" 27 | 28 | #define MAXREGVAR 4 29 | #define TYIREG TYLONG 30 | #define MSKIREG (M(TYSHORT)|M(TYLONG)) /* allowed types of DO indicies 31 | which can be put in registers */ 32 | -------------------------------------------------------------------------------- /src/makefile.u: -------------------------------------------------------------------------------- 1 | # Makefile for f2c, a Fortran 77 to C converter 2 | 3 | .SUFFIXES: .c .o 4 | CC = cc 5 | CFLAGS = -O 6 | SHELL = /bin/sh 7 | YACC = yacc 8 | YFLAGS = 9 | 10 | .c.o: 11 | $(CC) -c $(CFLAGS) $*.c 12 | 13 | OBJECTSd = main.o init.o gram.o lex.o proc.o equiv.o data.o format.o \ 14 | expr.o exec.o intr.o io.o misc.o error.o mem.o names.o \ 15 | output.o p1output.o pread.o put.o putpcc.o vax.o formatdata.o \ 16 | parse_args.o niceprintf.o cds.o sysdep.o version.o 17 | 18 | MALLOC = 19 | # To use the malloc whose source accompanies the f2c source, add malloc.o 20 | # to the right-hand side of the "MALLOC =" line above, so it becomes 21 | # MALLOC = malloc.o 22 | # This gives faster execution on some systems, but some other systems do 23 | # not tolerate replacement of the system's malloc. 24 | 25 | OBJECTS = $(OBJECTSd) $(MALLOC) 26 | 27 | all: xsum.out f2c 28 | 29 | f2c: $(OBJECTS) 30 | $(CC) $(LDFLAGS) $(OBJECTS) -o f2c 31 | 32 | # The following used to be a rule for gram.c rather than gram1.c, but 33 | # there are too many broken variants of yacc around, so now we 34 | # distribute a correctly functioning gram.c (derived with a Unix variant 35 | # of the yacc from plan9). 36 | 37 | gram1.c: gram.head gram.dcl gram.expr gram.exec gram.io defs.h tokdefs.h 38 | ( sed gram.in 40 | $(YACC) $(YFLAGS) gram.in 41 | @echo "(There should be 4 shift/reduce conflicts.)" 42 | sed 's/^# line.*/\/* & *\//' y.tab.c >gram.c 43 | rm -f gram.in y.tab.c 44 | 45 | $(OBJECTSd): defs.h ftypes.h defines.h machdefs.h sysdep.h 46 | 47 | tokdefs.h: tokens 48 | grep -n . tokdefs.h 49 | 50 | cds.o: sysdep.h 51 | exec.o: p1defs.h names.h 52 | expr.o: output.h niceprintf.h names.h 53 | format.o: p1defs.h format.h output.h niceprintf.h names.h iob.h 54 | formatdata.o: format.h output.h niceprintf.h names.h 55 | gram.o: p1defs.h 56 | init.o: output.h niceprintf.h iob.h 57 | intr.o: names.h 58 | io.o: names.h iob.h 59 | lex.o : tokdefs.h p1defs.h 60 | main.o: parse.h usignal.h 61 | mem.o: iob.h 62 | names.o: iob.h names.h output.h niceprintf.h 63 | niceprintf.o: defs.h names.h output.h niceprintf.h 64 | output.o: output.h niceprintf.h names.h 65 | p1output.o: p1defs.h output.h niceprintf.h names.h 66 | parse_args.o: parse.h 67 | proc.o: tokdefs.h names.h niceprintf.h output.h p1defs.h 68 | put.o: names.h pccdefs.h p1defs.h 69 | putpcc.o: names.h 70 | vax.o: defs.h output.h pccdefs.h 71 | output.h: niceprintf.h 72 | sysdep.o: sysdep.c sysdep.hd 73 | 74 | put.o putpcc.o: pccdefs.h 75 | 76 | sysdep.hd: 77 | if $(CC) sysdeptest.c; then echo '/*OK*/' > sysdep.hd;\ 78 | elif $(CC) -DNO_MKDTEMP sysdeptest.c; then echo '#define NO_MKDTEMP' >sysdep.hd;\ 79 | else echo '#define NO_MKDTEMP' >sysdep.hd; echo '#define NO_MKSTEMP' >>sysdep.hd; fi 80 | rm -f a.out 81 | 82 | f2c.t: f2c.1t 83 | troff -man f2c.1t >f2c.t 84 | 85 | #f2c.1: f2c.1t 86 | # nroff -man f2c.1t | col -b | uniq >f2c.1 87 | 88 | clean: 89 | rm -f *.o f2c sysdep.hd tokdefs.h f2c.t 90 | 91 | veryclean: clean 92 | rm -f xsum 93 | 94 | b = Notice README cds.c data.c defines.h defs.h equiv.c error.c \ 95 | exec.c expr.c f2c.1 f2c.1t f2c.h format.c format.h formatdata.c \ 96 | ftypes.h gram.c gram.dcl gram.exec gram.expr gram.head gram.io \ 97 | init.c intr.c io.c iob.h lex.c machdefs.h main.c makefile.u makefile.vc \ 98 | malloc.c mem.c memset.c misc.c names.c names.h niceprintf.c \ 99 | niceprintf.h output.c output.h p1defs.h p1output.c \ 100 | parse.h parse_args.c pccdefs.h pread.c proc.c put.c putpcc.c \ 101 | sysdep.c sysdep.h sysdeptest.c tokens usignal.h vax.c version.c xsum.c 102 | 103 | xsum: xsum.c 104 | $(CC) $(CFLAGS) -o xsum xsum.c 105 | 106 | #Check validity of transmitted source... 107 | xsum.out: xsum $b 108 | ./xsum $b >xsum1.out 109 | cmp xsum0.out xsum1.out && mv xsum1.out xsum.out 110 | 111 | #On non-Unix systems that end lines with carriage-return/newline pairs, 112 | #use "make xsumr.out" rather than "make xsum.out". The -r flag ignores 113 | #carriage-return characters. 114 | xsumr.out: xsum $b 115 | ./xsum -r $b >xsum1.out 116 | cmp xsum0.out xsum1.out && mv xsum1.out xsumr.out 117 | -------------------------------------------------------------------------------- /src/makefile.vc: -------------------------------------------------------------------------------- 1 | # Microsoft Visual C++ Makefile for f2c, a Fortran 77 to C converter 2 | # Invoke with "nmake -f makefile.vc", or execute the commands 3 | # copy makefile.vc makefile 4 | # nmake . 5 | 6 | CC = cl 7 | CFLAGS = -Ot1 -nologo -DNO_LONG_LONG 8 | 9 | .c.obj: 10 | $(CC) -c $(CFLAGS) $*.c 11 | 12 | OBJECTS = main.obj init.obj gram.obj lex.obj proc.obj equiv.obj data.obj format.obj \ 13 | expr.obj exec.obj intr.obj io.obj misc.obj error.obj mem.obj names.obj \ 14 | output.obj p1output.obj pread.obj put.obj putpcc.obj vax.obj formatdata.obj \ 15 | parse_args.obj niceprintf.obj cds.obj sysdep.obj version.obj 16 | 17 | checkfirst: xsum.out 18 | 19 | f2c.exe: $(OBJECTS) 20 | $(CC) -Fef2c.exe $(OBJECTS) setargv.obj 21 | 22 | $(OBJECTS): defs.h ftypes.h defines.h machdefs.h sysdep.h 23 | 24 | cds.obj: sysdep.h 25 | exec.obj: p1defs.h names.h 26 | expr.obj: output.h niceprintf.h names.h 27 | format.obj: p1defs.h format.h output.h niceprintf.h names.h iob.h 28 | formatdata.obj: format.h output.h niceprintf.h names.h 29 | gram.obj: p1defs.h 30 | init.obj: output.h niceprintf.h iob.h 31 | intr.obj: names.h 32 | io.obj: names.h iob.h 33 | lex.obj : tokdefs.h p1defs.h 34 | main.obj: parse.h usignal.h 35 | mem.obj: iob.h 36 | names.obj: iob.h names.h output.h niceprintf.h 37 | niceprintf.obj: defs.h names.h output.h niceprintf.h 38 | output.obj: output.h niceprintf.h names.h 39 | p1output.obj: p1defs.h output.h niceprintf.h names.h 40 | parse_args.obj: parse.h 41 | proc.obj: tokdefs.h names.h niceprintf.h output.h p1defs.h 42 | put.obj: names.h pccdefs.h p1defs.h 43 | putpcc.obj: names.h 44 | vax.obj: defs.h output.h pccdefs.h 45 | output.h: niceprintf.h 46 | 47 | put.obj putpcc.obj: pccdefs.h 48 | 49 | clean: 50 | deltree /Y *.obj f2c.exe 51 | 52 | veryclean: clean 53 | deltree /Y xsum.exe 54 | 55 | b = Notice README cds.c data.c defines.h defs.h equiv.c error.c \ 56 | exec.c expr.c f2c.1 f2c.1t f2c.h format.c format.h formatdata.c \ 57 | ftypes.h gram.c gram.dcl gram.exec gram.expr gram.head gram.io \ 58 | init.c intr.c io.c iob.h lex.c machdefs.h main.c makefile.u makefile.vc \ 59 | malloc.c mem.c memset.c misc.c names.c names.h niceprintf.c \ 60 | niceprintf.h output.c output.h p1defs.h p1output.c \ 61 | parse.h parse_args.c pccdefs.h pread.c proc.c put.c putpcc.c \ 62 | sysdep.c sysdep.h sysdeptest.c tokens usignal.h vax.c version.c xsum.c 63 | 64 | xsum.exe: xsum.c 65 | $(CC) $(CFLAGS) -DMSDOS xsum.c 66 | 67 | #Check validity of transmitted source... 68 | # Unfortunately, conditional execution is hard here, since fc does not set a 69 | # nonzero exit code when files differ. 70 | 71 | xsum.out: xsum.exe $b 72 | xsum $b >xsum1.out 73 | fc xsum0.out xsum1.out 74 | @echo If fc showed no differences, manually rename xsum1.out xsum.out: 75 | @echo if xsum.out exists, first "del xsum.out"; then "ren xsum1.out xsum.out". 76 | @echo Once you are happy that your source is OK, "nmake -f makefile.vc f2c.exe". 77 | -------------------------------------------------------------------------------- /src/malloc.c: -------------------------------------------------------------------------------- 1 | /**************************************************************** 2 | Copyright 1990, 1994, 2000 by AT&T, Lucent Technologies and Bellcore. 3 | 4 | Permission to use, copy, modify, and distribute this software 5 | and its documentation for any purpose and without fee is hereby 6 | granted, provided that the above copyright notice appear in all 7 | copies and that both that the copyright notice and this 8 | permission notice and warranty disclaimer appear in supporting 9 | documentation, and that the names of AT&T, Bell Laboratories, 10 | Lucent or Bellcore or any of their entities not be used in 11 | advertising or publicity pertaining to distribution of the 12 | software without specific, written prior permission. 13 | 14 | AT&T, Lucent and Bellcore disclaim all warranties with regard to 15 | this software, including all implied warranties of 16 | merchantability and fitness. In no event shall AT&T, Lucent or 17 | Bellcore be liable for any special, indirect or consequential 18 | damages or any damages whatsoever resulting from loss of use, 19 | data or profits, whether in an action of contract, negligence or 20 | other tortious action, arising out of or in connection with the 21 | use or performance of this software. 22 | ****************************************************************/ 23 | 24 | #ifndef CRAY 25 | #define STACKMIN 512 26 | #define MINBLK (2*sizeof(struct mem) + 16) 27 | #define F _malloc_free_ 28 | #define SBGULP 8192 29 | #include "string.h" /* for memcpy */ 30 | 31 | #ifdef KR_headers 32 | #define Char char 33 | #define Unsigned unsigned 34 | #define Int /*int*/ 35 | #else 36 | #define Char void 37 | #define Unsigned size_t 38 | #define Int int 39 | #endif 40 | 41 | typedef struct mem { 42 | struct mem *next; 43 | Unsigned len; 44 | } mem; 45 | 46 | mem *F; 47 | 48 | Char * 49 | #ifdef KR_headers 50 | malloc(size) 51 | register Unsigned size; 52 | #else 53 | malloc(register Unsigned size) 54 | #endif 55 | { 56 | register mem *p, *q, *r, *s; 57 | unsigned register k, m; 58 | extern Char *sbrk(Int); 59 | char *top, *top1; 60 | 61 | size = (size+7) & ~7; 62 | r = (mem *) &F; 63 | for (p = F, q = 0; p; r = p, p = p->next) { 64 | if ((k = p->len) >= size && (!q || m > k)) { 65 | m = k; 66 | q = p; 67 | s = r; 68 | } 69 | } 70 | if (q) { 71 | if (q->len - size >= MINBLK) { /* split block */ 72 | p = (mem *) (((char *) (q+1)) + size); 73 | p->next = q->next; 74 | p->len = q->len - size - sizeof(mem); 75 | s->next = p; 76 | q->len = size; 77 | } 78 | else 79 | s->next = q->next; 80 | } 81 | else { 82 | top = (Char *)(((long)sbrk(0) + 7) & ~7); 83 | if (F && (char *)(F+1) + F->len == top) { 84 | q = F; 85 | F = F->next; 86 | } 87 | else 88 | q = (mem *) top; 89 | top1 = (char *)(q+1) + size; 90 | if (sbrk((int)(top1-top+SBGULP)) == (Char *) -1) 91 | return 0; 92 | r = (mem *)top1; 93 | r->len = SBGULP - sizeof(mem); 94 | r->next = F; 95 | F = r; 96 | q->len = size; 97 | } 98 | return (Char *) (q+1); 99 | } 100 | 101 | void 102 | #ifdef KR_headers 103 | free(f) 104 | Char *f; 105 | #else 106 | free(Char *f) 107 | #endif 108 | { 109 | mem *p, *q, *r; 110 | char *pn, *qn; 111 | 112 | if (!f) return; 113 | q = (mem *) ((char *)f - sizeof(mem)); 114 | qn = (char *)f + q->len; 115 | for (p = F, r = (mem *) &F; ; r = p, p = p->next) { 116 | if (qn == (Char *) p) { 117 | q->len += p->len + sizeof(mem); 118 | p = p->next; 119 | } 120 | pn = p ? ((char *) (p+1)) + p->len : 0; 121 | if (pn == (Char *) q) { 122 | p->len += sizeof(mem) + q->len; 123 | q->len = 0; 124 | q->next = p; 125 | r->next = p; 126 | break; 127 | } 128 | if (pn < (char *) q) { 129 | r->next = q; 130 | q->next = p; 131 | break; 132 | } 133 | } 134 | } 135 | 136 | Char * 137 | #ifdef KR_headers 138 | realloc(f, size) 139 | Char *f; 140 | Unsigned size; 141 | #else 142 | realloc(Char *f, Unsigned size) 143 | #endif 144 | { 145 | mem *p; 146 | Char *q, *f1; 147 | Unsigned s1; 148 | 149 | if (!f) return malloc(size); 150 | p = (mem *) ((char *)f - sizeof(mem)); 151 | s1 = p->len; 152 | free(f); 153 | if (s1 > size) 154 | s1 = size + 7 & ~7; 155 | if (!p->len) { 156 | f1 = (Char *)(p->next + 1); 157 | /* til 20160114 was memcpy(f1, f, s1); */ 158 | memmove(f1, f, s1); 159 | f = f1; 160 | } 161 | q = malloc(size); 162 | if (q && q != f) 163 | memcpy(q, f, s1); 164 | return q; 165 | } 166 | 167 | /* The following (calloc) should really be in a separate file, */ 168 | /* but defining it here sometimes avoids confusion on systems */ 169 | /* that do not provide calloc in its own file. */ 170 | 171 | Char * 172 | #ifdef KR_headers 173 | calloc(n, m) Unsigned m, n; 174 | #else 175 | calloc(Unsigned n, Unsigned m) 176 | #endif 177 | { 178 | Char *rv; 179 | rv = malloc(n *= m); 180 | if (n && rv) 181 | memset(rv, 0, n); 182 | return rv; 183 | } 184 | #endif 185 | -------------------------------------------------------------------------------- /src/mem.c: -------------------------------------------------------------------------------- 1 | /**************************************************************** 2 | Copyright 1990, 1991, 1994, 2000 by AT&T, Lucent Technologies and Bellcore. 3 | 4 | Permission to use, copy, modify, and distribute this software 5 | and its documentation for any purpose and without fee is hereby 6 | granted, provided that the above copyright notice appear in all 7 | copies and that both that the copyright notice and this 8 | permission notice and warranty disclaimer appear in supporting 9 | documentation, and that the names of AT&T, Bell Laboratories, 10 | Lucent or Bellcore or any of their entities not be used in 11 | advertising or publicity pertaining to distribution of the 12 | software without specific, written prior permission. 13 | 14 | AT&T, Lucent and Bellcore disclaim all warranties with regard to 15 | this software, including all implied warranties of 16 | merchantability and fitness. In no event shall AT&T, Lucent or 17 | Bellcore be liable for any special, indirect or consequential 18 | damages or any damages whatsoever resulting from loss of use, 19 | data or profits, whether in an action of contract, negligence or 20 | other tortious action, arising out of or in connection with the 21 | use or performance of this software. 22 | ****************************************************************/ 23 | 24 | #include "defs.h" 25 | #include "iob.h" 26 | 27 | #define MEMBSIZE 32000 28 | #define GMEMBSIZE 16000 29 | 30 | #ifdef _WIN32 31 | #undef MSDOS 32 | #endif 33 | 34 | char * 35 | #ifdef KR_headers 36 | gmem(n, round) 37 | int n; 38 | int round; 39 | #else 40 | gmem(int n, int round) 41 | #endif 42 | { 43 | static char *last, *next; 44 | char *rv; 45 | if (round) 46 | #ifdef CRAY 47 | if ((Addr)next & 0xe000000000000000) 48 | next = (char *)(((Addr)next & 0x1fffffffffffffff) + 1); 49 | #else 50 | #ifdef MSDOS 51 | if ((int)next & 1) 52 | next++; 53 | #else 54 | next = (char *)(((Addr)next + sizeof(char *)-1) 55 | & ~((Addr)sizeof(char *)-1)); 56 | #endif 57 | #endif 58 | rv = next; 59 | if ((next += n) > last) { 60 | rv = Alloc(n + GMEMBSIZE); 61 | 62 | next = rv + n; 63 | last = next + GMEMBSIZE; 64 | } 65 | return rv; 66 | } 67 | 68 | struct memblock { 69 | struct memblock *next; 70 | char buf[MEMBSIZE]; 71 | }; 72 | typedef struct memblock memblock; 73 | 74 | static memblock *mem0; 75 | memblock *curmemblock, *firstmemblock; 76 | 77 | char *mem_first, *mem_next, *mem_last, *mem0_last; 78 | 79 | void 80 | mem_init(Void) 81 | { 82 | curmemblock = firstmemblock = mem0 83 | = (memblock *)Alloc(sizeof(memblock)); 84 | mem_first = mem0->buf; 85 | mem_next = mem0->buf; 86 | mem_last = mem0->buf + MEMBSIZE; 87 | mem0_last = mem0->buf + MEMBSIZE; 88 | mem0->next = 0; 89 | } 90 | 91 | char * 92 | #ifdef KR_headers 93 | mem(n, round) 94 | int n; 95 | int round; 96 | #else 97 | mem(int n, int round) 98 | #endif 99 | { 100 | memblock *b; 101 | register char *rv, *s; 102 | 103 | if (round) 104 | #ifdef CRAY 105 | if ((Addr)mem_next & 0xe000000000000000) 106 | mem_next = (char *)(((Addr)mem_next & 0x1fffffffffffffff) + 1); 107 | #else 108 | #ifdef MSDOS 109 | if ((int)mem_next & 1) 110 | mem_next++; 111 | #else 112 | mem_next = (char *)(((Addr)mem_next + sizeof(char *)-1) 113 | & ~((Addr)sizeof(char *)-1)); 114 | #endif 115 | #endif 116 | rv = mem_next; 117 | s = rv + n; 118 | if (s >= mem_last) { 119 | if (n > MEMBSIZE) { 120 | fprintf(stderr, "mem(%d) failure!\n", n); 121 | exit(1); 122 | } 123 | if (!(b = curmemblock->next)) { 124 | b = (memblock *)Alloc(sizeof(memblock)); 125 | curmemblock->next = b; 126 | b->next = 0; 127 | } 128 | curmemblock = b; 129 | rv = b->buf; 130 | mem_last = rv + sizeof(b->buf); 131 | s = rv + n; 132 | } 133 | mem_next = s; 134 | return rv; 135 | } 136 | 137 | char * 138 | #ifdef KR_headers 139 | tostring(s, n) 140 | register char *s; 141 | int n; 142 | #else 143 | tostring(register char *s, int n) 144 | #endif 145 | { 146 | register char *s1, *se, **sf; 147 | char *rv, *s0; 148 | register int k = n + 2, t; 149 | 150 | sf = str_fmt; 151 | sf['%'] = "%"; 152 | s0 = s; 153 | se = s + n; 154 | for(; s < se; s++) { 155 | t = *(unsigned char *)s; 156 | s1 = sf[t]; 157 | while(*++s1) 158 | k++; 159 | } 160 | sf['%'] = "%%"; 161 | rv = s1 = mem(k,0); 162 | *s1++ = '"'; 163 | for(s = s0; s < se; s++) { 164 | t = *(unsigned char *)s; 165 | sprintf(s1, sf[t], t); 166 | s1 += strlen(s1); 167 | } 168 | *s1 = 0; 169 | return rv; 170 | } 171 | 172 | char * 173 | #ifdef KR_headers 174 | cpstring(s) 175 | register char *s; 176 | #else 177 | cpstring(register char *s) 178 | #endif 179 | { 180 | return strcpy(mem(strlen(s)+1,0), s); 181 | } 182 | 183 | void 184 | #ifdef KR_headers 185 | new_iob_data(ios, name) 186 | register io_setup *ios; 187 | char *name; 188 | #else 189 | new_iob_data(register io_setup *ios, char *name) 190 | #endif 191 | { 192 | register iob_data *iod; 193 | register char **s, **se; 194 | 195 | iod = (iob_data *) 196 | mem(sizeof(iob_data) + ios->nelt*sizeof(char *), 1); 197 | iod->next = iob_list; 198 | iob_list = iod; 199 | iod->type = ios->fields[0]; 200 | iod->name = cpstring(name); 201 | s = iod->fields; 202 | se = s + ios->nelt; 203 | while(s < se) 204 | *s++ = "0"; 205 | *s = 0; 206 | } 207 | 208 | char * 209 | #ifdef KR_headers 210 | string_num(pfx, n) 211 | char *pfx; 212 | long n; 213 | #else 214 | string_num(char *pfx, long n) 215 | #endif 216 | { 217 | char buf[32]; 218 | sprintf(buf, "%s%ld", pfx, n); 219 | /* can't trust return type of sprintf -- BSD gets it wrong */ 220 | return strcpy(mem(strlen(buf)+1,0), buf); 221 | } 222 | 223 | static defines *define_list; 224 | 225 | void 226 | #ifdef KR_headers 227 | def_start(outfile, s1, s2, post) 228 | FILE *outfile; 229 | char *s1; 230 | char *s2; 231 | char *post; 232 | #else 233 | def_start(FILE *outfile, char *s1, char *s2, char *post) 234 | #endif 235 | { 236 | defines *d; 237 | int n, n1; 238 | extern int in_define; 239 | 240 | n = n1 = strlen(s1); 241 | if (s2) 242 | n += strlen(s2); 243 | d = (defines *)mem(sizeof(defines)+n, 1); 244 | d->next = define_list; 245 | define_list = d; 246 | strcpy(d->defname, s1); 247 | if (s2) 248 | strcpy(d->defname + n1, s2); 249 | in_define = 1; 250 | nice_printf(outfile, "#define %s", d->defname); 251 | if (post) 252 | nice_printf(outfile, " %s", post); 253 | } 254 | 255 | void 256 | #ifdef KR_headers 257 | other_undefs(outfile) 258 | FILE *outfile; 259 | #else 260 | other_undefs(FILE *outfile) 261 | #endif 262 | { 263 | defines *d; 264 | if (d = define_list) { 265 | define_list = 0; 266 | nice_printf(outfile, "\n"); 267 | do 268 | nice_printf(outfile, "#undef %s\n", d->defname); 269 | while(d = d->next); 270 | nice_printf(outfile, "\n"); 271 | } 272 | } 273 | -------------------------------------------------------------------------------- /src/memset.c: -------------------------------------------------------------------------------- 1 | /**************************************************************** 2 | Copyright 1990, 2000 by AT&T, Lucent Technologies and Bellcore. 3 | 4 | Permission to use, copy, modify, and distribute this software 5 | and its documentation for any purpose and without fee is hereby 6 | granted, provided that the above copyright notice appear in all 7 | copies and that both that the copyright notice and this 8 | permission notice and warranty disclaimer appear in supporting 9 | documentation, and that the names of AT&T, Bell Laboratories, 10 | Lucent or Bellcore or any of their entities not be used in 11 | advertising or publicity pertaining to distribution of the 12 | software without specific, written prior permission. 13 | 14 | AT&T, Lucent and Bellcore disclaim all warranties with regard to 15 | this software, including all implied warranties of 16 | merchantability and fitness. In no event shall AT&T, Lucent or 17 | Bellcore be liable for any special, indirect or consequential 18 | damages or any damages whatsoever resulting from loss of use, 19 | data or profits, whether in an action of contract, negligence or 20 | other tortious action, arising out of or in connection with the 21 | use or performance of this software. 22 | ****************************************************************/ 23 | 24 | /* This is for the benefit of people whose systems don't provide 25 | * memset, memcpy, and memcmp. If yours is such a system, adjust 26 | * the makefile by adding memset.o to the "OBJECTS =" assignment. 27 | * WARNING: the memcpy below is adequate for f2c, but is not a 28 | * general memcpy routine (which must correctly handle overlapping 29 | * fields). 30 | */ 31 | 32 | int 33 | #ifdef KR_headers 34 | memcmp(s1, s2, n) char *s1, *s2; int n; 35 | #else 36 | memcmp(char *s1, char *s2, int n) 37 | #endif 38 | { 39 | char *se; 40 | 41 | for(se = s1 + n; s1 < se; s1++, s2++) 42 | if (*s1 != *s2) 43 | return *s1 - *s2; 44 | return 0; 45 | } 46 | 47 | char * 48 | #ifdef KR_headers 49 | memcpy(s1, s2, n) char *s1, *s2; int n; 50 | #else 51 | memcpy(char *s1, char *s2, int n) 52 | #endif 53 | { 54 | char *s0 = s1, *se = s1 + n; 55 | 56 | while(s1 < se) 57 | *s1++ = *s2++; 58 | return s0; 59 | } 60 | 61 | void 62 | #ifdef KR_headers 63 | memset(s, c, n) char *s; int c, n; 64 | #else 65 | memset(char *s, int c, int n) 66 | #endif 67 | { 68 | char *se = s + n; 69 | 70 | while(s < se) 71 | *s++ = c; 72 | } 73 | -------------------------------------------------------------------------------- /src/mkfile.plan9: -------------------------------------------------------------------------------- 1 | # Plan 9 mkfile for f2c, a Fortran 77 to C converter 2 | 3 | gram.in 38 | $YACC $YFLAGS gram.in 39 | @echo "(There should be 4 shift/reduce conflicts.)" 40 | sed 's/^# line.*/\/* & *\//' y.tab.c >gram.c 41 | rm -f gram.in y.tab.c 42 | 43 | $OBJECTSd: defs.h ftypes.h defines.h machdefs.h sysdep.h 44 | 45 | tokdefs.h: tokens 46 | grep -n . tokdefs.h 47 | 48 | cds.$O: sysdep.h 49 | exec.$O: p1defs.h names.h 50 | expr.$O: output.h niceprintf.h names.h 51 | format.$O: p1defs.h format.h output.h niceprintf.h names.h iob.h 52 | formatdata.$O: format.h output.h niceprintf.h names.h 53 | gram.$O: p1defs.h 54 | init.$O: output.h niceprintf.h iob.h 55 | intr.$O: names.h 56 | io.$O: names.h iob.h 57 | lex.$O : tokdefs.h p1defs.h 58 | main.$O: parse.h usignal.h 59 | mem.$O: iob.h 60 | names.$O: iob.h names.h output.h niceprintf.h 61 | niceprintf.$O: defs.h names.h output.h niceprintf.h 62 | output.$O: output.h niceprintf.h names.h 63 | p1output.$O: p1defs.h output.h niceprintf.h names.h 64 | parse_args.$O: parse.h 65 | proc.$O: tokdefs.h names.h niceprintf.h output.h p1defs.h 66 | put.$O: names.h pccdefs.h p1defs.h 67 | putpcc.$O: names.h 68 | vax.$O: defs.h output.h pccdefs.h 69 | output.h: niceprintf.h 70 | 71 | put.$O putpcc.$O: pccdefs.h 72 | 73 | f2c.t: f2c.1t 74 | troff -man f2c.1t >f2c.t 75 | 76 | #f2c.1: f2c.1t 77 | # nroff -man f2c.1t | col -b | uniq >f2c.1 78 | 79 | clean: 80 | rm -f *.$O f2c tokdefs.h f2c.t 81 | 82 | veryclean: clean 83 | rm -f xsum 84 | 85 | b = Notice README cds.c data.c defines.h defs.h equiv.c error.c \ 86 | exec.c expr.c f2c.1 f2c.1t f2c.h format.c format.h formatdata.c \ 87 | ftypes.h gram.c gram.dcl gram.exec gram.expr gram.head gram.io \ 88 | init.c intr.c io.c iob.h lex.c machdefs.h main.c \ 89 | malloc.c mem.c memset.c misc.c names.c names.h niceprintf.c \ 90 | niceprintf.h output.c output.h p1defs.h p1output.c \ 91 | parse.h parse_args.c pccdefs.h pread.c proc.c put.c putpcc.c \ 92 | sysdep.c sysdep.h tokens usignal.h vax.c version.c xsum.c 93 | 94 | xsum: xsum.c 95 | $CC $CFLAGS -o xsum xsum.c 96 | 97 | #Check validity of transmitted source... 98 | xsum.out: xsum $b 99 | ./xsum $b >xsum1.out 100 | cmp xsum0.out xsum1.out && mv xsum1.out xsum.out 101 | 102 | #On non-Unix systems that end lines with carriage-return/newline pairs, 103 | #use "make xsumr.out" rather than "make xsum.out". The -r flag ignores 104 | #carriage-return characters. 105 | xsumr.out: xsum $b 106 | ./xsum -r $b >xsum1.out 107 | cmp xsum0.out xsum1.out && mv xsum1.out xsumr.out 108 | -------------------------------------------------------------------------------- /src/names.h: -------------------------------------------------------------------------------- 1 | #define CONST_IDENT_MAX 30 2 | #define IO_IDENT_MAX 30 3 | #define ARGUMENT_MAX 30 4 | #define USER_LABEL_MAX 30 5 | 6 | #define EQUIV_INIT_NAME "equiv" 7 | 8 | #define write_nv_ident(fp,a) wr_nv_ident_help ((fp), (struct Addrblock *) (a)) 9 | #define nv_type(x) nv_type_help ((struct Addrblock *) x) 10 | 11 | extern char *c_keywords[]; 12 | 13 | char* c_type_decl Argdcl((int, int)); 14 | void declare_new_addr Argdcl((Addrp)); 15 | char* new_arg_length Argdcl((Namep)); 16 | char* new_func_length Argdcl((void)); 17 | int nv_type_help Argdcl((Addrp)); 18 | char* temp_name Argdcl((char*, int, char*)); 19 | char* user_label Argdcl((long int)); 20 | -------------------------------------------------------------------------------- /src/niceprintf.h: -------------------------------------------------------------------------------- 1 | /* niceprintf.h -- contains constants and macros from the output filter 2 | for the generated C code. We use macros for increased speed, less 3 | function overhead. */ 4 | 5 | #define MAX_OUTPUT_SIZE 6000 /* Number of chars on one output line PLUS 6 | the length of the longest string 7 | printed using nice_printf */ 8 | 9 | 10 | 11 | #define next_tab(fp) (indent += tab_size) 12 | 13 | #define prev_tab(fp) (indent -= tab_size) 14 | 15 | 16 | 17 | -------------------------------------------------------------------------------- /src/output.h: -------------------------------------------------------------------------------- 1 | /* nice_printf -- same arguments as fprintf. 2 | 3 | All output which is to become C code must be directed through this 4 | function. For now, no buffering is done. Later on, every line of 5 | output will be filtered to accomodate the style definitions (e.g. one 6 | statement per line, spaces between function names and argument lists, 7 | etc.) 8 | */ 9 | #include "niceprintf.h" 10 | 11 | 12 | /* Definitions for the opcode table. The table is indexed by the macros 13 | which are #defined in defines.h */ 14 | 15 | #define UNARY_OP 01 16 | #define BINARY_OP 02 17 | 18 | #define SPECIAL_FMT NULL 19 | 20 | #define is_unary_op(x) (opcode_table[x].type == UNARY_OP) 21 | #define is_binary_op(x) (opcode_table[x].type == BINARY_OP) 22 | #define op_precedence(x) (opcode_table[x].prec) 23 | #define op_format(x) (opcode_table[x].format) 24 | 25 | /* _assoc_table -- encodes left-associativity and right-associativity 26 | information; indexed by precedence level. Only 2, 3, 14 are 27 | right-associative. Source: Kernighan & Ritchie, p. 49 */ 28 | 29 | extern char _assoc_table[]; 30 | 31 | #define is_right_assoc(x) (_assoc_table [x]) 32 | #define is_left_assoc(x) (! _assoc_table [x]) 33 | 34 | 35 | typedef struct { 36 | int type; /* UNARY_OP or BINARY_OP */ 37 | int prec; /* Precedence level, useful for adjusting 38 | number of parens to insert. Zero is a 39 | special level, and 2, 3, 14 are 40 | right-associative */ 41 | char *format; 42 | } table_entry; 43 | 44 | 45 | extern char *fl_fmt_string; /* Float constant format string */ 46 | extern char *db_fmt_string; /* Double constant format string */ 47 | extern char *cm_fmt_string; /* Complex constant format string */ 48 | extern char *dcm_fmt_string; /* Double Complex constant format string */ 49 | 50 | extern int indent; /* Number of spaces to indent; this is a 51 | temporary fix */ 52 | extern int tab_size; /* Number of spaces in each tab */ 53 | extern int in_string; 54 | 55 | extern table_entry opcode_table[]; 56 | 57 | 58 | void compgoto_out Argdcl((FILEP, tagptr, tagptr)); 59 | void endif_out Argdcl((FILEP)); 60 | void expr_out Argdcl((FILEP, tagptr)); 61 | void out_and_free_statement Argdcl((FILEP, tagptr)); 62 | void out_end_for Argdcl((FILEP)); 63 | void out_if Argdcl((FILEP, tagptr)); 64 | void out_name Argdcl((FILEP, Namep)); 65 | -------------------------------------------------------------------------------- /src/p1defs.h: -------------------------------------------------------------------------------- 1 | #define P1_UNKNOWN 0 2 | #define P1_COMMENT 1 /* Fortan comment string */ 3 | #define P1_EOF 2 /* End of file dummy token */ 4 | #define P1_SET_LINE 3 /* Reset the line counter */ 5 | #define P1_FILENAME 4 /* Name of current input file */ 6 | #define P1_NAME_POINTER 5 /* Pointer to hash table entry */ 7 | #define P1_CONST 6 /* Some constant value */ 8 | #define P1_EXPR 7 /* Followed by opcode */ 9 | 10 | /* The next two tokens could be grouped together, since they always come 11 | from an Addr structure */ 12 | 13 | #define P1_IDENT 8 /* Char string identifier in addrp->user 14 | field */ 15 | #define P1_EXTERN 9 /* Pointer to external symbol entry */ 16 | 17 | #define P1_HEAD 10 /* Function header info */ 18 | #define P1_LIST 11 /* A list of data (e.g. arguments) will 19 | follow the tag, type, and count */ 20 | #define P1_LITERAL 12 /* Hold the index into the literal pool */ 21 | #define P1_LABEL 13 /* label value */ 22 | #define P1_ASGOTO 14 /* Store the hash table pointer of 23 | variable used in assigned goto */ 24 | #define P1_GOTO 15 /* Store the statement number */ 25 | #define P1_IF 16 /* store the condition as an expression */ 26 | #define P1_ELSE 17 /* No data */ 27 | #define P1_ELIF 18 /* store the condition as an expression */ 28 | #define P1_ENDIF 19 /* Marks the end of a block IF */ 29 | #define P1_ENDELSE 20 /* Marks the end of a block ELSE */ 30 | #define P1_ADDR 21 /* Addr data; used for arrays, common and 31 | equiv addressing, NOT for names, idents 32 | or externs */ 33 | #define P1_SUBR_RET 22 /* Subroutine return; the return expression 34 | follows */ 35 | #define P1_COMP_GOTO 23 /* Computed goto; has expr, label list */ 36 | #define P1_FOR 24 /* C FOR loop; three expressions follow */ 37 | #define P1_ENDFOR 25 /* End of C FOR loop */ 38 | #define P1_FORTRAN 26 /* original Fortran source */ 39 | #define P1_CHARP 27 /* user.Charp field -- for long names */ 40 | #define P1_WHILE1START 28 /* start of DO WHILE */ 41 | #define P1_WHILE2START 29 /* rest of DO WHILE */ 42 | #define P1_PROCODE 30 /* invoke procode() -- to adjust params */ 43 | #define P1_ELSEIFSTART 31 /* handle extra code for abs, min, max 44 | in else if() */ 45 | 46 | #define P1_FILENAME_MAX 256 /* max filename length to retain (for -g) */ 47 | #define P1_STMTBUFSIZE 1400 48 | 49 | 50 | 51 | #define COMMENT_BUFFER_SIZE 255 /* max number of chars in each comment */ 52 | #define CONSTANT_STR_MAX 1000 /* max number of chars in string constant */ 53 | 54 | void p1_asgoto Argdcl((Addrp)); 55 | void p1_comment Argdcl((char*)); 56 | void p1_elif Argdcl((tagptr)); 57 | void p1_else Argdcl((void)); 58 | void p1_endif Argdcl((void)); 59 | void p1_expr Argdcl((tagptr)); 60 | void p1_for Argdcl((tagptr, tagptr, tagptr)); 61 | void p1_goto Argdcl((long int)); 62 | void p1_head Argdcl((int, char*)); 63 | void p1_if Argdcl((tagptr)); 64 | void p1_label Argdcl((long int)); 65 | void p1_line_number Argdcl((long int)); 66 | void p1_subr_ret Argdcl((tagptr)); 67 | void p1comp_goto Argdcl((tagptr, int, struct Labelblock**)); 68 | void p1else_end Argdcl((void)); 69 | void p1for_end Argdcl((void)); 70 | void p1put Argdcl((int)); 71 | void p1puts Argdcl((int, char*)); 72 | 73 | /* The pass 1 intermediate file has the following format: 74 | 75 | [ : [ [ ]]] \n 76 | 77 | e.g. 1: This is a comment 78 | 79 | This format is destined to change in the future, but for now a readable 80 | form is more desirable than a compact form. 81 | 82 | NOTES ABOUT THE P1 FORMAT 83 | ---------------------------------------------------------------------- 84 | 85 | P1_COMMENT: The comment string (in ) may be at most 86 | COMMENT_BUFFER_SIZE bytes long. It must contain no newlines 87 | or null characters. A side effect of the way comments are 88 | read in lex.c is that no '\377' chars may be in a 89 | comment either. 90 | 91 | P1_SET_LINE: holds the line number in the current source file. 92 | 93 | P1_INC_LINE: Increment the source line number; is empty. 94 | 95 | P1_NAME_POINTER: holds the integer representation of a 96 | pointer into a hash table entry. 97 | 98 | P1_CONST: the first field in is a type tag (one of the 99 | TYxxxx macros), the next field holds the constant 100 | value 101 | 102 | P1_EXPR: holds the opcode number of the expression, 103 | followed by the type of the expression (required for 104 | OPCONV). Next is the value of vleng. 105 | The type of operation represented by the 106 | opcode determines how many of the following data items 107 | are part of this expression. 108 | 109 | P1_IDENT: holds the type, then storage, then the 110 | char string identifier in the addrp->user field. 111 | 112 | P1_EXTERN: holds an offset into the external symbol 113 | table entry 114 | 115 | P1_HEAD: the first field in is the procedure class, the 116 | second is the name of the procedure 117 | 118 | P1_LIST: the first field in is the tag, the second the 119 | type of the list, the third the number of elements in 120 | the list 121 | 122 | P1_LITERAL: holds the litnum of a value in the 123 | literal pool. 124 | 125 | P1_LABEL: holds the statement number of the current 126 | line 127 | 128 | P1_ASGOTO: holds the hash table pointer of the variable 129 | 130 | P1_GOTO: holds the statement number to jump to 131 | 132 | P1_IF: is empty, the following expression is the IF 133 | condition. 134 | 135 | P1_ELSE: is empty. 136 | 137 | P1_ELIF: is empty, the following expression is the IF 138 | condition. 139 | 140 | P1_ENDIF: is empty. 141 | 142 | P1_ENDELSE: is empty. 143 | 144 | P1_ADDR: holds a direct copy of the structure. The 145 | next expression is a copy of vleng, and the next a 146 | copy of memoffset. 147 | 148 | P1_SUBR_RET: The next token is an expression for the return value. 149 | 150 | P1_COMP_GOTO: The next token is an integer expression, the 151 | following one a list of labels. 152 | 153 | P1_FOR: The next three expressions are the Init, Test, and 154 | Increment expressions of a C FOR loop. 155 | 156 | P1_ENDFOR: Marks the end of the body of a FOR loop 157 | 158 | */ 159 | -------------------------------------------------------------------------------- /src/parse.h: -------------------------------------------------------------------------------- 1 | #ifndef PARSE_INCLUDE 2 | #define PARSE_INCLUDE 3 | 4 | /* macros for the parse_args routine */ 5 | 6 | #define P_STRING 1 /* Macros for the result_type attribute */ 7 | #define P_CHAR 2 8 | #define P_SHORT 3 9 | #define P_INT 4 10 | #define P_LONG 5 11 | #define P_FILE 6 12 | #define P_OLD_FILE 7 13 | #define P_NEW_FILE 8 14 | #define P_FLOAT 9 15 | #define P_DOUBLE 10 16 | 17 | #define P_CASE_INSENSITIVE 01 /* Macros for the flags attribute */ 18 | #define P_REQUIRED_PREFIX 02 19 | 20 | #define P_NO_ARGS 0 /* Macros for the arg_count attribute */ 21 | #define P_ONE_ARG 1 22 | #define P_INFINITE_ARGS 2 23 | 24 | #define p_entry(pref,swit,flag,count,type,store,size) \ 25 | { (pref), (swit), (flag), (count), (type), (int *) (store), (size) } 26 | 27 | typedef struct { 28 | char *prefix; 29 | char *string; 30 | int flags; 31 | int count; 32 | int result_type; 33 | int *result_ptr; 34 | int table_size; 35 | } arg_info; 36 | 37 | #ifdef KR_headers 38 | #define Argdcl(x) () 39 | #else 40 | #define Argdcl(x) x 41 | #endif 42 | int arg_verify Argdcl((char**, arg_info*, int)); 43 | void init_store Argdcl((arg_info*, int)); 44 | int match_table Argdcl((char*, arg_info*, int, int, int*)); 45 | int parse_args Argdcl((int, char**, arg_info*, int, char**, int)); 46 | 47 | #endif 48 | -------------------------------------------------------------------------------- /src/pccdefs.h: -------------------------------------------------------------------------------- 1 | /* The following numbers are strange, and implementation-dependent */ 2 | 3 | #define P2BAD -1 4 | #define P2NAME 2 5 | #define P2ICON 4 /* Integer constant */ 6 | #define P2PLUS 6 7 | #define P2PLUSEQ 7 8 | #define P2MINUS 8 9 | #define P2NEG 10 10 | #define P2STAR 11 11 | #define P2STAREQ 12 12 | #define P2INDIRECT 13 13 | #define P2BITAND 14 14 | #define P2BITOR 17 15 | #define P2BITXOR 19 16 | #define P2QUEST 21 17 | #define P2COLON 22 18 | #define P2ANDAND 23 19 | #define P2OROR 24 20 | #define P2GOTO 37 21 | #define P2LISTOP 56 22 | #define P2ASSIGN 58 23 | #define P2COMOP 59 24 | #define P2SLASH 60 25 | #define P2MOD 62 26 | #define P2LSHIFT 64 27 | #define P2RSHIFT 66 28 | #define P2CALL 70 29 | #define P2CALL0 72 30 | 31 | #define P2NOT 76 32 | #define P2BITNOT 77 33 | #define P2EQ 80 34 | #define P2NE 81 35 | #define P2LE 82 36 | #define P2LT 83 37 | #define P2GE 84 38 | #define P2GT 85 39 | #define P2REG 94 40 | #define P2OREG 95 41 | #define P2CONV 104 42 | #define P2FORCE 108 43 | #define P2CBRANCH 109 44 | 45 | /* special operators included only for fortran's use */ 46 | 47 | #define P2PASS 200 48 | #define P2STMT 201 49 | #define P2SWITCH 202 50 | #define P2LBRACKET 203 51 | #define P2RBRACKET 204 52 | #define P2EOF 205 53 | #define P2ARIF 206 54 | #define P2LABEL 207 55 | 56 | #define P2SHORT 3 57 | #define P2INT 4 58 | #define P2LONG 4 59 | 60 | #define P2CHAR 2 61 | #define P2REAL 6 62 | #define P2DREAL 7 63 | #define P2PTR 020 64 | #define P2FUNCT 040 65 | -------------------------------------------------------------------------------- /src/sysdep.h: -------------------------------------------------------------------------------- 1 | /**************************************************************** 2 | Copyright 1990, 1991, 1994 by AT&T, Lucent Technologies and Bellcore. 3 | 4 | Permission to use, copy, modify, and distribute this software 5 | and its documentation for any purpose and without fee is hereby 6 | granted, provided that the above copyright notice appear in all 7 | copies and that both that the copyright notice and this 8 | permission notice and warranty disclaimer appear in supporting 9 | documentation, and that the names of AT&T, Bell Laboratories, 10 | Lucent or Bellcore or any of their entities not be used in 11 | advertising or publicity pertaining to distribution of the 12 | software without specific, written prior permission. 13 | 14 | AT&T, Lucent and Bellcore disclaim all warranties with regard to 15 | this software, including all implied warranties of 16 | merchantability and fitness. In no event shall AT&T, Lucent or 17 | Bellcore be liable for any special, indirect or consequential 18 | damages or any damages whatsoever resulting from loss of use, 19 | data or profits, whether in an action of contract, negligence or 20 | other tortious action, arising out of or in connection with the 21 | use or performance of this software. 22 | ****************************************************************/ 23 | 24 | /* This file is included at the start of defs.h; this file 25 | * is an initial attempt to gather in one place some declarations 26 | * that may need to be tweaked on some systems. 27 | */ 28 | 29 | #ifdef __STDC__ 30 | #undef KR_headers 31 | #endif 32 | 33 | #ifndef KR_headers 34 | #ifndef ANSI_Libraries 35 | #define ANSI_Libraries 36 | #endif 37 | #ifndef ANSI_Prototypes 38 | #define ANSI_Prototypes 39 | #endif 40 | #endif 41 | 42 | #ifdef __BORLANDC__ 43 | #define MSDOS 44 | #endif 45 | 46 | #ifdef __ZTC__ /* Zortech */ 47 | #define MSDOS 48 | #endif 49 | 50 | #ifdef MSDOS 51 | #define ANSI_Libraries 52 | #define ANSI_Prototypes 53 | #define LONG_CAST (long) 54 | #else 55 | #define LONG_CAST 56 | #endif 57 | 58 | #include 59 | 60 | #ifdef ANSI_Libraries 61 | #include 62 | #include 63 | #else 64 | char *calloc(), *malloc(), *realloc(); 65 | void *memcpy(), *memset(); 66 | #ifndef _SIZE_T 67 | typedef unsigned int size_t; 68 | #endif 69 | #ifndef atol 70 | long atol(); 71 | #endif 72 | 73 | #ifdef ANSI_Prototypes 74 | extern double atof(const char *); 75 | extern double strtod(const char*, char**); 76 | #else 77 | extern double atof(), strtod(); 78 | #endif 79 | #endif 80 | 81 | /* On systems like VMS where fopen might otherwise create 82 | * multiple versions of intermediate files, you may wish to 83 | * #define scrub(x) unlink(x) 84 | */ 85 | #ifndef scrub 86 | #define scrub(x) /* do nothing */ 87 | #endif 88 | 89 | /* On systems that severely limit the total size of statically 90 | * allocated arrays, you may need to change the following to 91 | * extern char **chr_fmt, *escapes, **str_fmt; 92 | * and to modify sysdep.c appropriately 93 | */ 94 | extern char *chr_fmt[], escapes[], *str_fmt[]; 95 | 96 | #include 97 | 98 | #include "ctype.h" 99 | 100 | #define Bits_per_Byte 8 101 | #define Table_size (1 << Bits_per_Byte) 102 | -------------------------------------------------------------------------------- /src/sysdeptest.c: -------------------------------------------------------------------------------- 1 | /* This is never meant to be executed; we just want to check for the */ 2 | /* presence of mkdtemp and mkstemp by whether this links without error. */ 3 | 4 | #include 5 | #include 6 | #include 7 | 8 | int 9 | #ifdef KR_headers 10 | main(argc, argv) int argc; char **argv; 11 | #else 12 | main(int argc, char **argv) 13 | #endif 14 | { 15 | char buf[16]; 16 | if (argc < 0) { 17 | #ifndef NO_MKDTEMP 18 | mkdtemp(buf); 19 | #else 20 | mkstemp(buf); 21 | #endif 22 | } 23 | return 0; 24 | } 25 | -------------------------------------------------------------------------------- /src/tokens: -------------------------------------------------------------------------------- 1 | SEOS 2 | SCOMMENT 3 | SLABEL 4 | SUNKNOWN 5 | SHOLLERITH 6 | SICON 7 | SRCON 8 | SDCON 9 | SBITCON 10 | SOCTCON 11 | SHEXCON 12 | STRUE 13 | SFALSE 14 | SNAME 15 | SNAMEEQ 16 | SFIELD 17 | SSCALE 18 | SINCLUDE 19 | SLET 20 | SASSIGN 21 | SAUTOMATIC 22 | SBACKSPACE 23 | SBLOCK 24 | SCALL 25 | SCHARACTER 26 | SCLOSE 27 | SCOMMON 28 | SCOMPLEX 29 | SCONTINUE 30 | SDATA 31 | SDCOMPLEX 32 | SDIMENSION 33 | SDO 34 | SDOUBLE 35 | SELSE 36 | SELSEIF 37 | SEND 38 | SENDFILE 39 | SENDIF 40 | SENTRY 41 | SEQUIV 42 | SEXTERNAL 43 | SFORMAT 44 | SFUNCTION 45 | SGOTO 46 | SASGOTO 47 | SCOMPGOTO 48 | SARITHIF 49 | SLOGIF 50 | SIMPLICIT 51 | SINQUIRE 52 | SINTEGER 53 | SINTRINSIC 54 | SLOGICAL 55 | SNAMELIST 56 | SOPEN 57 | SPARAM 58 | SPAUSE 59 | SPRINT 60 | SPROGRAM 61 | SPUNCH 62 | SREAD 63 | SREAL 64 | SRETURN 65 | SREWIND 66 | SSAVE 67 | SSTATIC 68 | SSTOP 69 | SSUBROUTINE 70 | STHEN 71 | STO 72 | SUNDEFINED 73 | SWRITE 74 | SLPAR 75 | SRPAR 76 | SEQUALS 77 | SCOLON 78 | SCOMMA 79 | SCURRENCY 80 | SPLUS 81 | SMINUS 82 | SSTAR 83 | SSLASH 84 | SPOWER 85 | SCONCAT 86 | SAND 87 | SOR 88 | SNEQV 89 | SEQV 90 | SNOT 91 | SEQ 92 | SLT 93 | SGT 94 | SLE 95 | SGE 96 | SNE 97 | SENDDO 98 | SWHILE 99 | SSLASHD 100 | SBYTE 101 | -------------------------------------------------------------------------------- /src/usignal.h: -------------------------------------------------------------------------------- 1 | #include 2 | #ifndef SIGHUP 3 | #define SIGHUP 1 /* hangup */ 4 | #endif 5 | #ifndef SIGQUIT 6 | #define SIGQUIT 3 /* quit */ 7 | #endif 8 | -------------------------------------------------------------------------------- /src/version.c: -------------------------------------------------------------------------------- 1 | char F2C_version[] = "20240504"; 2 | char xxxvers[] = "\n@(#) FORTRAN 77 to C Translator, VERSION 20240504\n"; 3 | -------------------------------------------------------------------------------- /src/xsum.c: -------------------------------------------------------------------------------- 1 | /**************************************************************** 2 | Copyright 1990, 1993, 1994, 2000 by AT&T, Lucent Technologies and Bellcore. 3 | 4 | Permission to use, copy, modify, and distribute this software and its 5 | documentation for any purpose and without fee is hereby granted, 6 | provided that the above copyright notice appear in all copies and that 7 | both that the copyright notice and this permission notice and warranty 8 | disclaimer appear in supporting documentation, and that the names of 9 | AT&T, Bell Laboratories, Lucent or Bellcore or any of their entities 10 | not be used in advertising or publicity pertaining to distribution of 11 | the software without specific, written prior permission. 12 | 13 | AT&T, Lucent and Bellcore disclaim all warranties with regard to this 14 | software, including all implied warranties of merchantability and 15 | fitness. In no event shall AT&T or Bellcore be liable for any 16 | special, indirect or consequential damages or any damages whatsoever 17 | resulting from loss of use, data or profits, whether in an action of 18 | contract, negligence or other tortious action, arising out of or in 19 | connection with the use or performance of this software. 20 | ****************************************************************/ 21 | 22 | #undef _POSIX_SOURCE 23 | #define _POSIX_SOURCE 24 | #include "stdio.h" 25 | #ifndef KR_headers 26 | #include "stdlib.h" 27 | #include "sys/types.h" 28 | #ifndef MSDOS 29 | #include "unistd.h" /* for read, close */ 30 | #endif 31 | #include "fcntl.h" /* for declaration of open, O_RDONLY */ 32 | #endif 33 | #ifdef MSDOS 34 | #include "io.h" 35 | #endif 36 | #ifndef O_RDONLY 37 | #define O_RDONLY 0 38 | #endif 39 | #ifndef O_BINARY 40 | #define O_BINARY O_RDONLY 41 | #endif 42 | 43 | char *progname; 44 | static int ignore_cr; 45 | 46 | void 47 | #ifdef KR_headers 48 | usage(rc) 49 | #else 50 | usage(int rc) 51 | #endif 52 | { 53 | fprintf(stderr, "usage: %s [-r] [file [file...]]\n\ 54 | option -r ignores carriage return characters\n", progname); 55 | exit(rc); 56 | } 57 | 58 | typedef unsigned char Uchar; 59 | 60 | long 61 | #ifdef KR_headers 62 | sum32(sum, x, n) 63 | register long sum; 64 | register Uchar *x; 65 | int n; 66 | #else 67 | sum32(register long sum, register Uchar *x, int n) 68 | #endif 69 | { 70 | register Uchar *xe; 71 | static long crc_table[256] = { 72 | 0, 151466134, 302932268, 453595578, 73 | -9583591, -160762737, -312236747, -463170141, 74 | -19167182, -136529756, -321525474, -439166584, 75 | 28724267, 145849533, 330837255, 448732561, 76 | -38334364, -189783822, -273059512, -423738914, 77 | 47895677, 199091435, 282375505, 433292743, 78 | 57448534, 174827712, 291699066, 409324012, 79 | -67019697, -184128295, -300991133, -418902539, 80 | -76668728, -227995554, -379567644, -530091662, 81 | 67364049, 218420295, 369985021, 520795499, 82 | 95791354, 213031020, 398182870, 515701056, 83 | -86479645, -203465611, -388624945, -506380967, 84 | 114897068, 266207290, 349655424, 500195606, 85 | -105581387, -256654301, -340093543, -490887921, 86 | -134039394, -251295736, -368256590, -485758684, 87 | 124746887, 241716241, 358686123, 476458301, 88 | -153337456, -2395898, -455991108, -304803798, 89 | 162629001, 11973919, 465560741, 314102835, 90 | 134728098, 16841012, 436840590, 319723544, 91 | -144044613, -26395347, -446403433, -329032703, 92 | 191582708, 40657250, 426062040, 274858062, 93 | -200894995, -50223749, -435620671, -284179369, 94 | -172959290, -55056048, -406931222, -289830788, 95 | 182263263, 64630089, 416513267, 299125861, 96 | 229794136, 78991822, 532414580, 381366498, 97 | -220224191, -69691945, -523123603, -371788549, 98 | -211162774, -93398532, -513308602, -396314416, 99 | 201600371, 84090341, 503991391, 386759881, 100 | -268078788, -117292630, -502591472, -351526778, 101 | 258520357, 107972019, 493278217, 341959839, 102 | 249493774, 131713432, 483432482, 366454964, 103 | -239911657, -122417791, -474129349, -356881235, 104 | -306674912, -457198666, -4791796, -156118374, 105 | 315967289, 466778031, 14362133, 165418627, 106 | 325258002, 442776452, 23947838, 141187752, 107 | -334573813, -452329571, -33509849, -150495567, 108 | 269456196, 419996626, 33682024, 184992510, 109 | -278767779, -429561909, -43239823, -194312473, 110 | -288089226, -405591072, -52790694, -170046772, 111 | 297394031, 415166457, 62373443, 179343061, 112 | 383165416, 533828478, 81314500, 232780370, 113 | -373594127, -524527769, -72022307, -223201717, 114 | -401789990, -519431348, -100447498, -217810336, 115 | 392228803, 510123861, 91131631, 208256633, 116 | -345918580, -496598246, -110112096, -261561802, 117 | 336361365, 487278339, 100800185, 251995695, 118 | 364526526, 482151208, 129260178, 246639108, 119 | -354943065, -472854735, -119955829, -237064675, 120 | 459588272, 308539942, 157983644, 7181066, 121 | -469170519, -317835713, -167286907, -16754925, 122 | -440448382, -323454444, -139383890, -21619912, 123 | 450006683, 332774925, 148697015, 31186721, 124 | -422325548, -271261118, -186797064, -36011154, 125 | 431888077, 280569435, 196114401, 45565815, 126 | 403200742, 286222960, 168180682, 50400092, 127 | -412770561, -295522711, -177471533, -59977915, 128 | -536157576, -384970002, -234585260, -83643454, 129 | 526853729, 375396087, 225003341, 74348507, 130 | 517040714, 399923932, 215944038, 98057200, 131 | -507728301, -390357307, -206385281, -88735767, 132 | 498987548, 347783818, 263426864, 112501670, 133 | -489671163, -338229613, -253864151, -103192641, 134 | -479823314, -362722632, -244835582, -126932076, 135 | 470531639, 353144481, 235265819, 117632909 136 | }; 137 | 138 | xe = x + n; 139 | while(x < xe) 140 | sum = crc_table[(sum ^ *x++) & 0xff] ^ (sum >> 8 & 0xffffff); 141 | return sum; 142 | } 143 | 144 | int 145 | #ifdef KR_headers 146 | cr_purge(buf, n) 147 | Uchar *buf; 148 | int n; 149 | #else 150 | cr_purge(Uchar *buf, int n) 151 | #endif 152 | { 153 | register Uchar *b, *b1, *be; 154 | b = buf; 155 | be = b + n; 156 | while(b < be) 157 | if (*b++ == '\r') { 158 | b1 = b - 1; 159 | while(b < be) 160 | if ((*b1 = *b++) != '\r') 161 | b1++; 162 | return b1 - buf; 163 | } 164 | return n; 165 | } 166 | 167 | static Uchar Buf[16*1024]; 168 | 169 | void 170 | #ifdef KR_headers 171 | process(s, x) 172 | char *s; 173 | int x; 174 | #else 175 | process(char *s, int x) 176 | #endif 177 | { 178 | register int n; 179 | long fsize, sum; 180 | 181 | sum = 0; 182 | fsize = 0; 183 | while((n = read(x, (char *)Buf, sizeof(Buf))) > 0) { 184 | if (ignore_cr) 185 | n = cr_purge(Buf, n); 186 | fsize += n; 187 | sum = sum32(sum, Buf, n); 188 | } 189 | sum &= 0xffffffff; 190 | if (n==0) 191 | printf("%s\t%lx\t%ld\n", s, sum & 0xffffffff, fsize); 192 | else { perror(s); } 193 | close(x); 194 | } 195 | 196 | int 197 | #ifdef KR_headers 198 | main(argc, argv) 199 | char **argv; 200 | #else 201 | main(int argc, char **argv) 202 | #endif 203 | { 204 | int x; 205 | char *s; 206 | static int rc; 207 | 208 | progname = *argv; 209 | argc = argc; /* turn off "not used" warning */ 210 | s = *++argv; 211 | if (s && *s == '-') { 212 | switch(s[1]) { 213 | case '?': 214 | usage(0); 215 | case 'r': 216 | ignore_cr = 1; 217 | case '-': 218 | break; 219 | default: 220 | fprintf(stderr, "invalid option %s\n", s); 221 | usage(1); 222 | } 223 | s = *++argv; 224 | } 225 | if (s) do { 226 | x = open(s, O_RDONLY|O_BINARY); 227 | if (x < 0) { 228 | fprintf(stderr, "%s: can't open %s\n", progname, s); 229 | rc |= 1; 230 | } 231 | else 232 | process(s, x); 233 | } 234 | while((s = *++argv)); 235 | else { 236 | process("/dev/stdin", fileno(stdin)); 237 | } 238 | return rc; 239 | } 240 | -------------------------------------------------------------------------------- /src/xsum0.out: -------------------------------------------------------------------------------- 1 | Notice 76f23b4 1212 2 | README f92ed640 8656 3 | cds.c 147aded1 4221 4 | data.c 32116b2 10688 5 | defines.h fd9fa7c5 8720 6 | defs.h f1324ea7 34590 7 | equiv.c fdeff25 9340 8 | error.c ef1dd812 5015 9 | exec.c e8f52ce0 21217 10 | expr.c 14bdc5da 72270 11 | f2c.1 69261bd 7791 12 | f2c.1t 1e96145e 7845 13 | f2c.h 1821c855 4706 14 | format.c 177017a3 60177 15 | format.h b396862 458 16 | formatdata.c 13bf4a7a 29060 17 | ftypes.h e2533d86 1836 18 | gram.c ff367120 64093 19 | gram.dcl 1971778e 8585 20 | gram.exec e20ca496 3033 21 | gram.expr eca86241 3193 22 | gram.head e35e29e8 7383 23 | gram.io 101f7521 3350 24 | init.c fe1abab5 11833 25 | intr.c ecab41aa 25006 26 | io.c 1739e50 30664 27 | iob.h ece45655 548 28 | lex.c 1b0d5df9 34746 29 | machdefs.h 4950e5b 659 30 | main.c 468e0c 21769 31 | makefile.u e0dd1cab 3710 32 | makefile.vc eb8aae7c 2685 33 | malloc.c 3505600 4020 34 | mem.c ad64d7c 5437 35 | memset.c 12a1e1aa 2121 36 | misc.c 8d99c9 22945 37 | names.c fa887031 21553 38 | names.h 110806d6 569 39 | niceprintf.c 141fb644 10950 40 | niceprintf.h c31f08c 412 41 | output.c ff23aa0b 43483 42 | output.h fa6797d9 2103 43 | p1defs.h 1b02743 5741 44 | p1output.c ff485aba 14681 45 | parse.h 18d34e6b 1119 46 | parse_args.c eb2fd4ea 14145 47 | pccdefs.h 1b4fbbee 1195 48 | pread.c fb4d5427 17831 49 | proc.c b4c8a9b 39337 50 | put.c af0be95 10345 51 | putpcc.c 7669b2f 46093 52 | sysdep.c eef0a794 15934 53 | sysdep.h e7826434 2755 54 | sysdeptest.c 449a7d0 428 55 | tokens 188b7c5d 733 56 | usignal.h 1c4ce909 124 57 | vax.c 8b21b83 12436 58 | version.c e5ab1294 107 59 | xsum.c e52f7b45 6655 60 | --------------------------------------------------------------------------------