diff options
| author | Joseph Hunkeler <jhunkeler@gmail.com> | 2015-07-08 20:46:52 -0400 |
|---|---|---|
| committer | Joseph Hunkeler <jhunkeler@gmail.com> | 2015-07-08 20:46:52 -0400 |
| commit | fa080de7afc95aa1c19a6e6fc0e0708ced2eadc4 (patch) | |
| tree | bdda434976bc09c864f2e4fa6f16ba1952b1e555 /unix/f2c | |
| download | iraf-linux-fa080de7afc95aa1c19a6e6fc0e0708ced2eadc4.tar.gz | |
Initial commit
Diffstat (limited to 'unix/f2c')
282 files changed, 73038 insertions, 0 deletions
diff --git a/unix/f2c/README b/unix/f2c/README new file mode 100644 index 00000000..1416f521 --- /dev/null +++ b/unix/f2c/README @@ -0,0 +1,186 @@ +To 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 <strings.h> +you may need to add " -Dstrchr=index" to the "CFLAGS =" assignment +in the makefile, and you may need to add " memset.o" to the "OBJECTS =" +assignment in the makefile -- see the comments in memset.c . + +For non-UNIX systems, you may need to change some things in sysdep.c, +such as the choice of intermediate file names. + +On some systems, you may need to modify parts of sysdep.h (which is +included by defs.h). In particular, for Sun 4.1 systems and perhaps +some others, you need to comment out the typedef of size_t. For some +systems (e.g., IRIX 4.0.1 and AIX) it is better to add +#define ANSI_Libraries +to the beginning of sysdep.h (or to supply -DANSI_Libraries in the +makefile). + +Alas, some systems #define __STDC__ but do not provide a true standard +(ANSI or ISO) C environment, e.g. do not provide stdlib.h . If yours +is such a system, then (a) you should complain loudly to your vendor +about __STDC__ being erroneously defined, and (b) you should insert +#undef __STDC__ +at the beginning of sysdep.h . You may need to make other adjustments. + +For some non-ANSI versions of stdio, you must change the values given +to binread and binwrite in sysdep.c from "rb" and "wb" to "r" and "w". +You may need to make this change if you run f2c and get an error +message of the form + Compiler error ... cannot open intermediate file ... + +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. diff --git a/unix/f2c/changes b/unix/f2c/changes new file mode 100644 index 00000000..f8d24179 --- /dev/null +++ b/unix/f2c/changes @@ -0,0 +1,3482 @@ +31 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 <string.h> in mem.c +changed to #include "string.h" so BSD people can create a local +string.h that simply says #include <strings.h> . + +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 <koon@gentoo.org> +(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 <unistd.h>). + +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. diff --git a/unix/f2c/f2c.1 b/unix/f2c/f2c.1 new file mode 100644 index 00000000..3bdbc8b8 --- /dev/null +++ b/unix/f2c/f2c.1 @@ -0,0 +1,222 @@ + + 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) + diff --git a/unix/f2c/f2c.1t b/unix/f2c/f2c.1t new file mode 100644 index 00000000..d73d3347 --- /dev/null +++ b/unix/f2c/f2c.1t @@ -0,0 +1,391 @@ +. \" 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 . diff --git a/unix/f2c/f2c.h b/unix/f2c/f2c.h new file mode 100644 index 00000000..b94ee7c8 --- /dev/null +++ b/unix/f2c/f2c.h @@ -0,0 +1,223 @@ +/* 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 diff --git a/unix/f2c/f2c.pdf b/unix/f2c/f2c.pdf Binary files differnew file mode 100644 index 00000000..757adec5 --- /dev/null +++ b/unix/f2c/f2c.pdf diff --git a/unix/f2c/f2c.ps b/unix/f2c/f2c.ps new file mode 100644 index 00000000..c1446802 --- /dev/null +++ b/unix/f2c/f2c.ps @@ -0,0 +1,5342 @@ +%!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 <f2c.h>)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 diff --git a/unix/f2c/fc b/unix/f2c/fc new file mode 100644 index 00000000..1f71e598 --- /dev/null +++ b/unix/f2c/fc @@ -0,0 +1,366 @@ +#! /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 diff --git a/unix/f2c/getopt.c b/unix/f2c/getopt.c new file mode 100644 index 00000000..6c97b59d --- /dev/null +++ b/unix/f2c/getopt.c @@ -0,0 +1,102 @@ +/**************************************************************** +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 <stdio.h> + +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; + } diff --git a/unix/f2c/index b/unix/f2c/index new file mode 100644 index 00000000..b207d367 --- /dev/null +++ b/unix/f2c/index @@ -0,0 +1,45 @@ +file 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 + diff --git a/unix/f2c/index.html b/unix/f2c/index.html new file mode 100644 index 00000000..01a7571d --- /dev/null +++ b/unix/f2c/index.html @@ -0,0 +1,57 @@ +<head> +<title>f2c</title> +<meta name="waisindex" value="nse"> +</head> +<h1>f2c</h1> +<p> +Click <A HREF="http://www.netlib.org/master_counts2.html#f2c">here</A> to see the number of accesses to this library. +<p><hr> +<pre> +file <a href="changes">changes</a> + +file <a href="f2c.1">f2c.1</a> +lang man page + +file <a href="f2c.1t">f2c.1t</a> +lang troff -man source for man page + +file <a href="f2c.h">f2c.h</a> + +file <a href="f2c.ps">f2c.ps</a> +lang Postscript + +file <a href="f2c.pdf">f2c.pdf</a> + +file <a href="fc">fc</a> +lang Bourne shell script + +file <a href="getopt.c">getopt.c</a> +for Source for "getopt" command used by fc (for systems lacking getopt) + +file <a href="index">index</a> + +file <a href="libf77">libf77</a> +lang C (bundle of source) + +file <a href="libi77">libi77</a> +lang C (bundle of source) + +file <a href="libf2c.zip">libf2c.zip</a> +for combined libf77, libi77, with several makefile variants +size 102 KB +# DO NOT REQUEST BY EMAIL, USE FTP! + +lib <a href="msdos/">msdos</a> +for MS-DOS f2c binaries (ftp only) + +lib <a href="mswin/">mswin</a> +for Win32 f2c binaries (ftp only) + +lib <a href="src/">src</a> +for f2c source + +file <a href="README">README</a> + +</pre> +</body> +</html> diff --git a/unix/f2c/libf2c/1 b/unix/f2c/libf2c/1 new file mode 100644 index 00000000..f9db547c --- /dev/null +++ b/unix/f2c/libf2c/1 @@ -0,0 +1 @@ +make: *** No rule to make target `_spool'. Stop. diff --git a/unix/f2c/libf2c/Notice b/unix/f2c/libf2c/Notice new file mode 100644 index 00000000..261b719b --- /dev/null +++ b/unix/f2c/libf2c/Notice @@ -0,0 +1,23 @@ +/**************************************************************** +Copyright 1990 - 1997 by AT&T, Lucent Technologies and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T, Bell Laboratories, +Lucent or Bellcore or any of their entities not be used in +advertising or publicity pertaining to distribution of the +software without specific, written prior permission. + +AT&T, Lucent and Bellcore disclaim all warranties with regard to +this software, including all implied warranties of +merchantability and fitness. In no event shall AT&T, Lucent or +Bellcore be liable for any special, indirect or consequential +damages or any damages whatsoever resulting from loss of use, +data or profits, whether in an action of contract, negligence or +other tortious action, arising out of or in connection with the +use or performance of this software. +****************************************************************/ + diff --git a/unix/f2c/libf2c/README b/unix/f2c/libf2c/README new file mode 100644 index 00000000..c163b877 --- /dev/null +++ b/unix/f2c/libf2c/README @@ -0,0 +1,374 @@ +As shipped, "makefile" is a copy of "makefile.u", a Unix makefile. +Variants for other systems have names of the form makefile.* and +have initial comments saying how to invoke them. You may wish to +copy one of the other makefile.* files to makefile. + +If you use a C++ compiler, first say + + make hadd + +to create a suitable f2c.h from f2c.h0 and f2ch.add. Otherwise, + + make f2c.h + +will just copy f2c.h0 to f2c.h . + +If your compiler does not recognize ANSI C headers, +compile with KR_headers defined: either add -DKR_headers +to the definition of CFLAGS in the makefile, or insert + +#define KR_headers + +at the top of f2c.h . + +If your system lacks onexit() and you are not using an ANSI C +compiler, then you should compile main.c with NO_ONEXIT defined. +See the comments about onexit in makefile.u. + +If your system has a double drem() function such that drem(a,b) +is the IEEE remainder function (with double a, b), then you may +wish to compile r_mod.c and d_mod.c with IEEE_drem defined. + +To check for transmission errors, issue the command + make check +or + make -f makefile.u check + +This assumes you have the xsum program whose source, xsum.c, +is distributed as part of "all from f2c/src", and that it +is installed somewhere in your search path. If you do not +have xsum, you can obtain xsum.c by sending the following E-mail +message to netlib@netlib.org + send xsum.c from f2c/src + +For convenience, the f2c.h0 in this directory is a copy of netlib's +"f2c.h from f2c". It is best to install f2c.h in a standard place, +so "include f2c.h" will work in any directory without further ado. +Beware that the makefiles do not cause recompilation when f2c.h is +changed. + +On machines, such as those using a DEC Alpha processor, on which +sizeof(short) == 2, sizeof(int) == sizeof(float) == 4, and +sizeof(long) == sizeof(double) == 8, it suffices to modify f2c.h by +removing the first occurrence of "long " on each line containing +"long ". On Unix systems, you can do this by issuing the commands + mv f2c.h f2c.h0 + sed 's/long int /int /' f2c.h0 >f2c.h +On such machines, one can enable INTEGER*8 by uncommenting the typedefs +of longint and ulongint in f2c.h and adjusting them, so they read + typedef long longint; + typedef unsigned long ulongint; +and by compiling libf2c with -DAllow_TYQUAD, as discussed below. + + +Most of the routines in libf2c are support routines for Fortran +intrinsic functions or for operations that f2c chooses not +to do "in line". There are a few exceptions, summarized below -- +functions and subroutines that appear to your program as ordinary +external Fortran routines. + +If you use the REAL valued functions listed below (ERF, ERFC, +DTIME, and ETIME) with "f2c -R", then you need to compile the +corresponding source files with -DREAL=float. To do this, it is +perhaps simplest to add "-DREAL=float" to CFLAGS in the makefile. + +1. CALL ABORT prints a message and causes a core dump. + +2. ERF(r) and DERF(d) and the REAL and DOUBLE PRECISION + error functions (with x REAL and d DOUBLE PRECISION); + DERF must be declared DOUBLE PRECISION in your program. + Both ERF and DERF assume your C library provides the + underlying erf() function (which not all systems do). + +3. ERFC(r) and DERFC(d) are the complementary error functions: + ERFC(r) = 1 - ERF(r) and DERFC(d) = 1.d0 - DERFC(d) + (except that their results may be more accurate than + explicitly evaluating the above formulae would give). + Again, ERFC and r are REAL, and DERFC and d are DOUBLE + PRECISION (and must be declared as such in your program), + and ERFC and DERFC rely on your system's erfc(). + +4. CALL GETARG(n,s), where n is an INTEGER and s is a CHARACTER + variable, sets s to the n-th command-line argument (or to + all blanks if there are fewer than n command-line arguments); + CALL GETARG(0,s) sets s to the name of the program (on systems + that support this feature). See IARGC below. + +5. CALL GETENV(name, value), where name and value are of type + CHARACTER, sets value to the environment value, $name, of + name (or to blanks if $name has not been set). + +6. NARGS = IARGC() sets NARGS to the number of command-line + arguments (an INTEGER value). + +7. CALL SIGNAL(n,func), where n is an INTEGER and func is an + EXTERNAL procedure, arranges for func to be invoked when n + occurs (on systems where this makes sense). + +If your compiler complains about the signal calls in main.c, s_paus.c, +and signal_.c, you may need to adjust signal1.h suitably. See the +comments in signal1.h. + +8. ETIME(ARR) and DTIME(ARR) are REAL functions that return + execution times. ARR is declared REAL ARR(2). The elapsed + user and system CPU times are stored in ARR(1) and ARR(2), + respectively. ETIME returns the total elapsed CPU time, + i.e., ARR(1) + ARR(2). DTIME returns total elapsed CPU + time since the previous call on DTIME. + +9. CALL SYSTEM(cmd), where cmd is of type CHARACTER, passes + cmd to the system's command processor (on systems where + this can be done). + +10. CALL FLUSH flushes all buffers. + +11. FTELL(i) is an INTEGER function that returns the current + offset of Fortran unit i (or -1 if unit i is not open). + +12. CALL FSEEK(i, offset, whence, *errlab) attemps to move + Fortran unit i to the specified offset: absolute offset + if whence = 0; relative to the current offset if whence = 1; + relative to the end of the file if whence = 2. It branches + to label errlab if unit i is not open or if the call + otherwise fails. + +The routines whose objects are makefile.u's $(I77) are for I/O. +The following comments apply to them. + +If your system lacks /usr/include/local.h , +then you should create an appropriate local.h in +this directory. An appropriate local.h may simply +be empty, or it may #define VAX or #define CRAY +(or whatever else you must do to make fp.h work right). +Alternatively, edit fp.h to suite your machine. + +If your system lacks /usr/include/fcntl.h , then you +should simply create an empty fcntl.h in this directory. +If your compiler then complains about creat and open not +having a prototype, compile with OPEN_DECL defined. +On many systems, open and creat are declared in fcntl.h . + +If your system's sprintf does not work the way ANSI C +specifies -- specifically, if it does not return the +number of characters transmitted -- then insert the line + +#define USE_STRLEN + +at the end of fmt.h . This is necessary with +at least some versions of Sun software. +In particular, if you get a warning about an improper +pointer/integer combination in compiling wref.c, then +you need to compile with -DUSE_STRLEN . + +If your system's fopen does not like the ANSI binary +reading and writing modes "rb" and "wb", then you should +compile open.c with NON_ANSI_RW_MODES #defined. + +If you get error messages about references to cf->_ptr +and cf->_base when compiling wrtfmt.c and wsfe.c or to +stderr->_flag when compiling err.c, then insert the line + +#define NON_UNIX_STDIO + +at the beginning of fio.h, and recompile everything (or +at least those modules that contain NON_UNIX_STDIO). + +Unformatted sequential records consist of a length of record +contents, the record contents themselves, and the length of +record contents again (for backspace). Prior to 17 Oct. 1991, +the length was of type int; now it is of type long, but you +can change it back to int by inserting + +#define UIOLEN_int + +at the beginning of fio.h. This affects only sue.c and uio.c . + +If you have a really ancient K&R C compiler that does not understand +void, add -Dvoid=int to the definition of CFLAGS in the makefile. + +On VAX, Cray, or Research Tenth-Edition Unix systems, you may +need to add -DVAX, -DCRAY, or -DV10 (respectively) to CFLAGS +to make fp.h work correctly. Alternatively, you may need to +edit fp.h to suit your machine. + +If your compiler complains about the signal calls in main.c, s_paus.c, +and signal_.c, you may need to adjust signal1.h suitably. See the +comments in signal1.h. + +You may need to supply the following non-ANSI routines: + + fstat(int fileds, struct stat *buf) is similar +to stat(char *name, struct stat *buf), except that +the first argument, fileds, is the file descriptor +returned by open rather than the name of the file. +fstat is used in the system-dependent routine +canseek (in the libf2c source file err.c), which +is supposed to return 1 if it's possible to issue +seeks on the file in question, 0 if it's not; you may +need to suitably modify err.c . On non-UNIX systems, +you can avoid references to fstat and stat by compiling +with NON_UNIX_STDIO defined; in that case, you may need +to supply access(char *Name,0), which is supposed to +return 0 if file Name exists, nonzero otherwise. + + char * mktemp(char *buf) is supposed to replace the +6 trailing X's in buf with a unique number and then +return buf. The idea is to get a unique name for +a temporary file. + +On non-UNIX systems, you may need to change a few other, +e.g.: the form of name computed by mktemp() in endfile.c and +open.c; the use of the open(), close(), and creat() system +calls in endfile.c, err.c, open.c; and the modes in calls on +fopen() and fdopen() (and perhaps the use of fdopen() itself +-- it's supposed to return a FILE* corresponding to a given +an integer file descriptor) in err.c and open.c (component ufmt +of struct unit is 1 for formatted I/O -- text mode on some systems +-- and 0 for unformatted I/O -- binary mode on some systems). +Compiling with -DNON_UNIX_STDIO omits all references to creat() +and almost all references to open() and close(), the exception +being in the function f__isdev() (in open.c). + +If you wish to use translated Fortran that has funny notions +of record length for direct unformatted I/O (i.e., that assumes +RECL= values in OPEN statements are not bytes but rather counts +of some other units -- e.g., 4-character words for VMS), then you +should insert an appropriate #define for url_Adjust at the +beginning of open.c . For VMS Fortran, for example, +#define url_Adjust(x) x *= 4 +would suffice. + +By default, Fortran I/O units 5, 6, and 0 are pre-connected to +stdin, stdout, and stderr, respectively. You can change this +behavior by changing f_init() in err.c to suit your needs. +Note that f2c assumes READ(*... means READ(5... and WRITE(*... +means WRITE(6... . Moreover, an OPEN(n,... statement that does +not specify a file name (and does not specify STATUS='SCRATCH') +assumes FILE='fort.n' . You can change this by editing open.c +and endfile.c suitably. + +Unless you adjust the "#define MXUNIT" line in fio.h, Fortran units +0, 1, ..., 99 are available, i.e., the highest allowed unit number +is MXUNIT - 1. + +Lines protected from compilation by #ifdef Allow_TYQUAD +are for a possible extension to 64-bit integers in which +integer = int = 32 bits and longint = long = 64 bits. + +The makefile does not attempt to compile pow_qq.c, qbitbits.c, +and qbitshft.c, which are meant for use with INTEGER*8. To use +INTEGER*8, you must modify f2c.h to declare longint and ulongint +appropriately; then add $(QINT) to the end of the makefile's +dependency list for libf2c.a (if makefile is a copy of makefile.u; +for the PC makefiles, add pow_qq.obj qbitbits.obj qbitshft.obj +to the library's dependency list and adjust libf2c.lbc or libf2c.sy +accordingly). Also add -DAllow_TYQUAD to the makefile's CFLAGS +assignment. To make longint and ulongint available, it may suffice +to add -DINTEGER_STAR_8 to the CFLAGS assignment. + +Following Fortran 90, s_cat.c and s_copy.c allow the target of a +(character string) assignment to be appear on its right-hand, at +the cost of some extra overhead for all run-time concatenations. +If you prefer the extra efficiency that comes with the Fortran 77 +requirement that the left-hand side of a character assignment not +be involved in the right-hand side, compile s_cat.c and s_copy.c +with -DNO_OVERWRITE . + +Extensions (Feb. 1993) to NAMELIST processing: + 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. (Sept. 1995) When looking for the &name that starts namelist +input, lines whose first non-blank character is something other +than &, $, or ? are treated as comment lines and ignored, unless +rsne.c is compiled with -DNo_Namelist_Comments. + +Nonstandard extension (Feb. 1993) to open: for 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. + +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 . + +If you want to be able to catch write failures (e.g., due to a +disk being full) with an ERR= specifier, compile dfe.c, due.c, +sfe.c, sue.c, and wsle.c with -DALWAYS_FLUSH. This will lead to +slower execution and more I/O, but should make ERR= work as +expected, provided fflush returns an error return when its +physical write fails. + +Carriage controls are meant to be interpreted by the UNIX col +program (or a similar program). Sometimes it's convenient to use +only ' ' as the carriage control character (normal single spacing). +If you compile lwrite.c and wsfe.c with -DOMIT_BLANK_CC, formatted +external output lines will have an initial ' ' quietly omitted, +making use of the col program unnecessary with output that only +has ' ' for carriage control. + +The Fortran 77 Standard leaves it up to the implementation whether +formatted writes of floating-point numbers of absolute value < 1 have +a zero before the decimal point. By default, libI77 omits such +superfluous zeros, but you can cause them to appear by compiling +lwrite.c, wref.c, and wrtfmt.c with -DWANT_LEAD_0 . + +If your (Unix) system lacks a ranlib command, you don't need it. +Either comment out the makefile's ranlib invocation, or install +a harmless "ranlib" command somewhere in your PATH, such as the +one-line shell script + + exit 0 + +or (on some systems) + + exec /usr/bin/ar lts $1 >/dev/null + +By default, the routines that implement complex and double complex +division, c_div.c and z_div.c, call sig_die to print an error message +and exit if they see a divisor of 0, as this is sometimes helpful for +debugging. On systems with IEEE arithmetic, compiling c_div.c and +z_div.c with -DIEEE_COMPLEX_DIVIDE causes them instead to set both +the real and imaginary parts of the result to +INFINITY if the +numerator is nonzero, or to NaN if it vanishes. + +Nowadays most Unix and Linux systems have function + int ftruncate(int fildes, off_t len); +defined in system header file unistd.h that adjusts the length of file +descriptor fildes to length len. Unless endfile.c is compiled with +-DNO_TRUNCATE, endfile.c #includes "unistd.h" and calls ftruncate() if +necessary to shorten files. If your system lacks ftruncate(), compile +endfile.c with -DNO_TRUNCATE to make endfile.c use the older and more +portable scheme of shortening a file by copying to a temporary file +and back again. + +The initializations for "f2c -trapuv" are done by _uninit_f2c(), +whose source is uninit.c, introduced June 2001. On IEEE-arithmetic +systems, _uninit_f2c should initialize floating-point variables to +signaling NaNs and, at its first invocation, should enable the +invalid operation exception. Alas, the rules for distinguishing +signaling from quiet NaNs were not specified in the IEEE P754 standard, +nor were the precise means of enabling and disabling IEEE-arithmetic +exceptions, and these details are thus system dependent. There are +#ifdef's in uninit.c that specify them for some popular systems. If +yours is not one of these systems, it may take some detective work to +discover the appropriate details for your system. Sometimes it helps +to look in the standard include directories for header files with +relevant-sounding names, such as ieeefp.h, nan.h, or trap.h, and +it may be simplest to run experiments to see what distinguishes a +signaling from a quiet NaN. (If x is initialized to a signaling +NaN and the invalid operation exception is masked off, as it should +be by default on IEEE-arithmetic systems, then computing, say, +y = x + 1 will yield a quiet NaN.) diff --git a/unix/f2c/libf2c/abort_.c b/unix/f2c/libf2c/abort_.c new file mode 100644 index 00000000..92c841a7 --- /dev/null +++ b/unix/f2c/libf2c/abort_.c @@ -0,0 +1,22 @@ +#include "stdio.h" +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +extern VOID sig_die(); + +int abort_() +#else +extern void sig_die(const char*,int); + +int abort_(void) +#endif +{ +sig_die("Fortran abort routine called", 1); +return 0; /* not reached */ +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/arith.h b/unix/f2c/libf2c/arith.h new file mode 100644 index 00000000..a199f927 --- /dev/null +++ b/unix/f2c/libf2c/arith.h @@ -0,0 +1,9 @@ +#define IEEE_8087 +#define Arith_Kind_ASL 1 +#define Long int +#define Intcast (int)(long) +#define Double_Align +#define X64_bit_pointers +#define NANCHECK +#define QNaN0 0x0 +#define QNaN1 0xfff80000 diff --git a/unix/f2c/libf2c/arithchk.c b/unix/f2c/libf2c/arithchk.c new file mode 100644 index 00000000..8e15722a --- /dev/null +++ b/unix/f2c/libf2c/arithchk.c @@ -0,0 +1,248 @@ +/**************************************************************** +Copyright (C) 1997, 1998, 2000 Lucent Technologies +All Rights Reserved + +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 name of Lucent or any of its 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 OR ANY OF ITS ENTITIES 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. +****************************************************************/ + +/* Try to deduce arith.h from arithmetic properties. */ + +#include <stdio.h> +#include <math.h> +#include <errno.h> + +#ifdef NO_FPINIT +#define fpinit_ASL() +#else +#ifndef KR_headers +extern +#ifdef __cplusplus + "C" +#endif + void fpinit_ASL(void); +#endif /*KR_headers*/ +#endif /*NO_FPINIT*/ + + static int dalign; + typedef struct +Akind { + char *name; + int kind; + } Akind; + + static Akind +IEEE_8087 = { "IEEE_8087", 1 }, +IEEE_MC68k = { "IEEE_MC68k", 2 }, +IBM = { "IBM", 3 }, +VAX = { "VAX", 4 }, +CRAY = { "CRAY", 5}; + + static double t_nan; + + static Akind * +Lcheck(void) +{ + union { + double d; + long L[2]; + } u; + struct { + double d; + long L; + } x[2]; + + if (sizeof(x) > 2*(sizeof(double) + sizeof(long))) + dalign = 1; + u.L[0] = u.L[1] = 0; + u.d = 1e13; + if (u.L[0] == 1117925532 && u.L[1] == -448790528) + return &IEEE_MC68k; + if (u.L[1] == 1117925532 && u.L[0] == -448790528) + return &IEEE_8087; + if (u.L[0] == -2065213935 && u.L[1] == 10752) + return &VAX; + if (u.L[0] == 1267827943 && u.L[1] == 704643072) + return &IBM; + return 0; + } + + static Akind * +icheck(void) +{ + union { + double d; + int L[2]; + } u; + struct { + double d; + int L; + } x[2]; + + if (sizeof(x) > 2*(sizeof(double) + sizeof(int))) + dalign = 1; + u.L[0] = u.L[1] = 0; + u.d = 1e13; + if (u.L[0] == 1117925532 && u.L[1] == -448790528) + return &IEEE_MC68k; + if (u.L[1] == 1117925532 && u.L[0] == -448790528) + return &IEEE_8087; + if (u.L[0] == -2065213935 && u.L[1] == 10752) + return &VAX; + if (u.L[0] == 1267827943 && u.L[1] == 704643072) + return &IBM; + return 0; + } + +char *emptyfmt = ""; /* avoid possible warning message with printf("") */ + + static Akind * +ccheck(void) +{ + union { + double d; + long L; + } u; + long Cray1; + + /* Cray1 = 4617762693716115456 -- without overflow on non-Crays */ + Cray1 = printf(emptyfmt) < 0 ? 0 : 4617762; + if (printf(emptyfmt, Cray1) >= 0) + Cray1 = 1000000*Cray1 + 693716; + if (printf(emptyfmt, Cray1) >= 0) + Cray1 = 1000000*Cray1 + 115456; + u.d = 1e13; + if (u.L == Cray1) + return &CRAY; + return 0; + } + + static int +fzcheck(void) +{ + double a, b; + int i; + + a = 1.; + b = .1; + for(i = 155;; b *= b, i >>= 1) { + if (i & 1) { + a *= b; + if (i == 1) + break; + } + } + b = a * a; + return b == 0.; + } + + static int +need_nancheck(void) +{ + double t; + + errno = 0; + t = log(t_nan); + if (errno == 0) + return 1; + errno = 0; + t = sqrt(t_nan); + return errno == 0; + } + + void +get_nanbits(unsigned int *b, int k) +{ + union { double d; unsigned int z[2]; } u, u1, u2; + + k = 2 - k; + u1.z[k] = u2.z[k] = 0x7ff00000; + u1.z[1-k] = u2.z[1-k] = 0; + u.d = u1.d - u2.d; /* Infinity - Infinity */ + b[0] = u.z[0]; + b[1] = u.z[1]; + } + + int +main(void) +{ + FILE *f; + Akind *a = 0; + int Ldef = 0; + unsigned int nanbits[2]; + + fpinit_ASL(); +#ifdef WRITE_ARITH_H /* for Symantec's buggy "make" */ + f = fopen("arith.h", "w"); + if (!f) { + printf("Cannot open arith.h\n"); + return 1; + } +#else + f = stdout; +#endif + + if (sizeof(double) == 2*sizeof(long)) + a = Lcheck(); + else if (sizeof(double) == 2*sizeof(int)) { + Ldef = 1; + a = icheck(); + } + else if (sizeof(double) == sizeof(long)) + a = ccheck(); + if (a) { + fprintf(f, "#define %s\n#define Arith_Kind_ASL %d\n", + a->name, a->kind); + if (Ldef) + fprintf(f, "#define Long int\n#define Intcast (int)(long)\n"); + if (dalign) + fprintf(f, "#define Double_Align\n"); + if (sizeof(char*) == 8) + fprintf(f, "#define X64_bit_pointers\n"); +#ifndef NO_LONG_LONG + if (sizeof(long long) > sizeof(long) + && sizeof(long long) == sizeof(void*)) + fprintf(f, "#define LONG_LONG_POINTERS\n"); + if (sizeof(long long) < 8) +#endif + fprintf(f, "#define NO_LONG_LONG\n"); + if (a->kind <= 2) { + if (fzcheck()) + fprintf(f, "#define Sudden_Underflow\n"); + t_nan = -a->kind; + if (need_nancheck()) + fprintf(f, "#define NANCHECK\n"); + if (sizeof(double) == 2*sizeof(unsigned int)) { + get_nanbits(nanbits, a->kind); + fprintf(f, "#define QNaN0 0x%x\n", nanbits[0]); + fprintf(f, "#define QNaN1 0x%x\n", nanbits[1]); + } + } + return 0; + } + fprintf(f, "/* Unknown arithmetic */\n"); + return 1; + } + +#ifdef __sun +#ifdef __i386 +/* kludge for Intel Solaris */ +void fpsetprec(int x) { } +#endif +#endif diff --git a/unix/f2c/libf2c/backspac.c b/unix/f2c/libf2c/backspac.c new file mode 100644 index 00000000..908a6189 --- /dev/null +++ b/unix/f2c/libf2c/backspac.c @@ -0,0 +1,76 @@ +#include "f2c.h" +#include "fio.h" +#ifdef __cplusplus +extern "C" { +#endif +#ifdef KR_headers +integer f_back(a) alist *a; +#else +integer f_back(alist *a) +#endif +{ unit *b; + OFF_T v, w, x, y, z; + uiolen n; + FILE *f; + + f__curunit = b = &f__units[a->aunit]; /* curunit for error messages */ + if(a->aunit >= MXUNIT || a->aunit < 0) + err(a->aerr,101,"backspace") + if(b->useek==0) err(a->aerr,106,"backspace") + if(b->ufd == NULL) { + fk_open(1, 1, a->aunit); + return(0); + } + if(b->uend==1) + { b->uend=0; + return(0); + } + if(b->uwrt) { + t_runc(a); + if (f__nowreading(b)) + err(a->aerr,errno,"backspace") + } + f = b->ufd; /* may have changed in t_runc() */ + if(b->url>0) + { + x=FTELL(f); + y = x % b->url; + if(y == 0) x--; + x /= b->url; + x *= b->url; + (void) FSEEK(f,x,SEEK_SET); + return(0); + } + + if(b->ufmt==0) + { FSEEK(f,-(OFF_T)sizeof(uiolen),SEEK_CUR); + fread((char *)&n,sizeof(uiolen),1,f); + FSEEK(f,-(OFF_T)n-2*sizeof(uiolen),SEEK_CUR); + return(0); + } + w = x = FTELL(f); + z = 0; + loop: + while(x) { + x -= x < 64 ? x : 64; + FSEEK(f,x,SEEK_SET); + for(y = x; y < w; y++) { + if (getc(f) != '\n') + continue; + v = FTELL(f); + if (v == w) { + if (z) + goto break2; + goto loop; + } + z = v; + } + err(a->aerr,(EOF),"backspace") + } + break2: + FSEEK(f, z, SEEK_SET); + return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/c_abs.c b/unix/f2c/libf2c/c_abs.c new file mode 100644 index 00000000..858f2c8b --- /dev/null +++ b/unix/f2c/libf2c/c_abs.c @@ -0,0 +1,20 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +extern double f__cabs(); + +double c_abs(z) complex *z; +#else +extern double f__cabs(double, double); + +double c_abs(complex *z) +#endif +{ +return( f__cabs( z->r, z->i ) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/c_cos.c b/unix/f2c/libf2c/c_cos.c new file mode 100644 index 00000000..29fe49e3 --- /dev/null +++ b/unix/f2c/libf2c/c_cos.c @@ -0,0 +1,23 @@ +#include "f2c.h" + +#ifdef KR_headers +extern double sin(), cos(), sinh(), cosh(); + +VOID c_cos(r, z) complex *r, *z; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif + +void c_cos(complex *r, complex *z) +#endif +{ + double zi = z->i, zr = z->r; + r->r = cos(zr) * cosh(zi); + r->i = - sin(zr) * sinh(zi); + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/c_div.c b/unix/f2c/libf2c/c_div.c new file mode 100644 index 00000000..9463a43d --- /dev/null +++ b/unix/f2c/libf2c/c_div.c @@ -0,0 +1,53 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +extern VOID sig_die(); +VOID c_div(c, a, b) +complex *a, *b, *c; +#else +extern void sig_die(const char*,int); +void c_div(complex *c, complex *a, complex *b) +#endif +{ + double ratio, den; + double abr, abi, cr; + + if( (abr = b->r) < 0.) + abr = - abr; + if( (abi = b->i) < 0.) + abi = - abi; + if( abr <= abi ) + { + if(abi == 0) { +#ifdef IEEE_COMPLEX_DIVIDE + float af, bf; + af = bf = abr; + if (a->i != 0 || a->r != 0) + af = 1.; + c->i = c->r = af / bf; + return; +#else + sig_die("complex division by zero", 1); +#endif + } + ratio = (double)b->r / b->i ; + den = b->i * (1 + ratio*ratio); + cr = (a->r*ratio + a->i) / den; + c->i = (a->i*ratio - a->r) / den; + } + + else + { + ratio = (double)b->i / b->r ; + den = b->r * (1 + ratio*ratio); + cr = (a->r + a->i*ratio) / den; + c->i = (a->i - a->r*ratio) / den; + } + c->r = cr; + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/c_exp.c b/unix/f2c/libf2c/c_exp.c new file mode 100644 index 00000000..f46508d3 --- /dev/null +++ b/unix/f2c/libf2c/c_exp.c @@ -0,0 +1,25 @@ +#include "f2c.h" + +#ifdef KR_headers +extern double exp(), cos(), sin(); + + VOID c_exp(r, z) complex *r, *z; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif + +void c_exp(complex *r, complex *z) +#endif +{ + double expx, zi = z->i; + + expx = exp(z->r); + r->r = expx * cos(zi); + r->i = expx * sin(zi); + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/c_log.c b/unix/f2c/libf2c/c_log.c new file mode 100644 index 00000000..a0ba3f0d --- /dev/null +++ b/unix/f2c/libf2c/c_log.c @@ -0,0 +1,23 @@ +#include "f2c.h" + +#ifdef KR_headers +extern double log(), f__cabs(), atan2(); +VOID c_log(r, z) complex *r, *z; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +extern double f__cabs(double, double); + +void c_log(complex *r, complex *z) +#endif +{ + double zi, zr; + r->i = atan2(zi = z->i, zr = z->r); + r->r = log( f__cabs(zr, zi) ); + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/c_sin.c b/unix/f2c/libf2c/c_sin.c new file mode 100644 index 00000000..c8bc30f2 --- /dev/null +++ b/unix/f2c/libf2c/c_sin.c @@ -0,0 +1,23 @@ +#include "f2c.h" + +#ifdef KR_headers +extern double sin(), cos(), sinh(), cosh(); + +VOID c_sin(r, z) complex *r, *z; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif + +void c_sin(complex *r, complex *z) +#endif +{ + double zi = z->i, zr = z->r; + r->r = sin(zr) * cosh(zi); + r->i = cos(zr) * sinh(zi); + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/c_sqrt.c b/unix/f2c/libf2c/c_sqrt.c new file mode 100644 index 00000000..1678c534 --- /dev/null +++ b/unix/f2c/libf2c/c_sqrt.c @@ -0,0 +1,41 @@ +#include "f2c.h" + +#ifdef KR_headers +extern double sqrt(), f__cabs(); + +VOID c_sqrt(r, z) complex *r, *z; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +extern double f__cabs(double, double); + +void c_sqrt(complex *r, complex *z) +#endif +{ + double mag, t; + double zi = z->i, zr = z->r; + + if( (mag = f__cabs(zr, zi)) == 0.) + r->r = r->i = 0.; + else if(zr > 0) + { + r->r = t = sqrt(0.5 * (mag + zr) ); + t = zi / t; + r->i = 0.5 * t; + } + else + { + t = sqrt(0.5 * (mag - zr) ); + if(zi < 0) + t = -t; + r->i = t; + t = zi / t; + r->r = 0.5 * t; + } + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/cabs.c b/unix/f2c/libf2c/cabs.c new file mode 100644 index 00000000..84750d50 --- /dev/null +++ b/unix/f2c/libf2c/cabs.c @@ -0,0 +1,33 @@ +#ifdef KR_headers +extern double sqrt(); +double f__cabs(real, imag) double real, imag; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double f__cabs(double real, double imag) +#endif +{ +double temp; + +if(real < 0) + real = -real; +if(imag < 0) + imag = -imag; +if(imag > real){ + temp = real; + real = imag; + imag = temp; +} +if((real+imag) == real) + return(real); + +temp = imag/real; +temp = real*sqrt(1.0 + temp*temp); /*overflow!!*/ +return(temp); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/close.c b/unix/f2c/libf2c/close.c new file mode 100644 index 00000000..e958c717 --- /dev/null +++ b/unix/f2c/libf2c/close.c @@ -0,0 +1,101 @@ +#include "f2c.h" +#include "fio.h" +#ifdef KR_headers +integer f_clos(a) cllist *a; +#else +#undef abs +#undef min +#undef max +#include "stdlib.h" +#ifdef NON_UNIX_STDIO +#ifndef unlink +#define unlink remove +#endif +#else +#ifdef MSDOS +#include "io.h" +#else +#ifdef __cplusplus +extern "C" int unlink(const char*); +#else +extern int unlink(const char*); +#endif +#endif +#endif + +#ifdef __cplusplus +extern "C" { +#endif + +integer f_clos(cllist *a) +#endif +{ unit *b; + + if(a->cunit >= MXUNIT) return(0); + b= &f__units[a->cunit]; + if(b->ufd==NULL) + goto done; + if (b->uscrtch == 1) + goto Delete; + if (!a->csta) + goto Keep; + switch(*a->csta) { + default: + Keep: + case 'k': + case 'K': + if(b->uwrt == 1) + t_runc((alist *)a); + if(b->ufnm) { + fclose(b->ufd); + free(b->ufnm); + } + break; + case 'd': + case 'D': + Delete: + fclose(b->ufd); + if(b->ufnm) { + unlink(b->ufnm); /*SYSDEP*/ + free(b->ufnm); + } + } + b->ufd=NULL; + done: + b->uend=0; + b->ufnm=NULL; + return(0); + } + void +#ifdef KR_headers +f_exit() +#else +f_exit(void) +#endif +{ int i; + static cllist xx; + if (!xx.cerr) { + xx.cerr=1; + xx.csta=NULL; + for(i=0;i<MXUNIT;i++) + { + xx.cunit=i; + (void) f_clos(&xx); + } + } +} + int +#ifdef KR_headers +flush_() +#else +flush_(void) +#endif +{ int i; + for(i=0;i<MXUNIT;i++) + if(f__units[i].ufd != NULL && f__units[i].uwrt) + fflush(f__units[i].ufd); +return 0; +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/comptry.bat b/unix/f2c/libf2c/comptry.bat new file mode 100644 index 00000000..0dc84531 --- /dev/null +++ b/unix/f2c/libf2c/comptry.bat @@ -0,0 +1,5 @@ +%1 %2 %3 %4 %5 %6 %7 %8 %9
+if errorlevel 1 goto nolonglong
+exit 0
+:nolonglong
+%1 -DNO_LONG_LONG %2 %3 %4 %5 %6 %7 %8 %9
diff --git a/unix/f2c/libf2c/ctype.c b/unix/f2c/libf2c/ctype.c new file mode 100644 index 00000000..96bdf1c3 --- /dev/null +++ b/unix/f2c/libf2c/ctype.c @@ -0,0 +1,2 @@ +#define My_ctype_DEF +#include "ctype.h" diff --git a/unix/f2c/libf2c/ctype.h b/unix/f2c/libf2c/ctype.h new file mode 100644 index 00000000..29156150 --- /dev/null +++ b/unix/f2c/libf2c/ctype.h @@ -0,0 +1,47 @@ +/* Custom ctype.h to overcome trouble with recent versions of Linux libc.a */ + +#ifdef NO_My_ctype +#include <ctype.h> +#else /*{*/ +#ifndef My_ctype_DEF +extern char My_ctype[]; +#else /*{*/ +char My_ctype[264] = { + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 2, 2, 2, 2, 2, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 2, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0}; +#endif /*}*/ + +#define isdigit(x) (My_ctype[(x)+8] & 1) +#define isspace(x) (My_ctype[(x)+8] & 2) +#endif diff --git a/unix/f2c/libf2c/d_abs.c b/unix/f2c/libf2c/d_abs.c new file mode 100644 index 00000000..2f7a153c --- /dev/null +++ b/unix/f2c/libf2c/d_abs.c @@ -0,0 +1,18 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +double d_abs(x) doublereal *x; +#else +double d_abs(doublereal *x) +#endif +{ +if(*x >= 0) + return(*x); +return(- *x); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/d_acos.c b/unix/f2c/libf2c/d_acos.c new file mode 100644 index 00000000..69005b56 --- /dev/null +++ b/unix/f2c/libf2c/d_acos.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double acos(); +double d_acos(x) doublereal *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double d_acos(doublereal *x) +#endif +{ +return( acos(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/d_asin.c b/unix/f2c/libf2c/d_asin.c new file mode 100644 index 00000000..d5196ab1 --- /dev/null +++ b/unix/f2c/libf2c/d_asin.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double asin(); +double d_asin(x) doublereal *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double d_asin(doublereal *x) +#endif +{ +return( asin(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/d_atan.c b/unix/f2c/libf2c/d_atan.c new file mode 100644 index 00000000..d8856f8d --- /dev/null +++ b/unix/f2c/libf2c/d_atan.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double atan(); +double d_atan(x) doublereal *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double d_atan(doublereal *x) +#endif +{ +return( atan(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/d_atn2.c b/unix/f2c/libf2c/d_atn2.c new file mode 100644 index 00000000..56113850 --- /dev/null +++ b/unix/f2c/libf2c/d_atn2.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double atan2(); +double d_atn2(x,y) doublereal *x, *y; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double d_atn2(doublereal *x, doublereal *y) +#endif +{ +return( atan2(*x,*y) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/d_cnjg.c b/unix/f2c/libf2c/d_cnjg.c new file mode 100644 index 00000000..38471d9b --- /dev/null +++ b/unix/f2c/libf2c/d_cnjg.c @@ -0,0 +1,19 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + + VOID +#ifdef KR_headers +d_cnjg(r, z) doublecomplex *r, *z; +#else +d_cnjg(doublecomplex *r, doublecomplex *z) +#endif +{ + doublereal zi = z->i; + r->r = z->r; + r->i = -zi; + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/d_cos.c b/unix/f2c/libf2c/d_cos.c new file mode 100644 index 00000000..12def9ad --- /dev/null +++ b/unix/f2c/libf2c/d_cos.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double cos(); +double d_cos(x) doublereal *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double d_cos(doublereal *x) +#endif +{ +return( cos(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/d_cosh.c b/unix/f2c/libf2c/d_cosh.c new file mode 100644 index 00000000..9214c7a0 --- /dev/null +++ b/unix/f2c/libf2c/d_cosh.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double cosh(); +double d_cosh(x) doublereal *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double d_cosh(doublereal *x) +#endif +{ +return( cosh(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/d_dim.c b/unix/f2c/libf2c/d_dim.c new file mode 100644 index 00000000..627ddb69 --- /dev/null +++ b/unix/f2c/libf2c/d_dim.c @@ -0,0 +1,16 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +double d_dim(a,b) doublereal *a, *b; +#else +double d_dim(doublereal *a, doublereal *b) +#endif +{ +return( *a > *b ? *a - *b : 0); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/d_exp.c b/unix/f2c/libf2c/d_exp.c new file mode 100644 index 00000000..e9ab5d44 --- /dev/null +++ b/unix/f2c/libf2c/d_exp.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double exp(); +double d_exp(x) doublereal *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double d_exp(doublereal *x) +#endif +{ +return( exp(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/d_imag.c b/unix/f2c/libf2c/d_imag.c new file mode 100644 index 00000000..d17b9dd5 --- /dev/null +++ b/unix/f2c/libf2c/d_imag.c @@ -0,0 +1,16 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +double d_imag(z) doublecomplex *z; +#else +double d_imag(doublecomplex *z) +#endif +{ +return(z->i); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/d_int.c b/unix/f2c/libf2c/d_int.c new file mode 100644 index 00000000..6da4ce35 --- /dev/null +++ b/unix/f2c/libf2c/d_int.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double floor(); +double d_int(x) doublereal *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double d_int(doublereal *x) +#endif +{ +return( (*x>0) ? floor(*x) : -floor(- *x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/d_lg10.c b/unix/f2c/libf2c/d_lg10.c new file mode 100644 index 00000000..664c19d9 --- /dev/null +++ b/unix/f2c/libf2c/d_lg10.c @@ -0,0 +1,21 @@ +#include "f2c.h" + +#define log10e 0.43429448190325182765 + +#ifdef KR_headers +double log(); +double d_lg10(x) doublereal *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double d_lg10(doublereal *x) +#endif +{ +return( log10e * log(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/d_log.c b/unix/f2c/libf2c/d_log.c new file mode 100644 index 00000000..e74be02c --- /dev/null +++ b/unix/f2c/libf2c/d_log.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double log(); +double d_log(x) doublereal *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double d_log(doublereal *x) +#endif +{ +return( log(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/d_mod.c b/unix/f2c/libf2c/d_mod.c new file mode 100644 index 00000000..3766d9fa --- /dev/null +++ b/unix/f2c/libf2c/d_mod.c @@ -0,0 +1,46 @@ +#include "f2c.h" + +#ifdef KR_headers +#ifdef IEEE_drem +double drem(); +#else +double floor(); +#endif +double d_mod(x,y) doublereal *x, *y; +#else +#ifdef IEEE_drem +double drem(double, double); +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +#endif +double d_mod(doublereal *x, doublereal *y) +#endif +{ +#ifdef IEEE_drem + double xa, ya, z; + if ((ya = *y) < 0.) + ya = -ya; + z = drem(xa = *x, ya); + if (xa > 0) { + if (z < 0) + z += ya; + } + else if (z > 0) + z -= ya; + return z; +#else + double quotient; + if( (quotient = *x / *y) >= 0) + quotient = floor(quotient); + else + quotient = -floor(-quotient); + return(*x - (*y) * quotient ); +#endif +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/d_nint.c b/unix/f2c/libf2c/d_nint.c new file mode 100644 index 00000000..66f2dd0e --- /dev/null +++ b/unix/f2c/libf2c/d_nint.c @@ -0,0 +1,20 @@ +#include "f2c.h" + +#ifdef KR_headers +double floor(); +double d_nint(x) doublereal *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double d_nint(doublereal *x) +#endif +{ +return( (*x)>=0 ? + floor(*x + .5) : -floor(.5 - *x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/d_prod.c b/unix/f2c/libf2c/d_prod.c new file mode 100644 index 00000000..f9f348b0 --- /dev/null +++ b/unix/f2c/libf2c/d_prod.c @@ -0,0 +1,16 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +double d_prod(x,y) real *x, *y; +#else +double d_prod(real *x, real *y) +#endif +{ +return( (*x) * (*y) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/d_sign.c b/unix/f2c/libf2c/d_sign.c new file mode 100644 index 00000000..d06e0d19 --- /dev/null +++ b/unix/f2c/libf2c/d_sign.c @@ -0,0 +1,18 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +double d_sign(a,b) doublereal *a, *b; +#else +double d_sign(doublereal *a, doublereal *b) +#endif +{ +double x; +x = (*a >= 0 ? *a : - *a); +return( *b >= 0 ? x : -x); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/d_sin.c b/unix/f2c/libf2c/d_sin.c new file mode 100644 index 00000000..ebd4eec5 --- /dev/null +++ b/unix/f2c/libf2c/d_sin.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double sin(); +double d_sin(x) doublereal *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double d_sin(doublereal *x) +#endif +{ +return( sin(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/d_sinh.c b/unix/f2c/libf2c/d_sinh.c new file mode 100644 index 00000000..2479a6fa --- /dev/null +++ b/unix/f2c/libf2c/d_sinh.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double sinh(); +double d_sinh(x) doublereal *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double d_sinh(doublereal *x) +#endif +{ +return( sinh(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/d_sqrt.c b/unix/f2c/libf2c/d_sqrt.c new file mode 100644 index 00000000..a7fa66c0 --- /dev/null +++ b/unix/f2c/libf2c/d_sqrt.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double sqrt(); +double d_sqrt(x) doublereal *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double d_sqrt(doublereal *x) +#endif +{ +return( sqrt(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/d_tan.c b/unix/f2c/libf2c/d_tan.c new file mode 100644 index 00000000..7d252c4d --- /dev/null +++ b/unix/f2c/libf2c/d_tan.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double tan(); +double d_tan(x) doublereal *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double d_tan(doublereal *x) +#endif +{ +return( tan(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/d_tanh.c b/unix/f2c/libf2c/d_tanh.c new file mode 100644 index 00000000..415b5850 --- /dev/null +++ b/unix/f2c/libf2c/d_tanh.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double tanh(); +double d_tanh(x) doublereal *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double d_tanh(doublereal *x) +#endif +{ +return( tanh(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/derf_.c b/unix/f2c/libf2c/derf_.c new file mode 100644 index 00000000..d935d315 --- /dev/null +++ b/unix/f2c/libf2c/derf_.c @@ -0,0 +1,18 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +double erf(); +double derf_(x) doublereal *x; +#else +extern double erf(double); +double derf_(doublereal *x) +#endif +{ +return( erf(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/derfc_.c b/unix/f2c/libf2c/derfc_.c new file mode 100644 index 00000000..18f5c619 --- /dev/null +++ b/unix/f2c/libf2c/derfc_.c @@ -0,0 +1,20 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +extern double erfc(); + +double derfc_(x) doublereal *x; +#else +extern double erfc(double); + +double derfc_(doublereal *x) +#endif +{ +return( erfc(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/dfe.c b/unix/f2c/libf2c/dfe.c new file mode 100644 index 00000000..c6b10d0e --- /dev/null +++ b/unix/f2c/libf2c/dfe.c @@ -0,0 +1,151 @@ +#include "f2c.h" +#include "fio.h" +#include "fmt.h" +#ifdef __cplusplus +extern "C" { +#endif + + int +y_rsk(Void) +{ + if(f__curunit->uend || f__curunit->url <= f__recpos + || f__curunit->url == 1) return 0; + do { + getc(f__cf); + } while(++f__recpos < f__curunit->url); + return 0; +} + + int +y_getc(Void) +{ + int ch; + if(f__curunit->uend) return(-1); + if((ch=getc(f__cf))!=EOF) + { + f__recpos++; + if(f__curunit->url>=f__recpos || + f__curunit->url==1) + return(ch); + else return(' '); + } + if(feof(f__cf)) + { + f__curunit->uend=1; + errno=0; + return(-1); + } + err(f__elist->cierr,errno,"readingd"); +} + + static int +y_rev(Void) +{ + if (f__recpos < f__hiwater) + f__recpos = f__hiwater; + if (f__curunit->url > 1) + while(f__recpos < f__curunit->url) + (*f__putn)(' '); + if (f__recpos) + f__putbuf(0); + f__recpos = 0; + return(0); +} + + static int +y_err(Void) +{ + err(f__elist->cierr, 110, "dfe"); +} + + static int +y_newrec(Void) +{ + y_rev(); + f__hiwater = f__cursor = 0; + return(1); +} + + int +#ifdef KR_headers +c_dfe(a) cilist *a; +#else +c_dfe(cilist *a) +#endif +{ + f__sequential=0; + f__formatted=f__external=1; + f__elist=a; + f__cursor=f__scale=f__recpos=0; + f__curunit = &f__units[a->ciunit]; + if(a->ciunit>MXUNIT || a->ciunit<0) + err(a->cierr,101,"startchk"); + if(f__curunit->ufd==NULL && fk_open(DIR,FMT,a->ciunit)) + err(a->cierr,104,"dfe"); + f__cf=f__curunit->ufd; + if(!f__curunit->ufmt) err(a->cierr,102,"dfe") + if(!f__curunit->useek) err(a->cierr,104,"dfe") + f__fmtbuf=a->cifmt; + if(a->cirec <= 0) + err(a->cierr,130,"dfe") + FSEEK(f__cf,(OFF_T)f__curunit->url * (a->cirec-1),SEEK_SET); + f__curunit->uend = 0; + return(0); +} +#ifdef KR_headers +integer s_rdfe(a) cilist *a; +#else +integer s_rdfe(cilist *a) +#endif +{ + int n; + if(!f__init) f_init(); + f__reading=1; + if(n=c_dfe(a))return(n); + if(f__curunit->uwrt && f__nowreading(f__curunit)) + err(a->cierr,errno,"read start"); + f__getn = y_getc; + f__doed = rd_ed; + f__doned = rd_ned; + f__dorevert = f__donewrec = y_err; + f__doend = y_rsk; + if(pars_f(f__fmtbuf)<0) + err(a->cierr,100,"read start"); + fmt_bg(); + return(0); +} +#ifdef KR_headers +integer s_wdfe(a) cilist *a; +#else +integer s_wdfe(cilist *a) +#endif +{ + int n; + if(!f__init) f_init(); + f__reading=0; + if(n=c_dfe(a)) return(n); + if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit)) + err(a->cierr,errno,"startwrt"); + f__putn = x_putc; + f__doed = w_ed; + f__doned= w_ned; + f__dorevert = y_err; + f__donewrec = y_newrec; + f__doend = y_rev; + if(pars_f(f__fmtbuf)<0) + err(a->cierr,100,"startwrt"); + fmt_bg(); + return(0); +} +integer e_rdfe(Void) +{ + en_fio(); + return 0; +} +integer e_wdfe(Void) +{ + return en_fio(); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/dolio.c b/unix/f2c/libf2c/dolio.c new file mode 100644 index 00000000..4070d879 --- /dev/null +++ b/unix/f2c/libf2c/dolio.c @@ -0,0 +1,26 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef __cplusplus +extern "C" { +#endif +#ifdef KR_headers +extern int (*f__lioproc)(); + +integer do_lio(type,number,ptr,len) ftnint *number,*type; char *ptr; ftnlen len; +#else +extern int (*f__lioproc)(ftnint*, char*, ftnlen, ftnint); + +integer do_lio(ftnint *type, ftnint *number, char *ptr, ftnlen len) +#endif +{ + return((*f__lioproc)(number,ptr,len,*type)); +} +#ifdef __cplusplus + } +#endif +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/dtime_.c b/unix/f2c/libf2c/dtime_.c new file mode 100644 index 00000000..6a09b3e9 --- /dev/null +++ b/unix/f2c/libf2c/dtime_.c @@ -0,0 +1,63 @@ +#include "time.h" + +#ifdef MSDOS +#undef USE_CLOCK +#define USE_CLOCK +#endif + +#ifndef REAL +#define REAL double +#endif + +#ifndef USE_CLOCK +#define _INCLUDE_POSIX_SOURCE /* for HP-UX */ +#define _INCLUDE_XOPEN_SOURCE /* for HP-UX */ +#include "sys/types.h" +#include "sys/times.h" +#ifdef __cplusplus +extern "C" { +#endif +#endif + +#undef Hz +#ifdef CLK_TCK +#define Hz CLK_TCK +#else +#ifdef HZ +#define Hz HZ +#else +#define Hz 60 +#endif +#endif + + REAL +#ifdef KR_headers +dtime_(tarray) float *tarray; +#else +dtime_(float *tarray) +#endif +{ +#ifdef USE_CLOCK +#ifndef CLOCKS_PER_SECOND +#define CLOCKS_PER_SECOND Hz +#endif + static double t0; + double t = clock(); + tarray[1] = 0; + tarray[0] = (t - t0) / CLOCKS_PER_SECOND; + t0 = t; + return tarray[0]; +#else + struct tms t; + static struct tms t0; + + times(&t); + tarray[0] = (double)(t.tms_utime - t0.tms_utime) / Hz; + tarray[1] = (double)(t.tms_stime - t0.tms_stime) / Hz; + t0 = t; + return tarray[0] + tarray[1]; +#endif + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/due.c b/unix/f2c/libf2c/due.c new file mode 100644 index 00000000..a7f4cec4 --- /dev/null +++ b/unix/f2c/libf2c/due.c @@ -0,0 +1,77 @@ +#include "f2c.h" +#include "fio.h" +#ifdef __cplusplus +extern "C" { +#endif + + int +#ifdef KR_headers +c_due(a) cilist *a; +#else +c_due(cilist *a) +#endif +{ + if(!f__init) f_init(); + f__sequential=f__formatted=f__recpos=0; + f__external=1; + f__curunit = &f__units[a->ciunit]; + if(a->ciunit>=MXUNIT || a->ciunit<0) + err(a->cierr,101,"startio"); + f__elist=a; + if(f__curunit->ufd==NULL && fk_open(DIR,UNF,a->ciunit) ) err(a->cierr,104,"due"); + f__cf=f__curunit->ufd; + if(f__curunit->ufmt) err(a->cierr,102,"cdue") + if(!f__curunit->useek) err(a->cierr,104,"cdue") + if(f__curunit->ufd==NULL) err(a->cierr,114,"cdue") + if(a->cirec <= 0) + err(a->cierr,130,"due") + FSEEK(f__cf,(OFF_T)(a->cirec-1)*f__curunit->url,SEEK_SET); + f__curunit->uend = 0; + return(0); +} +#ifdef KR_headers +integer s_rdue(a) cilist *a; +#else +integer s_rdue(cilist *a) +#endif +{ + int n; + f__reading=1; + if(n=c_due(a)) return(n); + if(f__curunit->uwrt && f__nowreading(f__curunit)) + err(a->cierr,errno,"read start"); + return(0); +} +#ifdef KR_headers +integer s_wdue(a) cilist *a; +#else +integer s_wdue(cilist *a) +#endif +{ + int n; + f__reading=0; + if(n=c_due(a)) return(n); + if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit)) + err(a->cierr,errno,"write start"); + return(0); +} +integer e_rdue(Void) +{ + if(f__curunit->url==1 || f__recpos==f__curunit->url) + return(0); + FSEEK(f__cf,(OFF_T)(f__curunit->url-f__recpos),SEEK_CUR); + if(FTELL(f__cf)%f__curunit->url) + err(f__elist->cierr,200,"syserr"); + return(0); +} +integer e_wdue(Void) +{ +#ifdef ALWAYS_FLUSH + if (fflush(f__cf)) + err(f__elist->cierr,errno,"write end"); +#endif + return(e_rdue()); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/ef1asc_.c b/unix/f2c/libf2c/ef1asc_.c new file mode 100644 index 00000000..70be0bc2 --- /dev/null +++ b/unix/f2c/libf2c/ef1asc_.c @@ -0,0 +1,25 @@ +/* EFL support routine to copy string b to string a */ + +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + + +#define M ( (long) (sizeof(long) - 1) ) +#define EVEN(x) ( ( (x)+ M) & (~M) ) + +#ifdef KR_headers +extern VOID s_copy(); +ef1asc_(a, la, b, lb) ftnint *a, *b; ftnlen *la, *lb; +#else +extern void s_copy(char*,char*,ftnlen,ftnlen); +int ef1asc_(ftnint *a, ftnlen *la, ftnint *b, ftnlen *lb) +#endif +{ +s_copy( (char *)a, (char *)b, EVEN(*la), *lb ); +return 0; /* ignored return value */ +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/ef1cmc_.c b/unix/f2c/libf2c/ef1cmc_.c new file mode 100644 index 00000000..4b420ae6 --- /dev/null +++ b/unix/f2c/libf2c/ef1cmc_.c @@ -0,0 +1,20 @@ +/* EFL support routine to compare two character strings */ + +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +extern integer s_cmp(); +integer ef1cmc_(a, la, b, lb) ftnint *a, *b; ftnlen *la, *lb; +#else +extern integer s_cmp(char*,char*,ftnlen,ftnlen); +integer ef1cmc_(ftnint *a, ftnlen *la, ftnint *b, ftnlen *lb) +#endif +{ +return( s_cmp( (char *)a, (char *)b, *la, *lb) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/endfile.c b/unix/f2c/libf2c/endfile.c new file mode 100644 index 00000000..04020d38 --- /dev/null +++ b/unix/f2c/libf2c/endfile.c @@ -0,0 +1,160 @@ +#include "f2c.h" +#include "fio.h" + +/* Compile this with -DNO_TRUNCATE if unistd.h does not exist or */ +/* if it does not define int truncate(const char *name, off_t). */ + +#ifdef MSDOS +#undef NO_TRUNCATE +#define NO_TRUNCATE +#endif + +#ifndef NO_TRUNCATE +#include "unistd.h" +#endif + +#ifdef KR_headers +extern char *strcpy(); +extern FILE *tmpfile(); +#else +#undef abs +#undef min +#undef max +#include "stdlib.h" +#include "string.h" +#ifdef __cplusplus +extern "C" { +#endif +#endif + +extern char *f__r_mode[], *f__w_mode[]; + +#ifdef KR_headers +integer f_end(a) alist *a; +#else +integer f_end(alist *a) +#endif +{ + unit *b; + FILE *tf; + + if(a->aunit>=MXUNIT || a->aunit<0) err(a->aerr,101,"endfile"); + b = &f__units[a->aunit]; + if(b->ufd==NULL) { + char nbuf[10]; + sprintf(nbuf,"fort.%ld",(long)a->aunit); + if (tf = FOPEN(nbuf, f__w_mode[0])) + fclose(tf); + return(0); + } + b->uend=1; + return(b->useek ? t_runc(a) : 0); +} + +#ifdef NO_TRUNCATE + static int +#ifdef KR_headers +copy(from, len, to) FILE *from, *to; register long len; +#else +copy(FILE *from, register long len, FILE *to) +#endif +{ + int len1; + char buf[BUFSIZ]; + + while(fread(buf, len1 = len > BUFSIZ ? BUFSIZ : (int)len, 1, from)) { + if (!fwrite(buf, len1, 1, to)) + return 1; + if ((len -= len1) <= 0) + break; + } + return 0; + } +#endif /* NO_TRUNCATE */ + + int +#ifdef KR_headers +t_runc(a) alist *a; +#else +t_runc(alist *a) +#endif +{ + OFF_T loc, len; + unit *b; + int rc; + FILE *bf; +#ifdef NO_TRUNCATE + FILE *tf; +#endif + + b = &f__units[a->aunit]; + if(b->url) + return(0); /*don't truncate direct files*/ + loc=FTELL(bf = b->ufd); + FSEEK(bf,(OFF_T)0,SEEK_END); + len=FTELL(bf); + if (loc >= len || b->useek == 0) + return(0); +#ifdef NO_TRUNCATE + if (b->ufnm == NULL) + return 0; + rc = 0; + fclose(b->ufd); + if (!loc) { + if (!(bf = FOPEN(b->ufnm, f__w_mode[b->ufmt]))) + rc = 1; + if (b->uwrt) + b->uwrt = 1; + goto done; + } + if (!(bf = FOPEN(b->ufnm, f__r_mode[0])) + || !(tf = tmpfile())) { +#ifdef NON_UNIX_STDIO + bad: +#endif + rc = 1; + goto done; + } + if (copy(bf, (long)loc, tf)) { + bad1: + rc = 1; + goto done1; + } + if (!(bf = FREOPEN(b->ufnm, f__w_mode[0], bf))) + goto bad1; + rewind(tf); + if (copy(tf, (long)loc, bf)) + goto bad1; + b->uwrt = 1; + b->urw = 2; +#ifdef NON_UNIX_STDIO + if (b->ufmt) { + fclose(bf); + if (!(bf = FOPEN(b->ufnm, f__w_mode[3]))) + goto bad; + FSEEK(bf,(OFF_T)0,SEEK_END); + b->urw = 3; + } +#endif +done1: + fclose(tf); +done: + f__cf = b->ufd = bf; +#else /* NO_TRUNCATE */ + if (b->urw & 2) + fflush(b->ufd); /* necessary on some Linux systems */ +#ifndef FTRUNCATE +#define FTRUNCATE ftruncate +#endif + rc = FTRUNCATE(fileno(b->ufd), loc); + /* The following FSEEK is unnecessary on some systems, */ + /* but should be harmless. */ + FSEEK(b->ufd, (OFF_T)0, SEEK_END); +#endif /* NO_TRUNCATE */ + if (rc) + err(a->aerr,111,"endfile"); + return 0; + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/erf_.c b/unix/f2c/libf2c/erf_.c new file mode 100644 index 00000000..532fec61 --- /dev/null +++ b/unix/f2c/libf2c/erf_.c @@ -0,0 +1,22 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifndef REAL +#define REAL double +#endif + +#ifdef KR_headers +double erf(); +REAL erf_(x) real *x; +#else +extern double erf(double); +REAL erf_(real *x) +#endif +{ +return( erf((double)*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/erfc_.c b/unix/f2c/libf2c/erfc_.c new file mode 100644 index 00000000..6f6c9f10 --- /dev/null +++ b/unix/f2c/libf2c/erfc_.c @@ -0,0 +1,22 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifndef REAL +#define REAL double +#endif + +#ifdef KR_headers +double erfc(); +REAL erfc_(x) real *x; +#else +extern double erfc(double); +REAL erfc_(real *x) +#endif +{ +return( erfc((double)*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/err.c b/unix/f2c/libf2c/err.c new file mode 100644 index 00000000..80a3b749 --- /dev/null +++ b/unix/f2c/libf2c/err.c @@ -0,0 +1,293 @@ +#include "sysdep1.h" /* here to get stat64 on some badly designed Linux systems */ +#include "f2c.h" +#ifdef KR_headers +#define Const /*nothing*/ +extern char *malloc(); +#else +#define Const const +#undef abs +#undef min +#undef max +#include "stdlib.h" +#endif +#include "fio.h" +#include "fmt.h" /* for struct syl */ + +/* Compile this with -DNO_ISATTY if unistd.h does not exist or */ +/* if it does not define int isatty(int). */ +#ifdef NO_ISATTY +#define isatty(x) 0 +#else +#include <unistd.h> +#endif + +#ifdef __cplusplus +extern "C" { +#endif + +/*global definitions*/ +unit f__units[MXUNIT]; /*unit table*/ +flag f__init; /*0 on entry, 1 after initializations*/ +cilist *f__elist; /*active external io list*/ +icilist *f__svic; /*active internal io list*/ +flag f__reading; /*1 if reading, 0 if writing*/ +flag f__cplus,f__cblank; +Const char *f__fmtbuf; +flag f__external; /*1 if external io, 0 if internal */ +#ifdef KR_headers +int (*f__doed)(),(*f__doned)(); +int (*f__doend)(),(*f__donewrec)(),(*f__dorevert)(); +int (*f__getn)(); /* for formatted input */ +void (*f__putn)(); /* for formatted output */ +#else +int (*f__getn)(void); /* for formatted input */ +void (*f__putn)(int); /* for formatted output */ +int (*f__doed)(struct syl*, char*, ftnlen),(*f__doned)(struct syl*); +int (*f__dorevert)(void),(*f__donewrec)(void),(*f__doend)(void); +#endif +flag f__sequential; /*1 if sequential io, 0 if direct*/ +flag f__formatted; /*1 if formatted io, 0 if unformatted*/ +FILE *f__cf; /*current file*/ +unit *f__curunit; /*current unit*/ +int f__recpos; /*place in current record*/ +OFF_T f__cursor, f__hiwater; +int f__scale; +char *f__icptr; + +/*error messages*/ +Const char *F_err[] = +{ + "error in format", /* 100 */ + "illegal unit number", /* 101 */ + "formatted io not allowed", /* 102 */ + "unformatted io not allowed", /* 103 */ + "direct io not allowed", /* 104 */ + "sequential io not allowed", /* 105 */ + "can't backspace file", /* 106 */ + "null file name", /* 107 */ + "can't stat file", /* 108 */ + "unit not connected", /* 109 */ + "off end of record", /* 110 */ + "truncation failed in endfile", /* 111 */ + "incomprehensible list input", /* 112 */ + "out of free space", /* 113 */ + "unit not connected", /* 114 */ + "read unexpected character", /* 115 */ + "bad logical input field", /* 116 */ + "bad variable type", /* 117 */ + "bad namelist name", /* 118 */ + "variable not in namelist", /* 119 */ + "no end record", /* 120 */ + "variable count incorrect", /* 121 */ + "subscript for scalar variable", /* 122 */ + "invalid array section", /* 123 */ + "substring out of bounds", /* 124 */ + "subscript out of bounds", /* 125 */ + "can't read file", /* 126 */ + "can't write file", /* 127 */ + "'new' file exists", /* 128 */ + "can't append to file", /* 129 */ + "non-positive record number", /* 130 */ + "nmLbuf overflow" /* 131 */ +}; +#define MAXERR (sizeof(F_err)/sizeof(char *)+100) + + int +#ifdef KR_headers +f__canseek(f) FILE *f; /*SYSDEP*/ +#else +f__canseek(FILE *f) /*SYSDEP*/ +#endif +{ +#ifdef NON_UNIX_STDIO + return !isatty(fileno(f)); +#else + struct STAT_ST x; + + if (FSTAT(fileno(f),&x) < 0) + return(0); +#ifdef S_IFMT + switch(x.st_mode & S_IFMT) { + case S_IFDIR: + case S_IFREG: + if(x.st_nlink > 0) /* !pipe */ + return(1); + else + return(0); + case S_IFCHR: + if(isatty(fileno(f))) + return(0); + return(1); +#ifdef S_IFBLK + case S_IFBLK: + return(1); +#endif + } +#else +#ifdef S_ISDIR + /* POSIX version */ + if (S_ISREG(x.st_mode) || S_ISDIR(x.st_mode)) { + if(x.st_nlink > 0) /* !pipe */ + return(1); + else + return(0); + } + if (S_ISCHR(x.st_mode)) { + if(isatty(fileno(f))) + return(0); + return(1); + } + if (S_ISBLK(x.st_mode)) + return(1); +#else + Help! How does fstat work on this system? +#endif +#endif + return(0); /* who knows what it is? */ +#endif +} + + void +#ifdef KR_headers +f__fatal(n,s) char *s; +#else +f__fatal(int n, const char *s) +#endif +{ + if(n<100 && n>=0) perror(s); /*SYSDEP*/ + else if(n >= (int)MAXERR || n < -1) + { fprintf(stderr,"%s: illegal error number %d\n",s,n); + } + else if(n == -1) fprintf(stderr,"%s: end of file\n",s); + else + fprintf(stderr,"%s: %s\n",s,F_err[n-100]); + if (f__curunit) { + fprintf(stderr,"apparent state: unit %d ", + (int)(f__curunit-f__units)); + fprintf(stderr, f__curunit->ufnm ? "named %s\n" : "(unnamed)\n", + f__curunit->ufnm); + } + else + fprintf(stderr,"apparent state: internal I/O\n"); + if (f__fmtbuf) + fprintf(stderr,"last format: %s\n",f__fmtbuf); + fprintf(stderr,"lately %s %s %s %s",f__reading?"reading":"writing", + f__sequential?"sequential":"direct",f__formatted?"formatted":"unformatted", + f__external?"external":"internal"); + sig_die(" IO", 1); +} +/*initialization routine*/ + VOID +f_init(Void) +{ unit *p; + + f__init=1; + p= &f__units[0]; + p->ufd=stderr; + p->useek=f__canseek(stderr); + p->ufmt=1; + p->uwrt=1; + p = &f__units[5]; + p->ufd=stdin; + p->useek=f__canseek(stdin); + p->ufmt=1; + p->uwrt=0; + p= &f__units[6]; + p->ufd=stdout; + p->useek=f__canseek(stdout); + p->ufmt=1; + p->uwrt=1; +} + + int +#ifdef KR_headers +f__nowreading(x) unit *x; +#else +f__nowreading(unit *x) +#endif +{ + OFF_T loc; + int ufmt, urw; + extern char *f__r_mode[], *f__w_mode[]; + + if (x->urw & 1) + goto done; + if (!x->ufnm) + goto cantread; + ufmt = x->url ? 0 : x->ufmt; + loc = FTELL(x->ufd); + urw = 3; + if (!FREOPEN(x->ufnm, f__w_mode[ufmt|2], x->ufd)) { + urw = 1; + if(!FREOPEN(x->ufnm, f__r_mode[ufmt], x->ufd)) { + cantread: + errno = 126; + return 1; + } + } + FSEEK(x->ufd,loc,SEEK_SET); + x->urw = urw; + done: + x->uwrt = 0; + return 0; +} + + int +#ifdef KR_headers +f__nowwriting(x) unit *x; +#else +f__nowwriting(unit *x) +#endif +{ + OFF_T loc; + int ufmt; + extern char *f__w_mode[]; + + if (x->urw & 2) { + if (x->urw & 1) + FSEEK(x->ufd, (OFF_T)0, SEEK_CUR); + goto done; + } + if (!x->ufnm) + goto cantwrite; + ufmt = x->url ? 0 : x->ufmt; + if (x->uwrt == 3) { /* just did write, rewind */ + if (!(f__cf = x->ufd = + FREOPEN(x->ufnm,f__w_mode[ufmt],x->ufd))) + goto cantwrite; + x->urw = 2; + } + else { + loc=FTELL(x->ufd); + if (!(f__cf = x->ufd = + FREOPEN(x->ufnm, f__w_mode[ufmt | 2], x->ufd))) + { + x->ufd = NULL; + cantwrite: + errno = 127; + return(1); + } + x->urw = 3; + FSEEK(x->ufd,loc,SEEK_SET); + } + done: + x->uwrt = 1; + return 0; +} + + int +#ifdef KR_headers +err__fl(f, m, s) int f, m; char *s; +#else +err__fl(int f, int m, const char *s) +#endif +{ + if (!f) + f__fatal(m, s); + if (f__doend) + (*f__doend)(); + return errno = m; + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/etime_.c b/unix/f2c/libf2c/etime_.c new file mode 100644 index 00000000..2d9a36d8 --- /dev/null +++ b/unix/f2c/libf2c/etime_.c @@ -0,0 +1,57 @@ +#include "time.h" + +#ifdef MSDOS +#undef USE_CLOCK +#define USE_CLOCK +#endif + +#ifndef REAL +#define REAL double +#endif + +#ifndef USE_CLOCK +#define _INCLUDE_POSIX_SOURCE /* for HP-UX */ +#define _INCLUDE_XOPEN_SOURCE /* for HP-UX */ +#include "sys/types.h" +#include "sys/times.h" +#ifdef __cplusplus +extern "C" { +#endif +#endif + +#undef Hz +#ifdef CLK_TCK +#define Hz CLK_TCK +#else +#ifdef HZ +#define Hz HZ +#else +#define Hz 60 +#endif +#endif + + REAL +#ifdef KR_headers +etime_(tarray) float *tarray; +#else +etime_(float *tarray) +#endif +{ +#ifdef USE_CLOCK +#ifndef CLOCKS_PER_SECOND +#define CLOCKS_PER_SECOND Hz +#endif + double t = clock(); + tarray[1] = 0; + return tarray[0] = t / CLOCKS_PER_SECOND; +#else + struct tms t; + + times(&t); + return (tarray[0] = (double)t.tms_utime/Hz) + + (tarray[1] = (double)t.tms_stime/Hz); +#endif + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/exit_.c b/unix/f2c/libf2c/exit_.c new file mode 100644 index 00000000..08e9d070 --- /dev/null +++ b/unix/f2c/libf2c/exit_.c @@ -0,0 +1,43 @@ +/* This gives the effect of + + subroutine exit(rc) + integer*4 rc + stop + end + + * with the added side effect of supplying rc as the program's exit code. + */ + +#include "f2c.h" +#undef abs +#undef min +#undef max +#ifndef KR_headers +#include "stdlib.h" +#ifdef __cplusplus +extern "C" { +#endif +#ifdef __cplusplus +extern "C" { +#endif +extern void f_exit(void); +#endif + + void +#ifdef KR_headers +exit_(rc) integer *rc; +#else +exit_(integer *rc) +#endif +{ +#ifdef NO_ONEXIT + f_exit(); +#endif + exit(*rc); + } +#ifdef __cplusplus +} +#endif +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/f2c.h b/unix/f2c/libf2c/f2c.h new file mode 100644 index 00000000..b94ee7c8 --- /dev/null +++ b/unix/f2c/libf2c/f2c.h @@ -0,0 +1,223 @@ +/* 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 diff --git a/unix/f2c/libf2c/f2c.h0 b/unix/f2c/libf2c/f2c.h0 new file mode 100644 index 00000000..b94ee7c8 --- /dev/null +++ b/unix/f2c/libf2c/f2c.h0 @@ -0,0 +1,223 @@ +/* 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 diff --git a/unix/f2c/libf2c/f2ch.add b/unix/f2c/libf2c/f2ch.add new file mode 100644 index 00000000..a2acc17a --- /dev/null +++ b/unix/f2c/libf2c/f2ch.add @@ -0,0 +1,162 @@ +/* If you are using a C++ compiler, append the following to f2c.h + for compiling libF77 and libI77. */ + +#ifdef __cplusplus +extern "C" { +extern int abort_(void); +extern double c_abs(complex *); +extern void c_cos(complex *, complex *); +extern void c_div(complex *, complex *, complex *); +extern void c_exp(complex *, complex *); +extern void c_log(complex *, complex *); +extern void c_sin(complex *, complex *); +extern void c_sqrt(complex *, complex *); +extern double d_abs(double *); +extern double d_acos(double *); +extern double d_asin(double *); +extern double d_atan(double *); +extern double d_atn2(double *, double *); +extern void d_cnjg(doublecomplex *, doublecomplex *); +extern double d_cos(double *); +extern double d_cosh(double *); +extern double d_dim(double *, double *); +extern double d_exp(double *); +extern double d_imag(doublecomplex *); +extern double d_int(double *); +extern double d_lg10(double *); +extern double d_log(double *); +extern double d_mod(double *, double *); +extern double d_nint(double *); +extern double d_prod(float *, float *); +extern double d_sign(double *, double *); +extern double d_sin(double *); +extern double d_sinh(double *); +extern double d_sqrt(double *); +extern double d_tan(double *); +extern double d_tanh(double *); +extern double derf_(double *); +extern double derfc_(double *); +extern integer do_fio(ftnint *, char *, ftnlen); +extern integer do_lio(ftnint *, ftnint *, char *, ftnlen); +extern integer do_uio(ftnint *, char *, ftnlen); +extern integer e_rdfe(void); +extern integer e_rdue(void); +extern integer e_rsfe(void); +extern integer e_rsfi(void); +extern integer e_rsle(void); +extern integer e_rsli(void); +extern integer e_rsue(void); +extern integer e_wdfe(void); +extern integer e_wdue(void); +extern integer e_wsfe(void); +extern integer e_wsfi(void); +extern integer e_wsle(void); +extern integer e_wsli(void); +extern integer e_wsue(void); +extern int ef1asc_(ftnint *, ftnlen *, ftnint *, ftnlen *); +extern integer ef1cmc_(ftnint *, ftnlen *, ftnint *, ftnlen *); +extern double erf(double); +extern double erf_(float *); +extern double erfc(double); +extern double erfc_(float *); +extern integer f_back(alist *); +extern integer f_clos(cllist *); +extern integer f_end(alist *); +extern void f_exit(void); +extern integer f_inqu(inlist *); +extern integer f_open(olist *); +extern integer f_rew(alist *); +extern int flush_(void); +extern void getarg_(integer *, char *, ftnlen); +extern void getenv_(char *, char *, ftnlen, ftnlen); +extern short h_abs(short *); +extern short h_dim(short *, short *); +extern short h_dnnt(double *); +extern short h_indx(char *, char *, ftnlen, ftnlen); +extern short h_len(char *, ftnlen); +extern short h_mod(short *, short *); +extern short h_nint(float *); +extern short h_sign(short *, short *); +extern short hl_ge(char *, char *, ftnlen, ftnlen); +extern short hl_gt(char *, char *, ftnlen, ftnlen); +extern short hl_le(char *, char *, ftnlen, ftnlen); +extern short hl_lt(char *, char *, ftnlen, ftnlen); +extern integer i_abs(integer *); +extern integer i_dim(integer *, integer *); +extern integer i_dnnt(double *); +extern integer i_indx(char *, char *, ftnlen, ftnlen); +extern integer i_len(char *, ftnlen); +extern integer i_mod(integer *, integer *); +extern integer i_nint(float *); +extern integer i_sign(integer *, integer *); +extern integer iargc_(void); +extern ftnlen l_ge(char *, char *, ftnlen, ftnlen); +extern ftnlen l_gt(char *, char *, ftnlen, ftnlen); +extern ftnlen l_le(char *, char *, ftnlen, ftnlen); +extern ftnlen l_lt(char *, char *, ftnlen, ftnlen); +extern void pow_ci(complex *, complex *, integer *); +extern double pow_dd(double *, double *); +extern double pow_di(double *, integer *); +extern short pow_hh(short *, shortint *); +extern integer pow_ii(integer *, integer *); +extern double pow_ri(float *, integer *); +extern void pow_zi(doublecomplex *, doublecomplex *, integer *); +extern void pow_zz(doublecomplex *, doublecomplex *, doublecomplex *); +extern double r_abs(float *); +extern double r_acos(float *); +extern double r_asin(float *); +extern double r_atan(float *); +extern double r_atn2(float *, float *); +extern void r_cnjg(complex *, complex *); +extern double r_cos(float *); +extern double r_cosh(float *); +extern double r_dim(float *, float *); +extern double r_exp(float *); +extern double r_imag(complex *); +extern double r_int(float *); +extern double r_lg10(float *); +extern double r_log(float *); +extern double r_mod(float *, float *); +extern double r_nint(float *); +extern double r_sign(float *, float *); +extern double r_sin(float *); +extern double r_sinh(float *); +extern double r_sqrt(float *); +extern double r_tan(float *); +extern double r_tanh(float *); +extern void s_cat(char *, char **, integer *, integer *, ftnlen); +extern integer s_cmp(char *, char *, ftnlen, ftnlen); +extern void s_copy(char *, char *, ftnlen, ftnlen); +extern int s_paus(char *, ftnlen); +extern integer s_rdfe(cilist *); +extern integer s_rdue(cilist *); +extern integer s_rnge(char *, integer, char *, integer); +extern integer s_rsfe(cilist *); +extern integer s_rsfi(icilist *); +extern integer s_rsle(cilist *); +extern integer s_rsli(icilist *); +extern integer s_rsne(cilist *); +extern integer s_rsni(icilist *); +extern integer s_rsue(cilist *); +extern int s_stop(char *, ftnlen); +extern integer s_wdfe(cilist *); +extern integer s_wdue(cilist *); +extern integer s_wsfe(cilist *); +extern integer s_wsfi(icilist *); +extern integer s_wsle(cilist *); +extern integer s_wsli(icilist *); +extern integer s_wsne(cilist *); +extern integer s_wsni(icilist *); +extern integer s_wsue(cilist *); +extern void sig_die(char *, int); +extern integer signal_(integer *, void (*)(int)); +extern integer system_(char *, ftnlen); +extern double z_abs(doublecomplex *); +extern void z_cos(doublecomplex *, doublecomplex *); +extern void z_div(doublecomplex *, doublecomplex *, doublecomplex *); +extern void z_exp(doublecomplex *, doublecomplex *); +extern void z_log(doublecomplex *, doublecomplex *); +extern void z_sin(doublecomplex *, doublecomplex *); +extern void z_sqrt(doublecomplex *, doublecomplex *); + } +#endif diff --git a/unix/f2c/libf2c/f77_aloc.c b/unix/f2c/libf2c/f77_aloc.c new file mode 100644 index 00000000..f5360990 --- /dev/null +++ b/unix/f2c/libf2c/f77_aloc.c @@ -0,0 +1,44 @@ +#include "f2c.h" +#undef abs +#undef min +#undef max +#include "stdio.h" + +static integer memfailure = 3; + +#ifdef KR_headers +extern char *malloc(); +extern void exit_(); + + char * +F77_aloc(Len, whence) integer Len; char *whence; +#else +#include "stdlib.h" +#ifdef __cplusplus +extern "C" { +#endif +#ifdef __cplusplus +extern "C" { +#endif +extern void exit_(integer*); +#ifdef __cplusplus + } +#endif + + char * +F77_aloc(integer Len, const char *whence) +#endif +{ + char *rv; + unsigned int uLen = (unsigned int) Len; /* for K&R C */ + + if (!(rv = (char*)malloc(uLen))) { + fprintf(stderr, "malloc(%u) failure in %s\n", + uLen, whence); + exit_(&memfailure); + } + return rv; + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/f77vers.c b/unix/f2c/libf2c/f77vers.c new file mode 100644 index 00000000..70cd6fe7 --- /dev/null +++ b/unix/f2c/libf2c/f77vers.c @@ -0,0 +1,97 @@ + char +_libf77_version_f2c[] = "\n@(#) LIBF77 VERSION (f2c) 20051004\n"; + +/* +2.00 11 June 1980. File version.c added to library. +2.01 31 May 1988. s_paus() flushes stderr; names of hl_* fixed + [ d]erf[c ] added + 8 Aug. 1989: #ifdefs for f2c -i2 added to s_cat.c + 29 Nov. 1989: s_cmp returns long (for f2c) + 30 Nov. 1989: arg types from f2c.h + 12 Dec. 1989: s_rnge allows long names + 19 Dec. 1989: getenv_ allows unsorted environment + 28 Mar. 1990: add exit(0) to end of main() + 2 Oct. 1990: test signal(...) == SIG_IGN rather than & 01 in main + 17 Oct. 1990: abort() calls changed to sig_die(...,1) + 22 Oct. 1990: separate sig_die from main + 25 Apr. 1991: minor, theoretically invisible tweaks to s_cat, sig_die + 31 May 1991: make system_ return status + 18 Dec. 1991: change long to ftnlen (for -i2) many places + 28 Feb. 1992: repair z_sqrt.c (scribbled on input, gave wrong answer) + 18 July 1992: for n < 0, repair handling of 0**n in pow_[dr]i.c + and m**n in pow_hh.c and pow_ii.c; + catch SIGTRAP in main() for error msg before abort + 23 July 1992: switch to ANSI prototypes unless KR_headers is #defined + 23 Oct. 1992: fix botch in signal_.c (erroneous deref of 2nd arg); + change Cabs to f__cabs. + 12 March 1993: various tweaks for C++ + 2 June 1994: adjust so abnormal terminations invoke f_exit just once + 16 Sept. 1994: s_cmp: treat characters as unsigned in comparisons. + 19 Sept. 1994: s_paus: flush after end of PAUSE; add -DMSDOS + 12 Jan. 1995: pow_[dhiqrz][hiq]: adjust x**i to work on machines + that sign-extend right shifts when i is the most + negative integer. + 26 Jan. 1995: adjust s_cat.c, s_copy.c to permit the left-hand side + of character assignments to appear on the right-hand + side (unless compiled with -DNO_OVERWRITE). + 27 Jan. 1995: minor tweak to s_copy.c: copy forward whenever + possible (for better cache behavior). + 30 May 1995: added subroutine exit(rc) integer rc. Version not changed. + 29 Aug. 1995: add F77_aloc.c; use it in s_cat.c and system_.c. + 6 Sept. 1995: fix return type of system_ under -DKR_headers. + 19 Dec. 1995: s_cat.c: fix bug when 2nd or later arg overlaps lhs. + 19 Mar. 1996: s_cat.c: supply missing break after overlap detection. + 13 May 1996: add [lq]bitbits.c and [lq]bitshft.c (f90 bit intrinsics). + 19 June 1996: add casts to unsigned in [lq]bitshft.c. + 26 Feb. 1997: 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.) + 4 April 1997: [cz]_div.c: tweaks invisible on most systems (that may + affect systems using gratuitous extra precision). + 19 Sept. 1997: [de]time_.c (Unix systems only): change return + type to double. + 2 May 1999: getenv_.c: omit environ in favor of getenv(). + c_cos.c, c_exp.c, c_sin.c, d_cnjg.c, r_cnjg.c, + z_cos.c, z_exp.c, z_log.c, z_sin.c: cope fully with + overlapping arguments caused by equivalence. + 3 May 1999: "invisible" tweaks to omit compiler warnings in + abort_.c, ef1asc_.c, s_rnge.c, s_stop.c. + + 7 Sept. 1999: [cz]_div.c: arrange for compilation under + -DIEEE_COMPLEX_DIVIDE to make these routines + avoid calling sig_die when the denominator + vanishes; instead, they return pairs of NaNs + or Infinities, depending whether the numerator + also vanishes or not. VERSION not changed. + 15 Nov. 1999: s_rnge.c: add casts for the case of + sizeof(ftnint) == sizeof(int) < sizeof(long). + 10 March 2000: z_log.c: improve accuracy of Real(log(z)) for, e.g., + z near (+-1,eps) with |eps| small. For the old + evaluation, compile with -DPre20000310 . + 20 April 2000: s_cat.c: tweak argument types to accord with + calls by f2c when ftnint and ftnlen are of + different sizes (different numbers of bits). + 4 July 2000: adjustments to permit compilation by C++ compilers; + VERSION string remains unchanged. + 29 Sept. 2000: 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. + 23 June 2001: add uninit.c; [fi]77vers.c: make version strings + visible as extern char _lib[fi]77_version_f2c[]. + 5 July 2001: modify uninit.c for __mc68k__ under Linux. + 16 Nov. 2001: uninit.c: Linux Power PC logic supplied by Alan Bain. + 18 Jan. 2002: fix glitches in qbit_bits(): wrong return type, + missing ~ on y in return value. + 14 March 2002: 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 new logic. + 4 Oct. 2002: uninit.c: on IRIX systems, omit use of shell variables. + 10 Oct 2005: 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. +*/ diff --git a/unix/f2c/libf2c/fio.h b/unix/f2c/libf2c/fio.h new file mode 100644 index 00000000..ebf76965 --- /dev/null +++ b/unix/f2c/libf2c/fio.h @@ -0,0 +1,141 @@ +#ifndef SYSDEP_H_INCLUDED +#include "sysdep1.h" +#endif +#include "stdio.h" +#include "errno.h" +#ifndef NULL +/* ANSI C */ +#include "stddef.h" +#endif + +#ifndef SEEK_SET +#define SEEK_SET 0 +#define SEEK_CUR 1 +#define SEEK_END 2 +#endif + +#ifndef FOPEN +#define FOPEN fopen +#endif + +#ifndef FREOPEN +#define FREOPEN freopen +#endif + +#ifndef FSEEK +#define FSEEK fseek +#endif + +#ifndef FSTAT +#define FSTAT fstat +#endif + +#ifndef FTELL +#define FTELL ftell +#endif + +#ifndef OFF_T +#define OFF_T long +#endif + +#ifndef STAT_ST +#define STAT_ST stat +#endif + +#ifndef STAT +#define STAT stat +#endif + +#ifdef MSDOS +#ifndef NON_UNIX_STDIO +#define NON_UNIX_STDIO +#endif +#endif + +#ifdef UIOLEN_int +typedef int uiolen; +#else +typedef long uiolen; +#endif + +/*units*/ +typedef struct +{ FILE *ufd; /*0=unconnected*/ + char *ufnm; +#ifndef MSDOS + long uinode; + int udev; +#endif + int url; /*0=sequential*/ + flag useek; /*true=can backspace, use dir, ...*/ + flag ufmt; + flag urw; /* (1 for can read) | (2 for can write) */ + flag ublnk; + flag uend; + flag uwrt; /*last io was write*/ + flag uscrtch; +} unit; + +#undef Void +#ifdef KR_headers +#define Void /*void*/ +extern int (*f__getn)(); /* for formatted input */ +extern void (*f__putn)(); /* for formatted output */ +extern void x_putc(); +extern long f__inode(); +extern VOID sig_die(); +extern int (*f__donewrec)(), t_putc(), x_wSL(); +extern int c_sfe(), err__fl(), xrd_SL(), f__putbuf(); +#else +#define Void void +#ifdef __cplusplus +extern "C" { +#endif +extern int (*f__getn)(void); /* for formatted input */ +extern void (*f__putn)(int); /* for formatted output */ +extern void x_putc(int); +extern long f__inode(char*,int*); +extern void sig_die(const char*,int); +extern void f__fatal(int, const char*); +extern int t_runc(alist*); +extern int f__nowreading(unit*), f__nowwriting(unit*); +extern int fk_open(int,int,ftnint); +extern int en_fio(void); +extern void f_init(void); +extern int (*f__donewrec)(void), t_putc(int), x_wSL(void); +extern void b_char(const char*,char*,ftnlen), g_char(const char*,ftnlen,char*); +extern int c_sfe(cilist*), z_rnew(void); +extern int err__fl(int,int,const char*); +extern int xrd_SL(void); +extern int f__putbuf(int); +#endif +extern flag f__init; +extern cilist *f__elist; /*active external io list*/ +extern flag f__reading,f__external,f__sequential,f__formatted; +extern int (*f__doend)(Void); +extern FILE *f__cf; /*current file*/ +extern unit *f__curunit; /*current unit*/ +extern unit f__units[]; +#define err(f,m,s) {if(f) errno= m; else f__fatal(m,s); return(m);} +#define errfl(f,m,s) return err__fl((int)f,m,s) + +/*Table sizes*/ +#define MXUNIT 100 + +extern int f__recpos; /*position in current record*/ +extern OFF_T f__cursor; /* offset to move to */ +extern OFF_T f__hiwater; /* so TL doesn't confuse us */ +#ifdef __cplusplus + } +#endif + +#define WRITE 1 +#define READ 2 +#define SEQ 3 +#define DIR 4 +#define FMT 5 +#define UNF 6 +#define EXT 7 +#define INT 8 + +#define buf_end(x) (x->_flag & _IONBF ? x->_ptr : x->_base + BUFSIZ) diff --git a/unix/f2c/libf2c/fmt.c b/unix/f2c/libf2c/fmt.c new file mode 100644 index 00000000..286c98f3 --- /dev/null +++ b/unix/f2c/libf2c/fmt.c @@ -0,0 +1,530 @@ +#include "f2c.h" +#include "fio.h" +#include "fmt.h" +#ifdef __cplusplus +extern "C" { +#endif +#define skip(s) while(*s==' ') s++ +#ifdef interdata +#define SYLMX 300 +#endif +#ifdef pdp11 +#define SYLMX 300 +#endif +#ifdef vax +#define SYLMX 300 +#endif +#ifndef SYLMX +#define SYLMX 300 +#endif +#define GLITCH '\2' + /* special quote character for stu */ +extern flag f__cblank,f__cplus; /*blanks in I and compulsory plus*/ +static struct syl f__syl[SYLMX]; +int f__parenlvl,f__pc,f__revloc; +#ifdef KR_headers +#define Const /*nothing*/ +#else +#define Const const +#endif + + static +#ifdef KR_headers +char *ap_end(s) char *s; +#else +const char *ap_end(const char *s) +#endif +{ char quote; + quote= *s++; + for(;*s;s++) + { if(*s!=quote) continue; + if(*++s!=quote) return(s); + } + if(f__elist->cierr) { + errno = 100; + return(NULL); + } + f__fatal(100, "bad string"); + /*NOTREACHED*/ return 0; +} + static int +#ifdef KR_headers +op_gen(a,b,c,d) +#else +op_gen(int a, int b, int c, int d) +#endif +{ struct syl *p= &f__syl[f__pc]; + if(f__pc>=SYLMX) + { fprintf(stderr,"format too complicated:\n"); + sig_die(f__fmtbuf, 1); + } + p->op=a; + p->p1=b; + p->p2.i[0]=c; + p->p2.i[1]=d; + return(f__pc++); +} +#ifdef KR_headers +static char *f_list(); +static char *gt_num(s,n,n1) char *s; int *n, n1; +#else +static const char *f_list(const char*); +static const char *gt_num(const char *s, int *n, int n1) +#endif +{ int m=0,f__cnt=0; + char c; + for(c= *s;;c = *s) + { if(c==' ') + { s++; + continue; + } + if(c>'9' || c<'0') break; + m=10*m+c-'0'; + f__cnt++; + s++; + } + if(f__cnt==0) { + if (!n1) + s = 0; + *n=n1; + } + else *n=m; + return(s); +} + + static +#ifdef KR_headers +char *f_s(s,curloc) char *s; +#else +const char *f_s(const char *s, int curloc) +#endif +{ + skip(s); + if(*s++!='(') + { + return(NULL); + } + if(f__parenlvl++ ==1) f__revloc=curloc; + if(op_gen(RET1,curloc,0,0)<0 || + (s=f_list(s))==NULL) + { + return(NULL); + } + skip(s); + return(s); +} + + static int +#ifdef KR_headers +ne_d(s,p) char *s,**p; +#else +ne_d(const char *s, const char **p) +#endif +{ int n,x,sign=0; + struct syl *sp; + switch(*s) + { + default: + return(0); + case ':': (void) op_gen(COLON,0,0,0); break; + case '$': + (void) op_gen(NONL, 0, 0, 0); break; + case 'B': + case 'b': + if(*++s=='z' || *s == 'Z') (void) op_gen(BZ,0,0,0); + else (void) op_gen(BN,0,0,0); + break; + case 'S': + case 's': + if(*(s+1)=='s' || *(s+1) == 'S') + { x=SS; + s++; + } + else if(*(s+1)=='p' || *(s+1) == 'P') + { x=SP; + s++; + } + else x=S; + (void) op_gen(x,0,0,0); + break; + case '/': (void) op_gen(SLASH,0,0,0); break; + case '-': sign=1; + case '+': s++; /*OUTRAGEOUS CODING TRICK*/ + case '0': case '1': case '2': case '3': case '4': + case '5': case '6': case '7': case '8': case '9': + if (!(s=gt_num(s,&n,0))) { + bad: *p = 0; + return 1; + } + switch(*s) + { + default: + return(0); + case 'P': + case 'p': if(sign) n= -n; (void) op_gen(P,n,0,0); break; + case 'X': + case 'x': (void) op_gen(X,n,0,0); break; + case 'H': + case 'h': + sp = &f__syl[op_gen(H,n,0,0)]; + sp->p2.s = (char*)s + 1; + s+=n; + break; + } + break; + case GLITCH: + case '"': + case '\'': + sp = &f__syl[op_gen(APOS,0,0,0)]; + sp->p2.s = (char*)s; + if((*p = ap_end(s)) == NULL) + return(0); + return(1); + case 'T': + case 't': + if(*(s+1)=='l' || *(s+1) == 'L') + { x=TL; + s++; + } + else if(*(s+1)=='r'|| *(s+1) == 'R') + { x=TR; + s++; + } + else x=T; + if (!(s=gt_num(s+1,&n,0))) + goto bad; + s--; + (void) op_gen(x,n,0,0); + break; + case 'X': + case 'x': (void) op_gen(X,1,0,0); break; + case 'P': + case 'p': (void) op_gen(P,1,0,0); break; + } + s++; + *p=s; + return(1); +} + + static int +#ifdef KR_headers +e_d(s,p) char *s,**p; +#else +e_d(const char *s, const char **p) +#endif +{ int i,im,n,w,d,e,found=0,x=0; + Const char *sv=s; + s=gt_num(s,&n,1); + (void) op_gen(STACK,n,0,0); + switch(*s++) + { + default: break; + case 'E': + case 'e': x=1; + case 'G': + case 'g': + found=1; + if (!(s=gt_num(s,&w,0))) { + bad: + *p = 0; + return 1; + } + if(w==0) break; + if(*s=='.') { + if (!(s=gt_num(s+1,&d,0))) + goto bad; + } + else d=0; + if(*s!='E' && *s != 'e') + (void) op_gen(x==1?E:G,w,d,0); /* default is Ew.dE2 */ + else { + if (!(s=gt_num(s+1,&e,0))) + goto bad; + (void) op_gen(x==1?EE:GE,w,d,e); + } + break; + case 'O': + case 'o': + i = O; + im = OM; + goto finish_I; + case 'Z': + case 'z': + i = Z; + im = ZM; + goto finish_I; + case 'L': + case 'l': + found=1; + if (!(s=gt_num(s,&w,0))) + goto bad; + if(w==0) break; + (void) op_gen(L,w,0,0); + break; + case 'A': + case 'a': + found=1; + skip(s); + if(*s>='0' && *s<='9') + { s=gt_num(s,&w,1); + if(w==0) break; + (void) op_gen(AW,w,0,0); + break; + } + (void) op_gen(A,0,0,0); + break; + case 'F': + case 'f': + if (!(s=gt_num(s,&w,0))) + goto bad; + found=1; + if(w==0) break; + if(*s=='.') { + if (!(s=gt_num(s+1,&d,0))) + goto bad; + } + else d=0; + (void) op_gen(F,w,d,0); + break; + case 'D': + case 'd': + found=1; + if (!(s=gt_num(s,&w,0))) + goto bad; + if(w==0) break; + if(*s=='.') { + if (!(s=gt_num(s+1,&d,0))) + goto bad; + } + else d=0; + (void) op_gen(D,w,d,0); + break; + case 'I': + case 'i': + i = I; + im = IM; + finish_I: + if (!(s=gt_num(s,&w,0))) + goto bad; + found=1; + if(w==0) break; + if(*s!='.') + { (void) op_gen(i,w,0,0); + break; + } + if (!(s=gt_num(s+1,&d,0))) + goto bad; + (void) op_gen(im,w,d,0); + break; + } + if(found==0) + { f__pc--; /*unSTACK*/ + *p=sv; + return(0); + } + *p=s; + return(1); +} + static +#ifdef KR_headers +char *i_tem(s) char *s; +#else +const char *i_tem(const char *s) +#endif +{ const char *t; + int n,curloc; + if(*s==')') return(s); + if(ne_d(s,&t)) return(t); + if(e_d(s,&t)) return(t); + s=gt_num(s,&n,1); + if((curloc=op_gen(STACK,n,0,0))<0) return(NULL); + return(f_s(s,curloc)); +} + + static +#ifdef KR_headers +char *f_list(s) char *s; +#else +const char *f_list(const char *s) +#endif +{ + for(;*s!=0;) + { skip(s); + if((s=i_tem(s))==NULL) return(NULL); + skip(s); + if(*s==',') s++; + else if(*s==')') + { if(--f__parenlvl==0) + { + (void) op_gen(REVERT,f__revloc,0,0); + return(++s); + } + (void) op_gen(GOTO,0,0,0); + return(++s); + } + } + return(NULL); +} + + int +#ifdef KR_headers +pars_f(s) char *s; +#else +pars_f(const char *s) +#endif +{ + f__parenlvl=f__revloc=f__pc=0; + if(f_s(s,0) == NULL) + { + return(-1); + } + return(0); +} +#define STKSZ 10 +int f__cnt[STKSZ],f__ret[STKSZ],f__cp,f__rp; +flag f__workdone, f__nonl; + + static int +#ifdef KR_headers +type_f(n) +#else +type_f(int n) +#endif +{ + switch(n) + { + default: + return(n); + case RET1: + return(RET1); + case REVERT: return(REVERT); + case GOTO: return(GOTO); + case STACK: return(STACK); + case X: + case SLASH: + case APOS: case H: + case T: case TL: case TR: + return(NED); + case F: + case I: + case IM: + case A: case AW: + case O: case OM: + case L: + case E: case EE: case D: + case G: case GE: + case Z: case ZM: + return(ED); + } +} +#ifdef KR_headers +integer do_fio(number,ptr,len) ftnint *number; ftnlen len; char *ptr; +#else +integer do_fio(ftnint *number, char *ptr, ftnlen len) +#endif +{ struct syl *p; + int n,i; + for(i=0;i<*number;i++,ptr+=len) + { +loop: switch(type_f((p= &f__syl[f__pc])->op)) + { + default: + fprintf(stderr,"unknown code in do_fio: %d\n%s\n", + p->op,f__fmtbuf); + err(f__elist->cierr,100,"do_fio"); + case NED: + if((*f__doned)(p)) + { f__pc++; + goto loop; + } + f__pc++; + continue; + case ED: + if(f__cnt[f__cp]<=0) + { f__cp--; + f__pc++; + goto loop; + } + if(ptr==NULL) + return((*f__doend)()); + f__cnt[f__cp]--; + f__workdone=1; + if((n=(*f__doed)(p,ptr,len))>0) + errfl(f__elist->cierr,errno,"fmt"); + if(n<0) + err(f__elist->ciend,(EOF),"fmt"); + continue; + case STACK: + f__cnt[++f__cp]=p->p1; + f__pc++; + goto loop; + case RET1: + f__ret[++f__rp]=p->p1; + f__pc++; + goto loop; + case GOTO: + if(--f__cnt[f__cp]<=0) + { f__cp--; + f__rp--; + f__pc++; + goto loop; + } + f__pc=1+f__ret[f__rp--]; + goto loop; + case REVERT: + f__rp=f__cp=0; + f__pc = p->p1; + if(ptr==NULL) + return((*f__doend)()); + if(!f__workdone) return(0); + if((n=(*f__dorevert)()) != 0) return(n); + goto loop; + case COLON: + if(ptr==NULL) + return((*f__doend)()); + f__pc++; + goto loop; + case NONL: + f__nonl = 1; + f__pc++; + goto loop; + case S: + case SS: + f__cplus=0; + f__pc++; + goto loop; + case SP: + f__cplus = 1; + f__pc++; + goto loop; + case P: f__scale=p->p1; + f__pc++; + goto loop; + case BN: + f__cblank=0; + f__pc++; + goto loop; + case BZ: + f__cblank=1; + f__pc++; + goto loop; + } + } + return(0); +} + + int +en_fio(Void) +{ ftnint one=1; + return(do_fio(&one,(char *)NULL,(ftnint)0)); +} + + VOID +fmt_bg(Void) +{ + f__workdone=f__cp=f__rp=f__pc=f__cursor=0; + f__cnt[0]=f__ret[0]=0; +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/fmt.h b/unix/f2c/libf2c/fmt.h new file mode 100644 index 00000000..ddfa551d --- /dev/null +++ b/unix/f2c/libf2c/fmt.h @@ -0,0 +1,105 @@ +struct syl +{ int op; + int p1; + union { int i[2]; char *s;} p2; + }; +#define RET1 1 +#define REVERT 2 +#define GOTO 3 +#define X 4 +#define SLASH 5 +#define STACK 6 +#define I 7 +#define ED 8 +#define NED 9 +#define IM 10 +#define APOS 11 +#define H 12 +#define TL 13 +#define TR 14 +#define T 15 +#define COLON 16 +#define S 17 +#define SP 18 +#define SS 19 +#define P 20 +#define BN 21 +#define BZ 22 +#define F 23 +#define E 24 +#define EE 25 +#define D 26 +#define G 27 +#define GE 28 +#define L 29 +#define A 30 +#define AW 31 +#define O 32 +#define NONL 33 +#define OM 34 +#define Z 35 +#define ZM 36 +typedef union +{ real pf; + doublereal pd; +} ufloat; +typedef union +{ short is; +#ifndef KR_headers + signed +#endif + char ic; + integer il; +#ifdef Allow_TYQUAD + longint ili; +#endif +} Uint; +#ifdef KR_headers +extern int (*f__doed)(),(*f__doned)(); +extern int (*f__dorevert)(); +extern int rd_ed(),rd_ned(); +extern int w_ed(),w_ned(); +extern int signbit_f2c(); +extern char *f__fmtbuf; +#else +#ifdef __cplusplus +extern "C" { +#define Cextern extern "C" +#else +#define Cextern extern +#endif +extern const char *f__fmtbuf; +extern int (*f__doed)(struct syl*, char*, ftnlen),(*f__doned)(struct syl*); +extern int (*f__dorevert)(void); +extern void fmt_bg(void); +extern int pars_f(const char*); +extern int rd_ed(struct syl*, char*, ftnlen),rd_ned(struct syl*); +extern int signbit_f2c(double*); +extern int w_ed(struct syl*, char*, ftnlen),w_ned(struct syl*); +extern int wrt_E(ufloat*, int, int, int, ftnlen); +extern int wrt_F(ufloat*, int, int, ftnlen); +extern int wrt_L(Uint*, int, ftnlen); +#endif +extern int f__pc,f__parenlvl,f__revloc; +extern flag f__cblank,f__cplus,f__workdone, f__nonl; +extern int f__scale; +#ifdef __cplusplus + } +#endif +#define GET(x) if((x=(*f__getn)())<0) return(x) +#define VAL(x) (x!='\n'?x:' ') +#define PUT(x) (*f__putn)(x) + +#undef TYQUAD +#ifndef Allow_TYQUAD +#undef longint +#define longint long +#else +#define TYQUAD 14 +#endif + +#ifdef KR_headers +extern char *f__icvt(); +#else +Cextern char *f__icvt(longint, int*, int*, int); +#endif diff --git a/unix/f2c/libf2c/fmtlib.c b/unix/f2c/libf2c/fmtlib.c new file mode 100644 index 00000000..279f66f4 --- /dev/null +++ b/unix/f2c/libf2c/fmtlib.c @@ -0,0 +1,51 @@ +/* @(#)fmtlib.c 1.2 */ +#define MAXINTLENGTH 23 + +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif +#ifndef Allow_TYQUAD +#undef longint +#define longint long +#undef ulongint +#define ulongint unsigned long +#endif + +#ifdef KR_headers +char *f__icvt(value,ndigit,sign, base) longint value; int *ndigit,*sign; + register int base; +#else +char *f__icvt(longint value, int *ndigit, int *sign, int base) +#endif +{ + static char buf[MAXINTLENGTH+1]; + register int i; + ulongint uvalue; + + if(value > 0) { + uvalue = value; + *sign = 0; + } + else if (value < 0) { + uvalue = -value; + *sign = 1; + } + else { + *sign = 0; + *ndigit = 1; + buf[MAXINTLENGTH-1] = '0'; + return &buf[MAXINTLENGTH-1]; + } + i = MAXINTLENGTH; + do { + buf[--i] = (uvalue%base) + '0'; + uvalue /= base; + } + while(uvalue > 0); + *ndigit = MAXINTLENGTH - i; + return &buf[i]; + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/fp.h b/unix/f2c/libf2c/fp.h new file mode 100644 index 00000000..40743d79 --- /dev/null +++ b/unix/f2c/libf2c/fp.h @@ -0,0 +1,28 @@ +#define FMAX 40 +#define EXPMAXDIGS 8 +#define EXPMAX 99999999 +/* FMAX = max number of nonzero digits passed to atof() */ +/* EXPMAX = 10^EXPMAXDIGS - 1 = largest allowed exponent absolute value */ + +#ifdef V10 /* Research Tenth-Edition Unix */ +#include "local.h" +#endif + +/* MAXFRACDIGS and MAXINTDIGS are for wrt_F -- bounds (not necessarily + tight) on the maximum number of digits to the right and left of + * the decimal point. + */ + +#ifdef VAX +#define MAXFRACDIGS 56 +#define MAXINTDIGS 38 +#else +#ifdef CRAY +#define MAXFRACDIGS 9880 +#define MAXINTDIGS 9864 +#else +/* values that suffice for IEEE double */ +#define MAXFRACDIGS 344 +#define MAXINTDIGS 308 +#endif +#endif diff --git a/unix/f2c/libf2c/ftell64_.c b/unix/f2c/libf2c/ftell64_.c new file mode 100644 index 00000000..9cc00cba --- /dev/null +++ b/unix/f2c/libf2c/ftell64_.c @@ -0,0 +1,52 @@ +#include "f2c.h" +#include "fio.h" +#ifdef __cplusplus +extern "C" { +#endif + + static FILE * +#ifdef KR_headers +unit_chk(Unit, who) integer Unit; char *who; +#else +unit_chk(integer Unit, char *who) +#endif +{ + if (Unit >= MXUNIT || Unit < 0) + f__fatal(101, who); + return f__units[Unit].ufd; + } + + longint +#ifdef KR_headers +ftell64_(Unit) integer *Unit; +#else +ftell64_(integer *Unit) +#endif +{ + FILE *f; + return (f = unit_chk(*Unit, "ftell")) ? FTELL(f) : -1L; + } + + int +#ifdef KR_headers +fseek64_(Unit, offset, whence) integer *Unit, *whence; longint *offset; +#else +fseek64_(integer *Unit, longint *offset, integer *whence) +#endif +{ + FILE *f; + int w = (int)*whence; +#ifdef SEEK_SET + static int wohin[3] = { SEEK_SET, SEEK_CUR, SEEK_END }; +#endif + if (w < 0 || w > 2) + w = 0; +#ifdef SEEK_SET + w = wohin[w]; +#endif + return !(f = unit_chk(*Unit, "fseek")) + || FSEEK(f, (OFF_T)*offset, w) ? 1 : 0; + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/ftell_.c b/unix/f2c/libf2c/ftell_.c new file mode 100644 index 00000000..0acd60fe --- /dev/null +++ b/unix/f2c/libf2c/ftell_.c @@ -0,0 +1,52 @@ +#include "f2c.h" +#include "fio.h" +#ifdef __cplusplus +extern "C" { +#endif + + static FILE * +#ifdef KR_headers +unit_chk(Unit, who) integer Unit; char *who; +#else +unit_chk(integer Unit, const char *who) +#endif +{ + if (Unit >= MXUNIT || Unit < 0) + f__fatal(101, who); + return f__units[Unit].ufd; + } + + integer +#ifdef KR_headers +ftell_(Unit) integer *Unit; +#else +ftell_(integer *Unit) +#endif +{ + FILE *f; + return (f = unit_chk(*Unit, "ftell")) ? ftell(f) : -1L; + } + + int +#ifdef KR_headers +fseek_(Unit, offset, whence) integer *Unit, *offset, *whence; +#else +fseek_(integer *Unit, integer *offset, integer *whence) +#endif +{ + FILE *f; + int w = (int)*whence; +#ifdef SEEK_SET + static int wohin[3] = { SEEK_SET, SEEK_CUR, SEEK_END }; +#endif + if (w < 0 || w > 2) + w = 0; +#ifdef SEEK_SET + w = wohin[w]; +#endif + return !(f = unit_chk(*Unit, "fseek")) + || fseek(f, *offset, w) ? 1 : 0; + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/getarg_.c b/unix/f2c/libf2c/getarg_.c new file mode 100644 index 00000000..2b69a1e1 --- /dev/null +++ b/unix/f2c/libf2c/getarg_.c @@ -0,0 +1,36 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +/* + * subroutine getarg(k, c) + * returns the kth unix command argument in fortran character + * variable argument c +*/ + +#ifdef KR_headers +VOID getarg_(n, s, ls) ftnint *n; char *s; ftnlen ls; +#define Const /*nothing*/ +#else +#define Const const +void getarg_(ftnint *n, char *s, ftnlen ls) +#endif +{ + extern int xargc; + extern char **xargv; + Const char *t; + int i; + + if(*n>=0 && *n<xargc) + t = xargv[*n]; + else + t = ""; + for(i = 0; i<ls && *t!='\0' ; ++i) + *s++ = *t++; + for( ; i<ls ; ++i) + *s++ = ' '; + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/getenv_.c b/unix/f2c/libf2c/getenv_.c new file mode 100644 index 00000000..b615a37e --- /dev/null +++ b/unix/f2c/libf2c/getenv_.c @@ -0,0 +1,62 @@ +#include "f2c.h" +#undef abs +#ifdef KR_headers +extern char *F77_aloc(), *getenv(); +#else +#include <stdlib.h> +#include <string.h> +#ifdef __cplusplus +extern "C" { +#endif +extern char *F77_aloc(ftnlen, const char*); +#endif + +/* + * getenv - f77 subroutine to return environment variables + * + * called by: + * call getenv (ENV_NAME, char_var) + * where: + * ENV_NAME is the name of an environment variable + * char_var is a character variable which will receive + * the current value of ENV_NAME, or all blanks + * if ENV_NAME is not defined + */ + +#ifdef KR_headers + VOID +getenv_(fname, value, flen, vlen) char *value, *fname; ftnlen vlen, flen; +#else + void +getenv_(char *fname, char *value, ftnlen flen, ftnlen vlen) +#endif +{ + char buf[256], *ep, *fp; + integer i; + + if (flen <= 0) + goto add_blanks; + for(i = 0; i < sizeof(buf); i++) { + if (i == flen || (buf[i] = fname[i]) == ' ') { + buf[i] = 0; + ep = getenv(buf); + goto have_ep; + } + } + while(i < flen && fname[i] != ' ') + i++; + strncpy(fp = F77_aloc(i+1, "getenv_"), fname, (int)i); + fp[i] = 0; + ep = getenv(fp); + free(fp); + have_ep: + if (ep) + while(*ep && vlen-- > 0) + *value++ = *ep++; + add_blanks: + while(vlen-- > 0) + *value++ = ' '; + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/h_abs.c b/unix/f2c/libf2c/h_abs.c new file mode 100644 index 00000000..db690686 --- /dev/null +++ b/unix/f2c/libf2c/h_abs.c @@ -0,0 +1,18 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +shortint h_abs(x) shortint *x; +#else +shortint h_abs(shortint *x) +#endif +{ +if(*x >= 0) + return(*x); +return(- *x); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/h_dim.c b/unix/f2c/libf2c/h_dim.c new file mode 100644 index 00000000..443427a9 --- /dev/null +++ b/unix/f2c/libf2c/h_dim.c @@ -0,0 +1,16 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +shortint h_dim(a,b) shortint *a, *b; +#else +shortint h_dim(shortint *a, shortint *b) +#endif +{ +return( *a > *b ? *a - *b : 0); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/h_dnnt.c b/unix/f2c/libf2c/h_dnnt.c new file mode 100644 index 00000000..1ec641c5 --- /dev/null +++ b/unix/f2c/libf2c/h_dnnt.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double floor(); +shortint h_dnnt(x) doublereal *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +shortint h_dnnt(doublereal *x) +#endif +{ +return (shortint)(*x >= 0. ? floor(*x + .5) : -floor(.5 - *x)); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/h_indx.c b/unix/f2c/libf2c/h_indx.c new file mode 100644 index 00000000..018f2f43 --- /dev/null +++ b/unix/f2c/libf2c/h_indx.c @@ -0,0 +1,32 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +shortint h_indx(a, b, la, lb) char *a, *b; ftnlen la, lb; +#else +shortint h_indx(char *a, char *b, ftnlen la, ftnlen lb) +#endif +{ +ftnlen i, n; +char *s, *t, *bend; + +n = la - lb + 1; +bend = b + lb; + +for(i = 0 ; i < n ; ++i) + { + s = a + i; + t = b; + while(t < bend) + if(*s++ != *t++) + goto no; + return((shortint)i+1); + no: ; + } +return(0); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/h_len.c b/unix/f2c/libf2c/h_len.c new file mode 100644 index 00000000..8b0aea99 --- /dev/null +++ b/unix/f2c/libf2c/h_len.c @@ -0,0 +1,16 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +shortint h_len(s, n) char *s; ftnlen n; +#else +shortint h_len(char *s, ftnlen n) +#endif +{ +return(n); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/h_mod.c b/unix/f2c/libf2c/h_mod.c new file mode 100644 index 00000000..611ef0aa --- /dev/null +++ b/unix/f2c/libf2c/h_mod.c @@ -0,0 +1,16 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +shortint h_mod(a,b) short *a, *b; +#else +shortint h_mod(short *a, short *b) +#endif +{ +return( *a % *b); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/h_nint.c b/unix/f2c/libf2c/h_nint.c new file mode 100644 index 00000000..9e2282f2 --- /dev/null +++ b/unix/f2c/libf2c/h_nint.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double floor(); +shortint h_nint(x) real *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +shortint h_nint(real *x) +#endif +{ +return (shortint)(*x >= 0 ? floor(*x + .5) : -floor(.5 - *x)); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/h_sign.c b/unix/f2c/libf2c/h_sign.c new file mode 100644 index 00000000..4e214380 --- /dev/null +++ b/unix/f2c/libf2c/h_sign.c @@ -0,0 +1,18 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +shortint h_sign(a,b) shortint *a, *b; +#else +shortint h_sign(shortint *a, shortint *b) +#endif +{ +shortint x; +x = (*a >= 0 ? *a : - *a); +return( *b >= 0 ? x : -x); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/hl_ge.c b/unix/f2c/libf2c/hl_ge.c new file mode 100644 index 00000000..8c72f03d --- /dev/null +++ b/unix/f2c/libf2c/hl_ge.c @@ -0,0 +1,18 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +extern integer s_cmp(); +shortlogical hl_ge(a,b,la,lb) char *a, *b; ftnlen la, lb; +#else +extern integer s_cmp(char *, char *, ftnlen, ftnlen); +shortlogical hl_ge(char *a, char *b, ftnlen la, ftnlen lb) +#endif +{ +return(s_cmp(a,b,la,lb) >= 0); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/hl_gt.c b/unix/f2c/libf2c/hl_gt.c new file mode 100644 index 00000000..a448522d --- /dev/null +++ b/unix/f2c/libf2c/hl_gt.c @@ -0,0 +1,18 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +extern integer s_cmp(); +shortlogical hl_gt(a,b,la,lb) char *a, *b; ftnlen la, lb; +#else +extern integer s_cmp(char *, char *, ftnlen, ftnlen); +shortlogical hl_gt(char *a, char *b, ftnlen la, ftnlen lb) +#endif +{ +return(s_cmp(a,b,la,lb) > 0); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/hl_le.c b/unix/f2c/libf2c/hl_le.c new file mode 100644 index 00000000..31cbc431 --- /dev/null +++ b/unix/f2c/libf2c/hl_le.c @@ -0,0 +1,18 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +extern integer s_cmp(); +shortlogical hl_le(a,b,la,lb) char *a, *b; ftnlen la, lb; +#else +extern integer s_cmp(char *, char *, ftnlen, ftnlen); +shortlogical hl_le(char *a, char *b, ftnlen la, ftnlen lb) +#endif +{ +return(s_cmp(a,b,la,lb) <= 0); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/hl_lt.c b/unix/f2c/libf2c/hl_lt.c new file mode 100644 index 00000000..7ad3c714 --- /dev/null +++ b/unix/f2c/libf2c/hl_lt.c @@ -0,0 +1,18 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +extern integer s_cmp(); +shortlogical hl_lt(a,b,la,lb) char *a, *b; ftnlen la, lb; +#else +extern integer s_cmp(char *, char *, ftnlen, ftnlen); +shortlogical hl_lt(char *a, char *b, ftnlen la, ftnlen lb) +#endif +{ +return(s_cmp(a,b,la,lb) < 0); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/i77vers.c b/unix/f2c/libf2c/i77vers.c new file mode 100644 index 00000000..60cc24ee --- /dev/null +++ b/unix/f2c/libf2c/i77vers.c @@ -0,0 +1,343 @@ + char +_libi77_version_f2c[] = "\n@(#) LIBI77 VERSION (f2c) pjw,dmg-mods 20030321\n"; + +/* +2.01 $ format added +2.02 Coding bug in open.c repaired +2.03 fixed bugs in lread.c (read * with negative f-format) and lio.c + and lio.h (e-format conforming to spec) +2.04 changed open.c and err.c (fopen and freopen respectively) to + update to new c-library (append mode) +2.05 added namelist capability +2.06 allow internal list and namelist I/O +*/ + +/* +close.c: + allow upper-case STATUS= values +endfile.c + create fort.nnn if unit nnn not open; + else if (file length == 0) use creat() rather than copy; + use local copy() rather than forking /bin/cp; + rewind, fseek to clear buffer (for no reading past EOF) +err.c + use neither setbuf nor setvbuf; make stderr buffered +fio.h + #define _bufend +inquire.c + upper case responses; + omit byfile test from SEQUENTIAL= + answer "YES" to DIRECT= for unopened file (open to debate) +lio.c + flush stderr, stdout at end of each stmt + space before character strings in list output only at line start +lio.h + adjust LEW, LED consistent with old libI77 +lread.c + use atof() + allow "nnn*," when reading complex constants +open.c + try opening for writing when open for read fails, with + special uwrt value (2) delaying creat() to first write; + set curunit so error messages don't drop core; + no file name ==> fort.nnn except for STATUS='SCRATCH' +rdfmt.c + use atof(); trust EOF == end-of-file (so don't read past + end-of-file after endfile stmt) +sfe.c + flush stderr, stdout at end of each stmt +wrtfmt.c: + use upper case + put wrt_E and wrt_F into wref.c, use sprintf() + rather than ecvt() and fcvt() [more accurate on VAX] +*/ + +/* 16 Oct. 1988: uwrt = 3 after write, rewind, so close won't zap the file. */ + +/* 10 July 1989: change _bufend to buf_end in fio.h, wsfe.c, wrtfmt.c */ + +/* 28 Nov. 1989: corrections for IEEE and Cray arithmetic */ +/* 29 Nov. 1989: change various int return types to long for f2c */ +/* 30 Nov. 1989: various types from f2c.h */ +/* 6 Dec. 1989: types corrected various places */ +/* 19 Dec. 1989: make iostat= work right for internal I/O */ +/* 8 Jan. 1990: add rsne, wsne -- routines for handling NAMELIST */ +/* 28 Jan. 1990: have NAMELIST read treat $ as &, general white + space as blank */ +/* 27 Mar. 1990: change an = to == in rd_L(rdfmt.c) so formatted reads + of logical values reject letters other than fFtT; + have nowwriting reset cf */ +/* 14 Aug. 1990: adjust lread.c to treat tabs as spaces in list input */ +/* 17 Aug. 1990: adjust open.c to recognize blank='Z...' as well as + blank='z...' when reopening an open file */ +/* 30 Aug. 1990: 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. */ +/* 18 Sep. 1990: add component udev to unit and consider old == new file + iff uinode and udev values agree; use stat rather than + access to check existence of file (when STATUS='OLD')*/ +/* 2 Oct. 1990: adjust rewind.c so two successive rewinds after a write + don't clobber the file. */ +/* 9 Oct. 1990: add #include "fcntl.h" to endfile.c, err.c, open.c; + adjust g_char in util.c for segmented memories. */ +/* 17 Oct. 1990: replace abort() and _cleanup() with calls on + sig_die(...,1) (defined in main.c). */ +/* 5 Nov. 1990: changes to open.c: complain if new= is specified and the + file already exists; allow file= to be omitted in open stmts + and allow status='replace' (Fortran 90 extensions). */ +/* 11 Dec. 1990: adjustments for POSIX. */ +/* 15 Jan. 1991: tweak i_ungetc in rsli.c to allow reading from + strings in read-only memory. */ +/* 25 Apr. 1991: adjust namelist stuff to work with f2c -i2 */ +/* 26 Apr. 1991: fix some bugs with NAMELIST read of multi-dim. arrays */ +/* 16 May 1991: increase LEFBL in lio.h to bypass NeXT bug */ +/* 17 Oct. 1991: change type of length field in sequential unformatted + records from int to long (for systems where sizeof(int) + can vary, depending on the compiler or compiler options). */ +/* 14 Nov. 1991: change uint to Uint in fmt.h, rdfmt.c, wrtfmt.c. */ +/* 25 Nov. 1991: change uint to Uint in lwrite.c; change sizeof(int) to + sizeof(uioint) in fseeks in sue.c (missed on 17 Oct.). */ +/* 1 Dec. 1991: uio.c: add test for read failure (seq. unformatted reads); + adjust an error return from EOF to off end of record */ +/* 12 Dec. 1991: rsli.c: fix bug with internal list input that caused + the last character of each record to be ignored. + iio.c: 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. */ +/* 17 Jan. 1992: lread.c, rsne.c: 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); 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). + lio.h, lwrite.c: omit insignificant zeros in + list and namelist output. To get the old + behavior, compile with -DOld_list_output . */ +/* 18 Jan. 1992: make list output consistent with F format by + printing .1 rather than 0.1 (introduced yesterday). */ +/* 3 Feb. 1992: rsne.c: fix namelist read bug that caused the + character following a comma to be ignored. */ +/* 19 May 1992: adjust iio.c, ilnw.c, rdfmt.c and rsli.c to make err= + work with internal list and formatted I/O. */ +/* 18 July 1992: adjust rsne.c to allow namelist input to stop at + an & (e.g. &end). */ +/* 23 July 1992: switch to ANSI prototypes unless KR_headers is #defined ; + recognize Z format (assuming 8-bit bytes). */ +/* 14 Aug. 1992: tweak wrt_E in wref.c to avoid -NaN */ +/* 23 Oct. 1992: 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). Prepend f__ to external + names that are only of internal interest to lib[FI]77. */ +/* 1 Feb. 1993: backspace.c: fix bug that bit when last char of 2nd + buffer == '\n'. + endfile.c: guard against tiny L_tmpnam; close and reopen + files in t_runc(). + lio.h: lengthen LINTW (buffer size in lwrite.c). + err.c, open.c: more prepending of f__ (to [rw]_mode). */ +/* 5 Feb. 1993: tweaks to NAMELIST: rsne.c: ? prints the namelist being + sought; namelists of the wrong name are skipped (after + an error message; xwsne.c: namelist writes have a + newline before each new variable. + open.c: ACCESS='APPEND' positions sequential files + at EOF (nonstandard extension -- that doesn't require + changing data structures). */ +/* 9 Feb. 1993: Change some #ifdef MSDOS lines to #ifdef NON_UNIX_STDIO. + err.c: under NON_UNIX_STDIO, avoid close(creat(name,0666)) + when the unit has another file descriptor for name. */ +/* 4 March 1993: err.c, open.c: take declaration of fdopen from rawio.h; + open.c: always give f__w_mode[] 4 elements for use + in t_runc (in endfile.c -- for change of 1 Feb. 1993). */ +/* 6 March 1993: uio.c: adjust off-end-of-record test for sequential + unformatted reads to respond to err= rather than end=. */ +/* 12 March 1993: various tweaks for C++ */ +/* 6 April 1993: adjust error returns for formatted inputs to flush + the current input line when err=label 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). */ +/* 23 June 1993: iio.c: fix bug in format reversions for internal writes. */ +/* 5 Aug. 1993: 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). */ +/* 7 Aug. 1993: lread.c: fix bug in namelist reading of incomplete + logical arrays. */ +/* 9 Aug. 1993: 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'. */ +/* 8 Sept. 1993: open.c: protect #include "sys/..." with + #ifndef NON_UNIX_STDIO; Version date not changed. */ +/* 10 Nov. 1993: backspace.c: add nonsense for #ifdef MSDOS */ +/* 8 Dec. 1993: iio.c: adjust internal formatted reads to treat + short records as though padded with blanks + (rather than causing an "off end of record" error). */ +/* 22 Feb. 1994: lread.c: check that realloc did not return NULL. */ +/* 6 June 1994: Under NON_UNIX_STDIO, use binary mode for direct + formatted files (avoiding any confusion regarding \n). */ +/* 5 July 1994: Fix bug (introduced 6 June 1994?) in reopening files + under NON_UNIX_STDIO. */ +/* 6 July 1994: 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. */ +/* 12 July 1994: wrtfmt.c: under G11.4, write 0. as " .0000 " rather + than " .0000E+00". */ +/* 3 Aug. 1994: lwrite.c: do not insert a newline when appending an + oversize item to an empty line. */ +/* 12 Aug. 1994: rsli.c rsne.c: fix glitch (reset nml_read) that kept + ERR= (in list- or format-directed input) from working + after a NAMELIST READ. */ +/* 7 Sept. 1994: typesize.c: adjust to allow types LOGICAL*1, LOGICAL*2, + INTEGER*1, and (under -DAllow_TYQUAD) INTEGER*8 + in NAMELISTs. */ +/* 6 Oct. 1994: util.c: omit f__mvgbt, as it is never used. */ +/* 2 Nov. 1994: add #ifdef ALWAYS_FLUSH logic. */ +/* 26 Jan. 1995: wref.c: fix glitch in printing the exponent of 0 when + GOOD_SPRINTF_EXPONENT is not #defined. */ +/* 24 Feb. 1995: iio.c: z_getc: insert (unsigned char *) to allow + internal reading of characters with high-bit set + (on machines that sign-extend characters). */ +/* 14 March 1995: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). */ +/* 26 May 1995: 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. */ +/* 29 Aug. 1995: backspace.c: adjust MSDOS logic. */ +/* 6 Sept. 1995: 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). Adjust f_init calls + for people who don't use libF77's main(); now open and + namelist read statements invoke f_init if needed. */ +/* 7 Sept. 1995: Fix some bugs with -DAllow_TYQUAD (for integer*8). + Add -DNo_Namelist_Comments lines to rsne.c. */ +/* 5 Oct. 1995: wrtfmt.c: fix bug with t editing (f__cursor was not + always zeroed in mv_cur). */ +/* 11 Oct. 1995: move defs of f__hiwater, f__svic, f__icptr from wrtfmt.c + to err.c */ +/* 15 Mar. 1996: lread.c, rsfe.c: honor END= in READ stmt with empty iolist */ + +/* 13 May 1996: add ftell_.c and fseek_.c */ +/* 9 June 1996: Adjust rsli.c and lread.c so internal list input with + too few items in the input string will honor end= . */ +/* 12 Sept. 1995:fmtlib.c: fix glitch in printing the most negative integer. */ +/* 25 Sept. 1995: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. */ +/* 9 Dec. 1996: d[fu]e.c, err.c: complain about non-positive rec= + in direct read and write statements. + ftell_.c: change param "unit" to "Unit" for -DKR_headers. */ +/* 26 Feb. 1997: ftell_.c: on systems that define SEEK_SET, etc., use + SEEK_SET, SEEK_CUR, SEEK_END for *whence = 0, 1, 2. */ +/* 7 Apr. 1997: fmt.c: adjust to complain at missing numbers in formats + (but still treat missing ".nnn" as ".0"). */ +/* 11 Apr. 1997: err.c: attempt to make stderr line buffered rather + than fully buffered. (Buffering is needed for format + items T and TR.) */ +/* 27 May 1997: ftell_.c: fix typo (that caused the third argument to be + treated as 2 on some systems). */ +/* 5 Aug. 1997: lread.c: adjust to accord with a change to the Fortran 8X + draft (in 1990 or 1991) that rescinded permission to elide + quote marks in namelist input of character data; compile + with -DF8X_NML_ELIDE_QUOTES to get the old behavior. + wrtfmt.o: wrt_G: tweak to print the right number of 0's + for zero under G format. */ +/* 16 Aug. 1997: iio.c: fix bug in internal writes to an array of character + strings that sometimes caused one more array element than + required by the format to be blank-filled. Example: + format(1x). */ +/* 16 Sept. 1997:fmt.[ch] rdfmt.c wrtfmt.c: tweak struct syl for machines + with 64-bit pointers and 32-bit ints that did not 64-bit + align struct syl (e.g., Linux on the DEC Alpha). */ +/* 19 Jan. 1998: backspace.c: for b->ufmt==0, change sizeof(int) to + sizeof(uiolen). On machines where this would make a + difference, it is best for portability to compile libI77 with + -DUIOLEN_int (which will render the change invisible). */ +/* 4 March 1998: open.c: fix glitch in comparing file names under + -DNON_UNIX_STDIO */ +/* 17 March 1998: endfile.c, open.c: acquire temporary files from tmpfile(), + unless compiled with -DNON_ANSI_STDIO, which uses mktemp(). + New buffering scheme independent of NON_UNIX_STDIO for + handling T format items. Now -DNON_UNIX_STDIO is no + longer be necessary for Linux, and libf2c no longer + causes stderr to be buffered -- the former setbuf or + setvbuf call for stderr was to make T format items work. + open.c: use the Posix access() function to check existence + or nonexistence of files, except under -DNON_POSIX_STDIO, + where trial fopen calls are used. */ +/* 5 April 1998: wsfe.c: make $ format item work: this was lost in the + changes of 17 March 1998. */ +/* 28 May 1998: backspace.c dfe.c due.c iio.c lread.c rsfe.c sue.c wsfe.c: + set f__curunit sooner so various error messages will + correctly identify the I/O unit involved. */ +/* 17 June 1998: lread.c: unless compiled with + ALLOW_FLOAT_IN_INTEGER_LIST_INPUT #defined, treat + floating-point numbers (containing either a decimal point + or an exponent field) as errors when they appear as list + input for integer data. */ +/* 7 Sept. 1998: move e_wdfe from sfe.c to dfe.c, where it was originally. + Why did it ever move to sfe.c? */ +/* 2 May 1999: open.c: set f__external (to get "external" versus "internal" + right in the error message if we cannot open the file). + 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. */ +/* 3 May 1999: open.c: insert two casts for machines with 64-bit longs. */ +/* 18 June 1999: backspace.c: allow for b->ufd changing in t_runc */ +/* 27 June 1999: 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) */ +/* 15 Nov. 1999: endfile.c: set state to writing (b->uwrt = 1) when an */ +/* endfile statement requires copying the file. */ +/* (Otherwise an immediately following rewind statement */ +/* could make the file appear empty.) Also, supply a */ +/* missing (long) cast in the sprintf call. */ +/* sfe.c: add #ifdef ALWAYS_FLUSH logic, for formatted I/O: */ +/* Compiling libf2c with -DALWAYS_FLUSH should prevent losing */ +/* any data in buffers should the program fault. It also */ +/* makes the program run more slowly. */ +/* 20 April 2000: rsne.c, xwsne.c: tweaks that only matter if ftnint and */ +/* ftnlen are of different fundamental types (different numbers */ +/* of bits). Since these files will not compile when this */ +/* change matters, the above VERSION string remains unchanged. */ +/* 4 July 2000: adjustments to permit compilation by C++ compilers; */ +/* VERSION string remains unchanged. */ +/* 5 Dec. 2000: lread.c: under namelist input, when reading a logical array, */ +/* treat Tstuff= and Fstuff= as new assignments rather than as */ +/* logical constants. */ +/* 22 Feb. 2001: endfile.c: adjust to use truncate() unless compiled with */ +/* -DNO_TRUNCATE (or with -DMSDOS). */ +/* 1 March 2001: 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. */ +/* 11 Oct. 2001: backspac.c dfe.c due.c endfile.c err.c fio.h fmt.c fmt.h */ +/* inquire.c open.c rdfmt.c sue.c util.c: change fseek and */ +/* ftell to FSEEK and FTELL (#defined to be fseek and ftell, */ +/* respectively, in fio.h unless otherwise #defined), and use */ +/* type OFF_T (#defined to be long unless otherwise #defined) */ +/* 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). */ +/* 15 Nov. 2001: endfile.c: add FSEEK after FTRUNCATE. */ +/* 28 Nov. 2001: fmt.h lwrite.c wref.c and (new) signbit.c: on IEEE systems, */ +/* print -0 as -0 when compiled with -DSIGNED_ZEROS. See */ +/* comments in makefile or (better) libf2c/makefile.* . */ +/* 6 Sept. 2002: 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 / */ +/* 21 March 2003: err.c: before writing to a file after reading from it, */ +/* f_seek(file, 0, SEEK_CUR) to make writing legal in ANSI C. */ diff --git a/unix/f2c/libf2c/i_abs.c b/unix/f2c/libf2c/i_abs.c new file mode 100644 index 00000000..2b92c4aa --- /dev/null +++ b/unix/f2c/libf2c/i_abs.c @@ -0,0 +1,18 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +integer i_abs(x) integer *x; +#else +integer i_abs(integer *x) +#endif +{ +if(*x >= 0) + return(*x); +return(- *x); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/i_dim.c b/unix/f2c/libf2c/i_dim.c new file mode 100644 index 00000000..60ed4d8c --- /dev/null +++ b/unix/f2c/libf2c/i_dim.c @@ -0,0 +1,16 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +integer i_dim(a,b) integer *a, *b; +#else +integer i_dim(integer *a, integer *b) +#endif +{ +return( *a > *b ? *a - *b : 0); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/i_dnnt.c b/unix/f2c/libf2c/i_dnnt.c new file mode 100644 index 00000000..3abc2dc4 --- /dev/null +++ b/unix/f2c/libf2c/i_dnnt.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double floor(); +integer i_dnnt(x) doublereal *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +integer i_dnnt(doublereal *x) +#endif +{ +return (integer)(*x >= 0. ? floor(*x + .5) : -floor(.5 - *x)); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/i_indx.c b/unix/f2c/libf2c/i_indx.c new file mode 100644 index 00000000..19256393 --- /dev/null +++ b/unix/f2c/libf2c/i_indx.c @@ -0,0 +1,32 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +integer i_indx(a, b, la, lb) char *a, *b; ftnlen la, lb; +#else +integer i_indx(char *a, char *b, ftnlen la, ftnlen lb) +#endif +{ +ftnlen i, n; +char *s, *t, *bend; + +n = la - lb + 1; +bend = b + lb; + +for(i = 0 ; i < n ; ++i) + { + s = a + i; + t = b; + while(t < bend) + if(*s++ != *t++) + goto no; + return(i+1); + no: ; + } +return(0); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/i_len.c b/unix/f2c/libf2c/i_len.c new file mode 100644 index 00000000..0f7b188d --- /dev/null +++ b/unix/f2c/libf2c/i_len.c @@ -0,0 +1,16 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +integer i_len(s, n) char *s; ftnlen n; +#else +integer i_len(char *s, ftnlen n) +#endif +{ +return(n); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/i_mod.c b/unix/f2c/libf2c/i_mod.c new file mode 100644 index 00000000..4a9b5609 --- /dev/null +++ b/unix/f2c/libf2c/i_mod.c @@ -0,0 +1,16 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +integer i_mod(a,b) integer *a, *b; +#else +integer i_mod(integer *a, integer *b) +#endif +{ +return( *a % *b); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/i_nint.c b/unix/f2c/libf2c/i_nint.c new file mode 100644 index 00000000..fe9fd68a --- /dev/null +++ b/unix/f2c/libf2c/i_nint.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double floor(); +integer i_nint(x) real *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +integer i_nint(real *x) +#endif +{ +return (integer)(*x >= 0 ? floor(*x + .5) : -floor(.5 - *x)); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/i_sign.c b/unix/f2c/libf2c/i_sign.c new file mode 100644 index 00000000..4c20e949 --- /dev/null +++ b/unix/f2c/libf2c/i_sign.c @@ -0,0 +1,18 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +integer i_sign(a,b) integer *a, *b; +#else +integer i_sign(integer *a, integer *b) +#endif +{ +integer x; +x = (*a >= 0 ? *a : - *a); +return( *b >= 0 ? x : -x); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/iargc_.c b/unix/f2c/libf2c/iargc_.c new file mode 100644 index 00000000..2f29da0e --- /dev/null +++ b/unix/f2c/libf2c/iargc_.c @@ -0,0 +1,17 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +ftnint iargc_() +#else +ftnint iargc_(void) +#endif +{ +extern int xargc; +return ( xargc - 1 ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/iio.c b/unix/f2c/libf2c/iio.c new file mode 100644 index 00000000..8553efcf --- /dev/null +++ b/unix/f2c/libf2c/iio.c @@ -0,0 +1,159 @@ +#include "f2c.h" +#include "fio.h" +#include "fmt.h" +#ifdef __cplusplus +extern "C" { +#endif +extern char *f__icptr; +char *f__icend; +extern icilist *f__svic; +int f__icnum; + + int +z_getc(Void) +{ + if(f__recpos++ < f__svic->icirlen) { + if(f__icptr >= f__icend) err(f__svic->iciend,(EOF),"endfile"); + return(*(unsigned char *)f__icptr++); + } + return '\n'; +} + + void +#ifdef KR_headers +z_putc(c) +#else +z_putc(int c) +#endif +{ + if (f__icptr < f__icend && f__recpos++ < f__svic->icirlen) + *f__icptr++ = c; +} + + int +z_rnew(Void) +{ + f__icptr = f__svic->iciunit + (++f__icnum)*f__svic->icirlen; + f__recpos = 0; + f__cursor = 0; + f__hiwater = 0; + return 1; +} + + static int +z_endp(Void) +{ + (*f__donewrec)(); + return 0; + } + + int +#ifdef KR_headers +c_si(a) icilist *a; +#else +c_si(icilist *a) +#endif +{ + f__elist = (cilist *)a; + f__fmtbuf=a->icifmt; + f__curunit = 0; + f__sequential=f__formatted=1; + f__external=0; + if(pars_f(f__fmtbuf)<0) + err(a->icierr,100,"startint"); + fmt_bg(); + f__cblank=f__cplus=f__scale=0; + f__svic=a; + f__icnum=f__recpos=0; + f__cursor = 0; + f__hiwater = 0; + f__icptr = a->iciunit; + f__icend = f__icptr + a->icirlen*a->icirnum; + f__cf = 0; + return(0); +} + + int +iw_rev(Void) +{ + if(f__workdone) + z_endp(); + f__hiwater = f__recpos = f__cursor = 0; + return(f__workdone=0); + } + +#ifdef KR_headers +integer s_rsfi(a) icilist *a; +#else +integer s_rsfi(icilist *a) +#endif +{ int n; + if(n=c_si(a)) return(n); + f__reading=1; + f__doed=rd_ed; + f__doned=rd_ned; + f__getn=z_getc; + f__dorevert = z_endp; + f__donewrec = z_rnew; + f__doend = z_endp; + return(0); +} + + int +z_wnew(Void) +{ + if (f__recpos < f__hiwater) { + f__icptr += f__hiwater - f__recpos; + f__recpos = f__hiwater; + } + while(f__recpos++ < f__svic->icirlen) + *f__icptr++ = ' '; + f__recpos = 0; + f__cursor = 0; + f__hiwater = 0; + f__icnum++; + return 1; +} +#ifdef KR_headers +integer s_wsfi(a) icilist *a; +#else +integer s_wsfi(icilist *a) +#endif +{ int n; + if(n=c_si(a)) return(n); + f__reading=0; + f__doed=w_ed; + f__doned=w_ned; + f__putn=z_putc; + f__dorevert = iw_rev; + f__donewrec = z_wnew; + f__doend = z_endp; + return(0); +} +integer e_rsfi(Void) +{ int n = en_fio(); + f__fmtbuf = NULL; + return(n); +} +integer e_wsfi(Void) +{ + int n; + n = en_fio(); + f__fmtbuf = NULL; + if(f__svic->icirnum != 1 + && (f__icnum > f__svic->icirnum + || (f__icnum == f__svic->icirnum && (f__recpos | f__hiwater)))) + err(f__svic->icierr,110,"inwrite"); + if (f__recpos < f__hiwater) + f__recpos = f__hiwater; + if (f__recpos >= f__svic->icirlen) + err(f__svic->icierr,110,"recend"); + if (!f__recpos && f__icnum) + return n; + while(f__recpos++ < f__svic->icirlen) + *f__icptr++ = ' '; + return n; +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/ilnw.c b/unix/f2c/libf2c/ilnw.c new file mode 100644 index 00000000..e8b3d49c --- /dev/null +++ b/unix/f2c/libf2c/ilnw.c @@ -0,0 +1,83 @@ +#include "f2c.h" +#include "fio.h" +#include "lio.h" +#ifdef __cplusplus +extern "C" { +#endif +extern char *f__icptr; +extern char *f__icend; +extern icilist *f__svic; +extern int f__icnum; +#ifdef KR_headers +extern void z_putc(); +#else +extern void z_putc(int); +#endif + + static int +z_wSL(Void) +{ + while(f__recpos < f__svic->icirlen) + z_putc(' '); + return z_rnew(); + } + + static void +#ifdef KR_headers +c_liw(a) icilist *a; +#else +c_liw(icilist *a) +#endif +{ + f__reading = 0; + f__external = 0; + f__formatted = 1; + f__putn = z_putc; + L_len = a->icirlen; + f__donewrec = z_wSL; + f__svic = a; + f__icnum = f__recpos = 0; + f__cursor = 0; + f__cf = 0; + f__curunit = 0; + f__icptr = a->iciunit; + f__icend = f__icptr + a->icirlen*a->icirnum; + f__elist = (cilist *)a; + } + + integer +#ifdef KR_headers +s_wsni(a) icilist *a; +#else +s_wsni(icilist *a) +#endif +{ + cilist ca; + + c_liw(a); + ca.cifmt = a->icifmt; + x_wsne(&ca); + z_wSL(); + return 0; + } + + integer +#ifdef KR_headers +s_wsli(a) icilist *a; +#else +s_wsli(icilist *a) +#endif +{ + f__lioproc = l_write; + c_liw(a); + return(0); + } + +integer e_wsli(Void) +{ + z_wSL(); + return(0); + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/inquire.c b/unix/f2c/libf2c/inquire.c new file mode 100644 index 00000000..5936a674 --- /dev/null +++ b/unix/f2c/libf2c/inquire.c @@ -0,0 +1,117 @@ +#include "f2c.h" +#include "fio.h" +#include "string.h" +#ifdef NON_UNIX_STDIO +#ifndef MSDOS +#include "unistd.h" /* for access() */ +#endif +#endif +#ifdef KR_headers +integer f_inqu(a) inlist *a; +#else +#ifdef __cplusplus +extern "C" integer f_inqu(inlist*); +#endif +#ifdef MSDOS +#undef abs +#undef min +#undef max +#include "io.h" +#endif +integer f_inqu(inlist *a) +#endif +{ flag byfile; + int i; +#ifndef NON_UNIX_STDIO + int n; +#endif + unit *p; + char buf[256]; + long x; + if(a->infile!=NULL) + { byfile=1; + g_char(a->infile,a->infilen,buf); +#ifdef NON_UNIX_STDIO + x = access(buf,0) ? -1 : 0; + for(i=0,p=NULL;i<MXUNIT;i++) + if(f__units[i].ufd != NULL + && f__units[i].ufnm != NULL + && !strcmp(f__units[i].ufnm,buf)) { + p = &f__units[i]; + break; + } +#else + x=f__inode(buf, &n); + for(i=0,p=NULL;i<MXUNIT;i++) + if(f__units[i].uinode==x + && f__units[i].ufd!=NULL + && f__units[i].udev == n) { + p = &f__units[i]; + break; + } +#endif + } + else + { + byfile=0; + if(a->inunit<MXUNIT && a->inunit>=0) + { + p= &f__units[a->inunit]; + } + else + { + p=NULL; + } + } + if(a->inex!=NULL) + if(byfile && x != -1 || !byfile && p!=NULL) + *a->inex=1; + else *a->inex=0; + if(a->inopen!=NULL) + if(byfile) *a->inopen=(p!=NULL); + else *a->inopen=(p!=NULL && p->ufd!=NULL); + if(a->innum!=NULL) *a->innum= p-f__units; + if(a->innamed!=NULL) + if(byfile || p!=NULL && p->ufnm!=NULL) + *a->innamed=1; + else *a->innamed=0; + if(a->inname!=NULL) + if(byfile) + b_char(buf,a->inname,a->innamlen); + else if(p!=NULL && p->ufnm!=NULL) + b_char(p->ufnm,a->inname,a->innamlen); + if(a->inacc!=NULL && p!=NULL && p->ufd!=NULL) + if(p->url) + b_char("DIRECT",a->inacc,a->inacclen); + else b_char("SEQUENTIAL",a->inacc,a->inacclen); + if(a->inseq!=NULL) + if(p!=NULL && p->url) + b_char("NO",a->inseq,a->inseqlen); + else b_char("YES",a->inseq,a->inseqlen); + if(a->indir!=NULL) + if(p==NULL || p->url) + b_char("YES",a->indir,a->indirlen); + else b_char("NO",a->indir,a->indirlen); + if(a->infmt!=NULL) + if(p!=NULL && p->ufmt==0) + b_char("UNFORMATTED",a->infmt,a->infmtlen); + else b_char("FORMATTED",a->infmt,a->infmtlen); + if(a->inform!=NULL) + if(p!=NULL && p->ufmt==0) + b_char("NO",a->inform,a->informlen); + else b_char("YES",a->inform,a->informlen); + if(a->inunf) + if(p!=NULL && p->ufmt==0) + b_char("YES",a->inunf,a->inunflen); + else if (p!=NULL) b_char("NO",a->inunf,a->inunflen); + else b_char("UNKNOWN",a->inunf,a->inunflen); + if(a->inrecl!=NULL && p!=NULL) + *a->inrecl=p->url; + if(a->innrec!=NULL && p!=NULL && p->url>0) + *a->innrec=(ftnint)(FTELL(p->ufd)/p->url+1); + if(a->inblank && p!=NULL && p->ufmt) + if(p->ublnk) + b_char("ZERO",a->inblank,a->inblanklen); + else b_char("NULL",a->inblank,a->inblanklen); + return(0); +} diff --git a/unix/f2c/libf2c/l_ge.c b/unix/f2c/libf2c/l_ge.c new file mode 100644 index 00000000..a84f0ee4 --- /dev/null +++ b/unix/f2c/libf2c/l_ge.c @@ -0,0 +1,18 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +extern integer s_cmp(); +logical l_ge(a,b,la,lb) char *a, *b; ftnlen la, lb; +#else +extern integer s_cmp(char *, char *, ftnlen, ftnlen); +logical l_ge(char *a, char *b, ftnlen la, ftnlen lb) +#endif +{ +return(s_cmp(a,b,la,lb) >= 0); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/l_gt.c b/unix/f2c/libf2c/l_gt.c new file mode 100644 index 00000000..ae6950d1 --- /dev/null +++ b/unix/f2c/libf2c/l_gt.c @@ -0,0 +1,18 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +extern integer s_cmp(); +logical l_gt(a,b,la,lb) char *a, *b; ftnlen la, lb; +#else +extern integer s_cmp(char *, char *, ftnlen, ftnlen); +logical l_gt(char *a, char *b, ftnlen la, ftnlen lb) +#endif +{ +return(s_cmp(a,b,la,lb) > 0); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/l_le.c b/unix/f2c/libf2c/l_le.c new file mode 100644 index 00000000..625b49a9 --- /dev/null +++ b/unix/f2c/libf2c/l_le.c @@ -0,0 +1,18 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +extern integer s_cmp(); +logical l_le(a,b,la,lb) char *a, *b; ftnlen la, lb; +#else +extern integer s_cmp(char *, char *, ftnlen, ftnlen); +logical l_le(char *a, char *b, ftnlen la, ftnlen lb) +#endif +{ +return(s_cmp(a,b,la,lb) <= 0); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/l_lt.c b/unix/f2c/libf2c/l_lt.c new file mode 100644 index 00000000..ab21b362 --- /dev/null +++ b/unix/f2c/libf2c/l_lt.c @@ -0,0 +1,18 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +extern integer s_cmp(); +logical l_lt(a,b,la,lb) char *a, *b; ftnlen la, lb; +#else +extern integer s_cmp(char *, char *, ftnlen, ftnlen); +logical l_lt(char *a, char *b, ftnlen la, ftnlen lb) +#endif +{ +return(s_cmp(a,b,la,lb) < 0); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/lbitbits.c b/unix/f2c/libf2c/lbitbits.c new file mode 100644 index 00000000..5b6ccf72 --- /dev/null +++ b/unix/f2c/libf2c/lbitbits.c @@ -0,0 +1,68 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifndef LONGBITS +#define LONGBITS 32 +#endif + + integer +#ifdef KR_headers +lbit_bits(a, b, len) integer a, b, len; +#else +lbit_bits(integer a, integer b, integer len) +#endif +{ + /* Assume 2's complement arithmetic */ + + unsigned long x, y; + + x = (unsigned long) a; + y = (unsigned long)-1L; + x >>= b; + y <<= len; + return (integer)(x & ~y); + } + + integer +#ifdef KR_headers +lbit_cshift(a, b, len) integer a, b, len; +#else +lbit_cshift(integer a, integer b, integer len) +#endif +{ + unsigned long x, y, z; + + x = (unsigned long)a; + if (len <= 0) { + if (len == 0) + return 0; + goto full_len; + } + if (len >= LONGBITS) { + full_len: + if (b >= 0) { + b %= LONGBITS; + return (integer)(x << b | x >> LONGBITS -b ); + } + b = -b; + b %= LONGBITS; + return (integer)(x << LONGBITS - b | x >> b); + } + y = z = (unsigned long)-1; + y <<= len; + z &= ~y; + y &= x; + x &= z; + if (b >= 0) { + b %= len; + return (integer)(y | z & (x << b | x >> len - b)); + } + b = -b; + b %= len; + return (integer)(y | z & (x >> b | x << len - b)); + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/lbitshft.c b/unix/f2c/libf2c/lbitshft.c new file mode 100644 index 00000000..fbee94f1 --- /dev/null +++ b/unix/f2c/libf2c/lbitshft.c @@ -0,0 +1,17 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + + integer +#ifdef KR_headers +lbit_shift(a, b) integer a; integer b; +#else +lbit_shift(integer a, integer b) +#endif +{ + return b >= 0 ? a << b : (integer)((uinteger)a >> -b); + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/libf2c.lbc b/unix/f2c/libf2c/libf2c.lbc new file mode 100644 index 00000000..c51c0aab --- /dev/null +++ b/unix/f2c/libf2c/libf2c.lbc @@ -0,0 +1,153 @@ +abort_.obj +backspac.obj +c_abs.obj +c_cos.obj +c_div.obj +c_exp.obj +c_log.obj +c_sin.obj +c_sqrt.obj +cabs.obj +close.obj +d_abs.obj +d_acos.obj +d_asin.obj +d_atan.obj +d_atn2.obj +d_cnjg.obj +d_cos.obj +d_cosh.obj +d_dim.obj +d_exp.obj +d_imag.obj +d_int.obj +d_lg10.obj +d_log.obj +d_mod.obj +d_nint.obj +d_prod.obj +d_sign.obj +d_sin.obj +d_sinh.obj +d_sqrt.obj +d_tan.obj +d_tanh.obj +derf_.obj +derfc_.obj +dfe.obj +dolio.obj +dtime_.obj +due.obj +ef1asc_.obj +ef1cmc_.obj +endfile.obj +erf_.obj +erfc_.obj +err.obj +etime_.obj +exit_.obj +f77_aloc.obj +f77vers.obj +fmt.obj +fmtlib.obj +ftell_.obj +getarg_.obj +getenv_.obj +h_abs.obj +h_dim.obj +h_dnnt.obj +h_indx.obj +h_len.obj +h_mod.obj +h_nint.obj +h_sign.obj +hl_ge.obj +hl_gt.obj +hl_le.obj +hl_lt.obj +i77vers.obj +i_abs.obj +i_dim.obj +i_dnnt.obj +i_indx.obj +i_len.obj +i_mod.obj +i_nint.obj +i_sign.obj +iargc_.obj +iio.obj +ilnw.obj +inquire.obj +l_ge.obj +l_gt.obj +l_le.obj +l_lt.obj +lbitbits.obj +lbitshft.obj +lread.obj +lwrite.obj +main.obj +open.obj +pow_ci.obj +pow_dd.obj +pow_di.obj +pow_hh.obj +pow_ii.obj +pow_ri.obj +pow_zi.obj +pow_zz.obj +r_abs.obj +r_acos.obj +r_asin.obj +r_atan.obj +r_atn2.obj +r_cnjg.obj +r_cos.obj +r_cosh.obj +r_dim.obj +r_exp.obj +r_imag.obj +r_int.obj +r_lg10.obj +r_log.obj +r_mod.obj +r_nint.obj +r_sign.obj +r_sin.obj +r_sinh.obj +r_sqrt.obj +r_tan.obj +r_tanh.obj +rdfmt.obj +rewind.obj +rsfe.obj +rsli.obj +rsne.obj +s_cat.obj +s_cmp.obj +s_copy.obj +s_paus.obj +s_rnge.obj +s_stop.obj +sfe.obj +sig_die.obj +signal_.obj +sue.obj +system_.obj +typesize.obj +uio.obj +uninit.obj +util.obj +wref.obj +wrtfmt.obj +wsfe.obj +wsle.obj +wsne.obj +xwsne.obj +z_abs.obj +z_cos.obj +z_div.obj +z_exp.obj +z_log.obj +z_sin.obj +z_sqrt.obj diff --git a/unix/f2c/libf2c/libf2c.sy b/unix/f2c/libf2c/libf2c.sy new file mode 100644 index 00000000..bcba643b --- /dev/null +++ b/unix/f2c/libf2c/libf2c.sy @@ -0,0 +1,153 @@ ++abort_.obj & ++backspac.obj & ++c_abs.obj & ++c_cos.obj & ++c_div.obj & ++c_exp.obj & ++c_log.obj & ++c_sin.obj & ++c_sqrt.obj & ++cabs.obj & ++close.obj & ++d_abs.obj & ++d_acos.obj & ++d_asin.obj & ++d_atan.obj & ++d_atn2.obj & ++d_cnjg.obj & ++d_cos.obj & ++d_cosh.obj & ++d_dim.obj & ++d_exp.obj & ++d_imag.obj & ++d_int.obj & ++d_lg10.obj & ++d_log.obj & ++d_mod.obj & ++d_nint.obj & ++d_prod.obj & ++d_sign.obj & ++d_sin.obj & ++d_sinh.obj & ++d_sqrt.obj & ++d_tan.obj & ++d_tanh.obj & ++derf_.obj & ++derfc_.obj & ++dfe.obj & ++dolio.obj & ++dtime_.obj & ++due.obj & ++ef1asc_.obj & ++ef1cmc_.obj & ++endfile.obj & ++erf_.obj & ++erfc_.obj & ++err.obj & ++etime_.obj & ++exit_.obj & ++f77_aloc.obj & ++f77vers.obj & ++fmt.obj & ++fmtlib.obj & ++ftell_.obj & ++getarg_.obj & ++getenv_.obj & ++h_abs.obj & ++h_dim.obj & ++h_dnnt.obj & ++h_indx.obj & ++h_len.obj & ++h_mod.obj & ++h_nint.obj & ++h_sign.obj & ++hl_ge.obj & ++hl_gt.obj & ++hl_le.obj & ++hl_lt.obj & ++i77vers.obj & ++i_abs.obj & ++i_dim.obj & ++i_dnnt.obj & ++i_indx.obj & ++i_len.obj & ++i_mod.obj & ++i_nint.obj & ++i_sign.obj & ++iargc_.obj & ++iio.obj & ++ilnw.obj & ++inquire.obj & ++l_ge.obj & ++l_gt.obj & ++l_le.obj & ++l_lt.obj & ++lbitbits.obj & ++lbitshft.obj & ++lread.obj & ++lwrite.obj & ++main.obj & ++open.obj & ++pow_ci.obj & ++pow_dd.obj & ++pow_di.obj & ++pow_hh.obj & ++pow_ii.obj & ++pow_ri.obj & ++pow_zi.obj & ++pow_zz.obj & ++r_abs.obj & ++r_acos.obj & ++r_asin.obj & ++r_atan.obj & ++r_atn2.obj & ++r_cnjg.obj & ++r_cos.obj & ++r_cosh.obj & ++r_dim.obj & ++r_exp.obj & ++r_imag.obj & ++r_int.obj & ++r_lg10.obj & ++r_log.obj & ++r_mod.obj & ++r_nint.obj & ++r_sign.obj & ++r_sin.obj & ++r_sinh.obj & ++r_sqrt.obj & ++r_tan.obj & ++r_tanh.obj & ++rdfmt.obj & ++rewind.obj & ++rsfe.obj & ++rsli.obj & ++rsne.obj & ++s_cat.obj & ++s_cmp.obj & ++s_copy.obj & ++s_paus.obj & ++s_rnge.obj & ++s_stop.obj & ++sfe.obj & ++sig_die.obj & ++signal_.obj & ++sue.obj & ++system_.obj & ++typesize.obj & ++uio.obj & ++uninit.obj & ++util.obj & ++wref.obj & ++wrtfmt.obj & ++wsfe.obj & ++wsle.obj & ++wsne.obj & ++xwsne.obj & ++z_abs.obj & ++z_cos.obj & ++z_div.obj & ++z_exp.obj & ++z_log.obj & ++z_sin.obj & ++z_sqrt.obj diff --git a/unix/f2c/libf2c/lio.h b/unix/f2c/libf2c/lio.h new file mode 100644 index 00000000..f9fd1cda --- /dev/null +++ b/unix/f2c/libf2c/lio.h @@ -0,0 +1,74 @@ +/* copy of ftypes from the compiler */ +/* variable types + * numeric assumptions: + * int < reals < complexes + * TYDREAL-TYREAL = TYDCOMPLEX-TYCOMPLEX + */ + +/* 0-10 retain their old (pre LOGICAL*1, etc.) */ +/* values to allow mixing old and new objects. */ + +#define TYUNKNOWN 0 +#define TYADDR 1 +#define TYSHORT 2 +#define TYLONG 3 +#define TYREAL 4 +#define TYDREAL 5 +#define TYCOMPLEX 6 +#define TYDCOMPLEX 7 +#define TYLOGICAL 8 +#define TYCHAR 9 +#define TYSUBR 10 +#define TYINT1 11 +#define TYLOGICAL1 12 +#define TYLOGICAL2 13 +#ifdef Allow_TYQUAD +#undef TYQUAD +#define TYQUAD 14 +#endif + +#define LINTW 24 +#define LINE 80 +#define LLOGW 2 +#ifdef Old_list_output +#define LLOW 1.0 +#define LHIGH 1.e9 +#define LEFMT " %# .8E" +#define LFFMT " %# .9g" +#else +#define LGFMT "%.9G" +#endif +/* LEFBL 20 should suffice; 24 overcomes a NeXT bug. */ +#define LEFBL 24 + +typedef union +{ + char flchar; + short flshort; + ftnint flint; +#ifdef Allow_TYQUAD + longint fllongint; +#endif + real flreal; + doublereal fldouble; +} flex; +#ifdef KR_headers +extern int (*f__lioproc)(), (*l_getc)(), (*l_ungetc)(); +extern int l_read(), l_write(); +#else +#ifdef __cplusplus +extern "C" { +#endif +extern int (*f__lioproc)(ftnint*, char*, ftnlen, ftnint); +extern int l_write(ftnint*, char*, ftnlen, ftnint); +extern void x_wsne(cilist*); +extern int c_le(cilist*), (*l_getc)(void), (*l_ungetc)(int,FILE*); +extern int l_read(ftnint*,char*,ftnlen,ftnint); +extern integer e_rsle(void), e_wsle(void), s_wsne(cilist*); +extern int z_rnew(void); +#endif +extern ftnint L_len; +extern int f__scale; +#ifdef __cplusplus + } +#endif diff --git a/unix/f2c/libf2c/lread.c b/unix/f2c/libf2c/lread.c new file mode 100644 index 00000000..699cda16 --- /dev/null +++ b/unix/f2c/libf2c/lread.c @@ -0,0 +1,806 @@ +#include "f2c.h" +#include "fio.h" + +/* Compile with -DF8X_NML_ELIDE_QUOTES to permit eliding quotation */ +/* marks in namelist input a la the Fortran 8X Draft published in */ +/* the May 1989 issue of Fortran Forum. */ + + +#ifdef Allow_TYQUAD +static longint f__llx; +#endif + +#ifdef KR_headers +extern double atof(); +extern char *malloc(), *realloc(); +int (*f__lioproc)(), (*l_getc)(), (*l_ungetc)(); +#else +#undef abs +#undef min +#undef max +#include "stdlib.h" +#endif + +#include "fmt.h" +#include "lio.h" +#include "ctype.h" +#include "fp.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +extern char *f__fmtbuf; +#else +extern const char *f__fmtbuf; +int (*f__lioproc)(ftnint*, char*, ftnlen, ftnint), (*l_getc)(void), + (*l_ungetc)(int,FILE*); +#endif + +int l_eof; + +#define isblnk(x) (f__ltab[x+1]&B) +#define issep(x) (f__ltab[x+1]&SX) +#define isapos(x) (f__ltab[x+1]&AX) +#define isexp(x) (f__ltab[x+1]&EX) +#define issign(x) (f__ltab[x+1]&SG) +#define iswhit(x) (f__ltab[x+1]&WH) +#define SX 1 +#define B 2 +#define AX 4 +#define EX 8 +#define SG 16 +#define WH 32 +char f__ltab[128+1] = { /* offset one for EOF */ + 0, + 0,0,AX,0,0,0,0,0,0,WH|B,SX|WH,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + SX|B|WH,0,AX,0,0,0,0,AX,0,0,0,SG,SX,SG,0,SX, + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + AX,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 +}; + +#ifdef ungetc + static int +#ifdef KR_headers +un_getc(x,f__cf) int x; FILE *f__cf; +#else +un_getc(int x, FILE *f__cf) +#endif +{ return ungetc(x,f__cf); } +#else +#define un_getc ungetc +#ifdef KR_headers + extern int ungetc(); +#else +extern int ungetc(int, FILE*); /* for systems with a buggy stdio.h */ +#endif +#endif + + int +t_getc(Void) +{ int ch; + if(f__curunit->uend) return(EOF); + if((ch=getc(f__cf))!=EOF) return(ch); + if(feof(f__cf)) + f__curunit->uend = l_eof = 1; + return(EOF); +} +integer e_rsle(Void) +{ + int ch; + if(f__curunit->uend) return(0); + while((ch=t_getc())!='\n') + if (ch == EOF) { + if(feof(f__cf)) + f__curunit->uend = l_eof = 1; + return EOF; + } + return(0); +} + +flag f__lquit; +int f__lcount,f__ltype,nml_read; +char *f__lchar; +double f__lx,f__ly; +#define ERR(x) if(n=(x)) return(n) +#define GETC(x) (x=(*l_getc)()) +#define Ungetc(x,y) (*l_ungetc)(x,y) + + static int +#ifdef KR_headers +l_R(poststar, reqint) int poststar, reqint; +#else +l_R(int poststar, int reqint) +#endif +{ + char s[FMAX+EXPMAXDIGS+4]; + register int ch; + register char *sp, *spe, *sp1; + long e, exp; + int havenum, havestar, se; + + if (!poststar) { + if (f__lcount > 0) + return(0); + f__lcount = 1; + } +#ifdef Allow_TYQUAD + f__llx = 0; +#endif + f__ltype = 0; + exp = 0; + havestar = 0; +retry: + sp1 = sp = s; + spe = sp + FMAX; + havenum = 0; + + switch(GETC(ch)) { + case '-': *sp++ = ch; sp1++; spe++; + case '+': + GETC(ch); + } + while(ch == '0') { + ++havenum; + GETC(ch); + } + while(isdigit(ch)) { + if (sp < spe) *sp++ = ch; + else ++exp; + GETC(ch); + } + if (ch == '*' && !poststar) { + if (sp == sp1 || exp || *s == '-') { + errfl(f__elist->cierr,112,"bad repetition count"); + } + poststar = havestar = 1; + *sp = 0; + f__lcount = atoi(s); + goto retry; + } + if (ch == '.') { +#ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT + if (reqint) + errfl(f__elist->cierr,115,"invalid integer"); +#endif + GETC(ch); + if (sp == sp1) + while(ch == '0') { + ++havenum; + --exp; + GETC(ch); + } + while(isdigit(ch)) { + if (sp < spe) + { *sp++ = ch; --exp; } + GETC(ch); + } + } + havenum += sp - sp1; + se = 0; + if (issign(ch)) + goto signonly; + if (havenum && isexp(ch)) { +#ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT + if (reqint) + errfl(f__elist->cierr,115,"invalid integer"); +#endif + GETC(ch); + if (issign(ch)) { +signonly: + if (ch == '-') se = 1; + GETC(ch); + } + if (!isdigit(ch)) { +bad: + errfl(f__elist->cierr,112,"exponent field"); + } + + e = ch - '0'; + while(isdigit(GETC(ch))) { + e = 10*e + ch - '0'; + if (e > EXPMAX) + goto bad; + } + if (se) + exp -= e; + else + exp += e; + } + (void) Ungetc(ch, f__cf); + if (sp > sp1) { + ++havenum; + while(*--sp == '0') + ++exp; + if (exp) + sprintf(sp+1, "e%ld", exp); + else + sp[1] = 0; + f__lx = atof(s); +#ifdef Allow_TYQUAD + if (reqint&2 && (se = sp - sp1 + exp) > 14 && se < 20) { + /* Assuming 64-bit longint and 32-bit long. */ + if (exp < 0) + sp += exp; + if (sp1 <= sp) { + f__llx = *sp1 - '0'; + while(++sp1 <= sp) + f__llx = 10*f__llx + (*sp1 - '0'); + } + while(--exp >= 0) + f__llx *= 10; + if (*s == '-') + f__llx = -f__llx; + } +#endif + } + else + f__lx = 0.; + if (havenum) + f__ltype = TYLONG; + else + switch(ch) { + case ',': + case '/': + break; + default: + if (havestar && ( ch == ' ' + ||ch == '\t' + ||ch == '\n')) + break; + if (nml_read > 1) { + f__lquit = 2; + return 0; + } + errfl(f__elist->cierr,112,"invalid number"); + } + return 0; + } + + static int +#ifdef KR_headers +rd_count(ch) register int ch; +#else +rd_count(register int ch) +#endif +{ + if (ch < '0' || ch > '9') + return 1; + f__lcount = ch - '0'; + while(GETC(ch) >= '0' && ch <= '9') + f__lcount = 10*f__lcount + ch - '0'; + Ungetc(ch,f__cf); + return f__lcount <= 0; + } + + static int +l_C(Void) +{ int ch, nml_save; + double lz; + if(f__lcount>0) return(0); + f__ltype=0; + GETC(ch); + if(ch!='(') + { + if (nml_read > 1 && (ch < '0' || ch > '9')) { + Ungetc(ch,f__cf); + f__lquit = 2; + return 0; + } + if (rd_count(ch)) + if(!f__cf || !feof(f__cf)) + errfl(f__elist->cierr,112,"complex format"); + else + err(f__elist->cierr,(EOF),"lread"); + if(GETC(ch)!='*') + { + if(!f__cf || !feof(f__cf)) + errfl(f__elist->cierr,112,"no star"); + else + err(f__elist->cierr,(EOF),"lread"); + } + if(GETC(ch)!='(') + { Ungetc(ch,f__cf); + return(0); + } + } + else + f__lcount = 1; + while(iswhit(GETC(ch))); + Ungetc(ch,f__cf); + nml_save = nml_read; + nml_read = 0; + if (ch = l_R(1,0)) + return ch; + if (!f__ltype) + errfl(f__elist->cierr,112,"no real part"); + lz = f__lx; + while(iswhit(GETC(ch))); + if(ch!=',') + { (void) Ungetc(ch,f__cf); + errfl(f__elist->cierr,112,"no comma"); + } + while(iswhit(GETC(ch))); + (void) Ungetc(ch,f__cf); + if (ch = l_R(1,0)) + return ch; + if (!f__ltype) + errfl(f__elist->cierr,112,"no imaginary part"); + while(iswhit(GETC(ch))); + if(ch!=')') errfl(f__elist->cierr,112,"no )"); + f__ly = f__lx; + f__lx = lz; +#ifdef Allow_TYQUAD + f__llx = 0; +#endif + nml_read = nml_save; + return(0); +} + + static char nmLbuf[256], *nmL_next; + static int (*nmL_getc_save)(Void); +#ifdef KR_headers + static int (*nmL_ungetc_save)(/* int, FILE* */); +#else + static int (*nmL_ungetc_save)(int, FILE*); +#endif + + static int +nmL_getc(Void) +{ + int rv; + if (rv = *nmL_next++) + return rv; + l_getc = nmL_getc_save; + l_ungetc = nmL_ungetc_save; + return (*l_getc)(); + } + + static int +#ifdef KR_headers +nmL_ungetc(x, f) int x; FILE *f; +#else +nmL_ungetc(int x, FILE *f) +#endif +{ + f = f; /* banish non-use warning */ + return *--nmL_next = x; + } + + static int +#ifdef KR_headers +Lfinish(ch, dot, rvp) int ch, dot, *rvp; +#else +Lfinish(int ch, int dot, int *rvp) +#endif +{ + char *s, *se; + static char what[] = "namelist input"; + + s = nmLbuf + 2; + se = nmLbuf + sizeof(nmLbuf) - 1; + *s++ = ch; + while(!issep(GETC(ch)) && ch!=EOF) { + if (s >= se) { + nmLbuf_ovfl: + return *rvp = err__fl(f__elist->cierr,131,what); + } + *s++ = ch; + if (ch != '=') + continue; + if (dot) + return *rvp = err__fl(f__elist->cierr,112,what); + got_eq: + *s = 0; + nmL_getc_save = l_getc; + l_getc = nmL_getc; + nmL_ungetc_save = l_ungetc; + l_ungetc = nmL_ungetc; + nmLbuf[1] = *(nmL_next = nmLbuf) = ','; + *rvp = f__lcount = 0; + return 1; + } + if (dot) + goto done; + for(;;) { + if (s >= se) + goto nmLbuf_ovfl; + *s++ = ch; + if (!isblnk(ch)) + break; + if (GETC(ch) == EOF) + goto done; + } + if (ch == '=') + goto got_eq; + done: + Ungetc(ch, f__cf); + return 0; + } + + static int +l_L(Void) +{ + int ch, rv, sawdot; + + if(f__lcount>0) + return(0); + f__lcount = 1; + f__ltype=0; + GETC(ch); + if(isdigit(ch)) + { + rd_count(ch); + if(GETC(ch)!='*') + if(!f__cf || !feof(f__cf)) + errfl(f__elist->cierr,112,"no star"); + else + err(f__elist->cierr,(EOF),"lread"); + GETC(ch); + } + sawdot = 0; + if(ch == '.') { + sawdot = 1; + GETC(ch); + } + switch(ch) + { + case 't': + case 'T': + if (nml_read && Lfinish(ch, sawdot, &rv)) + return rv; + f__lx=1; + break; + case 'f': + case 'F': + if (nml_read && Lfinish(ch, sawdot, &rv)) + return rv; + f__lx=0; + break; + default: + if(isblnk(ch) || issep(ch) || ch==EOF) + { (void) Ungetc(ch,f__cf); + return(0); + } + if (nml_read > 1) { + Ungetc(ch,f__cf); + f__lquit = 2; + return 0; + } + errfl(f__elist->cierr,112,"logical"); + } + f__ltype=TYLONG; + while(!issep(GETC(ch)) && ch!=EOF); + Ungetc(ch, f__cf); + return(0); +} + +#define BUFSIZE 128 + + static int +l_CHAR(Void) +{ int ch,size,i; + static char rafail[] = "realloc failure"; + char quote,*p; + if(f__lcount>0) return(0); + f__ltype=0; + if(f__lchar!=NULL) free(f__lchar); + size=BUFSIZE; + p=f__lchar = (char *)malloc((unsigned int)size); + if(f__lchar == NULL) + errfl(f__elist->cierr,113,"no space"); + + GETC(ch); + if(isdigit(ch)) { + /* allow Fortran 8x-style unquoted string... */ + /* either find a repetition count or the string */ + f__lcount = ch - '0'; + *p++ = ch; + for(i = 1;;) { + switch(GETC(ch)) { + case '*': + if (f__lcount == 0) { + f__lcount = 1; +#ifndef F8X_NML_ELIDE_QUOTES + if (nml_read) + goto no_quote; +#endif + goto noquote; + } + p = f__lchar; + goto have_lcount; + case ',': + case ' ': + case '\t': + case '\n': + case '/': + Ungetc(ch,f__cf); + /* no break */ + case EOF: + f__lcount = 1; + f__ltype = TYCHAR; + return *p = 0; + } + if (!isdigit(ch)) { + f__lcount = 1; +#ifndef F8X_NML_ELIDE_QUOTES + if (nml_read) { + no_quote: + errfl(f__elist->cierr,112, + "undelimited character string"); + } +#endif + goto noquote; + } + *p++ = ch; + f__lcount = 10*f__lcount + ch - '0'; + if (++i == size) { + f__lchar = (char *)realloc(f__lchar, + (unsigned int)(size += BUFSIZE)); + if(f__lchar == NULL) + errfl(f__elist->cierr,113,rafail); + p = f__lchar + i; + } + } + } + else (void) Ungetc(ch,f__cf); + have_lcount: + if(GETC(ch)=='\'' || ch=='"') quote=ch; + else if(isblnk(ch) || (issep(ch) && ch != '\n') || ch==EOF) { + Ungetc(ch,f__cf); + return 0; + } +#ifndef F8X_NML_ELIDE_QUOTES + else if (nml_read > 1) { + Ungetc(ch,f__cf); + f__lquit = 2; + return 0; + } +#endif + else { + /* Fortran 8x-style unquoted string */ + *p++ = ch; + for(i = 1;;) { + switch(GETC(ch)) { + case ',': + case ' ': + case '\t': + case '\n': + case '/': + Ungetc(ch,f__cf); + /* no break */ + case EOF: + f__ltype = TYCHAR; + return *p = 0; + } + noquote: + *p++ = ch; + if (++i == size) { + f__lchar = (char *)realloc(f__lchar, + (unsigned int)(size += BUFSIZE)); + if(f__lchar == NULL) + errfl(f__elist->cierr,113,rafail); + p = f__lchar + i; + } + } + } + f__ltype=TYCHAR; + for(i=0;;) + { while(GETC(ch)!=quote && ch!='\n' + && ch!=EOF && ++i<size) *p++ = ch; + if(i==size) + { + newone: + f__lchar= (char *)realloc(f__lchar, + (unsigned int)(size += BUFSIZE)); + if(f__lchar == NULL) + errfl(f__elist->cierr,113,rafail); + p=f__lchar+i-1; + *p++ = ch; + } + else if(ch==EOF) return(EOF); + else if(ch=='\n') + { if(*(p-1) != '\\') continue; + i--; + p--; + if(++i<size) *p++ = ch; + else goto newone; + } + else if(GETC(ch)==quote) + { if(++i<size) *p++ = ch; + else goto newone; + } + else + { (void) Ungetc(ch,f__cf); + *p = 0; + return(0); + } + } +} + + int +#ifdef KR_headers +c_le(a) cilist *a; +#else +c_le(cilist *a) +#endif +{ + if(!f__init) + f_init(); + f__fmtbuf="list io"; + f__curunit = &f__units[a->ciunit]; + if(a->ciunit>=MXUNIT || a->ciunit<0) + err(a->cierr,101,"stler"); + f__scale=f__recpos=0; + f__elist=a; + if(f__curunit->ufd==NULL && fk_open(SEQ,FMT,a->ciunit)) + err(a->cierr,102,"lio"); + f__cf=f__curunit->ufd; + if(!f__curunit->ufmt) err(a->cierr,103,"lio") + return(0); +} + + int +#ifdef KR_headers +l_read(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len; +#else +l_read(ftnint *number, char *ptr, ftnlen len, ftnint type) +#endif +{ +#define Ptr ((flex *)ptr) + int i,n,ch; + doublereal *yy; + real *xx; + for(i=0;i<*number;i++) + { + if(f__lquit) return(0); + if(l_eof) + err(f__elist->ciend, EOF, "list in") + if(f__lcount == 0) { + f__ltype = 0; + for(;;) { + GETC(ch); + switch(ch) { + case EOF: + err(f__elist->ciend,(EOF),"list in") + case ' ': + case '\t': + case '\n': + continue; + case '/': + f__lquit = 1; + goto loopend; + case ',': + f__lcount = 1; + goto loopend; + default: + (void) Ungetc(ch, f__cf); + goto rddata; + } + } + } + rddata: + switch((int)type) + { + case TYINT1: + case TYSHORT: + case TYLONG: +#ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT + ERR(l_R(0,1)); + break; +#endif + case TYREAL: + case TYDREAL: + ERR(l_R(0,0)); + break; +#ifdef TYQUAD + case TYQUAD: + n = l_R(0,2); + if (n) + return n; + break; +#endif + case TYCOMPLEX: + case TYDCOMPLEX: + ERR(l_C()); + break; + case TYLOGICAL1: + case TYLOGICAL2: + case TYLOGICAL: + ERR(l_L()); + break; + case TYCHAR: + ERR(l_CHAR()); + break; + } + while (GETC(ch) == ' ' || ch == '\t'); + if (ch != ',' || f__lcount > 1) + Ungetc(ch,f__cf); + loopend: + if(f__lquit) return(0); + if(f__cf && ferror(f__cf)) { + clearerr(f__cf); + errfl(f__elist->cierr,errno,"list in"); + } + if(f__ltype==0) goto bump; + switch((int)type) + { + case TYINT1: + case TYLOGICAL1: + Ptr->flchar = (char)f__lx; + break; + case TYLOGICAL2: + case TYSHORT: + Ptr->flshort = (short)f__lx; + break; + case TYLOGICAL: + case TYLONG: + Ptr->flint = (ftnint)f__lx; + break; +#ifdef Allow_TYQUAD + case TYQUAD: + if (!(Ptr->fllongint = f__llx)) + Ptr->fllongint = f__lx; + break; +#endif + case TYREAL: + Ptr->flreal=f__lx; + break; + case TYDREAL: + Ptr->fldouble=f__lx; + break; + case TYCOMPLEX: + xx=(real *)ptr; + *xx++ = f__lx; + *xx = f__ly; + break; + case TYDCOMPLEX: + yy=(doublereal *)ptr; + *yy++ = f__lx; + *yy = f__ly; + break; + case TYCHAR: + b_char(f__lchar,ptr,len); + break; + } + bump: + if(f__lcount>0) f__lcount--; + ptr += len; + if (nml_read) + nml_read++; + } + return(0); +#undef Ptr +} +#ifdef KR_headers +integer s_rsle(a) cilist *a; +#else +integer s_rsle(cilist *a) +#endif +{ + int n; + + f__reading=1; + f__external=1; + f__formatted=1; + if(n=c_le(a)) return(n); + f__lioproc = l_read; + f__lquit = 0; + f__lcount = 0; + l_eof = 0; + if(f__curunit->uwrt && f__nowreading(f__curunit)) + err(a->cierr,errno,"read start"); + if(f__curunit->uend) + err(f__elist->ciend,(EOF),"read start"); + l_getc = t_getc; + l_ungetc = un_getc; + f__doend = xrd_SL; + return(0); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/lwrite.c b/unix/f2c/libf2c/lwrite.c new file mode 100644 index 00000000..9e0d93de --- /dev/null +++ b/unix/f2c/libf2c/lwrite.c @@ -0,0 +1,314 @@ +#include "f2c.h" +#include "fio.h" +#include "fmt.h" +#include "lio.h" +#ifdef __cplusplus +extern "C" { +#endif + +ftnint L_len; +int f__Aquote; + + static VOID +donewrec(Void) +{ + if (f__recpos) + (*f__donewrec)(); + } + + static VOID +#ifdef KR_headers +lwrt_I(n) longint n; +#else +lwrt_I(longint n) +#endif +{ + char *p; + int ndigit, sign; + + p = f__icvt(n, &ndigit, &sign, 10); + if(f__recpos + ndigit >= L_len) + donewrec(); + PUT(' '); + if (sign) + PUT('-'); + while(*p) + PUT(*p++); +} + static VOID +#ifdef KR_headers +lwrt_L(n, len) ftnint n; ftnlen len; +#else +lwrt_L(ftnint n, ftnlen len) +#endif +{ + if(f__recpos+LLOGW>=L_len) + donewrec(); + wrt_L((Uint *)&n,LLOGW, len); +} + static VOID +#ifdef KR_headers +lwrt_A(p,len) char *p; ftnlen len; +#else +lwrt_A(char *p, ftnlen len) +#endif +{ + int a; + char *p1, *pe; + + a = 0; + pe = p + len; + if (f__Aquote) { + a = 3; + if (len > 1 && p[len-1] == ' ') { + while(--len > 1 && p[len-1] == ' '); + pe = p + len; + } + p1 = p; + while(p1 < pe) + if (*p1++ == '\'') + a++; + } + if(f__recpos+len+a >= L_len) + donewrec(); + if (a +#ifndef OMIT_BLANK_CC + || !f__recpos +#endif + ) + PUT(' '); + if (a) { + PUT('\''); + while(p < pe) { + if (*p == '\'') + PUT('\''); + PUT(*p++); + } + PUT('\''); + } + else + while(p < pe) + PUT(*p++); +} + + static int +#ifdef KR_headers +l_g(buf, n) char *buf; double n; +#else +l_g(char *buf, double n) +#endif +{ +#ifdef Old_list_output + doublereal absn; + char *fmt; + + absn = n; + if (absn < 0) + absn = -absn; + fmt = LLOW <= absn && absn < LHIGH ? LFFMT : LEFMT; +#ifdef USE_STRLEN + sprintf(buf, fmt, n); + return strlen(buf); +#else + return sprintf(buf, fmt, n); +#endif + +#else + register char *b, c, c1; + + b = buf; + *b++ = ' '; + if (n < 0) { + *b++ = '-'; + n = -n; + } + else + *b++ = ' '; + if (n == 0) { +#ifdef SIGNED_ZEROS + if (signbit_f2c(&n)) + *b++ = '-'; +#endif + *b++ = '0'; + *b++ = '.'; + *b = 0; + goto f__ret; + } + sprintf(b, LGFMT, n); + switch(*b) { +#ifndef WANT_LEAD_0 + case '0': + while(b[0] = b[1]) + b++; + break; +#endif + case 'i': + case 'I': + /* Infinity */ + case 'n': + case 'N': + /* NaN */ + while(*++b); + break; + + default: + /* Fortran 77 insists on having a decimal point... */ + for(;; b++) + switch(*b) { + case 0: + *b++ = '.'; + *b = 0; + goto f__ret; + case '.': + while(*++b); + goto f__ret; + case 'E': + for(c1 = '.', c = 'E'; *b = c1; + c1 = c, c = *++b); + goto f__ret; + } + } + f__ret: + return b - buf; +#endif + } + + static VOID +#ifdef KR_headers +l_put(s) register char *s; +#else +l_put(register char *s) +#endif +{ +#ifdef KR_headers + register void (*pn)() = f__putn; +#else + register void (*pn)(int) = f__putn; +#endif + register int c; + + while(c = *s++) + (*pn)(c); + } + + static VOID +#ifdef KR_headers +lwrt_F(n) double n; +#else +lwrt_F(double n) +#endif +{ + char buf[LEFBL]; + + if(f__recpos + l_g(buf,n) >= L_len) + donewrec(); + l_put(buf); +} + static VOID +#ifdef KR_headers +lwrt_C(a,b) double a,b; +#else +lwrt_C(double a, double b) +#endif +{ + char *ba, *bb, bufa[LEFBL], bufb[LEFBL]; + int al, bl; + + al = l_g(bufa, a); + for(ba = bufa; *ba == ' '; ba++) + --al; + bl = l_g(bufb, b) + 1; /* intentionally high by 1 */ + for(bb = bufb; *bb == ' '; bb++) + --bl; + if(f__recpos + al + bl + 3 >= L_len) + donewrec(); +#ifdef OMIT_BLANK_CC + else +#endif + PUT(' '); + PUT('('); + l_put(ba); + PUT(','); + if (f__recpos + bl >= L_len) { + (*f__donewrec)(); +#ifndef OMIT_BLANK_CC + PUT(' '); +#endif + } + l_put(bb); + PUT(')'); +} + + int +#ifdef KR_headers +l_write(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len; +#else +l_write(ftnint *number, char *ptr, ftnlen len, ftnint type) +#endif +{ +#define Ptr ((flex *)ptr) + int i; + longint x; + double y,z; + real *xx; + doublereal *yy; + for(i=0;i< *number; i++) + { + switch((int)type) + { + default: f__fatal(117,"unknown type in lio"); + case TYINT1: + x = Ptr->flchar; + goto xint; + case TYSHORT: + x=Ptr->flshort; + goto xint; +#ifdef Allow_TYQUAD + case TYQUAD: + x = Ptr->fllongint; + goto xint; +#endif + case TYLONG: + x=Ptr->flint; + xint: lwrt_I(x); + break; + case TYREAL: + y=Ptr->flreal; + goto xfloat; + case TYDREAL: + y=Ptr->fldouble; + xfloat: lwrt_F(y); + break; + case TYCOMPLEX: + xx= &Ptr->flreal; + y = *xx++; + z = *xx; + goto xcomplex; + case TYDCOMPLEX: + yy = &Ptr->fldouble; + y= *yy++; + z = *yy; + xcomplex: + lwrt_C(y,z); + break; + case TYLOGICAL1: + x = Ptr->flchar; + goto xlog; + case TYLOGICAL2: + x = Ptr->flshort; + goto xlog; + case TYLOGICAL: + x = Ptr->flint; + xlog: lwrt_L(Ptr->flint, len); + break; + case TYCHAR: + lwrt_A(ptr,len); + break; + } + ptr += len; + } + return(0); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/main.c b/unix/f2c/libf2c/main.c new file mode 100644 index 00000000..d95fdc92 --- /dev/null +++ b/unix/f2c/libf2c/main.c @@ -0,0 +1,148 @@ +/* STARTUP PROCEDURE FOR UNIX FORTRAN PROGRAMS */ + +#include "stdio.h" +#include "signal1.h" + +#ifndef SIGIOT +#ifdef SIGABRT +#define SIGIOT SIGABRT +#endif +#endif + +#ifndef KR_headers +#undef VOID +#include "stdlib.h" +#ifdef __cplusplus +extern "C" { +#endif +#endif + +#ifndef VOID +#define VOID void +#endif + +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef NO__STDC +#define ONEXIT onexit +extern VOID f_exit(); +#else +#ifndef KR_headers +extern void f_exit(void); +#ifndef NO_ONEXIT +#define ONEXIT atexit +extern int atexit(void (*)(void)); +#endif +#else +#ifndef NO_ONEXIT +#define ONEXIT onexit +extern VOID f_exit(); +#endif +#endif +#endif + +#ifdef KR_headers +extern VOID f_init(), sig_die(); +extern int MAIN__(); +#define Int /* int */ +#else +extern void f_init(void), sig_die(const char*, int); +extern int MAIN__(void); +#define Int int +#endif + +static VOID sigfdie(Sigarg) +{ +Use_Sigarg; +sig_die("Floating Exception", 1); +} + + +static VOID sigidie(Sigarg) +{ +Use_Sigarg; +sig_die("IOT Trap", 1); +} + +#ifdef SIGQUIT +static VOID sigqdie(Sigarg) +{ +Use_Sigarg; +sig_die("Quit signal", 1); +} +#endif + + +static VOID sigindie(Sigarg) +{ +Use_Sigarg; +sig_die("Interrupt", 0); +} + +static VOID sigtdie(Sigarg) +{ +Use_Sigarg; +sig_die("Killed", 0); +} + +#ifdef SIGTRAP +static VOID sigtrdie(Sigarg) +{ +Use_Sigarg; +sig_die("Trace trap", 1); +} +#endif + + +int xargc; +char **xargv; + +#ifdef __cplusplus + } +#endif + + int +#ifdef KR_headers +main(argc, argv) int argc; char **argv; +#else +main(int argc, char **argv) +#endif +{ +xargc = argc; +xargv = argv; +signal1(SIGFPE, sigfdie); /* ignore underflow, enable overflow */ +#ifdef SIGIOT +signal1(SIGIOT, sigidie); +#endif +#ifdef SIGTRAP +signal1(SIGTRAP, sigtrdie); +#endif +#ifdef SIGQUIT +if(signal1(SIGQUIT,sigqdie) == SIG_IGN) + signal1(SIGQUIT, SIG_IGN); +#endif +if(signal1(SIGINT, sigindie) == SIG_IGN) + signal1(SIGINT, SIG_IGN); +signal1(SIGTERM,sigtdie); + +#ifdef pdp11 + ldfps(01200); /* detect overflow as an exception */ +#endif + +f_init(); +#ifndef NO_ONEXIT +ONEXIT(f_exit); +#endif +MAIN__(); +#ifdef NO_ONEXIT +f_exit(); +#endif +exit(0); /* exit(0) rather than return(0) to bypass Cray bug */ +return 0; /* For compilers that complain of missing return values; */ + /* others will complain that this is unreachable code. */ +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/makefile.sy b/unix/f2c/libf2c/makefile.sy new file mode 100644 index 00000000..0e009eff --- /dev/null +++ b/unix/f2c/libf2c/makefile.sy @@ -0,0 +1,190 @@ +# For making f2c.lib (here called syf2c.lib) with Symantec C++ . +# Invoke with "make -f makefile.sy" . +# In the CFLAGS line below, "-mn" is for NT and W9x. +# For 32-bit addressing with MSDOS, change "-mn" to "-mx". +# With Symantec, it is necessary to explicitly load main.obj . + +# To get signed zeros in write statements on IEEE-arithmetic systems, +# add -DSIGNED_ZEROS to the CFLAGS assignment below and add signbit.obj +# to the objects in the "w =" list below. + +CC = sc +CFLAGS = -DMSDOS -D_POSIX_SOURCE -DNO_ONEXIT -s -mn -DUSE_CLOCK -DNO_My_ctype + +.c.obj: + $(CC) -c $(CFLAGS) $*.c + +w = \ + abort_.obj \ + backspac.obj \ + c_abs.obj \ + c_cos.obj \ + c_div.obj \ + c_exp.obj \ + c_log.obj \ + c_sin.obj \ + c_sqrt.obj \ + cabs.obj \ + close.obj \ + d_abs.obj \ + d_acos.obj \ + d_asin.obj \ + d_atan.obj \ + d_atn2.obj \ + d_cnjg.obj \ + d_cos.obj \ + d_cosh.obj \ + d_dim.obj \ + d_exp.obj \ + d_imag.obj \ + d_int.obj \ + d_lg10.obj \ + d_log.obj \ + d_mod.obj \ + d_nint.obj \ + d_prod.obj \ + d_sign.obj \ + d_sin.obj \ + d_sinh.obj \ + d_sqrt.obj \ + d_tan.obj \ + d_tanh.obj \ + derf_.obj \ + derfc_.obj \ + dfe.obj \ + dolio.obj \ + dtime_.obj \ + due.obj \ + ef1asc_.obj \ + ef1cmc_.obj \ + endfile.obj \ + erf_.obj \ + erfc_.obj \ + err.obj \ + etime_.obj \ + exit_.obj \ + f77_aloc.obj \ + f77vers.obj \ + fmt.obj \ + fmtlib.obj \ + ftell_.obj \ + getarg_.obj \ + getenv_.obj \ + h_abs.obj \ + h_dim.obj \ + h_dnnt.obj \ + h_indx.obj \ + h_len.obj \ + h_mod.obj \ + h_nint.obj \ + h_sign.obj \ + hl_ge.obj \ + hl_gt.obj \ + hl_le.obj \ + hl_lt.obj \ + i77vers.obj \ + i_abs.obj \ + i_dim.obj \ + i_dnnt.obj \ + i_indx.obj \ + i_len.obj \ + i_mod.obj \ + i_nint.obj \ + i_sign.obj \ + iargc_.obj \ + iio.obj \ + ilnw.obj \ + inquire.obj \ + l_ge.obj \ + l_gt.obj \ + l_le.obj \ + l_lt.obj \ + lbitbits.obj \ + lbitshft.obj \ + lread.obj \ + lwrite.obj \ + main.obj \ + open.obj \ + pow_ci.obj \ + pow_dd.obj \ + pow_di.obj \ + pow_hh.obj \ + pow_ii.obj \ + pow_ri.obj \ + pow_zi.obj \ + pow_zz.obj \ + r_abs.obj \ + r_acos.obj \ + r_asin.obj \ + r_atan.obj \ + r_atn2.obj \ + r_cnjg.obj \ + r_cos.obj \ + r_cosh.obj \ + r_dim.obj \ + r_exp.obj \ + r_imag.obj \ + r_int.obj \ + r_lg10.obj \ + r_log.obj \ + r_mod.obj \ + r_nint.obj \ + r_sign.obj \ + r_sin.obj \ + r_sinh.obj \ + r_sqrt.obj \ + r_tan.obj \ + r_tanh.obj \ + rdfmt.obj \ + rewind.obj \ + rsfe.obj \ + rsli.obj \ + rsne.obj \ + s_cat.obj \ + s_cmp.obj \ + s_copy.obj \ + s_paus.obj \ + s_rnge.obj \ + s_stop.obj \ + sfe.obj \ + sig_die.obj \ + signal_.obj \ + sue.obj \ + system_.obj \ + typesize.obj \ + uio.obj \ + util.obj \ + uninit.obj \ + wref.obj \ + wrtfmt.obj \ + wsfe.obj \ + wsle.obj \ + wsne.obj \ + xwsne.obj \ + z_abs.obj \ + z_cos.obj \ + z_div.obj \ + z_exp.obj \ + z_log.obj \ + z_sin.obj \ + z_sqrt.obj + +syf2c.lib: f2c.h signal1.h sysdep1.h $w + lib /B /C syf2c.lib @libf2c.sy + +f2c.h: f2c.h0 + copy f2c.h0 f2c.h + +signal1.h: signal1.h0 + copy signal1.h0 signal1.h + +sysdep1.h: sysdep1.h0 + copy sysdep1.h0 sysdep1.h + +signbit.obj uninit.obj: arith.h + +arith.h: arithchk.c + scomptry.bat $(CC) $(CFLAGS) arithchk.c + arithchk + del arithchk.exe + del arithchk.obj diff --git a/unix/f2c/libf2c/makefile.u b/unix/f2c/libf2c/makefile.u new file mode 100644 index 00000000..6d05dc6e --- /dev/null +++ b/unix/f2c/libf2c/makefile.u @@ -0,0 +1,219 @@ +# Unix makefile: see README. +# For C++, first "make hadd". +# If your compiler does not recognize ANSI C, add +# -DKR_headers +# to the CFLAGS = line below. +# On Sun and other BSD systems that do not provide an ANSI sprintf, add +# -DUSE_STRLEN +# to the CFLAGS = line below. +# On Linux systems, add +# -DNON_UNIX_STDIO +# to the CFLAGS = line below. For libf2c.so under Linux, also add +# -fPIC +# to the CFLAGS = line below. + +.SUFFIXES: .c .o +CC = cc +SHELL = /bin/sh +CFLAGS = -O -w $(HSI_CF) + +# compile, then strip unnecessary symbols +.c.o: + $(CC) -c -DSkip_f2c_Undefs $(CFLAGS) $*.c + ld -r -x -o $*.xxx $*.o + mv $*.xxx $*.o +## Under Solaris (and other systems that do not understand ld -x), +## omit -x in the ld line above. +## If your system does not have the ld command, comment out +## or remove both the ld and mv lines above. + +MISC = f77vers.o i77vers.o main.o s_rnge.o abort_.o exit_.o getarg_.o iargc_.o\ + getenv_.o signal_.o s_stop.o s_paus.o system_.o cabs.o ctype.o\ + derf_.o derfc_.o erf_.o erfc_.o sig_die.o uninit.o +POW = pow_ci.o pow_dd.o pow_di.o pow_hh.o pow_ii.o pow_ri.o pow_zi.o pow_zz.o +CX = c_abs.o c_cos.o c_div.o c_exp.o c_log.o c_sin.o c_sqrt.o +DCX = z_abs.o z_cos.o z_div.o z_exp.o z_log.o z_sin.o z_sqrt.o +REAL = r_abs.o r_acos.o r_asin.o r_atan.o r_atn2.o r_cnjg.o r_cos.o\ + r_cosh.o r_dim.o r_exp.o r_imag.o r_int.o\ + r_lg10.o r_log.o r_mod.o r_nint.o r_sign.o\ + r_sin.o r_sinh.o r_sqrt.o r_tan.o r_tanh.o +DBL = d_abs.o d_acos.o d_asin.o d_atan.o d_atn2.o\ + d_cnjg.o d_cos.o d_cosh.o d_dim.o d_exp.o\ + d_imag.o d_int.o d_lg10.o d_log.o d_mod.o\ + d_nint.o d_prod.o d_sign.o d_sin.o d_sinh.o\ + d_sqrt.o d_tan.o d_tanh.o +INT = i_abs.o i_dim.o i_dnnt.o i_indx.o i_len.o i_mod.o i_nint.o i_sign.o\ + lbitbits.o lbitshft.o +HALF = h_abs.o h_dim.o h_dnnt.o h_indx.o h_len.o h_mod.o h_nint.o h_sign.o +CMP = l_ge.o l_gt.o l_le.o l_lt.o hl_ge.o hl_gt.o hl_le.o hl_lt.o +EFL = ef1asc_.o ef1cmc_.o +CHAR = f77_aloc.o s_cat.o s_cmp.o s_copy.o +I77 = backspac.o close.o dfe.o dolio.o due.o endfile.o err.o\ + fmt.o fmtlib.o ftell_.o iio.o ilnw.o inquire.o lread.o lwrite.o\ + open.o rdfmt.o rewind.o rsfe.o rsli.o rsne.o sfe.o sue.o\ + typesize.o uio.o util.o wref.o wrtfmt.o wsfe.o wsle.o wsne.o xwsne.o +QINT = pow_qq.o qbitbits.o qbitshft.o ftell64_.o +TIME = dtime_.o etime_.o + +# If you get an error compiling dtime_.c or etime_.c, try adding +# -DUSE_CLOCK to the CFLAGS assignment above; if that does not work, +# omit $(TIME) from OFILES = assignment below. + +# To get signed zeros in write statements on IEEE-arithmetic systems, +# add -DSIGNED_ZEROS to the CFLAGS assignment below and add signbit.o +# to the end of the OFILES = assignment below. + +# For INTEGER*8 support (which requires system-dependent adjustments to +# f2c.h), add $(QINT) to the OFILES = assignment below... + +OFILES = $(MISC) $(POW) $(CX) $(DCX) $(REAL) $(DBL) $(INT) \ + $(HALF) $(CMP) $(EFL) $(CHAR) $(I77) $(TIME) + +all: f2c.h signal1.h sysdep1.h libf2c.a + +libf2c.a: $(OFILES) + ar r libf2c.a $? + -ranlib libf2c.a + +## Shared-library variant: the following rule works on Linux +## systems. Details are system-dependent. Under Linux, -fPIC +## must appear in the CFLAGS assignment when making libf2c.so. +## Under Solaris, use -Kpic in CFLAGS and use "ld -G" instead +## of "$(CC) -shared". +## For MacOSX 10.4 and 10.5 (and perhaps other versions >= 10.3), use +## "MACOSX_DEPLOYMENT_TARGET=10.3 libtool -dynamic -undefined dynamic_lookup -single_module" +## instead of "$(CC) -shared", and when running programs linked against libf2c.so, +## arrange for $DYLD_LIBRARY_PATH to include the directory containing libf2c.so. + +libf2c.so: $(OFILES) + $(CC) -shared -o libf2c.so $(OFILES) + +### If your system lacks ranlib, you don't need it; see README. + +f77vers.o: f77vers.c + $(CC) -c f77vers.c + +i77vers.o: i77vers.c + $(CC) -c i77vers.c + +# To get an "f2c.h" for use with "f2c -C++", first "make hadd" +hadd: f2c.h0 f2ch.add + cat f2c.h0 f2ch.add >f2c.h + +# For use with "f2c" and "f2c -A": +f2c.h: f2c.h0 + cp f2c.h0 f2c.h + +# You may need to adjust signal1.h and sysdep1.h suitably for your system... +signal1.h: signal1.h0 + cp signal1.h0 signal1.h + +sysdep1.h: sysdep1.h0 + cp sysdep1.h0 sysdep1.h + +# If your system lacks onexit() and you are not using an +# ANSI C compiler, then you should uncomment the following +# two lines (for compiling main.o): +#main.o: main.c +# $(CC) -c -DNO_ONEXIT -DSkip_f2c_Undefs main.c +# On at least some Sun systems, it is more appropriate to +# uncomment the following two lines: +#main.o: main.c +# $(CC) -c -Donexit=on_exit -DSkip_f2c_Undefs main.c + +install: libf2c.a + cp libf2c.a $(LIBDIR) + -ranlib $(LIBDIR)/libf2c.a + +clean: + rm -f libf2c.a *.o arith.h signal1.h sysdep1.h + +backspac.o: fio.h +close.o: fio.h +dfe.o: fio.h +dfe.o: fmt.h +due.o: fio.h +endfile.o: fio.h rawio.h +err.o: fio.h rawio.h +fmt.o: fio.h +fmt.o: fmt.h +iio.o: fio.h +iio.o: fmt.h +ilnw.o: fio.h +ilnw.o: lio.h +inquire.o: fio.h +lread.o: fio.h +lread.o: fmt.h +lread.o: lio.h +lread.o: fp.h +lwrite.o: fio.h +lwrite.o: fmt.h +lwrite.o: lio.h +open.o: fio.h rawio.h +rdfmt.o: fio.h +rdfmt.o: fmt.h +rdfmt.o: fp.h +rewind.o: fio.h +rsfe.o: fio.h +rsfe.o: fmt.h +rsli.o: fio.h +rsli.o: lio.h +rsne.o: fio.h +rsne.o: lio.h +sfe.o: fio.h +signbit.o: arith.h +sue.o: fio.h +uio.o: fio.h +uninit.o: arith.h +util.o: fio.h +wref.o: fio.h +wref.o: fmt.h +wref.o: fp.h +wrtfmt.o: fio.h +wrtfmt.o: fmt.h +wsfe.o: fio.h +wsfe.o: fmt.h +wsle.o: fio.h +wsle.o: fmt.h +wsle.o: lio.h +wsne.o: fio.h +wsne.o: lio.h +xwsne.o: fio.h +xwsne.o: lio.h +xwsne.o: fmt.h + +arith.h: arithchk.c + $(CC) $(CFLAGS) -DNO_FPINIT arithchk.c -lm ||\ + $(CC) -DNO_LONG_LONG $(CFLAGS) -DNO_FPINIT arithchk.c -lm + ./a.out >arith.h + rm -f a.out arithchk.o + +check: + xsum Notice README abort_.c arithchk.c backspac.c c_abs.c c_cos.c \ + c_div.c c_exp.c c_log.c c_sin.c c_sqrt.c cabs.c close.c comptry.bat \ + ctype.c ctype.h \ + d_abs.c d_acos.c d_asin.c d_atan.c d_atn2.c d_cnjg.c d_cos.c d_cosh.c \ + d_dim.c d_exp.c d_imag.c d_int.c d_lg10.c d_log.c d_mod.c \ + d_nint.c d_prod.c d_sign.c d_sin.c d_sinh.c d_sqrt.c d_tan.c \ + d_tanh.c derf_.c derfc_.c dfe.c dolio.c dtime_.c due.c ef1asc_.c \ + ef1cmc_.c endfile.c erf_.c erfc_.c err.c etime_.c exit_.c f2c.h0 \ + f2ch.add f77_aloc.c f77vers.c fio.h fmt.c fmt.h fmtlib.c \ + fp.h ftell_.c ftell64_.c \ + getarg_.c getenv_.c h_abs.c h_dim.c h_dnnt.c h_indx.c h_len.c \ + h_mod.c h_nint.c h_sign.c hl_ge.c hl_gt.c hl_le.c hl_lt.c \ + i77vers.c i_abs.c i_dim.c i_dnnt.c i_indx.c i_len.c i_mod.c \ + i_nint.c i_sign.c iargc_.c iio.c ilnw.c inquire.c l_ge.c l_gt.c \ + l_le.c l_lt.c lbitbits.c lbitshft.c libf2c.lbc libf2c.sy lio.h \ + lread.c lwrite.c main.c makefile.sy makefile.u makefile.vc \ + makefile.wat math.hvc mkfile.plan9 open.c pow_ci.c pow_dd.c \ + pow_di.c pow_hh.c pow_ii.c pow_qq.c pow_ri.c pow_zi.c pow_zz.c \ + qbitbits.c qbitshft.c r_abs.c r_acos.c r_asin.c r_atan.c r_atn2.c \ + r_cnjg.c r_cos.c r_cosh.c r_dim.c r_exp.c r_imag.c r_int.c r_lg10.c \ + r_log.c r_mod.c r_nint.c r_sign.c r_sin.c r_sinh.c r_sqrt.c \ + r_tan.c r_tanh.c rawio.h rdfmt.c rewind.c rsfe.c rsli.c rsne.c \ + s_cat.c s_cmp.c s_copy.c s_paus.c s_rnge.c s_stop.c scomptry.bat sfe.c \ + sig_die.c signal1.h0 signal_.c signbit.c sue.c sysdep1.h0 system_.c \ + typesize.c \ + uio.c uninit.c util.c wref.c wrtfmt.c wsfe.c wsle.c wsne.c xwsne.c \ + z_abs.c z_cos.c z_div.c z_exp.c z_log.c z_sin.c z_sqrt.c >xsum1.out + cmp xsum0.out xsum1.out && mv xsum1.out xsum.out || diff xsum[01].out diff --git a/unix/f2c/libf2c/makefile.vc b/unix/f2c/libf2c/makefile.vc new file mode 100644 index 00000000..b3dd90c1 --- /dev/null +++ b/unix/f2c/libf2c/makefile.vc @@ -0,0 +1,195 @@ +# For making f2c.lib (here called vcf2c.lib) with Microsoft Visual C++ . +# Invoke with "nmake -f makefile.vc" . + +# To get signed zeros in write statements on IEEE-arithmetic systems, +# add -DSIGNED_ZEROS to the CFLAGS assignment below and add signbit.obj +# to the objects in the "w =" list below. + +CC = cl +CFLAGS = -DUSE_CLOCK -DMSDOS -DNO_ONEXIT -Ot1 -DNO_My_ctype -DNO_ISATTY + +.c.obj: + $(CC) -c $(CFLAGS) $*.c + +w = \ + abort_.obj \ + backspac.obj \ + c_abs.obj \ + c_cos.obj \ + c_div.obj \ + c_exp.obj \ + c_log.obj \ + c_sin.obj \ + c_sqrt.obj \ + cabs.obj \ + close.obj \ + d_abs.obj \ + d_acos.obj \ + d_asin.obj \ + d_atan.obj \ + d_atn2.obj \ + d_cnjg.obj \ + d_cos.obj \ + d_cosh.obj \ + d_dim.obj \ + d_exp.obj \ + d_imag.obj \ + d_int.obj \ + d_lg10.obj \ + d_log.obj \ + d_mod.obj \ + d_nint.obj \ + d_prod.obj \ + d_sign.obj \ + d_sin.obj \ + d_sinh.obj \ + d_sqrt.obj \ + d_tan.obj \ + d_tanh.obj \ + derf_.obj \ + derfc_.obj \ + dfe.obj \ + dolio.obj \ + dtime_.obj \ + due.obj \ + ef1asc_.obj \ + ef1cmc_.obj \ + endfile.obj \ + erf_.obj \ + erfc_.obj \ + err.obj \ + etime_.obj \ + exit_.obj \ + f77_aloc.obj \ + f77vers.obj \ + fmt.obj \ + fmtlib.obj \ + ftell_.obj \ + getarg_.obj \ + getenv_.obj \ + h_abs.obj \ + h_dim.obj \ + h_dnnt.obj \ + h_indx.obj \ + h_len.obj \ + h_mod.obj \ + h_nint.obj \ + h_sign.obj \ + hl_ge.obj \ + hl_gt.obj \ + hl_le.obj \ + hl_lt.obj \ + i77vers.obj \ + i_abs.obj \ + i_dim.obj \ + i_dnnt.obj \ + i_indx.obj \ + i_len.obj \ + i_mod.obj \ + i_nint.obj \ + i_sign.obj \ + iargc_.obj \ + iio.obj \ + ilnw.obj \ + inquire.obj \ + l_ge.obj \ + l_gt.obj \ + l_le.obj \ + l_lt.obj \ + lbitbits.obj \ + lbitshft.obj \ + lread.obj \ + lwrite.obj \ + main.obj \ + open.obj \ + pow_ci.obj \ + pow_dd.obj \ + pow_di.obj \ + pow_hh.obj \ + pow_ii.obj \ + pow_ri.obj \ + pow_zi.obj \ + pow_zz.obj \ + r_abs.obj \ + r_acos.obj \ + r_asin.obj \ + r_atan.obj \ + r_atn2.obj \ + r_cnjg.obj \ + r_cos.obj \ + r_cosh.obj \ + r_dim.obj \ + r_exp.obj \ + r_imag.obj \ + r_int.obj \ + r_lg10.obj \ + r_log.obj \ + r_mod.obj \ + r_nint.obj \ + r_sign.obj \ + r_sin.obj \ + r_sinh.obj \ + r_sqrt.obj \ + r_tan.obj \ + r_tanh.obj \ + rdfmt.obj \ + rewind.obj \ + rsfe.obj \ + rsli.obj \ + rsne.obj \ + s_cat.obj \ + s_cmp.obj \ + s_copy.obj \ + s_paus.obj \ + s_rnge.obj \ + s_stop.obj \ + sfe.obj \ + sig_die.obj \ + signal_.obj \ + sue.obj \ + system_.obj \ + typesize.obj \ + uio.obj \ + uninit.obj \ + util.obj \ + wref.obj \ + wrtfmt.obj \ + wsfe.obj \ + wsle.obj \ + wsne.obj \ + xwsne.obj \ + z_abs.obj \ + z_cos.obj \ + z_div.obj \ + z_exp.obj \ + z_log.obj \ + z_sin.obj \ + z_sqrt.obj + +all: f2c.h math.h signal1.h sysdep1.h vcf2c.lib + +f2c.h: f2c.h0 + copy f2c.h0 f2c.h + +math.h: math.hvc + copy math.hvc math.h + +signal1.h: signal1.h0 + copy signal1.h0 signal1.h + +sysdep1.h: sysdep1.h0 + copy sysdep1.h0 sysdep1.h + +vcf2c.lib: $w + lib -out:vcf2c.lib @libf2c.lbc + +open.obj: open.c + $(CC) -c $(CFLAGS) -DMSDOS open.c + +signbit.obj uninit.obj: arith.h + +arith.h: arithchk.c + comptry.bat $(CC) $(CFLAGS) -DNO_FPINIT arithchk.c + arithchk >arith.h + del arithchk.exe + del arithchk.obj diff --git a/unix/f2c/libf2c/makefile.wat b/unix/f2c/libf2c/makefile.wat new file mode 100644 index 00000000..a81c06d6 --- /dev/null +++ b/unix/f2c/libf2c/makefile.wat @@ -0,0 +1,189 @@ +# For making f2c.lib (here called watf2c.lib) with WATCOM C/C++ . +# Invoke with "wmake -u -f makefile.wat" . +# In the CFLAGS line below, "-bt=nt" is for NT and W9x. +# With WATCOM, it is necessary to explicitly load main.obj . + +# To get signed zeros in write statements on IEEE-arithmetic systems, +# add -DSIGNED_ZEROS to the CFLAGS assignment below and add signbit.obj +# to the objects in the "w =" list below. + +CC = wcc386 +CFLAGS = -fpd -DMSDOS -DUSE_CLOCK -DNO_ONEXIT -bt=nt -DNO_My_ctype + +.c.obj: + $(CC) $(CFLAGS) $*.c + +w = \ + abort_.obj \ + backspac.obj \ + c_abs.obj \ + c_cos.obj \ + c_div.obj \ + c_exp.obj \ + c_log.obj \ + c_sin.obj \ + c_sqrt.obj \ + cabs.obj \ + close.obj \ + d_abs.obj \ + d_acos.obj \ + d_asin.obj \ + d_atan.obj \ + d_atn2.obj \ + d_cnjg.obj \ + d_cos.obj \ + d_cosh.obj \ + d_dim.obj \ + d_exp.obj \ + d_imag.obj \ + d_int.obj \ + d_lg10.obj \ + d_log.obj \ + d_mod.obj \ + d_nint.obj \ + d_prod.obj \ + d_sign.obj \ + d_sin.obj \ + d_sinh.obj \ + d_sqrt.obj \ + d_tan.obj \ + d_tanh.obj \ + derf_.obj \ + derfc_.obj \ + dfe.obj \ + dolio.obj \ + dtime_.obj \ + due.obj \ + ef1asc_.obj \ + ef1cmc_.obj \ + endfile.obj \ + erf_.obj \ + erfc_.obj \ + err.obj \ + etime_.obj \ + exit_.obj \ + f77_aloc.obj \ + f77vers.obj \ + fmt.obj \ + fmtlib.obj \ + ftell_.obj \ + getarg_.obj \ + getenv_.obj \ + h_abs.obj \ + h_dim.obj \ + h_dnnt.obj \ + h_indx.obj \ + h_len.obj \ + h_mod.obj \ + h_nint.obj \ + h_sign.obj \ + hl_ge.obj \ + hl_gt.obj \ + hl_le.obj \ + hl_lt.obj \ + i77vers.obj \ + i_abs.obj \ + i_dim.obj \ + i_dnnt.obj \ + i_indx.obj \ + i_len.obj \ + i_mod.obj \ + i_nint.obj \ + i_sign.obj \ + iargc_.obj \ + iio.obj \ + ilnw.obj \ + inquire.obj \ + l_ge.obj \ + l_gt.obj \ + l_le.obj \ + l_lt.obj \ + lbitbits.obj \ + lbitshft.obj \ + lread.obj \ + lwrite.obj \ + main.obj \ + open.obj \ + pow_ci.obj \ + pow_dd.obj \ + pow_di.obj \ + pow_hh.obj \ + pow_ii.obj \ + pow_ri.obj \ + pow_zi.obj \ + pow_zz.obj \ + r_abs.obj \ + r_acos.obj \ + r_asin.obj \ + r_atan.obj \ + r_atn2.obj \ + r_cnjg.obj \ + r_cos.obj \ + r_cosh.obj \ + r_dim.obj \ + r_exp.obj \ + r_imag.obj \ + r_int.obj \ + r_lg10.obj \ + r_log.obj \ + r_mod.obj \ + r_nint.obj \ + r_sign.obj \ + r_sin.obj \ + r_sinh.obj \ + r_sqrt.obj \ + r_tan.obj \ + r_tanh.obj \ + rdfmt.obj \ + rewind.obj \ + rsfe.obj \ + rsli.obj \ + rsne.obj \ + s_cat.obj \ + s_cmp.obj \ + s_copy.obj \ + s_paus.obj \ + s_rnge.obj \ + s_stop.obj \ + sfe.obj \ + sig_die.obj \ + signal_.obj \ + sue.obj \ + system_.obj \ + typesize.obj \ + uio.obj \ + uninit.obj \ + util.obj \ + wref.obj \ + wrtfmt.obj \ + wsfe.obj \ + wsle.obj \ + wsne.obj \ + xwsne.obj \ + z_abs.obj \ + z_cos.obj \ + z_div.obj \ + z_exp.obj \ + z_log.obj \ + z_sin.obj \ + z_sqrt.obj + +watf2c.lib: f2c.h signal1.h sysdep1.h $w + wlib -c watf2c.lib @libf2c + +f2c.h: f2c.h0 + copy f2c.h0 f2c.h + +signal1.h: signal1.h0 + copy signal1.h0 signal1.h + +sysdep1.h: sysdep1.h0 + copy sysdep1.h0 sysdep1.h + +signbit.obj uninit.obj: arith.h + +arith.h: arithchk.c + comptry.bat wcl386 -DNO_FPINIT arithchk.c + arithchk >arith.h + del arithchk.exe + del arithchk.obj diff --git a/unix/f2c/libf2c/math.hvc b/unix/f2c/libf2c/math.hvc new file mode 100644 index 00000000..52cfcee0 --- /dev/null +++ b/unix/f2c/libf2c/math.hvc @@ -0,0 +1,3 @@ +/* for VC 4.2 */ +#include <math.h> +#undef complex diff --git a/unix/f2c/libf2c/mkfile.plan9 b/unix/f2c/libf2c/mkfile.plan9 new file mode 100644 index 00000000..645e33d6 --- /dev/null +++ b/unix/f2c/libf2c/mkfile.plan9 @@ -0,0 +1,162 @@ +# Plan 9 mkfile for libf2c.a$O + +</$objtype/mkfile + +CC = pcc +CFLAGS = -D_POSIX_SOURCE -DNON_UNIX_STDIO -DNO_TRUNCATE + +%.$O: %.c + $CC -c $CFLAGS $stem.c + +MISC = f77vers.$O i77vers.$O main.$O s_rnge.$O abort_.$O exit_.$O\ + getarg_.$O iargc_.$O\ + getenv_.$O signal_.$O s_stop.$O s_paus.$O system_.$O cabs.$O\ + derf_.$O derfc_.$O erf_.$O erfc_.$O sig_die.$O uninit.$O +POW = pow_ci.$O pow_dd.$O pow_di.$O pow_hh.$O pow_ii.$O pow_ri.$O\ + pow_zi.$O pow_zz.$O +CX = c_abs.$O c_cos.$O c_div.$O c_exp.$O c_log.$O c_sin.$O c_sqrt.$O +DCX = z_abs.$O z_cos.$O z_div.$O z_exp.$O z_log.$O z_sin.$O z_sqrt.$O +REAL = r_abs.$O r_acos.$O r_asin.$O r_atan.$O r_atn2.$O r_cnjg.$O r_cos.$O\ + r_cosh.$O r_dim.$O r_exp.$O r_imag.$O r_int.$O\ + r_lg10.$O r_log.$O r_mod.$O r_nint.$O r_sign.$O\ + r_sin.$O r_sinh.$O r_sqrt.$O r_tan.$O r_tanh.$O +DBL = d_abs.$O d_acos.$O d_asin.$O d_atan.$O d_atn2.$O\ + d_cnjg.$O d_cos.$O d_cosh.$O d_dim.$O d_exp.$O\ + d_imag.$O d_int.$O d_lg10.$O d_log.$O d_mod.$O\ + d_nint.$O d_prod.$O d_sign.$O d_sin.$O d_sinh.$O\ + d_sqrt.$O d_tan.$O d_tanh.$O +INT = i_abs.$O i_dim.$O i_dnnt.$O i_indx.$O i_len.$O i_mod.$O\ + i_nint.$O i_sign.$O lbitbits.$O lbitshft.$O +HALF = h_abs.$O h_dim.$O h_dnnt.$O h_indx.$O h_len.$O h_mod.$O\ + h_nint.$O h_sign.$O +CMP = l_ge.$O l_gt.$O l_le.$O l_lt.$O hl_ge.$O hl_gt.$O hl_le.$O hl_lt.$O +EFL = ef1asc_.$O ef1cmc_.$O +CHAR = f77_aloc.$O s_cat.$O s_cmp.$O s_copy.$O +I77 = backspac.$O close.$O dfe.$O dolio.$O due.$O endfile.$O err.$O\ + fmt.$O fmtlib.$O ftell_.$O iio.$O ilnw.$O inquire.$O lread.$O\ + lwrite.$O open.$O rdfmt.$O rewind.$O rsfe.$O rsli.$O rsne.$O\ + sfe.$O sue.$O typesize.$O uio.$O util.$O wref.$O wrtfmt.$O\ + wsfe.$O wsle.$O wsne.$O xwsne.$O +QINT = pow_qq.$O qbitbits.$O qbitshft.$O +TIME = dtime_.$O etime_.$O + +# pcc does not currently (20010222) understand unsigned long long +# so we omit $QINT from the dependency list for libf2c.a$O. + +all:N: f2c.h signal1.h libf2c.a$O + +libf2c.a$O: $MISC $POW $CX $DCX $REAL $DBL $INT \ + $HALF $CMP $EFL $CHAR $I77 $TIME + ar r $target $newprereq + rm $newprereq + +### If your system lacks ranlib, you don't need it; see README.; set -e + +f77vers.$O: f77vers.c + $CC -c f77vers.c + +i77vers.$O: i77vers.c + $CC -c i77vers.c + +# To get an "f2c.h" for use with "f2c -C++", first "make hadd" +hadd: f2c.h0 f2ch.add + cat f2c.h0 f2ch.add >f2c.h + +# For use with "f2c" and "f2c -A": +f2c.h: f2c.h0 + cp f2c.h0 f2c.h + +# You may need to adjust signal1.h suitably for your system... +signal1.h: signal1.h0 + cp signal1.h0 signal1.h + +clean: + rm -f libf2c.a$O *.$O arith.h + +backspac.$O: fio.h +close.$O: fio.h +dfe.$O: fio.h +dfe.$O: fmt.h +due.$O: fio.h +endfile.$O: fio.h rawio.h +err.$O: fio.h rawio.h +fmt.$O: fio.h +fmt.$O: fmt.h +iio.$O: fio.h +iio.$O: fmt.h +ilnw.$O: fio.h +ilnw.$O: lio.h +inquire.$O: fio.h +lread.$O: fio.h +lread.$O: fmt.h +lread.$O: lio.h +lread.$O: fp.h +lwrite.$O: fio.h +lwrite.$O: fmt.h +lwrite.$O: lio.h +open.$O: fio.h rawio.h +rdfmt.$O: fio.h +rdfmt.$O: fmt.h +rdfmt.$O: fp.h +rewind.$O: fio.h +rsfe.$O: fio.h +rsfe.$O: fmt.h +rsli.$O: fio.h +rsli.$O: lio.h +rsne.$O: fio.h +rsne.$O: lio.h +sfe.$O: fio.h +sue.$O: fio.h +uio.$O: fio.h +uninit.$O: arith.h +util.$O: fio.h +wref.$O: fio.h +wref.$O: fmt.h +wref.$O: fp.h +wrtfmt.$O: fio.h +wrtfmt.$O: fmt.h +wsfe.$O: fio.h +wsfe.$O: fmt.h +wsle.$O: fio.h +wsle.$O: fmt.h +wsle.$O: lio.h +wsne.$O: fio.h +wsne.$O: lio.h +xwsne.$O: fio.h +xwsne.$O: lio.h +xwsne.$O: fmt.h + +arith.h: arithchk.c + pcc -DNO_FPINIT -o arithchk arithchk.c + arithchk >$target + rm arithchk + +xsum.out:V: check + +check: + xsum Notice README abort_.c arithchk.c backspac.c c_abs.c c_cos.c \ + c_div.c c_exp.c c_log.c c_sin.c c_sqrt.c cabs.c close.c comptry.bat \ + d_abs.c d_acos.c d_asin.c d_atan.c d_atn2.c d_cnjg.c d_cos.c d_cosh.c \ + d_dim.c d_exp.c d_imag.c d_int.c d_lg10.c d_log.c d_mod.c \ + d_nint.c d_prod.c d_sign.c d_sin.c d_sinh.c d_sqrt.c d_tan.c \ + d_tanh.c derf_.c derfc_.c dfe.c dolio.c dtime_.c due.c ef1asc_.c \ + ef1cmc_.c endfile.c erf_.c erfc_.c err.c etime_.c exit_.c f2c.h0 \ + f2ch.add f77_aloc.c f77vers.c fio.h fmt.c fmt.h fmtlib.c \ + fp.h ftell_.c \ + getarg_.c getenv_.c h_abs.c h_dim.c h_dnnt.c h_indx.c h_len.c \ + h_mod.c h_nint.c h_sign.c hl_ge.c hl_gt.c hl_le.c hl_lt.c \ + i77vers.c i_abs.c i_dim.c i_dnnt.c i_indx.c i_len.c i_mod.c \ + i_nint.c i_sign.c iargc_.c iio.c ilnw.c inquire.c l_ge.c l_gt.c \ + l_le.c l_lt.c lbitbits.c lbitshft.c libf2c.lbc libf2c.sy lio.h \ + lread.c lwrite.c main.c makefile.sy makefile.u makefile.vc \ + makefile.wat math.hvc mkfile.plan9 open.c pow_ci.c pow_dd.c \ + pow_di.c pow_hh.c pow_ii.c pow_qq.c pow_ri.c pow_zi.c pow_zz.c \ + qbitbits.c qbitshft.c r_abs.c r_acos.c r_asin.c r_atan.c r_atn2.c \ + r_cnjg.c r_cos.c r_cosh.c r_dim.c r_exp.c r_imag.c r_int.c r_lg10.c \ + r_log.c r_mod.c r_nint.c r_sign.c r_sin.c r_sinh.c r_sqrt.c \ + r_tan.c r_tanh.c rawio.h rdfmt.c rewind.c rsfe.c rsli.c rsne.c \ + s_cat.c s_cmp.c s_copy.c s_paus.c s_rnge.c s_stop.c sfe.c \ + sig_die.c signal1.h0 signal_.c sue.c system_.c typesize.c uio.c \ + uninit.c util.c wref.c wrtfmt.c wsfe.c wsle.c wsne.c xwsne.c \ + z_abs.c z_cos.c z_div.c z_exp.c z_log.c z_sin.c z_sqrt.c >xsum1.out + cmp xsum0.out xsum1.out && mv xsum1.out xsum.out || diff xsum[01].out diff --git a/unix/f2c/libf2c/mkpkg.sh b/unix/f2c/libf2c/mkpkg.sh new file mode 100644 index 00000000..39438572 --- /dev/null +++ b/unix/f2c/libf2c/mkpkg.sh @@ -0,0 +1,5 @@ +# Bootstrap the F2C compiler and libraries. + +make -f makefile.u +mv libf2c.a ../../bin/ +rm *.[aeo] diff --git a/unix/f2c/libf2c/open.c b/unix/f2c/libf2c/open.c new file mode 100644 index 00000000..a06428dd --- /dev/null +++ b/unix/f2c/libf2c/open.c @@ -0,0 +1,301 @@ +#include "f2c.h" +#include "fio.h" +#include "string.h" +#ifndef NON_POSIX_STDIO +#ifdef MSDOS +#include "io.h" +#else +#include "unistd.h" /* for access */ +#endif +#endif + +#ifdef KR_headers +extern char *malloc(); +#ifdef NON_ANSI_STDIO +extern char *mktemp(); +#endif +extern integer f_clos(); +#define Const /*nothing*/ +#else +#define Const const +#undef abs +#undef min +#undef max +#include "stdlib.h" +#ifdef __cplusplus +extern "C" { +#endif +extern int f__canseek(FILE*); +extern integer f_clos(cllist*); +#endif + +#ifdef NON_ANSI_RW_MODES +Const char *f__r_mode[2] = {"r", "r"}; +Const char *f__w_mode[4] = {"w", "w", "r+w", "r+w"}; +#else +Const char *f__r_mode[2] = {"rb", "r"}; +Const char *f__w_mode[4] = {"wb", "w", "r+b", "r+"}; +#endif + + static char f__buf0[400], *f__buf = f__buf0; + int f__buflen = (int)sizeof(f__buf0); + + static void +#ifdef KR_headers +f__bufadj(n, c) int n, c; +#else +f__bufadj(int n, int c) +#endif +{ + unsigned int len; + char *nbuf, *s, *t, *te; + + if (f__buf == f__buf0) + f__buflen = 1024; + while(f__buflen <= n) + f__buflen <<= 1; + len = (unsigned int)f__buflen; + if (len != f__buflen || !(nbuf = (char*)malloc(len))) + f__fatal(113, "malloc failure"); + s = nbuf; + t = f__buf; + te = t + c; + while(t < te) + *s++ = *t++; + if (f__buf != f__buf0) + free(f__buf); + f__buf = nbuf; + } + + int +#ifdef KR_headers +f__putbuf(c) int c; +#else +f__putbuf(int c) +#endif +{ + char *s, *se; + int n; + + if (f__hiwater > f__recpos) + f__recpos = f__hiwater; + n = f__recpos + 1; + if (n >= f__buflen) + f__bufadj(n, f__recpos); + s = f__buf; + se = s + f__recpos; + if (c) + *se++ = c; + *se = 0; + for(;;) { + fputs(s, f__cf); + s += strlen(s); + if (s >= se) + break; /* normally happens the first time */ + putc(*s++, f__cf); + } + return 0; + } + + void +#ifdef KR_headers +x_putc(c) +#else +x_putc(int c) +#endif +{ + if (f__recpos >= f__buflen) + f__bufadj(f__recpos, f__buflen); + f__buf[f__recpos++] = c; + } + +#define opnerr(f,m,s) {if(f) errno= m; else opn_err(m,s,a); return(m);} + + static void +#ifdef KR_headers +opn_err(m, s, a) int m; char *s; olist *a; +#else +opn_err(int m, const char *s, olist *a) +#endif +{ + if (a->ofnm) { + /* supply file name to error message */ + if (a->ofnmlen >= f__buflen) + f__bufadj((int)a->ofnmlen, 0); + g_char(a->ofnm, a->ofnmlen, f__curunit->ufnm = f__buf); + } + f__fatal(m, s); + } + +#ifdef KR_headers +integer f_open(a) olist *a; +#else +integer f_open(olist *a) +#endif +{ unit *b; + integer rv; + char buf[256], *s; + cllist x; + int ufmt; + FILE *tf; +#ifndef NON_UNIX_STDIO + int n; +#endif + f__external = 1; + if(a->ounit>=MXUNIT || a->ounit<0) + err(a->oerr,101,"open") + if (!f__init) + f_init(); + f__curunit = b = &f__units[a->ounit]; + if(b->ufd) { + if(a->ofnm==0) + { + same: if (a->oblnk) + b->ublnk = *a->oblnk == 'z' || *a->oblnk == 'Z'; + return(0); + } +#ifdef NON_UNIX_STDIO + if (b->ufnm + && strlen(b->ufnm) == a->ofnmlen + && !strncmp(b->ufnm, a->ofnm, (unsigned)a->ofnmlen)) + goto same; +#else + g_char(a->ofnm,a->ofnmlen,buf); + if (f__inode(buf,&n) == b->uinode && n == b->udev) + goto same; +#endif + x.cunit=a->ounit; + x.csta=0; + x.cerr=a->oerr; + if ((rv = f_clos(&x)) != 0) + return rv; + } + b->url = (int)a->orl; + b->ublnk = a->oblnk && (*a->oblnk == 'z' || *a->oblnk == 'Z'); + if(a->ofm==0) + { if(b->url>0) b->ufmt=0; + else b->ufmt=1; + } + else if(*a->ofm=='f' || *a->ofm == 'F') b->ufmt=1; + else b->ufmt=0; + ufmt = b->ufmt; +#ifdef url_Adjust + if (b->url && !ufmt) + url_Adjust(b->url); +#endif + if (a->ofnm) { + g_char(a->ofnm,a->ofnmlen,buf); + if (!buf[0]) + opnerr(a->oerr,107,"open") + } + else + sprintf(buf, "fort.%ld", (long)a->ounit); + b->uscrtch = 0; + b->uend=0; + b->uwrt = 0; + b->ufd = 0; + b->urw = 3; + switch(a->osta ? *a->osta : 'u') + { + case 'o': + case 'O': +#ifdef NON_POSIX_STDIO + if (!(tf = FOPEN(buf,"r"))) + opnerr(a->oerr,errno,"open") + fclose(tf); +#else + if (access(buf,0)) + opnerr(a->oerr,errno,"open") +#endif + break; + case 's': + case 'S': + b->uscrtch=1; +#ifdef NON_ANSI_STDIO + (void) strcpy(buf,"tmp.FXXXXXX"); + (void) mktemp(buf); + goto replace; +#else + if (!(b->ufd = tmpfile())) + opnerr(a->oerr,errno,"open") + b->ufnm = 0; +#ifndef NON_UNIX_STDIO + b->uinode = b->udev = -1; +#endif + b->useek = 1; + return 0; +#endif + + case 'n': + case 'N': +#ifdef NON_POSIX_STDIO + if ((tf = FOPEN(buf,"r")) || (tf = FOPEN(buf,"a"))) { + fclose(tf); + opnerr(a->oerr,128,"open") + } +#else + if (!access(buf,0)) + opnerr(a->oerr,128,"open") +#endif + /* no break */ + case 'r': /* Fortran 90 replace option */ + case 'R': +#ifdef NON_ANSI_STDIO + replace: +#endif + if (tf = FOPEN(buf,f__w_mode[0])) + fclose(tf); + } + + b->ufnm=(char *) malloc((unsigned int)(strlen(buf)+1)); + if(b->ufnm==NULL) opnerr(a->oerr,113,"no space"); + (void) strcpy(b->ufnm,buf); + if ((s = a->oacc) && b->url) + ufmt = 0; + if(!(tf = FOPEN(buf, f__w_mode[ufmt|2]))) { + if (tf = FOPEN(buf, f__r_mode[ufmt])) + b->urw = 1; + else if (tf = FOPEN(buf, f__w_mode[ufmt])) { + b->uwrt = 1; + b->urw = 2; + } + else + err(a->oerr, errno, "open"); + } + b->useek = f__canseek(b->ufd = tf); +#ifndef NON_UNIX_STDIO + if((b->uinode = f__inode(buf,&b->udev)) == -1) + opnerr(a->oerr,108,"open") +#endif + if(b->useek) + if (a->orl) + rewind(b->ufd); + else if ((s = a->oacc) && (*s == 'a' || *s == 'A') + && FSEEK(b->ufd, 0L, SEEK_END)) + opnerr(a->oerr,129,"open"); + return(0); +} + + int +#ifdef KR_headers +fk_open(seq,fmt,n) ftnint n; +#else +fk_open(int seq, int fmt, ftnint n) +#endif +{ char nbuf[10]; + olist a; + (void) sprintf(nbuf,"fort.%ld",(long)n); + a.oerr=1; + a.ounit=n; + a.ofnm=nbuf; + a.ofnmlen=strlen(nbuf); + a.osta=NULL; + a.oacc= (char*)(seq==SEQ?"s":"d"); + a.ofm = (char*)(fmt==FMT?"f":"u"); + a.orl = seq==DIR?1:0; + a.oblnk=NULL; + return(f_open(&a)); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/pow_ci.c b/unix/f2c/libf2c/pow_ci.c new file mode 100644 index 00000000..574e0b1e --- /dev/null +++ b/unix/f2c/libf2c/pow_ci.c @@ -0,0 +1,26 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +VOID pow_ci(p, a, b) /* p = a**b */ + complex *p, *a; integer *b; +#else +extern void pow_zi(doublecomplex*, doublecomplex*, integer*); +void pow_ci(complex *p, complex *a, integer *b) /* p = a**b */ +#endif +{ +doublecomplex p1, a1; + +a1.r = a->r; +a1.i = a->i; + +pow_zi(&p1, &a1, b); + +p->r = p1.r; +p->i = p1.i; +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/pow_dd.c b/unix/f2c/libf2c/pow_dd.c new file mode 100644 index 00000000..08fc2088 --- /dev/null +++ b/unix/f2c/libf2c/pow_dd.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double pow(); +double pow_dd(ap, bp) doublereal *ap, *bp; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double pow_dd(doublereal *ap, doublereal *bp) +#endif +{ +return(pow(*ap, *bp) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/pow_di.c b/unix/f2c/libf2c/pow_di.c new file mode 100644 index 00000000..abf36cb7 --- /dev/null +++ b/unix/f2c/libf2c/pow_di.c @@ -0,0 +1,41 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +double pow_di(ap, bp) doublereal *ap; integer *bp; +#else +double pow_di(doublereal *ap, integer *bp) +#endif +{ +double pow, x; +integer n; +unsigned long u; + +pow = 1; +x = *ap; +n = *bp; + +if(n != 0) + { + if(n < 0) + { + n = -n; + x = 1/x; + } + for(u = n; ; ) + { + if(u & 01) + pow *= x; + if(u >>= 1) + x *= x; + else + break; + } + } +return(pow); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/pow_hh.c b/unix/f2c/libf2c/pow_hh.c new file mode 100644 index 00000000..88216850 --- /dev/null +++ b/unix/f2c/libf2c/pow_hh.c @@ -0,0 +1,39 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +shortint pow_hh(ap, bp) shortint *ap, *bp; +#else +shortint pow_hh(shortint *ap, shortint *bp) +#endif +{ + shortint pow, x, n; + unsigned u; + + x = *ap; + n = *bp; + + if (n <= 0) { + if (n == 0 || x == 1) + return 1; + if (x != -1) + return x == 0 ? 1/x : 0; + n = -n; + } + u = n; + for(pow = 1; ; ) + { + if(u & 01) + pow *= x; + if(u >>= 1) + x *= x; + else + break; + } + return(pow); + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/pow_ii.c b/unix/f2c/libf2c/pow_ii.c new file mode 100644 index 00000000..748d1217 --- /dev/null +++ b/unix/f2c/libf2c/pow_ii.c @@ -0,0 +1,39 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +integer pow_ii(ap, bp) integer *ap, *bp; +#else +integer pow_ii(integer *ap, integer *bp) +#endif +{ + integer pow, x, n; + unsigned long u; + + x = *ap; + n = *bp; + + if (n <= 0) { + if (n == 0 || x == 1) + return 1; + if (x != -1) + return x == 0 ? 1/x : 0; + n = -n; + } + u = n; + for(pow = 1; ; ) + { + if(u & 01) + pow *= x; + if(u >>= 1) + x *= x; + else + break; + } + return(pow); + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/pow_qq.c b/unix/f2c/libf2c/pow_qq.c new file mode 100644 index 00000000..09fe18ec --- /dev/null +++ b/unix/f2c/libf2c/pow_qq.c @@ -0,0 +1,39 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +longint pow_qq(ap, bp) longint *ap, *bp; +#else +longint pow_qq(longint *ap, longint *bp) +#endif +{ + longint pow, x, n; + unsigned long long u; /* system-dependent */ + + x = *ap; + n = *bp; + + if (n <= 0) { + if (n == 0 || x == 1) + return 1; + if (x != -1) + return x == 0 ? 1/x : 0; + n = -n; + } + u = n; + for(pow = 1; ; ) + { + if(u & 01) + pow *= x; + if(u >>= 1) + x *= x; + else + break; + } + return(pow); + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/pow_ri.c b/unix/f2c/libf2c/pow_ri.c new file mode 100644 index 00000000..e29d416e --- /dev/null +++ b/unix/f2c/libf2c/pow_ri.c @@ -0,0 +1,41 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +double pow_ri(ap, bp) real *ap; integer *bp; +#else +double pow_ri(real *ap, integer *bp) +#endif +{ +double pow, x; +integer n; +unsigned long u; + +pow = 1; +x = *ap; +n = *bp; + +if(n != 0) + { + if(n < 0) + { + n = -n; + x = 1/x; + } + for(u = n; ; ) + { + if(u & 01) + pow *= x; + if(u >>= 1) + x *= x; + else + break; + } + } +return(pow); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/pow_zi.c b/unix/f2c/libf2c/pow_zi.c new file mode 100644 index 00000000..1c0a4b07 --- /dev/null +++ b/unix/f2c/libf2c/pow_zi.c @@ -0,0 +1,60 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +VOID pow_zi(p, a, b) /* p = a**b */ + doublecomplex *p, *a; integer *b; +#else +extern void z_div(doublecomplex*, doublecomplex*, doublecomplex*); +void pow_zi(doublecomplex *p, doublecomplex *a, integer *b) /* p = a**b */ +#endif +{ + integer n; + unsigned long u; + double t; + doublecomplex q, x; + static doublecomplex one = {1.0, 0.0}; + + n = *b; + q.r = 1; + q.i = 0; + + if(n == 0) + goto done; + if(n < 0) + { + n = -n; + z_div(&x, &one, a); + } + else + { + x.r = a->r; + x.i = a->i; + } + + for(u = n; ; ) + { + if(u & 01) + { + t = q.r * x.r - q.i * x.i; + q.i = q.r * x.i + q.i * x.r; + q.r = t; + } + if(u >>= 1) + { + t = x.r * x.r - x.i * x.i; + x.i = 2 * x.r * x.i; + x.r = t; + } + else + break; + } + done: + p->i = q.i; + p->r = q.r; + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/pow_zz.c b/unix/f2c/libf2c/pow_zz.c new file mode 100644 index 00000000..b5ffd334 --- /dev/null +++ b/unix/f2c/libf2c/pow_zz.c @@ -0,0 +1,29 @@ +#include "f2c.h" + +#ifdef KR_headers +double log(), exp(), cos(), sin(), atan2(), f__cabs(); +VOID pow_zz(r,a,b) doublecomplex *r, *a, *b; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +extern double f__cabs(double,double); +void pow_zz(doublecomplex *r, doublecomplex *a, doublecomplex *b) +#endif +{ +double logr, logi, x, y; + +logr = log( f__cabs(a->r, a->i) ); +logi = atan2(a->i, a->r); + +x = exp( logr * b->r - logi * b->i ); +y = logr * b->i + logi * b->r; + +r->r = x * cos(y); +r->i = x * sin(y); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/qbitbits.c b/unix/f2c/libf2c/qbitbits.c new file mode 100644 index 00000000..ba1b5bd0 --- /dev/null +++ b/unix/f2c/libf2c/qbitbits.c @@ -0,0 +1,72 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifndef LONGBITS +#define LONGBITS 32 +#endif + +#ifndef LONG8BITS +#define LONG8BITS (2*LONGBITS) +#endif + + longint +#ifdef KR_headers +qbit_bits(a, b, len) longint a; integer b, len; +#else +qbit_bits(longint a, integer b, integer len) +#endif +{ + /* Assume 2's complement arithmetic */ + + ulongint x, y; + + x = (ulongint) a; + y = (ulongint)-1L; + x >>= b; + y <<= len; + return (longint)(x & ~y); + } + + longint +#ifdef KR_headers +qbit_cshift(a, b, len) longint a; integer b, len; +#else +qbit_cshift(longint a, integer b, integer len) +#endif +{ + ulongint x, y, z; + + x = (ulongint)a; + if (len <= 0) { + if (len == 0) + return 0; + goto full_len; + } + if (len >= LONG8BITS) { + full_len: + if (b >= 0) { + b %= LONG8BITS; + return (longint)(x << b | x >> LONG8BITS - b ); + } + b = -b; + b %= LONG8BITS; + return (longint)(x << LONG8BITS - b | x >> b); + } + y = z = (unsigned long)-1; + y <<= len; + z &= ~y; + y &= x; + x &= z; + if (b >= 0) { + b %= len; + return (longint)(y | z & (x << b | x >> len - b)); + } + b = -b; + b %= len; + return (longint)(y | z & (x >> b | x << len - b)); + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/qbitshft.c b/unix/f2c/libf2c/qbitshft.c new file mode 100644 index 00000000..78e7b951 --- /dev/null +++ b/unix/f2c/libf2c/qbitshft.c @@ -0,0 +1,17 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + + longint +#ifdef KR_headers +qbit_shift(a, b) longint a; integer b; +#else +qbit_shift(longint a, integer b) +#endif +{ + return b >= 0 ? a << b : (longint)((ulongint)a >> -b); + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/r_abs.c b/unix/f2c/libf2c/r_abs.c new file mode 100644 index 00000000..f3291fb4 --- /dev/null +++ b/unix/f2c/libf2c/r_abs.c @@ -0,0 +1,18 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +double r_abs(x) real *x; +#else +double r_abs(real *x) +#endif +{ +if(*x >= 0) + return(*x); +return(- *x); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/r_acos.c b/unix/f2c/libf2c/r_acos.c new file mode 100644 index 00000000..103c7ff0 --- /dev/null +++ b/unix/f2c/libf2c/r_acos.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double acos(); +double r_acos(x) real *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double r_acos(real *x) +#endif +{ +return( acos(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/r_asin.c b/unix/f2c/libf2c/r_asin.c new file mode 100644 index 00000000..432b9406 --- /dev/null +++ b/unix/f2c/libf2c/r_asin.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double asin(); +double r_asin(x) real *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double r_asin(real *x) +#endif +{ +return( asin(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/r_atan.c b/unix/f2c/libf2c/r_atan.c new file mode 100644 index 00000000..7656982d --- /dev/null +++ b/unix/f2c/libf2c/r_atan.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double atan(); +double r_atan(x) real *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double r_atan(real *x) +#endif +{ +return( atan(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/r_atn2.c b/unix/f2c/libf2c/r_atn2.c new file mode 100644 index 00000000..ab957b89 --- /dev/null +++ b/unix/f2c/libf2c/r_atn2.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double atan2(); +double r_atn2(x,y) real *x, *y; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double r_atn2(real *x, real *y) +#endif +{ +return( atan2(*x,*y) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/r_cnjg.c b/unix/f2c/libf2c/r_cnjg.c new file mode 100644 index 00000000..cef0e4b0 --- /dev/null +++ b/unix/f2c/libf2c/r_cnjg.c @@ -0,0 +1,18 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +VOID r_cnjg(r, z) complex *r, *z; +#else +VOID r_cnjg(complex *r, complex *z) +#endif +{ + real zi = z->i; + r->r = z->r; + r->i = -zi; + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/r_cos.c b/unix/f2c/libf2c/r_cos.c new file mode 100644 index 00000000..4418f0c1 --- /dev/null +++ b/unix/f2c/libf2c/r_cos.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double cos(); +double r_cos(x) real *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double r_cos(real *x) +#endif +{ +return( cos(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/r_cosh.c b/unix/f2c/libf2c/r_cosh.c new file mode 100644 index 00000000..f5478355 --- /dev/null +++ b/unix/f2c/libf2c/r_cosh.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double cosh(); +double r_cosh(x) real *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double r_cosh(real *x) +#endif +{ +return( cosh(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/r_dim.c b/unix/f2c/libf2c/r_dim.c new file mode 100644 index 00000000..d573ca36 --- /dev/null +++ b/unix/f2c/libf2c/r_dim.c @@ -0,0 +1,16 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +double r_dim(a,b) real *a, *b; +#else +double r_dim(real *a, real *b) +#endif +{ +return( *a > *b ? *a - *b : 0); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/r_exp.c b/unix/f2c/libf2c/r_exp.c new file mode 100644 index 00000000..4e679794 --- /dev/null +++ b/unix/f2c/libf2c/r_exp.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double exp(); +double r_exp(x) real *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double r_exp(real *x) +#endif +{ +return( exp(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/r_imag.c b/unix/f2c/libf2c/r_imag.c new file mode 100644 index 00000000..1b4de143 --- /dev/null +++ b/unix/f2c/libf2c/r_imag.c @@ -0,0 +1,16 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +double r_imag(z) complex *z; +#else +double r_imag(complex *z) +#endif +{ +return(z->i); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/r_int.c b/unix/f2c/libf2c/r_int.c new file mode 100644 index 00000000..bff87176 --- /dev/null +++ b/unix/f2c/libf2c/r_int.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double floor(); +double r_int(x) real *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double r_int(real *x) +#endif +{ +return( (*x>0) ? floor(*x) : -floor(- *x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/r_lg10.c b/unix/f2c/libf2c/r_lg10.c new file mode 100644 index 00000000..64ffddf4 --- /dev/null +++ b/unix/f2c/libf2c/r_lg10.c @@ -0,0 +1,21 @@ +#include "f2c.h" + +#define log10e 0.43429448190325182765 + +#ifdef KR_headers +double log(); +double r_lg10(x) real *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double r_lg10(real *x) +#endif +{ +return( log10e * log(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/r_log.c b/unix/f2c/libf2c/r_log.c new file mode 100644 index 00000000..94c79b05 --- /dev/null +++ b/unix/f2c/libf2c/r_log.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double log(); +double r_log(x) real *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double r_log(real *x) +#endif +{ +return( log(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/r_mod.c b/unix/f2c/libf2c/r_mod.c new file mode 100644 index 00000000..63ed1753 --- /dev/null +++ b/unix/f2c/libf2c/r_mod.c @@ -0,0 +1,46 @@ +#include "f2c.h" + +#ifdef KR_headers +#ifdef IEEE_drem +double drem(); +#else +double floor(); +#endif +double r_mod(x,y) real *x, *y; +#else +#ifdef IEEE_drem +double drem(double, double); +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +#endif +double r_mod(real *x, real *y) +#endif +{ +#ifdef IEEE_drem + double xa, ya, z; + if ((ya = *y) < 0.) + ya = -ya; + z = drem(xa = *x, ya); + if (xa > 0) { + if (z < 0) + z += ya; + } + else if (z > 0) + z -= ya; + return z; +#else + double quotient; + if( (quotient = (double)*x / *y) >= 0) + quotient = floor(quotient); + else + quotient = -floor(-quotient); + return(*x - (*y) * quotient ); +#endif +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/r_nint.c b/unix/f2c/libf2c/r_nint.c new file mode 100644 index 00000000..7cc3f1b5 --- /dev/null +++ b/unix/f2c/libf2c/r_nint.c @@ -0,0 +1,20 @@ +#include "f2c.h" + +#ifdef KR_headers +double floor(); +double r_nint(x) real *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double r_nint(real *x) +#endif +{ +return( (*x)>=0 ? + floor(*x + .5) : -floor(.5 - *x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/r_sign.c b/unix/f2c/libf2c/r_sign.c new file mode 100644 index 00000000..797db1a4 --- /dev/null +++ b/unix/f2c/libf2c/r_sign.c @@ -0,0 +1,18 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +double r_sign(a,b) real *a, *b; +#else +double r_sign(real *a, real *b) +#endif +{ +double x; +x = (*a >= 0 ? *a : - *a); +return( *b >= 0 ? x : -x); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/r_sin.c b/unix/f2c/libf2c/r_sin.c new file mode 100644 index 00000000..37e0df25 --- /dev/null +++ b/unix/f2c/libf2c/r_sin.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double sin(); +double r_sin(x) real *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double r_sin(real *x) +#endif +{ +return( sin(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/r_sinh.c b/unix/f2c/libf2c/r_sinh.c new file mode 100644 index 00000000..39878f03 --- /dev/null +++ b/unix/f2c/libf2c/r_sinh.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double sinh(); +double r_sinh(x) real *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double r_sinh(real *x) +#endif +{ +return( sinh(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/r_sqrt.c b/unix/f2c/libf2c/r_sqrt.c new file mode 100644 index 00000000..e7b2c1c7 --- /dev/null +++ b/unix/f2c/libf2c/r_sqrt.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double sqrt(); +double r_sqrt(x) real *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double r_sqrt(real *x) +#endif +{ +return( sqrt(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/r_tan.c b/unix/f2c/libf2c/r_tan.c new file mode 100644 index 00000000..1774bed7 --- /dev/null +++ b/unix/f2c/libf2c/r_tan.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double tan(); +double r_tan(x) real *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double r_tan(real *x) +#endif +{ +return( tan(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/r_tanh.c b/unix/f2c/libf2c/r_tanh.c new file mode 100644 index 00000000..7739c6ce --- /dev/null +++ b/unix/f2c/libf2c/r_tanh.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double tanh(); +double r_tanh(x) real *x; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +double r_tanh(real *x) +#endif +{ +return( tanh(*x) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/rawio.h b/unix/f2c/libf2c/rawio.h new file mode 100644 index 00000000..fd36a482 --- /dev/null +++ b/unix/f2c/libf2c/rawio.h @@ -0,0 +1,41 @@ +#ifndef KR_headers +#ifdef MSDOS +#include "io.h" +#ifndef WATCOM +#define close _close +#define creat _creat +#define open _open +#define read _read +#define write _write +#endif /*WATCOM*/ +#endif /*MSDOS*/ +#ifdef __cplusplus +extern "C" { +#endif +#ifndef MSDOS +#ifdef OPEN_DECL +extern int creat(const char*,int), open(const char*,int); +#endif +extern int close(int); +extern int read(int,void*,size_t), write(int,void*,size_t); +extern int unlink(const char*); +#ifndef _POSIX_SOURCE +#ifndef NON_UNIX_STDIO +extern FILE *fdopen(int, const char*); +#endif +#endif +#endif /*KR_HEADERS*/ + +extern char *mktemp(char*); + +#ifdef __cplusplus + } +#endif +#endif + +#include "fcntl.h" + +#ifndef O_WRONLY +#define O_RDONLY 0 +#define O_WRONLY 1 +#endif diff --git a/unix/f2c/libf2c/rdfmt.c b/unix/f2c/libf2c/rdfmt.c new file mode 100644 index 00000000..09f3ccfc --- /dev/null +++ b/unix/f2c/libf2c/rdfmt.c @@ -0,0 +1,553 @@ +#include "f2c.h" +#include "fio.h" + +#ifdef KR_headers +extern double atof(); +#define Const /*nothing*/ +#else +#define Const const +#undef abs +#undef min +#undef max +#include "stdlib.h" +#endif + +#include "fmt.h" +#include "fp.h" +#include "ctype.h" +#ifdef __cplusplus +extern "C" { +#endif + + static int +#ifdef KR_headers +rd_Z(n,w,len) Uint *n; ftnlen len; +#else +rd_Z(Uint *n, int w, ftnlen len) +#endif +{ + long x[9]; + char *s, *s0, *s1, *se, *t; + Const char *sc; + int ch, i, w1, w2; + static char hex[256]; + static int one = 1; + int bad = 0; + + if (!hex['0']) { + sc = "0123456789"; + while(ch = *sc++) + hex[ch] = ch - '0' + 1; + sc = "ABCDEF"; + while(ch = *sc++) + hex[ch] = hex[ch + 'a' - 'A'] = ch - 'A' + 11; + } + s = s0 = (char *)x; + s1 = (char *)&x[4]; + se = (char *)&x[8]; + if (len > 4*sizeof(long)) + return errno = 117; + while (w) { + GET(ch); + if (ch==',' || ch=='\n') + break; + w--; + if (ch > ' ') { + if (!hex[ch & 0xff]) + bad++; + *s++ = ch; + if (s == se) { + /* discard excess characters */ + for(t = s0, s = s1; t < s1;) + *t++ = *s++; + s = s1; + } + } + } + if (bad) + return errno = 115; + w = (int)len; + w1 = s - s0; + w2 = w1+1 >> 1; + t = (char *)n; + if (*(char *)&one) { + /* little endian */ + t += w - 1; + i = -1; + } + else + i = 1; + for(; w > w2; t += i, --w) + *t = 0; + if (!w) + return 0; + if (w < w2) + s0 = s - (w << 1); + else if (w1 & 1) { + *t = hex[*s0++ & 0xff] - 1; + if (!--w) + return 0; + t += i; + } + do { + *t = hex[*s0 & 0xff]-1 << 4 | hex[s0[1] & 0xff]-1; + t += i; + s0 += 2; + } + while(--w); + return 0; + } + + static int +#ifdef KR_headers +rd_I(n,w,len, base) Uint *n; int w; ftnlen len; register int base; +#else +rd_I(Uint *n, int w, ftnlen len, register int base) +#endif +{ + int ch, sign; + longint x = 0; + + if (w <= 0) + goto have_x; + for(;;) { + GET(ch); + if (ch != ' ') + break; + if (!--w) + goto have_x; + } + sign = 0; + switch(ch) { + case ',': + case '\n': + w = 0; + goto have_x; + case '-': + sign = 1; + case '+': + break; + default: + if (ch >= '0' && ch <= '9') { + x = ch - '0'; + break; + } + goto have_x; + } + while(--w) { + GET(ch); + if (ch >= '0' && ch <= '9') { + x = x*base + ch - '0'; + continue; + } + if (ch != ' ') { + if (ch == '\n' || ch == ',') + w = 0; + break; + } + if (f__cblank) + x *= base; + } + if (sign) + x = -x; + have_x: + if(len == sizeof(integer)) + n->il=x; + else if(len == sizeof(char)) + n->ic = (char)x; +#ifdef Allow_TYQUAD + else if (len == sizeof(longint)) + n->ili = x; +#endif + else + n->is = (short)x; + if (w) { + while(--w) + GET(ch); + return errno = 115; + } + return 0; +} + + static int +#ifdef KR_headers +rd_L(n,w,len) ftnint *n; ftnlen len; +#else +rd_L(ftnint *n, int w, ftnlen len) +#endif +{ int ch, dot, lv; + + if (w <= 0) + goto bad; + for(;;) { + GET(ch); + --w; + if (ch != ' ') + break; + if (!w) + goto bad; + } + dot = 0; + retry: + switch(ch) { + case '.': + if (dot++ || !w) + goto bad; + GET(ch); + --w; + goto retry; + case 't': + case 'T': + lv = 1; + break; + case 'f': + case 'F': + lv = 0; + break; + default: + bad: + for(; w > 0; --w) + GET(ch); + /* no break */ + case ',': + case '\n': + return errno = 116; + } + switch(len) { + case sizeof(char): *(char *)n = (char)lv; break; + case sizeof(short): *(short *)n = (short)lv; break; + default: *n = lv; + } + while(w-- > 0) { + GET(ch); + if (ch == ',' || ch == '\n') + break; + } + return 0; +} + + static int +#ifdef KR_headers +rd_F(p, w, d, len) ufloat *p; ftnlen len; +#else +rd_F(ufloat *p, int w, int d, ftnlen len) +#endif +{ + char s[FMAX+EXPMAXDIGS+4]; + register int ch; + register char *sp, *spe, *sp1; + double x; + int scale1, se; + long e, exp; + + sp1 = sp = s; + spe = sp + FMAX; + exp = -d; + x = 0.; + + do { + GET(ch); + w--; + } while (ch == ' ' && w); + switch(ch) { + case '-': *sp++ = ch; sp1++; spe++; + case '+': + if (!w) goto zero; + --w; + GET(ch); + } + while(ch == ' ') { +blankdrop: + if (!w--) goto zero; GET(ch); } + while(ch == '0') + { if (!w--) goto zero; GET(ch); } + if (ch == ' ' && f__cblank) + goto blankdrop; + scale1 = f__scale; + while(isdigit(ch)) { +digloop1: + if (sp < spe) *sp++ = ch; + else ++exp; +digloop1e: + if (!w--) goto done; + GET(ch); + } + if (ch == ' ') { + if (f__cblank) + { ch = '0'; goto digloop1; } + goto digloop1e; + } + if (ch == '.') { + exp += d; + if (!w--) goto done; + GET(ch); + if (sp == sp1) { /* no digits yet */ + while(ch == '0') { +skip01: + --exp; +skip0: + if (!w--) goto done; + GET(ch); + } + if (ch == ' ') { + if (f__cblank) goto skip01; + goto skip0; + } + } + while(isdigit(ch)) { +digloop2: + if (sp < spe) + { *sp++ = ch; --exp; } +digloop2e: + if (!w--) goto done; + GET(ch); + } + if (ch == ' ') { + if (f__cblank) + { ch = '0'; goto digloop2; } + goto digloop2e; + } + } + switch(ch) { + default: + break; + case '-': se = 1; goto signonly; + case '+': se = 0; goto signonly; + case 'e': + case 'E': + case 'd': + case 'D': + if (!w--) + goto bad; + GET(ch); + while(ch == ' ') { + if (!w--) + goto bad; + GET(ch); + } + se = 0; + switch(ch) { + case '-': se = 1; + case '+': +signonly: + if (!w--) + goto bad; + GET(ch); + } + while(ch == ' ') { + if (!w--) + goto bad; + GET(ch); + } + if (!isdigit(ch)) + goto bad; + + e = ch - '0'; + for(;;) { + if (!w--) + { ch = '\n'; break; } + GET(ch); + if (!isdigit(ch)) { + if (ch == ' ') { + if (f__cblank) + ch = '0'; + else continue; + } + else + break; + } + e = 10*e + ch - '0'; + if (e > EXPMAX && sp > sp1) + goto bad; + } + if (se) + exp -= e; + else + exp += e; + scale1 = 0; + } + switch(ch) { + case '\n': + case ',': + break; + default: +bad: + return (errno = 115); + } +done: + if (sp > sp1) { + while(*--sp == '0') + ++exp; + if (exp -= scale1) + sprintf(sp+1, "e%ld", exp); + else + sp[1] = 0; + x = atof(s); + } +zero: + if (len == sizeof(real)) + p->pf = x; + else + p->pd = x; + return(0); + } + + + static int +#ifdef KR_headers +rd_A(p,len) char *p; ftnlen len; +#else +rd_A(char *p, ftnlen len) +#endif +{ int i,ch; + for(i=0;i<len;i++) + { GET(ch); + *p++=VAL(ch); + } + return(0); +} + static int +#ifdef KR_headers +rd_AW(p,w,len) char *p; ftnlen len; +#else +rd_AW(char *p, int w, ftnlen len) +#endif +{ int i,ch; + if(w>=len) + { for(i=0;i<w-len;i++) + GET(ch); + for(i=0;i<len;i++) + { GET(ch); + *p++=VAL(ch); + } + return(0); + } + for(i=0;i<w;i++) + { GET(ch); + *p++=VAL(ch); + } + for(i=0;i<len-w;i++) *p++=' '; + return(0); +} + static int +#ifdef KR_headers +rd_H(n,s) char *s; +#else +rd_H(int n, char *s) +#endif +{ int i,ch; + for(i=0;i<n;i++) + if((ch=(*f__getn)())<0) return(ch); + else *s++ = ch=='\n'?' ':ch; + return(1); +} + static int +#ifdef KR_headers +rd_POS(s) char *s; +#else +rd_POS(char *s) +#endif +{ char quote; + int ch; + quote= *s++; + for(;*s;s++) + if(*s==quote && *(s+1)!=quote) break; + else if((ch=(*f__getn)())<0) return(ch); + else *s = ch=='\n'?' ':ch; + return(1); +} + + int +#ifdef KR_headers +rd_ed(p,ptr,len) struct syl *p; char *ptr; ftnlen len; +#else +rd_ed(struct syl *p, char *ptr, ftnlen len) +#endif +{ int ch; + for(;f__cursor>0;f__cursor--) if((ch=(*f__getn)())<0) return(ch); + if(f__cursor<0) + { if(f__recpos+f__cursor < 0) /*err(elist->cierr,110,"fmt")*/ + f__cursor = -f__recpos; /* is this in the standard? */ + if(f__external == 0) { + extern char *f__icptr; + f__icptr += f__cursor; + } + else if(f__curunit && f__curunit->useek) + (void) FSEEK(f__cf, f__cursor,SEEK_CUR); + else + err(f__elist->cierr,106,"fmt"); + f__recpos += f__cursor; + f__cursor=0; + } + switch(p->op) + { + default: fprintf(stderr,"rd_ed, unexpected code: %d\n", p->op); + sig_die(f__fmtbuf, 1); + case IM: + case I: ch = rd_I((Uint *)ptr,p->p1,len, 10); + break; + + /* O and OM don't work right for character, double, complex, */ + /* or doublecomplex, and they differ from Fortran 90 in */ + /* showing a minus sign for negative values. */ + + case OM: + case O: ch = rd_I((Uint *)ptr, p->p1, len, 8); + break; + case L: ch = rd_L((ftnint *)ptr,p->p1,len); + break; + case A: ch = rd_A(ptr,len); + break; + case AW: + ch = rd_AW(ptr,p->p1,len); + break; + case E: case EE: + case D: + case G: + case GE: + case F: ch = rd_F((ufloat *)ptr,p->p1,p->p2.i[0],len); + break; + + /* Z and ZM assume 8-bit bytes. */ + + case ZM: + case Z: + ch = rd_Z((Uint *)ptr, p->p1, len); + break; + } + if(ch == 0) return(ch); + else if(ch == EOF) return(EOF); + if (f__cf) + clearerr(f__cf); + return(errno); +} + + int +#ifdef KR_headers +rd_ned(p) struct syl *p; +#else +rd_ned(struct syl *p) +#endif +{ + switch(p->op) + { + default: fprintf(stderr,"rd_ned, unexpected code: %d\n", p->op); + sig_die(f__fmtbuf, 1); + case APOS: + return(rd_POS(p->p2.s)); + case H: return(rd_H(p->p1,p->p2.s)); + case SLASH: return((*f__donewrec)()); + case TR: + case X: f__cursor += p->p1; + return(1); + case T: f__cursor=p->p1-f__recpos - 1; + return(1); + case TL: f__cursor -= p->p1; + if(f__cursor < -f__recpos) /* TL1000, 1X */ + f__cursor = -f__recpos; + return(1); + } +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/rewind.c b/unix/f2c/libf2c/rewind.c new file mode 100644 index 00000000..9a0e07e6 --- /dev/null +++ b/unix/f2c/libf2c/rewind.c @@ -0,0 +1,30 @@ +#include "f2c.h" +#include "fio.h" +#ifdef __cplusplus +extern "C" { +#endif +#ifdef KR_headers +integer f_rew(a) alist *a; +#else +integer f_rew(alist *a) +#endif +{ + unit *b; + if(a->aunit>=MXUNIT || a->aunit<0) + err(a->aerr,101,"rewind"); + b = &f__units[a->aunit]; + if(b->ufd == NULL || b->uwrt == 3) + return(0); + if(!b->useek) + err(a->aerr,106,"rewind") + if(b->uwrt) { + (void) t_runc(a); + b->uwrt = 3; + } + rewind(b->ufd); + b->uend=0; + return(0); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/rsfe.c b/unix/f2c/libf2c/rsfe.c new file mode 100644 index 00000000..abe9724a --- /dev/null +++ b/unix/f2c/libf2c/rsfe.c @@ -0,0 +1,91 @@ +/* read sequential formatted external */ +#include "f2c.h" +#include "fio.h" +#include "fmt.h" +#ifdef __cplusplus +extern "C" { +#endif + + int +xrd_SL(Void) +{ int ch; + if(!f__curunit->uend) + while((ch=getc(f__cf))!='\n') + if (ch == EOF) { + f__curunit->uend = 1; + break; + } + f__cursor=f__recpos=0; + return(1); +} + + int +x_getc(Void) +{ int ch; + if(f__curunit->uend) return(EOF); + ch = getc(f__cf); + if(ch!=EOF && ch!='\n') + { f__recpos++; + return(ch); + } + if(ch=='\n') + { (void) ungetc(ch,f__cf); + return(ch); + } + if(f__curunit->uend || feof(f__cf)) + { errno=0; + f__curunit->uend=1; + return(-1); + } + return(-1); +} + + int +x_endp(Void) +{ + xrd_SL(); + return f__curunit->uend == 1 ? EOF : 0; +} + + int +x_rev(Void) +{ + (void) xrd_SL(); + return(0); +} +#ifdef KR_headers +integer s_rsfe(a) cilist *a; /* start */ +#else +integer s_rsfe(cilist *a) /* start */ +#endif +{ int n; + if(!f__init) f_init(); + f__reading=1; + f__sequential=1; + f__formatted=1; + f__external=1; + if(n=c_sfe(a)) return(n); + f__elist=a; + f__cursor=f__recpos=0; + f__scale=0; + f__fmtbuf=a->cifmt; + f__cf=f__curunit->ufd; + if(pars_f(f__fmtbuf)<0) err(a->cierr,100,"startio"); + f__getn= x_getc; + f__doed= rd_ed; + f__doned= rd_ned; + fmt_bg(); + f__doend=x_endp; + f__donewrec=xrd_SL; + f__dorevert=x_rev; + f__cblank=f__curunit->ublnk; + f__cplus=0; + if(f__curunit->uwrt && f__nowreading(f__curunit)) + err(a->cierr,errno,"read start"); + if(f__curunit->uend) + err(f__elist->ciend,(EOF),"read start"); + return(0); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/rsli.c b/unix/f2c/libf2c/rsli.c new file mode 100644 index 00000000..3d4ea428 --- /dev/null +++ b/unix/f2c/libf2c/rsli.c @@ -0,0 +1,109 @@ +#include "f2c.h" +#include "fio.h" +#include "lio.h" +#include "fmt.h" /* for f__doend */ +#ifdef __cplusplus +extern "C" { +#endif + +extern flag f__lquit; +extern int f__lcount; +extern char *f__icptr; +extern char *f__icend; +extern icilist *f__svic; +extern int f__icnum, f__recpos; + +static int i_getc(Void) +{ + if(f__recpos >= f__svic->icirlen) { + if (f__recpos++ == f__svic->icirlen) + return '\n'; + z_rnew(); + } + f__recpos++; + if(f__icptr >= f__icend) + return EOF; + return(*f__icptr++); + } + + static +#ifdef KR_headers +int i_ungetc(ch, f) int ch; FILE *f; +#else +int i_ungetc(int ch, FILE *f) +#endif +{ + if (--f__recpos == f__svic->icirlen) + return '\n'; + if (f__recpos < -1) + err(f__svic->icierr,110,"recend"); + /* *--icptr == ch, and icptr may point to read-only memory */ + return *--f__icptr /* = ch */; + } + + static void +#ifdef KR_headers +c_lir(a) icilist *a; +#else +c_lir(icilist *a) +#endif +{ + extern int l_eof; + f__reading = 1; + f__external = 0; + f__formatted = 1; + f__svic = a; + L_len = a->icirlen; + f__recpos = -1; + f__icnum = f__recpos = 0; + f__cursor = 0; + l_getc = i_getc; + l_ungetc = i_ungetc; + l_eof = 0; + f__icptr = a->iciunit; + f__icend = f__icptr + a->icirlen*a->icirnum; + f__cf = 0; + f__curunit = 0; + f__elist = (cilist *)a; + } + + +#ifdef KR_headers +integer s_rsli(a) icilist *a; +#else +integer s_rsli(icilist *a) +#endif +{ + f__lioproc = l_read; + f__lquit = 0; + f__lcount = 0; + c_lir(a); + f__doend = 0; + return(0); + } + +integer e_rsli(Void) +{ return 0; } + +#ifdef KR_headers +integer s_rsni(a) icilist *a; +#else +extern int x_rsne(cilist*); + +integer s_rsni(icilist *a) +#endif +{ + extern int nml_read; + integer rv; + cilist ca; + ca.ciend = a->iciend; + ca.cierr = a->icierr; + ca.cifmt = a->icifmt; + c_lir(a); + rv = x_rsne(&ca); + nml_read = 0; + return rv; + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/rsne.c b/unix/f2c/libf2c/rsne.c new file mode 100644 index 00000000..e8e9daea --- /dev/null +++ b/unix/f2c/libf2c/rsne.c @@ -0,0 +1,618 @@ +#include "f2c.h" +#include "fio.h" +#include "lio.h" + +#define MAX_NL_CACHE 3 /* maximum number of namelist hash tables to cache */ +#define MAXDIM 20 /* maximum number of subscripts */ + + struct dimen { + ftnlen extent; + ftnlen curval; + ftnlen delta; + ftnlen stride; + }; + typedef struct dimen dimen; + + struct hashentry { + struct hashentry *next; + char *name; + Vardesc *vd; + }; + typedef struct hashentry hashentry; + + struct hashtab { + struct hashtab *next; + Namelist *nl; + int htsize; + hashentry *tab[1]; + }; + typedef struct hashtab hashtab; + + static hashtab *nl_cache; + static int n_nlcache; + static hashentry **zot; + static int colonseen; + extern ftnlen f__typesize[]; + + extern flag f__lquit; + extern int f__lcount, nml_read; + extern int t_getc(Void); + +#ifdef KR_headers + extern char *malloc(), *memset(); +#define Const /*nothing*/ + +#ifdef ungetc + static int +un_getc(x,f__cf) int x; FILE *f__cf; +{ return ungetc(x,f__cf); } +#else +#define un_getc ungetc + extern int ungetc(); +#endif + +#else +#define Const const +#undef abs +#undef min +#undef max +#include "stdlib.h" +#include "string.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef ungetc + static int +un_getc(int x, FILE *f__cf) +{ return ungetc(x,f__cf); } +#else +#define un_getc ungetc +extern int ungetc(int, FILE*); /* for systems with a buggy stdio.h */ +#endif +#endif + + static Vardesc * +#ifdef KR_headers +hash(ht, s) hashtab *ht; register char *s; +#else +hash(hashtab *ht, register char *s) +#endif +{ + register int c, x; + register hashentry *h; + char *s0 = s; + + for(x = 0; c = *s++; x = x & 0x4000 ? ((x << 1) & 0x7fff) + 1 : x << 1) + x += c; + for(h = *(zot = ht->tab + x % ht->htsize); h; h = h->next) + if (!strcmp(s0, h->name)) + return h->vd; + return 0; + } + + hashtab * +#ifdef KR_headers +mk_hashtab(nl) Namelist *nl; +#else +mk_hashtab(Namelist *nl) +#endif +{ + int nht, nv; + hashtab *ht; + Vardesc *v, **vd, **vde; + hashentry *he; + + hashtab **x, **x0, *y; + for(x = &nl_cache; y = *x; x0 = x, x = &y->next) + if (nl == y->nl) + return y; + if (n_nlcache >= MAX_NL_CACHE) { + /* discard least recently used namelist hash table */ + y = *x0; + free((char *)y->next); + y->next = 0; + } + else + n_nlcache++; + nv = nl->nvars; + if (nv >= 0x4000) + nht = 0x7fff; + else { + for(nht = 1; nht < nv; nht <<= 1); + nht += nht - 1; + } + ht = (hashtab *)malloc(sizeof(hashtab) + (nht-1)*sizeof(hashentry *) + + nv*sizeof(hashentry)); + if (!ht) + return 0; + he = (hashentry *)&ht->tab[nht]; + ht->nl = nl; + ht->htsize = nht; + ht->next = nl_cache; + nl_cache = ht; + memset((char *)ht->tab, 0, nht*sizeof(hashentry *)); + vd = nl->vars; + vde = vd + nv; + while(vd < vde) { + v = *vd++; + if (!hash(ht, v->name)) { + he->next = *zot; + *zot = he; + he->name = v->name; + he->vd = v; + he++; + } + } + return ht; + } + +static char Alpha[256], Alphanum[256]; + + static VOID +nl_init(Void) { + Const char *s; + int c; + + if(!f__init) + f_init(); + for(s = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; c = *s++; ) + Alpha[c] + = Alphanum[c] + = Alpha[c + 'a' - 'A'] + = Alphanum[c + 'a' - 'A'] + = c; + for(s = "0123456789_"; c = *s++; ) + Alphanum[c] = c; + } + +#define GETC(x) (x=(*l_getc)()) +#define Ungetc(x,y) (*l_ungetc)(x,y) + + static int +#ifdef KR_headers +getname(s, slen) register char *s; int slen; +#else +getname(register char *s, int slen) +#endif +{ + register char *se = s + slen - 1; + register int ch; + + GETC(ch); + if (!(*s++ = Alpha[ch & 0xff])) { + if (ch != EOF) + ch = 115; + errfl(f__elist->cierr, ch, "namelist read"); + } + while(*s = Alphanum[GETC(ch) & 0xff]) + if (s < se) + s++; + if (ch == EOF) + err(f__elist->cierr, EOF, "namelist read"); + if (ch > ' ') + Ungetc(ch,f__cf); + return *s = 0; + } + + static int +#ifdef KR_headers +getnum(chp, val) int *chp; ftnlen *val; +#else +getnum(int *chp, ftnlen *val) +#endif +{ + register int ch, sign; + register ftnlen x; + + while(GETC(ch) <= ' ' && ch >= 0); + if (ch == '-') { + sign = 1; + GETC(ch); + } + else { + sign = 0; + if (ch == '+') + GETC(ch); + } + x = ch - '0'; + if (x < 0 || x > 9) + return 115; + while(GETC(ch) >= '0' && ch <= '9') + x = 10*x + ch - '0'; + while(ch <= ' ' && ch >= 0) + GETC(ch); + if (ch == EOF) + return EOF; + *val = sign ? -x : x; + *chp = ch; + return 0; + } + + static int +#ifdef KR_headers +getdimen(chp, d, delta, extent, x1) + int *chp; dimen *d; ftnlen delta, extent, *x1; +#else +getdimen(int *chp, dimen *d, ftnlen delta, ftnlen extent, ftnlen *x1) +#endif +{ + register int k; + ftnlen x2, x3; + + if (k = getnum(chp, x1)) + return k; + x3 = 1; + if (*chp == ':') { + if (k = getnum(chp, &x2)) + return k; + x2 -= *x1; + if (*chp == ':') { + if (k = getnum(chp, &x3)) + return k; + if (!x3) + return 123; + x2 /= x3; + colonseen = 1; + } + if (x2 < 0 || x2 >= extent) + return 123; + d->extent = x2 + 1; + } + else + d->extent = 1; + d->curval = 0; + d->delta = delta; + d->stride = x3; + return 0; + } + +#ifndef No_Namelist_Questions + static Void +#ifdef KR_headers +print_ne(a) cilist *a; +#else +print_ne(cilist *a) +#endif +{ + flag intext = f__external; + int rpsave = f__recpos; + FILE *cfsave = f__cf; + unit *usave = f__curunit; + cilist t; + t = *a; + t.ciunit = 6; + s_wsne(&t); + fflush(f__cf); + f__external = intext; + f__reading = 1; + f__recpos = rpsave; + f__cf = cfsave; + f__curunit = usave; + f__elist = a; + } +#endif + + static char where0[] = "namelist read start "; + + int +#ifdef KR_headers +x_rsne(a) cilist *a; +#else +x_rsne(cilist *a) +#endif +{ + int ch, got1, k, n, nd, quote, readall; + Namelist *nl; + static char where[] = "namelist read"; + char buf[64]; + hashtab *ht; + Vardesc *v; + dimen *dn, *dn0, *dn1; + ftnlen *dims, *dims1; + ftnlen b, b0, b1, ex, no, nomax, size, span; + ftnint no1, no2, type; + char *vaddr; + long iva, ivae; + dimen dimens[MAXDIM], substr; + + if (!Alpha['a']) + nl_init(); + f__reading=1; + f__formatted=1; + got1 = 0; + top: + for(;;) switch(GETC(ch)) { + case EOF: + eof: + err(a->ciend,(EOF),where0); + case '&': + case '$': + goto have_amp; +#ifndef No_Namelist_Questions + case '?': + print_ne(a); + continue; +#endif + default: + if (ch <= ' ' && ch >= 0) + continue; +#ifndef No_Namelist_Comments + while(GETC(ch) != '\n') + if (ch == EOF) + goto eof; +#else + errfl(a->cierr, 115, where0); +#endif + } + have_amp: + if (ch = getname(buf,sizeof(buf))) + return ch; + nl = (Namelist *)a->cifmt; + if (strcmp(buf, nl->name)) +#ifdef No_Bad_Namelist_Skip + errfl(a->cierr, 118, where0); +#else + { + fprintf(stderr, + "Skipping namelist \"%s\": seeking namelist \"%s\".\n", + buf, nl->name); + fflush(stderr); + for(;;) switch(GETC(ch)) { + case EOF: + err(a->ciend, EOF, where0); + case '/': + case '&': + case '$': + if (f__external) + e_rsle(); + else + z_rnew(); + goto top; + case '"': + case '\'': + quote = ch; + more_quoted: + while(GETC(ch) != quote) + if (ch == EOF) + err(a->ciend, EOF, where0); + if (GETC(ch) == quote) + goto more_quoted; + Ungetc(ch,f__cf); + default: + continue; + } + } +#endif + ht = mk_hashtab(nl); + if (!ht) + errfl(f__elist->cierr, 113, where0); + for(;;) { + for(;;) switch(GETC(ch)) { + case EOF: + if (got1) + return 0; + err(a->ciend, EOF, where0); + case '/': + case '$': + case '&': + return 0; + default: + if (ch <= ' ' && ch >= 0 || ch == ',') + continue; + Ungetc(ch,f__cf); + if (ch = getname(buf,sizeof(buf))) + return ch; + goto havename; + } + havename: + v = hash(ht,buf); + if (!v) + errfl(a->cierr, 119, where); + while(GETC(ch) <= ' ' && ch >= 0); + vaddr = v->addr; + type = v->type; + if (type < 0) { + size = -type; + type = TYCHAR; + } + else + size = f__typesize[type]; + ivae = size; + iva = readall = 0; + if (ch == '(' /*)*/ ) { + dn = dimens; + if (!(dims = v->dims)) { + if (type != TYCHAR) + errfl(a->cierr, 122, where); + if (k = getdimen(&ch, dn, (ftnlen)size, + (ftnlen)size, &b)) + errfl(a->cierr, k, where); + if (ch != ')') + errfl(a->cierr, 115, where); + b1 = dn->extent; + if (--b < 0 || b + b1 > size) + return 124; + iva += b; + size = b1; + while(GETC(ch) <= ' ' && ch >= 0); + goto scalar; + } + nd = (int)dims[0]; + nomax = span = dims[1]; + ivae = iva + size*nomax; + colonseen = 0; + if (k = getdimen(&ch, dn, size, nomax, &b)) + errfl(a->cierr, k, where); + no = dn->extent; + b0 = dims[2]; + dims1 = dims += 3; + ex = 1; + for(n = 1; n++ < nd; dims++) { + if (ch != ',') + errfl(a->cierr, 115, where); + dn1 = dn + 1; + span /= *dims; + if (k = getdimen(&ch, dn1, dn->delta**dims, + span, &b1)) + errfl(a->cierr, k, where); + ex *= *dims; + b += b1*ex; + no *= dn1->extent; + dn = dn1; + } + if (ch != ')') + errfl(a->cierr, 115, where); + readall = 1 - colonseen; + b -= b0; + if (b < 0 || b >= nomax) + errfl(a->cierr, 125, where); + iva += size * b; + dims = dims1; + while(GETC(ch) <= ' ' && ch >= 0); + no1 = 1; + dn0 = dimens; + if (type == TYCHAR && ch == '(' /*)*/) { + if (k = getdimen(&ch, &substr, size, size, &b)) + errfl(a->cierr, k, where); + if (ch != ')') + errfl(a->cierr, 115, where); + b1 = substr.extent; + if (--b < 0 || b + b1 > size) + return 124; + iva += b; + b0 = size; + size = b1; + while(GETC(ch) <= ' ' && ch >= 0); + if (b1 < b0) + goto delta_adj; + } + if (readall) + goto delta_adj; + for(; dn0 < dn; dn0++) { + if (dn0->extent != *dims++ || dn0->stride != 1) + break; + no1 *= dn0->extent; + } + if (dn0 == dimens && dimens[0].stride == 1) { + no1 = dimens[0].extent; + dn0++; + } + delta_adj: + ex = 0; + for(dn1 = dn0; dn1 <= dn; dn1++) + ex += (dn1->extent-1) + * (dn1->delta *= dn1->stride); + for(dn1 = dn; dn1 > dn0; dn1--) { + ex -= (dn1->extent - 1) * dn1->delta; + dn1->delta -= ex; + } + } + else if (dims = v->dims) { + no = no1 = dims[1]; + ivae = iva + no*size; + } + else + scalar: + no = no1 = 1; + if (ch != '=') + errfl(a->cierr, 115, where); + got1 = nml_read = 1; + f__lcount = 0; + readloop: + for(;;) { + if (iva >= ivae || iva < 0) { + f__lquit = 1; + goto mustend; + } + else if (iva + no1*size > ivae) + no1 = (ivae - iva)/size; + f__lquit = 0; + if (k = l_read(&no1, vaddr + iva, size, type)) + return k; + if (f__lquit == 1) + return 0; + if (readall) { + iva += dn0->delta; + if (f__lcount > 0) { + no2 = (ivae - iva)/size; + if (no2 > f__lcount) + no2 = f__lcount; + if (k = l_read(&no2, vaddr + iva, + size, type)) + return k; + iva += no2 * dn0->delta; + } + } + mustend: + GETC(ch); + if (readall) + if (iva >= ivae) + readall = 0; + else for(;;) { + switch(ch) { + case ' ': + case '\t': + case '\n': + GETC(ch); + continue; + } + break; + } + if (ch == '/' || ch == '$' || ch == '&') { + f__lquit = 1; + return 0; + } + else if (f__lquit) { + while(ch <= ' ' && ch >= 0) + GETC(ch); + Ungetc(ch,f__cf); + if (!Alpha[ch & 0xff] && ch >= 0) + errfl(a->cierr, 125, where); + break; + } + Ungetc(ch,f__cf); + if (readall && !Alpha[ch & 0xff]) + goto readloop; + if ((no -= no1) <= 0) + break; + for(dn1 = dn0; dn1 <= dn; dn1++) { + if (++dn1->curval < dn1->extent) { + iva += dn1->delta; + goto readloop; + } + dn1->curval = 0; + } + break; + } + } + } + + integer +#ifdef KR_headers +s_rsne(a) cilist *a; +#else +s_rsne(cilist *a) +#endif +{ + extern int l_eof; + int n; + + f__external=1; + l_eof = 0; + if(n = c_le(a)) + return n; + if(f__curunit->uwrt && f__nowreading(f__curunit)) + err(a->cierr,errno,where0); + l_getc = t_getc; + l_ungetc = un_getc; + f__doend = xrd_SL; + n = x_rsne(a); + nml_read = 0; + if (n) + return n; + return e_rsle(); + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/s_cat.c b/unix/f2c/libf2c/s_cat.c new file mode 100644 index 00000000..8d92a637 --- /dev/null +++ b/unix/f2c/libf2c/s_cat.c @@ -0,0 +1,86 @@ +/* Unless compiled with -DNO_OVERWRITE, this variant of s_cat allows the + * target of a concatenation to appear on its right-hand side (contrary + * to the Fortran 77 Standard, but in accordance with Fortran 90). + */ + +#include "f2c.h" +#ifndef NO_OVERWRITE +#include "stdio.h" +#undef abs +#ifdef KR_headers + extern char *F77_aloc(); + extern void free(); + extern void exit_(); +#else +#undef min +#undef max +#include "stdlib.h" +extern +#ifdef __cplusplus + "C" +#endif + char *F77_aloc(ftnlen, const char*); +#endif +#include "string.h" +#endif /* NO_OVERWRITE */ + +#ifdef __cplusplus +extern "C" { +#endif + + VOID +#ifdef KR_headers +s_cat(lp, rpp, rnp, np, ll) char *lp, *rpp[]; ftnint rnp[], *np; ftnlen ll; +#else +s_cat(char *lp, char *rpp[], ftnint rnp[], ftnint *np, ftnlen ll) +#endif +{ + ftnlen i, nc; + char *rp; + ftnlen n = *np; +#ifndef NO_OVERWRITE + ftnlen L, m; + char *lp0, *lp1; + + lp0 = 0; + lp1 = lp; + L = ll; + i = 0; + while(i < n) { + rp = rpp[i]; + m = rnp[i++]; + if (rp >= lp1 || rp + m <= lp) { + if ((L -= m) <= 0) { + n = i; + break; + } + lp1 += m; + continue; + } + lp0 = lp; + lp = lp1 = F77_aloc(L = ll, "s_cat"); + break; + } + lp1 = lp; +#endif /* NO_OVERWRITE */ + for(i = 0 ; i < n ; ++i) { + nc = ll; + if(rnp[i] < nc) + nc = rnp[i]; + ll -= nc; + rp = rpp[i]; + while(--nc >= 0) + *lp++ = *rp++; + } + while(--ll >= 0) + *lp++ = ' '; +#ifndef NO_OVERWRITE + if (lp0) { + memcpy(lp0, lp1, L); + free(lp1); + } +#endif + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/s_cmp.c b/unix/f2c/libf2c/s_cmp.c new file mode 100644 index 00000000..3a2ea67d --- /dev/null +++ b/unix/f2c/libf2c/s_cmp.c @@ -0,0 +1,50 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +/* compare two strings */ + +#ifdef KR_headers +integer s_cmp(a0, b0, la, lb) char *a0, *b0; ftnlen la, lb; +#else +integer s_cmp(char *a0, char *b0, ftnlen la, ftnlen lb) +#endif +{ +register unsigned char *a, *aend, *b, *bend; +a = (unsigned char *)a0; +b = (unsigned char *)b0; +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) + { ++a; ++b; } + else + return( *a - *b ); + while(a < aend) + if(*a != ' ') + return(*a - ' '); + else ++a; + } +return(0); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/s_copy.c b/unix/f2c/libf2c/s_copy.c new file mode 100644 index 00000000..9dacfc7d --- /dev/null +++ b/unix/f2c/libf2c/s_copy.c @@ -0,0 +1,57 @@ +/* Unless compiled with -DNO_OVERWRITE, this variant of s_copy allows the + * target of an assignment to appear on its right-hand side (contrary + * to the Fortran 77 Standard, but in accordance with Fortran 90), + * as in a(2:5) = a(4:7) . + */ + +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +/* assign strings: a = b */ + +#ifdef KR_headers +VOID s_copy(a, b, la, lb) register char *a, *b; ftnlen la, lb; +#else +void s_copy(register char *a, register char *b, ftnlen la, ftnlen lb) +#endif +{ + register char *aend, *bend; + + aend = a + la; + + if(la <= lb) +#ifndef NO_OVERWRITE + if (a <= b || a >= b + la) +#endif + while(a < aend) + *a++ = *b++; +#ifndef NO_OVERWRITE + else + for(b += la; a < aend; ) + *--aend = *--b; +#endif + + else { + bend = b + lb; +#ifndef NO_OVERWRITE + if (a <= b || a >= bend) +#endif + while(b < bend) + *a++ = *b++; +#ifndef NO_OVERWRITE + else { + a += lb; + while(b < bend) + *--a = *--bend; + a += lb; + } +#endif + while(a < aend) + *a++ = ' '; + } + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/s_paus.c b/unix/f2c/libf2c/s_paus.c new file mode 100644 index 00000000..51d80eb0 --- /dev/null +++ b/unix/f2c/libf2c/s_paus.c @@ -0,0 +1,96 @@ +#include "stdio.h" +#include "f2c.h" +#define PAUSESIG 15 + +#include "signal1.h" +#ifdef KR_headers +#define Void /* void */ +#define Int /* int */ +#else +#define Void void +#define Int int +#undef abs +#undef min +#undef max +#include "stdlib.h" +#ifdef __cplusplus +extern "C" { +#endif +#ifdef __cplusplus +extern "C" { +#endif +extern int getpid(void), isatty(int), pause(void); +#endif + +extern VOID f_exit(Void); + +#ifndef MSDOS + static VOID +waitpause(Sigarg) +{ Use_Sigarg; + return; + } +#endif + + static VOID +#ifdef KR_headers +s_1paus(fin) FILE *fin; +#else +s_1paus(FILE *fin) +#endif +{ + fprintf(stderr, + "To resume execution, type go. Other input will terminate the job.\n"); + fflush(stderr); + if( getc(fin)!='g' || getc(fin)!='o' || getc(fin)!='\n' ) { + fprintf(stderr, "STOP\n"); +#ifdef NO_ONEXIT + f_exit(); +#endif + exit(0); + } + } + + int +#ifdef KR_headers +s_paus(s, n) char *s; ftnlen n; +#else +s_paus(char *s, ftnlen n) +#endif +{ + fprintf(stderr, "PAUSE "); + if(n > 0) + fprintf(stderr, " %.*s", (int)n, s); + fprintf(stderr, " statement executed\n"); + if( isatty(fileno(stdin)) ) + s_1paus(stdin); + else { +#ifdef MSDOS + FILE *fin; + fin = fopen("con", "r"); + if (!fin) { + fprintf(stderr, "s_paus: can't open con!\n"); + fflush(stderr); + exit(1); + } + s_1paus(fin); + fclose(fin); +#else + fprintf(stderr, + "To resume execution, execute a kill -%d %d command\n", + PAUSESIG, getpid() ); + signal1(PAUSESIG, waitpause); + fflush(stderr); + pause(); +#endif + } + fprintf(stderr, "Execution resumes after PAUSE.\n"); + fflush(stderr); + return 0; /* NOT REACHED */ +#ifdef __cplusplus + } +#endif +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/s_rnge.c b/unix/f2c/libf2c/s_rnge.c new file mode 100644 index 00000000..3dbc5135 --- /dev/null +++ b/unix/f2c/libf2c/s_rnge.c @@ -0,0 +1,32 @@ +#include "stdio.h" +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +/* called when a subscript is out of range */ + +#ifdef KR_headers +extern VOID sig_die(); +integer s_rnge(varn, offset, procn, line) char *varn, *procn; ftnint offset, line; +#else +extern VOID sig_die(const char*,int); +integer s_rnge(char *varn, ftnint offset, char *procn, ftnint line) +#endif +{ +register int i; + +fprintf(stderr, "Subscript out of range on file line %ld, procedure ", + (long)line); +while((i = *procn) && i != '_' && i != ' ') + putc(*procn++, stderr); +fprintf(stderr, ".\nAttempt to access the %ld-th element of variable ", + (long)offset+1); +while((i = *varn) && i != ' ') + putc(*varn++, stderr); +sig_die(".", 1); +return 0; /* not reached */ +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/s_stop.c b/unix/f2c/libf2c/s_stop.c new file mode 100644 index 00000000..68233aea --- /dev/null +++ b/unix/f2c/libf2c/s_stop.c @@ -0,0 +1,48 @@ +#include "stdio.h" +#include "f2c.h" + +#ifdef KR_headers +extern void f_exit(); +int s_stop(s, n) char *s; ftnlen n; +#else +#undef abs +#undef min +#undef max +#include "stdlib.h" +#ifdef __cplusplus +extern "C" { +#endif +#ifdef __cplusplus +extern "C" { +#endif +void f_exit(void); + +int s_stop(char *s, ftnlen n) +#endif +{ +int i; + +if(n > 0) + { + fprintf(stderr, "STOP "); + for(i = 0; i<n ; ++i) + putc(*s++, stderr); + fprintf(stderr, " statement executed\n"); + } +#ifdef NO_ONEXIT +f_exit(); +#endif +exit(0); + +/* We cannot avoid (useless) compiler diagnostics here: */ +/* some compilers complain if there is no return statement, */ +/* and others complain that this one cannot be reached. */ + +return 0; /* NOT REACHED */ +} +#ifdef __cplusplus +} +#endif +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/scomptry.bat b/unix/f2c/libf2c/scomptry.bat new file mode 100644 index 00000000..2c11a97e --- /dev/null +++ b/unix/f2c/libf2c/scomptry.bat @@ -0,0 +1,5 @@ +%1 -DWRITE_ARITH_H -DNO_FPINIT %2 %3 %4 %5 %6 %7 %8 %9
+if errorlevel 1 goto nolonglong
+exit 0
+:nolonglong
+%1 -DNO_LONG_LONG -DWRITE_ARITH_H -DNO_FPINIT %2 %3 %4 %5 %6 %7 %8 %9
diff --git a/unix/f2c/libf2c/sfe.c b/unix/f2c/libf2c/sfe.c new file mode 100644 index 00000000..d24af6d9 --- /dev/null +++ b/unix/f2c/libf2c/sfe.c @@ -0,0 +1,47 @@ +/* sequential formatted external common routines*/ +#include "f2c.h" +#include "fio.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +extern char *f__fmtbuf; +#else +extern const char *f__fmtbuf; +#endif + +integer e_rsfe(Void) +{ int n; + n=en_fio(); + f__fmtbuf=NULL; + return(n); +} + + int +#ifdef KR_headers +c_sfe(a) cilist *a; /* check */ +#else +c_sfe(cilist *a) /* check */ +#endif +{ unit *p; + f__curunit = p = &f__units[a->ciunit]; + if(a->ciunit >= MXUNIT || a->ciunit<0) + err(a->cierr,101,"startio"); + if(p->ufd==NULL && fk_open(SEQ,FMT,a->ciunit)) err(a->cierr,114,"sfe") + if(!p->ufmt) err(a->cierr,102,"sfe") + return(0); +} +integer e_wsfe(Void) +{ + int n = en_fio(); + f__fmtbuf = NULL; +#ifdef ALWAYS_FLUSH + if (!n && fflush(f__cf)) + err(f__elist->cierr, errno, "write end"); +#endif + return n; +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/sig_die.c b/unix/f2c/libf2c/sig_die.c new file mode 100644 index 00000000..63a73d91 --- /dev/null +++ b/unix/f2c/libf2c/sig_die.c @@ -0,0 +1,51 @@ +#include "stdio.h" +#include "signal.h" + +#ifndef SIGIOT +#ifdef SIGABRT +#define SIGIOT SIGABRT +#endif +#endif + +#ifdef KR_headers +void sig_die(s, kill) char *s; int kill; +#else +#include "stdlib.h" +#ifdef __cplusplus +extern "C" { +#endif +#ifdef __cplusplus +extern "C" { +#endif + extern void f_exit(void); + +void sig_die(const char *s, int kill) +#endif +{ + /* print error message, then clear buffers */ + fprintf(stderr, "%s\n", s); + + if(kill) + { + fflush(stderr); + f_exit(); + fflush(stderr); + /* now get a core */ +#ifdef SIGIOT + signal(SIGIOT, SIG_DFL); +#endif + abort(); + } + else { +#ifdef NO_ONEXIT + f_exit(); +#endif + exit(1); + } + } +#ifdef __cplusplus +} +#endif +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/signal1.h b/unix/f2c/libf2c/signal1.h new file mode 100644 index 00000000..a383774b --- /dev/null +++ b/unix/f2c/libf2c/signal1.h @@ -0,0 +1,35 @@ +/* You may need to adjust the definition of signal1 to supply a */ +/* cast to the correct argument type. This detail is system- and */ +/* compiler-dependent. The #define below assumes signal.h declares */ +/* type SIG_PF for the signal function's second argument. */ + +/* For some C++ compilers, "#define Sigarg_t ..." may be appropriate. */ + +#include <signal.h> + +#ifndef Sigret_t +#define Sigret_t void +#endif +#ifndef Sigarg_t +#ifdef KR_headers +#define Sigarg_t +#else +#define Sigarg_t int +#endif +#endif /*Sigarg_t*/ + +#ifdef USE_SIG_PF /* compile with -DUSE_SIG_PF under IRIX */ +#define sig_pf SIG_PF +#else +typedef Sigret_t (*sig_pf)(Sigarg_t); +#endif + +#define signal1(a,b) signal(a,(sig_pf)b) + +#ifdef __cplusplus +#define Sigarg ... +#define Use_Sigarg +#else +#define Sigarg Int n +#define Use_Sigarg n = n /* shut up compiler warning */ +#endif diff --git a/unix/f2c/libf2c/signal1.h0 b/unix/f2c/libf2c/signal1.h0 new file mode 100644 index 00000000..a383774b --- /dev/null +++ b/unix/f2c/libf2c/signal1.h0 @@ -0,0 +1,35 @@ +/* You may need to adjust the definition of signal1 to supply a */ +/* cast to the correct argument type. This detail is system- and */ +/* compiler-dependent. The #define below assumes signal.h declares */ +/* type SIG_PF for the signal function's second argument. */ + +/* For some C++ compilers, "#define Sigarg_t ..." may be appropriate. */ + +#include <signal.h> + +#ifndef Sigret_t +#define Sigret_t void +#endif +#ifndef Sigarg_t +#ifdef KR_headers +#define Sigarg_t +#else +#define Sigarg_t int +#endif +#endif /*Sigarg_t*/ + +#ifdef USE_SIG_PF /* compile with -DUSE_SIG_PF under IRIX */ +#define sig_pf SIG_PF +#else +typedef Sigret_t (*sig_pf)(Sigarg_t); +#endif + +#define signal1(a,b) signal(a,(sig_pf)b) + +#ifdef __cplusplus +#define Sigarg ... +#define Use_Sigarg +#else +#define Sigarg Int n +#define Use_Sigarg n = n /* shut up compiler warning */ +#endif diff --git a/unix/f2c/libf2c/signal_.c b/unix/f2c/libf2c/signal_.c new file mode 100644 index 00000000..3b0e6cfe --- /dev/null +++ b/unix/f2c/libf2c/signal_.c @@ -0,0 +1,21 @@ +#include "f2c.h" +#include "signal1.h" +#ifdef __cplusplus +extern "C" { +#endif + + ftnint +#ifdef KR_headers +signal_(sigp, proc) integer *sigp; sig_pf proc; +#else +signal_(integer *sigp, sig_pf proc) +#endif +{ + int sig; + sig = (int)*sigp; + + return (ftnint)signal(sig, proc); + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/signbit.c b/unix/f2c/libf2c/signbit.c new file mode 100644 index 00000000..de95a3b7 --- /dev/null +++ b/unix/f2c/libf2c/signbit.c @@ -0,0 +1,24 @@ +#include "arith.h" + +#ifndef Long +#define Long long +#endif + + int +#ifdef KR_headers +signbit_f2c(x) double *x; +#else +signbit_f2c(double *x) +#endif +{ +#ifdef IEEE_MC68k + if (*(Long*)x & 0x80000000) + return 1; +#else +#ifdef IEEE_8087 + if (((Long*)x)[1] & 0x80000000) + return 1; +#endif /*IEEE_8087*/ +#endif /*IEEE_MC68k*/ + return 0; + } diff --git a/unix/f2c/libf2c/sue.c b/unix/f2c/libf2c/sue.c new file mode 100644 index 00000000..191e3262 --- /dev/null +++ b/unix/f2c/libf2c/sue.c @@ -0,0 +1,90 @@ +#include "f2c.h" +#include "fio.h" +#ifdef __cplusplus +extern "C" { +#endif +extern uiolen f__reclen; +OFF_T f__recloc; + + int +#ifdef KR_headers +c_sue(a) cilist *a; +#else +c_sue(cilist *a) +#endif +{ + f__external=f__sequential=1; + f__formatted=0; + f__curunit = &f__units[a->ciunit]; + if(a->ciunit >= MXUNIT || a->ciunit < 0) + err(a->cierr,101,"startio"); + f__elist=a; + if(f__curunit->ufd==NULL && fk_open(SEQ,UNF,a->ciunit)) + err(a->cierr,114,"sue"); + f__cf=f__curunit->ufd; + if(f__curunit->ufmt) err(a->cierr,103,"sue") + if(!f__curunit->useek) err(a->cierr,103,"sue") + return(0); +} +#ifdef KR_headers +integer s_rsue(a) cilist *a; +#else +integer s_rsue(cilist *a) +#endif +{ + int n; + if(!f__init) f_init(); + f__reading=1; + if(n=c_sue(a)) return(n); + f__recpos=0; + if(f__curunit->uwrt && f__nowreading(f__curunit)) + err(a->cierr, errno, "read start"); + if(fread((char *)&f__reclen,sizeof(uiolen),1,f__cf) + != 1) + { if(feof(f__cf)) + { f__curunit->uend = 1; + err(a->ciend, EOF, "start"); + } + clearerr(f__cf); + err(a->cierr, errno, "start"); + } + return(0); +} +#ifdef KR_headers +integer s_wsue(a) cilist *a; +#else +integer s_wsue(cilist *a) +#endif +{ + int n; + if(!f__init) f_init(); + if(n=c_sue(a)) return(n); + f__reading=0; + f__reclen=0; + if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit)) + err(a->cierr, errno, "write start"); + f__recloc=FTELL(f__cf); + FSEEK(f__cf,(OFF_T)sizeof(uiolen),SEEK_CUR); + return(0); +} +integer e_wsue(Void) +{ OFF_T loc; + fwrite((char *)&f__reclen,sizeof(uiolen),1,f__cf); +#ifdef ALWAYS_FLUSH + if (fflush(f__cf)) + err(f__elist->cierr, errno, "write end"); +#endif + loc=FTELL(f__cf); + FSEEK(f__cf,f__recloc,SEEK_SET); + fwrite((char *)&f__reclen,sizeof(uiolen),1,f__cf); + FSEEK(f__cf,loc,SEEK_SET); + return(0); +} +integer e_rsue(Void) +{ + FSEEK(f__cf,(OFF_T)(f__reclen-f__recpos+sizeof(uiolen)),SEEK_CUR); + return(0); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/sysdep1.h b/unix/f2c/libf2c/sysdep1.h new file mode 100644 index 00000000..4c026a24 --- /dev/null +++ b/unix/f2c/libf2c/sysdep1.h @@ -0,0 +1,66 @@ +#ifndef SYSDEP_H_INCLUDED +#define SYSDEP_H_INCLUDED +#undef USE_LARGEFILE +#ifndef NO_LONG_LONG + +#ifdef __sun__ +#define USE_LARGEFILE +#define OFF_T off64_t +#endif + +#ifdef __linux__ +#define USE_LARGEFILE +#define OFF_T __off64_t +#endif + +#ifdef _AIX43 +#define _LARGE_FILES +#define _LARGE_FILE_API +#define USE_LARGEFILE +#endif /*_AIX43*/ + +#ifdef __hpux +#define _FILE64 +#define _LARGEFILE64_SOURCE +#define USE_LARGEFILE +#endif /*__hpux*/ + +#ifdef __sgi +#define USE_LARGEFILE +#endif /*__sgi*/ + +#ifdef __FreeBSD__ +#define OFF_T off_t +#define FSEEK fseeko +#define FTELL ftello +#endif + +#ifdef USE_LARGEFILE +#ifndef OFF_T +#define OFF_T off64_t +#endif +#define _LARGEFILE_SOURCE +#define _LARGEFILE64_SOURCE +#include <sys/types.h> +#include <sys/stat.h> +#define FOPEN fopen64 +#define FREOPEN freopen64 +#define FSEEK fseeko64 +#define FSTAT fstat64 +#define FTELL ftello64 +#define FTRUNCATE ftruncate64 +#define STAT stat64 +#define STAT_ST stat64 +#endif /*USE_LARGEFILE*/ +#endif /*NO_LONG_LONG*/ + +#ifndef NON_UNIX_STDIO +#ifndef USE_LARGEFILE +#define _INCLUDE_POSIX_SOURCE /* for HP-UX */ +#define _INCLUDE_XOPEN_SOURCE /* for HP-UX */ +#include "sys/types.h" +#include "sys/stat.h" +#endif +#endif + +#endif /*SYSDEP_H_INCLUDED*/ diff --git a/unix/f2c/libf2c/sysdep1.h0 b/unix/f2c/libf2c/sysdep1.h0 new file mode 100644 index 00000000..4c026a24 --- /dev/null +++ b/unix/f2c/libf2c/sysdep1.h0 @@ -0,0 +1,66 @@ +#ifndef SYSDEP_H_INCLUDED +#define SYSDEP_H_INCLUDED +#undef USE_LARGEFILE +#ifndef NO_LONG_LONG + +#ifdef __sun__ +#define USE_LARGEFILE +#define OFF_T off64_t +#endif + +#ifdef __linux__ +#define USE_LARGEFILE +#define OFF_T __off64_t +#endif + +#ifdef _AIX43 +#define _LARGE_FILES +#define _LARGE_FILE_API +#define USE_LARGEFILE +#endif /*_AIX43*/ + +#ifdef __hpux +#define _FILE64 +#define _LARGEFILE64_SOURCE +#define USE_LARGEFILE +#endif /*__hpux*/ + +#ifdef __sgi +#define USE_LARGEFILE +#endif /*__sgi*/ + +#ifdef __FreeBSD__ +#define OFF_T off_t +#define FSEEK fseeko +#define FTELL ftello +#endif + +#ifdef USE_LARGEFILE +#ifndef OFF_T +#define OFF_T off64_t +#endif +#define _LARGEFILE_SOURCE +#define _LARGEFILE64_SOURCE +#include <sys/types.h> +#include <sys/stat.h> +#define FOPEN fopen64 +#define FREOPEN freopen64 +#define FSEEK fseeko64 +#define FSTAT fstat64 +#define FTELL ftello64 +#define FTRUNCATE ftruncate64 +#define STAT stat64 +#define STAT_ST stat64 +#endif /*USE_LARGEFILE*/ +#endif /*NO_LONG_LONG*/ + +#ifndef NON_UNIX_STDIO +#ifndef USE_LARGEFILE +#define _INCLUDE_POSIX_SOURCE /* for HP-UX */ +#define _INCLUDE_XOPEN_SOURCE /* for HP-UX */ +#include "sys/types.h" +#include "sys/stat.h" +#endif +#endif + +#endif /*SYSDEP_H_INCLUDED*/ diff --git a/unix/f2c/libf2c/system_.c b/unix/f2c/libf2c/system_.c new file mode 100644 index 00000000..b18e8a67 --- /dev/null +++ b/unix/f2c/libf2c/system_.c @@ -0,0 +1,42 @@ +/* f77 interface to system routine */ + +#include "f2c.h" + +#ifdef KR_headers +extern char *F77_aloc(); + + integer +system_(s, n) register char *s; ftnlen n; +#else +#undef abs +#undef min +#undef max +#include "stdlib.h" +#ifdef __cplusplus +extern "C" { +#endif +extern char *F77_aloc(ftnlen, const char*); + + integer +system_(register char *s, ftnlen n) +#endif +{ + char buff0[256], *buff; + register char *bp, *blast; + integer rv; + + buff = bp = n < sizeof(buff0) + ? buff0 : F77_aloc(n+1, "system_"); + blast = bp + n; + + while(bp < blast && *s) + *bp++ = *s++; + *bp = 0; + rv = system(buff); + if (buff != buff0) + free(buff); + return rv; + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/typesize.c b/unix/f2c/libf2c/typesize.c new file mode 100644 index 00000000..39097f46 --- /dev/null +++ b/unix/f2c/libf2c/typesize.c @@ -0,0 +1,18 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +ftnlen f__typesize[] = { 0, 0, sizeof(shortint), sizeof(integer), + sizeof(real), sizeof(doublereal), + sizeof(complex), sizeof(doublecomplex), + sizeof(logical), sizeof(char), + 0, sizeof(integer1), + sizeof(logical1), sizeof(shortlogical), +#ifdef Allow_TYQUAD + sizeof(longint), +#endif + 0}; +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/uio.c b/unix/f2c/libf2c/uio.c new file mode 100644 index 00000000..44f768d9 --- /dev/null +++ b/unix/f2c/libf2c/uio.c @@ -0,0 +1,75 @@ +#include "f2c.h" +#include "fio.h" +#ifdef __cplusplus +extern "C" { +#endif +uiolen f__reclen; + + int +#ifdef KR_headers +do_us(number,ptr,len) ftnint *number; char *ptr; ftnlen len; +#else +do_us(ftnint *number, char *ptr, ftnlen len) +#endif +{ + if(f__reading) + { + f__recpos += (int)(*number * len); + if(f__recpos>f__reclen) + err(f__elist->cierr, 110, "do_us"); + if (fread(ptr,(int)len,(int)(*number),f__cf) != *number) + err(f__elist->ciend, EOF, "do_us"); + return(0); + } + else + { + f__reclen += *number * len; + (void) fwrite(ptr,(int)len,(int)(*number),f__cf); + return(0); + } +} +#ifdef KR_headers +integer do_ud(number,ptr,len) ftnint *number; char *ptr; ftnlen len; +#else +integer do_ud(ftnint *number, char *ptr, ftnlen len) +#endif +{ + f__recpos += (int)(*number * len); + if(f__recpos > f__curunit->url && f__curunit->url!=1) + err(f__elist->cierr,110,"do_ud"); + if(f__reading) + { +#ifdef Pad_UDread +#ifdef KR_headers + int i; +#else + size_t i; +#endif + if (!(i = fread(ptr,(int)len,(int)(*number),f__cf)) + && !(f__recpos - *number*len)) + err(f__elist->cierr,EOF,"do_ud") + if (i < *number) + memset(ptr + i*len, 0, (*number - i)*len); + return 0; +#else + if(fread(ptr,(int)len,(int)(*number),f__cf) != *number) + err(f__elist->cierr,EOF,"do_ud") + else return(0); +#endif + } + (void) fwrite(ptr,(int)len,(int)(*number),f__cf); + return(0); +} +#ifdef KR_headers +integer do_uio(number,ptr,len) ftnint *number; char *ptr; ftnlen len; +#else +integer do_uio(ftnint *number, char *ptr, ftnlen len) +#endif +{ + if(f__sequential) + return(do_us(number,ptr,len)); + else return(do_ud(number,ptr,len)); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/uninit.c b/unix/f2c/libf2c/uninit.c new file mode 100644 index 00000000..f15fe391 --- /dev/null +++ b/unix/f2c/libf2c/uninit.c @@ -0,0 +1,377 @@ +#include <stdio.h> +#include <string.h> +#include "arith.h" + +#define TYSHORT 2 +#define TYLONG 3 +#define TYREAL 4 +#define TYDREAL 5 +#define TYCOMPLEX 6 +#define TYDCOMPLEX 7 +#define TYINT1 11 +#define TYQUAD 14 +#ifndef Long +#define Long long +#endif + +#ifdef __mips +#define RNAN 0xffc00000 +#define DNAN0 0xfff80000 +#define DNAN1 0 +#endif + +#ifdef _PA_RISC1_1 +#define RNAN 0xffc00000 +#define DNAN0 0xfff80000 +#define DNAN1 0 +#endif + +#ifndef RNAN +#define RNAN 0xff800001 +#ifdef IEEE_MC68k +#define DNAN0 0xfff00000 +#define DNAN1 1 +#else +#define DNAN0 1 +#define DNAN1 0xfff00000 +#endif +#endif /*RNAN*/ + +#ifdef KR_headers +#define Void /*void*/ +#define FA7UL (unsigned Long) 0xfa7a7a7aL +#else +#define Void void +#define FA7UL 0xfa7a7a7aUL +#endif + +#ifdef __cplusplus +extern "C" { +#endif + +static void ieee0(Void); + +static unsigned Long rnan = RNAN, + dnan0 = DNAN0, + dnan1 = DNAN1; + +double _0 = 0.; + + void +#ifdef KR_headers +_uninit_f2c(x, type, len) void *x; int type; long len; +#else +_uninit_f2c(void *x, int type, long len) +#endif +{ + static int first = 1; + + unsigned Long *lx, *lxe; + + if (first) { + first = 0; + ieee0(); + } + if (len == 1) + switch(type) { + case TYINT1: + *(char*)x = 'Z'; + return; + case TYSHORT: + *(short*)x = 0xfa7a; + break; + case TYLONG: + *(unsigned Long*)x = FA7UL; + return; + case TYQUAD: + case TYCOMPLEX: + case TYDCOMPLEX: + break; + case TYREAL: + *(unsigned Long*)x = rnan; + return; + case TYDREAL: + lx = (unsigned Long*)x; + lx[0] = dnan0; + lx[1] = dnan1; + return; + default: + printf("Surprise type %d in _uninit_f2c\n", type); + } + switch(type) { + case TYINT1: + memset(x, 'Z', len); + break; + case TYSHORT: + *(short*)x = 0xfa7a; + break; + case TYQUAD: + len *= 2; + /* no break */ + case TYLONG: + lx = (unsigned Long*)x; + lxe = lx + len; + while(lx < lxe) + *lx++ = FA7UL; + break; + case TYCOMPLEX: + len *= 2; + /* no break */ + case TYREAL: + lx = (unsigned Long*)x; + lxe = lx + len; + while(lx < lxe) + *lx++ = rnan; + break; + case TYDCOMPLEX: + len *= 2; + /* no break */ + case TYDREAL: + lx = (unsigned Long*)x; + for(lxe = lx + 2*len; lx < lxe; lx += 2) { + lx[0] = dnan0; + lx[1] = dnan1; + } + } + } +#ifdef __cplusplus +} +#endif + +#ifndef MSpc +#ifdef MSDOS +#define MSpc +#else +#ifdef _WIN32 +#define MSpc +#endif +#endif +#endif + +#ifdef MSpc +#define IEEE0_done +#include "float.h" +#include "signal.h" + + static void +ieee0(Void) +{ +#ifndef __alpha +#ifndef EM_DENORMAL +#define EM_DENORMAL _EM_DENORMAL +#endif +#ifndef EM_UNDERFLOW +#define EM_UNDERFLOW _EM_UNDERFLOW +#endif +#ifndef EM_INEXACT +#define EM_INEXACT _EM_INEXACT +#endif +#ifndef MCW_EM +#define MCW_EM _MCW_EM +#endif + _control87(EM_DENORMAL | EM_UNDERFLOW | EM_INEXACT, MCW_EM); +#endif + /* With MS VC++, compiling and linking with -Zi will permit */ + /* clicking to invoke the MS C++ debugger, which will show */ + /* the point of error -- provided SIGFPE is SIG_DFL. */ + signal(SIGFPE, SIG_DFL); + } +#endif /* MSpc */ + +#ifdef __mips /* must link with -lfpe */ +#define IEEE0_done +/* code from Eric Grosse */ +#include <stdlib.h> +#include <stdio.h> +#include "/usr/include/sigfpe.h" /* full pathname for lcc -N */ +#include "/usr/include/sys/fpu.h" + + static void +#ifdef KR_headers +ieeeuserhand(exception, val) unsigned exception[5]; int val[2]; +#else +ieeeuserhand(unsigned exception[5], int val[2]) +#endif +{ + fflush(stdout); + fprintf(stderr,"ieee0() aborting because of "); + if(exception[0]==_OVERFL) fprintf(stderr,"overflow\n"); + else if(exception[0]==_UNDERFL) fprintf(stderr,"underflow\n"); + else if(exception[0]==_DIVZERO) fprintf(stderr,"divide by 0\n"); + else if(exception[0]==_INVALID) fprintf(stderr,"invalid operation\n"); + else fprintf(stderr,"\tunknown reason\n"); + fflush(stderr); + abort(); +} + + static void +#ifdef KR_headers +ieeeuserhand2(j) unsigned int **j; +#else +ieeeuserhand2(unsigned int **j) +#endif +{ + fprintf(stderr,"ieee0() aborting because of confusion\n"); + abort(); +} + + static void +ieee0(Void) +{ + int i; + for(i=1; i<=4; i++){ + sigfpe_[i].count = 1000; + sigfpe_[i].trace = 1; + sigfpe_[i].repls = _USER_DETERMINED; + } + sigfpe_[1].repls = _ZERO; /* underflow */ + handle_sigfpes( _ON, + _EN_UNDERFL|_EN_OVERFL|_EN_DIVZERO|_EN_INVALID, + ieeeuserhand,_ABORT_ON_ERROR,ieeeuserhand2); + } +#endif /* mips */ + +#ifdef __linux__ +#define IEEE0_done +#include "fpu_control.h" + +#ifdef __alpha__ +#ifndef USE_setfpucw +#define __setfpucw(x) __fpu_control = (x) +#endif +#endif + +#ifndef _FPU_SETCW +#undef Can_use__setfpucw +#define Can_use__setfpucw +#endif + + static void +ieee0(Void) +{ +#if (defined(__mc68000__) || defined(__mc68020__) || defined(mc68020) || defined (__mc68k__)) +/* Reported 20010705 by Alan Bain <alanb@chiark.greenend.org.uk> */ +/* Note that IEEE 754 IOP (illegal operation) */ +/* = Signaling NAN (SNAN) + operation error (OPERR). */ +#ifdef Can_use__setfpucw + __setfpucw(_FPU_IEEE + _FPU_DOUBLE + _FPU_MASK_OPERR + _FPU_MASK_DZ + _FPU_MASK_SNAN+_FPU_MASK_OVFL); +#else + __fpu_control = _FPU_IEEE + _FPU_DOUBLE + _FPU_MASK_OPERR + _FPU_MASK_DZ + _FPU_MASK_SNAN+_FPU_MASK_OVFL; + _FPU_SETCW(__fpu_control); +#endif + +#elif (defined(__powerpc__)||defined(_ARCH_PPC)||defined(_ARCH_PWR)) /* !__mc68k__ */ +/* Reported 20011109 by Alan Bain <alanb@chiark.greenend.org.uk> */ + +#ifdef Can_use__setfpucw + +/* The following is NOT a mistake -- the author of the fpu_control.h +for the PPC has erroneously defined IEEE mode to turn on exceptions +other than Inexact! Start from default then and turn on only the ones +which we want*/ + + __setfpucw(_FPU_DEFAULT + _FPU_MASK_IM+_FPU_MASK_OM+_FPU_MASK_UM); + +#else /* PPC && !Can_use__setfpucw */ + + __fpu_control = _FPU_DEFAULT +_FPU_MASK_OM+_FPU_MASK_IM+_FPU_MASK_UM; + _FPU_SETCW(__fpu_control); + +#endif /*Can_use__setfpucw*/ + +#else /* !(mc68000||powerpc) */ + +#ifdef _FPU_IEEE +#ifndef _FPU_EXTENDED /* e.g., ARM processor under Linux */ +#define _FPU_EXTENDED 0 +#endif +#ifndef _FPU_DOUBLE +#define _FPU_DOUBLE 0 +#endif +#ifdef Can_use__setfpucw /* pre-1997 (?) Linux */ + __setfpucw(_FPU_IEEE - _FPU_MASK_IM - _FPU_MASK_ZM - _FPU_MASK_OM); +#else +#ifdef UNINIT_F2C_PRECISION_53 /* 20051004 */ + /* unmask invalid, etc., and change rounding precision to double */ + __fpu_control = _FPU_IEEE - _FPU_EXTENDED + _FPU_DOUBLE - _FPU_MASK_IM - _FPU_MASK_ZM - _FPU_MASK_OM; + _FPU_SETCW(__fpu_control); +#else + /* unmask invalid, etc., and keep current rounding precision */ + fpu_control_t cw; + _FPU_GETCW(cw); + cw &= ~(_FPU_MASK_IM | _FPU_MASK_ZM | _FPU_MASK_OM); + _FPU_SETCW(cw); +#endif +#endif + +#else /* !_FPU_IEEE */ + + fprintf(stderr, "\n%s\n%s\n%s\n%s\n", + "WARNING: _uninit_f2c in libf2c does not know how", + "to enable trapping on this system, so f2c's -trapuv", + "option will not detect uninitialized variables unless", + "you can enable trapping manually."); + fflush(stderr); + +#endif /* _FPU_IEEE */ +#endif /* __mc68k__ */ + } +#endif /* __linux__ */ + +#ifdef __alpha +#ifndef IEEE0_done +#define IEEE0_done +#include <machine/fpu.h> + static void +ieee0(Void) +{ + ieee_set_fp_control(IEEE_TRAP_ENABLE_INV); + } +#endif /*IEEE0_done*/ +#endif /*__alpha*/ + +#ifdef __hpux +#define IEEE0_done +#define _INCLUDE_HPUX_SOURCE +#include <math.h> + +#ifndef FP_X_INV +#include <fenv.h> +#define fpsetmask fesettrapenable +#define FP_X_INV FE_INVALID +#endif + + static void +ieee0(Void) +{ + fpsetmask(FP_X_INV); + } +#endif /*__hpux*/ + +#ifdef _AIX +#define IEEE0_done +#include <fptrap.h> + + static void +ieee0(Void) +{ + fp_enable(TRP_INVALID); + fp_trap(FP_TRAP_SYNC); + } +#endif /*_AIX*/ + +#ifdef __sun +#define IEEE0_done +#include <ieeefp.h> + + static void +ieee0(Void) +{ + fpsetmask(FP_X_INV); + } +#endif /*__sparc*/ + +#ifndef IEEE0_done + static void +ieee0(Void) {} +#endif diff --git a/unix/f2c/libf2c/util.c b/unix/f2c/libf2c/util.c new file mode 100644 index 00000000..ad4bec5a --- /dev/null +++ b/unix/f2c/libf2c/util.c @@ -0,0 +1,57 @@ +#include "sysdep1.h" /* here to get stat64 on some badly designed Linux systems */ +#include "f2c.h" +#include "fio.h" +#ifdef __cplusplus +extern "C" { +#endif + + VOID +#ifdef KR_headers +#define Const /*nothing*/ +g_char(a,alen,b) char *a,*b; ftnlen alen; +#else +#define Const const +g_char(const char *a, ftnlen alen, char *b) +#endif +{ + Const char *x = a + alen; + char *y = b + alen; + + for(;; y--) { + if (x <= a) { + *b = 0; + return; + } + if (*--x != ' ') + break; + } + *y-- = 0; + do *y-- = *x; + while(x-- > a); + } + + VOID +#ifdef KR_headers +b_char(a,b,blen) char *a,*b; ftnlen blen; +#else +b_char(const char *a, char *b, ftnlen blen) +#endif +{ int i; + for(i=0;i<blen && *a!=0;i++) *b++= *a++; + for(;i<blen;i++) *b++=' '; +} +#ifndef NON_UNIX_STDIO +#ifdef KR_headers +long f__inode(a, dev) char *a; int *dev; +#else +long f__inode(char *a, int *dev) +#endif +{ struct STAT_ST x; + if(STAT(a,&x)<0) return(-1); + *dev = x.st_dev; + return(x.st_ino); +} +#endif +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/wref.c b/unix/f2c/libf2c/wref.c new file mode 100644 index 00000000..f2074b75 --- /dev/null +++ b/unix/f2c/libf2c/wref.c @@ -0,0 +1,294 @@ +#include "f2c.h" +#include "fio.h" + +#ifndef KR_headers +#undef abs +#undef min +#undef max +#include "stdlib.h" +#include "string.h" +#endif + +#include "fmt.h" +#include "fp.h" +#ifndef VAX +#include "ctype.h" +#ifdef __cplusplus +extern "C" { +#endif +#endif + + int +#ifdef KR_headers +wrt_E(p,w,d,e,len) ufloat *p; ftnlen len; +#else +wrt_E(ufloat *p, int w, int d, int e, ftnlen len) +#endif +{ + char buf[FMAX+EXPMAXDIGS+4], *s, *se; + int d1, delta, e1, i, sign, signspace; + double dd; +#ifdef WANT_LEAD_0 + int insert0 = 0; +#endif +#ifndef VAX + int e0 = e; +#endif + + if(e <= 0) + e = 2; + if(f__scale) { + if(f__scale >= d + 2 || f__scale <= -d) + goto nogood; + } + if(f__scale <= 0) + --d; + if (len == sizeof(real)) + dd = p->pf; + else + dd = p->pd; + if (dd < 0.) { + signspace = sign = 1; + dd = -dd; + } + else { + sign = 0; + signspace = (int)f__cplus; +#ifndef VAX + if (!dd) { +#ifdef SIGNED_ZEROS + if (signbit_f2c(&dd)) + signspace = sign = 1; +#endif + dd = 0.; /* avoid -0 */ + } +#endif + } + delta = w - (2 /* for the . and the d adjustment above */ + + 2 /* for the E+ */ + signspace + d + e); +#ifdef WANT_LEAD_0 + if (f__scale <= 0 && delta > 0) { + delta--; + insert0 = 1; + } + else +#endif + if (delta < 0) { +nogood: + while(--w >= 0) + PUT('*'); + return(0); + } + if (f__scale < 0) + d += f__scale; + if (d > FMAX) { + d1 = d - FMAX; + d = FMAX; + } + else + d1 = 0; + sprintf(buf,"%#.*E", d, dd); +#ifndef VAX + /* check for NaN, Infinity */ + if (!isdigit(buf[0])) { + switch(buf[0]) { + case 'n': + case 'N': + signspace = 0; /* no sign for NaNs */ + } + delta = w - strlen(buf) - signspace; + if (delta < 0) + goto nogood; + while(--delta >= 0) + PUT(' '); + if (signspace) + PUT(sign ? '-' : '+'); + for(s = buf; *s; s++) + PUT(*s); + return 0; + } +#endif + se = buf + d + 3; +#ifdef GOOD_SPRINTF_EXPONENT /* When possible, exponent has 2 digits. */ + if (f__scale != 1 && dd) + sprintf(se, "%+.2d", atoi(se) + 1 - f__scale); +#else + if (dd) + sprintf(se, "%+.2d", atoi(se) + 1 - f__scale); + else + strcpy(se, "+00"); +#endif + s = ++se; + if (e < 2) { + if (*s != '0') + goto nogood; + } +#ifndef VAX + /* accommodate 3 significant digits in exponent */ + if (s[2]) { +#ifdef Pedantic + if (!e0 && !s[3]) + for(s -= 2, e1 = 2; s[0] = s[1]; s++); + + /* Pedantic gives the behavior that Fortran 77 specifies, */ + /* i.e., requires that E be specified for exponent fields */ + /* of more than 3 digits. With Pedantic undefined, we get */ + /* the behavior that Cray displays -- you get a bigger */ + /* exponent field if it fits. */ +#else + if (!e0) { + for(s -= 2, e1 = 2; s[0] = s[1]; s++) +#ifdef CRAY + delta--; + if ((delta += 4) < 0) + goto nogood +#endif + ; + } +#endif + else if (e0 >= 0) + goto shift; + else + e1 = e; + } + else + shift: +#endif + for(s += 2, e1 = 2; *s; ++e1, ++s) + if (e1 >= e) + goto nogood; + while(--delta >= 0) + PUT(' '); + if (signspace) + PUT(sign ? '-' : '+'); + s = buf; + i = f__scale; + if (f__scale <= 0) { +#ifdef WANT_LEAD_0 + if (insert0) + PUT('0'); +#endif + PUT('.'); + for(; i < 0; ++i) + PUT('0'); + PUT(*s); + s += 2; + } + else if (f__scale > 1) { + PUT(*s); + s += 2; + while(--i > 0) + PUT(*s++); + PUT('.'); + } + if (d1) { + se -= 2; + while(s < se) PUT(*s++); + se += 2; + do PUT('0'); while(--d1 > 0); + } + while(s < se) + PUT(*s++); + if (e < 2) + PUT(s[1]); + else { + while(++e1 <= e) + PUT('0'); + while(*s) + PUT(*s++); + } + return 0; + } + + int +#ifdef KR_headers +wrt_F(p,w,d,len) ufloat *p; ftnlen len; +#else +wrt_F(ufloat *p, int w, int d, ftnlen len) +#endif +{ + int d1, sign, n; + double x; + char *b, buf[MAXINTDIGS+MAXFRACDIGS+4], *s; + + x= (len==sizeof(real)?p->pf:p->pd); + if (d < MAXFRACDIGS) + d1 = 0; + else { + d1 = d - MAXFRACDIGS; + d = MAXFRACDIGS; + } + if (x < 0.) + { x = -x; sign = 1; } + else { + sign = 0; +#ifndef VAX + if (!x) { +#ifdef SIGNED_ZEROS + if (signbit_f2c(&x)) + sign = 2; +#endif + x = 0.; + } +#endif + } + + if (n = f__scale) + if (n > 0) + do x *= 10.; while(--n > 0); + else + do x *= 0.1; while(++n < 0); + +#ifdef USE_STRLEN + sprintf(b = buf, "%#.*f", d, x); + n = strlen(b) + d1; +#else + n = sprintf(b = buf, "%#.*f", d, x) + d1; +#endif + +#ifndef WANT_LEAD_0 + if (buf[0] == '0' && d) + { ++b; --n; } +#endif + if (sign == 1) { + /* check for all zeros */ + for(s = b;;) { + while(*s == '0') s++; + switch(*s) { + case '.': + s++; continue; + case 0: + sign = 0; + } + break; + } + } + if (sign || f__cplus) + ++n; + if (n > w) { +#ifdef WANT_LEAD_0 + if (buf[0] == '0' && --n == w) + ++b; + else +#endif + { + while(--w >= 0) + PUT('*'); + return 0; + } + } + for(w -= n; --w >= 0; ) + PUT(' '); + if (sign) + PUT('-'); + else if (f__cplus) + PUT('+'); + while(n = *b++) + PUT(n); + while(--d1 >= 0) + PUT('0'); + return 0; + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/wrtfmt.c b/unix/f2c/libf2c/wrtfmt.c new file mode 100644 index 00000000..a970db95 --- /dev/null +++ b/unix/f2c/libf2c/wrtfmt.c @@ -0,0 +1,377 @@ +#include "f2c.h" +#include "fio.h" +#include "fmt.h" +#ifdef __cplusplus +extern "C" { +#endif + +extern icilist *f__svic; +extern char *f__icptr; + + static int +mv_cur(Void) /* shouldn't use fseek because it insists on calling fflush */ + /* instead we know too much about stdio */ +{ + int cursor = f__cursor; + f__cursor = 0; + if(f__external == 0) { + if(cursor < 0) { + if(f__hiwater < f__recpos) + f__hiwater = f__recpos; + f__recpos += cursor; + f__icptr += cursor; + if(f__recpos < 0) + err(f__elist->cierr, 110, "left off"); + } + else if(cursor > 0) { + if(f__recpos + cursor >= f__svic->icirlen) + err(f__elist->cierr, 110, "recend"); + if(f__hiwater <= f__recpos) + for(; cursor > 0; cursor--) + (*f__putn)(' '); + else if(f__hiwater <= f__recpos + cursor) { + cursor -= f__hiwater - f__recpos; + f__icptr += f__hiwater - f__recpos; + f__recpos = f__hiwater; + for(; cursor > 0; cursor--) + (*f__putn)(' '); + } + else { + f__icptr += cursor; + f__recpos += cursor; + } + } + return(0); + } + if (cursor > 0) { + if(f__hiwater <= f__recpos) + for(;cursor>0;cursor--) (*f__putn)(' '); + else if(f__hiwater <= f__recpos + cursor) { + cursor -= f__hiwater - f__recpos; + f__recpos = f__hiwater; + for(; cursor > 0; cursor--) + (*f__putn)(' '); + } + else { + f__recpos += cursor; + } + } + else if (cursor < 0) + { + if(cursor + f__recpos < 0) + err(f__elist->cierr,110,"left off"); + if(f__hiwater < f__recpos) + f__hiwater = f__recpos; + f__recpos += cursor; + } + return(0); +} + + static int +#ifdef KR_headers +wrt_Z(n,w,minlen,len) Uint *n; int w, minlen; ftnlen len; +#else +wrt_Z(Uint *n, int w, int minlen, ftnlen len) +#endif +{ + register char *s, *se; + register int i, w1; + static int one = 1; + static char hex[] = "0123456789ABCDEF"; + s = (char *)n; + --len; + if (*(char *)&one) { + /* little endian */ + se = s; + s += len; + i = -1; + } + else { + se = s + len; + i = 1; + } + for(;; s += i) + if (s == se || *s) + break; + w1 = (i*(se-s) << 1) + 1; + if (*s & 0xf0) + w1++; + if (w1 > w) + for(i = 0; i < w; i++) + (*f__putn)('*'); + else { + if ((minlen -= w1) > 0) + w1 += minlen; + while(--w >= w1) + (*f__putn)(' '); + while(--minlen >= 0) + (*f__putn)('0'); + if (!(*s & 0xf0)) { + (*f__putn)(hex[*s & 0xf]); + if (s == se) + return 0; + s += i; + } + for(;; s += i) { + (*f__putn)(hex[*s >> 4 & 0xf]); + (*f__putn)(hex[*s & 0xf]); + if (s == se) + break; + } + } + return 0; + } + + static int +#ifdef KR_headers +wrt_I(n,w,len, base) Uint *n; ftnlen len; register int base; +#else +wrt_I(Uint *n, int w, ftnlen len, register int base) +#endif +{ int ndigit,sign,spare,i; + longint x; + char *ans; + if(len==sizeof(integer)) x=n->il; + else if(len == sizeof(char)) x = n->ic; +#ifdef Allow_TYQUAD + else if (len == sizeof(longint)) x = n->ili; +#endif + else x=n->is; + ans=f__icvt(x,&ndigit,&sign, base); + spare=w-ndigit; + if(sign || f__cplus) spare--; + if(spare<0) + for(i=0;i<w;i++) (*f__putn)('*'); + else + { for(i=0;i<spare;i++) (*f__putn)(' '); + if(sign) (*f__putn)('-'); + else if(f__cplus) (*f__putn)('+'); + for(i=0;i<ndigit;i++) (*f__putn)(*ans++); + } + return(0); +} + static int +#ifdef KR_headers +wrt_IM(n,w,m,len,base) Uint *n; ftnlen len; int base; +#else +wrt_IM(Uint *n, int w, int m, ftnlen len, int base) +#endif +{ int ndigit,sign,spare,i,xsign; + longint x; + char *ans; + if(sizeof(integer)==len) x=n->il; + else if(len == sizeof(char)) x = n->ic; +#ifdef Allow_TYQUAD + else if (len == sizeof(longint)) x = n->ili; +#endif + else x=n->is; + ans=f__icvt(x,&ndigit,&sign, base); + if(sign || f__cplus) xsign=1; + else xsign=0; + if(ndigit+xsign>w || m+xsign>w) + { for(i=0;i<w;i++) (*f__putn)('*'); + return(0); + } + if(x==0 && m==0) + { for(i=0;i<w;i++) (*f__putn)(' '); + return(0); + } + if(ndigit>=m) + spare=w-ndigit-xsign; + else + spare=w-m-xsign; + for(i=0;i<spare;i++) (*f__putn)(' '); + if(sign) (*f__putn)('-'); + else if(f__cplus) (*f__putn)('+'); + for(i=0;i<m-ndigit;i++) (*f__putn)('0'); + for(i=0;i<ndigit;i++) (*f__putn)(*ans++); + return(0); +} + static int +#ifdef KR_headers +wrt_AP(s) char *s; +#else +wrt_AP(char *s) +#endif +{ char quote; + int i; + + if(f__cursor && (i = mv_cur())) + return i; + quote = *s++; + for(;*s;s++) + { if(*s!=quote) (*f__putn)(*s); + else if(*++s==quote) (*f__putn)(*s); + else return(1); + } + return(1); +} + static int +#ifdef KR_headers +wrt_H(a,s) char *s; +#else +wrt_H(int a, char *s) +#endif +{ + int i; + + if(f__cursor && (i = mv_cur())) + return i; + while(a--) (*f__putn)(*s++); + return(1); +} + + int +#ifdef KR_headers +wrt_L(n,len, sz) Uint *n; ftnlen sz; +#else +wrt_L(Uint *n, int len, ftnlen sz) +#endif +{ int i; + long x; + if(sizeof(long)==sz) x=n->il; + else if(sz == sizeof(char)) x = n->ic; + else x=n->is; + for(i=0;i<len-1;i++) + (*f__putn)(' '); + if(x) (*f__putn)('T'); + else (*f__putn)('F'); + return(0); +} + static int +#ifdef KR_headers +wrt_A(p,len) char *p; ftnlen len; +#else +wrt_A(char *p, ftnlen len) +#endif +{ + while(len-- > 0) (*f__putn)(*p++); + return(0); +} + static int +#ifdef KR_headers +wrt_AW(p,w,len) char * p; ftnlen len; +#else +wrt_AW(char * p, int w, ftnlen len) +#endif +{ + while(w>len) + { w--; + (*f__putn)(' '); + } + while(w-- > 0) + (*f__putn)(*p++); + return(0); +} + + static int +#ifdef KR_headers +wrt_G(p,w,d,e,len) ufloat *p; ftnlen len; +#else +wrt_G(ufloat *p, int w, int d, int e, ftnlen len) +#endif +{ double up = 1,x; + int i=0,oldscale,n,j; + x = len==sizeof(real)?p->pf:p->pd; + if(x < 0 ) x = -x; + if(x<.1) { + if (x != 0.) + return(wrt_E(p,w,d,e,len)); + i = 1; + goto have_i; + } + for(;i<=d;i++,up*=10) + { if(x>=up) continue; + have_i: + oldscale = f__scale; + f__scale = 0; + if(e==0) n=4; + else n=e+2; + i=wrt_F(p,w-n,d-i,len); + for(j=0;j<n;j++) (*f__putn)(' '); + f__scale=oldscale; + return(i); + } + return(wrt_E(p,w,d,e,len)); +} + + int +#ifdef KR_headers +w_ed(p,ptr,len) struct syl *p; char *ptr; ftnlen len; +#else +w_ed(struct syl *p, char *ptr, ftnlen len) +#endif +{ + int i; + + if(f__cursor && (i = mv_cur())) + return i; + switch(p->op) + { + default: + fprintf(stderr,"w_ed, unexpected code: %d\n", p->op); + sig_die(f__fmtbuf, 1); + case I: return(wrt_I((Uint *)ptr,p->p1,len, 10)); + case IM: + return(wrt_IM((Uint *)ptr,p->p1,p->p2.i[0],len,10)); + + /* O and OM don't work right for character, double, complex, */ + /* or doublecomplex, and they differ from Fortran 90 in */ + /* showing a minus sign for negative values. */ + + case O: return(wrt_I((Uint *)ptr, p->p1, len, 8)); + case OM: + return(wrt_IM((Uint *)ptr,p->p1,p->p2.i[0],len,8)); + case L: return(wrt_L((Uint *)ptr,p->p1, len)); + case A: return(wrt_A(ptr,len)); + case AW: + return(wrt_AW(ptr,p->p1,len)); + case D: + case E: + case EE: + return(wrt_E((ufloat *)ptr,p->p1,p->p2.i[0],p->p2.i[1],len)); + case G: + case GE: + return(wrt_G((ufloat *)ptr,p->p1,p->p2.i[0],p->p2.i[1],len)); + case F: return(wrt_F((ufloat *)ptr,p->p1,p->p2.i[0],len)); + + /* Z and ZM assume 8-bit bytes. */ + + case Z: return(wrt_Z((Uint *)ptr,p->p1,0,len)); + case ZM: + return(wrt_Z((Uint *)ptr,p->p1,p->p2.i[0],len)); + } +} + + int +#ifdef KR_headers +w_ned(p) struct syl *p; +#else +w_ned(struct syl *p) +#endif +{ + switch(p->op) + { + default: fprintf(stderr,"w_ned, unexpected code: %d\n", p->op); + sig_die(f__fmtbuf, 1); + case SLASH: + return((*f__donewrec)()); + case T: f__cursor = p->p1-f__recpos - 1; + return(1); + case TL: f__cursor -= p->p1; + if(f__cursor < -f__recpos) /* TL1000, 1X */ + f__cursor = -f__recpos; + return(1); + case TR: + case X: + f__cursor += p->p1; + return(1); + case APOS: + return(wrt_AP(p->p2.s)); + case H: + return(wrt_H(p->p1,p->p2.s)); + } +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/wsfe.c b/unix/f2c/libf2c/wsfe.c new file mode 100644 index 00000000..8709f3b3 --- /dev/null +++ b/unix/f2c/libf2c/wsfe.c @@ -0,0 +1,78 @@ +/*write sequential formatted external*/ +#include "f2c.h" +#include "fio.h" +#include "fmt.h" +#ifdef __cplusplus +extern "C" { +#endif + + int +x_wSL(Void) +{ + int n = f__putbuf('\n'); + f__hiwater = f__recpos = f__cursor = 0; + return(n == 0); +} + + static int +xw_end(Void) +{ + int n; + + if(f__nonl) { + f__putbuf(n = 0); + fflush(f__cf); + } + else + n = f__putbuf('\n'); + f__hiwater = f__recpos = f__cursor = 0; + return n; +} + + static int +xw_rev(Void) +{ + int n = 0; + if(f__workdone) { + n = f__putbuf('\n'); + f__workdone = 0; + } + f__hiwater = f__recpos = f__cursor = 0; + return n; +} + +#ifdef KR_headers +integer s_wsfe(a) cilist *a; /*start*/ +#else +integer s_wsfe(cilist *a) /*start*/ +#endif +{ int n; + if(!f__init) f_init(); + f__reading=0; + f__sequential=1; + f__formatted=1; + f__external=1; + if(n=c_sfe(a)) return(n); + f__elist=a; + f__hiwater = f__cursor=f__recpos=0; + f__nonl = 0; + f__scale=0; + f__fmtbuf=a->cifmt; + f__cf=f__curunit->ufd; + if(pars_f(f__fmtbuf)<0) err(a->cierr,100,"startio"); + f__putn= x_putc; + f__doed= w_ed; + f__doned= w_ned; + f__doend=xw_end; + f__dorevert=xw_rev; + f__donewrec=x_wSL; + fmt_bg(); + f__cplus=0; + f__cblank=f__curunit->ublnk; + if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit)) + err(a->cierr,errno,"write start"); + return(0); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/wsle.c b/unix/f2c/libf2c/wsle.c new file mode 100644 index 00000000..3e602702 --- /dev/null +++ b/unix/f2c/libf2c/wsle.c @@ -0,0 +1,42 @@ +#include "f2c.h" +#include "fio.h" +#include "fmt.h" +#include "lio.h" +#include "string.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +integer s_wsle(a) cilist *a; +#else +integer s_wsle(cilist *a) +#endif +{ + int n; + if(n=c_le(a)) return(n); + f__reading=0; + f__external=1; + f__formatted=1; + f__putn = x_putc; + f__lioproc = l_write; + L_len = LINE; + f__donewrec = x_wSL; + if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit)) + err(a->cierr, errno, "list output start"); + return(0); + } + +integer e_wsle(Void) +{ + int n = f__putbuf('\n'); + f__recpos=0; +#ifdef ALWAYS_FLUSH + if (!n && fflush(f__cf)) + err(f__elist->cierr, errno, "write end"); +#endif + return(n); + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/wsne.c b/unix/f2c/libf2c/wsne.c new file mode 100644 index 00000000..e204a51a --- /dev/null +++ b/unix/f2c/libf2c/wsne.c @@ -0,0 +1,32 @@ +#include "f2c.h" +#include "fio.h" +#include "lio.h" +#ifdef __cplusplus +extern "C" { +#endif + + integer +#ifdef KR_headers +s_wsne(a) cilist *a; +#else +s_wsne(cilist *a) +#endif +{ + int n; + + if(n=c_le(a)) + return(n); + f__reading=0; + f__external=1; + f__formatted=1; + f__putn = x_putc; + L_len = LINE; + f__donewrec = x_wSL; + if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit)) + err(a->cierr, errno, "namelist output start"); + x_wsne(a); + return e_wsle(); + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/xsum0.out b/unix/f2c/libf2c/xsum0.out new file mode 100644 index 00000000..d6c6dc0b --- /dev/null +++ b/unix/f2c/libf2c/xsum0.out @@ -0,0 +1,182 @@ +Notice 76f23b4 1212 +README 19870416 16866 +abort_.c f51c808 304 +arithchk.c e460ec03 5299 +backspac.c 10ebf554 1328 +c_abs.c fec22c59 272 +c_cos.c 18fc0ea3 354 +c_div.c 1797c106 936 +c_exp.c 1b85b1fc 349 +c_log.c 28cdfed 384 +c_sin.c 1ccaedc8 350 +c_sqrt.c f1ee88d5 605 +cabs.c f3d3b5f2 494 +close.c 173f01de 1393 +comptry.bat f8a8a0d5 125 +ctype.c f553a125 40 +ctype.h 1e54977d 1139 +d_abs.c e58094ef 218 +d_acos.c e5ecf93d 245 +d_asin.c e12ceeff 245 +d_atan.c 53034db 245 +d_atn2.c ff8a1a78 271 +d_cnjg.c 1c27c728 255 +d_cos.c c0eb625 241 +d_cosh.c 11dc4adb 245 +d_dim.c e1ccb774 232 +d_exp.c 1879c41c 241 +d_imag.c fe9c703e 201 +d_int.c f5de3566 269 +d_lg10.c 1a1d7b77 291 +d_log.c 1b368adf 241 +d_mod.c f540cf24 688 +d_nint.c ff913b40 281 +d_prod.c ad4856b 207 +d_sign.c 9562fc5 266 +d_sin.c 6e3f542 241 +d_sinh.c 18b22950 245 +d_sqrt.c 17e1db09 245 +d_tan.c ec93ebdb 241 +d_tanh.c 1c55d15b 245 +derf_.c f85e74a3 239 +derfc_.c e96b7667 253 +dfe.c 1d658105 2624 +dolio.c 19c9fbd9 471 +dtime_.c c982be4 972 +due.c ee219f6d 1624 +ef1asc_.c e0576e63 521 +ef1cmc_.c ea5ad9e8 427 +endfile.c 6f7201d 2838 +erf_.c e82f7790 270 +erfc_.c ba65441 275 +err.c e59d1707 6442 +etime_.c 19d1fdad 839 +exit_.c ff4baa3a 543 +f2c.h0 e770b7d8 4688 +f2ch.add ef66bf17 6060 +f77_aloc.c f8daf96e 684 +f77vers.c ed1c96fa 4933 +fio.h e41d245e 2939 +fmt.c f9a1bb94 8566 +fmt.h ec84ce17 2006 +fmtlib.c eefc6a27 865 +fp.h 100fb355 665 +ftell_.c 78218d 900 +ftell64_.c e2c4b21e 917 +getarg_.c fd514f59 592 +getenv_.c f4b06e2 1223 +h_abs.c e4443109 218 +h_dim.c c6e48bc 230 +h_dnnt.c f6bb90e 294 +h_indx.c ef8461eb 442 +h_len.c e8c3633 205 +h_mod.c 7355bd0 207 +h_nint.c f0da3396 281 +h_sign.c f1370ffd 266 +hl_ge.c ed792501 346 +hl_gt.c feeacbd9 345 +hl_le.c f6fb5d6e 346 +hl_lt.c 18501419 345 +i77vers.c f57b8ef2 18128 +i_abs.c 12ab51ab 214 +i_dim.c f2a56785 225 +i_dnnt.c 11748482 291 +i_indx.c fb59026f 430 +i_len.c 17d17252 203 +i_mod.c bef73ae 211 +i_nint.c e494b804 278 +i_sign.c fa015b08 260 +iargc_.c 49abda3 196 +iio.c f958b627 2639 +ilnw.c fe0ab14b 1125 +inquire.c 1883d542 2732 +l_ge.c f4710e74 334 +l_gt.c e8db94a7 333 +l_le.c c9c0a99 334 +l_lt.c 767e79f 333 +lbitbits.c 33fe981 1097 +lbitshft.c e81981d2 258 +libf2c.lbc 10af591e 1594 +libf2c.sy fd5f568f 2051 +lio.h 805735d 1564 +lread.c f1e54a1f 14739 +lwrite.c f80da63f 4616 +main.c 371f60f 2230 +makefile.sy 174ccb83 2990 +makefile.u ed8e28fa 7379 +makefile.vc 18a3c2ce 2954 +makefile.wat 18b044ac 2936 +math.hvc 19bb2d07 50 +mkfile.plan9 e67e471e 5174 +open.c e7bcc295 5701 +pow_ci.c fa934cec 412 +pow_dd.c f004559b 276 +pow_di.c a4db539 448 +pow_hh.c d1a45a9 489 +pow_ii.c 1fcf2742 488 +pow_qq.c e6a32de6 516 +pow_ri.c e7d9fc2a 436 +pow_zi.c 1b894af7 851 +pow_zz.c f81a06b5 549 +qbitbits.c fdb9910e 1151 +qbitshft.c 873054d 258 +r_abs.c f471383c 206 +r_acos.c 1a6aca63 233 +r_asin.c e8555587 233 +r_atan.c eac25444 233 +r_atn2.c f611bea 253 +r_cnjg.c a8d7805 235 +r_cos.c fdef1ece 229 +r_cosh.c f05d1ae 233 +r_dim.c ee23e1a8 214 +r_exp.c 1da16cd7 229 +r_imag.c 166ad0f3 189 +r_int.c fc80b9a8 257 +r_lg10.c e876cfab 279 +r_log.c 2062254 229 +r_mod.c 187363fc 678 +r_nint.c 6edcbb2 269 +r_sign.c 1ae32441 248 +r_sin.c c3d968 229 +r_sinh.c 1090c850 233 +r_sqrt.c ffbb0625 233 +r_tan.c fe85179d 229 +r_tanh.c 10ffcc5b 233 +rawio.h 1ab49f7c 718 +rdfmt.c 7222fee 8925 +rewind.c e4c6236f 475 +rsfe.c eb9e882c 1492 +rsli.c 11f59b61 1785 +rsne.c fea7e5be 11585 +s_cat.c 164a6ff1 1458 +s_cmp.c e69e8b60 722 +s_copy.c 1e258852 1024 +s_paus.c e37cfe6 1617 +s_rnge.c e8cf83a3 759 +s_stop.c ffa80b24 762 +scomptry.bat ed740ad8 181 +sfe.c 1e10bda3 828 +sig_die.c 12eb0eac 689 +signal1.h0 1d43ee57 842 +signal_.c f3ef9cfc 299 +signbit.c e37eac06 330 +sue.c 9705ecf 1865 +sysdep1.h0 1812022d 1202 +system_.c ff72e46c 652 +typesize.c eee307ae 386 +uio.c e354a770 1619 +uninit.c fe760fb0 7584 +util.c 172fa76e 972 +wref.c 17bbfb7b 4747 +wrtfmt.c 113fc4f9 7506 +wsfe.c f2d1fe4d 1280 +wsle.c fe50b4c9 697 +wsne.c 428bfda 479 +xwsne.c 185c4bdc 1174 +z_abs.c 1fa0640d 268 +z_cos.c facccd9b 363 +z_div.c e6f03676 913 +z_exp.c 1a8506e8 357 +z_log.c 6bf3b22 2729 +z_sin.c 1aa35b59 359 +z_sqrt.c 1864d867 581 diff --git a/unix/f2c/libf2c/xwsne.c b/unix/f2c/libf2c/xwsne.c new file mode 100644 index 00000000..f810d3ed --- /dev/null +++ b/unix/f2c/libf2c/xwsne.c @@ -0,0 +1,77 @@ +#include "f2c.h" +#include "fio.h" +#include "lio.h" +#include "fmt.h" + +extern int f__Aquote; + + static VOID +nl_donewrec(Void) +{ + (*f__donewrec)(); + PUT(' '); + } + +#ifdef KR_headers +x_wsne(a) cilist *a; +#else +#include "string.h" +#ifdef __cplusplus +extern "C" { +#endif + + VOID +x_wsne(cilist *a) +#endif +{ + Namelist *nl; + char *s; + Vardesc *v, **vd, **vde; + ftnint number, type; + ftnlen *dims; + ftnlen size; + extern ftnlen f__typesize[]; + + nl = (Namelist *)a->cifmt; + PUT('&'); + for(s = nl->name; *s; s++) + PUT(*s); + PUT(' '); + f__Aquote = 1; + vd = nl->vars; + vde = vd + nl->nvars; + while(vd < vde) { + v = *vd++; + s = v->name; +#ifdef No_Extra_Namelist_Newlines + if (f__recpos+strlen(s)+2 >= L_len) +#endif + nl_donewrec(); + while(*s) + PUT(*s++); + PUT(' '); + PUT('='); + number = (dims = v->dims) ? dims[1] : 1; + type = v->type; + if (type < 0) { + size = -type; + type = TYCHAR; + } + else + size = f__typesize[type]; + l_write(&number, v->addr, size, type); + if (vd < vde) { + if (f__recpos+2 >= L_len) + nl_donewrec(); + PUT(','); + PUT(' '); + } + else if (f__recpos+1 >= L_len) + nl_donewrec(); + } + f__Aquote = 0; + PUT('/'); + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/z_abs.c b/unix/f2c/libf2c/z_abs.c new file mode 100644 index 00000000..4d8a015d --- /dev/null +++ b/unix/f2c/libf2c/z_abs.c @@ -0,0 +1,18 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +double f__cabs(); +double z_abs(z) doublecomplex *z; +#else +double f__cabs(double, double); +double z_abs(doublecomplex *z) +#endif +{ +return( f__cabs( z->r, z->i ) ); +} +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/z_cos.c b/unix/f2c/libf2c/z_cos.c new file mode 100644 index 00000000..4abe8bf8 --- /dev/null +++ b/unix/f2c/libf2c/z_cos.c @@ -0,0 +1,21 @@ +#include "f2c.h" + +#ifdef KR_headers +double sin(), cos(), sinh(), cosh(); +VOID z_cos(r, z) doublecomplex *r, *z; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +void z_cos(doublecomplex *r, doublecomplex *z) +#endif +{ + double zi = z->i, zr = z->r; + r->r = cos(zr) * cosh(zi); + r->i = - sin(zr) * sinh(zi); + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/z_div.c b/unix/f2c/libf2c/z_div.c new file mode 100644 index 00000000..e45f3608 --- /dev/null +++ b/unix/f2c/libf2c/z_div.c @@ -0,0 +1,50 @@ +#include "f2c.h" +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef KR_headers +extern VOID sig_die(); +VOID z_div(c, a, b) doublecomplex *a, *b, *c; +#else +extern void sig_die(const char*, int); +void z_div(doublecomplex *c, doublecomplex *a, doublecomplex *b) +#endif +{ + double ratio, den; + double abr, abi, cr; + + if( (abr = b->r) < 0.) + abr = - abr; + if( (abi = b->i) < 0.) + abi = - abi; + if( abr <= abi ) + { + if(abi == 0) { +#ifdef IEEE_COMPLEX_DIVIDE + if (a->i != 0 || a->r != 0) + abi = 1.; + c->i = c->r = abi / abr; + return; +#else + sig_die("complex division by zero", 1); +#endif + } + ratio = b->r / b->i ; + den = b->i * (1 + ratio*ratio); + cr = (a->r*ratio + a->i) / den; + c->i = (a->i*ratio - a->r) / den; + } + + else + { + ratio = b->i / b->r ; + den = b->r * (1 + ratio*ratio); + cr = (a->r + a->i*ratio) / den; + c->i = (a->i - a->r*ratio) / den; + } + c->r = cr; + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/z_exp.c b/unix/f2c/libf2c/z_exp.c new file mode 100644 index 00000000..7b8edfec --- /dev/null +++ b/unix/f2c/libf2c/z_exp.c @@ -0,0 +1,23 @@ +#include "f2c.h" + +#ifdef KR_headers +double exp(), cos(), sin(); +VOID z_exp(r, z) doublecomplex *r, *z; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +void z_exp(doublecomplex *r, doublecomplex *z) +#endif +{ + double expx, zi = z->i; + + expx = exp(z->r); + r->r = expx * cos(zi); + r->i = expx * sin(zi); + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/z_log.c b/unix/f2c/libf2c/z_log.c new file mode 100644 index 00000000..4f11bbe0 --- /dev/null +++ b/unix/f2c/libf2c/z_log.c @@ -0,0 +1,121 @@ +#include "f2c.h" + +#ifdef KR_headers +double log(), f__cabs(), atan2(); +#define ANSI(x) () +#else +#define ANSI(x) x +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +extern double f__cabs(double, double); +#endif + +#ifndef NO_DOUBLE_EXTENDED +#ifndef GCC_COMPARE_BUG_FIXED +#ifndef Pre20000310 +#ifdef Comment +Some versions of gcc, such as 2.95.3 and 3.0.4, are buggy under -O2 or -O3: +on IA32 (Intel 80x87) systems, they may do comparisons on values computed +in extended-precision registers. This can lead to the test "s > s0" that +was used below being carried out incorrectly. The fix below cannot be +spoiled by overzealous optimization, since the compiler cannot know +whether gcc_bug_bypass_diff_F2C will be nonzero. (We expect it always +to be zero. The weird name is unlikely to collide with anything.) + +An example (provided by Ulrich Jakobus) where the bug fix matters is + + double complex a, b + a = (.1099557428756427618354862829619, .9857360542953131909982289471372) + b = log(a) + +An alternative to the fix below would be to use 53-bit rounding precision, +but the means of specifying this 80x87 feature are highly unportable. +#endif /*Comment*/ +#define BYPASS_GCC_COMPARE_BUG +double (*gcc_bug_bypass_diff_F2C) ANSI((double*,double*)); + static double +#ifdef KR_headers +diff1(a,b) double *a, *b; +#else +diff1(double *a, double *b) +#endif +{ return *a - *b; } +#endif /*Pre20000310*/ +#endif /*GCC_COMPARE_BUG_FIXED*/ +#endif /*NO_DOUBLE_EXTENDED*/ + +#ifdef KR_headers +VOID z_log(r, z) doublecomplex *r, *z; +#else +void z_log(doublecomplex *r, doublecomplex *z) +#endif +{ + double s, s0, t, t2, u, v; + double zi = z->i, zr = z->r; +#ifdef BYPASS_GCC_COMPARE_BUG + double (*diff) ANSI((double*,double*)); +#endif + + r->i = atan2(zi, zr); +#ifdef Pre20000310 + r->r = log( f__cabs( zr, zi ) ); +#else + if (zi < 0) + zi = -zi; + if (zr < 0) + zr = -zr; + if (zr < zi) { + t = zi; + zi = zr; + zr = t; + } + t = zi/zr; + s = zr * sqrt(1 + t*t); + /* now s = f__cabs(zi,zr), and zr = |zr| >= |zi| = zi */ + if ((t = s - 1) < 0) + t = -t; + if (t > .01) + r->r = log(s); + else { + +#ifdef Comment + + log(1+x) = x - x^2/2 + x^3/3 - x^4/4 + - ... + + = x(1 - x/2 + x^2/3 -+...) + + [sqrt(y^2 + z^2) - 1] * [sqrt(y^2 + z^2) + 1] = y^2 + z^2 - 1, so + + sqrt(y^2 + z^2) - 1 = (y^2 + z^2 - 1) / [sqrt(y^2 + z^2) + 1] + +#endif /*Comment*/ + +#ifdef BYPASS_GCC_COMPARE_BUG + if (!(diff = gcc_bug_bypass_diff_F2C)) + diff = diff1; +#endif + t = ((zr*zr - 1.) + zi*zi) / (s + 1); + t2 = t*t; + s = 1. - 0.5*t; + u = v = 1; + do { + s0 = s; + u *= t2; + v += 2; + s += u/v - t*u/(v+1); + } +#ifdef BYPASS_GCC_COMPARE_BUG + while(s - s0 > 1e-18 || (*diff)(&s,&s0) > 0.); +#else + while(s > s0); +#endif + r->r = s*t; + } +#endif + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/z_sin.c b/unix/f2c/libf2c/z_sin.c new file mode 100644 index 00000000..01225a94 --- /dev/null +++ b/unix/f2c/libf2c/z_sin.c @@ -0,0 +1,21 @@ +#include "f2c.h" + +#ifdef KR_headers +double sin(), cos(), sinh(), cosh(); +VOID z_sin(r, z) doublecomplex *r, *z; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +void z_sin(doublecomplex *r, doublecomplex *z) +#endif +{ + double zi = z->i, zr = z->r; + r->r = sin(zr) * cosh(zi); + r->i = cos(zr) * sinh(zi); + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf2c/z_sqrt.c b/unix/f2c/libf2c/z_sqrt.c new file mode 100644 index 00000000..35bd44c8 --- /dev/null +++ b/unix/f2c/libf2c/z_sqrt.c @@ -0,0 +1,35 @@ +#include "f2c.h" + +#ifdef KR_headers +double sqrt(), f__cabs(); +VOID z_sqrt(r, z) doublecomplex *r, *z; +#else +#undef abs +#include "math.h" +#ifdef __cplusplus +extern "C" { +#endif +extern double f__cabs(double, double); +void z_sqrt(doublecomplex *r, doublecomplex *z) +#endif +{ + double mag, zi = z->i, zr = z->r; + + if( (mag = f__cabs(zr, zi)) == 0.) + r->r = r->i = 0.; + else if(zr > 0) + { + r->r = sqrt(0.5 * (mag + zr) ); + r->i = zi / r->r / 2; + } + else + { + r->i = sqrt(0.5 * (mag - zr) ); + if(zi < 0) + r->i = - r->i; + r->r = zi / r->i / 2; + } + } +#ifdef __cplusplus +} +#endif diff --git a/unix/f2c/libf77 b/unix/f2c/libf77 new file mode 100644 index 00000000..ee82e9af --- /dev/null +++ b/unix/f2c/libf77 @@ -0,0 +1,5169 @@ +# to unbundle, sh this file (in an empty directory) +mkdir libF77 +echo libF77/uninit.c 1>&2 +sed >libF77/uninit.c <<'//GO.SYSIN DD libF77/uninit.c' 's/^-//' +-#include <stdio.h> +-#include <string.h> +-#include "arith.h" +- +-#define TYSHORT 2 +-#define TYLONG 3 +-#define TYREAL 4 +-#define TYDREAL 5 +-#define TYCOMPLEX 6 +-#define TYDCOMPLEX 7 +-#define TYINT1 11 +-#define TYQUAD 14 +-#ifndef Long +-#define Long long +-#endif +- +-#ifdef __mips +-#define RNAN 0xffc00000 +-#define DNAN0 0xfff80000 +-#define DNAN1 0 +-#endif +- +-#ifdef _PA_RISC1_1 +-#define RNAN 0xffc00000 +-#define DNAN0 0xfff80000 +-#define DNAN1 0 +-#endif +- +-#ifndef RNAN +-#define RNAN 0xff800001 +-#ifdef IEEE_MC68k +-#define DNAN0 0xfff00000 +-#define DNAN1 1 +-#else +-#define DNAN0 1 +-#define DNAN1 0xfff00000 +-#endif +-#endif /*RNAN*/ +- +-#ifdef KR_headers +-#define Void /*void*/ +-#define FA7UL (unsigned Long) 0xfa7a7a7aL +-#else +-#define Void void +-#define FA7UL 0xfa7a7a7aUL +-#endif +- +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-static void ieee0(Void); +- +-static unsigned Long rnan = RNAN, +- dnan0 = DNAN0, +- dnan1 = DNAN1; +- +-double _0 = 0.; +- +- void +-#ifdef KR_headers +-_uninit_f2c(x, type, len) void *x; int type; long len; +-#else +-_uninit_f2c(void *x, int type, long len) +-#endif +-{ +- static int first = 1; +- +- unsigned Long *lx, *lxe; +- +- if (first) { +- first = 0; +- ieee0(); +- } +- if (len == 1) +- switch(type) { +- case TYINT1: +- *(char*)x = 'Z'; +- return; +- case TYSHORT: +- *(short*)x = 0xfa7a; +- break; +- case TYLONG: +- *(unsigned Long*)x = FA7UL; +- return; +- case TYQUAD: +- case TYCOMPLEX: +- case TYDCOMPLEX: +- break; +- case TYREAL: +- *(unsigned Long*)x = rnan; +- return; +- case TYDREAL: +- lx = (unsigned Long*)x; +- lx[0] = dnan0; +- lx[1] = dnan1; +- return; +- default: +- printf("Surprise type %d in _uninit_f2c\n", type); +- } +- switch(type) { +- case TYINT1: +- memset(x, 'Z', len); +- break; +- case TYSHORT: +- *(short*)x = 0xfa7a; +- break; +- case TYQUAD: +- len *= 2; +- /* no break */ +- case TYLONG: +- lx = (unsigned Long*)x; +- lxe = lx + len; +- while(lx < lxe) +- *lx++ = FA7UL; +- break; +- case TYCOMPLEX: +- len *= 2; +- /* no break */ +- case TYREAL: +- lx = (unsigned Long*)x; +- lxe = lx + len; +- while(lx < lxe) +- *lx++ = rnan; +- break; +- case TYDCOMPLEX: +- len *= 2; +- /* no break */ +- case TYDREAL: +- lx = (unsigned Long*)x; +- for(lxe = lx + 2*len; lx < lxe; lx += 2) { +- lx[0] = dnan0; +- lx[1] = dnan1; +- } +- } +- } +-#ifdef __cplusplus +-} +-#endif +- +-#ifndef MSpc +-#ifdef MSDOS +-#define MSpc +-#else +-#ifdef _WIN32 +-#define MSpc +-#endif +-#endif +-#endif +- +-#ifdef MSpc +-#define IEEE0_done +-#include "float.h" +-#include "signal.h" +- +- static void +-ieee0(Void) +-{ +-#ifndef __alpha +- _control87(EM_DENORMAL | EM_UNDERFLOW | EM_INEXACT, MCW_EM); +-#endif +- /* With MS VC++, compiling and linking with -Zi will permit */ +- /* clicking to invoke the MS C++ debugger, which will show */ +- /* the point of error -- provided SIGFPE is SIG_DFL. */ +- signal(SIGFPE, SIG_DFL); +- } +-#endif /* MSpc */ +- +-#ifdef __mips /* must link with -lfpe */ +-#define IEEE0_done +-/* code from Eric Grosse */ +-#include <stdlib.h> +-#include <stdio.h> +-#include "/usr/include/sigfpe.h" /* full pathname for lcc -N */ +-#include "/usr/include/sys/fpu.h" +- +- static void +-#ifdef KR_headers +-ieeeuserhand(exception, val) unsigned exception[5]; int val[2]; +-#else +-ieeeuserhand(unsigned exception[5], int val[2]) +-#endif +-{ +- fflush(stdout); +- fprintf(stderr,"ieee0() aborting because of "); +- if(exception[0]==_OVERFL) fprintf(stderr,"overflow\n"); +- else if(exception[0]==_UNDERFL) fprintf(stderr,"underflow\n"); +- else if(exception[0]==_DIVZERO) fprintf(stderr,"divide by 0\n"); +- else if(exception[0]==_INVALID) fprintf(stderr,"invalid operation\n"); +- else fprintf(stderr,"\tunknown reason\n"); +- fflush(stderr); +- abort(); +-} +- +- static void +-#ifdef KR_headers +-ieeeuserhand2(j) unsigned int **j; +-#else +-ieeeuserhand2(unsigned int **j) +-#endif +-{ +- fprintf(stderr,"ieee0() aborting because of confusion\n"); +- abort(); +-} +- +- static void +-ieee0(Void) +-{ +- int i; +- for(i=1; i<=4; i++){ +- sigfpe_[i].count = 1000; +- sigfpe_[i].trace = 1; +- sigfpe_[i].repls = _USER_DETERMINED; +- } +- sigfpe_[1].repls = _ZERO; /* underflow */ +- handle_sigfpes( _ON, +- _EN_UNDERFL|_EN_OVERFL|_EN_DIVZERO|_EN_INVALID, +- ieeeuserhand,_ABORT_ON_ERROR,ieeeuserhand2); +- } +-#endif /* mips */ +- +-#ifdef __linux__ +-#define IEEE0_done +-#include "fpu_control.h" +- +-#ifdef __alpha__ +-#ifndef USE_setfpucw +-#define __setfpucw(x) __fpu_control = (x) +-#endif +-#endif +- +-#ifndef _FPU_SETCW +-#undef Can_use__setfpucw +-#define Can_use__setfpucw +-#endif +- +- static void +-ieee0(Void) +-{ +-#if (defined(__mc68000__) || defined(__mc68020__) || defined(mc68020) || defined (__mc68k__)) +-/* Reported 20010705 by Alan Bain <alanb@chiark.greenend.org.uk> */ +-/* Note that IEEE 754 IOP (illegal operation) */ +-/* = Signaling NAN (SNAN) + operation error (OPERR). */ +-#ifdef Can_use__setfpucw /* Has __setfpucw gone missing from S.u.S.E. 6.3? */ +- __setfpucw(_FPU_IEEE + _FPU_DOUBLE + _FPU_MASK_OPERR + _FPU_MASK_DZ + _FPU_MASK_SNAN+_FPU_MASK_OVFL); +-#else +- __fpu_control = _FPU_IEEE + _FPU_DOUBLE + _FPU_MASK_OPERR + _FPU_MASK_DZ + _FPU_MASK_SNAN+_FPU_MASK_OVFL; +- _FPU_SETCW(__fpu_control); +-#endif +- +-#elif (defined(__powerpc__)||defined(_ARCH_PPC)||defined(_ARCH_PWR)) /* !__mc68k__ */ +-/* Reported 20011109 by Alan Bain <alanb@chiark.greenend.org.uk> */ +- +-#ifdef Can_use__setfpucw +- +-/* The following is NOT a mistake -- the author of the fpu_control.h +-for the PPC has erroneously defined IEEE mode to turn on exceptions +-other than Inexact! Start from default then and turn on only the ones +-which we want*/ +- +- __setfpucw(_FPU_DEFAULT + _FPU_MASK_IM+_FPU_MASK_OM+_FPU_MASK_UM); +- +-#else /* PPC && !Can_use__setfpucw */ +- +- __fpu_control = _FPU_DEFAULT +_FPU_MASK_OM+_FPU_MASK_IM+_FPU_MASK_UM; +- _FPU_SETCW(__fpu_control); +- +-#endif /*Can_use__setfpucw*/ +- +-#else /* !(mc68000||powerpc) */ +- +-#ifdef _FPU_IEEE +-#ifndef _FPU_EXTENDED /* e.g., ARM processor under Linux */ +-#define _FPU_EXTENDED 0 +-#endif +-#ifndef _FPU_DOUBLE +-#define _FPU_DOUBLE 0 +-#endif +-#ifdef Can_use__setfpucw /* Has __setfpucw gone missing from S.u.S.E. 6.3? */ +- __setfpucw(_FPU_IEEE - _FPU_EXTENDED + _FPU_DOUBLE - _FPU_MASK_IM - _FPU_MASK_ZM - _FPU_MASK_OM); +-#else +- __fpu_control = _FPU_IEEE - _FPU_EXTENDED + _FPU_DOUBLE - _FPU_MASK_IM - _FPU_MASK_ZM - _FPU_MASK_OM; +- _FPU_SETCW(__fpu_control); +-#endif +- +-#else /* !_FPU_IEEE */ +- +- fprintf(stderr, "\n%s\n%s\n%s\n%s\n", +- "WARNING: _uninit_f2c in libf2c does not know how", +- "to enable trapping on this system, so f2c's -trapuv", +- "option will not detect uninitialized variables unless", +- "you can enable trapping manually."); +- fflush(stderr); +- +-#endif /* _FPU_IEEE */ +-#endif /* __mc68k__ */ +- } +-#endif /* __linux__ */ +- +-#ifdef __alpha +-#ifndef IEEE0_done +-#define IEEE0_done +-#include <machine/fpu.h> +- static void +-ieee0(Void) +-{ +- ieee_set_fp_control(IEEE_TRAP_ENABLE_INV); +- } +-#endif /*IEEE0_done*/ +-#endif /*__alpha*/ +- +-#ifdef __hpux +-#define IEEE0_done +-#define _INCLUDE_HPUX_SOURCE +-#include <math.h> +- +-#ifndef FP_X_INV +-#include <fenv.h> +-#define fpsetmask fesettrapenable +-#define FP_X_INV FE_INVALID +-#endif +- +- static void +-ieee0(Void) +-{ +- fpsetmask(FP_X_INV); +- } +-#endif /*__hpux*/ +- +-#ifdef _AIX +-#define IEEE0_done +-#include <fptrap.h> +- +- static void +-ieee0(Void) +-{ +- fp_enable(TRP_INVALID); +- fp_trap(FP_TRAP_SYNC); +- } +-#endif /*_AIX*/ +- +-#ifdef __sun +-#define IEEE0_done +-#include <ieeefp.h> +- +- static void +-ieee0(Void) +-{ +- fpsetmask(FP_X_INV); +- } +-#endif /*__sparc*/ +- +-#ifndef IEEE0_done +- static void +-ieee0(Void) {} +-#endif +//GO.SYSIN DD libF77/uninit.c +echo libF77/arithchk.c 1>&2 +sed >libF77/arithchk.c <<'//GO.SYSIN DD libF77/arithchk.c' 's/^-//' +-/**************************************************************** +-Copyright (C) 1997, 1998, 2000 Lucent Technologies +-All Rights Reserved +- +-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 name of Lucent or any of its 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 OR ANY OF ITS ENTITIES 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. +-****************************************************************/ +- +-/* Try to deduce arith.h from arithmetic properties. */ +- +-#include <stdio.h> +-#include <math.h> +-#include <errno.h> +- +-#ifdef NO_FPINIT +-#define fpinit_ASL() +-#else +-#ifndef KR_headers +-extern +-#ifdef __cplusplus +- "C" +-#endif +- void fpinit_ASL(void); +-#endif /*KR_headers*/ +-#endif /*NO_FPINIT*/ +- +- static int dalign; +- typedef struct +-Akind { +- char *name; +- int kind; +- } Akind; +- +- static Akind +-IEEE_8087 = { "IEEE_8087", 1 }, +-IEEE_MC68k = { "IEEE_MC68k", 2 }, +-IBM = { "IBM", 3 }, +-VAX = { "VAX", 4 }, +-CRAY = { "CRAY", 5}; +- +- static double t_nan; +- +- static Akind * +-Lcheck() +-{ +- union { +- double d; +- long L[2]; +- } u; +- struct { +- double d; +- long L; +- } x[2]; +- +- if (sizeof(x) > 2*(sizeof(double) + sizeof(long))) +- dalign = 1; +- u.L[0] = u.L[1] = 0; +- u.d = 1e13; +- if (u.L[0] == 1117925532 && u.L[1] == -448790528) +- return &IEEE_MC68k; +- if (u.L[1] == 1117925532 && u.L[0] == -448790528) +- return &IEEE_8087; +- if (u.L[0] == -2065213935 && u.L[1] == 10752) +- return &VAX; +- if (u.L[0] == 1267827943 && u.L[1] == 704643072) +- return &IBM; +- return 0; +- } +- +- static Akind * +-icheck() +-{ +- union { +- double d; +- int L[2]; +- } u; +- struct { +- double d; +- int L; +- } x[2]; +- +- if (sizeof(x) > 2*(sizeof(double) + sizeof(int))) +- dalign = 1; +- u.L[0] = u.L[1] = 0; +- u.d = 1e13; +- if (u.L[0] == 1117925532 && u.L[1] == -448790528) +- return &IEEE_MC68k; +- if (u.L[1] == 1117925532 && u.L[0] == -448790528) +- return &IEEE_8087; +- if (u.L[0] == -2065213935 && u.L[1] == 10752) +- return &VAX; +- if (u.L[0] == 1267827943 && u.L[1] == 704643072) +- return &IBM; +- return 0; +- } +- +-char *emptyfmt = ""; /* avoid possible warning message with printf("") */ +- +- static Akind * +-ccheck() +-{ +- union { +- double d; +- long L; +- } u; +- long Cray1; +- +- /* Cray1 = 4617762693716115456 -- without overflow on non-Crays */ +- Cray1 = printf(emptyfmt) < 0 ? 0 : 4617762; +- if (printf(emptyfmt, Cray1) >= 0) +- Cray1 = 1000000*Cray1 + 693716; +- if (printf(emptyfmt, Cray1) >= 0) +- Cray1 = 1000000*Cray1 + 115456; +- u.d = 1e13; +- if (u.L == Cray1) +- return &CRAY; +- return 0; +- } +- +- static int +-fzcheck() +-{ +- double a, b; +- int i; +- +- a = 1.; +- b = .1; +- for(i = 155;; b *= b, i >>= 1) { +- if (i & 1) { +- a *= b; +- if (i == 1) +- break; +- } +- } +- b = a * a; +- return b == 0.; +- } +- +- static int +-need_nancheck() +-{ +- double t; +- +- errno = 0; +- t = log(t_nan); +- if (errno == 0) +- return 1; +- errno = 0; +- t = sqrt(t_nan); +- return errno == 0; +- } +- +-main() +-{ +- FILE *f; +- Akind *a = 0; +- int Ldef = 0; +- +- fpinit_ASL(); +-#ifdef WRITE_ARITH_H /* for Symantec's buggy "make" */ +- f = fopen("arith.h", "w"); +- if (!f) { +- printf("Cannot open arith.h\n"); +- return 1; +- } +-#else +- f = stdout; +-#endif +- +- if (sizeof(double) == 2*sizeof(long)) +- a = Lcheck(); +- else if (sizeof(double) == 2*sizeof(int)) { +- Ldef = 1; +- a = icheck(); +- } +- else if (sizeof(double) == sizeof(long)) +- a = ccheck(); +- if (a) { +- fprintf(f, "#define %s\n#define Arith_Kind_ASL %d\n", +- a->name, a->kind); +- if (Ldef) +- fprintf(f, "#define Long int\n#define Intcast (int)(long)\n"); +- if (dalign) +- fprintf(f, "#define Double_Align\n"); +- if (sizeof(char*) == 8) +- fprintf(f, "#define X64_bit_pointers\n"); +-#ifndef NO_LONG_LONG +- if (sizeof(long long) < 8) +-#endif +- fprintf(f, "#define NO_LONG_LONG\n"); +- if (a->kind <= 2) { +- if (fzcheck()) +- fprintf(f, "#define Sudden_Underflow\n"); +- t_nan = -a->kind; +- if (need_nancheck()) +- fprintf(f, "#define NANCHECK\n"); +- } +- return 0; +- } +- fprintf(f, "/* Unknown arithmetic */\n"); +- return 1; +- } +- +-#ifdef __sun +-#ifdef __i386 +-/* kludge for Intel Solaris */ +-void fpsetprec(int x) { } +-#endif +-#endif +//GO.SYSIN DD libF77/arithchk.c +echo libF77/f77vers.c 1>&2 +sed >libF77/f77vers.c <<'//GO.SYSIN DD libF77/f77vers.c' 's/^-//' +- char +-_libf77_version_f2c[] = "\n@(#) LIBF77 VERSION (f2c) 20021004\n"; +- +-/* +-2.00 11 June 1980. File version.c added to library. +-2.01 31 May 1988. s_paus() flushes stderr; names of hl_* fixed +- [ d]erf[c ] added +- 8 Aug. 1989: #ifdefs for f2c -i2 added to s_cat.c +- 29 Nov. 1989: s_cmp returns long (for f2c) +- 30 Nov. 1989: arg types from f2c.h +- 12 Dec. 1989: s_rnge allows long names +- 19 Dec. 1989: getenv_ allows unsorted environment +- 28 Mar. 1990: add exit(0) to end of main() +- 2 Oct. 1990: test signal(...) == SIG_IGN rather than & 01 in main +- 17 Oct. 1990: abort() calls changed to sig_die(...,1) +- 22 Oct. 1990: separate sig_die from main +- 25 Apr. 1991: minor, theoretically invisible tweaks to s_cat, sig_die +- 31 May 1991: make system_ return status +- 18 Dec. 1991: change long to ftnlen (for -i2) many places +- 28 Feb. 1992: repair z_sqrt.c (scribbled on input, gave wrong answer) +- 18 July 1992: for n < 0, repair handling of 0**n in pow_[dr]i.c +- and m**n in pow_hh.c and pow_ii.c; +- catch SIGTRAP in main() for error msg before abort +- 23 July 1992: switch to ANSI prototypes unless KR_headers is #defined +- 23 Oct. 1992: fix botch in signal_.c (erroneous deref of 2nd arg); +- change Cabs to f__cabs. +- 12 March 1993: various tweaks for C++ +- 2 June 1994: adjust so abnormal terminations invoke f_exit just once +- 16 Sept. 1994: s_cmp: treat characters as unsigned in comparisons. +- 19 Sept. 1994: s_paus: flush after end of PAUSE; add -DMSDOS +- 12 Jan. 1995: pow_[dhiqrz][hiq]: adjust x**i to work on machines +- that sign-extend right shifts when i is the most +- negative integer. +- 26 Jan. 1995: adjust s_cat.c, s_copy.c to permit the left-hand side +- of character assignments to appear on the right-hand +- side (unless compiled with -DNO_OVERWRITE). +- 27 Jan. 1995: minor tweak to s_copy.c: copy forward whenever +- possible (for better cache behavior). +- 30 May 1995: added subroutine exit(rc) integer rc. Version not changed. +- 29 Aug. 1995: add F77_aloc.c; use it in s_cat.c and system_.c. +- 6 Sept. 1995: fix return type of system_ under -DKR_headers. +- 19 Dec. 1995: s_cat.c: fix bug when 2nd or later arg overlaps lhs. +- 19 Mar. 1996: s_cat.c: supply missing break after overlap detection. +- 13 May 1996: add [lq]bitbits.c and [lq]bitshft.c (f90 bit intrinsics). +- 19 June 1996: add casts to unsigned in [lq]bitshft.c. +- 26 Feb. 1997: 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.) +- 4 April 1997: [cz]_div.c: tweaks invisible on most systems (that may +- affect systems using gratuitous extra precision). +- 19 Sept. 1997: [de]time_.c (Unix systems only): change return +- type to double. +- 2 May 1999: getenv_.c: omit environ in favor of getenv(). +- c_cos.c, c_exp.c, c_sin.c, d_cnjg.c, r_cnjg.c, +- z_cos.c, z_exp.c, z_log.c, z_sin.c: cope fully with +- overlapping arguments caused by equivalence. +- 3 May 1999: "invisible" tweaks to omit compiler warnings in +- abort_.c, ef1asc_.c, s_rnge.c, s_stop.c. +- +- 7 Sept. 1999: [cz]_div.c: arrange for compilation under +- -DIEEE_COMPLEX_DIVIDE to make these routines +- avoid calling sig_die when the denominator +- vanishes; instead, they return pairs of NaNs +- or Infinities, depending whether the numerator +- also vanishes or not. VERSION not changed. +- 15 Nov. 1999: s_rnge.c: add casts for the case of +- sizeof(ftnint) == sizeof(int) < sizeof(long). +- 10 March 2000: z_log.c: improve accuracy of Real(log(z)) for, e.g., +- z near (+-1,eps) with |eps| small. For the old +- evaluation, compile with -DPre20000310 . +- 20 April 2000: s_cat.c: tweak argument types to accord with +- calls by f2c when ftnint and ftnlen are of +- different sizes (different numbers of bits). +- 4 July 2000: adjustments to permit compilation by C++ compilers; +- VERSION string remains unchanged. +- 29 Sept. 2000: 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. +- 23 June 2001: add uninit.c; [fi]77vers.c: make version strings +- visible as extern char _lib[fi]77_version_f2c[]. +- 5 July 2001: modify uninit.c for __mc68k__ under Linux. +- 16 Nov. 2001: uninit.c: Linux Power PC logic supplied by Alan Bain. +- 18 Jan. 2002: fix glitches in qbit_bits(): wrong return type, +- missing ~ on y in return value. +- 14 March 2002: 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 new logic. +- 4 Oct. 2002: uninit.c: on IRIX systems, omit use of shell variables. +-*/ +//GO.SYSIN DD libF77/f77vers.c +echo libF77/libF77.xsum 1>&2 +sed >libF77/libF77.xsum <<'//GO.SYSIN DD libF77/libF77.xsum' 's/^-//' +-F77_aloc.c f74c1f61 678 +-Notice 76f23b4 1212 +-README fbd01e7d 7210 +-abort_.c 1ef378f2 298 +-arithchk.c efc0d389 4669 +-c_abs.c fec22c59 272 +-c_cos.c 18fc0ea3 354 +-c_div.c f5424912 930 +-c_exp.c 1b85b1fc 349 +-c_log.c 28cdfed 384 +-c_sin.c 1ccaedc8 350 +-c_sqrt.c f1ee88d5 605 +-cabs.c f3d3b5f2 494 +-d_abs.c e58094ef 218 +-d_acos.c e5ecf93d 245 +-d_asin.c e12ceeff 245 +-d_atan.c 53034db 245 +-d_atn2.c ff8a1a78 271 +-d_cnjg.c 1c27c728 255 +-d_cos.c c0eb625 241 +-d_cosh.c 11dc4adb 245 +-d_dim.c e1ccb774 232 +-d_exp.c 1879c41c 241 +-d_imag.c fe9c703e 201 +-d_int.c f5de3566 269 +-d_lg10.c 1a1d7b77 291 +-d_log.c 1b368adf 241 +-d_mod.c f540cf24 688 +-d_nint.c ff913b40 281 +-d_prod.c ad4856b 207 +-d_sign.c 9562fc5 266 +-d_sin.c 6e3f542 241 +-d_sinh.c 18b22950 245 +-d_sqrt.c 17e1db09 245 +-d_tan.c ec93ebdb 241 +-d_tanh.c 1c55d15b 245 +-derf_.c f85e74a3 239 +-derfc_.c e96b7667 253 +-dtime_.c c982be4 972 +-ef1asc_.c e0576e63 521 +-ef1cmc_.c ea5ad9e8 427 +-erf_.c e82f7790 270 +-erfc_.c ba65441 275 +-etime_.c 19d1fdad 839 +-exit_.c ff4baa3a 543 +-f2ch.add ef66bf17 6060 +-f77vers.c 13362f51 4740 +-getarg_.c f182a268 562 +-getenv_.c ff3b797c 1217 +-h_abs.c e4443109 218 +-h_dim.c c6e48bc 230 +-h_dnnt.c f6bb90e 294 +-h_indx.c ef8461eb 442 +-h_len.c e8c3633 205 +-h_mod.c 7355bd0 207 +-h_nint.c f0da3396 281 +-h_sign.c f1370ffd 266 +-hl_ge.c ed792501 346 +-hl_gt.c feeacbd9 345 +-hl_le.c f6fb5d6e 346 +-hl_lt.c 18501419 345 +-i_abs.c 12ab51ab 214 +-i_dim.c f2a56785 225 +-i_dnnt.c 11748482 291 +-i_indx.c fb59026f 430 +-i_len.c 17d17252 203 +-i_mod.c bef73ae 211 +-i_nint.c e494b804 278 +-i_sign.c fa015b08 260 +-iargc_.c 49abda3 196 +-l_ge.c f4710e74 334 +-l_gt.c e8db94a7 333 +-l_le.c c9c0a99 334 +-l_lt.c 767e79f 333 +-lbitbits.c 33fe981 1097 +-lbitshft.c e81981d2 258 +-main.c dc8ce96 2219 +-makefile f4048935 4364 +-pow_ci.c fa934cec 412 +-pow_dd.c f004559b 276 +-pow_di.c a4db539 448 +-pow_hh.c d1a45a9 489 +-pow_ii.c 1fcf2742 488 +-pow_qq.c e6a32de6 516 +-pow_ri.c e7d9fc2a 436 +-pow_zi.c 1b894af7 851 +-pow_zz.c f81a06b5 549 +-qbitbits.c fdb9910e 1151 +-qbitshft.c 873054d 258 +-r_abs.c f471383c 206 +-r_acos.c 1a6aca63 233 +-r_asin.c e8555587 233 +-r_atan.c eac25444 233 +-r_atn2.c f611bea 253 +-r_cnjg.c a8d7805 235 +-r_cos.c fdef1ece 229 +-r_cosh.c f05d1ae 233 +-r_dim.c ee23e1a8 214 +-r_exp.c 1da16cd7 229 +-r_imag.c 166ad0f3 189 +-r_int.c fc80b9a8 257 +-r_lg10.c e876cfab 279 +-r_log.c 2062254 229 +-r_mod.c 187363fc 678 +-r_nint.c 6edcbb2 269 +-r_sign.c 1ae32441 248 +-r_sin.c c3d968 229 +-r_sinh.c 1090c850 233 +-r_sqrt.c ffbb0625 233 +-r_tan.c fe85179d 229 +-r_tanh.c 10ffcc5b 233 +-s_cat.c 3070507 1452 +-s_cmp.c e69e8b60 722 +-s_copy.c 1e258852 1024 +-s_paus.c 245d604 1596 +-s_rnge.c fd20c6b4 753 +-s_stop.c ffa80b24 762 +-sig_die.c fbcad8d6 701 +-signal1.h0 1d43ee57 842 +-signal_.c f3ef9cfc 299 +-system_.c eae6254c 646 +-uninit.c 183c9847 7170 +-z_abs.c 1fa0640d 268 +-z_cos.c facccd9b 363 +-z_div.c 1abdf45a 907 +-z_exp.c 1a8506e8 357 +-z_log.c 6bf3b22 2729 +-z_sin.c 1aa35b59 359 +-z_sqrt.c 1864d867 581 +//GO.SYSIN DD libF77/libF77.xsum +echo libF77/main.c 1>&2 +sed >libF77/main.c <<'//GO.SYSIN DD libF77/main.c' 's/^-//' +-/* STARTUP PROCEDURE FOR UNIX FORTRAN PROGRAMS */ +- +-#include "stdio.h" +-#include "signal1.h" +- +-#ifndef SIGIOT +-#ifdef SIGABRT +-#define SIGIOT SIGABRT +-#endif +-#endif +- +-#ifndef KR_headers +-#undef VOID +-#include "stdlib.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-#endif +- +-#ifndef VOID +-#define VOID void +-#endif +- +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef NO__STDC +-#define ONEXIT onexit +-extern VOID f_exit(); +-#else +-#ifndef KR_headers +-extern void f_exit(void); +-#ifndef NO_ONEXIT +-#define ONEXIT atexit +-extern int atexit(void (*)(void)); +-#endif +-#else +-#ifndef NO_ONEXIT +-#define ONEXIT onexit +-extern VOID f_exit(); +-#endif +-#endif +-#endif +- +-#ifdef KR_headers +-extern VOID f_init(), sig_die(); +-extern int MAIN__(); +-#define Int /* int */ +-#else +-extern void f_init(void), sig_die(char*, int); +-extern int MAIN__(void); +-#define Int int +-#endif +- +-static VOID sigfdie(Sigarg) +-{ +-Use_Sigarg; +-sig_die("Floating Exception", 1); +-} +- +- +-static VOID sigidie(Sigarg) +-{ +-Use_Sigarg; +-sig_die("IOT Trap", 1); +-} +- +-#ifdef SIGQUIT +-static VOID sigqdie(Sigarg) +-{ +-Use_Sigarg; +-sig_die("Quit signal", 1); +-} +-#endif +- +- +-static VOID sigindie(Sigarg) +-{ +-Use_Sigarg; +-sig_die("Interrupt", 0); +-} +- +-static VOID sigtdie(Sigarg) +-{ +-Use_Sigarg; +-sig_die("Killed", 0); +-} +- +-#ifdef SIGTRAP +-static VOID sigtrdie(Sigarg) +-{ +-Use_Sigarg; +-sig_die("Trace trap", 1); +-} +-#endif +- +- +-int xargc; +-char **xargv; +- +-#ifdef __cplusplus +- } +-#endif +- +-#ifdef KR_headers +-main(argc, argv) int argc; char **argv; +-#else +-main(int argc, char **argv) +-#endif +-{ +-xargc = argc; +-xargv = argv; +-signal1(SIGFPE, sigfdie); /* ignore underflow, enable overflow */ +-#ifdef SIGIOT +-signal1(SIGIOT, sigidie); +-#endif +-#ifdef SIGTRAP +-signal1(SIGTRAP, sigtrdie); +-#endif +-#ifdef SIGQUIT +-if(signal1(SIGQUIT,sigqdie) == SIG_IGN) +- signal1(SIGQUIT, SIG_IGN); +-#endif +-if(signal1(SIGINT, sigindie) == SIG_IGN) +- signal1(SIGINT, SIG_IGN); +-signal1(SIGTERM,sigtdie); +- +-#ifdef pdp11 +- ldfps(01200); /* detect overflow as an exception */ +-#endif +- +-f_init(); +-#ifndef NO_ONEXIT +-ONEXIT(f_exit); +-#endif +-MAIN__(); +-#ifdef NO_ONEXIT +-f_exit(); +-#endif +-exit(0); /* exit(0) rather than return(0) to bypass Cray bug */ +-return 0; /* For compilers that complain of missing return values; */ +- /* others will complain that this is unreachable code. */ +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/main.c +echo libF77/makefile 1>&2 +sed >libF77/makefile <<'//GO.SYSIN DD libF77/makefile' 's/^-//' +-.SUFFIXES: .c .o +-CC = cc +-SHELL = /bin/sh +-CFLAGS = -O +- +-# If your system lacks onexit() and you are not using an +-# ANSI C compiler, then you should add -DNO_ONEXIT to CFLAGS, +-# e.g., by changing the above "CFLAGS =" line to +-# CFLAGS = -O -DNO_ONEXIT +- +-# On at least some Sun systems, it is more appropriate to change the +-# "CFLAGS =" line to +-# CFLAGS = -O -Donexit=on_exit +- +-# compile, then strip unnecessary symbols +-.c.o: +- $(CC) -c -DSkip_f2c_Undefs $(CFLAGS) $*.c +- ld -r -x -o $*.xxx $*.o +- mv $*.xxx $*.o +-## Under Solaris (and other systems that do not understand ld -x), +-## omit -x in the ld line above. +-## If your system does not have the ld command, comment out +-## or remove both the ld and mv lines above. +- +-MISC = F77_aloc.o main.o s_rnge.o abort_.o f77vers.o getarg_.o iargc_.o \ +- getenv_.o signal_.o s_stop.o s_paus.o system_.o cabs.o\ +- derf_.o derfc_.o erf_.o erfc_.o sig_die.o exit_.o uninit.o +-POW = pow_ci.o pow_dd.o pow_di.o pow_hh.o pow_ii.o pow_ri.o pow_zi.o pow_zz.o +-CX = c_abs.o c_cos.o c_div.o c_exp.o c_log.o c_sin.o c_sqrt.o +-DCX = z_abs.o z_cos.o z_div.o z_exp.o z_log.o z_sin.o z_sqrt.o +-REAL = r_abs.o r_acos.o r_asin.o r_atan.o r_atn2.o r_cnjg.o r_cos.o\ +- r_cosh.o r_dim.o r_exp.o r_imag.o r_int.o\ +- r_lg10.o r_log.o r_mod.o r_nint.o r_sign.o\ +- r_sin.o r_sinh.o r_sqrt.o r_tan.o r_tanh.o +-DBL = d_abs.o d_acos.o d_asin.o d_atan.o d_atn2.o\ +- d_cnjg.o d_cos.o d_cosh.o d_dim.o d_exp.o\ +- d_imag.o d_int.o d_lg10.o d_log.o d_mod.o\ +- d_nint.o d_prod.o d_sign.o d_sin.o d_sinh.o\ +- d_sqrt.o d_tan.o d_tanh.o +-INT = i_abs.o i_dim.o i_dnnt.o i_indx.o i_len.o i_mod.o i_nint.o i_sign.o +-HALF = h_abs.o h_dim.o h_dnnt.o h_indx.o h_len.o h_mod.o h_nint.o h_sign.o +-CMP = l_ge.o l_gt.o l_le.o l_lt.o hl_ge.o hl_gt.o hl_le.o hl_lt.o +-EFL = ef1asc_.o ef1cmc_.o +-CHAR = F77_aloc.o s_cat.o s_cmp.o s_copy.o +-F90BIT = lbitbits.o lbitshft.o +-QINT = pow_qq.o qbitbits.o qbitshft.o +-TIME = dtime_.o etime_.o +- +-all: signal1.h libF77.a +- +-# You may need to adjust signal1.h suitably for your system... +-signal1.h: signal1.h0 +- cp signal1.h0 signal1.h +- +-# If you get an error compiling dtime_.c or etime_.c, try adding +-# -DUSE_CLOCK to the CFLAGS assignment above; if that does not work, +-# omit $(TIME) from the dependency list for libF77.a below. +- +-# For INTEGER*8 support (which requires system-dependent adjustments to +-# f2c.h), add $(QINT) to the libf2c.a dependency list below... +- +-libF77.a : $(MISC) $(POW) $(CX) $(DCX) $(REAL) $(DBL) $(INT) \ +- $(HALF) $(CMP) $(EFL) $(CHAR) $(F90BIT) $(TIME) +- ar r libF77.a $? +- ranlib libF77.a || true +- +-### If your system lacks ranlib, you don't need it; see README. +- +-# f77vers.c was "Version.c"; renamed on 20010623 to accord with libf2c.zip. +- +-f77vers.o: f77vers.c +- $(CC) -c f77vers.c +- +-uninit.o: arith.h +- +-arith.h: arithchk.c +- $(CC) $(CFLAGS) -DNO_FPINIT arithchk.c -lm ||\ +- $(CC) -DNO_LONG_LONG $(CFLAGS) -DNO_FPINIT arithchk.c -lm +- ./a.out >arith.h +- rm -f a.out arithchk.o +- +-# To compile with C++, first "make f2c.h" +-f2c.h: f2ch.add +- cat /usr/include/f2c.h f2ch.add >f2c.h +- +-install: libF77.a +- mv libF77.a $(LIBDIR)/libF77.a +- ranlib $(LIBDIR)/libF77.a || true +- +-clean: +- rm -f libF77.a *.o arith.h +- +-check: +- xsum F77_aloc.c Notice README abort_.c arithchk.c c_abs.c \ +- c_cos.c c_div.c c_exp.c c_log.c c_sin.c c_sqrt.c cabs.c \ +- d_abs.c d_acos.c \ +- d_asin.c d_atan.c d_atn2.c d_cnjg.c d_cos.c d_cosh.c d_dim.c \ +- d_exp.c d_imag.c d_int.c d_lg10.c d_log.c d_mod.c d_nint.c \ +- d_prod.c d_sign.c d_sin.c d_sinh.c d_sqrt.c d_tan.c d_tanh.c \ +- derf_.c derfc_.c dtime_.c ef1asc_.c ef1cmc_.c erf_.c erfc_.c \ +- etime_.c exit_.c f2ch.add f77vers.c \ +- getarg_.c getenv_.c h_abs.c h_dim.c h_dnnt.c h_indx.c h_len.c \ +- h_mod.c h_nint.c h_sign.c hl_ge.c hl_gt.c hl_le.c hl_lt.c \ +- i_abs.c i_dim.c i_dnnt.c i_indx.c i_len.c i_mod.c i_nint.c \ +- i_sign.c iargc_.c l_ge.c l_gt.c l_le.c l_lt.c lbitbits.c lbitshft.c \ +- main.c makefile pow_ci.c pow_dd.c pow_di.c pow_hh.c pow_ii.c \ +- pow_qq.c pow_ri.c pow_zi.c pow_zz.c qbitbits.c qbitshft.c \ +- r_abs.c r_acos.c r_asin.c r_atan.c r_atn2.c \ +- r_cnjg.c r_cos.c r_cosh.c r_dim.c r_exp.c r_imag.c r_int.c r_lg10.c \ +- r_log.c r_mod.c r_nint.c r_sign.c r_sin.c r_sinh.c r_sqrt.c \ +- r_tan.c r_tanh.c s_cat.c s_cmp.c s_copy.c \ +- s_paus.c s_rnge.c s_stop.c sig_die.c signal1.h0 signal_.c system_.c \ +- uninit.c z_abs.c z_cos.c z_div.c z_exp.c z_log.c z_sin.c z_sqrt.c >zap +- cmp zap libF77.xsum && rm zap || diff libF77.xsum zap +//GO.SYSIN DD libF77/makefile +echo libF77/pow_ci.c 1>&2 +sed >libF77/pow_ci.c <<'//GO.SYSIN DD libF77/pow_ci.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-VOID pow_ci(p, a, b) /* p = a**b */ +- complex *p, *a; integer *b; +-#else +-extern void pow_zi(doublecomplex*, doublecomplex*, integer*); +-void pow_ci(complex *p, complex *a, integer *b) /* p = a**b */ +-#endif +-{ +-doublecomplex p1, a1; +- +-a1.r = a->r; +-a1.i = a->i; +- +-pow_zi(&p1, &a1, b); +- +-p->r = p1.r; +-p->i = p1.i; +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/pow_ci.c +echo libF77/pow_dd.c 1>&2 +sed >libF77/pow_dd.c <<'//GO.SYSIN DD libF77/pow_dd.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double pow(); +-double pow_dd(ap, bp) doublereal *ap, *bp; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-double pow_dd(doublereal *ap, doublereal *bp) +-#endif +-{ +-return(pow(*ap, *bp) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/pow_dd.c +echo libF77/pow_di.c 1>&2 +sed >libF77/pow_di.c <<'//GO.SYSIN DD libF77/pow_di.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-double pow_di(ap, bp) doublereal *ap; integer *bp; +-#else +-double pow_di(doublereal *ap, integer *bp) +-#endif +-{ +-double pow, x; +-integer n; +-unsigned long u; +- +-pow = 1; +-x = *ap; +-n = *bp; +- +-if(n != 0) +- { +- if(n < 0) +- { +- n = -n; +- x = 1/x; +- } +- for(u = n; ; ) +- { +- if(u & 01) +- pow *= x; +- if(u >>= 1) +- x *= x; +- else +- break; +- } +- } +-return(pow); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/pow_di.c +echo libF77/pow_hh.c 1>&2 +sed >libF77/pow_hh.c <<'//GO.SYSIN DD libF77/pow_hh.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-shortint pow_hh(ap, bp) shortint *ap, *bp; +-#else +-shortint pow_hh(shortint *ap, shortint *bp) +-#endif +-{ +- shortint pow, x, n; +- unsigned u; +- +- x = *ap; +- n = *bp; +- +- if (n <= 0) { +- if (n == 0 || x == 1) +- return 1; +- if (x != -1) +- return x == 0 ? 1/x : 0; +- n = -n; +- } +- u = n; +- for(pow = 1; ; ) +- { +- if(u & 01) +- pow *= x; +- if(u >>= 1) +- x *= x; +- else +- break; +- } +- return(pow); +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/pow_hh.c +echo libF77/pow_ii.c 1>&2 +sed >libF77/pow_ii.c <<'//GO.SYSIN DD libF77/pow_ii.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-integer pow_ii(ap, bp) integer *ap, *bp; +-#else +-integer pow_ii(integer *ap, integer *bp) +-#endif +-{ +- integer pow, x, n; +- unsigned long u; +- +- x = *ap; +- n = *bp; +- +- if (n <= 0) { +- if (n == 0 || x == 1) +- return 1; +- if (x != -1) +- return x == 0 ? 1/x : 0; +- n = -n; +- } +- u = n; +- for(pow = 1; ; ) +- { +- if(u & 01) +- pow *= x; +- if(u >>= 1) +- x *= x; +- else +- break; +- } +- return(pow); +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/pow_ii.c +echo libF77/pow_qq.c 1>&2 +sed >libF77/pow_qq.c <<'//GO.SYSIN DD libF77/pow_qq.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-longint pow_qq(ap, bp) longint *ap, *bp; +-#else +-longint pow_qq(longint *ap, longint *bp) +-#endif +-{ +- longint pow, x, n; +- unsigned long long u; /* system-dependent */ +- +- x = *ap; +- n = *bp; +- +- if (n <= 0) { +- if (n == 0 || x == 1) +- return 1; +- if (x != -1) +- return x == 0 ? 1/x : 0; +- n = -n; +- } +- u = n; +- for(pow = 1; ; ) +- { +- if(u & 01) +- pow *= x; +- if(u >>= 1) +- x *= x; +- else +- break; +- } +- return(pow); +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/pow_qq.c +echo libF77/pow_ri.c 1>&2 +sed >libF77/pow_ri.c <<'//GO.SYSIN DD libF77/pow_ri.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-double pow_ri(ap, bp) real *ap; integer *bp; +-#else +-double pow_ri(real *ap, integer *bp) +-#endif +-{ +-double pow, x; +-integer n; +-unsigned long u; +- +-pow = 1; +-x = *ap; +-n = *bp; +- +-if(n != 0) +- { +- if(n < 0) +- { +- n = -n; +- x = 1/x; +- } +- for(u = n; ; ) +- { +- if(u & 01) +- pow *= x; +- if(u >>= 1) +- x *= x; +- else +- break; +- } +- } +-return(pow); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/pow_ri.c +echo libF77/pow_zi.c 1>&2 +sed >libF77/pow_zi.c <<'//GO.SYSIN DD libF77/pow_zi.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-VOID pow_zi(p, a, b) /* p = a**b */ +- doublecomplex *p, *a; integer *b; +-#else +-extern void z_div(doublecomplex*, doublecomplex*, doublecomplex*); +-void pow_zi(doublecomplex *p, doublecomplex *a, integer *b) /* p = a**b */ +-#endif +-{ +- integer n; +- unsigned long u; +- double t; +- doublecomplex q, x; +- static doublecomplex one = {1.0, 0.0}; +- +- n = *b; +- q.r = 1; +- q.i = 0; +- +- if(n == 0) +- goto done; +- if(n < 0) +- { +- n = -n; +- z_div(&x, &one, a); +- } +- else +- { +- x.r = a->r; +- x.i = a->i; +- } +- +- for(u = n; ; ) +- { +- if(u & 01) +- { +- t = q.r * x.r - q.i * x.i; +- q.i = q.r * x.i + q.i * x.r; +- q.r = t; +- } +- if(u >>= 1) +- { +- t = x.r * x.r - x.i * x.i; +- x.i = 2 * x.r * x.i; +- x.r = t; +- } +- else +- break; +- } +- done: +- p->i = q.i; +- p->r = q.r; +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/pow_zi.c +echo libF77/pow_zz.c 1>&2 +sed >libF77/pow_zz.c <<'//GO.SYSIN DD libF77/pow_zz.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double log(), exp(), cos(), sin(), atan2(), f__cabs(); +-VOID pow_zz(r,a,b) doublecomplex *r, *a, *b; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-extern double f__cabs(double,double); +-void pow_zz(doublecomplex *r, doublecomplex *a, doublecomplex *b) +-#endif +-{ +-double logr, logi, x, y; +- +-logr = log( f__cabs(a->r, a->i) ); +-logi = atan2(a->i, a->r); +- +-x = exp( logr * b->r - logi * b->i ); +-y = logr * b->i + logi * b->r; +- +-r->r = x * cos(y); +-r->i = x * sin(y); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/pow_zz.c +echo libF77/qbitbits.c 1>&2 +sed >libF77/qbitbits.c <<'//GO.SYSIN DD libF77/qbitbits.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifndef LONGBITS +-#define LONGBITS 32 +-#endif +- +-#ifndef LONG8BITS +-#define LONG8BITS (2*LONGBITS) +-#endif +- +- longint +-#ifdef KR_headers +-qbit_bits(a, b, len) longint a; integer b, len; +-#else +-qbit_bits(longint a, integer b, integer len) +-#endif +-{ +- /* Assume 2's complement arithmetic */ +- +- ulongint x, y; +- +- x = (ulongint) a; +- y = (ulongint)-1L; +- x >>= b; +- y <<= len; +- return (longint)(x & ~y); +- } +- +- longint +-#ifdef KR_headers +-qbit_cshift(a, b, len) longint a; integer b, len; +-#else +-qbit_cshift(longint a, integer b, integer len) +-#endif +-{ +- ulongint x, y, z; +- +- x = (ulongint)a; +- if (len <= 0) { +- if (len == 0) +- return 0; +- goto full_len; +- } +- if (len >= LONG8BITS) { +- full_len: +- if (b >= 0) { +- b %= LONG8BITS; +- return (longint)(x << b | x >> LONG8BITS - b ); +- } +- b = -b; +- b %= LONG8BITS; +- return (longint)(x << LONG8BITS - b | x >> b); +- } +- y = z = (unsigned long)-1; +- y <<= len; +- z &= ~y; +- y &= x; +- x &= z; +- if (b >= 0) { +- b %= len; +- return (longint)(y | z & (x << b | x >> len - b)); +- } +- b = -b; +- b %= len; +- return (longint)(y | z & (x >> b | x << len - b)); +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/qbitbits.c +echo libF77/qbitshft.c 1>&2 +sed >libF77/qbitshft.c <<'//GO.SYSIN DD libF77/qbitshft.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +- longint +-#ifdef KR_headers +-qbit_shift(a, b) longint a; integer b; +-#else +-qbit_shift(longint a, integer b) +-#endif +-{ +- return b >= 0 ? a << b : (longint)((ulongint)a >> -b); +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/qbitshft.c +echo libF77/r_abs.c 1>&2 +sed >libF77/r_abs.c <<'//GO.SYSIN DD libF77/r_abs.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-double r_abs(x) real *x; +-#else +-double r_abs(real *x) +-#endif +-{ +-if(*x >= 0) +- return(*x); +-return(- *x); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/r_abs.c +echo libF77/r_acos.c 1>&2 +sed >libF77/r_acos.c <<'//GO.SYSIN DD libF77/r_acos.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double acos(); +-double r_acos(x) real *x; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-double r_acos(real *x) +-#endif +-{ +-return( acos(*x) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/r_acos.c +echo libF77/r_asin.c 1>&2 +sed >libF77/r_asin.c <<'//GO.SYSIN DD libF77/r_asin.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double asin(); +-double r_asin(x) real *x; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-double r_asin(real *x) +-#endif +-{ +-return( asin(*x) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/r_asin.c +echo libF77/r_atan.c 1>&2 +sed >libF77/r_atan.c <<'//GO.SYSIN DD libF77/r_atan.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double atan(); +-double r_atan(x) real *x; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-double r_atan(real *x) +-#endif +-{ +-return( atan(*x) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/r_atan.c +echo libF77/r_atn2.c 1>&2 +sed >libF77/r_atn2.c <<'//GO.SYSIN DD libF77/r_atn2.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double atan2(); +-double r_atn2(x,y) real *x, *y; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-double r_atn2(real *x, real *y) +-#endif +-{ +-return( atan2(*x,*y) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/r_atn2.c +echo libF77/z_sqrt.c 1>&2 +sed >libF77/z_sqrt.c <<'//GO.SYSIN DD libF77/z_sqrt.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double sqrt(), f__cabs(); +-VOID z_sqrt(r, z) doublecomplex *r, *z; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-extern double f__cabs(double, double); +-void z_sqrt(doublecomplex *r, doublecomplex *z) +-#endif +-{ +- double mag, zi = z->i, zr = z->r; +- +- if( (mag = f__cabs(zr, zi)) == 0.) +- r->r = r->i = 0.; +- else if(zr > 0) +- { +- r->r = sqrt(0.5 * (mag + zr) ); +- r->i = zi / r->r / 2; +- } +- else +- { +- r->i = sqrt(0.5 * (mag - zr) ); +- if(zi < 0) +- r->i = - r->i; +- r->r = zi / r->i / 2; +- } +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/z_sqrt.c +echo libF77/r_cnjg.c 1>&2 +sed >libF77/r_cnjg.c <<'//GO.SYSIN DD libF77/r_cnjg.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-VOID r_cnjg(r, z) complex *r, *z; +-#else +-VOID r_cnjg(complex *r, complex *z) +-#endif +-{ +- real zi = z->i; +- r->r = z->r; +- r->i = -zi; +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/r_cnjg.c +echo libF77/r_cos.c 1>&2 +sed >libF77/r_cos.c <<'//GO.SYSIN DD libF77/r_cos.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double cos(); +-double r_cos(x) real *x; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-double r_cos(real *x) +-#endif +-{ +-return( cos(*x) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/r_cos.c +echo libF77/r_cosh.c 1>&2 +sed >libF77/r_cosh.c <<'//GO.SYSIN DD libF77/r_cosh.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double cosh(); +-double r_cosh(x) real *x; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-double r_cosh(real *x) +-#endif +-{ +-return( cosh(*x) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/r_cosh.c +echo libF77/r_dim.c 1>&2 +sed >libF77/r_dim.c <<'//GO.SYSIN DD libF77/r_dim.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-double r_dim(a,b) real *a, *b; +-#else +-double r_dim(real *a, real *b) +-#endif +-{ +-return( *a > *b ? *a - *b : 0); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/r_dim.c +echo libF77/r_exp.c 1>&2 +sed >libF77/r_exp.c <<'//GO.SYSIN DD libF77/r_exp.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double exp(); +-double r_exp(x) real *x; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-double r_exp(real *x) +-#endif +-{ +-return( exp(*x) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/r_exp.c +echo libF77/r_imag.c 1>&2 +sed >libF77/r_imag.c <<'//GO.SYSIN DD libF77/r_imag.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-double r_imag(z) complex *z; +-#else +-double r_imag(complex *z) +-#endif +-{ +-return(z->i); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/r_imag.c +echo libF77/r_int.c 1>&2 +sed >libF77/r_int.c <<'//GO.SYSIN DD libF77/r_int.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double floor(); +-double r_int(x) real *x; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-double r_int(real *x) +-#endif +-{ +-return( (*x>0) ? floor(*x) : -floor(- *x) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/r_int.c +echo libF77/r_lg10.c 1>&2 +sed >libF77/r_lg10.c <<'//GO.SYSIN DD libF77/r_lg10.c' 's/^-//' +-#include "f2c.h" +- +-#define log10e 0.43429448190325182765 +- +-#ifdef KR_headers +-double log(); +-double r_lg10(x) real *x; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-double r_lg10(real *x) +-#endif +-{ +-return( log10e * log(*x) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/r_lg10.c +echo libF77/r_log.c 1>&2 +sed >libF77/r_log.c <<'//GO.SYSIN DD libF77/r_log.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double log(); +-double r_log(x) real *x; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-double r_log(real *x) +-#endif +-{ +-return( log(*x) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/r_log.c +echo libF77/r_mod.c 1>&2 +sed >libF77/r_mod.c <<'//GO.SYSIN DD libF77/r_mod.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-#ifdef IEEE_drem +-double drem(); +-#else +-double floor(); +-#endif +-double r_mod(x,y) real *x, *y; +-#else +-#ifdef IEEE_drem +-double drem(double, double); +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-#endif +-double r_mod(real *x, real *y) +-#endif +-{ +-#ifdef IEEE_drem +- double xa, ya, z; +- if ((ya = *y) < 0.) +- ya = -ya; +- z = drem(xa = *x, ya); +- if (xa > 0) { +- if (z < 0) +- z += ya; +- } +- else if (z > 0) +- z -= ya; +- return z; +-#else +- double quotient; +- if( (quotient = (double)*x / *y) >= 0) +- quotient = floor(quotient); +- else +- quotient = -floor(-quotient); +- return(*x - (*y) * quotient ); +-#endif +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/r_mod.c +echo libF77/r_nint.c 1>&2 +sed >libF77/r_nint.c <<'//GO.SYSIN DD libF77/r_nint.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double floor(); +-double r_nint(x) real *x; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-double r_nint(real *x) +-#endif +-{ +-return( (*x)>=0 ? +- floor(*x + .5) : -floor(.5 - *x) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/r_nint.c +echo libF77/r_sign.c 1>&2 +sed >libF77/r_sign.c <<'//GO.SYSIN DD libF77/r_sign.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-double r_sign(a,b) real *a, *b; +-#else +-double r_sign(real *a, real *b) +-#endif +-{ +-double x; +-x = (*a >= 0 ? *a : - *a); +-return( *b >= 0 ? x : -x); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/r_sign.c +echo libF77/r_sin.c 1>&2 +sed >libF77/r_sin.c <<'//GO.SYSIN DD libF77/r_sin.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double sin(); +-double r_sin(x) real *x; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-double r_sin(real *x) +-#endif +-{ +-return( sin(*x) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/r_sin.c +echo libF77/r_sinh.c 1>&2 +sed >libF77/r_sinh.c <<'//GO.SYSIN DD libF77/r_sinh.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double sinh(); +-double r_sinh(x) real *x; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-double r_sinh(real *x) +-#endif +-{ +-return( sinh(*x) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/r_sinh.c +echo libF77/r_sqrt.c 1>&2 +sed >libF77/r_sqrt.c <<'//GO.SYSIN DD libF77/r_sqrt.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double sqrt(); +-double r_sqrt(x) real *x; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-double r_sqrt(real *x) +-#endif +-{ +-return( sqrt(*x) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/r_sqrt.c +echo libF77/r_tan.c 1>&2 +sed >libF77/r_tan.c <<'//GO.SYSIN DD libF77/r_tan.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double tan(); +-double r_tan(x) real *x; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-double r_tan(real *x) +-#endif +-{ +-return( tan(*x) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/r_tan.c +echo libF77/r_tanh.c 1>&2 +sed >libF77/r_tanh.c <<'//GO.SYSIN DD libF77/r_tanh.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double tanh(); +-double r_tanh(x) real *x; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-double r_tanh(real *x) +-#endif +-{ +-return( tanh(*x) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/r_tanh.c +echo libF77/s_cmp.c 1>&2 +sed >libF77/s_cmp.c <<'//GO.SYSIN DD libF77/s_cmp.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-/* compare two strings */ +- +-#ifdef KR_headers +-integer s_cmp(a0, b0, la, lb) char *a0, *b0; ftnlen la, lb; +-#else +-integer s_cmp(char *a0, char *b0, ftnlen la, ftnlen lb) +-#endif +-{ +-register unsigned char *a, *aend, *b, *bend; +-a = (unsigned char *)a0; +-b = (unsigned char *)b0; +-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) +- { ++a; ++b; } +- else +- return( *a - *b ); +- while(a < aend) +- if(*a != ' ') +- return(*a - ' '); +- else ++a; +- } +-return(0); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/s_cmp.c +echo libF77/s_copy.c 1>&2 +sed >libF77/s_copy.c <<'//GO.SYSIN DD libF77/s_copy.c' 's/^-//' +-/* Unless compiled with -DNO_OVERWRITE, this variant of s_copy allows the +- * target of an assignment to appear on its right-hand side (contrary +- * to the Fortran 77 Standard, but in accordance with Fortran 90), +- * as in a(2:5) = a(4:7) . +- */ +- +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-/* assign strings: a = b */ +- +-#ifdef KR_headers +-VOID s_copy(a, b, la, lb) register char *a, *b; ftnlen la, lb; +-#else +-void s_copy(register char *a, register char *b, ftnlen la, ftnlen lb) +-#endif +-{ +- register char *aend, *bend; +- +- aend = a + la; +- +- if(la <= lb) +-#ifndef NO_OVERWRITE +- if (a <= b || a >= b + la) +-#endif +- while(a < aend) +- *a++ = *b++; +-#ifndef NO_OVERWRITE +- else +- for(b += la; a < aend; ) +- *--aend = *--b; +-#endif +- +- else { +- bend = b + lb; +-#ifndef NO_OVERWRITE +- if (a <= b || a >= bend) +-#endif +- while(b < bend) +- *a++ = *b++; +-#ifndef NO_OVERWRITE +- else { +- a += lb; +- while(b < bend) +- *--a = *--bend; +- a += lb; +- } +-#endif +- while(a < aend) +- *a++ = ' '; +- } +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/s_copy.c +echo libF77/s_paus.c 1>&2 +sed >libF77/s_paus.c <<'//GO.SYSIN DD libF77/s_paus.c' 's/^-//' +-#include "stdio.h" +-#include "f2c.h" +-#define PAUSESIG 15 +- +-#include "signal1.h" +-#ifdef KR_headers +-#define Void /* void */ +-#define Int /* int */ +-#else +-#define Void void +-#define Int int +-#undef abs +-#undef min +-#undef max +-#include "stdlib.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-#ifdef __cplusplus +-extern "C" { +-#endif +-extern int getpid(void), isatty(int), pause(void); +-#endif +- +-extern VOID f_exit(Void); +- +- static VOID +-waitpause(Sigarg) +-{ Use_Sigarg; +- return; +- } +- +- static VOID +-#ifdef KR_headers +-s_1paus(fin) FILE *fin; +-#else +-s_1paus(FILE *fin) +-#endif +-{ +- fprintf(stderr, +- "To resume execution, type go. Other input will terminate the job.\n"); +- fflush(stderr); +- if( getc(fin)!='g' || getc(fin)!='o' || getc(fin)!='\n' ) { +- fprintf(stderr, "STOP\n"); +-#ifdef NO_ONEXIT +- f_exit(); +-#endif +- exit(0); +- } +- } +- +- int +-#ifdef KR_headers +-s_paus(s, n) char *s; ftnlen n; +-#else +-s_paus(char *s, ftnlen n) +-#endif +-{ +- fprintf(stderr, "PAUSE "); +- if(n > 0) +- fprintf(stderr, " %.*s", (int)n, s); +- fprintf(stderr, " statement executed\n"); +- if( isatty(fileno(stdin)) ) +- s_1paus(stdin); +- else { +-#ifdef MSDOS +- FILE *fin; +- fin = fopen("con", "r"); +- if (!fin) { +- fprintf(stderr, "s_paus: can't open con!\n"); +- fflush(stderr); +- exit(1); +- } +- s_1paus(fin); +- fclose(fin); +-#else +- fprintf(stderr, +- "To resume execution, execute a kill -%d %d command\n", +- PAUSESIG, getpid() ); +- signal1(PAUSESIG, waitpause); +- fflush(stderr); +- pause(); +-#endif +- } +- fprintf(stderr, "Execution resumes after PAUSE.\n"); +- fflush(stderr); +- return 0; /* NOT REACHED */ +-#ifdef __cplusplus +- } +-#endif +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/s_paus.c +echo libF77/s_rnge.c 1>&2 +sed >libF77/s_rnge.c <<'//GO.SYSIN DD libF77/s_rnge.c' 's/^-//' +-#include "stdio.h" +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-/* called when a subscript is out of range */ +- +-#ifdef KR_headers +-extern VOID sig_die(); +-integer s_rnge(varn, offset, procn, line) char *varn, *procn; ftnint offset, line; +-#else +-extern VOID sig_die(char*,int); +-integer s_rnge(char *varn, ftnint offset, char *procn, ftnint line) +-#endif +-{ +-register int i; +- +-fprintf(stderr, "Subscript out of range on file line %ld, procedure ", +- (long)line); +-while((i = *procn) && i != '_' && i != ' ') +- putc(*procn++, stderr); +-fprintf(stderr, ".\nAttempt to access the %ld-th element of variable ", +- (long)offset+1); +-while((i = *varn) && i != ' ') +- putc(*varn++, stderr); +-sig_die(".", 1); +-return 0; /* not reached */ +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/s_rnge.c +echo libF77/s_stop.c 1>&2 +sed >libF77/s_stop.c <<'//GO.SYSIN DD libF77/s_stop.c' 's/^-//' +-#include "stdio.h" +-#include "f2c.h" +- +-#ifdef KR_headers +-extern void f_exit(); +-int s_stop(s, n) char *s; ftnlen n; +-#else +-#undef abs +-#undef min +-#undef max +-#include "stdlib.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-#ifdef __cplusplus +-extern "C" { +-#endif +-void f_exit(void); +- +-int s_stop(char *s, ftnlen n) +-#endif +-{ +-int i; +- +-if(n > 0) +- { +- fprintf(stderr, "STOP "); +- for(i = 0; i<n ; ++i) +- putc(*s++, stderr); +- fprintf(stderr, " statement executed\n"); +- } +-#ifdef NO_ONEXIT +-f_exit(); +-#endif +-exit(0); +- +-/* We cannot avoid (useless) compiler diagnostics here: */ +-/* some compilers complain if there is no return statement, */ +-/* and others complain that this one cannot be reached. */ +- +-return 0; /* NOT REACHED */ +-} +-#ifdef __cplusplus +-} +-#endif +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/s_stop.c +echo libF77/signal1.h0 1>&2 +sed >libF77/signal1.h0 <<'//GO.SYSIN DD libF77/signal1.h0' 's/^-//' +-/* You may need to adjust the definition of signal1 to supply a */ +-/* cast to the correct argument type. This detail is system- and */ +-/* compiler-dependent. The #define below assumes signal.h declares */ +-/* type SIG_PF for the signal function's second argument. */ +- +-/* For some C++ compilers, "#define Sigarg_t ..." may be appropriate. */ +- +-#include <signal.h> +- +-#ifndef Sigret_t +-#define Sigret_t void +-#endif +-#ifndef Sigarg_t +-#ifdef KR_headers +-#define Sigarg_t +-#else +-#define Sigarg_t int +-#endif +-#endif /*Sigarg_t*/ +- +-#ifdef USE_SIG_PF /* compile with -DUSE_SIG_PF under IRIX */ +-#define sig_pf SIG_PF +-#else +-typedef Sigret_t (*sig_pf)(Sigarg_t); +-#endif +- +-#define signal1(a,b) signal(a,(sig_pf)b) +- +-#ifdef __cplusplus +-#define Sigarg ... +-#define Use_Sigarg +-#else +-#define Sigarg Int n +-#define Use_Sigarg n = n /* shut up compiler warning */ +-#endif +//GO.SYSIN DD libF77/signal1.h0 +echo libF77/signal_.c 1>&2 +sed >libF77/signal_.c <<'//GO.SYSIN DD libF77/signal_.c' 's/^-//' +-#include "f2c.h" +-#include "signal1.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +- ftnint +-#ifdef KR_headers +-signal_(sigp, proc) integer *sigp; sig_pf proc; +-#else +-signal_(integer *sigp, sig_pf proc) +-#endif +-{ +- int sig; +- sig = (int)*sigp; +- +- return (ftnint)signal(sig, proc); +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/signal_.c +echo libF77/system_.c 1>&2 +sed >libF77/system_.c <<'//GO.SYSIN DD libF77/system_.c' 's/^-//' +-/* f77 interface to system routine */ +- +-#include "f2c.h" +- +-#ifdef KR_headers +-extern char *F77_aloc(); +- +- integer +-system_(s, n) register char *s; ftnlen n; +-#else +-#undef abs +-#undef min +-#undef max +-#include "stdlib.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-extern char *F77_aloc(ftnlen, char*); +- +- integer +-system_(register char *s, ftnlen n) +-#endif +-{ +- char buff0[256], *buff; +- register char *bp, *blast; +- integer rv; +- +- buff = bp = n < sizeof(buff0) +- ? buff0 : F77_aloc(n+1, "system_"); +- blast = bp + n; +- +- while(bp < blast && *s) +- *bp++ = *s++; +- *bp = 0; +- rv = system(buff); +- if (buff != buff0) +- free(buff); +- return rv; +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/system_.c +echo libF77/z_abs.c 1>&2 +sed >libF77/z_abs.c <<'//GO.SYSIN DD libF77/z_abs.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-double f__cabs(); +-double z_abs(z) doublecomplex *z; +-#else +-double f__cabs(double, double); +-double z_abs(doublecomplex *z) +-#endif +-{ +-return( f__cabs( z->r, z->i ) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/z_abs.c +echo libF77/z_cos.c 1>&2 +sed >libF77/z_cos.c <<'//GO.SYSIN DD libF77/z_cos.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double sin(), cos(), sinh(), cosh(); +-VOID z_cos(r, z) doublecomplex *r, *z; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-void z_cos(doublecomplex *r, doublecomplex *z) +-#endif +-{ +- double zi = z->i, zr = z->r; +- r->r = cos(zr) * cosh(zi); +- r->i = - sin(zr) * sinh(zi); +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/z_cos.c +echo libF77/z_div.c 1>&2 +sed >libF77/z_div.c <<'//GO.SYSIN DD libF77/z_div.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-extern VOID sig_die(); +-VOID z_div(c, a, b) doublecomplex *a, *b, *c; +-#else +-extern void sig_die(char*, int); +-void z_div(doublecomplex *c, doublecomplex *a, doublecomplex *b) +-#endif +-{ +- double ratio, den; +- double abr, abi, cr; +- +- if( (abr = b->r) < 0.) +- abr = - abr; +- if( (abi = b->i) < 0.) +- abi = - abi; +- if( abr <= abi ) +- { +- if(abi == 0) { +-#ifdef IEEE_COMPLEX_DIVIDE +- if (a->i != 0 || a->r != 0) +- abi = 1.; +- c->i = c->r = abi / abr; +- return; +-#else +- sig_die("complex division by zero", 1); +-#endif +- } +- ratio = b->r / b->i ; +- den = b->i * (1 + ratio*ratio); +- cr = (a->r*ratio + a->i) / den; +- c->i = (a->i*ratio - a->r) / den; +- } +- +- else +- { +- ratio = b->i / b->r ; +- den = b->r * (1 + ratio*ratio); +- cr = (a->r + a->i*ratio) / den; +- c->i = (a->i - a->r*ratio) / den; +- } +- c->r = cr; +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/z_div.c +echo libF77/z_exp.c 1>&2 +sed >libF77/z_exp.c <<'//GO.SYSIN DD libF77/z_exp.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double exp(), cos(), sin(); +-VOID z_exp(r, z) doublecomplex *r, *z; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-void z_exp(doublecomplex *r, doublecomplex *z) +-#endif +-{ +- double expx, zi = z->i; +- +- expx = exp(z->r); +- r->r = expx * cos(zi); +- r->i = expx * sin(zi); +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/z_exp.c +echo libF77/z_log.c 1>&2 +sed >libF77/z_log.c <<'//GO.SYSIN DD libF77/z_log.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double log(), f__cabs(), atan2(); +-#define ANSI(x) () +-#else +-#define ANSI(x) x +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-extern double f__cabs(double, double); +-#endif +- +-#ifndef NO_DOUBLE_EXTENDED +-#ifndef GCC_COMPARE_BUG_FIXED +-#ifndef Pre20000310 +-#ifdef Comment +-Some versions of gcc, such as 2.95.3 and 3.0.4, are buggy under -O2 or -O3: +-on IA32 (Intel 80x87) systems, they may do comparisons on values computed +-in extended-precision registers. This can lead to the test "s > s0" that +-was used below being carried out incorrectly. The fix below cannot be +-spoiled by overzealous optimization, since the compiler cannot know +-whether gcc_bug_bypass_diff_F2C will be nonzero. (We expect it always +-to be zero. The weird name is unlikely to collide with anything.) +- +-An example (provided by Ulrich Jakobus) where the bug fix matters is +- +- double complex a, b +- a = (.1099557428756427618354862829619, .9857360542953131909982289471372) +- b = log(a) +- +-An alternative to the fix below would be to use 53-bit rounding precision, +-but the means of specifying this 80x87 feature are highly unportable. +-#endif /*Comment*/ +-#define BYPASS_GCC_COMPARE_BUG +-double (*gcc_bug_bypass_diff_F2C) ANSI((double*,double*)); +- static double +-#ifdef KR_headers +-diff1(a,b) double *a, *b; +-#else +-diff1(double *a, double *b) +-#endif +-{ return *a - *b; } +-#endif /*Pre20000310*/ +-#endif /*GCC_COMPARE_BUG_FIXED*/ +-#endif /*NO_DOUBLE_EXTENDED*/ +- +-#ifdef KR_headers +-VOID z_log(r, z) doublecomplex *r, *z; +-#else +-void z_log(doublecomplex *r, doublecomplex *z) +-#endif +-{ +- double s, s0, t, t2, u, v; +- double zi = z->i, zr = z->r; +-#ifdef BYPASS_GCC_COMPARE_BUG +- double (*diff) ANSI((double*,double*)); +-#endif +- +- r->i = atan2(zi, zr); +-#ifdef Pre20000310 +- r->r = log( f__cabs( zr, zi ) ); +-#else +- if (zi < 0) +- zi = -zi; +- if (zr < 0) +- zr = -zr; +- if (zr < zi) { +- t = zi; +- zi = zr; +- zr = t; +- } +- t = zi/zr; +- s = zr * sqrt(1 + t*t); +- /* now s = f__cabs(zi,zr), and zr = |zr| >= |zi| = zi */ +- if ((t = s - 1) < 0) +- t = -t; +- if (t > .01) +- r->r = log(s); +- else { +- +-#ifdef Comment +- +- log(1+x) = x - x^2/2 + x^3/3 - x^4/4 + - ... +- +- = x(1 - x/2 + x^2/3 -+...) +- +- [sqrt(y^2 + z^2) - 1] * [sqrt(y^2 + z^2) + 1] = y^2 + z^2 - 1, so +- +- sqrt(y^2 + z^2) - 1 = (y^2 + z^2 - 1) / [sqrt(y^2 + z^2) + 1] +- +-#endif /*Comment*/ +- +-#ifdef BYPASS_GCC_COMPARE_BUG +- if (!(diff = gcc_bug_bypass_diff_F2C)) +- diff = diff1; +-#endif +- t = ((zr*zr - 1.) + zi*zi) / (s + 1); +- t2 = t*t; +- s = 1. - 0.5*t; +- u = v = 1; +- do { +- s0 = s; +- u *= t2; +- v += 2; +- s += u/v - t*u/(v+1); +- } +-#ifdef BYPASS_GCC_COMPARE_BUG +- while(s - s0 > 1e-18 || (*diff)(&s,&s0) > 0.); +-#else +- while(s > s0); +-#endif +- r->r = s*t; +- } +-#endif +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/z_log.c +echo libF77/z_sin.c 1>&2 +sed >libF77/z_sin.c <<'//GO.SYSIN DD libF77/z_sin.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double sin(), cos(), sinh(), cosh(); +-VOID z_sin(r, z) doublecomplex *r, *z; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-void z_sin(doublecomplex *r, doublecomplex *z) +-#endif +-{ +- double zi = z->i, zr = z->r; +- r->r = sin(zr) * cosh(zi); +- r->i = cos(zr) * sinh(zi); +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/z_sin.c +echo libF77/i_mod.c 1>&2 +sed >libF77/i_mod.c <<'//GO.SYSIN DD libF77/i_mod.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-integer i_mod(a,b) integer *a, *b; +-#else +-integer i_mod(integer *a, integer *b) +-#endif +-{ +-return( *a % *b); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/i_mod.c +echo libF77/i_nint.c 1>&2 +sed >libF77/i_nint.c <<'//GO.SYSIN DD libF77/i_nint.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double floor(); +-integer i_nint(x) real *x; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-integer i_nint(real *x) +-#endif +-{ +-return (integer)(*x >= 0 ? floor(*x + .5) : -floor(.5 - *x)); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/i_nint.c +echo libF77/i_sign.c 1>&2 +sed >libF77/i_sign.c <<'//GO.SYSIN DD libF77/i_sign.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-integer i_sign(a,b) integer *a, *b; +-#else +-integer i_sign(integer *a, integer *b) +-#endif +-{ +-integer x; +-x = (*a >= 0 ? *a : - *a); +-return( *b >= 0 ? x : -x); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/i_sign.c +echo libF77/iargc_.c 1>&2 +sed >libF77/iargc_.c <<'//GO.SYSIN DD libF77/iargc_.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-ftnint iargc_() +-#else +-ftnint iargc_(void) +-#endif +-{ +-extern int xargc; +-return ( xargc - 1 ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/iargc_.c +echo libF77/l_ge.c 1>&2 +sed >libF77/l_ge.c <<'//GO.SYSIN DD libF77/l_ge.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-extern integer s_cmp(); +-logical l_ge(a,b,la,lb) char *a, *b; ftnlen la, lb; +-#else +-extern integer s_cmp(char *, char *, ftnlen, ftnlen); +-logical l_ge(char *a, char *b, ftnlen la, ftnlen lb) +-#endif +-{ +-return(s_cmp(a,b,la,lb) >= 0); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/l_ge.c +echo libF77/l_gt.c 1>&2 +sed >libF77/l_gt.c <<'//GO.SYSIN DD libF77/l_gt.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-extern integer s_cmp(); +-logical l_gt(a,b,la,lb) char *a, *b; ftnlen la, lb; +-#else +-extern integer s_cmp(char *, char *, ftnlen, ftnlen); +-logical l_gt(char *a, char *b, ftnlen la, ftnlen lb) +-#endif +-{ +-return(s_cmp(a,b,la,lb) > 0); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/l_gt.c +echo libF77/l_le.c 1>&2 +sed >libF77/l_le.c <<'//GO.SYSIN DD libF77/l_le.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-extern integer s_cmp(); +-logical l_le(a,b,la,lb) char *a, *b; ftnlen la, lb; +-#else +-extern integer s_cmp(char *, char *, ftnlen, ftnlen); +-logical l_le(char *a, char *b, ftnlen la, ftnlen lb) +-#endif +-{ +-return(s_cmp(a,b,la,lb) <= 0); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/l_le.c +echo libF77/l_lt.c 1>&2 +sed >libF77/l_lt.c <<'//GO.SYSIN DD libF77/l_lt.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-extern integer s_cmp(); +-logical l_lt(a,b,la,lb) char *a, *b; ftnlen la, lb; +-#else +-extern integer s_cmp(char *, char *, ftnlen, ftnlen); +-logical l_lt(char *a, char *b, ftnlen la, ftnlen lb) +-#endif +-{ +-return(s_cmp(a,b,la,lb) < 0); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/l_lt.c +echo libF77/lbitbits.c 1>&2 +sed >libF77/lbitbits.c <<'//GO.SYSIN DD libF77/lbitbits.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifndef LONGBITS +-#define LONGBITS 32 +-#endif +- +- integer +-#ifdef KR_headers +-lbit_bits(a, b, len) integer a, b, len; +-#else +-lbit_bits(integer a, integer b, integer len) +-#endif +-{ +- /* Assume 2's complement arithmetic */ +- +- unsigned long x, y; +- +- x = (unsigned long) a; +- y = (unsigned long)-1L; +- x >>= b; +- y <<= len; +- return (integer)(x & ~y); +- } +- +- integer +-#ifdef KR_headers +-lbit_cshift(a, b, len) integer a, b, len; +-#else +-lbit_cshift(integer a, integer b, integer len) +-#endif +-{ +- unsigned long x, y, z; +- +- x = (unsigned long)a; +- if (len <= 0) { +- if (len == 0) +- return 0; +- goto full_len; +- } +- if (len >= LONGBITS) { +- full_len: +- if (b >= 0) { +- b %= LONGBITS; +- return (integer)(x << b | x >> LONGBITS -b ); +- } +- b = -b; +- b %= LONGBITS; +- return (integer)(x << LONGBITS - b | x >> b); +- } +- y = z = (unsigned long)-1; +- y <<= len; +- z &= ~y; +- y &= x; +- x &= z; +- if (b >= 0) { +- b %= len; +- return (integer)(y | z & (x << b | x >> len - b)); +- } +- b = -b; +- b %= len; +- return (integer)(y | z & (x >> b | x << len - b)); +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/lbitbits.c +echo libF77/lbitshft.c 1>&2 +sed >libF77/lbitshft.c <<'//GO.SYSIN DD libF77/lbitshft.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +- integer +-#ifdef KR_headers +-lbit_shift(a, b) integer a; integer b; +-#else +-lbit_shift(integer a, integer b) +-#endif +-{ +- return b >= 0 ? a << b : (integer)((uinteger)a >> -b); +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/lbitshft.c +echo libF77/sig_die.c 1>&2 +sed >libF77/sig_die.c <<'//GO.SYSIN DD libF77/sig_die.c' 's/^-//' +-#include "stdio.h" +-#include "signal.h" +- +-#ifndef SIGIOT +-#ifdef SIGABRT +-#define SIGIOT SIGABRT +-#endif +-#endif +- +-#ifdef KR_headers +-void sig_die(s, kill) register char *s; int kill; +-#else +-#include "stdlib.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-#ifdef __cplusplus +-extern "C" { +-#endif +- extern void f_exit(void); +- +-void sig_die(register char *s, int kill) +-#endif +-{ +- /* print error message, then clear buffers */ +- fprintf(stderr, "%s\n", s); +- +- if(kill) +- { +- fflush(stderr); +- f_exit(); +- fflush(stderr); +- /* now get a core */ +-#ifdef SIGIOT +- signal(SIGIOT, SIG_DFL); +-#endif +- abort(); +- } +- else { +-#ifdef NO_ONEXIT +- f_exit(); +-#endif +- exit(1); +- } +- } +-#ifdef __cplusplus +-} +-#endif +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/sig_die.c +echo libF77/d_sinh.c 1>&2 +sed >libF77/d_sinh.c <<'//GO.SYSIN DD libF77/d_sinh.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double sinh(); +-double d_sinh(x) doublereal *x; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-double d_sinh(doublereal *x) +-#endif +-{ +-return( sinh(*x) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/d_sinh.c +echo libF77/d_sqrt.c 1>&2 +sed >libF77/d_sqrt.c <<'//GO.SYSIN DD libF77/d_sqrt.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double sqrt(); +-double d_sqrt(x) doublereal *x; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-double d_sqrt(doublereal *x) +-#endif +-{ +-return( sqrt(*x) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/d_sqrt.c +echo libF77/d_tan.c 1>&2 +sed >libF77/d_tan.c <<'//GO.SYSIN DD libF77/d_tan.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double tan(); +-double d_tan(x) doublereal *x; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-double d_tan(doublereal *x) +-#endif +-{ +-return( tan(*x) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/d_tan.c +echo libF77/d_tanh.c 1>&2 +sed >libF77/d_tanh.c <<'//GO.SYSIN DD libF77/d_tanh.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double tanh(); +-double d_tanh(x) doublereal *x; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-double d_tanh(doublereal *x) +-#endif +-{ +-return( tanh(*x) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/d_tanh.c +echo libF77/derf_.c 1>&2 +sed >libF77/derf_.c <<'//GO.SYSIN DD libF77/derf_.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-double erf(); +-double derf_(x) doublereal *x; +-#else +-extern double erf(double); +-double derf_(doublereal *x) +-#endif +-{ +-return( erf(*x) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/derf_.c +echo libF77/derfc_.c 1>&2 +sed >libF77/derfc_.c <<'//GO.SYSIN DD libF77/derfc_.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-extern double erfc(); +- +-double derfc_(x) doublereal *x; +-#else +-extern double erfc(double); +- +-double derfc_(doublereal *x) +-#endif +-{ +-return( erfc(*x) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/derfc_.c +echo libF77/dtime_.c 1>&2 +sed >libF77/dtime_.c <<'//GO.SYSIN DD libF77/dtime_.c' 's/^-//' +-#include "time.h" +- +-#ifdef MSDOS +-#undef USE_CLOCK +-#define USE_CLOCK +-#endif +- +-#ifndef REAL +-#define REAL double +-#endif +- +-#ifndef USE_CLOCK +-#define _INCLUDE_POSIX_SOURCE /* for HP-UX */ +-#define _INCLUDE_XOPEN_SOURCE /* for HP-UX */ +-#include "sys/types.h" +-#include "sys/times.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-#endif +- +-#undef Hz +-#ifdef CLK_TCK +-#define Hz CLK_TCK +-#else +-#ifdef HZ +-#define Hz HZ +-#else +-#define Hz 60 +-#endif +-#endif +- +- REAL +-#ifdef KR_headers +-dtime_(tarray) float *tarray; +-#else +-dtime_(float *tarray) +-#endif +-{ +-#ifdef USE_CLOCK +-#ifndef CLOCKS_PER_SECOND +-#define CLOCKS_PER_SECOND Hz +-#endif +- static double t0; +- double t = clock(); +- tarray[1] = 0; +- tarray[0] = (t - t0) / CLOCKS_PER_SECOND; +- t0 = t; +- return tarray[0]; +-#else +- struct tms t; +- static struct tms t0; +- +- times(&t); +- tarray[0] = (double)(t.tms_utime - t0.tms_utime) / Hz; +- tarray[1] = (double)(t.tms_stime - t0.tms_stime) / Hz; +- t0 = t; +- return tarray[0] + tarray[1]; +-#endif +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/dtime_.c +echo libF77/ef1asc_.c 1>&2 +sed >libF77/ef1asc_.c <<'//GO.SYSIN DD libF77/ef1asc_.c' 's/^-//' +-/* EFL support routine to copy string b to string a */ +- +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +- +-#define M ( (long) (sizeof(long) - 1) ) +-#define EVEN(x) ( ( (x)+ M) & (~M) ) +- +-#ifdef KR_headers +-extern VOID s_copy(); +-ef1asc_(a, la, b, lb) ftnint *a, *b; ftnlen *la, *lb; +-#else +-extern void s_copy(char*,char*,ftnlen,ftnlen); +-int ef1asc_(ftnint *a, ftnlen *la, ftnint *b, ftnlen *lb) +-#endif +-{ +-s_copy( (char *)a, (char *)b, EVEN(*la), *lb ); +-return 0; /* ignored return value */ +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/ef1asc_.c +echo libF77/ef1cmc_.c 1>&2 +sed >libF77/ef1cmc_.c <<'//GO.SYSIN DD libF77/ef1cmc_.c' 's/^-//' +-/* EFL support routine to compare two character strings */ +- +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-extern integer s_cmp(); +-integer ef1cmc_(a, la, b, lb) ftnint *a, *b; ftnlen *la, *lb; +-#else +-extern integer s_cmp(char*,char*,ftnlen,ftnlen); +-integer ef1cmc_(ftnint *a, ftnlen *la, ftnint *b, ftnlen *lb) +-#endif +-{ +-return( s_cmp( (char *)a, (char *)b, *la, *lb) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/ef1cmc_.c +echo libF77/erf_.c 1>&2 +sed >libF77/erf_.c <<'//GO.SYSIN DD libF77/erf_.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifndef REAL +-#define REAL double +-#endif +- +-#ifdef KR_headers +-double erf(); +-REAL erf_(x) real *x; +-#else +-extern double erf(double); +-REAL erf_(real *x) +-#endif +-{ +-return( erf((double)*x) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/erf_.c +echo libF77/erfc_.c 1>&2 +sed >libF77/erfc_.c <<'//GO.SYSIN DD libF77/erfc_.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifndef REAL +-#define REAL double +-#endif +- +-#ifdef KR_headers +-double erfc(); +-REAL erfc_(x) real *x; +-#else +-extern double erfc(double); +-REAL erfc_(real *x) +-#endif +-{ +-return( erfc((double)*x) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/erfc_.c +echo libF77/etime_.c 1>&2 +sed >libF77/etime_.c <<'//GO.SYSIN DD libF77/etime_.c' 's/^-//' +-#include "time.h" +- +-#ifdef MSDOS +-#undef USE_CLOCK +-#define USE_CLOCK +-#endif +- +-#ifndef REAL +-#define REAL double +-#endif +- +-#ifndef USE_CLOCK +-#define _INCLUDE_POSIX_SOURCE /* for HP-UX */ +-#define _INCLUDE_XOPEN_SOURCE /* for HP-UX */ +-#include "sys/types.h" +-#include "sys/times.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-#endif +- +-#undef Hz +-#ifdef CLK_TCK +-#define Hz CLK_TCK +-#else +-#ifdef HZ +-#define Hz HZ +-#else +-#define Hz 60 +-#endif +-#endif +- +- REAL +-#ifdef KR_headers +-etime_(tarray) float *tarray; +-#else +-etime_(float *tarray) +-#endif +-{ +-#ifdef USE_CLOCK +-#ifndef CLOCKS_PER_SECOND +-#define CLOCKS_PER_SECOND Hz +-#endif +- double t = clock(); +- tarray[1] = 0; +- return tarray[0] = t / CLOCKS_PER_SECOND; +-#else +- struct tms t; +- +- times(&t); +- return (tarray[0] = (double)t.tms_utime/Hz) +- + (tarray[1] = (double)t.tms_stime/Hz); +-#endif +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/etime_.c +echo libF77/exit_.c 1>&2 +sed >libF77/exit_.c <<'//GO.SYSIN DD libF77/exit_.c' 's/^-//' +-/* This gives the effect of +- +- subroutine exit(rc) +- integer*4 rc +- stop +- end +- +- * with the added side effect of supplying rc as the program's exit code. +- */ +- +-#include "f2c.h" +-#undef abs +-#undef min +-#undef max +-#ifndef KR_headers +-#include "stdlib.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-#ifdef __cplusplus +-extern "C" { +-#endif +-extern void f_exit(void); +-#endif +- +- void +-#ifdef KR_headers +-exit_(rc) integer *rc; +-#else +-exit_(integer *rc) +-#endif +-{ +-#ifdef NO_ONEXIT +- f_exit(); +-#endif +- exit(*rc); +- } +-#ifdef __cplusplus +-} +-#endif +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/exit_.c +echo libF77/getarg_.c 1>&2 +sed >libF77/getarg_.c <<'//GO.SYSIN DD libF77/getarg_.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-/* +- * subroutine getarg(k, c) +- * returns the kth unix command argument in fortran character +- * variable argument c +-*/ +- +-#ifdef KR_headers +-VOID getarg_(n, s, ls) ftnint *n; register char *s; ftnlen ls; +-#else +-void getarg_(ftnint *n, register char *s, ftnlen ls) +-#endif +-{ +-extern int xargc; +-extern char **xargv; +-register char *t; +-register int i; +- +-if(*n>=0 && *n<xargc) +- t = xargv[*n]; +-else +- t = ""; +-for(i = 0; i<ls && *t!='\0' ; ++i) +- *s++ = *t++; +-for( ; i<ls ; ++i) +- *s++ = ' '; +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/getarg_.c +echo libF77/getenv_.c 1>&2 +sed >libF77/getenv_.c <<'//GO.SYSIN DD libF77/getenv_.c' 's/^-//' +-#include "f2c.h" +-#undef abs +-#ifdef KR_headers +-extern char *F77_aloc(), *getenv(); +-#else +-#include <stdlib.h> +-#include <string.h> +-#ifdef __cplusplus +-extern "C" { +-#endif +-extern char *F77_aloc(ftnlen, char*); +-#endif +- +-/* +- * getenv - f77 subroutine to return environment variables +- * +- * called by: +- * call getenv (ENV_NAME, char_var) +- * where: +- * ENV_NAME is the name of an environment variable +- * char_var is a character variable which will receive +- * the current value of ENV_NAME, or all blanks +- * if ENV_NAME is not defined +- */ +- +-#ifdef KR_headers +- VOID +-getenv_(fname, value, flen, vlen) char *value, *fname; ftnlen vlen, flen; +-#else +- void +-getenv_(char *fname, char *value, ftnlen flen, ftnlen vlen) +-#endif +-{ +- char buf[256], *ep, *fp; +- integer i; +- +- if (flen <= 0) +- goto add_blanks; +- for(i = 0; i < sizeof(buf); i++) { +- if (i == flen || (buf[i] = fname[i]) == ' ') { +- buf[i] = 0; +- ep = getenv(buf); +- goto have_ep; +- } +- } +- while(i < flen && fname[i] != ' ') +- i++; +- strncpy(fp = F77_aloc(i+1, "getenv_"), fname, (int)i); +- fp[i] = 0; +- ep = getenv(fp); +- free(fp); +- have_ep: +- if (ep) +- while(*ep && vlen-- > 0) +- *value++ = *ep++; +- add_blanks: +- while(vlen-- > 0) +- *value++ = ' '; +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/getenv_.c +echo libF77/h_abs.c 1>&2 +sed >libF77/h_abs.c <<'//GO.SYSIN DD libF77/h_abs.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-shortint h_abs(x) shortint *x; +-#else +-shortint h_abs(shortint *x) +-#endif +-{ +-if(*x >= 0) +- return(*x); +-return(- *x); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/h_abs.c +echo libF77/h_dim.c 1>&2 +sed >libF77/h_dim.c <<'//GO.SYSIN DD libF77/h_dim.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-shortint h_dim(a,b) shortint *a, *b; +-#else +-shortint h_dim(shortint *a, shortint *b) +-#endif +-{ +-return( *a > *b ? *a - *b : 0); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/h_dim.c +echo libF77/h_dnnt.c 1>&2 +sed >libF77/h_dnnt.c <<'//GO.SYSIN DD libF77/h_dnnt.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double floor(); +-shortint h_dnnt(x) doublereal *x; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-shortint h_dnnt(doublereal *x) +-#endif +-{ +-return (shortint)(*x >= 0. ? floor(*x + .5) : -floor(.5 - *x)); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/h_dnnt.c +echo libF77/h_indx.c 1>&2 +sed >libF77/h_indx.c <<'//GO.SYSIN DD libF77/h_indx.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-shortint h_indx(a, b, la, lb) char *a, *b; ftnlen la, lb; +-#else +-shortint h_indx(char *a, char *b, ftnlen la, ftnlen lb) +-#endif +-{ +-ftnlen i, n; +-char *s, *t, *bend; +- +-n = la - lb + 1; +-bend = b + lb; +- +-for(i = 0 ; i < n ; ++i) +- { +- s = a + i; +- t = b; +- while(t < bend) +- if(*s++ != *t++) +- goto no; +- return((shortint)i+1); +- no: ; +- } +-return(0); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/h_indx.c +echo libF77/h_len.c 1>&2 +sed >libF77/h_len.c <<'//GO.SYSIN DD libF77/h_len.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-shortint h_len(s, n) char *s; ftnlen n; +-#else +-shortint h_len(char *s, ftnlen n) +-#endif +-{ +-return(n); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/h_len.c +echo libF77/h_mod.c 1>&2 +sed >libF77/h_mod.c <<'//GO.SYSIN DD libF77/h_mod.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-shortint h_mod(a,b) short *a, *b; +-#else +-shortint h_mod(short *a, short *b) +-#endif +-{ +-return( *a % *b); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/h_mod.c +echo libF77/h_nint.c 1>&2 +sed >libF77/h_nint.c <<'//GO.SYSIN DD libF77/h_nint.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double floor(); +-shortint h_nint(x) real *x; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-shortint h_nint(real *x) +-#endif +-{ +-return (shortint)(*x >= 0 ? floor(*x + .5) : -floor(.5 - *x)); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/h_nint.c +echo libF77/h_sign.c 1>&2 +sed >libF77/h_sign.c <<'//GO.SYSIN DD libF77/h_sign.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-shortint h_sign(a,b) shortint *a, *b; +-#else +-shortint h_sign(shortint *a, shortint *b) +-#endif +-{ +-shortint x; +-x = (*a >= 0 ? *a : - *a); +-return( *b >= 0 ? x : -x); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/h_sign.c +echo libF77/hl_ge.c 1>&2 +sed >libF77/hl_ge.c <<'//GO.SYSIN DD libF77/hl_ge.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-extern integer s_cmp(); +-shortlogical hl_ge(a,b,la,lb) char *a, *b; ftnlen la, lb; +-#else +-extern integer s_cmp(char *, char *, ftnlen, ftnlen); +-shortlogical hl_ge(char *a, char *b, ftnlen la, ftnlen lb) +-#endif +-{ +-return(s_cmp(a,b,la,lb) >= 0); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/hl_ge.c +echo libF77/hl_gt.c 1>&2 +sed >libF77/hl_gt.c <<'//GO.SYSIN DD libF77/hl_gt.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-extern integer s_cmp(); +-shortlogical hl_gt(a,b,la,lb) char *a, *b; ftnlen la, lb; +-#else +-extern integer s_cmp(char *, char *, ftnlen, ftnlen); +-shortlogical hl_gt(char *a, char *b, ftnlen la, ftnlen lb) +-#endif +-{ +-return(s_cmp(a,b,la,lb) > 0); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/hl_gt.c +echo libF77/hl_le.c 1>&2 +sed >libF77/hl_le.c <<'//GO.SYSIN DD libF77/hl_le.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-extern integer s_cmp(); +-shortlogical hl_le(a,b,la,lb) char *a, *b; ftnlen la, lb; +-#else +-extern integer s_cmp(char *, char *, ftnlen, ftnlen); +-shortlogical hl_le(char *a, char *b, ftnlen la, ftnlen lb) +-#endif +-{ +-return(s_cmp(a,b,la,lb) <= 0); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/hl_le.c +echo libF77/hl_lt.c 1>&2 +sed >libF77/hl_lt.c <<'//GO.SYSIN DD libF77/hl_lt.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-extern integer s_cmp(); +-shortlogical hl_lt(a,b,la,lb) char *a, *b; ftnlen la, lb; +-#else +-extern integer s_cmp(char *, char *, ftnlen, ftnlen); +-shortlogical hl_lt(char *a, char *b, ftnlen la, ftnlen lb) +-#endif +-{ +-return(s_cmp(a,b,la,lb) < 0); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/hl_lt.c +echo libF77/i_abs.c 1>&2 +sed >libF77/i_abs.c <<'//GO.SYSIN DD libF77/i_abs.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-integer i_abs(x) integer *x; +-#else +-integer i_abs(integer *x) +-#endif +-{ +-if(*x >= 0) +- return(*x); +-return(- *x); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/i_abs.c +echo libF77/i_dim.c 1>&2 +sed >libF77/i_dim.c <<'//GO.SYSIN DD libF77/i_dim.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-integer i_dim(a,b) integer *a, *b; +-#else +-integer i_dim(integer *a, integer *b) +-#endif +-{ +-return( *a > *b ? *a - *b : 0); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/i_dim.c +echo libF77/i_dnnt.c 1>&2 +sed >libF77/i_dnnt.c <<'//GO.SYSIN DD libF77/i_dnnt.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double floor(); +-integer i_dnnt(x) doublereal *x; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-integer i_dnnt(doublereal *x) +-#endif +-{ +-return (integer)(*x >= 0. ? floor(*x + .5) : -floor(.5 - *x)); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/i_dnnt.c +echo libF77/i_indx.c 1>&2 +sed >libF77/i_indx.c <<'//GO.SYSIN DD libF77/i_indx.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-integer i_indx(a, b, la, lb) char *a, *b; ftnlen la, lb; +-#else +-integer i_indx(char *a, char *b, ftnlen la, ftnlen lb) +-#endif +-{ +-ftnlen i, n; +-char *s, *t, *bend; +- +-n = la - lb + 1; +-bend = b + lb; +- +-for(i = 0 ; i < n ; ++i) +- { +- s = a + i; +- t = b; +- while(t < bend) +- if(*s++ != *t++) +- goto no; +- return(i+1); +- no: ; +- } +-return(0); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/i_indx.c +echo libF77/i_len.c 1>&2 +sed >libF77/i_len.c <<'//GO.SYSIN DD libF77/i_len.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-integer i_len(s, n) char *s; ftnlen n; +-#else +-integer i_len(char *s, ftnlen n) +-#endif +-{ +-return(n); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/i_len.c +echo libF77/F77_aloc.c 1>&2 +sed >libF77/F77_aloc.c <<'//GO.SYSIN DD libF77/F77_aloc.c' 's/^-//' +-#include "f2c.h" +-#undef abs +-#undef min +-#undef max +-#include "stdio.h" +- +-static integer memfailure = 3; +- +-#ifdef KR_headers +-extern char *malloc(); +-extern void exit_(); +- +- char * +-F77_aloc(Len, whence) integer Len; char *whence; +-#else +-#include "stdlib.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-#ifdef __cplusplus +-extern "C" { +-#endif +-extern void exit_(integer*); +-#ifdef __cplusplus +- } +-#endif +- +- char * +-F77_aloc(integer Len, char *whence) +-#endif +-{ +- char *rv; +- unsigned int uLen = (unsigned int) Len; /* for K&R C */ +- +- if (!(rv = (char*)malloc(uLen))) { +- fprintf(stderr, "malloc(%u) failure in %s\n", +- uLen, whence); +- exit_(&memfailure); +- } +- return rv; +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/F77_aloc.c +echo libF77/README 1>&2 +sed >libF77/README <<'//GO.SYSIN DD libF77/README' 's/^-//' +-If your compiler does not recognize ANSI C headers, +-compile with KR_headers defined: either add -DKR_headers +-to the definition of CFLAGS in the makefile, or insert +- +-#define KR_headers +- +-at the top of f2c.h , cabs.c , main.c , and sig_die.c . +- +-Under MS-DOS, compile s_paus.c with -DMSDOS. +- +-If you have a really ancient K&R C compiler that does not understand +-void, add -Dvoid=int to the definition of CFLAGS in the makefile. +- +-If you use a C++ compiler, first create a local f2c.h by appending +-f2ch.add to the usual f2c.h, e.g., by issuing the command +- make f2c.h +-which assumes f2c.h is installed in /usr/include . +- +-If your system lacks onexit() and you are not using an ANSI C +-compiler, then you should compile main.c, s_paus.c, s_stop.c, and +-sig_die.c with NO_ONEXIT defined. See the comments about onexit in +-the makefile. +- +-If your system has a double drem() function such that drem(a,b) +-is the IEEE remainder function (with double a, b), then you may +-wish to compile r_mod.c and d_mod.c with IEEE_drem defined. +-On some systems, you may also need to compile with -Ddrem=remainder . +- +-To check for transmission errors, issue the command +- make check +-This assumes you have the xsum program whose source, xsum.c, +-is distributed as part of "all from f2c/src". If you do not +-have xsum, you can obtain xsum.c by sending the following E-mail +-message to netlib@netlib.bell-labs.com +- send xsum.c from f2c/src +- +-The makefile assumes you have installed f2c.h in a standard +-place (and does not cause recompilation when f2c.h is changed); +-f2c.h comes with "all from f2c" (the source for f2c) and is +-available separately ("f2c.h from f2c"). +- +-Most of the routines in libF77 are support routines for Fortran +-intrinsic functions or for operations that f2c chooses not +-to do "in line". There are a few exceptions, summarized below -- +-functions and subroutines that appear to your program as ordinary +-external Fortran routines. +- +-If you use the REAL valued functions listed below (ERF, ERFC, +-DTIME, and ETIME) with "f2c -R", then you need to compile the +-corresponding source files with -DREAL=float. To do this, it is +-perhaps simplest to add "-DREAL=float" to CFLAGS in the makefile. +- +-1. CALL ABORT prints a message and causes a core dump. +- +-2. ERF(r) and DERF(d) and the REAL and DOUBLE PRECISION +- error functions (with x REAL and d DOUBLE PRECISION); +- DERF must be declared DOUBLE PRECISION in your program. +- Both ERF and DERF assume your C library provides the +- underlying erf() function (which not all systems do). +- +-3. ERFC(r) and DERFC(d) are the complementary error functions: +- ERFC(r) = 1 - ERF(r) and DERFC(d) = 1.d0 - DERFC(d) +- (except that their results may be more accurate than +- explicitly evaluating the above formulae would give). +- Again, ERFC and r are REAL, and DERFC and d are DOUBLE +- PRECISION (and must be declared as such in your program), +- and ERFC and DERFC rely on your system's erfc(). +- +-4. CALL GETARG(n,s), where n is an INTEGER and s is a CHARACTER +- variable, sets s to the n-th command-line argument (or to +- all blanks if there are fewer than n command-line arguments); +- CALL GETARG(0,s) sets s to the name of the program (on systems +- that support this feature). See IARGC below. +- +-5. CALL GETENV(name, value), where name and value are of type +- CHARACTER, sets value to the environment value, $name, of +- name (or to blanks if $name has not been set). +- +-6. NARGS = IARGC() sets NARGS to the number of command-line +- arguments (an INTEGER value). +- +-7. CALL SIGNAL(n,func), where n is an INTEGER and func is an +- EXTERNAL procedure, arranges for func to be invoked when +- signal n occurs (on systems where this makes sense). +- +-8. CALL SYSTEM(cmd), where cmd is of type CHARACTER, passes +- cmd to the system's command processor (on systems where +- this can be done). +- +-If your compiler complains about the signal calls in main.c, s_paus.c, +-and signal_.c, you may need to adjust signal1.h suitably. See the +-comments in signal1.h. +- +-8. ETIME(ARR) and DTIME(ARR) are REAL functions that return +- execution times. ARR is declared REAL ARR(2). The elapsed +- user and system CPU times are stored in ARR(1) and ARR(2), +- respectively. ETIME returns the total elapsed CPU time, +- i.e., ARR(1) + ARR(2). DTIME returns total elapsed CPU +- time since the previous call on DTIME. +- +-9. CALL SYSTEM(cmd), where cmd is of type CHARACTER, passes +- cmd to the system's command processor (on systems where +- this can be done). +- +-The makefile does not attempt to compile pow_qq.c, qbitbits.c, +-and qbitshft.c, which are meant for use with INTEGER*8. To use +-INTEGER*8, you must modify f2c.h to declare longint and ulongint +-appropriately; then add pow_qq.o to the POW = line in the makefile, +-and add " qbitbits.o qbitshft.o" to the makefile's F90BIT = line. +- +-Following Fortran 90, s_cat.c and s_copy.c allow the target of a +-(character string) assignment to be appear on its right-hand, at +-the cost of some extra overhead for all run-time concatenations. +-If you prefer the extra efficiency that comes with the Fortran 77 +-requirement that the left-hand side of a character assignment not +-be involved in the right-hand side, compile s_cat.c and s_copy.c +-with -DNO_OVERWRITE . +- +-If your system lacks a ranlib command, you don't need it. +-Either comment out the makefile's ranlib invocation, or install +-a harmless "ranlib" command somewhere in your PATH, such as the +-one-line shell script +- +- exit 0 +- +-or (on some systems) +- +- exec /usr/bin/ar lts $1 >/dev/null +- +-If your compiler complains about the signal calls in main.c, s_paus.c, +-and signal_.c, you may need to adjust signal1.h suitably. See the +-comments in signal1.h. +- +-By default, the routines that implement complex and double complex +-division, c_div.c and z_div.c, call sig_die to print an error message +-and exit if they see a divisor of 0, as this is sometimes helpful for +-debugging. On systems with IEEE arithmetic, compiling c_div.c and +-z_div.c with -DIEEE_COMPLEX_DIVIDE causes them instead to set both +-the real and imaginary parts of the result to +INFINITY if the +-numerator is nonzero, or to NaN if it vanishes. +- +-The initializations for "f2c -trapuv" are done by _uninit_f2c(), +-whose source is uninit.c, introduced June 2001. On IEEE-arithmetic +-systems, _uninit_f2c should initialize floating-point variables to +-signaling NaNs and, at its first invocation, should enable the +-invalid operation exception. Alas, the rules for distinguishing +-signaling from quiet NaNs were not specified in the IEEE P754 standard, +-nor were the precise means of enabling and disabling IEEE-arithmetic +-exceptions, and these details are thus system dependent. There are +-#ifdef's in uninit.c that specify them for some popular systems. If +-yours is not one of these systems, it may take some detective work to +-discover the appropriate details for your system. Sometimes it helps +-to look in the standard include directories for header files with +-relevant-sounding names, such as ieeefp.h, nan.h, or trap.h, and +-it may be simplest to run experiments to see what distinguishes a +-signaling from a quiet NaN. (If x is initialized to a signaling +-NaN and the invalid operation exception is masked off, as it should +-be by default on IEEE-arithmetic systems, then computing, say, +-y = x + 1 will yield a quiet NaN.) +//GO.SYSIN DD libF77/README +echo libF77/abort_.c 1>&2 +sed >libF77/abort_.c <<'//GO.SYSIN DD libF77/abort_.c' 's/^-//' +-#include "stdio.h" +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-extern VOID sig_die(); +- +-int abort_() +-#else +-extern void sig_die(char*,int); +- +-int abort_(void) +-#endif +-{ +-sig_die("Fortran abort routine called", 1); +-return 0; /* not reached */ +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/abort_.c +echo libF77/c_abs.c 1>&2 +sed >libF77/c_abs.c <<'//GO.SYSIN DD libF77/c_abs.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-extern double f__cabs(); +- +-double c_abs(z) complex *z; +-#else +-extern double f__cabs(double, double); +- +-double c_abs(complex *z) +-#endif +-{ +-return( f__cabs( z->r, z->i ) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/c_abs.c +echo libF77/c_cos.c 1>&2 +sed >libF77/c_cos.c <<'//GO.SYSIN DD libF77/c_cos.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-extern double sin(), cos(), sinh(), cosh(); +- +-VOID c_cos(r, z) complex *r, *z; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-void c_cos(complex *r, complex *z) +-#endif +-{ +- double zi = z->i, zr = z->r; +- r->r = cos(zr) * cosh(zi); +- r->i = - sin(zr) * sinh(zi); +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/c_cos.c +echo libF77/c_div.c 1>&2 +sed >libF77/c_div.c <<'//GO.SYSIN DD libF77/c_div.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-extern VOID sig_die(); +-VOID c_div(c, a, b) +-complex *a, *b, *c; +-#else +-extern void sig_die(char*,int); +-void c_div(complex *c, complex *a, complex *b) +-#endif +-{ +- double ratio, den; +- double abr, abi, cr; +- +- if( (abr = b->r) < 0.) +- abr = - abr; +- if( (abi = b->i) < 0.) +- abi = - abi; +- if( abr <= abi ) +- { +- if(abi == 0) { +-#ifdef IEEE_COMPLEX_DIVIDE +- float af, bf; +- af = bf = abr; +- if (a->i != 0 || a->r != 0) +- af = 1.; +- c->i = c->r = af / bf; +- return; +-#else +- sig_die("complex division by zero", 1); +-#endif +- } +- ratio = (double)b->r / b->i ; +- den = b->i * (1 + ratio*ratio); +- cr = (a->r*ratio + a->i) / den; +- c->i = (a->i*ratio - a->r) / den; +- } +- +- else +- { +- ratio = (double)b->i / b->r ; +- den = b->r * (1 + ratio*ratio); +- cr = (a->r + a->i*ratio) / den; +- c->i = (a->i - a->r*ratio) / den; +- } +- c->r = cr; +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/c_div.c +echo libF77/c_exp.c 1>&2 +sed >libF77/c_exp.c <<'//GO.SYSIN DD libF77/c_exp.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-extern double exp(), cos(), sin(); +- +- VOID c_exp(r, z) complex *r, *z; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-void c_exp(complex *r, complex *z) +-#endif +-{ +- double expx, zi = z->i; +- +- expx = exp(z->r); +- r->r = expx * cos(zi); +- r->i = expx * sin(zi); +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/c_exp.c +echo libF77/c_log.c 1>&2 +sed >libF77/c_log.c <<'//GO.SYSIN DD libF77/c_log.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-extern double log(), f__cabs(), atan2(); +-VOID c_log(r, z) complex *r, *z; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-extern double f__cabs(double, double); +- +-void c_log(complex *r, complex *z) +-#endif +-{ +- double zi, zr; +- r->i = atan2(zi = z->i, zr = z->r); +- r->r = log( f__cabs(zr, zi) ); +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/c_log.c +echo libF77/c_sin.c 1>&2 +sed >libF77/c_sin.c <<'//GO.SYSIN DD libF77/c_sin.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-extern double sin(), cos(), sinh(), cosh(); +- +-VOID c_sin(r, z) complex *r, *z; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-void c_sin(complex *r, complex *z) +-#endif +-{ +- double zi = z->i, zr = z->r; +- r->r = sin(zr) * cosh(zi); +- r->i = cos(zr) * sinh(zi); +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/c_sin.c +echo libF77/c_sqrt.c 1>&2 +sed >libF77/c_sqrt.c <<'//GO.SYSIN DD libF77/c_sqrt.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-extern double sqrt(), f__cabs(); +- +-VOID c_sqrt(r, z) complex *r, *z; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-extern double f__cabs(double, double); +- +-void c_sqrt(complex *r, complex *z) +-#endif +-{ +- double mag, t; +- double zi = z->i, zr = z->r; +- +- if( (mag = f__cabs(zr, zi)) == 0.) +- r->r = r->i = 0.; +- else if(zr > 0) +- { +- r->r = t = sqrt(0.5 * (mag + zr) ); +- t = zi / t; +- r->i = 0.5 * t; +- } +- else +- { +- t = sqrt(0.5 * (mag - zr) ); +- if(zi < 0) +- t = -t; +- r->i = t; +- t = zi / t; +- r->r = 0.5 * t; +- } +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/c_sqrt.c +echo libF77/cabs.c 1>&2 +sed >libF77/cabs.c <<'//GO.SYSIN DD libF77/cabs.c' 's/^-//' +-#ifdef KR_headers +-extern double sqrt(); +-double f__cabs(real, imag) double real, imag; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-double f__cabs(double real, double imag) +-#endif +-{ +-double temp; +- +-if(real < 0) +- real = -real; +-if(imag < 0) +- imag = -imag; +-if(imag > real){ +- temp = real; +- real = imag; +- imag = temp; +-} +-if((real+imag) == real) +- return(real); +- +-temp = imag/real; +-temp = real*sqrt(1.0 + temp*temp); /*overflow!!*/ +-return(temp); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/cabs.c +echo libF77/d_abs.c 1>&2 +sed >libF77/d_abs.c <<'//GO.SYSIN DD libF77/d_abs.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-double d_abs(x) doublereal *x; +-#else +-double d_abs(doublereal *x) +-#endif +-{ +-if(*x >= 0) +- return(*x); +-return(- *x); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/d_abs.c +echo libF77/d_acos.c 1>&2 +sed >libF77/d_acos.c <<'//GO.SYSIN DD libF77/d_acos.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double acos(); +-double d_acos(x) doublereal *x; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-double d_acos(doublereal *x) +-#endif +-{ +-return( acos(*x) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/d_acos.c +echo libF77/d_asin.c 1>&2 +sed >libF77/d_asin.c <<'//GO.SYSIN DD libF77/d_asin.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double asin(); +-double d_asin(x) doublereal *x; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-double d_asin(doublereal *x) +-#endif +-{ +-return( asin(*x) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/d_asin.c +echo libF77/d_atan.c 1>&2 +sed >libF77/d_atan.c <<'//GO.SYSIN DD libF77/d_atan.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double atan(); +-double d_atan(x) doublereal *x; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-double d_atan(doublereal *x) +-#endif +-{ +-return( atan(*x) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/d_atan.c +echo libF77/d_atn2.c 1>&2 +sed >libF77/d_atn2.c <<'//GO.SYSIN DD libF77/d_atn2.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double atan2(); +-double d_atn2(x,y) doublereal *x, *y; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-double d_atn2(doublereal *x, doublereal *y) +-#endif +-{ +-return( atan2(*x,*y) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/d_atn2.c +echo libF77/d_cnjg.c 1>&2 +sed >libF77/d_cnjg.c <<'//GO.SYSIN DD libF77/d_cnjg.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +- VOID +-#ifdef KR_headers +-d_cnjg(r, z) doublecomplex *r, *z; +-#else +-d_cnjg(doublecomplex *r, doublecomplex *z) +-#endif +-{ +- doublereal zi = z->i; +- r->r = z->r; +- r->i = -zi; +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/d_cnjg.c +echo libF77/d_cos.c 1>&2 +sed >libF77/d_cos.c <<'//GO.SYSIN DD libF77/d_cos.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double cos(); +-double d_cos(x) doublereal *x; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-double d_cos(doublereal *x) +-#endif +-{ +-return( cos(*x) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/d_cos.c +echo libF77/d_cosh.c 1>&2 +sed >libF77/d_cosh.c <<'//GO.SYSIN DD libF77/d_cosh.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double cosh(); +-double d_cosh(x) doublereal *x; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-double d_cosh(doublereal *x) +-#endif +-{ +-return( cosh(*x) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/d_cosh.c +echo libF77/d_dim.c 1>&2 +sed >libF77/d_dim.c <<'//GO.SYSIN DD libF77/d_dim.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-double d_dim(a,b) doublereal *a, *b; +-#else +-double d_dim(doublereal *a, doublereal *b) +-#endif +-{ +-return( *a > *b ? *a - *b : 0); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/d_dim.c +echo libF77/d_exp.c 1>&2 +sed >libF77/d_exp.c <<'//GO.SYSIN DD libF77/d_exp.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double exp(); +-double d_exp(x) doublereal *x; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-double d_exp(doublereal *x) +-#endif +-{ +-return( exp(*x) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/d_exp.c +echo libF77/d_imag.c 1>&2 +sed >libF77/d_imag.c <<'//GO.SYSIN DD libF77/d_imag.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-double d_imag(z) doublecomplex *z; +-#else +-double d_imag(doublecomplex *z) +-#endif +-{ +-return(z->i); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/d_imag.c +echo libF77/d_int.c 1>&2 +sed >libF77/d_int.c <<'//GO.SYSIN DD libF77/d_int.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double floor(); +-double d_int(x) doublereal *x; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-double d_int(doublereal *x) +-#endif +-{ +-return( (*x>0) ? floor(*x) : -floor(- *x) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/d_int.c +echo libF77/d_lg10.c 1>&2 +sed >libF77/d_lg10.c <<'//GO.SYSIN DD libF77/d_lg10.c' 's/^-//' +-#include "f2c.h" +- +-#define log10e 0.43429448190325182765 +- +-#ifdef KR_headers +-double log(); +-double d_lg10(x) doublereal *x; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-double d_lg10(doublereal *x) +-#endif +-{ +-return( log10e * log(*x) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/d_lg10.c +echo libF77/d_log.c 1>&2 +sed >libF77/d_log.c <<'//GO.SYSIN DD libF77/d_log.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double log(); +-double d_log(x) doublereal *x; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-double d_log(doublereal *x) +-#endif +-{ +-return( log(*x) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/d_log.c +echo libF77/d_mod.c 1>&2 +sed >libF77/d_mod.c <<'//GO.SYSIN DD libF77/d_mod.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-#ifdef IEEE_drem +-double drem(); +-#else +-double floor(); +-#endif +-double d_mod(x,y) doublereal *x, *y; +-#else +-#ifdef IEEE_drem +-double drem(double, double); +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-#endif +-double d_mod(doublereal *x, doublereal *y) +-#endif +-{ +-#ifdef IEEE_drem +- double xa, ya, z; +- if ((ya = *y) < 0.) +- ya = -ya; +- z = drem(xa = *x, ya); +- if (xa > 0) { +- if (z < 0) +- z += ya; +- } +- else if (z > 0) +- z -= ya; +- return z; +-#else +- double quotient; +- if( (quotient = *x / *y) >= 0) +- quotient = floor(quotient); +- else +- quotient = -floor(-quotient); +- return(*x - (*y) * quotient ); +-#endif +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/d_mod.c +echo libF77/d_nint.c 1>&2 +sed >libF77/d_nint.c <<'//GO.SYSIN DD libF77/d_nint.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double floor(); +-double d_nint(x) doublereal *x; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-double d_nint(doublereal *x) +-#endif +-{ +-return( (*x)>=0 ? +- floor(*x + .5) : -floor(.5 - *x) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/d_nint.c +echo libF77/d_prod.c 1>&2 +sed >libF77/d_prod.c <<'//GO.SYSIN DD libF77/d_prod.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-double d_prod(x,y) real *x, *y; +-#else +-double d_prod(real *x, real *y) +-#endif +-{ +-return( (*x) * (*y) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/d_prod.c +echo libF77/d_sign.c 1>&2 +sed >libF77/d_sign.c <<'//GO.SYSIN DD libF77/d_sign.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-double d_sign(a,b) doublereal *a, *b; +-#else +-double d_sign(doublereal *a, doublereal *b) +-#endif +-{ +-double x; +-x = (*a >= 0 ? *a : - *a); +-return( *b >= 0 ? x : -x); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/d_sign.c +echo libF77/d_sin.c 1>&2 +sed >libF77/d_sin.c <<'//GO.SYSIN DD libF77/d_sin.c' 's/^-//' +-#include "f2c.h" +- +-#ifdef KR_headers +-double sin(); +-double d_sin(x) doublereal *x; +-#else +-#undef abs +-#include "math.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-double d_sin(doublereal *x) +-#endif +-{ +-return( sin(*x) ); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/d_sin.c +echo libF77/s_cat.c 1>&2 +sed >libF77/s_cat.c <<'//GO.SYSIN DD libF77/s_cat.c' 's/^-//' +-/* Unless compiled with -DNO_OVERWRITE, this variant of s_cat allows the +- * target of a concatenation to appear on its right-hand side (contrary +- * to the Fortran 77 Standard, but in accordance with Fortran 90). +- */ +- +-#include "f2c.h" +-#ifndef NO_OVERWRITE +-#include "stdio.h" +-#undef abs +-#ifdef KR_headers +- extern char *F77_aloc(); +- extern void free(); +- extern void exit_(); +-#else +-#undef min +-#undef max +-#include "stdlib.h" +-extern +-#ifdef __cplusplus +- "C" +-#endif +- char *F77_aloc(ftnlen, char*); +-#endif +-#include "string.h" +-#endif /* NO_OVERWRITE */ +- +-#ifdef __cplusplus +-extern "C" { +-#endif +- +- VOID +-#ifdef KR_headers +-s_cat(lp, rpp, rnp, np, ll) char *lp, *rpp[]; ftnint rnp[], *np; ftnlen ll; +-#else +-s_cat(char *lp, char *rpp[], ftnint rnp[], ftnint *np, ftnlen ll) +-#endif +-{ +- ftnlen i, nc; +- char *rp; +- ftnlen n = *np; +-#ifndef NO_OVERWRITE +- ftnlen L, m; +- char *lp0, *lp1; +- +- lp0 = 0; +- lp1 = lp; +- L = ll; +- i = 0; +- while(i < n) { +- rp = rpp[i]; +- m = rnp[i++]; +- if (rp >= lp1 || rp + m <= lp) { +- if ((L -= m) <= 0) { +- n = i; +- break; +- } +- lp1 += m; +- continue; +- } +- lp0 = lp; +- lp = lp1 = F77_aloc(L = ll, "s_cat"); +- break; +- } +- lp1 = lp; +-#endif /* NO_OVERWRITE */ +- for(i = 0 ; i < n ; ++i) { +- nc = ll; +- if(rnp[i] < nc) +- nc = rnp[i]; +- ll -= nc; +- rp = rpp[i]; +- while(--nc >= 0) +- *lp++ = *rp++; +- } +- while(--ll >= 0) +- *lp++ = ' '; +-#ifndef NO_OVERWRITE +- if (lp0) { +- memcpy(lp0, lp1, L); +- free(lp1); +- } +-#endif +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libF77/s_cat.c +echo libF77/Notice 1>&2 +sed >libF77/Notice <<'//GO.SYSIN DD libF77/Notice' 's/^-//' +-/**************************************************************** +-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. +-****************************************************************/ +- +//GO.SYSIN DD libF77/Notice +echo libF77/f2ch.add 1>&2 +sed >libF77/f2ch.add <<'//GO.SYSIN DD libF77/f2ch.add' 's/^-//' +-/* If you are using a C++ compiler, append the following to f2c.h +- for compiling libF77 and libI77. */ +- +-#ifdef __cplusplus +-extern "C" { +-extern int abort_(void); +-extern double c_abs(complex *); +-extern void c_cos(complex *, complex *); +-extern void c_div(complex *, complex *, complex *); +-extern void c_exp(complex *, complex *); +-extern void c_log(complex *, complex *); +-extern void c_sin(complex *, complex *); +-extern void c_sqrt(complex *, complex *); +-extern double d_abs(double *); +-extern double d_acos(double *); +-extern double d_asin(double *); +-extern double d_atan(double *); +-extern double d_atn2(double *, double *); +-extern void d_cnjg(doublecomplex *, doublecomplex *); +-extern double d_cos(double *); +-extern double d_cosh(double *); +-extern double d_dim(double *, double *); +-extern double d_exp(double *); +-extern double d_imag(doublecomplex *); +-extern double d_int(double *); +-extern double d_lg10(double *); +-extern double d_log(double *); +-extern double d_mod(double *, double *); +-extern double d_nint(double *); +-extern double d_prod(float *, float *); +-extern double d_sign(double *, double *); +-extern double d_sin(double *); +-extern double d_sinh(double *); +-extern double d_sqrt(double *); +-extern double d_tan(double *); +-extern double d_tanh(double *); +-extern double derf_(double *); +-extern double derfc_(double *); +-extern integer do_fio(ftnint *, char *, ftnlen); +-extern integer do_lio(ftnint *, ftnint *, char *, ftnlen); +-extern integer do_uio(ftnint *, char *, ftnlen); +-extern integer e_rdfe(void); +-extern integer e_rdue(void); +-extern integer e_rsfe(void); +-extern integer e_rsfi(void); +-extern integer e_rsle(void); +-extern integer e_rsli(void); +-extern integer e_rsue(void); +-extern integer e_wdfe(void); +-extern integer e_wdue(void); +-extern integer e_wsfe(void); +-extern integer e_wsfi(void); +-extern integer e_wsle(void); +-extern integer e_wsli(void); +-extern integer e_wsue(void); +-extern int ef1asc_(ftnint *, ftnlen *, ftnint *, ftnlen *); +-extern integer ef1cmc_(ftnint *, ftnlen *, ftnint *, ftnlen *); +-extern double erf(double); +-extern double erf_(float *); +-extern double erfc(double); +-extern double erfc_(float *); +-extern integer f_back(alist *); +-extern integer f_clos(cllist *); +-extern integer f_end(alist *); +-extern void f_exit(void); +-extern integer f_inqu(inlist *); +-extern integer f_open(olist *); +-extern integer f_rew(alist *); +-extern int flush_(void); +-extern void getarg_(integer *, char *, ftnlen); +-extern void getenv_(char *, char *, ftnlen, ftnlen); +-extern short h_abs(short *); +-extern short h_dim(short *, short *); +-extern short h_dnnt(double *); +-extern short h_indx(char *, char *, ftnlen, ftnlen); +-extern short h_len(char *, ftnlen); +-extern short h_mod(short *, short *); +-extern short h_nint(float *); +-extern short h_sign(short *, short *); +-extern short hl_ge(char *, char *, ftnlen, ftnlen); +-extern short hl_gt(char *, char *, ftnlen, ftnlen); +-extern short hl_le(char *, char *, ftnlen, ftnlen); +-extern short hl_lt(char *, char *, ftnlen, ftnlen); +-extern integer i_abs(integer *); +-extern integer i_dim(integer *, integer *); +-extern integer i_dnnt(double *); +-extern integer i_indx(char *, char *, ftnlen, ftnlen); +-extern integer i_len(char *, ftnlen); +-extern integer i_mod(integer *, integer *); +-extern integer i_nint(float *); +-extern integer i_sign(integer *, integer *); +-extern integer iargc_(void); +-extern ftnlen l_ge(char *, char *, ftnlen, ftnlen); +-extern ftnlen l_gt(char *, char *, ftnlen, ftnlen); +-extern ftnlen l_le(char *, char *, ftnlen, ftnlen); +-extern ftnlen l_lt(char *, char *, ftnlen, ftnlen); +-extern void pow_ci(complex *, complex *, integer *); +-extern double pow_dd(double *, double *); +-extern double pow_di(double *, integer *); +-extern short pow_hh(short *, shortint *); +-extern integer pow_ii(integer *, integer *); +-extern double pow_ri(float *, integer *); +-extern void pow_zi(doublecomplex *, doublecomplex *, integer *); +-extern void pow_zz(doublecomplex *, doublecomplex *, doublecomplex *); +-extern double r_abs(float *); +-extern double r_acos(float *); +-extern double r_asin(float *); +-extern double r_atan(float *); +-extern double r_atn2(float *, float *); +-extern void r_cnjg(complex *, complex *); +-extern double r_cos(float *); +-extern double r_cosh(float *); +-extern double r_dim(float *, float *); +-extern double r_exp(float *); +-extern double r_imag(complex *); +-extern double r_int(float *); +-extern double r_lg10(float *); +-extern double r_log(float *); +-extern double r_mod(float *, float *); +-extern double r_nint(float *); +-extern double r_sign(float *, float *); +-extern double r_sin(float *); +-extern double r_sinh(float *); +-extern double r_sqrt(float *); +-extern double r_tan(float *); +-extern double r_tanh(float *); +-extern void s_cat(char *, char **, integer *, integer *, ftnlen); +-extern integer s_cmp(char *, char *, ftnlen, ftnlen); +-extern void s_copy(char *, char *, ftnlen, ftnlen); +-extern int s_paus(char *, ftnlen); +-extern integer s_rdfe(cilist *); +-extern integer s_rdue(cilist *); +-extern integer s_rnge(char *, integer, char *, integer); +-extern integer s_rsfe(cilist *); +-extern integer s_rsfi(icilist *); +-extern integer s_rsle(cilist *); +-extern integer s_rsli(icilist *); +-extern integer s_rsne(cilist *); +-extern integer s_rsni(icilist *); +-extern integer s_rsue(cilist *); +-extern int s_stop(char *, ftnlen); +-extern integer s_wdfe(cilist *); +-extern integer s_wdue(cilist *); +-extern integer s_wsfe(cilist *); +-extern integer s_wsfi(icilist *); +-extern integer s_wsle(cilist *); +-extern integer s_wsli(icilist *); +-extern integer s_wsne(cilist *); +-extern integer s_wsni(icilist *); +-extern integer s_wsue(cilist *); +-extern void sig_die(char *, int); +-extern integer signal_(integer *, void (*)(int)); +-extern integer system_(char *, ftnlen); +-extern double z_abs(doublecomplex *); +-extern void z_cos(doublecomplex *, doublecomplex *); +-extern void z_div(doublecomplex *, doublecomplex *, doublecomplex *); +-extern void z_exp(doublecomplex *, doublecomplex *); +-extern void z_log(doublecomplex *, doublecomplex *); +-extern void z_sin(doublecomplex *, doublecomplex *); +-extern void z_sqrt(doublecomplex *, doublecomplex *); +- } +-#endif +//GO.SYSIN DD libF77/f2ch.add diff --git a/unix/f2c/libi77 b/unix/f2c/libi77 new file mode 100644 index 00000000..750ee952 --- /dev/null +++ b/unix/f2c/libi77 @@ -0,0 +1,7453 @@ +# to unbundle, sh this file (in an empty directory) +mkdir libI77 +echo libI77/lio.h 1>&2 +sed >libI77/lio.h <<'//GO.SYSIN DD libI77/lio.h' 's/^-//' +-/* copy of ftypes from the compiler */ +-/* variable types +- * numeric assumptions: +- * int < reals < complexes +- * TYDREAL-TYREAL = TYDCOMPLEX-TYCOMPLEX +- */ +- +-/* 0-10 retain their old (pre LOGICAL*1, etc.) */ +-/* values to allow mixing old and new objects. */ +- +-#define TYUNKNOWN 0 +-#define TYADDR 1 +-#define TYSHORT 2 +-#define TYLONG 3 +-#define TYREAL 4 +-#define TYDREAL 5 +-#define TYCOMPLEX 6 +-#define TYDCOMPLEX 7 +-#define TYLOGICAL 8 +-#define TYCHAR 9 +-#define TYSUBR 10 +-#define TYINT1 11 +-#define TYLOGICAL1 12 +-#define TYLOGICAL2 13 +-#ifdef Allow_TYQUAD +-#undef TYQUAD +-#define TYQUAD 14 +-#endif +- +-#define LINTW 24 +-#define LINE 80 +-#define LLOGW 2 +-#ifdef Old_list_output +-#define LLOW 1.0 +-#define LHIGH 1.e9 +-#define LEFMT " %# .8E" +-#define LFFMT " %# .9g" +-#else +-#define LGFMT "%.9G" +-#endif +-/* LEFBL 20 should suffice; 24 overcomes a NeXT bug. */ +-#define LEFBL 24 +- +-typedef union +-{ +- char flchar; +- short flshort; +- ftnint flint; +-#ifdef Allow_TYQUAD +- longint fllongint; +-#endif +- real flreal; +- doublereal fldouble; +-} flex; +-extern int f__scale; +-#ifdef KR_headers +-extern int (*f__lioproc)(), (*l_getc)(), (*l_ungetc)(); +-extern int l_read(), l_write(); +-#else +-#ifdef __cplusplus +-extern "C" { +-#endif +-extern int (*f__lioproc)(ftnint*, char*, ftnlen, ftnint); +-extern int l_write(ftnint*, char*, ftnlen, ftnint); +-extern void x_wsne(cilist*); +-extern int c_le(cilist*), (*l_getc)(void), (*l_ungetc)(int,FILE*); +-extern int l_read(ftnint*,char*,ftnlen,ftnint); +-extern integer e_rsle(void), e_wsle(void), s_wsne(cilist*); +-extern int z_rnew(void); +-#ifdef __cplusplus +- } +-#endif +-#endif +-extern ftnint L_len; +//GO.SYSIN DD libI77/lio.h +echo libI77/lread.c 1>&2 +sed >libI77/lread.c <<'//GO.SYSIN DD libI77/lread.c' 's/^-//' +-#include "f2c.h" +-#include "fio.h" +- +-/* Compile with -DF8X_NML_ELIDE_QUOTES to permit eliding quotation */ +-/* marks in namelist input a la the Fortran 8X Draft published in */ +-/* the May 1989 issue of Fortran Forum. */ +- +- +-extern char *f__fmtbuf; +- +-#ifdef Allow_TYQUAD +-static longint f__llx; +-#endif +- +-#ifdef KR_headers +-extern double atof(); +-extern char *malloc(), *realloc(); +-int (*f__lioproc)(), (*l_getc)(), (*l_ungetc)(); +-#else +-#undef abs +-#undef min +-#undef max +-#include "stdlib.h" +-#endif +- +-#include "fmt.h" +-#include "lio.h" +-#include "ctype.h" +-#include "fp.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifndef KR_headers +-int (*f__lioproc)(ftnint*, char*, ftnlen, ftnint), (*l_getc)(void), +- (*l_ungetc)(int,FILE*); +-#endif +- +-int l_eof; +- +-#define isblnk(x) (f__ltab[x+1]&B) +-#define issep(x) (f__ltab[x+1]&SX) +-#define isapos(x) (f__ltab[x+1]&AX) +-#define isexp(x) (f__ltab[x+1]&EX) +-#define issign(x) (f__ltab[x+1]&SG) +-#define iswhit(x) (f__ltab[x+1]&WH) +-#define SX 1 +-#define B 2 +-#define AX 4 +-#define EX 8 +-#define SG 16 +-#define WH 32 +-char f__ltab[128+1] = { /* offset one for EOF */ +- 0, +- 0,0,AX,0,0,0,0,0,0,WH|B,SX|WH,0,0,0,0,0, +- 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, +- SX|B|WH,0,AX,0,0,0,0,AX,0,0,0,SG,SX,SG,0,SX, +- 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, +- 0,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0, +- 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, +- AX,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0, +- 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 +-}; +- +-#ifdef ungetc +- static int +-#ifdef KR_headers +-un_getc(x,f__cf) int x; FILE *f__cf; +-#else +-un_getc(int x, FILE *f__cf) +-#endif +-{ return ungetc(x,f__cf); } +-#else +-#define un_getc ungetc +-#ifdef KR_headers +- extern int ungetc(); +-#else +-extern int ungetc(int, FILE*); /* for systems with a buggy stdio.h */ +-#endif +-#endif +- +- int +-t_getc(Void) +-{ int ch; +- if(f__curunit->uend) return(EOF); +- if((ch=getc(f__cf))!=EOF) return(ch); +- if(feof(f__cf)) +- f__curunit->uend = l_eof = 1; +- return(EOF); +-} +-integer e_rsle(Void) +-{ +- int ch; +- if(f__curunit->uend) return(0); +- while((ch=t_getc())!='\n') +- if (ch == EOF) { +- if(feof(f__cf)) +- f__curunit->uend = l_eof = 1; +- return EOF; +- } +- return(0); +-} +- +-flag f__lquit; +-int f__lcount,f__ltype,nml_read; +-char *f__lchar; +-double f__lx,f__ly; +-#define ERR(x) if(n=(x)) return(n) +-#define GETC(x) (x=(*l_getc)()) +-#define Ungetc(x,y) (*l_ungetc)(x,y) +- +- static int +-#ifdef KR_headers +-l_R(poststar, reqint) int poststar, reqint; +-#else +-l_R(int poststar, int reqint) +-#endif +-{ +- char s[FMAX+EXPMAXDIGS+4]; +- register int ch; +- register char *sp, *spe, *sp1; +- long e, exp; +- int havenum, havestar, se; +- +- if (!poststar) { +- if (f__lcount > 0) +- return(0); +- f__lcount = 1; +- } +-#ifdef Allow_TYQUAD +- f__llx = 0; +-#endif +- f__ltype = 0; +- exp = 0; +- havestar = 0; +-retry: +- sp1 = sp = s; +- spe = sp + FMAX; +- havenum = 0; +- +- switch(GETC(ch)) { +- case '-': *sp++ = ch; sp1++; spe++; +- case '+': +- GETC(ch); +- } +- while(ch == '0') { +- ++havenum; +- GETC(ch); +- } +- while(isdigit(ch)) { +- if (sp < spe) *sp++ = ch; +- else ++exp; +- GETC(ch); +- } +- if (ch == '*' && !poststar) { +- if (sp == sp1 || exp || *s == '-') { +- errfl(f__elist->cierr,112,"bad repetition count"); +- } +- poststar = havestar = 1; +- *sp = 0; +- f__lcount = atoi(s); +- goto retry; +- } +- if (ch == '.') { +-#ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT +- if (reqint) +- errfl(f__elist->cierr,115,"invalid integer"); +-#endif +- GETC(ch); +- if (sp == sp1) +- while(ch == '0') { +- ++havenum; +- --exp; +- GETC(ch); +- } +- while(isdigit(ch)) { +- if (sp < spe) +- { *sp++ = ch; --exp; } +- GETC(ch); +- } +- } +- havenum += sp - sp1; +- se = 0; +- if (issign(ch)) +- goto signonly; +- if (havenum && isexp(ch)) { +-#ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT +- if (reqint) +- errfl(f__elist->cierr,115,"invalid integer"); +-#endif +- GETC(ch); +- if (issign(ch)) { +-signonly: +- if (ch == '-') se = 1; +- GETC(ch); +- } +- if (!isdigit(ch)) { +-bad: +- errfl(f__elist->cierr,112,"exponent field"); +- } +- +- e = ch - '0'; +- while(isdigit(GETC(ch))) { +- e = 10*e + ch - '0'; +- if (e > EXPMAX) +- goto bad; +- } +- if (se) +- exp -= e; +- else +- exp += e; +- } +- (void) Ungetc(ch, f__cf); +- if (sp > sp1) { +- ++havenum; +- while(*--sp == '0') +- ++exp; +- if (exp) +- sprintf(sp+1, "e%ld", exp); +- else +- sp[1] = 0; +- f__lx = atof(s); +-#ifdef Allow_TYQUAD +- if (reqint&2 && (se = sp - sp1 + exp) > 14 && se < 20) { +- /* Assuming 64-bit longint and 32-bit long. */ +- if (exp < 0) +- sp += exp; +- if (sp1 <= sp) { +- f__llx = *sp1 - '0'; +- while(++sp1 <= sp) +- f__llx = 10*f__llx + (*sp1 - '0'); +- } +- while(--exp >= 0) +- f__llx *= 10; +- if (*s == '-') +- f__llx = -f__llx; +- } +-#endif +- } +- else +- f__lx = 0.; +- if (havenum) +- f__ltype = TYLONG; +- else +- switch(ch) { +- case ',': +- case '/': +- break; +- default: +- if (havestar && ( ch == ' ' +- ||ch == '\t' +- ||ch == '\n')) +- break; +- if (nml_read > 1) { +- f__lquit = 2; +- return 0; +- } +- errfl(f__elist->cierr,112,"invalid number"); +- } +- return 0; +- } +- +- static int +-#ifdef KR_headers +-rd_count(ch) register int ch; +-#else +-rd_count(register int ch) +-#endif +-{ +- if (ch < '0' || ch > '9') +- return 1; +- f__lcount = ch - '0'; +- while(GETC(ch) >= '0' && ch <= '9') +- f__lcount = 10*f__lcount + ch - '0'; +- Ungetc(ch,f__cf); +- return f__lcount <= 0; +- } +- +- static int +-l_C(Void) +-{ int ch, nml_save; +- double lz; +- if(f__lcount>0) return(0); +- f__ltype=0; +- GETC(ch); +- if(ch!='(') +- { +- if (nml_read > 1 && (ch < '0' || ch > '9')) { +- Ungetc(ch,f__cf); +- f__lquit = 2; +- return 0; +- } +- if (rd_count(ch)) +- if(!f__cf || !feof(f__cf)) +- errfl(f__elist->cierr,112,"complex format"); +- else +- err(f__elist->cierr,(EOF),"lread"); +- if(GETC(ch)!='*') +- { +- if(!f__cf || !feof(f__cf)) +- errfl(f__elist->cierr,112,"no star"); +- else +- err(f__elist->cierr,(EOF),"lread"); +- } +- if(GETC(ch)!='(') +- { Ungetc(ch,f__cf); +- return(0); +- } +- } +- else +- f__lcount = 1; +- while(iswhit(GETC(ch))); +- Ungetc(ch,f__cf); +- nml_save = nml_read; +- nml_read = 0; +- if (ch = l_R(1,0)) +- return ch; +- if (!f__ltype) +- errfl(f__elist->cierr,112,"no real part"); +- lz = f__lx; +- while(iswhit(GETC(ch))); +- if(ch!=',') +- { (void) Ungetc(ch,f__cf); +- errfl(f__elist->cierr,112,"no comma"); +- } +- while(iswhit(GETC(ch))); +- (void) Ungetc(ch,f__cf); +- if (ch = l_R(1,0)) +- return ch; +- if (!f__ltype) +- errfl(f__elist->cierr,112,"no imaginary part"); +- while(iswhit(GETC(ch))); +- if(ch!=')') errfl(f__elist->cierr,112,"no )"); +- f__ly = f__lx; +- f__lx = lz; +-#ifdef Allow_TYQUAD +- f__llx = 0; +-#endif +- nml_read = nml_save; +- return(0); +-} +- +- static char nmLbuf[256], *nmL_next; +- static int (*nmL_getc_save)(Void); +-#ifdef KR_headers +- static int (*nmL_ungetc_save)(/* int, FILE* */); +-#else +- static int (*nmL_ungetc_save)(int, FILE*); +-#endif +- +- static int +-nmL_getc(Void) +-{ +- int rv; +- if (rv = *nmL_next++) +- return rv; +- l_getc = nmL_getc_save; +- l_ungetc = nmL_ungetc_save; +- return (*l_getc)(); +- } +- +- static int +-#ifdef KR_headers +-nmL_ungetc(x, f) int x; FILE *f; +-#else +-nmL_ungetc(int x, FILE *f) +-#endif +-{ +- f = f; /* banish non-use warning */ +- return *--nmL_next = x; +- } +- +- static int +-#ifdef KR_headers +-Lfinish(ch, dot, rvp) int ch, dot, *rvp; +-#else +-Lfinish(int ch, int dot, int *rvp) +-#endif +-{ +- char *s, *se; +- static char what[] = "namelist input"; +- +- s = nmLbuf + 2; +- se = nmLbuf + sizeof(nmLbuf) - 1; +- *s++ = ch; +- while(!issep(GETC(ch)) && ch!=EOF) { +- if (s >= se) { +- nmLbuf_ovfl: +- return *rvp = err__fl(f__elist->cierr,131,what); +- } +- *s++ = ch; +- if (ch != '=') +- continue; +- if (dot) +- return *rvp = err__fl(f__elist->cierr,112,what); +- got_eq: +- *s = 0; +- nmL_getc_save = l_getc; +- l_getc = nmL_getc; +- nmL_ungetc_save = l_ungetc; +- l_ungetc = nmL_ungetc; +- nmLbuf[1] = *(nmL_next = nmLbuf) = ','; +- *rvp = f__lcount = 0; +- return 1; +- } +- if (dot) +- goto done; +- for(;;) { +- if (s >= se) +- goto nmLbuf_ovfl; +- *s++ = ch; +- if (!isblnk(ch)) +- break; +- if (GETC(ch) == EOF) +- goto done; +- } +- if (ch == '=') +- goto got_eq; +- done: +- Ungetc(ch, f__cf); +- return 0; +- } +- +- static int +-l_L(Void) +-{ +- int ch, rv, sawdot; +- +- if(f__lcount>0) +- return(0); +- f__lcount = 1; +- f__ltype=0; +- GETC(ch); +- if(isdigit(ch)) +- { +- rd_count(ch); +- if(GETC(ch)!='*') +- if(!f__cf || !feof(f__cf)) +- errfl(f__elist->cierr,112,"no star"); +- else +- err(f__elist->cierr,(EOF),"lread"); +- GETC(ch); +- } +- sawdot = 0; +- if(ch == '.') { +- sawdot = 1; +- GETC(ch); +- } +- switch(ch) +- { +- case 't': +- case 'T': +- if (nml_read && Lfinish(ch, sawdot, &rv)) +- return rv; +- f__lx=1; +- break; +- case 'f': +- case 'F': +- if (nml_read && Lfinish(ch, sawdot, &rv)) +- return rv; +- f__lx=0; +- break; +- default: +- if(isblnk(ch) || issep(ch) || ch==EOF) +- { (void) Ungetc(ch,f__cf); +- return(0); +- } +- if (nml_read > 1) { +- Ungetc(ch,f__cf); +- f__lquit = 2; +- return 0; +- } +- errfl(f__elist->cierr,112,"logical"); +- } +- f__ltype=TYLONG; +- while(!issep(GETC(ch)) && ch!=EOF); +- Ungetc(ch, f__cf); +- return(0); +-} +- +-#define BUFSIZE 128 +- +- static int +-l_CHAR(Void) +-{ int ch,size,i; +- static char rafail[] = "realloc failure"; +- char quote,*p; +- if(f__lcount>0) return(0); +- f__ltype=0; +- if(f__lchar!=NULL) free(f__lchar); +- size=BUFSIZE; +- p=f__lchar = (char *)malloc((unsigned int)size); +- if(f__lchar == NULL) +- errfl(f__elist->cierr,113,"no space"); +- +- GETC(ch); +- if(isdigit(ch)) { +- /* allow Fortran 8x-style unquoted string... */ +- /* either find a repetition count or the string */ +- f__lcount = ch - '0'; +- *p++ = ch; +- for(i = 1;;) { +- switch(GETC(ch)) { +- case '*': +- if (f__lcount == 0) { +- f__lcount = 1; +-#ifndef F8X_NML_ELIDE_QUOTES +- if (nml_read) +- goto no_quote; +-#endif +- goto noquote; +- } +- p = f__lchar; +- goto have_lcount; +- case ',': +- case ' ': +- case '\t': +- case '\n': +- case '/': +- Ungetc(ch,f__cf); +- /* no break */ +- case EOF: +- f__lcount = 1; +- f__ltype = TYCHAR; +- return *p = 0; +- } +- if (!isdigit(ch)) { +- f__lcount = 1; +-#ifndef F8X_NML_ELIDE_QUOTES +- if (nml_read) { +- no_quote: +- errfl(f__elist->cierr,112, +- "undelimited character string"); +- } +-#endif +- goto noquote; +- } +- *p++ = ch; +- f__lcount = 10*f__lcount + ch - '0'; +- if (++i == size) { +- f__lchar = (char *)realloc(f__lchar, +- (unsigned int)(size += BUFSIZE)); +- if(f__lchar == NULL) +- errfl(f__elist->cierr,113,rafail); +- p = f__lchar + i; +- } +- } +- } +- else (void) Ungetc(ch,f__cf); +- have_lcount: +- if(GETC(ch)=='\'' || ch=='"') quote=ch; +- else if(isblnk(ch) || (issep(ch) && ch != '\n') || ch==EOF) { +- Ungetc(ch,f__cf); +- return 0; +- } +-#ifndef F8X_NML_ELIDE_QUOTES +- else if (nml_read > 1) { +- Ungetc(ch,f__cf); +- f__lquit = 2; +- return 0; +- } +-#endif +- else { +- /* Fortran 8x-style unquoted string */ +- *p++ = ch; +- for(i = 1;;) { +- switch(GETC(ch)) { +- case ',': +- case ' ': +- case '\t': +- case '\n': +- case '/': +- Ungetc(ch,f__cf); +- /* no break */ +- case EOF: +- f__ltype = TYCHAR; +- return *p = 0; +- } +- noquote: +- *p++ = ch; +- if (++i == size) { +- f__lchar = (char *)realloc(f__lchar, +- (unsigned int)(size += BUFSIZE)); +- if(f__lchar == NULL) +- errfl(f__elist->cierr,113,rafail); +- p = f__lchar + i; +- } +- } +- } +- f__ltype=TYCHAR; +- for(i=0;;) +- { while(GETC(ch)!=quote && ch!='\n' +- && ch!=EOF && ++i<size) *p++ = ch; +- if(i==size) +- { +- newone: +- f__lchar= (char *)realloc(f__lchar, +- (unsigned int)(size += BUFSIZE)); +- if(f__lchar == NULL) +- errfl(f__elist->cierr,113,rafail); +- p=f__lchar+i-1; +- *p++ = ch; +- } +- else if(ch==EOF) return(EOF); +- else if(ch=='\n') +- { if(*(p-1) != '\\') continue; +- i--; +- p--; +- if(++i<size) *p++ = ch; +- else goto newone; +- } +- else if(GETC(ch)==quote) +- { if(++i<size) *p++ = ch; +- else goto newone; +- } +- else +- { (void) Ungetc(ch,f__cf); +- *p = 0; +- return(0); +- } +- } +-} +- +- int +-#ifdef KR_headers +-c_le(a) cilist *a; +-#else +-c_le(cilist *a) +-#endif +-{ +- if(!f__init) +- f_init(); +- f__fmtbuf="list io"; +- f__curunit = &f__units[a->ciunit]; +- if(a->ciunit>=MXUNIT || a->ciunit<0) +- err(a->cierr,101,"stler"); +- f__scale=f__recpos=0; +- f__elist=a; +- if(f__curunit->ufd==NULL && fk_open(SEQ,FMT,a->ciunit)) +- err(a->cierr,102,"lio"); +- f__cf=f__curunit->ufd; +- if(!f__curunit->ufmt) err(a->cierr,103,"lio") +- return(0); +-} +- +- int +-#ifdef KR_headers +-l_read(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len; +-#else +-l_read(ftnint *number, char *ptr, ftnlen len, ftnint type) +-#endif +-{ +-#define Ptr ((flex *)ptr) +- int i,n,ch; +- doublereal *yy; +- real *xx; +- for(i=0;i<*number;i++) +- { +- if(f__lquit) return(0); +- if(l_eof) +- err(f__elist->ciend, EOF, "list in") +- if(f__lcount == 0) { +- f__ltype = 0; +- for(;;) { +- GETC(ch); +- switch(ch) { +- case EOF: +- err(f__elist->ciend,(EOF),"list in") +- case ' ': +- case '\t': +- case '\n': +- continue; +- case '/': +- f__lquit = 1; +- goto loopend; +- case ',': +- f__lcount = 1; +- goto loopend; +- default: +- (void) Ungetc(ch, f__cf); +- goto rddata; +- } +- } +- } +- rddata: +- switch((int)type) +- { +- case TYINT1: +- case TYSHORT: +- case TYLONG: +-#ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT +- ERR(l_R(0,1)); +- break; +-#endif +- case TYREAL: +- case TYDREAL: +- ERR(l_R(0,0)); +- break; +-#ifdef TYQUAD +- case TYQUAD: +- n = l_R(0,2); +- if (n) +- return n; +- break; +-#endif +- case TYCOMPLEX: +- case TYDCOMPLEX: +- ERR(l_C()); +- break; +- case TYLOGICAL1: +- case TYLOGICAL2: +- case TYLOGICAL: +- ERR(l_L()); +- break; +- case TYCHAR: +- ERR(l_CHAR()); +- break; +- } +- while (GETC(ch) == ' ' || ch == '\t'); +- if (ch != ',' || f__lcount > 1) +- Ungetc(ch,f__cf); +- loopend: +- if(f__lquit) return(0); +- if(f__cf && ferror(f__cf)) { +- clearerr(f__cf); +- errfl(f__elist->cierr,errno,"list in"); +- } +- if(f__ltype==0) goto bump; +- switch((int)type) +- { +- case TYINT1: +- case TYLOGICAL1: +- Ptr->flchar = (char)f__lx; +- break; +- case TYLOGICAL2: +- case TYSHORT: +- Ptr->flshort = (short)f__lx; +- break; +- case TYLOGICAL: +- case TYLONG: +- Ptr->flint = (ftnint)f__lx; +- break; +-#ifdef Allow_TYQUAD +- case TYQUAD: +- if (!(Ptr->fllongint = f__llx)) +- Ptr->fllongint = f__lx; +- break; +-#endif +- case TYREAL: +- Ptr->flreal=f__lx; +- break; +- case TYDREAL: +- Ptr->fldouble=f__lx; +- break; +- case TYCOMPLEX: +- xx=(real *)ptr; +- *xx++ = f__lx; +- *xx = f__ly; +- break; +- case TYDCOMPLEX: +- yy=(doublereal *)ptr; +- *yy++ = f__lx; +- *yy = f__ly; +- break; +- case TYCHAR: +- b_char(f__lchar,ptr,len); +- break; +- } +- bump: +- if(f__lcount>0) f__lcount--; +- ptr += len; +- if (nml_read) +- nml_read++; +- } +- return(0); +-#undef Ptr +-} +-#ifdef KR_headers +-integer s_rsle(a) cilist *a; +-#else +-integer s_rsle(cilist *a) +-#endif +-{ +- int n; +- +- f__reading=1; +- f__external=1; +- f__formatted=1; +- if(n=c_le(a)) return(n); +- f__lioproc = l_read; +- f__lquit = 0; +- f__lcount = 0; +- l_eof = 0; +- if(f__curunit->uwrt && f__nowreading(f__curunit)) +- err(a->cierr,errno,"read start"); +- if(f__curunit->uend) +- err(f__elist->ciend,(EOF),"read start"); +- l_getc = t_getc; +- l_ungetc = un_getc; +- f__doend = xrd_SL; +- return(0); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libI77/lread.c +echo libI77/lwrite.c 1>&2 +sed >libI77/lwrite.c <<'//GO.SYSIN DD libI77/lwrite.c' 's/^-//' +-#include "f2c.h" +-#include "fio.h" +-#include "fmt.h" +-#include "lio.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-ftnint L_len; +-int f__Aquote; +- +- static VOID +-donewrec(Void) +-{ +- if (f__recpos) +- (*f__donewrec)(); +- } +- +- static VOID +-#ifdef KR_headers +-lwrt_I(n) longint n; +-#else +-lwrt_I(longint n) +-#endif +-{ +- char *p; +- int ndigit, sign; +- +- p = f__icvt(n, &ndigit, &sign, 10); +- if(f__recpos + ndigit >= L_len) +- donewrec(); +- PUT(' '); +- if (sign) +- PUT('-'); +- while(*p) +- PUT(*p++); +-} +- static VOID +-#ifdef KR_headers +-lwrt_L(n, len) ftnint n; ftnlen len; +-#else +-lwrt_L(ftnint n, ftnlen len) +-#endif +-{ +- if(f__recpos+LLOGW>=L_len) +- donewrec(); +- wrt_L((Uint *)&n,LLOGW, len); +-} +- static VOID +-#ifdef KR_headers +-lwrt_A(p,len) char *p; ftnlen len; +-#else +-lwrt_A(char *p, ftnlen len) +-#endif +-{ +- int a; +- char *p1, *pe; +- +- a = 0; +- pe = p + len; +- if (f__Aquote) { +- a = 3; +- if (len > 1 && p[len-1] == ' ') { +- while(--len > 1 && p[len-1] == ' '); +- pe = p + len; +- } +- p1 = p; +- while(p1 < pe) +- if (*p1++ == '\'') +- a++; +- } +- if(f__recpos+len+a >= L_len) +- donewrec(); +- if (a +-#ifndef OMIT_BLANK_CC +- || !f__recpos +-#endif +- ) +- PUT(' '); +- if (a) { +- PUT('\''); +- while(p < pe) { +- if (*p == '\'') +- PUT('\''); +- PUT(*p++); +- } +- PUT('\''); +- } +- else +- while(p < pe) +- PUT(*p++); +-} +- +- static int +-#ifdef KR_headers +-l_g(buf, n) char *buf; double n; +-#else +-l_g(char *buf, double n) +-#endif +-{ +-#ifdef Old_list_output +- doublereal absn; +- char *fmt; +- +- absn = n; +- if (absn < 0) +- absn = -absn; +- fmt = LLOW <= absn && absn < LHIGH ? LFFMT : LEFMT; +-#ifdef USE_STRLEN +- sprintf(buf, fmt, n); +- return strlen(buf); +-#else +- return sprintf(buf, fmt, n); +-#endif +- +-#else +- register char *b, c, c1; +- +- b = buf; +- *b++ = ' '; +- if (n < 0) { +- *b++ = '-'; +- n = -n; +- } +- else +- *b++ = ' '; +- if (n == 0) { +-#ifdef SIGNED_ZEROS +- if (signbit_f2c(&n)) +- *b++ = '-'; +-#endif +- *b++ = '0'; +- *b++ = '.'; +- *b = 0; +- goto f__ret; +- } +- sprintf(b, LGFMT, n); +- switch(*b) { +-#ifndef WANT_LEAD_0 +- case '0': +- while(b[0] = b[1]) +- b++; +- break; +-#endif +- case 'i': +- case 'I': +- /* Infinity */ +- case 'n': +- case 'N': +- /* NaN */ +- while(*++b); +- break; +- +- default: +- /* Fortran 77 insists on having a decimal point... */ +- for(;; b++) +- switch(*b) { +- case 0: +- *b++ = '.'; +- *b = 0; +- goto f__ret; +- case '.': +- while(*++b); +- goto f__ret; +- case 'E': +- for(c1 = '.', c = 'E'; *b = c1; +- c1 = c, c = *++b); +- goto f__ret; +- } +- } +- f__ret: +- return b - buf; +-#endif +- } +- +- static VOID +-#ifdef KR_headers +-l_put(s) register char *s; +-#else +-l_put(register char *s) +-#endif +-{ +-#ifdef KR_headers +- register void (*pn)() = f__putn; +-#else +- register void (*pn)(int) = f__putn; +-#endif +- register int c; +- +- while(c = *s++) +- (*pn)(c); +- } +- +- static VOID +-#ifdef KR_headers +-lwrt_F(n) double n; +-#else +-lwrt_F(double n) +-#endif +-{ +- char buf[LEFBL]; +- +- if(f__recpos + l_g(buf,n) >= L_len) +- donewrec(); +- l_put(buf); +-} +- static VOID +-#ifdef KR_headers +-lwrt_C(a,b) double a,b; +-#else +-lwrt_C(double a, double b) +-#endif +-{ +- char *ba, *bb, bufa[LEFBL], bufb[LEFBL]; +- int al, bl; +- +- al = l_g(bufa, a); +- for(ba = bufa; *ba == ' '; ba++) +- --al; +- bl = l_g(bufb, b) + 1; /* intentionally high by 1 */ +- for(bb = bufb; *bb == ' '; bb++) +- --bl; +- if(f__recpos + al + bl + 3 >= L_len) +- donewrec(); +-#ifdef OMIT_BLANK_CC +- else +-#endif +- PUT(' '); +- PUT('('); +- l_put(ba); +- PUT(','); +- if (f__recpos + bl >= L_len) { +- (*f__donewrec)(); +-#ifndef OMIT_BLANK_CC +- PUT(' '); +-#endif +- } +- l_put(bb); +- PUT(')'); +-} +- +- int +-#ifdef KR_headers +-l_write(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len; +-#else +-l_write(ftnint *number, char *ptr, ftnlen len, ftnint type) +-#endif +-{ +-#define Ptr ((flex *)ptr) +- int i; +- longint x; +- double y,z; +- real *xx; +- doublereal *yy; +- for(i=0;i< *number; i++) +- { +- switch((int)type) +- { +- default: f__fatal(117,"unknown type in lio"); +- case TYINT1: +- x = Ptr->flchar; +- goto xint; +- case TYSHORT: +- x=Ptr->flshort; +- goto xint; +-#ifdef Allow_TYQUAD +- case TYQUAD: +- x = Ptr->fllongint; +- goto xint; +-#endif +- case TYLONG: +- x=Ptr->flint; +- xint: lwrt_I(x); +- break; +- case TYREAL: +- y=Ptr->flreal; +- goto xfloat; +- case TYDREAL: +- y=Ptr->fldouble; +- xfloat: lwrt_F(y); +- break; +- case TYCOMPLEX: +- xx= &Ptr->flreal; +- y = *xx++; +- z = *xx; +- goto xcomplex; +- case TYDCOMPLEX: +- yy = &Ptr->fldouble; +- y= *yy++; +- z = *yy; +- xcomplex: +- lwrt_C(y,z); +- break; +- case TYLOGICAL1: +- x = Ptr->flchar; +- goto xlog; +- case TYLOGICAL2: +- x = Ptr->flshort; +- goto xlog; +- case TYLOGICAL: +- x = Ptr->flint; +- xlog: lwrt_L(Ptr->flint, len); +- break; +- case TYCHAR: +- lwrt_A(ptr,len); +- break; +- } +- ptr += len; +- } +- return(0); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libI77/lwrite.c +echo libI77/makefile 1>&2 +sed >libI77/makefile <<'//GO.SYSIN DD libI77/makefile' 's/^-//' +-.SUFFIXES: .c .o +-CC = cc +-CFLAGS = -O +-SHELL = /bin/sh +- +-# compile, then strip unnecessary symbols +-.c.o: +- $(CC) -c -DSkip_f2c_Undefs $(CFLAGS) $*.c +- ld -r -x -o $*.xxx $*.o +- mv $*.xxx $*.o +-## Under Solaris (and other systems that do not understand ld -x), +-## omit -x in the ld line above. +-## If your system does not have the ld command, comment out +-## or remove both the ld and mv lines above. +- +-# To get signed zeros in write statements on IEEE-arithmetic systems, +-# add -DSIGNED_ZEROS to the CFLAGS assignment above and add signbit.o +-# to the end of the "OBJ =" assignment below. Also copy or link +-# libF77/arith.h to this directory (after "make arith.h" if necessary +-# in the libF77 directory). It's simpler to do things all at once +-# with libf2c.zip and its makefile.u. +- +-OBJ = backspace.o close.o dfe.o dolio.o due.o endfile.o err.o fmt.o \ +- fmtlib.o ftell_.o i77vers.o iio.o ilnw.o inquire.o lread.o lwrite.o \ +- open.o rdfmt.o rewind.o rsfe.o rsli.o rsne.o sfe.o sue.o typesize.o \ +- uio.o util.o wref.o wrtfmt.o wsfe.o wsle.o wsne.o xwsne.o +- +-all: sysdep1.h libI77.a +- +-libI77.a: $(OBJ) +- ar r libI77.a $? +- ranlib libI77.a || true +- +-### If your system lacks ranlib, you don't need it; see README. +- +-install: libI77.a +- cp libI77.a $(LIBDIR)/libI77.a +- ranlib $(LIBDIR)/libI77.a || true +- +-# i77vers.c was "Version.c"; renamed on 20010623 to accord with libf2c.zip. +- +-i77vers.o: i77vers.c +- $(CC) -c i77vers.c +- +-# To compile with C++, first "make f2c.h" +-f2c.h: f2ch.add +- cat /usr/include/f2c.h f2ch.add >f2c.h +- +- +-clean: +- rm -f $(OBJ) libI77.a +- +-clobber: clean +- rm -f libI77.a +- +-backspace.o: fio.h +-close.o: fio.h +-dfe.o: fio.h +-dfe.o: fmt.h +-due.o: fio.h +-endfile.o: fio.h rawio.h +-err.o: fio.h rawio.h +-fmt.o: fio.h +-fmt.o: fmt.h +-ftell_.o: fio.h +-ftell64_.o: fio.h +-iio.o: fio.h +-iio.o: fmt.h +-ilnw.o: fio.h +-ilnw.o: lio.h +-inquire.o: fio.h +-lread.o: fio.h +-lread.o: fmt.h +-lread.o: lio.h +-lread.o: fp.h +-lwrite.o: fio.h +-lwrite.o: fmt.h +-lwrite.o: lio.h +-open.o: fio.h rawio.h +-rdfmt.o: fio.h +-rdfmt.o: fmt.h +-rdfmt.o: fp.h +-rewind.o: fio.h +-rsfe.o: fio.h +-rsfe.o: fmt.h +-rsli.o: fio.h +-rsli.o: lio.h +-rsne.o: fio.h +-rsne.o: lio.h +-sfe.o: fio.h +-sue.o: fio.h +-uio.o: fio.h +-util.o: fio.h +-wref.o: fio.h +-wref.o: fmt.h +-wref.o: fp.h +-wrtfmt.o: fio.h +-wrtfmt.o: fmt.h +-wsfe.o: fio.h +-wsfe.o: fmt.h +-wsle.o: fio.h +-wsle.o: fmt.h +-wsle.o: lio.h +-wsne.o: fio.h +-wsne.o: lio.h +-xwsne.o: fio.h +-xwsne.o: lio.h +-xwsne.o: fmt.h +- +-sysdep1.h: sysdep1.h0 +- cp sysdep1.h0 sysdep1.h +- +-check: +- xsum Notice README backspace.c close.c dfe.c dolio.c due.c \ +- endfile.c err.c f2ch.add fio.h fmt.c fmt.h fmtlib.c fp.h ftell_.c \ +- ftell64_.c i77vers.c iio.c ilnw.c inquire.c lio.h lread.c lwrite.c \ +- makefile open.c rawio.h rdfmt.c rewind.c rsfe.c rsli.c rsne.c sfe.c \ +- sue.c typesize.c uio.c util.c wref.c wrtfmt.c wsfe.c wsle.c wsne.c \ +- xwsne.c >zap +- cmp zap libI77.xsum && rm zap || diff libI77.xsum zap +//GO.SYSIN DD libI77/makefile +echo libI77/open.c 1>&2 +sed >libI77/open.c <<'//GO.SYSIN DD libI77/open.c' 's/^-//' +-#include "f2c.h" +-#include "fio.h" +-#include "string.h" +-#ifndef NON_POSIX_STDIO +-#ifdef MSDOS +-#include "io.h" +-#else +-#include "unistd.h" /* for access */ +-#endif +-#endif +- +-#ifdef KR_headers +-extern char *malloc(); +-#ifdef NON_ANSI_STDIO +-extern char *mktemp(); +-#endif +-extern integer f_clos(); +-#else +-#undef abs +-#undef min +-#undef max +-#include "stdlib.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-extern int f__canseek(FILE*); +-extern integer f_clos(cllist*); +-#endif +- +-#ifdef NON_ANSI_RW_MODES +-char *f__r_mode[2] = {"r", "r"}; +-char *f__w_mode[4] = {"w", "w", "r+w", "r+w"}; +-#else +-char *f__r_mode[2] = {"rb", "r"}; +-char *f__w_mode[4] = {"wb", "w", "r+b", "r+"}; +-#endif +- +- static char f__buf0[400], *f__buf = f__buf0; +- int f__buflen = (int)sizeof(f__buf0); +- +- static void +-#ifdef KR_headers +-f__bufadj(n, c) int n, c; +-#else +-f__bufadj(int n, int c) +-#endif +-{ +- unsigned int len; +- char *nbuf, *s, *t, *te; +- +- if (f__buf == f__buf0) +- f__buflen = 1024; +- while(f__buflen <= n) +- f__buflen <<= 1; +- len = (unsigned int)f__buflen; +- if (len != f__buflen || !(nbuf = (char*)malloc(len))) +- f__fatal(113, "malloc failure"); +- s = nbuf; +- t = f__buf; +- te = t + c; +- while(t < te) +- *s++ = *t++; +- if (f__buf != f__buf0) +- free(f__buf); +- f__buf = nbuf; +- } +- +- int +-#ifdef KR_headers +-f__putbuf(c) int c; +-#else +-f__putbuf(int c) +-#endif +-{ +- char *s, *se; +- int n; +- +- if (f__hiwater > f__recpos) +- f__recpos = f__hiwater; +- n = f__recpos + 1; +- if (n >= f__buflen) +- f__bufadj(n, f__recpos); +- s = f__buf; +- se = s + f__recpos; +- if (c) +- *se++ = c; +- *se = 0; +- for(;;) { +- fputs(s, f__cf); +- s += strlen(s); +- if (s >= se) +- break; /* normally happens the first time */ +- putc(*s++, f__cf); +- } +- return 0; +- } +- +- void +-#ifdef KR_headers +-x_putc(c) +-#else +-x_putc(int c) +-#endif +-{ +- if (f__recpos >= f__buflen) +- f__bufadj(f__recpos, f__buflen); +- f__buf[f__recpos++] = c; +- } +- +-#define opnerr(f,m,s) {if(f) errno= m; else opn_err(m,s,a); return(m);} +- +- static void +-#ifdef KR_headers +-opn_err(m, s, a) int m; char *s; olist *a; +-#else +-opn_err(int m, char *s, olist *a) +-#endif +-{ +- if (a->ofnm) { +- /* supply file name to error message */ +- if (a->ofnmlen >= f__buflen) +- f__bufadj((int)a->ofnmlen, 0); +- g_char(a->ofnm, a->ofnmlen, f__curunit->ufnm = f__buf); +- } +- f__fatal(m, s); +- } +- +-#ifdef KR_headers +-integer f_open(a) olist *a; +-#else +-integer f_open(olist *a) +-#endif +-{ unit *b; +- integer rv; +- char buf[256], *s; +- cllist x; +- int ufmt; +- FILE *tf; +-#ifndef NON_UNIX_STDIO +- int n; +-#endif +- f__external = 1; +- if(a->ounit>=MXUNIT || a->ounit<0) +- err(a->oerr,101,"open") +- if (!f__init) +- f_init(); +- f__curunit = b = &f__units[a->ounit]; +- if(b->ufd) { +- if(a->ofnm==0) +- { +- same: if (a->oblnk) +- b->ublnk = *a->oblnk == 'z' || *a->oblnk == 'Z'; +- return(0); +- } +-#ifdef NON_UNIX_STDIO +- if (b->ufnm +- && strlen(b->ufnm) == a->ofnmlen +- && !strncmp(b->ufnm, a->ofnm, (unsigned)a->ofnmlen)) +- goto same; +-#else +- g_char(a->ofnm,a->ofnmlen,buf); +- if (f__inode(buf,&n) == b->uinode && n == b->udev) +- goto same; +-#endif +- x.cunit=a->ounit; +- x.csta=0; +- x.cerr=a->oerr; +- if ((rv = f_clos(&x)) != 0) +- return rv; +- } +- b->url = (int)a->orl; +- b->ublnk = a->oblnk && (*a->oblnk == 'z' || *a->oblnk == 'Z'); +- if(a->ofm==0) +- { if(b->url>0) b->ufmt=0; +- else b->ufmt=1; +- } +- else if(*a->ofm=='f' || *a->ofm == 'F') b->ufmt=1; +- else b->ufmt=0; +- ufmt = b->ufmt; +-#ifdef url_Adjust +- if (b->url && !ufmt) +- url_Adjust(b->url); +-#endif +- if (a->ofnm) { +- g_char(a->ofnm,a->ofnmlen,buf); +- if (!buf[0]) +- opnerr(a->oerr,107,"open") +- } +- else +- sprintf(buf, "fort.%ld", (long)a->ounit); +- b->uscrtch = 0; +- b->uend=0; +- b->uwrt = 0; +- b->ufd = 0; +- b->urw = 3; +- switch(a->osta ? *a->osta : 'u') +- { +- case 'o': +- case 'O': +-#ifdef NON_POSIX_STDIO +- if (!(tf = FOPEN(buf,"r"))) +- opnerr(a->oerr,errno,"open") +- fclose(tf); +-#else +- if (access(buf,0)) +- opnerr(a->oerr,errno,"open") +-#endif +- break; +- case 's': +- case 'S': +- b->uscrtch=1; +-#ifdef NON_ANSI_STDIO +- (void) strcpy(buf,"tmp.FXXXXXX"); +- (void) mktemp(buf); +- goto replace; +-#else +- if (!(b->ufd = tmpfile())) +- opnerr(a->oerr,errno,"open") +- b->ufnm = 0; +-#ifndef NON_UNIX_STDIO +- b->uinode = b->udev = -1; +-#endif +- b->useek = 1; +- return 0; +-#endif +- +- case 'n': +- case 'N': +-#ifdef NON_POSIX_STDIO +- if ((tf = FOPEN(buf,"r")) || (tf = FOPEN(buf,"a"))) { +- fclose(tf); +- opnerr(a->oerr,128,"open") +- } +-#else +- if (!access(buf,0)) +- opnerr(a->oerr,128,"open") +-#endif +- /* no break */ +- case 'r': /* Fortran 90 replace option */ +- case 'R': +-#ifdef NON_ANSI_STDIO +- replace: +-#endif +- if (tf = FOPEN(buf,f__w_mode[0])) +- fclose(tf); +- } +- +- b->ufnm=(char *) malloc((unsigned int)(strlen(buf)+1)); +- if(b->ufnm==NULL) opnerr(a->oerr,113,"no space"); +- (void) strcpy(b->ufnm,buf); +- if ((s = a->oacc) && b->url) +- ufmt = 0; +- if(!(tf = FOPEN(buf, f__w_mode[ufmt|2]))) { +- if (tf = FOPEN(buf, f__r_mode[ufmt])) +- b->urw = 1; +- else if (tf = FOPEN(buf, f__w_mode[ufmt])) { +- b->uwrt = 1; +- b->urw = 2; +- } +- else +- err(a->oerr, errno, "open"); +- } +- b->useek = f__canseek(b->ufd = tf); +-#ifndef NON_UNIX_STDIO +- if((b->uinode = f__inode(buf,&b->udev)) == -1) +- opnerr(a->oerr,108,"open") +-#endif +- if(b->useek) +- if (a->orl) +- rewind(b->ufd); +- else if ((s = a->oacc) && (*s == 'a' || *s == 'A') +- && FSEEK(b->ufd, 0L, SEEK_END)) +- opnerr(a->oerr,129,"open"); +- return(0); +-} +- +- int +-#ifdef KR_headers +-fk_open(seq,fmt,n) ftnint n; +-#else +-fk_open(int seq, int fmt, ftnint n) +-#endif +-{ char nbuf[10]; +- olist a; +- (void) sprintf(nbuf,"fort.%ld",(long)n); +- a.oerr=1; +- a.ounit=n; +- a.ofnm=nbuf; +- a.ofnmlen=strlen(nbuf); +- a.osta=NULL; +- a.oacc= (char*)(seq==SEQ?"s":"d"); +- a.ofm = (char*)(fmt==FMT?"f":"u"); +- a.orl = seq==DIR?1:0; +- a.oblnk=NULL; +- return(f_open(&a)); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libI77/open.c +echo libI77/rawio.h 1>&2 +sed >libI77/rawio.h <<'//GO.SYSIN DD libI77/rawio.h' 's/^-//' +-#ifndef KR_headers +-#ifdef MSDOS +-#include "io.h" +-#ifndef WATCOM +-#define close _close +-#define creat _creat +-#define open _open +-#define read _read +-#define write _write +-#endif /*WATCOM*/ +-#endif /*MSDOS*/ +-#ifdef __cplusplus +-extern "C" { +-#endif +-#ifndef MSDOS +-#ifdef OPEN_DECL +-extern int creat(const char*,int), open(const char*,int); +-#endif +-extern int close(int); +-extern int read(int,void*,size_t), write(int,void*,size_t); +-extern int unlink(const char*); +-#ifndef _POSIX_SOURCE +-#ifndef NON_UNIX_STDIO +-extern FILE *fdopen(int, const char*); +-#endif +-#endif +-#endif /*KR_HEADERS*/ +- +-extern char *mktemp(char*); +- +-#ifdef __cplusplus +- } +-#endif +-#endif +- +-#include "fcntl.h" +- +-#ifndef O_WRONLY +-#define O_RDONLY 0 +-#define O_WRONLY 1 +-#endif +//GO.SYSIN DD libI77/rawio.h +echo libI77/rdfmt.c 1>&2 +sed >libI77/rdfmt.c <<'//GO.SYSIN DD libI77/rdfmt.c' 's/^-//' +-#include "f2c.h" +-#include "fio.h" +- +-#ifdef KR_headers +-extern double atof(); +-#else +-#undef abs +-#undef min +-#undef max +-#include "stdlib.h" +-#endif +- +-#include "fmt.h" +-#include "fp.h" +-#include "ctype.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +- static int +-#ifdef KR_headers +-rd_Z(n,w,len) Uint *n; ftnlen len; +-#else +-rd_Z(Uint *n, int w, ftnlen len) +-#endif +-{ +- long x[9]; +- char *s, *s0, *s1, *se, *t; +- int ch, i, w1, w2; +- static char hex[256]; +- static int one = 1; +- int bad = 0; +- +- if (!hex['0']) { +- s = "0123456789"; +- while(ch = *s++) +- hex[ch] = ch - '0' + 1; +- s = "ABCDEF"; +- while(ch = *s++) +- hex[ch] = hex[ch + 'a' - 'A'] = ch - 'A' + 11; +- } +- s = s0 = (char *)x; +- s1 = (char *)&x[4]; +- se = (char *)&x[8]; +- if (len > 4*sizeof(long)) +- return errno = 117; +- while (w) { +- GET(ch); +- if (ch==',' || ch=='\n') +- break; +- w--; +- if (ch > ' ') { +- if (!hex[ch & 0xff]) +- bad++; +- *s++ = ch; +- if (s == se) { +- /* discard excess characters */ +- for(t = s0, s = s1; t < s1;) +- *t++ = *s++; +- s = s1; +- } +- } +- } +- if (bad) +- return errno = 115; +- w = (int)len; +- w1 = s - s0; +- w2 = w1+1 >> 1; +- t = (char *)n; +- if (*(char *)&one) { +- /* little endian */ +- t += w - 1; +- i = -1; +- } +- else +- i = 1; +- for(; w > w2; t += i, --w) +- *t = 0; +- if (!w) +- return 0; +- if (w < w2) +- s0 = s - (w << 1); +- else if (w1 & 1) { +- *t = hex[*s0++ & 0xff] - 1; +- if (!--w) +- return 0; +- t += i; +- } +- do { +- *t = hex[*s0 & 0xff]-1 << 4 | hex[s0[1] & 0xff]-1; +- t += i; +- s0 += 2; +- } +- while(--w); +- return 0; +- } +- +- static int +-#ifdef KR_headers +-rd_I(n,w,len, base) Uint *n; int w; ftnlen len; register int base; +-#else +-rd_I(Uint *n, int w, ftnlen len, register int base) +-#endif +-{ +- int ch, sign; +- longint x = 0; +- +- if (w <= 0) +- goto have_x; +- for(;;) { +- GET(ch); +- if (ch != ' ') +- break; +- if (!--w) +- goto have_x; +- } +- sign = 0; +- switch(ch) { +- case ',': +- case '\n': +- w = 0; +- goto have_x; +- case '-': +- sign = 1; +- case '+': +- break; +- default: +- if (ch >= '0' && ch <= '9') { +- x = ch - '0'; +- break; +- } +- goto have_x; +- } +- while(--w) { +- GET(ch); +- if (ch >= '0' && ch <= '9') { +- x = x*base + ch - '0'; +- continue; +- } +- if (ch != ' ') { +- if (ch == '\n' || ch == ',') +- w = 0; +- break; +- } +- if (f__cblank) +- x *= base; +- } +- if (sign) +- x = -x; +- have_x: +- if(len == sizeof(integer)) +- n->il=x; +- else if(len == sizeof(char)) +- n->ic = (char)x; +-#ifdef Allow_TYQUAD +- else if (len == sizeof(longint)) +- n->ili = x; +-#endif +- else +- n->is = (short)x; +- if (w) { +- while(--w) +- GET(ch); +- return errno = 115; +- } +- return 0; +-} +- +- static int +-#ifdef KR_headers +-rd_L(n,w,len) ftnint *n; ftnlen len; +-#else +-rd_L(ftnint *n, int w, ftnlen len) +-#endif +-{ int ch, dot, lv; +- +- if (w <= 0) +- goto bad; +- for(;;) { +- GET(ch); +- --w; +- if (ch != ' ') +- break; +- if (!w) +- goto bad; +- } +- dot = 0; +- retry: +- switch(ch) { +- case '.': +- if (dot++ || !w) +- goto bad; +- GET(ch); +- --w; +- goto retry; +- case 't': +- case 'T': +- lv = 1; +- break; +- case 'f': +- case 'F': +- lv = 0; +- break; +- default: +- bad: +- for(; w > 0; --w) +- GET(ch); +- /* no break */ +- case ',': +- case '\n': +- return errno = 116; +- } +- switch(len) { +- case sizeof(char): *(char *)n = (char)lv; break; +- case sizeof(short): *(short *)n = (short)lv; break; +- default: *n = lv; +- } +- while(w-- > 0) { +- GET(ch); +- if (ch == ',' || ch == '\n') +- break; +- } +- return 0; +-} +- +- static int +-#ifdef KR_headers +-rd_F(p, w, d, len) ufloat *p; ftnlen len; +-#else +-rd_F(ufloat *p, int w, int d, ftnlen len) +-#endif +-{ +- char s[FMAX+EXPMAXDIGS+4]; +- register int ch; +- register char *sp, *spe, *sp1; +- double x; +- int scale1, se; +- long e, exp; +- +- sp1 = sp = s; +- spe = sp + FMAX; +- exp = -d; +- x = 0.; +- +- do { +- GET(ch); +- w--; +- } while (ch == ' ' && w); +- switch(ch) { +- case '-': *sp++ = ch; sp1++; spe++; +- case '+': +- if (!w) goto zero; +- --w; +- GET(ch); +- } +- while(ch == ' ') { +-blankdrop: +- if (!w--) goto zero; GET(ch); } +- while(ch == '0') +- { if (!w--) goto zero; GET(ch); } +- if (ch == ' ' && f__cblank) +- goto blankdrop; +- scale1 = f__scale; +- while(isdigit(ch)) { +-digloop1: +- if (sp < spe) *sp++ = ch; +- else ++exp; +-digloop1e: +- if (!w--) goto done; +- GET(ch); +- } +- if (ch == ' ') { +- if (f__cblank) +- { ch = '0'; goto digloop1; } +- goto digloop1e; +- } +- if (ch == '.') { +- exp += d; +- if (!w--) goto done; +- GET(ch); +- if (sp == sp1) { /* no digits yet */ +- while(ch == '0') { +-skip01: +- --exp; +-skip0: +- if (!w--) goto done; +- GET(ch); +- } +- if (ch == ' ') { +- if (f__cblank) goto skip01; +- goto skip0; +- } +- } +- while(isdigit(ch)) { +-digloop2: +- if (sp < spe) +- { *sp++ = ch; --exp; } +-digloop2e: +- if (!w--) goto done; +- GET(ch); +- } +- if (ch == ' ') { +- if (f__cblank) +- { ch = '0'; goto digloop2; } +- goto digloop2e; +- } +- } +- switch(ch) { +- default: +- break; +- case '-': se = 1; goto signonly; +- case '+': se = 0; goto signonly; +- case 'e': +- case 'E': +- case 'd': +- case 'D': +- if (!w--) +- goto bad; +- GET(ch); +- while(ch == ' ') { +- if (!w--) +- goto bad; +- GET(ch); +- } +- se = 0; +- switch(ch) { +- case '-': se = 1; +- case '+': +-signonly: +- if (!w--) +- goto bad; +- GET(ch); +- } +- while(ch == ' ') { +- if (!w--) +- goto bad; +- GET(ch); +- } +- if (!isdigit(ch)) +- goto bad; +- +- e = ch - '0'; +- for(;;) { +- if (!w--) +- { ch = '\n'; break; } +- GET(ch); +- if (!isdigit(ch)) { +- if (ch == ' ') { +- if (f__cblank) +- ch = '0'; +- else continue; +- } +- else +- break; +- } +- e = 10*e + ch - '0'; +- if (e > EXPMAX && sp > sp1) +- goto bad; +- } +- if (se) +- exp -= e; +- else +- exp += e; +- scale1 = 0; +- } +- switch(ch) { +- case '\n': +- case ',': +- break; +- default: +-bad: +- return (errno = 115); +- } +-done: +- if (sp > sp1) { +- while(*--sp == '0') +- ++exp; +- if (exp -= scale1) +- sprintf(sp+1, "e%ld", exp); +- else +- sp[1] = 0; +- x = atof(s); +- } +-zero: +- if (len == sizeof(real)) +- p->pf = x; +- else +- p->pd = x; +- return(0); +- } +- +- +- static int +-#ifdef KR_headers +-rd_A(p,len) char *p; ftnlen len; +-#else +-rd_A(char *p, ftnlen len) +-#endif +-{ int i,ch; +- for(i=0;i<len;i++) +- { GET(ch); +- *p++=VAL(ch); +- } +- return(0); +-} +- static int +-#ifdef KR_headers +-rd_AW(p,w,len) char *p; ftnlen len; +-#else +-rd_AW(char *p, int w, ftnlen len) +-#endif +-{ int i,ch; +- if(w>=len) +- { for(i=0;i<w-len;i++) +- GET(ch); +- for(i=0;i<len;i++) +- { GET(ch); +- *p++=VAL(ch); +- } +- return(0); +- } +- for(i=0;i<w;i++) +- { GET(ch); +- *p++=VAL(ch); +- } +- for(i=0;i<len-w;i++) *p++=' '; +- return(0); +-} +- static int +-#ifdef KR_headers +-rd_H(n,s) char *s; +-#else +-rd_H(int n, char *s) +-#endif +-{ int i,ch; +- for(i=0;i<n;i++) +- if((ch=(*f__getn)())<0) return(ch); +- else *s++ = ch=='\n'?' ':ch; +- return(1); +-} +- static int +-#ifdef KR_headers +-rd_POS(s) char *s; +-#else +-rd_POS(char *s) +-#endif +-{ char quote; +- int ch; +- quote= *s++; +- for(;*s;s++) +- if(*s==quote && *(s+1)!=quote) break; +- else if((ch=(*f__getn)())<0) return(ch); +- else *s = ch=='\n'?' ':ch; +- return(1); +-} +- +- int +-#ifdef KR_headers +-rd_ed(p,ptr,len) struct syl *p; char *ptr; ftnlen len; +-#else +-rd_ed(struct syl *p, char *ptr, ftnlen len) +-#endif +-{ int ch; +- for(;f__cursor>0;f__cursor--) if((ch=(*f__getn)())<0) return(ch); +- if(f__cursor<0) +- { if(f__recpos+f__cursor < 0) /*err(elist->cierr,110,"fmt")*/ +- f__cursor = -f__recpos; /* is this in the standard? */ +- if(f__external == 0) { +- extern char *f__icptr; +- f__icptr += f__cursor; +- } +- else if(f__curunit && f__curunit->useek) +- (void) FSEEK(f__cf, f__cursor,SEEK_CUR); +- else +- err(f__elist->cierr,106,"fmt"); +- f__recpos += f__cursor; +- f__cursor=0; +- } +- switch(p->op) +- { +- default: fprintf(stderr,"rd_ed, unexpected code: %d\n", p->op); +- sig_die(f__fmtbuf, 1); +- case IM: +- case I: ch = rd_I((Uint *)ptr,p->p1,len, 10); +- break; +- +- /* O and OM don't work right for character, double, complex, */ +- /* or doublecomplex, and they differ from Fortran 90 in */ +- /* showing a minus sign for negative values. */ +- +- case OM: +- case O: ch = rd_I((Uint *)ptr, p->p1, len, 8); +- break; +- case L: ch = rd_L((ftnint *)ptr,p->p1,len); +- break; +- case A: ch = rd_A(ptr,len); +- break; +- case AW: +- ch = rd_AW(ptr,p->p1,len); +- break; +- case E: case EE: +- case D: +- case G: +- case GE: +- case F: ch = rd_F((ufloat *)ptr,p->p1,p->p2.i[0],len); +- break; +- +- /* Z and ZM assume 8-bit bytes. */ +- +- case ZM: +- case Z: +- ch = rd_Z((Uint *)ptr, p->p1, len); +- break; +- } +- if(ch == 0) return(ch); +- else if(ch == EOF) return(EOF); +- if (f__cf) +- clearerr(f__cf); +- return(errno); +-} +- +- int +-#ifdef KR_headers +-rd_ned(p) struct syl *p; +-#else +-rd_ned(struct syl *p) +-#endif +-{ +- switch(p->op) +- { +- default: fprintf(stderr,"rd_ned, unexpected code: %d\n", p->op); +- sig_die(f__fmtbuf, 1); +- case APOS: +- return(rd_POS(p->p2.s)); +- case H: return(rd_H(p->p1,p->p2.s)); +- case SLASH: return((*f__donewrec)()); +- case TR: +- case X: f__cursor += p->p1; +- return(1); +- case T: f__cursor=p->p1-f__recpos - 1; +- return(1); +- case TL: f__cursor -= p->p1; +- if(f__cursor < -f__recpos) /* TL1000, 1X */ +- f__cursor = -f__recpos; +- return(1); +- } +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libI77/rdfmt.c +echo libI77/rewind.c 1>&2 +sed >libI77/rewind.c <<'//GO.SYSIN DD libI77/rewind.c' 's/^-//' +-#include "f2c.h" +-#include "fio.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-#ifdef KR_headers +-integer f_rew(a) alist *a; +-#else +-integer f_rew(alist *a) +-#endif +-{ +- unit *b; +- if(a->aunit>=MXUNIT || a->aunit<0) +- err(a->aerr,101,"rewind"); +- b = &f__units[a->aunit]; +- if(b->ufd == NULL || b->uwrt == 3) +- return(0); +- if(!b->useek) +- err(a->aerr,106,"rewind") +- if(b->uwrt) { +- (void) t_runc(a); +- b->uwrt = 3; +- } +- rewind(b->ufd); +- b->uend=0; +- return(0); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libI77/rewind.c +echo libI77/rsfe.c 1>&2 +sed >libI77/rsfe.c <<'//GO.SYSIN DD libI77/rsfe.c' 's/^-//' +-/* read sequential formatted external */ +-#include "f2c.h" +-#include "fio.h" +-#include "fmt.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +- int +-xrd_SL(Void) +-{ int ch; +- if(!f__curunit->uend) +- while((ch=getc(f__cf))!='\n') +- if (ch == EOF) { +- f__curunit->uend = 1; +- break; +- } +- f__cursor=f__recpos=0; +- return(1); +-} +- +- int +-x_getc(Void) +-{ int ch; +- if(f__curunit->uend) return(EOF); +- ch = getc(f__cf); +- if(ch!=EOF && ch!='\n') +- { f__recpos++; +- return(ch); +- } +- if(ch=='\n') +- { (void) ungetc(ch,f__cf); +- return(ch); +- } +- if(f__curunit->uend || feof(f__cf)) +- { errno=0; +- f__curunit->uend=1; +- return(-1); +- } +- return(-1); +-} +- +- int +-x_endp(Void) +-{ +- xrd_SL(); +- return f__curunit->uend == 1 ? EOF : 0; +-} +- +- int +-x_rev(Void) +-{ +- (void) xrd_SL(); +- return(0); +-} +-#ifdef KR_headers +-integer s_rsfe(a) cilist *a; /* start */ +-#else +-integer s_rsfe(cilist *a) /* start */ +-#endif +-{ int n; +- if(!f__init) f_init(); +- f__reading=1; +- f__sequential=1; +- f__formatted=1; +- f__external=1; +- if(n=c_sfe(a)) return(n); +- f__elist=a; +- f__cursor=f__recpos=0; +- f__scale=0; +- f__fmtbuf=a->cifmt; +- f__cf=f__curunit->ufd; +- if(pars_f(f__fmtbuf)<0) err(a->cierr,100,"startio"); +- f__getn= x_getc; +- f__doed= rd_ed; +- f__doned= rd_ned; +- fmt_bg(); +- f__doend=x_endp; +- f__donewrec=xrd_SL; +- f__dorevert=x_rev; +- f__cblank=f__curunit->ublnk; +- f__cplus=0; +- if(f__curunit->uwrt && f__nowreading(f__curunit)) +- err(a->cierr,errno,"read start"); +- if(f__curunit->uend) +- err(f__elist->ciend,(EOF),"read start"); +- return(0); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libI77/rsfe.c +echo libI77/rsli.c 1>&2 +sed >libI77/rsli.c <<'//GO.SYSIN DD libI77/rsli.c' 's/^-//' +-#include "f2c.h" +-#include "fio.h" +-#include "lio.h" +-#include "fmt.h" /* for f__doend */ +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-extern flag f__lquit; +-extern int f__lcount; +-extern char *f__icptr; +-extern char *f__icend; +-extern icilist *f__svic; +-extern int f__icnum, f__recpos; +- +-static int i_getc(Void) +-{ +- if(f__recpos >= f__svic->icirlen) { +- if (f__recpos++ == f__svic->icirlen) +- return '\n'; +- z_rnew(); +- } +- f__recpos++; +- if(f__icptr >= f__icend) +- return EOF; +- return(*f__icptr++); +- } +- +- static +-#ifdef KR_headers +-int i_ungetc(ch, f) int ch; FILE *f; +-#else +-int i_ungetc(int ch, FILE *f) +-#endif +-{ +- if (--f__recpos == f__svic->icirlen) +- return '\n'; +- if (f__recpos < -1) +- err(f__svic->icierr,110,"recend"); +- /* *--icptr == ch, and icptr may point to read-only memory */ +- return *--f__icptr /* = ch */; +- } +- +- static void +-#ifdef KR_headers +-c_lir(a) icilist *a; +-#else +-c_lir(icilist *a) +-#endif +-{ +- extern int l_eof; +- f__reading = 1; +- f__external = 0; +- f__formatted = 1; +- f__svic = a; +- L_len = a->icirlen; +- f__recpos = -1; +- f__icnum = f__recpos = 0; +- f__cursor = 0; +- l_getc = i_getc; +- l_ungetc = i_ungetc; +- l_eof = 0; +- f__icptr = a->iciunit; +- f__icend = f__icptr + a->icirlen*a->icirnum; +- f__cf = 0; +- f__curunit = 0; +- f__elist = (cilist *)a; +- } +- +- +-#ifdef KR_headers +-integer s_rsli(a) icilist *a; +-#else +-integer s_rsli(icilist *a) +-#endif +-{ +- f__lioproc = l_read; +- f__lquit = 0; +- f__lcount = 0; +- c_lir(a); +- f__doend = 0; +- return(0); +- } +- +-integer e_rsli(Void) +-{ return 0; } +- +-#ifdef KR_headers +-integer s_rsni(a) icilist *a; +-#else +-extern int x_rsne(cilist*); +- +-integer s_rsni(icilist *a) +-#endif +-{ +- extern int nml_read; +- integer rv; +- cilist ca; +- ca.ciend = a->iciend; +- ca.cierr = a->icierr; +- ca.cifmt = a->icifmt; +- c_lir(a); +- rv = x_rsne(&ca); +- nml_read = 0; +- return rv; +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libI77/rsli.c +echo libI77/rsne.c 1>&2 +sed >libI77/rsne.c <<'//GO.SYSIN DD libI77/rsne.c' 's/^-//' +-#include "f2c.h" +-#include "fio.h" +-#include "lio.h" +- +-#define MAX_NL_CACHE 3 /* maximum number of namelist hash tables to cache */ +-#define MAXDIM 20 /* maximum number of subscripts */ +- +- struct dimen { +- ftnlen extent; +- ftnlen curval; +- ftnlen delta; +- ftnlen stride; +- }; +- typedef struct dimen dimen; +- +- struct hashentry { +- struct hashentry *next; +- char *name; +- Vardesc *vd; +- }; +- typedef struct hashentry hashentry; +- +- struct hashtab { +- struct hashtab *next; +- Namelist *nl; +- int htsize; +- hashentry *tab[1]; +- }; +- typedef struct hashtab hashtab; +- +- static hashtab *nl_cache; +- static int n_nlcache; +- static hashentry **zot; +- static int colonseen; +- extern ftnlen f__typesize[]; +- +- extern flag f__lquit; +- extern int f__lcount, nml_read; +- extern int t_getc(Void); +- +-#ifdef KR_headers +- extern char *malloc(), *memset(); +- +-#ifdef ungetc +- static int +-un_getc(x,f__cf) int x; FILE *f__cf; +-{ return ungetc(x,f__cf); } +-#else +-#define un_getc ungetc +- extern int ungetc(); +-#endif +- +-#else +-#undef abs +-#undef min +-#undef max +-#include "stdlib.h" +-#include "string.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef ungetc +- static int +-un_getc(int x, FILE *f__cf) +-{ return ungetc(x,f__cf); } +-#else +-#define un_getc ungetc +-extern int ungetc(int, FILE*); /* for systems with a buggy stdio.h */ +-#endif +-#endif +- +- static Vardesc * +-#ifdef KR_headers +-hash(ht, s) hashtab *ht; register char *s; +-#else +-hash(hashtab *ht, register char *s) +-#endif +-{ +- register int c, x; +- register hashentry *h; +- char *s0 = s; +- +- for(x = 0; c = *s++; x = x & 0x4000 ? ((x << 1) & 0x7fff) + 1 : x << 1) +- x += c; +- for(h = *(zot = ht->tab + x % ht->htsize); h; h = h->next) +- if (!strcmp(s0, h->name)) +- return h->vd; +- return 0; +- } +- +- hashtab * +-#ifdef KR_headers +-mk_hashtab(nl) Namelist *nl; +-#else +-mk_hashtab(Namelist *nl) +-#endif +-{ +- int nht, nv; +- hashtab *ht; +- Vardesc *v, **vd, **vde; +- hashentry *he; +- +- hashtab **x, **x0, *y; +- for(x = &nl_cache; y = *x; x0 = x, x = &y->next) +- if (nl == y->nl) +- return y; +- if (n_nlcache >= MAX_NL_CACHE) { +- /* discard least recently used namelist hash table */ +- y = *x0; +- free((char *)y->next); +- y->next = 0; +- } +- else +- n_nlcache++; +- nv = nl->nvars; +- if (nv >= 0x4000) +- nht = 0x7fff; +- else { +- for(nht = 1; nht < nv; nht <<= 1); +- nht += nht - 1; +- } +- ht = (hashtab *)malloc(sizeof(hashtab) + (nht-1)*sizeof(hashentry *) +- + nv*sizeof(hashentry)); +- if (!ht) +- return 0; +- he = (hashentry *)&ht->tab[nht]; +- ht->nl = nl; +- ht->htsize = nht; +- ht->next = nl_cache; +- nl_cache = ht; +- memset((char *)ht->tab, 0, nht*sizeof(hashentry *)); +- vd = nl->vars; +- vde = vd + nv; +- while(vd < vde) { +- v = *vd++; +- if (!hash(ht, v->name)) { +- he->next = *zot; +- *zot = he; +- he->name = v->name; +- he->vd = v; +- he++; +- } +- } +- return ht; +- } +- +-static char Alpha[256], Alphanum[256]; +- +- static VOID +-nl_init(Void) { +- register char *s; +- register int c; +- +- if(!f__init) +- f_init(); +- for(s = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; c = *s++; ) +- Alpha[c] +- = Alphanum[c] +- = Alpha[c + 'a' - 'A'] +- = Alphanum[c + 'a' - 'A'] +- = c; +- for(s = "0123456789_"; c = *s++; ) +- Alphanum[c] = c; +- } +- +-#define GETC(x) (x=(*l_getc)()) +-#define Ungetc(x,y) (*l_ungetc)(x,y) +- +- static int +-#ifdef KR_headers +-getname(s, slen) register char *s; int slen; +-#else +-getname(register char *s, int slen) +-#endif +-{ +- register char *se = s + slen - 1; +- register int ch; +- +- GETC(ch); +- if (!(*s++ = Alpha[ch & 0xff])) { +- if (ch != EOF) +- ch = 115; +- errfl(f__elist->cierr, ch, "namelist read"); +- } +- while(*s = Alphanum[GETC(ch) & 0xff]) +- if (s < se) +- s++; +- if (ch == EOF) +- err(f__elist->cierr, EOF, "namelist read"); +- if (ch > ' ') +- Ungetc(ch,f__cf); +- return *s = 0; +- } +- +- static int +-#ifdef KR_headers +-getnum(chp, val) int *chp; ftnlen *val; +-#else +-getnum(int *chp, ftnlen *val) +-#endif +-{ +- register int ch, sign; +- register ftnlen x; +- +- while(GETC(ch) <= ' ' && ch >= 0); +- if (ch == '-') { +- sign = 1; +- GETC(ch); +- } +- else { +- sign = 0; +- if (ch == '+') +- GETC(ch); +- } +- x = ch - '0'; +- if (x < 0 || x > 9) +- return 115; +- while(GETC(ch) >= '0' && ch <= '9') +- x = 10*x + ch - '0'; +- while(ch <= ' ' && ch >= 0) +- GETC(ch); +- if (ch == EOF) +- return EOF; +- *val = sign ? -x : x; +- *chp = ch; +- return 0; +- } +- +- static int +-#ifdef KR_headers +-getdimen(chp, d, delta, extent, x1) +- int *chp; dimen *d; ftnlen delta, extent, *x1; +-#else +-getdimen(int *chp, dimen *d, ftnlen delta, ftnlen extent, ftnlen *x1) +-#endif +-{ +- register int k; +- ftnlen x2, x3; +- +- if (k = getnum(chp, x1)) +- return k; +- x3 = 1; +- if (*chp == ':') { +- if (k = getnum(chp, &x2)) +- return k; +- x2 -= *x1; +- if (*chp == ':') { +- if (k = getnum(chp, &x3)) +- return k; +- if (!x3) +- return 123; +- x2 /= x3; +- colonseen = 1; +- } +- if (x2 < 0 || x2 >= extent) +- return 123; +- d->extent = x2 + 1; +- } +- else +- d->extent = 1; +- d->curval = 0; +- d->delta = delta; +- d->stride = x3; +- return 0; +- } +- +-#ifndef No_Namelist_Questions +- static Void +-#ifdef KR_headers +-print_ne(a) cilist *a; +-#else +-print_ne(cilist *a) +-#endif +-{ +- flag intext = f__external; +- int rpsave = f__recpos; +- FILE *cfsave = f__cf; +- unit *usave = f__curunit; +- cilist t; +- t = *a; +- t.ciunit = 6; +- s_wsne(&t); +- fflush(f__cf); +- f__external = intext; +- f__reading = 1; +- f__recpos = rpsave; +- f__cf = cfsave; +- f__curunit = usave; +- f__elist = a; +- } +-#endif +- +- static char where0[] = "namelist read start "; +- +- int +-#ifdef KR_headers +-x_rsne(a) cilist *a; +-#else +-x_rsne(cilist *a) +-#endif +-{ +- int ch, got1, k, n, nd, quote, readall; +- Namelist *nl; +- static char where[] = "namelist read"; +- char buf[64]; +- hashtab *ht; +- Vardesc *v; +- dimen *dn, *dn0, *dn1; +- ftnlen *dims, *dims1; +- ftnlen b, b0, b1, ex, no, nomax, size, span; +- ftnint no1, no2, type; +- char *vaddr; +- long iva, ivae; +- dimen dimens[MAXDIM], substr; +- +- if (!Alpha['a']) +- nl_init(); +- f__reading=1; +- f__formatted=1; +- got1 = 0; +- top: +- for(;;) switch(GETC(ch)) { +- case EOF: +- eof: +- err(a->ciend,(EOF),where0); +- case '&': +- case '$': +- goto have_amp; +-#ifndef No_Namelist_Questions +- case '?': +- print_ne(a); +- continue; +-#endif +- default: +- if (ch <= ' ' && ch >= 0) +- continue; +-#ifndef No_Namelist_Comments +- while(GETC(ch) != '\n') +- if (ch == EOF) +- goto eof; +-#else +- errfl(a->cierr, 115, where0); +-#endif +- } +- have_amp: +- if (ch = getname(buf,sizeof(buf))) +- return ch; +- nl = (Namelist *)a->cifmt; +- if (strcmp(buf, nl->name)) +-#ifdef No_Bad_Namelist_Skip +- errfl(a->cierr, 118, where0); +-#else +- { +- fprintf(stderr, +- "Skipping namelist \"%s\": seeking namelist \"%s\".\n", +- buf, nl->name); +- fflush(stderr); +- for(;;) switch(GETC(ch)) { +- case EOF: +- err(a->ciend, EOF, where0); +- case '/': +- case '&': +- case '$': +- if (f__external) +- e_rsle(); +- else +- z_rnew(); +- goto top; +- case '"': +- case '\'': +- quote = ch; +- more_quoted: +- while(GETC(ch) != quote) +- if (ch == EOF) +- err(a->ciend, EOF, where0); +- if (GETC(ch) == quote) +- goto more_quoted; +- Ungetc(ch,f__cf); +- default: +- continue; +- } +- } +-#endif +- ht = mk_hashtab(nl); +- if (!ht) +- errfl(f__elist->cierr, 113, where0); +- for(;;) { +- for(;;) switch(GETC(ch)) { +- case EOF: +- if (got1) +- return 0; +- err(a->ciend, EOF, where0); +- case '/': +- case '$': +- case '&': +- return 0; +- default: +- if (ch <= ' ' && ch >= 0 || ch == ',') +- continue; +- Ungetc(ch,f__cf); +- if (ch = getname(buf,sizeof(buf))) +- return ch; +- goto havename; +- } +- havename: +- v = hash(ht,buf); +- if (!v) +- errfl(a->cierr, 119, where); +- while(GETC(ch) <= ' ' && ch >= 0); +- vaddr = v->addr; +- type = v->type; +- if (type < 0) { +- size = -type; +- type = TYCHAR; +- } +- else +- size = f__typesize[type]; +- ivae = size; +- iva = readall = 0; +- if (ch == '(' /*)*/ ) { +- dn = dimens; +- if (!(dims = v->dims)) { +- if (type != TYCHAR) +- errfl(a->cierr, 122, where); +- if (k = getdimen(&ch, dn, (ftnlen)size, +- (ftnlen)size, &b)) +- errfl(a->cierr, k, where); +- if (ch != ')') +- errfl(a->cierr, 115, where); +- b1 = dn->extent; +- if (--b < 0 || b + b1 > size) +- return 124; +- iva += b; +- size = b1; +- while(GETC(ch) <= ' ' && ch >= 0); +- goto scalar; +- } +- nd = (int)dims[0]; +- nomax = span = dims[1]; +- ivae = iva + size*nomax; +- colonseen = 0; +- if (k = getdimen(&ch, dn, size, nomax, &b)) +- errfl(a->cierr, k, where); +- no = dn->extent; +- b0 = dims[2]; +- dims1 = dims += 3; +- ex = 1; +- for(n = 1; n++ < nd; dims++) { +- if (ch != ',') +- errfl(a->cierr, 115, where); +- dn1 = dn + 1; +- span /= *dims; +- if (k = getdimen(&ch, dn1, dn->delta**dims, +- span, &b1)) +- errfl(a->cierr, k, where); +- ex *= *dims; +- b += b1*ex; +- no *= dn1->extent; +- dn = dn1; +- } +- if (ch != ')') +- errfl(a->cierr, 115, where); +- readall = 1 - colonseen; +- b -= b0; +- if (b < 0 || b >= nomax) +- errfl(a->cierr, 125, where); +- iva += size * b; +- dims = dims1; +- while(GETC(ch) <= ' ' && ch >= 0); +- no1 = 1; +- dn0 = dimens; +- if (type == TYCHAR && ch == '(' /*)*/) { +- if (k = getdimen(&ch, &substr, size, size, &b)) +- errfl(a->cierr, k, where); +- if (ch != ')') +- errfl(a->cierr, 115, where); +- b1 = substr.extent; +- if (--b < 0 || b + b1 > size) +- return 124; +- iva += b; +- b0 = size; +- size = b1; +- while(GETC(ch) <= ' ' && ch >= 0); +- if (b1 < b0) +- goto delta_adj; +- } +- if (readall) +- goto delta_adj; +- for(; dn0 < dn; dn0++) { +- if (dn0->extent != *dims++ || dn0->stride != 1) +- break; +- no1 *= dn0->extent; +- } +- if (dn0 == dimens && dimens[0].stride == 1) { +- no1 = dimens[0].extent; +- dn0++; +- } +- delta_adj: +- ex = 0; +- for(dn1 = dn0; dn1 <= dn; dn1++) +- ex += (dn1->extent-1) +- * (dn1->delta *= dn1->stride); +- for(dn1 = dn; dn1 > dn0; dn1--) { +- ex -= (dn1->extent - 1) * dn1->delta; +- dn1->delta -= ex; +- } +- } +- else if (dims = v->dims) { +- no = no1 = dims[1]; +- ivae = iva + no*size; +- } +- else +- scalar: +- no = no1 = 1; +- if (ch != '=') +- errfl(a->cierr, 115, where); +- got1 = nml_read = 1; +- f__lcount = 0; +- readloop: +- for(;;) { +- if (iva >= ivae || iva < 0) { +- f__lquit = 1; +- goto mustend; +- } +- else if (iva + no1*size > ivae) +- no1 = (ivae - iva)/size; +- f__lquit = 0; +- if (k = l_read(&no1, vaddr + iva, size, type)) +- return k; +- if (f__lquit == 1) +- return 0; +- if (readall) { +- iva += dn0->delta; +- if (f__lcount > 0) { +- no2 = (ivae - iva)/size; +- if (no2 > f__lcount) +- no2 = f__lcount; +- if (k = l_read(&no2, vaddr + iva, +- size, type)) +- return k; +- iva += no2 * dn0->delta; +- } +- } +- mustend: +- GETC(ch); +- if (readall) +- if (iva >= ivae) +- readall = 0; +- else for(;;) { +- switch(ch) { +- case ' ': +- case '\t': +- case '\n': +- GETC(ch); +- continue; +- } +- break; +- } +- if (ch == '/' || ch == '$' || ch == '&') { +- f__lquit = 1; +- return 0; +- } +- else if (f__lquit) { +- while(ch <= ' ' && ch >= 0) +- GETC(ch); +- Ungetc(ch,f__cf); +- if (!Alpha[ch & 0xff] && ch >= 0) +- errfl(a->cierr, 125, where); +- break; +- } +- Ungetc(ch,f__cf); +- if (readall && !Alpha[ch & 0xff]) +- goto readloop; +- if ((no -= no1) <= 0) +- break; +- for(dn1 = dn0; dn1 <= dn; dn1++) { +- if (++dn1->curval < dn1->extent) { +- iva += dn1->delta; +- goto readloop; +- } +- dn1->curval = 0; +- } +- break; +- } +- } +- } +- +- integer +-#ifdef KR_headers +-s_rsne(a) cilist *a; +-#else +-s_rsne(cilist *a) +-#endif +-{ +- extern int l_eof; +- int n; +- +- f__external=1; +- l_eof = 0; +- if(n = c_le(a)) +- return n; +- if(f__curunit->uwrt && f__nowreading(f__curunit)) +- err(a->cierr,errno,where0); +- l_getc = t_getc; +- l_ungetc = un_getc; +- f__doend = xrd_SL; +- n = x_rsne(a); +- nml_read = 0; +- if (n) +- return n; +- return e_rsle(); +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libI77/rsne.c +echo libI77/sfe.c 1>&2 +sed >libI77/sfe.c <<'//GO.SYSIN DD libI77/sfe.c' 's/^-//' +-/* sequential formatted external common routines*/ +-#include "f2c.h" +-#include "fio.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-extern char *f__fmtbuf; +- +-integer e_rsfe(Void) +-{ int n; +- n=en_fio(); +- f__fmtbuf=NULL; +- return(n); +-} +- +- int +-#ifdef KR_headers +-c_sfe(a) cilist *a; /* check */ +-#else +-c_sfe(cilist *a) /* check */ +-#endif +-{ unit *p; +- f__curunit = p = &f__units[a->ciunit]; +- if(a->ciunit >= MXUNIT || a->ciunit<0) +- err(a->cierr,101,"startio"); +- if(p->ufd==NULL && fk_open(SEQ,FMT,a->ciunit)) err(a->cierr,114,"sfe") +- if(!p->ufmt) err(a->cierr,102,"sfe") +- return(0); +-} +-integer e_wsfe(Void) +-{ +- int n = en_fio(); +- f__fmtbuf = NULL; +-#ifdef ALWAYS_FLUSH +- if (!n && fflush(f__cf)) +- err(f__elist->cierr, errno, "write end"); +-#endif +- return n; +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libI77/sfe.c +echo libI77/sue.c 1>&2 +sed >libI77/sue.c <<'//GO.SYSIN DD libI77/sue.c' 's/^-//' +-#include "f2c.h" +-#include "fio.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-extern uiolen f__reclen; +-OFF_T f__recloc; +- +- int +-#ifdef KR_headers +-c_sue(a) cilist *a; +-#else +-c_sue(cilist *a) +-#endif +-{ +- f__external=f__sequential=1; +- f__formatted=0; +- f__curunit = &f__units[a->ciunit]; +- if(a->ciunit >= MXUNIT || a->ciunit < 0) +- err(a->cierr,101,"startio"); +- f__elist=a; +- if(f__curunit->ufd==NULL && fk_open(SEQ,UNF,a->ciunit)) +- err(a->cierr,114,"sue"); +- f__cf=f__curunit->ufd; +- if(f__curunit->ufmt) err(a->cierr,103,"sue") +- if(!f__curunit->useek) err(a->cierr,103,"sue") +- return(0); +-} +-#ifdef KR_headers +-integer s_rsue(a) cilist *a; +-#else +-integer s_rsue(cilist *a) +-#endif +-{ +- int n; +- if(!f__init) f_init(); +- f__reading=1; +- if(n=c_sue(a)) return(n); +- f__recpos=0; +- if(f__curunit->uwrt && f__nowreading(f__curunit)) +- err(a->cierr, errno, "read start"); +- if(fread((char *)&f__reclen,sizeof(uiolen),1,f__cf) +- != 1) +- { if(feof(f__cf)) +- { f__curunit->uend = 1; +- err(a->ciend, EOF, "start"); +- } +- clearerr(f__cf); +- err(a->cierr, errno, "start"); +- } +- return(0); +-} +-#ifdef KR_headers +-integer s_wsue(a) cilist *a; +-#else +-integer s_wsue(cilist *a) +-#endif +-{ +- int n; +- if(!f__init) f_init(); +- if(n=c_sue(a)) return(n); +- f__reading=0; +- f__reclen=0; +- if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit)) +- err(a->cierr, errno, "write start"); +- f__recloc=FTELL(f__cf); +- FSEEK(f__cf,(OFF_T)sizeof(uiolen),SEEK_CUR); +- return(0); +-} +-integer e_wsue(Void) +-{ OFF_T loc; +- fwrite((char *)&f__reclen,sizeof(uiolen),1,f__cf); +-#ifdef ALWAYS_FLUSH +- if (fflush(f__cf)) +- err(f__elist->cierr, errno, "write end"); +-#endif +- loc=FTELL(f__cf); +- FSEEK(f__cf,f__recloc,SEEK_SET); +- fwrite((char *)&f__reclen,sizeof(uiolen),1,f__cf); +- FSEEK(f__cf,loc,SEEK_SET); +- return(0); +-} +-integer e_rsue(Void) +-{ +- FSEEK(f__cf,(OFF_T)(f__reclen-f__recpos+sizeof(uiolen)),SEEK_CUR); +- return(0); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libI77/sue.c +echo libI77/typesize.c 1>&2 +sed >libI77/typesize.c <<'//GO.SYSIN DD libI77/typesize.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-ftnlen f__typesize[] = { 0, 0, sizeof(shortint), sizeof(integer), +- sizeof(real), sizeof(doublereal), +- sizeof(complex), sizeof(doublecomplex), +- sizeof(logical), sizeof(char), +- 0, sizeof(integer1), +- sizeof(logical1), sizeof(shortlogical), +-#ifdef Allow_TYQUAD +- sizeof(longint), +-#endif +- 0}; +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libI77/typesize.c +echo libI77/uio.c 1>&2 +sed >libI77/uio.c <<'//GO.SYSIN DD libI77/uio.c' 's/^-//' +-#include "f2c.h" +-#include "fio.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-uiolen f__reclen; +- +- int +-#ifdef KR_headers +-do_us(number,ptr,len) ftnint *number; char *ptr; ftnlen len; +-#else +-do_us(ftnint *number, char *ptr, ftnlen len) +-#endif +-{ +- if(f__reading) +- { +- f__recpos += (int)(*number * len); +- if(f__recpos>f__reclen) +- err(f__elist->cierr, 110, "do_us"); +- if (fread(ptr,(int)len,(int)(*number),f__cf) != *number) +- err(f__elist->ciend, EOF, "do_us"); +- return(0); +- } +- else +- { +- f__reclen += *number * len; +- (void) fwrite(ptr,(int)len,(int)(*number),f__cf); +- return(0); +- } +-} +-#ifdef KR_headers +-integer do_ud(number,ptr,len) ftnint *number; char *ptr; ftnlen len; +-#else +-integer do_ud(ftnint *number, char *ptr, ftnlen len) +-#endif +-{ +- f__recpos += (int)(*number * len); +- if(f__recpos > f__curunit->url && f__curunit->url!=1) +- err(f__elist->cierr,110,"do_ud"); +- if(f__reading) +- { +-#ifdef Pad_UDread +-#ifdef KR_headers +- int i; +-#else +- size_t i; +-#endif +- if (!(i = fread(ptr,(int)len,(int)(*number),f__cf)) +- && !(f__recpos - *number*len)) +- err(f__elist->cierr,EOF,"do_ud") +- if (i < *number) +- memset(ptr + i*len, 0, (*number - i)*len); +- return 0; +-#else +- if(fread(ptr,(int)len,(int)(*number),f__cf) != *number) +- err(f__elist->cierr,EOF,"do_ud") +- else return(0); +-#endif +- } +- (void) fwrite(ptr,(int)len,(int)(*number),f__cf); +- return(0); +-} +-#ifdef KR_headers +-integer do_uio(number,ptr,len) ftnint *number; char *ptr; ftnlen len; +-#else +-integer do_uio(ftnint *number, char *ptr, ftnlen len) +-#endif +-{ +- if(f__sequential) +- return(do_us(number,ptr,len)); +- else return(do_ud(number,ptr,len)); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libI77/uio.c +echo libI77/util.c 1>&2 +sed >libI77/util.c <<'//GO.SYSIN DD libI77/util.c' 's/^-//' +-#include "sysdep1.h" /* here to get stat64 on some badly designed Linux systems */ +-#include "f2c.h" +-#include "fio.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +- VOID +-#ifdef KR_headers +-g_char(a,alen,b) char *a,*b; ftnlen alen; +-#else +-g_char(char *a, ftnlen alen, char *b) +-#endif +-{ +- char *x = a + alen, *y = b + alen; +- +- for(;; y--) { +- if (x <= a) { +- *b = 0; +- return; +- } +- if (*--x != ' ') +- break; +- } +- *y-- = 0; +- do *y-- = *x; +- while(x-- > a); +- } +- +- VOID +-#ifdef KR_headers +-b_char(a,b,blen) char *a,*b; ftnlen blen; +-#else +-b_char(char *a, char *b, ftnlen blen) +-#endif +-{ int i; +- for(i=0;i<blen && *a!=0;i++) *b++= *a++; +- for(;i<blen;i++) *b++=' '; +-} +-#ifndef NON_UNIX_STDIO +-#ifdef KR_headers +-long f__inode(a, dev) char *a; int *dev; +-#else +-long f__inode(char *a, int *dev) +-#endif +-{ struct STAT_ST x; +- if(STAT(a,&x)<0) return(-1); +- *dev = x.st_dev; +- return(x.st_ino); +-} +-#endif +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libI77/util.c +echo libI77/wref.c 1>&2 +sed >libI77/wref.c <<'//GO.SYSIN DD libI77/wref.c' 's/^-//' +-#include "f2c.h" +-#include "fio.h" +- +-#ifndef KR_headers +-#undef abs +-#undef min +-#undef max +-#include "stdlib.h" +-#include "string.h" +-#endif +- +-#include "fmt.h" +-#include "fp.h" +-#ifndef VAX +-#include "ctype.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-#endif +- +- int +-#ifdef KR_headers +-wrt_E(p,w,d,e,len) ufloat *p; ftnlen len; +-#else +-wrt_E(ufloat *p, int w, int d, int e, ftnlen len) +-#endif +-{ +- char buf[FMAX+EXPMAXDIGS+4], *s, *se; +- int d1, delta, e1, i, sign, signspace; +- double dd; +-#ifdef WANT_LEAD_0 +- int insert0 = 0; +-#endif +-#ifndef VAX +- int e0 = e; +-#endif +- +- if(e <= 0) +- e = 2; +- if(f__scale) { +- if(f__scale >= d + 2 || f__scale <= -d) +- goto nogood; +- } +- if(f__scale <= 0) +- --d; +- if (len == sizeof(real)) +- dd = p->pf; +- else +- dd = p->pd; +- if (dd < 0.) { +- signspace = sign = 1; +- dd = -dd; +- } +- else { +- sign = 0; +- signspace = (int)f__cplus; +-#ifndef VAX +- if (!dd) { +-#ifdef SIGNED_ZEROS +- if (signbit_f2c(&dd)) +- signspace = sign = 1; +-#endif +- dd = 0.; /* avoid -0 */ +- } +-#endif +- } +- delta = w - (2 /* for the . and the d adjustment above */ +- + 2 /* for the E+ */ + signspace + d + e); +-#ifdef WANT_LEAD_0 +- if (f__scale <= 0 && delta > 0) { +- delta--; +- insert0 = 1; +- } +- else +-#endif +- if (delta < 0) { +-nogood: +- while(--w >= 0) +- PUT('*'); +- return(0); +- } +- if (f__scale < 0) +- d += f__scale; +- if (d > FMAX) { +- d1 = d - FMAX; +- d = FMAX; +- } +- else +- d1 = 0; +- sprintf(buf,"%#.*E", d, dd); +-#ifndef VAX +- /* check for NaN, Infinity */ +- if (!isdigit(buf[0])) { +- switch(buf[0]) { +- case 'n': +- case 'N': +- signspace = 0; /* no sign for NaNs */ +- } +- delta = w - strlen(buf) - signspace; +- if (delta < 0) +- goto nogood; +- while(--delta >= 0) +- PUT(' '); +- if (signspace) +- PUT(sign ? '-' : '+'); +- for(s = buf; *s; s++) +- PUT(*s); +- return 0; +- } +-#endif +- se = buf + d + 3; +-#ifdef GOOD_SPRINTF_EXPONENT /* When possible, exponent has 2 digits. */ +- if (f__scale != 1 && dd) +- sprintf(se, "%+.2d", atoi(se) + 1 - f__scale); +-#else +- if (dd) +- sprintf(se, "%+.2d", atoi(se) + 1 - f__scale); +- else +- strcpy(se, "+00"); +-#endif +- s = ++se; +- if (e < 2) { +- if (*s != '0') +- goto nogood; +- } +-#ifndef VAX +- /* accommodate 3 significant digits in exponent */ +- if (s[2]) { +-#ifdef Pedantic +- if (!e0 && !s[3]) +- for(s -= 2, e1 = 2; s[0] = s[1]; s++); +- +- /* Pedantic gives the behavior that Fortran 77 specifies, */ +- /* i.e., requires that E be specified for exponent fields */ +- /* of more than 3 digits. With Pedantic undefined, we get */ +- /* the behavior that Cray displays -- you get a bigger */ +- /* exponent field if it fits. */ +-#else +- if (!e0) { +- for(s -= 2, e1 = 2; s[0] = s[1]; s++) +-#ifdef CRAY +- delta--; +- if ((delta += 4) < 0) +- goto nogood +-#endif +- ; +- } +-#endif +- else if (e0 >= 0) +- goto shift; +- else +- e1 = e; +- } +- else +- shift: +-#endif +- for(s += 2, e1 = 2; *s; ++e1, ++s) +- if (e1 >= e) +- goto nogood; +- while(--delta >= 0) +- PUT(' '); +- if (signspace) +- PUT(sign ? '-' : '+'); +- s = buf; +- i = f__scale; +- if (f__scale <= 0) { +-#ifdef WANT_LEAD_0 +- if (insert0) +- PUT('0'); +-#endif +- PUT('.'); +- for(; i < 0; ++i) +- PUT('0'); +- PUT(*s); +- s += 2; +- } +- else if (f__scale > 1) { +- PUT(*s); +- s += 2; +- while(--i > 0) +- PUT(*s++); +- PUT('.'); +- } +- if (d1) { +- se -= 2; +- while(s < se) PUT(*s++); +- se += 2; +- do PUT('0'); while(--d1 > 0); +- } +- while(s < se) +- PUT(*s++); +- if (e < 2) +- PUT(s[1]); +- else { +- while(++e1 <= e) +- PUT('0'); +- while(*s) +- PUT(*s++); +- } +- return 0; +- } +- +- int +-#ifdef KR_headers +-wrt_F(p,w,d,len) ufloat *p; ftnlen len; +-#else +-wrt_F(ufloat *p, int w, int d, ftnlen len) +-#endif +-{ +- int d1, sign, n; +- double x; +- char *b, buf[MAXINTDIGS+MAXFRACDIGS+4], *s; +- +- x= (len==sizeof(real)?p->pf:p->pd); +- if (d < MAXFRACDIGS) +- d1 = 0; +- else { +- d1 = d - MAXFRACDIGS; +- d = MAXFRACDIGS; +- } +- if (x < 0.) +- { x = -x; sign = 1; } +- else { +- sign = 0; +-#ifndef VAX +- if (!x) { +-#ifdef SIGNED_ZEROS +- if (signbit_f2c(&x)) +- sign = 2; +-#endif +- x = 0.; +- } +-#endif +- } +- +- if (n = f__scale) +- if (n > 0) +- do x *= 10.; while(--n > 0); +- else +- do x *= 0.1; while(++n < 0); +- +-#ifdef USE_STRLEN +- sprintf(b = buf, "%#.*f", d, x); +- n = strlen(b) + d1; +-#else +- n = sprintf(b = buf, "%#.*f", d, x) + d1; +-#endif +- +-#ifndef WANT_LEAD_0 +- if (buf[0] == '0' && d) +- { ++b; --n; } +-#endif +- if (sign == 1) { +- /* check for all zeros */ +- for(s = b;;) { +- while(*s == '0') s++; +- switch(*s) { +- case '.': +- s++; continue; +- case 0: +- sign = 0; +- } +- break; +- } +- } +- if (sign || f__cplus) +- ++n; +- if (n > w) { +-#ifdef WANT_LEAD_0 +- if (buf[0] == '0' && --n == w) +- ++b; +- else +-#endif +- { +- while(--w >= 0) +- PUT('*'); +- return 0; +- } +- } +- for(w -= n; --w >= 0; ) +- PUT(' '); +- if (sign) +- PUT('-'); +- else if (f__cplus) +- PUT('+'); +- while(n = *b++) +- PUT(n); +- while(--d1 >= 0) +- PUT('0'); +- return 0; +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libI77/wref.c +echo libI77/wrtfmt.c 1>&2 +sed >libI77/wrtfmt.c <<'//GO.SYSIN DD libI77/wrtfmt.c' 's/^-//' +-#include "f2c.h" +-#include "fio.h" +-#include "fmt.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-extern icilist *f__svic; +-extern char *f__icptr; +- +- static int +-mv_cur(Void) /* shouldn't use fseek because it insists on calling fflush */ +- /* instead we know too much about stdio */ +-{ +- int cursor = f__cursor; +- f__cursor = 0; +- if(f__external == 0) { +- if(cursor < 0) { +- if(f__hiwater < f__recpos) +- f__hiwater = f__recpos; +- f__recpos += cursor; +- f__icptr += cursor; +- if(f__recpos < 0) +- err(f__elist->cierr, 110, "left off"); +- } +- else if(cursor > 0) { +- if(f__recpos + cursor >= f__svic->icirlen) +- err(f__elist->cierr, 110, "recend"); +- if(f__hiwater <= f__recpos) +- for(; cursor > 0; cursor--) +- (*f__putn)(' '); +- else if(f__hiwater <= f__recpos + cursor) { +- cursor -= f__hiwater - f__recpos; +- f__icptr += f__hiwater - f__recpos; +- f__recpos = f__hiwater; +- for(; cursor > 0; cursor--) +- (*f__putn)(' '); +- } +- else { +- f__icptr += cursor; +- f__recpos += cursor; +- } +- } +- return(0); +- } +- if (cursor > 0) { +- if(f__hiwater <= f__recpos) +- for(;cursor>0;cursor--) (*f__putn)(' '); +- else if(f__hiwater <= f__recpos + cursor) { +- cursor -= f__hiwater - f__recpos; +- f__recpos = f__hiwater; +- for(; cursor > 0; cursor--) +- (*f__putn)(' '); +- } +- else { +- f__recpos += cursor; +- } +- } +- else if (cursor < 0) +- { +- if(cursor + f__recpos < 0) +- err(f__elist->cierr,110,"left off"); +- if(f__hiwater < f__recpos) +- f__hiwater = f__recpos; +- f__recpos += cursor; +- } +- return(0); +-} +- +- static int +-#ifdef KR_headers +-wrt_Z(n,w,minlen,len) Uint *n; int w, minlen; ftnlen len; +-#else +-wrt_Z(Uint *n, int w, int minlen, ftnlen len) +-#endif +-{ +- register char *s, *se; +- register int i, w1; +- static int one = 1; +- static char hex[] = "0123456789ABCDEF"; +- s = (char *)n; +- --len; +- if (*(char *)&one) { +- /* little endian */ +- se = s; +- s += len; +- i = -1; +- } +- else { +- se = s + len; +- i = 1; +- } +- for(;; s += i) +- if (s == se || *s) +- break; +- w1 = (i*(se-s) << 1) + 1; +- if (*s & 0xf0) +- w1++; +- if (w1 > w) +- for(i = 0; i < w; i++) +- (*f__putn)('*'); +- else { +- if ((minlen -= w1) > 0) +- w1 += minlen; +- while(--w >= w1) +- (*f__putn)(' '); +- while(--minlen >= 0) +- (*f__putn)('0'); +- if (!(*s & 0xf0)) { +- (*f__putn)(hex[*s & 0xf]); +- if (s == se) +- return 0; +- s += i; +- } +- for(;; s += i) { +- (*f__putn)(hex[*s >> 4 & 0xf]); +- (*f__putn)(hex[*s & 0xf]); +- if (s == se) +- break; +- } +- } +- return 0; +- } +- +- static int +-#ifdef KR_headers +-wrt_I(n,w,len, base) Uint *n; ftnlen len; register int base; +-#else +-wrt_I(Uint *n, int w, ftnlen len, register int base) +-#endif +-{ int ndigit,sign,spare,i; +- longint x; +- char *ans; +- if(len==sizeof(integer)) x=n->il; +- else if(len == sizeof(char)) x = n->ic; +-#ifdef Allow_TYQUAD +- else if (len == sizeof(longint)) x = n->ili; +-#endif +- else x=n->is; +- ans=f__icvt(x,&ndigit,&sign, base); +- spare=w-ndigit; +- if(sign || f__cplus) spare--; +- if(spare<0) +- for(i=0;i<w;i++) (*f__putn)('*'); +- else +- { for(i=0;i<spare;i++) (*f__putn)(' '); +- if(sign) (*f__putn)('-'); +- else if(f__cplus) (*f__putn)('+'); +- for(i=0;i<ndigit;i++) (*f__putn)(*ans++); +- } +- return(0); +-} +- static int +-#ifdef KR_headers +-wrt_IM(n,w,m,len,base) Uint *n; ftnlen len; int base; +-#else +-wrt_IM(Uint *n, int w, int m, ftnlen len, int base) +-#endif +-{ int ndigit,sign,spare,i,xsign; +- longint x; +- char *ans; +- if(sizeof(integer)==len) x=n->il; +- else if(len == sizeof(char)) x = n->ic; +-#ifdef Allow_TYQUAD +- else if (len == sizeof(longint)) x = n->ili; +-#endif +- else x=n->is; +- ans=f__icvt(x,&ndigit,&sign, base); +- if(sign || f__cplus) xsign=1; +- else xsign=0; +- if(ndigit+xsign>w || m+xsign>w) +- { for(i=0;i<w;i++) (*f__putn)('*'); +- return(0); +- } +- if(x==0 && m==0) +- { for(i=0;i<w;i++) (*f__putn)(' '); +- return(0); +- } +- if(ndigit>=m) +- spare=w-ndigit-xsign; +- else +- spare=w-m-xsign; +- for(i=0;i<spare;i++) (*f__putn)(' '); +- if(sign) (*f__putn)('-'); +- else if(f__cplus) (*f__putn)('+'); +- for(i=0;i<m-ndigit;i++) (*f__putn)('0'); +- for(i=0;i<ndigit;i++) (*f__putn)(*ans++); +- return(0); +-} +- static int +-#ifdef KR_headers +-wrt_AP(s) char *s; +-#else +-wrt_AP(char *s) +-#endif +-{ char quote; +- int i; +- +- if(f__cursor && (i = mv_cur())) +- return i; +- quote = *s++; +- for(;*s;s++) +- { if(*s!=quote) (*f__putn)(*s); +- else if(*++s==quote) (*f__putn)(*s); +- else return(1); +- } +- return(1); +-} +- static int +-#ifdef KR_headers +-wrt_H(a,s) char *s; +-#else +-wrt_H(int a, char *s) +-#endif +-{ +- int i; +- +- if(f__cursor && (i = mv_cur())) +- return i; +- while(a--) (*f__putn)(*s++); +- return(1); +-} +- +- int +-#ifdef KR_headers +-wrt_L(n,len, sz) Uint *n; ftnlen sz; +-#else +-wrt_L(Uint *n, int len, ftnlen sz) +-#endif +-{ int i; +- long x; +- if(sizeof(long)==sz) x=n->il; +- else if(sz == sizeof(char)) x = n->ic; +- else x=n->is; +- for(i=0;i<len-1;i++) +- (*f__putn)(' '); +- if(x) (*f__putn)('T'); +- else (*f__putn)('F'); +- return(0); +-} +- static int +-#ifdef KR_headers +-wrt_A(p,len) char *p; ftnlen len; +-#else +-wrt_A(char *p, ftnlen len) +-#endif +-{ +- while(len-- > 0) (*f__putn)(*p++); +- return(0); +-} +- static int +-#ifdef KR_headers +-wrt_AW(p,w,len) char * p; ftnlen len; +-#else +-wrt_AW(char * p, int w, ftnlen len) +-#endif +-{ +- while(w>len) +- { w--; +- (*f__putn)(' '); +- } +- while(w-- > 0) +- (*f__putn)(*p++); +- return(0); +-} +- +- static int +-#ifdef KR_headers +-wrt_G(p,w,d,e,len) ufloat *p; ftnlen len; +-#else +-wrt_G(ufloat *p, int w, int d, int e, ftnlen len) +-#endif +-{ double up = 1,x; +- int i=0,oldscale,n,j; +- x = len==sizeof(real)?p->pf:p->pd; +- if(x < 0 ) x = -x; +- if(x<.1) { +- if (x != 0.) +- return(wrt_E(p,w,d,e,len)); +- i = 1; +- goto have_i; +- } +- for(;i<=d;i++,up*=10) +- { if(x>=up) continue; +- have_i: +- oldscale = f__scale; +- f__scale = 0; +- if(e==0) n=4; +- else n=e+2; +- i=wrt_F(p,w-n,d-i,len); +- for(j=0;j<n;j++) (*f__putn)(' '); +- f__scale=oldscale; +- return(i); +- } +- return(wrt_E(p,w,d,e,len)); +-} +- +- int +-#ifdef KR_headers +-w_ed(p,ptr,len) struct syl *p; char *ptr; ftnlen len; +-#else +-w_ed(struct syl *p, char *ptr, ftnlen len) +-#endif +-{ +- int i; +- +- if(f__cursor && (i = mv_cur())) +- return i; +- switch(p->op) +- { +- default: +- fprintf(stderr,"w_ed, unexpected code: %d\n", p->op); +- sig_die(f__fmtbuf, 1); +- case I: return(wrt_I((Uint *)ptr,p->p1,len, 10)); +- case IM: +- return(wrt_IM((Uint *)ptr,p->p1,p->p2.i[0],len,10)); +- +- /* O and OM don't work right for character, double, complex, */ +- /* or doublecomplex, and they differ from Fortran 90 in */ +- /* showing a minus sign for negative values. */ +- +- case O: return(wrt_I((Uint *)ptr, p->p1, len, 8)); +- case OM: +- return(wrt_IM((Uint *)ptr,p->p1,p->p2.i[0],len,8)); +- case L: return(wrt_L((Uint *)ptr,p->p1, len)); +- case A: return(wrt_A(ptr,len)); +- case AW: +- return(wrt_AW(ptr,p->p1,len)); +- case D: +- case E: +- case EE: +- return(wrt_E((ufloat *)ptr,p->p1,p->p2.i[0],p->p2.i[1],len)); +- case G: +- case GE: +- return(wrt_G((ufloat *)ptr,p->p1,p->p2.i[0],p->p2.i[1],len)); +- case F: return(wrt_F((ufloat *)ptr,p->p1,p->p2.i[0],len)); +- +- /* Z and ZM assume 8-bit bytes. */ +- +- case Z: return(wrt_Z((Uint *)ptr,p->p1,0,len)); +- case ZM: +- return(wrt_Z((Uint *)ptr,p->p1,p->p2.i[0],len)); +- } +-} +- +- int +-#ifdef KR_headers +-w_ned(p) struct syl *p; +-#else +-w_ned(struct syl *p) +-#endif +-{ +- switch(p->op) +- { +- default: fprintf(stderr,"w_ned, unexpected code: %d\n", p->op); +- sig_die(f__fmtbuf, 1); +- case SLASH: +- return((*f__donewrec)()); +- case T: f__cursor = p->p1-f__recpos - 1; +- return(1); +- case TL: f__cursor -= p->p1; +- if(f__cursor < -f__recpos) /* TL1000, 1X */ +- f__cursor = -f__recpos; +- return(1); +- case TR: +- case X: +- f__cursor += p->p1; +- return(1); +- case APOS: +- return(wrt_AP(p->p2.s)); +- case H: +- return(wrt_H(p->p1,p->p2.s)); +- } +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libI77/wrtfmt.c +echo libI77/wsfe.c 1>&2 +sed >libI77/wsfe.c <<'//GO.SYSIN DD libI77/wsfe.c' 's/^-//' +-/*write sequential formatted external*/ +-#include "f2c.h" +-#include "fio.h" +-#include "fmt.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +- int +-x_wSL(Void) +-{ +- int n = f__putbuf('\n'); +- f__hiwater = f__recpos = f__cursor = 0; +- return(n == 0); +-} +- +- static int +-xw_end(Void) +-{ +- int n; +- +- if(f__nonl) { +- f__putbuf(n = 0); +- fflush(f__cf); +- } +- else +- n = f__putbuf('\n'); +- f__hiwater = f__recpos = f__cursor = 0; +- return n; +-} +- +- static int +-xw_rev(Void) +-{ +- int n = 0; +- if(f__workdone) { +- n = f__putbuf('\n'); +- f__workdone = 0; +- } +- f__hiwater = f__recpos = f__cursor = 0; +- return n; +-} +- +-#ifdef KR_headers +-integer s_wsfe(a) cilist *a; /*start*/ +-#else +-integer s_wsfe(cilist *a) /*start*/ +-#endif +-{ int n; +- if(!f__init) f_init(); +- f__reading=0; +- f__sequential=1; +- f__formatted=1; +- f__external=1; +- if(n=c_sfe(a)) return(n); +- f__elist=a; +- f__hiwater = f__cursor=f__recpos=0; +- f__nonl = 0; +- f__scale=0; +- f__fmtbuf=a->cifmt; +- f__cf=f__curunit->ufd; +- if(pars_f(f__fmtbuf)<0) err(a->cierr,100,"startio"); +- f__putn= x_putc; +- f__doed= w_ed; +- f__doned= w_ned; +- f__doend=xw_end; +- f__dorevert=xw_rev; +- f__donewrec=x_wSL; +- fmt_bg(); +- f__cplus=0; +- f__cblank=f__curunit->ublnk; +- if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit)) +- err(a->cierr,errno,"write start"); +- return(0); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libI77/wsfe.c +echo libI77/wsle.c 1>&2 +sed >libI77/wsle.c <<'//GO.SYSIN DD libI77/wsle.c' 's/^-//' +-#include "f2c.h" +-#include "fio.h" +-#include "fmt.h" +-#include "lio.h" +-#include "string.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef KR_headers +-integer s_wsle(a) cilist *a; +-#else +-integer s_wsle(cilist *a) +-#endif +-{ +- int n; +- if(n=c_le(a)) return(n); +- f__reading=0; +- f__external=1; +- f__formatted=1; +- f__putn = x_putc; +- f__lioproc = l_write; +- L_len = LINE; +- f__donewrec = x_wSL; +- if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit)) +- err(a->cierr, errno, "list output start"); +- return(0); +- } +- +-integer e_wsle(Void) +-{ +- int n = f__putbuf('\n'); +- f__recpos=0; +-#ifdef ALWAYS_FLUSH +- if (!n && fflush(f__cf)) +- err(f__elist->cierr, errno, "write end"); +-#endif +- return(n); +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libI77/wsle.c +echo libI77/wsne.c 1>&2 +sed >libI77/wsne.c <<'//GO.SYSIN DD libI77/wsne.c' 's/^-//' +-#include "f2c.h" +-#include "fio.h" +-#include "lio.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +- integer +-#ifdef KR_headers +-s_wsne(a) cilist *a; +-#else +-s_wsne(cilist *a) +-#endif +-{ +- int n; +- +- if(n=c_le(a)) +- return(n); +- f__reading=0; +- f__external=1; +- f__formatted=1; +- f__putn = x_putc; +- L_len = LINE; +- f__donewrec = x_wSL; +- if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit)) +- err(a->cierr, errno, "namelist output start"); +- x_wsne(a); +- return e_wsle(); +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libI77/wsne.c +echo libI77/xwsne.c 1>&2 +sed >libI77/xwsne.c <<'//GO.SYSIN DD libI77/xwsne.c' 's/^-//' +-#include "f2c.h" +-#include "fio.h" +-#include "lio.h" +-#include "fmt.h" +- +-extern int f__Aquote; +- +- static VOID +-nl_donewrec(Void) +-{ +- (*f__donewrec)(); +- PUT(' '); +- } +- +-#ifdef KR_headers +-x_wsne(a) cilist *a; +-#else +-#include "string.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +- VOID +-x_wsne(cilist *a) +-#endif +-{ +- Namelist *nl; +- char *s; +- Vardesc *v, **vd, **vde; +- ftnint number, type; +- ftnlen *dims; +- ftnlen size; +- extern ftnlen f__typesize[]; +- +- nl = (Namelist *)a->cifmt; +- PUT('&'); +- for(s = nl->name; *s; s++) +- PUT(*s); +- PUT(' '); +- f__Aquote = 1; +- vd = nl->vars; +- vde = vd + nl->nvars; +- while(vd < vde) { +- v = *vd++; +- s = v->name; +-#ifdef No_Extra_Namelist_Newlines +- if (f__recpos+strlen(s)+2 >= L_len) +-#endif +- nl_donewrec(); +- while(*s) +- PUT(*s++); +- PUT(' '); +- PUT('='); +- number = (dims = v->dims) ? dims[1] : 1; +- type = v->type; +- if (type < 0) { +- size = -type; +- type = TYCHAR; +- } +- else +- size = f__typesize[type]; +- l_write(&number, v->addr, size, type); +- if (vd < vde) { +- if (f__recpos+2 >= L_len) +- nl_donewrec(); +- PUT(','); +- PUT(' '); +- } +- else if (f__recpos+1 >= L_len) +- nl_donewrec(); +- } +- f__Aquote = 0; +- PUT('/'); +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libI77/xwsne.c +echo libI77/Notice 1>&2 +sed >libI77/Notice <<'//GO.SYSIN DD libI77/Notice' 's/^-//' +-/**************************************************************** +-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. +-****************************************************************/ +- +//GO.SYSIN DD libI77/Notice +echo libI77/README 1>&2 +sed >libI77/README <<'//GO.SYSIN DD libI77/README' 's/^-//' +-If your compiler does not recognize ANSI C headers, +-compile with KR_headers defined: either add -DKR_headers +-to the definition of CFLAGS in the makefile, or insert +- +-#define KR_headers +- +-at the top of f2c.h and fmtlib.c . +- +- +-If you have a really ancient K&R C compiler that does not understand +-void, add -Dvoid=int to the definition of CFLAGS in the makefile. +- +-If you use a C++ compiler, first create a local f2c.h by appending +-f2ch.add to the usual f2c.h, e.g., by issuing the command +- make f2c.h +-which assumes f2c.h is installed in /usr/include . +- +-If your system lacks /usr/include/fcntl.h , then you +-should simply create an empty fcntl.h in this directory. +-If your compiler then complains about creat and open not +-having a prototype, compile with OPEN_DECL defined. +-On many systems, open and creat are declared in fcntl.h . +- +-If your system has /usr/include/fcntl.h, you may need to add +--D_POSIX_SOURCE to the makefile's definition of CFLAGS. +- +-If your system's sprintf does not work the way ANSI C +-specifies -- specifically, if it does not return the +-number of characters transmitted -- then insert the line +- +-#define USE_STRLEN +- +-at the end of fmt.h . This is necessary with +-at least some versions of Sun and DEC software. +-In particular, if you get a warning about an improper +-pointer/integer combination in compiling wref.c, then +-you need to compile with -DUSE_STRLEN . +- +-If your system's fopen does not like the ANSI binary +-reading and writing modes "rb" and "wb", then you should +-compile open.c with NON_ANSI_RW_MODES #defined. +- +-If you get error messages about references to cf->_ptr +-and cf->_base when compiling wrtfmt.c and wsfe.c or to +-stderr->_flag when compiling err.c, then insert the line +- +-#define NON_UNIX_STDIO +- +-at the beginning of fio.h, and recompile everything (or +-at least those modules that contain NON_UNIX_STDIO). +- +-Unformatted sequential records consist of a length of record +-contents, the record contents themselves, and the length of +-record contents again (for backspace). Prior to 17 Oct. 1991, +-the length was of type int; now it is of type long, but you +-can change it back to int by inserting +- +-#define UIOLEN_int +- +-at the beginning of fio.h. This affects only sue.c and uio.c . +- +-On VAX, Cray, or Research Tenth-Edition Unix systems, you may +-need to add -DVAX, -DCRAY, or -DV10 (respectively) to CFLAGS +-to make fp.h work correctly. Alternatively, you may need to +-edit fp.h to suit your machine. +- +-You may need to supply the following non-ANSI routines: +- +- fstat(int fileds, struct stat *buf) is similar +-to stat(char *name, struct stat *buf), except that +-the first argument, fileds, is the file descriptor +-returned by open rather than the name of the file. +-fstat is used in the system-dependent routine +-canseek (in the libI77 source file err.c), which +-is supposed to return 1 if it's possible to issue +-seeks on the file in question, 0 if it's not; you may +-need to suitably modify err.c . On non-UNIX systems, +-you can avoid references to fstat and stat by compiling +-with NON_UNIX_STDIO defined; in that case, you may need +-to supply access(char *Name,0), which is supposed to +-return 0 if file Name exists, nonzero otherwise. +- +- char * mktemp(char *buf) is supposed to replace the +-6 trailing X's in buf with a unique number and then +-return buf. The idea is to get a unique name for +-a temporary file. +- +-On non-UNIX systems, you may need to change a few other, +-e.g.: the form of name computed by mktemp() in endfile.c and +-open.c; the use of the open(), close(), and creat() system +-calls in endfile.c, err.c, open.c; and the modes in calls on +-fopen() and fdopen() (and perhaps the use of fdopen() itself +--- it's supposed to return a FILE* corresponding to a given +-an integer file descriptor) in err.c and open.c (component ufmt +-of struct unit is 1 for formatted I/O -- text mode on some systems +--- and 0 for unformatted I/O -- binary mode on some systems). +-Compiling with -DNON_UNIX_STDIO omits all references to creat() +-and almost all references to open() and close(), the exception +-being in the function f__isdev() (in open.c). +- +-For MS-DOS, compile all of libI77 with -DMSDOS (which implies +--DNON_UNIX_STDIO). You may need to make other compiler-dependent +-adjustments; for example, for Turbo C++ you need to adjust the mktemp +-invocations and to #undef ungetc in lread.c and rsne.c . +- +-If you want to be able to load against libI77 but not libF77, +-then you will need to add sig_die.o (from libF77) to libI77. +- +-If you wish to use translated Fortran that has funny notions +-of record length for direct unformatted I/O (i.e., that assumes +-RECL= values in OPEN statements are not bytes but rather counts +-of some other units -- e.g., 4-character words for VMS), then you +-should insert an appropriate #define for url_Adjust at the +-beginning of open.c . For VMS Fortran, for example, +-#define url_Adjust(x) x *= 4 +-would suffice. +- +-To check for transmission errors, issue the command +- make check +-This assumes you have the xsum program whose source, xsum.c, +-is distributed as part of "all from f2c/src". If you do not +-have xsum, you can obtain xsum.c by sending the following E-mail +-message to netlib@netlib.bell-labs.com +- send xsum.c from f2c/src +- +-The makefile assumes you have installed f2c.h in a standard +-place (and does not cause recompilation when f2c.h is changed); +-f2c.h comes with "all from f2c" (the source for f2c) and is +-available separately ("f2c.h from f2c"). +- +-By default, Fortran I/O units 5, 6, and 0 are pre-connected to +-stdin, stdout, and stderr, respectively. You can change this +-behavior by changing f_init() in err.c to suit your needs. +-Note that f2c assumes READ(*... means READ(5... and WRITE(*... +-means WRITE(6... . Moreover, an OPEN(n,... statement that does +-not specify a file name (and does not specify STATUS='SCRATCH') +-assumes FILE='fort.n' . You can change this by editing open.c +-and endfile.c suitably. +- +-Unless you adjust the "#define MXUNIT" line in fio.h, Fortran units +-0, 1, ..., 99 are available, i.e., the highest allowed unit number +-is MXUNIT - 1. +- +-Lines protected from compilation by #ifdef Allow_TYQUAD +-are for a possible extension to 64-bit integers in which +-integer = int = 32 bits and longint = long = 64 bits. +- +-Extensions (Feb. 1993) to NAMELIST processing: +- 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. (Sept. 1995) When looking for the &name that starts namelist +-input, lines whose first non-blank character is something other +-than &, $, or ? are treated as comment lines and ignored, unless +-rsne.c is compiled with -DNo_Namelist_Comments. +- +-Nonstandard extension (Feb. 1993) to open: for 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. +- +-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 . +- +-If you want to be able to catch write failures (e.g., due to a +-disk being full) with an ERR= specifier, compile dfe.c, due.c, +-sfe.c, sue.c, and wsle.c with -DALWAYS_FLUSH. This will lead to +-slower execution and more I/O, but should make ERR= work as +-expected, provided fflush returns an error return when its +-physical write fails. +- +-Carriage controls are meant to be interpreted by the UNIX col +-program (or a similar program). Sometimes it's convenient to use +-only ' ' as the carriage control character (normal single spacing). +-If you compile lwrite.c and wsfe.c with -DOMIT_BLANK_CC, formatted +-external output lines will have an initial ' ' quietly omitted, +-making use of the col program unnecessary with output that only +-has ' ' for carriage control. +- +-The Fortran 77 Standard leaves it up to the implementation whether +-formatted writes of floating-point numbers of absolute value < 1 have +-a zero before the decimal point. By default, libI77 omits such +-superfluous zeros, but you can cause them to appear by compiling +-lwrite.c, wref.c, and wrtfmt.c with -DWANT_LEAD_0 . +- +-If your system lacks a ranlib command, you don't need it. +-Either comment out the makefile's ranlib invocation, or install +-a harmless "ranlib" command somewhere in your PATH, such as the +-one-line shell script +- +- exit 0 +- +-or (on some systems) +- +- exec /usr/bin/ar lts $1 >/dev/null +- +-Most of the routines in libI77 are support routines for Fortran +-I/O. There are a few exceptions, summarized below -- I/O related +-functions and subroutines that appear to your program as ordinary +-external Fortran routines. +- +-1. CALL FLUSH flushes all buffers. +- +-2. FTELL(i) is an INTEGER function that returns the current +- offset of Fortran unit i (or -1 if unit i is not open). +- +-3. CALL FSEEK(i, offset, whence, *errlab) attemps to move +- Fortran unit i to the specified offset: absolute offset +- if whence = 0; relative to the current offset if whence = 1; +- relative to the end of the file if whence = 2. It branches +- to label errlab if unit i is not open or if the call +- otherwise fails. +- +-Nowadays most Unix and Linux systems have function +- int ftruncate(int fildes, off_t len); +-defined in system header file unistd.h that adjusts the length of file +-descriptor fildes to length len. Unless endfile.c is compiled with +--DNO_TRUNCATE, endfile.c #includes "unistd.h" and calls ftruncate() if +-necessary to shorten files. If your system lacks ftruncate(), compile +-endfile.c with -DNO_TRUNCATE to make endfile.c use the older and more +-portable scheme of shortening a file by copying to a temporary file +-and back again. +//GO.SYSIN DD libI77/README +echo libI77/backspace.c 1>&2 +sed >libI77/backspace.c <<'//GO.SYSIN DD libI77/backspace.c' 's/^-//' +-#include "f2c.h" +-#include "fio.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-#ifdef KR_headers +-integer f_back(a) alist *a; +-#else +-integer f_back(alist *a) +-#endif +-{ unit *b; +- OFF_T v, w, x, y, z; +- uiolen n; +- FILE *f; +- +- f__curunit = b = &f__units[a->aunit]; /* curunit for error messages */ +- if(a->aunit >= MXUNIT || a->aunit < 0) +- err(a->aerr,101,"backspace") +- if(b->useek==0) err(a->aerr,106,"backspace") +- if(b->ufd == NULL) { +- fk_open(1, 1, a->aunit); +- return(0); +- } +- if(b->uend==1) +- { b->uend=0; +- return(0); +- } +- if(b->uwrt) { +- t_runc(a); +- if (f__nowreading(b)) +- err(a->aerr,errno,"backspace") +- } +- f = b->ufd; /* may have changed in t_runc() */ +- if(b->url>0) +- { +- x=FTELL(f); +- y = x % b->url; +- if(y == 0) x--; +- x /= b->url; +- x *= b->url; +- (void) FSEEK(f,x,SEEK_SET); +- return(0); +- } +- +- if(b->ufmt==0) +- { FSEEK(f,-(OFF_T)sizeof(uiolen),SEEK_CUR); +- fread((char *)&n,sizeof(uiolen),1,f); +- FSEEK(f,-(OFF_T)n-2*sizeof(uiolen),SEEK_CUR); +- return(0); +- } +- w = x = FTELL(f); +- z = 0; +- loop: +- while(x) { +- x -= x < 64 ? x : 64; +- FSEEK(f,x,SEEK_SET); +- for(y = x; y < w; y++) { +- if (getc(f) != '\n') +- continue; +- v = FTELL(f); +- if (v == w) { +- if (z) +- goto break2; +- goto loop; +- } +- z = v; +- } +- err(a->aerr,(EOF),"backspace") +- } +- break2: +- FSEEK(f, z, SEEK_SET); +- return 0; +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libI77/backspace.c +echo libI77/close.c 1>&2 +sed >libI77/close.c <<'//GO.SYSIN DD libI77/close.c' 's/^-//' +-#include "f2c.h" +-#include "fio.h" +-#ifdef KR_headers +-integer f_clos(a) cllist *a; +-#else +-#undef abs +-#undef min +-#undef max +-#include "stdlib.h" +-#ifdef NON_UNIX_STDIO +-#ifndef unlink +-#define unlink remove +-#endif +-#else +-#ifdef MSDOS +-#include "io.h" +-#else +-#ifdef __cplusplus +-extern "C" int unlink(const char*); +-#else +-extern int unlink(const char*); +-#endif +-#endif +-#endif +- +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-integer f_clos(cllist *a) +-#endif +-{ unit *b; +- +- if(a->cunit >= MXUNIT) return(0); +- b= &f__units[a->cunit]; +- if(b->ufd==NULL) +- goto done; +- if (b->uscrtch == 1) +- goto Delete; +- if (!a->csta) +- goto Keep; +- switch(*a->csta) { +- default: +- Keep: +- case 'k': +- case 'K': +- if(b->uwrt == 1) +- t_runc((alist *)a); +- if(b->ufnm) { +- fclose(b->ufd); +- free(b->ufnm); +- } +- break; +- case 'd': +- case 'D': +- Delete: +- fclose(b->ufd); +- if(b->ufnm) { +- unlink(b->ufnm); /*SYSDEP*/ +- free(b->ufnm); +- } +- } +- b->ufd=NULL; +- done: +- b->uend=0; +- b->ufnm=NULL; +- return(0); +- } +- void +-#ifdef KR_headers +-f_exit() +-#else +-f_exit(void) +-#endif +-{ int i; +- static cllist xx; +- if (!xx.cerr) { +- xx.cerr=1; +- xx.csta=NULL; +- for(i=0;i<MXUNIT;i++) +- { +- xx.cunit=i; +- (void) f_clos(&xx); +- } +- } +-} +- int +-#ifdef KR_headers +-flush_() +-#else +-flush_(void) +-#endif +-{ int i; +- for(i=0;i<MXUNIT;i++) +- if(f__units[i].ufd != NULL && f__units[i].uwrt) +- fflush(f__units[i].ufd); +-return 0; +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libI77/close.c +echo libI77/dfe.c 1>&2 +sed >libI77/dfe.c <<'//GO.SYSIN DD libI77/dfe.c' 's/^-//' +-#include "f2c.h" +-#include "fio.h" +-#include "fmt.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +- int +-y_rsk(Void) +-{ +- if(f__curunit->uend || f__curunit->url <= f__recpos +- || f__curunit->url == 1) return 0; +- do { +- getc(f__cf); +- } while(++f__recpos < f__curunit->url); +- return 0; +-} +- +- int +-y_getc(Void) +-{ +- int ch; +- if(f__curunit->uend) return(-1); +- if((ch=getc(f__cf))!=EOF) +- { +- f__recpos++; +- if(f__curunit->url>=f__recpos || +- f__curunit->url==1) +- return(ch); +- else return(' '); +- } +- if(feof(f__cf)) +- { +- f__curunit->uend=1; +- errno=0; +- return(-1); +- } +- err(f__elist->cierr,errno,"readingd"); +-} +- +- static int +-y_rev(Void) +-{ +- if (f__recpos < f__hiwater) +- f__recpos = f__hiwater; +- if (f__curunit->url > 1) +- while(f__recpos < f__curunit->url) +- (*f__putn)(' '); +- if (f__recpos) +- f__putbuf(0); +- f__recpos = 0; +- return(0); +-} +- +- static int +-y_err(Void) +-{ +- err(f__elist->cierr, 110, "dfe"); +-} +- +- static int +-y_newrec(Void) +-{ +- y_rev(); +- f__hiwater = f__cursor = 0; +- return(1); +-} +- +- int +-#ifdef KR_headers +-c_dfe(a) cilist *a; +-#else +-c_dfe(cilist *a) +-#endif +-{ +- f__sequential=0; +- f__formatted=f__external=1; +- f__elist=a; +- f__cursor=f__scale=f__recpos=0; +- f__curunit = &f__units[a->ciunit]; +- if(a->ciunit>MXUNIT || a->ciunit<0) +- err(a->cierr,101,"startchk"); +- if(f__curunit->ufd==NULL && fk_open(DIR,FMT,a->ciunit)) +- err(a->cierr,104,"dfe"); +- f__cf=f__curunit->ufd; +- if(!f__curunit->ufmt) err(a->cierr,102,"dfe") +- if(!f__curunit->useek) err(a->cierr,104,"dfe") +- f__fmtbuf=a->cifmt; +- if(a->cirec <= 0) +- err(a->cierr,130,"dfe") +- FSEEK(f__cf,(OFF_T)f__curunit->url * (a->cirec-1),SEEK_SET); +- f__curunit->uend = 0; +- return(0); +-} +-#ifdef KR_headers +-integer s_rdfe(a) cilist *a; +-#else +-integer s_rdfe(cilist *a) +-#endif +-{ +- int n; +- if(!f__init) f_init(); +- f__reading=1; +- if(n=c_dfe(a))return(n); +- if(f__curunit->uwrt && f__nowreading(f__curunit)) +- err(a->cierr,errno,"read start"); +- f__getn = y_getc; +- f__doed = rd_ed; +- f__doned = rd_ned; +- f__dorevert = f__donewrec = y_err; +- f__doend = y_rsk; +- if(pars_f(f__fmtbuf)<0) +- err(a->cierr,100,"read start"); +- fmt_bg(); +- return(0); +-} +-#ifdef KR_headers +-integer s_wdfe(a) cilist *a; +-#else +-integer s_wdfe(cilist *a) +-#endif +-{ +- int n; +- if(!f__init) f_init(); +- f__reading=0; +- if(n=c_dfe(a)) return(n); +- if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit)) +- err(a->cierr,errno,"startwrt"); +- f__putn = x_putc; +- f__doed = w_ed; +- f__doned= w_ned; +- f__dorevert = y_err; +- f__donewrec = y_newrec; +- f__doend = y_rev; +- if(pars_f(f__fmtbuf)<0) +- err(a->cierr,100,"startwrt"); +- fmt_bg(); +- return(0); +-} +-integer e_rdfe(Void) +-{ +- en_fio(); +- return 0; +-} +-integer e_wdfe(Void) +-{ +- return en_fio(); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libI77/dfe.c +echo libI77/dolio.c 1>&2 +sed >libI77/dolio.c <<'//GO.SYSIN DD libI77/dolio.c' 's/^-//' +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-#ifdef __cplusplus +-extern "C" { +-#endif +-#ifdef KR_headers +-extern int (*f__lioproc)(); +- +-integer do_lio(type,number,ptr,len) ftnint *number,*type; char *ptr; ftnlen len; +-#else +-extern int (*f__lioproc)(ftnint*, char*, ftnlen, ftnint); +- +-integer do_lio(ftnint *type, ftnint *number, char *ptr, ftnlen len) +-#endif +-{ +- return((*f__lioproc)(number,ptr,len,*type)); +-} +-#ifdef __cplusplus +- } +-#endif +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libI77/dolio.c +echo libI77/due.c 1>&2 +sed >libI77/due.c <<'//GO.SYSIN DD libI77/due.c' 's/^-//' +-#include "f2c.h" +-#include "fio.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +- int +-#ifdef KR_headers +-c_due(a) cilist *a; +-#else +-c_due(cilist *a) +-#endif +-{ +- if(!f__init) f_init(); +- f__sequential=f__formatted=f__recpos=0; +- f__external=1; +- f__curunit = &f__units[a->ciunit]; +- if(a->ciunit>=MXUNIT || a->ciunit<0) +- err(a->cierr,101,"startio"); +- f__elist=a; +- if(f__curunit->ufd==NULL && fk_open(DIR,UNF,a->ciunit) ) err(a->cierr,104,"due"); +- f__cf=f__curunit->ufd; +- if(f__curunit->ufmt) err(a->cierr,102,"cdue") +- if(!f__curunit->useek) err(a->cierr,104,"cdue") +- if(f__curunit->ufd==NULL) err(a->cierr,114,"cdue") +- if(a->cirec <= 0) +- err(a->cierr,130,"due") +- FSEEK(f__cf,(OFF_T)(a->cirec-1)*f__curunit->url,SEEK_SET); +- f__curunit->uend = 0; +- return(0); +-} +-#ifdef KR_headers +-integer s_rdue(a) cilist *a; +-#else +-integer s_rdue(cilist *a) +-#endif +-{ +- int n; +- f__reading=1; +- if(n=c_due(a)) return(n); +- if(f__curunit->uwrt && f__nowreading(f__curunit)) +- err(a->cierr,errno,"read start"); +- return(0); +-} +-#ifdef KR_headers +-integer s_wdue(a) cilist *a; +-#else +-integer s_wdue(cilist *a) +-#endif +-{ +- int n; +- f__reading=0; +- if(n=c_due(a)) return(n); +- if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit)) +- err(a->cierr,errno,"write start"); +- return(0); +-} +-integer e_rdue(Void) +-{ +- if(f__curunit->url==1 || f__recpos==f__curunit->url) +- return(0); +- FSEEK(f__cf,(OFF_T)(f__curunit->url-f__recpos),SEEK_CUR); +- if(FTELL(f__cf)%f__curunit->url) +- err(f__elist->cierr,200,"syserr"); +- return(0); +-} +-integer e_wdue(Void) +-{ +-#ifdef ALWAYS_FLUSH +- if (fflush(f__cf)) +- err(f__elist->cierr,errno,"write end"); +-#endif +- return(e_rdue()); +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libI77/due.c +echo libI77/endfile.c 1>&2 +sed >libI77/endfile.c <<'//GO.SYSIN DD libI77/endfile.c' 's/^-//' +-#include "f2c.h" +-#include "fio.h" +- +-/* Compile this with -DNO_TRUNCATE if unistd.h does not exist or */ +-/* if it does not define int truncate(const char *name, off_t). */ +- +-#ifdef MSDOS +-#undef NO_TRUNCATE +-#define NO_TRUNCATE +-#endif +- +-#ifndef NO_TRUNCATE +-#include "unistd.h" +-#endif +- +-#ifdef KR_headers +-extern char *strcpy(); +-extern FILE *tmpfile(); +-#else +-#undef abs +-#undef min +-#undef max +-#include "stdlib.h" +-#include "string.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-#endif +- +-extern char *f__r_mode[], *f__w_mode[]; +- +-#ifdef KR_headers +-integer f_end(a) alist *a; +-#else +-integer f_end(alist *a) +-#endif +-{ +- unit *b; +- FILE *tf; +- +- if(a->aunit>=MXUNIT || a->aunit<0) err(a->aerr,101,"endfile"); +- b = &f__units[a->aunit]; +- if(b->ufd==NULL) { +- char nbuf[10]; +- sprintf(nbuf,"fort.%ld",(long)a->aunit); +- if (tf = FOPEN(nbuf, f__w_mode[0])) +- fclose(tf); +- return(0); +- } +- b->uend=1; +- return(b->useek ? t_runc(a) : 0); +-} +- +-#ifdef NO_TRUNCATE +- static int +-#ifdef KR_headers +-copy(from, len, to) FILE *from, *to; register long len; +-#else +-copy(FILE *from, register long len, FILE *to) +-#endif +-{ +- int len1; +- char buf[BUFSIZ]; +- +- while(fread(buf, len1 = len > BUFSIZ ? BUFSIZ : (int)len, 1, from)) { +- if (!fwrite(buf, len1, 1, to)) +- return 1; +- if ((len -= len1) <= 0) +- break; +- } +- return 0; +- } +-#endif /* NO_TRUNCATE */ +- +- int +-#ifdef KR_headers +-t_runc(a) alist *a; +-#else +-t_runc(alist *a) +-#endif +-{ +- OFF_T loc, len; +- unit *b; +- int rc; +- FILE *bf; +-#ifdef NO_TRUNCATE +- FILE *tf; +-#endif +- +- b = &f__units[a->aunit]; +- if(b->url) +- return(0); /*don't truncate direct files*/ +- loc=FTELL(bf = b->ufd); +- FSEEK(bf,(OFF_T)0,SEEK_END); +- len=FTELL(bf); +- if (loc >= len || b->useek == 0) +- return(0); +-#ifdef NO_TRUNCATE +- if (b->ufnm == NULL) +- return 0; +- rc = 0; +- fclose(b->ufd); +- if (!loc) { +- if (!(bf = FOPEN(b->ufnm, f__w_mode[b->ufmt]))) +- rc = 1; +- if (b->uwrt) +- b->uwrt = 1; +- goto done; +- } +- if (!(bf = FOPEN(b->ufnm, f__r_mode[0])) +- || !(tf = tmpfile())) { +-#ifdef NON_UNIX_STDIO +- bad: +-#endif +- rc = 1; +- goto done; +- } +- if (copy(bf, (long)loc, tf)) { +- bad1: +- rc = 1; +- goto done1; +- } +- if (!(bf = FREOPEN(b->ufnm, f__w_mode[0], bf))) +- goto bad1; +- rewind(tf); +- if (copy(tf, (long)loc, bf)) +- goto bad1; +- b->uwrt = 1; +- b->urw = 2; +-#ifdef NON_UNIX_STDIO +- if (b->ufmt) { +- fclose(bf); +- if (!(bf = FOPEN(b->ufnm, f__w_mode[3]))) +- goto bad; +- FSEEK(bf,(OFF_T)0,SEEK_END); +- b->urw = 3; +- } +-#endif +-done1: +- fclose(tf); +-done: +- f__cf = b->ufd = bf; +-#else /* NO_TRUNCATE */ +- if (b->urw & 2) +- fflush(b->ufd); /* necessary on some Linux systems */ +-#ifndef FTRUNCATE +-#define FTRUNCATE ftruncate +-#endif +- rc = FTRUNCATE(fileno(b->ufd), loc); +- /* The following FSEEK is unnecessary on some systems, */ +- /* but should be harmless. */ +- FSEEK(b->ufd, (OFF_T)0, SEEK_END); +-#endif /* NO_TRUNCATE */ +- if (rc) +- err(a->aerr,111,"endfile"); +- return 0; +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libI77/endfile.c +echo libI77/err.c 1>&2 +sed >libI77/err.c <<'//GO.SYSIN DD libI77/err.c' 's/^-//' +-#include "sysdep1.h" /* here to get stat64 on some badly designed Linux systems */ +-#include "f2c.h" +-#ifdef KR_headers +-extern char *malloc(); +-#else +-#undef abs +-#undef min +-#undef max +-#include "stdlib.h" +-#endif +-#include "fio.h" +-#include "fmt.h" /* for struct syl */ +-#ifdef __cplusplus +-extern "C" { +-#endif +- +-/*global definitions*/ +-unit f__units[MXUNIT]; /*unit table*/ +-flag f__init; /*0 on entry, 1 after initializations*/ +-cilist *f__elist; /*active external io list*/ +-icilist *f__svic; /*active internal io list*/ +-flag f__reading; /*1 if reading, 0 if writing*/ +-flag f__cplus,f__cblank; +-char *f__fmtbuf; +-flag f__external; /*1 if external io, 0 if internal */ +-#ifdef KR_headers +-int (*f__doed)(),(*f__doned)(); +-int (*f__doend)(),(*f__donewrec)(),(*f__dorevert)(); +-int (*f__getn)(); /* for formatted input */ +-void (*f__putn)(); /* for formatted output */ +-#else +-int (*f__getn)(void); /* for formatted input */ +-void (*f__putn)(int); /* for formatted output */ +-int (*f__doed)(struct syl*, char*, ftnlen),(*f__doned)(struct syl*); +-int (*f__dorevert)(void),(*f__donewrec)(void),(*f__doend)(void); +-#endif +-flag f__sequential; /*1 if sequential io, 0 if direct*/ +-flag f__formatted; /*1 if formatted io, 0 if unformatted*/ +-FILE *f__cf; /*current file*/ +-unit *f__curunit; /*current unit*/ +-int f__recpos; /*place in current record*/ +-OFF_T f__cursor, f__hiwater; +-int f__scale; +-char *f__icptr; +- +-/*error messages*/ +-char *F_err[] = +-{ +- "error in format", /* 100 */ +- "illegal unit number", /* 101 */ +- "formatted io not allowed", /* 102 */ +- "unformatted io not allowed", /* 103 */ +- "direct io not allowed", /* 104 */ +- "sequential io not allowed", /* 105 */ +- "can't backspace file", /* 106 */ +- "null file name", /* 107 */ +- "can't stat file", /* 108 */ +- "unit not connected", /* 109 */ +- "off end of record", /* 110 */ +- "truncation failed in endfile", /* 111 */ +- "incomprehensible list input", /* 112 */ +- "out of free space", /* 113 */ +- "unit not connected", /* 114 */ +- "read unexpected character", /* 115 */ +- "bad logical input field", /* 116 */ +- "bad variable type", /* 117 */ +- "bad namelist name", /* 118 */ +- "variable not in namelist", /* 119 */ +- "no end record", /* 120 */ +- "variable count incorrect", /* 121 */ +- "subscript for scalar variable", /* 122 */ +- "invalid array section", /* 123 */ +- "substring out of bounds", /* 124 */ +- "subscript out of bounds", /* 125 */ +- "can't read file", /* 126 */ +- "can't write file", /* 127 */ +- "'new' file exists", /* 128 */ +- "can't append to file", /* 129 */ +- "non-positive record number", /* 130 */ +- "nmLbuf overflow" /* 131 */ +-}; +-#define MAXERR (sizeof(F_err)/sizeof(char *)+100) +- +- int +-#ifdef KR_headers +-f__canseek(f) FILE *f; /*SYSDEP*/ +-#else +-f__canseek(FILE *f) /*SYSDEP*/ +-#endif +-{ +-#ifdef NON_UNIX_STDIO +- return !isatty(fileno(f)); +-#else +- struct STAT_ST x; +- +- if (FSTAT(fileno(f),&x) < 0) +- return(0); +-#ifdef S_IFMT +- switch(x.st_mode & S_IFMT) { +- case S_IFDIR: +- case S_IFREG: +- if(x.st_nlink > 0) /* !pipe */ +- return(1); +- else +- return(0); +- case S_IFCHR: +- if(isatty(fileno(f))) +- return(0); +- return(1); +-#ifdef S_IFBLK +- case S_IFBLK: +- return(1); +-#endif +- } +-#else +-#ifdef S_ISDIR +- /* POSIX version */ +- if (S_ISREG(x.st_mode) || S_ISDIR(x.st_mode)) { +- if(x.st_nlink > 0) /* !pipe */ +- return(1); +- else +- return(0); +- } +- if (S_ISCHR(x.st_mode)) { +- if(isatty(fileno(f))) +- return(0); +- return(1); +- } +- if (S_ISBLK(x.st_mode)) +- return(1); +-#else +- Help! How does fstat work on this system? +-#endif +-#endif +- return(0); /* who knows what it is? */ +-#endif +-} +- +- void +-#ifdef KR_headers +-f__fatal(n,s) char *s; +-#else +-f__fatal(int n, char *s) +-#endif +-{ +- if(n<100 && n>=0) perror(s); /*SYSDEP*/ +- else if(n >= (int)MAXERR || n < -1) +- { fprintf(stderr,"%s: illegal error number %d\n",s,n); +- } +- else if(n == -1) fprintf(stderr,"%s: end of file\n",s); +- else +- fprintf(stderr,"%s: %s\n",s,F_err[n-100]); +- if (f__curunit) { +- fprintf(stderr,"apparent state: unit %d ", +- (int)(f__curunit-f__units)); +- fprintf(stderr, f__curunit->ufnm ? "named %s\n" : "(unnamed)\n", +- f__curunit->ufnm); +- } +- else +- fprintf(stderr,"apparent state: internal I/O\n"); +- if (f__fmtbuf) +- fprintf(stderr,"last format: %s\n",f__fmtbuf); +- fprintf(stderr,"lately %s %s %s %s",f__reading?"reading":"writing", +- f__sequential?"sequential":"direct",f__formatted?"formatted":"unformatted", +- f__external?"external":"internal"); +- sig_die(" IO", 1); +-} +-/*initialization routine*/ +- VOID +-f_init(Void) +-{ unit *p; +- +- f__init=1; +- p= &f__units[0]; +- p->ufd=stderr; +- p->useek=f__canseek(stderr); +- p->ufmt=1; +- p->uwrt=1; +- p = &f__units[5]; +- p->ufd=stdin; +- p->useek=f__canseek(stdin); +- p->ufmt=1; +- p->uwrt=0; +- p= &f__units[6]; +- p->ufd=stdout; +- p->useek=f__canseek(stdout); +- p->ufmt=1; +- p->uwrt=1; +-} +- +- int +-#ifdef KR_headers +-f__nowreading(x) unit *x; +-#else +-f__nowreading(unit *x) +-#endif +-{ +- OFF_T loc; +- int ufmt, urw; +- extern char *f__r_mode[], *f__w_mode[]; +- +- if (x->urw & 1) +- goto done; +- if (!x->ufnm) +- goto cantread; +- ufmt = x->url ? 0 : x->ufmt; +- loc = FTELL(x->ufd); +- urw = 3; +- if (!FREOPEN(x->ufnm, f__w_mode[ufmt|2], x->ufd)) { +- urw = 1; +- if(!FREOPEN(x->ufnm, f__r_mode[ufmt], x->ufd)) { +- cantread: +- errno = 126; +- return 1; +- } +- } +- FSEEK(x->ufd,loc,SEEK_SET); +- x->urw = urw; +- done: +- x->uwrt = 0; +- return 0; +-} +- +- int +-#ifdef KR_headers +-f__nowwriting(x) unit *x; +-#else +-f__nowwriting(unit *x) +-#endif +-{ +- OFF_T loc; +- int ufmt; +- extern char *f__w_mode[]; +- +- if (x->urw & 2) { +- if (x->urw & 1) +- FSEEK(x->ufd, (OFF_T)0, SEEK_CUR); +- goto done; +- } +- if (!x->ufnm) +- goto cantwrite; +- ufmt = x->url ? 0 : x->ufmt; +- if (x->uwrt == 3) { /* just did write, rewind */ +- if (!(f__cf = x->ufd = +- FREOPEN(x->ufnm,f__w_mode[ufmt],x->ufd))) +- goto cantwrite; +- x->urw = 2; +- } +- else { +- loc=FTELL(x->ufd); +- if (!(f__cf = x->ufd = +- FREOPEN(x->ufnm, f__w_mode[ufmt | 2], x->ufd))) +- { +- x->ufd = NULL; +- cantwrite: +- errno = 127; +- return(1); +- } +- x->urw = 3; +- FSEEK(x->ufd,loc,SEEK_SET); +- } +- done: +- x->uwrt = 1; +- return 0; +-} +- +- int +-#ifdef KR_headers +-err__fl(f, m, s) int f, m; char *s; +-#else +-err__fl(int f, int m, char *s) +-#endif +-{ +- if (!f) +- f__fatal(m, s); +- if (f__doend) +- (*f__doend)(); +- return errno = m; +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libI77/err.c +echo libI77/f2ch.add 1>&2 +sed >libI77/f2ch.add <<'//GO.SYSIN DD libI77/f2ch.add' 's/^-//' +-/* If you are using a C++ compiler, append the following to f2c.h +- for compiling libF77 and libI77. */ +- +-#ifdef __cplusplus +-extern "C" { +-extern int abort_(void); +-extern double c_abs(complex *); +-extern void c_cos(complex *, complex *); +-extern void c_div(complex *, complex *, complex *); +-extern void c_exp(complex *, complex *); +-extern void c_log(complex *, complex *); +-extern void c_sin(complex *, complex *); +-extern void c_sqrt(complex *, complex *); +-extern double d_abs(double *); +-extern double d_acos(double *); +-extern double d_asin(double *); +-extern double d_atan(double *); +-extern double d_atn2(double *, double *); +-extern void d_cnjg(doublecomplex *, doublecomplex *); +-extern double d_cos(double *); +-extern double d_cosh(double *); +-extern double d_dim(double *, double *); +-extern double d_exp(double *); +-extern double d_imag(doublecomplex *); +-extern double d_int(double *); +-extern double d_lg10(double *); +-extern double d_log(double *); +-extern double d_mod(double *, double *); +-extern double d_nint(double *); +-extern double d_prod(float *, float *); +-extern double d_sign(double *, double *); +-extern double d_sin(double *); +-extern double d_sinh(double *); +-extern double d_sqrt(double *); +-extern double d_tan(double *); +-extern double d_tanh(double *); +-extern double derf_(double *); +-extern double derfc_(double *); +-extern integer do_fio(ftnint *, char *, ftnlen); +-extern integer do_lio(ftnint *, ftnint *, char *, ftnlen); +-extern integer do_uio(ftnint *, char *, ftnlen); +-extern integer e_rdfe(void); +-extern integer e_rdue(void); +-extern integer e_rsfe(void); +-extern integer e_rsfi(void); +-extern integer e_rsle(void); +-extern integer e_rsli(void); +-extern integer e_rsue(void); +-extern integer e_wdfe(void); +-extern integer e_wdue(void); +-extern integer e_wsfe(void); +-extern integer e_wsfi(void); +-extern integer e_wsle(void); +-extern integer e_wsli(void); +-extern integer e_wsue(void); +-extern int ef1asc_(ftnint *, ftnlen *, ftnint *, ftnlen *); +-extern integer ef1cmc_(ftnint *, ftnlen *, ftnint *, ftnlen *); +-extern double erf(double); +-extern double erf_(float *); +-extern double erfc(double); +-extern double erfc_(float *); +-extern integer f_back(alist *); +-extern integer f_clos(cllist *); +-extern integer f_end(alist *); +-extern void f_exit(void); +-extern integer f_inqu(inlist *); +-extern integer f_open(olist *); +-extern integer f_rew(alist *); +-extern int flush_(void); +-extern void getarg_(integer *, char *, ftnlen); +-extern void getenv_(char *, char *, ftnlen, ftnlen); +-extern short h_abs(short *); +-extern short h_dim(short *, short *); +-extern short h_dnnt(double *); +-extern short h_indx(char *, char *, ftnlen, ftnlen); +-extern short h_len(char *, ftnlen); +-extern short h_mod(short *, short *); +-extern short h_nint(float *); +-extern short h_sign(short *, short *); +-extern short hl_ge(char *, char *, ftnlen, ftnlen); +-extern short hl_gt(char *, char *, ftnlen, ftnlen); +-extern short hl_le(char *, char *, ftnlen, ftnlen); +-extern short hl_lt(char *, char *, ftnlen, ftnlen); +-extern integer i_abs(integer *); +-extern integer i_dim(integer *, integer *); +-extern integer i_dnnt(double *); +-extern integer i_indx(char *, char *, ftnlen, ftnlen); +-extern integer i_len(char *, ftnlen); +-extern integer i_mod(integer *, integer *); +-extern integer i_nint(float *); +-extern integer i_sign(integer *, integer *); +-extern integer iargc_(void); +-extern ftnlen l_ge(char *, char *, ftnlen, ftnlen); +-extern ftnlen l_gt(char *, char *, ftnlen, ftnlen); +-extern ftnlen l_le(char *, char *, ftnlen, ftnlen); +-extern ftnlen l_lt(char *, char *, ftnlen, ftnlen); +-extern void pow_ci(complex *, complex *, integer *); +-extern double pow_dd(double *, double *); +-extern double pow_di(double *, integer *); +-extern short pow_hh(short *, shortint *); +-extern integer pow_ii(integer *, integer *); +-extern double pow_ri(float *, integer *); +-extern void pow_zi(doublecomplex *, doublecomplex *, integer *); +-extern void pow_zz(doublecomplex *, doublecomplex *, doublecomplex *); +-extern double r_abs(float *); +-extern double r_acos(float *); +-extern double r_asin(float *); +-extern double r_atan(float *); +-extern double r_atn2(float *, float *); +-extern void r_cnjg(complex *, complex *); +-extern double r_cos(float *); +-extern double r_cosh(float *); +-extern double r_dim(float *, float *); +-extern double r_exp(float *); +-extern double r_imag(complex *); +-extern double r_int(float *); +-extern double r_lg10(float *); +-extern double r_log(float *); +-extern double r_mod(float *, float *); +-extern double r_nint(float *); +-extern double r_sign(float *, float *); +-extern double r_sin(float *); +-extern double r_sinh(float *); +-extern double r_sqrt(float *); +-extern double r_tan(float *); +-extern double r_tanh(float *); +-extern void s_cat(char *, char **, integer *, integer *, ftnlen); +-extern integer s_cmp(char *, char *, ftnlen, ftnlen); +-extern void s_copy(char *, char *, ftnlen, ftnlen); +-extern int s_paus(char *, ftnlen); +-extern integer s_rdfe(cilist *); +-extern integer s_rdue(cilist *); +-extern integer s_rnge(char *, integer, char *, integer); +-extern integer s_rsfe(cilist *); +-extern integer s_rsfi(icilist *); +-extern integer s_rsle(cilist *); +-extern integer s_rsli(icilist *); +-extern integer s_rsne(cilist *); +-extern integer s_rsni(icilist *); +-extern integer s_rsue(cilist *); +-extern int s_stop(char *, ftnlen); +-extern integer s_wdfe(cilist *); +-extern integer s_wdue(cilist *); +-extern integer s_wsfe(cilist *); +-extern integer s_wsfi(icilist *); +-extern integer s_wsle(cilist *); +-extern integer s_wsli(icilist *); +-extern integer s_wsne(cilist *); +-extern integer s_wsni(icilist *); +-extern integer s_wsue(cilist *); +-extern void sig_die(char *, int); +-extern integer signal_(integer *, void (*)(int)); +-extern integer system_(char *, ftnlen); +-extern double z_abs(doublecomplex *); +-extern void z_cos(doublecomplex *, doublecomplex *); +-extern void z_div(doublecomplex *, doublecomplex *, doublecomplex *); +-extern void z_exp(doublecomplex *, doublecomplex *); +-extern void z_log(doublecomplex *, doublecomplex *); +-extern void z_sin(doublecomplex *, doublecomplex *); +-extern void z_sqrt(doublecomplex *, doublecomplex *); +- } +-#endif +//GO.SYSIN DD libI77/f2ch.add +echo libI77/fio.h 1>&2 +sed >libI77/fio.h <<'//GO.SYSIN DD libI77/fio.h' 's/^-//' +-#ifndef SYSDEP_H_INCLUDED +-#include "sysdep1.h" +-#endif +-#include "stdio.h" +-#include "errno.h" +-#ifndef NULL +-/* ANSI C */ +-#include "stddef.h" +-#endif +- +-#ifndef SEEK_SET +-#define SEEK_SET 0 +-#define SEEK_CUR 1 +-#define SEEK_END 2 +-#endif +- +-#ifndef FOPEN +-#define FOPEN fopen +-#endif +- +-#ifndef FREOPEN +-#define FREOPEN freopen +-#endif +- +-#ifndef FSEEK +-#define FSEEK fseek +-#endif +- +-#ifndef FSTAT +-#define FSTAT fstat +-#endif +- +-#ifndef FTELL +-#define FTELL ftell +-#endif +- +-#ifndef OFF_T +-#define OFF_T long +-#endif +- +-#ifndef STAT_ST +-#define STAT_ST stat +-#endif +- +-#ifndef STAT +-#define STAT stat +-#endif +- +-#ifdef MSDOS +-#ifndef NON_UNIX_STDIO +-#define NON_UNIX_STDIO +-#endif +-#endif +- +-#ifdef UIOLEN_int +-typedef int uiolen; +-#else +-typedef long uiolen; +-#endif +- +-/*units*/ +-typedef struct +-{ FILE *ufd; /*0=unconnected*/ +- char *ufnm; +-#ifndef MSDOS +- long uinode; +- int udev; +-#endif +- int url; /*0=sequential*/ +- flag useek; /*true=can backspace, use dir, ...*/ +- flag ufmt; +- flag urw; /* (1 for can read) | (2 for can write) */ +- flag ublnk; +- flag uend; +- flag uwrt; /*last io was write*/ +- flag uscrtch; +-} unit; +- +-extern flag f__init; +-extern cilist *f__elist; /*active external io list*/ +-extern flag f__reading,f__external,f__sequential,f__formatted; +-#undef Void +-#ifdef KR_headers +-#define Void /*void*/ +-extern int (*f__getn)(); /* for formatted input */ +-extern void (*f__putn)(); /* for formatted output */ +-extern void x_putc(); +-extern long f__inode(); +-extern VOID sig_die(); +-extern int (*f__donewrec)(), t_putc(), x_wSL(); +-extern int c_sfe(), err__fl(), xrd_SL(), f__putbuf(); +-#else +-#define Void void +-#ifdef __cplusplus +-extern "C" { +-#endif +-extern int (*f__getn)(void); /* for formatted input */ +-extern void (*f__putn)(int); /* for formatted output */ +-extern void x_putc(int); +-extern long f__inode(char*,int*); +-extern void sig_die(char*,int); +-extern void f__fatal(int,char*); +-extern int t_runc(alist*); +-extern int f__nowreading(unit*), f__nowwriting(unit*); +-extern int fk_open(int,int,ftnint); +-extern int en_fio(void); +-extern void f_init(void); +-extern int (*f__donewrec)(void), t_putc(int), x_wSL(void); +-extern void b_char(char*,char*,ftnlen), g_char(char*,ftnlen,char*); +-extern int c_sfe(cilist*), z_rnew(void); +-extern int isatty(int); +-extern int err__fl(int,int,char*); +-extern int xrd_SL(void); +-extern int f__putbuf(int); +-#ifdef __cplusplus +- } +-#endif +-#endif +-extern int (*f__doend)(Void); +-extern FILE *f__cf; /*current file*/ +-extern unit *f__curunit; /*current unit*/ +-extern unit f__units[]; +-#define err(f,m,s) {if(f) errno= m; else f__fatal(m,s); return(m);} +-#define errfl(f,m,s) return err__fl((int)f,m,s) +- +-/*Table sizes*/ +-#define MXUNIT 100 +- +-extern int f__recpos; /*position in current record*/ +-extern OFF_T f__cursor; /* offset to move to */ +-extern OFF_T f__hiwater; /* so TL doesn't confuse us */ +- +-#define WRITE 1 +-#define READ 2 +-#define SEQ 3 +-#define DIR 4 +-#define FMT 5 +-#define UNF 6 +-#define EXT 7 +-#define INT 8 +- +-#define buf_end(x) (x->_flag & _IONBF ? x->_ptr : x->_base + BUFSIZ) +//GO.SYSIN DD libI77/fio.h +echo libI77/fmt.c 1>&2 +sed >libI77/fmt.c <<'//GO.SYSIN DD libI77/fmt.c' 's/^-//' +-#include "f2c.h" +-#include "fio.h" +-#include "fmt.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-#define skip(s) while(*s==' ') s++ +-#ifdef interdata +-#define SYLMX 300 +-#endif +-#ifdef pdp11 +-#define SYLMX 300 +-#endif +-#ifdef vax +-#define SYLMX 300 +-#endif +-#ifndef SYLMX +-#define SYLMX 300 +-#endif +-#define GLITCH '\2' +- /* special quote character for stu */ +-extern flag f__cblank,f__cplus; /*blanks in I and compulsory plus*/ +-static struct syl f__syl[SYLMX]; +-int f__parenlvl,f__pc,f__revloc; +- +- static +-#ifdef KR_headers +-char *ap_end(s) char *s; +-#else +-char *ap_end(char *s) +-#endif +-{ char quote; +- quote= *s++; +- for(;*s;s++) +- { if(*s!=quote) continue; +- if(*++s!=quote) return(s); +- } +- if(f__elist->cierr) { +- errno = 100; +- return(NULL); +- } +- f__fatal(100, "bad string"); +- /*NOTREACHED*/ return 0; +-} +- static int +-#ifdef KR_headers +-op_gen(a,b,c,d) +-#else +-op_gen(int a, int b, int c, int d) +-#endif +-{ struct syl *p= &f__syl[f__pc]; +- if(f__pc>=SYLMX) +- { fprintf(stderr,"format too complicated:\n"); +- sig_die(f__fmtbuf, 1); +- } +- p->op=a; +- p->p1=b; +- p->p2.i[0]=c; +- p->p2.i[1]=d; +- return(f__pc++); +-} +-#ifdef KR_headers +-static char *f_list(); +-static char *gt_num(s,n,n1) char *s; int *n, n1; +-#else +-static char *f_list(char*); +-static char *gt_num(char *s, int *n, int n1) +-#endif +-{ int m=0,f__cnt=0; +- char c; +- for(c= *s;;c = *s) +- { if(c==' ') +- { s++; +- continue; +- } +- if(c>'9' || c<'0') break; +- m=10*m+c-'0'; +- f__cnt++; +- s++; +- } +- if(f__cnt==0) { +- if (!n1) +- s = 0; +- *n=n1; +- } +- else *n=m; +- return(s); +-} +- +- static +-#ifdef KR_headers +-char *f_s(s,curloc) char *s; +-#else +-char *f_s(char *s, int curloc) +-#endif +-{ +- skip(s); +- if(*s++!='(') +- { +- return(NULL); +- } +- if(f__parenlvl++ ==1) f__revloc=curloc; +- if(op_gen(RET1,curloc,0,0)<0 || +- (s=f_list(s))==NULL) +- { +- return(NULL); +- } +- skip(s); +- return(s); +-} +- +- static int +-#ifdef KR_headers +-ne_d(s,p) char *s,**p; +-#else +-ne_d(char *s, char **p) +-#endif +-{ int n,x,sign=0; +- struct syl *sp; +- switch(*s) +- { +- default: +- return(0); +- case ':': (void) op_gen(COLON,0,0,0); break; +- case '$': +- (void) op_gen(NONL, 0, 0, 0); break; +- case 'B': +- case 'b': +- if(*++s=='z' || *s == 'Z') (void) op_gen(BZ,0,0,0); +- else (void) op_gen(BN,0,0,0); +- break; +- case 'S': +- case 's': +- if(*(s+1)=='s' || *(s+1) == 'S') +- { x=SS; +- s++; +- } +- else if(*(s+1)=='p' || *(s+1) == 'P') +- { x=SP; +- s++; +- } +- else x=S; +- (void) op_gen(x,0,0,0); +- break; +- case '/': (void) op_gen(SLASH,0,0,0); break; +- case '-': sign=1; +- case '+': s++; /*OUTRAGEOUS CODING TRICK*/ +- case '0': case '1': case '2': case '3': case '4': +- case '5': case '6': case '7': case '8': case '9': +- if (!(s=gt_num(s,&n,0))) { +- bad: *p = 0; +- return 1; +- } +- switch(*s) +- { +- default: +- return(0); +- case 'P': +- case 'p': if(sign) n= -n; (void) op_gen(P,n,0,0); break; +- case 'X': +- case 'x': (void) op_gen(X,n,0,0); break; +- case 'H': +- case 'h': +- sp = &f__syl[op_gen(H,n,0,0)]; +- sp->p2.s = s + 1; +- s+=n; +- break; +- } +- break; +- case GLITCH: +- case '"': +- case '\'': +- sp = &f__syl[op_gen(APOS,0,0,0)]; +- sp->p2.s = s; +- if((*p = ap_end(s)) == NULL) +- return(0); +- return(1); +- case 'T': +- case 't': +- if(*(s+1)=='l' || *(s+1) == 'L') +- { x=TL; +- s++; +- } +- else if(*(s+1)=='r'|| *(s+1) == 'R') +- { x=TR; +- s++; +- } +- else x=T; +- if (!(s=gt_num(s+1,&n,0))) +- goto bad; +- s--; +- (void) op_gen(x,n,0,0); +- break; +- case 'X': +- case 'x': (void) op_gen(X,1,0,0); break; +- case 'P': +- case 'p': (void) op_gen(P,1,0,0); break; +- } +- s++; +- *p=s; +- return(1); +-} +- +- static int +-#ifdef KR_headers +-e_d(s,p) char *s,**p; +-#else +-e_d(char *s, char **p) +-#endif +-{ int i,im,n,w,d,e,found=0,x=0; +- char *sv=s; +- s=gt_num(s,&n,1); +- (void) op_gen(STACK,n,0,0); +- switch(*s++) +- { +- default: break; +- case 'E': +- case 'e': x=1; +- case 'G': +- case 'g': +- found=1; +- if (!(s=gt_num(s,&w,0))) { +- bad: +- *p = 0; +- return 1; +- } +- if(w==0) break; +- if(*s=='.') { +- if (!(s=gt_num(s+1,&d,0))) +- goto bad; +- } +- else d=0; +- if(*s!='E' && *s != 'e') +- (void) op_gen(x==1?E:G,w,d,0); /* default is Ew.dE2 */ +- else { +- if (!(s=gt_num(s+1,&e,0))) +- goto bad; +- (void) op_gen(x==1?EE:GE,w,d,e); +- } +- break; +- case 'O': +- case 'o': +- i = O; +- im = OM; +- goto finish_I; +- case 'Z': +- case 'z': +- i = Z; +- im = ZM; +- goto finish_I; +- case 'L': +- case 'l': +- found=1; +- if (!(s=gt_num(s,&w,0))) +- goto bad; +- if(w==0) break; +- (void) op_gen(L,w,0,0); +- break; +- case 'A': +- case 'a': +- found=1; +- skip(s); +- if(*s>='0' && *s<='9') +- { s=gt_num(s,&w,1); +- if(w==0) break; +- (void) op_gen(AW,w,0,0); +- break; +- } +- (void) op_gen(A,0,0,0); +- break; +- case 'F': +- case 'f': +- if (!(s=gt_num(s,&w,0))) +- goto bad; +- found=1; +- if(w==0) break; +- if(*s=='.') { +- if (!(s=gt_num(s+1,&d,0))) +- goto bad; +- } +- else d=0; +- (void) op_gen(F,w,d,0); +- break; +- case 'D': +- case 'd': +- found=1; +- if (!(s=gt_num(s,&w,0))) +- goto bad; +- if(w==0) break; +- if(*s=='.') { +- if (!(s=gt_num(s+1,&d,0))) +- goto bad; +- } +- else d=0; +- (void) op_gen(D,w,d,0); +- break; +- case 'I': +- case 'i': +- i = I; +- im = IM; +- finish_I: +- if (!(s=gt_num(s,&w,0))) +- goto bad; +- found=1; +- if(w==0) break; +- if(*s!='.') +- { (void) op_gen(i,w,0,0); +- break; +- } +- if (!(s=gt_num(s+1,&d,0))) +- goto bad; +- (void) op_gen(im,w,d,0); +- break; +- } +- if(found==0) +- { f__pc--; /*unSTACK*/ +- *p=sv; +- return(0); +- } +- *p=s; +- return(1); +-} +- static +-#ifdef KR_headers +-char *i_tem(s) char *s; +-#else +-char *i_tem(char *s) +-#endif +-{ char *t; +- int n,curloc; +- if(*s==')') return(s); +- if(ne_d(s,&t)) return(t); +- if(e_d(s,&t)) return(t); +- s=gt_num(s,&n,1); +- if((curloc=op_gen(STACK,n,0,0))<0) return(NULL); +- return(f_s(s,curloc)); +-} +- +- static +-#ifdef KR_headers +-char *f_list(s) char *s; +-#else +-char *f_list(char *s) +-#endif +-{ +- for(;*s!=0;) +- { skip(s); +- if((s=i_tem(s))==NULL) return(NULL); +- skip(s); +- if(*s==',') s++; +- else if(*s==')') +- { if(--f__parenlvl==0) +- { +- (void) op_gen(REVERT,f__revloc,0,0); +- return(++s); +- } +- (void) op_gen(GOTO,0,0,0); +- return(++s); +- } +- } +- return(NULL); +-} +- +- int +-#ifdef KR_headers +-pars_f(s) char *s; +-#else +-pars_f(char *s) +-#endif +-{ +- f__parenlvl=f__revloc=f__pc=0; +- if(f_s(s,0) == NULL) +- { +- return(-1); +- } +- return(0); +-} +-#define STKSZ 10 +-int f__cnt[STKSZ],f__ret[STKSZ],f__cp,f__rp; +-flag f__workdone, f__nonl; +- +- static int +-#ifdef KR_headers +-type_f(n) +-#else +-type_f(int n) +-#endif +-{ +- switch(n) +- { +- default: +- return(n); +- case RET1: +- return(RET1); +- case REVERT: return(REVERT); +- case GOTO: return(GOTO); +- case STACK: return(STACK); +- case X: +- case SLASH: +- case APOS: case H: +- case T: case TL: case TR: +- return(NED); +- case F: +- case I: +- case IM: +- case A: case AW: +- case O: case OM: +- case L: +- case E: case EE: case D: +- case G: case GE: +- case Z: case ZM: +- return(ED); +- } +-} +-#ifdef KR_headers +-integer do_fio(number,ptr,len) ftnint *number; ftnlen len; char *ptr; +-#else +-integer do_fio(ftnint *number, char *ptr, ftnlen len) +-#endif +-{ struct syl *p; +- int n,i; +- for(i=0;i<*number;i++,ptr+=len) +- { +-loop: switch(type_f((p= &f__syl[f__pc])->op)) +- { +- default: +- fprintf(stderr,"unknown code in do_fio: %d\n%s\n", +- p->op,f__fmtbuf); +- err(f__elist->cierr,100,"do_fio"); +- case NED: +- if((*f__doned)(p)) +- { f__pc++; +- goto loop; +- } +- f__pc++; +- continue; +- case ED: +- if(f__cnt[f__cp]<=0) +- { f__cp--; +- f__pc++; +- goto loop; +- } +- if(ptr==NULL) +- return((*f__doend)()); +- f__cnt[f__cp]--; +- f__workdone=1; +- if((n=(*f__doed)(p,ptr,len))>0) +- errfl(f__elist->cierr,errno,"fmt"); +- if(n<0) +- err(f__elist->ciend,(EOF),"fmt"); +- continue; +- case STACK: +- f__cnt[++f__cp]=p->p1; +- f__pc++; +- goto loop; +- case RET1: +- f__ret[++f__rp]=p->p1; +- f__pc++; +- goto loop; +- case GOTO: +- if(--f__cnt[f__cp]<=0) +- { f__cp--; +- f__rp--; +- f__pc++; +- goto loop; +- } +- f__pc=1+f__ret[f__rp--]; +- goto loop; +- case REVERT: +- f__rp=f__cp=0; +- f__pc = p->p1; +- if(ptr==NULL) +- return((*f__doend)()); +- if(!f__workdone) return(0); +- if((n=(*f__dorevert)()) != 0) return(n); +- goto loop; +- case COLON: +- if(ptr==NULL) +- return((*f__doend)()); +- f__pc++; +- goto loop; +- case NONL: +- f__nonl = 1; +- f__pc++; +- goto loop; +- case S: +- case SS: +- f__cplus=0; +- f__pc++; +- goto loop; +- case SP: +- f__cplus = 1; +- f__pc++; +- goto loop; +- case P: f__scale=p->p1; +- f__pc++; +- goto loop; +- case BN: +- f__cblank=0; +- f__pc++; +- goto loop; +- case BZ: +- f__cblank=1; +- f__pc++; +- goto loop; +- } +- } +- return(0); +-} +- +- int +-en_fio(Void) +-{ ftnint one=1; +- return(do_fio(&one,(char *)NULL,(ftnint)0)); +-} +- +- VOID +-fmt_bg(Void) +-{ +- f__workdone=f__cp=f__rp=f__pc=f__cursor=0; +- f__cnt[0]=f__ret[0]=0; +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libI77/fmt.c +echo libI77/fmt.h 1>&2 +sed >libI77/fmt.h <<'//GO.SYSIN DD libI77/fmt.h' 's/^-//' +-struct syl +-{ int op; +- int p1; +- union { int i[2]; char *s;} p2; +- }; +-#define RET1 1 +-#define REVERT 2 +-#define GOTO 3 +-#define X 4 +-#define SLASH 5 +-#define STACK 6 +-#define I 7 +-#define ED 8 +-#define NED 9 +-#define IM 10 +-#define APOS 11 +-#define H 12 +-#define TL 13 +-#define TR 14 +-#define T 15 +-#define COLON 16 +-#define S 17 +-#define SP 18 +-#define SS 19 +-#define P 20 +-#define BN 21 +-#define BZ 22 +-#define F 23 +-#define E 24 +-#define EE 25 +-#define D 26 +-#define G 27 +-#define GE 28 +-#define L 29 +-#define A 30 +-#define AW 31 +-#define O 32 +-#define NONL 33 +-#define OM 34 +-#define Z 35 +-#define ZM 36 +-extern int f__pc,f__parenlvl,f__revloc; +-typedef union +-{ real pf; +- doublereal pd; +-} ufloat; +-typedef union +-{ short is; +-#ifndef KR_headers +- signed +-#endif +- char ic; +- integer il; +-#ifdef Allow_TYQUAD +- longint ili; +-#endif +-} Uint; +-#ifdef KR_headers +-extern int (*f__doed)(),(*f__doned)(); +-extern int (*f__dorevert)(); +-extern int rd_ed(),rd_ned(); +-extern int w_ed(),w_ned(); +-extern int signbit_f2c(); +-#else +-#ifdef __cplusplus +-extern "C" { +-#define Cextern extern "C" +-#else +-#define Cextern extern +-#endif +-extern int (*f__doed)(struct syl*, char*, ftnlen),(*f__doned)(struct syl*); +-extern int (*f__dorevert)(void); +-extern void fmt_bg(void); +-extern int pars_f(char*); +-extern int rd_ed(struct syl*, char*, ftnlen),rd_ned(struct syl*); +-extern int signbit_f2c(double*); +-extern int w_ed(struct syl*, char*, ftnlen),w_ned(struct syl*); +-extern int wrt_E(ufloat*, int, int, int, ftnlen); +-extern int wrt_F(ufloat*, int, int, ftnlen); +-extern int wrt_L(Uint*, int, ftnlen); +-#ifdef __cplusplus +- } +-#endif +-#endif +-extern flag f__cblank,f__cplus,f__workdone, f__nonl; +-extern char *f__fmtbuf; +-extern int f__scale; +-#define GET(x) if((x=(*f__getn)())<0) return(x) +-#define VAL(x) (x!='\n'?x:' ') +-#define PUT(x) (*f__putn)(x) +- +-#undef TYQUAD +-#ifndef Allow_TYQUAD +-#undef longint +-#define longint long +-#else +-#define TYQUAD 14 +-#endif +- +-#ifdef KR_headers +-extern char *f__icvt(); +-#else +-Cextern char *f__icvt(longint, int*, int*, int); +-#endif +//GO.SYSIN DD libI77/fmt.h +echo libI77/fmtlib.c 1>&2 +sed >libI77/fmtlib.c <<'//GO.SYSIN DD libI77/fmtlib.c' 's/^-//' +-/* @(#)fmtlib.c 1.2 */ +-#define MAXINTLENGTH 23 +- +-#include "f2c.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-#ifndef Allow_TYQUAD +-#undef longint +-#define longint long +-#undef ulongint +-#define ulongint unsigned long +-#endif +- +-#ifdef KR_headers +-char *f__icvt(value,ndigit,sign, base) longint value; int *ndigit,*sign; +- register int base; +-#else +-char *f__icvt(longint value, int *ndigit, int *sign, int base) +-#endif +-{ +- static char buf[MAXINTLENGTH+1]; +- register int i; +- ulongint uvalue; +- +- if(value > 0) { +- uvalue = value; +- *sign = 0; +- } +- else if (value < 0) { +- uvalue = -value; +- *sign = 1; +- } +- else { +- *sign = 0; +- *ndigit = 1; +- buf[MAXINTLENGTH-1] = '0'; +- return &buf[MAXINTLENGTH-1]; +- } +- i = MAXINTLENGTH; +- do { +- buf[--i] = (uvalue%base) + '0'; +- uvalue /= base; +- } +- while(uvalue > 0); +- *ndigit = MAXINTLENGTH - i; +- return &buf[i]; +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libI77/fmtlib.c +echo libI77/fp.h 1>&2 +sed >libI77/fp.h <<'//GO.SYSIN DD libI77/fp.h' 's/^-//' +-#define FMAX 40 +-#define EXPMAXDIGS 8 +-#define EXPMAX 99999999 +-/* FMAX = max number of nonzero digits passed to atof() */ +-/* EXPMAX = 10^EXPMAXDIGS - 1 = largest allowed exponent absolute value */ +- +-#ifdef V10 /* Research Tenth-Edition Unix */ +-#include "local.h" +-#endif +- +-/* MAXFRACDIGS and MAXINTDIGS are for wrt_F -- bounds (not necessarily +- tight) on the maximum number of digits to the right and left of +- * the decimal point. +- */ +- +-#ifdef VAX +-#define MAXFRACDIGS 56 +-#define MAXINTDIGS 38 +-#else +-#ifdef CRAY +-#define MAXFRACDIGS 9880 +-#define MAXINTDIGS 9864 +-#else +-/* values that suffice for IEEE double */ +-#define MAXFRACDIGS 344 +-#define MAXINTDIGS 308 +-#endif +-#endif +//GO.SYSIN DD libI77/fp.h +echo libI77/ftell_.c 1>&2 +sed >libI77/ftell_.c <<'//GO.SYSIN DD libI77/ftell_.c' 's/^-//' +-#include "f2c.h" +-#include "fio.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +- static FILE * +-#ifdef KR_headers +-unit_chk(Unit, who) integer Unit; char *who; +-#else +-unit_chk(integer Unit, char *who) +-#endif +-{ +- if (Unit >= MXUNIT || Unit < 0) +- f__fatal(101, who); +- return f__units[Unit].ufd; +- } +- +- integer +-#ifdef KR_headers +-ftell_(Unit) integer *Unit; +-#else +-ftell_(integer *Unit) +-#endif +-{ +- FILE *f; +- return (f = unit_chk(*Unit, "ftell")) ? ftell(f) : -1L; +- } +- +- int +-#ifdef KR_headers +-fseek_(Unit, offset, whence) integer *Unit, *offset, *whence; +-#else +-fseek_(integer *Unit, integer *offset, integer *whence) +-#endif +-{ +- FILE *f; +- int w = (int)*whence; +-#ifdef SEEK_SET +- static int wohin[3] = { SEEK_SET, SEEK_CUR, SEEK_END }; +-#endif +- if (w < 0 || w > 2) +- w = 0; +-#ifdef SEEK_SET +- w = wohin[w]; +-#endif +- return !(f = unit_chk(*Unit, "fseek")) +- || fseek(f, *offset, w) ? 1 : 0; +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libI77/ftell_.c +echo libI77/iio.c 1>&2 +sed >libI77/iio.c <<'//GO.SYSIN DD libI77/iio.c' 's/^-//' +-#include "f2c.h" +-#include "fio.h" +-#include "fmt.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-extern char *f__icptr; +-char *f__icend; +-extern icilist *f__svic; +-int f__icnum; +- +- int +-z_getc(Void) +-{ +- if(f__recpos++ < f__svic->icirlen) { +- if(f__icptr >= f__icend) err(f__svic->iciend,(EOF),"endfile"); +- return(*(unsigned char *)f__icptr++); +- } +- return '\n'; +-} +- +- void +-#ifdef KR_headers +-z_putc(c) +-#else +-z_putc(int c) +-#endif +-{ +- if (f__icptr < f__icend && f__recpos++ < f__svic->icirlen) +- *f__icptr++ = c; +-} +- +- int +-z_rnew(Void) +-{ +- f__icptr = f__svic->iciunit + (++f__icnum)*f__svic->icirlen; +- f__recpos = 0; +- f__cursor = 0; +- f__hiwater = 0; +- return 1; +-} +- +- static int +-z_endp(Void) +-{ +- (*f__donewrec)(); +- return 0; +- } +- +- int +-#ifdef KR_headers +-c_si(a) icilist *a; +-#else +-c_si(icilist *a) +-#endif +-{ +- f__elist = (cilist *)a; +- f__fmtbuf=a->icifmt; +- f__curunit = 0; +- f__sequential=f__formatted=1; +- f__external=0; +- if(pars_f(f__fmtbuf)<0) +- err(a->icierr,100,"startint"); +- fmt_bg(); +- f__cblank=f__cplus=f__scale=0; +- f__svic=a; +- f__icnum=f__recpos=0; +- f__cursor = 0; +- f__hiwater = 0; +- f__icptr = a->iciunit; +- f__icend = f__icptr + a->icirlen*a->icirnum; +- f__cf = 0; +- return(0); +-} +- +- int +-iw_rev(Void) +-{ +- if(f__workdone) +- z_endp(); +- f__hiwater = f__recpos = f__cursor = 0; +- return(f__workdone=0); +- } +- +-#ifdef KR_headers +-integer s_rsfi(a) icilist *a; +-#else +-integer s_rsfi(icilist *a) +-#endif +-{ int n; +- if(n=c_si(a)) return(n); +- f__reading=1; +- f__doed=rd_ed; +- f__doned=rd_ned; +- f__getn=z_getc; +- f__dorevert = z_endp; +- f__donewrec = z_rnew; +- f__doend = z_endp; +- return(0); +-} +- +- int +-z_wnew(Void) +-{ +- if (f__recpos < f__hiwater) { +- f__icptr += f__hiwater - f__recpos; +- f__recpos = f__hiwater; +- } +- while(f__recpos++ < f__svic->icirlen) +- *f__icptr++ = ' '; +- f__recpos = 0; +- f__cursor = 0; +- f__hiwater = 0; +- f__icnum++; +- return 1; +-} +-#ifdef KR_headers +-integer s_wsfi(a) icilist *a; +-#else +-integer s_wsfi(icilist *a) +-#endif +-{ int n; +- if(n=c_si(a)) return(n); +- f__reading=0; +- f__doed=w_ed; +- f__doned=w_ned; +- f__putn=z_putc; +- f__dorevert = iw_rev; +- f__donewrec = z_wnew; +- f__doend = z_endp; +- return(0); +-} +-integer e_rsfi(Void) +-{ int n = en_fio(); +- f__fmtbuf = NULL; +- return(n); +-} +-integer e_wsfi(Void) +-{ +- int n; +- n = en_fio(); +- f__fmtbuf = NULL; +- if(f__svic->icirnum != 1 +- && (f__icnum > f__svic->icirnum +- || (f__icnum == f__svic->icirnum && (f__recpos | f__hiwater)))) +- err(f__svic->icierr,110,"inwrite"); +- if (f__recpos < f__hiwater) +- f__recpos = f__hiwater; +- if (f__recpos >= f__svic->icirlen) +- err(f__svic->icierr,110,"recend"); +- if (!f__recpos && f__icnum) +- return n; +- while(f__recpos++ < f__svic->icirlen) +- *f__icptr++ = ' '; +- return n; +-} +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libI77/iio.c +echo libI77/ilnw.c 1>&2 +sed >libI77/ilnw.c <<'//GO.SYSIN DD libI77/ilnw.c' 's/^-//' +-#include "f2c.h" +-#include "fio.h" +-#include "lio.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +-extern char *f__icptr; +-extern char *f__icend; +-extern icilist *f__svic; +-extern int f__icnum; +-#ifdef KR_headers +-extern void z_putc(); +-#else +-extern void z_putc(int); +-#endif +- +- static int +-z_wSL(Void) +-{ +- while(f__recpos < f__svic->icirlen) +- z_putc(' '); +- return z_rnew(); +- } +- +- static void +-#ifdef KR_headers +-c_liw(a) icilist *a; +-#else +-c_liw(icilist *a) +-#endif +-{ +- f__reading = 0; +- f__external = 0; +- f__formatted = 1; +- f__putn = z_putc; +- L_len = a->icirlen; +- f__donewrec = z_wSL; +- f__svic = a; +- f__icnum = f__recpos = 0; +- f__cursor = 0; +- f__cf = 0; +- f__curunit = 0; +- f__icptr = a->iciunit; +- f__icend = f__icptr + a->icirlen*a->icirnum; +- f__elist = (cilist *)a; +- } +- +- integer +-#ifdef KR_headers +-s_wsni(a) icilist *a; +-#else +-s_wsni(icilist *a) +-#endif +-{ +- cilist ca; +- +- c_liw(a); +- ca.cifmt = a->icifmt; +- x_wsne(&ca); +- z_wSL(); +- return 0; +- } +- +- integer +-#ifdef KR_headers +-s_wsli(a) icilist *a; +-#else +-s_wsli(icilist *a) +-#endif +-{ +- f__lioproc = l_write; +- c_liw(a); +- return(0); +- } +- +-integer e_wsli(Void) +-{ +- z_wSL(); +- return(0); +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libI77/ilnw.c +echo libI77/inquire.c 1>&2 +sed >libI77/inquire.c <<'//GO.SYSIN DD libI77/inquire.c' 's/^-//' +-#include "f2c.h" +-#include "fio.h" +-#include "string.h" +-#ifdef NON_UNIX_STDIO +-#ifndef MSDOS +-#include "unistd.h" /* for access() */ +-#endif +-#endif +-#ifdef KR_headers +-integer f_inqu(a) inlist *a; +-#else +-#ifdef __cplusplus +-extern "C" integer f_inqu(inlist*); +-#endif +-#ifdef MSDOS +-#undef abs +-#undef min +-#undef max +-#include "io.h" +-#endif +-integer f_inqu(inlist *a) +-#endif +-{ flag byfile; +- int i; +-#ifndef NON_UNIX_STDIO +- int n; +-#endif +- unit *p; +- char buf[256]; +- long x; +- if(a->infile!=NULL) +- { byfile=1; +- g_char(a->infile,a->infilen,buf); +-#ifdef NON_UNIX_STDIO +- x = access(buf,0) ? -1 : 0; +- for(i=0,p=NULL;i<MXUNIT;i++) +- if(f__units[i].ufd != NULL +- && f__units[i].ufnm != NULL +- && !strcmp(f__units[i].ufnm,buf)) { +- p = &f__units[i]; +- break; +- } +-#else +- x=f__inode(buf, &n); +- for(i=0,p=NULL;i<MXUNIT;i++) +- if(f__units[i].uinode==x +- && f__units[i].ufd!=NULL +- && f__units[i].udev == n) { +- p = &f__units[i]; +- break; +- } +-#endif +- } +- else +- { +- byfile=0; +- if(a->inunit<MXUNIT && a->inunit>=0) +- { +- p= &f__units[a->inunit]; +- } +- else +- { +- p=NULL; +- } +- } +- if(a->inex!=NULL) +- if(byfile && x != -1 || !byfile && p!=NULL) +- *a->inex=1; +- else *a->inex=0; +- if(a->inopen!=NULL) +- if(byfile) *a->inopen=(p!=NULL); +- else *a->inopen=(p!=NULL && p->ufd!=NULL); +- if(a->innum!=NULL) *a->innum= p-f__units; +- if(a->innamed!=NULL) +- if(byfile || p!=NULL && p->ufnm!=NULL) +- *a->innamed=1; +- else *a->innamed=0; +- if(a->inname!=NULL) +- if(byfile) +- b_char(buf,a->inname,a->innamlen); +- else if(p!=NULL && p->ufnm!=NULL) +- b_char(p->ufnm,a->inname,a->innamlen); +- if(a->inacc!=NULL && p!=NULL && p->ufd!=NULL) +- if(p->url) +- b_char("DIRECT",a->inacc,a->inacclen); +- else b_char("SEQUENTIAL",a->inacc,a->inacclen); +- if(a->inseq!=NULL) +- if(p!=NULL && p->url) +- b_char("NO",a->inseq,a->inseqlen); +- else b_char("YES",a->inseq,a->inseqlen); +- if(a->indir!=NULL) +- if(p==NULL || p->url) +- b_char("YES",a->indir,a->indirlen); +- else b_char("NO",a->indir,a->indirlen); +- if(a->infmt!=NULL) +- if(p!=NULL && p->ufmt==0) +- b_char("UNFORMATTED",a->infmt,a->infmtlen); +- else b_char("FORMATTED",a->infmt,a->infmtlen); +- if(a->inform!=NULL) +- if(p!=NULL && p->ufmt==0) +- b_char("NO",a->inform,a->informlen); +- else b_char("YES",a->inform,a->informlen); +- if(a->inunf) +- if(p!=NULL && p->ufmt==0) +- b_char("YES",a->inunf,a->inunflen); +- else if (p!=NULL) b_char("NO",a->inunf,a->inunflen); +- else b_char("UNKNOWN",a->inunf,a->inunflen); +- if(a->inrecl!=NULL && p!=NULL) +- *a->inrecl=p->url; +- if(a->innrec!=NULL && p!=NULL && p->url>0) +- *a->innrec=(ftnint)(FTELL(p->ufd)/p->url+1); +- if(a->inblank && p!=NULL && p->ufmt) +- if(p->ublnk) +- b_char("ZERO",a->inblank,a->inblanklen); +- else b_char("NULL",a->inblank,a->inblanklen); +- return(0); +-} +//GO.SYSIN DD libI77/inquire.c +echo libI77/i77vers.c 1>&2 +sed >libI77/i77vers.c <<'//GO.SYSIN DD libI77/i77vers.c' 's/^-//' +- char +-_libi77_version_f2c[] = "\n@(#) LIBI77 VERSION (f2c) pjw,dmg-mods 20030321\n"; +- +-/* +-2.01 $ format added +-2.02 Coding bug in open.c repaired +-2.03 fixed bugs in lread.c (read * with negative f-format) and lio.c +- and lio.h (e-format conforming to spec) +-2.04 changed open.c and err.c (fopen and freopen respectively) to +- update to new c-library (append mode) +-2.05 added namelist capability +-2.06 allow internal list and namelist I/O +-*/ +- +-/* +-close.c: +- allow upper-case STATUS= values +-endfile.c +- create fort.nnn if unit nnn not open; +- else if (file length == 0) use creat() rather than copy; +- use local copy() rather than forking /bin/cp; +- rewind, fseek to clear buffer (for no reading past EOF) +-err.c +- use neither setbuf nor setvbuf; make stderr buffered +-fio.h +- #define _bufend +-inquire.c +- upper case responses; +- omit byfile test from SEQUENTIAL= +- answer "YES" to DIRECT= for unopened file (open to debate) +-lio.c +- flush stderr, stdout at end of each stmt +- space before character strings in list output only at line start +-lio.h +- adjust LEW, LED consistent with old libI77 +-lread.c +- use atof() +- allow "nnn*," when reading complex constants +-open.c +- try opening for writing when open for read fails, with +- special uwrt value (2) delaying creat() to first write; +- set curunit so error messages don't drop core; +- no file name ==> fort.nnn except for STATUS='SCRATCH' +-rdfmt.c +- use atof(); trust EOF == end-of-file (so don't read past +- end-of-file after endfile stmt) +-sfe.c +- flush stderr, stdout at end of each stmt +-wrtfmt.c: +- use upper case +- put wrt_E and wrt_F into wref.c, use sprintf() +- rather than ecvt() and fcvt() [more accurate on VAX] +-*/ +- +-/* 16 Oct. 1988: uwrt = 3 after write, rewind, so close won't zap the file. */ +- +-/* 10 July 1989: change _bufend to buf_end in fio.h, wsfe.c, wrtfmt.c */ +- +-/* 28 Nov. 1989: corrections for IEEE and Cray arithmetic */ +-/* 29 Nov. 1989: change various int return types to long for f2c */ +-/* 30 Nov. 1989: various types from f2c.h */ +-/* 6 Dec. 1989: types corrected various places */ +-/* 19 Dec. 1989: make iostat= work right for internal I/O */ +-/* 8 Jan. 1990: add rsne, wsne -- routines for handling NAMELIST */ +-/* 28 Jan. 1990: have NAMELIST read treat $ as &, general white +- space as blank */ +-/* 27 Mar. 1990: change an = to == in rd_L(rdfmt.c) so formatted reads +- of logical values reject letters other than fFtT; +- have nowwriting reset cf */ +-/* 14 Aug. 1990: adjust lread.c to treat tabs as spaces in list input */ +-/* 17 Aug. 1990: adjust open.c to recognize blank='Z...' as well as +- blank='z...' when reopening an open file */ +-/* 30 Aug. 1990: 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. */ +-/* 18 Sep. 1990: add component udev to unit and consider old == new file +- iff uinode and udev values agree; use stat rather than +- access to check existence of file (when STATUS='OLD')*/ +-/* 2 Oct. 1990: adjust rewind.c so two successive rewinds after a write +- don't clobber the file. */ +-/* 9 Oct. 1990: add #include "fcntl.h" to endfile.c, err.c, open.c; +- adjust g_char in util.c for segmented memories. */ +-/* 17 Oct. 1990: replace abort() and _cleanup() with calls on +- sig_die(...,1) (defined in main.c). */ +-/* 5 Nov. 1990: changes to open.c: complain if new= is specified and the +- file already exists; allow file= to be omitted in open stmts +- and allow status='replace' (Fortran 90 extensions). */ +-/* 11 Dec. 1990: adjustments for POSIX. */ +-/* 15 Jan. 1991: tweak i_ungetc in rsli.c to allow reading from +- strings in read-only memory. */ +-/* 25 Apr. 1991: adjust namelist stuff to work with f2c -i2 */ +-/* 26 Apr. 1991: fix some bugs with NAMELIST read of multi-dim. arrays */ +-/* 16 May 1991: increase LEFBL in lio.h to bypass NeXT bug */ +-/* 17 Oct. 1991: change type of length field in sequential unformatted +- records from int to long (for systems where sizeof(int) +- can vary, depending on the compiler or compiler options). */ +-/* 14 Nov. 1991: change uint to Uint in fmt.h, rdfmt.c, wrtfmt.c. */ +-/* 25 Nov. 1991: change uint to Uint in lwrite.c; change sizeof(int) to +- sizeof(uioint) in fseeks in sue.c (missed on 17 Oct.). */ +-/* 1 Dec. 1991: uio.c: add test for read failure (seq. unformatted reads); +- adjust an error return from EOF to off end of record */ +-/* 12 Dec. 1991: rsli.c: fix bug with internal list input that caused +- the last character of each record to be ignored. +- iio.c: 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. */ +-/* 17 Jan. 1992: lread.c, rsne.c: 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); 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). +- lio.h, lwrite.c: omit insignificant zeros in +- list and namelist output. To get the old +- behavior, compile with -DOld_list_output . */ +-/* 18 Jan. 1992: make list output consistent with F format by +- printing .1 rather than 0.1 (introduced yesterday). */ +-/* 3 Feb. 1992: rsne.c: fix namelist read bug that caused the +- character following a comma to be ignored. */ +-/* 19 May 1992: adjust iio.c, ilnw.c, rdfmt.c and rsli.c to make err= +- work with internal list and formatted I/O. */ +-/* 18 July 1992: adjust rsne.c to allow namelist input to stop at +- an & (e.g. &end). */ +-/* 23 July 1992: switch to ANSI prototypes unless KR_headers is #defined ; +- recognize Z format (assuming 8-bit bytes). */ +-/* 14 Aug. 1992: tweak wrt_E in wref.c to avoid -NaN */ +-/* 23 Oct. 1992: 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). Prepend f__ to external +- names that are only of internal interest to lib[FI]77. */ +-/* 1 Feb. 1993: backspace.c: fix bug that bit when last char of 2nd +- buffer == '\n'. +- endfile.c: guard against tiny L_tmpnam; close and reopen +- files in t_runc(). +- lio.h: lengthen LINTW (buffer size in lwrite.c). +- err.c, open.c: more prepending of f__ (to [rw]_mode). */ +-/* 5 Feb. 1993: tweaks to NAMELIST: rsne.c: ? prints the namelist being +- sought; namelists of the wrong name are skipped (after +- an error message; xwsne.c: namelist writes have a +- newline before each new variable. +- open.c: ACCESS='APPEND' positions sequential files +- at EOF (nonstandard extension -- that doesn't require +- changing data structures). */ +-/* 9 Feb. 1993: Change some #ifdef MSDOS lines to #ifdef NON_UNIX_STDIO. +- err.c: under NON_UNIX_STDIO, avoid close(creat(name,0666)) +- when the unit has another file descriptor for name. */ +-/* 4 March 1993: err.c, open.c: take declaration of fdopen from rawio.h; +- open.c: always give f__w_mode[] 4 elements for use +- in t_runc (in endfile.c -- for change of 1 Feb. 1993). */ +-/* 6 March 1993: uio.c: adjust off-end-of-record test for sequential +- unformatted reads to respond to err= rather than end=. */ +-/* 12 March 1993: various tweaks for C++ */ +-/* 6 April 1993: adjust error returns for formatted inputs to flush +- the current input line when err=label 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). */ +-/* 23 June 1993: iio.c: fix bug in format reversions for internal writes. */ +-/* 5 Aug. 1993: 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). */ +-/* 7 Aug. 1993: lread.c: fix bug in namelist reading of incomplete +- logical arrays. */ +-/* 9 Aug. 1993: 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'. */ +-/* 8 Sept. 1993: open.c: protect #include "sys/..." with +- #ifndef NON_UNIX_STDIO; Version date not changed. */ +-/* 10 Nov. 1993: backspace.c: add nonsense for #ifdef MSDOS */ +-/* 8 Dec. 1993: iio.c: adjust internal formatted reads to treat +- short records as though padded with blanks +- (rather than causing an "off end of record" error). */ +-/* 22 Feb. 1994: lread.c: check that realloc did not return NULL. */ +-/* 6 June 1994: Under NON_UNIX_STDIO, use binary mode for direct +- formatted files (avoiding any confusion regarding \n). */ +-/* 5 July 1994: Fix bug (introduced 6 June 1994?) in reopening files +- under NON_UNIX_STDIO. */ +-/* 6 July 1994: 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. */ +-/* 12 July 1994: wrtfmt.c: under G11.4, write 0. as " .0000 " rather +- than " .0000E+00". */ +-/* 3 Aug. 1994: lwrite.c: do not insert a newline when appending an +- oversize item to an empty line. */ +-/* 12 Aug. 1994: rsli.c rsne.c: fix glitch (reset nml_read) that kept +- ERR= (in list- or format-directed input) from working +- after a NAMELIST READ. */ +-/* 7 Sept. 1994: typesize.c: adjust to allow types LOGICAL*1, LOGICAL*2, +- INTEGER*1, and (under -DAllow_TYQUAD) INTEGER*8 +- in NAMELISTs. */ +-/* 6 Oct. 1994: util.c: omit f__mvgbt, as it is never used. */ +-/* 2 Nov. 1994: add #ifdef ALWAYS_FLUSH logic. */ +-/* 26 Jan. 1995: wref.c: fix glitch in printing the exponent of 0 when +- GOOD_SPRINTF_EXPONENT is not #defined. */ +-/* 24 Feb. 1995: iio.c: z_getc: insert (unsigned char *) to allow +- internal reading of characters with high-bit set +- (on machines that sign-extend characters). */ +-/* 14 March 1995: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). */ +-/* 26 May 1995: 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. */ +-/* 29 Aug. 1995: backspace.c: adjust MSDOS logic. */ +-/* 6 Sept. 1995: 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). Adjust f_init calls +- for people who don't use libF77's main(); now open and +- namelist read statements invoke f_init if needed. */ +-/* 7 Sept. 1995: Fix some bugs with -DAllow_TYQUAD (for integer*8). +- Add -DNo_Namelist_Comments lines to rsne.c. */ +-/* 5 Oct. 1995: wrtfmt.c: fix bug with t editing (f__cursor was not +- always zeroed in mv_cur). */ +-/* 11 Oct. 1995: move defs of f__hiwater, f__svic, f__icptr from wrtfmt.c +- to err.c */ +-/* 15 Mar. 1996: lread.c, rsfe.c: honor END= in READ stmt with empty iolist */ +- +-/* 13 May 1996: add ftell_.c and fseek_.c */ +-/* 9 June 1996: Adjust rsli.c and lread.c so internal list input with +- too few items in the input string will honor end= . */ +-/* 12 Sept. 1995:fmtlib.c: fix glitch in printing the most negative integer. */ +-/* 25 Sept. 1995: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. */ +-/* 9 Dec. 1996: d[fu]e.c, err.c: complain about non-positive rec= +- in direct read and write statements. +- ftell_.c: change param "unit" to "Unit" for -DKR_headers. */ +-/* 26 Feb. 1997: ftell_.c: on systems that define SEEK_SET, etc., use +- SEEK_SET, SEEK_CUR, SEEK_END for *whence = 0, 1, 2. */ +-/* 7 Apr. 1997: fmt.c: adjust to complain at missing numbers in formats +- (but still treat missing ".nnn" as ".0"). */ +-/* 11 Apr. 1997: err.c: attempt to make stderr line buffered rather +- than fully buffered. (Buffering is needed for format +- items T and TR.) */ +-/* 27 May 1997: ftell_.c: fix typo (that caused the third argument to be +- treated as 2 on some systems). */ +-/* 5 Aug. 1997: lread.c: adjust to accord with a change to the Fortran 8X +- draft (in 1990 or 1991) that rescinded permission to elide +- quote marks in namelist input of character data; compile +- with -DF8X_NML_ELIDE_QUOTES to get the old behavior. +- wrtfmt.o: wrt_G: tweak to print the right number of 0's +- for zero under G format. */ +-/* 16 Aug. 1997: iio.c: fix bug in internal writes to an array of character +- strings that sometimes caused one more array element than +- required by the format to be blank-filled. Example: +- format(1x). */ +-/* 16 Sept. 1997:fmt.[ch] rdfmt.c wrtfmt.c: tweak struct syl for machines +- with 64-bit pointers and 32-bit ints that did not 64-bit +- align struct syl (e.g., Linux on the DEC Alpha). */ +-/* 19 Jan. 1998: backspace.c: for b->ufmt==0, change sizeof(int) to +- sizeof(uiolen). On machines where this would make a +- difference, it is best for portability to compile libI77 with +- -DUIOLEN_int (which will render the change invisible). */ +-/* 4 March 1998: open.c: fix glitch in comparing file names under +- -DNON_UNIX_STDIO */ +-/* 17 March 1998: endfile.c, open.c: acquire temporary files from tmpfile(), +- unless compiled with -DNON_ANSI_STDIO, which uses mktemp(). +- New buffering scheme independent of NON_UNIX_STDIO for +- handling T format items. Now -DNON_UNIX_STDIO is no +- longer be necessary for Linux, and libf2c no longer +- causes stderr to be buffered -- the former setbuf or +- setvbuf call for stderr was to make T format items work. +- open.c: use the Posix access() function to check existence +- or nonexistence of files, except under -DNON_POSIX_STDIO, +- where trial fopen calls are used. */ +-/* 5 April 1998: wsfe.c: make $ format item work: this was lost in the +- changes of 17 March 1998. */ +-/* 28 May 1998: backspace.c dfe.c due.c iio.c lread.c rsfe.c sue.c wsfe.c: +- set f__curunit sooner so various error messages will +- correctly identify the I/O unit involved. */ +-/* 17 June 1998: lread.c: unless compiled with +- ALLOW_FLOAT_IN_INTEGER_LIST_INPUT #defined, treat +- floating-point numbers (containing either a decimal point +- or an exponent field) as errors when they appear as list +- input for integer data. */ +-/* 7 Sept. 1998: move e_wdfe from sfe.c to dfe.c, where it was originally. +- Why did it ever move to sfe.c? */ +-/* 2 May 1999: open.c: set f__external (to get "external" versus "internal" +- right in the error message if we cannot open the file). +- 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. */ +-/* 3 May 1999: open.c: insert two casts for machines with 64-bit longs. */ +-/* 18 June 1999: backspace.c: allow for b->ufd changing in t_runc */ +-/* 27 June 1999: 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) */ +-/* 15 Nov. 1999: endfile.c: set state to writing (b->uwrt = 1) when an */ +-/* endfile statement requires copying the file. */ +-/* (Otherwise an immediately following rewind statement */ +-/* could make the file appear empty.) Also, supply a */ +-/* missing (long) cast in the sprintf call. */ +-/* sfe.c: add #ifdef ALWAYS_FLUSH logic, for formatted I/O: */ +-/* Compiling libf2c with -DALWAYS_FLUSH should prevent losing */ +-/* any data in buffers should the program fault. It also */ +-/* makes the program run more slowly. */ +-/* 20 April 2000: rsne.c, xwsne.c: tweaks that only matter if ftnint and */ +-/* ftnlen are of different fundamental types (different numbers */ +-/* of bits). Since these files will not compile when this */ +-/* change matters, the above VERSION string remains unchanged. */ +-/* 4 July 2000: adjustments to permit compilation by C++ compilers; */ +-/* VERSION string remains unchanged. */ +-/* 5 Dec. 2000: lread.c: under namelist input, when reading a logical array, */ +-/* treat Tstuff= and Fstuff= as new assignments rather than as */ +-/* logical constants. */ +-/* 22 Feb. 2001: endfile.c: adjust to use truncate() unless compiled with */ +-/* -DNO_TRUNCATE (or with -DMSDOS). */ +-/* 1 March 2001: 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. */ +-/* 11 Oct. 2001: backspac.c dfe.c due.c endfile.c err.c fio.h fmt.c fmt.h */ +-/* inquire.c open.c rdfmt.c sue.c util.c: change fseek and */ +-/* ftell to FSEEK and FTELL (#defined to be fseek and ftell, */ +-/* respectively, in fio.h unless otherwise #defined), and use */ +-/* type OFF_T (#defined to be long unless otherwise #defined) */ +-/* 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). */ +-/* 15 Nov. 2001: endfile.c: add FSEEK after FTRUNCATE. */ +-/* 28 Nov. 2001: fmt.h lwrite.c wref.c and (new) signbit.c: on IEEE systems, */ +-/* print -0 as -0 when compiled with -DSIGNED_ZEROS. See */ +-/* comments in makefile or (better) libf2c/makefile.* . */ +-/* 6 Sept. 2002: 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 / */ +-/* 21 March 2003: err.c: before writing to a file after reading from it, */ +-/* f_seek(file, 0, SEEK_CUR) to make writing legal in ANSI C. */ +//GO.SYSIN DD libI77/i77vers.c +echo libI77/sysdep1.h0 1>&2 +sed >libI77/sysdep1.h0 <<'//GO.SYSIN DD libI77/sysdep1.h0' 's/^-//' +-#ifndef SYSDEP_H_INCLUDED +-#define SYSDEP_H_INCLUDED +-#undef USE_LARGEFILE +-#ifndef NO_LONG_LONG +- +-#ifdef __sun__ +-#define USE_LARGEFILE +-#define OFF_T off64_t +-#endif +- +-#ifdef __linux__ +-#define USE_LARGEFILE +-#define OFF_T __off64_t +-#endif +- +-#ifdef _AIX43 +-#define _LARGE_FILES +-#define _LARGE_FILE_API +-#define USE_LARGEFILE +-#endif /*_AIX43*/ +- +-#ifdef __hpux +-#define _FILE64 +-#define _LARGEFILE64_SOURCE +-#define USE_LARGEFILE +-#endif /*__hpux*/ +- +-#ifdef __sgi +-#define USE_LARGEFILE +-#endif /*__sgi*/ +- +-#ifdef __FreeBSD__ +-#define OFF_T off_t +-#define FSEEK fseeko +-#define FTELL ftello +-#endif +- +-#ifdef USE_LARGEFILE +-#ifndef OFF_T +-#define OFF_T off64_t +-#endif +-#define _LARGEFILE_SOURCE +-#define _LARGEFILE64_SOURCE +-#include <sys/types.h> +-#include <sys/stat.h> +-#define FOPEN fopen64 +-#define FREOPEN freopen64 +-#define FSEEK fseeko64 +-#define FSTAT fstat64 +-#define FTELL ftello64 +-#define FTRUNCATE ftruncate64 +-#define STAT stat64 +-#define STAT_ST stat64 +-#endif /*USE_LARGEFILE*/ +-#endif /*NO_LONG_LONG*/ +- +-#ifndef NON_UNIX_STDIO +-#ifndef USE_LARGEFILE +-#define _INCLUDE_POSIX_SOURCE /* for HP-UX */ +-#define _INCLUDE_XOPEN_SOURCE /* for HP-UX */ +-#include "sys/types.h" +-#include "sys/stat.h" +-#endif +-#endif +- +-#endif /*SYSDEP_H_INCLUDED*/ +//GO.SYSIN DD libI77/sysdep1.h0 +echo libI77/ftell64_.c 1>&2 +sed >libI77/ftell64_.c <<'//GO.SYSIN DD libI77/ftell64_.c' 's/^-//' +-#include "f2c.h" +-#include "fio.h" +-#ifdef __cplusplus +-extern "C" { +-#endif +- +- static FILE * +-#ifdef KR_headers +-unit_chk(Unit, who) integer Unit; char *who; +-#else +-unit_chk(integer Unit, char *who) +-#endif +-{ +- if (Unit >= MXUNIT || Unit < 0) +- f__fatal(101, who); +- return f__units[Unit].ufd; +- } +- +- longint +-#ifdef KR_headers +-ftell64_(Unit) integer *Unit; +-#else +-ftell64_(integer *Unit) +-#endif +-{ +- FILE *f; +- return (f = unit_chk(*Unit, "ftell")) ? FTELL(f) : -1L; +- } +- +- int +-#ifdef KR_headers +-fseek64_(Unit, offset, whence) integer *Unit, *whence; longint *offset; +-#else +-fseek64_(integer *Unit, longint *offset, integer *whence) +-#endif +-{ +- FILE *f; +- int w = (int)*whence; +-#ifdef SEEK_SET +- static int wohin[3] = { SEEK_SET, SEEK_CUR, SEEK_END }; +-#endif +- if (w < 0 || w > 2) +- w = 0; +-#ifdef SEEK_SET +- w = wohin[w]; +-#endif +- return !(f = unit_chk(*Unit, "fseek")) +- || FSEEK(f, (OFF_T)*offset, w) ? 1 : 0; +- } +-#ifdef __cplusplus +-} +-#endif +//GO.SYSIN DD libI77/ftell64_.c +echo libI77/signbit.c 1>&2 +sed >libI77/signbit.c <<'//GO.SYSIN DD libI77/signbit.c' 's/^-//' +-#include "arith.h" +- +-#ifndef Long +-#define Long long +-#endif +- +- int +-#ifdef KR_headers +-signbit_f2c(x) double *x; +-#else +-signbit_f2c(double *x) +-#endif +-{ +-#ifdef IEEE_MC68k +- if (*(Long*)x & 0x80000000) +- return 1; +-#else +-#ifdef IEEE_8087 +- if (((Long*)x)[1] & 0x80000000) +- return 1; +-#endif /*IEEE_8087*/ +-#endif /*IEEE_MC68k*/ +- return 0; +- } +//GO.SYSIN DD libI77/signbit.c +echo libI77/libI77.xsum 1>&2 +sed >libI77/libI77.xsum <<'//GO.SYSIN DD libI77/libI77.xsum' 's/^-//' +-Notice 76f23b4 1212 +-README f35cf24 10373 +-backspace.c 10ebf554 1328 +-close.c 173f01de 1393 +-dfe.c 1d658105 2624 +-dolio.c 19c9fbd9 471 +-due.c ee219f6d 1624 +-endfile.c 6f7201d 2838 +-err.c fea5c2a7 6189 +-f2ch.add ef66bf17 6060 +-fio.h f9389f5f 2932 +-fmt.c cdfb2a1 8361 +-fmt.h f5dd2afb 1970 +-fmtlib.c eefc6a27 865 +-fp.h 100fb355 665 +-ftell64_.c e2c4b21e 917 +-ftell_.c e845eedb 894 +-i77vers.c f57b8ef2 18128 +-iio.c f958b627 2639 +-ilnw.c fe0ab14b 1125 +-inquire.c 1883d542 2732 +-lio.h a087b39 1564 +-lread.c eb3c2be3 14705 +-lwrite.c f80da63f 4616 +-makefile e31c232c 2856 +-open.c a2fe776 5625 +-rawio.h 1ab49f7c 718 +-rdfmt.c ffbd74b2 8858 +-rewind.c e4c6236f 475 +-rsfe.c eb9e882c 1492 +-rsli.c 11f59b61 1785 +-rsne.c 1b1e1814 11551 +-sfe.c d24f06 767 +-signbit.c e37eac06 330 +-sue.c 9705ecf 1865 +-sysdep1.h0 1812022d 1202 +-typesize.c eee307ae 386 +-uio.c e354a770 1619 +-util.c e526349d 902 +-wref.c 17bbfb7b 4747 +-wrtfmt.c 113fc4f9 7506 +-wsfe.c f2d1fe4d 1280 +-wsle.c fe50b4c9 697 +-wsne.c 428bfda 479 +-xwsne.c 185c4bdc 1174 +//GO.SYSIN DD libI77/libI77.xsum diff --git a/unix/f2c/mkpkg.sh b/unix/f2c/mkpkg.sh new file mode 100644 index 00000000..ccb92bb8 --- /dev/null +++ b/unix/f2c/mkpkg.sh @@ -0,0 +1,6 @@ +# Bootstrap the F2C compiler and libraries. + +echo "----------------------- F2C ---------------------------" +(cd src; sh -x mkpkg.sh) +echo "----------------------- LIBF2C ------------------------" +(cd libf2c; sh -x mkpkg.sh) diff --git a/unix/f2c/msdos/README b/unix/f2c/msdos/README new file mode 100644 index 00000000..2e0f921b --- /dev/null +++ b/unix/f2c/msdos/README @@ -0,0 +1,48 @@ +f2c.exe.gz is a compressed MSDOS version of f2c that should run on just +about any MSDOS machine. It was compiled by Microsoft Visual C++ 1.51 +with ccm.bat in March 1999; we do not intend to recompile it again. +It is superceded by the Win32 f2c.exe in directory ../mswin. + +f2cx.exe.gz is a compressed MSDOS version of f2c that requires an 80386 +or 80486, as it uses extended memory. It was compiled by the Symantec +C/C++ compiler (version 6.11, with ccs.bat), and it generally can +translate larger Fortran files without running out of memory than can +f2c.exe. + +etime.exe.gz is a compressed MSDOS timing program that is of interest +because it can redirect stderr (file descriptor 2). For example, +invoking + + etime -2foo.err f2c foo.f +or + etime -2+foo.err f2c foo.f + +will cause the output that f2c writes on file descriptor 2 (such as +the names of the subprograms translated and any warning or error +messages) while it processes the Fortran in file foo.f to be written +to file foo.err rather than to the screen. The first invocation +overwrites foo.err, while the second one appends to it. (You can +replace "foo.f" with any f2c command-line options and input file name +of your choice, and can similarly change "foo.err" to any file name +you like. Sensible shells allow redirection of stderr, but etime.exe +is useful with MSDOS's command.com.) Etime also can run f2cx.exe, or +any other MSDOS program whose arguments fit on its command line. +Execute "etime" or "etime -?" for usage summary. + +Compression is by gzip, source for which is available by ftp +in prep.ai.mit.edu:/pub/gnu. As a convenience, gzip binaries for +several systems (with names of the form system.executable) and +source for the gzip used to compress the *.gz files are available +for ftp from netlib directory gnu/gzip. In particular, if you +copy gnu/gzip/dos.executable to an MSDOS machine (in binary mode), +rename it gzip.exe, and rename f2c.exe.gz f2c.exz and f2cx.exe f2cx.exz, +then on the MSDOS machine you can recover f2c.exe and f2cx.exe by +executing "gzip -dN f2c.exz f2cx.exz". + +"xsum f2c.exe f2c.exe.gz f2cx.exe f2cx.exe.gz" should give you: +f2c.exe 1c458998 285402 +f2c.exe.gz e93d0ab 141545 +f2cx.exe f721d8b8 262097 +f2cx.exe.gz 13ba4d83 140359 + +Last (and final) update of f2cx.exe: 17 December 2002 diff --git a/unix/f2c/msdos/ccb.bat b/unix/f2c/msdos/ccb.bat new file mode 100644 index 00000000..1caf5723 --- /dev/null +++ b/unix/f2c/msdos/ccb.bat @@ -0,0 +1,64 @@ +rem script for compiling f2c with Borland C++ 4.02 +del *.obj +bcc -c -ml -N -w-pia -w-pro -O2 -Ot -Ox -G -Z -Oe cds.c >zot +if errorlevel 1 goto +bcc -c -ml -N -w-pia -w-pro -O2 -Ot -Ox -G -Z -Oe data.c >zot +if errorlevel 1 goto +bcc -c -ml -N -w-pia -w-pro -O2 -Ot -Ox -G -Z -Oe equiv.c >zot +if errorlevel 1 goto +bcc -c -ml -N -w-pia -w-pro -O2 -Ot -Ox -G -Z -Oe error.c >zot +if errorlevel 1 goto +bcc -c -ml -N -w-pia -w-pro -O2 -Ot -Ox -G -Z -Oe exec.c >zot +if errorlevel 1 goto +bcc -c -ml -N -w-pia -w-pro -O2 -Ot -Ox -G -Z -Oe expr.c >zot +if errorlevel 1 goto +bcc -c -ml -N -w-pia -w-pro -O2 -Ot -Ox -G -Z -Oe format.c >zot +if errorlevel 1 goto +bcc -c -ml -N -w-pia -w-pro -O2 -Ot -Ox -G -Z -Oe formatda.c >zot +if errorlevel 1 goto +bcc -c -ml -N -w-pia -w-pro -O2 -Ot -Ox -G -Z -Oe gram.c >zot +if errorlevel 1 goto +bcc -c -ml -N -w-pia -w-pro -O2 -Ot -Ox -G -Z -Oe init.c >zot +if errorlevel 1 goto +bcc -c -ml -N -w-pia -w-pro -O2 -Ot -Ox -G -Z -Oe intr.c >zot +if errorlevel 1 goto +bcc -c -ml -N -w-pia -w-pro -O2 -Ot -Ox -G -Z -Oe io.c >zot +if errorlevel 1 goto +bcc -c -ml -N -w-pia -w-pro -O2 -Ot -Ox -G -Z -Oe lex.c >zot +if errorlevel 1 goto +bcc -c -ml -N -w-pia -w-pro -O2 -Ot -Ox -G -Z -Oe main.c >zot +if errorlevel 1 goto +bcc -c -ml -N -w-pia -w-pro -O2 -Ot -Ox -G -Z -Oe mem.c >zot +if errorlevel 1 goto +bcc -c -ml -N -w-pia -w-pro -O2 -Ot -Ox -G -Z -Oe misc.c >zot +if errorlevel 1 goto +bcc -c -ml -N -w-pia -w-pro -O2 -Ot -Ox -G -Z -Oe names.c >zot +if errorlevel 1 goto +bcc -c -ml -N -w-pia -w-pro -O2 -Ot -Ox -G -Z -Oe niceprin.c >zot +if errorlevel 1 goto +bcc -c -ml -N -w-pia -w-pro -O2 -Ot -Ox -G -Z -Oe output.c >zot +if errorlevel 1 goto +bcc -c -ml -N -w-pia -w-pro -O2 -Ot -Ox -G -Z -Oe p1output.c >zot +if errorlevel 1 goto +bcc -c -ml -N -w-pia -w-pro -O2 -Ot -Ox -G -Z -Oe parse_ar.c >zot +if errorlevel 1 goto +bcc -c -ml -N -w-pia -w-pro -O2 -Ot -Ox -G -Z -Oe pread.c >zot +if errorlevel 1 goto +bcc -c -ml -N -w-pia -w-pro -O2 -Ot -Ox -G -Z -Oe proc.c >zot +if errorlevel 1 goto +bcc -c -ml -N -w-pia -w-pro -O2 -Ot -Ox -G -Z -Oe put.c >zot +if errorlevel 1 goto +bcc -c -ml -N -w-pia -w-pro -O2 -Ot -Ox -G -Z -Oe putpcc.c >zot +if errorlevel 1 goto +bcc -c -ml -N -w-pia -w-pro -O2 -Ot -Ox -G -Z -Oe sysdep.c >zot +if errorlevel 1 goto +bcc -c -ml -N -w-pia -w-pro -O2 -Ot -Ox -G -Z -Oe vax.c >zot +if errorlevel 1 goto +bcc -c -ml -N -w-pia -w-pro -O2 -Ot -Ox -G -Z -Oe version.c >zot +if errorlevel 1 goto +echo extern unsigned _stklen = 0x4000; >stklen.c +bcc -c -ml -N -w-pia -w-pro -O2 -Ot -Ox -G -Z -Oe stklen.c >zot +if errorlevel 1 goto +bcc -ml -N -ef2c *.obj +if errorlevel 1 goto +del *.obj diff --git a/unix/f2c/msdos/ccm.bat b/unix/f2c/msdos/ccm.bat new file mode 100644 index 00000000..b116a34b --- /dev/null +++ b/unix/f2c/msdos/ccm.bat @@ -0,0 +1,90 @@ +rem script for compiling conventional-memory f2c with Microsoft C compilers +del *.obj +cl -c -AL -Gt28 -Ox -Ge -nologo CDS.C +if errorlevel 1 goto +del CDS.C +cl -c -AL -Gt28 -Ox -Ge -nologo DATA.C +if errorlevel 1 goto +del DATA.C +cl -c -AL -Gt28 -Ox -Ge -nologo EQUIV.C +if errorlevel 1 goto +del EQUIV.C +cl -c -AL -Gt28 -Ox -Ge -nologo ERROR.C +if errorlevel 1 goto +del ERROR.C +cl -c -AL -Gt28 -Ox -Ge -nologo EXEC.C +if errorlevel 1 goto +del EXEC.C +cl -c -AL -Gt28 -Ox -Ge -nologo EXPR.C +if errorlevel 1 goto +del EXPR.C +cl -c -AL -Gt28 -Ox -Ge -nologo FORMAT.C +if errorlevel 1 goto +del FORMAT.C +cl -c -AL -Gt28 -Ox -Ge -nologo FORMATDA.C +if errorlevel 1 goto +del FORMATDA.C +cl -c -AL -Gt28 -Ox -Ge -nologo GRAM.C +if errorlevel 1 goto +del GRAM.C +cl -c -AL -Gt28 -Ox -Ge -nologo INIT.C +if errorlevel 1 goto +del INIT.C +cl -c -AL -Gt28 -Ox -Ge -nologo INTR.C +if errorlevel 1 goto +del INTR.C +cl -c -AL -Gt28 -Ox -Ge -nologo IO.C +if errorlevel 1 goto +del IO.C +cl -c -AL -Gt28 -Ox -Ge -nologo LEX.C +if errorlevel 1 goto +del LEX.C +cl -c -AL -Gt28 -Ox -Ge -nologo MAIN.C +if errorlevel 1 goto +del MAIN.C +cl -c -AL -Gt28 -Ox -Ge -nologo MEM.C +if errorlevel 1 goto +del MEM.C +cl -c -AL -Gt28 -Ox -Ge -nologo MISC.C +if errorlevel 1 goto +del MISC.C +cl -c -AL -Gt28 -Ox -Ge -nologo NAMES.C +if errorlevel 1 goto +del NAMES.C +cl -c -AL -Gt28 -Ox -Ge -nologo NICEPRIN.C +if errorlevel 1 goto +del NICEPRIN.C +cl -c -AL -Gt28 -Ox -Ge -nologo OUTPUT.C +if errorlevel 1 goto +del OUTPUT.C +cl -c -AL -Gt28 -Ox -Ge -nologo P1OUTPUT.C +if errorlevel 1 goto +del P1OUTPUT.C +cl -c -AL -Gt28 -Ox -Ge -nologo PARSE_AR.C +if errorlevel 1 goto +del PARSE_AR.C +cl -c -AL -Gt28 -Ox -Ge -nologo PREAD.C +if errorlevel 1 goto +del PREAD.C +cl -c -AL -Gt28 -Ox -Ge -nologo PROC.C +if errorlevel 1 goto +del PROC.C +cl -c -AL -Gt28 -Ox -Ge -nologo PUT.C +if errorlevel 1 goto +del PUT.C +cl -c -AL -Gt28 -Ox -Ge -nologo PUTPCC.C +if errorlevel 1 goto +del PUTPCC.C +cl -c -AL -Gt28 -Ox -Ge -nologo SYSDEP.C +if errorlevel 1 goto +del SYSDEP.C +cl -c -AL -Gt28 -Ox -Ge -nologo VAX.C +if errorlevel 1 goto +del VAX.C +cl -c -AL -Gt28 -Ox -Ge -nologo VERSION.C +if errorlevel 1 goto +del VERSION.C +cl -AL *.obj -link /ST:0x6000 +if errorlevel 1 goto +ren cds.exe f2c.exe +if errorlevel 1 goto diff --git a/unix/f2c/msdos/ccs.bat b/unix/f2c/msdos/ccs.bat new file mode 100644 index 00000000..1d385903 --- /dev/null +++ b/unix/f2c/msdos/ccs.bat @@ -0,0 +1,71 @@ +rem script for compiling f2cx (extended-memory f2c) with Symantec C version 6 +del *.obj +sc -c -s -mx -o -w2 -w7 -DMSDOS cds.c >zot +if errorlevel 1 goto +sc -c -s -mx -o -w2 -w7 -DMSDOS data.c >>zot +if errorlevel 1 goto +sc -c -s -mx -o -w2 -w7 -DMSDOS equiv.c >>zot +if errorlevel 1 goto +sc -c -s -mx -o -w2 -w7 -DMSDOS error.c >>zot +if errorlevel 1 goto +sc -c -s -mx -o -w2 -w7 -DMSDOS exec.c >>zot +if errorlevel 1 goto +sc -c -s -mx -o -w2 -w7 -DMSDOS expr.c >>zot +if errorlevel 1 goto +sc -c -s -mx -o -w2 -w7 -DMSDOS format.c >>zot +if errorlevel 1 goto +sc -c -s -mx -o -w2 -w7 -DMSDOS formatda.c >>zot +if errorlevel 1 goto +sc -c -s -mx -o -w2 -w7 -DMSDOS gram.c >>zot +if errorlevel 1 goto +sc -c -s -mx -o -w2 -w7 -DMSDOS init.c >>zot +if errorlevel 1 goto +sc -c -s -mx -o -w2 -w7 -DMSDOS intr.c >>zot +if errorlevel 1 goto +sc -c -s -mx -o -w2 -w7 -DMSDOS io.c >>zot +if errorlevel 1 goto +sc -c -s -mx -o -w2 -w7 -DMSDOS lex.c >>zot +if errorlevel 1 goto +sc -c -s -mx -o -w2 -w7 -DMSDOS main.c >>zot +if errorlevel 1 goto +sc -c -s -mx -o -w2 -w7 -DMSDOS mem.c >>zot +if errorlevel 1 goto +sc -c -s -mx -o -w2 -w7 -DMSDOS misc.c >>zot +if errorlevel 1 goto +sc -c -s -mx -o -w2 -w7 -DMSDOS names.c >>zot +if errorlevel 1 goto +sc -c -s -mx -o -w2 -w7 -DMSDOS niceprin.c >>zot +if errorlevel 1 goto +sc -c -s -mx -o -w2 -w7 -DMSDOS -DUSE_DTOA output.c >>zot +if errorlevel 1 goto +sc -c -s -mx -o -w2 -w7 -DMSDOS p1output.c >>zot +if errorlevel 1 goto +sc -c -s -mx -o -w2 -w7 -DMSDOS parse_ar.c >>zot +if errorlevel 1 goto +sc -c -s -mx -o -w2 -w7 -DMSDOS pread.c >>zot +if errorlevel 1 goto +sc -c -s -mx -o -w2 -w7 -DMSDOS proc.c >>zot +if errorlevel 1 goto +sc -c -s -mx -o -w2 -w7 -DMSDOS put.c >>zot +if errorlevel 1 goto +sc -c -s -mx -o -w2 -w7 -DMSDOS putpcc.c >>zot +if errorlevel 1 goto +sc -c -s -mx -o -w2 -w7 -DMSDOS sysdep.c >>zot +if errorlevel 1 goto +sc -c -s -mx -o -w2 -w7 -DMSDOS vax.c >>zot +if errorlevel 1 goto +sc -c -s -mx -o -w2 -w7 -DMSDOS version.c >>zot +if errorlevel 1 goto +rem The following echo and ren create stklen.c if it does not exist +rem and avoid overwriting an existing stklen.c . +echo extern unsigned _stklen = 0x4000; >zap +ren zap stklen.c +sc -c -s -mx -o -w2 -w7 -DMSDOS stklen.c >>zot +if errorlevel 1 goto +rem README tells about dtoa.c and g_fmt.c . +sc -c -s -mx -o -w2 -w7 -DMSDOS -DMALLOC=ckalloc -DIEEE_8087 dtoa.c >>zot +if errorlevel 1 goto +sc -c -s -mx -o -w2 -w7 -DMSDOS -DIEEE_8087 g_fmt.c >>zot +if errorlevel 1 goto +sc -mx -s -o f2cx.exe *.obj +del *.obj diff --git a/unix/f2c/msdos/etime.exe.gz b/unix/f2c/msdos/etime.exe.gz Binary files differnew file mode 100644 index 00000000..5c4ff2d1 --- /dev/null +++ b/unix/f2c/msdos/etime.exe.gz diff --git a/unix/f2c/msdos/f2c.exe.gz b/unix/f2c/msdos/f2c.exe.gz Binary files differnew file mode 100644 index 00000000..91bcecb4 --- /dev/null +++ b/unix/f2c/msdos/f2c.exe.gz diff --git a/unix/f2c/msdos/f2cx.exe.gz b/unix/f2c/msdos/f2cx.exe.gz Binary files differnew file mode 100644 index 00000000..d614650b --- /dev/null +++ b/unix/f2c/msdos/f2cx.exe.gz diff --git a/unix/f2c/msdos/index.html b/unix/f2c/msdos/index.html new file mode 100644 index 00000000..2229f846 --- /dev/null +++ b/unix/f2c/msdos/index.html @@ -0,0 +1,32 @@ +<head> +<title>f2c/msdos</title> +<meta name="waisindex" value="nse"> +</head> +<h1>f2c/msdos</h1> +<p> +Click <A HREF="http://www.netlib.org/master_counts2.html#f2c/msdos">here</A> to see the number of accesses to this library. +<p><hr> +<pre> +file <a href="README">README</a> + +file <a href="f2c.exe.gz">f2c.exe.gz</a> +for conventional-memory MSDOS version of f2c (compiled by Borland C++ 4.02) + +file <a href="f2cx.exe.gz">f2cx.exe.gz</a> +for extended-memory MSDOS version of f2c (compiled by Symantec C/C++) + +file <a href="ccb.bat">ccb.bat</a> +for compilation of f2c.exe (for people curious about how it was done) + +file <a href="ccs.bat">ccs.bat</a> +for compilation of f2cx.exe (for people curious about how it was done) + +file <a href="ccm.bat">ccm.bat</a> + +file <a href="etime.exe.gz">etime.exe.gz</a> + +file <a href="xsum.executable (uncompressed MSDOS version of xsum)">xsum.executable (uncompressed MSDOS version of xsum)</a> + +</pre> +</body> +</html> diff --git a/unix/f2c/mswin/README b/unix/f2c/mswin/README new file mode 100644 index 00000000..26f05313 --- /dev/null +++ b/unix/f2c/mswin/README @@ -0,0 +1,19 @@ +f2c.exe.gz is a compressed Win32 console binary for f2c that runs +under Microsoft Windows 9x and NT. It was compiled by Microsoft +Visual C++ 6.0 by makefile.vc. + +Compression is by gzip, source for which is available by ftp +in prep.ai.mit.edu:/pub/gnu. As a convenience, gzip binaries for +several systems (with names of the form system.executable) and +source for the gzip used to compress the *.gz files are available +for ftp from netlib directory gnu/gzip. In particular, if you +copy gnu/gzip/dos.executable to an MSDOS machine (in binary mode), +rename it gzip.exe, and rename f2c.exe.gz f2c.exz and f2cx.exe f2cx.exz, +then on the MSDOS machine you can recover f2c.exe and f2cx.exe by +executing "gzip -dN f2c.exz f2cx.exz". + +"xsum f2c.exe f2c.exe.gz" should give you: +f2c.exe b39b23e 245760 +f2c.exe.gz efe20e82 133264 + +Last update: 6 May 2006 diff --git a/unix/f2c/mswin/f2c.exe.gz b/unix/f2c/mswin/f2c.exe.gz Binary files differnew file mode 100644 index 00000000..a2d679c9 --- /dev/null +++ b/unix/f2c/mswin/f2c.exe.gz diff --git a/unix/f2c/mswin/index.html b/unix/f2c/mswin/index.html new file mode 100644 index 00000000..0fc5eb99 --- /dev/null +++ b/unix/f2c/mswin/index.html @@ -0,0 +1,16 @@ +<html> +<head> +<title>f2c/mswin</title> +</head> +<body> +<pre> +file <a href="README">README</a> + +file <a href="f2c.exe.gz">f2c.exe.gz</a> +for Win32 console version of f2c (compiled by MSVC++ 6.0) + +file <a href="makefile.vc">makefile.vc</a> +for compiling f2c.exe by MSVC++ +</pre> +</body> +</html> diff --git a/unix/f2c/mswin/makefile.vc b/unix/f2c/mswin/makefile.vc new file mode 100644 index 00000000..e79a6ca8 --- /dev/null +++ b/unix/f2c/mswin/makefile.vc @@ -0,0 +1,76 @@ +# 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".
diff --git a/unix/f2c/src/README b/unix/f2c/src/README new file mode 100644 index 00000000..1416f521 --- /dev/null +++ b/unix/f2c/src/README @@ -0,0 +1,186 @@ +To 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 <strings.h> +you may need to add " -Dstrchr=index" to the "CFLAGS =" assignment +in the makefile, and you may need to add " memset.o" to the "OBJECTS =" +assignment in the makefile -- see the comments in memset.c . + +For non-UNIX systems, you may need to change some things in sysdep.c, +such as the choice of intermediate file names. + +On some systems, you may need to modify parts of sysdep.h (which is +included by defs.h). In particular, for Sun 4.1 systems and perhaps +some others, you need to comment out the typedef of size_t. For some +systems (e.g., IRIX 4.0.1 and AIX) it is better to add +#define ANSI_Libraries +to the beginning of sysdep.h (or to supply -DANSI_Libraries in the +makefile). + +Alas, some systems #define __STDC__ but do not provide a true standard +(ANSI or ISO) C environment, e.g. do not provide stdlib.h . If yours +is such a system, then (a) you should complain loudly to your vendor +about __STDC__ being erroneously defined, and (b) you should insert +#undef __STDC__ +at the beginning of sysdep.h . You may need to make other adjustments. + +For some non-ANSI versions of stdio, you must change the values given +to binread and binwrite in sysdep.c from "rb" and "wb" to "r" and "w". +You may need to make this change if you run f2c and get an error +message of the form + Compiler error ... cannot open intermediate file ... + +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. diff --git a/unix/f2c/src/cds.c b/unix/f2c/src/cds.c new file mode 100644 index 00000000..05f3d501 --- /dev/null +++ b/unix/f2c/src/cds.c @@ -0,0 +1,195 @@ +/**************************************************************** +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; + } diff --git a/unix/f2c/src/data.c b/unix/f2c/src/data.c new file mode 100644 index 00000000..7da3ecb0 --- /dev/null +++ b/unix/f2c/src/data.c @@ -0,0 +1,502 @@ +/**************************************************************** +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; + } + } diff --git a/unix/f2c/src/defines.h b/unix/f2c/src/defines.h new file mode 100644 index 00000000..1ed4537e --- /dev/null +++ b/unix/f2c/src/defines.h @@ -0,0 +1,300 @@ +#define PDP11 4 + +#define BIGGEST_CHAR 0x7f /* Assumes 32-bit arithmetic */ +#define BIGGEST_SHORT 0x7fff /* Assumes 32-bit arithmetic */ +#define BIGGEST_LONG 0x7fffffff /* Assumes 32-bit arithmetic */ + +#define M(x) (1<<x) /* Mask (x) returns 2^x */ + +#define ALLOC(x) (struct x *) ckalloc((int)sizeof(struct x)) +#define ALLEXPR (expptr) ckalloc((int)sizeof(union Expression) ) +typedef int *ptr; +typedef char *charptr; +typedef FILE *FILEP; +typedef int flag; +typedef char field; /* actually need only 4 bits */ +typedef long int ftnint; +#define LOCAL static + +#define NO 0 +#define YES 1 + +#define CNULL (char *) 0 /* Character string null */ +#define PNULL (ptr) 0 +#define CHNULL (chainp) 0 /* Chain null */ +#define ENULL (expptr) 0 + + +/* BAD_MEMNO - used to distinguish between long string constants and other + constants in the table */ + +#define BAD_MEMNO -32768 + + +/* block tag values -- syntactic stuff */ + +#define TNAME 1 +#define TCONST 2 +#define TEXPR 3 +#define TADDR 4 +#define TPRIM 5 /* Primitive datum - should not appear in an + expptr variable, it should have already been + identified */ +#define TLIST 6 +#define TIMPLDO 7 +#define TERROR 8 + + +/* parser states - order is important, since there are several tests for + state < INDATA */ + +#define OUTSIDE 0 +#define INSIDE 1 +#define INDCL 2 +#define INDATA 3 +#define INEXEC 4 + +/* procedure classes */ + +#define PROCMAIN 1 +#define PROCBLOCK 2 +#define PROCSUBR 3 +#define PROCFUNCT 4 + + +/* storage classes -- vstg values. BSS and INIT are used in the later + merge pass over identifiers; and they are entered differently into the + symbol table */ + +#define STGUNKNOWN 0 +#define STGARG 1 /* adjustable dimensions */ +#define STGAUTO 2 /* for stack references */ +#define STGBSS 3 /* uninitialized storage (normal variables) */ +#define STGINIT 4 /* initialized storage */ +#define STGCONST 5 +#define STGEXT 6 /* external storage */ +#define STGINTR 7 /* intrinsic (late decision) reference. See + chapter 5 of the Fortran 77 standard */ +#define STGSTFUNCT 8 +#define STGCOMMON 9 +#define STGEQUIV 10 +#define STGREG 11 /* register - the outermost DO loop index will be + in a register (because the compiler is one + pass, it can't know where the innermost loop is + */ +#define STGLENG 12 +#define STGNULL 13 +#define STGMEMNO 14 /* interemediate-file pointer to constant table */ + +/* name classes -- vclass values, also procclass values */ + +#define CLUNKNOWN 0 +#define CLPARAM 1 /* Parameter - macro definition */ +#define CLVAR 2 /* variable */ +#define CLENTRY 3 +#define CLMAIN 4 +#define CLBLOCK 5 +#define CLPROC 6 +#define CLNAMELIST 7 /* in data with this tag, the vdcldone flag should + be ignored (according to vardcl()) */ + + +/* vprocclass values -- there is some overlap with the vclass values given + above */ + +#define PUNKNOWN 0 +#define PEXTERNAL 1 +#define PINTRINSIC 2 +#define PSTFUNCT 3 +#define PTHISPROC 4 /* here to allow recursion - further distinction + is given in the CL tag (those just above). + This applies to the presence of the name of a + function used within itself. The function name + means either call the function again, or assign + some value to the storage allocated to the + function's return value. */ + +/* control stack codes - these are part of a state machine which handles + the nesting of blocks (i.e. what to do about the ELSE statement) */ + +#define CTLDO 1 +#define CTLIF 2 +#define CTLELSE 3 +#define CTLIFX 4 + + +/* operators for both Fortran input and C output. They are common because + so many are shared between the trees */ + +#define OPPLUS 1 +#define OPMINUS 2 +#define OPSTAR 3 +#define OPSLASH 4 +#define OPPOWER 5 +#define OPNEG 6 +#define OPOR 7 +#define OPAND 8 +#define OPEQV 9 +#define OPNEQV 10 +#define OPNOT 11 +#define OPCONCAT 12 +#define OPLT 13 +#define OPEQ 14 +#define OPGT 15 +#define OPLE 16 +#define OPNE 17 +#define OPGE 18 +#define OPCALL 19 +#define OPCCALL 20 +#define OPASSIGN 21 +#define OPPLUSEQ 22 +#define OPSTAREQ 23 +#define OPCONV 24 +#define OPLSHIFT 25 +#define OPMOD 26 +#define OPCOMMA 27 +#define OPQUEST 28 +#define OPCOLON 29 +#define OPABS 30 +#define OPMIN 31 +#define OPMAX 32 +#define OPADDR 33 +#define OPCOMMA_ARG 34 +#define OPBITOR 35 +#define OPBITAND 36 +#define OPBITXOR 37 +#define OPBITNOT 38 +#define OPRSHIFT 39 +#define OPWHATSIN 40 /* dereferencing operator */ +#define OPMINUSEQ 41 /* assignment operators */ +#define OPSLASHEQ 42 +#define OPMODEQ 43 +#define OPLSHIFTEQ 44 +#define OPRSHIFTEQ 45 +#define OPBITANDEQ 46 +#define OPBITXOREQ 47 +#define OPBITOREQ 48 +#define OPPREINC 49 /* Preincrement (++x) operator */ +#define OPPREDEC 50 /* Predecrement (--x) operator */ +#define OPDOT 51 /* structure field reference */ +#define OPARROW 52 /* structure pointer field reference */ +#define OPNEG1 53 /* simple negation under forcedouble */ +#define OPDMIN 54 /* min(a,b) macro under forcedouble */ +#define OPDMAX 55 /* max(a,b) macro under forcedouble */ +#define OPASSIGNI 56 /* assignment for inquire stmt */ +#define OPIDENTITY 57 /* for turning TADDR into TEXPR */ +#define OPCHARCAST 58 /* for casting to char * (in I/O stmts) */ +#define OPDABS 59 /* abs macro under forcedouble */ +#define OPMIN2 60 /* min(a,b) macro */ +#define OPMAX2 61 /* max(a,b) macro */ +#define OPBITTEST 62 /* btest */ +#define OPBITCLR 63 /* ibclr */ +#define OPBITSET 64 /* ibset */ +#define OPQBITCLR 65 /* ibclr, integer*8 */ +#define OPQBITSET 66 /* ibset, integer*8 */ +#define OPBITBITS 67 /* ibits */ +#define OPBITSH 68 /* ishft */ +#define OPBITSHC 69 /* ishftc */ + +/* label type codes -- used with the ASSIGN statement */ + +#define LABUNKNOWN 0 +#define LABEXEC 1 +#define LABFORMAT 2 +#define LABOTHER 3 + + +/* INTRINSIC function codes*/ + +#define INTREND 0 +#define INTRCONV 1 +#define INTRMIN 2 +#define INTRMAX 3 +#define INTRGEN 4 /* General intrinsic, e.g. cos v. dcos, zcos, ccos */ +#define INTRSPEC 5 +#define INTRBOOL 6 +#define INTRCNST 7 /* constants, e.g. bigint(1.0) v. bigint (1d0) */ +#define INTRBGEN 8 /* bit manipulation */ + + +/* I/O statement codes - these all form Integer Constants, and are always + reevaluated */ + +#define IOSTDIN ICON(5) +#define IOSTDOUT ICON(6) +#define IOSTDERR ICON(0) + +#define IOSBAD (-1) +#define IOSPOSITIONAL 0 +#define IOSUNIT 1 +#define IOSFMT 2 + +#define IOINQUIRE 1 +#define IOOPEN 2 +#define IOCLOSE 3 +#define IOREWIND 4 +#define IOBACKSPACE 5 +#define IOENDFILE 6 +#define IOREAD 7 +#define IOWRITE 8 + + +/* User name tags -- these identify the form of the original identifier + stored in a struct Addrblock structure (in the user field). */ + +#define UNAM_UNKNOWN 0 /* Not specified */ +#define UNAM_NAME 1 /* Local symbol, store in the hash table */ +#define UNAM_IDENT 2 /* Character string not stored elsewhere */ +#define UNAM_EXTERN 3 /* External reference; check symbol table + using memno as index */ +#define UNAM_CONST 4 /* Constant value */ +#define UNAM_CHARP 5 /* pointer to string */ +#define UNAM_REF 6 /* subscript reference with -s */ + + +#define IDENT_LEN 31 /* Maximum length user.ident */ +#define MAXNAMELEN 50 /* Maximum Fortran name length */ + +/* type masks - TYLOGICAL defined in ftypes */ + +#define MSKLOGICAL M(TYLOGICAL)|M(TYLOGICAL1)|M(TYLOGICAL2) +#define MSKADDR M(TYADDR) +#define MSKCHAR M(TYCHAR) +#ifdef TYQUAD +#define MSKINT M(TYINT1)|M(TYSHORT)|M(TYLONG)|M(TYQUAD) +#else +#define MSKINT M(TYINT1)|M(TYSHORT)|M(TYLONG) +#endif +#define MSKREAL M(TYREAL)|M(TYDREAL) /* DREAL means Double Real */ +#define MSKCOMPLEX M(TYCOMPLEX)|M(TYDCOMPLEX) +#define MSKSTATIC (M(STGINIT)|M(STGBSS)|M(STGCOMMON)|M(STGEQUIV)|M(STGCONST)) + +/* miscellaneous macros */ + +/* ONEOF (x, y) -- x is the number of one of the OR'ed masks in y (i.e., x is + the log of one of the OR'ed masks in y) */ + +#define ONEOF(x,y) (M(x) & (y)) +#define ISCOMPLEX(z) ONEOF(z, MSKCOMPLEX) +#define ISREAL(z) ONEOF(z, MSKREAL) +#define ISNUMERIC(z) ONEOF(z, MSKINT|MSKREAL|MSKCOMPLEX) +#define ISICON(z) (z->tag==TCONST && ISINT(z->constblock.vtype)) +#define ISLOGICAL(z) ONEOF(z, MSKLOGICAL) + +/* ISCHAR assumes that z has some kind of structure, i.e. is not null */ + +#define ISCHAR(z) (z->headblock.vtype==TYCHAR) +#define ISINT(z) ONEOF(z, MSKINT) /* z is a tag, i.e. a mask number */ +#define ISCONST(z) (z->tag==TCONST) +#define ISERROR(z) (z->tag==TERROR) +#define ISPLUSOP(z) (z->tag==TEXPR && z->exprblock.opcode==OPPLUS) +#define ISSTAROP(z) (z->tag==TEXPR && z->exprblock.opcode==OPSTAR) +#define ISONE(z) (ISICON(z) && z->constblock.Const.ci==1) +#define INT(z) ONEOF(z, MSKINT|MSKCHAR) /* has INT storage in real life */ +#define ICON(z) mkintcon( (ftnint)(z) ) + +/* NO66 -- F77 feature is being used + NOEXT -- F77 extension is being used */ + +#define NO66(s) if(no66flag) err66(s) +#define NOEXT(s) if(noextflag) errext(s) diff --git a/unix/f2c/src/defs.h b/unix/f2c/src/defs.h new file mode 100644 index 00000000..0f0a1c2d --- /dev/null +++ b/unix/f2c/src/defs.h @@ -0,0 +1,1073 @@ +/**************************************************************** +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 <something> from going negative */ +extern int nintnames; + +/* Chain of tagged blocks */ + +struct Chain + { + chainp nextp; + char * datap; /* Tagged block */ + }; + +extern chainp chains; + +/* Recall that field is intended to hold four-bit characters */ + +/* This structure exists only to defeat the type checking */ + +struct Headblock + { + field tag; + field vtype; + field vclass; + field vstg; + expptr vleng; /* Expression for length of char string - + this may be a constant, or an argument + generated by mkarg() */ + } ; + +/* Control construct info (for do loops, else, etc) */ + +struct Ctlframe + { + unsigned ctltype:8; + unsigned dostepsign:8; /* 0 - variable, 1 - pos, 2 - neg */ + unsigned dowhile:1; + int ctlabels[4]; /* Control labels, defined below */ + int dolabel; /* label marking end of this DO loop */ + Namep donamep; /* DO index variable */ + expptr doinit; /* for use with -onetrip */ + expptr domax; /* constant or temp variable holding MAX + loop value; or expr of while(expr) */ + expptr dostep; /* expression */ + Namep loopname; + }; +#define endlabel ctlabels[0] +#define elselabel ctlabels[1] +#define dobodylabel ctlabels[1] +#define doposlabel ctlabels[2] +#define doneglabel ctlabels[3] +extern struct Ctlframe *ctls; /* Keeps info on DO and BLOCK IF + structures - this is the stack + bottom */ +extern struct Ctlframe *ctlstack; /* Pointer to current nesting + level */ +extern struct Ctlframe *lastctl; /* Point to end of + dynamically-allocated array */ + +typedef struct { + int type; + chainp cp; + } Atype; + +typedef struct { + int defined, dnargs, nargs, changes; + Atype atypes[1]; + } Argtypes; + +/* External Symbols */ + +struct Extsym + { + char *fextname; /* Fortran version of external name */ + char *cextname; /* C version of external name */ + field extstg; /* STG -- should be COMMON, UNKNOWN or EXT + */ + unsigned extype:4; /* for transmitting type to output routines */ + unsigned used_here:1; /* Boolean - true on the second pass + through a function if the block has + been referenced */ + unsigned exused:1; /* Has been used (for help with error msgs + about externals typed differently in + different modules) */ + unsigned exproto:1; /* type specified in a .P file */ + unsigned extinit:1; /* Procedure has been defined, + or COMMON has DATA */ + unsigned extseen:1; /* True if previously referenced */ + chainp extp; /* List of identifiers in the common + block for this function, stored as + Namep (hash table pointers) */ + chainp allextp; /* List of lists of identifiers; we keep one + list for each layout of this common block */ + int curno; /* current number for this common block, + used for constructing appending _nnn + to the common block name */ + int maxno; /* highest curno value for this common block */ + ftnint extleng; + ftnint maxleng; + Argtypes *arginfo; + }; +typedef struct Extsym Extsym; + +extern Extsym *extsymtab; /* External symbol table */ +extern Extsym *nextext; +extern Extsym *lastext; +extern int complex_seen, dcomplex_seen; + +/* Statement labels */ + +struct Labelblock + { + int labelno; /* Internal label */ + unsigned blklevel:8; /* level of nesting, for branch-in-loop + checking */ + unsigned labused:1; + unsigned fmtlabused:1; + unsigned labinacc:1; /* inaccessible? (i.e. has its scope + vanished) */ + unsigned labdefined:1; /* YES or NO */ + unsigned labtype:2; /* LAB{FORMAT,EXEC,etc} */ + ftnint stateno; /* Original label */ + char *fmtstring; /* format string */ + }; + +extern struct Labelblock *labeltab; /* Label table - keeps track of + all labels, including undefined */ +extern struct Labelblock *labtabend; +extern struct Labelblock *highlabtab; + +/* Entry point list */ + +struct Entrypoint + { + struct Entrypoint *entnextp; + Extsym *entryname; /* Name of this ENTRY */ + chainp arglist; + int typelabel; /* Label for function exit; this + will return the proper type of + object */ + Namep enamep; /* External name */ + }; + +/* Primitive block, or Primary block. This is a general template returned + by the parser, which will be interpreted in context. It is a template + for an identifier (variable name, function name), parenthesized + arguments (array subscripts, function parameters) and substring + specifications. */ + +struct Primblock + { + field tag; + field vtype; + unsigned parenused:1; /* distinguish (a) from a */ + Namep namep; /* Pointer to structure Nameblock */ + struct Listblock *argsp; + expptr fcharp; /* first-char-index-pointer (in + substring) */ + expptr lcharp; /* last-char-index-pointer (in + substring) */ + }; + + +struct Hashentry + { + int hashval; + Namep varp; + }; +extern struct Hashentry *hashtab; /* Hash table */ +extern struct Hashentry *lasthash; + +struct Intrpacked /* bits for intrinsic function description */ + { + unsigned f1:4; + unsigned f2:4; + unsigned f3:7; + unsigned f4:1; + }; + +struct Nameblock + { + field tag; + field vtype; + field vclass; + field vstg; + expptr vleng; /* length of character string, if applicable */ + char *fvarname; /* name in the Fortran source */ + char *cvarname; /* name in the resulting C */ + chainp vlastdim; /* datap points to new_vars entry for the */ + /* system variable, if any, storing the final */ + /* dimension; we zero the datap if this */ + /* variable is needed */ + unsigned vprocclass:3; /* P____ macros - selects the varxptr + field below */ + unsigned vdovar:1; /* "is it a DO variable?" for register + and multi-level loop checking */ + unsigned vdcldone:1; /* "do I think I'm done?" - set when the + context is sufficient to determine its + status */ + unsigned vadjdim:1; /* "adjustable dimension?" - needed for + information about copies */ + unsigned vsave:1; + unsigned vimpldovar:1; /* used to prevent erroneous error messages + for variables used only in DATA stmt + implicit DOs */ + unsigned vis_assigned:1;/* True if this variable has had some + label ASSIGNED to it; hence + varxptr.assigned_values is valid */ + unsigned vimplstg:1; /* True if storage type is assigned implicitly; + this allows a COMMON variable to participate + in a DIMENSION before the COMMON declaration. + */ + unsigned vcommequiv:1; /* True if EQUIVALENCEd onto STGCOMMON */ + unsigned vfmt_asg:1; /* True if char *var_fmt needed */ + unsigned vpassed:1; /* True if passed as a character-variable arg */ + unsigned vknownarg:1; /* True if seen in a previous entry point */ + unsigned visused:1; /* True if variable is referenced -- so we */ + /* can omit variables that only appear in DATA */ + unsigned vnamelist:1; /* Appears in a NAMELIST */ + unsigned vimpltype:1; /* True if implicitly typed and not + invoked as a function or subroutine + (so we can consistently type procedures + declared external and passed as args + but never invoked). + */ + unsigned vtypewarned:1; /* so we complain just once about + changed types of external procedures */ + unsigned vinftype:1; /* so we can restore implicit type to a + procedure if it is invoked as a function + after being given a different type by -it */ + unsigned vinfproc:1; /* True if -it infers this to be a procedure */ + unsigned vcalled:1; /* has been invoked */ + unsigned vdimfinish:1; /* need to invoke dim_finish() */ + unsigned vrefused:1; /* Need to #define name_ref (for -s) */ + unsigned vsubscrused:1; /* Need to #define name_subscr (for -2) */ + unsigned veqvadjust:1; /* voffset has been adjusted for equivalence */ + +/* The vardesc union below is used to store the number of an intrinsic + function (when vstg == STGINTR and vprocclass == PINTRINSIC), or to + store the index of this external symbol in extsymtab (when vstg == + STGEXT and vprocclass == PEXTERNAL) */ + + union { + int varno; /* Return variable for a function. + This is used when a function is + assigned a return value. Also + used to point to the COMMON + block, when this is a field of + that block. Also points to + EQUIV block when STGEQUIV */ + struct Intrpacked intrdesc; /* bits for intrinsic function*/ + } vardesc; + struct Dimblock *vdim; /* points to the dimensions if they exist */ + ftnint voffset; /* offset in a storage block (the variable + name will be "v.%d", voffset in a + common blck on the vax). Also holds + pointers for automatic variables. When + STGEQUIV, this is -(offset from array + base) */ + union { + chainp namelist; /* points to names in the NAMELIST, + if this is a NAMELIST name */ + chainp vstfdesc; /* points to (formals, expr) pair */ + chainp assigned_values; /* list of integers, each being a + statement label assigned to + this variable in the current function */ + } varxptr; + int argno; /* for multiple entries */ + Argtypes *arginfo; + }; + + +/* PARAMETER statements */ + +struct Paramblock + { + field tag; + field vtype; + field vclass; + field vstg; + expptr vleng; + char *fvarname; + char *cvarname; + expptr paramval; + } ; + + +/* Expression block */ + +struct Exprblock + { + field tag; + field vtype; + field vclass; + field vstg; + expptr vleng; /* in the case of a character expression, this + value is inherited from the children */ + unsigned 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 <x 1>, <y 2>, <z 3> AT THE INVOCATION, NOT + at the definition */ + +struct Rplblock /* name replacement block */ + { + struct Rplblock *rplnextp; + Namep rplnp; /* Name of the formal parameter */ + expptr rplvp; /* Value of the actual parameter */ + expptr rplxp; /* Initialization of temporary variable, + if required; else null */ + int rpltag; /* Tag on the value of the actual param */ + }; + + + +/* Equivalence block */ + +struct Equivblock + { + struct Eqvchain *equivs; /* List (Eqvchain) of primblocks + holding variable identifiers */ + flag eqvinit; + long eqvtop; + long eqvbottom; + int eqvtype; + } ; +#define eqvleng eqvtop + +extern struct Equivblock *eqvclass; + + +struct Eqvchain + { + struct Eqvchain *eqvnextp; + union + { + struct Primblock *eqvlhs; + Namep eqvname; + } eqvitem; + long eqvoffset; + } ; + + + +/* For allocation purposes only, and to keep lint quiet. In particular, + don't count on the tag being able to tell you which structure is used */ + + +/* There is a tradition in Fortran that the compiler not generate the same + bit pattern more than is necessary. This structure is used to do just + that; if two integer constants have the same bit pattern, just generate + it once. This could be expanded to optimize without regard to type, by + removing the type check in putconst() */ + +struct Literal + { + short littype; + short lituse; /* usage count */ + long litnum; /* numeric part of the assembler + label for this constant value */ + union { + ftnint litival; + double litdval[2]; + ftnint litival2[2]; /* length, nblanks for strings */ +#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 diff --git a/unix/f2c/src/equiv.c b/unix/f2c/src/equiv.c new file mode 100644 index 00000000..bcf07e72 --- /dev/null +++ b/unix/f2c/src/equiv.c @@ -0,0 +1,412 @@ +/**************************************************************** +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; + } diff --git a/unix/f2c/src/error.c b/unix/f2c/src/error.c new file mode 100644 index 00000000..d0064f03 --- /dev/null +++ b/unix/f2c/src/error.c @@ -0,0 +1,347 @@ +/**************************************************************** +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; +} diff --git a/unix/f2c/src/exec.c b/unix/f2c/src/exec.c new file mode 100644 index 00000000..88932222 --- /dev/null +++ b/unix/f2c/src/exec.c @@ -0,0 +1,984 @@ +/**************************************************************** +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 */ +} diff --git a/unix/f2c/src/expr.c b/unix/f2c/src/expr.c new file mode 100644 index 00000000..d9f86c0f --- /dev/null +++ b/unix/f2c/src/expr.c @@ -0,0 +1,3738 @@ +/**************************************************************** +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); + } diff --git a/unix/f2c/src/f2c.1 b/unix/f2c/src/f2c.1 new file mode 100644 index 00000000..3bdbc8b8 --- /dev/null +++ b/unix/f2c/src/f2c.1 @@ -0,0 +1,222 @@ + + 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) + diff --git a/unix/f2c/src/f2c.1t b/unix/f2c/src/f2c.1t new file mode 100644 index 00000000..d73d3347 --- /dev/null +++ b/unix/f2c/src/f2c.1t @@ -0,0 +1,391 @@ +. \" 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 . diff --git a/unix/f2c/src/f2c.h b/unix/f2c/src/f2c.h new file mode 100644 index 00000000..b94ee7c8 --- /dev/null +++ b/unix/f2c/src/f2c.h @@ -0,0 +1,223 @@ +/* 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 diff --git a/unix/f2c/src/format.c b/unix/f2c/src/format.c new file mode 100644 index 00000000..96f2acf9 --- /dev/null +++ b/unix/f2c/src/format.c @@ -0,0 +1,2613 @@ +/**************************************************************** +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); + } + } diff --git a/unix/f2c/src/format.h b/unix/f2c/src/format.h new file mode 100644 index 00000000..3de97f6f --- /dev/null +++ b/unix/f2c/src/format.h @@ -0,0 +1,12 @@ +#define DEF_C_LINE_LENGTH 77 +/* actual max will be 79 */ + +extern int c_output_line_length; /* max # chars per line in C source + code */ + +chainp data_value Argdcl((FILEP, long int, int)); +int do_init_data Argdcl((FILEP, FILEP)); +void list_init_data Argdcl((FILEP*, char*, FILEP)); +char* wr_ardecls Argdcl((FILEP, struct Dimblock*, long int)); +void wr_one_init Argdcl((FILEP, char*, chainp*, int)); +void wr_output_values Argdcl((FILEP, Namep, chainp)); diff --git a/unix/f2c/src/formatdata.c b/unix/f2c/src/formatdata.c new file mode 100644 index 00000000..c399c618 --- /dev/null +++ b/unix/f2c/src/formatdata.c @@ -0,0 +1,1263 @@ +/**************************************************************** +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); + } diff --git a/unix/f2c/src/ftypes.h b/unix/f2c/src/ftypes.h new file mode 100644 index 00000000..8181d876 --- /dev/null +++ b/unix/f2c/src/ftypes.h @@ -0,0 +1,64 @@ + +/* 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? */ + diff --git a/unix/f2c/src/gram.c b/unix/f2c/src/gram.c new file mode 100644 index 00000000..16d524e3 --- /dev/null +++ b/unix/f2c/src/gram.c @@ -0,0 +1,1957 @@ +#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->blklevel<blklevel + && thislabel->labtype!=LABFORMAT) + warn1("there is a branch to label %s from outside block", + convic( (ftnint) (thislabel->stateno) ) ); + thislabel->blklevel = blklevel; + thislabel->labdefined = YES; + if(thislabel->labtype != LABFORMAT) + p1_label((long)(thislabel - labeltab)); + } + } + else 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 */ +} diff --git a/unix/f2c/src/gram.dcl b/unix/f2c/src/gram.dcl new file mode 100644 index 00000000..e5c5df0d --- /dev/null +++ b/unix/f2c/src/gram.dcl @@ -0,0 +1,416 @@ +spec: dcl + | common + | external + | intrinsic + | equivalence + | data + | implicit + | namelist + | SSAVE + { NO66("SAVE statement"); + saveall = YES; } + | SSAVE savelist + { NO66("SAVE statement"); } + | SFORMAT + { fmtstmt(thislabel); setfmt(thislabel); } + | SPARAM in_dcl SLPAR paramlist SRPAR + { NO66("PARAMETER statement"); } + ; + +dcl: type opt_comma name in_dcl new_dcl dims lengspec + { settype($3, $1, $7); + if(ndim>0) setbound($3,ndim,dims); + } + | dcl SCOMMA name dims lengspec + { settype($3, $1, $5); + if(ndim>0) setbound($3,ndim,dims); + } + | dcl SSLASHD datainit vallist SSLASHD + { if (new_dcl == 2) { + err("attempt to give DATA in type-declaration"); + new_dcl = 1; + } + } + ; + +new_dcl: { new_dcl = 2; } ; + +type: typespec lengspec + { varleng = $2; } + ; + +typespec: typename + { varleng = ($1<0 || ONEOF($1,M(TYLOGICAL)|M(TYLONG)) + ? 0 : typesize[$1]); + vartype = $1; } + ; + +typename: SINTEGER { $$ = TYLONG; } + | SREAL { $$ = tyreal; } + | SCOMPLEX { ++complex_seen; $$ = tycomplex; } + | SDOUBLE { $$ = TYDREAL; } + | SDCOMPLEX { ++dcomplex_seen; NOEXT("DOUBLE COMPLEX statement"); $$ = TYDCOMPLEX; } + | SLOGICAL { $$ = TYLOGICAL; } + | SCHARACTER { NO66("CHARACTER statement"); $$ = TYCHAR; } + | SUNDEFINED { $$ = TYUNKNOWN; } + | SDIMENSION { $$ = TYUNKNOWN; } + | SAUTOMATIC { NOEXT("AUTOMATIC statement"); $$ = - STGAUTO; } + | SSTATIC { NOEXT("STATIC statement"); $$ = - STGBSS; } + | SBYTE { $$ = TYINT1; } + ; + +lengspec: + { $$ = varleng; } + | SSTAR intonlyon expr intonlyoff + { + expptr p; + p = $3; + NO66("length specification *n"); + if( ! ISICON(p) || p->constblock.Const.ci <= 0 ) + { + $$ = 0; + dclerr("length must be a positive integer constant", + NPNULL); + } + else { + if (vartype == TYCHAR) + $$ = p->constblock.Const.ci; + else switch((int)p->constblock.Const.ci) { + case 1: $$ = 1; break; + case 2: $$ = typesize[TYSHORT]; break; + case 4: $$ = typesize[TYLONG]; break; + case 8: $$ = typesize[TYDREAL]; break; + case 16: $$ = typesize[TYDCOMPLEX]; break; + default: + dclerr("invalid length",NPNULL); + $$ = varleng; + } + } + } + | SSTAR intonlyon SLPAR SSTAR SRPAR intonlyoff + { NO66("length specification *(*)"); $$ = -1; } + ; + +common: SCOMMON in_dcl var + { incomm( $$ = comblock("") , $3 ); } + | SCOMMON in_dcl comblock var + { $$ = $3; incomm($3, $4); } + | common opt_comma comblock opt_comma var + { $$ = $3; incomm($3, $5); } + | common SCOMMA var + { incomm($1, $3); } + ; + +comblock: SCONCAT + { $$ = comblock(""); } + | SSLASH SNAME SSLASH + { $$ = comblock(token); } + ; + +external: SEXTERNAL in_dcl name + { setext($3); } + | external SCOMMA name + { setext($3); } + ; + +intrinsic: SINTRINSIC in_dcl name + { NO66("INTRINSIC statement"); setintr($3); } + | intrinsic SCOMMA name + { setintr($3); } + ; + +equivalence: SEQUIV in_dcl equivset + | equivalence SCOMMA equivset + ; + +equivset: SLPAR equivlist SRPAR + { + struct Equivblock *p; + if(nequiv >= maxequiv) + many("equivalences", 'q', maxequiv); + p = & eqvclass[nequiv++]; + p->eqvinit = NO; + p->eqvbottom = 0; + p->eqvtop = 0; + p->equivs = $2; + } + ; + +equivlist: lhs + { $$=ALLOC(Eqvchain); + $$->eqvitem.eqvlhs = primchk($1); + } + | equivlist SCOMMA lhs + { $$=ALLOC(Eqvchain); + $$->eqvitem.eqvlhs = primchk($3); + $$->eqvnextp = $1; + } + ; + +data: SDATA in_data datalist + | data opt_comma datalist + ; + +in_data: + { if(parstate == OUTSIDE) + { + newproc(); + startproc(ESNULL, CLMAIN); + } + if(parstate < INDATA) + { + enddcl(); + parstate = INDATA; + datagripe = 1; + } + } + ; + +datalist: datainit datavarlist SSLASH datapop vallist SSLASH + { ftnint junk; + if(nextdata(&junk) != NULL) + err("too few initializers"); + frdata($2); + frrpl(); + } + ; + +datainit: /* nothing */ { frchain(&datastack); curdtp = 0; } ; + +datapop: /* nothing */ { pop_datastack(); } ; + +vallist: { toomanyinit = NO; } val + | vallist SCOMMA val + ; + +val: value + { dataval(ENULL, $1); } + | simple SSTAR value + { dataval($1, $3); } + ; + +value: simple + | addop simple + { if( $1==OPMINUS && ISCONST($2) ) + consnegop((Constp)$2); + $$ = $2; + } + | complex_const + ; + +savelist: saveitem + | savelist SCOMMA saveitem + ; + +saveitem: name + { int k; + $1->vsave = YES; + k = $1->vstg; + if( ! ONEOF(k, M(STGUNKNOWN)|M(STGBSS)|M(STGINIT)) ) + dclerr("can only save static variables", $1); + } + | comblock + ; + +paramlist: paramitem + | paramlist SCOMMA paramitem + ; + +paramitem: name SEQUALS expr + { if($1->vclass == CLUNKNOWN) + make_param((struct Paramblock *)$1, $3); + else dclerr("cannot make into parameter", $1); + } + ; + +var: name dims + { if(ndim>0) setbound($1, ndim, dims); } + ; + +datavar: lhs + { Namep np; + struct Primblock *pp = (struct Primblock *)$1; + int tt = $1->tag; + if (tt != TPRIM) { + if (tt == TCONST) + err("parameter in data statement"); + else + erri("tag %d in data statement",tt); + $$ = 0; + err_lineno = lineno; + break; + } + np = pp -> namep; + vardcl(np); + if ((pp->fcharp || pp->lcharp) + && (np->vtype != TYCHAR || np->vdim && !pp->argsp)) + sserr(np); + if(np->vstg == STGCOMMON) + extsymtab[np->vardesc.varno].extinit = YES; + else if(np->vstg==STGEQUIV) + eqvclass[np->vardesc.varno].eqvinit = YES; + else if(np->vstg!=STGINIT && np->vstg!=STGBSS) { + errstr(np->vstg == STGARG + ? "Dummy argument \"%.60s\" in data statement." + : "Cannot give data to \"%.75s\"", + np->fvarname); + $$ = 0; + err_lineno = lineno; + break; + } + $$ = mkchain((char *)$1, CHNULL); + } + | SLPAR datavarlist SCOMMA dospec SRPAR + { chainp p; struct Impldoblock *q; + pop_datastack(); + q = ALLOC(Impldoblock); + q->tag = TIMPLDO; + (q->varnp = (Namep) ($4->datap))->vimpldovar = 1; + p = $4->nextp; + if(p) { q->implb = (expptr)(p->datap); p = p->nextp; } + if(p) { q->impub = (expptr)(p->datap); p = p->nextp; } + if(p) { q->impstep = (expptr)(p->datap); } + frchain( & ($4) ); + $$ = mkchain((char *)q, CHNULL); + q->datalist = hookup($2, $$); + } + ; + +datavarlist: datavar + { if (!datastack) + curdtp = 0; + datastack = mkchain((char *)curdtp, datastack); + curdtp = $1; curdtelt = 0; + } + | datavarlist SCOMMA datavar + { $$ = hookup($1, $3); } + ; + +dims: + { ndim = 0; } + | SLPAR dimlist SRPAR + ; + +dimlist: { ndim = 0; } dim + | dimlist SCOMMA dim + ; + +dim: ubound + { + if(ndim == maxdim) + err("too many dimensions"); + else if(ndim < maxdim) + { dims[ndim].lb = 0; + dims[ndim].ub = $1; + } + ++ndim; + } + | expr SCOLON ubound + { + if(ndim == maxdim) + err("too many dimensions"); + else if(ndim < maxdim) + { dims[ndim].lb = $1; + dims[ndim].ub = $3; + } + ++ndim; + } + ; + +ubound: SSTAR + { $$ = 0; } + | expr + ; + +labellist: label + { nstars = 1; labarray[0] = $1; } + | labellist SCOMMA label + { if(nstars < maxlablist) labarray[nstars++] = $3; } + ; + +label: SICON + { $$ = execlab( convci(toklen, token) ); } + ; + +implicit: SIMPLICIT in_dcl implist + { NO66("IMPLICIT statement"); } + | implicit SCOMMA implist + ; + +implist: imptype SLPAR letgroups SRPAR + | imptype + { if (vartype != TYUNKNOWN) + dclerr("-- expected letter range",NPNULL); + setimpl(vartype, varleng, 'a', 'z'); } + ; + +imptype: { needkwd = 1; } type + /* { vartype = $2; } */ + ; + +letgroups: letgroup + | letgroups SCOMMA letgroup + ; + +letgroup: letter + { setimpl(vartype, varleng, $1, $1); } + | letter SMINUS letter + { setimpl(vartype, varleng, $1, $3); } + ; + +letter: SNAME + { if(toklen!=1 || token[0]<'a' || token[0]>'z') + { + dclerr("implicit item must be single letter", NPNULL); + $$ = 0; + } + else $$ = token[0]; + } + ; + +namelist: SNAMELIST + | namelist namelistentry + ; + +namelistentry: SSLASH name SSLASH namelistlist + { + if($2->vclass == CLUNKNOWN) + { + $2->vclass = CLNAMELIST; + $2->vtype = TYINT; + $2->vstg = STGBSS; + $2->varxptr.namelist = $4; + $2->vardesc.varno = ++lastvarno; + } + else dclerr("cannot be a namelist name", $2); + } + ; + +namelistlist: name + { $$ = mkchain((char *)$1, CHNULL); } + | namelistlist SCOMMA name + { $$ = hookup($1, mkchain((char *)$3, CHNULL)); } + ; + +in_dcl: + { switch(parstate) + { + case OUTSIDE: newproc(); + startproc(ESNULL, CLMAIN); + case INSIDE: parstate = INDCL; + case INDCL: break; + + case INDATA: + if (datagripe) { + errstr( + "Statement order error: declaration after DATA", + CNULL); + datagripe = 0; + } + break; + + default: + dclerr("declaration among executables", NPNULL); + } + } + ; diff --git a/unix/f2c/src/gram.exec b/unix/f2c/src/gram.exec new file mode 100644 index 00000000..98a94f90 --- /dev/null +++ b/unix/f2c/src/gram.exec @@ -0,0 +1,143 @@ +exec: iffable + | SDO end_spec label opt_comma dospecw + { + if($3->labdefined) + execerr("no backward DO loops", CNULL); + $3->blklevel = blklevel+1; + exdo($3->labelno, NPNULL, $5); + } + | SDO end_spec opt_comma dospecw + { + exdo((int)(ctls - ctlstack - 2), NPNULL, $4); + NOEXT("DO without label"); + } + | SENDDO + { exenddo(NPNULL); } + | logif iffable + { exendif(); thiswasbranch = NO; } + | logif STHEN + | SELSEIF end_spec SLPAR {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; } + ; diff --git a/unix/f2c/src/gram.expr b/unix/f2c/src/gram.expr new file mode 100644 index 00000000..b6ce6ff1 --- /dev/null +++ b/unix/f2c/src/gram.expr @@ -0,0 +1,146 @@ +funarglist: + { $$ = 0; } + | funargs + { $$ = revchain($1); } + ; + +funargs: expr + { $$ = mkchain((char *)$1, CHNULL); } + | funargs SCOMMA expr + { $$ = mkchain((char *)$3, $1); } + ; + + +expr: uexpr + | SLPAR expr SRPAR { $$ = $2; if ($$->tag == TPRIM) + 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); } + ; diff --git a/unix/f2c/src/gram.head b/unix/f2c/src/gram.head new file mode 100644 index 00000000..be17cd29 --- /dev/null +++ b/unix/f2c/src/gram.head @@ -0,0 +1,293 @@ +/**************************************************************** +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 <labval> thislabel label assignlabel +%type <tagval> other inelt +%type <ival> type typespec typename dcl letter addop relop stop nameeq +%type <lval> lengspec +%type <charpval> filename +%type <chval> datavar datavarlist namelistlist funarglist funargs +%type <chval> dospec dospecw +%type <chval> callarglist arglist args exprlist inlist outlist out2 substring +%type <namval> name arg call var +%type <expval> lhs expr uexpr opt_expr fexpr unpar_fexpr +%type <expval> ubound simple value callarg complex_const simple_const bit_const +%type <extval> common comblock entryname progname +%type <eqvval> equivlist + +%% + +program: + | program stat SEOS + ; + +stat: thislabel entry + { +/* stat: is the nonterminal for Fortran statements */ + + lastwasbranch = NO; } + | thislabel spec + | thislabel exec + { /* forbid further statement function definitions... */ + if (parstate == INDATA && laststfcn != thisstno) + parstate = INEXEC; + thisstno++; + if($1 && ($1->labelno==dorange)) + enddo($1->labelno); + if(lastwasbranch && thislabel==NULL) + warn("statement cannot be reached"); + lastwasbranch = thiswasbranch; + thiswasbranch = NO; + if($1) + { + if($1->labtype == LABFORMAT) + err("label already that of a format"); + else + $1->labtype = LABEXEC; + } + freetemps(); + } + | thislabel SINCLUDE filename + { if (can_include) + doinclude( $3 ); + else { + fprintf(diagfile, "Cannot open file %s\n", $3); + done(1); + } + } + | thislabel SEND end_spec + { if ($1) + lastwasbranch = NO; + 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->blklevel<blklevel + && thislabel->labtype!=LABFORMAT) + warn1("there is a branch to label %s from outside block", + convic( (ftnint) (thislabel->stateno) ) ); + thislabel->blklevel = blklevel; + thislabel->labdefined = YES; + if(thislabel->labtype != LABFORMAT) + p1_label((long)(thislabel - labeltab)); + } + } + else $$ = thislabel = NULL; + } + ; + +entry: SPROGRAM new_proc progname + {startproc($3, CLMAIN); } + | SPROGRAM new_proc progname progarglist + { warn("ignoring arguments to main program"); + /* hashclear(); */ + startproc($3, CLMAIN); } + | SBLOCK new_proc progname + { if($3) NO66("named BLOCKDATA"); + startproc($3, CLBLOCK); } + | SSUBROUTINE new_proc entryname arglist + { entrypt(CLPROC, TYSUBR, (ftnint) 0, $3, $4); } + | SFUNCTION new_proc entryname arglist + { entrypt(CLPROC, TYUNKNOWN, (ftnint) 0, $3, $4); } + | type SFUNCTION new_proc entryname arglist + { entrypt(CLPROC, $1, varleng, $4, $5); } + | SENTRY entryname arglist + { if(parstate==OUTSIDE || procclass==CLMAIN + || procclass==CLBLOCK) + execerr("misplaced entry statement", CNULL); + entrypt(CLENTRY, 0, (ftnint) 0, $2, $3); + } + ; + +new_proc: + { newproc(); } + ; + +entryname: name + { $$ = newentry($1, 1); } + ; + +name: SNAME + { $$ = mkname(token); } + ; + +progname: { $$ = NULL; } + | entryname + ; + +progarglist: + SLPAR SRPAR + | SLPAR progargs SRPAR + ; + +progargs: progarg + | progargs SCOMMA progarg + ; + +progarg: SNAME + | SNAME SEQUALS SNAME + ; + +arglist: + { $$ = 0; } + | SLPAR SRPAR + { NO66(" () argument list"); + $$ = 0; } + | SLPAR args SRPAR + {$$ = $2; } + ; + +args: arg + { $$ = ($1 ? mkchain((char *)$1,CHNULL) : CHNULL ); } + | args SCOMMA arg + { if($3) $1 = $$ = mkchain((char *)$3, $1); } + ; + +arg: name + { if($1->vstg!=STGUNKNOWN && $1->vstg!=STGARG) + dclerr("name declared as argument after use", $1); + $1->vstg = STGARG; + } + | SSTAR + { NO66("altenate return argument"); + +/* substars means that '*'ed formal parameters should be replaced. + This is used to specify alternate return labels; in theory, only + parameter slots which have '*' should accept the statement labels. + This compiler chooses to ignore the '*'s in the formal declaration, and + always return the proper value anyway. + + This variable is only referred to in proc.c */ + + $$ = 0; substars = YES; } + ; + + + +filename: SHOLLERITH + { + char *s; + s = copyn(toklen+1, token); + s[toklen] = '\0'; + $$ = s; + } + ; diff --git a/unix/f2c/src/gram.io b/unix/f2c/src/gram.io new file mode 100644 index 00000000..00ff0f28 --- /dev/null +++ b/unix/f2c/src/gram.io @@ -0,0 +1,175 @@ + /* 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(); } + ; diff --git a/unix/f2c/src/index.html b/unix/f2c/src/index.html new file mode 100644 index 00000000..c3215ac2 --- /dev/null +++ b/unix/f2c/src/index.html @@ -0,0 +1,150 @@ +<head> +<title>f2c/src</title> +<meta name="waisindex" value="nse"> +</head> +<h1>f2c/src</h1> +<p> +Click <A HREF="http://www.netlib.org/master_counts2.html#f2c/src">here</A> to see the number of accesses to this library. +<p><hr> +<pre> +# ====== 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 <a href="cds.c">cds.c</a> <a href="/cgi-bin/netlibfiles.pl?filename=/f2c/src/cds.c">cds.c plus dependencies</a> + +file <a href="data.c">data.c</a> + +file <a href="defines.h">defines.h</a> <a href="/cgi-bin/netlibfiles.pl?filename=/f2c/src/defines.h">defines.h plus dependencies</a> + +file <a href="defs.h">defs.h</a> + +file <a href="equiv.c">equiv.c</a> <a href="/cgi-bin/netlibfiles.pl?filename=/f2c/src/equiv.c">equiv.c plus dependencies</a> + +file <a href="error.c">error.c</a> + +file <a href="exec.c">exec.c</a> <a href="/cgi-bin/netlibfiles.pl?filename=/f2c/src/exec.c">exec.c plus dependencies</a> + +file <a href="expr.c">expr.c</a> + +file <a href="f2c.1">f2c.1</a> <a href="/cgi-bin/netlibfiles.pl?filename=/f2c/src/f2c.1">f2c.1 plus dependencies</a> + +file <a href="f2c.1t">f2c.1t</a> + +file <a href="f2c.h">f2c.h</a> <a href="/cgi-bin/netlibfiles.pl?filename=/f2c/src/f2c.h">f2c.h plus dependencies</a> + +file <a href="format.c">format.c</a> + +file <a href="format.h">format.h</a> <a href="/cgi-bin/netlibfiles.pl?filename=/f2c/src/format.h">format.h plus dependencies</a> + +file <a href="formatdata.c">formatdata.c</a> + +file <a href="ftypes.h">ftypes.h</a> <a href="/cgi-bin/netlibfiles.pl?filename=/f2c/src/ftypes.h">ftypes.h plus dependencies</a> + +file <a href="gram.c">gram.c</a> + +file <a href="gram.dcl">gram.dcl</a> <a href="/cgi-bin/netlibfiles.pl?filename=/f2c/src/gram.dcl">gram.dcl plus dependencies</a> + +file <a href="gram.exec">gram.exec</a> + +file <a href="gram.expr">gram.expr</a> <a href="/cgi-bin/netlibfiles.pl?filename=/f2c/src/gram.expr">gram.expr plus dependencies</a> + +file <a href="gram.head">gram.head</a> + +file <a href="gram.io">gram.io</a> <a href="/cgi-bin/netlibfiles.pl?filename=/f2c/src/gram.io">gram.io plus dependencies</a> + +file <a href="init.c">init.c</a> + +file <a href="intr.c">intr.c</a> <a href="/cgi-bin/netlibfiles.pl?filename=/f2c/src/intr.c">intr.c plus dependencies</a> + +file <a href="io.c">io.c</a> + +file <a href="iob.h">iob.h</a> <a href="/cgi-bin/netlibfiles.pl?filename=/f2c/src/iob.h">iob.h plus dependencies</a> + +file <a href="lex.c">lex.c</a> + +file <a href="machdefs.h">machdefs.h</a> <a href="/cgi-bin/netlibfiles.pl?filename=/f2c/src/machdefs.h">machdefs.h plus dependencies</a> + +file <a href="main.c">main.c</a> + +file <a href="makefile.u">makefile.u</a> <a href="/cgi-bin/netlibfiles.pl?filename=/f2c/src/makefile.u">makefile.u plus dependencies</a> + +file <a href="makefile.vc">makefile.vc</a> + +file <a href="malloc.c">malloc.c</a> <a href="/cgi-bin/netlibfiles.pl?filename=/f2c/src/malloc.c">malloc.c plus dependencies</a> + +file <a href="mem.c">mem.c</a> + +file <a href="memset.c">memset.c</a> <a href="/cgi-bin/netlibfiles.pl?filename=/f2c/src/memset.c">memset.c plus dependencies</a> + +file <a href="misc.c">misc.c</a> + +file <a href="mkfile.plan9">mkfile.plan9</a> <a href="/cgi-bin/netlibfiles.pl?filename=/f2c/src/mkfile.plan9">mkfile.plan9 plus dependencies</a> +for making f2c under plan 9 (mk -f mkfile.plan9) + +file <a href="names.c">names.c</a> + +file <a href="names.h">names.h</a> <a href="/cgi-bin/netlibfiles.pl?filename=/f2c/src/names.h">names.h plus dependencies</a> + +file <a href="niceprintf.c">niceprintf.c</a> + +file <a href="niceprintf.h">niceprintf.h</a> <a href="/cgi-bin/netlibfiles.pl?filename=/f2c/src/niceprintf.h">niceprintf.h plus dependencies</a> + +file <a href="notice">notice</a> + +file <a href="output.c">output.c</a> + +file <a href="output.h">output.h</a> <a href="/cgi-bin/netlibfiles.pl?filename=/f2c/src/output.h">output.h plus dependencies</a> + +file <a href="p1defs.h">p1defs.h</a> + +file <a href="p1output.c">p1output.c</a> <a href="/cgi-bin/netlibfiles.pl?filename=/f2c/src/p1output.c">p1output.c plus dependencies</a> + +file <a href="parse.h">parse.h</a> + +file <a href="parse_args.c">parse_args.c</a> <a href="/cgi-bin/netlibfiles.pl?filename=/f2c/src/parse_args.c">parse_args.c plus dependencies</a> + +file <a href="pccdefs.h">pccdefs.h</a> + +file <a href="pread.c">pread.c</a> <a href="/cgi-bin/netlibfiles.pl?filename=/f2c/src/pread.c">pread.c plus dependencies</a> + +file <a href="proc.c">proc.c</a> + +file <a href="put.c">put.c</a> <a href="/cgi-bin/netlibfiles.pl?filename=/f2c/src/put.c">put.c plus dependencies</a> + +file <a href="putpcc.c">putpcc.c</a> + +file <a href="sysdep.c">sysdep.c</a> <a href="/cgi-bin/netlibfiles.pl?filename=/f2c/src/sysdep.c">sysdep.c plus dependencies</a> + +file <a href="sysdep.h">sysdep.h</a> + +file <a href="sysdeptest.c">sysdeptest.c</a> <a href="/cgi-bin/netlibfiles.pl?filename=/f2c/src/sysdeptest.c">sysdeptest.c plus dependencies</a> + +file <a href="tokens">tokens</a> + +file <a href="tokdefs.h">tokdefs.h</a> <a href="/cgi-bin/netlibfiles.pl?filename=/f2c/src/tokdefs.h">tokdefs.h plus dependencies</a> + +file <a href="usignal.h">usignal.h</a> + +file <a href="vax.c">vax.c</a> <a href="/cgi-bin/netlibfiles.pl?filename=/f2c/src/vax.c">vax.c plus dependencies</a> + +file <a href="version.c">version.c</a> + +file <a href="xsum.c">xsum.c</a> <a href="/cgi-bin/netlibfiles.pl?filename=/f2c/src/xsum.c">xsum.c plus dependencies</a> + +file <a href="xsum0.out">xsum0.out</a> + +file <a href="Notice">Notice</a> + +file <a href="README">README</a> + +file <a href="readme">readme</a> + +</pre> +</body> +</html> diff --git a/unix/f2c/src/init.c b/unix/f2c/src/init.c new file mode 100644 index 00000000..752c99a8 --- /dev/null +++ b/unix/f2c/src/init.c @@ -0,0 +1,526 @@ +/**************************************************************** +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[] = { + "<<unknown>>", + "address", + "integer1", + "shortint", + "integer", +#ifdef TYQUAD + "longint", +#endif + "real", + "doublereal", + "complex", + "doublecomplex", + "logical1", + "shortlogical", + "logical", + "char" /* character */ + }; + +int type_pref[NTYPES] = { 0, 0, 3, 5, 7, +#ifdef TYQUAD + 10, +#endif + 8, 11, 9, 12, 1, 4, 6, 2 }; + +char *protorettypes[] = { + "?", "??", "integer1", "shortint", "integer", +#ifdef TYQUAD + "longint", +#endif + "real", "doublereal", + "C_f", "Z_f", "logical1", "shortlogical", "logical", "H_f", "int" + }; + +char *casttypes[TYSUBR+1] = { + "U_fp", "??bug??", "I1_fp", + "J_fp", "I_fp", +#ifdef TYQUAD + "Q_fp", +#endif + "R_fp", "D_fp", "C_fp", "Z_fp", + "L1_fp", "L2_fp", "L_fp", "H_fp", "S_fp" + }; +char *usedcasts[TYSUBR+1]; + +char *dfltarg[] = { + 0, 0, "(integer1 *)0", + "(shortint *)0", "(integer *)0", +#ifdef TYQUAD + "(longint *)0", +#endif + "(real *)0", + "(doublereal *)0", "(complex *)0", "(doublecomplex *)0", + "(logical1 *)0","(shortlogical *)0", "(logical *)0", "(char *)0" + }; + +static char *dflt0proc[] = { + 0, 0, "(integer1 (*)())0", + "(shortint (*)())0", "(integer (*)())0", +#ifdef TYQUAD + "(longint (*)())0", +#endif + "(real (*)())0", + "(doublereal (*)())0", "(complex (*)())0", "(doublecomplex (*)())0", + "(logical1 (*)())0", "(shortlogical (*)())0", + "(logical (*)())0", "(char (*)())0", "(int (*)())0" + }; + +char *dflt1proc[] = { "(U_fp)0", "( ??bug?? )0", "(I1_fp)0", + "(J_fp)0", "(I_fp)0", +#ifdef TYQUAD + "(Q_fp)0", +#endif + "(R_fp)0", "(D_fp)0", "(C_fp)0", "(Z_fp)0", + "(L1_fp)0","(L2_fp)0", + "(L_fp)0", "(H_fp)0", "(S_fp)0" + }; + +char **dfltproc = dflt0proc; + +static char Bug[] = "bug"; + +char *ftn_types[] = { "external", "??", "integer*1", + "integer*2", "integer", +#ifdef TYQUAD + "integer*8", +#endif + "real", + "double precision", "complex", "double complex", + "logical*1", "logical*2", + "logical", "character", "subroutine", + Bug,Bug,Bug,Bug,Bug,Bug,Bug,Bug,Bug, "ftnlen" + }; + +int init_ac[TYSUBR+1] = { 0,0,0,0,0,0,0, +#ifdef TYQUAD + 0, +#endif + 1, 1, 0, 0, 0, 2}; + +int proctype = TYUNKNOWN; +char *procname; +int rtvlabel[NTYPES0]; +Addrp retslot; /* Holds automatic variable which was + allocated the function return value + */ +Addrp xretslot[NTYPES0]; /* for multiple entry points */ +int cxslot = -1; +int chslot = -1; +int chlgslot = -1; +int procclass = CLUNKNOWN; +int nentry; +int nallargs; +int nallchargs; +flag multitype; +ftnint procleng; +long lastiolabno; +long lastlabno; +int lastvarno; +int lastargslot; +int autonum[TYVOID]; +char *av_pfix[TYVOID] = {"??TYUNKNOWN??", "a","i1","s","i", +#ifdef TYQUAD + "i8", +#endif + "r","d","q","z","L1","L2","L","ch", + "??TYSUBR??", "??TYERROR??","ci", "ici", + "o", "cl", "al", "ioin" }; + +extern int maxctl; +struct Ctlframe *ctls; +struct Ctlframe *ctlstack; +struct Ctlframe *lastctl; + +Namep regnamep[MAXREGVAR]; +int highregvar; +int nregvar; + +extern int maxext; +Extsym *extsymtab; +Extsym *nextext; +Extsym *lastext; + +extern int maxequiv; +struct Equivblock *eqvclass; + +extern int maxhash; +struct Hashentry *hashtab; +struct Hashentry *lasthash; + +extern int maxstno; /* Maximum number of statement labels */ +struct Labelblock *labeltab; +struct Labelblock *labtabend; +struct Labelblock *highlabtab; + +int maxdim = MAXDIM; +struct Rplblock *rpllist = NULL; +struct Chain *curdtp = NULL; +flag toomanyinit; +ftnint curdtelt; +chainp templist[TYVOID]; +chainp holdtemps; +int dorange = 0; +struct Entrypoint *entries = NULL; + +chainp chains = NULL; + +flag inioctl; +int iostmt; +int nioctl; +int nequiv = 0; +int eqvstart = 0; +int nintnames = 0; +extern int maxlablist; +struct Labelblock **labarray; + +struct Literal *litpool; +int nliterals; + +char dflttype[26]; +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<NTYPES0 ; ++i) + rtvlabel[i] = 0; + + if(undeftype) + setimpl(TYUNKNOWN, (ftnint) 0, 'a', 'z'); + else + { + setimpl(tyreal, (ftnint) 0, 'a', 'z'); + setimpl(tyint, (ftnint) 0, 'i', 'n'); + } + setimpl(-STGBSS, (ftnint) 0, 'a', 'z'); /* set class */ +} + + + + void +#ifdef KR_headers +setimpl(type, length, c1, c2) + int type; + ftnint length; + int c1; + int c2; +#else +setimpl(int type, ftnint length, int c1, int c2) +#endif +{ + int i; + char buff[100]; + + if(c1==0 || c2==0) + return; + + if(c1 > c2) { + sprintf(buff, "characters out of order in implicit:%c-%c", c1, c2); + err(buff); + } + else { + c1 = letter(c1); + c2 = letter(c2); + if(type < 0) + for(i = c1 ; i<=c2 ; ++i) + implstg[i] = - type; + else { + type = lengtype(type, length); + if(type == TYCHAR) { + if (length < 0) { + err("length (*) in implicit"); + length = 1; + } + } + else if (type != TYLONG) + length = 0; + for(i = c1 ; i<=c2 ; ++i) { + impltype[i] = type; + implleng[i] = length; + } + } + } + } diff --git a/unix/f2c/src/intr.c b/unix/f2c/src/intr.c new file mode 100644 index 00000000..dcae4db8 --- /dev/null +++ b/unix/f2c/src/intr.c @@ -0,0 +1,1087 @@ +/**************************************************************** +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 ; i<f2field ; ++i) + if(cstp->atype == mtype) + goto foundconst; + else + ++cstp; + goto badtype; + +foundconst: + switch(cstp->rtype) + { + case TYLONG: + return(mkintcon(intcon[cstp->constno])); + + case TYREAL: + case TYDREAL: + return(mkrealcon(cstp->rtype, + realcon[cstp->constno]) ); + + default: + Fatal("impossible intrinsic constant"); + } + } +#endif + + case INTRGEN: + sp = spectab + f3field; + if(no66flag) + if(sp->atype == mtype) + goto specfunct; + else err66("generic function"); + + for(i=0; i<f2field ; ++i) + if(sp->atype == mtype) + goto specfunct; + else + ++sp; + warn1 ("bad argument type to intrinsic %s", np->fvarname); + +/* Made this a warning rather than an error so things like "log (5) ==> + log (5.0)" can be accommodated. When none of these cases matches, the + argument is cast up to the first type in the spectab list; this first + type is assumed to be the "smallest" type, e.g. REAL before DREAL + before COMPLEX, before DCOMPLEX */ + + sp = spectab + f3field; + mtype = sp -> atype; + goto specfunct; + + case INTRSPEC: + sp = spectab + f3field; +specfunct: + if(tyint==TYLONG && ONEOF(sp->rtype,M(TYSHORT)|M(TYLOGICAL)) + && (sp+1)->atype==sp->atype) + ++sp; + + if(nargs != sp->nargs) + goto badnargs; + if(mtype != sp->atype) + goto badtype; + +/* NOTE!! I moved fixargs (YES) into the ELSE branch so that constants in + the inline expression wouldn't get put into the constant table */ + + fixargs (NO, argsp); + cast_args (mtype, argsp -> listp); + + if(q = Inline((int)(sp-spectab), mtype, argsp->listp)) + { + frchain( &(argsp->listp) ); + free( (charptr) argsp); + } else { + + if(sp->othername) { + /* C library routines that return double... */ + /* sp->rtype might be TYREAL */ + ap = builtin(sp->rtype, + callbyvalue[sp->othername], 1); + q = fixexpr((Exprp) + mkexpr(OPCCALL, (expptr)ap, (expptr)argsp) ); + } else { + fixargs(YES, argsp); + ap = builtin(sp->rtype, sp->spxname, 0); + q = fixexpr((Exprp) + mkexpr(OPCALL, (expptr)ap, (expptr)argsp) ); + } /* else */ + } /* else */ + return(q); + + case INTRMIN: + case INTRMAX: + if(nargs < 2) + goto badnargs; + if( ! ONEOF(mtype, MSKINT|MSKREAL) ) + goto badtype; + argsp->vtype = mtype; + 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); +} diff --git a/unix/f2c/src/io.c b/unix/f2c/src/io.c new file mode 100644 index 00000000..ed1ed160 --- /dev/null +++ b/unix/f2c/src/io.c @@ -0,0 +1,1509 @@ +/**************************************************************** +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); +} diff --git a/unix/f2c/src/iob.h b/unix/f2c/src/iob.h new file mode 100644 index 00000000..065d813a --- /dev/null +++ b/unix/f2c/src/iob.h @@ -0,0 +1,26 @@ +struct iob_data { + struct iob_data *next; + char *type; + char *name; + char *fields[1]; + }; +struct io_setup { + char **fields; + int nelt, type; + }; + +struct defines { + struct defines *next; + char defname[1]; + }; + +typedef struct iob_data iob_data; +typedef struct io_setup io_setup; +typedef struct defines defines; + +extern iob_data *iob_list; +extern struct Addrblock *io_structs[9]; +void def_start Argdcl((FILEP, char*, char*, char*)); +void new_iob_data Argdcl((io_setup*, char*)); +void other_undefs Argdcl((FILEP)); +char* tostring Argdcl((char*, int)); diff --git a/unix/f2c/src/lex.c b/unix/f2c/src/lex.c new file mode 100644 index 00000000..4b4bce4a --- /dev/null +++ b/unix/f2c/src/lex.c @@ -0,0 +1,1749 @@ +/**************************************************************** +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<lastch && + nextch[0]=='t' && nextch[1]=='o') + { + nextch+=2; + retval = STO; + break; + } + if (tokno == 2 && stkey == SDO) { + intonly = 1; + retval = gettok(); + intonly = 0; + } + else + retval = gettok(); + break; + +reteos: + case RETEOS: + lexstate = NEWSTMT; + retval = SEOS; + break; + default: + fatali("impossible lexstate %d", lexstate); + break; + } + + if (retval == SEOF) + flush_comments (); + + return retval; +} + + LOCAL void +contmax(Void) +{ + lineno = thislin; + many("continuation lines", 'C', maxcontin); + } + +/* Get Cards. + + Returns STEOF or STINITIAL, never STCONTINUE. Any continuation cards get +merged into one long card (hence the size of the buffer named sbuf) */ + + LOCAL int +getcds(Void) +{ + register char *p, *q; + + flush_comments (); +top: + if(nextcd == NULL) + { + code = getcd( nextcd = sbuf, 1 ); + stno = nxtstno; + prevlin = thislin; + } + if(code == STEOF) + if( popinclude() ) + goto top; + else + return(STEOF); + + if(code == STCONTINUE) + { + lineno = thislin; + nextcd = NULL; + goto top; + } + +/* Get rid of unused space at the head of the buffer */ + + if(nextcd > sbuf) + { + q = nextcd; + p = sbuf; + while(q < endcd) + *p++ = *q++; + endcd = p; + } + +/* Be aware that the input (i.e. the string at the address nextcd) is NOT + NULL-terminated */ + +/* This loop merges all continuations into one long statement, AND puts the next + card to be read at the end of the buffer (i.e. it stores the look-ahead card + when there's room) */ + + ncont = 0; + for(;;) { + nextcd = endcd; + if (ncont >= maxcont || nextcd+66 > send) + contmax(); + linestart[ncont++] = nextcd; + if ((code = getcd(nextcd,0)) != STCONTINUE) + break; + if (ncont == 20 && noextflag) { + lineno = thislin; + errext("more than 19 continuation lines"); + } + } + nextch = sbuf; + lastch = nextcd - 1; + + lineno = prevlin; + prevlin = thislin; + 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<aend && (c=getc(infile)) != '\n' && c!=EOF; ) + if(c == '\t') + +/* The tab character translates into blank characters in the statement label */ + + { + atend = p; + while(p < aend) + *p++ = BLANK; + speclin = YES; + bend = send; + } + else + *p++ = c; + } + +/* By now we've read either a continuation character or the statement label + field */ + + if(c == EOF) + return(STEOF); + +/* The next 'if' block handles lines that have fewer than 7 characters */ + + if(c == '\n') + { + while(p < aend) + *p++ = BLANK; + +/* Blank out the buffer on lines which are not longer than 66 characters */ + + endcd0 = endcd; + if( ! speclin ) + while(endcd < bend) + *endcd++ = BLANK; + } + else { /* read body of line */ + if (warn72 & 2) { + speclin = YES; + bend = send; + } + while( endcd<bend && (c=getc(infile)) != '\n' && c!=EOF ) + *endcd++ = c; + if(c == EOF) + return(STEOF); + +/* Drop any extra characters on the input card; this usually means those after + column 72 */ + + if(c != '\n') + { + i = 0; + while( (c=getc(infile)) != '\n' && c != EOF) + if (i < 23 && c != '\r') + buf72[i++] = c; + if (warn72 && i && !speclin) { + buf72[i] = 0; + if (i >= 23) + strcpy(buf72+20, "..."); + lineno = thislin + 1; + errstr("text after column 72: %s", buf72); + } + if(c == EOF) + return(STEOF); + } + + endcd0 = endcd; + if( ! speclin ) + while(endcd < bend) + *endcd++ = BLANK; + } + +/* The flow of control usually gets to this line (unless an earlier RETURN has + been taken) */ + + ++thislin; + + /* Fortran 77 specifies that a 0 in column 6 */ + /* does not signify continuation */ + + if( !isspace(a[5]) && a[5]!='0') { + if (!amp) + for(p = a; p < aend;) + if (*p++ == '!' && p != aend) + goto initcheck; + if (addftnsrc && stb) { + if (stbend > stb + 7) { /* otherwise forget col 1-6 */ + /* kludge around funny p1gets behavior */ + *stb++ = '$'; + if (amp) + *stb++ = '&'; + else + for(p = a; p < atend;) + *stb++ = *p++; + } + if (endcd0 - b > stbend - stb) { + if (stb > stbend) + stb = stbend; + endcd0 = b + (stbend - stb); + } + for(p = b; p < endcd0;) + *stb++ = *p++; + *stb++ = '\n'; + *stb = 0; + } + if (nocont) { + lineno = thislin; + errstr("illegal continuation card (starts \"%.6s\")",a); + } + else if (!amp && strncmp(a," ",5)) { + lineno = thislin; + errstr("labeled continuation line (starts \"%.6s\")",a); + } + return(STCONTINUE); + } +initcheck: + for(p=a; p<atend; ++p) + if( !isspace(*p) ) { + if (*p++ != '!') + goto initline; + bang(p, atend, aend, b, endcd); + goto top; + } + for(p = b ; p<endcd ; ++p) + if( !isspace(*p) ) { + if (*p++ != '!') + goto initline; + bang(a, a, a, p, endcd); + goto top; + } + +/* Skip over blank cards by reading the next one right away */ + + goto top; + +initline: + if (!lastline) + lastline = thislin; + if (addftnsrc) { + nst = (nst+1)%3; + if (!laststb && stb0) + laststb = stb0; + stb0 = stb = stbuf[nst]; + *stb++ = '$'; /* kludge around funny p1gets behavior */ + stbend = stb + sizeof(stbuf[0])-2; + for(p = a; p < atend;) + *stb++ = *p++; + if (atend < aend) + *stb++ = '\t'; + for(p = b; p < endcd0;) + *stb++ = *p++; + *stb++ = '\n'; + *stb = 0; + } + +/* Set nxtstno equal to the integer value of the statement label */ + + nxtstno = 0; + bend = a + 5; + for(p = a ; p < bend ; ++p) + if( !isspace(*p) ) + if(isdigit(*p)) + nxtstno = 10*nxtstno + (*p - '0'); + else if (*p == '!') { + if (!addftnsrc) + bang(p+1,atend,aend,b,endcd); + endcd = b; + break; + } + else { + lineno = thislin; + errstr( + "nondigit in statement label field \"%.5s\"", a); + nxtstno = 0; + break; + } + firstline = thislin; + return(STINITIAL); +} + + LOCAL void +#ifdef KR_headers +adjtoklen(newlen) + int newlen; +#else +adjtoklen(int newlen) +#endif +{ + while(maxtoklen < newlen) + maxtoklen = 2*maxtoklen + 2; + if (token = (char *)realloc(token, maxtoklen)) + return; + fprintf(stderr, "adjtoklen: realloc(%d) failure!\n", maxtoklen); + exit(2); + } + +/* crunch -- deletes all space characters, folds the backslash chars and + Hollerith strings, quotes the Fortran strings */ + + LOCAL void +crunch(Void) +{ + register char *i, *j, *j0, *j1, *prvstr; + int k, ten, nh, nh0, quote; + + /* i is the next input character to be looked at + j is the next output character */ + + new_dcl = needwkey = parlev = parseen = 0; + expcom = 0; /* exposed ','s */ + expeql = 0; /* exposed equal signs */ + j = sbuf; + prvstr = sbuf; + k = 0; + for(i=sbuf ; i<=lastch ; ++i) + { + if(isspace(*i) ) + continue; + if (*i == '!') { + while(i >= linestart[k]) + if (++k >= maxcont) + contmax(); + j0 = linestart[k]; + if (!addftnsrc) + bang(sbuf,sbuf,sbuf,i+1,j0); + i = j0-1; + continue; + } + +/* Keep everything in a quoted string */ + + if(*i=='\'' || *i=='"') + { + int len = 0; + + quote = *i; + *j = MYQUOTE; /* special marker */ + for(;;) + { + if(++i > lastch) + { + err("unbalanced quotes; closing quote supplied"); + if (j >= lastch) + j = lastch - 1; + break; + } + if(*i == quote) + if(i<lastch && i[1]==quote) ++i; + else break; + else if(*i=='\\' && i<lastch && use_bs) { + ++i; + *i = escapes[*(unsigned char *)i]; + } + *++j = *i; + len++; + } /* for (;;) */ + + if ((len = j - sbuf) > maxtoklen) + adjtoklen(len); + j[1] = MYQUOTE; + j += 2; + prvstr = j; + } + else if( (*i=='h' || *i=='H') && j>prvstr) /* test for Hollerith strings */ + { + j0 = j - 1; + if( ! isdigit(*j0)) goto copychar; + nh = *j0 - '0'; + ten = 10; + j1 = prvstr; + if (j1 > sbuf && j1[-1] == MYQUOTE) + --j1; + if (j1+4 < j) + j1 = j-4; + for(;;) { + if (j0-- <= j1) + goto copychar; + if( ! isdigit(*j0 ) ) break; + nh += ten * (*j0-'0'); + ten*=10; + } +/* A Hollerith string must be preceded by a punctuation mark. + '*' is possible only as repetition factor in a data statement + not, in particular, in character*2h . + To avoid some confusion with missing commas in FORMAT statements, + treat a preceding string as a punctuation mark. + */ + + if( !(*j0=='*'&&sbuf[0]=='d') && *j0!='/' + && *j0!='(' && *j0!=',' && *j0!='=' && *j0!='.' + && *j0 != MYQUOTE) + goto copychar; + nh0 = nh; + if(i+nh > lastch) + { + erri("%dH too big", nh); + nh = lastch - i; + nh0 = -1; + } + if (nh > maxtoklen) + adjtoklen(nh); + j0[1] = MYQUOTE; /* special marker */ + j = j0 + 1; + while(nh-- > 0) + { + if (++i > lastch) { + hol_overflow: + if (nh0 >= 0) + erri("escapes make %dH too big", + nh0); + break; + } + if(*i == '\\' && use_bs) { + if (++i > lastch) + goto hol_overflow; + *i = escapes[*(unsigned char *)i]; + } + *++j = *i; + } + j[1] = MYQUOTE; + j+=2; + prvstr = j; + } + else { + if(*i == '(') parseen = ++parlev; + else if(*i == ')') --parlev; + else if(parlev == 0) + if(*i == '=') expeql = 1; + else if(*i == ',') expcom = 1; +copychar: /*not a string or space -- copy, shifting case if necessary */ + if(shiftcase && isupper(*i)) + *j++ = tolower(*i); + else *j++ = *i; + } + } + lastch = j - 1; + nextch = sbuf; +} + + LOCAL void +analyz(Void) +{ + register char *i; + + if(parlev != 0) + { + err("unbalanced parentheses, statement skipped"); + stkey = SUNKNOWN; + lastch = sbuf - 1; /* prevent double error msg */ + return; + } + if(nextch+2<=lastch && nextch[0]=='i' && nextch[1]=='f' && nextch[2]=='(') + { + /* assignment or if statement -- look at character after balancing paren */ + parlev = 1; + for(i=nextch+3 ; i<=lastch; ++i) + if(*i == (MYQUOTE)) + { + while(*++i != MYQUOTE) + ; + } + else if(*i == '(') + ++parlev; + else if(*i == ')') + { + if(--parlev == 0) + break; + } + if(i >= lastch) + stkey = SLOGIF; + else if(i[1] == '=') + stkey = SLET; + else if( isdigit(i[1]) ) + stkey = SARITHIF; + else stkey = SLOGIF; + if(stkey != SLET) + nextch += 2; + } + else if(expeql) /* may be an assignment */ + { + if(expcom && nextch<lastch && + nextch[0]=='d' && nextch[1]=='o') + { + stkey = SDO; + nextch += 2; + } + else stkey = SLET; + } + else if (parseen && nextch + 7 < lastch + && nextch[2] != 'u' /* screen out "double..." early */ + && nextch[0] == 'd' && nextch[1] == 'o' + && ((nextch[2] >= '0' && nextch[2] <= '9') + || nextch[2] == ',' + || nextch[2] == 'w')) + { + stkey = SDO; + nextch += 2; + needwkey = 1; + } + /* otherwise search for keyword */ + else { + stkey = getkwd(); + if(stkey==SGOTO && lastch>=nextch) + if(nextch[0]=='(') + stkey = SCOMPGOTO; + else if(isalpha_(* USC nextch)) + stkey = SASGOTO; + } + parlev = 0; +} + + + + LOCAL int +getkwd(Void) +{ + register char *i, *j; + register struct Keylist *pk, *pend; + int k; + + if(! isalpha_(* USC nextch) ) + return(SUNKNOWN); + k = letter(nextch[0]); + if(pk = keystart[k]) + for(pend = keyend[k] ; pk<=pend ; ++pk ) + { + i = pk->keyname; + j = nextch; + while(*++i==*++j && *i!='\0') + ; + if(*i=='\0' && j<=lastch+1) + { + nextch = j; + if(no66flag && pk->notinf66) + errstr("Not a Fortran 66 keyword: %s", + pk->keyname); + return(pk->keyval); + } + } + return(SUNKNOWN); +} + + void +initkey(Void) +{ + register struct Keylist *p; + register int i,j; + register char *s; + + for(i = 0 ; i<26 ; ++i) + keystart[i] = NULL; + + for(p = keys ; p->keyname ; ++p) { + j = letter(p->keyname[0]); + if(keystart[j] == NULL) + keystart[j] = p; + keyend[j] = p; + } + i = (maxcontin + 2) * 66; + sbuf = (char *)ckalloc(i + 70 + 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<lastch && nextch[0]=='(' && + (nextch[1]==')' || isalpha_(* USC (nextch+1))) ) + { + nextch -= (toklen - 8); + return(SFUNCTION); + } + + if(toklen > 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<lastch) + if(nextch[1]=='+' || nextch[1]=='-') + ++nextch; + if( ! isdigit(*++nextch) ) { + nextch = p; + havdbl = havexp = NO; + break; + } + for(++nextch ; + nextch<=lastch && isdigit(* USC nextch); + ++nextch); + } + break; + } + } + p = token; + i = n1; + while(i < nextch) + *p++ = *i++; + toklen = p - token; + *p = 0; + if(havdbl) return(SDCON); + if(havdot || havexp) return(SRCON); + return(SICON); +badchar: + sbuf[0] = *nextch++; + return(SUNKNOWN); +} + +/* Comment buffering code */ + + static void +#ifdef KR_headers +store_comment(str) + char *str; +#else +store_comment(char *str) +#endif +{ + int len; + comment_buf *ncb; + + if (nextcd == sbuf) { + flush_comments(); + p1_comment(str); + return; + } + len = strlen(str) + 1; + if (cbnext + len > cblast) { + ncb = 0; + if (cbcur) { + cbcur->last = cbnext; + ncb = cbcur->next; + } + if (!ncb) { + ncb = (comment_buf *) Alloc(sizeof(comment_buf)); + if (cbcur) + cbcur->next = ncb; + else { + cbfirst = ncb; + cbinit = ncb->buf; + } + ncb->next = 0; + } + cbcur = ncb; + cbnext = ncb->buf; + cblast = cbnext + COMMENT_BUF_STORE; + } + strcpy(cbnext, str); + cbnext += len; + } + + static void +flush_comments(Void) +{ + register char *s, *s1; + register comment_buf *cb; + if (cbnext == cbinit) + return; + cbcur->last = cbnext; + for(cb = cbfirst;; cb = cb->next) { + for(s = cb->buf; s < cb->last; s = s1) { + /* compute s1 = new s value first, since */ + /* p1_comment may insert nulls into s */ + s1 = s + strlen(s) + 1; + p1_comment(s); + } + if (cb == cbcur) + break; + } + cbcur = cbfirst; + cbnext = cbinit; + cblast = cbnext + COMMENT_BUF_STORE; + } + + void +unclassifiable(Void) +{ + register char *s, *se; + + s = sbuf; + se = lastch; + if (se < sbuf) + return; + lastch = s - 1; + if (++se - s > 10) + se = s + 10; + for(; s < se; s++) + if (*s == MYQUOTE) { + se = s; + break; + } + *se = 0; + errstr("unclassifiable statement (starts \"%s\")", sbuf); + } + + void +endcheck(Void) +{ + if (nextch <= lastch) + warn("ignoring text after \"end\"."); + lexstate = RETEOS; + } diff --git a/unix/f2c/src/machdefs.h b/unix/f2c/src/machdefs.h new file mode 100644 index 00000000..3ab8961f --- /dev/null +++ b/unix/f2c/src/machdefs.h @@ -0,0 +1,31 @@ +#define TYLENG TYLONG /* char string length field */ + +#define TYINT TYLONG +#define SZADDR 4 +#define SZSHORT 2 +#define SZINT 4 + +#define SZLONG 4 +#define SZLENG SZLONG + +#define SZDREAL 8 + +/* Alignment restrictions */ + +#define ALIADDR SZADDR +#define ALISHORT SZSHORT +#define ALILONG 4 +#define ALIDOUBLE 8 +#define ALIINT ALILONG +#define ALILENG ALILONG + +#define BLANKCOMMON "_BLNK__" /* Name for the unnamed + common block; this is unique + because of underscores */ + +#define LABELFMT "%s:\n" + +#define MAXREGVAR 4 +#define TYIREG TYLONG +#define MSKIREG (M(TYSHORT)|M(TYLONG)) /* allowed types of DO indicies + which can be put in registers */ diff --git a/unix/f2c/src/main.c b/unix/f2c/src/main.c new file mode 100644 index 00000000..14276f6d --- /dev/null +++ b/unix/f2c/src/main.c @@ -0,0 +1,792 @@ +/**************************************************************** +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\ +/*<<</dev/null>>>*/\n\ +/*>>>'%s'<<<*/\n", cdfilename); + if (gflag) + nice_printf (c_output, "#line 1 \"%s\"\n", file_name); + if (!skipversion) { + nice_printf (c_output, "/* %s -- translated by f2c ", file_name); + nice_printf (c_output, "(version %s).\n", F2C_version); + nice_printf (c_output, + " You must link the resulting object file with 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); +} diff --git a/unix/f2c/src/makefile.u b/unix/f2c/src/makefile.u new file mode 100644 index 00000000..0e2c7351 --- /dev/null +++ b/unix/f2c/src/makefile.u @@ -0,0 +1,117 @@ +# Makefile for f2c, a Fortran 77 to C converter + +.SUFFIXES: .c .o +CC = cc +CFLAGS = -O -w $(HSI_CF) +LDFLAGS = $(HSI_LF) +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: 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 <tokdefs.h "s/#define/%token/" ;\ + cat gram.head gram.dcl gram.expr gram.exec gram.io ) >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 . <tokens | sed "s/\([^:]*\):\(.*\)/#define \2 \1/" >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 diff --git a/unix/f2c/src/makefile.vc b/unix/f2c/src/makefile.vc new file mode 100644 index 00000000..e79a6ca8 --- /dev/null +++ b/unix/f2c/src/makefile.vc @@ -0,0 +1,76 @@ +# 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".
diff --git a/unix/f2c/src/malloc.c b/unix/f2c/src/malloc.c new file mode 100644 index 00000000..dc32add3 --- /dev/null +++ b/unix/f2c/src/malloc.c @@ -0,0 +1,183 @@ +/**************************************************************** +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 diff --git a/unix/f2c/src/mem.c b/unix/f2c/src/mem.c new file mode 100644 index 00000000..2f0aed32 --- /dev/null +++ b/unix/f2c/src/mem.c @@ -0,0 +1,272 @@ +/**************************************************************** +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"); + } + } diff --git a/unix/f2c/src/memset.c b/unix/f2c/src/memset.c new file mode 100644 index 00000000..496b6164 --- /dev/null +++ b/unix/f2c/src/memset.c @@ -0,0 +1,72 @@ +/**************************************************************** +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; + } diff --git a/unix/f2c/src/misc.c b/unix/f2c/src/misc.c new file mode 100644 index 00000000..bdb9bcb3 --- /dev/null +++ b/unix/f2c/src/misc.c @@ -0,0 +1,1398 @@ +/**************************************************************** +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 ; p<nextext ; ++p) + if(!strcmp(s,p->cextname)) + return( p ); + + if(nextext >= lastext) + many("external symbols", 'x', maxext); + + nextext->fextname = strcpy(gmem(strlen(f)+1,0), f); + nextext->cextname = f == s + ? nextext->fextname + : strcpy(gmem(strlen(s)+1,0), s); + nextext->extstg = STGUNKNOWN; + nextext->extp = 0; + nextext->allextp = 0; + nextext->extleng = 0; + nextext->maxleng = 0; + nextext->extinit = 0; + nextext->curno = nextext->maxno = 0; + return( nextext++ ); +} + + + Extsym * +#ifdef KR_headers +mkext(f, s) + char *f; + char *s; +#else +mkext(char *f, char *s) +#endif +{ + Extsym *e = mkext1(f, s); + if (e->extstg == STGCOMMON) + errstr("%.52s cannot be a subprogram: it is a common block.",f); + return e; + } + + Addrp +#ifdef KR_headers +builtin(t, s, dbi) + int t; + char *s; + int dbi; +#else +builtin(int t, char *s, int dbi) +#endif +{ + register Extsym *p; + register Addrp q; + extern chainp used_builtins; + + p = mkext(s,s); + if(p->extstg == STGUNKNOWN) + p->extstg = STGEXT; + else if(p->extstg != STGEXT) + { + errstr("improper use of builtin %s", s); + return(0); + } + + q = ALLOC(Addrblock); + q->tag = TADDR; + q->vtype = t; + q->vclass = CLPROC; + q->vstg = STGEXT; + q->memno = p - extsymtab; + q->dbl_builtin = dbi; + +/* A NULL pointer here tells you to use memno to check the external + symbol table */ + + q -> uname_tag = UNAM_EXTERN; + +/* Add to the list of used builtins */ + + if (dbi >= 0) + add_extern_to_list (q, &used_builtins); + return(q); +} + + + void +#ifdef KR_headers +add_extern_to_list(addr, list_store) + Addrp addr; + chainp *list_store; +#else +add_extern_to_list(Addrp addr, chainp *list_store) +#endif +{ + chainp last = CHNULL; + chainp list; + int memno; + + if (list_store == (chainp *) NULL || addr == (Addrp) NULL) + return; + + list = *list_store; + memno = addr -> memno; + + for (;list; last = list, list = list -> nextp) { + Addrp This = (Addrp) (list -> datap); + + if (This -> tag == TADDR && This -> uname_tag == UNAM_EXTERN && + This -> memno == memno) + return; + } /* for */ + + if (*list_store == CHNULL) + *list_store = mkchain((char *)cpexpr((expptr)addr), CHNULL); + else + last->nextp = mkchain((char *)cpexpr((expptr)addr), CHNULL); + +} /* add_extern_to_list */ + + + void +#ifdef KR_headers +frchain(p) + register chainp *p; +#else +frchain(register chainp *p) +#endif +{ + register chainp q; + + if(p==0 || *p==0) + return; + + for(q = *p; q->nextp ; q = q->nextp) + ; + q->nextp = chains; + chains = *p; + *p = 0; +} + + void +#ifdef KR_headers +frexchain(p) + register chainp *p; +#else +frexchain(register chainp *p) +#endif +{ + register chainp q, r; + + if (q = *p) { + for(;;q = r) { + frexpr((expptr)q->datap); + if (!(r = q->nextp)) + break; + } + q->nextp = chains; + chains = *p; + *p = 0; + } + } + + + tagptr +#ifdef KR_headers +cpblock(n, p) + register int n; + register char *p; +#else +cpblock(register int n, register char *p) +#endif +{ + register ptr q; + + memcpy((char *)(q = ckalloc(n)), (char *)p, n); + return( (tagptr) q); +} + + + + ftnint +#ifdef KR_headers +lmax(a, b) + ftnint a; + ftnint b; +#else +lmax(ftnint a, ftnint b) +#endif +{ + return( a>b ? a : b); +} + + ftnint +#ifdef KR_headers +lmin(a, b) + ftnint a; + ftnint b; +#else +lmin(ftnint a, ftnint b) +#endif +{ + return(a < b ? a : b); +} + + + + 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 + } diff --git a/unix/f2c/src/mkfile.plan9 b/unix/f2c/src/mkfile.plan9 new file mode 100644 index 00000000..73466121 --- /dev/null +++ b/unix/f2c/src/mkfile.plan9 @@ -0,0 +1,107 @@ +# Plan 9 mkfile for f2c, a Fortran 77 to C converter + +</$objtype/mkfile +NPROC = 1 +CC = pcc +CFLAGS = -DANSI_Libraries -DNO_LONG_LONG + +%.$O: %.c + $CC -c $CFLAGS $stem.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 = malloc.$O +# 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:N: 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 function 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 <tokdefs.h "s/#define/%token/" ;\ + cat gram.head gram.dcl gram.expr gram.exec gram.io ) >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 . <tokens | sed 's/([^:]*):(.*)/#define \2 \1/' >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 diff --git a/unix/f2c/src/mkpkg.sh b/unix/f2c/src/mkpkg.sh new file mode 100644 index 00000000..4092705d --- /dev/null +++ b/unix/f2c/src/mkpkg.sh @@ -0,0 +1,5 @@ +# Bootstrap the F2C compiler and libraries. + +make -f makefile.u +mv f2c ../../bin/f2c.e +rm *.o diff --git a/unix/f2c/src/names.c b/unix/f2c/src/names.c new file mode 100644 index 00000000..373f656c --- /dev/null +++ b/unix/f2c/src/names.c @@ -0,0 +1,835 @@ +/**************************************************************** +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<memno> (big constant number) + 1.2 -> c_1_2 (constant 1.2) + 1.234345 -> c_b<memno> (big constant number) + -1 -> c_n1 (constant -1) + -1.0 -> c_n1_0 (constant -1.0) + .true. -> c_true (constant true) + .false. -> c_false (constant false) + default -> c_b<memno> (default label) +*/ + + char * +#ifdef KR_headers +lit_name(litp) + struct Literal *litp; +#else +lit_name(struct Literal *litp) +#endif +{ + static char buf[CONST_IDENT_MAX]; + ftnint val; + char *fmt; + + if (litp == (struct Literal *) NULL) + return NULL; + + switch (litp -> littype) { + case TYINT1: + val = litp -> litval.litival; + if (val >= 256 || val < -255) + sprintf (buf, "ci1_b%ld", litp -> litnum); + else if (val < 0) + sprintf (buf, "ci1_n%ld", -val); + else + sprintf(buf, "ci1__%ld", val); + break; + case TYSHORT: + val = litp -> litval.litival; + if (val >= 32768 || val <= -32769) + sprintf (buf, "cs_b%ld", litp -> litnum); + else if (val < 0) + sprintf (buf, "cs_n%ld", -val); + else + sprintf (buf, "cs__%ld", val); + break; + case TYLONG: +#ifdef TYQUAD + case TYQUAD: +#endif + val = litp -> litval.litival; + if (val >= 100000 || val <= -10000) + sprintf (buf, "c_b%ld", litp -> litnum); + else if (val < 0) + sprintf (buf, "c_n%ld", -val); + else + sprintf (buf, "c__%ld", val); + break; + case TYLOGICAL1: + fmt = "cl1_%s"; + goto spr_logical; + case TYLOGICAL2: + fmt = "cl2_%s"; + goto spr_logical; + case TYLOGICAL: + fmt = "c_%s"; + spr_logical: + sprintf (buf, fmt, (litp -> litval.litival + ? "true" : "false")); + break; + case TYREAL: + case TYDREAL: + /* Given a limit of 6 or 8 character on external names, */ + /* few f.p. values can be meaningfully encoded in the */ + /* constant name. Just going with the default cb_# */ + /* seems to be the best course for floating-point */ + /* constants. */ + case TYCHAR: + /* Shouldn't be any of these */ + case TYADDR: + case TYCOMPLEX: + case TYDCOMPLEX: + case TYSUBR: + default: + sprintf (buf, "c_b%ld", litp -> litnum); + } /* switch */ + return buf; +} /* lit_name */ + + + + char * +#ifdef KR_headers +comm_union_name(count) + int count; +#else +comm_union_name(int count) +#endif +{ + static char buf[12]; + + sprintf(buf, "%d", count); + return buf; + } + + + + +/* wr_globals -- after every function has been translated, we need to + output the global declarations, such as the static table of constant + values */ + + void +#ifdef KR_headers +wr_globals(outfile) + FILE *outfile; +#else +wr_globals(FILE *outfile) +#endif +{ + struct Literal *litp, *lastlit; + extern int hsize; + char *litname; + int did_one, t; + struct Constblock cb; + ftnint x, y; + + if (nliterals == 0) + return; + + lastlit = litpool + nliterals; + did_one = 0; + for (litp = litpool; litp < lastlit; litp++) { + if (!litp->lituse) + continue; + litname = lit_name(litp); + if (!did_one) { + margin_printf(outfile, "/* Table of constant values */\n\n"); + did_one = 1; + } + cb.vtype = litp->littype; + if (litp->littype == TYCHAR) { + x = litp->litval.litival2[0] + litp->litval.litival2[1]; + if (y = x % hsize) + x += y = hsize - y; + nice_printf(outfile, + "static struct { %s fill; char val[%ld+1];", halign, x); + nice_printf(outfile, " char fill2[%ld];", hsize - 1); + nice_printf(outfile, " } %s_st = { 0,", litname); + cb.vleng = ICON(litp->litval.litival2[0]); + cb.Const.ccp = litp->cds[0]; + cb.Const.ccp1.blanks = litp->litval.litival2[1] + y; + cb.vtype = TYCHAR; + out_const(outfile, &cb); + frexpr(cb.vleng); + nice_printf(outfile, " };\n"); + nice_printf(outfile, "#define %s %s_st.val\n", litname, litname); + continue; + } + nice_printf(outfile, "static %s %s = ", + c_type_decl(litp->littype,0), litname); + + t = litp->littype; + if (ONEOF(t, MSKREAL|MSKCOMPLEX)) { + cb.vstg = 1; + cb.Const.cds[0] = litp->cds[0]; + cb.Const.cds[1] = litp->cds[1]; + } + else { + memcpy((char *)&cb.Const, (char *)&litp->litval, + sizeof(cb.Const)); + cb.vstg = 0; + } + out_const(outfile, &cb); + + nice_printf (outfile, ";\n"); + } /* for */ + if (did_one) + nice_printf (outfile, "\n"); +} /* wr_globals */ + + ftnint +#ifdef KR_headers +commlen(vl) + register chainp vl; +#else +commlen(register chainp vl) +#endif +{ + ftnint size; + int type; + struct Dimblock *t; + Namep v; + + while(vl->nextp) + vl = vl->nextp; + v = (Namep)vl->datap; + type = v->vtype; + if (type == TYCHAR) + size = v->vleng->constblock.Const.ci; + else + size = typesize[type]; + if ((t = v->vdim) && ISCONST(t->nelt)) + size *= t->nelt->constblock.Const.ci; + return size + v->voffset; + } + + static void /* Pad common block if an EQUIVALENCE extended it. */ +#ifdef KR_headers +pad_common(c) + Extsym *c; +#else +pad_common(Extsym *c) +#endif +{ + register chainp cvl; + register Namep v; + long L = c->maxleng; + int type; + struct Dimblock *t; + int szshort = typesize[TYSHORT]; + + for(cvl = c->allextp; cvl; cvl = cvl->nextp) + if (commlen((chainp)cvl->datap) >= L) + return; + v = ALLOC(Nameblock); + v->vtype = type = L % szshort ? TYCHAR + : type_choice[L/szshort % 4]; + v->vstg = STGCOMMON; + v->vclass = CLVAR; + v->tag = TNAME; + v->vdim = t = ALLOC(Dimblock); + t->ndim = 1; + t->dims[0].dimsize = ICON(L / typesize[type]); + v->fvarname = v->cvarname = "eqv_pad"; + if (type == TYCHAR) + v->vleng = ICON(1); + c->allextp = mkchain((char *)mkchain((char *)v, CHNULL), c->allextp); + } + + +/* wr_common_decls -- outputs the common declarations in one of three + formats. If all references to a common block look the same (field + names and types agree), only one actual declaration will appear. + Otherwise, the same block will require many structs. If there is no + block data, these structs will be union'ed together (so the linker + knows the size of the largest one). If there IS a block data, only + that version will be associated with the variable, others will only be + defined as types, so the pointer can be cast to it. e.g. + + FORTRAN C +---------------------------------------------------------------------- + common /com1/ a, b, c struct { real a, b, c; } com1_; + + common /com1/ a, b, c union { + common /com1/ i, j, k struct { real a, b, c; } _1; + struct { integer i, j, k; } _2; + } com1_; + + common /com1/ a, b, c struct com1_1_ { real a, b, c; }; + block data struct { integer i, j, k; } com1_ = + common /com1/ i, j, k { 1, 2, 3 }; + data i/1/, j/2/, k/3/ + + + All of these versions will be followed by #defines, since the code in + the function bodies can't know ahead of time which of these options + will be taken */ + +/* Macros for deciding the output type */ + +#define ONE_STRUCT 1 +#define UNION_STRUCT 2 +#define INIT_STRUCT 3 + + void +#ifdef KR_headers +wr_common_decls(outfile) + FILE *outfile; +#else +wr_common_decls(FILE *outfile) +#endif +{ + Extsym *ext; + extern int extcomm; + static char *Extern[4] = {"", "Extern ", "extern "}; + char *E, *E0 = Extern[extcomm]; + int did_one = 0; + + for (ext = extsymtab; ext < nextext; ext++) { + if (ext -> extstg == STGCOMMON && ext->allextp) { + chainp comm; + int count = 1; + int which; /* which display to use; + ONE_STRUCT, UNION or INIT */ + + if (!did_one) + nice_printf (outfile, "/* Common Block Declarations */\n\n"); + + pad_common(ext); + +/* Construct the proper, condensed list of structs; eliminate duplicates + from the initial list ext -> allextp */ + + comm = ext->allextp = revchain(ext->allextp); + + if (ext -> extinit) + which = INIT_STRUCT; + else if (comm->nextp) { + which = UNION_STRUCT; + nice_printf (outfile, "%sunion {\n", E0); + next_tab (outfile); + E = ""; + } + else { + which = ONE_STRUCT; + E = E0; + } + + for (; comm; comm = comm -> nextp, count++) { + + if (which == INIT_STRUCT) + nice_printf (outfile, "struct %s%d_ {\n", + ext->cextname, count); + else + nice_printf (outfile, "%sstruct {\n", E); + + next_tab (c_file); + + wr_struct (outfile, (chainp) comm -> datap); + + prev_tab (c_file); + if (which == UNION_STRUCT) + nice_printf (outfile, "} _%d;\n", count); + else if (which == ONE_STRUCT) + nice_printf (outfile, "} %s;\n", ext->cextname); + else + nice_printf (outfile, "};\n"); + } /* for */ + + if (which == UNION_STRUCT) { + prev_tab (c_file); + nice_printf (outfile, "} %s;\n", ext->cextname); + } /* if */ + did_one = 1; + nice_printf (outfile, "\n"); + + for (count = 1, comm = ext -> allextp; comm; + comm = comm -> nextp, count++) { + def_start(outfile, ext->cextname, + comm_union_name(count), ""); + switch (which) { + case ONE_STRUCT: + extern_out (outfile, ext); + break; + case UNION_STRUCT: + nice_printf (outfile, "("); + extern_out (outfile, ext); + nice_printf(outfile, "._%d)", count); + break; + case INIT_STRUCT: + nice_printf (outfile, "(*(struct "); + extern_out (outfile, ext); + nice_printf (outfile, "%d_ *) &", count); + extern_out (outfile, ext); + nice_printf (outfile, ")"); + break; + } /* switch */ + nice_printf (outfile, "\n"); + } /* for count = 1, comm = ext -> allextp */ + nice_printf (outfile, "\n"); + } /* if ext -> extstg == STGCOMMON */ + } /* for ext = extsymtab */ +} /* wr_common_decls */ + + void +#ifdef KR_headers +wr_struct(outfile, var_list) + FILE *outfile; + chainp var_list; +#else +wr_struct(FILE *outfile, chainp var_list) +#endif +{ + int last_type = -1; + int did_one = 0; + chainp this_var; + + for (this_var = var_list; this_var; this_var = this_var -> nextp) { + Namep var = (Namep) this_var -> datap; + int type; + char *comment = NULL; + + if (var == (Namep) NULL) + err ("wr_struct: null variable"); + else if (var -> tag != TNAME) + erri ("wr_struct: bad tag on variable '%d'", + var -> tag); + + type = var -> vtype; + + if (last_type == type && did_one) + nice_printf (outfile, ", "); + else { + if (did_one) + nice_printf (outfile, ";\n"); + nice_printf (outfile, "%s ", + c_type_decl (type, var -> vclass == CLPROC)); + } /* else */ + +/* Character type is really a string type. Put out a '*' for parameters + with unknown length and functions returning character */ + + if (var -> vtype == TYCHAR && (!ISICON ((var -> vleng)) + || var -> vclass == CLPROC)) + nice_printf (outfile, "*"); + + var -> vstg = STGAUTO; + out_name (outfile, var); + if (var -> vclass == CLPROC) + nice_printf (outfile, "()"); + else if (var -> vdim) + comment = wr_ardecls(outfile, var->vdim, + var->vtype == TYCHAR && ISICON(var->vleng) + ? var->vleng->constblock.Const.ci : 1L); + else if (var -> vtype == TYCHAR && var -> vclass != CLPROC && + ISICON ((var -> vleng))) + nice_printf (outfile, "[%ld]", + var -> vleng -> constblock.Const.ci); + + if (comment) + nice_printf (outfile, "%s", comment); + did_one = 1; + last_type = type; + } /* for this_var */ + + if (did_one) + nice_printf (outfile, ";\n"); +} /* wr_struct */ + + + char * +#ifdef KR_headers +user_label(stateno) + ftnint stateno; +#else +user_label(ftnint stateno) +#endif +{ + static char buf[USER_LABEL_MAX + 1]; + static char *Lfmt[2] = { "L_%ld", "L%ld" }; + + if (stateno >= 0) + sprintf(buf, Lfmt[shiftcase], stateno); + else + sprintf(buf, "L_%s", extsymtab[-1-stateno].fextname); + return buf; +} /* user_label */ + + + char * +#ifdef KR_headers +temp_name(starter, num, storage) + char *starter; + int num; + char *storage; +#else +temp_name(char *starter, int num, char *storage) +#endif +{ + static char buf[IDENT_LEN]; + char *pointer = buf; + char *prefix = "t"; + + if (storage) + pointer = storage; + + if (starter && *starter) + prefix = starter; + + sprintf (pointer, "%s__%d", prefix, num); + return pointer; +} /* temp_name */ + + + char * +#ifdef KR_headers +equiv_name(memno, store) + int memno; + char *store; +#else +equiv_name(int memno, char *store) +#endif +{ + static char buf[IDENT_LEN]; + char *pointer = buf; + + if (store) + pointer = store; + + sprintf (pointer, "%s_%d", EQUIV_INIT_NAME, memno); + return pointer; +} /* equiv_name */ + + void +#ifdef KR_headers +def_commons(of) + FILE *of; +#else +def_commons(FILE *of) +#endif +{ + Extsym *ext; + int c, onefile, Union; + chainp comm; + extern int ext1comm; + FILE *c_filesave = c_file; + + if (ext1comm == 1) { + onefile = 1; + c_file = of; + fprintf(of, "/*>>>'/dev/null'<<<*/\n\ +#ifdef Define_COMMONs\n\ +/*<<</dev/null>>>*/\n"); + } + else + onefile = 0; + for(ext = extsymtab; ext < nextext; ext++) + if (ext->extstg == STGCOMMON + && !ext->extinit && (comm = ext->allextp)) { + sprintf(outbtail, "%scom.c", ext->cextname); + if (onefile) + fprintf(of, "/*>>>'%s'<<<*/\n", + outbtail); + else { + c_file = of = fopen(outbuf,textwrite); + if (!of) + fatalstr("can't open %s", outbuf); + } + fprintf(of, "#include \"f2c.h\"\n"); + if (Ansi == 2) + fprintf(of, + "\n#ifdef __cplusplus\nextern \"C\" {\n#endif\n\n"); + if (comm->nextp) { + Union = 1; + nice_printf(of, "union {\n"); + next_tab(of); + } + else + Union = 0; + for(c = 1; comm; comm = comm->nextp) { + nice_printf(of, "struct {\n"); + next_tab(of); + wr_struct(of, (chainp)comm->datap); + prev_tab(of); + if (Union) + nice_printf(of, "} _%d;\n", c++); + } + if (Union) + prev_tab(of); + nice_printf(of, "} %s;\n", ext->cextname); + if (Ansi == 2) + fprintf(of, + "\n#ifdef __cplusplus\n}\n#endif\n"); + if (onefile) + fprintf(of, "/*<<<%s>>>*/\n", outbtail); + else + fclose(of); + } + if (onefile) + fprintf(of, "/*>>>'/dev/null'<<<*/\n#endif\n\ +/*<<</dev/null>>>*/\n"); + c_file = c_filesave; + } + +/* C Language keywords. Needed to filter unwanted fortran identifiers like + * "int", etc. Source: Kernighan & Ritchie, eds. 1 and 2; Stroustrup. + * Also includes C++ keywords and types used for I/O in f2c.h . + * These keywords must be in alphabetical order (as defined by strcmp()). + */ + +char *c_keywords[] = { + "Long", "Multitype", "Namelist", "Vardesc", "abs", "acos", + "addr", "address", "aerr", "alist", "asin", "asm", "atan", + "atan2", "aunit", "auto", "break", "c", "case", "catch", "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 *); diff --git a/unix/f2c/src/names.h b/unix/f2c/src/names.h new file mode 100644 index 00000000..16bcc0b4 --- /dev/null +++ b/unix/f2c/src/names.h @@ -0,0 +1,19 @@ +#define CONST_IDENT_MAX 30 +#define IO_IDENT_MAX 30 +#define ARGUMENT_MAX 30 +#define USER_LABEL_MAX 30 + +#define EQUIV_INIT_NAME "equiv" + +#define write_nv_ident(fp,a) wr_nv_ident_help ((fp), (struct Addrblock *) (a)) +#define nv_type(x) nv_type_help ((struct Addrblock *) x) + +extern char *c_keywords[]; + +char* c_type_decl Argdcl((int, int)); +void declare_new_addr Argdcl((Addrp)); +char* new_arg_length Argdcl((Namep)); +char* new_func_length Argdcl((void)); +int nv_type_help Argdcl((Addrp)); +char* temp_name Argdcl((char*, int, char*)); +char* user_label Argdcl((long int)); diff --git a/unix/f2c/src/niceprintf.c b/unix/f2c/src/niceprintf.c new file mode 100644 index 00000000..a32411c4 --- /dev/null +++ b/unix/f2c/src/niceprintf.c @@ -0,0 +1,445 @@ +/**************************************************************** +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 */ diff --git a/unix/f2c/src/niceprintf.h b/unix/f2c/src/niceprintf.h new file mode 100644 index 00000000..24c65d4d --- /dev/null +++ b/unix/f2c/src/niceprintf.h @@ -0,0 +1,16 @@ +/* niceprintf.h -- contains constants and macros from the output filter + for the generated C code. We use macros for increased speed, less + function overhead. */ + +#define MAX_OUTPUT_SIZE 6000 /* Number of chars on one output line PLUS + the length of the longest string + printed using nice_printf */ + + + +#define next_tab(fp) (indent += tab_size) + +#define prev_tab(fp) (indent -= tab_size) + + + diff --git a/unix/f2c/src/notice b/unix/f2c/src/notice new file mode 100644 index 00000000..261b719b --- /dev/null +++ b/unix/f2c/src/notice @@ -0,0 +1,23 @@ +/**************************************************************** +Copyright 1990 - 1997 by AT&T, Lucent Technologies and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T, Bell Laboratories, +Lucent or Bellcore or any of their entities not be used in +advertising or publicity pertaining to distribution of the +software without specific, written prior permission. + +AT&T, Lucent and Bellcore disclaim all warranties with regard to +this software, including all implied warranties of +merchantability and fitness. In no event shall AT&T, Lucent or +Bellcore be liable for any special, indirect or consequential +damages or any damages whatsoever resulting from loss of use, +data or profits, whether in an action of contract, negligence or +other tortious action, arising out of or in connection with the +use or performance of this software. +****************************************************************/ + diff --git a/unix/f2c/src/output.c b/unix/f2c/src/output.c new file mode 100644 index 00000000..c734ca94 --- /dev/null +++ b/unix/f2c/src/output.c @@ -0,0 +1,1753 @@ +/**************************************************************** +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 */ diff --git a/unix/f2c/src/output.h b/unix/f2c/src/output.h new file mode 100644 index 00000000..97e3a0ad --- /dev/null +++ b/unix/f2c/src/output.h @@ -0,0 +1,64 @@ +/* nice_printf -- same arguments as fprintf. + + All output which is to become C code must be directed through this + function. For now, no buffering is done. Later on, every line of + output will be filtered to accomodate the style definitions (e.g. one + statement per line, spaces between function names and argument lists, + etc.) +*/ +#include "niceprintf.h" + + +/* Definitions for the opcode table. The table is indexed by the macros + which are #defined in defines.h */ + +#define UNARY_OP 01 +#define BINARY_OP 02 + +#define SPECIAL_FMT NULL + +#define is_unary_op(x) (opcode_table[x].type == UNARY_OP) +#define is_binary_op(x) (opcode_table[x].type == BINARY_OP) +#define op_precedence(x) (opcode_table[x].prec) +#define op_format(x) (opcode_table[x].format) + +/* _assoc_table -- encodes left-associativity and right-associativity + information; indexed by precedence level. Only 2, 3, 14 are + right-associative. Source: Kernighan & Ritchie, p. 49 */ + +extern char _assoc_table[]; + +#define is_right_assoc(x) (_assoc_table [x]) +#define is_left_assoc(x) (! _assoc_table [x]) + + +typedef struct { + int type; /* UNARY_OP or BINARY_OP */ + int prec; /* Precedence level, useful for adjusting + number of parens to insert. Zero is a + special level, and 2, 3, 14 are + right-associative */ + char *format; +} table_entry; + + +extern char *fl_fmt_string; /* Float constant format string */ +extern char *db_fmt_string; /* Double constant format string */ +extern char *cm_fmt_string; /* Complex constant format string */ +extern char *dcm_fmt_string; /* Double Complex constant format string */ + +extern int indent; /* Number of spaces to indent; this is a + temporary fix */ +extern int tab_size; /* Number of spaces in each tab */ +extern int in_string; + +extern table_entry opcode_table[]; + + +void compgoto_out Argdcl((FILEP, tagptr, tagptr)); +void endif_out Argdcl((FILEP)); +void expr_out Argdcl((FILEP, tagptr)); +void out_and_free_statement Argdcl((FILEP, tagptr)); +void out_end_for Argdcl((FILEP)); +void out_if Argdcl((FILEP, tagptr)); +void out_name Argdcl((FILEP, Namep)); diff --git a/unix/f2c/src/p1defs.h b/unix/f2c/src/p1defs.h new file mode 100644 index 00000000..c76af229 --- /dev/null +++ b/unix/f2c/src/p1defs.h @@ -0,0 +1,158 @@ +#define P1_UNKNOWN 0 +#define P1_COMMENT 1 /* Fortan comment string */ +#define P1_EOF 2 /* End of file dummy token */ +#define P1_SET_LINE 3 /* Reset the line counter */ +#define P1_FILENAME 4 /* Name of current input file */ +#define P1_NAME_POINTER 5 /* Pointer to hash table entry */ +#define P1_CONST 6 /* Some constant value */ +#define P1_EXPR 7 /* Followed by opcode */ + +/* The next two tokens could be grouped together, since they always come + from an Addr structure */ + +#define P1_IDENT 8 /* Char string identifier in addrp->user + field */ +#define P1_EXTERN 9 /* Pointer to external symbol entry */ + +#define P1_HEAD 10 /* Function header info */ +#define P1_LIST 11 /* A list of data (e.g. arguments) will + follow the tag, type, and count */ +#define P1_LITERAL 12 /* Hold the index into the literal pool */ +#define P1_LABEL 13 /* label value */ +#define P1_ASGOTO 14 /* Store the hash table pointer of + variable used in assigned goto */ +#define P1_GOTO 15 /* Store the statement number */ +#define P1_IF 16 /* store the condition as an expression */ +#define P1_ELSE 17 /* No data */ +#define P1_ELIF 18 /* store the condition as an expression */ +#define P1_ENDIF 19 /* Marks the end of a block IF */ +#define P1_ENDELSE 20 /* Marks the end of a block ELSE */ +#define P1_ADDR 21 /* Addr data; used for arrays, common and + equiv addressing, NOT for names, idents + or externs */ +#define P1_SUBR_RET 22 /* Subroutine return; the return expression + follows */ +#define P1_COMP_GOTO 23 /* Computed goto; has expr, label list */ +#define P1_FOR 24 /* C FOR loop; three expressions follow */ +#define P1_ENDFOR 25 /* End of C FOR loop */ +#define P1_FORTRAN 26 /* original Fortran source */ +#define P1_CHARP 27 /* user.Charp field -- for long names */ +#define P1_WHILE1START 28 /* start of DO WHILE */ +#define P1_WHILE2START 29 /* rest of DO WHILE */ +#define P1_PROCODE 30 /* invoke procode() -- to adjust params */ +#define P1_ELSEIFSTART 31 /* handle extra code for abs, min, max + in else if() */ + +#define P1_FILENAME_MAX 256 /* max filename length to retain (for -g) */ +#define P1_STMTBUFSIZE 1400 + + + +#define COMMENT_BUFFER_SIZE 255 /* max number of chars in each comment */ +#define CONSTANT_STR_MAX 1000 /* max number of chars in string constant */ + +void p1_asgoto Argdcl((Addrp)); +void p1_comment Argdcl((char*)); +void p1_elif Argdcl((tagptr)); +void p1_else Argdcl((void)); +void p1_endif Argdcl((void)); +void p1_expr Argdcl((tagptr)); +void p1_for Argdcl((tagptr, tagptr, tagptr)); +void p1_goto Argdcl((long int)); +void p1_head Argdcl((int, char*)); +void p1_if Argdcl((tagptr)); +void p1_label Argdcl((long int)); +void p1_line_number Argdcl((long int)); +void p1_subr_ret Argdcl((tagptr)); +void p1comp_goto Argdcl((tagptr, int, struct Labelblock**)); +void p1else_end Argdcl((void)); +void p1for_end Argdcl((void)); +void p1put Argdcl((int)); +void p1puts Argdcl((int, char*)); + +/* The pass 1 intermediate file has the following format: + + <ascii-integer-rep> [ : [ <sp> [ <data> ]]] \n + + e.g. 1: This is a comment + + This format is destined to change in the future, but for now a readable + form is more desirable than a compact form. + + NOTES ABOUT THE P1 FORMAT + ---------------------------------------------------------------------- + + P1_COMMENT: The comment string (in <data>) may be at most + COMMENT_BUFFER_SIZE bytes long. It must contain no newlines + or null characters. A side effect of the way comments are + read in lex.c is that no '\377' chars may be in a + comment either. + + P1_SET_LINE: <data> holds the line number in the current source file. + + P1_INC_LINE: Increment the source line number; <data> is empty. + + P1_NAME_POINTER: <data> holds the integer representation of a + pointer into a hash table entry. + + P1_CONST: the first field in <data> is a type tag (one of the + TYxxxx macros), the next field holds the constant + value + + P1_EXPR: <data> holds the opcode number of the expression, + followed by the type of the expression (required for + OPCONV). Next is the value of vleng. + The type of operation represented by the + opcode determines how many of the following data items + are part of this expression. + + P1_IDENT: <data> holds the type, then storage, then the + char string identifier in the addrp->user field. + + P1_EXTERN: <data> holds an offset into the external symbol + table entry + + P1_HEAD: the first field in <data> is the procedure class, the + second is the name of the procedure + + P1_LIST: the first field in <data> is the tag, the second the + type of the list, the third the number of elements in + the list + + P1_LITERAL: <data> holds the litnum of a value in the + literal pool. + + P1_LABEL: <data> holds the statement number of the current + line + + P1_ASGOTO: <data> holds the hash table pointer of the variable + + P1_GOTO: <data> holds the statement number to jump to + + P1_IF: <data> is empty, the following expression is the IF + condition. + + P1_ELSE: <data> is empty. + + P1_ELIF: <data> is empty, the following expression is the IF + condition. + + P1_ENDIF: <data> is empty. + + P1_ENDELSE: <data> is empty. + + P1_ADDR: <data> holds a direct copy of the structure. The + next expression is a copy of vleng, and the next a + copy of memoffset. + + P1_SUBR_RET: The next token is an expression for the return value. + + P1_COMP_GOTO: The next token is an integer expression, the + following one a list of labels. + + P1_FOR: The next three expressions are the Init, Test, and + Increment expressions of a C FOR loop. + + P1_ENDFOR: Marks the end of the body of a FOR loop + +*/ diff --git a/unix/f2c/src/p1output.c b/unix/f2c/src/p1output.c new file mode 100644 index 00000000..5afc7473 --- /dev/null +++ b/unix/f2c/src/p1output.c @@ -0,0 +1,728 @@ +/**************************************************************** +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 */ diff --git a/unix/f2c/src/parse.h b/unix/f2c/src/parse.h new file mode 100644 index 00000000..6de23994 --- /dev/null +++ b/unix/f2c/src/parse.h @@ -0,0 +1,47 @@ +#ifndef PARSE_INCLUDE +#define PARSE_INCLUDE + +/* macros for the parse_args routine */ + +#define P_STRING 1 /* Macros for the result_type attribute */ +#define P_CHAR 2 +#define P_SHORT 3 +#define P_INT 4 +#define P_LONG 5 +#define P_FILE 6 +#define P_OLD_FILE 7 +#define P_NEW_FILE 8 +#define P_FLOAT 9 +#define P_DOUBLE 10 + +#define P_CASE_INSENSITIVE 01 /* Macros for the flags attribute */ +#define P_REQUIRED_PREFIX 02 + +#define P_NO_ARGS 0 /* Macros for the arg_count attribute */ +#define P_ONE_ARG 1 +#define P_INFINITE_ARGS 2 + +#define p_entry(pref,swit,flag,count,type,store,size) \ + { (pref), (swit), (flag), (count), (type), (int *) (store), (size) } + +typedef struct { + char *prefix; + char *string; + int flags; + int count; + int result_type; + int *result_ptr; + int table_size; +} arg_info; + +#ifdef KR_headers +#define Argdcl(x) () +#else +#define Argdcl(x) x +#endif +int arg_verify Argdcl((char**, arg_info*, int)); +void init_store Argdcl((arg_info*, int)); +int match_table Argdcl((char*, arg_info*, int, int, int*)); +int parse_args Argdcl((int, char**, arg_info*, int, char**, int)); + +#endif diff --git a/unix/f2c/src/parse_args.c b/unix/f2c/src/parse_args.c new file mode 100644 index 00000000..dd7b7810 --- /dev/null +++ b/unix/f2c/src/parse_args.c @@ -0,0 +1,558 @@ +/**************************************************************** +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 <stdio.h> +#ifndef NULL +/* ANSI C */ +#include <stddef.h> +#endif +#ifdef KR_headers +extern double atof(); +#else +#include "stdlib.h" +#include "string.h" +#endif +#include "parse.h" +#include <math.h> /* For atof */ +#include <ctype.h> + +#define MAX_INPUT_SIZE 1000 + +#define arg_prefix(x) ((x).prefix) +#define arg_string(x) ((x).string) +#define arg_flags(x) ((x).flags) +#define arg_count(x) ((x).count) +#define arg_result_type(x) ((x).result_type) +#define arg_result_ptr(x) ((x).result_ptr) +#define arg_table_size(x) ((x).table_size) + +#ifndef TRUE +#define TRUE 1 +#endif +#ifndef FALSE +#define FALSE 0 +#endif +typedef int boolean; + + +static char *this_program = ""; + +static int arg_parse Argdcl((char*, arg_info*)); +static char *lower_string Argdcl((char*, char*)); +static int match Argdcl((char*, char*, arg_info*, boolean)); +static int put_one_arg Argdcl((int, char*, char**, char*, char*)); +extern int badargs; + + + boolean +#ifdef KR_headers +parse_args(argc, argv, table, entries, others, other_count) + int argc; + char **argv; + arg_info *table; + int entries; + char **others; + int other_count; +#else +parse_args(int argc, char **argv, arg_info *table, int entries, char **others, int other_count) +#endif +{ + boolean result; + + if (argv) + this_program = argv[0]; + +/* Check the validity of the table and its parameters */ + + result = arg_verify (argv, table, entries); + +/* Initialize the storage values */ + + init_store (table, entries); + + if (result) { + boolean use_prefix = TRUE; + char *argv0; + + argc--; + argv0 = *++argv; + while (argc) { + int index, length; + + index = match_table (*argv, table, entries, use_prefix, &length); + if (index < 0) { + +/* The argument doesn't match anything in the table */ + + if (others) { + + if (*argv > argv0) + *--*argv = '-'; /* complain at invalid flag */ + + if (other_count > 0) { + *others++ = *argv; + other_count--; + } else { + fprintf (stderr, "%s: too many parameters: ", + this_program); + fprintf (stderr, "'%s' ignored\n", *argv); + badargs++; + } /* else */ + } /* if (others) */ + argv0 = *++argv; + argc--; + 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 */ diff --git a/unix/f2c/src/pccdefs.h b/unix/f2c/src/pccdefs.h new file mode 100644 index 00000000..bde81177 --- /dev/null +++ b/unix/f2c/src/pccdefs.h @@ -0,0 +1,64 @@ +/* The following numbers are strange, and implementation-dependent */ + +#define P2BAD -1 +#define P2NAME 2 +#define P2ICON 4 /* Integer constant */ +#define P2PLUS 6 +#define P2PLUSEQ 7 +#define P2MINUS 8 +#define P2NEG 10 +#define P2STAR 11 +#define P2STAREQ 12 +#define P2INDIRECT 13 +#define P2BITAND 14 +#define P2BITOR 17 +#define P2BITXOR 19 +#define P2QUEST 21 +#define P2COLON 22 +#define P2ANDAND 23 +#define P2OROR 24 +#define P2GOTO 37 +#define P2LISTOP 56 +#define P2ASSIGN 58 +#define P2COMOP 59 +#define P2SLASH 60 +#define P2MOD 62 +#define P2LSHIFT 64 +#define P2RSHIFT 66 +#define P2CALL 70 +#define P2CALL0 72 + +#define P2NOT 76 +#define P2BITNOT 77 +#define P2EQ 80 +#define P2NE 81 +#define P2LE 82 +#define P2LT 83 +#define P2GE 84 +#define P2GT 85 +#define P2REG 94 +#define P2OREG 95 +#define P2CONV 104 +#define P2FORCE 108 +#define P2CBRANCH 109 + +/* special operators included only for fortran's use */ + +#define P2PASS 200 +#define P2STMT 201 +#define P2SWITCH 202 +#define P2LBRACKET 203 +#define P2RBRACKET 204 +#define P2EOF 205 +#define P2ARIF 206 +#define P2LABEL 207 + +#define P2SHORT 3 +#define P2INT 4 +#define P2LONG 4 + +#define P2CHAR 2 +#define P2REAL 6 +#define P2DREAL 7 +#define P2PTR 020 +#define P2FUNCT 040 diff --git a/unix/f2c/src/pread.c b/unix/f2c/src/pread.c new file mode 100644 index 00000000..40152182 --- /dev/null +++ b/unix/f2c/src/pread.c @@ -0,0 +1,990 @@ +/**************************************************************** +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); + } diff --git a/unix/f2c/src/proc.c b/unix/f2c/src/proc.c new file mode 100644 index 00000000..955d4646 --- /dev/null +++ b/unix/f2c/src/proc.c @@ -0,0 +1,1834 @@ +/**************************************************************** +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 ; p<lasthash ; ++p) + if(q = p->varp) + { + qstg = q->vstg; + qtype = q->vtype; + qclass = q->vclass; + + if( (qclass==CLUNKNOWN && qstg!=STGARG) || + (qclass==CLVAR && qstg==STGUNKNOWN) ) { + if (!(q->vis_assigned | q->vimpldovar)) + warn1("local variable %s never used", + q->fvarname); + } + else if(qclass==CLVAR && qstg==STGBSS) + { ; } + +/* Give external procedures the proper storage class */ + + else if(qclass==CLPROC && q->vprocclass==PEXTERNAL + && qstg!=STGARG) { + e = mkext(q->fvarname,addunder(q->cvarname)); + e->extstg = STGEXT; + q->vardesc.varno = e - extsymtab; + if (e->extype != qtype) + changedtype(q); + } + if(qclass==CLVAR) { + if (qstg != STGARG && q->vdim) + dim_check(q); + } /* if qclass == CLVAR */ + } + +} + + + void +donmlist(Void) +{ + register struct Hashentry *p; + register Namep q; + + for(p=hashtab; p<lasthash; ++p) + if( (q = p->varp) && q->vclass==CLNAMELIST) + namelist(q); +} + + +/* iarrlen -- Returns the size of the array in bytes, or -1 */ + + ftnint +#ifdef KR_headers +iarrlen(q) + register Namep q; +#else +iarrlen(register Namep q) +#endif +{ + ftnint leng; + + leng = typesize[q->vtype]; + if(leng <= 0) + return(-1); + if(q->vdim) + if( ISICON(q->vdim->nelt) ) + leng *= q->vdim->nelt->constblock.Const.ci; + else return(-1); + if(q->vleng) + if( ISICON(q->vleng) ) + leng *= q->vleng->constblock.Const.ci; + else return(-1); + return(leng); +} + + void +#ifdef KR_headers +namelist(np) + Namep np; +#else +namelist(Namep np) +#endif +{ + register chainp q; + register Namep v; + int y; + + if (!np->visused) + return; + y = 0; + + for(q = np->varxptr.namelist ; q ; q = q->nextp) + { + vardcl( v = (Namep) (q->datap) ); + if( !ONEOF(v->vstg, MSKSTATIC) ) + dclerr("may not appear in namelist", v); + else { + v->vnamelist = 1; + v->visused = 1; + v->vsave = 1; + y = 1; + } + np->visused = y; + } +} + +/* docommon -- called at the end of procedure declarations, before + equivalences and the procedure body */ + + LOCAL void +docommon(Void) +{ + register Extsym *extptr; + register chainp q, q1; + struct Dimblock *t; + expptr neltp; + register Namep comvar; + ftnint size; + int i, k, pref, type; + extern int type_pref[]; + + for(extptr = extsymtab ; extptr<nextext ; ++extptr) + if (extptr->extstg == STGCOMMON && (q = extptr->extp)) { + +/* If a common declaration also had a list of variables ... */ + + q = extptr->extp = revchain(q); + pref = 1; + for(k = TYCHAR; q ; q = q->nextp) + { + comvar = (Namep) (q->datap); + + if(comvar->vdcldone == NO) + vardcl(comvar); + type = comvar->vtype; + if (pref < type_pref[type]) + pref = type_pref[k = type]; + if(extptr->extleng % typealign[type] != 0) { + dclerr("common alignment", comvar); + --nerr; /* don't give bad return code for this */ +#if 0 + extptr->extleng = roundup(extptr->extleng, typealign[type]); +#endif + } /* if extptr -> extleng % */ + +/* Set the offset into the common block */ + + comvar->voffset = extptr->extleng; + comvar->vardesc.varno = extptr - extsymtab; + if(type == TYCHAR) + if (comvar->vleng) + size = comvar->vleng->constblock.Const.ci; + else { + dclerr("character*(*) in common", comvar); + size = 1; + } + else + size = typesize[type]; + if(t = comvar->vdim) + if( (neltp = t->nelt) && ISCONST(neltp) ) + size *= neltp->constblock.Const.ci; + else + dclerr("adjustable array in common", comvar); + +/* Adjust the length of the common block so far */ + + extptr->extleng += size; + } /* for */ + + extptr->extype = k; + +/* Determine curno and, if new, save this identifier chain */ + + q1 = extptr->extp; + for (q = extptr->allextp, i = 0; q; i++, q = q->nextp) + if (struct_eq((chainp)q->datap, q1)) + break; + if (q) + extptr->curno = extptr->maxno - i; + else { + extptr->curno = ++extptr->maxno; + extptr->allextp = mkchain((char *)extptr->extp, + extptr->allextp); + } + } /* if extptr -> extstg == STGCOMMON */ + +/* Now the hash table entries have STGCOMMON, vdcldone, voffset, and + varno. And the common block itself has its full size in extleng. */ + +} /* docommon */ + + +/* copy_data -- copy the Namep entries so they are available even after + the hash table is empty */ + + void +#ifdef KR_headers +copy_data(list) + chainp list; +#else +copy_data(chainp list) +#endif +{ + for (; list; list = list -> nextp) { + Namep namep = ALLOC (Nameblock); + int size, nd, i; + struct Dimblock *dp; + + cpn(sizeof(struct Nameblock), list->datap, (char *)namep); + namep->fvarname = strcpy(gmem(strlen(namep->fvarname)+1,0), + namep->fvarname); + namep->cvarname = strcmp(namep->fvarname, namep->cvarname) + ? strcpy(gmem(strlen(namep->cvarname)+1,0), namep->cvarname) + : namep->fvarname; + if (namep -> vleng) + namep -> vleng = (expptr) cpexpr (namep -> vleng); + if (namep -> vdim) { + nd = namep -> vdim -> ndim; + size = sizeof(int) + (3 + 2 * nd) * sizeof (expptr); + dp = (struct Dimblock *) ckalloc (size); + cpn(size, (char *)namep->vdim, (char *)dp); + namep -> vdim = dp; + dp->nelt = (expptr)cpexpr(dp->nelt); + for (i = 0; i < nd; i++) { + dp -> dims[i].dimsize = (expptr) cpexpr (dp -> dims[i].dimsize); + } /* for */ + } /* if */ + list -> datap = (char *) namep; + } /* for */ +} /* copy_data */ + + + + LOCAL void +docomleng(Void) +{ + register Extsym *p; + + for(p = extsymtab ; p < nextext ; ++p) + if(p->extstg == STGCOMMON) + { + if(p->maxleng!=0 && p->extleng!=0 && p->maxleng!=p->extleng + && strcmp(Blank, p->cextname) ) + warn1("incompatible lengths for common block %.60s", + p->fextname); + if(p->maxleng < p->extleng) + p->maxleng = p->extleng; + p->extleng = 0; + } +} + + +/* ROUTINES DEALING WITH AUTOMATIC AND TEMPORARY STORAGE */ + + void +#ifdef KR_headers +frtemp(p) + Addrp p; +#else +frtemp(Addrp p) +#endif +{ + /* put block on chain of temps to be reclaimed */ + holdtemps = mkchain((char *)p, holdtemps); +} + + void +freetemps(Void) +{ + register chainp p, p1; + register Addrp q; + register int t; + + p1 = holdtemps; + while(p = p1) { + q = (Addrp)p->datap; + t = q->vtype; + if (t == TYCHAR && q->varleng != 0) { + /* restore clobbered character string lengths */ + frexpr(q->vleng); + q->vleng = ICON(q->varleng); + } + p1 = p->nextp; + p->nextp = templist[t]; + templist[t] = p; + } + holdtemps = 0; + } + +/* allocate an automatic variable slot for each of nelt variables */ + + Addrp +#ifdef KR_headers +autovar(nelt0, t, lengp, name) + register int nelt0; + register int t; + expptr lengp; + char *name; +#else +autovar(register int nelt0, register int t, expptr lengp, char *name) +#endif +{ + ftnint leng; + register Addrp q; + register int nelt = nelt0 > 0 ? nelt0 : 1; + extern char *av_pfix[]; + + if(t == TYCHAR) + if( ISICON(lengp) ) + leng = lengp->constblock.Const.ci; + else { + Fatal("automatic variable of nonconstant length"); + } + else + leng = typesize[t]; + + q = ALLOC(Addrblock); + q->tag = TADDR; + q->vtype = t; + if(t == TYCHAR) + { + q->vleng = ICON(leng); + q->varleng = leng; + } + q->vstg = STGAUTO; + q->ntempelt = nelt; + q->isarray = (nelt > 1); + q->memoffset = ICON(0); + + /* kludge for nls so we can have ret_val rather than ret_val_4 */ + if (*name == ' ') + unamstring(q, name); + else { + q->uname_tag = UNAM_IDENT; + temp_name(av_pfix[t], ++autonum[t], q->user.ident); + } + if (nelt0 > 0) + declare_new_addr (q); + return(q); +} + + +/* Returns a temporary of the appropriate type. Will reuse existing + temporaries when possible */ + + Addrp +#ifdef KR_headers +mktmpn(nelt, type, lengp) + int nelt; + register int type; + expptr lengp; +#else +mktmpn(int nelt, register int type, expptr lengp) +#endif +{ + ftnint leng; + chainp p, oldp; + register Addrp q; + extern int krparens; + + if(type==TYUNKNOWN || type==TYERROR) + badtype("mktmpn", type); + + if(type==TYCHAR) + if(lengp && ISICON(lengp) ) + leng = lengp->constblock.Const.ci; + else { + err("adjustable length"); + return( (Addrp) errnode() ); + } + else if (type > TYCHAR || type < TYADDR) { + erri("mktmpn: unexpected type %d", type); + exit(1); + } +/* + * if a temporary of appropriate shape is on the templist, + * remove it from the list and return it + */ + if (krparens == 2 && ONEOF(type,M(TYREAL)|M(TYCOMPLEX))) + type++; + for(oldp=CHNULL, p=templist[type]; p ; oldp=p, p=p->nextp) + { + q = (Addrp) (p->datap); + if(q->ntempelt==nelt && + (type!=TYCHAR || q->vleng->constblock.Const.ci==leng) ) + { + if(oldp) + oldp->nextp = p->nextp; + else + templist[type] = p->nextp; + free( (charptr) p); + return(q); + } + } + q = autovar(nelt, type, lengp, ""); + return(q); +} + + + + +/* mktmp -- create new local variable; call it something like name + lengp is taken directly, not copied */ + + Addrp +#ifdef KR_headers +mktmp(type, lengp) + int type; + expptr lengp; +#else +mktmp(int type, expptr lengp) +#endif +{ + Addrp rv; + /* arrange for temporaries to be recycled */ + /* at the end of this statement... */ + rv = mktmpn(1,type,lengp); + frtemp((Addrp)cpexpr((expptr)rv)); + return rv; +} + +/* mktmp0 omits frtemp() */ + Addrp +#ifdef KR_headers +mktmp0(type, lengp) + int type; + expptr lengp; +#else +mktmp0(int type, expptr lengp) +#endif +{ + Addrp rv; + /* arrange for temporaries to be recycled */ + /* when this Addrp is freed */ + rv = mktmpn(1,type,lengp); + rv->istemp = YES; + return rv; +} + +/* VARIOUS ROUTINES FOR PROCESSING DECLARATIONS */ + +/* comblock -- Declare a new common block. Input parameters name the block; + s will be NULL if the block is unnamed */ + + Extsym * +#ifdef KR_headers +comblock(s) + register char *s; +#else +comblock(register char *s) +#endif +{ + Extsym *p; + register char *t; + register int c, i; + char cbuf[256], *s0; + +/* Give the unnamed common block a unique name */ + + if(*s == 0) + p = mkext1(s0 = Blank, Blank); + else { + s0 = s; + t = cbuf; + for(i = 0; c = *t = *s++; t++) + if (c == '_') + i = 1; + if (i) + *t++ = '_'; + t[0] = '_'; + t[1] = 0; + p = mkext1(s0,cbuf); + } + if(p->extstg == STGUNKNOWN) + p->extstg = STGCOMMON; + else if(p->extstg != STGCOMMON) + { + errstr("%.52s cannot be a common block: it is a subprogram.", + s0); + return(0); + } + + return( p ); +} + + +/* incomm -- add a new variable to a common declaration */ + + void +#ifdef KR_headers +incomm(c, v) + Extsym *c; + Namep v; +#else +incomm(Extsym *c, Namep v) +#endif +{ + if (!c) + return; + if(v->vstg != STGUNKNOWN && !v->vimplstg) + dclerr(v->vstg == STGARG + ? "dummy arguments cannot be in common" + : "incompatible common declaration", v); + else + { + v->vstg = STGCOMMON; + c->extp = mkchain((char *)v, c->extp); + } +} + + + + +/* settype -- set the type or storage class of a Namep object. If + v -> vstg == STGUNKNOWN && type < 0, attempt to reset vstg to be + -type. This function will not change any earlier definitions in v, + in will only attempt to fill out more information give the other params */ + + void +#ifdef KR_headers +settype(v, type, length) + register Namep v; + register int type; + register ftnint length; +#else +settype(register Namep v, register int type, register ftnint length) +#endif +{ + int type1; + + if(type == TYUNKNOWN) + return; + + if(type==TYSUBR && v->vtype!=TYUNKNOWN && v->vstg==STGARG) + { + v->vtype = TYSUBR; + frexpr(v->vleng); + v->vleng = 0; + v->vimpltype = 0; + } + else if(type < 0) /* storage class set */ + { + if(v->vstg == STGUNKNOWN) + v->vstg = - type; + else if(v->vstg != -type) + dclerr("incompatible storage declarations", v); + } + else if(v->vtype == TYUNKNOWN + || v->vtype != type + && (v->vimpltype || v->vinftype || v->vinfproc)) + { + if( (v->vtype = lengtype(type, length))==TYCHAR ) + if (length>=0) + v->vleng = ICON(length); + else if (parstate >= INDATA) + v->vleng = ICON(1); /* avoid a memory fault */ + v->vimpltype = 0; + v->vinftype = 0; /* 19960709 */ + v->vinfproc = 0; /* 19960709 */ + + if (v->vclass == CLPROC) { + if (v->vstg == STGEXT + && (type1 = extsymtab[v->vardesc.varno].extype) + && type1 != v->vtype) + changedtype(v); + else if (v->vprocclass == PTHISPROC + && (parstate >= INDATA + || procclass == CLMAIN) + && !xretslot[type]) { + xretslot[type] = autovar(ONEOF(type, + MSKCOMPLEX|MSKCHAR) ? 0 : 1, type, + v->vleng, " ret_val"); + if (procclass == CLMAIN) + errstr( + "illegal use of %.60s (main program name)", + v->fvarname); + /* not completely right, but enough to */ + /* avoid memory faults; we won't */ + /* emit any C as we have illegal Fortran */ + } + } + } + else if(v->vtype != type && v->vtype != lengtype(type, length)) { + incompat: + dclerr("incompatible type declarations", v); + } + else if (type==TYCHAR) + if (v->vleng && v->vleng->constblock.Const.ci != length) + goto incompat; + else if (parstate >= INDATA) + v->vleng = ICON(1); /* avoid a memory fault */ +} + + + + + +/* lengtype -- returns the proper compiler type, given input of Fortran + type and length specifier */ + + int +#ifdef KR_headers +lengtype(type, len) + register int type; + ftnint len; +#else +lengtype(register int type, ftnint len) +#endif +{ + register int length = (int)len; + switch(type) + { + case TYREAL: + if(length == typesize[TYDREAL]) + return(TYDREAL); + if(length == typesize[TYREAL]) + goto ret; + break; + + case TYCOMPLEX: + if(length == typesize[TYDCOMPLEX]) + return(TYDCOMPLEX); + if(length == typesize[TYCOMPLEX]) + goto ret; + break; + + case TYINT1: + case TYSHORT: + case TYDREAL: + case TYDCOMPLEX: + case TYCHAR: + case TYLOGICAL1: + case TYLOGICAL2: + case TYUNKNOWN: + case TYSUBR: + case TYERROR: +#ifdef TYQUAD + case TYQUAD: +#endif + goto ret; + + case TYLOGICAL: + switch(length) { + case 0: return tylog; + case 1: return TYLOGICAL1; + case 2: return TYLOGICAL2; + case 4: goto ret; + } + break; + + case TYLONG: + if(length == 0) + return(tyint); + if (length == 1) + return TYINT1; + if(length == typesize[TYSHORT]) + return(TYSHORT); +#ifdef TYQUAD + if(length == typesize[TYQUAD] && use_tyquad) + return(TYQUAD); +#endif + if(length == typesize[TYLONG]) + goto ret; + break; + default: + badtype("lengtype", type); + } + + if(len != 0) + err("incompatible type-length combination"); + +ret: + return(type); +} + + + + + +/* setintr -- Set Intrinsic function */ + + void +#ifdef KR_headers +setintr(v) + register Namep v; +#else +setintr(register Namep v) +#endif +{ + int k; + + if(k = intrfunct(v->fvarname)) { + if ((*(struct Intrpacked *)&k).f4) + if (noextflag) + goto unknown; + else + dcomplex_seen++; + v->vardesc.varno = k; + } + else { + unknown: + dclerr("unknown intrinsic function", v); + return; + } + if(v->vstg == STGUNKNOWN) + v->vstg = STGINTR; + else if(v->vstg!=STGINTR) + dclerr("incompatible use of intrinsic function", v); + if(v->vclass==CLUNKNOWN) + v->vclass = CLPROC; + if(v->vprocclass == PUNKNOWN) + v->vprocclass = PINTRINSIC; + else if(v->vprocclass != PINTRINSIC) + dclerr("invalid intrinsic declaration", v); +} + + + +/* setext -- Set External declaration -- assume that unknowns will become + procedures */ + + void +#ifdef KR_headers +setext(v) + register Namep v; +#else +setext(register Namep v) +#endif +{ + if(v->vclass == CLUNKNOWN) + v->vclass = CLPROC; + else if(v->vclass != CLPROC) + dclerr("invalid external declaration", v); + + if(v->vprocclass == PUNKNOWN) + v->vprocclass = PEXTERNAL; + else if(v->vprocclass != PEXTERNAL) + dclerr("invalid external declaration", v); +} /* setext */ + + + + +/* create dimensions block for array variable */ + + void +#ifdef KR_headers +setbound(v, nd, dims) + register Namep v; + int nd; + struct Dims *dims; +#else +setbound(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 */ diff --git a/unix/f2c/src/put.c b/unix/f2c/src/put.c new file mode 100644 index 00000000..15c70cd8 --- /dev/null +++ b/unix/f2c/src/put.c @@ -0,0 +1,458 @@ +/**************************************************************** +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 ; litp<lastlit ; ++litp) + +/* Remove this type checking to ensure that all bit patterns are reused */ + + if(type == litp->littype) switch(litflavor) + { + case LIT_CHAR: + if (len == (int)litp->litval.litival2[0] + && nblanks == litp->litval.litival2[1] + && !memcmp(strp, litp->cds[0], len)) { + q->memno = litp->litnum; + frexpr((expptr)p); + q->user.Const.ccp1.ccp0 = litp->cds[0]; + return(q); + } + break; + case LIT_FLOAT: + if(cd[0] == litp->litval.litdval[0] + && !strcmp(ds[0], litp->cds[0]) + && (k == 1 || + cd[1] == litp->litval.litdval[1] + && !strcmp(ds[1], litp->cds[1]))) { +ret: + q->memno = litp->litnum; + frexpr((expptr)p); + return(q); + } + break; + + case LIT_INT: + if(p->Const.ci == litp->litval.litival) + goto ret; + break; +#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 ); +} diff --git a/unix/f2c/src/putpcc.c b/unix/f2c/src/putpcc.c new file mode 100644 index 00000000..18a9df66 --- /dev/null +++ b/unix/f2c/src/putpcc.c @@ -0,0 +1,2169 @@ +/**************************************************************** +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<<k */ + if(INT(p->exprblock.leftp->headblock.vtype) && + ISICON(p->exprblock.rightp) && + ( (k = log_2(p->exprblock.rightp->constblock.Const.ci))>0) ) + { + p->exprblock.opcode = OPLSHIFT; + frexpr(p->exprblock.rightp); + p->exprblock.rightp = ICON(k); + goto putopp; + } + if (krparens && ISREAL(p->exprblock.vtype)) + return krput(p); + + case OPMOD: + goto putopp; + case OPPLUS: + if (krparens && ISREAL(p->exprblock.vtype)) + return krput(p); + case OPMINUS: + case OPSLASH: + case OPNEG: + case OPNEG1: + case OPABS: + case OPDABS: + if( ISCOMPLEX(p->exprblock.vtype) ) + p = putcxop(p); + else goto putopp; + break; + + case OPCONV: + if( ISCOMPLEX(p->exprblock.vtype) ) + p = putcxop(p); + else if( ISCOMPLEX(p->exprblock.leftp->headblock.vtype) ) + { + p = putx( mkconv(p->exprblock.vtype, + (expptr)realpart(putcx1(p->exprblock.leftp)))); + } + else goto putopp; + break; + + case OPNOT: + case OPOR: + case OPAND: + case OPEQV: + case OPNEQV: + case OPADDR: + case OPPLUSEQ: + case OPSTAREQ: + case OPCOMMA: + case OPQUEST: + case OPCOLON: + case OPBITOR: + case OPBITAND: + case OPBITXOR: + case OPBITNOT: + case OPLSHIFT: + case OPRSHIFT: + case OPASSIGNI: + case OPIDENTITY: + case OPCHARCAST: + case OPMIN2: + case OPMAX2: + case OPDMIN: + case OPDMAX: + case OPBITTEST: + case OPBITCLR: + case OPBITSET: +#ifdef TYQUAD + case OPQBITSET: + case OPQBITCLR: +#endif +putopp: + p = putop(p); + break; + + case OPCONCAT: + /* weird things like ichar(a//a) */ + p = (expptr)putch1(p); + break; + + default: + badop("putx", opc); + p = errnode (); + } + break; + + case TADDR: + p = putaddr(p); + break; + + default: + badtag("putx", p->tag); + p = errnode (); + } + + return p; +} + + + + LOCAL expptr +#ifdef KR_headers +putop(p) + expptr p; +#else +putop(expptr p) +#endif +{ + expptr lp, tp; + int pt, lt, lt1; + int comma; + char *hsave; + + switch(p->exprblock.opcode) /* check for special cases and rewrite */ + { + case OPCONV: + pt = p->exprblock.vtype; + lp = p->exprblock.leftp; + lt = lp->headblock.vtype; + +/* Simplify nested type casts */ + + while(p->tag==TEXPR && p->exprblock.opcode==OPCONV && + ( (ISREAL(pt)&&ONEOF(lt,MSKREAL|MSKCOMPLEX)) || + (INT(pt)&&(ONEOF(lt,MSKINT|MSKADDR|MSKCHAR|M(TYSUBR)))) )) + { + if(pt==TYDREAL && lt==TYREAL) + { + if(lp->tag==TEXPR + && lp->exprblock.opcode == OPCONV) { + lt1 = lp->exprblock.leftp->headblock.vtype; + if (lt1 == TYDREAL) { + lp->exprblock.leftp = + putx(lp->exprblock.leftp); + return p; + } + if (lt1 == TYDCOMPLEX) { + lp->exprblock.leftp = putx( + (expptr)realpart( + putcx1(lp->exprblock.leftp))); + return p; + } + } + break; + } + else if (ISREAL(pt) && ISCOMPLEX(lt)) { + p->exprblock.leftp = putx(mkconv(pt, + (expptr)realpart( + putcx1(p->exprblock.leftp)))); + break; + } + if(lt==TYCHAR && lp->tag==TEXPR && + lp->exprblock.opcode==OPCALL) + { + +/* May want to make a comma expression here instead. I had one, but took + it out for my convenience, not for the convenience of the end user */ + + putout (putcall (lp, (Addrp *) &(p -> + exprblock.leftp))); + return putop (p); + } + if (lt == TYCHAR) { + if (ISCONST(p->exprblock.leftp) + && ISNUMERIC(p->exprblock.vtype)) { + hsave = halign; + halign = 0; + p->exprblock.leftp = putx((expptr) + putconst((Constp) + p->exprblock.leftp)); + halign = hsave; + } + else + p->exprblock.leftp = + putx(p->exprblock.leftp); + return p; + } + if (pt < lt && ONEOF(lt,MSKINT|MSKREAL)) + break; + frexpr(p->exprblock.vleng); + free( (charptr) p ); + p = lp; + if (p->tag != TEXPR) + goto retputx; + pt = lt; + lp = p->exprblock.leftp; + lt = lp->headblock.vtype; + } /* while */ + if(p->tag==TEXPR && p->exprblock.opcode==OPCONV) + break; + retputx: + return putx(p); + + case OPADDR: + comma = NO; + lp = p->exprblock.leftp; + free( (charptr) p ); + if(lp->tag != TADDR) + { + tp = (expptr) + mktmp(lp->headblock.vtype,lp->headblock.vleng); + p = putx( mkexpr(OPASSIGN, cpexpr(tp), lp) ); + lp = tp; + comma = YES; + } + if(comma) + p = mkexpr(OPCOMMA, p, putaddr(lp)); + else + p = (expptr)putaddr(lp); + return p; + + case OPASSIGN: + case OPASSIGNI: + case OPLT: + case OPLE: + case OPGT: + case OPGE: + case OPEQ: + case OPNE: + ; + } + + if( ops2[p->exprblock.opcode] <= 0) + badop("putop", p->exprblock.opcode); + lp = p->exprblock.leftp = putx(p->exprblock.leftp); + if (p -> exprblock.rightp) { + tp = p->exprblock.rightp = putx(p->exprblock.rightp); + if (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) ==> + { <type> t1, t2; + + t1 = a; + t2 = b; t1 = (t1 < t2) ? t1 : t2; + t2 = c; t1 = (t1 < t2) ? t1 : t2; + t2 = d; t1 = (t1 < t2) ? t1 : t2; + } +*/ + + if (!doin_setbound) { + switch(op) { + case OPLT: + case OPMIN: + case OPDMIN: + case OPMIN2: + what = "IN"; + break; + default: + what = "AX"; + } + sprintf (comment_buf, "Computing M%s", what); + p1_comment (comment_buf); + } + + p1 = p0->nextp; + temp = (expptr)p0->datap; + if (addressable(temp) && addressable((expptr)p1->datap)) { + p = mkconv(type, cpexpr(temp)); + arg = mkconv(type, cpexpr((expptr)p1->datap)); + temp = mkexpr(op2, p, arg); + if (!ISCONST(temp)) + temp = fixexpr((Exprp)temp); + p1 = p1->nextp; + } + p = putassign (cpexpr((expptr)sp), temp); + + for(; p1 ; p1 = p1->nextp) + { + if (addressable ((expptr) p1 -> datap)) { + arg = mkconv(type, cpexpr((expptr)p1->datap)); + temp = mkexpr(op2, cpexpr((expptr)sp), arg); + temp = fixexpr((Exprp)temp); + } else { + temp = (expptr) cpexpr (qp); + p = mkexpr(OPCOMMA, p, + putassign(cpexpr((expptr)tp), (expptr)p1->datap)); + } /* else */ + + if(p1->nextp) + p = mkexpr(OPCOMMA, p, + putassign(cpexpr((expptr)sp), temp)); + else { + if (type == TYREAL && forcedouble) + temp->exprblock.opcode = + op == OPMIN ? OPDMIN : OPDMAX; + if (doin_setbound) + p = mkexpr(OPCOMMA, p, temp); + else { + putout (p); + p = putx(temp); + } + if (qp) + frexpr (qp); + } /* else */ + } /* for */ + + frchain( &p0 ); + return p; +} + + + void +#ifdef KR_headers +putwhile(p) + expptr p; +#else +putwhile(expptr p) +#endif +{ + 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); + } diff --git a/unix/f2c/src/sysdep.c b/unix/f2c/src/sysdep.c new file mode 100644 index 00000000..ab5b04ee --- /dev/null +++ b/unix/f2c/src/sysdep.c @@ -0,0 +1,699 @@ +/**************************************************************** +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 <windows.h> /* for GetVolumeInformation */ +#undef WANT_spawnvp +#define WANT_spawnvp +#undef MSDOS +#define MSDOS +#endif + +#ifdef WANT_spawnvp +#include <process.h> +#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 <unistd.h> /* 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 diff --git a/unix/f2c/src/sysdep.h b/unix/f2c/src/sysdep.h new file mode 100644 index 00000000..f9b7cbce --- /dev/null +++ b/unix/f2c/src/sysdep.h @@ -0,0 +1,101 @@ +/**************************************************************** +Copyright 1990, 1991, 1994 by AT&T, Lucent Technologies and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T, Bell Laboratories, +Lucent or Bellcore or any of their entities not be used in +advertising or publicity pertaining to distribution of the +software without specific, written prior permission. + +AT&T, Lucent and Bellcore disclaim all warranties with regard to +this software, including all implied warranties of +merchantability and fitness. In no event shall AT&T, Lucent or +Bellcore be liable for any special, indirect or consequential +damages or any damages whatsoever resulting from loss of use, +data or profits, whether in an action of contract, negligence or +other tortious action, arising out of or in connection with the +use or performance of this software. +****************************************************************/ + +/* This file is included at the start of defs.h; this file + * is an initial attempt to gather in one place some declarations + * that may need to be tweaked on some systems. + */ + +#ifdef __STDC__ +#undef KR_headers +#endif + +#ifndef KR_headers +#ifndef ANSI_Libraries +#define ANSI_Libraries +#endif +#ifndef ANSI_Prototypes +#define ANSI_Prototypes +#endif +#endif + +#ifdef __BORLANDC__ +#define MSDOS +#endif + +#ifdef __ZTC__ /* Zortech */ +#define MSDOS +#endif + +#ifdef MSDOS +#define ANSI_Libraries +#define ANSI_Prototypes +#define LONG_CAST (long) +#else +#define LONG_CAST +#endif + +#include <stdio.h> + +#ifdef ANSI_Libraries +#include <stddef.h> +#include <stdlib.h> +#else +char *calloc(), *malloc(), *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 <string.h> + +#include "ctype.h" + +#define Bits_per_Byte 8 +#define Table_size (1 << Bits_per_Byte) diff --git a/unix/f2c/src/sysdep.hd b/unix/f2c/src/sysdep.hd new file mode 100644 index 00000000..e15e92f3 --- /dev/null +++ b/unix/f2c/src/sysdep.hd @@ -0,0 +1 @@ +/*OK*/ diff --git a/unix/f2c/src/sysdeptest.c b/unix/f2c/src/sysdeptest.c new file mode 100644 index 00000000..3c470522 --- /dev/null +++ b/unix/f2c/src/sysdeptest.c @@ -0,0 +1,23 @@ +/* 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 <stdio.h> +#include <unistd.h> + + 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; + } diff --git a/unix/f2c/src/tokdefs.h b/unix/f2c/src/tokdefs.h new file mode 100644 index 00000000..35e3d72b --- /dev/null +++ b/unix/f2c/src/tokdefs.h @@ -0,0 +1,100 @@ +#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 diff --git a/unix/f2c/src/tokens b/unix/f2c/src/tokens new file mode 100644 index 00000000..07b18816 --- /dev/null +++ b/unix/f2c/src/tokens @@ -0,0 +1,100 @@ +SEOS +SCOMMENT +SLABEL +SUNKNOWN +SHOLLERITH +SICON +SRCON +SDCON +SBITCON +SOCTCON +SHEXCON +STRUE +SFALSE +SNAME +SNAMEEQ +SFIELD +SSCALE +SINCLUDE +SLET +SASSIGN +SAUTOMATIC +SBACKSPACE +SBLOCK +SCALL +SCHARACTER +SCLOSE +SCOMMON +SCOMPLEX +SCONTINUE +SDATA +SDCOMPLEX +SDIMENSION +SDO +SDOUBLE +SELSE +SELSEIF +SEND +SENDFILE +SENDIF +SENTRY +SEQUIV +SEXTERNAL +SFORMAT +SFUNCTION +SGOTO +SASGOTO +SCOMPGOTO +SARITHIF +SLOGIF +SIMPLICIT +SINQUIRE +SINTEGER +SINTRINSIC +SLOGICAL +SNAMELIST +SOPEN +SPARAM +SPAUSE +SPRINT +SPROGRAM +SPUNCH +SREAD +SREAL +SRETURN +SREWIND +SSAVE +SSTATIC +SSTOP +SSUBROUTINE +STHEN +STO +SUNDEFINED +SWRITE +SLPAR +SRPAR +SEQUALS +SCOLON +SCOMMA +SCURRENCY +SPLUS +SMINUS +SSTAR +SSLASH +SPOWER +SCONCAT +SAND +SOR +SNEQV +SEQV +SNOT +SEQ +SLT +SGT +SLE +SGE +SNE +SENDDO +SWHILE +SSLASHD +SBYTE diff --git a/unix/f2c/src/usignal.h b/unix/f2c/src/usignal.h new file mode 100644 index 00000000..ba4ee6ad --- /dev/null +++ b/unix/f2c/src/usignal.h @@ -0,0 +1,7 @@ +#include <signal.h> +#ifndef SIGHUP +#define SIGHUP 1 /* hangup */ +#endif +#ifndef SIGQUIT +#define SIGQUIT 3 /* quit */ +#endif diff --git a/unix/f2c/src/vax.c b/unix/f2c/src/vax.c new file mode 100644 index 00000000..63a7d8c8 --- /dev/null +++ b/unix/f2c/src/vax.c @@ -0,0 +1,585 @@ +/**************************************************************** +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 */ diff --git a/unix/f2c/src/version.c b/unix/f2c/src/version.c new file mode 100644 index 00000000..07013406 --- /dev/null +++ b/unix/f2c/src/version.c @@ -0,0 +1,2 @@ +char F2C_version[] = "20100827"; +char xxxvers[] = "\n@(#) FORTRAN 77 to C Translator, VERSION 20100827\n"; diff --git a/unix/f2c/src/xsum.c b/unix/f2c/src/xsum.c new file mode 100644 index 00000000..a5d70e45 --- /dev/null +++ b/unix/f2c/src/xsum.c @@ -0,0 +1,239 @@ +/**************************************************************** +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; + } diff --git a/unix/f2c/src/xsum.out b/unix/f2c/src/xsum.out new file mode 100644 index 00000000..d880438b --- /dev/null +++ b/unix/f2c/src/xsum.out @@ -0,0 +1,59 @@ +Notice 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 diff --git a/unix/f2c/src/xsum0.out b/unix/f2c/src/xsum0.out new file mode 100644 index 00000000..d880438b --- /dev/null +++ b/unix/f2c/src/xsum0.out @@ -0,0 +1,59 @@ +Notice 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 diff --git a/unix/f2c/src/xsum1.out b/unix/f2c/src/xsum1.out new file mode 100644 index 00000000..44d962fc --- /dev/null +++ b/unix/f2c/src/xsum1.out @@ -0,0 +1,59 @@ +Notice 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 f11b7532 3713 +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 |