From 0f16a0f6f8ea601d892cafb2932ff3741a2ba815 Mon Sep 17 00:00:00 2001 From: ceriel Date: Mon, 7 Oct 1991 16:35:03 +0000 Subject: [PATCH] Added --- lang/fortran/.distr | 7 + lang/fortran/changes | 1184 +++++++++++++ lang/fortran/comp/.distr | 60 + lang/fortran/comp/Notice | 23 + lang/fortran/comp/README | 73 + lang/fortran/comp/cds.c | 178 ++ lang/fortran/comp/data.c | 436 +++++ lang/fortran/comp/defines.h | 289 ++++ lang/fortran/comp/defs.h | 769 +++++++++ lang/fortran/comp/equiv.c | 372 +++++ lang/fortran/comp/error.c | 252 +++ lang/fortran/comp/exec.c | 831 +++++++++ lang/fortran/comp/expr.c | 2882 ++++++++++++++++++++++++++++++++ lang/fortran/comp/f2c.1 | 182 ++ lang/fortran/comp/f2c.1t | 326 ++++ lang/fortran/comp/f2c.6 | 317 ++++ lang/fortran/comp/f2c.h | 209 +++ lang/fortran/comp/format.c | 2108 +++++++++++++++++++++++ lang/fortran/comp/format.h | 10 + lang/fortran/comp/formatdata.c | 1037 ++++++++++++ lang/fortran/comp/ftypes.h | 39 + lang/fortran/comp/gram.dcl | 399 +++++ lang/fortran/comp/gram.exec | 143 ++ lang/fortran/comp/gram.expr | 141 ++ lang/fortran/comp/gram.head | 299 ++++ lang/fortran/comp/gram.io | 173 ++ lang/fortran/comp/init.c | 446 +++++ lang/fortran/comp/intr.c | 846 ++++++++++ lang/fortran/comp/io.c | 1416 ++++++++++++++++ lang/fortran/comp/iob.h | 24 + lang/fortran/comp/lex.c | 1453 ++++++++++++++++ lang/fortran/comp/machdefs.h | 31 + lang/fortran/comp/main.c | 590 +++++++ lang/fortran/comp/makefile | 84 + lang/fortran/comp/malloc.c | 142 ++ lang/fortran/comp/mem.c | 230 +++ lang/fortran/comp/memset.c | 66 + lang/fortran/comp/misc.c | 1041 ++++++++++++ lang/fortran/comp/names.c | 711 ++++++++ lang/fortran/comp/names.h | 22 + lang/fortran/comp/niceprintf.c | 367 ++++ lang/fortran/comp/niceprintf.h | 16 + lang/fortran/comp/output.c | 1431 ++++++++++++++++ lang/fortran/comp/output.h | 65 + lang/fortran/comp/p1defs.h | 160 ++ lang/fortran/comp/p1output.c | 568 +++++++ lang/fortran/comp/parse.h | 39 + lang/fortran/comp/parse_args.c | 499 ++++++ lang/fortran/comp/pccdefs.h | 64 + lang/fortran/comp/pread.c | 881 ++++++++++ lang/fortran/comp/proc.c | 1562 +++++++++++++++++ lang/fortran/comp/proto.make | 373 +++++ lang/fortran/comp/put.c | 399 +++++ lang/fortran/comp/putpcc.c | 1781 ++++++++++++++++++++ lang/fortran/comp/string.h | 16 + lang/fortran/comp/sysdep.c | 441 +++++ lang/fortran/comp/sysdep.h | 83 + lang/fortran/comp/tokens | 99 ++ lang/fortran/comp/usignal.h | 7 + lang/fortran/comp/vax.c | 325 ++++ lang/fortran/comp/version.c | 2 + lang/fortran/comp/xsum.c | 174 ++ lang/fortran/comp/xsum0.out | 56 + lang/fortran/disclaimer | 15 + lang/fortran/fc | 180 ++ lang/fortran/fixes | 1184 +++++++++++++ lang/fortran/index | 392 +++++ lang/fortran/lib/.distr | 3 + lang/fortran/lib/LIST | 3 + 69 files changed, 31026 insertions(+) create mode 100644 lang/fortran/.distr create mode 100644 lang/fortran/changes create mode 100644 lang/fortran/comp/.distr create mode 100644 lang/fortran/comp/Notice create mode 100644 lang/fortran/comp/README create mode 100644 lang/fortran/comp/cds.c create mode 100644 lang/fortran/comp/data.c create mode 100644 lang/fortran/comp/defines.h create mode 100644 lang/fortran/comp/defs.h create mode 100644 lang/fortran/comp/equiv.c create mode 100644 lang/fortran/comp/error.c create mode 100644 lang/fortran/comp/exec.c create mode 100644 lang/fortran/comp/expr.c create mode 100644 lang/fortran/comp/f2c.1 create mode 100644 lang/fortran/comp/f2c.1t create mode 100644 lang/fortran/comp/f2c.6 create mode 100644 lang/fortran/comp/f2c.h create mode 100644 lang/fortran/comp/format.c create mode 100644 lang/fortran/comp/format.h create mode 100644 lang/fortran/comp/formatdata.c create mode 100644 lang/fortran/comp/ftypes.h create mode 100644 lang/fortran/comp/gram.dcl create mode 100644 lang/fortran/comp/gram.exec create mode 100644 lang/fortran/comp/gram.expr create mode 100644 lang/fortran/comp/gram.head create mode 100644 lang/fortran/comp/gram.io create mode 100644 lang/fortran/comp/init.c create mode 100644 lang/fortran/comp/intr.c create mode 100644 lang/fortran/comp/io.c create mode 100644 lang/fortran/comp/iob.h create mode 100644 lang/fortran/comp/lex.c create mode 100644 lang/fortran/comp/machdefs.h create mode 100644 lang/fortran/comp/main.c create mode 100644 lang/fortran/comp/makefile create mode 100644 lang/fortran/comp/malloc.c create mode 100644 lang/fortran/comp/mem.c create mode 100644 lang/fortran/comp/memset.c create mode 100644 lang/fortran/comp/misc.c create mode 100644 lang/fortran/comp/names.c create mode 100644 lang/fortran/comp/names.h create mode 100644 lang/fortran/comp/niceprintf.c create mode 100644 lang/fortran/comp/niceprintf.h create mode 100644 lang/fortran/comp/output.c create mode 100644 lang/fortran/comp/output.h create mode 100644 lang/fortran/comp/p1defs.h create mode 100644 lang/fortran/comp/p1output.c create mode 100644 lang/fortran/comp/parse.h create mode 100644 lang/fortran/comp/parse_args.c create mode 100644 lang/fortran/comp/pccdefs.h create mode 100644 lang/fortran/comp/pread.c create mode 100644 lang/fortran/comp/proc.c create mode 100644 lang/fortran/comp/proto.make create mode 100644 lang/fortran/comp/put.c create mode 100644 lang/fortran/comp/putpcc.c create mode 100644 lang/fortran/comp/string.h create mode 100644 lang/fortran/comp/sysdep.c create mode 100644 lang/fortran/comp/sysdep.h create mode 100644 lang/fortran/comp/tokens create mode 100644 lang/fortran/comp/usignal.h create mode 100644 lang/fortran/comp/vax.c create mode 100644 lang/fortran/comp/version.c create mode 100644 lang/fortran/comp/xsum.c create mode 100644 lang/fortran/comp/xsum0.out create mode 100644 lang/fortran/disclaimer create mode 100644 lang/fortran/fc create mode 100644 lang/fortran/fixes create mode 100644 lang/fortran/index create mode 100644 lang/fortran/lib/.distr create mode 100644 lang/fortran/lib/LIST diff --git a/lang/fortran/.distr b/lang/fortran/.distr new file mode 100644 index 000000000..a9f8e4fd8 --- /dev/null +++ b/lang/fortran/.distr @@ -0,0 +1,7 @@ +changes +comp +disclaimer +fc +fixes +index +lib diff --git a/lang/fortran/changes b/lang/fortran/changes new file mode 100644 index 000000000..34c3f2b57 --- /dev/null +++ b/lang/fortran/changes @@ -0,0 +1,1184 @@ +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 in mem.c +changed to #include "string.h" so BSD people can create a local +string.h that simply says #include . + +Jan 30 10:34:00 EST 1990: + Fix erroneous warning at end of definition of a procedure with +character arguments when the procedure had previously been called with +a numeric argument instead of a character argument. (There were two +warnings, the second one incorrectly complaining of a wrong number of +arguments.) + +Jan 30 16:29:41 EST 1990: + Fix case where -P and -Ps erroneously reported another iteration +necessary. (Only harm is the extra iteration.) + +Feb 3 01:40:00 EST 1990: + Supply semicolon occasionally omitted under -c . + Try to force correct alignment when numeric variables are initialized +with character data (a non-standard and non-portable practice). You +must use the -W option if your code has such data statements and is +meant to run on a machine with other than 4 characters/word; e.g., for +code meant to run on a Cray, you would specify -W8 . + Allow parentheses around expressions in output lists (in write and +print statements). + Rename source files so their names are <= 12 characters long +(so there's room to append .Z and still have <= 14 characters); +renamed files: formatdata.c niceprintf.c niceprintf.h safstrncpy.c . + f2c material made available by anonymous ftp from research.att.com +(look in dist/f2c ). + +Feb 3 03:49:00 EST 1990: + Repair memory fault that arose from use (in an assignment or +call) of a non-argument variable declared CHARACTER*(*). + +Feb 9 01:35:43 EST 1990: + Fix erroneous error msg about bad types in + subroutine foo(a,adim) + dimension a(adim) + integer adim + Fix improper passing of character args (and possible memory fault) +in the expression part of a computed goto. + Fix botched calling sequences in array references involving +functions having character args. + Fix memory fault caused by invocation of character-valued functions +of no arguments. + Fix botched calling sequence of a character*1-valued function +assigned to a character*1 variable. + Fix bug in error msg for inconsistent number of args in prototypes. + Allow generation of C output despite inconsistencies in prototypes, +but give exit code 8. + Simplify include logic (by removing some bogus logic); never +prepend "/usr/include/" to file names. + Minor cleanups (that should produce no visible change in f2c's +behavior) in intr.c parse.h main.c defs.h formatdata.c p1output.c . + +Feb 10 00:19:38 EST 1990: + Insert (integer) casts when floating-point expressions are used +as subscripts. + Make SAVE stmt (with no variable list) override -a . + Minor cleanups: change field to Field in struct Addrblock (for the +benefit of buggy C compilers); omit system("/bin/cp ...") in misc.c . + +Feb 13 00:39:00 EST 1990: + Error msg fix in gram.dcl: change "cannot make %s parameter" +to "cannot make into parameter". + +Feb 14 14:02:00 EST 1990: + Various cleanups (invisible on systems with 4-byte ints), thanks +to Dave Regan: vaxx.c eliminated; %d changed to %ld various places; +external names adjusted for the benefit of stupid systems (that ignore +case and recognize only 6 significant characters in external names); +buffer shortened in xsum.c (e.g. for MS-DOS); fopen modes distinguish +text and binary files; several unused functions eliminated; missing +arg supplied to an unlikely fatalstr invocation. + +Thu Feb 15 19:15:53 EST 1990: + More cleanups (invisible on systems with 4 byte ints); casts inserted +so most complaints from cyntax(1) and lint(1) go away; a few (int) +versus (long) casts corrected. + +Fri Feb 16 19:55:00 EST 1990: + Recognize and translate unnamed Fortran 8x do while statements. + Fix bug that occasionally caused improper breaking of character +strings. + New error message for attempts to provide DATA in a type-declaration +statement. + +Sat Feb 17 11:43:00 EST 1990: + Fix infinite loop clf -> Fatal -> done -> clf after I/O error. + Change "if (addrp->vclass = CLPROC)" to "if (addrp->vclass == CLPROC)" +in p1_addr (in p1output.c); this was probably harmless. + Move a misplaced } in lex.c (which slowed initkey()). + Thanks to Gary Word for pointing these things out. + +Sun Feb 18 18:07:00 EST 1990: + Detect overlapping initializations of arrays and scalar variables +in previously missed cases. + Treat logical*2 as logical (after issuing a warning). + Don't pass string literals to p1_comment(). + Correct a cast (introduced 16 Feb.) in gram.expr; this matters e.g. +on a Cray. + Attempt to isolate UNIX-specific things in sysdep.c (a new source +file). Unless sysdep.c is compiled with SYSTEM_SORT defined, the +intermediate files created for DATA statements are now sorted in-core +without invoking system(). + +Tue Feb 20 16:10:35 EST 1990: + Move definition of binread and binwrite from init.c to sysdep.c . + Recognize Fortran 8x tokens < <= == >= > <> as synonyms for +.LT. .LE. .EQ. .GE. .GT. .NE. + Minor cleanup in putpcc.c: fully remove simoffset(). + More discussion of system dependencies added to libI77/README. + +Tue Feb 20 21:44:07 EST 1990: + Minor cleanups for the benefit of EBCDIC machines -- try to remove +the assumption that 'a' through 'z' are contiguous. (Thanks again to +Gary Word.) Also, change log2 to log_2 (shouldn't be necessary). + +Wed Feb 21 06:24:56 EST 1990: + Fix botch in init.c introduced in previous change; only matters +to non-ASCII machines. + +Thu Feb 22 17:29:12 EST 1990: + Allow several entry points to mention the same array. Protect +parameter adjustments with if's (for the case that an array is not +an argument to all entrypoints). + Under -u, allow + subroutine foo(x,n) + real x(n) + integer n + Compute intermediate variables used to evaluate dimension expressions +at the right time. Example previously mistranslated: + subroutine foo(x,k,m,n) + real x(min(k,m,n)) + ... + write(*,*) x + Detect duplicate arguments. (The error msg points to the first +executable stmt -- not wonderful, but not worth fixing.) + Minor cleanup of min/max computation (sometimes slightly simpler). + +Sun Feb 25 09:39:01 EST 1990: + Minor tweak to multiple entry points: protect parameter adjustments +with if's only for (array) args that do not appear in all entry points. + Minor tweaks to format.c and io.c (invisible unless your compiler +complained at the duplicate #defines of IOSUNIT and IOSFMT or at +comparisons of p1gets(...) with NULL). + +Sun Feb 25 18:40:10 EST 1990: + Fix bug introduced Feb. 22: if a subprogram contained DATA and the +first executable statement was labeled, then the label got lost. +(Just change INEXEC to INDATA in p1output.c; it occurs just once.) + +Mon Feb 26 17:45:10 EST 1990: + Fix bug in handling of " and ' in comments. + +Wed Mar 28 01:43:06 EST 1990: +libI77: + 1. Repair nasty I/O bug: opening two files and closing the first +(after possibly reading or writing it), then writing the second caused +the last buffer of the second to be lost. + 2. Formatted reads of logical values treated all letters other than +t or T as f (false). + libI77 files changed: err.c rdfmt.c Version.c + (Request "libi77 from f2c" -- you can't get these files individually.) + +f2c itself: + Repair nasty bug in translation of + ELSE IF (condition involving complicated abs, min, or max) +-- auxiliary statements were emitted at the wrong place. + Supply semicolon previously omitted from the translation of a label +(of a CONTINUE) immediately preceding an ELSE IF or an ELSE. This +bug made f2c produce invalid C. + Correct a memory fault that occurred (on some machines) when the +error message "adjustable dimension on non-argument" should be given. + Minor tweaks to remove some harmless warnings by overly chatty C +compilers. + Argument arays having constant dimensions but a variable lower bound +(e.g., x(n+1:n+3)) had a * omitted from scalar arguments involved in +the array offset computation. + +Wed Mar 28 18:47:59 EST 1990: +libf77: add exit(0) to end of main [return(0) encounters a Cray bug] + +Sun Apr 1 16:20:58 EDT 1990: + Avoid dereferencing null when processing equivalences after an error. + +Fri Apr 6 08:29:49 EDT 1990: + Calls involving alternate return specifiers omitted processing +needed for things like min, max, abs, and // (concatenation). + INTEGER*2 PARAMETERs were treated as INTEGER*4. + Convert some O(n^2) parsing to O(n). + +Tue Apr 10 20:07:02 EDT 1990: + When inconsistent calling sequences involve differing numbers of +arguments, report the first differing argument rather than the numbers +of arguments. + Fix bug under -a: formatted I/O in which either the unit or the +format was a local character variable sometimes resulted in invalid C +(a static struct initialized with an automatic component). + Improve error message for invalid flag after elided -. + Complain when literal table overflows, rather than infinitely +looping. (The complaint mentions the new and otherwise undocumented +-NL option for specifying a larger literal table.) + New option -h for forcing strings to word (or, with -hd, double-word) +boundaries where possible. + Repair a bug that could cause improper splitting of strings. + Fix bug (cast of c to doublereal) in + subroutine foo(c,r) + double complex c + double precision r + c = cmplx(r,real(c)) + end + New include file "sysdep.h" has some things from defs.h (and +elsewhere) that one may need to modify on some systems. + Some large arrays that were previously statically allocated are now +dynamically allocated when f2c starts running. + f2c/src files changed: + README cds.c defs.h f2c.1 f2c.1t format.c formatdata.c init.c + io.c lex.c main.c makefile mem.c misc.c names.c niceprintf.c + output.c parse_args.c pread.c put.c putpcc.c sysdep.h + version.c xsum0.out + +Wed Apr 11 18:27:12 EDT 1990: + Fix bug in argument consistency checking of character, complex, and +double complex valued functions. If the same source file contained a +definition of such a function with arguments not explicitly typed, +then subsequent references to the function might get erroneous +warnings of inconsistent calling sequences. + Tweaks to sysdep.h for partially ANSI systems. + New options -kr and -krd cause f2c to use temporary variables to +enforce Fortran evaluation-order rules with pernicious, old-style C +compilers that apply the associative law to floating-point operations. + +Sat Apr 14 15:50:15 EDT 1990: + libi77: libI77 adjusted to allow list-directed and namelist I/O +of internal files; bug in namelist I/O of logical and character arrays +fixed; list input of complex numbers adjusted to permit d or D to +denote the start of the exponent field of a component. + f2c itself: fix bug in handling complicated lower-bound +expressions for character substrings; e.g., min and max did not work +right, nor did function invocations involving character arguments. + Switch to octal notation, rather than hexadecimal, for nonprinting +characters in character and string constants. + Fix bug (when neither -A nor -C++ was specified) in typing of +external arguments of type complex, double complex, or character: + subroutine foo(c) + external c + complex c +now results in + /* Complex */ int (*c) (); +(as, indeed, it once did) rather than + complex (*c) (); + +Sat Apr 14 22:50:39 EDT 1990: + libI77/makefile: updated "make check" to omit lio.c + lib[FI]77/makefile: trivial change: define CC = cc, reference $(CC). + (Request, e.g., "libi77 from f2c" -- you can't ask for individual +files from lib[FI]77.) + +Wed Apr 18 00:56:37 EDT 1990: + Move declaration of atof() from defs.h to sysdep.h, where it is +now not declared if stdlib.h is included. (NeXT's stdlib.h has a +#define atof that otherwise wreaks havoc.) + Under -u, provide a more intelligible error message (than "bad tag") +for an attempt to define a function without specifying its type. + +Wed Apr 18 17:26:27 EDT 1990: + Recognize \v (vertical tab) in Hollerith as well as quoted strings; +add recognition of \r (carriage return). + New option -!bs turns off recognition of escapes in character strings +(\0, \\, \b, \f, \n, \r, \t, \v). + Move to sysdep.c initialization of some arrays whose initialization +assumed ASCII; #define Table_size in sysdep.h rather than using +hard-coded 256 in allocating arrays of size 1 << (bits/byte). + +Thu Apr 19 08:13:21 EDT 1990: + Warn when escapes would make Hollerith extend beyond statement end. + Omit max() definition from misc.c (should be invisible except on +systems that erroneously #define max in stdlib.h). + +Mon Apr 23 22:24:51 EDT 1990: + When producing default-style C (no -A or -C++), cast switch +expressions to (int). + Move "-lF77 -lI77 -lm -lc" to link_msg, defined in sysdep.c . + Add #define scrub(x) to sysdep.h, with invocations in format.c and +formatdata.c, so that people who have systems like VMS that would +otherwise create multiple versions of intermediate files can +#define scrub(x) unlink(x) + +Tue Apr 24 18:28:36 EDT 1990: + Pass string lengths once rather than twice to a function of character +arguments involved in comparison of character strings of length 1. + +Fri Apr 27 13:11:52 EDT 1990: + Fix bug that made f2c gag on concatenations involving char(...) on +some systems. + +Sat Apr 28 23:20:16 EDT 1990: + Fix control-stack bug in + if(...) then + else if (complicated condition) + else + endif +(where the complicated condition causes assignment to an auxiliary +variable, e.g., max(a*b,c)). + +Mon Apr 30 13:30:10 EDT 1990: + Change fillers for DATA with holes from substructures to arrays +(in an attempt to make things work right with C compilers that have +funny padding rules for substructures, e.g., Sun C compilers). + Minor cleanup of exec.c (should not affect generated C). + +Mon Apr 30 23:13:51 EDT 1990: + Fix bug in handling return values of functions having multiple +entry points of differing return types. + +Sat May 5 01:45:18 EDT 1990: + Fix type inference bug in + subroutine foo(x) + call goo(x) + end + subroutine goo(i) + i = 3 + end +Instead of warning of inconsistent calling sequences for goo, +f2c was simply making i a real variable; now i is correctly +typed as an integer variable, and f2c issues an error message. + Adjust error messages issued at end of declarations so they +don't blame the first executable statement. + +Sun May 6 01:29:07 EDT 1990: + Fix bug in -P and -Ps: warn when the definition of a subprogram adds +information that would change prototypes or previous declarations. + +Thu May 10 18:09:15 EDT 1990: + Fix further obscure bug with (default) -it: inconsistent calling +sequences and I/O statements could interact to cause a memory fault. +Example: + SUBROUTINE FOO + CALL GOO(' Something') ! Forgot integer first arg + END + SUBROUTINE GOO(IUNIT,MSG) + CHARACTER*(*)MSG + WRITE(IUNIT,'(1X,A)') MSG + END + +Fri May 11 16:49:11 EDT 1990: + Under -!c, do not delete any .c files (when there are errors). + Avoid dereferencing 0 when a fatal error occurs while reading +Fortran on stdin. + +Wed May 16 18:24:42 EDT 1990: + f2c.ps made available. + +Mon Jun 4 12:53:08 EDT 1990: + Diagnose I/O units of invalid type. + Add specific error msg about dummy arguments in common. + +Wed Jun 13 12:43:17 EDT 1990: + Under -A, supply a missing "[1]" for CHARACTER*1 variables that appear +both in a DATA statement and in either COMMON or EQUIVALENCE. + +Mon Jun 18 16:58:31 EDT 1990: + Trivial updates to f2c.ps . ("Fortran 8x" --> "Fortran 90"; omit +"(draft)" from "(draft) ANSI C".) + +Tue Jun 19 07:36:32 EDT 1990: + Fix incorrect code generated for ELSE IF(expression involving +function call passing non-constant substring). + Under -h, preserve the property that strings are null-terminated +where possible. + Remove spaces between # and define in lex.c output.c parse.h . + +Mon Jun 25 07:22:59 EDT 1990: + Minor tweak to makefile to reduce unnecessary recompilations. + +Tue Jun 26 11:49:53 EDT 1990: + Fix unintended truncation of some integer constants on machines +where casting a long to (int) may change the value. E.g., when f2c +ran on machines with 16-bit ints, "i = 99999" was being translated +to "i = -31073;". + +Wed Jun 27 11:05:32 EDT 1990: + Arrange for CHARACTER-valued PARAMETERs to honor their length +specifications. Allow CHAR(nn) in expressions defining such PARAMETERs. + +Fri Jul 20 09:17:30 EDT 1990: + Avoid dereferencing 0 when a FORMAT statement has no label. + +Thu Jul 26 11:09:39 EDT 1990: + Remarks about VOID and binread,binwrite added to README. + Tweaks to parse_args: should be invisible unless your compiler +complained at (short)*store. + +Thu Aug 2 02:07:58 EDT 1990: + f2c.ps: change the first line of page 5 from + include stuff +to + include 'stuff' + +Tue Aug 14 13:21:24 EDT 1990: + libi77: libI77 adjusted to treat tabs as spaces in list input. + +Fri Aug 17 07:24:53 EDT 1990: + libi77: libI77 adjusted so a blank='ZERO' clause (upper case Z) +in an open of a currently open file works right. + +Tue Aug 28 01:56:44 EDT 1990: + Fix bug in warnings of inconsistent calling sequences: if an +argument to a subprogram was never referenced, then a previous +invocation of the subprogram (in the same source file) that +passed something of the wrong type for that argument did not +elicit a warning message. + +Thu Aug 30 09:46:12 EDT 1990: + libi77: prevent embedded blanks in list output of complex values; +omit exponent field in list output of values of magnitude between +10 and 1e8; prevent writing stdin and reading stdout or stderr; +don't close stdin, stdout, or stderr when reopening units 5, 6, 0. + +Tue Sep 4 12:30:57 EDT 1990: + Fix bug in C emitted under -I2 or -i2 for INTEGER*4 FUNCTION. + Warn of missing final END even if there are previous errors. + +Fri Sep 7 13:55:34 EDT 1990: + Remark about "make xsum.out" and "make f2c" added to README. + +Tue Sep 18 23:50:01 EDT 1990: + Fix null dereference (and, on some systems, writing of bogus *_com.c +files) under -ec or -e1c when a prototype file (*.p or *.P) describes +COMMON blocks that do not appear in the Fortran source. + libi77: + Add some #ifdef lines (#ifdef MSDOS, #ifndef MSDOS) to avoid +references to stat and fstat on non-UNIX systems. + On UNIX systems, add component udev to unit; decide that old +and new files are the same iff both the uinode and udev components +of unit agree. + When an open stmt specifies STATUS='OLD', use stat rather than +access (on UNIX systems) to check the existence of the file (in case +directories leading to the file have funny permissions and this is +a setuid or setgid program). + +Thu Sep 27 16:04:09 EDT 1990: + Supply missing entry for Impldoblock in blksize array of cpexpr +(in expr.c). No examples are known where this omission caused trouble. + +Tue Oct 2 22:58:09 EDT 1990: + libf77: test signal(...) == SIG_IGN rather than & 01 in main(). + libi77: adjust rewind.c so two successive rewinds after a write +don't clobber the file. + +Thu Oct 11 18:00:14 EDT 1990: + libi77: minor cleanups: add #include "fcntl.h" to endfile.c, err.c, +open.c; adjust g_char in util.c for segmented memories; in f_inqu +(inquire.c), define x appropriately when MSDOS is defined. + +Mon Oct 15 20:02:11 EDT 1990: + Add #ifdef MSDOS pointer adjustments to mem.c; treat NAME= as a +synonym for FILE= in OPEN statements. + +Wed Oct 17 16:40:37 EDT 1990: + libf77, libi77: minor cleanups: _cleanup() and abort() invocations +replaced by invocations of sig_die in main.c; some error messages +previously lost in buffers will now appear. + +Mon Oct 22 16:11:27 EDT 1990: + libf77: separate sig_die from main (for folks who don't want to use +the main in libF77). + libi77: minor tweak to comments in README. + +Fri Nov 2 13:49:35 EST 1990: + Use two underscores rather than one in generated temporary variable +names to avoid conflict with COMMON names. f2c.ps updated to reflect +this change and the NAME= extension introduced 15 Oct. + Repair a rare memory fault in io.c . + +Mon Nov 5 16:43:55 EST 1990: + libi77: changes to open.c (and err.c): complain if an open stmt +specifies new= and the file already exists (as specified by Fortrans 77 +and 90); allow file= to be omitted in open stmts and allow +status='replace' (Fortran 90 extensions). + +Fri Nov 30 10:10:14 EST 1990: + Adjust malloc.c for unusual systems whose sbrk() can return values +not properly aligned for doubles. + Arrange for slightly more helpful and less repetitive warnings for +non-character variables initialized with character data; these warnings +are (still) suppressed by -w66. + +Fri Nov 30 15:57:59 EST 1990: + Minor tweak to README (about changing VOID in f2c.h). + +Mon Dec 3 07:36:20 EST 1990: + Fix spelling of "character" in f2c.1t. + +Tue Dec 4 09:48:56 EST 1990: + Remark about link_msg and libf2c added to f2c/README. + +Thu Dec 6 08:33:24 EST 1990: + Under -U, render label nnn as L_nnn rather than Lnnn. + +Fri Dec 7 18:05:00 EST 1990: + Add more names from f2c.h (e.g. integer, real) to the c_keywords +list of names to which an underscore is appended to avoid confusion. + +Mon Dec 10 19:11:15 EST 1990: + Minor tweaks to makefile (./xsum) and README (binread/binwrite). + libi77: a few modifications for POSIX systems; meant to be invisible +elsewhere. + +Sun Dec 16 23:03:16 EST 1990: + Fix null dereference caused by unusual erroneous input, e.g. + call foo('abc') + end + subroutine foo(msg) + data n/3/ + character*(*) msg + end +(Subroutine foo is illegal because the character statement comes after a +data statement.) + Use decimal rather than hex constants in xsum.c (to prevent +erroneous warning messages about constant overflow). + +Mon Dec 17 12:26:40 EST 1990: + Fix rare extra underscore in character length parameters passed +for multiple entry points. + +Wed Dec 19 17:19:26 EST 1990: + Allow generation of C despite error messages about bad alignment +forced by equivalence. + Allow variable-length concatenations in I/O statements, such as + open(3, file=bletch(1:n) // '.xyz') + +Fri Dec 28 17:08:30 EST 1990: + Fix bug under -p with formats and internal I/O "units" in COMMON, +as in + COMMON /FIGLEA/F + CHARACTER*20 F + F = '(A)' + WRITE (*,FMT=F) 'Hello, world!' + END + +Tue Jan 15 12:00:24 EST 1991: + Fix bug when two equivalence groups are merged, the second with +nonzero offset, and the result is then merged into a common block. +Example: + INTEGER W(3), X(3), Y(3), Z(3) + COMMON /ZOT/ Z + EQUIVALENCE (W(1),X(1)), (X(2),Y(1)), (Z(3),X(1)) +***** W WAS GIVEN THE WRONG OFFSET + Recognize Fortran 90's optional NML= in NAMELIST READs and WRITEs. +(Currently NML= and FMT= are treated as synonyms -- there's no +error message if, e.g., NML= specifies a format.) + libi77: minor adjustment to allow internal READs from character +string constants in read-only memory. + +Fri Jan 18 22:56:15 EST 1991: + Add comment to README about needing to comment out the typedef of +size_t in sysdep.h on some systems, e.g. Sun 4.1. + Fix misspelling of "statement" in an error message in lex.c + +Wed Jan 23 00:38:48 EST 1991: + Allow hex, octal, and binary constants to have the qualifying letter +(z, x, o, or b) either before or after the quoted string containing the +digits. For now this change will not be reflected in f2c.ps . + +Tue Jan 29 16:23:45 EST 1991: + Arrange for character-valued statement functions to give results of +the right length (that of the statement function's name). + +Wed Jan 30 07:05:32 EST 1991: + More tweaks for character-valued statement functions: an error +check and an adjustment so a right-hand side of nonconstant length +(e.g., a substring) is handled right. + +Wed Jan 30 09:49:36 EST 1991: + Fix p1_head to avoid printing (char *)0 with %s. + +Thu Jan 31 13:53:44 EST 1991: + Add a test after the cleanup call generated for I/O statements with +ERR= or END= clauses to catch the unlikely event that the cleanup +routine encounters an error. + +Mon Feb 4 08:00:58 EST 1991: + Minor cleanup: omit unneeded jumps and labels from code generated for +some NAMELIST READs and WRITEs with IOSTAT=, ERR=, and/or END=. + +Tue Feb 5 01:39:36 EST 1991: + Change Mktemp to mktmp (for the benefit of systems so brain-damaged +that they do not distinguish case in external names -- and that for +some reason want to load mktemp). Try to get xsum0.out right this +time (it somehow didn't get updated on 4 Feb. 1991). + Add note to libi77/README about adjusting the interpretation of +RECL= specifiers in OPENs for direct unformatted I/O. + +Thu Feb 7 17:24:42 EST 1991: + New option -r casts values of REAL functions, including intrinsics, +to REAL. This only matters for unportable code like + real r + r = asin(1.) + if (r .eq. asin(1.)) ... +[The behavior of such code varies with the Fortran compiler used -- +and sometimes is affected by compiler options.] For now, the man page +at the end of f2c.ps is the only part of f2c.ps that reflects this new +option. + +Fri Feb 8 18:12:51 EST 1991: + Cast pointer differences passed as arguments to the appropriate type. +This matters, e.g., with MSDOS compilers that yield a long pointer +difference but have int == short. + Disallow nonpositive dimensions. + +Fri Feb 15 12:24:15 EST 1991: + Change %d to %ld in sprintf call in putpower in putpcc.c. + Free more memory (e.g. allowing translation of larger Fortran +files under MS-DOS). + Recognize READ (character expression) and WRITE (character expression) +as formatted I/O with the format given by the character expression. + Update year in Notice. + +Sat Feb 16 00:42:32 EST 1991: + Recant recognizing WRITE(character expression) as formatted output +-- Fortran 77 is not symmetric in its syntax for READ and WRITE. + +Mon Mar 4 15:19:42 EST 1991: + Fix bug in passing the real part of a complex argument to an intrinsic +function. Omit unneeded parentheses in nested calls to intrinsics. +Example: + subroutine foo(x, y) + complex y + x = exp(sin(real(y))) + exp(imag(y)) + end + +Fri Mar 8 15:05:42 EST 1991: + Fix a comment in expr.c; omit safstrncpy.c (which had bugs in +cases not used by f2c). + +Wed Mar 13 02:27:23 EST 1991: + Initialize firstmemblock->next in mem_init in mem.c . [On most +systems it was fortuituously 0, but with System V, -lmalloc could +trip on this missed initialization.] + +Wed Mar 13 11:47:42 EST 1991: + Fix a reference to freed memory. + +Wed Mar 27 00:42:19 EST 1991: + Fix a memory fault caused by such illegal Fortran as + function foo + x = 3 + logical foo ! declaration among executables + foo=.false. ! used to suffer memory fault + end + +Fri Apr 5 08:30:31 EST 1991: + Fix loss of % in some format expressions, e.g. + write(*,'(1h%)') + Fix botch introduced 27 March 1991 that caused subroutines with +multiple entry points to have extraneous declarations of ret_val. + +Fri Apr 5 12:44:02 EST 1991 + Try again to omit extraneous ret_val declarations -- this morning's +fix was sometimes wrong. + +Mon Apr 8 13:47:06 EDT 1991: + Arrange for s_rnge to have the right prototype under -A -C . + +Wed Apr 17 13:36:03 EDT 1991: + New fatal error message for apparent invocation of a recursive +statement function. + +Thu Apr 25 15:13:37 EDT 1991: + F2c and libi77 adjusted so NAMELIST works with -i2. (I forgot +about -i2 when adding NAMELIST.) This required a change to f2c.h +(that only affects NAMELIST I/O under -i2.) Man-page description of +-i2 adjusted to reflect that -i2 stores array lengths in short ints. + +Fri Apr 26 02:54:41 EDT 1991: + Libi77: fix some bugs in NAMELIST reading of multi-dimensional arrays +(file rsne.c). + +Thu May 9 02:13:51 EDT 1991: + Omit a trailing space in expr.c (could cause a false xsum value if +a mailer drops the trailing blank). + +Thu May 16 13:14:59 EDT 1991: + Libi77: increase LEFBL in lio.h to overcome a NeXT bug. + Tweak for compilers that recognize "nested" comments: inside comments, +turn /* into /+ (as well as */ into +/). + +Sat May 25 11:44:25 EDT 1991: + libf77: s_rnge: declare line long int rather than int. + +Fri May 31 07:51:50 EDT 1991: + libf77: system_: officially return status. + +Mon Jun 17 16:52:53 EDT 1991: + Minor tweaks: omit unnecessary declaration of strcmp (that caused +trouble on a system where strcmp was a macro) from misc.c; add +SHELL = /bin/sh to makefiles. + Fix a dereference of null when a CHARACTER*(*) declaration appears +(illegally) after DATA. Complain only once per subroutine about +declarations appearing after DATA. + +Mon Jul 1 00:28:13 EDT 1991: + Add test and error message for illegal use of subroutine names, e.g. + SUBROUTINE ZAP(A) + ZAP = A + END + +Mon Jul 8 21:49:20 EDT 1991: + Issue a warning about things like + integer i + i = 'abc' +(which is treated as i = ichar('a')). [It might be nice to treat 'abc' +as an integer initialized (in a DATA statement) with 'abc', but +other matters have higher priority.] + Render + i = ichar('A') +as + i = 'A'; +rather than + i = 65; +(which assumes ASCII). + +Fri Jul 12 07:41:30 EDT 1991: + Note added to README about erroneous definitions of __STDC__ . + +Sat Jul 13 13:38:54 EDT 1991: + Fix bugs in double type convesions of complex values, e.g. +sngl(real(...)) or dble(real(...)) (where ... is complex). + +Mon Jul 15 13:21:42 EDT 1991: + Fix bug introduced 8 July 1991 that caused erroneous warnings +"ichar([first char. of] char. string) assumed for conversion to numeric" +when a subroutine had an array of character strings as an argument. + +Wed Aug 28 01:12:17 EDT 1991: + Omit an unused function in format.c, an unused variable in proc.c . + Under -r8, promote complex to double complex (as the man page claims). + +Fri Aug 30 17:19:17 EDT 1991: + f2c.ps updated: slightly expand description of intrinsics and,or,xor, +not; add mention of intrinsics lshift, rshift; add note about f2c +accepting Fortran 90 inline comments (starting with !); update Cobalt +Blue address. + +Tue Sep 17 07:17:33 EDT 1991: + libI77: err.c and open.c modified to use modes "rb" and "wb" +when (f)opening unformatted files; README updated to point out +that it may be necessary to change these modes to "r" and "w" +on some non-ANSI systems. + +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. diff --git a/lang/fortran/comp/.distr b/lang/fortran/comp/.distr new file mode 100644 index 000000000..da90eeac6 --- /dev/null +++ b/lang/fortran/comp/.distr @@ -0,0 +1,60 @@ +Notice +README +cds.c +data.c +defines.h +defs.h +equiv.c +error.c +exec.c +expr.c +f2c.1 +f2c.1t +f2c.6 +f2c.h +format.c +format.h +formatdata.c +ftypes.h +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 +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 +proto.make +put.c +putpcc.c +string.h +sysdep.c +sysdep.h +tokens +usignal.h +vax.c +version.c +xsum.c +xsum0.out diff --git a/lang/fortran/comp/Notice b/lang/fortran/comp/Notice new file mode 100644 index 000000000..ec5f903dc --- /dev/null +++ b/lang/fortran/comp/Notice @@ -0,0 +1,23 @@ +/**************************************************************** +Copyright 1990, 1991 by AT&T Bell Laboratories and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T Bell Laboratories or +Bellcore or any of their entities not be used in advertising or +publicity pertaining to distribution of the software without +specific, written prior permission. + +AT&T and Bellcore disclaim all warranties with regard to this +software, including all implied warranties of merchantability +and fitness. In no event shall AT&T or Bellcore be liable for +any special, indirect or consequential damages or any damages +whatsoever resulting from loss of use, data or profits, whether +in an action of contract, negligence or other tortious action, +arising out of or in connection with the use or performance of +this software. +****************************************************************/ + diff --git a/lang/fortran/comp/README b/lang/fortran/comp/README new file mode 100644 index 000000000..82cc1395c --- /dev/null +++ b/lang/fortran/comp/README @@ -0,0 +1,73 @@ +Type "make" to check the validity of the f2c source and compile f2c. + +If (in accordance with what follows) you need to modify the makefile +or any of the source files, first issue a "make xsum.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 to send you +the files in question "from f2c/src". For example, if exec.c and +expr.c have incorrect check sums, you would send netlib the message + send exec.c expr.c from f2c/src + +On some systems, the malloc and free in malloc.c let f2c run faster +than do the standard malloc and free. Other systems cannot tolerate +redefinition of malloc and free. If yours is such a system, you may +either modify the makefile appropriately, or simply execute + cc -c -DCRAY malloc.c +before typing "make". Still other systems have a -lmalloc that +provides performance competitive with that from malloc.c; you may +wish to compare the two on your system. + +On some BSD systems, you may need to create a file named "string.h" +whose single line is +#include +you may need to add " -Dstrchr=index" to the "CFLAGS =" assignment +in the makefile, and you may need to add " memset.o" to the "OBJECTS =" +assignment in the makefile -- see the comments in memset.c . + +For non-UNIX systems, you may need to change some things in sysdep.c, +such as the choice of intermediate file names. + +On some systems, you may need to modify parts of sysdep.h (which is +included by defs.h). In particular, for Sun 4.1 systems and perhaps +some others, you need to comment out the typedef of size_t. + +Alas, some systems #define __STDC__ but do not provide a true standard +(ANSI or ISO) C environment, e.g. do not provide stdlib.h . If yours +is such a system, then (a) you should complain loudly to your vendor +about __STDC__ being erroneously defined, and (b) you should insert +#undef __STDC__ +at the beginning of sysdep.h . You may need to make other adjustments. + +For some non-ANSI versions of stdio, you must change the values given +to binread and binwrite in sysdep.c from "rb" and "wb" to "r" and "w". +You may need to make this change if you run f2c and get an error +message of the form + Compiler error ... cannot open intermediate file ... + +On many systems, it is best to combine libF77 and libI77 into a single +library, say libf2c, as suggested in "index from f2c". If you do this, +then you should adjust the definition of link_msg in sysdep.c +appropriately (e.g., replacing "-lF77 -lI77" by "-lf2c"). + +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. + +Please send bug reports to dmg@research.att.com . The index file +("send index from f2c") will report recent changes in the recent-change +log at its end; all changes will be shown in the "fixes" file +("send fixes 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/lang/fortran/comp/cds.c b/lang/fortran/comp/cds.c new file mode 100644 index 000000000..d462c853f --- /dev/null +++ b/lang/fortran/comp/cds.c @@ -0,0 +1,178 @@ +/**************************************************************** +Copyright 1990 by AT&T Bell Laboratories and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T Bell Laboratories or +Bellcore or any of their entities not be used in advertising or +publicity pertaining to distribution of the software without +specific, written prior permission. + +AT&T and Bellcore disclaim all warranties with regard to this +software, including all implied warranties of merchantability +and fitness. In no event shall AT&T or Bellcore be liable for +any special, indirect or consequential damages or any damages +whatsoever resulting from loss of use, data or profits, whether +in an action of contract, negligence or other tortious action, +arising out of or in connection with the use or performance of +this software. +****************************************************************/ + +/* 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 "sysdep.h" + + char * +cds(s, z0) + char *s, *z0; +{ + 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; + } + /* debug */ if (c) + /* debug*/ Fatal("unexpected character in cds"); + ex -= ea; + if (!nd) { + if (!z0) + z0 = mem(4,0); + strcpy(z0, "-0."); + sign = 0; + } + else if (ex > 2 || ex + nd < -2) { + sprintf(ebuf, "%ld", ex + nd - 1); + k = strlen(ebuf) + nd + 3; + if (nd > 1) + k++; + if (!z0) + z0 = mem(k,0); + z = z0; + *z++ = '-'; + *z++ = *db; + if (nd > 1) { + *z++ = '.'; + for(k = 1; k < nd; k++) + *z++ = db[k]; + } + *z++ = 'e'; + strcpy(z, ebuf); + } + else { + k = (int)(ex + nd); + i = nd + 3; + if (k < 0) + i -= k; + else if (ex > 0) + i += ex; + if (!z0) + z0 = mem(i,0); + z = z0; + *z++ = '-'; + if (ex >= 0) { + for(k = 0; k < nd; k++) + *z++ = db[k]; + while(--ex >= 0) + *z++ = '0'; + *z++ = '.'; + } + else { + for(i = 0; i < k;) + *z++ = db[i++]; + *z++ = '.'; + while(++k <= 0) + *z++ = '0'; + while(i < nd) + *z++ = db[i++]; + } + *z = 0; + } + return sign ? z0 : z0+1; + } diff --git a/lang/fortran/comp/data.c b/lang/fortran/comp/data.c new file mode 100644 index 000000000..8d64ceb93 --- /dev/null +++ b/lang/fortran/comp/data.c @@ -0,0 +1,436 @@ +/**************************************************************** +Copyright 1990 by AT&T Bell Laboratories and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T Bell Laboratories or +Bellcore or any of their entities not be used in advertising or +publicity pertaining to distribution of the software without +specific, written prior permission. + +AT&T and Bellcore disclaim all warranties with regard to this +software, including all implied warranties of merchantability +and fitness. In no event shall AT&T or Bellcore be liable for +any special, indirect or consequential damages or any damages +whatsoever resulting from loss of use, data or profits, whether +in an action of contract, negligence or other tortious action, +arising out of or in connection with the use or performance of +this software. +****************************************************************/ + +#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 */ +dataval(repp, valp) +register expptr repp, valp; +{ + int i, nrep; + ftnint elen; + register Addrp p; + Addrp nextdata(); + + 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) ) + { + err("non-constant initializer"); + goto ret; + } + + if(toomanyinit) goto ret; + for(i = 0 ; i < nrep ; ++i) + { + p = nextdata(&elen); + if(p == NULL) + { + err("too many initializers"); + toomanyinit = YES; + goto ret; + } + setdata((Addrp)p, (Constp)valp, elen); + frexpr((expptr)p); + } + +ret: + frexpr(valp); +} + + +Addrp nextdata(elenp) +ftnint *elenp; +{ + register struct Impldoblock *ip; + struct Primblock *pp; + register Namep np; + register struct Rplblock *rp; + tagptr p; + expptr neltp; + register expptr q; + int skip; + ftnint off, vlen; + + while(curdtp) + { + p = (tagptr)curdtp->datap; + if(p->tag == TIMPLDO) + { + ip = &(p->impldoblock); + if(ip->implb==NULL || ip->impub==NULL || ip->varnp==NULL) + fatali("bad impldoblock 0%o", (int) ip); + if(ip->isactive) + ip->varvp->Const.ci += ip->impdiff; + else + { + q = fixtype(cpexpr(ip->implb)); + if( ! ISICON(q) ) + goto doerr; + ip->varvp = (Constp) q; + + if(ip->impstep) + { + q = fixtype(cpexpr(ip->impstep)); + if( ! ISICON(q) ) + goto doerr; + ip->impdiff = q->constblock.Const.ci; + frexpr(q); + } + else + ip->impdiff = 1; + + q = fixtype(cpexpr(ip->impub)); + if(! ISICON(q)) + goto doerr; + ip->implim = q->constblock.Const.ci; + frexpr(q); + + ip->isactive = YES; + rp = ALLOC(Rplblock); + rp->rplnextp = rpllist; + rpllist = rp; + rp->rplnp = ip->varnp; + rp->rplvp = (expptr) (ip->varvp); + rp->rpltag = TCONST; + } + + if( (ip->impdiff>0 && (ip->varvp->Const.ci <= ip->implim)) + || (ip->impdiff<0 && (ip->varvp->Const.ci >= ip->implim)) ) + { /* start new loop */ + curdtp = ip->datalist; + goto next; + } + + /* clean up loop */ + + if(rpllist) + { + rp = rpllist; + rpllist = rpllist->rplnextp; + free( (charptr) rp); + } + else + Fatal("rpllist empty"); + + frexpr((expptr)ip->varvp); + ip->isactive = NO; + curdtp = curdtp->nextp; + goto next; + } + + pp = (struct Primblock *) p; + np = pp->namep; + cur_varname = np->fvarname; + skip = YES; + + if(p->primblock.argsp==NULL && np->vdim!=NULL) + { /* array initialization */ + q = (expptr) mkaddr(np); + off = typesize[np->vtype] * curdtelt; + if(np->vtype == TYCHAR) + off *= np->vleng->constblock.Const.ci; + q->addrblock.memoffset = + mkexpr(OPPLUS, q->addrblock.memoffset, mkintcon(off) ); + if( (neltp = np->vdim->nelt) && ISCONST(neltp)) + { + if(++curdtelt < neltp->constblock.Const.ci) + skip = NO; + } + else + err("attempt to initialize adjustable array"); + } + else + q = mklhs( (struct Primblock *)cpexpr((expptr)pp) ); + 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; + + +setdata(varp, valp, elen) +register Addrp varp; +ftnint elen; +register Constp valp; +{ + struct Constblock con; + register int type; + int i, k, valtype; + ftnint offset; + char *dataname(), *varname; + static Addrp badvar; + register unsigned char *s; + static int last_lineno; + static char *last_varname; + + if (varp->vstg == STGCOMMON) { + if (!(dfile = blkdfile)) + dfile = blkdfile = opf(blkdfname, textwrite); + } + else { + if (procclass == CLBLOCK) { + if (varp != badvar) { + badvar = varp; + warn1("%s is not in a COMMON block", + varp->uname_tag == UNAM_NAME + ? varp->user.name->fvarname + : "???"); + } + return; + } + if (!(dfile = initfile)) + dfile = initfile = opf(initfname, textwrite); + } + varname = dataname(varp->vstg, varp->memno); + offset = varp->memoffset->constblock.Const.ci; + type = varp->vtype; + valtype = valp->vtype; + if(type!=TYCHAR && valtype==TYCHAR) + { + if(! ftn66flag + && (last_varname != cur_varname || last_lineno != lineno)) { + /* prevent multiple warnings */ + last_lineno = lineno; + warn1( + "non-character datum %.42s initialized with character string", + last_varname = cur_varname); + } + varp->vleng = ICON(typesize[type]); + varp->vtype = type = TYCHAR; + } + else if( (type==TYCHAR && valtype!=TYCHAR) || + (cktype(OPASSIGN,type,valtype) == TYERROR) ) + { + err("incompatible types in initialization"); + return; + } + if(type == TYADDR) + con.Const.ci = valp->Const.ci; + else if(type != TYCHAR) + { + if(valtype == TYUNKNOWN) + con.Const.ci = valp->Const.ci; + else consconv(type, &con, valp); + } + + k = 1; + + switch(type) + { + case TYLOGICAL: + if (tylogical != TYLONG) + type = tylogical; + case TYSHORT: + case TYLONG: + dataline(varname, offset, type); + prconi(dfile, con.Const.ci); + break; + + case TYADDR: + dataline(varname, offset, type); + prcona(dfile, con.Const.ci); + break; + + case TYCOMPLEX: + case TYDCOMPLEX: + k = 2; + case TYREAL: + case TYDREAL: + dataline(varname, offset, type); + prconr(dfile, &con, k); + break; + + case TYCHAR: + k = valp -> vleng -> constblock.Const.ci; + if (elen < k) + k = elen; + s = (unsigned char *)valp->Const.ccp; + for(i = 0 ; i < k ; ++i) { + dataline(varname, offset++, TYCHAR); + fprintf(dfile, "\t%d\n", *s++); + } + k = elen - valp->vleng->constblock.Const.ci; + if(k > 0) { + dataline(varname, offset, TYBLANK); + fprintf(dfile, "\t%d\n", k); + } + break; + + default: + badtype("setdata", type); + } + +} + + + +/* + output form of name is padded with blanks and preceded + with a storage class digit +*/ +char *dataname(stg,memno) + int stg; + long memno; +{ + static char varname[64]; + register char *s, *t; + char buf[16], *memname(); + + 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); +} + + + + + +frdata(p0) +chainp p0; +{ + 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); +} + + + +dataline(varname, offset, type) +char *varname; +ftnint offset; +int type; +{ + fprintf(dfile, datafmt, varname, offset, type); +} + + void +make_param(p, e) + register struct Paramblock *p; + expptr e; +{ + register expptr q; + + p->vclass = CLPARAM; + impldcl((Namep)p); + p->paramval = q = mkconv(p->vtype, e); + if (p->vtype == TYCHAR) { + if (q->tag == TEXPR) + p->paramval = q = fixexpr(q); + 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/lang/fortran/comp/defines.h b/lang/fortran/comp/defines.h new file mode 100644 index 000000000..8a470f773 --- /dev/null +++ b/lang/fortran/comp/defines.h @@ -0,0 +1,289 @@ +#define PDP11 4 + +#define BIGGEST_SHORT 0x7fff /* Assumes 32-bit arithmetic */ +#define BIGGEST_LONG 0x7fffffff /* Assumes 32-bit arithmetic */ + +#define M(x) (1<tag==TCONST && ISINT(z->constblock.vtype)) + +/* 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) + +/* round a up to the nearest multiple of b: + + a = b * floor ( (a + (b - 1)) / b )*/ + +#define roundup(a,b) ( b * ( (a+b-1)/b) ) diff --git a/lang/fortran/comp/defs.h b/lang/fortran/comp/defs.h new file mode 100644 index 000000000..9ace5575e --- /dev/null +++ b/lang/fortran/comp/defs.h @@ -0,0 +1,769 @@ +/**************************************************************** +Copyright 1990, 1991 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 "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 MAXTOKENLEN 302 /* length of longest token */ +#define MAXCTL 20 +#define MAXHASH 401 +#define MAXSTNO 801 +#define MAXEXT 200 +#define MAXEQUIV 150 +#define MAXLABLIST 125 /* Max number of labels in an alternate + return CALL */ + +/* 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 opf(); +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 char *blkdfname, *initfname, *sortfname; +extern long int 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 toklen; +extern long 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 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 int lastlabno; +extern int lastvarno; +extern int lastargslot; /* integer offset pointing to the next free + location for an argument to the current routine */ +extern int argloc; +extern int autonum[]; /* for numbering + automatic variables, e.g. temporaries */ +extern int retlabel; +extern int ret0label; +extern int dorange; /* Number of the label which terminates + the innermost DO loop */ +extern int regnum[ ]; /* Numbers of DO indicies named in + regnamep (below) */ +extern Namep regnamep[ ]; /* List of DO indicies in registers */ +extern int maxregvar; /* number of elts in regnamep */ +extern int highregvar; /* keeps track of the highest register + number used by DO index allocator */ +extern int nregvar; /* count of DO indicies in registers */ + +extern chainp templist[]; +extern int maxdim; +extern chainp earlylabs; +extern chainp holdtemps; +extern struct Entrypoint *entries; +extern struct Rplblock *rpllist; +extern struct Chain *curdtp; +extern ftnint curdtelt; +extern chainp allargs; /* union of args in entries */ +extern int nallargs; /* total number of args */ +extern int nallchargs; /* total number of character args */ +extern flag toomanyinit; /* True iff too many initializers in a + DATA statement */ + +extern flag inioctl; +extern int iostmt; +extern Addrp ioblkp; +extern int nioctl; +extern int nequiv; +extern int eqvstart; /* offset to eqv number to guarantee uniqueness + and prevent from going negative */ +extern int nintnames; + +/* Chain of tagged blocks */ + +struct Chain + { + chainp nextp; + char * datap; /* Tagged block */ + }; + +extern chainp chains; + +/* Recall that field is intended to hold four-bit characters */ + +/* This structure exists only to defeat the type checking */ + +struct Headblock + { + field tag; + field vtype; + field vclass; + field vstg; + expptr vleng; /* Expression for length of char string - + this may be a constant, or an argument + generated by mkarg() */ + } ; + +/* Control construct info (for do loops, else, etc) */ + +struct Ctlframe + { + unsigned ctltype:8; + unsigned dostepsign:8; /* 0 - variable, 1 - pos, 2 - neg */ + unsigned dowhile:1; + int ctlabels[4]; /* Control labels, defined below */ + int dolabel; /* label marking end of this DO loop */ + Namep donamep; /* DO index variable */ + expptr 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 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; + 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:3; + 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() */ + +/* The vardesc union below is used to store the number of an intrinsic + function (when vstg == STGINTR and vprocclass == PINTRINSIC), or to + store the index of this external symbol in extsymtab (when vstg == + STGEXT and vprocclass == PEXTERNAL) */ + + union { + int varno; /* Return variable for a function. + This is used when a function is + assigned a return value. Also + used to point to the COMMON + block, when this is a field of + that block. Also points to + EQUIV block when STGEQUIV */ + struct Intrpacked intrdesc; /* bits for intrinsic function*/ + } vardesc; + struct Dimblock *vdim; /* points to the dimensions if they exist */ + ftnint voffset; /* offset in a storage block (the variable + name will be "v.%d", voffset in a + common blck on the vax). Also holds + pointers for automatic variables. When + STGEQUIV, this is -(offset from array + base) */ + union { + chainp namelist; /* points to names in the NAMELIST, + if this is a NAMELIST name */ + chainp vstfdesc; /* points to (formals, expr) pair */ + chainp assigned_values; /* list of integers, each being a + statement label assigned to + this variable in the current function */ + } varxptr; + int argno; /* for multiple entries */ + Argtypes *arginfo; + }; + + +/* PARAMETER statements */ + +struct Paramblock + { + field tag; + field vtype; + field vclass; + field vstg; + expptr vleng; + char *fvarname; + char *cvarname; + expptr paramval; + } ; + + +/* Expression block */ + +struct Exprblock + { + field tag; + field vtype; + field vclass; + field vstg; + expptr vleng; /* in the case of a character expression, this + value is inherited from the children */ + unsigned opcode; + expptr leftp; + expptr rightp; + }; + + +union Constant + { + struct { + char *ccp0; + ftnint blanks; + } ccp1; + ftnint ci; /* Constant long integer */ + 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 */ + ftnint varleng; /* holds a copy of a constant length which + is stored in the vleng field (e.g. + a double is 8 bytes) */ + int uname_tag; /* Tag describing which of the unions() + below to use */ + char *Field; /* field name when dereferencing a struct */ +}; /* struct Addrblock */ + + +/* Errorbock - placeholder for errors, to allow the compilation to + continue */ + +struct Errorblock + { + field tag; + field vtype; + }; + + +/* Implicit DO block, especially related to DATA statements. This block + keeps track of the compiler's location in the implicit DO while it's + running. In particular, the isactive and isbusy flags tell where + it is */ + +struct Impldoblock + { + field tag; + unsigned isactive:1; + unsigned isbusy:1; + Namep varnp; + Constp varvp; + chainp impdospec; + expptr implb; + expptr impub; + expptr impstep; + ftnint impdiff; + ftnint implim; + struct Chain *datalist; + }; + + +/* Each of these components has a first field called tag. This union + exists just for allocation simplicity */ + +union Expression + { + field tag; + struct Addrblock addrblock; + struct Constblock constblock; + struct Errorblock errorblock; + struct Exprblock exprblock; + struct Headblock headblock; + struct Impldoblock impldoblock; + struct Listblock listblock; + struct Nameblock nameblock; + struct Paramblock paramblock; + struct Primblock primblock; + } ; + + + +struct Dimblock + { + int ndim; + expptr nelt; /* This is NULL if the array is unbounded */ + expptr baseoffset; /* a constant or local variable holding + the offset in this procedure */ + expptr basexpr; /* expression for comuting the offset, if + it's not constant. If this is + non-null, the register named in + baseoffset will get initialized to this + value in the procedure's prolog */ + struct + { + expptr dimsize; /* constant or register holding the size + of this dimension */ + expptr dimexpr; /* as above in basexpr, this is an + expression for computing a variable + dimension */ + } dims[1]; /* Dimblocks are allocated with enough + space for this to become dims[ndim] */ + }; + + +/* Statement function identifier stack - this holds the name and value of + the parameters in a statement function invocation. For example, + + f(x,y,z)=x+y+z + . + . + y = f(1,2,3) + + generates a stack of depth 3, with , , AT THE INVOCATION, NOT + at the definition */ + +struct Rplblock /* name replacement block */ + { + struct Rplblock *rplnextp; + Namep rplnp; /* Name of the formal parameter */ + expptr rplvp; /* Value of the actual parameter */ + expptr rplxp; /* Initialization of temporary variable, + if required; else null */ + int rpltag; /* Tag on the value of the actual param */ + }; + + + +/* Equivalence block */ + +struct Equivblock + { + struct Eqvchain *equivs; /* List (Eqvchain) of primblocks + holding variable identifiers */ + flag eqvinit; + long int eqvtop; + long int eqvbottom; + int eqvtype; + } ; +#define eqvleng eqvtop + +extern struct Equivblock *eqvclass; + + +struct Eqvchain + { + struct Eqvchain *eqvnextp; + union + { + struct Primblock *eqvlhs; + Namep eqvname; + } eqvitem; + long int 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 litnum; /* numeric part of the assembler + label for this constant value */ + int lituse; /* usage count */ + union { + ftnint litival; + double litdval[2]; + ftnint litival2[2]; /* length, nblanks for strings */ + } litval; + char *cds[2]; + }; + +extern struct Literal *litpool; +extern int maxliterals, nliterals; +extern char Letters[]; +#define letter(x) Letters[x] + +struct Dims { expptr lb, ub; }; + + +/* popular functions with non integer return values */ + + +int *ckalloc(); +char *varstr(), *nounder(), *addunder(); +char *copyn(), *copys(); +chainp hookup(), mkchain(), revchain(); +ftnint convci(); +char *convic(); +char *setdoto(); +double convcd(); +Namep mkname(); +struct Labelblock *mklabel(), *execlab(); +Extsym *mkext(), *newentry(); +expptr addrof(), call1(), call2(), call3(), call4(); +Addrp builtin(), mktmp(), mktmp0(), mktmpn(), autovar(); +Addrp mkplace(), mkaddr(), putconst(), memversion(); +expptr mkprim(), mklhs(), mkexpr(), mkconv(), mkfunct(), fixexpr(), fixtype(); +expptr errnode(), mkaddcon(), mkintcon(), putcxop(); +tagptr cpexpr(); +ftnint lmin(), lmax(), iarrlen(); +char *dbconst(), *flconst(); + +void puteq (), putex1 (); +expptr putx (), putsteq (), putassign (); + +extern int forcedouble; /* force real functions to double */ +extern int doin_setbound; /* special handling for array bounds */ +extern int Ansi; +extern char *cds(), *cpstring(), *dtos(), *string_num(); +extern char *c_type_decl(); +extern char hextoi_tab[]; +#define hextoi(x) hextoi_tab[(x) & 0xff] +extern char *casttypes[], *ftn_types[], *protorettypes[], *usedcasts[]; +extern int Castargs, infertypes; +extern FILE *protofile; +extern void exit(), inferdcl(), protowrite(), save_argtypes(); +extern char binread[], binwrite[], textread[], textwrite[]; +extern char *ei_first, *ei_last, *ei_next; +extern char *wh_first, *wh_last, *wh_next; +extern void putwhile(); +extern char *halign; diff --git a/lang/fortran/comp/equiv.c b/lang/fortran/comp/equiv.c new file mode 100644 index 000000000..65d6a2734 --- /dev/null +++ b/lang/fortran/comp/equiv.c @@ -0,0 +1,372 @@ +/**************************************************************** +Copyright 1990 by AT&T Bell Laboratories and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T Bell Laboratories or +Bellcore or any of their entities not be used in advertising or +publicity pertaining to distribution of the software without +specific, written prior permission. + +AT&T and Bellcore disclaim all warranties with regard to this +software, including all implied warranties of merchantability +and fitness. In no event shall AT&T or Bellcore be liable for +any special, indirect or consequential damages or any damages +whatsoever resulting from loss of use, data or profits, whether +in an action of contract, negligence or other tortious action, +arising out of or in connection with the use or performance of +this software. +****************************************************************/ + +#include "defs.h" + +LOCAL eqvcommon(), eqveqv(), nsubs(); + +/* ROUTINES RELATED TO EQUIVALENCE CLASS PROCESSING */ + +/* called at end of declarations section to process chains + created by EQUIVALENCE statements + */ +doequiv() +{ + 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; + primp = q->eqvitem.eqvlhs; + vardcl(np = primp->namep); + if(primp->argsp || primp->fcharp) + { + expptr offp, suboffset(); + +/* 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->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 eqvcommon(p, comno, comoffset) +struct Equivblock *p; +int comno; +ftnint comoffset; +{ + 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 eqveqv(nvarno, ovarno, delta) +int ovarno, nvarno; +ftnint delta; +{ + 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; +} + + + + +freqchain(p) +register struct Equivblock *p; +{ + 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 nsubs(p) +register struct Listblock *p; +{ + register int n; + register chainp q; + + n = 0; + if(p) + for(q = p->listp ; q ; q = q->nextp) + ++n; + + return(n); +} diff --git a/lang/fortran/comp/error.c b/lang/fortran/comp/error.c new file mode 100644 index 000000000..7877bd7c1 --- /dev/null +++ b/lang/fortran/comp/error.c @@ -0,0 +1,252 @@ +/**************************************************************** +Copyright 1990 by AT&T Bell Laboratories and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T Bell Laboratories or +Bellcore or any of their entities not be used in advertising or +publicity pertaining to distribution of the software without +specific, written prior permission. + +AT&T and Bellcore disclaim all warranties with regard to this +software, including all implied warranties of merchantability +and fitness. In no event shall AT&T or Bellcore be liable for +any special, indirect or consequential damages or any damages +whatsoever resulting from loss of use, data or profits, whether +in an action of contract, negligence or other tortious action, +arising out of or in connection with the use or performance of +this software. +****************************************************************/ + +#include "defs.h" + +warni(s,t) + char *s; + int t; +{ + char buf[100]; + sprintf(buf,s,t); + warn(buf); + } + +warn1(s,t) +char *s, *t; +{ + char buff[100]; + sprintf(buff, s, t); + warn(buff); +} + + +warn(s) +char *s; +{ + 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; +} + + +errstr(s, t) +char *s, *t; +{ + char buff[100]; + sprintf(buff, s, t); + err(buff); +} + + + +erri(s,t) +char *s; +int t; +{ + char buff[100]; + sprintf(buff, s, t); + err(buff); +} + +errl(s,t) +char *s; +long t; +{ + char buff[100]; + sprintf(buff, s, t); + err(buff); +} + + char *err_proc = 0; + +err(s) +char *s; +{ + 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; +} + + +yyerror(s) +char *s; +{ + err(s); +} + + + +dclerr(s, v) +char *s; +Namep v; +{ + char buff[100]; + + if(v) + { + sprintf(buff, "Declaration error for %s: %s", v->fvarname, s); + err(buff); + } + else + errstr("Declaration error %s", s); +} + + + +execerr(s, n) +char *s, *n; +{ + char buf1[100], buf2[100]; + + sprintf(buf1, "Execution error %s", s); + sprintf(buf2, buf1, n); + err(buf2); +} + + +Fatal(t) +char *t; +{ + fprintf(diagfile, "Compiler error line %ld", lineno); + if (infname) + fprintf(diagfile, " of %s", infname); + fprintf(diagfile, ": %s\n", t); + done(3); +} + + + + +fatalstr(t,s) +char *t, *s; +{ + char buff[100]; + sprintf(buff, t, s); + Fatal(buff); +} + + + +fatali(t,d) +char *t; +int d; +{ + char buff[100]; + sprintf(buff, t, d); + Fatal(buff); +} + + + +badthing(thing, r, t) +char *thing, *r; +int t; +{ + char buff[50]; + sprintf(buff, "Impossible %s %d in routine %s", thing, t, r); + Fatal(buff); +} + + + +badop(r, t) +char *r; +int t; +{ + badthing("opcode", r, t); +} + + + +badtag(r, t) +char *r; +int t; +{ + badthing("tag", r, t); +} + + + + + +badstg(r, t) +char *r; +int t; +{ + badthing("storage class", r, t); +} + + + + +badtype(r, t) +char *r; +int t; +{ + badthing("type", r, t); +} + + +many(s, c, n) +char *s, c; +int n; +{ + char buff[250]; + + sprintf(buff, + "Too many %s.\nTable limit now %d.\nTry recompiling using the -N%c%d option\n", + s, n, c, 2*n); + Fatal(buff); +} + + +err66(s) +char *s; +{ + errstr("Fortran 77 feature used: %s", s); + --nerr; +} + + + +errext(s) +char *s; +{ + errstr("F77 compiler extension used: %s", s); + --nerr; +} diff --git a/lang/fortran/comp/exec.c b/lang/fortran/comp/exec.c new file mode 100644 index 000000000..60a38b233 --- /dev/null +++ b/lang/fortran/comp/exec.c @@ -0,0 +1,831 @@ +/**************************************************************** +Copyright 1990 by AT&T Bell Laboratories and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T Bell Laboratories or +Bellcore or any of their entities not be used in advertising or +publicity pertaining to distribution of the software without +specific, written prior permission. + +AT&T and Bellcore disclaim all warranties with regard to this +software, including all implied warranties of merchantability +and fitness. In no event shall AT&T or Bellcore be liable for +any special, indirect or consequential damages or any damages +whatsoever resulting from loss of use, data or profits, whether +in an action of contract, negligence or other tortious action, +arising out of or in connection with the use or performance of +this software. +****************************************************************/ + +#include "defs.h" +#include "p1defs.h" +#include "names.h" + +LOCAL void exar2(), popctl(), pushctl(); + +/* Logical IF codes +*/ + + +exif(p) +expptr p; +{ + pushctl(CTLIF); + putif(p, 0); /* 0 => if, not elseif */ +} + + + +exelif(p) +expptr p; +{ + if (ctlstack->ctltype == CTLIF || ctlstack->ctltype == CTLIFX) + putif(p, 1); /* 1 ==> elseif */ + else + execerr("elseif out of place", CNULL); +} + + + + + +exelse() +{ + 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); + } + + +exendif() +{ + 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); + } + + +new_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 +pushctl(code) + int code; +{ + 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; + ++blklevel; +} + + + LOCAL void +popctl() +{ + if( ctlstack-- < ctls ) + Fatal("control stack empty"); + --blklevel; +} + + + +/* poplab -- update the flags in labeltab */ + +LOCAL poplab() +{ + 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 +*/ + +exgoto(lab) +struct Labelblock *lab; +{ + lab->labused = 1; + p1_goto (lab -> stateno); +} + + + + + + + +exequals(lp, rp) +register struct Primblock *lp; +register expptr rp; +{ + 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) + err("statement function amid executables"); + mkstfunct(lp, rp); + } + else + { + expptr new_lp, new_rp; + + if(parstate < INDATA) + enddcl(); + new_lp = mklhs (lp); + new_rp = fixtype (rp); + puteq(new_lp, new_rp); + } +} + + + +/* Make Statement Function */ + +long laststfcn = -1, thisstno; +int doing_stmtfcn; + +mkstfunct(lp, rp) +struct Primblock *lp; +expptr rp; +{ + 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"); + 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 +mixed_type(np) + Namep np; +{ + char buf[128]; + sprintf(buf, "%s function %.90s invoked as subroutine", + ftn_types[np->vtype], np->fvarname); + warn(buf); + } + + +excall(name, args, nstars, labels) +Namep name; +struct Listblock *args; +int nstars; +struct Labelblock *labels[ ]; +{ + 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) ); + +/* 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); +} + + + +exstop(stop, p) +int stop; +register expptr p; +{ + char *str; + int n; + expptr mkstrcon(); + + if(p) + { + if( ! ISCONST(p) ) + { + execerr("pause/stop argument must be constant", CNULL); + frexpr(p); + p = mkstrcon(0, CNULL); + } + else if( ISINT(p->constblock.vtype) ) + { + str = convic(p->constblock.Const.ci); + n = strlen(str); + if(n > 0) + { + p->constblock.Const.ccp = copyn(n, str); + p->constblock.Const.ccp1.blanks = 0; + p->constblock.vtype = TYCHAR; + p->constblock.vleng = (expptr) ICON(n); + } + else + p = (expptr) mkstrcon(0, CNULL); + } + else if(p->constblock.vtype != TYCHAR) + { + execerr("pause/stop argument must be integer or string", CNULL); + p = (expptr) mkstrcon(0, CNULL); + } + } + else p = (expptr) mkstrcon(0, CNULL); + + { + expptr subr_call; + + subr_call = call1(TYSUBR, (stop ? "s_stop" : "s_paus"), p); + putexpr( subr_call ); + } +} + +/* DO LOOP CODE */ + +#define DOINIT par[0] +#define DOLIMIT par[1] +#define DOINCR par[2] + + +/* Macros for ctlstack -> dostepsign */ + +#define VARSTEP 0 +#define POSSTEP 1 +#define NEGSTEP 2 + + +/* exdo -- generate DO loop code. In the case of a variable increment, + positive increment tests are placed above the body, negative increment + tests are placed below (see enddo() ) */ + +exdo(range, loopname, spec) +int range; /* end label */ +Namep loopname; +chainp spec; /* 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 */ + + 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 { + 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), 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); +} + +exenddo(np) + Namep np; +{ + Namep np1; + int here; + struct Ctlframe *cf; + + if( ctlstack < ctls ) + Fatal("control stack empty"); + here = ctlstack->dolabel; + if (ctlstack->ctltype != CTLDO || here >= 0) { + 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); + } + + +enddo(here) +int here; +{ + 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; + e = ctlstack->dostep; + if (e->tag == TADDR && e->addrblock.istemp) + frtemp((Addrp)e); + else + frexpr(e); + e = ctlstack->domax; + if (e->tag == TADDR && e->addrblock.istemp) + frtemp((Addrp)e); + else + frexpr(e); + } + 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; + } + } +} + +exassign(vname, labelval) + register Namep vname; +struct Labelblock *labelval; +{ + Addrp p; + expptr mkaddcon(); + register Addrp q; + static char nullstr[] = ""; + 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 */ + + if (!labelval->labdefined || !labelval->fmtstring) { + + 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... */ + + fs = labelval->fmtstring; + if (!labelval->labdefined || fs && fs != nullstr) { + extern void fmtname(); + + if (!fs) + labelval->fmtstring = nullstr; + 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 */ + + + +exarif(expr, neglab, zerlab, poslab) +expptr expr; +struct Labelblock *neglab, *zerlab, *poslab; +{ + register int lm, lz, lp; + + lm = neglab->stateno; + lz = zerlab->stateno; + lp = poslab->stateno; + expr = fixtype(expr); + + if( ! ONEOF(expr->headblock.vtype, MSKINT|MSKREAL) ) + { + err("invalid type of arithmetic if expression"); + frexpr(expr); + } + else + { + if (lm == lz && lz == lp) + exgoto (neglab); + else if(lm == lz) + exar2(OPLE, expr, neglab, poslab); + else if(lm == lp) + exar2(OPNE, expr, neglab, zerlab); + else if(lz == lp) + exar2(OPGE, expr, zerlab, neglab); + else { + expptr t; + + if (!addressable (expr)) { + t = (expptr) mktmp(expr -> headblock.vtype, ENULL); + expr = mkexpr (OPASSIGN, cpexpr (t), expr); + } else + t = (expptr) cpexpr (expr); + + p1_if(putx(fixtype(mkexpr (OPLT, expr, ICON (0))))); + exgoto(neglab); + p1_elif (mkexpr (OPEQ, t, ICON (0))); + exgoto(zerlab); + p1_else (); + exgoto(poslab); + p1else_end (); + } /* else */ + } +} + + + +/* exar2 -- Do arithmetic IF for only 2 distinct labels; if !(e.op.0) + goto l2 else goto l1. If this seems backwards, that's because it is, + in order to make the 1 pass algorithm work. */ + + LOCAL void +exar2(op, e, l1, l2) + int op; + expptr e; + struct Labelblock *l1, *l2; +{ + 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 */ + +exreturn(p) +register expptr p; +{ + 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); +} + + +exasgoto(labvar) +Namep labvar; +{ + register Addrp p; + void p1_asgoto(); + + p = mkplace(labvar); + if( ! ISINT(p->vtype) ) + err("assigned goto variable must be integer"); + else { + p1_asgoto (p); + } /* else */ +} diff --git a/lang/fortran/comp/expr.c b/lang/fortran/comp/expr.c new file mode 100644 index 000000000..3b0939959 --- /dev/null +++ b/lang/fortran/comp/expr.c @@ -0,0 +1,2882 @@ +/**************************************************************** +Copyright 1990, 1991 by AT&T Bell Laboratories and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T Bell Laboratories or +Bellcore or any of their entities not be used in advertising or +publicity pertaining to distribution of the software without +specific, written prior permission. + +AT&T and Bellcore disclaim all warranties with regard to this +software, including all implied warranties of merchantability +and fitness. In no event shall AT&T or Bellcore be liable for +any special, indirect or consequential damages or any damages +whatsoever resulting from loss of use, data or profits, whether +in an action of contract, negligence or other tortious action, +arising out of or in connection with the use or performance of +this software. +****************************************************************/ + +#include "defs.h" +#include "output.h" +#include "names.h" + +LOCAL void conspower(), consbinop(), zdiv(); +LOCAL expptr fold(), mkpower(), stfcall(); +#ifndef stfcall_MAX +#define stfcall_MAX 144 +#endif + +typedef struct { double dreal, dimag; } dcomplex; + +extern char dflttype[26]; + +/* little routines to create constant blocks */ + +Constp mkconst(t) +register int t; +{ + register Constp p; + + p = ALLOC(Constblock); + p->tag = TCONST; + p->vtype = t; + return(p); +} + + +/* mklogcon -- Make Logical Constant */ + +expptr mklogcon(l) +register int l; +{ + register Constp p; + + p = mkconst(TYLOGICAL); + p->Const.ci = l; + return( (expptr) p ); +} + + + +/* mkintcon -- Make Integer Constant */ + +expptr mkintcon(l) +ftnint l; +{ + register Constp p; + + p = mkconst(tyint); + p->Const.ci = l; + return( (expptr) p ); +} + + + + +/* mkaddcon -- Make Address Constant, given integer value */ + +expptr mkaddcon(l) +register long l; +{ + register Constp p; + + p = mkconst(TYADDR); + p->Const.ci = l; + return( (expptr) p ); +} + + + +/* mkrealcon -- Make Real Constant. The type t is assumed + to be TYREAL or TYDREAL */ + +expptr mkrealcon(t, d) + register int t; + char *d; +{ + register Constp p; + + p = mkconst(t); + p->Const.cds[0] = cds(d,CNULL); + p->vstg = 1; + return( (expptr) p ); +} + + +/* mkbitcon -- Make bit constant. Reads the input string, which is + assumed to correctly specify a number in base 2^shift (where shift + is the input parameter). shift may not exceed 4, i.e. only binary, + quad, octal and hex bases may be input. Constants may not exceed 32 + bits, or whatever the size of (struct Constblock).ci may be. */ + +expptr mkbitcon(shift, leng, s) +int shift; +int leng; +char *s; +{ + register Constp p; + register long x; + + p = mkconst(TYLONG); + x = 0; + while(--leng >= 0) + if(*s != ' ') + x = (x << shift) | hextoi(*s++); + /* mwm wanted to change the type to short for short constants, + * but this is dangerous -- there is no syntax for long constants + * with small values. + */ + p->Const.ci = x; + return( (expptr) p ); +} + + + + + +/* mkstrcon -- Make string constant. Allocates storage and initializes + the memory for a copy of the input Fortran-string. */ + +expptr mkstrcon(l,v) +int l; +register char *v; +{ + register Constp p; + register char *s; + + p = mkconst(TYCHAR); + p->vleng = ICON(l); + p->Const.ccp = s = (char *) ckalloc(l+1); + p->Const.ccp1.blanks = 0; + while(--l >= 0) + *s++ = *v++; + *s = '\0'; + return( (expptr) p ); +} + + + +/* mkcxcon -- Make complex contsant. A complex number is a pair of + values, each of which may be integer, real or double. */ + +expptr mkcxcon(realp,imagp) +register expptr realp, imagp; +{ + int rtype, itype; + register Constp p; + expptr errnode(); + + 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() +{ + 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 mkconv(t, p) +register int t; +register expptr p; +{ + register expptr q; + register int pt, charwarn = 1; + expptr opconv(); + + 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) + { + 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 ); + frexpr(p); + } + else { + if (pt == TYCHAR && t != TYADDR && charwarn) + 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 opconv(p, t) +expptr p; +int t; +{ + register expptr q; + + if (t == TYSUBR) + err("illegal use of subroutine name"); + q = mkexpr(OPCONV, p, ENULL); + q->headblock.vtype = t; + return(q); +} + + + +/* addrof -- Create an ADDR expression operation */ + +expptr addrof(p) +expptr p; +{ + return( mkexpr(OPADDR, p, ENULL) ); +} + + + +/* cpexpr - Returns a new copy of input expression p */ + +tagptr cpexpr(p) +register tagptr p; +{ + register tagptr e; + int tag; + register chainp ep, pp; + tagptr cpblock(); + +/* 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 */ + +frexpr(p) +register tagptr p; +{ + register chainp q; + + if(p == NULL) + return; + + switch(p->tag) + { + case TCONST: + if( ISCHAR(p) ) + { + free( (charptr) (p->constblock.Const.ccp) ); + frexpr(p->constblock.vleng); + } + break; + + case TADDR: + if (p->addrblock.vtype > TYERROR) /* i/o block */ + break; + frexpr(p->addrblock.vleng); + frexpr(p->addrblock.memoffset); + break; + + case TERROR: + break; + +/* TNAME blocks don't get free'd - probably because they're pointed to in + the hash table. 14-Jun-88 -- mwm */ + + case TNAME: + return; + + case TPRIM: + frexpr((expptr)p->primblock.argsp); + frexpr(p->primblock.fcharp); + frexpr(p->primblock.lcharp); + break; + + case TEXPR: + frexpr(p->exprblock.leftp); + if(p->exprblock.rightp) + frexpr(p->exprblock.rightp); + break; + + case TLIST: + for(q = p->listblock.listp ; q ; q = q->nextp) + frexpr((tagptr)q->datap); + frchain( &(p->listblock.listp) ); + break; + + default: + badtag("frexpr", p->tag); + } + + free( (charptr) p ); +} + + void +wronginf(np) + Namep np; +{ + int c, k; + warn1("fixing wrong type inferred for %.65s", np->fvarname); + np->vinftype = 0; + c = letter(np->fvarname[0]); + if ((np->vtype = impltype[c]) == TYCHAR + && (k = implleng[c])) + np->vleng = ICON(k); + } + +/* fix up types in expression; replace subtrees and convert + names to address blocks */ + +expptr fixtype(p) +register tagptr p; +{ + + 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: + 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) ); + } +} + + + static expptr +cplenexpr(p) + expptr p; +{ + expptr rv; + + 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 fixexpr(p) +register Exprp p; +{ + expptr lp; + register expptr rp; + register expptr q; + int opcode, ltype, rtype, ptype, mtype; + + if( ISERROR(p) ) + 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"); + 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) + { + frexpr((expptr)p); + return( errnode() ); + } + +/* 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(p); + return(q); + } + free( (charptr) q ); /* constants did not fold */ + } + + if( (ptype = cktype(opcode, ltype, rtype)) == TYERROR) + { + frexpr((expptr)p); + return( errnode() ); + } + + if (ltype == TYCHAR && ISCONST(lp)) + p->leftp = lp = (expptr)putconst((Constp)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) + break; + case OPPLUSEQ: + case OPSTAREQ: + if(ltype == rtype) + break; + if( ! ISCONST(rp) && ISREAL(ltype) && ISREAL(rtype) ) + break; + if( ISCOMPLEX(ltype) || ISCOMPLEX(rtype) ) + break; + if( ONEOF(ltype, MSKADDR|MSKINT) && ONEOF(rtype, MSKADDR|MSKINT) + && typesize[ltype]>=typesize[rtype] ) + break; + +/* Cast the right hand side to match the type of the expression */ + + p->rightp = fixtype( mkconv(ptype, rp) ); + break; + + case OPSLASH: + if( ISCOMPLEX(rtype) ) + { + p = (Exprp) call2(ptype, + +/* Handle double precision complex variables */ + + ptype == TYCOMPLEX ? "c_div" : "z_div", + mkconv(ptype, lp), mkconv(ptype, rp) ); + break; + } + case OPPLUS: + case OPMINUS: + case OPSTAR: + case OPMOD: + if(ptype==TYDREAL && ( (ltype==TYREAL && ! ISCONST(lp) ) || + (rtype==TYREAL && ! ISCONST(rp) ) )) + break; + if( ISCOMPLEX(ptype) ) + break; + +/* Cast both sides of the expression to match the type of the whole + expression. */ + + if(ltype != ptype && (ltype < TYSHORT || ptype > TYDREAL)) + p->leftp = fixtype(mkconv(ptype,lp)); + if(rtype != ptype && (rtype < TYSHORT || ptype > TYDREAL)) + p->rightp = fixtype(mkconv(ptype,rp)); + break; + + case OPPOWER: + return( mkpower((expptr)p) ); + + case OPLT: + case OPLE: + case OPGT: + case OPGE: + case OPEQ: + case OPNE: + if(ltype == rtype) + break; + mtype = cktype(OPMINUS, ltype, rtype); + if(mtype==TYDREAL && ( (ltype==TYREAL && ! ISCONST(lp)) || + (rtype==TYREAL && ! ISCONST(rp)) )) + 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) + { + 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; + return((expptr) p); +} + + +/* fix an argument list, taking due care for special first level cases */ + +fixargs(doput, p0) +int doput; /* doput is true if constants need to be passed by reference */ +struct Listblock *p0; +{ + register chainp p; + register tagptr q, t; + register int qtag; + int nargs; + Addrp mkscalar(); + + 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; + } + +/* Take a function name and turn it into an Addr. This only happens when + nothing else has figured out the function beforehand */ + + else if(qtag==TPRIM && q->primblock.argsp==0 && + q->primblock.namep->vclass==CLPROC && + q->primblock.namep->vprocclass != PTHISPROC) + p->datap = (char *)mkaddr(q->primblock.namep); + + else if(qtag==TPRIM && q->primblock.argsp==0 && + q->primblock.namep->vdim!=NULL) + p->datap = (char *)mkscalar(q->primblock.namep); + + else if(qtag==TPRIM && q->primblock.argsp==0 && + q->primblock.namep->vdovar && + (t = (tagptr) memversion(q->primblock.namep)) ) + p->datap = (char *)fixtype(t); + else + p->datap = (char *)fixtype(q); + } + return(nargs); +} + + + +/* mkscalar -- only called by fixargs above, and by some routines in + io.c */ + +Addrp mkscalar(np) +register Namep np; +{ + register Addrp ap; + + vardcl(np); + ap = mkaddr(np); + + /* The prolog causes array arguments to point to the + * (0,...,0) element, unless subscript checking is on. + */ + if( !checksubs && np->vstg==STGARG) + { + register struct Dimblock *dp; + dp = np->vdim; + frexpr(ap->memoffset); + ap->memoffset = mkexpr(OPSTAR, + (np->vtype==TYCHAR ? + cpexpr(np->vleng) : + (tagptr)ICON(typesize[np->vtype]) ), + cpexpr(dp->baseoffset) ); + } + return(ap); +} + + + static void +adjust_arginfo(np) /* adjust arginfo to omit the length arg for the + arg that we now know to be a character-valued + function */ + register Namep np; +{ + struct Entrypoint *ep; + register chainp args; + 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 mkfunct(p0) + expptr p0; +{ + register struct Primblock *p = (struct Primblock *)p0; + struct Entrypoint *ep; + Addrp ap; + Extsym *extp; + register Namep np; + register expptr q; + expptr intrcall(); + extern chainp new_procs; + int k, nargs; + int class; + + if(p->tag != TPRIM) + return( errnode() ); + + np = p->namep; + class = np->vclass; + + + if(class == CLUNKNOWN) + { + np->vclass = class = CLPROC; + if(np->vstg == STGUNKNOWN) + { + if(np->vtype!=TYSUBR && (k = intrfunct(np->fvarname)) + && (zflag || !(*(struct Intrpacked *)&k).f4 + || dcomplex_seen)) + { + np->vstg = STGINTR; + np->vardesc.varno = k; + np->vprocclass = PINTRINSIC; + } + else + { + extp = mkext(np->fvarname, + addunder(np->cvarname)); + extp->extstg = STGEXT; + np->vstg = STGEXT; + np->vardesc.varno = extp - extsymtab; + np->vprocclass = PEXTERNAL; + } + } + else if(np->vstg==STGARG) + { + if(np->vtype == TYCHAR) { + adjust_arginfo(np); + if (np->vpassed) { + char wbuf[160], *who; + who = np->fvarname; + sprintf(wbuf, "%s%s%s\n\t%s%s%s", + "Character-valued dummy procedure ", + who, " not declared EXTERNAL.", + "Code may be wrong for previous function calls having ", + who, " as a parameter."); + warn(wbuf); + } + } + np->vprocclass = PEXTERNAL; + } + } + + if(class != CLPROC) + fatali("invalid class code %d for function", class); + +/* 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() ); +} + + + +LOCAL expptr stfcall(np, actlist) +Namep np; +struct Listblock *actlist; +{ + register chainp actuals; + int nargs; + chainp oactp, formals; + int type; + expptr Ln, Lq, q, q1, rhs, ap; + Namep tnp; + register struct Rplblock *rp; + struct Rplblock *tlist; + static int inv_count; + + if (++inv_count > stfcall_MAX) + Fatal("Loop invoking recursive statement function?"); + 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) + { + rp = ALLOC(Rplblock); + rp->rplnp = tnp = (Namep) formals->datap; + 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; + } + frchain( &oactp ); + --inv_count; + 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 mkplace(np) +register Namep np; +{ + register Addrp s; + register struct Rplblock *rp; + int regn; + + /* is name on the replace list? */ + + for(rp = rpllist ; rp ; rp = rp->rplnextp) + { + if(np == rp->rplnp) + { + replaced = 1; + if(rp->rpltag == TNAME) + { + np = (Namep) (rp->rplvp); + break; + } + else return( (Addrp) cpexpr(rp->rplvp) ); + } + } + + /* is variable a DO index in a register ? */ + + if(np->vdovar && ( (regn = inregister(np)) >= 0) ) + if(np->vtype == TYERROR) + return((Addrp) errnode() ); + else + { + s = ALLOC(Addrblock); + s->tag = TADDR; + s->vstg = STGREG; + s->vtype = TYIREG; + s->memno = regn; + s->memoffset = ICON(0); + s -> uname_tag = UNAM_NAME; + s -> user.name = np; + return(s); + } + + vardcl(np); + return(mkaddr(np)); +} + + + 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 mklhs(p) +register struct Primblock *p; +{ + expptr suboffset(); + register Addrp s; + Namep np; + + if(p->tag != TPRIM) + return( (expptr) p ); + np = p->namep; + + replaced = 0; + s = mkplace(np); + if(s->tag!=TADDR || s->vstg==STGREG) + { + free( (charptr) p ); + return( (expptr) s ); + } + + /* compute the address modified by subscripts */ + + if (!replaced) + s->memoffset = 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) + errstr("substring of noncharacter %s", np->fvarname); + else { + if(p->lcharp == NULL) + p->lcharp = (expptr) cpexpr(s->vleng); + if(p->fcharp) { + doing_vleng = 1; + s->vleng = fixtype(mkexpr(OPMINUS, + p->lcharp, + mkexpr(OPMINUS, p->fcharp, ICON(1) ))); + doing_vleng = 0; + } + else { + frexpr(s->vleng); + s->vleng = p->lcharp; + } + } + } + + s->vleng = fixtype( s->vleng ); + s->memoffset = fixtype( s->memoffset ); + free( (charptr) p ); + return( (expptr) s ); +} + + + + + +/* deregister -- remove a register allocation from the list; assumes that + names are deregistered in stack order (LIFO order - Last In First Out) */ + +deregister(np) +Namep np; +{ + 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 memversion(np) +register Namep np; +{ + register Addrp s; + + if(np->vdovar==NO || (inregister(np)<0) ) + return(NULL); + np->vdovar = NO; + s = mkplace(np); + np->vdovar = YES; + return(s); +} + + + +/* inregister -- looks for the input name in the global list regnamep */ + +inregister(np) +register Namep np; +{ + register int i; + + for(i = 0 ; i < nregvar ; ++i) + if(regnamep[i] == np) + return( regnum[i] ); + return(-1); +} + + + +/* suboffset -- Compute the offset from the start of the array, given the + subscripts as arguments */ + +expptr suboffset(p) +register struct Primblock *p; +{ + int n; + expptr si, size; + chainp cp; + expptr e, e1, offp, prod; + expptr subcheck(); + struct Dimblock *dimp; + expptr sub[MAXDIM+1]; + register Namep np; + + np = p->namep; + offp = ICON(0); + n = 0; + if(p->argsp) + for(cp = p->argsp->listp ; cp ; cp = cp->nextp) + { + si = fixtype(cpexpr((tagptr)cp->datap)); + if (!ISINT(si->headblock.vtype)) { + NOEXT("non-integer subscript"); + si = mkconv(TYLONG, si); + } + sub[n++] = si; + if(n > maxdim) + { + erri("more than %d subscripts", maxdim); + break; + } + } + + dimp = np->vdim; + if(n>0 && dimp==NULL) + errstr("subscripts on scalar variable %.68s", np->fvarname); + else if(dimp && dimp->ndim!=n) + errstr("wrong number of subscripts on %.68s", np->fvarname); + else if(n > 0) + { + prod = sub[--n]; + while( --n >= 0) + prod = mkexpr(OPPLUS, sub[n], + mkexpr(OPSTAR, prod, cpexpr(dimp->dims[n].dimsize)) ); + if(checksubs || np->vstg!=STGARG) + prod = mkexpr(OPMINUS, prod, cpexpr(dimp->baseoffset)); + +/* Add in the run-time bounds check */ + + if(checksubs) + prod = subcheck(np, prod); + size = np->vtype == TYCHAR ? + (expptr) cpexpr(np->vleng) : ICON(typesize[np->vtype]); + prod = mkexpr(OPSTAR, prod, size); + offp = mkexpr(OPPLUS, offp, prod); + } + +/* Check for substring indicator */ + + if(p->fcharp && np->vtype==TYCHAR) { + e = p->fcharp; + e1 = mkexpr(OPMINUS, cpexpr(e), ICON(1)); + if (!ISCONST(e) && (e->tag != TPRIM || e->primblock.argsp)) { + e = (expptr)mktmp(TYLONG, ENULL); + putout(putassign(cpexpr(e), e1)); + p->fcharp = mkexpr(OPPLUS, cpexpr(e), ICON(1)); + e1 = e; + } + offp = mkexpr(OPPLUS, offp, e1); + } + return(offp); +} + + + + +expptr subcheck(np, p) +Namep np; +register expptr p; +{ + struct Dimblock *dimp; + expptr t, checkvar, checkcond, badcall; + + dimp = np->vdim; + if(dimp->nelt == NULL) + return(p); /* don't check arrays with * bounds */ + np->vlastdim = 0; + if( ISICON(p) ) + { + +/* check for negative (constant) offset */ + + if(p->constblock.Const.ci < 0) + goto badsub; + if( ISICON(dimp->nelt) ) + +/* see if constant offset exceeds the array declaration */ + + if(p->constblock.Const.ci < dimp->nelt->constblock.Const.ci) + return(p); + else + goto badsub; + } + +/* We know that the subscript offset p or dimp -> nelt is not a constant. + Now find a register to use for run-time bounds checking */ + + if(p->tag==TADDR && p->addrblock.vstg==STGREG) + { + checkvar = (expptr) cpexpr(p); + t = p; + } + else { + checkvar = (expptr) mktmp(p->headblock.vtype, ENULL); + t = mkexpr(OPASSIGN, cpexpr(checkvar), p); + } + checkcond = mkexpr(OPLT, t, cpexpr(dimp->nelt) ); + if( ! ISICON(p) ) + checkcond = mkexpr(OPAND, checkcond, + mkexpr(OPLE, ICON(0), cpexpr(checkvar)) ); + +/* Construct the actual test */ + + badcall = call4(p->headblock.vtype, "s_rnge", + mkstrcon(strlen(np->fvarname), np->fvarname), + mkconv(TYLONG, cpexpr(checkvar)), + mkstrcon(strlen(procname), procname), + ICON(lineno) ); + badcall->exprblock.opcode = OPCCALL; + p = mkexpr(OPQUEST, checkcond, + mkexpr(OPCOLON, checkvar, badcall)); + + return(p); + +badsub: + frexpr(p); + errstr("subscript on variable %s out of range", np->fvarname); + return ( ICON(0) ); +} + + + + +Addrp mkaddr(p) +register Namep p; +{ + Extsym *extp; + register Addrp t; + Addrp intraddr(); + 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)); + } + 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 mkarg(type, argno) +int type, argno; +{ + register Addrp p; + + p = ALLOC(Addrblock); + p->tag = TADDR; + p->vtype = type; + p->vclass = CLVAR; + +/* TYLENG is the type of the field holding the length of a character string */ + + p->vstg = (type==TYLENG ? STGLENG : STGARG); + p->memno = argno; + return(p); +} + + + + +/* mkprim -- Create a PRIM (primary/primitive) block consisting of a + Nameblock (or Paramblock), arguments (actual params or array + subscripts) and substring bounds. Requires that v have lots of + extra (uninitialized) storage, since it could be a paramblock or + nameblock */ + +expptr mkprim(v0, args, substr) + Namep v0; + struct Listblock *args; + chainp substr; +{ + typedef union { + struct Paramblock paramblock; + struct Nameblock nameblock; + struct Headblock headblock; + } *Primu; + register Primu v = (Primu)v0; + register struct Primblock *p; + + if(v->headblock.vclass == CLPARAM) + { + +/* v is to be a Paramblock */ + + if(args || substr) + { + errstr("no qualifiers on parameter name %s", + v->paramblock.fvarname); + frexpr((expptr)args); + if(substr) + { + frexpr((tagptr)substr->datap); + frexpr((tagptr)substr->nextp->datap); + frchain(&substr); + } + frexpr((expptr)v); + return( errnode() ); + } + return( (expptr) cpexpr(v->paramblock.paramval) ); + } + + p = ALLOC(Primblock); + p->tag = TPRIM; + p->vtype = v->nameblock.vtype; + +/* v is to be a Nameblock */ + + p->namep = (Namep) v; + p->argsp = args; + if(substr) + { + p->fcharp = (expptr) substr->datap; + p->lcharp = (expptr) substr->nextp->datap; + frchain(&substr); + } + return( (expptr) p); +} + + + +/* vardcl -- attempt to fill out the Name template for variable v. + This function is called on identifiers known to be variables or + recursive references to the same function */ + +vardcl(v) +register Namep v; +{ + 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 */ + +impldcl(p) +register Namep p; +{ + register int k; + int type; + ftnint leng; + + if(p->vdcldone || (p->vclass==CLPROC && p->vprocclass==PINTRINSIC) ) + return; + if(p->vtype == TYUNKNOWN) + { + k = letter(p->fvarname[0]); + type = impltype[ k ]; + leng = implleng[ k ]; + if(type == TYUNKNOWN) + { + if(p->vclass == CLPROC) + return; + dclerr("attempt to use undefined variable", p); + type = dflttype[k]; + leng = 0; + } + settype(p, type, leng); + p->vimpltype = 1; + } +} + + void +inferdcl(np,type) + Namep np; + int type; +{ + 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; + } + + +#define ICONEQ(z, c) (ISICON(z) && z->constblock.Const.ci==c) +#define COMMUTE { e = lp; lp = rp; rp = e; } + + + +/* mkexpr -- Make expression, and simplify constant subcomponents (tree + order is not preserved). Assumes that lp is nonempty, and uses + fold() to simplify adjacent constants */ + +expptr mkexpr(opcode, lp, rp) +int opcode; +register expptr lp, rp; +{ + register expptr e, e1; + int etype; + int ltype, rtype; + int ltag, rtag; + long L; + + ltype = lp->headblock.vtype; + ltag = lp->tag; + if(rp && opcode!=OPCALL && opcode!=OPCCALL) + { + rtype = rp->headblock.vtype; + rtag = rp->tag; + } + else rtype = 0; + + etype = cktype(opcode, ltype, rtype); + if(etype == TYERROR) + goto error; + + switch(opcode) + { + /* check for multiplication by 0 and 1 and addition to 0 */ + + case OPSTAR: + if( ISCONST(lp) ) + COMMUTE + + if( ISICON(rp) ) + { + if(rp->constblock.Const.ci == 0) + goto retright; + goto mulop; + } + break; + + case OPSLASH: + case OPMOD: + if( ICONEQ(rp, 0) ) + { + err("attempted division by zero"); + rp = ICON(1); + break; + } + 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 (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 OPLT: + case OPGT: + case OPLE: + case OPGE: + case OPEQ: + case OPNE: + + case OPCONCAT: + break; + case OPMIN: + case OPMAX: + case OPMIN2: + case OPMAX2: + case OPDMIN: + case OPDMAX: + + case OPASSIGN: + case OPASSIGNI: + case OPPLUSEQ: + case OPSTAREQ: + case OPMINUSEQ: + case OPSLASHEQ: + case OPMODEQ: + case OPLSHIFTEQ: + case OPRSHIFTEQ: + case OPBITANDEQ: + case OPBITXOREQ: + case OPBITOREQ: + + case OPCONV: + case OPADDR: + case OPWHATSIN: + + case OPCOMMA: + case OPCOMMA_ARG: + case OPQUEST: + case OPCOLON: + case OPDOT: + case OPARROW: + case OPIDENTITY: + case OPCHARCAST: + case OPABS: + case OPDABS: + break; + + default: + badop("mkexpr", opcode); + } + + e = (expptr) ALLOC(Exprblock); + e->exprblock.tag = TEXPR; + e->exprblock.opcode = opcode; + e->exprblock.vtype = etype; + e->exprblock.leftp = lp; + e->exprblock.rightp = rp; + if(ltag==TCONST && (rp==0 || rtag==TCONST) ) + e = fold(e); + return(e); + +retleft: + frexpr(rp); + return(lp); + +retright: + frexpr(lp); + 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 */ + +cktype(op, lt, rt) +register int op, lt, rt; +{ + 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(lt == TYLOGICAL) + return(TYLOGICAL); + ERR("NOT of nonlogical") + + case OPAND: + case OPOR: + case OPEQV: + case OPNEQV: + if(lt==TYLOGICAL && rt==TYLOGICAL) + return(TYLOGICAL); + ERR("nonlogical operand of logical operator") + + case OPLT: + case OPGT: + case OPLE: + case OPGE: + case OPEQ: + case OPNE: + if(lt==TYCHAR || rt==TYCHAR || lt==TYLOGICAL || rt==TYLOGICAL) + { + if(lt != rt) + 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") + 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); + case OPASSIGN: + case OPASSIGNI: + case OPMINUSEQ: + case OPPLUSEQ: + case OPSTAREQ: + case OPSLASHEQ: + case OPMODEQ: + case OPLSHIFTEQ: + case OPRSHIFTEQ: + case OPBITANDEQ: + case OPBITXOREQ: + case OPBITOREQ: + if( ISINT(lt) && rt==TYCHAR) + return(lt); + if(lt==TYCHAR || rt==TYCHAR || lt==TYLOGICAL || rt==TYLOGICAL) + 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 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); + break; + default: + badop("cktype", op); + } +error: + err(errs); +error1: + return(TYERROR); +} + +/* fold -- simplifies constant expressions; it assumes that e -> leftp and + e -> rightp are TCONST or NULL */ + + LOCAL expptr +fold(e) + register expptr e; +{ + Constp p; + register expptr lp, rp; + int etype, mtype, ltype, rtype, opcode; + int i, bl, ll, lr; + char *q, *s; + struct Constblock lcon, rcon; + long L; + double d; + + opcode = e->exprblock.opcode; + etype = e->exprblock.vtype; + + lp = e->exprblock.leftp; + ltype = lp->headblock.vtype; + rp = e->exprblock.rightp; + + if(rp == 0) + switch(opcode) + { + case OPNOT: + lp->constblock.Const.ci = ! lp->constblock.Const.ci; + retlp: + e->exprblock.leftp = 0; + frexpr(e); + return(lp); + + case OPBITNOT: + lp->constblock.Const.ci = ~ lp->constblock.Const.ci; + goto retlp; + + case OPNEG: + case OPNEG1: + consnegop((Constp)lp); + goto retlp; + + case OPCONV: + case OPADDR: + return(e); + + case OPABS: + case OPDABS: + switch(ltype) { + case TYSHORT: + case TYLONG: + if ((L = lp->constblock.Const.ci) < 0) + lp->constblock.Const.ci = -L; + goto retlp; + case TYREAL: + case TYDREAL: + if (lp->constblock.vstg) { + s = lp->constblock.Const.cds[0]; + if (*s == '-') + lp->constblock.Const.cds[0] = s + 1; + goto retlp; + } + if ((d = lp->constblock.Const.cd[0]) < 0.) + lp->constblock.Const.cd[0] = -d; + case TYCOMPLEX: + case TYDCOMPLEX: + return e; /* lazy way out */ + } + default: + badop("fold", opcode); + } + + rtype = rp->headblock.vtype; + + p = ALLOC(Constblock); + p->tag = TCONST; + p->vtype = etype; + p->vleng = e->exprblock.vleng; + + switch(opcode) + { + case OPCOMMA: + case OPCOMMA_ARG: + case OPQUEST: + case OPCOLON: + return(e); + + case OPAND: + p->Const.ci = lp->constblock.Const.ci && + rp->constblock.Const.ci; + break; + + case OPOR: + p->Const.ci = lp->constblock.Const.ci || + rp->constblock.Const.ci; + break; + + case OPEQV: + p->Const.ci = lp->constblock.Const.ci == + rp->constblock.Const.ci; + break; + + case OPNEQV: + p->Const.ci = lp->constblock.Const.ci != + rp->constblock.Const.ci; + break; + + case OPBITAND: + p->Const.ci = lp->constblock.Const.ci & + rp->constblock.Const.ci; + break; + + case OPBITOR: + p->Const.ci = lp->constblock.Const.ci | + rp->constblock.Const.ci; + break; + + case OPBITXOR: + p->Const.ci = lp->constblock.Const.ci ^ + rp->constblock.Const.ci; + break; + + case OPLSHIFT: + p->Const.ci = lp->constblock.Const.ci << + rp->constblock.Const.ci; + break; + + case OPRSHIFT: + p->Const.ci = lp->constblock.Const.ci >> + 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) ) + return(e); + conspower(p, (Constp)lp, rp->constblock.Const.ci); + 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 ); +} + + + +/* assign constant l = r , doing coercion */ + +consconv(lt, lc, rc) + int lt; + register Constp lc, rc; +{ + int rt = rc->vtype; + register union Constant *lv = &lc->Const, *rv = &rc->Const; + + lc->vtype = lt; + if (ONEOF(lt, MSKREAL|MSKCOMPLEX) && ONEOF(rt, MSKREAL|MSKCOMPLEX)) { + memcpy((char *)lv, (char *)rv, sizeof(union Constant)); + lc->vstg = rc->vstg; + if (ISCOMPLEX(lt) && ISREAL(rt)) { + if (rc->vstg) + lv->cds[1] = cds("0",CNULL); + else + lv->cd[1] = 0.; + } + return; + } + lc->vstg = 0; + + switch(lt) + { + +/* Casting to character means just copying the first sizeof (character) + bytes into a new 1 character string. This is weird. */ + + case TYCHAR: + *(lv->ccp = (char *) ckalloc(1)) = rv->ci; + lv->ccp1.blanks = 0; + break; + + case TYSHORT: + case TYLONG: + if(rt == TYCHAR) + lv->ci = rv->ccp[0]; + else if( ISINT(rt) ) + lv->ci = rv->ci; + else lv->ci = rc->vstg ? atof(rv->cds[0]) : rv->cd[0]; + + break; + + case TYCOMPLEX: + case TYDCOMPLEX: + lv->cd[1] = 0.; + lv->cd[0] = rv->ci; + break; + + case TYREAL: + case TYDREAL: + lv->cd[0] = rv->ci; + break; + + case TYLOGICAL: + lv->ci = rv->ci; + break; + } +} + + + +/* Negate constant value -- changes the input node's value */ + +consnegop(p) +register Constp p; +{ + register char *s; + + if (p->vstg) { + if (ISCOMPLEX(p->vtype)) { + s = p->Const.cds[1]; + p->Const.cds[1] = *s == '-' ? s+1 + : *s == '0' ? s : s-1; + } + s = p->Const.cds[0]; + p->Const.cds[0] = *s == '-' ? s+1 + : *s == '0' ? s : s-1; + return; + } + switch(p->vtype) + { + case TYSHORT: + case TYLONG: + p->Const.ci = - p->Const.ci; + break; + + case TYCOMPLEX: + case TYDCOMPLEX: + p->Const.cd[1] = - p->Const.cd[1]; + /* fall through and do the real parts */ + case TYREAL: + case TYDREAL: + p->Const.cd[0] = - p->Const.cd[0]; + break; + default: + badtype("consnegop", p->vtype); + } +} + + + +/* conspower -- Expand out an exponentiation */ + + LOCAL void +conspower(p, ap, n) + Constp p, ap; + ftnint n; +{ + register union Constant *powp = &p->Const; + register int type; + struct Constblock x, x0; + + if (n == 1) { + memcpy((char *)powp, (char *)&ap->Const, sizeof(ap->Const)); + return; + } + + switch(type = ap->vtype) /* pow = 1 */ + { + case TYSHORT: + case TYLONG: + powp->ci = 1; + break; + case TYCOMPLEX: + case TYDCOMPLEX: + powp->cd[1] = 0; + case TYREAL: + case TYDREAL: + powp->cd[0] = 1; + break; + default: + badtype("conspower", type); + } + + if(n == 0) + return; + switch(type) /* x0 = ap */ + { + case TYSHORT: + case TYLONG: + x0.Const.ci = ap->Const.ci; + break; + case TYCOMPLEX: + case TYDCOMPLEX: + x0.Const.cd[1] = + ap->vstg ? atof(ap->Const.cds[1]) : ap->Const.cd[1]; + case TYREAL: + case TYDREAL: + x0.Const.cd[0] = + ap->vstg ? atof(ap->Const.cds[0]) : ap->Const.cd[0]; + break; + } + x0.vtype = type; + x0.vstg = 0; + if(n < 0) + { + if( ISINT(type) ) + { + err("integer ** negative number"); + return; + } + else if (!x0.Const.cd[0] + && (!ISCOMPLEX(type) || !x0.Const.cd[1])) { + err("0.0 ** negative number"); + return; + } + n = -n; + consbinop(OPSLASH, type, &x, p, &x0); + } + else + 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 +consbinop(opcode, type, cpp, app, bpp) + int opcode, type; + Constp cpp, app, bpp; +{ + register union Constant *ap = &app->Const, + *bp = &bpp->Const, + *cp = &cpp->Const; + int k; + double ad[2], bd[2], temp; + + 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 TYSHORT: + case TYLONG: + cp->ci = ap->ci + bp->ci; + break; + case TYCOMPLEX: + case TYDCOMPLEX: + cp->cd[1] = ad[1] + bd[1]; + case TYREAL: + case TYDREAL: + cp->cd[0] = ad[0] + bd[0]; + break; + } + break; + + case OPMINUS: + switch(type) + { + case TYSHORT: + case TYLONG: + cp->ci = ap->ci - bp->ci; + break; + case TYCOMPLEX: + case TYDCOMPLEX: + cp->cd[1] = ad[1] - bd[1]; + case TYREAL: + case TYDREAL: + cp->cd[0] = ad[0] - bd[0]; + break; + } + break; + + case OPSTAR: + switch(type) + { + case TYSHORT: + case TYLONG: + cp->ci = ap->ci * bp->ci; + break; + case TYREAL: + case TYDREAL: + cp->cd[0] = ad[0] * bd[0]; + break; + case TYCOMPLEX: + case TYDCOMPLEX: + temp = ad[0] * bd[0] - ad[1] * bd[1] ; + cp->cd[1] = ad[0] * bd[1] + ad[1] * bd[0] ; + cp->cd[0] = temp; + break; + } + break; + case OPSLASH: + switch(type) + { + case TYSHORT: + case TYLONG: + cp->ci = ap->ci / bp->ci; + break; + case TYREAL: + case TYDREAL: + cp->cd[0] = ad[0] / bd[0]; + break; + case TYCOMPLEX: + case TYDCOMPLEX: + zdiv((dcomplex*)cp, (dcomplex*)ad, (dcomplex*)bd); + break; + } + break; + + case OPMOD: + if( ISINT(type) ) + { + cp->ci = ap->ci % bp->ci; + break; + } + else + Fatal("inline mod of noninteger"); + + case OPMIN2: + case OPDMIN: + switch(type) + { + case TYSHORT: + case TYLONG: + cp->ci = ap->ci <= bp->ci ? ap->ci : bp->ci; + break; + case TYREAL: + case TYDREAL: + cp->cd[0] = ad[0] <= bd[0] ? ad[0] : bd[0]; + break; + default: + Fatal("inline min of exected type"); + } + break; + + case OPMAX2: + case OPDMAX: + switch(type) + { + case TYSHORT: + case TYLONG: + cp->ci = ap->ci >= bp->ci ? ap->ci : bp->ci; + break; + case TYREAL: + case TYDREAL: + cp->cd[0] = ad[0] >= bd[0] ? ad[0] : bd[0]; + break; + default: + Fatal("inline max of exected type"); + } + break; + + default: /* relational ops */ + switch(type) + { + case TYSHORT: + case TYLONG: + if(ap->ci < bp->ci) + k = -1; + else if(ap->ci == bp->ci) + k = 0; + else k = 1; + break; + case TYREAL: + case TYDREAL: + if(ad[0] < bd[0]) + k = -1; + else if(ad[0] == bd[0]) + k = 0; + else k = 1; + break; + case TYCOMPLEX: + case TYDCOMPLEX: + if(ad[0] == bd[0] && + ad[1] == bd[1] ) + k = 0; + else k = 1; + break; + } + + 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 */ + +conssgn(p) +register expptr p; +{ + register char *s; + + if( ! ISCONST(p) ) + Fatal( "sgn(nonconstant)" ); + + switch(p->headblock.vtype) + { + case TYSHORT: + case TYLONG: + if(p->constblock.Const.ci > 0) return(1); + if(p->constblock.Const.ci < 0) return(-1); + return(0); + + case TYREAL: + case TYDREAL: + if (p->constblock.vstg) { + s = p->constblock.Const.cds[0]; + if (*s == '-') + return -1; + if (*s == '0') + return 0; + return 1; + } + if(p->constblock.Const.cd[0] > 0) return(1); + if(p->constblock.Const.cd[0] < 0) return(-1); + return(0); + + +/* The sign of a complex number is 0 iff the number is 0 + 0i, else it's 1 */ + + case TYCOMPLEX: + case TYDCOMPLEX: + if (p->constblock.vstg) + return *p->constblock.Const.cds[0] != '0' + && *p->constblock.Const.cds[1] != '0'; + return(p->constblock.Const.cd[0]!=0 || p->constblock.Const.cd[1]!=0); + + default: + badtype( "conssgn", p->constblock.vtype); + } + /* NOT REACHED */ return 0; +} + +char *powint[ ] = { + "pow_ii", "pow_ri", "pow_di", "pow_ci", "pow_zi" }; + +LOCAL expptr mkpower(p) +register expptr p; +{ + register expptr q, lp, rp; + int ltype, rtype, mtype, tyi; + + lp = p->exprblock.leftp; + rp = p->exprblock.rightp; + ltype = lp->headblock.vtype; + rtype = rp->headblock.vtype; + + if(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) && !doin_setbound) { + 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(ltype == TYSHORT) + { + ltype = TYLONG; + lp = mkconv(TYLONG,lp); + } + 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 +zdiv(c, a, b) + register dcomplex *a, *b, *c; +{ + 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; + } +} diff --git a/lang/fortran/comp/f2c.1 b/lang/fortran/comp/f2c.1 new file mode 100644 index 000000000..8681209b4 --- /dev/null +++ b/lang/fortran/comp/f2c.1 @@ -0,0 +1,182 @@ + + F2C(1) 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 + current 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. + + -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. If the option is + `-w66', only Fortran 66 compatibility warnings are + suppressed. + + The following options are peculiar to f2c. + + -A Produce ANSI C. Default is old-style C. + + -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. + + Page 1 Tenth Edition (printed 4/25/91) + + F2C(1) F2C(1) + + -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. + + -g Include original Fortran line numbers as comments. + + -h 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. + + -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- + precision operands. + + -P Write a file.P of ANSI (or C++) prototypes for pro- + cedures defined in each input file.f or file.F. When + reading Fortran from standard input, write prototypes + at the beginning of standard output. Implies -A unless + option `-C++' is present. Option -Ps implies -P , and + gives exit status 4 if rerunning f2c may change proto- + types 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 values of REAL functions (including intrinsics) to + REAL. + + -r8 Promote REAL to DOUBLE PRECISION, COMPLEX to DOUBLE + COMPLEX. + + -Tdir + Put temporary files in directory dir. + + -w8 Suppress warnings when COMMON or EQUIVALENCE forces + odd-word alignment of doubles. + + Page 2 Tenth Edition (printed 4/25/91) + + F2C(1) F2C(1) + + -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. + + -!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.a + intrinsic function library + + /usr/lib/libI77.a + Fortran 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 + + Page 3 Tenth Edition (printed 4/25/91) + + F2C(1) F2C(1) + + 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. + + Page 4 Tenth Edition (printed 4/25/91) + diff --git a/lang/fortran/comp/f2c.1t b/lang/fortran/comp/f2c.1t new file mode 100644 index 000000000..83f7aa820 --- /dev/null +++ b/lang/fortran/comp/f2c.1t @@ -0,0 +1,326 @@ +. \" 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 +f\^2c \(mi Convert Fortran 77 to C or C++ +.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 +.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. +If the option is +.LR -w66 , +only Fortran 66 compatibility warnings are suppressed. +.PP +The following options are peculiar to +.IR f\^2c . +.TP +.B -A +Produce +.SM ANSI +C. +Default is old-style C. +.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 -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 -g +Include original Fortran line numbers as comments. +.TP +.B -h +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 -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 procedures defined in each input +.IB file .f +or +.IB file .F . +When reading Fortran from standard input, write prototypes +at the beginning of standard output. +Implies +.B -A +unless option +.L -C++ +is present. 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 values of REAL functions (including intrinsics) to REAL. +.TP +.B -r8 +Promote +.SM REAL +to +.SM DOUBLE PRECISION, COMPLEX +to +.SM DOUBLE COMPLEX. +.TP +.BI -T dir +Put temporary files in directory +.I dir. +.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 -!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 +.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 . diff --git a/lang/fortran/comp/f2c.6 b/lang/fortran/comp/f2c.6 new file mode 100644 index 000000000..f4480490a --- /dev/null +++ b/lang/fortran/comp/f2c.6 @@ -0,0 +1,317 @@ +. \" 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 6 +.CT 1 prog_other +.SH NAME +f\^2c \(mi Convert Fortran 77 to C or C++ +.SH SYNOPSIS +.B ~em/lib.bin/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 +.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. +If the option is +.LR -w66 , +only Fortran 66 compatibility warnings are suppressed. +.PP +The following options are peculiar to +.IR f\^2c . +.TP +.B -A +Produce +.SM ANSI +C. +Default is old-style C. +.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 -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 -g +Include original Fortran line numbers as comments. +.TP +.B -h +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 -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 procedures defined in each input +.IB file .f +or +.IB file .F . +When reading Fortran from standard input, write prototypes +at the beginning of standard output. +Implies +.B -A +unless option +.L -C++ +is present. 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 values of REAL functions (including intrinsics) to REAL. +.TP +.B -r8 +Promote +.SM REAL +to +.SM DOUBLE PRECISION, COMPLEX +to +.SM DOUBLE COMPLEX. +.TP +.BI -T dir +Put temporary files in directory +.I dir. +.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 -!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 +.IB file .[fF] +input file +.TP +.B *.c +output file +.TP +.F ~em/include/fortran/f2c.h +header file +.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 . diff --git a/lang/fortran/comp/f2c.h b/lang/fortran/comp/f2c.h new file mode 100644 index 000000000..e851b5ad4 --- /dev/null +++ b/lang/fortran/comp/f2c.h @@ -0,0 +1,209 @@ +/* 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 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; + +#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 flag; +typedef long ftnlen; +typedef long 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 */ + shortint h; + integer i; + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +typedef long 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) + +/* 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/lang/fortran/comp/format.c b/lang/fortran/comp/format.c new file mode 100644 index 000000000..53cdcf882 --- /dev/null +++ b/lang/fortran/comp/format.c @@ -0,0 +1,2108 @@ +/**************************************************************** +Copyright 1990, 1991 by AT&T Bell Laboratories and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T Bell Laboratories or +Bellcore or any of their entities not be used in advertising or +publicity pertaining to distribution of the software without +specific, written prior permission. + +AT&T and Bellcore disclaim all warranties with regard to this +software, including all implied warranties of merchantability +and fitness. In no event shall AT&T or Bellcore be liable for +any special, indirect or consequential damages or any damages +whatsoever resulting from loss of use, data or profits, whether +in an action of contract, negligence or other tortious action, +arising out of or in connection with the use or performance of +this software. +****************************************************************/ + +/* 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 int p1getd(), p1gets(), p1getf(), get_p1_token(); +static int p1get_const(), p1getn(); +static expptr do_format(), do_p1_name_pointer(), do_p1_const(); +static expptr do_p1_expr(), do_p1_ident(), do_p1_charp(), do_p1_extern(); +static expptr do_p1_head(), do_p1_list(), do_p1_literal(); +static void do_p1_label(), do_p1_asgoto(), do_p1_goto(); +static void do_p1_if(), do_p1_else(), do_p1_elif(), do_p1_endif(); +static void do_p1_endelse(), do_p1_subr_ret(), do_p1_comp_goto(); +static void do_p1_for(), do_p1_end_for(), do_p1_fortran(); +static void do_p1_1while(), do_p1_2while(), do_p1_elseifstart(); +static void do_p1_comment(), do_p1_set_line(); +static expptr do_p1_addr(); +static void proto(); +void list_arg_types(); +chainp length_comp(); +void listargs(); +extern chainp assigned_fmts; +static long old_lineno; +static char filename[P1_FILENAME_MAX]; +extern int gflag; +extern char *parens; + +start_formatting () +{ + 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; + old_lineno = lineno; + 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); + 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 +put_semi(outfile) + FILE *outfile; +{ + 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 do_format (infile, outfile) +FILE *infile, *outfile; +{ + int gsave, 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: + gsave = gflag; + gflag = 0; + retval = do_p1_head (infile, outfile); + gflag = gsave; + 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 +do_p1_comment (infile, outfile) +FILE *infile, *outfile; +{ + extern int c_output_line_length, in_comment; + + char storage[COMMENT_BUFFER_SIZE + 1]; + int length; + + if (!p1gets(infile, storage, COMMENT_BUFFER_SIZE + 1)) + return; + + length = strlen (storage); + + in_comment = 1; + if (length > c_output_line_length - 6) + margin_printf (outfile, "/*%s*/\n", storage); + else + margin_printf (outfile, length ? "/* %s */\n" : "\n", storage); + in_comment = 0; +} /* do_p1_comment */ + + static void +do_p1_set_line (infile) +FILE *infile; +{ + 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; + if (gflag) + fprintf(c_file, "/*# %ld \"%s\"*/\n", lineno, filename); + } +} /* do_p1_set_line */ + + +static expptr do_p1_name_pointer (infile) +FILE *infile; +{ + Namep namep = (Namep) NULL; + int status; + + status = p1getd (infile, (long *) &namep); + + if (status == EOF) + err ("do_p1_name_pointer: Missing pointer at end of file\n"); + else if (status == 0 || namep == (Namep) NULL) + erri ("do_p1_name_pointer: Illegal name pointer in p1 file: '%x'\n", + (int) namep); + + return (expptr) namep; +} /* do_p1_name_pointer */ + + + +static expptr do_p1_const (infile) +FILE *infile; +{ + 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 */ + + +static expptr do_p1_literal (infile) +FILE *infile; +{ + 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 { + struct Literal *litp, *lastlit; + + addrp = ALLOC (Addrblock); + addrp -> tag = TADDR; + addrp -> vtype = TYUNKNOWN; + addrp -> Field = NULL; + + lastlit = litpool + nliterals; + for (litp = litpool; litp < lastlit; litp++) + if (litp -> litnum == memno) { + addrp -> vtype = litp -> littype; + *((union Constant *) &(addrp -> user)) = + *((union Constant *) &(litp -> litval)); + break; + } /* if litp -> litnum == memno */ + + addrp -> memno = memno; + addrp -> vstg = STGMEMNO; + addrp -> uname_tag = UNAM_CONST; + } /* else */ + + return (expptr) addrp; +} /* do_p1_literal */ + + +static void do_p1_label (infile, outfile) +FILE *infile, *outfile; +{ + int status; + ftnint stateno; + char *user_label (); + 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 do_p1_asgoto (infile, outfile) +FILE *infile, *outfile; +{ + expptr expr; + + expr = do_format (infile, outfile); + out_asgoto (outfile, expr); + +} /* do_p1_asgoto */ + + +static void do_p1_goto (infile, outfile) +FILE *infile, *outfile; +{ + int status; + long stateno; + char *user_label (); + + 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 do_p1_if (infile, outfile) +FILE *infile, *outfile; +{ + expptr cond; + + do { + cond = do_format (infile, outfile); + } while (cond == ENULL); + + out_if (outfile, cond); +} /* do_p1_if */ + + +static void do_p1_else (outfile) +FILE *outfile; +{ + out_else (outfile); +} /* do_p1_else */ + + +static void do_p1_elif (infile, outfile) +FILE *infile, *outfile; +{ + expptr cond; + + do { + cond = do_format (infile, outfile); + } while (cond == ENULL); + + elif_out (outfile, cond); +} /* do_p1_elif */ + +static void do_p1_endif (outfile) +FILE *outfile; +{ + endif_out (outfile); +} /* do_p1_endif */ + + +static void do_p1_endelse (outfile) +FILE *outfile; +{ + end_else_out (outfile); +} /* do_p1_endelse */ + + +static expptr do_p1_addr (infile, outfile) +FILE *infile, *outfile; +{ + Addrp addrp = (Addrp) NULL; + int status; + + status = p1getn (infile, 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 do_p1_subr_ret (infile, outfile) +FILE *infile, *outfile; +{ + 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 do_p1_comp_goto (infile, outfile) +FILE *infile, *outfile; +{ + 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 do_p1_for (infile, outfile) +FILE *infile, *outfile; +{ + 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 do_p1_end_for (outfile) +FILE *outfile; +{ + out_end_for (outfile); +} /* do_p1_end_for */ + + + static void +do_p1_fortran(infile, outfile) + FILE *infile, *outfile; +{ + 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 do_p1_expr (infile, outfile) +FILE *infile, *outfile; +{ + int status; + long opcode, type; + struct Exprblock *result = (struct Exprblock *) NULL; + + status = p1getd (infile, &opcode); + + if (status == EOF) + err ("do_p1_expr: Missing expr opcode at end of file"); + else if (status == 0) + err ("do_p1_expr: Missing expr opcode in p1 file"); + else { + + status = p1getd (infile, &type); + + if (status == EOF) + err ("do_p1_expr: Missing expr type at end of file"); + else if (status == 0) + err ("do_p1_expr: Missing expr type in p1 file"); + else if (opcode == 0) + return ENULL; + else { + result = ALLOC (Exprblock); + + result -> tag = TEXPR; + result -> vtype = type; + result -> opcode = opcode; + result -> vleng = do_format (infile, outfile); + + if (is_unary_op (opcode)) + result -> leftp = do_format (infile, outfile); + else if (is_binary_op (opcode)) { + result -> leftp = do_format (infile, outfile); + result -> rightp = do_format (infile, outfile); + } else + errl("do_p1_expr: Illegal opcode %ld", opcode); + } /* else */ + } /* else */ + + return (expptr) result; +} /* do_p1_expr */ + + +static expptr do_p1_ident(infile) +FILE *infile; +{ + Addrp addrp; + int status; + long vtype, vstg; + + addrp = ALLOC (Addrblock); + addrp -> tag = TADDR; + + status = p1getd (infile, &vtype); + if (status == EOF) + err ("do_p1_ident: Missing identifier type at end of file\n"); + else if (status == 0 || vtype < 0 || vtype >= NTYPES) + errl("do_p1_ident: Bad type in intermediate file: %ld\n", vtype); + else + addrp -> vtype = vtype; + + status = p1getd (infile, &vstg); + if (status == EOF) + err ("do_p1_ident: Missing identifier storage at end of file\n"); + else if (status == 0 || vstg < 0 || vstg > STGNULL) + errl("do_p1_ident: Bad storage in intermediate file: %ld\n", vtype); + else + addrp -> vstg = vstg; + + status = p1gets(infile, addrp->user.ident, IDENT_LEN); + + if (status == EOF) + err ("do_p1_ident: Missing ident string at end of file"); + else if (status == 0) + err ("do_p1_ident: Missing ident string in intermediate file"); + addrp->uname_tag = UNAM_IDENT; + return (expptr) addrp; +} /* do_p1_ident */ + +static expptr do_p1_charp(infile) +FILE *infile; +{ + Addrp addrp; + int status; + long vtype, vstg; + char buf[64]; + + addrp = ALLOC (Addrblock); + addrp -> tag = TADDR; + + status = p1getd (infile, &vtype); + if (status == EOF) + err ("do_p1_ident: Missing identifier type at end of file\n"); + else if (status == 0 || vtype < 0 || vtype >= NTYPES) + errl("do_p1_ident: Bad type in intermediate file: %ld\n", vtype); + else + addrp -> vtype = vtype; + + status = p1getd (infile, &vstg); + if (status == EOF) + err ("do_p1_ident: Missing identifier storage at end of file\n"); + else if (status == 0 || vstg < 0 || vstg > STGNULL) + errl("do_p1_ident: Bad storage in intermediate file: %ld\n", vtype); + else + addrp -> vstg = vstg; + + status = p1gets(infile, buf, (int)sizeof(buf)); + + if (status == EOF) + err ("do_p1_ident: Missing charp ident string at end of file"); + else if (status == 0) + err ("do_p1_ident: Missing charp ident string in intermediate file"); + addrp->uname_tag = UNAM_CHARP; + addrp->user.Charp = strcpy(mem(strlen(buf)+1,0), buf); + return (expptr) addrp; +} + + +static expptr do_p1_extern (infile) +FILE *infile; +{ + 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 do_p1_head (infile, outfile) +FILE *infile, *outfile; +{ + int status; + int add_n_; + long class; + char storage[256]; + + status = p1getd (infile, &class); + if (status == EOF) + err ("do_p1_head: missing header class at end of file"); + else if (status == 0) + err ("do_p1_head: missing header class in p1 file"); + else { + status = p1gets (infile, storage, (int)sizeof(storage)); + if (status == EOF || status == 0) + storage[0] = '\0'; + } /* else */ + + if (class == CLPROC || class == CLMAIN) { + chainp lengths; + + add_n_ = nentry > 1; + lengths = length_comp(entries, add_n_); + + if (!add_n_ && protofile && class != CLMAIN) + protowrite(protofile, proctype, storage, entries, lengths); + + if (class == CLMAIN) + nice_printf (outfile, "/* Main program */ "); + else + nice_printf(outfile, "%s ", multitype ? "VOID" + : c_type_decl(proctype, 1)); + + nice_printf(outfile, add_n_ ? "%s0_" : "%s", storage); + if (!Ansi) { + listargs(outfile, entries, add_n_, lengths); + nice_printf (outfile, "\n"); + } + list_arg_types (outfile, entries, lengths, add_n_, "\n"); + nice_printf (outfile, "{\n"); + frchain(&lengths); + next_tab (outfile); + strcpy(this_proc_name, storage); + list_decls (outfile); + + } else if (class == CLBLOCK) + next_tab (outfile); + else + errl("do_p1_head: got class %ld", class); + + return NULL; +} /* do_p1_head */ + + +static expptr do_p1_list (infile, outfile) +FILE *infile, *outfile; +{ + long tag, type, count; + int status; + expptr result; + + status = p1getd (infile, &tag); + if (status == EOF) + err ("do_p1_list: missing list tag at end of file"); + else if (status == 0) + err ("do_p1_list: missing list tag in p1 file"); + else { + status = p1getd (infile, &type); + if (status == EOF) + err ("do_p1_list: missing list type at end of file"); + else if (status == 0) + err ("do_p1_list: missing list type in p1 file"); + else { + status = p1getd (infile, &count); + if (status == EOF) + err ("do_p1_list: missing count at end of file"); + else if (status == 0) + err ("do_p1_list: missing count in p1 file"); + } /* else */ + } /* else */ + + result = (expptr) ALLOC (Listblock); + if (result) { + chainp pointer; + + result -> tag = tag; + result -> listblock.vtype = type; + +/* Assume there will be enough data */ + + if (count--) { + pointer = result->listblock.listp = + mkchain((char *)do_format(infile, outfile), CHNULL); + while (count--) { + pointer -> nextp = + mkchain((char *)do_format(infile, outfile), CHNULL); + pointer = pointer -> nextp; + } /* while (count--) */ + } /* if (count) */ + } /* if (result) */ + + return result; +} /* do_p1_list */ + + +chainp length_comp(e, add_n) /* get lengths of characters args */ + struct Entrypoint *e; + int add_n; +{ + chainp lengths; + chainp args, args1; + Namep arg, np; + int nchargs; + Argtypes *at; + Atype *a; + extern int init_ac[TYSUBR+1]; + + 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 listargs(outfile, entryp, add_n_, lengths) + FILE *outfile; + struct Entrypoint *entryp; + int add_n_; + chainp lengths; +{ + 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 + 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 list_arg_types(outfile, entryp, lengths, add_n_, finalnl) +FILE *outfile; +struct Entrypoint *entryp; +chainp lengths; +int add_n_; +char *finalnl; +{ + chainp args; + int last_type = -1, last_class = -1; + int did_one = 0, done_one, is_ext; + char *s, *sep = "", *sep1; + + if (outfile == (FILE *) NULL) { + err ("list_arg_types: null output file"); + return; + } else if (entryp == (struct Entrypoint *) NULL) { + err ("list_arg_types: null procedure entry pointer"); + return; + } /* else */ + + if (Ansi) { + done_one = 0; + sep1 = ", "; + nice_printf(outfile, "(" /*)*/); + } + else { + done_one = 1; + sep1 = ";\n"; + } + args = entryp->arglist; + if (add_n_) { + nice_printf(outfile, "int n__"); + did_one = done_one; + sep = sep1; + args = allargs; + } + if (multitype) { + nice_printf(outfile, "%sMultitype *ret_val", sep); + did_one = done_one; + sep = sep1; + } + else if (ONEOF (proctype, MSKCOMPLEX|MSKCHAR)) { + s = xretslot[proctype]->user.ident; + nice_printf(outfile, "%s%s *%s", sep, c_type_decl(proctype, 0), + *s == '(' /*)*/ ? "r_v" : s); + did_one = done_one; + sep = sep1; + if (proctype == TYCHAR) + nice_printf (outfile, "%sftnlen ret_val_len", sep); + } /* if ONEOF proctype */ + for (; args; args = args -> nextp) { + Namep arg = (Namep) args->datap; + +/* Scalars are passed by reference, and arrays will have their lower bound + adjusted, so nearly everything is printed with a star in front. The + exception is character lengths, which are passed by value. */ + + if (arg) { + int type = arg -> vtype, class = arg -> vclass; + + if (class == CLPROC) + if (arg->vimpltype) + type = Castargs ? TYUNKNOWN : TYSUBR; + else if (type == TYREAL && forcedouble && !Castargs) + type = TYDREAL; + + if (type == last_type && class == last_class && did_one) + nice_printf (outfile, ", "); + else + if ((is_ext = class == CLPROC) && Castargs) + nice_printf(outfile, "%s%s ", sep, + usedcasts[type] = casttypes[type]); + else + nice_printf(outfile, "%s%s ", sep, + c_type_decl(type, is_ext)); + if (class == CLPROC) + if (Castargs) + out_name(outfile, arg); + else { + nice_printf(outfile, "(*"); + out_name(outfile, arg); + nice_printf(outfile, ") %s", parens); + } + else { + nice_printf (outfile, "*"); + out_name (outfile, arg); + } + + last_type = type; + last_class = class; + did_one = done_one; + sep = sep1; + } /* if (arg) */ + } /* for args = entryp -> arglist */ + + for (args = lengths; args; args = args -> nextp) + nice_printf(outfile, "%sftnlen %s", sep, + new_arg_length((Namep)args->datap)); + if (did_one) + nice_printf (outfile, ";\n"); + else if (Ansi) + nice_printf(outfile, + /*((*/ sep != sep1 && Ansi == 1 ? "void)%s" : ")%s", + finalnl); +} /* list_arg_types */ + + static void +write_formats(outfile) + FILE *outfile; +{ + 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 +write_ioblocks(outfile) + FILE *outfile; +{ + 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 +write_assigned_fmts(outfile) + FILE *outfile; +{ + register chainp cp; + Namep np; + int did_one = 0; + + cp = assigned_fmts = revchain(assigned_fmts); + nice_printf(outfile, "/* Assigned format variables */\nchar "); + do { + np = (Namep)cp->datap; + if (did_one) + nice_printf(outfile, ", "); + did_one = 1; + nice_printf(outfile, "*%s_fmt", np->fvarname); + } + while(cp = cp->nextp); + nice_printf(outfile, ";\n\n"); + } + + static char * +to_upper(s) + register char *s; +{ + 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 +write_namelists(nmch, outfile) + chainp nmch; + FILE *outfile; +{ + 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(name), + type == TYCHAR ? "" : dimp ? "(char *)" : "(char *)&"); + out_name(outfile, v); + nice_printf(outfile, dimp ? ", %s_dims" : ", (ftnlen *)0", name); + nice_printf(outfile, ", %ld };\n", + type != TYCHAR ? (long)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(name), 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 +fixexttype(var) + Namep var; +{ + Extsym *e; + int type, type1; + extern void changedtype(); + + 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; + } + +list_decls (outfile) +FILE *outfile; +{ + extern chainp used_builtins; + extern struct Hashentry *hashtab; + extern ftnint wr_char_len(); + struct Hashentry *entry; + int write_header = 1; + int last_class = -1, last_stg = -1; + Namep var; + int Alias, Define, did_one, last_type, type; + extern int def_equivs, useauto; + extern chainp new_vars; /* Compiler-generated locals */ + chainp namelists = 0; + char *ctype; + long lineno_save = lineno; + int useauto1 = useauto && !saveall; + long x; + extern int hsize; + + lineno = old_lineno; + +/* First write out the statically initialized data */ + + if (initfile) + list_init_data(&initfile, initfname, outfile); + +/* Next come formats */ + write_formats(outfile); + +/* Now write out the system-generated identifiers */ + + if (new_vars || nequiv) { + chainp args, next_var, this_var; + chainp nv[TYVOID], nv1[TYVOID]; + int i, j; + Addrp Var; + Namep arg; + + /* zap unused dimension variables */ + + for(args = allargs; args; args = args->nextp) { + arg = (Namep)args->datap; + if (this_var = arg->vlastdim) { + frexpr((tagptr)this_var->datap); + this_var->datap = 0; + } + } + + /* sort new_vars by type, skipping entries just zapped */ + + for(i = TYADDR; i < TYVOID; i++) + nv[i] = 0; + for(this_var = new_vars; this_var; this_var = next_var) { + next_var = this_var->nextp; + if (Var = (Addrp)this_var->datap) { + if (!(this_var->nextp = nv[j = Var->vtype])) + nv1[j] = this_var; + nv[j] = this_var; + } + else { + this_var->nextp = 0; + frchain(&this_var); + } + } + new_vars = 0; + for(i = TYVOID; --i >= TYADDR;) + if (this_var = nv[i]) { + nv1[i]->nextp = new_vars; + new_vars = this_var; + } + + /* write the declarations */ + + did_one = 0; + last_type = -1; + + for (this_var = new_vars; this_var; this_var = this_var -> nextp) { + Var = (Addrp) this_var->datap; + + if (Var == (Addrp) NULL) + err ("list_decls: null variable"); + else if (Var -> tag != TADDR) + erri ("list_decls: bad tag on new variable '%d'", + Var -> tag); + + type = nv_type (Var); + if (Var->vstg == STGINIT + || Var->uname_tag == UNAM_IDENT + && *Var->user.ident == ' ' + && multitype) + continue; + if (!did_one) + nice_printf (outfile, "/* System generated locals */\n"); + + if (last_type == type && did_one) + nice_printf (outfile, ", "); + else { + if (did_one) + nice_printf (outfile, ";\n"); + nice_printf (outfile, "%s ", + c_type_decl (type, Var -> vclass == CLPROC)); + } /* else */ + +/* Character type is really a string type. Put out a '*' for parameters + with unknown length and functions returning character */ + + if (Var -> vtype == TYCHAR && (!ISICON ((Var -> vleng)) + || Var -> vclass == CLPROC)) + nice_printf (outfile, "*"); + + write_nv_ident(outfile, (Addrp)this_var->datap); + if (Var -> vtype == TYCHAR && Var->vclass != CLPROC && + ISICON((Var -> vleng)) + && (i = Var->vleng->constblock.Const.ci) > 0) + nice_printf (outfile, "[%d]", i); + + did_one = 1; + last_type = nv_type (Var); + } /* for this_var */ + +/* Handle the uninitialized equivalences */ + + do_uninit_equivs (outfile, &did_one); + + if (did_one) + nice_printf (outfile, ";\n\n"); + } /* if new_vars */ + +/* Write out builtin declarations */ + + if (used_builtins) { + chainp cp; + Extsym *es; + + last_type = -1; + did_one = 0; + + nice_printf (outfile, "/* Builtin functions */"); + + for (cp = used_builtins; cp; cp = cp -> nextp) { + Addrp e = (Addrp)cp->datap; + + switch(type = e->vtype) { + case TYDREAL: + case TYREAL: + /* if (forcedouble || e->dbl_builtin) */ + /* libF77 currently assumes everything double */ + type = TYDREAL; + ctype = "double"; + break; + case TYCOMPLEX: + case TYDCOMPLEX: + type = TYVOID; + /* no break */ + default: + ctype = c_type_decl(type, 0); + } + + if (did_one && last_type == type) + nice_printf(outfile, ", "); + else + nice_printf(outfile, "%s\n%s ", did_one ? ";" : "", ctype); + + extern_out(outfile, es = &extsymtab[e -> memno]); + proto(outfile, es->arginfo, es->fextname); + last_type = type; + did_one = 1; + } /* for cp = used_builtins */ + + nice_printf (outfile, ";\n\n"); + } /* if used_builtins */ + + last_type = -1; + for (entry = hashtab; entry < lasthash; ++entry) { + var = entry -> varp; + + if (var) { + int procclass = var -> vprocclass; + char *comment = NULL; + int stg = var -> vstg; + int class = var -> vclass; + type = var -> vtype; + + if (ONEOF(stg, M(STGARG)|M(STGLENG)|M(STGINIT))) + continue; + + if (useauto1 && stg == STGBSS && !var->vsave) + stg = STGAUTO; + + switch (class) { + case CLVAR: + break; + case CLPROC: + switch(procclass) { + case PTHISPROC: + extsymtab[var->vardesc.varno].extype = type; + continue; + case PSTFUNCT: + case PINTRINSIC: + continue; + case PUNKNOWN: + err ("list_decls: unknown procedure class"); + continue; + case PEXTERNAL: + if (stg == STGUNKNOWN) { + warn1( + "%.64s declared EXTERNAL but never used.", + var->fvarname); + /* to retain names declared EXTERNAL */ + /* but not referenced, change + /* "continue" to "stg = STGEXT" */ + continue; + } + else + type = fixexttype(var); + } + break; + case CLUNKNOWN: + /* declared but never used */ + continue; + case CLPARAM: + continue; + case CLNAMELIST: + if (var->visused) + namelists = mkchain((char *)var, namelists); + continue; + default: + erri("list_decls: can't handle class '%d' yet", + class); + Fatal(var->fvarname); + continue; + } /* switch */ + + /* Might be equivalenced to a common. If not, don't process */ + if (stg == STGCOMMON && !var->vcommequiv) + continue; + +/* Only write the header if system-generated locals, builtins, or + uninitialized equivs were already output */ + + if (write_header == 1 && (new_vars || nequiv || used_builtins) + && oneof_stg ( var, stg, + M(STGBSS)|M(STGEXT)|M(STGAUTO)|M(STGCOMMON)|M(STGEQUIV))) { + nice_printf (outfile, "/* Local variables */\n"); + write_header = 2; + } + + + Alias = oneof_stg(var, stg, M(STGEQUIV)|M(STGCOMMON)); + if (Define = (Alias && def_equivs)) { + if (!write_header) + nice_printf(outfile, ";\n"); + def_start(outfile, var->cvarname, CNULL, "("); + goto Alias1; + } + else if (type == last_type && class == last_class && + stg == last_stg && !write_header) + nice_printf (outfile, ", "); + else { + if (!write_header && ONEOF(stg, M(STGBSS)| + M(STGEXT)|M(STGAUTO)|M(STGEQUIV)|M(STGCOMMON))) + nice_printf (outfile, ";\n"); + + switch (stg) { + case STGARG: + case STGLENG: + /* Part of the argument list, don't write them out + again */ + continue; /* Go back to top of the loop */ + case STGBSS: + case STGEQUIV: + case STGCOMMON: + nice_printf (outfile, "static "); + break; + case STGEXT: + nice_printf (outfile, "extern "); + break; + case STGAUTO: + break; + case STGINIT: + case STGUNKNOWN: + /* Don't want to touch the initialized data, that will + be handled elsewhere. Unknown data have + already been complained about, so skip them */ + continue; + default: + erri("list_decls: can't handle storage class %d", + stg); + continue; + } /* switch */ + + if (type == TYCHAR && halign && class != CLPROC + && ISICON(var->vleng)) { + nice_printf(outfile, "struct { %s fill; char val", + halign); + x = wr_char_len(outfile, var->vdim, + var->vleng->constblock.Const.ci, 1); + if (x %= hsize) + nice_printf(outfile, "; char fill2[%ld]", + hsize - x); + nice_printf(outfile, "; } %s_st;\n", var->cvarname); + def_start(outfile, var->cvarname, CNULL, var->cvarname); + ind_printf(0, outfile, "_st.val\n"); + last_type = -1; + write_header = 2; + continue; + } + nice_printf(outfile, "%s ", + c_type_decl(type, class == CLPROC)); + } /* else */ + +/* Character type is really a string type. Put out a '*' for variable + length strings, and also for equivalences */ + + if (type == TYCHAR && class != CLPROC + && (!var->vleng || !ISICON (var -> vleng)) + || oneof_stg(var, stg, M(STGEQUIV)|M(STGCOMMON))) + nice_printf (outfile, "*%s", var->cvarname); + else { + nice_printf (outfile, "%s", var->cvarname); + if (class == CLPROC) + proto(outfile, var->arginfo, var->fvarname); + else if (type == TYCHAR && ISICON ((var -> vleng))) + wr_char_len(outfile, var->vdim, + (int)var->vleng->constblock.Const.ci, 0); + else if (var -> vdim && + !oneof_stg (var, stg, M(STGEQUIV)|M(STGCOMMON))) + comment = wr_ardecls(outfile, var->vdim, 1L); + } + + if (comment) + nice_printf (outfile, "%s", comment); + Alias1: + if (Alias) { + char *amp, *lp, *name, *rp; + char *equiv_name (); + ftnint voff = var -> voffset; + int et0, expr_type, k; + Extsym *E; + struct Equivblock *eb; + char buf[16]; + +/* We DON'T want to use oneof_stg here, because we need to distinguish + between them */ + + if (stg == STGEQUIV) { + name = equiv_name(k = var->vardesc.varno, CNULL); + eb = eqvclass + k; + if (eb->eqvinit) { + amp = "&"; + et0 = TYERROR; + } + else { + amp = ""; + et0 = eb->eqvtype; + } + expr_type = et0; + } + else { + E = &extsymtab[var->vardesc.varno]; + sprintf(name = buf, "%s%d", E->cextname, E->curno); + expr_type = type; + et0 = -1; + amp = "&"; + } /* else */ + + if (!Define) + nice_printf (outfile, " = "); + if (voff) { + k = typesize[type]; + switch((int)(voff % k)) { + case 0: + voff /= k; + expr_type = type; + break; + case SZSHORT: + case SZSHORT+SZLONG: + expr_type = TYSHORT; + voff /= SZSHORT; + break; + case SZLONG: + expr_type = TYLONG; + voff /= SZLONG; + break; + default: + expr_type = TYCHAR; + } + } + + if (expr_type == type) { + lp = rp = ""; + if (et0 == -1 && !voff) + goto cast; + } + else { + lp = "("; + rp = ")"; + cast: + nice_printf(outfile, "(%s *)", c_type_decl(type, 0)); + } + +/* Now worry about computing the offset */ + + if (voff) { + if (expr_type == et0) + nice_printf (outfile, "%s%s + %ld%s", + lp, name, voff, rp); + else + nice_printf(outfile, "%s(%s *)%s%s + %ld%s", lp, + c_type_decl (expr_type, 0), amp, + name, voff, rp); + } else + nice_printf(outfile, "%s%s", amp, name); +/* Always put these at the end of the line */ + last_type = last_class = last_stg = -1; + write_header = 0; + if (Define) { + ind_printf(0, outfile, ")\n"); + write_header = 2; + } + continue; + } + write_header = 0; + last_type = type; + last_class = class; + last_stg = stg; + } /* if (var) */ + } /* for (entry = hashtab */ + + if (!write_header) + nice_printf (outfile, ";\n\n"); + else if (write_header == 2) + nice_printf(outfile, "\n"); + +/* Next, namelists, which may reference equivs */ + + if (namelists) { + write_namelists(namelists = revchain(namelists), outfile); + frchain(&namelists); + } + +/* Finally, ioblocks (which may reference equivs and namelists) */ + if (iob_list) + write_ioblocks(outfile); + if (assigned_fmts) + write_assigned_fmts(outfile); + lineno = lineno_save; +} /* list_decls */ + +do_uninit_equivs (outfile, did_one) +FILE *outfile; +int *did_one; +{ + 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 *wr_ardecls(outfile, dimp, size) +FILE *outfile; +struct Dimblock *dimp; +long size; +{ + int i, k; + 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 (!ISICON (this_size)) + err ("wr_ardecls: nonconstant array size"); + else { + size *= this_size -> constblock.Const.ci; + sprintf(buf+k, "[%ld]", this_size -> constblock.Const.ci); + k += strlen(buf+k); /* BSD prevents combining this with prev stmt */ + } /* else */ + } /* 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 get_p1_token (infile) +FILE *infile; +{ + 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 p1gets (fp, str, size) +FILE *fp; +char *str; +int size; +{ + char *fgets (); + char c; + + if (str == NULL) + return 0; + + if ((c = getc (fp)) != ' ') + ungetc (c, fp); + + if (fgets (str, size, fp)) { + int length; + + str[size - 1] = '\0'; + length = strlen (str); + +/* Get rid of the newline */ + + if (str[length - 1] == '\n') + str[length - 1] = '\0'; + return 1; + + } else if (feof (fp)) + return EOF; + else + return 0; +} /* p1gets */ + + +static int p1get_const (infile, type, resultp) +FILE *infile; +int type; +struct Constblock **resultp; +{ + int status; + struct Constblock *result; + + if (type != TYCHAR) { + *resultp = result = ALLOC(Constblock); + result -> tag = TCONST; + result -> vtype = type; + } + + switch (type) { + case TYSHORT: + case TYLONG: + case TYLOGICAL: + status = p1getd (infile, &(result -> Const.ci)); + break; + case TYREAL: + case TYDREAL: + status = p1getf(infile, &result->Const.cds[0]); + result->vstg = 1; + break; + case TYCOMPLEX: + case TYDCOMPLEX: + status = p1getf(infile, &result->Const.cds[0]); + if (status && status != EOF) + status = p1getf(infile, &result->Const.cds[1]); + result->vstg = 1; + break; + case TYCHAR: + status = fscanf(infile, "%lx", resultp); + break; + default: + erri ("p1get_const: bad constant type '%d'", type); + status = 0; + break; + } /* switch */ + + return status; +} /* p1get_const */ + +static int p1getd (infile, result) +FILE *infile; +long *result; +{ + return fscanf (infile, "%ld", result); +} /* p1getd */ + + static int +p1getf(infile, result) + FILE *infile; + char **result; +{ + + 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 p1getn (infile, count, result) +FILE *infile; +int count; +char **result; +{ + + char *bufptr; + extern ptr ckalloc (); + + 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 +proto(outfile, at, fname) + FILE *outfile; + Argtypes *at; + char *fname; +{ + int i, j, k, n; + char *comma; + Atype *atypes; + Namep np; + chainp cp; + extern void bad_atypes(); + + if (at) { + /* Correct types that we learn on the fly, e.g. + subroutine gotcha(foo) + external foo + call zap(...,foo,...) + call foo(...) + */ + atypes = at->atypes; + n = 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 { + 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->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; + 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 +protowrite(protofile, type, name, e, lengths) + FILE *protofile; + char *name; + struct Entrypoint *e; + chainp lengths; +{ + extern char used_rets[]; + + nice_printf(protofile, "extern %s %s", protorettypes[type], name); + list_arg_types(protofile, e, lengths, 0, ";\n"); + used_rets[type] = 1; + } + + static void +do_p1_1while(outfile) + FILE *outfile; +{ + if (*wh_next) { + nice_printf(outfile, + "for(;;) { /* while(complicated condition) */\n" /*}*/ ); + next_tab(outfile); + } + else + nice_printf(outfile, "while(" /*)*/ ); + } + + static void +do_p1_2while(infile, outfile) + FILE *infile, *outfile; +{ + 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 +do_p1_elseifstart(outfile) + FILE *outfile; +{ + if (*ei_next++) { + prev_tab(outfile); + nice_printf(outfile, /*{*/ + "} else /* if(complicated condition) */ {\n" /*}*/ ); + next_tab(outfile); + } + } diff --git a/lang/fortran/comp/format.h b/lang/fortran/comp/format.h new file mode 100644 index 000000000..a88c03892 --- /dev/null +++ b/lang/fortran/comp/format.h @@ -0,0 +1,10 @@ +#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 */ + +char *wr_ardecls (/* FILE *, struct Dimblock * */); +void list_init_data (), wr_one_init (), wr_output_values (); +int do_init_data (); +chainp data_value (); diff --git a/lang/fortran/comp/formatdata.c b/lang/fortran/comp/formatdata.c new file mode 100644 index 000000000..408f07c45 --- /dev/null +++ b/lang/fortran/comp/formatdata.c @@ -0,0 +1,1037 @@ +/**************************************************************** +Copyright 1990 by AT&T Bell Laboratories and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T Bell Laboratories or +Bellcore or any of their entities not be used in advertising or +publicity pertaining to distribution of the software without +specific, written prior permission. + +AT&T and Bellcore disclaim all warranties with regard to this +software, including all implied warranties of merchantability +and fitness. In no event shall AT&T or Bellcore be liable for +any special, indirect or consequential damages or any damages +whatsoever resulting from loss of use, data or profits, whether +in an action of contract, negligence or other tortious action, +arising out of or in connection with the use or performance of +this software. +****************************************************************/ + +#include "defs.h" +#include "output.h" +#include "names.h" +#include "format.h" + +#define MAX_INIT_LINE 100 +#define NAME_MAX 64 + +static int memno2info(); + +extern char *initbname; +extern void def_start(); + +void list_init_data(Infile, Inname, outfile) + FILE **Infile, *outfile; + char *Inname; +{ + 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 do_init_data(outfile, infile) +FILE *outfile, *infile; +{ + char varname[NAME_MAX], ovarname[NAME_MAX]; + ftnint offset; + ftnint type; + int vargroup; /* 0 --> init, 1 --> equiv, 2 --> common */ + int did_one = 0; /* True when one has been output */ + chainp values = CHNULL; /* Actual data values */ + int keepit = 0; + Namep np; + + ovarname[0] = '\0'; + + while (rdname (infile, &vargroup, varname) && rdlong (infile, &offset) + && rdlong (infile, &type)) { + if (strcmp (varname, ovarname)) { + + /* If this is a new variable name, the old initialization has been + completed */ + + wr_one_init(outfile, ovarname, &values, keepit); + + strcpy (ovarname, varname); + values = CHNULL; + if (vargroup == 0) { + if (memno2info(atoi(varname+2), &np)) { + if (((Addrp)np)->uname_tag != UNAM_NAME) { + err("do_init_data: expected NAME"); + goto Keep; + } + np = ((Addrp)np)->user.name; + } + if (!(keepit = np->visused) && !np->vimpldovar) + warn1("local variable %s never used", + np->fvarname); + } + else { + Keep: + keepit = 1; + } + if (keepit && !did_one) { + nice_printf (outfile, "/* Initialized data */\n\n"); + did_one = YES; + } + } /* if strcmp */ + + values = mkchain((char *)data_value(infile, offset, (int)type), values); + } /* while */ + +/* Write out the last declaration */ + + wr_one_init (outfile, ovarname, &values, keepit); + + return did_one; +} /* do_init_data */ + + + ftnint +wr_char_len(outfile, dimp, n, extra1) + FILE *outfile; + int n; + struct Dimblock *dimp; + int extra1; +{ + int i, nd; + expptr e; + ftnint rv; + + if (!dimp) { + nice_printf (outfile, extra1 ? "[%d+1]" : "[%d]", n); + return n + extra1; + } + nice_printf(outfile, "[%d", n); + nd = dimp->ndim; + rv = n; + for(i = 0; i < nd; i++) { + e = dimp->dims[i].dimsize; + if (!ISICON (e)) + err ("wr_char_len: nonconstant array size"); + else { + nice_printf(outfile, "*%ld", e->constblock.Const.ci); + rv *= e->constblock.Const.ci; + } + } + /* 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 +write_char_init(outfile, Values, namep) + FILE *outfile; + chainp *Values; + Namep namep; +{ + struct Equivblock *eqv; + long size; + struct Dimblock *dimp; + int i, nd, type; + 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 (!ISICON(ds)) + err("write_char_values: nonconstant array size"); + else + size *= ds->constblock.Const.ci; + } + *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) + ind_printf(0, outfile, "((char *)&equiv_%d)\n\n", eqvmemno); + else + ind_printf(0, 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 wr_one_init (outfile, varname, Values, keepit) +FILE *outfile; +char *varname; +chainp *Values; +int keepit; +{ + static int memno; + static union { + Namep name; + Addrp addr; + } info; + Namep namep; + int is_addr, size, type; + ftnint last, loc; + int is_scalar = 0; + char *array_comment = NULL, *name; + chainp cp, values; + extern char datachar[]; + static int e1[3] = {1, 0, 1}; + ftnint x; + extern int hsize; + + if (!keepit) + goto done; + if (varname == NULL || varname[1] != '.') + goto badvar; + +/* Get back to a meaningful representation; find the given memno in one + of the appropriate tables (user-generated variables in the hash table, + system-generated variables in a separate list */ + + memno = atoi(varname + 2); + switch(varname[0]) { + case 'q': + /* Must subtract eqvstart when the source file + * contains more than one procedure. + */ + wr_equiv_init(outfile, eqvmemno = memno - eqvstart, Values, 0); + goto done; + case 'Q': + /* COMMON initialization (BLOCK DATA) */ + wr_equiv_init(outfile, memno, Values, 1); + goto done; + case 'v': + break; + default: + badvar: + errstr("wr_one_init: unknown variable name '%s'", varname); + goto done; + } + + is_addr = memno2info (memno, &info.name); + if (info.name == (Namep) NULL) { + err ("wr_one_init -- unknown variable"); + return; + } + if (is_addr) { + if (info.addr -> uname_tag != UNAM_NAME) { + erri ("wr_one_init -- couldn't get name pointer; tag is %d", + info.addr -> uname_tag); + namep = (Namep) NULL; + nice_printf (outfile, " /* bad init data */"); + } else + namep = info.addr -> user.name; + } else + namep = info.name; + + /* check for character initialization */ + + *Values = values = revchain(*Values); + type = info.name->vtype; + if (type == TYCHAR) { + for(last = 0; values; values = values->nextp) { + cp = (chainp)values->datap; + loc = (ftnint)cp->datap; + if (loc > last) { + write_char_init(outfile, Values, namep); + goto done; + } + last = (int)cp->nextp->datap == TYBLANK + ? loc + (int)cp->nextp->nextp->datap + : loc + 1; + } + if (halign && info.name->tag == TNAME) { + nice_printf(outfile, "static struct { %s fill; char val", + halign); + x = wr_char_len(outfile, namep->vdim, ch_ar_dim = + info.name -> vleng -> constblock.Const.ci, 1); + if (x %= hsize) + nice_printf(outfile, "; char fill2[%ld]", hsize - x); + name = info.name->cvarname; + nice_printf(outfile, "; } %s_st = { 0,", name); + wr_output_values(outfile, namep, *Values); + nice_printf(outfile, " };\n"); + ch_ar_dim = -1; + def_start(outfile, name, CNULL, name); + ind_printf(0, outfile, "_st.val\n"); + goto done; + } + } + else { + size = typesize[type]; + loc = 0; + for(; values; values = values->nextp) { + if ((int)((chainp)values->datap)->nextp->datap == TYCHAR) { + write_char_init(outfile, Values, namep); + goto done; + } + last = ((long) ((chainp) values->datap)->datap) / size; + if (last - loc > 4) { + write_char_init(outfile, Values, namep); + goto done; + } + loc = last; + } + } + values = *Values; + + nice_printf (outfile, "static %s ", c_type_decl (type, 0)); + + if (is_addr) + write_nv_ident (outfile, info.addr); + else + out_name (outfile, info.name); + + if (namep) + is_scalar = namep -> vdim == (struct Dimblock *) NULL; + + if (namep && !is_scalar) + array_comment = type == TYCHAR + ? 0 : wr_ardecls(outfile, namep->vdim, 1L); + + if (type == TYCHAR) + if (ISICON (info.name -> vleng)) + +/* We'll make single strings one character longer, so that we can use the + standard C initialization. All this does is pad an extra zero onto the + end of the string */ + wr_char_len(outfile, namep->vdim, ch_ar_dim = + info.name -> vleng -> constblock.Const.ci, e1[Ansi]); + else + err ("variable length character initialization"); + + if (array_comment) + nice_printf (outfile, "%s", array_comment); + + nice_printf (outfile, " = "); + wr_output_values (outfile, namep, values); + ch_ar_dim = -1; + nice_printf (outfile, ";\n"); + done: + frchain(Values); +} /* wr_one_init */ + + + + +chainp data_value (infile, offset, type) +FILE *infile; +ftnint offset; +int type; +{ + char line[MAX_INIT_LINE + 1], *pointer; + chainp vals, prev_val; + long atol(); + char *newval; + + if (fgets (line, MAX_INIT_LINE, infile) == NULL) { + err ("data_value: error reading from intermediate file"); + return CHNULL; + } /* if fgets */ + +/* Get rid of the trailing newline */ + + if (line[0]) + line[strlen (line) - 1] = '\0'; + +#define iswhite(x) (isspace (x) || (x) == ',') + + pointer = line; + prev_val = vals = CHNULL; + + while (*pointer) { + register char *end_ptr, old_val; + +/* Move pointer to the start of the next word */ + + while (*pointer && iswhite (*pointer)) + pointer++; + if (*pointer == '\0') + break; + +/* Move end_ptr to the end of the current word */ + + for (end_ptr = pointer + 1; *end_ptr && !iswhite (*end_ptr); + end_ptr++) + ; + + old_val = *end_ptr; + *end_ptr = '\0'; + +/* Add this value to the end of the list */ + + if (ONEOF(type, MSKREAL|MSKCOMPLEX)) + newval = cpstring(pointer); + else + newval = (char *)atol(pointer); + if (vals) { + prev_val->nextp = mkchain(newval, CHNULL); + prev_val = prev_val -> nextp; + } else + prev_val = vals = mkchain(newval, CHNULL); + *end_ptr = old_val; + pointer = end_ptr; + } /* while *pointer */ + + return mkchain((char *)offset, mkchain((char *)type, vals)); +} /* data_value */ + + static void +overlapping() +{ + 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(); + static long charlen; + +void wr_output_values (outfile, namep, values) +FILE *outfile; +Namep namep; +chainp values; +{ + int type = TYUNKNOWN; + struct Constblock Const; + static expptr Vlen; + + if (namep) + type = namep -> vtype; + +/* Handle array initializations away from scalars */ + + if (namep && namep -> vdim) + wr_array_init (outfile, namep -> vtype, values); + + else if (values->nextp && type != TYCHAR) + overlapping(); + + else { + make_one_const(type, &Const.Const, values); + Const.vtype = type; + Const.vstg = ONEOF(type, MSKREAL|MSKCOMPLEX); + if (type== TYCHAR) { + if (!Vlen) + Vlen = ICON(0); + Const.vleng = Vlen; + Vlen->constblock.Const.ci = charlen; + out_const (outfile, &Const); + free (Const.Const.ccp); + } + else + out_const (outfile, &Const); + } + } + + +wr_array_init (outfile, type, values) +FILE *outfile; +int type; +chainp values; +{ + int size = typesize[type]; + long index, main_index = 0; + int k; + + if (type == TYCHAR) { + nice_printf(outfile, "\""); + k = 0; + if (Ansi != 1) + ch_ar_dim = -1; + } + else + nice_printf (outfile, "{ "); + while (values) { + struct Constblock Const; + + index = ((long) ((chainp) values->datap)->datap) / size; + while (index > main_index) { + +/* Fill with zeros. The structure shorthand works because the compiler + will expand the "0" in braces to fill the size of the entire structure + */ + + switch (type) { + case TYREAL: + case TYDREAL: + nice_printf (outfile, "0.0,"); + break; + case TYCOMPLEX: + case TYDCOMPLEX: + nice_printf (outfile, "{0},"); + break; + case TYCHAR: + nice_printf(outfile, " "); + break; + default: + nice_printf (outfile, "0,"); + break; + } /* switch */ + main_index++; + } /* while index > main_index */ + + if (index < main_index) + overlapping(); + else switch (type) { + case TYCHAR: + { int this_char; + + if (k == ch_ar_dim) { + nice_printf(outfile, "\" \""); + k = 0; + } + this_char = (int) ((chainp) values->datap)-> + nextp->nextp->datap; + if ((int)((chainp)values->datap)->nextp->datap == TYBLANK) { + main_index += this_char; + k += this_char; + while(--this_char >= 0) + nice_printf(outfile, " "); + values = values -> nextp; + continue; + } + nice_printf(outfile, str_fmt[this_char], this_char); + k++; + } /* case TYCHAR */ + break; + + case TYSHORT: + case TYLONG: + case TYREAL: + case TYDREAL: + case TYLOGICAL: + case TYCOMPLEX: + case TYDCOMPLEX: + make_one_const(type, &Const.Const, values); + Const.vtype = type; + Const.vstg = ONEOF(type, MSKREAL|MSKCOMPLEX); + 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 +make_one_const(type, storage, values) + int type; + union Constant *storage; + chainp values; +{ + union Constant *Const; + register char **L; + + if (type == TYCHAR) { + char *str, *str_ptr; + chainp v, prev; + int b = 0, k, main_index = 0; + +/* Find the max length of init string, by finding the highest offset + value stored in the list of initial values */ + + for(k = 1, prev = CHNULL, v = values; v; prev = v, v = v->nextp) + ; + if (prev != CHNULL) + k = ((int) (((chainp) prev->datap)->datap)) + 2; + /* + 2 above for null char at end */ + str = Alloc (k); + for (str_ptr = str; values; str_ptr++) { + int index = (int) (((chainp) values->datap)->datap); + + if (index < main_index) + overlapping(); + while (index > main_index++) + *str_ptr++ = ' '; + + k = (int) (((chainp) values->datap)->nextp->nextp->datap); + if ((int)((chainp)values->datap)->nextp->datap == TYBLANK) { + b = k; + break; + } + *str_ptr = k; + values = values -> nextp; + } /* for str_ptr */ + *str_ptr = '\0'; + Const = storage; + Const -> ccp = str; + Const -> ccp1.blanks = b; + charlen = str_ptr - str; + } else { + int i = 0; + chainp vals; + + vals = ((chainp)values->datap)->nextp->nextp; + if (vals) { + L = (char **)storage; + do L[i++] = vals->datap; + while(vals = vals->nextp); + } + + } /* else */ + +} /* make_one_const */ + + + +rdname (infile, vargroupp, name) +FILE *infile; +int *vargroupp; +char *name; +{ + register int i, c; + + c = getc (infile); + + if (feof (infile)) + return NO; + + *vargroupp = c - '0'; + for (i = 1;; i++) { + if (i >= NAME_MAX) + Fatal("rdname: oversize name"); + c = getc (infile); + if (feof (infile)) + return NO; + if (c == '\t') + break; + *name++ = c; + } + *name = 0; + return YES; +} /* rdname */ + +rdlong (infile, n) +FILE *infile; +ftnint *n; +{ + 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 +memno2info (memno, info) + int memno; + Namep *info; +{ + 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 +do_string(outfile, v, nloc) + FILEP outfile; + register chainp v; + ftnint *nloc; +{ + register chainp cp, v0; + ftnint dloc, k, loc; + unsigned long uk; + char buf[8], *comma; + + nice_printf(outfile, "{"); + cp = (chainp)v->datap; + loc = (ftnint)cp->datap; + comma = ""; + for(v0 = v;;) { + switch((int)cp->nextp->datap) { + case TYBLANK: + k = (ftnint)cp->nextp->nextp->datap; + loc += k; + while(--k >= 0) { + nice_printf(outfile, "%s' '", comma); + comma = ", "; + } + break; + case TYCHAR: + uk = (ftnint)cp->nextp->nextp->datap; + sprintf(buf, chr_fmt[uk], uk); + nice_printf(outfile, "%s'%s'", comma, buf); + comma = ", "; + loc++; + break; + default: + goto done; + } + v0 = v; + if (!(v = v->nextp)) + break; + cp = (chainp)v->datap; + dloc = (ftnint)cp->datap; + if (loc != dloc) + break; + } + done: + nice_printf(outfile, "}"); + *nloc = loc; + return v0; + } + + static chainp +Ado_string(outfile, v, nloc) + FILEP outfile; + register chainp v; + ftnint *nloc; +{ + register chainp cp, v0; + ftnint dloc, k, loc; + + nice_printf(outfile, "\""); + cp = (chainp)v->datap; + loc = (ftnint)cp->datap; + for(v0 = v;;) { + switch((int)cp->nextp->datap) { + case TYBLANK: + k = (ftnint)cp->nextp->nextp->datap; + loc += k; + while(--k >= 0) + nice_printf(outfile, " "); + break; + case TYCHAR: + k = (ftnint)cp->nextp->nextp->datap; + nice_printf(outfile, str_fmt[k], k); + loc++; + break; + default: + goto done; + } + v0 = v; + if (!(v = v->nextp)) + break; + cp = (chainp)v->datap; + dloc = (ftnint)cp->datap; + if (loc != dloc) + break; + } + done: + nice_printf(outfile, "\""); + *nloc = loc; + return v0; + } + + static char * +Len(L,type) + long L; + int type; +{ + static char buf[24]; + if (L == 1 && type != TYCHAR) + return ""; + sprintf(buf, "[%ld]", L); + return buf; + } + +wr_equiv_init(outfile, memno, Values, iscomm) + FILE *outfile; + int memno; + chainp *Values; + int iscomm; +{ + struct Equivblock *eqv; + char *equiv_name (); + int curtype, dtype, filltype, filltype1, j, k, wasblank, xtype; + static char Blank[] = ""; + register char *comma = Blank; + register chainp cp, v; + chainp sentinel, values, v1; + ftnint L, L1, dL, dloc, loc, loc0; + union Constant Const; + char imag_buf[50], real_buf[50]; + int szshort = typesize[TYSHORT]; + static char typepref[] = {0, 0, TYSHORT, TYLONG, TYREAL, TYDREAL, + TYREAL, TYDREAL, TYLOGICAL, TYCHAR}; + 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; + + 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 */ + + for(v = *Values;;v = v->nextp) { + if (!v) { + dtype = typepref[xtype]; + z = ISREAL(dtype) ? cpstring("0.") : (char *)0; + k = typesize[dtype]; + if (j = L % k) + L += k - j; + v = mkchain((char *)L, + mkchain((char *)dtype, + mkchain(z, CHNULL))); + *Values = mkchain((char *)v, *Values); + L += k; + break; + } + if ((int)((chainp)v->datap)->nextp->datap == xtype) + break; + } + } + + sentinel = mkchain((char *)L, mkchain((char *)TYERROR,CHNULL)); + *Values = values = revchain(mkchain((char *)sentinel, *Values)); + + /* use doublereal fillers only if there are doublereal values */ + + k = TYLONG; + for(v = values; v; v = v->nextp) + if (ONEOF((int)((chainp)v->datap)->nextp->datap, + M(TYDREAL)|M(TYDCOMPLEX))) { + k = TYDREAL; + break; + } + type_choice[0] = k; + + nice_printf(outfile, "%sstruct {\n", iscomm ? "" : "static "); + next_tab(outfile); + loc = loc0 = k = 0; + curtype = -1; + for(v = values; v; v = v->nextp) { + cp = (chainp)v->datap; + dloc = (ftnint)cp->datap; + L = dloc - loc; + if (L < 0) { + overlapping(); + v1 = cp; + frchain(&v1); + v->datap = 0; + continue; + } + dtype = (int)cp->nextp->datap; + if (dtype == TYBLANK) { + dtype = TYCHAR; + wasblank = 1; + } + else + wasblank = 0; + if (curtype != dtype || L > 0) { + if (curtype != -1) { + L1 = (loc - loc0)/dL; + nice_printf(outfile, "%s e_%d%s;\n", + typename[curtype], ++k, + Len(L1,curtype)); + } + curtype = dtype; + loc0 = dloc; + } + if (L > 0) { + if (xtype == TYCHAR) + filltype = TYCHAR; + else { + filltype = L % szshort ? TYCHAR + : type_choice[L/szshort % 4]; + filltype1 = loc % szshort ? TYCHAR + : type_choice[loc/szshort % 4]; + if (typesize[filltype] > typesize[filltype1]) + filltype = filltype1; + } + L1 = L / typesize[filltype]; + nice_printf(outfile, "%s fill_%d[%ld];\n", + typename[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; + for(v = values; ; v = v->nextp) { + cp = (chainp)v->datap; + if (!cp) + continue; + dtype = (int)cp->nextp->datap; + if (dtype == TYERROR) + break; + dloc = (ftnint)cp->datap; + if (dloc > loc) { + 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: + 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 TYSHORT: + case TYLONG: + nice_printf(outfile, "%ld", Const.ci); + break; + case TYREAL: + nice_printf(outfile, "%s", + flconst(real_buf, Const.cds[0])); + break; + case TYDREAL: + nice_printf(outfile, "%s", Const.cds[0]); + break; + case TYCOMPLEX: + nice_printf(outfile, "%s, %s", + flconst(real_buf, Const.cds[0]), + flconst(imag_buf, Const.cds[1])); + break; + case TYDCOMPLEX: + nice_printf(outfile, "%s, %s", + Const.cds[0], Const.cds[1]); + break; + default: + erri("unexpected type %d in wr_equiv_init", + dtype); + } + loc += typesize[dtype]; + } + nice_printf(outfile, " };\n\n"); + prev_tab(outfile); + frchain(&sentinel); + } diff --git a/lang/fortran/comp/ftypes.h b/lang/fortran/comp/ftypes.h new file mode 100644 index 000000000..c8eb9b4c7 --- /dev/null +++ b/lang/fortran/comp/ftypes.h @@ -0,0 +1,39 @@ + +/* variable types (stored in the vtype field of expptr) + * numeric assumptions: + * int < reals < complexes + * TYDREAL-TYREAL = TYDCOMPLEX-TYCOMPLEX + */ + +#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 TYERROR 11 +#define TYCILIST 12 +#define TYICILIST 13 +#define TYOLIST 14 +#define TYCLLIST 15 +#define TYALIST 16 +#define TYINLIST 17 +#define TYVOID 18 +#define TYLABEL 19 +#define TYFTNLEN 20 +/* 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/lang/fortran/comp/gram.dcl b/lang/fortran/comp/gram.dcl new file mode 100644 index 000000000..1d598ad72 --- /dev/null +++ b/lang/fortran/comp/gram.dcl @@ -0,0 +1,399 @@ +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; + if (vartype == TYLOGICAL && varleng == 1) { + varleng = 0; + err("treating LOGICAL*1 as LOGICAL"); + --nerr; /* allow generation of .c file */ + } + } + ; + +typespec: typename + { varleng = ($1<0 || $1==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; } + ; + +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 = (struct Primblock *)$1; + } + | equivlist SCOMMA lhs + { $$=ALLOC(Eqvchain); + $$->eqvitem.eqvlhs = (struct Primblock *) $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; + np = ( (struct Primblock *) $1) -> namep; + vardcl(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) + dclerr("inconsistent storage classes", np); + $$ = 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/lang/fortran/comp/gram.exec b/lang/fortran/comp/gram.exec new file mode 100644 index 000000000..31c03dab9 --- /dev/null +++ b/lang/fortran/comp/gram.exec @@ -0,0 +1,143 @@ +exec: iffable + | SDO end_spec intonlyon label intonlyoff opt_comma dospecw + { + if($4->labdefined) + execerr("no backward DO loops", CNULL); + $4->blklevel = blklevel+1; + exdo($4->labelno, NPNULL, $7); + } + | SDO end_spec opt_comma dospecw + { + exdo((int)(ctls - ctlstack - 2), NPNULL, $4); + NOEXT("DO without label"); + } + | SENDDO + { exenddo(NPNULL); } + | logif iffable + { exendif(); thiswasbranch = NO; } + | logif STHEN + | SELSEIF end_spec SLPAR expr SRPAR STHEN + { exelif($4); lastwasbranch = NO; } + | SELSE end_spec + { exelse(); lastwasbranch = NO; } + | SENDIF end_spec + { exendif(); lastwasbranch = NO; } + ; + +logif: SLOGIF end_spec SLPAR expr SRPAR + { exif($4); } + ; + +dospec: name SEQUALS exprlist + { $$ = mkchain((char *)$1, $3); } + ; + +dospecw: dospec + | SWHILE SLPAR expr SRPAR + { $$ = mkchain(CNULL, (chainp)$3); } + ; + +iffable: let lhs SEQUALS expr + { exequals((struct Primblock *)$2, $4); } + | SASSIGN end_spec assignlabel STO name + { exassign($5, $3); } + | SCONTINUE end_spec + | goto + | io + { inioctl = NO; } + | SARITHIF end_spec SLPAR expr SRPAR label SCOMMA label SCOMMA label + { exarif($4, $6, $8, $10); thiswasbranch = YES; } + | call + { excall($1, LBNULL, 0, labarray); } + | call SLPAR SRPAR + { excall($1, LBNULL, 0, labarray); } + | call SLPAR callarglist SRPAR + { if(nstars < MAXLABLIST) + excall($1, mklist(revchain($3)), nstars, labarray); + else + err("too many alternate returns"); + } + | 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 + err("computed GOTO list too long"); + } + ; + +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(nstarsvclass == CLPARAM) + $$ = (expptr) cpexpr( + ( (struct Paramblock *) ($1) ) -> paramval); + } + | simple_const + ; + +simple_const: STRUE { $$ = mklogcon(1); } + | SFALSE { $$ = mklogcon(0); } + | SHOLLERITH { $$ = mkstrcon(toklen, token); } + | SICON = { $$ = mkintcon( convci(toklen, token) ); } + | SRCON = { $$ = mkrealcon(tyreal, token); } + | SDCON = { $$ = mkrealcon(TYDREAL, token); } + | bit_const + ; + +complex_const: SLPAR uexpr SCOMMA uexpr SRPAR + { $$ = mkcxcon($2,$4); } + ; + +bit_const: SHEXCON + { NOEXT("hex constant"); + $$ = mkbitcon(4, toklen, token); } + | SOCTCON + { NOEXT("octal constant"); + $$ = mkbitcon(3, toklen, token); } + | SBITCON + { NOEXT("binary constant"); + $$ = mkbitcon(1, toklen, token); } + ; + +fexpr: unpar_fexpr + | SLPAR fexpr SRPAR + { $$ = $2; } + ; + +unpar_fexpr: lhs + | simple_const + | fexpr addop fexpr %prec SPLUS + { $$ = mkexpr($2, $1, $3); } + | fexpr SSTAR fexpr + { $$ = mkexpr(OPSTAR, $1, $3); } + | fexpr SSLASH fexpr + { $$ = mkexpr(OPSLASH, $1, $3); } + | fexpr SPOWER fexpr + { $$ = mkexpr(OPPOWER, $1, $3); } + | addop fexpr %prec SSTAR + { if($1 == OPMINUS) + $$ = mkexpr(OPNEG, $2, ENULL); + else $$ = $2; + } + | fexpr SCONCAT fexpr + { NO66("concatenation operator //"); + $$ = mkexpr(OPCONCAT, $1, $3); } + ; diff --git a/lang/fortran/comp/gram.head b/lang/fortran/comp/gram.head new file mode 100644 index 000000000..c844feb40 --- /dev/null +++ b/lang/fortran/comp/gram.head @@ -0,0 +1,299 @@ +/**************************************************************** +Copyright 1990 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]; +static struct Labelblock *labarray[MAXLABLIST]; /* Labels in an alternate + return CALL */ + +/* 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 */ + +ftnint convci(); +Addrp nextdata(); +expptr mklogcon(), mkaddcon(), mkrealcon(), mkstrcon(), mkbitcon(); +expptr mkcxcon(); +struct Listblock *mklist(); +struct Listblock *mklist(); +struct Impldoblock *mkiodo(); +Extsym *comblock(); +#define ESNULL (Extsym *)0 +#define NPNULL (Namep)0 +#define LBNULL (struct Listblock *)0 +extern void freetemps(), make_param(); + + static void +pop_datastack() { + chainp d0 = datastack; + if (d0->datap) + curdtp = (chainp)d0->datap; + datastack = d0->nextp; + d0->nextp = 0; + frchain(&d0); + } + +%} + +/* Specify precedences and associativities. */ + +%union { + int ival; + ftnint lval; + char *charpval; + chainp chval; + tagptr tagval; + expptr expval; + struct Labelblock *labval; + struct Nameblock *namval; + struct Eqvchain *eqvval; + Extsym *extval; + } + +%left SCOMMA +%nonassoc SCOLON +%right SEQUALS +%left SEQV SNEQV +%left SOR +%left SAND +%left SNOT +%nonassoc SLT SGT SLE SGE SEQ SNE +%left SCONCAT +%left SPLUS SMINUS +%left SSTAR SSLASH +%right SPOWER + +%start program +%type thislabel label assignlabel +%type other inelt +%type type typespec typename dcl letter addop relop stop nameeq +%type lengspec +%type filename +%type datavar datavarlist namelistlist funarglist funargs +%type dospec dospecw +%type callarglist arglist args exprlist inlist outlist out2 substring +%type name arg call var +%type lhs expr uexpr opt_expr fexpr unpar_fexpr +%type ubound simple value callarg complex_const simple_const bit_const +%type common comblock entryname progname +%type equivlist + +%% + +program: + | program stat SEOS + ; + +stat: thislabel entry + { +/* stat: is the nonterminal for Fortran statements */ + + lastwasbranch = NO; } + | thislabel spec + | thislabel exec + { /* forbid further statement function definitions... */ + if (parstate == INDATA && laststfcn != thisstno) + parstate = INEXEC; + thisstno++; + if($1 && ($1->labelno==dorange)) + enddo($1->labelno); + if(lastwasbranch && thislabel==NULL) + warn("statement cannot be reached"); + lastwasbranch = thiswasbranch; + thiswasbranch = NO; + if($1) + { + if($1->labtype == LABFORMAT) + err("label already that of a format"); + else + $1->labtype = LABEXEC; + } + freetemps(); + } + | thislabel SINCLUDE filename + { if (can_include) + doinclude( $3 ); + else { + fprintf(diagfile, "Cannot open file %s\n", $3); + done(1); + } + } + | thislabel SEND end_spec + { if ($1) + lastwasbranch = NO; + endproc(); /* lastwasbranch = NO; -- set in endproc() */ + } + | thislabel SUNKNOWN + { extern void unclassifiable(); + unclassifiable(); + +/* flline flushes the current line, ignoring the rest of the text there */ + + flline(); }; + | error + { flline(); needkwd = NO; inioctl = NO; + yyerrok; yyclearin; } + ; + +thislabel: SLABEL + { + if(yystno != 0) + { + $$ = thislabel = mklabel(yystno); + if( ! headerdone ) { + if (procclass == CLUNKNOWN) + procclass = CLMAIN; + puthead(CNULL, procclass); + } + if(thislabel->labdefined) + execerr("label %s already defined", + convic(thislabel->stateno) ); + else { + if(thislabel->blklevel!=0 && thislabel->blklevellabtype!=LABFORMAT) + warn1("there is a branch to label %s from outside block", + convic( (ftnint) (thislabel->stateno) ) ); + thislabel->blklevel = blklevel; + thislabel->labdefined = YES; + if(thislabel->labtype != LABFORMAT) + p1_label((long)(thislabel - labeltab)); + } + } + else $$ = thislabel = NULL; + } + ; + +entry: SPROGRAM new_proc progname + {startproc($3, CLMAIN); } + | SPROGRAM new_proc progname progarglist + { warn("ignoring arguments to main program"); + /* hashclear(); */ + startproc($3, CLMAIN); } + | SBLOCK new_proc progname + { if($3) NO66("named BLOCKDATA"); + startproc($3, CLBLOCK); } + | SSUBROUTINE new_proc entryname arglist + { entrypt(CLPROC, TYSUBR, (ftnint) 0, $3, $4); } + | SFUNCTION new_proc entryname arglist + { entrypt(CLPROC, TYUNKNOWN, (ftnint) 0, $3, $4); } + | type SFUNCTION new_proc entryname arglist + { entrypt(CLPROC, $1, varleng, $4, $5); } + | SENTRY entryname arglist + { if(parstate==OUTSIDE || procclass==CLMAIN + || procclass==CLBLOCK) + execerr("misplaced entry statement", CNULL); + entrypt(CLENTRY, 0, (ftnint) 0, $2, $3); + } + ; + +new_proc: + { newproc(); } + ; + +entryname: name + { $$ = newentry($1, 1); } + ; + +name: SNAME + { $$ = mkname(token); } + ; + +progname: { $$ = NULL; } + | entryname + ; + +progarglist: + SLPAR SRPAR + | SLPAR progargs SRPAR + ; + +progargs: progarg + | progargs SCOMMA progarg + ; + +progarg: SNAME + | SNAME SEQUALS SNAME + ; + +arglist: + { $$ = 0; } + | SLPAR SRPAR + { NO66(" () argument list"); + $$ = 0; } + | SLPAR args SRPAR + {$$ = $2; } + ; + +args: arg + { $$ = ($1 ? mkchain((char *)$1,CHNULL) : CHNULL ); } + | args SCOMMA arg + { if($3) $1 = $$ = mkchain((char *)$3, $1); } + ; + +arg: name + { if($1->vstg!=STGUNKNOWN && $1->vstg!=STGARG) + dclerr("name declared as argument after use", $1); + $1->vstg = STGARG; + } + | SSTAR + { NO66("altenate return argument"); + +/* substars means that '*'ed formal parameters should be replaced. + This is used to specify alternate return labels; in theory, only + parameter slots which have '*' should accept the statement labels. + This compiler chooses to ignore the '*'s in the formal declaration, and + always return the proper value anyway. + + This variable is only referred to in proc.c */ + + $$ = 0; substars = YES; } + ; + + + +filename: SHOLLERITH + { + char *s; + s = copyn(toklen+1, token); + s[toklen] = '\0'; + $$ = s; + } + ; diff --git a/lang/fortran/comp/gram.io b/lang/fortran/comp/gram.io new file mode 100644 index 000000000..f1a6649aa --- /dev/null +++ b/lang/fortran/comp/gram.io @@ -0,0 +1,173 @@ + /* Input/Output Statements */ + +io: io1 + { endio(); } + ; + +io1: iofmove ioctl + | iofmove unpar_fexpr + { ioclause(IOSUNIT, $2); endioctl(); } + | iofmove SSTAR + { ioclause(IOSUNIT, ENULL); endioctl(); } + | iofmove SPOWER + { ioclause(IOSUNIT, IOSTDERR); endioctl(); } + | iofctl ioctl + | read ioctl + { doio(CHNULL); } + | read infmt + { doio(CHNULL); } + | read ioctl inlist + { doio(revchain($3)); } + | read infmt SCOMMA inlist + { doio(revchain($4)); } + | read ioctl SCOMMA inlist + { doio(revchain($4)); } + | write ioctl + { doio(CHNULL); } + | write ioctl outlist + { doio(revchain($3)); } + | print + { doio(CHNULL); } + | print SCOMMA outlist + { doio(revchain($3)); } + ; + +iofmove: fmkwd end_spec in_ioctl + ; + +fmkwd: SBACKSPACE + { iostmt = IOBACKSPACE; } + | SREWIND + { iostmt = IOREWIND; } + | SENDFILE + { iostmt = IOENDFILE; } + ; + +iofctl: ctlkwd end_spec in_ioctl + ; + +ctlkwd: SINQUIRE + { iostmt = IOINQUIRE; } + | SOPEN + { iostmt = IOOPEN; } + | SCLOSE + { iostmt = IOCLOSE; } + ; + +infmt: unpar_fexpr + { + ioclause(IOSUNIT, ENULL); + ioclause(IOSFMT, $1); + endioctl(); + } + | SSTAR + { + ioclause(IOSUNIT, ENULL); + ioclause(IOSFMT, ENULL); + endioctl(); + } + ; + +ioctl: SLPAR fexpr SRPAR + { + ioclause(IOSUNIT, $2); + endioctl(); + } + | SLPAR ctllist SRPAR + { endioctl(); } + ; + +ctllist: ioclause + | ctllist SCOMMA ioclause + ; + +ioclause: fexpr + { ioclause(IOSPOSITIONAL, $1); } + | SSTAR + { ioclause(IOSPOSITIONAL, ENULL); } + | SPOWER + { ioclause(IOSPOSITIONAL, IOSTDERR); } + | nameeq expr + { ioclause($1, $2); } + | nameeq SSTAR + { ioclause($1, ENULL); } + | nameeq SPOWER + { ioclause($1, IOSTDERR); } + ; + +nameeq: SNAMEEQ + { $$ = iocname(); } + ; + +read: SREAD end_spec in_ioctl + { iostmt = IOREAD; } + ; + +write: SWRITE end_spec in_ioctl + { iostmt = IOWRITE; } + ; + +print: SPRINT end_spec fexpr in_ioctl + { + iostmt = IOWRITE; + ioclause(IOSUNIT, ENULL); + ioclause(IOSFMT, $3); + endioctl(); + } + | SPRINT end_spec SSTAR in_ioctl + { + iostmt = IOWRITE; + ioclause(IOSUNIT, ENULL); + ioclause(IOSFMT, ENULL); + endioctl(); + } + ; + +inlist: inelt + { $$ = mkchain((char *)$1, CHNULL); } + | inlist SCOMMA inelt + { $$ = mkchain((char *)$3, $1); } + ; + +inelt: lhs + { $$ = (tagptr) $1; } + | SLPAR inlist SCOMMA dospec SRPAR + { $$ = (tagptr) mkiodo($4,revchain($2)); } + ; + +outlist: uexpr + { $$ = mkchain((char *)$1, CHNULL); } + | other + { $$ = mkchain((char *)$1, CHNULL); } + | out2 + ; + +out2: uexpr SCOMMA uexpr + { $$ = mkchain((char *)$3, mkchain((char *)$1, CHNULL) ); } + | uexpr SCOMMA other + { $$ = mkchain((char *)$3, mkchain((char *)$1, CHNULL) ); } + | other SCOMMA uexpr + { $$ = mkchain((char *)$3, mkchain((char *)$1, CHNULL) ); } + | other SCOMMA other + { $$ = mkchain((char *)$3, mkchain((char *)$1, CHNULL) ); } + | out2 SCOMMA uexpr + { $$ = mkchain((char *)$3, $1); } + | out2 SCOMMA other + { $$ = mkchain((char *)$3, $1); } + ; + +other: complex_const + { $$ = (tagptr) $1; } + | SLPAR expr SRPAR + { $$ = (tagptr) $2; } + | SLPAR uexpr SCOMMA dospec SRPAR + { $$ = (tagptr) mkiodo($4, mkchain((char *)$2, CHNULL) ); } + | SLPAR other SCOMMA dospec SRPAR + { $$ = (tagptr) mkiodo($4, mkchain((char *)$2, CHNULL) ); } + | SLPAR out2 SCOMMA dospec SRPAR + { $$ = (tagptr) mkiodo($4, revchain($2)); } + ; + +in_ioctl: + { startioctl(); } + ; diff --git a/lang/fortran/comp/init.c b/lang/fortran/comp/init.c new file mode 100644 index 000000000..590ba13fa --- /dev/null +++ b/lang/fortran/comp/init.c @@ -0,0 +1,446 @@ +/**************************************************************** +Copyright 1990 by AT&T Bell Laboratories and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T Bell Laboratories or +Bellcore or any of their entities not be used in advertising or +publicity pertaining to distribution of the software without +specific, written prior permission. + +AT&T and Bellcore disclaim all warranties with regard to this +software, including all implied warranties of merchantability +and fitness. In no event shall AT&T or Bellcore be liable for +any special, indirect or consequential damages or any damages +whatsoever resulting from loss of use, data or profits, whether +in an action of contract, negligence or other tortious action, +arising out of or in connection with the use or performance of +this software. +****************************************************************/ + +#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[MAXTOKENLEN]; +int toklen; +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 typesize[NTYPES] = { + 1, SZADDR, SZSHORT, SZLONG, SZLONG, 2*SZLONG, + 2*SZLONG, 4*SZLONG, 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, ALISHORT, ALILONG, ALILONG, ALIDOUBLE, + ALILONG, ALIDOUBLE, ALILONG, 1, 1, 1, + ALILONG, ALILONG, ALILONG, ALILONG, ALILONG, ALILONG}; + +int type_choice[4] = { TYDREAL, TYSHORT, TYLONG, TYSHORT }; + +char *typename[] = { + "<>", + "address", + "shortint", + "integer", + "real", + "doublereal", + "complex", + "doublecomplex", + "logical", + "char" /* character */ + }; + +int type_pref[NTYPES] = { 0, 0, 2, 4, 5, 7, 6, 8, 3, 1 }; + +char *protorettypes[] = { + "?", "??", "shortint", "integer", "real", "doublereal", + "C_f", "Z_f", "logical", "H_f", "int" + }; + +char *casttypes[TYSUBR+1] = { + "U_fp", "??bug??", + "J_fp", "I_fp", "R_fp", + "D_fp", "C_fp", "Z_fp", + "L_fp", "H_fp", "S_fp" + }; +char *usedcasts[TYSUBR+1]; + +char *dfltarg[] = { + 0, 0, + "(shortint *)0", "(integer *)0", "(real *)0", + "(doublereal *)0", "(complex *)0", "(doublecomplex *)0", + "(logical *)0", "(char *)0" + }; + +static char *dflt0proc[] = { + 0, 0, + "(shortint (*)())0", "(integer (*)())0", "(real (*)())0", + "(doublereal (*)())0", "(complex (*)())0", "(doublecomplex (*)())0", + "(logical (*)())0", "(char (*)())0", "(int (*)())0" + }; + +char *dflt1proc[] = { "(U_fp)0", "(??bug??)0", + "(J_fp)0", "(I_fp)0", "(R_fp)0", + "(D_fp)0", "(C_fp)0", "(Z_fp)0", + "(L_fp)0", "(H_fp)0", "(S_fp)0" + }; + +char **dfltproc = dflt0proc; + +static char Bug[] = "bug"; + +char *ftn_types[] = { "external", "??", + "integer*2", "integer", "real", + "double precision", "complex", "double complex", + "logical", "character", "subroutine", + Bug,Bug,Bug,Bug,Bug,Bug,Bug,Bug,Bug, "ftnlen" + }; + +int init_ac[TYSUBR+1] = { 0,0,0,0,0,0, 1, 1, 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; +int lastlabno; +int lastvarno; +int lastargslot; +int autonum[TYVOID]; +char *av_pfix[TYVOID] = {"??TYUNKNOWN??", "a","s","i","r","d","q","z","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; + +struct Literal *litpool; +int nliterals; + +char dflttype[26]; +char hextoi_tab[Table_size], Letters[Table_size]; +char *ei_first, *ei_next, *ei_last; +char *wh_first, *wh_next, *wh_last; + +#define ALLOCN(n,x) (struct x *) ckalloc((n)*sizeof(struct x)) + +fileinit() +{ + register char *s; + register int i, j; + extern void fmt_init(), mem_init(), np_init(); + + lastiolabno = 100000; + lastlabno = 0; + lastvarno = 0; + nliterals = 0; + nerr = 0; + + infile = stdin; + + memset(dflttype, tyreal, 26); + memset(dflttype + 'i' - 'a', tyint, 6); + memset(hextoi_tab, 16, sizeof(hextoi_tab)); + for(i = 0, s = "0123456789abcdef"; *s; i++, s++) + hextoi(*s) = i; + for(i = 10, s = "ABCDEF"; *s; i++, s++) + hextoi(*s) = i; + for(j = 0, s = "abcdefghijklmnopqrstuvwxyz"; i = *s++; j++) + Letters[i] = Letters[i+'A'-'a'] = j; + + ctls = ALLOCN(maxctl+1, Ctlframe); + extsymtab = ALLOCN(maxext, Extsym); + eqvclass = ALLOCN(maxequiv, Equivblock); + hashtab = ALLOCN(maxhash, Hashentry); + labeltab = ALLOCN(maxstno, Labelblock); + litpool = ALLOCN(maxliterals, Literal); + 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 (); +} + +hashclear() /* 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; + } + } + +procinit() +{ + register struct Labelblock *lp; + struct Chain *cp; + int i; + extern struct memblock *curmemblock, *firstmemblock; + extern char *mem_first, *mem_next, *mem_last, *mem0_last; + extern void frexchain(); + + curmemblock = firstmemblock; + mem_next = mem_first; + mem_last = mem0_last; + ei_next = ei_first = ei_last = 0; + wh_next = wh_first = wh_last = 0; + iob_list = 0; + for(i = 0; i < 9; i++) + io_structs[i] = 0; + + parstate = OUTSIDE; + headerdone = NO; + blklevel = 1; + saveall = NO; + substars = NO; + nwarn = 0; + thislabel = NULL; + needkwd = 0; + + proctype = TYUNKNOWN; + procname = "MAIN_"; + procclass = CLUNKNOWN; + nentry = 0; + nallargs = nallchargs = 0; + multitype = NO; + retslot = NULL; + for(i = 0; i < NTYPES0; i++) { + frexpr((expptr)xretslot[i]); + xretslot[i] = 0; + } + cxslot = -1; + chslot = -1; + chlgslot = -1; + procleng = 0; + blklevel = 1; + lastargslot = 0; + + for(lp = labeltab ; lp < labtabend ; ++lp) + lp->stateno = 0; + + hashclear(); + +/* Clear the list of newly generated identifiers from the previous + function */ + + frexchain(&new_vars); + frexchain(&used_builtins); + frchain(&assigned_fmts); + frchain(&allargs); + frchain(&earlylabs); + + nintnames = 0; + highlabtab = labeltab; + + ctlstack = ctls - 1; + for(i = TYADDR; i < TYVOID; i++) { + for(cp = templist[i]; cp ; cp = cp->nextp) + free( (charptr) (cp->datap) ); + frchain(templist + i); + autonum[i] = 0; + } + holdtemps = NULL; + dorange = 0; + nregvar = 0; + highregvar = 0; + entries = NULL; + rpllist = NULL; + inioctl = NO; + eqvstart += nequiv; + nequiv = 0; + dcomplex_seen = 0; + + for(i = 0 ; i c2) { + sprintf(buff, "characters out of order in implicit:%c-%c", c1, c2); + err(buff); + } + else { + c1 = letter(c1); + c2 = letter(c2); + if(type < 0) + for(i = c1 ; i<=c2 ; ++i) + implstg[i] = - type; + else { + type = lengtype(type, length); + if(type != TYCHAR) + length = 0; + for(i = c1 ; i<=c2 ; ++i) { + impltype[i] = type; + implleng[i] = length; + } + } + } + } diff --git a/lang/fortran/comp/intr.c b/lang/fortran/comp/intr.c new file mode 100644 index 000000000..4920dee8c --- /dev/null +++ b/lang/fortran/comp/intr.c @@ -0,0 +1,846 @@ +/**************************************************************** +Copyright 1990 by AT&T Bell Laboratories and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T Bell Laboratories or +Bellcore or any of their entities not be used in advertising or +publicity pertaining to distribution of the software without +specific, written prior permission. + +AT&T and Bellcore disclaim all warranties with regard to this +software, including all implied warranties of merchantability +and fitness. In no event shall AT&T or Bellcore be liable for +any special, indirect or consequential damages or any damages +whatsoever resulting from loss of use, data or profits, whether +in an action of contract, negligence or other tortious action, +arising out of or in connection with the use or performance of +this software. +****************************************************************/ + +#include "defs.h" +#include "names.h" + +void cast_args (); + +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 */ + }; + +/* 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 }, +"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 }, + +"" }; + + +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() /* adjust tables for -r8 */ +{ + register struct Intrblock *I; + register struct Specblock *S; + + for(I = intrtab; I->intrfname[0]; I++) + if (I->intrval.intrgroup != INTRGEN) + switch(I->intrval.intrstuff) { + case TYREAL: + I->intrval.intrstuff = TYDREAL; + I->intrval.intrno = I->intrval.dblintrno; + break; + case TYCOMPLEX: + I->intrval.intrstuff = TYDCOMPLEX; + I->intrval.intrno = I->intrval.dblintrno; + I->intrval.dblcmplx = 1; + } + + for(S = spectab; S->atype; S++) + switch(S->atype) { + case TYCOMPLEX: + S->atype = TYDCOMPLEX; + if (S->rtype == TYREAL) + S->rtype = TYDREAL; + else if (S->rtype == TYCOMPLEX) + S->rtype = TYDCOMPLEX; + switch(S->spxname[0]) { + case 'r': + S->spxname[0] = 'd'; + break; + case 'c': + S->spxname[0] = 'z'; + break; + default: + Fatal("r8fix bug"); + } + break; + case TYREAL: + S->atype = TYDREAL; + switch(S->rtype) { + case TYREAL: + S->rtype = TYDREAL; + if (S->spxname[0] != 'r') + Fatal("r8fix bug"); + S->spxname[0] = 'd'; + case TYDREAL: /* d_prod */ + break; + + case TYSHORT: + if (!strcmp(S->spxname, "hr_expn")) + S->spxname[1] = 'd'; + else if (!strcmp(S->spxname, "h_nint")) + strcpy(S->spxname, "h_dnnt"); + else Fatal("r8fix bug"); + break; + + case TYLONG: + if (!strcmp(S->spxname, "ir_expn")) + S->spxname[1] = 'd'; + else if (!strcmp(S->spxname, "i_nint")) + strcpy(S->spxname, "i_dnnt"); + else Fatal("r8fix bug"); + break; + + default: + Fatal("r8fix bug"); + } + } + } + +expptr intrcall(np, argsp, nargs) +Namep np; +struct Listblock *argsp; +int nargs; +{ + int i, rettype; + Addrp ap; + register struct Specblock *sp; + register struct Chain *cp; + expptr Inline(), mkcxcon(), mkrealcon(); + expptr q, ep; + int mtype; + int op; + int f1field, f2field, f3field; + + packed.ijunk = np->vardesc.varno; + f1field = packed.bits.f1; + f2field = packed.bits.f2; + f3field = packed.bits.f3; + if(nargs == 0) + goto badnargs; + + mtype = 0; + for(cp = argsp->listp ; cp ; cp = cp->nextp) + { + ep = (expptr)cp->datap; + if( ISCONST(ep) && ep->headblock.vtype==TYSHORT ) + cp->datap = (char *) mkconv(tyint, ep); + mtype = maxtype(mtype, ep->headblock.vtype); + } + + switch(f1field) + { + case 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; + q = mkexpr(op, (expptr)argsp->listp->datap, + (expptr)argsp->listp->nextp->datap); + } + frchain( &(argsp->listp) ); + free( (charptr) argsp); + return(q); + + case INTRCONV: + rettype = f2field; + if(rettype == TYLONG) + rettype = tyint; + if( ISCOMPLEX(rettype) && nargs==2) + { + expptr qr, qi; + qr = (expptr) argsp->listp->datap; + qi = (expptr) argsp->listp->nextp->datap; + 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); + } + else goto badnargs; + + q->headblock.vtype = rettype; + frchain(&(argsp->listp)); + free( (charptr) argsp); + return(q); + + +#if 0 + case INTRCNST: + +/* Machine-dependent f77 stuff that f2c omits: + +intcon contains + radix for short int + radix for long int + radix for single precision + radix for double precision + precision for short int + precision for long int + precision for single precision + precision for double precision + emin for single precision + emin for double precision + emax for single precision + emax for double prcision + largest short int + largest long int + +realcon contains + tiny for single precision + tiny for double precision + huge for single precision + huge for double precision + mrsp (epsilon) for single precision + mrsp (epsilon) for double precision +*/ + { register struct Incstblock *cstp; + extern ftnint intcon[14]; + extern double realcon[6]; + + cstp = consttab + f3field; + for(i=0 ; iatype == mtype) + goto foundconst; + else + ++cstp; + goto badtype; + +foundconst: + switch(cstp->rtype) + { + case TYLONG: + return(mkintcon(intcon[cstp->constno])); + + case TYREAL: + case TYDREAL: + return(mkrealcon(cstp->rtype, + realcon[cstp->constno]) ); + + default: + Fatal("impossible intrinsic constant"); + } + } +#endif + + case INTRGEN: + sp = spectab + f3field; + if(no66flag) + if(sp->atype == mtype) + goto specfunct; + else err66("generic function"); + + for(i=0; iatype == mtype) + goto specfunct; + else + ++sp; + warn1 ("bad argument type to intrinsic %s", np->fvarname); + +/* Made this a warning rather than an error so things like "log (5) ==> + log (5.0)" can be accommodated. When none of these cases matches, the + argument is cast up to the first type in the spectab list; this first + type is assumed to be the "smallest" type, e.g. REAL before DREAL + before COMPLEX, before DCOMPLEX */ + + sp = spectab + f3field; + mtype = sp -> atype; + goto specfunct; + + case INTRSPEC: + sp = spectab + f3field; +specfunct: + if(tyint==TYLONG && ONEOF(sp->rtype,M(TYSHORT)|M(TYLOGICAL)) + && (sp+1)->atype==sp->atype) + ++sp; + + if(nargs != sp->nargs) + goto badnargs; + if(mtype != sp->atype) + goto badtype; + +/* NOTE!! I moved fixargs (YES) into the ELSE branch so that constants in + the inline expression wouldn't get put into the constant table */ + + fixargs (NO, argsp); + cast_args (mtype, argsp -> listp); + + if(q = Inline((int)(sp-spectab), mtype, argsp->listp)) + { + frchain( &(argsp->listp) ); + free( (charptr) argsp); + } else { + + if(sp->othername) { + /* C library routines that return double... */ + /* sp->rtype might be TYREAL */ + ap = builtin(sp->rtype, + callbyvalue[sp->othername], 1); + q = fixexpr((Exprp) + mkexpr(OPCCALL, (expptr)ap, (expptr)argsp) ); + } else { + fixargs(YES, argsp); + ap = builtin(sp->rtype, sp->spxname, 0); + q = fixexpr((Exprp) + mkexpr(OPCALL, (expptr)ap, (expptr)argsp) ); + } /* else */ + } /* else */ + return(q); + + case INTRMIN: + case INTRMAX: + if(nargs < 2) + goto badnargs; + if( ! ONEOF(mtype, MSKINT|MSKREAL) ) + goto badtype; + argsp->vtype = mtype; + 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() ); +} + + + + +intrfunct(s) +char *s; +{ + register struct Intrblock *p; + + for(p = intrtab; p->intrval.intrgroup!=INTREND ; ++p) + { + if( !strcmp(s, p->intrfname) ) + { + 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 intraddr(np) +Namep np; +{ + 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; + q = builtin(sp->rtype, sp->spxname, + sp->othername ? 1 : 0); + return(q); + + case INTRCONV: + case INTRMIN: + case INTRMAX: + case INTRBOOL: + case INTRCNST: +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 cast_args (maxtype, args) +int maxtype; +chainp args; +{ + 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 Inline(fno, type, args) +int fno; +int type; +struct Chain *args; +{ + 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(q); + + case 14: /* half-integer mod */ + case 15: /* mod */ + return mkexpr(OPMOD, (expptr) args->datap, + (expptr) args->nextp->datap); + } + return(NULL); +} diff --git a/lang/fortran/comp/io.c b/lang/fortran/comp/io.c new file mode 100644 index 000000000..f346b7f1b --- /dev/null +++ b/lang/fortran/comp/io.c @@ -0,0 +1,1416 @@ +/**************************************************************** +Copyright 1990, 1991 by AT&T Bell Laboratories and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T Bell Laboratories or +Bellcore or any of their entities not be used in advertising or +publicity pertaining to distribution of the software without +specific, written prior permission. + +AT&T and Bellcore disclaim all warranties with regard to this +software, including all implied warranties of merchantability +and fitness. In no event shall AT&T or Bellcore be liable for +any special, indirect or consequential damages or any damages +whatsoever resulting from loss of use, data or profits, whether +in an action of contract, negligence or other tortious action, +arising out of or in connection with the use or performance of +this software. +****************************************************************/ + +/* 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 inqmask; + +LOCAL void dofclose(), dofinquire(), dofinquire(), dofmove(), dofopen(), + doiolist(), ioset(), ioseta(), iosetc(), iosetip(), iosetlc(), + putio(), putiocall(); + +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 MAXIO SZFLAG + 10*SZIOINT + 15*SZADDR + +/* #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 +#define XRLEN 2*SZFLAG + 2*SZADDR +#define XRNUM 2*SZFLAG + 2*SZADDR + SZIOINT + +/* offsets for internal READ and WRITE statements */ + +#define XIERR 0 +#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 + + +fmtstmt(lp) +register struct Labelblock *lp; +{ + if(lp == NULL) + { + execerr("unlabeled format statement" , CNULL); + return(-1); + } + if(lp->labtype == LABUNKNOWN) + { + lp->labtype = LABFORMAT; + lp->labelno = newlabel(); + } + else if(lp->labtype != LABFORMAT) + { + execerr("bad format number", CNULL); + return(-1); + } + return(lp->labelno); +} + + +setfmt(lp) +struct Labelblock *lp; +{ + int n; + char *s0, *lexline(); + register char *s, *se, *t; + register k; + + s0 = s = lexline(&n); + se = t = s + n; + + /* warn of trivial errors, e.g. " 11 CONTINUE" (one too few spaces) */ + /* following FORMAT... */ + + if (n <= 0) + warn("No (...) after FORMAT"); + else if (*s != '(') + warni("%c rather than ( after FORMAT", *s); + else if (se[-1] != ')') { + *se = 0; + while(--t > s && *t != ')') ; + if (t <= s) + warn("No ) at end of FORMAT statement"); + else if (se - t > 30) + warn1("Extraneous text at end of FORMAT: ...%s", se-12); + else + warn1("Extraneous text at end of FORMAT: %s", t+1); + t = se; + } + + /* fix MYQUOTES (\002's) and \\'s */ + + while(s < se) + switch(*s++) { + case 2: + t += 3; break; + case '"': + case '\\': + t++; break; + } + s = s0; + if (lp) { + lp->fmtstring = t = mem((int)(t - s + 1), 0); + while(s < se) + switch(k = *s++) { + case 2: + t[0] = '\\'; + t[1] = '0'; + t[2] = '0'; + t[3] = '2'; + t += 4; + break; + case '"': + case '\\': + *t++ = '\\'; + /* no break */ + default: + *t++ = k; + } + *t = 0; + } + flline(); +} + + + +startioctl() +{ + register int i; + + inioctl = YES; + nioctl = 0; + ioformatted = UNFORMATTED; + for(i = 1 ; i<=NIOS ; ++i) + V(i) = NULL; +} + + static long +newiolabel() { + long rv; + rv = ++lastiolabno; + skiplabel = mklabel(rv); + skiplabel->labdefined = 1; + return rv; + } + + +endioctl() +{ + 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)); +} + + + +iocname() +{ + 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); +} + + +ioclause(n, p) +register int n; +register expptr p; +{ + 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 */ + +doio(list) +chainp list; +{ + expptr call0(); + + if(ioformatted == NAMEDIRECTED) + { + if(list) + err("no I/O list allowed in NAMELIST read/write"); + } + else + { + doiolist(list); + ioroutine[0] = 'e'; + if (skiplab || ioroutine[4] == 'l') + jumplab = 0; + putiocall( call0(TYINT, ioroutine) ); + } +} + + + + + + LOCAL void +doiolist(p0) + chainp p0; +{ + chainp p; + register tagptr q; + register expptr qe; + register Namep qn; + Addrp tp, mkscalar(); + int range; + extern char *ohalign; + + for (p = p0 ; p ; p = p->nextp) + { + q = (tagptr)p->datap; + if(q->tag == TIMPLDO) + { + exdo(range=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) + { + ftnint lencat(); + 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 */ + + LOCAL void +putio(nelt, addr) + expptr nelt; + register expptr addr; +{ + int type; + register expptr q; + extern Constp mkconst(); + 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(type)); + q = c ? call4(TYINT, "do_lio", mc, nelt, addr, (expptr)c) + : call3(TYINT, "do_lio", mc, nelt, addr); + } + else { + char *s = ioformatted==FORMATTED ? "do_fio" : "do_uio"; + q = c ? call3(TYINT, s, nelt, addr, (expptr)c) + : call2(TYINT, s, nelt, addr); + } + iocalladdr = TYCHAR; + putiocall(q); + iocalladdr = TYADDR; +} + + + + +endio() +{ + extern void p1_label(); + + 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 +putiocall(q) + register expptr q; +{ + 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 +fmtname(np, q) + Namep np; + register Addrp q; +{ + 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 asg_addr(p) + union Expression *p; +{ + 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; + } + +startrw() +{ + register expptr p; + register Namep np; + register Addrp unitp, fmtp, recp; + register expptr nump; + Addrp mkscalar(); + expptr mkaddcon(); + 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(np->vdim->nelt) + { + nump = (expptr) cpexpr(np->vdim->nelt); + if( ! ISCONST(nump) ) + statstruct = NO; + } + 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() +{ + 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() +{ + 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() +{ + 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 +dofmove(subname) + char *subname; +{ + 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 +ioset(type, offset, p) + int type, offset; + register expptr p; +{ + 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 +iosetc(offset, p) + int offset; + register expptr p; +{ + extern Addrp putchop(); + + 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 +ioseta(offset, p) + int offset; + register Addrp p; +{ + 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 +iosetip(i, offset) + int i, offset; +{ + 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 +iosetlc(i, offp, offl) + int i, offp, offl; +{ + register expptr p; + if( (p = V(i)) && p->headblock.vtype==TYCHAR) + ioset(TYIOINT, offl, cpexpr(p->headblock.vleng) ); + iosetc(offp, p); +} diff --git a/lang/fortran/comp/iob.h b/lang/fortran/comp/iob.h new file mode 100644 index 000000000..9f2269bbe --- /dev/null +++ b/lang/fortran/comp/iob.h @@ -0,0 +1,24 @@ +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]; +extern void def_start(), new_iob_data(), other_undefs(); +extern char *tostring(); diff --git a/lang/fortran/comp/lex.c b/lang/fortran/comp/lex.c new file mode 100644 index 000000000..12f171eb8 --- /dev/null +++ b/lang/fortran/comp/lex.c @@ -0,0 +1,1453 @@ +/**************************************************************** +Copyright 1990 by AT&T Bell Laboratories and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T Bell Laboratories or +Bellcore or any of their entities not be used in advertising or +publicity pertaining to distribution of the software without +specific, written prior permission. + +AT&T and Bellcore disclaim all warranties with regard to this +software, including all implied warranties of merchantability +and fitness. In no event shall AT&T or Bellcore be liable for +any special, indirect or consequential damages or any damages +whatsoever resulting from loss of use, data or profits, whether +in an action of contract, negligence or other tortious action, +arising out of or in connection with the use or performance of +this software. +****************************************************************/ + +#include "defs.h" +#include "tokdefs.h" +#include "p1defs.h" + +#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) */ +extern char token[]; /* holds the actual token text */ +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[1390]; /* Main buffer for Fortran source input. The number + comes from lines of at most 66 characters, with at + most 20 continuation cards (or something); this is + part of the defn of the standard */ +LOCAL char *send = sbuf+20*66; +LOCAL int nincl = 0; /* Current number of include files */ +LOCAL long firstline; +LOCAL char *laststb, *stb0; +extern int addftnsrc; +#define CONTMAX 100 /* max continuation lines for ! processing */ +char *linestart[CONTMAX]; +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(); +extern flag use_bs; + + +/* 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 }, + { "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 } +}; + +LOCAL void analyz(), crunch(), store_comment(); +LOCAL int getcd(), getcds(), getkwd(), gettok(); +LOCAL char *stbuf[3]; + +inilex(name) +char *name; +{ + 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 */ +flline() +{ + lexstate = RETEOS; +} + + + +char *lexline(n) +int *n; +{ + *n = (lastch - nextch) + 1; + return(nextch); +} + + + + + +doinclude(name) +char *name; +{ + FILEP fp; + struct Inclfile *t; + + if(inclp) + { + inclp->incllno = thislin; + inclp->inclcode = code; + inclp->inclstno = nxtstno; + if(nextcd) + inclp->incllinp = copyn(inclp->incllen = endcd-nextcd , nextcd); + else + inclp->incllinp = 0; + } + nextcd = NULL; + + if(++nincl >= MAXINCLUDES) + Fatal("includes nested too deep"); + if(name[0] == '\0') + fp = stdin; + else + fp = fopen(name, textread); + if (fp) + { + t = inclp; + inclp = ALLOC(Inclfile); + inclp->inclnext = t; + prevlin = thislin = 0; + infname = inclp->inclname = name; + infile = inclp->inclfp = fp; + } + else + { + fprintf(diagfile, "Cannot open file %s\n", name); + done(1); + } +} + + + + +LOCAL popinclude() +{ + struct Inclfile *t; + register char *p; + register int k; + + if(infile != stdin) + clf(&infile, infname, 1); /* Close the input file */ + free(infname); + + --nincl; + t = inclp->inclnext; + free( (charptr) inclp); + inclp = t; + if(inclp == NULL) { + infname = 0; + return(NO); + } + + infile = inclp->inclfp; + infname = inclp->inclname; + prevlin = thislin = inclp->incllno; + code = inclp->inclcode; + stno = nxtstno = inclp->inclstno; + if(inclp->incllinp) + { + endcd = nextcd = sbuf; + k = inclp->incllen; + p = inclp->incllinp; + while(--k >= 0) + *endcd++ = *p++; + free( (charptr) (inclp->incllinp) ); + } + else + nextcd = NULL; + return(YES); +} + + static void +putlineno() +{ + static long lastline; + static char *lastfile = "??", *lastfile0 = "?"; + static char fbuf[P1_FILENAME_MAX]; + extern int gflag; + register char *s0, *s1; + + if (gflag) { + if (lastline) { + if (lastfile != lastfile0) { + p1puts(P1_FILENAME, fbuf); + lastfile0 = lastfile; + } + 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; + } + } + + +yylex() +{ + static int tokno; + int retval; + + switch(lexstate) + { + case NEWSTMT : /* need a new statement */ + retval = getcds(); + putlineno(); + if(retval == STEOF) { + retval = SEOF; + break; + } /* if getcds() == STEOF */ + crunch(); + tokno = 0; + lexstate = FIRSTTOKEN; + yystno = stno; + stno = nxtstno; + toklen = 0; + retval = SLABEL; + break; + +first: + case FIRSTTOKEN : /* first step on a statement */ + analyz(); + lexstate = OTHERTOKEN; + tokno = 1; + retval = stkey; + break; + + case OTHERTOKEN : /* return next token */ + if(nextch > lastch) + goto reteos; + ++tokno; + if( (stkey==SLOGIF || stkey==SELSEIF) && parlev==0 && tokno>3) + goto first; + + if(stkey==SASSIGN && tokno==3 && nextch sbuf) + { + q = nextcd; + p = sbuf; + while(q < endcd) + *p++ = *q++; + endcd = p; + } + +/* Be aware that the input (i.e. the string at the address nextcd) is NOT + NULL-terminated */ + +/* This loop merges all continuations into one long statement, AND puts the next + card to be read at the end of the buffer (i.e. it stores the look-ahead card + when there's room) */ + + ncont = 0; + do { + nextcd = endcd; + if (ncont < CONTMAX) + linestart[ncont++] = nextcd; + } + while(nextcd+66<=send && (code = getcd(nextcd,0))==STCONTINUE); + nextch = sbuf; + lastch = nextcd - 1; + +/* Handle buffer overflow by zeroing the 'next' pointer (nextcd) so that + the top of this function will initialize it next time it is called */ + + if(nextcd >= send) + nextcd = NULL; + lineno = prevlin; + prevlin = thislin; + return(STINITIAL); +} + + static void +bang(a,b,c,d,e) /* save ! comments */ + char *a, *b, *c; + register char *d, *e; +{ + 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 +getcd(b, nocont) + register char *b; +{ + 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; + int amp; + char storage[COMMENT_BUFFER_SIZE + 1]; + char *pointer; + +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 & 0xfff]) + { + if (feof (infile)) + return STEOF; + + 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 stb + 7) { /* otherwise forget col 1-6 */ + /* kludge around funny p1gets behavior */ + *stb++ = '$'; + if (amp) + *stb++ = '&'; + else + for(p = a; p < atend;) + *stb++ = *p++; + } + if (endcd0 - b > stbend - stb) { + if (stb > stbend) + stb = stbend; + endcd0 = b + (stbend - stb); + } + for(p = b; p < endcd0;) + *stb++ = *p++; + *stb++ = '\n'; + *stb = 0; + } + if (nocont) { + lineno = thislin; + errstr("illegal continuation card (starts \"%.6s\")",a); + } + else if (!amp && strncmp(a," ",5)) { + lineno = thislin; + errstr("labeled continuation line (starts \"%.6s\")",a); + } + return(STCONTINUE); + } +initcheck: + for(p=a; p= linestart[k]) + if (++k >= CONTMAX) + Fatal("too many continuations\n"); + 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(iprvstr) /* test for Hollerith strings */ + { + j0 = j - 1; + if( ! isdigit(*j0)) goto copychar; + nh = *j0 - '0'; + ten = 10; + j1 = prvstr; + 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 must be preceded by a punctuation mark. + '*' is possible only as repetition factor in a data statement + not, in particular, in character*2h +*/ + + if( !(*j0=='*'&&sbuf[0]=='d') && *j0!='/' + && *j0!='(' && *j0!=',' && *j0!='=' && *j0!='.') + goto copychar; + nh0 = nh; + if(i+nh > lastch || nh + 2 > MAXTOKENLEN) + { + erri("%dH too big", nh); + nh = lastch - i; + if (nh > MAXTOKENLEN - 2) + nh = MAXTOKENLEN - 2; + nh0 = -1; + } + 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() +{ + register char *i; + + if(parlev != 0) + { + err("unbalanced parentheses, statement skipped"); + stkey = SUNKNOWN; + lastch = sbuf - 1; /* prevent double error msg */ + return; + } + if(nextch+2<=lastch && nextch[0]=='i' && nextch[1]=='f' && nextch[2]=='(') + { + /* assignment or if statement -- look at character after balancing paren */ + parlev = 1; + for(i=nextch+3 ; i<=lastch; ++i) + if(*i == (MYQUOTE)) + { + while(*++i != MYQUOTE) + ; + } + else if(*i == '(') + ++parlev; + else if(*i == ')') + { + if(--parlev == 0) + break; + } + if(i >= lastch) + stkey = SLOGIF; + else if(i[1] == '=') + stkey = SLET; + else if( isdigit(i[1]) ) + stkey = SARITHIF; + else stkey = SLOGIF; + if(stkey != SLET) + nextch += 2; + } + else if(expeql) /* may be an assignment */ + { + if(expcom && nextch= '0' && nextch[2] <= '9') + || nextch[2] == ',' + || nextch[2] == 'w')) + { + stkey = SDO; + nextch += 2; + needwkey = 1; + } + /* otherwise search for keyword */ + else { + stkey = getkwd(); + if(stkey==SGOTO && lastch>=nextch) + if(nextch[0]=='(') + stkey = SCOMPGOTO; + else if(isalpha_(* USC nextch)) + stkey = SASGOTO; + } + parlev = 0; +} + + + + LOCAL int +getkwd() +{ + 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); +} + +initkey() +{ + 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; + } + comstart['c'] = comstart['C'] = comstart['*'] = comstart['!'] = 1; + s = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_"; + while(i = *s++) + anum_buf[i] = 1; + s = "0123456789"; + while(i = *s++) + anum_buf[i] = 2; + } + + LOCAL int +hexcheck(key) + int key; +{ + 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() +{ +int havdot, havexp, havdbl; + int radix, val; + struct Punctlist *pp; + struct Dotlist *pd; + register int ch; + + 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 '/': + if (*nextch == '/') { + nextch++; + val = SCONCAT; + } + else if (new_dcl && parlev == 0) + val = SSLASHD; + return val; + case '*': + if (*nextch == '*') { + nextch++; + return SPOWER; + } + break; + case '<': + if (*nextch == '=') { + nextch++; + val = SLE; + } + if (*nextch == '>') { + 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 50) + { + char buff[100]; + sprintf(buff, toklen >= 60 + ? "name %.56s... too long, truncated to %.*s" + : "name %s too long, truncated to %.*s", + token, 50, token); + err(buff); + toklen = 50; + token[50] = '\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[2] == '#' && isdigit(nextch[1])) { + + radix = atoi (nextch); + if (*++nextch != '#') + nextch++; + if (radix != 2 && radix != 8 && radix != 16) { + erri("invalid base %d for constant, defaulting to hex", + radix); + radix = 16; + } /* if */ + if (++nextch > lastch) + goto badchar; + for (p = token; hextoi(*nextch) < radix;) { + *p++ = *nextch++; + if (nextch > lastch) + break; + } + toklen = p - token; + *p = 0; + return (radix == 16) ? SHEXCON : ((radix == 8) ? SOCTCON : + SBITCON); + } + } + else + goto badchar; +numconst: + havdot = NO; + havexp = NO; + havdbl = NO; + for(n1 = nextch ; nextch<=lastch ; ++nextch) + { + if(*nextch == '.') + if(havdot) break; + else if(nextch+2<=lastch && isalpha_(* USC (nextch+1)) + && isalpha_(* USC (nextch+2))) + break; + else havdot = YES; + else if( !intonly && (*nextch=='d' || *nextch=='e') ) + { + p = nextch; + havexp = YES; + if(*nextch == 'd') + havdbl = YES; + if(nextch cblast) { + if (!cbcur || !(ncb = cbcur->next)) { + ncb = (comment_buf *) Alloc(sizeof(comment_buf)); + if (cbcur) { + cbcur->last = cbnext; + 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() +{ + 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() +{ + register char *s, *se; + + s = sbuf; + se = lastch; + if (se < sbuf) + return; + lastch = s - 1; + if (se - s > 10) + se = s + 10; + for(; s < se; s++) + if (*s == MYQUOTE) { + se = s; + break; + } + *se = 0; + errstr("unclassifiable statement (starts \"%s\")", sbuf); + } diff --git a/lang/fortran/comp/machdefs.h b/lang/fortran/comp/machdefs.h new file mode 100644 index 000000000..3ab8961f0 --- /dev/null +++ b/lang/fortran/comp/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/lang/fortran/comp/main.c b/lang/fortran/comp/main.c new file mode 100644 index 000000000..e8f4148b1 --- /dev/null +++ b/lang/fortran/comp/main.c @@ -0,0 +1,590 @@ +/**************************************************************** +Copyright 1990, 1991 by AT&T Bell Laboratories and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T Bell Laboratories or +Bellcore or any of their entities not be used in advertising or +publicity pertaining to distribution of the software without +specific, written prior permission. + +AT&T and Bellcore disclaim all warranties with regard to this +software, including all implied warranties of merchantability +and fitness. In no event shall AT&T or Bellcore be liable for +any special, indirect or consequential damages or any damages +whatsoever resulting from loss of use, data or profits, whether +in an action of contract, negligence or other tortious action, +arising out of or in connection with the use or performance of +this software. +****************************************************************/ + +extern char F2C_version[]; + +#include "defs.h" +#include "parse.h" + +int complex_seen, dcomplex_seen; + +LOCAL int Max_ftn_files; + +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; +int tyreal = TYREAL; +int tycomplex = TYCOMPLEX; +extern void r8fix(), read_Pfiles(); + +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 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 Ansi = NO; +int def_equivs = YES; +int tyioint = TYLONG; +int szleng = SZLENG; +int inqmask = M(TYLONG)|M(TYLOGICAL); +int wordalign = NO; +int forcereal = NO; +static int skipC, skipversion; +char *filename0, *parens; +int Castargs = 1; +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 */ + +#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 ("d", P_ONE_ARG, P_INT, &debugflag, 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 ("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 ("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), + + /* options omitted from man pages */ + + /* -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) + +}; /* 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" */ +static char *proto_fname; /* "proto_file" */ +FILE *protofile; + +extern void list_init_data(), set_tmp_names(), sigcatch(), Un_link_all(); +extern char *c_name(); + + +set_externs () +{ + 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[TYDREAL] = typesize[TYCOMPLEX] = chars_per_wd << 1; + typesize[TYDCOMPLEX] = chars_per_wd << 2; + typesize[TYSHORT] = 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(TYLOGICAL); + goto checklong; + } + else + szleng = typesize[TYLONG]; + if (useshortints) { + inqmask = M(TYLONG); + checklong: + protorettypes[TYLOGICAL] = typename[TYLOGICAL] = "shortlogical"; + typesize[TYLOGICAL] = typesize[TYSHORT]; + casttypes[TYLOGICAL] = "K_fp"; + if (uselongints) + err ("Can't use both long and short ints"); + else + tyint = tylogical = TYSHORT; + } + 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"; + } + + 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() +{ + Extsym *ext; + if (ext1comm) + for(ext = extsymtab; ext < nextext; ext++) + if (ext->extstg == STGCOMMON && !ext->extinit) + return ext1comm; + return 0; + } + + static void +write_typedefs(outfile) + FILE *outfile; +{ + register int i; + register char *s, *p = 0; + static char st[4] = { TYREAL, TYCOMPLEX, TYDCOMPLEX, TYCHAR }; + static char stl[4] = { 'E', 'C', 'Z', 'H' }; + + for(i = 0; i <= TYSUBR; i++) + if (s = usedcasts[i]) { + if (!p) { + p = Ansi == 1 ? "()" : "(...)"; + nice_printf(outfile, + "/* Types for casting procedure arguments: */\ +\n\n#ifndef F2C_proc_par_types\n"); + if (i == 0) { + nice_printf(outfile, + "typedef int /* Unknown procedure type */ (*%s)%s;\n", + s, p); + continue; + } + } + nice_printf(outfile, "typedef %s (*%s)%s;\n", + c_type_decl(i,1), s, p); + } + for(i = !forcedouble; i < 4; i++) + if (used_rets[st[i]]) + nice_printf(outfile, + "typedef %s %c_f; /* %s function */\n", + p = i ? "VOID" : "doublereal", + stl[i], ftn_types[st[i]]); + if (p) + nice_printf(outfile, "#endif\n\n"); + } + + static void +commonprotos(outfile) + register FILE *outfile; +{ + 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 (Castargs < 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); + } + } + } + + int retcode = 0; + +main(argc, argv) +int argc; +char **argv; +{ + int c2d, k; + FILE *c_output; + char *filename, *cdfilename; + static char stderrbuf[BUFSIZ]; + extern void def_commons(); + extern char **dfltproc, *dflt1proc[]; + extern char link_msg[]; + + diagfile = stderr; + setbuf(stderr, stderrbuf); /* arrange for fast error msgs */ + + 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 (!can_include && ext1comm == 2) + ext1comm = 1; + if (ext1comm && !extcomm) + extcomm = 2; + if (protostatus) + Castargs = 3; + else if (Castargs == 1 && !Ansi) + Castargs = 0; + if (Castargs >= 2 && !Ansi) + Ansi = 1; + + if (!Ansi) + parens = "()"; + else if (!Castargs) + parens = Ansi == 1 ? "()" : "(...)"; + else + dfltproc = dflt1proc; + + set_externs(); + fileinit(); + read_Pfiles(ftn_files); + + for(k = 1; ftn_files[k]; k++) + if (dofork()) + break; + filename0 = filename = ftn_files[current_ftn_file = k - 1]; + + set_tmp_names(); + sigcatch(); + + c_file = opf(c_functions, textwrite); + pass1_file=opf(p1_file, binwrite); + initkey(); + if (filename && *filename) { + if (debugflag != 1) { + coutput = c_name(filename,'c'); + if (Castargs >= 2) + proto_fname = c_name(filename,'P'); + } + cdfilename = coutput; + if (skipC) + coutput = 0; + else if (!(c_output = fopen(coutput, textwrite))) { + filename = coutput; + coutput = 0; /* don't delete read-only .c file */ + fatalstr("can't open %.86s", filename); + } + + if (Castargs >= 2 + && !(protofile = fopen(proto_fname, textwrite))) + fatalstr("Can't open %.84s\n", proto_fname); + } + else { + filename = ""; + cdfilename = "f2c_out.c"; + c_output = stdout; + coutput = 0; + if (Castargs >= 2) { + protofile = stdout; + if (!skipC) + printf("#ifdef P_R_O_T_O_T_Y_P_E_S\n"); + } + } + + if(inilex( copys(filename) )) + done(1); + if (filename0) { + fprintf(diagfile, "%s:\n", filename); + fflush(diagfile); + } + + procinit(); + if(k = yyparse()) + { + fprintf(diagfile, "Bad parse, return code %d\n", k); + done(1); + } + + commonprotos(protofile); + if (protofile == stdout && !skipC) + printf("#endif\n\n"); + + if (nerr || skipC) + goto C_skipped; + + +/* Write out the declarations which are global to this file */ + + if ((c2d = comm2dcl()) == 1) + nice_printf(c_output, "/*>>>'/dev/null'<<<*/\n\n\ +/* Split this into several files by piping it through\n\n\ +sed \"s/^\\/\\*>>>'\\(.*\\)'<<<\\*\\/\\$/cat >'\\1' <<'\\/*<<<\\1>>>*\\/'/\" | /bin/sh\n\ + */\n\ +/*<<>>*/\n\ +/*>>>'%s'<<<*/\n", cdfilename); + if (!skipversion) { + nice_printf (c_output, "/* %s -- translated by f2c ", filename); + nice_printf (c_output, "(version of %s).\n", F2C_version); + nice_printf (c_output, + " You must link the resulting object file with the libraries:\n\ + %s (in that order)\n*/\n\n", link_msg); + } + if (Ansi == 2) + nice_printf(c_output, + "#ifdef __cplusplus\nextern \"C\" {\n#endif\n"); + nice_printf (c_output, "%s#include \"f2c.h\"\n\n", def_i2); + if (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__ (); }\n", + main_alias); + } + 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(); + } + done(nerr ? 1 : 0); +} + + +FILEP opf(fn, mode) +char *fn, *mode; +{ + FILEP fp; + if( fp = fopen(fn, mode) ) + return(fp); + + fatalstr("cannot open intermediate file %s", fn); + /* NOT REACHED */ return 0; +} + + +clf(p, what, quit) + FILEP *p; + char *what; + int quit; +{ + 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; +} + + +done(k) +int k; +{ + 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/lang/fortran/comp/makefile b/lang/fortran/comp/makefile new file mode 100644 index 000000000..01e0b76c9 --- /dev/null +++ b/lang/fortran/comp/makefile @@ -0,0 +1,84 @@ +# Makefile for f2c, a Fortran 77 to C converter + +g = -g +CFLAGS = $g +SHELL = /bin/sh + +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 +OBJECTS = $(OBJECTSd) malloc.o + +all: xsum.out f2c + +f2c: $(OBJECTS) + $(CC) $(LDFLAGS) $(OBJECTS) -o f2c + size f2c + +gram.c: gram.head gram.dcl gram.expr gram.exec gram.io defs.h tokdefs.h + ( sed gram.in + $(YACC) $(YFLAGS) gram.in + echo "(expect 4 shift/reduce)" + sed 's/^# line.*/\/* & *\//' y.tab.c >gram.c + rm -f gram.in y.tab.c + +$(OBJECTSd): defs.h ftypes.h defines.h machdefs.h sysdep.h + +tokdefs.h: tokens + grep -n . tokdefs.h + +cds.o: sysdep.h +exec.o: p1defs.h names.h +expr.o: output.h niceprintf.h names.h +format.o: p1defs.h format.h output.h niceprintf.h names.h iob.h +formatdata.o: format.h output.h niceprintf.h names.h +gram.o: p1defs.h +init.o: output.h niceprintf.h iob.h +intr.o: names.h +io.o: names.h iob.h +lex.o : tokdefs.h p1defs.h +main.o: parse.h usignal.h +mem.o: iob.h +names.o: iob.h names.h output.h niceprintf.h +niceprintf.o: defs.h names.h output.h niceprintf.h +output.o: output.h niceprintf.h names.h +p1output.o: p1defs.h output.h niceprintf.h names.h +parse_args.o: parse.h +proc.o: tokdefs.h names.h niceprintf.h output.h p1defs.h +put.o: names.h pccdefs.h p1defs.h +putpcc.o: names.h +vax.o: defs.h output.h pccdefs.h +output.h: niceprintf.h + +put.o putpcc.o: pccdefs.h + +f2c.t: f2c.1t + troff -man f2c.1t >f2c.t + +f2c.1: f2c.1t + nroff -man f2c.1t | col -b | uniq >f2c.1 + +clean: + rm -f gram.c *.o f2c tokdefs.h f2c.t + +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.dcl gram.exec gram.expr gram.head gram.io \ + init.c intr.c io.c iob.h lex.c machdefs.h main.c makefile \ + 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 + +bundle: + bundle $b xsum0.out >/tmp/f2c.bundle + +xsum: xsum.c + $(CC) -o xsum xsum.c + +#Check validity of transmitted source... +xsum.out: xsum + ./xsum $b >xsum1.out + cmp xsum0.out xsum1.out && mv xsum1.out xsum.out diff --git a/lang/fortran/comp/malloc.c b/lang/fortran/comp/malloc.c new file mode 100644 index 000000000..e4414dad9 --- /dev/null +++ b/lang/fortran/comp/malloc.c @@ -0,0 +1,142 @@ +/**************************************************************** +Copyright 1990 by AT&T Bell Laboratories and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T Bell Laboratories or +Bellcore or any of their entities not be used in advertising or +publicity pertaining to distribution of the software without +specific, written prior permission. + +AT&T and Bellcore disclaim all warranties with regard to this +software, including all implied warranties of merchantability +and fitness. In no event shall AT&T or Bellcore be liable for +any special, indirect or consequential damages or any damages +whatsoever resulting from loss of use, data or profits, whether +in an action of contract, negligence or other tortious action, +arising out of or in connection with the use or performance of +this software. +****************************************************************/ + +#ifndef CRAY +#define STACKMIN 512 +#define MINBLK (2*sizeof(struct mem) + 16) +#define MSTUFF _malloc_stuff_ +#define F MSTUFF.free +#define B MSTUFF.busy +#define SBGULP 8192 +char *memcpy(); + +struct mem { + struct mem *next; + unsigned len; + }; + +struct { + struct mem *free; + char *busy; + } MSTUFF; + +char * +malloc(size) +register unsigned size; +{ + register struct mem *p, *q, *r, *s; + unsigned register k, m; + extern char *sbrk(); + char *top, *top1; + + size = (size+7) & ~7; + r = (struct 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 = (struct mem *) (((char *) (q+1)) + size); + p->next = q->next; + p->len = q->len - size - sizeof(struct mem); + s->next = p; + q->len = size; + } + else s->next = q->next; + } + else { + top = B ? B : (char *)(((long)sbrk(0) + 7) & ~7); + if (F && (char *)(F+1) + F->len == B) + { q = F; F = F->next; } + else q = (struct mem *) top; + top1 = (char *)(q+1) + size; + if (top1 > top) { + if (sbrk((int)(top1-top+SBGULP)) == (char *) -1) + return 0; + r = (struct mem *)top1; + r->len = SBGULP - sizeof(struct mem); + r->next = F; + F = r; + top1 += SBGULP; + } + q->len = size; + B = top1; + } + return (char *) (q+1); + } + +free(f) +char *f; +{ + struct mem *p, *q, *r; + char *pn, *qn; + + if (!f) return; + q = (struct mem *) (f - sizeof(struct mem)); + qn = f + q->len; + for (p = F, r = (struct mem *) &F; ; r = p, p = p->next) { + if (qn == (char *) p) { + q->len += p->len + sizeof(struct mem); + p = p->next; + } + pn = p ? ((char *) (p+1)) + p->len : 0; + if (pn == (char *) q) { + p->len += sizeof(struct 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 * +realloc(f, size) +char *f; +unsigned size; +{ + struct mem *p; + char *q, *f1; + unsigned s1; + + if (!f) return malloc(size); + p = (struct mem *) (f - sizeof(struct 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; + } +#endif diff --git a/lang/fortran/comp/mem.c b/lang/fortran/comp/mem.c new file mode 100644 index 000000000..b90af8a14 --- /dev/null +++ b/lang/fortran/comp/mem.c @@ -0,0 +1,230 @@ +/**************************************************************** +Copyright 1990, 1991 by AT&T Bell Laboratories and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T Bell Laboratories or +Bellcore or any of their entities not be used in advertising or +publicity pertaining to distribution of the software without +specific, written prior permission. + +AT&T and Bellcore disclaim all warranties with regard to this +software, including all implied warranties of merchantability +and fitness. In no event shall AT&T or Bellcore be liable for +any special, indirect or consequential damages or any damages +whatsoever resulting from loss of use, data or profits, whether +in an action of contract, negligence or other tortious action, +arising out of or in connection with the use or performance of +this software. +****************************************************************/ + +#include "defs.h" +#include "iob.h" + +#define MEMBSIZE 32000 +#define GMEMBSIZE 16000 + + extern void exit(); + + char * +gmem(n, round) + int n, round; +{ + 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() +{ + 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 * +mem(n, round) + int n, round; +{ + 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 * +tostring(s,n) + register char *s; + int n; +{ + 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 * +cpstring(s) + register char *s; +{ + return strcpy(mem(strlen(s)+1,0), s); + } + + void +new_iob_data(ios, name) + register io_setup *ios; + char *name; +{ + 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 * +string_num(pfx, n) + char *pfx; + long n; +{ + 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 +def_start(outfile, s1, s2, post) + FILE *outfile; + char *s1, *s2, *post; +{ + defines *d; + int n, n1; + + 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); + nice_printf(outfile, "#define %s %s", d->defname, post); + } + + void +other_undefs(outfile) + FILE *outfile; +{ + 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/lang/fortran/comp/memset.c b/lang/fortran/comp/memset.c new file mode 100644 index 000000000..98a7ce72a --- /dev/null +++ b/lang/fortran/comp/memset.c @@ -0,0 +1,66 @@ +/**************************************************************** +Copyright 1990 by AT&T Bell Laboratories and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T Bell Laboratories or +Bellcore or any of their entities not be used in advertising or +publicity pertaining to distribution of the software without +specific, written prior permission. + +AT&T and Bellcore disclaim all warranties with regard to this +software, including all implied warranties of merchantability +and fitness. In no event shall AT&T or Bellcore be liable for +any special, indirect or consequential damages or any damages +whatsoever resulting from loss of use, data or profits, whether +in an action of contract, negligence or other tortious action, +arising out of or in connection with the use or performance of +this software. +****************************************************************/ + +/* This is for the benefit of people whose systems don't provide + * memset, memcpy, and memcmp. If yours is such a system, adjust + * the makefile by adding memset.o to the "OBJECTS =" assignment. + * WARNING: the memcpy below is adequate for f2c, but is not a + * general memcpy routine (which must correctly handle overlapping + * fields). + */ + + int +memcmp(s1, s2, n) + register char *s1, *s2; + int n; +{ + register char *se; + + for(se = s1 + n; s1 < se; s1++, s2++) + if (*s1 != *s2) + return *s1 - *s2; + return 0; + } + + char * +memcpy(s1, s2, n) + register char *s1, *s2; + int n; +{ + register char *s0 = s1, *se = s1 + n; + + while(s1 < se) + *s1++ = *s2++; + return s0; + } + +memset(s, c, n) + register char *s; + register int c; + int n; +{ + register char *se = s + n; + + while(s < se) + *s++ = c; + } diff --git a/lang/fortran/comp/misc.c b/lang/fortran/comp/misc.c new file mode 100644 index 000000000..c71ebe300 --- /dev/null +++ b/lang/fortran/comp/misc.c @@ -0,0 +1,1041 @@ +/**************************************************************** +Copyright 1990 by AT&T Bell Laboratories and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T Bell Laboratories or +Bellcore or any of their entities not be used in advertising or +publicity pertaining to distribution of the software without +specific, written prior permission. + +AT&T and Bellcore disclaim all warranties with regard to this +software, including all implied warranties of merchantability +and fitness. In no event shall AT&T or Bellcore be liable for +any special, indirect or consequential damages or any damages +whatsoever resulting from loss of use, data or profits, whether +in an action of contract, negligence or other tortious action, +arising out of or in connection with the use or performance of +this software. +****************************************************************/ + +#include "defs.h" + +int oneof_stg (name, stg, mask) + Namep name; + int stg, mask; +{ + 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 op_assign (opcode) +int opcode; +{ + 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 * +Alloc(n) /* error-checking version of malloc */ + /* ckalloc initializes memory to 0; Alloc does not */ + int n; +{ + char errbuf[32]; + register char *rv; + + rv = malloc(n); + if (!rv) { + sprintf(errbuf, "malloc(%d) failure!", n); + Fatal(errbuf); + } + return rv; + } + + +cpn(n, a, b) +register int n; +register char *a, *b; +{ + while(--n >= 0) + *b++ = *a++; +} + + + +eqn(n, a, b) +register int n; +register char *a, *b; +{ + while(--n >= 0) + if(*a++ != *b++) + return(NO); + return(YES); +} + + + + + + + +cmpstr(a, b, la, lb) /* compare two strings */ +register char *a, *b; +ftnint la, lb; +{ + 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 hookup(x,y) +register chainp x, y; +{ + register chainp p; + + if(x == NULL) + return(y); + + for(p = x ; p->nextp ; p = p->nextp) + ; + p->nextp = y; + return(x); +} + + + +struct Listblock *mklist(p) +chainp p; +{ + register struct Listblock *q; + + q = ALLOC(Listblock); + q->tag = TLIST; + q->listp = p; + return(q); +} + + +chainp mkchain(p,q) +register char * p; +register chainp q; +{ + register chainp r; + + if(chains) + { + r = chains; + chains = chains->nextp; + } + else + r = ALLOC(Chain); + + r->datap = p; + r->nextp = q; + return(r); +} + + chainp +revchain(next) + register chainp next; +{ + 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 * +addunder(s) + register char *s; +{ + register int c, i; + char *s0 = s; + + i = 0; + while(c = *s++) + if (c == '_') + i++; + else + i = 0; + if (!i) { + *s-- = 0; + *s = '_'; + } + return( s0 ); + } + + +/* copyn -- return a new copy of the input Fortran-string */ + +char *copyn(n, s) +register int n; +register char *s; +{ + 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 *copys(s) +char *s; +{ + return( copyn( strlen(s)+1 , s) ); +} + + + +/* convci -- Convert Fortran-string to integer; assumes that input is a + legal number, with no trailing blanks */ + +ftnint convci(n, s) +register int n; +register char *s; +{ + ftnint sum; + sum = 0; + while(n-- > 0) + sum = 10*sum + (*s++ - '0'); + return(sum); +} + +/* convic - Convert Integer constant to string */ + +char *convic(n) +ftnint n; +{ + 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 mkname(s) +register char *s; +{ + 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 = 1; + } + 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 _ */ + while(*t = *s++) + t++; + if (i) { + t[0] = t[1] = '_'; + t[2] = 0; + } + else if (in_vector(s0) >= 0) { + t[0] = '_'; + t[1] = 0; + } + return(q); +} + + +struct Labelblock *mklabel(l) +ftnint l; +{ + 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 = newlabel(); + lp->blklevel = 0; + lp->labused = NO; + lp->fmtlabused = NO; + lp->labdefined = NO; + lp->labinacc = NO; + lp->labtype = LABUNKNOWN; + lp->fmtstring = 0; + return(lp); +} + + +newlabel() +{ + return( ++lastlabno ); +} + + +/* this label appears in a branch context */ + +struct Labelblock *execlab(stateno) +ftnint stateno; +{ + 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 *mkext(f,s) +char *f, *s; +{ + Extsym *p; + + for(p = extsymtab ; pcextname)) + return( p ); + + if(nextext >= lastext) + many("external symbols", 'x', maxext); + + nextext->fextname = strcpy(gmem(strlen(f)+1,0), f); + nextext->cextname = f == s + ? nextext->fextname + : strcpy(gmem(strlen(s)+1,0), s); + nextext->extstg = STGUNKNOWN; + nextext->extp = 0; + nextext->allextp = 0; + nextext->extleng = 0; + nextext->maxleng = 0; + nextext->extinit = 0; + nextext->curno = nextext->maxno = 0; + return( nextext++ ); +} + + +Addrp builtin(t, s, dbi) +int t, dbi; +char *s; +{ + 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); +} + + + +add_extern_to_list (addr, list_store) +Addrp addr; +chainp *list_store; +{ + 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 */ + + +frchain(p) +register chainp *p; +{ + 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 +frexchain(p) + register chainp *p; +{ + 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 cpblock(n,p) +register int n; +register char * p; +{ + register ptr q; + + memcpy((char *)(q = ckalloc(n)), (char *)p, n); + return( (tagptr) q); +} + + + +ftnint lmax(a, b) +ftnint a, b; +{ + return( a>b ? a : b); +} + +ftnint lmin(a, b) +ftnint a, b; +{ + return(a < b ? a : b); +} + + + + +maxtype(t1, t2) +int t1, t2; +{ + 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 */ +log_2(n) +ftnint n; +{ + int k; + + /* trick based on binary representation */ + + if(n<=0 || (n & (n-1))!=0) + return(-1); + + for(k = 0 ; n >>= 1 ; ++k) + ; + return(k); +} + + + +frrpl() +{ + 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 callk(type, name, args) +int type; +char *name; +chainp args; +{ + register expptr p; + + p = mkexpr(OPCALL, + (expptr)builtin(callk_kludge ? callk_kludge : type, name, 0), + (expptr)args); + p->exprblock.vtype = type; + return(p); +} + + + +expptr call4(type, name, arg1, arg2, arg3, arg4) +int type; +char *name; +expptr arg1, arg2, arg3, arg4; +{ + 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 call3(type, name, arg1, arg2, arg3) +int type; +char *name; +expptr arg1, arg2, arg3; +{ + struct Listblock *args; + args = mklist( mkchain((char *)arg1, + mkchain((char *)arg2, + mkchain((char *)arg3, CHNULL) ) ) ); + return( callk(type, name, (chainp)args) ); +} + + + + + +expptr call2(type, name, arg1, arg2) +int type; +char *name; +expptr arg1, arg2; +{ + struct Listblock *args; + + args = mklist( mkchain((char *)arg1, mkchain((char *)arg2, CHNULL) ) ); + return( callk(type,name, (chainp)args) ); +} + + + + +expptr call1(type, name, arg) +int type; +char *name; +expptr arg; +{ + return( callk(type,name, (chainp)mklist(mkchain((char *)arg,CHNULL)) )); +} + + +expptr call0(type, name) +int type; +char *name; +{ + return( callk(type, name, CHNULL) ); +} + + + +struct Impldoblock *mkiodo(dospec, list) +chainp dospec, list; +{ + 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 ckalloc(n) +register int n; +{ + register ptr p; + if( p = (ptr)calloc(1, (unsigned) n) ) + return(p); + fprintf(stderr, "failing to get %d bytes\n",n); + Fatal("out of memory"); + /* NOT REACHED */ return 0; +} + + + +isaddr(p) +register expptr p; +{ + 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); +} + + + + +isstatic(p) +register expptr p; +{ + 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 */ + +addressable(p) +register expptr p; +{ + switch(p->tag) + { + case TCONST: + return(YES); + + case TADDR: + return( addressable(p->addrblock.memoffset) ); + + default: + return(NO); + } +} + + +/* isnegative_const -- returns true if the constant is negative. Returns + false for imaginary and nonnumeric constants */ + +int isnegative_const (cp) +struct Constblock *cp; +{ + int retval; + + if (cp == NULL) + return 0; + + switch (cp -> vtype) { + case TYSHORT: + case TYLONG: + 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 */ + +negate_const(cp) + Constp cp; +{ + if (cp == (struct Constblock *) NULL) + return; + + switch (cp -> vtype) { + case TYSHORT: + case TYLONG: + 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 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 */ + +ffilecopy (infp, outfp) +FILE *infp, *outfp; +{ + while (!feof (infp)) { + register c = getc (infp); + if (!feof (infp)) + putc (c, outfp); + } /* while */ +} /* ffilecopy */ + + +#define NOT_IN_VECTOR -1 + +/* in_vector -- verifies whether str is in c_keywords. + If so, the index is returned else NOT_IN_VECTOR is returned. + c_keywords must be in alphabetical order (as defined by strcmp). +*/ + +int in_vector(str) +char *str; +{ + extern int n_keywords; + extern char *c_keywords[]; + register int n = n_keywords; + register char **K = c_keywords; + register int n1, t; + + do { + n1 = n >> 1; + if (!(t = strcmp(str, K[n1]))) + return K - c_keywords + n1; + if (t < 0) + n = n1; + else { + n -= ++n1; + K += n1; + } + } + while(n > 0); + + return NOT_IN_VECTOR; + } /* in_vector */ + + +int is_negatable (Const) +Constp Const; +{ + int retval = 0; + if (Const != (Constp) NULL) + switch (Const -> vtype) { + case TYSHORT: + retval = Const -> Const.ci >= -BIGGEST_SHORT; + break; + case TYLONG: + retval = Const -> Const.ci >= -BIGGEST_LONG; + break; + case TYREAL: + case TYDREAL: + case TYCOMPLEX: + case TYDCOMPLEX: + retval = 1; + break; + case TYLOGICAL: + case TYCHAR: + case TYSUBR: + default: + retval = 0; + break; + } /* switch */ + + return retval; +} /* is_negatable */ + +backup(fname, bname) + char *fname, *bname; +{ + 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 struct_eq (s1, s2) +chainp s1, s2; +{ + 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) + return NO; + if (!(d2 = v2->vdim)) + if (cp1->Const.ci == 1) + continue; + else + return NO; + if (!(cp2 = (Constp)d2->nelt) || cp2->tag != TCONST + || cp1->Const.ci != cp2->Const.ci) + return NO; + } + else if ((d2 = v2->vdim) && (!(cp2 = (Constp)d2->nelt) + || cp2->tag != TCONST + || cp2->Const.ci != 1)) + return NO; + } /* while s1 != CHNULL && s2 != CHNULL */ + + return s1 == CHNULL && s2 == CHNULL; +} /* struct_eq */ diff --git a/lang/fortran/comp/names.c b/lang/fortran/comp/names.c new file mode 100644 index 000000000..bc69c86fe --- /dev/null +++ b/lang/fortran/comp/names.c @@ -0,0 +1,711 @@ +/**************************************************************** +Copyright 1990 by AT&T Bell Laboratories and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T Bell Laboratories or +Bellcore or any of their entities not be used in advertising or +publicity pertaining to distribution of the software without +specific, written prior permission. + +AT&T and Bellcore disclaim all warranties with regard to this +software, including all implied warranties of merchantability +and fitness. In no event shall AT&T or Bellcore be liable for +any special, indirect or consequential damages or any damages +whatsoever resulting from loss of use, data or profits, whether +in an action of contract, negligence or other tortious action, +arising out of or in connection with the use or performance of +this software. +****************************************************************/ + +#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 *c_type_decl (type, is_extern) +int type, is_extern; +{ + static char buff[100]; + + switch (type) { + case TYADDR: strcpy (buff, "address"); break; + case TYSHORT: strcpy (buff, "shortint"); break; + case TYLONG: strcpy (buff, "integer"); break; + case TYREAL: if (!is_extern || !forcedouble) + { strcpy (buff, "real");break; } + case TYDREAL: strcpy (buff, "doublereal"); break; + case TYCOMPLEX: if (is_extern) + strcpy (buff, Ansi ? "/* Complex */ VOID" + : "/* Complex */ int"); + else + strcpy (buff, "complex"); + break; + case TYDCOMPLEX:if (is_extern) + strcpy (buff, Ansi ? "/* Double Complex */ VOID" + : "/* Double Complex */ int"); + else + strcpy (buff, "doublecomplex"); + break; + case TYLOGICAL: strcpy(buff, typename[TYLOGICAL]); + break; + case TYCHAR: if (is_extern) + strcpy (buff, Ansi ? "/* Character */ VOID" + : "/* Character */ int"); + 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() +{ return "ret_val_len"; } + +char *new_arg_length(arg) + Namep arg; +{ + static char buf[64]; + sprintf (buf, "%s_len", arg->fvarname); + + 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 +declare_new_addr (addrp) +struct Addrblock *addrp; +{ + extern chainp new_vars; + + new_vars = mkchain((char *)cpexpr((expptr)addrp), new_vars); +} /* declare_new_addr */ + + +wr_nv_ident_help (outfile, addrp) +FILE *outfile; +struct Addrblock *addrp; +{ + 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 nv_type_help (addrp) +struct Addrblock *addrp; +{ + if (addrp == (struct Addrblock *) NULL) + return -1; + + return addrp -> vtype; +} /* nv_type_help */ + + +/* lit_name -- returns a unique identifier for the given literal. Make + the label useful, when possible. For example: + + 1 -> c_1 (constant 1) + 2 -> c_2 (constant 2) + 1000 -> c_1000 (constant 1000) + 1000000 -> c_b (big constant number) + 1.2 -> c_1_2 (constant 1.2) + 1.234345 -> c_b (big constant number) + -1 -> c_n1 (constant -1) + -1.0 -> c_n1_0 (constant -1.0) + .true. -> c_true (constant true) + .false. -> c_false (constant false) + default -> c_b (default label) +*/ + +char *lit_name (litp) +struct Literal *litp; +{ + static char buf[CONST_IDENT_MAX]; + + if (litp == (struct Literal *) NULL) + return NULL; + + switch (litp -> littype) { + case TYSHORT: + if (litp -> litval.litival < 32768 && + litp -> litval.litival > -32769) { + ftnint val = litp -> litval.litival; + + if (val < 0) + sprintf (buf, "cs_n%ld", -val); + else + sprintf (buf, "cs__%ld", val); + } else + sprintf (buf, "c_b%d", litp -> litnum); + break; + case TYLONG: + if (litp -> litval.litival < 100000 && + litp -> litval.litival > -10000) { + ftnint val = litp -> litval.litival; + + if (val < 0) + sprintf (buf, "c_n%ld", -val); + else + sprintf (buf, "c__%ld", val); + } else + sprintf (buf, "c_b%d", litp -> litnum); + break; + case TYLOGICAL: + sprintf (buf, "c_%s", (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%d", litp -> litnum); + break; + } /* switch */ + return buf; +} /* lit_name */ + + + + char * +comm_union_name(count) + int count; +{ + 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 */ + +wr_globals (outfile) +FILE *outfile; +{ + struct Literal *litp, *lastlit; + extern int hsize; + extern char *lit_name(); + 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]; + y = x + 1; + nice_printf(outfile, + "static struct { %s fill; char val[%ld+1];", halign, x); + if (y %= hsize) + nice_printf(outfile, " char fill2[%ld];", hsize - y); + 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]; + 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 +commlen(vl) + register chainp vl; +{ + 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. */ +pad_common(c) + Extsym *c; +{ + 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"; + 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 + +wr_common_decls(outfile) + FILE *outfile; +{ + 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 */ + + +wr_struct (outfile, var_list) +FILE *outfile; +chainp var_list; +{ + 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, *wr_ardecls (); + + 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 *user_label(stateno) +ftnint stateno; +{ + 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 *temp_name (starter, num, storage) +char *starter; +int num; +char *storage; +{ + 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 *equiv_name (memno, store) +int memno; +char *store; +{ + 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 +def_commons(of) + FILE *of; +{ + Extsym *ext; + int c, onefile, Union; + char buf[64]; + chainp comm; + extern int ext1comm; + + if (ext1comm == 1) { + onefile = 1; + c_file = of; + fprintf(of, "/*>>>'/dev/null'<<<*/\n\ +#ifdef Define_COMMONs\n\ +/*<<>>*/\n"); + } + else + onefile = 0; + for(ext = extsymtab; ext < nextext; ext++) + if (ext->extstg == STGCOMMON + && !ext->extinit && (comm = ext->allextp)) { + sprintf(buf, "%scom.c", ext->cextname); + if (onefile) + fprintf(of, "/*>>>'%s'<<<*/\n", + buf); + else { + c_file = of = fopen(buf,textwrite); + if (!of) + fatalstr("can't open %s", buf); + } + fprintf(of, "#include \"f2c.h\"\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 (onefile) + fprintf(of, "/*<<<%s>>>*/\n", buf); + else + fclose(of); + } + if (onefile) + fprintf(of, "/*>>>'/dev/null'<<<*/\n#endif\n\ +/*<<>>*/\n"); + } + +/* 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", "address", "alist", "asin", "asm", + "atan", "atan2", "auto", "break", + "case", "catch", "char", "cilist", "class", "cllist", + "complex", "const", "continue", "cos", "cosh", + "dabs", "default", "defined", "delete", + "dmax", "dmin", "do", "double", "doublecomplex", "doublereal", + "else", "entry", "enum", "exp", "extern", + "flag", "float", "for", "friend", "ftnint", "ftnlen", "goto", + "icilist", "if", "include", "inline", "inlist", "int", "integer", + "log", "logical", "long", "max", "min", "new", + "olist", "operator", "overload", "private", "protected", "public", + "real", "register", "return", + "short", "shortint", "shortlogical", "signed", "sin", "sinh", + "sizeof", "sqrt", "static", "struct", "switch", + "tan", "tanh", "template", "this", "try", "typedef", + "union", "unsigned", "virtual", "void", "volatile", "while" +}; /* c_keywords */ + +int n_keywords = sizeof(c_keywords)/sizeof(char *); diff --git a/lang/fortran/comp/names.h b/lang/fortran/comp/names.h new file mode 100644 index 000000000..1ca17d0a0 --- /dev/null +++ b/lang/fortran/comp/names.h @@ -0,0 +1,22 @@ +#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 *new_io_ident (/* char * */); +char *new_func_length (/* char * */); +char *new_arg_length (/* Namep */); +void declare_new_addr (/* struct Addrblock * */); +char *nv_ident_help (/* struct Addrblock * */); +int nv_type_help (/* struct Addrblock */); +char *user_label (/* int */); +char *temp_name (/* int, char */); +char *c_type_decl (/* int, int */); +char *equiv_name (/* int, char * */); diff --git a/lang/fortran/comp/niceprintf.c b/lang/fortran/comp/niceprintf.c new file mode 100644 index 000000000..ab722d945 --- /dev/null +++ b/lang/fortran/comp/niceprintf.c @@ -0,0 +1,367 @@ +/**************************************************************** +Copyright 1990, 1991 by AT&T Bell Laboratories and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T Bell Laboratories or +Bellcore or any of their entities not be used in advertising or +publicity pertaining to distribution of the software without +specific, written prior permission. + +AT&T and Bellcore disclaim all warranties with regard to this +software, including all implied warranties of merchantability +and fitness. In no event shall AT&T or Bellcore be liable for +any special, indirect or consequential damages or any damages +whatsoever resulting from loss of use, data or profits, whether +in an action of contract, negligence or other tortious action, +arising out of or in connection with the use or performance of +this software. +****************************************************************/ + +#include "defs.h" +#include "names.h" +#include "output.h" + +#define TOO_LONG_INDENT (2 * tab_size) +#define MAX_INDENT 44 +#define MIN_INDENT 22 +static int last_was_newline = 0; +int indent = 0; +int in_comment = 0; + + static int +write_indent(fp, use_indent, extra_indent, start, end) + FILE *fp; + int use_indent, extra_indent; + char *start, *end; +{ + int ind, tab; + + 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 */ + + +/*VARARGS2*/ +int 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*/ +int 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 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() +{ + next_slot = output_buf = Alloc(MAX_OUTPUT_SIZE); + memset(output_buf, 0, MAX_OUTPUT_SIZE); + } + + static char * +adjust_pointer_in_string(pointer) + register char *pointer; +{ + 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 +fwd_strcpy(t, s) + register char *t, *s; +{ 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]) + +int 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; +{ + extern int max_line_len; + extern FILEP c_file; + extern char tr_tab[]; /* in output.c */ + register char *Tr = tr_tab; + int ch, 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 1; + } /* 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 = ind + extra_indent; + set_cursor = 0; + } + if (in_comment) + for (pointer = next_slot; *pointer && *pointer != '\n' && + cursor_pos <= max_line_len; 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 && isident(*(unsigned char *)pointer)) + word_start = pointer; + else if (word_start && isntident(*(unsigned char *)pointer)) + word_start = NULL; + 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 (word_start && *pointer != '\n' && 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) { + extern char *strchr(); + 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 + 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; + } + } + else { + extra_indent = TOO_LONG_INDENT; + if (In_string && !string_start) { + if (Ansi == 1) { + fprintf(fp, "\"\n"); + use_indent = 1; + last_was_newline = 1; + } + else { + fprintf(fp, "\\\n"); + last_was_newline = 0; + } + In_string = in_string0; + } + else { + 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); + + return 0; +} /* ind_printf */ diff --git a/lang/fortran/comp/niceprintf.h b/lang/fortran/comp/niceprintf.h new file mode 100644 index 000000000..24c65d4db --- /dev/null +++ b/lang/fortran/comp/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/lang/fortran/comp/output.c b/lang/fortran/comp/output.c new file mode 100644 index 000000000..4330e44d9 --- /dev/null +++ b/lang/fortran/comp/output.c @@ -0,0 +1,1431 @@ +/**************************************************************** +Copyright 1990, 1991 by AT&T Bell Laboratories and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T Bell Laboratories or +Bellcore or any of their entities not be used in advertising or +publicity pertaining to distribution of the software without +specific, written prior permission. + +AT&T and Bellcore disclaim all warranties with regard to this +software, including all implied warranties of merchantability +and fitness. In no event shall AT&T or Bellcore be liable for +any special, indirect or consequential damages or any damages +whatsoever resulting from loss of use, data or profits, whether +in an action of contract, negligence or other tortious action, +arising out of or in connection with the use or performance of +this software. +****************************************************************/ + +#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)" }, + +/* 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) + +static char opeqable[sizeof(opcode_table)/sizeof(table_entry)]; + + +static void output_prim (); +static void output_unary (), output_binary (), output_arg_list (); +static void output_list (), output_literal (); + + +void expr_out (fp, e) +FILE *fp; +expptr e; +{ + 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: warn ("expr_out: got TPRIM"); + output_prim (fp, &(e -> primblock)); + return; + + case TLIST: output_list (fp, &(e -> listblock)); + end_out: frexpr(e); + return; + + case TIMPLDO: err ("expr_out: got TIMPLDO"); + return; + + case TERROR: + default: + erri ("expr_out: bad tag '%d'", e -> tag); + } /* switch */ + +/* Now we know that the tag is TEXPR */ + +/* Optimize on simple expressions, such as "a = a + b" ==> "a += b" */ + + if (e -> exprblock.opcode == OPASSIGN && e -> exprblock.rightp && + e -> exprblock.rightp -> tag == TEXPR) { + int opcode; + + opcode = e -> exprblock.rightp -> exprblock.opcode; + + if (opeqable[opcode]) { + expptr leftp, rightp; + + if ((leftp = e -> exprblock.leftp) && + (rightp = e -> exprblock.rightp -> exprblock.leftp)) { + + if (same_ident (leftp, rightp)) { + expptr temp = e -> exprblock.rightp; + + e -> exprblock.opcode = op_assign(opcode); + + e -> exprblock.rightp = temp -> exprblock.rightp; + temp->exprblock.rightp = 0; + frexpr(temp); + } /* if same_ident (leftp, rightp) */ + } /* if leftp && rightp */ + } /* if opcode == OPPLUS || */ + } /* if e -> exprblock.opcode == OPASSIGN */ + + +/* Optimize on increment or decrement by 1 */ + + { + int opcode = e -> exprblock.opcode; + expptr leftp = e -> exprblock.leftp; + expptr rightp = e -> exprblock.rightp; + + if (leftp && rightp && (leftp -> headblock.vstg == STGARG || + ISINT (leftp -> headblock.vtype)) && + (opcode == OPPLUSEQ || opcode == OPMINUSEQ) && + ISINT (rightp -> headblock.vtype) && + ISICON (e -> exprblock.rightp) && + (ISONE (e -> exprblock.rightp) || + e -> exprblock.rightp -> constblock.Const.ci == -1)) { + +/* Allow for the '-1' constant value */ + + if (!ISONE (e -> exprblock.rightp)) + opcode = (opcode == OPPLUSEQ) ? OPMINUSEQ : OPPLUSEQ; + +/* replace the existing opcode */ + + if (opcode == OPPLUSEQ) + e -> exprblock.opcode = OPPREINC; + else + e -> exprblock.opcode = OPPREDEC; + +/* Free up storage used by the right hand side */ + + frexpr (e -> exprblock.rightp); + e->exprblock.rightp = 0; + } /* if opcode == OPPLUS */ + } /* block */ + + + if (is_unary_op (e -> exprblock.opcode)) + output_unary (fp, &(e -> exprblock)); + else if (is_binary_op (e -> exprblock.opcode)) + output_binary (fp, &(e -> exprblock)); + else + erri ("expr_out: bad opcode '%d'", (int) e -> exprblock.opcode); + + free((char *)e); + +} /* expr_out */ + + +void out_and_free_statement (outfile, expr) +FILE *outfile; +expptr expr; +{ + if (expr) + expr_out (outfile, expr); + + nice_printf (outfile, ";\n"); +} /* out_and_free_statement */ + + + +int same_ident (left, right) +expptr left, right; +{ + 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_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 +samefpconst(c1, c2, n) + register Constp c1, c2; + register int n; +{ + 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 +sameconst(c1, c2) + register Constp c1, c2; +{ + 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 same_expr (e1, e2) +expptr e1, e2; +{ + 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 out_name (fp, namep) + FILE *fp; + Namep namep; +{ + 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 */ + + +static char *Longfmt = "%ld"; + +#define cpd(n) cp->vstg ? cp->Const.cds[n] : dtos(cp->Const.cd[n]) + +void out_const(fp, cp) + FILE *fp; + register Constp cp; +{ + static char real_buf[50], imag_buf[50]; + unsigned int k; + int type = cp->vtype; + + switch (type) { + case TYSHORT: + nice_printf (fp, "%ld", cp->Const.ci); /* don't cast ci! */ + break; + case TYLONG: + nice_printf (fp, Longfmt, cp->Const.ci); /* don't cast ci! */ + break; + case TYREAL: + nice_printf(fp, "%s", flconst(real_buf, cpd(0))); + break; + case TYDREAL: + nice_printf(fp, "%s", cpd(0)); + break; + case TYCOMPLEX: + nice_printf(fp, cm_fmt_string, flconst(real_buf, cpd(0)), + flconst(imag_buf, cpd(1))); + break; + case TYDCOMPLEX: + nice_printf(fp, dcm_fmt_string, cpd(0), cpd(1)); + break; + case TYLOGICAL: + nice_printf (fp, "%s", cp->Const.ci ? "TRUE_" : "FALSE_"); + break; + case TYCHAR: { + char *c = cp->Const.ccp, *ce; + + if (c == NULL) { + nice_printf (fp, "\"\""); + break; + } /* if c == NULL */ + + nice_printf (fp, "\""); + ce = c + cp->vleng->constblock.Const.ci; + while(c < ce) { + k = *(unsigned char *)c++; + nice_printf(fp, str_fmt[k], k); + } + for(k = cp->Const.ccp1.blanks; k > 0; k--) + nice_printf(fp, " "); + nice_printf (fp, "\""); + break; + } /* case TYCHAR */ + default: + erri ("out_const: bad type '%d'", (int) type); + break; + } /* switch */ + +} /* out_const */ +#undef cpd + + +/* out_addr -- this routine isn't local because it is called by the + system-generated identifier printing routines */ + +void out_addr (fp, addrp) +FILE *fp; +struct Addrblock *addrp; +{ + 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_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, (int)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) + 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 output_literal (fp, memno, cp) + FILE *fp; + int memno; + Constp cp; +{ + struct Literal *litp, *lastlit; + extern char *lit_name (); + + 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 output_prim (fp, primp) +FILE *fp; +struct Primblock *primp; +{ + 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 output_arg_list (fp, listp) +FILE *fp; +struct Listblock *listp; +{ + 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 output_unary (fp, e) +FILE *fp; +struct Exprblock *e; +{ + if (e == NULL) + return; + + switch (e -> opcode) { + case OPNEG: + if (e->vtype == TYREAL && forcedouble) { + 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 * +findconst(m) + register long m; +{ + 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 +opconv_fudge(fp,e) + FILE *fp; + struct Exprblock *e; +{ + /* special handling for ichar and character*1 */ + register expptr lp = e->leftp; + register union Expression *Offset; + register char *cp; + int lt = lp->headblock.vtype; + char buf[8]; + unsigned int k; + Namep np; + + if (lp->addrblock.vtype == TYCHAR) { + switch(lp->tag) { + case TNAME: + nice_printf(fp, "*"); + out_name(fp, (Namep)lp); + return 1; + case TCONST: + tconst: + cp = lp->constblock.Const.ccp; + tconst1: + k = *(unsigned char *)cp; + sprintf(buf, chr_fmt[k], k); + nice_printf(fp, "'%s'", buf); + return 1; + case TADDR: + switch(lp->addrblock.vstg) { + case STGMEMNO: + cp = findconst(lp->addrblock.memno); + goto tconst1; + case STGCONST: + goto tconst; + } + lt = lp->addrblock.vtype = tyint; + Offset = lp->addrblock.memoffset; + if (lp->addrblock.uname_tag == 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; + break; + default: + badtag("opconv_fudge", lp->tag); + } + } + if (lt != e->vtype) + nice_printf(fp, "(%s) ", + c_type_decl(e->vtype, 0)); + return 0; + } + + +static void output_binary (fp, e) +FILE *fp; +struct Exprblock *e; +{ + char *format; + extern table_entry opcode_table[]; + int prec; + + if (e == NULL || e -> tag != TEXPR) + return; + +/* Instead of writing a huge switch, I've incorporated the output format + into a table. Things like "%l" and "%r" stand for the left and + right subexpressions. This should allow both prefix and infix + functions to be specified (e.g. "(%l * %r", "z_div (%l, %r"). Of + course, I should REALLY think out the ramifications of writing out + straight text, as opposed to some intermediate format, which could + figure out and optimize on the the number of required blanks (we don't + want "x - (-y)" to become "x --y", for example). Special cases (such as + incomplete implementations) could still be implemented as part of the + switch, they will just have some dummy value instead of the string + pattern. Another difficulty is the fact that the complex functions + will differ from the integer and real ones */ + +/* Handle a special case. We don't want to output "x + - 4", or "y - - 3" +*/ + if ((e -> opcode == OPPLUS || e -> opcode == OPMINUS) && + e -> rightp && e -> rightp -> tag == TCONST && + isnegative_const (&(e -> rightp -> constblock)) && + is_negatable (&(e -> rightp -> constblock))) { + + e -> opcode = (e -> opcode == OPPLUS) ? OPMINUS : OPPLUS; + negate_const (&(e -> rightp -> constblock)); + } /* if e -> opcode == PLUS or MINUS */ + + prec = op_precedence (e -> opcode); + format = op_format (e -> opcode); + + if (format != SPECIAL_FMT) { + while (*format) { + if (*format == '%') { + int arg_prec, use_paren = 0; + expptr lp, rp; + + switch (*(format + 1)) { + case 'l': + lp = e->leftp; + if (lp && lp->tag == TEXPR) { + arg_prec = op_precedence(lp->exprblock.opcode); + + use_paren = arg_prec && + (arg_prec < prec || (arg_prec == prec && + is_right_assoc (prec))); + } /* if e -> leftp */ + if (e->opcode == OPCONV && opconv_fudge(fp,e)) + break; + if (use_paren) + nice_printf (fp, "("); + expr_out(fp, lp); + if (use_paren) + nice_printf (fp, ")"); + break; + case 'r': + rp = e->rightp; + if (rp && rp->tag == TEXPR) { + arg_prec = op_precedence(rp->exprblock.opcode); + + use_paren = arg_prec && + (arg_prec < prec || (arg_prec == prec && + is_left_assoc (prec))); + use_paren = use_paren || + (rp->exprblock.opcode == OPNEG + && prec >= op_precedence(OPMINUS)); + } /* if e -> rightp */ + if (use_paren) + nice_printf (fp, "("); + expr_out(fp, rp); + if (use_paren) + nice_printf (fp, ")"); + break; + case '\0': + case '%': + nice_printf (fp, "%%"); + break; + default: + erri ("output_binary: format err: '%%%c' illegal", + (int) *(format + 1)); + break; + } /* switch */ + format += 2; + } else + nice_printf (fp, "%c", *format++); + } /* while *format */ + } else { + +/* Handle Special cases of formatting */ + + switch (e -> opcode) { + case OPCCALL: + case OPCALL: + out_call (fp, (int) e -> opcode, e -> vtype, + e -> vleng, e -> leftp, e -> rightp); + break; + + case OPCOMMA_ARG: + doin_setbound = 1; + nice_printf(fp, "("); + expr_out(fp, e->leftp); + nice_printf(fp, ", &"); + doin_setbound = 0; + expr_out(fp, e->rightp); + nice_printf(fp, ")"); + break; + + case OPADDR: + default: + nice_printf (fp, "Sorry, can't format OPCODE '%d'", + e -> opcode); + break; + } + + } /* else */ +} /* output_binary */ + + +out_call (outfile, op, ftype, len, name, args) +FILE *outfile; +int op, ftype; +expptr len, name, args; +{ + 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; + 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 */ + +/* 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, "("); + np = (Namep)name->exprblock.leftp; /*expr_out will free name */ + expr_out (outfile, name); + nice_printf (outfile, ")"); + } + else { + np = (Namep)name; + expr_out(outfile, name); + } + + /* prepare to cast procedure parameters -- set A if we know how */ + + A = np->tag == TNAME && (at = np->arginfo) && at->nargs > 0 + ? at->atypes : 0; + + nice_printf(outfile, "("); + + if (ret_val) { + if (ISCOMPLEX (ftype)) + nice_printf (outfile, "&"); + expr_out (outfile, (expptr) ret_val); + +/* 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; + + /* &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 + && Castargs + && (q->tag != TNAME + || q->nameblock.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]); + } + + 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 (tyioint == TYLONG) + Longfmt = "%ldL"; + out_const(outfile, &q->constblock); + Longfmt = "%ld"; + } + +/* 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 (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 * +flconst(buf, x) + char *buf, *x; +{ + sprintf(buf, fl_fmt_string, x); + return buf; + } + + char * +dtos(x) + double x; +{ + static char buf[64]; + sprintf(buf, db_fmt_string, x); + return 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 () +{ + extern int tab_size; + register char *s; + + s = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_+-."; + while(*s) + tr_tab[*s++] = 3; + tr_tab['>'] = 1; + + opeqable[OPPLUS] = 1; + opeqable[OPMINUS] = 1; + opeqable[OPSTAR] = 1; + opeqable[OPSLASH] = 1; + opeqable[OPMOD] = 1; + opeqable[OPLSHIFT] = 1; + opeqable[OPBITAND] = 1; + opeqable[OPBITXOR] = 1; + opeqable[OPBITOR ] = 1; + + +/* Set the output format for both types of floating point constants */ + + if (fl_fmt_string == NULL || *fl_fmt_string == '\0') + fl_fmt_string = Ansi == 1 ? "%sf" : "(float)%s"; + + if (db_fmt_string == NULL || *db_fmt_string == '\0') + db_fmt_string = "%.17g"; + +/* Set the output format for both types of complex constants. They will + have string parameters rather than float or double so that the decimal + point may be added to the strings generated by the {db,fl}_fmt_string + formats above */ + + if (cm_fmt_string == NULL || *cm_fmt_string == '\0') { + cm_fmt_string = "{%s,%s}"; + } /* if cm_fmt_string == NULL */ + + if (dcm_fmt_string == NULL || *dcm_fmt_string == '\0') { + dcm_fmt_string = "{%s,%s}"; + } /* if dcm_fmt_string == NULL */ + + tab_size = 4; +} /* out_init */ + + +void extern_out (fp, extsym) +FILE *fp; +Extsym *extsym; +{ + if (extsym == (Extsym *) NULL) + return; + + nice_printf (fp, "%s", extsym->cextname); + +} /* extern_out */ + + + +static void output_list (fp, listp) +FILE *fp; +struct Listblock *listp; +{ + 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 out_asgoto (outfile, expr) +FILE *outfile; +expptr expr; +{ + char *user_label(); + 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 out_if (outfile, expr) +FILE *outfile; +expptr expr; +{ + nice_printf (outfile, "if ("); + expr_out (outfile, expr); + nice_printf (outfile, ") {\n"); + next_tab (outfile); +} /* out_if */ + + static void +output_rbrace(outfile, s) + FILE *outfile; + char *s; +{ + 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 out_else (outfile) +FILE *outfile; +{ + prev_tab (outfile); + output_rbrace(outfile, "} else {\n"); + next_tab (outfile); +} /* out_else */ + +void elif_out (outfile, expr) +FILE *outfile; +expptr expr; +{ + prev_tab (outfile); + output_rbrace(outfile, "} else "); + out_if (outfile, expr); +} /* elif_out */ + +void endif_out (outfile) +FILE *outfile; +{ + prev_tab (outfile); + output_rbrace(outfile, "}\n"); +} /* endif_out */ + +void end_else_out (outfile) +FILE *outfile; +{ + prev_tab (outfile); + output_rbrace(outfile, "}\n"); +} /* end_else_out */ + + + +void compgoto_out (outfile, index, labels) +FILE *outfile; +expptr index, labels; +{ + 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 { + extern char *user_label (); + 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 out_for (outfile, init, test, inc) +FILE *outfile; +expptr init, test, inc; +{ + 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 out_end_for (outfile) +FILE *outfile; +{ + prev_tab (outfile); + nice_printf (outfile, "}\n"); +} /* out_end_for */ diff --git a/lang/fortran/comp/output.h b/lang/fortran/comp/output.h new file mode 100644 index 000000000..2bc21da3b --- /dev/null +++ b/lang/fortran/comp/output.h @@ -0,0 +1,65 @@ +/* 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" + +extern int nice_printf (); + + +/* 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 expr_out (), out_init (), out_addr (), out_const (); +void out_name (), extern_out (), out_asgoto (); +void out_if (), out_else (), elif_out (); +void endif_out (), end_else_out (); +void compgoto_out (), out_for (); +void out_end_for (), out_and_free_statement (); diff --git a/lang/fortran/comp/p1defs.h b/lang/fortran/comp/p1defs.h new file mode 100644 index 000000000..16bda0edc --- /dev/null +++ b/lang/fortran/comp/p1defs.h @@ -0,0 +1,160 @@ +#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 */ + +extern void p1put (/* int */); +extern void p1_comment (/* char * */); +extern void p1_label (/* int */); +extern void p1_line_number (/* int */); +extern void p1put_filename(); +extern void p1_expr (/* expptr */); +extern void p1_head (/* int, char * */); +extern void p1_if (/* expptr */); +extern void p1_else (); +extern void p1_elif (/* expptr */); +extern void p1_endif (); +extern void p1else_end (); +extern void p1_subr_ret (/* expptr */); +extern void p1_goto(/* long */); +extern void p1comp_goto (/* expptr, int, struct Labelblock *[] */); +extern void p1_for (/* expptr, expptr, expptr */); +extern void p1for_end (); + + +extern void p1puts (/* int, char * */); + +/* The pass 1 intermediate file has the following format: + + [ : [ [ ]]] \n + + e.g. 1: This is a comment + + This format is destined to change in the future, but for now a readable + form is more desirable than a compact form. + + NOTES ABOUT THE P1 FORMAT + ---------------------------------------------------------------------- + + P1_COMMENT: The comment string (in ) may be at most + COMMENT_BUFFER_SIZE bytes long. It must contain no newlines + or null characters. A side effect of the way comments are + read in lex.c is that no '\377' chars may be in a + comment either. + + P1_SET_LINE: holds the line number in the current source file. + + P1_INC_LINE: Increment the source line number; is empty. + + P1_NAME_POINTER: holds the integer representation of a + pointer into a hash table entry. + + P1_CONST: the first field in is a type tag (one of the + TYxxxx macros), the next field holds the constant + value + + P1_EXPR: holds the opcode number of the expression, + followed by the type of the expression (required for + OPCONV). Next is the value of vleng. + The type of operation represented by the + opcode determines how many of the following data items + are part of this expression. + + P1_IDENT: holds the type, then storage, then the + char string identifier in the addrp->user field. + + P1_EXTERN: holds an offset into the external symbol + table entry + + P1_HEAD: the first field in is the procedure class, the + second is the name of the procedure + + P1_LIST: the first field in is the tag, the second the + type of the list, the third the number of elements in + the list + + P1_LITERAL: holds the litnum of a value in the + literal pool. + + P1_LABEL: holds the statement number of the current + line + + P1_ASGOTO: holds the hash table pointer of the variable + + P1_GOTO: holds the statement number to jump to + + P1_IF: is empty, the following expression is the IF + condition. + + P1_ELSE: is empty. + + P1_ELIF: is empty, the following expression is the IF + condition. + + P1_ENDIF: is empty. + + P1_ENDELSE: is empty. + + P1_ADDR: holds a direct copy of the structure. The + next expression is a copy of vleng, and the next a + copy of memoffset. + + P1_SUBR_RET: The next token is an expression for the return value. + + P1_COMP_GOTO: The next token is an integer expression, the + following one a list of labels. + + P1_FOR: The next three expressions are the Init, Test, and + Increment expressions of a C FOR loop. + + P1_ENDFOR: Marks the end of the body of a FOR loop + +*/ diff --git a/lang/fortran/comp/p1output.c b/lang/fortran/comp/p1output.c new file mode 100644 index 000000000..0d381fc13 --- /dev/null +++ b/lang/fortran/comp/p1output.c @@ -0,0 +1,568 @@ +/**************************************************************** +Copyright 1990, 1991 by AT&T Bell Laboratories and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T Bell Laboratories or +Bellcore or any of their entities not be used in advertising or +publicity pertaining to distribution of the software without +specific, written prior permission. + +AT&T and Bellcore disclaim all warranties with regard to this +software, including all implied warranties of merchantability +and fitness. In no event shall AT&T or Bellcore be liable for +any special, indirect or consequential damages or any damages +whatsoever resulting from loss of use, data or profits, whether +in an action of contract, negligence or other tortious action, +arising out of or in connection with the use or performance of +this software. +****************************************************************/ + +#include "defs.h" +#include "p1defs.h" +#include "output.h" +#include "names.h" + + +static void p1_addr(), p1_big_addr(), p1_binary(), p1_const(), p1_list(), + p1_literal(), p1_name(), p1_unary(), p1putn(); +static void p1putd (/* int, int */); +static void p1putds (/* int, int, char * */); +static void p1putdds (/* int, int, int, char * */); +static void p1putdd (/* int, int, int */); +static void p1putddd (/* int, int, int, int */); + + +/* 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 p1_comment (str) +char *str; +{ + 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 */ + +void p1_line_number (line_number) +long line_number; +{ + + p1putd (P1_SET_LINE, line_number); +} /* p1_line_number */ + +/* p1_name -- Writes the address of a hash table entry into the + intermediate file */ + +static void p1_name (namep) +Namep namep; +{ + p1putd (P1_NAME_POINTER, (long) namep); + namep->visused = 1; +} /* p1_name */ + + + +void p1_expr (expr) +expptr expr; +{ +/* 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 p1_const(cp) + register Constp cp; +{ + int type = cp->vtype; + expptr vleng = cp->vleng; + union Constant *c = &cp->Const; + char cdsbuf0[64], cdsbuf1[64]; + char *cds0, *cds1; + + switch (type) { + case TYSHORT: + case TYLONG: + case TYLOGICAL: + fprintf(pass1_file, "%d: %d %ld\n", P1_CONST, type, c->ci); + break; + case TYREAL: + case TYDREAL: + fprintf(pass1_file, "%d: %d %s\n", P1_CONST, type, + cp->vstg ? c->cds[0] : cds(dtos(c->cd[0]), cdsbuf0)); + break; + case TYCOMPLEX: + case TYDCOMPLEX: + if (cp->vstg) { + cds0 = c->cds[0]; + cds1 = c->cds[1]; + } + else { + cds0 = cds(dtos(c->cd[0]), cdsbuf0); + cds1 = cds(dtos(c->cd[1]), cdsbuf1); + } + fprintf(pass1_file, "%d: %d %s %s\n", P1_CONST, type, + cds0, cds1); + break; + case TYCHAR: + if (vleng && !ISICON (vleng)) + erri("p1_const: bad vleng '%d'\n", (int) vleng); + else + fprintf(pass1_file, "%d: %d %lx\n", P1_CONST, type, + cpexpr((expptr)cp)); + break; + default: + erri ("p1_const: bad constant type '%d'", type); + break; + } /* switch */ +} /* p1_const */ + + +void p1_asgoto (addrp) +Addrp addrp; +{ + p1put (P1_ASGOTO); + p1_addr (addrp); +} /* p1_asgoto */ + + +void p1_goto (stateno) +ftnint stateno; +{ + p1putd (P1_GOTO, stateno); +} /* p1_goto */ + + +static void p1_addr (addrp) + register struct Addrblock *addrp; +{ + 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 p1_list (listp) +struct Listblock *listp; +{ + 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 p1_label (lab) +long lab; +{ + if (parstate < INDATA) + earlylabs = mkchain((char *)lab, earlylabs); + else + p1putd (P1_LABEL, lab); + } + + + +static void p1_literal (memno) +long memno; +{ + p1putd (P1_LITERAL, memno); +} /* p1_literal */ + + +void p1_if (expr) +expptr expr; +{ + p1put (P1_IF); + p1_expr (expr); +} /* p1_if */ + + + + +void p1_elif (expr) +expptr expr; +{ + p1put (P1_ELIF); + p1_expr (expr); +} /* p1_elif */ + + + + +void p1_else () +{ + p1put (P1_ELSE); +} /* p1_else */ + + + + +void p1_endif () +{ + p1put (P1_ENDIF); +} /* p1_endif */ + + + + +void p1else_end () +{ + p1put (P1_ENDELSE); +} /* p1else_end */ + + +static void p1_big_addr (addrp) +Addrp addrp; +{ + if (addrp == (Addrp) NULL) + return; + + p1putn (P1_ADDR, 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 p1_unary (e) +struct Exprblock *e; +{ + 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 p1_binary (e) +struct Exprblock *e; +{ + 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 p1_head (class, name) +int class; +char *name; +{ + p1putds (P1_HEAD, class, name ? name : ""); +} /* p1_head */ + + +void p1_subr_ret (retexp) +expptr retexp; +{ + + p1put (P1_SUBR_RET); + p1_expr (cpexpr(retexp)); +} /* p1_subr_ret */ + + + +void p1comp_goto (index, count, labels) +expptr index; +int count; +struct Labelblock *labels[]; +{ + 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 p1_for (init, test, inc) +expptr init, test, inc; +{ + p1put (P1_FOR); + p1_expr (init); + p1_expr (test); + p1_expr (inc); +} /* p1_for */ + + +void p1for_end () +{ + 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 p1puts (type, str) +int type; +char *str; +{ + fprintf (pass1_file, "%d: %s\n", type, str); +} /* p1puts */ + + +/* p1putd -- Put a typed integer into the Pass 1 intermediate file. */ + +static void p1putd (type, value) +int type; +long value; +{ + fprintf (pass1_file, "%d: %ld\n", type, value); +} /* p1_putd */ + + +/* p1putdd -- Put a typed pair of integers into the intermediate file. */ + +static void p1putdd (type, v1, v2) +int type, v1, v2; +{ + fprintf (pass1_file, "%d: %d %d\n", type, v1, v2); +} /* p1putdd */ + + +/* p1putddd -- Put a typed triple of integers into the intermediate file. */ + +static void p1putddd (type, v1, v2, v3) +int type, v1, v2, v3; +{ + fprintf (pass1_file, "%d: %d %d %d\n", type, v1, v2, v3); +} /* p1putddd */ + + union dL { + double d; + long L[2]; + }; + +static void p1putn (type, count, str) +int type, count; +char *str; +{ + 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 p1put(type) +int type; +{ + fprintf (pass1_file, "%d:\n", type); +} /* p1put */ + + + +static void p1putds (type, i, str) +int type; +int i; +char *str; +{ + fprintf (pass1_file, "%d: %d %s\n", type, i, str); +} /* p1putds */ + + +static void p1putdds (token, type, stg, str) +int token, type, stg; +char *str; +{ + fprintf (pass1_file, "%d: %d %d %s\n", token, type, stg, str); +} /* p1putdds */ diff --git a/lang/fortran/comp/parse.h b/lang/fortran/comp/parse.h new file mode 100644 index 000000000..1eb2c5465 --- /dev/null +++ b/lang/fortran/comp/parse.h @@ -0,0 +1,39 @@ +#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; + +extern int parse_args (); + +#endif diff --git a/lang/fortran/comp/parse_args.c b/lang/fortran/comp/parse_args.c new file mode 100644 index 000000000..77ec6f02f --- /dev/null +++ b/lang/fortran/comp/parse_args.c @@ -0,0 +1,499 @@ +/**************************************************************** +Copyright 1990 by AT&T Bell Laboratories and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T Bell Laboratories or +Bellcore or any of their entities not be used in advertising or +publicity pertaining to distribution of the software without +specific, written prior permission. + +AT&T and Bellcore disclaim all warranties with regard to this +software, including all implied warranties of merchantability +and fitness. In no event shall AT&T or Bellcore be liable for +any special, indirect or consequential damages or any damages +whatsoever resulting from loss of use, data or profits, whether +in an action of contract, negligence or other tortious action, +arising out of or in connection with the use or performance of +this software. +****************************************************************/ + +/* parse_args + + This function will parse command line input into appropriate data + structures, output error messages when appropriate and provide some + minimal type conversion. + + Input to the function consists of the standard argc,argv + values, and a table which directs the parser. Each table entry has the + following components: + + prefix -- the (optional) switch character string, e.g. "-" "/" "=" + switch -- the command string, e.g. "o" "data" "file" "F" + flags -- control flags, e.g. CASE_INSENSITIVE, REQUIRED_PREFIX + arg_count -- number of arguments this command requires, e.g. 0 for + booleans, 1 for filenames, INFINITY for input files + result_type -- how to interpret the switch arguments, e.g. STRING, + CHAR, FILE, OLD_FILE, NEW_FILE + result_ptr -- pointer to storage for the result, be it a table or + a string or whatever + table_size -- if the arguments fill a table, the maximum number of + entries; if there are no arguments, the value to + load into the result storage + + Although the table can be used to hold a list of filenames, only + scalar values (e.g. pointers) can be stored in the table. No vector + processing will be done, only pointers to string storage will be moved. + + An example entry, which could be used to parse input filenames, is: + + "-", "o", 0, oo, OLD_FILE, infilenames, INFILE_TABLE_SIZE + +*/ + +#include +#ifndef NULL +/* ANSI C */ +#include +#endif +#include "parse.h" +#include /* For atof */ +#include + +#define MAX_INPUT_SIZE 1000 + +#define arg_prefix(x) ((x).prefix) +#define arg_string(x) ((x).string) +#define arg_flags(x) ((x).flags) +#define arg_count(x) ((x).count) +#define arg_result_type(x) ((x).result_type) +#define arg_result_ptr(x) ((x).result_ptr) +#define arg_table_size(x) ((x).table_size) + +#ifndef TRUE +#define TRUE 1 +#endif +#ifndef FALSE +#define FALSE 0 +#endif +typedef int boolean; + + +char *lower_string (/* char [], char * */); + +static char *this_program = ""; + +extern long atol(); +static int arg_parse (/* char *, arg_info * */); + + +boolean parse_args (argc, argv, table, entries, others, other_count) +int argc; +char *argv[]; +arg_info table[]; +int entries; +char *others[]; +int other_count; +{ + boolean arg_verify (/* argv, table, entries */); + void init_store (/* table, entries */); + + 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); + } /* else */ + } /* if (others) */ + argv0 = *++argv; + argc--; + } else { + +/* A match was found */ + + if (length >= strlen (*argv)) { + argc--; + argv0 = *++argv; + use_prefix = TRUE; + } else { + (*argv) += length; + use_prefix = FALSE; + } /* else */ + +/* Parse any necessary arguments */ + + if (arg_count (table[index]) != P_NO_ARGS) { + +/* Now length will be used to store the number of parsed characters */ + + length = arg_parse(*argv, &table[index]); + if (*argv == NULL) + argc = 0; + else if (length >= strlen (*argv)) { + argc--; + argv0 = *++argv; + use_prefix = TRUE; + } else { + (*argv) += length; + use_prefix = FALSE; + } /* else */ + } /* if (argv_count != P_NO_ARGS) */ + else + *arg_result_ptr(table[index]) = + arg_table_size(table[index]); + } /* else */ + } /* while (argc) */ + } /* if (result) */ + + return result; +} /* parse_args */ + + +boolean arg_verify (argv, table, entries) +char *argv[]; +arg_info table[]; +int entries; +{ + 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)); + } /* 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); + } /* 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); + } /* 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); + } + +/* 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); + } /* 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 match_table (norm_input, table, entries, use_prefix, length) +register char *norm_input; +arg_info table[]; +int entries; +boolean use_prefix; +int *length; +{ + extern int match (/* char *, char *, arg_info *, boolean */); + + 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 +*/ + +int match (norm_input, low_input, entry, use_prefix) +char *norm_input, *low_input; +arg_info *entry; +boolean use_prefix; +{ + 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 */ + + +char *lower_string (dest, src) +char *dest, *src; +{ + 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 arg_parse (str, entry) +char *str; +arg_info *entry; +{ + 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 */ + + +int put_one_arg (type, str, store, prefix, string) +int type; +char *str; +char **store; +char *prefix, *string; +{ + int length = 0; + long L; + + if (store) { + switch (type) { + case P_STRING: + case P_FILE: + case P_OLD_FILE: + case P_NEW_FILE: + *store = str; + if (str == NULL) + fprintf (stderr, "%s: Missing argument after '%s%s'\n", + this_program, prefix, string); + length = str ? strlen (str) : 0; + 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); + 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); + 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); + break; + } /* switch */ + } /* if (store) */ + + return length; +} /* put_one_arg */ + + +void init_store (table, entries) +arg_info *table; +int entries; +{ + 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/lang/fortran/comp/pccdefs.h b/lang/fortran/comp/pccdefs.h new file mode 100644 index 000000000..bde81177a --- /dev/null +++ b/lang/fortran/comp/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/lang/fortran/comp/pread.c b/lang/fortran/comp/pread.c new file mode 100644 index 000000000..5f521efac --- /dev/null +++ b/lang/fortran/comp/pread.c @@ -0,0 +1,881 @@ +/**************************************************************** +Copyright 1990 by AT&T Bell Laboratories and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T Bell Laboratories or +Bellcore or any of their entities not be used in advertising or +publicity pertaining to distribution of the software without +specific, written prior permission. + +AT&T and Bellcore disclaim all warranties with regard to this +software, including all implied warranties of merchantability +and fitness. In no event shall AT&T or Bellcore be liable for +any special, indirect or consequential damages or any damages +whatsoever resulting from loss of use, data or profits, whether +in an action of contract, negligence or other tortious action, +arising out of or in connection with the use or performance of +this software. +****************************************************************/ + +#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() +{ + 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 +badchar(c) + int c; +{ + fprintf(stderr, + "unexpected character 0x%.2x = '%c' on line %ld of %s\n", + c, c, Plineno, Pfname); + exit(2); + } + + static void +bad_type() +{ + fprintf(stderr, + "unexpected type \"%s\" on line %ld of %s\n", + Ptok, Plineno, Pfname); + exit(2); + } + + static void +badflag(tname, option) + char *tname, *option; +{ + fprintf(stderr, "%s type from `f2c -%s` on line %ld of %s\n", + tname, option, Plineno, Pfname); + Pbad++; + } + + static void +detected(msg) + char *msg; +{ + fprintf(stderr, + "%sdetected on line %ld of %s\n", msg, Plineno, Pfname); + Pbad++; + } + + static void +checklogical(k) + int k; +{ + 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"); + } + } + } + + static void +checkreal(k) +{ + static int warned = 0; + static int seen[2] = {0,0}; + + seen[k] = 1; + if (seen[1-k]) { + if (warned < 2) + detected("Illegal mixture of -R and -!R "); + warned = 2; + return; + } + if (k == forcedouble || warned) + return; + warned = 1; + badflag("REAL return", k ? "!R" : "R"); + } + + static void +Pnotboth(e) + Extsym *e; +{ + 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 +numread(pf, n) + register FILE *pf; + int *n; +{ + 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(), Pbadret(); + + static int +readref(pf, e, ftype) + register FILE *pf; + Extsym *e; + int ftype; +{ + 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->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 +comlen(pf) + register FILE *pf; +{ + 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 = mkext(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 +Ptoken(pf, canend) + FILE *pf; + int canend; +{ + 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() +{ + 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; + break; + case 'l': + if (!strcmp(Ptok+1, "ogical")) { + checklogical(1); + return TYLOGICAL; + } + 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 TYLOGICAL; + } + break; + } + bad_type(); + /* NOT REACHED */ + return 0; + } + + static void +wanted(i, what) + int i; + char *what; +{ + 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 +Ptype(pf) + FILE *pf; +{ + 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; + 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; + 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 (!strcmp(Ptok+1, "nteger")) + rv = TYLONG; + break; + case 'l': + if (!strcmp(Ptok+1, "ogical")) { + checklogical(1); + rv = TYLOGICAL; + } + 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 = TYLOGICAL; + } + 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() +{ + 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 +Pbadmsg(msg, p) + char *msg; + Extsym *p; +{ + Pbad++; + fprintf(stderr, "%s for %s (line %ld of %s):\n\t", msg, + p->fextname, Plineno, Pfname); + p->arginfo->nargs = -1; + } + + char *Argtype(); + + static void +Pbadret(ftype, p) + int ftype; + Extsym *p; +{ + 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 +argverify(ftype, p) + int ftype; + Extsym *p; +{ + Argtypes *at; + register Atype *aty; + int i, j, k; + register int *t, *te; + char buf1[32], buf2[32]; + int type_fixup(); + + 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 +newarg(ftype, p) + int ftype; + Extsym *p; +{ + 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->nargs = i; + at->changes = 0; + for(aty = at->atypes; t < te; aty++) { + aty->type = *t++; + aty->cp = 0; + } + } + + static int +Pfile(fname) + char *fname; +{ + 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 = mkext(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); + else + newarg(ftype, p); + i = Ptoken(pf,0); + switch(i) { + case ';': + break; + case ',': + goto getname; + default: + wanted(i, "\";\" or \",\""); + } + } + fclose(pf); + return 1; + } + + void +read_Pfiles(ffiles) + char **ffiles; +{ + 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/lang/fortran/comp/proc.c b/lang/fortran/comp/proc.c new file mode 100644 index 000000000..3c1718b07 --- /dev/null +++ b/lang/fortran/comp/proc.c @@ -0,0 +1,1562 @@ +/**************************************************************** +Copyright 1990 by AT&T Bell Laboratories and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T Bell Laboratories or +Bellcore or any of their entities not be used in advertising or +publicity pertaining to distribution of the software without +specific, written prior permission. + +AT&T and Bellcore disclaim all warranties with regard to this +software, including all implied warranties of merchantability +and fitness. In no event shall AT&T or Bellcore be liable for +any special, indirect or consequential damages or any damages +whatsoever resulting from loss of use, data or profits, whether +in an action of contract, negligence or other tortious action, +arising out of or in connection with the use or performance of +this software. +****************************************************************/ + +#include "defs.h" +#include "names.h" +#include "output.h" +#include "p1defs.h" + +#define EXNULL (union Expression *)0 + +LOCAL dobss(), docomleng(), docommon(), doentry(), + epicode(), nextarg(), retval(); + +static char Blank[] = BLANKCOMMON; + + static char *postfix[] = { "h", "i", "r", "d", "c", "z", "i" }; + + chainp new_procs; + int prev_proc, proc_argchanges, proc_protochanges; + + void +changedtype(q) + Namep q; +{ + 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) + 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 +unamstring(q, s) + register Addrp q; + register char *s; +{ + 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() /* 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 = TYSHORT; i <= TYLOGICAL; i++) + if (a = xretslot[i]) + sprintf(a->user.ident, "(*ret_val).%s", + postfix[i-TYSHORT]); + + do { + np = e->enamep; + switch(np->vtype) { + case TYSHORT: + case TYLONG: + case TYREAL: + case TYDREAL: + case TYCOMPLEX: + case TYDCOMPLEX: + case TYLOGICAL: + np->vstg = STGARG; + } + } + while(e = e->entnextp); + } + + static void +putentries(outfile) /* put out wrappers for multiple entries */ + FILE *outfile; +{ + char base[IDENT_LEN]; + struct Entrypoint *e; + Namep *A, *Ae, *Ae1, **Alp, *a, **a1, np; + chainp args, lengths, length_comp(); + void listargs(), list_arg_types(); + int i, k, mt, nL, type; + extern char *dfltarg[], **dfltproc; + + nL = (nallargs + nallchargs) * sizeof(Namep *); + A = (Namep *)ckalloc(nL + nallargs*sizeof(Namep **)); + Ae = A + nallargs; + Alp = (Namep **)(Ae1 = Ae + nallchargs); + i = k = 0; + for(a1 = Alp, args = allargs; args; a1++, args = args->nextp) { + np = (Namep)args->datap; + if (np->vtype == TYCHAR && np->vclass != CLPROC) + *a1 = &Ae[i++]; + } + + e = entries; + 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) + nice_printf(outfile, ", %s", (np = *a) + ? np->cvarname + : ((Namep)args->datap)->vclass == CLPROC + ? dfltproc[((Namep)args->datap)->vtype] + : dfltarg[((Namep)args->datap)->vtype]); + for(; a < Ae1; a++) + if (np = *a) + nice_printf(outfile, ", %s_len", np->fvarname); + 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;\nreturn 0;\n"); + else if (type == TYDCOMPLEX) + nice_printf(outfile, + "r_v->r = ret_val.z.r; r_v->i = ret_val.z.i;\nreturn 0;\n"); + else nice_printf(outfile, "return ret_val.%s;\n", + postfix[type-TYSHORT]); + } + else if (ONEOF(type, M(TYCHAR)|M(TYCOMPLEX)|M(TYDCOMPLEX))) + nice_printf(outfile, "return 0;\n"); + nice_printf(outfile, "}\n"); + prev_tab(outfile); + } + while(e = e->entnextp); + free((char *)A); + } + + static void +entry_goto(outfile) + FILEP outfile; +{ + 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 */ + +newproc() +{ + if(parstate != OUTSIDE) + { + execerr("missing end statement", CNULL); + endproc(); + } + + parstate = INSIDE; + procclass = CLMAIN; /* default */ +} + + static void +zap_changes() +{ + 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 */ + +endproc() +{ + 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. */ + +enddcl() +{ + register struct Entrypoint *ep; + struct Entrypoint *ep0; + extern void freetemps(); + 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); + } +} + +/* ROUTINES CALLED WHEN ENCOUNTERING ENTRY POINTS */ + +/* Main program or Block data */ + +startproc(progname, class) +Extsym * progname; +int class; +{ + register struct Entrypoint *p; + + p = ALLOC(Entrypoint); + if(class == CLMAIN) { + puthead(CNULL, CLMAIN); + if (progname) + strcpy (main_alias, progname->cextname); + } else + 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 *newentry(v, substmsg) + register Namep v; + int substmsg; +{ + 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); +} + + +entrypt(class, type, length, entry, args) +int class, type; +ftnint length; +Extsym *entry; +chainp args; +{ + register Namep q; + register struct Entrypoint *p; + extern int types3[]; + + 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 epicode() +{ + 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 && lastwasbranch == NO) + p1_subr_ret (ICON(0)); + } + else if (!multitype && lastwasbranch == NO) + retval(proctype); + } + lastwasbranch = NO; +} + + +/* generate code to return value of type t */ + +LOCAL retval(t) +register int t; +{ + register Addrp p; + + switch(t) + { + case TYCHAR: + case TYCOMPLEX: + case TYDCOMPLEX: + break; + + case TYLOGICAL: + t = tylogical; + case TYADDR: + case TYSHORT: + case TYLONG: + case TYREAL: + case TYDREAL: + p = (Addrp) cpexpr((expptr)retslot); + p->vtype = t; + p1_subr_ret (mkconv (t, fixtype((expptr)p))); + break; + + default: + badtype("retval", t); + } +} + + +/* Do parameter adjustments */ + +procode(outfile) +FILE *outfile; +{ + prolog(outfile, allargs); + + if (nentry > 1) + entry_goto(outfile); + } + +/* 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 +dim_finish(v) + Namep v; +{ + register struct Dimblock *p; + register expptr q; + register int i, nd; + extern expptr make_int_expr(); + + p = v->vdim; + v->vdimfinish = 0; + nd = p->ndim; + doin_setbound = 1; + for(i = 0; i < nd; i++) + if (q = p->dims[i].dimexpr) + p->dims[i].dimexpr = make_int_expr(putx(fixtype(q))); + if (q = p->basexpr) + p->basexpr = make_int_expr(putx(fixtype(q))); + doin_setbound = 0; + } + + static void +duparg(q) + Namep q; +{ errstr("duplicate argument %.80s", q->fvarname); } + +/* + manipulate argument lists (allocate argument slot positions) + * keep track of return types and labels + */ + +LOCAL doentry(ep) +struct Entrypoint *ep; +{ + register int type; + register Namep np; + chainp p, p1; + register Namep q; + Addrp mkarg(), rs; + int it, k; + extern char dflttype[26]; + Extsym *entryname = ep->entryname; + + if (++nentry > 1) + p1_label((long)(extsymtab - entryname - 1)); + +/* The main program isn't allowed to have parameters, so any given + parameters are ignored */ + + if(procclass == CLMAIN || procclass == CLBLOCK) + return; + +/* So now we're working with something other than CLMAIN or CLBLOCK. + Determine the type of its return value. */ + + impldcl( np = mkname(entryname->fextname) ); + type = np->vtype; + proc_argchanges = prev_proc && type != entryname->extype; + entryname->extseen = 1; + if(proctype == TYUNKNOWN) + if( (proctype = type) == TYCHAR) + procleng = np->vleng ? np->vleng->constblock.Const.ci + : (ftnint) (-1); + + if(proctype == TYCHAR) + { + if(type != TYCHAR) + err("noncharacter entry of character function"); + +/* Functions returning type char can only have multiple entries if all + entries return the same length */ + + else if( (np->vleng ? np->vleng->constblock.Const.ci : + (ftnint) (-1)) != procleng) + err("mismatched character entry lengths"); + } + else if(type == TYCHAR) + err("character entry of noncharacter function"); + else if(type != proctype) + multitype = YES; + if(rtvlabel[type] == 0) + rtvlabel[type] = 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, 0); + infertypes = it; +} + + + +LOCAL nextarg(type) +int type; +{ + int k; + k = lastargslot; + lastargslot += typesize[type]; + return(k); +} + + LOCAL +dim_check(q) + Namep q; +{ + register struct Dimblock *vdim = q->vdim; + + if(!vdim->nelt || !ISICON(vdim->nelt)) + dclerr("adjustable dimension on non-argument", q); + else if (vdim->nelt->constblock.Const.ci <= 0) + dclerr("nonpositive dimension", q); + } + +LOCAL dobss() +{ + register struct Hashentry *p; + register Namep q; + int qstg, qclass, qtype; + Extsym *e; + + for(p = hashtab ; pvarp) + { + qstg = q->vstg; + qtype = q->vtype; + qclass = q->vclass; + + if( (qclass==CLUNKNOWN && qstg!=STGARG) || + (qclass==CLVAR && qstg==STGUNKNOWN) ) { + if (!(q->vis_assigned | q->vimpldovar)) + warn1("local variable %s never used", + q->fvarname); + } + else if(qclass==CLVAR && qstg==STGBSS) + { ; } + +/* Give external procedures the proper storage class */ + + else if(qclass==CLPROC && q->vprocclass==PEXTERNAL + && qstg!=STGARG) { + e = mkext(q->fvarname,addunder(q->cvarname)); + e->extstg = STGEXT; + q->vardesc.varno = e - extsymtab; + if (e->extype != qtype) + changedtype(q); + } + if(qclass==CLVAR) { + if (qstg != STGARG && q->vdim) + dim_check(q); + } /* if qclass == CLVAR */ + } + +} + + + +donmlist() +{ + register struct Hashentry *p; + register Namep q; + + for(p=hashtab; pvarp) && q->vclass==CLNAMELIST) + namelist(q); +} + + +/* iarrlen -- Returns the size of the array in bytes, or -1 */ + +ftnint iarrlen(q) +register Namep q; +{ + 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); +} + +namelist(np) +Namep np; +{ + 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 docommon() +{ + register Extsym *extptr; + register chainp q, q1; + struct Dimblock *t; + expptr neltp; + register Namep comvar; + ftnint size; + int i, k, pref, type; + extern int type_pref[]; + + for(extptr = extsymtab ; extptrextstg == STGCOMMON && (q = extptr->extp)) { + +/* If a common declaration also had a list of variables ... */ + + q = extptr->extp = revchain(q); + pref = 1; + for(k = TYCHAR; q ; q = q->nextp) + { + comvar = (Namep) (q->datap); + + if(comvar->vdcldone == NO) + vardcl(comvar); + type = comvar->vtype; + if (pref < type_pref[type]) + pref = type_pref[k = type]; + if(extptr->extleng % typealign[type] != 0) { + dclerr("common alignment", comvar); + --nerr; /* don't give bad return code for this */ +#if 0 + extptr->extleng = roundup(extptr->extleng, typealign[type]); +#endif + } /* if extptr -> extleng % */ + +/* Set the offset into the common block */ + + comvar->voffset = extptr->extleng; + comvar->vardesc.varno = extptr - extsymtab; + if(type == TYCHAR) + size = comvar->vleng->constblock.Const.ci; + 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 */ + +copy_data (list) +chainp list; +{ + 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 docomleng() +{ + 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 */ + +frtemp(p) +Addrp p; +{ + /* put block on chain of temps to be reclaimed */ + holdtemps = mkchain((char *)p, holdtemps); +} + + void +freetemps() +{ + 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 autovar(nelt0, t, lengp, name) +register int nelt0, t; +expptr lengp; +char *name; +{ + ftnint leng; + register Addrp q; + char *temp_name (); + 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 mktmpn(nelt, type, lengp) +int nelt; +register int type; +expptr lengp; +{ + ftnint leng; + chainp p, oldp; + register Addrp q; + + if(type==TYUNKNOWN || type==TYERROR) + badtype("mktmpn", type); + + if(type==TYCHAR) + if( 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 + */ + 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 mktmp(type, lengp) +int type; +expptr lengp; +{ + 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 mktmp0(type, lengp) +int type; +expptr lengp; +{ + 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 *comblock(s) + register char *s; +{ + 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 = mkext(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 = mkext(s0,cbuf); + } + if(p->extstg == STGUNKNOWN) + p->extstg = STGCOMMON; + else if(p->extstg != STGCOMMON) + { + errstr("%.68s cannot be a common block name", s); + return(0); + } + + return( p ); +} + + +/* incomm -- add a new variable to a common declaration */ + +incomm(c, v) +Extsym *c; +Namep v; +{ + 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 */ + +settype(v, type, length) +register Namep v; +register int type; +register ftnint length; +{ + 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->vimpltype && v->vtype != type) + { + 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; + + 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 + && !xretslot[type]) + xretslot[type] = autovar(ONEOF(type, + MSKCOMPLEX|MSKCHAR) ? 0 : 1, type, + v->vleng, " ret_val"); + /* 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) { + 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 */ + +lengtype(type, len) +register int type; +ftnint len; +{ + 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 TYSHORT: + case TYDREAL: + case TYDCOMPLEX: + case TYCHAR: + case TYUNKNOWN: + case TYSUBR: + case TYERROR: + goto ret; + + case TYLOGICAL: + if(length == typesize[TYLOGICAL]) + goto ret; + if(length == 1 || length == 2) { + erri("treating LOGICAL*%d as LOGICAL", length); + --nerr; /* allow generation of .c file */ + goto ret; + } + break; + + case TYLONG: + if(length == 0) + return(tyint); + if(length == typesize[TYSHORT]) + return(TYSHORT); + 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 */ + +setintr(v) +register Namep v; +{ + int k; + + 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); + 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); + } +} + + + +/* setext -- Set External declaration -- assume that unknowns will become + procedures */ + +setext(v) +register Namep v; +{ + 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 */ + +setbound(v, nd, dims) +register Namep v; +int nd; +struct Dims dims[ ]; +{ + register expptr q, t; + register struct Dimblock *p; + int i; + extern chainp new_vars; + char buf[256]; + + if(v->vclass == CLUNKNOWN) + v->vclass = CLVAR; + else if(v->vclass != CLVAR) + { + dclerr("only variables may be arrays", v); + return; + } + + v->vdim = p = (struct Dimblock *) + ckalloc( sizeof(int) + (3+2*nd)*sizeof(expptr) ); + p->ndim = nd--; + p->nelt = ICON(1); + doin_setbound = 1; + + for(i = 0; i <= nd; ++i) + { + if( (q = dims[i].ub) == NULL) + { + if(i == nd) + { + frexpr(p->nelt); + p->nelt = NULL; + } + else + err("only last bound may be asterisk"); + p->dims[i].dimsize = ICON(1); + ; + p->dims[i].dimexpr = NULL; + } + else + { + + if(dims[i].lb) + { + q = mkexpr(OPMINUS, q, cpexpr(dims[i].lb)); + q = mkexpr(OPPLUS, q, ICON(1) ); + } + if( ISCONST(q) ) + { + p->dims[i].dimsize = q; + p->dims[i].dimexpr = (expptr) PNULL; + } + else { + sprintf(buf, " %s_dim%d", v->fvarname, i+1); + p->dims[i].dimsize = (expptr) + autovar(1, tyint, EXNULL, buf); + p->dims[i].dimexpr = q; + if (i == nd) + v->vlastdim = new_vars; + v->vdimfinish = 1; + } + if(p->nelt) + p->nelt = mkexpr(OPSTAR, p->nelt, + cpexpr(p->dims[i].dimsize) ); + } + } + + q = dims[nd].lb; + if(q == NULL) + q = ICON(1); + + for(i = nd-1 ; i>=0 ; --i) + { + t = dims[i].lb; + if(t == NULL) + t = ICON(1); + if(p->dims[i].dimsize) + q = mkexpr(OPPLUS, t, mkexpr(OPSTAR, cpexpr(p->dims[i].dimsize), q) ); + } + + if( ISCONST(q) ) + { + p->baseoffset = q; + p->basexpr = NULL; + } + else + { + sprintf(buf, " %s_offset", v->fvarname); + p->baseoffset = (expptr) autovar(1, tyint, EXNULL, buf); + p->basexpr = q; + v->vdimfinish = 1; + } + doin_setbound = 0; +} + + + +wr_abbrevs (outfile, function_head, vars) +FILE *outfile; +int function_head; +chainp vars; +{ + 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/lang/fortran/comp/proto.make b/lang/fortran/comp/proto.make new file mode 100644 index 000000000..7c3995f33 --- /dev/null +++ b/lang/fortran/comp/proto.make @@ -0,0 +1,373 @@ +# $Header$ + +# Makefile for f2c, a Fortran 77 to C converter + +#PARAMS do not remove this line! + +UTIL_BIN = \ + $(UTIL_HOME)/bin +SRC_DIR = \ + $(SRC_HOME)/lang/fortran/comp +INCLUDES = -I$(SRC_DIR) -I. +CFLAGS = $(COPTIONS) $(INCLUDES) +LINTFLAGS = $(LINTOPTIONS) $(INCLUDES) +LDFLAGS = $(LDOPTIONS) + +OBJECTS = main.$(SUF) init.$(SUF) gram.$(SUF) lex.$(SUF) proc.$(SUF) \ + equiv.$(SUF) data.$(SUF) format.$(SUF) expr.$(SUF) exec.$(SUF) \ + intr.$(SUF) io.$(SUF) misc.$(SUF) error.$(SUF) mem.$(SUF) \ + names.$(SUF) output.$(SUF) p1output.$(SUF) pread.$(SUF) put.$(SUF) \ + putpcc.$(SUF) vax.$(SUF) formatdata.$(SUF) parse_args.$(SUF) \ + niceprintf.$(SUF) cds.$(SUF) sysdep.$(SUF) version.$(SUF) + + +GSRC = \ + $(SRC_DIR)/gram.head \ + $(SRC_DIR)/gram.dcl \ + $(SRC_DIR)/gram.expr \ + $(SRC_DIR)/gram.exec \ + $(SRC_DIR)/gram.io +CSRC = \ + $(SRC_DIR)/main.c \ + $(SRC_DIR)/init.c \ + $(SRC_DIR)/lex.c \ + $(SRC_DIR)/proc.c \ + $(SRC_DIR)/equiv.c \ + $(SRC_DIR)/data.c \ + $(SRC_DIR)/format.c \ + $(SRC_DIR)/expr.c \ + $(SRC_DIR)/exec.c \ + $(SRC_DIR)/intr.c \ + $(SRC_DIR)/io.c \ + $(SRC_DIR)/misc.c \ + $(SRC_DIR)/error.c \ + $(SRC_DIR)/mem.c \ + $(SRC_DIR)/names.c \ + $(SRC_DIR)/output.c \ + $(SRC_DIR)/p1output.c \ + $(SRC_DIR)/pread.c \ + $(SRC_DIR)/put.c \ + $(SRC_DIR)/putpcc.c \ + $(SRC_DIR)/vax.c \ + $(SRC_DIR)/formatdata.c \ + $(SRC_DIR)/parse_args.c \ + $(SRC_DIR)/niceprintf.c \ + $(SRC_DIR)/cds.c \ + $(SRC_DIR)/sysdep.c \ + $(SRC_DIR)/version.c +HSRC = \ + $(SRC_DIR)/defines.h \ + $(SRC_DIR)/defs.h \ + $(SRC_DIR)/f2c.h \ + $(SRC_DIR)/format.h \ + $(SRC_DIR)/ftypes.h \ + $(SRC_DIR)/iob.h \ + $(SRC_DIR)/machdefs.h \ + $(SRC_DIR)/names.h \ + $(SRC_DIR)/niceprintf.h \ + $(SRC_DIR)/output.h \ + $(SRC_DIR)/p1defs.h \ + $(SRC_DIR)/parse.h \ + $(SRC_DIR)/pccdefs.h \ + $(SRC_DIR)/sysdep.h \ + $(SRC_DIR)/usignal.h + +SRC = $(SRC_DIR)/tokens $(GSRC) $(HSRC) $(CSRC) + +CFILES = gram.c $(CSRC) + +all: f2c + +install: all + rm -f $(TARGET_HOME)/lib.bin/f2c + cp f2c $(TARGET_HOME)/lib.bin/f2c + rm -f $(TARGET_HOME)/man/f2c.6 + cp $(SRC_DIR)/f2c.6 $(TARGET_HOME)/man/f2c.6 + rm -f $(TARGET_HOME)/include/_tail_cc/f2c.h + cp $(SRC_DIR)/f2c.h $(TARGET_HOME)/include/_tail_cc/f2c.h + +cmp: all + -cmp f2c $(TARGET_HOME)/lib.bin/f2c + -cmp $(SRC_DIR)/f2c.6 $(TARGET_HOME)/man/f2c.6 + -cmp $(SRC_DIR)/f2c.h $(TARGET_HOME)/include/_tail_cc/f2c.h + +lint: $(CFILES) tokdefs.h + $(LINT) $(LINTFLAGS) $(CFILES) + +pr: + @pr $(SRC_DIR)/proto.make $(SRC) + +pr: + make pr | opr + +depend: $(CFILES) tokdefs.h + sed '/^#DEPENDENCIES/,$$d' Makefile >Makefile.new + echo '#DEPENDENCIES' >>Makefile.new + for i in $(CFILES) ; do \ + echo "`basename $$i .c`.$$(SUF): $$i" >> Makefile.new ; \ + echo ' $$(CC) -c $$(CFLAGS)' $$i >> Makefile.new ; \ + $(UTIL_HOME)/lib.bin/cpp -d $(INCLUDES) $$i | sed "s/^/`basename $$i .c`.$$(SUF): /" >> Makefile.new ; \ + done + mv Makefile Makefile.old + mv Makefile.new Makefile + +f2c: $(OBJECTS) + $(CC) $(LDFLAGS) $(OBJECTS) $(TARGET_HOME)/modules/lib/libstring.$(LIBSUF) -o f2c + +gram.c: $(GSRC) $(SRC_DIR)/defs.h tokdefs.h + ( sed gram.in + yacc gram.in + echo "(expect 4 shift/reduce)" + sed 's/^# line.*/\/* & *\//' y.tab.c >gram.c + rm -f gram.in y.tab.c + +tokdefs.h: $(SRC_DIR)/tokens + grep -n . <$(SRC_DIR)/tokens | \ + sed "s/\([^:]*\):\(.*\)/#define \2 \1/" >tokdefs.h + +clean: + rm -f gram.c *.$(SUF) f2c tokdefs.h Out + +#DEPENDENCIES +gram.$(SUF): gram.c + $(CC) -c $(CFLAGS) gram.c +gram.$(SUF): $(SRC_DIR)/p1defs.h +gram.$(SUF): $(SRC_DIR)/machdefs.h +gram.$(SUF): $(SRC_DIR)/defines.h +gram.$(SUF): $(SRC_DIR)/ftypes.h +gram.$(SUF): $(SRC_DIR)/sysdep.h +gram.$(SUF): $(SRC_DIR)/defs.h +main.$(SUF): $(SRC_DIR)/main.c + $(CC) -c $(CFLAGS) $(SRC_DIR)/main.c +main.$(SUF): $(SRC_DIR)/parse.h +main.$(SUF): $(SRC_DIR)/machdefs.h +main.$(SUF): $(SRC_DIR)/defines.h +main.$(SUF): $(SRC_DIR)/ftypes.h +main.$(SUF): $(SRC_DIR)/sysdep.h +main.$(SUF): $(SRC_DIR)/defs.h +init.$(SUF): $(SRC_DIR)/init.c + $(CC) -c $(CFLAGS) $(SRC_DIR)/init.c +init.$(SUF): $(SRC_DIR)/iob.h +init.$(SUF): $(SRC_DIR)/niceprintf.h +init.$(SUF): $(SRC_DIR)/output.h +init.$(SUF): $(SRC_DIR)/machdefs.h +init.$(SUF): $(SRC_DIR)/defines.h +init.$(SUF): $(SRC_DIR)/ftypes.h +init.$(SUF): $(SRC_DIR)/sysdep.h +init.$(SUF): $(SRC_DIR)/defs.h +lex.$(SUF): $(SRC_DIR)/lex.c + $(CC) -c $(CFLAGS) $(SRC_DIR)/lex.c +lex.$(SUF): $(SRC_DIR)/p1defs.h +lex.$(SUF): ./tokdefs.h +lex.$(SUF): $(SRC_DIR)/machdefs.h +lex.$(SUF): $(SRC_DIR)/defines.h +lex.$(SUF): $(SRC_DIR)/ftypes.h +lex.$(SUF): $(SRC_DIR)/sysdep.h +lex.$(SUF): $(SRC_DIR)/defs.h +proc.$(SUF): $(SRC_DIR)/proc.c + $(CC) -c $(CFLAGS) $(SRC_DIR)/proc.c +proc.$(SUF): $(SRC_DIR)/p1defs.h +proc.$(SUF): $(SRC_DIR)/niceprintf.h +proc.$(SUF): $(SRC_DIR)/output.h +proc.$(SUF): $(SRC_DIR)/names.h +proc.$(SUF): $(SRC_DIR)/machdefs.h +proc.$(SUF): $(SRC_DIR)/defines.h +proc.$(SUF): $(SRC_DIR)/ftypes.h +proc.$(SUF): $(SRC_DIR)/sysdep.h +proc.$(SUF): $(SRC_DIR)/defs.h +equiv.$(SUF): $(SRC_DIR)/equiv.c + $(CC) -c $(CFLAGS) $(SRC_DIR)/equiv.c +equiv.$(SUF): $(SRC_DIR)/machdefs.h +equiv.$(SUF): $(SRC_DIR)/defines.h +equiv.$(SUF): $(SRC_DIR)/ftypes.h +equiv.$(SUF): $(SRC_DIR)/sysdep.h +equiv.$(SUF): $(SRC_DIR)/defs.h +data.$(SUF): $(SRC_DIR)/data.c + $(CC) -c $(CFLAGS) $(SRC_DIR)/data.c +data.$(SUF): $(SRC_DIR)/machdefs.h +data.$(SUF): $(SRC_DIR)/defines.h +data.$(SUF): $(SRC_DIR)/ftypes.h +data.$(SUF): $(SRC_DIR)/sysdep.h +data.$(SUF): $(SRC_DIR)/defs.h +format.$(SUF): $(SRC_DIR)/format.c + $(CC) -c $(CFLAGS) $(SRC_DIR)/format.c +format.$(SUF): $(SRC_DIR)/iob.h +format.$(SUF): $(SRC_DIR)/names.h +format.$(SUF): $(SRC_DIR)/niceprintf.h +format.$(SUF): $(SRC_DIR)/output.h +format.$(SUF): $(SRC_DIR)/format.h +format.$(SUF): $(SRC_DIR)/p1defs.h +format.$(SUF): $(SRC_DIR)/machdefs.h +format.$(SUF): $(SRC_DIR)/defines.h +format.$(SUF): $(SRC_DIR)/ftypes.h +format.$(SUF): $(SRC_DIR)/sysdep.h +format.$(SUF): $(SRC_DIR)/defs.h +expr.$(SUF): $(SRC_DIR)/expr.c + $(CC) -c $(CFLAGS) $(SRC_DIR)/expr.c +expr.$(SUF): $(SRC_DIR)/names.h +expr.$(SUF): $(SRC_DIR)/niceprintf.h +expr.$(SUF): $(SRC_DIR)/output.h +expr.$(SUF): $(SRC_DIR)/machdefs.h +expr.$(SUF): $(SRC_DIR)/defines.h +expr.$(SUF): $(SRC_DIR)/ftypes.h +expr.$(SUF): $(SRC_DIR)/sysdep.h +expr.$(SUF): $(SRC_DIR)/defs.h +exec.$(SUF): $(SRC_DIR)/exec.c + $(CC) -c $(CFLAGS) $(SRC_DIR)/exec.c +exec.$(SUF): $(SRC_DIR)/names.h +exec.$(SUF): $(SRC_DIR)/p1defs.h +exec.$(SUF): $(SRC_DIR)/machdefs.h +exec.$(SUF): $(SRC_DIR)/defines.h +exec.$(SUF): $(SRC_DIR)/ftypes.h +exec.$(SUF): $(SRC_DIR)/sysdep.h +exec.$(SUF): $(SRC_DIR)/defs.h +intr.$(SUF): $(SRC_DIR)/intr.c + $(CC) -c $(CFLAGS) $(SRC_DIR)/intr.c +intr.$(SUF): $(SRC_DIR)/names.h +intr.$(SUF): $(SRC_DIR)/machdefs.h +intr.$(SUF): $(SRC_DIR)/defines.h +intr.$(SUF): $(SRC_DIR)/ftypes.h +intr.$(SUF): $(SRC_DIR)/sysdep.h +intr.$(SUF): $(SRC_DIR)/defs.h +io.$(SUF): $(SRC_DIR)/io.c + $(CC) -c $(CFLAGS) $(SRC_DIR)/io.c +io.$(SUF): $(SRC_DIR)/iob.h +io.$(SUF): $(SRC_DIR)/names.h +io.$(SUF): $(SRC_DIR)/machdefs.h +io.$(SUF): $(SRC_DIR)/defines.h +io.$(SUF): $(SRC_DIR)/ftypes.h +io.$(SUF): $(SRC_DIR)/sysdep.h +io.$(SUF): $(SRC_DIR)/defs.h +misc.$(SUF): $(SRC_DIR)/misc.c + $(CC) -c $(CFLAGS) $(SRC_DIR)/misc.c +misc.$(SUF): $(SRC_DIR)/machdefs.h +misc.$(SUF): $(SRC_DIR)/defines.h +misc.$(SUF): $(SRC_DIR)/ftypes.h +misc.$(SUF): $(SRC_DIR)/sysdep.h +misc.$(SUF): $(SRC_DIR)/defs.h +error.$(SUF): $(SRC_DIR)/error.c + $(CC) -c $(CFLAGS) $(SRC_DIR)/error.c +error.$(SUF): $(SRC_DIR)/machdefs.h +error.$(SUF): $(SRC_DIR)/defines.h +error.$(SUF): $(SRC_DIR)/ftypes.h +error.$(SUF): $(SRC_DIR)/sysdep.h +error.$(SUF): $(SRC_DIR)/defs.h +mem.$(SUF): $(SRC_DIR)/mem.c + $(CC) -c $(CFLAGS) $(SRC_DIR)/mem.c +mem.$(SUF): $(SRC_DIR)/iob.h +mem.$(SUF): $(SRC_DIR)/machdefs.h +mem.$(SUF): $(SRC_DIR)/defines.h +mem.$(SUF): $(SRC_DIR)/ftypes.h +mem.$(SUF): $(SRC_DIR)/sysdep.h +mem.$(SUF): $(SRC_DIR)/defs.h +names.$(SUF): $(SRC_DIR)/names.c + $(CC) -c $(CFLAGS) $(SRC_DIR)/names.c +names.$(SUF): $(SRC_DIR)/iob.h +names.$(SUF): $(SRC_DIR)/names.h +names.$(SUF): $(SRC_DIR)/niceprintf.h +names.$(SUF): $(SRC_DIR)/output.h +names.$(SUF): $(SRC_DIR)/machdefs.h +names.$(SUF): $(SRC_DIR)/defines.h +names.$(SUF): $(SRC_DIR)/ftypes.h +names.$(SUF): $(SRC_DIR)/sysdep.h +names.$(SUF): $(SRC_DIR)/defs.h +output.$(SUF): $(SRC_DIR)/output.c + $(CC) -c $(CFLAGS) $(SRC_DIR)/output.c +output.$(SUF): $(SRC_DIR)/niceprintf.h +output.$(SUF): $(SRC_DIR)/output.h +output.$(SUF): $(SRC_DIR)/names.h +output.$(SUF): $(SRC_DIR)/machdefs.h +output.$(SUF): $(SRC_DIR)/defines.h +output.$(SUF): $(SRC_DIR)/ftypes.h +output.$(SUF): $(SRC_DIR)/sysdep.h +output.$(SUF): $(SRC_DIR)/defs.h +p1output.$(SUF): $(SRC_DIR)/p1output.c + $(CC) -c $(CFLAGS) $(SRC_DIR)/p1output.c +p1output.$(SUF): $(SRC_DIR)/names.h +p1output.$(SUF): $(SRC_DIR)/niceprintf.h +p1output.$(SUF): $(SRC_DIR)/output.h +p1output.$(SUF): $(SRC_DIR)/p1defs.h +p1output.$(SUF): $(SRC_DIR)/machdefs.h +p1output.$(SUF): $(SRC_DIR)/defines.h +p1output.$(SUF): $(SRC_DIR)/ftypes.h +p1output.$(SUF): $(SRC_DIR)/sysdep.h +p1output.$(SUF): $(SRC_DIR)/defs.h +pread.$(SUF): $(SRC_DIR)/pread.c + $(CC) -c $(CFLAGS) $(SRC_DIR)/pread.c +pread.$(SUF): $(SRC_DIR)/machdefs.h +pread.$(SUF): $(SRC_DIR)/defines.h +pread.$(SUF): $(SRC_DIR)/ftypes.h +pread.$(SUF): $(SRC_DIR)/sysdep.h +pread.$(SUF): $(SRC_DIR)/defs.h +put.$(SUF): $(SRC_DIR)/put.c + $(CC) -c $(CFLAGS) $(SRC_DIR)/put.c +put.$(SUF): $(SRC_DIR)/p1defs.h +put.$(SUF): $(SRC_DIR)/pccdefs.h +put.$(SUF): $(SRC_DIR)/names.h +put.$(SUF): $(SRC_DIR)/machdefs.h +put.$(SUF): $(SRC_DIR)/defines.h +put.$(SUF): $(SRC_DIR)/ftypes.h +put.$(SUF): $(SRC_DIR)/sysdep.h +put.$(SUF): $(SRC_DIR)/defs.h +putpcc.$(SUF): $(SRC_DIR)/putpcc.c + $(CC) -c $(CFLAGS) $(SRC_DIR)/putpcc.c +putpcc.$(SUF): $(SRC_DIR)/p1defs.h +putpcc.$(SUF): $(SRC_DIR)/names.h +putpcc.$(SUF): $(SRC_DIR)/niceprintf.h +putpcc.$(SUF): $(SRC_DIR)/output.h +putpcc.$(SUF): $(SRC_DIR)/pccdefs.h +putpcc.$(SUF): $(SRC_DIR)/machdefs.h +putpcc.$(SUF): $(SRC_DIR)/defines.h +putpcc.$(SUF): $(SRC_DIR)/ftypes.h +putpcc.$(SUF): $(SRC_DIR)/sysdep.h +putpcc.$(SUF): $(SRC_DIR)/defs.h +vax.$(SUF): $(SRC_DIR)/vax.c + $(CC) -c $(CFLAGS) $(SRC_DIR)/vax.c +vax.$(SUF): $(SRC_DIR)/niceprintf.h +vax.$(SUF): $(SRC_DIR)/output.h +vax.$(SUF): $(SRC_DIR)/pccdefs.h +vax.$(SUF): $(SRC_DIR)/machdefs.h +vax.$(SUF): $(SRC_DIR)/defines.h +vax.$(SUF): $(SRC_DIR)/ftypes.h +vax.$(SUF): $(SRC_DIR)/sysdep.h +vax.$(SUF): $(SRC_DIR)/defs.h +formatdata.$(SUF): $(SRC_DIR)/formatdata.c + $(CC) -c $(CFLAGS) $(SRC_DIR)/formatdata.c +formatdata.$(SUF): $(SRC_DIR)/format.h +formatdata.$(SUF): $(SRC_DIR)/names.h +formatdata.$(SUF): $(SRC_DIR)/niceprintf.h +formatdata.$(SUF): $(SRC_DIR)/output.h +formatdata.$(SUF): $(SRC_DIR)/machdefs.h +formatdata.$(SUF): $(SRC_DIR)/defines.h +formatdata.$(SUF): $(SRC_DIR)/ftypes.h +formatdata.$(SUF): $(SRC_DIR)/sysdep.h +formatdata.$(SUF): $(SRC_DIR)/defs.h +parse_args.$(SUF): $(SRC_DIR)/parse_args.c + $(CC) -c $(CFLAGS) $(SRC_DIR)/parse_args.c +parse_args.$(SUF): $(SRC_DIR)/parse.h +niceprintf.$(SUF): $(SRC_DIR)/niceprintf.c + $(CC) -c $(CFLAGS) $(SRC_DIR)/niceprintf.c +niceprintf.$(SUF): $(SRC_DIR)/niceprintf.h +niceprintf.$(SUF): $(SRC_DIR)/output.h +niceprintf.$(SUF): $(SRC_DIR)/names.h +niceprintf.$(SUF): $(SRC_DIR)/machdefs.h +niceprintf.$(SUF): $(SRC_DIR)/defines.h +niceprintf.$(SUF): $(SRC_DIR)/ftypes.h +niceprintf.$(SUF): $(SRC_DIR)/sysdep.h +niceprintf.$(SUF): $(SRC_DIR)/defs.h +cds.$(SUF): $(SRC_DIR)/cds.c + $(CC) -c $(CFLAGS) $(SRC_DIR)/cds.c +cds.$(SUF): $(SRC_DIR)/sysdep.h +sysdep.$(SUF): $(SRC_DIR)/sysdep.c + $(CC) -c $(CFLAGS) $(SRC_DIR)/sysdep.c +sysdep.$(SUF): $(SRC_DIR)/usignal.h +sysdep.$(SUF): $(SRC_DIR)/machdefs.h +sysdep.$(SUF): $(SRC_DIR)/defines.h +sysdep.$(SUF): $(SRC_DIR)/ftypes.h +sysdep.$(SUF): $(SRC_DIR)/sysdep.h +sysdep.$(SUF): $(SRC_DIR)/defs.h +version.$(SUF): $(SRC_DIR)/version.c + $(CC) -c $(CFLAGS) $(SRC_DIR)/version.c +memset.$(SUF): $(SRC_DIR)/memset.c + $(CC) -c $(CFLAGS) $(SRC_DIR)/memset.c diff --git a/lang/fortran/comp/put.c b/lang/fortran/comp/put.c new file mode 100644 index 000000000..fcab40042 --- /dev/null +++ b/lang/fortran/comp/put.c @@ -0,0 +1,399 @@ +/**************************************************************** +Copyright 1990 by AT&T Bell Laboratories and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T Bell Laboratories or +Bellcore or any of their entities not be used in advertising or +publicity pertaining to distribution of the software without +specific, written prior permission. + +AT&T and Bellcore disclaim all warranties with regard to this +software, including all implied warranties of merchantability +and fitness. In no event shall AT&T or Bellcore be liable for +any special, indirect or consequential damages or any damages +whatsoever resulting from loss of use, data or profits, whether +in an action of contract, negligence or other tortious action, +arising out of or in connection with the use or performance of +this software. +****************************************************************/ + +/* + * INTERMEDIATE CODE GENERATION PROCEDURES COMMON TO BOTH + * JOHNSON (PORTABLE) AND RITCHIE FAMILIES OF SECOND PASSES +*/ + +#include "defs.h" +#include "names.h" /* For LOCAL_CONST_NAME */ +#include "pccdefs.h" +#include "p1defs.h" + +/* Definitions for putconst() */ + +#define LIT_CHAR 1 +#define LIT_FLOAT 2 +#define LIT_INT 3 + + +/* +char *ops [ ] = + { + "??", "+", "-", "*", "/", "**", "-", + "OR", "AND", "EQV", "NEQV", "NOT", + "CONCAT", + "<", "==", ">", "<=", "!=", ">=", + " of ", " ofC ", " = ", " += ", " *= ", " CONV ", " << ", " % ", + " , ", " ? ", " : " + " abs ", " min ", " max ", " addr ", " indirect ", + " bitor ", " bitand ", " bitxor ", " bitnot ", " >> ", + }; +*/ + +/* Each of these values is defined in pccdefs */ + +int ops2 [ ] = +{ + P2BAD, P2PLUS, P2MINUS, P2STAR, P2SLASH, P2BAD, P2NEG, + P2OROR, P2ANDAND, P2EQ, P2NE, P2NOT, + P2BAD, + P2LT, P2EQ, P2GT, P2LE, P2NE, P2GE, + P2CALL, P2CALL, P2ASSIGN, P2PLUSEQ, P2STAREQ, P2CONV, P2LSHIFT, P2MOD, + P2COMOP, P2QUEST, P2COLON, + 1, P2BAD, P2BAD, P2BAD, P2BAD, + P2BITOR, P2BITAND, P2BITXOR, P2BITNOT, P2RSHIFT, + P2BAD, P2BAD, P2BAD, P2BAD, P2BAD, P2BAD, P2BAD, P2BAD, P2BAD, + P2BAD, P2BAD, P2BAD, P2BAD, + 1,1,1,1,1, /* OPNEG1, OPDMIN, OPDMAX, OPASSIGNI, OPIDENTITY */ + 1,1,1,1 /* OPCHARCAST, OPDABS, OPMIN2, OPMAX2 */ +}; + + +int types2 [ ] = +{ + P2BAD, P2INT|P2PTR, P2SHORT, P2LONG, P2REAL, P2DREAL, + P2REAL, P2DREAL, P2LONG, P2CHAR, P2INT, P2BAD +}; + + +setlog() +{ + types2[TYLOGICAL] = types2[tylogical]; + typesize[TYLOGICAL] = typesize[tylogical]; + typealign[TYLOGICAL] = typealign[tylogical]; +} + + +void putex1(p) +expptr p; +{ +/* Write the expression to the p1 file */ + + p = (expptr) putx (fixtype (p)); + p1_expr (p); +} + + + + + +expptr putassign(lp, rp) +expptr lp, rp; +{ + return putx(fixexpr((Exprp)mkexpr(OPASSIGN, lp, rp))); +} + + + + +void puteq(lp, rp) +expptr lp, rp; +{ + putexpr(mkexpr(OPASSIGN, lp, rp) ); +} + + + + +/* put code for a *= b */ + +expptr putsteq(a, b) +Addrp a, b; +{ + return putx( fixexpr((Exprp) + mkexpr(OPSTAREQ, cpexpr((expptr)a), cpexpr((expptr)b)))); +} + + + + +Addrp mkfield(res, f, ty) +register Addrp res; +char *f; +int ty; +{ + res -> vtype = ty; + res -> Field = f; + return res; +} /* mkfield */ + + +Addrp realpart(p) +register Addrp p; +{ + register Addrp q; + expptr mkrealcon(); + + if (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)); + } /* if p -> uname_tag */ + + q = (Addrp) cpexpr((expptr) p); + if( ISCOMPLEX(p->vtype) ) + q = mkfield (q, "r", p -> vtype + TYREAL - TYCOMPLEX); + + return(q); +} + + + + +expptr imagpart(p) +register Addrp p; +{ + register Addrp q; + expptr mkrealcon(); + + if( ISCOMPLEX(p->vtype) ) + { + if (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 */ + +ncat(p) +register expptr p; +{ + 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 lencat(p) +register expptr p; +{ + 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 putconst(p) +register Constp p; +{ + register Addrp q; + struct Literal *litp, *lastlit; + int k, len, type; + int litflavor; + double cd[2]; + ftnint nblanks; + char *strp; + char cdsbuf0[64], cdsbuf1[64], *ds[2]; + + if (p->tag != TCONST) + badtag("putconst", p->tag); + + q = ALLOC(Addrblock); + q->tag = TADDR; + type = p->vtype; + q->vtype = ( type==TYADDR ? tyint : type ); + q->vleng = (expptr) cpexpr(p->vleng); + q->vstg = STGCONST; + +/* Create the new label for the constant. This is wasteful of labels + because when the constant value already exists in the literal pool, + this label gets thrown away and is never reclaimed. It might be + cleaner to move this down past the first switch() statement below */ + + q->memno = newlabel(); + q->memoffset = ICON(0); + q -> uname_tag = UNAM_CONST; + +/* Copy the constant info into the Addrblock; do this by copying the + largest storage elts */ + + q -> user.Const = p -> Const; + q->user.kludge.vstg1 = p->vstg; /* distinguish string from binary fp */ + + /* check for value in literal pool, and update pool if necessary */ + + k = 1; + switch(type) + { + case TYCHAR: + if (halign) { + strp = p->Const.ccp; + nblanks = p->Const.ccp1.blanks; + len = p->vleng->constblock.Const.ci; + litflavor = LIT_CHAR; + goto loop; + } + else + q->memno = BAD_MEMNO; + break; + case TYCOMPLEX: + case TYDCOMPLEX: + k = 2; + if (p->vstg) + cd[1] = atof(ds[1] = p->Const.cds[1]); + else + ds[1] = cds(dtos(cd[1] = p->Const.cd[1]), cdsbuf1); + case TYREAL: + case TYDREAL: + litflavor = LIT_FLOAT; + if (p->vstg) + cd[0] = atof(ds[0] = p->Const.cds[0]); + else + ds[0] = cds(dtos(cd[0] = p->Const.cd[0]), cdsbuf0); + goto loop; + + case TYLOGICAL: + type = tylogical; + goto lit_int_flavor; + case TYLONG: + type = tyint; + case TYSHORT: + lit_int_flavor: + litflavor = LIT_INT; + +/* Scan the literal pool for this constant value. If this same constant + has been assigned before, use the same label. Note that this routine + does NOT consider two differently-typed constants with the same bit + pattern to be the same constant */ + + loop: + lastlit = litpool + nliterals; + for(litp = litpool ; litplittype) switch(litflavor) + { + case LIT_CHAR: + if (len == (int)litp->litval.litival2[0] + && nblanks == litp->litval.litival2[1] + && !memcmp(strp, litp->cds[0], len)) { + q->memno = litp->litnum; + frexpr((expptr)p); + return(q); + } + break; + case LIT_FLOAT: + if(cd[0] == litp->litval.litdval[0] + && !strcmp(ds[0], litp->cds[0]) + && (k == 1 || + cd[1] == litp->litval.litdval[1] + && !strcmp(ds[1], litp->cds[1]))) { +ret: + q->memno = litp->litnum; + frexpr((expptr)p); + return(q); + } + break; + + case LIT_INT: + if(p->Const.ci == litp->litval.litival) + goto ret; + break; + } + +/* If there's room in the literal pool, add this new value to the pool */ + + if(nliterals < maxliterals) + { + ++nliterals; + + /* litp now points to the next free elt */ + + litp->littype = type; + litp->litnum = q->memno; + switch(litflavor) + { + case LIT_CHAR: + litp->litval.litival2[0] = len; + litp->litval.litival2[1] = nblanks; + q->user.Const.ccp = litp->cds[0] = + memcpy(gmem(len,0), strp, len); + break; + + case LIT_FLOAT: + litp->litval.litdval[0] = cd[0]; + litp->cds[0] = copys(ds[0]); + if (k == 2) { + litp->litval.litdval[1] = cd[1]; + litp->cds[1] = copys(ds[1]); + } + break; + + case LIT_INT: + litp->litval.litival = p->Const.ci; + break; + } /* switch (litflavor) */ + } + else + many("literal constants", 'L', maxliterals); + + break; + case TYADDR: + break; + default: + badtype ("putconst", p -> vtype); + break; + } /* switch */ + + if (type != TYCHAR || halign) + frexpr((expptr)p); + return( q ); +} diff --git a/lang/fortran/comp/putpcc.c b/lang/fortran/comp/putpcc.c new file mode 100644 index 000000000..b306bb1ba --- /dev/null +++ b/lang/fortran/comp/putpcc.c @@ -0,0 +1,1781 @@ +/**************************************************************** +Copyright 1990, 1991 by AT&T Bell Laboratories and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T Bell Laboratories or +Bellcore or any of their entities not be used in advertising or +publicity pertaining to distribution of the software without +specific, written prior permission. + +AT&T and Bellcore disclaim all warranties with regard to this +software, including all implied warranties of merchantability +and fitness. In no event shall AT&T or Bellcore be liable for +any special, indirect or consequential damages or any damages +whatsoever resulting from loss of use, data or profits, whether +in an action of contract, negligence or other tortious action, +arising out of or in connection with the use or performance of +this software. +****************************************************************/ + +/* 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" + +Addrp realpart(); +LOCAL Addrp intdouble(), putcx1(), putcxeq (), putch1 (); +LOCAL putct1 (); + +expptr putcxop(); +LOCAL expptr putcall (), putmnmx (), putcheq(), putcat (); +LOCAL expptr putaddr(), putchcmp (), putpower(), putop(); +LOCAL expptr putcxcmp (); +expptr imagpart(); +ftnint lencat(); + +#define FOUR 4 +extern int ops2[]; +extern int types2[]; +extern int proc_argchanges, proc_protochanges; +extern int krparens; + +#define P2BUFFMAX 128 + +/* Puthead -- output the header information about subroutines, functions + and entry points */ + +puthead(s, class) +char *s; +int class; +{ + if (headerdone == NO) { + if (class == CLMAIN) + s = "MAIN__"; + p1_head (class, s); + headerdone = YES; + } +} + +putif(p, else_if_p) + register expptr p; + int else_if_p; +{ + register int k; + int n; + long where; + + if (else_if_p) { + p1put(P1_ELSEIFSTART); + where = ftell(pass1_file); + } + if( ( k = (p = fixtype(p))->headblock.vtype) != TYLOGICAL) + { + if(k != TYERROR) + err("non-logical expression in IF statement"); + } + else { + if (else_if_p) { + if (ei_next >= ei_last) + { + k = ei_last - ei_first; + n = k + 100; + ei_next = mem(n,0); + ei_last = ei_first + n; + if (k) + memcpy(ei_next, ei_first, k); + ei_first = ei_next; + ei_next += k; + ei_last = ei_first + n; + } + p = putx(p); + if (*ei_next++ = ftell(pass1_file) > where) { + p1_if(p); + new_endif(); + } + else + p1_elif(p); + } + else { + p = putx(p); + p1_if(p); + } + } + } + + +putexpr(p) +expptr p; +{ + putex1(p); +} + + +putout(p) +expptr p; +{ + 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). */ +} + + + +putcmgo(index, nlab, labs) +expptr index; +int nlab; +struct Labelblock *labs[]; +{ + if(! ISINT(index->headblock.vtype) ) + { + execerr("computed goto index must be integer", CNULL); + return; + } + + p1comp_goto (index, nlab, labs); +} + + static expptr +krput(p) + register expptr p; +{ + 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 putx(p) + register expptr p; +{ + int opc; + int k; + + if (p) + switch(p->tag) + { + case TERROR: + break; + + case TCONST: + switch(p->constblock.vtype) + { + case TYLOGICAL: + case TYLONG: + case TYSHORT: + break; + + case TYADDR: + break; + case TYREAL: + case TYDREAL: + +/* Don't write it out to the p2 file, since you'd need to call putconst, + which is just what we need to avoid in the translator */ + + break; + default: + p = putx( (expptr)putconst((Constp)p) ); + break; + } + break; + + case TEXPR: + switch(opc = p->exprblock.opcode) + { + case OPCALL: + case OPCCALL: + if( ISCOMPLEX(p->exprblock.vtype) ) + p = putcxop(p); + else p = putcall(p, (Addrp *)NULL); + break; + + case OPMIN: + case OPMAX: + p = putmnmx(p); + break; + + + case OPASSIGN: + if(ISCOMPLEX(p->exprblock.leftp->headblock.vtype) + || ISCOMPLEX(p->exprblock.rightp->headblock.vtype)) { + (void) putcxeq(p); + p = ENULL; + } else if( ISCHAR(p) ) + p = putcheq(p); + else + goto putopp; + break; + + case OPEQ: + case OPNE: + if( ISCOMPLEX(p->exprblock.leftp->headblock.vtype) || + ISCOMPLEX(p->exprblock.rightp->headblock.vtype) ) + { + p = putcxcmp(p); + break; + } + case OPLT: + case OPLE: + case OPGT: + case OPGE: + if(ISCHAR(p->exprblock.leftp)) + { + p = putchcmp(p); + break; + } + goto putopp; + + case OPPOWER: + p = putpower(p); + break; + + case OPSTAR: + /* m * (2**k) -> m<exprblock.leftp->headblock.vtype) && + ISICON(p->exprblock.rightp) && + ( (k = log_2(p->exprblock.rightp->constblock.Const.ci))>0) ) + { + p->exprblock.opcode = OPLSHIFT; + frexpr(p->exprblock.rightp); + p->exprblock.rightp = ICON(k); + goto putopp; + } + if (krparens && ISREAL(p->exprblock.vtype)) + return krput(p); + + case OPMOD: + goto putopp; + case OPPLUS: + if (krparens && ISREAL(p->exprblock.vtype)) + return krput(p); + case OPMINUS: + case OPSLASH: + case OPNEG: + case OPNEG1: + case OPABS: + case OPDABS: + if( ISCOMPLEX(p->exprblock.vtype) ) + p = putcxop(p); + else goto putopp; + break; + + case OPCONV: + if( ISCOMPLEX(p->exprblock.vtype) ) + p = putcxop(p); + else if( ISCOMPLEX(p->exprblock.leftp->headblock.vtype) ) + { + p = putx( mkconv(p->exprblock.vtype, + (expptr)realpart(putcx1(p->exprblock.leftp)))); + } + else goto putopp; + break; + + case OPNOT: + case OPOR: + case OPAND: + case OPEQV: + case OPNEQV: + case OPADDR: + case OPPLUSEQ: + case OPSTAREQ: + case OPCOMMA: + case OPQUEST: + case OPCOLON: + case OPBITOR: + case OPBITAND: + case OPBITXOR: + case OPBITNOT: + case OPLSHIFT: + case OPRSHIFT: + case OPASSIGNI: + case OPIDENTITY: + case OPCHARCAST: + case OPMIN2: + case OPMAX2: + case OPDMIN: + case OPDMAX: +putopp: + p = putop(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 putop(p) +expptr p; +{ + expptr lp, tp; + int pt, lt, lt1; + int comma; + + 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) { + p->exprblock.leftp = putx(p->exprblock.leftp); + return p; + } + 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); + p -> exprblock.leftp = putx (p -> exprblock.leftp); + if (p -> exprblock.rightp) + p -> exprblock.rightp = putx (p -> exprblock.rightp); + return p; +} + +LOCAL expptr putpower(p) +expptr p; +{ + 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 { + 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 intdouble(p) +Addrp p; +{ + register Addrp t; + + t = mktmp(TYDREAL, ENULL); + putout (putassign(cpexpr((expptr)t), (expptr)p)); + return(t); +} + + + + + +/* Complex-type variable assignment */ + +LOCAL Addrp putcxeq(p) +register expptr p; +{ + 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 putcxop(p) +expptr p; +{ + return (expptr)putaddr((expptr)putcx1(p)); +} + +#define PAIR(x,y) mkexpr (OPCOMMA, (x), (y)) + +LOCAL Addrp putcx1(p) +register expptr p; +{ + expptr q; + Addrp lp, rp; + register Addrp resp; + int opcode; + int ltype, rtype; + long ts; + expptr mkrealcon(); + + 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; + if ((q = resp->memoffset) && 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)); + } + else + ts = 0; + resp = mktmp(tyint, ENULL); + putout(putassign(cpexpr((expptr)resp), q)); + p->addrblock.memoffset = (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(TYDREAL, ENULL); + putout (putassign( cpexpr((expptr)resp), p)); + return(resp); + + 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( 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 putcxcmp(p) +register expptr p; +{ + 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 ); + return putx( fixexpr((Exprp)q) ); +} + +/* putch1 -- Forces constants into the literal pool, among other things */ + +LOCAL Addrp putch1(p) +register expptr p; +{ + 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 = tyint; + 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 putchop(p) +expptr p; +{ + p = putaddr((expptr)putch1(p)); + return (Addrp)p; +} + + + + +LOCAL expptr putcheq(p) +register expptr p; +{ + expptr lp, rp; + + 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 */ + + if( rp->tag==TEXPR && rp->exprblock.opcode==OPCONCAT ) + p = putcat(lp, rp); + else 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 = tyint; + p = putop(mkexpr(OPASSIGN, lp, rp)); + } + else + p = putx( call2(TYSUBR, "s_copy", lp, rp) ); + return p; +} + + + + +LOCAL expptr putchcmp(p) +register expptr p; +{ + 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 = tyint; + } + 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 putcat(lhs0, rhs) + expptr lhs0; + register expptr rhs; +{ + 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 putct1(q, length_var, string_var, ip) +register expptr q; +register Addrp length_var, string_var; +int *ip; +{ + 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)++; + 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[TYLONG])); + e = cpexpr(q->headblock.vleng); + 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 putaddr(p0) + expptr p0; +{ + register Addrp p; + + 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) + p->memoffset = putx(p->memoffset); + return (expptr) p; +} + + LOCAL expptr +addrfix(e) /* fudge character string length if it's a TADDR */ + expptr e; +{ + return e->tag == TADDR ? mkexpr(OPIDENTITY, e, ENULL) : e; + } + + LOCAL int +typekludge(ccall, q, at, j) + int ccall; + register expptr q; + Atype *at; + int 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 * +Argtype(k, buf) + int k; + char *buf; +{ + 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 +atype_squawk(at, msg) + Argtypes *at; + char *msg; +{ + 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) + proc_protochanges++; + } + + static char inconsist[] = "inconsistent calling sequences for "; + + void +bad_atypes(at, fname, i, j, k, here, prev) + Argtypes *at; + char *fname, *here, *prev; + int i, j, k; +{ + 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 +type_fixup(at,a,k) + Argtypes *at; + Atype *a; + int k; +{ + register struct Entrypoint *ep; + if (!infertypes) + return 0; + for(ep = entries; ep; ep = ep->entnextp) + if (at == ep->entryname->arginfo) { + a->type = k % 100; + return proc_argchanges = 1; + } + return 0; + } + + + void +save_argtypes(arglist, at0, at1, ccall, fname, stg, nchargs, type, zap) + chainp arglist; + Argtypes **at0, **at1; + int ccall, stg, nchargs, type, zap; + char *fname; +{ + Argtypes *at; + chainp cp; + int i, i0, j, k, nargs, *t, *te; + Atype *atypes; + expptr q; + char buf[208]; + static int initargs[4] = {TYCOMPLEX, TYDCOMPLEX, TYCHAR, TYFTNLEN+100}; + static int *init_ap[TYSUBR+1] = {0,0,0,0,0,0, + initargs, initargs+1,0,initargs+2}; + extern int init_ac[TYSUBR+1]; + + i0 = init_ac[type]; + t = init_ap[type]; + te = t + i0; + if (at = *at0) { + *at1 = at; + nargs = at->nargs; + if (nargs < 0) { /* inconsistent usage seen */ + if (type) { + if (at->changes & 2) + --proc_protochanges; + goto newlist; + } + return; + } + atypes = at->atypes; + i = nchargs; + for(; t < te; atypes++) { + if (++i > nargs) { + toomany: + i = nchargs + i0; + for(cp = arglist; cp; cp = cp->nextp) + i++; + toofew: + sprintf(buf, + "%s%.90s:\n\there %d, previously %d args and string lengths.", + inconsist, fname, i, nargs); + atype_squawk(at, buf); + retn: + if (type) + goto newlist; + return; + } + j = atypes->type; + k = *t++; + if (j != k) + 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) + goto badtypes; + else ; /* fall through to update */ + else if (k == TYUNKNOWN+200) + continue; + else if (j != TYUNKNOWN+200) + { + badtypes: + bad_atypes(at, fname, i, j, k, "here ", + ", previously"); + if (type) { + /* we're defining the procedure */ + t = init_ap[type]; + te = t + i0; + proc_argchanges = 1; + goto newlist; + } + goto retn; + } + /* 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 + */ + atypes->type = k; + at->changes |= 1; + } + if (i < nargs) + goto toofew; + if (zap && (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->nargs = i; + 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; + } + } + + void +saveargtypes(p) /* for writing prototypes */ + register Exprp p; +{ + Addrp a; + Argtypes **at0, **at1; + Namep np; + chainp arglist; + expptr rp; + Extsym *e; + char *fname; + + a = (Addrp)p->leftp; + switch(a->vstg) { + case STGEXT: + switch(a->uname_tag) { + case UNAM_EXTERN: /* e.g., sqrt() */ + e = extsymtab + a->memno; + at0 = at1 = &e->arginfo; + fname = e->fextname; + break; + case UNAM_NAME: + np = a->user.name; + at0 = &extsymtab[np->vardesc.varno].arginfo; + at1 = &np->arginfo; + fname = np->fvarname; + break; + default: + goto bug; + } + break; + case STGARG: + if (a->uname_tag != UNAM_NAME) + goto bug; + np = a->user.name; + at0 = at1 = &np->arginfo; + fname = np->fvarname; + break; + default: + bug: + Fatal("Confusion in saveargtypes"); + } + rp = p->rightp; + arglist = rp && rp->tag == TLIST ? rp->listblock.listp : 0; + save_argtypes(arglist, at0, at1, p->opcode == OPCCALL, + fname, a->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 putcall(p0, temp) + expptr p0; + Addrp *temp; +{ + 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 */ + extern int Castargs; + char *s; + extern struct Listblock *mklist(); + + 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 */ + + for(cp = arglist ; cp ; cp = cp->nextp) + if(!byvalue) { + 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)) + { + 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; + } + } + 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) ) + 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 + || 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 */ + + t = (expptr) mktmp(q->headblock.vtype, q->headblock.vleng); + +/* Assign to temporary variables before invoking the subroutine or + function */ + + t1 = putassign( cpexpr(t), q ); + if (doin_setbound) + t = mkexpr(OPCOMMA_ARG, t1, t); + else + putout(t1); + cp -> datap = (char *) t; + } /* else */ + } /* if !ISERROR(q) */ + } + +/* Now adjust the lengths of the CHARACTER parameters */ + + for(cp = charsp ; cp ; cp = cp->nextp) + cp->datap = (char *)addrfix(putx( + /* in case MAIN has a character*(*)... */ + (s = cp->datap) ? mkconv(TYLENG,(expptr)s) + : ICON(0))); + +/* ... and add them to the end of the argument list */ + + hookup (arglist, charsp); + +/* Return the name of the temporary used to hold the results, if any was + necessary. */ + + if (temp) *temp = fval; + else frexpr ((expptr)fval); + + saveargtypes(p); + + return (expptr) p; +} + + + +/* putmnmx -- Put min or max. p must point to an EXPR, not just a + CONST */ + +LOCAL expptr putmnmx(p) +register expptr p; +{ + int op, op2, type; + expptr arg, qp, temp; + chainp p0, p1; + Addrp sp, tp; + char comment_buf[80]; + char *what; + + if(p->tag != TEXPR) + badtag("putmnmx", p->tag); + + type = p->exprblock.vtype; + op = p->exprblock.opcode; + op2 = op == OPMIN ? OPMIN2 : OPMAX2; + p0 = p->exprblock.leftp->listblock.listp; + free( (charptr) (p->exprblock.leftp) ); + free( (charptr) p ); + + /* special case for two addressable operands */ + + if (addressable((expptr)p0->datap) + && (p1 = p0->nextp) + && addressable((expptr)p1->datap) + && !p1->nextp) { + if (type == TYREAL && forcedouble) + op2 = op == OPMIN ? OPDMIN : OPDMAX; + p = mkexpr(op2, mkconv(type, cpexpr((expptr)p0->datap)), + mkconv(type, cpexpr((expptr)p1->datap))); + frchain(&p0); + return p; + } + + /* general case */ + + sp = mktmp(type, ENULL); + +/* We only need a second temporary if the arg list has an unaddressable + value */ + + tp = (Addrp) NULL; + qp = ENULL; + for (p1 = p0 -> nextp; p1; p1 = p1 -> nextp) + if (!addressable ((expptr) p1 -> datap)) { + tp = mktmp(type, ENULL); + qp = mkexpr(op2, cpexpr((expptr)sp), cpexpr((expptr)tp)); + qp = fixexpr((Exprp)qp); + break; + } /* if */ + +/* Now output the appropriate number of assignments and comparisons. Min + and max are implemented by the simple O(n) algorithm: + + min (a, b, c, d) ==> + { 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 +putwhile(p) + expptr p; +{ + long where; + int k, n; + + if (wh_next >= wh_last) + { + k = wh_last - wh_first; + n = k + 100; + wh_next = mem(n,0); + wh_last = wh_first + n; + if (k) + memcpy(wh_next, wh_first, k); + wh_first = wh_next; + wh_next += k; + wh_last = wh_first + n; + } + if( ( k = (p = fixtype(p))->headblock.vtype) != TYLOGICAL) + { + if(k != TYERROR) + err("non-logical expression in DO WHILE statement"); + } + else { + p1put(P1_WHILE1START); + where = ftell(pass1_file); + p = putx(p); + *wh_next++ = ftell(pass1_file) > where; + p1put(P1_WHILE2START); + p1_expr(p); + } + } diff --git a/lang/fortran/comp/string.h b/lang/fortran/comp/string.h new file mode 100644 index 000000000..a11509d85 --- /dev/null +++ b/lang/fortran/comp/string.h @@ -0,0 +1,16 @@ +#ifndef NULL +#define NULL 0 +#endif + +#define strchr strindex +#define strrchr strrindex + +extern char * strcat(); +extern char * strchr(); +extern int strcmp(); +extern char * strcpy(); +extern int strlen(); +extern char * strncat(); +extern int strncmp(); +extern char * strncpy(); +extern char * strrchr(); diff --git a/lang/fortran/comp/sysdep.c b/lang/fortran/comp/sysdep.c new file mode 100644 index 000000000..62ec74c59 --- /dev/null +++ b/lang/fortran/comp/sysdep.c @@ -0,0 +1,441 @@ +/**************************************************************** +Copyright 1990 by AT&T Bell Laboratories and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T Bell Laboratories or +Bellcore or any of their entities not be used in advertising or +publicity pertaining to distribution of the software without +specific, written prior permission. + +AT&T and Bellcore disclaim all warranties with regard to this +software, including all implied warranties of merchantability +and fitness. In no event shall AT&T or Bellcore be liable for +any special, indirect or consequential damages or any damages +whatsoever resulting from loss of use, data or profits, whether +in an action of contract, negligence or other tortious action, +arising out of or in connection with the use or performance of +this software. +****************************************************************/ +#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 link_msg[] = "-lF77 -lI77 -lm -lc"; + +#ifndef TMPDIR +#ifdef MSDOS +#define TMPDIR "" +#else +#define TMPDIR "/tmp" +#endif +#endif + +char *tmpdir = TMPDIR; + + void +Un_link_all(cdelete) +{ + if (!debugflag) { + unlink(c_functions); + unlink(initfname); + unlink(p1_file); + unlink(sortfname); + unlink(blkdfname); + if (cdelete && coutput) + unlink(coutput); + } + } + + void +set_tmp_names() +{ + int k; + if (debugflag == 1) + return; + k = strlen(tmpdir) + 16; + c_functions = (char *)ckalloc(7*k); + initfname = c_functions + k; + initbname = initfname + k; + blkdfname = initbname + k; + p1_file = blkdfname + k; + p1_bakfile = p1_file + k; + sortfname = p1_bakfile + k; + { +#ifdef MSDOS + char buf[64], *s, *t; + if (!*tmpdir || *tmpdir == '.' && !tmpdir[1]) + t = ""; + else { + /* substitute \ for / to avoid confusion with a + * switch indicator in the system("sort ...") + * call in formatdata.c + */ + for(s = tmpdir, t = buf; *s; s++, t++) + if ((*t = *s) == '/') + *t = '\\'; + if (t[-1] != '\\') + *t++ = '\\'; + *t = 0; + t = buf; + } + sprintf(c_functions, "%sf2c_func", t); + sprintf(initfname, "%sf2c_rd", t); + sprintf(blkdfname, "%sf2c_blkd", t); + sprintf(p1_file, "%sf2c_p1f", t); + sprintf(p1_bakfile, "%sf2c_p1fb", t); + sprintf(sortfname, "%sf2c_sort", t); +#else + int pid = getpid(); + sprintf(c_functions, "%s/f2c%d_func", tmpdir, pid); + sprintf(initfname, "%s/f2c%d_rd", tmpdir, pid); + sprintf(blkdfname, "%s/f2c%d_blkd", tmpdir, pid); + sprintf(p1_file, "%s/f2c%d_p1f", tmpdir, pid); + sprintf(p1_bakfile, "%s/f2c%d_p1fb", tmpdir, pid); + sprintf(sortfname, "%s/f2c%d_sort", tmpdir, pid); +#endif + sprintf(initbname, "%s.b", initfname); + } + if (debugflag) + fprintf(diagfile, "%s %s %s %s %s %s\n", c_functions, + initfname, blkdfname, p1_file, p1_bakfile, sortfname); + } + + char * +c_name(s,ft)char *s; +{ + 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"); + } + *s = ft; + b = copys(b); + *s = c; + return b; + } + + static void +killed() +{ + 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 +sig1catch(sig) int sig; +{ + if (signal(sig, SIG_IGN) != SIG_IGN) + signal(sig, killed); + } + + static void +flovflo() +{ + 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 +sigcatch() +{ + sig1catch(SIGINT); +#ifdef SIGQUIT + sig1catch(SIGQUIT); +#endif +#ifdef SIGHUP + sig1catch(SIGHUP); +#endif + sig1catch(SIGTERM); + signal(SIGFPE, flovflo); /* catch overflows */ + } + + +dofork() +{ +#ifdef MSDOS + Fatal("Only one Fortran input file allowed under MS-DOS"); +#else + int pid, status, w; + extern int retcode; + + if (!(pid = fork())) + return 1; + if (pid == -1) + Fatal("bad fork"); + while((w = wait(&status)) != pid) + if (w == -1) + Fatal("bad wait code"); + retcode |= status >> 8; +#endif + return 0; + } + +/* Initialization of tables that change with the character set... */ + +char escapes[Table_size]; + +#ifdef non_ASCII +char *str_fmt[Table_size]; +static char *str0fmt[127] = { /*}*/ +#else +char *str_fmt[Table_size] = { +#endif + "\\000", "\\001", "\\002", "\\003", "\\004", "\\005", "\\006", "\\007", + "\\b", "\\t", "\\n", "\\013", "\\f", "\\r", "\\016", "\\017", + "\\020", "\\021", "\\022", "\\023", "\\024", "\\025", "\\026", "\\027", + "\\030", "\\031", "\\032", "\\033", "\\034", "\\035", "\\036", "\\037", + " ", "!", "\\\"", "#", "$", "%%", "&", "'", + "(", ")", "*", "+", ",", "-", ".", "/", + "0", "1", "2", "3", "4", "5", "6", "7", + "8", "9", ":", ";", "<", "=", ">", "?", + "@", "A", "B", "C", "D", "E", "F", "G", + "H", "I", "J", "K", "L", "M", "N", "O", + "P", "Q", "R", "S", "T", "U", "V", "W", + "X", "Y", "Z", "[", "\\\\", "]", "^", "_", + "`", "a", "b", "c", "d", "e", "f", "g", + "h", "i", "j", "k", "l", "m", "n", "o", + "p", "q", "r", "s", "t", "u", "v", "w", + "x", "y", "z", "{", "|", "}", "~" + }; + +#ifdef non_ASCII +char *chr_fmt[Table_size]; +static char *chr0fmt[127] = { /*}*/ +#else +char *chr_fmt[Table_size] = { +#endif + "\\0", "\\1", "\\2", "\\3", "\\4", "\\5", "\\6", "\\7", + "\\b", "\\t", "\\n", "\\13", "\\f", "\\r", "\\16", "\\17", + "\\20", "\\21", "\\22", "\\23", "\\24", "\\25", "\\26", "\\27", + "\\30", "\\31", "\\32", "\\33", "\\34", "\\35", "\\36", "\\37", + " ", "!", "\"", "#", "$", "%%", "&", "\\'", + "(", ")", "*", "+", ",", "-", ".", "/", + "0", "1", "2", "3", "4", "5", "6", "7", + "8", "9", ":", ";", "<", "=", ">", "?", + "@", "A", "B", "C", "D", "E", "F", "G", + "H", "I", "J", "K", "L", "M", "N", "O", + "P", "Q", "R", "S", "T", "U", "V", "W", + "X", "Y", "Z", "[", "\\\\", "]", "^", "_", + "`", "a", "b", "c", "d", "e", "f", "g", + "h", "i", "j", "k", "l", "m", "n", "o", + "p", "q", "r", "s", "t", "u", "v", "w", + "x", "y", "z", "{", "|", "}", "~" + }; + + void +fmt_init() +{ + static char *str1fmt[6] = + { "\\b", "\\t", "\\n", "\\f", "\\r", "\\%03o" }; + register int i, j; + register char *s; + + /* str_fmt */ + +#ifdef non_ASCII + i = 0; +#else + i = 127; +#endif + for(; i < Table_size; i++) + str_fmt[i] = "\\%03o"; +#ifdef non_ASCII + for(i = 32; i < 127; i++) { + s = str0fmt[i]; + str_fmt[*(unsigned char *)s] = s; + } + str_fmt['"'] = "\\\""; +#else + if (Ansi == 1) + str_fmt[7] = chr_fmt[7] = "\\a"; +#endif + + /* chr_fmt */ + +#ifdef non_ASCII + for(i = 0; i < 32; i++) + chr_fmt[i] = chr0fmt[i]; +#else + i = 127; +#endif + for(; i < Table_size; i++) + chr_fmt[i] = "\\%o"; +#ifdef non_ASCII + for(i = 32; i < 127; i++) { + s = chr0fmt[i]; + j = *(unsigned char *)s; + if (j == '\\') + j = *(unsigned char *)(s+1); + chr_fmt[j] = s; + } +#endif + + /* escapes (used in lex.c) */ + + for(i = 0; i < Table_size; i++) + escapes[i] = i; + for(s = "btnfr0", i = 0; i < 6; i++) + escapes[*(unsigned char *)s++] = "\b\t\n\f\r"[i]; + /* finish str_fmt and chr_fmt */ + + if (Ansi) + str1fmt[5] = "\\v"; + if ('\v' == 'v') { /* ancient C compiler */ + str1fmt[5] = "v"; +#ifndef non_ASCII + escapes['v'] = 11; +#endif + } + else + escapes['v'] = '\v'; + for(s = "\b\t\n\f\r\v", i = 0; j = *(unsigned char *)s++;) + str_fmt[j] = chr_fmt[j] = str1fmt[i++]; + /* '\v' = 11 for both EBCDIC and ASCII... */ + chr_fmt[11] = Ansi ? "\\v" : "\\13"; + } + + + +/* 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 + +dsort(from, to) + char *from, *to; +{ + char buf[200]; + sprintf(buf, "sort <%s >%s", from, to); + return system(buf) >> 8; + } +#else + + static int +compare(a,b) + char *a, *b; +{ return strcmp(*(char **)a, *(char **)b); } + +dsort(from, to) + char *from, *to; +{ + extern char *Alloc(); + + 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/lang/fortran/comp/sysdep.h b/lang/fortran/comp/sysdep.h new file mode 100644 index 000000000..90fcde5fd --- /dev/null +++ b/lang/fortran/comp/sysdep.h @@ -0,0 +1,83 @@ +/**************************************************************** +Copyright 1990 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. +****************************************************************/ + +/* 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__ +#ifndef ANSI_Libraries +#define ANSI_Libraries +#endif +#ifndef ANSI_Prototypes +#define ANSI_Prototypes +#endif +#endif + +#include + +#ifdef ANSI_Libraries +#include +#include +#else +char *calloc(), *malloc(), *memcpy(), *memset(), *realloc(); +/* typedef int size_t; */ +#ifdef ANSI_Prototypes +extern double atof(const char *); +#else +extern double atof(); +#endif +#endif + +#ifdef ANSI_Prototypes +extern char *gmem(int, int); +extern char *mem(int, int); +extern char *Alloc(int); +extern int* ckalloc(int); +#else +extern char *Alloc(), *gmem(), *mem(); +int *ckalloc(); +#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 Table_size 256 +/* Table_size should be 1 << (bits/byte) */ diff --git a/lang/fortran/comp/tokens b/lang/fortran/comp/tokens new file mode 100644 index 000000000..d97fb52a8 --- /dev/null +++ b/lang/fortran/comp/tokens @@ -0,0 +1,99 @@ +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 diff --git a/lang/fortran/comp/usignal.h b/lang/fortran/comp/usignal.h new file mode 100644 index 000000000..ba4ee6ad4 --- /dev/null +++ b/lang/fortran/comp/usignal.h @@ -0,0 +1,7 @@ +#include +#ifndef SIGHUP +#define SIGHUP 1 /* hangup */ +#endif +#ifndef SIGQUIT +#define SIGQUIT 3 /* quit */ +#endif diff --git a/lang/fortran/comp/vax.c b/lang/fortran/comp/vax.c new file mode 100644 index 000000000..f1e44071a --- /dev/null +++ b/lang/fortran/comp/vax.c @@ -0,0 +1,325 @@ +/**************************************************************** +Copyright 1990 by AT&T Bell Laboratories and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T Bell Laboratories or +Bellcore or any of their entities not be used in advertising or +publicity pertaining to distribution of the software without +specific, written prior permission. + +AT&T and Bellcore disclaim all warranties with regard to this +software, including all implied warranties of merchantability +and fitness. In no event shall AT&T or Bellcore be liable for +any special, indirect or consequential damages or any damages +whatsoever resulting from loss of use, data or profits, whether +in an action of contract, negligence or other tortious action, +arising out of or in connection with the use or performance of +this software. +****************************************************************/ + +#include "defs.h" +#include "pccdefs.h" +#include "output.h" + +int regnum[] = { + 11, 10, 9, 8, 7, 6 }; + +/* Put out a constant integer */ + +prconi(fp, n) +FILEP fp; +ftnint n; +{ + fprintf(fp, "\t%ld\n", n); +} + + + +/* Put out a constant address */ + +prcona(fp, a) +FILEP fp; +ftnint a; +{ + fprintf(fp, "\tL%ld\n", a); +} + + + +prconr(fp, x, k) + FILEP fp; + int k; + Constp x; +{ + 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 *memname(stg, mem) + int stg; + long mem; +{ + 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); +} + +/* make_int_expr -- takes an arbitrary expression, and replaces all + occurrences of arguments with indirection */ + +expptr make_int_expr (e) +expptr e; +{ + if (e != ENULL) + switch (e -> tag) { + case TADDR: + if (e -> addrblock.vstg == STGARG) + e = mkexpr (OPWHATSIN, e, ENULL); + break; + case TEXPR: + e -> exprblock.leftp = make_int_expr (e -> exprblock.leftp); + e -> exprblock.rightp = make_int_expr (e -> exprblock.rightp); + break; + 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 prune_left_conv (e) +expptr e; +{ + 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() +{ + if (!wrote_comment) { + wrote_comment = 1; + nice_printf (comment_file, "/* Parameter adjustments */\n"); + } + } + + static int * +count_args() +{ + 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; + } + +prolog(outfile, p) + FILE *outfile; + register chainp p; +{ + int addif, addif0, i, nd, size; + int *ac; + register Namep q; + register struct Dimblock *dp; + + if(procclass == CLBLOCK) + return; + 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); +} /* prolog */ diff --git a/lang/fortran/comp/version.c b/lang/fortran/comp/version.c new file mode 100644 index 000000000..06d114738 --- /dev/null +++ b/lang/fortran/comp/version.c @@ -0,0 +1,2 @@ +char F2C_version[] = "28 August 1991 0:07:02"; +char xxxvers[] = "\n@(#) FORTRAN 77 to C Translator, VERSION 28 August 1991 0:07:02\n"; diff --git a/lang/fortran/comp/xsum.c b/lang/fortran/comp/xsum.c new file mode 100644 index 000000000..3e824e929 --- /dev/null +++ b/lang/fortran/comp/xsum.c @@ -0,0 +1,174 @@ +/**************************************************************** +Copyright 1990 by AT&T Bell Laboratories and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T Bell Laboratories or +Bellcore or any of their entities not be used in advertising or +publicity pertaining to distribution of the software without +specific, written prior permission. + +AT&T and Bellcore disclaim all warranties with regard to this +software, including all implied warranties of merchantability +and fitness. In no event shall AT&T or Bellcore be liable for +any special, indirect or consequential damages or any damages +whatsoever resulting from loss of use, data or profits, whether +in an action of contract, negligence or other tortious action, +arising out of or in connection with the use or performance of +this software. +****************************************************************/ + +#include "stdio.h" + + char *progname; + + void +usage(rc) +{ + fprintf(stderr, "usage: %s [file [file...]]\n", progname); + exit(rc); + } + +main(argc, argv) + char **argv; +{ + int x; + char *s; + static int rc; + + progname = *argv; + s = *++argv; + if (s && *s == '-') { + switch(s[1]) { + case '?': + usage(0); + case '-': + break; + default: + fprintf(stderr, "invalid option %s\n", s); + usage(1); + } + s = *++argv; + } + if (s) do { + x = open(s,0); + 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)); + } + exit(rc); + } + +typedef unsigned char uchar; + + long +sum32(sum, x, n) + register long sum; + register uchar *x; + int n; +{ + 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; + } + +process(s, x) + char *s; + int x; +{ + register int n; + uchar buf[16*1024]; + long fsize, sum; + + sum = 0; + fsize = 0; + while((n = read(x, (char *)buf, sizeof(buf))) > 0) { + 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); + return(0); + } diff --git a/lang/fortran/comp/xsum0.out b/lang/fortran/comp/xsum0.out new file mode 100644 index 000000000..6c2db3124 --- /dev/null +++ b/lang/fortran/comp/xsum0.out @@ -0,0 +1,56 @@ +Notice fb5a412e 1183 +README fe10cd03 3340 +cds.c e93849b8 3884 +data.c e552a480 9278 +defines.h ef026e5f 8179 +defs.h e74a0285 23464 +equiv.c e7eb3399 8552 +error.c 111d9ebf 3653 +exec.c 18ed4ede 18027 +expr.c e2bc323c 57458 +f2c.1 e65632a 5799 +f2c.1t 1aad289 5706 +f2c.h ed0a0173 4138 +format.c e7b58fa8 49914 +format.h e861ad39 300 +formatdata.c eeebb124 23833 +ftypes.h e5db6a7c 941 +gram.dcl fac72441 8102 +gram.exec ff121afb 2996 +gram.expr 1cdcf8c5 3081 +gram.head e6859fc0 7539 +gram.io 1b7c281c 3294 +init.c f7ca02f1 10347 +intr.c e2b8e4ab 19647 +io.c c474aae 28975 +iob.h fe479ed3 459 +lex.c fe1e63b6 29374 +machdefs.h 4950e5b 659 +main.c 1e4ec3a1 16300 +makefile 12f58dbe 2510 +malloc.c 5c2be2a 3422 +mem.c 5b007b2 4761 +memset.c 17404d52 1964 +misc.c 19c4624d 17758 +names.c e5184875 19122 +names.h f25436a3 689 +niceprintf.c f9d80b51 9355 +niceprintf.h c31f08c 412 +output.c f97db62 37044 +output.h edfe9e59 2113 +p1defs.h e4e11c4e 5776 +p1output.c e60446f5 12198 +parse.h e457df2e 855 +parse_args.c f3e5da4d 13015 +pccdefs.h 1b4fbbee 1195 +pread.c 135e64ca 15796 +proc.c f5df26ff 34052 +put.c 1f22b2c0 9499 +putpcc.c 1f96161e 38473 +sysdep.c 197e669f 10864 +sysdep.h e602b6fd 2532 +tokens 194fccfe 727 +usignal.h 1c4ce909 124 +vax.c b060552 7649 +version.c f7b72f6f 137 +xsum.c bd02396 5479 diff --git a/lang/fortran/disclaimer b/lang/fortran/disclaimer new file mode 100644 index 000000000..59db1ecf4 --- /dev/null +++ b/lang/fortran/disclaimer @@ -0,0 +1,15 @@ +f2c is a Fortran to C converter under development by + David Gay (AT&T Bell Labs) + Stu Feldman (Bellcore) + Mark Maimone (Carnegie-Mellon University) + Norm Schryer (AT&T Bell Labs) +Please send bug reports to dmg@research.att.com or uunet!research!dmg. + +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. diff --git a/lang/fortran/fc b/lang/fortran/fc new file mode 100644 index 000000000..1d9f8b943 --- /dev/null +++ b/lang/fortran/fc @@ -0,0 +1,180 @@ +#!/bin/sh +PATH=/v/bin:/bin:/usr/bin +# f77-style shell script to compile and load fortran, C, and assembly codes + +# usage: f77 [-O] [-o absfile] [-c] files [-l library] + +# -o objfile Override default executable name a.out. + +# -c Do not call linker, leave relocatables in *.o. + +# -S leave assembler output on file.s + +# -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 . +# C source files ending in .c . +# Assembly language files ending in .s . +# efl source files ending in .e . + +# -D def passed to C compiler (for .c files) + +# -I includepath passed to C compiler (for .c files) + +# -Ntnnn allow nnn entries in table t + +s=/tmp/stderr_$$ +t=/tmp/f77_$$.o +CC=${CC_f2c:-'/v/bin/lcc -Wfdouble=8,4,1'} +EFL=${EFL:-/v/bin/efl} +EFLFLAGS=${EFLFLAGS:-'system=portable deltastno=10'} +F2C=${F2C:-/v/bin/f2c} +F2CFLAGS=${F2CFLAGS:='-ARw8'} +rc=0 +trap "rm -f $s $t; exit \$rc" 0 +lib=/lib/num/lib.lo +OUTF=a.out +cOPT=1 +set -- `getopt cD:gI:N:Oo:Suw6 "$@"` +case $? in 0);; *) exit 1;; esac +CCFLAGS= +while + test X"$1" != X-- +do + case "$1" + in + -c) cOPT=0 + shift + ;; + + -D) CCFLAGS="$CCFLAGS -D$2" + shift 2 + ;; + + -g) CFLAGS="$CFLAGS -g" + shift;; + + -I) CCFLAGS="$CCFLAGS -I$2" + shift 2 + ;; + + -o) OUTF=$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 + # lcc ignores -O... + 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 + ;; + + -N) F2CFLAGS="$F2CFLAGS $1""$2" + shift 2 + ;; + + -S) CFLAGS="$CFLAGS -S" + cOPT=0 + shift + ;; + + *) + echo "invalid parameter $1" 1>&2 + shift + ;; + esac +done +shift +while + test -n "$1" +do + case "$1" + in + *.[fF]) + case "$1" in *.f) f=".f";; *.F) f=".F";; esac + b=`basename $1 $f` + $F2C $F2CFLAGS $1 + case $? in 0);; *) exit;; esac + $CC -c $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);; *) exit;; esac + $F2C $F2CFLAGS $b.f + case $? in 0);; *) exit;; esac + $CC -c $CFLAGS $b.c + case $? in 0);; *) 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:-/usr/bin/as} -o $OFILE $AFLAGS $1 + case $? in 0);; *) 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 $CFLAGS $CCFLAGS $1 + rc=$?; case $rc in 0);; *) 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 + ;; + -l) + OFILES="$OFILES -l$2" + shift 2 + case $cOPT in 1) cOPT=2;; esac + ;; + -l*) + OFILES="$OFILES $1" + shift + case $cOPT in 1) cOPT=2;; esac + ;; + -o) + OUTF=$2; shift 2;; + *) + OFILES="$OFILES $1" + shift + case $cOPT in 1) cOPT=2;; esac + ;; + esac +done + +case $cOPT in 2) $CC -o $OUTF -u MAIN__ $OFILES -lf2c -lm;; esac +rc=$? +exit $rc diff --git a/lang/fortran/fixes b/lang/fortran/fixes new file mode 100644 index 000000000..34c3f2b57 --- /dev/null +++ b/lang/fortran/fixes @@ -0,0 +1,1184 @@ +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 in mem.c +changed to #include "string.h" so BSD people can create a local +string.h that simply says #include . + +Jan 30 10:34:00 EST 1990: + Fix erroneous warning at end of definition of a procedure with +character arguments when the procedure had previously been called with +a numeric argument instead of a character argument. (There were two +warnings, the second one incorrectly complaining of a wrong number of +arguments.) + +Jan 30 16:29:41 EST 1990: + Fix case where -P and -Ps erroneously reported another iteration +necessary. (Only harm is the extra iteration.) + +Feb 3 01:40:00 EST 1990: + Supply semicolon occasionally omitted under -c . + Try to force correct alignment when numeric variables are initialized +with character data (a non-standard and non-portable practice). You +must use the -W option if your code has such data statements and is +meant to run on a machine with other than 4 characters/word; e.g., for +code meant to run on a Cray, you would specify -W8 . + Allow parentheses around expressions in output lists (in write and +print statements). + Rename source files so their names are <= 12 characters long +(so there's room to append .Z and still have <= 14 characters); +renamed files: formatdata.c niceprintf.c niceprintf.h safstrncpy.c . + f2c material made available by anonymous ftp from research.att.com +(look in dist/f2c ). + +Feb 3 03:49:00 EST 1990: + Repair memory fault that arose from use (in an assignment or +call) of a non-argument variable declared CHARACTER*(*). + +Feb 9 01:35:43 EST 1990: + Fix erroneous error msg about bad types in + subroutine foo(a,adim) + dimension a(adim) + integer adim + Fix improper passing of character args (and possible memory fault) +in the expression part of a computed goto. + Fix botched calling sequences in array references involving +functions having character args. + Fix memory fault caused by invocation of character-valued functions +of no arguments. + Fix botched calling sequence of a character*1-valued function +assigned to a character*1 variable. + Fix bug in error msg for inconsistent number of args in prototypes. + Allow generation of C output despite inconsistencies in prototypes, +but give exit code 8. + Simplify include logic (by removing some bogus logic); never +prepend "/usr/include/" to file names. + Minor cleanups (that should produce no visible change in f2c's +behavior) in intr.c parse.h main.c defs.h formatdata.c p1output.c . + +Feb 10 00:19:38 EST 1990: + Insert (integer) casts when floating-point expressions are used +as subscripts. + Make SAVE stmt (with no variable list) override -a . + Minor cleanups: change field to Field in struct Addrblock (for the +benefit of buggy C compilers); omit system("/bin/cp ...") in misc.c . + +Feb 13 00:39:00 EST 1990: + Error msg fix in gram.dcl: change "cannot make %s parameter" +to "cannot make into parameter". + +Feb 14 14:02:00 EST 1990: + Various cleanups (invisible on systems with 4-byte ints), thanks +to Dave Regan: vaxx.c eliminated; %d changed to %ld various places; +external names adjusted for the benefit of stupid systems (that ignore +case and recognize only 6 significant characters in external names); +buffer shortened in xsum.c (e.g. for MS-DOS); fopen modes distinguish +text and binary files; several unused functions eliminated; missing +arg supplied to an unlikely fatalstr invocation. + +Thu Feb 15 19:15:53 EST 1990: + More cleanups (invisible on systems with 4 byte ints); casts inserted +so most complaints from cyntax(1) and lint(1) go away; a few (int) +versus (long) casts corrected. + +Fri Feb 16 19:55:00 EST 1990: + Recognize and translate unnamed Fortran 8x do while statements. + Fix bug that occasionally caused improper breaking of character +strings. + New error message for attempts to provide DATA in a type-declaration +statement. + +Sat Feb 17 11:43:00 EST 1990: + Fix infinite loop clf -> Fatal -> done -> clf after I/O error. + Change "if (addrp->vclass = CLPROC)" to "if (addrp->vclass == CLPROC)" +in p1_addr (in p1output.c); this was probably harmless. + Move a misplaced } in lex.c (which slowed initkey()). + Thanks to Gary Word for pointing these things out. + +Sun Feb 18 18:07:00 EST 1990: + Detect overlapping initializations of arrays and scalar variables +in previously missed cases. + Treat logical*2 as logical (after issuing a warning). + Don't pass string literals to p1_comment(). + Correct a cast (introduced 16 Feb.) in gram.expr; this matters e.g. +on a Cray. + Attempt to isolate UNIX-specific things in sysdep.c (a new source +file). Unless sysdep.c is compiled with SYSTEM_SORT defined, the +intermediate files created for DATA statements are now sorted in-core +without invoking system(). + +Tue Feb 20 16:10:35 EST 1990: + Move definition of binread and binwrite from init.c to sysdep.c . + Recognize Fortran 8x tokens < <= == >= > <> as synonyms for +.LT. .LE. .EQ. .GE. .GT. .NE. + Minor cleanup in putpcc.c: fully remove simoffset(). + More discussion of system dependencies added to libI77/README. + +Tue Feb 20 21:44:07 EST 1990: + Minor cleanups for the benefit of EBCDIC machines -- try to remove +the assumption that 'a' through 'z' are contiguous. (Thanks again to +Gary Word.) Also, change log2 to log_2 (shouldn't be necessary). + +Wed Feb 21 06:24:56 EST 1990: + Fix botch in init.c introduced in previous change; only matters +to non-ASCII machines. + +Thu Feb 22 17:29:12 EST 1990: + Allow several entry points to mention the same array. Protect +parameter adjustments with if's (for the case that an array is not +an argument to all entrypoints). + Under -u, allow + subroutine foo(x,n) + real x(n) + integer n + Compute intermediate variables used to evaluate dimension expressions +at the right time. Example previously mistranslated: + subroutine foo(x,k,m,n) + real x(min(k,m,n)) + ... + write(*,*) x + Detect duplicate arguments. (The error msg points to the first +executable stmt -- not wonderful, but not worth fixing.) + Minor cleanup of min/max computation (sometimes slightly simpler). + +Sun Feb 25 09:39:01 EST 1990: + Minor tweak to multiple entry points: protect parameter adjustments +with if's only for (array) args that do not appear in all entry points. + Minor tweaks to format.c and io.c (invisible unless your compiler +complained at the duplicate #defines of IOSUNIT and IOSFMT or at +comparisons of p1gets(...) with NULL). + +Sun Feb 25 18:40:10 EST 1990: + Fix bug introduced Feb. 22: if a subprogram contained DATA and the +first executable statement was labeled, then the label got lost. +(Just change INEXEC to INDATA in p1output.c; it occurs just once.) + +Mon Feb 26 17:45:10 EST 1990: + Fix bug in handling of " and ' in comments. + +Wed Mar 28 01:43:06 EST 1990: +libI77: + 1. Repair nasty I/O bug: opening two files and closing the first +(after possibly reading or writing it), then writing the second caused +the last buffer of the second to be lost. + 2. Formatted reads of logical values treated all letters other than +t or T as f (false). + libI77 files changed: err.c rdfmt.c Version.c + (Request "libi77 from f2c" -- you can't get these files individually.) + +f2c itself: + Repair nasty bug in translation of + ELSE IF (condition involving complicated abs, min, or max) +-- auxiliary statements were emitted at the wrong place. + Supply semicolon previously omitted from the translation of a label +(of a CONTINUE) immediately preceding an ELSE IF or an ELSE. This +bug made f2c produce invalid C. + Correct a memory fault that occurred (on some machines) when the +error message "adjustable dimension on non-argument" should be given. + Minor tweaks to remove some harmless warnings by overly chatty C +compilers. + Argument arays having constant dimensions but a variable lower bound +(e.g., x(n+1:n+3)) had a * omitted from scalar arguments involved in +the array offset computation. + +Wed Mar 28 18:47:59 EST 1990: +libf77: add exit(0) to end of main [return(0) encounters a Cray bug] + +Sun Apr 1 16:20:58 EDT 1990: + Avoid dereferencing null when processing equivalences after an error. + +Fri Apr 6 08:29:49 EDT 1990: + Calls involving alternate return specifiers omitted processing +needed for things like min, max, abs, and // (concatenation). + INTEGER*2 PARAMETERs were treated as INTEGER*4. + Convert some O(n^2) parsing to O(n). + +Tue Apr 10 20:07:02 EDT 1990: + When inconsistent calling sequences involve differing numbers of +arguments, report the first differing argument rather than the numbers +of arguments. + Fix bug under -a: formatted I/O in which either the unit or the +format was a local character variable sometimes resulted in invalid C +(a static struct initialized with an automatic component). + Improve error message for invalid flag after elided -. + Complain when literal table overflows, rather than infinitely +looping. (The complaint mentions the new and otherwise undocumented +-NL option for specifying a larger literal table.) + New option -h for forcing strings to word (or, with -hd, double-word) +boundaries where possible. + Repair a bug that could cause improper splitting of strings. + Fix bug (cast of c to doublereal) in + subroutine foo(c,r) + double complex c + double precision r + c = cmplx(r,real(c)) + end + New include file "sysdep.h" has some things from defs.h (and +elsewhere) that one may need to modify on some systems. + Some large arrays that were previously statically allocated are now +dynamically allocated when f2c starts running. + f2c/src files changed: + README cds.c defs.h f2c.1 f2c.1t format.c formatdata.c init.c + io.c lex.c main.c makefile mem.c misc.c names.c niceprintf.c + output.c parse_args.c pread.c put.c putpcc.c sysdep.h + version.c xsum0.out + +Wed Apr 11 18:27:12 EDT 1990: + Fix bug in argument consistency checking of character, complex, and +double complex valued functions. If the same source file contained a +definition of such a function with arguments not explicitly typed, +then subsequent references to the function might get erroneous +warnings of inconsistent calling sequences. + Tweaks to sysdep.h for partially ANSI systems. + New options -kr and -krd cause f2c to use temporary variables to +enforce Fortran evaluation-order rules with pernicious, old-style C +compilers that apply the associative law to floating-point operations. + +Sat Apr 14 15:50:15 EDT 1990: + libi77: libI77 adjusted to allow list-directed and namelist I/O +of internal files; bug in namelist I/O of logical and character arrays +fixed; list input of complex numbers adjusted to permit d or D to +denote the start of the exponent field of a component. + f2c itself: fix bug in handling complicated lower-bound +expressions for character substrings; e.g., min and max did not work +right, nor did function invocations involving character arguments. + Switch to octal notation, rather than hexadecimal, for nonprinting +characters in character and string constants. + Fix bug (when neither -A nor -C++ was specified) in typing of +external arguments of type complex, double complex, or character: + subroutine foo(c) + external c + complex c +now results in + /* Complex */ int (*c) (); +(as, indeed, it once did) rather than + complex (*c) (); + +Sat Apr 14 22:50:39 EDT 1990: + libI77/makefile: updated "make check" to omit lio.c + lib[FI]77/makefile: trivial change: define CC = cc, reference $(CC). + (Request, e.g., "libi77 from f2c" -- you can't ask for individual +files from lib[FI]77.) + +Wed Apr 18 00:56:37 EDT 1990: + Move declaration of atof() from defs.h to sysdep.h, where it is +now not declared if stdlib.h is included. (NeXT's stdlib.h has a +#define atof that otherwise wreaks havoc.) + Under -u, provide a more intelligible error message (than "bad tag") +for an attempt to define a function without specifying its type. + +Wed Apr 18 17:26:27 EDT 1990: + Recognize \v (vertical tab) in Hollerith as well as quoted strings; +add recognition of \r (carriage return). + New option -!bs turns off recognition of escapes in character strings +(\0, \\, \b, \f, \n, \r, \t, \v). + Move to sysdep.c initialization of some arrays whose initialization +assumed ASCII; #define Table_size in sysdep.h rather than using +hard-coded 256 in allocating arrays of size 1 << (bits/byte). + +Thu Apr 19 08:13:21 EDT 1990: + Warn when escapes would make Hollerith extend beyond statement end. + Omit max() definition from misc.c (should be invisible except on +systems that erroneously #define max in stdlib.h). + +Mon Apr 23 22:24:51 EDT 1990: + When producing default-style C (no -A or -C++), cast switch +expressions to (int). + Move "-lF77 -lI77 -lm -lc" to link_msg, defined in sysdep.c . + Add #define scrub(x) to sysdep.h, with invocations in format.c and +formatdata.c, so that people who have systems like VMS that would +otherwise create multiple versions of intermediate files can +#define scrub(x) unlink(x) + +Tue Apr 24 18:28:36 EDT 1990: + Pass string lengths once rather than twice to a function of character +arguments involved in comparison of character strings of length 1. + +Fri Apr 27 13:11:52 EDT 1990: + Fix bug that made f2c gag on concatenations involving char(...) on +some systems. + +Sat Apr 28 23:20:16 EDT 1990: + Fix control-stack bug in + if(...) then + else if (complicated condition) + else + endif +(where the complicated condition causes assignment to an auxiliary +variable, e.g., max(a*b,c)). + +Mon Apr 30 13:30:10 EDT 1990: + Change fillers for DATA with holes from substructures to arrays +(in an attempt to make things work right with C compilers that have +funny padding rules for substructures, e.g., Sun C compilers). + Minor cleanup of exec.c (should not affect generated C). + +Mon Apr 30 23:13:51 EDT 1990: + Fix bug in handling return values of functions having multiple +entry points of differing return types. + +Sat May 5 01:45:18 EDT 1990: + Fix type inference bug in + subroutine foo(x) + call goo(x) + end + subroutine goo(i) + i = 3 + end +Instead of warning of inconsistent calling sequences for goo, +f2c was simply making i a real variable; now i is correctly +typed as an integer variable, and f2c issues an error message. + Adjust error messages issued at end of declarations so they +don't blame the first executable statement. + +Sun May 6 01:29:07 EDT 1990: + Fix bug in -P and -Ps: warn when the definition of a subprogram adds +information that would change prototypes or previous declarations. + +Thu May 10 18:09:15 EDT 1990: + Fix further obscure bug with (default) -it: inconsistent calling +sequences and I/O statements could interact to cause a memory fault. +Example: + SUBROUTINE FOO + CALL GOO(' Something') ! Forgot integer first arg + END + SUBROUTINE GOO(IUNIT,MSG) + CHARACTER*(*)MSG + WRITE(IUNIT,'(1X,A)') MSG + END + +Fri May 11 16:49:11 EDT 1990: + Under -!c, do not delete any .c files (when there are errors). + Avoid dereferencing 0 when a fatal error occurs while reading +Fortran on stdin. + +Wed May 16 18:24:42 EDT 1990: + f2c.ps made available. + +Mon Jun 4 12:53:08 EDT 1990: + Diagnose I/O units of invalid type. + Add specific error msg about dummy arguments in common. + +Wed Jun 13 12:43:17 EDT 1990: + Under -A, supply a missing "[1]" for CHARACTER*1 variables that appear +both in a DATA statement and in either COMMON or EQUIVALENCE. + +Mon Jun 18 16:58:31 EDT 1990: + Trivial updates to f2c.ps . ("Fortran 8x" --> "Fortran 90"; omit +"(draft)" from "(draft) ANSI C".) + +Tue Jun 19 07:36:32 EDT 1990: + Fix incorrect code generated for ELSE IF(expression involving +function call passing non-constant substring). + Under -h, preserve the property that strings are null-terminated +where possible. + Remove spaces between # and define in lex.c output.c parse.h . + +Mon Jun 25 07:22:59 EDT 1990: + Minor tweak to makefile to reduce unnecessary recompilations. + +Tue Jun 26 11:49:53 EDT 1990: + Fix unintended truncation of some integer constants on machines +where casting a long to (int) may change the value. E.g., when f2c +ran on machines with 16-bit ints, "i = 99999" was being translated +to "i = -31073;". + +Wed Jun 27 11:05:32 EDT 1990: + Arrange for CHARACTER-valued PARAMETERs to honor their length +specifications. Allow CHAR(nn) in expressions defining such PARAMETERs. + +Fri Jul 20 09:17:30 EDT 1990: + Avoid dereferencing 0 when a FORMAT statement has no label. + +Thu Jul 26 11:09:39 EDT 1990: + Remarks about VOID and binread,binwrite added to README. + Tweaks to parse_args: should be invisible unless your compiler +complained at (short)*store. + +Thu Aug 2 02:07:58 EDT 1990: + f2c.ps: change the first line of page 5 from + include stuff +to + include 'stuff' + +Tue Aug 14 13:21:24 EDT 1990: + libi77: libI77 adjusted to treat tabs as spaces in list input. + +Fri Aug 17 07:24:53 EDT 1990: + libi77: libI77 adjusted so a blank='ZERO' clause (upper case Z) +in an open of a currently open file works right. + +Tue Aug 28 01:56:44 EDT 1990: + Fix bug in warnings of inconsistent calling sequences: if an +argument to a subprogram was never referenced, then a previous +invocation of the subprogram (in the same source file) that +passed something of the wrong type for that argument did not +elicit a warning message. + +Thu Aug 30 09:46:12 EDT 1990: + libi77: prevent embedded blanks in list output of complex values; +omit exponent field in list output of values of magnitude between +10 and 1e8; prevent writing stdin and reading stdout or stderr; +don't close stdin, stdout, or stderr when reopening units 5, 6, 0. + +Tue Sep 4 12:30:57 EDT 1990: + Fix bug in C emitted under -I2 or -i2 for INTEGER*4 FUNCTION. + Warn of missing final END even if there are previous errors. + +Fri Sep 7 13:55:34 EDT 1990: + Remark about "make xsum.out" and "make f2c" added to README. + +Tue Sep 18 23:50:01 EDT 1990: + Fix null dereference (and, on some systems, writing of bogus *_com.c +files) under -ec or -e1c when a prototype file (*.p or *.P) describes +COMMON blocks that do not appear in the Fortran source. + libi77: + Add some #ifdef lines (#ifdef MSDOS, #ifndef MSDOS) to avoid +references to stat and fstat on non-UNIX systems. + On UNIX systems, add component udev to unit; decide that old +and new files are the same iff both the uinode and udev components +of unit agree. + When an open stmt specifies STATUS='OLD', use stat rather than +access (on UNIX systems) to check the existence of the file (in case +directories leading to the file have funny permissions and this is +a setuid or setgid program). + +Thu Sep 27 16:04:09 EDT 1990: + Supply missing entry for Impldoblock in blksize array of cpexpr +(in expr.c). No examples are known where this omission caused trouble. + +Tue Oct 2 22:58:09 EDT 1990: + libf77: test signal(...) == SIG_IGN rather than & 01 in main(). + libi77: adjust rewind.c so two successive rewinds after a write +don't clobber the file. + +Thu Oct 11 18:00:14 EDT 1990: + libi77: minor cleanups: add #include "fcntl.h" to endfile.c, err.c, +open.c; adjust g_char in util.c for segmented memories; in f_inqu +(inquire.c), define x appropriately when MSDOS is defined. + +Mon Oct 15 20:02:11 EDT 1990: + Add #ifdef MSDOS pointer adjustments to mem.c; treat NAME= as a +synonym for FILE= in OPEN statements. + +Wed Oct 17 16:40:37 EDT 1990: + libf77, libi77: minor cleanups: _cleanup() and abort() invocations +replaced by invocations of sig_die in main.c; some error messages +previously lost in buffers will now appear. + +Mon Oct 22 16:11:27 EDT 1990: + libf77: separate sig_die from main (for folks who don't want to use +the main in libF77). + libi77: minor tweak to comments in README. + +Fri Nov 2 13:49:35 EST 1990: + Use two underscores rather than one in generated temporary variable +names to avoid conflict with COMMON names. f2c.ps updated to reflect +this change and the NAME= extension introduced 15 Oct. + Repair a rare memory fault in io.c . + +Mon Nov 5 16:43:55 EST 1990: + libi77: changes to open.c (and err.c): complain if an open stmt +specifies new= and the file already exists (as specified by Fortrans 77 +and 90); allow file= to be omitted in open stmts and allow +status='replace' (Fortran 90 extensions). + +Fri Nov 30 10:10:14 EST 1990: + Adjust malloc.c for unusual systems whose sbrk() can return values +not properly aligned for doubles. + Arrange for slightly more helpful and less repetitive warnings for +non-character variables initialized with character data; these warnings +are (still) suppressed by -w66. + +Fri Nov 30 15:57:59 EST 1990: + Minor tweak to README (about changing VOID in f2c.h). + +Mon Dec 3 07:36:20 EST 1990: + Fix spelling of "character" in f2c.1t. + +Tue Dec 4 09:48:56 EST 1990: + Remark about link_msg and libf2c added to f2c/README. + +Thu Dec 6 08:33:24 EST 1990: + Under -U, render label nnn as L_nnn rather than Lnnn. + +Fri Dec 7 18:05:00 EST 1990: + Add more names from f2c.h (e.g. integer, real) to the c_keywords +list of names to which an underscore is appended to avoid confusion. + +Mon Dec 10 19:11:15 EST 1990: + Minor tweaks to makefile (./xsum) and README (binread/binwrite). + libi77: a few modifications for POSIX systems; meant to be invisible +elsewhere. + +Sun Dec 16 23:03:16 EST 1990: + Fix null dereference caused by unusual erroneous input, e.g. + call foo('abc') + end + subroutine foo(msg) + data n/3/ + character*(*) msg + end +(Subroutine foo is illegal because the character statement comes after a +data statement.) + Use decimal rather than hex constants in xsum.c (to prevent +erroneous warning messages about constant overflow). + +Mon Dec 17 12:26:40 EST 1990: + Fix rare extra underscore in character length parameters passed +for multiple entry points. + +Wed Dec 19 17:19:26 EST 1990: + Allow generation of C despite error messages about bad alignment +forced by equivalence. + Allow variable-length concatenations in I/O statements, such as + open(3, file=bletch(1:n) // '.xyz') + +Fri Dec 28 17:08:30 EST 1990: + Fix bug under -p with formats and internal I/O "units" in COMMON, +as in + COMMON /FIGLEA/F + CHARACTER*20 F + F = '(A)' + WRITE (*,FMT=F) 'Hello, world!' + END + +Tue Jan 15 12:00:24 EST 1991: + Fix bug when two equivalence groups are merged, the second with +nonzero offset, and the result is then merged into a common block. +Example: + INTEGER W(3), X(3), Y(3), Z(3) + COMMON /ZOT/ Z + EQUIVALENCE (W(1),X(1)), (X(2),Y(1)), (Z(3),X(1)) +***** W WAS GIVEN THE WRONG OFFSET + Recognize Fortran 90's optional NML= in NAMELIST READs and WRITEs. +(Currently NML= and FMT= are treated as synonyms -- there's no +error message if, e.g., NML= specifies a format.) + libi77: minor adjustment to allow internal READs from character +string constants in read-only memory. + +Fri Jan 18 22:56:15 EST 1991: + Add comment to README about needing to comment out the typedef of +size_t in sysdep.h on some systems, e.g. Sun 4.1. + Fix misspelling of "statement" in an error message in lex.c + +Wed Jan 23 00:38:48 EST 1991: + Allow hex, octal, and binary constants to have the qualifying letter +(z, x, o, or b) either before or after the quoted string containing the +digits. For now this change will not be reflected in f2c.ps . + +Tue Jan 29 16:23:45 EST 1991: + Arrange for character-valued statement functions to give results of +the right length (that of the statement function's name). + +Wed Jan 30 07:05:32 EST 1991: + More tweaks for character-valued statement functions: an error +check and an adjustment so a right-hand side of nonconstant length +(e.g., a substring) is handled right. + +Wed Jan 30 09:49:36 EST 1991: + Fix p1_head to avoid printing (char *)0 with %s. + +Thu Jan 31 13:53:44 EST 1991: + Add a test after the cleanup call generated for I/O statements with +ERR= or END= clauses to catch the unlikely event that the cleanup +routine encounters an error. + +Mon Feb 4 08:00:58 EST 1991: + Minor cleanup: omit unneeded jumps and labels from code generated for +some NAMELIST READs and WRITEs with IOSTAT=, ERR=, and/or END=. + +Tue Feb 5 01:39:36 EST 1991: + Change Mktemp to mktmp (for the benefit of systems so brain-damaged +that they do not distinguish case in external names -- and that for +some reason want to load mktemp). Try to get xsum0.out right this +time (it somehow didn't get updated on 4 Feb. 1991). + Add note to libi77/README about adjusting the interpretation of +RECL= specifiers in OPENs for direct unformatted I/O. + +Thu Feb 7 17:24:42 EST 1991: + New option -r casts values of REAL functions, including intrinsics, +to REAL. This only matters for unportable code like + real r + r = asin(1.) + if (r .eq. asin(1.)) ... +[The behavior of such code varies with the Fortran compiler used -- +and sometimes is affected by compiler options.] For now, the man page +at the end of f2c.ps is the only part of f2c.ps that reflects this new +option. + +Fri Feb 8 18:12:51 EST 1991: + Cast pointer differences passed as arguments to the appropriate type. +This matters, e.g., with MSDOS compilers that yield a long pointer +difference but have int == short. + Disallow nonpositive dimensions. + +Fri Feb 15 12:24:15 EST 1991: + Change %d to %ld in sprintf call in putpower in putpcc.c. + Free more memory (e.g. allowing translation of larger Fortran +files under MS-DOS). + Recognize READ (character expression) and WRITE (character expression) +as formatted I/O with the format given by the character expression. + Update year in Notice. + +Sat Feb 16 00:42:32 EST 1991: + Recant recognizing WRITE(character expression) as formatted output +-- Fortran 77 is not symmetric in its syntax for READ and WRITE. + +Mon Mar 4 15:19:42 EST 1991: + Fix bug in passing the real part of a complex argument to an intrinsic +function. Omit unneeded parentheses in nested calls to intrinsics. +Example: + subroutine foo(x, y) + complex y + x = exp(sin(real(y))) + exp(imag(y)) + end + +Fri Mar 8 15:05:42 EST 1991: + Fix a comment in expr.c; omit safstrncpy.c (which had bugs in +cases not used by f2c). + +Wed Mar 13 02:27:23 EST 1991: + Initialize firstmemblock->next in mem_init in mem.c . [On most +systems it was fortuituously 0, but with System V, -lmalloc could +trip on this missed initialization.] + +Wed Mar 13 11:47:42 EST 1991: + Fix a reference to freed memory. + +Wed Mar 27 00:42:19 EST 1991: + Fix a memory fault caused by such illegal Fortran as + function foo + x = 3 + logical foo ! declaration among executables + foo=.false. ! used to suffer memory fault + end + +Fri Apr 5 08:30:31 EST 1991: + Fix loss of % in some format expressions, e.g. + write(*,'(1h%)') + Fix botch introduced 27 March 1991 that caused subroutines with +multiple entry points to have extraneous declarations of ret_val. + +Fri Apr 5 12:44:02 EST 1991 + Try again to omit extraneous ret_val declarations -- this morning's +fix was sometimes wrong. + +Mon Apr 8 13:47:06 EDT 1991: + Arrange for s_rnge to have the right prototype under -A -C . + +Wed Apr 17 13:36:03 EDT 1991: + New fatal error message for apparent invocation of a recursive +statement function. + +Thu Apr 25 15:13:37 EDT 1991: + F2c and libi77 adjusted so NAMELIST works with -i2. (I forgot +about -i2 when adding NAMELIST.) This required a change to f2c.h +(that only affects NAMELIST I/O under -i2.) Man-page description of +-i2 adjusted to reflect that -i2 stores array lengths in short ints. + +Fri Apr 26 02:54:41 EDT 1991: + Libi77: fix some bugs in NAMELIST reading of multi-dimensional arrays +(file rsne.c). + +Thu May 9 02:13:51 EDT 1991: + Omit a trailing space in expr.c (could cause a false xsum value if +a mailer drops the trailing blank). + +Thu May 16 13:14:59 EDT 1991: + Libi77: increase LEFBL in lio.h to overcome a NeXT bug. + Tweak for compilers that recognize "nested" comments: inside comments, +turn /* into /+ (as well as */ into +/). + +Sat May 25 11:44:25 EDT 1991: + libf77: s_rnge: declare line long int rather than int. + +Fri May 31 07:51:50 EDT 1991: + libf77: system_: officially return status. + +Mon Jun 17 16:52:53 EDT 1991: + Minor tweaks: omit unnecessary declaration of strcmp (that caused +trouble on a system where strcmp was a macro) from misc.c; add +SHELL = /bin/sh to makefiles. + Fix a dereference of null when a CHARACTER*(*) declaration appears +(illegally) after DATA. Complain only once per subroutine about +declarations appearing after DATA. + +Mon Jul 1 00:28:13 EDT 1991: + Add test and error message for illegal use of subroutine names, e.g. + SUBROUTINE ZAP(A) + ZAP = A + END + +Mon Jul 8 21:49:20 EDT 1991: + Issue a warning about things like + integer i + i = 'abc' +(which is treated as i = ichar('a')). [It might be nice to treat 'abc' +as an integer initialized (in a DATA statement) with 'abc', but +other matters have higher priority.] + Render + i = ichar('A') +as + i = 'A'; +rather than + i = 65; +(which assumes ASCII). + +Fri Jul 12 07:41:30 EDT 1991: + Note added to README about erroneous definitions of __STDC__ . + +Sat Jul 13 13:38:54 EDT 1991: + Fix bugs in double type convesions of complex values, e.g. +sngl(real(...)) or dble(real(...)) (where ... is complex). + +Mon Jul 15 13:21:42 EDT 1991: + Fix bug introduced 8 July 1991 that caused erroneous warnings +"ichar([first char. of] char. string) assumed for conversion to numeric" +when a subroutine had an array of character strings as an argument. + +Wed Aug 28 01:12:17 EDT 1991: + Omit an unused function in format.c, an unused variable in proc.c . + Under -r8, promote complex to double complex (as the man page claims). + +Fri Aug 30 17:19:17 EDT 1991: + f2c.ps updated: slightly expand description of intrinsics and,or,xor, +not; add mention of intrinsics lshift, rshift; add note about f2c +accepting Fortran 90 inline comments (starting with !); update Cobalt +Blue address. + +Tue Sep 17 07:17:33 EDT 1991: + libI77: err.c and open.c modified to use modes "rb" and "wb" +when (f)opening unformatted files; README updated to point out +that it may be necessary to change these modes to "r" and "w" +on some non-ANSI systems. + +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. diff --git a/lang/fortran/index b/lang/fortran/index new file mode 100644 index 000000000..af761c420 --- /dev/null +++ b/lang/fortran/index @@ -0,0 +1,392 @@ + +====== index for f2c ============ + +FILES: + +f2c.h Include file necessary for compiling output of the converter. + See the second NOTE below. + +f2c.1 Man page for f2c. + +f2c.1t Source for f2c.1 (to be processed by troff -man or nroff -man). + +libf77 Library of non I/O support routines the generated C may need. + Fortran main programs result in a C function named MAIN__ that + is meant to be invoked by the main() in libf77. + +libi77 Library of Fortran I/O routines the generated C may need. + Note that some vendors (e.g., BSD, Sun and MIPS) provide a + libF77 and libI77 that are incompatible with f2c -- they + provide some differently named routines or routines with the + names that f2c expects, but with different calling sequences. + On such systems, the recommended procedure is to merge + libf77 and libi77 into a single library, say libf2c, to install + it where you can access it by specifying -lf2c , and to adjust + the definition of link_msg in sysdep.c appropriately. + +f2c.ps Postscript for a technical report on f2c. After you strip the + mail header, the first line should be "%!PS". + +fixes The complete change log, reporting bug fixes and other changes. + (Some recent change-log entries are given below). + +fc A shell script that uses f2c and imitates much of the behavior + of commonly found f77 commands. You will almost certainly + need to adjust some of the shell-variable assignments to make + this script work on your system. + + +SUBDIRECTORY: + +f2c/src Source for the converter itself, including a file of checksums + and source for a program to compute the checksums (to verify + correct transmission of the source), is available: ask netlib to + send all from f2c/src + If the checksums show damage to just a few source files, or if + the change log file (see "fixes" below) reports corrections to + some source files, you can request those files individually + "from f2c/src". For example, to get defs.h and xsum0.out, you + would ask netlib to + send defs.h xsum0.out from f2c/src + "all from f2c/src" is 649642 bytes long. + + Tip: if asked to send over 99,000 bytes in one request, netlib + breaks the shipment into 1000 line pieces and sends each piece + separately (since otherwise some mailers might gag). To avoid + the hassle of reassembling the pieces, try to keep each request + under 99,000 bytes long. The final number in each line of + xsum0.out gives the length of each file in f2c/src. For + example, + send exec.c expr.c from f2c/src + send format.c format_data.c from f2c/src + will give you slightly less hassle than + send exec.c expr.c format.c format_data.c from f2c/src + + If you have trouble generating gram.c, you can ask netlib to + send gram.c from f2c/src + Then `xsum gram.c` should report + gram.c efa337b3 57282 + +NOTE: For now, you may exercise f2c by sending netlib a message whose + first line is "execute f2c" and whose remaining lines are + the Fortran 77 source that you wish to have converted. + Return mail brings you the resulting C, with f2c's error + messages between #ifdef uNdEfInEd and #endif at the end. + (To understand line numbers in the error messages, regard + the "execute f2c" line as line 0. It is stripped away by + the netlib software before f2c sees your Fortran input.) + Options described in the man page may be transmitted to + netlib by having the first line of input be a comment + whose first 6 characters are "c$f2c " and whose remaining + characters are the desired options, e.g., "c$f2c -R -u". + This scheme may change -- ask netlib to + send index from f2c + if you do not get the behavior you expect. + + During the initial experimental period, incoming Fortran + will be saved in a file. Don't send any secrets! + + +BUGS: Please send bug reports (including the shortest example + you can find that illustrates the bug) to research!dmg + or dmg@research.att.com . You might first check whether + the bug goes away when you turn optimization off. + + +NOTE: f2c.h defines several types, e.g., real, integer, doublereal. + The definitions in f2c.h are suitable for most machines, but if + your machine has sizeof(double) > 2*sizeof(long), you may need + to adjust f2c.h appropriately. f2c assumes + sizeof(doublecomplex) = 2*sizeof(doublereal) + sizeof(doublereal) = sizeof(complex) + sizeof(doublereal) = 2*sizeof(real) + sizeof(real) = sizeof(integer) + sizeof(real) = sizeof(logical) + sizeof(real) = 2*sizeof(shortint) + EQUIVALENCEs may not be translated correctly if these + assumptions are violated. + + There exists a C compiler that objects to the lines + typedef VOID C_f; /* complex function */ + typedef VOID H_f; /* character function */ + typedef VOID Z_f; /* double complex function */ + in f2c.h . If yours is such a compiler, do two things: + 1. Complain to your vendor about this compiler bug. + 2. Find the line + #define VOID void + in f2c.h and change it to + #define VOID int + (For readability, the f2c.h lines shown above have had two + tabs inserted before their first character.) + +FTP: All the material described above is now available by ftp from + research.att.com (login: netlib; Password: your E-mail address; + cd f2c). You must uncompress the .Z files once you have a + copy of them, e.g., by + uncompress *.Z + +----------------- +Recent change log (partial) +----------------- + +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. + +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. + +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. + +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) +as formatted I/O with the format given by the character expression. + Update year in Notice. + +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). + +Tue May 7 09:04:48 EDT 1991: + gram.c added to f2c/src (for folks who have trouble generating it. It +is not in "all from f2c", nor in the list of current timestamps below.) + +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. + +Current timestamps of files in "all from f2c/src", sorted by time, +appear below (mm/dd/year hh:mm:ss). To bring your source up to date, +obtain source files with a timestamp later than the time shown in your +version.c. Note that the time shown in the current version.c is the +timestamp of the source module that immediately follows version.c below: + + 8/28/1991 0:29:01 xsum0.out + 8/28/1991 0:23:26 version.c + 8/28/1991 0:07:02 main.c + 8/28/1991 0:07:01 gram.dcl + 8/28/1991 0:07:01 expr.c + 8/28/1991 0:07:00 defs.h + 8/13/1991 9:06:09 format.c + 8/13/1991 9:04:25 proc.c + 7/13/1991 12:58:37 putpcc.c + 7/12/1991 7:25:33 README + 7/05/1991 7:16:57 intr.c + 6/17/1991 16:43:01 gram.head + 6/06/1991 0:41:56 makefile + 6/05/1991 8:34:09 misc.c + 5/16/1991 13:06:06 p1output.c + 4/25/1991 13:20:26 f2c.1 + 4/25/1991 12:56:19 f2c.h + 4/25/1991 12:51:27 f2c.1t + 4/25/1991 12:10:22 io.c + 4/05/1991 7:43:45 mem.c + 3/13/1991 11:18:09 output.c + 3/08/1991 10:14:45 niceprintf.c + 2/15/1991 12:08:26 Notice + 2/08/1991 11:29:18 gram.exec + 2/08/1991 11:29:18 malloc.c + 2/05/1991 0:52:39 exec.c + 1/22/1991 19:25:10 lex.c + 1/15/1991 1:21:00 equiv.c +12/16/1990 16:46:20 xsum.c +12/07/1990 17:37:08 names.c +11/30/1990 9:47:48 data.c + 7/26/1990 10:54:47 parse_args.c + 7/26/1990 10:44:26 parse.h + 6/19/1990 0:18:23 formatdata.c + 5/11/1990 14:17:04 error.c + 4/23/1990 17:35:47 sysdep.h + 4/23/1990 16:37:50 sysdep.c + 4/18/1990 12:25:19 init.c + 4/18/1990 12:25:19 pread.c + 4/18/1990 12:25:18 cds.c + 4/10/1990 0:00:38 put.c + 4/06/1990 0:00:57 gram.io + 4/05/1990 23:40:09 gram.expr + 3/27/1990 16:39:18 names.h + 3/27/1990 10:05:15 p1defs.h + 3/27/1990 10:05:14 defines.h + 2/25/1990 9:04:30 vax.c + 2/16/1990 10:37:27 tokens + 2/14/1990 2:00:20 format.h + 2/14/1990 1:38:46 output.h + 2/14/1990 0:54:06 iob.h + 2/03/1990 0:58:26 niceprintf.h + 1/29/1990 13:26:52 memset.c + 1/11/1990 18:02:51 ftypes.h + 1/07/1990 1:20:01 usignal.h +11/27/1989 8:27:37 machdefs.h + 7/01/1989 11:59:44 pccdefs.h diff --git a/lang/fortran/lib/.distr b/lang/fortran/lib/.distr new file mode 100644 index 000000000..254dfd229 --- /dev/null +++ b/lang/fortran/lib/.distr @@ -0,0 +1,3 @@ +LIST +libF77 +libI77 diff --git a/lang/fortran/lib/LIST b/lang/fortran/lib/LIST new file mode 100644 index 000000000..254dfd229 --- /dev/null +++ b/lang/fortran/lib/LIST @@ -0,0 +1,3 @@ +LIST +libF77 +libI77