pax_global_header00006660000000000000000000000064117164703000014511gustar00rootroot0000000000000052 comment=d4b8dfcccf7a1fa0ec4a72136efabcdb676c9584 f2c/000077500000000000000000000000001171647030000115275ustar00rootroot00000000000000f2c/.list000066400000000000000000000000231171647030000124760ustar00rootroot00000000000000jcarbaut@myway.com f2c/.master000066400000000000000000000001641171647030000130240ustar00rootroot00000000000000lib f2c for converting Fortran to C by Feldman, Gay, Maimone, and Schryer editor David Gay master ornl.gov gams s1 f2c/README000066400000000000000000000174451171647030000124220ustar00rootroot00000000000000To compile f2c on Linux or Unix systems, copy makefile.u to makefile, edit makefile if necessary (see the comments in it and below) and type "make" (or maybe "nmake", depending on your system). To compile f2c.exe on MS Windows systems with Microsoft Visual C++, copy makefile.vc makefile nmake With other PC compilers, you may need to compile xsum.c with -DMSDOS (i.e., with MSDOS #defined). If your compiler does not understand ANSI/ISO C syntax (i.e., if you have a K&R C compiler), compile with -DKR_headers . On non-Unix systems where files have separate binary and text modes, you may need to "make xsumr.out" rather than "make xsum.out". If (in accordance with what follows) you need to any of the source files (excluding the makefile), first issue a "make xsum.out" (or, if appropriate, "make xsumr.out") to check the validity of the f2c source, then make your changes, then type "make f2c". The file usignal.h is for the benefit of strictly ANSI include files on a UNIX system -- the ANSI signal.h does not define SIGHUP or SIGQUIT. You may need to modify usignal.h if you are not running f2c on a UNIX system. Should you get the message "xsum0.out xsum1.out differ", see what lines are different (`diff xsum0.out xsum1.out`) and ask netlib (e.g., netlib@netlib.org) to send you the files in question, plus the current xsum0.out (which may have changed) "from f2c/src". For example, if exec.c and expr.c have incorrect check sums, you would send netlib the message send exec.c expr.c xsum0.out from f2c/src You can also ftp these files from netlib.bell-labs.com; for more details, ask netlib@netlib.org to "send readme from f2c". On some systems, the malloc and free in malloc.c let f2c run faster than do the standard malloc and free. Other systems may not tolerate redefinition of malloc and free (though changes of 8 Nov. 1994 may render this less of a problem than hitherto). If your system permits use of a user-supplied malloc, you may wish to change the MALLOC = line in the makefile to "MALLOC = malloc.o", or to type make MALLOC=malloc.o instead of make Still other systems have a -lmalloc that provides performance competitive with that from malloc.c; you may wish to compare the two on your system. If your system does not permit user-supplied malloc routines, then f2c may fault with "MALLOC=malloc.o", or may display other untoward behavior. On some BSD systems, you may need to create a file named "string.h" whose single line is #include you may need to add " -Dstrchr=index" to the "CFLAGS =" assignment in the makefile, and you may need to add " memset.o" to the "OBJECTS =" assignment in the makefile -- see the comments in memset.c . For non-UNIX systems, you may need to change some things in sysdep.c, such as the choice of intermediate file names. On some systems, you may need to modify parts of sysdep.h (which is included by defs.h). In particular, for Sun 4.1 systems and perhaps some others, you need to comment out the typedef of size_t. For some systems (e.g., IRIX 4.0.1 and AIX) it is better to add #define ANSI_Libraries to the beginning of sysdep.h (or to supply -DANSI_Libraries in the makefile). Alas, some systems #define __STDC__ but do not provide a true standard (ANSI or ISO) C environment, e.g. do not provide stdlib.h . If yours is such a system, then (a) you should complain loudly to your vendor about __STDC__ being erroneously defined, and (b) you should insert #undef __STDC__ at the beginning of sysdep.h . You may need to make other adjustments. For some non-ANSI versions of stdio, you must change the values given to binread and binwrite in sysdep.c from "rb" and "wb" to "r" and "w". You may need to make this change if you run f2c and get an error message of the form Compiler error ... cannot open intermediate file ... In the days of yore, two libraries, libF77 and libI77, were used with f77 (the Fortran compiler on which f2c is based). Separate source for these libraries is still available from netlib, but it is more convenient to combine them into a single library, libf2c. Source for this combined library is also available from netlib in f2c/libf2c.zip, e.g., http://netlib.bell-labs.com/netlib/f2c/libf2c.zip or http://www.netlib.org/f2c/libf2c.zip (and similarly for other netlib mirrors). After unzipping libf2c.zip, copy the relevant makefile.* to makefile, edit makefile if necessary (see the comments in it and in libf2c/README) and invoke "make" or "nmake". The resulting library is called *f2c.lib on MS Windows systems and libf2c.a or libf2c.so on Linux and Unix systems; makefile.u just shows how to make libf2c.a. Details on creating the shared-library variant, libf2c.so, are system-dependent; some that have worked under Linux appear below. For some other systems, you can glean the details from the system-dependent makefile variants in directory http://www.netlib.org/ampl/solvers/funclink or http://netlib.bell-labs.com/netlib/ampl/solvers/funclink, etc. In general, under Linux it is necessary to compile libf2c (or libI77) with -DNON_UNIX_STDIO . Under at least one variant of Linux, you can make and install a shared-library version of libf2c by compiling libI77 with -DNON_UNIX_STDIO, creating libf2c.a as above, and then executing mkdir t ln lib?77/*.o t cd t; cc -shared -o ../libf2c.so -Wl,-soname,libf2c.so.1 *.o cd .. rm -r t rm /usr/lib/libf2c* mv libf2c.a libf2c.so /usr/lib cd /usr/lib ln libf2c.so libf2c.so.1 ln libf2c.so libf2c.so.1.0.0 On some other systems, /usr/local/lib is the appropriate installation directory. Some older C compilers object to typedef void (*foo)(); or to typedef void zap; zap (*foo)(); If yours is such a compiler, change the definition of VOID in f2c.h from void to int. For convenience with systems that use control-Z to denote end-of-file, f2c treats control-Z characters (ASCII 26, '\x1a') that appear at the beginning of a line as an end-of-file indicator. You can disable this test by compiling lex.c with NO_EOF_CHAR_CHECK #defined, or can change control-Z to some other character by #defining EOF_CHAR to be the desired value. If your machine has IEEE, VAX, or IBM-mainframe arithmetic, but your printf is inaccurate (e.g., with Symantec C++ version 6.0, printf("%.17g",12.) prints 12.000000000000001), you can make f2c print correctly rounded numbers by compiling with -DUSE_DTOA and adding dtoa.o g_fmt.o to the makefile's OBJECTS = line, so it becomes OBJECTS = $(OBJECTSd) malloc.o dtoa.o g_fmt.o Also add the rule dtoa.o: dtoa.c $(CC) -c $(CFLAGS) -DMALLOC=ckalloc -DIEEE... dtoa.c (without the initial tab) to the makefile, where IEEE... is one of IEEE_MC68k, IEEE_8087, VAX, or IBM, depending on your machine's arithmetic. See the comments near the start of dtoa.c. The relevant source files, dtoa.c and g_fmt.c, are available separately from netlib's fp directory. For example, you could send the E-mail message send dtoa.c g_fmt.c from fp to netlib@netlib.netlib.org (or use anonymous ftp from ftp.netlib.org and look in directory /netlib/fp). The makefile has a rule for creating tokdefs.h. If you cannot use the makefile, an alternative is to extract tokdefs.h from the beginning of gram.c: it's the first 100 lines. File mem.c has #ifdef CRAY lines that are appropriate for machines with the conventional CRAY architecture, but not for "Cray" machines based on DEC Alpha chips, such as the T3E; on such machines, you may need to make a suitable adjustment, e.g., add #undef CRAY to sysdep.h. Please send bug reports to dmg at acm.org (with " at " changed to "@"). The old index file (now called "readme" due to unfortunate changes in netlib conventions: "send readme from f2c") will report recent changes in the recent-change log at its end; all changes will be shown in the "changes" file ("send changes from f2c"). To keep current source, you will need to request xsum0.out and version.c, in addition to the changed source files. f2c/changes000066400000000000000000004105031171647030000130650ustar00rootroot0000000000000031 Aug. 1989: 1. A(min(i,j)) now is translated correctly (where A is an array). 2. 7 and 8 character variable names are allowed (but elicit a complaint under -ext). 3. LOGICAL*1 is treated as LOGICAL, with just one error message per LOGICAL*1 statement (rather than one per variable declared in that statement). [Note that LOGICAL*1 is not in Fortran 77.] Like f77, f2c now allows the format in a read or write statement to be an integer array. 5 Sept. 1989: Fixed botch in argument passing of substrings of equivalenced variables. 15 Sept. 1989: Warn about incorrect code generated when a character-valued function is not declared external and is passed as a parameter (in violation of the Fortran 77 standard) before it is invoked. Example: subroutine foo(a,b) character*10 a,b call goo(a,b) b = a(3) end 18 Sept. 1989: Complain about overlapping initializations. 20 Sept. 1989: Warn about names declared EXTERNAL but never referenced; include such names as externs in the generated C (even though most C compilers will discard them). 24 Sept. 1989: New option -w8 to suppress complaint when COMMON or EQUIVALENCE forces word alignment of a double. Under -A (for ANSI C), ensure that floating constants (terminated by 'f') contain either a decimal point or an exponent field. Repair bugs sometimes encountered with CHAR and ICHAR intrinsic functions. Restore f77's optimizations for copying and comparing character strings of length 1. Always assume floating-point valued routines in libF77 return doubles, even under -R. Repair occasional omission of arguments in routines having multiple entry points. Repair bugs in computing offsets of character strings involved in EQUIVALENCE. Don't omit structure qualification when COMMON variables are used as FORMATs or internal files. 2 Oct. 1989: Warn about variables that appear only in data stmts; don't emit them. Fix bugs in character DATA for noncharacter variables involved in EQUIVALENCE. Treat noncharacter variables initialized (at least partly) with character data as though they were equivalenced -- put out a struct and #define the variables. This eliminates the hideous and nonportable numeric values that were used to initialize such variables. Treat IMPLICIT NONE as IMPLICIT UNDEFINED(A-Z) . Quit when given invalid options. 8 Oct. 1989: Modified naming scheme for generated intermediate variables; more are recycled, fewer distinct ones used. New option -W nn specifies nn characters/word for Hollerith data initializing non-character variables. Bug fix: x(i:min(i+10,j)) used to elicit "Can't handle opcode 31 yet". Integer expressions of the form (i+const1) - (i+const2), where i is a scalar integer variable, are now simplified to (const1-const2); this leads to simpler translation of some substring expressions. Initialize uninitialized portions of character string arrays to 0 rather than to blanks. 9 Oct. 1989: New option -c to insert comments showing original Fortran source. New option -g to insert line numbers of original Fortran source. 10 Oct. 1989: ! recognized as in-line comment delimiter (a la Fortran 88). 24 Oct. 1989: New options to ease coping with systems that want the structs that result from COMMON blocks to be defined just once: -E causes uninitialized COMMON blocks to be declared Extern; if Extern is undefined, f2c.h #defines it to be extern. -ec causes a separate .c file to be emitted for each uninitialized COMMON block: COMMON /ABC/ yields abc_com.c; thus one can compile *_com.c into a library to ensure precisely one definition. -e1c is similar to -ec, except that everything goes into one file, along with comments that give a sed script for splitting the file into the pieces that -ec would give. This is for use with netlib's "execute f2c" service (for which -ec is coerced into -e1c, and the sed script will put everything but the COMMON definitions into f2c_out.c ). 28 Oct. 1989: Convert "i = i op ..." into "i op= ...;" even when i is a dummy argument. 13 Nov. 1989: Name integer constants (passed as arguments) c__... rather than c_... so common /c/stuff call foo(1) ... is translated correctly. 19 Nov. 1989: Floating-point constants are now kept as strings unless they are involved in constant expressions that get simplified. The floating-point constants kept as strings can have arbitrarily many significant figures and a very large exponent field (as large as long int allows on the machine on which f2c runs). Thus, for example, the body of subroutine zot(x) double precision x(6), pi parameter (pi=3.1415926535897932384626433832795028841972) x(1) = pi x(2) = pi+1 x(3) = 9287349823749272.7429874923740978492734D-298374 x(4) = .89 x(5) = 4.0005 x(6) = 10D7 end now gets translated into x[1] = 3.1415926535897932384626433832795028841972; x[2] = 4.1415926535897931; x[3] = 9.2873498237492727429874923740978492734e-298359; x[4] = (float).89; x[5] = (float)4.0005; x[6] = 1e8; rather than the former x[1] = 3.1415926535897931; x[2] = 4.1415926535897931; x[3] = 0.; x[4] = (float)0.89000000000000003; x[5] = (float)4.0004999999999997; x[6] = 100000000.; Recognition of f77 machine-constant intrinsics deleted, i.e., epbase, epprec, epemin, epemax, eptiny, ephuge, epmrsp. 22 Nov. 1989: Workarounds for glitches on some Sun systems... libf77: libF77/makefile modified to point out possible need to compile libF77/main.c with -Donexit=on_exit . libi77: libI77/wref.c (and libI77/README) modified so non-ANSI systems can compile with USE_STRLEN defined, which will cause sprintf(b = buf, "%#.*f", d, x); n = strlen(b) + d1; rather than n = sprintf(b = buf, "%#.*f", d, x) + d1; to be compiled. 26 Nov. 1989: Longer names are now accepted (up to 50 characters); names may contain underscores (in which case they will have two underscores appended, to avoid clashes with library names). 28 Nov. 1989: libi77 updated: 1. Allow 3 (or, on Crays, 4) digit exponents under format Ew.d . 2. Try to get things right on machines where ints have 16 bits. 29 Nov. 1989: Supplied missing semicolon in parameterless subroutines that have multiple entry points (all of them parameterless). 30 Nov. 1989: libf77 and libi77 revised to use types from f2c.h. f2c now types floating-point valued C library routines as "double" rather than "doublereal" (for use with nonstandard C compilers for which "double" is IEEE double extended). 1 Dec. 1989: f2c.h updated to eliminate #defines rendered unnecessary (and, indeed, dangerous) by change of 26 Nov. to long names possibly containing underscores. libi77 further revised: yesterday's change omitted two tweaks to fmt.h (tweaks which only matter if float and real or double and doublereal are different types). 2 Dec. 1989: Better error message (than "bad tag") for NAMELIST, which no longer inhibits C output. 4 Dec. 1989: Allow capital letters in hex constants (f77 extension; e.g., x'a012BCd', X'A012BCD' and x'a012bcd' are all treated as the integer 167848909). libi77 further revised: lio.c lio.h lread.c wref.c wrtfmt.c tweaked again to allow float and real or double and doublereal to be different. 6 Dec. 1989: Revised f2c.h -- required for the following... Simpler looking translations for abs, min, max, using #defines in revised f2c.h . libi77: more corrections to types; additions for NAMELIST. Corrected casts in some I/O calls. Translation of NAMELIST; libi77 must still be revised. Currently libi77 gives you a run-time error message if you attempt NAMELIST I/O. 7 Dec. 1989: Fixed bug that prevented local integer variables that appear in DATA stmts from being ASSIGNed statement labels. Fillers (for DATA statements initializing EQUIVALENCEd variables and variables in COMMON) typed integer rather than doublereal (for slightly more portability, e.g. to Crays). libi77: missing return values supplied in a few places; some tests reordered for better working on the Cray. libf77: better accuracy for complex divide, complex square root, real mod function (casts to double; double temporaries). 9 Dec. 1989: Fixed bug that caused needless (albeit harmless) empty lines to be inserted in the C output when a comment line contained trailing blanks. Further tweak to type of fillers: allow doublereal fillers if the struct has doublereal data. 11 Dec. 1989: Alteration of rule for producing external (C) names from names that contain underscores. Now the external name is always obtained by appending a pair of underscores. 12 Dec. 1989: C production inhibited after most errors. 15 Dec. 1989: Fixed bug in headers for subroutines having two or more character strings arguments: the length arguments were reversed. 19 Dec. 1989: f2c.h libf77 libi77: adjusted so #undefs in f2c.h should not foil compilation of libF77 and libI77. libf77: getenv_ adjusted to work with unsorted environments. libi77: the iostat= specifier should now work right with internal I/O. 20 Dec. 1989: f2c bugs fixed: In the absence of an err= specifier, the iostat= specifier was generally set wrong. Character strings containing explicit nulls (\0) were truncated at the first null. Unlabeled DO loops recognized; must be terminated by ENDDO. (Don't ask for CYCLE, EXIT, named DO loops, or DO WHILE.) 29 Dec. 1989: Nested unlabeled DO loops now handled properly; new warning for extraneous text at end of FORMAT. 30 Dec. 1989: Fixed bug in translating dble(real(...)), dble(sngl(...)), and dble(float(...)), where ... is either of type double complex or is an expression requiring assignment to intermediate variables (e.g., dble(real(foo(x+1))), where foo is a function and x is a variable). Regard nonblank label fields on continuation lines as an error. 3 Jan. 1990: New option -C++ yields output that should be understood by C++ compilers. 6 Jan. 1989: -a now excludes variables that appear in a namelist from those that it makes automatic. (As before, it also excludes variables that appear in a common, data, equivalence, or save statement.) The syntactically correct Fortran read(*,i) x end now yields syntactically correct C (even though both the Fortran and C are buggy -- no FORMAT has not been ASSIGNed to i). 7 Jan. 1990: libi77: routines supporting NAMELIST added. Surrounding quotes made optional when no ambiguity arises in a list or namelist READ of a character-string value. 9 Jan. 1990: f2c.src made available. 16 Jan. 1990: New options -P to produce ANSI C or C++ prototypes for procedures defined. Change to -A and -C++: f2c tries to infer prototypes for invoked procedures unless the new -!P option is given. New warning messages for inconsistent calling sequences among procedures within a single file. Most of f2c/src is affected. f2c.h: typedefs for procedure arguments added; netlib's f2c service will insert appropriate typedefs for use with older versions of f2c.h. 17 Jan. 1990: f2c/src: defs.h exec.c format.c proc.c putpcc.c version.c xsum0.out updated. Castargs and protofile made extern in defs.h; exec.c modified so superfluous else clauses are diagnosed; unused variables omitted from declarations in format.c proc.c putpcc.c . 21 Jan. 1990: No C emitted for procedures declared external but not referenced. f2c.h: more new types added for use with -P. New feature: f2c accepts as arguments files ending in .p or .P; such files are assumed to be prototype files, such as produced by the -P option. All prototype files are read before any Fortran files and apply globally to all Fortran files. Suitable prototypes help f2c warn about calling-sequence errors and can tell f2c how to type procedures declared external but not explicitly typed; the latter is mainly of interest for users of the -A and -C++ options. (Prototype arguments are not available to netlib's "execute f2c" service.) New option -it tells f2c to try to infer types of untyped external arguments from their use as parameters to prototyped or previously defined procedures. f2c/src: many minor cleanups; most modules changed. Individual files in f2c/src are now in "bundle" format. The former f2c.1 is now f2c.1t; "f2c.1t from f2c" and "f2c.1t from f2c/src" are now the same, as are "f2c.1 from f2c" and "f2c.1 from f2c/src". People who do not obtain a new copy of "all from f2c/src" should at least add fclose(sortfp); after the call on do_init_data(outfile, sortfp) in format_data.c . 22 Jan. 1990: Cleaner man page wording (thanks to Doug McIlroy). -it now also applies to all untyped EXTERNAL procedures, not just arguments. 23 Jan. 01:34:00 EST 1990: Bug fixes: under -A and -C++, incorrect C was generated for subroutines having multiple entries but no arguments. Under -A -P, subroutines of no arguments were given prototype calling sequence () rather than (void). Character-valued functions elicited erroneous warning messages about inconsistent calling sequences when referenced by another procedure in the same file. f2c.1t: omit first appearance of libF77.a in FILES section; load order of libraries is -lF77 -lI77, not vice versa (bug introduced in yesterday's edits); define .F macro for those whose -man lacks it. (For a while after yesterday's fixes were posted, f2c.1t was out of date. Sorry!) 23 Jan. 9:53:24 EST 1990: Character substring expressions involving function calls having character arguments (including the intrinsic len function) yielded incorrect C. Procedures defined after invocation (in the same file) with conflicting argument types also got an erroneous message about the wrong number of arguments. 24 Jan. 11:44:00 EST 1990: Bug fixes: -p omitted #undefs; COMMON block names containing underscores had their C names incorrectly computed; a COMMON block having the name of a previously defined procedure wreaked havoc; if all arguments were .P files, f2c tried reading the second as a Fortran file. New feature: -P emits comments showing COMMON block lengths, so one can get warnings of incompatible COMMON block lengths by having f2c read .P (or .p) files. Now by running f2c twice, first with -P -!c (or -P!c), then with *.P among the arguments, you can be warned of inconsistent COMMON usage, and COMMON blocks having inconsistent lengths will be given the maximum length. (The latter always did happen within each input file; now -P lets you extend this behavior across files.) 26 Jan. 16:44:00 EST 1990: Option -it made less aggressive: untyped external procedures that are invoked are now typed by the rules of Fortran, rather than by previous use of procedures to which they are passed as arguments before being invoked. Option -P now includes information about references, i.e., called procedures, in the prototype files (in the form of special comments). This allows iterative invocations of f2c to infer more about untyped external names, particularly when multiple Fortran files are involved. As usual, there are some obscure bug fixes: 1. Repair of erroneous warning messages about inconsistent number of arguments that arose when a character dummy parameter was discovered to be a function or when multiple entry points involved character variables appearing in a previous entry point. 2. Repair of memory fault after error msg about "adjustable character function". 3. Under -U, allow MAIN_ as a subroutine name (in the same file as a main program). 4. Change for consistency: a known function invoked as a subroutine, then as a function elicits a warning rather than an error. 26 Jan. 22:32:00 EST 1990: Fixed two bugs that resulted in incorrect C for substrings, within the body of a character-valued function, of the function's name, when those substrings were arguments to another function (even implicitly, as in character-string assignment). 28 Jan. 18:32:00 EST 1990: libf77, libi77: checksum files added; "make check" looks for transmission errors. NAMELIST read modified to allow $ rather than & to precede a namelist name, to allow $ rather than / to terminate input where the name of another variable would otherwise be expected, and to regard all nonprinting ASCII characters <= ' ' as spaces. 29 Jan. 02:11:00 EST 1990: "fc from f2c" added. -it option made the default; -!it turns it off. Type information is now updated in a previously missed case. -P option tweaked again; message about when rerunning f2c may change prototypes or declarations made more accurate. New option -Ps implies -P and returns exit status 4 if rerunning f2c -P with prototype inputs might change prototypes or declarations. Now you can execute a crude script like cat *.f >zap.F rm -f zap.P while :; do f2c -Ps -!c zap.[FP] case $? in 4) ;; *) break;; esac done to get a file zap.P of the best prototypes f2c can determine for *.f . Jan. 29 07:30:21 EST 1990: Forgot to check for error status when setting return code 4 under -Ps; error status (1, 2, 3, or, for caught signal, 126) now takes precedence. Jan 29 14:17:00 EST 1990: Incorrect handling of open(n,'filename') repaired -- now treated as open(n,file='filename') (and, under -ext, given an error message). New optional source file memset.c for people whose systems don't provide memset, memcmp, and memcpy; #include in mem.c changed to #include "string.h" so BSD people can create a local string.h that simply says #include . Jan 30 10:34:00 EST 1990: Fix erroneous warning at end of definition of a procedure with character arguments when the procedure had previously been called with a numeric argument instead of a character argument. (There were two warnings, the second one incorrectly complaining of a wrong number of arguments.) Jan 30 16:29:41 EST 1990: Fix case where -P and -Ps erroneously reported another iteration necessary. (Only harm is the extra iteration.) Feb 3 01:40:00 EST 1990: Supply semicolon occasionally omitted under -c . Try to force correct alignment when numeric variables are initialized with character data (a non-standard and non-portable practice). You must use the -W option if your code has such data statements and is meant to run on a machine with other than 4 characters/word; e.g., for code meant to run on a Cray, you would specify -W8 . Allow parentheses around expressions in output lists (in write and print statements). Rename source files so their names are <= 12 characters long (so there's room to append .Z and still have <= 14 characters); renamed files: formatdata.c niceprintf.c niceprintf.h safstrncpy.c . f2c material made available by anonymous ftp from research.att.com (look in dist/f2c ). Feb 3 03:49:00 EST 1990: Repair memory fault that arose from use (in an assignment or call) of a non-argument variable declared CHARACTER*(*). Feb 9 01:35:43 EST 1990: Fix erroneous error msg about bad types in subroutine foo(a,adim) dimension a(adim) integer adim Fix improper passing of character args (and possible memory fault) in the expression part of a computed goto. Fix botched calling sequences in array references involving functions having character args. Fix memory fault caused by invocation of character-valued functions of no arguments. Fix botched calling sequence of a character*1-valued function assigned to a character*1 variable. Fix bug in error msg for inconsistent number of args in prototypes. Allow generation of C output despite inconsistencies in prototypes, but give exit code 8. Simplify include logic (by removing some bogus logic); never prepend "/usr/include/" to file names. Minor cleanups (that should produce no visible change in f2c's behavior) in intr.c parse.h main.c defs.h formatdata.c p1output.c . Feb 10 00:19:38 EST 1990: Insert (integer) casts when floating-point expressions are used as subscripts. Make SAVE stmt (with no variable list) override -a . Minor cleanups: change field to Field in struct Addrblock (for the benefit of buggy C compilers); omit system("/bin/cp ...") in misc.c . Feb 13 00:39:00 EST 1990: Error msg fix in gram.dcl: change "cannot make %s parameter" to "cannot make into parameter". Feb 14 14:02:00 EST 1990: Various cleanups (invisible on systems with 4-byte ints), thanks to Dave Regan: vaxx.c eliminated; %d changed to %ld various places; external names adjusted for the benefit of stupid systems (that ignore case and recognize only 6 significant characters in external names); buffer shortened in xsum.c (e.g. for MS-DOS); fopen modes distinguish text and binary files; several unused functions eliminated; missing arg supplied to an unlikely fatalstr invocation. Thu Feb 15 19:15:53 EST 1990: More cleanups (invisible on systems with 4 byte ints); casts inserted so most complaints from cyntax(1) and lint(1) go away; a few (int) versus (long) casts corrected. Fri Feb 16 19:55:00 EST 1990: Recognize and translate unnamed Fortran 8x do while statements. Fix bug that occasionally caused improper breaking of character strings. New error message for attempts to provide DATA in a type-declaration statement. Sat Feb 17 11:43:00 EST 1990: Fix infinite loop clf -> Fatal -> done -> clf after I/O error. Change "if (addrp->vclass = CLPROC)" to "if (addrp->vclass == CLPROC)" in p1_addr (in p1output.c); this was probably harmless. Move a misplaced } in lex.c (which slowed initkey()). Thanks to Gary Word for pointing these things out. Sun Feb 18 18:07:00 EST 1990: Detect overlapping initializations of arrays and scalar variables in previously missed cases. Treat logical*2 as logical (after issuing a warning). Don't pass string literals to p1_comment(). Correct a cast (introduced 16 Feb.) in gram.expr; this matters e.g. on a Cray. Attempt to isolate UNIX-specific things in sysdep.c (a new source file). Unless sysdep.c is compiled with SYSTEM_SORT defined, the intermediate files created for DATA statements are now sorted in-core without invoking system(). Tue Feb 20 16:10:35 EST 1990: Move definition of binread and binwrite from init.c to sysdep.c . Recognize Fortran 8x tokens < <= == >= > <> as synonyms for .LT. .LE. .EQ. .GE. .GT. .NE. Minor cleanup in putpcc.c: fully remove simoffset(). More discussion of system dependencies added to libI77/README. Tue Feb 20 21:44:07 EST 1990: Minor cleanups for the benefit of EBCDIC machines -- try to remove the assumption that 'a' through 'z' are contiguous. (Thanks again to Gary Word.) Also, change log2 to log_2 (shouldn't be necessary). Wed Feb 21 06:24:56 EST 1990: Fix botch in init.c introduced in previous change; only matters to non-ASCII machines. Thu Feb 22 17:29:12 EST 1990: Allow several entry points to mention the same array. Protect parameter adjustments with if's (for the case that an array is not an argument to all entrypoints). Under -u, allow subroutine foo(x,n) real x(n) integer n Compute intermediate variables used to evaluate dimension expressions at the right time. Example previously mistranslated: subroutine foo(x,k,m,n) real x(min(k,m,n)) ... write(*,*) x Detect duplicate arguments. (The error msg points to the first executable stmt -- not wonderful, but not worth fixing.) Minor cleanup of min/max computation (sometimes slightly simpler). Sun Feb 25 09:39:01 EST 1990: Minor tweak to multiple entry points: protect parameter adjustments with if's only for (array) args that do not appear in all entry points. Minor tweaks to format.c and io.c (invisible unless your compiler complained at the duplicate #defines of IOSUNIT and IOSFMT or at comparisons of p1gets(...) with NULL). Sun Feb 25 18:40:10 EST 1990: Fix bug introduced Feb. 22: if a subprogram contained DATA and the first executable statement was labeled, then the label got lost. (Just change INEXEC to INDATA in p1output.c; it occurs just once.) Mon Feb 26 17:45:10 EST 1990: Fix bug in handling of " and ' in comments. Wed Mar 28 01:43:06 EST 1990: libI77: 1. Repair nasty I/O bug: opening two files and closing the first (after possibly reading or writing it), then writing the second caused the last buffer of the second to be lost. 2. Formatted reads of logical values treated all letters other than t or T as f (false). libI77 files changed: err.c rdfmt.c Version.c (Request "libi77 from f2c" -- you can't get these files individually.) f2c itself: Repair nasty bug in translation of ELSE IF (condition involving complicated abs, min, or max) -- auxiliary statements were emitted at the wrong place. Supply semicolon previously omitted from the translation of a label (of a CONTINUE) immediately preceding an ELSE IF or an ELSE. This bug made f2c produce invalid C. Correct a memory fault that occurred (on some machines) when the error message "adjustable dimension on non-argument" should be given. Minor tweaks to remove some harmless warnings by overly chatty C compilers. Argument arays having constant dimensions but a variable lower bound (e.g., x(n+1:n+3)) had a * omitted from scalar arguments involved in the array offset computation. Wed Mar 28 18:47:59 EST 1990: libf77: add exit(0) to end of main [return(0) encounters a Cray bug] Sun Apr 1 16:20:58 EDT 1990: Avoid dereferencing null when processing equivalences after an error. Fri Apr 6 08:29:49 EDT 1990: Calls involving alternate return specifiers omitted processing needed for things like min, max, abs, and // (concatenation). INTEGER*2 PARAMETERs were treated as INTEGER*4. Convert some O(n^2) parsing to O(n). Tue Apr 10 20:07:02 EDT 1990: When inconsistent calling sequences involve differing numbers of arguments, report the first differing argument rather than the numbers of arguments. Fix bug under -a: formatted I/O in which either the unit or the format was a local character variable sometimes resulted in invalid C (a static struct initialized with an automatic component). Improve error message for invalid flag after elided -. Complain when literal table overflows, rather than infinitely looping. (The complaint mentions the new and otherwise undocumented -NL option for specifying a larger literal table.) New option -h for forcing strings to word (or, with -hd, double-word) boundaries where possible. Repair a bug that could cause improper splitting of strings. Fix bug (cast of c to doublereal) in subroutine foo(c,r) double complex c double precision r c = cmplx(r,real(c)) end New include file "sysdep.h" has some things from defs.h (and elsewhere) that one may need to modify on some systems. Some large arrays that were previously statically allocated are now dynamically allocated when f2c starts running. f2c/src files changed: README cds.c defs.h f2c.1 f2c.1t format.c formatdata.c init.c io.c lex.c main.c makefile mem.c misc.c names.c niceprintf.c output.c parse_args.c pread.c put.c putpcc.c sysdep.h version.c xsum0.out Wed Apr 11 18:27:12 EDT 1990: Fix bug in argument consistency checking of character, complex, and double complex valued functions. If the same source file contained a definition of such a function with arguments not explicitly typed, then subsequent references to the function might get erroneous warnings of inconsistent calling sequences. Tweaks to sysdep.h for partially ANSI systems. New options -kr and -krd cause f2c to use temporary variables to enforce Fortran evaluation-order rules with pernicious, old-style C compilers that apply the associative law to floating-point operations. Sat Apr 14 15:50:15 EDT 1990: libi77: libI77 adjusted to allow list-directed and namelist I/O of internal files; bug in namelist I/O of logical and character arrays fixed; list input of complex numbers adjusted to permit d or D to denote the start of the exponent field of a component. f2c itself: fix bug in handling complicated lower-bound expressions for character substrings; e.g., min and max did not work right, nor did function invocations involving character arguments. Switch to octal notation, rather than hexadecimal, for nonprinting characters in character and string constants. Fix bug (when neither -A nor -C++ was specified) in typing of external arguments of type complex, double complex, or character: subroutine foo(c) external c complex c now results in /* Complex */ int (*c) (); (as, indeed, it once did) rather than complex (*c) (); Sat Apr 14 22:50:39 EDT 1990: libI77/makefile: updated "make check" to omit lio.c lib[FI]77/makefile: trivial change: define CC = cc, reference $(CC). (Request, e.g., "libi77 from f2c" -- you can't ask for individual files from lib[FI]77.) Wed Apr 18 00:56:37 EDT 1990: Move declaration of atof() from defs.h to sysdep.h, where it is now not declared if stdlib.h is included. (NeXT's stdlib.h has a #define atof that otherwise wreaks havoc.) Under -u, provide a more intelligible error message (than "bad tag") for an attempt to define a function without specifying its type. Wed Apr 18 17:26:27 EDT 1990: Recognize \v (vertical tab) in Hollerith as well as quoted strings; add recognition of \r (carriage return). New option -!bs turns off recognition of escapes in character strings (\0, \\, \b, \f, \n, \r, \t, \v). Move to sysdep.c initialization of some arrays whose initialization assumed ASCII; #define Table_size in sysdep.h rather than using hard-coded 256 in allocating arrays of size 1 << (bits/byte). Thu Apr 19 08:13:21 EDT 1990: Warn when escapes would make Hollerith extend beyond statement end. Omit max() definition from misc.c (should be invisible except on systems that erroneously #define max in stdlib.h). Mon Apr 23 22:24:51 EDT 1990: When producing default-style C (no -A or -C++), cast switch expressions to (int). Move "-lF77 -lI77 -lm -lc" to link_msg, defined in sysdep.c . Add #define scrub(x) to sysdep.h, with invocations in format.c and formatdata.c, so that people who have systems like VMS that would otherwise create multiple versions of intermediate files can #define scrub(x) unlink(x) Tue Apr 24 18:28:36 EDT 1990: Pass string lengths once rather than twice to a function of character arguments involved in comparison of character strings of length 1. Fri Apr 27 13:11:52 EDT 1990: Fix bug that made f2c gag on concatenations involving char(...) on some systems. Sat Apr 28 23:20:16 EDT 1990: Fix control-stack bug in if(...) then else if (complicated condition) else endif (where the complicated condition causes assignment to an auxiliary variable, e.g., max(a*b,c)). Mon Apr 30 13:30:10 EDT 1990: Change fillers for DATA with holes from substructures to arrays (in an attempt to make things work right with C compilers that have funny padding rules for substructures, e.g., Sun C compilers). Minor cleanup of exec.c (should not affect generated C). Mon Apr 30 23:13:51 EDT 1990: Fix bug in handling return values of functions having multiple entry points of differing return types. Sat May 5 01:45:18 EDT 1990: Fix type inference bug in subroutine foo(x) call goo(x) end subroutine goo(i) i = 3 end Instead of warning of inconsistent calling sequences for goo, f2c was simply making i a real variable; now i is correctly typed as an integer variable, and f2c issues an error message. Adjust error messages issued at end of declarations so they don't blame the first executable statement. Sun May 6 01:29:07 EDT 1990: Fix bug in -P and -Ps: warn when the definition of a subprogram adds information that would change prototypes or previous declarations. Thu May 10 18:09:15 EDT 1990: Fix further obscure bug with (default) -it: inconsistent calling sequences and I/O statements could interact to cause a memory fault. Example: SUBROUTINE FOO CALL GOO(' Something') ! Forgot integer first arg END SUBROUTINE GOO(IUNIT,MSG) CHARACTER*(*)MSG WRITE(IUNIT,'(1X,A)') MSG END Fri May 11 16:49:11 EDT 1990: Under -!c, do not delete any .c files (when there are errors). Avoid dereferencing 0 when a fatal error occurs while reading Fortran on stdin. Wed May 16 18:24:42 EDT 1990: f2c.ps made available. Mon Jun 4 12:53:08 EDT 1990: Diagnose I/O units of invalid type. Add specific error msg about dummy arguments in common. Wed Jun 13 12:43:17 EDT 1990: Under -A, supply a missing "[1]" for CHARACTER*1 variables that appear both in a DATA statement and in either COMMON or EQUIVALENCE. Mon Jun 18 16:58:31 EDT 1990: Trivial updates to f2c.ps . ("Fortran 8x" --> "Fortran 90"; omit "(draft)" from "(draft) ANSI C".) Tue Jun 19 07:36:32 EDT 1990: Fix incorrect code generated for ELSE IF(expression involving function call passing non-constant substring). Under -h, preserve the property that strings are null-terminated where possible. Remove spaces between # and define in lex.c output.c parse.h . Mon Jun 25 07:22:59 EDT 1990: Minor tweak to makefile to reduce unnecessary recompilations. Tue Jun 26 11:49:53 EDT 1990: Fix unintended truncation of some integer constants on machines where casting a long to (int) may change the value. E.g., when f2c ran on machines with 16-bit ints, "i = 99999" was being translated to "i = -31073;". Wed Jun 27 11:05:32 EDT 1990: Arrange for CHARACTER-valued PARAMETERs to honor their length specifications. Allow CHAR(nn) in expressions defining such PARAMETERs. Fri Jul 20 09:17:30 EDT 1990: Avoid dereferencing 0 when a FORMAT statement has no label. Thu Jul 26 11:09:39 EDT 1990: Remarks about VOID and binread,binwrite added to README. Tweaks to parse_args: should be invisible unless your compiler complained at (short)*store. Thu Aug 2 02:07:58 EDT 1990: f2c.ps: change the first line of page 5 from include stuff to include 'stuff' Tue Aug 14 13:21:24 EDT 1990: libi77: libI77 adjusted to treat tabs as spaces in list input. Fri Aug 17 07:24:53 EDT 1990: libi77: libI77 adjusted so a blank='ZERO' clause (upper case Z) in an open of a currently open file works right. Tue Aug 28 01:56:44 EDT 1990: Fix bug in warnings of inconsistent calling sequences: if an argument to a subprogram was never referenced, then a previous invocation of the subprogram (in the same source file) that passed something of the wrong type for that argument did not elicit a warning message. Thu Aug 30 09:46:12 EDT 1990: libi77: prevent embedded blanks in list output of complex values; omit exponent field in list output of values of magnitude between 10 and 1e8; prevent writing stdin and reading stdout or stderr; don't close stdin, stdout, or stderr when reopening units 5, 6, 0. Tue Sep 4 12:30:57 EDT 1990: Fix bug in C emitted under -I2 or -i2 for INTEGER*4 FUNCTION. Warn of missing final END even if there are previous errors. Fri Sep 7 13:55:34 EDT 1990: Remark about "make xsum.out" and "make f2c" added to README. Tue Sep 18 23:50:01 EDT 1990: Fix null dereference (and, on some systems, writing of bogus *_com.c files) under -ec or -e1c when a prototype file (*.p or *.P) describes COMMON blocks that do not appear in the Fortran source. libi77: Add some #ifdef lines (#ifdef MSDOS, #ifndef MSDOS) to avoid references to stat and fstat on non-UNIX systems. On UNIX systems, add component udev to unit; decide that old and new files are the same iff both the uinode and udev components of unit agree. When an open stmt specifies STATUS='OLD', use stat rather than access (on UNIX systems) to check the existence of the file (in case directories leading to the file have funny permissions and this is a setuid or setgid program). Thu Sep 27 16:04:09 EDT 1990: Supply missing entry for Impldoblock in blksize array of cpexpr (in expr.c). No examples are known where this omission caused trouble. Tue Oct 2 22:58:09 EDT 1990: libf77: test signal(...) == SIG_IGN rather than & 01 in main(). libi77: adjust rewind.c so two successive rewinds after a write don't clobber the file. Thu Oct 11 18:00:14 EDT 1990: libi77: minor cleanups: add #include "fcntl.h" to endfile.c, err.c, open.c; adjust g_char in util.c for segmented memories; in f_inqu (inquire.c), define x appropriately when MSDOS is defined. Mon Oct 15 20:02:11 EDT 1990: Add #ifdef MSDOS pointer adjustments to mem.c; treat NAME= as a synonym for FILE= in OPEN statements. Wed Oct 17 16:40:37 EDT 1990: libf77, libi77: minor cleanups: _cleanup() and abort() invocations replaced by invocations of sig_die in main.c; some error messages previously lost in buffers will now appear. Mon Oct 22 16:11:27 EDT 1990: libf77: separate sig_die from main (for folks who don't want to use the main in libF77). libi77: minor tweak to comments in README. Fri Nov 2 13:49:35 EST 1990: Use two underscores rather than one in generated temporary variable names to avoid conflict with COMMON names. f2c.ps updated to reflect this change and the NAME= extension introduced 15 Oct. Repair a rare memory fault in io.c . Mon Nov 5 16:43:55 EST 1990: libi77: changes to open.c (and err.c): complain if an open stmt specifies new= and the file already exists (as specified by Fortrans 77 and 90); allow file= to be omitted in open stmts and allow status='replace' (Fortran 90 extensions). Fri Nov 30 10:10:14 EST 1990: Adjust malloc.c for unusual systems whose sbrk() can return values not properly aligned for doubles. Arrange for slightly more helpful and less repetitive warnings for non-character variables initialized with character data; these warnings are (still) suppressed by -w66. Fri Nov 30 15:57:59 EST 1990: Minor tweak to README (about changing VOID in f2c.h). Mon Dec 3 07:36:20 EST 1990: Fix spelling of "character" in f2c.1t. Tue Dec 4 09:48:56 EST 1990: Remark about link_msg and libf2c added to f2c/README. Thu Dec 6 08:33:24 EST 1990: Under -U, render label nnn as L_nnn rather than Lnnn. Fri Dec 7 18:05:00 EST 1990: Add more names from f2c.h (e.g. integer, real) to the c_keywords list of names to which an underscore is appended to avoid confusion. Mon Dec 10 19:11:15 EST 1990: Minor tweaks to makefile (./xsum) and README (binread/binwrite). libi77: a few modifications for POSIX systems; meant to be invisible elsewhere. Sun Dec 16 23:03:16 EST 1990: Fix null dereference caused by unusual erroneous input, e.g. call foo('abc') end subroutine foo(msg) data n/3/ character*(*) msg end (Subroutine foo is illegal because the character statement comes after a data statement.) Use decimal rather than hex constants in xsum.c (to prevent erroneous warning messages about constant overflow). Mon Dec 17 12:26:40 EST 1990: Fix rare extra underscore in character length parameters passed for multiple entry points. Wed Dec 19 17:19:26 EST 1990: Allow generation of C despite error messages about bad alignment forced by equivalence. Allow variable-length concatenations in I/O statements, such as open(3, file=bletch(1:n) // '.xyz') Fri Dec 28 17:08:30 EST 1990: Fix bug under -p with formats and internal I/O "units" in COMMON, as in COMMON /FIGLEA/F CHARACTER*20 F F = '(A)' WRITE (*,FMT=F) 'Hello, world!' END Tue Jan 15 12:00:24 EST 1991: Fix bug when two equivalence groups are merged, the second with nonzero offset, and the result is then merged into a common block. Example: INTEGER W(3), X(3), Y(3), Z(3) COMMON /ZOT/ Z EQUIVALENCE (W(1),X(1)), (X(2),Y(1)), (Z(3),X(1)) ***** W WAS GIVEN THE WRONG OFFSET Recognize Fortran 90's optional NML= in NAMELIST READs and WRITEs. (Currently NML= and FMT= are treated as synonyms -- there's no error message if, e.g., NML= specifies a format.) libi77: minor adjustment to allow internal READs from character string constants in read-only memory. Fri Jan 18 22:56:15 EST 1991: Add comment to README about needing to comment out the typedef of size_t in sysdep.h on some systems, e.g. Sun 4.1. Fix misspelling of "statement" in an error message in lex.c Wed Jan 23 00:38:48 EST 1991: Allow hex, octal, and binary constants to have the qualifying letter (z, x, o, or b) either before or after the quoted string containing the digits. For now this change will not be reflected in f2c.ps . Tue Jan 29 16:23:45 EST 1991: Arrange for character-valued statement functions to give results of the right length (that of the statement function's name). Wed Jan 30 07:05:32 EST 1991: More tweaks for character-valued statement functions: an error check and an adjustment so a right-hand side of nonconstant length (e.g., a substring) is handled right. Wed Jan 30 09:49:36 EST 1991: Fix p1_head to avoid printing (char *)0 with %s. Thu Jan 31 13:53:44 EST 1991: Add a test after the cleanup call generated for I/O statements with ERR= or END= clauses to catch the unlikely event that the cleanup routine encounters an error. Mon Feb 4 08:00:58 EST 1991: Minor cleanup: omit unneeded jumps and labels from code generated for some NAMELIST READs and WRITEs with IOSTAT=, ERR=, and/or END=. Tue Feb 5 01:39:36 EST 1991: Change Mktemp to mktmp (for the benefit of systems so brain-damaged that they do not distinguish case in external names -- and that for some reason want to load mktemp). Try to get xsum0.out right this time (it somehow didn't get updated on 4 Feb. 1991). Add note to libi77/README about adjusting the interpretation of RECL= specifiers in OPENs for direct unformatted I/O. Thu Feb 7 17:24:42 EST 1991: New option -r casts values of REAL functions, including intrinsics, to REAL. This only matters for unportable code like real r r = asin(1.) if (r .eq. asin(1.)) ... [The behavior of such code varies with the Fortran compiler used -- and sometimes is affected by compiler options.] For now, the man page at the end of f2c.ps is the only part of f2c.ps that reflects this new option. Fri Feb 8 18:12:51 EST 1991: Cast pointer differences passed as arguments to the appropriate type. This matters, e.g., with MSDOS compilers that yield a long pointer difference but have int == short. Disallow nonpositive dimensions. Fri Feb 15 12:24:15 EST 1991: Change %d to %ld in sprintf call in putpower in putpcc.c. Free more memory (e.g. allowing translation of larger Fortran files under MS-DOS). Recognize READ (character expression) and WRITE (character expression) as formatted I/O with the format given by the character expression. Update year in Notice. Sat Feb 16 00:42:32 EST 1991: Recant recognizing WRITE(character expression) as formatted output -- Fortran 77 is not symmetric in its syntax for READ and WRITE. Mon Mar 4 15:19:42 EST 1991: Fix bug in passing the real part of a complex argument to an intrinsic function. Omit unneeded parentheses in nested calls to intrinsics. Example: subroutine foo(x, y) complex y x = exp(sin(real(y))) + exp(imag(y)) end Fri Mar 8 15:05:42 EST 1991: Fix a comment in expr.c; omit safstrncpy.c (which had bugs in cases not used by f2c). Wed Mar 13 02:27:23 EST 1991: Initialize firstmemblock->next in mem_init in mem.c . [On most systems it was fortuituously 0, but with System V, -lmalloc could trip on this missed initialization.] Wed Mar 13 11:47:42 EST 1991: Fix a reference to freed memory. Wed Mar 27 00:42:19 EST 1991: Fix a memory fault caused by such illegal Fortran as function foo x = 3 logical foo ! declaration among executables foo=.false. ! used to suffer memory fault end Fri Apr 5 08:30:31 EST 1991: Fix loss of % in some format expressions, e.g. write(*,'(1h%)') Fix botch introduced 27 March 1991 that caused subroutines with multiple entry points to have extraneous declarations of ret_val. Fri Apr 5 12:44:02 EST 1991 Try again to omit extraneous ret_val declarations -- this morning's fix was sometimes wrong. Mon Apr 8 13:47:06 EDT 1991: Arrange for s_rnge to have the right prototype under -A -C . Wed Apr 17 13:36:03 EDT 1991: New fatal error message for apparent invocation of a recursive statement function. Thu Apr 25 15:13:37 EDT 1991: F2c and libi77 adjusted so NAMELIST works with -i2. (I forgot about -i2 when adding NAMELIST.) This required a change to f2c.h (that only affects NAMELIST I/O under -i2.) Man-page description of -i2 adjusted to reflect that -i2 stores array lengths in short ints. Fri Apr 26 02:54:41 EDT 1991: Libi77: fix some bugs in NAMELIST reading of multi-dimensional arrays (file rsne.c). Thu May 9 02:13:51 EDT 1991: Omit a trailing space in expr.c (could cause a false xsum value if a mailer drops the trailing blank). Thu May 16 13:14:59 EDT 1991: Libi77: increase LEFBL in lio.h to overcome a NeXT bug. Tweak for compilers that recognize "nested" comments: inside comments, turn /* into /+ (as well as */ into +/). Sat May 25 11:44:25 EDT 1991: libf77: s_rnge: declare line long int rather than int. Fri May 31 07:51:50 EDT 1991: libf77: system_: officially return status. Mon Jun 17 16:52:53 EDT 1991: Minor tweaks: omit unnecessary declaration of strcmp (that caused trouble on a system where strcmp was a macro) from misc.c; add SHELL = /bin/sh to makefiles. Fix a dereference of null when a CHARACTER*(*) declaration appears (illegally) after DATA. Complain only once per subroutine about declarations appearing after DATA. Mon Jul 1 00:28:13 EDT 1991: Add test and error message for illegal use of subroutine names, e.g. SUBROUTINE ZAP(A) ZAP = A END Mon Jul 8 21:49:20 EDT 1991: Issue a warning about things like integer i i = 'abc' (which is treated as i = ichar('a')). [It might be nice to treat 'abc' as an integer initialized (in a DATA statement) with 'abc', but other matters have higher priority.] Render i = ichar('A') as i = 'A'; rather than i = 65; (which assumes ASCII). Fri Jul 12 07:41:30 EDT 1991: Note added to README about erroneous definitions of __STDC__ . Sat Jul 13 13:38:54 EDT 1991: Fix bugs in double type convesions of complex values, e.g. sngl(real(...)) or dble(real(...)) (where ... is complex). Mon Jul 15 13:21:42 EDT 1991: Fix bug introduced 8 July 1991 that caused erroneous warnings "ichar([first char. of] char. string) assumed for conversion to numeric" when a subroutine had an array of character strings as an argument. Wed Aug 28 01:12:17 EDT 1991: Omit an unused function in format.c, an unused variable in proc.c . Under -r8, promote complex to double complex (as the man page claims). Fri Aug 30 17:19:17 EDT 1991: f2c.ps updated: slightly expand description of intrinsics and,or,xor, not; add mention of intrinsics lshift, rshift; add note about f2c accepting Fortran 90 inline comments (starting with !); update Cobalt Blue address. Tue Sep 17 07:17:33 EDT 1991: libI77: err.c and open.c modified to use modes "rb" and "wb" when (f)opening unformatted files; README updated to point out that it may be necessary to change these modes to "r" and "w" on some non-ANSI systems. Tue Oct 15 10:25:49 EDT 1991: Minor tweaks that make some PC compilers happier: insert some casts, add args to signal functions. Change -g to emit uncommented #line lines -- and to emit more of them; update fc, f2c.1, f2c.1t, f2c.ps to reflect this. Change uchar to Uchar in xsum.c . Bring gram.c up to date. Thu Oct 17 09:22:05 EDT 1991: libi77: README, fio.h, sue.c, uio.c changed so the length field in unformatted sequential records has type long rather than int (unless UIOLEN_int is #defined). This is for systems where sizeof(int) can vary, depending on the compiler or compiler options. Thu Oct 17 13:42:59 EDT 1991: libi77: inquire.c: when MSDOS is defined, don't strcmp units[i].ufnm when it is NULL. Fri Oct 18 15:16:00 EDT 1991: Correct xsum0.out in "all from f2c/src" (somehow botched on 15 Oct.). Tue Oct 22 18:12:56 EDT 1991: Fix memory fault when a character*(*) argument is used (illegally) as a dummy variable in the definition of a statement function. (The memory fault occurred when the statement function was invoked.) Complain about implicit character*(*). Thu Nov 14 08:50:42 EST 1991: libi77: change uint to Uint in fmt.h, rdfmt.c, wrtfmt.c; this change should be invisible unless you're running a brain-damaged system. Mon Nov 25 19:04:40 EST 1991: libi77: correct botches introduced 17 Oct. 1991 and 14 Nov. 1991 (change uint to Uint in lwrite.c; other changes that only matter if sizeof(int) != sizeof(long)). Add a more meaningful error message when bailing out due to an attempt to invoke a COMMON variable as a function. Sun Dec 1 19:29:24 EST 1991: libi77: uio.c: add test for read failure (seq. unformatted reads); adjust an error return from EOF to off end of record. Tue Dec 10 17:42:28 EST 1991: Add tests to prevent memory faults with bad uses of character*(*). Thu Dec 12 11:24:41 EST 1991: libi77: fix bug with internal list input that caused the last character of each record to be ignored; adjust error message in internal formatted input from "end-of-file" to "off end of record" if the format specifies more characters than the record contains. Wed Dec 18 17:48:11 EST 1991: Fix bug in translating nonsensical ichar invocations involving concatenations. Fix bug in passing intrinsics lle, llt, lge, lgt as arguments; hl_le was being passed rather than l_le, etc. libf77: adjust length parameters from long to ftnlen, for compiling with f2c_i2 defined. Sat Dec 21 15:30:57 EST 1991: Allow DO nnn ... to end with an END DO statement labelled nnn. Tue Dec 31 13:53:47 EST 1991: Fix bug in handling dimension a(n**3,2) -- pow_ii was called incorrectly. Fix bug in translating subroutine x(abc,n) character abc(n) write(abc,'(i10)') 123 end (omitted declaration and initialiation of abc_dim1). Complain about dimension expressions of such invalid types as complex and logical. Fri Jan 17 11:54:20 EST 1992: Diagnose some illegal uses of main program name (rather than memory faulting). libi77: (1) In list and namelist input, treat "r* ," and "r*," alike (where r is a positive integer constant), and fix a bug in handling null values following items with repeat counts (e.g., 2*1,,3). (2) For namelist reading of a numeric array, allow a new name-value subsequence to terminate the current one (as though the current one ended with the right number of null values). (3) [lio.h, lwrite.c]: omit insignificant zeros in list and namelist output. (Compile with -DOld_list_output to get the old behavior.) Sat Jan 18 15:58:01 EST 1992: libi77: make list output consistent with F format by printing .1 rather than 0.1 (introduced yesterday). Wed Jan 22 08:32:43 EST 1992: libi77: add comment to README pointing out preconnection of Fortran units 5, 6, 0 to stdin, stdout, stderr (respectively). Mon Feb 3 11:57:53 EST 1992: libi77: fix namelist read bug that caused the character following a comma to be ignored. Fri Feb 28 01:04:26 EST 1992: libf77: fix buggy z_sqrt.c (double precision square root), which misbehaved for arguments in the southwest quadrant. Thu Mar 19 15:05:18 EST 1992: Fix bug (introduced 17 Jan 1992) in handling multiple entry points of differing types (with implicitly typed entries appearing after the first executable statement). Fix memory fault in the following illegal Fortran: double precision foo(i) * illegal: above should be "double precision function foo(i)" foo = i * 3.2 entry moo(i) end Note about ANSI_Libraries (relevant, e.g., to IRIX 4.0.1 and AIX) added to README. Abort zero divides during constant simplification. Sat Mar 21 01:27:09 EST 1992: Tweak ckalloc (misc.c) for systems where malloc(0) = 0; this matters for subroutines with multiple entry points but no arguments. Add "struct memblock;" to init.c (irrelevant to most compilers). Wed Mar 25 13:31:05 EST 1992: Fix bug with IMPLICIT INTEGER*4(...): under -i2 or -I2, the *4 was ignored. Tue May 5 09:53:55 EDT 1992: Tweaks to README; e.g., ANSI_LIbraries changed to ANSI_Libraries . Wed May 6 23:49:07 EDT 1992 Under -A and -C++, have subroutines return 0 (even if they have no * arguments). Adjust libi77 (rsne.c and lread.c) for systems where ungetc is a macro. Tweak lib[FI]77/makefile to use unique intermediate file names (for parallel makes). Tue May 19 09:03:05 EDT 1992: Adjust libI77 to make err= work with internal list and formatted I/O. Sat May 23 18:17:42 EDT 1992: Under -A and -C++, supply "return 0;" after the code generated for a STOP statement -- the C compiler doesn't know that s_stop won't return. New (mutually exclusive) options: -f treats all input lines as free-format lines, honoring text that appears after column 72 and not padding lines shorter than 72 characters with blanks (which matters if a character string is continued across 2 or more lines). -72 treats text appearing after column 72 as an error. Sun May 24 09:45:37 EDT 1992: Tweak description of -f in f2c.1 and f2c.1t; update f2c.ps . Fri May 29 01:17:15 EDT 1992: Complain about externals used as variables. Example subroutine foo(a,b) external b a = a*b ! illegal use of b; perhaps should be b() end Mon Jun 15 11:15:27 EDT 1992: Fix bug in handling namelists with names that have underscores. Sat Jun 27 17:30:59 EDT 1992: Under -A and -C++, end Main program aliases with "return 0;". Under -A and -C++, use .P files and usage in previous subprograms in the current file to give prototypes for functions declared EXTERNAL but not invoked. Fix memory fault under -d1 -P . Under -A and -C++, cast arguments to the right types in calling a function that has been defined in the current file or in a .P file. Fix bug in handling multi-dimensional arrays with array references in their leading dimensions. Fix bug in the intrinsic cmplx function when the first argument involves an expression for which f2c generates temporary variables, e.g. cmplx(abs(real(a)),1.) . Sat Jul 18 07:36:58 EDT 1992: Fix buglet with -e1c (invisible on most systems) temporary file f2c_functions was unlinked before being closed. libf77: fix bugs in evaluating m**n for integer n < 0 and m an integer different from 1 or a real or double precision 0. Catch SIGTRAP (to print "Trace trap" before aborting). Programs that previously erroneously computed 1 for 0**-1 may now fault. Relevant routines: main.c pow_di.c pow_hh.c pow_ii.c pow_ri.c . Sat Jul 18 08:40:10 EDT 1992: libi77: allow namelist input to end with & (e.g. &end). Thu Jul 23 00:14:43 EDT 1992 Append two underscores rather than one to C keywords used as local variables to avoid conflicts with similarly named COMMON blocks. Thu Jul 23 11:20:55 EDT 1992: libf77, libi77 updated to assume ANSI prototypes unless KR_headers is #defined. libi77 now recognizes a Z format item as in Fortran 90; the implementation assumes 8-bit bytes and botches character strings on little-endian machines (by printing their bytes from right to left): expect this bug to persist; fixing it would require a change to the I/O calling sequences. Tue Jul 28 15:18:33 EDT 1992: libi77: insert missed "#ifdef KR_headers" lines around getnum header in rsne.c. Version not updated. NOTE: "index from f2c" now ends with current timestamps of files in "all from f2c/src", sorted by time. To bring your source up to date, obtain source files with a timestamp later than the time shown in your version.c. Fri Aug 14 08:07:09 EDT 1992: libi77: tweak wrt_E in wref.c to avoid signing NaNs. Sun Aug 23 19:05:22 EDT 1992: fc: supply : after O in getopt invocation (for -O1 -O2 -O3). Mon Aug 24 18:37:59 EDT 1992: Recant above tweak to fc: getopt is dumber than I thought; it's necessary to say -O 1 (etc.). libF77/README: add comments about ABORT, ERF, DERF, ERFC, DERFC, GETARG, GETENV, IARGC, SIGNAL, and SYSTEM. Tue Oct 27 01:57:42 EST 1992: libf77, libi77: 1. Fix botched indirection in signal_.c. 2. Supply missing l_eof = 0 assignment to s_rsne() in rsne.c (so end-of-file on other files won't confuse namelist reads of external files). 3. Prepend f__ to external names that are only of internal interest to lib[FI]77. Thu Oct 29 12:37:18 EST 1992: libf77: Fix botch in signal_.c when KR_headers is #defined; add CFLAGS to makefile. libi77: trivial change to makefile for consistency with libF77/makefile. Wed Feb 3 02:05:16 EST 1993: Recognize types INTEGER*1, LOGICAL*1, LOGICAL*2, INTEGER*8. INTEGER*8 is not well tested and will only work reasonably on systems where int = 4 bytes, long = 8 bytes; on such systems, you'll have to modify f2c.h appropriately, changing integer from long to int and adding typedef long longint. You'll also have to compile libI77 with Allow_TYQUAD #defined and adjust libF77/makefile to compile pow_qq.c. In the f2c source, changes for INTEGER*8 are delimited by #ifdef TYQUAD ... #endif. You can omit the INTEGER*8 changes by compiling with NO_TYQUAD #defined. Otherwise, the new command-line option -!i8 disables recognition of INTEGER*8. libf77: add pow_qq.c libi77: add #ifdef Allow_TYQUAD stuff. Changes for INTEGER*1, LOGICAL*1, and LOGICAL*2 came last 23 July 1992. Fix bug in backspace (that only bit when the last character of the second or subsequent buffer read was the previous newline). Guard against L_tmpnam being too small in endfile.c. For MSDOS, close and reopen files when copying to truncate. Lengthen LINTW (buffer size in lwrite.c). Add \ to the end of #define lines that get broken. Fix bug in handling NAMELIST of items in EQUIVALENCE. Under -h (or -hd), convert Hollerith to integer in general expressions (e.g., assignments), not just when they're passed as arguments, and blank-pad rather than 0-pad the Hollerith to a multiple of sizeof(integer) or sizeof(doublereal). Add command-line option -s, which instructs f2c preserve multi- dimensional subscripts (by emitting and using appropriate #defines). Fix glitch (with default type inferences) in examples like call foo('abc') end subroutine foo(goo) end This gave two warning messages: Warning on line 4 of y.f: inconsistent calling sequences for foo: here 1, previously 2 args and string lengths. Warning on line 4 of y.f: inconsistent calling sequences for foo: here 2, previously 1 args and string lengths. Now the second Warning is suppressed. Complain about all inconsistent arguments, not just the first. Switch to automatic creation of "all from f2c/src". For folks getting f2c source via ftp, this means f2c/src/all.Z is now an empty file rather than a bundle. Separate -P and -A: -P no longer implies -A. Thu Feb 4 00:32:20 EST 1993: Fix some glitches (introduced yesterday) with -h . Fri Feb 5 01:40:38 EST 1993: Fix bug in types conveyed for namelists (introduced 3 Feb. 1993). Fri Feb 5 21:26:43 EST 1993: libi77: tweaks to NAMELIST and open (after comments by Harold Youngren): 1. Reading a ? instead of &name (the start of a namelist) causes the namelist being sought to be written to stdout (unit 6); to omit this feature, compile rsne.c with -DNo_Namelist_Questions. 2. Reading the wrong namelist name now leads to an error message and an attempt to skip input until the right namelist name is found; to omit this feature, compile rsne.c with -DNo_Bad_Namelist_Skip. 3. Namelist writes now insert newlines before each variable; to omit this feature, compile xwsne.c with -DNo_Extra_Namelist_Newlines. 4. For OPEN of sequential files, ACCESS='APPEND' (or access='anything else starting with "A" or "a"') causes the file to be positioned at end-of-file, so a write will append to the file. (This is nonstandard, but does not require modifying data structures.) Mon Feb 8 14:40:37 EST 1993: Increase number of continuation lines allowed from 19 to 99, and allow changing this limit with -NC (e.g. -NC200 for 200 lines). Treat control-Z (at the beginning of a line) as end-of-file: see the new penultimate paragraph of README. Fix a rarely seen glitch that could make an error messages to say "line 0". Tue Feb 9 02:05:40 EST 1993 libi77: change some #ifdef MSDOS lines to #ifdef NON_UNIX_STDIO, and, in err.c under NON_UNIX_STDIO, avoid close(creat(name,0666)) when the unit has another file descriptor for name. Tue Feb 9 17:12:49 EST 1993 libi77: more tweaks for NON_UNIX_STDIO: use stdio routines rather than open, close, creat, seek, fdopen (except for f__isdev). Fri Feb 12 15:49:33 EST 1993 Update src/gram.c (which was forgotten in the recent updates). Most folks regenerate it anyway (wity yacc or bison). Thu Mar 4 17:07:38 EST 1993 Increase default max labels in computed gotos and alternate returns to 257, and allow -Nl1234 to specify this number. Tweak put.c to check p->tag == TADDR in realpart() and imagpart(). Adjust fc script to allow .r (RATFOR) files and -C (check subscripts). Avoid declaring strchr in niceprintf.c under -DANSI_Libraries . gram.c updated again. libi77: err.c, open.c: take declaration of fdopen from rawio.h. Sat Mar 6 07:09:11 EST 1993 libi77: uio.c: adjust off-end-of-record test for sequential unformatted reads to respond to err= rather than end= . Sat Mar 6 16:12:47 EST 1993 Treat scalar arguments of the form (v) and v+0, where v is a variable, as expressions: assign to a temporary variable, and pass the latter. gram.c updated. Mon Mar 8 09:35:38 EST 1993 "f2c.h from f2c" updated to add types logical1 and integer1 for LOGICAL*1 and INTEGER*1. ("f2c.h from f2c" is supposed to be the same as "f2c.h from f2c/src", which was updated 3 Feb. 1993.) Mon Mar 8 17:57:55 EST 1993 Fix rarely seen bug that could cause strange casts in function invocations (revealed by an example with msdos/f2c.exe). msdos/f2cx.exe.Z and msdos/f2c.exe.Z updated (ftp access only). Fri Mar 12 12:37:01 EST 1993 Fix bug with -s in handling subscripts involving min, max, and complicated expressions requiring temporaries. Fix bug in handling COMMONs that need padding by a char array. msdos/f2cx.exe.Z and msdos/f2c.exe.Z updated (ftp access only). Fri Mar 12 17:16:16 EST 1993 libf77, libi77: updated for compiling under C++. Mon Mar 15 16:21:37 EST 1993 libi77: more minor tweaks (for -DKR_headers); Version.c not changed. Thu Mar 18 12:37:30 EST 1993 Flag -r (for discarding carriage-returns on systems that end lines with carriage-return/newline pairs, e.g. PCs) added to xsum, and xsum.c converted to ANSI/ISO syntax (with K&R syntax available with -DKR_headers). [When time permits, the f2c source will undergo a similar conversion.] libi77: tweaks to #includes in endfile.c, err.c, open.c, rawio.h; Version.c not changed. f2c.ps updated (to pick up revision of 2 Feb. 1993 to f2c.1). Fri Mar 19 09:19:26 EST 1993 libi77: add (char *) casts to malloc and realloc invocations in err.c, open.c; Version.c not changed. Tue Mar 30 07:17:15 EST 1993 Fix bug introduced 6 March 1993: possible memory corruption when loops in data statements involve constant subscripts, as in DATA (GUNIT(1,I),I=0,14)/15*-1/ Tue Mar 30 16:17:42 EST 1993 Fix bug with -s: (floating-point array item)*(complex item) generates an _subscr() reference for the floating-point array, but a #define for the _subscr() was omitted. Tue Apr 6 12:11:22 EDT 1993 libi77: adjust error returns for formatted inputs to flush the current input line when err= is specified. To restore the old behavior (input left mid-line), either adjust the #definition of errfl in fio.h or omit the invocation of f__doend in err__fl (in err.c). Tue Apr 6 13:30:04 EDT 1993 Fix bug revealed in subroutine foo(i) call goo(int(i)) end which now passes a copy of i, rather than i itself. Sat Apr 17 11:41:02 EDT 1993 Adjust appending of underscores to conform with f2c.ps ("A Fortran to C Converter"): names that conflict with C keywords or f2c type names now have just one underscore appended (rather than two); add "integer1", "logical1", "longint" to the keyword list. Append underscores to names that appear in EQUIVALENCE and are component names in a structure declared in f2c.h, thus avoiding a problem caused by the #defines emitted for equivalences. Example: complex a equivalence (i,j) a = 1 ! a.i went awry because of #define i j = 2 write(*,*) a, i end Adjust line-breaking logic to avoid splitting very long constants (and names). Example: ! The next line starts with tab and thus is a free-format line. a=.012345689012345689012345689012345689012345689012345689012345689012345689 end Omit extraneous "return 0;" from entry stubs emitted for multiple entry points of type character, complex, or double complex. Sat Apr 17 14:35:05 EDT 1993 Fix bug (introduced 4 Feb.) in separating -P from -A that kept f2c from re-reading a .P file written without -A or -C++ describing a routine with an external argument. [See the just-added note about separating -P from -A in the changes above for 3 Feb. 1993.] Fix bug (type UNKNOWN for V in the example below) revealed by subroutine a() external c call b(c) end subroutine b(v) end Sun Apr 18 19:55:26 EDT 1993 Fix wrong calling sequence for mem() in yesterday's addition to equiv.c . Wed Apr 21 17:39:46 EDT 1993 Fix bug revealed in ASSIGN 10 TO L1 GO TO 20 10 ASSIGN 30 TO L2 STOP 10 20 ASSIGN 10 TO L2 ! Bug here because 10 had been assigned ! to another label, then defined. GO TO L2 30 END Fri Apr 23 18:38:50 EDT 1993 Fix bug with -h revealed in CHARACTER*9 FOO WRITE(FOO,'(I6)') 1 WRITE(FOO,'(I6)') 2 ! struct icilist io___3 botched END Tue Apr 27 16:08:28 EDT 1993 Tweak to makefile: remove "size f2c". Tue May 4 23:48:20 EDT 1993 libf77: tweak signal_ line of f2ch.add . Tue Jun 1 13:47:13 EDT 1993 Fix bug introduced 3 Feb. 1993 in handling multiple entry points with differing return types -- the postfix array in proc.c needed a new entry for integer*8 (which resulted in wrong Multitype suffixes for non-integral types). For (default) K&R C, generate VOID rather than int functions for functions of Fortran type character, complex, and double complex. msdos/f2cx.exe.Z and msdos/f2c.exe.Z updated (ftp access only). Tue Jun 1 23:11:15 EDT 1993 f2c.h: add Multitype component g and commented type longint. proc.c: omit "return 0;" from stubs for complex and double complex entries (when entries have multiple types); add test to avoid memory fault with illegal combinations of entry types. Mon Jun 7 12:00:47 EDT 1993 Fix memory fault in common /c/ m integer m(1) data m(1)/1/, m(2)/2/ ! one too many initializers end msdos/f2cx.exe.Z and msdos/f2c.exe.Z updated (ftp access only). Fri Jun 18 13:55:51 EDT 1993 libi77: change type of signal_ in f2ch.add; change type of il in union Uint from long to integer (for machines like the DEC Alpha, where integer should be the same as int). Version.c not changed. Tweak gram.dcl and gram.head: add semicolons after some rules that lacked them, and remove an extraneous semicolon. These changes are completely transparent to our local yacc programs, but apparently matter on some VMS systems. Wed Jun 23 01:02:56 EDT 1993 Update "fc" shell script, and bring f2c.1 and f2c.1t up to date: they're meant to be linked with (i.e., the same as) src/f2c.1 and src/f2c.1t . [In the last update of f2c.1* (2 Feb. 1993), only src/f2c.1 and src/f2c.1t got changed -- a mistake.] Wed Jun 23 09:04:31 EDT 1993 libi77: fix bug in format reversions for internal writes. Example: character*60 lines(2) write(lines,"('n =',i3,2(' more text',i3))") 3, 4, 5, 6 write(*,*) 'lines(1) = ', lines(1) write(*,*) 'lines(2) = ', lines(2) end gave an error message that began "iio: off end of record", rather than giving the correct output: lines(1) = n = 3 more text 4 more text 5 lines(2) = more text 6 more text Thu Aug 5 11:31:14 EDT 1993 libi77: lread.c: fix bug in handling repetition counts for logical data (during list or namelist input). Change struct f__syl to struct syl (for buggy compilers). Sat Aug 7 16:05:30 EDT 1993 libi77: lread.c (again): fix bug in namelist reading of incomplete logical arrays. Fix minor calling-sequence errors in format.c, output.c, putpcc.c: should be invisible. Mon Aug 9 09:12:38 EDT 1993 Fix erroneous cast under -A in translating character*(*) function getc() getc(2:3)=' ' !wrong cast in first arg to s_copy end libi77: lread.c: fix bug in namelist reading of an incomplete array of numeric data followed by another namelist item whose name starts with 'd', 'D', 'e', or 'E'. Fri Aug 20 13:22:10 EDT 1993 Fix bug in do while revealed by subroutine skdig (line, i) character line*(*), ch*1 integer i logical isdigit isdigit(ch) = ch.ge.'0' .and. ch.le.'9' do while (isdigit(line(i:i))) ! ch__1[0] was set before ! "while(...) {...}" i = i + 1 enddo end Fri Aug 27 08:22:54 EDT 1993 Add #ifdefs to avoid declaring atol when it is a macro; version.c not updated. Wed Sep 8 12:24:26 EDT 1993 libi77: open.c: protect #include "sys/..." with #ifndef NON_UNIX_STDIO; Version date not changed. Thu Sep 9 08:51:21 EDT 1993 Adjust "include" to interpret file names relative to the directory of the file that contains the "include". Fri Sep 24 00:56:12 EDT 1993 Fix offset error resulting from repeating the same equivalence statement twice. Example: real a(2), b(2) equivalence (a(2), b(2)) equivalence (a(2), b(2)) end Increase MAXTOKENLEN (to roughly the largest allowed by ANSI C). Mon Sep 27 08:55:09 EDT 1993 libi77: endfile.c: protect #include "sys/types.h" with #ifndef NON_UNIX_STDIO; Version.c not changed. Fri Oct 15 15:37:26 EDT 1993 Fix rarely seen parsing bug illustrated by subroutine foo(xabcdefghij) character*(*) xabcdefghij IF (xabcdefghij.NE.'##') GOTO 40 40 end in which the spacing in the IF line is crucial. Thu Oct 21 13:55:11 EDT 1993 Give more meaningful error message (then "unexpected character in cds") when constant simplification leads to Infinity or NaN. Wed Nov 10 15:01:05 EST 1993 libi77: backspace.c: adjust, under -DMSDOS, to cope with MSDOS text files, as handled by some popular PC C compilers. Beware: the (defective) libraries associated with these compilers assume lines end with \r\n (conventional MS-DOS text files) -- and ftell (and hence the current implementation of backspace) screws up if lines with just \n. Thu Nov 18 09:37:47 EST 1993 Give a better error (than "control stack empty") for an extraneous ENDDO. Example: enddo end Update comments about ftp in "readme from f2c". Sun Nov 28 17:26:50 EST 1993 Change format of time stamp in version.c to yyyymmdd. Sort parameter adjustments (or complain of impossible dependencies) so that dummy arguments are referenced only after being adjusted. Example: subroutine foo(a,b) integer a(2) ! a must be adjusted before b double precision b(a(1),a(2)) call goo(b(3,4)) end Adjust structs for initialized common blocks and equivalence classes to omit the trailing struct component added to force alignment when padding already forces the desired alignment. Example: PROGRAM TEST COMMON /Z/ A, CC CHARACTER*4 CC DATA cc /'a'/ END now gives struct { integer fill_1[1]; char e_2[4]; } z_ = { {0}, {'a', ' ', ' ', ' '} }; rather than struct { integer fill_1[1]; char e_2[4]; real e_3; } z_ = { {0}, {'a', ' ', ' ', ' '}, (float)0. }; Wed Dec 8 16:24:43 EST 1993 Adjust lex.c to recognize # nnn "filename" lines emitted by cpp; this affects the file names and line numbers in error messages and the #line lines emitted under -g. Under -g, arrange for a file that starts with an executable statement to have the first #line line indicate line 1, rather than the line number of the END statement ending the main program. Adjust fc script to run files ending in .F through /lib/cpp. Fix bug ("Impossible tag 2") in if (t .eq. (0,2)) write(*,*) 'Bug!' end libi77: iio.c: adjust internal formatted reads to treat short records as though padded with blanks (rather than causing an "off end of record" error). Wed Dec 15 15:19:15 EST 1993 fc: adjusted for .F files to pass -D and -I options to cpp. Fri Dec 17 20:03:38 EST 1993 Fix botch introduced 28 Nov. 1993 in vax.c; change "version of" to "version". Tue Jan 4 15:39:52 EST 1994 msdos/f2cx.exe.Z and msdos/f2c.exe.Z updated (ftp access only). Wed Jan 19 08:55:19 EST 1994 Arrange to accept integer Nx, Ny, Nz parameter (Nx = 10, Ny = 20) parameter (Nz = max(Nx, Ny)) integer c(Nz) call foo(c) end rather than complaining "Declaration error for c: adjustable dimension on non-argument". The necessary changes cause some hitherto unfolded constant expressions to be folded. Accept BYTE as a synonym for INTEGER*1. Thu Jan 27 08:57:40 EST 1994 Fix botch in changes of 19 Jan. 1994 that broke entry points with multi-dimensional array arguments that did not appear in the subprogram argument list and whose leading dimensions depend on arguments. Mon Feb 7 09:24:30 EST 1994 Remove artifact in "fc" script that caused -O to be ignored: 87c87 < # lcc ignores -O... --- > CFLAGS="$CFLAGS $O" Sun Feb 20 17:04:58 EST 1994 Fix bugs reading .P files for routines with arguments of type INTEGER*1, INTEGER*8, LOGICAL*2. Fix glitch in reporting inconsistent arguments for routines involving character arguments: "arg n" had n too large by the number of character arguments. Tue Feb 22 20:50:08 EST 1994 Trivial changes to data.c format.c main.c niceprintf.c output.h and sysdep.h (consistency improvements). libI77: lread.c: check for NULL return from realloc. Fri Feb 25 23:56:08 EST 1994 output.c, sysdep.h: arrange for -DUSE_DTOA to use dtoa.c and g_fmt.c for correctly rounded decimal values on IEEE-arithmetic machines (plus machines with VAX and IBM-mainframe arithmetic). These routines are available from netlib's fp directory. msdos/f2cx.exe.Z and msdos/f2c.exe.Z updated (ftp access only); the former uses -DUSE_DTOA to keep 12 from printing as 12.000000000000001. vax.c: fix wrong arguments to badtag and frchain introduced 28 Nov. 1993. Source for f2c converted to ANSI/ISO format, with the K&R format available by compilation with -DKR_headers . Arrange for (double precision expression) relop (single precision constant) to retain the single-precision nature of the constant. Example: double precision t if (t .eq. 0.3) ... Mon Feb 28 11:40:24 EST 1994 README updated to reflect a modification just made to netlib's "dtoa.c from fp": 96a97,105 > Also add the rule > > dtoa.o: dtoa.c > $(CC) -c $(CFLAGS) -DMALLOC=ckalloc -DIEEE... dtoa.c > > (without the initial tab) to the makefile, where IEEE... is one of > IEEE_MC68k, IEEE_8087, VAX, or IBM, depending on your machine's > arithmetic. See the comments near the start of dtoa.c. > Sat Mar 5 09:41:52 EST 1994 Complain about functions with the name of a previously declared common block (which is illegal). New option -d specifies the directory for output .c and .P files; f2c.1 and f2c.1t updated. The former undocumented debug option -dnnn is now -Dnnn. Thu Mar 10 10:21:44 EST 1994 libf77: add #undef min and #undef max lines to s_paus.c s_stop.c and system_.c; Version.c not changed. libi77: add -DPad_UDread lines to uio.c and explanation to README: Some buggy Fortran programs use unformatted direct I/O to write an incomplete record and later read more from that record than they have written. For records other than the last, the unwritten portion of the record reads as binary zeros. The last record is a special case: attempting to read more from it than was written gives end-of-file -- which may help one find a bug. Some other Fortran I/O libraries treat the last record no differently than others and thus give no help in finding the bug of reading more than was written. If you wish to have this behavior, compile uio.c with -DPad_UDread . Version.c not changed. Tue Mar 29 17:27:54 EST 1994 Adjust make_param so dimensions involving min, max, and other complicated constant expressions do not provoke error messages about adjustable dimensions on non-arguments. Fix botch introduced 19 Jan 1994: "adjustable dimension on non- argument" messages could cause some things to be freed twice. Tue May 10 07:55:12 EDT 1994 Trivial changes to exec.c, p1output.c, parse_args.c, proc.c, and putpcc.c: change arguments from type foo[] to type *foo for consistency with defs.h. For most compilers, this makes no difference. Thu Jun 2 12:18:18 EDT 1994 Fix bug in handling FORMAT statements that have adjacent character (or Hollerith) strings: an extraneous \002 appeared between the strings. libf77: under -DNO_ONEXIT, arrange for f_exit to be called just once; previously, upon abnormal termination (including stop statements), it was called twice. Mon Jun 6 15:52:57 EDT 1994 libf77: Avoid references to SIGABRT and SIGIOT if neither is defined; Version.c not changed. libi77: Add cast to definition of errfl() in fio.h; this only matters on systems with sizeof(int) < sizeof(long). Under -DNON_UNIX_STDIO, use binary mode for direct formatted files (to avoid any confusion connected with \n characters). Fri Jun 10 16:47:31 EDT 1994 Fix bug under -A in handling unreferenced (and undeclared) external arguments in subroutines with multiple entry points. Example: subroutine m(fcn,futil) external fcn,futil call fcn entry mintio(i1) ! (D_fp)0 rather than (U_fp)0 for futil end Wed Jun 15 10:38:14 EDT 1994 Allow char(constant expression) function in parameter declarations. (This was probably broken in the changes of 29 March 1994.) Fri Jul 1 23:54:00 EDT 1994 Minor adjustments to makefile (rule for f2c.1 commented out) and sysdep.h (#undef KR_headers if __STDC__ is #defined, and base test for ANSI_Libraries and ANSI_Prototypes on KR_headers rather than __STDC__); version.c touched but not changed. libi77: adjust fp.h so local.h is only needed under -DV10; Version.c not changed. Tue Jul 5 03:05:46 EDT 1994 Fix segmentation fault in subroutine foo(a,b,k) data i/1/ double precision a(k,1) ! sequence error: must precede data b = a(i,1) end libi77: Fix bug (introduced 6 June 1994?) in reopening files under NON_UNIX_STDIO. Fix some error messages caused by illegal Fortran. Examples: * 1. x(i) = 0 !Missing declaration for array x call f(x) !Said Impossible storage class 8 in routine mkaddr end !Now says invalid use of statement function x * 2. f = g !No declaration for g; by default it's a real variable call g !Said invalid class code 2 for function g end !Now says g cannot be called * 3. intrinsic foo !Invalid intrinsic name a = foo(b) !Said intrcall: bad intrgroup 0 end !Now just complains about line 1 Tue Jul 5 11:14:26 EDT 1994 Fix glitch in handling erroneous statement function declarations. Example: a(j(i) - i) = a(j(i) - i) + 1 ! bad statement function call foo(a(3)) ! Said Impossible type 0 in routine mktmpn end ! Now warns that i and j are not used Wed Jul 6 17:31:25 EDT 1994 Tweak test for statement functions that (illegally) call themselves; f2c will now proceed to check for other errors, rather than bailing out at the first recursive statement function reference. Warn about but retain divisions by 0 (instead of calling them "compiler errors" and quiting). On IEEE machines, this permits double precision nan, ninf, pinf nan = 0.d0/0.d0 pinf = 1.d0/0.d0 ninf = -1.d0/0.d0 write(*,*) 'nan, pinf, ninf = ', nan, pinf, ninf end to print nan, pinf, ninf = NaN Infinity -Infinity libi77: wref.c: protect with #ifdef GOOD_SPRINTF_EXPONENT an optimization that requires exponents to have 2 digits when 2 digits suffice. lwrite.c wsfe.c (list and formatted external output): omit ' ' carriage-control when compiled with -DOMIT_BLANK_CC . Off-by-one bug fixed in character count for list output of character strings. Omit '.' in list-directed printing of Nan, Infinity. Mon Jul 11 13:05:33 EDT 1994 src/gram.c updated. Tue Jul 12 10:24:42 EDT 1994 libi77: wrtfmt.c: under G11.4, write 0. as " .0000 " rather than " .0000E+00". Thu Jul 14 17:55:46 EDT 1994 Fix glitch in changes of 6 July 1994 that could cause erroneous "division by zero" warnings (or worse). Example: subroutine foo(a,b) y = b a = a / y ! erroneous warning of division by zero end Mon Aug 1 16:45:17 EDT 1994 libi77: lread.c rsne.c: for benefit of systems with a buggy stdio.h, declare ungetc when neither KR_headers nor ungetc is #defined. Version.c not changed. Wed Aug 3 01:53:00 EDT 1994 libi77: lwrite.c (list output): do not insert a newline when appending an oversize item to an empty line. Mon Aug 8 00:51:01 EDT 1994 Fix bug (introduced 3 Feb. 1993) that, under -i2, kept LOGICAL*2 variables from appearing in INQUIRE statements. Under -I2, allow LOGICAL*4 variables to appear in INQUIRE. Fix intrinsic function LEN so it returns a short value under -i2, a long value otherwise. exec.c: fix obscure memory fault possible with bizarre (and highly erroneous) DO-loop syntax. Fri Aug 12 10:45:57 EDT 1994 libi77: fix glitch that kept ERR= (in list- or format-directed input) from working after a NAMELIST READ. Thu Aug 25 13:58:26 EDT 1994 Suppress -s when -C is specified. Give full pathname (netlib@research.att.com) for netlib in readme and src/README. Wed Sep 7 22:13:20 EDT 1994 libi77: typesize.c: adjust to allow types LOGICAL*1, LOGICAL*2, INTEGER*1, and (under -DAllow_TYQUAD) INTEGER*8 in NAMELISTs. Fri Sep 16 17:50:18 EDT 1994 Change name adjustment for reserved words: instead of just appending "_" (a single underscore), append "_a_" to local variable names to avoid trouble when a common block is named a reserved word and the same reserved word is also a local variable name. Example: common /const/ a,b,c real const(3) equivalence (const(1),a) a = 1.234 end Arrange for ichar() to treat characters as unsigned. libf77: s_cmp.c: treat characters as unsigned in comparisons. These changes for unsignedness only matter for strings that contain non-ASCII characters. Now ichar() should always be >= 0. Sat Sep 17 11:19:32 EDT 1994 fc: set rc=$? before exit (to get exit code right in trap code). Mon Sep 19 17:49:43 EDT 1994 libf77: s_paus.c: flush stderr after PAUSE; add #ifdef MSDOS stuff. libi77: README: point out general need for -DMSDOS under MS-DOS. Tue Sep 20 11:42:30 EDT 1994 Fix bug in comparing identically named common blocks, in which all components have the same names and types, but at least one is dimensioned (1) and the other is not dimensioned. Example: subroutine foo common /ab/ a a=1. !!! translated correctly to ab_1.a = (float)1.; end subroutine goo common /ab/ a(1) a(1)=2. !!! translated erroneously to ab_1.a[0] = (float)2. end Tue Sep 27 23:47:34 EDT 1994 Fix bug introduced 16 Sept. 1994: don't add _a_ to C keywords used as external names. In fact, return to earlier behavior of appending __ to C keywords unless they are used as external names, in which case they get just one underscore appended. Adjust constant handling so integer and logical PARAMETERs retain type information, particularly under -I2. Example: SUBROUTINE FOO INTEGER I INTEGER*1 I1 INTEGER*2 I2 INTEGER*4 I4 LOGICAL L LOGICAL*1 L1 LOGICAL*2 L2 LOGICAL*4 L4 PARAMETER (L=.FALSE., L1=.FALSE., L2=.FALSE., L4=.FALSE.) PARAMETER (I=0,I1=0,I2=0,I4=0) CALL DUMMY(I, I1, I2, I4, L, L1, L2, L4) END f2c.1t: Change f\^2c to f2c (omit half-narrow space) in line following ".SH NAME" for benefit of systems that cannot cope with troff commands in this context. Wed Sep 28 12:45:19 EDT 1994 libf77: s_cmp.c fix glitch in -DKR_headers version introduced 12 days ago. Thu Oct 6 09:46:53 EDT 1994 libi77: util.c: omit f__mvgbt (which is never used). f2c.h: change "long" to "long int" to facilitate the adjustments by means of sed described above. Comment out unused typedef of Long. Fri Oct 21 18:02:24 EDT 1994 libf77: add s_catow.c and adjust README to point out that changing "s_cat.o" to "s_catow.o" in the makefile will permit the target of a concatenation to appear on its right-hand side (contrary to the Fortran 77 Standard and at the cost of some run-time efficiency). Wed Nov 2 00:03:58 EST 1994 Adjust -g output to contain only one #line line per statement, inserting \ before the \n ending lines broken because of their length [this insertion was recanted 10 Dec. 1994]. This change accommodates an idiocy in the ANSI/ISO C standard, which leaves undefined the behavior of #line lines that occur within the arguments to a macro call. Wed Nov 2 14:44:27 EST 1994 libi77: under compilation with -DALWAYS_FLUSH, flush buffers at the end of each write statement, and test (via the return from fflush) for write failures, which can be caught with an ERR= specifier in the write statement. This extra flushing slows execution, but can abort execution or alter the flow of control when a disk fills up. f2c/src/io.c: Add ERR= test to e_wsle invocation (end of list-directed external output) to catch write failures when libI77 is compiled with -DALWAYS_FLUSH. Thu Nov 3 10:59:13 EST 1994 Fix bug in handling dimensions involving certain intrinsic functions of constant expressions: the expressions, rather than pointers to them, were passed. Example: subroutine subtest(n,x) real x(2**n,n) ! pow_ii(2,n) was called; now it's pow_ii(&c__2,n) x(2,2)=3. end Tue Nov 8 23:56:30 EST 1994 malloc.c: remove assumption that only malloc calls sbrk. This appears to make malloc.c useful on RS6000 systems. Sun Nov 13 13:09:38 EST 1994 Turn off constant folding of integers used in floating-point expressions, so the assignment in subroutine foo(x) double precision x x = x*1000000*500000 end is rendered as *x = *x * 1000000 * 500000; rather than as *x *= 1783793664; Sat Dec 10 16:31:40 EST 1994 Supply a better error message (than "Impossible type 14") for subroutine foo foo = 3 end Under -g, convey name of included files to #line lines. Recant insertion of \ introduced (under -g) 2 Nov. 1994. Thu Dec 15 14:33:55 EST 1994 New command-line option -Idir specifies directories in which to look for non-absolute include files (after looking in the directory of the current input file). There can be several -Idir options, each specifying one directory. All -Idir options are considered, from left to right, until a suitably named file is found. The -I2 and -I4 command-line options have precedence, so directories named 2 or 4 must be spelled by some circumlocation, such as -I./2 . f2c.ps updated to mention the new -Idir option, correct a typo, and bring the man page at the end up to date. lex.c: fix bug in reading line numbers in #line lines. fc updated to pass -Idir options to f2c. Thu Dec 29 09:48:03 EST 1994 Fix bug (e.g., addressing fault) in diagnosing inconsistency in the type of function eta in the following example: function foo(c1,c2) double complex foo,c1,c2 double precision eta foo = eta(c1,c2) end function eta(c1,c2) double complex eta,c1,c2 eta = c1*c2 end Mon Jan 2 13:27:26 EST 1995 Retain casts for SNGL (or FLOAT) that were erroneously optimized away. Example: subroutine foo(a,b) double precision a,b a = float(b) ! now rendered as *a = (real) (*b); end Use float (rather than double) temporaries in certain expressions of type complex. Example: the temporary for sngl(b) in complex a double precision b a = sngl(b) - (3.,4.) is now of type float. Fri Jan 6 00:00:27 EST 1995 Adjust intrinsic function cmplx to act as dcmplx (returning double complex rather than complex) if either of its args is of type double precision. The double temporaries used prior to 2 Jan. 1995 previously gave it this same behavior. Thu Jan 12 12:31:35 EST 1995 Adjust -krd to use double temporaries in some calculations of type complex. libf77: pow_[dhiqrz][hiq].c: adjust x**i to work on machines that sign-extend right shifts when i is the most negative integer. Wed Jan 25 00:14:42 EST 1995 Fix memory fault in handling overlapping initializations in block data common /zot/ d double precision d(3) character*6 v(4) real r(2) equivalence (d(3),r(1)), (d(1),v(1)) data v/'abcdef', 'ghijkl', 'mnopqr', 'stuvwx'/ data r/4.,5./ end names.c: add "far", "huge", "near" to c_keywords (causing them to have __ appended when used as local variables). libf77: add s_copyow.c, an alternative to s_copy.c for handling (illegal) character assignments where the right- and left-hand sides overlap, as in a(2:4) = a(1:3). Thu Jan 26 14:21:19 EST 1995 libf77: roll s_catow.c and s_copyow.c into s_cat.c and s_copy.c, respectively, allowing the left-hand side of a character assignment to appear on its right-hand side unless s_cat.c and s_copy.c are compiled with -DNO_OVERWRITE (which is a bit more efficient). Fortran 77 forbids the left-hand side from participating in the right-hand side (of a character assignment), but Fortran 90 allows it. libi77: wref.c: fix glitch in printing the exponent of 0 when GOOD_SPRINTF_EXPONENT is not #defined. Fri Jan 27 12:25:41 EST 1995 Under -C++ -ec (or -C++ -e1c), surround struct declarations with #ifdef __cplusplus extern "C" { #endif and #ifdef __cplusplus } #endif (This isn't needed with cfront, but apparently is necessary with some other C++ compilers.) libf77: minor tweak to s_copy.c: copy forward whenever possible (for better cache behavior). Wed Feb 1 10:26:12 EST 1995 Complain about parameter statements that assign values to dummy arguments, as in subroutine foo(x) parameter(x = 3.4) end Sat Feb 4 20:22:02 EST 1995 fc: omit "lib=/lib/num/lib.lo". Wed Feb 8 08:41:14 EST 1995 Minor changes to exec.c, putpcc.c to avoid "bad tag" or "error in frexpr" with certain invalid Fortran. Sat Feb 11 08:57:39 EST 1995 Complain about integer overflows, both in simplifying integer expressions, and in converting integers from decimal to binary. Fix a memory fault in putcx1() associated with invalid input. Thu Feb 23 11:20:59 EST 1995 Omit MAXTOKENLEN; realloc token if necessary (to handle very long strings). Fri Feb 24 11:02:00 EST 1995 libi77: iio.c: z_getc: insert (unsigned char *) to allow internal reading of characters with high-bit set (on machines that sign-extend characters). Tue Mar 14 18:22:42 EST 1995 Fix glitch (in io.c) in handling 0-length strings in format statements, as in write(*,10) 10 format(' ab','','cd') libi77: lread.c and rsfe.c: adjust s_rsle and s_rsfe to check for end-of-file (to prevent infinite loops with empty read statements). Wed Mar 22 10:01:46 EST 1995 f2c.ps: adjust discussion of -P on p. 7 to reflect a change made 3 Feb. 1993: -P no longer implies -A. Fri Apr 21 18:35:00 EDT 1995 fc script: remove absolute paths (since PATH specifies only standard places). On most systems, it's still necessary to adjust the PATH assignment at the start of fc to fit the local conventions. Fri May 26 10:03:17 EDT 1995 fc script: add recognition of -P and .P files. libi77: iio.c: z_wnew: fix bug in handling T format items in internal writes whose last item is written to an earlier position than some previous item. Wed May 31 11:39:48 EDT 1995 libf77: added subroutine exit(rc) (with integer return code rc), which works like a stop statement but supplies rc as the program's return code. Fri Jun 2 11:56:50 EDT 1995 Fix memory fault in parameter (x=2.) data x /2./ end This now elicits two error messages; the second ("too many initializers"), though not desirable, seems hard to eliminate without considerable hassle. Mon Jul 17 23:24:20 EDT 1995 Fix botch in simplifying constants in certain complex expressions. Example: subroutine foo(s,z) double complex z double precision s, M, P parameter ( M = 100.d0, P = 2.d0 ) z = M * M / s * dcmplx (1.d0, P/M) *** The imaginary part of z was miscomputed *** end Under -ext, complain about nonintegral dimensions. Fri Jul 21 11:18:36 EDT 1995 Fix glitch on line 159 of init.c: change "(shortlogical *)0)", to "(shortlogical *)0", This affects multiple entry points when some but not all have arguments of type logical*2. libi77: adjust lwrite.c, wref.c, wrtfmt.c so compiling with -DWANT_LEAD_0 causes formatted writes of floating-point numbers of magnitude < 1 to have an explicit 0 before the decimal point (if the field-width permits it). Note that the Fortran 77 Standard leaves it up to the implementation whether to supply these superfluous zeros. Tue Aug 1 09:25:56 EDT 1995 Permit real (or double precision) parameters in dimension expressions. Mon Aug 7 08:04:00 EDT 1995 Append "_eqv" rather than just "_" to names that that appear in EQUIVALENCE statements as well as structs in f2c.h (to avoid a conflict when these names also name common blocks). Tue Aug 8 12:49:02 EDT 1995 Modify yesterday's change: merge st_fields with c_keywords, to cope with equivalences introduced to permit initializing numeric variables with character data. DATA statements causing these equivalences can appear after executable statements, so the only safe course is to rename all local variable with names in the former st_fields list. This has the unfortunate side effect that the common local variable "i" will henceforth be renamed "i__". Wed Aug 30 00:19:32 EDT 1995 libf77: add F77_aloc, now used in s_cat and system_ (to allocate memory and check for failure in so doing). libi77: improve MSDOS logic in backspace.c. Wed Sep 6 09:06:19 EDT 1995 libf77: Fix return type of system_ (integer) under -DKR_headers. libi77: Move some f_init calls around for people who do not use libF77's main(); now open and namelist read statements that are the first I/O statements executed should work right in that context. Adjust namelist input to treat a subscripted name whose subscripts do not involve colons similarly to the name without a subscript: accept several values, stored in successive elements starting at the indicated subscript. Adjust namelist output to quote character strings (avoiding confusion with arrays of character strings). Thu Sep 7 00:36:04 EDT 1995 Fix glitch in integer*8 exponentiation function: it's pow_qq, not pow_qi. libi77: fix some bugs with -DAllow_TYQUAD (for integer*8); when looking for the &name that starts NAMELIST input, treat lines whose first nonblank character is something other than &, $, or ? as comment lines (i.e., ignore them), unless rsne.c is compiled with -DNo_Namelist_Comments. Thu Sep 7 09:05:40 EDT 1995 libi77: rdfmt.c: one more tweak for -DAllow_TYQUAD. Tue Sep 19 00:03:02 EDT 1995 Adjust handling of floating-point subscript bounds (a questionable f2c extension) so subscripts in the generated C are of integral type. Move #define of roundup to proc.c (where its use is commented out); version.c left at 19950918. Wed Sep 20 17:24:19 EDT 1995 Fix bug in handling ichar() under -h. Thu Oct 5 07:52:56 EDT 1995 libi77: wrtfmt.c: fix bug with t editing (f__cursor was not always zeroed in mv_cur). Tue Oct 10 10:47:54 EDT 1995 Under -ext, warn about X**-Y and X**+Y. Following the original f77, f2c treats these as X**(-Y) and X**(+Y), respectively. (They are not allowed by the official Fortran 77 Standard.) Some Fortran compilers give a bizarre interpretation to larger contexts, making multiplication noncommutative: they treat X**-Y*Z as X**(-Y*Z) rather than X**(-Y)*Z, which, following the rules of Fortran 77, is the same as (X**(-Y))*Z. Wed Oct 11 13:27:05 EDT 1995 libi77: move defs of f__hiwater, f__svic, f__icptr from wrtfmt.c to err.c. This should work around a problem with buggy loaders and sometimes leads to smaller executable programs. Sat Oct 21 23:54:22 EDT 1995 Under -h, fix bug in the treatment of ichar('0') in arithmetic expressions. Demote to -dneg (a new command-line option not mentioned in the man page) imitation of the original f77's treatment of unary minus applied to a REAL operand (yielding a DOUBLE PRECISION result). Previously this imitation (which was present for debugging) occurred under (the default) -!R. It is still suppressed by -R. Tue Nov 7 23:52:57 EST 1995 Adjust assigned GOTOs to honor SAVE declarations. Add comments about ranlib to lib[FI]77/README and makefile. Tue Dec 19 22:54:06 EST 1995 libf77: s_cat.c: fix bug when 2nd or later arg overlaps lhs. Tue Jan 2 17:54:00 EST 1996 libi77: rdfmt.c: move #include "ctype.h" up before "stdlib.h"; no change to Version.c. Sun Feb 25 22:20:20 EST 1996 Adjust expr.c to permit raising the integer constants 1 and -1 to negative constant integral powers. Avoid faulting when -T and -d are not followed by a directory name (immediately, without intervening spaces). Wed Feb 28 12:49:01 EST 1996 Fix a glitch in handling complex parameters assigned a "wrong" type. Example: complex d, z parameter(z = (0d0,0d0)) data d/z/ ! elicited "non-constant initializer" call foo(d) end Thu Feb 29 00:53:12 EST 1996 Fix bug in handling character parameters assigned a char() value. Example: character*2 b,c character*1 esc parameter(esc = char(27)) integer i data (b(i:i),i=1,2)/esc,'a'/ data (c(i:i),i=1,2)/esc,'b'/ ! memory fault call foo(b,c) end Fri Mar 1 23:44:51 EST 1996 Fix glitch in evaluating .EQ. and .NE. when both operands are logical constants (.TRUE. or .FALSE.). Fri Mar 15 17:29:54 EST 1996 libi77: lread.c, rsfe.c: honor END= in READ stmts with empty iolist. Tue Mar 19 23:08:32 EST 1996 lex.c: arrange for a "statement" consisting of a single short bogus keyword to elicit an error message showing the whole keyword. The error message formerly omitted the last letter of the bad keyword. libf77: s_cat.c: supply missing break after overlap detection. Mon May 13 23:35:26 EDT 1996 Recognize Fortran 90's /= as a synonym for .NE.. (<> remains a synonym for .NE..) Emit an empty int function of no arguments to supply an external name to named block data subprograms (so they can be called somewhere to force them to be loaded from a library). Fix bug (memory fault) in handling the following illegal Fortran: parameter(i=1) equivalence(i,j) end Treat cdabs, cdcos, cdexp, cdlog, cdsin, and cdsqrt as synonyms for the double complex intrinsics zabs, zcos, zexp, zlog, zsin, and zsqrt, respectively, unless -cd is specified. Recognize the Fortran 90 bit-manipulation intrinsics btest, iand, ibclr, ibits, ibset, ieor, ior, ishft, and ishftc, unless -i90 is specified. Note that iand, ieor, and ior are thus now synonyms for "and", "xor", and "or", respectively. Add three macros (bit_test, bit_clear, bit_set) to f2c.h for use with btest, ibclr, and ibset, respectively. Add new functions [lq]bit_bits, [lq]bit_shift, and [lq]_bit_cshift to libF77 for use with ibits, ishft, and ishftc, respectively. Add integer function ftell(unit) (returning -1 on error) and subroutine fseek(unit, offset, whence, *) to libI77 (with branch to label * on error). Tue May 14 23:21:12 EDT 1996 Fix glitch (possible memory fault, or worse) in handling multiple entry points with names over 28 characters long. Mon Jun 10 01:20:16 EDT 1996 Update netlib E-mail and ftp addresses in f2c/readme and f2c/src/readme (which are different files) -- to reflect the upcoming breakup of AT&T. libf77: trivial tweaks to F77_aloc.c and system_.c; Version.c not changed. libi77: Adjust rsli.c and lread.c so internal list input with too few items in the input string will honor end= . Mon Jun 10 22:59:57 EDT 1996 Add Bits_per_Byte to sysdep.h and adjust definition of Table_size to depend on Bits_per_Byte (forcing Table_size to be a power of 2); in lex.c, change "comstart[c & 0xfff]" to "comstart[c & (Table_size-1)]" to avoid an out-of-range subscript on end-of-file. Wed Jun 12 00:24:28 EDT 1996 Fix bug in output.c (dereferencing a freed pointer) revealed in print * !np in out_call in output.c clobbered by free end !during out_expr. Wed Jun 19 08:12:47 EDT 1996 f2c.h: add types uinteger, ulongint (for libF77); add qbit_clear and qbit_set macros (in a commented-out section) for integer*8. For integer*8, use qbit_clear and qbit_set for ibclr and ibset. libf77: add casts to unsigned in [lq]bitshft.c. Thu Jun 20 13:30:43 EDT 1996 Complain at character*(*) in common (rather than faulting). Fix bug in recognizing hex constants that start with "16#" (e.g., 16#1234abcd, which is a synonym for z'1234abcd'). Fix bugs in constant folding of expressions involving btest, ibclr, and ibset. Fix bug in constant folding of rshift(16#80000000, -31) (on a 32-bit machine; more generally, the bug was in constant folding of rshift(ibset(0,NBITS-1), 1-NBITS) when f2c runs on a machine with long ints having NBITS bits. Mon Jun 24 07:58:53 EDT 1996 Adjust struct Literal and newlabel() function to accommodate huge source files (with more than 32767 newlabel() invocations). Omit .c file when the .f file has a missing final end statement. Wed Jun 26 14:00:02 EDT 1996 libi77: Add discussion of MXUNIT (highest allowed Fortran unit number) to libI77/README. Fri Jun 28 14:16:11 EDT 1996 Fix glitch with -onetrip: the temporary variable used for nonconstant initial loop variable values was recycled too soon. Example: do i = j+1, k call foo(i+1) ! temp for j+1 was reused here enddo end Tue Jul 2 16:11:27 EDT 1996 formatdata.c: add a 0 to the end of the basetype array (for TYBLANK) (an omission that was harmless on most machines). expr.c: fix a dereference of NULL that was only possible with buggy input, such as subroutine $sub(s) ! the '$' is erroneous character s*(*) s(1:) = ' ' end Sat Jul 6 00:44:56 EDT 1996 Fix glitch in the intrinsic "real" function when applied to a complex (or double complex) variable and passed as an argument to some intrinsic functions. Example: complex a b = sqrt(a) end Fix glitch (only visible if you do not use f2c's malloc and the malloc you do use is defective in the sense that malloc(0) returns 0) in handling include files that end with another include (perhaps followed by comments). Fix glitch with character*(*) arguments named "h" and "i" when the body of the subroutine invokes the intrinsic LEN function. Arrange that after a previous "f2c -P foo.f" has produced foo.P, running "f2c foo.P foo.f" will produce valid C when foo.f contains call sub('1234') end subroutine sub(msg) end Specifically, the length argument in "call sub" is now suppressed. With or without foo.P, it is also now suppressed when the order of subprograms in file foo.f is reversed: subroutine sub(msg) end call sub('1234') end Adjust copyright notices to reflect AT&T breakup. Wed Jul 10 09:25:49 EDT 1996 Fix bug (possible memory fault) in handling erroneously placed and inconsistent declarations. Example that faulted: character*1 w(8) call foo(w) end subroutine foo(m) data h /0.5/ integer m(2) ! should be before data end Fix bug (possible fault) in handling illegal "if" constructions. Example (that faulted): subroutine foo(i,j) if (i) then ! bug: i is integer, not logical else if (j) then ! bug: j is integer, not logical endif end Fix glitch with character*(*) argument named "ret_len" to a character*(*) function. Wed Jul 10 23:04:16 EDT 1996 Fix more glitches in the intrinsic "real" function when applied to a complex (or double complex) variable and passed as an argument to some intrinsic functions. Example: complex a, b r = sqrt(real(conjg(a))) + sqrt(real(a*b)) end Thu Jul 11 17:27:16 EDT 1996 Fix a memory fault associated with complicated, illegal input. Example: subroutine goo character a call foo(a) ! inconsistent with subsequent def and call end subroutine foo(a) end call foo(a) end Wed Jul 17 19:18:28 EDT 1996 Fix yet another case of intrinsic "real" applied to a complex argument. Example: complex a(3) x = sqrt(real(a(2))) ! gave error message about bad tag end Mon Aug 26 11:28:57 EDT 1996 Tweak sysdep.c for non-Unix systems in which process ID's can be over 5 digits long. Tue Aug 27 08:31:32 EDT 1996 Adjust the ishft intrinsic to use unsigned right shifts. (Previously, a negative constant second operand resulted in a possibly signed shift.) Thu Sep 12 14:04:07 EDT 1996 equiv.c: fix glitch with -DKR_headers. libi77: fmtlib.c: fix bug in printing the most negative integer. Fri Sep 13 08:54:40 EDT 1996 Diagnose some illegal appearances of substring notation. Tue Sep 17 17:48:09 EDT 1996 Fix fault in handling some complex parameters. Example: subroutine foo(a) double complex a, b parameter(b = (0,1)) a = b ! f2c faulted here end Thu Sep 26 07:47:10 EDT 1996 libi77: fmt.h: for formatted writes of negative integer*1 values, make ic signed on ANSI systems. If formatted writes of integer*1 values trouble you when using a K&R C compiler, switch to an ANSI compiler or use a compiler flag that makes characters signed. Tue Oct 1 14:41:36 EDT 1996 Give a better error message when dummy arguments appear in data statements. Thu Oct 17 13:37:22 EDT 1996 Fix bug in typechecking arguments to character and complex (or double complex) functions; the bug could cause length arguments for character arguments to be omitted on invocations appearing textually after the first invocation. For example, in subroutine foo character c complex zot call goo(zot(c), zot(c)) end the length was omitted from the second invocation of zot, and there was an erroneous error message about inconsistent calling sequences. Wed Dec 4 13:59:14 EST 1996 Fix bug revealed by subroutine test(cdum,rdum) complex cdum rdum=cos(real(cdum)) ! "Unexpected tag 3 in opconv_fudge" end Fix glitch in parsing "DO 10 D0 = 1, 10". Fix glitch in parsing real*8 x real*8 x ! erroneous "incompatible type" message call foo(x) end Mon Dec 9 23:15:02 EST 1996 Fix glitch in parameter adjustments for arrays whose lower bound depends on a scalar argument. Example: subroutine bug(p,z,m,n) integer z(*),m,n double precision p(z(m):z(m) + n) ! p_offset botched call foo(p(0), p(n)) end libi77: complain about non-positive rec= in direct read and write statements. libf77: trivial adjustments; Version.c not changed. Wed Feb 12 00:18:03 EST 1997 output.c: fix (seldom problematic) glitch in out_call: put parens around the ... in a test of the form "if (q->tag == TADDR && ...)". vax.c: fix bug revealed in the "psi_offset =" assignment in the following example: subroutine foo(psi,m) integer z(100),m common /a/ z double precision psi(z(m):z(m) + 10) call foo(m+1, psi(0),psi(10)) end Mon Feb 24 23:44:54 EST 1997 For consistency with f2c's current treatment of adjacent character strings in FORMAT statements, recognize a Hollerith string following a string (and merge adjacent strings in FORMAT statements). Wed Feb 26 13:41:11 EST 1997 New libf2c.zip, a combination of the libf77 and libi77 bundles (and available only by ftp). libf77: adjust functions with a complex output argument to permit aliasing it with input arguments. (For now, at least, this is just for possible benefit of g77.) libi77: tweak to ftell_.c for systems with strange definitions of SEEK_SET, etc. Tue Apr 8 20:57:08 EDT 1997 libf77: [cz]_div.c: tweaks invisible on most systems (that may improve things slightly with optimized compilation on systems that use gratuitous extra precision). libi77: fmt.c: adjust to complain at missing numbers in formats (but still treat missing ".nnn" as ".0"). Fri Apr 11 14:05:57 EDT 1997 libi77: err.c: attempt to make stderr line buffered rather than fully buffered. (Buffering is needed for format items T and TR.) Thu Apr 17 22:42:43 EDT 1997 libf77: add F77_aloc.o to makefile (and makefile.u in libf2c.zip). Fri Apr 25 19:32:09 EDT 1997 libf77: add [de]time_.c (which may give trouble on some systems). Tue May 27 09:18:52 EDT 1997 libi77: ftell_.c: fix typo that caused the third argument to be treated as 2 on some systems. Mon Jun 9 00:04:37 EDT 1997 libi77 (and libf2c.zip): adjust include order in err.c lread.c wref.c rdfmt.c to include fmt.h (etc.) after system includes. Version.c not changed. Mon Jul 21 16:04:54 EDT 1997 proc.c: fix glitch in logic for "nonpositive dimension" message. libi77: inquire.c: always include string.h (for possible use with -DNON_UNIX_STDIO); Version.c not changed. Thu Jul 24 17:11:23 EDT 1997 Tweak "Notice" to reflect the AT&T breakup -- we missed it when updating the copyright notices in the source files last summer. Adjust src/makefile so malloc.o is not used by default, but can be specified with "make MALLOC=malloc.o". Add comments to src/README about the "CRAY" T3E. Tue Aug 5 14:53:25 EDT 1997 Add definition of calloc to malloc.c; this makes f2c's malloc work on some systems where trouble hitherto arose because references to calloc brought in the system's malloc. (On sensible systems, calloc is defined separately from malloc. To avoid confusion on other systems, f2c/malloc.c now defines calloc.) libi77: lread.c: adjust to accord with a change to the Fortran 8X draft (in 1990 or 1991) that rescinded permission to elide quote marks in namelist input of character data; to get the old behavior, compile with F8X_NML_ELIDE_QUOTES #defined. wrtfmt.o: wrt_G: tweak to print the right number of 0's for zero under G format. Sat Aug 16 05:45:32 EDT 1997 libi77: iio.c: fix bug in internal writes to an array of character strings that sometimes caused one more array element than required by the format to be blank-filled. Example: format(1x). Wed Sep 17 00:39:29 EDT 1997 libi77: fmt.[ch] rdfmt.c wrtfmt.c: tweak struct syl for machines with 64-bit pointers and 32-bit ints that did not 64-bit align struct syl (e.g., Linux on the DEC Alpha). This change should be invisible on other machines. Sun Sep 21 22:05:19 EDT 1997 libf77: [de]time_.c (Unix systems only): change return type to double. Thu Dec 4 22:10:09 EST 1997 Fix bug with handling large blocks of comments (over 4k); parts of the second and subsequent blocks were likely to be lost (not copied into comments in the resulting C). Allow comment lines to be longer before breaking them. Mon Jan 19 17:19:27 EST 1998 makefile: change the rule for making gram.c to one for making gram1.c; henceforth, asking netlib to "send all from f2c/src" will bring you a working gram.c. Nowadays there are simply too many broken versions of yacc floating around. libi77: backspace.c: for b->ufmt==0, change sizeof(int) to sizeof(uiolen). On machines where this would make a difference, it is best for portability to compile libI77 with -DUIOLEN_int, which will render the change invisible. Tue Feb 24 08:35:33 EST 1998 makefile: remove gram.c from the "make clean" rule. Wed Feb 25 08:29:39 EST 1998 makefile: change CFLAGS assignment to -O; add "veryclean" rule. Wed Mar 4 13:13:21 EST 1998 libi77: open.c: fix glitch in comparing file names under -DNON_UNIX_STDIO. Mon Mar 9 23:56:56 EST 1998 putpcc.c: omit an unnecessary temporary variable in computing (expr)**3. libf77, libi77: minor tweaks to make some C++ compilers happy; Version.c not changed. Wed Mar 18 18:08:47 EST 1998 libf77: minor tweaks to [ed]time_.c; Version.c not changed. libi77: endfile.c, open.c: acquire temporary files from tmpfile(), unless compiled with -DNON_ANSI_STDIO, which uses mktemp(). New buffering scheme independent of NON_UNIX_STDIO for handling T format items. Now -DNON_UNIX_STDIO is no longer be necessary for Linux, and libf2c no longer causes stderr to be buffered -- the former setbuf or setvbuf call for stderr was to make T format items work. open.c: use the Posix access() function to check existence or nonexistence of files, except under -DNON_POSIX_STDIO, where trial fopen calls are used. In open.c, fix botch in changes of 19980304. libf2c.zip: the PC makefiles are now set for NT/W95, with comments about changes for DOS. Fri Apr 3 17:22:12 EST 1998 Adjust fix of 19960913 to again permit substring notation on character variables in data statements. Sun Apr 5 19:26:50 EDT 1998 libi77: wsfe.c: make $ format item work: this was lost in the changes of 17 March 1998. Sat May 16 19:08:51 EDT 1998 Adjust output of ftnlen constants: rather than appending L, prepend (ftnlen). This should make the resulting C more portable, e.g., to systems (such as DEC Alpha Unix systems) on which long may be longer than ftnlen. Adjust -r so it also casts REAL expressions passed to intrinsic functions to REAL. Wed May 27 16:02:35 EDT 1998 libf2c.zip: tweak description of compiling libf2c for INTEGER*8 to accord with makefile.u rather than libF77/makefile. Thu May 28 22:45:59 EDT 1998 libi77: backspace.c dfe.c due.c iio.c lread.c rsfe.c sue.c wsfe.c: set f__curunit sooner so various error messages will correctly identify the I/O unit involved. libf2c.zip: above, plus tweaks to PC makefiles: for some purposes, it's still best to compile with -DMSDOS (even for use with NT). Thu Jun 18 01:22:52 EDT 1998 libi77: lread.c: modified so floating-point numbers (containing either a decimal point or an exponent field) are treated as errors when they appear as list input for integer data. Compile lread.c with -DALLOW_FLOAT_IN_INTEGER_LIST_INPUT to restore the old behavior. Mon Aug 31 10:38:54 EDT 1998 formatdata.c: if possible, and assuming doubles must be aligned on double boundaries, use existing holes in DATA for common blocks to force alignment of the block. For example, block data common /abc/ a, b double precision a integer b(2) data b(2)/1/ end used to generate struct { integer fill_1[3]; integer e_2; doublereal e_3; } abc_ = { {0}, 1, 0. }; and now generates struct { doublereal fill_1[1]; integer fill_2[1]; integer e_3; } abc_ = { {0}, {0}, 1 }; In the old generated C, e_3 was added to force alignment; in the new C, fill_1 does this job. Mon Sep 7 19:48:51 EDT 1998 libi77: move e_wdfe from sfe.c to dfe.c, where it was originally. Why did it ever move to sfe.c? Tue Sep 8 10:22:50 EDT 1998 Treat dreal as a synonym for dble unless -cd is specified on the command line. Sun Sep 13 22:23:41 EDT 1998 format.c: fix bug in writing prototypes under f2c -A ... *.P: under some circumstances involving external functions with no known type, a null pointer was passed to printf. Tue Oct 20 23:25:54 EDT 1998 Comments added to libf2c/README and libF77/README, pointing out the need to modify signal1.h on some systems. Wed Feb 10 22:59:52 EST 1999 defs.h lex.c: permit long names (up to at least roughly MAX_SHARPLINE_LEN = 1000 characters long) in #line lines (which only matters under -g). fc: add -U option; recognize .so files. Sat Feb 13 10:18:27 EST 1999 libf2c: endfile.c, lread.c, signal1.h0: minor tweaks to make some (C++) compilers happier; f77_aloc.c: make exit_() visible to C++ compilers. Version strings not changed. Thu Mar 11 23:14:02 EST 1999 Modify f2c (exec.c, expr.c) to diagnose incorrect mixing of types when (f2c extended) intrinsic functions are involved, as in (not(17) .and. 4). Catching this in the first executable statement is a bit tricky, as some checking must be postponed until all statement function declarations have been parsed. Thus there is a chance of today's changes introducing bugs under (let us hope) unusual conditions. Sun Mar 28 13:17:44 EST 1999 lex.c: tweak to get the file name right in error messages caused by statements just after a # nnn "filename" line emitted by the C preprocessor. (The trouble is that the line following the # nnn line must be read to see if it is a continuation of the stuff that preceded the # nnn line.) When # nnn "filename" lines appear among the lines for a Fortran statement, the filename reported in an error message for the statement should now be the file that was current when the first line of the statement was read. Sun May 2 22:38:25 EDT 1999 libf77, libi77, libf2c.zip: make getenv_() more portable (call getenv() rather than knowing about char **environ); adjust some complex intrinsics to work with overlapping arguments (caused by inappropriate use of equivalence); open.c: get "external" versus "internal" right in the error message if a file cannot be opened; err.c: cast a pointer difference to (int) for %d; rdfmt.c: omit fixed-length buffer that could be overwritten by formats Inn or Lnn with nn > 83. Mon May 3 13:14:07 EDT 1999 "Invisible" changes to omit a few compiler warnings in f2c and libf2c; two new casts in libf2c/open.c that matter with 64-bit longs, and one more tweak (libf2c/c_log.c) for pathological equivalences. Minor update to "fc" script: new -L flag and comment correction. Fri Jun 18 02:33:08 EDT 1999 libf2c.zip: rename backspace.c backspac.c, and fix a glitch in it -- b->ufd may change in t_runc(). (For now, it's still backspace.c in the libi77 bundle.) Sun Jun 27 22:05:47 EDT 1999 libf2c.zip, libi77: rsne.c: fix bug in namelist input: a misplaced increment could cause wrong array elements to be assigned; e.g., "&input k(5)=10*1 &end" assigned k(5) and k(15 .. 23). Tue Sep 7 14:10:24 EDT 1999 f2c.h, libf2c/f2c.h0, libf2c/README: minor tweaks so a simple sed command converts f2c.h == libf2c/f2c.h0 to a form suitable for machines with 8-byte longs and doubles, 4-byte int's and floats, while working with a forthcoming (ill-advised) update to the C standard that outlaws plain "unsigned". f2c.h, libf2c/f2c.h0: change "if 0" to "#ifdef INTEGER_STAR_8". libf77, libf2c.zip: [cz]_div.c and README: arrange for compilation under -DIEEE_COMPLEX_DIVIDE to make these routines avoid calling sig_die when the denominator of a complex or double complex division vanishes; instead, they return pairs of NaNs or Infinities, depending whether the numerator also vanishes or not. Tue Oct 5 23:50:14 EDT 1999 formatdata.c, io.c, output.c, sysdep.c: adjust to make format strings legal when they contain 8-bit characters with the high bit on. (For many C compilers, this is not necessary, but it the ANSI/ISO C standard does not require this to work.) libf2c.zip: tweak README and correct xsum0.out. Mon Oct 25 17:30:54 EDT 1999 io.c: fix glitch introduced in the previous change (19991005) that caused format(' %') to print "%%" rather than "%". Mon Nov 15 12:10:35 EST 1999 libf2c.zip: fix bug with the sequence backspace(n); endfile(n); rewind(n); read(n). Supply missing (long) casts in a couple of places where they matter when size(ftnint) == sizeof(int) < sizeof(long). Tue Jan 18 19:22:24 EST 2000 Arrange for parameter statements involving min(...) and max(...) functions of three or more arguments to work. Warn about text after "end" (rather than reporting a syntax error with a surprising line number). Accept preprocessor line numbers of the form "# 1234" (possibly with trailing blanks). Accept a comma after write(...) and before a list of things to write. Fri Jan 21 17:26:27 EST 2000 Minor updates to make compiling Win32 console binaries easier. A side effect is that the MSDOS restriction of only one Fortran file per invocation is lifted (and "f2c *.f") works. Tue Feb 1 18:38:32 EST 2000 f2c/src/tokdefs.h added (to help people on non-Unix systems -- the makefile has always had a rule for generating tokdefs.h). Fri Mar 10 18:48:17 EST 2000 libf77, libf2c.zip: z_log.c: the real part of the double complex log of numbers near, e.g., (+-1,eps) with |eps| small is now more accurate. For example if z = (1,1d-7), then "write(*,*) z" now writes "(5.E-15,1.E-07" rather than the previous "(4.88498131E-15,1.E-07)". Thu Apr 20 13:02:54 EDT 2000 libf77, libi77, libf2c.zip: s_cat.c, rsne.c, xwsne.c: fix type errors that only matter if sizeof(ftnint) != sizeof(ftnlen). Tue May 30 23:36:18 EDT 2000 expr.c: adjust subcheck() to use a temporary variable of type TYLONG rather than TYSHORT under -C -I2. Wed May 31 08:48:03 EDT 2000 Simplify yesterday's adjustment; today's change should be invisible. Tue Jul 4 22:52:21 EDT 2000 misc.c, function "addressable": fix fault with "f2c -I2 foo.f" when foo.f consists of the 4 lines subroutine foo(c) character*(*) c i = min(len(c),23) end Sundry files: tweaks for portability, e.g., for compilation by overly fastidious C++ compilers; "false" and "true" now treated as C keywords (so they get two underscores appended). libf77, libi77, libf2c.zip: "invisible" adjustments to permit compilation by C++ compilers; version numbers not changed. Thu Jul 6 23:46:07 EDT 2000 Various files: tweaks to banish more compiler warnings. lib?77, libf2c.zip/makefile.u: add "|| true" to ranlib invocations. Thanks to Nelson H. F. Beebe for messages leading to these changes (and to many of the ones two days ago). xsum.c: tweak include order. Fri Jul 7 18:01:25 EDT 2000 fc: accept -m xxx or -mxxx, pass them to the compiler as -mxxx (suggestion of Nelson Beebe). Note that fc simply appends to CFLAGS, so system-specific stuff can be supplied in the environment variable CFLAGS. With some shells, invocations of the form CFLAGS='system-specific stuff' fc ... are one way to do this. Thu Aug 17 21:38:36 EDT 2000 Fix obscure glitch: in "Error on line nnn of ...: Bad # line:...", get nnn right. Sat Sep 30 00:28:30 EDT 2000 libf77, libf2c.zip: dtime_.c, etime_.c: use floating-point divide; dtime_.d, erf_.c, erfc_.c, etime.c: for use with "f2c -R", compile with -DREAL=float. Tue Dec 5 22:55:56 EST 2000 lread.c: under namelist input, when reading a logical array, treat Tstuff= and Fstuff= as new assignments rather than as logical constants. Fri Feb 23 00:43:56 EST 2001 libf2c: endfile.c: adjust to use truncate() unless compiled with -DNO_TRUNCATE (or with -DMSDOS). Add libf2c/mkfile.plan9. Sat Feb 24 21:14:24 EST 2001 Prevent malloc(0) when a subroutine of no arguments has an entry with no arguments, as in subroutine foo entry goo end Fix a fault that was possible when MAIN (illegally) had entry points. Fix a buffer overflow connected with the error message for names more than MAXNAMELEN (i.e., 50) bytes long. Fix a bug in command-line argument passing that caused the invocation "f2c -!czork foo.f" to complain about two invalid flags ('-ork' and '-oo.f') instead of just one ('-ork'). fc: add -s option (strip executable); portability tweaks. Adjustments to handing of integer*8 to permit processing 8-byte hex, binary, octal, and decimal constants. The adjustments are only available when type long long (for >= 64 bit integers) is available to f2c; they are assumed available unless f2c is compiled with either -DNO_TYQUAD or -DNO_LONGLONG. As has long been the case, compilation of f2c itself with -DNO_TYQUAD eliminates recognition of integer*8 altogether. Compilation with just -DNO_LONGLONG permits the previous handling of integer*8, which could only handle 32-bit constants associated with integer*8 variables. New command-line argument -i8const (available only when f2c itself is compiled with neither -DNO_TYQUAD nor -DNO_LONGLONG) suppresses the new automatic promotion of integer constants too long to express as 32-bit values to type integer*8. There are corresponding updates to f2c.1 and f2c.1t. Wed Feb 28 00:50:04 EST 2001 Adjust misc.c for (older) systems that recognize long long but do not have LLONG_MAX or LONGLONG_MAX in limits.h. main.c: filter out bad files before dofork loop to avoid trouble in Win32 "f2c.exe" binaries. Thu Mar 1 16:25:19 EST 2001 Cosmetic change for consistency with some other netlib directories: change NO_LONGLONG to NO_LONG_LONG. (This includes adjusting the above entry for Feb 23 2001.) No change (other than timestamp) to version.c. libf2c: endfile.c: switch to ftruncate (absent -DNO_TRUNCATE), thus permitting truncation of scratch files on true Unix systems, where scratch files have no name. Add an fflush() (surprisingly) needed on some Linux systems. Tue Mar 20 22:03:23 EST 2001 expr.c: complain ("impossible conversion") about attempts to assign character expressions ... to integer variables, rather than implicitly assigning ichar(...). Sat Jun 23 23:08:22 EDT 2001 New command-line option -trapuv adds calls on _uninit_f2c() to prologs to dynamically initialize local variables, except those appearing in SAVE or DATA statements, with values that may help find references to uninitialized variables. For example, with IEEE arithmetic, floating- point variables are initialized to signaling NaNs. expr.c: new warning for out-of-bounds constant substring expressions. Under -C, such expressions now inhibit C output. libf2c/mkfile.plan9: fix glitch with rule for "check" (or xsum.out). libf2c.zip: add uninit.c (for _uninit_f2c()) in support of -trapuv. fc, f2c.1, f2c.1t: adjust for -trapuv. Thu Jul 5 22:00:51 EDT 2001 libf2c.zip: modify uninit.c for __mc68k__ under Linux. Wed Aug 22 08:01:37 EDT 2001 cds.c, expr.c: in constants, preserve the sign of 0. expr.c: fix some glitches in folding constants to integer*8 (when NO_LONG_LONG is not #defined). intr.c: fold constant min(...) and max(...) expressions. Fri Nov 16 02:00:03 EST 2001 libf2c.zip: tweak to permit handling files over 2GB long where possible, with suitable -D options, provided for some systems in new header file sysdep1.h (copied from sysdep1.h0 by default). Add an fseek to endfile.c to fix a glitch on some systems. Wed Nov 28 17:58:12 EST 2001 libf2c.zip: on IEEE systems, print -0 as -0 when the relevant libf2c/makefile.* is suitably adjusted: see comments about -DSIGNED_ZEROS in libf2c/makefile.*. Fri Jan 18 16:17:44 EST 2002 libf2c.zip: fix bugs (reported by Holger Helmke) in qbit_bits(): wrong return type, missing ~ on y in return value. This affects the intrinsic ibits function for first argument of type integer*8. Thu Feb 7 17:14:43 EST 2002 Fix bug handling leading array dimensions in common: invalid C resulted. Example (after one provided by Dmitry G. Baksheyev): subroutine foo(a) common/c/m integer m, n equivalence(m,n) integer a(n,2) a(1,2) = 3 end Fix a bug, apparently introduced sometime after 19980913, in handling certain substring expressions that involve temporary assignments and the first invocation of an implicitly typed function. When the expressions appeared in "else if (...)" and "do while(...)", the temporary assignments appeared too soon. Examples are hard to find, but here is one (after an example provided by Nat Bachman): subroutine foo(n) character*8 s do while (moo(s(n+1:n+2)) .ge. 2) n = n + 1 enddo end It is hard for f2c to get this sort of example correct when the "untyped" function is a generic intrinsic. When incorrect code would otherwise result, f2c now issues an error message and declines to produce C. For example, subroutine foo(n) character*8 s double precision goo do while (sin(goo(s(n+1:n+2))) .ge. 2) n = n + 1 enddo end gives the new error message, but both subroutine foo(n) character*8 s double precision goo do while (dsin(goo(s(n+1:n+2))) .ge. 2) n = n + 1 enddo end and subroutine foo(n) character*8 s double precision goo do while (sin(goo(min(n, (n-3)**2))) .ge. 2) n = n + 1 enddo end give correct C. Fri Feb 8 08:43:40 EST 2002 Make a cleaner fix of the bug fixed yesterday in handling certain "do while(...)" and "else if (...)" constructs involving auxiliary assignments. (Yesterday's changes to expr.c are recanted; expr.c is now restored to that of 20010820.) Now subroutine foo(n) character*8 s double precision goo do while (sin(goo(s(n+1:n+2))) .ge. 0.2) n = n + 1 enddo end is correctly translated. Thu Mar 14 12:53:08 EST 2002 lex.c: adjust to avoid an error message under -72 when source files are in CRLF form ("text mode" on Microsoft systems), a source line is exactly 72 characters long, and f2c is run on a system (such as a Unix or Linux system) that does not distinguish text and binary modes. Example (in CRLF form): write(*,*)"Hello world, with a source line that is 72 chars long." end libf2c/z_log.c: add code to cope with buggy compilers (e.g., some versions of gcc under -O2 or -O3) that do floating-point comparisons against values computed into extended-precision registers on some systems (such as Intel IA32 systems). Compile with -DNO_DOUBLE_EXTENDED to omit the kludge that circumvents this bug. Thu May 2 19:09:01 EDT 2002 src/misc.c, src/sysdep.h, src/gram.c: tweaks for KR_headers (a rare concern today); version.c touched but left unchanged. libf2c: fix glitch in makefile.vc; KR_header tweaks in s_stop.c and uninit.c (which also had a misplaced #endif). Wed Jun 5 16:13:34 EDT 2002 libf2c: uninit.c: for Linux on an ARM processor, add some #ifndef _FPU... tests; f77vers.c not changed. Tue Jun 25 15:13:32 EDT 2002 New command-line option -K requests old-style ("K&R") C. The default is changed to -A (ANSI/ISO style). Under -K, cast string-length arguments to (ftnlen). This should matter only in the unusual case that "readme" instructs obtaining f2c.h by sed 's/long int /long long /' f2c.h0 >f2c.h Increase defaults for some table sizes: make -Nn802 -Nq300 -Nx400 the default. Fri Sep 6 18:39:24 EDT 2002 libf2c.zip: rsne.c: fix bug with multiple repeat counts in reading namelists, e.g., &nl a(2) = 3*1.0, 2*2.0, 3*3.0 / (Bug found by Jim McDonald, reported by Toon Moene.) Fri Oct 4 10:23:51 EDT 2002 libf2c.zip: uninit.c: on IRIX systems, omit references to shell variables (a dreg). This only matters with f2c -trapuv . Thu Dec 12 22:16:00 EST 2002 proc.c: tweak to omit "* 1" from "a_offset = 1 + a_dim1 * 1;". libf2c.zip: uninit.c: adjust to work with HP-UX B.11.11 as well as HP-UX B.10.20; f77vers.c not changed. Tue Feb 11 08:19:54 EST 2003 Fix a fault with f2c -s on the following example of invalid Fortran (reported by Nickolay A. Khokhlov); "function" should appear before "cat" on the first line: character*(*) cat(a, b) character*(*) a, b cat = a // b end Issue warnings about inappropriate uses of arrays a, b, c and pass a temporary for d in real a(2), b(2), c(2), d call foo((a), 1*b, +c, +d) end (correcting bugs reported by Arnaud Desitter). Thu Mar 6 22:48:08 EST 2003 output.c: fix a bug leading to "Unexpected tag 4 in opconv_fudge" when f2c -s processes the real part of a complex array reference. Example (simplified from netlib/linpack/zchdc.f): subroutine foo(a,work,n,k) integer k, n complex*16 a(n,n), work(n) work(k) = dcmplx(dsqrt(dreal(a(k,k))),0.0d0) end (Thanks to Nickolay A. Khokhlov for the bug report.) Thu Mar 20 13:50:12 EST 2003 format.c: code around a bug (reported by Nelson H. F. Beebe) in some versions of FreeBSD. Compiling with __FreeBSD__ but not NO_FSCANF_LL_BUG #defined or with FSCANF_LL_BUG #defined causes special logic to replace fscanf(infile, "%llx", result) with custom logic. Here's an example (from Beebe) where the bug bit: integer*8 m, n m = 9223372036854775807 end Fri Mar 21 13:14:05 EST 2003 libf2c.zip: err.c: before writing to a file after reading from it, do an f_seek(file, 0, SEEK_CUR) to make writing legal in ANSI C. Fri Jun 6 14:56:44 EDT 2003 libf2c.zip: add comments about libf2c.so (and a rule that works under Linux, after an adjustment to the CFLAGS = line) to libf2c/makefile.u. Sat Oct 25 07:57:53 MDT 2003 README, main.c, sysdep.c: adjust comments about libf2c and expand the comments thereon in the C that f2c writes (since too few people read the README files). Change makefile to makefile.u (with the expectation that people will "cp makefile.u makefile" and edit makefile if necessary) and add makefile.vc (for Microsoft Visual C++). Thu Oct 7 23:25:28 MDT 2004 names.c: for convenience of MSVC++ users, map "cdecl" to "cdecl__". Fri Mar 4 18:40:48 MST 2005 sysdep.c, makefile.u, new file sysdeptest.c: changes in response to a message forwarded by Eric Grosse from Thierry Carrez (who is apparently unaware of f2c's -T option) about an unlikely security issue: that a local attacker could plant symbolic links in /tmp corresponding to temporary file names that f2c generates and thus cause overwriting of arbitrary files. Today's change is that if neither -T nor the unusual debugging flag -Dn is specified and the system is not an MS-Windows system (which cannot have symbolic links, as far as I know), then f2c's temporary files will be written in a temporary directory that is readable and writable only by the user and that is removed at the end of f2c's execution. To disable today's change, compile sysdep.c with -DNO_TEMPDIR (i.e., with NO_TEMPDIR #defined). Sun Mar 27 20:06:49 MST 2005 sysdep.c: in set_tmp_names(), fix botched placement of "if (debugflag == 1) return;": move it below declarations. Sun May 1 21:45:46 MDT 2005 sysdep.c: fix a possible fault under -DMSDOS and improper handling of a tmpnam failure under the unusual combination of both -DNO_MKDTEMP and -DNO_MKSTEMP (without -DNO_TEMPDIR). Tue Oct 4 23:38:54 MDT 2005 libf2c.zip: uninit.c: on IA32 Linux systems, leave the rounding precision alone rather than forcing it to 53 bits; compile with -DUNINIT_F2C_PRECISION_53 to get the former behavior. This only affects Fortran files translated by f2c -trapuv . Sun May 7 00:38:59 MDT 2006 main.c, version.c: add options -? (or --help) that print out pointers to usage documentation and -v (or --version) that print the current version. fc script: fix botch with -O[123]; recognize --version (or -v) and --help (or -?). Add f2c.pdf == PDF version of f2c.ps. Sun Oct 8 02:45:04 MDT 2006 putpcc.c: fix glitch in subscripting complex variables: subscripts of type integer*8 were converted to integer*4, which causes trouble when 32-bit addressing does not suffice. Tue Sep 11 23:54:05 MDT 2007 xsum.c: insert explicit "int" before main. Mon Dec 3 20:53:24 MST 2007 libf2c/main.c: insert explicit "int" before main. Sat Apr 5 21:39:57 MDT 2008 libf2c.zip: tweaks for political C++ and const correctness, and to fix ctype trouble in some recent Linux versions. No behavior should change. Sun Apr 6 22:38:56 MDT 2008 libf2c.zip: adjust alternate makefiles to reflect yesterday's change. Wed Nov 26 23:23:27 MST 2008 libf2c.zip: add brief discussion of MacOSX to comments in makefile.u. Fri Jan 2 23:13:25 MST 2009 libf2c.zip: add -DNO_ISATTY to CFLAGS assignment in makefile.vc. Sat Apr 11 18:06:00 MDT 2009 src/sysdep.c src/sysdeptest.c: tweak for MacOSX (include ). Wed Jul 7 10:51:12 MDT 2010 src/data.c, src/format.c, src/p1output.c: "invisible" tweaks to silence warnings seen in compilation under Ubuntu; version.c not changed. Fri Aug 27 09:14:17 MDT 2010 format.c: make sizeof(buf) depend on MAXNAMELEN to fix a bug with long names. Update mswin/f2c.exe.gz accordingly. Fri Sep 3 16:03:24 MDT 2010 fc: have "-m ..." modify CC rather than CFLAGS (to affect linking). Mon Aug 1 13:46:40 MDT 2011 README, README in libf2c.zip: update some netlib pointers. NOTE: the old libf77 and libi77 bundles are no longer being updated. Use libf2c.zip instead. f2c/f2c.1000066400000000000000000000165541171647030000122760ustar00rootroot00000000000000 F2C(1) UNIX System V F2C(1) NAME f2c - Convert Fortran 77 to C or C++ SYNOPSIS f2c [ option ... ] file ... DESCRIPTION F2c converts Fortran 77 source code in files with names end- ing in `.f' or `.F' to C (or C++) source files in the cur- rent directory, with `.c' substituted for the final `.f' or `.F'. If no Fortran files are named, f2c reads Fortran from standard input and writes C on standard output. File names that end with `.p' or `.P' are taken to be prototype files, as produced by option `-P', and are read first. The following options have the same meaning as in f77(1). -C Compile code to check that subscripts are within declared array bounds. -I2 Render INTEGER and LOGICAL as short, INTEGER*4 as long int. Assume the default libF77 and libI77: allow only INTEGER*4 (and no LOGICAL) variables in INQUIREs. Option `-I4' confirms the default rendering of INTEGER as long int. -Idir Look for a non-absolute include file first in the directory of the current input file, then in directo- ries specified by -I options (one directory per option). Options -I2 and -I4 have precedence, so, e.g., a directory named 2 should be specified by -I./2 . -onetrip Compile DO loops that are performed at least once if reached. (Fortran 77 DO loops are not performed at all if the upper limit is smaller than the lower limit.) -U Honor the case of variable and external names. Fortran keywords must be in lower case. -u Make the default type of a variable `undefined' rather than using the default Fortran rules. -w Suppress all warning messages, or, if the option is `-w66', just Fortran 66 compatibility warnings. The following options are peculiar to f2c. -A Produce ANSI C (default, starting 20020621). For old- style C, use option -K. Page 1 (printed 6/21/02) F2C(1) UNIX System V F2C(1) -a Make local variables automatic rather than static unless they appear in a DATA, EQUIVALENCE, NAMELIST, or SAVE statement. -C++ Output C++ code. -c Include original Fortran source as comments. -cd Do not recognize cdabs, cdcos, cdexp, cdlog, cdsin, and cdsqrt as synonyms for the double complex intrinsics zabs, zcos, zexp, zlog, zsin, and zsqrt, respectively, nor dreal as a synonym for dble. -ddir Write `.c' files in directory dir instead of the cur- rent directory. -E Declare uninitialized COMMON to be Extern (overridably defined in f2c.h as extern). -ec Place uninitialized COMMON blocks in separate files: COMMON /ABC/ appears in file abc_com.c. Option `-e1c' bundles the separate files into the output file, with comments that give an unbundling sed(1) script. -ext Complain about f77(1) extensions. -f Assume free-format input: accept text after column 72 and do not pad fixed-format lines shorter than 72 char- acters with blanks. -72 Treat text appearing after column 72 as an error. -g Include original Fortran line numbers in #line lines. -h Emulate Fortran 66's treatment of Hollerith: try to align character strings on word (or, if the option is `-hd', on double-word) boundaries. -i2 Similar to -I2, but assume a modified libF77 and libI77 (compiled with -Df2c_i2), so INTEGER and LOGICAL vari- ables may be assigned by INQUIRE and array lengths are stored in short ints. -i90 Do not recognize the Fortran 90 bit-manipulation intrinsics btest, iand, ibclr, ibits, ibset, ieor, ior, ishft, and ishftc. -kr Use temporary values to enforce Fortran expression evaluation where K&R (first edition) parenthesization rules allow rearrangement. If the option is `-krd', use double precision temporaries even for single- Page 2 (printed 6/21/02) F2C(1) UNIX System V F2C(1) precision operands. -P Write a file.P of ANSI (or C++) prototypes for defini- tions in each input file.f or file.F. When reading Fortran from standard input, write prototypes at the beginning of standard output. Option -Ps implies -P and gives exit status 4 if rerunning f2c may change prototypes or declarations. -p Supply preprocessor definitions to make common-block members look like local variables. -R Do not promote REAL functions and operations to DOUBLE PRECISION. Option `-!R' confirms the default, which imitates f77. -r Cast REAL arguments of intrinsic functions and values of REAL functions (including intrinsics) to REAL. -r8 Promote REAL to DOUBLE PRECISION, COMPLEX to DOUBLE COMPLEX. -s Preserve multidimensional subscripts. Suppressed by option `-C' . -Tdir Put temporary files in directory dir. -trapuv Dynamically initialize local variables, except those appearing in SAVE or DATA statements, with values that may help find references to uninitialized variables. For example, with IEEE arithmetic, initialize local floating-point variables to signaling NaNs. -w8 Suppress warnings when COMMON or EQUIVALENCE forces odd-word alignment of doubles. -Wn Assume n characters/word (default 4) when initializing numeric variables with character data. -z Do not implicitly recognize DOUBLE COMPLEX. -!bs Do not recognize backslash escapes (\", \', \0, \\, \b, \f, \n, \r, \t, \v) in character strings. -!c Inhibit C output, but produce -P output. -!I Reject include statements. -!i8 Disallow INTEGER*8 , or, if the option is `-!i8const', permit INTEGER*8 but do not promote integer constants Page 3 (printed 6/21/02) F2C(1) UNIX System V F2C(1) to INTEGER*8 when they involve more than 32 bits. -!it Don't infer types of untyped EXTERNAL procedures from use as parameters to previously defined or prototyped procedures. -!P Do not attempt to infer ANSI or C++ prototypes from usage. The resulting C invokes the support routines of f77; object code should be loaded by f77 or with ld(1) or cc(1) options -lF77 -lI77 -lm. Calling conventions are those of f77: see the reference below. FILES file.[fF] input file *.c output file /usr/include/f2c.h header file /usr/lib/libF77.aintrinsic function library /usr/lib/libI77.aFortran I/O library /lib/libc.a C library, see section 3 SEE ALSO S. I. Feldman and P. J. Weinberger, `A Portable Fortran 77 Compiler', UNIX Time Sharing System Programmer's Manual, Tenth Edition, Volume 2, AT&T Bell Laboratories, 1990. DIAGNOSTICS The diagnostics produced by f2c are intended to be self- explanatory. BUGS Floating-point constant expressions are simplified in the floating-point arithmetic of the machine running f2c, so they are typically accurate to at most 16 or 17 decimal places. Untypable EXTERNAL functions are declared int. There is no notation for INTEGER*8 constants. Some intrinsic functions do not yet work with INTEGER*8 . Page 4 (printed 6/21/02) f2c/f2c.1t000066400000000000000000000166261171647030000124620ustar00rootroot00000000000000. \" Definitions of F, L and LR for the benefit of systems . \" whose -man lacks them... .de F .nh .if n \%\&\\$1 .if t \%\&\f(CW\\$1\fR .hy 14 .. .de L .nh .if n \%`\\$1' .if t \%\&\f(CW\\$1\fR .hy 14 .. .de LR .nh .if n \%`\\$1'\\$2 .if t \%\&\f(CW\\$1\fR\\$2 .hy 14 .. .TH F2C 1 .CT 1 prog_other .SH NAME f2c \- Convert Fortran 77 to C or C++ . \" f\^2c changed to f2c in the previous line for the benefit of . \" people on systems (e.g. Sun systems) whose makewhatis cannot . \" cope with troff formatting commands. .SH SYNOPSIS .B f\^2c [ .I option ... ] .I file ... .SH DESCRIPTION .I F2c converts Fortran 77 source code in .I files with names ending in .L .f or .L .F to C (or C++) source files in the current directory, with .L .c substituted for the final .L .f or .LR .F . If no Fortran files are named, .I f\^2c reads Fortran from standard input and writes C on standard output. .I File names that end with .L .p or .L .P are taken to be prototype files, as produced by option .LR -P , and are read first. .PP The following options have the same meaning as in .IR f\^77 (1). .TP .B -C Compile code to check that subscripts are within declared array bounds. .TP .B -I2 Render INTEGER and LOGICAL as short, INTEGER\(**4 as long int. Assume the default \fIlibF77\fR and \fIlibI77\fR: allow only INTEGER\(**4 (and no LOGICAL) variables in INQUIREs. Option .L -I4 confirms the default rendering of INTEGER as long int. .TP .BI -I dir Look for a non-absolute include file first in the directory of the current input file, then in directories specified by \f(CW-I\fP options (one directory per option). Options \f(CW-I2\fP and \f(CW-I4\fP have precedence, so, e.g., a directory named \f(CW2\fP should be specified by \f(CW-I./2\fP . .TP .B -onetrip Compile DO loops that are performed at least once if reached. (Fortran 77 DO loops are not performed at all if the upper limit is smaller than the lower limit.) .TP .B -U Honor the case of variable and external names. Fortran keywords must be in .I lower case. .TP .B -u Make the default type of a variable `undefined' rather than using the default Fortran rules. .TP .B -w Suppress all warning messages, or, if the option is .LR -w66 , just Fortran 66 compatibility warnings. .PP The following options are peculiar to .IR f\^2c . .TP .B -A Produce .SM ANSI C (default, starting 20020621). For old-style C, use option \f(CW-K\fP. .TP .B -a Make local variables automatic rather than static unless they appear in a .SM "DATA, EQUIVALENCE, NAMELIST," or .SM SAVE statement. .TP .B -C++ Output C++ code. .TP .B -c Include original Fortran source as comments. .TP .B -cd Do not recognize cdabs, cdcos, cdexp, cdlog, cdsin, and cdsqrt as synonyms for the double complex intrinsics zabs, zcos, zexp, zlog, zsin, and zsqrt, respectively, nor dreal as a synonym for dble. .TP .BI -d dir Write .L .c files in directory .I dir instead of the current directory. .TP .B -E Declare uninitialized .SM COMMON to be .B Extern (overridably defined in .F f2c.h as .B extern). .TP .B -ec Place uninitialized .SM COMMON blocks in separate files: .B COMMON /ABC/ appears in file .BR abc_com.c . Option .LR -e1c bundles the separate files into the output file, with comments that give an unbundling .IR sed (1) script. .TP .B -ext Complain about .IR f\^77 (1) extensions. .TP .B -f Assume free-format input: accept text after column 72 and do not pad fixed-format lines shorter than 72 characters with blanks. .TP .B -72 Treat text appearing after column 72 as an error. .TP .B -g Include original Fortran line numbers in \f(CW#line\fR lines. .TP .B -h Emulate Fortran 66's treatment of Hollerith: try to align character strings on word (or, if the option is .LR -hd , on double-word) boundaries. .TP .B -i2 Similar to .BR -I2 , but assume a modified .I libF77 and .I libI77 (compiled with .BR -Df\^2c_i2 ), so .SM INTEGER and .SM LOGICAL variables may be assigned by .SM INQUIRE and array lengths are stored in short ints. .TP .B -i90 Do not recognize the Fortran 90 bit-manipulation intrinsics btest, iand, ibclr, ibits, ibset, ieor, ior, ishft, and ishftc. .TP .B -kr Use temporary values to enforce Fortran expression evaluation where K&R (first edition) parenthesization rules allow rearrangement. If the option is .LR -krd , use double precision temporaries even for single-precision operands. .TP .B -P Write a .IB file .P of ANSI (or C++) prototypes for definitions in each input .IB file .f or .IB file .F . When reading Fortran from standard input, write prototypes at the beginning of standard output. Option .B -Ps implies .B -P and gives exit status 4 if rerunning .I f\^2c may change prototypes or declarations. .TP .B -p Supply preprocessor definitions to make common-block members look like local variables. .TP .B -R Do not promote .SM REAL functions and operations to .SM DOUBLE PRECISION. Option .L -!R confirms the default, which imitates .IR f\^77 . .TP .B -r Cast REAL arguments of intrinsic functions and values of REAL functions (including intrinsics) to REAL. .TP .B -r8 Promote .SM REAL to .SM DOUBLE PRECISION, COMPLEX to .SM DOUBLE COMPLEX. .TP .B -s Preserve multidimensional subscripts. Suppressed by option .L -C \&. .TP .BI -T dir Put temporary files in directory .I dir. .TP .B -trapuv Dynamically initialize local variables, except those appearing in .SM SAVE or .SM DATA statements, with values that may help find references to uninitialized variables. For example, with IEEE arithmetic, initialize local floating-point variables to signaling NaNs. .TP .B -w8 Suppress warnings when .SM COMMON or .SM EQUIVALENCE forces odd-word alignment of doubles. .TP .BI -W n Assume .I n characters/word (default 4) when initializing numeric variables with character data. .TP .B -z Do not implicitly recognize .SM DOUBLE COMPLEX. .TP .B -!bs Do not recognize \fIb\fRack\fIs\fRlash escapes (\e", \e', \e0, \e\e, \eb, \ef, \en, \er, \et, \ev) in character strings. .TP .B -!c Inhibit C output, but produce .B -P output. .TP .B -!I Reject .B include statements. .TP .B -!i8 Disallow .SM INTEGER*8 , or, if the option is .LR -!i8const , permit .SM INTEGER*8 but do not promote integer constants to .SM INTEGER*8 when they involve more than 32 bits. .TP .B -!it Don't infer types of untyped .SM EXTERNAL procedures from use as parameters to previously defined or prototyped procedures. .TP .B -!P Do not attempt to infer .SM ANSI or C++ prototypes from usage. .PP The resulting C invokes the support routines of .IR f\^77 ; object code should be loaded by .I f\^77 or with .IR ld (1) or .IR cc (1) options .BR "-lF77 -lI77 -lm" . Calling conventions are those of .IR f\&77 : see the reference below. .br .SH FILES .TP .nr )I 1.75i .IB file .[fF] input file .TP .B *.c output file .TP .F /usr/include/f2c.h header file .TP .F /usr/lib/libF77.a intrinsic function library .TP .F /usr/lib/libI77.a Fortran I/O library .TP .F /lib/libc.a C library, see section 3 .SH "SEE ALSO" S. I. Feldman and P. J. Weinberger, `A Portable Fortran 77 Compiler', \fIUNIX Time Sharing System Programmer's Manual\fR, Tenth Edition, Volume 2, AT&T Bell Laboratories, 1990. .SH DIAGNOSTICS The diagnostics produced by .I f\^2c are intended to be self-explanatory. .SH BUGS Floating-point constant expressions are simplified in the floating-point arithmetic of the machine running .IR f\^2c , so they are typically accurate to at most 16 or 17 decimal places. .br Untypable .SM EXTERNAL functions are declared .BR int . .br There is no notation for .SM INTEGER*8 constants. .br Some intrinsic functions do not yet work with .SM INTEGER*8 . f2c/f2c.h000066400000000000000000000111201171647030000123450ustar00rootroot00000000000000/* f2c.h -- Standard Fortran to C header file */ /** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ #ifndef F2C_INCLUDE #define F2C_INCLUDE typedef long int integer; typedef unsigned long int uinteger; typedef char *address; typedef short int shortint; typedef float real; typedef double doublereal; typedef struct { real r, i; } complex; typedef struct { doublereal r, i; } doublecomplex; typedef long int logical; typedef short int shortlogical; typedef char logical1; typedef char integer1; #ifdef INTEGER_STAR_8 /* Adjust for integer*8. */ typedef long long longint; /* system-dependent */ typedef unsigned long long ulongint; /* system-dependent */ #define qbit_clear(a,b) ((a) & ~((ulongint)1 << (b))) #define qbit_set(a,b) ((a) | ((ulongint)1 << (b))) #endif #define TRUE_ (1) #define FALSE_ (0) /* Extern is for use with -E */ #ifndef Extern #define Extern extern #endif /* I/O stuff */ #ifdef f2c_i2 /* for -i2 */ typedef short flag; typedef short ftnlen; typedef short ftnint; #else typedef long int flag; typedef long int ftnlen; typedef long int ftnint; #endif /*external read, write*/ typedef struct { flag cierr; ftnint ciunit; flag ciend; char *cifmt; ftnint cirec; } cilist; /*internal read, write*/ typedef struct { flag icierr; char *iciunit; flag iciend; char *icifmt; ftnint icirlen; ftnint icirnum; } icilist; /*open*/ typedef struct { flag oerr; ftnint ounit; char *ofnm; ftnlen ofnmlen; char *osta; char *oacc; char *ofm; ftnint orl; char *oblnk; } olist; /*close*/ typedef struct { flag cerr; ftnint cunit; char *csta; } cllist; /*rewind, backspace, endfile*/ typedef struct { flag aerr; ftnint aunit; } alist; /* inquire */ typedef struct { flag inerr; ftnint inunit; char *infile; ftnlen infilen; ftnint *inex; /*parameters in standard's order*/ ftnint *inopen; ftnint *innum; ftnint *innamed; char *inname; ftnlen innamlen; char *inacc; ftnlen inacclen; char *inseq; ftnlen inseqlen; char *indir; ftnlen indirlen; char *infmt; ftnlen infmtlen; char *inform; ftnint informlen; char *inunf; ftnlen inunflen; ftnint *inrecl; ftnint *innrec; char *inblank; ftnlen inblanklen; } inlist; #define VOID void union Multitype { /* for multiple entry points */ integer1 g; shortint h; integer i; /* longint j; */ real r; doublereal d; complex c; doublecomplex z; }; typedef union Multitype Multitype; /*typedef long int Long;*/ /* No longer used; formerly in Namelist */ struct Vardesc { /* for Namelist */ char *name; char *addr; ftnlen *dims; int type; }; typedef struct Vardesc Vardesc; struct Namelist { char *name; Vardesc **vars; int nvars; }; typedef struct Namelist Namelist; #define abs(x) ((x) >= 0 ? (x) : -(x)) #define dabs(x) (doublereal)abs(x) #define min(a,b) ((a) <= (b) ? (a) : (b)) #define max(a,b) ((a) >= (b) ? (a) : (b)) #define dmin(a,b) (doublereal)min(a,b) #define dmax(a,b) (doublereal)max(a,b) #define bit_test(a,b) ((a) >> (b) & 1) #define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) #define bit_set(a,b) ((a) | ((uinteger)1 << (b))) /* procedure parameter types for -A and -C++ */ #define F2C_proc_par_types 1 #ifdef __cplusplus typedef int /* Unknown procedure type */ (*U_fp)(...); typedef shortint (*J_fp)(...); typedef integer (*I_fp)(...); typedef real (*R_fp)(...); typedef doublereal (*D_fp)(...), (*E_fp)(...); typedef /* Complex */ VOID (*C_fp)(...); typedef /* Double Complex */ VOID (*Z_fp)(...); typedef logical (*L_fp)(...); typedef shortlogical (*K_fp)(...); typedef /* Character */ VOID (*H_fp)(...); typedef /* Subroutine */ int (*S_fp)(...); #else typedef int /* Unknown procedure type */ (*U_fp)(); typedef shortint (*J_fp)(); typedef integer (*I_fp)(); typedef real (*R_fp)(); typedef doublereal (*D_fp)(), (*E_fp)(); typedef /* Complex */ VOID (*C_fp)(); typedef /* Double Complex */ VOID (*Z_fp)(); typedef logical (*L_fp)(); typedef shortlogical (*K_fp)(); typedef /* Character */ VOID (*H_fp)(); typedef /* Subroutine */ int (*S_fp)(); #endif /* E_fp is for real functions when -R is not specified */ typedef VOID C_f; /* complex function */ typedef VOID H_f; /* character function */ typedef VOID Z_f; /* double complex function */ typedef doublereal E_f; /* real function with -R not specified */ /* undef any lower-case symbols that your C compiler predefines, e.g.: */ #ifndef Skip_f2c_Undefs #undef cray #undef gcos #undef mc68010 #undef mc68020 #undef mips #undef pdp11 #undef sgi #undef sparc #undef sun #undef sun2 #undef sun3 #undef sun4 #undef u370 #undef u3b #undef u3b2 #undef u3b5 #undef unix #undef vax #endif #endif f2c/f2c.pdf000066400000000000000000002176061171647030000127100ustar00rootroot00000000000000%PDF-1.2 %Çì¢ 5 0 obj <> stream xœ]’ßn›0ÅïyŠïjê¦àÚø\¶ÙÚmj².eÚµKÜĘÔV¼Öžp6†4›,„þs|ü=FpXÓ»j ·þÙ%Ï ÿÀôª¸.“Ë ʧ$² # "P6IŠç¼€ò5¹¸*ß•p­ëîÔcëTß:£»÷寄¢R’A¹Rdç#³::§ølêz므e!Y@R&ð‘Þoâ(Ç2'#·l›Ã±7v•Ñ¶ÒPêjoM¥jØèCëzX·+‚Øå&‡`ÿ”defb“(á\óÃ眲iߦKX¶öE»^»¨PLMP‰r¯ N ˜ŒÓëÁ7ºÞ6ÊFŽà äÔƒ<@þ•Ly4‰œ;)~T/f +·j{!Éó2eA0±Lå~ÃO+ešÖê°]r×Ñôψ‹ˆŸ¬È›ÕÁò}îÝ0z¾þ”Ò±7&fŽ1Fi´½S]ÇÃVõÚ'U®Úû1Y) ŽâUŽ§;%Æþú%sfg¬ªëL×GˆqŒþ«0¤§²ü¼Å9#‡”ŸN%d!âTŽéÇ¥9†éèMk;?!9°j3]ß¾Úyü3{5Bßz;Ç9ó»¢úR9«wF§+oÓZøašÎôÃîMßwG·ó>÷W@xFhÐúT&ßýú æäGendstream endobj 6 0 obj 524 endobj 13 0 obj <> stream xœ½YÛrÜÆ}çWÌSD•¹fp òDÓ‘#—n‘ÖVª(=Ìb‡\XX€¤èr~1§ç`—”bç!ÅbqEzúrúôiè3‹#Îbúò?«ýIÌ~Ä÷õÉçnÿÂüjϾ_ŸüõmÁ¸`ë«÷gBð¨`RÄl½?YÅQ,˲ˆ3¶¾;9=gÏ:3Õ²¡cì¢koµ´yºþ–$™†¥¤Œ[ñ2ÊÙz{ qVdeRXï"öb/U½ïZ}ä5/–YÄ£³î—y”†\D™ŒóöH•¡<‰ÓÜÝÆjÛ%'ó™ ›µ±©¸ z —TÃŒV}×öÅc_^É `uϾëöz¨÷®ÍÒ2’Tw‡H²,•Þ‰Áû±Já'qéÌy—ÒdìõÕØPèfDÝ­o@|GöªÚÕ@—…ÿNB.ÖýMÝhÃ6ãÀÚnz2üÞÆ”r ,L1e6;Ö×óÁ;êLŽ¦q™pw¦v0o?s±¹Z¶5Dî[ÛÔe<só¥9àb]BÜz” " áŽ&`ÔXÎI¦˜iÉTØ*¤§i„_·×ÞhVïoº¾¯=²õ—£û]¾„WgÜŒL0¹qÉa‘Þ9²´SfKQ>j oéßì鎮LJ1ƒ4 ç æ­Qh\Ìpü 6;C£îѦ¸EU¬»îôRªˆ“ÁWŽ[½]ï'e„B\måŸÙiXé®u«»±g[5(ÜjÆj U‰²]©¦éV¶úFã7E¢ÃÝí5ëï¶ý‡§îÞg>å<·‹ i¶ºÀ€Æ•‡‹;2%Sä¨Âž"¼îÑè¬Gu@qÈæ"¾ Ü.@`IBE”qá °5ð0¨NÓ@äÓ”'>Æìëüh Æ ùxjZÎã0ü-T(Å=㘻`æÞåFoáwh5ôk Ò½U˜»ƒ½ß÷3ò^ÍT\$ÖõL¿dÌ@¦ 9žèm¦'‡Ä¦ÃÃ;¸À?˜u«`eY)ܨ÷‘×­e‰å»äÇ%h1™HNÆ~C7µ÷>÷3¹É" Œ¾ßv¨.°pK °ÎÝ)›Áê` YFàA97 /â<÷„L´E¨Üê㫧„Þ»ügÔrο„ð¢Át{^Ê“ûdã*eTR(ö"è ‚‡{¦Ad!^àX o¤?ÜÃà@Â/FÖ4Ú+ÌŠÁ‚‰ç”Ã,‘“ `êHº‹¨,cÏu§¤ ¨ÂÇkÁdGB´8Az x\Rr¸wð<ö³ÍÃ¥ ü‘ÝrJç2åYê7—žJ¹ü>P!Õ4µg"u=›/ÕUO:öAÂjÏ=À/ˆ¨»CŒÕÇ:YõG*Sˆ/o÷´ºoõåHaä³*”ñ„„§üÃS‚Û‘tNÑètNè¾#—FÓìÉÑåÙÂÚej%†(A>aBa®A|‹)Ô€þÅœñµêÁ ÃnѳT€¶Ç¦ÛÊuVVZ`{Ã\N •ÚÆÁ£n°v`^èê“Ï# yA™  ±‰Hdw ìmêßA¸—<ùüÜ.È—aq ¾:X4Jð}šMâ`íîÄR¦H’2ñiX„o"‹º/€O“}£zmG­ß⟀6L ¿Usè†À¦âåÍéÕá½é¼]@I‡þÆ]“Ø»Ì?Fž •çÅYÐÂïIÔÜjKGÝ‘Çüÿ5ù,³³Ù„ì¶ó„“ ê æ|9”¸=5‡ãÆ`„’”mê¡ Ú»4N¼ØÜClÕ‘ŽÎlCù½“„éBNgyzÒÙ!æÑìÚ`LÑþðôoÔ9= ª·:ôÅXØeâyóúíúhyÇ2$H —!·v%ôëÂ,ÿ†Y0qê U÷h·Ô>—ÒŽO)ˆjç’Ñ+ ¯ƒŠoŽš‰ç­´ ¥Çôç¯^¿shÁf%— s¯=.¹øèôŠäþ»³BquÓÕ$õ¡­@+©ƒG½EÐRÐoi#žcä VyÄhMò]kPzh'ãjˆ¿À¡žFˆÑ d§ÕíÊËäd’/É$ã²ôدžŽv c,ݪf´ŠÌ_põoȲ—û¤ÖœXëÙ¦V 6ÃûaseW²Çhge_a-ñodˆ¬&’bªÞ¹¤ÆëÝ°°I= _<Åoôp§5üÚü O6„ðLgÕçE.ý`ˬ¢ábEÂv¬\“Û÷ é<N7GïíH‹üáÞŸÊ—d“ò¦yg§›Ùé kºê˜åxR† ¿ÁrI6½?Z°œ[c’j"À¬aQ\{M$’à'y:5G î—ž_ÎÿÅîÂ^QÒ*¸Øݱ³Æ^ÆÜ‘E™°$=dÍ’ðõ§'‡e%©wÚ/PÙòµÄ\ô Ôã…ÖjõIÛÝá`ÉhËA¾ÍضgÞ L»± B’pB5Ô@ÊF…íÞî6Alj8¼ñ µ[.™™+&4¡ð]™øã5æu ÏCõ±„úÉMëûêM|~ôU\A†× RFŒ”L2Ú*'ÀðSîµ"JòÈšoK1ªQüÿ!4ˆ»ÒìwÝØ q;RÓ½¢wN!Ñ@]ù—ùÅáû[^x<û™öP>§2 ô¯æÂ’Õ–€„pÓØù™p$“Ši.~Ëhš$Ùdô ©ü’°ód?;2;óŽ> stream xœÕZËrÛÈÝë+z:#ÁèÆ«»¼’]ž)We슭ÉÆr¹ ƒIL*ßãÝÌgå7rn¿B´-Oe‘Xe›"Ý÷}ϹÍ_YpÒý¿Øž„ì'ü½9ùõ„ëO˜ý¯Ø²ç'OßfôÆÅõ‰y€3‘© c™ŠÙÅöä, B¡R™%ìâîduÆ;{rñ÷“3.VE)»XŸð€'a&õ’ózØ´ã͆ݕl“ß–lèªrMϨ,HC3ôB†q¦Ÿ`C˶ù§’Ö<}«¬8qdJšÕBq•D\¯¿f¢0k½èQ ý¾i,c½îO=kÇa7¬+ó¾mò«zO/×xQžâ³ŽÝ´yÍÚkÖCÈb`E»ÝåCuUÕÕ°7jfY•¹ ÍWwÕ°9”RˆÀj´º>”)b'’ CeDÊ2VmwuUö¬o·%kò~سºm?UÍ ŽonË®¯Ú¦h3.ã í6Ø/áIj,öªZOv´2Iƒ8äÞ¶2áÂ8 šåC¹-›¡?eUÃvy7TÅXçÝ)»)›²Ëkå¦Ô»œ‰4Éӗad_Þïòf]®±¼•³¾„W{íUd¡ˆÜÑ\ÊD™£a×Ûà ë kÕ@íª94 ’p3ÌblXWW¯²ìÐ" ”ýøôðÙô¶çq*”µ=âÕÓ7 ‡ty·×&†Â¡—>‚&ad¥¿ØŒZ?áOAl…IäbvS².¾ÚëCÁ2,õJ}3xas«Æ];Ö:UÎâ0s^ÀãÒ&€v]{¥ãøªÔ4l(p`éœ5ÕÍfØæÎ#ždAäB' $R˜'³lƒñ—å={ñŒUÓ'Ӧ۱ذmÛaû²é+dÊÁPÛä…Ýߢ¦B*£bÛU7UƒÄú±í†.oNýÛ×È,ÈŠÃò¦¼ceŽƒ†jkÄ•ä‡Ì‰›¥aâŠÖ›¼¹)×ÚaqFé$Ã"ÚuïZ³•¨2“æY&a³é½-»¢‚h·e³n;äDÜpÓö%£tˆÛdˆ rJ†8l‰ÛíðxuÏÎOa¥ò,DOÈ'OIeÒË®ì®Ûn;ÙÎöUY¯É"/p|Ž j`}òá¼\yï«®,†zÿŒ\Ð'¸­„T«SÅVʃæ\ïÊ_Ǫ3уí›ÖÀe“ÐZmeA5@‘Û6B)–‘Þöß•==D©z”¨Çð¢ínò¦ú,ˆ°ºn뺽suŒCÐÔFÀ¨œ;§A'œI‹¢N?LchccV°uÙ]u… B™§®c~cˆ“Û½×à ?6ãLYmŒÆÞô"4®0ÜWö«ýas<¶÷À 6}/W¨‘‹þúäþRBõ²fÙå“€}Ž´A¸îáZPJ­:ý¸E–Ã懔÷e*i‡Lµ9ÇP}(ªZ©Ä‰óµ'_¬Dbb 1ØÞû€½¼ÏÑÊ´õeH_E=‡ïlú6·ma‚ÐØ]F(£SK]–NŽÄy´„ÒG‰+9’3ï¨×}Žuô%påT1ŒTŸS$¡šJý&0²´Õ¿ªë ½³g·°v;öAd"µ³"gÁck}4“9S‚+‡TæÙzŠ ¹fŸSŠÜ¾Z°ÜšO¸„gñ”Q(¾ý°”’pB®^çÛe±› °:o–ÕòÑvš·²LÆ\ZÒe³‚÷;€6ÊF*4e“ø¥‘$ãÄÜåjê©Ö Ô @?ªRØÃm ïÙ{ñáò‰6ÅuÝÂë iÉ,€rRoïó%á<F¼œö»\-ªìã‘“òrG‰­cSè®käÐrA-R¿k+ƒÖ¡«'Þh\ŦӰ$$¾Ðå|Þ_>1UÇl¶Í÷.kØØP*@tLÉœØŸÇ¨È aÍxÑš^Jhó7ÎaÎÌoÛjM;ÿNC]ª)ìÌ¡ˆAK8= Öç…ˆWwÑæˆó©Ûé=& ,òË©!}'»ÄSÜ#ÛëK@  ÞD¦N†2È&]SØÛœ G:T[8ã®Û‘åºtY¢ÆS…‘^ðY!4'Ú:Èg”)ÐôÍ"†`](³KÏü´!‰#Gî(QºsÀ üºì{ÇVŸ¾å>'Cj6]Vg¿<ˆH ¹WíΠ¨4˜e@– gÇ»vMœÑn”æŠæ¬D3)†Ë'Ït{ëˆk­NY”štš$ Ò>ÿeœd©œaփЕa‹Q»YkBk…t»x1E) ¯ê¶ø„cµïrÖ£¸£çNžóŽc•.˜{¶nYÓê°‚ €O4Ž†Æ'^ez_³? HfÚåUGòëÍàÐmh ð™í}‹0šKóÅ´ IíÄE™:2¿É&¢å`²³h?^ÍÓRÒv.¾À|ˆƒN¾X/¢ á›(»xuþüÅ"š\ï;]<6 |Î?>ÿ¸x* ýá”é"¶Ø‰†¼ŽGé>.¶’3¶Ò ë:Xo¬ŠÑì×pãc¢bXQó«b±½ˆ¿ Ÿ;4 ,ÿxõ±øÈÇñ ŒÃm2¶¾9¦­à®W<Øu¹o"¾:„Rxxêèé˼£ $‘Ãe4öhp þ‚RÃz £aÙÁ–»¶ÑƒS”/€å‹:7„ªfç…ó÷Lýƒ°Ü‡ç4'öåÉHsF˦r,C™Ú ô[ãGV3{;x-Š`s<Æ°Sâ&‹°:Û”9Ò‹ýFÕJÒ¶$»É£'#³©|š [Ù\W3tš:ÏŠº¿Kt©ÍœV4Ši&³ »K^á¿Í»ì)³½ët?ÝeÂê!àž®\y£%?VJÒÈò¿u>ä¬-ŠqgdíA–X¾mÇFß„nËmÛíò4¡‰Î4@;Ú %PÊ3įÊ>+J3^å{j”eYd"ÝI~G³}=5²?[ ûP}Çõ›·S$•–å}?ú¹ÙI#m éþ¦¶cP51šDÞ´Ûq uÕÒø C¦‹ymtV>µIÔ¬0õsÎô‡« ¤‹®G0 8Sö6úò Mp’ƒ€iev†“0·y]ÙáV’LãÇ(PGèÈ´ê€ÄÁ¼Mφaó =Ðü”dE—ö8žî‚I¥g»GCÅåÅï"ÌgäYÊ3èÓ†ÀViC_ßy`;⋧/™b¥G¿1CZ©!}/(s_I2ß<(64t95·)c?°m»®®÷ÒGQûŸºÞ1gŠùœ#Œ¹¿´ß,;âÏM[[W P䕈§»¦w¥ùj"d9UÄ!Їm ŸSšO²ÒÜ…›Ù×õØá¼Î]¯ºïT ÈUªo=R¿½avú9ïŠ â”q¥ôíôË‹“¿âç?²•e‡endstream endobj 18 0 obj 3626 endobj 22 0 obj <> stream xœ­XÛnãÈ}÷WôSFÄN_ÙdæÉ»H‚³™‹£Å‚[2³©áÅÿÔ~cª¯¼È3Ú]ÆÀc‰]]—S§Nñ3"˜"b~üïÃùŽ À¿ÓÝç;j¿Aþ×ጾ{¼ûËGe>x<Þ¹1•c…T.Ðãù.!˜°<Í”D/w›q”Ü?þŽeþXˆ‚瞢ÇÒ>ÏU–“Ô>ÿQc× ‹zÔ½;®c%TâÌœ"X¦ŠÓÌžy@DZ9 UÛ öˆ†×‹viîOª ðÎmªfÐ'Ý-- æ¿Ý®JœúoêöTŠúísà"œ2ë͵ÝÊ Uá9dÙŽûZ£K§Un/­æ9Äž—DfîÐyì´×¨Ô‡ºèt‰Šè{»Íp‰9™?ÌY’ºØÄ OÅ€:›ÜþÐèÐvî/mSVÍÉ& #4%˜éîgX ’º°Ð?ö{Š!"øG2"ÒÌ•Á˜½ ³\ä>‡ÉÇe T`‘a$ãÖR{±>W=ª¤G}ÐnÓk. Aßíî·6Ž¾8kóäÐÚ”¿°©`„O©`X¥Ä LßBŠÀ¾V›N¯ËÍDH‹’$wA¿G-xѽT½Þº»gÖRq÷†µóh+•.ý[—Û%ŸâŒÄS™Ŗ~†…«r¯œ˜ ù Ùñh¼v0%¡Ê*U’¥>Þá ²ýT~AÇâPÕÕP ºGíØ¡þwžV½õA÷`kkœ«TŽ—ZÈ‚aÓlîc{Á*&ý¸ˆ‰Rɸð³íðTtÅaÐ]bËP¢B¬ŸŒâ9#Âa »"ÜÐðÒ"ýºê ý_áé² 2 `³”„ëfx› @pÙixrà€¾#$ûà€YKˆšh#÷O†ìgq*-û®¶TN¹:}R…–þ?Bêh‚”õ°õÙXàʆµ€S·ÀäÌ98CɧãÐÀþû½Äâ÷PÊsîé¢)¬Æº4m^5Ïí/€7˜ÁߣýëíÀM`®ý'*úº7ÉüS“-{f‹¨ü°EzÿÍÆ‡É ,ÔÞûïqïa 0í&ÇÍÜ9{E/Àhk¶NYÄpàJšDÆYÆr—uöÀ”m¯==öPs¿jóaur®¸ Œ;O¢®y2#ãtK'˜A{Ž½“`,…!3÷2=“æ)`•ŒÐ4 ÅT(Ç´c+éd†´%ýºØëºßÝÛD5- €¢ï!&?Bh[´ûÌè¿-[×Ò9Î)²7%T¦^‚¸ͱ¤|$‹Ë@Õ”ú ˜ÛÇUS¢E] zéÚƒ.Ç.Q£Rb( ÂñRÔ2Æ$•3nþ Jõ VzˆÕœÉÁg‡´Q5i Êfè^Ã8tãuUA›Q§´™2*YÍIPLx´YßÎ(„Gè9ø> SF*¨c”'BÎ8ÒÖ™‘¹Hf0l].Q¬éŠG)”HZ‚^6'd5àOM}¤¸Å>t»<†oŽ?öÎð+j¦ÐõjÉV‚ áÇ›Uý²PƒAQ¿ú–µù$Ì\6ŽƒÓÑ30»ht§vMï …Õ–^<<(¤[Ķœ¶¡f¾)¤—~³\s:àûÕFL…2¼ÀL.âNìêüäÚ‡ª¾¹#æ\¹CPëøĦ}»;:§"µP TG£0ö½ÈÃ|6Ç3³ëúÐö<å8.¸<•‹&*Ç%GùúYC5m“Ä™¼T¢PÍöèºË`žÈ‰B$Ž™m’D°[ÌÌœªg»ËºÆbš'`Y¢¾4n\ÚðIO­érãØ\ȧM+˜ò })LRfæ£yèÌÎøán±i_o™«œ…~p3|YY0 Î%žWS> stream xœYÛnÜÈ}×WôS$'nßØÍŽ‘íb,°±[ ˆ,Å鑸Ë!Ç$G²üQ~ ßKUßÈáèâÆ®/bWUŸºªþHhÆÅ_á÷j{BÉ_á¿›“'Ìý„„ߪ-ùþòä»÷ÿársâ0µÉ4ÑF’ËíÉŠf”Uèœ\ÞŸœ­ˆ$«W—¿¬8ÕðÕJ(r¹>¡™T9Æ}ó¶-oËþgÉ—~‰mìÖ¶#é6¤$?²ïËR6÷åÃ@nË ûë¡êëÝH>Û¾;'×û‘¼éú±/[T&˜Ìr4Ï©ÊÍ¥vª¼¤\Û›º% ‘‘벶›rߌ™³3œ]1îO+V*ÝéïmUî5EaeoÉ0v½]ZuÍ~Û®¶åo]Oº~mûs”Ë…È4-’MÓÑ¥ ÁÝWx—¡)G;-ÀP¯Ö5€?Ô][6sT™T™¡* Ð9¸DÃëvìH×ÚÓµZ¸Ï0ìAM¹ÛõÝ®¯A'ºÒS‰ŸnBsMóFzw×í ±Ÿv½PúùËárbëg°ŒŠœ¦Ü9‘‘ÿyùãÛ?½{û\¾#oÞ½¿|ñ–hýêt ÏA±Ê’jf¨ôúP·•%õÆC¤ôõøeÓwÛCG• ÌÙær™Éð­Þc¹ÿÉ‹^KÂiÜçÖ°ßíÀ;gÓ`¦@öŠ×É/Ø„ çEn¼#µtGï:¼,‚~íÃð_êßÙÂx®³Ï+–ii”7ÿÍ3æƒ:Å4+|6ž3u>ù :÷?JðÂ} NhökëJĦkšîb!XÄhTT`œý÷À³: •àìòabñ Í\ê¹t5!@ÕÜx ¨Ê9û1wæ"zéß‹¾œÙHE0xœc 0˜¥x¨QìQñ©À-ò´ˆ ž –˜ ä¿DL˜‘*ô¢,ƒ/{“›|Üy€‚Ó؃ƒ=äëΕö[w½l:+l0+l=kl=fé . ½ ‚ŠüúëÝh8=õ¶Èow;[öØl*ƒü)OvM]Õ㡦œfŤŠ‘6À±• t!kz»‡(ÛÔ­]/§Úe‚}P[œ-¡4»a Li+¦´%we_û|•Tdô„¼P±‘”àØdwC,úž©c½wž,‡¡«7®IcÇÚ#pV®-òB‡Kƒ„¾jÊÀŸK‚@“Ä‚ÅHZÄÈyŬü§szJs*HOˆê?[uqL0tÒžà7¡œÂHœaðœKZàÑ ýákÕ ab¡ƒä³÷5d ºÚ7š¯R“œ|fõùêÕK* ©•JA eb ´~Õ€Ò힨{1ÀVû-LôÔY¤Ûà„‡ÚÍÆV®pAÒÚÙÿáÅVƸÜûF•Î™ïÒaötÁÖbö„>„y¥²ë}o¿1û)}Œÿ=Š\ÖWÀÞñXÁØÏa¾òåMÛ¶¹ƒb{ „w¶y8'uf³ó$dþ™­·Y×ð=&D‡e%ým¼í»ý#P«¨vÖLçÚ«.Iu[ÖÈ?Iç$¢¢á10:U žßíÃ=Œ´K¦£Xb ˜5õ" …I¼"om‘¶•û±ÛÎu<ÌÀû&³b "nªÈpaW3ÜÄã)¥ðð‘~ðMeóàgW­2=ãtH¢A¾¼Ti tY‚¾Hyd¦ …Jl£÷|£ÈÁL¬U›Ðl‰£¥÷j‹)¸{ᣑG&”C¿I<cy•F™¨ÜPOÒŒä:4{Û¡JŸ;t†=äHü'ŒÎ£à©{øç&l~¤ŽP¼ð©°w~¼·¶ÐﺪtÃFf§¤Cø†ã÷ÒAÉóâWÍ° ´œ¼ó; =q™O Š÷ ô}î“}2Á3cÇ &3ch ¾Ilž_ óLÆßX˜Ñ[{¾Âf¹¼Ýé2˜a‰?ÉU ðg 1R¦o.^’–猺Øק¶=[Ê11ÃEyÆ1™}úDÚr¬>Þ©7U‹’¬b.Ÿ/yI*ër,\O¾x¹CS Ž$‹'RG¢wNŽFWž¨ÔÙÓçByH ™4ýd Y K¹Hú %Â<ørÏ <+ºnµ¸ýJ2>Ÿ)7)¬¡X·7}„¥&9(@³ÅÕmyžõh(¬3bÛ{êîOªš7y-LÜ{^m +aßšâÍÏÊ`>ò?Ç‹}pù2¢pÂ÷>; ·™)ñr¶OEÚ7ÄYþÍaýuñ¹Ø¡?¢,.DÕAõ‘yõê¨ksY¸¦õRß*§Ï– 2–×Ä—x¿©Waá=¡îû%îiÜŒ¾‡ø¨ õ:̇\‚ySk“"/4[¤ÞÚD„‘;§ ,C~ †nñÐù¶¿Š‚¦ÁŸR]x;½MDswižø|¼ŸšÄElÓ:4mËH¹ÝÁ|qÌ2¶Ü¤Yþ‹!y6Ç+hÛ:lÔL„9"V¹mûÓ@@Qu-Pß½kLîÿPÁ˜™ê€Û "Ž#?ÃWÓTœiÎ (®pâzÊï×_Ä7xi2·¹ÅT}Æ÷ød1öÖÍe@¥"kÖÚ·Ž ªYR$S¿|²ë¹Ó‡?»ARfn.ˡƃk· elæR¨pé¿nA}ØìA …í0ÁµÎkwå—*¿N_ßÜ:¨8çÓ‚ ŒU†à÷SèuS¶¿08u3‰ÓÜßFDÁæÅ™K–›Xœƒ¤éÚ›×p÷‡§-ý=>Ií´®ë¡*{¸‡‹\,R–0S46tr±îz a›SÆ€sóøKg®0í†5Nº!³¦` />eUuÇùŒ"»”…™|¿ƒa”0Á)Y^ßYLå¼ÓÚÊo[Âú¦kì‚₪ÆWÁ6€- Lĺ¬ÏAe¾ßZVÏ•G”ò)È•;íW0¡øì1æ"×ÔÔ[ÿ*ä· PœÇQ …®Û湚X甈W»ÿÅ:Wâ³Æ€Ï’ÛÒ‹_çðQÎ;>s«÷#wø›½vp/j=£,MYLáioû猫3–BDâ Z.ØcÃ"—Ó¹@™Îþ³<MR*;:3ukÝçÛ“/|E™‹5Ì”fzÎ;Ó Õt4žôÔ6m03ý•WÖ‚Æ>?#¸P×?Ì\^º% m}ßZ¡'ø­£7´bq¬ySÖMè¸V§l‚Ìí—|ýëÈ—H§’Çd& {Æý.Òâ °aÅúÞAc=,uè ùÁKˆàLùïãUq÷Ï©`ÏsÕ¤@\ý´RžÞßú£<žv ø€V„Ò|4èùÕ4î ¢ bm°w¶/¿F Ÿ„]DØ.H¥ÁÑG ëY-ŠË´¿•=àü:†Éñó/Oþ¿þ£.cendstream endobj 27 0 obj 3261 endobj 30 0 obj <> stream xœÍZÙŽÇ}Ÿ¯¨D¢‚a»–^­§Èˆ“âvI°‹Í"Ùžf7ÕË,úœ¼äͯù¤üFî­­›EŽ4‘ H£VÕ½u×sO÷{B#F(~ÙïåኒßÃßÝÕû+¦?!ö[y ïn¯¾ø>Ã_Ün¯ÌFxVDÉŠ˜Ü®–4¢¼Hó,!·W‹%IÈòÍíOWKNi”’¥HÉíæŠFèÞÙ+×| :â8öxðÃxd#ßé^¦áQŒ#ÔTe(ãvͼѭ‘P¨«C…PU:¬×OZ†Èa šÝRΰiGC^Å4†[LSD–áB½j]+ÓZq~›uˆp”•|2x–[y«78+ÁàÒƒÞNuyW]þqzêìÌ$ÉÜ©oIµõµ¾Éf p4¼«š Î@ZÚµ†&íõÆxf^Lòh6 gi,˜ñº:¬Õfc¨Üo%¡ˆv`?þÔ©£AKpG Eôô§Û[-{ÍÜpõóe–`Ï0Î0YH<ù\DW™EuÅïd ò,e™!W4Š¾¯Á];ÙôK;%bƒÊÝõ0’œfÜûZΑÂ?„&K_é7g¸-{!jËXSsÃ?Sºe.ÈaLÙOuØ-ø,©‹›‰0æ£ÔSeÀ¥¾“ƒ1S;¦ÕSF0Ñ‘ÃXÕ±~Zn*ø]µï:ù4‹#NY”L..òLXèJvÕ½j0RMü÷ã9ÀãpåÙ½%Ïa$¢3ö(ž¼[ÊÞ ðCÕã1¸!…êF'žxÒ~’`m-ï@>%(Ì’Šž²Û\Õ€µ1„HšBê"7' ,m¬Ø¥•; ).r7Tß#6„N šŽŸB´P$íœ}ƒ¶C˜&ŒØMÛ,§Ð¹—€I‘=6©~óÅ·¦±eŸø%ž$ybѺZwÈ!¸2äAôê‚»QVÝdÁTÃÅÄnò,Í_æ,»)ÉϪÞXƒOÉ4q7°K“ª¦Åjýóbþöé¶CÐÎ5D°Tý›8˜>‹È?ÈŠ”±F3ºohƒCÓtvd` ÈÏY §‡CU’‰¢=¹ËNwŸîu¤ÿG¤êÛçÏÝþc"‘B£@ŸÄ.x„^^õþá†;«˜&íOLò˜bµz •I<:¹  õŠÚÝ—ï¯ z!lOÔôÓ5ÖT]À âäÍ‘R0?E9ÕXúGð1ÝèÜLõÌ s _á,*<7Ð çOeÞ íQ —8L·QHÍJ„"ý*ž#8™èjº#dñ¡€%§ç ¸»j‚Q5νÈTŽÇÕÕ ÁFm%´Ü“þ@ôhá Ô‘åg$ë2†Ñ!Š/λº_¹ œEwÌ] ÐÎÖ©ˆüy4=GˆIªV¨3¶õxT¥5C[–ãñ‰ìe°ëÇǦ^¿6½Žô7 qâØþ-DbÛACÐþ“2¯ÒÖÙ“‚pŠàŠžcÇ°°p=}9OÂ{õ^[çÙU§é³u5ví} Ó‡jJ O||óÛ›?¡§v<˜;Ý\Ú;ü®1Ùý¢ºÉÎ çW—‚ç„K¢0•™‡BŽ™p1Sn®d]}˜Q'OT3.¾×ä…€¹Ý+–¯BF ›Å¡ÝŒH"­ãâïCAIဳ”o[Þ‘s™ú]“ ôãÚÚذپà`߀Ô¯&ZáÙ¹9¿&¬(\ý»Û«ïàë?*Ã>endstream endobj 31 0 obj 3511 endobj 34 0 obj <> stream xœ½YÛŽÛF}Ÿ¯èŒXHt_Iöl¼@68öf£,XBQ”Ä]^’òÌìí[^óù¢­¾°I5%½‹±=3"»»êTÕ©Sí_ÂêË~OË+Œ^ÃßÝÕ¯WD?Aö[Z¢¿.¯^ü=R,·WfA4’A„"ÉѲ¼ZàSÆ‘@Ëû«Ù…hq½ü',#Ø®[PÁ‚§h¹¹šýn÷»FÚx vbXRnvZî3T$ë¬@eòˆÖªË¼ë² Ú6u‰{†ìmc,àfŸÙ¦>=ð@ G`ɬ­E]P¾E:IÿÜ¢.kʼJÔ9ëG”Tþ1œ‚'昬Úø'1ÚŸ4k;ؤ̪.ðÑ` -Hü$"–1çÚÖŸª*)Á¨WuÓ5I…$ö,‹EoÖ 65ºßçEvº½Àc(ÂXrÁ-Jš %EQßgmvD‰©Y®a̤~ýxL÷ê:ÚÄ4¢¡yž@×Ù.¯ZtŸw{øÈA‚jú¶nJÏ!8ˆ°Â‡žfl~o>ï²€Ù:iNQÄ#X]|@ï½óeÿl~ºEh?þà-ýÎ3 ÷jæ™çò(!µpïò4)Pöph²¶Ík?Ñ¢Þ›Õõ© *dº…G»Cb™(&ÕAZ¶(ij%[Èg õ€½†§Ðù}j*Rè,†ô$u$&ؤfÝŸ“@¥vé>¯v¾3±Cõ\Ñ`ûlZ)”iWO*EN*…—!ÑƼB4õF6ƒqÀ„"Ò/6YZïªüßY«ñê µU]=–í¤ô¥K±oÎçÆ|’=%}óÒ3Š>¹äå—/ùËÿ°ä¬'8à!&ÂóhpãmÉ {×¼-ˆp{Ð8Ɔ0 ÒO`Nëò4y[W¨>dMÒÕ÷‚F¡càÍ2ðÒ‘_ò­Ï¦7·_¼äö‡/^òúËOy}ÉÝòYtxâ€ÞÞN*†„Ò¯2)˜Ù[h%EÞv^o ŒdD÷uó/è -Ê«q•¼§æ=±CÇ„ø‘uMžv¹ ªÏg”º2œU—Ž·ÙÇ‚0¤† óêpìnP{\·i“:$¡„VDm-’€Ŧí”G³ë‚cÄC1ŒE86½O>f^ªœÒ¥;×c,çË© xn¼ÝˆÃüÉ­>½Ýx½œŠžü¦¦{Ôêz#8%½Lƒ@BïIÊC‘ÍÇ…é¢&m²E* /œ®È«.ÛÙ—«Ylz“²æ"Tèg«Ás‚áÉó!ÐèÅÃà TÎуú4@ð¥~€›ÕìëùÃ~}ÜãôÁ›ƒÁvBciƒ—ÖÇbƒÔÚ§ýêáA›4'«kôѹþí†Íã‚o¨þÌéœÍù\ÌC­h@ÃÙˆ(–4iµšE7Ö[Î\;1_" ¿˜tiUnc0…ÿúØ¡{íà“æÊš"R‚HvБ ‚TPtö·ŸíæE¿´q ýšz 0‰çªî $ô|ô÷Z€wª¸Lrª5DúܳhœÄäo$ ½÷Jé¦to}µ¨€Ú/²äÓ ç¬®5ß!½* Uõª~j cîš~O&¦ëtù:/òN‹Ž:&†…Ar[«© ‚àñƒ³% ?Íd¸çh8< Id4ßGhxI>¶ÇáÈ[0È)×êÀ J«ÊÛì#4Ç}ÙR±pGAwY¥´c;÷ˆ#£1BØΨ£íT±^¿ju Ó¯Ÿ·pfÓj*ßžn.XÏÓ³"_ßE‘ÇJ¡Ä5Ku~_gƒtxvº4ÃÆ@.kSºZ¥Ã±¼`–è îIÃð:›¾º°çlÚKI䟰œÄ£6OÆ@ìV^L— ‚L‡n åþ¨Aá ‹1 & º$³­l¬–Ú}}_¡d]CÛºD‹8RYûÜðìÿFÏ2‡ð à1WDI!žœvCA™vï É4$¾Bv±ÉA¬«‰\7®§Ü½x7™WÇGkþýŒ![¡öØéÄO‡”j5IöɼïË>ÎNrÅ“èìdª ºœ)}uQÖnû%“HŸî[˜9ý-/ÎS”Øæñô=Lì i¾¼*òJ¥`©^‚r‰Ï…»/Xî³Gs_0v—ÐÙÒPjÓYA9u—IÞ×ñŸ<YÍ%ãÒÂ÷0gHuÚ´.Že…B‹Gìà€¾± ªÐ5ç`0ŸØy…èîí?Þ}÷íòîÝ[tûó·ßÿíÍí¾þ(j=fDpÙ²†3+ Ð+²ÉP éé²Lò*Øz±Œ]‚á¯Ð‘›R—“µ£«ÊÄ0ÎÕÃ2ßí;ŪÚŸÞÞýì% ÁªÊMÕþáAŽÕTn©\Ën<2b„ùD´¥)2.¢sÖª@Äc eÙf¼ÜC5Àxq,:=†(4ÛB׆ÂöÛþö¿¨ìñ1Š‰«ßÀï}î^@ÆÀ½Ò“Y ‹˜ª›¨^GÇ¡íä3cO^íÐwÆ ¨†I›à®öµëžl¨ã3ÑDZõWºQIH%`”UÐXj3ü°AO0ÁcbºŠN•­¯û%‡vÄ¢‚Ja›‘ö/7¢4=6ºG2¬\7s­«€‡|XôüŠRÍbð#è•,=vÉÞ<4õÂI{è0¦ "Ä´]“”šð}lu“Qù{í>‘ùDP;žËüm­øK™{HòF]LªZ@6­[?¯… Î&ö×&giŠ526Á‡ð[ñ ”Ú¢¸Óÿ–Þ˜s’òaŽÜÝ·n÷>†.™õÆžÛÌ==—N2mÍ¥¥jž¡½Ù;¨a^ÉÎöX*¼Ch¿ül]m’fóüù R@ÕÂÐ²× (Ýžê\ܱ¼25O™Î]qàÙá2è‚ìtwW„b) sèu€h@{wzàס˜b`bÁçkf„±Ò\¦üÞUvúp2–ÄŒ‹¾ÁÕaû ¶TWŽÀh𧪠¢iF­f ï·ÇF_Ýnò6=¶FõQ†aêqZCîÇšÿ„«ë?£|ko>¸~Ï‚EõýE-dÿ>12:ÑWÀ‰Jôµúÿ£ôµ-#¼¼’á²ûBãK!$C#;¾¸Ï>Áúê·|3ß¡HRsaa VwÒAC,ìÌÐn8Ð8¹.Wwð8#¨í5ˆå…uˆd§UoÊô‹Š^=öËäÒÂL W\‚â7Þ~Ÿ40SÐçDJ¡ö½]^ý_ÿæÁendstream endobj 35 0 obj 2432 endobj 38 0 obj <> stream xœ­YÛnäÆ}×WtÍÚºÙÍæÅl”81àØÊ®?¬ ˜šéÑÐË!ÇlRkùŸ¼)¿’OÊ©¾3œÕJ‚…±^Y¬®:uêTñÆ£˜qúãÿ^íÎ8û þ»;ûå,¶¿0ÿ×jÇþx}öÅ›Œ.\oÎÜ1Ye,+v½;[òˆ‹"Í3Å®?œ-–,cËW×?Ÿ-Ïp×R¦ìz}†·qÉ“ÌÞó¶Ýé¾ÚiêžU†­µ©ºò¶Ö¬oÙ`4=þÅ›"¼U‘Â{aï*âBÉØšÙ0±r·ŽÊ(ww.Îû)fŠñ§å›ÙSI”ºŸàeœŠØ™o÷}Õ6ìöZmY¯ëÚ;–e/ô*’`Ÿ+žå±°w6mOÞ´ÝÊ9I#Áñ›¿Up™ÆÒÞÉʺfÿi˾jî–û¶jzÖîuW’ƒ6l¼%â-yÌ–d~}GiªR÷¦[ÍÖm£YÕàï½ïôª2x<¢gã åþÍ ‚À•Ë&»Y|ßXçD¥œûsÀvžø0±]u·íYÙÝ È߶ìgqϲH™|*ö8óh3*·6Ͷê5»%ƒp]oÊ¡î/ØíгÖ›XȨà2<©ÒLº“²ÇfmZ ]§›ÞE&•8ž ‘!ÄæRÒ¡±ìº²¹Ó;ÜÍvm‡GÛæ^7ý¹Aæ Å}Ê4‰Šß J%YÌ {_tóŠýPõÛY´¤Œž UrP<Íó$s0{äòQ¯/ìÁ‘Ùûª Ó¿–»=R}«W¨·© 2¶Œ [ˆ¿²ps΋[¾aŸEd\üöl±Âµ–íö]{‡Ÿð¯ÚÞWï^¸·9ιŒso0ŠsU¤êù‚ï~S—½fFßÔ5ûºíè"3í€Ò`5=ØàÖ’d]ÒE ])ó(‰epÖq@¸ÞVöÌBŽUðÄ×|Ð¥©êW·'1l%'‹Áœä]$¯/¨z9¥+΋D¹——çx¬{Ý}9ÏI|š’UÙS>Ø¿ý»Ó›M4{Ù,ø‹ë­ž ?%X¯O€U„%*¤áøÕºŸñ^¢Nö\ ²`Y*ánÁ³×ß½ýID¥™¾V½aïäj*]¯«ÅN—kŠÍ$Š>å£Á$'_]>/ñ¨næµDÌ#éWÛ²+Wˆú±‹ÊÛ[Ü—]åà„$1¶2¹‚ôuD¥U_•uõO½¶8Ìm‡S‡Šã)ç[¨r¡Æ&jÙm{B8.ÒøétyK‹²YÏÓœ†\>Ã*•çº4ýsÜ‘¨OÃtùšhä…`%o¤*qAñ“`6vùùçì]¬ *Ó¶+Xw7óƒgÔY8b2v®8%²Ö/Xéè‚Z!Õº¥yhúòWê©«®ºõ)ˆ%²Sˆ$O|¬:‚ Ä踿 ñ°‡„+½:m.œ€ÏI6íG©Ý@3ÞêzCýÊÒ—‚¸9¯Jå²ð¨»®í¨ƒ[‘huÖ¾4Ô[½ø$Z÷®Êˆ\ø.}m…íaQÙèÛ•ï5³-šM<o–ÎNèÔ\ú\^Í [Eñø&€‰§‡Å°*‘ÄY+TYÐvϵB€3ŸºJq®ò4„r…6ýSÎúìxðÅc}r1â':=F”1˜5w°t a²ÂÖªÅsè±Ñkqߤõã< n”C]¢EWÍ~è½…v’…z™Ã›‡Ãs7‹¶›)íQmUC~\ ‚´¦‹^€T»~ÿöõõ7ßÇþôçë×ß|ûv¶‚"DØÁ‡ÑhU` ãDt >mWeŠ‘ßÞpÜ–”ñÖÑSÙ¬*¿*ÞRã"aVÎI4*C©Tá1ËÆ­]˜¨(€ïÒ½Æ'ÄŒ?Ï&D¹ÁN$5&É)E­“9íz -T¢Ç!F/ûNë0«@_Î*‡îqt[¥ªwëÂHè•¡ÆÙÆl+=ÃJÜQ‚ŒïÀÍ-~d{œ×î0/'oW——7¯Ø»Â[Ò*'4*IÛY„ƒ­0);éÉâ¶4NdY4-÷íG¹þ­ÖvÄ\[wDžºôszå¨È5J¶6½csÁiòW17j8¤µz×<»Æå5‘4ÉŒLÁÎ7¸1Âw’†¸×oiŒŒÞWkx=„3&}}9 <åiÅÊ5”f[Wkÿ­¤µšÛg‰°Z·è¦Ÿß7í¨·;mãNBlPút”Z÷”@èlH%œÓ~R‰œßô fÚÜŸ¦Žî”Ô´â@š 2¤ >¹ü¶Ç$ϽõŠHuÕîýƺ 晆ÊQ+:ŒÎˆ#Ǭ§Kš§‰wêc%íJ ˜dr%m±‘?”˾³_¥P2åI<Ùä”p8'³Ñ_ÂÂ]Wî`×o0ìX–Ž`N¸ Y¨Ô(ä"¥ dš£2ÂBrdx– ˆFš^–‹lªQÛ§Õ˜‰Ù¨:xÛÒÒãdÛ6ŠŒy…ß]Llì™ñvS ²Ë&’Td´(ñ:w<¬ÞSõ4h±Ð·C]?¸ªä©#<ë`Fò«öƒÊµà¥ Ýă©Ra}e·ÛmS€a6?Ô ;ˆS¿9öûÖ8ÔmûžZiÕ@}^0úÆé/–û½ß:UMãÄÊ{ÚþE~9>65%2 óà_0ë’ÝØùŪ±YU×hïÔÈç+ƒüÅ_iä¤å¼ÔÓß¹?KQë·.ÂhÎÅU>}$ýÚe:.(¦£*JrÖO†¦/‰ !Ü0Ú!_v6Ñ~ñƒ~…Œ*-T3€SO3‘Ï ‘nvÐ ðhœ‡Úð¤æCõåqh²—Gæˆd:ÞÚ]cGWŸOן{Ö!÷•›„s’ü(dÄ8ld‹‘ÉþVvà!.X\ŠnÿóõÙßñçø’nendstream endobj 39 0 obj 3159 endobj 42 0 obj <> stream xœXÛrÛF}çWteLÑ<ƒ;ìõCìÈ)U9Ê®ÃÔƵܒAphÁIÜÔþRü‹{zf^”­u©$JÀLÏôésNÏè W’à/û™o'‚~Ä÷ÇÉ—‰ÔoÈ~ä[zµ˜<{óƒÅfb&HòâÔ)NZl'Žp…—FIÒâ~2u(!çbñ ÓdJ)Osd¹!9>Ư±{óëõëÅÕÏ×ôÃÏ‹åôzþÛüýò‚§ñJo'Ó«ëÅå—ïèúâÉdúîòû·ô†-/0Œ?ø)fÒKæWÞáþ”s=Åñ¤‘ÃÁÖ¹ž^b¯$x-ÛÁL÷”W¹Z^ÌÞëéxñgzyýƒÉlĉ$B;žà0 ¨ºú4w/q‡Lì€g3Z×»!Ç¡®Éª¶Ì:µ¦Õž6^NËéjÚ¢®H¦i(|,/\ g0ìâ}ÝÓ¶o;*‹ê3u·ŠÕöeWT©^}RyG›¢Tt_t·úuY¬š¬)Tûœcå㔼ªSnO!‘{Ö¨,‘¿ó=78«»Í:ª›µj,JÒ Ž¶8{¦W2¥üKQåe¿VôVso¿ã‚­ë~UªFe%ãq³œVsz˜Ó^WÖR`ªª¡Yõ‚§èÁ3 šíõß¿ãÇq•Û_öm§¶ôQUªÑÀ–už•-™ýŒ‹›yˆÙ¨îæ.+ùÝ1"½å‰tØ2lTG7ÖvYWä4F;ù·¬É¶ªÃ‹lý eÚªª;ï8&Çy8ú¦¯òŽËÿª^ïO¦Ø=‚¦Ë馬³ny!\„sÁc Ò¦n¸h,„TÐ__š\ééÓbyA¿Ÿ+Cg*Ås PàÕpXòéKzøgñ/šÑ/Œ&ŽcüGc‹á}Sƒy6Š ÷oìZG"2ñ­ˆ ¨Ð cͳØ{$“×”•÷Ù¾%T ¨šá}øpcx¸B$–Ì®¡ohktöä åõ–ëBYµ¦lT¬u9%¤ž™>²÷tÏ¡tS; ÞœÏ÷Üa²&üéL_Øw®y>ÌJ†€Žtã ¤±Iòò3´º,a –àD#?–Æ|QþdeÑÔÕ)îš:Wë¾QT›PC÷ªqò¬5#²ÝNUëVÃÁÝElwƒ"/ò…qPŒ¥¾‚ìÛ¼F4ÄáµÔè^+ýÆú6iàQ:Á!™8‘Ò,´œ"vvWØ|ݶg’×Õ×"ên\mo2|2 ÝpØ:È M;Á$è`̽Dz7Úý©h?|xD 0kLú=MF&‡Ø"†t`ü(–Œ4!ü¯@ðÑ(Ïë¾Ò:~*ÑÁ<ˆ!S9Ð@×e“¡h«†ršfTáI*>à`Ú (+¬û{nx€íתo¨üphL‰0Že`›D™­<6k¸uYQA©E5H¬%ÞMö»T 7©]ß ¦ªuMçHc7Ñ ü$ L]þB#TFëŒszS7¬v,µAÿ¨rÃfíàžÌ½v$k ‰N§ª‰¦¾Ý>÷ì?‰Vž4€³Ú9C<»éÁ,O«xÃz^GÑ9Ýßù-ÝÖåzjÙk%­4~z˦*aà¦"ª'PúP´¤Ö6æp´:¬“ˆÀ.ıÏÙ»qÆéÞq.pã1Ž”Ò7ô­wÓÔÙ©¼øC­ç§Æ'ÃÙÄH¡@ß’ð‘uI>ÚxÏT²Æ±§kíQ†0#}v²]A@ØfB·ß)zd»€bHÛúéÒ^<¼„hb) F#ct ¸ôg1ãqÚщå4r$· ǹôJ唣›*ZÅQ7‚l<[¡¾e5pÖ¯aõî%^ïøäR7-•*[k6~Ä¢p&Óxvü#Ùmë˜jóG‘å{BBm l³êQíYÁ¤çs½FfqKÓ˺þlU½ÛA}Ut…Ræ|ðsÌcNYËv`¢•zl„péÑ tƒcžzaœD\×=k§£kù‘à ‰5ÊU}§Î:¬#·}öÿwY™Ž÷Œ „gÄ`–e¹§u9T01ÓŒÚù~íë¾åV«cÚçôýõ/W¨®•L’rÔµ1Gg-`{b9úR&¡eG½!ż̘¡8tý£Ú§Qÿ+Ž… ”³«aièÉ;\ ø2Á%¨ÖgÀQ/úFÄîècI§±áxßÚƒ†M±éKÃ5RÅaÿþVUÇXØþð¥/ô£4TC$Ž_e8tÍMX7=C=î€Þ°ø7¢ ½à«.¹‡.Ÿ Šó]ßôN×uåð~µ.ù”s°ÎÔ‹D`9h];Ü ³éM£´?ßµÞÅ°Ç^%,8=Rd i0BÚ/ø̹V› ´3FÁ`‡ß ıu!|ŒÖ5`­jnç¸õì:ÝD`ŸéÓáZuÇÔåscÖP…±{B„ñælê¢$»*ò‚©]>ÃD¦/ÆÊñ‰@ÿ°|1Ô%‰‘|G÷¬ÃÁ¬7‹>À!‚T¢ ™!Lnõmw¥škÊÙºŸý—/°¼ÆxÛ6®ñ€ËP6[NW³ÜÜU§{}Êf+\ôs\TŽN£aÈ|ïó+…4”FJ&ˆìG8r; 秬AK÷¼¹¾·óèËÅäïøú/æn¡Ýendstream endobj 43 0 obj 1997 endobj 46 0 obj <> stream xœ­WÛr£F}×Wô“ƒ¼€g` Ž²[É–«r©$z‹R.ŒF61ï€|ÉÖþR¾1Ý3€–ojK^[ËLwŸ9}º§ùÌçÀèÓýÍ73ïñßÍìÃŒ›èþäx»˜ý*éÁb=³™údÂb3ó˜Ï‚4Nd‹Ç™ãA Þ|ñ'šñ¿£™Ç#é ðî_a ÚöÁ),kü/ççdCa~˜9ÏÝ¢Y:ŸµÁ‹˜‚Çrå,nÕªƒ˜úb¤EïNÛÅÞ6àˆÚ®eÕjj˜>:ÃÕÄRö–ÜBrs†ú¾-êª<Û6ŽÞ[4À@zRžFš¬!ÈÇ®¹ôãÁµàL˜}m èZµ¹¯u¦Ÿá!ÓEv]ªpi]ë\A^k­òÔCVn3‚µ^) E{KA< ?B²‚"J…4ªºò¾ýé·Kx‡Ž6÷E©tã“U@‚¢\ù‰ŒEl-¾¯u«³ .Ï~†¢1Ve‘g­ZCYÜMàB „®ÇG1ƒvAJwb¿š5awâFÉÒ84óºzPºmP=ûh›QnTÕBQ!}yV– ]í­ê÷Y¾ÒÈOz¾°>xÀYj“—²¸¦TŒ‡QÄÁõK)'Â~j—_rÙñ)ªášû1cas$fË>®=•ŠÐ—iÚ‘äh•M…ºó%™ ƒ /¤ã…ÜX_ ºhÕØ`;H2éݸD˜V”üU)4>#ÊJºDžukXwiƒ=jâ – ~ƒZöCÃF²¯×0Ln3 ªèbbb €Êò[|¨6@L úÎҪʙK,-õô‡qO?¼/”a6HýpàŸF‰ ÂÕN°Ry™iScÍ´·¡#êx×ÝPfê+1¯·U»t8[ÎÉŒVb)—Ý£Qc‹±þûÆf¡E¶Œuº‹ÞÙìE&"–Ω{ºœÛè.Åg÷E(’¹°ºÃܶ[]©•-•¦Þ(¸EŸx˜²¨Tóõ@˜‚Ù@™/r¸"ƒ”û]æ=áwY¿&I}Û‡ Îm)²Ðx¶}½SΌפo1ƒ_Î:Çœ™Ã®ãð ÚðZðÓ—÷ðôìÞn‹²-*Xo«Ü^§gF}üæJ7¥Z:˹ «úª,jû] Ïé6ôF~FÛï€×eß áºSçEY4Øë+tz˜Íƒ‡þÌ…È¥ßôŸÎ'úâQ4Xœ2¤ÈØSý’žÕ“Ê·-]iVXÇu5àéÙ9AĈ­›œž¨“Ÿ Ï"ƒIúOlb C/cî lˆÉÈféä·™,¤SH¿³?\|¸n«RUËySü¥êõ²OÝrÞÁAɆ8#¡‰ø¥QbÁHmç@g_Zã,v9’È£@„6‰—æê/Ú]ƒ¬½²®ïñŠPþÿ9M `›dAB7½Ñ|+¨f]è[ç‘îE°X¥ÖjGÝK=u0ßA÷/ÍëˆÈÂŽ‹›î„GÈÎà7¦«À›7>¢îö+ðpæÅÿȼ{°£½gð×J40Cô–è%…‡9Q©:ŸL›à¡2_ ¾»™aqàÞìæs6Œ?8X\L†¨¸Ú½' “§£´>j‰8¤Ÿæ›{•〠›ìN™ö§U³¥»àµ©pí3ÆPK´µÎpzg²÷Ê ˆcËiÖ“gÜÿa[hzOhZófpmf-O8–¢i7Ja#œm»Ñ¤Á Y­†4>c{s7“IÊâ.©ê)ÃRWî¸pðU)MÂðHQ»Ä ÕídñÙgï`;nàqfG¶“ _wUî\+|Û°wOÅ¥wˆ~HLcÖ5€3a`ßHÓˆ¶·˜ý‚ŸDCÍúendstream endobj 47 0 obj 1421 endobj 50 0 obj <> stream xœÕVKÛ6¾ûWL/YÙkkIQÏ,rhŠ´(ÚúVW¢m¶ZÊ‘èÝuƒþ÷ ²e力¶@a–9œ×73ßè#1ÿ[ÝO|‡ßÍäã„Z øŸêÞ.'7?fæ`¹ž8 Q–…dE ËûÉ‚„$*Ò> stream xœ½VÉŽã6½û+ È¡í’Z™F. ’ @rHàœÚF,Ñ%Z<’ÜíÆ`þ=ÅE2¥ééä6M«Š|ïUÉxˆ|̘×+?ãç´ú¸¢ÊfÈkø~»òÿHäÂö¸ÒX’x ¶^¹Ä#ŒÇiÁöyµvRp7Û¿ÐràÒÏ¥Iì…àèP`&¹¯h/‡Jt"« /ñ¸[_wé&SýºZ+Ë»ëýænµþ„_Œz1¸ÒXHãpéíHЕ8pu`gœv²ÛÜËXëÏèéjW¦]­¼yÛ7â„î/:³qùo9é,¡/vÎfnDäÕiŠˆÉ0?µÝÐeÍÞPƒÎ“·uÝû$H½H›%ÚM‚4P(vâT¶MY'@OP6C ?,âSB½Ô$è‡î’‹±62/b$Q¡{ð¬r‹¼€ðv€8Hb®éqÍês%>0—ƒBäUÖeƒ<ÛR`^€xÄ-}g𛬅¹…¥µÂ7`’+äˆ;’+ ÒD¹yÙc"(n6EKw›#&â$:(oKU{*sÜUOKL ¯<"¯¸Š{Ùn#9Àá;ù#Üm|"åbÑS¼ÐD3‚Dh³È°Ô_ª™™cÁRäd„&>)ÜmùMƒ¢âQ%2À|Sˆ#ŠßX¨ÑÕÄ|¦ª1å¦Ð4^ý0þƒì[Åaýò®ã®âíõÛ4؃oMÃý«—XD \)Iy*tÿl D•º(©f(s»çyeÐÐ.=ƱÕq«=KykÝg‡öi3‘7Ax#&%!SC~6ˆZ4ò-z¨[,l$³Èão—¥Dì i$*#_¹Å@®Å?š ËTÌMeêæ¦Ò2•sSm³­MsYPKõÃÛ20ôÚ'º¿Î4Inôürü*3™Øþ÷fÒ”‡ºŒU›ÿ ÏXkXÊOmõ¤º-d¯ôZ¦˯Ȇlž(f3¤×*í/‡sמº¬v@x'oI;§xþíóo5ÔJöÔ»ÿ§¥®åTìšøí‡4ùŽ íÕgÁI§¬9)u“ }G¶¥H½=õËIŠC^öLØ÷ŽYÕ Ï—w¶6®ES,”2oÏ|L Ú¨’æ•–ð©|_{a†tÔŠ•èXÏí¥*°xO(‹÷ïãptˆíVoÊåQ€Õ$H2Ê=It¸»s ¯76ÿ> ’8åQ@Õæ#°|•O!C™uê²ï/X/ºåˆ _àKTÜ€„ꥥÿ̘²_@cN½VýŠ†¨Õ ¾ÕhÈ'è˺ü0æå<’»Ü®~Çç%·sendstream endobj 55 0 obj 1043 endobj 58 0 obj <> stream xœVÛŽÛ6}÷W P ‘ KKRÔ…òÐI -ÐÄEÖ K´­V–]²Ù,ö—ú^$Ëö Œ]‰ÔÜ8sf?ñ(õ³Ïì0#ðþífŸgTûÈðj5»ù©Õvf(°(òD‚Ãê0s‰G˜ã(€ÕÝÌq2pç«P JÏ¥Qèqp}TÈÑ“’û%—Û¢’P¥™'ÖÎbí´]ÓgÝ°—Àb=‡gfµž+› •ßÏœ›¼«Š®HËâ›Ì!O»7óç³Á¾3ê…àªÈó™“Õ‡c)¿‚Lè eˆCyÝoJÙÈ´„mQ– »¥äÓ ehòE&þå–æ·ÂÈZ©@/Šª“;Ù‘p´7lË$º‹o)5be½+2mM\‹Qr±G›#x ˜ºmY§ÝzN½åiApñ@—À†—ñ“?ìð%ã>Óæ)À2©êè¯o}ÿñM¢²r/r*<¾0áÒ V¦±òˆaL½« Û-ȯ©*ÁÒ( «Æ^d,#ŽOµÖXvî‚Z94ð ˆ´X#ËB¶PWðúy ¦ø}#•¦@\?”"á[„B1@'í ÔlúMt5´ýñXÞÃ7ÙÔzÝíåˆã!†ÀóEhl:º&çÇñ‰ýV{þ}D‡^I›&½GWû´Sâ® D6œ“QkÉ.ýWBT!A{L3 Ûº»}‘í¡ª/£dbpç¨Ö8…Eºñµ‡€™L~IËÓp‡ø†]ñEVžRÃóF„ÚûØèÄH#–V&;Œ{œ>ZŒ)³i œÕUÛ¥U×^„ù^(,¬œÕ‡¿Þ$çúþ¨“VùU%<[ZçÓ‰®8é8¸œ O ÉUC‹ ÊI¨cÍåΑ¢ºð¶†-6˼ý…“¡ØžN.t'8w¬?ôYlýzŸ6iÖa/Òª8ö¥FŸNŠˆÏ J?&Â$±Þ¡/»;ÇÍF ô¢Úµ°“•lÒAÛÈÅð°í«Lãs_¶ºŠ,P½eÌ3[3°%z[7zb¶&5¤llÞ³®u} |šÄ fĶ¬Â&ìš´:ÿ!Õi Oóc<ÉBýù4æní¤ËIè•\º„(†“/…›³–ˆçÓqd]êiäܲÌÛó˜XŒÍÆäx€?íÚ S7KЬ ÃðsÕ¤ÔiI˜Î›6_Ócg©š—.3è@²:Õ~q£Œ«s&kœ^]‚}·û’”²ZêCâ³Ø¨Ç$°°²š¶]…Ÿ§êzÛ¢Åf*–Žvc3nœøòôÇû¶“‹±Û£¬R­"ZMšçº­¢nÀ¯2DoÙ'“Ž€ôb5d·ÐMûCU6QÅ°^õöà çc@*ä~ÓÔ}§î6Ñm¢!µž«cº—Gü»A&¨vjD¡˜¬ !{ÓëÃ[‘¨èÈ'%ÀÉEõmÉÒ Ê<;˜QÅÍ.•-t|þ§ôi§›ŸpJ¿çtsåÔ± ¡i ?ÙTOªˆjÖ”•†ƒ·k<Ë’1ãWö´Êòª¶êŒèK¦=Ç#`}U›ÙrN†ƒí}{Uá~Ì-þQwöõ¦YôÐ7•«yÐͮۛžçH›'¾‹pü±/è#T—>PÜ$äó€Âp´æû¾0Œ¯¦]•ÃÇAªÉaBh¯½PÂNdwmýgitó„*£Ahy]†w„¾•¹7ÞZÂ)'ÄáÜ×±»J 'æªj˜è¶UVN–×Ø´Eå–ؼ†´Gc ¬\³V쉑µ4Ù¢ÎyK—rSç÷ŠI/Ê (Þn"…Ê=>˜á"èï÷´Á cK BJçÍjö'þþýwqÉendstream endobj 59 0 obj 1407 endobj 62 0 obj <> stream xœ…VÛnã6}÷WLQ ± ‰I]¬éC‹Ý¶ÀîCîS¼‰ŠYHÔF’7AƒüûII–. !‘ȹp朙¡! ó ï¼^ð;þ=,ÔJ`xå5üº_l>%fc_.œ–$„A’†°¯~@–ÆÛ$‚ýÓbéåà¯öÿ M!5v> Cð9ªxŽÑÊ¢y/Û5…ò¤ó^5*Ñõúþ°|öôae<˜S?\*?–Fx³X:m¸…¸1ë¢1Q*ÜÐP|Š»4Æ@}ã§X,U èü°T‡-‰±ÄÏþ(µ=m®;ywúF¾lejµ9KêT‰_~”’p4b‰Í y£{¥OÒ˜áîèÍ0# ~LÍ™,²â{™7µì.±‹sãgìÖGöUT.õ ­lZÌÍ$¿Ö;á—[ ;ð}“ê ÆÉ(‰¯p¸SŸá‡Ûƒé\ivŠQÝÍ€ÉüBûÕˆýÏܬá ~†õæïW—b:¢À"›£EÁ§$ Ó˜ÚTßË/£[’‚órêfX Ò”li×·§¼¿4æ±bÅ&§ÌUlbäerÄ8‰G?²TZ^z ÙÙSL´sžúúV讽¼rq—òñ¤Z©ó+·ñ #1 \5uÞ7­…Q ‚p:8h3«Â($£ˆò0 \rXŠõ—JåOòYàBBwlžl‹ú‹>E^˜1¤$Œ“Ä!¯ôƒi PûN¸þlÊ«”Ò…e!zq™ yxRýñ\:±„ÑÕþo––Þ•]¼=dóù§aéòÅÑú§V½•úÛÚ‚¿¶XÆß îf7«+,[B2c»©ždÆwób’Y¸›W’Ì¢ y©ª*‹ï(ÿl·_ÇèñòxÁ¬Êªýa…s^¸`ó Ž‹Ðƒý§¿ßeð:»bøtŸì…iƒ¦4÷k× ÝÖðIvãã’êLÏæ0Æ–gè*FŽoî(Ûô -[2ÎT·Wg¸»÷æçK<¶=^OAê&ÇGÑæG` q¤idŒÞíáó Aiendstream endobj 63 0 obj 1089 endobj 66 0 obj <> stream xœµYÛ’ÛÆ}߯˜rª¼+ a—⇔´±­’lÇZÇNi]2H IX @ã²+V*ß“7åWòI9=3€Ø]E~H©l²ÌtO÷éÓ§gc¾Ç™Oÿìçz泯ñßöì·3®Ÿ0û±Þ³×gϾ—ôÃõæÌ,àLHé &Ó]ïÏ–¾ç‹4NdÄ®ïÎ.–Œ‡lùäúW¬ã)KiÝ’ËØïä°Dï={Ê^eEÅM½m²={úŒ½z~õÍ[ZÉEêÅ°„——,ÑûìíÍÅÍzº4—\¿pñúMpúEø'û¿¬×YÉn³¦ÈV¥jaB/Ÿ¾{ñ‡\mŠJ±œaû‹¼îñf£°ìéÍ“Ï×û*Û«·ÜØ%{/Ç…^QTÚªfþúùø^©ß+ëm±¾¿íä½F¿÷ís{<{`õ¾SMÅpÀ×ýª©ûŽV#|p…µÙ^Çé ã°ùmØÏ[/X¾`Ÿ7oøÏø(ÞúØ¿ ðñY[ïÛÕ%bPt»Ïð`ýæƒ ô’{ùàáB[ †g&ðÈÿKëÀ2H|¼>8þOòÙ%9 ïíH?Ë!óv7›´ø$i}… ±fšóS©#j¾“ï9¾8^Š>/yêEÚ’çÐû¼eÝ®h™zŸí¥bí®¾kÍ©]¦ž´®û^ÊÓ(àz톉µyÓÕ‹}d…©~­ë›ªeûªnº&«t@\ ‡5ž]ê“ÅøÑ°…Œ¢$2[°M_­»¢®å4wÅf¬ÆðN¹èÆzŽ» ñè`x6 HBìsóªÇ~Üuj¥çN?à6QUÝÍl.Cy)B*t‚ö¨ìSKÂÙñ÷Í1þÄ~Te9‹n`|Q«¯¤œí’:¬yQì'Ò8´®«)ª—Œl³¡,º]Ö±¬Aœ·ª5A]A e B{ªMÝ°ÄHÁJ±uY·*gYßÕû¬£â-ìn§*lª ‘„€ö²§Ôq´ Ñ» ÙÛvõ¡]8W´1åM Ñ æ !5ðŸA¨¨nëwj~Ø4ÖíówTØ…gž$CÉp°*À#¤q4Jyh2{ì»o¿¿~þâêåÕõßiU". 3Ù€¿nUƒ®~ꚈxþgÌã¡~È#‡±­î¢kU¹ÑLpbò’¹”÷(kÏÒYª]1 ¥)žïÕ6krª~Zü¡i;ƒ™#É`R¡¨\êdÄ%®[UåuC‰SÞÖ[@¶TÚŸWWß½¾yÂvÙ-B°#ÊM8@µdJ‡¥rT³ä‘¯M8#xpÓK,y³®Lή#Ú(’qb ¶iê½ö£nŠmQAMÁ!ºÅñMüóÍ;.:?v-.ð[žßb#íPøþؽ‚( åƒñÑâ('o‡È¼0eôXÔNϽ €y>2þceN(…‡ÆçÂïR‡0Ï™›'®€Ð9 šÞŸZ GÚŠí–·YÙÃm×Ile„(Š` îÄ÷ƒtàîÞÈ0H’d¤‡aCŠ¹ìHâ41\Låÿ‰!t;á'ad2 LÖ”ÿ»€9qñ8´—–ÝAik¸‘–ku‘Îh@«ÕO¥ØE'ä¡o2ªÞÔºk™éAJ ÒeEø´£ #4T¿ù°.vH?v½4vD…¨´Â®/séGÒîÓk¡¡‘®w8¤™â˜&Õ‹šKMGºÓ%eê€Xé¶ÈŠUß!j-mv}ÑÕ} f!? ]›ý¸n¼¨g ÁùtåGøŸ§Ü‚ÕU)Œ¡kJgûB#?PèˆA¢±Ÿ¶ÐëÕ¯:¨“¥‰ æ≽II#nEI%2ÑåÀÖ9[gG êýÔ‰dàCP´ “ÐÆŸ08ñÎØ^µe“–óÖM,ö…Æt ľo;CÑ¡ÇÒjî8}«l¯k˜™ôsmÜuÇIÏœŸ“Tlð‰çt4"Ôzìª2C€çàbÒÓöèÛ²Úª…öŽB ãøp"ö}cš1ÊØì"©-Œ¢µÊ #„É´]ù$Û"S’õŠ&tϾY+'½§"‡W§–ìX8,WªÃŠ`'góá–›šük!úþ•Ütè}±Ýuƒû³Eãô`€׆†z ¯ïF¤g}Û<Ãúgf/›ß“|¦ {í×µÊWÝ—¹QpÓ‘ïÞ­]¨‹YZAhÔÁš=õÖlYÂ0þ¿Ÿ5ÃÓ›}7(ej YîÐÌ•ñ±FäT>—¿{ö0ãÔl¤²¢–{< ‚ÈŽAåÍŒP¦òmTÖÖU¶šÌ´bÝ¥VÔ@º‚&c›ž. ÷Ÿ견ì²ÉŽØ²Ì-Írædhgµ¯Z¿-,ûKzo,€D„ÂDêõ×W£Nþó——ìoÏbê·¾8Ð0âEaÀ—ŠÚ¬¾´Ã)Z=ùo1(’Ð }'d„r³D§ÑM#³¾=°87BÖ'Ù Åmé›ý¥¾S0b=O ‰ü Ñ‹”h{ Ýš‘Ä7zä¸7o@‡K$.ÑaÇ ™ NéJE›\©19!µFìW]Ëuu“mÑw² ú~ÂŽ°àTÛ¦LúíîÖQ¦74߶MQÈDrKåYuœ4ƒKÅvèi‚šÓǘ6ê³ÔÝ8Ü&ìCcFÿæ}”Ή/…e§øìèþÇ©~Ç¡ôÇÀËç2ah§NM.ùx"¥0ý¢67I7”Æ燺`ñž½ÀäééfŒÒ¡LÛGÔ¼“û”MÅjw-mûý 5pB¾5Ù×2à®oòAÐT¬‰cî?§WK<gïèãM=ãÜ€QoÂdMÅê<_jË«º¯r4; #ä-W,1pí¸b?à"P;­Ë© N%ûHÖ €aÞ¸|p*/¼¸ KGõb‚øg}höâTPÏ ?ôÆ©)´·Äƒž£ËÀ¤Ü‘%Æ|>½ L}›ò_~é+Ðàù9%ª=d&w;"k=Ä `«¥K˳.cÝñ œj,f ïü\ó ÈDrwH«+®Lås/öGÄBXž¤t¡ø+E> stream xœYkÛÆý¾¿bݵ!ÑóàCýàMk Ðx‹~è EQ+:)ó±kÕð_Êoì¹ó )ÚNŒz±Ú]‰3sçž{îøã‘`œ¾üÏâxÅÙßð}õîJØO˜ÿQÙ··WÏ~JéÛÝ•[ ˜LÓH²4‹ÙíñjÍ#.³Ä¤šÝ>^ݬ™ÐlýäöíÕZrÇÖ*a·Û+‡JÙ‡›á°e›’å§SÛœÚ*ïˈ֘4J¹Ä!X!##¸v»²ïš–>Y$9Ý<’&Ñ´==ÑïKv»¯ê_Ù+V4ÇSu([ÖÔöýò¢ªû¦Û¯Â; ^Z¶Ïëí W;TuÉœ]uYn­‚'QsÖBÒyäij2žH{bßÀœTÒ³Ï~Ë(HÒD+ÒH[Ý£çS¹-w¬Û7m϶Ͱ9”þG[æ‡n‡æµ²;d~‡H'±È\à^ïعÚ™‹´4M¢˜K¢’$Z ã¢rjqðouÙ±î|Ü4‡Þæ=V“£Å!ïöì±ê÷¬oóº; [ 5ýÅrä… ­ócÙQ˜ÊÚ‡EÐy!,Èl¦|öa9I›ç‡®aùÖFÒðHqáóJaTFá\šc`Œ¤ „†ï™1nÙÍŸ†1¼ •2QÜJHgåŽ6‹í”ˆ2¿×NÑ~±°Óš«ÌnQÖ(©lµØs8àQY m[ÖÈh¹Ë‡C¿8/QQú;çÉÉt®…JR+ã¡Ú’ý€é®9šGWN á0!è7U}¿8NèHý~¨ôÌ¡¥ŠgÑÚ5íìDìóüÓ(¦:ej÷(ÚüÌŽEb¸äô|æíÂȺûŠÞUÞ>)üÛC-é}-.žTÊñ²ÑmFFöóŽûcÇê\Ÿò¶°ÜÇ—‡µ¢ml…xì Ÿ¸¡®Þ;ŽBÔf»»¥Öx{Úž„p´ô‰áô[W“…ñ‰Òy¿(i«(¶çŒe¤‰Êœ=/;†‚+ß÷eÝUÄPÍE¨Ä4eozPUÞnWnß1çFDf,«LdZ9wL—&ˆ4d?Ö2õ¹Ï)Ù«›ºØçm^ôŽPP¯éŒPR±ð4Xꋼª«¾ÊÕÁÄ$ª<Žôœ!h·Ø9ĶyŸ[Ö×é3¤"-¹Ë1Ñyç«ÏÌXßÄ*öÑžB ¯jp:Êñp&‡Nºb¹«¥z8n¨%ìØhÐÓ7­%¹>úåࢿ¾¶>v†b0#ÿD™P¥ªš¶9²c^ì©{ þWëø(ÁjņÃ7U]8ZI©M äE{Œ*É6U¶BÚÒúqlºžp´Ú ‡% ´ÎôWB" Œ'…4Ú'9ﺔÏâY¤,,T”p9âˆ#Íèû¾Ñ8ä¬clšò1l"B1׌œC˜Wl3ô®ûÚO=%²ÀÀUóP¶mµÝ–øëL~/hH&"ò¹Yÿk„ðA}é¯ ü¥©Lœ³h¤GÔÖÚ €ÆÚà¤HFΪ€ÊOµˆä3-‚¥à#*ó#´Z˜¼V:ÐØm. Ä–Yˆ.Zdš¸ )@S“´TýÊõñ*”a Fj¬»„€”T«4Ö>G¯ˆ¥I8 ”Ñë‡ö]W%3óÚ ’xlÚmäj0ƶ£Ìní®/kŸø8Bž×‹Ö#>|HÈà}y8¸ŒŠõ¹cPRéY¡Äé¨é¬Ké,ÒN>$©ÈÆlª.EØZKÚ3[ 1¢V=»Î7Åöú™Ý|uó–ý…UO®ah½Ås[œÍh›ÃÑQmM¼3“™.ñòègOÙëWZKž>s@²&t}ÞWÑEÏ>À ) ÖÂa™ÃÊŸÅ¿ãÿ¼˜þ‘•ï†êág>°×9ÊêzC/½l¯?²/°× ~H/ ï»»yz1Ñ—÷ÈöÓ»'öÛÝ=±¦Y ü"o`xøí‹™ñ6~öœ £#†¯™µN˜ØHÏ›£¹¼2ÑÆøîæ 6:”æn©“ ÉnªË2u•$%çØoÅÊè>÷,y$›”¤ m8i5)cé±G@×eQv]Þž™#†‰ˆÒø«‰xÚß$ã˜T¬+K[ëKïÅ(.«%Ë™Ñ!–¯%²³é)’V‘“;ÐʘçõxM'ÓóS{gU9P®&†A—Äb¿ôõÎQ$‰©§µ™ùŠAëóö¾{°ÜmLãÝȨZ͘‹ £õ¨Ò§´n)Dud7¶ÊËÝýþzxNHØ´øÇö[¾¿ÿf±œ¦±§|7ÍE›—ìÆAPA&Nt<›€‰µ1œ…F.ÆÀÖl‡±9/šZ"¾VèMˆN3î+ÉØÔG–ê~§rŒ‰õ{á³Ê¢Q Žþ»V ›Ò#šÏ Es5Íç~Nš¤˜‹vO¹˜u‘ªÄ×À—ú„/Û3’6Îlad›"'i€HÓÿCqÊÊ|I',bhÌ8€}®³O¢ ýMR}ØA¦zð³^Ñ`˜,f%—[=DÝ>·ù[‚ïvz¶„6Up}¹<ß@IK‡áØW`*ž¼‚Á‰äÄa×èµÂ°žÝÃ'ÝóÏÎgœÏô¸žXÆÝ­|.81da ¶~¹ºœfžèÀØäúËß¼^QUø!8!¿ƒ€¢JéþøúeìB®úÞtÙ9ê©WZ›?8.ÿb˲P‰! œåo@Ù/O'H‰ê=ûÖGuJ™ÕÄé˜0›!oš J„‘)Ê¿œ9ªîq^NˆŸñ RMÇ(_¶t»cŵïòˆ±¡{„Õ:1îÈ‘¢Éé~v^ 5ÈÜd†y%š#!ÑÚÏ8Ô<ºSYT¿Ëˆ¹Á›ÝPìô­…$=Æ4V>€@ášwÉE-EµÑ©èšDxœÝÑ4á sŒðBÌ|Йòx´Áñ7^uW¶(Š‡FKˆ›É/¸9YH$5+DEúCˆ`›HÆ:ù±q7YRcþ›‚“ÌFkÒE§ŸÉ¹(j û4’‹JØT[ÇÇê=êpŪ|Ù¼øxféªYÌ?*|¸œLt '+Ì5:ïK_›ŸvÎ$èŽù¡ôSî¬uŽ*Ge©Ê’°× b„{cÃiüEQš?y_\V0ºYu¼e¨3MWÇ¡ÂØ÷Õ¯¥Ç }†uÀ)Õ©cwPûy¬¦p·Ú-‡k.fÍáÚÈ7N·bƵ3ëXõ«ƒÙ-…Ïê‹%}#4¨CTq1»y±7¶¨n‡Ô„½‘Ç.L}înoVÿ¡½ \B;ÛÑÛì¥Ýœ¦h+n²q/«ÄCˆIpò}›Q (¦Ù8yö™ûWÉÓI³º!â2hq<âpt6ºL82ôQà8K\¾û4fv1ƵRAˆôm™#ùd1-L šHÕø” æ=ù:<„ Ô§ž&•Tù«öœöœ€éVÍ®8ŽP°‡2ßÚ}•·mÓRJXçÿAÆDãõ ÏÇ Çsîƨ¹sRaq Qƒ†Ó¤ÄÖ‰¤Íw¥§|"`Á¯ò”rÅD–Ù«Ö¿Þ^ý_ÿMÅâ{endstream endobj 71 0 obj 2699 endobj 74 0 obj <> stream xœX]ã¶}Ÿ_A¤«Im-II”ˆÅ>¤ƒ¦-°idZˆ‹G¢mueÉ+É3ãùKù½—_’5Þiv°˜±E‘÷ãÜsÏågBcF(þ¸ßåᆒ¿ÀÿÝÍçfž÷«–âÉÔž›g. ŸåÂ×vTu'¨œË#¨¡â¨ )cÚs  Pød˜Rˆ‚±¬àkvãõS×Wä¡;µ•êÏÆ5)b1ƒ°,I®ÃÓ@æúÄWnTv‡C×.L–±'2à€¥¿…!j|ˆQ‚Øè¶\ø,Â,fÂÑ‚N#- ä ÎÆ_àÔÀ¯à»Èç¯OÀ€Y¹[XÓ9Õ^¹ô1‡]sêØÖ¥qû–tUe{DB©A·)H!™­±—±ósJ {Yàcþ÷­cÀËi&ÑSóÔ£ìi¯ÁÅyj'欫 ²t¬Ýä¨*W·§^¦ú@=gþ¤ øÎEœÔ[ÒêÒz–R€c“o,Í=ýëa§VÕhvÚp%R~_ïöãd˜qœ #«zÐ%´pmäûí¨ï{µld> stream xœµWÛnÜ6}߯$Ù$CRJ ú¦h ´5Їº0h‰k+Õe#JqE¿§oùÆκí:nÓ‡À0lˆÔÌœ™3gFï€3œ~Æ¿y½áð=þ^oÞm„;ñO^Ã×ç›g?+zp¾ÛøH¥˜•Ep^oθ̒TÅp~»Ù Ïßâ{"ƒŒÞ „JXAˆ/è‰î={¯Úºnøºjó?à“WºÓ}Ù6ž<#oþ°Ù >ƒ??ÚHÁ(–b³µ}7ä=>§›ëƒ¼­÷•ùùo‚ÿþ‚Žƒ£ó¿àR¸ÇÂÛŸ =ºÇŽ¾ßüäã¼ntm._¬@<,Ì®lÌt$àb;þË.ÅÅcô->yQ®/Jwq´ˆ |£Ëö]{Ýéso^¾þñ’LÉ ãqÑ!VŠò —[|¢õÇS¸«J¾ÔÇ|èM×zùe¸êÚ¡§ ÐGÙô`uí¬9€Sx‚å¿ñßY_aÈ»ªÕýÅcÁÎàø¸\söbî.·Éü£;©%Ô%zŽ£;鱚°{ #™‚dqû/°rŸ¥¹üOrŠc{—cñã~ÜÓùpÉ|ê:Ó˜d~R h iÂ@¦,Å{sÝDí'²0Œ3‡V[¸5Uø·¿1ð±2s+úו`!!@ ,?ö¡äxåùi#‹ˆÅè\±U+?,›¼ v2g7´/Öµ_¸_ïM4gQ*¤¹sŸZ{’Û0eSâž|*­Q<“E*LÂÐÙªõ®°ß1ú²21± UyÕéîú›Üöp{Sæ7Ð’2èFà=‹‚iwhß›®:ÀNÛ¾,Êvp‘)5¶ûÌ“I¤_þøËkx5ùì,så Â&X^a¢D&3Ún@¸Ðî໶ë;Œ@)Ðû½îLÓ£ã½éê²Ç°mÙNć٧`J‘Œ•›;>¢Ldq(œ“È“l‰ù&g*æIì/nP`0vC“;_˜ L!F×ö§„d–-iØbzOܤ“žÆq+çåŒÚ§Â|lÐB›]è¦Å£Î¹:£>+«j@Nê‹wuðm×aÅÌM„¤Dü­\†CÁYÌ3ïO²Xñ<¼nÜ@ Y4熇OF¾¡Q=<;Îhœ2…7?3§ÉÜýEiݘ"Ø IVns¢ IÛB…ð\§r²P~wì*eñ‚…Ë„“²ZZÀWfvÙÁAp9'‡s•zð¿–ýÍHÐÙ ˆ²õßÛ¶6k6SíÐI®kœ¯›²¹†Û¶³Ž"•èhnE+‘ˆ%Ï Fv«»ßqé “Œe|Ng¡ Eè]×ÆZ}m^À-†ŽèÙ2ú&.ø°ôŠ§ú {Ⱦ颔%-!¹)†Î“3Ä)‘LXëÔ \U£t¬D™'*Š”‡Bü@$0j¹=ØÞÔ£P/ ?–X‹™>"ÌÒhìL-ñ-\}æx Xïá:ïZk猬¹lÏü.‰Ÿd~̶`BrO`ì‚Ûv¨ b|YïÑNIÔê[¿zÇøZ83D%ñÈF žÙQn Ôë7o»Îä4oð!Vz¥³oQ…‰¹UÛþAeÅDŒ &w3ý¥œgáÚƒK|œ¡<ˆd*¸Z þ³Éaˆ5^ê-ã„Çcµ_=}º´"ÝM¨­åt5”È Ñ^ÑN¥•b¬G~ Aóy5ñøâ˜ñ¥ ”Ð4É(â«šý‡YB/mAiʱÿG­8K²…+H”™+Ö¼ðš…Ôûî\¨h}rÛÁ4‘ÉÓ‡Üì{@xîi0ê=Ì*9ÚÃsÆù>‚ö$^ œ,d³t§ë/•¯‹E±9ë)qâ?|óËÖI¯/Z$¸šÞSQ–xÍýîîH͘šÝ$*LÃIUÛ[ëDrìy7”ŒÍ5VAæ7Ï}›§‘[Fýz24…W”dœÓŒ ]'’8–k{ºüï…×LÄe§õ„èï.ü;üJõ_[Q8çiù Ë÷¸ѯ_0üz÷ãK濶MS”;Üèÿë;'|Ñ}s£¶\— j"_Ù[×}¸Sì‡Þ©ü¾Ò¹_Óq›…€Zo Ê3Ïí7ºCý—ò D–Åt÷ÛóÍOøóÈ৺endstream endobj 79 0 obj 1798 endobj 82 0 obj <> stream xœÝYÙrÜÆ}Ÿ¯èHÉD«tˆR®²i9a"[ŠD§’«TàL Œ°bªòKü­üFn¯Xf¸ÈÉK"•Š"Ý}—sÏ=·ç"˜"¢ÿºŸ«í‚ ßÿ‹Å§5Ÿ ÷cµEßž.^¾OôƒÓÍÂ. ˆ% f(Ébtº]D–É4èôz±ŒMQôüôgXG3”éuM$ŽQÄaÁNÒï=-6kµAõ›1‡íˆþ,ÒÿÓ£«]Ù·úŸ~CŸÿf±üçóg‹È¼Qóþò©ªÖÅÆçÍŒXŠÁF07çaš¦©L̾y‡ºK…`ª7¨èZtüÕW¨î»]ßaså8%ܚð„gÖ¢ÓKܲ1Žy&3û.q–OK1Í2|“‡| —SBb¿\$Ô,)‹Jµ(oÚÔñà\Uê¶ÓNÔåZ5Ú c~œ`ID0)£1q§®êí®(Mj"žeðZD™1 r(h"’Ô¼ªš΀P­kTÕjÔª¾¨ŠÌýc±sÎ&U}îTS¡'ÇOfŽûÖÛç©Ï•z0é|¦4¡6à FïÞ¿=}{ú·w¯?L÷cÚòÄ®2å®8©Ð7?~8AÇ(‡üBDŽPnz‹3‰gÊ®©»º»Ù©éÖ1ÃÜG/á1‹-¬×ª]5ŹjMðWy ¹@­úÔ«j¥tr´é«UWÔ•ÅQJ1÷‰œ0Ûà¢wþàÖADÊ‘LðŒº„åjó+å2Æq©t£˜È$ØvÞ_\h{ºb ȸA—ªÜéßWy·ºDªijÈhQ»€á€±ŒQ¢ëØž7õª5Ž@­S¼ñ½õã,ã>ÀÑ»id©À.`¼`ÜžZïtÈÀ¸¶kúU×Nó%¥_Íh&¸Í±Õl÷Äç v'”Úrïj¤¶E‡L²ô“{§ÌÑ$DW—~‰ ˆõ()ÀÂebd à“Ý¢µº­Ô<0Ï‘=nÝC_¡v§VÅ­ŽìÍÑÔ5ÇšíõÖ\„´\³jTÞib˜nÍS_–ËÛr¯h™'Û%ÞÏЀýXz`¸C±„E\ª‡HòH*Ð0êÔ,pøqfÍøœ¬ÜGöìaKJêû·ü~¶%óŸÄ„qc6Fo+³À8Ô#éPâ x¸É« ËÅ*ÕU^uCˆX4QEC)ÁëP–Ucê*¢œb1Ô³’ÙôÛêzÈ¡ïn¡$’G—t2_±n¿Q ‰bã“$¥6Ôyyß´Ž^Uûp–Ÿºì¢'&âOîM*Åq†-›|Ö²+ŸG8ÎÆäÓs~gÎùzzèá}ðFÚš<{~4£t]@‚˺þÝ6mç›7—cuÇ¡¨“QVV}Ó( ¢uŠ­«›OÖì1gâô±À®|  –c­HDF˜‹ÝeßZkoAti3FÐ7 ]ÕU—GÌðŠgý0hºè%Τ#Ã}ZKñ Â#B¸Bj.Û89_O³œ esÝîËšUÚb»+o†ôŠ-0ÐûE¿…8TAŒ± ¡ùR 7¢tõ¬AäÒŒ~)93,5ŒNl¢cÆÊÝt…6ùª› HϸHÒAÕ€¨aÜÖ½Xk(e±s:«nt¥Úžyþ Þí.ëþÂ`v¹”å A¡¸™cÛ—]±+Õdµ™c –Ö¥‘MkµS•ÕfL€&"éÐÓ™Ó¸UÊX2±qÈÊw:@ÂÚ-:ŸsÅ!° Œ¯¸À žr vÍ¿[‘µHkû©êkøy¡Íq@s R”KÊ-1ø„ùK¿äIL–GRÔ³M ) DlŠ ÒLCÊëJÝ´SÚC<`ª}e4ŠúœÒÕÑœ  W¯@—e}Q@ÝΦ¡8´ïq/uëe`Š¢êÔ…jîZ¬ÍÎMÒÒù‡©}£ [yh·lx èè˜YxjqpÞw>[H6D’­}nó­v\ï`‡/=ÅùÎ¤ë ‚kãõ$¯¾RÍ<@ä2“Þ×ÕeÞ@¡ÍnÇå|µBSów©>ÏgÊ@F¼;e³QÆæíd]÷ç¥B·MÃP°c -͉PÃÈ¢#E¢_—ºvYÀ+B¥7lKP3ëÀtƒÃÐt뱧ÿåíÉw³êIüœMõí µÕsí‚Päãüì á-X0—´Ü9‰y*¼À7ˆŸ&ä¾xSAƒ’³Gî[/ Á8êigsS°Ñpß 0 Ú}«VyߪÙÌ&aHýu‚ &Õº¥ôü]›IÕÊÖVÙrh˜ÛÛvÖ‚Ž ÅA°&wFWè ÕÄ]§@ó¾ ?Ï@]Ó0ÁIBŠ½r lß©šŒ áÆŽ3˜4õÒÙóéÐ6)º1'ÂÉÑS}#P—e}m®armP{Y_[Í}6S&âwŽÆÒªÏ2ffr6PÜ}3ꈿu("áºÆfät27âض‘èã—þ™‚¤µêøãf7&-ýÙ›Åò;ýx„ßg‹åkýÈý2Á²çâÂ\IJp£ßÌø÷ÐuhœHÇ·gKŠµÚä IΞϫ›š«„‰0NŒ[ÁòD?òÍnlpʃÁ$w˜öÜÒ±Á`7(Ë?Ž¶~ÁÌiÒFMç›óøH}SíÏ<[ÎÎä.êëÅ·`wÅ÷^O£“Ù:?o.÷cϸÀAô-ßh¯GV/ßÿ§yo£ Ò4òÁ„¶?o@$öÚgù<›Á³p€.áyGàqhöâÛÚ%|tÐßÈOšøP”P:ì¿Q 4Œ>˜¦yËyVXÃgÚ&l¸kù/ý 9þÅ}¡ò?õ›u9¢\þ_¹5ꨜgæ–KÄöŠI,ßsB5ŠÚßCïI©áôмOµ¹äÌ µWºmÝèJåú.r4µ6§z&4ãpñãDÝ~9 ¢£ç¤è›»4ÝN eì¾âQQ¸{b$q=þh˜ƒö®dþœ/“2tKí»öϾÆI„¾ªK¼è2&îŽÞ^I@›¶ÊÔ3ñpCša>Dæª.ÖsQê7%›Nˆ5²²ÊøÛ¨®o*t•—=|¶çqÿr`¸ Nb6“¸oT {ÂÛßÙ§I+|cžÜ=Ñ ÏïšÁÂ7BÃ<3×9‚Vð*G8»ïáÕÕÌXÌha0ÒÏ É;Ž‡ßÂÂÃ×®X?‰=í?Ò<ê¦en‰%wøÄ &SrOÇ5zÛˆ¥¿bå¨X2}«IæyŽ³pGñCÞ€pgìÑ,zåëÓÅŸáï¿ògËendstream endobj 83 0 obj 2791 endobj 86 0 obj <> stream xœµYÉŽÜȽ÷W¤OSº¨\¸dŽàƒFöflÙj÷!°ÈdG,²Ä¥—ù(}£#r+’½Z€!L÷tU®/^D¼ˆüJhÄÅîwq8£ä/ðßÕÙ×3f¾!îWq ?]œ½ùG†\Tgv#<Ë"N2“‹ÃÙ–F”«Tf ¹¸9Ûl Sdûêâ7˜§Ü¼-“&lEJ.Jø+Êb•23üg ;8l¢¢v4J2EciæÍБ›¾õ@†£.ê¼!Ew8èvHÝ’cßÝxwÔä[C®ê뺽"ã^“F·WãžtÑy±·›14®d”Úí6¸\×.O#Ü&e©9Í®éŠ/oÉÍ^›ñ[!9^q7RÆ<¶xÀAô½ÓåÎRIÄ(á²1‹©]žäýÕd®v¾D2U–Ù)€¼b*Éê>’i¤Ââ‰T26{—"3èûHÈõHŠ¼%õ0Lšää&ï[„ò ‡!¿Ò¤®ÌYÊ#áol8e"¶;Ô°ÐÏ]?ö¸L{œF»Ï7¼9)ëªÒ=læ Su=l{ÐkË0ɧ,#£Ä}m¬™cqžšcáOøŠEq–8K|‚=Æ®AŽº;6Ú²‰t€DS×yS—áà€ò¸ÏG\• 8 u‡a`(ÀÒÚ)Ük}«Á\+_݉Á¡™âOÜj+TêQåQÆU'ÂEäƒ_¤QJýy #”bî@S±?a®Ò€=ëvìÈ ¯u¶Fâ*,ap«Ô¯Âd*œS’¼--ŒuI`îûsëJ]^꾚š’h4ƒ§u­ÆF[zHÅ4óWa‘ˆ“Ì,>óBãš°à žDvw¤ŸZtš¥ó2)¢XÉ—9ï6fòRD &,€ãM]èsò­FrS눖J±6ÛX­ÊChU2œ›m[³–¹Z¯‡©Ѩ!laÈ"yYÖ0p(ħ·fÆl\£Çå­O¿çÆR`j’Ú3–zÔý¡n5¹ÜvÞ!ò¦ÁØŽ1§›F 6ï Å/_™£ýR@«u |FÏ| žüÏáF˜gá†&Žg@3Œªà~EŽ Yxg@Á—ð³ê»Cð×aÚÁ€«>? &öRMÞ¾ A#ɘg#¤ŠØ±1ÇU ]N½q«ÝÚ«¶"IÌT‡ìFß–`Åår§RØÅwgÙ‘¶‰¾Å»Ôcs‡ó ßųÜ%’4eÉ,&Vwp.“ðmAh´®mîÈ1ó&ƒc—EÓK¶&Ÿ®c1fBà^sbÄ‚q»ÛåæCeì|ÂŽ©P·×Ý=<eXy êm ›1È›ÎóÂÁ¬Ç,yžÆ³IÏåeFÒdEfó&†ŸQŸAW$œo9ãÖˆÜsk3]–ê¼EQ™XTzðôLA¤šÚøƒ¤‰âùˆˆùqÜûlr°F³¡ó÷SãµÖÒš‹SE—¯L°„l-˜¸JÆ:®KYŒaÊ Ñ‡â÷Ž/µ Û˜ €-=‰(ˆð”f2 cxôÆÃ?d¤Ú p:I–²ŒÙøÌœÚùÞÔâ…Ëy0­=Ç,¬-“%oÀ€½¡ª3Ðà¢ÜrâN÷eЖ]CÝ@&_Ý%È‘Q•Z"mAÊLéœéB~ùÊ8”JQvfÞTŠSËnr‰Ì¦FÈ'[qˆÁî"&AÚ$‡$¸Ò-( ”ïÑ÷ùµ&L¨®ð^u qz¨‡…‘ f&α³HйˆdÌ—^žˆ6˜ÃC U!îð(aÔQ‰lˆ&a€?<ºE&UࢾÍäú<`¬l€„ЊˆlÖ5xi3ܘXÇ¿ Á?«®»ÜTÀü`T[â/5©.7·ö›²›v Þ<È(…êœÜš±äöìÜY Ì0Ì©È{jJéT;&e4ä:mI¯Š¶"²’è×wþú™|^%¦~ÜÆZ"è“€ÇÒëAÈ›×äS -yý%%©>_n._½]¥qð€øt H‰’Æ–a–†bÉB[1…*!h+pAƒœ3¤ùÖÑ9~Ç9‹‚&w*Á NcÎvkcÓÌY(=IHàxbýÞÅÅR‘VB";¹W *ñÓdµ”<Ü€3W¨ÎI_ÔÖå­VHxD—yŒÅ™ÌìªW€m[¡‚ƒ |¨á:ƒIŽ;Ôî£<ÈÜSôã3ò\…òÑ+®hƒ `"|ÝšB¦€“›|ðÓÙjÅæΉ÷™kbxɸs bÖPDì…±9ói@MSj ë ÿ÷+¸X2ä ® ùY QÙÍ’æNÃÔ´yé-pîf­ÌÀ̉c‡7óÅ~²å7ÏNutLEÂ|‘>ß&áuÓÀ/Ï]y aÊ,äk+¬ã,̧£­è'‘P>šonï~_)w…Hϧ@«"ó œt½žòVÞä»uÛX„ì/§E>_UòÆÈ÷“/d”†žµph¨È$“Ì'x™˜Y€€]°¢ÔÈU^CþÂN þ5h«éž  ÛìQÙ¬¡ƒúÂÒ`*œ«*ì=œ”H›Vº;΃p Èã² TÚ”'*KÓµ4@a ©u±¯®ÀÓî‰WöC|'kww/V†ïî‘Ás†ì*à±"ò“Y‚Á±i‡6XʹӚv,¤íÇÕFs… >‡]C»]w4–Äüð`ålJ5‹œÏ…℺¶—o˜Ð9ú¿Q3WJ{m!¼‚¨Ýw&:pšF u§Ž!`¯åÇ0kHêÚ@ãaÌ[¬Ôë ½f…S¨`ÌßócT­ Î8 Õ^EBâü½C 8Ï´”å!ˆ>š4ì»›3ȵó]×Á8ña)ŒY(€Š; $Ò~ôÎ|ðïêã×0ÆЉL”˜«˜.ÖýŸ,f¸ôʬ‚ÏéÃTè–Âj7ûú~=V{©0Bgi’:¨{Pn#æ;ôúu›……~@õù1ž£âY{bhÊ‚ÆíV3AQ„™+»l¹HMLzH­tÓdOk7Øüró§ÏÕG/ ¸pŠÜÅIÈr¶0ÍÛåùܤïÑŽ/8ç?_tN x¨u÷ `¸i‘a#Àµ`|¦ð¶P,zaojY²Sgا]êò) 4™ûøÇÇ(íû¾(g)MÖvŸýùúÖƒûæõ½®~4@ⶌ€ðt—XriÈ5Ã2A·=a9@qjäû£h2*¢—¿LÌáTÂeìp`É„|ndP4ÿ—3¥$Kð9¹¿“´Øe=«¤è½ZŒÅ"ñ!sS÷kÊxÞ¡ÉÍNÒ$U’Ç®ZvB¶Xt½}72ÖÑ£%CPlþÍdV™@€•ß×öF¢D³Ú£4ÚAxXKŽ“ðyÀ¾ñóÓ©B™ñ\±$#9C2IßÔ™°ãÜjûä²zHó­¶Å»_h<I=kÜ"ƶý²Ut^Úà–\¹XãJ³’`c3Ê`]úíüº¾„eX%ÑЕ“¡l ÿr žÏÞ7…LœVB¥mŸ ——«×H%#/ïzá/X蹕€ÛqoŠ\ó"é_"­‡ðÔ„x Z à“fÖãE±×Åÿ2ãªï;tYlØ TµláúHØUcþñ‹c½ã߇ÞÙDZô$|Y&‚OÔøÀ—÷ ÀXV:J,ù©ó'‚N¶mDšI€¨mಀ  ŸÅá’>©ÔWŠ¿æ=P…ós”JpÊŸ/Îþÿþ *¬ƒáendstream endobj 87 0 obj 2937 endobj 90 0 obj <> stream xœXÙŽÛ8}÷W°Ÿâl67mÉÓ,½3˜™F5楀´J¢lvkqH©êÊüâ\’¢6W£På²D]ÞåÜsõL±?ãgÑìú~O»;êî ñ£hÐ_wßþœØ ÕÎ?@KÌP’ ôØ쎖Åi¡ÇënDŒ ãÃão»##,;ò=–»}!ËAKs°·¾ý9Mò§`€Œf§ÎL…XáWN›'8ñ+)æ©Ý– —2ï¥AýY"ÕVnò^u-R=:çÁp§ygÿzk4lLÓÈ%ÀºöVËêíz7.Â^",q›]Óȶ7ÖúU+»¯jQŽ.ºë»þå"ѧZúÈŽct¤Ì™×ò²è×q³‹;ãæ‹ ‘ˆ'”dnéƒj|~o»k-Ë“ÄnwÛ´Ã_á¶ÿ—.U›kU¿¬]|¼Ï…©H‹„ÄÂç£×ʦ¾³™—ÚÕÀe¡«PÞ¢¡µ_ÊmÚE2¥]~ì¥nóz½YDÂ#ÈòÑB’=‚P¥»J`Ð`$‚"çú4¸ºøÔ§bN½ËXĸðhW'3ƺi×Nœ÷ÆåƧd¬Ã3Îú¾ÓnAŠ3Bæ!¨ ±_#?æÍ¥–¤ªMø"Ãi‡T¸ZÇÎ ä;a4ôTѵ}®Zƒ~L?YÌìGš¤/øðÕ&îYäì[Ûÿ+y ºîi_==<¼Um óîÇÄÂ&ó†\L™õÁYÌÛò6w÷`ÿ{ÓBlºØøÎ2ÔW\HõÖ×÷Oû¿¿¯.OïÖ¶¡ÌÉÉÙ=`¯]Œ¶÷+Ðñ/2Ž^qucÎÅíÀ|ú,CÝ»f·/eQçÚñÌz˺ã3á”Ýð\K-mI ¦ÛxÆgdq°ÿK[B í`0P(] éó¶:Ef(ξï\J{Õg„Dã NËÐã²PÆŽwuZs²ß\ü™_žöô0öÁ|‰NËÖXîx‚ÃÚÓ²{²W»‡âDØF·~K¨ÙÌq,Miêùé“2wU4èd“ÿìò˜€1Âxx€'‡o.‹9ºyh ‹Íƒ+ O™¢ûÃZìÏyoGW$–áÙEx®¿ î¹+rf ¶‹ ¤Ì#îáxÍu …HAù3q@i2½eÒEh8½% ÏÀ §ujFÀrœ0⩣dzòŽq4‘.x”¤)_1®EU-OPk é^À’äÝv1¬ã÷†¢o˜†™HÈÖ¢êr,Æ‘g±ãŠÅ€I£QŽ”òS+˃òá[ô€ž_ÖðN¾ˆl‹ÃÖAóàªBpáZbDŸP@.8=¬-€Øb»õAò,„ýSëÉ%+0j%q˜ @­zyMSq˜Šcjߨ~“Û88ýD®ÝÅ 6Ç4¦×ÃV(ø£»UÊ4> stream xœ­YkoãÆýî_1 X[XÌpørh›Ý:éMân$@ 9’Ø¥H-Ö:èÿé·ý=w¤D9ŽSt…,sž÷ž{î¹—÷|ÆéÇ~æ» Î¾ÄÿÍŇ _?aö#ß±×·Ÿ½“ô‡Ûõ…™à3!¥'˜LCv»»Xr‹4NdÄn‹%>[¾¸ý×ÅRðÖAÌn‹ áÅÜO͘nXµÍЗµòØÝâú^Õ4^žä~Œ0œ{BpÉ=žÊ~KC>{ç§ö,"ðü4 ÍèÅòeo¸³ŠØ“öa·WyùIWf„[!än®âl¯w[3‘Ÿ®åÇ^äŽåÇRJs¬²ëÕ±Œ²¶.ë Û©®Ë6Še+ÜŽ•uÞÔ]ÙõªîYžU†Ðº‚'žàñ¸5R cÖ©ƒªsÕi Iêq ]úBßdÝ´33ø¡v£yØÌŽØ'ÞÝ ½œÄØ¥¯Ý±x­òlèÔ©Ié.ú›&Iܾ¾'“HH=îЖ=,Rö«2üÖ³÷us¨T£4kÖ?ìéiÝ7lß6}CßµE|‹H·^’øp¬6ǧJuWX•SY÷À0Uo«çíP(´Tx æ[3‘M9°XHÞ-^7C[«»¬Ûªªb]Þ–ûžõÛ¬´ð‡M¥²ßÛeËÝ°cû¦ëÊU¥ô™qdX~—õeS¿j˜%^B6”Ȫ^{{@FúÇÅb¨û²zqy¾±¨ÈÙòÃü_Ó¤E¾Û³egÿtƒyË㉋Bû÷äO»{Éì®Q+L›Ü´”461§ó=!4½ÿÛšuC¾µ¦€í¢­š#̇G\˜Ýt³(Ÿañ˜§ÆmÍž,Ìc“쾪áBÕjû½š/%ä˧öY¹ÛW¥êf³ƒÀ)àf†ÐÈÍõ½@ú‰AhVðf×·CÞw§àbéß¿ôF°†Âç©hjFÐ 9÷HbH"3³^«z ‘åM¡XHƒ#B/FŽ„F2Œ-!”k˜¯[ÚɆlWn¶à”mVÛ°BåUf5í[ž®®áÖK‹8øÆ,}»´ Äóˆ?tѱnªª9»Ù¨A$îšÖÜ2ð‰ŸÒ‘ŸÔúS^‚îž ‡m‰èzùŠ=‚j?®o~2¡‘Ÿü |ÇBÄñ«WìOøXµ*{ßU—åÀýoà‰|_šËÝânõ°[Á®€ýhÚÎD/Òr¥ü0Š¹ŒI µWuѱÆÐÑ:Û´Ù~kƒ‡ŒŸ«bh5Ñͱž^š:´Û¨?Fû¸£ã#ÀšÍJœ´-Ìy³ý^eíÒ:A§Yµ˜s™øvn®ÎOˆ1fÎŽàR¼A¦Ò«xìÛ¦ímòB†Ü¡‰{QhÙrï›}S5›Ö±G¾[táÛr=7J”zqêÂ<[ågà{Nxì.S¨_¹ “‡±Aýsn1rÅ“Ø· ¾='!9Î~ê Áx n5<vG‰ËS$å‰{ÕõçÖ´“}DTÌC·ÉñV1e]gä6¶RýA)ØþИE: d€u•­ªpȦi ¶UC ÁRæ†9"È—–¡ß|YRúÂè?÷& óT}Ì@ÖêÊ ˜G ™ðà_jF;¨–ô%Ú”HózU=˜ë¸§ë‰É‡&)©J²ÄºA¦±å²ÅÍ7ïnƒ™'¥7­&£$Jgj”UåªÍÚb2Ô>ë:Äñê}j¡ethCÀ¤¤Hjf=¤ïéK‰ã-eH.{žáŽ‡¿9ô€)€nëŽJA:²µ×#šÈ‰‰…ÞþtuHëvøb†>&þG#Æ¢år¦óÓ£ |fÙ¿°^}5+—ƒ±tùÐNm¥¾Óÿº’1 F¶yC e¶©J¾®`zú踒˜šÀf1@k³JF<»ŒŸ®¸no'Y$Ž› gÎá£2p¤NíœÛ³ ™C¸*®Î+[µO Är²Ó˜UvŠ œ²Û!QQí±RTº±ÿ€ç{دnlu§t¶vÉ„S…3Z’(u]mÝ#8Y"õÀÉ®\F‘°Á±jzEÙ‘8)l%–¨ÔDàî¦ôÅd3 Oÿ¸„ä¡€í-çu}Öö(²MSb3ˆ2yà óÀFÕÈ£’ Í™—AâéO¢YÇò%,AÖ)ÔGFŽ¤ ¾ü}FS Cü;/,ÛªüýXñ mK -\¨:WõØÛhŠó%Y)Á‘BÓZŠSk[9R rTF“ZÒ"°t½2”…áXsªã#gqÚÖ”ÒÀÅ×$ªI4Òp8øFõÔ'jöVÂD$5Æ6Ñ¢9+EøH°Ÿ·}ï‹—³i¡Vð»D¯óÿp‰”¡´]¶¯ÀPï¡hèÖ‰N¤Q2ÙÔÊžîL÷üóÖ8ýRÎ 4ÒŘ„ŽR|2M};Ÿ i>–Û‰ZSÀvÝ°{„à áIÙôLvæ:ù„ëpε”ôQâãsᑘId+eäBFÍQâ‚ýÐšœ ç¬4aִ妬'¡a“icÌ3¡ˆ¹÷”¤›R!ˆê4#u/;öóÏóˆ'&6£ŽDÂéªq|TL ßµÿ//O¸<ëëÞ‰¸oVú¡‰í£N|øû5‘{¹TˆË¬Ô6»/aZ’ì1Á\qεŽ6m œÚ:F‘‡ÂwEÑúÈÄÎè$vñ<÷ € Z!Õ¡ï†M7Vñ>Õ<8$b\»2K )q!w®ÕêŠ ·Y’3¸B¥ÑyNÁO´­LÒ±}w\‡#u$G„‹ÄèGn\6CAêEiLz[ZU ’Y3ˆ 2|l¹Ã”P'›6£ŽPÙ—YUþb»U¡œAu¸€M‰pÈØ=êNÓ nQÑèDß›®\Šd0Ò„?nf»aL×{³Ë@=…iìâƒrSÏh+9’!Oýdº0m~€/s²çozî(|©7‹ÓRÃ{èÜ«/éM¯mÎïG^ðLÀÇG#9á5k“µ/²[«î^h´D!TŒK–H°OlNýÜtÏx:¢Ìt‚J¤dþÿCΦϗÎS_*tä@¶Ü 7%ÁÜ–çlÄÞ …ßBu(*ÁLSÄ"ŠÞLÃ[mÛ´/O:ãÙº‡£þöùíçónþ¨Ú¸‡a`­*ÓºKƒ0S ’â&˜AµSkþd ‹ÞÒ>&Ñ&ìÔÔ1÷xÈ-CBNLyhÇÝ«$ŠÜRÝh‘;z=ˆ’ušNJðŠsC'éÝ‹YíâÃÏ}ý)½Q¬¤¥7bª…ÙèW<ú¥ÀÈŽÚüㆨÏç£7SzâèFv 1Ý. §6“y¹ìS#ë¤â)ë{P tŸggË€z¸Ny§ã»¨¯(93!®´xD£¯o/þ‰Ÿÿ¢;Cýendstream endobj 95 0 obj 3150 endobj 99 0 obj <> stream xœYÛnÜF}×W4`¥,F »yir÷IqäD-{-åÛ€)N†k9!9’g?*@þ$Ÿ´§úF%%Þ…‘È°šÕÝU§Nªþ•…g!ý±?ËÍQȾÅ·G¿qýf”öõõÑWo$ýÃõêÈ|À™2Læ1»Þ†A(ò4“ »¾?:9eB°Ó/¯ÿ}tʳËN£”]/x¦!}5—í=ÖÅ@«¾z“[ë1R˜ÇÚ“F uuc~í6i›_‡AžòHdÚV»Z©®g}»ëJÅVmwhTz£8gÎó$âú³å¡}.ƒÄ¬äOÓPèuÕЫzÅÞ=SŸ¶uQ5jɪçWæ{î¶âaäöU³TŸíGQ ½ý8RÛÿ­Vl£š¡jÉnqÓÞ©w_.ؽ6~‰ra®D©»6Î¢Ê -+wÝPTõáµÓìÏ})‚Ìù2ÜÅå¸g>Ìo•ºK…0i¶Vån€¯çLS·)¬Ê8Æ…ÇǬWÝ]UªÛªn]l{VW›j¨š[Vé;¨Í¶n÷Jõ¬]±³ë¿]³¢Y²¯U][$ɧ°~ ÀIòħl;õO2R«¢Óq!—tð)ë‡ç„Ébµ*ª®_°NýºSý0]5»¯ˆr€öé( ‡ ]`~™Ù_ž À ñBÔlĤ84çÌöúÕÕÕÅ×/ÎÙùÏ×ç—W¯.¯fqIpÉ&Èþ3s¾zÿ MâÏDô4t2 c¹¾‚·«ßàì²mà"ã™q(¤_swpÂ}§úíõ…D!·NŠž‡©‰4»Ð¦8²0ôÉš¦™p îÛ]½d7Š5€«VþÓM€þN1}L}÷SAx…AŸqf²Û¢ï‘8úkw·ë…Æ Ì>o»¡+š9–E¢I¼»-ºb£Õú,ñÇŽC¥ÖcæDd±¯©%}ƒ C¹å‘ #noYôóã Ì¥uîÉKµn[â¦\pÒ>`?4 ´a×`×z¿ÐÂ^¡ðÛ‚©¸S¯îTWÔp2«7"£ Áê‘BbîÖ“ë·Ý«e›â£>Oš |äò,2n&›=kaõž!0-"uSëO—-ÑájW×ìV5t€jØkœ8ªô8ÁÖÖA¯ ТHbMèÙH†q¥,RûŽµÂ{4×wŸLZ+ÌMa`‡rÊ®ùH„(pUÝ6&ÔÓ}CÇœð:ç‡8ñüàJшî¿]¶;¸ïQ ë\&S™9ÖóƒüÁ6ÕízXPÅCîdh@ܵõ¨ÍfËê®rµ8’É]“$”™¥ƒ¶ÑiƒP„PŠ ªFÚ‚ÕEw‹ÈÌ(O¥9Ëë®Úa¿µ0¦€v”ZúfU?¨¦Ü³r­Ê½ÓQTnˆ1mZ0C4ºÒXcªfbÃz­‡Ž…Ïì™ÀÀS„§#Âõ¡N-o“ð9(j€›®>uéTF±l;ÒÕ:@z'”GÊgb  iY•…–¡÷k*ðO€"ÙmQøHmèĦÝ_˜öU.Í-z6„Ž¡!HIjBÅÒäÆf·¹"·û]¹Í[¢ZWÔµ©wÇG`ª õ` ã4Îl4q>¬ÛƒANð\æTjÚÊÁ®ª¦4Q™ÖZ:x%à¡1$™#ù„@3ÁEfîzèÿÑvä w'V€±]$ŽJ5Km7íMß‚KàøŽ d™¿§ŒxîÐr¯4]IÙ Ù©Ug°U×n  é ,¬{Ò“²êÕ#8OdÊ¥1?9#ŽØÞÏUšŽìÏj?rœ€|V„t5Õ­hö`âø2œ8êa4SÏr¢ž)rGsõ¢"§ßA+vÆh&!èúëåÂ5æxÔÄŒCnæV>Ù2@²Õ®Ã_:/ÅÈ„=(T‘ömF×p3öžN,Ñ•ù¬Ö.$]¬„×½e§ÛL#ºOr (ú¾ê×t‘m×ÞUK5ågœg²ÑìAÁî5yQ §<2DdÙ›óççoÎ/ŸÏž “½8:yËߣ—ÉH$^1‡nw†CŽ »Ô:§¿¤eÐwßvÅfC{*½+ÀðÏ_½¹~sv¹˜a)óO\pc¶þ ãfja>›¦ã(å/š~¨†Ý€*y‰ºóKÛ}Äß~Y0è‚̶S©žp»mÝ®ììòêBc$›´1d>ÎG ÿù©·uÊ%á=š<¼ï¹\øGÂ4”"ú+÷ÑÜåb¢à¯ö=ähÿ„[M"ÌÜJbÙ%ð³¯Ï_ž-¼†žÂÖJP2ò€}Ó+'~’æ߷qWÙ‚ýMH#±eô@dÖO|=éƒýÏÿíƒ?÷ÂìÙH_?Ü>Ör»aáC´±?A“Õ·"¤¦7ùÿÑÄÂ` Mcäpú¨÷6~—Tý"(Xmé‡Ë‹ŸÙ5ª»Zƒáã3ï0ÕëäáˆV>öÌÁ^Í®¨çžÌÑÉ3¥4‘ylãG¯®ôâŠ@Ü´PE-ÑðÄ5\dãV¸¨wÍ5êìÚ°ñØþq7daçËŠaA+ùô%ÈsÿÒøc[£j3îœ7Ñca%¡‘Bo“÷ì{½$â=,O’,±£’ï‘è I+èr~°o»¶'¹ýáÃ7ÔQ\™¹>G*Å¡„ˆPE2[äVp$Í®€&Wíj¸§q×͞ת„Ö‚(Çšª^Ïú—èôÜg( »SëLwÊ$övI’¤±òýìÙËâyx…3ÒÓ.…,µMõ TàKh`S’”Ún‡Ñïôf¨O$Atèð,4Î|›¾gWÆáˆû— Tf©ÜEÀž«z‰î ³Sqðô¦ d¹{ (F?©ª¹Qh:ŠË{ýˆ&€ã¶UÇÇþh|­‡ÏG}©q5 ò‡¦út/”ÖÿáÁð!ߺ)c˜…áÅÅLcÉÉÃ{(\C±`ßµõ°`o 2¬ƒ†ÛO¨T÷ŽØ8z÷¥ñq&ôœì1Ë÷ðÈ“Ï"‡ v·Ÿôó›€}‡ÌHÕË€½€f+×ÝÞú±¾Eöë KDööœÆþO5£“_hµµÜHp]ͱ<²d,8zºw¯kêG)O‘CÔæÂ+ÔøЯò³coþîäû:<ªÎ±\ÊßyfŠ5ÂÓDôÞúŠ_仚¿Z~~}ô/üù/ãìæ—endstream endobj 100 0 obj 3764 endobj 103 0 obj <> stream xœ•WÛnãF|÷Wô›=ˆÔÛW²™}Ò(ãÉ&öÈ+i6Yd-µ-.xQx±Gù¨þÃTw“”í±ƒ C6Õ—sêÔ©:ü0Ê s?ýç¦8aä=~oO~;áþÒl òv}òeì¬oNÂNDSAâD‘uq2e”‰$2±&ëû“³)’L߬ÿw2LcÙTFd½ÅÉÔ–ø5¿˜Ï䊺5RRΘÁ©n ãÒ/!3JΫ/|ºu:Diešï(ù>Íó IË-ù@É%«Í®>ØzB~ýu½³n« ßøèµ ,IÂ1gW‹åzø:d'M†;Ž ±^¦íÎi›mÒœ¬ºëºêÚ¬´ä"»®Óú09= §$F5îï˜Í/=Òh=åÂ=\*b‰ 9¬ë´l(q· øꦽOë>lÓŸ˜õª§ÇT‡/žÕàÓÙBäIl>½™ýžbƒzà"ò`" 8§\Ó¯K“|&«¯KÃh%qÜç”üPíʦ*Î3rUÕmz[2¯Š}–Ûú[ð«úà sU§Àg•%‰»B$ wÄè\0Éà Yù UÔ&á#O˜à}¼óª¼±µ-7–,í¦ª·¤º ˜sÇÑs©ü”“œg7íŽÌʲCQQ%²:ûªÉº‚T%ÎÊM¶ÏmƒÃð_u[§E‘•·>æ(¦lˆçr¦U‚¾HËÛ.½µÍÓ*©ˆš—÷;”q$t@6È…[oªÚá7í£—GƸꎵÝ;úÝ‚0›hˆ?…:‡Ò }¬«¦&f!¶_8ûLÞ†º**SGâHÎ ‘Ÿ(ùÑÖev»KK_<´Ø%%ˬÅuvò¬(ÒÐ1-`"…ëP}2ŒÜˆÍä)6\2*ÇP8¹ }q…š:ÒLCƒ»C‚’ ÌK9òswe<ðå« Ýrœ0`=ð1-F…y5ýÈÕÕ¨ã.ðw³WtdRb„áâåäMHÞpj˜èwHª#¦)È Ü¹L‘+ÕLä9{·Í¿þšâEäT³häË}~»`‹=o¡#Ñ·/0ÃòUÚ•[[7N$.ÿõa±"Nv>6¶>mÈû.ÛzIXÛÍ®ô꺴{ Y-.ˆ‘p¥Å1®8}>ÉñdÐ9@;‰[šÖ¾ñПXù­˜°„Àû6+²ßCÇ]¤×U¶Ð)Цå“ev‡˜³öà‹>ÒxhwAUÄeÔ°Ã/Süƒp'ghôj9ë™+œ¢¾Æ]ùjª„E¢¯ó{ñ°ý\ÃÆÈlý‡_y‘zä±i=øÌ(;Õß}Ùã'¥Oý‡Ë„Š¿k@hX5xÔɃÄÈУ Ÿõ¯1PŸáâ=ñ£þd,}bñ3_p‚Ð÷¡¶añÚ6­“ðÔS×zâçUê$tº¯²²%³:kw… ®ô­cäsóÊ £F‰Æ=]½Mx¥´w6¯öÓÑ}äcýf&2 ­T »]XOG‹'Þ?*Ð2/RaBì–:5›W÷Ö©ÄÑð®`øà n(1¯O¿"šð…H Í¿j1÷4mÝ퟉ J(O’hܤƽ ~óÍÿ¥ƒJ£—sc¿Î¶Û SÆô'Ûäöà•0Œ0GvN…ðP 5§J~ÿ~oËmö…̾u(l ·Í1XÖ-æ®i[Mçhžr[ÕÏ<û±Pz"Ò‹YKܱ®ˆí.kÈ=H„ü&ä­„¾J}wµ»Ô¯õ:’HÈØ(öLcééçÏóêÞásbÁ¹j†0I[ÁN ï^— [Ð~ÀæÆ:Jc|&P²(²¶µ^¬uLÕ±KTdà¨áúáRrVÞeØà®Ìœº¤kB–6«‰ý’Af!ÒT.×"=ø™Hk*ÉÉÇÇà ·É»­ÃÂø‡tûmê.¸r\ ×Oǘ$`„D.ßf„9íËIƒ2³¡êŽwÜ1¯ ¯Ó¼%oó. §þ\yì'T‹|K–U㺟éöÍ©[å&Ë~6_uÀ‚|§ÃW¾‰1H„ýý¾ y?#Gý ¡4†˜^ƒÍÍç<ú'9ŸýL†§h-<5ûÜûÑEhoƒWƒ0C\-—/fƒªxɘWõÞ–sóÓc^Ê›MŸzÞ×wñ}‘cþtqwµˆäƒVZW;¿êqY¦{ä¼Ù†:Üゆ…zqóLcŽ @Sü²Â_פêADö£<Ѓ±çyŠ‚ÜmiU¤„Ž”Ùñ&ñá¿h>¸è '>p™€íªážcä8 #^©TÿÂV#~!œZ$Ú1àÝúäßøù`˜ØŠendstream endobj 104 0 obj 1772 endobj 107 0 obj <> stream xœYmsÛ¸þî_™~8¥'1d¾ùçN3‰‹}×vêNK‘Í EêH*Žü£2ÓØ]¼‘¢,§ãñÈìb_ž}vù'¡#ìg¾9£ägø½?ûóŒé'Ä~äòÓíÙëO IÉíú̬g$D¦‚ÜnÎ,ˆD,áïdzÙ;~AîfðüîÕ«Û?Îx0Jì¸-Θƒ0Šõ:òÛÕò︂ÅISfVЀF‚Qf×Üì»^mÈï¸.Ô˸=)ˆ¢…fÕÝ ŸÇAbž¡:1M:ä|»UuQ~µGpJ/JH;u~ÂIgˆ8I¬}•0ãkØóá¾æ<`£½2åN9o‹…ˆ¢@€1"Á…³«ó—øàõ'‰Æã†1YÀñÐ¥pIsΚçä¿ä¢©¿¨¶'o³šHIú†\¦%?þhŽ²nZè£Ð((éæW×o–7nÉ‘4ȤY„ç‡j?ôÕfÿ4ߧöû(“Æ<Òû›m_65 ‚`r¹Ä™hö¯çLný­RÃ1îbà‰áno/o.>-?Þ.¯¯O®Q9½D“S=BÆ& rcànlá®Ùµ¹"yS(RÖ‡"˜ nT¶›Iî…È(…ÃPÈcÙ?:Û¨Ž`hÖ÷¸KƤÌë$9uFðBÙ 5`iâäë‰ÔÈI5ít'ĦÛöîÔ6ÄRr™jé:¾îf&Âî^9kàe­b‹EÎÐ4H`cjâ «íÚVÕ=)ÊVå}Óî篤u™7 ¦žŠÜ#8œ2&UºÝªëË~׫‚¬A;ö­ÎªÉÉiâñŒÂ쟲“=/ 8†¼V& K}88&õhNŒCŒÏIÝø˜Ò¶ËZ¥c ˜O"ŠÉHöRRzý[•Æ_p)…ƒe+{Ý6ÒõY]dmÜîzÿǶìA+€’zxÜìzx*È#æÓø]Y©iȻˇƒpëýCÖcÀ?‰ü¿œ6}ÁMÞ»Om;@*™D«÷Ùge7<>Ü8’¡tq¿RdÛ6}Óï·&àç$ëð«b—CÔ­öÄ ÝT)¹J1[LµâÎE"L…Qk®}€Ê¡'É·¶3V_°DŽ±·ñŠØäæ-Äüº©ªæ@Ä*Ó‘‡ì‹ÒéÐÙÉFe5>ͺ#ðâ4qà¡ËÔ»Ô;2¦C›»»{åÙ<^pÎAÁ’GeÍ_[¤ òF ºh6[ˆ ­`ðüAåŸMœ`zçm¹íM¦`È”5)T^Á¿hª6Û“U³«‹nªÌAá[,ùóªÈ…)L…ÿa©Z²¼º½üùò“vÆû럗çïÑnÝ$ÏÜ=µÞ¦Îˆpug›¿ŠŠÕÔÕþ„9 Ò4å/΀BÖžw¨9«õÔ¨/Y[f+S¡@ί¿-?]š0a)*9½¡ÊZx¾~.“ChRdsy)¦”É=BÁBš:ñ­Ýtcï@jcéL]¡6‰†Óq|èé}•uâ˜d`eÀ:\ä½ošÏºRf`¬z‘­º¦‚ê ’ójWh€ÓÀƒ6Ój»ŠêŽK¹)°|Ž_k›…¹çð1Ðo £xš=ia0×.õE*²lKpY·UyùMãëı§SÞ£Zî¥GPyâí¾Ôã m•6£@y¨'­]„êèB@?È!øÙg¨‰šn¢'´q3¯ê¸{â3nT:<–E÷d‹,ñÐX¿…{©BÕ¹šs9Ë(NB‹]3'*¸ ÞŒÌ¡iÈT*]Í&ú'ŽB².¨ÉD@É]U`Ñ<íÁt U‹eðz Í| §ÓôXŒÓÚCy8Õ=Ñ@@uK“ƒ2óör­Ùv–n‹Ý\R‹(¦þ`Ñ0|Ù`¹éI¥2ÈŒLÊ5–i(V…Á}–=ŠiÈbáz?K»|ó9’ƒD›#Ð8Ý /lzn†ƒÑ(Àʘ¦°È¶­ƒ~»¨&êZÞ–T妄d…„ÚÀ3… 93™ ø잦3=‰:¿®ã2ih¸é/Mmxžu ñÂ!°.¥êk¯Z æ¦ç16^ÃC™=ŠŒ-†y7fLŒû:C>«ýcÓÙìÀ/«ãÖ $¤ièÒIßy’PÿGµàWÒ ÛbwÚŽLŠ}vyûš=‚I²Á(ÿÚ¢¾Õªø´¬µ¾ÙuXÆ{kow•úÏy<­‹ãÔŽ#n 6ZÕu:\³VSCpJ—Ý#½mÚ¹ "ÛÄ—Spã”{>¾xŒã‰M}ïC©'ÝsòúÈ]Zí22ëËUY•ýÞéa.¸à1Û]VIÝ°çyÊk²5ßUe¶l&<&¢NãïuT¡Ç¼©±!§†‹óçí=ûhÚ÷T,BkçW7“Â,jÈÁ„Á ‹€¼83Dì(ÚÖ׎4U±èú=ÄÕÅ‘Öfh6Ö;;E‡¥Hb›„:†«&‡”¨T¶ë› 8-?ˆYèñ«]]aTÁ÷ò¹æD}ÿ•ˆPšP `øXAv`¢ˆïcŽßQ»üíùíùœ\ûýüýåÕÅåÜBbø§§hï—7·ó Y¤Gí½•Å¨¯B7ç¿O&pÜ=›©:æeŒóC`ð£·g¡Ap×W]ëvç(ºãy9Ÿó—Ž”nl¹´ä­iËû!Ö%™Ó½„\Ã[|>òâd›%¡-¤o]š€74÷uùp_œÃGÞèõu‹Usg¦±…?ÿl{ÝJí{MÑìVf†J ÷=•‰ r¸‚%vͨŠÆD˶R_‘HÇîʼ#OZ¹'­Û“VíIköä{B½æp!¤,}ùEUû—Í4i‘…Ç,ÜqfÃÙÊF‡!ÝÑÀKŒ ã'nÚøt»?T&NNé'òqáN¸µ,ªÇÄá{G¡ÉÃÐ?_;1,ñz¿5];€DY—}™U:ÅAF&ÃÄäâúÃ7ÈuÇ 1*fÃtXh5„Ôtf½Ô¬c¢ó•@«ÂÕ¶%Ä3´¦¦8Ï]SÇ&Ö<N’׬;T ðƹÆP!ÛW@/„A22§:‘õ!BhhRþc•å/ÚÒ;ûy[ÊQÛËÄPÕ ýg\Úfðfàõfr‘a, ›#fç¼F y}þÓÅëI«à_¨„AQ #¦hiß*5Í·#‰U>0gãns_RLÓ‰‹AgæúýàDÃï™bÓc<2‰”Ç ú ˆ\¥L›`8„¡Æð(úº]Öƒ‡Ç¦Ï¸Ð1“>]•|ûB)Ÿ›Z7¬µ,û²`”ôÔ•+U%=ź?Lðˆ®å7£“€üÚŸª ûœÑ ¯Ê°¨¯à¾ c—Ûÿ÷ñ9…1sÖí+=É¢õ)•‡± 3[#ëV©6Q™k¼!Yž«-ÐvH²5¤+x¬Úmt¨pšé0‡K¥cKl$×¥0%r‹Sܯªpgƒã”$š6dáŽ7êð¿E6¤Vpbþ!•Ã–ÎÄΪÊêÏß©äòÄÀ%€ùYjgÇк[ê|ÔCâÑ}õ€öÕ€±i_zZfH“ȾŒ=ÉVÐ<¤ÞmVªížyÝceÁ¥'‘W›ùhv²Ãø˜"÷x8-B&Œ.7» Óyh[~€œE«aúbÉü¥Á¾üò¾ßãàø¾¼¦C•Fc4¥QìÞ wHUî;|炽¬~Í6iÀ|K3³ÙQS6Œ=La`ôf5FïsjÈ×eC†éiz†38SR> stream xœ•YÝvÛ¸¾÷S ½Ø(»Müm¯EÎQëØ^[Ùì9UOKQÅ5EjIÊŽóPyÆÎ H–›ŸHŽIæ÷›o†סÄÅýîN\òþÝüyB墿Òy¿89½‰HL›u?%¾GÂØ#‹ÝÉ„:¾„ðûãÉèœMÉr×—ïÞ-þ8a±C]׃'ëêq‡û¼|¾œÿŽwÐ r—ª;\Çõ=êR}ÏíS݈ù ïãò6¦%9¾Ï)Ww-Gx=p"u Õ ÜX©CÎö{Q¬³¯ZsÝÈå…,hÕy7DïdxAé¤)Ü ûfhù`¯²‚9´÷l³V9ã t!ø|8ñhìxà–‰á#£IÆÔ¡¾ƒ­–qÈX ”¼ÍvYžT¤)‡â<¯={4™[‚(s˜Å\N•^c²:4Rñ¨5 ®G!•ÚI]v‚$dW®³ïb­„ÆZhÄÒQž­ÎÃÐRÞmÏ%…õ( ¸{tn?ÊÂVòÀòå(-wû,kò˜5Û¡ùß [DcªB3ù°!,U·R·•ßêýï¡ _ÿÙŽCèDw\/ˆ•:ïƤ.Û;eY0ˆº–1¿\Ì>În†‚&ÜᎠú¿ïý8 Ú0Œ.®>ΧgÃÇ=íÐ ¦mÌh¤âôTY²ÊEMvÉY Œ[vW€›VOCùpÜè÷ëçùÍÌŠYÜêGp/檺@Q’THÏEq×lkøŸ uSVpHVz[V üÒÔŽ•ãÌçÒ`,L•ã±{,ɽˆR_e懒eC*‘–wEöMf+È9R%‰]²ÊšÉ.)²ý!Oš¬,ðì*+ê,­Éªu3–¸@M¸q+ßýHD20iL²UšWø•55~Õ¢/QâßàeLZ!:hèp¼/ÅdõvO {䯩m>׳ý¾:fzÄ|ÏSYþ¹kÅn_VIõD’ümJ"ŠMY¥Ä×}% Ð`¼À»¤¤Õc´¸Øg±ÎXò¸·ütˆô½ª"Ö>¶|GöÑb¢,Ö´ÅÔaQ¨Tƒ0ÔÙ7åòê€)—äyùÂô(îÄNtõ€jm w"Ï 4Î7ò:oAÜ£!Õúa”˽ h­‹¶ÅŒó¨…¸ûjmFÛ_îòk€;€7×媃€»ÒLú«uo&jm0Âz`êúÌU°/DAÀñ¤ÎŠ»\L:!å^€Åëg? ùõËŸBQyÄ—*k f‡É=ƒßs1<¢uÝȱ¤ÌûÆ ¡*'”rvy;‡ƒÓ_~Á`WeS6O{ˆÚ¶ß ™5³HÒ-|ïUkèTb^`:Ì+:m†:Å-vÂéV`Œ^wn5'h¯Xçè?Ù YbÓÓAuÁ¦@²®!šm%IÞº¸¦Eò0¤ú^²©Ê D:©ÖÊ-cò(CÖóbÒÈÜ]‰»¬(P68ÝB,€“RÀÏaúÎî’{A€hìÊb²ÊËôžìÄn%ªšäeyOò .ß“œ˜¾û:Ü׋z€µQ¿ãV»²ƒ¶ Ô¦Mú›™Í XßL¨¢js(ReFTbUk¡E ÜŽÜ0àݺU|¸úüþbF®ofÓùíüêÒ®6f¯Ÿ¹¬üµkòÆrsÓ÷܈Ðä‘iY|¯v5’*`ÀÖo»UÑË*Œ®_È~sPÊ©¯;?;ÖY?dµœs‡­52(9XöÀ³íõ6i~<Ø¡~ôÌ'4b뛬94@!îêÆ\oqÿ²lÐäyCþjm˜¨’Ñì÷ÅìæÒæ¾ÛíÞ8gžî¦’-¯NŒ8á\Ô¸5Hvá¹ ÀûCVj(uäÔêl0&túëJ ñòmÿštg¼N€Þª£¦;ÀŸ¤ÁÆ× ~ÒAĦFG8#[`Íû ëC¾ºFm˜£S´òIr'e³?è‘À¢À‹U}-`P‘• OA«‡ò^HÞ Ôd¿ÇUZ%“2ŽÚÄþÿMjáô0äžZˆþ”+¬&qÖw‡\†)b€f‚fBÍmpÞIÖ½ub« ´Á0þAm‚nÌb³ÜOv«\ÓM?åÖ’'êF‡€³ õb˜&Úû…‰çF]âR ýb§—68Xp="ji’ÎYót·‘½. ©^4Mòó°$ŸËÏÅ< ©à »tÈ0EÓ<Zn)×»çzÖH€_jš«pZBõ=Ë —9,n³yó,¼ooSFvü•ÔBíW+å!Š÷v¦cUƒn0`çó‹Ù­¸Àxû•Î?7çÿ²[7( œEJ3¹l!F’YßÃ}<øyxaÔööÑA;ê Ž_|z¨«SÝ^N7,u¶¶ÄΣ@µ}Ó[ÅRý ø<[ª·'Nr\º‹>Ñ¼È Œf $ yý7ÿÇò<õ*O¯›ç§W?xŽ>#}Ý òH-Š¦­Ü±ÌÄZ(£ø0ýhÀúxêr¯­×ÛÙŒœ]Ü^=k :a¤ ™^>ß:dîs‘¯w`®F®òw‡|Y±ÕšõŸ3r F#;6Ëv(ë©z÷T½[IOÍ‹7<‰zŠäá›M²ÈòÊÍkKÈm׋·Àâ° ¨—œjö7QÅzKCþô\`ñokò))Iþl5ãõi§Ç4ó“ È–ÌÔÎL~+s|½ÇÆälñÓ‚¼yN.’̈0f¢Ç®è†òa~öñòêv1ŸÞ €ìžÌÓý­³ä®(ë_×hbù¼» W LsùñÅbA´„zv/ +L¯|3_÷yR ™Oº_1q‚ž7{>×Ó3ôuÂ| Ô¸+h_es(£PwÉO‰TŸÇ]‹R(“~ ðêlqò+üüþúendstream endobj 112 0 obj 2989 endobj 115 0 obj <> stream xœ]RËnÛ0¼ë+ö¨ç(ã ´A›ÈE¾°2m«Ð+’ŒÆ?Õþbù’‚@J;»;3»¯€ìžxVm‚áÁ¾‡ä5!>ñ¨ZX•ÉÝS Ê}ð©8”m’$x.íýW’~¤`›Úøöæ¦ü™P…ÆÜf”»„p†˜È=6Ÿ^‚äÊ1 Œ°à“ˆy>O³iá»Ã1£±‚PÛÔÅsT„˜£“cèÀý0˜nW¿ÅãâÒŠKš/tVP ö¯Ï‹"6ðR’ïeÄúVoPAy—+]È]¼È¸ˆ[32^8`ºÚ<<»ÀÝ“tf[sY™Õèé)EÁÔ¦×sݲ¡¯»ª¾›fm/æmÍ4Õöôh`ªÛ¡©›ÔÌG®òôXÏÇÖÌuýÞŽ,¡"lñ QDKZ]ëÎÀxê:[$0U‘i¶äE¾Vµ$J„‘ìV×»ŒÇϸ\öà¦ÞQ9{óy¨+Ý4ö«ªN£ží¯ô m?Í`×¢HØ™ªnuC£+3!o®ïɤ›ÎVÒ?³°ð«k禉týR®Ÿï?_³ø‘ð‚³0ÿý©«æ‹Ç¶wcÏ]È,b¦ÂHÄÒÖéÿ´“esÒ@•2·,Yn§ ñݤïöEŸÐ[ Jåmw&:ǤD2'a8_õ!ŒO©¥:êÓÖeòÍ>4èö¥endstream endobj 116 0 obj 538 endobj 4 0 obj <> /Contents 5 0 R >> endobj 12 0 obj <> /Contents 13 0 R >> endobj 16 0 obj <> /Contents 17 0 R >> endobj 21 0 obj <> /Contents 22 0 R >> endobj 25 0 obj <> /Contents 26 0 R >> endobj 29 0 obj <> /Contents 30 0 R >> endobj 33 0 obj <> /Contents 34 0 R >> endobj 37 0 obj <> /Contents 38 0 R >> endobj 41 0 obj <> /Contents 42 0 R >> endobj 45 0 obj <> /Contents 46 0 R >> endobj 49 0 obj <> /Contents 50 0 R >> endobj 53 0 obj <> /Contents 54 0 R >> endobj 57 0 obj <> /Contents 58 0 R >> endobj 61 0 obj <> /Contents 62 0 R >> endobj 65 0 obj <> /Contents 66 0 R >> endobj 69 0 obj <> /Contents 70 0 R >> endobj 73 0 obj <> /Contents 74 0 R >> endobj 77 0 obj <> /Contents 78 0 R >> endobj 81 0 obj <> /Contents 82 0 R >> endobj 85 0 obj <> /Contents 86 0 R >> endobj 89 0 obj <> /Contents 90 0 R >> endobj 93 0 obj <> /Contents 94 0 R >> endobj 98 0 obj <> /Contents 99 0 R >> endobj 102 0 obj <> /Contents 103 0 R >> endobj 106 0 obj <> /Contents 107 0 R >> endobj 110 0 obj <> /Contents 111 0 R >> endobj 114 0 obj <> /Contents 115 0 R >> endobj 3 0 obj << /Type /Pages /Kids [ 4 0 R 12 0 R 16 0 R 21 0 R 25 0 R 29 0 R 33 0 R 37 0 R 41 0 R 45 0 R 49 0 R 53 0 R 57 0 R 61 0 R 65 0 R 69 0 R 73 0 R 77 0 R 81 0 R 85 0 R 89 0 R 93 0 R 98 0 R 102 0 R 106 0 R 110 0 R 114 0 R ] /Count 27 >> endobj 1 0 obj <> endobj 11 0 obj <> endobj 15 0 obj <> endobj 20 0 obj <> endobj 24 0 obj <> endobj 28 0 obj <> endobj 32 0 obj <> endobj 36 0 obj <> endobj 40 0 obj <> endobj 44 0 obj <> endobj 48 0 obj <> endobj 52 0 obj <> endobj 56 0 obj <> endobj 60 0 obj <> endobj 64 0 obj <> endobj 68 0 obj <> endobj 72 0 obj <> endobj 76 0 obj <> endobj 80 0 obj <> endobj 84 0 obj <> endobj 88 0 obj <> endobj 92 0 obj <> endobj 97 0 obj <> endobj 101 0 obj <> endobj 105 0 obj <> endobj 109 0 obj <> endobj 113 0 obj <> endobj 117 0 obj <> endobj 7 0 obj <> endobj 96 0 obj <> endobj 19 0 obj <> endobj 8 0 obj <> endobj 9 0 obj <> endobj 10 0 obj <> endobj 2 0 obj <>endobj xref 0 118 0000000000 65535 f 0000069001 00000 n 0000071011 00000 n 0000068755 00000 n 0000064856 00000 n 0000000015 00000 n 0000000609 00000 n 0000070616 00000 n 0000070817 00000 n 0000070882 00000 n 0000070949 00000 n 0000069049 00000 n 0000064998 00000 n 0000000628 00000 n 0000003416 00000 n 0000069108 00000 n 0000065142 00000 n 0000003437 00000 n 0000007135 00000 n 0000070754 00000 n 0000069156 00000 n 0000065286 00000 n 0000007156 00000 n 0000009319 00000 n 0000069226 00000 n 0000065430 00000 n 0000009340 00000 n 0000012673 00000 n 0000069296 00000 n 0000065574 00000 n 0000012694 00000 n 0000016277 00000 n 0000069366 00000 n 0000065718 00000 n 0000016298 00000 n 0000018802 00000 n 0000069427 00000 n 0000065862 00000 n 0000018823 00000 n 0000022054 00000 n 0000069497 00000 n 0000066006 00000 n 0000022075 00000 n 0000024144 00000 n 0000069556 00000 n 0000066150 00000 n 0000024165 00000 n 0000025658 00000 n 0000069606 00000 n 0000066294 00000 n 0000025679 00000 n 0000026915 00000 n 0000069656 00000 n 0000066438 00000 n 0000026936 00000 n 0000028051 00000 n 0000069717 00000 n 0000066582 00000 n 0000028072 00000 n 0000029551 00000 n 0000069767 00000 n 0000066726 00000 n 0000029572 00000 n 0000030733 00000 n 0000069817 00000 n 0000066870 00000 n 0000030754 00000 n 0000033931 00000 n 0000069867 00000 n 0000067014 00000 n 0000033952 00000 n 0000036723 00000 n 0000069926 00000 n 0000067158 00000 n 0000036744 00000 n 0000039170 00000 n 0000069976 00000 n 0000067302 00000 n 0000039191 00000 n 0000041061 00000 n 0000070026 00000 n 0000067446 00000 n 0000041082 00000 n 0000043945 00000 n 0000070076 00000 n 0000067590 00000 n 0000043966 00000 n 0000046975 00000 n 0000070146 00000 n 0000067734 00000 n 0000046996 00000 n 0000049014 00000 n 0000070196 00000 n 0000067878 00000 n 0000049035 00000 n 0000052257 00000 n 0000070682 00000 n 0000070246 00000 n 0000068022 00000 n 0000052278 00000 n 0000056115 00000 n 0000070316 00000 n 0000068167 00000 n 0000056137 00000 n 0000057983 00000 n 0000070376 00000 n 0000068314 00000 n 0000058005 00000 n 0000061116 00000 n 0000070425 00000 n 0000068461 00000 n 0000061138 00000 n 0000064201 00000 n 0000070496 00000 n 0000068608 00000 n 0000064223 00000 n 0000064835 00000 n 0000070567 00000 n trailer << /Size 118 /Root 1 0 R /Info 2 0 R /ID [(ä®Ç_\(*Ô$¸‰u)(ä®Ç_\(*Ô$¸‰u)] >> startxref 71120 %%EOF f2c/f2c.ps000066400000000000000000004276151171647030000125640ustar00rootroot00000000000000%!PS %%Version: 3.3.1 %%DocumentFonts: (atend) %%Pages: (atend) %%EndComments % % Version 3.3.1 prologue for troff files. % /#copies 1 store /aspectratio 1 def /formsperpage 1 def /landscape false def /linewidth .3 def /magnification 1 def /margin 0 def /orientation 0 def /resolution 720 def /rotation 1 def /xoffset 0 def /yoffset 0 def /roundpage true def /useclippath true def /pagebbox [0 0 612 792] def /R /Times-Roman def /I /Times-Italic def /B /Times-Bold def /BI /Times-BoldItalic def /H /Helvetica def /HI /Helvetica-Oblique def /HB /Helvetica-Bold def /HX /Helvetica-BoldOblique def /CW /Courier def /CO /Courier def /CI /Courier-Oblique def /CB /Courier-Bold def /CX /Courier-BoldOblique def /PA /Palatino-Roman def /PI /Palatino-Italic def /PB /Palatino-Bold def /PX /Palatino-BoldItalic def /Hr /Helvetica-Narrow def /Hi /Helvetica-Narrow-Oblique def /Hb /Helvetica-Narrow-Bold def /Hx /Helvetica-Narrow-BoldOblique def /KR /Bookman-Light def /KI /Bookman-LightItalic def /KB /Bookman-Demi def /KX /Bookman-DemiItalic def /AR /AvantGarde-Book def /AI /AvantGarde-BookOblique def /AB /AvantGarde-Demi def /AX /AvantGarde-DemiOblique def /NR /NewCenturySchlbk-Roman def /NI /NewCenturySchlbk-Italic def /NB /NewCenturySchlbk-Bold def /NX /NewCenturySchlbk-BoldItalic def /ZD /ZapfDingbats def /ZI /ZapfChancery-MediumItalic def /S /S def /S1 /S1 def /GR /Symbol def /inch {72 mul} bind def /min {2 copy gt {exch} if pop} bind def /setup { counttomark 2 idiv {def} repeat pop landscape {/orientation 90 orientation add def} if /scaling 72 resolution div def linewidth setlinewidth 1 setlinecap pagedimensions xcenter ycenter translate orientation rotation mul rotate width 2 div neg height 2 div translate xoffset inch yoffset inch neg translate margin 2 div dup neg translate magnification dup aspectratio mul scale scaling scaling scale addmetrics 0 0 moveto } def /pagedimensions { useclippath userdict /gotpagebbox known not and { /pagebbox [clippath pathbbox newpath] def roundpage currentdict /roundpagebbox known and {roundpagebbox} if } if pagebbox aload pop 4 -1 roll exch 4 1 roll 4 copy landscape {4 2 roll} if sub /width exch def sub /height exch def add 2 div /xcenter exch def add 2 div /ycenter exch def userdict /gotpagebbox true put } def /addmetrics { /Symbol /S null Sdefs cf /Times-Roman /S1 StandardEncoding dup length array copy S1defs cf } def /pagesetup { /page exch def currentdict /pagedict known currentdict page known and { page load pagedict exch get cvx exec } if } def /decodingdefs [ {counttomark 2 idiv {y moveto show} repeat} {neg /y exch def counttomark 2 idiv {y moveto show} repeat} {neg moveto {2 index stringwidth pop sub exch div 0 32 4 -1 roll widthshow} repeat} {neg moveto {spacewidth sub 0.0 32 4 -1 roll widthshow} repeat} {counttomark 2 idiv {y moveto show} repeat} {neg setfunnytext} ] def /setdecoding {/t decodingdefs 3 -1 roll get bind def} bind def /w {neg moveto show} bind def /m {neg dup /y exch def moveto} bind def /done {/lastpage where {pop lastpage} if} def /f { dup /font exch def findfont exch dup /ptsize exch def scaling div dup /size exch def scalefont setfont linewidth ptsize mul scaling 10 mul div setlinewidth /spacewidth ( ) stringwidth pop def } bind def /changefont { /fontheight exch def /fontslant exch def currentfont [ 1 0 fontheight ptsize div fontslant sin mul fontslant cos div fontheight ptsize div 0 0 ] makefont setfont } bind def /sf {f} bind def /cf { dup length 2 idiv /entries exch def /chtab exch def /newencoding exch def /newfont exch def findfont dup length 1 add dict /newdict exch def {1 index /FID ne {newdict 3 1 roll put}{pop pop} ifelse} forall newencoding type /arraytype eq {newdict /Encoding newencoding put} if newdict /Metrics entries dict put newdict /Metrics get begin chtab aload pop 1 1 entries {pop def} for newfont newdict definefont pop end } bind def % % A few arrays used to adjust reference points and character widths in some % of the printer resident fonts. If square roots are too high try changing % the lines describing /radical and /radicalex to, % % /radical [0 -75 550 0] % /radicalex [-50 -75 500 0] % % Move braceleftbt a bit - default PostScript character is off a bit. % /Sdefs [ /bracketlefttp [201 500] /bracketleftbt [201 500] /bracketrighttp [-81 380] /bracketrightbt [-83 380] /braceleftbt [203 490] /bracketrightex [220 -125 500 0] /radical [0 0 550 0] /radicalex [-50 0 500 0] /parenleftex [-20 -170 0 0] /integral [100 -50 500 0] /infinity [10 -75 730 0] ] def /S1defs [ /underscore [0 80 500 0] /endash [7 90 650 0] ] def % % Tries to round clipping path dimensions, as stored in array pagebbox, so they % match one of the known sizes in the papersizes array. Lower left coordinates % are always set to 0. % /roundpagebbox { 7 dict begin /papersizes [8.5 inch 11 inch 14 inch 17 inch] def /mappapersize { /val exch def /slop .5 inch def /diff slop def /j 0 def 0 1 papersizes length 1 sub { /i exch def papersizes i get val sub abs dup diff le {/diff exch def /j i def} {pop} ifelse } for diff slop lt {papersizes j get} {val} ifelse } def pagebbox 0 0 put pagebbox 1 0 put pagebbox dup 2 get mappapersize 2 exch put pagebbox dup 3 get mappapersize 3 exch put end } bind def %%EndProlog %%BeginSetup mark /landscape false def /resolution 720 def setup 2 setdecoding %%EndSetup %%Page: 1 1 /saveobj save def mark 1 pagesetup 10 R f (AT&T Bell Laboratories)2 993 1 2203 1560 t (Murray Hill, NJ 07974)3 916 1 2242 1680 t (Computing Science Technical Report No. 149)5 1848 1 1776 2853 t 12 B f (A Fortran-to-C Converter)2 1343 1 2028 3147 t 10 I f (S. I. Feldman)2 538 1 2406 3411 t 10 S f (*)2944 3361 w 10 I f (David M. Gay)2 568 1 2416 3531 t (Mark W. Maimone)2 751 1 2299 3651 t (\262)3050 3601 w (N. L. Schryer)2 533 1 2433 3771 t 10 R f (Last updated March 22, 1995.)4 1198 1 2101 6231 t (Originally issued May 16, 1990.)4 1294 1 2053 6351 t 10 S f (*)1440 6831 w 10 R f (Bell Communications Research, Morristown, NJ 07960)5 2224 1 1490 6881 t (\262)1440 7011 w (Carnegie-Mellon University, Pittsburgh, PA 15213)4 2044 1 1490 7061 t cleartomark showpage saveobj restore %%EndPage: 1 1 %%Page: 1 2 /saveobj save def mark 2 pagesetup 12 B f (A Fortran to C Converter)4 1323 1 2218 1220 t 10 R f (S. I. Feldman)2 539 1 2610 1416 t 10 I f (Bellcore)2711 1574 w (Morristown, NJ 07960)2 909 1 2425 1694 t 10 R f (David M. Gay)2 574 1 2593 1890 t 10 I f (AT&T Bell Laboratories)2 985 1 2387 2048 t (Murray Hill, New Jersey 07974)4 1268 1 2246 2168 t 10 R f (Mark W. Maimone)2 768 1 2496 2364 t 10 I f (Carnegie-Mellon University)1 1129 1 2315 2522 t (Pittsburgh, PA 15213)2 870 1 2445 2642 t 10 R f (N. L. Schryer)2 543 1 2608 2838 t 10 I f (AT&T Bell Laboratories)2 985 1 2387 2996 t (Murray Hill, New Jersey 07974)4 1268 1 2246 3116 t 10 R f (ABSTRACT)2618 3389 w (We describe)1 500 1 1080 3623 t 10 I f (f 2c)1 138 1 1610 3623 t 10 R f ( 77 into C or C++.)5 765(, a program that translates Fortran)5 1378 2 1748 3623 t 10 I f (F 2c)1 163 1 3947 3623 t 10 R f (lets one port-)2 539 1 4141 3623 t (ably mix C and Fortran and makes a large body of well-tested Fortran source code avail-)15 3600 1 1080 3743 t (able to C environments.)3 955 1 1080 3863 t 10 B f (1. INTRODUCTION)1 900 1 720 4136 t 10 R f ( it is)2 177( Sometimes)1 497( desirable for several reasons.)4 1190( is)1 93( 11])1 149(Automatic conversion of Fortran 77 [1] to C [10,)8 1964 6 970 4302 t ( At)1 150(useful to run a well-tested Fortran program on a machine that has a C compiler but no Fortran compiler.)18 4170 2 720 4422 t ( things are impossible to express in Fortran 77 or)9 2002( Some)1 283( and Fortran.)2 523(other times, it is convenient to mix C)7 1512 4 720 4542 t ( storage management, some character operations, arrays of)7 2396(are harder to express in Fortran than in C \(e.g.)9 1924 2 720 4662 t ( pro-)1 206(functions, heterogeneous data structures, and calls that depend on the operating system\), and some)13 4114 2 720 4782 t ( for carrying)2 502( is a large body of well tested Fortran source code)10 2020( There)1 285(grammers simply prefer C to Fortran.)5 1513 4 720 4902 t ( desirable to exploit some of this Fortran)7 1743(out a wide variety of useful calculations, and it is sometimes)10 2577 2 720 5022 t ( but the details vary)4 796( vendors provide some way of mixing C and Fortran,)9 2147( Many)1 286(source in a C environment.)4 1091 4 720 5142 t ( a)1 87( Fortran to C conversion lets one create)7 1691( Automatic)1 489(from system to system.)3 979 4 720 5262 t 10 I f (portable)4009 5262 w 10 R f (C program that)2 641 1 4399 5262 t (exploits Fortran source code.)3 1159 1 720 5382 t 10 R f ( to C conversion is that it allows such tools as)10 1908(A side bene\256t of automatic Fortran 77)6 1568 2 970 5548 t 10 I f (cyntax)4479 5548 w 10 R f (\(1\) and)1 293 1 4747 5548 t 10 I f (lint)720 5668 w 10 R f ( and portability checks that the)5 1289( to provide Fortran 77 programs with some of the consistency)10 2594(\(1\) [4])1 295 3 862 5668 t ( consistency checks detect errors in calling)6 1851( The)1 228(Pfort Veri\256er [13] provided to Fortran 66 programs.)7 2241 3 720 5788 t (sequences and are thus a boon to debugging.)7 1780 1 720 5908 t 10 R f (This paper describes)2 828 1 970 6074 t 10 I f (f 2c)1 138 1 1828 6074 t 10 R f (, a Fortran 77 to C converter based on Feldman's original)10 2344 1 1966 6074 t 10 I f (f)4340 6074 w 10 R f (77 compiler [6].)2 656 1 4384 6074 t (We have used)2 571 1 720 6194 t 10 I f (f 2c)1 138 1 1322 6194 t 10 R f ( large programs and subroutine libraries to C automatically \(i.e., with)10 2816(to convert various)2 733 2 1491 6194 t (no manual intervention\); these include the)5 1714 1 720 6314 t 8 R f (PORT3)2465 6314 w 10 R f (subroutine library \()2 783 1 2742 6314 t 8 R f (PORT1)3525 6314 w 10 R f ( MINOS)1 353( 8]\),)1 157(is described in [7,)3 728 3 3802 6314 t ( \257oating-point test is of particular interest, as it relies heav-)10 2381( The)1 207([12], and Schryer's \257oating-point test [14].)5 1732 3 720 6434 t (ily on correct evaluation of parenthesized expressions and is bit-level self-testing.)10 3258 1 720 6554 t 10 R f ( compiled from the C produced)5 1256(As a debugging aid, we sought bit-level compatibility between objects)9 2814 2 970 6720 t (by)720 6840 w 10 I f (f 2c)1 138 1 849 6840 t 10 R f (and objects produced by our local)5 1370 1 1016 6840 t 10 I f (f)2415 6840 w 10 R f ( we developed)2 582( is, on the VAX where)5 918( That)1 237(77 compiler.)1 509 4 2459 6840 t 10 I f (f 2c)1 138 1 4733 6840 t 10 R f (, we)1 169 1 4871 6840 t ( been)1 222(sought to make it impossible to tell by running a Fortran program whether some of its modules had)17 4098 2 720 6960 t (compiled by)1 500 1 720 7080 t 10 I f (f 2c)1 138 1 1248 7080 t 10 R f (or all had been compiled by)5 1122 1 1413 7080 t 10 I f (f)2562 7080 w 10 R f ( meant that)2 448(77. This)1 355 2 2606 7080 t 10 I f (f 2c)1 138 1 3436 7080 t 10 R f (should follow the same calling con-)5 1439 1 3601 7080 t (ventions as)1 447 1 720 7200 t 10 I f (f)1192 7200 w 10 R f (77 [6] and should use)4 860 1 1236 7200 t 10 I f (f)2121 7200 w 10 R f (77's support libraries,)2 874 1 2165 7200 t 10 I f (libF77)3064 7200 w 10 R f (and)3356 7200 w 10 I f (libI77)3525 7200 w 10 R f (.)3764 7200 w 10 R f (March 22, 1995)2 635 1 2550 7560 t cleartomark showpage saveobj restore %%EndPage: 1 2 %%Page: 2 3 /saveobj save def mark 3 pagesetup 10 R f (- 2 -)2 166 1 2797 480 t ( to make)2 370(Although we have tried)3 976 2 970 840 t 10 I f (f 2c)1 138 1 2354 840 t 10 R f ('s output reasonably readable, our goal of strict compatibility)8 2548 1 2492 840 t (with)720 960 w 10 I f (f)942 960 w 10 R f ( statements, in particular, generally get)5 1645( Input/output)1 564(77 implies some nasty looking conversions.)5 1845 3 986 960 t ( of calls on routines in)5 951(expanded into a series)3 917 2 720 1080 t 10 I f (libI77)2625 1080 w 10 R f (,)2864 1080 w 10 I f (f)2926 1080 w 10 R f ( the C output of)4 676( Thus)1 262(77's I/O library.)2 670 3 2970 1080 t 10 I f (f 2c)1 138 1 4615 1080 t 10 R f (would)4790 1080 w ( to maintain as C; it would be much more sensible to maintain the)13 2747(probably be something of a nightmare)5 1573 2 720 1200 t ( commercial vendors, e.g., those listed in)6 1685( Some)1 286( it changed.)2 479(original Fortran, translating it anew each time)6 1870 4 720 1320 t ( perform translations yielding C that one might reasonably maintain directly; these)11 3454(Appendix A, seek to)3 866 2 720 1440 t (translations generally require some manual intervention.)5 2252 1 720 1560 t 10 R f ( conventions used)2 718( 2 describes the interlanguage)4 1186( Section)1 350(The rest of this paper is organized as follows.)8 1816 4 970 1743 t (by)720 1863 w 10 I f (f 2c)1 138 1 848 1863 t 10 R f (\(and)1014 1863 w 10 I f (f)1219 1863 w 10 R f ( summarizes some extensions to Fortran 77 that)7 1928(77\). \2473)1 311 2 1263 1863 t 10 I f (f 2c)1 138 1 3529 1863 t 10 R f ( invocations)1 488(recognizes. Example)1 858 2 3694 1863 t (of)720 1983 w 10 I f (f 2c)1 138 1 833 1983 t 10 R f ( illustrates various details of)4 1147( \2475)1 155(appear in \2474.)2 528 3 1001 1983 t 10 I f (f 2c)1 138 1 2861 1983 t 10 R f ( issues.)1 295('s translations, and \2476 considers portability)5 1746 2 2999 1983 t (\2477 discusses the generation and use of)6 1555 1 720 2103 t 10 I f (prototypes)2305 2103 w 10 R f ( and ANSI C compilers)4 954(, which can be used both by C++)7 1351 2 2735 2103 t (and by)1 279 1 720 2223 t 10 I f (f 2c)1 138 1 1034 2223 t 10 R f ( describes our experience with an experimental)6 1938( \2478)1 160(to check consistency of calling sequences.)5 1735 3 1207 2223 t 10 I f (f 2c)1 138 1 720 2343 t 10 R f (service provided by)2 805 1 892 2343 t 10 I f (netlib)1731 2343 w 10 R f ( A lists some vendors)4 893( Appendix)1 452([5], and \2479 considers possible extensions.)5 1702 3 1993 2343 t ( B contains a)3 546( Appendix)1 427( Finally,)1 367(who offer conversion of Fortran to C that one might maintain as C.)12 2774 4 720 2463 t 10 I f (man)4868 2463 w 10 R f (page telling how to use)4 927 1 720 2583 t 10 I f (f 2c)1 138 1 1672 2583 t 10 R f (.)1810 2583 w 10 B f (2. INTERLANGUAGE CONVENTIONS)2 1765 1 720 2915 t 10 R f (Much of the material in this section is taken from [6].)10 2139 1 970 3098 t 10 B f (Names)720 3430 w 10 R f (An)970 3613 w 10 I f (f 2c)1 138 1 1122 3613 t 10 R f ( \(until recently called Fortran 8x [2]\) is that long names are)11 2431(extension inspired by Fortran 90)4 1319 2 1290 3613 t (allowed \()1 380 1 720 3733 t 10 I f (f 2c)1 138 1 1100 3733 t 10 R f ( To)1 166( 50 characters\), and names may contain underscores.)7 2137(truncates names that are longer than)5 1468 3 1269 3733 t ( and with names that)4 875(avoid con\257ict with the names of library routines)7 2000 2 720 3853 t 10 I f (f 2c)1 138 1 3632 3853 t 10 R f (generates, Fortran names may)3 1233 1 3807 3853 t ( lower case \(unless the)4 967( names are forced to)4 876( Fortran)1 361(have one or two underscores appended.)5 1658 4 720 3973 t 10 CW f (-U)4623 3973 w 10 R f (option)4784 3973 w ( names of Fortran procedures and common)6 1767(described in Appendix B is in effect\); external names, i.e., the)10 2553 2 720 4093 t ( contain any underscores and have a pair of under-)9 2031(blocks, have a single underscore appended if they do not)9 2289 2 720 4213 t ( named)1 316( Fortran subroutines)2 853( Thus)1 274(scores appended if they do contain underscores.)6 2053 4 720 4333 t 10 CW f (ABC)4266 4333 w 10 R f (,)4446 4333 w 10 CW f (A_B_C)4521 4333 w 10 R f (, and)1 219 1 4821 4333 t 10 CW f (A_B_C_)720 4453 w 10 R f (result in C functions named)4 1105 1 1105 4453 t 10 CW f (abc_)2235 4453 w 10 R f (,)2475 4453 w 10 CW f (a_b_c_ _)1 444 1 2525 4453 t 10 R f (, and)1 194 1 2969 4453 t 10 CW f (a_b_c_ _ _)2 528 1 3188 4453 t 10 R f (.)3716 4453 w 10 B f (Types)720 4785 w 10 R f ( use types)2 442(The table below shows corresponding Fortran and C declarations; the C declarations)11 3628 2 970 4968 t (de\256ned in)1 414 1 720 5088 t 10 CW f (f2c.h)1176 5088 w 10 R f (, a header \256le upon which)5 1116 1 1476 5088 t 10 I f (f 2c)1 138 1 2634 5088 t 10 R f ( table also shows the C types)6 1251( The)1 221( rely.)1 221('s translations)1 575 4 2772 5088 t (de\256ned in the standard version of)5 1334 1 720 5208 t 10 CW f (f2c.h)2079 5208 w 10 R f (.)2379 5208 w 10 S f (_ _______________________________________________________)1 2789 1 1485 5334 t 10 R f ( standard)1 948(Fortran C)1 1059 2 1757 5454 t 10 CW f (f2c.h)3789 5454 w 10 R f (integer)1535 5634 w 10 S f (*)1812 5634 w 10 R f ( int x;)2 234( short)1 660( x;)1 103( shortint)1 742(2 x)1 125 5 1862 5634 t ( int x;)2 234( long)1 667( x;)1 103( integer)1 813(integer x)1 352 5 1535 5754 t ( int x;)2 234( long)1 635( int x;)2 234( long)1 719(logical x)1 347 5 1535 5874 t ( x;)1 103( \257oat)1 795( x;)1 103( real)1 813(real x)1 224 5 1535 5994 t ( x;)1 103( double)1 617( x;)1 103( doublereal)1 571(double precision x)2 738 5 1535 6114 t ( { \257oat r, i; } x;)6 616( struct)1 644( x;)1 103( complex)1 813(complex x)1 419 5 1535 6234 t ( { double r, i; } x;)6 710( struct)1 372( x;)1 103( doublecomplex)1 788(double complex x)2 716 5 1535 6354 t (character)1535 6474 w 10 S f (*)1899 6474 w 10 R f ( x[6];)1 219( char)1 650( x[6];)1 219( char)1 520(6 x)1 125 5 1949 6474 t 10 S f ( \347)1 -2789(_ _______________________________________________________)1 2789 2 1485 6494 t (\347)1485 6434 w (\347)1485 6334 w (\347)1485 6234 w (\347)1485 6134 w (\347)1485 6034 w (\347)1485 5934 w (\347)1485 5834 w (\347)1485 5734 w (\347)1485 5634 w (\347)1485 5534 w (\347)1485 5434 w (\347)4274 6494 w (\347)4274 6434 w (\347)4274 6334 w (\347)4274 6234 w (\347)4274 6134 w (\347)4274 6034 w (\347)4274 5934 w (\347)4274 5834 w (\347)4274 5734 w (\347)4274 5634 w (\347)4274 5534 w (\347)4274 5434 w 10 R f (By the rules of Fortran,)4 951 1 720 6720 t 10 CW f (integer, logical,)1 990 1 1700 6720 t 10 R f (and)2720 6720 w 10 CW f (real)2894 6720 w 10 R f (data occupy the same amount of memory, and)7 1876 1 3164 6720 t 10 CW f (double precision)1 965 1 720 6840 t 10 R f (and)1715 6840 w 10 CW f (complex)1889 6840 w 10 R f (occupy twice this amount;)3 1064 1 2339 6840 t 10 I f (f 2c)1 138 1 3432 6840 t 10 R f (assumes that the types in the C col-)7 1441 1 3599 6840 t ( \(in)1 151(umn above are chosen)3 931 2 720 6960 t 10 CW f (f2c.h)1842 6960 w 10 R f ( translations of the Fortran)4 1120( The)1 220(\) so that these assumptions are valid.)6 1558 3 2142 6960 t 10 CW f (equivalence)720 7080 w 10 R f (and)1408 7080 w 10 CW f (data)1580 7080 w 10 R f ( some machines, one must modify)5 1376( On)1 174(statements depend on these assumptions.)4 1643 3 1847 7080 t 10 CW f (f2c.h)720 7200 w 10 R f ( \2476 for examples and further discussion.)6 1600( See)1 194(to make these assumptions hold.)4 1297 3 1045 7200 t 10 R f (March 22, 1995)2 635 1 2550 7560 t cleartomark showpage saveobj restore %%EndPage: 2 3 %%Page: 3 4 /saveobj save def mark 4 pagesetup 10 R f (- 3 -)2 166 1 2797 480 t 10 B f (Return Values)1 619 1 720 840 t 10 R f (A function of type)3 753 1 970 998 t 10 CW f (integer)1754 998 w 10 R f (,)2174 998 w 10 CW f (logical)2230 998 w 10 R f (, or)1 139 1 2650 998 t 10 CW f (double precision)1 966 1 2820 998 t 10 R f (must be declared as a C func-)6 1222 1 3818 998 t ( the)1 148( If)1 117(tion that returns the corresponding type.)5 1603 3 720 1118 t 10 CW f (-R)2613 1118 w 10 R f (option is in effect \(see Appendix B\), the same is true of a)12 2282 1 2758 1118 t (function of type)2 694 1 720 1238 t 10 CW f (real)1467 1238 w 10 R f (; otherwise, a)2 591 1 1707 1238 t 10 CW f (real)2351 1238 w 10 R f ( as a C function that returns)6 1278(function must be declared)3 1118 2 2644 1238 t 10 CW f (doublereal)720 1358 w 10 R f (; this hack facilitates our VAX regression testing, as it duplicates the behavior of our local)15 3720 1 1320 1358 t (Fortran compiler \()2 738 1 720 1478 t 10 I f (f)1458 1478 w 10 R f (77\). A)1 283 1 1502 1478 t 10 CW f (complex)1814 1478 w 10 R f (or)2263 1478 w 10 CW f (double complex)1 844 1 2375 1478 t 10 R f (function is equivalent to a C routine with an)8 1792 1 3248 1478 t ( Thus,)1 275(additional initial argument that points to the place where the return value is to be stored.)15 3518 2 720 1598 t 9 CW f (complex function f\( . . . \))6 1458 1 1008 1761 t 10 R f (is equivalent to)2 611 1 720 1944 t 9 CW f (void f_\(temp, . . .\))4 1080 1 1008 2107 t (complex)1008 2207 w 9 S f (*)1440 2207 w 9 CW f (temp;)1485 2207 w (. . .)2 270 1 1062 2307 t 10 R f ( equivalent to a C routine with two extra initial arguments: a data address and)14 3110(A character-valued function is)3 1210 2 720 2490 t ( Thus,)1 275(a length.)1 344 2 720 2610 t 9 CW f (character)1008 2773 w 9 S f (*)1494 2773 w 9 CW f (15 function g\( . . . \))6 1188 1 1539 2773 t 10 R f (is equivalent to)2 611 1 720 2956 t 9 CW f (g_\(result, length, . . .\))4 1350 1 1008 3119 t (char)1008 3219 w 9 S f (*)1278 3219 w 9 CW f (result;)1323 3219 w (ftnlen length;)1 756 1 1008 3319 t (. . .)2 270 1 1062 3419 t 10 R f (and could be invoked in C by)6 1177 1 720 3602 t 9 CW f (char chars[15];)1 810 1 1008 3765 t (. . .)2 270 1 1062 3865 t (g_\(chars, 15L, . . . \);)5 1242 1 1008 3965 t 10 R f (Subroutines are invoked as if they were)6 1598 1 720 4148 t 10 CW f (int)2346 4148 w 10 R f (-valued functions whose value speci\256es which alternate return)7 2514 1 2526 4148 t ( an)1 125( return arguments \(statement labels\) are not passed to the function, but are used to do)15 3499( Alternate)1 428(to use.)1 268 4 720 4268 t ( entry points with alternate return argu-)6 1617( the subroutine has no)4 905( \(If)1 156(indexed branch in the calling procedure.)5 1642 4 720 4388 t ( statement)1 408( The)1 205(ments, the returned value is unde\256ned.\))5 1578 3 720 4508 t 9 CW f (call nret\()1 540 1 1008 4671 t 9 S f (*)1548 4671 w 9 CW f (1,)1593 4671 w 9 S f (*)1755 4671 w 9 CW f (2,)1800 4671 w 9 S f (*)1962 4671 w 9 CW f (3\))2007 4671 w 10 R f (is treated exactly as if it were the Fortran computed)9 2054 1 720 4854 t 10 CW f (goto)2799 4854 w 9 CW f ( \))1 108( nret\()1 378(goto \(1, 2, 3\),)3 810 3 1008 5017 t 10 B f (Argument Lists)1 669 1 720 5262 t 10 R f ( addition, for every non-function argument that is of)8 2115( In)1 137( address.)1 353(All Fortran arguments are passed by)5 1465 4 970 5420 t ( string lengths are)3 728( \(The)1 243( length of the value is passed.)6 1209(type character, an argument giving the)5 1565 4 720 5540 t 10 CW f (ftnlen)4495 5540 w 10 R f (val-)4885 5540 w (ues, i.e.,)1 335 1 720 5660 t 10 CW f (long int)1 485 1 1085 5660 t 10 R f ( of arguments is: extra arguments)5 1364( summary, the order)3 819( In)1 138(quantities passed by value\).)3 1119 4 1600 5660 t ( function, and a)3 621(for complex and character functions, an address for each datum or)10 2649 2 720 5780 t 10 CW f (ftnlen)4015 5780 w 10 R f (for each charac-)2 640 1 4400 5780 t ( the call in)3 419( Thus,)1 275(ter argument \(other than character-valued functions\).)5 2110 3 720 5900 t 9 CW f (external f)1 540 1 1008 6063 t (character)1008 6163 w 9 S f (*)1494 6163 w 9 CW f (7 s)1 162 1 1539 6163 t (integer b\(3\))1 648 1 1008 6263 t (. . .)2 270 1 1062 6363 t (call sam\(f, b\(2\), s\))3 1080 1 1008 6463 t 10 R f (is equivalent to that in)4 889 1 720 6646 t 9 CW f (int f\(\);)1 432 1 1008 6809 t (char s[7];)1 540 1 1008 6909 t (long int b[3];)2 756 1 1008 7009 t (. . .)2 270 1 1062 7109 t (sam_\(f, &b[1], s, 7L\);)3 1188 1 1008 7209 t 10 R f (March 22, 1995)2 635 1 2550 7560 t cleartomark showpage saveobj restore %%EndPage: 3 4 %%Page: 4 5 /saveobj save def mark 5 pagesetup 10 R f (- 4 -)2 166 1 2797 480 t ( arrays begin at 1 by default.)6 1175(Note that the \256rst element of a C array always has subscript zero, but Fortran)14 3145 2 720 840 t ( whereas C arrays are stored in row-major order,)8 1983(Because Fortran arrays are stored in column-major order,)7 2337 2 720 960 t 10 I f (f 2c)1 138 1 720 1080 t 10 R f ( arrays into one-dimensional C arrays and issues appropriate sub-)9 2681(translates multi-dimensional Fortran)2 1469 2 890 1080 t (scripting expressions.)1 866 1 720 1200 t 10 B f (3. EXTENSIONS TO FORTRAN 77)4 1560 1 720 1460 t 10 R f (Since it is derived from)4 938 1 970 1622 t 10 I f (f)1933 1622 w 10 R f (77,)1977 1622 w 10 I f (f 2c)1 138 1 2127 1622 t 10 R f (supports all of the)3 719 1 2290 1622 t 10 I f (f)3035 1622 w 10 R f (77 extensions described in [6].)4 1227 1 3079 1622 t 10 I f (F 2c)1 163 1 4357 1622 t 10 R f ('s extensions)1 520 1 4520 1622 t (include the following.)2 880 1 720 1742 t 10 S f (\267)720 1922 w 10 R f (Type)791 1922 w 10 CW f (double complex)1 854 1 1035 1922 t 10 R f (\(alias)1928 1922 w 10 CW f (complex*16)2183 1922 w 10 R f (\) is a double-precision version of)5 1387 1 2783 1922 t 10 CW f (complex)4209 1922 w 10 R f (. Speci\256c)1 411 1 4629 1922 t ( for)1 148(intrinsic functions)1 733 2 791 2042 t 10 CW f (double complex)1 847 1 1704 2042 t 10 R f (have names that start with)4 1071 1 2583 2042 t 10 CW f (z)3686 2042 w 10 R f (rather than)1 436 1 3778 2042 t 10 CW f (c)4246 2042 w 10 R f ( exception to)2 530(. An)1 204 2 4306 2042 t (this rule is)2 425 1 791 2162 t 10 CW f (dimag)1245 2162 w 10 R f ( of a)2 187(, which returns the imaginary part)5 1373 2 1545 2162 t 10 CW f (double complex)1 845 1 3135 2162 t 10 R f (value;)4010 2162 w 10 CW f (imag)4284 2162 w 10 R f (is the corre-)2 486 1 4554 2162 t ( generic intrinsic function)3 1035( The)1 207(sponding generic intrinsic function.)3 1430 3 791 2282 t 10 CW f (real)3490 2282 w 10 R f (is extended so that it returns the)6 1283 1 3757 2282 t (real part of a)3 509 1 791 2402 t 10 CW f (double complex)1 841 1 1326 2402 t 10 R f (value as a)2 395 1 2193 2402 t 10 CW f (double precision)1 961 1 2614 2402 t 10 R f (value;)3601 2402 w 10 CW f (dble)3871 2402 w 10 R f (is the speci\256c intrinsic)3 903 1 4137 2402 t (function that does this job.)4 1064 1 791 2522 t 10 S f (\267)720 2702 w 10 R f (The ``types'' that may appear in an)6 1425 1 791 2702 t 10 CW f (implicit)2244 2702 w 10 R f (statement include)1 705 1 2752 2702 t 10 CW f (undefined)3485 2702 w 10 R f ( vari-)1 217(, which implies that)3 798 2 4025 2702 t (ables whose names begin with the associated letters must be explicitly declared in a type statement.)15 4032 1 791 2822 t 10 I f (F 2c)1 163 1 4877 2822 t 10 R f (also recognizes the Fortran 90 statement)5 1611 1 791 2942 t 9 CW f (implicit none)1 702 1 1008 3112 t 10 R f (as equivalent to)2 627 1 791 3302 t 9 CW f (implicit undefined\(a-z\))1 1242 1 1008 3472 t 10 R f (The command-line option)2 1038 1 791 3662 t 10 CW f (-u)1854 3662 w 10 R f (has the effect of inserting)4 1014 1 1999 3662 t 9 CW f (implicit none)1 702 1 1008 3832 t 10 R f (at the beginning of each Fortran procedure.)6 1726 1 791 4022 t 10 S f (\267)720 4202 w 10 R f ( themselves recursively, i.e., may call themselves either directly or indirectly through)11 3436(Procedures may call)2 813 2 791 4202 t (a chain of other calls.)4 856 1 791 4322 t 10 S f (\267)720 4502 w 10 R f (The keywords)1 579 1 791 4502 t 10 CW f (static)1406 4502 w 10 R f (and)1802 4502 w 10 CW f (automatic)1982 4502 w 10 R f (act as ``types'' in type and implicit statements; they specify)9 2482 1 2558 4502 t ( of each)2 325( is exactly one copy)4 817( There)1 288(storage classes.)1 621 4 791 4622 t 10 CW f (static)2872 4622 w 10 R f (variable, and such variables retain their val-)6 1778 1 3262 4622 t ( of a)2 189( the other hand, each invocation)5 1300( On)1 177(ues between invocations of the procedure in which they appear.)9 2583 4 791 4742 t (procedure gets new copies of the procedure's)6 1877 1 791 4862 t 10 CW f (automatic)2705 4862 w 10 R f (variables.)3282 4862 w 10 CW f (Automatic)3729 4862 w 10 R f (variables may not)2 734 1 4306 4862 t (appear in)1 392 1 791 4982 t 10 CW f (equivalence)1232 4982 w 10 R f (,)1892 4982 w 10 CW f (data)1967 4982 w 10 R f (,)2207 4982 w 10 CW f (namelist)2282 4982 w 10 R f (, or)1 158 1 2762 4982 t 10 CW f (save)2970 4982 w 10 R f ( command-line option)2 933(statements. The)1 677 2 3260 4982 t 10 CW f (-a)4920 4982 w 10 R f (changes the default storage class from)5 1526 1 791 5102 t 10 CW f (static)2342 5102 w 10 R f (to)2727 5102 w 10 CW f (automatic)2830 5102 w 10 R f (\(for all variables except those that appear)6 1645 1 3395 5102 t (in)791 5222 w 10 CW f (common)894 5222 w 10 R f (,)1254 5222 w 10 CW f (data)1304 5222 w 10 R f (,)1544 5222 w 10 CW f (equivalence)1594 5222 w 10 R f (,)2254 5222 w 10 CW f (namelist)2304 5222 w 10 R f (, or)1 133 1 2784 5222 t 10 CW f (save)2942 5222 w 10 R f (statements\).)3207 5222 w 10 S f (\267)720 5402 w 10 R f ( free-format line, which may extend beyond)6 1784(A tab in the \256rst 6 columns signi\256es that the current line is a)13 2465 2 791 5402 t ( ampersand)1 459( An)1 174(column 72.)1 452 3 791 5522 t 10 CW f (&)1903 5522 w 10 R f (in column 1 indicates that the current line is a free-format continuation line.)12 3050 1 1990 5522 t ( have neither an ampersand in column 1 nor a tab in the \256rst 6 columns are treated as Fortran 77)20 3852(Lines that)1 397 2 791 5642 t ( with blanks until they are 72)6 1166( shorter than 72 characters, they are padded on the right)10 2229( if)1 112(\256xed-format lines:)1 742 4 791 5762 t ( taking)1 277( After)1 262(characters long; if longer than 72 characters, the characters beyond column 72 are discarded.)13 3710 3 791 5882 t ( this is the only constraint on)6 1204(continuations into account, statements may be up to 1320 characters long;)10 3045 2 791 6002 t ( the Fortran 77 standard, which allows at most 19)9 1994( limit is implied by)4 767( \(This)1 262(the length of free-format lines.)4 1226 4 791 6122 t (continuation lines; 1320)2 967 1 791 6242 t 10 S f (=)1807 6242 w 10 R f (\( 1)1 91 1 1911 6242 t 10 S f (+)2042 6242 w 10 R f (19 \))1 141 1 2137 6242 t 10 S f (\264)2327 6242 w 10 R f (66.\))2423 6242 w 10 S f (\267)720 6422 w 10 R f (Aside from quoted strings,)3 1066 1 791 6422 t 10 I f (f 2c)1 138 1 1882 6422 t 10 R f (ignores case \(unless the)3 945 1 2045 6422 t 10 CW f (-U)3015 6422 w 10 R f (option is in effect\).)3 760 1 3160 6422 t 10 S f (\267)720 6602 w 10 R f (The statement)1 563 1 791 6602 t 9 CW f (include 'stuff')1 810 1 1008 6772 t 10 R f (is replaced by the contents of the \256le)7 1551 1 791 6962 t 10 I f (stuff)2379 6962 w 10 R f (. Unless)1 359 1 2560 6962 t 10 I f (stuff)2956 6962 w 10 R f ( \256le name,)2 445(appears to be an absolute)4 1051 2 3174 6962 t 10 I f (f 2c)1 138 1 4708 6962 t 10 R f (\256rst)4884 6962 w (looks for)1 370 1 791 7082 t 10 I f (stuff)1198 7082 w 10 R f ( to \256nd)2 308( Failing)1 346(in the directory of the \256le it is currently reading.)9 2033 3 1416 7082 t 10 I f (stuff)4140 7082 w 10 R f (there, it looks in)3 683 1 4357 7082 t (directories speci\256ed by)2 934 1 791 7202 t 10 CW f (-I)1789 7202 w 10 I f (dir)1909 7202 w 10 R f (command-line options; there can be several such options, each specifying)9 2984 1 2056 7202 t 10 R f (March 22, 1995)2 635 1 2550 7560 t cleartomark showpage saveobj restore %%EndPage: 4 5 %%Page: 5 6 /saveobj save def mark 6 pagesetup 10 R f (- 5 -)2 166 1 2797 480 t (one directory.)1 558 1 791 840 t 10 CW f (Include)1403 840 w 10 R f ( command-line option)2 889( The)1 208( depth, currently ten.)3 838(s may be nested to a reasonable)6 1282 4 1823 840 t 10 CW f (-!I)791 960 w 10 R f (disables)1020 960 w 10 CW f (include)1391 960 w 10 R f (s; this option is used by the)6 1234 1 1811 960 t 10 I f ( 2c)1 110(netlib f)1 305 2 3094 960 t 10 R f ( \(for which)2 493(service described in \2478)3 989 2 3558 960 t 10 CW f (include)791 1080 w 10 R f (obviously makes no sense\).)3 1099 1 1236 1080 t 10 S f (\267)720 1260 w 10 I f (F)791 1260 w 10 R f (77 allows binary, octal, and hexadecimal constants to appear in)9 2598 1 860 1260 t 10 CW f (data)3491 1260 w 10 R f (statements;)3764 1260 w 10 I f (f 2c)1 138 1 4247 1260 t 10 R f (goes somewhat)1 622 1 4418 1260 t ( a decimal integer constant)4 1090(further, allowing such constants to appear anywhere; they are treated just like)11 3159 2 791 1380 t ( hexadecimal constants may assume one of two forms: a)9 2321( octal, and)2 427( Binary,)1 354(having the equivalent value.)3 1147 4 791 1500 t ( quoted string of digits, or a decimal base, followed by a sharp sign)13 2748(letter followed by a)3 797 2 791 1620 t 10 CW f (#)4366 1620 w 10 R f (, followed by a)3 614 1 4426 1620 t ( letter is)2 324( The)1 206(string of digits \(not quoted\).)4 1129 3 791 1740 t 10 CW f (b)2476 1740 w 10 R f (or)2562 1740 w 10 CW f (B)2671 1740 w 10 R f (for binary constants,)2 820 1 2757 1740 t 10 CW f (o)3603 1740 w 10 R f (or)3689 1740 w 10 CW f (O)3798 1740 w 10 R f (for octal constants, and)3 932 1 3884 1740 t 10 CW f (x)4843 1740 w 10 R f (,)4903 1740 w 10 CW f (X)4955 1740 w 10 R f (,)5015 1740 w 10 CW f (z)791 1860 w 10 R f (, or)1 185 1 851 1860 t 10 CW f (Z)1113 1860 w 10 R f ( for example,)2 631( Thus,)1 326(for hexadecimal constants.)2 1169 3 1250 1860 t 10 CW f (z'a7')3452 1860 w 10 R f (,)3752 1860 w 10 CW f (16#a7)3853 1860 w 10 R f (,)4153 1860 w 10 CW f (o'247')4254 1860 w 10 R f (,)4614 1860 w 10 CW f (8#247)4715 1860 w 10 R f (,)5015 1860 w 10 CW f (b'10100111')791 1980 w 10 R f (and)1476 1980 w 10 CW f (2#10100111)1645 1980 w 10 R f (are all treated just like the integer)6 1336 1 2270 1980 t 10 CW f (167)3631 1980 w 10 R f (.)3811 1980 w 10 S f (\267)720 2160 w 10 R f (For compatibility with C, quoted strings may contain the following escapes:)10 3041 1 791 2160 t 10 S f (_ __________________________________________)1 2129 1 1851 2250 t 10 CW f (\\0)1901 2370 w 10 R f (null)2171 2370 w 10 CW f (\\n)3029 2370 w 10 R f (newline)3323 2370 w 10 CW f (\\\\)1901 2490 w 10 R f (\\)2171 2490 w 10 CW f (\\r)3029 2490 w 10 R f (carriage return)1 583 1 3323 2490 t 10 CW f (\\b)1901 2610 w 10 R f (backspace)2171 2610 w 10 CW f (\\t)3029 2610 w 10 R f (tab)3323 2610 w 10 CW f (\\f)1901 2730 w 10 R f (form feed)1 390 1 2171 2730 t 10 CW f (\\v)3029 2730 w 10 R f (vertical tab)1 446 1 3323 2730 t 10 CW f (\\')1972 2910 w 10 R f (apostrophe \(does not terminate a string\))5 1589 1 2171 2910 t 10 CW f (\\")1972 3030 w 10 R f (quotation mark \(does not terminate a string\))6 1759 1 2171 3030 t 10 CW f (\\)1972 3150 w 10 I f (x x)1 183 1 2032 3150 t 10 R f (, where)1 293 1 2215 3150 t 10 I f (x)2533 3150 w 10 R f (is any other character)3 855 1 2602 3150 t 10 S f ( \347)1 -2129(_ __________________________________________)1 2129 2 1851 3170 t (\347)1851 3150 w (\347)1851 3050 w (\347)1851 2950 w (\347)1851 2850 w (\347)1851 2750 w (\347)1851 2650 w (\347)1851 2550 w (\347)1851 2450 w (\347)1851 2350 w (\347)3980 3170 w (\347)3980 3150 w (\347)3980 3050 w (\347)3980 2950 w (\347)3980 2850 w (\347)3980 2750 w (\347)3980 2650 w (\347)3980 2550 w (\347)3980 2450 w (\347)3980 2350 w 10 R f (The)791 3360 w 10 CW f (-!bs)971 3360 w 10 R f (option tells)1 448 1 1236 3360 t 10 I f (f 2c)1 138 1 1709 3360 t 10 R f ( dou-)1 209( strings may be delimited either by)6 1388( Quoted)1 344(not to recognize these escapes.)4 1227 4 1872 3360 t (ble quotes \()2 482 1 791 3480 t 10 CW f (")1298 3480 w 10 R f (\) or by single quotes \()5 914 1 1383 3480 t 10 S f (\242)2322 3480 w 10 R f (\); if a string starts with one kind of quote, the other kind may be)14 2668 1 2372 3480 t ( possible, trans-)2 648( Where)1 324( escape.)1 324(embedded in the string without being repeated or quoted by a backslash)11 2953 4 791 3600 t (lated strings are null-terminated.)3 1298 1 791 3720 t 10 S f (\267)720 3900 w 10 R f (Hollerith strings are treated as character strings.)6 1909 1 791 3900 t 10 S f (\267)720 4080 w 10 R f (In)791 4080 w 10 CW f (equivalence)908 4080 w 10 R f ( given a single subscript, in which)6 1423(statements, a multiply-dimensioned array may be)5 2015 2 1602 4080 t ( subscripts are taken to be 1 \(for backward compatibility with Fortran 66\) and a warning)15 3584(case the missing)2 665 2 791 4200 t (message is issued.)2 730 1 791 4320 t 10 S f (\267)720 4500 w 10 R f ( library \()2 355(In a formatted read of non-character variables, the I/O)8 2172 2 791 4500 t 10 I f (libI77)3318 4500 w 10 R f (\) allows a \256eld to be terminated by a)8 1483 1 3557 4500 t (comma.)791 4620 w 10 S f (\267)720 4800 w 10 R f (Type)791 4800 w 10 CW f (real*4)1029 4800 w 10 R f (is equivalent to)2 627 1 1422 4800 t 10 CW f (real)2082 4800 w 10 R f (,)2322 4800 w 10 CW f (integer*4)2380 4800 w 10 R f (to)2953 4800 w 10 CW f (integer)3064 4800 w 10 R f (,)3484 4800 w 10 CW f (real*8)3542 4800 w 10 R f (to)3935 4800 w 10 CW f (double precision)1 969 1 4046 4800 t 10 R f (,)5015 4800 w 10 CW f (complex*8)791 4920 w 10 R f (to)1356 4920 w 10 CW f (complex)1459 4920 w 10 R f (, and, as stated before,)4 889 1 1879 4920 t 10 CW f (complex*16)2793 4920 w 10 R f (to)3418 4920 w 10 CW f (double complex)1 840 1 3521 4920 t 10 R f (.)4361 4920 w 10 S f (\267)720 5100 w 10 R f (The type)1 372 1 791 5100 t 10 CW f (integer*2)1208 5100 w 10 R f (designates short integers \(translated to type)5 1828 1 1793 5100 t 10 CW f (shortint)3666 5100 w 10 R f ( is)1 113(, which by default)3 781 2 4146 5100 t 10 CW f (short int)1 562 1 791 5220 t 10 R f ( command-line)1 623( The)1 226( of storage.)2 488( integers are expected to occupy half a ``unit'')8 2020(\). Such)1 330 5 1353 5220 t (options)791 5340 w 10 CW f (-I2)1120 5340 w 10 R f (and)1334 5340 w 10 CW f (-i2)1512 5340 w 10 R f (turn type)1 367 1 1726 5340 t 10 CW f (integer)2127 5340 w 10 R f (into)2581 5340 w 10 CW f (integer*2)2771 5340 w 10 R f (; see the)2 345 1 3311 5340 t 10 I f (man)3690 5340 w 10 R f (page \(appendix B\) for more)4 1144 1 3896 5340 t (details.)791 5460 w 10 S f (\267)720 5640 w 10 R f (The binary intrinsic functions)3 1224 1 791 5640 t 10 CW f (and)2053 5640 w 10 R f (,)2233 5640 w 10 CW f (or)2296 5640 w 10 R f (,)2416 5640 w 10 CW f (xor)2480 5640 w 10 R f (,)2660 5640 w 10 CW f (lshift)2724 5640 w 10 R f (, and)1 208 1 3084 5640 t 10 CW f (rshift)3331 5640 w 10 R f (and the unary intrinsic function)4 1310 1 3730 5640 t 10 CW f (not)791 5760 w 10 R f (perform bitwise operations on)3 1234 1 1007 5760 t 10 CW f (integer)2277 5760 w 10 R f (or)2732 5760 w 10 CW f (logical)2850 5760 w 10 R f (operands. For)1 584 1 3305 5760 t 10 CW f (lshift)3924 5760 w 10 R f (and)4319 5760 w 10 CW f (rshift)4498 5760 w 10 R f (, the)1 182 1 4858 5760 t (second operand tells how many bits to shift the \256rst operand.)10 2434 1 791 5880 t 10 S f (\267)720 6060 w 10 I f (LibF77)791 6060 w 10 R f (provides two functions for accessing command-line arguments:)6 2655 1 1131 6060 t 10 CW f (iargc\(dummy\))3831 6060 w 10 R f (returns the)1 444 1 4596 6060 t ( ignores its argument\);)3 911(number of command-line arguments \(and)4 1674 2 791 6180 t 10 CW f (getarg\(k,c\))3404 6180 w 10 R f (sets the character string)3 948 1 4092 6180 t 10 CW f (c)791 6300 w 10 R f (to the)1 225 1 876 6300 t 10 I f (k)1126 6300 w 10 R f (th command-line argument \(or to blanks if)6 1698 1 1170 6300 t 10 I f (k)2893 6300 w 10 R f (is out of range\).)3 632 1 2962 6300 t 10 S f (\267)720 6480 w 10 R f (Variable,)791 6480 w 10 CW f (common)1196 6480 w 10 R f ( the 50th)2 376(, and procedure names may be arbitrarily long, but they are truncated after)12 3108 2 1556 6480 t ( underscores \(in which case their translations will have a pair of)11 2712( names may contain)3 844(character. These)1 693 3 791 6600 t (underscores appended\).)1 941 1 791 6720 t 10 S f (\267)720 6900 w 10 R f (MAIN programs may have arguments, which are ignored.)7 2314 1 791 6900 t 10 S f (\267)720 7080 w 10 CW f (Common)791 7080 w 10 R f (variables may be initialized by a)5 1340 1 1185 7080 t 10 CW f (data)2559 7080 w 10 R f (statement in any module, not just in a)7 1563 1 2833 7080 t 10 CW f (block data)1 610 1 4430 7080 t 10 R f (subprogram.)791 7200 w 10 R f (March 22, 1995)2 635 1 2550 7560 t cleartomark showpage saveobj restore %%EndPage: 5 6 %%Page: 6 7 /saveobj save def mark 7 pagesetup 10 R f (- 6 -)2 166 1 2797 480 t 10 S f (\267)720 900 w 10 R f (The label may be omitted from a)6 1309 1 791 900 t 10 CW f (do)2125 900 w 10 R f (loop if the loop is terminated by an)7 1402 1 2270 900 t 10 CW f (enddo)3697 900 w 10 R f (statement.)4022 900 w 10 S f (\267)720 1080 w 10 R f (Unnamed Fortran 90)2 832 1 791 1080 t 10 CW f (do while)1 480 1 1648 1080 t 10 R f ( a loop begins with a statement of the form)9 1712( Such)1 250(loops are allowed.)2 729 3 2153 1080 t 10 CW f (do)2025 1200 w 10 R f ([)2205 1200 w 10 I f (label)2238 1200 w 10 R f (] [)1 91 1 2446 1200 t 10 CW f (,)2537 1200 w 10 R f (])2597 1200 w 10 CW f (while\()2655 1200 w 10 I f (logical expression)1 730 1 3015 1200 t 10 CW f (\))3745 1200 w 10 R f (and ends either after the statement labelled by)7 1832 1 791 1320 t 10 I f (label)2648 1320 w 10 R f (or after a matching)3 756 1 2873 1320 t 10 CW f (enddo)3654 1320 w 10 R f (.)3954 1320 w 10 S f (\267)720 1500 w 10 I f (F 2c)1 163 1 791 1500 t 10 R f (recognizes the Fortran 90 synonyms)4 1464 1 983 1500 t 10 CW f (<)2476 1500 w 10 R f (,)2536 1500 w 10 CW f (<=)2590 1500 w 10 R f (,)2710 1500 w 10 CW f (==)2764 1500 w 10 R f (,)2884 1500 w 10 CW f (>=)2938 1500 w 10 R f (,)3058 1500 w 10 CW f (>)3112 1500 w 10 R f (, and)1 199 1 3172 1500 t 10 CW f (<>)3401 1500 w 10 R f (for the Fortran comparison operators)4 1489 1 3551 1500 t 10 CW f (.LT.)791 1620 w 10 R f (,)1031 1620 w 10 CW f (.LE.)1081 1620 w 10 R f (,)1321 1620 w 10 CW f (.EQ.)1371 1620 w 10 R f (,)1611 1620 w 10 CW f (.GE.)1661 1620 w 10 R f (,)1901 1620 w 10 CW f (.GT.)1951 1620 w 10 R f (, and)1 194 1 2191 1620 t 10 CW f (.NE.)2410 1620 w 10 S f (\267)720 1800 w 10 CW f (Namelist)791 1800 w 10 R f (works as in Fortran 90 [2], with a minor restriction on)10 2256 1 1306 1800 t 10 CW f (namelist)3598 1800 w 10 R f ( must)1 231(input: subscripts)1 695 2 4114 1800 t (have the form)2 554 1 791 1920 t 10 I f (subscript)2240 2040 w 10 R f ([ :)1 86 1 2632 2040 t 10 I f (subscript)2743 2040 w 10 R f ([ :)1 86 1 3135 2040 t 10 I f (stride)3246 2040 w 10 R f (] ])1 91 1 3499 2040 t (For example, the Fortran)3 993 1 791 2160 t 9 CW f (integer m\(8\))1 648 1 1008 2345 t (real x\(10,10\))1 702 1 1008 2445 t (namelist /xx/ m, x)3 972 1 1008 2545 t (. . .)2 270 1 1008 2645 t (read\(*,xx\))1008 2745 w 10 R f (could read)1 418 1 791 2950 t 9 CW f ( = 9,10/)2 432( m\(7:8\))1 432(&xx x\(1,1\) = 2, x\(1:3,8:10:2\) = 1,2,3,4,5,6)6 2322 3 1008 3135 t 10 R f (but would elicit error messages on the inputs)7 1790 1 791 3340 t 9 CW f (&xx x\(:3,8:10:2\) = 1,2,3,4,5,6/)3 1674 1 1008 3525 t ( 1,2,3,4,5,6/)1 702( =)1 162(&xx x\(1:3,8::2\))1 810 3 1008 3625 t (&xx m\(7:\) = 9,10/)3 918 1 1008 3725 t 10 R f ( with the)2 358( compatibility)1 562( For)1 192(\(which inputs would be legal in Fortran 90\).)7 1786 4 791 3930 t 10 CW f (namelist)3718 3930 w 10 R f (variants supplied by)2 813 1 4227 3930 t (several vendors as Fortran 77 extensions,)5 1672 1 791 4050 t 10 I f (f 2c)1 138 1 2492 4050 t 10 R f ('s version of)2 507 1 2630 4050 t 10 I f (libI77)3166 4050 w 10 R f (permits)3434 4050 w 10 CW f ($)3763 4050 w 10 R f (to be used instead of)4 837 1 3852 4050 t 10 CW f (&)4718 4050 w 10 R f (and)4807 4050 w 10 CW f (/)4980 4050 w 10 R f (in)791 4170 w 10 CW f (namelist)894 4170 w 10 R f ( the Fortran shown above could read)6 1458(input. Thus)1 481 2 1399 4170 t 9 CW f ( = 9,10$end)2 594( m\(7:8\))1 432($xx x\(1,1\) = 2, x\(1:3,8:10:2\) = 1,2,3,4,5,6)6 2322 3 1008 4355 t 10 S f (\267)720 4620 w 10 R f (Internal list-directed and namelist I/O are allowed.)6 2015 1 791 4620 t 10 S f (\267)720 4800 w 10 R f (In an)1 202 1 791 4800 t 10 CW f (open)1018 4800 w 10 R f (statement,)1283 4800 w 10 CW f (name=)1716 4800 w 10 R f (is treated as)2 471 1 2041 4800 t 10 CW f (file=)2537 4800 w 10 R f (.)2837 4800 w 10 S f (\267)720 4980 w 10 R f ( start with a)3 469( They)1 255(Fortran 90 inline comments are allowed.)5 1620 3 791 4980 t 10 CW f (!)3160 4980 w 10 R f (anywhere but column 6.)3 965 1 3270 4980 t 10 B f (4. INVOCATION EXAMPLES)2 1342 1 720 5269 t 10 R f (To convert the Fortran \256les)4 1093 1 970 5440 t 10 CW f (main.f)2088 5440 w 10 R f (and)2473 5440 w 10 CW f (subs.f)2642 5440 w 10 R f (, one might use the UNIX)5 1032 1 3002 5440 t 10 S f (\322)4034 5390 w 10 R f (command:)4138 5440 w 9 CW f (f2c main.f subs.f)2 918 1 1008 5625 t 10 R f (This results in translated \256les suf\256xed with)6 1782 1 720 5830 t 10 CW f (.c)2537 5830 w 10 R f ( the resulting C \256les are)5 1007(, i.e.,)1 207 2 2657 5830 t 10 CW f (main.c)3907 5830 w 10 R f (and)4303 5830 w 10 CW f (subs.c)4483 5830 w 10 R f (. To)1 197 1 4843 5830 t ( \256les in the current directory, compile the resulting C, and create an executable pro-)14 3379(translate all the Fortran)3 941 2 720 5950 t (gram named)1 496 1 720 6070 t 10 CW f (myprog)1241 6070 w 10 R f (, one might use the following pair of UNIX commands:)9 2220 1 1601 6070 t 9 CW f (f2c *.f)1 378 1 1008 6255 t (cc -o myprog *.c -lF77 -lI77 -lm)6 1728 1 1008 6355 t 10 R f (The above)1 430 1 720 6560 t 10 CW f (-lF77)1187 6560 w 10 R f (and)1524 6560 w 10 CW f (-lI77)1705 6560 w 10 R f (options assume that the ``standard'' Fortran support libraries)7 2511 1 2042 6560 t 10 I f (libF77)4591 6560 w 10 R f (and)4896 6560 w 10 I f (libI77)720 6680 w 10 R f (are appropriate for use with)4 1110 1 986 6680 t 10 I f (f 2c)1 138 1 2123 6680 t 10 R f ( \2476\); if)2 274( some systems this is not the case \(as further discussed in)11 2306(. On)1 199 3 2261 6680 t (one had installed a combination of the appropriate)7 2117 1 720 6800 t 10 I f (libF77)2878 6800 w 10 R f (and)3186 6800 w 10 I f (libI77)3371 6800 w 10 R f ( the)1 164(in the appropriate place, then)4 1225 2 3651 6800 t (above example might become)3 1195 1 720 6920 t 9 CW f (f2c *.f)1 378 1 1008 7105 t (cc -o myprog *.c -lf2c -lm)5 1404 1 1008 7205 t 10 R f (March 22, 1995)2 635 1 2550 7560 t cleartomark showpage saveobj restore %%EndPage: 6 7 %%Page: 7 8 /saveobj save def mark 8 pagesetup 10 R f (- 7 -)2 166 1 2797 480 t (Sometimes it is desirable to use)5 1269 1 720 840 t 10 I f (f 2c)1 138 1 2015 840 t 10 R f ('s)2153 840 w 10 CW f (-R)2251 840 w 10 R f (option, which tells)2 744 1 2397 840 t 10 I f (f 2c)1 138 1 3167 840 t 10 R f ( all \257oating-point operations to)4 1247(not to force)2 462 2 3331 840 t ( might argue that)3 731( \(One)1 266(be done in double precision.)4 1197 3 720 960 t 10 CW f (-R)2956 960 w 10 R f ( \256nd the current)3 683(should be the default, but we)5 1239 2 3118 960 t (arrangement more convenient for testing)4 1624 1 720 1080 t 10 I f (f 2c)1 138 1 2369 1080 t 10 R f (.\) With)1 308 1 2507 1080 t 10 CW f (-R)2840 1080 w 10 R f (speci\256ed, the previous example becomes)4 1633 1 2985 1080 t 9 CW f (f2c -R *.f)2 540 1 1008 1245 t (cc -o myprog *.c -lf2c -lm)5 1404 1 1008 1345 t 10 R f ( is easily done by)4 706( This)1 230(Sometimes it is desirable to translate several Fortran source \256les into a single C \256le.)14 3384 3 720 1530 t (using)720 1650 w 10 I f (f 2c)1 138 1 962 1650 t 10 R f (as a \256lter:)2 394 1 1125 1650 t 9 CW f (cat *.f | f2c >mystuff.c)4 1296 1 1008 1815 t 10 R f (The)720 2000 w 10 CW f (-A)904 2000 w 10 R f (option lets)1 424 1 1053 2000 t 10 I f (f 2c)1 138 1 1506 2000 t 10 R f ( C when)2 343(use ANSI C constructs [3], which yields more readable)8 2236 2 1673 2000 t 10 CW f (character)4282 2000 w 10 R f (vari-)4852 2000 w ( both)1 203( With)1 250(ables are initialized.)2 801 3 720 2120 t 10 CW f (-A)1999 2120 w 10 R f (and)2144 2120 w 10 CW f (-R)2313 2120 w 10 R f (speci\256ed, the last example becomes)4 1428 1 2458 2120 t 9 CW f (cat *.f | f2c -A -R >mystuff.c)6 1620 1 1008 2285 t 10 R f (For use with C++ [15], one would specify)7 1677 1 720 2470 t 10 CW f (-C++)2422 2470 w 10 R f (rather than)1 429 1 2687 2470 t 10 CW f (-A)3141 2470 w 10 R f (; the last example would then become)6 1509 1 3261 2470 t 9 CW f (cat *.f | f2c -C++ -R >mystuff.c)6 1728 1 1008 2635 t 10 R f (The)720 2820 w 10 CW f (-C++)900 2820 w 10 R f ( of character strings and)4 962(option gives ANSI-style headers and old-style C formatting)7 2384 2 1165 2820 t 10 CW f (float)4537 2820 w 10 R f (con-)4863 2820 w (stants \(since some C++ compilers reject the ANSI versions of these constructs\).)11 3185 1 720 2940 t 10 R f (With ANSI C, one can use)5 1075 1 720 3099 t 10 I f (prototypes)1822 3099 w 10 R f ( the calling sequences of procedures,)5 1483(, i.e., a special syntax describing)5 1305 2 2252 3099 t ( make using prototypes convenient, the)5 1595( To)1 167( errors in argument passing.)4 1136(to help catch)2 524 4 720 3219 t 10 CW f (-P)4173 3219 w 10 R f (option causes)1 547 1 4324 3219 t 10 I f (f 2c)1 138 1 4902 3219 t 10 R f (to create a)2 431 1 720 3339 t 10 I f (\256le)1187 3339 w 10 CW f (.P)1309 3339 w 10 R f ( in each input)3 577(of prototypes for the procedures de\256ned)5 1654 2 1465 3339 t 10 I f (\256le)3733 3339 w 10 CW f (.f)3855 3339 w 10 R f (\(or)4012 3339 w 10 I f (\256le)4165 3339 w 10 CW f (.F)4287 3339 w 10 R f (, i.e., the suf\256x)3 633 1 4407 3339 t (``)720 3459 w 10 CW f (.f)786 3459 w 10 R f ('' or ``)2 271 1 906 3459 t 10 CW f (.F)1177 3459 w 10 R f ('' is replaced by ``)4 748 1 1297 3459 t 10 CW f (.P)2045 3459 w 10 R f ( into a header \256le)4 701( could concatenate all relevant prototype \256les)6 1831(''\). One)1 343 3 2165 3459 t (and arrange for the header to be)6 1279 1 720 3579 t 10 CW f (#include)2026 3579 w 10 R f ( could convert all the Fortran)5 1177( One)1 219( compiled.)1 425(d with each C \256le)4 713 4 2506 3579 t (\256les in the current directory to ANSI C and get corresponding prototype \256les by issuing the command)16 4074 1 720 3699 t 9 CW f (f2c -P -A *.f)3 702 1 1008 3864 t 10 R f ( an argument; thus to specify)5 1177(Several command options may be combined if none but perhaps the last takes)12 3143 2 720 4049 t 10 CW f (-R)720 4169 w 10 R f (and get C++ prototypes for all the \256les in the current directory, one could say either)15 3340 1 865 4169 t 9 CW f (f2c -C++ -P -R *.f)4 972 1 1008 4334 t 10 R f (or)720 4519 w 9 CW f (f2c -C++PR *.f)2 756 1 1008 4684 t 10 R f (or)720 4869 w 9 CW f (f2c -RPC++ *.f)2 756 1 1008 5034 t 10 R f (\320 options can come in any order.)6 1356 1 720 5219 t 10 R f ( data, the)2 369(For numeric variables initialized by character)5 1825 2 720 5378 t 10 CW f (-W)2942 5378 w 10 R f ( num-)1 264(option speci\256es the \(machine-dependent!\))3 1686 2 3090 5378 t ( option takes a numeric argument, as in)7 1577( This)1 229( discussed in \2476.)3 664(ber of characters per word and is further)7 1616 4 720 5498 t 10 CW f (-W8)4832 5498 w 10 R f (;)5012 5498 w (such an option must be listed either separately or at the end of a string of other options, as in)19 3690 1 720 5618 t 9 CW f (f2c -C++RPW8 *.f)2 864 1 1008 5783 t 10 B f (5. TRANSLATION DETAILS)2 1299 1 720 6034 t 10 I f (F 2c)1 163 1 970 6193 t 10 R f (is based on the ancient)4 960 1 1172 6193 t 10 I f (f)2171 6193 w 10 R f ( compiler produced a C parse-tree,)5 1449( That)1 247(77 Fortran compiler of [6].)4 1129 3 2215 6193 t ( compiler has)2 550( The)1 211( converted into input for the second pass of the portable C compiler \(PCC\) [9].)14 3227(which it)1 332 4 720 6313 t ( it provided us)3 578( Thus,)1 276( of many current Fortran compilers.)5 1430(been used for many years and is the direct ancestor)9 2036 4 720 6433 t ( converter)1 401( The)1 205( base of Fortran knowledge and a nearly complete C representation.)10 2702(with a solid)2 469 4 720 6553 t 10 I f (f 2c)1 138 1 4522 6553 t 10 R f (is a copy)2 355 1 4685 6553 t (of the)1 241 1 720 6673 t 10 I f (f)997 6673 w 10 R f ( program being)2 634(77 Fortran compiler which has been altered to print out a C representation of the)14 3365 2 1041 6673 t ( program)1 371(converted. The)1 631 2 720 6793 t 10 I f (f 2c)1 138 1 1755 6793 t 10 R f (is a)1 144 1 1926 6793 t 10 I f (horror)2103 6793 w 10 R f ( are only)2 363( Users)1 284( and hacked unmercifully.)3 1063(, based on ancient code)4 960 4 2370 6793 t (supposed to look at its C output, not at its appalling inner workings.)12 2712 1 720 6913 t 10 R f (Here are some examples that illustrate)5 1552 1 970 7072 t 10 I f (f 2c)1 138 1 2552 7072 t 10 R f ( short but)2 390( starters, it is helpful to see a)7 1178( For)1 194('s translations.)1 588 4 2690 7072 t (complete example:)1 757 1 720 7192 t 10 I f (f 2c)1 138 1 1502 7192 t 10 R f (turns the Fortran inner product routine)5 1534 1 1665 7192 t 10 R f (March 22, 1995)2 635 1 2550 7560 t cleartomark showpage saveobj restore %%EndPage: 7 8 %%Page: 8 9 /saveobj save def mark 9 pagesetup 10 R f (- 8 -)2 166 1 2797 480 t 9 CW f (FUNCTION DOT\(N,X,Y\))1 1026 1 1332 820 t (INTEGER N)1 486 1 1332 920 t (REAL X\(N\),Y\(N\))1 756 1 1332 1020 t (DOT = 0)2 378 1 1332 1120 t (DO 10 I = 1, N)5 756 1 1332 1220 t ( = DOT + X\(I\)*Y\(I\))4 972(10 DOT)1 486 2 1116 1320 t (END)1332 1420 w 10 R f (into)720 1622 w 9 CW f (/* dot.f -- translated by f2c \(version 19950314\).)7 2646 1 1008 1804 t (You must link the resulting object file with the libraries:)9 3186 1 1170 1904 t ( that order\))2 648( \(in)1 324(-lf2c -lm)1 486 3 1440 2004 t (*/)1008 2104 w (#include "f2c.h")1 864 1 1008 2304 t (doublereal dot_\(n, x, y\))3 1296 1 1008 2504 t (integer *n;)1 594 1 1008 2604 t (real *x, *y;)2 648 1 1008 2704 t ({)1008 2804 w (/* System generated locals */)4 1566 1 1224 2904 t (integer i__1;)1 702 1 1224 3004 t (real ret_val;)1 702 1 1224 3104 t (/* Local variables */)3 1134 1 1224 3304 t (static integer i;)2 918 1 1224 3404 t (/* Parameter adjustments */)3 1458 1 1224 3604 t (--y;)1224 3704 w (--x;)1224 3804 w (/* Function Body */)3 1026 1 1224 4004 t (ret_val = \(float\)0.;)2 1080 1 1224 4104 t (i__1 = *n;)2 540 1 1224 4204 t (for \(i = 1; i <= i__1; ++i\) {)8 1566 1 1224 4304 t (/* L10: */)2 540 1 1008 4404 t (ret_val += x[i] * y[i];)4 1242 1 1440 4504 t (})1224 4604 w (return ret_val;)1 810 1 1224 4704 t (} /* dot_ */)3 648 1 1008 4804 t 10 R f ( by f2c'' comment and a)5 1048(The translated C always starts with a ``translated)7 2040 2 720 5106 t 10 CW f (#include)3847 5106 w 10 R f (of)4366 5106 w 10 CW f (f2c.h)4488 5106 w 10 R f (.)4788 5106 w 10 I f (F 2c)1 163 1 4877 5106 t 10 R f ( an underscore to the external name)6 1418(forces the variable and procedure names to lower-case and appends)9 2697 2 720 5226 t 10 CW f (dot)4860 5226 w 10 R f ( parameter adjustments ``)3 1041( The)1 213(\(to avoid possible con\257icts with library names\).)6 1955 3 720 5346 t 10 CW f (--x)3929 5346 w 10 R f ('' and ``)2 342 1 4109 5346 t 10 CW f (--y)4451 5346 w 10 R f ('' account)1 409 1 4631 5346 t ( labels are retained in comments for orienteering purposes.)8 2342( Unused)1 356(for the fact that C arrays start at index 0.)9 1622 3 720 5466 t ( into references to the local variable)6 1483(Within a function, Fortran references to the function name are turned)10 2837 2 720 5586 t 10 CW f (ret_val)720 5706 w 10 R f ( the)1 150( Unless)1 325(, which holds the value to be returned.)7 1549 3 1140 5706 t 10 CW f (-R)3192 5706 w 10 R f (option is speci\256ed,)2 757 1 3339 5706 t 10 I f (f 2c)1 138 1 4123 5706 t 10 R f (converts the return)2 752 1 4288 5706 t (type of)1 291 1 720 5826 t 10 CW f (real)1047 5826 w 10 R f (function values to)2 740 1 1324 5826 t 10 CW f (doublereal)2101 5826 w 10 R f ( using the C ``op='' operators leads to greater)8 1920(. Because)1 419 2 2701 5826 t (ef\256ciency on some machines,)3 1199 1 720 5946 t 10 I f (f 2c)1 138 1 1950 5946 t 10 R f (looks for opportunities to use these operators, as in the line ``)11 2502 1 2118 5946 t 10 CW f (ret_val)4620 5946 w (+= ...)1 360 1 720 6066 t 10 R f ('' above.)1 379 1 1080 6066 t 10 I f (F 2c)1 163 1 970 6235 t 10 R f ( of evaluation)2 567(generally dispenses with super\257uous parentheses: ANSI C speci\256es a clear order)10 3307 2 1166 6235 t (for \257oating-point expressions, and)3 1401 1 720 6355 t 10 I f (f 2c)1 138 1 2156 6355 t 10 R f (uses the ANSI C rules to decide when parentheses are required to)11 2712 1 2328 6355 t ( compilers are free to violate parenthe-)6 1605( Non-ANSI)1 497(faithfully translate a parenthesized Fortran expression.)5 2218 3 720 6475 t (ses; by default,)2 614 1 720 6595 t 10 I f (f 2c)1 138 1 1365 6595 t 10 R f ( to foil pernicious non-)4 936(does not attempt to break an expression into several statements)9 2570 2 1534 6595 t ( for example, the Fortran)4 995( Thus,)1 275(ANSI C compilers.)2 769 3 720 6715 t 9 CW f (x = a*\(b*c\))2 594 1 1278 6897 t (y = \(a*b\)*c)2 594 1 1278 6997 t 10 R f (becomes)720 7199 w 10 R f (March 22, 1995)2 635 1 2550 7560 t cleartomark showpage saveobj restore %%EndPage: 8 9 %%Page: 9 10 /saveobj save def mark 10 pagesetup 10 R f (- 9 -)2 166 1 2797 480 t 9 CW f (x = a * \(b * c\);)6 864 1 1224 820 t (y = a * b * c;)6 756 1 1224 920 t 10 R f (The)720 1100 w 10 CW f (-kr)912 1100 w 10 R f (and)1129 1100 w 10 CW f (-krd)1310 1100 w 10 R f (options cause)1 554 1 1587 1100 t 10 I f (f 2c)1 138 1 2179 1100 t 10 R f (to use temporary variables to force correct evaluation order with)9 2685 1 2355 1100 t (non-ANSI C compilers.)2 952 1 720 1220 t 10 R f (Fortran I/O is complicated; like)4 1296 1 970 1376 t 10 I f (f)2301 1376 w 10 R f (77,)2345 1376 w 10 I f (f 2c)1 138 1 2505 1376 t 10 R f (converts a Fortran I/O statement into calls on the Fortran)9 2362 1 2678 1376 t (I/O library)1 426 1 720 1496 t 10 I f (libI77)1173 1496 w 10 R f ( Fortran)1 321(. For)1 216 2 1412 1496 t 10 CW f (read)1976 1496 w 10 R f (s and)1 210 1 2216 1496 t 10 CW f (write)2453 1496 w 10 R f ( to)1 104(s, there is generally one call to start the statement, one)10 2183 2 2753 1496 t ( the Fortran declarations)3 973( Given)1 294(end it, and one for each item read or written.)9 1776 3 720 1616 t 9 CW f (integer count\(10\))1 918 1 1332 1776 t (real val\(10\))1 648 1 1332 1876 t 10 R f (the Fortran)1 441 1 720 2056 t 9 CW f (read\(*,*\) count, val)2 1080 1 1332 2216 t 10 R f (is turned into some header lines:)5 1296 1 720 2396 t 9 CW f ( = 3;)2 270( _3)1 130(static integer c_)2 918 3 1008 2556 t ( = 10;)2 324( _10)1 184(static integer c_)2 918 3 1008 2656 t ( = 4;)2 270( _4)1 130(static integer c_)2 918 3 1008 2756 t (. . .)2 270 1 1008 2856 t (/* Builtin functions */)3 1242 1 1224 2956 t (integer s_rsle\(\), do_lio\(\), e_rsle\(\);)3 1998 1 1224 3056 t (. . .)2 270 1 1008 3156 t (/* Fortran I/O blocks */)4 1296 1 1224 3256 t ( = { 0, 5, 0, 0, 0 };)8 1134( _1)1 130(static cilist io_)2 918 3 1224 3356 t 10 R f (and the executable lines)3 956 1 720 3536 t 9 CW f (s_rsle\(&io_ _1\);)1 832 1 1008 3696 t ( \(char *\)&count[0], \(ftnlen\)sizeof\(integer\)\);)3 2430( _10,)1 238( &c_)1 216(do_lio\(&c_ _3,)1 724 4 1008 3796 t ( \(char *\)&val[0], \(ftnlen\)sizeof\(real\)\);)3 2160( _10,)1 238( &c_)1 216(do_lio\(&c_ _4,)1 724 4 1008 3896 t (e_rsle\(\);)1008 3996 w 10 R f (Implicit Fortran do-loops, e.g.)3 1205 1 720 4176 t 9 CW f (read\(*,*\) \(count\(i\), val\(i\), i = 1, 10\))6 2106 1 1332 4336 t 10 R f (get turned into explicit C loops:)5 1270 1 720 4516 t 9 CW f (s_rsle\(&io_ _4\);)1 832 1 1008 4676 t (for \(i = 1; i <= 10; ++i\) {)8 1458 1 1008 4776 t ( \(char *\)&count[i - 1], \(ftnlen\)sizeof\(integer\)\);)5 2646( _1,)1 184( &c_)1 216(do_lio\(&c_ _3,)1 724 4 1224 4876 t ( \(char *\)&val[i - 1], \(ftnlen\)sizeof\(real\)\);)5 2376( _1,)1 184( &c_)1 216(do_lio\(&c_ _4,)1 724 4 1224 4976 t (})1008 5076 w (e_rsle\(\);)1008 5176 w 10 R f (The Fortran)1 478 1 720 5356 t 10 CW f (end=)1227 5356 w 10 R f (and)1496 5356 w 10 CW f (err=)1669 5356 w 10 R f ( as they require tests to be)6 1067(speci\256ers make the resulting C even less readable,)7 2035 2 1938 5356 t ( example,)1 388(inserted. For)1 530 2 720 5476 t 9 CW f (read\(*,*,err=10\) count, val)2 1458 1 1332 5636 t (10 continue)1 702 1 1062 5736 t 10 R f (becomes)720 5916 w 10 R f (March 22, 1995)2 635 1 2550 7560 t cleartomark showpage saveobj restore %%EndPage: 9 10 %%Page: 10 11 /saveobj save def mark 11 pagesetup 10 R f (- 10 -)2 216 1 2772 480 t 9 CW f ( _1\);)1 238( = s_rsle\(&io_)2 756(i_ _1)1 238 3 1224 820 t ( != 0\) {)3 432( _1)1 130(if \(i_)1 324 3 1224 920 t (goto L10;)1 486 1 1440 1020 t (})1224 1120 w ( \(char *\)&count[0], \(ftnlen\)sizeof\(integer\)\);)3 2430( _10,)1 238( &c_)1 216( _3,)1 184( = do_lio\(&c_)2 702(i_ _1)1 238 6 1224 1220 t ( != 0\) {)3 432( _1)1 130(if \(i_)1 324 3 1224 1320 t (goto L10;)1 486 1 1440 1420 t (})1224 1520 w ( \(char *\)&val[0], \(ftnlen\)sizeof\(real\)\);)3 2160( _10,)1 238( &c_)1 216( _4,)1 184( = do_lio\(&c_)2 702(i_ _1)1 238 6 1224 1620 t ( != 0\) {)3 432( _1)1 130(if \(i_)1 324 3 1224 1720 t (goto L10;)1 486 1 1440 1820 t (})1224 1920 w ( = e_rsle\(\);)2 648(i_ _1)1 238 2 1224 2020 t (L10:)1008 2120 w (;)1224 2220 w 10 R f (A Fortran routine containing)3 1146 1 970 2400 t 10 I f (n)2141 2400 w 10 CW f (entry)2216 2400 w 10 R f (statements is turned into)3 975 1 2541 2400 t 10 I f (n)3542 2400 w 10 S f (+)3632 2400 w 10 R f (2 C functions, a big one contain-)6 1313 1 3727 2400 t (ing the translation of everything but the)6 1630 1 720 2520 t 10 CW f (entry)2383 2520 w 10 R f (statements, and)1 624 1 2716 2520 t 10 I f (n)3373 2520 w 10 S f (+)3463 2520 w 10 R f (1 little ones that invoke the big one.)7 1482 1 3558 2520 t ( to the big one to tell it where to begin; the big one starts with a)16 2676(Each little one passes a different integer)6 1644 2 720 2640 t ( instance, the Fortran)3 843( For)1 189(switch that branches to the code for the appropriate entry.)9 2300 3 720 2760 t 9 CW f (function sine\(x\))1 864 1 1332 2920 t (data pi/3.14159265358979324/)1 1512 1 1332 3020 t (sine = sin\(x\))2 702 1 1332 3120 t (return)1332 3220 w (entry cosneg\(y\))1 810 1 1332 3320 t (cosneg = cos\(y+pi\))2 972 1 1332 3420 t (return)1332 3520 w (end)1332 3620 w 10 R f (is turned into the big procedure)5 1251 1 720 3800 t 9 CW f ( x, y\))2 324( _,)1 130(doublereal sine_0_\(n_)1 1134 3 1008 3960 t ( _;)1 130(int n_)1 324 2 1008 4060 t (real *x, *y;)2 648 1 1008 4160 t ({)1008 4260 w (/* Initialized data */)3 1188 1 1224 4360 t (static real pi = \(float\)3.14159265358979324;)4 2376 1 1224 4560 t (/* System generated locals */)4 1566 1 1224 4760 t (real ret_val;)1 702 1 1224 4860 t (/* Builtin functions */)3 1242 1 1224 5060 t (double sin\(\), cos\(\);)2 1080 1 1224 5160 t ( {)1 108(switch\(n_ _\))1 616 2 1224 5360 t (case 1: goto L_cosneg;)3 1188 1 1440 5460 t (})1440 5560 w (ret_val = sin\(*x\);)2 972 1 1224 5760 t (return ret_val;)1 810 1 1224 5860 t (L_cosneg:)1008 6060 w (ret_val = cos\(*y + pi\);)4 1242 1 1224 6160 t (return ret_val;)1 810 1 1224 6260 t (} /* sine_ */)3 702 1 1008 6360 t 10 R f (and the little invoking procedures)4 1343 1 720 6540 t 10 R f (March 22, 1995)2 635 1 2550 7560 t cleartomark showpage saveobj restore %%EndPage: 10 11 %%Page: 11 12 /saveobj save def mark 12 pagesetup 10 R f (- 11 -)2 216 1 2772 480 t 9 CW f (doublereal sine_\(x\))1 1026 1 1008 820 t (real *x;)1 432 1 1008 920 t ({)1008 1020 w (return sine_0_\(0, x, \(real *\)0\);)4 1728 1 1224 1120 t (})1224 1220 w (doublereal cosneg_\(y\))1 1134 1 1008 1420 t (real *y;)1 432 1 1008 1520 t ({)1008 1620 w (return sine_0_\(1, \(real *\)0, y\);)4 1728 1 1224 1720 t (})1224 1820 w 10 R f (Fortran)720 2002 w 10 CW f (common)1039 2002 w 10 R f (regions are turned into C)4 993 1 1424 2002 t 10 CW f (struct)2442 2002 w 10 R f ( example, the Fortran declarations)4 1361(s. For)1 253 2 2802 2002 t 9 CW f (common /named/ c, d, r, i, m)6 1512 1 1332 2164 t (complex c\(10\))1 702 1 1332 2264 t (double precision d\(10\))2 1188 1 1332 2364 t (real r\(10\))1 540 1 1332 2464 t (integer i\(10\))1 702 1 1332 2564 t (logical m\(10\))1 702 1 1332 2664 t (if \(m\(i\(2\)\)\) d\(3\) = d\(4\)/d\(5\))4 1566 1 1332 2864 t 10 R f (result in)1 325 1 720 3046 t 9 CW f (struct {)1 432 1 1008 3208 t (complex c[10];)1 756 1 1224 3308 t (doublereal d[10];)1 918 1 1224 3408 t (real r[10];)1 594 1 1224 3508 t (integer i[10];)1 756 1 1224 3608 t (logical m[10];)1 756 1 1224 3708 t (} named_;)1 486 1 1008 3808 t (#define named_1 named_)2 1188 1 1008 4008 t (. . .)2 270 1 1008 4108 t (if \(named_1.m[named_1.i[1] - 1]\) {)4 1836 1 1224 4308 t (named_1.d[2] = named_1.d[3] / named_1.d[4];)4 2322 1 1440 4408 t (})1440 4508 w 10 R f (Under the)1 396 1 720 4690 t 10 CW f (-p)1141 4690 w 10 R f (option, the above)2 691 1 1286 4690 t 10 CW f (if)2002 4690 w 10 R f (statement becomes more readable:)3 1377 1 2147 4690 t 9 CW f (. . .)2 270 1 1008 4852 t (#define c \(named_1.c\))2 1134 1 1008 4952 t (#define d \(named_1.d\))2 1134 1 1008 5052 t (#define r \(named_1.r\))2 1134 1 1008 5152 t (#define i \(named_1.i\))2 1134 1 1008 5252 t (#define m \(named_1.m\))2 1134 1 1008 5352 t (. . .)2 270 1 1008 5452 t (if \(m[i[1] - 1]\) {)4 972 1 1224 5552 t (d[2] = d[3] / d[4];)4 1026 1 1440 5652 t 10 R f (If the above)2 476 1 720 5834 t 10 CW f (common)1221 5834 w 10 R f (block were involved in a)4 987 1 1606 5834 t 10 CW f (block data)1 600 1 2618 5834 t 10 R f (subprogram, e.g.)1 671 1 3243 5834 t 9 CW f (block data)1 540 1 1332 5996 t (common /named/ c, d, r, i, l, m)7 1674 1 1332 6096 t (complex c\(10\))1 702 1 1332 6196 t (double precision d\(10\))2 1188 1 1332 6296 t (real r\(10\))1 540 1 1332 6396 t (integer i\(10\))1 702 1 1332 6496 t (logical m\(10\))1 702 1 1332 6596 t (data c\(1\)/\(1.0,0e0\)/, d\(2\)/2d0/, r\(3\)/3e0/, i\(4\)/4/,)4 2808 1 1332 6696 t (* m\(5\)/.false./)1 1026 1 1278 6796 t (end)1332 6896 w 10 R f (then the)1 345 1 720 7078 t 10 CW f (struct)1116 7078 w 10 R f (would begin ``)2 640 1 1527 7078 t 10 CW f (struct named_1_ {)2 1072 1 2167 7078 t 10 R f ('', and)1 287 1 3239 7078 t 10 I f (f 2c)1 138 1 3578 7078 t 10 R f (would issue a more elaborate)4 1272 1 3768 7078 t 10 CW f (#define)720 7198 w 10 R f (:)1140 7198 w 10 R f (March 22, 1995)2 635 1 2550 7560 t cleartomark showpage saveobj restore %%EndPage: 11 12 %%Page: 12 13 /saveobj save def mark 13 pagesetup 10 R f (- 12 -)2 216 1 2772 480 t 9 CW f (#define named_1 \(*\(struct named_1_ *\) &named_\))5 2484 1 1008 820 t (/* Initialized data */)3 1188 1 1008 1020 t (struct {)1 432 1 1008 1220 t (complex e_1;)1 648 1 1224 1320 t (doublereal fill_2[10];)1 1188 1 1224 1420 t (doublereal e_3;)1 810 1 1224 1520 t (doublereal fill_4[9];)1 1134 1 1224 1620 t (real e_5;)1 486 1 1224 1720 t (integer fill_6[10];)1 1026 1 1224 1820 t (integer e_7;)1 648 1 1224 1920 t (integer fill_8[11];)1 1026 1 1224 2020 t (logical e_9;)1 648 1 1224 2120 t (integer fill_10[5];)1 1026 1 1224 2220 t (} named_ = { \(float\)1., \(float\)0., {0}, 2., {0}, \(float\)3., {0}, 4,)11 3618 1 1224 2320 t ( };)1 162({0}, FALSE_)1 648 2 1656 2420 t 10 R f (In this example,)2 655 1 720 2600 t 10 I f (f 2c)1 138 1 1407 2600 t 10 R f ( initialization rules to supply zeros to the)7 1686(relies on C's structure)3 900 2 1577 2600 t 10 CW f (fill_)4231 2600 w 10 I f (n)4531 2600 w 10 R f (arrays that)1 426 1 4614 2600 t (take up the space for which no)6 1261 1 720 2720 t 10 CW f (data)2013 2720 w 10 R f ( logical constants)2 706( \(The)1 244(values were given.)2 757 3 2284 2720 t 10 CW f (TRUE_)4022 2720 w 10 R f (and)4353 2720 w 10 CW f (FALSE_)4528 2720 w 10 R f (are)4919 2720 w (de\256ned in)1 397 1 720 2840 t 10 CW f (f2c.h)1142 2840 w 10 R f (.\))1442 2840 w 10 R f ( example,)1 390( For)1 191( of multiple-character strings generally result in function calls.)8 2509(Character manipulations)1 980 4 970 2996 t (the Fortran)1 441 1 720 3116 t 9 CW f (character*\(*\) function cat\(a,b\))2 1674 1 1332 3276 t (character*\(*\) a, b)2 972 1 1332 3376 t (cat = a // b)4 648 1 1332 3476 t (end)1332 3576 w 10 R f (yields)720 3756 w 9 CW f (. . .)2 270 1 1008 3916 t ( = 2;)2 270( _2)1 130(static integer c_)2 918 3 1008 4016 t (/* Character */ int cat_\(ret_val, ret_val_len, a, b, a_len, b_len\))9 3564 1 1008 4216 t (char *ret_val;)1 756 1 1008 4316 t (ftnlen ret_val_len;)1 1026 1 1008 4416 t (char *a, *b;)2 648 1 1008 4516 t (ftnlen a_len;)1 702 1 1008 4616 t (ftnlen b_len;)1 702 1 1008 4716 t ({)1008 4816 w (/* System generated locals */)4 1566 1 1224 5016 t ( _1[2];)1 346(address a_)1 540 2 1224 5116 t ( _1[2];)1 346(integer i_)1 540 2 1224 5216 t (/* Builtin functions */)3 1242 1 1224 5416 t (/* Subroutine */ int s_cat\(\);)4 1566 1 1224 5516 t (/* Writing concatenation */)3 1458 1 1008 5716 t ( = a;)2 270( _1[0])1 292( = a_len, a_)3 648(i_ _1[0])1 400 4 1224 5816 t ( = b;)2 270( _1[1])1 292( = b_len, a_)3 648(i_ _1[1])1 400 4 1224 5916 t ( ret_val_len\);)1 756( _2,)1 184( &c_)1 216( _1,)1 184( i_)1 162( _1,)1 184(s_cat\(ret_val, a_)1 918 7 1224 6016 t (} /* cat_ */)3 648 1 1008 6116 t 10 R f ( \()1 64(Note how the return-value length)4 1345 2 720 6296 t 10 CW f (ret_val_len)2129 6296 w 10 R f (\) and parameter lengths \()4 1021 1 2789 6296 t 10 CW f (a_len)3810 6296 w 10 R f (and)4141 6296 w 10 CW f (b_len)4316 6296 w 10 R f (\) are used.)2 424 1 4616 6296 t ( example, the body of the Fortran)6 1334( For)1 189(Single character operations are generally done in-line.)6 2158 3 720 6416 t 10 R f (March 22, 1995)2 635 1 2550 7560 t cleartomark showpage saveobj restore %%EndPage: 12 13 %%Page: 13 14 /saveobj save def mark 14 pagesetup 10 R f (- 13 -)2 216 1 2772 480 t 9 CW f (character*1 function lastnb\(x,n\))2 1728 1 1332 820 t (character*1 x\(n\))1 864 1 1332 920 t (lastnb = ' ')3 648 1 1332 1020 t (do 10 i = n, 1, -1)6 972 1 1332 1120 t (if \(x\(i\) .ne. ' '\) then)5 1242 1 1494 1220 t (lastnb = x\(i\))2 702 1 1656 1320 t (return)1656 1420 w (end if)1 324 1 1656 1520 t (10 continue)1 864 1 1062 1620 t (end)1332 1720 w 10 R f (becomes)720 1970 w 9 CW f (*ret_val = ' ';)3 810 1 1224 2200 t (for \(i = *n; i >= 1; --i\) {)8 1458 1 1224 2300 t (if \(x[i] != ' '\) {)5 972 1 1440 2400 t (*ret_val = x[i];)2 864 1 1656 2500 t (return ;)1 432 1 1656 2600 t (})1440 2700 w (/* L10: */)2 540 1 1008 2800 t (})1224 2900 w 10 I f (F 2c)1 163 1 970 3150 t 10 R f (uses)1159 3150 w 10 CW f (struct)1357 3150 w 10 R f (s and)1 209 1 1717 3150 t 10 CW f (#define)1952 3150 w 10 R f (s to translate)2 507 1 2372 3150 t 10 CW f (equivalence)2905 3150 w 10 R f ( complicated example show-)3 1151( a)1 70(s. For)1 254 3 3565 3150 t (ing the interaction of)3 880 1 720 3270 t 10 CW f (data)1640 3270 w 10 R f (with)1920 3270 w 10 CW f (common)2138 3270 w 10 R f (,)2498 3270 w 10 CW f (equivalence)2563 3270 w 10 R f ( good measure, Hollerith notation,)4 1427(, and, for)2 390 2 3223 3270 t (consider the Fortran)2 804 1 720 3390 t 9 CW f (common /cmname/ c)2 918 1 1332 3620 t (complex c\(10\))1 702 1 1332 3720 t (double precision d\(10\))2 1188 1 1332 3820 t (real r\(10\))1 540 1 1332 3920 t (integer i\(10\))1 702 1 1332 4020 t (logical m\(10\))1 702 1 1332 4120 t (equivalence \(c\(1\),d\(1\),r\(1\),i\(1\),m\(1\)\))1 2052 1 1332 4220 t (data c\(1\)/\(1.,0.\)/)1 972 1 1332 4320 t (data d\(2\)/2d0/, r\(5\)/3e0/, i\(6\)/4/, m\(7\)/.true./)4 2592 1 1332 4420 t (call sam\(c,d\(1\),r\(2\),i\(3\),m\(4\),14hsome hollerith,14\))2 2808 1 1332 4520 t (end)1332 4620 w 10 R f (The resulting C is)3 714 1 720 4870 t 9 CW f (. . .)2 270 1 1008 5100 t (struct cmname_1_ {)2 972 1 1008 5200 t (complex c[10];)1 756 1 1224 5300 t (};)1008 5400 w (#define cmname_1 \(*\(struct cmname_1_ *\) &cmname_\))5 2646 1 1008 5600 t (/* Initialized data */)3 1188 1 1008 5800 t (struct {)1 432 1 1008 6000 t (complex e_1;)1 648 1 1224 6100 t (doublereal e_2;)1 810 1 1224 6200 t (real e_3;)1 486 1 1224 6300 t (integer e_4;)1 648 1 1224 6400 t (logical e_5;)1 648 1 1224 6500 t (integer fill_6[13];)1 1026 1 1224 6600 t (} cmname_ = { \(float\)1., \(float\)0., 2., \(float\)3., 4, TRUE_ };)10 3348 1 1224 6700 t (/* Table of constant values */)5 1620 1 1008 7000 t ( = 14;)2 324( _14)1 184(static integer c_)2 918 3 1008 7200 t 10 R f (March 22, 1995)2 635 1 2550 7560 t cleartomark showpage saveobj restore %%EndPage: 13 14 %%Page: 14 15 /saveobj save def mark 15 pagesetup 10 R f (- 14 -)2 216 1 2772 480 t 9 CW f ( _\(\))1 184(/* Main program */ MAIN_)4 1296 2 1008 820 t ({)1008 920 w (/* Local variables */)3 1134 1 1224 1120 t (#define d \(\(doublereal *\)&cmname_1\))3 1890 1 1008 1320 t (#define i \(\(integer *\)&cmname_1\))3 1728 1 1008 1420 t (#define l \(\(logical *\)&cmname_1\))3 1728 1 1008 1520 t (#define r \(\(real *\)&cmname_1\))3 1566 1 1008 1620 t (extern /* Subroutine */ int sam_\(\);)5 1890 1 1224 1720 t ( 14L\);)1 324( _14,)1 238(sam_\(cmname_1.c, d, &r[1], &i[2], &m[3], "some hollerith", &c_)7 3348 3 1224 1920 t ( */)1 162( _)1 76(} /* MAIN_)2 540 3 1008 2020 t (#undef r)1 432 1 1008 2220 t (#undef l)1 432 1 1008 2320 t (#undef i)1 432 1 1008 2420 t (#undef d)1 432 1 1008 2520 t 10 R f (As this example shows,)3 965 1 720 2715 t 10 I f (f 2c)1 138 1 1717 2715 t 10 R f ( function named)2 665(turns a Fortran MAIN program into a C)7 1633 2 1887 2715 t 10 CW f (MAIN_ _)1 384 1 4218 2715 t 10 R f ( not)1 161(. Why)1 277 2 4602 2715 t 10 CW f (main)720 2835 w 10 R f (? Well,)1 319 1 960 2835 t 10 I f (libF77)1310 2835 w 10 R f ( for \256les to be closed automatically when the)8 1832(contains a C main routine that arranges)6 1600 2 1608 2835 t ( to be printed if a \257oating-point exception occurs, and)9 2183(Fortran program stops, arranges for an error message)7 2137 2 720 2955 t (arranges for the command-line argument accessing functions)6 2463 1 720 3075 t 10 CW f (iargc)3213 3075 w 10 R f (and)3542 3075 w 10 CW f (getarg)3715 3075 w 10 R f ( This)1 232(to work properly.)2 704 2 4104 3075 t (C main routine invokes)3 936 1 720 3195 t 10 CW f (MAIN_ _)1 384 1 1681 3195 t 10 R f (.)2065 3195 w 10 B f ( ISSUES)1 371(6. PORTABILITY)1 826 2 720 3465 t 10 R f (Three portability issues are relevant to)5 1543 1 970 3630 t 10 I f (f 2c)1 138 1 2540 3630 t 10 R f ( libraries \()2 416(: the portability of the support)5 1207 2 2678 3630 t 10 I f (libF77)4301 3630 w 10 R f (and)4596 3630 w 10 I f (libI77)4768 3630 w 10 R f (\))5007 3630 w (upon which the translated C programs rely, that of the converter)10 2559 1 720 3750 t 10 I f (f 2c)1 138 1 3304 3750 t 10 R f (itself, and that of the C it produces.)7 1407 1 3467 3750 t 10 R f ( vendors \(e.g., Sun and MIPS\) have changed the calling conventions)10 2812(Regarding the \256rst issue, some)4 1258 2 970 3915 t (for their)1 330 1 720 4035 t 10 I f (libI77)1081 4035 w 10 R f ( MIPS\) have changed the)4 1029( vendors \(e.g.,)2 580( Other)1 283(from the original conventions \(those of [6]\).)6 1797 4 1351 4035 t 10 I f (libF77)720 4155 w 10 R f (calling conventions \(e.g., for)3 1154 1 1014 4155 t 10 CW f (complex)2196 4155 w 10 R f ( having libraries)2 655( Thus,)1 278(-valued functions\).)1 757 3 2616 4155 t 10 I f (libF77)4334 4155 w 10 R f (and)4629 4155 w 10 I f (libI77)4801 4155 w 10 R f (or otherwise having library routines with the names that)8 2260 1 720 4275 t 10 I f (f 2c)1 138 1 3008 4275 t 10 R f ( using a machine)3 680( When)1 290( insuf\256cient.)1 502(expects is)1 394 4 3174 4275 t (whose vendor provides but has gratuitously changed)6 2133 1 720 4395 t 10 I f (libF77)2884 4395 w 10 R f (or)3182 4395 w 10 I f (libI77)3296 4395 w 10 R f ( objects com-)2 552(, one cannot safely mix)4 953 2 3535 4395 t (piled from the C produced by)5 1224 1 720 4515 t 10 I f (f 2c)1 138 1 1978 4515 t 10 R f (with objects compiled by the vendor's Fortran compiler, and one must)10 2891 1 2149 4515 t (use the correct libraries with programs translated by)7 2104 1 720 4635 t 10 I f (f 2c)1 138 1 2853 4635 t 10 R f ( is to)2 205( such a case, the recommended procedure)6 1682(. In)1 162 3 2991 4635 t (obtain source for the libraries \(e.g. from)6 1602 1 720 4755 t 10 I f (netlib)2348 4755 w 10 R f ( them into a single library, say)6 1213(\320 see \2478\), combine)3 807 2 2610 4755 t 10 CW f (libf2c)4655 4755 w 10 R f (,)5015 4755 w ( a UNIX system, for example, one)6 1429( On)1 182(and install the library where it they can be conveniently accessed.)10 2709 3 720 4875 t (might install)1 504 1 720 4995 t 10 CW f (libf2c)1249 4995 w 10 R f (in)1634 4995 w 10 CW f (/usr/lib/libf2c.a)1737 4995 w 10 R f (; then one could issue the command)6 1432 1 2757 4995 t 9 CW f (cc *.c -lf2c -lm)3 864 1 1008 5170 t 10 R f (to compile and link a program translated by)7 1745 1 720 5365 t 10 I f (f 2c)1 138 1 2490 5365 t 10 R f (.)2628 5365 w 10 R f ( IBM, MIPS,)2 549(The converter itself is reasonably portable and has run successfully on Apollo, Cray,)12 3521 2 970 5530 t ( However,)1 448( UNIX operating system.)3 1028(SGI, Sun and DEC VAX equipment, all running some version of the)11 2844 3 720 5650 t ( be portable due to subtle storage management issues in Fortran)10 2581(we shall see that the C it produces may not)9 1739 2 720 5770 t ( any case, the C output of)6 1036(77. In)1 261 2 720 5890 t 10 I f (f 2c)1 138 1 2045 5890 t 10 R f ( least if the)3 447(will run \256ne, at)3 620 2 2211 5890 t 10 CW f (-W)3305 5890 w 10 I f (n)3425 5890 w 10 R f (option \(see Appendix B\) is used to set)7 1538 1 3502 5890 t (the number of characters per word correctly, and if C)9 2121 1 720 6010 t 10 CW f (double)2866 6010 w 10 R f (values may fall on an odd-word boundary.)6 1694 1 3251 6010 t 10 R f (The Fortran 77 standard says that)5 1474 1 970 6175 t 10 CW f (Complex)2497 6175 w 10 R f (and)2970 6175 w 10 CW f (Double Precision)1 989 1 3168 6175 t 10 R f (objects occupy two)2 829 1 4211 6175 t ( may be necessary to edit the)6 1177( It)1 116(``units'' of space while other non-character data types occupy one ``unit.'')10 3027 3 720 6295 t (header \256le)1 430 1 720 6415 t 10 CW f (f2c.h)1187 6415 w 10 R f ( the Cray, for example,)4 972( On)1 185(to make these assumptions hold, if possible.)6 1839 3 1524 6415 t 10 CW f (float)4558 6415 w 10 R f (and)4896 6415 w 10 CW f (double)720 6535 w 10 R f ( C types, and Fortran double precision, if available, would correspond to the C type)14 3416(are the same)2 512 2 1112 6535 t 10 CW f (long double)1 660 1 720 6655 t 10 R f ( this case, changing the de\256nition of)6 1446(. In)1 158 2 1380 6655 t 10 CW f (doublereal)3009 6655 w 10 R f (in)3634 6655 w 10 CW f (f2c.h)3737 6655 w 10 R f (from)4062 6655 w 9 CW f (typedef double doublereal;)2 1404 1 1008 6830 t 10 R f (to)720 7025 w 9 CW f (typedef long double doublereal;)3 1674 1 1008 7200 t 10 R f (March 22, 1995)2 635 1 2550 7560 t cleartomark showpage saveobj restore %%EndPage: 14 15 %%Page: 15 16 /saveobj save def mark 16 pagesetup 10 R f (- 15 -)2 216 1 2772 480 t ( the Think C compiler on the Macintosh, on the other hand, this line would need)15 3251( For)1 192(would be appropriate.)2 877 3 720 840 t (to become)1 413 1 720 960 t 9 CW f (typedef short double doublereal;)3 1728 1 1008 1135 t 10 R f ( prede\256nes symbols that could clash with translated Fortran variable names, then)11 3306(If your C compiler)3 764 2 970 1330 t ( appropriate)1 480(you should also add)3 803 2 720 1450 t 10 CW f (#undef)2029 1450 w 10 R f (lines to)1 293 1 2415 1450 t 10 CW f (f2c.h)2734 1450 w 10 R f ( current default)2 611(. The)1 231 2 3034 1450 t 10 CW f (f2c.h)3902 1450 w 10 R f (provides the follow-)2 812 1 4228 1450 t (ing)720 1570 w 10 CW f (#undef)873 1570 w 10 R f (lines for the following symbols:)4 1278 1 1258 1570 t 10 CW f ( u370 u3b5)2 780( sun2)1 510( sgi)1 330(cray mc68020)1 990 4 1575 1765 t ( unix)1 450( sun3 u3b)2 720(gcos mips sparc)2 1440 3 1575 1885 t ( u3b2 vax)2 720( sun sun4)2 960(mc68010 pdp11)1 870 3 1575 2005 t 10 R f (As an extension to the Fortran 77 Standard,)7 1786 1 970 2200 t 10 I f (f 2c)1 138 1 2788 2200 t 10 R f ( variables to be initialized with)5 1275(allows noncharacter)1 807 2 2958 2200 t ( extension is inherently nonportable, as the number of characters storable per ``unit'')12 3492( This)1 238(character data.)1 590 3 720 2320 t ( 32 bit machines are the most plentiful,)7 1560( Since)1 272(varies from machine to machine.)4 1311 3 720 2440 t 10 I f (f 2c)1 138 1 3888 2440 t 10 R f ( per)1 153(assumes 4 characters)2 836 2 4051 2440 t (Fortran ``unit'', but this assumption can be overridden by the)9 2573 1 720 2560 t 10 CW f (-W)3332 2560 w 10 I f (n)3452 2560 w 10 R f ( example,)1 401( For)1 202(command-line option.)1 896 3 3541 2560 t 10 CW f (-W8)720 2680 w 10 R f ( An)1 177( Cray computers, since Crays store 8 characters per word.)9 2347(is appropriate for C that is to be run on)9 1587 3 929 2680 t ( Fortran)1 319( the)1 172(example is helpful here:)3 962 3 720 2800 t 9 CW f (data i/'abcd'/)1 756 1 1332 2975 t (j = i)2 270 1 1332 3075 t (end)1332 3175 w 10 R f (turns into)1 381 1 720 3370 t 9 CW f (/* Initialized data */)3 1188 1 1224 3545 t (static struct {)2 810 1 1224 3745 t (char e_1[4];)1 648 1 1440 3845 t (} equiv_3 = { {'a', 'b', 'c', 'd'} };)8 1998 1 1440 3945 t (#define i \(*\(integer *\)&equiv_3\))3 1728 1 1008 4145 t (static integer j;)2 918 1 1224 4345 t (j = i;)2 324 1 1224 4545 t (. . .)2 270 1 1008 4645 t (#undef i)1 432 1 1008 4745 t 10 R f (\(Some use of)2 533 1 720 4940 t 10 CW f (i)1281 4940 w 10 R f (, e.g. ``)2 291 1 1341 4940 t 10 CW f (j = i)2 306 1 1632 4940 t 10 R f ('', is necessary or)3 712 1 1938 4940 t 10 I f (f 2c)1 138 1 2678 4940 t 10 R f (will see that)2 489 1 2844 4940 t 10 CW f (i)3361 4940 w 10 R f ( If)1 120( and will not initialize it.\))5 1037(is not used)2 434 3 3449 4940 t ( Cray and the string were)5 1086(the target machine were a)4 1092 2 720 5060 t 10 CW f ('abcdefgh')2939 5060 w 10 R f (or)3580 5060 w 10 CW f ("abcdefhg")3704 5060 w 10 R f (, then the Fortran)3 736 1 4304 5060 t (would run \256ne, but the C produced by)7 1577 1 720 5180 t 10 I f (f 2c)1 138 1 2330 5180 t 10 R f (would only store)2 688 1 2501 5180 t 10 CW f ("abcd")3222 5180 w 10 R f ( the default number of)4 923(in i, 4 being)3 502 2 3615 5180 t ( The)1 205(characters per word.)2 810 2 720 5300 t 10 I f (f 2c)1 138 1 1760 5300 t 10 R f (command-line option)1 858 1 1923 5300 t 10 CW f (-W8)2806 5300 w 10 R f (gives the correct initialization for a Cray.)6 1644 1 3011 5300 t 10 R f ( the option)2 438( Using)1 294(The initialization above is clumsy, using 4 separate characters.)8 2533 3 970 5465 t 10 CW f (-A)4265 5465 w 10 R f (, for ANSI, pro-)3 655 1 4385 5465 t (duces)720 5585 w 9 CW f (. . .)2 270 1 1008 5760 t (} equiv_3 = { "abcd" };)5 1242 1 1440 5860 t (. . .)2 270 1 1008 5960 t 10 R f (See Appendix B.)2 680 1 720 6155 t 10 R f ( examples explain why the Fortran 77 standard excludes Hollerith data statements: the)12 3637(The above)1 433 2 970 6320 t ( \(For-)1 261( not speci\256ed and hence such code is not portable even in Fortran.)12 2709(number of characters per word is)5 1350 3 720 6440 t ( that Fortran)2 508( Note)1 251(tran that conservatively assumes only 1 or 2 characters per word is portable but messy.)14 3561 3 720 6560 t (77 forbids the mixing, via)4 1056 1 720 6680 t 10 CW f (common)1806 6680 w 10 R f (,)2166 6680 w 10 CW f (data)2221 6680 w 10 R f (, or)1 138 1 2461 6680 t 10 CW f (equivalence)2629 6680 w 10 R f ( Like)1 237( noncharacter types.)2 808(, of character and)3 706 3 3289 6680 t (many Fortran compilers,)2 987 1 720 6800 t 10 I f (f 2c)1 138 1 1733 6800 t 10 R f (permits such nonportable mixing; initialization of numeric variables with Hol-)9 3143 1 1897 6800 t (lerith data is one example of this mixing.\))7 1671 1 720 6920 t 10 R f (Some Fortran 66 programs pass Hollerith strings to)7 2052 1 970 7085 t 10 CW f (integer)3047 7085 w 10 R f (variables.)3492 7085 w 10 I f (F 2c)1 163 1 3927 7085 t 10 R f ( string)1 254(treats a Hollerith)2 671 2 4115 7085 t ( systems if the character string winds up being)8 1869(as a character string, but this may lead to bus errors on some)12 2451 2 720 7205 t 10 R f (March 22, 1995)2 635 1 2550 7560 t cleartomark showpage saveobj restore %%EndPage: 15 16 %%Page: 16 17 /saveobj save def mark 17 pagesetup 10 R f (- 16 -)2 216 1 2772 480 t ( The)1 212(improperly aligned.)1 795 2 720 840 t 10 CW f (-h)1759 840 w 10 R f (option instructs)1 627 1 1911 840 t 10 I f (f 2c)1 138 1 2570 840 t 10 R f ( character variables and constants the same)6 1765(to try to give)3 535 2 2740 840 t (alignment as)1 508 1 720 960 t 10 CW f (integer)1253 960 w 10 R f (s. Under)1 363 1 1673 960 t 10 CW f (-h)2061 960 w 10 R f ( Fortran)1 319( the)1 172(, for example,)2 554 3 2181 960 t 9 CW f (call foo\("a string"\))2 1080 1 1332 1120 t (call goo\(8ha string\))2 1080 1 1332 1220 t 10 R f (is translated to)2 583 1 720 1400 t 9 CW f (static struct { integer fill; char val[8+1]; char fill2[3]; } c_b1_st = { 0,)13 4104 1 1008 1560 t ("a string" };)2 702 1 1440 1660 t (#define c_b1 c_b1_st.val)2 1296 1 1008 1760 t (. . .)2 270 1 1008 1860 t (foo_\(c_b1, 8L\);)1 810 1 1224 1960 t (goo_\(c_b1, 8L\);)1 810 1 1224 2060 t (. . .)2 270 1 1008 2160 t 10 R f (Some systems require that C values of type)7 1736 1 970 2340 t 10 CW f (double)2732 2340 w 10 R f ( Fortran)1 346( double-word boundary.)2 966(be aligned on a)3 610 3 3118 2340 t 10 CW f (common)720 2460 w 10 R f (and)1117 2460 w 10 CW f (equivalence)1298 2460 w 10 R f ( require some C)3 668(statements may)1 631 2 1995 2460 t 10 CW f (double)3330 2460 w 10 R f (values to be aligned on an odd-)6 1314 1 3726 2460 t ( if nec-)2 294( systems where double-word alignment is required, C compilers pad structures,)10 3212( On)1 177(word boundary.)1 637 4 720 2580 t ( validity of)2 441( such padding has no effect on the)7 1375( Often)1 279(essary, to arrange for the right alignment.)6 1664 4 720 2700 t 10 I f (f 2c)1 138 1 4505 2700 t 10 R f ('s transla-)1 397 1 4643 2700 t ( using)1 243(tion, but)1 334 2 720 2820 t 10 CW f (common)1323 2820 w 10 R f (or)1709 2820 w 10 CW f (equivalence)1818 2820 w 10 R f (, it is easy to contrive examples in which the translated C works)12 2562 1 2478 2820 t (incorrectly.)720 2940 w 10 I f (F 2c)1 163 1 1233 2940 t 10 R f ( may cause trouble, but, like)5 1154(issues a warning message when double-word alignment)6 2260 2 1427 2940 t 10 I f (f)4871 2940 w 10 R f (77,)4915 2940 w (it makes no attempt to circumvent this trouble; the run-time costs of circumvention would be substantial.)15 4192 1 720 3060 t 10 R f (Long decimal strings in)3 950 1 970 3216 t 10 CW f (data)1946 3216 w 10 R f ( expressions involving)2 904( However,)1 442( C unaltered.)2 517(statements are passed to)3 965 4 2212 3216 t ( a VAX 8550, the Fortran)5 1026( On)1 172(long decimal strings are rounded in a machine-dependent manner.)8 2636 3 720 3336 t 9 CW f (x=1.2**10)1332 3496 w (end)1332 3596 w 10 R f (yields the C)2 478 1 720 3776 t 9 CW f (static real x;)2 756 1 1224 3936 t (x = \(float\)6.1917364224000008;)2 1620 1 1224 4136 t 10 R f ( external scope, such as the)5 1156(ANSI C compilers require that all but one instance of any entity with)12 2914 2 970 4316 t 10 CW f (struct)720 4436 w 10 R f (s into which)2 497 1 1080 4436 t 10 I f (f 2c)1 138 1 1605 4436 t 10 R f (translates)1771 4436 w 10 CW f (common)2176 4436 w 10 R f (, be declared)2 512 1 2536 4436 t 10 CW f (extern)3076 4436 w 10 R f (and that exactly one declaration should)5 1576 1 3464 4436 t (de\256ne the entity, i.e., should not be declared)7 1830 1 720 4556 t 10 CW f (extern)2584 4556 w 10 R f ( restriction.)1 465( older C compilers have no such)6 1341(. Most)1 290 3 2944 4556 t ( with ANSI usage, the)4 905(To be compatible)2 711 2 720 4676 t 10 I f (f 2c)1 138 1 2366 4676 t 10 R f (command-line option)1 863 1 2534 4676 t 10 CW f (-ec)3427 4676 w 10 R f (causes the)1 412 1 3637 4676 t 10 CW f (struct)4079 4676 w 10 R f (corresponding)4469 4676 w (to an uninitialized)2 734 1 720 4796 t 10 CW f (common)1485 4796 w 10 R f (region to be declared)3 857 1 1876 4796 t 10 CW f (extern)2764 4796 w 10 R f (and makes a)2 505 1 3155 4796 t 10 CW f (union)3691 4796 w 10 R f ( declara-)1 352(of all successive)2 666 2 4022 4796 t (tions of that)2 498 1 720 4916 t 10 CW f (common)1288 4916 w 10 R f (region into a de\256ning declaration placed in a \256le with the name)11 2637 1 1683 4916 t 10 CW f (cname_com.c)4355 4916 w 10 R f (,)5015 4916 w (where)720 5036 w 10 CW f (cname)988 5036 w 10 R f (is the name of the)4 710 1 1313 5036 t 10 CW f (common)2048 5036 w 10 R f ( example, the Fortran)3 854(region. For)1 469 2 2433 5036 t 9 CW f (common /cmname/ c)2 918 1 1332 5196 t (complex c\(10\))1 702 1 1332 5296 t (c\(1\)=cmplx\(1.,0.\))1332 5396 w (call sam\(c\))1 594 1 1332 5496 t (end)1332 5596 w (subroutine sam\(c\))1 918 1 1332 5696 t (complex c)1 486 1 1332 5796 t (common /cmname/ca)1 918 1 1332 5896 t (complex ca\(10\))1 756 1 1332 5996 t (ca\(2\) = cmplx\(1e0,2e0\))2 1188 1 1332 6096 t (return)1332 6196 w (end)1332 6296 w 10 R f (when converted by)2 759 1 720 6476 t 10 CW f (f2c -ec)1 420 1 1504 6476 t 10 R f (produces)1949 6476 w 10 R f (March 22, 1995)2 635 1 2550 7560 t cleartomark showpage saveobj restore %%EndPage: 16 17 %%Page: 17 18 /saveobj save def mark 18 pagesetup 10 R f (- 17 -)2 216 1 2772 480 t 9 CW f (/* Common Block Declarations */)4 1674 1 1008 820 t (union {)1 378 1 1008 1020 t (struct {)1 432 1 1224 1120 t (complex c[10];)1 756 1 1440 1220 t (} _1;)1 270 1 1224 1320 t (struct {)1 432 1 1224 1420 t (complex ca[10];)1 810 1 1440 1520 t (} _2;)1 270 1 1224 1620 t (} cmname_;)1 540 1 1008 1720 t (#define cmname_1 \(cmname_._1\))2 1566 1 1008 1920 t (#define cmname_2 \(cmname_._2\))2 1566 1 1008 2020 t ( _\(\))1 184(/* Main program */ MAIN_)4 1296 2 1008 2220 t ({)1008 2320 w (extern /* Subroutine */ int sam_\(\);)5 1890 1 1224 2520 t (cmname_1.c[0].r = \(float\)1., cmname_1.c[0].i = \(float\)0.;)5 3078 1 1224 2720 t (sam_\(cmname_1.c\);)1224 2820 w ( */)1 162( _)1 76(} /* MAIN_)2 540 3 1008 2920 t (/* Subroutine */ int sam_\(c\))4 1512 1 1008 3120 t (complex *c;)1 594 1 1008 3220 t ({)1008 3320 w (cmname_2.ca[1].r = \(float\)1., cmname_2.ca[1].i = \(float\)2.;)5 3186 1 1224 3420 t (return 0;)1 486 1 1224 3520 t (} /* sam_ */)3 648 1 1008 3620 t 10 R f (as well as the \256le)4 688 1 720 3814 t 10 CW f (cmname_com.c)1433 3814 w 10 R f (:)2153 3814 w 9 CW f (#include "f2c.h")1 864 1 1008 3988 t (union {)1 378 1 1008 4088 t (struct {)1 432 1 1224 4188 t (complex c[10];)1 756 1 1440 4288 t (} _1;)1 270 1 1224 4388 t (struct {)1 432 1 1224 4488 t (complex ca[10];)1 810 1 1440 4588 t (} _2;)1 270 1 1224 4688 t (} cmname_;)1 540 1 1008 4788 t 10 R f (The \256les)1 352 1 720 4982 t 10 CW f (*_com.c)1102 4982 w 10 R f (may be compiled into a library against which one can load to satisfy overly fastidious)14 3488 1 1552 4982 t (ANSI C compilers.)2 769 1 720 5102 t 10 R f (The rules of Fortran 77 apparently permit a situation in which)10 2539 1 970 5267 t 10 I f (f 2c)1 138 1 3541 5267 t 10 R f (declares a function to be of type)6 1328 1 3712 5267 t 10 CW f (int)720 5387 w 10 R f ( that example,)2 563( In)1 134(, then de\256nes it to be of another type, as illustrated by the \256rst example in \2477.)16 3105 3 900 5387 t 10 I f (f 2c)1 138 1 4727 5387 t 10 R f (dis-)4890 5387 w (covers too late that)3 757 1 720 5507 t 10 CW f (f)1502 5507 w 10 R f ( than a warning)3 621( some C compilers, this causes nothing worse)7 1821( With)1 250(is not a subroutine.)3 761 4 1587 5507 t ( unforgiving C compilers, one can usu-)6 1580( With)1 254(message; with others, it causes the compilation to be aborted.)9 2486 3 720 5627 t ( e.g., with the)3 574(ally avoid trouble by splitting the Fortran source into one \256le per procedure,)12 3146 2 720 5747 t 10 I f (fsplit)4475 5747 w 10 R f (\(1\) com-)1 356 1 4684 5747 t ( solution is to use prototypes, as discussed in \2477.)9 1942( Another)1 377(mand, and converting each procedure separately.)5 1952 3 720 5867 t 10 R f ( consistent prototype declarations across separate compilations,)6 2544(With an ANSI C system that enforced)6 1526 2 970 6032 t ( translate the main program correctly in the last example just by looking at the)14 3264(it would be impossible to)4 1056 2 720 6152 t ( do enforce the consistency of prototype declarations across separate)9 2770( C++ compilers)2 629( Recent)1 330(main program.)1 591 4 720 6272 t ( sequences into the translated names of functions, except for func-)10 2731(compilations, e.g., by encoding calling)4 1589 2 720 6392 t (tions that are declared)3 902 1 720 6512 t 10 CW f (extern "C")1 608 1 1655 6512 t 10 R f (and compiled separately.)2 1013 1 2297 6512 t 10 I f (F 2c)1 163 1 3369 6512 t 10 R f (allows one to use this escape hatch:)6 1474 1 3566 6512 t (under)720 6632 w 10 CW f (-C++)972 6632 w 10 R f (,)1212 6632 w 10 I f (f 2c)1 138 1 1262 6632 t 10 R f (inserts)1425 6632 w 9 CW f ( _cplusplus)1 562(#ifdef _)1 432 2 1008 6806 t (extern "C" {)2 648 1 1008 6906 t (#endif)1008 7006 w 10 R f (at the beginning of its C++ output and places)8 1800 1 720 7200 t 10 R f (March 22, 1995)2 635 1 2550 7560 t cleartomark showpage saveobj restore %%EndPage: 17 18 %%Page: 18 19 /saveobj save def mark 19 pagesetup 10 R f (- 18 -)2 216 1 2772 480 t 9 CW f ( _cplusplus)1 562(#ifdef _)1 432 2 1008 820 t (})1440 920 w (#endif)1008 1020 w 10 R f ( The)1 207(at the end of its C++ output.)6 1138 2 720 1223 t 10 CW f ( _cplusplus)1 624(#ifdef _)1 482 2 2092 1223 t 10 R f ( compil-)1 339(lines are for the bene\256t of older C++)7 1476 2 3225 1223 t (ers that do not recognize)4 981 1 720 1343 t 10 CW f (extern "C")1 600 1 1726 1343 t 10 R f (.)2326 1343 w 10 B f (7. PROTOTYPES)1 779 1 720 1629 t 10 R f (In ANSI C and C++, a)5 935 1 970 1799 t 10 I f (prototype)1937 1799 w 10 R f ( can save)2 381( Prototypes)1 486(describes the calling sequence of a function.)6 1813 3 2360 1799 t ( The)1 215( calling sequences.)2 771(debugging time by helping catch errors in)6 1736 3 720 1919 t 10 CW f (-P)3477 1919 w 10 R f (option instructs)1 630 1 3632 1919 t 10 I f (f 2c)1 138 1 4297 1919 t 10 R f (to emit proto-)2 570 1 4470 1919 t ( all the functions de\256ned in the C it produces; speci\256cally,)10 2409(types for)1 359 2 720 2039 t 10 I f (f 2c)1 138 1 3521 2039 t 10 R f (creates a)1 353 1 3692 2039 t 10 I f (\256le)4078 2039 w 10 CW f (.P)4200 2039 w 10 R f (of prototypes for)2 687 1 4353 2039 t (each input)1 417 1 720 2159 t 10 I f (\256le)1166 2159 w 10 CW f (.f)1288 2159 w 10 R f (or)1437 2159 w 10 I f (\256le)1549 2159 w 10 CW f (.F)1671 2159 w 10 R f ( can then arrange for relevant prototype \256les to be seen by the C compiler.)14 3005(. One)1 244 2 1791 2159 t (For instance, if)2 634 1 720 2279 t 10 I f (f 2c)1 138 1 1395 2279 t 10 R f ('s header \256le)2 547 1 1533 2279 t 10 CW f (f2c.h)2122 2279 w 10 R f (is installed as)2 573 1 2464 2279 t 10 CW f (/usr/include/f2c.h)3079 2279 w 10 R f (, one could issue the)4 881 1 4159 2279 t (UNIX command)1 668 1 720 2399 t 9 CW f (cat /usr/include/f2c.h *.P >f2c.h)3 1782 1 1008 2582 t 10 R f (to create a local copy of)5 1020 1 720 2785 t 10 CW f (f2c.h)1778 2785 w 10 R f (that has in it all the prototypes in)7 1405 1 2116 2785 t 10 CW f (*.P)3559 2785 w 10 R f ( produced by)2 549( the C)2 265(. Since)1 310 3 3739 2785 t 10 I f (f 2c)1 138 1 4902 2785 t 10 R f (always speci\256es)1 646 1 720 2905 t 9 CW f (#include "f2c.h")1 864 1 1008 3088 t 10 R f (\(rather than)1 465 1 720 3291 t 10 CW f (#include )1 963 1 1213 3291 t 10 R f ( the current directory for)4 996(\), the C compiler will look \256rst in)7 1366 2 2176 3291 t 10 CW f (f2c.h)4567 3291 w 10 R f (and)4896 3291 w (thus will \256nd the local copy that contains the prototypes.)9 2266 1 720 3411 t 10 I f (F 2c)1 163 1 970 3581 t 10 R f ( to)1 104(can also read the prototype \256les it writes; one simply speci\256es them as arguments)13 3255 2 1158 3581 t 10 I f (f 2c)1 138 1 4543 3581 t 10 R f ( fact,)1 200(. In)1 159 2 4681 3581 t 10 I f (f 2c)1 138 1 720 3701 t 10 R f ( multiple Fortran \256les are handled indepen-)6 1779(reads all prototype \256les before any Fortran \256les; although)8 2369 2 892 3701 t (dently, any prototype \256le arguments apply to all of them.)9 2396 1 720 3821 t 10 I f (F 2c)1 163 1 3179 3821 t 10 R f ( Fortran)1 333(has more detailed knowledge of)4 1327 2 3380 3821 t ( it conveys in the C it puts out; for example,)10 1758(types than)1 409 2 720 3941 t 10 CW f (logical)2912 3941 w 10 R f (and)3357 3941 w 10 CW f (integer)3526 3941 w 10 R f (are different Fortran types,)3 1069 1 3971 3941 t ( Moreover,)1 470(but are mapped to the same C type.)7 1423 2 720 4061 t 10 CW f (character)2640 4061 w 10 R f (,)3180 4061 w 10 CW f (complex)3232 4061 w 10 R f (, and)1 196 1 3652 4061 t 10 CW f (double complex)1 843 1 3875 4061 t 10 R f (Fortran)4746 4061 w ( translated to)2 540(functions are all)2 669 2 720 4181 t 10 CW f (VOID)1966 4181 w 10 R f (C functions, and, unless the)4 1153 1 2243 4181 t 10 CW f (-R)3433 4181 w 10 R f (option is speci\256ed, both)3 992 1 3590 4181 t 10 CW f (real)4619 4181 w 10 R f (and)4896 4181 w 10 CW f (double precision)1 987 1 720 4301 t 10 R f (Fortran functions are translated to)4 1461 1 1759 4301 t 10 CW f (doublereal)3272 4301 w 10 R f ( Because)1 409(C functions.)1 516 2 3924 4301 t 10 I f (f 2c)1 138 1 4902 4301 t 10 R f ( ANSI C)2 362(denotes all these types differently in its prototype \256les, it can catch errors that are invisible to an)17 3958 2 720 4421 t (\(or C++\) compiler.)2 758 1 720 4541 t 10 R f (The following table shows the types that)6 1621 1 970 4711 t 10 I f (f 2c)1 138 1 2616 4711 t 10 R f (uses for procedure arguments:)3 1205 1 2779 4711 t 10 S f (_ _________________________________________________)1 2491 1 1634 4814 t 10 CW f (C_fp complex)1 810 1 1684 4934 t (D_fp doublereal)1 990 1 1684 5054 t (E_fp real)1 630 1 1684 5174 t 10 R f (under)2339 5174 w 10 CW f (-!R)2591 5174 w 10 R f (\(the default\))1 490 1 2796 5174 t 10 CW f (H_fp character)1 930 1 1684 5294 t (I_fp integer)1 810 1 1684 5414 t 10 R f (or)2519 5414 w 10 CW f (integer*4)2627 5414 w (J_fp integer*2)1 930 1 1684 5534 t (K_fp shortlogical)1 1110 1 1684 5654 t 10 R f (\()2819 5654 w 10 CW f (logical)2852 5654 w 10 R f (under)3297 5654 w 10 CW f (-i2)3549 5654 w 10 R f (or)3754 5654 w 10 CW f (-I2)3862 5654 w 10 R f (\))4042 5654 w 10 CW f (L_fp logical)1 810 1 1684 5774 t (R_fp real)1 630 1 1684 5894 t 10 R f (under)2339 5894 w 10 CW f (-R)2591 5894 w (S_fp subroutine)1 990 1 1684 6014 t (U_fp)1684 6134 w 10 R f (untyped)2074 6134 w 10 CW f (external)2421 6134 w (Z_fp doublecomplex)1 1170 1 1684 6254 t 10 S f ( \347)1 -2491(_ _________________________________________________)1 2491 2 1634 6274 t (\347)1634 6214 w (\347)1634 6114 w (\347)1634 6014 w (\347)1634 5914 w (\347)1634 5814 w (\347)1634 5714 w (\347)1634 5614 w (\347)1634 5514 w (\347)1634 5414 w (\347)1634 5314 w (\347)1634 5214 w (\347)1634 5114 w (\347)1634 5014 w (\347)1634 4914 w (\347)4125 6274 w (\347)4125 6214 w (\347)4125 6114 w (\347)4125 6014 w (\347)4125 5914 w (\347)4125 5814 w (\347)4125 5714 w (\347)4125 5614 w (\347)4125 5514 w (\347)4125 5414 w (\347)4125 5314 w (\347)4125 5214 w (\347)4125 5114 w (\347)4125 5014 w (\347)4125 4914 w 10 R f (These types are de\256ned in)4 1086 1 720 6477 t 10 CW f (f2c.h)1842 6477 w 10 R f ( and, under)2 470(; they appear in prototypes)4 1109 2 2142 6477 t 10 CW f (-A)3758 6477 w 10 R f (or)3915 6477 w 10 CW f (-C++)4035 6477 w 10 R f (, in the C that)4 590 1 4275 6477 t 10 I f (f 2c)1 138 1 4902 6477 t 10 R f ( also use special)3 664(writes. Prototypes)1 753 2 720 6597 t 10 CW f (void)2167 6597 w 10 R f (types to denote the return values of)6 1433 1 2437 6597 t 10 CW f (complex)3900 6597 w 10 R f (,)4320 6597 w 10 CW f (double com-)1 665 1 4375 6597 t (plex)720 6717 w 10 R f (, and)1 194 1 960 6717 t 10 CW f (character)1179 6717 w 10 R f (functions:)1744 6717 w 10 S f (_ _________________________)1 1270 1 2245 6820 t 10 CW f (C_f complex)1 750 1 2295 6940 t (H_f character)1 870 1 2295 7060 t ( complex)1 480(Z_f double)1 690 2 2295 7180 t 10 S f ( \347)1 -1270(_ _________________________)1 1270 2 2245 7200 t (\347)2245 7120 w (\347)2245 7020 w (\347)2245 6920 w (\347)3515 7200 w (\347)3515 7120 w (\347)3515 7020 w (\347)3515 6920 w 10 R f (March 22, 1995)2 635 1 2550 7560 t cleartomark showpage saveobj restore %%EndPage: 18 19 %%Page: 19 20 /saveobj save def mark 20 pagesetup 10 R f (- 19 -)2 216 1 2772 480 t 10 I f (F 2c)1 163 1 970 840 t 10 R f (also writes special comments in prototype \256les giving the length of each)11 2955 1 1164 840 t 10 CW f (common)4150 840 w 10 R f (block; when)1 498 1 4542 840 t ( arguments,)1 472(given prototype \256les as)3 951 2 720 960 t 10 I f (f 2c)1 138 1 2174 960 t 10 R f (reads these special comments so it can issue a warning message if)11 2697 1 2343 960 t (its Fortran input speci\256es a different length for some)8 2103 1 720 1080 t 10 CW f (common)2848 1080 w 10 R f (block.)3233 1080 w 10 R f ( speci\256es different lengths for a)5 1341(Sometimes people write otherwise valid Fortran 77 that)7 2328 2 970 1243 t 10 CW f (common)4680 1243 w 10 R f ( and converted to C, the loader could end up giving too little)12 2436( such Fortran is split into several \256les)7 1518(block. If)1 366 3 720 1363 t (space to the)2 499 1 720 1483 t 10 CW f (common)1258 1483 w 10 R f ( the confusion this could cause by running)7 1795( can avoid)2 438( One)1 230(block in question.)2 742 4 1657 1483 t 10 I f (f 2c)1 138 1 4902 1483 t 10 R f (twice, \256rst with)2 647 1 720 1603 t 10 CW f (-P!c)1402 1603 w 10 R f (, then with the resulting prototypes as additional arguments; the prototypes let)11 3225 1 1642 1603 t 10 I f (f 2c)1 138 1 4902 1603 t 10 R f (determine \(and convey to all of its output C \256les\) the true length needed for each)15 3225 1 720 1723 t 10 CW f (common)3970 1723 w 10 R f (block.)4355 1723 w 10 R f ( a procedure to be)4 762(One complication with prototypes comes from Fortran subprograms that declare)9 3308 2 970 1886 t 10 CW f (external)720 2006 w 10 R f ( specify a type for it and only pass it as a parameter to another procedure.)15 2986(but do not explicitly)3 824 2 1230 2006 t (\(If the subprogram also invokes the)5 1417 1 720 2126 t 10 CW f (external)2162 2126 w 10 R f (procedure, then)1 620 1 2667 2126 t 10 I f (f 2c)1 138 1 3312 2126 t 10 R f (can tell whether the procedure is a sub-)7 1565 1 3475 2126 t ( it)1 81( If)1 116(routine or a function; in the latter case, Fortran's implicit typing rules specify a type for the procedure.\))17 4123 3 720 2246 t (can do no better, then)4 866 1 720 2366 t 10 I f (f 2c)1 138 1 1612 2366 t 10 R f (assumes that untyped)2 857 1 1776 2366 t 10 CW f (external)2660 2366 w 10 R f (procedures are subroutines \(and hence become)5 1873 1 3167 2366 t 10 CW f (int)720 2486 w 10 R f ( can cause the generated C to have multiple and inconsistent declarations)11 2947( This)1 232(-valued functions in C\).)3 961 3 900 2486 t ( example,)1 388( For)1 189(for some procedures.)2 839 3 720 2606 t 9 CW f (external f)1 540 1 1440 2778 t (call foo\(f\))1 594 1 1440 2878 t (end)1440 2978 w (function f\(x\))1 702 1 1440 3078 t (double precision f, x)3 1134 1 1440 3178 t (f = x)2 270 1 1440 3278 t (end)1440 3378 w 10 R f (results in)1 364 1 720 3570 t 10 CW f (MAIN_ _)1 384 1 1109 3570 t 10 R f (declaring)1518 3570 w 9 CW f (extern /* Subroutine */ int f_\(\);)5 1782 1 1224 3742 t 10 R f ( the subsequent de\256nition of)4 1181(and in)1 258 2 720 3934 t 10 CW f (doublereal f_\(x\))1 972 1 2196 3934 t 10 R f ( inconsistencies are)2 800( Such)1 262(in the same C \256le.)4 773 3 3205 3934 t (grounds for some C compilers to abort compilation.)7 2071 1 720 4054 t 10 I f (F 2c)1 163 1 970 4217 t 10 R f ('s type inferences only apply sequentially to the procedures in a \256le, because)12 3195 1 1133 4217 t 10 I f (f 2c)1 138 1 4364 4217 t 10 R f (writes C for)2 501 1 4539 4217 t ( procedure)1 426( as just illustrated, if)4 830( Thus,)1 279(each procedure before reading the next one.)6 1770 4 720 4337 t 10 CW f (xyz)4053 4337 w 10 R f (comes after)1 465 1 4261 4337 t 10 CW f (abc)4754 4337 w 10 R f (in)4962 4337 w (a Fortran input \256le, then)4 997 1 720 4457 t 10 I f (f 2c)1 138 1 1749 4457 t 10 R f (cannot use information it gains when it sees the de\256nition of)10 2485 1 1919 4457 t 10 CW f (xyz)4436 4457 w 10 R f (to deduce)1 392 1 4648 4457 t (types for)1 353 1 720 4577 t 10 CW f (external)1099 4577 w 10 R f (procedures passed as arguments to)4 1384 1 1605 4577 t 10 CW f (xyz)3015 4577 w 10 R f (by)3221 4577 w 10 CW f (abc)3347 4577 w 10 R f ( using the)2 389(. By)1 193 2 3527 4577 t 10 CW f (-P)4134 4577 w 10 R f (option and running)2 761 1 4279 4577 t 10 I f (f 2c)1 138 1 720 4697 t 10 R f ( instance, if \256le)3 661( For)1 204(several times, one can get around this de\256ciency.)7 2065 3 898 4697 t 10 CW f (zap.f)3868 4697 w 10 R f (contains the Fortran)2 831 1 4209 4697 t (shown above, then the commands)4 1351 1 720 4817 t 9 CW f (f2c -P!c zap.f)2 756 1 1440 4989 t (f2c -A zap.[fP])2 810 1 1440 5089 t 10 R f (result in a \256le)3 547 1 720 5281 t 10 CW f (zap.c)1292 5281 w 10 R f (in which)1 347 1 1617 5281 t 10 CW f (MAIN_ _)1 384 1 1989 5281 t 10 R f (correctly types)1 590 1 2398 5281 t 10 CW f (f_)3013 5281 w 10 R f (and)3158 5281 w 10 CW f (foo_)3327 5281 w 10 R f (as)3592 5281 w 9 CW f (extern doublereal f_\(\);)2 1242 1 1224 5453 t (extern /* Subroutine */ int foo_\(D_fp\);)5 2106 1 1224 5553 t 10 R f (rather than)1 429 1 720 5745 t 9 CW f (extern /* Subroutine */ int f_\(\);)5 1782 1 1224 5917 t (extern /* Subroutine */ int foo_\(U_fp\);)5 2106 1 1224 6017 t 10 R f (The \256rst invocation of)3 891 1 720 6209 t 10 I f (f 2c)1 138 1 1636 6209 t 10 R f (results in a \256le)3 586 1 1799 6209 t 10 CW f (zap.P)2410 6209 w 10 R f (containing)2735 6209 w 9 CW f (extern doublereal f_\(doublereal *x\);)3 1944 1 1008 6381 t (/*:ref: foo_ 10 1 200 */)5 1296 1 1008 6481 t 10 R f (The second invocation of)3 1012 1 720 6673 t 10 I f (f 2c)1 138 1 1757 6673 t 10 R f (is able to type)3 558 1 1920 6673 t 10 CW f (f_)2503 6673 w 10 R f (and)2648 6673 w 10 CW f (foo_)2817 6673 w 10 R f (correctly because of the \256rst line in)6 1408 1 3082 6673 t 10 CW f (zap.P)4515 6673 w 10 R f (.)4815 6673 w 10 R f (The second line in)3 735 1 970 6836 t 10 CW f (zap.P)1730 6836 w 10 R f ( comment that records the incomplete type information that)8 2383(is a special)2 438 2 2055 6836 t 10 I f (f 2c)1 138 1 4902 6836 t 10 R f (has about)1 381 1 720 6956 t 10 CW f (foo_)1126 6956 w 10 R f (.)1366 6956 w 10 I f (F 2c)1 163 1 1441 6956 t 10 R f (puts one such special comment in the prototype \256le for each Fortran procedure that is)14 3411 1 1629 6956 t ( it reads prototype \256les,)4 957( When)1 292(referenced but not de\256ned in the Fortran \256le.)7 1819 3 720 7076 t 10 I f (f 2c)1 138 1 3817 7076 t 10 R f (deciphers these comments)2 1056 1 3984 7076 t ( untyped external pro-)3 887( it learns more about)4 829( As)1 163(and uses them to check the consistency of calling sequences.)9 2441 4 720 7196 t 10 R f (March 22, 1995)2 635 1 2550 7560 t cleartomark showpage saveobj restore %%EndPage: 19 20 %%Page: 20 21 /saveobj save def mark 21 pagesetup 10 R f (- 20 -)2 216 1 2772 480 t (cedures,)720 840 w 10 I f (f 2c)1 138 1 1088 840 t 10 R f (updates the information it has on them; the)7 1811 1 1265 840 t 10 CW f (:ref:)3116 840 w 10 R f (comments it writes in a prototype \256le)6 1584 1 3456 840 t (re\257ect)720 960 w 10 I f (f 2c)1 138 1 994 960 t 10 R f ('s latest knowledge.)2 796 1 1132 960 t 10 R f (Ordinarily)970 1124 w 10 I f (f 2c)1 138 1 1416 1124 t 10 R f (tries to infer the type of an untyped)7 1441 1 1584 1124 t 10 CW f (external)3055 1124 w 10 R f (procedure from its use as arguments)5 1474 1 3566 1124 t ( example, if)2 474( For)1 189(to procedures of known argument types.)5 1608 3 720 1244 t 10 CW f (f.f)3016 1244 w 10 R f (contains just)1 503 1 3221 1244 t 9 CW f (external f)1 540 1 1440 1418 t (call foo\(f\))1 594 1 1440 1518 t (end)1440 1618 w 10 R f (and if)1 230 1 720 1812 t 10 CW f (foo.P)975 1812 w 10 R f (contains)1300 1812 w 9 CW f (extern int foo_\(D_fp\);)2 1188 1 1008 1986 t 10 R f (then)720 2180 w 9 CW f (f2c -A f.f foo.P)3 864 1 1008 2354 t 10 R f (results in the declaration)3 979 1 720 2548 t 9 CW f (extern doublereal f_\(\);)2 1242 1 1224 2722 t 10 R f ( can lead to erroneous error messages or to incorrect typ-)10 2281(Under unusual circumstances, such type inferences)5 2039 2 720 2916 t ( is an example:)3 602(ing. Here)1 396 2 720 3036 t 9 CW f (subroutine zoo)1 756 1 1440 3210 t (external f)1 540 1 1440 3310 t (double precision f)2 972 1 1440 3410 t (external g)1 540 1 1440 3510 t (call zap\(1,f\))1 702 1 1440 3610 t (call zap\(2,g\))1 702 1 1440 3710 t (end)1440 3810 w (subroutine goo)1 756 1 1440 3910 t (call g)1 324 1 1440 4010 t (end)1440 4110 w 10 I f (F 2c)1 163 1 720 4304 t 10 R f ( a double precision function, then discovers that it must be a subroutine and issues a)15 3412(\256rst infers g to be)4 717 2 911 4304 t (warning message about inconsistent declarations for)5 2148 1 720 4424 t 10 CW f (g)2905 4424 w 10 R f ( example is legal Fortran 77;)5 1206(. This)1 265 2 2965 4424 t 10 CW f (zap)4472 4424 w 10 R f (could be)1 352 1 4688 4424 t (de\256ned, for instance, by)3 962 1 720 4544 t 9 CW f (subroutine zap\(n,f\))1 1026 1 1440 4718 t (external f)1 540 1 1440 4818 t (if \(n .le. 1\) call zap1\(f\))5 1404 1 1440 4918 t (if \(n .ge. 2\) call zap2\(f\))5 1404 1 1440 5018 t (end)1440 5118 w 10 R f (In such a case one can specify the)7 1362 1 720 5312 t 10 CW f (-!it)2109 5312 w 10 R f (option to instruct)2 688 1 2376 5312 t 10 I f (f 2c)1 138 1 3091 5312 t 10 R f ( of otherwise untypable)3 949(not to infer the types)4 835 2 3256 5312 t 10 CW f (external)720 5432 w 10 R f ( is another \(some-)3 736( Here)1 249( as arguments to known procedures.)5 1466(procedures from their appearance)3 1357 4 1232 5432 t (what far-fetched\) example where)3 1319 1 720 5552 t 10 CW f (-!it)2064 5552 w 10 R f (is useful:)1 364 1 2329 5552 t 9 CW f (subroutine grok\(f,g,h\))1 1188 1 1440 5726 t (external f, g, h)3 864 1 1440 5826 t (logical g)1 486 1 1440 5926 t (call foo\(1,g\))1 702 1 1440 6026 t (call foo\(2,f\))1 702 1 1440 6126 t (call zit\(1,f\))1 702 1 1440 6226 t (call zit\(2,h\))1 702 1 1440 6326 t (call zot\(f\(3\)\))1 756 1 1440 6426 t (end)1440 6526 w 10 R f (Without)720 6720 w 10 CW f (-!it)1076 6720 w 10 R f (,)1316 6720 w 10 I f (f 2c)1 138 1 1369 6720 t 10 R f (\256rst infers)1 411 1 1535 6720 t 10 CW f (f_)1974 6720 w 10 R f (to be a)2 274 1 2123 6720 t 10 CW f (logical)2426 6720 w 10 R f (function, then discovers that Fortran's implicit typing)6 2165 1 2875 6720 t ( a)1 92(rules require it to be)4 900 2 720 6840 t 10 CW f (real)1760 6840 w 10 R f (function.)2048 6840 w 10 I f (F 2c)1 163 1 2479 6840 t 10 R f (issues the warning message ``)4 1284 1 2690 6840 t 10 CW f (fixing wrong type)2 1066 1 3974 6840 t (inferred for f)2 842 1 720 6960 t 10 R f ('', which should serve as a warning that)7 1598 1 1562 6960 t 10 I f (f 2c)1 138 1 3186 6960 t 10 R f (may have made some incorrect type infer-)6 1690 1 3350 6960 t ( Indeed,)1 350(ences in the mean time.)4 956 2 720 7080 t 10 I f (f 2c)1 138 1 2055 7080 t 10 R f (ends up typing)2 597 1 2222 7080 t 10 CW f (h_)2848 7080 w 10 R f (as a)1 156 1 2997 7080 t 10 CW f (logical)3182 7080 w 10 R f (function; with)1 567 1 3631 7080 t 10 CW f (-!it)4226 7080 w 10 R f (speci\256ed,)4494 7080 w 10 I f (f 2c)1 138 1 4902 7080 t 10 R f (types)720 7200 w 10 CW f (h_)958 7200 w 10 R f (as an)1 204 1 1105 7200 t 10 CW f (external)1336 7200 w 10 R f (procedure unknown type, i.e., a)4 1266 1 1843 7200 t 10 CW f (U_fp)3137 7200 w 10 R f (, which to the C compiler appears to be a)9 1663 1 3377 7200 t 10 R f (March 22, 1995)2 635 1 2550 7560 t cleartomark showpage saveobj restore %%EndPage: 20 21 %%Page: 21 22 /saveobj save def mark 22 pagesetup 10 R f (- 21 -)2 216 1 2772 480 t ( with)1 205(subroutine. \(Even)1 737 2 720 840 t 10 CW f (-!it)1689 840 w 10 R f (speci\256ed,)1956 840 w 10 I f (f 2c)1 138 1 2363 840 t 10 R f ( sequences)1 430(issues a warning message about inconsistent calling)6 2082 2 2528 840 t (for)720 960 w 10 CW f (foo)861 960 w 10 R f (.\))1041 960 w 10 R f (Because)970 1120 w 10 I f (f 2c)1 138 1 1345 1120 t 10 R f ( \256les, it is easy to write a crude)8 1392(writes its latest knowledge of types into prototype)7 2122 2 1526 1120 t (\(Bourne\) shell script that will glean the maximum possible type information:)10 3071 1 720 1240 t 9 CW f (>f.p)1008 1407 w (until)1008 1507 w (f2c -Pit f.p f.f)3 864 1 1440 1607 t (cmp -s f.p f.P)3 756 1 1440 1707 t (do)1008 1807 w (mv f.P f.p)2 540 1 1440 1907 t (done)1440 2007 w 10 R f (In such scripts, use of the)5 1080 1 720 2194 t 10 CW f (-Ps)1838 2194 w 10 R f (option can save an iteration;)4 1178 1 2056 2194 t 10 CW f (-Ps)3273 2194 w 10 R f (implies)3492 2194 w 10 CW f (-P)3826 2194 w 10 R f (and instructs)1 522 1 3985 2194 t 10 I f (f 2c)1 138 1 4546 2194 t 10 R f (to issue)1 317 1 4723 2194 t ( the following script is more)5 1130( Thus)1 250( if another iteration might change a declaration or prototype.)9 2412(return code 4)2 528 4 720 2314 t (ef\256cient:)720 2434 w 9 CW f (while :; do)2 594 1 1008 2601 t (f2c -Ps f.[fP])2 756 1 1440 2701 t (case $? in 4\) ;; *\) break;; esac)7 1728 1 1440 2801 t (done)1440 2901 w 10 R f ( depends on the call graph of the procedures in)9 1910(The number of iterations)3 1002 2 720 3088 t 10 CW f (f.f)3662 3088 w 10 R f (and on their order of appear-)5 1168 1 3872 3088 t (ance in)1 292 1 720 3208 t 10 CW f (f.f)1044 3208 w 10 R f ( them into topological order \(so that if)7 1566(. Sorting)1 377 2 1224 3208 t 10 CW f (abc)3198 3208 w 10 R f (calls)3409 3208 w 10 CW f (def)3623 3208 w 10 R f (, then)1 228 1 3803 3208 t 10 CW f (abc)4062 3208 w 10 R f (precedes)4273 3208 w 10 CW f (def)4652 3208 w 10 R f (\) and)1 208 1 4832 3208 t ( example,)1 389( For)1 190( alternating between the two orders is probably a good heuristic.)10 2575(reverse topological order and)3 1166 4 720 3328 t ( type the)2 350(we were able to completely)4 1113 2 720 3448 t 8 R f (PORT3)2211 3448 w 10 R f (subroutine library in two passes by \256rst processing it in reverse)10 2555 1 2485 3448 t ( one can devise situations where arbitrarily many)7 2023( Unfortunately,)1 644( in forward order.)3 730(topological order, then)2 923 4 720 3568 t ( is slightly annoying, since with appropriate data structures \(in an extensively)11 3168( This)1 236(iterations are required.)2 916 3 720 3688 t (reorganized version of)2 897 1 720 3808 t 10 I f (f 2c)1 138 1 1642 3808 t 10 R f (\), one could do this calculation in linear time.)8 1815 1 1780 3808 t 10 B f (8. EXPERIENCE WITH)2 1065 1 720 4061 t 10 BI f (netlib)1810 4061 w 10 R f ( the)1 150(With the help of Eric Grosse, we arranged for)8 1841 2 970 4221 t 10 I f (netlib)2989 4221 w 10 R f ([5] server)1 387 1 3245 4221 t 10 CW f (netlib@research.att.com)3660 4221 w 10 R f ( executing the UNIX)3 876( By)1 181(to provide an experimental Fortran-to-C translation service by electronic mail.)9 3263 3 720 4341 t (command)720 4461 w 10 CW f (\(echo execute f2c; cat foo.f\) | mail netlib@research.att.com)7 3600 1 1080 4641 t 10 R f (one submits the Fortran in)4 1054 1 720 4821 t 10 CW f (foo.f)1800 4821 w 10 R f (to)2126 4821 w 10 I f (netlib)2230 4821 w 10 R f ('s)2458 4821 w 10 I f (f 2c)1 138 1 2556 4821 t 10 R f (service;)2721 4821 w 10 I f (netlib)3058 4821 w 10 R f (replies with the C and diagnostic messages)6 1727 1 3313 4821 t (produced by)1 498 1 720 4941 t 10 I f (f 2c)1 138 1 1245 4941 t 10 R f (from)1410 4941 w 10 CW f (foo.f)1631 4941 w 10 R f (. \(The)1 265 1 1931 4941 t 10 CW f (include)2223 4941 w 10 R f ( context,)1 345(mechanism described in \2473 makes no sense in this)8 2025 2 2670 4941 t ( start using this service, one would generally execute)8 2110( To)1 161(so it is disabled.\))3 678 3 720 5061 t 10 CW f (echo 'send index from f2c' | mail netlib@research.att.com)7 3420 1 1170 5241 t 10 R f ( the returned C, it is necessary to get a copy)10 1784( compiling)1 434( Before)1 324(to check on the current status of the service.)8 1778 4 720 5421 t (of)720 5541 w 10 CW f (f2c.h)828 5541 w 10 R f (:)1128 5541 w 10 CW f (echo 'send f2c.h from f2c' | mail netlib@research.att.com)7 3420 1 1170 5721 t 10 R f ( the versions of)3 640(Most likely it would also be necessary to obtain source for)10 2416 2 720 5901 t 10 I f (libF77)3810 5901 w 10 R f (and)4111 5901 w 10 I f (libI77)4289 5901 w 10 R f (assumed by)1 478 1 4562 5901 t 10 I f (f 2c)1 138 1 720 6021 t 10 R f (:)858 6021 w 10 CW f (echo 'send libf77 libi77 from f2c' | mail netlib@research.att.com)8 3900 1 930 6201 t 10 R f (For testing purposes, we retain the original Fortran submitted to)9 2581 1 970 6361 t 10 I f (netlib)3579 6361 w 10 R f ('s ``)1 167 1 3807 6361 t 10 CW f (execute f2c)1 664 1 3974 6361 t 10 R f ('' service.)1 402 1 4638 6361 t (Observing)720 6481 w 10 I f (f 2c)1 138 1 1162 6481 t 10 R f ( of submitted Fortran helped us \256nd many obscure bugs and)10 2398('s behavior on over 400,000 lines)5 1342 2 1300 6481 t ( a)1 70( example,)1 388( For)1 189(led us to make some of the extensions described in \2473.)10 2178 4 720 6601 t 10 CW f (block data)1 601 1 3571 6601 t 10 R f (subprogram initializ-)1 842 1 4198 6601 t ( appear in any)3 568(ing a variable that does not)5 1094 2 720 6721 t 10 CW f (common)2409 6721 w 10 R f (blocks now elicits a warning message \(rather than caus-)8 2244 1 2796 6721 t (ing)720 6841 w 10 I f (f 2c)1 138 1 873 6841 t 10 R f ( example is that)3 630( Another)1 377(to drop core\).)2 540 3 1036 6841 t 10 I f (f 2c)1 138 1 2609 6841 t 10 R f (now gives the warning message ``)5 1366 1 2773 6841 t 10 CW f (Statement order)1 901 1 4139 6841 t (error: declaration after DATA)3 1761 1 720 6961 t 10 R f ( a)1 75('' and declines to produce any C if a declaration comes after)11 2484 2 2481 6961 t 10 CW f (data)720 7081 w 10 R f (statement \(for reasons discussed in \2479\);)5 1623 1 994 7081 t 10 I f (f 2c)1 138 1 2651 7081 t 10 R f ( and then)2 386(formerly gave a more obscure error message)6 1831 2 2823 7081 t (produced invalid C.)2 791 1 720 7201 t 10 R f (March 22, 1995)2 635 1 2550 7560 t cleartomark showpage saveobj restore %%EndPage: 21 22 %%Page: 22 23 /saveobj save def mark 23 pagesetup 10 R f (- 22 -)2 216 1 2772 480 t (Now that)1 380 1 970 840 t 10 I f (netlib)1386 840 w 10 R f (offers source for)2 680 1 1650 840 t 10 I f (f 2c)1 138 1 2366 840 t 10 R f (itself \(as explained in the)4 1052 1 2541 840 t 10 CW f (index)3630 840 w 10 R f (\256le mentioned above\), we)3 1073 1 3967 840 t (expect to curtail)2 655 1 720 960 t 10 I f (netlib)1406 960 w 10 R f ('s ``)1 169 1 1634 960 t 10 CW f (execute f2c)1 666 1 1803 960 t 10 R f ('' service, perhaps limiting it to employees of AT&T and Bell-)10 2571 1 2469 960 t (core; to learn the current state of affairs, request the current)10 2367 1 720 1080 t 10 CW f (index)3112 1080 w 10 R f (\256le.)3437 1080 w 10 B f (9. POSSIBLE EXTENSIONS)2 1262 1 720 1322 t 10 R f (Currently)970 1479 w 10 I f (f 2c)1 138 1 1384 1479 t 10 R f ( would be nice if constant expressions were simply)8 2092( It)1 118( expressions.)1 523(simpli\256es constant)1 754 4 1553 1479 t (passed through, and if Fortran)4 1221 1 720 1599 t 10 CW f (parameter)1971 1599 w 10 R f ( as)1 112(s were translated)2 680 2 2511 1599 t 10 CW f (#define)3332 1599 w 10 R f ( several things)2 585(s. Unfortunately,)1 703 2 3752 1599 t ( worst is that)3 535( Perhaps)1 373( this nearly impossible to do in full generality.)8 1903(conspire to make)2 694 4 720 1719 t 10 CW f (parameter)4257 1719 w 10 R f (s may)1 243 1 4797 1719 t (be assigned)1 473 1 720 1839 t 10 CW f (complex)1228 1839 w 10 R f (or)1683 1839 w 10 CW f (doublecomplex)1801 1839 w 10 R f (expressions that might, for example, involve complex divi-)7 2425 1 2615 1839 t (sion and exponentiation to a large integer power.)7 2022 1 720 1959 t 10 CW f (Parameter)2802 1959 w 10 R f (s may appear in)3 659 1 3342 1959 t 10 CW f (data)4037 1959 w 10 R f (statements, which)1 727 1 4313 1959 t (may initialize)1 554 1 720 2079 t 10 CW f (common)1306 2079 w 10 R f ( to have)2 328( Arranging)1 466( be moved near the beginning of the C output.)9 1891(variables and so)2 657 4 1698 2079 t (the right)1 353 1 720 2199 t 10 CW f (#define)1115 2199 w 10 R f ( Of)1 173( in this worst case, be a nightmare.)7 1510(s in effect for the data initialization would,)7 1822 3 1535 2199 t ( and)1 176(course, one could arrange to handle ``easy'' cases with unsimpli\256ed constant expressions)11 3653 2 720 2319 t 10 CW f (#define)4581 2319 w 10 R f (s)5001 2319 w (for parameters.)1 603 1 720 2439 t 10 R f ( Proto-)1 311( alternate return speci\256ers.)3 1091(Prototypes and the argument consistency checks currently ignore)7 2668 3 970 2596 t (types could be adorned with special comments indicating where alternate return speci\256ers are supposed to)14 4320 1 720 2716 t ( alternate return)2 633( Since)1 273( really matters.)2 598(come, or at least telling the number of such speci\256ers, which is all that)13 2816 4 720 2836 t ( we have so far refrained from this exer-)8 1669(speci\256ers are rarely used \(Fortran 90 calls them ``obsolescent''\),)8 2651 2 720 2956 t (cise.)720 3076 w 10 R f (Fortran 90 allows)2 717 1 970 3233 t 10 CW f (data)1718 3233 w 10 R f ( would be nice if)4 695( It)1 117(statements to appear anywhere.)3 1270 3 1989 3233 t 10 I f (f 2c)1 138 1 4102 3233 t 10 R f ( the same,)2 416(could do)1 353 2 4271 3233 t (but that would entail major rewriting of)6 1594 1 720 3353 t 10 I f (f 2c)1 138 1 2341 3353 t 10 R f (. Presently)1 449 1 2479 3353 t 10 CW f (data)2955 3353 w 10 R f ( written to a \256le as soon as they are)9 1415(values are)1 403 2 3222 3353 t ( an)1 127( If)1 124(seen; among the information in the \256le is the offset of each value.)12 2705 3 720 3473 t 10 CW f (equivalence)3709 3473 w 10 R f (statement could)1 638 1 4402 3473 t (follow the)1 408 1 720 3593 t 10 CW f (data)1153 3593 w 10 R f (statement, then the offsets would be invalidated.)6 1931 1 1418 3593 t 10 R f (It would be fairly straightforward to extend)6 1754 1 970 3750 t 10 I f (f 2c)1 138 1 2753 3750 t 10 R f ( new speci\256ers introduced by)4 1190('s I/O to encompass the)4 959 2 2891 3750 t ( that would mean changing)4 1094( Unfortunately,)1 638(Fortran 90.)1 447 3 720 3870 t 10 I f (libI77)2927 3870 w 10 R f ( would make it incompatible with)5 1357(in ways that)2 489 2 3194 3870 t 10 I f (f)720 3990 w 10 R f (77.)764 3990 w 10 R f ( would be nice to translate all of Fortran 90, but some of the Fortran 90 array manipula-)17 3568(Of course, it)2 502 2 970 4147 t (tions would require new calling conventions and large enough revisions to)10 3014 1 720 4267 t 10 I f (f 2c)1 138 1 3763 4267 t 10 R f (that one might be better off)5 1110 1 3930 4267 t (starting from scratch.)2 851 1 720 4387 t 10 R f ( hacking,)1 381(With suf\256cient)1 611 2 970 4544 t 10 I f (f 2c)1 138 1 2002 4544 t 10 R f (could be modi\256ed to recognize Fortran 90 control structures \()9 2595 1 2180 4544 t 10 CW f (case)4775 4544 w 10 R f (,)5015 4544 w 10 CW f (cycle)720 4664 w 10 R f (,)1020 4664 w 10 CW f (exit)1077 4664 w 10 R f (, and named loops\), local arrays of dimensions that depend on arguments and common val-)14 3723 1 1317 4664 t (ues, and such types as)4 879 1 720 4784 t 10 CW f (logical*1)1624 4784 w 10 R f (,)2164 4784 w 10 CW f (logical*2)2214 4784 w 10 R f (,)2754 4784 w 10 CW f (integer*1)2804 4784 w 10 R f (or)3370 4784 w 10 CW f (byte)3479 4784 w 10 R f ( our main concern is with)5 1023(. Since)1 298 2 3719 4784 t ( so far refrained from these further)6 1420(making portable Fortran 77 libraries available to the C world, we have)11 2900 2 720 4904 t ( commercial vendors will wish to provide some of these extensions.)10 2711(extensions. Perhaps)1 813 2 720 5024 t 10 B f (10. REFERENCES)1 823 1 720 5266 t 10 R f ([1])720 5423 w 10 I f (American National Standard Programming Language FORTRAN,)5 2786 1 970 5423 t 10 R f (American National Standards)2 1233 1 3807 5423 t ( X3.9-1978.)1 480( ANSI)1 283(Institute, New York, NY, 1978.)4 1265 3 970 5543 t 10 R f ([2])720 5700 w 10 I f (American National Standard for Information Systems Programming Language Fortran,)8 3648 1 970 5700 t 10 R f (CBEMA,)4659 5700 w ( S8, Version 112.)3 697(1989. Draft)1 485 2 970 5820 t 10 R f ([3])720 5977 w 10 I f (American National Standard for Information Systems \320 Programming Language \320 C,)10 3638 1 970 5977 t 10 R f (American)4647 5977 w ( X3.159-1989.)1 580( ANSI)1 283(National Standards Institute, New York, NY, 1990.)6 2053 3 970 6097 t 10 R f ([4])720 6254 w 10 I f ( Manual,)1 368(UNIX Time Sharing System Programmer's)4 1739 2 970 6254 t 10 R f ( Edition,)1 352( Tenth)1 290(AT&T Bell Laboratories, 1990.)3 1289 3 3109 6254 t (Volume 1.)1 422 1 970 6374 t 10 R f ( of Mathematical Software by Electronic Mail,'')6 1950( J. Dongarra and E. Grosse, ``Distribution)6 1684([5] J.)1 314 3 720 6531 t 10 I f (Commu-)4696 6531 w (nications of the ACM)3 853 1 970 6651 t 10 B f (30)1848 6651 w 10 R f (#5 \(May 1987\), pp. 403\261407.)4 1174 1 1973 6651 t 10 R f ( P. J. Weinberger, ``A Portable Fortran 77 Compiler,'' in)9 2286( I. Feldman and)3 627([6] S.)1 331 3 720 6808 t 10 I f (Unix Programmer's Man-)2 1050 1 3990 6808 t (ual, Volume II)2 574 1 970 6928 t 10 R f (, Holt, Rinehart and Winston \(1983\).)5 1471 1 1544 6928 t 10 R f ( A. Fox, A. D. Hall, and N. L. Schryer, ``Algorithm 528: Framework for a Portable Library,'')16 3751([7] P.)1 331 2 720 7085 t 10 I f (ACM)4829 7085 w (Trans. Math. Software)2 901 1 970 7205 t 10 B f (4)1896 7205 w 10 R f (\(June 1978\), pp. 177\261188.)3 1049 1 1971 7205 t 10 R f (March 22, 1995)2 635 1 2550 7560 t cleartomark showpage saveobj restore %%EndPage: 22 23 %%Page: 23 24 /saveobj save def mark 24 pagesetup 10 R f (- 23 -)2 216 1 2772 480 t ( D. Hall, and N. L. Schryer, ``The)7 1478( A. Fox, A.)3 501([8] P.)1 331 3 720 840 t 8 R f (PORT)3073 840 w 10 R f (Mathematical Subroutine Library,'')2 1464 1 3322 840 t 10 I f (ACM)4829 840 w (Trans. Math. Software)2 901 1 970 960 t 10 B f (4)1896 960 w 10 R f (\(June 1978\), pp. 104\261126.)3 1049 1 1971 960 t 10 R f ( in)1 114( C. Johnson, ``A Portable Compiler: Theory and Practice,'' pp. 97\261104)10 2941([9] S.)1 331 3 720 1116 t 10 I f (Conference Record of)2 898 1 4142 1116 t ( Languages)1 469(the Fifth Annual ACM Symposium on Principles of Programming)8 2670 2 970 1236 t 10 R f (, Association for Com-)3 931 1 4109 1236 t (puting Machinery \(1978\).)2 1029 1 970 1356 t 10 R f ( W. Kernighan and D. M. Ritchie,)6 1359([10] B.)1 342 2 720 1512 t 10 I f (The C Programming Language,)3 1278 1 2446 1512 t 10 R f (Prentice-Hall, 1978.)1 807 1 3749 1512 t 10 R f ( D. M. Ritchie,)3 633( W. Kernighan and)3 789([11] B.)1 342 3 720 1668 t 10 I f (The C Programming Language,)3 1311 1 2520 1668 t 10 R f ( Second)1 355(Prentice-Hall, 1988.)1 818 2 3867 1668 t (Edition)970 1788 w 10 R f ( M. A. Saunders, ``MINOS 5.1 User's Guide,'' Technical Report SOL 83-20R)11 3282( A. Murtagh and)3 696([12] B.)1 342 3 720 1944 t ( CA.)1 189( Stanford,)1 419( Optimization Laboratory, Stanford University,)4 1887(\(1987\), Systems)1 675 4 970 2064 t 10 R f ( G. Ryder, ``The PFORT Veri\256er,'')5 1425([13] B.)1 342 2 720 2220 t 10 I f (Software Practice and Experience)3 1367 1 2512 2220 t 10 B f (4)3904 2220 w 10 R f (\(1974\), pp. 359\261377.)2 841 1 3979 2220 t 10 R f ( Test of a Computer's Floating-point Arithmetic Unit,'' in)8 2388( L. Schryer, ``A)3 655([14] N.)1 347 3 720 2376 t 10 I f (Sources and Develop-)2 897 1 4143 2376 t (ment of Mathematical Software)3 1258 1 970 2496 t 10 R f (, ed. W. Cowell, Prentice-Hall \(1981\).)5 1525 1 2228 2496 t 10 R f ( Stroustrup,)1 467([15] B.)1 342 2 720 2652 t 10 I f (The C++ Programming Language,)3 1414 1 1554 2652 t 10 R f (Addison-Wesley, 1986.)1 946 1 2993 2652 t 10 B f (Appendix A: Commercial Fortran-to-C Vendors)4 2069 1 720 2892 t 10 R f ( following vendors offer Fortran to C conversion ser-)8 2132(At the time of this writing, we are aware that the)10 1938 2 970 3048 t ( include them in updated ver-)5 1193( vendors are invited to inform us of their existence, so we may)12 2553(vice. Omitted)1 574 3 720 3168 t (sions of this appendix.)3 900 1 720 3288 t (Cobalt Blue)1 481 1 2520 3528 t (875 Old Roswell Road)3 914 1 2520 3648 t (Suite D400)1 453 1 2520 3768 t (Roswell, GA 30076)2 797 1 2520 3888 t (\(404\) 518\2611116; FAX \(404\) 640\2611182)4 1560 1 2520 4008 t (PROMULA Development Corporation)2 1560 1 2520 4368 t (Columbus, OH)1 606 1 2520 4488 t (\(614\) 263\2615454)1 641 1 2520 4608 t (Rapitech Systems)1 714 1 2520 4968 t (Of\256ce Center at Montebello)3 1123 1 2520 5088 t (400 Rella Blvd.)2 631 1 2520 5208 t (Suffern, NY 10901)2 768 1 2520 5328 t (\(914\) 368\2613000)1 641 1 2520 5448 t 10 R f (March 22, 1995)2 635 1 2550 7560 t cleartomark showpage saveobj restore %%EndPage: 23 24 %%Page: 1 25 /saveobj save def mark 25 pagesetup 9 B f ( \( 1 \))3 126( F2C)1 1621( \))1 37( B)1 83( Appendix)1 382( \()1 68( System V)2 386( UNIX)1 1686(F2C \( 1 \))3 291 9 540 480 t (NAME)540 960 w 10 R f (f2c \261 Convert Fortran 77 to C or C++)8 1500 1 900 1080 t 9 B f (SYNOPSIS)540 1248 w 10 B f (f 2c)1 135 1 900 1368 t 10 R f ([)1060 1368 w 10 I f (option ...)1 356 1 1118 1368 t 10 R f (])1499 1368 w 10 I f (\256le ...)1 222 1 1557 1368 t 9 B f (DESCRIPTION)540 1536 w 10 I f (F2c)900 1656 w 10 R f (converts Fortran 77 source code in)5 1413 1 1086 1656 t 10 I f (\256les)2530 1656 w 10 R f ( in)1 110(with names ending)2 767 2 2722 1656 t 10 CW f (.f)3631 1656 w 10 R f (or)3783 1656 w 10 CW f (.F)3898 1656 w 10 R f (to C \(or C++\) source \256les in)6 1170 1 4050 1656 t (the current directory, with)3 1069 1 900 1776 t 10 CW f (.c)2003 1776 w 10 R f (substituted for the \256nal)3 949 1 2156 1776 t 10 CW f (.f)3138 1776 w 10 R f (or)3291 1776 w 10 CW f (.F)3407 1776 w 10 R f ( no Fortran \256les are named,)5 1138(. If)1 149 2 3527 1776 t 10 I f (f 2c)1 130 1 4847 1776 t 10 R f (reads)5010 1776 w (Fortran from standard input and writes C on standard output.)9 2458 1 900 1896 t 10 I f (File)3411 1896 w 10 R f (names that end with)3 814 1 3601 1896 t 10 CW f (.p)4444 1896 w 10 R f (or)4593 1896 w 10 CW f (.P)4705 1896 w 10 R f (are taken)1 366 1 4854 1896 t (to be prototype \256les, as produced by option)7 1732 1 900 2016 t 10 CW f (-P)2657 2016 w 10 R f (, and are read \256rst.)4 742 1 2777 2016 t (The following options have the same meaning as in)8 2059 1 900 2184 t 10 I f (f 77)1 136 1 2984 2184 t 10 R f (\(1\).)3128 2184 w 10 B f (-C)900 2352 w 10 R f (Compile code to check that subscripts are within declared array bounds.)10 2875 1 1260 2352 t 10 B f (-I2)900 2520 w 10 R f (Render INTEGER and LOGICAL as short, INTEGER)6 2224 1 1260 2520 t 10 S f (*)3484 2520 w 10 R f ( the default)2 465( Assume)1 380(4 as long int.)3 541 3 3534 2520 t 10 I f (libF77)4953 2520 w 10 R f (and)1260 2640 w 10 I f (libI77)1442 2640 w 10 R f ( only INTEGER)2 681(: allow)1 313 2 1681 2640 t 10 S f (*)2675 2640 w 10 R f ( Option)1 340(4 \(and no LOGICAL\) variables in INQUIREs.)6 1938 2 2725 2640 t 10 CW f (-I4)5040 2640 w 10 R f (con\256rms the default rendering of INTEGER as long int.)8 2233 1 1260 2760 t 10 B f (-I)900 2928 w 10 I f (dir)972 2928 w 10 R f ( in directo-)2 452(Look for a non-absolute include \256le \256rst in the directory of the current input \256le, then)15 3508 2 1260 2928 t (ries speci\256ed by)2 661 1 1260 3048 t 10 CW f (-I)1952 3048 w 10 R f ( Options)1 372( option\).)1 344(options \(one directory per)3 1052 3 2103 3048 t 10 CW f (-I2)3936 3048 w 10 R f (and)4146 3048 w 10 CW f (-I4)4320 3048 w 10 R f (have precedence,)1 690 1 4530 3048 t (so, e.g., a directory named)4 1053 1 1260 3168 t 10 CW f (2)2338 3168 w 10 R f (should be speci\256ed by)3 891 1 2423 3168 t 10 CW f (-I./2)3339 3168 w 10 R f (.)3664 3168 w 10 B f (-onetrip)900 3336 w 10 R f ( 77 DO loops are not per-)6 1050( \(Fortran)1 382( that are performed at least once if reached.)8 1764(Compile DO loops)2 764 4 1260 3456 t (formed at all if the upper limit is smaller than the lower limit.\))12 2490 1 1260 3576 t 10 B f (-U)900 3744 w 10 R f ( keywords must be in)4 855( Fortran)1 344(Honor the case of variable and external names.)7 1872 3 1260 3744 t 10 I f (lower)4356 3744 w 10 R f (case.)4609 3744 w 10 B f (-u)900 3912 w 10 R f (Make the default type of a variable `unde\256ned' rather than using the default Fortran rules.)14 3589 1 1260 3912 t 10 B f (-w)900 4080 w 10 R f (Suppress all warning messages, or, if the option is)8 2004 1 1260 4080 t 10 CW f (-w66)3289 4080 w 10 R f (, just Fortran 66 compatibility warnings.)5 1614 1 3529 4080 t (The following options are peculiar to)5 1484 1 900 4248 t 10 I f (f 2c)1 130 1 2409 4248 t 10 R f (.)2547 4248 w 10 B f (-A)900 4416 w 10 R f (Produce)1260 4416 w 9 R f (ANSI)1610 4416 w 10 R f ( is old-style C.)3 584(C. Default)1 441 2 1845 4416 t 10 B f (-a)900 4584 w 10 R f ( appear in a)3 489(Make local variables automatic rather than static unless they)8 2476 2 1260 4584 t 9 R f (DATA, EQUIVALENCE,)1 963 1 4257 4584 t (NAMELIST,)1260 4704 w 10 R f (or)1763 4704 w 9 R f (SAVE)1869 4704 w 10 R f (statement.)2129 4704 w 10 B f (-C++)900 4872 w 10 R f (Output C++ code.)2 720 1 1260 4872 t 10 B f (-c)900 5040 w 10 R f (Include original Fortran source as comments.)5 1808 1 1260 5040 t 10 B f (-cd)900 5208 w 10 R f ( com-)1 238(Do not recognize cdabs, cdcos, cdexp, cdlog, cdsin, and cdsqrt as synonyms for the double)14 3722 2 1260 5208 t (plex intrinsics zabs, zcos, zexp, zlog, zsin, and zsqrt, respectively.)9 2634 1 1260 5328 t 10 B f (-d)900 5496 w 10 I f (dir)989 5496 w 10 R f (Write)1260 5496 w 10 CW f (.c)1512 5496 w 10 R f (\256les in directory)2 655 1 1657 5496 t 10 I f (dir)2337 5496 w 10 R f (instead of the current directory.)4 1255 1 2479 5496 t 10 B f (-E)900 5664 w 10 R f (Declare uninitialized)1 834 1 1260 5664 t 9 R f (COMMON)2117 5664 w 10 R f (to be)1 197 1 2557 5664 t 10 B f (Extern)2779 5664 w 10 R f (\(overridably de\256ned in)2 915 1 3098 5664 t 10 CW f (f2c.h)4038 5664 w 10 R f (as)4363 5664 w 10 B f (extern\).)4471 5664 w (-ec)900 5832 w 10 R f (Place uninitialized)1 780 1 1260 5832 t 9 R f (COMMON)2102 5832 w 10 R f (blocks in separate \256les:)3 1052 1 2581 5832 t 10 B f (COMMON /ABC/)1 819 1 3697 5832 t 10 R f (appears in \256le)2 640 1 4580 5832 t 10 B f (abc)1260 5952 w 10 S f (_)1410 5952 w 10 B f (com.c)1460 5952 w 10 R f (. Option)1 359 1 1706 5952 t 10 CW f (-e1c)2096 5952 w 10 R f (bundles the separate \256les into the output \256le, with comments that give)11 2854 1 2366 5952 t (an unbundling)1 575 1 1260 6072 t 10 I f (sed)1860 6072 w 10 R f (\(1\) script.)1 388 1 2001 6072 t 10 B f (-ext)900 6240 w 10 R f (Complain about)1 642 1 1260 6240 t 10 I f (f 77)1 136 1 1927 6240 t 10 R f (\(1\) extensions.)1 588 1 2071 6240 t 10 B f (-f)900 6408 w 10 R f ( 72 and do not pad \256xed-format lines shorter)8 1861(Assume free-format input: accept text after column)6 2099 2 1260 6408 t (than 72 characters with blanks.)4 1239 1 1260 6528 t 10 B f (-72)900 6696 w 10 R f (Treat text appearing after column 72 as an error.)8 1930 1 1260 6696 t 10 B f (-g)900 6864 w 10 R f (Include original Fortran line numbers in)5 1601 1 1260 6864 t 10 CW f (#line)2886 6864 w 10 R f (lines.)3211 6864 w 10 B f (-h)900 7032 w 10 R f ( strings on word \(or, if the option)7 1334(Emulate Fortran 66's treatment of Hollerith: try to align character)9 2626 2 1260 7032 t (is)1260 7152 w 10 CW f (-hd)1352 7152 w 10 R f (, on double-word\) boundaries.)3 1206 1 1532 7152 t ( 24)1 125( Page)1 3997(May 12, 1996)2 558 3 540 7680 t cleartomark showpage saveobj restore %%EndPage: 1 25 %%Page: 25 26 /saveobj save def mark 26 pagesetup 9 B f ( \( 1 \))3 126( F2C)1 1621( \))1 37( B)1 83( Appendix)1 382( \()1 68( System V)2 386( UNIX)1 1686(F2C \( 1 \))3 291 9 540 480 t 10 B f (-i2)900 960 w 10 R f (Similar to)1 407 1 1260 960 t 10 B f (-I2)1701 960 w 10 R f ( assume a modi\256ed)3 799(, but)1 187 2 1823 960 t 10 I f (libF77)2844 960 w 10 R f (and)3146 960 w 10 I f (libI77)3325 960 w 10 R f (\(compiled with)1 618 1 3599 960 t 10 B f (-Df 2c)1 240 1 4252 960 t 10 S f (_)4492 960 w 10 B f (i2)4542 960 w 10 R f (\), so)1 182 1 4620 960 t 9 R f (INTEGER)4835 960 w 10 R f (and)1260 1080 w 9 R f (LOGICAL)1427 1080 w 10 R f (variables may be assigned by)4 1170 1 1847 1080 t 9 R f (INQUIRE)3040 1080 w 10 R f (and array lengths are stored in short ints.)7 1625 1 3435 1080 t 10 B f (-i90)900 1248 w 10 R f ( iand, ibclr, ibits, ibset, ieor, ior,)6 1319(Do not recognize the Fortran 90 bit-manipulation intrinsics btest,)8 2641 2 1260 1248 t (ishft, and ishftc.)2 644 1 1260 1368 t 10 B f (-kr)900 1536 w 10 R f ( where K&R \(\256rst edition\) paren-)5 1389(Use temporary values to enforce Fortran expression evaluation)7 2571 2 1260 1536 t ( the option is)3 562( If)1 130(thesization rules allow rearrangement.)3 1566 3 1260 1656 t 10 CW f (-krd)3557 1656 w 10 R f (, use double precision temporaries)4 1423 1 3797 1656 t (even for single-precision operands.)3 1402 1 1260 1776 t 10 B f (-P)900 1944 w 10 R f (Write a)1 310 1 1260 1944 t 10 I f (\256le)1609 1944 w 10 B f (.P)1739 1944 w 10 R f (of ANSI \(or C++\) prototypes for de\256nitions in each input)9 2422 1 1864 1944 t 10 I f (\256le)4325 1944 w 10 B f (.f)4455 1944 w 10 R f (or)4553 1944 w 10 I f (\256le)4676 1944 w 10 B f (.F)4806 1944 w 10 I f (.)4892 1944 w 10 R f (When)4982 1944 w ( Option)1 332( from standard input, write prototypes at the beginning of standard output.)11 3005(reading Fortran)1 623 3 1260 2064 t 10 B f (-Ps)1260 2184 w 10 R f (implies)1418 2184 w 10 B f (-P)1738 2184 w 10 R f (and gives exit status 4 if rerunning)6 1382 1 1857 2184 t 10 I f (f 2c)1 130 1 3264 2184 t 10 R f (may change prototypes or declarations.)4 1566 1 3419 2184 t 10 B f (-p)900 2352 w 10 R f (Supply preprocessor de\256nitions to make common-block members look like local variables.)10 3638 1 1260 2352 t 10 B f (-R)900 2520 w 10 R f (Do not promote)2 633 1 1260 2520 t 9 R f (REAL)1916 2520 w 10 R f (functions and operations to)3 1085 1 2176 2520 t 9 R f (DOUBLE PRECISION.)1 877 1 3284 2520 t 10 R f (Option)4212 2520 w 10 CW f (-!R)4516 2520 w 10 R f (con\256rms the)1 498 1 4722 2520 t (default, which imitates)2 913 1 1260 2640 t 10 I f (f 77)1 136 1 2198 2640 t 10 R f (.)2342 2640 w 10 B f (-r)900 2808 w 10 R f (Cast values of REAL functions \(including intrinsics\) to REAL.)8 2524 1 1260 2808 t 10 B f (-r8)900 2976 w 10 R f (Promote)1260 2976 w 9 R f (REAL)1622 2976 w 10 R f (to)1882 2976 w 9 R f (DOUBLE PRECISION, COMPLEX)2 1329 1 1983 2976 t 10 R f (to)3337 2976 w 9 R f (DOUBLE COMPLEX.)1 841 1 3438 2976 t 10 B f (-s)900 3144 w 10 R f ( by option)2 406( Suppressed)1 505(Preserve multidimensional subscripts.)2 1519 3 1260 3144 t 10 CW f (-C)3715 3144 w 10 R f (.)3860 3144 w 10 B f (-T)900 3312 w 10 I f (dir)1000 3312 w 10 R f (Put temporary \256les in directory)4 1249 1 1260 3312 t 10 I f (dir.)2534 3312 w 10 B f (-w8)900 3480 w 10 R f (Suppress warnings when)2 993 1 1260 3480 t 9 R f (COMMON)2276 3480 w 10 R f (or)2716 3480 w 9 R f (EQUIVALENCE)2822 3480 w 10 R f (forces odd-word alignment of doubles.)4 1550 1 3482 3480 t 10 B f (-W)900 3648 w 10 I f (n)1033 3648 w 10 R f (Assume)1260 3648 w 10 I f (n)1607 3648 w 10 R f (characters/word \(default 4\) when initializing numeric variables with character data.)9 3324 1 1682 3648 t 10 B f (-z)900 3816 w 10 R f (Do not implicitly recognize)3 1102 1 1260 3816 t 9 R f (DOUBLE COMPLEX.)1 841 1 2385 3816 t 10 B f (-!bs)900 3984 w 10 R f (Do not recognize)2 687 1 1260 3984 t 10 I f (b)1972 3984 w 10 R f (ack)2022 3984 w 10 I f (s)2160 3984 w 10 R f (lash escapes \(\\", \\', \\0, \\\\, \\b, \\f, \\n, \\r, \\t, \\v\) in character strings.)14 2516 1 2199 3984 t 10 B f (-!c)900 4152 w 10 R f (Inhibit C output, but produce)4 1164 1 1260 4152 t 10 B f (-P)2449 4152 w 10 R f (output.)2568 4152 w 10 B f (-!I)900 4320 w 10 R f (Reject)1260 4320 w 10 B f (include)1540 4320 w 10 R f (statements.)1877 4320 w 10 B f (-!i8)900 4488 w 10 R f (Disallow)1260 4488 w 9 R f (INTEGER)1644 4488 w 9 S f (*)2029 4488 w 9 R f (8.)2074 4488 w 10 B f (-!it)900 4656 w 10 R f (Don't infer types of untyped)4 1149 1 1260 4656 t 9 R f (EXTERNAL)2435 4656 w 10 R f (procedures from use as parameters to previously de\256ned)7 2281 1 2939 4656 t (or prototyped procedures.)2 1028 1 1260 4776 t 10 B f (-!P)900 4944 w 10 R f (Do not attempt to infer)4 916 1 1260 4944 t 9 R f (ANSI)2199 4944 w 10 R f (or C++ prototypes from usage.)4 1230 1 2434 4944 t (The resulting C invokes the support routines of)7 1927 1 900 5112 t 10 I f (f 77)1 136 1 2858 5112 t 10 R f ( be loaded by)3 556(; object code should)3 820 2 3002 5112 t 10 I f (f 77)1 136 1 4410 5112 t 10 R f (or with)1 293 1 4578 5112 t 10 I f (ld)4903 5112 w 10 R f (\(1\) or)1 231 1 4989 5112 t 10 I f (cc)900 5232 w 10 R f (\(1\) options)1 436 1 996 5232 t 10 B f (-lF77 -lI77 -lm)2 616 1 1457 5232 t 10 R f ( conventions are those of)4 998(. Calling)1 370 2 2073 5232 t 10 I f (f77)3466 5232 w 10 R f (: see the reference below.)4 1015 1 3602 5232 t 9 B f (FILES)540 5400 w 10 I f (\256le)900 5520 w 10 B f (.[fF])1030 5520 w 10 R f (input \256le)1 359 1 2160 5520 t 10 S f (*)900 5688 w 10 B f (.c)950 5688 w 10 R f (output \256le)1 409 1 2160 5688 t 10 CW f (/usr/include/f2c.h)900 5856 w 10 R f (header \256le)1 418 1 2160 5856 t 10 CW f (/usr/lib/libF77.a)900 6024 w 10 R f (intrinsic function library)2 977 1 2160 6024 t 10 CW f (/usr/lib/libI77.a)900 6192 w 10 R f (Fortran I/O library)2 743 1 2160 6192 t 10 CW f (/lib/libc.a)900 6360 w 10 R f (C library, see section 3)4 918 1 2160 6360 t 9 B f (SEE ALSO)1 438 1 540 6528 t 10 R f (S. I. Feldman and P. J. Weinberger, `A Portable Fortran 77 Compiler',)11 3091 1 900 6648 t 10 I f ( Sharing System)2 696(UNIX Time)1 483 2 4041 6648 t (Programmer's Manual)1 924 1 900 6768 t 10 R f (, Tenth Edition, Volume 2, AT&T Bell Laboratories, 1990.)8 2368 1 1824 6768 t 9 B f (DIAGNOSTICS)540 6936 w 10 R f (The diagnostics produced by)3 1151 1 900 7056 t 10 I f (f 2c)1 130 1 2076 7056 t 10 R f (are intended to be self-explanatory.)4 1410 1 2231 7056 t ( 12, 1996)2 375( May)1 3986(Page 25)1 319 3 540 7680 t cleartomark showpage saveobj restore %%EndPage: 25 26 %%Page: 26 27 /saveobj save def mark 27 pagesetup 9 B f ( \( 1 \))3 126( F2C)1 1621( \))1 37( B)1 83( Appendix)1 382( \()1 68( System V)2 386( UNIX)1 1686(F2C \( 1 \))3 291 9 540 480 t (BUGS)540 960 w 10 R f ( machine running)2 721(Floating-point constant expressions are simpli\256ed in the \257oating-point arithmetic of the)10 3599 2 900 1080 t 10 I f (f 2c)1 130 1 900 1200 t 10 R f (, so they are typically accurate to at most 16 or 17 decimal places.)13 2631 1 1038 1200 t (Untypable)900 1320 w 9 R f (EXTERNAL)1339 1320 w 10 R f (functions are declared)2 880 1 1839 1320 t 10 B f (int)2744 1320 w 10 R f (.)2861 1320 w ( 26)1 125( Page)1 3997(May 12, 1996)2 558 3 540 7680 t cleartomark showpage saveobj restore %%EndPage: 26 27 %%Trailer done %%Pages: 27 %%DocumentFonts: Times-Italic Times-Roman Symbol Times-BoldItalic Courier Times-Bold f2c/fc000066400000000000000000000171071171647030000120500ustar00rootroot00000000000000#! /bin/sh # NOTE: you may need to adjust the references to /usr/local/... below # (or remove them if they're not needed on your system). # You may need to add something like "-Olimit 2000" to the -O # processing below or change it to something more suitable for your # system. See also the comments starting with ### below. # Note that with some shells, invocations of the form # CFLAGS='system-specific stuff' fc ... # may be useful as way to pass system-specific stuff to the C compiler. # The script below simply appends to the initial CFLAGS value. PATH=/usr/local/bin:/bin:/usr/bin # f77-style shell script to compile and load fortran, C, and assembly codes # usage: f77 [options] files [-l library] # Options: # -o objfile Override default executable name a.out. # -a use automatic variable storage (on the stack) # by default -- rather than static storage # -c Do not call linker, leave relocatables in *.o. # -C Check that subscripts are in bounds. # -S leave assembler output on file.s # -L libdir (passed to ld) # -l library (passed to ld) # -u complain about undeclared variables # -w omit all warning messages # -w66 omit Fortran 66 compatibility warning messages # files FORTRAN source files ending in .f . # FORTRAN with cpp preprocessor directives # ending in .F . # C source files ending in .c . # Assembly language files ending in .s . # efl source files ending in .e . # RATFOR files ending in .r . # Object files ending in .o . # Shared libraries ending in .so . # f2c prototype files ending in .P ; such # files only affect subsequent files. # -D def passed to C compiler (for .c files) # or to cpp (for .F files) # -I includepath passed to C compiler (for .c files) # or to cpp (for .F files), and to f2c # -m xxx passed to C compiler as -mxxx # -N tnnn allow nnn entries in table t # -P emit .P files # -r8 promote real to double precision and # complex to double complex # -s strip executable # -trapuv Initialize floating-point variables to # signaling NaNs (on machines with IEEE # arithmetic) unless they appear in save, # common, or data statements. Initialize # other kinds of variables to values that # may attract attention if used without # being assigned proper values. # -U def passed to C compiler (for .c files) # or to cpp (for .F files) to remove def # -v show current f2c version # --version same as -v s=/tmp/stderr_$$ t=/tmp/f77_$$.o ### On some systems (e.g., IRIX), -common prevents complaints ### about multiple definitions of COMMON blocks. #CC=${CC_f2c:-'cc -common'} CC=${CC_f2c:-'cc'} EFL=${EFL:-efl} EFLFLAGS=${EFLFLAGS:-'system=portable deltastno=10'} RATFOR=${RATFOR:-ratfor} RFLAGS=${RFLAGS:-'-6&'} F2C=${F2C:-/usr/local/bin/f2c} show_fc_help=0 case $1 in --help) show_fc_help=1;; --version) show_fc_help=2;; '-?') show_fc_help=1;; -h) show_fc_help=1;; -v) show_fc_help=2;; esac case $show_fc_help in 1) echo 'f77 script based on f2c' echo 'For usage details, see comments at the beginning of' $0 . echo 'For pointers to f2c documentation, invoke' $F2C --help exit 0;; 2) echo $0 'script based on f2c:'; $F2C -v exit 0;; esac F2CFLAGS=${F2CFLAGS:='-ARw8 -Nn802 -Nq300 -Nx400'} CPP=${CPP:-/lib/cpp} rc=0 trap "rm -f $s $t; exit \$rc" 0 OUTF=a.out OUTO= cOPT=1 set -- `getopt acCD:gI:L:m:N:O:U:o:r:sSt:uw6 "$@"` case $? in 0);; *) rc=$?; exit;; esac CPPFLAGS=${CPPFLAGS:-'-I/usr/local/include'} CFLAGSF2C=${CFLAGSF2C:-'-I/usr/local/include'} OFILES= trapuv= strip= LIBS="-lf2c -lm" while test X"$1" != X-- do case "$1" in -a) F2CFLAGS="$F2CFLAGS -a" shift;; -C) F2CFLAGS="$F2CFLAGS -C" shift;; -c) cOPT=0 shift ;; -D) CPPFLAGS="$CPPFLAGS -D$2" shift 2 ;; -g) CFLAGS="$CFLAGS -g" F2CFLAGS="$F2CFLAGS -g" shift;; -I) CPPFLAGS="$CPPFLAGS -I$2" F2CFLAGS="$F2CFLAGS -I$2" shift 2 ;; -m) CC="$CC -m$2" shift 2 ;; -U) CPPFLAGS="$CPPFLAGS -U$2" shift 2 ;; -o) OUTF=$2 OUTO=$2 shift 2 ;; -O) case $2 in 1) O=-O1;; 2) O=-O2;; 3) O=-O3;; *) O=-O;; esac case $O in -O);; *) shift;; esac CFLAGS="$CFLAGS $O" # CFLAGS="$CFLAGS $O -Olimit 2000" shift ;; -r) case $2 in 8) F2CFLAGS="$F2CFLAGS -r8";; *) echo "Ignoring -r$2";; esac shift; shift ;; -s) strip=1 shift ;; -u) F2CFLAGS="$F2CFLAGS -u" shift ;; -w) F2CFLAGS="$F2CFLAGS -w" case $2 in -6) F2CFLAGS="$F2CFLAGS"66; shift case $2 in -6) shift;; esac;; esac shift ;; -L) OFILES="$OFILES $1$2" shift 2 case $cOPT in 1) cOPT=2;; esac ;; -L*) OFILES="$OFILES $1" shift case $cOPT in 1) cOPT=2;; esac ;; -N) F2CFLAGS="$F2CFLAGS $1""$2" shift 2 ;; -P) F2CFLAGS="$F2CFLAGS $1" shift ;; -S) CFLAGS="$CFLAGS -S" cOPT=0 shift ;; -t) case $2 in rapuv) F2CFLAGS="$F2CFLAGS -trapuv" trapuv=1 # LIBS="$LIBS -lfpe" shift 2;; *) echo "invalid parameter $1" 1>&2 shift;; esac ;; '') echo $0: 'unexpected null argument'; exit 1;; *) echo "invalid parameter $1" 1>&2 shift ;; esac done shift case $cOPT in 0) case $OUTO in '');; *) CFLAGS="$CFLAGS -o $OUTO";; esac;; esac while test -n "$1" do case "$1" in *.[fF]) case "$1" in *.f) f=".f";; *.F) f=".F";; esac case "$1" in *.f) b=`basename $1 .f` $F2C $F2CFLAGS $1 rc=$? ;; *.F) b=`basename $1 .F` $CPP $CPPFLAGS $1 >$b.i rc=$? case $rc in 0) $F2C $F2CFLAGS <$b.i >$b.c rc=$? ;;esac rm $b.i ;; esac case $rc in 0);; *) exit;; esac $CC -c $CFLAGSF2C $CFLAGS $b.c 2>$s rc=$? sed '/parameter .* is not referenced/d;/warning: too many parameters/d' $s 1>&2 case $rc in 0);; *) exit;; esac OFILES="$OFILES $b.o" rm $b.c case $cOPT in 1) cOPT=2;; esac shift ;; *.e) b=`basename $1 .e` $EFL $EFLFLAGS $1 >$b.f case $? in 0);; *) rc=$?; exit;; esac $F2C $F2CFLAGS $b.f case $? in 0);; *) rc=$?; exit;; esac $CC -c $CFLAGSF2C $CFLAGS $b.c case $? in 0);; *) rc=$?; exit;; esac OFILES="$OFILES $b.o" rm $b.[cf] case $cOPT in 1) cOPT=2;; esac shift ;; *.r) b=`basename $1 .r` $RATFOR $RFLAGS $1 >$b.f case $? in 0);; *) rc=$?; exit;; esac $F2C $F2CFLAGS $b.f case $? in 0);; *) rc=$?; exit;; esac $CC -c $CFLAGSF2C $CFLAGS $b.c case $? in 0);; *) rc=$?; exit;; esac OFILES="$OFILES $b.o" rm $b.[cf] case $cOPT in 1) cOPT=2;; esac shift ;; *.s) echo $1: 1>&2 OFILE=`basename $1 .s`.o ${AS:-as} -o $OFILE $AFLAGS $1 case $? in 0);; *) rc=$?; exit;; esac OFILES="$OFILES $OFILE" case $cOPT in 1) cOPT=2;; esac shift ;; *.c) echo $1: 1>&2 OFILE=`basename $1 .c`.o $CC -c $CFLAGSF2C $CPPFLAGS $CFLAGS $1 rc=$?; case $rc in 0);; *) rc=$?; exit;; esac OFILES="$OFILES $OFILE" case $cOPT in 1) cOPT=2;; esac shift ;; *.o) OFILES="$OFILES $1" case $cOPT in 1) cOPT=2;; esac shift ;; *.so) OFILES="$OFILES $1" case $cOPT in 1) cOPT=2;; esac shift ;; -[lL]) OFILES="$OFILES $1$2" shift 2 case $cOPT in 1) cOPT=2;; esac ;; -[lL]*) OFILES="$OFILES $1" shift case $cOPT in 1) cOPT=2;; esac ;; -o) case $cOPT in 0) CFLAGS="$CFLAGS -o $2";; *) OUTF=$2;; esac shift 2;; *.P) F2CFLAGS="$F2CFLAGS $1" shift ;; *) OFILES="$OFILES $1" shift case $cOPT in 1) cOPT=2;; esac ;; esac done ### On some (IRIX) systems, -Wl,-dont_warn_unused prevents complaints ### about unnecessary -l options. case $cOPT in 2) # case $trapuv in 1) OFILES="$OFILES -lfpe";; esac # $CC -Wl,-dont_warn_unused -o $OUTF -u MAIN__ -L/usr/local/lib $OFILES $LIBS $CC -o $OUTF -u MAIN__ -L/usr/local/lib $OFILES $LIBS case $strip in 1) strip $OUTF;; esac ;; esac rc=$? exit $rc f2c/getopt.c000066400000000000000000000050321171647030000131750ustar00rootroot00000000000000/**************************************************************** Copyright 1996 by Lucent Technologies. Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the above copyright notice appear in all copies and that both that the copyright notice and this permission notice and warranty disclaimer appear in supporting documentation, and that the names of Bell Laboratories or Lucent Technologies or any of their entities not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. Lucent disclaims all warranties with regard to this software, including all implied warranties of merchantability and fitness. In no event shall Lucent be liable for any special, indirect or consequential damages or any damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortious action, arising out of or in connection with the use or performance of this software. ****************************************************************/ /* Source for a "getopt" command, as invoked by the "fc" script. */ #include static char opts[256]; /* assume 8-bit bytes */ int #ifdef KR_headers main(argc, argv) int argc; char **argv; #else main(int argc, char **argv) #endif { char **av, *fmt, *s, *s0; int i; if (argc < 2) { fprintf(stderr, "Usage: getopt optstring arg1 arg2...\n"); return 1; } for(s = argv[1]; *s; ) { i = *(unsigned char *)s++; if (!opts[i]) opts[i] = 1; if (*s == ':') { s++; opts[i] = 2; } } /* scan for legal args */ av = argv + 2; nextarg: while(s = *av++) { if (*s++ != '-' || s[0] == '-' && s[1] == 0) break; while(i = *(unsigned char *)s++) { switch(opts[i]) { case 0: fprintf(stderr, "getopt: Illegal option -- %c\n", s[-1]); return 1; case 2: s0 = s - 1; if (*s || *av++) goto nextarg; fprintf(stderr, "getopt: Option requires an argument -- %c\n", *s0); return 1; } } } /* output modified args */ av = argv + 2; fmt = "-%c"; nextarg1: while(s = *av++) { if (s[0] != '-') break; if (*++s == '-' && !s[1]) { s = *av++; break; } while(*s) { printf(fmt, *s); fmt = " -%c"; if (opts[*(unsigned char *)s++] == 2) { if (!*s) s = *av++; printf(" %s", s); goto nextarg1; } } } printf(*fmt == ' ' ? " --" : "--"); for(; s; s = *av++) printf(" %s", s); printf("\n"); return 0; } f2c/index000066400000000000000000000012401171647030000125560ustar00rootroot00000000000000file f2c/changes file f2c/f2c.1 lang man page file f2c/f2c.1t lang troff -man source for man page file f2c/f2c.h file f2c/f2c.ps lang Postscript file f2c/f2c.pdf file f2c/fc lang Bourne shell script file f2c/getopt.c for Source for "getopt" command used by fc (for systems lacking getopt) file f2c/index file f2c/libf77 lang C (bundle of source) file f2c/libi77 lang C (bundle of source) file f2c/libf2c.zip for combined libf77, libi77, with several makefile variants size 102 KB # DO NOT REQUEST BY EMAIL, USE FTP! lib f2c/msdos for MS-DOS f2c binaries (ftp only) lib f2c/mswin for Win32 f2c binaries (ftp only) lib f2c/src for f2c source file f2c/README f2c/index.html000066400000000000000000000022411171647030000135230ustar00rootroot00000000000000 f2c

f2c

Click here to see the number of accesses to this library. 

file	changes

file	f2c.1
lang	man page

file	f2c.1t
lang	troff -man source for man page

file	f2c.h

file	f2c.ps
lang	Postscript

file	f2c.pdf

file	fc
lang	Bourne shell script

file	getopt.c
for	Source for "getopt" command used by fc (for systems lacking getopt)

file	index

file	libf77
lang	C (bundle of source)

file	libi77
lang	C (bundle of source)

file	libf2c.zip
for	combined libf77, libi77, with several makefile variants
size	102 KB
#	DO NOT REQUEST BY EMAIL, USE FTP!

lib	msdos
for	MS-DOS f2c binaries (ftp only)

lib	mswin
for	Win32 f2c binaries (ftp only)

lib	src
for	f2c source

file	README
f2c/src/000077500000000000000000000000001171647030000123165ustar00rootroot00000000000000f2c/src/Notice000066400000000000000000000022741171647030000134670ustar00rootroot00000000000000/**************************************************************** Copyright 1990 - 1997 by AT&T, Lucent Technologies and Bellcore. Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the above copyright notice appear in all copies and that both that the copyright notice and this permission notice and warranty disclaimer appear in supporting documentation, and that the names of AT&T, Bell Laboratories, Lucent or Bellcore or any of their entities not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. AT&T, Lucent and Bellcore disclaim all warranties with regard to this software, including all implied warranties of merchantability and fitness. In no event shall AT&T, Lucent or Bellcore be liable for any special, indirect or consequential damages or any damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortious action, arising out of or in connection with the use or performance of this software. ****************************************************************/ f2c/src/README000066400000000000000000000174451171647030000132110ustar00rootroot00000000000000To compile f2c on Linux or Unix systems, copy makefile.u to makefile, edit makefile if necessary (see the comments in it and below) and type "make" (or maybe "nmake", depending on your system). To compile f2c.exe on MS Windows systems with Microsoft Visual C++, copy makefile.vc makefile nmake With other PC compilers, you may need to compile xsum.c with -DMSDOS (i.e., with MSDOS #defined). If your compiler does not understand ANSI/ISO C syntax (i.e., if you have a K&R C compiler), compile with -DKR_headers . On non-Unix systems where files have separate binary and text modes, you may need to "make xsumr.out" rather than "make xsum.out". If (in accordance with what follows) you need to any of the source files (excluding the makefile), first issue a "make xsum.out" (or, if appropriate, "make xsumr.out") to check the validity of the f2c source, then make your changes, then type "make f2c". The file usignal.h is for the benefit of strictly ANSI include files on a UNIX system -- the ANSI signal.h does not define SIGHUP or SIGQUIT. You may need to modify usignal.h if you are not running f2c on a UNIX system. Should you get the message "xsum0.out xsum1.out differ", see what lines are different (`diff xsum0.out xsum1.out`) and ask netlib (e.g., netlib@netlib.org) to send you the files in question, plus the current xsum0.out (which may have changed) "from f2c/src". For example, if exec.c and expr.c have incorrect check sums, you would send netlib the message send exec.c expr.c xsum0.out from f2c/src You can also ftp these files from netlib.bell-labs.com; for more details, ask netlib@netlib.org to "send readme from f2c". On some systems, the malloc and free in malloc.c let f2c run faster than do the standard malloc and free. Other systems may not tolerate redefinition of malloc and free (though changes of 8 Nov. 1994 may render this less of a problem than hitherto). If your system permits use of a user-supplied malloc, you may wish to change the MALLOC = line in the makefile to "MALLOC = malloc.o", or to type make MALLOC=malloc.o instead of make Still other systems have a -lmalloc that provides performance competitive with that from malloc.c; you may wish to compare the two on your system. If your system does not permit user-supplied malloc routines, then f2c may fault with "MALLOC=malloc.o", or may display other untoward behavior. On some BSD systems, you may need to create a file named "string.h" whose single line is #include you may need to add " -Dstrchr=index" to the "CFLAGS =" assignment in the makefile, and you may need to add " memset.o" to the "OBJECTS =" assignment in the makefile -- see the comments in memset.c . For non-UNIX systems, you may need to change some things in sysdep.c, such as the choice of intermediate file names. On some systems, you may need to modify parts of sysdep.h (which is included by defs.h). In particular, for Sun 4.1 systems and perhaps some others, you need to comment out the typedef of size_t. For some systems (e.g., IRIX 4.0.1 and AIX) it is better to add #define ANSI_Libraries to the beginning of sysdep.h (or to supply -DANSI_Libraries in the makefile). Alas, some systems #define __STDC__ but do not provide a true standard (ANSI or ISO) C environment, e.g. do not provide stdlib.h . If yours is such a system, then (a) you should complain loudly to your vendor about __STDC__ being erroneously defined, and (b) you should insert #undef __STDC__ at the beginning of sysdep.h . You may need to make other adjustments. For some non-ANSI versions of stdio, you must change the values given to binread and binwrite in sysdep.c from "rb" and "wb" to "r" and "w". You may need to make this change if you run f2c and get an error message of the form Compiler error ... cannot open intermediate file ... In the days of yore, two libraries, libF77 and libI77, were used with f77 (the Fortran compiler on which f2c is based). Separate source for these libraries is still available from netlib, but it is more convenient to combine them into a single library, libf2c. Source for this combined library is also available from netlib in f2c/libf2c.zip, e.g., http://netlib.bell-labs.com/netlib/f2c/libf2c.zip or http://www.netlib.org/f2c/libf2c.zip (and similarly for other netlib mirrors). After unzipping libf2c.zip, copy the relevant makefile.* to makefile, edit makefile if necessary (see the comments in it and in libf2c/README) and invoke "make" or "nmake". The resulting library is called *f2c.lib on MS Windows systems and libf2c.a or libf2c.so on Linux and Unix systems; makefile.u just shows how to make libf2c.a. Details on creating the shared-library variant, libf2c.so, are system-dependent; some that have worked under Linux appear below. For some other systems, you can glean the details from the system-dependent makefile variants in directory http://www.netlib.org/ampl/solvers/funclink or http://netlib.bell-labs.com/netlib/ampl/solvers/funclink, etc. In general, under Linux it is necessary to compile libf2c (or libI77) with -DNON_UNIX_STDIO . Under at least one variant of Linux, you can make and install a shared-library version of libf2c by compiling libI77 with -DNON_UNIX_STDIO, creating libf2c.a as above, and then executing mkdir t ln lib?77/*.o t cd t; cc -shared -o ../libf2c.so -Wl,-soname,libf2c.so.1 *.o cd .. rm -r t rm /usr/lib/libf2c* mv libf2c.a libf2c.so /usr/lib cd /usr/lib ln libf2c.so libf2c.so.1 ln libf2c.so libf2c.so.1.0.0 On some other systems, /usr/local/lib is the appropriate installation directory. Some older C compilers object to typedef void (*foo)(); or to typedef void zap; zap (*foo)(); If yours is such a compiler, change the definition of VOID in f2c.h from void to int. For convenience with systems that use control-Z to denote end-of-file, f2c treats control-Z characters (ASCII 26, '\x1a') that appear at the beginning of a line as an end-of-file indicator. You can disable this test by compiling lex.c with NO_EOF_CHAR_CHECK #defined, or can change control-Z to some other character by #defining EOF_CHAR to be the desired value. If your machine has IEEE, VAX, or IBM-mainframe arithmetic, but your printf is inaccurate (e.g., with Symantec C++ version 6.0, printf("%.17g",12.) prints 12.000000000000001), you can make f2c print correctly rounded numbers by compiling with -DUSE_DTOA and adding dtoa.o g_fmt.o to the makefile's OBJECTS = line, so it becomes OBJECTS = $(OBJECTSd) malloc.o dtoa.o g_fmt.o Also add the rule dtoa.o: dtoa.c $(CC) -c $(CFLAGS) -DMALLOC=ckalloc -DIEEE... dtoa.c (without the initial tab) to the makefile, where IEEE... is one of IEEE_MC68k, IEEE_8087, VAX, or IBM, depending on your machine's arithmetic. See the comments near the start of dtoa.c. The relevant source files, dtoa.c and g_fmt.c, are available separately from netlib's fp directory. For example, you could send the E-mail message send dtoa.c g_fmt.c from fp to netlib@netlib.netlib.org (or use anonymous ftp from ftp.netlib.org and look in directory /netlib/fp). The makefile has a rule for creating tokdefs.h. If you cannot use the makefile, an alternative is to extract tokdefs.h from the beginning of gram.c: it's the first 100 lines. File mem.c has #ifdef CRAY lines that are appropriate for machines with the conventional CRAY architecture, but not for "Cray" machines based on DEC Alpha chips, such as the T3E; on such machines, you may need to make a suitable adjustment, e.g., add #undef CRAY to sysdep.h. Please send bug reports to dmg at acm.org (with " at " changed to "@"). The old index file (now called "readme" due to unfortunate changes in netlib conventions: "send readme from f2c") will report recent changes in the recent-change log at its end; all changes will be shown in the "changes" file ("send changes from f2c"). To keep current source, you will need to request xsum0.out and version.c, in addition to the changed source files. f2c/src/cds.c000066400000000000000000000101751171647030000132370ustar00rootroot00000000000000/**************************************************************** Copyright 1990, 1993, 1994, 2000 by AT&T, Lucent Technologies and Bellcore. Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the above copyright notice appear in all copies and that both that the copyright notice and this permission notice and warranty disclaimer appear in supporting documentation, and that the names of AT&T, Bell Laboratories, Lucent or Bellcore or any of their entities not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. AT&T, Lucent and Bellcore disclaim all warranties with regard to this software, including all implied warranties of merchantability and fitness. In no event shall AT&T, Lucent or Bellcore be liable for any special, indirect or consequential damages or any damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortious action, arising out of or in connection with the use or performance of this software. ****************************************************************/ /* Put strings representing decimal floating-point numbers * into canonical form: always have a decimal point or * exponent field; if using an exponent field, have the * number before it start with a digit and decimal point * (if the number has more than one digit); only have an * exponent field if it saves space. * * Arrange that the return value, rv, satisfies rv[0] == '-' || rv[-1] == '-' . */ #include "defs.h" char * #ifdef KR_headers cds(s, z0) char *s; char *z0; #else cds(char *s, char *z0) #endif { int ea, esign, et, i, k, nd = 0, sign = 0, tz; char c, *z; char ebuf[24]; long ex = 0; static char etype[Table_size], *db; static int dblen = 64; if (!db) { etype['E'] = 1; etype['e'] = 1; etype['D'] = 1; etype['d'] = 1; etype['+'] = 2; etype['-'] = 3; db = Alloc(dblen); } while((c = *s++) == '0'); if (c == '-') { sign = 1; c = *s++; } else if (c == '+') c = *s++; k = strlen(s) + 2; if (k >= dblen) { do dblen <<= 1; while(k >= dblen); free(db); db = Alloc(dblen); } if (etype[(unsigned char)c] >= 2) while(c == '0') c = *s++; tz = 0; while(c >= '0' && c <= '9') { if (c == '0') tz++; else { if (nd) for(; tz; --tz) db[nd++] = '0'; else tz = 0; db[nd++] = c; } c = *s++; } ea = -tz; if (c == '.') { while((c = *s++) >= '0' && c <= '9') { if (c == '0') tz++; else { if (tz) { ea += tz; if (nd) for(; tz; --tz) db[nd++] = '0'; else tz = 0; } db[nd++] = c; ea++; } } } if (et = etype[(unsigned char)c]) { esign = et == 3; c = *s++; if (et == 1) { if(etype[(unsigned char)c] > 1) { if (c == '-') esign = 1; c = *s++; } } while(c >= '0' && c <= '9') { ex = 10*ex + (c - '0'); c = *s++; } if (esign) ex = -ex; } switch(c) { case 0: break; #ifndef VAX case 'i': case 'I': Fatal("Overflow evaluating constant expression."); case 'n': case 'N': Fatal("Constant expression yields NaN."); #endif default: Fatal("unexpected character in cds."); } ex -= ea; if (!nd) { if (!z0) z0 = mem(4,0); strcpy(z0, "-0."); /* sign = 0; */ /* 20010820: preserve sign of 0. */ } else if (ex > 2 || ex + nd < -2) { sprintf(ebuf, "%ld", ex + nd - 1); k = strlen(ebuf) + nd + 3; if (nd > 1) k++; if (!z0) z0 = mem(k,0); z = z0; *z++ = '-'; *z++ = *db; if (nd > 1) { *z++ = '.'; for(k = 1; k < nd; k++) *z++ = db[k]; } *z++ = 'e'; strcpy(z, ebuf); } else { k = (int)(ex + nd); i = nd + 3; if (k < 0) i -= k; else if (ex > 0) i += (int)ex; if (!z0) z0 = mem(i,0); z = z0; *z++ = '-'; if (ex >= 0) { for(k = 0; k < nd; k++) *z++ = db[k]; while(--ex >= 0) *z++ = '0'; *z++ = '.'; } else { for(i = 0; i < k;) *z++ = db[i++]; *z++ = '.'; while(++k <= 0) *z++ = '0'; while(i < nd) *z++ = db[i++]; } *z = 0; } return sign ? z0 : z0+1; } f2c/src/data.c000066400000000000000000000247111171647030000134000ustar00rootroot00000000000000/**************************************************************** Copyright 1990, 1993-1996, 1999, 2001 by AT&T, Lucent Technologies and Bellcore. Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the above copyright notice appear in all copies and that both that the copyright notice and this permission notice and warranty disclaimer appear in supporting documentation, and that the names of AT&T, Bell Laboratories, Lucent or Bellcore or any of their entities not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. AT&T, Lucent and Bellcore disclaim all warranties with regard to this software, including all implied warranties of merchantability and fitness. In no event shall AT&T, Lucent or Bellcore be liable for any special, indirect or consequential damages or any damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortious action, arising out of or in connection with the use or performance of this software. ****************************************************************/ #include "defs.h" /* ROUTINES CALLED DURING DATA AND PARAMETER STATEMENT PROCESSING */ static char datafmt[] = "%s\t%09ld\t%d"; static char *cur_varname; /* another initializer, called from parser */ void #ifdef KR_headers dataval(repp, valp) register expptr repp; register expptr valp; #else dataval(register expptr repp, register expptr valp) #endif { ftnint elen, i, nrep; register Addrp p; if (parstate < INDATA) { frexpr(repp); goto ret; } if(repp == NULL) nrep = 1; else if (ISICON(repp) && repp->constblock.Const.ci >= 0) nrep = repp->constblock.Const.ci; else { err("invalid repetition count in DATA statement"); frexpr(repp); goto ret; } frexpr(repp); if( ! ISCONST(valp) ) { if (valp->tag == TADDR && valp->addrblock.uname_tag == UNAM_CONST) { /* kludge */ frexpr(valp->addrblock.memoffset); valp->tag = TCONST; } else { err("non-constant initializer"); goto ret; } } if(toomanyinit) goto ret; for(i = 0 ; i < nrep ; ++i) { p = nextdata(&elen); if(p == NULL) { if (lineno != err_lineno) err("too many initializers"); toomanyinit = YES; goto ret; } setdata((Addrp)p, (Constp)valp, elen); frexpr((expptr)p); } ret: frexpr(valp); } Addrp #ifdef KR_headers nextdata(elenp) ftnint *elenp; #else nextdata(ftnint *elenp) #endif { register struct Impldoblock *ip; struct Primblock *pp; register Namep np; register struct Rplblock *rp; tagptr p; expptr neltp; register expptr q; int skip; ftnint off, vlen; while(curdtp) { p = (tagptr)curdtp->datap; if(p->tag == TIMPLDO) { ip = &(p->impldoblock); if(ip->implb==NULL || ip->impub==NULL || ip->varnp==NULL) { char buf[100]; sprintf(buf, "bad impldoblock #%lx", (unsigned long)ip); Fatal(buf); } if(ip->isactive) ip->varvp->Const.ci += ip->impdiff; else { q = fixtype(cpexpr(ip->implb)); if( ! ISICON(q) ) goto doerr; ip->varvp = (Constp) q; if(ip->impstep) { q = fixtype(cpexpr(ip->impstep)); if( ! ISICON(q) ) goto doerr; ip->impdiff = q->constblock.Const.ci; frexpr(q); } else ip->impdiff = 1; q = fixtype(cpexpr(ip->impub)); if(! ISICON(q)) goto doerr; ip->implim = q->constblock.Const.ci; frexpr(q); ip->isactive = YES; rp = ALLOC(Rplblock); rp->rplnextp = rpllist; rpllist = rp; rp->rplnp = ip->varnp; rp->rplvp = (expptr) (ip->varvp); rp->rpltag = TCONST; } if( (ip->impdiff>0 && (ip->varvp->Const.ci <= ip->implim)) || (ip->impdiff<0 && (ip->varvp->Const.ci >= ip->implim)) ) { /* start new loop */ curdtp = ip->datalist; goto next; } /* clean up loop */ if(rpllist) { rp = rpllist; rpllist = rpllist->rplnextp; free( (charptr) rp); } else Fatal("rpllist empty"); frexpr((expptr)ip->varvp); ip->isactive = NO; curdtp = curdtp->nextp; goto next; } pp = (struct Primblock *) p; np = pp->namep; cur_varname = np->fvarname; skip = YES; if(p->primblock.argsp==NULL && np->vdim!=NULL) { /* array initialization */ q = (expptr) mkaddr(np); off = typesize[np->vtype] * curdtelt; if(np->vtype == TYCHAR) off *= np->vleng->constblock.Const.ci; q->addrblock.memoffset = mkexpr(OPPLUS, q->addrblock.memoffset, mkintcon(off) ); if( (neltp = np->vdim->nelt) && ISCONST(neltp)) { if(++curdtelt < neltp->constblock.Const.ci) skip = NO; } else err("attempt to initialize adjustable array"); } else q = mklhs((struct Primblock *)cpexpr((expptr)pp), 0); if(skip) { curdtp = curdtp->nextp; curdtelt = 0; } if(q->headblock.vtype == TYCHAR) if(ISICON(q->headblock.vleng)) *elenp = q->headblock.vleng->constblock.Const.ci; else { err("initialization of string of nonconstant length"); continue; } else *elenp = typesize[q->headblock.vtype]; if (np->vstg == STGBSS) { vlen = np->vtype==TYCHAR ? np->vleng->constblock.Const.ci : typesize[np->vtype]; if(vlen > 0) np->vstg = STGINIT; } return( (Addrp) q ); doerr: err("nonconstant implied DO parameter"); frexpr(q); curdtp = curdtp->nextp; next: curdtelt = 0; } return(NULL); } LOCAL FILEP dfile; void #ifdef KR_headers setdata(varp, valp, elen) register Addrp varp; register Constp valp; ftnint elen; #else setdata(register Addrp varp, register Constp valp, ftnint elen) #endif { struct Constblock con; register int type; int j, valtype; ftnint i, k, offset; char *varname; static Addrp badvar; register unsigned char *s; static long last_lineno; static char *last_varname; if (varp->vstg == STGCOMMON) { if (!(dfile = blkdfile)) dfile = blkdfile = opf(blkdfname, textwrite); } else { if (procclass == CLBLOCK) { if (varp != badvar) { badvar = varp; warn1("%s is not in a COMMON block", varp->uname_tag == UNAM_NAME ? varp->user.name->fvarname : "???"); } return; } if (!(dfile = initfile)) dfile = initfile = opf(initfname, textwrite); } varname = dataname(varp->vstg, varp->memno); offset = varp->memoffset->constblock.Const.ci; type = varp->vtype; valtype = valp->vtype; if(type!=TYCHAR && valtype==TYCHAR) { if(! ftn66flag && (last_varname != cur_varname || last_lineno != lineno)) { /* prevent multiple warnings */ last_lineno = lineno; warn1( "non-character datum %.42s initialized with character string", last_varname = cur_varname); } varp->vleng = ICON(typesize[type]); varp->vtype = type = TYCHAR; } else if( (type==TYCHAR && valtype!=TYCHAR) || (cktype(OPASSIGN,type,valtype) == TYERROR) ) { err("incompatible types in initialization"); return; } if(type == TYADDR) con.Const.ci = valp->Const.ci; else if(type != TYCHAR) { if(valtype == TYUNKNOWN) con.Const.ci = valp->Const.ci; else consconv(type, &con, valp); } j = 1; switch(type) { case TYLOGICAL: case TYINT1: case TYLOGICAL1: case TYLOGICAL2: case TYSHORT: case TYLONG: #ifdef TYQUAD0 case TYQUAD: #endif dataline(varname, offset, type); prconi(dfile, con.Const.ci); break; #ifndef NO_LONG_LONG case TYQUAD: dataline(varname, offset, type); prconq(dfile, con.Const.cq); break; #endif case TYADDR: dataline(varname, offset, type); prcona(dfile, con.Const.ci); break; case TYCOMPLEX: case TYDCOMPLEX: j = 2; case TYREAL: case TYDREAL: dataline(varname, offset, type); prconr(dfile, &con, j); break; case TYCHAR: k = valp -> vleng -> constblock.Const.ci; if (elen < k) k = elen; s = (unsigned char *)valp->Const.ccp; for(i = 0 ; i < k ; ++i) { dataline(varname, offset++, TYCHAR); fprintf(dfile, "\t%d\n", *s++); } k = elen - valp->vleng->constblock.Const.ci; if(k > 0) { dataline(varname, offset, TYBLANK); fprintf(dfile, "\t%d\n", (int)k); } break; default: badtype("setdata", type); } } /* output form of name is padded with blanks and preceded with a storage class digit */ char* #ifdef KR_headers dataname(stg, memno) int stg; long memno; #else dataname(int stg, long memno) #endif { static char varname[64]; register char *s, *t; char buf[16]; if (stg == STGCOMMON) { varname[0] = '2'; sprintf(s = buf, "Q.%ld", memno); } else { varname[0] = stg==STGEQUIV ? '1' : '0'; s = memname(stg, memno); } t = varname + 1; while(*t++ = *s++); *t = 0; return(varname); } void #ifdef KR_headers frdata(p0) chainp p0; #else frdata(chainp p0) #endif { register struct Chain *p; register tagptr q; for(p = p0 ; p ; p = p->nextp) { q = (tagptr)p->datap; if(q->tag == TIMPLDO) { if(q->impldoblock.isbusy) return; /* circular chain completed */ q->impldoblock.isbusy = YES; frdata(q->impldoblock.datalist); free( (charptr) q); } else frexpr(q); } frchain( &p0); } void #ifdef KR_headers dataline(varname, offset, type) char *varname; ftnint offset; int type; #else dataline(char *varname, ftnint offset, int type) #endif { fprintf(dfile, datafmt, varname, offset, type); } void #ifdef KR_headers make_param(p, e) register struct Paramblock *p; expptr e; #else make_param(register struct Paramblock *p, expptr e) #endif { register expptr q; Constp qc; if (p->vstg == STGARG) errstr("Dummy argument %.50s appears in a parameter statement.", p->fvarname); p->vclass = CLPARAM; impldcl((Namep)p); if (e->headblock.vtype != TYCHAR) e = putx(fixtype(e)); p->paramval = q = mkconv(p->vtype, e); if (p->vtype == TYCHAR) { if (q->tag == TEXPR) p->paramval = q = fixexpr((Exprp)q); if (q->tag == TADDR && q->addrblock.uname_tag == UNAM_CONST) { qc = mkconst(TYCHAR); qc->Const = q->addrblock.user.Const; qc->vleng = q->addrblock.vleng; q->addrblock.vleng = 0; frexpr(q); p->paramval = q = (expptr)qc; } if (!ISCONST(q) || q->constblock.vtype != TYCHAR) { errstr("invalid value for character parameter %s", p->fvarname); return; } if (!(e = p->vleng)) p->vleng = ICON(q->constblock.vleng->constblock.Const.ci + q->constblock.Const.ccp1.blanks); else if (q->constblock.vleng->constblock.Const.ci > e->constblock.Const.ci) { q->constblock.vleng->constblock.Const.ci = e->constblock.Const.ci; q->constblock.Const.ccp1.blanks = 0; } else q->constblock.Const.ccp1.blanks = e->constblock.Const.ci - q->constblock.vleng->constblock.Const.ci; } } f2c/src/defines.h000066400000000000000000000210201171647030000140770ustar00rootroot00000000000000#define PDP11 4 #define BIGGEST_CHAR 0x7f /* Assumes 32-bit arithmetic */ #define BIGGEST_SHORT 0x7fff /* Assumes 32-bit arithmetic */ #define BIGGEST_LONG 0x7fffffff /* Assumes 32-bit arithmetic */ #define M(x) (1<tag==TCONST && ISINT(z->constblock.vtype)) #define ISLOGICAL(z) ONEOF(z, MSKLOGICAL) /* ISCHAR assumes that z has some kind of structure, i.e. is not null */ #define ISCHAR(z) (z->headblock.vtype==TYCHAR) #define ISINT(z) ONEOF(z, MSKINT) /* z is a tag, i.e. a mask number */ #define ISCONST(z) (z->tag==TCONST) #define ISERROR(z) (z->tag==TERROR) #define ISPLUSOP(z) (z->tag==TEXPR && z->exprblock.opcode==OPPLUS) #define ISSTAROP(z) (z->tag==TEXPR && z->exprblock.opcode==OPSTAR) #define ISONE(z) (ISICON(z) && z->constblock.Const.ci==1) #define INT(z) ONEOF(z, MSKINT|MSKCHAR) /* has INT storage in real life */ #define ICON(z) mkintcon( (ftnint)(z) ) /* NO66 -- F77 feature is being used NOEXT -- F77 extension is being used */ #define NO66(s) if(no66flag) err66(s) #define NOEXT(s) if(noextflag) errext(s) f2c/src/defs.h000066400000000000000000001033331171647030000134130ustar00rootroot00000000000000/**************************************************************** Copyright 1990 - 1996, 1999-2001 by AT&T, Lucent Technologies and Bellcore. Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the above copyright notice appear in all copies and that both that the copyright notice and this permission notice and warranty disclaimer appear in supporting documentation, and that the names of AT&T, Bell Laboratories, Lucent or Bellcore or any of their entities not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. AT&T, Lucent and Bellcore disclaim all warranties with regard to this software, including all implied warranties of merchantability and fitness. In no event shall AT&T, Lucent or Bellcore be liable for any special, indirect or consequential damages or any damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortious action, arising out of or in connection with the use or performance of this software. ****************************************************************/ #include "sysdep.h" #include "ftypes.h" #include "defines.h" #include "machdefs.h" #define MAXDIM 20 #define MAXINCLUDES 10 #define MAXLITERALS 200 /* Max number of constants in the literal pool */ #define MAXCTL 20 #define MAXHASH 802 #define MAXSTNO 801 #define MAXEXT 400 #define MAXEQUIV 300 #define MAXLABLIST 258 /* Max number of labels in an alternate return CALL or computed GOTO */ #define MAXCONTIN 99 /* Max continuation lines */ #define MAX_SHARPLINE_LEN 1000 /* Elbow room for #line lines with long names */ /* These are the primary pointer types used in the compiler */ typedef union Expression *expptr, *tagptr; typedef struct Chain *chainp; typedef struct Addrblock *Addrp; typedef struct Constblock *Constp; typedef struct Exprblock *Exprp; typedef struct Nameblock *Namep; extern FILEP infile; extern FILEP diagfile; extern FILEP textfile; extern FILEP asmfile; extern FILEP c_file; /* output file for all functions; extern declarations will have to be prepended */ extern FILEP pass1_file; /* Temp file to hold the function bodies read on pass 1 */ extern FILEP expr_file; /* Debugging file */ extern FILEP initfile; /* Intermediate data file pointer */ extern FILEP blkdfile; /* BLOCK DATA file */ extern int current_ftn_file; extern int maxcontin; extern char *blkdfname, *initfname, *sortfname; extern long headoffset; /* Since the header block requires data we don't know about until AFTER each function has been processed, we keep a pointer to the current (dummy) header block (at the top of the assembly file) here */ extern char main_alias[]; /* name given to PROGRAM psuedo-op */ extern char *token; extern int maxtoklen, toklen; extern long err_lineno, lineno; extern char *infname; extern int needkwd; extern struct Labelblock *thislabel; /* Used to allow runtime expansion of internal tables. In particular, these values can exceed their associated constants */ extern int maxctl; extern int maxequiv; extern int maxstno; extern int maxhash; extern int maxext; extern flag nowarnflag; extern flag ftn66flag; /* Generate warnings when weird f77 features are used (undeclared dummy procedure, non-char initialized with string, 1-dim subscript in EQUIV) */ extern flag no66flag; /* Generate an error when a generic function (f77 feature) is used */ extern flag noextflag; /* Generate an error when an extension to Fortran 77 is used (hex/oct/bin constants, automatic, static, double complex types) */ extern flag zflag; /* enable double complex intrinsics */ extern flag shiftcase; extern flag undeftype; extern flag shortsubs; /* Use short subscripts on arrays? */ extern flag onetripflag; /* if true, always execute DO loop body */ extern flag checksubs; extern flag debugflag; extern int nerr; extern int nwarn; extern int parstate; extern flag headerdone; /* True iff the current procedure's header data has been written */ extern int blklevel; extern flag saveall; extern flag substars; /* True iff some formal parameter is an asterisk */ extern int impltype[ ]; extern ftnint implleng[ ]; extern int implstg[ ]; extern int tycomplex, tyint, tyioint, tyreal; extern int tylog, tylogical; /* TY____ of the implementation of logical. This will be LONG unless '-2' is given on the command line */ extern int type_choice[]; extern char *Typename[]; extern int typesize[]; /* size (in bytes) of an object of each type. Indexed by TY___ macros */ extern int typealign[]; extern int proctype; /* Type of return value in this procedure */ extern char * procname; /* External name of the procedure, or last ENTRY name */ extern int rtvlabel[ ]; /* Return value labels, indexed by TY___ macros */ extern Addrp retslot; extern Addrp xretslot[]; extern int cxslot; /* Complex return argument slot (frame pointer offset)*/ extern int chslot; /* Character return argument slot (fp offset) */ extern int chlgslot; /* Argument slot for length of character buffer */ extern int procclass; /* Class of the current procedure: either CLPROC, CLMAIN, CLBLOCK or CLUNKNOWN */ extern ftnint procleng; /* Length of function return value (e.g. char string length). If this is -1, then the length is not known at compile time */ extern int nentry; /* Number of entry points (other than the original function call) into this procedure */ extern flag multitype; /* YES iff there is more than one return value possible */ extern int blklevel; extern long lastiolabno; extern long lastlabno; extern int lastvarno; extern int lastargslot; /* integer offset pointing to the next free location for an argument to the current routine */ extern int argloc; extern int autonum[]; /* for numbering automatic variables, e.g. temporaries */ extern int retlabel; extern int ret0label; extern int dorange; /* Number of the label which terminates the innermost DO loop */ extern int regnum[ ]; /* Numbers of DO indicies named in regnamep (below) */ extern Namep regnamep[ ]; /* List of DO indicies in registers */ extern int maxregvar; /* number of elts in regnamep */ extern int highregvar; /* keeps track of the highest register number used by DO index allocator */ extern int nregvar; /* count of DO indicies in registers */ extern chainp templist[]; extern int maxdim; extern chainp earlylabs; extern chainp holdtemps; extern struct Entrypoint *entries; extern struct Rplblock *rpllist; extern struct Chain *curdtp; extern ftnint curdtelt; extern chainp allargs; /* union of args in entries */ extern int nallargs; /* total number of args */ extern int nallchargs; /* total number of character args */ extern flag toomanyinit; /* True iff too many initializers in a DATA statement */ extern flag inioctl; extern int iostmt; extern Addrp ioblkp; extern int nioctl; extern int nequiv; extern int eqvstart; /* offset to eqv number to guarantee uniqueness and prevent from going negative */ extern int nintnames; /* Chain of tagged blocks */ struct Chain { chainp nextp; char * datap; /* Tagged block */ }; extern chainp chains; /* Recall that field is intended to hold four-bit characters */ /* This structure exists only to defeat the type checking */ struct Headblock { field tag; field vtype; field vclass; field vstg; expptr vleng; /* Expression for length of char string - this may be a constant, or an argument generated by mkarg() */ } ; /* Control construct info (for do loops, else, etc) */ struct Ctlframe { unsigned ctltype:8; unsigned dostepsign:8; /* 0 - variable, 1 - pos, 2 - neg */ unsigned dowhile:1; int ctlabels[4]; /* Control labels, defined below */ int dolabel; /* label marking end of this DO loop */ Namep donamep; /* DO index variable */ expptr doinit; /* for use with -onetrip */ expptr domax; /* constant or temp variable holding MAX loop value; or expr of while(expr) */ expptr dostep; /* expression */ Namep loopname; }; #define endlabel ctlabels[0] #define elselabel ctlabels[1] #define dobodylabel ctlabels[1] #define doposlabel ctlabels[2] #define doneglabel ctlabels[3] extern struct Ctlframe *ctls; /* Keeps info on DO and BLOCK IF structures - this is the stack bottom */ extern struct Ctlframe *ctlstack; /* Pointer to current nesting level */ extern struct Ctlframe *lastctl; /* Point to end of dynamically-allocated array */ typedef struct { int type; chainp cp; } Atype; typedef struct { int defined, dnargs, nargs, changes; Atype atypes[1]; } Argtypes; /* External Symbols */ struct Extsym { char *fextname; /* Fortran version of external name */ char *cextname; /* C version of external name */ field extstg; /* STG -- should be COMMON, UNKNOWN or EXT */ unsigned extype:4; /* for transmitting type to output routines */ unsigned used_here:1; /* Boolean - true on the second pass through a function if the block has been referenced */ unsigned exused:1; /* Has been used (for help with error msgs about externals typed differently in different modules) */ unsigned exproto:1; /* type specified in a .P file */ unsigned extinit:1; /* Procedure has been defined, or COMMON has DATA */ unsigned extseen:1; /* True if previously referenced */ chainp extp; /* List of identifiers in the common block for this function, stored as Namep (hash table pointers) */ chainp allextp; /* List of lists of identifiers; we keep one list for each layout of this common block */ int curno; /* current number for this common block, used for constructing appending _nnn to the common block name */ int maxno; /* highest curno value for this common block */ ftnint extleng; ftnint maxleng; Argtypes *arginfo; }; typedef struct Extsym Extsym; extern Extsym *extsymtab; /* External symbol table */ extern Extsym *nextext; extern Extsym *lastext; extern int complex_seen, dcomplex_seen; /* Statement labels */ struct Labelblock { int labelno; /* Internal label */ unsigned blklevel:8; /* level of nesting, for branch-in-loop checking */ unsigned labused:1; unsigned fmtlabused:1; unsigned labinacc:1; /* inaccessible? (i.e. has its scope vanished) */ unsigned labdefined:1; /* YES or NO */ unsigned labtype:2; /* LAB{FORMAT,EXEC,etc} */ ftnint stateno; /* Original label */ char *fmtstring; /* format string */ }; extern struct Labelblock *labeltab; /* Label table - keeps track of all labels, including undefined */ extern struct Labelblock *labtabend; extern struct Labelblock *highlabtab; /* Entry point list */ struct Entrypoint { struct Entrypoint *entnextp; Extsym *entryname; /* Name of this ENTRY */ chainp arglist; int typelabel; /* Label for function exit; this will return the proper type of object */ Namep enamep; /* External name */ }; /* Primitive block, or Primary block. This is a general template returned by the parser, which will be interpreted in context. It is a template for an identifier (variable name, function name), parenthesized arguments (array subscripts, function parameters) and substring specifications. */ struct Primblock { field tag; field vtype; unsigned parenused:1; /* distinguish (a) from a */ Namep namep; /* Pointer to structure Nameblock */ struct Listblock *argsp; expptr fcharp; /* first-char-index-pointer (in substring) */ expptr lcharp; /* last-char-index-pointer (in substring) */ }; struct Hashentry { int hashval; Namep varp; }; extern struct Hashentry *hashtab; /* Hash table */ extern struct Hashentry *lasthash; struct Intrpacked /* bits for intrinsic function description */ { unsigned f1:4; unsigned f2:4; unsigned f3:7; unsigned f4:1; }; struct Nameblock { field tag; field vtype; field vclass; field vstg; expptr vleng; /* length of character string, if applicable */ char *fvarname; /* name in the Fortran source */ char *cvarname; /* name in the resulting C */ chainp vlastdim; /* datap points to new_vars entry for the */ /* system variable, if any, storing the final */ /* dimension; we zero the datap if this */ /* variable is needed */ unsigned vprocclass:3; /* P____ macros - selects the varxptr field below */ unsigned vdovar:1; /* "is it a DO variable?" for register and multi-level loop checking */ unsigned vdcldone:1; /* "do I think I'm done?" - set when the context is sufficient to determine its status */ unsigned vadjdim:1; /* "adjustable dimension?" - needed for information about copies */ unsigned vsave:1; unsigned vimpldovar:1; /* used to prevent erroneous error messages for variables used only in DATA stmt implicit DOs */ unsigned vis_assigned:1;/* True if this variable has had some label ASSIGNED to it; hence varxptr.assigned_values is valid */ unsigned vimplstg:1; /* True if storage type is assigned implicitly; this allows a COMMON variable to participate in a DIMENSION before the COMMON declaration. */ unsigned vcommequiv:1; /* True if EQUIVALENCEd onto STGCOMMON */ unsigned vfmt_asg:1; /* True if char *var_fmt needed */ unsigned vpassed:1; /* True if passed as a character-variable arg */ unsigned vknownarg:1; /* True if seen in a previous entry point */ unsigned visused:1; /* True if variable is referenced -- so we */ /* can omit variables that only appear in DATA */ unsigned vnamelist:1; /* Appears in a NAMELIST */ unsigned vimpltype:1; /* True if implicitly typed and not invoked as a function or subroutine (so we can consistently type procedures declared external and passed as args but never invoked). */ unsigned vtypewarned:1; /* so we complain just once about changed types of external procedures */ unsigned vinftype:1; /* so we can restore implicit type to a procedure if it is invoked as a function after being given a different type by -it */ unsigned vinfproc:1; /* True if -it infers this to be a procedure */ unsigned vcalled:1; /* has been invoked */ unsigned vdimfinish:1; /* need to invoke dim_finish() */ unsigned vrefused:1; /* Need to #define name_ref (for -s) */ unsigned vsubscrused:1; /* Need to #define name_subscr (for -2) */ unsigned veqvadjust:1; /* voffset has been adjusted for equivalence */ /* The vardesc union below is used to store the number of an intrinsic function (when vstg == STGINTR and vprocclass == PINTRINSIC), or to store the index of this external symbol in extsymtab (when vstg == STGEXT and vprocclass == PEXTERNAL) */ union { int varno; /* Return variable for a function. This is used when a function is assigned a return value. Also used to point to the COMMON block, when this is a field of that block. Also points to EQUIV block when STGEQUIV */ struct Intrpacked intrdesc; /* bits for intrinsic function*/ } vardesc; struct Dimblock *vdim; /* points to the dimensions if they exist */ ftnint voffset; /* offset in a storage block (the variable name will be "v.%d", voffset in a common blck on the vax). Also holds pointers for automatic variables. When STGEQUIV, this is -(offset from array base) */ union { chainp namelist; /* points to names in the NAMELIST, if this is a NAMELIST name */ chainp vstfdesc; /* points to (formals, expr) pair */ chainp assigned_values; /* list of integers, each being a statement label assigned to this variable in the current function */ } varxptr; int argno; /* for multiple entries */ Argtypes *arginfo; }; /* PARAMETER statements */ struct Paramblock { field tag; field vtype; field vclass; field vstg; expptr vleng; char *fvarname; char *cvarname; expptr paramval; } ; /* Expression block */ struct Exprblock { field tag; field vtype; field vclass; field vstg; expptr vleng; /* in the case of a character expression, this value is inherited from the children */ unsigned int opcode; expptr leftp; expptr rightp; int typefixed; }; union Constant { struct { char *ccp0; ftnint blanks; } ccp1; ftnint ci; /* Constant integer */ #ifndef NO_LONG_LONG Llong cq; /* for TYQUAD integer */ ULlong ucq; #endif double cd[2]; char *cds[2]; }; #define ccp ccp1.ccp0 struct Constblock { field tag; field vtype; field vclass; field vstg; /* vstg = 1 when using Const.cds */ expptr vleng; union Constant Const; }; struct Listblock { field tag; field vtype; chainp listp; }; /* Address block - this is the FINAL form of identifiers before being sent to pass 2. We'll want to add the original identifier here so that it can be preserved in the translation. An example identifier is q.7. The "q" refers to the storage class (field vstg), the 7 to the variable number (int memno). */ struct Addrblock { field tag; field vtype; field vclass; field vstg; expptr vleng; /* put union...user here so the beginning of an Addrblock * is the same as a Constblock. */ union { Namep name; /* contains a pointer into the hash table */ char ident[IDENT_LEN + 1]; /* C string form of identifier */ char *Charp; union Constant Const; /* Constant value */ struct { double dfill[2]; field vstg1; } kludge; /* so we can distinguish string vs binary * floating-point constants */ } user; long memno; /* when vstg == STGCONST, this is the numeric part of the assembler label where the constant value is stored */ expptr memoffset; /* used in subscript computations, usually */ unsigned istemp:1; /* used in stack management of temporary variables */ unsigned isarray:1; /* used to show that memoffset is meaningful, even if zero */ unsigned ntempelt:10; /* for representing temporary arrays, as in concatenation */ unsigned dbl_builtin:1; /* builtin to be declared double */ unsigned charleng:1; /* so saveargtypes can get i/o calls right */ unsigned cmplx_sub:1; /* used in complex arithmetic under -s */ unsigned skip_offset:1; /* used in complex arithmetic under -s */ unsigned parenused:1; /* distinguish (a) from a */ ftnint varleng; /* holds a copy of a constant length which is stored in the vleng field (e.g. a double is 8 bytes) */ int uname_tag; /* Tag describing which of the unions() below to use */ char *Field; /* field name when dereferencing a struct */ }; /* struct Addrblock */ /* Errorbock - placeholder for errors, to allow the compilation to continue */ struct Errorblock { field tag; field vtype; }; /* Implicit DO block, especially related to DATA statements. This block keeps track of the compiler's location in the implicit DO while it's running. In particular, the isactive and isbusy flags tell where it is */ struct Impldoblock { field tag; unsigned isactive:1; unsigned isbusy:1; Namep varnp; Constp varvp; chainp impdospec; expptr implb; expptr impub; expptr impstep; ftnint impdiff; ftnint implim; struct Chain *datalist; }; /* Each of these components has a first field called tag. This union exists just for allocation simplicity */ union Expression { field tag; struct Addrblock addrblock; struct Constblock constblock; struct Errorblock errorblock; struct Exprblock exprblock; struct Headblock headblock; struct Impldoblock impldoblock; struct Listblock listblock; struct Nameblock nameblock; struct Paramblock paramblock; struct Primblock primblock; } ; struct Dimblock { int ndim; expptr nelt; /* This is NULL if the array is unbounded */ expptr baseoffset; /* a constant or local variable holding the offset in this procedure */ expptr basexpr; /* expression for comuting the offset, if it's not constant. If this is non-null, the register named in baseoffset will get initialized to this value in the procedure's prolog */ struct { expptr dimsize; /* constant or register holding the size of this dimension */ expptr dimexpr; /* as above in basexpr, this is an expression for computing a variable dimension */ } dims[1]; /* Dimblocks are allocated with enough space for this to become dims[ndim] */ }; /* Statement function identifier stack - this holds the name and value of the parameters in a statement function invocation. For example, f(x,y,z)=x+y+z . . y = f(1,2,3) generates a stack of depth 3, with , , AT THE INVOCATION, NOT at the definition */ struct Rplblock /* name replacement block */ { struct Rplblock *rplnextp; Namep rplnp; /* Name of the formal parameter */ expptr rplvp; /* Value of the actual parameter */ expptr rplxp; /* Initialization of temporary variable, if required; else null */ int rpltag; /* Tag on the value of the actual param */ }; /* Equivalence block */ struct Equivblock { struct Eqvchain *equivs; /* List (Eqvchain) of primblocks holding variable identifiers */ flag eqvinit; long eqvtop; long eqvbottom; int eqvtype; } ; #define eqvleng eqvtop extern struct Equivblock *eqvclass; struct Eqvchain { struct Eqvchain *eqvnextp; union { struct Primblock *eqvlhs; Namep eqvname; } eqvitem; long eqvoffset; } ; /* For allocation purposes only, and to keep lint quiet. In particular, don't count on the tag being able to tell you which structure is used */ /* There is a tradition in Fortran that the compiler not generate the same bit pattern more than is necessary. This structure is used to do just that; if two integer constants have the same bit pattern, just generate it once. This could be expanded to optimize without regard to type, by removing the type check in putconst() */ struct Literal { short littype; short lituse; /* usage count */ long litnum; /* numeric part of the assembler label for this constant value */ union { ftnint litival; double litdval[2]; ftnint litival2[2]; /* length, nblanks for strings */ #ifndef NO_LONG_LONG Llong litqval; #endif } litval; char *cds[2]; }; extern struct Literal *litpool; extern int maxliterals, nliterals; extern unsigned char Letters[]; #define letter(x) Letters[x] struct Dims { expptr lb, ub; }; extern int forcedouble; /* force real functions to double */ extern int doin_setbound; /* special handling for array bounds */ extern int Ansi; extern unsigned char hextoi_tab[]; #define hextoi(x) hextoi_tab[(x) & 0xff] extern char *casttypes[], *ftn_types[], *protorettypes[], *usedcasts[]; extern int Castargs, infertypes; extern FILE *protofile; extern char binread[], binwrite[], textread[], textwrite[]; extern char *ei_first, *ei_last, *ei_next; extern char *wh_first, *wh_last, *wh_next; extern char *halign, *outbuf, *outbtail; extern flag keepsubs; #ifdef TYQUAD extern flag use_tyquad; extern unsigned long ff; #ifndef NO_LONG_LONG extern flag allow_i8c; #endif #endif /*TYQUAD*/ extern int n_keywords; extern char *c_keywords[]; #ifdef KR_headers #define Argdcl(x) () #define Void /* void */ #else #define Argdcl(x) x #define Void void #endif char* Alloc Argdcl((int)); char* Argtype Argdcl((int, char*)); void Fatal Argdcl((char*)); struct Impldoblock* mkiodo Argdcl((chainp, chainp)); tagptr Inline Argdcl((int, int, chainp)); struct Labelblock* execlab Argdcl((long)); struct Labelblock* mklabel Argdcl((long)); struct Listblock* mklist Argdcl((chainp)); void Un_link_all Argdcl((int)); void add_extern_to_list Argdcl((Addrp, chainp*)); int addressable Argdcl((tagptr)); tagptr addrof Argdcl((tagptr)); char* addunder Argdcl((char*)); void argkludge Argdcl((int*, char***)); Addrp autovar Argdcl((int, int, tagptr, char*)); void backup Argdcl((char*, char*)); void bad_atypes Argdcl((Argtypes*, char*, int, int, int, char*, char*)); int badchleng Argdcl((tagptr)); void badop Argdcl((char*, int)); void badstg Argdcl((char*, int)); void badtag Argdcl((char*, int)); void badthing Argdcl((char*, char*, int)); void badtype Argdcl((char*, int)); Addrp builtin Argdcl((int, char*, int)); char* c_name Argdcl((char*, int)); tagptr call0 Argdcl((int, char*)); tagptr call1 Argdcl((int, char*, tagptr)); tagptr call2 Argdcl((int, char*, tagptr, tagptr)); tagptr call3 Argdcl((int, char*, tagptr, tagptr, tagptr)); tagptr call4 Argdcl((int, char*, tagptr, tagptr, tagptr, tagptr)); tagptr callk Argdcl((int, char*, chainp)); void cast_args Argdcl((int, chainp)); char* cds Argdcl((char*, char*)); void changedtype Argdcl((Namep)); ptr ckalloc Argdcl((int)); int cktype Argdcl((int, int, int)); void clf Argdcl((FILEP*, char*, int)); int cmpstr Argdcl((char*, char*, long, long)); char* c_type_decl Argdcl((int, int)); Extsym* comblock Argdcl((char*)); char* comm_union_name Argdcl((int)); void consconv Argdcl((int, Constp, Constp)); void consnegop Argdcl((Constp)); int conssgn Argdcl((tagptr)); char* convic Argdcl((long)); void copy_data Argdcl((chainp)); char* copyn Argdcl((int, char*)); char* copys Argdcl((char*)); tagptr cpblock Argdcl((int, char*)); tagptr cpexpr Argdcl((tagptr)); void cpn Argdcl((int, char*, char*)); char* cpstring Argdcl((char*)); void dataline Argdcl((char*, long, int)); char* dataname Argdcl((int, long)); void dataval Argdcl((tagptr, tagptr)); void dclerr Argdcl((const char*, Namep)); void def_commons Argdcl((FILEP)); void def_start Argdcl((FILEP, char*, char*, char*)); void deregister Argdcl((Namep)); void do_uninit_equivs Argdcl((FILEP, ptr)); void doequiv(Void); int dofork Argdcl((char*)); void doinclude Argdcl((char*)); void doio Argdcl((chainp)); void done Argdcl((int)); void donmlist(Void); int dsort Argdcl((char*, char*)); char* dtos Argdcl((double)); void elif_out Argdcl((FILEP, tagptr)); void end_else_out Argdcl((FILEP)); void enddcl(Void); void enddo Argdcl((int)); void endio(Void); void endioctl(Void); void endproc(Void); void entrypt Argdcl((int, int, long, Extsym*, chainp)); int eqn Argdcl((int, char*, char*)); char* equiv_name Argdcl((int, char*)); void err Argdcl((char*)); void err66 Argdcl((char*)); void errext Argdcl((char*)); void erri Argdcl((char*, int)); void errl Argdcl((char*, long)); tagptr errnode(Void); void errstr Argdcl((const char*, const char*)); void exarif Argdcl((tagptr, struct Labelblock*, struct Labelblock*, struct Labelblock*)); void exasgoto Argdcl((Namep)); void exassign Argdcl((Namep, struct Labelblock*)); void excall Argdcl((Namep, struct Listblock*, int, struct Labelblock**)); void exdo Argdcl((int, Namep, chainp)); void execerr Argdcl((char*, char*)); void exelif Argdcl((tagptr)); void exelse(Void); void exenddo Argdcl((Namep)); void exendif(Void); void exequals Argdcl((struct Primblock*, tagptr)); void exgoto Argdcl((struct Labelblock*)); void exif Argdcl((tagptr)); void exreturn Argdcl((tagptr)); void exstop Argdcl((int, tagptr)); void extern_out Argdcl((FILEP, Extsym*)); void fatali Argdcl((char*, int)); void fatalstr Argdcl((char*, char*)); void ffilecopy Argdcl((FILEP, FILEP)); void fileinit(Void); int fixargs Argdcl((int, struct Listblock*)); tagptr fixexpr Argdcl((Exprp)); tagptr fixtype Argdcl((tagptr)); char* flconst Argdcl((char*, char*)); void flline(Void); void fmt_init(Void); void fmtname Argdcl((Namep, Addrp)); int fmtstmt Argdcl((struct Labelblock*)); tagptr fold Argdcl((tagptr)); void frchain Argdcl((chainp*)); void frdata Argdcl((chainp)); void freetemps(Void); void freqchain Argdcl((struct Equivblock*)); void frexchain Argdcl((chainp*)); void frexpr Argdcl((tagptr)); void frrpl(Void); void frtemp Argdcl((Addrp)); char* gmem Argdcl((int, int)); void hashclear(Void); chainp hookup Argdcl((chainp, chainp)); expptr imagpart Argdcl((Addrp)); void impldcl Argdcl((Namep)); int in_vector Argdcl((char*, char**, int)); void incomm Argdcl((Extsym*, Namep)); void inferdcl Argdcl((Namep, int)); int inilex Argdcl((char*)); void initkey(Void); int inregister Argdcl((Namep)); long int commlen Argdcl((chainp)); long int convci Argdcl((int, char*)); long int iarrlen Argdcl((Namep)); long int lencat Argdcl((expptr)); long int lmax Argdcl((long, long)); long int lmin Argdcl((long, long)); long int wr_char_len Argdcl((FILEP, struct Dimblock*, ftnint, int)); Addrp intraddr Argdcl((Namep)); tagptr intrcall Argdcl((Namep, struct Listblock*, int)); int intrfunct Argdcl((char*)); void ioclause Argdcl((int, expptr)); int iocname(Void); int is_negatable Argdcl((Constp)); int isaddr Argdcl((tagptr)); int isnegative_const Argdcl((Constp)); int isstatic Argdcl((tagptr)); chainp length_comp Argdcl((struct Entrypoint*, int)); int lengtype Argdcl((int, long)); char* lexline Argdcl((ptr)); void list_arg_types Argdcl((FILEP, struct Entrypoint*, chainp, int, char*)); void list_decls Argdcl((FILEP)); void list_init_data Argdcl((FILE **, char *, FILE *)); void listargs Argdcl((FILEP, struct Entrypoint*, int, chainp)); char* lit_name Argdcl((struct Literal*)); int log_2 Argdcl((long)); char* lower_string Argdcl((char*, char*)); int main Argdcl((int, char**)); expptr make_int_expr Argdcl((expptr)); void make_param Argdcl((struct Paramblock*, tagptr)); void many Argdcl((char*, char, int)); void margin_printf Argdcl((FILEP, const char*, ...)); int maxtype Argdcl((int, int)); char* mem Argdcl((int, int)); void mem_init(Void); char* memname Argdcl((int, long)); Addrp memversion Argdcl((Namep)); tagptr mkaddcon Argdcl((long)); Addrp mkaddr Argdcl((Namep)); Addrp mkarg Argdcl((int, int)); tagptr mkbitcon Argdcl((int, int, char*)); chainp mkchain Argdcl((char*, chainp)); Constp mkconst Argdcl((int)); tagptr mkconv Argdcl((int, tagptr)); tagptr mkcxcon Argdcl((tagptr, tagptr)); tagptr mkexpr Argdcl((int, tagptr, tagptr)); Extsym* mkext Argdcl((char*, char*)); Extsym* mkext1 Argdcl((char*, char*)); Addrp mkfield Argdcl((Addrp, char*, int)); tagptr mkfunct Argdcl((tagptr)); tagptr mkintcon Argdcl((long)); tagptr mkintqcon Argdcl((int, char*)); tagptr mklhs Argdcl((struct Primblock*, int)); tagptr mklogcon Argdcl((int)); Namep mkname Argdcl((char*)); Addrp mkplace Argdcl((Namep)); tagptr mkprim Argdcl((Namep, struct Listblock*, chainp)); tagptr mkrealcon Argdcl((int, char*)); Addrp mkscalar Argdcl((Namep)); void mkstfunct Argdcl((struct Primblock*, tagptr)); tagptr mkstrcon Argdcl((int, char*)); Addrp mktmp Argdcl((int, tagptr)); Addrp mktmp0 Argdcl((int, tagptr)); Addrp mktmpn Argdcl((int, int, tagptr)); void namelist Argdcl((Namep)); int ncat Argdcl((expptr)); void negate_const Argdcl((Constp)); void new_endif(Void); Extsym* newentry Argdcl((Namep, int)); long newlabel(Void); void newproc(Void); Addrp nextdata Argdcl((long*)); void nice_printf Argdcl((FILEP, const char*, ...)); void not_both Argdcl((char*)); void np_init(Void); int oneof_stg Argdcl((Namep, int, int)); int op_assign Argdcl((int)); tagptr opconv Argdcl((tagptr, int)); FILEP opf Argdcl((char*, char*)); void out_addr Argdcl((FILEP, Addrp)); void out_asgoto Argdcl((FILEP, tagptr)); void out_call Argdcl((FILEP, int, int, tagptr, tagptr, tagptr)); void out_const Argdcl((FILEP, Constp)); void out_else Argdcl((FILEP)); void out_for Argdcl((FILEP, tagptr, tagptr, tagptr)); void out_init(Void); void outbuf_adjust(Void); void p1_label Argdcl((long)); void paren_used Argdcl((struct Primblock*)); void prcona Argdcl((FILEP, long)); void prconi Argdcl((FILEP, long)); #ifndef NO_LONG_LONG void prconq Argdcl((FILEP, Llong)); #endif void prconr Argdcl((FILEP, Constp, int)); void procinit(Void); void procode Argdcl((FILEP)); void prolog Argdcl((FILEP, chainp)); void protowrite Argdcl((FILEP, int, char*, struct Entrypoint*, chainp)); expptr prune_left_conv Argdcl((expptr)); int put_one_arg Argdcl((int, char*, char**, char*, char*)); expptr putassign Argdcl((expptr, expptr)); Addrp putchop Argdcl((tagptr)); void putcmgo Argdcl((tagptr, int, struct Labelblock**)); Addrp putconst Argdcl((Constp)); tagptr putcxop Argdcl((tagptr)); void puteq Argdcl((expptr, expptr)); void putexpr Argdcl((expptr)); void puthead Argdcl((char*, int)); void putif Argdcl((tagptr, int)); void putout Argdcl((tagptr)); expptr putsteq Argdcl((Addrp, Addrp)); void putwhile Argdcl((tagptr)); tagptr putx Argdcl((tagptr)); void r8fix(Void); int rdlong Argdcl((FILEP, long*)); int rdname Argdcl((FILEP, ptr, char*)); void read_Pfiles Argdcl((char**)); Addrp realpart Argdcl((Addrp)); chainp revchain Argdcl((chainp)); int same_expr Argdcl((tagptr, tagptr)); int same_ident Argdcl((tagptr, tagptr)); void save_argtypes Argdcl((chainp, Argtypes**, Argtypes**, int, char*, int, int, int, int)); void saveargtypes Argdcl((Exprp)); void set_externs(Void); void set_tmp_names(Void); void setbound Argdcl((Namep, int, struct Dims*)); void setdata Argdcl((Addrp, Constp, long)); void setext Argdcl((Namep)); void setfmt Argdcl((struct Labelblock*)); void setimpl Argdcl((int, long, int, int)); void setintr Argdcl((Namep)); void settype Argdcl((Namep, int, long)); void sigcatch Argdcl((int)); void sserr Argdcl((Namep)); void start_formatting(Void); void startioctl(Void); void startproc Argdcl((Extsym*, int)); void startrw(Void); char* string_num Argdcl((char*, long)); int struct_eq Argdcl((chainp, chainp)); tagptr subcheck Argdcl((Namep, tagptr)); tagptr suboffset Argdcl((struct Primblock*)); int type_fixup Argdcl((Argtypes*, Atype*, int)); void unamstring Argdcl((Addrp, char*)); void unclassifiable(Void); void vardcl Argdcl((Namep)); void warn Argdcl((char*)); void warn1 Argdcl((const char*, const char*)); void warni Argdcl((char*, int)); void westart Argdcl((int)); void wr_abbrevs Argdcl((FILEP, int, chainp)); char* wr_ardecls Argdcl((FILE*, struct Dimblock*, long)); void wr_array_init Argdcl((FILEP, int, chainp)); void wr_common_decls Argdcl((FILEP)); void wr_equiv_init Argdcl((FILEP, int, chainp*, int)); void wr_globals Argdcl((FILEP)); void wr_nv_ident_help Argdcl((FILEP, Addrp)); void wr_struct Argdcl((FILEP, chainp)); void wronginf Argdcl((Namep)); void yyerror Argdcl((char*)); int yylex(Void); int yyparse(Void); #ifdef USE_DTOA #define atof(x) strtod(x,0) void g_fmt Argdcl((char*, double)); #endif f2c/src/equiv.c000066400000000000000000000221741171647030000136210ustar00rootroot00000000000000/**************************************************************** Copyright 1990, 1993-6, 2000 by AT&T, Lucent Technologies and Bellcore. Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the above copyright notice appear in all copies and that both that the copyright notice and this permission notice and warranty disclaimer appear in supporting documentation, and that the names of AT&T, Bell Laboratories, Lucent or Bellcore or any of their entities not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. AT&T, Lucent and Bellcore disclaim all warranties with regard to this software, including all implied warranties of merchantability and fitness. In no event shall AT&T, Lucent or Bellcore be liable for any special, indirect or consequential damages or any damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortious action, arising out of or in connection with the use or performance of this software. ****************************************************************/ #include "defs.h" static void eqvcommon Argdcl((struct Equivblock*, int, long int)); static void eqveqv Argdcl((int, int, long int)); static int nsubs Argdcl((struct Listblock*)); /* ROUTINES RELATED TO EQUIVALENCE CLASS PROCESSING */ /* called at end of declarations section to process chains created by EQUIVALENCE statements */ void doequiv(Void) { register int i; int inequiv; /* True if one namep occurs in several EQUIV declarations */ int comno; /* Index into Extsym table of the last COMMON block seen (implicitly assuming that only one will be given) */ int ovarno; ftnint comoffset; /* Index into the COMMON block */ ftnint offset; /* Offset from array base */ ftnint leng; register struct Equivblock *equivdecl; register struct Eqvchain *q; struct Primblock *primp; register Namep np; int k, k1, ns, pref, t; chainp cp; extern int type_pref[]; for(i = 0 ; i < nequiv ; ++i) { /* Handle each equivalence declaration */ equivdecl = &eqvclass[i]; equivdecl->eqvbottom = equivdecl->eqvtop = 0; comno = -1; for(q = equivdecl->equivs ; q ; q = q->eqvnextp) { offset = 0; if (!(primp = q->eqvitem.eqvlhs)) continue; vardcl(np = primp->namep); if(primp->argsp || primp->fcharp) { expptr offp; /* Pad ones onto the end of an array declaration when needed */ if(np->vdim!=NULL && np->vdim->ndim>1 && nsubs(primp->argsp)==1 ) { if(! ftn66flag) warni ("1-dim subscript in EQUIVALENCE, %d-dim declared", np -> vdim -> ndim); cp = NULL; ns = np->vdim->ndim; while(--ns > 0) cp = mkchain((char *)ICON(1), cp); primp->argsp->listp->nextp = cp; } offp = suboffset(primp); if(ISICON(offp)) offset = offp->constblock.Const.ci; else { dclerr ("nonconstant subscript in equivalence ", np); np = NULL; } frexpr(offp); } /* Free up the primblock, since we now have a hash table (Namep) entry */ frexpr((expptr)primp); if(np && (leng = iarrlen(np))<0) { dclerr("adjustable in equivalence", np); np = NULL; } if(np) switch(np->vstg) { case STGUNKNOWN: case STGBSS: case STGEQUIV: break; case STGCOMMON: /* The code assumes that all COMMON references in a given EQUIVALENCE will be to the same COMMON block, and will all be consistent */ comno = np->vardesc.varno; comoffset = np->voffset + offset; break; default: dclerr("bad storage class in equivalence", np); np = NULL; break; } if(np) { q->eqvoffset = offset; /* eqvbottom gets the largest difference between the array base address and the address specified in the EQUIV declaration */ equivdecl->eqvbottom = lmin(equivdecl->eqvbottom, -offset); /* eqvtop gets the largest difference between the end of the array and the address given in the EQUIVALENCE */ equivdecl->eqvtop = lmax(equivdecl->eqvtop, leng-offset); } q->eqvitem.eqvname = np; } /* Now all equivalenced variables are in the hash table with the proper offset, and eqvtop and eqvbottom are set. */ if(comno >= 0) /* Get rid of all STGEQUIVS, they will be mapped onto STGCOMMON variables */ eqvcommon(equivdecl, comno, comoffset); else for(q = equivdecl->equivs ; q ; q = q->eqvnextp) { if(np = q->eqvitem.eqvname) { inequiv = NO; if(np->vstg==STGEQUIV) if( (ovarno = np->vardesc.varno) == i) { /* Can't EQUIV different elements of the same array */ if(np->voffset + q->eqvoffset != 0) dclerr ("inconsistent equivalence", np); } else { offset = np->voffset; inequiv = YES; } np->vstg = STGEQUIV; np->vardesc.varno = i; np->voffset = - q->eqvoffset; if(inequiv) /* Combine 2 equivalence declarations */ eqveqv(i, ovarno, q->eqvoffset + offset); } } } /* Now each equivalence declaration is distinct (all connections have been merged in eqveqv()), and some may be empty. */ for(i = 0 ; i < nequiv ; ++i) { equivdecl = & eqvclass[i]; if(equivdecl->eqvbottom!=0 || equivdecl->eqvtop!=0) { /* a live chain */ k = TYCHAR; pref = 1; for(q = equivdecl->equivs ; q; q = q->eqvnextp) if ((np = q->eqvitem.eqvname) && !np->veqvadjust) { np->veqvadjust = 1; np->voffset -= equivdecl->eqvbottom; t = typealign[k1 = np->vtype]; if (pref < type_pref[k1]) { k = k1; pref = type_pref[k1]; } if(np->voffset % t != 0) { dclerr("bad alignment forced by equivalence", np); --nerr; /* don't give bad return code for this */ } } equivdecl->eqvtype = k; } freqchain(equivdecl); } } /* put equivalence chain p at common block comno + comoffset */ LOCAL void #ifdef KR_headers eqvcommon(p, comno, comoffset) struct Equivblock *p; int comno; ftnint comoffset; #else eqvcommon(struct Equivblock *p, int comno, ftnint comoffset) #endif { int ovarno; ftnint k, offq; register Namep np; register struct Eqvchain *q; if(comoffset + p->eqvbottom < 0) { errstr("attempt to extend common %s backward", extsymtab[comno].fextname); freqchain(p); return; } if( (k = comoffset + p->eqvtop) > extsymtab[comno].extleng) extsymtab[comno].extleng = k; for(q = p->equivs ; q ; q = q->eqvnextp) if(np = q->eqvitem.eqvname) { switch(np->vstg) { case STGUNKNOWN: case STGBSS: np->vstg = STGCOMMON; np->vcommequiv = 1; np->vardesc.varno = comno; /* np -> voffset will point to the base of the array */ np->voffset = comoffset - q->eqvoffset; break; case STGEQUIV: ovarno = np->vardesc.varno; /* offq will point to the current element, even if it's in an array */ offq = comoffset - q->eqvoffset - np->voffset; np->vstg = STGCOMMON; np->vcommequiv = 1; np->vardesc.varno = comno; /* np -> voffset will point to the base of the array */ np->voffset += offq; if(ovarno != (p - eqvclass)) eqvcommon(&eqvclass[ovarno], comno, offq); break; case STGCOMMON: if(comno != np->vardesc.varno || comoffset != np->voffset+q->eqvoffset) dclerr("inconsistent common usage", np); break; default: badstg("eqvcommon", np->vstg); } } freqchain(p); p->eqvbottom = p->eqvtop = 0; } /* Move all items on ovarno chain to the front of nvarno chain. * adjust offsets of ovarno elements and top and bottom of nvarno chain */ LOCAL void #ifdef KR_headers eqveqv(nvarno, ovarno, delta) int nvarno; int ovarno; ftnint delta; #else eqveqv(int nvarno, int ovarno, ftnint delta) #endif { register struct Equivblock *neweqv, *oldeqv; register Namep np; struct Eqvchain *q, *q1; neweqv = eqvclass + nvarno; oldeqv = eqvclass + ovarno; neweqv->eqvbottom = lmin(neweqv->eqvbottom, oldeqv->eqvbottom - delta); neweqv->eqvtop = lmax(neweqv->eqvtop, oldeqv->eqvtop - delta); oldeqv->eqvbottom = oldeqv->eqvtop = 0; for(q = oldeqv->equivs ; q ; q = q1) { q1 = q->eqvnextp; if( (np = q->eqvitem.eqvname) && np->vardesc.varno==ovarno) { q->eqvnextp = neweqv->equivs; neweqv->equivs = q; q->eqvoffset += delta; np->vardesc.varno = nvarno; np->voffset -= delta; } else free( (charptr) q); } oldeqv->equivs = NULL; } void #ifdef KR_headers freqchain(p) register struct Equivblock *p; #else freqchain(register struct Equivblock *p) #endif { register struct Eqvchain *q, *oq; for(q = p->equivs ; q ; q = oq) { oq = q->eqvnextp; free( (charptr) q); } p->equivs = NULL; } /* nsubs -- number of subscripts in this arglist (just the length of the list) */ LOCAL int #ifdef KR_headers nsubs(p) register struct Listblock *p; #else nsubs(register struct Listblock *p) #endif { register int n; register chainp q; n = 0; if(p) for(q = p->listp ; q ; q = q->nextp) ++n; return(n); } struct Primblock * #ifdef KR_headers primchk(e) expptr e; #else primchk(expptr e) #endif { if (e->headblock.tag != TPRIM) { err("Invalid name in EQUIVALENCE."); return 0; } return &e->primblock; } f2c/src/error.c000066400000000000000000000116271171647030000136220ustar00rootroot00000000000000/**************************************************************** Copyright 1990, 1993, 1994, 2000 by AT&T, Lucent Technologies and Bellcore. Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the above copyright notice appear in all copies and that both that the copyright notice and this permission notice and warranty disclaimer appear in supporting documentation, and that the names of AT&T, Bell Laboratories, Lucent or Bellcore or any of their entities not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. AT&T, Lucent and Bellcore disclaim all warranties with regard to this software, including all implied warranties of merchantability and fitness. In no event shall AT&T, Lucent or Bellcore be liable for any special, indirect or consequential damages or any damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortious action, arising out of or in connection with the use or performance of this software. ****************************************************************/ #include "defs.h" void #ifdef KR_headers warni(s, t) char *s; int t; #else warni(char *s, int t) #endif { char buf[100]; sprintf(buf,s,t); warn(buf); } void #ifdef KR_headers warn1(s, t) char *s; char *t; #else warn1(const char *s, const char *t) #endif { char buff[100]; sprintf(buff, s, t); warn(buff); } void #ifdef KR_headers warn(s) char *s; #else warn(char *s) #endif { if(nowarnflag) return; if (infname && *infname) fprintf(diagfile, "Warning on line %ld of %s: %s\n", lineno, infname, s); else fprintf(diagfile, "Warning on line %ld: %s\n", lineno, s); fflush(diagfile); ++nwarn; } void #ifdef KR_headers errstr(s, t) char *s; char *t; #else errstr(const char *s, const char *t) #endif { char buff[100]; sprintf(buff, s, t); err(buff); } void #ifdef KR_headers erri(s, t) char *s; int t; #else erri(char *s, int t) #endif { char buff[100]; sprintf(buff, s, t); err(buff); } void #ifdef KR_headers errl(s, t) char *s; long t; #else errl(char *s, long t) #endif { char buff[100]; sprintf(buff, s, t); err(buff); } char *err_proc = 0; void #ifdef KR_headers err(s) char *s; #else err(char *s) #endif { if (err_proc) fprintf(diagfile, "Error processing %s before line %ld", err_proc, lineno); else fprintf(diagfile, "Error on line %ld", lineno); if (infname && *infname) fprintf(diagfile, " of %s", infname); fprintf(diagfile, ": %s\n", s); fflush(diagfile); ++nerr; } void #ifdef KR_headers yyerror(s) char *s; #else yyerror(char *s) #endif { err(s); } void #ifdef KR_headers dclerr(s, v) char *s; Namep v; #else dclerr(const char *s, Namep v) #endif { char buff[100]; if(v) { sprintf(buff, "Declaration error for %s: %s", v->fvarname, s); err(buff); } else errstr("Declaration error %s", s); } void #ifdef KR_headers execerr(s, n) char *s; char *n; #else execerr(char *s, char *n) #endif { char buf1[100], buf2[100]; sprintf(buf1, "Execution error %s", s); sprintf(buf2, buf1, n); err(buf2); } void #ifdef KR_headers Fatal(t) char *t; #else Fatal(char *t) #endif { fprintf(diagfile, "Compiler error line %ld", lineno); if (infname) fprintf(diagfile, " of %s", infname); fprintf(diagfile, ": %s\n", t); done(3); } void #ifdef KR_headers fatalstr(t, s) char *t; char *s; #else fatalstr(char *t, char *s) #endif { char buff[100]; sprintf(buff, t, s); Fatal(buff); } void #ifdef KR_headers fatali(t, d) char *t; int d; #else fatali(char *t, int d) #endif { char buff[100]; sprintf(buff, t, d); Fatal(buff); } void #ifdef KR_headers badthing(thing, r, t) char *thing; char *r; int t; #else badthing(char *thing, char *r, int t) #endif { char buff[50]; sprintf(buff, "Impossible %s %d in routine %s", thing, t, r); Fatal(buff); } void #ifdef KR_headers badop(r, t) char *r; int t; #else badop(char *r, int t) #endif { badthing("opcode", r, t); } void #ifdef KR_headers badtag(r, t) char *r; int t; #else badtag(char *r, int t) #endif { badthing("tag", r, t); } void #ifdef KR_headers badstg(r, t) char *r; int t; #else badstg(char *r, int t) #endif { badthing("storage class", r, t); } void #ifdef KR_headers badtype(r, t) char *r; int t; #else badtype(char *r, int t) #endif { badthing("type", r, t); } void #ifdef KR_headers many(s, c, n) char *s; char c; int n; #else many(char *s, char c, int n) #endif { char buff[250]; sprintf(buff, "Too many %s.\nTable limit now %d.\nTry rerunning with the -N%c%d option.\n", s, n, c, 2*n); Fatal(buff); } void #ifdef KR_headers err66(s) char *s; #else err66(char *s) #endif { errstr("Fortran 77 feature used: %s", s); --nerr; } void #ifdef KR_headers errext(s) char *s; #else errext(char *s) #endif { errstr("f2c extension used: %s", s); --nerr; } f2c/src/exec.c000066400000000000000000000513071171647030000134140ustar00rootroot00000000000000/**************************************************************** Copyright 1990, 1993 - 1996, 2000 by AT&T, Lucent Technologies and Bellcore. Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the above copyright notice appear in all copies and that both that the copyright notice and this permission notice and warranty disclaimer appear in supporting documentation, and that the names of AT&T, Bell Laboratories, Lucent or Bellcore or any of their entities not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. AT&T, Lucent and Bellcore disclaim all warranties with regard to this software, including all implied warranties of merchantability and fitness. In no event shall AT&T, Lucent or Bellcore be liable for any special, indirect or consequential damages or any damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortious action, arising out of or in connection with the use or performance of this software. ****************************************************************/ #include "defs.h" #include "p1defs.h" #include "names.h" static void exar2 Argdcl((int, tagptr, struct Labelblock*, struct Labelblock*)); static void popctl Argdcl((void)); static void pushctl Argdcl((int)); /* Logical IF codes */ void #ifdef KR_headers exif(p) expptr p; #else exif(expptr p) #endif { pushctl(CTLIF); putif(p, 0); /* 0 => if, not elseif */ } void #ifdef KR_headers exelif(p) expptr p; #else exelif(expptr p) #endif { if (ctlstack->ctltype == CTLIF || ctlstack->ctltype == CTLIFX) putif(p, 1); /* 1 ==> elseif */ else execerr("elseif out of place", CNULL); } void exelse(Void) { register struct Ctlframe *c; for(c = ctlstack; c->ctltype == CTLIFX; --c); if(c->ctltype == CTLIF) { p1_else (); c->ctltype = CTLELSE; } else execerr("else out of place", CNULL); } void #ifdef KR_headers exendif() #else exendif() #endif { while(ctlstack->ctltype == CTLIFX) { popctl(); p1else_end(); } if(ctlstack->ctltype == CTLIF) { popctl(); p1_endif (); } else if(ctlstack->ctltype == CTLELSE) { popctl(); p1else_end (); } else execerr("endif out of place", CNULL); } void #ifdef KR_headers new_endif() #else new_endif() #endif { if (ctlstack->ctltype == CTLIF || ctlstack->ctltype == CTLIFX) pushctl(CTLIFX); else err("new_endif bug"); } /* pushctl -- Start a new control construct, initialize the labels (to zero) */ LOCAL void #ifdef KR_headers pushctl(code) int code; #else pushctl(int code) #endif { register int i; if(++ctlstack >= lastctl) many("loops or if-then-elses", 'c', maxctl); ctlstack->ctltype = code; for(i = 0 ; i < 4 ; ++i) ctlstack->ctlabels[i] = 0; ctlstack->dowhile = 0; ctlstack->domax = ctlstack->dostep = 0; /* in case of errors */ ++blklevel; } LOCAL void popctl(Void) { if( ctlstack-- < ctls ) Fatal("control stack empty"); --blklevel; } /* poplab -- update the flags in labeltab */ LOCAL void poplab(Void) { register struct Labelblock *lp; for(lp = labeltab ; lp < highlabtab ; ++lp) if(lp->labdefined) { /* mark all labels in inner blocks unreachable */ if(lp->blklevel > blklevel) lp->labinacc = YES; } else if(lp->blklevel > blklevel) { /* move all labels referred to in inner blocks out a level */ lp->blklevel = blklevel; } } /* BRANCHING CODE */ void #ifdef KR_headers exgoto(lab) struct Labelblock *lab; #else exgoto(struct Labelblock *lab) #endif { lab->labused = 1; p1_goto (lab -> stateno); } static expptr #ifdef KR_headers cktype1(p) expptr p; #else cktype1(expptr p) #endif { /* Do things omitted because we might have been parsing a */ /* statement function... Check types and fold constants. */ chainp c; tagptr t; if(p == 0) return(0); switch(p->tag) { case TCONST: case TADDR: case TERROR: break; /* This case means that fixexpr can't call fixtype with any expr, only a subexpr of its parameter. */ case TEXPR: t = mkexpr(p->exprblock.opcode, cktype1(p->exprblock.leftp), cktype1(p->exprblock.rightp)); free((charptr)p); p = (expptr) t; break; case TLIST: for(c = p->listblock.listp; c; c = c->nextp) c->datap = (char*)cktype1((expptr)c->datap); break; case TPRIM: p->primblock.argsp = (struct Listblock*) cktype1((expptr)p->primblock.argsp); p->primblock.fcharp = cktype1(p->primblock.fcharp); p->primblock.lcharp = cktype1(p->primblock.lcharp); break; default: badtag("cktype1", p->tag); } return p; } void #ifdef KR_headers exequals(lp, rp) register struct Primblock *lp; register expptr rp; #else exequals(register struct Primblock *lp, register expptr rp) #endif { if(lp->tag != TPRIM) { err("assignment to a non-variable"); frexpr((expptr)lp); frexpr(rp); } else if(lp->namep->vclass!=CLVAR && lp->argsp) { if(parstate >= INEXEC) errstr("statement function %.62s amid executables.", lp->namep->fvarname); mkstfunct(lp, rp); } else if (lp->vtype == TYSUBR) err("illegal use of subroutine name"); else { expptr new_lp, new_rp; if(parstate < INDATA) { enddcl(); lp = (struct Primblock *)cktype1((expptr)lp); rp = cktype1(rp); } new_lp = mklhs (lp, keepsubs); new_rp = fixtype (rp); puteq(new_lp, new_rp); } } /* Make Statement Function */ long laststfcn = -1, thisstno; int doing_stmtfcn; void #ifdef KR_headers mkstfunct(lp, rp) struct Primblock *lp; expptr rp; #else mkstfunct(struct Primblock *lp, expptr rp) #endif { register struct Primblock *p; register Namep np; chainp args; laststfcn = thisstno; np = lp->namep; if(np->vclass == CLUNKNOWN) np->vclass = CLPROC; else { dclerr("redeclaration of statement function", np); return; } np->vprocclass = PSTFUNCT; np->vstg = STGSTFUNCT; /* Set the type of the function */ impldcl(np); if (np->vtype == TYCHAR && !np->vleng) err("character statement function with length (*)"); args = (lp->argsp ? lp->argsp->listp : CHNULL); np->varxptr.vstfdesc = mkchain((char *)args, (chainp)rp); for(doing_stmtfcn = 1 ; args ; args = args->nextp) /* It is an error for the formal parameters to have arguments or subscripts */ if( ((tagptr)(args->datap))->tag!=TPRIM || (p = (struct Primblock *)(args->datap) )->argsp || p->fcharp || p->lcharp ) { err("non-variable argument in statement function definition"); args->datap = 0; } else { /* Replace the name on the left-hand side */ args->datap = (char *)p->namep; vardcl(p -> namep); free((char *)p); } doing_stmtfcn = 0; } static void #ifdef KR_headers mixed_type(np) Namep np; #else mixed_type(Namep np) #endif { char buf[128]; sprintf(buf, "%s function %.90s invoked as subroutine", ftn_types[np->vtype], np->fvarname); warn(buf); } void #ifdef KR_headers excall(name, args, nstars, labels) Namep name; struct Listblock *args; int nstars; struct Labelblock **labels; #else excall(Namep name, struct Listblock *args, int nstars, struct Labelblock **labels) #endif { register expptr p; if (name->vtype != TYSUBR) { if (name->vinfproc && !name->vcalled) { name->vtype = TYSUBR; frexpr(name->vleng); name->vleng = 0; } else if (!name->vimpltype && name->vtype != TYUNKNOWN) mixed_type(name); else settype(name, TYSUBR, (ftnint)0); } p = mkfunct( mkprim(name, args, CHNULL) ); if (p->tag == TERROR) return; /* Subroutines and their identifiers acquire the type INT */ p->exprblock.vtype = p->exprblock.leftp->headblock.vtype = TYINT; /* Handle the alternate return mechanism */ if(nstars > 0) putcmgo(putx(fixtype(p)), nstars, labels); else putexpr(p); } void #ifdef KR_headers exstop(stop, p) int stop; register expptr p; #else exstop(int stop, register expptr p) #endif { char *str; int n; if(p) { if( ! ISCONST(p) ) { execerr("pause/stop argument must be constant", CNULL); frexpr(p); p = mkstrcon(0, CNULL); } else if( ISINT(p->constblock.vtype) ) { str = convic(p->constblock.Const.ci); n = strlen(str); if(n > 0) { p->constblock.Const.ccp = copyn(n, str); p->constblock.Const.ccp1.blanks = 0; p->constblock.vtype = TYCHAR; p->constblock.vleng = (expptr) ICON(n); } else p = (expptr) mkstrcon(0, CNULL); } else if(p->constblock.vtype != TYCHAR) { execerr("pause/stop argument must be integer or string", CNULL); p = (expptr) mkstrcon(0, CNULL); } } else p = (expptr) mkstrcon(0, CNULL); { expptr subr_call; subr_call = call1(TYSUBR, (char*)(stop ? "s_stop" : "s_paus"), p); putexpr( subr_call ); } } /* DO LOOP CODE */ #define DOINIT par[0] #define DOLIMIT par[1] #define DOINCR par[2] /* Macros for ctlstack -> dostepsign */ #define VARSTEP 0 #define POSSTEP 1 #define NEGSTEP 2 /* exdo -- generate DO loop code. In the case of a variable increment, positive increment tests are placed above the body, negative increment tests are placed below (see enddo() ) */ void #ifdef KR_headers exdo(range, loopname, spec) int range; Namep loopname; chainp spec; #else exdo(int range, Namep loopname, chainp spec) #endif /* range = end label */ /* input spec must have at least 2 exprs */ { register expptr p; register Namep np; chainp cp; /* loops over the fields in spec */ register int i; int dotype; /* type of the index variable */ int incsign; /* sign of the increment, if it's constant */ Addrp dovarp; /* loop index variable */ expptr doinit; /* constant or register for init param */ expptr par[3]; /* local specification parameters */ expptr init, test, inc; /* Expressions in the resulting FOR loop */ test = ENULL; pushctl(CTLDO); dorange = ctlstack->dolabel = range; ctlstack->loopname = loopname; /* Declare the loop index */ np = (Namep)spec->datap; ctlstack->donamep = NULL; if (!np) { /* do while */ ctlstack->dowhile = 1; #if 0 if (loopname) { if (loopname->vtype == TYUNKNOWN) { loopname->vdcldone = 1; loopname->vclass = CLLABEL; loopname->vprocclass = PLABEL; loopname->vtype = TYLABEL; } if (loopname->vtype == TYLABEL) if (loopname->vdovar) dclerr("already in use as a loop name", loopname); else loopname->vdovar = 1; else dclerr("already declared; cannot be a loop name", loopname); } #endif putwhile((expptr)spec->nextp); NOEXT("do while"); spec->nextp = 0; frchain(&spec); return; } if(np->vdovar) { errstr("nested loops with variable %s", np->fvarname); ctlstack->donamep = NULL; return; } /* Create a memory-resident version of the index variable */ dovarp = mkplace(np); if( ! ONEOF(dovarp->vtype, MSKINT|MSKREAL) ) { err("bad type on do variable"); return; } ctlstack->donamep = np; np->vdovar = YES; /* Now dovarp points to the index to be used within the loop, dostgp points to the one which may need to be stored */ dotype = dovarp->vtype; /* Count the input specifications and type-check each one independently; this just eliminates non-numeric values from the specification */ for(i=0 , cp = spec->nextp ; cp!=NULL && i<3 ; cp = cp->nextp) { p = par[i++] = fixtype((tagptr)cp->datap); if( ! ONEOF(p->headblock.vtype, MSKINT|MSKREAL) ) { err("bad type on DO parameter"); return; } } frchain(&spec); switch(i) { case 0: case 1: err("too few DO parameters"); return; default: err("too many DO parameters"); return; case 2: DOINCR = (expptr) ICON(1); case 3: break; } /* Now all of the local specification fields are set, but their types are not yet consistent */ /* Declare the loop initialization value, casting it properly and declaring a register if need be */ ctlstack->doinit = 0; if (ISCONST (DOINIT) || !onetripflag) /* putx added 6-29-89 (mwm), not sure if fixtype is required, but I doubt it since mkconv is called just before */ doinit = putx (mkconv (dotype, DOINIT)); else { if (onetripflag) ctlstack->doinit = doinit = (expptr) mktmp0(dotype, ENULL); else doinit = (expptr) mktmp(dotype, ENULL); puteq (cpexpr (doinit), DOINIT); } /* else */ /* Declare the loop ending value, casting it to the type of the index variable */ if( ISCONST(DOLIMIT) ) ctlstack->domax = mkconv(dotype, DOLIMIT); else { ctlstack->domax = (expptr) mktmp0(dotype, ENULL); puteq (cpexpr (ctlstack -> domax), DOLIMIT); } /* else */ /* Declare the loop increment value, casting it to the type of the index variable */ if( ISCONST(DOINCR) ) { ctlstack->dostep = mkconv(dotype, DOINCR); if( (incsign = conssgn(ctlstack->dostep)) == 0) err("zero DO increment"); ctlstack->dostepsign = (incsign > 0 ? POSSTEP : NEGSTEP); } else { ctlstack->dostep = (expptr) mktmp0(dotype, ENULL); ctlstack->dostepsign = VARSTEP; puteq (cpexpr (ctlstack -> dostep), DOINCR); } /* All data is now properly typed and in the ctlstack, except for the initial value. Assignments of temps have been generated already */ switch (ctlstack -> dostepsign) { case VARSTEP: test = mkexpr (OPQUEST, mkexpr (OPLT, cpexpr (ctlstack -> dostep), ICON(0)), mkexpr (OPCOLON, mkexpr (OPGE, cpexpr((expptr)dovarp), cpexpr (ctlstack -> domax)), mkexpr (OPLE, cpexpr((expptr)dovarp), cpexpr (ctlstack -> domax)))); break; case POSSTEP: test = mkexpr (OPLE, cpexpr((expptr)dovarp), cpexpr (ctlstack -> domax)); break; case NEGSTEP: test = mkexpr (OPGE, cpexpr((expptr)dovarp), cpexpr (ctlstack -> domax)); break; default: erri ("exdo: bad dostepsign '%d'", ctlstack -> dostepsign); break; } /* switch (ctlstack -> dostepsign) */ if (onetripflag) test = mkexpr (OPOR, test, mkexpr (OPEQ, cpexpr((expptr)dovarp), cpexpr (doinit))); init = mkexpr (OPASSIGN, cpexpr((expptr)dovarp), ctlstack->doinit ? cpexpr(doinit) : doinit); inc = mkexpr (OPPLUSEQ, (expptr)dovarp, cpexpr (ctlstack -> dostep)); if (!onetripflag && ISCONST (ctlstack -> domax) && ISCONST (doinit) && ctlstack -> dostepsign != VARSTEP) { expptr tester; tester = mkexpr (OPMINUS, cpexpr (doinit), cpexpr (ctlstack -> domax)); if (incsign == conssgn (tester)) warn ("DO range never executed"); frexpr (tester); } /* if !onetripflag && */ p1_for (init, test, inc); } void #ifdef KR_headers exenddo(np) Namep np; #else exenddo(Namep np) #endif { Namep np1; int here; struct Ctlframe *cf; if( ctlstack < ctls ) goto misplaced; here = ctlstack->dolabel; if (ctlstack->ctltype != CTLDO || here >= 0 && (!thislabel || thislabel->labelno != here)) { misplaced: err("misplaced ENDDO"); return; } if (np != ctlstack->loopname) { if (np1 = ctlstack->loopname) errstr("expected \"enddo %s\"", np1->fvarname); else err("expected unnamed ENDDO"); for(cf = ctls; cf < ctlstack; cf++) if (cf->ctltype == CTLDO && cf->loopname == np) { here = cf->dolabel; break; } } enddo(here); } void #ifdef KR_headers enddo(here) int here; #else enddo(int here) #endif { register struct Ctlframe *q; Namep np; /* name of the current DO index */ Addrp ap; register int i; register expptr e; /* Many DO's can end at the same statement, so keep looping over all nested indicies */ while(here == dorange) { if(np = ctlstack->donamep) { p1for_end (); /* Now we're done with all of the tests, and the loop has terminated. Store the index value back in long-term memory */ if(ap = memversion(np)) puteq((expptr)ap, (expptr)mkplace(np)); for(i = 0 ; i < 4 ; ++i) ctlstack->ctlabels[i] = 0; deregister(ctlstack->donamep); ctlstack->donamep->vdovar = NO; /* ctlstack->dostep and ctlstack->domax can be zero */ /* with sufficiently bizarre (erroneous) syntax */ if (e = ctlstack->dostep) if (e->tag == TADDR && e->addrblock.istemp) frtemp((Addrp)e); else frexpr(e); if (e = ctlstack->domax) if (e->tag == TADDR && e->addrblock.istemp) frtemp((Addrp)e); else frexpr(e); if (e = ctlstack->doinit) frtemp((Addrp)e); } else if (ctlstack->dowhile) p1for_end (); /* Set dorange to the closing label of the next most enclosing DO loop */ popctl(); poplab(); dorange = 0; for(q = ctlstack ; q>=ctls ; --q) if(q->ctltype == CTLDO) { dorange = q->dolabel; break; } } } void #ifdef KR_headers exassign(vname, labelval) register Namep vname; struct Labelblock *labelval; #else exassign(register Namep vname, struct Labelblock *labelval) #endif { Addrp p; register Addrp q; char *fs; register chainp cp, cpprev; register ftnint k, stno; p = mkplace(vname); if( ! ONEOF(p->vtype, MSKINT|MSKADDR) ) { err("noninteger assign variable"); return; } /* If the label hasn't been defined, then we do things twice: * once for an executable stmt label, once for a format */ /* code for executable label... */ /* Now store the assigned value in a list associated with this variable. This will be used later to generate a switch() statement in the C output */ fs = labelval->fmtstring; if (!labelval->labdefined || !fs) { if (vname -> vis_assigned == 0) { vname -> varxptr.assigned_values = CHNULL; vname -> vis_assigned = 1; } /* don't duplicate labels... */ stno = labelval->stateno; cpprev = 0; for(k = 0, cp = vname->varxptr.assigned_values; cp; cpprev = cp, cp = cp->nextp, k++) if ((ftnint)cp->datap == stno) break; if (!cp) { cp = mkchain((char *)stno, CHNULL); if (cpprev) cpprev->nextp = cp; else vname->varxptr.assigned_values = cp; labelval->labused = 1; } putout(mkexpr(OPASSIGN, (expptr)p, mkintcon(k))); } /* Code for FORMAT label... */ if (!labelval->labdefined || fs) { labelval->fmtlabused = 1; p = ALLOC(Addrblock); p->tag = TADDR; p->vtype = TYCHAR; p->vstg = STGAUTO; p->memoffset = ICON(0); fmtname(vname, p); q = ALLOC(Addrblock); q->tag = TADDR; q->vtype = TYCHAR; q->vstg = STGAUTO; q->ntempelt = 1; q->memoffset = ICON(0); q->uname_tag = UNAM_IDENT; sprintf(q->user.ident, "fmt_%ld", labelval->stateno); putout(mkexpr(OPASSIGN, (expptr)p, (expptr)q)); } } /* exassign */ void #ifdef KR_headers exarif(expr, neglab, zerlab, poslab) expptr expr; struct Labelblock *neglab; struct Labelblock *zerlab; struct Labelblock *poslab; #else exarif(expptr expr, struct Labelblock *neglab, struct Labelblock *zerlab, struct Labelblock *poslab) #endif { ftnint lm, lz, lp; lm = neglab->stateno; lz = zerlab->stateno; lp = poslab->stateno; expr = fixtype(expr); if( ! ONEOF(expr->headblock.vtype, MSKINT|MSKREAL) ) { err("invalid type of arithmetic if expression"); frexpr(expr); } else { if (lm == lz && lz == lp) exgoto (neglab); else if(lm == lz) exar2(OPLE, expr, neglab, poslab); else if(lm == lp) exar2(OPNE, expr, neglab, zerlab); else if(lz == lp) exar2(OPGE, expr, zerlab, neglab); else { expptr t; if (!addressable (expr)) { t = (expptr) mktmp(expr -> headblock.vtype, ENULL); expr = mkexpr (OPASSIGN, cpexpr (t), expr); } else t = (expptr) cpexpr (expr); p1_if(putx(fixtype(mkexpr (OPLT, expr, ICON (0))))); exgoto(neglab); p1_elif (mkexpr (OPEQ, t, ICON (0))); exgoto(zerlab); p1_else (); exgoto(poslab); p1else_end (); } /* else */ } } /* exar2 -- Do arithmetic IF for only 2 distinct labels; if !(e.op.0) goto l2 else goto l1. If this seems backwards, that's because it is, in order to make the 1 pass algorithm work. */ LOCAL void #ifdef KR_headers exar2(op, e, l1, l2) int op; expptr e; struct Labelblock *l1; struct Labelblock *l2; #else exar2(int op, expptr e, struct Labelblock *l1, struct Labelblock *l2) #endif { expptr comp; comp = mkexpr (op, e, ICON (0)); p1_if(putx(fixtype(comp))); exgoto(l1); p1_else (); exgoto(l2); p1else_end (); } /* exreturn -- return the value in p from a SUBROUTINE call -- used to implement the alternate return mechanism */ void #ifdef KR_headers exreturn(p) register expptr p; #else exreturn(register expptr p) #endif { if(procclass != CLPROC) warn("RETURN statement in main or block data"); if(p && (proctype!=TYSUBR || procclass!=CLPROC) ) { err("alternate return in nonsubroutine"); p = 0; } if (p || proctype == TYSUBR) { if (p == ENULL) p = ICON (0); p = mkconv (TYLONG, fixtype (p)); p1_subr_ret (p); } /* if p || proctype == TYSUBR */ else p1_subr_ret((expptr)retslot); } void #ifdef KR_headers exasgoto(labvar) Namep labvar; #else exasgoto(Namep labvar) #endif { register Addrp p; p = mkplace(labvar); if( ! ISINT(p->vtype) ) err("assigned goto variable must be integer"); else { p1_asgoto (p); } /* else */ } f2c/src/expr.c000066400000000000000000002151241171647030000134450ustar00rootroot00000000000000/**************************************************************** Copyright 1990 - 1996, 2000-2001 by AT&T, Lucent Technologies and Bellcore. Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the above copyright notice appear in all copies and that both that the copyright notice and this permission notice and warranty disclaimer appear in supporting documentation, and that the names of AT&T, Bell Laboratories, Lucent or Bellcore or any of their entities not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. AT&T, Lucent and Bellcore disclaim all warranties with regard to this software, including all implied warranties of merchantability and fitness. In no event shall AT&T, Lucent or Bellcore be liable for any special, indirect or consequential damages or any damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortious action, arising out of or in connection with the use or performance of this software. ****************************************************************/ #include "defs.h" #include "output.h" #include "names.h" typedef struct { double dreal, dimag; } dcomplex; static void consbinop Argdcl((int, int, Constp, Constp, Constp)); static void conspower Argdcl((Constp, Constp, long int)); static void zdiv Argdcl((dcomplex*, dcomplex*, dcomplex*)); static tagptr mkpower Argdcl((tagptr)); static tagptr stfcall Argdcl((Namep, struct Listblock*)); extern char dflttype[26]; extern int htype; /* little routines to create constant blocks */ Constp #ifdef KR_headers mkconst(t) int t; #else mkconst(int t) #endif { Constp p; p = ALLOC(Constblock); p->tag = TCONST; p->vtype = t; return(p); } /* mklogcon -- Make Logical Constant */ expptr #ifdef KR_headers mklogcon(l) int l; #else mklogcon(int l) #endif { Constp p; p = mkconst(tylog); p->Const.ci = l; return( (expptr) p ); } /* mkintcon -- Make Integer Constant */ expptr #ifdef KR_headers mkintcon(l) ftnint l; #else mkintcon(ftnint l) #endif { Constp p; p = mkconst(tyint); p->Const.ci = l; return( (expptr) p ); } /* mkaddcon -- Make Address Constant, given integer value */ expptr #ifdef KR_headers mkaddcon(l) long l; #else mkaddcon(long l) #endif { Constp p; p = mkconst(TYADDR); p->Const.ci = l; return( (expptr) p ); } /* mkrealcon -- Make Real Constant. The type t is assumed to be TYREAL or TYDREAL */ expptr #ifdef KR_headers mkrealcon(t, d) int t; char *d; #else mkrealcon(int t, char *d) #endif { Constp p; p = mkconst(t); p->Const.cds[0] = cds(d,CNULL); p->vstg = 1; return( (expptr) p ); } /* mkbitcon -- Make bit constant. Reads the input string, which is assumed to correctly specify a number in base 2^shift (where shift is the input parameter). shift may not exceed 4, i.e. only binary, quad, octal and hex bases may be input. */ expptr #ifdef KR_headers mkbitcon(shift, leng, s) int shift; int leng; char *s; #else mkbitcon(int shift, int leng, char *s) #endif { Constp p; unsigned long m, ovfl, x, y, z; int L32, len; char buff[100], *s0 = s; #ifndef NO_LONG_LONG ULlong u; #endif static char *kind[3] = { "Binary", "Hex", "Octal" }; p = mkconst(TYLONG); /* Song and dance to convert to TYQUAD only if ftnint is too small. */ m = x = y = ovfl = 0; /* Older C compilers may not know about */ /* UL suffixes on hex constants... */ while(--leng >= 0) if(*s != ' ') { if (!m) { z = x; x = ((x << shift) | hextoi(*s++)) & ff; if (!((x >> shift) - z)) continue; m = (ff << (L32 = 32 - shift)) & ff; --s; x = z; } ovfl |= y & m; y = y << shift | (x >> L32); x = ((x << shift) | hextoi(*s++)) & ff; } /* Don't change the type to short for short constants, as * that is dangerous -- there is no syntax for long constants * with small values. */ p->Const.ci = (ftnint)x; #ifndef NO_LONG_LONG if (m) { if (allow_i8c) { u = y; p->Const.ucq = (u << 32) | x; p->vtype = TYQUAD; } else ovfl = 1; } #else ovfl |= m; #endif if (ovfl) { if (--shift == 3) shift = 1; if ((len = (int)leng) > 60) sprintf(buff, "%s constant '%.60s' truncated.", kind[shift], s0); else sprintf(buff, "%s constant '%.*s' truncated.", kind[shift], len, s0); err(buff); } return( (expptr) p ); } /* mkstrcon -- Make string constant. Allocates storage and initializes the memory for a copy of the input Fortran-string. */ expptr #ifdef KR_headers mkstrcon(l, v) int l; char *v; #else mkstrcon(int l, char *v) #endif { Constp p; char *s; p = mkconst(TYCHAR); p->vleng = ICON(l); p->Const.ccp = s = (char *) ckalloc(l+1); p->Const.ccp1.blanks = 0; while(--l >= 0) *s++ = *v++; *s = '\0'; return( (expptr) p ); } /* mkcxcon -- Make complex contsant. A complex number is a pair of values, each of which may be integer, real or double. */ expptr #ifdef KR_headers mkcxcon(realp, imagp) expptr realp; expptr imagp; #else mkcxcon(expptr realp, expptr imagp) #endif { int rtype, itype; Constp p; rtype = realp->headblock.vtype; itype = imagp->headblock.vtype; if( ISCONST(realp) && ISNUMERIC(rtype) && ISCONST(imagp) && ISNUMERIC(itype) ) { p = mkconst( (rtype==TYDREAL||itype==TYDREAL) ? TYDCOMPLEX : tycomplex); if (realp->constblock.vstg || imagp->constblock.vstg) { p->vstg = 1; p->Const.cds[0] = ISINT(rtype) ? string_num("", realp->constblock.Const.ci) : realp->constblock.vstg ? realp->constblock.Const.cds[0] : dtos(realp->constblock.Const.cd[0]); p->Const.cds[1] = ISINT(itype) ? string_num("", imagp->constblock.Const.ci) : imagp->constblock.vstg ? imagp->constblock.Const.cds[0] : dtos(imagp->constblock.Const.cd[0]); } else { p->Const.cd[0] = ISINT(rtype) ? realp->constblock.Const.ci : realp->constblock.Const.cd[0]; p->Const.cd[1] = ISINT(itype) ? imagp->constblock.Const.ci : imagp->constblock.Const.cd[0]; } } else { err("invalid complex constant"); p = (Constp)errnode(); } frexpr(realp); frexpr(imagp); return( (expptr) p ); } /* errnode -- Allocate a new error block */ expptr errnode(Void) { struct Errorblock *p; p = ALLOC(Errorblock); p->tag = TERROR; p->vtype = TYERROR; return( (expptr) p ); } /* mkconv -- Make type conversion. Cast expression p into type t. Note that casting to a character copies only the first sizeof(char) bytes. */ expptr #ifdef KR_headers mkconv(t, p) int t; expptr p; #else mkconv(int t, expptr p) #endif { expptr q; int pt, charwarn = 1; if (t >= 100) { t -= 100; charwarn = 0; } if(t==TYUNKNOWN || t==TYERROR) badtype("mkconv", t); pt = p->headblock.vtype; /* Casting to the same type is a no-op */ if(t == pt) return(p); /* If we're casting a constant which is not in the literal table ... */ else if( ISCONST(p) && pt!=TYADDR && pt != TYCHAR || p->tag == TADDR && p->addrblock.uname_tag == UNAM_CONST) { #ifndef NO_LONG_LONG if (t != TYQUAD && pt != TYQUAD) /*20010820*/ #endif if (ISINT(t) && ISINT(pt) || ISREAL(t) && ISREAL(pt)) { /* avoid trouble with -i2 */ p->headblock.vtype = t; return p; } q = (expptr) mkconst(t); consconv(t, &q->constblock, &p->constblock ); if (p->tag == TADDR) q->constblock.vstg = p->addrblock.user.kludge.vstg1; frexpr(p); } else { if (pt == TYCHAR && t != TYADDR && charwarn && (!halign || p->tag != TADDR || p->addrblock.uname_tag != UNAM_CONST)) warn( "ichar([first char. of] char. string) assumed for conversion to numeric"); q = opconv(p, t); } if(t == TYCHAR) q->constblock.vleng = ICON(1); return(q); } /* opconv -- Convert expression p to type t using the main expression evaluator; returns an OPCONV expression, I think 14-jun-88 mwm */ expptr #ifdef KR_headers opconv(p, t) expptr p; int t; #else opconv(expptr p, int t) #endif { expptr q; if (t == TYSUBR) err("illegal use of subroutine name"); q = mkexpr(OPCONV, p, ENULL); q->headblock.vtype = t; return(q); } /* addrof -- Create an ADDR expression operation */ expptr #ifdef KR_headers addrof(p) expptr p; #else addrof(expptr p) #endif { return( mkexpr(OPADDR, p, ENULL) ); } /* cpexpr - Returns a new copy of input expression p */ tagptr #ifdef KR_headers cpexpr(p) tagptr p; #else cpexpr(tagptr p) #endif { tagptr e; int tag; chainp ep, pp; /* This table depends on the ordering of the T macros, e.g. TNAME */ static int blksize[ ] = { 0, sizeof(struct Nameblock), sizeof(struct Constblock), sizeof(struct Exprblock), sizeof(struct Addrblock), sizeof(struct Primblock), sizeof(struct Listblock), sizeof(struct Impldoblock), sizeof(struct Errorblock) }; if(p == NULL) return(NULL); /* TNAMEs are special, and don't get copied. Each name in the current symbol table has a unique TNAME structure. */ if( (tag = p->tag) == TNAME) return(p); e = cpblock(blksize[p->tag], (char *)p); switch(tag) { case TCONST: if(e->constblock.vtype == TYCHAR) { e->constblock.Const.ccp = copyn((int)e->constblock.vleng->constblock.Const.ci+1, e->constblock.Const.ccp); e->constblock.vleng = (expptr) cpexpr(e->constblock.vleng); } case TERROR: break; case TEXPR: e->exprblock.leftp = (expptr) cpexpr(p->exprblock.leftp); e->exprblock.rightp = (expptr) cpexpr(p->exprblock.rightp); break; case TLIST: if(pp = p->listblock.listp) { ep = e->listblock.listp = mkchain((char *)cpexpr((tagptr)pp->datap), CHNULL); for(pp = pp->nextp ; pp ; pp = pp->nextp) ep = ep->nextp = mkchain((char *)cpexpr((tagptr)pp->datap), CHNULL); } break; case TADDR: e->addrblock.vleng = (expptr) cpexpr(e->addrblock.vleng); e->addrblock.memoffset = (expptr)cpexpr(e->addrblock.memoffset); e->addrblock.istemp = NO; break; case TPRIM: e->primblock.argsp = (struct Listblock *) cpexpr((expptr)e->primblock.argsp); e->primblock.fcharp = (expptr) cpexpr(e->primblock.fcharp); e->primblock.lcharp = (expptr) cpexpr(e->primblock.lcharp); break; default: badtag("cpexpr", tag); } return(e); } /* frexpr -- Free expression -- frees up memory used by expression p */ void #ifdef KR_headers frexpr(p) tagptr p; #else frexpr(tagptr p) #endif { chainp q; if(p == NULL) return; switch(p->tag) { case TCONST: if( ISCHAR(p) ) { free( (charptr) (p->constblock.Const.ccp) ); frexpr(p->constblock.vleng); } break; case TADDR: if (p->addrblock.vtype > TYERROR) /* i/o block */ break; frexpr(p->addrblock.vleng); frexpr(p->addrblock.memoffset); break; case TERROR: break; /* TNAME blocks don't get free'd - probably because they're pointed to in the hash table. 14-Jun-88 -- mwm */ case TNAME: return; case TPRIM: frexpr((expptr)p->primblock.argsp); frexpr(p->primblock.fcharp); frexpr(p->primblock.lcharp); break; case TEXPR: frexpr(p->exprblock.leftp); if(p->exprblock.rightp) frexpr(p->exprblock.rightp); break; case TLIST: for(q = p->listblock.listp ; q ; q = q->nextp) frexpr((tagptr)q->datap); frchain( &(p->listblock.listp) ); break; default: badtag("frexpr", p->tag); } free( (charptr) p ); } void #ifdef KR_headers wronginf(np) Namep np; #else wronginf(Namep np) #endif { int c; ftnint k; warn1("fixing wrong type inferred for %.65s", np->fvarname); np->vinftype = 0; c = letter(np->fvarname[0]); if ((np->vtype = impltype[c]) == TYCHAR && (k = implleng[c])) np->vleng = ICON(k); } /* fix up types in expression; replace subtrees and convert names to address blocks */ expptr #ifdef KR_headers fixtype(p) tagptr p; #else fixtype(tagptr p) #endif { if(p == 0) return(0); switch(p->tag) { case TCONST: if(ONEOF(p->constblock.vtype,MSKINT|MSKLOGICAL|MSKADDR| MSKREAL) ) return( (expptr) p); return( (expptr) putconst((Constp)p) ); case TADDR: p->addrblock.memoffset = fixtype(p->addrblock.memoffset); return( (expptr) p); case TERROR: return( (expptr) p); default: badtag("fixtype", p->tag); /* This case means that fixexpr can't call fixtype with any expr, only a subexpr of its parameter. */ case TEXPR: if (((Exprp)p)->typefixed) return (expptr)p; return( fixexpr((Exprp)p) ); case TLIST: return( (expptr) p ); case TPRIM: if(p->primblock.argsp && p->primblock.namep->vclass!=CLVAR) { if(p->primblock.namep->vtype == TYSUBR) { err("function invocation of subroutine"); return( errnode() ); } else { if (p->primblock.namep->vinftype) wronginf(p->primblock.namep); return( mkfunct(p) ); } } /* The lack of args makes p a function name, substring reference or variable name. */ else return mklhs((struct Primblock *) p, keepsubs); } } int #ifdef KR_headers badchleng(p) expptr p; #else badchleng(expptr p) #endif { if (!p->headblock.vleng) { if (p->headblock.tag == TADDR && p->addrblock.uname_tag == UNAM_NAME) errstr("bad use of character*(*) variable %.60s", p->addrblock.user.name->fvarname); else err("Bad use of character*(*)"); return 1; } return 0; } static expptr #ifdef KR_headers cplenexpr(p) expptr p; #else cplenexpr(expptr p) #endif { expptr rv; if (badchleng(p)) return ICON(1); rv = cpexpr(p->headblock.vleng); if (ISCONST(p) && p->constblock.vtype == TYCHAR) rv->constblock.Const.ci += p->constblock.Const.ccp1.blanks; return rv; } /* special case tree transformations and cleanups of expression trees. Parameter p should have a TEXPR tag at its root, else an error is returned */ expptr #ifdef KR_headers fixexpr(p) Exprp p; #else fixexpr(Exprp p) #endif { expptr lp, rp, q; char *hsave; int opcode, ltype, rtype, ptype, mtype; if( ISERROR(p) || p->typefixed ) return( (expptr) p ); else if(p->tag != TEXPR) badtag("fixexpr", p->tag); opcode = p->opcode; /* First set the types of the left and right subexpressions */ lp = p->leftp; if (!ISCONST(lp) || lp->constblock.vtype != TYCHAR) lp = p->leftp = fixtype(lp); ltype = lp->headblock.vtype; if(opcode==OPASSIGN && lp->tag!=TADDR) { err("left side of assignment must be variable"); eret: frexpr((expptr)p); return( errnode() ); } if(rp = p->rightp) { if (!ISCONST(rp) || rp->constblock.vtype != TYCHAR) rp = p->rightp = fixtype(rp); rtype = rp->headblock.vtype; } else rtype = 0; if(ltype==TYERROR || rtype==TYERROR) goto eret; /* Now work on the whole expression */ /* force folding if possible */ if( ISCONST(lp) && (rp==NULL || ISCONST(rp)) ) { q = opcode == OPCONV && lp->constblock.vtype == p->vtype ? lp : mkexpr(opcode, lp, rp); /* mkexpr is expected to reduce constant expressions */ if( ISCONST(q) ) { p->leftp = p->rightp = 0; frexpr((expptr)p); return(q); } free( (charptr) q ); /* constants did not fold */ } if( (ptype = cktype(opcode, ltype, rtype)) == TYERROR) goto eret; if (ltype == TYCHAR && ISCONST(lp)) { if (opcode == OPCONV) { hsave = halign; halign = 0; lp = (expptr)putconst((Constp)lp); halign = hsave; } else lp = (expptr)putconst((Constp)lp); p->leftp = lp; } if (rtype == TYCHAR && ISCONST(rp)) p->rightp = rp = (expptr)putconst((Constp)rp); switch(opcode) { case OPCONCAT: if(p->vleng == NULL) p->vleng = mkexpr(OPPLUS, cplenexpr(lp), cplenexpr(rp) ); break; case OPASSIGN: if (rtype == TYREAL || ISLOGICAL(ptype) || rtype == TYDREAL && ltype == TYREAL && !ISCONST(rp)) break; case OPPLUSEQ: case OPSTAREQ: if(ltype == rtype) break; if( ! ISCONST(rp) && ISREAL(ltype) && ISREAL(rtype) ) break; if( ISCOMPLEX(ltype) || ISCOMPLEX(rtype) ) break; if( ONEOF(ltype, MSKADDR|MSKINT) && ONEOF(rtype, MSKADDR|MSKINT) && typesize[ltype]>=typesize[rtype] ) break; /* Cast the right hand side to match the type of the expression */ p->rightp = fixtype( mkconv(ptype, rp) ); break; case OPSLASH: if( ISCOMPLEX(rtype) ) { p = (Exprp) call2(ptype, /* Handle double precision complex variables */ (char*)(ptype == TYCOMPLEX ? "c_div" : "z_div"), mkconv(ptype, lp), mkconv(ptype, rp) ); break; } case OPPLUS: case OPMINUS: case OPSTAR: case OPMOD: if(ptype==TYDREAL && ( (ltype==TYREAL && ! ISCONST(lp) ) || (rtype==TYREAL && ! ISCONST(rp) ) )) break; if( ISCOMPLEX(ptype) ) break; /* Cast both sides of the expression to match the type of the whole expression. */ if(ltype != ptype && (ltype < TYINT1 || ptype > TYDREAL)) p->leftp = fixtype(mkconv(ptype,lp)); if(rtype != ptype && (rtype < TYINT1 || ptype > TYDREAL)) p->rightp = fixtype(mkconv(ptype,rp)); break; case OPPOWER: rp = mkpower((expptr)p); if (rp->tag == TEXPR) rp->exprblock.typefixed = 1; return rp; case OPLT: case OPLE: case OPGT: case OPGE: case OPEQ: case OPNE: if(ltype == rtype) break; if (htype) { if (ltype == TYCHAR) { p->leftp = fixtype(mkconv(rtype,lp)); break; } if (rtype == TYCHAR) { p->rightp = fixtype(mkconv(ltype,rp)); break; } } mtype = cktype(OPMINUS, ltype, rtype); if(mtype==TYDREAL && (ltype==TYREAL || rtype==TYREAL)) break; if( ISCOMPLEX(mtype) ) break; if(ltype != mtype) p->leftp = fixtype(mkconv(mtype,lp)); if(rtype != mtype) p->rightp = fixtype(mkconv(mtype,rp)); break; case OPCONV: ptype = cktype(OPCONV, p->vtype, ltype); if(lp->tag==TEXPR && lp->exprblock.opcode==OPCOMMA && !ISCOMPLEX(ptype)) { lp->exprblock.rightp = fixtype( mkconv(ptype, lp->exprblock.rightp) ); free( (charptr) p ); p = (Exprp) lp; } break; case OPADDR: if(lp->tag==TEXPR && lp->exprblock.opcode==OPADDR) Fatal("addr of addr"); break; case OPCOMMA: case OPQUEST: case OPCOLON: break; case OPMIN: case OPMAX: case OPMIN2: case OPMAX2: case OPDMIN: case OPDMAX: case OPABS: case OPDABS: ptype = p->vtype; break; default: break; } p->vtype = ptype; p->typefixed = 1; return((expptr) p); } /* fix an argument list, taking due care for special first level cases */ int #ifdef KR_headers fixargs(doput, p0) int doput; struct Listblock *p0; #else fixargs(int doput, struct Listblock *p0) #endif /* doput is true if constants need to be passed by reference */ { chainp p; tagptr q, t; int qtag, nargs; nargs = 0; if(p0) for(p = p0->listp ; p ; p = p->nextp) { ++nargs; q = (tagptr)p->datap; qtag = q->tag; if(qtag == TCONST) { /* Call putconst() to store values in a constant table. Since even constants must be passed by reference, this can optimize on the storage required */ p->datap = doput ? (char *)putconst((Constp)q) : (char *)q; continue; } /* Take a function name and turn it into an Addr. This only happens when nothing else has figured out the function beforehand */ if (qtag == TPRIM && q->primblock.argsp == 0) { if (q->primblock.namep->vclass==CLPROC && q->primblock.namep->vprocclass != PTHISPROC) { p->datap = (char *)mkaddr(q->primblock.namep); continue; } if (q->primblock.namep->vdim != NULL) { p->datap = (char *)mkscalar(q->primblock.namep); if ((q->primblock.fcharp||q->primblock.lcharp) && (q->primblock.namep->vtype != TYCHAR || q->primblock.namep->vdim)) sserr(q->primblock.namep); continue; } if (q->primblock.namep->vdovar && (t = (tagptr) memversion(q->primblock.namep))) { p->datap = (char *)fixtype(t); continue; } } p->datap = (char *)fixtype(q); } return(nargs); } /* mkscalar -- only called by fixargs above, and by some routines in io.c */ Addrp #ifdef KR_headers mkscalar(np) Namep np; #else mkscalar(Namep np) #endif { Addrp ap; vardcl(np); ap = mkaddr(np); /* The prolog causes array arguments to point to the * (0,...,0) element, unless subscript checking is on. */ if( !checksubs && np->vstg==STGARG) { struct Dimblock *dp; dp = np->vdim; frexpr(ap->memoffset); ap->memoffset = mkexpr(OPSTAR, (np->vtype==TYCHAR ? cpexpr(np->vleng) : (tagptr)ICON(typesize[np->vtype]) ), cpexpr(dp->baseoffset) ); } return(ap); } static void #ifdef KR_headers adjust_arginfo(np) Namep np; #else adjust_arginfo(Namep np) #endif /* adjust arginfo to omit the length arg for the arg that we now know to be a character-valued function */ { struct Entrypoint *ep; chainp args; Argtypes *at; for(ep = entries; ep; ep = ep->entnextp) for(args = ep->arglist; args; args = args->nextp) if (np == (Namep)args->datap && (at = ep->entryname->arginfo)) --at->nargs; } expptr #ifdef KR_headers mkfunct(p0) expptr p0; #else mkfunct(expptr p0) #endif { struct Primblock *p = (struct Primblock *)p0; struct Entrypoint *ep; Addrp ap; Extsym *extp; Namep np; expptr q; extern chainp new_procs; int k, nargs; int vclass; if(p->tag != TPRIM) return( errnode() ); np = p->namep; vclass = np->vclass; if(vclass == CLUNKNOWN) { np->vclass = vclass = CLPROC; if(np->vstg == STGUNKNOWN) { if(np->vtype!=TYSUBR && (k = intrfunct(np->fvarname)) && (zflag || !(*(struct Intrpacked *)&k).f4 || dcomplex_seen)) { np->vstg = STGINTR; np->vardesc.varno = k; np->vprocclass = PINTRINSIC; } else { extp = mkext(np->fvarname, addunder(np->cvarname)); extp->extstg = STGEXT; np->vstg = STGEXT; np->vardesc.varno = extp - extsymtab; np->vprocclass = PEXTERNAL; } } else if(np->vstg==STGARG) { if(np->vtype == TYCHAR) { adjust_arginfo(np); if (np->vpassed) { char wbuf[160], *who; who = np->fvarname; sprintf(wbuf, "%s%s%s\n\t%s%s%s", "Character-valued dummy procedure ", who, " not declared EXTERNAL.", "Code may be wrong for previous function calls having ", who, " as a parameter."); warn(wbuf); } } np->vprocclass = PEXTERNAL; } } if(vclass != CLPROC) { if (np->vstg == STGCOMMON) fatalstr( "Cannot invoke common variable %.50s as a function.", np->fvarname); errstr("%.80s cannot be called.", np->fvarname); goto error; } /* F77 doesn't allow subscripting of function calls */ if(p->fcharp || p->lcharp) { err("no substring of function call"); goto error; } impldcl(np); np->vimpltype = 0; /* invoking as function ==> inferred type */ np->vcalled = 1; nargs = fixargs( np->vprocclass!=PINTRINSIC, p->argsp); switch(np->vprocclass) { case PEXTERNAL: if(np->vtype == TYUNKNOWN) { dclerr("attempt to use untyped function", np); np->vtype = dflttype[letter(np->fvarname[0])]; } ap = mkaddr(np); if (!extsymtab[np->vardesc.varno].extseen) { new_procs = mkchain((char *)np, new_procs); extsymtab[np->vardesc.varno].extseen = 1; } call: q = mkexpr(OPCALL, (expptr)ap, (expptr)p->argsp); q->exprblock.vtype = np->vtype; if(np->vleng) q->exprblock.vleng = (expptr) cpexpr(np->vleng); break; case PINTRINSIC: q = intrcall(np, p->argsp, nargs); break; case PSTFUNCT: q = stfcall(np, p->argsp); break; case PTHISPROC: warn("recursive call"); /* entries is the list of multiple entry points */ for(ep = entries ; ep ; ep = ep->entnextp) if(ep->enamep == np) break; if(ep == NULL) Fatal("mkfunct: impossible recursion"); ap = builtin(np->vtype, ep->entryname->cextname, -2); /* the negative last arg prevents adding */ /* this name to the list of used builtins */ goto call; default: fatali("mkfunct: impossible vprocclass %d", (int) (np->vprocclass) ); } free( (charptr) p ); return(q); error: frexpr((expptr)p); return( errnode() ); } static expptr #ifdef KR_headers stfcall(np, actlist) Namep np; struct Listblock *actlist; #else stfcall(Namep np, struct Listblock *actlist) #endif { chainp actuals; int nargs; chainp oactp, formals; int type; expptr Ln, Lq, q, q1, rhs, ap; Namep tnp; struct Rplblock *rp; struct Rplblock *tlist; if (np->arginfo) { errstr("statement function %.66s calls itself.", np->fvarname); return ICON(0); } np->arginfo = (Argtypes *)np; /* arbitrary nonzero value */ if(actlist) { actuals = actlist->listp; free( (charptr) actlist); } else actuals = NULL; oactp = actuals; nargs = 0; tlist = NULL; if( (type = np->vtype) == TYUNKNOWN) { dclerr("attempt to use untyped statement function", np); type = np->vtype = dflttype[letter(np->fvarname[0])]; } formals = (chainp) np->varxptr.vstfdesc->datap; rhs = (expptr) (np->varxptr.vstfdesc->nextp); /* copy actual arguments into temporaries */ while(actuals!=NULL && formals!=NULL) { if (!(tnp = (Namep) formals->datap)) { /* buggy statement function declaration */ q = ICON(1); goto done; } rp = ALLOC(Rplblock); rp->rplnp = tnp; ap = fixtype((tagptr)actuals->datap); if(tnp->vtype==ap->headblock.vtype && tnp->vtype!=TYCHAR && (ap->tag==TCONST || ap->tag==TADDR) ) { /* If actuals are constants or variable names, no temporaries are required */ rp->rplvp = (expptr) ap; rp->rplxp = NULL; rp->rpltag = ap->tag; } else { rp->rplvp = (expptr) mktmp(tnp->vtype, tnp->vleng); rp -> rplxp = NULL; putexpr ( mkexpr(OPASSIGN, cpexpr(rp->rplvp), ap)); if((rp->rpltag = rp->rplvp->tag) == TERROR) err("disagreement of argument types in statement function call"); } rp->rplnextp = tlist; tlist = rp; actuals = actuals->nextp; formals = formals->nextp; ++nargs; } if(actuals!=NULL || formals!=NULL) err("statement function definition and argument list differ"); /* now push down names involved in formal argument list, then evaluate rhs of statement function definition in this environment */ if(tlist) /* put tlist in front of the rpllist */ { for(rp = tlist; rp->rplnextp; rp = rp->rplnextp) ; rp->rplnextp = rpllist; rpllist = tlist; } /* So when the expression finally gets evaled, that evaluator must read from the globl rpllist 14-jun-88 mwm */ q = (expptr) mkconv(type, fixtype(cpexpr(rhs)) ); /* get length right of character-valued statement functions... */ if (type == TYCHAR && (Ln = np->vleng) && q->tag != TERROR && (Lq = q->exprblock.vleng) && (Lq->tag != TCONST || Ln->constblock.Const.ci != Lq->constblock.Const.ci)) { q1 = (expptr) mktmp(type, Ln); putexpr ( mkexpr(OPASSIGN, cpexpr(q1), q)); q = q1; } /* now generate the tree ( t1=a1, (t2=a2,... , f))))) */ while(--nargs >= 0) { if(rpllist->rplxp) q = mkexpr(OPCOMMA, rpllist->rplxp, q); rp = rpllist->rplnextp; frexpr(rpllist->rplvp); free((char *)rpllist); rpllist = rp; } done: frchain( &oactp ); np->arginfo = 0; return(q); } static int replaced; /* mkplace -- Figure out the proper storage class for the input name and return an addrp with the appropriate stuff */ Addrp #ifdef KR_headers mkplace(np) Namep np; #else mkplace(Namep np) #endif { Addrp s; struct Rplblock *rp; int regn; /* is name on the replace list? */ for(rp = rpllist ; rp ; rp = rp->rplnextp) { if(np == rp->rplnp) { replaced = 1; if(rp->rpltag == TNAME) { np = (Namep) (rp->rplvp); break; } else return( (Addrp) cpexpr(rp->rplvp) ); } } /* is variable a DO index in a register ? */ if(np->vdovar && ( (regn = inregister(np)) >= 0) ) if(np->vtype == TYERROR) return((Addrp) errnode() ); else { s = ALLOC(Addrblock); s->tag = TADDR; s->vstg = STGREG; s->vtype = TYIREG; s->memno = regn; s->memoffset = ICON(0); s -> uname_tag = UNAM_NAME; s -> user.name = np; return(s); } if (np->vclass == CLPROC && np->vprocclass != PTHISPROC) errstr("external %.60s used as a variable", np->fvarname); vardcl(np); return(mkaddr(np)); } static expptr #ifdef KR_headers subskept(p, a) struct Primblock *p; Addrp a; #else subskept(struct Primblock *p, Addrp a) #endif { expptr ep; struct Listblock *Lb; chainp cp; if (a->uname_tag != UNAM_NAME) erri("subskept: uname_tag %d", a->uname_tag); a->user.name->vrefused = 1; a->user.name->visused = 1; a->uname_tag = UNAM_REF; Lb = (struct Listblock *)cpexpr((tagptr)p->argsp); for(cp = Lb->listp; cp; cp = cp->nextp) cp->datap = (char *)putx(fixtype((tagptr)cp->datap)); if (a->vtype == TYCHAR) { ep = p->fcharp ? mkexpr(OPMINUS, cpexpr(p->fcharp), ICON(1)) : ICON(0); Lb->listp = mkchain((char *)ep, Lb->listp); } return (expptr)Lb; } static void #ifdef KR_headers substrerr(np) Namep np; #else substrerr(Namep np) #endif { void (*f) Argdcl((const char*, const char*)); f = checksubs ? errstr : warn1; (*f)("substring of %.65s is out of bounds.", np->fvarname); } static int doing_vleng; /* mklhs -- Compute the actual address of the given expression; account for array subscripts, stack offset, and substring offsets. The f -> C translator will need this only to worry about the subscript stuff */ expptr #ifdef KR_headers mklhs(p, subkeep) struct Primblock *p; int subkeep; #else mklhs(struct Primblock *p, int subkeep) #endif { Addrp s; Namep np; if(p->tag != TPRIM) return( (expptr) p ); np = p->namep; replaced = 0; s = mkplace(np); if(s->tag!=TADDR || s->vstg==STGREG) { free( (charptr) p ); return( (expptr) s ); } s->parenused = p->parenused; /* compute the address modified by subscripts */ if (!replaced) s->memoffset = (subkeep && np->vdim && p->argsp && (np->vdim->ndim > 1 || np->vtype == TYCHAR && (!ISCONST(np->vleng) || np->vleng->constblock.Const.ci != 1))) ? subskept(p,s) : mkexpr(OPPLUS, s->memoffset, suboffset(p) ); frexpr((expptr)p->argsp); p->argsp = NULL; /* now do substring part */ if(p->fcharp || p->lcharp) { if(np->vtype != TYCHAR) sserr(np); else { if(p->lcharp == NULL) p->lcharp = (expptr)( /* s->vleng == 0 only with errors */ s->vleng ? cpexpr(s->vleng) : ICON(1)); else if (ISCONST(p->lcharp) && ISCONST(np->vleng) && p->lcharp->constblock.Const.ci > np->vleng->constblock.Const.ci) substrerr(np); if(p->fcharp) { doing_vleng = 1; s->vleng = fixtype(mkexpr(OPMINUS, p->lcharp, mkexpr(OPMINUS, p->fcharp, ICON(1) ))); doing_vleng = 0; } else { frexpr(s->vleng); s->vleng = p->lcharp; } if (s->memoffset && ISCONST(s->memoffset) && s->memoffset->constblock.Const.ci < 0) substrerr(np); } } s->vleng = fixtype( s->vleng ); s->memoffset = fixtype( s->memoffset ); free( (charptr) p ); return( (expptr) s ); } /* deregister -- remove a register allocation from the list; assumes that names are deregistered in stack order (LIFO order - Last In First Out) */ void #ifdef KR_headers deregister(np) Namep np; #else deregister(Namep np) #endif { if(nregvar>0 && regnamep[nregvar-1]==np) { --nregvar; } } /* memversion -- moves a DO index REGISTER into a memory location; other objects are passed through untouched */ Addrp #ifdef KR_headers memversion(np) Namep np; #else memversion(Namep np) #endif { Addrp s; if(np->vdovar==NO || (inregister(np)<0) ) return(NULL); np->vdovar = NO; s = mkplace(np); np->vdovar = YES; return(s); } /* inregister -- looks for the input name in the global list regnamep */ int #ifdef KR_headers inregister(np) Namep np; #else inregister(Namep np) #endif { int i; for(i = 0 ; i < nregvar ; ++i) if(regnamep[i] == np) return( regnum[i] ); return(-1); } /* suboffset -- Compute the offset from the start of the array, given the subscripts as arguments */ expptr #ifdef KR_headers suboffset(p) struct Primblock *p; #else suboffset(struct Primblock *p) #endif { int n; expptr si, size; chainp cp; expptr e, e1, offp, prod; struct Dimblock *dimp; expptr sub[MAXDIM+1]; Namep np; np = p->namep; offp = ICON(0); n = 0; if(p->argsp) for(cp = p->argsp->listp ; cp ; cp = cp->nextp) { si = fixtype(cpexpr((tagptr)cp->datap)); if (!ISINT(si->headblock.vtype)) { NOEXT("non-integer subscript"); si = mkconv(TYLONG, si); } sub[n++] = si; if(n > maxdim) { erri("more than %d subscripts", maxdim); break; } } dimp = np->vdim; if(n>0 && dimp==NULL) errstr("subscripts on scalar variable %.68s", np->fvarname); else if(dimp && dimp->ndim!=n) errstr("wrong number of subscripts on %.68s", np->fvarname); else if(n > 0) { prod = sub[--n]; while( --n >= 0) prod = mkexpr(OPPLUS, sub[n], mkexpr(OPSTAR, prod, cpexpr(dimp->dims[n].dimsize)) ); if(checksubs || np->vstg!=STGARG) prod = mkexpr(OPMINUS, prod, cpexpr(dimp->baseoffset)); /* Add in the run-time bounds check */ if(checksubs) prod = subcheck(np, prod); size = np->vtype == TYCHAR ? (expptr) cpexpr(np->vleng) : ICON(typesize[np->vtype]); prod = mkexpr(OPSTAR, prod, size); offp = mkexpr(OPPLUS, offp, prod); } /* Check for substring indicator */ if(p->fcharp && np->vtype==TYCHAR) { e = p->fcharp; e1 = mkexpr(OPMINUS, cpexpr(e), ICON(1)); if (!ISCONST(e) && (e->tag != TPRIM || e->primblock.argsp)) { e = (expptr)mktmp(TYLONG, ENULL); putout(putassign(cpexpr(e), e1)); p->fcharp = mkexpr(OPPLUS, cpexpr(e), ICON(1)); e1 = e; } offp = mkexpr(OPPLUS, offp, e1); } return(offp); } expptr #ifdef KR_headers subcheck(np, p) Namep np; expptr p; #else subcheck(Namep np, expptr p) #endif { struct Dimblock *dimp; expptr t, checkvar, checkcond, badcall; dimp = np->vdim; if(dimp->nelt == NULL) return(p); /* don't check arrays with * bounds */ np->vlastdim = 0; if( ISICON(p) ) { /* check for negative (constant) offset */ if(p->constblock.Const.ci < 0) goto badsub; if( ISICON(dimp->nelt) ) /* see if constant offset exceeds the array declaration */ if(p->constblock.Const.ci < dimp->nelt->constblock.Const.ci) return(p); else goto badsub; } /* We know that the subscript offset p or dimp -> nelt is not a constant. Now find a register to use for run-time bounds checking */ if(p->tag==TADDR && p->addrblock.vstg==STGREG) { checkvar = (expptr) cpexpr(p); t = p; } else { checkvar = (expptr) mktmp(TYLONG, ENULL); t = mkexpr(OPASSIGN, cpexpr(checkvar), p); } checkcond = mkexpr(OPLT, t, cpexpr(dimp->nelt) ); if( ! ISICON(p) ) checkcond = mkexpr(OPAND, checkcond, mkexpr(OPLE, ICON(0), cpexpr(checkvar)) ); /* Construct the actual test */ badcall = call4(p->headblock.vtype, "s_rnge", mkstrcon(strlen(np->fvarname), np->fvarname), mkconv(TYLONG, cpexpr(checkvar)), mkstrcon(strlen(procname), procname), ICON(lineno) ); badcall->exprblock.opcode = OPCCALL; p = mkexpr(OPQUEST, checkcond, mkexpr(OPCOLON, checkvar, badcall)); return(p); badsub: frexpr(p); errstr("subscript on variable %s out of range", np->fvarname); return ( ICON(0) ); } Addrp #ifdef KR_headers mkaddr(p) Namep p; #else mkaddr(Namep p) #endif { Extsym *extp; Addrp t; int k; switch( p->vstg) { case STGAUTO: if(p->vclass == CLPROC && p->vprocclass == PTHISPROC) return (Addrp) cpexpr((expptr)xretslot[p->vtype]); goto other; case STGUNKNOWN: if(p->vclass != CLPROC) break; /* Error */ extp = mkext(p->fvarname, addunder(p->cvarname)); extp->extstg = STGEXT; p->vstg = STGEXT; p->vardesc.varno = extp - extsymtab; p->vprocclass = PEXTERNAL; if ((extp->exproto || infertypes) && (p->vtype == TYUNKNOWN || p->vimpltype) && (k = extp->extype)) inferdcl(p, k); case STGCOMMON: case STGEXT: case STGBSS: case STGINIT: case STGEQUIV: case STGARG: case STGLENG: other: t = ALLOC(Addrblock); t->tag = TADDR; t->vclass = p->vclass; t->vtype = p->vtype; t->vstg = p->vstg; t->memno = p->vardesc.varno; t->memoffset = ICON(p->voffset); if (p->vdim) t->isarray = 1; if(p->vleng) { t->vleng = (expptr) cpexpr(p->vleng); if( ISICON(t->vleng) ) t->varleng = t->vleng->constblock.Const.ci; } /* Keep the original name around for the C code generation */ t -> uname_tag = UNAM_NAME; t -> user.name = p; return(t); case STGINTR: return ( intraddr (p)); case STGSTFUNCT: errstr("invalid use of statement function %.64s.", p->fvarname); return putconst((Constp)ICON(0)); } badstg("mkaddr", p->vstg); /* NOT REACHED */ return 0; } /* mkarg -- create storage for a new parameter. This is called when a function returns a string (for the return value, which is the first parameter), or when a variable-length string is passed to a function. */ Addrp #ifdef KR_headers mkarg(type, argno) int type; int argno; #else mkarg(int type, int argno) #endif { Addrp p; p = ALLOC(Addrblock); p->tag = TADDR; p->vtype = type; p->vclass = CLVAR; /* TYLENG is the type of the field holding the length of a character string */ p->vstg = (type==TYLENG ? STGLENG : STGARG); p->memno = argno; return(p); } /* mkprim -- Create a PRIM (primary/primitive) block consisting of a Nameblock (or Paramblock), arguments (actual params or array subscripts) and substring bounds. Requires that v have lots of extra (uninitialized) storage, since it could be a paramblock or nameblock */ expptr #ifdef KR_headers mkprim(v0, args, substr) Namep v0; struct Listblock *args; chainp substr; #else mkprim(Namep v0, struct Listblock *args, chainp substr) #endif { typedef union { struct Paramblock paramblock; struct Nameblock nameblock; struct Headblock headblock; } *Primu; Primu v = (Primu)v0; struct Primblock *p; if(v->headblock.vclass == CLPARAM) { /* v is to be a Paramblock */ if(args || substr) { errstr("no qualifiers on parameter name %s", v->paramblock.fvarname); frexpr((expptr)args); if(substr) { frexpr((tagptr)substr->datap); frexpr((tagptr)substr->nextp->datap); frchain(&substr); } frexpr((expptr)v); return( errnode() ); } return( (expptr) cpexpr(v->paramblock.paramval) ); } p = ALLOC(Primblock); p->tag = TPRIM; p->vtype = v->nameblock.vtype; /* v is to be a Nameblock */ p->namep = (Namep) v; p->argsp = args; if(substr) { p->fcharp = (expptr) substr->datap; p->lcharp = (expptr) substr->nextp->datap; frchain(&substr); } return( (expptr) p); } /* vardcl -- attempt to fill out the Name template for variable v. This function is called on identifiers known to be variables or recursive references to the same function */ void #ifdef KR_headers vardcl(v) Namep v; #else vardcl(Namep v) #endif { struct Dimblock *t; expptr neltp; extern int doing_stmtfcn; if(v->vclass == CLUNKNOWN) { v->vclass = CLVAR; if (v->vinftype) { v->vtype = TYUNKNOWN; if (v->vdcldone) { v->vdcldone = 0; impldcl(v); } } } if(v->vdcldone) return; if(v->vclass == CLNAMELIST) return; if(v->vtype == TYUNKNOWN) impldcl(v); else if(v->vclass!=CLVAR && v->vprocclass!=PTHISPROC) { dclerr("used as variable", v); return; } if(v->vstg==STGUNKNOWN) { if (doing_stmtfcn) { /* neither declare this variable if its only use */ /* is in defining a stmt function, nor complain */ /* that it is never used */ v->vimpldovar = 1; return; } v->vstg = implstg[ letter(v->fvarname[0]) ]; v->vimplstg = 1; } /* Compute the actual storage location, i.e. offsets from base addresses, possibly the stack pointer */ switch(v->vstg) { case STGBSS: v->vardesc.varno = ++lastvarno; break; case STGAUTO: if(v->vclass==CLPROC && v->vprocclass==PTHISPROC) break; if(t = v->vdim) if( (neltp = t->nelt) && ISCONST(neltp) ) ; else dclerr("adjustable automatic array", v); break; default: break; } v->vdcldone = YES; } /* Set the implicit type declaration of parameter p based on its first letter */ void #ifdef KR_headers impldcl(p) Namep p; #else impldcl(Namep p) #endif { int k; int type; ftnint leng; if(p->vdcldone || (p->vclass==CLPROC && p->vprocclass==PINTRINSIC) ) return; if(p->vtype == TYUNKNOWN) { k = letter(p->fvarname[0]); type = impltype[ k ]; leng = implleng[ k ]; if(type == TYUNKNOWN) { if(p->vclass == CLPROC) return; dclerr("attempt to use undefined variable", p); type = dflttype[k]; leng = 0; } settype(p, type, leng); p->vimpltype = 1; } } void #ifdef KR_headers inferdcl(np, type) Namep np; int type; #else inferdcl(Namep np, int type) #endif { int k = impltype[letter(np->fvarname[0])]; if (k != type) { np->vinftype = 1; np->vtype = type; frexpr(np->vleng); np->vleng = 0; } np->vimpltype = 0; np->vinfproc = 1; } LOCAL int #ifdef KR_headers zeroconst(e) expptr e; #else zeroconst(expptr e) #endif { Constp c = (Constp) e; if (c->tag == TCONST) switch(c->vtype) { case TYINT1: case TYSHORT: case TYLONG: #ifdef TYQUAD0 case TYQUAD: #endif return c->Const.ci == 0; #ifndef NO_LONG_LONG case TYQUAD: return c->Const.cq == 0; #endif case TYREAL: case TYDREAL: if (c->vstg == 1) return !strcmp(c->Const.cds[0],"0."); return c->Const.cd[0] == 0.; case TYCOMPLEX: case TYDCOMPLEX: if (c->vstg == 1) return !strcmp(c->Const.cds[0],"0.") && !strcmp(c->Const.cds[1],"0."); return c->Const.cd[0] == 0. && c->Const.cd[1] == 0.; } return 0; } void #ifdef KR_headers paren_used(p) struct Primblock *p; #else paren_used(struct Primblock *p) #endif { Namep np; p->parenused = 1; if (!p->argsp && (np = p->namep) && np->vdim) warn1("inappropriate operation on unsubscripted array %.50s", np->fvarname); } #define ICONEQ(z, c) (ISICON(z) && z->constblock.Const.ci==c) #define COMMUTE { e = lp; lp = rp; rp = e; } /* mkexpr -- Make expression, and simplify constant subcomponents (tree order is not preserved). Assumes that lp is nonempty, and uses fold() to simplify adjacent constants */ expptr #ifdef KR_headers mkexpr(opcode, lp, rp) int opcode; expptr lp; expptr rp; #else mkexpr(int opcode, expptr lp, expptr rp) #endif { expptr e, e1; int etype; int ltype, rtype; int ltag, rtag; long L; static long divlineno; if (parstate < INEXEC) { /* Song and dance to get statement functions right */ /* while catching incorrect type combinations in the */ /* first executable statement. */ ltype = lp->headblock.vtype; ltag = lp->tag; if(rp && opcode!=OPCALL && opcode!=OPCCALL) { rtype = rp->headblock.vtype; rtag = rp->tag; } else rtype = 0; etype = cktype(opcode, ltype, rtype); if(etype == TYERROR) goto error; goto no_fold; } ltype = lp->headblock.vtype; if (ltype == TYUNKNOWN) { lp = fixtype(lp); ltype = lp->headblock.vtype; } ltag = lp->tag; if(rp && opcode!=OPCALL && opcode!=OPCCALL) { rtype = rp->headblock.vtype; if (rtype == TYUNKNOWN) { rp = fixtype(rp); rtype = rp->headblock.vtype; } rtag = rp->tag; } else rtype = 0; etype = cktype(opcode, ltype, rtype); if(etype == TYERROR) goto error; switch(opcode) { /* check for multiplication by 0 and 1 and addition to 0 */ case OPSTAR: if( ISCONST(lp) ) COMMUTE if( ISICON(rp) ) { if(rp->constblock.Const.ci == 0) goto retright; goto mulop; } break; case OPSLASH: case OPMOD: if( zeroconst(rp) && lineno != divlineno ) { warn("attempted division by zero"); divlineno = lineno; } if(opcode == OPMOD) break; /* Handle multiplying or dividing by 1, -1 */ mulop: if( ISICON(rp) ) { if(rp->constblock.Const.ci == 1) goto retleft; if(rp->constblock.Const.ci == -1) { frexpr(rp); return( mkexpr(OPNEG, lp, ENULL) ); } } /* Group all constants together. In particular, (x * CONST1) * CONST2 ==> x * (CONST1 * CONST2) (x * CONST1) / CONST2 ==> x * (CONST1 / CONST2) */ if (!ISINT(etype) || lp->tag != TEXPR || !lp->exprblock.rightp || !ISICON(lp->exprblock.rightp)) break; if (lp->exprblock.opcode == OPLSHIFT) { L = 1 << lp->exprblock.rightp->constblock.Const.ci; if (opcode == OPSTAR || ISICON(rp) && !(L % rp->constblock.Const.ci)) { lp->exprblock.opcode = OPSTAR; lp->exprblock.rightp->constblock.Const.ci = L; } } if (lp->exprblock.opcode == OPSTAR) { if(opcode == OPSTAR) e = mkexpr(OPSTAR, lp->exprblock.rightp, rp); else if(ISICON(rp) && (lp->exprblock.rightp->constblock.Const.ci % rp->constblock.Const.ci) == 0) e = mkexpr(OPSLASH, lp->exprblock.rightp, rp); else break; e1 = lp->exprblock.leftp; free( (charptr) lp ); return( mkexpr(OPSTAR, e1, e) ); } break; case OPPLUS: if( ISCONST(lp) ) COMMUTE goto addop; case OPMINUS: if( ICONEQ(lp, 0) ) { frexpr(lp); return( mkexpr(OPNEG, rp, ENULL) ); } if( ISCONST(rp) && is_negatable((Constp)rp)) { opcode = OPPLUS; consnegop((Constp)rp); } /* Group constants in an addition expression (also subtraction, since the subtracted value was negated above). In particular, (x + CONST1) + CONST2 ==> x + (CONST1 + CONST2) */ addop: if( ISICON(rp) ) { if(rp->constblock.Const.ci == 0) goto retleft; if( ISPLUSOP(lp) && ISICON(lp->exprblock.rightp) ) { e = mkexpr(OPPLUS, lp->exprblock.rightp, rp); e1 = lp->exprblock.leftp; free( (charptr) lp ); return( mkexpr(OPPLUS, e1, e) ); } } if (opcode == OPMINUS && (ISINT(etype) || doing_vleng)) { /* check for (i [+const]) - (i [+const]) */ if (lp->tag == TPRIM) e = lp; else if (lp->tag == TEXPR && lp->exprblock.opcode == OPPLUS && lp->exprblock.rightp->tag == TCONST) { e = lp->exprblock.leftp; if (e->tag != TPRIM) break; } else break; if (e->primblock.argsp) break; if (rp->tag == TPRIM) e1 = rp; else if (rp->tag == TEXPR && rp->exprblock.opcode == OPPLUS && rp->exprblock.rightp->tag == TCONST) { e1 = rp->exprblock.leftp; if (e1->tag != TPRIM) break; } else break; if (e->primblock.namep != e1->primblock.namep || e1->primblock.argsp) break; L = e == lp ? 0 : lp->exprblock.rightp->constblock.Const.ci; if (e1 != rp) L -= rp->exprblock.rightp->constblock.Const.ci; frexpr(lp); frexpr(rp); return ICON(L); } break; case OPPOWER: break; /* Eliminate outermost double negations */ case OPNEG: case OPNEG1: if(ltag==TEXPR && lp->exprblock.opcode==OPNEG) { e = lp->exprblock.leftp; free( (charptr) lp ); return(e); } break; /* Eliminate outermost double NOTs */ case OPNOT: if(ltag==TEXPR && lp->exprblock.opcode==OPNOT) { e = lp->exprblock.leftp; free( (charptr) lp ); return(e); } break; case OPCALL: case OPCCALL: etype = ltype; if(rp!=NULL && rp->listblock.listp==NULL) { free( (charptr) rp ); rp = NULL; } break; case OPAND: case OPOR: if( ISCONST(lp) ) COMMUTE if( ISCONST(rp) ) { if(rp->constblock.Const.ci == 0) if(opcode == OPOR) goto retleft; else goto retright; else if(opcode == OPOR) goto retright; else goto retleft; } case OPEQV: case OPNEQV: case OPBITAND: case OPBITOR: case OPBITXOR: case OPBITNOT: case OPLSHIFT: case OPRSHIFT: case OPBITTEST: case OPBITCLR: case OPBITSET: #ifdef TYQUAD case OPQBITCLR: case OPQBITSET: #endif case OPLT: case OPGT: case OPLE: case OPGE: case OPEQ: case OPNE: case OPCONCAT: break; case OPMIN: case OPMAX: case OPMIN2: case OPMAX2: case OPDMIN: case OPDMAX: case OPASSIGN: case OPASSIGNI: case OPPLUSEQ: case OPSTAREQ: case OPMINUSEQ: case OPSLASHEQ: case OPMODEQ: case OPLSHIFTEQ: case OPRSHIFTEQ: case OPBITANDEQ: case OPBITXOREQ: case OPBITOREQ: case OPCONV: case OPADDR: case OPWHATSIN: case OPCOMMA: case OPCOMMA_ARG: case OPQUEST: case OPCOLON: case OPDOT: case OPARROW: case OPIDENTITY: case OPCHARCAST: case OPABS: case OPDABS: break; default: badop("mkexpr", opcode); } no_fold: e = (expptr) ALLOC(Exprblock); e->exprblock.tag = TEXPR; e->exprblock.opcode = opcode; e->exprblock.vtype = etype; e->exprblock.leftp = lp; e->exprblock.rightp = rp; if(ltag==TCONST && (rp==0 || rtag==TCONST) ) e = fold(e); return(e); retleft: frexpr(rp); if (lp->tag == TPRIM) paren_used(&lp->primblock); return(lp); retright: frexpr(lp); if (rp->tag == TPRIM) paren_used(&rp->primblock); return(rp); error: frexpr(lp); if(rp && opcode!=OPCALL && opcode!=OPCCALL) frexpr(rp); return( errnode() ); } #define ERR(s) { errs = s; goto error; } /* cktype -- Check and return the type of the expression */ int #ifdef KR_headers cktype(op, lt, rt) int op; int lt; int rt; #else cktype(int op, int lt, int rt) #endif { char *errs; if(lt==TYERROR || rt==TYERROR) goto error1; if(lt==TYUNKNOWN) return(TYUNKNOWN); if(rt==TYUNKNOWN) /* If not unary operation, return UNKNOWN */ if(!is_unary_op (op) && op != OPCALL && op != OPCCALL) return(TYUNKNOWN); switch(op) { case OPPLUS: case OPMINUS: case OPSTAR: case OPSLASH: case OPPOWER: case OPMOD: if( ISNUMERIC(lt) && ISNUMERIC(rt) ) return( maxtype(lt, rt) ); ERR("nonarithmetic operand of arithmetic operator") case OPNEG: case OPNEG1: if( ISNUMERIC(lt) ) return(lt); ERR("nonarithmetic operand of negation") case OPNOT: if(ISLOGICAL(lt)) return(lt); ERR("NOT of nonlogical") case OPAND: case OPOR: case OPEQV: case OPNEQV: if(ISLOGICAL(lt) && ISLOGICAL(rt)) return( maxtype(lt, rt) ); ERR("nonlogical operand of logical operator") case OPLT: case OPGT: case OPLE: case OPGE: case OPEQ: case OPNE: if(lt==TYCHAR || rt==TYCHAR || ISLOGICAL(lt) || ISLOGICAL(rt)) { if(lt != rt){ if (htype && (lt == TYCHAR && ISNUMERIC(rt) || rt == TYCHAR && ISNUMERIC(lt))) return TYLOGICAL; ERR("illegal comparison") } } else if( ISCOMPLEX(lt) || ISCOMPLEX(rt) ) { if(op!=OPEQ && op!=OPNE) ERR("order comparison of complex data") } else if( ! ISNUMERIC(lt) || ! ISNUMERIC(rt) ) ERR("comparison of nonarithmetic data") case OPBITTEST: return(TYLOGICAL); case OPCONCAT: if(lt==TYCHAR && rt==TYCHAR) return(TYCHAR); ERR("concatenation of nonchar data") case OPCALL: case OPCCALL: case OPIDENTITY: return(lt); case OPADDR: case OPCHARCAST: return(TYADDR); case OPCONV: if(rt == 0) return(0); if(lt==TYCHAR && ISINT(rt) ) return(TYCHAR); if (ISLOGICAL(lt) && ISLOGICAL(rt) || ISINT(lt) && rt == TYCHAR) return lt; case OPASSIGN: case OPASSIGNI: case OPMINUSEQ: case OPPLUSEQ: case OPSTAREQ: case OPSLASHEQ: case OPMODEQ: case OPLSHIFTEQ: case OPRSHIFTEQ: case OPBITANDEQ: case OPBITXOREQ: case OPBITOREQ: if (ISLOGICAL(lt) && ISLOGICAL(rt) && op == OPASSIGN) return lt; if(lt==TYCHAR || rt==TYCHAR || ISLOGICAL(lt) || ISLOGICAL(rt)) if((op!=OPASSIGN && op != OPPLUSEQ && op != OPMINUSEQ) || (lt!=rt)) { ERR("impossible conversion") } return(lt); case OPMIN: case OPMAX: case OPDMIN: case OPDMAX: case OPMIN2: case OPMAX2: case OPBITOR: case OPBITAND: case OPBITXOR: case OPBITNOT: case OPLSHIFT: case OPRSHIFT: case OPWHATSIN: case OPABS: case OPDABS: return(lt); case OPBITCLR: case OPBITSET: #ifdef TYQUAD0 case OPQBITCLR: case OPQBITSET: #endif if (lt < TYLONG) lt = TYLONG; return(lt); #ifndef NO_LONG_LONG case OPQBITCLR: case OPQBITSET: return TYQUAD; #endif case OPCOMMA: case OPCOMMA_ARG: case OPQUEST: case OPCOLON: /* Only checks the rightmost type because of C language definition (rightmost comma-expr is the value of the expr) */ return(rt); case OPDOT: case OPARROW: return (lt); default: badop("cktype", op); } error: err(errs); error1: return(TYERROR); } static void intovfl(Void) { err("overflow simplifying integer constants."); } #ifndef NO_LONG_LONG static void #ifdef KR_headers LRget(Lp, Rp, lp, rp) Llong *Lp, *Rp; expptr lp, rp; #else LRget(Llong *Lp, Llong *Rp, expptr lp, expptr rp) #endif { if (lp->headblock.vtype == TYQUAD) *Lp = lp->constblock.Const.cq; else *Lp = lp->constblock.Const.ci; if (rp->headblock.vtype == TYQUAD) *Rp = rp->constblock.Const.cq; else *Rp = rp->constblock.Const.ci; } #endif /*NO_LONG_LONG*/ /* fold -- simplifies constant expressions; it assumes that e -> leftp and e -> rightp are TCONST or NULL */ expptr #ifdef KR_headers fold(e) expptr e; #else fold(expptr e) #endif { Constp p; expptr lp, rp; int etype, mtype, ltype, rtype, opcode; ftnint i, bl, ll, lr; char *q, *s; struct Constblock lcon, rcon; ftnint L; double d; #ifndef NO_LONG_LONG Llong LL, LR; #endif opcode = e->exprblock.opcode; etype = e->exprblock.vtype; lp = e->exprblock.leftp; ltype = lp->headblock.vtype; rp = e->exprblock.rightp; if(rp == 0) switch(opcode) { case OPNOT: #ifndef NO_LONG_LONG if (ltype == TYQUAD) lp->constblock.Const.cq = ! lp->constblock.Const.cq; else #endif lp->constblock.Const.ci = ! lp->constblock.Const.ci; retlp: e->exprblock.leftp = 0; frexpr(e); return(lp); case OPBITNOT: #ifndef NO_LONG_LONG if (ltype == TYQUAD) lp->constblock.Const.cq = ~ lp->constblock.Const.cq; else #endif lp->constblock.Const.ci = ~ lp->constblock.Const.ci; goto retlp; case OPNEG: case OPNEG1: consnegop((Constp)lp); goto retlp; case OPCONV: case OPADDR: return(e); case OPABS: case OPDABS: switch(ltype) { case TYINT1: case TYSHORT: case TYLONG: if ((L = lp->constblock.Const.ci) < 0) { lp->constblock.Const.ci = -L; if (L != -lp->constblock.Const.ci) intovfl(); } goto retlp; #ifndef NO_LONG_LONG case TYQUAD: if ((LL = lp->constblock.Const.cq) < 0) { lp->constblock.Const.cq = -LL; if (LL != -lp->constblock.Const.cq) intovfl(); } goto retlp; #endif case TYREAL: case TYDREAL: if (lp->constblock.vstg) { s = lp->constblock.Const.cds[0]; if (*s == '-') lp->constblock.Const.cds[0] = s + 1; goto retlp; } if ((d = lp->constblock.Const.cd[0]) < 0.) lp->constblock.Const.cd[0] = -d; case TYCOMPLEX: case TYDCOMPLEX: return e; /* lazy way out */ } default: badop("fold", opcode); } rtype = rp->headblock.vtype; p = ALLOC(Constblock); p->tag = TCONST; p->vtype = etype; p->vleng = e->exprblock.vleng; switch(opcode) { case OPCOMMA: case OPCOMMA_ARG: case OPQUEST: case OPCOLON: goto ereturn; case OPAND: p->Const.ci = lp->constblock.Const.ci && rp->constblock.Const.ci; break; case OPOR: p->Const.ci = lp->constblock.Const.ci || rp->constblock.Const.ci; break; case OPEQV: p->Const.ci = lp->constblock.Const.ci == rp->constblock.Const.ci; break; case OPNEQV: p->Const.ci = lp->constblock.Const.ci != rp->constblock.Const.ci; break; case OPBITAND: #ifndef NO_LONG_LONG if (etype == TYQUAD) { LRget(&LL, &LR, lp, rp); p->Const.cq = LL & LR; } else #endif p->Const.ci = lp->constblock.Const.ci & rp->constblock.Const.ci; break; case OPBITOR: #ifndef NO_LONG_LONG if (etype == TYQUAD) { LRget(&LL, &LR, lp, rp); p->Const.cq = LL | LR; } else #endif p->Const.ci = lp->constblock.Const.ci | rp->constblock.Const.ci; break; case OPBITXOR: #ifndef NO_LONG_LONG if (etype == TYQUAD) { LRget(&LL, &LR, lp, rp); p->Const.cq = LL ^ LR; } else #endif p->Const.ci = lp->constblock.Const.ci ^ rp->constblock.Const.ci; break; case OPLSHIFT: #ifndef NO_LONG_LONG if (etype == TYQUAD) { LRget(&LL, &LR, lp, rp); p->Const.cq = LL << (int)LR; if (p->Const.cq >> (int)LR != LL) intovfl(); break; } #endif p->Const.ci = lp->constblock.Const.ci << rp->constblock.Const.ci; if ((((unsigned long)p->Const.ci) >> rp->constblock.Const.ci) != lp->constblock.Const.ci) intovfl(); break; case OPRSHIFT: #ifndef NO_LONG_LONG if (etype == TYQUAD) { LRget(&LL, &LR, lp, rp); p->Const.cq = LL >> (int)LR; } else #endif p->Const.ci = (unsigned long)lp->constblock.Const.ci >> rp->constblock.Const.ci; break; case OPBITTEST: #ifndef NO_LONG_LONG if (ltype == TYQUAD) p->Const.ci = (lp->constblock.Const.cq & 1LL << rp->constblock.Const.ci) != 0; else #endif p->Const.ci = (lp->constblock.Const.ci & 1L << rp->constblock.Const.ci) != 0; break; case OPBITCLR: #ifndef NO_LONG_LONG if (etype == TYQUAD) { LRget(&LL, &LR, lp, rp); p->Const.cq = LL & ~(1LL << (int)LR); } else #endif p->Const.ci = lp->constblock.Const.ci & ~(1L << rp->constblock.Const.ci); break; case OPBITSET: #ifndef NO_LONG_LONG if (etype == TYQUAD) { LRget(&LL, &LR, lp, rp); p->Const.cq = LL | (1LL << (int)LR); } else #endif p->Const.ci = lp->constblock.Const.ci | 1L << rp->constblock.Const.ci; break; case OPCONCAT: ll = lp->constblock.vleng->constblock.Const.ci; lr = rp->constblock.vleng->constblock.Const.ci; bl = lp->constblock.Const.ccp1.blanks; p->Const.ccp = q = (char *) ckalloc(ll+lr+bl); p->Const.ccp1.blanks = rp->constblock.Const.ccp1.blanks; p->vleng = ICON(ll+lr+bl); s = lp->constblock.Const.ccp; for(i = 0 ; i < ll ; ++i) *q++ = *s++; for(i = 0 ; i < bl ; i++) *q++ = ' '; s = rp->constblock.Const.ccp; for(i = 0; i < lr; ++i) *q++ = *s++; break; case OPPOWER: if( !ISINT(rtype) || rp->constblock.Const.ci < 0 && zeroconst(lp)) goto ereturn; conspower(p, (Constp)lp, rp->constblock.Const.ci); break; case OPSLASH: if (zeroconst(rp)) goto ereturn; /* no break */ default: if(ltype == TYCHAR) { lcon.Const.ci = cmpstr(lp->constblock.Const.ccp, rp->constblock.Const.ccp, lp->constblock.vleng->constblock.Const.ci, rp->constblock.vleng->constblock.Const.ci); rcon.Const.ci = 0; mtype = tyint; } else { mtype = maxtype(ltype, rtype); consconv(mtype, &lcon, &lp->constblock); consconv(mtype, &rcon, &rp->constblock); } consbinop(opcode, mtype, p, &lcon, &rcon); break; } frexpr(e); return( (expptr) p ); ereturn: free((char *)p); return e; } /* assign constant l = r , doing coercion */ void #ifdef KR_headers consconv(lt, lc, rc) int lt; Constp lc; Constp rc; #else consconv(int lt, Constp lc, Constp rc) #endif { int rt = rc->vtype; union Constant *lv = &lc->Const, *rv = &rc->Const; lc->vtype = lt; if (ONEOF(lt, MSKREAL|MSKCOMPLEX) && ONEOF(rt, MSKREAL|MSKCOMPLEX)) { memcpy((char *)lv, (char *)rv, sizeof(union Constant)); lc->vstg = rc->vstg; if (ISCOMPLEX(lt) && ISREAL(rt)) { if (rc->vstg) lv->cds[1] = cds("0",CNULL); else lv->cd[1] = 0.; } return; } lc->vstg = 0; switch(lt) { /* Casting to character means just copying the first sizeof (character) bytes into a new 1 character string. This is weird. */ case TYCHAR: *(lv->ccp = (char *) ckalloc(1)) = (char)rv->ci; lv->ccp1.blanks = 0; break; case TYINT1: case TYSHORT: case TYLONG: #ifdef TYQUAD0 case TYQUAD: #endif if(rt == TYCHAR) lv->ci = rv->ccp[0]; else if( ISINT(rt) ) { #ifndef NO_LONG_LONG if (rt == TYQUAD) lv->ci = rv->cq; else #endif lv->ci = rv->ci; } else lv->ci = (ftnint)(rc->vstg ? atof(rv->cds[0]) : rv->cd[0]); break; #ifndef NO_LONG_LONG case TYQUAD: if(rt == TYCHAR) lv->cq = rv->ccp[0]; else if( ISINT(rt) ) { if (rt == TYQUAD) lv->cq = rv->cq; else lv->cq = rv->ci; } else lv->cq = (ftnint)(rc->vstg ? atof(rv->cds[0]) : rv->cd[0]); break; #endif case TYCOMPLEX: case TYDCOMPLEX: lv->cd[1] = 0.; case TYREAL: case TYDREAL: #ifndef NO_LONG_LONG if (rt == TYQUAD) lv->cd[0] = rv->cq; else #endif lv->cd[0] = rv->ci; break; case TYLOGICAL: case TYLOGICAL1: case TYLOGICAL2: lv->ci = rv->ci; break; } } /* Negate constant value -- changes the input node's value */ void #ifdef KR_headers consnegop(p) Constp p; #else consnegop(Constp p) #endif { char *s; ftnint L; #ifndef NO_LONG_LONG Llong LL; #endif if (p->vstg) { /* 20010820: comment out "*s == '0' ? s :" to preserve */ /* the sign of zero */ if (ISCOMPLEX(p->vtype)) { s = p->Const.cds[1]; p->Const.cds[1] = *s == '-' ? s+1 : /* *s == '0' ? s : */ s-1; } s = p->Const.cds[0]; p->Const.cds[0] = *s == '-' ? s+1 : /* *s == '0' ? s : */ s-1; return; } switch(p->vtype) { case TYINT1: case TYSHORT: case TYLONG: #ifdef TYQUAD0 case TYQUAD: #endif p->Const.ci = -(L = p->Const.ci); if (L != -p->Const.ci) intovfl(); break; #ifndef NO_LONG_LONG case TYQUAD: p->Const.cq = -(LL = p->Const.cq); if (LL != -p->Const.cq) intovfl(); break; #endif case TYCOMPLEX: case TYDCOMPLEX: p->Const.cd[1] = - p->Const.cd[1]; /* fall through and do the real parts */ case TYREAL: case TYDREAL: p->Const.cd[0] = - p->Const.cd[0]; break; default: badtype("consnegop", p->vtype); } } /* conspower -- Expand out an exponentiation */ LOCAL void #ifdef KR_headers conspower(p, ap, n) Constp p; Constp ap; ftnint n; #else conspower(Constp p, Constp ap, ftnint n) #endif { union Constant *powp = &p->Const; int type; struct Constblock x, x0; if (n == 1) { memcpy((char *)powp, (char *)&ap->Const, sizeof(ap->Const)); return; } switch(type = ap->vtype) /* pow = 1 */ { case TYINT1: case TYSHORT: case TYLONG: #ifdef TYQUAD0 case TYQUAD: #endif powp->ci = 1; break; #ifndef NO_LONG_LONG case TYQUAD: powp->cq = 1; break; #endif case TYCOMPLEX: case TYDCOMPLEX: powp->cd[1] = 0; case TYREAL: case TYDREAL: powp->cd[0] = 1; break; default: badtype("conspower", type); } if(n == 0) return; switch(type) /* x0 = ap */ { case TYINT1: case TYSHORT: case TYLONG: #ifdef TYQUAD0 case TYQUAD: #endif x0.Const.ci = ap->Const.ci; break; #ifndef NO_LONG_LONG case TYQUAD: x0.Const.cq = ap->Const.cq; break; #endif case TYCOMPLEX: case TYDCOMPLEX: x0.Const.cd[1] = ap->vstg ? atof(ap->Const.cds[1]) : ap->Const.cd[1]; case TYREAL: case TYDREAL: x0.Const.cd[0] = ap->vstg ? atof(ap->Const.cds[0]) : ap->Const.cd[0]; break; } x0.vtype = type; x0.vstg = 0; if(n < 0) { n = -n; if( ISINT(type) ) { switch(ap->Const.ci) { case 0: err("0 ** negative number"); return; case 1: case -1: goto mult; } err("integer ** negative number"); return; } else if (!x0.Const.cd[0] && (!ISCOMPLEX(type) || !x0.Const.cd[1])) { err("0.0 ** negative number"); return; } consbinop(OPSLASH, type, &x, p, &x0); } else mult: consbinop(OPSTAR, type, &x, p, &x0); for( ; ; ) { if(n & 01) consbinop(OPSTAR, type, p, p, &x); if(n >>= 1) consbinop(OPSTAR, type, &x, &x, &x); else break; } } /* do constant operation cp = a op b -- assumes that ap and bp have data matching the input type */ LOCAL void #ifdef KR_headers consbinop(opcode, type, cpp, app, bpp) int opcode; int type; Constp cpp; Constp app; Constp bpp; #else consbinop(int opcode, int type, Constp cpp, Constp app, Constp bpp) #endif { union Constant *ap = &app->Const, *bp = &bpp->Const, *cp = &cpp->Const; ftnint k; double ad[2], bd[2], temp; ftnint a, b; #ifndef NO_LONG_LONG Llong aL, bL; #endif cpp->vstg = 0; if (ONEOF(type, MSKREAL|MSKCOMPLEX)) { ad[0] = app->vstg ? atof(ap->cds[0]) : ap->cd[0]; bd[0] = bpp->vstg ? atof(bp->cds[0]) : bp->cd[0]; if (ISCOMPLEX(type)) { ad[1] = app->vstg ? atof(ap->cds[1]) : ap->cd[1]; bd[1] = bpp->vstg ? atof(bp->cds[1]) : bp->cd[1]; } } switch(opcode) { case OPPLUS: switch(type) { case TYINT1: case TYSHORT: case TYLONG: #ifdef TYQUAD0 case TYQUAD: #endif cp->ci = ap->ci + bp->ci; if (ap->ci != cp->ci - bp->ci) intovfl(); break; #ifndef NO_LONG_LONG case TYQUAD: cp->cq = ap->cq + bp->cq; if (ap->cq != cp->cq - bp->cq) intovfl(); break; #endif case TYCOMPLEX: case TYDCOMPLEX: cp->cd[1] = ad[1] + bd[1]; case TYREAL: case TYDREAL: cp->cd[0] = ad[0] + bd[0]; break; } break; case OPMINUS: switch(type) { case TYINT1: case TYSHORT: case TYLONG: #ifdef TYQUAD0 case TYQUAD: #endif cp->ci = ap->ci - bp->ci; if (ap->ci != bp->ci + cp->ci) intovfl(); break; #ifndef NO_LONG_LONG case TYQUAD: cp->cq = ap->cq - bp->cq; if (ap->cq != bp->cq + cp->cq) intovfl(); break; #endif case TYCOMPLEX: case TYDCOMPLEX: cp->cd[1] = ad[1] - bd[1]; case TYREAL: case TYDREAL: cp->cd[0] = ad[0] - bd[0]; break; } break; case OPSTAR: switch(type) { case TYINT1: case TYSHORT: case TYLONG: #ifdef TYQUAD0 case TYQUAD: #endif cp->ci = (a = ap->ci) * (b = bp->ci); if (a && cp->ci / a != b) intovfl(); break; #ifndef NO_LONG_LONG case TYQUAD: cp->cq = (aL = ap->cq) * (bL = bp->cq); if (aL && cp->cq / aL != bL) intovfl(); break; #endif case TYREAL: case TYDREAL: cp->cd[0] = ad[0] * bd[0]; break; case TYCOMPLEX: case TYDCOMPLEX: temp = ad[0] * bd[0] - ad[1] * bd[1] ; cp->cd[1] = ad[0] * bd[1] + ad[1] * bd[0] ; cp->cd[0] = temp; break; } break; case OPSLASH: switch(type) { case TYINT1: case TYSHORT: case TYLONG: #ifdef TYQUAD0 case TYQUAD: #endif cp->ci = ap->ci / bp->ci; break; #ifndef NO_LONG_LONG case TYQUAD: cp->cq = ap->cq / bp->cq; break; #endif case TYREAL: case TYDREAL: cp->cd[0] = ad[0] / bd[0]; break; case TYCOMPLEX: case TYDCOMPLEX: zdiv((dcomplex*)cp, (dcomplex*)ad, (dcomplex*)bd); break; } break; case OPMOD: if( ISINT(type) ) { #ifndef NO_LONG_LONG if (type == TYQUAD) cp->cq = ap->cq % bp->cq; else #endif cp->ci = ap->ci % bp->ci; break; } else Fatal("inline mod of noninteger"); case OPMIN2: case OPDMIN: switch(type) { case TYINT1: case TYSHORT: case TYLONG: #ifdef TYQUAD0 case TYQUAD: #endif cp->ci = ap->ci <= bp->ci ? ap->ci : bp->ci; break; #ifndef NO_LONG_LONG case TYQUAD: cp->cq = ap->cq <= bp->cq ? ap->cq : bp->cq; break; #endif case TYREAL: case TYDREAL: cp->cd[0] = ad[0] <= bd[0] ? ad[0] : bd[0]; break; default: Fatal("inline min of exected type"); } break; case OPMAX2: case OPDMAX: switch(type) { case TYINT1: case TYSHORT: case TYLONG: #ifdef TYQUAD0 case TYQUAD: #endif cp->ci = ap->ci >= bp->ci ? ap->ci : bp->ci; break; #ifndef NO_LONG_LONG case TYQUAD: cp->cq = ap->cq >= bp->cq ? ap->cq : bp->cq; break; #endif case TYREAL: case TYDREAL: cp->cd[0] = ad[0] >= bd[0] ? ad[0] : bd[0]; break; default: Fatal("inline max of exected type"); } break; default: /* relational ops */ switch(type) { case TYINT1: case TYSHORT: case TYLONG: #ifdef TYQUAD0 case TYQUAD: #endif if(ap->ci < bp->ci) k = -1; else if(ap->ci == bp->ci) k = 0; else k = 1; break; #ifndef NO_LONG_LONG case TYQUAD: if(ap->cq < bp->cq) k = -1; else if(ap->cq == bp->cq) k = 0; else k = 1; break; #endif case TYREAL: case TYDREAL: if(ad[0] < bd[0]) k = -1; else if(ad[0] == bd[0]) k = 0; else k = 1; break; case TYCOMPLEX: case TYDCOMPLEX: if(ad[0] == bd[0] && ad[1] == bd[1] ) k = 0; else k = 1; break; case TYLOGICAL: k = ap->ci - bp->ci; } switch(opcode) { case OPEQ: cp->ci = (k == 0); break; case OPNE: cp->ci = (k != 0); break; case OPGT: cp->ci = (k == 1); break; case OPLT: cp->ci = (k == -1); break; case OPGE: cp->ci = (k >= 0); break; case OPLE: cp->ci = (k <= 0); break; } break; } } /* conssgn - returns the sign of a Fortran constant */ int #ifdef KR_headers conssgn(p) expptr p; #else conssgn(expptr p) #endif { char *s; if( ! ISCONST(p) ) Fatal( "sgn(nonconstant)" ); switch(p->headblock.vtype) { case TYINT1: case TYSHORT: case TYLONG: #ifdef TYQUAD0 case TYQUAD: #endif if(p->constblock.Const.ci > 0) return(1); if(p->constblock.Const.ci < 0) return(-1); return(0); #ifndef NO_LONG_LONG case TYQUAD: if(p->constblock.Const.cq > 0) return(1); if(p->constblock.Const.cq < 0) return(-1); return(0); #endif case TYREAL: case TYDREAL: if (p->constblock.vstg) { s = p->constblock.Const.cds[0]; if (*s == '-') return -1; if (*s == '0') return 0; return 1; } if(p->constblock.Const.cd[0] > 0) return(1); if(p->constblock.Const.cd[0] < 0) return(-1); return(0); /* The sign of a complex number is 0 iff the number is 0 + 0i, else it's 1 */ case TYCOMPLEX: case TYDCOMPLEX: if (p->constblock.vstg) return *p->constblock.Const.cds[0] != '0' && *p->constblock.Const.cds[1] != '0'; return(p->constblock.Const.cd[0]!=0 || p->constblock.Const.cd[1]!=0); default: badtype( "conssgn", p->constblock.vtype); } /* NOT REACHED */ return 0; } char *powint[ ] = { "pow_ii", #ifdef TYQUAD "pow_qq", #endif "pow_ri", "pow_di", "pow_ci", "pow_zi" }; LOCAL expptr #ifdef KR_headers mkpower(p) expptr p; #else mkpower(expptr p) #endif { expptr q, lp, rp; int ltype, rtype, mtype, tyi; lp = p->exprblock.leftp; rp = p->exprblock.rightp; ltype = lp->headblock.vtype; rtype = rp->headblock.vtype; if (lp->tag == TADDR) lp->addrblock.parenused = 0; if (rp->tag == TADDR) rp->addrblock.parenused = 0; if(ISICON(rp)) { if(rp->constblock.Const.ci == 0) { frexpr(p); if( ISINT(ltype) ) return( ICON(1) ); else if (ISREAL (ltype)) return mkconv (ltype, ICON (1)); else return( (expptr) putconst((Constp) mkconv(ltype, ICON(1))) ); } if(rp->constblock.Const.ci < 0) { if( ISINT(ltype) ) { frexpr(p); err("integer**negative"); return( errnode() ); } rp->constblock.Const.ci = - rp->constblock.Const.ci; p->exprblock.leftp = lp = fixexpr((Exprp)mkexpr(OPSLASH, ICON(1), lp)); } if(rp->constblock.Const.ci == 1) { frexpr(rp); free( (charptr) p ); return(lp); } if( ONEOF(ltype, MSKINT|MSKREAL) ) { p->exprblock.vtype = ltype; return(p); } } if( ISINT(rtype) ) { if(ltype==TYSHORT && rtype==TYSHORT && (!ISCONST(lp) || tyint==TYSHORT) ) q = call2(TYSHORT, "pow_hh", lp, rp); else { if(ONEOF(ltype,M(TYINT1)|M(TYSHORT))) { ltype = TYLONG; lp = mkconv(TYLONG,lp); } #ifdef TYQUAD if (ltype == TYQUAD) rp = mkconv(TYQUAD,rp); else #endif rp = mkconv(TYLONG,rp); if (ISCONST(rp)) { tyi = tyint; tyint = TYLONG; rp = (expptr)putconst((Constp)rp); tyint = tyi; } q = call2(ltype, powint[ltype-TYLONG], lp, rp); } } else if( ISREAL( (mtype = maxtype(ltype,rtype)) )) { extern int callk_kludge; callk_kludge = TYDREAL; q = call2(mtype, "pow_dd", mkconv(TYDREAL,lp), mkconv(TYDREAL,rp)); callk_kludge = 0; } else { q = call2(TYDCOMPLEX, "pow_zz", mkconv(TYDCOMPLEX,lp), mkconv(TYDCOMPLEX,rp)); if(mtype == TYCOMPLEX) q = mkconv(TYCOMPLEX, q); } free( (charptr) p ); return(q); } /* Complex Division. Same code as in Runtime Library */ LOCAL void #ifdef KR_headers zdiv(c, a, b) dcomplex *c; dcomplex *a; dcomplex *b; #else zdiv(dcomplex *c, dcomplex *a, dcomplex *b) #endif { double ratio, den; double abr, abi; if( (abr = b->dreal) < 0.) abr = - abr; if( (abi = b->dimag) < 0.) abi = - abi; if( abr <= abi ) { if(abi == 0) Fatal("complex division by zero"); ratio = b->dreal / b->dimag ; den = b->dimag * (1 + ratio*ratio); c->dreal = (a->dreal*ratio + a->dimag) / den; c->dimag = (a->dimag*ratio - a->dreal) / den; } else { ratio = b->dimag / b->dreal ; den = b->dreal * (1 + ratio*ratio); c->dreal = (a->dreal + a->dimag*ratio) / den; c->dimag = (a->dimag - a->dreal*ratio) / den; } } void #ifdef KR_headers sserr(np) Namep np; #else sserr(Namep np) #endif { errstr(np->vtype == TYCHAR ? "substring of character array %.70s" : "substring of noncharacter %.73s", np->fvarname); } f2c/src/f2c.1000066400000000000000000000165541171647030000130650ustar00rootroot00000000000000 F2C(1) UNIX System V F2C(1) NAME f2c - Convert Fortran 77 to C or C++ SYNOPSIS f2c [ option ... ] file ... DESCRIPTION F2c converts Fortran 77 source code in files with names end- ing in `.f' or `.F' to C (or C++) source files in the cur- rent directory, with `.c' substituted for the final `.f' or `.F'. If no Fortran files are named, f2c reads Fortran from standard input and writes C on standard output. File names that end with `.p' or `.P' are taken to be prototype files, as produced by option `-P', and are read first. The following options have the same meaning as in f77(1). -C Compile code to check that subscripts are within declared array bounds. -I2 Render INTEGER and LOGICAL as short, INTEGER*4 as long int. Assume the default libF77 and libI77: allow only INTEGER*4 (and no LOGICAL) variables in INQUIREs. Option `-I4' confirms the default rendering of INTEGER as long int. -Idir Look for a non-absolute include file first in the directory of the current input file, then in directo- ries specified by -I options (one directory per option). Options -I2 and -I4 have precedence, so, e.g., a directory named 2 should be specified by -I./2 . -onetrip Compile DO loops that are performed at least once if reached. (Fortran 77 DO loops are not performed at all if the upper limit is smaller than the lower limit.) -U Honor the case of variable and external names. Fortran keywords must be in lower case. -u Make the default type of a variable `undefined' rather than using the default Fortran rules. -w Suppress all warning messages, or, if the option is `-w66', just Fortran 66 compatibility warnings. The following options are peculiar to f2c. -A Produce ANSI C (default, starting 20020621). For old- style C, use option -K. Page 1 (printed 6/21/02) F2C(1) UNIX System V F2C(1) -a Make local variables automatic rather than static unless they appear in a DATA, EQUIVALENCE, NAMELIST, or SAVE statement. -C++ Output C++ code. -c Include original Fortran source as comments. -cd Do not recognize cdabs, cdcos, cdexp, cdlog, cdsin, and cdsqrt as synonyms for the double complex intrinsics zabs, zcos, zexp, zlog, zsin, and zsqrt, respectively, nor dreal as a synonym for dble. -ddir Write `.c' files in directory dir instead of the cur- rent directory. -E Declare uninitialized COMMON to be Extern (overridably defined in f2c.h as extern). -ec Place uninitialized COMMON blocks in separate files: COMMON /ABC/ appears in file abc_com.c. Option `-e1c' bundles the separate files into the output file, with comments that give an unbundling sed(1) script. -ext Complain about f77(1) extensions. -f Assume free-format input: accept text after column 72 and do not pad fixed-format lines shorter than 72 char- acters with blanks. -72 Treat text appearing after column 72 as an error. -g Include original Fortran line numbers in #line lines. -h Emulate Fortran 66's treatment of Hollerith: try to align character strings on word (or, if the option is `-hd', on double-word) boundaries. -i2 Similar to -I2, but assume a modified libF77 and libI77 (compiled with -Df2c_i2), so INTEGER and LOGICAL vari- ables may be assigned by INQUIRE and array lengths are stored in short ints. -i90 Do not recognize the Fortran 90 bit-manipulation intrinsics btest, iand, ibclr, ibits, ibset, ieor, ior, ishft, and ishftc. -kr Use temporary values to enforce Fortran expression evaluation where K&R (first edition) parenthesization rules allow rearrangement. If the option is `-krd', use double precision temporaries even for single- Page 2 (printed 6/21/02) F2C(1) UNIX System V F2C(1) precision operands. -P Write a file.P of ANSI (or C++) prototypes for defini- tions in each input file.f or file.F. When reading Fortran from standard input, write prototypes at the beginning of standard output. Option -Ps implies -P and gives exit status 4 if rerunning f2c may change prototypes or declarations. -p Supply preprocessor definitions to make common-block members look like local variables. -R Do not promote REAL functions and operations to DOUBLE PRECISION. Option `-!R' confirms the default, which imitates f77. -r Cast REAL arguments of intrinsic functions and values of REAL functions (including intrinsics) to REAL. -r8 Promote REAL to DOUBLE PRECISION, COMPLEX to DOUBLE COMPLEX. -s Preserve multidimensional subscripts. Suppressed by option `-C' . -Tdir Put temporary files in directory dir. -trapuv Dynamically initialize local variables, except those appearing in SAVE or DATA statements, with values that may help find references to uninitialized variables. For example, with IEEE arithmetic, initialize local floating-point variables to signaling NaNs. -w8 Suppress warnings when COMMON or EQUIVALENCE forces odd-word alignment of doubles. -Wn Assume n characters/word (default 4) when initializing numeric variables with character data. -z Do not implicitly recognize DOUBLE COMPLEX. -!bs Do not recognize backslash escapes (\", \', \0, \\, \b, \f, \n, \r, \t, \v) in character strings. -!c Inhibit C output, but produce -P output. -!I Reject include statements. -!i8 Disallow INTEGER*8 , or, if the option is `-!i8const', permit INTEGER*8 but do not promote integer constants Page 3 (printed 6/21/02) F2C(1) UNIX System V F2C(1) to INTEGER*8 when they involve more than 32 bits. -!it Don't infer types of untyped EXTERNAL procedures from use as parameters to previously defined or prototyped procedures. -!P Do not attempt to infer ANSI or C++ prototypes from usage. The resulting C invokes the support routines of f77; object code should be loaded by f77 or with ld(1) or cc(1) options -lF77 -lI77 -lm. Calling conventions are those of f77: see the reference below. FILES file.[fF] input file *.c output file /usr/include/f2c.h header file /usr/lib/libF77.aintrinsic function library /usr/lib/libI77.aFortran I/O library /lib/libc.a C library, see section 3 SEE ALSO S. I. Feldman and P. J. Weinberger, `A Portable Fortran 77 Compiler', UNIX Time Sharing System Programmer's Manual, Tenth Edition, Volume 2, AT&T Bell Laboratories, 1990. DIAGNOSTICS The diagnostics produced by f2c are intended to be self- explanatory. BUGS Floating-point constant expressions are simplified in the floating-point arithmetic of the machine running f2c, so they are typically accurate to at most 16 or 17 decimal places. Untypable EXTERNAL functions are declared int. There is no notation for INTEGER*8 constants. Some intrinsic functions do not yet work with INTEGER*8 . Page 4 (printed 6/21/02) f2c/src/f2c.1t000066400000000000000000000166261171647030000132510ustar00rootroot00000000000000. \" Definitions of F, L and LR for the benefit of systems . \" whose -man lacks them... .de F .nh .if n \%\&\\$1 .if t \%\&\f(CW\\$1\fR .hy 14 .. .de L .nh .if n \%`\\$1' .if t \%\&\f(CW\\$1\fR .hy 14 .. .de LR .nh .if n \%`\\$1'\\$2 .if t \%\&\f(CW\\$1\fR\\$2 .hy 14 .. .TH F2C 1 .CT 1 prog_other .SH NAME f2c \- Convert Fortran 77 to C or C++ . \" f\^2c changed to f2c in the previous line for the benefit of . \" people on systems (e.g. Sun systems) whose makewhatis cannot . \" cope with troff formatting commands. .SH SYNOPSIS .B f\^2c [ .I option ... ] .I file ... .SH DESCRIPTION .I F2c converts Fortran 77 source code in .I files with names ending in .L .f or .L .F to C (or C++) source files in the current directory, with .L .c substituted for the final .L .f or .LR .F . If no Fortran files are named, .I f\^2c reads Fortran from standard input and writes C on standard output. .I File names that end with .L .p or .L .P are taken to be prototype files, as produced by option .LR -P , and are read first. .PP The following options have the same meaning as in .IR f\^77 (1). .TP .B -C Compile code to check that subscripts are within declared array bounds. .TP .B -I2 Render INTEGER and LOGICAL as short, INTEGER\(**4 as long int. Assume the default \fIlibF77\fR and \fIlibI77\fR: allow only INTEGER\(**4 (and no LOGICAL) variables in INQUIREs. Option .L -I4 confirms the default rendering of INTEGER as long int. .TP .BI -I dir Look for a non-absolute include file first in the directory of the current input file, then in directories specified by \f(CW-I\fP options (one directory per option). Options \f(CW-I2\fP and \f(CW-I4\fP have precedence, so, e.g., a directory named \f(CW2\fP should be specified by \f(CW-I./2\fP . .TP .B -onetrip Compile DO loops that are performed at least once if reached. (Fortran 77 DO loops are not performed at all if the upper limit is smaller than the lower limit.) .TP .B -U Honor the case of variable and external names. Fortran keywords must be in .I lower case. .TP .B -u Make the default type of a variable `undefined' rather than using the default Fortran rules. .TP .B -w Suppress all warning messages, or, if the option is .LR -w66 , just Fortran 66 compatibility warnings. .PP The following options are peculiar to .IR f\^2c . .TP .B -A Produce .SM ANSI C (default, starting 20020621). For old-style C, use option \f(CW-K\fP. .TP .B -a Make local variables automatic rather than static unless they appear in a .SM "DATA, EQUIVALENCE, NAMELIST," or .SM SAVE statement. .TP .B -C++ Output C++ code. .TP .B -c Include original Fortran source as comments. .TP .B -cd Do not recognize cdabs, cdcos, cdexp, cdlog, cdsin, and cdsqrt as synonyms for the double complex intrinsics zabs, zcos, zexp, zlog, zsin, and zsqrt, respectively, nor dreal as a synonym for dble. .TP .BI -d dir Write .L .c files in directory .I dir instead of the current directory. .TP .B -E Declare uninitialized .SM COMMON to be .B Extern (overridably defined in .F f2c.h as .B extern). .TP .B -ec Place uninitialized .SM COMMON blocks in separate files: .B COMMON /ABC/ appears in file .BR abc_com.c . Option .LR -e1c bundles the separate files into the output file, with comments that give an unbundling .IR sed (1) script. .TP .B -ext Complain about .IR f\^77 (1) extensions. .TP .B -f Assume free-format input: accept text after column 72 and do not pad fixed-format lines shorter than 72 characters with blanks. .TP .B -72 Treat text appearing after column 72 as an error. .TP .B -g Include original Fortran line numbers in \f(CW#line\fR lines. .TP .B -h Emulate Fortran 66's treatment of Hollerith: try to align character strings on word (or, if the option is .LR -hd , on double-word) boundaries. .TP .B -i2 Similar to .BR -I2 , but assume a modified .I libF77 and .I libI77 (compiled with .BR -Df\^2c_i2 ), so .SM INTEGER and .SM LOGICAL variables may be assigned by .SM INQUIRE and array lengths are stored in short ints. .TP .B -i90 Do not recognize the Fortran 90 bit-manipulation intrinsics btest, iand, ibclr, ibits, ibset, ieor, ior, ishft, and ishftc. .TP .B -kr Use temporary values to enforce Fortran expression evaluation where K&R (first edition) parenthesization rules allow rearrangement. If the option is .LR -krd , use double precision temporaries even for single-precision operands. .TP .B -P Write a .IB file .P of ANSI (or C++) prototypes for definitions in each input .IB file .f or .IB file .F . When reading Fortran from standard input, write prototypes at the beginning of standard output. Option .B -Ps implies .B -P and gives exit status 4 if rerunning .I f\^2c may change prototypes or declarations. .TP .B -p Supply preprocessor definitions to make common-block members look like local variables. .TP .B -R Do not promote .SM REAL functions and operations to .SM DOUBLE PRECISION. Option .L -!R confirms the default, which imitates .IR f\^77 . .TP .B -r Cast REAL arguments of intrinsic functions and values of REAL functions (including intrinsics) to REAL. .TP .B -r8 Promote .SM REAL to .SM DOUBLE PRECISION, COMPLEX to .SM DOUBLE COMPLEX. .TP .B -s Preserve multidimensional subscripts. Suppressed by option .L -C \&. .TP .BI -T dir Put temporary files in directory .I dir. .TP .B -trapuv Dynamically initialize local variables, except those appearing in .SM SAVE or .SM DATA statements, with values that may help find references to uninitialized variables. For example, with IEEE arithmetic, initialize local floating-point variables to signaling NaNs. .TP .B -w8 Suppress warnings when .SM COMMON or .SM EQUIVALENCE forces odd-word alignment of doubles. .TP .BI -W n Assume .I n characters/word (default 4) when initializing numeric variables with character data. .TP .B -z Do not implicitly recognize .SM DOUBLE COMPLEX. .TP .B -!bs Do not recognize \fIb\fRack\fIs\fRlash escapes (\e", \e', \e0, \e\e, \eb, \ef, \en, \er, \et, \ev) in character strings. .TP .B -!c Inhibit C output, but produce .B -P output. .TP .B -!I Reject .B include statements. .TP .B -!i8 Disallow .SM INTEGER*8 , or, if the option is .LR -!i8const , permit .SM INTEGER*8 but do not promote integer constants to .SM INTEGER*8 when they involve more than 32 bits. .TP .B -!it Don't infer types of untyped .SM EXTERNAL procedures from use as parameters to previously defined or prototyped procedures. .TP .B -!P Do not attempt to infer .SM ANSI or C++ prototypes from usage. .PP The resulting C invokes the support routines of .IR f\^77 ; object code should be loaded by .I f\^77 or with .IR ld (1) or .IR cc (1) options .BR "-lF77 -lI77 -lm" . Calling conventions are those of .IR f\&77 : see the reference below. .br .SH FILES .TP .nr )I 1.75i .IB file .[fF] input file .TP .B *.c output file .TP .F /usr/include/f2c.h header file .TP .F /usr/lib/libF77.a intrinsic function library .TP .F /usr/lib/libI77.a Fortran I/O library .TP .F /lib/libc.a C library, see section 3 .SH "SEE ALSO" S. I. Feldman and P. J. Weinberger, `A Portable Fortran 77 Compiler', \fIUNIX Time Sharing System Programmer's Manual\fR, Tenth Edition, Volume 2, AT&T Bell Laboratories, 1990. .SH DIAGNOSTICS The diagnostics produced by .I f\^2c are intended to be self-explanatory. .SH BUGS Floating-point constant expressions are simplified in the floating-point arithmetic of the machine running .IR f\^2c , so they are typically accurate to at most 16 or 17 decimal places. .br Untypable .SM EXTERNAL functions are declared .BR int . .br There is no notation for .SM INTEGER*8 constants. .br Some intrinsic functions do not yet work with .SM INTEGER*8 . f2c/src/f2c.h000066400000000000000000000111201171647030000131340ustar00rootroot00000000000000/* f2c.h -- Standard Fortran to C header file */ /** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ #ifndef F2C_INCLUDE #define F2C_INCLUDE typedef long int integer; typedef unsigned long int uinteger; typedef char *address; typedef short int shortint; typedef float real; typedef double doublereal; typedef struct { real r, i; } complex; typedef struct { doublereal r, i; } doublecomplex; typedef long int logical; typedef short int shortlogical; typedef char logical1; typedef char integer1; #ifdef INTEGER_STAR_8 /* Adjust for integer*8. */ typedef long long longint; /* system-dependent */ typedef unsigned long long ulongint; /* system-dependent */ #define qbit_clear(a,b) ((a) & ~((ulongint)1 << (b))) #define qbit_set(a,b) ((a) | ((ulongint)1 << (b))) #endif #define TRUE_ (1) #define FALSE_ (0) /* Extern is for use with -E */ #ifndef Extern #define Extern extern #endif /* I/O stuff */ #ifdef f2c_i2 /* for -i2 */ typedef short flag; typedef short ftnlen; typedef short ftnint; #else typedef long int flag; typedef long int ftnlen; typedef long int ftnint; #endif /*external read, write*/ typedef struct { flag cierr; ftnint ciunit; flag ciend; char *cifmt; ftnint cirec; } cilist; /*internal read, write*/ typedef struct { flag icierr; char *iciunit; flag iciend; char *icifmt; ftnint icirlen; ftnint icirnum; } icilist; /*open*/ typedef struct { flag oerr; ftnint ounit; char *ofnm; ftnlen ofnmlen; char *osta; char *oacc; char *ofm; ftnint orl; char *oblnk; } olist; /*close*/ typedef struct { flag cerr; ftnint cunit; char *csta; } cllist; /*rewind, backspace, endfile*/ typedef struct { flag aerr; ftnint aunit; } alist; /* inquire */ typedef struct { flag inerr; ftnint inunit; char *infile; ftnlen infilen; ftnint *inex; /*parameters in standard's order*/ ftnint *inopen; ftnint *innum; ftnint *innamed; char *inname; ftnlen innamlen; char *inacc; ftnlen inacclen; char *inseq; ftnlen inseqlen; char *indir; ftnlen indirlen; char *infmt; ftnlen infmtlen; char *inform; ftnint informlen; char *inunf; ftnlen inunflen; ftnint *inrecl; ftnint *innrec; char *inblank; ftnlen inblanklen; } inlist; #define VOID void union Multitype { /* for multiple entry points */ integer1 g; shortint h; integer i; /* longint j; */ real r; doublereal d; complex c; doublecomplex z; }; typedef union Multitype Multitype; /*typedef long int Long;*/ /* No longer used; formerly in Namelist */ struct Vardesc { /* for Namelist */ char *name; char *addr; ftnlen *dims; int type; }; typedef struct Vardesc Vardesc; struct Namelist { char *name; Vardesc **vars; int nvars; }; typedef struct Namelist Namelist; #define abs(x) ((x) >= 0 ? (x) : -(x)) #define dabs(x) (doublereal)abs(x) #define min(a,b) ((a) <= (b) ? (a) : (b)) #define max(a,b) ((a) >= (b) ? (a) : (b)) #define dmin(a,b) (doublereal)min(a,b) #define dmax(a,b) (doublereal)max(a,b) #define bit_test(a,b) ((a) >> (b) & 1) #define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) #define bit_set(a,b) ((a) | ((uinteger)1 << (b))) /* procedure parameter types for -A and -C++ */ #define F2C_proc_par_types 1 #ifdef __cplusplus typedef int /* Unknown procedure type */ (*U_fp)(...); typedef shortint (*J_fp)(...); typedef integer (*I_fp)(...); typedef real (*R_fp)(...); typedef doublereal (*D_fp)(...), (*E_fp)(...); typedef /* Complex */ VOID (*C_fp)(...); typedef /* Double Complex */ VOID (*Z_fp)(...); typedef logical (*L_fp)(...); typedef shortlogical (*K_fp)(...); typedef /* Character */ VOID (*H_fp)(...); typedef /* Subroutine */ int (*S_fp)(...); #else typedef int /* Unknown procedure type */ (*U_fp)(); typedef shortint (*J_fp)(); typedef integer (*I_fp)(); typedef real (*R_fp)(); typedef doublereal (*D_fp)(), (*E_fp)(); typedef /* Complex */ VOID (*C_fp)(); typedef /* Double Complex */ VOID (*Z_fp)(); typedef logical (*L_fp)(); typedef shortlogical (*K_fp)(); typedef /* Character */ VOID (*H_fp)(); typedef /* Subroutine */ int (*S_fp)(); #endif /* E_fp is for real functions when -R is not specified */ typedef VOID C_f; /* complex function */ typedef VOID H_f; /* character function */ typedef VOID Z_f; /* double complex function */ typedef doublereal E_f; /* real function with -R not specified */ /* undef any lower-case symbols that your C compiler predefines, e.g.: */ #ifndef Skip_f2c_Undefs #undef cray #undef gcos #undef mc68010 #undef mc68020 #undef mips #undef pdp11 #undef sgi #undef sparc #undef sun #undef sun2 #undef sun3 #undef sun4 #undef u370 #undef u3b #undef u3b2 #undef u3b5 #undef unix #undef vax #endif #endif f2c/src/format.c000066400000000000000000001645421171647030000137660ustar00rootroot00000000000000/**************************************************************** Copyright 1990-1996, 1999-2001 by AT&T, Lucent Technologies and Bellcore. Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the above copyright notice appear in all copies and that both that the copyright notice and this permission notice and warranty disclaimer appear in supporting documentation, and that the names of AT&T, Bell Laboratories, Lucent or Bellcore or any of their entities not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. AT&T, Lucent and Bellcore disclaim all warranties with regard to this software, including all implied warranties of merchantability and fitness. In no event shall AT&T, Lucent or Bellcore be liable for any special, indirect or consequential damages or any damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortious action, arising out of or in connection with the use or performance of this software. ****************************************************************/ /* Format.c -- this file takes an intermediate file (generated by pass 1 of the translator) and some state information about the contents of that file, and generates C program text. */ #include "defs.h" #include "p1defs.h" #include "format.h" #include "output.h" #include "names.h" #include "iob.h" int c_output_line_length = DEF_C_LINE_LENGTH; int last_was_label; /* Boolean used to generate semicolons when a label terminates a block */ static char this_proc_name[52]; /* Name of the current procedure. This is probably too simplistic to handle multiple entry points */ static tagptr do_format Argdcl((FILEP, FILEP)); static void do_p1_1while Argdcl((FILEP)); static void do_p1_2while Argdcl((FILEP, FILEP)); static tagptr do_p1_addr Argdcl((FILEP, FILEP)); static void do_p1_asgoto Argdcl((FILEP, FILEP)); static tagptr do_p1_charp Argdcl((FILEP)); static void do_p1_comment Argdcl((FILEP, FILEP)); static void do_p1_comp_goto Argdcl((FILEP, FILEP)); static tagptr do_p1_const Argdcl((FILEP)); static void do_p1_elif Argdcl((FILEP, FILEP)); static void do_p1_else Argdcl((FILEP)); static void do_p1_elseifstart Argdcl((FILEP)); static void do_p1_end_for Argdcl((FILEP)); static void do_p1_endelse Argdcl((FILEP)); static void do_p1_endif Argdcl((FILEP)); static tagptr do_p1_expr Argdcl((FILEP, FILEP)); static tagptr do_p1_extern Argdcl((FILEP)); static void do_p1_for Argdcl((FILEP, FILEP)); static void do_p1_fortran Argdcl((FILEP, FILEP)); static void do_p1_goto Argdcl((FILEP, FILEP)); static tagptr do_p1_head Argdcl((FILEP, FILEP)); static tagptr do_p1_ident Argdcl((FILEP)); static void do_p1_if Argdcl((FILEP, FILEP)); static void do_p1_label Argdcl((FILEP, FILEP)); static tagptr do_p1_list Argdcl((FILEP, FILEP)); static tagptr do_p1_literal Argdcl((FILEP)); static tagptr do_p1_name_pointer Argdcl((FILEP)); static void do_p1_set_line Argdcl((FILEP)); static void do_p1_subr_ret Argdcl((FILEP, FILEP)); static int get_p1_token Argdcl((FILEP)); static int p1get_const Argdcl((FILEP, int, Constp*)); static int p1getd Argdcl((FILEP, long int*)); static int p1getf Argdcl((FILEP, char**)); static int p1getn Argdcl((FILEP, int, char**)); static int p1gets Argdcl((FILEP, char*, int)); static void proto Argdcl((FILEP, Argtypes*, char*)); extern chainp assigned_fmts; char filename[P1_FILENAME_MAX]; extern int gflag, sharp_line, trapuv; extern int typeconv[]; int gflag1; extern char *parens; void start_formatting(Void) { FILE *infile; static int wrote_one = 0; extern int usedefsforcommon; extern char *p1_file, *p1_bakfile; this_proc_name[0] = '\0'; last_was_label = 0; ei_next = ei_first; wh_next = wh_first; (void) fclose (pass1_file); if ((infile = fopen (p1_file, binread)) == NULL) Fatal("start_formatting: couldn't open the intermediate file\n"); if (wrote_one) nice_printf (c_file, "\n"); while (!feof (infile)) { expptr this_expr; this_expr = do_format (infile, c_file); if (this_expr) { out_and_free_statement (c_file, this_expr); } /* if this_expr */ } /* while !feof infile */ (void) fclose (infile); if (last_was_label) nice_printf (c_file, ";\n"); prev_tab (c_file); gflag1 = sharp_line = 0; if (this_proc_name[0]) nice_printf (c_file, "} /* %s */\n", this_proc_name); /* Write the #undefs for common variable reference */ if (usedefsforcommon) { Extsym *ext; int did_one = 0; for (ext = extsymtab; ext < nextext; ext++) if (ext -> extstg == STGCOMMON && ext -> used_here) { ext -> used_here = 0; if (!did_one) nice_printf (c_file, "\n"); wr_abbrevs(c_file, 0, ext->extp); did_one = 1; ext -> extp = CHNULL; } /* if */ if (did_one) nice_printf (c_file, "\n"); } /* if usedefsforcommon */ other_undefs(c_file); wrote_one = 1; /* For debugging only */ if (debugflag && (pass1_file = fopen (p1_bakfile, binwrite))) if (infile = fopen (p1_file, binread)) { ffilecopy (infile, pass1_file); fclose (infile); fclose (pass1_file); } /* if infile */ /* End of "debugging only" */ scrub(p1_file); /* optionally unlink */ if ((pass1_file = fopen (p1_file, binwrite)) == NULL) err ("start_formatting: couldn't reopen the pass1 file"); } /* start_formatting */ static void #ifdef KR_headers put_semi(outfile) FILE *outfile; #else put_semi(FILE *outfile) #endif { nice_printf (outfile, ";\n"); last_was_label = 0; } #define SEM_CHECK(x) if (last_was_label) put_semi(x) /* do_format -- takes an input stream (a file in pass1 format) and writes the appropriate C code to outfile when possible. When reading an expression, the expression tree is returned instead. */ static expptr #ifdef KR_headers do_format(infile, outfile) FILE *infile; FILE *outfile; #else do_format(FILE *infile, FILE *outfile) #endif { int token_type, was_c_token; expptr retval = ENULL; token_type = get_p1_token (infile); was_c_token = 1; switch (token_type) { case P1_COMMENT: do_p1_comment (infile, outfile); was_c_token = 0; break; case P1_SET_LINE: do_p1_set_line (infile); was_c_token = 0; break; case P1_FILENAME: p1gets(infile, filename, P1_FILENAME_MAX); was_c_token = 0; break; case P1_NAME_POINTER: retval = do_p1_name_pointer (infile); break; case P1_CONST: retval = do_p1_const (infile); break; case P1_EXPR: retval = do_p1_expr (infile, outfile); break; case P1_IDENT: retval = do_p1_ident(infile); break; case P1_CHARP: retval = do_p1_charp(infile); break; case P1_EXTERN: retval = do_p1_extern (infile); break; case P1_HEAD: gflag1 = sharp_line = 0; retval = do_p1_head (infile, outfile); gflag1 = sharp_line = gflag; break; case P1_LIST: retval = do_p1_list (infile, outfile); break; case P1_LITERAL: retval = do_p1_literal (infile); break; case P1_LABEL: do_p1_label (infile, outfile); /* last_was_label = 1; -- now set in do_p1_label */ was_c_token = 0; break; case P1_ASGOTO: do_p1_asgoto (infile, outfile); break; case P1_GOTO: do_p1_goto (infile, outfile); break; case P1_IF: do_p1_if (infile, outfile); break; case P1_ELSE: SEM_CHECK(outfile); do_p1_else (outfile); break; case P1_ELIF: SEM_CHECK(outfile); do_p1_elif (infile, outfile); break; case P1_ENDIF: SEM_CHECK(outfile); do_p1_endif (outfile); break; case P1_ENDELSE: SEM_CHECK(outfile); do_p1_endelse (outfile); break; case P1_ADDR: retval = do_p1_addr (infile, outfile); break; case P1_SUBR_RET: do_p1_subr_ret (infile, outfile); break; case P1_COMP_GOTO: do_p1_comp_goto (infile, outfile); break; case P1_FOR: do_p1_for (infile, outfile); break; case P1_ENDFOR: SEM_CHECK(outfile); do_p1_end_for (outfile); break; case P1_WHILE1START: do_p1_1while(outfile); break; case P1_WHILE2START: do_p1_2while(infile, outfile); break; case P1_PROCODE: procode(outfile); break; case P1_ELSEIFSTART: SEM_CHECK(outfile); do_p1_elseifstart(outfile); break; case P1_FORTRAN: do_p1_fortran(infile, outfile); /* no break; */ case P1_EOF: was_c_token = 0; break; case P1_UNKNOWN: Fatal("do_format: Unknown token type in intermediate file"); break; default: Fatal("do_format: Bad token type in intermediate file"); break; } /* switch */ if (was_c_token) last_was_label = 0; return retval; } /* do_format */ static void #ifdef KR_headers do_p1_comment(infile, outfile) FILE *infile; FILE *outfile; #else do_p1_comment(FILE *infile, FILE *outfile) #endif { extern int in_comment; char storage[COMMENT_BUFFER_SIZE + 1]; int length; if (!p1gets(infile, storage, COMMENT_BUFFER_SIZE + 1)) return; length = strlen (storage); gflag1 = sharp_line = 0; in_comment = 1; margin_printf(outfile, length ? "/* %s */\n" : "\n", storage); in_comment = 0; gflag1 = sharp_line = gflag; } /* do_p1_comment */ static void #ifdef KR_headers do_p1_set_line(infile) FILE *infile; #else do_p1_set_line(FILE *infile) #endif { int status; long new_line_number = -1; status = p1getd (infile, &new_line_number); if (status == EOF) err ("do_p1_set_line: Missing line number at end of file\n"); else if (status == 0 || new_line_number == -1) errl("do_p1_set_line: Illegal line number in intermediate file: %ld\n", new_line_number); else { lineno = new_line_number; } } /* do_p1_set_line */ static expptr #ifdef KR_headers do_p1_name_pointer(infile) FILE *infile; #else do_p1_name_pointer(FILE *infile) #endif { Namep namep = (Namep) NULL; int status; status = p1getd (infile, (long *) &namep); if (status == EOF) err ("do_p1_name_pointer: Missing pointer at end of file\n"); else if (status == 0 || namep == (Namep) NULL) erri ("do_p1_name_pointer: Illegal name pointer in p1 file: '#%lx'\n", (unsigned long) namep); return (expptr) namep; } /* do_p1_name_pointer */ static expptr #ifdef KR_headers do_p1_const(infile) FILE *infile; #else do_p1_const(FILE *infile) #endif { struct Constblock *c = (struct Constblock *) NULL; long type = -1; int status; status = p1getd (infile, &type); if (status == EOF) err ("do_p1_const: Missing constant type at end of file\n"); else if (status == 0) errl("do_p1_const: Illegal constant type in p1 file: %ld\n", type); else { status = p1get_const (infile, (int)type, &c); if (status == EOF) { err ("do_p1_const: Missing constant value at end of file\n"); c = (struct Constblock *) NULL; } else if (status == 0) { err ("do_p1_const: Illegal constant value in p1 file\n"); c = (struct Constblock *) NULL; } /* else */ } /* else */ return (expptr) c; } /* do_p1_const */ void #ifdef KR_headers addrlit(addrp) Addrp addrp; #else addrlit(Addrp addrp) #endif { long memno = addrp->memno; struct Literal *litp, *lastlit; lastlit = litpool + nliterals; for (litp = litpool; litp < lastlit; litp++) if (litp->litnum == memno) { addrp->vtype = litp->littype; *((union Constant *) &(addrp->user)) = *((union Constant *) &(litp->litval)); addrp->vstg = STGMEMNO; return; } err("addrlit failure!"); } static expptr #ifdef KR_headers do_p1_literal(infile) FILE *infile; #else do_p1_literal(FILE *infile) #endif { int status; long memno; Addrp addrp; status = p1getd (infile, &memno); if (status == EOF) err ("do_p1_literal: Missing memno at end of file"); else if (status == 0) err ("do_p1_literal: Missing memno in p1 file"); else { addrp = ALLOC (Addrblock); addrp -> tag = TADDR; addrp -> vtype = TYUNKNOWN; addrp -> Field = NULL; addrp -> memno = memno; addrlit(addrp); addrp -> uname_tag = UNAM_CONST; } /* else */ return (expptr) addrp; } /* do_p1_literal */ static void #ifdef KR_headers do_p1_label(infile, outfile) FILE *infile; FILE *outfile; #else do_p1_label(FILE *infile, FILE *outfile) #endif { int status; ftnint stateno; struct Labelblock *L; char *fmt; status = p1getd (infile, &stateno); if (status == EOF) err ("do_p1_label: Missing label at end of file"); else if (status == 0) err ("do_p1_label: Missing label in p1 file "); else if (stateno < 0) { /* entry */ margin_printf(outfile, "\n%s:\n", user_label(stateno)); last_was_label = 1; } else { L = labeltab + stateno; if (L->labused) { fmt = "%s:\n"; last_was_label = 1; } else fmt = "/* %s: */\n"; margin_printf(outfile, fmt, user_label(L->stateno)); } /* else */ } /* do_p1_label */ static void #ifdef KR_headers do_p1_asgoto(infile, outfile) FILE *infile; FILE *outfile; #else do_p1_asgoto(FILE *infile, FILE *outfile) #endif { expptr expr; expr = do_format (infile, outfile); out_asgoto (outfile, expr); } /* do_p1_asgoto */ static void #ifdef KR_headers do_p1_goto(infile, outfile) FILE *infile; FILE *outfile; #else do_p1_goto(FILE *infile, FILE *outfile) #endif { int status; long stateno; status = p1getd (infile, &stateno); if (status == EOF) err ("do_p1_goto: Missing goto label at end of file"); else if (status == 0) err ("do_p1_goto: Missing goto label in p1 file"); else { nice_printf (outfile, "goto %s;\n", user_label (stateno)); } /* else */ } /* do_p1_goto */ static void #ifdef KR_headers do_p1_if(infile, outfile) FILE *infile; FILE *outfile; #else do_p1_if(FILE *infile, FILE *outfile) #endif { expptr cond; do { cond = do_format (infile, outfile); } while (cond == ENULL); out_if (outfile, cond); } /* do_p1_if */ static void #ifdef KR_headers do_p1_else(outfile) FILE *outfile; #else do_p1_else(FILE *outfile) #endif { out_else (outfile); } /* do_p1_else */ static void #ifdef KR_headers do_p1_elif(infile, outfile) FILE *infile; FILE *outfile; #else do_p1_elif(FILE *infile, FILE *outfile) #endif { expptr cond; do { cond = do_format (infile, outfile); } while (cond == ENULL); elif_out (outfile, cond); } /* do_p1_elif */ static void #ifdef KR_headers do_p1_endif(outfile) FILE *outfile; #else do_p1_endif(FILE *outfile) #endif { endif_out (outfile); } /* do_p1_endif */ static void #ifdef KR_headers do_p1_endelse(outfile) FILE *outfile; #else do_p1_endelse(FILE *outfile) #endif { end_else_out (outfile); } /* do_p1_endelse */ static expptr #ifdef KR_headers do_p1_addr(infile, outfile) FILE *infile; FILE *outfile; #else do_p1_addr(FILE *infile, FILE *outfile) #endif { Addrp addrp = (Addrp) NULL; int status; status = p1getn (infile, (int)sizeof(struct Addrblock), (char **) &addrp); if (status == EOF) err ("do_p1_addr: Missing Addrp at end of file"); else if (status == 0) err ("do_p1_addr: Missing Addrp in p1 file"); else if (addrp == (Addrp) NULL) err ("do_p1_addr: Null addrp in p1 file"); else if (addrp -> tag != TADDR) erri ("do_p1_addr: bad tag in p1 file '%d'", addrp -> tag); else { addrp -> vleng = do_format (infile, outfile); addrp -> memoffset = do_format (infile, outfile); } return (expptr) addrp; } /* do_p1_addr */ static void #ifdef KR_headers do_p1_subr_ret(infile, outfile) FILE *infile; FILE *outfile; #else do_p1_subr_ret(FILE *infile, FILE *outfile) #endif { expptr retval; nice_printf (outfile, "return "); retval = do_format (infile, outfile); if (!multitype) if (retval) expr_out (outfile, retval); nice_printf (outfile, ";\n"); } /* do_p1_subr_ret */ static void #ifdef KR_headers do_p1_comp_goto(infile, outfile) FILE *infile; FILE *outfile; #else do_p1_comp_goto(FILE *infile, FILE *outfile) #endif { expptr index; expptr labels; index = do_format (infile, outfile); if (index == ENULL) { err ("do_p1_comp_goto: no expression for computed goto"); return; } /* if index == ENULL */ labels = do_format (infile, outfile); if (labels && labels -> tag != TLIST) erri ("do_p1_comp_goto: expected list, got tag '%d'", labels -> tag); else compgoto_out (outfile, index, labels); } /* do_p1_comp_goto */ static void #ifdef KR_headers do_p1_for(infile, outfile) FILE *infile; FILE *outfile; #else do_p1_for(FILE *infile, FILE *outfile) #endif { expptr init, test, inc; init = do_format (infile, outfile); test = do_format (infile, outfile); inc = do_format (infile, outfile); out_for (outfile, init, test, inc); } /* do_p1_for */ static void #ifdef KR_headers do_p1_end_for(outfile) FILE *outfile; #else do_p1_end_for(FILE *outfile) #endif { out_end_for (outfile); } /* do_p1_end_for */ static void #ifdef KR_headers do_p1_fortran(infile, outfile) FILE *infile; FILE *outfile; #else do_p1_fortran(FILE *infile, FILE *outfile) #endif { char buf[P1_STMTBUFSIZE]; if (!p1gets(infile, buf, P1_STMTBUFSIZE)) return; /* bypass nice_printf nonsense */ fprintf(outfile, "/*< %s >*/\n", buf+1); /* + 1 to skip by '$' */ } static expptr #ifdef KR_headers do_p1_expr(infile, outfile) FILE *infile; FILE *outfile; #else do_p1_expr(FILE *infile, FILE *outfile) #endif { int status; long opcode, type; struct Exprblock *result = (struct Exprblock *) NULL; status = p1getd (infile, &opcode); if (status == EOF) err ("do_p1_expr: Missing expr opcode at end of file"); else if (status == 0) err ("do_p1_expr: Missing expr opcode in p1 file"); else { status = p1getd (infile, &type); if (status == EOF) err ("do_p1_expr: Missing expr type at end of file"); else if (status == 0) err ("do_p1_expr: Missing expr type in p1 file"); else if (opcode == 0) return ENULL; else { result = ALLOC (Exprblock); result -> tag = TEXPR; result -> vtype = (field)type; result -> opcode = (unsigned int)opcode; result -> vleng = do_format (infile, outfile); if (is_unary_op (opcode)) result -> leftp = do_format (infile, outfile); else if (is_binary_op (opcode)) { result -> leftp = do_format (infile, outfile); result -> rightp = do_format (infile, outfile); } else errl("do_p1_expr: Illegal opcode %ld", opcode); } /* else */ } /* else */ return (expptr) result; } /* do_p1_expr */ static expptr #ifdef KR_headers do_p1_ident(infile) FILE *infile; #else do_p1_ident(FILE *infile) #endif { Addrp addrp; int status; long vtype, vstg; addrp = ALLOC (Addrblock); addrp -> tag = TADDR; status = p1getd (infile, &vtype); if (status == EOF) err ("do_p1_ident: Missing identifier type at end of file\n"); else if (status == 0 || vtype < 0 || vtype >= NTYPES) errl("do_p1_ident: Bad type in intermediate file: %ld\n", vtype); else addrp -> vtype = (field)vtype; status = p1getd (infile, &vstg); if (status == EOF) err ("do_p1_ident: Missing identifier storage at end of file\n"); else if (status == 0 || vstg < 0 || vstg > STGNULL) errl("do_p1_ident: Bad storage in intermediate file: %ld\n", vtype); else addrp -> vstg = (field)vstg; status = p1gets(infile, addrp->user.ident, IDENT_LEN); if (status == EOF) err ("do_p1_ident: Missing ident string at end of file"); else if (status == 0) err ("do_p1_ident: Missing ident string in intermediate file"); addrp->uname_tag = UNAM_IDENT; return (expptr) addrp; } /* do_p1_ident */ static expptr #ifdef KR_headers do_p1_charp(infile) FILE *infile; #else do_p1_charp(FILE *infile) #endif { Addrp addrp; int status; long vtype, vstg; char buf[64]; addrp = ALLOC (Addrblock); addrp -> tag = TADDR; status = p1getd (infile, &vtype); if (status == EOF) err ("do_p1_ident: Missing identifier type at end of file\n"); else if (status == 0 || vtype < 0 || vtype >= NTYPES) errl("do_p1_ident: Bad type in intermediate file: %ld\n", vtype); else addrp -> vtype = (field)vtype; status = p1getd (infile, &vstg); if (status == EOF) err ("do_p1_ident: Missing identifier storage at end of file\n"); else if (status == 0 || vstg < 0 || vstg > STGNULL) errl("do_p1_ident: Bad storage in intermediate file: %ld\n", vtype); else addrp -> vstg = (field)vstg; status = p1gets(infile, buf, (int)sizeof(buf)); if (status == EOF) err ("do_p1_ident: Missing charp ident string at end of file"); else if (status == 0) err ("do_p1_ident: Missing charp ident string in intermediate file"); addrp->uname_tag = UNAM_CHARP; addrp->user.Charp = strcpy(mem(strlen(buf)+1,0), buf); return (expptr) addrp; } static expptr #ifdef KR_headers do_p1_extern(infile) FILE *infile; #else do_p1_extern(FILE *infile) #endif { Addrp addrp; addrp = ALLOC (Addrblock); if (addrp) { int status; addrp->tag = TADDR; addrp->vstg = STGEXT; addrp->uname_tag = UNAM_EXTERN; status = p1getd (infile, &(addrp -> memno)); if (status == EOF) err ("do_p1_extern: Missing memno at end of file"); else if (status == 0) err ("do_p1_extern: Missing memno in intermediate file"); if (addrp->vtype = extsymtab[addrp->memno].extype) addrp->vclass = CLPROC; } /* if addrp */ return (expptr) addrp; } /* do_p1_extern */ static expptr #ifdef KR_headers do_p1_head(infile, outfile) FILE *infile; FILE *outfile; #else do_p1_head(FILE *infile, FILE *outfile) #endif { int status; int add_n_; long Class; char storage[256]; status = p1getd (infile, &Class); if (status == EOF) err ("do_p1_head: missing header class at end of file"); else if (status == 0) err ("do_p1_head: missing header class in p1 file"); else { status = p1gets (infile, storage, (int)sizeof(storage)); if (status == EOF || status == 0) storage[0] = '\0'; } /* else */ if (Class == CLPROC || Class == CLMAIN) { chainp lengths; add_n_ = nentry > 1; lengths = length_comp(entries, add_n_); if (!add_n_ && protofile && Class != CLMAIN) protowrite(protofile, proctype, storage, entries, lengths); if (Class == CLMAIN) nice_printf (outfile, "/* Main program */ int "); else nice_printf(outfile, "%s ", multitype ? "VOID" : c_type_decl(proctype, 1)); nice_printf(outfile, add_n_ ? "%s0_" : "%s", storage); if (!Ansi) { listargs(outfile, entries, add_n_, lengths); nice_printf (outfile, "\n"); } list_arg_types (outfile, entries, lengths, add_n_, "\n"); nice_printf (outfile, "{\n"); frchain(&lengths); next_tab (outfile); strcpy(this_proc_name, storage); list_decls (outfile); } else if (Class == CLBLOCK) next_tab (outfile); else errl("do_p1_head: got class %ld", Class); return NULL; } /* do_p1_head */ static expptr #ifdef KR_headers do_p1_list(infile, outfile) FILE *infile; FILE *outfile; #else do_p1_list(FILE *infile, FILE *outfile) #endif { long tag, type, count; int status; expptr result; status = p1getd (infile, &tag); if (status == EOF) err ("do_p1_list: missing list tag at end of file"); else if (status == 0) err ("do_p1_list: missing list tag in p1 file"); else { status = p1getd (infile, &type); if (status == EOF) err ("do_p1_list: missing list type at end of file"); else if (status == 0) err ("do_p1_list: missing list type in p1 file"); else { status = p1getd (infile, &count); if (status == EOF) err ("do_p1_list: missing count at end of file"); else if (status == 0) err ("do_p1_list: missing count in p1 file"); } /* else */ } /* else */ result = (expptr) ALLOC (Listblock); if (result) { chainp pointer; result -> tag = (field)tag; result -> listblock.vtype = (field)type; /* Assume there will be enough data */ if (count--) { pointer = result->listblock.listp = mkchain((char *)do_format(infile, outfile), CHNULL); while (count--) { pointer -> nextp = mkchain((char *)do_format(infile, outfile), CHNULL); pointer = pointer -> nextp; } /* while (count--) */ } /* if (count) */ } /* if (result) */ return result; } /* do_p1_list */ chainp #ifdef KR_headers length_comp(e, add_n) struct Entrypoint *e; int add_n; #else length_comp(struct Entrypoint *e, int add_n) #endif /* get lengths of characters args */ { chainp lengths; chainp args, args1; Namep arg, np; int nchargs; Argtypes *at; Atype *a; extern int init_ac[TYSUBR+1]; if (!e) return 0; /* possible only with errors */ args = args1 = add_n ? allargs : e->arglist; nchargs = 0; for (lengths = NULL; args; args = args -> nextp) if (arg = (Namep)args->datap) { if (arg->vclass == CLUNKNOWN) arg->vclass = CLVAR; if (arg->vtype == TYCHAR && arg->vclass != CLPROC) { lengths = mkchain((char *)arg, lengths); nchargs++; } } if (!add_n && (np = e->enamep)) { /* one last check -- by now we know all we ever will * about external args... */ save_argtypes(e->arglist, &e->entryname->arginfo, &np->arginfo, 0, np->fvarname, STGEXT, nchargs, np->vtype, 1); at = e->entryname->arginfo; a = at->atypes + init_ac[np->vtype]; for(; args1; a++, args1 = args1->nextp) { frchain(&a->cp); if (arg = (Namep)args1->datap) switch(arg->vclass) { case CLPROC: if (arg->vimpltype && a->type >= 300) a->type = TYUNKNOWN + 200; break; case CLUNKNOWN: a->type %= 100; } } } return revchain(lengths); } void #ifdef KR_headers listargs(outfile, entryp, add_n_, lengths) FILE *outfile; struct Entrypoint *entryp; int add_n_; chainp lengths; #else listargs(FILE *outfile, struct Entrypoint *entryp, int add_n_, chainp lengths) #endif { chainp args; char *s; Namep arg; int did_one = 0; nice_printf (outfile, "("); if (add_n_) { nice_printf(outfile, "n__"); did_one = 1; args = allargs; } else { if (!entryp) return; /* possible only with errors */ args = entryp->arglist; } if (multitype) { nice_printf(outfile, ", ret_val"); did_one = 1; args = allargs; } else if (ONEOF(proctype, MSKCOMPLEX|MSKCHAR)) { s = xretslot[proctype]->user.ident; nice_printf(outfile, did_one ? ", %s" : "%s", *s == '(' /*)*/ ? "r_v" : s); did_one = 1; if (proctype == TYCHAR) nice_printf (outfile, ", ret_val_len"); } for (; args; args = args -> nextp) if (arg = (Namep)args->datap) { nice_printf (outfile, "%s", did_one ? ", " : ""); out_name (outfile, arg); did_one = 1; } for (args = lengths; args; args = args -> nextp) nice_printf(outfile, ", %s", new_arg_length((Namep)args->datap)); nice_printf (outfile, ")"); } /* listargs */ void #ifdef KR_headers list_arg_types(outfile, entryp, lengths, add_n_, finalnl) FILE *outfile; struct Entrypoint *entryp; chainp lengths; int add_n_; char *finalnl; #else list_arg_types(FILE *outfile, struct Entrypoint *entryp, chainp lengths, int add_n_, char *finalnl) #endif { chainp args; int last_type = -1, last_class = -1; int did_one = 0, done_one, is_ext; char *s, *sep = "", *sep1; if (outfile == (FILE *) NULL) { err ("list_arg_types: null output file"); return; } else if (entryp == (struct Entrypoint *) NULL) { err ("list_arg_types: null procedure entry pointer"); return; } /* else */ if (Ansi) { done_one = 0; sep1 = ", "; nice_printf(outfile, "(" /*)*/); } else { done_one = 1; sep1 = ";\n"; } args = entryp->arglist; if (add_n_) { nice_printf(outfile, "int n__"); did_one = done_one; sep = sep1; args = allargs; } if (multitype) { nice_printf(outfile, "%sMultitype *ret_val", sep); did_one = done_one; sep = sep1; } else if (ONEOF (proctype, MSKCOMPLEX|MSKCHAR)) { s = xretslot[proctype]->user.ident; nice_printf(outfile, "%s%s *%s", sep, c_type_decl(proctype, 0), *s == '(' /*)*/ ? "r_v" : s); did_one = done_one; sep = sep1; if (proctype == TYCHAR) nice_printf (outfile, "%sftnlen ret_val_len", sep); } /* if ONEOF proctype */ for (; args; args = args -> nextp) { Namep arg = (Namep) args->datap; /* Scalars are passed by reference, and arrays will have their lower bound adjusted, so nearly everything is printed with a star in front. The exception is character lengths, which are passed by value. */ if (arg) { int type = arg -> vtype, vclass = arg -> vclass; if (vclass == CLPROC) if (arg->vimpltype) type = Castargs ? TYUNKNOWN : TYSUBR; else if (type == TYREAL && forcedouble && !Castargs) type = TYDREAL; if (type == last_type && vclass == last_class && did_one) nice_printf (outfile, ", "); else if ((is_ext = vclass == CLPROC) && Castargs) nice_printf(outfile, "%s%s ", sep, usedcasts[type] = casttypes[type]); else nice_printf(outfile, "%s%s ", sep, c_type_decl(type, is_ext)); if (vclass == CLPROC) if (Castargs) out_name(outfile, arg); else { nice_printf(outfile, "(*"); out_name(outfile, arg); nice_printf(outfile, ") %s", parens); } else { nice_printf (outfile, "*"); out_name (outfile, arg); } last_type = type; last_class = vclass; did_one = done_one; sep = sep1; } /* if (arg) */ } /* for args = entryp -> arglist */ for (args = lengths; args; args = args -> nextp) nice_printf(outfile, "%sftnlen %s", sep, new_arg_length((Namep)args->datap)); if (did_one) nice_printf (outfile, ";\n"); else if (Ansi) nice_printf(outfile, /*((*/ sep != sep1 && Ansi == 1 ? "void)%s" : ")%s", finalnl); } /* list_arg_types */ static void #ifdef KR_headers write_formats(outfile) FILE *outfile; #else write_formats(FILE *outfile) #endif { register struct Labelblock *lp; int first = 1; char *fs; for(lp = labeltab ; lp < highlabtab ; ++lp) if (lp->fmtlabused) { if (first) { first = 0; nice_printf(outfile, "/* Format strings */\n"); } nice_printf(outfile, "static char fmt_%ld[] = \"", lp->stateno); if (!(fs = lp->fmtstring)) fs = ""; nice_printf(outfile, "%s\";\n", fs); } if (!first) nice_printf(outfile, "\n"); } static void #ifdef KR_headers write_ioblocks(outfile) FILE *outfile; #else write_ioblocks(FILE *outfile) #endif { register iob_data *L; register char *f, **s, *sep; nice_printf(outfile, "/* Fortran I/O blocks */\n"); L = iob_list = (iob_data *)revchain((chainp)iob_list); do { nice_printf(outfile, "static %s %s = { ", L->type, L->name); sep = 0; for(s = L->fields; f = *s; s++) { if (sep) nice_printf(outfile, sep); sep = ", "; if (*f == '"') { /* kludge */ nice_printf(outfile, "\""); nice_printf(outfile, "%s\"", f+1); } else nice_printf(outfile, "%s", f); } nice_printf(outfile, " };\n"); } while(L = L->next); nice_printf(outfile, "\n\n"); } static void #ifdef KR_headers write_assigned_fmts(outfile) FILE *outfile; #else write_assigned_fmts(FILE *outfile) #endif { register chainp cp; Namep np; char *comma, *type; int did_one = 0; cp = assigned_fmts = revchain(assigned_fmts); nice_printf(outfile, "/* Assigned format variables */\n"); do { np = (Namep)cp->datap; if (did_one == np->vstg) { comma = ", "; type = ""; } else { comma = (char*)(did_one ? ";\n" : ""); type = (char*)(np->vstg == STGAUTO ? "char " : "static char "); did_one = np->vstg; } nice_printf(outfile, "%s%s*%s_fmt", comma, type, np->fvarname); } while(cp = cp->nextp); nice_printf(outfile, ";\n\n"); } static char * #ifdef KR_headers to_upper(s) register char *s; #else to_upper(register char *s) #endif { static char buf[64]; register char *t = buf; register int c; while(*t++ = (c = *s++) >= 'a' && c <= 'z' ? c + 'A' - 'a' : c); return buf; } /* This routine creates static structures representing a namelist. Declarations of the namelist and related structures are: struct Vardesc { char *name; char *addr; ftnlen *dims; *//* laid out as struct dimensions below *//* int type; }; typedef struct Vardesc Vardesc; struct Namelist { char *name; Vardesc **vars; int nvars; }; struct dimensions { ftnlen numberofdimensions; ftnlen numberofelements ftnlen baseoffset; ftnlen span[numberofdimensions-1]; }; If dims is not null, then the corner element of the array is at addr. However, the element with subscripts (i1,...,in) is at addr + sizeoftype * (i1+span[0]*(i2+span[1]*...) - dimp->baseoffset) */ static void #ifdef KR_headers write_namelists(nmch, outfile) chainp nmch; FILE *outfile; #else write_namelists(chainp nmch, FILE *outfile) #endif { Namep var; struct Hashentry *entry; struct Dimblock *dimp; int i, nd, type; char *comma, *name; register chainp q; register Namep v; nice_printf(outfile, "/* Namelist stuff */\n\n"); for (entry = hashtab; entry < lasthash; ++entry) { if (!(v = entry->varp) || !v->vnamelist) continue; type = v->vtype; name = v->cvarname; if (dimp = v->vdim) { nd = dimp->ndim; nice_printf(outfile, "static ftnlen %s_dims[] = { %d, %ld, %ld", name, nd, dimp->nelt->constblock.Const.ci, dimp->baseoffset->constblock.Const.ci); for(i = 0, --nd; i < nd; i++) nice_printf(outfile, ", %ld", dimp->dims[i].dimsize->constblock.Const.ci); nice_printf(outfile, " };\n"); } nice_printf(outfile, "static Vardesc %s_dv = { \"%s\", %s", name, to_upper(v->fvarname), type == TYCHAR ? "" : (dimp || oneof_stg(v,v->vstg, M(STGEQUIV)|M(STGCOMMON))) ? "(char *)" : "(char *)&"); out_name(outfile, v); nice_printf(outfile, dimp ? ", %s_dims" : ", (ftnlen *)0", name); nice_printf(outfile, ", %ld };\n", type != TYCHAR ? (long)typeconv[type] : -v->vleng->constblock.Const.ci); } do { var = (Namep)nmch->datap; name = var->cvarname; nice_printf(outfile, "\nstatic Vardesc *%s_vl[] = ", name); comma = "{"; i = 0; for(q = var->varxptr.namelist ; q ; q = q->nextp) { v = (Namep)q->datap; if (!v->vnamelist) continue; i++; nice_printf(outfile, "%s &%s_dv", comma, v->cvarname); comma = ","; } nice_printf(outfile, " };\n"); nice_printf(outfile, "static Namelist %s = { \"%s\", %s_vl, %d };\n", name, to_upper(var->fvarname), name, i); } while(nmch = nmch->nextp); nice_printf(outfile, "\n"); } /* fixextype tries to infer from usage in previous procedures the type of an external procedure declared external and passed as an argument but never typed or invoked. */ static int #ifdef KR_headers fixexttype(var) Namep var; #else fixexttype(Namep var) #endif { Extsym *e; int type, type1; type = var->vtype; e = &extsymtab[var->vardesc.varno]; if ((type1 = e->extype) && type == TYUNKNOWN) return var->vtype = type1; if (var->visused) { if (e->exused && type != type1) changedtype(var); e->exused = 1; e->extype = type; } return type; } static void #ifdef KR_headers ref_defs(outfile, refdefs) FILE *outfile; chainp refdefs; #else ref_defs(FILE *outfile, chainp refdefs) #endif { chainp cp; int eb, i, j, n; struct Dimblock *dimp; expptr b, vl; Namep var; char *amp, *comma; margin_printf(outfile, "\n"); for(cp = refdefs = revchain(refdefs); cp; cp = cp->nextp) { var = (Namep)cp->datap; cp->datap = 0; amp = "_subscr"; if (!(eb = var->vsubscrused)) { var->vrefused = 0; if (!ISCOMPLEX(var->vtype)) amp = "_ref"; } def_start(outfile, var->cvarname, amp, CNULL); dimp = var->vdim; vl = 0; comma = "("; amp = ""; if (var->vtype == TYCHAR) { amp = "&"; vl = var->vleng; if (ISCONST(vl) && vl->constblock.Const.ci == 1) vl = 0; nice_printf(outfile, "%sa_0", comma); comma = ","; } n = dimp->ndim; for(i = 1; i <= n; i++, comma = ",") nice_printf(outfile, "%sa_%d", comma, i); nice_printf(outfile, ") %s", amp); if (var->vsubscrused) var->vsubscrused = 0; else if (!ISCOMPLEX(var->vtype)) { out_name(outfile, var); nice_printf(outfile, "[%s", vl ? "(" : ""); } for(j = 2; j < n; j++) nice_printf(outfile, "("); while(--i > 1) { nice_printf(outfile, "(a_%d)%s*", i, i == n ? "" : ")"); expr_out(outfile, cpexpr(dimp->dims[i-2].dimsize)); nice_printf(outfile, " + "); } nice_printf(outfile, "a_1"); if (var->vtype == TYCHAR) { if (vl) { nice_printf(outfile, ")*"); expr_out(outfile, cpexpr(vl)); } nice_printf(outfile, " + a_0"); } if ((var->vstg != STGARG /* || checksubs */ ) && (b = dimp->baseoffset)) { b = cpexpr(b); if (var->vtype == TYCHAR) b = mkexpr(OPSTAR, cpexpr(var->vleng), b); nice_printf(outfile, " - "); expr_out(outfile, b); } if (ISCOMPLEX(var->vtype)) { margin_printf(outfile, "\n"); def_start(outfile, var->cvarname, "_ref", CNULL); comma = "("; for(i = 1; i <= n; i++, comma = ",") nice_printf(outfile, "%sa_%d", comma, i); nice_printf(outfile, ") %s[%s_subscr", var->cvarname, var->cvarname); comma = "("; for(i = 1; i <= n; i++, comma = ",") nice_printf(outfile, "%sa_%d", comma, i); nice_printf(outfile, ")"); } margin_printf(outfile, "]\n" + eb); } nice_printf(outfile, "\n"); frchain(&refdefs); } static long #ifdef KR_headers n_elt(vd) struct Dimblock *vd; #else n_elt(struct Dimblock *vd) #endif { expptr ne; long nv = 1; if (vd) { if (!(ne = vd->nelt)) Fatal("Null nelt in n_elt"); if (ne->tag != TCONST) fatali("Unexpected nelt tag %d in n_elt", ne->tag); if (!ISINT(ne->constblock.vtype)) fatali("Unexpected vtype %d in n_elt", ne->constblock.vtype); nv = ne->constblock.Const.ci; } return nv; } void #ifdef KR_headers list_decls(outfile) FILE *outfile; #else list_decls(FILE *outfile) #endif { extern chainp used_builtins; extern struct Hashentry *hashtab; struct Hashentry *entry; int write_header = 1; int last_class = -1, last_stg = -1; Namep var; int Alias, Define, did_one, last_type, stg, type; extern int def_equivs, useauto; extern chainp new_vars; /* Compiler-generated locals */ chainp namelists = 0, refdefs = 0; char *ctype; int useauto1 = useauto && !saveall; long x; extern int hsize; /* First write out the statically initialized data */ if (initfile) list_init_data(&initfile, initfname, outfile); /* Next come formats */ write_formats(outfile); /* Now write out the system-generated identifiers */ if (new_vars || nequiv) { chainp args, next_var, this_var; chainp nv[TYVOID], nv1[TYVOID]; int i, j; ftnint k; Addrp Var; Namep arg; /* zap unused dimension variables */ for(args = allargs; args; args = args->nextp) { arg = (Namep)args->datap; if (this_var = arg->vlastdim) { frexpr((tagptr)this_var->datap); this_var->datap = 0; } } /* sort new_vars by type, skipping entries just zapped */ for(i = TYADDR; i < TYVOID; i++) nv[i] = 0; for(this_var = new_vars; this_var; this_var = next_var) { next_var = this_var->nextp; if (Var = (Addrp)this_var->datap) { if (!(this_var->nextp = nv[j = Var->vtype])) nv1[j] = this_var; nv[j] = this_var; } else { this_var->nextp = 0; frchain(&this_var); } } new_vars = 0; for(i = TYVOID; --i >= TYADDR;) if (this_var = nv[i]) { nv1[i]->nextp = new_vars; new_vars = this_var; } /* write the declarations */ did_one = 0; last_type = -1; for (this_var = new_vars; this_var; this_var = this_var -> nextp) { Var = (Addrp) this_var->datap; if (Var == (Addrp) NULL) err ("list_decls: null variable"); else if (Var -> tag != TADDR) erri ("list_decls: bad tag on new variable '%d'", Var -> tag); type = nv_type (Var); if (Var->vstg == STGINIT || Var->uname_tag == UNAM_IDENT && *Var->user.ident == ' ' && multitype) continue; if (!did_one) nice_printf (outfile, "/* System generated locals */\n"); if (last_type == type && did_one) nice_printf (outfile, ", "); else { if (did_one) nice_printf (outfile, ";\n"); nice_printf (outfile, "%s ", c_type_decl (type, Var -> vclass == CLPROC)); } /* else */ /* Character type is really a string type. Put out a '*' for parameters with unknown length and functions returning character */ if (Var -> vtype == TYCHAR && (!ISICON ((Var -> vleng)) || Var -> vclass == CLPROC)) nice_printf (outfile, "*"); write_nv_ident(outfile, (Addrp)this_var->datap); if (Var -> vtype == TYCHAR && Var->vclass != CLPROC && ISICON((Var -> vleng)) && (k = Var->vleng->constblock.Const.ci) > 0) nice_printf (outfile, "[%ld]", (long)k); did_one = 1; last_type = nv_type (Var); } /* for this_var */ /* Handle the uninitialized equivalences */ do_uninit_equivs (outfile, &did_one); if (did_one) nice_printf (outfile, ";\n\n"); } /* if new_vars */ /* Write out builtin declarations */ if (used_builtins) { chainp cp; Extsym *es; last_type = -1; did_one = 0; nice_printf (outfile, "/* Builtin functions */"); for (cp = used_builtins; cp; cp = cp -> nextp) { Addrp e = (Addrp)cp->datap; switch(type = e->vtype) { case TYDREAL: case TYREAL: /* if (forcedouble || e->dbl_builtin) */ /* libF77 currently assumes everything double */ type = TYDREAL; ctype = "double"; break; case TYCOMPLEX: case TYDCOMPLEX: type = TYVOID; /* no break */ default: ctype = c_type_decl(type, 0); } if (did_one && last_type == type) nice_printf(outfile, ", "); else nice_printf(outfile, "%s\n%s ", did_one ? ";" : "", ctype); extern_out(outfile, es = &extsymtab[e -> memno]); proto(outfile, es->arginfo, es->fextname); last_type = type; did_one = 1; } /* for cp = used_builtins */ nice_printf (outfile, ";\n\n"); } /* if used_builtins */ last_type = -1; for (entry = hashtab; entry < lasthash; ++entry) { var = entry -> varp; if (var) { int procclass = var -> vprocclass; char *comment = NULL; int vclass = var -> vclass; stg = var -> vstg; type = var -> vtype; if (var->vrefused) refdefs = mkchain((char *)var, refdefs); if (var->vsubscrused) if (ISCOMPLEX(var->vtype)) var->vsubscrused = 0; else refdefs = mkchain((char *)var, refdefs); if (ONEOF(stg, M(STGARG)|M(STGLENG)|M(STGINIT))) continue; if (useauto1 && stg == STGBSS && !var->vsave) stg = STGAUTO; switch (vclass) { case CLVAR: break; case CLPROC: switch(procclass) { case PTHISPROC: extsymtab[var->vardesc.varno].extype = type; continue; case PSTFUNCT: case PINTRINSIC: continue; case PUNKNOWN: err ("list_decls: unknown procedure class"); continue; case PEXTERNAL: if (stg == STGUNKNOWN) { warn1( "%.64s declared EXTERNAL but never used.", var->fvarname); /* to retain names declared EXTERNAL */ /* but not referenced, change */ /* "continue" to "stg = STGEXT" */ continue; } else type = fixexttype(var); } break; case CLUNKNOWN: /* declared but never used */ continue; case CLPARAM: continue; case CLNAMELIST: if (var->visused) namelists = mkchain((char *)var, namelists); continue; default: erri("list_decls: can't handle class '%d' yet", vclass); Fatal(var->fvarname); continue; } /* switch */ /* Might be equivalenced to a common. If not, don't process */ if (stg == STGCOMMON && !var->vcommequiv) continue; /* Only write the header if system-generated locals, builtins, or uninitialized equivs were already output */ if (write_header == 1 && (new_vars || nequiv || used_builtins) && oneof_stg ( var, stg, M(STGBSS)|M(STGEXT)|M(STGAUTO)|M(STGCOMMON)|M(STGEQUIV))) { nice_printf (outfile, "/* Local variables */\n"); write_header = 2; } Alias = oneof_stg(var, stg, M(STGEQUIV)|M(STGCOMMON)); if (Define = (Alias && def_equivs)) { if (!write_header) nice_printf(outfile, ";\n"); def_start(outfile, var->cvarname, CNULL, "("); goto Alias1; } else if (type == last_type && vclass == last_class && stg == last_stg && !write_header) nice_printf (outfile, ", "); else { if (!write_header && ONEOF(stg, M(STGBSS)| M(STGEXT)|M(STGAUTO)|M(STGEQUIV)|M(STGCOMMON))) nice_printf (outfile, ";\n"); switch (stg) { case STGARG: case STGLENG: /* Part of the argument list, don't write them out again */ continue; /* Go back to top of the loop */ case STGBSS: case STGEQUIV: case STGCOMMON: nice_printf (outfile, "static "); break; case STGEXT: nice_printf (outfile, "extern "); break; case STGAUTO: break; case STGINIT: case STGUNKNOWN: /* Don't want to touch the initialized data, that will be handled elsewhere. Unknown data have already been complained about, so skip them */ continue; default: erri("list_decls: can't handle storage class %d", stg); continue; } /* switch */ if (type == TYCHAR && halign && vclass != CLPROC && ISICON(var->vleng)) { nice_printf(outfile, "struct { %s fill; char val", halign); x = wr_char_len(outfile, var->vdim, var->vleng->constblock.Const.ci, 1); if (x %= hsize) nice_printf(outfile, "; char fill2[%ld]", hsize - x); nice_printf(outfile, "; } %s_st;\n", var->cvarname); def_start(outfile, var->cvarname, CNULL, var->cvarname); margin_printf(outfile, "_st.val\n"); last_type = -1; write_header = 2; continue; } nice_printf(outfile, "%s ", c_type_decl(type, vclass == CLPROC)); } /* else */ /* Character type is really a string type. Put out a '*' for variable length strings, and also for equivalences */ if (type == TYCHAR && vclass != CLPROC && (!var->vleng || !ISICON (var -> vleng)) || oneof_stg(var, stg, M(STGEQUIV)|M(STGCOMMON))) nice_printf (outfile, "*%s", var->cvarname); else { nice_printf (outfile, "%s", var->cvarname); if (vclass == CLPROC) { Argtypes *at; if (!(at = var->arginfo) && var->vprocclass == PEXTERNAL) at = extsymtab[var->vardesc.varno].arginfo; proto(outfile, at, var->fvarname); } else if (type == TYCHAR && ISICON ((var -> vleng))) wr_char_len(outfile, var->vdim, var->vleng->constblock.Const.ci, 0); else if (var -> vdim && !oneof_stg (var, stg, M(STGEQUIV)|M(STGCOMMON))) comment = wr_ardecls(outfile, var->vdim, 1L); } if (comment) nice_printf (outfile, "%s", comment); Alias1: if (Alias) { char *amp, *lp, *name, *rp; ftnint voff = var -> voffset; int et0, expr_type, k; Extsym *E; struct Equivblock *eb; char buf[MAXNAMELEN+30]; /*30 should be overkill*/ /* We DON'T want to use oneof_stg here, because we need to distinguish between them */ if (stg == STGEQUIV) { name = equiv_name(k = var->vardesc.varno, CNULL); eb = eqvclass + k; if (eb->eqvinit) { amp = "&"; et0 = TYERROR; } else { amp = ""; et0 = eb->eqvtype; } expr_type = et0; } else { E = &extsymtab[var->vardesc.varno]; sprintf(name = buf, "%s%d", E->cextname, E->curno); expr_type = type; et0 = -1; amp = "&"; } /* else */ if (!Define) nice_printf (outfile, " = "); if (voff) { k = typesize[type]; switch((int)(voff % k)) { case 0: voff /= k; expr_type = type; break; case SZSHORT: case SZSHORT+SZLONG: expr_type = TYSHORT; voff /= SZSHORT; break; case SZLONG: expr_type = TYLONG; voff /= SZLONG; break; default: expr_type = TYCHAR; } } if (expr_type == type) { lp = rp = ""; if (et0 == -1 && !voff) goto cast; } else { lp = "("; rp = ")"; cast: nice_printf(outfile, "(%s *)", c_type_decl(type, 0)); } /* Now worry about computing the offset */ if (voff) { if (expr_type == et0) nice_printf (outfile, "%s%s + %ld%s", lp, name, voff, rp); else nice_printf(outfile, "%s(%s *)%s%s + %ld%s", lp, c_type_decl (expr_type, 0), amp, name, voff, rp); } else nice_printf(outfile, "%s%s", amp, name); /* Always put these at the end of the line */ last_type = last_class = last_stg = -1; write_header = 0; if (Define) { margin_printf(outfile, ")\n"); write_header = 2; } continue; } write_header = 0; last_type = type; last_class = vclass; last_stg = stg; } /* if (var) */ } /* for (entry = hashtab */ if (!write_header) nice_printf (outfile, ";\n\n"); else if (write_header == 2) nice_printf(outfile, "\n"); /* Next, namelists, which may reference equivs */ if (namelists) { write_namelists(namelists = revchain(namelists), outfile); frchain(&namelists); } /* Finally, ioblocks (which may reference equivs and namelists) */ if (iob_list) write_ioblocks(outfile); if (assigned_fmts) write_assigned_fmts(outfile); if (refdefs) ref_defs(outfile, refdefs); if (trapuv) { for (entry = hashtab; entry < lasthash; ++entry) if ((var = entry->varp) && ONEOF(var->vstg, M(STGAUTO)|M(STGBSS)) && ISNUMERIC(var->vtype) && var->vclass == CLVAR && !var->vsave) nice_printf(outfile, "_uninit_f2c(&%s,%d,%ldL);\n", var->cvarname, typeconv[var->vtype], n_elt(var->vdim)); } } /* list_decls */ void #ifdef KR_headers do_uninit_equivs(outfile, did_one) FILE *outfile; int *did_one; #else do_uninit_equivs(FILE *outfile, int *did_one) #endif { extern int nequiv; struct Equivblock *eqv, *lasteqv = eqvclass + nequiv; int k, last_type = -1, t; for (eqv = eqvclass; eqv < lasteqv; eqv++) if (!eqv -> eqvinit && eqv -> eqvtop != eqv -> eqvbottom) { if (!*did_one) nice_printf (outfile, "/* System generated locals */\n"); t = eqv->eqvtype; if (last_type == t) nice_printf (outfile, ", "); else { if (*did_one) nice_printf (outfile, ";\n"); nice_printf (outfile, "static %s ", c_type_decl(t, 0)); k = typesize[t]; } /* else */ nice_printf(outfile, "%s", equiv_name((int)(eqv - eqvclass), CNULL)); nice_printf(outfile, "[%ld]", (eqv->eqvtop - eqv->eqvbottom + k - 1) / k); last_type = t; *did_one = 1; } /* if !eqv -> eqvinit */ } /* do_uninit_equivs */ /* wr_ardecls -- Writes the brackets and size for an array declaration. Because of the inner workings of the compiler, multi-dimensional arrays get mapped directly into a one-dimensional array, so we have to compute the size of the array here. When the dimension is greater than 1, a string comment about the original size is returned */ char * #ifdef KR_headers wr_ardecls(outfile, dimp, size) FILE *outfile; struct Dimblock *dimp; long size; #else wr_ardecls(FILE *outfile, struct Dimblock *dimp, long size) #endif { int i, k; ftnint j; static char buf[1000]; if (dimp == (struct Dimblock *) NULL) return NULL; sprintf(buf, "\t/* was "); /* would like to say k = sprintf(...), but */ k = strlen(buf); /* BSD doesn't return char transmitted count */ for (i = 0; i < dimp -> ndim; i++) { expptr this_size = dimp -> dims[i].dimsize; if (ISCONST(this_size)) { if (ISINT(this_size->constblock.vtype)) j = this_size -> constblock.Const.ci; else if (ISREAL(this_size->constblock.vtype)) j = (ftnint)this_size -> constblock.Const.cd[0]; else goto non_const; size *= j; sprintf(buf+k, "[%ld]", j); k += strlen(buf+k); /* BSD prevents getting strlen from sprintf */ } else { non_const: err ("wr_ardecls: nonconstant array size"); } } /* for i = 0 */ nice_printf (outfile, "[%ld]", size); strcat(buf+k, " */"); return (i > 1) ? buf : NULL; } /* wr_ardecls */ /* ---------------------------------------------------------------------- The following routines read from the p1 intermediate file. If that format changes, only these routines need be changed ---------------------------------------------------------------------- */ static int #ifdef KR_headers get_p1_token(infile) FILE *infile; #else get_p1_token(FILE *infile) #endif { int token = P1_UNKNOWN; /* NOT PORTABLE!! */ if (fscanf (infile, "%d", &token) == EOF) return P1_EOF; /* Skip over the ": " */ if (getc (infile) != '\n') getc (infile); return token; } /* get_p1_token */ /* Returns a (null terminated) string from the input file */ static int #ifdef KR_headers p1gets(fp, str, size) FILE *fp; char *str; int size; #else p1gets(FILE *fp, char *str, int size) #endif { char c; if (str == NULL) return 0; if ((c = getc (fp)) != ' ') ungetc (c, fp); if (fgets (str, size, fp)) { int length; str[size - 1] = '\0'; length = strlen (str); /* Get rid of the newline */ if (str[length - 1] == '\n') str[length - 1] = '\0'; return 1; } else if (feof (fp)) return EOF; else return 0; } /* p1gets */ #ifndef NO_LONG_LONG static int #ifdef KR_headers p1getq(infile, result) FILE *infile; Llong *result; #else p1getq(FILE *infile, Llong *result) #endif { #ifdef __FreeBSD__ #ifndef NO_FSCANF_LL_BUG #define FSCANF_LL_BUG #endif #endif #ifdef FSCANF_LL_BUG ULlong x = 0; int c, have_c = 0; for(;;) { c = getc(infile); if (c == EOF) break; if (c <= ' ') { if (!have_c) continue; goto done; } if (c >= '0' && c <= '9') c -= '0'; else if (c >= 'a' && c <= 'f') c += 10 - 'a'; else if (c >= 'A' && c <= 'F') c += 10 - 'A'; else { done: ungetc(c, infile); break; } x = x << 4 | c; have_c = 1; } if (have_c) { *result = (Llong)x; return 1; } return 0; #else return fscanf(infile, "%llx", result); #endif } #endif static int #ifdef KR_headers p1get_const(infile, type, resultp) FILE *infile; int type; struct Constblock **resultp; #else p1get_const(FILE *infile, int type, struct Constblock **resultp) #endif { int status; unsigned long a; struct Constblock *result; if (type != TYCHAR) { *resultp = result = ALLOC(Constblock); result -> tag = TCONST; result -> vtype = type; } switch (type) { case TYINT1: case TYSHORT: case TYLONG: case TYLOGICAL: case TYLOGICAL1: case TYLOGICAL2: status = p1getd (infile, &(result -> Const.ci)); break; #ifndef NO_LONG_LONG case TYQUAD: status = p1getq(infile, &result->Const.cq); break; #endif case TYREAL: case TYDREAL: status = p1getf(infile, &result->Const.cds[0]); result->vstg = 1; break; case TYCOMPLEX: case TYDCOMPLEX: status = p1getf(infile, &result->Const.cds[0]); if (status && status != EOF) status = p1getf(infile, &result->Const.cds[1]); result->vstg = 1; break; case TYCHAR: status = fscanf(infile, "%lx", &a); *resultp = (struct Constblock *) a; break; default: erri ("p1get_const: bad constant type '%d'", type); status = 0; break; } /* switch */ return status; } /* p1get_const */ static int #ifdef KR_headers p1getd(infile, result) FILE *infile; long *result; #else p1getd(FILE *infile, long *result) #endif { return fscanf (infile, "%ld", result); } /* p1getd */ static int #ifdef KR_headers p1getf(infile, result) FILE *infile; char **result; #else p1getf(FILE *infile, char **result) #endif { char buf[1324]; register int k; k = fscanf (infile, "%s", buf); if (k < 1) k = EOF; else strcpy(*result = mem(strlen(buf)+1,0), buf); return k; } static int #ifdef KR_headers p1getn(infile, count, result) FILE *infile; int count; char **result; #else p1getn(FILE *infile, int count, char **result) #endif { char *bufptr; bufptr = (char *) ckalloc (count); if (result) *result = bufptr; for (; !feof (infile) && count > 0; count--) *bufptr++ = getc (infile); return feof (infile) ? EOF : 1; } /* p1getn */ static void #ifdef KR_headers proto(outfile, at, fname) FILE *outfile; Argtypes *at; char *fname; #else proto(FILE *outfile, Argtypes *at, char *fname) #endif { int i, j, k, n; char *comma; Atype *atypes; Namep np; chainp cp; if (at) { /* Correct types that we learn on the fly, e.g. subroutine gotcha(foo) external foo call zap(...,foo,...) call foo(...) */ atypes = at->atypes; n = at->defined ? at->dnargs : at->nargs; for(i = 0; i++ < n; atypes++) { if (!(cp = atypes->cp)) continue; j = atypes->type; do { np = (Namep)cp->datap; k = np->vtype; if (np->vclass == CLPROC) { if (!np->vimpltype && k) k += 200; else { if (j >= 300) j = TYUNKNOWN + 200; continue; } } if (j == k) continue; if (j >= 300 || j == 200 && k >= 200) j = k; else { if (at->nargs >= 0) bad_atypes(at,fname,i,j,k,""," and"); goto break2; } } while(cp = cp->nextp); atypes->type = j; frchain(&atypes->cp); } } break2: if (parens) { nice_printf(outfile, parens); return; } if (!at || (n = at-> defined ? at->dnargs : at->nargs) < 0) { nice_printf(outfile, Ansi == 1 ? "()" : "(...)"); return; } if (n == 0) { nice_printf(outfile, Ansi == 1 ? "(void)" : "()"); return; } atypes = at->atypes; nice_printf(outfile, "("); comma = ""; for(; --n >= 0; atypes++) { k = atypes->type; if (k == TYADDR) nice_printf(outfile, "%schar **", comma); else if (k >= 200) { k -= 200; if (k >= 100) k -= 100; nice_printf(outfile, "%s%s", comma, usedcasts[k] = casttypes[k]); } else if (k >= 100) nice_printf(outfile, k == TYCHAR + 100 ? "%s%s *" : "%s%s", comma, c_type_decl(k-100, 0)); else nice_printf(outfile, "%s%s *", comma, c_type_decl(k, 0)); comma = ", "; } nice_printf(outfile, ")"); } void #ifdef KR_headers protowrite(protofile, type, name, e, lengths) FILE *protofile; int type; char *name; struct Entrypoint *e; chainp lengths; #else protowrite(FILE *protofile, int type, char *name, struct Entrypoint *e, chainp lengths) #endif { extern char used_rets[]; int asave; if (!(asave = Ansi)) Castargs = Ansi = 1; nice_printf(protofile, "extern %s %s", protorettypes[type], name); list_arg_types(protofile, e, lengths, 0, ";\n"); used_rets[type] = 1; if (!(Ansi = asave)) Castargs = 0; } static void #ifdef KR_headers do_p1_1while(outfile) FILE *outfile; #else do_p1_1while(FILE *outfile) #endif { if (*wh_next) { nice_printf(outfile, "for(;;) { /* while(complicated condition) */\n" /*}*/ ); next_tab(outfile); } else nice_printf(outfile, "while(" /*)*/ ); } static void #ifdef KR_headers do_p1_2while(infile, outfile) FILE *infile; FILE *outfile; #else do_p1_2while(FILE *infile, FILE *outfile) #endif { expptr test; test = do_format(infile, outfile); if (*wh_next) nice_printf(outfile, "if (!("); expr_out(outfile, test); if (*wh_next++) nice_printf(outfile, "))\n\tbreak;\n"); else { nice_printf(outfile, /*(*/ ") {\n"); next_tab(outfile); } } static void #ifdef KR_headers do_p1_elseifstart(outfile) FILE *outfile; #else do_p1_elseifstart(FILE *outfile) #endif { /* with sufficiently illegal input, ei_next == ei_last == 0 is possible */ if (ei_next < ei_last && *ei_next++) { prev_tab(outfile); nice_printf(outfile, /*{*/ "} else /* if(complicated condition) */ {\n" /*}*/ ); next_tab(outfile); } } f2c/src/format.h000066400000000000000000000007121171647030000137570ustar00rootroot00000000000000#define DEF_C_LINE_LENGTH 77 /* actual max will be 79 */ extern int c_output_line_length; /* max # chars per line in C source code */ chainp data_value Argdcl((FILEP, long int, int)); int do_init_data Argdcl((FILEP, FILEP)); void list_init_data Argdcl((FILEP*, char*, FILEP)); char* wr_ardecls Argdcl((FILEP, struct Dimblock*, long int)); void wr_one_init Argdcl((FILEP, char*, chainp*, int)); void wr_output_values Argdcl((FILEP, Namep, chainp)); f2c/src/formatdata.c000066400000000000000000000703061171647030000146120ustar00rootroot00000000000000/**************************************************************** Copyright 1990-1, 1993-6, 1999-2001 by AT&T, Lucent Technologies and Bellcore. Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the above copyright notice appear in all copies and that both that the copyright notice and this permission notice and warranty disclaimer appear in supporting documentation, and that the names of AT&T, Bell Laboratories, Lucent or Bellcore or any of their entities not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. AT&T, Lucent and Bellcore disclaim all warranties with regard to this software, including all implied warranties of merchantability and fitness. In no event shall AT&T, Lucent or Bellcore be liable for any special, indirect or consequential damages or any damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortious action, arising out of or in connection with the use or performance of this software. ****************************************************************/ #include "defs.h" #include "output.h" #include "names.h" #include "format.h" #define MAX_INIT_LINE 100 #define VNAME_MAX 64 static int memno2info Argdcl((int, Namep*)); typedef unsigned long Ulong; extern char *initbname; void #ifdef KR_headers list_init_data(Infile, Inname, outfile) FILE **Infile; char *Inname; FILE *outfile; #else list_init_data(FILE **Infile, char *Inname, FILE *outfile) #endif { FILE *sortfp; int status; fclose(*Infile); *Infile = 0; if (status = dsort(Inname, sortfname)) fatali ("sort failed, status %d", status); scrub(Inname); /* optionally unlink Inname */ if ((sortfp = fopen(sortfname, textread)) == NULL) Fatal("Couldn't open sorted initialization data"); do_init_data(outfile, sortfp); fclose(sortfp); scrub(sortfname); /* Insert a blank line after any initialized data */ nice_printf (outfile, "\n"); if (debugflag && infname) /* don't back block data file up -- it won't be overwritten */ backup(initfname, initbname); } /* list_init_data */ /* do_init_data -- returns YES when at least one declaration has been written */ int #ifdef KR_headers do_init_data(outfile, infile) FILE *outfile; FILE *infile; #else do_init_data(FILE *outfile, FILE *infile) #endif { char varname[VNAME_MAX], ovarname[VNAME_MAX]; ftnint offset; ftnint type; int vargroup; /* 0 --> init, 1 --> equiv, 2 --> common */ int did_one = 0; /* True when one has been output */ chainp values = CHNULL; /* Actual data values */ int keepit = 0; Namep np; ovarname[0] = '\0'; while (rdname (infile, &vargroup, varname) && rdlong (infile, &offset) && rdlong (infile, &type)) { if (strcmp (varname, ovarname)) { /* If this is a new variable name, the old initialization has been completed */ wr_one_init(outfile, ovarname, &values, keepit); strcpy (ovarname, varname); values = CHNULL; if (vargroup == 0) { if (memno2info(atoi(varname+2), &np)) { if (((Addrp)np)->uname_tag != UNAM_NAME) { err("do_init_data: expected NAME"); goto Keep; } np = ((Addrp)np)->user.name; } if (!(keepit = np->visused) && !np->vimpldovar) warn1("local variable %s never used", np->fvarname); } else { Keep: keepit = 1; } if (keepit && !did_one) { nice_printf (outfile, "/* Initialized data */\n\n"); did_one = YES; } } /* if strcmp */ values = mkchain((char *)data_value(infile, offset, (int)type), values); } /* while */ /* Write out the last declaration */ wr_one_init (outfile, ovarname, &values, keepit); return did_one; } /* do_init_data */ ftnint #ifdef KR_headers wr_char_len(outfile, dimp, n, extra1) FILE *outfile; struct Dimblock *dimp; ftnint n; int extra1; #else wr_char_len(FILE *outfile, struct Dimblock *dimp, ftnint n, int extra1) #endif { int i, nd; expptr e; ftnint j, rv; if (!dimp) { nice_printf (outfile, extra1 ? "[%ld+1]" : "[%ld]", (long)n); return n + extra1; } nice_printf(outfile, "[%ld", (long)n); nd = dimp->ndim; rv = n; for(i = 0; i < nd; i++) { e = dimp->dims[i].dimsize; if (ISCONST(e)) { if (ISINT(e->constblock.vtype)) j = e->constblock.Const.ci; else if (ISREAL(e->constblock.vtype)) j = (ftnint)e->constblock.Const.cd[0]; else goto non_const; nice_printf(outfile, "*%ld", j); rv *= j; } else { non_const: err ("wr_char_len: nonconstant array size"); } } /* extra1 allows for stupid C compilers that complain about * too many initializers in * char x[2] = "ab"; */ nice_printf(outfile, extra1 ? "+1]" : "]"); return extra1 ? rv+1 : rv; } static int ch_ar_dim = -1; /* length of each element of char string array */ static int eqvmemno; /* kludge */ static void #ifdef KR_headers write_char_init(outfile, Values, namep) FILE *outfile; chainp *Values; Namep namep; #else write_char_init(FILE *outfile, chainp *Values, Namep namep) #endif { struct Equivblock *eqv; long size; struct Dimblock *dimp; int i, nd, type; ftnint j; expptr ds; if (!namep) return; if(nequiv >= maxequiv) many("equivalences", 'q', maxequiv); eqv = &eqvclass[nequiv]; eqv->eqvbottom = 0; type = namep->vtype; size = type == TYCHAR ? namep->vleng->constblock.Const.ci : typesize[type]; if (dimp = namep->vdim) for(i = 0, nd = dimp->ndim; i < nd; i++) { ds = dimp->dims[i].dimsize; if (ISCONST(ds)) { if (ISINT(ds->constblock.vtype)) j = ds->constblock.Const.ci; else if (ISREAL(ds->constblock.vtype)) j = (ftnint)ds->constblock.Const.cd[0]; else goto non_const; size *= j; } else { non_const: err("write_char_values: nonconstant array size"); } } *Values = revchain(*Values); eqv->eqvtop = size; eqvmemno = ++lastvarno; eqv->eqvtype = type; wr_equiv_init(outfile, nequiv, Values, 0); def_start(outfile, namep->cvarname, CNULL, ""); if (type == TYCHAR) margin_printf(outfile, "((char *)&equiv_%d)\n\n", eqvmemno); else margin_printf(outfile, dimp ? "((%s *)&equiv_%d)\n\n" : "(*(%s *)&equiv_%d)\n\n", c_type_decl(type,0), eqvmemno); } /* wr_one_init -- outputs the initialization of the variable pointed to by info. When is_addr is true, info is an Addrp; otherwise, treat it as a Namep */ void #ifdef KR_headers wr_one_init(outfile, varname, Values, keepit) FILE *outfile; char *varname; chainp *Values; int keepit; #else wr_one_init(FILE *outfile, char *varname, chainp *Values, int keepit) #endif { static int memno; static union { Namep name; Addrp addr; } info; Namep namep; int is_addr, size, type; ftnint last, loc; int is_scalar = 0; char *array_comment = NULL, *name; chainp cp, values; extern char datachar[]; static int e1[3] = {1, 0, 1}; ftnint x; extern int hsize; if (!keepit) goto done; if (varname == NULL || varname[1] != '.') goto badvar; /* Get back to a meaningful representation; find the given memno in one of the appropriate tables (user-generated variables in the hash table, system-generated variables in a separate list */ memno = atoi(varname + 2); switch(varname[0]) { case 'q': /* Must subtract eqvstart when the source file * contains more than one procedure. */ wr_equiv_init(outfile, eqvmemno = memno - eqvstart, Values, 0); goto done; case 'Q': /* COMMON initialization (BLOCK DATA) */ wr_equiv_init(outfile, memno, Values, 1); goto done; case 'v': break; default: badvar: errstr("wr_one_init: unknown variable name '%s'", varname); goto done; } is_addr = memno2info (memno, &info.name); if (info.name == (Namep) NULL) { err ("wr_one_init -- unknown variable"); return; } if (is_addr) { if (info.addr -> uname_tag != UNAM_NAME) { erri ("wr_one_init -- couldn't get name pointer; tag is %d", info.addr -> uname_tag); namep = (Namep) NULL; nice_printf (outfile, " /* bad init data */"); } else namep = info.addr -> user.name; } else namep = info.name; /* check for character initialization */ *Values = values = revchain(*Values); type = info.name->vtype; if (type == TYCHAR) { for(last = 0; values; values = values->nextp) { cp = (chainp)values->datap; loc = (ftnint)cp->datap; if (loc > last) { write_char_init(outfile, Values, namep); goto done; } last = (Ulong)cp->nextp->datap == TYBLANK ? loc + (Ulong)cp->nextp->nextp->datap : loc + 1; } if (halign && info.name->tag == TNAME) { nice_printf(outfile, "static struct { %s fill; char val", halign); x = wr_char_len(outfile, namep->vdim, ch_ar_dim = info.name -> vleng -> constblock.Const.ci, 1); if (x %= hsize) nice_printf(outfile, "; char fill2[%ld]", hsize - x); name = info.name->cvarname; nice_printf(outfile, "; } %s_st = { 0,", name); wr_output_values(outfile, namep, *Values); nice_printf(outfile, " };\n"); ch_ar_dim = -1; def_start(outfile, name, CNULL, name); margin_printf(outfile, "_st.val\n"); goto done; } } else { size = typesize[type]; loc = 0; for(; values; values = values->nextp) { if ((Ulong)((chainp)values->datap)->nextp->datap == TYCHAR) { write_char_init(outfile, Values, namep); goto done; } last = ((long) ((chainp) values->datap)->datap) / size; if (last - loc > 4) { write_char_init(outfile, Values, namep); goto done; } loc = last; } } values = *Values; nice_printf (outfile, "static %s ", c_type_decl (type, 0)); if (is_addr) write_nv_ident (outfile, info.addr); else out_name (outfile, info.name); if (namep) is_scalar = namep -> vdim == (struct Dimblock *) NULL; if (namep && !is_scalar) array_comment = type == TYCHAR ? 0 : wr_ardecls(outfile, namep->vdim, 1L); if (type == TYCHAR) if (ISICON (info.name -> vleng)) /* We'll make single strings one character longer, so that we can use the standard C initialization. All this does is pad an extra zero onto the end of the string */ wr_char_len(outfile, namep->vdim, ch_ar_dim = info.name -> vleng -> constblock.Const.ci, e1[Ansi]); else err ("variable length character initialization"); if (array_comment) nice_printf (outfile, "%s", array_comment); nice_printf (outfile, " = "); wr_output_values (outfile, namep, values); ch_ar_dim = -1; nice_printf (outfile, ";\n"); done: frchain(Values); } /* wr_one_init */ chainp #ifdef KR_headers data_value(infile, offset, type) FILE *infile; ftnint offset; int type; #else data_value(FILE *infile, ftnint offset, int type) #endif { char line[MAX_INIT_LINE + 1], *pointer; chainp vals, prev_val; char *newval; if (fgets (line, MAX_INIT_LINE, infile) == NULL) { err ("data_value: error reading from intermediate file"); return CHNULL; } /* if fgets */ /* Get rid of the trailing newline */ if (line[0]) line[strlen (line) - 1] = '\0'; #define iswhite(x) (isspace (x) || (x) == ',') pointer = line; prev_val = vals = CHNULL; while (*pointer) { register char *end_ptr, old_val; /* Move pointer to the start of the next word */ while (*pointer && iswhite (*pointer)) pointer++; if (*pointer == '\0') break; /* Move end_ptr to the end of the current word */ for (end_ptr = pointer + 1; *end_ptr && !iswhite (*end_ptr); end_ptr++) ; old_val = *end_ptr; *end_ptr = '\0'; /* Add this value to the end of the list */ #ifdef NO_LONG_LONG if (ONEOF(type, MSKREAL|MSKCOMPLEX)) #else if (ONEOF(type, MSKREAL|MSKCOMPLEX|M(TYQUAD))) #endif newval = cpstring(pointer); else newval = (char *)atol(pointer); if (vals) { prev_val->nextp = mkchain(newval, CHNULL); prev_val = prev_val -> nextp; } else prev_val = vals = mkchain(newval, CHNULL); *end_ptr = old_val; pointer = end_ptr; } /* while *pointer */ return mkchain((char *)offset, mkchain((char *)(Ulong)type, vals)); } /* data_value */ static void overlapping(Void) { extern char *filename0; static int warned = 0; if (warned) return; warned = 1; fprintf(stderr, "Error"); if (filename0) fprintf(stderr, " in file %s", filename0); fprintf(stderr, ": overlapping initializations\n"); nerr++; } static void make_one_const Argdcl((int, union Constant*, chainp)); static long charlen; void #ifdef KR_headers wr_output_values(outfile, namep, values) FILE *outfile; Namep namep; chainp values; #else wr_output_values(FILE *outfile, Namep namep, chainp values) #endif { int type = TYUNKNOWN; struct Constblock Const; static expptr Vlen; if (namep) type = namep -> vtype; /* Handle array initializations away from scalars */ if (namep && namep -> vdim) wr_array_init (outfile, type, values); else if (values->nextp && type != TYCHAR) overlapping(); else { make_one_const(type, &Const.Const, values); Const.vtype = type; Const.vstg = ONEOF(type, MSKREAL|MSKCOMPLEX) != 0; if (type== TYCHAR) { if (!Vlen) Vlen = ICON(0); Const.vleng = Vlen; Vlen->constblock.Const.ci = charlen; out_const (outfile, &Const); free (Const.Const.ccp); } else { #ifndef NO_LONG_LONG if (type == TYQUAD) Const.Const.cd[1] = 123.456; /* kludge */ /* kludge assumes max(sizeof(char*), */ /* sizeof(long long)) <= sizeof(double) */ #endif out_const (outfile, &Const); } } } void #ifdef KR_headers wr_array_init(outfile, type, values) FILE *outfile; int type; chainp values; #else wr_array_init(FILE *outfile, int type, chainp values) #endif { int size = typesize[type]; long index, main_index = 0; int k; if (type == TYCHAR) { nice_printf(outfile, "\""); k = 0; if (Ansi != 1) ch_ar_dim = -1; } else nice_printf (outfile, "{ "); while (values) { struct Constblock Const; index = ((long) ((chainp) values->datap)->datap) / size; while (index > main_index) { /* Fill with zeros. The structure shorthand works because the compiler will expand the "0" in braces to fill the size of the entire structure */ switch (type) { case TYREAL: case TYDREAL: nice_printf (outfile, "0.0,"); break; case TYCOMPLEX: case TYDCOMPLEX: nice_printf (outfile, "{0},"); break; case TYCHAR: nice_printf(outfile, " "); break; default: nice_printf (outfile, "0,"); break; } /* switch */ main_index++; } /* while index > main_index */ if (index < main_index) overlapping(); else switch (type) { case TYCHAR: { int this_char; if (k == ch_ar_dim) { nice_printf(outfile, "\" \""); k = 0; } this_char = (int)(Ulong) ((chainp) values->datap)-> nextp->nextp->datap; if ((Ulong)((chainp)values->datap)->nextp->datap == TYBLANK) { main_index += this_char; k += this_char; while(--this_char >= 0) nice_printf(outfile, " "); values = values -> nextp; continue; } nice_printf(outfile, str_fmt[this_char]); k++; } /* case TYCHAR */ break; #ifdef TYQUAD case TYQUAD: #ifndef NO_LONG_LONG Const.Const.cd[1] = 123.456; #endif #endif case TYINT1: case TYSHORT: case TYLONG: case TYREAL: case TYDREAL: case TYLOGICAL: case TYLOGICAL1: case TYLOGICAL2: case TYCOMPLEX: case TYDCOMPLEX: make_one_const(type, &Const.Const, values); Const.vtype = type; Const.vstg = ONEOF(type, MSKREAL|MSKCOMPLEX) != 0; out_const(outfile, &Const); break; default: erri("wr_array_init: bad type '%d'", type); break; } /* switch */ values = values->nextp; main_index++; if (values && type != TYCHAR) nice_printf (outfile, ","); } /* while values */ if (type == TYCHAR) { nice_printf(outfile, "\""); } else nice_printf (outfile, " }"); } /* wr_array_init */ static void #ifdef KR_headers make_one_const(type, storage, values) int type; union Constant *storage; chainp values; #else make_one_const(int type, union Constant *storage, chainp values) #endif { union Constant *Const; register char **L; if (type == TYCHAR) { char *str, *str_ptr; chainp v, prev; int b = 0, k, main_index = 0; /* Find the max length of init string, by finding the highest offset value stored in the list of initial values */ for(k = 1, prev = CHNULL, v = values; v; prev = v, v = v->nextp) ; if (prev != CHNULL) k = ((int)(Ulong) (((chainp) prev->datap)->datap)) + 2; /* + 2 above for null char at end */ str = Alloc (k); for (str_ptr = str; values; str_ptr++) { int index = (int)(Ulong) (((chainp) values->datap)->datap); if (index < main_index) overlapping(); while (index > main_index++) *str_ptr++ = ' '; k = (int)(Ulong)(((chainp)values->datap)->nextp->nextp->datap); if ((Ulong)((chainp)values->datap)->nextp->datap == TYBLANK) { b = k; break; } *str_ptr = (char)k; values = values -> nextp; } /* for str_ptr */ *str_ptr = '\0'; Const = storage; Const -> ccp = str; Const -> ccp1.blanks = b; charlen = str_ptr - str; } else { int i = 0; chainp vals; vals = ((chainp)values->datap)->nextp->nextp; if (vals) { L = (char **)storage; do L[i++] = vals->datap; while(vals = vals->nextp); } } /* else */ } /* make_one_const */ int #ifdef KR_headers rdname(infile, vargroupp, name) FILE *infile; int *vargroupp; char *name; #else rdname(FILE *infile, int *vargroupp, char *name) #endif { register int i, c; c = getc (infile); if (feof (infile)) return NO; *vargroupp = c - '0'; for (i = 1;; i++) { if (i >= VNAME_MAX) Fatal("rdname: oversize name"); c = getc (infile); if (feof (infile)) return NO; if (c == '\t') break; *name++ = c; } *name = 0; return YES; } /* rdname */ int #ifdef KR_headers rdlong(infile, n) FILE *infile; ftnint *n; #else rdlong(FILE *infile, ftnint *n) #endif { register int c; for (c = getc (infile); !feof (infile) && isspace (c); c = getc (infile)) ; if (feof (infile)) return NO; for (*n = 0; isdigit (c); c = getc (infile)) *n = 10 * (*n) + c - '0'; return YES; } /* rdlong */ static int #ifdef KR_headers memno2info(memno, info) int memno; Namep *info; #else memno2info(int memno, Namep *info) #endif { chainp this_var; extern chainp new_vars; extern struct Hashentry *hashtab, *lasthash; struct Hashentry *entry; for (this_var = new_vars; this_var; this_var = this_var -> nextp) { Addrp var = (Addrp) this_var->datap; if (var == (Addrp) NULL) Fatal("memno2info: null variable"); else if (var -> tag != TADDR) Fatal("memno2info: bad tag"); if (memno == var -> memno) { *info = (Namep) var; return 1; } /* if memno == var -> memno */ } /* for this_var = new_vars */ for (entry = hashtab; entry < lasthash; ++entry) { Namep var = entry -> varp; if (var && var -> vardesc.varno == memno && var -> vstg == STGINIT) { *info = (Namep) var; return 0; } /* if entry -> vardesc.varno == memno */ } /* for entry = hashtab */ Fatal("memno2info: couldn't find memno"); return 0; } /* memno2info */ static chainp #ifdef KR_headers do_string(outfile, v, nloc) FILE *outfile; register chainp v; ftnint *nloc; #else do_string(FILE *outfile, register chainp v, ftnint *nloc) #endif { register chainp cp, v0; ftnint dloc, k, loc; unsigned long uk; char buf[8], *comma; nice_printf(outfile, "{"); cp = (chainp)v->datap; loc = (ftnint)cp->datap; comma = ""; for(v0 = v;;) { switch((Ulong)cp->nextp->datap) { case TYBLANK: k = (ftnint)cp->nextp->nextp->datap; loc += k; while(--k >= 0) { nice_printf(outfile, "%s' '", comma); comma = ", "; } break; case TYCHAR: uk = (ftnint)cp->nextp->nextp->datap; sprintf(buf, chr_fmt[uk], uk); nice_printf(outfile, "%s'%s'", comma, buf); comma = ", "; loc++; break; default: goto done; } v0 = v; if (!(v = v->nextp) || !(cp = (chainp)v->datap)) break; dloc = (ftnint)cp->datap; if (loc != dloc) break; } done: nice_printf(outfile, "}"); *nloc = loc; return v0; } static chainp #ifdef KR_headers Ado_string(outfile, v, nloc) FILE *outfile; register chainp v; ftnint *nloc; #else Ado_string(FILE *outfile, register chainp v, ftnint *nloc) #endif { register chainp cp, v0; ftnint dloc, k, loc; nice_printf(outfile, "\""); cp = (chainp)v->datap; loc = (ftnint)cp->datap; for(v0 = v;;) { switch((Ulong)cp->nextp->datap) { case TYBLANK: k = (ftnint)cp->nextp->nextp->datap; loc += k; while(--k >= 0) nice_printf(outfile, " "); break; case TYCHAR: k = (ftnint)cp->nextp->nextp->datap; nice_printf(outfile, str_fmt[k]); loc++; break; default: goto done; } v0 = v; if (!(v = v->nextp) || !(cp = (chainp)v->datap)) break; dloc = (ftnint)cp->datap; if (loc != dloc) break; } done: nice_printf(outfile, "\""); *nloc = loc; return v0; } static char * #ifdef KR_headers Len(L, type) long L; int type; #else Len(long L, int type) #endif { static char buf[24]; if (L == 1 && type != TYCHAR) return ""; sprintf(buf, "[%ld]", L); return buf; } static void #ifdef KR_headers fill_dcl(outfile, t, k, L) FILE *outfile; int t; int k; ftnint L; #else fill_dcl(FILE *outfile, int t, int k, ftnint L) #endif { nice_printf(outfile, "%s fill_%d[%ld];\n", Typename[t], k, L); } static int #ifdef KR_headers fill_type(L, loc, xtype) ftnint L; ftnint loc; int xtype; #else fill_type(ftnint L, ftnint loc, int xtype) #endif { int ft, ft1, szshort; if (xtype == TYCHAR) return xtype; szshort = typesize[TYSHORT]; ft = L % szshort ? TYCHAR : type_choice[L/szshort % 4]; ft1 = loc % szshort ? TYCHAR : type_choice[loc/szshort % 4]; if (typesize[ft] > typesize[ft1]) ft = ft1; return ft; } static ftnint #ifdef KR_headers get_fill(dloc, loc, t0, t1, L0, L1, xtype) ftnint dloc; ftnint loc; int *t0; int *t1; ftnint *L0; ftnint *L1; int xtype; #else get_fill(ftnint dloc, ftnint loc, int *t0, int *t1, ftnint *L0, ftnint *L1, int xtype) #endif { ftnint L, L2, loc0; if (L = loc % typesize[xtype]) { loc0 = loc; loc += L = typesize[xtype] - L; if (L % typesize[TYSHORT]) *t0 = TYCHAR; else L /= typesize[*t0 = fill_type(L, loc0, xtype)]; } if (dloc < loc + typesize[xtype]) return 0; *L0 = L; L2 = (dloc - loc) / typesize[xtype]; loc += L2*typesize[xtype]; if (dloc -= loc) dloc /= typesize[*t1 = fill_type(dloc, loc, xtype)]; *L1 = dloc; return L2; } void #ifdef KR_headers wr_equiv_init(outfile, memno, Values, iscomm) FILE *outfile; int memno; chainp *Values; int iscomm; #else wr_equiv_init(FILE *outfile, int memno, chainp *Values, int iscomm) #endif { struct Equivblock *eqv; int btype, curtype, dtype, filltype, j, k, n, t0, t1; int wasblank, xfilled, xtype; static char Blank[] = ""; register char *comma = Blank; register chainp cp, v; chainp sentinel, values, v1, vlast; ftnint L, L0, L1, L2, dL, dloc, loc, loc0; union Constant Const; char imag_buf[50], real_buf[50]; int szshort = typesize[TYSHORT]; static char typepref[] = {0, 0, TYINT1, TYSHORT, TYLONG, #ifdef TYQUAD TYQUAD, #endif TYREAL, TYDREAL, TYREAL, TYDREAL, TYLOGICAL1, TYLOGICAL2, TYLOGICAL, TYCHAR}; static char basetype[] = {0, 0, TYCHAR, TYSHORT, TYLONG, #ifdef TYQUAD TYDREAL, #endif TYLONG, TYDREAL, TYLONG, TYDREAL, TYCHAR, TYSHORT, TYLONG, TYCHAR, 0 /* for TYBLANK */ }; extern int htype; char *z; /* add sentinel */ if (iscomm) { L = extsymtab[memno].maxleng; xtype = extsymtab[memno].extype; } else { eqv = &eqvclass[memno]; L = eqv->eqvtop - eqv->eqvbottom; xtype = eqv->eqvtype; } if (halign && typealign[typepref[xtype]] < typealign[htype]) xtype = htype; xtype = typepref[xtype]; *Values = values = revchain(vlast = *Values); xfilled = 2; if (xtype != TYCHAR) { /* unless the data include a value of the appropriate * type, we add an extra element in an attempt * to force correct alignment */ btype = basetype[xtype]; loc = 0; for(v = *Values;;v = v->nextp) { if (!v) { dtype = typepref[xtype]; z = ISREAL(dtype) ? cpstring("0.") : (char *)0; k = typesize[dtype]; if (j = (int)(L % k)) L += k - j; v = mkchain((char *)L, mkchain((char *)(Ulong)dtype, mkchain(z, CHNULL))); vlast = vlast->nextp = mkchain((char *)v, CHNULL); L += k; break; } cp = (chainp)v->datap; if (basetype[(Ulong)cp->nextp->datap] == btype) break; dloc = (ftnint)cp->datap; if (get_fill(dloc, loc, &t0, &t1, &L0, &L1, xtype)) { xfilled = 0; break; } L1 = dloc - loc; if (L1 > 0 && !(L1 % szshort) && !(loc % szshort) && btype <= type_choice[L1/szshort % 4] && btype <= type_choice[loc/szshort % 4]) break; dtype = (int)(Ulong)cp->nextp->datap; loc = dloc + (dtype == TYBLANK ? (ftnint)cp->nextp->nextp->datap : typesize[dtype]); } } sentinel = mkchain((char *)L, mkchain((char *)TYERROR,CHNULL)); vlast->nextp = mkchain((char *)sentinel, CHNULL); /* use doublereal fillers only if there are doublereal values */ k = TYLONG; for(v = values; v; v = v->nextp) if (ONEOF((Ulong)((chainp)v->datap)->nextp->datap, M(TYDREAL)|M(TYDCOMPLEX))) { k = TYDREAL; break; } type_choice[0] = k; nice_printf(outfile, "%sstruct {\n", iscomm ? "" : "static "); next_tab(outfile); loc = loc0 = k = 0; curtype = -1; for(v = values; v; v = v->nextp) { cp = (chainp)v->datap; dloc = (ftnint)cp->datap; L = dloc - loc; if (L < 0) { overlapping(); if ((Ulong)cp->nextp->datap != TYERROR) { v1 = cp; frchain(&v1); v->datap = 0; } continue; } dtype = (int)(Ulong)cp->nextp->datap; if (dtype == TYBLANK) { dtype = TYCHAR; wasblank = 1; } else wasblank = 0; if (curtype != dtype || L > 0) { if (curtype != -1) { L1 = (loc - loc0)/dL; nice_printf(outfile, "%s e_%d%s;\n", Typename[curtype], ++k, Len(L1,curtype)); } curtype = dtype; loc0 = dloc; } if (L > 0) { filltype = fill_type(L, loc, xtype); L1 = L / typesize[filltype]; if (!xfilled && (L2 = get_fill(dloc, loc, &t0, &t1, &L0, &L1, xtype))) { xfilled = 1; if (L0) fill_dcl(outfile, t0, ++k, L0); fill_dcl(outfile, xtype, ++k, L2); if (L1) fill_dcl(outfile, t1, ++k, L1); } else fill_dcl(outfile, filltype, ++k, L1); loc = dloc; } if (wasblank) { loc += (ftnint)cp->nextp->nextp->datap; dL = 1; } else { dL = typesize[dtype]; loc += dL; } } nice_printf(outfile, "} %s = { ", iscomm ? extsymtab[memno].cextname : equiv_name(eqvmemno, CNULL)); loc = 0; xfilled &= 2; for(v = values; ; v = v->nextp) { cp = (chainp)v->datap; if (!cp) continue; dtype = (int)(Ulong)cp->nextp->datap; if (dtype == TYERROR) break; dloc = (ftnint)cp->datap; if (dloc > loc) { n = 1; if (!xfilled && (L2 = get_fill(dloc, loc, &t0, &t1, &L0, &L1, xtype))) { xfilled = 1; if (L0) n = 2; if (L1) n++; } while(n--) { nice_printf(outfile, "%s{0}", comma); comma = ", "; } loc = dloc; } if (comma != Blank) nice_printf(outfile, ", "); comma = ", "; if (dtype == TYCHAR || dtype == TYBLANK) { v = Ansi == 1 ? Ado_string(outfile, v, &loc) : do_string(outfile, v, &loc); continue; } make_one_const(dtype, &Const, v); switch(dtype) { case TYLOGICAL: case TYLOGICAL2: case TYLOGICAL1: if (Const.ci < 0 || Const.ci > 1) errl( "wr_equiv_init: unexpected logical value %ld", Const.ci); nice_printf(outfile, Const.ci ? "TRUE_" : "FALSE_"); break; case TYINT1: case TYSHORT: case TYLONG: #ifdef TYQUAD0 case TYQUAD: #endif nice_printf(outfile, "%ld", Const.ci); break; #ifndef NO_LONG_LONG case TYQUAD: nice_printf(outfile, "%s", Const.cds[0]); break; #endif case TYREAL: nice_printf(outfile, "%s", flconst(real_buf, Const.cds[0])); break; case TYDREAL: nice_printf(outfile, "%s", Const.cds[0]); break; case TYCOMPLEX: nice_printf(outfile, "%s, %s", flconst(real_buf, Const.cds[0]), flconst(imag_buf, Const.cds[1])); break; case TYDCOMPLEX: nice_printf(outfile, "%s, %s", Const.cds[0], Const.cds[1]); break; default: erri("unexpected type %d in wr_equiv_init", dtype); } loc += typesize[dtype]; } nice_printf(outfile, " };\n\n"); prev_tab(outfile); frchain(&sentinel); } f2c/src/ftypes.h000066400000000000000000000031201171647030000137750ustar00rootroot00000000000000 /* variable types (stored in the vtype field of expptr) * numeric assumptions: * int < reals < complexes * TYDREAL-TYREAL = TYDCOMPLEX-TYCOMPLEX */ #undef TYQUAD0 #ifdef NO_TYQUAD #undef TYQUAD #define TYQUAD_inc 0 #undef NO_LONG_LONG #define NO_LONG_LONG #else #define TYQUAD 5 #define TYQUAD_inc 1 #ifdef NO_LONG_LONG #define TYQUAD0 #else #ifndef Llong typedef long long Llong; #endif #ifndef ULlong typedef unsigned long long ULlong; #endif #endif /*NO_LONG_LONG*/ #endif /*NO_TYQUAD*/ #define TYUNKNOWN 0 #define TYADDR 1 #define TYINT1 2 #define TYSHORT 3 #define TYLONG 4 /* #define TYQUAD 5 */ #define TYREAL (5+TYQUAD_inc) #define TYDREAL (6+TYQUAD_inc) #define TYCOMPLEX (7+TYQUAD_inc) #define TYDCOMPLEX (8+TYQUAD_inc) #define TYLOGICAL1 (9+TYQUAD_inc) #define TYLOGICAL2 (10+TYQUAD_inc) #define TYLOGICAL (11+TYQUAD_inc) #define TYCHAR (12+TYQUAD_inc) #define TYSUBR (13+TYQUAD_inc) #define TYERROR (14+TYQUAD_inc) #define TYCILIST (15+TYQUAD_inc) #define TYICILIST (16+TYQUAD_inc) #define TYOLIST (17+TYQUAD_inc) #define TYCLLIST (18+TYQUAD_inc) #define TYALIST (19+TYQUAD_inc) #define TYINLIST (20+TYQUAD_inc) #define TYVOID (21+TYQUAD_inc) #define TYLABEL (22+TYQUAD_inc) #define TYFTNLEN (23+TYQUAD_inc) /* TYVOID is not in any tables. */ /* NTYPES, NTYPES0 -- Total number of types, used to allocate tables indexed by type. Such tables can include the size (in bytes) of objects of a given type, or labels for returning objects of different types from procedures (see array rtvlabels) */ #define NTYPES TYVOID #define NTYPES0 TYCILIST #define TYBLANK TYSUBR /* Huh? */ f2c/src/gram.c000066400000000000000000001753621171647030000134260ustar00rootroot00000000000000#define SEOS 1 #define SCOMMENT 2 #define SLABEL 3 #define SUNKNOWN 4 #define SHOLLERITH 5 #define SICON 6 #define SRCON 7 #define SDCON 8 #define SBITCON 9 #define SOCTCON 10 #define SHEXCON 11 #define STRUE 12 #define SFALSE 13 #define SNAME 14 #define SNAMEEQ 15 #define SFIELD 16 #define SSCALE 17 #define SINCLUDE 18 #define SLET 19 #define SASSIGN 20 #define SAUTOMATIC 21 #define SBACKSPACE 22 #define SBLOCK 23 #define SCALL 24 #define SCHARACTER 25 #define SCLOSE 26 #define SCOMMON 27 #define SCOMPLEX 28 #define SCONTINUE 29 #define SDATA 30 #define SDCOMPLEX 31 #define SDIMENSION 32 #define SDO 33 #define SDOUBLE 34 #define SELSE 35 #define SELSEIF 36 #define SEND 37 #define SENDFILE 38 #define SENDIF 39 #define SENTRY 40 #define SEQUIV 41 #define SEXTERNAL 42 #define SFORMAT 43 #define SFUNCTION 44 #define SGOTO 45 #define SASGOTO 46 #define SCOMPGOTO 47 #define SARITHIF 48 #define SLOGIF 49 #define SIMPLICIT 50 #define SINQUIRE 51 #define SINTEGER 52 #define SINTRINSIC 53 #define SLOGICAL 54 #define SNAMELIST 55 #define SOPEN 56 #define SPARAM 57 #define SPAUSE 58 #define SPRINT 59 #define SPROGRAM 60 #define SPUNCH 61 #define SREAD 62 #define SREAL 63 #define SRETURN 64 #define SREWIND 65 #define SSAVE 66 #define SSTATIC 67 #define SSTOP 68 #define SSUBROUTINE 69 #define STHEN 70 #define STO 71 #define SUNDEFINED 72 #define SWRITE 73 #define SLPAR 74 #define SRPAR 75 #define SEQUALS 76 #define SCOLON 77 #define SCOMMA 78 #define SCURRENCY 79 #define SPLUS 80 #define SMINUS 81 #define SSTAR 82 #define SSLASH 83 #define SPOWER 84 #define SCONCAT 85 #define SAND 86 #define SOR 87 #define SNEQV 88 #define SEQV 89 #define SNOT 90 #define SEQ 91 #define SLT 92 #define SGT 93 #define SLE 94 #define SGE 95 #define SNE 96 #define SENDDO 97 #define SWHILE 98 #define SSLASHD 99 #define SBYTE 100 /* #line 125 "/n/bopp/v5/dmg/f2c/gram.in" */ #include "defs.h" #include "p1defs.h" static int nstars; /* Number of labels in an alternate return CALL */ static int datagripe; static int ndim; static int vartype; int new_dcl; static ftnint varleng; static struct Dims dims[MAXDIM+1]; extern struct Labelblock **labarray; /* Labels in an alternate return CALL */ extern int maxlablist; /* The next two variables are used to verify that each statement might be reached during runtime. lastwasbranch is tested only in the defintion of the stat: nonterminal. */ int lastwasbranch = NO; static int thiswasbranch = NO; extern ftnint yystno; extern flag intonly; static chainp datastack; extern long laststfcn, thisstno; extern int can_include; /* for netlib */ extern void endcheck Argdcl((void)); extern struct Primblock *primchk Argdcl((expptr)); #define ESNULL (Extsym *)0 #define NPNULL (Namep)0 #define LBNULL (struct Listblock *)0 static void pop_datastack(Void) { chainp d0 = datastack; if (d0->datap) curdtp = (chainp)d0->datap; datastack = d0->nextp; d0->nextp = 0; frchain(&d0); } /* #line 172 "/n/bopp/v5/dmg/f2c/gram.in" */ typedef union { int ival; ftnint lval; char *charpval; chainp chval; tagptr tagval; expptr expval; struct Labelblock *labval; struct Nameblock *namval; struct Eqvchain *eqvval; Extsym *extval; } YYSTYPE; extern int yyerrflag; #ifndef YYMAXDEPTH #define YYMAXDEPTH 150 #endif YYSTYPE yylval; YYSTYPE yyval; #define YYEOFCODE 1 #define YYERRCODE 2 short yyexca[] = {-1, 1, 1, -1, -2, 0, -1, 20, 4, 38, -2, 231, -1, 24, 4, 42, -2, 231, -1, 151, 4, 247, -2, 189, -1, 175, 4, 269, 81, 269, -2, 189, -1, 225, 80, 174, -2, 140, -1, 246, 77, 231, -2, 228, -1, 273, 4, 290, -2, 144, -1, 277, 4, 299, 81, 299, -2, 146, -1, 330, 80, 175, -2, 142, -1, 360, 4, 271, 17, 271, 77, 271, 81, 271, -2, 190, -1, 439, 94, 0, 95, 0, 96, 0, 97, 0, 98, 0, 99, 0, -2, 154, -1, 456, 4, 293, 81, 293, -2, 144, -1, 458, 4, 295, 81, 295, -2, 144, -1, 460, 4, 297, 81, 297, -2, 144, -1, 462, 4, 300, 81, 300, -2, 145, -1, 506, 81, 293, -2, 144, }; #define YYNPROD 305 #define YYPRIVATE 57344 #define YYLAST 1455 short yyact[] = { 239, 359, 474, 306, 416, 427, 299, 389, 473, 267, 315, 231, 400, 358, 318, 415, 328, 253, 319, 100, 224, 297, 294, 280, 402, 401, 305, 117, 185, 265, 17, 122, 204, 275, 196, 191, 202, 203, 119, 129, 107, 271, 200, 184, 112, 104, 338, 102, 166, 167, 336, 337, 338, 344, 343, 342, 121, 157, 120, 345, 347, 346, 349, 348, 350, 261, 276, 336, 337, 338, 131, 132, 133, 134, 104, 136, 539, 158, 399, 158, 313, 166, 167, 336, 337, 338, 344, 343, 342, 341, 340, 311, 345, 347, 346, 349, 348, 350, 399, 398, 105, 514, 115, 537, 166, 167, 336, 337, 338, 344, 343, 342, 341, 340, 238, 345, 347, 346, 349, 348, 350, 106, 130, 104, 478, 211, 187, 188, 412, 320, 259, 260, 261, 411, 95, 166, 167, 336, 337, 338, 186, 213, 296, 212, 194, 486, 195, 542, 245, 96, 97, 98, 527, 104, 529, 158, 523, 449, 258, 158, 241, 243, 484, 101, 487, 485, 216, 274, 471, 222, 217, 472, 221, 158, 483, 465, 430, 220, 166, 167, 259, 260, 261, 262, 158, 166, 167, 336, 337, 338, 344, 156, 121, 156, 120, 464, 345, 347, 346, 349, 348, 350, 463, 373, 281, 282, 283, 236, 104, 232, 242, 242, 249, 101, 292, 301, 263, 468, 290, 302, 279, 296, 291, 288, 289, 166, 167, 259, 260, 261, 264, 317, 455, 335, 189, 351, 312, 310, 446, 453, 431, 284, 425, 335, 166, 167, 259, 260, 261, 262, 258, 466, 325, 158, 467, 450, 380, 99, 449, 158, 158, 158, 158, 158, 258, 258, 357, 379, 269, 156, 234, 420, 266, 156, 421, 409, 393, 335, 410, 394, 361, 333, 323, 362, 334, 258, 378, 156, 270, 208, 326, 101, 330, 178, 113, 332, 374, 111, 156, 375, 376, 403, 352, 110, 109, 108, 354, 355, 385, 386, 363, 356, 384, 225, 377, 425, 367, 368, 369, 370, 371, 422, 223, 364, 335, 538, 391, 335, 534, 533, 532, 335, 423, 335, 372, 413, 408, 395, 390, 166, 167, 259, 260, 261, 262, 381, 434, 528, 531, 526, 494, 429, 237, 335, 496, 335, 335, 335, 104, 104, 490, 298, 138, 158, 258, 335, 448, 156, 258, 258, 258, 258, 258, 156, 156, 156, 156, 156, 251, 192, 451, 103, 335, 454, 309, 277, 277, 360, 287, 426, 118, 352, 166, 167, 259, 260, 261, 262, 137, 387, 403, 232, 435, 436, 437, 438, 439, 440, 441, 442, 443, 444, 477, 247, 469, 406, 482, 470, 308, 269, 452, 166, 167, 336, 337, 338, 344, 335, 479, 155, 244, 155, 488, 228, 225, 499, 335, 335, 335, 335, 335, 335, 335, 335, 335, 335, 383, 497, 273, 273, 495, 502, 201, 258, 150, 151, 214, 175, 103, 103, 103, 103, 501, 190, 475, 454, 210, 172, 193, 142, 503, 197, 198, 199, 504, 510, 335, 156, 207, 403, 277, 513, 507, 508, 509, 331, 277, 482, 517, 489, 335, 520, 492, 335, 197, 218, 219, 242, 498, 335, 525, 519, 518, 516, 515, 524, 353, 155, 404, 512, 246, 155, 248, 104, 406, 417, 30, 535, 406, 511, 390, 209, 213, 335, 227, 155, 268, 93, 6, 541, 250, 335, 171, 173, 177, 82, 155, 335, 4, 475, 81, 335, 5, 273, 543, 80, 457, 459, 461, 382, 124, 79, 103, 174, 304, 295, 307, 522, 78, 77, 76, 60, 49, 242, 48, 45, 424, 322, 33, 114, 530, 118, 206, 316, 414, 321, 205, 397, 396, 300, 197, 536, 481, 135, 215, 392, 277, 277, 277, 314, 540, 116, 26, 406, 25, 353, 24, 23, 22, 21, 388, 286, 9, 8, 7, 155, 2, 404, 303, 20, 165, 155, 155, 155, 155, 155, 51, 491, 293, 268, 230, 329, 268, 268, 166, 167, 336, 337, 338, 344, 343, 457, 459, 461, 327, 345, 347, 346, 349, 348, 350, 418, 92, 256, 53, 339, 19, 55, 37, 456, 458, 460, 226, 3, 1, 0, 0, 0, 0, 0, 0, 307, 0, 405, 197, 0, 0, 0, 0, 0, 0, 277, 277, 277, 419, 0, 0, 0, 353, 0, 321, 0, 0, 0, 0, 0, 404, 0, 0, 0, 493, 0, 0, 0, 432, 166, 167, 336, 337, 338, 344, 343, 342, 341, 340, 0, 345, 347, 346, 349, 348, 350, 0, 0, 0, 155, 0, 500, 0, 0, 0, 0, 0, 0, 0, 0, 268, 0, 0, 0, 0, 0, 462, 0, 506, 458, 460, 166, 167, 336, 337, 338, 344, 343, 342, 341, 340, 0, 345, 347, 346, 349, 348, 350, 0, 0, 0, 295, 0, 0, 0, 0, 405, 480, 0, 307, 405, 0, 0, 447, 0, 0, 0, 0, 166, 167, 336, 337, 338, 344, 343, 342, 341, 340, 316, 345, 347, 346, 349, 348, 350, 0, 0, 445, 0, 0, 0, 0, 166, 167, 336, 337, 338, 344, 343, 342, 341, 340, 268, 345, 347, 346, 349, 348, 350, 0, 0, 0, 505, 0, 0, 0, 0, 0, 0, 0, 505, 505, 505, 0, 0, 0, 0, 0, 0, 0, 307, 12, 0, 0, 0, 405, 0, 0, 0, 0, 505, 0, 0, 0, 521, 10, 56, 46, 73, 86, 14, 61, 70, 91, 38, 66, 47, 42, 68, 72, 31, 67, 35, 34, 11, 88, 36, 18, 41, 39, 28, 16, 57, 58, 59, 50, 54, 43, 89, 64, 40, 69, 44, 90, 29, 62, 85, 13, 0, 83, 65, 52, 87, 27, 74, 63, 15, 433, 0, 71, 84, 0, 166, 167, 336, 337, 338, 344, 343, 342, 341, 340, 0, 345, 347, 346, 349, 348, 350, 0, 0, 0, 0, 0, 32, 0, 0, 75, 166, 167, 336, 337, 338, 344, 343, 342, 341, 340, 0, 345, 347, 346, 349, 348, 350, 73, 0, 0, 0, 70, 0, 0, 66, 0, 0, 68, 72, 0, 67, 161, 162, 163, 164, 170, 169, 168, 159, 160, 104, 0, 0, 0, 0, 0, 0, 0, 64, 0, 69, 0, 0, 0, 0, 0, 0, 0, 0, 65, 0, 0, 0, 74, 0, 0, 0, 0, 71, 161, 162, 163, 164, 170, 169, 168, 159, 160, 104, 0, 161, 162, 163, 164, 170, 169, 168, 159, 160, 104, 0, 0, 0, 0, 0, 0, 75, 0, 0, 0, 235, 0, 0, 0, 0, 0, 166, 167, 365, 0, 366, 0, 0, 0, 0, 0, 240, 161, 162, 163, 164, 170, 169, 168, 159, 160, 104, 0, 161, 162, 163, 164, 170, 169, 168, 159, 160, 104, 235, 229, 0, 0, 0, 0, 166, 167, 233, 0, 0, 235, 0, 0, 0, 0, 240, 166, 167, 476, 0, 0, 0, 0, 0, 0, 0, 240, 161, 162, 163, 164, 170, 169, 168, 159, 160, 104, 161, 162, 163, 164, 170, 169, 168, 159, 160, 104, 235, 0, 0, 0, 0, 0, 166, 167, 233, 0, 0, 235, 0, 0, 0, 0, 240, 166, 167, 428, 0, 0, 0, 0, 0, 0, 0, 240, 161, 162, 163, 164, 170, 169, 168, 159, 160, 104, 0, 161, 162, 163, 164, 170, 169, 168, 159, 160, 104, 278, 0, 0, 0, 272, 0, 166, 167, 0, 0, 0, 0, 0, 0, 0, 0, 240, 161, 162, 163, 164, 170, 169, 168, 159, 160, 104, 0, 0, 0, 0, 0, 0, 0, 0, 0, 94, 161, 162, 163, 164, 170, 169, 168, 159, 160, 104, 257, 235, 0, 0, 0, 0, 0, 166, 167, 0, 0, 0, 278, 0, 0, 0, 0, 240, 166, 167, 0, 123, 0, 0, 126, 127, 128, 0, 240, 0, 0, 0, 0, 0, 0, 0, 139, 140, 0, 324, 141, 0, 143, 144, 145, 166, 167, 146, 147, 148, 0, 149, 0, 0, 0, 240, 0, 0, 0, 252, 0, 0, 0, 0, 0, 166, 167, 254, 0, 255, 0, 179, 180, 181, 182, 183, 161, 162, 163, 164, 170, 169, 168, 159, 160, 104, 0, 161, 162, 163, 164, 170, 169, 168, 159, 160, 104, 161, 162, 163, 164, 170, 169, 168, 159, 160, 104, 161, 162, 163, 164, 170, 169, 168, 159, 160, 104, 161, 162, 163, 164, 170, 169, 168, 159, 160, 104, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 154, 0, 0, 0, 0, 0, 166, 167, 152, 0, 153, 252, 0, 0, 0, 0, 0, 166, 167, 285, 0, 154, 0, 0, 0, 0, 0, 166, 167, 176, 0, 407, 0, 0, 0, 0, 0, 166, 167, 56, 46, 252, 86, 0, 61, 0, 91, 166, 167, 47, 0, 0, 0, 0, 0, 0, 0, 0, 88, 0, 0, 0, 0, 0, 0, 57, 58, 59, 50, 0, 0, 89, 0, 0, 0, 0, 90, 0, 62, 85, 0, 0, 83, 0, 52, 87, 0, 0, 63, 0, 125, 0, 0, 84 }; short yypact[] = { -1000, 536, 524, 830,-1000,-1000,-1000,-1000,-1000,-1000, 519,-1000,-1000,-1000,-1000,-1000,-1000, 210, 496, 19, 224, 223, 222, 216, 82, 213, 16, 106,-1000,-1000, -1000,-1000,-1000,1378,-1000,-1000,-1000, 37,-1000,-1000, -1000,-1000,-1000,-1000,-1000, 496,-1000,-1000,-1000,-1000, -1000, 392,-1000,-1000,-1000,-1000,-1000,-1000,-1000,-1000, -1000,-1000,-1000,-1000,-1000,-1000,-1000,-1000,-1000,-1000, -1000,-1000,-1000,-1000,-1000,-1000,1284, 390,1305, 390, 212,-1000,-1000,-1000,-1000,-1000,-1000,-1000,-1000,-1000, -1000,-1000,-1000,-1000,-1000, 496, 496, 496, 496,-1000, 496,-1000, 302,-1000,-1000, 496,-1000, -30, 496, 496, 496, 375,-1000,-1000,-1000, 496, 208,-1000,-1000,-1000, -1000, 504, 389, 132,-1000,-1000, 379,-1000,-1000,-1000, -1000, 106, 496, 496, 375,-1000,-1000, 243, 357, 515, -1000, 356, 995,1140,1140, 353, 513, 496, 336, 496, -1000,-1000,-1000,-1000,1198,-1000,-1000, 95,1325,-1000, -1000,-1000,-1000,-1000,-1000,-1000,-1000,-1000,-1000,-1000, -1000,-1000,1198, 191, 207,-1000,-1000,1092,1151,-1000, -1000,-1000,-1000,1295, 311,-1000,-1000, 302, 302, 496, -1000,-1000, 136, 284,-1000, 82,-1000, 284,-1000,-1000, -1000, 496,-1000, 341,-1000, 307, 927, 5, 106, -6, 496, 82, 28,-1000,-1000,1178,-1000, 496,-1000,-1000, -1000,-1000,-1000,1140,-1000,1140, 411,-1000,1140,-1000, 203,-1000, 851, 513,-1000,1140,-1000,-1000,-1000,1140, 1140,-1000, 851,-1000,1140,-1000, 82, 513,-1000, 309, 202,-1000,1325,-1000,-1000,-1000, 957,-1000,1325,1325, 1325,1325,1325, -22, 256, 122, 342,-1000,-1000, 342, 342,-1000,1151, 205, 186, 175, 851,-1000,1151,-1000, -1000,-1000,-1000,-1000, 95,-1000,-1000, 321,-1000,-1000, 302,-1000,-1000, 198,-1000,-1000,-1000, 37,-1000, -3, 1315, 496,-1000, 197,-1000, 47,-1000,-1000, 341, 498, -1000, 496,-1000,-1000, 193,-1000, 242, 28,-1000,-1000, -1000, 163,1140, 851,1054,-1000, 851, 273, 96, 159, 851, 496, 825,-1000,1043,1140,1140,1140,1140,1140, 1140,1140,1140,1140,1140,-1000,-1000,-1000,-1000,-1000, -1000,-1000, 715, 157, -41, 102, 691, 289, 177,-1000, -1000,-1000,1198, 161, 851,-1000,-1000, 45, -22, -22, -22, 142,-1000, 342, 122, 151, 122,-1000,1151,1151, 1151, 654, 121, 114, 94,-1000,-1000,-1000, 173,-1000, 138,-1000, 284,-1000, 57,-1000, 90,1006,-1000,1315, -1000,-1000, 39,1102,-1000,-1000,-1000,1140,-1000,-1000, 496,-1000, 341, 93, 84,-1000, 61,-1000, 83,-1000, -1000, 496,1140,-1000, 283,1140, 612,-1000, 272, 277, 1140,1140,-1000, 513,-1000, -18, -41, -41, -41, 338, -35, -35, 541, 102, 52,-1000,1140,-1000, 513, 513, 82,-1000, 95,-1000,-1000, 342,-1000,-1000,-1000,-1000, -1000,-1000,-1000,1151,1151,1151,-1000, 503, 502, 37, -1000,-1000,1006,-1000,-1000, 21,-1000,-1000,1315,-1000, -1000,-1000,-1000, 341,-1000, 498, 498, 496,-1000, 851, 1140, 75, 851, 432,-1000,-1000,1140, 271, 851, 71, 269, 76,-1000,1140, 270, 236, 269, 252, 251, 250, -1000,-1000,-1000,-1000,1006,-1000,-1000, 17, 247,-1000, -1000,-1000, -2,1140,-1000,-1000,-1000, 513,-1000,-1000, 851,-1000,-1000,-1000,-1000,-1000, 851,-1000,-1000,-1000, 851, 66, 513,-1000 }; short yypgo[] = { 0, 654, 653, 1, 652, 167, 9, 30, 648, 647, 646, 4, 0, 645, 644, 643, 39, 642, 3, 26, 641, 634, 621, 18, 14, 620, 35, 618, 617, 29, 41, 33, 20, 362, 22, 616, 34, 352, 66, 270, 16, 57, 378, 2, 24, 25, 11, 207, 114, 610, 609, 38, 28, 43, 608, 606, 604, 603, 602,1205, 134, 601, 600, 7, 599, 598, 597, 596, 594, 592, 591, 31, 589, 19, 585, 21, 37, 6, 584, 5, 42, 583, 36, 582, 579, 12, 27, 10, 578, 577, 8, 13, 32, 576, 574, 572, 15, 569, 516, 568, 567, 566, 565, 564, 562, 561, 560, 454, 559, 558, 553, 551, 545, 540, 23, 535, 530, 17 }; short yyr1[] = { 0, 1, 1, 55, 55, 55, 55, 55, 55, 55, 2, 56, 56, 56, 56, 56, 56, 56, 60, 52, 33, 53, 53, 61, 61, 62, 62, 63, 63, 26, 26, 26, 27, 27, 34, 34, 17, 57, 57, 57, 57, 57, 57, 57, 57, 57, 57, 57, 57, 10, 10, 10, 74, 7, 8, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 16, 16, 16, 50, 50, 50, 50, 51, 51, 64, 64, 65, 65, 66, 66, 80, 54, 54, 67, 67, 81, 82, 76, 83, 84, 77, 77, 85, 85, 45, 45, 45, 70, 70, 86, 86, 72, 72, 87, 36, 18, 18, 19, 19, 75, 75, 89, 88, 88, 90, 90, 43, 43, 91, 91, 3, 68, 68, 92, 92, 95, 93, 94, 94, 96, 96, 11, 69, 69, 97, 20, 20, 71, 21, 21, 22, 22, 38, 38, 38, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 12, 12, 13, 13, 13, 13, 13, 13, 37, 37, 37, 37, 32, 40, 40, 44, 44, 48, 48, 48, 48, 48, 48, 48, 47, 49, 49, 49, 41, 41, 42, 42, 42, 42, 42, 42, 42, 42, 58, 58, 58, 58, 58, 58, 100, 58, 58, 58, 99, 23, 24, 101, 24, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 4, 102, 103, 103, 103, 103, 73, 73, 35, 25, 25, 46, 46, 14, 14, 28, 28, 59, 78, 79, 104, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 106, 113, 113, 113, 108, 115, 115, 115, 110, 110, 107, 107, 116, 116, 117, 117, 117, 117, 117, 117, 15, 109, 111, 112, 112, 29, 29, 6, 6, 30, 30, 30, 31, 31, 31, 31, 31, 31, 5, 5, 5, 5, 5, 114 }; short yyr2[] = { 0, 0, 3, 2, 2, 2, 3, 3, 2, 1, 1, 3, 4, 3, 4, 4, 5, 3, 0, 1, 1, 0, 1, 2, 3, 1, 3, 1, 3, 0, 2, 3, 1, 3, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 1, 5, 7, 5, 5, 0, 2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 4, 6, 3, 4, 5, 3, 1, 3, 3, 3, 3, 3, 3, 3, 3, 1, 3, 3, 3, 0, 6, 0, 0, 0, 2, 3, 1, 3, 1, 2, 1, 1, 3, 1, 1, 1, 3, 3, 2, 1, 5, 1, 3, 0, 3, 0, 2, 3, 1, 3, 1, 1, 1, 3, 1, 3, 3, 4, 1, 0, 2, 1, 3, 1, 3, 1, 1, 2, 4, 1, 3, 0, 0, 1, 1, 3, 1, 3, 1, 1, 1, 3, 3, 3, 3, 2, 3, 3, 3, 3, 3, 2, 3, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 4, 5, 5, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 5, 1, 1, 1, 1, 3, 1, 1, 3, 3, 3, 3, 2, 3, 1, 5, 4, 1, 2, 2, 0, 7, 2, 2, 5, 3, 1, 0, 5, 4, 5, 2, 1, 1, 10, 1, 3, 4, 3, 3, 1, 1, 3, 3, 7, 7, 0, 1, 3, 1, 3, 1, 2, 1, 1, 1, 3, 0, 0, 0, 1, 2, 2, 2, 2, 2, 2, 2, 3, 4, 4, 2, 3, 4, 1, 3, 3, 1, 1, 1, 3, 1, 1, 1, 1, 1, 3, 3, 1, 3, 1, 1, 1, 2, 2, 2, 1, 3, 3, 4, 4, 1, 3, 1, 5, 1, 1, 1, 3, 3, 3, 3, 3, 3, 1, 3, 5, 5, 5, 0 }; short yychk[] = { -1000, -1, -55, -2, 2, 6, 4, -56, -57, -58, 21, 40, 7, 63, 26, 72, 47, -7, 43, -10, -50, -64, -65, -66, -67, -68, -69, 69, 46, 60, -98, 36, 100, -99, 39, 38, 42, -8, 30, 45, 56, 44, 33, 53, 58,-102, 23, 32,-103,-104, 51, -35, 67, -14, 52, -9, 22, 48, 49, 50, -105, 27, 61, 71, 55, 66, 31, 37, 34, 57, 28, 75, 35, 24, 70, 103,-106,-108,-109,-111, -112,-113,-115, 65, 76, 62, 25, 68, 41, 54, 59, 29, -17, 8, -59, -60, -60, -60, -60, 47, -73, 81, -52, -33, 17, 81, 102, -73, 81, 81, 81, 81, -73, 81, -97, 86, -70, -86, -33, -51, 88, 86, -71, -59, -98, 73, -59, -59, -59, -16, 85, -71, -71, -71, -71, -81, -71, -37, -33, -59, -59, -59, 77, -59, -59, -59, -59, -59, -59, -59, -107, -42, 85, 87, 77, -37, -48, -41, -12, 15, 16, 8, 9, 10, 11, -49, 83, 84, 14, 13, 12,-107, 77,-107,-110, -42, 85,-107, 81, -59, -59, -59, -59, -59, -53, -52, -53, -52, -52, -60, -33, -26, 77, -33, -76, -51, -36, -33, -33, -33, -80, 77, -82, -76, -92, -93, -95, -33, 81, 17, 77, -3, -73, 9, 77, -78, -36, -51, -33, -33, -80, -82, -92, 79, -32, 77, -4, 9, 77, 78, -25, -46, -38, 85, -39, 77, -47, -37, -48, -12, 93, -40, -38, -40, 77, -3, -33, 77, -33, -41, -116, -42, 77,-117, 85, 87, -15, 18, -12, 85, 86, 87, 88, -41, -41, -29, 81, -6, -37, 77, 81, -30, 81, -39, -5, -31, -38, -47, 77, -30, -114,-114,-114,-114, -41, 85, -61, 77, -26, -26, -52, -71, 78, -27, -34, -33, 85, -75, 77, -77, -84, -73, -75, -54, -37, -19, -18, -37, 77, 77, -7, 86, -86, 86, -72, -87, -33, -73, -24, -23, 101, -33,-100, -38, 77, -36, -38, -21, -40, -22, -38, 74, -38, 78, 81, -12, 85, 86, 87, -13, 92, 91, 90, 89, 88, 94, 96, 95, 98, 97, 99, -3, -38, -39, -38, -38, -38, -73, -91, -3, 78, 78, 81, -41, -38, 85, 87, -41, -41, -41, -41, -41, 78, 81, -29, -29, -29, -30, 81, 81, 81, -38, -39, -5, -31,-114,-114, 78, -62, -63, 17, -26, -74, 78, 81, -16, -88, -89, 102, 81, -85, -45, -44, -12, -47, -33, -48, 77, -36, 78, 81, 86, 81, -19, -94, -96, -11, 17, -20, -33, 78, 81, 79, -24,-101, 79, -38, -79, 85, 78, 80, 81, -33, 78, -46, -38, -38, -38, -38, -38, -38, -38, -38, -38, -38, 78, 81, 78, 77, 81, 78,-117, -41, 78, -6, 81, -39, -5, -39, -5, -39, -5, 78, 81, 81, 81, 78, 81, 79, -75, -34, 78, 81, -90, -43, -38, 85, -85, 85, -44, -37, -83, -18, 81, 78, 81, 84, 81, -87, -38, 77, -28, -38, 78, 78, -32, 77, -40, -38, -3, -39, -91, -3, -73, -23, -33, -39, -23, -23, -23, -63, 17, -16, -90, 80, -45, -44, -77, -23, -96, -11, -33, -38, 81, 73, -79, 78, 81, 78, 78, -38, 78, 78, 78, 78, -43, -38, 86, 78, 78, -38, -3, 81, -3 }; short yydef[] = { 1, -2, 0, 0, 9, 10, 2, 3, 4, 5, 0, 242, 8, 18, 18, 18, 18, 231, 0, 37, -2, 39, 40, 41, -2, 43, 44, 45, 47, 139, 199, 242, 202, 0, 242, 242, 242, 67, 139, 139, 139, 139, 87, 139, 134, 0, 242, 242, 217, 218, 242, 220, 242, 242, 242, 54, 226, 242, 242, 242, 245, 242, 238, 239, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, 66, 0, 0, 0, 0, 259, 242, 242, 242, 242, 242, 262, 263, 264, 266, 267, 268, 6, 36, 7, 21, 21, 0, 0, 18, 0, 232, 29, 19, 20, 0, 89, 0, 232, 0, 0, 0, 89, 127, 135, 0, 46, 99, 101, 102, 74, 0, 0, 231, 203, 204, 0, 207, 208, 53, 243, 0, 0, 0, 0, 89, 127, 0, 169, 0, 216, 0, 0, 174, 174, 0, 0, 0, 0, 0, 246, -2, 248, 249, 0, 191, 192, 0, 0, 178, 179, 180, 181, 182, 183, 184, 161, 162, 186, 187, 188, 250, 0, 251, 252, -2, 270, 256, 0, 304, 304, 304, 304, 0, 11, 22, 13, 29, 29, 0, 139, 17, 0, 111, 91, 231, 73, 111, 77, 79, 81, 0, 86, 0, 124, 126, 0, 0, 0, 0, 0, 231, 0, 122, 205, 0, 70, 0, 76, 78, 80, 85, 123, 0, 170, -2, 0, 225, 0, 221, 0, 234, 236, 0, 144, 0, 146, 147, 148, 0, 0, 223, 175, 224, 0, 227, -2, 0, 233, 275, 0, 189, 0, 273, 276, 277, 0, 281, 0, 0, 0, 0, 0, 197, 275, 253, 0, 286, 288, 0, 0, 257, 0, -2, 291, 292, 0, -2, 0, 260, 261, 265, 282, 283, 304, 304, 12, 0, 14, 15, 29, 52, 30, 0, 32, 34, 35, 67, 113, 0, 0, 0, 106, 0, 83, 0, 109, 107, 0, 0, 128, 0, 100, 75, 0, 103, 0, 0, 201, 211, 212, 0, 0, 244, 0, 71, 214, 0, 0, 141, -2, 0, 0, 222, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 163, 164, 165, 166, 167, 168, 237, 0, 144, 153, 159, 0, 0, 0, 120, -2, 272, 0, 0, 278, 279, 280, 193, 194, 195, 196, 198, 271, 0, 255, 0, 254, 258, 0, 0, 0, 0, 144, 0, 0, 284, 285, 23, 0, 25, 27, 16, 111, 31, 0, 50, 0, 0, 51, 0, 92, 94, 96, 0, 98, 176, 177, 0, 72, 82, 0, 90, 0, 0, 0, 129, 131, 133, 136, 137, 48, 0, 0, 200, 0, 0, 0, 68, 0, 171, 174, 0, 215, 0, 235, 149, 150, 151, 152, -2, 155, 156, 157, 158, 160, 145, 0, 209, 0, 0, 231, 274, 275, 190, 287, 0, -2, 294, -2, 296, -2, 298, -2, 0, 0, 0, 24, 0, 0, 67, 33, 112, 0, 114, 116, 119, 118, 93, 0, 97, 84, 91, 110, 0, 125, 0, 0, 0, 104, 105, 0, 210, 240, 0, 244, 172, 174, 0, 143, 0, 144, 0, 121, 0, 0, 169, -2, 0, 0, 0, 26, 28, 49, 115, 0, 95, 96, 0, 0, 130, 132, 138, 0, 0, 206, 69, 173, 0, 185, 229, 230, 289, 301, 302, 303, 117, 119, 88, 108, 213, 241, 0, 0, 219 }; short yytok1[] = { 1, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, 91, 92, 93, 94, 95, 96, 97, 98, 99, 100, 101, 102, 103 }; short yytok2[] = { 2, 3 }; long yytok3[] = { 0 }; #define YYFLAG -1000 #define YYERROR goto yyerrlab #define YYACCEPT return(0) #define YYABORT return(1) #define yyclearin yychar = -1 #define yyerrok yyerrflag = 0 #ifdef yydebug #include "y.debug" #else #define yydebug 0 char* yytoknames[1]; /* for debugging */ char* yystates[1]; /* for debugging */ #endif /* parser for yacc output */ int yynerrs = 0; /* number of errors */ int yyerrflag = 0; /* error recovery flag */ extern int fprint(int, char*, ...); extern int sprint(char*, char*, ...); char* yytokname(int yyc) { static char x[10]; if(yyc > 0 && yyc <= sizeof(yytoknames)/sizeof(yytoknames[0])) if(yytoknames[yyc-1]) return yytoknames[yyc-1]; sprintf(x, "<%d>", yyc); return x; } char* yystatname(int yys) { static char x[10]; if(yys >= 0 && yys < sizeof(yystates)/sizeof(yystates[0])) if(yystates[yys]) return yystates[yys]; sprintf(x, "<%d>\n", yys); return x; } long yylex1(void) { long yychar; long *t3p; int c; yychar = yylex(); if(yychar <= 0) { c = yytok1[0]; goto out; } if(yychar < sizeof(yytok1)/sizeof(yytok1[0])) { c = yytok1[yychar]; goto out; } if(yychar >= YYPRIVATE) if(yychar < YYPRIVATE+sizeof(yytok2)/sizeof(yytok2[0])) { c = yytok2[yychar-YYPRIVATE]; goto out; } for(t3p=yytok3;; t3p+=2) { c = t3p[0]; if(c == yychar) { c = t3p[1]; goto out; } if(c == 0) break; } c = 0; out: if(c == 0) c = yytok2[1]; /* unknown char */ if(yydebug >= 3) printf("lex %.4lX %s\n", yychar, yytokname(c)); return c; } int yyparse(void) { struct { YYSTYPE yyv; int yys; } yys[YYMAXDEPTH], *yyp, *yypt; short *yyxi; int yyj, yym, yystate, yyn, yyg; YYSTYPE save1, save2; int save3, save4; long yychar; save1 = yylval; save2 = yyval; save3 = yynerrs; save4 = yyerrflag; yystate = 0; yychar = -1; yynerrs = 0; yyerrflag = 0; yyp = &yys[-1]; goto yystack; ret0: yyn = 0; goto ret; ret1: yyn = 1; goto ret; ret: yylval = save1; yyval = save2; yynerrs = save3; yyerrflag = save4; return yyn; yystack: /* put a state and value onto the stack */ if(yydebug >= 4) printf("char %s in %s", yytokname(yychar), yystatname(yystate)); yyp++; if(yyp >= &yys[YYMAXDEPTH]) { yyerror("yacc stack overflow"); goto ret1; } yyp->yys = yystate; yyp->yyv = yyval; yynewstate: yyn = yypact[yystate]; if(yyn <= YYFLAG) goto yydefault; /* simple state */ if(yychar < 0) yychar = yylex1(); yyn += yychar; if(yyn < 0 || yyn >= YYLAST) goto yydefault; yyn = yyact[yyn]; if(yychk[yyn] == yychar) { /* valid shift */ yychar = -1; yyval = yylval; yystate = yyn; if(yyerrflag > 0) yyerrflag--; goto yystack; } yydefault: /* default state action */ yyn = yydef[yystate]; if(yyn == -2) { if(yychar < 0) yychar = yylex1(); /* look through exception table */ for(yyxi=yyexca;; yyxi+=2) if(yyxi[0] == -1 && yyxi[1] == yystate) break; for(yyxi += 2;; yyxi += 2) { yyn = yyxi[0]; if(yyn < 0 || yyn == yychar) break; } yyn = yyxi[1]; if(yyn < 0) goto ret0; } if(yyn == 0) { /* error ... attempt to resume parsing */ switch(yyerrflag) { case 0: /* brand new error */ yyerror("syntax error"); if(yydebug >= 1) { printf("%s", yystatname(yystate)); printf("saw %s\n", yytokname(yychar)); } yyerrlab: yynerrs++; case 1: case 2: /* incompletely recovered error ... try again */ yyerrflag = 3; /* find a state where "error" is a legal shift action */ while(yyp >= yys) { yyn = yypact[yyp->yys] + YYERRCODE; if(yyn >= 0 && yyn < YYLAST) { yystate = yyact[yyn]; /* simulate a shift of "error" */ if(yychk[yystate] == YYERRCODE) goto yystack; } /* the current yyp has no shift onn "error", pop stack */ if(yydebug >= 2) printf("error recovery pops state %d, uncovers %d\n", yyp->yys, (yyp-1)->yys ); yyp--; } /* there is no state on the stack with an error shift ... abort */ goto ret1; case 3: /* no shift yet; clobber input char */ if(yydebug >= YYEOFCODE) printf("error recovery discards %s\n", yytokname(yychar)); if(yychar == YYEOFCODE) goto ret1; yychar = -1; goto yynewstate; /* try again in the same state */ } } /* reduction by production yyn */ if(yydebug >= 2) printf("reduce %d in:\n\t%s", yyn, yystatname(yystate)); yypt = yyp; yyp -= yyr2[yyn]; yyval = (yyp+1)->yyv; yym = yyn; /* consult goto table to find next state */ yyn = yyr1[yyn]; yyg = yypgo[yyn]; yyj = yyg + yyp->yys + 1; if(yyj >= YYLAST || yychk[yystate=yyact[yyj]] != -yyn) yystate = yyact[yyg]; switch(yym) { case 3: /* #line 220 "/n/bopp/v5/dmg/f2c/gram.in" */ { /* stat: is the nonterminal for Fortran statements */ lastwasbranch = NO; } break; case 5: /* #line 226 "/n/bopp/v5/dmg/f2c/gram.in" */ { /* forbid further statement function definitions... */ if (parstate == INDATA && laststfcn != thisstno) parstate = INEXEC; thisstno++; if(yypt[-1].yyv.labval && (yypt[-1].yyv.labval->labelno==dorange)) enddo(yypt[-1].yyv.labval->labelno); if(lastwasbranch && thislabel==NULL) warn("statement cannot be reached"); lastwasbranch = thiswasbranch; thiswasbranch = NO; if(yypt[-1].yyv.labval) { if(yypt[-1].yyv.labval->labtype == LABFORMAT) err("label already that of a format"); else yypt[-1].yyv.labval->labtype = LABEXEC; } freetemps(); } break; case 6: /* #line 246 "/n/bopp/v5/dmg/f2c/gram.in" */ { if (can_include) doinclude( yypt[-0].yyv.charpval ); else { fprintf(diagfile, "Cannot open file %s\n", yypt[-0].yyv.charpval); done(1); } } break; case 7: /* #line 254 "/n/bopp/v5/dmg/f2c/gram.in" */ { if (yypt[-2].yyv.labval) lastwasbranch = NO; endcheck(); endproc(); /* lastwasbranch = NO; -- set in endproc() */ } break; case 8: /* #line 260 "/n/bopp/v5/dmg/f2c/gram.in" */ { unclassifiable(); /* flline flushes the current line, ignoring the rest of the text there */ flline(); } break; case 9: /* #line 266 "/n/bopp/v5/dmg/f2c/gram.in" */ { flline(); needkwd = NO; inioctl = NO; yyerrok; yyclearin; } break; case 10: /* #line 271 "/n/bopp/v5/dmg/f2c/gram.in" */ { if(yystno != 0) { yyval.labval = thislabel = mklabel(yystno); if( ! headerdone ) { if (procclass == CLUNKNOWN) procclass = CLMAIN; puthead(CNULL, procclass); } if(thislabel->labdefined) execerr("label %s already defined", convic(thislabel->stateno) ); else { if(thislabel->blklevel!=0 && thislabel->blklevellabtype!=LABFORMAT) warn1("there is a branch to label %s from outside block", convic( (ftnint) (thislabel->stateno) ) ); thislabel->blklevel = blklevel; thislabel->labdefined = YES; if(thislabel->labtype != LABFORMAT) p1_label((long)(thislabel - labeltab)); } } else yyval.labval = thislabel = NULL; } break; case 11: /* #line 299 "/n/bopp/v5/dmg/f2c/gram.in" */ {startproc(yypt[-0].yyv.extval, CLMAIN); } break; case 12: /* #line 301 "/n/bopp/v5/dmg/f2c/gram.in" */ { warn("ignoring arguments to main program"); /* hashclear(); */ startproc(yypt[-1].yyv.extval, CLMAIN); } break; case 13: /* #line 305 "/n/bopp/v5/dmg/f2c/gram.in" */ { if(yypt[-0].yyv.extval) NO66("named BLOCKDATA"); startproc(yypt[-0].yyv.extval, CLBLOCK); } break; case 14: /* #line 308 "/n/bopp/v5/dmg/f2c/gram.in" */ { entrypt(CLPROC, TYSUBR, (ftnint) 0, yypt[-1].yyv.extval, yypt[-0].yyv.chval); } break; case 15: /* #line 310 "/n/bopp/v5/dmg/f2c/gram.in" */ { entrypt(CLPROC, TYUNKNOWN, (ftnint) 0, yypt[-1].yyv.extval, yypt[-0].yyv.chval); } break; case 16: /* #line 312 "/n/bopp/v5/dmg/f2c/gram.in" */ { entrypt(CLPROC, yypt[-4].yyv.ival, varleng, yypt[-1].yyv.extval, yypt[-0].yyv.chval); } break; case 17: /* #line 314 "/n/bopp/v5/dmg/f2c/gram.in" */ { if(parstate==OUTSIDE || procclass==CLMAIN || procclass==CLBLOCK) execerr("misplaced entry statement", CNULL); entrypt(CLENTRY, 0, (ftnint) 0, yypt[-1].yyv.extval, yypt[-0].yyv.chval); } break; case 18: /* #line 322 "/n/bopp/v5/dmg/f2c/gram.in" */ { newproc(); } break; case 19: /* #line 326 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.extval = newentry(yypt[-0].yyv.namval, 1); } break; case 20: /* #line 330 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.namval = mkname(token); } break; case 21: /* #line 333 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.extval = NULL; } break; case 29: /* #line 351 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.chval = 0; } break; case 30: /* #line 353 "/n/bopp/v5/dmg/f2c/gram.in" */ { NO66(" () argument list"); yyval.chval = 0; } break; case 31: /* #line 356 "/n/bopp/v5/dmg/f2c/gram.in" */ {yyval.chval = yypt[-1].yyv.chval; } break; case 32: /* #line 360 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.chval = (yypt[-0].yyv.namval ? mkchain((char *)yypt[-0].yyv.namval,CHNULL) : CHNULL ); } break; case 33: /* #line 362 "/n/bopp/v5/dmg/f2c/gram.in" */ { if(yypt[-0].yyv.namval) yypt[-2].yyv.chval = yyval.chval = mkchain((char *)yypt[-0].yyv.namval, yypt[-2].yyv.chval); } break; case 34: /* #line 366 "/n/bopp/v5/dmg/f2c/gram.in" */ { if(yypt[-0].yyv.namval->vstg!=STGUNKNOWN && yypt[-0].yyv.namval->vstg!=STGARG) dclerr("name declared as argument after use", yypt[-0].yyv.namval); yypt[-0].yyv.namval->vstg = STGARG; } break; case 35: /* #line 371 "/n/bopp/v5/dmg/f2c/gram.in" */ { NO66("altenate return argument"); /* substars means that '*'ed formal parameters should be replaced. This is used to specify alternate return labels; in theory, only parameter slots which have '*' should accept the statement labels. This compiler chooses to ignore the '*'s in the formal declaration, and always return the proper value anyway. This variable is only referred to in proc.c */ yyval.namval = 0; substars = YES; } break; case 36: /* #line 387 "/n/bopp/v5/dmg/f2c/gram.in" */ { char *s; s = copyn(toklen+1, token); s[toklen] = '\0'; yyval.charpval = s; } break; case 45: /* #line 403 "/n/bopp/v5/dmg/f2c/gram.in" */ { NO66("SAVE statement"); saveall = YES; } break; case 46: /* #line 406 "/n/bopp/v5/dmg/f2c/gram.in" */ { NO66("SAVE statement"); } break; case 47: /* #line 408 "/n/bopp/v5/dmg/f2c/gram.in" */ { fmtstmt(thislabel); setfmt(thislabel); } break; case 48: /* #line 410 "/n/bopp/v5/dmg/f2c/gram.in" */ { NO66("PARAMETER statement"); } break; case 49: /* #line 414 "/n/bopp/v5/dmg/f2c/gram.in" */ { settype(yypt[-4].yyv.namval, yypt[-6].yyv.ival, yypt[-0].yyv.lval); if(ndim>0) setbound(yypt[-4].yyv.namval,ndim,dims); } break; case 50: /* #line 418 "/n/bopp/v5/dmg/f2c/gram.in" */ { settype(yypt[-2].yyv.namval, yypt[-4].yyv.ival, yypt[-0].yyv.lval); if(ndim>0) setbound(yypt[-2].yyv.namval,ndim,dims); } break; case 51: /* #line 422 "/n/bopp/v5/dmg/f2c/gram.in" */ { if (new_dcl == 2) { err("attempt to give DATA in type-declaration"); new_dcl = 1; } } break; case 52: /* #line 429 "/n/bopp/v5/dmg/f2c/gram.in" */ { new_dcl = 2; } break; case 53: /* #line 432 "/n/bopp/v5/dmg/f2c/gram.in" */ { varleng = yypt[-0].yyv.lval; } break; case 54: /* #line 436 "/n/bopp/v5/dmg/f2c/gram.in" */ { varleng = (yypt[-0].yyv.ival<0 || ONEOF(yypt[-0].yyv.ival,M(TYLOGICAL)|M(TYLONG)) ? 0 : typesize[yypt[-0].yyv.ival]); vartype = yypt[-0].yyv.ival; } break; case 55: /* #line 441 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.ival = TYLONG; } break; case 56: /* #line 442 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.ival = tyreal; } break; case 57: /* #line 443 "/n/bopp/v5/dmg/f2c/gram.in" */ { ++complex_seen; yyval.ival = tycomplex; } break; case 58: /* #line 444 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.ival = TYDREAL; } break; case 59: /* #line 445 "/n/bopp/v5/dmg/f2c/gram.in" */ { ++dcomplex_seen; NOEXT("DOUBLE COMPLEX statement"); yyval.ival = TYDCOMPLEX; } break; case 60: /* #line 446 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.ival = TYLOGICAL; } break; case 61: /* #line 447 "/n/bopp/v5/dmg/f2c/gram.in" */ { NO66("CHARACTER statement"); yyval.ival = TYCHAR; } break; case 62: /* #line 448 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.ival = TYUNKNOWN; } break; case 63: /* #line 449 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.ival = TYUNKNOWN; } break; case 64: /* #line 450 "/n/bopp/v5/dmg/f2c/gram.in" */ { NOEXT("AUTOMATIC statement"); yyval.ival = - STGAUTO; } break; case 65: /* #line 451 "/n/bopp/v5/dmg/f2c/gram.in" */ { NOEXT("STATIC statement"); yyval.ival = - STGBSS; } break; case 66: /* #line 452 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.ival = TYINT1; } break; case 67: /* #line 456 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.lval = varleng; } break; case 68: /* #line 458 "/n/bopp/v5/dmg/f2c/gram.in" */ { expptr p; p = yypt[-1].yyv.expval; NO66("length specification *n"); if( ! ISICON(p) || p->constblock.Const.ci <= 0 ) { yyval.lval = 0; dclerr("length must be a positive integer constant", NPNULL); } else { if (vartype == TYCHAR) yyval.lval = p->constblock.Const.ci; else switch((int)p->constblock.Const.ci) { case 1: yyval.lval = 1; break; case 2: yyval.lval = typesize[TYSHORT]; break; case 4: yyval.lval = typesize[TYLONG]; break; case 8: yyval.lval = typesize[TYDREAL]; break; case 16: yyval.lval = typesize[TYDCOMPLEX]; break; default: dclerr("invalid length",NPNULL); yyval.lval = varleng; } } } break; case 69: /* #line 484 "/n/bopp/v5/dmg/f2c/gram.in" */ { NO66("length specification *(*)"); yyval.lval = -1; } break; case 70: /* #line 488 "/n/bopp/v5/dmg/f2c/gram.in" */ { incomm( yyval.extval = comblock("") , yypt[-0].yyv.namval ); } break; case 71: /* #line 490 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.extval = yypt[-1].yyv.extval; incomm(yypt[-1].yyv.extval, yypt[-0].yyv.namval); } break; case 72: /* #line 492 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.extval = yypt[-2].yyv.extval; incomm(yypt[-2].yyv.extval, yypt[-0].yyv.namval); } break; case 73: /* #line 494 "/n/bopp/v5/dmg/f2c/gram.in" */ { incomm(yypt[-2].yyv.extval, yypt[-0].yyv.namval); } break; case 74: /* #line 498 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.extval = comblock(""); } break; case 75: /* #line 500 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.extval = comblock(token); } break; case 76: /* #line 504 "/n/bopp/v5/dmg/f2c/gram.in" */ { setext(yypt[-0].yyv.namval); } break; case 77: /* #line 506 "/n/bopp/v5/dmg/f2c/gram.in" */ { setext(yypt[-0].yyv.namval); } break; case 78: /* #line 510 "/n/bopp/v5/dmg/f2c/gram.in" */ { NO66("INTRINSIC statement"); setintr(yypt[-0].yyv.namval); } break; case 79: /* #line 512 "/n/bopp/v5/dmg/f2c/gram.in" */ { setintr(yypt[-0].yyv.namval); } break; case 82: /* #line 520 "/n/bopp/v5/dmg/f2c/gram.in" */ { struct Equivblock *p; if(nequiv >= maxequiv) many("equivalences", 'q', maxequiv); p = & eqvclass[nequiv++]; p->eqvinit = NO; p->eqvbottom = 0; p->eqvtop = 0; p->equivs = yypt[-1].yyv.eqvval; } break; case 83: /* #line 533 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.eqvval=ALLOC(Eqvchain); yyval.eqvval->eqvitem.eqvlhs = primchk(yypt[-0].yyv.expval); } break; case 84: /* #line 537 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.eqvval=ALLOC(Eqvchain); yyval.eqvval->eqvitem.eqvlhs = primchk(yypt[-0].yyv.expval); yyval.eqvval->eqvnextp = yypt[-2].yyv.eqvval; } break; case 87: /* #line 548 "/n/bopp/v5/dmg/f2c/gram.in" */ { if(parstate == OUTSIDE) { newproc(); startproc(ESNULL, CLMAIN); } if(parstate < INDATA) { enddcl(); parstate = INDATA; datagripe = 1; } } break; case 88: /* #line 563 "/n/bopp/v5/dmg/f2c/gram.in" */ { ftnint junk; if(nextdata(&junk) != NULL) err("too few initializers"); frdata(yypt[-4].yyv.chval); frrpl(); } break; case 89: /* #line 571 "/n/bopp/v5/dmg/f2c/gram.in" */ { frchain(&datastack); curdtp = 0; } break; case 90: /* #line 573 "/n/bopp/v5/dmg/f2c/gram.in" */ { pop_datastack(); } break; case 91: /* #line 575 "/n/bopp/v5/dmg/f2c/gram.in" */ { toomanyinit = NO; } break; case 94: /* #line 580 "/n/bopp/v5/dmg/f2c/gram.in" */ { dataval(ENULL, yypt[-0].yyv.expval); } break; case 95: /* #line 582 "/n/bopp/v5/dmg/f2c/gram.in" */ { dataval(yypt[-2].yyv.expval, yypt[-0].yyv.expval); } break; case 97: /* #line 587 "/n/bopp/v5/dmg/f2c/gram.in" */ { if( yypt[-1].yyv.ival==OPMINUS && ISCONST(yypt[-0].yyv.expval) ) consnegop((Constp)yypt[-0].yyv.expval); yyval.expval = yypt[-0].yyv.expval; } break; case 101: /* #line 599 "/n/bopp/v5/dmg/f2c/gram.in" */ { int k; yypt[-0].yyv.namval->vsave = YES; k = yypt[-0].yyv.namval->vstg; if( ! ONEOF(k, M(STGUNKNOWN)|M(STGBSS)|M(STGINIT)) ) dclerr("can only save static variables", yypt[-0].yyv.namval); } break; case 105: /* #line 613 "/n/bopp/v5/dmg/f2c/gram.in" */ { if(yypt[-2].yyv.namval->vclass == CLUNKNOWN) make_param((struct Paramblock *)yypt[-2].yyv.namval, yypt[-0].yyv.expval); else dclerr("cannot make into parameter", yypt[-2].yyv.namval); } break; case 106: /* #line 620 "/n/bopp/v5/dmg/f2c/gram.in" */ { if(ndim>0) setbound(yypt[-1].yyv.namval, ndim, dims); } break; case 107: /* #line 624 "/n/bopp/v5/dmg/f2c/gram.in" */ { Namep np; struct Primblock *pp = (struct Primblock *)yypt[-0].yyv.expval; int tt = yypt[-0].yyv.expval->tag; if (tt != TPRIM) { if (tt == TCONST) err("parameter in data statement"); else erri("tag %d in data statement",tt); yyval.chval = 0; err_lineno = lineno; break; } np = pp -> namep; vardcl(np); if ((pp->fcharp || pp->lcharp) && (np->vtype != TYCHAR || np->vdim && !pp->argsp)) sserr(np); if(np->vstg == STGCOMMON) extsymtab[np->vardesc.varno].extinit = YES; else if(np->vstg==STGEQUIV) eqvclass[np->vardesc.varno].eqvinit = YES; else if(np->vstg!=STGINIT && np->vstg!=STGBSS) { errstr(np->vstg == STGARG ? "Dummy argument \"%.60s\" in data statement." : "Cannot give data to \"%.75s\"", np->fvarname); yyval.chval = 0; err_lineno = lineno; break; } yyval.chval = mkchain((char *)yypt[-0].yyv.expval, CHNULL); } break; case 108: /* #line 657 "/n/bopp/v5/dmg/f2c/gram.in" */ { chainp p; struct Impldoblock *q; pop_datastack(); q = ALLOC(Impldoblock); q->tag = TIMPLDO; (q->varnp = (Namep) (yypt[-1].yyv.chval->datap))->vimpldovar = 1; p = yypt[-1].yyv.chval->nextp; if(p) { q->implb = (expptr)(p->datap); p = p->nextp; } if(p) { q->impub = (expptr)(p->datap); p = p->nextp; } if(p) { q->impstep = (expptr)(p->datap); } frchain( & (yypt[-1].yyv.chval) ); yyval.chval = mkchain((char *)q, CHNULL); q->datalist = hookup(yypt[-3].yyv.chval, yyval.chval); } break; case 109: /* #line 673 "/n/bopp/v5/dmg/f2c/gram.in" */ { if (!datastack) curdtp = 0; datastack = mkchain((char *)curdtp, datastack); curdtp = yypt[-0].yyv.chval; curdtelt = 0; } break; case 110: /* #line 679 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.chval = hookup(yypt[-2].yyv.chval, yypt[-0].yyv.chval); } break; case 111: /* #line 683 "/n/bopp/v5/dmg/f2c/gram.in" */ { ndim = 0; } break; case 113: /* #line 687 "/n/bopp/v5/dmg/f2c/gram.in" */ { ndim = 0; } break; case 116: /* #line 692 "/n/bopp/v5/dmg/f2c/gram.in" */ { if(ndim == maxdim) err("too many dimensions"); else if(ndim < maxdim) { dims[ndim].lb = 0; dims[ndim].ub = yypt[-0].yyv.expval; } ++ndim; } break; case 117: /* #line 702 "/n/bopp/v5/dmg/f2c/gram.in" */ { if(ndim == maxdim) err("too many dimensions"); else if(ndim < maxdim) { dims[ndim].lb = yypt[-2].yyv.expval; dims[ndim].ub = yypt[-0].yyv.expval; } ++ndim; } break; case 118: /* #line 714 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.expval = 0; } break; case 120: /* #line 719 "/n/bopp/v5/dmg/f2c/gram.in" */ { nstars = 1; labarray[0] = yypt[-0].yyv.labval; } break; case 121: /* #line 721 "/n/bopp/v5/dmg/f2c/gram.in" */ { if(nstars < maxlablist) labarray[nstars++] = yypt[-0].yyv.labval; } break; case 122: /* #line 725 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.labval = execlab( convci(toklen, token) ); } break; case 123: /* #line 729 "/n/bopp/v5/dmg/f2c/gram.in" */ { NO66("IMPLICIT statement"); } break; case 126: /* #line 735 "/n/bopp/v5/dmg/f2c/gram.in" */ { if (vartype != TYUNKNOWN) dclerr("-- expected letter range",NPNULL); setimpl(vartype, varleng, 'a', 'z'); } break; case 127: /* #line 740 "/n/bopp/v5/dmg/f2c/gram.in" */ { needkwd = 1; } break; case 131: /* #line 749 "/n/bopp/v5/dmg/f2c/gram.in" */ { setimpl(vartype, varleng, yypt[-0].yyv.ival, yypt[-0].yyv.ival); } break; case 132: /* #line 751 "/n/bopp/v5/dmg/f2c/gram.in" */ { setimpl(vartype, varleng, yypt[-2].yyv.ival, yypt[-0].yyv.ival); } break; case 133: /* #line 755 "/n/bopp/v5/dmg/f2c/gram.in" */ { if(toklen!=1 || token[0]<'a' || token[0]>'z') { dclerr("implicit item must be single letter", NPNULL); yyval.ival = 0; } else yyval.ival = token[0]; } break; case 136: /* #line 769 "/n/bopp/v5/dmg/f2c/gram.in" */ { if(yypt[-2].yyv.namval->vclass == CLUNKNOWN) { yypt[-2].yyv.namval->vclass = CLNAMELIST; yypt[-2].yyv.namval->vtype = TYINT; yypt[-2].yyv.namval->vstg = STGBSS; yypt[-2].yyv.namval->varxptr.namelist = yypt[-0].yyv.chval; yypt[-2].yyv.namval->vardesc.varno = ++lastvarno; } else dclerr("cannot be a namelist name", yypt[-2].yyv.namval); } break; case 137: /* #line 783 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.chval = mkchain((char *)yypt[-0].yyv.namval, CHNULL); } break; case 138: /* #line 785 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.chval = hookup(yypt[-2].yyv.chval, mkchain((char *)yypt[-0].yyv.namval, CHNULL)); } break; case 139: /* #line 789 "/n/bopp/v5/dmg/f2c/gram.in" */ { switch(parstate) { case OUTSIDE: newproc(); startproc(ESNULL, CLMAIN); case INSIDE: parstate = INDCL; case INDCL: break; case INDATA: if (datagripe) { errstr( "Statement order error: declaration after DATA", CNULL); datagripe = 0; } break; default: dclerr("declaration among executables", NPNULL); } } break; case 140: /* #line 811 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.chval = 0; } break; case 141: /* #line 813 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.chval = revchain(yypt[-0].yyv.chval); } break; case 142: /* #line 817 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.chval = mkchain((char *)yypt[-0].yyv.expval, CHNULL); } break; case 143: /* #line 819 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.chval = mkchain((char *)yypt[-0].yyv.expval, yypt[-2].yyv.chval); } break; case 145: /* #line 824 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.expval = yypt[-1].yyv.expval; if (yyval.expval->tag == TPRIM) paren_used(&yyval.expval->primblock); } break; case 149: /* #line 832 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.expval = mkexpr(yypt[-1].yyv.ival, yypt[-2].yyv.expval, yypt[-0].yyv.expval); } break; case 150: /* #line 834 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.expval = mkexpr(OPSTAR, yypt[-2].yyv.expval, yypt[-0].yyv.expval); } break; case 151: /* #line 836 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.expval = mkexpr(OPSLASH, yypt[-2].yyv.expval, yypt[-0].yyv.expval); } break; case 152: /* #line 838 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.expval = mkexpr(OPPOWER, yypt[-2].yyv.expval, yypt[-0].yyv.expval); } break; case 153: /* #line 840 "/n/bopp/v5/dmg/f2c/gram.in" */ { if(yypt[-1].yyv.ival == OPMINUS) yyval.expval = mkexpr(OPNEG, yypt[-0].yyv.expval, ENULL); else { yyval.expval = yypt[-0].yyv.expval; if (yyval.expval->tag == TPRIM) paren_used(&yyval.expval->primblock); } } break; case 154: /* #line 849 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.expval = mkexpr(yypt[-1].yyv.ival, yypt[-2].yyv.expval, yypt[-0].yyv.expval); } break; case 155: /* #line 851 "/n/bopp/v5/dmg/f2c/gram.in" */ { NO66(".EQV. operator"); yyval.expval = mkexpr(OPEQV, yypt[-2].yyv.expval,yypt[-0].yyv.expval); } break; case 156: /* #line 854 "/n/bopp/v5/dmg/f2c/gram.in" */ { NO66(".NEQV. operator"); yyval.expval = mkexpr(OPNEQV, yypt[-2].yyv.expval, yypt[-0].yyv.expval); } break; case 157: /* #line 857 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.expval = mkexpr(OPOR, yypt[-2].yyv.expval, yypt[-0].yyv.expval); } break; case 158: /* #line 859 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.expval = mkexpr(OPAND, yypt[-2].yyv.expval, yypt[-0].yyv.expval); } break; case 159: /* #line 861 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.expval = mkexpr(OPNOT, yypt[-0].yyv.expval, ENULL); } break; case 160: /* #line 863 "/n/bopp/v5/dmg/f2c/gram.in" */ { NO66("concatenation operator //"); yyval.expval = mkexpr(OPCONCAT, yypt[-2].yyv.expval, yypt[-0].yyv.expval); } break; case 161: /* #line 867 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.ival = OPPLUS; } break; case 162: /* #line 868 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.ival = OPMINUS; } break; case 163: /* #line 871 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.ival = OPEQ; } break; case 164: /* #line 872 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.ival = OPGT; } break; case 165: /* #line 873 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.ival = OPLT; } break; case 166: /* #line 874 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.ival = OPGE; } break; case 167: /* #line 875 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.ival = OPLE; } break; case 168: /* #line 876 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.ival = OPNE; } break; case 169: /* #line 880 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.expval = mkprim(yypt[-0].yyv.namval, LBNULL, CHNULL); } break; case 170: /* #line 882 "/n/bopp/v5/dmg/f2c/gram.in" */ { NO66("substring operator :"); yyval.expval = mkprim(yypt[-1].yyv.namval, LBNULL, yypt[-0].yyv.chval); } break; case 171: /* #line 885 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.expval = mkprim(yypt[-3].yyv.namval, mklist(yypt[-1].yyv.chval), CHNULL); } break; case 172: /* #line 887 "/n/bopp/v5/dmg/f2c/gram.in" */ { NO66("substring operator :"); yyval.expval = mkprim(yypt[-4].yyv.namval, mklist(yypt[-2].yyv.chval), yypt[-0].yyv.chval); } break; case 173: /* #line 892 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.chval = mkchain((char *)yypt[-3].yyv.expval, mkchain((char *)yypt[-1].yyv.expval,CHNULL)); } break; case 174: /* #line 896 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.expval = 0; } break; case 176: /* #line 901 "/n/bopp/v5/dmg/f2c/gram.in" */ { if(yypt[-0].yyv.namval->vclass == CLPARAM) yyval.expval = (expptr) cpexpr( ( (struct Paramblock *) (yypt[-0].yyv.namval) ) -> paramval); } break; case 178: /* #line 908 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.expval = mklogcon(1); } break; case 179: /* #line 909 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.expval = mklogcon(0); } break; case 180: /* #line 910 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.expval = mkstrcon(toklen, token); } break; case 181: /* #line 911 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.expval = mkintqcon(toklen, token); } break; case 182: /* #line 912 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.expval = mkrealcon(tyreal, token); } break; case 183: /* #line 913 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.expval = mkrealcon(TYDREAL, token); } break; case 185: /* #line 918 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.expval = mkcxcon(yypt[-3].yyv.expval,yypt[-1].yyv.expval); } break; case 186: /* #line 922 "/n/bopp/v5/dmg/f2c/gram.in" */ { NOEXT("hex constant"); yyval.expval = mkbitcon(4, toklen, token); } break; case 187: /* #line 925 "/n/bopp/v5/dmg/f2c/gram.in" */ { NOEXT("octal constant"); yyval.expval = mkbitcon(3, toklen, token); } break; case 188: /* #line 928 "/n/bopp/v5/dmg/f2c/gram.in" */ { NOEXT("binary constant"); yyval.expval = mkbitcon(1, toklen, token); } break; case 190: /* #line 934 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.expval = yypt[-1].yyv.expval; } break; case 193: /* #line 940 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.expval = mkexpr(yypt[-1].yyv.ival, yypt[-2].yyv.expval, yypt[-0].yyv.expval); } break; case 194: /* #line 942 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.expval = mkexpr(OPSTAR, yypt[-2].yyv.expval, yypt[-0].yyv.expval); } break; case 195: /* #line 944 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.expval = mkexpr(OPSLASH, yypt[-2].yyv.expval, yypt[-0].yyv.expval); } break; case 196: /* #line 946 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.expval = mkexpr(OPPOWER, yypt[-2].yyv.expval, yypt[-0].yyv.expval); } break; case 197: /* #line 948 "/n/bopp/v5/dmg/f2c/gram.in" */ { if(yypt[-1].yyv.ival == OPMINUS) yyval.expval = mkexpr(OPNEG, yypt[-0].yyv.expval, ENULL); else yyval.expval = yypt[-0].yyv.expval; } break; case 198: /* #line 953 "/n/bopp/v5/dmg/f2c/gram.in" */ { NO66("concatenation operator //"); yyval.expval = mkexpr(OPCONCAT, yypt[-2].yyv.expval, yypt[-0].yyv.expval); } break; case 200: /* #line 958 "/n/bopp/v5/dmg/f2c/gram.in" */ { if(yypt[-2].yyv.labval->labdefined) execerr("no backward DO loops", CNULL); yypt[-2].yyv.labval->blklevel = blklevel+1; exdo(yypt[-2].yyv.labval->labelno, NPNULL, yypt[-0].yyv.chval); } break; case 201: /* #line 965 "/n/bopp/v5/dmg/f2c/gram.in" */ { exdo((int)(ctls - ctlstack - 2), NPNULL, yypt[-0].yyv.chval); NOEXT("DO without label"); } break; case 202: /* #line 970 "/n/bopp/v5/dmg/f2c/gram.in" */ { exenddo(NPNULL); } break; case 203: /* #line 972 "/n/bopp/v5/dmg/f2c/gram.in" */ { exendif(); thiswasbranch = NO; } break; case 205: /* #line 974 "/n/bopp/v5/dmg/f2c/gram.in" */ {westart(1);} break; case 206: /* #line 975 "/n/bopp/v5/dmg/f2c/gram.in" */ { exelif(yypt[-2].yyv.expval); lastwasbranch = NO; } break; case 207: /* #line 977 "/n/bopp/v5/dmg/f2c/gram.in" */ { exelse(); lastwasbranch = NO; } break; case 208: /* #line 979 "/n/bopp/v5/dmg/f2c/gram.in" */ { exendif(); lastwasbranch = NO; } break; case 209: /* #line 983 "/n/bopp/v5/dmg/f2c/gram.in" */ { exif(yypt[-1].yyv.expval); } break; case 210: /* #line 987 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.chval = mkchain((char *)yypt[-2].yyv.namval, yypt[-0].yyv.chval); } break; case 212: /* #line 991 "/n/bopp/v5/dmg/f2c/gram.in" */ {westart(0);} break; case 213: /* #line 992 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.chval = mkchain(CNULL, (chainp)yypt[-1].yyv.expval); } break; case 214: /* #line 996 "/n/bopp/v5/dmg/f2c/gram.in" */ { exequals((struct Primblock *)yypt[-2].yyv.expval, yypt[-0].yyv.expval); } break; case 215: /* #line 998 "/n/bopp/v5/dmg/f2c/gram.in" */ { exassign(yypt[-0].yyv.namval, yypt[-2].yyv.labval); } break; case 218: /* #line 1002 "/n/bopp/v5/dmg/f2c/gram.in" */ { inioctl = NO; } break; case 219: /* #line 1004 "/n/bopp/v5/dmg/f2c/gram.in" */ { exarif(yypt[-6].yyv.expval, yypt[-4].yyv.labval, yypt[-2].yyv.labval, yypt[-0].yyv.labval); thiswasbranch = YES; } break; case 220: /* #line 1006 "/n/bopp/v5/dmg/f2c/gram.in" */ { excall(yypt[-0].yyv.namval, LBNULL, 0, labarray); } break; case 221: /* #line 1008 "/n/bopp/v5/dmg/f2c/gram.in" */ { excall(yypt[-2].yyv.namval, LBNULL, 0, labarray); } break; case 222: /* #line 1010 "/n/bopp/v5/dmg/f2c/gram.in" */ { if(nstars < maxlablist) excall(yypt[-3].yyv.namval, mklist(revchain(yypt[-1].yyv.chval)), nstars, labarray); else many("alternate returns", 'l', maxlablist); } break; case 223: /* #line 1016 "/n/bopp/v5/dmg/f2c/gram.in" */ { exreturn(yypt[-0].yyv.expval); thiswasbranch = YES; } break; case 224: /* #line 1018 "/n/bopp/v5/dmg/f2c/gram.in" */ { exstop(yypt[-2].yyv.ival, yypt[-0].yyv.expval); thiswasbranch = yypt[-2].yyv.ival; } break; case 225: /* #line 1022 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.labval = mklabel( convci(toklen, token) ); } break; case 226: /* #line 1026 "/n/bopp/v5/dmg/f2c/gram.in" */ { if(parstate == OUTSIDE) { newproc(); startproc(ESNULL, CLMAIN); } } break; case 227: /* #line 1035 "/n/bopp/v5/dmg/f2c/gram.in" */ { exgoto(yypt[-0].yyv.labval); thiswasbranch = YES; } break; case 228: /* #line 1037 "/n/bopp/v5/dmg/f2c/gram.in" */ { exasgoto(yypt[-0].yyv.namval); thiswasbranch = YES; } break; case 229: /* #line 1039 "/n/bopp/v5/dmg/f2c/gram.in" */ { exasgoto(yypt[-4].yyv.namval); thiswasbranch = YES; } break; case 230: /* #line 1041 "/n/bopp/v5/dmg/f2c/gram.in" */ { if(nstars < maxlablist) putcmgo(putx(fixtype(yypt[-0].yyv.expval)), nstars, labarray); else many("labels in computed GOTO list", 'l', maxlablist); } break; case 233: /* #line 1053 "/n/bopp/v5/dmg/f2c/gram.in" */ { nstars = 0; yyval.namval = yypt[-0].yyv.namval; } break; case 234: /* #line 1057 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.chval = yypt[-0].yyv.expval ? mkchain((char *)yypt[-0].yyv.expval,CHNULL) : CHNULL; } break; case 235: /* #line 1059 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.chval = yypt[-0].yyv.expval ? mkchain((char *)yypt[-0].yyv.expval, yypt[-2].yyv.chval) : yypt[-2].yyv.chval; } break; case 237: /* #line 1064 "/n/bopp/v5/dmg/f2c/gram.in" */ { if(nstars < maxlablist) labarray[nstars++] = yypt[-0].yyv.labval; yyval.expval = 0; } break; case 238: /* #line 1068 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.ival = 0; } break; case 239: /* #line 1070 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.ival = 2; } break; case 240: /* #line 1074 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.chval = mkchain((char *)yypt[-0].yyv.expval, CHNULL); } break; case 241: /* #line 1076 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.chval = hookup(yypt[-2].yyv.chval, mkchain((char *)yypt[-0].yyv.expval,CHNULL) ); } break; case 242: /* #line 1080 "/n/bopp/v5/dmg/f2c/gram.in" */ { if(parstate == OUTSIDE) { newproc(); startproc(ESNULL, CLMAIN); } /* This next statement depends on the ordering of the state table encoding */ if(parstate < INDATA) enddcl(); } break; case 243: /* #line 1093 "/n/bopp/v5/dmg/f2c/gram.in" */ { intonly = YES; } break; case 244: /* #line 1097 "/n/bopp/v5/dmg/f2c/gram.in" */ { intonly = NO; } break; case 245: /* #line 1102 "/n/bopp/v5/dmg/f2c/gram.in" */ { endio(); } break; case 247: /* #line 1107 "/n/bopp/v5/dmg/f2c/gram.in" */ { ioclause(IOSUNIT, yypt[-0].yyv.expval); endioctl(); } break; case 248: /* #line 1109 "/n/bopp/v5/dmg/f2c/gram.in" */ { ioclause(IOSUNIT, ENULL); endioctl(); } break; case 249: /* #line 1111 "/n/bopp/v5/dmg/f2c/gram.in" */ { ioclause(IOSUNIT, IOSTDERR); endioctl(); } break; case 251: /* #line 1114 "/n/bopp/v5/dmg/f2c/gram.in" */ { doio(CHNULL); } break; case 252: /* #line 1116 "/n/bopp/v5/dmg/f2c/gram.in" */ { doio(CHNULL); } break; case 253: /* #line 1118 "/n/bopp/v5/dmg/f2c/gram.in" */ { doio(revchain(yypt[-0].yyv.chval)); } break; case 254: /* #line 1120 "/n/bopp/v5/dmg/f2c/gram.in" */ { doio(revchain(yypt[-0].yyv.chval)); } break; case 255: /* #line 1122 "/n/bopp/v5/dmg/f2c/gram.in" */ { doio(revchain(yypt[-0].yyv.chval)); } break; case 256: /* #line 1124 "/n/bopp/v5/dmg/f2c/gram.in" */ { doio(CHNULL); } break; case 257: /* #line 1126 "/n/bopp/v5/dmg/f2c/gram.in" */ { doio(revchain(yypt[-0].yyv.chval)); } break; case 258: /* #line 1128 "/n/bopp/v5/dmg/f2c/gram.in" */ { doio(revchain(yypt[-0].yyv.chval)); } break; case 259: /* #line 1130 "/n/bopp/v5/dmg/f2c/gram.in" */ { doio(CHNULL); } break; case 260: /* #line 1132 "/n/bopp/v5/dmg/f2c/gram.in" */ { doio(revchain(yypt[-0].yyv.chval)); } break; case 262: /* #line 1139 "/n/bopp/v5/dmg/f2c/gram.in" */ { iostmt = IOBACKSPACE; } break; case 263: /* #line 1141 "/n/bopp/v5/dmg/f2c/gram.in" */ { iostmt = IOREWIND; } break; case 264: /* #line 1143 "/n/bopp/v5/dmg/f2c/gram.in" */ { iostmt = IOENDFILE; } break; case 266: /* #line 1150 "/n/bopp/v5/dmg/f2c/gram.in" */ { iostmt = IOINQUIRE; } break; case 267: /* #line 1152 "/n/bopp/v5/dmg/f2c/gram.in" */ { iostmt = IOOPEN; } break; case 268: /* #line 1154 "/n/bopp/v5/dmg/f2c/gram.in" */ { iostmt = IOCLOSE; } break; case 269: /* #line 1158 "/n/bopp/v5/dmg/f2c/gram.in" */ { ioclause(IOSUNIT, ENULL); ioclause(IOSFMT, yypt[-0].yyv.expval); endioctl(); } break; case 270: /* #line 1164 "/n/bopp/v5/dmg/f2c/gram.in" */ { ioclause(IOSUNIT, ENULL); ioclause(IOSFMT, ENULL); endioctl(); } break; case 271: /* #line 1172 "/n/bopp/v5/dmg/f2c/gram.in" */ { ioclause(IOSUNIT, yypt[-1].yyv.expval); endioctl(); } break; case 272: /* #line 1177 "/n/bopp/v5/dmg/f2c/gram.in" */ { endioctl(); } break; case 275: /* #line 1185 "/n/bopp/v5/dmg/f2c/gram.in" */ { ioclause(IOSPOSITIONAL, yypt[-0].yyv.expval); } break; case 276: /* #line 1187 "/n/bopp/v5/dmg/f2c/gram.in" */ { ioclause(IOSPOSITIONAL, ENULL); } break; case 277: /* #line 1189 "/n/bopp/v5/dmg/f2c/gram.in" */ { ioclause(IOSPOSITIONAL, IOSTDERR); } break; case 278: /* #line 1191 "/n/bopp/v5/dmg/f2c/gram.in" */ { ioclause(yypt[-1].yyv.ival, yypt[-0].yyv.expval); } break; case 279: /* #line 1193 "/n/bopp/v5/dmg/f2c/gram.in" */ { ioclause(yypt[-1].yyv.ival, ENULL); } break; case 280: /* #line 1195 "/n/bopp/v5/dmg/f2c/gram.in" */ { ioclause(yypt[-1].yyv.ival, IOSTDERR); } break; case 281: /* #line 1199 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.ival = iocname(); } break; case 282: /* #line 1203 "/n/bopp/v5/dmg/f2c/gram.in" */ { iostmt = IOREAD; } break; case 283: /* #line 1207 "/n/bopp/v5/dmg/f2c/gram.in" */ { iostmt = IOWRITE; } break; case 284: /* #line 1211 "/n/bopp/v5/dmg/f2c/gram.in" */ { iostmt = IOWRITE; ioclause(IOSUNIT, ENULL); ioclause(IOSFMT, yypt[-1].yyv.expval); endioctl(); } break; case 285: /* #line 1218 "/n/bopp/v5/dmg/f2c/gram.in" */ { iostmt = IOWRITE; ioclause(IOSUNIT, ENULL); ioclause(IOSFMT, ENULL); endioctl(); } break; case 286: /* #line 1227 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.chval = mkchain((char *)yypt[-0].yyv.tagval, CHNULL); } break; case 287: /* #line 1229 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.chval = mkchain((char *)yypt[-0].yyv.tagval, yypt[-2].yyv.chval); } break; case 288: /* #line 1233 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.tagval = (tagptr) yypt[-0].yyv.expval; } break; case 289: /* #line 1235 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.tagval = (tagptr) mkiodo(yypt[-1].yyv.chval,revchain(yypt[-3].yyv.chval)); } break; case 290: /* #line 1239 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.chval = mkchain((char *)yypt[-0].yyv.expval, CHNULL); } break; case 291: /* #line 1241 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.chval = mkchain((char *)yypt[-0].yyv.tagval, CHNULL); } break; case 293: /* #line 1246 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.chval = mkchain((char *)yypt[-0].yyv.expval, mkchain((char *)yypt[-2].yyv.expval, CHNULL) ); } break; case 294: /* #line 1248 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.chval = mkchain((char *)yypt[-0].yyv.tagval, mkchain((char *)yypt[-2].yyv.expval, CHNULL) ); } break; case 295: /* #line 1250 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.chval = mkchain((char *)yypt[-0].yyv.expval, mkchain((char *)yypt[-2].yyv.tagval, CHNULL) ); } break; case 296: /* #line 1252 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.chval = mkchain((char *)yypt[-0].yyv.tagval, mkchain((char *)yypt[-2].yyv.tagval, CHNULL) ); } break; case 297: /* #line 1254 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.chval = mkchain((char *)yypt[-0].yyv.expval, yypt[-2].yyv.chval); } break; case 298: /* #line 1256 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.chval = mkchain((char *)yypt[-0].yyv.tagval, yypt[-2].yyv.chval); } break; case 299: /* #line 1260 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.tagval = (tagptr) yypt[-0].yyv.expval; } break; case 300: /* #line 1262 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.tagval = (tagptr) yypt[-1].yyv.expval; } break; case 301: /* #line 1264 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.tagval = (tagptr) mkiodo(yypt[-1].yyv.chval, mkchain((char *)yypt[-3].yyv.expval, CHNULL) ); } break; case 302: /* #line 1266 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.tagval = (tagptr) mkiodo(yypt[-1].yyv.chval, mkchain((char *)yypt[-3].yyv.tagval, CHNULL) ); } break; case 303: /* #line 1268 "/n/bopp/v5/dmg/f2c/gram.in" */ { yyval.tagval = (tagptr) mkiodo(yypt[-1].yyv.chval, revchain(yypt[-3].yyv.chval)); } break; case 304: /* #line 1272 "/n/bopp/v5/dmg/f2c/gram.in" */ { startioctl(); } break; } goto yystack; /* stack new state and value */ } f2c/src/gram.dcl000066400000000000000000000204171171647030000137340ustar00rootroot00000000000000spec: dcl | common | external | intrinsic | equivalence | data | implicit | namelist | SSAVE { NO66("SAVE statement"); saveall = YES; } | SSAVE savelist { NO66("SAVE statement"); } | SFORMAT { fmtstmt(thislabel); setfmt(thislabel); } | SPARAM in_dcl SLPAR paramlist SRPAR { NO66("PARAMETER statement"); } ; dcl: type opt_comma name in_dcl new_dcl dims lengspec { settype($3, $1, $7); if(ndim>0) setbound($3,ndim,dims); } | dcl SCOMMA name dims lengspec { settype($3, $1, $5); if(ndim>0) setbound($3,ndim,dims); } | dcl SSLASHD datainit vallist SSLASHD { if (new_dcl == 2) { err("attempt to give DATA in type-declaration"); new_dcl = 1; } } ; new_dcl: { new_dcl = 2; } ; type: typespec lengspec { varleng = $2; } ; typespec: typename { varleng = ($1<0 || ONEOF($1,M(TYLOGICAL)|M(TYLONG)) ? 0 : typesize[$1]); vartype = $1; } ; typename: SINTEGER { $$ = TYLONG; } | SREAL { $$ = tyreal; } | SCOMPLEX { ++complex_seen; $$ = tycomplex; } | SDOUBLE { $$ = TYDREAL; } | SDCOMPLEX { ++dcomplex_seen; NOEXT("DOUBLE COMPLEX statement"); $$ = TYDCOMPLEX; } | SLOGICAL { $$ = TYLOGICAL; } | SCHARACTER { NO66("CHARACTER statement"); $$ = TYCHAR; } | SUNDEFINED { $$ = TYUNKNOWN; } | SDIMENSION { $$ = TYUNKNOWN; } | SAUTOMATIC { NOEXT("AUTOMATIC statement"); $$ = - STGAUTO; } | SSTATIC { NOEXT("STATIC statement"); $$ = - STGBSS; } | SBYTE { $$ = TYINT1; } ; lengspec: { $$ = varleng; } | SSTAR intonlyon expr intonlyoff { expptr p; p = $3; NO66("length specification *n"); if( ! ISICON(p) || p->constblock.Const.ci <= 0 ) { $$ = 0; dclerr("length must be a positive integer constant", NPNULL); } else { if (vartype == TYCHAR) $$ = p->constblock.Const.ci; else switch((int)p->constblock.Const.ci) { case 1: $$ = 1; break; case 2: $$ = typesize[TYSHORT]; break; case 4: $$ = typesize[TYLONG]; break; case 8: $$ = typesize[TYDREAL]; break; case 16: $$ = typesize[TYDCOMPLEX]; break; default: dclerr("invalid length",NPNULL); $$ = varleng; } } } | SSTAR intonlyon SLPAR SSTAR SRPAR intonlyoff { NO66("length specification *(*)"); $$ = -1; } ; common: SCOMMON in_dcl var { incomm( $$ = comblock("") , $3 ); } | SCOMMON in_dcl comblock var { $$ = $3; incomm($3, $4); } | common opt_comma comblock opt_comma var { $$ = $3; incomm($3, $5); } | common SCOMMA var { incomm($1, $3); } ; comblock: SCONCAT { $$ = comblock(""); } | SSLASH SNAME SSLASH { $$ = comblock(token); } ; external: SEXTERNAL in_dcl name { setext($3); } | external SCOMMA name { setext($3); } ; intrinsic: SINTRINSIC in_dcl name { NO66("INTRINSIC statement"); setintr($3); } | intrinsic SCOMMA name { setintr($3); } ; equivalence: SEQUIV in_dcl equivset | equivalence SCOMMA equivset ; equivset: SLPAR equivlist SRPAR { struct Equivblock *p; if(nequiv >= maxequiv) many("equivalences", 'q', maxequiv); p = & eqvclass[nequiv++]; p->eqvinit = NO; p->eqvbottom = 0; p->eqvtop = 0; p->equivs = $2; } ; equivlist: lhs { $$=ALLOC(Eqvchain); $$->eqvitem.eqvlhs = primchk($1); } | equivlist SCOMMA lhs { $$=ALLOC(Eqvchain); $$->eqvitem.eqvlhs = primchk($3); $$->eqvnextp = $1; } ; data: SDATA in_data datalist | data opt_comma datalist ; in_data: { if(parstate == OUTSIDE) { newproc(); startproc(ESNULL, CLMAIN); } if(parstate < INDATA) { enddcl(); parstate = INDATA; datagripe = 1; } } ; datalist: datainit datavarlist SSLASH datapop vallist SSLASH { ftnint junk; if(nextdata(&junk) != NULL) err("too few initializers"); frdata($2); frrpl(); } ; datainit: /* nothing */ { frchain(&datastack); curdtp = 0; } ; datapop: /* nothing */ { pop_datastack(); } ; vallist: { toomanyinit = NO; } val | vallist SCOMMA val ; val: value { dataval(ENULL, $1); } | simple SSTAR value { dataval($1, $3); } ; value: simple | addop simple { if( $1==OPMINUS && ISCONST($2) ) consnegop((Constp)$2); $$ = $2; } | complex_const ; savelist: saveitem | savelist SCOMMA saveitem ; saveitem: name { int k; $1->vsave = YES; k = $1->vstg; if( ! ONEOF(k, M(STGUNKNOWN)|M(STGBSS)|M(STGINIT)) ) dclerr("can only save static variables", $1); } | comblock ; paramlist: paramitem | paramlist SCOMMA paramitem ; paramitem: name SEQUALS expr { if($1->vclass == CLUNKNOWN) make_param((struct Paramblock *)$1, $3); else dclerr("cannot make into parameter", $1); } ; var: name dims { if(ndim>0) setbound($1, ndim, dims); } ; datavar: lhs { Namep np; struct Primblock *pp = (struct Primblock *)$1; int tt = $1->tag; if (tt != TPRIM) { if (tt == TCONST) err("parameter in data statement"); else erri("tag %d in data statement",tt); $$ = 0; err_lineno = lineno; break; } np = pp -> namep; vardcl(np); if ((pp->fcharp || pp->lcharp) && (np->vtype != TYCHAR || np->vdim && !pp->argsp)) sserr(np); if(np->vstg == STGCOMMON) extsymtab[np->vardesc.varno].extinit = YES; else if(np->vstg==STGEQUIV) eqvclass[np->vardesc.varno].eqvinit = YES; else if(np->vstg!=STGINIT && np->vstg!=STGBSS) { errstr(np->vstg == STGARG ? "Dummy argument \"%.60s\" in data statement." : "Cannot give data to \"%.75s\"", np->fvarname); $$ = 0; err_lineno = lineno; break; } $$ = mkchain((char *)$1, CHNULL); } | SLPAR datavarlist SCOMMA dospec SRPAR { chainp p; struct Impldoblock *q; pop_datastack(); q = ALLOC(Impldoblock); q->tag = TIMPLDO; (q->varnp = (Namep) ($4->datap))->vimpldovar = 1; p = $4->nextp; if(p) { q->implb = (expptr)(p->datap); p = p->nextp; } if(p) { q->impub = (expptr)(p->datap); p = p->nextp; } if(p) { q->impstep = (expptr)(p->datap); } frchain( & ($4) ); $$ = mkchain((char *)q, CHNULL); q->datalist = hookup($2, $$); } ; datavarlist: datavar { if (!datastack) curdtp = 0; datastack = mkchain((char *)curdtp, datastack); curdtp = $1; curdtelt = 0; } | datavarlist SCOMMA datavar { $$ = hookup($1, $3); } ; dims: { ndim = 0; } | SLPAR dimlist SRPAR ; dimlist: { ndim = 0; } dim | dimlist SCOMMA dim ; dim: ubound { if(ndim == maxdim) err("too many dimensions"); else if(ndim < maxdim) { dims[ndim].lb = 0; dims[ndim].ub = $1; } ++ndim; } | expr SCOLON ubound { if(ndim == maxdim) err("too many dimensions"); else if(ndim < maxdim) { dims[ndim].lb = $1; dims[ndim].ub = $3; } ++ndim; } ; ubound: SSTAR { $$ = 0; } | expr ; labellist: label { nstars = 1; labarray[0] = $1; } | labellist SCOMMA label { if(nstars < maxlablist) labarray[nstars++] = $3; } ; label: SICON { $$ = execlab( convci(toklen, token) ); } ; implicit: SIMPLICIT in_dcl implist { NO66("IMPLICIT statement"); } | implicit SCOMMA implist ; implist: imptype SLPAR letgroups SRPAR | imptype { if (vartype != TYUNKNOWN) dclerr("-- expected letter range",NPNULL); setimpl(vartype, varleng, 'a', 'z'); } ; imptype: { needkwd = 1; } type /* { vartype = $2; } */ ; letgroups: letgroup | letgroups SCOMMA letgroup ; letgroup: letter { setimpl(vartype, varleng, $1, $1); } | letter SMINUS letter { setimpl(vartype, varleng, $1, $3); } ; letter: SNAME { if(toklen!=1 || token[0]<'a' || token[0]>'z') { dclerr("implicit item must be single letter", NPNULL); $$ = 0; } else $$ = token[0]; } ; namelist: SNAMELIST | namelist namelistentry ; namelistentry: SSLASH name SSLASH namelistlist { if($2->vclass == CLUNKNOWN) { $2->vclass = CLNAMELIST; $2->vtype = TYINT; $2->vstg = STGBSS; $2->varxptr.namelist = $4; $2->vardesc.varno = ++lastvarno; } else dclerr("cannot be a namelist name", $2); } ; namelistlist: name { $$ = mkchain((char *)$1, CHNULL); } | namelistlist SCOMMA name { $$ = hookup($1, mkchain((char *)$3, CHNULL)); } ; in_dcl: { switch(parstate) { case OUTSIDE: newproc(); startproc(ESNULL, CLMAIN); case INSIDE: parstate = INDCL; case INDCL: break; case INDATA: if (datagripe) { errstr( "Statement order error: declaration after DATA", CNULL); datagripe = 0; } break; default: dclerr("declaration among executables", NPNULL); } } ; f2c/src/gram.exec000066400000000000000000000057311171647030000141200ustar00rootroot00000000000000exec: iffable | SDO end_spec label opt_comma dospecw { if($3->labdefined) execerr("no backward DO loops", CNULL); $3->blklevel = blklevel+1; exdo($3->labelno, NPNULL, $5); } | SDO end_spec opt_comma dospecw { exdo((int)(ctls - ctlstack - 2), NPNULL, $4); NOEXT("DO without label"); } | SENDDO { exenddo(NPNULL); } | logif iffable { exendif(); thiswasbranch = NO; } | logif STHEN | SELSEIF end_spec SLPAR {westart(1);} expr SRPAR STHEN { exelif($5); lastwasbranch = NO; } | SELSE end_spec { exelse(); lastwasbranch = NO; } | SENDIF end_spec { exendif(); lastwasbranch = NO; } ; logif: SLOGIF end_spec SLPAR expr SRPAR { exif($4); } ; dospec: name SEQUALS exprlist { $$ = mkchain((char *)$1, $3); } ; dospecw: dospec | SWHILE {westart(0);} SLPAR expr SRPAR { $$ = mkchain(CNULL, (chainp)$4); } ; iffable: let lhs SEQUALS expr { exequals((struct Primblock *)$2, $4); } | SASSIGN end_spec assignlabel STO name { exassign($5, $3); } | SCONTINUE end_spec | goto | io { inioctl = NO; } | SARITHIF end_spec SLPAR expr SRPAR label SCOMMA label SCOMMA label { exarif($4, $6, $8, $10); thiswasbranch = YES; } | call { excall($1, LBNULL, 0, labarray); } | call SLPAR SRPAR { excall($1, LBNULL, 0, labarray); } | call SLPAR callarglist SRPAR { if(nstars < maxlablist) excall($1, mklist(revchain($3)), nstars, labarray); else many("alternate returns", 'l', maxlablist); } | SRETURN end_spec opt_expr { exreturn($3); thiswasbranch = YES; } | stop end_spec opt_expr { exstop($1, $3); thiswasbranch = $1; } ; assignlabel: SICON { $$ = mklabel( convci(toklen, token) ); } ; let: SLET { if(parstate == OUTSIDE) { newproc(); startproc(ESNULL, CLMAIN); } } ; goto: SGOTO end_spec label { exgoto($3); thiswasbranch = YES; } | SASGOTO end_spec name { exasgoto($3); thiswasbranch = YES; } | SASGOTO end_spec name opt_comma SLPAR labellist SRPAR { exasgoto($3); thiswasbranch = YES; } | SCOMPGOTO end_spec SLPAR labellist SRPAR opt_comma expr { if(nstars < maxlablist) putcmgo(putx(fixtype($7)), nstars, labarray); else many("labels in computed GOTO list", 'l', maxlablist); } ; opt_comma: | SCOMMA ; call: SCALL end_spec name { nstars = 0; $$ = $3; } ; callarglist: callarg { $$ = $1 ? mkchain((char *)$1,CHNULL) : CHNULL; } | callarglist SCOMMA callarg { $$ = $3 ? mkchain((char *)$3, $1) : $1; } ; callarg: expr | SSTAR label { if(nstars < maxlablist) labarray[nstars++] = $2; $$ = 0; } ; stop: SPAUSE { $$ = 0; } | SSTOP { $$ = 2; } ; exprlist: expr { $$ = mkchain((char *)$1, CHNULL); } | exprlist SCOMMA expr { $$ = hookup($1, mkchain((char *)$3,CHNULL) ); } ; end_spec: { if(parstate == OUTSIDE) { newproc(); startproc(ESNULL, CLMAIN); } /* This next statement depends on the ordering of the state table encoding */ if(parstate < INDATA) enddcl(); } ; intonlyon: { intonly = YES; } ; intonlyoff: { intonly = NO; } ; f2c/src/gram.expr000066400000000000000000000061711171647030000141510ustar00rootroot00000000000000funarglist: { $$ = 0; } | funargs { $$ = revchain($1); } ; funargs: expr { $$ = mkchain((char *)$1, CHNULL); } | funargs SCOMMA expr { $$ = mkchain((char *)$3, $1); } ; expr: uexpr | SLPAR expr SRPAR { $$ = $2; if ($$->tag == TPRIM) paren_used(&$$->primblock); } | complex_const ; uexpr: lhs | simple_const | expr addop expr %prec SPLUS { $$ = mkexpr($2, $1, $3); } | expr SSTAR expr { $$ = mkexpr(OPSTAR, $1, $3); } | expr SSLASH expr { $$ = mkexpr(OPSLASH, $1, $3); } | expr SPOWER expr { $$ = mkexpr(OPPOWER, $1, $3); } | addop expr %prec SSTAR { if($1 == OPMINUS) $$ = mkexpr(OPNEG, $2, ENULL); else { $$ = $2; if ($$->tag == TPRIM) paren_used(&$$->primblock); } } | expr relop expr %prec SEQ { $$ = mkexpr($2, $1, $3); } | expr SEQV expr { NO66(".EQV. operator"); $$ = mkexpr(OPEQV, $1,$3); } | expr SNEQV expr { NO66(".NEQV. operator"); $$ = mkexpr(OPNEQV, $1, $3); } | expr SOR expr { $$ = mkexpr(OPOR, $1, $3); } | expr SAND expr { $$ = mkexpr(OPAND, $1, $3); } | SNOT expr { $$ = mkexpr(OPNOT, $2, ENULL); } | expr SCONCAT expr { NO66("concatenation operator //"); $$ = mkexpr(OPCONCAT, $1, $3); } ; addop: SPLUS { $$ = OPPLUS; } | SMINUS { $$ = OPMINUS; } ; relop: SEQ { $$ = OPEQ; } | SGT { $$ = OPGT; } | SLT { $$ = OPLT; } | SGE { $$ = OPGE; } | SLE { $$ = OPLE; } | SNE { $$ = OPNE; } ; lhs: name { $$ = mkprim($1, LBNULL, CHNULL); } | name substring { NO66("substring operator :"); $$ = mkprim($1, LBNULL, $2); } | name SLPAR funarglist SRPAR { $$ = mkprim($1, mklist($3), CHNULL); } | name SLPAR funarglist SRPAR substring { NO66("substring operator :"); $$ = mkprim($1, mklist($3), $5); } ; substring: SLPAR opt_expr SCOLON opt_expr SRPAR { $$ = mkchain((char *)$2, mkchain((char *)$4,CHNULL)); } ; opt_expr: { $$ = 0; } | expr ; simple: name { if($1->vclass == CLPARAM) $$ = (expptr) cpexpr( ( (struct Paramblock *) ($1) ) -> paramval); } | simple_const ; simple_const: STRUE { $$ = mklogcon(1); } | SFALSE { $$ = mklogcon(0); } | SHOLLERITH { $$ = mkstrcon(toklen, token); } | SICON = { $$ = mkintqcon(toklen, token); } | SRCON = { $$ = mkrealcon(tyreal, token); } | SDCON = { $$ = mkrealcon(TYDREAL, token); } | bit_const ; complex_const: SLPAR uexpr SCOMMA uexpr SRPAR { $$ = mkcxcon($2,$4); } ; bit_const: SHEXCON { NOEXT("hex constant"); $$ = mkbitcon(4, toklen, token); } | SOCTCON { NOEXT("octal constant"); $$ = mkbitcon(3, toklen, token); } | SBITCON { NOEXT("binary constant"); $$ = mkbitcon(1, toklen, token); } ; fexpr: unpar_fexpr | SLPAR fexpr SRPAR { $$ = $2; } ; unpar_fexpr: lhs | simple_const | fexpr addop fexpr %prec SPLUS { $$ = mkexpr($2, $1, $3); } | fexpr SSTAR fexpr { $$ = mkexpr(OPSTAR, $1, $3); } | fexpr SSLASH fexpr { $$ = mkexpr(OPSLASH, $1, $3); } | fexpr SPOWER fexpr { $$ = mkexpr(OPPOWER, $1, $3); } | addop fexpr %prec SSTAR { if($1 == OPMINUS) $$ = mkexpr(OPNEG, $2, ENULL); else $$ = $2; } | fexpr SCONCAT fexpr { NO66("concatenation operator //"); $$ = mkexpr(OPCONCAT, $1, $3); } ; f2c/src/gram.head000066400000000000000000000163021171647030000140710ustar00rootroot00000000000000/**************************************************************** Copyright 1990, 1993 by AT&T Bell Laboratories, Bellcore. Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the above copyright notice appear in all copies and that both that the copyright notice and this permission notice and warranty disclaimer appear in supporting documentation, and that the names of AT&T Bell Laboratories or Bellcore or any of their entities not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. AT&T and Bellcore disclaim all warranties with regard to this software, including all implied warranties of merchantability and fitness. In no event shall AT&T or Bellcore be liable for any special, indirect or consequential damages or any damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortious action, arising out of or in connection with the use or performance of this software. ****************************************************************/ %{ #include "defs.h" #include "p1defs.h" static int nstars; /* Number of labels in an alternate return CALL */ static int datagripe; static int ndim; static int vartype; int new_dcl; static ftnint varleng; static struct Dims dims[MAXDIM+1]; extern struct Labelblock **labarray; /* Labels in an alternate return CALL */ extern int maxlablist; /* The next two variables are used to verify that each statement might be reached during runtime. lastwasbranch is tested only in the defintion of the stat: nonterminal. */ int lastwasbranch = NO; static int thiswasbranch = NO; extern ftnint yystno; extern flag intonly; static chainp datastack; extern long laststfcn, thisstno; extern int can_include; /* for netlib */ extern void endcheck Argdcl((void)); extern struct Primblock *primchk Argdcl((expptr)); #define ESNULL (Extsym *)0 #define NPNULL (Namep)0 #define LBNULL (struct Listblock *)0 static void pop_datastack(Void) { chainp d0 = datastack; if (d0->datap) curdtp = (chainp)d0->datap; datastack = d0->nextp; d0->nextp = 0; frchain(&d0); } %} /* Specify precedences and associativities. */ %union { int ival; ftnint lval; char *charpval; chainp chval; tagptr tagval; expptr expval; struct Labelblock *labval; struct Nameblock *namval; struct Eqvchain *eqvval; Extsym *extval; } %left SCOMMA %nonassoc SCOLON %right SEQUALS %left SEQV SNEQV %left SOR %left SAND %left SNOT %nonassoc SLT SGT SLE SGE SEQ SNE %left SCONCAT %left SPLUS SMINUS %left SSTAR SSLASH %right SPOWER %start program %type thislabel label assignlabel %type other inelt %type type typespec typename dcl letter addop relop stop nameeq %type lengspec %type filename %type datavar datavarlist namelistlist funarglist funargs %type dospec dospecw %type callarglist arglist args exprlist inlist outlist out2 substring %type name arg call var %type lhs expr uexpr opt_expr fexpr unpar_fexpr %type ubound simple value callarg complex_const simple_const bit_const %type common comblock entryname progname %type equivlist %% program: | program stat SEOS ; stat: thislabel entry { /* stat: is the nonterminal for Fortran statements */ lastwasbranch = NO; } | thislabel spec | thislabel exec { /* forbid further statement function definitions... */ if (parstate == INDATA && laststfcn != thisstno) parstate = INEXEC; thisstno++; if($1 && ($1->labelno==dorange)) enddo($1->labelno); if(lastwasbranch && thislabel==NULL) warn("statement cannot be reached"); lastwasbranch = thiswasbranch; thiswasbranch = NO; if($1) { if($1->labtype == LABFORMAT) err("label already that of a format"); else $1->labtype = LABEXEC; } freetemps(); } | thislabel SINCLUDE filename { if (can_include) doinclude( $3 ); else { fprintf(diagfile, "Cannot open file %s\n", $3); done(1); } } | thislabel SEND end_spec { if ($1) lastwasbranch = NO; endcheck(); endproc(); /* lastwasbranch = NO; -- set in endproc() */ } | thislabel SUNKNOWN { unclassifiable(); /* flline flushes the current line, ignoring the rest of the text there */ flline(); } | error { flline(); needkwd = NO; inioctl = NO; yyerrok; yyclearin; } ; thislabel: SLABEL { if(yystno != 0) { $$ = thislabel = mklabel(yystno); if( ! headerdone ) { if (procclass == CLUNKNOWN) procclass = CLMAIN; puthead(CNULL, procclass); } if(thislabel->labdefined) execerr("label %s already defined", convic(thislabel->stateno) ); else { if(thislabel->blklevel!=0 && thislabel->blklevellabtype!=LABFORMAT) warn1("there is a branch to label %s from outside block", convic( (ftnint) (thislabel->stateno) ) ); thislabel->blklevel = blklevel; thislabel->labdefined = YES; if(thislabel->labtype != LABFORMAT) p1_label((long)(thislabel - labeltab)); } } else $$ = thislabel = NULL; } ; entry: SPROGRAM new_proc progname {startproc($3, CLMAIN); } | SPROGRAM new_proc progname progarglist { warn("ignoring arguments to main program"); /* hashclear(); */ startproc($3, CLMAIN); } | SBLOCK new_proc progname { if($3) NO66("named BLOCKDATA"); startproc($3, CLBLOCK); } | SSUBROUTINE new_proc entryname arglist { entrypt(CLPROC, TYSUBR, (ftnint) 0, $3, $4); } | SFUNCTION new_proc entryname arglist { entrypt(CLPROC, TYUNKNOWN, (ftnint) 0, $3, $4); } | type SFUNCTION new_proc entryname arglist { entrypt(CLPROC, $1, varleng, $4, $5); } | SENTRY entryname arglist { if(parstate==OUTSIDE || procclass==CLMAIN || procclass==CLBLOCK) execerr("misplaced entry statement", CNULL); entrypt(CLENTRY, 0, (ftnint) 0, $2, $3); } ; new_proc: { newproc(); } ; entryname: name { $$ = newentry($1, 1); } ; name: SNAME { $$ = mkname(token); } ; progname: { $$ = NULL; } | entryname ; progarglist: SLPAR SRPAR | SLPAR progargs SRPAR ; progargs: progarg | progargs SCOMMA progarg ; progarg: SNAME | SNAME SEQUALS SNAME ; arglist: { $$ = 0; } | SLPAR SRPAR { NO66(" () argument list"); $$ = 0; } | SLPAR args SRPAR {$$ = $2; } ; args: arg { $$ = ($1 ? mkchain((char *)$1,CHNULL) : CHNULL ); } | args SCOMMA arg { if($3) $1 = $$ = mkchain((char *)$3, $1); } ; arg: name { if($1->vstg!=STGUNKNOWN && $1->vstg!=STGARG) dclerr("name declared as argument after use", $1); $1->vstg = STGARG; } | SSTAR { NO66("altenate return argument"); /* substars means that '*'ed formal parameters should be replaced. This is used to specify alternate return labels; in theory, only parameter slots which have '*' should accept the statement labels. This compiler chooses to ignore the '*'s in the formal declaration, and always return the proper value anyway. This variable is only referred to in proc.c */ $$ = 0; substars = YES; } ; filename: SHOLLERITH { char *s; s = copyn(toklen+1, token); s[toklen] = '\0'; $$ = s; } ; f2c/src/gram.io000066400000000000000000000064261171647030000136050ustar00rootroot00000000000000 /* Input/Output Statements */ io: io1 { endio(); } ; io1: iofmove ioctl | iofmove unpar_fexpr { ioclause(IOSUNIT, $2); endioctl(); } | iofmove SSTAR { ioclause(IOSUNIT, ENULL); endioctl(); } | iofmove SPOWER { ioclause(IOSUNIT, IOSTDERR); endioctl(); } | iofctl ioctl | read ioctl { doio(CHNULL); } | read infmt { doio(CHNULL); } | read ioctl inlist { doio(revchain($3)); } | read infmt SCOMMA inlist { doio(revchain($4)); } | read ioctl SCOMMA inlist { doio(revchain($4)); } | write ioctl { doio(CHNULL); } | write ioctl outlist { doio(revchain($3)); } | write ioctl SCOMMA outlist { doio(revchain($4)); } | print { doio(CHNULL); } | print SCOMMA outlist { doio(revchain($3)); } ; iofmove: fmkwd end_spec in_ioctl ; fmkwd: SBACKSPACE { iostmt = IOBACKSPACE; } | SREWIND { iostmt = IOREWIND; } | SENDFILE { iostmt = IOENDFILE; } ; iofctl: ctlkwd end_spec in_ioctl ; ctlkwd: SINQUIRE { iostmt = IOINQUIRE; } | SOPEN { iostmt = IOOPEN; } | SCLOSE { iostmt = IOCLOSE; } ; infmt: unpar_fexpr { ioclause(IOSUNIT, ENULL); ioclause(IOSFMT, $1); endioctl(); } | SSTAR { ioclause(IOSUNIT, ENULL); ioclause(IOSFMT, ENULL); endioctl(); } ; ioctl: SLPAR fexpr SRPAR { ioclause(IOSUNIT, $2); endioctl(); } | SLPAR ctllist SRPAR { endioctl(); } ; ctllist: ioclause | ctllist SCOMMA ioclause ; ioclause: fexpr { ioclause(IOSPOSITIONAL, $1); } | SSTAR { ioclause(IOSPOSITIONAL, ENULL); } | SPOWER { ioclause(IOSPOSITIONAL, IOSTDERR); } | nameeq expr { ioclause($1, $2); } | nameeq SSTAR { ioclause($1, ENULL); } | nameeq SPOWER { ioclause($1, IOSTDERR); } ; nameeq: SNAMEEQ { $$ = iocname(); } ; read: SREAD end_spec in_ioctl { iostmt = IOREAD; } ; write: SWRITE end_spec in_ioctl { iostmt = IOWRITE; } ; print: SPRINT end_spec fexpr in_ioctl { iostmt = IOWRITE; ioclause(IOSUNIT, ENULL); ioclause(IOSFMT, $3); endioctl(); } | SPRINT end_spec SSTAR in_ioctl { iostmt = IOWRITE; ioclause(IOSUNIT, ENULL); ioclause(IOSFMT, ENULL); endioctl(); } ; inlist: inelt { $$ = mkchain((char *)$1, CHNULL); } | inlist SCOMMA inelt { $$ = mkchain((char *)$3, $1); } ; inelt: lhs { $$ = (tagptr) $1; } | SLPAR inlist SCOMMA dospec SRPAR { $$ = (tagptr) mkiodo($4,revchain($2)); } ; outlist: uexpr { $$ = mkchain((char *)$1, CHNULL); } | other { $$ = mkchain((char *)$1, CHNULL); } | out2 ; out2: uexpr SCOMMA uexpr { $$ = mkchain((char *)$3, mkchain((char *)$1, CHNULL) ); } | uexpr SCOMMA other { $$ = mkchain((char *)$3, mkchain((char *)$1, CHNULL) ); } | other SCOMMA uexpr { $$ = mkchain((char *)$3, mkchain((char *)$1, CHNULL) ); } | other SCOMMA other { $$ = mkchain((char *)$3, mkchain((char *)$1, CHNULL) ); } | out2 SCOMMA uexpr { $$ = mkchain((char *)$3, $1); } | out2 SCOMMA other { $$ = mkchain((char *)$3, $1); } ; other: complex_const { $$ = (tagptr) $1; } | SLPAR expr SRPAR { $$ = (tagptr) $2; } | SLPAR uexpr SCOMMA dospec SRPAR { $$ = (tagptr) mkiodo($4, mkchain((char *)$2, CHNULL) ); } | SLPAR other SCOMMA dospec SRPAR { $$ = (tagptr) mkiodo($4, mkchain((char *)$2, CHNULL) ); } | SLPAR out2 SCOMMA dospec SRPAR { $$ = (tagptr) mkiodo($4, revchain($2)); } ; in_ioctl: { startioctl(); } ; f2c/src/index.html000066400000000000000000000134031171647030000143140ustar00rootroot00000000000000 f2c/src

f2c/src

Click here to see the number of accesses to this library. 

#	======  index for f2c/src  ======
#	NOTE: The E-mail request "send all from f2c/src" retrieves the
#	complete f2c source (sans libraries).
#	The remaining files in this directory are the component modules
#	of "all from f2c/src", so you can request just the modules that
#	have changed since last you updated your f2c source.  You can
#	tell what has changed by looking at the timestamps at the end
#	of "readme from f2c".

file	cds.c  cds.c plus dependencies

file	data.c

file	defines.h  defines.h plus dependencies

file	defs.h

file	equiv.c  equiv.c plus dependencies

file	error.c

file	exec.c  exec.c plus dependencies

file	expr.c

file	f2c.1  f2c.1 plus dependencies

file	f2c.1t

file	f2c.h  f2c.h plus dependencies

file	format.c

file	format.h  format.h plus dependencies

file	formatdata.c

file	ftypes.h  ftypes.h plus dependencies

file	gram.c

file	gram.dcl  gram.dcl plus dependencies

file	gram.exec

file	gram.expr  gram.expr plus dependencies

file	gram.head

file	gram.io  gram.io plus dependencies

file	init.c

file	intr.c  intr.c plus dependencies

file	io.c

file	iob.h  iob.h plus dependencies

file	lex.c

file	machdefs.h  machdefs.h plus dependencies

file	main.c

file	makefile.u  makefile.u plus dependencies

file	makefile.vc

file	malloc.c  malloc.c plus dependencies

file	mem.c

file	memset.c  memset.c plus dependencies

file	misc.c

file	mkfile.plan9  mkfile.plan9 plus dependencies
for	making f2c under plan 9 (mk -f mkfile.plan9)

file	names.c

file	names.h  names.h plus dependencies

file	niceprintf.c

file	niceprintf.h  niceprintf.h plus dependencies

file	notice

file	output.c

file	output.h  output.h plus dependencies

file	p1defs.h

file	p1output.c  p1output.c plus dependencies

file	parse.h

file	parse_args.c  parse_args.c plus dependencies

file	pccdefs.h

file	pread.c  pread.c plus dependencies

file	proc.c

file	put.c  put.c plus dependencies

file	putpcc.c

file	sysdep.c  sysdep.c plus dependencies

file	sysdep.h

file	sysdeptest.c  sysdeptest.c plus dependencies

file	tokens

file	tokdefs.h  tokdefs.h plus dependencies

file	usignal.h

file	vax.c  vax.c plus dependencies

file	version.c

file	xsum.c  xsum.c plus dependencies

file	xsum0.out

file	Notice

file	README

file	readme
f2c/src/init.c000066400000000000000000000270711171647030000134340ustar00rootroot00000000000000/**************************************************************** Copyright 1990, 1992-1996, 2000-2001 by AT&T, Lucent Technologies and Bellcore. Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the above copyright notice appear in all copies and that both that the copyright notice and this permission notice and warranty disclaimer appear in supporting documentation, and that the names of AT&T, Bell Laboratories, Lucent or Bellcore or any of their entities not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. AT&T, Lucent and Bellcore disclaim all warranties with regard to this software, including all implied warranties of merchantability and fitness. In no event shall AT&T, Lucent or Bellcore be liable for any special, indirect or consequential damages or any damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortious action, arising out of or in connection with the use or performance of this software. ****************************************************************/ #include "defs.h" #include "output.h" #include "iob.h" /* State required for the C output */ char *fl_fmt_string; /* Float format string */ char *db_fmt_string; /* Double format string */ char *cm_fmt_string; /* Complex format string */ char *dcm_fmt_string; /* Double complex format string */ chainp new_vars = CHNULL; /* List of newly created locals in this function. These may have identifiers which have underscores and more than VL characters */ chainp used_builtins = CHNULL; /* List of builtins used by this function. These are all Addrps with UNAM_EXTERN */ chainp assigned_fmts = CHNULL; /* assigned formats */ chainp allargs; /* union of args in all entry points */ chainp earlylabs; /* labels seen before enddcl() */ char main_alias[52]; /* PROGRAM name, if any is given */ int tab_size = 4; FILEP infile; FILEP diagfile; FILEP c_file; FILEP pass1_file; FILEP initfile; FILEP blkdfile; char *token; int maxtoklen, toklen; long err_lineno; long lineno; /* Current line in the input file, NOT the Fortran statement label number */ char *infname; int needkwd; struct Labelblock *thislabel = NULL; int nerr; int nwarn; flag saveall; flag substars; int parstate = OUTSIDE; flag headerdone = NO; int blklevel; int doin_setbound; int impltype[26]; ftnint implleng[26]; int implstg[26]; int tyint = TYLONG ; int tylogical = TYLONG; int tylog = TYLOGICAL; int typesize[NTYPES] = { 1, SZADDR, 1, SZSHORT, SZLONG, #ifdef TYQUAD 2*SZLONG, #endif SZLONG, 2*SZLONG, 2*SZLONG, 4*SZLONG, 1, SZSHORT, SZLONG, 1, 1, 0, 4*SZLONG + SZADDR, /* sizeof(cilist) */ 4*SZLONG + 2*SZADDR, /* sizeof(icilist) */ 4*SZLONG + 5*SZADDR, /* sizeof(olist) */ 2*SZLONG + SZADDR, /* sizeof(cllist) */ 2*SZLONG, /* sizeof(alist) */ 11*SZLONG + 15*SZADDR /* sizeof(inlist) */ }; int typealign[NTYPES] = { 1, ALIADDR, 1, ALISHORT, ALILONG, #ifdef TYQUAD ALIDOUBLE, #endif ALILONG, ALIDOUBLE, ALILONG, ALIDOUBLE, 1, ALISHORT, ALILONG, 1, 1, 1, ALILONG, ALILONG, ALILONG, ALILONG, ALILONG, ALILONG}; int type_choice[4] = { TYDREAL, TYSHORT, TYLONG, TYSHORT }; char *Typename[] = { "<>", "address", "integer1", "shortint", "integer", #ifdef TYQUAD "longint", #endif "real", "doublereal", "complex", "doublecomplex", "logical1", "shortlogical", "logical", "char" /* character */ }; int type_pref[NTYPES] = { 0, 0, 3, 5, 7, #ifdef TYQUAD 10, #endif 8, 11, 9, 12, 1, 4, 6, 2 }; char *protorettypes[] = { "?", "??", "integer1", "shortint", "integer", #ifdef TYQUAD "longint", #endif "real", "doublereal", "C_f", "Z_f", "logical1", "shortlogical", "logical", "H_f", "int" }; char *casttypes[TYSUBR+1] = { "U_fp", "??bug??", "I1_fp", "J_fp", "I_fp", #ifdef TYQUAD "Q_fp", #endif "R_fp", "D_fp", "C_fp", "Z_fp", "L1_fp", "L2_fp", "L_fp", "H_fp", "S_fp" }; char *usedcasts[TYSUBR+1]; char *dfltarg[] = { 0, 0, "(integer1 *)0", "(shortint *)0", "(integer *)0", #ifdef TYQUAD "(longint *)0", #endif "(real *)0", "(doublereal *)0", "(complex *)0", "(doublecomplex *)0", "(logical1 *)0","(shortlogical *)0", "(logical *)0", "(char *)0" }; static char *dflt0proc[] = { 0, 0, "(integer1 (*)())0", "(shortint (*)())0", "(integer (*)())0", #ifdef TYQUAD "(longint (*)())0", #endif "(real (*)())0", "(doublereal (*)())0", "(complex (*)())0", "(doublecomplex (*)())0", "(logical1 (*)())0", "(shortlogical (*)())0", "(logical (*)())0", "(char (*)())0", "(int (*)())0" }; char *dflt1proc[] = { "(U_fp)0", "( ??bug?? )0", "(I1_fp)0", "(J_fp)0", "(I_fp)0", #ifdef TYQUAD "(Q_fp)0", #endif "(R_fp)0", "(D_fp)0", "(C_fp)0", "(Z_fp)0", "(L1_fp)0","(L2_fp)0", "(L_fp)0", "(H_fp)0", "(S_fp)0" }; char **dfltproc = dflt0proc; static char Bug[] = "bug"; char *ftn_types[] = { "external", "??", "integer*1", "integer*2", "integer", #ifdef TYQUAD "integer*8", #endif "real", "double precision", "complex", "double complex", "logical*1", "logical*2", "logical", "character", "subroutine", Bug,Bug,Bug,Bug,Bug,Bug,Bug,Bug,Bug, "ftnlen" }; int init_ac[TYSUBR+1] = { 0,0,0,0,0,0,0, #ifdef TYQUAD 0, #endif 1, 1, 0, 0, 0, 2}; int proctype = TYUNKNOWN; char *procname; int rtvlabel[NTYPES0]; Addrp retslot; /* Holds automatic variable which was allocated the function return value */ Addrp xretslot[NTYPES0]; /* for multiple entry points */ int cxslot = -1; int chslot = -1; int chlgslot = -1; int procclass = CLUNKNOWN; int nentry; int nallargs; int nallchargs; flag multitype; ftnint procleng; long lastiolabno; long lastlabno; int lastvarno; int lastargslot; int autonum[TYVOID]; char *av_pfix[TYVOID] = {"??TYUNKNOWN??", "a","i1","s","i", #ifdef TYQUAD "i8", #endif "r","d","q","z","L1","L2","L","ch", "??TYSUBR??", "??TYERROR??","ci", "ici", "o", "cl", "al", "ioin" }; extern int maxctl; struct Ctlframe *ctls; struct Ctlframe *ctlstack; struct Ctlframe *lastctl; Namep regnamep[MAXREGVAR]; int highregvar; int nregvar; extern int maxext; Extsym *extsymtab; Extsym *nextext; Extsym *lastext; extern int maxequiv; struct Equivblock *eqvclass; extern int maxhash; struct Hashentry *hashtab; struct Hashentry *lasthash; extern int maxstno; /* Maximum number of statement labels */ struct Labelblock *labeltab; struct Labelblock *labtabend; struct Labelblock *highlabtab; int maxdim = MAXDIM; struct Rplblock *rpllist = NULL; struct Chain *curdtp = NULL; flag toomanyinit; ftnint curdtelt; chainp templist[TYVOID]; chainp holdtemps; int dorange = 0; struct Entrypoint *entries = NULL; chainp chains = NULL; flag inioctl; int iostmt; int nioctl; int nequiv = 0; int eqvstart = 0; int nintnames = 0; extern int maxlablist; struct Labelblock **labarray; struct Literal *litpool; int nliterals; char dflttype[26]; unsigned char hextoi_tab[Table_size], Letters[Table_size]; char *ei_first, *ei_next, *ei_last; char *wh_first, *wh_next, *wh_last; #ifdef TYQUAD unsigned long ff; #endif #define ALLOCN(n,x) (struct x *) ckalloc((n)*sizeof(struct x)) void fileinit(Void) { register char *s; register int i, j; lastiolabno = 100000; lastlabno = 0; lastvarno = 0; nliterals = 0; nerr = 0; infile = stdin; maxtoklen = 502; token = (char *)ckalloc(maxtoklen+2); memset(dflttype, tyreal, 26); memset(dflttype + ('i' - 'a'), tyint, 6); memset(hextoi_tab, 16, sizeof(hextoi_tab)); for(i = 0, s = "0123456789abcdef"; *s; i++, s++) hextoi(*s) = i; for(i = 10, s = "ABCDEF"; *s; i++, s++) hextoi(*s) = i; for(j = 0, s = "abcdefghijklmnopqrstuvwxyz"; i = *s++; j++) Letters[i] = Letters[i+'A'-'a'] = j; #ifdef TYQUAD /* Older C compilers may not understand UL suffixes. */ /* It would be much simpler to use 0xffffffffUL some places... */ ff = 0xffff; ff = (ff << 16) | ff; #endif ctls = ALLOCN(maxctl+1, Ctlframe); extsymtab = ALLOCN(maxext, Extsym); eqvclass = ALLOCN(maxequiv, Equivblock); hashtab = ALLOCN(maxhash, Hashentry); labeltab = ALLOCN(maxstno, Labelblock); litpool = ALLOCN(maxliterals, Literal); labarray = (struct Labelblock **)ckalloc(maxlablist* sizeof(struct Labelblock *)); fmt_init(); mem_init(); np_init(); ctlstack = ctls++; lastctl = ctls + maxctl; nextext = extsymtab; lastext = extsymtab + maxext; lasthash = hashtab + maxhash; labtabend = labeltab + maxstno; highlabtab = labeltab; main_alias[0] = '\0'; if (forcedouble) dfltproc[TYREAL] = dfltproc[TYDREAL]; /* Initialize the routines for providing C output */ out_init (); } void hashclear(Void) /* clear hash table */ { register struct Hashentry *hp; register Namep p; register struct Dimblock *q; register int i; for(hp = hashtab ; hp < lasthash ; ++hp) if(p = hp->varp) { frexpr(p->vleng); if(q = p->vdim) { for(i = 0 ; i < q->ndim ; ++i) { frexpr(q->dims[i].dimsize); frexpr(q->dims[i].dimexpr); } frexpr(q->nelt); frexpr(q->baseoffset); frexpr(q->basexpr); free( (charptr) q); } if(p->vclass == CLNAMELIST) frchain( &(p->varxptr.namelist) ); free( (charptr) p); hp->varp = NULL; } } extern struct memblock *curmemblock, *firstmemblock; extern char *mem_first, *mem_next, *mem_last, *mem0_last; void procinit(Void) { register struct Labelblock *lp; struct Chain *cp; int i; struct memblock; curmemblock = firstmemblock; mem_next = mem_first; mem_last = mem0_last; ei_next = ei_first = ei_last = 0; wh_next = wh_first = wh_last = 0; iob_list = 0; for(i = 0; i < 9; i++) io_structs[i] = 0; parstate = OUTSIDE; headerdone = NO; blklevel = 1; saveall = NO; substars = NO; nwarn = 0; thislabel = NULL; needkwd = 0; proctype = TYUNKNOWN; procname = "MAIN_"; procclass = CLUNKNOWN; nentry = 0; nallargs = nallchargs = 0; multitype = NO; retslot = NULL; for(i = 0; i < NTYPES0; i++) { frexpr((expptr)xretslot[i]); xretslot[i] = 0; } cxslot = -1; chslot = -1; chlgslot = -1; procleng = 0; blklevel = 1; lastargslot = 0; for(lp = labeltab ; lp < labtabend ; ++lp) lp->stateno = 0; hashclear(); /* Clear the list of newly generated identifiers from the previous function */ frexchain(&new_vars); frexchain(&used_builtins); frchain(&assigned_fmts); frchain(&allargs); frchain(&earlylabs); nintnames = 0; highlabtab = labeltab; ctlstack = ctls - 1; for(i = TYADDR; i < TYVOID; i++) { for(cp = templist[i]; cp ; cp = cp->nextp) free( (charptr) (cp->datap) ); frchain(templist + i); autonum[i] = 0; } holdtemps = NULL; dorange = 0; nregvar = 0; highregvar = 0; entries = NULL; rpllist = NULL; inioctl = NO; eqvstart += nequiv; nequiv = 0; dcomplex_seen = 0; for(i = 0 ; i c2) { sprintf(buff, "characters out of order in implicit:%c-%c", c1, c2); err(buff); } else { c1 = letter(c1); c2 = letter(c2); if(type < 0) for(i = c1 ; i<=c2 ; ++i) implstg[i] = - type; else { type = lengtype(type, length); if(type == TYCHAR) { if (length < 0) { err("length (*) in implicit"); length = 1; } } else if (type != TYLONG) length = 0; for(i = c1 ; i<=c2 ; ++i) { impltype[i] = type; implleng[i] = length; } } } } f2c/src/intr.c000066400000000000000000000606701171647030000134470ustar00rootroot00000000000000/**************************************************************** Copyright 1990, 1992, 1994-6, 1998 by AT&T, Lucent Technologies and Bellcore. Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the above copyright notice appear in all copies and that both that the copyright notice and this permission notice and warranty disclaimer appear in supporting documentation, and that the names of AT&T, Bell Laboratories, Lucent or Bellcore or any of their entities not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. AT&T, Lucent and Bellcore disclaim all warranties with regard to this software, including all implied warranties of merchantability and fitness. In no event shall AT&T, Lucent or Bellcore be liable for any special, indirect or consequential damages or any damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortious action, arising out of or in connection with the use or performance of this software. ****************************************************************/ #include "defs.h" #include "names.h" union { int ijunk; struct Intrpacked bits; } packed; struct Intrbits { char intrgroup /* :3 */; char intrstuff /* result type or number of generics */; char intrno /* :7 */; char dblcmplx; char dblintrno; /* for -r8 */ char extflag; /* for -cd, -i90 */ }; /* List of all intrinsic functions. */ LOCAL struct Intrblock { char intrfname[8]; struct Intrbits intrval; } intrtab[ ] = { "int", { INTRCONV, TYLONG }, "real", { INTRCONV, TYREAL, 1 }, /* 1 ==> real(TYDCOMPLEX) yields TYDREAL */ "dble", { INTRCONV, TYDREAL }, "dreal", { INTRCONV, TYDREAL, 0, 0, 0, 1 }, "cmplx", { INTRCONV, TYCOMPLEX }, "dcmplx", { INTRCONV, TYDCOMPLEX, 0, 1 }, "ifix", { INTRCONV, TYLONG }, "idint", { INTRCONV, TYLONG }, "float", { INTRCONV, TYREAL }, "dfloat", { INTRCONV, TYDREAL }, "sngl", { INTRCONV, TYREAL }, "ichar", { INTRCONV, TYLONG }, "iachar", { INTRCONV, TYLONG }, "char", { INTRCONV, TYCHAR }, "achar", { INTRCONV, TYCHAR }, /* any MAX or MIN can be used with any types; the compiler will cast them correctly. So rules against bad syntax in these expressions are not enforced */ "max", { INTRMAX, TYUNKNOWN }, "max0", { INTRMAX, TYLONG }, "amax0", { INTRMAX, TYREAL }, "max1", { INTRMAX, TYLONG }, "amax1", { INTRMAX, TYREAL }, "dmax1", { INTRMAX, TYDREAL }, "and", { INTRBOOL, TYUNKNOWN, OPBITAND }, "or", { INTRBOOL, TYUNKNOWN, OPBITOR }, "xor", { INTRBOOL, TYUNKNOWN, OPBITXOR }, "not", { INTRBOOL, TYUNKNOWN, OPBITNOT }, "lshift", { INTRBOOL, TYUNKNOWN, OPLSHIFT }, "rshift", { INTRBOOL, TYUNKNOWN, OPRSHIFT }, "min", { INTRMIN, TYUNKNOWN }, "min0", { INTRMIN, TYLONG }, "amin0", { INTRMIN, TYREAL }, "min1", { INTRMIN, TYLONG }, "amin1", { INTRMIN, TYREAL }, "dmin1", { INTRMIN, TYDREAL }, "aint", { INTRGEN, 2, 0 }, "dint", { INTRSPEC, TYDREAL, 1 }, "anint", { INTRGEN, 2, 2 }, "dnint", { INTRSPEC, TYDREAL, 3 }, "nint", { INTRGEN, 4, 4 }, "idnint", { INTRGEN, 2, 6 }, "abs", { INTRGEN, 6, 8 }, "iabs", { INTRGEN, 2, 9 }, "dabs", { INTRSPEC, TYDREAL, 11 }, "cabs", { INTRSPEC, TYREAL, 12, 0, 13 }, "zabs", { INTRSPEC, TYDREAL, 13, 1 }, "mod", { INTRGEN, 4, 14 }, "amod", { INTRSPEC, TYREAL, 16, 0, 17 }, "dmod", { INTRSPEC, TYDREAL, 17 }, "sign", { INTRGEN, 4, 18 }, "isign", { INTRGEN, 2, 19 }, "dsign", { INTRSPEC, TYDREAL, 21 }, "dim", { INTRGEN, 4, 22 }, "idim", { INTRGEN, 2, 23 }, "ddim", { INTRSPEC, TYDREAL, 25 }, "dprod", { INTRSPEC, TYDREAL, 26 }, "len", { INTRSPEC, TYLONG, 27 }, "index", { INTRSPEC, TYLONG, 29 }, "imag", { INTRGEN, 2, 31 }, "aimag", { INTRSPEC, TYREAL, 31, 0, 32 }, "dimag", { INTRSPEC, TYDREAL, 32 }, "conjg", { INTRGEN, 2, 33 }, "dconjg", { INTRSPEC, TYDCOMPLEX, 34, 1 }, "sqrt", { INTRGEN, 4, 35 }, "dsqrt", { INTRSPEC, TYDREAL, 36 }, "csqrt", { INTRSPEC, TYCOMPLEX, 37, 0, 38 }, "zsqrt", { INTRSPEC, TYDCOMPLEX, 38, 1 }, "exp", { INTRGEN, 4, 39 }, "dexp", { INTRSPEC, TYDREAL, 40 }, "cexp", { INTRSPEC, TYCOMPLEX, 41, 0, 42 }, "zexp", { INTRSPEC, TYDCOMPLEX, 42, 1 }, "log", { INTRGEN, 4, 43 }, "alog", { INTRSPEC, TYREAL, 43, 0, 44 }, "dlog", { INTRSPEC, TYDREAL, 44 }, "clog", { INTRSPEC, TYCOMPLEX, 45, 0, 46 }, "zlog", { INTRSPEC, TYDCOMPLEX, 46, 1 }, "log10", { INTRGEN, 2, 47 }, "alog10", { INTRSPEC, TYREAL, 47, 0, 48 }, "dlog10", { INTRSPEC, TYDREAL, 48 }, "sin", { INTRGEN, 4, 49 }, "dsin", { INTRSPEC, TYDREAL, 50 }, "csin", { INTRSPEC, TYCOMPLEX, 51, 0, 52 }, "zsin", { INTRSPEC, TYDCOMPLEX, 52, 1 }, "cos", { INTRGEN, 4, 53 }, "dcos", { INTRSPEC, TYDREAL, 54 }, "ccos", { INTRSPEC, TYCOMPLEX, 55, 0, 56 }, "zcos", { INTRSPEC, TYDCOMPLEX, 56, 1 }, "tan", { INTRGEN, 2, 57 }, "dtan", { INTRSPEC, TYDREAL, 58 }, "asin", { INTRGEN, 2, 59 }, "dasin", { INTRSPEC, TYDREAL, 60 }, "acos", { INTRGEN, 2, 61 }, "dacos", { INTRSPEC, TYDREAL, 62 }, "atan", { INTRGEN, 2, 63 }, "datan", { INTRSPEC, TYDREAL, 64 }, "atan2", { INTRGEN, 2, 65 }, "datan2", { INTRSPEC, TYDREAL, 66 }, "sinh", { INTRGEN, 2, 67 }, "dsinh", { INTRSPEC, TYDREAL, 68 }, "cosh", { INTRGEN, 2, 69 }, "dcosh", { INTRSPEC, TYDREAL, 70 }, "tanh", { INTRGEN, 2, 71 }, "dtanh", { INTRSPEC, TYDREAL, 72 }, "lge", { INTRSPEC, TYLOGICAL, 73}, "lgt", { INTRSPEC, TYLOGICAL, 75}, "lle", { INTRSPEC, TYLOGICAL, 77}, "llt", { INTRSPEC, TYLOGICAL, 79}, #if 0 "epbase", { INTRCNST, 4, 0 }, "epprec", { INTRCNST, 4, 4 }, "epemin", { INTRCNST, 2, 8 }, "epemax", { INTRCNST, 2, 10 }, "eptiny", { INTRCNST, 2, 12 }, "ephuge", { INTRCNST, 4, 14 }, "epmrsp", { INTRCNST, 2, 18 }, #endif "fpexpn", { INTRGEN, 4, 81 }, "fpabsp", { INTRGEN, 2, 85 }, "fprrsp", { INTRGEN, 2, 87 }, "fpfrac", { INTRGEN, 2, 89 }, "fpmake", { INTRGEN, 2, 91 }, "fpscal", { INTRGEN, 2, 93 }, "cdabs", { INTRSPEC, TYDREAL, 13, 1, 0, 1 }, "cdsqrt", { INTRSPEC, TYDCOMPLEX, 38, 1, 0, 1 }, "cdexp", { INTRSPEC, TYDCOMPLEX, 42, 1, 0, 1 }, "cdlog", { INTRSPEC, TYDCOMPLEX, 46, 1, 0, 1 }, "cdsin", { INTRSPEC, TYDCOMPLEX, 52, 1, 0, 1 }, "cdcos", { INTRSPEC, TYDCOMPLEX, 56, 1, 0, 1 }, "iand", { INTRBOOL, TYUNKNOWN, OPBITAND, 0, 0, 2 }, "ior", { INTRBOOL, TYUNKNOWN, OPBITOR, 0, 0, 2 }, "ieor", { INTRBOOL, TYUNKNOWN, OPBITXOR, 0, 0, 2 }, "btest", { INTRBGEN, TYLOGICAL, OPBITTEST,0, 0, 2 }, "ibclr", { INTRBGEN, TYUNKNOWN, OPBITCLR, 0, 0, 2 }, "ibset", { INTRBGEN, TYUNKNOWN, OPBITSET, 0, 0, 2 }, "ibits", { INTRBGEN, TYUNKNOWN, OPBITBITS,0, 0, 2 }, "ishft", { INTRBGEN, TYUNKNOWN, OPBITSH, 0, 0, 2 }, "ishftc", { INTRBGEN, TYUNKNOWN, OPBITSHC, 0, 0, 2 }, "" }; LOCAL struct Specblock { char atype; /* Argument type; every arg must have this type */ char rtype; /* Result type */ char nargs; /* Number of arguments */ char spxname[8]; /* Name of the function in Fortran */ char othername; /* index into callbyvalue table */ } spectab[ ] = { { TYREAL,TYREAL,1,"r_int" }, { TYDREAL,TYDREAL,1,"d_int" }, { TYREAL,TYREAL,1,"r_nint" }, { TYDREAL,TYDREAL,1,"d_nint" }, { TYREAL,TYSHORT,1,"h_nint" }, { TYREAL,TYLONG,1,"i_nint" }, { TYDREAL,TYSHORT,1,"h_dnnt" }, { TYDREAL,TYLONG,1,"i_dnnt" }, { TYREAL,TYREAL,1,"r_abs" }, { TYSHORT,TYSHORT,1,"h_abs" }, { TYLONG,TYLONG,1,"i_abs" }, { TYDREAL,TYDREAL,1,"d_abs" }, { TYCOMPLEX,TYREAL,1,"c_abs" }, { TYDCOMPLEX,TYDREAL,1,"z_abs" }, { TYSHORT,TYSHORT,2,"h_mod" }, { TYLONG,TYLONG,2,"i_mod" }, { TYREAL,TYREAL,2,"r_mod" }, { TYDREAL,TYDREAL,2,"d_mod" }, { TYREAL,TYREAL,2,"r_sign" }, { TYSHORT,TYSHORT,2,"h_sign" }, { TYLONG,TYLONG,2,"i_sign" }, { TYDREAL,TYDREAL,2,"d_sign" }, { TYREAL,TYREAL,2,"r_dim" }, { TYSHORT,TYSHORT,2,"h_dim" }, { TYLONG,TYLONG,2,"i_dim" }, { TYDREAL,TYDREAL,2,"d_dim" }, { TYREAL,TYDREAL,2,"d_prod" }, { TYCHAR,TYSHORT,1,"h_len" }, { TYCHAR,TYLONG,1,"i_len" }, { TYCHAR,TYSHORT,2,"h_indx" }, { TYCHAR,TYLONG,2,"i_indx" }, { TYCOMPLEX,TYREAL,1,"r_imag" }, { TYDCOMPLEX,TYDREAL,1,"d_imag" }, { TYCOMPLEX,TYCOMPLEX,1,"r_cnjg" }, { TYDCOMPLEX,TYDCOMPLEX,1,"d_cnjg" }, { TYREAL,TYREAL,1,"r_sqrt", 1 }, { TYDREAL,TYDREAL,1,"d_sqrt", 1 }, { TYCOMPLEX,TYCOMPLEX,1,"c_sqrt" }, { TYDCOMPLEX,TYDCOMPLEX,1,"z_sqrt" }, { TYREAL,TYREAL,1,"r_exp", 2 }, { TYDREAL,TYDREAL,1,"d_exp", 2 }, { TYCOMPLEX,TYCOMPLEX,1,"c_exp" }, { TYDCOMPLEX,TYDCOMPLEX,1,"z_exp" }, { TYREAL,TYREAL,1,"r_log", 3 }, { TYDREAL,TYDREAL,1,"d_log", 3 }, { TYCOMPLEX,TYCOMPLEX,1,"c_log" }, { TYDCOMPLEX,TYDCOMPLEX,1,"z_log" }, { TYREAL,TYREAL,1,"r_lg10" }, { TYDREAL,TYDREAL,1,"d_lg10" }, { TYREAL,TYREAL,1,"r_sin", 4 }, { TYDREAL,TYDREAL,1,"d_sin", 4 }, { TYCOMPLEX,TYCOMPLEX,1,"c_sin" }, { TYDCOMPLEX,TYDCOMPLEX,1,"z_sin" }, { TYREAL,TYREAL,1,"r_cos", 5 }, { TYDREAL,TYDREAL,1,"d_cos", 5 }, { TYCOMPLEX,TYCOMPLEX,1,"c_cos" }, { TYDCOMPLEX,TYDCOMPLEX,1,"z_cos" }, { TYREAL,TYREAL,1,"r_tan", 6 }, { TYDREAL,TYDREAL,1,"d_tan", 6 }, { TYREAL,TYREAL,1,"r_asin", 7 }, { TYDREAL,TYDREAL,1,"d_asin", 7 }, { TYREAL,TYREAL,1,"r_acos", 8 }, { TYDREAL,TYDREAL,1,"d_acos", 8 }, { TYREAL,TYREAL,1,"r_atan", 9 }, { TYDREAL,TYDREAL,1,"d_atan", 9 }, { TYREAL,TYREAL,2,"r_atn2", 10 }, { TYDREAL,TYDREAL,2,"d_atn2", 10 }, { TYREAL,TYREAL,1,"r_sinh", 11 }, { TYDREAL,TYDREAL,1,"d_sinh", 11 }, { TYREAL,TYREAL,1,"r_cosh", 12 }, { TYDREAL,TYDREAL,1,"d_cosh", 12 }, { TYREAL,TYREAL,1,"r_tanh", 13 }, { TYDREAL,TYDREAL,1,"d_tanh", 13 }, { TYCHAR,TYLOGICAL,2,"hl_ge" }, { TYCHAR,TYLOGICAL,2,"l_ge" }, { TYCHAR,TYLOGICAL,2,"hl_gt" }, { TYCHAR,TYLOGICAL,2,"l_gt" }, { TYCHAR,TYLOGICAL,2,"hl_le" }, { TYCHAR,TYLOGICAL,2,"l_le" }, { TYCHAR,TYLOGICAL,2,"hl_lt" }, { TYCHAR,TYLOGICAL,2,"l_lt" }, { TYREAL,TYSHORT,1,"hr_expn" }, { TYREAL,TYLONG,1,"ir_expn" }, { TYDREAL,TYSHORT,1,"hd_expn" }, { TYDREAL,TYLONG,1,"id_expn" }, { TYREAL,TYREAL,1,"r_absp" }, { TYDREAL,TYDREAL,1,"d_absp" }, { TYREAL,TYDREAL,1,"r_rrsp" }, { TYDREAL,TYDREAL,1,"d_rrsp" }, { TYREAL,TYREAL,1,"r_frac" }, { TYDREAL,TYDREAL,1,"d_frac" }, { TYREAL,TYREAL,2,"r_make" }, { TYDREAL,TYDREAL,2,"d_make" }, { TYREAL,TYREAL,2,"r_scal" }, { TYDREAL,TYDREAL,2,"d_scal" }, { 0 } } ; #if 0 LOCAL struct Incstblock { char atype; char rtype; char constno; } consttab[ ] = { { TYSHORT, TYLONG, 0 }, { TYLONG, TYLONG, 1 }, { TYREAL, TYLONG, 2 }, { TYDREAL, TYLONG, 3 }, { TYSHORT, TYLONG, 4 }, { TYLONG, TYLONG, 5 }, { TYREAL, TYLONG, 6 }, { TYDREAL, TYLONG, 7 }, { TYREAL, TYLONG, 8 }, { TYDREAL, TYLONG, 9 }, { TYREAL, TYLONG, 10 }, { TYDREAL, TYLONG, 11 }, { TYREAL, TYREAL, 0 }, { TYDREAL, TYDREAL, 1 }, { TYSHORT, TYLONG, 12 }, { TYLONG, TYLONG, 13 }, { TYREAL, TYREAL, 2 }, { TYDREAL, TYDREAL, 3 }, { TYREAL, TYREAL, 4 }, { TYDREAL, TYDREAL, 5 } }; #endif char *callbyvalue[ ] = {0, "sqrt", "exp", "log", "sin", "cos", "tan", "asin", "acos", "atan", "atan2", "sinh", "cosh", "tanh" }; void r8fix(Void) /* adjust tables for -r8 */ { register struct Intrblock *I; register struct Specblock *S; for(I = intrtab; I->intrfname[0]; I++) if (I->intrval.intrgroup != INTRGEN) switch(I->intrval.intrstuff) { case TYREAL: I->intrval.intrstuff = TYDREAL; I->intrval.intrno = I->intrval.dblintrno; break; case TYCOMPLEX: I->intrval.intrstuff = TYDCOMPLEX; I->intrval.intrno = I->intrval.dblintrno; I->intrval.dblcmplx = 1; } for(S = spectab; S->atype; S++) switch(S->atype) { case TYCOMPLEX: S->atype = TYDCOMPLEX; if (S->rtype == TYREAL) S->rtype = TYDREAL; else if (S->rtype == TYCOMPLEX) S->rtype = TYDCOMPLEX; switch(S->spxname[0]) { case 'r': S->spxname[0] = 'd'; break; case 'c': S->spxname[0] = 'z'; break; default: Fatal("r8fix bug"); } break; case TYREAL: S->atype = TYDREAL; switch(S->rtype) { case TYREAL: S->rtype = TYDREAL; if (S->spxname[0] != 'r') Fatal("r8fix bug"); S->spxname[0] = 'd'; case TYDREAL: /* d_prod */ break; case TYSHORT: if (!strcmp(S->spxname, "hr_expn")) S->spxname[1] = 'd'; else if (!strcmp(S->spxname, "h_nint")) strcpy(S->spxname, "h_dnnt"); else Fatal("r8fix bug"); break; case TYLONG: if (!strcmp(S->spxname, "ir_expn")) S->spxname[1] = 'd'; else if (!strcmp(S->spxname, "i_nint")) strcpy(S->spxname, "i_dnnt"); else Fatal("r8fix bug"); break; default: Fatal("r8fix bug"); } } } static expptr #ifdef KR_headers foldminmax(ismin, argsp) int ismin; struct Listblock *argsp; #else foldminmax(int ismin, struct Listblock *argsp) #endif { #ifndef NO_LONG_LONG Llong cq, cq1; #endif Constp h; double cd, cd1; ftnint ci; int mtype; struct Chain *cp, *cpx; mtype = argsp->vtype; cp = cpx = argsp->listp; h = &((expptr)cp->datap)->constblock; #ifndef NO_LONG_LONG if (mtype == TYQUAD) { cq = h->vtype == TYQUAD ? h->Const.cq : h->Const.ci; while(cp = cp->nextp) { h = &((expptr)cp->datap)->constblock; cq1 = h->vtype == TYQUAD ? h->Const.cq : h->Const.ci; if (ismin) { if (cq > cq1) { cq = cq1; cpx = cp; } } else { if (cq < cq1) { cq = cq1; cpx = cp; } } } } else #endif if (ISINT(mtype)) { ci = h->Const.ci; if (ismin) while(cp = cp->nextp) { h = &((expptr)cp->datap)->constblock; if (ci > h->Const.ci) { ci = h->Const.ci; cpx = cp; } } else while(cp = cp->nextp) { h = &((expptr)cp->datap)->constblock; if (ci < h->Const.ci) { ci = h->Const.ci; cpx = cp; } } } else { if (ISREAL(h->vtype)) cd = h->vstg ? atof(h->Const.cds[0]) : h->Const.cd[0]; #ifndef NO_LONG_LONG else if (h->vtype == TYQUAD) cd = h->Const.cq; #endif else cd = h->Const.ci; while(cp = cp->nextp) { h = &((expptr)cp->datap)->constblock; if (ISREAL(h->vtype)) cd1 = h->vstg ? atof(h->Const.cds[0]) : h->Const.cd[0]; #ifndef NO_LONG_LONG else if (h->vtype == TYQUAD) cd1 = h->Const.cq; #endif else cd1 = h->Const.ci; if (ismin) { if (cd > cd1) { cd = cd1; cpx = cp; } } else { if (cd < cd1) { cd = cd1; cpx = cp; } } } } h = &((expptr)cpx->datap)->constblock; cpx->datap = 0; frexpr((tagptr)argsp); if (h->vtype != mtype) return mkconv(mtype, (expptr)h); return (expptr)h; } expptr #ifdef KR_headers intrcall(np, argsp, nargs) Namep np; struct Listblock *argsp; int nargs; #else intrcall(Namep np, struct Listblock *argsp, int nargs) #endif { int i, rettype; ftnint k; Addrp ap; register struct Specblock *sp; register struct Chain *cp; expptr q, ep; int constargs, mtype, op; int f1field, f2field, f3field; char *s; static char bit_bits[] = "?bit_bits", bit_shift[] = "?bit_shift", bit_cshift[] = "?bit_cshift"; static char *bitop[3] = { bit_bits, bit_shift, bit_cshift }; static int t_pref[2] = { 'l', 'q' }; packed.ijunk = np->vardesc.varno; f1field = packed.bits.f1; f2field = packed.bits.f2; f3field = packed.bits.f3; if(nargs == 0) goto badnargs; mtype = 0; constargs = 1; for(cp = argsp->listp ; cp ; cp = cp->nextp) { ep = (expptr)cp->datap; if (!ISCONST(ep)) constargs = 0; else if( ep->headblock.vtype==TYSHORT ) cp->datap = (char *) mkconv(tyint, ep); mtype = maxtype(mtype, ep->headblock.vtype); } switch(f1field) { case INTRBGEN: op = f3field; if( ! ONEOF(mtype, MSKINT) ) goto badtype; if (op < OPBITBITS) { if(nargs != 2) goto badnargs; if (op != OPBITTEST) { #ifdef TYQUAD if (mtype == TYQUAD) op += 2; #endif goto intrbool2; } q = mkexpr(op, (expptr)argsp->listp->datap, (expptr)argsp->listp->nextp->datap); q->exprblock.vtype = TYLOGICAL; goto intrbool2a; } if (nargs != 2 && (nargs != 3 || op == OPBITSH)) goto badnargs; cp = argsp->listp; ep = (expptr)cp->datap; if (ep->headblock.vtype < TYLONG) cp->datap = (char *)mkconv(TYLONG, ep); while(cp->nextp) { cp = cp->nextp; ep = (expptr)cp->datap; if (ep->headblock.vtype != TYLONG) cp->datap = (char *)mkconv(TYLONG, ep); } if (op == OPBITSH) { ep = (expptr)argsp->listp->nextp->datap; if (ISCONST(ep)) { if ((k = ep->constblock.Const.ci) < 0) { q = (expptr)argsp->listp->datap; if (ISCONST(q)) { ep->constblock.Const.ci = -k; op = OPRSHIFT; goto intrbool2; } } else { op = OPLSHIFT; goto intrbool2; } } } else if (nargs == 2) { if (op == OPBITBITS) goto badnargs; cp->nextp = mkchain((char*)ICON(-1), 0); } ep = (expptr)argsp->listp->datap; i = ep->headblock.vtype; s = bitop[op - OPBITBITS]; *s = t_pref[i - TYLONG]; ap = builtin(i, s, 1); return fixexpr((Exprp) mkexpr(OPCCALL, (expptr)ap, (expptr)argsp) ); case INTRBOOL: op = f3field; if( ! ONEOF(mtype, MSKINT|MSKLOGICAL) ) goto badtype; if(op == OPBITNOT) { if(nargs != 1) goto badnargs; q = mkexpr(OPBITNOT, (expptr)argsp->listp->datap, ENULL); } else { if(nargs != 2) goto badnargs; intrbool2: q = mkexpr(op, (expptr)argsp->listp->datap, (expptr)argsp->listp->nextp->datap); } intrbool2a: frchain( &(argsp->listp) ); free( (charptr) argsp); return(q); case INTRCONV: rettype = f2field; switch(rettype) { case TYLONG: rettype = tyint; break; case TYLOGICAL: rettype = tylog; } if( ISCOMPLEX(rettype) && nargs==2) { expptr qr, qi; qr = (expptr) argsp->listp->datap; qi = (expptr) argsp->listp->nextp->datap; if (qr->headblock.vtype == TYDREAL || qi->headblock.vtype == TYDREAL) rettype = TYDCOMPLEX; if(ISCONST(qr) && ISCONST(qi)) q = mkcxcon(qr,qi); else q = mkexpr(OPCONV,mkconv(rettype-2,qr), mkconv(rettype-2,qi)); } else if(nargs == 1) { if (f3field && ((Exprp)argsp->listp->datap)->vtype == TYDCOMPLEX) rettype = TYDREAL; q = mkconv(rettype+100, (expptr)argsp->listp->datap); if (q->tag == TADDR) q->addrblock.parenused = 1; } else goto badnargs; q->headblock.vtype = rettype; frchain(&(argsp->listp)); free( (charptr) argsp); return(q); #if 0 case INTRCNST: /* Machine-dependent f77 stuff that f2c omits: intcon contains radix for short int radix for long int radix for single precision radix for double precision precision for short int precision for long int precision for single precision precision for double precision emin for single precision emin for double precision emax for single precision emax for double prcision largest short int largest long int realcon contains tiny for single precision tiny for double precision huge for single precision huge for double precision mrsp (epsilon) for single precision mrsp (epsilon) for double precision */ { register struct Incstblock *cstp; extern ftnint intcon[14]; extern double realcon[6]; cstp = consttab + f3field; for(i=0 ; iatype == mtype) goto foundconst; else ++cstp; goto badtype; foundconst: switch(cstp->rtype) { case TYLONG: return(mkintcon(intcon[cstp->constno])); case TYREAL: case TYDREAL: return(mkrealcon(cstp->rtype, realcon[cstp->constno]) ); default: Fatal("impossible intrinsic constant"); } } #endif case INTRGEN: sp = spectab + f3field; if(no66flag) if(sp->atype == mtype) goto specfunct; else err66("generic function"); for(i=0; iatype == mtype) goto specfunct; else ++sp; warn1 ("bad argument type to intrinsic %s", np->fvarname); /* Made this a warning rather than an error so things like "log (5) ==> log (5.0)" can be accommodated. When none of these cases matches, the argument is cast up to the first type in the spectab list; this first type is assumed to be the "smallest" type, e.g. REAL before DREAL before COMPLEX, before DCOMPLEX */ sp = spectab + f3field; mtype = sp -> atype; goto specfunct; case INTRSPEC: sp = spectab + f3field; specfunct: if(tyint==TYLONG && ONEOF(sp->rtype,M(TYSHORT)|M(TYLOGICAL)) && (sp+1)->atype==sp->atype) ++sp; if(nargs != sp->nargs) goto badnargs; if(mtype != sp->atype) goto badtype; /* NOTE!! I moved fixargs (YES) into the ELSE branch so that constants in the inline expression wouldn't get put into the constant table */ fixargs (NO, argsp); cast_args (mtype, argsp -> listp); if(q = Inline((int)(sp-spectab), mtype, argsp->listp)) { frchain( &(argsp->listp) ); free( (charptr) argsp); } else { if(sp->othername) { /* C library routines that return double... */ /* sp->rtype might be TYREAL */ ap = builtin(sp->rtype, callbyvalue[sp->othername], 1); q = fixexpr((Exprp) mkexpr(OPCCALL, (expptr)ap, (expptr)argsp) ); } else { fixargs(YES, argsp); ap = builtin(sp->rtype, sp->spxname, 0); q = fixexpr((Exprp) mkexpr(OPCALL, (expptr)ap, (expptr)argsp) ); } /* else */ } /* else */ return(q); case INTRMIN: case INTRMAX: if(nargs < 2) goto badnargs; if( ! ONEOF(mtype, MSKINT|MSKREAL) ) goto badtype; argsp->vtype = mtype; if (constargs) q = foldminmax(f1field==INTRMIN, argsp); else q = mkexpr(f1field==INTRMIN ? OPMIN : OPMAX, (expptr)argsp, ENULL); q->headblock.vtype = mtype; rettype = f2field; if(rettype == TYLONG) rettype = tyint; else if(rettype == TYUNKNOWN) rettype = mtype; return( mkconv(rettype, q) ); default: fatali("intrcall: bad intrgroup %d", f1field); } badnargs: errstr("bad number of arguments to intrinsic %s", np->fvarname); goto bad; badtype: errstr("bad argument type to intrinsic %s", np->fvarname); bad: return( errnode() ); } int #ifdef KR_headers intrfunct(s) char *s; #else intrfunct(char *s) #endif { register struct Intrblock *p; int i; extern int intr_omit; for(p = intrtab; p->intrval.intrgroup!=INTREND ; ++p) { if( !strcmp(s, p->intrfname) ) { if (i = p->intrval.extflag) { if (i & intr_omit) return 0; if (noextflag) errext(s); } packed.bits.f1 = p->intrval.intrgroup; packed.bits.f2 = p->intrval.intrstuff; packed.bits.f3 = p->intrval.intrno; packed.bits.f4 = p->intrval.dblcmplx; return(packed.ijunk); } } return(0); } Addrp #ifdef KR_headers intraddr(np) Namep np; #else intraddr(Namep np) #endif { Addrp q; register struct Specblock *sp; int f3field; if(np->vclass!=CLPROC || np->vprocclass!=PINTRINSIC) fatalstr("intraddr: %s is not intrinsic", np->fvarname); packed.ijunk = np->vardesc.varno; f3field = packed.bits.f3; switch(packed.bits.f1) { case INTRGEN: /* imag, log, and log10 arent specific functions */ if(f3field==31 || f3field==43 || f3field==47) goto bad; case INTRSPEC: sp = spectab + f3field; if (tyint == TYLONG && (sp->rtype == TYSHORT || sp->rtype == TYLOGICAL)) ++sp; q = builtin(sp->rtype, sp->spxname, sp->othername ? 1 : 0); return(q); case INTRCONV: case INTRMIN: case INTRMAX: case INTRBOOL: case INTRCNST: case INTRBGEN: bad: errstr("cannot pass %s as actual", np->fvarname); return((Addrp)errnode()); } fatali("intraddr: impossible f1=%d\n", (int) packed.bits.f1); /* NOT REACHED */ return 0; } void #ifdef KR_headers cast_args(maxtype, args) int maxtype; chainp args; #else cast_args(int maxtype, chainp args) #endif { for (; args; args = args -> nextp) { expptr e = (expptr) args->datap; if (e -> headblock.vtype != maxtype) if (e -> tag == TCONST) args->datap = (char *) mkconv(maxtype, e); else { Addrp temp = mktmp(maxtype, ENULL); puteq(cpexpr((expptr)temp), e); args->datap = (char *)temp; } /* else */ } /* for */ } /* cast_args */ expptr #ifdef KR_headers Inline(fno, type, args) int fno; int type; struct Chain *args; #else Inline(int fno, int type, struct Chain *args) #endif { register expptr q, t, t1; switch(fno) { case 8: /* real abs */ case 9: /* short int abs */ case 10: /* long int abs */ case 11: /* double precision abs */ if( addressable(q = (expptr) args->datap) ) { t = q; q = NULL; } else t = (expptr) mktmp(type,ENULL); t1 = mkexpr(type == TYREAL && forcedouble ? OPDABS : OPABS, cpexpr(t), ENULL); if(q) t1 = mkexpr(OPCOMMA, mkexpr(OPASSIGN, cpexpr(t),q), t1); frexpr(t); return(t1); case 26: /* dprod */ q = mkexpr(OPSTAR, mkconv(TYDREAL,(expptr)args->datap), (expptr)args->nextp->datap); return(q); case 27: /* len of character string */ q = (expptr) cpexpr(((tagptr)args->datap)->headblock.vleng); frexpr((expptr)args->datap); return mkconv(tyioint, q); case 14: /* half-integer mod */ case 15: /* mod */ return mkexpr(OPMOD, (expptr) args->datap, (expptr) args->nextp->datap); } return(NULL); } f2c/src/io.c000066400000000000000000000737101171647030000131010ustar00rootroot00000000000000/**************************************************************** Copyright 1990, 1991, 1993, 1994, 1996, 2000 by AT&T, Lucent Technologies and Bellcore. Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the above copyright notice appear in all copies and that both that the copyright notice and this permission notice and warranty disclaimer appear in supporting documentation, and that the names of AT&T, Bell Laboratories, Lucent or Bellcore or any of their entities not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. AT&T, Lucent and Bellcore disclaim all warranties with regard to this software, including all implied warranties of merchantability and fitness. In no event shall AT&T, Lucent or Bellcore be liable for any special, indirect or consequential damages or any damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortious action, arising out of or in connection with the use or performance of this software. ****************************************************************/ /* Routines to generate code for I/O statements. Some corrections and improvements due to David Wasley, U. C. Berkeley */ /* TEMPORARY */ #define TYIOINT TYLONG #define SZIOINT SZLONG #include "defs.h" #include "names.h" #include "iob.h" extern int byterev, inqmask; static void dofclose Argdcl((void)); static void dofinquire Argdcl((void)); static void dofmove Argdcl((char*)); static void dofopen Argdcl((void)); static void doiolist Argdcl((chainp)); static void ioset Argdcl((int, int, expptr)); static void ioseta Argdcl((int, Addrp)); static void iosetc Argdcl((int, expptr)); static void iosetip Argdcl((int, int)); static void iosetlc Argdcl((int, int, int)); static void putio Argdcl((expptr, expptr)); static void putiocall Argdcl((expptr)); iob_data *iob_list; Addrp io_structs[9]; LOCAL char ioroutine[12]; LOCAL long ioendlab; LOCAL long ioerrlab; LOCAL int endbit; LOCAL int errbit; LOCAL long jumplab; LOCAL long skiplab; LOCAL int ioformatted; LOCAL int statstruct = NO; LOCAL struct Labelblock *skiplabel; Addrp ioblkp; #define UNFORMATTED 0 #define FORMATTED 1 #define LISTDIRECTED 2 #define NAMEDIRECTED 3 #define V(z) ioc[z].iocval #define IOALL 07777 LOCAL struct Ioclist { char *iocname; int iotype; expptr iocval; } ioc[ ] = { { "", 0 }, { "unit", IOALL }, { "fmt", M(IOREAD) | M(IOWRITE) }, { "err", IOALL }, { "end", M(IOREAD) }, { "iostat", IOALL }, { "rec", M(IOREAD) | M(IOWRITE) }, { "recl", M(IOOPEN) | M(IOINQUIRE) }, { "file", M(IOOPEN) | M(IOINQUIRE) }, { "status", M(IOOPEN) | M(IOCLOSE) }, { "access", M(IOOPEN) | M(IOINQUIRE) }, { "form", M(IOOPEN) | M(IOINQUIRE) }, { "blank", M(IOOPEN) | M(IOINQUIRE) }, { "exist", M(IOINQUIRE) }, { "opened", M(IOINQUIRE) }, { "number", M(IOINQUIRE) }, { "named", M(IOINQUIRE) }, { "name", M(IOINQUIRE) }, { "sequential", M(IOINQUIRE) }, { "direct", M(IOINQUIRE) }, { "formatted", M(IOINQUIRE) }, { "unformatted", M(IOINQUIRE) }, { "nextrec", M(IOINQUIRE) }, { "nml", M(IOREAD) | M(IOWRITE) } }; #define NIOS (sizeof(ioc)/sizeof(struct Ioclist) - 1) /* #define IOSUNIT 1 */ /* #define IOSFMT 2 */ #define IOSERR 3 #define IOSEND 4 #define IOSIOSTAT 5 #define IOSREC 6 #define IOSRECL 7 #define IOSFILE 8 #define IOSSTATUS 9 #define IOSACCESS 10 #define IOSFORM 11 #define IOSBLANK 12 #define IOSEXISTS 13 #define IOSOPENED 14 #define IOSNUMBER 15 #define IOSNAMED 16 #define IOSNAME 17 #define IOSSEQUENTIAL 18 #define IOSDIRECT 19 #define IOSFORMATTED 20 #define IOSUNFORMATTED 21 #define IOSNEXTREC 22 #define IOSNML 23 #define IOSTP V(IOSIOSTAT) /* offsets in generated structures */ #define SZFLAG SZIOINT /* offsets for external READ and WRITE statements */ #define XERR 0 #define XUNIT SZFLAG #define XEND SZFLAG + SZIOINT #define XFMT 2*SZFLAG + SZIOINT #define XREC 2*SZFLAG + SZIOINT + SZADDR /* offsets for internal READ and WRITE statements */ #define XIUNIT SZFLAG #define XIEND SZFLAG + SZADDR #define XIFMT 2*SZFLAG + SZADDR #define XIRLEN 2*SZFLAG + 2*SZADDR #define XIRNUM 2*SZFLAG + 2*SZADDR + SZIOINT #define XIREC 2*SZFLAG + 2*SZADDR + 2*SZIOINT /* offsets for OPEN statements */ #define XFNAME SZFLAG + SZIOINT #define XFNAMELEN SZFLAG + SZIOINT + SZADDR #define XSTATUS SZFLAG + 2*SZIOINT + SZADDR #define XACCESS SZFLAG + 2*SZIOINT + 2*SZADDR #define XFORMATTED SZFLAG + 2*SZIOINT + 3*SZADDR #define XRECLEN SZFLAG + 2*SZIOINT + 4*SZADDR #define XBLANK SZFLAG + 3*SZIOINT + 4*SZADDR /* offset for CLOSE statement */ #define XCLSTATUS SZFLAG + SZIOINT /* offsets for INQUIRE statement */ #define XFILE SZFLAG + SZIOINT #define XFILELEN SZFLAG + SZIOINT + SZADDR #define XEXISTS SZFLAG + 2*SZIOINT + SZADDR #define XOPEN SZFLAG + 2*SZIOINT + 2*SZADDR #define XNUMBER SZFLAG + 2*SZIOINT + 3*SZADDR #define XNAMED SZFLAG + 2*SZIOINT + 4*SZADDR #define XNAME SZFLAG + 2*SZIOINT + 5*SZADDR #define XNAMELEN SZFLAG + 2*SZIOINT + 6*SZADDR #define XQACCESS SZFLAG + 3*SZIOINT + 6*SZADDR #define XQACCLEN SZFLAG + 3*SZIOINT + 7*SZADDR #define XSEQ SZFLAG + 4*SZIOINT + 7*SZADDR #define XSEQLEN SZFLAG + 4*SZIOINT + 8*SZADDR #define XDIRECT SZFLAG + 5*SZIOINT + 8*SZADDR #define XDIRLEN SZFLAG + 5*SZIOINT + 9*SZADDR #define XFORM SZFLAG + 6*SZIOINT + 9*SZADDR #define XFORMLEN SZFLAG + 6*SZIOINT + 10*SZADDR #define XFMTED SZFLAG + 7*SZIOINT + 10*SZADDR #define XFMTEDLEN SZFLAG + 7*SZIOINT + 11*SZADDR #define XUNFMT SZFLAG + 8*SZIOINT + 11*SZADDR #define XUNFMTLEN SZFLAG + 8*SZIOINT + 12*SZADDR #define XQRECL SZFLAG + 9*SZIOINT + 12*SZADDR #define XNEXTREC SZFLAG + 9*SZIOINT + 13*SZADDR #define XQBLANK SZFLAG + 9*SZIOINT + 14*SZADDR #define XQBLANKLEN SZFLAG + 9*SZIOINT + 15*SZADDR LOCAL char *cilist_names[] = { "cilist", "cierr", "ciunit", "ciend", "cifmt", "cirec" }; LOCAL char *icilist_names[] = { "icilist", "icierr", "iciunit", "iciend", "icifmt", "icirlen", "icirnum" }; LOCAL char *olist_names[] = { "olist", "oerr", "ounit", "ofnm", "ofnmlen", "osta", "oacc", "ofm", "orl", "oblnk" }; LOCAL char *cllist_names[] = { "cllist", "cerr", "cunit", "csta" }; LOCAL char *alist_names[] = { "alist", "aerr", "aunit" }; LOCAL char *inlist_names[] = { "inlist", "inerr", "inunit", "infile", "infilen", "inex", "inopen", "innum", "innamed", "inname", "innamlen", "inacc", "inacclen", "inseq", "inseqlen", "indir", "indirlen", "infmt", "infmtlen", "inform", "informlen", "inunf", "inunflen", "inrecl", "innrec", "inblank", "inblanklen" }; LOCAL char **io_fields; #define zork(n,t) n, sizeof(n)/sizeof(char *) - 1, t LOCAL io_setup io_stuff[] = { zork(cilist_names, TYCILIST), /* external read/write */ zork(inlist_names, TYINLIST), /* inquire */ zork(olist_names, TYOLIST), /* open */ zork(cllist_names, TYCLLIST), /* close */ zork(alist_names, TYALIST), /* rewind */ zork(alist_names, TYALIST), /* backspace */ zork(alist_names, TYALIST), /* endfile */ zork(icilist_names,TYICILIST), /* internal read */ zork(icilist_names,TYICILIST) /* internal write */ }; #undef zork int #ifdef KR_headers fmtstmt(lp) register struct Labelblock *lp; #else fmtstmt(register struct Labelblock *lp) #endif { if(lp == NULL) { execerr("unlabeled format statement" , CNULL); return(-1); } if(lp->labtype == LABUNKNOWN) { lp->labtype = LABFORMAT; lp->labelno = (int)newlabel(); } else if(lp->labtype != LABFORMAT) { execerr("bad format number", CNULL); return(-1); } return(lp->labelno); } void #ifdef KR_headers setfmt(lp) struct Labelblock *lp; #else setfmt(struct Labelblock *lp) #endif { char *s, *s0, *sc, *se, *t; int k, n, parity; s0 = s = lexline(&n); se = t = s + n; /* warn of trivial errors, e.g. " 11 CONTINUE" (one too few spaces) */ /* following FORMAT... */ if (n <= 0) warn("No (...) after FORMAT"); else if (*s != '(') warni("%c rather than ( after FORMAT", *s); else if (se[-1] != ')') { *se = 0; while(--t > s && *t != ')') ; if (t <= s) warn("No ) at end of FORMAT statement"); else if (se - t > 30) warn1("Extraneous text at end of FORMAT: ...%s", se-12); else warn1("Extraneous text at end of FORMAT: %s", t+1); t = se; } /* fix MYQUOTES (\002's) and \\'s */ parity = 1; str_fmt['%'] = "%"; while(s < se) { k = *(unsigned char *)s++; if (k == 2) { if ((parity ^= 1) && *s == 2) { t -= 2; ++s; } else t += 3; } else { sc = str_fmt[k]; while(*++sc) t++; } } s = s0; parity = 1; if (lp) { lp->fmtstring = t = mem((int)(t - s + 1), 0); while(s < se) { k = *(unsigned char *)s++; if (k == 2) { if ((parity ^= 1) && *s == 2) s++; else { t[0] = '\\'; t[1] = '0'; t[2] = '0'; t[3] = '2'; t += 4; } } else { sc = str_fmt[k]; do *t++ = *sc++; while(*sc); } } *t = 0; } str_fmt['%'] = "%%"; flline(); } void #ifdef KR_headers startioctl() #else startioctl() #endif { register int i; inioctl = YES; nioctl = 0; ioformatted = UNFORMATTED; for(i = 1 ; i<=NIOS ; ++i) V(i) = NULL; } static long newiolabel(Void) { long rv; rv = ++lastiolabno; skiplabel = mklabel(rv); skiplabel->labdefined = 1; return rv; } void endioctl(Void) { int i; expptr p; struct io_setup *ios; inioctl = NO; /* set up for error recovery */ ioerrlab = ioendlab = skiplab = jumplab = 0; if(p = V(IOSEND)) if(ISICON(p)) execlab(ioendlab = p->constblock.Const.ci); else err("bad end= clause"); if(p = V(IOSERR)) if(ISICON(p)) execlab(ioerrlab = p->constblock.Const.ci); else err("bad err= clause"); if(IOSTP) if(IOSTP->tag!=TADDR || ! ISINT(IOSTP->addrblock.vtype) ) { err("iostat must be an integer variable"); frexpr(IOSTP); IOSTP = NULL; } if(iostmt == IOREAD) { if(IOSTP) { if(ioerrlab && ioendlab && ioerrlab==ioendlab) jumplab = ioerrlab; else skiplab = jumplab = newiolabel(); } else { if(ioerrlab && ioendlab && ioerrlab!=ioendlab) { IOSTP = (expptr) mktmp(TYINT, ENULL); skiplab = jumplab = newiolabel(); } else jumplab = (ioerrlab ? ioerrlab : ioendlab); } } else if(iostmt == IOWRITE) { if(IOSTP && !ioerrlab) skiplab = jumplab = newiolabel(); else jumplab = ioerrlab; } else jumplab = ioerrlab; endbit = IOSTP!=NULL || ioendlab!=0; /* for use in startrw() */ errbit = IOSTP!=NULL || ioerrlab!=0; if (jumplab && !IOSTP) IOSTP = (expptr) mktmp(TYINT, ENULL); if(iostmt!=IOREAD && iostmt!=IOWRITE) { ios = io_stuff + iostmt; io_fields = ios->fields; ioblkp = io_structs[iostmt]; if(ioblkp == NULL) io_structs[iostmt] = ioblkp = autovar(1, ios->type, ENULL, ""); ioset(TYIOINT, XERR, ICON(errbit)); } switch(iostmt) { case IOOPEN: dofopen(); break; case IOCLOSE: dofclose(); break; case IOINQUIRE: dofinquire(); break; case IOBACKSPACE: dofmove("f_back"); break; case IOREWIND: dofmove("f_rew"); break; case IOENDFILE: dofmove("f_end"); break; case IOREAD: case IOWRITE: startrw(); break; default: fatali("impossible iostmt %d", iostmt); } for(i = 1 ; i<=NIOS ; ++i) if(i!=IOSIOSTAT && V(i)!=NULL) frexpr(V(i)); } int iocname(Void) { register int i; int found, mask; found = 0; mask = M(iostmt); for(i = 1 ; i <= NIOS ; ++i) if(!strcmp(ioc[i].iocname, token)) if(ioc[i].iotype & mask) return(i); else { found = i; break; } if(found) { if (iostmt == IOOPEN && !strcmp(ioc[i].iocname, "name")) { NOEXT("open with \"name=\" treated as \"file=\""); for(i = 1; strcmp(ioc[i].iocname, "file"); i++); return i; } errstr("invalid control %s for statement", ioc[found].iocname); } else errstr("unknown iocontrol %s", token); return(IOSBAD); } void #ifdef KR_headers ioclause(n, p) register int n; register expptr p; #else ioclause(register int n, register expptr p) #endif { struct Ioclist *iocp; ++nioctl; if(n == IOSBAD) return; if(n == IOSPOSITIONAL) { n = nioctl; if (n == IOSFMT) { if (iostmt == IOOPEN) { n = IOSFILE; NOEXT("file= specifier omitted from open"); } else if (iostmt < IOREAD) goto illegal; } else if(n > IOSFMT) { illegal: err("illegal positional iocontrol"); return; } } else if (n == IOSNML) n = IOSFMT; if(p == NULL) { if(n == IOSUNIT) p = (expptr) (iostmt==IOREAD ? IOSTDIN : IOSTDOUT); else if(n != IOSFMT) { err("illegal * iocontrol"); return; } } if(n == IOSFMT) ioformatted = (p==NULL ? LISTDIRECTED : FORMATTED); iocp = & ioc[n]; if(iocp->iocval == NULL) { if(n!=IOSFMT && ( n!=IOSUNIT || (p && p->headblock.vtype!=TYCHAR) ) ) p = fixtype(p); else if (p && p->tag == TPRIM && p->primblock.namep->vclass == CLUNKNOWN) { /* kludge made necessary by attempt to infer types * for untyped external parameters: given an error * in calling sequences, an integer argument might * tentatively be assumed TYCHAR; this would otherwise * be corrected too late in startrw after startrw * had decided this to be an internal file. */ vardcl(p->primblock.namep); p->primblock.vtype = p->primblock.namep->vtype; } iocp->iocval = p; } else errstr("iocontrol %s repeated", iocp->iocname); } /* io list item */ void #ifdef KR_headers doio(list) chainp list; #else doio(chainp list) #endif { if(ioformatted == NAMEDIRECTED) { if(list) err("no I/O list allowed in NAMELIST read/write"); } else { doiolist(list); ioroutine[0] = 'e'; if (skiplab) jumplab = 0; putiocall( call0(TYINT, ioroutine) ); } } LOCAL void #ifdef KR_headers doiolist(p0) chainp p0; #else doiolist(chainp p0) #endif { chainp p; register tagptr q; register expptr qe; register Namep qn; Addrp tp; int range; extern char *ohalign; for (p = p0 ; p ; p = p->nextp) { q = (tagptr)p->datap; if(q->tag == TIMPLDO) { exdo(range = (int)newlabel(), (Namep)0, q->impldoblock.impdospec); doiolist(q->impldoblock.datalist); enddo(range); free( (charptr) q); } else { if(q->tag==TPRIM && q->primblock.argsp==NULL && q->primblock.namep->vdim!=NULL) { vardcl(qn = q->primblock.namep); if(qn->vdim->nelt) { putio( fixtype(cpexpr(qn->vdim->nelt)), (expptr)mkscalar(qn) ); qn->vlastdim = 0; } else err("attempt to i/o array of unknown size"); } else if(q->tag==TPRIM && q->primblock.argsp==NULL && (qe = (expptr) memversion(q->primblock.namep)) ) putio(ICON(1),qe); else if (ISCONST(q) && q->constblock.vtype == TYCHAR) { halign = 0; putio(ICON(1), qe = fixtype(cpexpr(q))); halign = ohalign; } else if(((qe = fixtype(cpexpr(q)))->tag==TADDR && (qe->addrblock.uname_tag != UNAM_CONST || !ISCOMPLEX(qe -> addrblock.vtype))) || (qe -> tag == TCONST && !ISCOMPLEX(qe -> headblock.vtype))) { if (qe -> tag == TCONST) qe = (expptr) putconst((Constp)qe); putio(ICON(1), qe); } else if(qe->headblock.vtype != TYERROR) { if(iostmt == IOWRITE) { expptr qvl; qvl = NULL; if( ISCHAR(qe) ) { qvl = (expptr) cpexpr(qe->headblock.vleng); tp = mktmp(qe->headblock.vtype, ICON(lencat(qe))); } else tp = mktmp(qe->headblock.vtype, qe->headblock.vleng); puteq( cpexpr((expptr)tp), qe); if(qvl) /* put right length on block */ { frexpr(tp->vleng); tp->vleng = qvl; } putio(ICON(1), (expptr)tp); } else err("non-left side in READ list"); } frexpr(q); } } frchain( &p0 ); } int iocalladdr = TYADDR; /* for fixing TYADDR in saveargtypes */ int typeconv[TYERROR+1] = { #ifdef TYQUAD 0, 1, 11, 2, 3, 14, 4, 5, 6, 7, 12, 13, 8, 9, 10, 15 #else 0, 1, 11, 2, 3, 4, 5, 6, 7, 12, 13, 8, 9, 10, 14 #endif }; LOCAL void #ifdef KR_headers putio(nelt, addr) expptr nelt; register expptr addr; #else putio(expptr nelt, register expptr addr) #endif { int type; register expptr q; register Addrp c = 0; type = addr->headblock.vtype; if(ioformatted!=LISTDIRECTED && ISCOMPLEX(type) ) { nelt = mkexpr(OPSTAR, ICON(2), nelt); type -= (TYCOMPLEX-TYREAL); } /* pass a length with every item. for noncharacter data, fake one */ if(type != TYCHAR) { if( ISCONST(addr) ) addr = (expptr) putconst((Constp)addr); c = ALLOC(Addrblock); c->tag = TADDR; c->vtype = TYLENG; c->vstg = STGAUTO; c->ntempelt = 1; c->isarray = 1; c->memoffset = ICON(0); c->uname_tag = UNAM_IDENT; c->charleng = 1; sprintf(c->user.ident, "(ftnlen)sizeof(%s)", Typename[type]); addr = mkexpr(OPCHARCAST, addr, ENULL); } nelt = fixtype( mkconv(tyioint,nelt) ); if(ioformatted == LISTDIRECTED) { expptr mc = mkconv(tyioint, ICON(typeconv[type])); q = c ? call4(TYINT, "do_lio", mc, nelt, addr, (expptr)c) : call3(TYINT, "do_lio", mc, nelt, addr); } else { char *s = (char*)(ioformatted==FORMATTED ? "do_fio" : !byterev ? "do_uio" : ONEOF(type, M(TYCHAR)|M(TYINT1)|M(TYLOGICAL1)) ? "do_ucio" : "do_unio"); q = c ? call3(TYINT, s, nelt, addr, (expptr)c) : call2(TYINT, s, nelt, addr); } iocalladdr = TYCHAR; putiocall(q); iocalladdr = TYADDR; } void endio(Void) { if(skiplab) { if (ioformatted != NAMEDIRECTED) p1_label((long)(skiplabel - labeltab)); if(ioendlab) { exif( mkexpr(OPLT, cpexpr(IOSTP), ICON(0))); exgoto(execlab(ioendlab)); exendif(); } if(ioerrlab) { exif( mkexpr(iostmt==IOREAD||iostmt==IOWRITE ? OPGT : OPNE, cpexpr(IOSTP), ICON(0))); exgoto(execlab(ioerrlab)); exendif(); } } if(IOSTP) frexpr(IOSTP); } LOCAL void #ifdef KR_headers putiocall(q) register expptr q; #else putiocall(register expptr q) #endif { int tyintsave; tyintsave = tyint; tyint = tyioint; /* for -I2 and -i2 */ if(IOSTP) { q->headblock.vtype = TYINT; q = fixexpr((Exprp)mkexpr(OPASSIGN, cpexpr(IOSTP), q)); } putexpr(q); if(jumplab) { exif(mkexpr(OPNE, cpexpr(IOSTP), ICON(0))); exgoto(execlab(jumplab)); exendif(); } tyint = tyintsave; } void #ifdef KR_headers fmtname(np, q) Namep np; register Addrp q; #else fmtname(Namep np, register Addrp q) #endif { register int k; register char *s, *t; extern chainp assigned_fmts; if (!np->vfmt_asg) { np->vfmt_asg = 1; assigned_fmts = mkchain((char *)np, assigned_fmts); } k = strlen(s = np->fvarname); if (k < IDENT_LEN - 4) { q->uname_tag = UNAM_IDENT; t = q->user.ident; } else { q->uname_tag = UNAM_CHARP; q->user.Charp = t = mem(k + 5,0); } sprintf(t, "%s_fmt", s); } LOCAL Addrp #ifdef KR_headers asg_addr(p) union Expression *p; #else asg_addr(union Expression *p) #endif { register Addrp q; if (p->tag != TPRIM) badtag("asg_addr", p->tag); q = ALLOC(Addrblock); q->tag = TADDR; q->vtype = TYCHAR; q->vstg = STGAUTO; q->ntempelt = 1; q->isarray = 0; q->memoffset = ICON(0); fmtname(p->primblock.namep, q); return q; } void startrw(Void) { register expptr p; register Namep np; register Addrp unitp, fmtp, recp; register expptr nump; int iostmt1; flag intfile, sequential, ok, varfmt; struct io_setup *ios; /* First look at all the parameters and determine what is to be done */ ok = YES; statstruct = YES; intfile = NO; if(p = V(IOSUNIT)) { if( ISINT(p->headblock.vtype) ) { int_unit: unitp = (Addrp) cpexpr(p); } else if(p->headblock.vtype == TYCHAR) { if (nioctl == 1 && iostmt == IOREAD) { /* kludge to recognize READ(format expr) */ V(IOSFMT) = p; V(IOSUNIT) = p = (expptr) IOSTDIN; ioformatted = FORMATTED; goto int_unit; } intfile = YES; if(p->tag==TPRIM && p->primblock.argsp==NULL && (np = p->primblock.namep)->vdim!=NULL) { vardcl(np); if(nump = np->vdim->nelt) { nump = fixtype(cpexpr(nump)); if( ! ISCONST(nump) ) { statstruct = NO; np->vlastdim = 0; } } else { err("attempt to use internal unit array of unknown size"); ok = NO; nump = ICON(1); } unitp = mkscalar(np); } else { nump = ICON(1); unitp = (Addrp /*pjw */) fixtype(cpexpr(p)); } if(! isstatic((expptr)unitp) ) statstruct = NO; } else { err("unit specifier not of type integer or character"); ok = NO; } } else { err("bad unit specifier"); ok = NO; } sequential = YES; if(p = V(IOSREC)) if( ISINT(p->headblock.vtype) ) { recp = (Addrp) cpexpr(p); sequential = NO; } else { err("bad REC= clause"); ok = NO; } else recp = NULL; varfmt = YES; fmtp = NULL; if(p = V(IOSFMT)) { if(p->tag==TPRIM && p->primblock.argsp==NULL) { np = p->primblock.namep; if(np->vclass == CLNAMELIST) { ioformatted = NAMEDIRECTED; fmtp = (Addrp) fixtype(p); V(IOSFMT) = (expptr)fmtp; if (skiplab) jumplab = 0; goto endfmt; } vardcl(np); if(np->vdim) { if( ! ONEOF(np->vstg, MSKSTATIC) ) statstruct = NO; fmtp = mkscalar(np); goto endfmt; } if( ISINT(np->vtype) ) /* ASSIGNed label */ { statstruct = NO; varfmt = YES; fmtp = asg_addr(p); goto endfmt; } } p = V(IOSFMT) = fixtype(p); if(p->headblock.vtype == TYCHAR /* Since we allow write(6,n) */ /* we may as well allow write(6,n(2)) */ || p->tag == TADDR && ISINT(p->addrblock.vtype)) { if( ! isstatic(p) ) statstruct = NO; fmtp = (Addrp) cpexpr(p); } else if( ISICON(p) ) { struct Labelblock *lp; lp = mklabel(p->constblock.Const.ci); if (fmtstmt(lp) > 0) { fmtp = (Addrp)mkaddcon(lp->stateno); /* lp->stateno for names fmt_nnn */ lp->fmtlabused = 1; varfmt = NO; } else ioformatted = UNFORMATTED; } else { err("bad format descriptor"); ioformatted = UNFORMATTED; ok = NO; } } else fmtp = NULL; endfmt: if(intfile) { if (ioformatted==UNFORMATTED) { err("unformatted internal I/O not allowed"); ok = NO; } if (recp) { err("direct internal I/O not allowed"); ok = NO; } } if(!sequential && ioformatted==LISTDIRECTED) { err("direct list-directed I/O not allowed"); ok = NO; } if(!sequential && ioformatted==NAMEDIRECTED) { err("direct namelist I/O not allowed"); ok = NO; } if( ! ok ) { statstruct = NO; return; } /* Now put out the I/O structure, statically if all the clauses are constants, dynamically otherwise */ if (intfile) { ios = io_stuff + iostmt; iostmt1 = IOREAD; } else { ios = io_stuff; iostmt1 = 0; } io_fields = ios->fields; if(statstruct) { ioblkp = ALLOC(Addrblock); ioblkp->tag = TADDR; ioblkp->vtype = ios->type; ioblkp->vclass = CLVAR; ioblkp->vstg = STGINIT; ioblkp->memno = ++lastvarno; ioblkp->memoffset = ICON(0); ioblkp -> uname_tag = UNAM_IDENT; new_iob_data(ios, temp_name("io_", lastvarno, ioblkp->user.ident)); } else if(!(ioblkp = io_structs[iostmt1])) io_structs[iostmt1] = ioblkp = autovar(1, ios->type, ENULL, ""); ioset(TYIOINT, XERR, ICON(errbit)); if(iostmt == IOREAD) ioset(TYIOINT, (intfile ? XIEND : XEND), ICON(endbit) ); if(intfile) { ioset(TYIOINT, XIRNUM, nump); ioset(TYIOINT, XIRLEN, cpexpr(unitp->vleng) ); ioseta(XIUNIT, unitp); } else ioset(TYIOINT, XUNIT, (expptr) unitp); if(recp) ioset(TYIOINT, /* intfile ? XIREC : */ XREC, (expptr) recp); if(varfmt) ioseta( intfile ? XIFMT : XFMT , fmtp); else ioset(TYADDR, intfile ? XIFMT : XFMT, (expptr) fmtp); ioroutine[0] = 's'; ioroutine[1] = '_'; ioroutine[2] = iostmt==IOREAD ? 'r' : 'w'; ioroutine[3] = "ds"[sequential]; ioroutine[4] = "ufln"[ioformatted]; ioroutine[5] = "ei"[intfile]; ioroutine[6] = '\0'; putiocall( call1(TYINT, ioroutine, cpexpr((expptr)ioblkp) )); if(statstruct) { frexpr((expptr)ioblkp); statstruct = NO; ioblkp = 0; /* unnecessary */ } } LOCAL void dofopen(Void) { register expptr p; if( (p = V(IOSUNIT)) && ISINT(p->headblock.vtype) ) ioset(TYIOINT, XUNIT, cpexpr(p) ); else err("bad unit in open"); if( (p = V(IOSFILE)) ) if(p->headblock.vtype == TYCHAR) ioset(TYIOINT, XFNAMELEN, cpexpr(p->headblock.vleng) ); else err("bad file in open"); iosetc(XFNAME, p); if(p = V(IOSRECL)) if( ISINT(p->headblock.vtype) ) ioset(TYIOINT, XRECLEN, cpexpr(p) ); else err("bad recl"); else ioset(TYIOINT, XRECLEN, ICON(0) ); iosetc(XSTATUS, V(IOSSTATUS)); iosetc(XACCESS, V(IOSACCESS)); iosetc(XFORMATTED, V(IOSFORM)); iosetc(XBLANK, V(IOSBLANK)); putiocall( call1(TYINT, "f_open", cpexpr((expptr)ioblkp) )); } LOCAL void dofclose(Void) { register expptr p; if( (p = V(IOSUNIT)) && ISINT(p->headblock.vtype) ) { ioset(TYIOINT, XUNIT, cpexpr(p) ); iosetc(XCLSTATUS, V(IOSSTATUS)); putiocall( call1(TYINT, "f_clos", cpexpr((expptr)ioblkp)) ); } else err("bad unit in close statement"); } LOCAL void dofinquire(Void) { register expptr p; if(p = V(IOSUNIT)) { if( V(IOSFILE) ) err("inquire by unit or by file, not both"); ioset(TYIOINT, XUNIT, cpexpr(p) ); } else if( ! V(IOSFILE) ) err("must inquire by unit or by file"); iosetlc(IOSFILE, XFILE, XFILELEN); iosetip(IOSEXISTS, XEXISTS); iosetip(IOSOPENED, XOPEN); iosetip(IOSNUMBER, XNUMBER); iosetip(IOSNAMED, XNAMED); iosetlc(IOSNAME, XNAME, XNAMELEN); iosetlc(IOSACCESS, XQACCESS, XQACCLEN); iosetlc(IOSSEQUENTIAL, XSEQ, XSEQLEN); iosetlc(IOSDIRECT, XDIRECT, XDIRLEN); iosetlc(IOSFORM, XFORM, XFORMLEN); iosetlc(IOSFORMATTED, XFMTED, XFMTEDLEN); iosetlc(IOSUNFORMATTED, XUNFMT, XUNFMTLEN); iosetip(IOSRECL, XQRECL); iosetip(IOSNEXTREC, XNEXTREC); iosetlc(IOSBLANK, XQBLANK, XQBLANKLEN); putiocall( call1(TYINT, "f_inqu", cpexpr((expptr)ioblkp) )); } LOCAL void #ifdef KR_headers dofmove(subname) char *subname; #else dofmove(char *subname) #endif { register expptr p; if( (p = V(IOSUNIT)) && ISINT(p->headblock.vtype) ) { ioset(TYIOINT, XUNIT, cpexpr(p) ); putiocall( call1(TYINT, subname, cpexpr((expptr)ioblkp) )); } else err("bad unit in I/O motion statement"); } static int ioset_assign = OPASSIGN; LOCAL void #ifdef KR_headers ioset(type, offset, p) int type; int offset; register expptr p; #else ioset(int type, int offset, register expptr p) #endif { offset /= SZLONG; if(statstruct && ISCONST(p)) { register char *s; switch(type) { case TYADDR: /* stmt label */ s = "fmt_"; break; case TYIOINT: s = ""; break; default: badtype("ioset", type); } iob_list->fields[offset] = string_num(s, p->constblock.Const.ci); frexpr(p); } else { register Addrp q; q = ALLOC(Addrblock); q->tag = TADDR; q->vtype = type; q->vstg = STGAUTO; q->ntempelt = 1; q->isarray = 0; q->memoffset = ICON(0); q->uname_tag = UNAM_IDENT; sprintf(q->user.ident, "%s.%s", statstruct ? iob_list->name : ioblkp->user.ident, io_fields[offset + 1]); if (type == TYADDR && p->tag == TCONST && p->constblock.vtype == TYADDR) { /* kludge */ register Addrp p1; p1 = ALLOC(Addrblock); p1->tag = TADDR; p1->vtype = type; p1->vstg = STGAUTO; /* wrong, but who cares? */ p1->ntempelt = 1; p1->isarray = 0; p1->memoffset = ICON(0); p1->uname_tag = UNAM_IDENT; sprintf(p1->user.ident, "fmt_%ld", p->constblock.Const.ci); frexpr(p); p = (expptr)p1; } if (type == TYADDR && p->headblock.vtype == TYCHAR) q->vtype = TYCHAR; putexpr(mkexpr(ioset_assign, (expptr)q, p)); } } LOCAL void #ifdef KR_headers iosetc(offset, p) int offset; register expptr p; #else iosetc(int offset, register expptr p) #endif { if(p == NULL) ioset(TYADDR, offset, ICON(0) ); else if(p->headblock.vtype == TYCHAR) { p = putx(fixtype((expptr)putchop(cpexpr(p)))); ioset(TYADDR, offset, addrof(p)); } else err("non-character control clause"); } LOCAL void #ifdef KR_headers ioseta(offset, p) int offset; register Addrp p; #else ioseta(int offset, register Addrp p) #endif { char *s, *s1; static char who[] = "ioseta"; expptr e, mo; Namep np; ftnint ci; int k; char buf[24], buf1[24]; Extsym *comm; extern int usedefsforcommon; if(statstruct) { if (!p) return; if (p->tag != TADDR) badtag(who, p->tag); offset /= SZLONG; switch(p->uname_tag) { case UNAM_NAME: mo = p->memoffset; if (mo->tag != TCONST) badtag("ioseta/memoffset", mo->tag); np = p->user.name; np->visused = 1; ci = mo->constblock.Const.ci - np->voffset; if (np->vstg == STGCOMMON && !np->vcommequiv && !usedefsforcommon) { comm = &extsymtab[np->vardesc.varno]; sprintf(buf, "%d.", comm->curno); k = strlen(buf) + strlen(comm->cextname) + strlen(np->cvarname); if (ci) { sprintf(buf1, "+%ld", ci); k += strlen(buf1); } else buf1[0] = 0; s = mem(k + 1, 0); sprintf(s, "%s%s%s%s", comm->cextname, buf, np->cvarname, buf1); } else if (ci) { sprintf(buf,"%ld", ci); s1 = p->user.name->cvarname; k = strlen(buf) + strlen(s1); sprintf(s = mem(k+2,0), "%s+%s", s1, buf); } else s = cpstring(np->cvarname); break; case UNAM_CONST: s = tostring(p->user.Const.ccp1.ccp0, (int)p->vleng->constblock.Const.ci); break; default: badthing("uname_tag", who, p->uname_tag); } /* kludge for Hollerith */ if (p->vtype != TYCHAR) { s1 = mem(strlen(s)+10,0); sprintf(s1, "(char *)%s%s", p->isarray ? "" : "&", s); s = s1; } iob_list->fields[offset] = s; } else { if (!p) e = ICON(0); else if (p->vtype != TYCHAR) { NOEXT("non-character variable as format or internal unit"); e = mkexpr(OPCHARCAST, (expptr)p, ENULL); } else e = addrof((expptr)p); ioset(TYADDR, offset, e); } } LOCAL void #ifdef KR_headers iosetip(i, offset) int i; int offset; #else iosetip(int i, int offset) #endif { register expptr p; if(p = V(i)) if(p->tag==TADDR && ONEOF(p->addrblock.vtype, inqmask) ) { ioset_assign = OPASSIGNI; ioset(TYADDR, offset, addrof(cpexpr(p)) ); ioset_assign = OPASSIGN; } else errstr("impossible inquire parameter %s", ioc[i].iocname); else ioset(TYADDR, offset, ICON(0) ); } LOCAL void #ifdef KR_headers iosetlc(i, offp, offl) int i; int offp; int offl; #else iosetlc(int i, int offp, int offl) #endif { register expptr p; if( (p = V(i)) && p->headblock.vtype==TYCHAR) ioset(TYIOINT, offl, cpexpr(p->headblock.vleng) ); iosetc(offp, p); } f2c/src/iob.h000066400000000000000000000010441171647030000132370ustar00rootroot00000000000000struct iob_data { struct iob_data *next; char *type; char *name; char *fields[1]; }; struct io_setup { char **fields; int nelt, type; }; struct defines { struct defines *next; char defname[1]; }; typedef struct iob_data iob_data; typedef struct io_setup io_setup; typedef struct defines defines; extern iob_data *iob_list; extern struct Addrblock *io_structs[9]; void def_start Argdcl((FILEP, char*, char*, char*)); void new_iob_data Argdcl((io_setup*, char*)); void other_undefs Argdcl((FILEP)); char* tostring Argdcl((char*, int)); f2c/src/lex.c000066400000000000000000001036721171647030000132630ustar00rootroot00000000000000/**************************************************************** Copyright 1990, 1992 - 1997, 1999, 2000 by AT&T, Lucent Technologies and Bellcore. Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the above copyright notice appear in all copies and that both that the copyright notice and this permission notice and warranty disclaimer appear in supporting documentation, and that the names of AT&T, Bell Laboratories, Lucent or Bellcore or any of their entities not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. AT&T, Lucent and Bellcore disclaim all warranties with regard to this software, including all implied warranties of merchantability and fitness. In no event shall AT&T, Lucent or Bellcore be liable for any special, indirect or consequential damages or any damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortious action, arising out of or in connection with the use or performance of this software. ****************************************************************/ #include "defs.h" #include "tokdefs.h" #include "p1defs.h" #ifdef _WIN32 #undef MSDOS #define MSDOS #endif #ifdef NO_EOF_CHAR_CHECK #undef EOF_CHAR #else #ifndef EOF_CHAR #define EOF_CHAR 26 /* ASCII control-Z */ #endif #endif #define BLANK ' ' #define MYQUOTE (2) #define SEOF 0 /* card types */ #define STEOF 1 #define STINITIAL 2 #define STCONTINUE 3 /* lex states */ #define NEWSTMT 1 #define FIRSTTOKEN 2 #define OTHERTOKEN 3 #define RETEOS 4 LOCAL int stkey; /* Type of the current statement (DO, END, IF, etc) */ static int needwkey; ftnint yystno; flag intonly; extern int new_dcl; LOCAL long int stno; LOCAL long int nxtstno; /* Statement label */ LOCAL int parlev; /* Parentheses level */ LOCAL int parseen; LOCAL int expcom; LOCAL int expeql; LOCAL char *nextch; LOCAL char *lastch; LOCAL char *nextcd = NULL; LOCAL char *endcd; LOCAL long prevlin; LOCAL long thislin; LOCAL int code; /* Card type; INITIAL, CONTINUE or EOF */ LOCAL int lexstate = NEWSTMT; LOCAL char *sbuf; /* Main buffer for Fortran source input. */ LOCAL char *send; /* Was = sbuf+20*66 with sbuf[1390]. */ LOCAL char *shend; /* reflects elbow room for #line lines */ LOCAL int maxcont; LOCAL int nincl = 0; /* Current number of include files */ LOCAL long firstline; LOCAL char *infname1, *infname2, *laststb, *stb0; extern int addftnsrc; static char **linestart; LOCAL int ncont; LOCAL char comstart[Table_size]; #define USC (unsigned char *) static char anum_buf[Table_size]; #define isalnum_(x) anum_buf[x] #define isalpha_(x) (anum_buf[x] == 1) #define COMMENT_BUF_STORE 4088 typedef struct comment_buf { struct comment_buf *next; char *last; char buf[COMMENT_BUF_STORE]; } comment_buf; static comment_buf *cbfirst, *cbcur; static char *cbinit, *cbnext, *cblast; static void flush_comments Argdcl((void)); extern flag use_bs; static char *lastfile = "??", *lastfile0 = "?"; static char fbuf[P1_FILENAME_MAX]; static long lastline; static void putlineno(Void); /* Comment buffering data Comments are kept in a list until the statement before them has been parsed. This list is implemented with the above comment_buf structure and the pointers cbnext and cblast. The comments are stored with terminating NULL, and no other intervening space. The last few bytes of each block are likely to remain unused. */ /* struct Inclfile holds the state information for each include file */ struct Inclfile { struct Inclfile *inclnext; FILEP inclfp; char *inclname; int incllno; char *incllinp; int incllen; int inclcode; ftnint inclstno; }; LOCAL struct Inclfile *inclp = NULL; struct Keylist { char *keyname; int keyval; char notinf66; }; struct Punctlist { char punchar; int punval; }; struct Fmtlist { char fmtchar; int fmtval; }; struct Dotlist { char *dotname; int dotval; }; LOCAL struct Keylist *keystart[26], *keyend[26]; /* KEYWORD AND SPECIAL CHARACTER TABLES */ static struct Punctlist puncts[ ] = { '(', SLPAR, ')', SRPAR, '=', SEQUALS, ',', SCOMMA, '+', SPLUS, '-', SMINUS, '*', SSTAR, '/', SSLASH, '$', SCURRENCY, ':', SCOLON, '<', SLT, '>', SGT, 0, 0 }; LOCAL struct Dotlist dots[ ] = { "and.", SAND, "or.", SOR, "not.", SNOT, "true.", STRUE, "false.", SFALSE, "eq.", SEQ, "ne.", SNE, "lt.", SLT, "le.", SLE, "gt.", SGT, "ge.", SGE, "neqv.", SNEQV, "eqv.", SEQV, 0, 0 }; LOCAL struct Keylist keys[ ] = { { "assign", SASSIGN }, { "automatic", SAUTOMATIC, YES }, { "backspace", SBACKSPACE }, { "blockdata", SBLOCK }, { "byte", SBYTE }, { "call", SCALL }, { "character", SCHARACTER, YES }, { "close", SCLOSE, YES }, { "common", SCOMMON }, { "complex", SCOMPLEX }, { "continue", SCONTINUE }, { "data", SDATA }, { "dimension", SDIMENSION }, { "doubleprecision", SDOUBLE }, { "doublecomplex", SDCOMPLEX, YES }, { "elseif", SELSEIF, YES }, { "else", SELSE, YES }, { "endfile", SENDFILE }, { "endif", SENDIF, YES }, { "enddo", SENDDO, YES }, { "end", SEND }, { "entry", SENTRY, YES }, { "equivalence", SEQUIV }, { "external", SEXTERNAL }, { "format", SFORMAT }, { "function", SFUNCTION }, { "goto", SGOTO }, { "implicit", SIMPLICIT, YES }, { "include", SINCLUDE, YES }, { "inquire", SINQUIRE, YES }, { "intrinsic", SINTRINSIC, YES }, { "integer", SINTEGER }, { "logical", SLOGICAL }, { "namelist", SNAMELIST, YES }, { "none", SUNDEFINED, YES }, { "open", SOPEN, YES }, { "parameter", SPARAM, YES }, { "pause", SPAUSE }, { "print", SPRINT }, { "program", SPROGRAM, YES }, { "punch", SPUNCH, YES }, { "read", SREAD }, { "real", SREAL }, { "return", SRETURN }, { "rewind", SREWIND }, { "save", SSAVE, YES }, { "static", SSTATIC, YES }, { "stop", SSTOP }, { "subroutine", SSUBROUTINE }, { "then", STHEN, YES }, { "undefined", SUNDEFINED, YES }, { "while", SWHILE, YES }, { "write", SWRITE }, { 0, 0 } }; static void analyz Argdcl((void)); static void crunch Argdcl((void)); static int getcd Argdcl((char*, int)); static int getcds Argdcl((void)); static int getkwd Argdcl((void)); static int gettok Argdcl((void)); static void store_comment Argdcl((char*)); LOCAL char *stbuf[3]; int #ifdef KR_headers inilex(name) char *name; #else inilex(char *name) #endif { stbuf[0] = Alloc(3*P1_STMTBUFSIZE); stbuf[1] = stbuf[0] + P1_STMTBUFSIZE; stbuf[2] = stbuf[1] + P1_STMTBUFSIZE; nincl = 0; inclp = NULL; doinclude(name); lexstate = NEWSTMT; return(NO); } /* throw away the rest of the current line */ void flline(Void) { lexstate = RETEOS; } char * #ifdef KR_headers lexline(n) int *n; #else lexline(int *n) #endif { *n = (lastch - nextch) + 1; return(nextch); } void #ifdef KR_headers doinclude(name) char *name; #else doinclude(char *name) #endif { FILEP fp; struct Inclfile *t; char *name0, *lastslash, *s, *s0, *temp; int j, k; chainp I; extern chainp Iargs; err_lineno = -1; if(inclp) { inclp->incllno = thislin; inclp->inclcode = code; inclp->inclstno = nxtstno; if(nextcd && (j = endcd - nextcd) > 0) inclp->incllinp = copyn(inclp->incllen = j, nextcd); else inclp->incllinp = 0; } nextcd = NULL; if(++nincl >= MAXINCLUDES) Fatal("includes nested too deep"); if(name[0] == '\0') fp = stdin; else if(name[0] == '/' || inclp == NULL #ifdef MSDOS || name[0] == '\\' || name[1] == ':' #endif ) fp = fopen(name, textread); else { lastslash = NULL; s = s0 = inclp->inclname; #ifdef MSDOS if (s[1] == ':') lastslash = s + 1; #endif for(; *s ; ++s) if(*s == '/' #ifdef MSDOS || *s == '\\' #endif ) lastslash = s; name0 = name; if(lastslash) { k = lastslash - s0 + 1; temp = Alloc(k + strlen(name) + 1); strncpy(temp, s0, k); strcpy(temp+k, name); name = temp; } fp = fopen(name, textread); if (!fp && (I = Iargs)) { k = strlen(name0) + 2; for(; I; I = I->nextp) { j = strlen(s = I->datap); name = Alloc(j + k); strcpy(name, s); switch(s[j-1]) { case '/': #ifdef MSDOS case ':': case '\\': #endif break; default: name[j++] = '/'; } strcpy(name+j, name0); if (fp = fopen(name, textread)) { free(name0); goto havefp; } free(name); name = name0; } } } if (fp) { havefp: t = inclp; inclp = ALLOC(Inclfile); inclp->inclnext = t; prevlin = thislin = lineno = 0; infname = inclp->inclname = name; infile = inclp->inclfp = fp; lastline = 0; putlineno(); lastline = 0; } else { fprintf(diagfile, "Cannot open file %s\n", name); done(1); } } LOCAL int popinclude(Void) { struct Inclfile *t; register char *p; register int k; if(infile != stdin) clf(&infile, infname, 1); /* Close the input file */ free(infname); --nincl; err_lineno = -1; t = inclp->inclnext; free( (charptr) inclp); inclp = t; if(inclp == NULL) { infname = 0; return(NO); } infile = inclp->inclfp; infname = inclp->inclname; lineno = prevlin = thislin = inclp->incllno; code = inclp->inclcode; stno = nxtstno = inclp->inclstno; if(inclp->incllinp) { lastline = 0; putlineno(); lastline = lineno; endcd = nextcd = sbuf; k = inclp->incllen; p = inclp->incllinp; while(--k >= 0) *endcd++ = *p++; free( (charptr) (inclp->incllinp) ); } else nextcd = NULL; return(YES); } void #ifdef KR_headers p1_line_number(line_number) long line_number; #else p1_line_number(long line_number) #endif { if (lastfile != lastfile0) { p1puts(P1_FILENAME, fbuf); lastfile0 = lastfile; } fprintf(pass1_file, "%d: %ld\n", P1_SET_LINE, line_number); } static void putlineno(Void) { extern int gflag; register char *s0, *s1; if (gflag) { if (lastline) p1_line_number(lastline); lastline = firstline; if (lastfile != infname) if (lastfile = infname) { strncpy(fbuf, lastfile, sizeof(fbuf)); fbuf[sizeof(fbuf)-1] = 0; } else fbuf[0] = 0; } if (addftnsrc) { if (laststb && *laststb) { for(s1 = laststb; *s1; s1++) { for(s0 = s1; *s1 != '\n'; s1++) if (*s1 == '*' && s1[1] == '/') *s1 = '+'; *s1 = 0; p1puts(P1_FORTRAN, s0); } *laststb = 0; /* prevent trouble after EOF */ } laststb = stb0; } } int yylex(Void) { static int tokno; int retval; switch(lexstate) { case NEWSTMT : /* need a new statement */ retval = getcds(); putlineno(); if(retval == STEOF) { retval = SEOF; break; } /* if getcds() == STEOF */ crunch(); tokno = 0; lexstate = FIRSTTOKEN; yystno = stno; stno = nxtstno; toklen = 0; retval = SLABEL; break; first: case FIRSTTOKEN : /* first step on a statement */ analyz(); lexstate = OTHERTOKEN; tokno = 1; retval = stkey; break; case OTHERTOKEN : /* return next token */ if(nextch > lastch) goto reteos; ++tokno; if( (stkey==SLOGIF || stkey==SELSEIF) && parlev==0 && tokno>3) goto first; if(stkey==SASSIGN && tokno==3 && nextch sbuf) { q = nextcd; p = sbuf; while(q < endcd) *p++ = *q++; endcd = p; } /* Be aware that the input (i.e. the string at the address nextcd) is NOT NULL-terminated */ /* This loop merges all continuations into one long statement, AND puts the next card to be read at the end of the buffer (i.e. it stores the look-ahead card when there's room) */ ncont = 0; for(;;) { nextcd = endcd; if (ncont >= maxcont || nextcd+66 > send) contmax(); linestart[ncont++] = nextcd; if ((code = getcd(nextcd,0)) != STCONTINUE) break; if (ncont == 20 && noextflag) { lineno = thislin; errext("more than 19 continuation lines"); } } nextch = sbuf; lastch = nextcd - 1; lineno = prevlin; prevlin = thislin; if (infname2) { free(infname); infname = infname2; if (inclp) inclp->inclname = infname; } infname2 = infname1; infname1 = 0; return(STINITIAL); } static void #ifdef KR_headers bang(a, b, c, d, e) char *a; char *b; char *c; register char *d; register char *e; #else bang(char *a, char *b, char *c, register char *d, register char *e) #endif /* save ! comments */ { char buf[COMMENT_BUFFER_SIZE + 1]; register char *p, *pe; p = buf; pe = buf + COMMENT_BUFFER_SIZE; *pe = 0; while(a < b) if (!(*p++ = *a++)) p[-1] = 0; if (b < c) *p++ = '\t'; while(d < e) { if (!(*p++ = *d++)) p[-1] = ' '; if (p == pe) { store_comment(buf); p = buf; } } if (p > buf) { while(--p >= buf && *p == ' '); p[1] = 0; store_comment(buf); } } /* getcd - Get next input card This function reads the next input card from global file pointer infile. It assumes that b points to currently empty storage somewhere in sbuf */ LOCAL int #ifdef KR_headers getcd(b, nocont) register char *b; int nocont; #else getcd(register char *b, int nocont) #endif { register int c; register char *p, *bend; int speclin; /* Special line - true when the line is allowed to have more than 66 characters (e.g. the "&" shorthand for continuation, use of a "\t" to skip part of the label columns) */ static char a[6]; /* Statement label buffer */ static char *aend = a+6; static char *stb, *stbend; static int nst; char *atend, *endcd0; extern int warn72; char buf72[24]; int amp, i; char storage[COMMENT_BUFFER_SIZE + 1]; char *pointer; long L; top: endcd = b; bend = b+66; amp = speclin = NO; atend = aend; /* Handle the continuation shorthand of "&" in the first column, which stands for " x" */ if( (c = getc(infile)) == '&') { a[0] = c; a[1] = 0; a[5] = 'x'; amp = speclin = YES; bend = send; p = aend; } /* Handle the Comment cards (a 'C', 'c', '*', or '!' in the first column). */ else if(comstart[c & (Table_size-1)]) { if (feof (infile) #ifdef EOF_CHAR || c == EOF_CHAR #endif ) return STEOF; if (c == '#') { *endcd++ = c; while((c = getc(infile)) != '\n') if (c == EOF) return STEOF; else if (endcd < shend) *endcd++ = c; ++thislin; *endcd = 0; if (b[1] == ' ') p = b + 2; else if (!strncmp(b,"#line ",6)) p = b + 6; else { bad_cpp: lineno = thislin; errstr("Bad # line: \"%s\"", b); goto top; } if (*p < '1' || *p > '9') goto bad_cpp; L = *p - '0'; while((c = *++p) >= '0' && c <= '9') L = 10*L + c - '0'; while(c == ' ') c = *++p; if (!c) { /* accept "# 1234" */ thislin = L - 1; goto top; } if (c != '"') goto bad_cpp; bend = p; while(*++p != '"') if (!*p) goto bad_cpp; *p = 0; i = p - bend++; thislin = L - 1; if (!infname1 || strcmp(infname1, bend)) { if (infname1) free(infname1); if (infname && !strcmp(infname, bend)) { infname1 = 0; goto top; } lastfile = 0; infname1 = Alloc(i); strcpy(infname1, bend); if (!infname) { infname = infname1; infname1 = 0; } } goto top; } storage[COMMENT_BUFFER_SIZE] = c = '\0'; pointer = storage; while( !feof (infile) && (*pointer++ = c = getc(infile)) != '\n') { /* Handle obscure end of file conditions on many machines */ if (feof (infile) && (c == '\377' || c == EOF)) { pointer--; break; } /* if (feof (infile)) */ if (c == '\0') *(pointer - 1) = ' '; if (pointer == &storage[COMMENT_BUFFER_SIZE]) { store_comment (storage); pointer = storage; } /* if (pointer == BUFFER_SIZE) */ } /* while */ if (pointer > storage) { if (c == '\n') /* Get rid of the newline */ pointer[-1] = 0; else *pointer = 0; store_comment (storage); } /* if */ if (feof (infile)) if (c != '\n') /* To allow the line index to increment correctly */ return STEOF; ++thislin; goto top; } else if(c != EOF) { /* Load buffer a with the statement label */ /* a tab in columns 1-6 skips to column 7 */ ungetc(c, infile); for(p=a; p= 23) strcpy(buf72+20, "..."); lineno = thislin + 1; errstr("text after column 72: %s", buf72); } if(c == EOF) return(STEOF); } endcd0 = endcd; if( ! speclin ) while(endcd < bend) *endcd++ = BLANK; } /* The flow of control usually gets to this line (unless an earlier RETURN has been taken) */ ++thislin; /* Fortran 77 specifies that a 0 in column 6 */ /* does not signify continuation */ if( !isspace(a[5]) && a[5]!='0') { if (!amp) for(p = a; p < aend;) if (*p++ == '!' && p != aend) goto initcheck; if (addftnsrc && stb) { if (stbend > stb + 7) { /* otherwise forget col 1-6 */ /* kludge around funny p1gets behavior */ *stb++ = '$'; if (amp) *stb++ = '&'; else for(p = a; p < atend;) *stb++ = *p++; } if (endcd0 - b > stbend - stb) { if (stb > stbend) stb = stbend; endcd0 = b + (stbend - stb); } for(p = b; p < endcd0;) *stb++ = *p++; *stb++ = '\n'; *stb = 0; } if (nocont) { lineno = thislin; errstr("illegal continuation card (starts \"%.6s\")",a); } else if (!amp && strncmp(a," ",5)) { lineno = thislin; errstr("labeled continuation line (starts \"%.6s\")",a); } return(STCONTINUE); } initcheck: for(p=a; p= linestart[k]) if (++k >= maxcont) contmax(); j0 = linestart[k]; if (!addftnsrc) bang(sbuf,sbuf,sbuf,i+1,j0); i = j0-1; continue; } /* Keep everything in a quoted string */ if(*i=='\'' || *i=='"') { int len = 0; quote = *i; *j = MYQUOTE; /* special marker */ for(;;) { if(++i > lastch) { err("unbalanced quotes; closing quote supplied"); if (j >= lastch) j = lastch - 1; break; } if(*i == quote) if(i maxtoklen) adjtoklen(len); j[1] = MYQUOTE; j += 2; prvstr = j; } else if( (*i=='h' || *i=='H') && j>prvstr) /* test for Hollerith strings */ { j0 = j - 1; if( ! isdigit(*j0)) goto copychar; nh = *j0 - '0'; ten = 10; j1 = prvstr; if (j1 > sbuf && j1[-1] == MYQUOTE) --j1; if (j1+4 < j) j1 = j-4; for(;;) { if (j0-- <= j1) goto copychar; if( ! isdigit(*j0 ) ) break; nh += ten * (*j0-'0'); ten*=10; } /* A Hollerith string must be preceded by a punctuation mark. '*' is possible only as repetition factor in a data statement not, in particular, in character*2h . To avoid some confusion with missing commas in FORMAT statements, treat a preceding string as a punctuation mark. */ if( !(*j0=='*'&&sbuf[0]=='d') && *j0!='/' && *j0!='(' && *j0!=',' && *j0!='=' && *j0!='.' && *j0 != MYQUOTE) goto copychar; nh0 = nh; if(i+nh > lastch) { erri("%dH too big", nh); nh = lastch - i; nh0 = -1; } if (nh > maxtoklen) adjtoklen(nh); j0[1] = MYQUOTE; /* special marker */ j = j0 + 1; while(nh-- > 0) { if (++i > lastch) { hol_overflow: if (nh0 >= 0) erri("escapes make %dH too big", nh0); break; } if(*i == '\\' && use_bs) { if (++i > lastch) goto hol_overflow; *i = escapes[*(unsigned char *)i]; } *++j = *i; } j[1] = MYQUOTE; j+=2; prvstr = j; } else { if(*i == '(') parseen = ++parlev; else if(*i == ')') --parlev; else if(parlev == 0) if(*i == '=') expeql = 1; else if(*i == ',') expcom = 1; copychar: /*not a string or space -- copy, shifting case if necessary */ if(shiftcase && isupper(*i)) *j++ = tolower(*i); else *j++ = *i; } } lastch = j - 1; nextch = sbuf; } LOCAL void analyz(Void) { register char *i; if(parlev != 0) { err("unbalanced parentheses, statement skipped"); stkey = SUNKNOWN; lastch = sbuf - 1; /* prevent double error msg */ return; } if(nextch+2<=lastch && nextch[0]=='i' && nextch[1]=='f' && nextch[2]=='(') { /* assignment or if statement -- look at character after balancing paren */ parlev = 1; for(i=nextch+3 ; i<=lastch; ++i) if(*i == (MYQUOTE)) { while(*++i != MYQUOTE) ; } else if(*i == '(') ++parlev; else if(*i == ')') { if(--parlev == 0) break; } if(i >= lastch) stkey = SLOGIF; else if(i[1] == '=') stkey = SLET; else if( isdigit(i[1]) ) stkey = SARITHIF; else stkey = SLOGIF; if(stkey != SLET) nextch += 2; } else if(expeql) /* may be an assignment */ { if(expcom && nextch= '0' && nextch[2] <= '9') || nextch[2] == ',' || nextch[2] == 'w')) { stkey = SDO; nextch += 2; needwkey = 1; } /* otherwise search for keyword */ else { stkey = getkwd(); if(stkey==SGOTO && lastch>=nextch) if(nextch[0]=='(') stkey = SCOMPGOTO; else if(isalpha_(* USC nextch)) stkey = SASGOTO; } parlev = 0; } LOCAL int getkwd(Void) { register char *i, *j; register struct Keylist *pk, *pend; int k; if(! isalpha_(* USC nextch) ) return(SUNKNOWN); k = letter(nextch[0]); if(pk = keystart[k]) for(pend = keyend[k] ; pk<=pend ; ++pk ) { i = pk->keyname; j = nextch; while(*++i==*++j && *i!='\0') ; if(*i=='\0' && j<=lastch+1) { nextch = j; if(no66flag && pk->notinf66) errstr("Not a Fortran 66 keyword: %s", pk->keyname); return(pk->keyval); } } return(SUNKNOWN); } void initkey(Void) { register struct Keylist *p; register int i,j; register char *s; for(i = 0 ; i<26 ; ++i) keystart[i] = NULL; for(p = keys ; p->keyname ; ++p) { j = letter(p->keyname[0]); if(keystart[j] == NULL) keystart[j] = p; keyend[j] = p; } i = (maxcontin + 2) * 66; sbuf = (char *)ckalloc(i + 70 + MAX_SHARPLINE_LEN); send = sbuf + i; shend = send + MAX_SHARPLINE_LEN; maxcont = maxcontin + 1; linestart = (char **)ckalloc(maxcont*sizeof(char*)); comstart['c'] = comstart['C'] = comstart['*'] = comstart['!'] = comstart['#'] = 1; #ifdef EOF_CHAR comstart[EOF_CHAR] = 1; #endif s = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_"; while(i = *s++) anum_buf[i] = 1; s = "0123456789"; while(i = *s++) anum_buf[i] = 2; } LOCAL int #ifdef KR_headers hexcheck(key) int key; #else hexcheck(int key) #endif { register int radix; register char *p; char *kind; switch(key) { case 'z': case 'Z': case 'x': case 'X': radix = 16; key = SHEXCON; kind = "hexadecimal"; break; case 'o': case 'O': radix = 8; key = SOCTCON; kind = "octal"; break; case 'b': case 'B': radix = 2; key = SBITCON; kind = "binary"; break; default: err("bad bit identifier"); return(SNAME); } for(p = token; *p; p++) if (hextoi(*p) >= radix) { errstr("invalid %s character", kind); break; } return key; } /* gettok -- moves the right amount of text from nextch into the token buffer. token initially contains garbage (leftovers from the prev token) */ LOCAL int gettok(Void) { int havdot, havexp, havdbl; int radix, val; struct Punctlist *pp; struct Dotlist *pd; register int ch; static char Exp_mi[] = "X**-Y treated as X**(-Y)", Exp_pl[] = "X**+Y treated as X**(+Y)"; char *i, *j, *n1, *p; ch = * USC nextch; if(ch == (MYQUOTE)) { ++nextch; p = token; while(*nextch != MYQUOTE) *p++ = *nextch++; toklen = p - token; *p = 0; /* allow octal, binary, hex constants of the form 'abc'x (etc.) */ if (++nextch <= lastch && isalpha_(val = * USC nextch)) { ++nextch; return hexcheck(val); } return (SHOLLERITH); } if(needkwd) { needkwd = 0; return( getkwd() ); } for(pp=puncts; pp->punchar; ++pp) if(ch == pp->punchar) { val = pp->punval; if (++nextch <= lastch) switch(ch) { case '/': switch(*nextch) { case '/': nextch++; val = SCONCAT; break; case '=': goto sne; default: if (new_dcl && parlev == 0) val = SSLASHD; } return val; case '*': if (*nextch == '*') { nextch++; if (noextflag && nextch <= lastch) switch(*nextch) { case '-': errext(Exp_mi); break; case '+': errext(Exp_pl); } return SPOWER; } break; case '<': switch(*nextch) { case '=': nextch++; val = SLE; break; case '>': sne: nextch++; val = SNE; } goto extchk; case '=': if (*nextch == '=') { nextch++; val = SEQ; goto extchk; } break; case '>': if (*nextch == '=') { nextch++; val = SGE; } extchk: NOEXT("Fortran 8x comparison operator"); return val; } else if (ch == '/' && new_dcl && parlev == 0) return SSLASHD; switch(val) { case SLPAR: ++parlev; break; case SRPAR: --parlev; } return(val); } if(ch == '.') if(nextch >= lastch) goto badchar; else if(isdigit(nextch[1])) goto numconst; else { for(pd=dots ; (j=pd->dotname) ; ++pd) { for(i=nextch+1 ; i<=lastch ; ++i) if(*i != *j) break; else if(*i != '.') ++j; else { nextch = i+1; return(pd->dotval); } } goto badchar; } if( isalpha_(ch) ) { p = token; *p++ = *nextch++; while(nextch<=lastch) if( isalnum_(* USC nextch) ) *p++ = *nextch++; else break; toklen = p - token; *p = 0; if (needwkey) { needwkey = 0; if (toklen == 5 && nextch <= lastch && *nextch == '(' /*)*/ && !strcmp(token,"while")) return(SWHILE); } if(inioctl && nextch<=lastch && *nextch=='=') { ++nextch; return(SNAMEEQ); } if(toklen>8 && eqn(8,token,"function") && isalpha_(* USC (token+8)) && nextch MAXNAMELEN) { char buff[2*MAXNAMELEN+50]; if (toklen >= MAXNAMELEN+10) sprintf(buff, "name %.*s... too long, truncated to %.*s", MAXNAMELEN+6, token, MAXNAMELEN, token); else sprintf(buff, "name %s too long, truncated to %.*s", token, MAXNAMELEN, token); err(buff); toklen = MAXNAMELEN; token[MAXNAMELEN] = '\0'; } if(toklen==1 && *nextch==MYQUOTE) { val = token[0]; ++nextch; for(p = token ; *nextch!=MYQUOTE ; ) *p++ = *nextch++; ++nextch; toklen = p - token; *p = 0; return hexcheck(val); } return(SNAME); } if (isdigit(ch)) { /* Check for NAG's special hex constant */ if (nextch[1] == '#' && nextch < lastch || nextch[2] == '#' && isdigit(nextch[1]) && lastch - nextch >= 2) { radix = atoi (nextch); if (*++nextch != '#') nextch++; if (radix != 2 && radix != 8 && radix != 16) { erri("invalid base %d for constant, defaulting to hex", radix); radix = 16; } /* if */ if (++nextch > lastch) goto badchar; for (p = token; hextoi(*nextch) < radix;) { *p++ = *nextch++; if (nextch > lastch) break; } toklen = p - token; *p = 0; return (radix == 16) ? SHEXCON : ((radix == 8) ? SOCTCON : SBITCON); } } else goto badchar; numconst: havdot = NO; havexp = NO; havdbl = NO; for(n1 = nextch ; nextch<=lastch ; ++nextch) { if(*nextch == '.') if(havdot) break; else if(nextch+2<=lastch && isalpha_(* USC (nextch+1)) && isalpha_(* USC (nextch+2))) break; else havdot = YES; else if( ! isdigit(* USC nextch) ) { if( !intonly && (*nextch=='d' || *nextch=='e') ) { p = nextch; havexp = YES; if(*nextch == 'd') havdbl = YES; if(nextch cblast) { ncb = 0; if (cbcur) { cbcur->last = cbnext; ncb = cbcur->next; } if (!ncb) { ncb = (comment_buf *) Alloc(sizeof(comment_buf)); if (cbcur) cbcur->next = ncb; else { cbfirst = ncb; cbinit = ncb->buf; } ncb->next = 0; } cbcur = ncb; cbnext = ncb->buf; cblast = cbnext + COMMENT_BUF_STORE; } strcpy(cbnext, str); cbnext += len; } static void flush_comments(Void) { register char *s, *s1; register comment_buf *cb; if (cbnext == cbinit) return; cbcur->last = cbnext; for(cb = cbfirst;; cb = cb->next) { for(s = cb->buf; s < cb->last; s = s1) { /* compute s1 = new s value first, since */ /* p1_comment may insert nulls into s */ s1 = s + strlen(s) + 1; p1_comment(s); } if (cb == cbcur) break; } cbcur = cbfirst; cbnext = cbinit; cblast = cbnext + COMMENT_BUF_STORE; } void unclassifiable(Void) { register char *s, *se; s = sbuf; se = lastch; if (se < sbuf) return; lastch = s - 1; if (++se - s > 10) se = s + 10; for(; s < se; s++) if (*s == MYQUOTE) { se = s; break; } *se = 0; errstr("unclassifiable statement (starts \"%s\")", sbuf); } void endcheck(Void) { if (nextch <= lastch) warn("ignoring text after \"end\"."); lexstate = RETEOS; } f2c/src/machdefs.h000066400000000000000000000012231171647030000142370ustar00rootroot00000000000000#define TYLENG TYLONG /* char string length field */ #define TYINT TYLONG #define SZADDR 4 #define SZSHORT 2 #define SZINT 4 #define SZLONG 4 #define SZLENG SZLONG #define SZDREAL 8 /* Alignment restrictions */ #define ALIADDR SZADDR #define ALISHORT SZSHORT #define ALILONG 4 #define ALIDOUBLE 8 #define ALIINT ALILONG #define ALILENG ALILONG #define BLANKCOMMON "_BLNK__" /* Name for the unnamed common block; this is unique because of underscores */ #define LABELFMT "%s:\n" #define MAXREGVAR 4 #define TYIREG TYLONG #define MSKIREG (M(TYSHORT)|M(TYLONG)) /* allowed types of DO indicies which can be put in registers */ f2c/src/main.c000066400000000000000000000506711171647030000134170ustar00rootroot00000000000000/**************************************************************** Copyright 1990-1996, 2000-2001 by AT&T, Lucent Technologies and Bellcore. Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the above copyright notice appear in all copies and that both that the copyright notice and this permission notice and warranty disclaimer appear in supporting documentation, and that the names of AT&T, Bell Laboratories, Lucent or Bellcore or any of their entities not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. AT&T, Lucent and Bellcore disclaim all warranties with regard to this software, including all implied warranties of merchantability and fitness. In no event shall AT&T, Lucent or Bellcore be liable for any special, indirect or consequential damages or any damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortious action, arising out of or in connection with the use or performance of this software. ****************************************************************/ extern char F2C_version[]; #include "defs.h" #include "parse.h" int complex_seen, dcomplex_seen; LOCAL int Max_ftn_files; int badargs; char **ftn_files; int current_ftn_file = 0; flag ftn66flag = NO; flag nowarnflag = NO; flag noextflag = NO; flag no66flag = NO; /* Must also set noextflag to this same value */ flag zflag = YES; /* recognize double complex intrinsics */ flag debugflag = NO; flag onetripflag = NO; flag shiftcase = YES; flag undeftype = NO; flag checksubs = NO; flag r8flag = NO; flag use_bs = YES; flag keepsubs = NO; flag byterev = NO; int intr_omit; static int no_cd, no_i90; #ifdef TYQUAD flag use_tyquad = YES; #ifndef NO_LONG_LONG flag allow_i8c = YES; #endif #endif int tyreal = TYREAL; int tycomplex = TYCOMPLEX; int maxregvar = MAXREGVAR; /* if maxregvar > MAXREGVAR, error */ int maxequiv = MAXEQUIV; int maxext = MAXEXT; int maxstno = MAXSTNO; int maxctl = MAXCTL; int maxhash = MAXHASH; int maxliterals = MAXLITERALS; int maxcontin = MAXCONTIN; int maxlablist = MAXLABLIST; int extcomm, ext1comm, useauto; int can_include = YES; /* so we can disable includes for netlib */ static char *def_i2 = ""; static int useshortints = NO; /* YES => tyint = TYSHORT */ static int uselongints = NO; /* YES => tyint = TYLONG */ int addftnsrc = NO; /* Include ftn source in output */ int usedefsforcommon = NO; /* Use #defines for common reference */ int forcedouble = YES; /* force real functions to double */ int dneg = NO; /* f77 treatment of unary minus */ int Ansi = YES; int def_equivs = YES; int tyioint = TYLONG; int szleng = SZLENG; int inqmask = M(TYLONG)|M(TYLOGICAL); int wordalign = NO; int forcereal = NO; int warn72 = NO; static int help, showver, skipC, skipversion; char *file_name, *filename0, *parens; int Castargs = 1; static int Castargs1; static int typedefs = 0; int chars_per_wd, gflag, protostatus; int infertypes = 1; char used_rets[TYSUBR+1]; extern char *tmpdir; static int h0align = 0; char *halign, *ohalign; int krparens = NO; int hsize; /* for padding under -h */ int htype; /* for wr_equiv_init under -h */ int trapuv; chainp Iargs; #define f2c_entry(swit,count,type,store,size) \ p_entry ("-", swit, 0, count, type, store, size) static arg_info table[] = { f2c_entry ("w66", P_NO_ARGS, P_INT, &ftn66flag, YES), f2c_entry ("w", P_NO_ARGS, P_INT, &nowarnflag, YES), f2c_entry ("66", P_NO_ARGS, P_INT, &no66flag, YES), f2c_entry ("1", P_NO_ARGS, P_INT, &onetripflag, YES), f2c_entry ("onetrip", P_NO_ARGS, P_INT, &onetripflag, YES), f2c_entry ("I2", P_NO_ARGS, P_INT, &useshortints, YES), f2c_entry ("I4", P_NO_ARGS, P_INT, &uselongints, YES), f2c_entry ("U", P_NO_ARGS, P_INT, &shiftcase, NO), f2c_entry ("u", P_NO_ARGS, P_INT, &undeftype, YES), f2c_entry ("O", P_ONE_ARG, P_INT, &maxregvar, 0), f2c_entry ("C", P_NO_ARGS, P_INT, &checksubs, YES), f2c_entry ("Nq", P_ONE_ARG, P_INT, &maxequiv, 0), f2c_entry ("Nx", P_ONE_ARG, P_INT, &maxext, 0), f2c_entry ("Ns", P_ONE_ARG, P_INT, &maxstno, 0), f2c_entry ("Nc", P_ONE_ARG, P_INT, &maxctl, 0), f2c_entry ("Nn", P_ONE_ARG, P_INT, &maxhash, 0), f2c_entry ("NL", P_ONE_ARG, P_INT, &maxliterals, 0), f2c_entry ("NC", P_ONE_ARG, P_INT, &maxcontin, 0), f2c_entry ("Nl", P_ONE_ARG, P_INT, &maxlablist, 0), f2c_entry ("c", P_NO_ARGS, P_INT, &addftnsrc, YES), f2c_entry ("p", P_NO_ARGS, P_INT, &usedefsforcommon, YES), f2c_entry ("R", P_NO_ARGS, P_INT, &forcedouble, NO), f2c_entry ("!R", P_NO_ARGS, P_INT, &forcedouble, YES), f2c_entry ("A", P_NO_ARGS, P_INT, &Ansi, YES), f2c_entry ("K", P_NO_ARGS, P_INT, &Ansi, NO), f2c_entry ("ext", P_NO_ARGS, P_INT, &noextflag, YES), f2c_entry ("z", P_NO_ARGS, P_INT, &zflag, NO), f2c_entry ("a", P_NO_ARGS, P_INT, &useauto, YES), f2c_entry ("r8", P_NO_ARGS, P_INT, &r8flag, YES), f2c_entry ("i2", P_NO_ARGS, P_INT, &tyioint, NO), f2c_entry ("w8", P_NO_ARGS, P_INT, &wordalign, YES), f2c_entry ("!I", P_NO_ARGS, P_INT, &can_include, NO), f2c_entry ("W", P_ONE_ARG, P_INT, &chars_per_wd, 0), f2c_entry ("g", P_NO_ARGS, P_INT, &gflag, YES), f2c_entry ("T", P_ONE_ARG, P_STRING, &tmpdir, 0), f2c_entry ("E", P_NO_ARGS, P_INT, &extcomm, 1), f2c_entry ("e1c", P_NO_ARGS, P_INT, &ext1comm, 1), f2c_entry ("ec", P_NO_ARGS, P_INT, &ext1comm, 2), f2c_entry ("C++", P_NO_ARGS, P_INT, &Ansi, 2), f2c_entry ("P", P_NO_ARGS, P_INT, &Castargs, 3), f2c_entry ("Ps", P_NO_ARGS, P_INT, &protostatus, 1), f2c_entry ("!P", P_NO_ARGS, P_INT, &Castargs, 0), f2c_entry ("!c", P_NO_ARGS, P_INT, &skipC, 1), f2c_entry ("!it", P_NO_ARGS, P_INT, &infertypes, 0), f2c_entry ("h", P_NO_ARGS, P_INT, &h0align, 1), f2c_entry ("hd", P_NO_ARGS, P_INT, &h0align, 2), f2c_entry ("kr", P_NO_ARGS, P_INT, &krparens, 1), f2c_entry ("krd", P_NO_ARGS, P_INT, &krparens, 2), f2c_entry ("!bs", P_NO_ARGS, P_INT, &use_bs, NO), f2c_entry ("r", P_NO_ARGS, P_INT, &forcereal, YES), f2c_entry ("72", P_NO_ARGS, P_INT, &warn72, 1), f2c_entry ("f", P_NO_ARGS, P_INT, &warn72, 2), f2c_entry ("s", P_NO_ARGS, P_INT, &keepsubs, 1), f2c_entry ("d", P_ONE_ARG, P_STRING, &outbuf, 0), f2c_entry ("cd", P_NO_ARGS, P_INT, &no_cd, 1), f2c_entry ("i90", P_NO_ARGS, P_INT, &no_i90, 2), f2c_entry ("trapuv", P_NO_ARGS, P_INT, &trapuv, 1), #ifdef TYQUAD #ifndef NO_LONG_LONG f2c_entry ("!i8const", P_NO_ARGS, P_INT, &allow_i8c, NO), #endif f2c_entry ("!i8", P_NO_ARGS, P_INT, &use_tyquad, NO), #endif /* options omitted from man pages */ /* -b ==> for unformatted I/O, call do_unio (for noncharacter */ /* data of length > 1 byte) and do_ucio (for the rest) rather */ /* than do_uio. This permits modifying libI77 to byte-reverse */ /* numeric data. */ f2c_entry ("b", P_NO_ARGS, P_INT, &byterev, YES), /* -ev ==> implement equivalence with initialized pointers */ f2c_entry ("ev", P_NO_ARGS, P_INT, &def_equivs, NO), /* -!it used to be the default when -it was more agressive */ f2c_entry ("it", P_NO_ARGS, P_INT, &infertypes, 1), /* -Pd is similar to -P, but omits :ref: lines */ f2c_entry ("Pd", P_NO_ARGS, P_INT, &Castargs, 2), /* -t ==> emit typedefs (under -A or -C++) for procedure argument types used. This is meant for netlib's f2c service, so -A and -C++ will work with older versions of f2c.h */ f2c_entry ("t", P_NO_ARGS, P_INT, &typedefs, 1), /* -!V ==> omit version msg (to facilitate using diff in regression testing) */ f2c_entry ("!V", P_NO_ARGS, P_INT, &skipversion, 1), /* -Dnnn = debug level nnn */ f2c_entry ("D", P_ONE_ARG, P_INT, &debugflag, YES), /* -dneg ==> under (default) -!R, imitate f77's bizarre */ /* treatment of unary minus of REAL expressions by */ /* promoting them to DOUBLE PRECISION . */ f2c_entry ("dneg", P_NO_ARGS, P_INT, &dneg, YES), /* -?, --help, -v, --version */ f2c_entry ("?", P_NO_ARGS, P_INT, &help, YES), f2c_entry ("-help", P_NO_ARGS, P_INT, &help, YES), f2c_entry ("v", P_NO_ARGS, P_INT, &showver, YES), f2c_entry ("-version", P_NO_ARGS, P_INT, &showver, YES) }; /* table */ extern char *c_functions; /* "c_functions" */ extern char *coutput; /* "c_output" */ extern char *initfname; /* "raw_data" */ extern char *blkdfname; /* "block_data" */ extern char *p1_file; /* "p1_file" */ extern char *p1_bakfile; /* "p1_file.BAK" */ extern char *sortfname; /* "init_file" */ extern char *proto_fname; /* "proto_file" */ FILE *protofile; void set_externs(Void) { static char *hset[3] = { 0, "integer", "doublereal" }; /* Adjust the global flags according to the command line parameters */ if (chars_per_wd > 0) { typesize[TYADDR] = typesize[TYLONG] = typesize[TYREAL] = typesize[TYLOGICAL] = chars_per_wd; typesize[TYINT1] = typesize[TYLOGICAL1] = 1; typesize[TYDREAL] = typesize[TYCOMPLEX] = chars_per_wd << 1; typesize[TYDCOMPLEX] = chars_per_wd << 2; typesize[TYSHORT] = typesize[TYLOGICAL2] = chars_per_wd >> 1; typesize[TYCILIST] = 5*chars_per_wd; typesize[TYICILIST] = 6*chars_per_wd; typesize[TYOLIST] = 9*chars_per_wd; typesize[TYCLLIST] = 3*chars_per_wd; typesize[TYALIST] = 2*chars_per_wd; typesize[TYINLIST] = 26*chars_per_wd; } if (wordalign) typealign[TYDREAL] = typealign[TYDCOMPLEX] = typealign[TYREAL]; if (!tyioint) { tyioint = TYSHORT; szleng = typesize[TYSHORT]; def_i2 = "#define f2c_i2 1\n"; inqmask = M(TYSHORT)|M(TYLOGICAL2); goto checklong; } else szleng = typesize[TYLONG]; if (useshortints) { /* inqmask = M(TYLONG); */ /* used to disallow LOGICAL in INQUIRE under -I2 */ checklong: protorettypes[TYLOGICAL] = "shortlogical"; casttypes[TYLOGICAL] = "K_fp"; if (uselongints) err ("Can't use both long and short ints"); else { tyint = tylogical = TYSHORT; tylog = TYLOGICAL2; } } else if (uselongints) tyint = TYLONG; if (h0align) { if (tyint == TYLONG && wordalign) h0align = 1; ohalign = halign = hset[h0align]; htype = h0align == 1 ? tyint : TYDREAL; hsize = typesize[htype]; } if (no66flag) noextflag = no66flag; if (noextflag) zflag = 0; if (r8flag) { tyreal = TYDREAL; tycomplex = TYDCOMPLEX; r8fix(); } if (forcedouble) { protorettypes[TYREAL] = "E_f"; casttypes[TYREAL] = "E_fp"; } else dneg = 0; #ifndef NO_LONG_LONG if (!use_tyquad) allow_i8c = 0; #endif if (maxregvar > MAXREGVAR) { warni("-O%d: too many register variables", maxregvar); maxregvar = MAXREGVAR; } /* if maxregvar > MAXREGVAR */ /* Check the list of input files */ { int bad, i, cur_max = Max_ftn_files; for (i = bad = 0; i < cur_max && ftn_files[i]; i++) if (ftn_files[i][0] == '-') { errstr ("Invalid flag '%s'", ftn_files[i]); bad++; } if (bad) exit(1); } /* block */ } /* set_externs */ static int comm2dcl(Void) { Extsym *ext; if (ext1comm) for(ext = extsymtab; ext < nextext; ext++) if (ext->extstg == STGCOMMON && !ext->extinit) return ext1comm; return 0; } static void #ifdef KR_headers write_typedefs(outfile) FILE *outfile; #else write_typedefs(FILE *outfile) #endif { register int i; register char *s, *p = 0; static char st[4] = { TYREAL, TYCOMPLEX, TYDCOMPLEX, TYCHAR }; static char stl[4] = { 'E', 'C', 'Z', 'H' }; for(i = 0; i <= TYSUBR; i++) if (s = usedcasts[i]) { if (!p) { p = (char*)(Ansi == 1 ? "()" : "(...)"); nice_printf(outfile, "/* Types for casting procedure arguments: */\ \n\n#ifndef F2C_proc_par_types\n"); if (i == 0) { nice_printf(outfile, "typedef int /* Unknown procedure type */ (*%s)%s;\n", s, p); continue; } } nice_printf(outfile, "typedef %s (*%s)%s;\n", c_type_decl(i,1), s, p); } for(i = !forcedouble; i < 4; i++) if (used_rets[st[i]]) nice_printf(outfile, "typedef %s %c_f; /* %s function */\n", p = (char*)(i ? "VOID" : "doublereal"), stl[i], ftn_types[st[i]]); if (p) nice_printf(outfile, "#endif\n\n"); } static void #ifdef KR_headers commonprotos(outfile) register FILE *outfile; #else commonprotos(register FILE *outfile) #endif { register Extsym *e, *ee; register Argtypes *at; Atype *a, *ae; int k; extern int proc_protochanges; if (!outfile) return; for (e = extsymtab, ee = nextext; e < ee; e++) if (e->extstg == STGCOMMON && e->allextp) nice_printf(outfile, "/* comlen %s %ld */\n", e->cextname, e->maxleng); if (Castargs1 < 3) return; /* -Pr: special comments conveying current knowledge of external references */ k = proc_protochanges; for (e = extsymtab, ee = nextext; e < ee; e++) if (e->extstg == STGEXT && e->cextname != e->fextname) /* not a library function */ if (at = e->arginfo) { if ((!e->extinit || at->changes & 1) /* not defined here or changed since definition */ && at->nargs >= 0) { nice_printf(outfile, "/*:ref: %s %d %d", e->cextname, e->extype, at->nargs); a = at->atypes; for(ae = a + at->nargs; a < ae; a++) nice_printf(outfile, " %d", a->type); nice_printf(outfile, " */\n"); if (at->changes & 1) k++; } } else if (e->extype) /* typed external, never invoked */ nice_printf(outfile, "/*:ref: %s %d :*/\n", e->cextname, e->extype); if (k) { nice_printf(outfile, "/* Rerunning f2c -P may change prototypes or declarations. */\n"); if (nerr) return; if (protostatus) done(4); if (protofile != stdout) { fprintf(diagfile, "Rerunning \"f2c -P ... %s %s\" may change prototypes or declarations.\n", filename0, proto_fname); fflush(diagfile); } } } static int #ifdef KR_headers I_args(argc, a) int argc; char **a; #else I_args(int argc, char **a) #endif { char **a0, **a1, **ae, *s; ae = a + argc; a0 = a; for(a1 = ++a; a < ae; a++) { if (!(s = *a)) break; if (*s == '-' && s[1] == 'I' && s[2] && (s[3] || s[2] != '2' && s[2] != '4')) Iargs = mkchain(s+2, Iargs); else *a1++ = s; } Iargs = revchain(Iargs); *a1 = 0; return a1 - a0; } static void omit_non_f(Void) { /* complain about ftn_files that do not end in .f or .F */ char *s, *s1; int i, k; for(i = k = 0; s = ftn_files[k]; k++) { s1 = s + strlen(s); if (s1 - s >= 3) { s1 -= 2; if (*s1 == '.') switch(s1[1]) { case 'f': case 'F': ftn_files[i++] = s; continue; } } fprintf(diagfile, "\"%s\" does not end in .f or .F\n", s); } if (i != k) { fflush(diagfile); if (!i) exit(1); ftn_files[i] = 0; } } static void show_version(Void) { printf("f2c (Fortran to C Translator) version %s.\n", F2C_version); } static void #ifdef KR_headers show_help(progname) char *progname; #else show_help(char *progname) #endif { show_version(); if (!progname) progname = "f2c"; printf("Usage: %s [ option ... ] [file ...]\n%s%s%s%s%s%s%s", progname, "For usage details, see the man page, f2c.1.\n", "For technical details, see the f2c report.\n", "Both are available from netlib, e.g.,\n", "\thttp://netlib.bell-labs.com/netlib/f2c/f2c.1.gz\n", "\thttp://netlib.bell-labs.com/netlib/f2c/f2c.pdf\n", "or\n\thttp://www.netlib.org/f2c/f2c.1\n", "\thttp://www.netlib.org/f2c/f2c.pdf\n"); } int retcode = 0; int #ifdef KR_headers main(argc, argv) int argc; char **argv; #else main(int argc, char **argv) #endif { int c2d, k; FILE *c_output; char *cdfilename; static char stderrbuf[BUFSIZ]; extern char **dfltproc, *dflt1proc[]; extern char link_msg[]; diagfile = stderr; setbuf(stderr, stderrbuf); /* arrange for fast error msgs */ argkludge(&argc, &argv); /* for _WIN32 */ argc = I_args(argc, argv); /* extract -I args */ Max_ftn_files = argc - 1; ftn_files = (char **)ckalloc((argc+1)*sizeof(char *)); parse_args (argc, argv, table, sizeof(table)/sizeof(arg_info), ftn_files, Max_ftn_files); if (badargs) return 1; if (help) { show_help(argv[0]); return 0; } if (showver && !ftn_files[0]) { show_version(); return 0; } intr_omit = no_cd | no_i90; if (keepsubs && checksubs) { warn("-C suppresses -s\n"); keepsubs = 0; } if (!can_include && ext1comm == 2) ext1comm = 1; if (ext1comm && !extcomm) extcomm = 2; if (protostatus) Castargs = 3; Castargs1 = Castargs; if (!Ansi) { Castargs = 0; parens = "()"; } else if (!Castargs) parens = (char*)(Ansi == 1 ? "()" : "(...)"); else dfltproc = dflt1proc; outbuf_adjust(); set_externs(); fileinit(); read_Pfiles(ftn_files); omit_non_f(); for(k = 0; ftn_files[k+1]; k++) if (dofork(ftn_files[k])) break; filename0 = file_name = ftn_files[current_ftn_file = k]; set_tmp_names(); sigcatch(0); c_file = opf(c_functions, textwrite); pass1_file=opf(p1_file, binwrite); initkey(); if (file_name && *file_name) { cdfilename = coutput; if (debugflag != 1) { coutput = c_name(file_name,'c'); cdfilename = copys(outbtail); if (Castargs1 >= 2) proto_fname = c_name(file_name,'P'); } if (skipC) coutput = 0; else if (!(c_output = fopen(coutput, textwrite))) { file_name = coutput; coutput = 0; /* don't delete read-only .c file */ fatalstr("can't open %.86s", file_name); } if (Castargs1 >= 2 && !(protofile = fopen(proto_fname, textwrite))) fatalstr("Can't open %.84s\n", proto_fname); } else { file_name = ""; cdfilename = "f2c_out.c"; c_output = stdout; coutput = 0; if (Castargs1 >= 2) { protofile = stdout; if (!skipC) printf("#ifdef P_R_O_T_O_T_Y_P_E_S\n"); } } if(inilex( copys(file_name) )) done(1); if (filename0) { fprintf(diagfile, "%s:\n", file_name); fflush(diagfile); } procinit(); if(k = yyparse()) { fprintf(diagfile, "Bad parse, return code %d\n", k); done(1); } commonprotos(protofile); if (protofile == stdout && !skipC) printf("#endif\n\n"); if (nerr || skipC) goto C_skipped; /* Write out the declarations which are global to this file */ if ((c2d = comm2dcl()) == 1) nice_printf(c_output, "/*>>>'/dev/null'<<<*/\n\n\ /* Split this into several files by piping it through\n\n\ sed \"s/^\\/\\*>>>'\\(.*\\)'<<<\\*\\/\\$/cat >'\\1' <<'\\/*<<<\\1>>>*\\/'/\" | /bin/sh\n\ */\n\ /*<<>>*/\n\ /*>>>'%s'<<<*/\n", cdfilename); if (gflag) nice_printf (c_output, "#line 1 \"%s\"\n", file_name); if (!skipversion) { nice_printf (c_output, "/* %s -- translated by f2c ", file_name); nice_printf (c_output, "(version %s).\n", F2C_version); nice_printf (c_output, " You must link the resulting object file with libf2c:\n\ %s\n*/\n\n", link_msg); } if (Ansi == 2) nice_printf(c_output, "#ifdef __cplusplus\nextern \"C\" {\n#endif\n"); nice_printf (c_output, "%s#include \"f2c.h\"\n\n", def_i2); if (trapuv) nice_printf(c_output, "extern void _uninit_f2c(%s);\n%s\n\n", Ansi ? "void*,int,long" : "", "extern double _0;"); if (gflag) nice_printf (c_output, "#line 1 \"%s\"\n", file_name); if (Castargs && typedefs) write_typedefs(c_output); nice_printf (c_file, "\n"); fclose (c_file); c_file = c_output; /* HACK to get the next indenting to work */ wr_common_decls (c_output); if (blkdfile) list_init_data(&blkdfile, blkdfname, c_output); wr_globals (c_output); if ((c_file = fopen (c_functions, textread)) == (FILE *) NULL) Fatal("main - couldn't reopen c_functions"); ffilecopy (c_file, c_output); if (*main_alias) { nice_printf (c_output, "/* Main program alias */ "); nice_printf (c_output, "int %s () { MAIN__ ();%s }\n", main_alias, Ansi ? " return 0;" : ""); } if (Ansi == 2) nice_printf(c_output, "#ifdef __cplusplus\n\t}\n#endif\n"); if (c2d) { if (c2d == 1) fprintf(c_output, "/*<<<%s>>>*/\n", cdfilename); else fclose(c_output); def_commons(c_output); } if (c2d != 2) fclose (c_output); C_skipped: if(parstate != OUTSIDE) { warn("missing final end statement"); endproc(); nerr = 1; } done(nerr ? 1 : 0); /* NOT REACHED */ return 0; } FILEP #ifdef KR_headers opf(fn, mode) char *fn; char *mode; #else opf(char *fn, char *mode) #endif { FILEP fp; if( fp = fopen(fn, mode) ) return(fp); fatalstr("cannot open intermediate file %s", fn); /* NOT REACHED */ return 0; } void #ifdef KR_headers clf(p, what, quit) FILEP *p; char *what; int quit; #else clf(FILEP *p, char *what, int quit) #endif { if(p!=NULL && *p!=NULL && *p!=stdout) { if(ferror(*p)) { fprintf(stderr, "I/O error on %s\n", what); if (quit) done(3); retcode = 3; } fclose(*p); } *p = NULL; } void #ifdef KR_headers done(k) int k; #else done(int k) #endif { clf(&initfile, "initfile", 0); clf(&c_file, "c_file", 0); clf(&pass1_file, "pass1_file", 0); Un_link_all(k); exit(k|retcode); } f2c/src/makefile.u000066400000000000000000000071761171647030000142740ustar00rootroot00000000000000# Makefile for f2c, a Fortran 77 to C converter .SUFFIXES: .c .o CC = cc CFLAGS = -O SHELL = /bin/sh YACC = yacc YFLAGS = .c.o: $(CC) -c $(CFLAGS) $*.c OBJECTSd = main.o init.o gram.o lex.o proc.o equiv.o data.o format.o \ expr.o exec.o intr.o io.o misc.o error.o mem.o names.o \ output.o p1output.o pread.o put.o putpcc.o vax.o formatdata.o \ parse_args.o niceprintf.o cds.o sysdep.o version.o MALLOC = # To use the malloc whose source accompanies the f2c source, add malloc.o # to the right-hand side of the "MALLOC =" line above, so it becomes # MALLOC = malloc.o # This gives faster execution on some systems, but some other systems do # not tolerate replacement of the system's malloc. OBJECTS = $(OBJECTSd) $(MALLOC) all: xsum.out f2c f2c: $(OBJECTS) $(CC) $(LDFLAGS) $(OBJECTS) -o f2c # The following used to be a rule for gram.c rather than gram1.c, but # there are too many broken variants of yacc around, so now we # distribute a correctly functioning gram.c (derived with a Unix variant # of the yacc from plan9). gram1.c: gram.head gram.dcl gram.expr gram.exec gram.io defs.h tokdefs.h ( sed gram.in $(YACC) $(YFLAGS) gram.in @echo "(There should be 4 shift/reduce conflicts.)" sed 's/^# line.*/\/* & *\//' y.tab.c >gram.c rm -f gram.in y.tab.c $(OBJECTSd): defs.h ftypes.h defines.h machdefs.h sysdep.h tokdefs.h: tokens grep -n . tokdefs.h cds.o: sysdep.h exec.o: p1defs.h names.h expr.o: output.h niceprintf.h names.h format.o: p1defs.h format.h output.h niceprintf.h names.h iob.h formatdata.o: format.h output.h niceprintf.h names.h gram.o: p1defs.h init.o: output.h niceprintf.h iob.h intr.o: names.h io.o: names.h iob.h lex.o : tokdefs.h p1defs.h main.o: parse.h usignal.h mem.o: iob.h names.o: iob.h names.h output.h niceprintf.h niceprintf.o: defs.h names.h output.h niceprintf.h output.o: output.h niceprintf.h names.h p1output.o: p1defs.h output.h niceprintf.h names.h parse_args.o: parse.h proc.o: tokdefs.h names.h niceprintf.h output.h p1defs.h put.o: names.h pccdefs.h p1defs.h putpcc.o: names.h vax.o: defs.h output.h pccdefs.h output.h: niceprintf.h sysdep.o: sysdep.c sysdep.hd put.o putpcc.o: pccdefs.h sysdep.hd: if $(CC) sysdeptest.c; then echo '/*OK*/' > sysdep.hd;\ elif $(CC) -DNO_MKDTEMP sysdeptest.c; then echo '#define NO_MKDTEMP' >sysdep.hd;\ else echo '#define NO_MKDTEMP' >sysdep.hd; echo '#define NO_MKSTEMP' >>sysdep.hd; fi rm -f a.out f2c.t: f2c.1t troff -man f2c.1t >f2c.t #f2c.1: f2c.1t # nroff -man f2c.1t | col -b | uniq >f2c.1 clean: rm -f *.o f2c sysdep.hd tokdefs.h f2c.t veryclean: clean rm -f xsum b = 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 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 xsum: xsum.c $(CC) $(CFLAGS) -o xsum xsum.c #Check validity of transmitted source... xsum.out: xsum $b ./xsum $b >xsum1.out cmp xsum0.out xsum1.out && mv xsum1.out xsum.out #On non-Unix systems that end lines with carriage-return/newline pairs, #use "make xsumr.out" rather than "make xsum.out". The -r flag ignores #carriage-return characters. xsumr.out: xsum $b ./xsum -r $b >xsum1.out cmp xsum0.out xsum1.out && mv xsum1.out xsumr.out f2c/src/makefile.vc000066400000000000000000000051751171647030000144350ustar00rootroot00000000000000# Microsoft Visual C++ Makefile for f2c, a Fortran 77 to C converter # Invoke with "nmake -f makefile.vc", or execute the commands # copy makefile.vc makefile # nmake . CC = cl CFLAGS = -Ot1 -nologo -DNO_LONG_LONG .c.obj: $(CC) -c $(CFLAGS) $*.c OBJECTS = main.obj init.obj gram.obj lex.obj proc.obj equiv.obj data.obj format.obj \ expr.obj exec.obj intr.obj io.obj misc.obj error.obj mem.obj names.obj \ output.obj p1output.obj pread.obj put.obj putpcc.obj vax.obj formatdata.obj \ parse_args.obj niceprintf.obj cds.obj sysdep.obj version.obj checkfirst: xsum.out f2c.exe: $(OBJECTS) $(CC) -Fef2c.exe $(OBJECTS) setargv.obj $(OBJECTS): defs.h ftypes.h defines.h machdefs.h sysdep.h cds.obj: sysdep.h exec.obj: p1defs.h names.h expr.obj: output.h niceprintf.h names.h format.obj: p1defs.h format.h output.h niceprintf.h names.h iob.h formatdata.obj: format.h output.h niceprintf.h names.h gram.obj: p1defs.h init.obj: output.h niceprintf.h iob.h intr.obj: names.h io.obj: names.h iob.h lex.obj : tokdefs.h p1defs.h main.obj: parse.h usignal.h mem.obj: iob.h names.obj: iob.h names.h output.h niceprintf.h niceprintf.obj: defs.h names.h output.h niceprintf.h output.obj: output.h niceprintf.h names.h p1output.obj: p1defs.h output.h niceprintf.h names.h parse_args.obj: parse.h proc.obj: tokdefs.h names.h niceprintf.h output.h p1defs.h put.obj: names.h pccdefs.h p1defs.h putpcc.obj: names.h vax.obj: defs.h output.h pccdefs.h output.h: niceprintf.h put.obj putpcc.obj: pccdefs.h clean: deltree /Y *.obj f2c.exe veryclean: clean deltree /Y xsum.exe b = 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 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 xsum.exe: xsum.c $(CC) $(CFLAGS) -DMSDOS xsum.c #Check validity of transmitted source... # Unfortunately, conditional execution is hard here, since fc does not set a # nonzero exit code when files differ. xsum.out: xsum.exe $b xsum $b >xsum1.out fc xsum0.out xsum1.out @echo If fc showed no differences, manually rename xsum1.out xsum.out: @echo if xsum.out exists, first "del xsum.out"; then "ren xsum1.out xsum.out". @echo Once you are happy that your source is OK, "nmake -f makefile.vc f2c.exe". f2c/src/malloc.c000066400000000000000000000076071171647030000137430ustar00rootroot00000000000000/**************************************************************** Copyright 1990, 1994, 2000 by AT&T, Lucent Technologies and Bellcore. Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the above copyright notice appear in all copies and that both that the copyright notice and this permission notice and warranty disclaimer appear in supporting documentation, and that the names of AT&T, Bell Laboratories, Lucent or Bellcore or any of their entities not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. AT&T, Lucent and Bellcore disclaim all warranties with regard to this software, including all implied warranties of merchantability and fitness. In no event shall AT&T, Lucent or Bellcore be liable for any special, indirect or consequential damages or any damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortious action, arising out of or in connection with the use or performance of this software. ****************************************************************/ #ifndef CRAY #define STACKMIN 512 #define MINBLK (2*sizeof(struct mem) + 16) #define F _malloc_free_ #define SBGULP 8192 #include "string.h" /* for memcpy */ #ifdef KR_headers #define Char char #define Unsigned unsigned #define Int /*int*/ #else #define Char void #define Unsigned size_t #define Int int #endif typedef struct mem { struct mem *next; Unsigned len; } mem; mem *F; Char * #ifdef KR_headers malloc(size) register Unsigned size; #else malloc(register Unsigned size) #endif { register mem *p, *q, *r, *s; unsigned register k, m; extern Char *sbrk(Int); char *top, *top1; size = (size+7) & ~7; r = (mem *) &F; for (p = F, q = 0; p; r = p, p = p->next) { if ((k = p->len) >= size && (!q || m > k)) { m = k; q = p; s = r; } } if (q) { if (q->len - size >= MINBLK) { /* split block */ p = (mem *) (((char *) (q+1)) + size); p->next = q->next; p->len = q->len - size - sizeof(mem); s->next = p; q->len = size; } else s->next = q->next; } else { top = (Char *)(((long)sbrk(0) + 7) & ~7); if (F && (char *)(F+1) + F->len == top) { q = F; F = F->next; } else q = (mem *) top; top1 = (char *)(q+1) + size; if (sbrk((int)(top1-top+SBGULP)) == (Char *) -1) return 0; r = (mem *)top1; r->len = SBGULP - sizeof(mem); r->next = F; F = r; q->len = size; } return (Char *) (q+1); } void #ifdef KR_headers free(f) Char *f; #else free(Char *f) #endif { mem *p, *q, *r; char *pn, *qn; if (!f) return; q = (mem *) ((char *)f - sizeof(mem)); qn = (char *)f + q->len; for (p = F, r = (mem *) &F; ; r = p, p = p->next) { if (qn == (Char *) p) { q->len += p->len + sizeof(mem); p = p->next; } pn = p ? ((char *) (p+1)) + p->len : 0; if (pn == (Char *) q) { p->len += sizeof(mem) + q->len; q->len = 0; q->next = p; r->next = p; break; } if (pn < (char *) q) { r->next = q; q->next = p; break; } } } Char * #ifdef KR_headers realloc(f, size) Char *f; Unsigned size; #else realloc(Char *f, Unsigned size) #endif { mem *p; Char *q, *f1; Unsigned s1; if (!f) return malloc(size); p = (mem *) ((char *)f - sizeof(mem)); s1 = p->len; free(f); if (s1 > size) s1 = size + 7 & ~7; if (!p->len) { f1 = (Char *)(p->next + 1); memcpy(f1, f, s1); f = f1; } q = malloc(size); if (q && q != f) memcpy(q, f, s1); return q; } /* The following (calloc) should really be in a separate file, */ /* but defining it here sometimes avoids confusion on systems */ /* that do not provide calloc in its own file. */ Char * #ifdef KR_headers calloc(n, m) Unsigned m, n; #else calloc(Unsigned n, Unsigned m) #endif { Char *rv; rv = malloc(n *= m); if (n && rv) memset(rv, 0, n); return rv; } #endif f2c/src/mem.c000066400000000000000000000124751171647030000132510ustar00rootroot00000000000000/**************************************************************** Copyright 1990, 1991, 1994, 2000 by AT&T, Lucent Technologies and Bellcore. Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the above copyright notice appear in all copies and that both that the copyright notice and this permission notice and warranty disclaimer appear in supporting documentation, and that the names of AT&T, Bell Laboratories, Lucent or Bellcore or any of their entities not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. AT&T, Lucent and Bellcore disclaim all warranties with regard to this software, including all implied warranties of merchantability and fitness. In no event shall AT&T, Lucent or Bellcore be liable for any special, indirect or consequential damages or any damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortious action, arising out of or in connection with the use or performance of this software. ****************************************************************/ #include "defs.h" #include "iob.h" #define MEMBSIZE 32000 #define GMEMBSIZE 16000 #ifdef _WIN32 #undef MSDOS #endif char * #ifdef KR_headers gmem(n, round) int n; int round; #else gmem(int n, int round) #endif { static char *last, *next; char *rv; if (round) #ifdef CRAY if ((long)next & 0xe000000000000000) next = (char *)(((long)next & 0x1fffffffffffffff) + 1); #else #ifdef MSDOS if ((int)next & 1) next++; #else next = (char *)(((long)next + sizeof(char *)-1) & ~((long)sizeof(char *)-1)); #endif #endif rv = next; if ((next += n) > last) { rv = Alloc(n + GMEMBSIZE); next = rv + n; last = next + GMEMBSIZE; } return rv; } struct memblock { struct memblock *next; char buf[MEMBSIZE]; }; typedef struct memblock memblock; static memblock *mem0; memblock *curmemblock, *firstmemblock; char *mem_first, *mem_next, *mem_last, *mem0_last; void mem_init(Void) { curmemblock = firstmemblock = mem0 = (memblock *)Alloc(sizeof(memblock)); mem_first = mem0->buf; mem_next = mem0->buf; mem_last = mem0->buf + MEMBSIZE; mem0_last = mem0->buf + MEMBSIZE; mem0->next = 0; } char * #ifdef KR_headers mem(n, round) int n; int round; #else mem(int n, int round) #endif { memblock *b; register char *rv, *s; if (round) #ifdef CRAY if ((long)mem_next & 0xe000000000000000) mem_next = (char *)(((long)mem_next & 0x1fffffffffffffff) + 1); #else #ifdef MSDOS if ((int)mem_next & 1) mem_next++; #else mem_next = (char *)(((long)mem_next + sizeof(char *)-1) & ~((long)sizeof(char *)-1)); #endif #endif rv = mem_next; s = rv + n; if (s >= mem_last) { if (n > MEMBSIZE) { fprintf(stderr, "mem(%d) failure!\n", n); exit(1); } if (!(b = curmemblock->next)) { b = (memblock *)Alloc(sizeof(memblock)); curmemblock->next = b; b->next = 0; } curmemblock = b; rv = b->buf; mem_last = rv + sizeof(b->buf); s = rv + n; } mem_next = s; return rv; } char * #ifdef KR_headers tostring(s, n) register char *s; int n; #else tostring(register char *s, int n) #endif { register char *s1, *se, **sf; char *rv, *s0; register int k = n + 2, t; sf = str_fmt; sf['%'] = "%"; s0 = s; se = s + n; for(; s < se; s++) { t = *(unsigned char *)s; s1 = sf[t]; while(*++s1) k++; } sf['%'] = "%%"; rv = s1 = mem(k,0); *s1++ = '"'; for(s = s0; s < se; s++) { t = *(unsigned char *)s; sprintf(s1, sf[t], t); s1 += strlen(s1); } *s1 = 0; return rv; } char * #ifdef KR_headers cpstring(s) register char *s; #else cpstring(register char *s) #endif { return strcpy(mem(strlen(s)+1,0), s); } void #ifdef KR_headers new_iob_data(ios, name) register io_setup *ios; char *name; #else new_iob_data(register io_setup *ios, char *name) #endif { register iob_data *iod; register char **s, **se; iod = (iob_data *) mem(sizeof(iob_data) + ios->nelt*sizeof(char *), 1); iod->next = iob_list; iob_list = iod; iod->type = ios->fields[0]; iod->name = cpstring(name); s = iod->fields; se = s + ios->nelt; while(s < se) *s++ = "0"; *s = 0; } char * #ifdef KR_headers string_num(pfx, n) char *pfx; long n; #else string_num(char *pfx, long n) #endif { char buf[32]; sprintf(buf, "%s%ld", pfx, n); /* can't trust return type of sprintf -- BSD gets it wrong */ return strcpy(mem(strlen(buf)+1,0), buf); } static defines *define_list; void #ifdef KR_headers def_start(outfile, s1, s2, post) FILE *outfile; char *s1; char *s2; char *post; #else def_start(FILE *outfile, char *s1, char *s2, char *post) #endif { defines *d; int n, n1; extern int in_define; n = n1 = strlen(s1); if (s2) n += strlen(s2); d = (defines *)mem(sizeof(defines)+n, 1); d->next = define_list; define_list = d; strcpy(d->defname, s1); if (s2) strcpy(d->defname + n1, s2); in_define = 1; nice_printf(outfile, "#define %s", d->defname); if (post) nice_printf(outfile, " %s", post); } void #ifdef KR_headers other_undefs(outfile) FILE *outfile; #else other_undefs(FILE *outfile) #endif { defines *d; if (d = define_list) { define_list = 0; nice_printf(outfile, "\n"); do nice_printf(outfile, "#undef %s\n", d->defname); while(d = d->next); nice_printf(outfile, "\n"); } } f2c/src/memset.c000066400000000000000000000041111171647030000137510ustar00rootroot00000000000000/**************************************************************** Copyright 1990, 2000 by AT&T, Lucent Technologies and Bellcore. Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the above copyright notice appear in all copies and that both that the copyright notice and this permission notice and warranty disclaimer appear in supporting documentation, and that the names of AT&T, Bell Laboratories, Lucent or Bellcore or any of their entities not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. AT&T, Lucent and Bellcore disclaim all warranties with regard to this software, including all implied warranties of merchantability and fitness. In no event shall AT&T, Lucent or Bellcore be liable for any special, indirect or consequential damages or any damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortious action, arising out of or in connection with the use or performance of this software. ****************************************************************/ /* This is for the benefit of people whose systems don't provide * memset, memcpy, and memcmp. If yours is such a system, adjust * the makefile by adding memset.o to the "OBJECTS =" assignment. * WARNING: the memcpy below is adequate for f2c, but is not a * general memcpy routine (which must correctly handle overlapping * fields). */ int #ifdef KR_headers memcmp(s1, s2, n) char *s1, *s2; int n; #else memcmp(char *s1, char *s2, int n) #endif { char *se; for(se = s1 + n; s1 < se; s1++, s2++) if (*s1 != *s2) return *s1 - *s2; return 0; } char * #ifdef KR_headers memcpy(s1, s2, n) char *s1, *s2; int n; #else memcpy(char *s1, char *s2, int n) #endif { char *s0 = s1, *se = s1 + n; while(s1 < se) *s1++ = *s2++; return s0; } void #ifdef KR_headers memset(s, c, n) char *s; int c, n; #else memset(char *s, int c, int n) #endif { char *se = s + n; while(s < se) *s++ = c; } f2c/src/misc.c000066400000000000000000000546411171647030000134270ustar00rootroot00000000000000/**************************************************************** Copyright 1990, 1992-1995, 2000-2001 by AT&T, Lucent Technologies and Bellcore. Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the above copyright notice appear in all copies and that both that the copyright notice and this permission notice and warranty disclaimer appear in supporting documentation, and that the names of AT&T, Bell Laboratories, Lucent or Bellcore or any of their entities not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. AT&T, Lucent and Bellcore disclaim all warranties with regard to this software, including all implied warranties of merchantability and fitness. In no event shall AT&T, Lucent or Bellcore be liable for any special, indirect or consequential damages or any damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortious action, arising out of or in connection with the use or performance of this software. ****************************************************************/ #include "defs.h" #include "limits.h" int #ifdef KR_headers oneof_stg(name, stg, mask) Namep name; int stg; int mask; #else oneof_stg(Namep name, int stg, int mask) #endif { if (stg == STGCOMMON && name) { if ((mask & M(STGEQUIV))) return name->vcommequiv; if ((mask & M(STGCOMMON))) return !name->vcommequiv; } return ONEOF(stg, mask); } /* op_assign -- given a binary opcode, return the associated assignment operator */ int #ifdef KR_headers op_assign(opcode) int opcode; #else op_assign(int opcode) #endif { int retval = -1; switch (opcode) { case OPPLUS: retval = OPPLUSEQ; break; case OPMINUS: retval = OPMINUSEQ; break; case OPSTAR: retval = OPSTAREQ; break; case OPSLASH: retval = OPSLASHEQ; break; case OPMOD: retval = OPMODEQ; break; case OPLSHIFT: retval = OPLSHIFTEQ; break; case OPRSHIFT: retval = OPRSHIFTEQ; break; case OPBITAND: retval = OPBITANDEQ; break; case OPBITXOR: retval = OPBITXOREQ; break; case OPBITOR: retval = OPBITOREQ; break; default: erri ("op_assign: bad opcode '%d'", opcode); break; } /* switch */ return retval; } /* op_assign */ char * #ifdef KR_headers Alloc(n) int n; #else Alloc(int n) #endif /* error-checking version of malloc */ /* ckalloc initializes memory to 0; Alloc does not */ { char errbuf[32]; register char *rv; rv = (char*)malloc(n); if (!rv) { sprintf(errbuf, "malloc(%d) failure!", n); Fatal(errbuf); } return rv; } void #ifdef KR_headers cpn(n, a, b) register int n; register char *a; register char *b; #else cpn(register int n, register char *a, register char *b) #endif { while(--n >= 0) *b++ = *a++; } int #ifdef KR_headers eqn(n, a, b) register int n; register char *a; register char *b; #else eqn(register int n, register char *a, register char *b) #endif { while(--n >= 0) if(*a++ != *b++) return(NO); return(YES); } int #ifdef KR_headers cmpstr(a, b, la, lb) register char *a; register char *b; ftnint la; ftnint lb; #else cmpstr(register char *a, register char *b, ftnint la, ftnint lb) #endif /* compare two strings */ { register char *aend, *bend; aend = a + la; bend = b + lb; if(la <= lb) { while(a < aend) if(*a != *b) return( *a - *b ); else { ++a; ++b; } while(b < bend) if(*b != ' ') return(' ' - *b); else ++b; } else { while(b < bend) if(*a != *b) return( *a - *b ); else { ++a; ++b; } while(a < aend) if(*a != ' ') return(*a - ' '); else ++a; } return(0); } /* hookup -- Same as LISP NCONC, that is a destructive append of two lists */ chainp #ifdef KR_headers hookup(x, y) register chainp x; register chainp y; #else hookup(register chainp x, register chainp y) #endif { register chainp p; if(x == NULL) return(y); for(p = x ; p->nextp ; p = p->nextp) ; p->nextp = y; return(x); } struct Listblock * #ifdef KR_headers mklist(p) chainp p; #else mklist(chainp p) #endif { register struct Listblock *q; q = ALLOC(Listblock); q->tag = TLIST; q->listp = p; return(q); } chainp #ifdef KR_headers mkchain(p, q) register char * p; register chainp q; #else mkchain(register char * p, register chainp q) #endif { register chainp r; if(chains) { r = chains; chains = chains->nextp; } else r = ALLOC(Chain); r->datap = p; r->nextp = q; return(r); } chainp #ifdef KR_headers revchain(next) register chainp next; #else revchain(register chainp next) #endif { register chainp p, prev = 0; while(p = next) { next = p->nextp; p->nextp = prev; prev = p; } return prev; } /* addunder -- turn a cvarname into an external name */ /* The cvarname may already end in _ (to avoid C keywords); */ /* if not, it has room for appending an _. */ char * #ifdef KR_headers addunder(s) register char *s; #else addunder(register char *s) #endif { register int c, i, j; char *s0 = s; i = j = 0; while(c = *s++) if (c == '_') i++, j++; else i = 0; if (!i) { *s-- = 0; *s = '_'; } else if (j == 2) s[-2] = 0; return( s0 ); } /* copyn -- return a new copy of the input Fortran-string */ char * #ifdef KR_headers copyn(n, s) register int n; register char *s; #else copyn(register int n, register char *s) #endif { register char *p, *q; p = q = (char *) Alloc(n); while(--n >= 0) *q++ = *s++; return(p); } /* copys -- return a new copy of the input C-string */ char * #ifdef KR_headers copys(s) char *s; #else copys(char *s) #endif { return( copyn( strlen(s)+1 , s) ); } /* convci -- Convert Fortran-string to integer; assumes that input is a legal number, with no trailing blanks */ ftnint #ifdef KR_headers convci(n, s) register int n; register char *s; #else convci(register int n, register char *s) #endif { ftnint sum, t; char buff[100], *s0; int n0; s0 = s; n0 = n; sum = 0; while(n-- > 0) { /* sum = 10*sum + (*s++ - '0'); */ t = *s++ - '0'; if (sum > LONG_MAX/10) { ovfl: if (n0 > 60) n0 = 60; sprintf(buff, "integer constant %.*s truncated.", n0, s0); err(buff); return LONG_MAX; } sum *= 10; if (sum > LONG_MAX - t) goto ovfl; sum += t; } return(sum); } /* convic - Convert Integer constant to string */ char * #ifdef KR_headers convic(n) ftnint n; #else convic(ftnint n) #endif { static char s[20]; register char *t; s[19] = '\0'; t = s+19; do { *--t = '0' + n%10; n /= 10; } while(n > 0); return(t); } /* mkname -- add a new identifier to the environment, including the closed hash table. */ Namep #ifdef KR_headers mkname(s) register char *s; #else mkname(register char *s) #endif { struct Hashentry *hp; register Namep q; register int c, hash, i; register char *t; char *s0; char errbuf[64]; hash = i = 0; s0 = s; while(c = *s++) { hash += c; if (c == '_') i = 2; } if (!i && in_vector(s0,c_keywords,n_keywords) >= 0) i = 2; hash %= maxhash; /* Add the name to the closed hash table */ hp = hashtab + hash; while(q = hp->varp) if( hash == hp->hashval && !strcmp(s0,q->fvarname) ) return(q); else if(++hp >= lasthash) hp = hashtab; if(++nintnames >= maxhash-1) many("names", 'n', maxhash); /* Fatal error */ hp->varp = q = ALLOC(Nameblock); hp->hashval = hash; q->tag = TNAME; /* TNAME means the tag type is NAME */ c = s - s0; if (c > 7 && noextflag) { sprintf(errbuf, "\"%.35s%s\" over 6 characters long", s0, c > 36 ? "..." : ""); errext(errbuf); } q->fvarname = strcpy(mem(c,0), s0); t = q->cvarname = mem(c + i + 1, 0); s = s0; /* add __ to the end of any name containing _ and to any C keyword */ while(*t = *s++) t++; if (i) { do *t++ = '_'; while(--i > 0); *t = 0; } return(q); } struct Labelblock * #ifdef KR_headers mklabel(l) ftnint l; #else mklabel(ftnint l) #endif { register struct Labelblock *lp; if(l <= 0) return(NULL); for(lp = labeltab ; lp < highlabtab ; ++lp) if(lp->stateno == l) return(lp); if(++highlabtab > labtabend) many("statement labels", 's', maxstno); lp->stateno = l; lp->labelno = (int)newlabel(); lp->blklevel = 0; lp->labused = NO; lp->fmtlabused = NO; lp->labdefined = NO; lp->labinacc = NO; lp->labtype = LABUNKNOWN; lp->fmtstring = 0; return(lp); } long newlabel(Void) { return ++lastlabno; } /* this label appears in a branch context */ struct Labelblock * #ifdef KR_headers execlab(stateno) ftnint stateno; #else execlab(ftnint stateno) #endif { register struct Labelblock *lp; if(lp = mklabel(stateno)) { if(lp->labinacc) warn1("illegal branch to inner block, statement label %s", convic(stateno) ); else if(lp->labdefined == NO) lp->blklevel = blklevel; if(lp->labtype == LABFORMAT) err("may not branch to a format"); else lp->labtype = LABEXEC; } else execerr("illegal label %s", convic(stateno)); return(lp); } /* find or put a name in the external symbol table */ Extsym * #ifdef KR_headers mkext1(f, s) char *f; char *s; #else mkext1(char *f, char *s) #endif { Extsym *p; for(p = extsymtab ; pcextname)) return( p ); if(nextext >= lastext) many("external symbols", 'x', maxext); nextext->fextname = strcpy(gmem(strlen(f)+1,0), f); nextext->cextname = f == s ? nextext->fextname : strcpy(gmem(strlen(s)+1,0), s); nextext->extstg = STGUNKNOWN; nextext->extp = 0; nextext->allextp = 0; nextext->extleng = 0; nextext->maxleng = 0; nextext->extinit = 0; nextext->curno = nextext->maxno = 0; return( nextext++ ); } Extsym * #ifdef KR_headers mkext(f, s) char *f; char *s; #else mkext(char *f, char *s) #endif { Extsym *e = mkext1(f, s); if (e->extstg == STGCOMMON) errstr("%.52s cannot be a subprogram: it is a common block.",f); return e; } Addrp #ifdef KR_headers builtin(t, s, dbi) int t; char *s; int dbi; #else builtin(int t, char *s, int dbi) #endif { register Extsym *p; register Addrp q; extern chainp used_builtins; p = mkext(s,s); if(p->extstg == STGUNKNOWN) p->extstg = STGEXT; else if(p->extstg != STGEXT) { errstr("improper use of builtin %s", s); return(0); } q = ALLOC(Addrblock); q->tag = TADDR; q->vtype = t; q->vclass = CLPROC; q->vstg = STGEXT; q->memno = p - extsymtab; q->dbl_builtin = dbi; /* A NULL pointer here tells you to use memno to check the external symbol table */ q -> uname_tag = UNAM_EXTERN; /* Add to the list of used builtins */ if (dbi >= 0) add_extern_to_list (q, &used_builtins); return(q); } void #ifdef KR_headers add_extern_to_list(addr, list_store) Addrp addr; chainp *list_store; #else add_extern_to_list(Addrp addr, chainp *list_store) #endif { chainp last = CHNULL; chainp list; int memno; if (list_store == (chainp *) NULL || addr == (Addrp) NULL) return; list = *list_store; memno = addr -> memno; for (;list; last = list, list = list -> nextp) { Addrp This = (Addrp) (list -> datap); if (This -> tag == TADDR && This -> uname_tag == UNAM_EXTERN && This -> memno == memno) return; } /* for */ if (*list_store == CHNULL) *list_store = mkchain((char *)cpexpr((expptr)addr), CHNULL); else last->nextp = mkchain((char *)cpexpr((expptr)addr), CHNULL); } /* add_extern_to_list */ void #ifdef KR_headers frchain(p) register chainp *p; #else frchain(register chainp *p) #endif { register chainp q; if(p==0 || *p==0) return; for(q = *p; q->nextp ; q = q->nextp) ; q->nextp = chains; chains = *p; *p = 0; } void #ifdef KR_headers frexchain(p) register chainp *p; #else frexchain(register chainp *p) #endif { register chainp q, r; if (q = *p) { for(;;q = r) { frexpr((expptr)q->datap); if (!(r = q->nextp)) break; } q->nextp = chains; chains = *p; *p = 0; } } tagptr #ifdef KR_headers cpblock(n, p) register int n; register char *p; #else cpblock(register int n, register char *p) #endif { register ptr q; memcpy((char *)(q = ckalloc(n)), (char *)p, n); return( (tagptr) q); } ftnint #ifdef KR_headers lmax(a, b) ftnint a; ftnint b; #else lmax(ftnint a, ftnint b) #endif { return( a>b ? a : b); } ftnint #ifdef KR_headers lmin(a, b) ftnint a; ftnint b; #else lmin(ftnint a, ftnint b) #endif { return(a < b ? a : b); } int #ifdef KR_headers maxtype(t1, t2) int t1; int t2; #else maxtype(int t1, int t2) #endif { int t; t = t1 >= t2 ? t1 : t2; if(t==TYCOMPLEX && (t1==TYDREAL || t2==TYDREAL) ) t = TYDCOMPLEX; return(t); } /* return log base 2 of n if n a power of 2; otherwise -1 */ int #ifdef KR_headers log_2(n) ftnint n; #else log_2(ftnint n) #endif { int k; /* trick based on binary representation */ if(n<=0 || (n & (n-1))!=0) return(-1); for(k = 0 ; n >>= 1 ; ++k) ; return(k); } void frrpl(Void) { struct Rplblock *rp; while(rpllist) { rp = rpllist->rplnextp; free( (charptr) rpllist); rpllist = rp; } } /* Call a Fortran function with an arbitrary list of arguments */ int callk_kludge; expptr #ifdef KR_headers callk(type, name, args) int type; char *name; chainp args; #else callk(int type, char *name, chainp args) #endif { register expptr p; p = mkexpr(OPCALL, (expptr)builtin(callk_kludge ? callk_kludge : type, name, 0), (expptr)args); p->exprblock.vtype = type; return(p); } expptr #ifdef KR_headers call4(type, name, arg1, arg2, arg3, arg4) int type; char *name; expptr arg1; expptr arg2; expptr arg3; expptr arg4; #else call4(int type, char *name, expptr arg1, expptr arg2, expptr arg3, expptr arg4) #endif { struct Listblock *args; args = mklist( mkchain((char *)arg1, mkchain((char *)arg2, mkchain((char *)arg3, mkchain((char *)arg4, CHNULL)) ) ) ); return( callk(type, name, (chainp)args) ); } expptr #ifdef KR_headers call3(type, name, arg1, arg2, arg3) int type; char *name; expptr arg1; expptr arg2; expptr arg3; #else call3(int type, char *name, expptr arg1, expptr arg2, expptr arg3) #endif { struct Listblock *args; args = mklist( mkchain((char *)arg1, mkchain((char *)arg2, mkchain((char *)arg3, CHNULL) ) ) ); return( callk(type, name, (chainp)args) ); } expptr #ifdef KR_headers call2(type, name, arg1, arg2) int type; char *name; expptr arg1; expptr arg2; #else call2(int type, char *name, expptr arg1, expptr arg2) #endif { struct Listblock *args; args = mklist( mkchain((char *)arg1, mkchain((char *)arg2, CHNULL) ) ); return( callk(type,name, (chainp)args) ); } expptr #ifdef KR_headers call1(type, name, arg) int type; char *name; expptr arg; #else call1(int type, char *name, expptr arg) #endif { return( callk(type,name, (chainp)mklist(mkchain((char *)arg,CHNULL)) )); } expptr #ifdef KR_headers call0(type, name) int type; char *name; #else call0(int type, char *name) #endif { return( callk(type, name, CHNULL) ); } struct Impldoblock * #ifdef KR_headers mkiodo(dospec, list) chainp dospec; chainp list; #else mkiodo(chainp dospec, chainp list) #endif { register struct Impldoblock *q; q = ALLOC(Impldoblock); q->tag = TIMPLDO; q->impdospec = dospec; q->datalist = list; return(q); } /* ckalloc -- Allocate 1 memory unit of size n, checking for out of memory error */ ptr #ifdef KR_headers ckalloc(n) register int n; #else ckalloc(register int n) #endif { register ptr p; p = (ptr)calloc(1, (unsigned) n); if (p || !n) return(p); fprintf(stderr, "failing to get %d bytes\n",n); Fatal("out of memory"); /* NOT REACHED */ return 0; } int #ifdef KR_headers isaddr(p) register expptr p; #else isaddr(register expptr p) #endif { if(p->tag == TADDR) return(YES); if(p->tag == TEXPR) switch(p->exprblock.opcode) { case OPCOMMA: return( isaddr(p->exprblock.rightp) ); case OPASSIGN: case OPASSIGNI: case OPPLUSEQ: case OPMINUSEQ: case OPSLASHEQ: case OPMODEQ: case OPLSHIFTEQ: case OPRSHIFTEQ: case OPBITANDEQ: case OPBITXOREQ: case OPBITOREQ: return( isaddr(p->exprblock.leftp) ); } return(NO); } int #ifdef KR_headers isstatic(p) register expptr p; #else isstatic(register expptr p) #endif { extern int useauto; if(p->headblock.vleng && !ISCONST(p->headblock.vleng)) return(NO); switch(p->tag) { case TCONST: return(YES); case TADDR: if(ONEOF(p->addrblock.vstg,MSKSTATIC) && ISCONST(p->addrblock.memoffset) && !useauto) return(YES); default: return(NO); } } /* addressable -- return True iff it is a constant value, or can be referenced by constant values */ int #ifdef KR_headers addressable(p) expptr p; #else addressable(expptr p) #endif { if (p) switch(p->tag) { case TCONST: return(YES); case TADDR: return( addressable(p->addrblock.memoffset) ); } return(NO); } /* isnegative_const -- returns true if the constant is negative. Returns false for imaginary and nonnumeric constants */ int #ifdef KR_headers isnegative_const(cp) struct Constblock *cp; #else isnegative_const(struct Constblock *cp) #endif { int retval; if (cp == NULL) return 0; switch (cp -> vtype) { case TYINT1: case TYSHORT: case TYLONG: #ifdef TYQUAD case TYQUAD: #endif retval = cp -> Const.ci < 0; break; case TYREAL: case TYDREAL: retval = cp->vstg ? *cp->Const.cds[0] == '-' : cp->Const.cd[0] < 0.0; break; default: retval = 0; break; } /* switch */ return retval; } /* isnegative_const */ void #ifdef KR_headers negate_const(cp) Constp cp; #else negate_const(Constp cp) #endif { if (cp == (struct Constblock *) NULL) return; switch (cp -> vtype) { case TYINT1: case TYSHORT: case TYLONG: #ifdef TYQUAD case TYQUAD: #endif cp -> Const.ci = - cp -> Const.ci; break; case TYCOMPLEX: case TYDCOMPLEX: if (cp->vstg) switch(*cp->Const.cds[1]) { case '-': ++cp->Const.cds[1]; break; case '0': break; default: --cp->Const.cds[1]; } else cp->Const.cd[1] = -cp->Const.cd[1]; /* no break */ case TYREAL: case TYDREAL: if (cp->vstg) switch(*cp->Const.cds[0]) { case '-': ++cp->Const.cds[0]; break; case '0': break; default: --cp->Const.cds[0]; } else cp->Const.cd[0] = -cp->Const.cd[0]; break; case TYCHAR: case TYLOGICAL1: case TYLOGICAL2: case TYLOGICAL: erri ("negate_const: can't negate type '%d'", cp -> vtype); break; default: erri ("negate_const: bad type '%d'", cp -> vtype); break; } /* switch */ } /* negate_const */ void #ifdef KR_headers ffilecopy(infp, outfp) FILE *infp, *outfp; #else ffilecopy(FILE *infp, FILE *outfp) #endif { int c; while (!feof(infp)) { c = getc(infp); if (!feof(infp)) putc(c, outfp); } } /* in_vector -- verifies whether str is in c_keywords. If so, the index is returned else -1 is returned. c_keywords must be in alphabetical order (as defined by strcmp). */ int #ifdef KR_headers in_vector(str, keywds, n) char *str; char **keywds; register int n; #else in_vector(char *str, char **keywds, register int n) #endif { register char **K = keywds; register int n1, t; do { n1 = n >> 1; if (!(t = strcmp(str, K[n1]))) return K - keywds + n1; if (t < 0) n = n1; else { n -= ++n1; K += n1; } } while(n > 0); return -1; } /* in_vector */ int #ifdef KR_headers is_negatable(Const) Constp Const; #else is_negatable(Constp Const) #endif { int retval = 0; if (Const != (Constp) NULL) switch (Const -> vtype) { case TYINT1: retval = Const -> Const.ci >= -BIGGEST_CHAR; break; case TYSHORT: retval = Const -> Const.ci >= -BIGGEST_SHORT; break; case TYLONG: #ifdef TYQUAD case TYQUAD: #endif retval = Const -> Const.ci >= -BIGGEST_LONG; break; case TYREAL: case TYDREAL: case TYCOMPLEX: case TYDCOMPLEX: retval = 1; break; case TYLOGICAL1: case TYLOGICAL2: case TYLOGICAL: case TYCHAR: case TYSUBR: default: retval = 0; break; } /* switch */ return retval; } /* is_negatable */ void #ifdef KR_headers backup(fname, bname) char *fname; char *bname; #else backup(char *fname, char *bname) #endif { FILE *b, *f; static char couldnt[] = "Couldn't open %.80s"; if (!(f = fopen(fname, binread))) { warn1(couldnt, fname); return; } if (!(b = fopen(bname, binwrite))) { warn1(couldnt, bname); return; } ffilecopy(f, b); fclose(f); fclose(b); } /* struct_eq -- returns YES if structures have the same field names and types, NO otherwise */ int #ifdef KR_headers struct_eq(s1, s2) chainp s1; chainp s2; #else struct_eq(chainp s1, chainp s2) #endif { struct Dimblock *d1, *d2; Constp cp1, cp2; if (s1 == CHNULL && s2 == CHNULL) return YES; for(; s1 && s2; s1 = s1->nextp, s2 = s2->nextp) { register Namep v1 = (Namep) s1 -> datap; register Namep v2 = (Namep) s2 -> datap; if (v1 == (Namep) NULL || v1 -> tag != TNAME || v2 == (Namep) NULL || v2 -> tag != TNAME) return NO; if (v1->vtype != v2->vtype || v1->vclass != v2->vclass || strcmp(v1->fvarname, v2->fvarname)) return NO; /* compare dimensions (needed for comparing COMMON blocks) */ if (d1 = v1->vdim) { if (!(cp1 = (Constp)d1->nelt) || cp1->tag != TCONST || !(d2 = v2->vdim) || !(cp2 = (Constp)d2->nelt) || cp2->tag != TCONST || cp1->Const.ci != cp2->Const.ci) return NO; } else if (v2->vdim) return NO; } /* while s1 != CHNULL && s2 != CHNULL */ return s1 == CHNULL && s2 == CHNULL; } /* struct_eq */ static int #ifdef KR_headers int_trunc(n0, s0) int n0; char *s0; #else int_trunc(int n0, char *s0) #endif { char buff[100]; if (n0 > 60) n0 = 60; sprintf(buff, "integer constant %.*s truncated.", n0, s0); err(buff); return 1; } tagptr #ifdef KR_headers mkintqcon(n, s) int n; char *s; #else mkintqcon(int n, char *s) #endif { #ifdef NO_LONG_LONG return mkintcon(convci(n, s)); #else #ifndef LLONG_MAX #ifdef LONGLONG_MAX #define LLONG_MAX LONGLONG_MAX #else #define LLONG_MAX 0x7fffffffffffffffLL #endif #endif Constp p; Llong sum, t; char *s0; int n0, warned = 0; s0 = s; n0 = n; sum = 0; while(n-- > 0) { /* sum = 10*sum + (*s++ - '0'); */ t = *s++ - '0'; if (sum > LLONG_MAX/10) { ovfl: warned = int_trunc(n0,s0); sum = LLONG_MAX; break; } sum *= 10; if (sum > LLONG_MAX - t) goto ovfl; sum += t; } p = mkconst(tyint); if (sum > LONG_MAX) { if (allow_i8c) { p->vtype = TYQUAD; p->Const.cq = sum; } else { p->Const.ci = LONG_MAX; if (!warned) int_trunc(n0,s0); } } else p->Const.ci = (ftnint) sum; return (tagptr)p; #endif } f2c/src/mkfile.plan9000066400000000000000000000065511171647030000145410ustar00rootroot00000000000000# Plan 9 mkfile for f2c, a Fortran 77 to C converter gram.in $YACC $YFLAGS gram.in @echo "(There should be 4 shift/reduce conflicts.)" sed 's/^# line.*/\/* & *\//' y.tab.c >gram.c rm -f gram.in y.tab.c $OBJECTSd: defs.h ftypes.h defines.h machdefs.h sysdep.h tokdefs.h: tokens grep -n . tokdefs.h cds.$O: sysdep.h exec.$O: p1defs.h names.h expr.$O: output.h niceprintf.h names.h format.$O: p1defs.h format.h output.h niceprintf.h names.h iob.h formatdata.$O: format.h output.h niceprintf.h names.h gram.$O: p1defs.h init.$O: output.h niceprintf.h iob.h intr.$O: names.h io.$O: names.h iob.h lex.$O : tokdefs.h p1defs.h main.$O: parse.h usignal.h mem.$O: iob.h names.$O: iob.h names.h output.h niceprintf.h niceprintf.$O: defs.h names.h output.h niceprintf.h output.$O: output.h niceprintf.h names.h p1output.$O: p1defs.h output.h niceprintf.h names.h parse_args.$O: parse.h proc.$O: tokdefs.h names.h niceprintf.h output.h p1defs.h put.$O: names.h pccdefs.h p1defs.h putpcc.$O: names.h vax.$O: defs.h output.h pccdefs.h output.h: niceprintf.h put.$O putpcc.$O: pccdefs.h f2c.t: f2c.1t troff -man f2c.1t >f2c.t #f2c.1: f2c.1t # nroff -man f2c.1t | col -b | uniq >f2c.1 clean: rm -f *.$O f2c tokdefs.h f2c.t veryclean: clean rm -f xsum b = 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 \ malloc.c mem.c memset.c misc.c 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 tokens usignal.h vax.c version.c xsum.c xsum: xsum.c $CC $CFLAGS -o xsum xsum.c #Check validity of transmitted source... xsum.out: xsum $b ./xsum $b >xsum1.out cmp xsum0.out xsum1.out && mv xsum1.out xsum.out #On non-Unix systems that end lines with carriage-return/newline pairs, #use "make xsumr.out" rather than "make xsum.out". The -r flag ignores #carriage-return characters. xsumr.out: xsum $b ./xsum -r $b >xsum1.out cmp xsum0.out xsum1.out && mv xsum1.out xsumr.out f2c/src/names.c000066400000000000000000000520611171647030000135710ustar00rootroot00000000000000/**************************************************************** Copyright 1990, 1992 - 1996, 2000 by AT&T, Lucent Technologies and Bellcore. Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the above copyright notice appear in all copies and that both that the copyright notice and this permission notice and warranty disclaimer appear in supporting documentation, and that the names of AT&T, Bell Laboratories, Lucent or Bellcore or any of their entities not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. AT&T, Lucent and Bellcore disclaim all warranties with regard to this software, including all implied warranties of merchantability and fitness. In no event shall AT&T, Lucent or Bellcore be liable for any special, indirect or consequential damages or any damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortious action, arising out of or in connection with the use or performance of this software. ****************************************************************/ #include "defs.h" #include "output.h" #include "names.h" #include "iob.h" /* Names generated by the translator are guaranteed to be unique from the Fortan names because Fortran does not allow underscores in identifiers, and all of the system generated names do have underscores. The various naming conventions are outlined below: FORMAT APPLICATION ---------------------------------------------------------------------- io_# temporaries generated by IO calls; these will contain the device number (e.g. 5, 6, 0) ret_val function return value, required for complex and character functions. ret_val_len length of the return value in character functions ssss_len length of character argument "ssss" c_# member of the literal pool, where # is an arbitrary label assigned by the system cs_# short integer constant in the literal pool t_# expression temporary, # is the depth of arguments on the stack. L# label "#", given by user in the Fortran program. This is unique because Fortran labels are numeric pad_# label on an init field required for alignment xxx_init label on a common block union, if a block data requires a separate declaration */ /* generate variable references */ char * #ifdef KR_headers c_type_decl(type, is_extern) int type; int is_extern; #else c_type_decl(int type, int is_extern) #endif { static char buff[100]; switch (type) { case TYREAL: if (!is_extern || !forcedouble) { strcpy (buff, "real");break; } case TYDREAL: strcpy (buff, "doublereal"); break; case TYCOMPLEX: if (is_extern) strcpy (buff, "/* Complex */ VOID"); else strcpy (buff, "complex"); break; case TYDCOMPLEX:if (is_extern) strcpy (buff, "/* Double Complex */ VOID"); else strcpy (buff, "doublecomplex"); break; case TYADDR: case TYINT1: case TYSHORT: case TYLONG: #ifdef TYQUAD case TYQUAD: #endif case TYLOGICAL1: case TYLOGICAL2: case TYLOGICAL: strcpy(buff, Typename[type]); break; case TYCHAR: if (is_extern) strcpy (buff, "/* Character */ VOID"); else strcpy (buff, "char"); break; case TYUNKNOWN: strcpy (buff, "UNKNOWN"); /* If a procedure's type is unknown, assume it's a subroutine */ if (!is_extern) break; /* Subroutines must return an INT, because they might return a label value. Even if one doesn't, the caller will EXPECT it to. */ case TYSUBR: strcpy (buff, "/* Subroutine */ int"); break; case TYERROR: strcpy (buff, "ERROR"); break; case TYVOID: strcpy (buff, "void"); break; case TYCILIST: strcpy (buff, "cilist"); break; case TYICILIST: strcpy (buff, "icilist"); break; case TYOLIST: strcpy (buff, "olist"); break; case TYCLLIST: strcpy (buff, "cllist"); break; case TYALIST: strcpy (buff, "alist"); break; case TYINLIST: strcpy (buff, "inlist"); break; case TYFTNLEN: strcpy (buff, "ftnlen"); break; default: sprintf (buff, "BAD DECL '%d'", type); break; } /* switch */ return buff; } /* c_type_decl */ char * new_func_length(Void) { return "ret_val_len"; } char * #ifdef KR_headers new_arg_length(arg) Namep arg; #else new_arg_length(Namep arg) #endif { static char buf[64]; char *fmt = "%s_len", *s = arg->fvarname; switch(*s) { case 'r': if (!strcmp(s+1, "et_val")) goto adjust_fmt; break; case 'h': case 'i': if (!s[1]) { adjust_fmt: fmt = "%s_length"; /* avoid conflict with libF77 */ } } sprintf (buf, fmt, s); return buf; } /* new_arg_length */ /* declare_new_addr -- Add a new local variable to the function, given a pointer to an Addrblock structure (which must have the uname_tag set) This list of idents will be printed in reverse (i.e., chronological) order */ void #ifdef KR_headers declare_new_addr(addrp) struct Addrblock *addrp; #else declare_new_addr(struct Addrblock *addrp) #endif { extern chainp new_vars; new_vars = mkchain((char *)cpexpr((expptr)addrp), new_vars); } /* declare_new_addr */ void #ifdef KR_headers wr_nv_ident_help(outfile, addrp) FILE *outfile; struct Addrblock *addrp; #else wr_nv_ident_help(FILE *outfile, struct Addrblock *addrp) #endif { int eltcount = 0; if (addrp == (struct Addrblock *) NULL) return; if (addrp -> isarray) { frexpr (addrp -> memoffset); addrp -> memoffset = ICON(0); eltcount = addrp -> ntempelt; addrp -> ntempelt = 0; addrp -> isarray = 0; } /* if */ out_addr (outfile, addrp); if (eltcount) nice_printf (outfile, "[%d]", eltcount); } /* wr_nv_ident_help */ int #ifdef KR_headers nv_type_help(addrp) struct Addrblock *addrp; #else nv_type_help(struct Addrblock *addrp) #endif { if (addrp == (struct Addrblock *) NULL) return -1; return addrp -> vtype; } /* nv_type_help */ /* lit_name -- returns a unique identifier for the given literal. Make the label useful, when possible. For example: 1 -> c_1 (constant 1) 2 -> c_2 (constant 2) 1000 -> c_1000 (constant 1000) 1000000 -> c_b (big constant number) 1.2 -> c_1_2 (constant 1.2) 1.234345 -> c_b (big constant number) -1 -> c_n1 (constant -1) -1.0 -> c_n1_0 (constant -1.0) .true. -> c_true (constant true) .false. -> c_false (constant false) default -> c_b (default label) */ char * #ifdef KR_headers lit_name(litp) struct Literal *litp; #else lit_name(struct Literal *litp) #endif { static char buf[CONST_IDENT_MAX]; ftnint val; char *fmt; if (litp == (struct Literal *) NULL) return NULL; switch (litp -> littype) { case TYINT1: val = litp -> litval.litival; if (val >= 256 || val < -255) sprintf (buf, "ci1_b%ld", litp -> litnum); else if (val < 0) sprintf (buf, "ci1_n%ld", -val); else sprintf(buf, "ci1__%ld", val); break; case TYSHORT: val = litp -> litval.litival; if (val >= 32768 || val <= -32769) sprintf (buf, "cs_b%ld", litp -> litnum); else if (val < 0) sprintf (buf, "cs_n%ld", -val); else sprintf (buf, "cs__%ld", val); break; case TYLONG: #ifdef TYQUAD case TYQUAD: #endif val = litp -> litval.litival; if (val >= 100000 || val <= -10000) sprintf (buf, "c_b%ld", litp -> litnum); else if (val < 0) sprintf (buf, "c_n%ld", -val); else sprintf (buf, "c__%ld", val); break; case TYLOGICAL1: fmt = "cl1_%s"; goto spr_logical; case TYLOGICAL2: fmt = "cl2_%s"; goto spr_logical; case TYLOGICAL: fmt = "c_%s"; spr_logical: sprintf (buf, fmt, (litp -> litval.litival ? "true" : "false")); break; case TYREAL: case TYDREAL: /* Given a limit of 6 or 8 character on external names, */ /* few f.p. values can be meaningfully encoded in the */ /* constant name. Just going with the default cb_# */ /* seems to be the best course for floating-point */ /* constants. */ case TYCHAR: /* Shouldn't be any of these */ case TYADDR: case TYCOMPLEX: case TYDCOMPLEX: case TYSUBR: default: sprintf (buf, "c_b%ld", litp -> litnum); } /* switch */ return buf; } /* lit_name */ char * #ifdef KR_headers comm_union_name(count) int count; #else comm_union_name(int count) #endif { static char buf[12]; sprintf(buf, "%d", count); return buf; } /* wr_globals -- after every function has been translated, we need to output the global declarations, such as the static table of constant values */ void #ifdef KR_headers wr_globals(outfile) FILE *outfile; #else wr_globals(FILE *outfile) #endif { struct Literal *litp, *lastlit; extern int hsize; char *litname; int did_one, t; struct Constblock cb; ftnint x, y; if (nliterals == 0) return; lastlit = litpool + nliterals; did_one = 0; for (litp = litpool; litp < lastlit; litp++) { if (!litp->lituse) continue; litname = lit_name(litp); if (!did_one) { margin_printf(outfile, "/* Table of constant values */\n\n"); did_one = 1; } cb.vtype = litp->littype; if (litp->littype == TYCHAR) { x = litp->litval.litival2[0] + litp->litval.litival2[1]; if (y = x % hsize) x += y = hsize - y; nice_printf(outfile, "static struct { %s fill; char val[%ld+1];", halign, x); nice_printf(outfile, " char fill2[%ld];", hsize - 1); nice_printf(outfile, " } %s_st = { 0,", litname); cb.vleng = ICON(litp->litval.litival2[0]); cb.Const.ccp = litp->cds[0]; cb.Const.ccp1.blanks = litp->litval.litival2[1] + y; cb.vtype = TYCHAR; out_const(outfile, &cb); frexpr(cb.vleng); nice_printf(outfile, " };\n"); nice_printf(outfile, "#define %s %s_st.val\n", litname, litname); continue; } nice_printf(outfile, "static %s %s = ", c_type_decl(litp->littype,0), litname); t = litp->littype; if (ONEOF(t, MSKREAL|MSKCOMPLEX)) { cb.vstg = 1; cb.Const.cds[0] = litp->cds[0]; cb.Const.cds[1] = litp->cds[1]; } else { memcpy((char *)&cb.Const, (char *)&litp->litval, sizeof(cb.Const)); cb.vstg = 0; } out_const(outfile, &cb); nice_printf (outfile, ";\n"); } /* for */ if (did_one) nice_printf (outfile, "\n"); } /* wr_globals */ ftnint #ifdef KR_headers commlen(vl) register chainp vl; #else commlen(register chainp vl) #endif { ftnint size; int type; struct Dimblock *t; Namep v; while(vl->nextp) vl = vl->nextp; v = (Namep)vl->datap; type = v->vtype; if (type == TYCHAR) size = v->vleng->constblock.Const.ci; else size = typesize[type]; if ((t = v->vdim) && ISCONST(t->nelt)) size *= t->nelt->constblock.Const.ci; return size + v->voffset; } static void /* Pad common block if an EQUIVALENCE extended it. */ #ifdef KR_headers pad_common(c) Extsym *c; #else pad_common(Extsym *c) #endif { register chainp cvl; register Namep v; long L = c->maxleng; int type; struct Dimblock *t; int szshort = typesize[TYSHORT]; for(cvl = c->allextp; cvl; cvl = cvl->nextp) if (commlen((chainp)cvl->datap) >= L) return; v = ALLOC(Nameblock); v->vtype = type = L % szshort ? TYCHAR : type_choice[L/szshort % 4]; v->vstg = STGCOMMON; v->vclass = CLVAR; v->tag = TNAME; v->vdim = t = ALLOC(Dimblock); t->ndim = 1; t->dims[0].dimsize = ICON(L / typesize[type]); v->fvarname = v->cvarname = "eqv_pad"; if (type == TYCHAR) v->vleng = ICON(1); c->allextp = mkchain((char *)mkchain((char *)v, CHNULL), c->allextp); } /* wr_common_decls -- outputs the common declarations in one of three formats. If all references to a common block look the same (field names and types agree), only one actual declaration will appear. Otherwise, the same block will require many structs. If there is no block data, these structs will be union'ed together (so the linker knows the size of the largest one). If there IS a block data, only that version will be associated with the variable, others will only be defined as types, so the pointer can be cast to it. e.g. FORTRAN C ---------------------------------------------------------------------- common /com1/ a, b, c struct { real a, b, c; } com1_; common /com1/ a, b, c union { common /com1/ i, j, k struct { real a, b, c; } _1; struct { integer i, j, k; } _2; } com1_; common /com1/ a, b, c struct com1_1_ { real a, b, c; }; block data struct { integer i, j, k; } com1_ = common /com1/ i, j, k { 1, 2, 3 }; data i/1/, j/2/, k/3/ All of these versions will be followed by #defines, since the code in the function bodies can't know ahead of time which of these options will be taken */ /* Macros for deciding the output type */ #define ONE_STRUCT 1 #define UNION_STRUCT 2 #define INIT_STRUCT 3 void #ifdef KR_headers wr_common_decls(outfile) FILE *outfile; #else wr_common_decls(FILE *outfile) #endif { Extsym *ext; extern int extcomm; static char *Extern[4] = {"", "Extern ", "extern "}; char *E, *E0 = Extern[extcomm]; int did_one = 0; for (ext = extsymtab; ext < nextext; ext++) { if (ext -> extstg == STGCOMMON && ext->allextp) { chainp comm; int count = 1; int which; /* which display to use; ONE_STRUCT, UNION or INIT */ if (!did_one) nice_printf (outfile, "/* Common Block Declarations */\n\n"); pad_common(ext); /* Construct the proper, condensed list of structs; eliminate duplicates from the initial list ext -> allextp */ comm = ext->allextp = revchain(ext->allextp); if (ext -> extinit) which = INIT_STRUCT; else if (comm->nextp) { which = UNION_STRUCT; nice_printf (outfile, "%sunion {\n", E0); next_tab (outfile); E = ""; } else { which = ONE_STRUCT; E = E0; } for (; comm; comm = comm -> nextp, count++) { if (which == INIT_STRUCT) nice_printf (outfile, "struct %s%d_ {\n", ext->cextname, count); else nice_printf (outfile, "%sstruct {\n", E); next_tab (c_file); wr_struct (outfile, (chainp) comm -> datap); prev_tab (c_file); if (which == UNION_STRUCT) nice_printf (outfile, "} _%d;\n", count); else if (which == ONE_STRUCT) nice_printf (outfile, "} %s;\n", ext->cextname); else nice_printf (outfile, "};\n"); } /* for */ if (which == UNION_STRUCT) { prev_tab (c_file); nice_printf (outfile, "} %s;\n", ext->cextname); } /* if */ did_one = 1; nice_printf (outfile, "\n"); for (count = 1, comm = ext -> allextp; comm; comm = comm -> nextp, count++) { def_start(outfile, ext->cextname, comm_union_name(count), ""); switch (which) { case ONE_STRUCT: extern_out (outfile, ext); break; case UNION_STRUCT: nice_printf (outfile, "("); extern_out (outfile, ext); nice_printf(outfile, "._%d)", count); break; case INIT_STRUCT: nice_printf (outfile, "(*(struct "); extern_out (outfile, ext); nice_printf (outfile, "%d_ *) &", count); extern_out (outfile, ext); nice_printf (outfile, ")"); break; } /* switch */ nice_printf (outfile, "\n"); } /* for count = 1, comm = ext -> allextp */ nice_printf (outfile, "\n"); } /* if ext -> extstg == STGCOMMON */ } /* for ext = extsymtab */ } /* wr_common_decls */ void #ifdef KR_headers wr_struct(outfile, var_list) FILE *outfile; chainp var_list; #else wr_struct(FILE *outfile, chainp var_list) #endif { int last_type = -1; int did_one = 0; chainp this_var; for (this_var = var_list; this_var; this_var = this_var -> nextp) { Namep var = (Namep) this_var -> datap; int type; char *comment = NULL; if (var == (Namep) NULL) err ("wr_struct: null variable"); else if (var -> tag != TNAME) erri ("wr_struct: bad tag on variable '%d'", var -> tag); type = var -> vtype; if (last_type == type && did_one) nice_printf (outfile, ", "); else { if (did_one) nice_printf (outfile, ";\n"); nice_printf (outfile, "%s ", c_type_decl (type, var -> vclass == CLPROC)); } /* else */ /* Character type is really a string type. Put out a '*' for parameters with unknown length and functions returning character */ if (var -> vtype == TYCHAR && (!ISICON ((var -> vleng)) || var -> vclass == CLPROC)) nice_printf (outfile, "*"); var -> vstg = STGAUTO; out_name (outfile, var); if (var -> vclass == CLPROC) nice_printf (outfile, "()"); else if (var -> vdim) comment = wr_ardecls(outfile, var->vdim, var->vtype == TYCHAR && ISICON(var->vleng) ? var->vleng->constblock.Const.ci : 1L); else if (var -> vtype == TYCHAR && var -> vclass != CLPROC && ISICON ((var -> vleng))) nice_printf (outfile, "[%ld]", var -> vleng -> constblock.Const.ci); if (comment) nice_printf (outfile, "%s", comment); did_one = 1; last_type = type; } /* for this_var */ if (did_one) nice_printf (outfile, ";\n"); } /* wr_struct */ char * #ifdef KR_headers user_label(stateno) ftnint stateno; #else user_label(ftnint stateno) #endif { static char buf[USER_LABEL_MAX + 1]; static char *Lfmt[2] = { "L_%ld", "L%ld" }; if (stateno >= 0) sprintf(buf, Lfmt[shiftcase], stateno); else sprintf(buf, "L_%s", extsymtab[-1-stateno].fextname); return buf; } /* user_label */ char * #ifdef KR_headers temp_name(starter, num, storage) char *starter; int num; char *storage; #else temp_name(char *starter, int num, char *storage) #endif { static char buf[IDENT_LEN]; char *pointer = buf; char *prefix = "t"; if (storage) pointer = storage; if (starter && *starter) prefix = starter; sprintf (pointer, "%s__%d", prefix, num); return pointer; } /* temp_name */ char * #ifdef KR_headers equiv_name(memno, store) int memno; char *store; #else equiv_name(int memno, char *store) #endif { static char buf[IDENT_LEN]; char *pointer = buf; if (store) pointer = store; sprintf (pointer, "%s_%d", EQUIV_INIT_NAME, memno); return pointer; } /* equiv_name */ void #ifdef KR_headers def_commons(of) FILE *of; #else def_commons(FILE *of) #endif { Extsym *ext; int c, onefile, Union; chainp comm; extern int ext1comm; FILE *c_filesave = c_file; if (ext1comm == 1) { onefile = 1; c_file = of; fprintf(of, "/*>>>'/dev/null'<<<*/\n\ #ifdef Define_COMMONs\n\ /*<<>>*/\n"); } else onefile = 0; for(ext = extsymtab; ext < nextext; ext++) if (ext->extstg == STGCOMMON && !ext->extinit && (comm = ext->allextp)) { sprintf(outbtail, "%scom.c", ext->cextname); if (onefile) fprintf(of, "/*>>>'%s'<<<*/\n", outbtail); else { c_file = of = fopen(outbuf,textwrite); if (!of) fatalstr("can't open %s", outbuf); } fprintf(of, "#include \"f2c.h\"\n"); if (Ansi == 2) fprintf(of, "\n#ifdef __cplusplus\nextern \"C\" {\n#endif\n\n"); if (comm->nextp) { Union = 1; nice_printf(of, "union {\n"); next_tab(of); } else Union = 0; for(c = 1; comm; comm = comm->nextp) { nice_printf(of, "struct {\n"); next_tab(of); wr_struct(of, (chainp)comm->datap); prev_tab(of); if (Union) nice_printf(of, "} _%d;\n", c++); } if (Union) prev_tab(of); nice_printf(of, "} %s;\n", ext->cextname); if (Ansi == 2) fprintf(of, "\n#ifdef __cplusplus\n}\n#endif\n"); if (onefile) fprintf(of, "/*<<<%s>>>*/\n", outbtail); else fclose(of); } if (onefile) fprintf(of, "/*>>>'/dev/null'<<<*/\n#endif\n\ /*<<>>*/\n"); c_file = c_filesave; } /* C Language keywords. Needed to filter unwanted fortran identifiers like * "int", etc. Source: Kernighan & Ritchie, eds. 1 and 2; Stroustrup. * Also includes C++ keywords and types used for I/O in f2c.h . * These keywords must be in alphabetical order (as defined by strcmp()). */ char *c_keywords[] = { "Long", "Multitype", "Namelist", "Vardesc", "abs", "acos", "addr", "address", "aerr", "alist", "asin", "asm", "atan", "atan2", "aunit", "auto", "break", "c", "case", "catch", "cdecl", "cerr", "char", "ciend", "cierr", "cifmt", "cilist", "cirec", "ciunit", "class", "cllist", "complex", "const", "continue", "cos", "cosh", "csta", "cunit", "d", "dabs", "default", "defined", "delete", "dims", "dmax", "dmin", "do", "double", "doublecomplex", "doublereal", "else", "entry", "enum", "exp", "extern", "false", "far", "flag", "float", "for", "friend", "ftnint", "ftnlen", "goto", "h", "huge", "i", "iciend", "icierr", "icifmt", "icilist", "icirlen", "icirnum", "iciunit", "if", "inacc", "inacclen", "inblank", "inblanklen", "include", "indir", "indirlen", "inerr", "inex", "infile", "infilen", "infmt", "infmtlen", "inform", "informlen", "inline", "inlist", "inname", "innamed", "innamlen", "innrec", "innum", "inopen", "inrecl", "inseq", "inseqlen", "int", "integer", "integer1", "inunf", "inunflen", "inunit", "log", "logical", "logical1", "long", "longint", "max", "min", "name", "near", "new", "nvars", "oacc", "oblnk", "oerr", "ofm", "ofnm", "ofnmlen", "olist", "operator", "orl", "osta", "ounit", "overload", "private", "protected", "public", "r", "real", "register", "return", "short", "shortint", "shortlogical", "signed", "sin", "sinh", "sizeof", "sqrt", "static", "struct", "switch", "tan", "tanh", "template", "this", "true", "try", "type", "typedef", "uinteger", "ulongint", "union", "unsigned", "vars", "virtual", "void", "volatile", "while", "z" }; /* c_keywords */ int n_keywords = sizeof(c_keywords)/sizeof(char *); f2c/src/names.h000066400000000000000000000010711171647030000135710ustar00rootroot00000000000000#define CONST_IDENT_MAX 30 #define IO_IDENT_MAX 30 #define ARGUMENT_MAX 30 #define USER_LABEL_MAX 30 #define EQUIV_INIT_NAME "equiv" #define write_nv_ident(fp,a) wr_nv_ident_help ((fp), (struct Addrblock *) (a)) #define nv_type(x) nv_type_help ((struct Addrblock *) x) extern char *c_keywords[]; char* c_type_decl Argdcl((int, int)); void declare_new_addr Argdcl((Addrp)); char* new_arg_length Argdcl((Namep)); char* new_func_length Argdcl((void)); int nv_type_help Argdcl((Addrp)); char* temp_name Argdcl((char*, int, char*)); char* user_label Argdcl((long int)); f2c/src/niceprintf.c000066400000000000000000000253061171647030000146310ustar00rootroot00000000000000/**************************************************************** Copyright 1990, 1991, 1993, 1994, 2000 by AT&T, Lucent Technologies and Bellcore. Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the above copyright notice appear in all copies and that both that the copyright notice and this permission notice and warranty disclaimer appear in supporting documentation, and that the names of AT&T, Bell Laboratories, Lucent or Bellcore or any of their entities not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. AT&T, Lucent and Bellcore disclaim all warranties with regard to this software, including all implied warranties of merchantability and fitness. In no event shall AT&T, Lucent or Bellcore be liable for any special, indirect or consequential damages or any damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortious action, arising out of or in connection with the use or performance of this software. ****************************************************************/ #include "defs.h" #include "names.h" #include "output.h" #ifndef KR_headers #include "stdarg.h" #endif #define TOO_LONG_INDENT (2 * tab_size) #define MAX_INDENT 44 #define MIN_INDENT 22 static int last_was_newline = 0; int sharp_line = 0; int indent = 0; int in_comment = 0; int in_define = 0; extern int gflag1; extern char filename[]; static void ind_printf Argdcl((int, FILE*, const char*, va_list)); static void #ifdef KR_headers write_indent(fp, use_indent, extra_indent, start, end) FILE *fp; int use_indent; int extra_indent; char *start; char *end; #else write_indent(FILE *fp, int use_indent, int extra_indent, char *start, char *end) #endif { int ind, tab; if (sharp_line) { fprintf(fp, "#line %ld \"%s\"\n", lineno, filename); sharp_line = 0; } if (in_define == 1) { in_define = 2; use_indent = 0; } if (last_was_newline && use_indent) { if (*start == '\n') do { putc('\n', fp); if (++start > end) return; } while(*start == '\n'); ind = indent <= MAX_INDENT ? indent : MIN_INDENT + indent % (MAX_INDENT - MIN_INDENT); tab = ind + extra_indent; while (tab > 7) { putc ('\t', fp); tab -= 8; } /* while */ while (tab-- > 0) putc (' ', fp); } /* if last_was_newline */ while (start <= end) putc (*start++, fp); } /* write_indent */ #ifdef KR_headers /*VARARGS2*/ void margin_printf (fp, a, b, c, d, e, f, g) FILE *fp; char *a; long b, c, d, e, f, g; { ind_printf (0, fp, a, b, c, d, e, f, g); } /* margin_printf */ /*VARARGS2*/ void nice_printf (fp, a, b, c, d, e, f, g) FILE *fp; char *a; long b, c, d, e, f, g; { ind_printf (1, fp, a, b, c, d, e, f, g); } /* nice_printf */ #define SPRINTF(x,a,b,c,d,e,f,g) sprintf(x,a,b,c,d,e,f,g) #else /* if (!defined(KR_HEADERS)) */ #define SPRINTF(x,a,b,c,d,e,f,g) vsprintf(x,a,ap) void margin_printf(FILE *fp, const char *fmt, ...) { va_list ap; va_start(ap,fmt); ind_printf(0, fp, fmt, ap); va_end(ap); } void nice_printf(FILE *fp, const char *fmt, ...) { va_list ap; va_start(ap,fmt); ind_printf(1, fp, fmt, ap); va_end(ap); } #endif #define max_line_len c_output_line_length /* 74Number of characters allowed on an output line. This assumes newlines are handled nicely, i.e. a newline after a full text line on a terminal is ignored */ /* output_buf holds the text of the next line to be printed. It gets flushed when a newline is printed. next_slot points to the next available location in the output buffer, i.e. where the next call to nice_printf will have its output stored */ static char *output_buf; static char *next_slot; static char *string_start; static char *word_start = NULL; static int cursor_pos = 0; static int In_string = 0; void np_init(Void) { next_slot = output_buf = Alloc(MAX_OUTPUT_SIZE); memset(output_buf, 0, MAX_OUTPUT_SIZE); } static char * #ifdef KR_headers adjust_pointer_in_string(pointer) register char *pointer; #else adjust_pointer_in_string(register char *pointer) #endif { register char *s, *s1, *se, *s0; /* arrange not to break \002 */ s1 = string_start ? string_start : output_buf; for(s = s1; s < pointer; s++) { s0 = s1; s1 = s; if (*s == '\\') { se = s++ + 4; if (se > pointer) break; if (*s < '0' || *s > '7') continue; while(++s < se) if (*s < '0' || *s > '7') break; --s; } } return s0 - 1; } /* ANSI says strcpy's behavior is undefined for overlapping args, * so we roll our own fwd_strcpy: */ static void #ifdef KR_headers fwd_strcpy(t, s) register char *t; register char *s; #else fwd_strcpy(register char *t, register char *s) #endif { while(*t++ = *s++); } /* isident -- true iff character could belong to a unit. C allows letters, numbers and underscores in identifiers. This also doubles as a check for numeric constants, since we include the decimal point and minus sign. The minus has to be here, since the constant "10e-2" cannot be broken up. The '.' also prevents structure references from being broken, which is a quite acceptable side effect */ #define isident(x) (Tr[x] & 1) #define isntident(x) (!Tr[x]) static void #ifdef KR_headers ind_printf (use_indent, fp, a, b, c, d, e, f, g) int use_indent; FILE *fp; char *a; long b, c, d, e, f, g; #else ind_printf (int use_indent, FILE *fp, const char *a, va_list ap) #endif { extern int max_line_len; extern FILEP c_file; extern char tr_tab[]; /* in output.c */ register char *Tr = tr_tab; int ch, cmax, inc, ind; static int extra_indent, last_indent, set_cursor = 1; cursor_pos += indent - last_indent; last_indent = indent; SPRINTF (next_slot, a, b, c, d, e, f, g); if (fp != c_file) { fprintf (fp,"%s", next_slot); return; } /* if fp != c_file */ do { char *pointer; /* The for loop will parse one output line */ if (set_cursor) { ind = indent <= MAX_INDENT ? indent : MIN_INDENT + indent % (MAX_INDENT - MIN_INDENT); cursor_pos = extra_indent; if (use_indent) cursor_pos += ind; set_cursor = 0; } if (in_comment) { cmax = max_line_len + 32; /* let comments be wider */ for (pointer = next_slot; *pointer && *pointer != '\n' && cursor_pos <= cmax; pointer++) cursor_pos++; } else for (pointer = next_slot; *pointer && *pointer != '\n' && cursor_pos <= max_line_len; pointer++) { /* Update state variables here */ if (In_string) { switch(*pointer) { case '\\': if (++cursor_pos > max_line_len) { cursor_pos -= 2; --pointer; goto overflow; } ++pointer; break; case '"': In_string = 0; word_start = 0; } } else switch (*pointer) { case '"': if (cursor_pos + 5 > max_line_len) { word_start = 0; --pointer; goto overflow; } In_string = 1; string_start = word_start = pointer; break; case '\'': if (pointer[1] == '\\') if ((ch = pointer[2]) >= '0' && ch <= '7') for(inc = 3; pointer[inc] != '\'' && ++inc < 5;); else inc = 3; else inc = 2; /*debug*/ if (pointer[inc] != '\'') /*debug*/ fatalstr("Bad character constant %.10s", pointer); if ((cursor_pos += inc) > max_line_len) { cursor_pos -= inc; word_start = 0; --pointer; goto overflow; } word_start = pointer; pointer += inc; break; case '\t': cursor_pos = 8 * ((cursor_pos + 8) / 8) - 1; break; default: { /* HACK Assumes that all characters in an atomic C token will be written at the same time. Must check for tokens first, since '-' is considered part of an identifier; checking isident first would mean breaking up "->" */ if (word_start) { if (isntident(*(unsigned char *)pointer)) word_start = NULL; } else if (isident(*(unsigned char *)pointer)) word_start = pointer; break; } /* default */ } /* switch */ cursor_pos++; } /* for pointer = next_slot */ overflow: if (*pointer == '\0') { /* The output line is not complete, so break out and don't output anything. The current line fragment will be stored in the buffer */ next_slot = pointer; break; } else { char last_char; int in_string0 = In_string; /* If the line was too long, move pointer back to the character before the current word. This allows line breaking on word boundaries. Make sure that 80 character comment lines get broken up somehow. We assume that any non-string 80 character identifier must be in a comment. */ if (*pointer == '\n') in_define = 0; else if (word_start && word_start > output_buf) if (In_string) if (string_start && pointer - string_start < 5) pointer = string_start - 1; else { pointer = adjust_pointer_in_string(pointer); string_start = 0; } else if (word_start == string_start && pointer - string_start >= 5) { pointer = adjust_pointer_in_string(next_slot); In_string = 1; string_start = 0; } else pointer = word_start - 1; else if (cursor_pos > max_line_len) { #ifndef ANSI_Libraries extern char *strchr(); #endif if (In_string) { pointer = adjust_pointer_in_string(pointer); if (string_start && pointer > string_start) string_start = 0; } else if (strchr("&*+-/<=>|", *pointer) && strchr("!%&*+-/<=>^|", pointer[-1])) { pointer -= 2; if (strchr("<>", *pointer)) /* <<=, >>= */ pointer--; } else { if (word_start) while(isident(*(unsigned char *)pointer)) pointer++; pointer--; } } last_char = *pointer; write_indent(fp, use_indent, extra_indent, output_buf, pointer); next_slot = output_buf; if (In_string && !string_start && Ansi == 1 && last_char != '\n') *next_slot++ = '"'; fwd_strcpy(next_slot, pointer + 1); /* insert a line break */ if (last_char == '\n') { if (In_string) last_was_newline = 0; else { last_was_newline = 1; extra_indent = 0; sharp_line = gflag1; } } else { extra_indent = TOO_LONG_INDENT; if (In_string && !string_start) { if (Ansi == 1) { fprintf(fp, gflag1 ? "\"\\\n" : "\"\n"); use_indent = 1; last_was_newline = 1; } else { fprintf(fp, "\\\n"); last_was_newline = 0; } In_string = in_string0; } else { if (in_define/* | gflag1*/) putc('\\', fp); putc ('\n', fp); last_was_newline = 1; } } /* if *pointer != '\n' */ if (In_string && Ansi != 1 && !string_start) cursor_pos = 0; else set_cursor = 1; string_start = word_start = NULL; } /* else */ } while (*next_slot); } /* ind_printf */ f2c/src/niceprintf.h000066400000000000000000000006341171647030000146330ustar00rootroot00000000000000/* niceprintf.h -- contains constants and macros from the output filter for the generated C code. We use macros for increased speed, less function overhead. */ #define MAX_OUTPUT_SIZE 6000 /* Number of chars on one output line PLUS the length of the longest string printed using nice_printf */ #define next_tab(fp) (indent += tab_size) #define prev_tab(fp) (indent -= tab_size) f2c/src/notice000066400000000000000000000022741171647030000135270ustar00rootroot00000000000000/**************************************************************** Copyright 1990 - 1997 by AT&T, Lucent Technologies and Bellcore. Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the above copyright notice appear in all copies and that both that the copyright notice and this permission notice and warranty disclaimer appear in supporting documentation, and that the names of AT&T, Bell Laboratories, Lucent or Bellcore or any of their entities not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. AT&T, Lucent and Bellcore disclaim all warranties with regard to this software, including all implied warranties of merchantability and fitness. In no event shall AT&T, Lucent or Bellcore be liable for any special, indirect or consequential damages or any damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortious action, arising out of or in connection with the use or performance of this software. ****************************************************************/ f2c/src/output.c000066400000000000000000001247331171647030000140340ustar00rootroot00000000000000/**************************************************************** Copyright 1990-1996, 2000-2001 by AT&T, Lucent Technologies and Bellcore. Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the above copyright notice appear in all copies and that both that the copyright notice and this permission notice and warranty disclaimer appear in supporting documentation, and that the names of AT&T, Bell Laboratories, Lucent or Bellcore or any of their entities not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. AT&T, Lucent and Bellcore disclaim all warranties with regard to this software, including all implied warranties of merchantability and fitness. In no event shall AT&T, Lucent or Bellcore be liable for any special, indirect or consequential damages or any damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortious action, arising out of or in connection with the use or performance of this software. ****************************************************************/ #include "defs.h" #include "names.h" #include "output.h" #ifndef TRUE #define TRUE 1 #endif #ifndef FALSE #define FALSE 0 #endif char _assoc_table[] = { 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0 }; /* Opcode table -- This array is indexed by the OP_____ macros defined in defines.h; these macros are expected to be adjacent integers, so that this table is as small as possible. */ table_entry opcode_table[] = { { 0, 0, NULL }, /* OPPLUS 1 */ { BINARY_OP, 12, "%l + %r" }, /* OPMINUS 2 */ { BINARY_OP, 12, "%l - %r" }, /* OPSTAR 3 */ { BINARY_OP, 13, "%l * %r" }, /* OPSLASH 4 */ { BINARY_OP, 13, "%l / %r" }, /* OPPOWER 5 */ { BINARY_OP, 0, "power (%l, %r)" }, /* OPNEG 6 */ { UNARY_OP, 14, "-%l" }, /* OPOR 7 */ { BINARY_OP, 4, "%l || %r" }, /* OPAND 8 */ { BINARY_OP, 5, "%l && %r" }, /* OPEQV 9 */ { BINARY_OP, 9, "%l == %r" }, /* OPNEQV 10 */ { BINARY_OP, 9, "%l != %r" }, /* OPNOT 11 */ { UNARY_OP, 14, "! %l" }, /* OPCONCAT 12 */ { BINARY_OP, 0, "concat (%l, %r)" }, /* OPLT 13 */ { BINARY_OP, 10, "%l < %r" }, /* OPEQ 14 */ { BINARY_OP, 9, "%l == %r" }, /* OPGT 15 */ { BINARY_OP, 10, "%l > %r" }, /* OPLE 16 */ { BINARY_OP, 10, "%l <= %r" }, /* OPNE 17 */ { BINARY_OP, 9, "%l != %r" }, /* OPGE 18 */ { BINARY_OP, 10, "%l >= %r" }, /* OPCALL 19 */ { BINARY_OP, 15, SPECIAL_FMT }, /* OPCCALL 20 */ { BINARY_OP, 15, SPECIAL_FMT }, /* Left hand side of an assignment cannot have outermost parens */ /* OPASSIGN 21 */ { BINARY_OP, 2, "%l = %r" }, /* OPPLUSEQ 22 */ { BINARY_OP, 2, "%l += %r" }, /* OPSTAREQ 23 */ { BINARY_OP, 2, "%l *= %r" }, /* OPCONV 24 */ { BINARY_OP, 14, "%l" }, /* OPLSHIFT 25 */ { BINARY_OP, 11, "%l << %r" }, /* OPMOD 26 */ { BINARY_OP, 13, "%l %% %r" }, /* OPCOMMA 27 */ { BINARY_OP, 1, "%l, %r" }, /* Don't want to nest the colon operator in parens */ /* OPQUEST 28 */ { BINARY_OP, 3, "%l ? %r" }, /* OPCOLON 29 */ { BINARY_OP, 3, "%l : %r" }, /* OPABS 30 */ { UNARY_OP, 0, "abs(%l)" }, /* OPMIN 31 */ { BINARY_OP, 0, SPECIAL_FMT }, /* OPMAX 32 */ { BINARY_OP, 0, SPECIAL_FMT }, /* OPADDR 33 */ { UNARY_OP, 14, "&%l" }, /* OPCOMMA_ARG 34 */ { BINARY_OP, 15, SPECIAL_FMT }, /* OPBITOR 35 */ { BINARY_OP, 6, "%l | %r" }, /* OPBITAND 36 */ { BINARY_OP, 8, "%l & %r" }, /* OPBITXOR 37 */ { BINARY_OP, 7, "%l ^ %r" }, /* OPBITNOT 38 */ { UNARY_OP, 14, "~ %l" }, /* OPRSHIFT 39 */ { BINARY_OP, 11, "%l >> %r" }, /* This isn't quite right -- it doesn't handle arrays, for instance */ /* OPWHATSIN 40 */ { UNARY_OP, 14, "*%l" }, /* OPMINUSEQ 41 */ { BINARY_OP, 2, "%l -= %r" }, /* OPSLASHEQ 42 */ { BINARY_OP, 2, "%l /= %r" }, /* OPMODEQ 43 */ { BINARY_OP, 2, "%l %%= %r" }, /* OPLSHIFTEQ 44 */ { BINARY_OP, 2, "%l <<= %r" }, /* OPRSHIFTEQ 45 */ { BINARY_OP, 2, "%l >>= %r" }, /* OPBITANDEQ 46 */ { BINARY_OP, 2, "%l &= %r" }, /* OPBITXOREQ 47 */ { BINARY_OP, 2, "%l ^= %r" }, /* OPBITOREQ 48 */ { BINARY_OP, 2, "%l |= %r" }, /* OPPREINC 49 */ { UNARY_OP, 14, "++%l" }, /* OPPREDEC 50 */ { UNARY_OP, 14, "--%l" }, /* OPDOT 51 */ { BINARY_OP, 15, "%l.%r" }, /* OPARROW 52 */ { BINARY_OP, 15, "%l -> %r"}, /* OPNEG1 53 */ { UNARY_OP, 14, "-%l" }, /* OPDMIN 54 */ { BINARY_OP, 0, "dmin(%l,%r)" }, /* OPDMAX 55 */ { BINARY_OP, 0, "dmax(%l,%r)" }, /* OPASSIGNI 56 */ { BINARY_OP, 2, "%l = &%r" }, /* OPIDENTITY 57 */ { UNARY_OP, 15, "%l" }, /* OPCHARCAST 58 */ { UNARY_OP, 14, "(char *)&%l" }, /* OPDABS 59 */ { UNARY_OP, 0, "dabs(%l)" }, /* OPMIN2 60 */ { BINARY_OP, 0, "min(%l,%r)" }, /* OPMAX2 61 */ { BINARY_OP, 0, "max(%l,%r)" }, /* OPBITTEST 62 */ { BINARY_OP, 0, "bit_test(%l,%r)" }, /* OPBITCLR 63 */ { BINARY_OP, 0, "bit_clear(%l,%r)" }, /* OPBITSET 64 */ { BINARY_OP, 0, "bit_set(%l,%r)" }, #ifdef TYQUAD /* OPQBITCLR 65 */ { BINARY_OP, 0, "qbit_clear(%l,%r)" }, /* OPQBITSET 66 */ { BINARY_OP, 0, "qbit_set(%l,%r)" }, #endif /* kludge to imitate (under forcedouble) f77's bizarre treatement of OPNEG... */ /* OPNEG KLUDGE */ { UNARY_OP, 14, "-(doublereal)%l" } }; /* opcode_table */ #define OPNEG_KLUDGE (sizeof(opcode_table)/sizeof(table_entry) - 1) extern int dneg, trapuv; static char opeqable[sizeof(opcode_table)/sizeof(table_entry)]; static void output_arg_list Argdcl((FILEP, struct Listblock*)); static void output_binary Argdcl((FILEP, Exprp)); static void output_list Argdcl((FILEP, struct Listblock*)); static void output_literal Argdcl((FILEP, long, Constp)); static void output_prim Argdcl((FILEP, struct Primblock*)); static void output_unary Argdcl((FILEP, Exprp)); void #ifdef KR_headers expr_out(fp, e) FILE *fp; expptr e; #else expr_out(FILE *fp, expptr e) #endif { Namep var; expptr leftp, rightp; int opcode; if (e == (expptr) NULL) return; switch (e -> tag) { case TNAME: out_name (fp, (struct Nameblock *) e); return; case TCONST: out_const(fp, &e->constblock); goto end_out; case TEXPR: break; case TADDR: out_addr (fp, &(e -> addrblock)); goto end_out; case TPRIM: if (!nerr) warn ("expr_out: got TPRIM"); output_prim (fp, &(e -> primblock)); return; case TLIST: output_list (fp, &(e -> listblock)); end_out: frexpr(e); return; case TIMPLDO: err ("expr_out: got TIMPLDO"); return; case TERROR: default: erri ("expr_out: bad tag '%d'", e -> tag); } /* switch */ /* Now we know that the tag is TEXPR */ /* Optimize on simple expressions, such as "a = a + b" ==> "a += b" */ if (e -> exprblock.opcode == OPASSIGN && e -> exprblock.rightp) switch(e->exprblock.rightp->tag) { case TEXPR: opcode = e -> exprblock.rightp -> exprblock.opcode; if (opeqable[opcode]) { if ((leftp = e -> exprblock.leftp) && (rightp = e -> exprblock.rightp -> exprblock.leftp)) { if (same_ident (leftp, rightp)) { expptr temp = e -> exprblock.rightp; e -> exprblock.opcode = op_assign(opcode); e -> exprblock.rightp = temp -> exprblock.rightp; temp->exprblock.rightp = 0; frexpr(temp); } /* if same_ident (leftp, rightp) */ } /* if leftp && rightp */ } /* if opcode == OPPLUS || */ break; case TNAME: if (trapuv) { var = &e->exprblock.rightp->nameblock; if (ISREAL(var->vtype) && var->vclass == CLVAR && ONEOF(var->vstg, M(STGAUTO)|M(STGBSS)) && !var->vsave) { expr_out(fp, e -> exprblock.leftp); nice_printf(fp, " = _0 + "); expr_out(fp, e->exprblock.rightp); goto done; } } } /* if e -> exprblock.opcode == OPASSIGN */ /* Optimize on increment or decrement by 1 */ { opcode = e -> exprblock.opcode; leftp = e -> exprblock.leftp; rightp = e -> exprblock.rightp; if (leftp && rightp && (leftp -> headblock.vstg == STGARG || ISINT (leftp -> headblock.vtype)) && (opcode == OPPLUSEQ || opcode == OPMINUSEQ) && ISINT (rightp -> headblock.vtype) && ISICON (e -> exprblock.rightp) && (ISONE (e -> exprblock.rightp) || e -> exprblock.rightp -> constblock.Const.ci == -1)) { /* Allow for the '-1' constant value */ if (!ISONE (e -> exprblock.rightp)) opcode = (opcode == OPPLUSEQ) ? OPMINUSEQ : OPPLUSEQ; /* replace the existing opcode */ if (opcode == OPPLUSEQ) e -> exprblock.opcode = OPPREINC; else e -> exprblock.opcode = OPPREDEC; /* Free up storage used by the right hand side */ frexpr (e -> exprblock.rightp); e->exprblock.rightp = 0; } /* if opcode == OPPLUS */ } /* block */ if (is_unary_op (e -> exprblock.opcode)) output_unary (fp, &(e -> exprblock)); else if (is_binary_op (e -> exprblock.opcode)) output_binary (fp, &(e -> exprblock)); else erri ("expr_out: bad opcode '%d'", (int) e -> exprblock.opcode); done: free((char *)e); } /* expr_out */ void #ifdef KR_headers out_and_free_statement(outfile, expr) FILE *outfile; expptr expr; #else out_and_free_statement(FILE *outfile, expptr expr) #endif { if (expr) expr_out (outfile, expr); nice_printf (outfile, ";\n"); } /* out_and_free_statement */ int #ifdef KR_headers same_ident(left, right) expptr left; expptr right; #else same_ident(expptr left, expptr right) #endif { if (!left || !right) return 0; if (left -> tag == TNAME && right -> tag == TNAME && left == right) return 1; if (left -> tag == TADDR && right -> tag == TADDR && left -> addrblock.uname_tag == right -> addrblock.uname_tag) switch (left -> addrblock.uname_tag) { case UNAM_REF: case UNAM_NAME: /* Check for array subscripts */ if (left -> addrblock.user.name -> vdim || right -> addrblock.user.name -> vdim) if (left -> addrblock.user.name != right -> addrblock.user.name || !same_expr (left -> addrblock.memoffset, right -> addrblock.memoffset)) return 0; return same_ident ((expptr) (left -> addrblock.user.name), (expptr) right -> addrblock.user.name); case UNAM_IDENT: return strcmp(left->addrblock.user.ident, right->addrblock.user.ident) == 0; case UNAM_CHARP: return strcmp(left->addrblock.user.Charp, right->addrblock.user.Charp) == 0; default: return 0; } /* switch */ if (left->tag == TEXPR && left->exprblock.opcode == OPWHATSIN && right->tag == TEXPR && right->exprblock.opcode == OPWHATSIN) return same_ident(left->exprblock.leftp, right->exprblock.leftp); return 0; } /* same_ident */ static int #ifdef KR_headers samefpconst(c1, c2, n) register Constp c1; register Constp c2; register int n; #else samefpconst(register Constp c1, register Constp c2, register int n) #endif { char *s1, *s2; if (!c1->vstg && !c2->vstg) return c1->Const.cd[n] == c2->Const.cd[n]; s1 = c1->vstg ? c1->Const.cds[n] : dtos(c1->Const.cd[n]); s2 = c2->vstg ? c2->Const.cds[n] : dtos(c2->Const.cd[n]); return !strcmp(s1, s2); } static int #ifdef KR_headers sameconst(c1, c2) register Constp c1; register Constp c2; #else sameconst(register Constp c1, register Constp c2) #endif { switch(c1->vtype) { case TYCOMPLEX: case TYDCOMPLEX: if (!samefpconst(c1,c2,1)) return 0; case TYREAL: case TYDREAL: return samefpconst(c1,c2,0); case TYCHAR: return c1->Const.ccp1.blanks == c2->Const.ccp1.blanks && c1->vleng->constblock.Const.ci == c2->vleng->constblock.Const.ci && !memcmp(c1->Const.ccp, c2->Const.ccp, (int)c1->vleng->constblock.Const.ci); case TYSHORT: case TYINT: case TYLOGICAL: return c1->Const.ci == c2->Const.ci; } err("unexpected type in sameconst"); return 0; } /* same_expr -- Returns true only if e1 and e2 match. This is somewhat pessimistic, but can afford to be because it's just used to optimize on the assignment operators (+=, -=, etc). */ int #ifdef KR_headers same_expr(e1, e2) expptr e1; expptr e2; #else same_expr(expptr e1, expptr e2) #endif { if (!e1 || !e2) return !e1 && !e2; if (e1 -> tag != e2 -> tag || e1 -> headblock.vtype != e2 -> headblock.vtype) return 0; switch (e1 -> tag) { case TEXPR: if (e1 -> exprblock.opcode != e2 -> exprblock.opcode) return 0; return same_expr (e1 -> exprblock.leftp, e2 -> exprblock.leftp) && same_expr (e1 -> exprblock.rightp, e2 -> exprblock.rightp); case TNAME: case TADDR: return same_ident (e1, e2); case TCONST: return sameconst(&e1->constblock, &e2->constblock); default: return 0; } /* switch */ } /* same_expr */ void #ifdef KR_headers out_name(fp, namep) FILE *fp; Namep namep; #else out_name(FILE *fp, Namep namep) #endif { extern int usedefsforcommon; Extsym *comm; if (namep == NULL) return; /* DON'T want to use oneof_stg() here; need to find the right common name */ if (namep->vstg == STGCOMMON && !namep->vcommequiv && !usedefsforcommon) { comm = &extsymtab[namep->vardesc.varno]; extern_out(fp, comm); nice_printf(fp, "%d.", comm->curno); } /* if namep -> vstg == STGCOMMON */ if (namep->vprocclass == PTHISPROC && namep->vtype != TYSUBR) nice_printf(fp, xretslot[namep->vtype]->user.ident); else nice_printf (fp, "%s", namep->cvarname); } /* out_name */ #define cpd(n) cp->vstg ? cp->Const.cds[n] : dtos(cp->Const.cd[n]) void #ifdef KR_headers out_const(fp, cp) FILE *fp; register Constp cp; #else out_const(FILE *fp, register Constp cp) #endif { static char real_buf[50], imag_buf[50]; ftnint j; unsigned int k; int type = cp->vtype; switch (type) { case TYINT1: case TYSHORT: nice_printf (fp, "%ld", cp->Const.ci); /* don't cast ci! */ break; case TYLONG: #ifdef TYQUAD0 case TYQUAD: #endif nice_printf (fp, "%ld", cp->Const.ci); /* don't cast ci! */ break; #ifndef NO_LONG_LONG case TYQUAD: if (cp->Const.cd[1] == 123.456) nice_printf (fp, "%s", cp->Const.cds[0]); else nice_printf (fp, "%lld", cp->Const.cq); break; #endif case TYREAL: nice_printf(fp, "%s", flconst(real_buf, cpd(0))); break; case TYDREAL: nice_printf(fp, "%s", cpd(0)); break; case TYCOMPLEX: nice_printf(fp, cm_fmt_string, flconst(real_buf, cpd(0)), flconst(imag_buf, cpd(1))); break; case TYDCOMPLEX: nice_printf(fp, dcm_fmt_string, cpd(0), cpd(1)); break; case TYLOGICAL1: case TYLOGICAL2: case TYLOGICAL: nice_printf (fp, "%s", cp->Const.ci ? "TRUE_" : "FALSE_"); break; case TYCHAR: { char *c = cp->Const.ccp, *ce; if (c == NULL) { nice_printf (fp, "\"\""); break; } /* if c == NULL */ nice_printf (fp, "\""); ce = c + cp->vleng->constblock.Const.ci; while(c < ce) { k = *(unsigned char *)c++; nice_printf(fp, str_fmt[k]); } for(j = cp->Const.ccp1.blanks; j > 0; j--) nice_printf(fp, " "); nice_printf (fp, "\""); break; } /* case TYCHAR */ default: erri ("out_const: bad type '%d'", (int) type); break; } /* switch */ } /* out_const */ #undef cpd static void #ifdef KR_headers out_args(fp, ep) FILE *fp; expptr ep; #else out_args(FILE *fp, expptr ep) #endif { chainp arglist; if(ep->tag != TLIST) badtag("out_args", ep->tag); for(arglist = ep->listblock.listp;;) { expr_out(fp, (expptr)arglist->datap); arglist->datap = 0; if (!(arglist = arglist->nextp)) break; nice_printf(fp, ", "); } } /* out_addr -- this routine isn't local because it is called by the system-generated identifier printing routines */ void #ifdef KR_headers out_addr(fp, addrp) FILE *fp; struct Addrblock *addrp; #else out_addr(FILE *fp, struct Addrblock *addrp) #endif { extern Extsym *extsymtab; int was_array = 0; char *s; if (addrp == NULL) return; if (doin_setbound && addrp->vstg == STGARG && addrp->vtype != TYCHAR && ISICON(addrp->memoffset) && !addrp->memoffset->constblock.Const.ci) nice_printf(fp, "*"); switch (addrp -> uname_tag) { case UNAM_REF: nice_printf(fp, "%s_%s(", addrp->user.name->cvarname, addrp->cmplx_sub ? "subscr" : "ref"); out_args(fp, addrp->memoffset); nice_printf(fp, ")"); return; case UNAM_NAME: out_name (fp, addrp -> user.name); break; case UNAM_IDENT: if (*(s = addrp->user.ident) == ' ') { if (multitype) nice_printf(fp, "%s", xretslot[addrp->vtype]->user.ident); else nice_printf(fp, "%s", s+1); } else { nice_printf(fp, "%s", s); } break; case UNAM_CHARP: nice_printf(fp, "%s", addrp->user.Charp); break; case UNAM_EXTERN: extern_out (fp, &extsymtab[addrp -> memno]); break; case UNAM_CONST: switch(addrp->vstg) { case STGCONST: out_const(fp, (Constp)addrp); break; case STGMEMNO: output_literal (fp, addrp->memno, (Constp)addrp); break; default: Fatal("unexpected vstg in out_addr"); } break; case UNAM_UNKNOWN: default: nice_printf (fp, "Unknown Addrp"); break; } /* switch */ /* It's okay to just throw in the brackets here because they have a precedence level of 15, the highest value. */ if ((addrp->uname_tag == UNAM_NAME && addrp->user.name->vdim || addrp->ntempelt > 1 || addrp->isarray) && addrp->vtype != TYCHAR) { expptr offset; was_array = 1; offset = addrp -> memoffset; addrp->memoffset = 0; if (ONEOF(addrp->vstg, M(STGCOMMON)|M(STGEQUIV)) && addrp -> uname_tag == UNAM_NAME && !addrp->skip_offset) offset = mkexpr (OPMINUS, offset, mkintcon ( addrp -> user.name -> voffset)); nice_printf (fp, "["); offset = mkexpr (OPSLASH, offset, ICON (typesize[addrp -> vtype] * (addrp -> Field ? 2 : 1))); expr_out (fp, offset); nice_printf (fp, "]"); } /* Check for structure field reference */ if (addrp -> Field && addrp -> uname_tag != UNAM_CONST && addrp -> uname_tag != UNAM_UNKNOWN) { if (oneof_stg((addrp -> uname_tag == UNAM_NAME ? addrp -> user.name : (Namep) NULL), addrp -> vstg, M(STGARG)|M(STGEQUIV)) && !was_array && (addrp->vclass != CLPROC || !multitype)) nice_printf (fp, "->%s", addrp -> Field); else nice_printf (fp, ".%s", addrp -> Field); } /* if */ /* Check for character subscripting */ if (addrp->vtype == TYCHAR && (addrp->vclass != CLPROC || addrp->uname_tag == UNAM_NAME && addrp->user.name->vprocclass == PTHISPROC) && addrp -> memoffset && (addrp -> uname_tag != UNAM_NAME || addrp -> user.name -> vtype == TYCHAR) && (!ISICON (addrp -> memoffset) || (addrp -> memoffset -> constblock.Const.ci))) { int use_paren = 0; expptr e = addrp -> memoffset; if (!e) return; addrp->memoffset = 0; if (ONEOF(addrp->vstg, M(STGCOMMON)|M(STGEQUIV)) && addrp -> uname_tag == UNAM_NAME) { e = mkexpr (OPMINUS, e, mkintcon (addrp -> user.name -> voffset)); /* mkexpr will simplify it to zero if possible */ if (e->tag == TCONST && e->constblock.Const.ci == 0) return; } /* if addrp -> vstg == STGCOMMON */ /* In the worst case, parentheses might be needed OUTSIDE the expression, too. But since I think this subscripting can only appear as a parameter in a procedure call, I don't think outside parens will ever be needed. INSIDE parens are handled below */ nice_printf (fp, " + "); if (e -> tag == TEXPR) { int arg_prec = op_precedence (e -> exprblock.opcode); int prec = op_precedence (OPPLUS); use_paren = arg_prec && (arg_prec < prec || (arg_prec == prec && is_left_assoc (OPPLUS))); } /* if e -> tag == TEXPR */ if (use_paren) nice_printf (fp, "("); expr_out (fp, e); if (use_paren) nice_printf (fp, ")"); } /* if */ } /* out_addr */ static void #ifdef KR_headers output_literal(fp, memno, cp) FILE *fp; long memno; Constp cp; #else output_literal(FILE *fp, long memno, Constp cp) #endif { struct Literal *litp, *lastlit; lastlit = litpool + nliterals; for (litp = litpool; litp < lastlit; litp++) { if (litp -> litnum == memno) break; } /* for litp */ if (litp >= lastlit) out_const (fp, cp); else { nice_printf (fp, "%s", lit_name (litp)); litp->lituse++; } } /* output_literal */ static void #ifdef KR_headers output_prim(fp, primp) FILE *fp; struct Primblock *primp; #else output_prim(FILE *fp, struct Primblock *primp) #endif { if (primp == NULL) return; out_name (fp, primp -> namep); if (primp -> argsp) output_arg_list (fp, primp -> argsp); if (primp -> fcharp != (expptr) NULL || primp -> lcharp != (expptr) NULL) nice_printf (fp, "Sorry, no substrings yet"); } static void #ifdef KR_headers output_arg_list(fp, listp) FILE *fp; struct Listblock *listp; #else output_arg_list(FILE *fp, struct Listblock *listp) #endif { chainp arg_list; if (listp == (struct Listblock *) NULL || listp -> listp == (chainp) NULL) return; nice_printf (fp, "("); for (arg_list = listp -> listp; arg_list; arg_list = arg_list -> nextp) { expr_out (fp, (expptr) arg_list -> datap); if (arg_list -> nextp != (chainp) NULL) /* Might want to add a hook in here to accomodate the style setting which wants spaces after commas */ nice_printf (fp, ","); } /* for arg_list */ nice_printf (fp, ")"); } /* output_arg_list */ static void #ifdef KR_headers output_unary(fp, e) FILE *fp; struct Exprblock *e; #else output_unary(FILE *fp, struct Exprblock *e) #endif { if (e == NULL) return; switch (e -> opcode) { case OPNEG: if (e->vtype == TYREAL && dneg) { e->opcode = OPNEG_KLUDGE; output_binary(fp,e); e->opcode = OPNEG; break; } case OPNEG1: case OPNOT: case OPABS: case OPBITNOT: case OPWHATSIN: case OPPREINC: case OPPREDEC: case OPADDR: case OPIDENTITY: case OPCHARCAST: case OPDABS: output_binary (fp, e); break; case OPCALL: case OPCCALL: nice_printf (fp, "Sorry, no OPCALL yet"); break; default: erri ("output_unary: bad opcode", (int) e -> opcode); break; } /* switch */ } /* output_unary */ static char * #ifdef KR_headers findconst(m) register long m; #else findconst(register long m) #endif { register struct Literal *litp, *litpe; litp = litpool; for(litpe = litp + nliterals; litp < litpe; litp++) if (litp->litnum == m) return litp->cds[0]; Fatal("findconst failure!"); return 0; } static int #ifdef KR_headers opconv_fudge(fp, e) FILE *fp; struct Exprblock *e; #else opconv_fudge(FILE *fp, struct Exprblock *e) #endif { /* special handling for conversions, ichar and character*1 */ register expptr lp; register union Expression *Offset; register char *cp; int lt; char buf[8], *s; unsigned int k; Namep np; Addrp ap; if (!(lp = e->leftp)) /* possible with erroneous Fortran */ return 1; lt = lp->headblock.vtype; if (lt == TYCHAR) { switch(lp->tag) { case TNAME: nice_printf(fp, "*(unsigned char *)"); out_name(fp, (Namep)lp); return 1; case TCONST: tconst: cp = lp->constblock.Const.ccp; tconst1: k = *(unsigned char *)cp; if (k < 128) { /* ASCII character */ sprintf(buf, chr_fmt[k], k); nice_printf(fp, "'%s'", buf); } else nice_printf(fp, "%d", k); return 1; case TADDR: switch(lp->addrblock.vstg) { case STGMEMNO: if (halign && e->vtype != TYCHAR) { nice_printf(fp, "*(%s *)", c_type_decl(e->vtype,0)); expr_out(fp, lp); return 1; } cp = findconst(lp->addrblock.memno); goto tconst1; case STGCONST: goto tconst; } lp->addrblock.vtype = tyint; Offset = lp->addrblock.memoffset; switch(lp->addrblock.uname_tag) { case UNAM_REF: nice_printf(fp, "*(unsigned char *)"); return 0; case UNAM_NAME: np = lp->addrblock.user.name; if (ONEOF(np->vstg, M(STGCOMMON)|M(STGEQUIV))) Offset = mkexpr(OPMINUS, Offset, ICON(np->voffset)); } lp->addrblock.memoffset = Offset ? mkexpr(OPSTAR, Offset, ICON(typesize[tyint])) : ICON(0); lp->addrblock.isarray = 1; /* STGCOMMON or STGEQUIV would cause */ /* voffset to be added in a second time */ lp->addrblock.vstg = STGUNKNOWN; nice_printf(fp, "*(unsigned char *)&"); return 0; default: badtag("opconv_fudge", lp->tag); } } if (lt != e->vtype) { s = c_type_decl(e->vtype, 0); if (ISCOMPLEX(lt)) { tryagain: np = (Namep)e->leftp; switch(np->tag) { case TNAME: nice_printf(fp, "(%s) %s%sr", s, np->cvarname, np->vstg == STGARG ? "->" : "."); return 1; case TADDR: ap = (Addrp)np; switch(ap->uname_tag) { case UNAM_IDENT: nice_printf(fp, "(%s) %s.r", s, ap->user.ident); return 1; case UNAM_NAME: nice_printf(fp, "(%s) ", s); out_addr(fp, ap); nice_printf(fp, ".r"); return 1; case UNAM_REF: nice_printf(fp, "(%s) %s_%s(", s, ap->user.name->cvarname, ap->cmplx_sub ? "subscr" : "ref"); out_args(fp, ap->memoffset); nice_printf(fp, ").r"); return 1; default: fatali( "Bad uname_tag %d in opconv_fudge", ap->uname_tag); } case TEXPR: e = (Exprp)np; if (e->opcode == OPWHATSIN) goto tryagain; default: fatali("Unexpected tag %d in opconv_fudge", np->tag); } } nice_printf(fp, "(%s) ", s); } return 0; } static void #ifdef KR_headers output_binary(fp, e) FILE *fp; struct Exprblock *e; #else output_binary(FILE *fp, struct Exprblock *e) #endif { char *format; int prec; if (e == NULL || e -> tag != TEXPR) return; /* Instead of writing a huge switch, I've incorporated the output format into a table. Things like "%l" and "%r" stand for the left and right subexpressions. This should allow both prefix and infix functions to be specified (e.g. "(%l * %r", "z_div (%l, %r"). Of course, I should REALLY think out the ramifications of writing out straight text, as opposed to some intermediate format, which could figure out and optimize on the the number of required blanks (we don't want "x - (-y)" to become "x --y", for example). Special cases (such as incomplete implementations) could still be implemented as part of the switch, they will just have some dummy value instead of the string pattern. Another difficulty is the fact that the complex functions will differ from the integer and real ones */ /* Handle a special case. We don't want to output "x + - 4", or "y - - 3" */ if ((e -> opcode == OPPLUS || e -> opcode == OPMINUS) && e -> rightp && e -> rightp -> tag == TCONST && isnegative_const (&(e -> rightp -> constblock)) && is_negatable (&(e -> rightp -> constblock))) { e -> opcode = (e -> opcode == OPPLUS) ? OPMINUS : OPPLUS; negate_const (&(e -> rightp -> constblock)); } /* if e -> opcode == PLUS or MINUS */ prec = op_precedence (e -> opcode); format = op_format (e -> opcode); if (format != SPECIAL_FMT) { while (*format) { if (*format == '%') { int arg_prec, use_paren = 0; expptr lp, rp; switch (*(format + 1)) { case 'l': lp = e->leftp; if (lp && lp->tag == TEXPR) { arg_prec = op_precedence(lp->exprblock.opcode); use_paren = arg_prec && (arg_prec < prec || (arg_prec == prec && is_right_assoc (prec))); } /* if e -> leftp */ if (e->opcode == OPCONV && opconv_fudge(fp,e)) break; if (use_paren) nice_printf (fp, "("); expr_out(fp, lp); if (use_paren) nice_printf (fp, ")"); break; case 'r': rp = e->rightp; if (rp && rp->tag == TEXPR) { arg_prec = op_precedence(rp->exprblock.opcode); use_paren = arg_prec && (arg_prec < prec || (arg_prec == prec && is_left_assoc (prec))); use_paren = use_paren || (rp->exprblock.opcode == OPNEG && prec >= op_precedence(OPMINUS)); } /* if e -> rightp */ if (use_paren) nice_printf (fp, "("); expr_out(fp, rp); if (use_paren) nice_printf (fp, ")"); break; case '\0': case '%': nice_printf (fp, "%%"); break; default: erri ("output_binary: format err: '%%%c' illegal", (int) *(format + 1)); break; } /* switch */ format += 2; } else nice_printf (fp, "%c", *format++); } /* while *format */ } else { /* Handle Special cases of formatting */ switch (e -> opcode) { case OPCCALL: case OPCALL: out_call (fp, (int) e -> opcode, e -> vtype, e -> vleng, e -> leftp, e -> rightp); break; case OPCOMMA_ARG: doin_setbound = 1; nice_printf(fp, "("); expr_out(fp, e->leftp); nice_printf(fp, ", &"); doin_setbound = 0; expr_out(fp, e->rightp); nice_printf(fp, ")"); break; case OPADDR: default: nice_printf (fp, "Sorry, can't format OPCODE '%d'", e -> opcode); break; } } /* else */ } /* output_binary */ void #ifdef KR_headers out_call(outfile, op, ftype, len, name, args) FILE *outfile; int op; int ftype; expptr len; expptr name; expptr args; #else out_call(FILE *outfile, int op, int ftype, expptr len, expptr name, expptr args) #endif { chainp arglist; /* Pointer to any actual arguments */ chainp cp; /* Iterator over argument lists */ Addrp ret_val = (Addrp) NULL; /* Function return value buffer, if any is required */ int byvalue; /* True iff we're calling a C library routine */ int done_once; /* Used for writing commas to outfile */ int narg, t; register expptr q; long L; Argtypes *at; Atype *A, *Ac; Namep np; extern int forcereal; /* Don't use addresses if we're calling a C function */ byvalue = op == OPCCALL; if (args) arglist = args -> listblock.listp; else arglist = CHNULL; /* If this is a CHARACTER function, the first argument is the result */ if (ftype == TYCHAR) if (ISICON (len)) { ret_val = (Addrp) (arglist -> datap); arglist = arglist -> nextp; } else { err ("adjustable character function"); return; } /* else */ /* If this is a COMPLEX function, the first argument is the result */ else if (ISCOMPLEX (ftype)) { ret_val = (Addrp) (arglist -> datap); arglist = arglist -> nextp; } /* if ISCOMPLEX */ /* prepare to cast procedure parameters -- set A if we know how */ np = name->tag == TEXPR && name->exprblock.opcode == OPWHATSIN ? (Namep)name->exprblock.leftp : (Namep)name; A = Ac = 0; if (np->tag == TNAME && (at = np->arginfo)) { if (at->nargs > 0) A = at->atypes; if (Ansi && (at->defined || at->nargs > 0)) Ac = at->atypes; } /* Now we can actually start to write out the function invocation */ if (ftype == TYREAL && forcereal) nice_printf(outfile, "(real)"); if (name -> tag == TEXPR && name -> exprblock.opcode == OPWHATSIN) { nice_printf (outfile, "("); expr_out (outfile, name); nice_printf (outfile, ")"); } else expr_out(outfile, name); nice_printf(outfile, "("); if (ret_val) { if (ISCOMPLEX (ftype)) nice_printf (outfile, "&"); expr_out (outfile, (expptr) ret_val); if (Ac) Ac++; /* The length of the result of a character function is the second argument */ /* It should be in place from putcall(), so we won't touch it explicitly */ } /* if ret_val */ done_once = ret_val ? TRUE : FALSE; /* Now run through the named arguments */ narg = -1; for (cp = arglist; cp; cp = cp -> nextp, done_once = TRUE) { if (done_once) nice_printf (outfile, ", "); narg++; if (!( q = (expptr)cp->datap) ) continue; if (q->tag == TADDR) { if (q->addrblock.vtype > TYERROR) { /* I/O block */ nice_printf(outfile, "&%s", q->addrblock.user.ident); continue; } if (!byvalue && q->addrblock.isarray && q->addrblock.vtype != TYCHAR && q->addrblock.memoffset->tag == TCONST) { /* check for 0 offset -- after */ /* correcting for equivalence. */ L = q->addrblock.memoffset->constblock.Const.ci; if (ONEOF(q->addrblock.vstg, M(STGCOMMON)|M(STGEQUIV)) && q->addrblock.uname_tag == UNAM_NAME) L -= q->addrblock.user.name->voffset; if (L) goto skip_deref; if (Ac && narg < at->dnargs && q->headblock.vtype != (t = Ac[narg].type) && t > TYADDR && t < TYSUBR) nice_printf(outfile, "(%s*)", Typename[t]); /* &x[0] == x */ /* This also prevents &sizeof(doublereal)[0] */ switch(q->addrblock.uname_tag) { case UNAM_NAME: out_name(outfile, q->addrblock.user.name); continue; case UNAM_IDENT: nice_printf(outfile, "%s", q->addrblock.user.ident); continue; case UNAM_CHARP: nice_printf(outfile, "%s", q->addrblock.user.Charp); continue; case UNAM_EXTERN: extern_out(outfile, &extsymtab[q->addrblock.memno]); continue; } } } /* Skip over the dereferencing operator generated only for the intermediate file */ skip_deref: if (q -> tag == TEXPR && q -> exprblock.opcode == OPWHATSIN) q = q -> exprblock.leftp; if (q->headblock.vclass == CLPROC) { if (Castargs && (q->tag != TNAME || q->nameblock.vprocclass != PTHISPROC) && (q->tag != TADDR || q->addrblock.uname_tag != UNAM_NAME || q->addrblock.user.name->vprocclass != PTHISPROC)) { if (A && (t = A[narg].type) >= 200) t %= 100; else { t = q->headblock.vtype; if (q->tag == TNAME && q->nameblock.vimpltype) t = TYUNKNOWN; } nice_printf(outfile, "(%s)", usedcasts[t] = casttypes[t]); } } else if (Ac && narg < at->dnargs && q->headblock.vtype != (t = Ac[narg].type) && t > TYADDR && t < TYSUBR) nice_printf(outfile, "(%s*)", Typename[t]); if ((q -> tag == TADDR || q-> tag == TNAME) && (byvalue || q -> headblock.vstg != STGREG)) { if (q -> headblock.vtype != TYCHAR) if (byvalue) { if (q -> tag == TADDR && q -> addrblock.uname_tag == UNAM_NAME && ! q -> addrblock.user.name -> vdim && oneof_stg(q -> addrblock.user.name, q -> addrblock.vstg, M(STGARG)|M(STGEQUIV)) && ! ISCOMPLEX(q->addrblock.user.name->vtype)) nice_printf (outfile, "*"); else if (q -> tag == TNAME && oneof_stg(&q->nameblock, q -> nameblock.vstg, M(STGARG)|M(STGEQUIV)) && !(q -> nameblock.vdim)) nice_printf (outfile, "*"); } else { expptr memoffset; if (q->tag == TADDR && ( !ONEOF (q -> addrblock.vstg, M(STGEXT)|M(STGLENG)) && (ONEOF(q->addrblock.vstg, M(STGCOMMON)|M(STGEQUIV)|M(STGMEMNO)) || ((memoffset = q->addrblock.memoffset) && (!ISICON(memoffset) || memoffset->constblock.Const.ci))) || ONEOF(q->addrblock.vstg, M(STGINIT)|M(STGAUTO)|M(STGBSS)) && !q->addrblock.isarray)) nice_printf (outfile, "&"); else if (q -> tag == TNAME && !oneof_stg(&q->nameblock, q -> nameblock.vstg, M(STGARG)|M(STGEXT)|M(STGEQUIV))) nice_printf (outfile, "&"); } /* else */ expr_out (outfile, q); } /* if q -> tag == TADDR || q -> tag == TNAME */ /* Might be a Constant expression, e.g. string length, character constants */ else if (q -> tag == TCONST) { if (q->constblock.vtype == TYLONG) nice_printf(outfile, "(ftnlen)%ld", q->constblock.Const.ci); else out_const(outfile, &q->constblock); } /* Must be some other kind of expression, or register var, or constant. In particular, this is likely to be a temporary variable assignment which was generated in p1put_call */ else if (!ISCOMPLEX (q -> headblock.vtype) && !ISCHAR (q)){ int use_paren = q -> tag == TEXPR && op_precedence (q -> exprblock.opcode) <= op_precedence (OPCOMMA); if (q->headblock.vtype == TYREAL) { if (forcereal) { nice_printf(outfile, "(real)"); use_paren = 1; } } else if (!Ansi && ISINT(q->headblock.vtype)) { nice_printf(outfile, "(ftnlen)"); use_paren = 1; } if (use_paren) nice_printf (outfile, "("); expr_out (outfile, q); if (use_paren) nice_printf (outfile, ")"); } /* if !ISCOMPLEX */ else err ("out_call: unknown parameter"); } /* for (cp = arglist */ if (arglist) frchain (&arglist); nice_printf (outfile, ")"); } /* out_call */ char * #ifdef KR_headers flconst(buf, x) char *buf; char *x; #else flconst(char *buf, char *x) #endif { sprintf(buf, fl_fmt_string, x); return buf; } char * #ifdef KR_headers dtos(x) double x; #else dtos(double x) #endif { static char buf[64]; #ifdef USE_DTOA g_fmt(buf, x); #else sprintf(buf, db_fmt_string, x); #endif return strcpy(mem(strlen(buf)+1,0), buf); } char tr_tab[Table_size]; /* out_init -- Initialize the data structures used by the routines in output.c. These structures include the output format to be used for Float, Double, Complex, and Double Complex constants. */ void out_init(Void) { extern int tab_size; register char *s; s = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_+-."; while(*s) tr_tab[*s++] = 3; tr_tab['>'] = 1; opeqable[OPPLUS] = 1; opeqable[OPMINUS] = 1; opeqable[OPSTAR] = 1; opeqable[OPSLASH] = 1; opeqable[OPMOD] = 1; opeqable[OPLSHIFT] = 1; opeqable[OPBITAND] = 1; opeqable[OPBITXOR] = 1; opeqable[OPBITOR ] = 1; /* Set the output format for both types of floating point constants */ if (fl_fmt_string == NULL || *fl_fmt_string == '\0') fl_fmt_string = (char*)(Ansi == 1 ? "%sf" : "(float)%s"); if (db_fmt_string == NULL || *db_fmt_string == '\0') db_fmt_string = "%.17g"; /* Set the output format for both types of complex constants. They will have string parameters rather than float or double so that the decimal point may be added to the strings generated by the {db,fl}_fmt_string formats above */ if (cm_fmt_string == NULL || *cm_fmt_string == '\0') { cm_fmt_string = "{%s,%s}"; } /* if cm_fmt_string == NULL */ if (dcm_fmt_string == NULL || *dcm_fmt_string == '\0') { dcm_fmt_string = "{%s,%s}"; } /* if dcm_fmt_string == NULL */ tab_size = 4; } /* out_init */ void #ifdef KR_headers extern_out(fp, extsym) FILE *fp; Extsym *extsym; #else extern_out(FILE *fp, Extsym *extsym) #endif { if (extsym == (Extsym *) NULL) return; nice_printf (fp, "%s", extsym->cextname); } /* extern_out */ static void #ifdef KR_headers output_list(fp, listp) FILE *fp; struct Listblock *listp; #else output_list(FILE *fp, struct Listblock *listp) #endif { int did_one = 0; chainp elts; nice_printf (fp, "("); if (listp) for (elts = listp -> listp; elts; elts = elts -> nextp) { if (elts -> datap) { if (did_one) nice_printf (fp, ", "); expr_out (fp, (expptr) elts -> datap); did_one = 1; } /* if elts -> datap */ } /* for elts */ nice_printf (fp, ")"); } /* output_list */ void #ifdef KR_headers out_asgoto(outfile, expr) FILE *outfile; expptr expr; #else out_asgoto(FILE *outfile, expptr expr) #endif { chainp value; Namep namep; int k; if (expr == (expptr) NULL) { err ("out_asgoto: NULL variable expr"); return; } /* if expr */ nice_printf (outfile, Ansi ? "switch (" : "switch ((int)"); /*)*/ expr_out (outfile, expr); nice_printf (outfile, ") {\n"); next_tab (outfile); /* The initial addrp value will be stored as a namep pointer */ switch(expr->tag) { case TNAME: /* local variable */ namep = &expr->nameblock; break; case TEXPR: if (expr->exprblock.opcode == OPWHATSIN && expr->exprblock.leftp->tag == TNAME) /* argument */ namep = &expr->exprblock.leftp->nameblock; else goto bad; break; case TADDR: if (expr->addrblock.uname_tag == UNAM_NAME) { /* initialized local variable */ namep = expr->addrblock.user.name; break; } default: bad: err("out_asgoto: bad expr"); return; } for(k = 0, value = namep -> varxptr.assigned_values; value; value = value->nextp, k++) { nice_printf (outfile, "case %d: goto %s;\n", k, user_label((long)value->datap)); } /* for value */ prev_tab (outfile); nice_printf (outfile, "}\n"); } /* out_asgoto */ void #ifdef KR_headers out_if(outfile, expr) FILE *outfile; expptr expr; #else out_if(FILE *outfile, expptr expr) #endif { nice_printf (outfile, "if ("); expr_out (outfile, expr); nice_printf (outfile, ") {\n"); next_tab (outfile); } /* out_if */ static void #ifdef KR_headers output_rbrace(outfile, s) FILE *outfile; char *s; #else output_rbrace(FILE *outfile, char *s) #endif { extern int last_was_label; register char *fmt; if (last_was_label) { last_was_label = 0; fmt = ";%s"; } else fmt = "%s"; nice_printf(outfile, fmt, s); } void #ifdef KR_headers out_else(outfile) FILE *outfile; #else out_else(FILE *outfile) #endif { prev_tab (outfile); output_rbrace(outfile, "} else {\n"); next_tab (outfile); } /* out_else */ void #ifdef KR_headers elif_out(outfile, expr) FILE *outfile; expptr expr; #else elif_out(FILE *outfile, expptr expr) #endif { prev_tab (outfile); output_rbrace(outfile, "} else "); out_if (outfile, expr); } /* elif_out */ void #ifdef KR_headers endif_out(outfile) FILE *outfile; #else endif_out(FILE *outfile) #endif { prev_tab (outfile); output_rbrace(outfile, "}\n"); } /* endif_out */ void #ifdef KR_headers end_else_out(outfile) FILE *outfile; #else end_else_out(FILE *outfile) #endif { prev_tab (outfile); output_rbrace(outfile, "}\n"); } /* end_else_out */ void #ifdef KR_headers compgoto_out(outfile, index, labels) FILE *outfile; expptr index; expptr labels; #else compgoto_out(FILE *outfile, expptr index, expptr labels) #endif { char *s1, *s2; if (index == ENULL) err ("compgoto_out: null index for computed goto"); else if (labels && labels -> tag != TLIST) erri ("compgoto_out: expected label list, got tag '%d'", labels -> tag); else { chainp elts; int i = 1; s2 = /*(*/ ") {\n"; /*}*/ if (Ansi) s1 = "switch ("; /*)*/ else if (index->tag == TNAME || index->tag == TEXPR && index->exprblock.opcode == OPWHATSIN) s1 = "switch ((int)"; /*)*/ else { s1 = "switch ((int)("; s2 = ")) {\n"; /*}*/ } nice_printf(outfile, s1); expr_out (outfile, index); nice_printf (outfile, s2); next_tab (outfile); for (elts = labels -> listblock.listp; elts; elts = elts -> nextp, i++) { if (elts -> datap) { if (ISICON(((expptr) (elts -> datap)))) nice_printf (outfile, "case %d: goto %s;\n", i, user_label(((expptr)(elts->datap))->constblock.Const.ci)); else err ("compgoto_out: bad label in label list"); } /* if (elts -> datap) */ } /* for elts */ prev_tab (outfile); nice_printf (outfile, /*{*/ "}\n"); } /* else */ } /* compgoto_out */ void #ifdef KR_headers out_for(outfile, init, test, inc) FILE *outfile; expptr init; expptr test; expptr inc; #else out_for(FILE *outfile, expptr init, expptr test, expptr inc) #endif { nice_printf (outfile, "for ("); expr_out (outfile, init); nice_printf (outfile, "; "); expr_out (outfile, test); nice_printf (outfile, "; "); expr_out (outfile, inc); nice_printf (outfile, ") {\n"); next_tab (outfile); } /* out_for */ void #ifdef KR_headers out_end_for(outfile) FILE *outfile; #else out_end_for(FILE *outfile) #endif { prev_tab (outfile); nice_printf (outfile, "}\n"); } /* out_end_for */ f2c/src/output.h000066400000000000000000000040671171647030000140360ustar00rootroot00000000000000/* nice_printf -- same arguments as fprintf. All output which is to become C code must be directed through this function. For now, no buffering is done. Later on, every line of output will be filtered to accomodate the style definitions (e.g. one statement per line, spaces between function names and argument lists, etc.) */ #include "niceprintf.h" /* Definitions for the opcode table. The table is indexed by the macros which are #defined in defines.h */ #define UNARY_OP 01 #define BINARY_OP 02 #define SPECIAL_FMT NULL #define is_unary_op(x) (opcode_table[x].type == UNARY_OP) #define is_binary_op(x) (opcode_table[x].type == BINARY_OP) #define op_precedence(x) (opcode_table[x].prec) #define op_format(x) (opcode_table[x].format) /* _assoc_table -- encodes left-associativity and right-associativity information; indexed by precedence level. Only 2, 3, 14 are right-associative. Source: Kernighan & Ritchie, p. 49 */ extern char _assoc_table[]; #define is_right_assoc(x) (_assoc_table [x]) #define is_left_assoc(x) (! _assoc_table [x]) typedef struct { int type; /* UNARY_OP or BINARY_OP */ int prec; /* Precedence level, useful for adjusting number of parens to insert. Zero is a special level, and 2, 3, 14 are right-associative */ char *format; } table_entry; extern char *fl_fmt_string; /* Float constant format string */ extern char *db_fmt_string; /* Double constant format string */ extern char *cm_fmt_string; /* Complex constant format string */ extern char *dcm_fmt_string; /* Double Complex constant format string */ extern int indent; /* Number of spaces to indent; this is a temporary fix */ extern int tab_size; /* Number of spaces in each tab */ extern int in_string; extern table_entry opcode_table[]; void compgoto_out Argdcl((FILEP, tagptr, tagptr)); void endif_out Argdcl((FILEP)); void expr_out Argdcl((FILEP, tagptr)); void out_and_free_statement Argdcl((FILEP, tagptr)); void out_end_for Argdcl((FILEP)); void out_if Argdcl((FILEP, tagptr)); void out_name Argdcl((FILEP, Namep)); f2c/src/p1defs.h000066400000000000000000000131551171647030000136560ustar00rootroot00000000000000#define P1_UNKNOWN 0 #define P1_COMMENT 1 /* Fortan comment string */ #define P1_EOF 2 /* End of file dummy token */ #define P1_SET_LINE 3 /* Reset the line counter */ #define P1_FILENAME 4 /* Name of current input file */ #define P1_NAME_POINTER 5 /* Pointer to hash table entry */ #define P1_CONST 6 /* Some constant value */ #define P1_EXPR 7 /* Followed by opcode */ /* The next two tokens could be grouped together, since they always come from an Addr structure */ #define P1_IDENT 8 /* Char string identifier in addrp->user field */ #define P1_EXTERN 9 /* Pointer to external symbol entry */ #define P1_HEAD 10 /* Function header info */ #define P1_LIST 11 /* A list of data (e.g. arguments) will follow the tag, type, and count */ #define P1_LITERAL 12 /* Hold the index into the literal pool */ #define P1_LABEL 13 /* label value */ #define P1_ASGOTO 14 /* Store the hash table pointer of variable used in assigned goto */ #define P1_GOTO 15 /* Store the statement number */ #define P1_IF 16 /* store the condition as an expression */ #define P1_ELSE 17 /* No data */ #define P1_ELIF 18 /* store the condition as an expression */ #define P1_ENDIF 19 /* Marks the end of a block IF */ #define P1_ENDELSE 20 /* Marks the end of a block ELSE */ #define P1_ADDR 21 /* Addr data; used for arrays, common and equiv addressing, NOT for names, idents or externs */ #define P1_SUBR_RET 22 /* Subroutine return; the return expression follows */ #define P1_COMP_GOTO 23 /* Computed goto; has expr, label list */ #define P1_FOR 24 /* C FOR loop; three expressions follow */ #define P1_ENDFOR 25 /* End of C FOR loop */ #define P1_FORTRAN 26 /* original Fortran source */ #define P1_CHARP 27 /* user.Charp field -- for long names */ #define P1_WHILE1START 28 /* start of DO WHILE */ #define P1_WHILE2START 29 /* rest of DO WHILE */ #define P1_PROCODE 30 /* invoke procode() -- to adjust params */ #define P1_ELSEIFSTART 31 /* handle extra code for abs, min, max in else if() */ #define P1_FILENAME_MAX 256 /* max filename length to retain (for -g) */ #define P1_STMTBUFSIZE 1400 #define COMMENT_BUFFER_SIZE 255 /* max number of chars in each comment */ #define CONSTANT_STR_MAX 1000 /* max number of chars in string constant */ void p1_asgoto Argdcl((Addrp)); void p1_comment Argdcl((char*)); void p1_elif Argdcl((tagptr)); void p1_else Argdcl((void)); void p1_endif Argdcl((void)); void p1_expr Argdcl((tagptr)); void p1_for Argdcl((tagptr, tagptr, tagptr)); void p1_goto Argdcl((long int)); void p1_head Argdcl((int, char*)); void p1_if Argdcl((tagptr)); void p1_label Argdcl((long int)); void p1_line_number Argdcl((long int)); void p1_subr_ret Argdcl((tagptr)); void p1comp_goto Argdcl((tagptr, int, struct Labelblock**)); void p1else_end Argdcl((void)); void p1for_end Argdcl((void)); void p1put Argdcl((int)); void p1puts Argdcl((int, char*)); /* The pass 1 intermediate file has the following format: [ : [ [ ]]] \n e.g. 1: This is a comment This format is destined to change in the future, but for now a readable form is more desirable than a compact form. NOTES ABOUT THE P1 FORMAT ---------------------------------------------------------------------- P1_COMMENT: The comment string (in ) may be at most COMMENT_BUFFER_SIZE bytes long. It must contain no newlines or null characters. A side effect of the way comments are read in lex.c is that no '\377' chars may be in a comment either. P1_SET_LINE: holds the line number in the current source file. P1_INC_LINE: Increment the source line number; is empty. P1_NAME_POINTER: holds the integer representation of a pointer into a hash table entry. P1_CONST: the first field in is a type tag (one of the TYxxxx macros), the next field holds the constant value P1_EXPR: holds the opcode number of the expression, followed by the type of the expression (required for OPCONV). Next is the value of vleng. The type of operation represented by the opcode determines how many of the following data items are part of this expression. P1_IDENT: holds the type, then storage, then the char string identifier in the addrp->user field. P1_EXTERN: holds an offset into the external symbol table entry P1_HEAD: the first field in is the procedure class, the second is the name of the procedure P1_LIST: the first field in is the tag, the second the type of the list, the third the number of elements in the list P1_LITERAL: holds the litnum of a value in the literal pool. P1_LABEL: holds the statement number of the current line P1_ASGOTO: holds the hash table pointer of the variable P1_GOTO: holds the statement number to jump to P1_IF: is empty, the following expression is the IF condition. P1_ELSE: is empty. P1_ELIF: is empty, the following expression is the IF condition. P1_ENDIF: is empty. P1_ENDELSE: is empty. P1_ADDR: holds a direct copy of the structure. The next expression is a copy of vleng, and the next a copy of memoffset. P1_SUBR_RET: The next token is an expression for the return value. P1_COMP_GOTO: The next token is an integer expression, the following one a list of labels. P1_FOR: The next three expressions are the Init, Test, and Increment expressions of a C FOR loop. P1_ENDFOR: Marks the end of the body of a FOR loop */ f2c/src/p1output.c000066400000000000000000000340501171647030000142650ustar00rootroot00000000000000/**************************************************************** Copyright 1990, 1991, 1993, 1994, 1999-2001 by AT&T, Lucent Technologies and Bellcore. Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the above copyright notice appear in all copies and that both that the copyright notice and this permission notice and warranty disclaimer appear in supporting documentation, and that the names of AT&T, Bell Laboratories, Lucent or Bellcore or any of their entities not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. AT&T, Lucent and Bellcore disclaim all warranties with regard to this software, including all implied warranties of merchantability and fitness. In no event shall AT&T, Lucent or Bellcore be liable for any special, indirect or consequential damages or any damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortious action, arising out of or in connection with the use or performance of this software. ****************************************************************/ #include "defs.h" #include "p1defs.h" #include "output.h" #include "names.h" static void p1_addr Argdcl((Addrp)); static void p1_big_addr Argdcl((Addrp)); static void p1_binary Argdcl((Exprp)); static void p1_const Argdcl((Constp)); static void p1_list Argdcl((struct Listblock*)); static void p1_literal Argdcl((long int)); static void p1_name Argdcl((Namep)); static void p1_unary Argdcl((Exprp)); static void p1putd Argdcl((int, long int)); static void p1putdd Argdcl((int, int, int)); static void p1putddd Argdcl((int, int, int, int)); static void p1putdds Argdcl((int, int, int, char*)); static void p1putds Argdcl((int, int, char*)); static void p1putn Argdcl((int, int, char*)); /* p1_comment -- save the text of a Fortran comment in the intermediate file. Make sure that there are no spurious "/ *" or "* /" characters by mapping them onto "/+" and "+/". str is assumed to hold no newlines and be null terminated; it may be modified by this function. */ void #ifdef KR_headers p1_comment(str) char *str; #else p1_comment(char *str) #endif { register unsigned char *pointer, *ustr; if (!str) return; /* Get rid of any open or close comment combinations that may be in the Fortran input */ ustr = (unsigned char *)str; for(pointer = ustr; *pointer; pointer++) if (*pointer == '*' && (pointer[1] == '/' || pointer > ustr && pointer[-1] == '/')) *pointer = '+'; /* trim trailing white space */ #ifdef isascii while(--pointer >= ustr && (!isascii(*pointer) || isspace(*pointer))); #else while(--pointer >= ustr && isspace(*pointer)); #endif pointer[1] = 0; p1puts (P1_COMMENT, str); } /* p1_comment */ /* p1_name -- Writes the address of a hash table entry into the intermediate file */ static void #ifdef KR_headers p1_name(namep) Namep namep; #else p1_name(Namep namep) #endif { p1putd (P1_NAME_POINTER, (long) namep); namep->visused = 1; } /* p1_name */ void #ifdef KR_headers p1_expr(expr) expptr expr; #else p1_expr(expptr expr) #endif { /* An opcode of 0 means a null entry */ if (expr == ENULL) { p1putdd (P1_EXPR, 0, TYUNKNOWN); /* Should this be TYERROR? */ return; } /* if (expr == ENULL) */ switch (expr -> tag) { case TNAME: p1_name ((Namep) expr); return; case TCONST: p1_const(&expr->constblock); return; case TEXPR: /* Fall through the switch */ break; case TADDR: p1_addr (&(expr -> addrblock)); goto freeup; case TPRIM: warn ("p1_expr: got TPRIM"); return; case TLIST: p1_list (&(expr->listblock)); frchain( &(expr->listblock.listp) ); return; case TERROR: return; default: erri ("p1_expr: bad tag '%d'", (int) (expr -> tag)); return; } /* Now we know that the tag is TEXPR */ if (is_unary_op (expr -> exprblock.opcode)) p1_unary (&(expr -> exprblock)); else if (is_binary_op (expr -> exprblock.opcode)) p1_binary (&(expr -> exprblock)); else erri ("p1_expr: bad opcode '%d'", (int) expr -> exprblock.opcode); freeup: free((char *)expr); } /* p1_expr */ static void #ifdef KR_headers p1_const(cp) register Constp cp; #else p1_const(register Constp cp) #endif { int type = cp->vtype; expptr vleng = cp->vleng; union Constant *c = &cp->Const; char cdsbuf0[64], cdsbuf1[64]; char *cds0, *cds1; switch (type) { case TYINT1: case TYSHORT: case TYLONG: #ifdef TYQUAD0 case TYQUAD: #endif case TYLOGICAL: case TYLOGICAL1: case TYLOGICAL2: fprintf(pass1_file, "%d: %d %ld\n", P1_CONST, type, c->ci); break; #ifndef NO_LONG_LONG case TYQUAD: fprintf(pass1_file, "%d: %d %llx\n", P1_CONST, type, c->cq); break; #endif case TYREAL: case TYDREAL: fprintf(pass1_file, "%d: %d %s\n", P1_CONST, type, cp->vstg ? c->cds[0] : cds(dtos(c->cd[0]), cdsbuf0)); break; case TYCOMPLEX: case TYDCOMPLEX: if (cp->vstg) { cds0 = c->cds[0]; cds1 = c->cds[1]; } else { cds0 = cds(dtos(c->cd[0]), cdsbuf0); cds1 = cds(dtos(c->cd[1]), cdsbuf1); } fprintf(pass1_file, "%d: %d %s %s\n", P1_CONST, type, cds0, cds1); break; case TYCHAR: if (vleng && !ISICON (vleng)) err("p1_const: bad vleng\n"); else fprintf(pass1_file, "%d: %d %lx\n", P1_CONST, type, (unsigned long)cpexpr((expptr)cp)); break; default: erri ("p1_const: bad constant type '%d'", type); break; } /* switch */ } /* p1_const */ void #ifdef KR_headers p1_asgoto(addrp) Addrp addrp; #else p1_asgoto(Addrp addrp) #endif { p1put (P1_ASGOTO); p1_addr (addrp); } /* p1_asgoto */ void #ifdef KR_headers p1_goto(stateno) ftnint stateno; #else p1_goto(ftnint stateno) #endif { p1putd (P1_GOTO, stateno); } /* p1_goto */ static void #ifdef KR_headers p1_addr(addrp) register struct Addrblock *addrp; #else p1_addr(register struct Addrblock *addrp) #endif { int stg; if (addrp == (struct Addrblock *) NULL) return; stg = addrp -> vstg; if (ONEOF(stg, M(STGINIT)|M(STGREG)) || ONEOF(stg, M(STGCOMMON)|M(STGEQUIV)) && (!ISICON(addrp->memoffset) || (addrp->uname_tag == UNAM_NAME ? addrp->memoffset->constblock.Const.ci != addrp->user.name->voffset : addrp->memoffset->constblock.Const.ci)) || ONEOF(stg, M(STGBSS)|M(STGINIT)|M(STGAUTO)|M(STGARG)) && (!ISICON(addrp->memoffset) || addrp->memoffset->constblock.Const.ci) || addrp->Field || addrp->isarray || addrp->vstg == STGLENG) { p1_big_addr (addrp); return; } /* Write out a level of indirection for non-array arguments, which have addrp -> memoffset set and are handled by p1_big_addr(). Lengths are passed by value, so don't check STGLENG 28-Jun-89 (dmg) Added the check for != TYCHAR */ if (oneof_stg ( addrp -> uname_tag == UNAM_NAME ? addrp -> user.name : NULL, stg, M(STGARG)|M(STGEQUIV)) && addrp->vtype != TYCHAR) { p1putdd (P1_EXPR, OPWHATSIN, addrp -> vtype); p1_expr (ENULL); /* Put dummy vleng */ } /* if stg == STGARG */ switch (addrp -> uname_tag) { case UNAM_NAME: p1_name (addrp -> user.name); break; case UNAM_IDENT: p1putdds(P1_IDENT, addrp->vtype, addrp->vstg, addrp->user.ident); break; case UNAM_CHARP: p1putdds(P1_CHARP, addrp->vtype, addrp->vstg, addrp->user.Charp); break; case UNAM_EXTERN: p1putd (P1_EXTERN, (long) addrp -> memno); if (addrp->vclass == CLPROC) extsymtab[addrp->memno].extype = addrp->vtype; break; case UNAM_CONST: if (addrp -> memno != BAD_MEMNO) p1_literal (addrp -> memno); else p1_const((struct Constblock *)addrp); break; case UNAM_UNKNOWN: default: erri ("p1_addr: unknown uname_tag '%d'", addrp -> uname_tag); break; } /* switch */ } /* p1_addr */ static void #ifdef KR_headers p1_list(listp) struct Listblock *listp; #else p1_list(struct Listblock *listp) #endif { chainp lis; int count = 0; if (listp == (struct Listblock *) NULL) return; /* Count the number of parameters in the list */ for (lis = listp -> listp; lis; lis = lis -> nextp) count++; p1putddd (P1_LIST, listp -> tag, listp -> vtype, count); for (lis = listp -> listp; lis; lis = lis -> nextp) p1_expr ((expptr) lis -> datap); } /* p1_list */ void #ifdef KR_headers p1_label(lab) long lab; #else p1_label(long lab) #endif { if (parstate < INDATA) earlylabs = mkchain((char *)lab, earlylabs); else p1putd (P1_LABEL, lab); } static void #ifdef KR_headers p1_literal(memno) long memno; #else p1_literal(long memno) #endif { p1putd (P1_LITERAL, memno); } /* p1_literal */ void #ifdef KR_headers p1_if(expr) expptr expr; #else p1_if(expptr expr) #endif { p1put (P1_IF); p1_expr (expr); } /* p1_if */ void #ifdef KR_headers p1_elif(expr) expptr expr; #else p1_elif(expptr expr) #endif { p1put (P1_ELIF); p1_expr (expr); } /* p1_elif */ void p1_else(Void) { p1put (P1_ELSE); } /* p1_else */ void p1_endif(Void) { p1put (P1_ENDIF); } /* p1_endif */ void p1else_end(Void) { p1put (P1_ENDELSE); } /* p1else_end */ static void #ifdef KR_headers p1_big_addr(addrp) Addrp addrp; #else p1_big_addr(Addrp addrp) #endif { if (addrp == (Addrp) NULL) return; p1putn (P1_ADDR, (int)sizeof(struct Addrblock), (char *) addrp); p1_expr (addrp -> vleng); p1_expr (addrp -> memoffset); if (addrp->uname_tag == UNAM_NAME) addrp->user.name->visused = 1; } /* p1_big_addr */ static void #ifdef KR_headers p1_unary(e) struct Exprblock *e; #else p1_unary(struct Exprblock *e) #endif { if (e == (struct Exprblock *) NULL) return; p1putdd (P1_EXPR, (int) e -> opcode, e -> vtype); p1_expr (e -> vleng); switch (e -> opcode) { case OPNEG: case OPNEG1: case OPNOT: case OPABS: case OPBITNOT: case OPPREINC: case OPPREDEC: case OPADDR: case OPIDENTITY: case OPCHARCAST: case OPDABS: p1_expr(e -> leftp); break; default: erri ("p1_unary: bad opcode '%d'", (int) e -> opcode); break; } /* switch */ } /* p1_unary */ static void #ifdef KR_headers p1_binary(e) struct Exprblock *e; #else p1_binary(struct Exprblock *e) #endif { if (e == (struct Exprblock *) NULL) return; p1putdd (P1_EXPR, e -> opcode, e -> vtype); p1_expr (e -> vleng); p1_expr (e -> leftp); p1_expr (e -> rightp); } /* p1_binary */ void #ifdef KR_headers p1_head(Class, name) int Class; char *name; #else p1_head(int Class, char *name) #endif { p1putds (P1_HEAD, Class, (char*)(name ? name : "")); } /* p1_head */ void #ifdef KR_headers p1_subr_ret(retexp) expptr retexp; #else p1_subr_ret(expptr retexp) #endif { p1put (P1_SUBR_RET); p1_expr (cpexpr(retexp)); } /* p1_subr_ret */ void #ifdef KR_headers p1comp_goto(index, count, labels) expptr index; int count; struct Labelblock **labels; #else p1comp_goto(expptr index, int count, struct Labelblock **labels) #endif { struct Constblock c; int i; register struct Labelblock *L; p1put (P1_COMP_GOTO); p1_expr (index); /* Write out a P1_LIST directly, to avoid the overhead of allocating a list before it's needed HACK HACK HACK */ p1putddd (P1_LIST, TLIST, TYUNKNOWN, count); c.vtype = TYLONG; c.vleng = 0; for (i = 0; i < count; i++) { L = labels[i]; L->labused = 1; c.Const.ci = L->stateno; p1_const(&c); } /* for i = 0 */ } /* p1comp_goto */ void #ifdef KR_headers p1_for(init, test, inc) expptr init; expptr test; expptr inc; #else p1_for(expptr init, expptr test, expptr inc) #endif { p1put (P1_FOR); p1_expr (init); p1_expr (test); p1_expr (inc); } /* p1_for */ void p1for_end(Void) { p1put (P1_ENDFOR); } /* p1for_end */ /* ---------------------------------------------------------------------- The intermediate file actually gets written ONLY by the routines below. To change the format of the file, you need only change these routines. ---------------------------------------------------------------------- */ /* p1puts -- Put a typed string into the Pass 1 intermediate file. Assumes that str contains no newlines and is null-terminated. */ void #ifdef KR_headers p1puts(type, str) int type; char *str; #else p1puts(int type, char *str) #endif { fprintf (pass1_file, "%d: %s\n", type, str); } /* p1puts */ /* p1putd -- Put a typed integer into the Pass 1 intermediate file. */ static void #ifdef KR_headers p1putd(type, value) int type; long value; #else p1putd(int type, long value) #endif { fprintf (pass1_file, "%d: %ld\n", type, value); } /* p1_putd */ /* p1putdd -- Put a typed pair of integers into the intermediate file. */ static void #ifdef KR_headers p1putdd(type, v1, v2) int type; int v1; int v2; #else p1putdd(int type, int v1, int v2) #endif { fprintf (pass1_file, "%d: %d %d\n", type, v1, v2); } /* p1putdd */ /* p1putddd -- Put a typed triple of integers into the intermediate file. */ static void #ifdef KR_headers p1putddd(type, v1, v2, v3) int type; int v1; int v2; int v3; #else p1putddd(int type, int v1, int v2, int v3) #endif { fprintf (pass1_file, "%d: %d %d %d\n", type, v1, v2, v3); } /* p1putddd */ union dL { double d; long L[2]; }; static void #ifdef KR_headers p1putn(type, count, str) int type; int count; char *str; #else p1putn(int type, int count, char *str) #endif { int i; fprintf (pass1_file, "%d: ", type); for (i = 0; i < count; i++) putc (str[i], pass1_file); putc ('\n', pass1_file); } /* p1putn */ /* p1put -- Put a type marker into the intermediate file. */ void #ifdef KR_headers p1put(type) int type; #else p1put(int type) #endif { fprintf (pass1_file, "%d:\n", type); } /* p1put */ static void #ifdef KR_headers p1putds(type, i, str) int type; int i; char *str; #else p1putds(int type, int i, char *str) #endif { fprintf (pass1_file, "%d: %d %s\n", type, i, str); } /* p1putds */ static void #ifdef KR_headers p1putdds(token, type, stg, str) int token; int type; int stg; char *str; #else p1putdds(int token, int type, int stg, char *str) #endif { fprintf (pass1_file, "%d: %d %d %s\n", token, type, stg, str); } /* p1putdds */ f2c/src/parse.h000066400000000000000000000021371171647030000136040ustar00rootroot00000000000000#ifndef PARSE_INCLUDE #define PARSE_INCLUDE /* macros for the parse_args routine */ #define P_STRING 1 /* Macros for the result_type attribute */ #define P_CHAR 2 #define P_SHORT 3 #define P_INT 4 #define P_LONG 5 #define P_FILE 6 #define P_OLD_FILE 7 #define P_NEW_FILE 8 #define P_FLOAT 9 #define P_DOUBLE 10 #define P_CASE_INSENSITIVE 01 /* Macros for the flags attribute */ #define P_REQUIRED_PREFIX 02 #define P_NO_ARGS 0 /* Macros for the arg_count attribute */ #define P_ONE_ARG 1 #define P_INFINITE_ARGS 2 #define p_entry(pref,swit,flag,count,type,store,size) \ { (pref), (swit), (flag), (count), (type), (int *) (store), (size) } typedef struct { char *prefix; char *string; int flags; int count; int result_type; int *result_ptr; int table_size; } arg_info; #ifdef KR_headers #define Argdcl(x) () #else #define Argdcl(x) x #endif int arg_verify Argdcl((char**, arg_info*, int)); void init_store Argdcl((arg_info*, int)); int match_table Argdcl((char*, arg_info*, int, int, int*)); int parse_args Argdcl((int, char**, arg_info*, int, char**, int)); #endif f2c/src/parse_args.c000066400000000000000000000335011171647030000146120ustar00rootroot00000000000000/**************************************************************** Copyright 1990, 1994-5, 2001 by AT&T, Lucent Technologies and Bellcore. Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the above copyright notice appear in all copies and that both that the copyright notice and this permission notice and warranty disclaimer appear in supporting documentation, and that the names of AT&T, Bell Laboratories, Lucent or Bellcore or any of their entities not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. AT&T, Lucent and Bellcore disclaim all warranties with regard to this software, including all implied warranties of merchantability and fitness. In no event shall AT&T, Lucent or Bellcore be liable for any special, indirect or consequential damages or any damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortious action, arising out of or in connection with the use or performance of this software. ****************************************************************/ /* parse_args This function will parse command line input into appropriate data structures, output error messages when appropriate and provide some minimal type conversion. Input to the function consists of the standard argc,argv values, and a table which directs the parser. Each table entry has the following components: prefix -- the (optional) switch character string, e.g. "-" "/" "=" switch -- the command string, e.g. "o" "data" "file" "F" flags -- control flags, e.g. CASE_INSENSITIVE, REQUIRED_PREFIX arg_count -- number of arguments this command requires, e.g. 0 for booleans, 1 for filenames, INFINITY for input files result_type -- how to interpret the switch arguments, e.g. STRING, CHAR, FILE, OLD_FILE, NEW_FILE result_ptr -- pointer to storage for the result, be it a table or a string or whatever table_size -- if the arguments fill a table, the maximum number of entries; if there are no arguments, the value to load into the result storage Although the table can be used to hold a list of filenames, only scalar values (e.g. pointers) can be stored in the table. No vector processing will be done, only pointers to string storage will be moved. An example entry, which could be used to parse input filenames, is: "-", "o", 0, oo, OLD_FILE, infilenames, INFILE_TABLE_SIZE */ #include #ifndef NULL /* ANSI C */ #include #endif #ifdef KR_headers extern double atof(); #else #include "stdlib.h" #include "string.h" #endif #include "parse.h" #include /* For atof */ #include #define MAX_INPUT_SIZE 1000 #define arg_prefix(x) ((x).prefix) #define arg_string(x) ((x).string) #define arg_flags(x) ((x).flags) #define arg_count(x) ((x).count) #define arg_result_type(x) ((x).result_type) #define arg_result_ptr(x) ((x).result_ptr) #define arg_table_size(x) ((x).table_size) #ifndef TRUE #define TRUE 1 #endif #ifndef FALSE #define FALSE 0 #endif typedef int boolean; static char *this_program = ""; static int arg_parse Argdcl((char*, arg_info*)); static char *lower_string Argdcl((char*, char*)); static int match Argdcl((char*, char*, arg_info*, boolean)); static int put_one_arg Argdcl((int, char*, char**, char*, char*)); extern int badargs; boolean #ifdef KR_headers parse_args(argc, argv, table, entries, others, other_count) int argc; char **argv; arg_info *table; int entries; char **others; int other_count; #else parse_args(int argc, char **argv, arg_info *table, int entries, char **others, int other_count) #endif { boolean result; if (argv) this_program = argv[0]; /* Check the validity of the table and its parameters */ result = arg_verify (argv, table, entries); /* Initialize the storage values */ init_store (table, entries); if (result) { boolean use_prefix = TRUE; char *argv0; argc--; argv0 = *++argv; while (argc) { int index, length; index = match_table (*argv, table, entries, use_prefix, &length); if (index < 0) { /* The argument doesn't match anything in the table */ if (others) { if (*argv > argv0) *--*argv = '-'; /* complain at invalid flag */ if (other_count > 0) { *others++ = *argv; other_count--; } else { fprintf (stderr, "%s: too many parameters: ", this_program); fprintf (stderr, "'%s' ignored\n", *argv); badargs++; } /* else */ } /* if (others) */ argv0 = *++argv; argc--; use_prefix = TRUE; } else { /* A match was found */ if (length >= strlen (*argv)) { argc--; argv0 = *++argv; use_prefix = TRUE; } else { (*argv) += length; use_prefix = FALSE; } /* else */ /* Parse any necessary arguments */ if (arg_count (table[index]) != P_NO_ARGS) { /* Now length will be used to store the number of parsed characters */ length = arg_parse(*argv, &table[index]); if (*argv == NULL) argc = 0; else if (length >= strlen (*argv)) { argc--; argv0 = *++argv; use_prefix = TRUE; } else { (*argv) += length; use_prefix = FALSE; } /* else */ } /* if (argv_count != P_NO_ARGS) */ else *arg_result_ptr(table[index]) = arg_table_size(table[index]); } /* else */ } /* while (argc) */ } /* if (result) */ return result; } /* parse_args */ boolean #ifdef KR_headers arg_verify(argv, table, entries) char **argv; arg_info *table; int entries; #else arg_verify(char **argv, arg_info *table, int entries) #endif { int i; char *this_program = ""; if (argv) this_program = argv[0]; for (i = 0; i < entries; i++) { arg_info *arg = &table[i]; /* Check the argument flags */ if (arg_flags (*arg) & ~(P_CASE_INSENSITIVE | P_REQUIRED_PREFIX)) { fprintf (stderr, "%s [arg_verify]: too many ", this_program); fprintf (stderr, "flags in entry %d: '%x' (hex)\n", i, arg_flags (*arg)); badargs++; } /* if */ /* Check the argument count */ { int count = arg_count (*arg); if (count != P_NO_ARGS && count != P_ONE_ARG && count != P_INFINITE_ARGS) { fprintf (stderr, "%s [arg_verify]: invalid ", this_program); fprintf (stderr, "argument count in entry %d: '%d'\n", i, count); badargs++; } /* if count != P_NO_ARGS ... */ /* Check the result field; want to be able to store results */ else if (arg_result_ptr (*arg) == (int *) NULL) { fprintf (stderr, "%s [arg_verify]: ", this_program); fprintf (stderr, "no argument storage given for "); fprintf (stderr, "entry %d\n", i); badargs++; } /* if arg_result_ptr */ } /* Check the argument type */ { int type = arg_result_type (*arg); if (type < P_STRING || type > P_DOUBLE) { fprintf(stderr, "%s [arg_verify]: bad arg type in entry %d: '%d'\n", this_program, i, type); badargs++; } } /* Check table size */ { int size = arg_table_size (*arg); if (arg_count (*arg) == P_INFINITE_ARGS && size < 1) { fprintf (stderr, "%s [arg_verify]: bad ", this_program); fprintf (stderr, "table size in entry %d: '%d'\n", i, size); badargs++; } /* if (arg_count == P_INFINITE_ARGS && size < 1) */ } } /* for i = 0 */ return TRUE; } /* arg_verify */ /* match_table -- returns the index of the best entry matching the input, -1 if no match. The best match is the one of longest length which appears lowest in the table. The length of the match will be returned in length ONLY IF a match was found. */ int #ifdef KR_headers match_table(norm_input, table, entries, use_prefix, length) register char *norm_input; arg_info *table; int entries; boolean use_prefix; int *length; #else match_table(register char *norm_input, arg_info *table, int entries, boolean use_prefix, int *length) #endif { char low_input[MAX_INPUT_SIZE]; register int i; int best_index = -1, best_length = 0; /* FUNCTION BODY */ (void) lower_string (low_input, norm_input); for (i = 0; i < entries; i++) { int this_length = match(norm_input, low_input, &table[i], use_prefix); if (this_length > best_length) { best_index = i; best_length = this_length; } /* if (this_length > best_length) */ } /* for (i = 0) */ if (best_index > -1 && length != (int *) NULL) *length = best_length; return best_index; } /* match_table */ /* match -- takes an input string and table entry, and returns the length of the longer match. 0 ==> input doesn't match For example: INPUT PREFIX STRING RESULT ---------------------------------------------------------------------- "abcd" "-" "d" 0 "-d" "-" "d" 2 (i.e. "-d") "dout" "-" "d" 1 (i.e. "d") "-d" "" "-d" 2 (i.e. "-d") "dd" "d" "d" 2 <= here's the weird one */ static int #ifdef KR_headers match(norm_input, low_input, entry, use_prefix) char *norm_input; char *low_input; arg_info *entry; boolean use_prefix; #else match(char *norm_input, char *low_input, arg_info *entry, boolean use_prefix) #endif { char *norm_prefix = arg_prefix (*entry); char *norm_string = arg_string (*entry); boolean prefix_match = FALSE, string_match = FALSE; int result = 0; /* Buffers for the lowercased versions of the strings being compared. These are used when the switch is to be case insensitive */ static char low_prefix[MAX_INPUT_SIZE]; static char low_string[MAX_INPUT_SIZE]; int prefix_length = strlen (norm_prefix); int string_length = strlen (norm_string); /* Pointers for the required strings (lowered or nonlowered) */ register char *input, *prefix, *string; /* FUNCTION BODY */ /* Use the appropriate strings to handle case sensitivity */ if (arg_flags (*entry) & P_CASE_INSENSITIVE) { input = low_input; prefix = lower_string (low_prefix, norm_prefix); string = lower_string (low_string, norm_string); } else { input = norm_input; prefix = norm_prefix; string = norm_string; } /* else */ /* First, check the string formed by concatenating the prefix onto the switch string, but only when the prefix is not being ignored */ if (use_prefix && prefix != NULL && *prefix != '\0') prefix_match = (strncmp (input, prefix, prefix_length) == 0) && (strncmp (input + prefix_length, string, string_length) == 0); /* Next, check just the switch string, if that's allowed */ if (!use_prefix && (arg_flags (*entry) & P_REQUIRED_PREFIX) == 0) string_match = strncmp (input, string, string_length) == 0; if (prefix_match) result = prefix_length + string_length; else if (string_match) result = string_length; return result; } /* match */ static char * #ifdef KR_headers lower_string(dest, src) char *dest; char *src; #else lower_string(char *dest, char *src) #endif { char *result = dest; register int c; if (dest == NULL || src == NULL) result = NULL; else while (*dest++ = (c = *src++) >= 'A' && c <= 'Z' ? tolower(c) : c); return result; } /* lower_string */ /* arg_parse -- returns the number of characters parsed for this entry */ static int #ifdef KR_headers arg_parse(str, entry) char *str; arg_info *entry; #else arg_parse(char *str, arg_info *entry) #endif { int length = 0; if (arg_count (*entry) == P_ONE_ARG) { char **store = (char **) arg_result_ptr (*entry); length = put_one_arg (arg_result_type (*entry), str, store, arg_prefix (*entry), arg_string (*entry)); } /* if (arg_count == P_ONE_ARG) */ else { /* Must be a table of arguments */ char **store = (char **) arg_result_ptr (*entry); if (store) { while (*store) store++; length = put_one_arg(arg_result_type (*entry), str, store++, arg_prefix (*entry), arg_string (*entry)); *store = (char *) NULL; } /* if (store) */ } /* else */ return length; } /* arg_parse */ static int #ifdef KR_headers put_one_arg(type, str, store, prefix, string) int type; char *str; char **store; char *prefix; char *string; #else put_one_arg(int type, char *str, char **store, char *prefix, char *string) #endif { int length = 0; long L; if (store) { switch (type) { case P_STRING: case P_FILE: case P_OLD_FILE: case P_NEW_FILE: if (str == NULL) { fprintf(stderr, "%s: Missing argument after '%s%s'\n", this_program, prefix, string); length = 0; badargs++; } else length = strlen(*store = str); break; case P_CHAR: *((char *) store) = *str; length = 1; break; case P_SHORT: L = atol(str); *(short *)store = (short) L; if (L != *(short *)store) { fprintf(stderr, "%s%s parameter '%ld' is not a SHORT INT (truncating to %d)\n", prefix, string, L, *(short *)store); badargs++; } length = strlen (str); break; case P_INT: L = atol(str); *(int *)store = (int)L; if (L != *(int *)store) { fprintf(stderr, "%s%s parameter '%ld' is not an INT (truncating to %d)\n", prefix, string, L, *(int *)store); badargs++; } length = strlen (str); break; case P_LONG: *(long *)store = atol(str); length = strlen (str); break; case P_FLOAT: *((float *) store) = (float) atof(str); length = strlen (str); break; case P_DOUBLE: *((double *) store) = (double) atof(str); length = strlen (str); break; default: fprintf (stderr, "put_one_arg: bad type '%d'\n", type); badargs++; break; } /* switch */ } /* if (store) */ return length; } /* put_one_arg */ void #ifdef KR_headers init_store(table, entries) arg_info *table; int entries; #else init_store(arg_info *table, int entries) #endif { int index; for (index = 0; index < entries; index++) if (arg_count (table[index]) == P_INFINITE_ARGS) { char **place = (char **) arg_result_ptr (table[index]); if (place) *place = (char *) NULL; } /* if arg_count == P_INFINITE_ARGS */ } /* init_store */ f2c/src/pccdefs.h000066400000000000000000000022531171647030000141000ustar00rootroot00000000000000/* The following numbers are strange, and implementation-dependent */ #define P2BAD -1 #define P2NAME 2 #define P2ICON 4 /* Integer constant */ #define P2PLUS 6 #define P2PLUSEQ 7 #define P2MINUS 8 #define P2NEG 10 #define P2STAR 11 #define P2STAREQ 12 #define P2INDIRECT 13 #define P2BITAND 14 #define P2BITOR 17 #define P2BITXOR 19 #define P2QUEST 21 #define P2COLON 22 #define P2ANDAND 23 #define P2OROR 24 #define P2GOTO 37 #define P2LISTOP 56 #define P2ASSIGN 58 #define P2COMOP 59 #define P2SLASH 60 #define P2MOD 62 #define P2LSHIFT 64 #define P2RSHIFT 66 #define P2CALL 70 #define P2CALL0 72 #define P2NOT 76 #define P2BITNOT 77 #define P2EQ 80 #define P2NE 81 #define P2LE 82 #define P2LT 83 #define P2GE 84 #define P2GT 85 #define P2REG 94 #define P2OREG 95 #define P2CONV 104 #define P2FORCE 108 #define P2CBRANCH 109 /* special operators included only for fortran's use */ #define P2PASS 200 #define P2STMT 201 #define P2SWITCH 202 #define P2LBRACKET 203 #define P2RBRACKET 204 #define P2EOF 205 #define P2ARIF 206 #define P2LABEL 207 #define P2SHORT 3 #define P2INT 4 #define P2LONG 4 #define P2CHAR 2 #define P2REAL 6 #define P2DREAL 7 #define P2PTR 020 #define P2FUNCT 040 f2c/src/pread.c000066400000000000000000000426471171647030000135720ustar00rootroot00000000000000/**************************************************************** Copyright 1990, 1992, 1993, 1994, 2000 by AT&T, Lucent Technologies and Bellcore. Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the above copyright notice appear in all copies and that both that the copyright notice and this permission notice and warranty disclaimer appear in supporting documentation, and that the names of AT&T, Bell Laboratories, Lucent or Bellcore or any of their entities not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. AT&T, Lucent and Bellcore disclaim all warranties with regard to this software, including all implied warranties of merchantability and fitness. In no event shall AT&T, Lucent or Bellcore be liable for any special, indirect or consequential damages or any damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortious action, arising out of or in connection with the use or performance of this software. ****************************************************************/ #include "defs.h" static char Ptok[128], Pct[Table_size]; static char *Pfname; static long Plineno; static int Pbad; static int *tfirst, *tlast, *tnext, tmax; #define P_space 1 #define P_anum 2 #define P_delim 3 #define P_slash 4 #define TGULP 100 static void trealloc(Void) { int k = tmax; tfirst = (int *)realloc((char *)tfirst, (tmax += TGULP)*sizeof(int)); if (!tfirst) { fprintf(stderr, "Pfile: realloc failure!\n"); exit(2); } tlast = tfirst + tmax; tnext = tfirst + k; } static void #ifdef KR_headers badchar(c) int c; #else badchar(int c) #endif { fprintf(stderr, "unexpected character 0x%.2x = '%c' on line %ld of %s\n", c, c, Plineno, Pfname); exit(2); } static void bad_type(Void) { fprintf(stderr, "unexpected type \"%s\" on line %ld of %s\n", Ptok, Plineno, Pfname); exit(2); } static void #ifdef KR_headers badflag(tname, option) char *tname; char *option; #else badflag(char *tname, char *option) #endif { fprintf(stderr, "%s type from `f2c -%s` on line %ld of %s\n", tname, option, Plineno, Pfname); Pbad++; } static void #ifdef KR_headers detected(msg) char *msg; #else detected(char *msg) #endif { fprintf(stderr, "%sdetected on line %ld of %s\n", msg, Plineno, Pfname); Pbad++; } #if 0 static void #ifdef KR_headers checklogical(k) int k; #else checklogical(int k) #endif { static int lastmsg = 0; static int seen[2] = {0,0}; seen[k] = 1; if (seen[1-k]) { if (lastmsg < 3) { lastmsg = 3; detected( "Illegal combination of LOGICAL types -- mixing -I4 with -I2 or -i2\n\t"); } return; } if (k) { if (tylogical == TYLONG || lastmsg >= 2) return; if (!lastmsg) { lastmsg = 2; badflag("LOGICAL", "I4"); } } else { if (tylogical == TYSHORT || lastmsg & 1) return; if (!lastmsg) { lastmsg = 1; badflag("LOGICAL", "i2` or `f2c -I2"); } } } #else #define checklogical(n) /* */ #endif static void #ifdef KR_headers checkreal(k) int k; #else checkreal(int k) #endif { static int warned = 0; static int seen[2] = {0,0}; seen[k] = 1; if (seen[1-k]) { if (warned < 2) detected("Illegal mixture of -R and -!R "); warned = 2; return; } if (k == forcedouble || warned) return; warned = 1; badflag("REAL return", (char*)(k ? "!R" : "R")); } static void #ifdef KR_headers Pnotboth(e) Extsym *e; #else Pnotboth(Extsym *e) #endif { if (e->curno) return; Pbad++; e->curno = 1; fprintf(stderr, "%s cannot be both a procedure and a common block (line %ld of %s)\n", e->fextname, Plineno, Pfname); } static int #ifdef KR_headers numread(pf, n) register FILE *pf; int *n; #else numread(register FILE *pf, int *n) #endif { register int c, k; if ((c = getc(pf)) < '0' || c > '9') return c; k = c - '0'; for(;;) { if ((c = getc(pf)) == ' ') { *n = k; return c; } if (c < '0' || c > '9') break; k = 10*k + c - '0'; } return c; } static void argverify Argdcl((int, Extsym*)); static void Pbadret Argdcl((int ftype, Extsym *p)); static int #ifdef KR_headers readref(pf, e, ftype) register FILE *pf; Extsym *e; int ftype; #else readref(register FILE *pf, Extsym *e, int ftype) #endif { register int c, *t; int i, nargs, type; Argtypes *at; Atype *a, *ae; if (ftype > TYSUBR) return 0; if ((c = numread(pf, &nargs)) != ' ') { if (c != ':') return c == EOF; /* just a typed external */ if (e->extstg == STGUNKNOWN) { at = 0; goto justsym; } if (e->extstg == STGEXT) { if (e->extype != ftype) Pbadret(ftype, e); } else Pnotboth(e); return 0; } tnext = tfirst; for(i = 0; i < nargs; i++) { if ((c = numread(pf, &type)) != ' ' || type >= 500 || type != TYFTNLEN + 100 && type % 100 > TYSUBR) return c == EOF; if (tnext >= tlast) trealloc(); *tnext++ = type; } if (e->extstg == STGUNKNOWN) { save_at: at = (Argtypes *) gmem(sizeof(Argtypes) + (nargs-1)*sizeof(Atype), 1); at->dnargs = at->nargs = nargs; at->changes = 0; t = tfirst; a = at->atypes; for(ae = a + nargs; a < ae; a++) { a->type = *t++; a->cp = 0; } justsym: e->extstg = STGEXT; e->extype = ftype; e->arginfo = at; } else if (e->extstg != STGEXT) { Pnotboth(e); } else if (!e->arginfo) { if (e->extype != ftype) Pbadret(ftype, e); else goto save_at; } else argverify(ftype, e); return 0; } static int #ifdef KR_headers comlen(pf) register FILE *pf; #else comlen(register FILE *pf) #endif { register int c; register char *s, *se; char buf[128], cbuf[128]; int refread; long L; Extsym *e; if ((c = getc(pf)) == EOF) return 1; if (c == ' ') { refread = 0; s = "comlen "; } else if (c == ':') { refread = 1; s = "ref: "; } else { ret0: if (c == '*') ungetc(c,pf); return 0; } while(*s) { if ((c = getc(pf)) == EOF) return 1; if (c != *s++) goto ret0; } s = buf; se = buf + sizeof(buf) - 1; for(;;) { if ((c = getc(pf)) == EOF) return 1; if (c == ' ') break; if (s >= se || Pct[c] != P_anum) goto ret0; *s++ = c; } *s-- = 0; if (s <= buf || *s != '_') return 0; strcpy(cbuf,buf); *s-- = 0; if (*s == '_') { *s-- = 0; if (s <= buf) return 0; } for(L = 0;;) { if ((c = getc(pf)) == EOF) return 1; if (c == ' ') break; if (c < '0' && c > '9') goto ret0; L = 10*L + c - '0'; } if (!L && !refread) return 0; e = mkext1(buf, cbuf); if (refread) return readref(pf, e, (int)L); if (e->extstg == STGUNKNOWN) { e->extstg = STGCOMMON; e->maxleng = L; } else if (e->extstg != STGCOMMON) Pnotboth(e); else if (e->maxleng != L) { fprintf(stderr, "incompatible lengths for common block %s (line %ld of %s)\n", buf, Plineno, Pfname); if (e->maxleng < L) e->maxleng = L; } return 0; } static int #ifdef KR_headers Ptoken(pf, canend) FILE *pf; int canend; #else Ptoken(FILE *pf, int canend) #endif { register int c; register char *s, *se; top: for(;;) { c = getc(pf); if (c == EOF) { if (canend) return 0; goto badeof; } if (Pct[c] != P_space) break; if (c == '\n') Plineno++; } switch(Pct[c]) { case P_anum: if (c == '_') badchar(c); s = Ptok; se = s + sizeof(Ptok) - 1; do { if (s < se) *s++ = c; if ((c = getc(pf)) == EOF) { badeof: fprintf(stderr, "unexpected end of file in %s\n", Pfname); exit(2); } } while(Pct[c] == P_anum); ungetc(c,pf); *s = 0; return P_anum; case P_delim: return c; case P_slash: if ((c = getc(pf)) != '*') { if (c == EOF) goto badeof; badchar('/'); } if (canend && comlen(pf)) goto badeof; for(;;) { while((c = getc(pf)) != '*') { if (c == EOF) goto badeof; if (c == '\n') Plineno++; } slashseek: switch(getc(pf)) { case '/': goto top; case EOF: goto badeof; case '*': goto slashseek; } } default: badchar(c); } /* NOT REACHED */ return 0; } static int Pftype(Void) { switch(Ptok[0]) { case 'C': if (!strcmp(Ptok+1, "_f")) return TYCOMPLEX; break; case 'E': if (!strcmp(Ptok+1, "_f")) { /* TYREAL under forcedouble */ checkreal(1); return TYREAL; } break; case 'H': if (!strcmp(Ptok+1, "_f")) return TYCHAR; break; case 'Z': if (!strcmp(Ptok+1, "_f")) return TYDCOMPLEX; break; case 'd': if (!strcmp(Ptok+1, "oublereal")) return TYDREAL; break; case 'i': if (!strcmp(Ptok+1, "nt")) return TYSUBR; if (!strcmp(Ptok+1, "nteger")) return TYLONG; if (!strcmp(Ptok+1, "nteger1")) return TYINT1; break; case 'l': if (!strcmp(Ptok+1, "ogical")) { checklogical(1); return TYLOGICAL; } if (!strcmp(Ptok+1, "ogical1")) return TYLOGICAL1; #ifdef TYQUAD if (!strcmp(Ptok+1, "ongint")) return TYQUAD; #endif break; case 'r': if (!strcmp(Ptok+1, "eal")) { checkreal(0); return TYREAL; } break; case 's': if (!strcmp(Ptok+1, "hortint")) return TYSHORT; if (!strcmp(Ptok+1, "hortlogical")) { checklogical(0); return TYLOGICAL2; } break; } bad_type(); /* NOT REACHED */ return 0; } static void #ifdef KR_headers wanted(i, what) int i; char *what; #else wanted(int i, char *what) #endif { if (i != P_anum) { Ptok[0] = i; Ptok[1] = 0; } fprintf(stderr,"Error: expected %s, not \"%s\" (line %ld of %s)\n", what, Ptok, Plineno, Pfname); exit(2); } static int #ifdef KR_headers Ptype(pf) FILE *pf; #else Ptype(FILE *pf) #endif { int i, rv; i = Ptoken(pf,0); if (i == ')') return 0; if (i != P_anum) badchar(i); rv = 0; switch(Ptok[0]) { case 'C': if (!strcmp(Ptok+1, "_fp")) rv = TYCOMPLEX+200; break; case 'D': if (!strcmp(Ptok+1, "_fp")) rv = TYDREAL+200; break; case 'E': case 'R': if (!strcmp(Ptok+1, "_fp")) rv = TYREAL+200; break; case 'H': if (!strcmp(Ptok+1, "_fp")) rv = TYCHAR+200; break; case 'I': if (!strcmp(Ptok+1, "_fp")) rv = TYLONG+200; else if (!strcmp(Ptok+1, "1_fp")) rv = TYINT1+200; #ifdef TYQUAD else if (!strcmp(Ptok+1, "8_fp")) rv = TYQUAD+200; #endif break; case 'J': if (!strcmp(Ptok+1, "_fp")) rv = TYSHORT+200; break; case 'K': checklogical(0); goto Logical; case 'L': checklogical(1); Logical: if (!strcmp(Ptok+1, "_fp")) rv = TYLOGICAL+200; else if (!strcmp(Ptok+1, "1_fp")) rv = TYLOGICAL1+200; else if (!strcmp(Ptok+1, "2_fp")) rv = TYLOGICAL2+200; break; case 'S': if (!strcmp(Ptok+1, "_fp")) rv = TYSUBR+200; break; case 'U': if (!strcmp(Ptok+1, "_fp")) rv = TYUNKNOWN+300; break; case 'Z': if (!strcmp(Ptok+1, "_fp")) rv = TYDCOMPLEX+200; break; case 'c': if (!strcmp(Ptok+1, "har")) rv = TYCHAR; else if (!strcmp(Ptok+1, "omplex")) rv = TYCOMPLEX; break; case 'd': if (!strcmp(Ptok+1, "oublereal")) rv = TYDREAL; else if (!strcmp(Ptok+1, "oublecomplex")) rv = TYDCOMPLEX; break; case 'f': if (!strcmp(Ptok+1, "tnlen")) rv = TYFTNLEN+100; break; case 'i': if (!strncmp(Ptok+1, "nteger", 6)) { if (!Ptok[7]) rv = TYLONG; else if (Ptok[7] == '1' && !Ptok[8]) rv = TYINT1; } break; case 'l': if (!strncmp(Ptok+1, "ogical", 6)) { if (!Ptok[7]) { checklogical(1); rv = TYLOGICAL; } else if (Ptok[7] == '1' && !Ptok[8]) rv = TYLOGICAL1; } #ifdef TYQUAD else if (!strcmp(Ptok+1,"ongint")) rv = TYQUAD; #endif break; case 'r': if (!strcmp(Ptok+1, "eal")) rv = TYREAL; break; case 's': if (!strcmp(Ptok+1, "hortint")) rv = TYSHORT; else if (!strcmp(Ptok+1, "hortlogical")) { checklogical(0); rv = TYLOGICAL2; } break; case 'v': if (tnext == tfirst && !strcmp(Ptok+1, "oid")) { if ((i = Ptoken(pf,0)) != /*(*/ ')') wanted(i, /*(*/ "\")\""); return 0; } } if (!rv) bad_type(); if (rv < 100 && (i = Ptoken(pf,0)) != '*') wanted(i, "\"*\""); if ((i = Ptoken(pf,0)) == P_anum) i = Ptoken(pf,0); /* skip variable name */ switch(i) { case ')': ungetc(i,pf); break; case ',': break; default: wanted(i, "\",\" or \")\""); } return rv; } static char * trimunder(Void) { register char *s; register int n; static char buf[128]; s = Ptok + strlen(Ptok) - 1; if (*s != '_') { fprintf(stderr, "warning: %s does not end in _ (line %ld of %s)\n", Ptok, Plineno, Pfname); return Ptok; } if (s[-1] == '_') s--; strncpy(buf, Ptok, n = s - Ptok); buf[n] = 0; return buf; } static void #ifdef KR_headers Pbadmsg(msg, p) char *msg; Extsym *p; #else Pbadmsg(char *msg, Extsym *p) #endif { Pbad++; fprintf(stderr, "%s for %s (line %ld of %s):\n\t", msg, p->fextname, Plineno, Pfname); p->arginfo->nargs = -1; } static void #ifdef KR_headers Pbadret(ftype, p) int ftype; Extsym *p; #else Pbadret(int ftype, Extsym *p) #endif { char buf1[32], buf2[32]; Pbadmsg("inconsistent types",p); fprintf(stderr, "here %s, previously %s\n", Argtype(ftype+200,buf1), Argtype(p->extype+200,buf2)); } static void #ifdef KR_headers argverify(ftype, p) int ftype; Extsym *p; #else argverify(int ftype, Extsym *p) #endif { Argtypes *at; register Atype *aty; int i, j, k; register int *t, *te; char buf1[32], buf2[32]; at = p->arginfo; if (at->nargs < 0) return; if (p->extype != ftype) { Pbadret(ftype, p); return; } t = tfirst; te = tnext; i = te - t; if (at->nargs != i) { j = at->nargs; Pbadmsg("differing numbers of arguments",p); fprintf(stderr, "here %d, previously %d\n", i, j); return; } for(aty = at->atypes; t < te; t++, aty++) { if (*t == aty->type) continue; j = aty->type; k = *t; if (k >= 300 || k == j) continue; if (j >= 300) { if (k >= 200) { if (k == TYUNKNOWN + 200) continue; if (j % 100 != k - 200 && k != TYSUBR + 200 && j != TYUNKNOWN + 300 && !type_fixup(at,aty,k)) goto badtypes; } else if (j % 100 % TYSUBR != k % TYSUBR && !type_fixup(at,aty,k)) goto badtypes; } else if (k < 200 || j < 200) goto badtypes; else if (k == TYUNKNOWN+200) continue; else if (j != TYUNKNOWN+200) { badtypes: Pbadmsg("differing calling sequences",p); i = t - tfirst + 1; fprintf(stderr, "arg %d: here %s, prevously %s\n", i, Argtype(k,buf1), Argtype(j,buf2)); return; } /* We've subsequently learned the right type, as in the call on zoo below... subroutine foo(x, zap) external zap call goo(zap) x = zap(3) call zoo(zap) end */ aty->type = k; at->changes = 1; } } static void #ifdef KR_headers newarg(ftype, p) int ftype; Extsym *p; #else newarg(int ftype, Extsym *p) #endif { Argtypes *at; register Atype *aty; register int *t, *te; int i, k; if (p->extstg == STGCOMMON) { Pnotboth(p); return; } p->extstg = STGEXT; p->extype = ftype; p->exproto = 1; t = tfirst; te = tnext; i = te - t; k = sizeof(Argtypes) + (i-1)*sizeof(Atype); at = p->arginfo = (Argtypes *)gmem(k,1); at->dnargs = at->nargs = i; at->defined = at->changes = 0; for(aty = at->atypes; t < te; aty++) { aty->type = *t++; aty->cp = 0; } } static int #ifdef KR_headers Pfile(fname) char *fname; #else Pfile(char *fname) #endif { char *s; int ftype, i; FILE *pf; Extsym *p; for(s = fname; *s; s++); if (s - fname < 2 || s[-2] != '.' || (s[-1] != 'P' && s[-1] != 'p')) return 0; if (!(pf = fopen(fname, textread))) { fprintf(stderr, "can't open %s\n", fname); exit(2); } Pfname = fname; Plineno = 1; if (!Pct[' ']) { for(s = " \t\n\r\v\f"; *s; s++) Pct[*s] = P_space; for(s = "*,();"; *s; s++) Pct[*s] = P_delim; for(i = '0'; i <= '9'; i++) Pct[i] = P_anum; for(s = "abcdefghijklmnopqrstuvwxyz"; i = *s; s++) Pct[i] = Pct[i+'A'-'a'] = P_anum; Pct['_'] = P_anum; Pct['/'] = P_slash; } for(;;) { if (!(i = Ptoken(pf,1))) break; if (i != P_anum || !strcmp(Ptok, "extern") && (i = Ptoken(pf,0)) != P_anum) badchar(i); ftype = Pftype(); getname: if ((i = Ptoken(pf,0)) != P_anum) badchar(i); p = mkext1(trimunder(), Ptok); if ((i = Ptoken(pf,0)) != '(') badchar(i); tnext = tfirst; while(i = Ptype(pf)) { if (tnext >= tlast) trealloc(); *tnext++ = i; } if (p->arginfo) { argverify(ftype, p); if (p->arginfo->nargs < 0) newarg(ftype, p); } else newarg(ftype, p); p->arginfo->defined = 1; i = Ptoken(pf,0); switch(i) { case ';': break; case ',': goto getname; default: wanted(i, "\";\" or \",\""); } } fclose(pf); return 1; } void #ifdef KR_headers read_Pfiles(ffiles) char **ffiles; #else read_Pfiles(char **ffiles) #endif { char **f1files, **f1files0, *s; int k; register Extsym *e, *ee; register Argtypes *at; extern int retcode; f1files0 = f1files = ffiles; while(s = *ffiles++) if (!Pfile(s)) *f1files++ = s; if (Pbad) retcode = 8; if (tfirst) { free((char *)tfirst); /* following should be unnecessary, as we won't be back here */ tfirst = tnext = tlast = 0; tmax = 0; } *f1files = 0; if (f1files == f1files0) f1files[1] = 0; k = 0; ee = nextext; for (e = extsymtab; e < ee; e++) if (e->extstg == STGEXT && (at = e->arginfo)) { if (at->nargs < 0 || at->changes) k++; at->changes = 2; } if (k) { fprintf(diagfile, "%d prototype%s updated while reading prototypes.\n", k, k > 1 ? "s" : ""); } fflush(diagfile); } f2c/src/proc.c000066400000000000000000001144061171647030000134330ustar00rootroot00000000000000/**************************************************************** Copyright 1990, 1994-6, 2000-2001 by AT&T, Lucent Technologies and Bellcore. Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the above copyright notice appear in all copies and that both that the copyright notice and this permission notice and warranty disclaimer appear in supporting documentation, and that the names of AT&T, Bell Laboratories, Lucent or Bellcore or any of their entities not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. AT&T, Lucent and Bellcore disclaim all warranties with regard to this software, including all implied warranties of merchantability and fitness. In no event shall AT&T, Lucent or Bellcore be liable for any special, indirect or consequential damages or any damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortious action, arising out of or in connection with the use or performance of this software. ****************************************************************/ #include "defs.h" #include "names.h" #include "output.h" #include "p1defs.h" /* round a up to the nearest multiple of b: a = b * floor ( (a + (b - 1)) / b )*/ #undef roundup #define roundup(a,b) ( b * ( (a+b-1)/b) ) #define EXNULL (union Expression *)0 static void dobss Argdcl((void)); static void docomleng Argdcl((void)); static void docommon Argdcl((void)); static void doentry Argdcl((struct Entrypoint*)); static void epicode Argdcl((void)); static int nextarg Argdcl((int)); static void retval Argdcl((int)); static char Blank[] = BLANKCOMMON; static char *postfix[] = { "g", "h", "i", #ifdef TYQUAD "j", #endif "r", "d", "c", "z", "g", "h", "i" }; chainp new_procs; int prev_proc, proc_argchanges, proc_protochanges; void #ifdef KR_headers changedtype(q) Namep q; #else changedtype(Namep q) #endif { char buf[200]; int qtype, type1; register Extsym *e; Argtypes *at; if (q->vtypewarned) return; q->vtypewarned = 1; qtype = q->vtype; e = &extsymtab[q->vardesc.varno]; if (!(at = e->arginfo)) { if (!e->exused) return; } else if (at->changes & 2 && qtype != TYUNKNOWN && !at->defined) proc_protochanges++; type1 = e->extype; if (type1 == TYUNKNOWN) return; if (qtype == TYUNKNOWN) /* e.g., subroutine foo end external foo call goo(foo) end */ return; sprintf(buf, "%.90s: inconsistent declarations:\n\ here %s%s, previously %s%s.", q->fvarname, ftn_types[qtype], qtype == TYSUBR ? "" : " function", ftn_types[type1], type1 == TYSUBR ? "" : " function"); warn(buf); } void #ifdef KR_headers unamstring(q, s) register Addrp q; register char *s; #else unamstring(register Addrp q, register char *s) #endif { register int k; register char *t; k = strlen(s); if (k < IDENT_LEN) { q->uname_tag = UNAM_IDENT; t = q->user.ident; } else { q->uname_tag = UNAM_CHARP; q->user.Charp = t = mem(k+1, 0); } strcpy(t, s); } static void fix_entry_returns(Void) /* for multiple entry points */ { Addrp a; int i; struct Entrypoint *e; Namep np; e = entries = (struct Entrypoint *)revchain((chainp)entries); allargs = revchain(allargs); if (!multitype) return; /* TYLOGICAL should have been turned into TYLONG or TYSHORT by now */ for(i = TYINT1; i <= TYLOGICAL; i++) if (a = xretslot[i]) sprintf(a->user.ident, "(*ret_val).%s", postfix[i-TYINT1]); do { np = e->enamep; switch(np->vtype) { case TYINT1: case TYSHORT: case TYLONG: #ifdef TYQUAD case TYQUAD: #endif case TYREAL: case TYDREAL: case TYCOMPLEX: case TYDCOMPLEX: case TYLOGICAL1: case TYLOGICAL2: case TYLOGICAL: np->vstg = STGARG; } } while(e = e->entnextp); } static void #ifdef KR_headers putentries(outfile) FILE *outfile; #else putentries(FILE *outfile) #endif /* put out wrappers for multiple entries */ { char base[MAXNAMELEN+4]; struct Entrypoint *e; Namep *A, *Ae, *Ae1, **Alp, *a, **a1, np; chainp args, lengths; int i, k, mt, nL, t, type; extern char *dfltarg[], **dfltproc; e = entries; if (!e->enamep) /* only possible with erroneous input */ return; nL = (nallargs + nallchargs) * sizeof(Namep *); if (!nL) nL = 8; A = (Namep *)ckalloc(nL + nallargs*sizeof(Namep **)); Ae = A + nallargs; Alp = (Namep **)(Ae1 = Ae + nallchargs); i = k = 0; for(a1 = Alp, args = allargs; args; a1++, args = args->nextp) { np = (Namep)args->datap; if (np->vtype == TYCHAR && np->vclass != CLPROC) *a1 = &Ae[i++]; } mt = multitype; multitype = 0; sprintf(base, "%s0_", e->enamep->cvarname); do { np = e->enamep; lengths = length_comp(e, 0); proctype = type = np->vtype; if (protofile) protowrite(protofile, type, np->cvarname, e, lengths); nice_printf(outfile, "\n%s ", c_type_decl(type, 1)); nice_printf(outfile, "%s", np->cvarname); if (!Ansi) { listargs(outfile, e, 0, lengths); nice_printf(outfile, "\n"); } list_arg_types(outfile, e, lengths, 0, "\n"); nice_printf(outfile, "{\n"); frchain(&lengths); next_tab(outfile); if (mt) nice_printf(outfile, "Multitype ret_val;\n%s(%d, &ret_val", base, k); /*)*/ else if (ISCOMPLEX(type)) nice_printf(outfile, "%s(%d,%s", base, k, xretslot[type]->user.ident); /*)*/ else if (type == TYCHAR) nice_printf(outfile, "%s(%d, ret_val, ret_val_len", base, k); /*)*/ else nice_printf(outfile, "return %s(%d", base, k); /*)*/ k++; memset((char *)A, 0, nL); for(args = e->arglist; args; args = args->nextp) { np = (Namep)args->datap; A[np->argno] = np; if (np->vtype == TYCHAR && np->vclass != CLPROC) *Alp[np->argno] = np; } args = allargs; for(a = A; a < Ae; a++, args = args->nextp) { t = ((Namep)args->datap)->vtype; nice_printf(outfile, ", %s", (np = *a) ? np->cvarname : ((Namep)args->datap)->vclass == CLPROC ? dfltproc[((Namep)args->datap)->vimpltype ? (Castargs ? TYUNKNOWN : TYSUBR) : t == TYREAL && forcedouble && !Castargs ? TYDREAL : t] : dfltarg[((Namep)args->datap)->vtype]); } for(; a < Ae1; a++) if (np = *a) nice_printf(outfile, ", %s", new_arg_length(np)); else nice_printf(outfile, ", (ftnint)0"); nice_printf(outfile, /*(*/ ");\n"); if (mt) { if (type == TYCOMPLEX) nice_printf(outfile, "r_v->r = ret_val.c.r; r_v->i = ret_val.c.i;\n"); else if (type == TYDCOMPLEX) nice_printf(outfile, "r_v->r = ret_val.z.r; r_v->i = ret_val.z.i;\n"); else if (type <= TYLOGICAL) nice_printf(outfile, "return ret_val.%s;\n", postfix[type-TYINT1]); } nice_printf(outfile, "}\n"); prev_tab(outfile); } while(e = e->entnextp); free((char *)A); } static void #ifdef KR_headers entry_goto(outfile) FILE *outfile; #else entry_goto(FILE *outfile) #endif { struct Entrypoint *e = entries; int k = 0; nice_printf(outfile, "switch(n__) {\n"); next_tab(outfile); while(e = e->entnextp) nice_printf(outfile, "case %d: goto %s;\n", ++k, user_label((long)(extsymtab - e->entryname - 1))); nice_printf(outfile, "}\n\n"); prev_tab(outfile); } /* start a new procedure */ void newproc(Void) { if(parstate != OUTSIDE) { execerr("missing end statement", CNULL); endproc(); } parstate = INSIDE; procclass = CLMAIN; /* default */ } static void zap_changes(Void) { register chainp cp; register Argtypes *at; /* arrange to get correct count of prototypes that would change by running f2c again */ if (prev_proc && proc_argchanges) proc_protochanges++; prev_proc = proc_argchanges = 0; for(cp = new_procs; cp; cp = cp->nextp) if (at = ((Namep)cp->datap)->arginfo) at->changes &= ~1; frchain(&new_procs); } /* end of procedure. generate variables, epilogs, and prologs */ void endproc(Void) { struct Labelblock *lp; Extsym *ext; if(parstate < INDATA) enddcl(); if(ctlstack >= ctls) err("DO loop or BLOCK IF not closed"); for(lp = labeltab ; lp < labtabend ; ++lp) if(lp->stateno!=0 && lp->labdefined==NO) errstr("missing statement label %s", convic(lp->stateno) ); /* Save copies of the common variables in extptr -> allextp */ for (ext = extsymtab; ext < nextext; ext++) if (ext -> extstg == STGCOMMON && ext -> extp) { extern int usedefsforcommon; /* Write out the abbreviations for common block reference */ copy_data (ext -> extp); if (usedefsforcommon) { wr_abbrevs (c_file, 1, ext -> extp); ext -> used_here = 1; } else ext -> extp = CHNULL; } if (nentry > 1) fix_entry_returns(); epicode(); donmlist(); dobss(); start_formatting (); if (nentry > 1) putentries(c_file); zap_changes(); procinit(); /* clean up for next procedure */ } /* End of declaration section of procedure. Allocate storage. */ void enddcl(Void) { register struct Entrypoint *ep; struct Entrypoint *ep0; chainp cp; extern char *err_proc; static char comblks[] = "common blocks"; err_proc = comblks; docommon(); /* Now the hash table entries for fields of common blocks have STGCOMMON, vdcldone, voffset, and varno. And the common blocks themselves have their full sizes in extleng. */ err_proc = "equivalences"; doequiv(); err_proc = comblks; docomleng(); /* This implies that entry points in the declarations are buffered in entries but not written out */ err_proc = "entries"; if (ep = ep0 = (struct Entrypoint *)revchain((chainp)entries)) { /* entries could be 0 in case of an error */ do doentry(ep); while(ep = ep->entnextp); entries = (struct Entrypoint *)revchain((chainp)ep0); } err_proc = 0; parstate = INEXEC; p1put(P1_PROCODE); freetemps(); if (earlylabs) { for(cp = earlylabs = revchain(earlylabs); cp; cp = cp->nextp) p1_label((long)cp->datap); frchain(&earlylabs); } p1_line_number(lineno); /* for files that start with a MAIN program */ /* that starts with an executable statement */ } /* ROUTINES CALLED WHEN ENCOUNTERING ENTRY POINTS */ /* Main program or Block data */ void #ifdef KR_headers startproc(progname, Class) Extsym *progname; int Class; #else startproc(Extsym *progname, int Class) #endif { register struct Entrypoint *p; p = ALLOC(Entrypoint); if(Class == CLMAIN) { puthead(CNULL, CLMAIN); if (progname) strcpy (main_alias, progname->cextname); } else { if (progname) { /* Construct an empty subroutine with this name */ /* in case the name is needed to force loading */ /* of this block-data subprogram: the name can */ /* appear elsewhere in an external statement. */ entrypt(CLPROC, TYSUBR, (ftnint)0, progname, (chainp)0); endproc(); newproc(); } puthead(CNULL, CLBLOCK); } if(Class == CLMAIN) newentry( mkname(" MAIN"), 0 )->extinit = 1; p->entryname = progname; entries = p; procclass = Class; fprintf(diagfile, " %s", (Class==CLMAIN ? "MAIN" : "BLOCK DATA") ); if(progname) { fprintf(diagfile, " %s", progname->fextname); procname = progname->cextname; } fprintf(diagfile, ":\n"); fflush(diagfile); } /* subroutine or function statement */ Extsym * #ifdef KR_headers newentry(v, substmsg) register Namep v; int substmsg; #else newentry(register Namep v, int substmsg) #endif { register Extsym *p; char buf[128], badname[64]; static int nbad = 0; static char already[] = "external name already used"; p = mkext(v->fvarname, addunder(v->cvarname)); if(p->extinit || ! ONEOF(p->extstg, M(STGUNKNOWN)|M(STGEXT)) ) { sprintf(badname, "%s_bad%d", v->fvarname, ++nbad); if (substmsg) { sprintf(buf,"%s\n\tsubstituting \"%s\"", already, badname); dclerr(buf, v); } else dclerr(already, v); p = mkext(v->fvarname, badname); } v->vstg = STGAUTO; v->vprocclass = PTHISPROC; v->vclass = CLPROC; if (p->extstg == STGEXT) prev_proc = 1; else p->extstg = STGEXT; p->extinit = YES; v->vardesc.varno = p - extsymtab; return(p); } void #ifdef KR_headers entrypt(Class, type, length, entry, args) int Class; int type; ftnint length; Extsym *entry; chainp args; #else entrypt(int Class, int type, ftnint length, Extsym *entry, chainp args) #endif { register Namep q; register struct Entrypoint *p; if(Class != CLENTRY) puthead( procname = entry->cextname, Class); else fprintf(diagfile, " entry "); fprintf(diagfile, " %s:\n", entry->fextname); fflush(diagfile); q = mkname(entry->fextname); if (type == TYSUBR) q->vstg = STGEXT; type = lengtype(type, length); if(Class == CLPROC) { procclass = CLPROC; proctype = type; procleng = type == TYCHAR ? length : 0; } p = ALLOC(Entrypoint); p->entnextp = entries; entries = p; p->entryname = entry; p->arglist = revchain(args); p->enamep = q; if(Class == CLENTRY) { Class = CLPROC; if(proctype == TYSUBR) type = TYSUBR; } q->vclass = Class; q->vprocclass = 0; settype(q, type, length); q->vprocclass = PTHISPROC; /* hold all initial entry points till end of declarations */ if(parstate >= INDATA) doentry(p); } /* generate epilogs */ /* epicode -- write out the proper function return mechanism at the end of the procedure declaration. Handles multiple return value types, as well as cooercion into the proper value */ LOCAL void epicode(Void) { extern int lastwasbranch; if(procclass==CLPROC) { if(proctype==TYSUBR) { /* Return a zero only when the alternate return mechanism has been specified in the function header */ if ((substars || Ansi) && lastwasbranch != YES) p1_subr_ret (ICON(0)); } else if (!multitype && lastwasbranch != YES) retval(proctype); } else if (procclass == CLMAIN && Ansi && lastwasbranch != YES) p1_subr_ret (ICON(0)); lastwasbranch = NO; } /* generate code to return value of type t */ LOCAL void #ifdef KR_headers retval(t) register int t; #else retval(register int t) #endif { register Addrp p; switch(t) { case TYCHAR: case TYCOMPLEX: case TYDCOMPLEX: break; case TYLOGICAL: t = tylogical; case TYINT1: case TYADDR: case TYSHORT: case TYLONG: #ifdef TYQUAD case TYQUAD: #endif case TYREAL: case TYDREAL: case TYLOGICAL1: case TYLOGICAL2: p = (Addrp) cpexpr((expptr)retslot); p->vtype = t; p1_subr_ret (mkconv (t, fixtype((expptr)p))); break; default: badtype("retval", t); } } /* Do parameter adjustments */ void #ifdef KR_headers procode(outfile) FILE *outfile; #else procode(FILE *outfile) #endif { prolog(outfile, allargs); if (nentry > 1) entry_goto(outfile); } static void #ifdef KR_headers bad_dimtype(q) Namep q; #else bad_dimtype(Namep q) #endif { errstr("bad dimension type for %.70s", q->fvarname); } /* Finish bound computations now that all variables are declared. * This used to be in setbound(), but under -u the following incurred * an erroneous error message: * subroutine foo(x,n) * real x(n) * integer n */ static void #ifdef KR_headers dim_finish(v) Namep v; #else dim_finish(Namep v) #endif { register struct Dimblock *p; register expptr q; register int i, nd; p = v->vdim; v->vdimfinish = 0; nd = p->ndim; doin_setbound = 1; for(i = 0; i < nd; i++) if (q = p->dims[i].dimexpr) { q = p->dims[i].dimexpr = make_int_expr(putx(fixtype(q))); if (!ONEOF(q->headblock.vtype, MSKINT|MSKREAL)) bad_dimtype(v); } if (q = p->basexpr) p->basexpr = make_int_expr(putx(fixtype(q))); doin_setbound = 0; } static void #ifdef KR_headers duparg(q) Namep q; #else duparg(Namep q) #endif { errstr("duplicate argument %.80s", q->fvarname); } /* manipulate argument lists (allocate argument slot positions) * keep track of return types and labels */ LOCAL void #ifdef KR_headers doentry(ep) struct Entrypoint *ep; #else doentry(struct Entrypoint *ep) #endif { register int type; register Namep np; chainp p, p1; register Namep q; Addrp rs; int it, k; extern char dflttype[26]; Extsym *entryname = ep->entryname; if (++nentry > 1) p1_label((long)(extsymtab - entryname - 1)); /* The main program isn't allowed to have parameters, so any given parameters are ignored */ if(procclass == CLMAIN && !ep->arglist || procclass == CLBLOCK) return; /* Entry points in MAIN are an error, but we process them here */ /* to prevent faults elsewhere. */ /* So now we're working with something other than CLMAIN or CLBLOCK. Determine the type of its return value. */ impldcl( np = mkname(entryname->fextname) ); type = np->vtype; proc_argchanges = prev_proc && type != entryname->extype; entryname->extseen = 1; if(proctype == TYUNKNOWN) if( (proctype = type) == TYCHAR) procleng = np->vleng ? np->vleng->constblock.Const.ci : (ftnint) (-1); if(proctype == TYCHAR) { if(type != TYCHAR) err("noncharacter entry of character function"); /* Functions returning type char can only have multiple entries if all entries return the same length */ else if( (np->vleng ? np->vleng->constblock.Const.ci : (ftnint) (-1)) != procleng) err("mismatched character entry lengths"); } else if(type == TYCHAR) err("character entry of noncharacter function"); else if(type != proctype) multitype = YES; if(rtvlabel[type] == 0) rtvlabel[type] = (int)newlabel(); ep->typelabel = rtvlabel[type]; if(type == TYCHAR) { if(chslot < 0) { chslot = nextarg(TYADDR); chlgslot = nextarg(TYLENG); } np->vstg = STGARG; /* Put a new argument in the function, one which will hold the result of a character function. This will have to be named sometime, probably in mkarg(). */ if(procleng < 0) { np->vleng = (expptr) mkarg(TYLENG, chlgslot); np->vleng->addrblock.uname_tag = UNAM_IDENT; strcpy (np -> vleng -> addrblock.user.ident, new_func_length()); } if (!xretslot[TYCHAR]) { xretslot[TYCHAR] = rs = autovar(0, type, ISCONST(np->vleng) ? np->vleng : ICON(0), ""); strcpy(rs->user.ident, "ret_val"); } } /* Handle a complex return type -- declare a new parameter (pointer to a complex value) */ else if( ISCOMPLEX(type) ) { if (!xretslot[type]) xretslot[type] = autovar(0, type, EXNULL, " ret_val"); /* the blank is for use in out_addr */ np->vstg = STGARG; if(cxslot < 0) cxslot = nextarg(TYADDR); } else if (type != TYSUBR) { if (type == TYUNKNOWN) { dclerr("untyped function", np); proctype = type = np->vtype = dflttype[letter(np->fvarname[0])]; } if (!xretslot[type]) xretslot[type] = retslot = autovar(1, type, EXNULL, " ret_val"); /* the blank is for use in out_addr */ np->vstg = STGAUTO; } for(p = ep->arglist ; p ; p = p->nextp) if(! (( q = (Namep) (p->datap) )->vknownarg) ) { q->vknownarg = 1; q->vardesc.varno = nextarg(TYADDR); allargs = mkchain((char *)q, allargs); q->argno = nallargs++; } else if (nentry == 1) duparg(q); else for(p1 = ep->arglist ; p1 != p; p1 = p1->nextp) if ((Namep)p1->datap == q) duparg(q); k = 0; for(p = ep->arglist ; p ; p = p->nextp) { if(! (( q = (Namep) (p->datap) )->vdcldone) ) { impldcl(q); q->vdcldone = YES; if(q->vtype == TYCHAR) { /* If we don't know the length of a char*(*) (i.e. a string), we must add in this additional length argument. */ ++nallchargs; if (q->vclass == CLPROC) nallchargs--; else if (q->vleng == NULL) { /* character*(*) */ q->vleng = (expptr) mkarg(TYLENG, nextarg(TYLENG) ); unamstring((Addrp)q->vleng, new_arg_length(q)); } } } if (q->vdimfinish) dim_finish(q); if (q->vtype == TYCHAR && q->vclass != CLPROC) k++; } if (entryname->extype != type) changedtype(np); /* save information for checking consistency of arg lists */ it = infertypes; if (entryname->exproto) infertypes = 1; save_argtypes(ep->arglist, &entryname->arginfo, &np->arginfo, 0, np->fvarname, STGEXT, k, np->vtype, 2); infertypes = it; } LOCAL int #ifdef KR_headers nextarg(type) int type; #else nextarg(int type) #endif { type = type; /* shut up warning */ return(lastargslot++); } LOCAL void #ifdef KR_headers dim_check(q) Namep q; #else dim_check(Namep q) #endif { register struct Dimblock *vdim = q->vdim; register expptr nelt; if(!(nelt = vdim->nelt) || !ISCONST(nelt)) dclerr("adjustable dimension on non-argument", q); else if (!ONEOF(nelt->headblock.vtype, MSKINT|MSKREAL)) bad_dimtype(q); else if (ISINT(nelt->headblock.vtype) ? nelt->constblock.Const.ci <= 0 : nelt->constblock.Const.cd[0] <= 0.) dclerr("nonpositive dimension", q); } LOCAL void dobss(Void) { register struct Hashentry *p; register Namep q; int qstg, qclass, qtype; Extsym *e; for(p = hashtab ; pvarp) { qstg = q->vstg; qtype = q->vtype; qclass = q->vclass; if( (qclass==CLUNKNOWN && qstg!=STGARG) || (qclass==CLVAR && qstg==STGUNKNOWN) ) { if (!(q->vis_assigned | q->vimpldovar)) warn1("local variable %s never used", q->fvarname); } else if(qclass==CLVAR && qstg==STGBSS) { ; } /* Give external procedures the proper storage class */ else if(qclass==CLPROC && q->vprocclass==PEXTERNAL && qstg!=STGARG) { e = mkext(q->fvarname,addunder(q->cvarname)); e->extstg = STGEXT; q->vardesc.varno = e - extsymtab; if (e->extype != qtype) changedtype(q); } if(qclass==CLVAR) { if (qstg != STGARG && q->vdim) dim_check(q); } /* if qclass == CLVAR */ } } void donmlist(Void) { register struct Hashentry *p; register Namep q; for(p=hashtab; pvarp) && q->vclass==CLNAMELIST) namelist(q); } /* iarrlen -- Returns the size of the array in bytes, or -1 */ ftnint #ifdef KR_headers iarrlen(q) register Namep q; #else iarrlen(register Namep q) #endif { ftnint leng; leng = typesize[q->vtype]; if(leng <= 0) return(-1); if(q->vdim) if( ISICON(q->vdim->nelt) ) leng *= q->vdim->nelt->constblock.Const.ci; else return(-1); if(q->vleng) if( ISICON(q->vleng) ) leng *= q->vleng->constblock.Const.ci; else return(-1); return(leng); } void #ifdef KR_headers namelist(np) Namep np; #else namelist(Namep np) #endif { register chainp q; register Namep v; int y; if (!np->visused) return; y = 0; for(q = np->varxptr.namelist ; q ; q = q->nextp) { vardcl( v = (Namep) (q->datap) ); if( !ONEOF(v->vstg, MSKSTATIC) ) dclerr("may not appear in namelist", v); else { v->vnamelist = 1; v->visused = 1; v->vsave = 1; y = 1; } np->visused = y; } } /* docommon -- called at the end of procedure declarations, before equivalences and the procedure body */ LOCAL void docommon(Void) { register Extsym *extptr; register chainp q, q1; struct Dimblock *t; expptr neltp; register Namep comvar; ftnint size; int i, k, pref, type; extern int type_pref[]; for(extptr = extsymtab ; extptrextstg == STGCOMMON && (q = extptr->extp)) { /* If a common declaration also had a list of variables ... */ q = extptr->extp = revchain(q); pref = 1; for(k = TYCHAR; q ; q = q->nextp) { comvar = (Namep) (q->datap); if(comvar->vdcldone == NO) vardcl(comvar); type = comvar->vtype; if (pref < type_pref[type]) pref = type_pref[k = type]; if(extptr->extleng % typealign[type] != 0) { dclerr("common alignment", comvar); --nerr; /* don't give bad return code for this */ #if 0 extptr->extleng = roundup(extptr->extleng, typealign[type]); #endif } /* if extptr -> extleng % */ /* Set the offset into the common block */ comvar->voffset = extptr->extleng; comvar->vardesc.varno = extptr - extsymtab; if(type == TYCHAR) if (comvar->vleng) size = comvar->vleng->constblock.Const.ci; else { dclerr("character*(*) in common", comvar); size = 1; } else size = typesize[type]; if(t = comvar->vdim) if( (neltp = t->nelt) && ISCONST(neltp) ) size *= neltp->constblock.Const.ci; else dclerr("adjustable array in common", comvar); /* Adjust the length of the common block so far */ extptr->extleng += size; } /* for */ extptr->extype = k; /* Determine curno and, if new, save this identifier chain */ q1 = extptr->extp; for (q = extptr->allextp, i = 0; q; i++, q = q->nextp) if (struct_eq((chainp)q->datap, q1)) break; if (q) extptr->curno = extptr->maxno - i; else { extptr->curno = ++extptr->maxno; extptr->allextp = mkchain((char *)extptr->extp, extptr->allextp); } } /* if extptr -> extstg == STGCOMMON */ /* Now the hash table entries have STGCOMMON, vdcldone, voffset, and varno. And the common block itself has its full size in extleng. */ } /* docommon */ /* copy_data -- copy the Namep entries so they are available even after the hash table is empty */ void #ifdef KR_headers copy_data(list) chainp list; #else copy_data(chainp list) #endif { for (; list; list = list -> nextp) { Namep namep = ALLOC (Nameblock); int size, nd, i; struct Dimblock *dp; cpn(sizeof(struct Nameblock), list->datap, (char *)namep); namep->fvarname = strcpy(gmem(strlen(namep->fvarname)+1,0), namep->fvarname); namep->cvarname = strcmp(namep->fvarname, namep->cvarname) ? strcpy(gmem(strlen(namep->cvarname)+1,0), namep->cvarname) : namep->fvarname; if (namep -> vleng) namep -> vleng = (expptr) cpexpr (namep -> vleng); if (namep -> vdim) { nd = namep -> vdim -> ndim; size = sizeof(int) + (3 + 2 * nd) * sizeof (expptr); dp = (struct Dimblock *) ckalloc (size); cpn(size, (char *)namep->vdim, (char *)dp); namep -> vdim = dp; dp->nelt = (expptr)cpexpr(dp->nelt); for (i = 0; i < nd; i++) { dp -> dims[i].dimsize = (expptr) cpexpr (dp -> dims[i].dimsize); } /* for */ } /* if */ list -> datap = (char *) namep; } /* for */ } /* copy_data */ LOCAL void docomleng(Void) { register Extsym *p; for(p = extsymtab ; p < nextext ; ++p) if(p->extstg == STGCOMMON) { if(p->maxleng!=0 && p->extleng!=0 && p->maxleng!=p->extleng && strcmp(Blank, p->cextname) ) warn1("incompatible lengths for common block %.60s", p->fextname); if(p->maxleng < p->extleng) p->maxleng = p->extleng; p->extleng = 0; } } /* ROUTINES DEALING WITH AUTOMATIC AND TEMPORARY STORAGE */ void #ifdef KR_headers frtemp(p) Addrp p; #else frtemp(Addrp p) #endif { /* put block on chain of temps to be reclaimed */ holdtemps = mkchain((char *)p, holdtemps); } void freetemps(Void) { register chainp p, p1; register Addrp q; register int t; p1 = holdtemps; while(p = p1) { q = (Addrp)p->datap; t = q->vtype; if (t == TYCHAR && q->varleng != 0) { /* restore clobbered character string lengths */ frexpr(q->vleng); q->vleng = ICON(q->varleng); } p1 = p->nextp; p->nextp = templist[t]; templist[t] = p; } holdtemps = 0; } /* allocate an automatic variable slot for each of nelt variables */ Addrp #ifdef KR_headers autovar(nelt0, t, lengp, name) register int nelt0; register int t; expptr lengp; char *name; #else autovar(register int nelt0, register int t, expptr lengp, char *name) #endif { ftnint leng; register Addrp q; register int nelt = nelt0 > 0 ? nelt0 : 1; extern char *av_pfix[]; if(t == TYCHAR) if( ISICON(lengp) ) leng = lengp->constblock.Const.ci; else { Fatal("automatic variable of nonconstant length"); } else leng = typesize[t]; q = ALLOC(Addrblock); q->tag = TADDR; q->vtype = t; if(t == TYCHAR) { q->vleng = ICON(leng); q->varleng = leng; } q->vstg = STGAUTO; q->ntempelt = nelt; q->isarray = (nelt > 1); q->memoffset = ICON(0); /* kludge for nls so we can have ret_val rather than ret_val_4 */ if (*name == ' ') unamstring(q, name); else { q->uname_tag = UNAM_IDENT; temp_name(av_pfix[t], ++autonum[t], q->user.ident); } if (nelt0 > 0) declare_new_addr (q); return(q); } /* Returns a temporary of the appropriate type. Will reuse existing temporaries when possible */ Addrp #ifdef KR_headers mktmpn(nelt, type, lengp) int nelt; register int type; expptr lengp; #else mktmpn(int nelt, register int type, expptr lengp) #endif { ftnint leng; chainp p, oldp; register Addrp q; extern int krparens; if(type==TYUNKNOWN || type==TYERROR) badtype("mktmpn", type); if(type==TYCHAR) if(lengp && ISICON(lengp) ) leng = lengp->constblock.Const.ci; else { err("adjustable length"); return( (Addrp) errnode() ); } else if (type > TYCHAR || type < TYADDR) { erri("mktmpn: unexpected type %d", type); exit(1); } /* * if a temporary of appropriate shape is on the templist, * remove it from the list and return it */ if (krparens == 2 && ONEOF(type,M(TYREAL)|M(TYCOMPLEX))) type++; for(oldp=CHNULL, p=templist[type]; p ; oldp=p, p=p->nextp) { q = (Addrp) (p->datap); if(q->ntempelt==nelt && (type!=TYCHAR || q->vleng->constblock.Const.ci==leng) ) { if(oldp) oldp->nextp = p->nextp; else templist[type] = p->nextp; free( (charptr) p); return(q); } } q = autovar(nelt, type, lengp, ""); return(q); } /* mktmp -- create new local variable; call it something like name lengp is taken directly, not copied */ Addrp #ifdef KR_headers mktmp(type, lengp) int type; expptr lengp; #else mktmp(int type, expptr lengp) #endif { Addrp rv; /* arrange for temporaries to be recycled */ /* at the end of this statement... */ rv = mktmpn(1,type,lengp); frtemp((Addrp)cpexpr((expptr)rv)); return rv; } /* mktmp0 omits frtemp() */ Addrp #ifdef KR_headers mktmp0(type, lengp) int type; expptr lengp; #else mktmp0(int type, expptr lengp) #endif { Addrp rv; /* arrange for temporaries to be recycled */ /* when this Addrp is freed */ rv = mktmpn(1,type,lengp); rv->istemp = YES; return rv; } /* VARIOUS ROUTINES FOR PROCESSING DECLARATIONS */ /* comblock -- Declare a new common block. Input parameters name the block; s will be NULL if the block is unnamed */ Extsym * #ifdef KR_headers comblock(s) register char *s; #else comblock(register char *s) #endif { Extsym *p; register char *t; register int c, i; char cbuf[256], *s0; /* Give the unnamed common block a unique name */ if(*s == 0) p = mkext1(s0 = Blank, Blank); else { s0 = s; t = cbuf; for(i = 0; c = *t = *s++; t++) if (c == '_') i = 1; if (i) *t++ = '_'; t[0] = '_'; t[1] = 0; p = mkext1(s0,cbuf); } if(p->extstg == STGUNKNOWN) p->extstg = STGCOMMON; else if(p->extstg != STGCOMMON) { errstr("%.52s cannot be a common block: it is a subprogram.", s0); return(0); } return( p ); } /* incomm -- add a new variable to a common declaration */ void #ifdef KR_headers incomm(c, v) Extsym *c; Namep v; #else incomm(Extsym *c, Namep v) #endif { if (!c) return; if(v->vstg != STGUNKNOWN && !v->vimplstg) dclerr(v->vstg == STGARG ? "dummy arguments cannot be in common" : "incompatible common declaration", v); else { v->vstg = STGCOMMON; c->extp = mkchain((char *)v, c->extp); } } /* settype -- set the type or storage class of a Namep object. If v -> vstg == STGUNKNOWN && type < 0, attempt to reset vstg to be -type. This function will not change any earlier definitions in v, in will only attempt to fill out more information give the other params */ void #ifdef KR_headers settype(v, type, length) register Namep v; register int type; register ftnint length; #else settype(register Namep v, register int type, register ftnint length) #endif { int type1; if(type == TYUNKNOWN) return; if(type==TYSUBR && v->vtype!=TYUNKNOWN && v->vstg==STGARG) { v->vtype = TYSUBR; frexpr(v->vleng); v->vleng = 0; v->vimpltype = 0; } else if(type < 0) /* storage class set */ { if(v->vstg == STGUNKNOWN) v->vstg = - type; else if(v->vstg != -type) dclerr("incompatible storage declarations", v); } else if(v->vtype == TYUNKNOWN || v->vtype != type && (v->vimpltype || v->vinftype || v->vinfproc)) { if( (v->vtype = lengtype(type, length))==TYCHAR ) if (length>=0) v->vleng = ICON(length); else if (parstate >= INDATA) v->vleng = ICON(1); /* avoid a memory fault */ v->vimpltype = 0; v->vinftype = 0; /* 19960709 */ v->vinfproc = 0; /* 19960709 */ if (v->vclass == CLPROC) { if (v->vstg == STGEXT && (type1 = extsymtab[v->vardesc.varno].extype) && type1 != v->vtype) changedtype(v); else if (v->vprocclass == PTHISPROC && (parstate >= INDATA || procclass == CLMAIN) && !xretslot[type]) { xretslot[type] = autovar(ONEOF(type, MSKCOMPLEX|MSKCHAR) ? 0 : 1, type, v->vleng, " ret_val"); if (procclass == CLMAIN) errstr( "illegal use of %.60s (main program name)", v->fvarname); /* not completely right, but enough to */ /* avoid memory faults; we won't */ /* emit any C as we have illegal Fortran */ } } } else if(v->vtype != type && v->vtype != lengtype(type, length)) { incompat: dclerr("incompatible type declarations", v); } else if (type==TYCHAR) if (v->vleng && v->vleng->constblock.Const.ci != length) goto incompat; else if (parstate >= INDATA) v->vleng = ICON(1); /* avoid a memory fault */ } /* lengtype -- returns the proper compiler type, given input of Fortran type and length specifier */ int #ifdef KR_headers lengtype(type, len) register int type; ftnint len; #else lengtype(register int type, ftnint len) #endif { register int length = (int)len; switch(type) { case TYREAL: if(length == typesize[TYDREAL]) return(TYDREAL); if(length == typesize[TYREAL]) goto ret; break; case TYCOMPLEX: if(length == typesize[TYDCOMPLEX]) return(TYDCOMPLEX); if(length == typesize[TYCOMPLEX]) goto ret; break; case TYINT1: case TYSHORT: case TYDREAL: case TYDCOMPLEX: case TYCHAR: case TYLOGICAL1: case TYLOGICAL2: case TYUNKNOWN: case TYSUBR: case TYERROR: #ifdef TYQUAD case TYQUAD: #endif goto ret; case TYLOGICAL: switch(length) { case 0: return tylog; case 1: return TYLOGICAL1; case 2: return TYLOGICAL2; case 4: goto ret; } break; case TYLONG: if(length == 0) return(tyint); if (length == 1) return TYINT1; if(length == typesize[TYSHORT]) return(TYSHORT); #ifdef TYQUAD if(length == typesize[TYQUAD] && use_tyquad) return(TYQUAD); #endif if(length == typesize[TYLONG]) goto ret; break; default: badtype("lengtype", type); } if(len != 0) err("incompatible type-length combination"); ret: return(type); } /* setintr -- Set Intrinsic function */ void #ifdef KR_headers setintr(v) register Namep v; #else setintr(register Namep v) #endif { int k; if(k = intrfunct(v->fvarname)) { if ((*(struct Intrpacked *)&k).f4) if (noextflag) goto unknown; else dcomplex_seen++; v->vardesc.varno = k; } else { unknown: dclerr("unknown intrinsic function", v); return; } if(v->vstg == STGUNKNOWN) v->vstg = STGINTR; else if(v->vstg!=STGINTR) dclerr("incompatible use of intrinsic function", v); if(v->vclass==CLUNKNOWN) v->vclass = CLPROC; if(v->vprocclass == PUNKNOWN) v->vprocclass = PINTRINSIC; else if(v->vprocclass != PINTRINSIC) dclerr("invalid intrinsic declaration", v); } /* setext -- Set External declaration -- assume that unknowns will become procedures */ void #ifdef KR_headers setext(v) register Namep v; #else setext(register Namep v) #endif { if(v->vclass == CLUNKNOWN) v->vclass = CLPROC; else if(v->vclass != CLPROC) dclerr("invalid external declaration", v); if(v->vprocclass == PUNKNOWN) v->vprocclass = PEXTERNAL; else if(v->vprocclass != PEXTERNAL) dclerr("invalid external declaration", v); } /* setext */ /* create dimensions block for array variable */ void #ifdef KR_headers setbound(v, nd, dims) register Namep v; int nd; struct Dims *dims; #else setbound(Namep v, int nd, struct Dims *dims) #endif { expptr q, q0, t; struct Dimblock *p; int i; extern chainp new_vars; char buf[256]; if(v->vclass == CLUNKNOWN) v->vclass = CLVAR; else if(v->vclass != CLVAR) { dclerr("only variables may be arrays", v); return; } v->vdim = p = (struct Dimblock *) ckalloc( sizeof(int) + (3+2*nd)*sizeof(expptr) ); p->ndim = nd--; p->nelt = ICON(1); doin_setbound = 1; if (noextflag) for(i = 0; i <= nd; i++) if (((q = dims[i].lb) && !ISINT(q->headblock.vtype)) || ((q = dims[i].ub) && !ISINT(q->headblock.vtype))) { sprintf(buf, "dimension %d of %s is not an integer.", i+1, v->fvarname); errext(buf); break; } for(i = 0; i <= nd; i++) { if (((q = dims[i].lb) && !ISINT(q->headblock.vtype))) dims[i].lb = mkconv(TYINT, q); if (((q = dims[i].ub) && !ISINT(q->headblock.vtype))) dims[i].ub = mkconv(TYINT, q); } for(i = 0; i <= nd; ++i) { if( (q = dims[i].ub) == NULL) { if(i == nd) { frexpr(p->nelt); p->nelt = NULL; } else err("only last bound may be asterisk"); p->dims[i].dimsize = ICON(1); p->dims[i].dimexpr = NULL; } else { if(dims[i].lb) { q = mkexpr(OPMINUS, q, cpexpr(dims[i].lb)); q = mkexpr(OPPLUS, q, ICON(1) ); } if( ISCONST(q) ) { p->dims[i].dimsize = q; p->dims[i].dimexpr = (expptr) PNULL; } else { sprintf(buf, " %s_dim%d", v->fvarname, i+1); p->dims[i].dimsize = (expptr) autovar(1, tyint, EXNULL, buf); p->dims[i].dimexpr = q; if (i == nd) v->vlastdim = new_vars; v->vdimfinish = 1; } if(p->nelt) p->nelt = mkexpr(OPSTAR, p->nelt, cpexpr(p->dims[i].dimsize) ); } } q = dims[nd].lb; q0 = 0; if(q == NULL) q = q0 = ICON(1); for(i = nd-1 ; i>=0 ; --i) { t = dims[i].lb; if(t == NULL) t = ICON(1); if(p->dims[i].dimsize) { if (q == q0) { q0 = 0; frexpr(q); q = cpexpr(p->dims[i].dimsize); } else q = mkexpr(OPSTAR, cpexpr(p->dims[i].dimsize), q); q = mkexpr(OPPLUS, t, q); } } if( ISCONST(q) ) { p->baseoffset = q; p->basexpr = NULL; } else { sprintf(buf, " %s_offset", v->fvarname); p->baseoffset = (expptr) autovar(1, tyint, EXNULL, buf); p->basexpr = q; v->vdimfinish = 1; } doin_setbound = 0; } void #ifdef KR_headers wr_abbrevs(outfile, function_head, vars) FILE *outfile; int function_head; chainp vars; #else wr_abbrevs(FILE *outfile, int function_head, chainp vars) #endif { for (; vars; vars = vars -> nextp) { Namep name = (Namep) vars -> datap; if (!name->visused) continue; if (function_head) nice_printf (outfile, "#define "); else nice_printf (outfile, "#undef "); out_name (outfile, name); if (function_head) { Extsym *comm = &extsymtab[name -> vardesc.varno]; nice_printf (outfile, " ("); extern_out (outfile, comm); nice_printf (outfile, "%d.", comm->curno); nice_printf (outfile, "%s)", name->cvarname); } /* if function_head */ nice_printf (outfile, "\n"); } /* for */ } /* wr_abbrevs */ f2c/src/put.c000066400000000000000000000241511171647030000132750ustar00rootroot00000000000000/**************************************************************** Copyright 1990-1991, 1993-1994, 1996, 2000-2001 by AT&T, Lucent Technologies and Bellcore. Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the above copyright notice appear in all copies and that both that the copyright notice and this permission notice and warranty disclaimer appear in supporting documentation, and that the names of AT&T, Bell Laboratories, Lucent or Bellcore or any of their entities not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. AT&T, Lucent and Bellcore disclaim all warranties with regard to this software, including all implied warranties of merchantability and fitness. In no event shall AT&T, Lucent or Bellcore be liable for any special, indirect or consequential damages or any damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortious action, arising out of or in connection with the use or performance of this software. ****************************************************************/ /* * INTERMEDIATE CODE GENERATION PROCEDURES COMMON TO BOTH * JOHNSON (PORTABLE) AND RITCHIE FAMILIES OF SECOND PASSES */ #include "defs.h" #include "names.h" /* For LOCAL_CONST_NAME */ #include "pccdefs.h" #include "p1defs.h" /* Definitions for putconst() */ #define LIT_CHAR 1 #define LIT_FLOAT 2 #define LIT_INT 3 #define LIT_INTQ 4 /* char *ops [ ] = { "??", "+", "-", "*", "/", "**", "-", "OR", "AND", "EQV", "NEQV", "NOT", "CONCAT", "<", "==", ">", "<=", "!=", ">=", " of ", " ofC ", " = ", " += ", " *= ", " CONV ", " << ", " % ", " , ", " ? ", " : " " abs ", " min ", " max ", " addr ", " indirect ", " bitor ", " bitand ", " bitxor ", " bitnot ", " >> ", }; */ /* Each of these values is defined in pccdefs */ int ops2 [ ] = { P2BAD, P2PLUS, P2MINUS, P2STAR, P2SLASH, P2BAD, P2NEG, P2OROR, P2ANDAND, P2EQ, P2NE, P2NOT, P2BAD, P2LT, P2EQ, P2GT, P2LE, P2NE, P2GE, P2CALL, P2CALL, P2ASSIGN, P2PLUSEQ, P2STAREQ, P2CONV, P2LSHIFT, P2MOD, P2COMOP, P2QUEST, P2COLON, 1, P2BAD, P2BAD, P2BAD, P2BAD, P2BITOR, P2BITAND, P2BITXOR, P2BITNOT, P2RSHIFT, P2BAD, P2BAD, P2BAD, P2BAD, P2BAD, P2BAD, P2BAD, P2BAD, P2BAD, P2BAD, P2BAD, P2BAD, P2BAD, 1,1,1,1,1, /* OPNEG1, OPDMIN, OPDMAX, OPASSIGNI, OPIDENTITY */ 1,1,1,1, /* OPCHARCAST, OPDABS, OPMIN2, OPMAX2 */ 1,1,1,1,1 /* OPBITTEST, OPBITCLR, OPBITSET, OPQBIT{CLR,SET} */ }; void #ifdef KR_headers putexpr(p) expptr p; #else putexpr(expptr p) #endif { /* Write the expression to the p1 file */ p = (expptr) putx (fixtype (p)); p1_expr (p); } expptr #ifdef KR_headers putassign(lp, rp) expptr lp; expptr rp; #else putassign(expptr lp, expptr rp) #endif { return putx(fixexpr((Exprp)mkexpr(OPASSIGN, lp, rp))); } void #ifdef KR_headers puteq(lp, rp) expptr lp; expptr rp; #else puteq(expptr lp, expptr rp) #endif { putexpr(mkexpr(OPASSIGN, lp, rp) ); } /* put code for a *= b */ expptr #ifdef KR_headers putsteq(a, b) Addrp a; Addrp b; #else putsteq(Addrp a, Addrp b) #endif { return putx( fixexpr((Exprp) mkexpr(OPSTAREQ, cpexpr((expptr)a), cpexpr((expptr)b)))); } Addrp #ifdef KR_headers mkfield(res, f, ty) register Addrp res; char *f; int ty; #else mkfield(register Addrp res, char *f, int ty) #endif { res -> vtype = ty; res -> Field = f; return res; } /* mkfield */ Addrp #ifdef KR_headers realpart(p) register Addrp p; #else realpart(register Addrp p) #endif { register Addrp q; if (p->tag == TADDR && p->uname_tag == UNAM_CONST && ISCOMPLEX (p->vtype)) return (Addrp)mkrealcon (p -> vtype + TYREAL - TYCOMPLEX, p->user.kludge.vstg1 ? p->user.Const.cds[0] : cds(dtos(p->user.Const.cd[0]),CNULL)); q = (Addrp) cpexpr((expptr) p); if( ISCOMPLEX(p->vtype) ) q = mkfield (q, "r", p -> vtype + TYREAL - TYCOMPLEX); return(q); } expptr #ifdef KR_headers imagpart(p) register Addrp p; #else imagpart(register Addrp p) #endif { register Addrp q; if( ISCOMPLEX(p->vtype) ) { if (p->tag == TADDR && p->uname_tag == UNAM_CONST) return mkrealcon (p -> vtype + TYREAL - TYCOMPLEX, p->user.kludge.vstg1 ? p->user.Const.cds[1] : cds(dtos(p->user.Const.cd[1]),CNULL)); q = (Addrp) cpexpr((expptr) p); q = mkfield (q, "i", p -> vtype + TYREAL - TYCOMPLEX); return( (expptr) q ); } else /* Cast an integer type onto a Double Real type */ return( mkrealcon( ISINT(p->vtype) ? TYDREAL : p->vtype , "0")); } /* ncat -- computes the number of adjacent concatenation operations */ int #ifdef KR_headers ncat(p) register expptr p; #else ncat(register expptr p) #endif { if(p->tag==TEXPR && p->exprblock.opcode==OPCONCAT) return( ncat(p->exprblock.leftp) + ncat(p->exprblock.rightp) ); else return(1); } /* lencat -- returns the length of the concatenated string. Each substring must have a static (i.e. compile-time) fixed length */ ftnint #ifdef KR_headers lencat(p) register expptr p; #else lencat(register expptr p) #endif { if(p->tag==TEXPR && p->exprblock.opcode==OPCONCAT) return( lencat(p->exprblock.leftp) + lencat(p->exprblock.rightp) ); else if( p->headblock.vleng!=NULL && ISICON(p->headblock.vleng) ) return(p->headblock.vleng->constblock.Const.ci); else if(p->tag==TADDR && p->addrblock.varleng!=0) return(p->addrblock.varleng); else { err("impossible element in concatenation"); return(0); } } /* putconst -- Creates a new Addrp value which maps onto the input constant value. The Addrp doesn't retain the value of the constant, instead that value is copied into a table of constants (called litpool, for pool of literal values). The only way to retrieve the actual value of the constant is to look at the memno field of the Addrp result. You know that the associated literal is the one referred to by q when (q -> memno == litp -> litnum). */ Addrp #ifdef KR_headers putconst(p) register Constp p; #else putconst(register Constp p) #endif { register Addrp q; struct Literal *litp, *lastlit; int k, len, type; int litflavor; double cd[2]; ftnint nblanks; char *strp; char cdsbuf0[64], cdsbuf1[64], *ds[2]; if (p->tag != TCONST) badtag("putconst", p->tag); q = ALLOC(Addrblock); q->tag = TADDR; type = p->vtype; q->vtype = ( type==TYADDR ? tyint : type ); q->vleng = (expptr) cpexpr(p->vleng); q->vstg = STGCONST; /* Create the new label for the constant. This is wasteful of labels because when the constant value already exists in the literal pool, this label gets thrown away and is never reclaimed. It might be cleaner to move this down past the first switch() statement below */ q->memno = newlabel(); q->memoffset = ICON(0); q -> uname_tag = UNAM_CONST; /* Copy the constant info into the Addrblock; do this by copying the largest storage elts */ q -> user.Const = p -> Const; q->user.kludge.vstg1 = p->vstg; /* distinguish string from binary fp */ /* check for value in literal pool, and update pool if necessary */ k = 1; switch(type) { case TYCHAR: if (halign) { strp = p->Const.ccp; nblanks = p->Const.ccp1.blanks; len = (int)p->vleng->constblock.Const.ci; litflavor = LIT_CHAR; goto loop; } else q->memno = BAD_MEMNO; break; case TYCOMPLEX: case TYDCOMPLEX: k = 2; if (p->vstg) cd[1] = atof(ds[1] = p->Const.cds[1]); else ds[1] = cds(dtos(cd[1] = p->Const.cd[1]), cdsbuf1); case TYREAL: case TYDREAL: litflavor = LIT_FLOAT; if (p->vstg) cd[0] = atof(ds[0] = p->Const.cds[0]); else ds[0] = cds(dtos(cd[0] = p->Const.cd[0]), cdsbuf0); goto loop; #ifndef NO_LONG_LONG case TYQUAD: litflavor = LIT_INTQ; goto loop; #endif case TYLOGICAL1: case TYLOGICAL2: case TYLOGICAL: case TYLONG: case TYSHORT: case TYINT1: #ifdef TYQUAD0 case TYQUAD: #endif litflavor = LIT_INT; /* Scan the literal pool for this constant value. If this same constant has been assigned before, use the same label. Note that this routine does NOT consider two differently-typed constants with the same bit pattern to be the same constant */ loop: lastlit = litpool + nliterals; for(litp = litpool ; litplittype) switch(litflavor) { case LIT_CHAR: if (len == (int)litp->litval.litival2[0] && nblanks == litp->litval.litival2[1] && !memcmp(strp, litp->cds[0], len)) { q->memno = litp->litnum; frexpr((expptr)p); q->user.Const.ccp1.ccp0 = litp->cds[0]; return(q); } break; case LIT_FLOAT: if(cd[0] == litp->litval.litdval[0] && !strcmp(ds[0], litp->cds[0]) && (k == 1 || cd[1] == litp->litval.litdval[1] && !strcmp(ds[1], litp->cds[1]))) { ret: q->memno = litp->litnum; frexpr((expptr)p); return(q); } break; case LIT_INT: if(p->Const.ci == litp->litval.litival) goto ret; break; #ifndef NO_LONG_LONG case LIT_INTQ: if(p->Const.cq == litp->litval.litqval) goto ret; break; #endif } /* If there's room in the literal pool, add this new value to the pool */ if(nliterals < maxliterals) { ++nliterals; /* litp now points to the next free elt */ litp->littype = type; litp->litnum = q->memno; switch(litflavor) { case LIT_CHAR: litp->litval.litival2[0] = len; litp->litval.litival2[1] = nblanks; q->user.Const.ccp = litp->cds[0] = (char*) memcpy(gmem(len,0), strp, len); break; case LIT_FLOAT: litp->litval.litdval[0] = cd[0]; litp->cds[0] = copys(ds[0]); if (k == 2) { litp->litval.litdval[1] = cd[1]; litp->cds[1] = copys(ds[1]); } break; case LIT_INT: litp->litval.litival = p->Const.ci; break; #ifndef NO_LONG_LONG case LIT_INTQ: litp->litval.litqval = p->Const.cq; break; #endif } /* switch (litflavor) */ } else many("literal constants", 'L', maxliterals); break; case TYADDR: break; default: badtype ("putconst", p -> vtype); break; } /* switch */ if (type != TYCHAR || halign) frexpr((expptr)p); return( q ); } f2c/src/putpcc.c000066400000000000000000001320151171647030000137620ustar00rootroot00000000000000/**************************************************************** Copyright 1990-1996, 2000-2001 by AT&T, Lucent Technologies and Bellcore. Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the above copyright notice appear in all copies and that both that the copyright notice and this permission notice and warranty disclaimer appear in supporting documentation, and that the names of AT&T, Bell Laboratories, Lucent or Bellcore or any of their entities not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. AT&T, Lucent and Bellcore disclaim all warranties with regard to this software, including all implied warranties of merchantability and fitness. In no event shall AT&T, Lucent or Bellcore be liable for any special, indirect or consequential damages or any damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortious action, arising out of or in connection with the use or performance of this software. ****************************************************************/ /* INTERMEDIATE CODE GENERATION FOR S. C. JOHNSON C COMPILERS */ /* NEW VERSION USING BINARY POLISH POSTFIX INTERMEDIATE */ #include "defs.h" #include "pccdefs.h" #include "output.h" /* for nice_printf */ #include "names.h" #include "p1defs.h" static Addrp intdouble Argdcl((Addrp)); static Addrp putcx1 Argdcl((tagptr)); static tagptr putaddr Argdcl((tagptr)); static tagptr putcall Argdcl((tagptr, Addrp*)); static tagptr putcat Argdcl((tagptr, tagptr)); static Addrp putch1 Argdcl((tagptr)); static tagptr putchcmp Argdcl((tagptr)); static tagptr putcheq Argdcl((tagptr)); static void putct1 Argdcl((tagptr, Addrp, Addrp, ptr)); static tagptr putcxcmp Argdcl((tagptr)); static Addrp putcxeq Argdcl((tagptr)); static tagptr putmnmx Argdcl((tagptr)); static tagptr putop Argdcl((tagptr)); static tagptr putpower Argdcl((tagptr)); static long p1_where; extern int init_ac[TYSUBR+1]; extern int ops2[]; extern int proc_argchanges, proc_protochanges; extern int krparens; #define P2BUFFMAX 128 /* Puthead -- output the header information about subroutines, functions and entry points */ void #ifdef KR_headers puthead(s, Class) char *s; int Class; #else puthead(char *s, int Class) #endif { if (headerdone == NO) { if (Class == CLMAIN) s = "MAIN__"; p1_head (Class, s); headerdone = YES; } } void #ifdef KR_headers putif(p, else_if_p) register expptr p; int else_if_p; #else putif(register expptr p, int else_if_p) #endif { int k, n; if( !ISLOGICAL((k = (p = fixtype(p))->headblock.vtype )) ) { if(k != TYERROR) err("non-logical expression in IF statement"); } else { if (else_if_p) { if (ei_next >= ei_last) { k = ei_last - ei_first; n = k + 100; ei_next = mem(n,0); ei_last = ei_first + n; if (k) memcpy(ei_next, ei_first, k); ei_first = ei_next; ei_next += k; ei_last = ei_first + n; } p = putx(p); if (*ei_next++ = ftell(pass1_file) > p1_where) { p1_if(p); new_endif(); } else p1_elif(p); } else { p = putx(p); p1_if(p); } } } void #ifdef KR_headers putout(p) expptr p; #else putout(expptr p) #endif { p1_expr (p); /* Used to make temporaries in holdtemps available here, but they */ /* may be reused too soon (e.g. when multiple **'s are involved). */ } void #ifdef KR_headers putcmgo(index, nlab, labs) expptr index; int nlab; struct Labelblock **labs; #else putcmgo(expptr index, int nlab, struct Labelblock **labs) #endif { if(! ISINT(index->headblock.vtype) ) { execerr("computed goto index must be integer", CNULL); return; } p1comp_goto (index, nlab, labs); } static expptr #ifdef KR_headers krput(p) register expptr p; #else krput(register expptr p) #endif { register expptr e, e1; register unsigned op; int t = krparens == 2 ? TYDREAL : p->exprblock.vtype; op = p->exprblock.opcode; e = p->exprblock.leftp; if (e->tag == TEXPR && e->exprblock.opcode == op) { e1 = (expptr)mktmp(t, ENULL); putout(putassign(cpexpr(e1), e)); p->exprblock.leftp = e1; } else p->exprblock.leftp = putx(e); e = p->exprblock.rightp; if (e->tag == TEXPR && e->exprblock.opcode == op) { e1 = (expptr)mktmp(t, ENULL); putout(putassign(cpexpr(e1), e)); p->exprblock.rightp = e1; } else p->exprblock.rightp = putx(e); return p; } expptr #ifdef KR_headers putx(p) register expptr p; #else putx(register expptr p) #endif { int opc; int k; if (p) switch(p->tag) { case TERROR: break; case TCONST: switch(p->constblock.vtype) { case TYLOGICAL1: case TYLOGICAL2: case TYLOGICAL: #ifdef TYQUAD case TYQUAD: #endif case TYLONG: case TYSHORT: case TYINT1: break; case TYADDR: break; case TYREAL: case TYDREAL: /* Don't write it out to the p2 file, since you'd need to call putconst, which is just what we need to avoid in the translator */ break; default: p = putx( (expptr)putconst((Constp)p) ); break; } break; case TEXPR: switch(opc = p->exprblock.opcode) { case OPCALL: case OPCCALL: if( ISCOMPLEX(p->exprblock.vtype) ) p = putcxop(p); else p = putcall(p, (Addrp *)NULL); break; case OPMIN: case OPMAX: p = putmnmx(p); break; case OPASSIGN: if(ISCOMPLEX(p->exprblock.leftp->headblock.vtype) || ISCOMPLEX(p->exprblock.rightp->headblock.vtype)) { (void) putcxeq(p); p = ENULL; } else if( ISCHAR(p) ) p = putcheq(p); else goto putopp; break; case OPEQ: case OPNE: if( ISCOMPLEX(p->exprblock.leftp->headblock.vtype) || ISCOMPLEX(p->exprblock.rightp->headblock.vtype) ) { p = putcxcmp(p); break; } case OPLT: case OPLE: case OPGT: case OPGE: if(ISCHAR(p->exprblock.leftp)) { p = putchcmp(p); break; } goto putopp; case OPPOWER: p = putpower(p); break; case OPSTAR: /* m * (2**k) -> m<exprblock.leftp->headblock.vtype) && ISICON(p->exprblock.rightp) && ( (k = log_2(p->exprblock.rightp->constblock.Const.ci))>0) ) { p->exprblock.opcode = OPLSHIFT; frexpr(p->exprblock.rightp); p->exprblock.rightp = ICON(k); goto putopp; } if (krparens && ISREAL(p->exprblock.vtype)) return krput(p); case OPMOD: goto putopp; case OPPLUS: if (krparens && ISREAL(p->exprblock.vtype)) return krput(p); case OPMINUS: case OPSLASH: case OPNEG: case OPNEG1: case OPABS: case OPDABS: if( ISCOMPLEX(p->exprblock.vtype) ) p = putcxop(p); else goto putopp; break; case OPCONV: if( ISCOMPLEX(p->exprblock.vtype) ) p = putcxop(p); else if( ISCOMPLEX(p->exprblock.leftp->headblock.vtype) ) { p = putx( mkconv(p->exprblock.vtype, (expptr)realpart(putcx1(p->exprblock.leftp)))); } else goto putopp; break; case OPNOT: case OPOR: case OPAND: case OPEQV: case OPNEQV: case OPADDR: case OPPLUSEQ: case OPSTAREQ: case OPCOMMA: case OPQUEST: case OPCOLON: case OPBITOR: case OPBITAND: case OPBITXOR: case OPBITNOT: case OPLSHIFT: case OPRSHIFT: case OPASSIGNI: case OPIDENTITY: case OPCHARCAST: case OPMIN2: case OPMAX2: case OPDMIN: case OPDMAX: case OPBITTEST: case OPBITCLR: case OPBITSET: #ifdef TYQUAD case OPQBITSET: case OPQBITCLR: #endif putopp: p = putop(p); break; case OPCONCAT: /* weird things like ichar(a//a) */ p = (expptr)putch1(p); break; default: badop("putx", opc); p = errnode (); } break; case TADDR: p = putaddr(p); break; default: badtag("putx", p->tag); p = errnode (); } return p; } LOCAL expptr #ifdef KR_headers putop(p) expptr p; #else putop(expptr p) #endif { expptr lp, tp; int pt, lt, lt1; int comma; char *hsave; switch(p->exprblock.opcode) /* check for special cases and rewrite */ { case OPCONV: pt = p->exprblock.vtype; lp = p->exprblock.leftp; lt = lp->headblock.vtype; /* Simplify nested type casts */ while(p->tag==TEXPR && p->exprblock.opcode==OPCONV && ( (ISREAL(pt)&&ONEOF(lt,MSKREAL|MSKCOMPLEX)) || (INT(pt)&&(ONEOF(lt,MSKINT|MSKADDR|MSKCHAR|M(TYSUBR)))) )) { if(pt==TYDREAL && lt==TYREAL) { if(lp->tag==TEXPR && lp->exprblock.opcode == OPCONV) { lt1 = lp->exprblock.leftp->headblock.vtype; if (lt1 == TYDREAL) { lp->exprblock.leftp = putx(lp->exprblock.leftp); return p; } if (lt1 == TYDCOMPLEX) { lp->exprblock.leftp = putx( (expptr)realpart( putcx1(lp->exprblock.leftp))); return p; } } break; } else if (ISREAL(pt) && ISCOMPLEX(lt)) { p->exprblock.leftp = putx(mkconv(pt, (expptr)realpart( putcx1(p->exprblock.leftp)))); break; } if(lt==TYCHAR && lp->tag==TEXPR && lp->exprblock.opcode==OPCALL) { /* May want to make a comma expression here instead. I had one, but took it out for my convenience, not for the convenience of the end user */ putout (putcall (lp, (Addrp *) &(p -> exprblock.leftp))); return putop (p); } if (lt == TYCHAR) { if (ISCONST(p->exprblock.leftp) && ISNUMERIC(p->exprblock.vtype)) { hsave = halign; halign = 0; p->exprblock.leftp = putx((expptr) putconst((Constp) p->exprblock.leftp)); halign = hsave; } else p->exprblock.leftp = putx(p->exprblock.leftp); return p; } if (pt < lt && ONEOF(lt,MSKINT|MSKREAL)) break; frexpr(p->exprblock.vleng); free( (charptr) p ); p = lp; if (p->tag != TEXPR) goto retputx; pt = lt; lp = p->exprblock.leftp; lt = lp->headblock.vtype; } /* while */ if(p->tag==TEXPR && p->exprblock.opcode==OPCONV) break; retputx: return putx(p); case OPADDR: comma = NO; lp = p->exprblock.leftp; free( (charptr) p ); if(lp->tag != TADDR) { tp = (expptr) mktmp(lp->headblock.vtype,lp->headblock.vleng); p = putx( mkexpr(OPASSIGN, cpexpr(tp), lp) ); lp = tp; comma = YES; } if(comma) p = mkexpr(OPCOMMA, p, putaddr(lp)); else p = (expptr)putaddr(lp); return p; case OPASSIGN: case OPASSIGNI: case OPLT: case OPLE: case OPGT: case OPGE: case OPEQ: case OPNE: ; } if( ops2[p->exprblock.opcode] <= 0) badop("putop", p->exprblock.opcode); lp = p->exprblock.leftp = putx(p->exprblock.leftp); if (p -> exprblock.rightp) { tp = p->exprblock.rightp = putx(p->exprblock.rightp); if (tp && ISCONST(tp) && ISCONST(lp)) p = fold(p); } return p; } LOCAL expptr #ifdef KR_headers putpower(p) expptr p; #else putpower(expptr p) #endif { expptr base; Addrp t1, t2; ftnint k; int type; char buf[80]; /* buffer for text of comment */ if(!ISICON(p->exprblock.rightp) || (k = p->exprblock.rightp->constblock.Const.ci)<2) Fatal("putpower: bad call"); base = p->exprblock.leftp; type = base->headblock.vtype; t1 = mktmp(type, ENULL); t2 = NULL; free ((charptr) p); p = putassign (cpexpr((expptr) t1), base); sprintf (buf, "Computing %ld%s power", k, k == 2 ? "nd" : k == 3 ? "rd" : "th"); p1_comment (buf); for( ; (k&1)==0 && k>2 ; k>>=1 ) { p = mkexpr (OPCOMMA, p, putsteq(t1, t1)); } if(k == 2) { /* Write the power computation out immediately */ putout (p); p = putx( mkexpr(OPSTAR, cpexpr((expptr)t1), cpexpr((expptr)t1))); } else if (k == 3) { putout(p); p = putx( mkexpr(OPSTAR, cpexpr((expptr)t1), mkexpr(OPSTAR, cpexpr((expptr)t1), cpexpr((expptr)t1)))); } else { t2 = mktmp(type, ENULL); p = mkexpr (OPCOMMA, p, putassign(cpexpr((expptr)t2), cpexpr((expptr)t1))); for(k>>=1 ; k>1 ; k>>=1) { p = mkexpr (OPCOMMA, p, putsteq(t1, t1)); if(k & 1) { p = mkexpr (OPCOMMA, p, putsteq(t2, t1)); } } /* Write the power computation out immediately */ putout (p); p = putx( mkexpr(OPSTAR, cpexpr((expptr)t2), mkexpr(OPSTAR, cpexpr((expptr)t1), cpexpr((expptr)t1)))); } frexpr((expptr)t1); if(t2) frexpr((expptr)t2); return p; } LOCAL Addrp #ifdef KR_headers intdouble(p) Addrp p; #else intdouble(Addrp p) #endif { register Addrp t; t = mktmp(TYDREAL, ENULL); putout (putassign(cpexpr((expptr)t), (expptr)p)); return(t); } /* Complex-type variable assignment */ LOCAL Addrp #ifdef KR_headers putcxeq(p) register expptr p; #else putcxeq(register expptr p) #endif { register Addrp lp, rp; expptr code; if(p->tag != TEXPR) badtag("putcxeq", p->tag); lp = putcx1(p->exprblock.leftp); rp = putcx1(p->exprblock.rightp); code = putassign ( (expptr)realpart(lp), (expptr)realpart(rp)); if( ISCOMPLEX(p->exprblock.vtype) ) { code = mkexpr (OPCOMMA, code, putassign (imagpart(lp), imagpart(rp))); } putout (code); frexpr((expptr)rp); free ((charptr) p); return lp; } /* putcxop -- used to write out embedded calls to complex functions, and complex arguments to procedures */ expptr #ifdef KR_headers putcxop(p) expptr p; #else putcxop(expptr p) #endif { return (expptr)putaddr((expptr)putcx1(p)); } #define PAIR(x,y) mkexpr (OPCOMMA, (x), (y)) LOCAL Addrp #ifdef KR_headers putcx1(p) register expptr p; #else putcx1(register expptr p) #endif { expptr q; Addrp lp, rp; register Addrp resp; int opcode; int ltype, rtype; long ts, tskludge; if(p == NULL) return(NULL); switch(p->tag) { case TCONST: if( ISCOMPLEX(p->constblock.vtype) ) p = (expptr) putconst((Constp)p); return( (Addrp) p ); case TADDR: resp = &p->addrblock; if (addressable(p)) return (Addrp) p; ts = tskludge = 0; if (q = resp->memoffset) { if (resp->uname_tag == UNAM_REF) { q = cpexpr((tagptr)resp); q->addrblock.vtype = tyint; q->addrblock.cmplx_sub = 1; p->addrblock.skip_offset = 1; resp->user.name->vsubscrused = 1; resp->uname_tag = UNAM_NAME; tskludge = typesize[resp->vtype] * (resp->Field ? 2 : 1); } else if (resp->isarray && resp->vtype != TYCHAR) { if (ONEOF(resp->vstg, M(STGCOMMON)|M(STGEQUIV)) && resp->uname_tag == UNAM_NAME) q = mkexpr(OPMINUS, q, mkintcon(resp->user.name->voffset)); ts = typesize[resp->vtype] * (resp->Field ? 2 : 1); q = resp->memoffset = mkexpr(OPSLASH, q, ICON(ts)); } } #ifdef TYQUAD resp = mktmp(q->headblock.vtype == TYQUAD ? TYQUAD : tyint, ENULL); #else resp = mktmp(tyint, ENULL); #endif putout(putassign(cpexpr((expptr)resp), q)); p->addrblock.memoffset = tskludge ? mkexpr(OPSTAR, (expptr)resp, ICON(tskludge)) : (expptr)resp; if (ts) { resp = &p->addrblock; q = mkexpr(OPSTAR, resp->memoffset, ICON(ts)); if (ONEOF(resp->vstg, M(STGCOMMON)|M(STGEQUIV)) && resp->uname_tag == UNAM_NAME) q = mkexpr(OPPLUS, q, mkintcon(resp->user.name->voffset)); resp->memoffset = q; } return (Addrp) p; case TEXPR: if( ISCOMPLEX(p->exprblock.vtype) ) break; resp = mktmp(p->exprblock.vtype, ENULL); /*first arg of above mktmp call was TYDREAL before 19950102 */ putout (putassign( cpexpr((expptr)resp), p)); return(resp); case TERROR: return NULL; default: badtag("putcx1", p->tag); } opcode = p->exprblock.opcode; if(opcode==OPCALL || opcode==OPCCALL) { Addrp t; p = putcall(p, &t); putout(p); return t; } else if(opcode == OPASSIGN) { return putcxeq (p); } /* BUG (inefficient) Generates too many temporary variables */ resp = mktmp(p->exprblock.vtype, ENULL); if(lp = putcx1(p->exprblock.leftp) ) ltype = lp->vtype; if(rp = putcx1(p->exprblock.rightp) ) rtype = rp->vtype; switch(opcode) { case OPCOMMA: frexpr((expptr)resp); resp = rp; rp = NULL; break; case OPNEG: case OPNEG1: putout (PAIR ( putassign( (expptr)realpart(resp), mkexpr(OPNEG, (expptr)realpart(lp), ENULL)), putassign( imagpart(resp), mkexpr(OPNEG, imagpart(lp), ENULL)))); break; case OPPLUS: case OPMINUS: { expptr r; r = putassign( (expptr)realpart(resp), mkexpr(opcode, (expptr)realpart(lp), (expptr)realpart(rp) )); if(rtype < TYCOMPLEX) q = putassign( imagpart(resp), imagpart(lp) ); else if(ltype < TYCOMPLEX) { if(opcode == OPPLUS) q = putassign( imagpart(resp), imagpart(rp) ); else q = putassign( imagpart(resp), mkexpr(OPNEG, imagpart(rp), ENULL) ); } else q = putassign( imagpart(resp), mkexpr(opcode, imagpart(lp), imagpart(rp) )); r = PAIR (r, q); putout (r); break; } /* case OPPLUS, OPMINUS: */ case OPSTAR: if(ltype < TYCOMPLEX) { if( ISINT(ltype) ) lp = intdouble(lp); putout (PAIR ( putassign( (expptr)realpart(resp), mkexpr(OPSTAR, cpexpr((expptr)lp), (expptr)realpart(rp))), putassign( imagpart(resp), mkexpr(OPSTAR, cpexpr((expptr)lp), imagpart(rp))))); } else if(rtype < TYCOMPLEX) { if( ISINT(rtype) ) rp = intdouble(rp); putout (PAIR ( putassign( (expptr)realpart(resp), mkexpr(OPSTAR, cpexpr((expptr)rp), (expptr)realpart(lp))), putassign( imagpart(resp), mkexpr(OPSTAR, cpexpr((expptr)rp), imagpart(lp))))); } else { putout (PAIR ( putassign( (expptr)realpart(resp), mkexpr(OPMINUS, mkexpr(OPSTAR, (expptr)realpart(lp), (expptr)realpart(rp)), mkexpr(OPSTAR, imagpart(lp), imagpart(rp)))), putassign( imagpart(resp), mkexpr(OPPLUS, mkexpr(OPSTAR, (expptr)realpart(lp), imagpart(rp)), mkexpr(OPSTAR, imagpart(lp), (expptr)realpart(rp)))))); } break; case OPSLASH: /* fixexpr has already replaced all divisions * by a complex by a function call */ if( ISINT(rtype) ) rp = intdouble(rp); putout (PAIR ( putassign( (expptr)realpart(resp), mkexpr(OPSLASH, (expptr)realpart(lp), cpexpr((expptr)rp))), putassign( imagpart(resp), mkexpr(OPSLASH, imagpart(lp), cpexpr((expptr)rp))))); break; case OPCONV: if (!lp) break; if(ISCOMPLEX(lp->vtype) ) q = imagpart(lp); else if(rp != NULL) q = (expptr) realpart(rp); else q = mkrealcon(TYDREAL, "0"); putout (PAIR ( putassign( (expptr)realpart(resp), (expptr)realpart(lp)), putassign( imagpart(resp), q))); break; default: badop("putcx1", opcode); } frexpr((expptr)lp); frexpr((expptr)rp); free( (charptr) p ); return(resp); } /* Only .EQ. and .NE. may be performed on COMPLEX data, other relations are not defined */ LOCAL expptr #ifdef KR_headers putcxcmp(p) register expptr p; #else putcxcmp(register expptr p) #endif { int opcode; register Addrp lp, rp; expptr q; if(p->tag != TEXPR) badtag("putcxcmp", p->tag); opcode = p->exprblock.opcode; lp = putcx1(p->exprblock.leftp); rp = putcx1(p->exprblock.rightp); q = mkexpr( opcode==OPEQ ? OPAND : OPOR , mkexpr(opcode, (expptr)realpart(lp), (expptr)realpart(rp)), mkexpr(opcode, imagpart(lp), imagpart(rp)) ); free( (charptr) lp); free( (charptr) rp); free( (charptr) p ); if (ISCONST(q)) return q; return putx( fixexpr((Exprp)q) ); } /* putch1 -- Forces constants into the literal pool, among other things */ LOCAL Addrp #ifdef KR_headers putch1(p) register expptr p; #else putch1(register expptr p) #endif { Addrp t; expptr e; switch(p->tag) { case TCONST: return( putconst((Constp)p) ); case TADDR: return( (Addrp) p ); case TEXPR: switch(p->exprblock.opcode) { expptr q; case OPCALL: case OPCCALL: p = putcall(p, &t); putout (p); break; case OPCONCAT: t = mktmp(TYCHAR, ICON(lencat(p))); q = (expptr) cpexpr(p->headblock.vleng); p = putcat( cpexpr((expptr)t), p ); /* put the correct length on the block */ frexpr(t->vleng); t->vleng = q; putout (p); break; case OPCONV: if(!ISICON(p->exprblock.vleng) || p->exprblock.vleng->constblock.Const.ci!=1 || ! INT(p->exprblock.leftp->headblock.vtype) ) Fatal("putch1: bad character conversion"); t = mktmp(TYCHAR, ICON(1)); e = mkexpr(OPCONV, (expptr)t, ENULL); e->headblock.vtype = TYCHAR; p = putop( mkexpr(OPASSIGN, cpexpr(e), p)); putout (p); break; default: badop("putch1", p->exprblock.opcode); } return(t); default: badtag("putch1", p->tag); } /* NOT REACHED */ return 0; } /* putchop -- Write out a character actual parameter; that is, this is part of a procedure invocation */ Addrp #ifdef KR_headers putchop(p) expptr p; #else putchop(expptr p) #endif { p = putaddr((expptr)putch1(p)); return (Addrp)p; } LOCAL expptr #ifdef KR_headers putcheq(p) register expptr p; #else putcheq(register expptr p) #endif { expptr lp, rp; int nbad; if(p->tag != TEXPR) badtag("putcheq", p->tag); lp = p->exprblock.leftp; rp = p->exprblock.rightp; frexpr(p->exprblock.vleng); free( (charptr) p ); /* If s = t // u, don't bother copying the result, write it directly into this buffer */ nbad = badchleng(lp) + badchleng(rp); if( rp->tag==TEXPR && rp->exprblock.opcode==OPCONCAT ) p = putcat(lp, rp); else if( !nbad && ISONE(lp->headblock.vleng) && ISONE(rp->headblock.vleng) ) { lp = mkexpr(OPCONV, lp, ENULL); rp = mkexpr(OPCONV, rp, ENULL); lp->headblock.vtype = rp->headblock.vtype = TYCHAR; p = putop(mkexpr(OPASSIGN, lp, rp)); } else p = putx( call2(TYSUBR, "s_copy", lp, rp) ); return p; } LOCAL expptr #ifdef KR_headers putchcmp(p) register expptr p; #else putchcmp(register expptr p) #endif { expptr lp, rp; if(p->tag != TEXPR) badtag("putchcmp", p->tag); lp = p->exprblock.leftp; rp = p->exprblock.rightp; if(ISONE(lp->headblock.vleng) && ISONE(rp->headblock.vleng) ) { lp = mkexpr(OPCONV, lp, ENULL); rp = mkexpr(OPCONV, rp, ENULL); lp->headblock.vtype = rp->headblock.vtype = TYCHAR; } else { lp = call2(TYINT,"s_cmp", lp, rp); rp = ICON(0); } p->exprblock.leftp = lp; p->exprblock.rightp = rp; p = putop(p); return p; } /* putcat -- Writes out a concatenation operation. Two temporary arrays are allocated, putct1() is called to initialize them, and then a call to runtime library routine s_cat() is inserted. This routine generates code which will perform an (nconc lhs rhs) at runtime. The runtime funciton does not return a value, the routine that calls this putcat must remember the name of lhs. */ LOCAL expptr #ifdef KR_headers putcat(lhs0, rhs) expptr lhs0; register expptr rhs; #else putcat(expptr lhs0, register expptr rhs) #endif { register Addrp lhs = (Addrp)lhs0; int n, tyi; Addrp length_var, string_var; expptr p; static char Writing_concatenation[] = "Writing concatenation"; /* Create the temporary arrays */ n = ncat(rhs); length_var = mktmpn(n, tyioint, ENULL); string_var = mktmpn(n, TYADDR, ENULL); frtemp((Addrp)cpexpr((expptr)length_var)); frtemp((Addrp)cpexpr((expptr)string_var)); /* Initialize the arrays */ n = 0; /* p1_comment scribbles on its argument, so we * cannot safely pass a string literal here. */ p1_comment(Writing_concatenation); putct1(rhs, length_var, string_var, &n); /* Create the invocation */ tyi = tyint; tyint = tyioint; /* for -I2 */ p = putx (call4 (TYSUBR, "s_cat", (expptr)lhs, (expptr)string_var, (expptr)length_var, (expptr)putconst((Constp)ICON(n)))); tyint = tyi; return p; } LOCAL void #ifdef KR_headers putct1(q, length_var, string_var, ip) register expptr q; register Addrp length_var; register Addrp string_var; int *ip; #else putct1(register expptr q, register Addrp length_var, register Addrp string_var, int *ip) #endif { int i; Addrp length_copy, string_copy; expptr e; extern int szleng; if(q->tag==TEXPR && q->exprblock.opcode==OPCONCAT) { putct1(q->exprblock.leftp, length_var, string_var, ip); putct1(q->exprblock.rightp, length_var, string_var, ip); frexpr (q -> exprblock.vleng); free ((charptr) q); } else { i = (*ip)++; e = cpexpr(q->headblock.vleng); if (!e) return; /* error -- character*(*) */ length_copy = (Addrp) cpexpr((expptr)length_var); length_copy->memoffset = mkexpr(OPPLUS,length_copy->memoffset, ICON(i*szleng)); string_copy = (Addrp) cpexpr((expptr)string_var); string_copy->memoffset = mkexpr(OPPLUS, string_copy->memoffset, ICON(i*typesize[TYADDR])); putout (PAIR (putassign((expptr)length_copy, e), putassign((expptr)string_copy, addrof((expptr)putch1(q))))); } } /* putaddr -- seems to write out function invocation actual parameters */ LOCAL expptr #ifdef KR_headers putaddr(p0) expptr p0; #else putaddr(expptr p0) #endif { register Addrp p; chainp cp; if (!(p = (Addrp)p0)) return ENULL; if( p->tag==TERROR || (p->memoffset!=NULL && ISERROR(p->memoffset)) ) { frexpr((expptr)p); return ENULL; } if (p->isarray && p->memoffset) if (p->uname_tag == UNAM_REF) { cp = p->memoffset->listblock.listp; for(; cp; cp = cp->nextp) cp->datap = (char *)fixtype((tagptr)cp->datap); } else p->memoffset = putx(p->memoffset); return (expptr) p; } LOCAL expptr #ifdef KR_headers addrfix(e) expptr e; #else addrfix(expptr e) #endif /* fudge character string length if it's a TADDR */ { return e->tag == TADDR ? mkexpr(OPIDENTITY, e, ENULL) : e; } LOCAL int #ifdef KR_headers typekludge(ccall, q, at, j) int ccall; register expptr q; Atype *at; int j; #else typekludge(int ccall, register expptr q, Atype *at, int j) #endif /* j = alternate type */ { register int i, k; extern int iocalladdr; register Namep np; /* Return value classes: * < 100 ==> Fortran arg (pointer to type) * < 200 ==> C arg * < 300 ==> procedure arg * < 400 ==> external, no explicit type * < 500 ==> arg that may turn out to be * either a variable or a procedure */ k = q->headblock.vtype; if (ccall) { if (k == TYREAL) k = TYDREAL; /* force double for library routines */ return k + 100; } if (k == TYADDR) return iocalladdr; i = q->tag; if ((i == TEXPR && q->exprblock.opcode != OPCOMMA_ARG) || (i == TADDR && q->addrblock.charleng) || i == TCONST) k = TYFTNLEN + 100; else if (i == TADDR) switch(q->addrblock.vclass) { case CLPROC: if (q->addrblock.uname_tag != UNAM_NAME) k += 200; else if ((np = q->addrblock.user.name)->vprocclass != PTHISPROC) { if (k && !np->vimpltype) k += 200; else { if (j > 200 && infertypes && j < 300) { k = j; inferdcl(np, j-200); } else k = (np->vstg == STGEXT ? extsymtab[np->vardesc.varno].extype : 0) + 200; at->cp = mkchain((char *)np, at->cp); } } else if (k == TYSUBR) k += 200; break; case CLUNKNOWN: if (q->addrblock.vstg == STGARG && q->addrblock.uname_tag == UNAM_NAME) { k += 400; at->cp = mkchain((char *)q->addrblock.user.name, at->cp); } } else if (i == TNAME && q->nameblock.vstg == STGARG) { np = &q->nameblock; switch(np->vclass) { case CLPROC: if (!np->vimpltype) k += 200; else if (j <= 200 || !infertypes || j >= 300) k += 300; else { k = j; inferdcl(np, j-200); } goto add2chain; case CLUNKNOWN: /* argument may be a scalar variable or a function */ if (np->vimpltype && j && infertypes && j < 300) { inferdcl(np, j % 100); k = j; } else k += 400; /* to handle procedure args only so far known to be * external, save a pointer to the symbol table entry... */ add2chain: at->cp = mkchain((char *)np, at->cp); } } return k; } char * #ifdef KR_headers Argtype(k, buf) int k; char *buf; #else Argtype(int k, char *buf) #endif { if (k < 100) { sprintf(buf, "%s variable", ftn_types[k]); return buf; } if (k < 200) { k -= 100; return ftn_types[k]; } if (k < 300) { k -= 200; if (k == TYSUBR) return ftn_types[TYSUBR]; sprintf(buf, "%s function", ftn_types[k]); return buf; } if (k < 400) return "external argument"; k -= 400; sprintf(buf, "%s argument", ftn_types[k]); return buf; } static void #ifdef KR_headers atype_squawk(at, msg) Argtypes *at; char *msg; #else atype_squawk(Argtypes *at, char *msg) #endif { register Atype *a, *ae; warn(msg); for(a = at->atypes, ae = a + at->nargs; a < ae; a++) frchain(&a->cp); at->nargs = -1; if (at->changes & 2 && !at->defined) proc_protochanges++; } static char inconsist[] = "inconsistent calling sequences for "; void #ifdef KR_headers bad_atypes(at, fname, i, j, k, here, prev) Argtypes *at; char *fname; int i; int j; int k; char *here; char *prev; #else bad_atypes(Argtypes *at, char *fname, int i, int j, int k, char *here, char *prev) #endif { char buf[208], buf1[32], buf2[32]; sprintf(buf, "%s%.90s,\n\targ %d: %s%s%s %s.", inconsist, fname, i, here, Argtype(k, buf1), prev, Argtype(j, buf2)); atype_squawk(at, buf); } int #ifdef KR_headers type_fixup(at, a, k) Argtypes *at; Atype *a; int k; #else type_fixup(Argtypes *at, Atype *a, int k) #endif { register struct Entrypoint *ep; if (!infertypes) return 0; for(ep = entries; ep; ep = ep->entnextp) if (ep->entryname && at == ep->entryname->arginfo) { a->type = k % 100; return proc_argchanges = 1; } return 0; } void #ifdef KR_headers save_argtypes(arglist, at0, at1, ccall, fname, stg, nchargs, type, zap) chainp arglist; Argtypes **at0; Argtypes **at1; int ccall; char *fname; int stg; int nchargs; int type; int zap; #else save_argtypes(chainp arglist, Argtypes **at0, Argtypes **at1, int ccall, char *fname, int stg, int nchargs, int type, int zap) #endif { Argtypes *at; chainp cp; int i, i0, j, k, nargs, nbad, *t, *te; Atype *atypes; expptr q; char buf[208], buf1[32], buf2[32]; static int initargs[4] = {TYCOMPLEX, TYDCOMPLEX, TYCHAR, TYFTNLEN+100}; static int *init_ap[TYSUBR+1] = {0,0,0,0,0,0,0, #ifdef TYQUAD 0, #endif initargs, initargs+1,0,0,0,initargs+2}; i0 = init_ac[type]; t = init_ap[type]; te = t + i0; if (at = *at0) { *at1 = at; nargs = at->nargs; if (nargs < 0 && type && at->changes & 2 && !at->defined) --proc_protochanges; if (at->dnargs >= 0 && zap != 2) type = 0; if (nargs < 0) { /* inconsistent usage seen */ if (type) goto newlist; return; } atypes = at->atypes; i = nchargs; for(nbad = 0; t < te; atypes++) { if (++i > nargs) { toomany: i = nchargs + i0; for(cp = arglist; cp; cp = cp->nextp) i++; toofew: switch(zap) { case 2: zap = 6; break; case 1: if (at->defined & 4) return; } sprintf(buf, "%s%.90s:\n\there %d, previously %d args and string lengths.", inconsist, fname, i, nargs); atype_squawk(at, buf); if (type) { t = init_ap[type]; goto newlist; } return; } j = atypes->type; k = *t++; if (j != k && j-400 != k) { cp = 0; goto badtypes; } } for(cp = arglist; cp; atypes++, cp = cp->nextp) { if (++i > nargs) goto toomany; j = atypes->type; if (!(q = (expptr)cp->datap)) continue; k = typekludge(ccall, q, atypes, j); if (k >= 300 || k == j) continue; if (j >= 300) { if (k >= 200) { if (k == TYUNKNOWN + 200) continue; if (j % 100 != k - 200 && k != TYSUBR + 200 && j != TYUNKNOWN + 300 && !type_fixup(at,atypes,k)) goto badtypes; } else if (j % 100 % TYSUBR != k % TYSUBR && !type_fixup(at,atypes,k)) goto badtypes; } else if (k < 200 || j < 200) if (j) { if (k == TYUNKNOWN && q->tag == TNAME && q->nameblock.vinfproc) { q->nameblock.vdcldone = 0; impldcl((Namep)q); } goto badtypes; } else ; /* fall through to update */ else if (k == TYUNKNOWN+200) continue; else if (j != TYUNKNOWN+200) { badtypes: if (++nbad == 1) bad_atypes(at, fname, i - nchargs, j, k, "here ", ", previously"); else fprintf(stderr, "\targ %d: here %s, previously %s.\n", i - nchargs, Argtype(k,buf1), Argtype(j,buf2)); if (!cp) break; continue; } /* We've subsequently learned the right type, as in the call on zoo below... subroutine foo(x, zap) external zap call goo(zap) x = zap(3) call zoo(zap) end */ if (!nbad) { atypes->type = k; at->changes |= 1; } } if (i < nargs) goto toofew; if (nbad) { if (type) { /* we're defining the procedure */ t = init_ap[type]; te = t + i0; proc_argchanges = 1; goto newlist; } return; } if (zap == 1 && (at->changes & 5) != 5) at->changes = 0; return; } newlist: i = i0 + nchargs; for(cp = arglist; cp; cp = cp->nextp) i++; k = sizeof(Argtypes) + (i-1)*sizeof(Atype); *at0 = *at1 = at = stg == STGEXT ? (Argtypes *)gmem(k,1) : (Argtypes *) mem(k,1); at->dnargs = at->nargs = i; at->defined = zap & 6; at->changes = type ? 0 : 4; atypes = at->atypes; for(; t < te; atypes++) { atypes->type = *t++; atypes->cp = 0; } for(cp = arglist; cp; atypes++, cp = cp->nextp) { atypes->cp = 0; atypes->type = (q = (expptr)cp->datap) ? typekludge(ccall, q, atypes, 0) : 0; } for(; --nchargs >= 0; atypes++) { atypes->type = TYFTNLEN + 100; atypes->cp = 0; } } static char* #ifdef KR_headers get_argtypes(p, pat0, pat1) Exprp p; Argtypes ***pat0, ***pat1; #else get_argtypes(Exprp p, Argtypes ***pat0, Argtypes ***pat1) #endif { Addrp a; Argtypes **at0, **at1; Namep np; Extsym *e; char *fname; a = (Addrp)p->leftp; switch(a->vstg) { case STGEXT: switch(a->uname_tag) { case UNAM_EXTERN: /* e.g., sqrt() */ e = extsymtab + a->memno; at0 = at1 = &e->arginfo; fname = e->fextname; break; case UNAM_NAME: np = a->user.name; at0 = &extsymtab[np->vardesc.varno].arginfo; at1 = &np->arginfo; fname = np->fvarname; break; default: goto bug; } break; case STGARG: if (a->uname_tag != UNAM_NAME) goto bug; np = a->user.name; at0 = at1 = &np->arginfo; fname = np->fvarname; break; default: bug: Fatal("Confusion in saveargtypes"); } *pat0 = at0; *pat1 = at1; return fname; } void #ifdef KR_headers saveargtypes(p) register Exprp p; #else saveargtypes(register Exprp p) #endif /* for writing prototypes */ { Argtypes **at0, **at1; chainp arglist; expptr rp; char *fname; fname = get_argtypes(p, &at0, &at1); rp = p->rightp; arglist = rp && rp->tag == TLIST ? rp->listblock.listp : 0; save_argtypes(arglist, at0, at1, p->opcode == OPCCALL, fname, p->leftp->addrblock.vstg, 0, 0, 0); } /* putcall - fix up the argument list, and write out the invocation. p is expected to be initialized and point to an OPCALL or OPCCALL expression. The return value is a pointer to a temporary holding the result of a COMPLEX or CHARACTER operation, or NULL. */ LOCAL expptr #ifdef KR_headers putcall(p0, temp) expptr p0; Addrp *temp; #else putcall(expptr p0, Addrp *temp) #endif { register Exprp p = (Exprp)p0; chainp arglist; /* Pointer to actual arguments, if any */ chainp charsp; /* List of copies of the variables which hold the lengths of character parameters (other than procedure parameters) */ chainp cp; /* Iterator over argument lists */ register expptr q; /* Pointer to the current argument */ Addrp fval; /* Function return value */ int type; /* type of the call - presumably this was set elsewhere */ int byvalue; /* True iff we don't want to massage the parameter list, since we're calling a C library routine */ char *s; Argtypes *at, **at0, **at1; Atype *At, *Ate; type = p -> vtype; charsp = NULL; byvalue = (p->opcode == OPCCALL); /* Verify the actual parameters */ if (p == (Exprp) NULL) err ("putcall: NULL call expression"); else if (p -> tag != TEXPR) erri ("putcall: expected TEXPR, got '%d'", p -> tag); /* Find the argument list */ if(p->rightp && p -> rightp -> tag == TLIST) arglist = p->rightp->listblock.listp; else arglist = NULL; /* Count the number of explicit arguments, including lengths of character variables */ if (!byvalue) { get_argtypes(p, &at0, &at1); At = Ate = 0; if ((at = *at0) && at->nargs >= 0) { At = at->atypes; Ate = At + at->nargs; At += init_ac[type]; } for(cp = arglist ; cp ; cp = cp->nextp) { q = (expptr) cp->datap; if( ISCONST(q) ) { /* Even constants are passed by reference, so we need to put them in the literal table */ q = (expptr) putconst((Constp)q); cp->datap = (char *) q; } /* Save the length expression of character variables (NOT character procedures) for the end of the argument list */ if( ISCHAR(q) && (q->headblock.vclass != CLPROC || q->headblock.vstg == STGARG && q->tag == TADDR && q->addrblock.uname_tag == UNAM_NAME && q->addrblock.user.name->vprocclass == PTHISPROC) && (!At || At->type % 100 % TYSUBR == TYCHAR)) { p0 = cpexpr(q->headblock.vleng); charsp = mkchain((char *)p0, charsp); if (q->headblock.vclass == CLUNKNOWN && q->headblock.vstg == STGARG) q->addrblock.user.name->vpassed = 1; else if (q->tag == TADDR && q->addrblock.uname_tag == UNAM_CONST) p0->constblock.Const.ci += q->addrblock.user.Const.ccp1.blanks; } if (At && ++At == Ate) At = 0; } } charsp = revchain(charsp); /* If the routine is a CHARACTER function ... */ if(type == TYCHAR) { if( ISICON(p->vleng) ) { /* Allocate a temporary to hold the return value of the function */ fval = mktmp(TYCHAR, p->vleng); } else { err("adjustable character function"); if (temp) *temp = 0; return 0; } } /* If the routine is a COMPLEX function ... */ else if( ISCOMPLEX(type) ) fval = mktmp(type, ENULL); else fval = NULL; /* Write the function name, without taking its address */ p -> leftp = putx(fixtype(putaddr(p->leftp))); if(fval) { chainp prepend; /* Prepend a copy of the function return value buffer out as the first argument. */ prepend = mkchain((char *)putx(putaddr(cpexpr((expptr)fval))), arglist); /* If it's a character function, also prepend the length of the result */ if(type==TYCHAR) { prepend->nextp = mkchain((char *)putx(mkconv(TYLENG, p->vleng)), arglist); } if (!(q = p->rightp)) p->rightp = q = (expptr)mklist(CHNULL); q->listblock.listp = prepend; } /* Scan through the fortran argument list */ for(cp = arglist ; cp ; cp = cp->nextp) { q = (expptr) (cp->datap); if (q == ENULL) err ("putcall: NULL argument"); /* call putaddr only when we've got a parameter for a C routine or a memory resident parameter */ if (q -> tag == TCONST && !byvalue) q = (expptr) putconst ((Constp)q); if(q->tag==TADDR && (byvalue || q->addrblock.vstg!=STGREG) ) { if (q->addrblock.parenused && !byvalue && q->headblock.vtype != TYCHAR) goto make_copy; cp->datap = (char *)putaddr(q); } else if( ISCOMPLEX(q->headblock.vtype) ) cp -> datap = (char *) putx (fixtype(putcxop(q))); else if (ISCHAR(q) ) cp -> datap = (char *) putx (fixtype((expptr)putchop(q))); else if( ! ISERROR(q) ) { if(byvalue) { if (q->tag == TEXPR && q->exprblock.opcode == OPCONV) { if (ISCOMPLEX(q->exprblock.leftp->headblock.vtype) && q->exprblock.leftp->tag == TEXPR) q->exprblock.leftp = putcxop(q->exprblock.leftp); else q->exprblock.leftp = putx(q->exprblock.leftp); } else cp -> datap = (char *) putx(q); } else if (q->tag == TEXPR && q->exprblock.opcode == OPCHARCAST) cp -> datap = (char *) putx(q); else { expptr t, t1; /* If we've got a register parameter, or (maybe?) a constant, save it in a temporary first */ make_copy: t = (expptr) mktmp(q->headblock.vtype, q->headblock.vleng); /* Assign to temporary variables before invoking the subroutine or function */ t1 = putassign( cpexpr(t), q ); if (doin_setbound) t = mkexpr(OPCOMMA_ARG, t1, t); else putout(t1); cp -> datap = (char *) t; } /* else */ } /* if !ISERROR(q) */ } /* Now adjust the lengths of the CHARACTER parameters */ for(cp = charsp ; cp ; cp = cp->nextp) cp->datap = (char *)addrfix(putx( /* in case MAIN has a character*(*)... */ (s = cp->datap) ? mkconv(TYLENG,(expptr)s) : ICON(0))); /* ... and add them to the end of the argument list */ hookup (arglist, charsp); /* Return the name of the temporary used to hold the results, if any was necessary. */ if (temp) *temp = fval; else frexpr ((expptr)fval); saveargtypes(p); return (expptr) p; } static expptr #ifdef KR_headers foldminmax(op, type, p) int op; int type; chainp p; #else foldminmax(int op, int type, chainp p) #endif { Constp c, c1; ftnint i, i1; double d, d1; int dstg, d1stg; char *s, *s1; c = ALLOC(Constblock); c->tag = TCONST; c->vtype = type; s = s1 = 0; switch(type) { case TYREAL: case TYDREAL: c1 = (Constp)p->datap; d = ISINT(c1->vtype) ? (double)c1->Const.ci : c1->vstg ? atof(c1->Const.cds[0]) : c1->Const.cd[0]; dstg = 0; if (ISINT(c1->vtype)) d = (double)c1->Const.ci; else if (dstg = c1->vstg) d = atof(s = c1->Const.cds[0]); else d = c1->Const.cd[0]; while(p = p->nextp) { c1 = (Constp)p->datap; d1stg = 0; if (ISINT(c1->vtype)) d1 = (double)c1->Const.ci; else if (d1stg = c1->vstg) d1 = atof(s1 = c1->Const.cds[0]); else d1 = c1->Const.cd[0]; if (op == OPMIN) { if (d > d1) goto d1copy; } else if (d < d1) { d1copy: d = d1; dstg = d1stg; s = s1; } } if (c->vstg = dstg) c->Const.cds[0] = s; else c->Const.cd[0] = d; break; default: i = ((Constp)p->datap)->Const.ci; while(p = p->nextp) { i1 = ((Constp)p->datap)->Const.ci; if (op == OPMIN) { if (i > i1) i = i1; } else if (i < i1) i = i1; } c->Const.ci = i; } return (expptr)c; } /* putmnmx -- Put min or max. p must point to an EXPR, not just a CONST */ LOCAL expptr #ifdef KR_headers putmnmx(p) register expptr p; #else putmnmx(register expptr p) #endif { int op, op2, type; expptr arg, qp, temp; chainp p0, p1; Addrp sp, tp; char comment_buf[80]; char *what; if(p->tag != TEXPR) badtag("putmnmx", p->tag); type = p->exprblock.vtype; op = p->exprblock.opcode; op2 = op == OPMIN ? OPMIN2 : OPMAX2; p0 = p->exprblock.leftp->listblock.listp; free( (charptr) (p->exprblock.leftp) ); free( (charptr) p ); /* for param statements, deal with constant expressions now */ for(p1 = p0;; p1 = p1->nextp) { if (!p1) { /* all constants */ p = foldminmax(op, type, p0); frchain(&p0); return p; } else if (!ISCONST(((expptr)p1->datap))) break; } /* special case for two addressable operands */ if (addressable((expptr)p0->datap) && (p1 = p0->nextp) && addressable((expptr)p1->datap) && !p1->nextp) { if (type == TYREAL && forcedouble) op2 = op == OPMIN ? OPDMIN : OPDMAX; p = mkexpr(op2, mkconv(type, cpexpr((expptr)p0->datap)), mkconv(type, cpexpr((expptr)p1->datap))); frchain(&p0); return p; } /* general case */ sp = mktmp(type, ENULL); /* We only need a second temporary if the arg list has an unaddressable value */ tp = (Addrp) NULL; qp = ENULL; for (p1 = p0 -> nextp; p1; p1 = p1 -> nextp) if (!addressable ((expptr) p1 -> datap)) { tp = mktmp(type, ENULL); qp = mkexpr(op2, cpexpr((expptr)sp), cpexpr((expptr)tp)); qp = fixexpr((Exprp)qp); break; } /* if */ /* Now output the appropriate number of assignments and comparisons. Min and max are implemented by the simple O(n) algorithm: min (a, b, c, d) ==> { t1, t2; t1 = a; t2 = b; t1 = (t1 < t2) ? t1 : t2; t2 = c; t1 = (t1 < t2) ? t1 : t2; t2 = d; t1 = (t1 < t2) ? t1 : t2; } */ if (!doin_setbound) { switch(op) { case OPLT: case OPMIN: case OPDMIN: case OPMIN2: what = "IN"; break; default: what = "AX"; } sprintf (comment_buf, "Computing M%s", what); p1_comment (comment_buf); } p1 = p0->nextp; temp = (expptr)p0->datap; if (addressable(temp) && addressable((expptr)p1->datap)) { p = mkconv(type, cpexpr(temp)); arg = mkconv(type, cpexpr((expptr)p1->datap)); temp = mkexpr(op2, p, arg); if (!ISCONST(temp)) temp = fixexpr((Exprp)temp); p1 = p1->nextp; } p = putassign (cpexpr((expptr)sp), temp); for(; p1 ; p1 = p1->nextp) { if (addressable ((expptr) p1 -> datap)) { arg = mkconv(type, cpexpr((expptr)p1->datap)); temp = mkexpr(op2, cpexpr((expptr)sp), arg); temp = fixexpr((Exprp)temp); } else { temp = (expptr) cpexpr (qp); p = mkexpr(OPCOMMA, p, putassign(cpexpr((expptr)tp), (expptr)p1->datap)); } /* else */ if(p1->nextp) p = mkexpr(OPCOMMA, p, putassign(cpexpr((expptr)sp), temp)); else { if (type == TYREAL && forcedouble) temp->exprblock.opcode = op == OPMIN ? OPDMIN : OPDMAX; if (doin_setbound) p = mkexpr(OPCOMMA, p, temp); else { putout (p); p = putx(temp); } if (qp) frexpr (qp); } /* else */ } /* for */ frchain( &p0 ); return p; } void #ifdef KR_headers putwhile(p) expptr p; #else putwhile(expptr p) #endif { int k, n; if (wh_next >= wh_last) { k = wh_last - wh_first; n = k + 100; wh_next = mem(n,0); wh_last = wh_first + n; if (k) memcpy(wh_next, wh_first, k); wh_first = wh_next; wh_next += k; wh_last = wh_first + n; } if( !ISLOGICAL((k = (p = fixtype(p))->headblock.vtype))) { if(k != TYERROR) err("non-logical expression in DO WHILE statement"); } else { p = putx(p); *wh_next++ = ftell(pass1_file) > p1_where; p1put(P1_WHILE2START); p1_expr(p); } } void #ifdef KR_headers westart(elseif) int elseif; #else westart(int elseif) #endif { static int we[2] = { P1_WHILE1START, P1_ELSEIFSTART }; p1put(we[elseif]); p1_where = ftell(pass1_file); } f2c/src/readme000066400000000000000000000174451171647030000135110ustar00rootroot00000000000000To compile f2c on Linux or Unix systems, copy makefile.u to makefile, edit makefile if necessary (see the comments in it and below) and type "make" (or maybe "nmake", depending on your system). To compile f2c.exe on MS Windows systems with Microsoft Visual C++, copy makefile.vc makefile nmake With other PC compilers, you may need to compile xsum.c with -DMSDOS (i.e., with MSDOS #defined). If your compiler does not understand ANSI/ISO C syntax (i.e., if you have a K&R C compiler), compile with -DKR_headers . On non-Unix systems where files have separate binary and text modes, you may need to "make xsumr.out" rather than "make xsum.out". If (in accordance with what follows) you need to any of the source files (excluding the makefile), first issue a "make xsum.out" (or, if appropriate, "make xsumr.out") to check the validity of the f2c source, then make your changes, then type "make f2c". The file usignal.h is for the benefit of strictly ANSI include files on a UNIX system -- the ANSI signal.h does not define SIGHUP or SIGQUIT. You may need to modify usignal.h if you are not running f2c on a UNIX system. Should you get the message "xsum0.out xsum1.out differ", see what lines are different (`diff xsum0.out xsum1.out`) and ask netlib (e.g., netlib@netlib.org) to send you the files in question, plus the current xsum0.out (which may have changed) "from f2c/src". For example, if exec.c and expr.c have incorrect check sums, you would send netlib the message send exec.c expr.c xsum0.out from f2c/src You can also ftp these files from netlib.bell-labs.com; for more details, ask netlib@netlib.org to "send readme from f2c". On some systems, the malloc and free in malloc.c let f2c run faster than do the standard malloc and free. Other systems may not tolerate redefinition of malloc and free (though changes of 8 Nov. 1994 may render this less of a problem than hitherto). If your system permits use of a user-supplied malloc, you may wish to change the MALLOC = line in the makefile to "MALLOC = malloc.o", or to type make MALLOC=malloc.o instead of make Still other systems have a -lmalloc that provides performance competitive with that from malloc.c; you may wish to compare the two on your system. If your system does not permit user-supplied malloc routines, then f2c may fault with "MALLOC=malloc.o", or may display other untoward behavior. On some BSD systems, you may need to create a file named "string.h" whose single line is #include you may need to add " -Dstrchr=index" to the "CFLAGS =" assignment in the makefile, and you may need to add " memset.o" to the "OBJECTS =" assignment in the makefile -- see the comments in memset.c . For non-UNIX systems, you may need to change some things in sysdep.c, such as the choice of intermediate file names. On some systems, you may need to modify parts of sysdep.h (which is included by defs.h). In particular, for Sun 4.1 systems and perhaps some others, you need to comment out the typedef of size_t. For some systems (e.g., IRIX 4.0.1 and AIX) it is better to add #define ANSI_Libraries to the beginning of sysdep.h (or to supply -DANSI_Libraries in the makefile). Alas, some systems #define __STDC__ but do not provide a true standard (ANSI or ISO) C environment, e.g. do not provide stdlib.h . If yours is such a system, then (a) you should complain loudly to your vendor about __STDC__ being erroneously defined, and (b) you should insert #undef __STDC__ at the beginning of sysdep.h . You may need to make other adjustments. For some non-ANSI versions of stdio, you must change the values given to binread and binwrite in sysdep.c from "rb" and "wb" to "r" and "w". You may need to make this change if you run f2c and get an error message of the form Compiler error ... cannot open intermediate file ... In the days of yore, two libraries, libF77 and libI77, were used with f77 (the Fortran compiler on which f2c is based). Separate source for these libraries is still available from netlib, but it is more convenient to combine them into a single library, libf2c. Source for this combined library is also available from netlib in f2c/libf2c.zip, e.g., http://netlib.bell-labs.com/netlib/f2c/libf2c.zip or http://www.netlib.org/f2c/libf2c.zip (and similarly for other netlib mirrors). After unzipping libf2c.zip, copy the relevant makefile.* to makefile, edit makefile if necessary (see the comments in it and in libf2c/README) and invoke "make" or "nmake". The resulting library is called *f2c.lib on MS Windows systems and libf2c.a or libf2c.so on Linux and Unix systems; makefile.u just shows how to make libf2c.a. Details on creating the shared-library variant, libf2c.so, are system-dependent; some that have worked under Linux appear below. For some other systems, you can glean the details from the system-dependent makefile variants in directory http://www.netlib.org/ampl/solvers/funclink or http://netlib.bell-labs.com/netlib/ampl/solvers/funclink, etc. In general, under Linux it is necessary to compile libf2c (or libI77) with -DNON_UNIX_STDIO . Under at least one variant of Linux, you can make and install a shared-library version of libf2c by compiling libI77 with -DNON_UNIX_STDIO, creating libf2c.a as above, and then executing mkdir t ln lib?77/*.o t cd t; cc -shared -o ../libf2c.so -Wl,-soname,libf2c.so.1 *.o cd .. rm -r t rm /usr/lib/libf2c* mv libf2c.a libf2c.so /usr/lib cd /usr/lib ln libf2c.so libf2c.so.1 ln libf2c.so libf2c.so.1.0.0 On some other systems, /usr/local/lib is the appropriate installation directory. Some older C compilers object to typedef void (*foo)(); or to typedef void zap; zap (*foo)(); If yours is such a compiler, change the definition of VOID in f2c.h from void to int. For convenience with systems that use control-Z to denote end-of-file, f2c treats control-Z characters (ASCII 26, '\x1a') that appear at the beginning of a line as an end-of-file indicator. You can disable this test by compiling lex.c with NO_EOF_CHAR_CHECK #defined, or can change control-Z to some other character by #defining EOF_CHAR to be the desired value. If your machine has IEEE, VAX, or IBM-mainframe arithmetic, but your printf is inaccurate (e.g., with Symantec C++ version 6.0, printf("%.17g",12.) prints 12.000000000000001), you can make f2c print correctly rounded numbers by compiling with -DUSE_DTOA and adding dtoa.o g_fmt.o to the makefile's OBJECTS = line, so it becomes OBJECTS = $(OBJECTSd) malloc.o dtoa.o g_fmt.o Also add the rule dtoa.o: dtoa.c $(CC) -c $(CFLAGS) -DMALLOC=ckalloc -DIEEE... dtoa.c (without the initial tab) to the makefile, where IEEE... is one of IEEE_MC68k, IEEE_8087, VAX, or IBM, depending on your machine's arithmetic. See the comments near the start of dtoa.c. The relevant source files, dtoa.c and g_fmt.c, are available separately from netlib's fp directory. For example, you could send the E-mail message send dtoa.c g_fmt.c from fp to netlib@netlib.netlib.org (or use anonymous ftp from ftp.netlib.org and look in directory /netlib/fp). The makefile has a rule for creating tokdefs.h. If you cannot use the makefile, an alternative is to extract tokdefs.h from the beginning of gram.c: it's the first 100 lines. File mem.c has #ifdef CRAY lines that are appropriate for machines with the conventional CRAY architecture, but not for "Cray" machines based on DEC Alpha chips, such as the T3E; on such machines, you may need to make a suitable adjustment, e.g., add #undef CRAY to sysdep.h. Please send bug reports to dmg at acm.org (with " at " changed to "@"). The old index file (now called "readme" due to unfortunate changes in netlib conventions: "send readme from f2c") will report recent changes in the recent-change log at its end; all changes will be shown in the "changes" file ("send changes from f2c"). To keep current source, you will need to request xsum0.out and version.c, in addition to the changed source files. f2c/src/sysdep.c000066400000000000000000000370251171647030000140000ustar00rootroot00000000000000/**************************************************************** Copyright 1990 - 1994, 2000 by AT&T, Lucent Technologies and Bellcore. Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the above copyright notice appear in all copies and that both that the copyright notice and this permission notice and warranty disclaimer appear in supporting documentation, and that the names of AT&T, Bell Laboratories, Lucent or Bellcore or any of their entities not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. AT&T, Lucent and Bellcore disclaim all warranties with regard to this software, including all implied warranties of merchantability and fitness. In no event shall AT&T, Lucent or Bellcore be liable for any special, indirect or consequential damages or any damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortious action, arising out of or in connection with the use or performance of this software. ****************************************************************/ #include "defs.h" #include "usignal.h" char binread[] = "rb", textread[] = "r"; char binwrite[] = "wb", textwrite[] = "w"; char *c_functions = "c_functions"; char *coutput = "c_output"; char *initfname = "raw_data"; char *initbname = "raw_data.b"; char *blkdfname = "block_data"; char *p1_file = "p1_file"; char *p1_bakfile = "p1_file.BAK"; char *sortfname = "init_file"; char *proto_fname = "proto_file"; char link_msg[] = "on Microsoft Windows system, link with libf2c.lib;\n\ on Linux or Unix systems, link with .../path/to/libf2c.a -lm\n\ or, if you install libf2c.a in a standard place, with -lf2c -lm\n\ -- in that order, at the end of the command line, as in\n\ cc *.o -lf2c -lm\n\ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,\n\n\ http://www.netlib.org/f2c/libf2c.zip"; char *outbuf = "", *outbtail; #undef WANT_spawnvp #ifdef MSDOS #ifndef NO_spawnvp #define WANT_spawnvp #endif #endif #ifdef _WIN32 #include /* for GetVolumeInformation */ #undef WANT_spawnvp #define WANT_spawnvp #undef MSDOS #define MSDOS #endif #ifdef WANT_spawnvp #include #ifndef _P_WAIT #define _P_WAIT P_WAIT /* Symantec C/C++ */ #endif static char **spargv, **pfname; #endif char *tmpdir = ""; #ifdef __cplusplus #define Cextern extern "C" extern "C" { static void flovflo(int), killed(int); static int compare(const void *a, const void *b); } #else #define Cextern extern #endif Cextern int unlink Argdcl((const char *)); Cextern int fork Argdcl((void)), getpid Argdcl((void)), wait Argdcl((int*)); void #ifdef KR_headers Un_link_all(cdelete) int cdelete; #else Un_link_all(int cdelete) #endif { if (!debugflag) { unlink(c_functions); unlink(initfname); unlink(p1_file); unlink(sortfname); unlink(blkdfname); if (cdelete && coutput) unlink(coutput); } } #ifndef NO_TEMPDIR static void rmtdir(Void) { char *s; if (*(s = tmpdir)) { tmpdir = ""; rmdir(s); } } #endif /*NO_TEMPDIR*/ #ifndef MSDOS #include "sysdep.hd" #ifndef NO_MKDTEMP #include /* for mkdtemp */ #endif #endif static void alloc_names(Void) { int k = strlen(tmpdir) + 24; c_functions = (char *)ckalloc(7*k); initfname = c_functions + k; initbname = initfname + k; blkdfname = initbname + k; p1_file = blkdfname + k; p1_bakfile = p1_file + k; sortfname = p1_bakfile + k; } void set_tmp_names(Void) { #ifdef MSDOS char buf[64], *s, *t; #ifdef _WIN32 DWORD flags, maxlen, volser; char volname[512], f2c[24], fsname[512], *name1; int i; if (debugflag == 1) return; i = sprintf(f2c, "%x", _getpid()); if (!GetVolumeInformation(NULL, volname, sizeof(volname), &volser, &maxlen, &flags, fsname, sizeof(fsname)) || maxlen < i+8) /* FAT16 */ strcpy(f2c, "f2c_"); #else static char f2c[] = "f2c_"; if (debugflag == 1) return; #endif if (!*tmpdir || *tmpdir == '.' && !tmpdir[1]) t = ""; else { /* substitute \ for / to avoid confusion with a * switch indicator in the system("sort ...") * call in formatdata.c */ for(s = tmpdir, t = buf; *s; s++, t++) if ((*t = *s) == '/') *t = '\\'; if (t[-1] != '\\') *t++ = '\\'; *t = 0; t = buf; } alloc_names(); sprintf(c_functions, "%s%sfunc", t, f2c); sprintf(initfname, "%s%srd", t, f2c); sprintf(blkdfname, "%s%sblkd", t, f2c); sprintf(p1_file, "%s%sp1f", t, f2c); sprintf(p1_bakfile, "%s%sp1fb", t, f2c); sprintf(sortfname, "%s%ssort", t, f2c); #else /*!MSDOS*/ long pid; #define L_TDNAME 20 #ifdef NO_MKDTEMP #ifdef NO_MKSTEMP #undef L_TDNAME #define L_TDNAME L_tmpnam #endif #endif static char tdbuf[L_TDNAME]; if (debugflag == 1) return; pid = getpid(); if (!*tmpdir) { #ifdef NO_TEMPDIR tmpdir = "/tmp"; #else #ifdef NO_MKDTEMP #ifdef NO_MKSTEMP if (!(tmpdir = tmpnam(tdbuf))) { fprintf(stderr, "tmpnam failed (for -T)\n"); exit(1); } #else int f; strcpy(tdbuf, "/tmp/f2ctd_XXXXXX"); f = mkstemp(tdbuf); if (f >= 0) { close(f); remove(tmpdir = tdbuf); } else { fprintf(stderr, "mkstemp failed (for -T)\n"); exit(1); } #endif /*NO_MKSTEMP*/ if (mkdir(tdbuf,0700)) { fprintf(stderr, "mkdir failed (for -T)\n"); exit(1); } #else /*!NO_MKDTEMP*/ strcpy(tdbuf, "/tmp/f2ctd_XXXXXX"); if (!(tmpdir = mkdtemp(tdbuf))) { fprintf(stderr, "mkdtemp failed (for -T)\n"); exit(1); } #endif /*NO_MKDTEMP*/ if (!debugflag) atexit(rmtdir); #endif /*NO_TEMPDIR*/ } alloc_names(); sprintf(c_functions, "%s/f2c%ld_func", tmpdir, pid); sprintf(initfname, "%s/f2c%ld_rd", tmpdir, pid); sprintf(blkdfname, "%s/f2c%ld_blkd", tmpdir, pid); sprintf(p1_file, "%s/f2c%ld_p1f", tmpdir, pid); sprintf(p1_bakfile, "%s/f2c%ld_p1fb", tmpdir, pid); sprintf(sortfname, "%s/f2c%ld_sort", tmpdir, pid); #endif /*MSDOS*/ sprintf(initbname, "%s.b", initfname); if (debugflag) fprintf(diagfile, "%s %s %s %s %s %s\n", c_functions, initfname, blkdfname, p1_file, p1_bakfile, sortfname); } char * #ifdef KR_headers c_name(s, ft) char *s; int ft; #else c_name(char *s, int ft) #endif { char *b, *s0; int c; b = s0 = s; while(c = *s++) if (c == '/') b = s; if (--s < s0 + 3 || s[-2] != '.' || ((c = *--s) != 'f' && c != 'F')) { infname = s0; Fatal("file name must end in .f or .F"); } strcpy(outbtail, b); outbtail[s-b] = ft; b = copys(outbuf); return b; } static void #ifdef KR_headers killed(sig) int sig; #else killed(int sig) #endif { sig = sig; /* shut up warning */ signal(SIGINT, SIG_IGN); #ifdef SIGQUIT signal(SIGQUIT, SIG_IGN); #endif #ifdef SIGHUP signal(SIGHUP, SIG_IGN); #endif signal(SIGTERM, SIG_IGN); Un_link_all(1); exit(126); } static void #ifdef KR_headers sig1catch(sig) int sig; #else sig1catch(int sig) #endif { sig = sig; /* shut up warning */ if (signal(sig, SIG_IGN) != SIG_IGN) signal(sig, killed); } static void #ifdef KR_headers flovflo(sig) int sig; #else flovflo(int sig) #endif { sig = sig; /* shut up warning */ Fatal("floating exception during constant evaluation; cannot recover"); /* vax returns a reserved operand that generates an illegal operand fault on next instruction, which if ignored causes an infinite loop. */ signal(SIGFPE, flovflo); } void #ifdef KR_headers sigcatch(sig) int sig; #else sigcatch(int sig) #endif { sig = sig; /* shut up warning */ sig1catch(SIGINT); #ifdef SIGQUIT sig1catch(SIGQUIT); #endif #ifdef SIGHUP sig1catch(SIGHUP); #endif sig1catch(SIGTERM); signal(SIGFPE, flovflo); /* catch overflows */ } /* argkludge permits wild-card expansion and caching of the original or expanded */ /* argv to kludge around the lack of fork() and exec() when necessary. */ void #ifdef KR_headers argkludge(pargc, pargv) int *pargc; char ***pargv; #else argkludge(int *pargc, char ***pargv) #endif { #ifdef WANT_spawnvp size_t L, L1; int argc, i, nf; char **a, **argv, *s, *t, *t0; /* Assume wild-card expansion has been done by Microsoft's setargv.obj */ /* Count Fortran input files. */ L = argc = *pargc; argv = *pargv; for(i = nf = 0; i < argc; i++) { L += L1 = strlen(s = argv[i]); if (L1 > 2 && s[L1-2] == '.') switch(s[L1-1]) { case 'f': case 'F': nf++; } } if (nf <= 1) return; /* Cache inputs */ i = argc - nf + 2; a = spargv = (char**)Alloc(i*sizeof(char*) + L); t = (char*)(a + i); for(i = 0; i < argc; i++) { *a++ = t0 = t; for(s = argv[i]; *t++ = *s; s++); if (t-t0 > 3 && s[-2] == '.') switch(s[-1]) { case 'f': case 'F': --a; t = t0; } } pfname = a++; *a = 0; #endif } int #ifdef KR_headers dofork(fname) char *fname; #else dofork(char *fname) #endif { extern int retcode; #ifdef MSDOS #ifdef WANT_spawnvp *pfname = fname; retcode |= _spawnvp(_P_WAIT, spargv[0], (char const*const*)spargv); #else /*_WIN32*/ Fatal("Only one Fortran input file allowed under MS-DOS"); #endif /*_WIN32*/ #else int pid, status, w; if (!(pid = fork())) return 1; if (pid == -1) Fatal("bad fork"); while((w = wait(&status)) != pid) if (w == -1) Fatal("bad wait code"); retcode |= status >> 8; #endif return 0; } /* Initialization of tables that change with the character set... */ char escapes[Table_size]; #ifdef non_ASCII char *str_fmt[Table_size]; static char *str0fmt[127] = { /*}*/ #else char *str_fmt[Table_size] = { #endif "\\000", "\\001", "\\002", "\\003", "\\004", "\\005", "\\006", "\\007", "\\b", "\\t", "\\n", "\\013", "\\f", "\\r", "\\016", "\\017", "\\020", "\\021", "\\022", "\\023", "\\024", "\\025", "\\026", "\\027", "\\030", "\\031", "\\032", "\\033", "\\034", "\\035", "\\036", "\\037", " ", "!", "\\\"", "#", "$", "%%", "&", "'", "(", ")", "*", "+", ",", "-", ".", "/", "0", "1", "2", "3", "4", "5", "6", "7", "8", "9", ":", ";", "<", "=", ">", "?", "@", "A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z", "[", "\\\\", "]", "^", "_", "`", "a", "b", "c", "d", "e", "f", "g", "h", "i", "j", "k", "l", "m", "n", "o", "p", "q", "r", "s", "t", "u", "v", "w", "x", "y", "z", "{", "|", "}", "~" }; #ifdef non_ASCII char *chr_fmt[Table_size]; static char *chr0fmt[127] = { /*}*/ #else char *chr_fmt[Table_size] = { #endif "\\0", "\\1", "\\2", "\\3", "\\4", "\\5", "\\6", "\\7", "\\b", "\\t", "\\n", "\\13", "\\f", "\\r", "\\16", "\\17", "\\20", "\\21", "\\22", "\\23", "\\24", "\\25", "\\26", "\\27", "\\30", "\\31", "\\32", "\\33", "\\34", "\\35", "\\36", "\\37", " ", "!", "\"", "#", "$", "%%", "&", "\\'", "(", ")", "*", "+", ",", "-", ".", "/", "0", "1", "2", "3", "4", "5", "6", "7", "8", "9", ":", ";", "<", "=", ">", "?", "@", "A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z", "[", "\\\\", "]", "^", "_", "`", "a", "b", "c", "d", "e", "f", "g", "h", "i", "j", "k", "l", "m", "n", "o", "p", "q", "r", "s", "t", "u", "v", "w", "x", "y", "z", "{", "|", "}", "~" }; void fmt_init(Void) { static char *str1fmt[6] = { "\\b", "\\t", "\\n", "\\f", "\\r", "\\013" }; register int i, j; register char *s; /* str_fmt */ #ifdef non_ASCII i = 0; #else i = 127; #endif s = Alloc(5*(Table_size - i)); for(; i < Table_size; i++) { sprintf(str_fmt[i] = s, "\\%03o", i); s += 5; } #ifdef non_ASCII for(i = 32; i < 127; i++) { s = str0fmt[i]; str_fmt[*(unsigned char *)s] = s; } str_fmt['"'] = "\\\""; #else if (Ansi == 1) str_fmt[7] = chr_fmt[7] = "\\a"; #endif /* chr_fmt */ #ifdef non_ASCII for(i = 0; i < 32; i++) chr_fmt[i] = chr0fmt[i]; #else i = 127; #endif for(; i < Table_size; i++) chr_fmt[i] = "\\%o"; #ifdef non_ASCII for(i = 32; i < 127; i++) { s = chr0fmt[i]; j = *(unsigned char *)s; if (j == '\\') j = *(unsigned char *)(s+1); chr_fmt[j] = s; } #endif /* escapes (used in lex.c) */ for(i = 0; i < Table_size; i++) escapes[i] = i; for(s = "btnfr0", i = 0; i < 6; i++) escapes[*(unsigned char *)s++] = "\b\t\n\f\r"[i]; /* finish str_fmt and chr_fmt */ if (Ansi) str1fmt[5] = "\\v"; if ('\v' == 'v') { /* ancient C compiler */ str1fmt[5] = "v"; #ifndef non_ASCII escapes['v'] = 11; #endif } else escapes['v'] = '\v'; for(s = "\b\t\n\f\r\v", i = 0; j = *(unsigned char *)s++;) str_fmt[j] = chr_fmt[j] = str1fmt[i++]; /* '\v' = 11 for both EBCDIC and ASCII... */ chr_fmt[11] = (char*)(Ansi ? "\\v" : "\\13"); } void outbuf_adjust(Void) { int n, n1; char *s; n = n1 = strlen(outbuf); if (*outbuf && outbuf[n-1] != '/') n1++; s = Alloc(n+64); outbtail = s + n1; strcpy(s, outbuf); if (n != n1) strcpy(s+n, "/"); outbuf = s; } /* Unless SYSTEM_SORT is defined, the following gives a simple * in-core version of dsort(). On Fortran source with huge DATA * statements, the in-core version may exhaust the available memory, * in which case you might either recompile this source file with * SYSTEM_SORT defined (if that's reasonable on your system), or * replace the dsort below with a more elaborate version that * does a merging sort with the help of auxiliary files. */ #ifdef SYSTEM_SORT int #ifdef KR_headers dsort(from, to) char *from; char *to; #else dsort(char *from, char *to) #endif { char buf[200]; sprintf(buf, "sort <%s >%s", from, to); return system(buf) >> 8; } #else static int #ifdef KR_headers compare(a,b) char *a, *b; #else compare(const void *a, const void *b) #endif { return strcmp(*(char **)a, *(char **)b); } int #ifdef KR_headers dsort(from, to) char *from; char *to; #else dsort(char *from, char *to) #endif { struct Memb { struct Memb *next; int n; char buf[32000]; }; typedef struct Memb memb; memb *mb, *mb1; register char *x, *x0, *xe; register int c, n; FILE *f; char **z, **z0; int nn = 0; f = opf(from, textread); mb = (memb *)Alloc(sizeof(memb)); mb->next = 0; x0 = x = mb->buf; xe = x + sizeof(mb->buf); n = 0; for(;;) { c = getc(f); if (x >= xe && (c != EOF || x != x0)) { if (!n) return 126; nn += n; mb->n = n; mb1 = (memb *)Alloc(sizeof(memb)); mb1->next = mb; mb = mb1; memcpy(mb->buf, x0, n = x-x0); x0 = mb->buf; x = x0 + n; xe = x0 + sizeof(mb->buf); n = 0; } if (c == EOF) break; if (c == '\n') { ++n; *x++ = 0; x0 = x; } else *x++ = c; } clf(&f, from, 1); f = opf(to, textwrite); if (x > x0) { /* shouldn't happen */ *x = 0; ++n; } mb->n = n; nn += n; if (!nn) /* shouldn't happen */ goto done; z = z0 = (char **)Alloc(nn*sizeof(char *)); for(mb1 = mb; mb1; mb1 = mb1->next) { x = mb1->buf; n = mb1->n; for(;;) { *z++ = x; if (--n <= 0) break; while(*x++); } } qsort((char *)z0, nn, sizeof(char *), compare); for(n = nn, z = z0; n > 0; n--) fprintf(f, "%s\n", *z++); free((char *)z0); done: clf(&f, to, 1); do { mb1 = mb->next; free((char *)mb); } while(mb = mb1); return 0; } #endif f2c/src/sysdep.h000066400000000000000000000053031171647030000137770ustar00rootroot00000000000000/**************************************************************** Copyright 1990, 1991, 1994 by AT&T, Lucent Technologies and Bellcore. Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the above copyright notice appear in all copies and that both that the copyright notice and this permission notice and warranty disclaimer appear in supporting documentation, and that the names of AT&T, Bell Laboratories, Lucent or Bellcore or any of their entities not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. AT&T, Lucent and Bellcore disclaim all warranties with regard to this software, including all implied warranties of merchantability and fitness. In no event shall AT&T, Lucent or Bellcore be liable for any special, indirect or consequential damages or any damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortious action, arising out of or in connection with the use or performance of this software. ****************************************************************/ /* This file is included at the start of defs.h; this file * is an initial attempt to gather in one place some declarations * that may need to be tweaked on some systems. */ #ifdef __STDC__ #undef KR_headers #endif #ifndef KR_headers #ifndef ANSI_Libraries #define ANSI_Libraries #endif #ifndef ANSI_Prototypes #define ANSI_Prototypes #endif #endif #ifdef __BORLANDC__ #define MSDOS #endif #ifdef __ZTC__ /* Zortech */ #define MSDOS #endif #ifdef MSDOS #define ANSI_Libraries #define ANSI_Prototypes #define LONG_CAST (long) #else #define LONG_CAST #endif #include #ifdef ANSI_Libraries #include #include #else char *calloc(), *malloc(), *realloc(); void *memcpy(), *memset(); #ifndef _SIZE_T typedef unsigned int size_t; #endif #ifndef atol long atol(); #endif #ifdef ANSI_Prototypes extern double atof(const char *); extern double strtod(const char*, char**); #else extern double atof(), strtod(); #endif #endif /* On systems like VMS where fopen might otherwise create * multiple versions of intermediate files, you may wish to * #define scrub(x) unlink(x) */ #ifndef scrub #define scrub(x) /* do nothing */ #endif /* On systems that severely limit the total size of statically * allocated arrays, you may need to change the following to * extern char **chr_fmt, *escapes, **str_fmt; * and to modify sysdep.c appropriately */ extern char *chr_fmt[], escapes[], *str_fmt[]; #include #include "ctype.h" #define Bits_per_Byte 8 #define Table_size (1 << Bits_per_Byte) f2c/src/sysdeptest.c000066400000000000000000000006301171647030000146700ustar00rootroot00000000000000/* This is never meant to be executed; we just want to check for the */ /* presence of mkdtemp and mkstemp by whether this links without error. */ #include #include int #ifdef KR_headers main(argc, argv) int argc; char **argv; #else main(int argc, char **argv) #endif { char buf[16]; if (argc < 0) { #ifndef NO_MKDTEMP mkdtemp(buf); #else mkstemp(buf); #endif } return 0; } f2c/src/tokdefs.h000066400000000000000000000034411171647030000141300ustar00rootroot00000000000000#define SEOS 1 #define SCOMMENT 2 #define SLABEL 3 #define SUNKNOWN 4 #define SHOLLERITH 5 #define SICON 6 #define SRCON 7 #define SDCON 8 #define SBITCON 9 #define SOCTCON 10 #define SHEXCON 11 #define STRUE 12 #define SFALSE 13 #define SNAME 14 #define SNAMEEQ 15 #define SFIELD 16 #define SSCALE 17 #define SINCLUDE 18 #define SLET 19 #define SASSIGN 20 #define SAUTOMATIC 21 #define SBACKSPACE 22 #define SBLOCK 23 #define SCALL 24 #define SCHARACTER 25 #define SCLOSE 26 #define SCOMMON 27 #define SCOMPLEX 28 #define SCONTINUE 29 #define SDATA 30 #define SDCOMPLEX 31 #define SDIMENSION 32 #define SDO 33 #define SDOUBLE 34 #define SELSE 35 #define SELSEIF 36 #define SEND 37 #define SENDFILE 38 #define SENDIF 39 #define SENTRY 40 #define SEQUIV 41 #define SEXTERNAL 42 #define SFORMAT 43 #define SFUNCTION 44 #define SGOTO 45 #define SASGOTO 46 #define SCOMPGOTO 47 #define SARITHIF 48 #define SLOGIF 49 #define SIMPLICIT 50 #define SINQUIRE 51 #define SINTEGER 52 #define SINTRINSIC 53 #define SLOGICAL 54 #define SNAMELIST 55 #define SOPEN 56 #define SPARAM 57 #define SPAUSE 58 #define SPRINT 59 #define SPROGRAM 60 #define SPUNCH 61 #define SREAD 62 #define SREAL 63 #define SRETURN 64 #define SREWIND 65 #define SSAVE 66 #define SSTATIC 67 #define SSTOP 68 #define SSUBROUTINE 69 #define STHEN 70 #define STO 71 #define SUNDEFINED 72 #define SWRITE 73 #define SLPAR 74 #define SRPAR 75 #define SEQUALS 76 #define SCOLON 77 #define SCOMMA 78 #define SCURRENCY 79 #define SPLUS 80 #define SMINUS 81 #define SSTAR 82 #define SSLASH 83 #define SPOWER 84 #define SCONCAT 85 #define SAND 86 #define SOR 87 #define SNEQV 88 #define SEQV 89 #define SNOT 90 #define SEQ 91 #define SLT 92 #define SGT 93 #define SLE 94 #define SGE 95 #define SNE 96 #define SENDDO 97 #define SWHILE 98 #define SSLASHD 99 #define SBYTE 100 f2c/src/tokens000066400000000000000000000013351171647030000135460ustar00rootroot00000000000000SEOS SCOMMENT SLABEL SUNKNOWN SHOLLERITH SICON SRCON SDCON SBITCON SOCTCON SHEXCON STRUE SFALSE SNAME SNAMEEQ SFIELD SSCALE SINCLUDE SLET SASSIGN SAUTOMATIC SBACKSPACE SBLOCK SCALL SCHARACTER SCLOSE SCOMMON SCOMPLEX SCONTINUE SDATA SDCOMPLEX SDIMENSION SDO SDOUBLE SELSE SELSEIF SEND SENDFILE SENDIF SENTRY SEQUIV SEXTERNAL SFORMAT SFUNCTION SGOTO SASGOTO SCOMPGOTO SARITHIF SLOGIF SIMPLICIT SINQUIRE SINTEGER SINTRINSIC SLOGICAL SNAMELIST SOPEN SPARAM SPAUSE SPRINT SPROGRAM SPUNCH SREAD SREAL SRETURN SREWIND SSAVE SSTATIC SSTOP SSUBROUTINE STHEN STO SUNDEFINED SWRITE SLPAR SRPAR SEQUALS SCOLON SCOMMA SCURRENCY SPLUS SMINUS SSTAR SSLASH SPOWER SCONCAT SAND SOR SNEQV SEQV SNOT SEQ SLT SGT SLE SGE SNE SENDDO SWHILE SSLASHD SBYTE f2c/src/usignal.h000066400000000000000000000001741171647030000141330ustar00rootroot00000000000000#include #ifndef SIGHUP #define SIGHUP 1 /* hangup */ #endif #ifndef SIGQUIT #define SIGQUIT 3 /* quit */ #endif f2c/src/vax.c000066400000000000000000000302241171647030000132610ustar00rootroot00000000000000/**************************************************************** Copyright 1990, 1992-1994, 2001 by AT&T, Lucent Technologies and Bellcore. Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the above copyright notice appear in all copies and that both that the copyright notice and this permission notice and warranty disclaimer appear in supporting documentation, and that the names of AT&T, Bell Laboratories, Lucent or Bellcore or any of their entities not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. AT&T, Lucent and Bellcore disclaim all warranties with regard to this software, including all implied warranties of merchantability and fitness. In no event shall AT&T, Lucent or Bellcore be liable for any special, indirect or consequential damages or any damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortious action, arising out of or in connection with the use or performance of this software. ****************************************************************/ #include "defs.h" #include "pccdefs.h" #include "output.h" int regnum[] = { 11, 10, 9, 8, 7, 6 }; /* Put out a constant integer */ void #ifdef KR_headers prconi(fp, n) FILEP fp; ftnint n; #else prconi(FILEP fp, ftnint n) #endif { fprintf(fp, "\t%ld\n", n); } #ifndef NO_LONG_LONG void #ifdef KR_headers prconq(fp, n) FILEP fp; Llong n; #else prconq(FILEP fp, Llong n) #endif { fprintf(fp, "\t%lld\n", n); } #endif /* Put out a constant address */ void #ifdef KR_headers prcona(fp, a) FILEP fp; ftnint a; #else prcona(FILEP fp, ftnint a) #endif { fprintf(fp, "\tL%ld\n", a); } void #ifdef KR_headers prconr(fp, x, k) FILEP fp; Constp x; int k; #else prconr(FILEP fp, Constp x, int k) #endif { char *x0, *x1; char cdsbuf0[64], cdsbuf1[64]; if (k > 1) { if (x->vstg) { x0 = x->Const.cds[0]; x1 = x->Const.cds[1]; } else { x0 = cds(dtos(x->Const.cd[0]), cdsbuf0); x1 = cds(dtos(x->Const.cd[1]), cdsbuf1); } fprintf(fp, "\t%s %s\n", x0, x1); } else fprintf(fp, "\t%s\n", x->vstg ? x->Const.cds[0] : cds(dtos(x->Const.cd[0]), cdsbuf0)); } char * #ifdef KR_headers memname(stg, mem) int stg; long mem; #else memname(int stg, long mem) #endif { static char s[20]; switch(stg) { case STGCOMMON: case STGEXT: sprintf(s, "_%s", extsymtab[mem].cextname); break; case STGBSS: case STGINIT: sprintf(s, "v.%ld", mem); break; case STGCONST: sprintf(s, "L%ld", mem); break; case STGEQUIV: sprintf(s, "q.%ld", mem+eqvstart); break; default: badstg("memname", stg); } return(s); } extern void addrlit Argdcl((Addrp)); /* make_int_expr -- takes an arbitrary expression, and replaces all occurrences of arguments with indirection */ expptr #ifdef KR_headers make_int_expr(e) expptr e; #else make_int_expr(expptr e) #endif { chainp listp; Addrp ap; expptr e1; if (e != ENULL) switch (e -> tag) { case TADDR: if (e->addrblock.isarray) { if (e1 = e->addrblock.memoffset) e->addrblock.memoffset = make_int_expr(e1); } else if (e->addrblock.vstg == STGARG || e->addrblock.vstg == STGCOMMON && e->addrblock.uname_tag == UNAM_NAME && e->addrblock.user.name->vcommequiv) e = mkexpr(OPWHATSIN, e, ENULL); break; case TEXPR: e -> exprblock.leftp = make_int_expr (e -> exprblock.leftp); e -> exprblock.rightp = make_int_expr (e -> exprblock.rightp); break; case TLIST: for(listp = e->listblock.listp; listp; listp = listp->nextp) if ((ap = (Addrp)listp->datap) && ap->tag == TADDR && ap->uname_tag == UNAM_CONST) addrlit(ap); break; default: break; } /* switch */ return e; } /* make_int_expr */ /* prune_left_conv -- used in prolog() to strip type cast away from left-hand side of parameter adjustments. This is necessary to avoid error messages from cktype() */ expptr #ifdef KR_headers prune_left_conv(e) expptr e; #else prune_left_conv(expptr e) #endif { struct Exprblock *leftp; if (e && e -> tag == TEXPR && e -> exprblock.leftp && e -> exprblock.leftp -> tag == TEXPR) { leftp = &(e -> exprblock.leftp -> exprblock); if (leftp -> opcode == OPCONV) { e -> exprblock.leftp = leftp -> leftp; free ((charptr) leftp); } } return e; } /* prune_left_conv */ static int wrote_comment; static FILE *comment_file; static void write_comment(Void) { if (!wrote_comment) { wrote_comment = 1; nice_printf (comment_file, "/* Parameter adjustments */\n"); } } static int * count_args(Void) { register int *ac; register chainp cp; register struct Entrypoint *ep; register Namep q; ac = (int *)ckalloc(nallargs*sizeof(int)); for(ep = entries; ep; ep = ep->entnextp) for(cp = ep->arglist; cp; cp = cp->nextp) if (q = (Namep)cp->datap) ac[q->argno]++; return ac; } static int nu, *refs, *used; static void awalk Argdcl((expptr)); static void #ifdef KR_headers aawalk(P) struct Primblock *P; #else aawalk(struct Primblock *P) #endif { chainp p; expptr q; if (P->argsp) for(p = P->argsp->listp; p; p = p->nextp) { q = (expptr)p->datap; if (q->tag != TCONST) awalk(q); } if (P->namep->vtype == TYCHAR) { if (q = P->fcharp) awalk(q); if (q = P->lcharp) awalk(q); } } static void #ifdef KR_headers afwalk(P) struct Primblock *P; #else afwalk(struct Primblock *P) #endif { chainp p; expptr q; Namep np; for(p = P->argsp->listp; p; p = p->nextp) { q = (expptr)p->datap; switch(q->tag) { case TPRIM: np = q->primblock.namep; if (np->vknownarg) if (!refs[np->argno]++) used[nu++] = np->argno; if (q->primblock.argsp == 0) { if (q->primblock.namep->vclass == CLPROC && q->primblock.namep->vprocclass != PTHISPROC || q->primblock.namep->vdim != NULL) continue; } default: awalk(q); /* no break */ case TCONST: continue; } } } static void #ifdef KR_headers awalk(e) expptr e; #else awalk(expptr e) #endif { Namep np; top: if (!e) return; switch(e->tag) { default: badtag("awalk", e->tag); case TCONST: case TERROR: case TLIST: return; case TADDR: if (e->addrblock.uname_tag == UNAM_NAME) { np = e->addrblock.user.name; if (np->vknownarg && !refs[np->argno]++) used[nu++] = np->argno; } e = e->addrblock.memoffset; goto top; case TPRIM: np = e->primblock.namep; if (np->vknownarg && !refs[np->argno]++) used[nu++] = np->argno; if (e->primblock.argsp && np->vclass != CLVAR) afwalk((struct Primblock *)e); else aawalk((struct Primblock *)e); return; case TEXPR: awalk(e->exprblock.rightp); e = e->exprblock.leftp; goto top; } } static chainp #ifdef KR_headers argsort(p0) chainp p0; #else argsort(chainp p0) #endif { Namep *args, q, *stack; int i, nargs, nout, nst; chainp *d, *da, p, rv, *rvp; struct Dimblock *dp; if (!p0) return p0; for(nargs = 0, p = p0; p; p = p->nextp) nargs++; args = (Namep *)ckalloc(i = nargs*(sizeof(Namep) + 2*sizeof(chainp) + 2*sizeof(int))); memset((char *)args, 0, i); stack = args + nargs; d = (chainp *)(stack + nargs); refs = (int *)(d + nargs); used = refs + nargs; for(p = p0; p; p = p->nextp) { q = (Namep) p->datap; args[q->argno] = q; } for(p = p0; p; p = p->nextp) { q = (Namep) p->datap; if (!(dp = q->vdim)) continue; i = dp->ndim; while(--i >= 0) awalk(dp->dims[i].dimexpr); awalk(dp->basexpr); while(nu > 0) { refs[i = used[--nu]] = 0; d[i] = mkchain((char *)q, d[i]); } } for(i = nst = 0; i < nargs; i++) for(p = d[i]; p; p = p->nextp) refs[((Namep)p->datap)->argno]++; while(--i >= 0) if (!refs[i]) stack[nst++] = args[i]; if (nst == nargs) { rv = p0; goto done; } nout = 0; rv = 0; rvp = &rv; while(nst > 0) { nout++; q = stack[--nst]; *rvp = p = mkchain((char *)q, CHNULL); rvp = &p->nextp; da = d + q->argno; for(p = *da; p; p = p->nextp) if (!--refs[(q = (Namep)p->datap)->argno]) stack[nst++] = q; frchain(da); } if (nout < nargs) for(i = 0; i < nargs; i++) if (refs[i]) { q = args[i]; errstr("Can't adjust %.38s correctly\n\ due to dependencies among arguments.", q->fvarname); *rvp = p = mkchain((char *)q, CHNULL); rvp = &p->nextp; frchain(d+i); } done: free((char *)args); return rv; } void #ifdef KR_headers prolog(outfile, p) FILE *outfile; register chainp p; #else prolog(FILE *outfile, register chainp p) #endif { int addif, addif0, i, nd; ftnint size; int *ac; register Namep q; register struct Dimblock *dp; chainp p0, p1; if(procclass == CLBLOCK) return; p0 = p; p1 = p = argsort(p); wrote_comment = 0; comment_file = outfile; ac = 0; /* Compute the base addresses and offsets for the array parameters, and assign these values to local variables */ addif = addif0 = nentry > 1; for(; p ; p = p->nextp) { q = (Namep) p->datap; if(dp = q->vdim) /* if this param is an array ... */ { expptr Q, expr; /* See whether to protect the following with an if. */ /* This only happens when there are multiple entries. */ nd = dp->ndim - 1; if (addif0) { if (!ac) ac = count_args(); if (ac[q->argno] == nentry) addif = 0; else if (dp->basexpr || dp->baseoffset->constblock.Const.ci) addif = 1; else for(addif = i = 0; i <= nd; i++) if (dp->dims[i].dimexpr && (i < nd || !q->vlastdim)) { addif = 1; break; } if (addif) { write_comment(); nice_printf(outfile, "if (%s) {\n", /*}*/ q->cvarname); next_tab(outfile); } } for(i = 0 ; i <= nd; ++i) /* Store the variable length of each dimension (which is fixed upon runtime procedure entry) into a local variable */ if ((Q = dp->dims[i].dimexpr) && (i < nd || !q->vlastdim)) { expr = (expptr)cpexpr(Q); write_comment(); out_and_free_statement (outfile, mkexpr (OPASSIGN, fixtype(cpexpr(dp->dims[i].dimsize)), expr)); } /* if dp -> dims[i].dimexpr */ /* size will equal the size of a single element, or -1 if the type is variable length character type */ size = typesize[ q->vtype ]; if(q->vtype == TYCHAR) if( ISICON(q->vleng) ) size *= q->vleng->constblock.Const.ci; else size = -1; /* Fudge the argument pointers for arrays so subscripts * are 0-based. Not done if array bounds are being checked. */ if(dp->basexpr) { /* Compute the base offset for this procedure */ write_comment(); out_and_free_statement (outfile, mkexpr (OPASSIGN, cpexpr(fixtype(dp->baseoffset)), cpexpr(fixtype(dp->basexpr)))); } /* if dp -> basexpr */ if(! checksubs) { if(dp->basexpr) { expptr tp; /* If the base of this array has a variable adjustment ... */ tp = (expptr) cpexpr (dp -> baseoffset); if(size < 0 || q -> vtype == TYCHAR) tp = mkexpr (OPSTAR, tp, cpexpr (q -> vleng)); write_comment(); tp = mkexpr (OPMINUSEQ, mkconv (TYADDR, (expptr)p->datap), mkconv(TYINT, fixtype (fixtype (tp)))); /* Avoid type clash by removing the type conversion */ tp = prune_left_conv (tp); out_and_free_statement (outfile, tp); } else if(dp->baseoffset->constblock.Const.ci != 0) { /* if the base of this array has a nonzero constant adjustment ... */ expptr tp; write_comment(); if(size > 0 && q -> vtype != TYCHAR) { tp = prune_left_conv (mkexpr (OPMINUSEQ, mkconv (TYADDR, (expptr)p->datap), mkconv (TYINT, fixtype (cpexpr (dp->baseoffset))))); out_and_free_statement (outfile, tp); } else { tp = prune_left_conv (mkexpr (OPMINUSEQ, mkconv (TYADDR, (expptr)p->datap), mkconv (TYINT, fixtype (mkexpr (OPSTAR, cpexpr (dp -> baseoffset), cpexpr (q -> vleng)))))); out_and_free_statement (outfile, tp); } /* else */ } /* if dp -> baseoffset -> const */ } /* if !checksubs */ if (addif) { nice_printf(outfile, /*{*/ "}\n"); prev_tab(outfile); } } } if (wrote_comment) nice_printf (outfile, "\n/* Function Body */\n"); if (ac) free((char *)ac); if (p0 != p1) frchain(&p1); } /* prolog */ f2c/src/version.c000066400000000000000000000001531171647030000141460ustar00rootroot00000000000000char F2C_version[] = "20100827"; char xxxvers[] = "\n@(#) FORTRAN 77 to C Translator, VERSION 20100827\n"; f2c/src/xsum.c000066400000000000000000000147751171647030000134740ustar00rootroot00000000000000/**************************************************************** Copyright 1990, 1993, 1994, 2000 by AT&T, Lucent Technologies and Bellcore. Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the above copyright notice appear in all copies and that both that the copyright notice and this permission notice and warranty disclaimer appear in supporting documentation, and that the names of AT&T, Bell Laboratories, Lucent or Bellcore or any of their entities not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. AT&T, Lucent and Bellcore disclaim all warranties with regard to this software, including all implied warranties of merchantability and fitness. In no event shall AT&T or Bellcore be liable for any special, indirect or consequential damages or any damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortious action, arising out of or in connection with the use or performance of this software. ****************************************************************/ #undef _POSIX_SOURCE #define _POSIX_SOURCE #include "stdio.h" #ifndef KR_headers #include "stdlib.h" #include "sys/types.h" #ifndef MSDOS #include "unistd.h" /* for read, close */ #endif #include "fcntl.h" /* for declaration of open, O_RDONLY */ #endif #ifdef MSDOS #include "io.h" #endif #ifndef O_RDONLY #define O_RDONLY 0 #endif #ifndef O_BINARY #define O_BINARY O_RDONLY #endif char *progname; static int ignore_cr; void #ifdef KR_headers usage(rc) #else usage(int rc) #endif { fprintf(stderr, "usage: %s [-r] [file [file...]]\n\ option -r ignores carriage return characters\n", progname); exit(rc); } typedef unsigned char Uchar; long #ifdef KR_headers sum32(sum, x, n) register long sum; register Uchar *x; int n; #else sum32(register long sum, register Uchar *x, int n) #endif { register Uchar *xe; static long crc_table[256] = { 0, 151466134, 302932268, 453595578, -9583591, -160762737, -312236747, -463170141, -19167182, -136529756, -321525474, -439166584, 28724267, 145849533, 330837255, 448732561, -38334364, -189783822, -273059512, -423738914, 47895677, 199091435, 282375505, 433292743, 57448534, 174827712, 291699066, 409324012, -67019697, -184128295, -300991133, -418902539, -76668728, -227995554, -379567644, -530091662, 67364049, 218420295, 369985021, 520795499, 95791354, 213031020, 398182870, 515701056, -86479645, -203465611, -388624945, -506380967, 114897068, 266207290, 349655424, 500195606, -105581387, -256654301, -340093543, -490887921, -134039394, -251295736, -368256590, -485758684, 124746887, 241716241, 358686123, 476458301, -153337456, -2395898, -455991108, -304803798, 162629001, 11973919, 465560741, 314102835, 134728098, 16841012, 436840590, 319723544, -144044613, -26395347, -446403433, -329032703, 191582708, 40657250, 426062040, 274858062, -200894995, -50223749, -435620671, -284179369, -172959290, -55056048, -406931222, -289830788, 182263263, 64630089, 416513267, 299125861, 229794136, 78991822, 532414580, 381366498, -220224191, -69691945, -523123603, -371788549, -211162774, -93398532, -513308602, -396314416, 201600371, 84090341, 503991391, 386759881, -268078788, -117292630, -502591472, -351526778, 258520357, 107972019, 493278217, 341959839, 249493774, 131713432, 483432482, 366454964, -239911657, -122417791, -474129349, -356881235, -306674912, -457198666, -4791796, -156118374, 315967289, 466778031, 14362133, 165418627, 325258002, 442776452, 23947838, 141187752, -334573813, -452329571, -33509849, -150495567, 269456196, 419996626, 33682024, 184992510, -278767779, -429561909, -43239823, -194312473, -288089226, -405591072, -52790694, -170046772, 297394031, 415166457, 62373443, 179343061, 383165416, 533828478, 81314500, 232780370, -373594127, -524527769, -72022307, -223201717, -401789990, -519431348, -100447498, -217810336, 392228803, 510123861, 91131631, 208256633, -345918580, -496598246, -110112096, -261561802, 336361365, 487278339, 100800185, 251995695, 364526526, 482151208, 129260178, 246639108, -354943065, -472854735, -119955829, -237064675, 459588272, 308539942, 157983644, 7181066, -469170519, -317835713, -167286907, -16754925, -440448382, -323454444, -139383890, -21619912, 450006683, 332774925, 148697015, 31186721, -422325548, -271261118, -186797064, -36011154, 431888077, 280569435, 196114401, 45565815, 403200742, 286222960, 168180682, 50400092, -412770561, -295522711, -177471533, -59977915, -536157576, -384970002, -234585260, -83643454, 526853729, 375396087, 225003341, 74348507, 517040714, 399923932, 215944038, 98057200, -507728301, -390357307, -206385281, -88735767, 498987548, 347783818, 263426864, 112501670, -489671163, -338229613, -253864151, -103192641, -479823314, -362722632, -244835582, -126932076, 470531639, 353144481, 235265819, 117632909 }; xe = x + n; while(x < xe) sum = crc_table[(sum ^ *x++) & 0xff] ^ (sum >> 8 & 0xffffff); return sum; } int #ifdef KR_headers cr_purge(buf, n) Uchar *buf; int n; #else cr_purge(Uchar *buf, int n) #endif { register Uchar *b, *b1, *be; b = buf; be = b + n; while(b < be) if (*b++ == '\r') { b1 = b - 1; while(b < be) if ((*b1 = *b++) != '\r') b1++; return b1 - buf; } return n; } static Uchar Buf[16*1024]; void #ifdef KR_headers process(s, x) char *s; int x; #else process(char *s, int x) #endif { register int n; long fsize, sum; sum = 0; fsize = 0; while((n = read(x, (char *)Buf, sizeof(Buf))) > 0) { if (ignore_cr) n = cr_purge(Buf, n); fsize += n; sum = sum32(sum, Buf, n); } sum &= 0xffffffff; if (n==0) printf("%s\t%lx\t%ld\n", s, sum & 0xffffffff, fsize); else { perror(s); } close(x); } int #ifdef KR_headers main(argc, argv) char **argv; #else main(int argc, char **argv) #endif { int x; char *s; static int rc; progname = *argv; argc = argc; /* turn off "not used" warning */ s = *++argv; if (s && *s == '-') { switch(s[1]) { case '?': usage(0); case 'r': ignore_cr = 1; case '-': break; default: fprintf(stderr, "invalid option %s\n", s); usage(1); } s = *++argv; } if (s) do { x = open(s, O_RDONLY|O_BINARY); if (x < 0) { fprintf(stderr, "%s: can't open %s\n", progname, s); rc |= 1; } else process(s, x); } while(s = *++argv); else { process("/dev/stdin", fileno(stdin)); } return rc; } f2c/src/xsum0.out000066400000000000000000000024501171647030000141240ustar00rootroot00000000000000Notice 76f23b4 1212 README f11dd32a 7973 cds.c 147aded1 4221 data.c e53078ae 10697 defines.h fd9fa7c5 8720 defs.h e48cebb 34523 equiv.c fdeff25 9340 error.c ef1dd812 5015 exec.c e169a868 21191 expr.c 6bfe005 72276 f2c.1 b0441b2 7532 f2c.1t bf1f87 7574 f2c.h e770b7d8 4688 format.c f97004df 59746 format.h b396862 458 formatdata.c 11a95834 28870 ftypes.h 9a0b38c 1616 gram.c 3794117 64242 gram.dcl e38579ff 8463 gram.exec e20ca496 3033 gram.expr eca86241 3193 gram.head e6bbfeab 7362 gram.io 101f7521 3350 init.c fe1abab5 11833 intr.c 1ebf37ee 25016 io.c 1739e50 30664 iob.h ece45655 548 lex.c 1b0d5df9 34746 machdefs.h 4950e5b 659 main.c e2fad403 20921 makefile.u e0dd1cab 3710 makefile.vc eb8aae7c 2685 malloc.c 40d2ad0 3975 mem.c e54b227d 5437 memset.c 12a1e1aa 2121 misc.c 8d99c9 22945 names.c fa887031 21553 names.h 110806d6 569 niceprintf.c 141fb644 10950 niceprintf.h c31f08c 412 output.c ee3a3cc5 43483 output.h fa6797d9 2103 p1defs.h 1b02743 5741 p1output.c 6fd9954 14376 parse.h 18d34e6b 1119 parse_args.c eb2fd4ea 14145 pccdefs.h 1b4fbbee 1195 pread.c 1fbd30ab 17831 proc.c 649db52 39174 put.c af0be95 10345 putpcc.c 7669b2f 46093 sysdep.c fe71c52a 15893 sysdep.h e7826434 2755 sysdeptest.c c92b2d4 408 tokens 188b7c5d 733 usignal.h 1c4ce909 124 vax.c 8b21b83 12436 version.c f48eeae3 107 xsum.c e05654a7 6653