--- /dev/null
+changes
+comp
+disclaimer
+fc
+fixes
+index
+lib
--- /dev/null
+31 Aug. 1989:
+ 1. A(min(i,j)) now is translated correctly (where A is an array).
+ 2. 7 and 8 character variable names are allowed (but elicit a
+ complaint under -ext).
+ 3. LOGICAL*1 is treated as LOGICAL, with just one error message
+ per LOGICAL*1 statement (rather than one per variable declared
+ in that statement). [Note that LOGICAL*1 is not in Fortran 77.]
+ Like f77, f2c now allows the format in a read or write statement
+ to be an integer array.
+
+5 Sept. 1989:
+ Fixed botch in argument passing of substrings of equivalenced
+variables.
+
+15 Sept. 1989:
+ Warn about incorrect code generated when a character-valued
+function is not declared external and is passed as a parameter
+(in violation of the Fortran 77 standard) before it is invoked.
+Example:
+
+ subroutine foo(a,b)
+ character*10 a,b
+ call goo(a,b)
+ b = a(3)
+ end
+
+18 Sept. 1989:
+ Complain about overlapping initializations.
+
+20 Sept. 1989:
+ Warn about names declared EXTERNAL but never referenced;
+include such names as externs in the generated C (even
+though most C compilers will discard them).
+
+24 Sept. 1989:
+ New option -w8 to suppress complaint when COMMON or EQUIVALENCE
+forces word alignment of a double.
+ Under -A (for ANSI C), ensure that floating constants (terminated
+by 'f') contain either a decimal point or an exponent field.
+ Repair bugs sometimes encountered with CHAR and ICHAR intrinsic
+functions.
+ Restore f77's optimizations for copying and comparing character
+strings of length 1.
+ Always assume floating-point valued routines in libF77 return
+doubles, even under -R.
+ Repair occasional omission of arguments in routines having multiple
+entry points.
+ Repair bugs in computing offsets of character strings involved
+in EQUIVALENCE.
+ Don't omit structure qualification when COMMON variables are used
+as FORMATs or internal files.
+
+2 Oct. 1989:
+ Warn about variables that appear only in data stmts; don't emit them.
+ Fix bugs in character DATA for noncharacter variables
+involved in EQUIVALENCE.
+ Treat noncharacter variables initialized (at least partly) with
+character data as though they were equivalenced -- put out a struct
+and #define the variables. This eliminates the hideous and nonportable
+numeric values that were used to initialize such variables.
+ Treat IMPLICIT NONE as IMPLICIT UNDEFINED(A-Z) .
+ Quit when given invalid options.
+
+8 Oct. 1989:
+ Modified naming scheme for generated intermediate variables;
+more are recycled, fewer distinct ones used.
+ New option -W nn specifies nn characters/word for Hollerith
+data initializing non-character variables.
+ Bug fix: x(i:min(i+10,j)) used to elicit "Can't handle opcode 31 yet".
+ Integer expressions of the form (i+const1) - (i+const2), where
+i is a scalar integer variable, are now simplified to (const1-const2);
+this leads to simpler translation of some substring expressions.
+ Initialize uninitialized portions of character string arrays to 0
+rather than to blanks.
+
+9 Oct. 1989:
+ New option -c to insert comments showing original Fortran source.
+ New option -g to insert line numbers of original Fortran source.
+
+10 Oct. 1989:
+ ! recognized as in-line comment delimiter (a la Fortran 88).
+
+24 Oct. 1989:
+ New options to ease coping with systems that want the structs
+that result from COMMON blocks to be defined just once:
+ -E causes uninitialized COMMON blocks to be declared Extern;
+if Extern is undefined, f2c.h #defines it to be extern.
+ -ec causes a separate .c file to be emitted for each
+uninitialized COMMON block: COMMON /ABC/ yields abc_com.c;
+thus one can compile *_com.c into a library to ensure
+precisely one definition.
+ -e1c is similar to -ec, except that everything goes into
+one file, along with comments that give a sed script for
+splitting the file into the pieces that -ec would give.
+This is for use with netlib's "execute f2c" service (for which
+-ec is coerced into -e1c, and the sed script will put everything
+but the COMMON definitions into f2c_out.c ).
+
+28 Oct. 1989:
+ Convert "i = i op ..." into "i op= ...;" even when i is a
+dummy argument.
+
+13 Nov. 1989:
+ Name integer constants (passed as arguments) c__... rather
+than c_... so
+ common /c/stuff
+ call foo(1)
+ ...
+is translated correctly.
+
+19 Nov. 1989:
+ Floating-point constants are now kept as strings unless they
+are involved in constant expressions that get simplified. The
+floating-point constants kept as strings can have arbitrarily
+many significant figures and a very large exponent field (as
+large as long int allows on the machine on which f2c runs).
+Thus, for example, the body of
+
+ subroutine zot(x)
+ double precision x(6), pi
+ parameter (pi=3.1415926535897932384626433832795028841972)
+ x(1) = pi
+ x(2) = pi+1
+ x(3) = 9287349823749272.7429874923740978492734D-298374
+ x(4) = .89
+ x(5) = 4.0005
+ x(6) = 10D7
+ end
+
+now gets translated into
+
+ x[1] = 3.1415926535897932384626433832795028841972;
+ x[2] = 4.1415926535897931;
+ x[3] = 9.2873498237492727429874923740978492734e-298359;
+ x[4] = (float).89;
+ x[5] = (float)4.0005;
+ x[6] = 1e8;
+
+rather than the former
+
+ x[1] = 3.1415926535897931;
+ x[2] = 4.1415926535897931;
+ x[3] = 0.;
+ x[4] = (float)0.89000000000000003;
+ x[5] = (float)4.0004999999999997;
+ x[6] = 100000000.;
+
+ Recognition of f77 machine-constant intrinsics deleted, i.e.,
+epbase, epprec, epemin, epemax, eptiny, ephuge, epmrsp.
+
+22 Nov. 1989:
+ Workarounds for glitches on some Sun systems...
+ libf77: libF77/makefile modified to point out possible need
+to compile libF77/main.c with -Donexit=on_exit .
+ libi77: libI77/wref.c (and libI77/README) modified so non-ANSI
+systems can compile with USE_STRLEN defined, which will cause
+ sprintf(b = buf, "%#.*f", d, x);
+ n = strlen(b) + d1;
+rather than
+ n = sprintf(b = buf, "%#.*f", d, x) + d1;
+to be compiled.
+
+26 Nov. 1989:
+ Longer names are now accepted (up to 50 characters); names may
+contain underscores (in which case they will have two underscores
+appended, to avoid clashes with library names).
+
+28 Nov. 1989:
+ libi77 updated:
+ 1. Allow 3 (or, on Crays, 4) digit exponents under format Ew.d .
+ 2. Try to get things right on machines where ints have 16 bits.
+
+29 Nov. 1989:
+ Supplied missing semicolon in parameterless subroutines that
+have multiple entry points (all of them parameterless).
+
+30 Nov. 1989:
+ libf77 and libi77 revised to use types from f2c.h.
+ f2c now types floating-point valued C library routines as "double"
+rather than "doublereal" (for use with nonstandard C compilers for
+which "double" is IEEE double extended).
+
+1 Dec. 1989:
+ f2c.h updated to eliminate #defines rendered unnecessary (and,
+indeed, dangerous) by change of 26 Nov. to long names possibly
+containing underscores.
+ libi77 further revised: yesterday's change omitted two tweaks to fmt.h
+(tweaks which only matter if float and real or double and doublereal are
+different types).
+
+2 Dec. 1989:
+ Better error message (than "bad tag") for NAMELIST, which no longer
+inhibits C output.
+
+4 Dec. 1989:
+ Allow capital letters in hex constants (f77 extension; e.g.,
+x'a012BCd', X'A012BCD' and x'a012bcd' are all treated as the integer
+167848909).
+ libi77 further revised: lio.c lio.h lread.c wref.c wrtfmt.c tweaked
+again to allow float and real or double and doublereal to be different.
+
+6 Dec. 1989:
+ Revised f2c.h -- required for the following...
+ Simpler looking translations for abs, min, max, using #defines in
+revised f2c.h .
+ libi77: more corrections to types; additions for NAMELIST.
+ Corrected casts in some I/O calls.
+ Translation of NAMELIST; libi77 must still be revised. Currently
+libi77 gives you a run-time error message if you attempt NAMELIST I/O.
+
+7 Dec. 1989:
+ Fixed bug that prevented local integer variables that appear in DATA
+stmts from being ASSIGNed statement labels.
+ Fillers (for DATA statements initializing EQUIVALENCEd variables and
+variables in COMMON) typed integer rather than doublereal (for slightly
+more portability, e.g. to Crays).
+ libi77: missing return values supplied in a few places; some tests
+reordered for better working on the Cray.
+ libf77: better accuracy for complex divide, complex square root,
+real mod function (casts to double; double temporaries).
+
+9 Dec. 1989:
+ Fixed bug that caused needless (albeit harmless) empty lines to be
+inserted in the C output when a comment line contained trailing blanks.
+ Further tweak to type of fillers: allow doublereal fillers if the
+struct has doublereal data.
+
+11 Dec. 1989:
+ Alteration of rule for producing external (C) names from names that
+contain underscores. Now the external name is always obtained by
+appending a pair of underscores.
+
+12 Dec. 1989:
+ C production inhibited after most errors.
+
+15 Dec. 1989:
+ Fixed bug in headers for subroutines having two or more character
+strings arguments: the length arguments were reversed.
+
+19 Dec. 1989:
+ f2c.h libf77 libi77: adjusted so #undefs in f2c.h should not foil
+compilation of libF77 and libI77.
+ libf77: getenv_ adjusted to work with unsorted environments.
+ libi77: the iostat= specifier should now work right with internal I/O.
+
+20 Dec. 1989:
+ f2c bugs fixed: In the absence of an err= specifier, the iostat=
+specifier was generally set wrong. Character strings containing
+explicit nulls (\0) were truncated at the first null.
+ Unlabeled DO loops recognized; must be terminated by ENDDO.
+(Don't ask for CYCLE, EXIT, named DO loops, or DO WHILE.)
+
+29 Dec. 1989:
+ Nested unlabeled DO loops now handled properly; new warning for
+extraneous text at end of FORMAT.
+
+30 Dec. 1989:
+ Fixed bug in translating dble(real(...)), dble(sngl(...)), and
+dble(float(...)), where ... is either of type double complex or
+is an expression requiring assignment to intermediate variables (e.g.,
+dble(real(foo(x+1))), where foo is a function and x is a variable).
+Regard nonblank label fields on continuation lines as an error.
+
+3 Jan. 1990:
+ New option -C++ yields output that should be understood
+by C++ compilers.
+
+6 Jan. 1989:
+ -a now excludes variables that appear in a namelist from those
+that it makes automatic. (As before, it also excludes variables
+that appear in a common, data, equivalence, or save statement.)
+ The syntactically correct Fortran
+ read(*,i) x
+ end
+now yields syntactically correct C (even though both the Fortran
+and C are buggy -- no FORMAT has not been ASSIGNed to i).
+
+7 Jan. 1990:
+ libi77: routines supporting NAMELIST added. Surrounding quotes
+made optional when no ambiguity arises in a list or namelist READ
+of a character-string value.
+
+9 Jan. 1990:
+ f2c.src made available.
+
+16 Jan. 1990:
+ New options -P to produce ANSI C or C++ prototypes for procedures
+defined. Change to -A and -C++: f2c tries to infer prototypes for
+invoked procedures unless the new -!P option is given. New warning
+messages for inconsistent calling sequences among procedures within
+a single file. Most of f2c/src is affected.
+ f2c.h: typedefs for procedure arguments added; netlib's f2c service
+will insert appropriate typedefs for use with older versions of f2c.h.
+
+17 Jan. 1990:
+ f2c/src: defs.h exec.c format.c proc.c putpcc.c version.c xsum0.out
+updated. Castargs and protofile made extern in defs.h; exec.c
+modified so superfluous else clauses are diagnosed; unused variables
+omitted from declarations in format.c proc.c putpcc.c .
+
+21 Jan. 1990:
+ No C emitted for procedures declared external but not referenced.
+ f2c.h: more new types added for use with -P.
+ New feature: f2c accepts as arguments files ending in .p or .P;
+such files are assumed to be prototype files, such as produced by
+the -P option. All prototype files are read before any Fortran files
+and apply globally to all Fortran files. Suitable prototypes help f2c
+warn about calling-sequence errors and can tell f2c how to type
+procedures declared external but not explicitly typed; the latter is
+mainly of interest for users of the -A and -C++ options. (Prototype
+arguments are not available to netlib's "execute f2c" service.)
+ New option -it tells f2c to try to infer types of untyped external
+arguments from their use as parameters to prototyped or previously
+defined procedures.
+ f2c/src: many minor cleanups; most modules changed. Individual
+files in f2c/src are now in "bundle" format. The former f2c.1 is
+now f2c.1t; "f2c.1t from f2c" and "f2c.1t from f2c/src" are now the
+same, as are "f2c.1 from f2c" and "f2c.1 from f2c/src". People who
+do not obtain a new copy of "all from f2c/src" should at least add
+ fclose(sortfp);
+after the call on do_init_data(outfile, sortfp) in format_data.c .
+
+22 Jan. 1990:
+ Cleaner man page wording (thanks to Doug McIlroy).
+ -it now also applies to all untyped EXTERNAL procedures, not just
+arguments.
+
+23 Jan. 01:34:00 EST 1990:
+ Bug fixes: under -A and -C++, incorrect C was generated for
+subroutines having multiple entries but no arguments.
+ Under -A -P, subroutines of no arguments were given prototype
+calling sequence () rather than (void).
+ Character-valued functions elicited erroneous warning messages
+about inconsistent calling sequences when referenced by another
+procedure in the same file.
+ f2c.1t: omit first appearance of libF77.a in FILES section;
+load order of libraries is -lF77 -lI77, not vice versa (bug
+introduced in yesterday's edits); define .F macro for those whose
+-man lacks it. (For a while after yesterday's fixes were posted,
+f2c.1t was out of date. Sorry!)
+
+23 Jan. 9:53:24 EST 1990:
+ Character substring expressions involving function calls having
+character arguments (including the intrinsic len function) yielded
+incorrect C.
+ Procedures defined after invocation (in the same file) with
+conflicting argument types also got an erroneous message about
+the wrong number of arguments.
+
+24 Jan. 11:44:00 EST 1990:
+ Bug fixes: -p omitted #undefs; COMMON block names containing
+underscores had their C names incorrectly computed; a COMMON block
+having the name of a previously defined procedure wreaked havoc;
+if all arguments were .P files, f2c tried reading the second as a
+Fortran file.
+ New feature: -P emits comments showing COMMON block lengths, so one
+can get warnings of incompatible COMMON block lengths by having f2c
+read .P (or .p) files. Now by running f2c twice, first with -P -!c
+(or -P!c), then with *.P among the arguments, you can be warned of
+inconsistent COMMON usage, and COMMON blocks having inconsistent
+lengths will be given the maximum length. (The latter always did
+happen within each input file; now -P lets you extend this behavior
+across files.)
+
+26 Jan. 16:44:00 EST 1990:
+ Option -it made less aggressive: untyped external procedures that
+are invoked are now typed by the rules of Fortran, rather than by
+previous use of procedures to which they are passed as arguments
+before being invoked.
+ Option -P now includes information about references, i.e., called
+procedures, in the prototype files (in the form of special comments).
+This allows iterative invocations of f2c to infer more about untyped
+external names, particularly when multiple Fortran files are involved.
+ As usual, there are some obscure bug fixes:
+1. Repair of erroneous warning messages about inconsistent number of
+arguments that arose when a character dummy parameter was discovered
+to be a function or when multiple entry points involved character
+variables appearing in a previous entry point.
+2. Repair of memory fault after error msg about "adjustable character
+function".
+3. Under -U, allow MAIN_ as a subroutine name (in the same file as a
+main program).
+4. Change for consistency: a known function invoked as a subroutine,
+then as a function elicits a warning rather than an error.
+
+26 Jan. 22:32:00 EST 1990:
+ Fixed two bugs that resulted in incorrect C for substrings, within
+the body of a character-valued function, of the function's name, when
+those substrings were arguments to another function (even implicitly,
+as in character-string assignment).
+
+28 Jan. 18:32:00 EST 1990:
+ libf77, libi77: checksum files added; "make check" looks for
+transmission errors. NAMELIST read modified to allow $ rather than &
+to precede a namelist name, to allow $ rather than / to terminate
+input where the name of another variable would otherwise be expected,
+and to regard all nonprinting ASCII characters <= ' ' as spaces.
+
+29 Jan. 02:11:00 EST 1990:
+ "fc from f2c" added.
+ -it option made the default; -!it turns it off. Type information is
+now updated in a previously missed case.
+ -P option tweaked again; message about when rerunning f2c may change
+prototypes or declarations made more accurate.
+ New option -Ps implies -P and returns exit status 4 if rerunning
+f2c -P with prototype inputs might change prototypes or declarations.
+Now you can execute a crude script like
+
+ cat *.f >zap.F
+ rm -f zap.P
+ while :; do
+ f2c -Ps -!c zap.[FP]
+ case $? in 4) ;; *) break;; esac
+ done
+
+to get a file zap.P of the best prototypes f2c can determine for *.f .
+
+Jan. 29 07:30:21 EST 1990:
+ Forgot to check for error status when setting return code 4 under -Ps;
+error status (1, 2, 3, or, for caught signal, 126) now takes precedence.
+
+Jan 29 14:17:00 EST 1990:
+ Incorrect handling of
+ open(n,'filename')
+repaired -- now treated as
+ open(n,file='filename')
+(and, under -ext, given an error message).
+ New optional source file memset.c for people whose systems don't
+provide memset, memcmp, and memcpy; #include <string.h> in mem.c
+changed to #include "string.h" so BSD people can create a local
+string.h that simply says #include <strings.h> .
+
+Jan 30 10:34:00 EST 1990:
+ Fix erroneous warning at end of definition of a procedure with
+character arguments when the procedure had previously been called with
+a numeric argument instead of a character argument. (There were two
+warnings, the second one incorrectly complaining of a wrong number of
+arguments.)
+
+Jan 30 16:29:41 EST 1990:
+ Fix case where -P and -Ps erroneously reported another iteration
+necessary. (Only harm is the extra iteration.)
+
+Feb 3 01:40:00 EST 1990:
+ Supply semicolon occasionally omitted under -c .
+ Try to force correct alignment when numeric variables are initialized
+with character data (a non-standard and non-portable practice). You
+must use the -W option if your code has such data statements and is
+meant to run on a machine with other than 4 characters/word; e.g., for
+code meant to run on a Cray, you would specify -W8 .
+ Allow parentheses around expressions in output lists (in write and
+print statements).
+ Rename source files so their names are <= 12 characters long
+(so there's room to append .Z and still have <= 14 characters);
+renamed files: formatdata.c niceprintf.c niceprintf.h safstrncpy.c .
+ f2c material made available by anonymous ftp from research.att.com
+(look in dist/f2c ).
+
+Feb 3 03:49:00 EST 1990:
+ Repair memory fault that arose from use (in an assignment or
+call) of a non-argument variable declared CHARACTER*(*).
+
+Feb 9 01:35:43 EST 1990:
+ Fix erroneous error msg about bad types in
+ subroutine foo(a,adim)
+ dimension a(adim)
+ integer adim
+ Fix improper passing of character args (and possible memory fault)
+in the expression part of a computed goto.
+ Fix botched calling sequences in array references involving
+functions having character args.
+ Fix memory fault caused by invocation of character-valued functions
+of no arguments.
+ Fix botched calling sequence of a character*1-valued function
+assigned to a character*1 variable.
+ Fix bug in error msg for inconsistent number of args in prototypes.
+ Allow generation of C output despite inconsistencies in prototypes,
+but give exit code 8.
+ Simplify include logic (by removing some bogus logic); never
+prepend "/usr/include/" to file names.
+ Minor cleanups (that should produce no visible change in f2c's
+behavior) in intr.c parse.h main.c defs.h formatdata.c p1output.c .
+
+Feb 10 00:19:38 EST 1990:
+ Insert (integer) casts when floating-point expressions are used
+as subscripts.
+ Make SAVE stmt (with no variable list) override -a .
+ Minor cleanups: change field to Field in struct Addrblock (for the
+benefit of buggy C compilers); omit system("/bin/cp ...") in misc.c .
+
+Feb 13 00:39:00 EST 1990:
+ Error msg fix in gram.dcl: change "cannot make %s parameter"
+to "cannot make into parameter".
+
+Feb 14 14:02:00 EST 1990:
+ Various cleanups (invisible on systems with 4-byte ints), thanks
+to Dave Regan: vaxx.c eliminated; %d changed to %ld various places;
+external names adjusted for the benefit of stupid systems (that ignore
+case and recognize only 6 significant characters in external names);
+buffer shortened in xsum.c (e.g. for MS-DOS); fopen modes distinguish
+text and binary files; several unused functions eliminated; missing
+arg supplied to an unlikely fatalstr invocation.
+
+Thu Feb 15 19:15:53 EST 1990:
+ More cleanups (invisible on systems with 4 byte ints); casts inserted
+so most complaints from cyntax(1) and lint(1) go away; a few (int)
+versus (long) casts corrected.
+
+Fri Feb 16 19:55:00 EST 1990:
+ Recognize and translate unnamed Fortran 8x do while statements.
+ Fix bug that occasionally caused improper breaking of character
+strings.
+ New error message for attempts to provide DATA in a type-declaration
+statement.
+
+Sat Feb 17 11:43:00 EST 1990:
+ Fix infinite loop clf -> Fatal -> done -> clf after I/O error.
+ Change "if (addrp->vclass = CLPROC)" to "if (addrp->vclass == CLPROC)"
+in p1_addr (in p1output.c); this was probably harmless.
+ Move a misplaced } in lex.c (which slowed initkey()).
+ Thanks to Gary Word for pointing these things out.
+
+Sun Feb 18 18:07:00 EST 1990:
+ Detect overlapping initializations of arrays and scalar variables
+in previously missed cases.
+ Treat logical*2 as logical (after issuing a warning).
+ Don't pass string literals to p1_comment().
+ Correct a cast (introduced 16 Feb.) in gram.expr; this matters e.g.
+on a Cray.
+ Attempt to isolate UNIX-specific things in sysdep.c (a new source
+file). Unless sysdep.c is compiled with SYSTEM_SORT defined, the
+intermediate files created for DATA statements are now sorted in-core
+without invoking system().
+
+Tue Feb 20 16:10:35 EST 1990:
+ Move definition of binread and binwrite from init.c to sysdep.c .
+ Recognize Fortran 8x tokens < <= == >= > <> as synonyms for
+.LT. .LE. .EQ. .GE. .GT. .NE.
+ Minor cleanup in putpcc.c: fully remove simoffset().
+ More discussion of system dependencies added to libI77/README.
+
+Tue Feb 20 21:44:07 EST 1990:
+ Minor cleanups for the benefit of EBCDIC machines -- try to remove
+the assumption that 'a' through 'z' are contiguous. (Thanks again to
+Gary Word.) Also, change log2 to log_2 (shouldn't be necessary).
+
+Wed Feb 21 06:24:56 EST 1990:
+ Fix botch in init.c introduced in previous change; only matters
+to non-ASCII machines.
+
+Thu Feb 22 17:29:12 EST 1990:
+ Allow several entry points to mention the same array. Protect
+parameter adjustments with if's (for the case that an array is not
+an argument to all entrypoints).
+ Under -u, allow
+ subroutine foo(x,n)
+ real x(n)
+ integer n
+ Compute intermediate variables used to evaluate dimension expressions
+at the right time. Example previously mistranslated:
+ subroutine foo(x,k,m,n)
+ real x(min(k,m,n))
+ ...
+ write(*,*) x
+ Detect duplicate arguments. (The error msg points to the first
+executable stmt -- not wonderful, but not worth fixing.)
+ Minor cleanup of min/max computation (sometimes slightly simpler).
+
+Sun Feb 25 09:39:01 EST 1990:
+ Minor tweak to multiple entry points: protect parameter adjustments
+with if's only for (array) args that do not appear in all entry points.
+ Minor tweaks to format.c and io.c (invisible unless your compiler
+complained at the duplicate #defines of IOSUNIT and IOSFMT or at
+comparisons of p1gets(...) with NULL).
+
+Sun Feb 25 18:40:10 EST 1990:
+ Fix bug introduced Feb. 22: if a subprogram contained DATA and the
+first executable statement was labeled, then the label got lost.
+(Just change INEXEC to INDATA in p1output.c; it occurs just once.)
+
+Mon Feb 26 17:45:10 EST 1990:
+ Fix bug in handling of " and ' in comments.
+
+Wed Mar 28 01:43:06 EST 1990:
+libI77:
+ 1. Repair nasty I/O bug: opening two files and closing the first
+(after possibly reading or writing it), then writing the second caused
+the last buffer of the second to be lost.
+ 2. Formatted reads of logical values treated all letters other than
+t or T as f (false).
+ libI77 files changed: err.c rdfmt.c Version.c
+ (Request "libi77 from f2c" -- you can't get these files individually.)
+
+f2c itself:
+ Repair nasty bug in translation of
+ ELSE IF (condition involving complicated abs, min, or max)
+-- auxiliary statements were emitted at the wrong place.
+ Supply semicolon previously omitted from the translation of a label
+(of a CONTINUE) immediately preceding an ELSE IF or an ELSE. This
+bug made f2c produce invalid C.
+ Correct a memory fault that occurred (on some machines) when the
+error message "adjustable dimension on non-argument" should be given.
+ Minor tweaks to remove some harmless warnings by overly chatty C
+compilers.
+ Argument arays having constant dimensions but a variable lower bound
+(e.g., x(n+1:n+3)) had a * omitted from scalar arguments involved in
+the array offset computation.
+
+Wed Mar 28 18:47:59 EST 1990:
+libf77: add exit(0) to end of main [return(0) encounters a Cray bug]
+
+Sun Apr 1 16:20:58 EDT 1990:
+ Avoid dereferencing null when processing equivalences after an error.
+
+Fri Apr 6 08:29:49 EDT 1990:
+ Calls involving alternate return specifiers omitted processing
+needed for things like min, max, abs, and // (concatenation).
+ INTEGER*2 PARAMETERs were treated as INTEGER*4.
+ Convert some O(n^2) parsing to O(n).
+
+Tue Apr 10 20:07:02 EDT 1990:
+ When inconsistent calling sequences involve differing numbers of
+arguments, report the first differing argument rather than the numbers
+of arguments.
+ Fix bug under -a: formatted I/O in which either the unit or the
+format was a local character variable sometimes resulted in invalid C
+(a static struct initialized with an automatic component).
+ Improve error message for invalid flag after elided -.
+ Complain when literal table overflows, rather than infinitely
+looping. (The complaint mentions the new and otherwise undocumented
+-NL option for specifying a larger literal table.)
+ New option -h for forcing strings to word (or, with -hd, double-word)
+boundaries where possible.
+ Repair a bug that could cause improper splitting of strings.
+ Fix bug (cast of c to doublereal) in
+ subroutine foo(c,r)
+ double complex c
+ double precision r
+ c = cmplx(r,real(c))
+ end
+ New include file "sysdep.h" has some things from defs.h (and
+elsewhere) that one may need to modify on some systems.
+ Some large arrays that were previously statically allocated are now
+dynamically allocated when f2c starts running.
+ f2c/src files changed:
+ README cds.c defs.h f2c.1 f2c.1t format.c formatdata.c init.c
+ io.c lex.c main.c makefile mem.c misc.c names.c niceprintf.c
+ output.c parse_args.c pread.c put.c putpcc.c sysdep.h
+ version.c xsum0.out
+
+Wed Apr 11 18:27:12 EDT 1990:
+ Fix bug in argument consistency checking of character, complex, and
+double complex valued functions. If the same source file contained a
+definition of such a function with arguments not explicitly typed,
+then subsequent references to the function might get erroneous
+warnings of inconsistent calling sequences.
+ Tweaks to sysdep.h for partially ANSI systems.
+ New options -kr and -krd cause f2c to use temporary variables to
+enforce Fortran evaluation-order rules with pernicious, old-style C
+compilers that apply the associative law to floating-point operations.
+
+Sat Apr 14 15:50:15 EDT 1990:
+ libi77: libI77 adjusted to allow list-directed and namelist I/O
+of internal files; bug in namelist I/O of logical and character arrays
+fixed; list input of complex numbers adjusted to permit d or D to
+denote the start of the exponent field of a component.
+ f2c itself: fix bug in handling complicated lower-bound
+expressions for character substrings; e.g., min and max did not work
+right, nor did function invocations involving character arguments.
+ Switch to octal notation, rather than hexadecimal, for nonprinting
+characters in character and string constants.
+ Fix bug (when neither -A nor -C++ was specified) in typing of
+external arguments of type complex, double complex, or character:
+ subroutine foo(c)
+ external c
+ complex c
+now results in
+ /* Complex */ int (*c) ();
+(as, indeed, it once did) rather than
+ complex (*c) ();
+
+Sat Apr 14 22:50:39 EDT 1990:
+ libI77/makefile: updated "make check" to omit lio.c
+ lib[FI]77/makefile: trivial change: define CC = cc, reference $(CC).
+ (Request, e.g., "libi77 from f2c" -- you can't ask for individual
+files from lib[FI]77.)
+
+Wed Apr 18 00:56:37 EDT 1990:
+ Move declaration of atof() from defs.h to sysdep.h, where it is
+now not declared if stdlib.h is included. (NeXT's stdlib.h has a
+#define atof that otherwise wreaks havoc.)
+ Under -u, provide a more intelligible error message (than "bad tag")
+for an attempt to define a function without specifying its type.
+
+Wed Apr 18 17:26:27 EDT 1990:
+ Recognize \v (vertical tab) in Hollerith as well as quoted strings;
+add recognition of \r (carriage return).
+ New option -!bs turns off recognition of escapes in character strings
+(\0, \\, \b, \f, \n, \r, \t, \v).
+ Move to sysdep.c initialization of some arrays whose initialization
+assumed ASCII; #define Table_size in sysdep.h rather than using
+hard-coded 256 in allocating arrays of size 1 << (bits/byte).
+
+Thu Apr 19 08:13:21 EDT 1990:
+ Warn when escapes would make Hollerith extend beyond statement end.
+ Omit max() definition from misc.c (should be invisible except on
+systems that erroneously #define max in stdlib.h).
+
+Mon Apr 23 22:24:51 EDT 1990:
+ When producing default-style C (no -A or -C++), cast switch
+expressions to (int).
+ Move "-lF77 -lI77 -lm -lc" to link_msg, defined in sysdep.c .
+ Add #define scrub(x) to sysdep.h, with invocations in format.c and
+formatdata.c, so that people who have systems like VMS that would
+otherwise create multiple versions of intermediate files can
+#define scrub(x) unlink(x)
+
+Tue Apr 24 18:28:36 EDT 1990:
+ Pass string lengths once rather than twice to a function of character
+arguments involved in comparison of character strings of length 1.
+
+Fri Apr 27 13:11:52 EDT 1990:
+ Fix bug that made f2c gag on concatenations involving char(...) on
+some systems.
+
+Sat Apr 28 23:20:16 EDT 1990:
+ Fix control-stack bug in
+ if(...) then
+ else if (complicated condition)
+ else
+ endif
+(where the complicated condition causes assignment to an auxiliary
+variable, e.g., max(a*b,c)).
+
+Mon Apr 30 13:30:10 EDT 1990:
+ Change fillers for DATA with holes from substructures to arrays
+(in an attempt to make things work right with C compilers that have
+funny padding rules for substructures, e.g., Sun C compilers).
+ Minor cleanup of exec.c (should not affect generated C).
+
+Mon Apr 30 23:13:51 EDT 1990:
+ Fix bug in handling return values of functions having multiple
+entry points of differing return types.
+
+Sat May 5 01:45:18 EDT 1990:
+ Fix type inference bug in
+ subroutine foo(x)
+ call goo(x)
+ end
+ subroutine goo(i)
+ i = 3
+ end
+Instead of warning of inconsistent calling sequences for goo,
+f2c was simply making i a real variable; now i is correctly
+typed as an integer variable, and f2c issues an error message.
+ Adjust error messages issued at end of declarations so they
+don't blame the first executable statement.
+
+Sun May 6 01:29:07 EDT 1990:
+ Fix bug in -P and -Ps: warn when the definition of a subprogram adds
+information that would change prototypes or previous declarations.
+
+Thu May 10 18:09:15 EDT 1990:
+ Fix further obscure bug with (default) -it: inconsistent calling
+sequences and I/O statements could interact to cause a memory fault.
+Example:
+ SUBROUTINE FOO
+ CALL GOO(' Something') ! Forgot integer first arg
+ END
+ SUBROUTINE GOO(IUNIT,MSG)
+ CHARACTER*(*)MSG
+ WRITE(IUNIT,'(1X,A)') MSG
+ END
+
+Fri May 11 16:49:11 EDT 1990:
+ Under -!c, do not delete any .c files (when there are errors).
+ Avoid dereferencing 0 when a fatal error occurs while reading
+Fortran on stdin.
+
+Wed May 16 18:24:42 EDT 1990:
+ f2c.ps made available.
+
+Mon Jun 4 12:53:08 EDT 1990:
+ Diagnose I/O units of invalid type.
+ Add specific error msg about dummy arguments in common.
+
+Wed Jun 13 12:43:17 EDT 1990:
+ Under -A, supply a missing "[1]" for CHARACTER*1 variables that appear
+both in a DATA statement and in either COMMON or EQUIVALENCE.
+
+Mon Jun 18 16:58:31 EDT 1990:
+ Trivial updates to f2c.ps . ("Fortran 8x" --> "Fortran 90"; omit
+"(draft)" from "(draft) ANSI C".)
+
+Tue Jun 19 07:36:32 EDT 1990:
+ Fix incorrect code generated for ELSE IF(expression involving
+function call passing non-constant substring).
+ Under -h, preserve the property that strings are null-terminated
+where possible.
+ Remove spaces between # and define in lex.c output.c parse.h .
+
+Mon Jun 25 07:22:59 EDT 1990:
+ Minor tweak to makefile to reduce unnecessary recompilations.
+
+Tue Jun 26 11:49:53 EDT 1990:
+ Fix unintended truncation of some integer constants on machines
+where casting a long to (int) may change the value. E.g., when f2c
+ran on machines with 16-bit ints, "i = 99999" was being translated
+to "i = -31073;".
+
+Wed Jun 27 11:05:32 EDT 1990:
+ Arrange for CHARACTER-valued PARAMETERs to honor their length
+specifications. Allow CHAR(nn) in expressions defining such PARAMETERs.
+
+Fri Jul 20 09:17:30 EDT 1990:
+ Avoid dereferencing 0 when a FORMAT statement has no label.
+
+Thu Jul 26 11:09:39 EDT 1990:
+ Remarks about VOID and binread,binwrite added to README.
+ Tweaks to parse_args: should be invisible unless your compiler
+complained at (short)*store.
+
+Thu Aug 2 02:07:58 EDT 1990:
+ f2c.ps: change the first line of page 5 from
+ include stuff
+to
+ include 'stuff'
+
+Tue Aug 14 13:21:24 EDT 1990:
+ libi77: libI77 adjusted to treat tabs as spaces in list input.
+
+Fri Aug 17 07:24:53 EDT 1990:
+ libi77: libI77 adjusted so a blank='ZERO' clause (upper case Z)
+in an open of a currently open file works right.
+
+Tue Aug 28 01:56:44 EDT 1990:
+ Fix bug in warnings of inconsistent calling sequences: if an
+argument to a subprogram was never referenced, then a previous
+invocation of the subprogram (in the same source file) that
+passed something of the wrong type for that argument did not
+elicit a warning message.
+
+Thu Aug 30 09:46:12 EDT 1990:
+ libi77: prevent embedded blanks in list output of complex values;
+omit exponent field in list output of values of magnitude between
+10 and 1e8; prevent writing stdin and reading stdout or stderr;
+don't close stdin, stdout, or stderr when reopening units 5, 6, 0.
+
+Tue Sep 4 12:30:57 EDT 1990:
+ Fix bug in C emitted under -I2 or -i2 for INTEGER*4 FUNCTION.
+ Warn of missing final END even if there are previous errors.
+
+Fri Sep 7 13:55:34 EDT 1990:
+ Remark about "make xsum.out" and "make f2c" added to README.
+
+Tue Sep 18 23:50:01 EDT 1990:
+ Fix null dereference (and, on some systems, writing of bogus *_com.c
+files) under -ec or -e1c when a prototype file (*.p or *.P) describes
+COMMON blocks that do not appear in the Fortran source.
+ libi77:
+ Add some #ifdef lines (#ifdef MSDOS, #ifndef MSDOS) to avoid
+references to stat and fstat on non-UNIX systems.
+ On UNIX systems, add component udev to unit; decide that old
+and new files are the same iff both the uinode and udev components
+of unit agree.
+ When an open stmt specifies STATUS='OLD', use stat rather than
+access (on UNIX systems) to check the existence of the file (in case
+directories leading to the file have funny permissions and this is
+a setuid or setgid program).
+
+Thu Sep 27 16:04:09 EDT 1990:
+ Supply missing entry for Impldoblock in blksize array of cpexpr
+(in expr.c). No examples are known where this omission caused trouble.
+
+Tue Oct 2 22:58:09 EDT 1990:
+ libf77: test signal(...) == SIG_IGN rather than & 01 in main().
+ libi77: adjust rewind.c so two successive rewinds after a write
+don't clobber the file.
+
+Thu Oct 11 18:00:14 EDT 1990:
+ libi77: minor cleanups: add #include "fcntl.h" to endfile.c, err.c,
+open.c; adjust g_char in util.c for segmented memories; in f_inqu
+(inquire.c), define x appropriately when MSDOS is defined.
+
+Mon Oct 15 20:02:11 EDT 1990:
+ Add #ifdef MSDOS pointer adjustments to mem.c; treat NAME= as a
+synonym for FILE= in OPEN statements.
+
+Wed Oct 17 16:40:37 EDT 1990:
+ libf77, libi77: minor cleanups: _cleanup() and abort() invocations
+replaced by invocations of sig_die in main.c; some error messages
+previously lost in buffers will now appear.
+
+Mon Oct 22 16:11:27 EDT 1990:
+ libf77: separate sig_die from main (for folks who don't want to use
+the main in libF77).
+ libi77: minor tweak to comments in README.
+
+Fri Nov 2 13:49:35 EST 1990:
+ Use two underscores rather than one in generated temporary variable
+names to avoid conflict with COMMON names. f2c.ps updated to reflect
+this change and the NAME= extension introduced 15 Oct.
+ Repair a rare memory fault in io.c .
+
+Mon Nov 5 16:43:55 EST 1990:
+ libi77: changes to open.c (and err.c): complain if an open stmt
+specifies new= and the file already exists (as specified by Fortrans 77
+and 90); allow file= to be omitted in open stmts and allow
+status='replace' (Fortran 90 extensions).
+
+Fri Nov 30 10:10:14 EST 1990:
+ Adjust malloc.c for unusual systems whose sbrk() can return values
+not properly aligned for doubles.
+ Arrange for slightly more helpful and less repetitive warnings for
+non-character variables initialized with character data; these warnings
+are (still) suppressed by -w66.
+
+Fri Nov 30 15:57:59 EST 1990:
+ Minor tweak to README (about changing VOID in f2c.h).
+
+Mon Dec 3 07:36:20 EST 1990:
+ Fix spelling of "character" in f2c.1t.
+
+Tue Dec 4 09:48:56 EST 1990:
+ Remark about link_msg and libf2c added to f2c/README.
+
+Thu Dec 6 08:33:24 EST 1990:
+ Under -U, render label nnn as L_nnn rather than Lnnn.
+
+Fri Dec 7 18:05:00 EST 1990:
+ Add more names from f2c.h (e.g. integer, real) to the c_keywords
+list of names to which an underscore is appended to avoid confusion.
+
+Mon Dec 10 19:11:15 EST 1990:
+ Minor tweaks to makefile (./xsum) and README (binread/binwrite).
+ libi77: a few modifications for POSIX systems; meant to be invisible
+elsewhere.
+
+Sun Dec 16 23:03:16 EST 1990:
+ Fix null dereference caused by unusual erroneous input, e.g.
+ call foo('abc')
+ end
+ subroutine foo(msg)
+ data n/3/
+ character*(*) msg
+ end
+(Subroutine foo is illegal because the character statement comes after a
+data statement.)
+ Use decimal rather than hex constants in xsum.c (to prevent
+erroneous warning messages about constant overflow).
+
+Mon Dec 17 12:26:40 EST 1990:
+ Fix rare extra underscore in character length parameters passed
+for multiple entry points.
+
+Wed Dec 19 17:19:26 EST 1990:
+ Allow generation of C despite error messages about bad alignment
+forced by equivalence.
+ Allow variable-length concatenations in I/O statements, such as
+ open(3, file=bletch(1:n) // '.xyz')
+
+Fri Dec 28 17:08:30 EST 1990:
+ Fix bug under -p with formats and internal I/O "units" in COMMON,
+as in
+ COMMON /FIGLEA/F
+ CHARACTER*20 F
+ F = '(A)'
+ WRITE (*,FMT=F) 'Hello, world!'
+ END
+
+Tue Jan 15 12:00:24 EST 1991:
+ Fix bug when two equivalence groups are merged, the second with
+nonzero offset, and the result is then merged into a common block.
+Example:
+ INTEGER W(3), X(3), Y(3), Z(3)
+ COMMON /ZOT/ Z
+ EQUIVALENCE (W(1),X(1)), (X(2),Y(1)), (Z(3),X(1))
+***** W WAS GIVEN THE WRONG OFFSET
+ Recognize Fortran 90's optional NML= in NAMELIST READs and WRITEs.
+(Currently NML= and FMT= are treated as synonyms -- there's no
+error message if, e.g., NML= specifies a format.)
+ libi77: minor adjustment to allow internal READs from character
+string constants in read-only memory.
+
+Fri Jan 18 22:56:15 EST 1991:
+ Add comment to README about needing to comment out the typedef of
+size_t in sysdep.h on some systems, e.g. Sun 4.1.
+ Fix misspelling of "statement" in an error message in lex.c
+
+Wed Jan 23 00:38:48 EST 1991:
+ Allow hex, octal, and binary constants to have the qualifying letter
+(z, x, o, or b) either before or after the quoted string containing the
+digits. For now this change will not be reflected in f2c.ps .
+
+Tue Jan 29 16:23:45 EST 1991:
+ Arrange for character-valued statement functions to give results of
+the right length (that of the statement function's name).
+
+Wed Jan 30 07:05:32 EST 1991:
+ More tweaks for character-valued statement functions: an error
+check and an adjustment so a right-hand side of nonconstant length
+(e.g., a substring) is handled right.
+
+Wed Jan 30 09:49:36 EST 1991:
+ Fix p1_head to avoid printing (char *)0 with %s.
+
+Thu Jan 31 13:53:44 EST 1991:
+ Add a test after the cleanup call generated for I/O statements with
+ERR= or END= clauses to catch the unlikely event that the cleanup
+routine encounters an error.
+
+Mon Feb 4 08:00:58 EST 1991:
+ Minor cleanup: omit unneeded jumps and labels from code generated for
+some NAMELIST READs and WRITEs with IOSTAT=, ERR=, and/or END=.
+
+Tue Feb 5 01:39:36 EST 1991:
+ Change Mktemp to mktmp (for the benefit of systems so brain-damaged
+that they do not distinguish case in external names -- and that for
+some reason want to load mktemp). Try to get xsum0.out right this
+time (it somehow didn't get updated on 4 Feb. 1991).
+ Add note to libi77/README about adjusting the interpretation of
+RECL= specifiers in OPENs for direct unformatted I/O.
+
+Thu Feb 7 17:24:42 EST 1991:
+ New option -r casts values of REAL functions, including intrinsics,
+to REAL. This only matters for unportable code like
+ real r
+ r = asin(1.)
+ if (r .eq. asin(1.)) ...
+[The behavior of such code varies with the Fortran compiler used --
+and sometimes is affected by compiler options.] For now, the man page
+at the end of f2c.ps is the only part of f2c.ps that reflects this new
+option.
+
+Fri Feb 8 18:12:51 EST 1991:
+ Cast pointer differences passed as arguments to the appropriate type.
+This matters, e.g., with MSDOS compilers that yield a long pointer
+difference but have int == short.
+ Disallow nonpositive dimensions.
+
+Fri Feb 15 12:24:15 EST 1991:
+ Change %d to %ld in sprintf call in putpower in putpcc.c.
+ Free more memory (e.g. allowing translation of larger Fortran
+files under MS-DOS).
+ Recognize READ (character expression) and WRITE (character expression)
+as formatted I/O with the format given by the character expression.
+ Update year in Notice.
+
+Sat Feb 16 00:42:32 EST 1991:
+ Recant recognizing WRITE(character expression) as formatted output
+-- Fortran 77 is not symmetric in its syntax for READ and WRITE.
+
+Mon Mar 4 15:19:42 EST 1991:
+ Fix bug in passing the real part of a complex argument to an intrinsic
+function. Omit unneeded parentheses in nested calls to intrinsics.
+Example:
+ subroutine foo(x, y)
+ complex y
+ x = exp(sin(real(y))) + exp(imag(y))
+ end
+
+Fri Mar 8 15:05:42 EST 1991:
+ Fix a comment in expr.c; omit safstrncpy.c (which had bugs in
+cases not used by f2c).
+
+Wed Mar 13 02:27:23 EST 1991:
+ Initialize firstmemblock->next in mem_init in mem.c . [On most
+systems it was fortuituously 0, but with System V, -lmalloc could
+trip on this missed initialization.]
+
+Wed Mar 13 11:47:42 EST 1991:
+ Fix a reference to freed memory.
+
+Wed Mar 27 00:42:19 EST 1991:
+ Fix a memory fault caused by such illegal Fortran as
+ function foo
+ x = 3
+ logical foo ! declaration among executables
+ foo=.false. ! used to suffer memory fault
+ end
+
+Fri Apr 5 08:30:31 EST 1991:
+ Fix loss of % in some format expressions, e.g.
+ write(*,'(1h%)')
+ Fix botch introduced 27 March 1991 that caused subroutines with
+multiple entry points to have extraneous declarations of ret_val.
+
+Fri Apr 5 12:44:02 EST 1991
+ Try again to omit extraneous ret_val declarations -- this morning's
+fix was sometimes wrong.
+
+Mon Apr 8 13:47:06 EDT 1991:
+ Arrange for s_rnge to have the right prototype under -A -C .
+
+Wed Apr 17 13:36:03 EDT 1991:
+ New fatal error message for apparent invocation of a recursive
+statement function.
+
+Thu Apr 25 15:13:37 EDT 1991:
+ F2c and libi77 adjusted so NAMELIST works with -i2. (I forgot
+about -i2 when adding NAMELIST.) This required a change to f2c.h
+(that only affects NAMELIST I/O under -i2.) Man-page description of
+-i2 adjusted to reflect that -i2 stores array lengths in short ints.
+
+Fri Apr 26 02:54:41 EDT 1991:
+ Libi77: fix some bugs in NAMELIST reading of multi-dimensional arrays
+(file rsne.c).
+
+Thu May 9 02:13:51 EDT 1991:
+ Omit a trailing space in expr.c (could cause a false xsum value if
+a mailer drops the trailing blank).
+
+Thu May 16 13:14:59 EDT 1991:
+ Libi77: increase LEFBL in lio.h to overcome a NeXT bug.
+ Tweak for compilers that recognize "nested" comments: inside comments,
+turn /* into /+ (as well as */ into +/).
+
+Sat May 25 11:44:25 EDT 1991:
+ libf77: s_rnge: declare line long int rather than int.
+
+Fri May 31 07:51:50 EDT 1991:
+ libf77: system_: officially return status.
+
+Mon Jun 17 16:52:53 EDT 1991:
+ Minor tweaks: omit unnecessary declaration of strcmp (that caused
+trouble on a system where strcmp was a macro) from misc.c; add
+SHELL = /bin/sh to makefiles.
+ Fix a dereference of null when a CHARACTER*(*) declaration appears
+(illegally) after DATA. Complain only once per subroutine about
+declarations appearing after DATA.
+
+Mon Jul 1 00:28:13 EDT 1991:
+ Add test and error message for illegal use of subroutine names, e.g.
+ SUBROUTINE ZAP(A)
+ ZAP = A
+ END
+
+Mon Jul 8 21:49:20 EDT 1991:
+ Issue a warning about things like
+ integer i
+ i = 'abc'
+(which is treated as i = ichar('a')). [It might be nice to treat 'abc'
+as an integer initialized (in a DATA statement) with 'abc', but
+other matters have higher priority.]
+ Render
+ i = ichar('A')
+as
+ i = 'A';
+rather than
+ i = 65;
+(which assumes ASCII).
+
+Fri Jul 12 07:41:30 EDT 1991:
+ Note added to README about erroneous definitions of __STDC__ .
+
+Sat Jul 13 13:38:54 EDT 1991:
+ Fix bugs in double type convesions of complex values, e.g.
+sngl(real(...)) or dble(real(...)) (where ... is complex).
+
+Mon Jul 15 13:21:42 EDT 1991:
+ Fix bug introduced 8 July 1991 that caused erroneous warnings
+"ichar([first char. of] char. string) assumed for conversion to numeric"
+when a subroutine had an array of character strings as an argument.
+
+Wed Aug 28 01:12:17 EDT 1991:
+ Omit an unused function in format.c, an unused variable in proc.c .
+ Under -r8, promote complex to double complex (as the man page claims).
+
+Fri Aug 30 17:19:17 EDT 1991:
+ f2c.ps updated: slightly expand description of intrinsics and,or,xor,
+not; add mention of intrinsics lshift, rshift; add note about f2c
+accepting Fortran 90 inline comments (starting with !); update Cobalt
+Blue address.
+
+Tue Sep 17 07:17:33 EDT 1991:
+ libI77: err.c and open.c modified to use modes "rb" and "wb"
+when (f)opening unformatted files; README updated to point out
+that it may be necessary to change these modes to "r" and "w"
+on some non-ANSI systems.
+
+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.
--- /dev/null
+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
--- /dev/null
+/****************************************************************
+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.
+****************************************************************/
+
--- /dev/null
+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 <strings.h>
+you may need to add " -Dstrchr=index" to the "CFLAGS =" assignment
+in the makefile, and you may need to add " memset.o" to the "OBJECTS ="
+assignment in the makefile -- see the comments in memset.c .
+
+For non-UNIX systems, you may need to change some things in sysdep.c,
+such as the choice of intermediate file names.
+
+On some systems, you may need to modify parts of sysdep.h (which is
+included by defs.h). In particular, for Sun 4.1 systems and perhaps
+some others, you need to comment out the typedef of size_t.
+
+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.
--- /dev/null
+/****************************************************************
+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;
+ }
--- /dev/null
+/****************************************************************
+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;
+ }
+ }
--- /dev/null
+#define PDP11 4
+
+#define BIGGEST_SHORT 0x7fff /* Assumes 32-bit arithmetic */
+#define BIGGEST_LONG 0x7fffffff /* Assumes 32-bit arithmetic */
+
+#define M(x) (1<<x) /* Mask (x) returns 2^x */
+
+#define ALLOC(x) (struct x *) ckalloc(sizeof(struct x))
+#define ALLEXPR (expptr) ckalloc( sizeof(union Expression) )
+typedef int *ptr;
+typedef char *charptr;
+typedef FILE *FILEP;
+typedef int flag;
+typedef char field; /* actually need only 4 bits */
+typedef long int ftnint;
+#define LOCAL static
+
+#define NO 0
+#define YES 1
+
+#define CNULL (char *) 0 /* Character string null */
+#define PNULL (ptr) 0
+#define CHNULL (chainp) 0 /* Chain null */
+#define ENULL (expptr) 0
+
+
+/* BAD_MEMNO - used to distinguish between long string constants and other
+ constants in the table */
+
+#define BAD_MEMNO -32768
+
+
+/* block tag values -- syntactic stuff */
+
+#define TNAME 1
+#define TCONST 2
+#define TEXPR 3
+#define TADDR 4
+#define TPRIM 5 /* Primitive datum - should not appear in an
+ expptr variable, it should have already been
+ identified */
+#define TLIST 6
+#define TIMPLDO 7
+#define TERROR 8
+
+
+/* parser states - order is important, since there are several tests for
+ state < INDATA */
+
+#define OUTSIDE 0
+#define INSIDE 1
+#define INDCL 2
+#define INDATA 3
+#define INEXEC 4
+
+/* procedure classes */
+
+#define PROCMAIN 1
+#define PROCBLOCK 2
+#define PROCSUBR 3
+#define PROCFUNCT 4
+
+
+/* storage classes -- vstg values. BSS and INIT are used in the later
+ merge pass over identifiers; and they are entered differently into the
+ symbol table */
+
+#define STGUNKNOWN 0
+#define STGARG 1 /* adjustable dimensions */
+#define STGAUTO 2 /* for stack references */
+#define STGBSS 3 /* uninitialized storage (normal variables) */
+#define STGINIT 4 /* initialized storage */
+#define STGCONST 5
+#define STGEXT 6 /* external storage */
+#define STGINTR 7 /* intrinsic (late decision) reference. See
+ chapter 5 of the Fortran 77 standard */
+#define STGSTFUNCT 8
+#define STGCOMMON 9
+#define STGEQUIV 10
+#define STGREG 11 /* register - the outermost DO loop index will be
+ in a register (because the compiler is one
+ pass, it can't know where the innermost loop is
+ */
+#define STGLENG 12
+#define STGNULL 13
+#define STGMEMNO 14 /* interemediate-file pointer to constant table */
+
+/* name classes -- vclass values, also procclass values */
+
+#define CLUNKNOWN 0
+#define CLPARAM 1 /* Parameter - macro definition */
+#define CLVAR 2 /* variable */
+#define CLENTRY 3
+#define CLMAIN 4
+#define CLBLOCK 5
+#define CLPROC 6
+#define CLNAMELIST 7 /* in data with this tag, the vdcldone flag should
+ be ignored (according to vardcl()) */
+
+
+/* vprocclass values -- there is some overlap with the vclass values given
+ above */
+
+#define PUNKNOWN 0
+#define PEXTERNAL 1
+#define PINTRINSIC 2
+#define PSTFUNCT 3
+#define PTHISPROC 4 /* here to allow recursion - further distinction
+ is given in the CL tag (those just above).
+ This applies to the presence of the name of a
+ function used within itself. The function name
+ means either call the function again, or assign
+ some value to the storage allocated to the
+ function's return value. */
+
+/* control stack codes - these are part of a state machine which handles
+ the nesting of blocks (i.e. what to do about the ELSE statement) */
+
+#define CTLDO 1
+#define CTLIF 2
+#define CTLELSE 3
+#define CTLIFX 4
+
+
+/* operators for both Fortran input and C output. They are common because
+ so many are shared between the trees */
+
+#define OPPLUS 1
+#define OPMINUS 2
+#define OPSTAR 3
+#define OPSLASH 4
+#define OPPOWER 5
+#define OPNEG 6
+#define OPOR 7
+#define OPAND 8
+#define OPEQV 9
+#define OPNEQV 10
+#define OPNOT 11
+#define OPCONCAT 12
+#define OPLT 13
+#define OPEQ 14
+#define OPGT 15
+#define OPLE 16
+#define OPNE 17
+#define OPGE 18
+#define OPCALL 19
+#define OPCCALL 20
+#define OPASSIGN 21
+#define OPPLUSEQ 22
+#define OPSTAREQ 23
+#define OPCONV 24
+#define OPLSHIFT 25
+#define OPMOD 26
+#define OPCOMMA 27
+#define OPQUEST 28
+#define OPCOLON 29
+#define OPABS 30
+#define OPMIN 31
+#define OPMAX 32
+#define OPADDR 33
+#define OPCOMMA_ARG 34
+#define OPBITOR 35
+#define OPBITAND 36
+#define OPBITXOR 37
+#define OPBITNOT 38
+#define OPRSHIFT 39
+#define OPWHATSIN 40 /* dereferencing operator */
+#define OPMINUSEQ 41 /* assignment operators */
+#define OPSLASHEQ 42
+#define OPMODEQ 43
+#define OPLSHIFTEQ 44
+#define OPRSHIFTEQ 45
+#define OPBITANDEQ 46
+#define OPBITXOREQ 47
+#define OPBITOREQ 48
+#define OPPREINC 49 /* Preincrement (++x) operator */
+#define OPPREDEC 50 /* Predecrement (--x) operator */
+#define OPDOT 51 /* structure field reference */
+#define OPARROW 52 /* structure pointer field reference */
+#define OPNEG1 53 /* simple negation under forcedouble */
+#define OPDMIN 54 /* min(a,b) macro under forcedouble */
+#define OPDMAX 55 /* max(a,b) macro under forcedouble */
+#define OPASSIGNI 56 /* assignment for inquire stmt */
+#define OPIDENTITY 57 /* for turning TADDR into TEXPR */
+#define OPCHARCAST 58 /* for casting to char * (in I/O stmts) */
+#define OPDABS 59 /* abs macro under forcedouble */
+#define OPMIN2 60 /* min(a,b) macro */
+#define OPMAX2 61 /* max(a,b) macro */
+
+/* label type codes -- used with the ASSIGN statement */
+
+#define LABUNKNOWN 0
+#define LABEXEC 1
+#define LABFORMAT 2
+#define LABOTHER 3
+
+
+/* INTRINSIC function codes*/
+
+#define INTREND 0
+#define INTRCONV 1
+#define INTRMIN 2
+#define INTRMAX 3
+#define INTRGEN 4 /* General intrinsic, e.g. cos v. dcos, zcos, ccos */
+#define INTRSPEC 5
+#define INTRBOOL 6
+#define INTRCNST 7 /* constants, e.g. bigint(1.0) v. bigint (1d0) */
+
+
+/* I/O statement codes - these all form Integer Constants, and are always
+ reevaluated */
+
+#define IOSTDIN ICON(5)
+#define IOSTDOUT ICON(6)
+#define IOSTDERR ICON(0)
+
+#define IOSBAD (-1)
+#define IOSPOSITIONAL 0
+#define IOSUNIT 1
+#define IOSFMT 2
+
+#define IOINQUIRE 1
+#define IOOPEN 2
+#define IOCLOSE 3
+#define IOREWIND 4
+#define IOBACKSPACE 5
+#define IOENDFILE 6
+#define IOREAD 7
+#define IOWRITE 8
+
+
+/* User name tags -- these identify the form of the original identifier
+ stored in a struct Addrblock structure (in the user field). */
+
+#define UNAM_UNKNOWN 0 /* Not specified */
+#define UNAM_NAME 1 /* Local symbol, store in the hash table */
+#define UNAM_IDENT 2 /* Character string not stored elsewhere */
+#define UNAM_EXTERN 3 /* External reference; check symbol table
+ using memno as index */
+#define UNAM_CONST 4 /* Constant value */
+#define UNAM_CHARP 5 /* pointer to string */
+
+
+#define IDENT_LEN 31 /* Maximum length user.ident */
+
+/* type masks - TYLOGICAL defined in ftypes */
+
+#define MSKLOGICAL M(TYLOGICAL)
+#define MSKADDR M(TYADDR)
+#define MSKCHAR M(TYCHAR)
+#define MSKINT M(TYSHORT)|M(TYLONG)
+#define MSKREAL M(TYREAL)|M(TYDREAL) /* DREAL means Double Real */
+#define MSKCOMPLEX M(TYCOMPLEX)|M(TYDCOMPLEX)
+#define MSKSTATIC (M(STGINIT)|M(STGBSS)|M(STGCOMMON)|M(STGEQUIV)|M(STGCONST))
+
+/* miscellaneous macros */
+
+/* ONEOF (x, y) -- x is the number of one of the OR'ed masks in y (i.e., x is
+ the log of one of the OR'ed masks in y) */
+
+#define ONEOF(x,y) (M(x) & (y))
+#define ISCOMPLEX(z) ONEOF(z, MSKCOMPLEX)
+#define ISREAL(z) ONEOF(z, MSKREAL)
+#define ISNUMERIC(z) ONEOF(z, MSKINT|MSKREAL|MSKCOMPLEX)
+#define ISICON(z) (z->tag==TCONST && ISINT(z->constblock.vtype))
+
+/* 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) )
--- /dev/null
+/****************************************************************
+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 <something> from going negative */
+extern int nintnames;
+
+/* Chain of tagged blocks */
+
+struct Chain
+ {
+ chainp nextp;
+ char * datap; /* Tagged block */
+ };
+
+extern chainp chains;
+
+/* Recall that field is intended to hold four-bit characters */
+
+/* This structure exists only to defeat the type checking */
+
+struct Headblock
+ {
+ field tag;
+ field vtype;
+ field vclass;
+ field vstg;
+ expptr vleng; /* Expression for length of char string -
+ this may be a constant, or an argument
+ generated by mkarg() */
+ } ;
+
+/* Control construct info (for do loops, else, etc) */
+
+struct Ctlframe
+ {
+ unsigned ctltype:8;
+ unsigned dostepsign:8; /* 0 - variable, 1 - pos, 2 - neg */
+ unsigned dowhile:1;
+ int ctlabels[4]; /* Control labels, defined below */
+ int dolabel; /* label marking end of this DO loop */
+ Namep donamep; /* DO index variable */
+ expptr 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 <x 1>, <y 2>, <z 3> AT THE INVOCATION, NOT
+ at the definition */
+
+struct Rplblock /* name replacement block */
+ {
+ struct Rplblock *rplnextp;
+ Namep rplnp; /* Name of the formal parameter */
+ expptr rplvp; /* Value of the actual parameter */
+ expptr rplxp; /* Initialization of temporary variable,
+ if required; else null */
+ int rpltag; /* Tag on the value of the actual param */
+ };
+
+
+
+/* Equivalence block */
+
+struct Equivblock
+ {
+ struct Eqvchain *equivs; /* List (Eqvchain) of primblocks
+ holding variable identifiers */
+ flag eqvinit;
+ long 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;
--- /dev/null
+/****************************************************************
+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);
+}
--- /dev/null
+/****************************************************************
+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;
+}
--- /dev/null
+/****************************************************************
+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 */
+}
--- /dev/null
+/****************************************************************
+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;
+ }
+}
--- /dev/null
+
+ 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)
+
--- /dev/null
+. \" 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 .
--- /dev/null
+. \" 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 .
--- /dev/null
+/* 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
--- /dev/null
+/****************************************************************
+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);
+ }
+ }
--- /dev/null
+#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 ();
--- /dev/null
+/****************************************************************
+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);
+ }
--- /dev/null
+
+/* 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? */
+
--- /dev/null
+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);
+ }
+ }
+ ;
--- /dev/null
+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(nstars<MAXLABLIST) labarray[nstars++] = $2; $$ = 0; }
+ ;
+
+stop: SPAUSE
+ { $$ = 0; }
+ | SSTOP
+ { $$ = 1; }
+ ;
+
+exprlist: expr
+ { $$ = mkchain((char *)$1, CHNULL); }
+ | exprlist SCOMMA expr
+ { $$ = hookup($1, mkchain((char *)$3,CHNULL) ); }
+ ;
+
+end_spec:
+ { if(parstate == OUTSIDE)
+ {
+ newproc();
+ startproc(ESNULL, CLMAIN);
+ }
+
+/* This next statement depends on the ordering of the state table encoding */
+
+ if(parstate < INDATA) enddcl();
+ }
+ ;
+
+intonlyon:
+ { intonly = YES; }
+ ;
+
+intonlyoff:
+ { intonly = NO; }
+ ;
--- /dev/null
+funarglist:
+ { $$ = 0; }
+ | funargs
+ { $$ = revchain($1); }
+ ;
+
+funargs: expr
+ { $$ = mkchain((char *)$1, CHNULL); }
+ | funargs SCOMMA expr
+ { $$ = mkchain((char *)$3, $1); }
+ ;
+
+
+expr: uexpr
+ | SLPAR expr SRPAR { $$ = $2; }
+ | complex_const
+ ;
+
+uexpr: lhs
+ | simple_const
+ | expr addop expr %prec SPLUS
+ { $$ = mkexpr($2, $1, $3); }
+ | expr SSTAR expr
+ { $$ = mkexpr(OPSTAR, $1, $3); }
+ | expr SSLASH expr
+ { $$ = mkexpr(OPSLASH, $1, $3); }
+ | expr SPOWER expr
+ { $$ = mkexpr(OPPOWER, $1, $3); }
+ | addop expr %prec SSTAR
+ { if($1 == OPMINUS)
+ $$ = mkexpr(OPNEG, $2, ENULL);
+ else $$ = $2;
+ }
+ | expr relop expr %prec SEQ
+ { $$ = mkexpr($2, $1, $3); }
+ | expr SEQV expr
+ { NO66(".EQV. operator");
+ $$ = mkexpr(OPEQV, $1,$3); }
+ | expr SNEQV expr
+ { NO66(".NEQV. operator");
+ $$ = mkexpr(OPNEQV, $1, $3); }
+ | expr SOR expr
+ { $$ = mkexpr(OPOR, $1, $3); }
+ | expr SAND expr
+ { $$ = mkexpr(OPAND, $1, $3); }
+ | SNOT expr
+ { $$ = mkexpr(OPNOT, $2, ENULL); }
+ | expr SCONCAT expr
+ { NO66("concatenation operator //");
+ $$ = mkexpr(OPCONCAT, $1, $3); }
+ ;
+
+addop: SPLUS { $$ = OPPLUS; }
+ | SMINUS { $$ = OPMINUS; }
+ ;
+
+relop: SEQ { $$ = OPEQ; }
+ | SGT { $$ = OPGT; }
+ | SLT { $$ = OPLT; }
+ | SGE { $$ = OPGE; }
+ | SLE { $$ = OPLE; }
+ | SNE { $$ = OPNE; }
+ ;
+
+lhs: name
+ { $$ = mkprim($1, LBNULL, CHNULL); }
+ | name substring
+ { NO66("substring operator :");
+ $$ = mkprim($1, LBNULL, $2); }
+ | name SLPAR funarglist SRPAR
+ { $$ = mkprim($1, mklist($3), CHNULL); }
+ | name SLPAR funarglist SRPAR substring
+ { NO66("substring operator :");
+ $$ = mkprim($1, mklist($3), $5); }
+ ;
+
+substring: SLPAR opt_expr SCOLON opt_expr SRPAR
+ { $$ = mkchain((char *)$2, mkchain((char *)$4,CHNULL)); }
+ ;
+
+opt_expr:
+ { $$ = 0; }
+ | expr
+ ;
+
+simple: name
+ { if($1->vclass == CLPARAM)
+ $$ = (expptr) cpexpr(
+ ( (struct Paramblock *) ($1) ) -> paramval);
+ }
+ | simple_const
+ ;
+
+simple_const: STRUE { $$ = mklogcon(1); }
+ | SFALSE { $$ = mklogcon(0); }
+ | SHOLLERITH { $$ = mkstrcon(toklen, token); }
+ | SICON = { $$ = mkintcon( convci(toklen, token) ); }
+ | SRCON = { $$ = mkrealcon(tyreal, token); }
+ | SDCON = { $$ = mkrealcon(TYDREAL, token); }
+ | bit_const
+ ;
+
+complex_const: SLPAR uexpr SCOMMA uexpr SRPAR
+ { $$ = mkcxcon($2,$4); }
+ ;
+
+bit_const: SHEXCON
+ { NOEXT("hex constant");
+ $$ = mkbitcon(4, toklen, token); }
+ | SOCTCON
+ { NOEXT("octal constant");
+ $$ = mkbitcon(3, toklen, token); }
+ | SBITCON
+ { NOEXT("binary constant");
+ $$ = mkbitcon(1, toklen, token); }
+ ;
+
+fexpr: unpar_fexpr
+ | SLPAR fexpr SRPAR
+ { $$ = $2; }
+ ;
+
+unpar_fexpr: lhs
+ | simple_const
+ | fexpr addop fexpr %prec SPLUS
+ { $$ = mkexpr($2, $1, $3); }
+ | fexpr SSTAR fexpr
+ { $$ = mkexpr(OPSTAR, $1, $3); }
+ | fexpr SSLASH fexpr
+ { $$ = mkexpr(OPSLASH, $1, $3); }
+ | fexpr SPOWER fexpr
+ { $$ = mkexpr(OPPOWER, $1, $3); }
+ | addop fexpr %prec SSTAR
+ { if($1 == OPMINUS)
+ $$ = mkexpr(OPNEG, $2, ENULL);
+ else $$ = $2;
+ }
+ | fexpr SCONCAT fexpr
+ { NO66("concatenation operator //");
+ $$ = mkexpr(OPCONCAT, $1, $3); }
+ ;
--- /dev/null
+/****************************************************************
+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 <labval> thislabel label assignlabel
+%type <tagval> other inelt
+%type <ival> type typespec typename dcl letter addop relop stop nameeq
+%type <lval> lengspec
+%type <charpval> filename
+%type <chval> datavar datavarlist namelistlist funarglist funargs
+%type <chval> dospec dospecw
+%type <chval> callarglist arglist args exprlist inlist outlist out2 substring
+%type <namval> name arg call var
+%type <expval> lhs expr uexpr opt_expr fexpr unpar_fexpr
+%type <expval> ubound simple value callarg complex_const simple_const bit_const
+%type <extval> common comblock entryname progname
+%type <eqvval> equivlist
+
+%%
+
+program:
+ | program stat SEOS
+ ;
+
+stat: thislabel entry
+ {
+/* stat: is the nonterminal for Fortran statements */
+
+ lastwasbranch = NO; }
+ | thislabel spec
+ | thislabel exec
+ { /* forbid further statement function definitions... */
+ if (parstate == INDATA && laststfcn != thisstno)
+ parstate = INEXEC;
+ thisstno++;
+ if($1 && ($1->labelno==dorange))
+ enddo($1->labelno);
+ if(lastwasbranch && thislabel==NULL)
+ warn("statement cannot be reached");
+ lastwasbranch = thiswasbranch;
+ thiswasbranch = NO;
+ if($1)
+ {
+ if($1->labtype == LABFORMAT)
+ err("label already that of a format");
+ else
+ $1->labtype = LABEXEC;
+ }
+ freetemps();
+ }
+ | thislabel SINCLUDE filename
+ { if (can_include)
+ doinclude( $3 );
+ else {
+ fprintf(diagfile, "Cannot open file %s\n", $3);
+ done(1);
+ }
+ }
+ | thislabel SEND end_spec
+ { if ($1)
+ lastwasbranch = NO;
+ endproc(); /* lastwasbranch = NO; -- set in endproc() */
+ }
+ | thislabel SUNKNOWN
+ { 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->blklevel<blklevel
+ && thislabel->labtype!=LABFORMAT)
+ warn1("there is a branch to label %s from outside block",
+ convic( (ftnint) (thislabel->stateno) ) );
+ thislabel->blklevel = blklevel;
+ thislabel->labdefined = YES;
+ if(thislabel->labtype != LABFORMAT)
+ p1_label((long)(thislabel - labeltab));
+ }
+ }
+ else $$ = thislabel = NULL;
+ }
+ ;
+
+entry: SPROGRAM new_proc progname
+ {startproc($3, CLMAIN); }
+ | SPROGRAM new_proc progname progarglist
+ { warn("ignoring arguments to main program");
+ /* hashclear(); */
+ startproc($3, CLMAIN); }
+ | SBLOCK new_proc progname
+ { if($3) NO66("named BLOCKDATA");
+ startproc($3, CLBLOCK); }
+ | SSUBROUTINE new_proc entryname arglist
+ { entrypt(CLPROC, TYSUBR, (ftnint) 0, $3, $4); }
+ | SFUNCTION new_proc entryname arglist
+ { entrypt(CLPROC, TYUNKNOWN, (ftnint) 0, $3, $4); }
+ | type SFUNCTION new_proc entryname arglist
+ { entrypt(CLPROC, $1, varleng, $4, $5); }
+ | SENTRY entryname arglist
+ { if(parstate==OUTSIDE || procclass==CLMAIN
+ || procclass==CLBLOCK)
+ execerr("misplaced entry statement", CNULL);
+ entrypt(CLENTRY, 0, (ftnint) 0, $2, $3);
+ }
+ ;
+
+new_proc:
+ { newproc(); }
+ ;
+
+entryname: name
+ { $$ = newentry($1, 1); }
+ ;
+
+name: SNAME
+ { $$ = mkname(token); }
+ ;
+
+progname: { $$ = NULL; }
+ | entryname
+ ;
+
+progarglist:
+ SLPAR SRPAR
+ | SLPAR progargs SRPAR
+ ;
+
+progargs: progarg
+ | progargs SCOMMA progarg
+ ;
+
+progarg: SNAME
+ | SNAME SEQUALS SNAME
+ ;
+
+arglist:
+ { $$ = 0; }
+ | SLPAR SRPAR
+ { NO66(" () argument list");
+ $$ = 0; }
+ | SLPAR args SRPAR
+ {$$ = $2; }
+ ;
+
+args: arg
+ { $$ = ($1 ? mkchain((char *)$1,CHNULL) : CHNULL ); }
+ | args SCOMMA arg
+ { if($3) $1 = $$ = mkchain((char *)$3, $1); }
+ ;
+
+arg: name
+ { if($1->vstg!=STGUNKNOWN && $1->vstg!=STGARG)
+ dclerr("name declared as argument after use", $1);
+ $1->vstg = STGARG;
+ }
+ | SSTAR
+ { NO66("altenate return argument");
+
+/* substars means that '*'ed formal parameters should be replaced.
+ This is used to specify alternate return labels; in theory, only
+ parameter slots which have '*' should accept the statement labels.
+ This compiler chooses to ignore the '*'s in the formal declaration, and
+ always return the proper value anyway.
+
+ This variable is only referred to in proc.c */
+
+ $$ = 0; substars = YES; }
+ ;
+
+
+
+filename: SHOLLERITH
+ {
+ char *s;
+ s = copyn(toklen+1, token);
+ s[toklen] = '\0';
+ $$ = s;
+ }
+ ;
--- /dev/null
+ /* 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(); }
+ ;
--- /dev/null
+/****************************************************************
+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[] = {
+ "<<unknown>>",
+ "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<NTYPES0 ; ++i)
+ rtvlabel[i] = 0;
+
+ if(undeftype)
+ setimpl(TYUNKNOWN, (ftnint) 0, 'a', 'z');
+ else
+ {
+ setimpl(tyreal, (ftnint) 0, 'a', 'z');
+ setimpl(tyint, (ftnint) 0, 'i', 'n');
+ }
+ setimpl(-STGBSS, (ftnint) 0, 'a', 'z'); /* set class */
+ setlog();
+}
+
+
+
+
+setimpl(type, length, c1, c2)
+int type;
+ftnint length;
+int c1, c2;
+{
+ int i;
+ char buff[100];
+
+ if(c1==0 || c2==0)
+ return;
+
+ if(c1 > c2) {
+ sprintf(buff, "characters out of order in implicit:%c-%c", c1, c2);
+ err(buff);
+ }
+ else {
+ c1 = letter(c1);
+ c2 = letter(c2);
+ if(type < 0)
+ for(i = c1 ; i<=c2 ; ++i)
+ implstg[i] = - type;
+ else {
+ type = lengtype(type, length);
+ if(type != TYCHAR)
+ length = 0;
+ for(i = c1 ; i<=c2 ; ++i) {
+ impltype[i] = type;
+ implleng[i] = length;
+ }
+ }
+ }
+ }
--- /dev/null
+/****************************************************************
+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 ; i<f2field ; ++i)
+ if(cstp->atype == mtype)
+ goto foundconst;
+ else
+ ++cstp;
+ goto badtype;
+
+foundconst:
+ switch(cstp->rtype)
+ {
+ case TYLONG:
+ return(mkintcon(intcon[cstp->constno]));
+
+ case TYREAL:
+ case TYDREAL:
+ return(mkrealcon(cstp->rtype,
+ realcon[cstp->constno]) );
+
+ default:
+ Fatal("impossible intrinsic constant");
+ }
+ }
+#endif
+
+ case INTRGEN:
+ sp = spectab + f3field;
+ if(no66flag)
+ if(sp->atype == mtype)
+ goto specfunct;
+ else err66("generic function");
+
+ for(i=0; i<f2field ; ++i)
+ if(sp->atype == mtype)
+ goto specfunct;
+ else
+ ++sp;
+ warn1 ("bad argument type to intrinsic %s", np->fvarname);
+
+/* Made this a warning rather than an error so things like "log (5) ==>
+ log (5.0)" can be accommodated. When none of these cases matches, the
+ argument is cast up to the first type in the spectab list; this first
+ type is assumed to be the "smallest" type, e.g. REAL before DREAL
+ before COMPLEX, before DCOMPLEX */
+
+ sp = spectab + f3field;
+ mtype = sp -> atype;
+ goto specfunct;
+
+ case INTRSPEC:
+ sp = spectab + f3field;
+specfunct:
+ if(tyint==TYLONG && ONEOF(sp->rtype,M(TYSHORT)|M(TYLOGICAL))
+ && (sp+1)->atype==sp->atype)
+ ++sp;
+
+ if(nargs != sp->nargs)
+ goto badnargs;
+ if(mtype != sp->atype)
+ goto badtype;
+
+/* NOTE!! I moved fixargs (YES) into the ELSE branch so that constants in
+ the inline expression wouldn't get put into the constant table */
+
+ fixargs (NO, argsp);
+ cast_args (mtype, argsp -> listp);
+
+ if(q = Inline((int)(sp-spectab), mtype, argsp->listp))
+ {
+ frchain( &(argsp->listp) );
+ free( (charptr) argsp);
+ } else {
+
+ if(sp->othername) {
+ /* C library routines that return double... */
+ /* sp->rtype might be TYREAL */
+ ap = builtin(sp->rtype,
+ callbyvalue[sp->othername], 1);
+ q = fixexpr((Exprp)
+ mkexpr(OPCCALL, (expptr)ap, (expptr)argsp) );
+ } else {
+ fixargs(YES, argsp);
+ ap = builtin(sp->rtype, sp->spxname, 0);
+ q = fixexpr((Exprp)
+ mkexpr(OPCALL, (expptr)ap, (expptr)argsp) );
+ } /* else */
+ } /* else */
+ return(q);
+
+ case INTRMIN:
+ case INTRMAX:
+ if(nargs < 2)
+ goto badnargs;
+ if( ! ONEOF(mtype, MSKINT|MSKREAL) )
+ goto badtype;
+ argsp->vtype = mtype;
+ q = mkexpr( (f1field==INTRMIN ? OPMIN : OPMAX), (expptr)argsp, ENULL);
+
+ q->headblock.vtype = mtype;
+ rettype = f2field;
+ if(rettype == TYLONG)
+ rettype = tyint;
+ else if(rettype == TYUNKNOWN)
+ rettype = mtype;
+ return( mkconv(rettype, q) );
+
+ default:
+ fatali("intrcall: bad intrgroup %d", f1field);
+ }
+badnargs:
+ errstr("bad number of arguments to intrinsic %s", np->fvarname);
+ goto bad;
+
+badtype:
+ errstr("bad argument type to intrinsic %s", np->fvarname);
+
+bad:
+ return( errnode() );
+}
+
+
+
+
+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);
+}
--- /dev/null
+/****************************************************************
+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);
+}
--- /dev/null
+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();
--- /dev/null
+/****************************************************************
+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<lastch &&
+ nextch[0]=='t' && nextch[1]=='o')
+ {
+ nextch+=2;
+ retval = STO;
+ break;
+ }
+ retval = gettok();
+ break;
+
+reteos:
+ case RETEOS:
+ lexstate = NEWSTMT;
+ retval = SEOS;
+ break;
+ default:
+ fatali("impossible lexstate %d", lexstate);
+ break;
+ }
+
+ if (retval == SEOF)
+ flush_comments ();
+
+ return retval;
+}
+
+/* Get Cards.
+
+ Returns STEOF or STINITIAL, never STCONTINUE. Any continuation cards get
+merged into one long card (hence the size of the buffer named sbuf) */
+
+ LOCAL int
+getcds()
+{
+ register char *p, *q;
+
+ flush_comments ();
+top:
+ if(nextcd == NULL)
+ {
+ code = getcd( nextcd = sbuf, 1 );
+ stno = nxtstno;
+ prevlin = thislin;
+ }
+ if(code == STEOF)
+ if( popinclude() )
+ goto top;
+ else
+ return(STEOF);
+
+ if(code == STCONTINUE)
+ {
+ lineno = thislin;
+ nextcd = NULL;
+ goto top;
+ }
+
+/* Get rid of unused space at the head of the buffer */
+
+ if(nextcd > sbuf)
+ {
+ q = nextcd;
+ p = sbuf;
+ while(q < endcd)
+ *p++ = *q++;
+ endcd = p;
+ }
+
+/* Be aware that the input (i.e. the string at the address nextcd) is NOT
+ NULL-terminated */
+
+/* This loop merges all continuations into one long statement, AND puts the next
+ card to be read at the end of the buffer (i.e. it stores the look-ahead card
+ when there's room) */
+
+ ncont = 0;
+ 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<aend && (c=getc(infile)) != '\n' && c!=EOF; )
+ if(c == '\t')
+
+/* The tab character translates into blank characters in the statement label */
+
+ {
+ atend = p;
+ while(p < aend)
+ *p++ = BLANK;
+ speclin = YES;
+ bend = send;
+ }
+ else
+ *p++ = c;
+ }
+
+/* By now we've read either a continuation character or the statement label
+ field */
+
+ if(c == EOF)
+ return(STEOF);
+
+/* The next 'if' block handles lines that have fewer than 7 characters */
+
+ if(c == '\n')
+ {
+ while(p < aend)
+ *p++ = BLANK;
+
+/* Blank out the buffer on lines which are not longer than 66 characters */
+
+ endcd0 = endcd;
+ if( ! speclin )
+ while(endcd < bend)
+ *endcd++ = BLANK;
+ }
+ else { /* read body of line */
+ while( endcd<bend && (c=getc(infile)) != '\n' && c!=EOF )
+ *endcd++ = c;
+ if(c == EOF)
+ return(STEOF);
+
+/* Drop any extra characters on the input card; this usually means those after
+ column 72 */
+
+ if(c != '\n')
+ {
+ while( (c=getc(infile)) != '\n')
+ if(c == EOF)
+ return(STEOF);
+ }
+
+ endcd0 = endcd;
+ if( ! speclin )
+ while(endcd < bend)
+ *endcd++ = BLANK;
+ }
+
+/* The flow of control usually gets to this line (unless an earlier RETURN has
+ been taken) */
+
+ ++thislin;
+
+ /* Fortran 77 specifies that a 0 in column 6 */
+ /* does not signify continuation */
+
+ if( !isspace(a[5]) && a[5]!='0') {
+ if (!amp)
+ for(p = a; p < aend;)
+ if (*p++ == '!' && p != aend)
+ goto initcheck;
+ if (addftnsrc && stb) {
+ if (stbend > stb + 7) { /* otherwise forget col 1-6 */
+ /* kludge around funny p1gets behavior */
+ *stb++ = '$';
+ if (amp)
+ *stb++ = '&';
+ else
+ for(p = a; p < atend;)
+ *stb++ = *p++;
+ }
+ if (endcd0 - b > stbend - stb) {
+ if (stb > stbend)
+ stb = stbend;
+ endcd0 = b + (stbend - stb);
+ }
+ for(p = b; p < endcd0;)
+ *stb++ = *p++;
+ *stb++ = '\n';
+ *stb = 0;
+ }
+ if (nocont) {
+ lineno = thislin;
+ errstr("illegal continuation card (starts \"%.6s\")",a);
+ }
+ else if (!amp && strncmp(a," ",5)) {
+ lineno = thislin;
+ errstr("labeled continuation line (starts \"%.6s\")",a);
+ }
+ return(STCONTINUE);
+ }
+initcheck:
+ for(p=a; p<atend; ++p)
+ if( !isspace(*p) ) {
+ if (*p++ != '!')
+ goto initline;
+ bang(p, atend, aend, b, endcd);
+ goto top;
+ }
+ for(p = b ; p<endcd ; ++p)
+ if( !isspace(*p) ) {
+ if (*p++ != '!')
+ goto initline;
+ bang(a, a, a, p, endcd);
+ goto top;
+ }
+
+/* Skip over blank cards by reading the next one right away */
+
+ goto top;
+
+initline:
+ if (addftnsrc) {
+ nst = (nst+1)%3;
+ if (!laststb && stb0)
+ laststb = stb0;
+ stb0 = stb = stbuf[nst];
+ *stb++ = '$'; /* kludge around funny p1gets behavior */
+ stbend = stb + sizeof(stbuf[0])-2;
+ for(p = a; p < atend;)
+ *stb++ = *p++;
+ if (atend < aend)
+ *stb++ = '\t';
+ for(p = b; p < endcd0;)
+ *stb++ = *p++;
+ *stb++ = '\n';
+ *stb = 0;
+ }
+
+/* Set nxtstno equal to the integer value of the statement label */
+
+ nxtstno = 0;
+ bend = a + 5;
+ for(p = a ; p < bend ; ++p)
+ if( !isspace(*p) )
+ if(isdigit(*p))
+ nxtstno = 10*nxtstno + (*p - '0');
+ else if (*p == '!') {
+ if (!addftnsrc)
+ bang(p+1,atend,aend,b,endcd);
+ endcd = b;
+ break;
+ }
+ else {
+ lineno = thislin;
+ errstr(
+ "nondigit in statement label field \"%.5s\"", a);
+ nxtstno = 0;
+ break;
+ }
+ firstline = thislin;
+ return(STINITIAL);
+}
+
+
+/* crunch -- deletes all space characters, folds the backslash chars and
+ Hollerith strings, quotes the Fortran strings */
+
+ LOCAL void
+crunch()
+{
+ register char *i, *j, *j0, *j1, *prvstr;
+ int k, ten, nh, nh0, quote;
+
+ /* i is the next input character to be looked at
+ j is the next output character */
+
+ new_dcl = needwkey = parlev = parseen = 0;
+ expcom = 0; /* exposed ','s */
+ expeql = 0; /* exposed equal signs */
+ j = sbuf;
+ prvstr = sbuf;
+ k = 0;
+ for(i=sbuf ; i<=lastch ; ++i)
+ {
+ if(isspace(*i) )
+ continue;
+ if (*i == '!') {
+ while(i >= linestart[k])
+ if (++k >= 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(i<lastch && i[1]==quote) ++i;
+ else break;
+ else if(*i=='\\' && i<lastch && use_bs) {
+ ++i;
+ *i = escapes[*(unsigned char *)i];
+ }
+ if (len + 2 < MAXTOKENLEN)
+ *++j = *i;
+ else if (len + 2 == MAXTOKENLEN)
+ erri
+ ("String too long, truncating to %d chars", MAXTOKENLEN - 2);
+ len++;
+ } /* for (;;) */
+
+ j[1] = MYQUOTE;
+ j += 2;
+ prvstr = j;
+ }
+ else if( (*i=='h' || *i=='H') && j>prvstr) /* test for Hollerith strings */
+ {
+ j0 = j - 1;
+ if( ! isdigit(*j0)) goto copychar;
+ nh = *j0 - '0';
+ ten = 10;
+ j1 = prvstr;
+ if (j1+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<lastch &&
+ nextch[0]=='d' && nextch[1]=='o')
+ {
+ stkey = SDO;
+ nextch += 2;
+ }
+ else stkey = SLET;
+ }
+ else if (parseen && nextch + 7 < lastch
+ && nextch[2] != 'u' /* screen out "double..." early */
+ && nextch[0] == 'd' && nextch[1] == 'o'
+ && ((nextch[2] >= '0' && nextch[2] <= '9')
+ || nextch[2] == ','
+ || nextch[2] == 'w'))
+ {
+ stkey = SDO;
+ nextch += 2;
+ needwkey = 1;
+ }
+ /* otherwise search for keyword */
+ else {
+ stkey = getkwd();
+ if(stkey==SGOTO && lastch>=nextch)
+ if(nextch[0]=='(')
+ stkey = SCOMPGOTO;
+ else if(isalpha_(* USC nextch))
+ stkey = SASGOTO;
+ }
+ parlev = 0;
+}
+
+
+
+ LOCAL int
+getkwd()
+{
+ 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<lastch && nextch[0]=='(' &&
+ (nextch[1]==')' || isalpha_(* USC (nextch+1))) )
+ {
+ nextch -= (toklen - 8);
+ return(SFUNCTION);
+ }
+
+ if(toklen > 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<lastch)
+ if(nextch[1]=='+' || nextch[1]=='-')
+ ++nextch;
+ if( ! isdigit(*++nextch) )
+ {
+ nextch = p;
+ havdbl = havexp = NO;
+ break;
+ }
+ for(++nextch ;
+ nextch<=lastch && isdigit(* USC nextch);
+ ++nextch);
+ break;
+ }
+ else if( ! isdigit(* USC nextch) )
+ break;
+ }
+ p = token;
+ i = n1;
+ while(i < nextch)
+ *p++ = *i++;
+ toklen = p - token;
+ *p = 0;
+ if(havdbl) return(SDCON);
+ if(havdot || havexp) return(SRCON);
+ return(SICON);
+badchar:
+ sbuf[0] = *nextch++;
+ return(SUNKNOWN);
+}
+
+/* Comment buffering code */
+
+ static void
+store_comment(str)
+ char *str;
+{
+ int len;
+ comment_buf *ncb;
+
+ if (nextcd == sbuf) {
+ flush_comments();
+ p1_comment(str);
+ return;
+ }
+ len = strlen(str) + 1;
+ if (cbnext + len > 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);
+ }
--- /dev/null
+#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 */
--- /dev/null
+/****************************************************************
+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\
+/*<<</dev/null>>>*/\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);
+}
--- /dev/null
+# 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 <tokdefs.h "s/#define/%token/" ;\
+ cat gram.head gram.dcl gram.expr gram.exec gram.io ) >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 . <tokens | sed "s/\([^:]*\):\(.*\)/#define \2 \1/" >tokdefs.h
+
+cds.o: sysdep.h
+exec.o: p1defs.h names.h
+expr.o: output.h niceprintf.h names.h
+format.o: p1defs.h format.h output.h niceprintf.h names.h iob.h
+formatdata.o: format.h output.h niceprintf.h names.h
+gram.o: p1defs.h
+init.o: output.h niceprintf.h iob.h
+intr.o: names.h
+io.o: names.h iob.h
+lex.o : tokdefs.h p1defs.h
+main.o: parse.h usignal.h
+mem.o: iob.h
+names.o: iob.h names.h output.h niceprintf.h
+niceprintf.o: defs.h names.h output.h niceprintf.h
+output.o: output.h niceprintf.h names.h
+p1output.o: p1defs.h output.h niceprintf.h names.h
+parse_args.o: parse.h
+proc.o: tokdefs.h names.h niceprintf.h output.h p1defs.h
+put.o: names.h pccdefs.h p1defs.h
+putpcc.o: names.h
+vax.o: defs.h output.h pccdefs.h
+output.h: niceprintf.h
+
+put.o putpcc.o: pccdefs.h
+
+f2c.t: f2c.1t
+ troff -man f2c.1t >f2c.t
+
+f2c.1: f2c.1t
+ nroff -man f2c.1t | col -b | uniq >f2c.1
+
+clean:
+ rm -f 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
--- /dev/null
+/****************************************************************
+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
--- /dev/null
+/****************************************************************
+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");
+ }
+ }
--- /dev/null
+/****************************************************************
+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;
+ }
--- /dev/null
+/****************************************************************
+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 ; p<nextext ; ++p)
+ if(!strcmp(s,p->cextname))
+ return( p );
+
+ if(nextext >= lastext)
+ many("external symbols", 'x', maxext);
+
+ nextext->fextname = strcpy(gmem(strlen(f)+1,0), f);
+ nextext->cextname = f == s
+ ? nextext->fextname
+ : strcpy(gmem(strlen(s)+1,0), s);
+ nextext->extstg = STGUNKNOWN;
+ nextext->extp = 0;
+ nextext->allextp = 0;
+ nextext->extleng = 0;
+ nextext->maxleng = 0;
+ nextext->extinit = 0;
+ nextext->curno = nextext->maxno = 0;
+ return( nextext++ );
+}
+
+
+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 */
--- /dev/null
+/****************************************************************
+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<memno> (big constant number)
+ 1.2 -> c_1_2 (constant 1.2)
+ 1.234345 -> c_b<memno> (big constant number)
+ -1 -> c_n1 (constant -1)
+ -1.0 -> c_n1_0 (constant -1.0)
+ .true. -> c_true (constant true)
+ .false. -> c_false (constant false)
+ default -> c_b<memno> (default label)
+*/
+
+char *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\
+/*<<</dev/null>>>*/\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\
+/*<<</dev/null>>>*/\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 *);
--- /dev/null
+#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 * */);
--- /dev/null
+/****************************************************************
+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 */
--- /dev/null
+/* 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)
+
+
+
--- /dev/null
+/****************************************************************
+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 */
--- /dev/null
+/* 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 ();
--- /dev/null
+#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:
+
+ <ascii-integer-rep> [ : [ <sp> [ <data> ]]] \n
+
+ e.g. 1: This is a comment
+
+ This format is destined to change in the future, but for now a readable
+ form is more desirable than a compact form.
+
+ NOTES ABOUT THE P1 FORMAT
+ ----------------------------------------------------------------------
+
+ P1_COMMENT: The comment string (in <data>) may be at most
+ COMMENT_BUFFER_SIZE bytes long. It must contain no newlines
+ or null characters. A side effect of the way comments are
+ read in lex.c is that no '\377' chars may be in a
+ comment either.
+
+ P1_SET_LINE: <data> holds the line number in the current source file.
+
+ P1_INC_LINE: Increment the source line number; <data> is empty.
+
+ P1_NAME_POINTER: <data> holds the integer representation of a
+ pointer into a hash table entry.
+
+ P1_CONST: the first field in <data> is a type tag (one of the
+ TYxxxx macros), the next field holds the constant
+ value
+
+ P1_EXPR: <data> holds the opcode number of the expression,
+ followed by the type of the expression (required for
+ OPCONV). Next is the value of vleng.
+ The type of operation represented by the
+ opcode determines how many of the following data items
+ are part of this expression.
+
+ P1_IDENT: <data> holds the type, then storage, then the
+ char string identifier in the addrp->user field.
+
+ P1_EXTERN: <data> holds an offset into the external symbol
+ table entry
+
+ P1_HEAD: the first field in <data> is the procedure class, the
+ second is the name of the procedure
+
+ P1_LIST: the first field in <data> is the tag, the second the
+ type of the list, the third the number of elements in
+ the list
+
+ P1_LITERAL: <data> holds the litnum of a value in the
+ literal pool.
+
+ P1_LABEL: <data> holds the statement number of the current
+ line
+
+ P1_ASGOTO: <data> holds the hash table pointer of the variable
+
+ P1_GOTO: <data> holds the statement number to jump to
+
+ P1_IF: <data> is empty, the following expression is the IF
+ condition.
+
+ P1_ELSE: <data> is empty.
+
+ P1_ELIF: <data> is empty, the following expression is the IF
+ condition.
+
+ P1_ENDIF: <data> is empty.
+
+ P1_ENDELSE: <data> is empty.
+
+ P1_ADDR: <data> holds a direct copy of the structure. The
+ next expression is a copy of vleng, and the next a
+ copy of memoffset.
+
+ P1_SUBR_RET: The next token is an expression for the return value.
+
+ P1_COMP_GOTO: The next token is an integer expression, the
+ following one a list of labels.
+
+ P1_FOR: The next three expressions are the Init, Test, and
+ Increment expressions of a C FOR loop.
+
+ P1_ENDFOR: Marks the end of the body of a FOR loop
+
+*/
--- /dev/null
+/****************************************************************
+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 */
--- /dev/null
+#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
--- /dev/null
+/****************************************************************
+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 <stdio.h>
+#ifndef NULL
+/* ANSI C */
+#include <stddef.h>
+#endif
+#include "parse.h"
+#include <math.h> /* For atof */
+#include <ctype.h>
+
+#define MAX_INPUT_SIZE 1000
+
+#define arg_prefix(x) ((x).prefix)
+#define arg_string(x) ((x).string)
+#define arg_flags(x) ((x).flags)
+#define arg_count(x) ((x).count)
+#define arg_result_type(x) ((x).result_type)
+#define arg_result_ptr(x) ((x).result_ptr)
+#define arg_table_size(x) ((x).table_size)
+
+#ifndef TRUE
+#define TRUE 1
+#endif
+#ifndef FALSE
+#define FALSE 0
+#endif
+typedef int boolean;
+
+
+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 */
+
--- /dev/null
+/* 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
--- /dev/null
+/****************************************************************
+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);
+ }
--- /dev/null
+/****************************************************************
+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 ; p<lasthash ; ++p)
+ if(q = p->varp)
+ {
+ qstg = q->vstg;
+ qtype = q->vtype;
+ qclass = q->vclass;
+
+ if( (qclass==CLUNKNOWN && qstg!=STGARG) ||
+ (qclass==CLVAR && qstg==STGUNKNOWN) ) {
+ if (!(q->vis_assigned | q->vimpldovar))
+ warn1("local variable %s never used",
+ q->fvarname);
+ }
+ else if(qclass==CLVAR && qstg==STGBSS)
+ { ; }
+
+/* Give external procedures the proper storage class */
+
+ else if(qclass==CLPROC && q->vprocclass==PEXTERNAL
+ && qstg!=STGARG) {
+ e = mkext(q->fvarname,addunder(q->cvarname));
+ e->extstg = STGEXT;
+ q->vardesc.varno = e - extsymtab;
+ if (e->extype != qtype)
+ changedtype(q);
+ }
+ if(qclass==CLVAR) {
+ if (qstg != STGARG && q->vdim)
+ dim_check(q);
+ } /* if qclass == CLVAR */
+ }
+
+}
+
+
+
+donmlist()
+{
+ register struct Hashentry *p;
+ register Namep q;
+
+ for(p=hashtab; p<lasthash; ++p)
+ if( (q = p->varp) && q->vclass==CLNAMELIST)
+ namelist(q);
+}
+
+
+/* iarrlen -- Returns the size of the array in bytes, or -1 */
+
+ftnint 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 ; extptr<nextext ; ++extptr)
+ if (extptr->extstg == STGCOMMON && (q = extptr->extp)) {
+
+/* If a common declaration also had a list of variables ... */
+
+ q = extptr->extp = revchain(q);
+ pref = 1;
+ for(k = TYCHAR; q ; q = q->nextp)
+ {
+ comvar = (Namep) (q->datap);
+
+ if(comvar->vdcldone == NO)
+ vardcl(comvar);
+ type = comvar->vtype;
+ if (pref < type_pref[type])
+ pref = type_pref[k = type];
+ if(extptr->extleng % typealign[type] != 0) {
+ dclerr("common alignment", comvar);
+ --nerr; /* don't give bad return code for this */
+#if 0
+ extptr->extleng = roundup(extptr->extleng, typealign[type]);
+#endif
+ } /* if extptr -> extleng % */
+
+/* Set the offset into the common block */
+
+ comvar->voffset = extptr->extleng;
+ comvar->vardesc.varno = extptr - extsymtab;
+ if(type == TYCHAR)
+ 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 */
--- /dev/null
+# $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 <tokdefs.h "s/#define/%token/" ;\
+ cat $(GSRC) ) >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
--- /dev/null
+/****************************************************************
+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 ; litp<lastlit ; ++litp)
+
+/* Remove this type checking to ensure that all bit patterns are reused */
+
+ if(type == litp->littype) switch(litflavor)
+ {
+ case LIT_CHAR:
+ if (len == (int)litp->litval.litival2[0]
+ && nblanks == litp->litval.litival2[1]
+ && !memcmp(strp, litp->cds[0], len)) {
+ q->memno = litp->litnum;
+ frexpr((expptr)p);
+ 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 );
+}
--- /dev/null
+/****************************************************************
+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<<k */
+ if(INT(p->exprblock.leftp->headblock.vtype) &&
+ ISICON(p->exprblock.rightp) &&
+ ( (k = log_2(p->exprblock.rightp->constblock.Const.ci))>0) )
+ {
+ p->exprblock.opcode = OPLSHIFT;
+ frexpr(p->exprblock.rightp);
+ p->exprblock.rightp = ICON(k);
+ goto putopp;
+ }
+ if (krparens && ISREAL(p->exprblock.vtype))
+ return krput(p);
+
+ case OPMOD:
+ goto putopp;
+ case OPPLUS:
+ if (krparens && ISREAL(p->exprblock.vtype))
+ return krput(p);
+ case OPMINUS:
+ case OPSLASH:
+ case OPNEG:
+ case OPNEG1:
+ case OPABS:
+ case OPDABS:
+ if( ISCOMPLEX(p->exprblock.vtype) )
+ p = putcxop(p);
+ else goto putopp;
+ break;
+
+ case OPCONV:
+ if( ISCOMPLEX(p->exprblock.vtype) )
+ p = putcxop(p);
+ else if( ISCOMPLEX(p->exprblock.leftp->headblock.vtype) )
+ {
+ p = putx( mkconv(p->exprblock.vtype,
+ (expptr)realpart(putcx1(p->exprblock.leftp))));
+ }
+ else goto putopp;
+ break;
+
+ case OPNOT:
+ case OPOR:
+ case OPAND:
+ case OPEQV:
+ case OPNEQV:
+ case OPADDR:
+ case OPPLUSEQ:
+ case OPSTAREQ:
+ case OPCOMMA:
+ case OPQUEST:
+ case OPCOLON:
+ case OPBITOR:
+ case OPBITAND:
+ case OPBITXOR:
+ case OPBITNOT:
+ case OPLSHIFT:
+ case OPRSHIFT:
+ case OPASSIGNI:
+ case OPIDENTITY:
+ case OPCHARCAST:
+ case OPMIN2:
+ case OPMAX2:
+ case OPDMIN:
+ case OPDMAX:
+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) ==>
+ { <type> t1, t2;
+
+ t1 = a;
+ t2 = b; t1 = (t1 < t2) ? t1 : t2;
+ t2 = c; t1 = (t1 < t2) ? t1 : t2;
+ t2 = d; t1 = (t1 < t2) ? t1 : t2;
+ }
+*/
+
+ if (!doin_setbound) {
+ switch(op) {
+ case OPLT:
+ case OPMIN:
+ case OPDMIN:
+ case OPMIN2:
+ what = "IN";
+ break;
+ default:
+ what = "AX";
+ }
+ sprintf (comment_buf, "Computing M%s", what);
+ p1_comment (comment_buf);
+ }
+
+ p1 = p0->nextp;
+ temp = (expptr)p0->datap;
+ if (addressable(temp) && addressable((expptr)p1->datap)) {
+ p = mkconv(type, cpexpr(temp));
+ arg = mkconv(type, cpexpr((expptr)p1->datap));
+ temp = mkexpr(op2, p, arg);
+ if (!ISCONST(temp))
+ temp = fixexpr((Exprp)temp);
+ p1 = p1->nextp;
+ }
+ p = putassign (cpexpr((expptr)sp), temp);
+
+ for(; p1 ; p1 = p1->nextp)
+ {
+ if (addressable ((expptr) p1 -> datap)) {
+ arg = mkconv(type, cpexpr((expptr)p1->datap));
+ temp = mkexpr(op2, cpexpr((expptr)sp), arg);
+ temp = fixexpr((Exprp)temp);
+ } else {
+ temp = (expptr) cpexpr (qp);
+ p = mkexpr(OPCOMMA, p,
+ putassign(cpexpr((expptr)tp), (expptr)p1->datap));
+ } /* else */
+
+ if(p1->nextp)
+ p = mkexpr(OPCOMMA, p,
+ putassign(cpexpr((expptr)sp), temp));
+ else {
+ if (type == TYREAL && forcedouble)
+ temp->exprblock.opcode =
+ op == OPMIN ? OPDMIN : OPDMAX;
+ if (doin_setbound)
+ p = mkexpr(OPCOMMA, p, temp);
+ else {
+ putout (p);
+ p = putx(temp);
+ }
+ if (qp)
+ frexpr (qp);
+ } /* else */
+ } /* for */
+
+ frchain( &p0 );
+ return p;
+}
+
+
+ void
+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);
+ }
+ }
--- /dev/null
+#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();
--- /dev/null
+/****************************************************************
+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
--- /dev/null
+/****************************************************************
+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 <stdio.h>
+
+#ifdef ANSI_Libraries
+#include <stddef.h>
+#include <stdlib.h>
+#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) */
--- /dev/null
+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
--- /dev/null
+#include <signal.h>
+#ifndef SIGHUP
+#define SIGHUP 1 /* hangup */
+#endif
+#ifndef SIGQUIT
+#define SIGQUIT 3 /* quit */
+#endif
--- /dev/null
+/****************************************************************
+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 */
--- /dev/null
+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";
--- /dev/null
+/****************************************************************
+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);
+ }
--- /dev/null
+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
--- /dev/null
+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.
--- /dev/null
+#!/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
--- /dev/null
+31 Aug. 1989:
+ 1. A(min(i,j)) now is translated correctly (where A is an array).
+ 2. 7 and 8 character variable names are allowed (but elicit a
+ complaint under -ext).
+ 3. LOGICAL*1 is treated as LOGICAL, with just one error message
+ per LOGICAL*1 statement (rather than one per variable declared
+ in that statement). [Note that LOGICAL*1 is not in Fortran 77.]
+ Like f77, f2c now allows the format in a read or write statement
+ to be an integer array.
+
+5 Sept. 1989:
+ Fixed botch in argument passing of substrings of equivalenced
+variables.
+
+15 Sept. 1989:
+ Warn about incorrect code generated when a character-valued
+function is not declared external and is passed as a parameter
+(in violation of the Fortran 77 standard) before it is invoked.
+Example:
+
+ subroutine foo(a,b)
+ character*10 a,b
+ call goo(a,b)
+ b = a(3)
+ end
+
+18 Sept. 1989:
+ Complain about overlapping initializations.
+
+20 Sept. 1989:
+ Warn about names declared EXTERNAL but never referenced;
+include such names as externs in the generated C (even
+though most C compilers will discard them).
+
+24 Sept. 1989:
+ New option -w8 to suppress complaint when COMMON or EQUIVALENCE
+forces word alignment of a double.
+ Under -A (for ANSI C), ensure that floating constants (terminated
+by 'f') contain either a decimal point or an exponent field.
+ Repair bugs sometimes encountered with CHAR and ICHAR intrinsic
+functions.
+ Restore f77's optimizations for copying and comparing character
+strings of length 1.
+ Always assume floating-point valued routines in libF77 return
+doubles, even under -R.
+ Repair occasional omission of arguments in routines having multiple
+entry points.
+ Repair bugs in computing offsets of character strings involved
+in EQUIVALENCE.
+ Don't omit structure qualification when COMMON variables are used
+as FORMATs or internal files.
+
+2 Oct. 1989:
+ Warn about variables that appear only in data stmts; don't emit them.
+ Fix bugs in character DATA for noncharacter variables
+involved in EQUIVALENCE.
+ Treat noncharacter variables initialized (at least partly) with
+character data as though they were equivalenced -- put out a struct
+and #define the variables. This eliminates the hideous and nonportable
+numeric values that were used to initialize such variables.
+ Treat IMPLICIT NONE as IMPLICIT UNDEFINED(A-Z) .
+ Quit when given invalid options.
+
+8 Oct. 1989:
+ Modified naming scheme for generated intermediate variables;
+more are recycled, fewer distinct ones used.
+ New option -W nn specifies nn characters/word for Hollerith
+data initializing non-character variables.
+ Bug fix: x(i:min(i+10,j)) used to elicit "Can't handle opcode 31 yet".
+ Integer expressions of the form (i+const1) - (i+const2), where
+i is a scalar integer variable, are now simplified to (const1-const2);
+this leads to simpler translation of some substring expressions.
+ Initialize uninitialized portions of character string arrays to 0
+rather than to blanks.
+
+9 Oct. 1989:
+ New option -c to insert comments showing original Fortran source.
+ New option -g to insert line numbers of original Fortran source.
+
+10 Oct. 1989:
+ ! recognized as in-line comment delimiter (a la Fortran 88).
+
+24 Oct. 1989:
+ New options to ease coping with systems that want the structs
+that result from COMMON blocks to be defined just once:
+ -E causes uninitialized COMMON blocks to be declared Extern;
+if Extern is undefined, f2c.h #defines it to be extern.
+ -ec causes a separate .c file to be emitted for each
+uninitialized COMMON block: COMMON /ABC/ yields abc_com.c;
+thus one can compile *_com.c into a library to ensure
+precisely one definition.
+ -e1c is similar to -ec, except that everything goes into
+one file, along with comments that give a sed script for
+splitting the file into the pieces that -ec would give.
+This is for use with netlib's "execute f2c" service (for which
+-ec is coerced into -e1c, and the sed script will put everything
+but the COMMON definitions into f2c_out.c ).
+
+28 Oct. 1989:
+ Convert "i = i op ..." into "i op= ...;" even when i is a
+dummy argument.
+
+13 Nov. 1989:
+ Name integer constants (passed as arguments) c__... rather
+than c_... so
+ common /c/stuff
+ call foo(1)
+ ...
+is translated correctly.
+
+19 Nov. 1989:
+ Floating-point constants are now kept as strings unless they
+are involved in constant expressions that get simplified. The
+floating-point constants kept as strings can have arbitrarily
+many significant figures and a very large exponent field (as
+large as long int allows on the machine on which f2c runs).
+Thus, for example, the body of
+
+ subroutine zot(x)
+ double precision x(6), pi
+ parameter (pi=3.1415926535897932384626433832795028841972)
+ x(1) = pi
+ x(2) = pi+1
+ x(3) = 9287349823749272.7429874923740978492734D-298374
+ x(4) = .89
+ x(5) = 4.0005
+ x(6) = 10D7
+ end
+
+now gets translated into
+
+ x[1] = 3.1415926535897932384626433832795028841972;
+ x[2] = 4.1415926535897931;
+ x[3] = 9.2873498237492727429874923740978492734e-298359;
+ x[4] = (float).89;
+ x[5] = (float)4.0005;
+ x[6] = 1e8;
+
+rather than the former
+
+ x[1] = 3.1415926535897931;
+ x[2] = 4.1415926535897931;
+ x[3] = 0.;
+ x[4] = (float)0.89000000000000003;
+ x[5] = (float)4.0004999999999997;
+ x[6] = 100000000.;
+
+ Recognition of f77 machine-constant intrinsics deleted, i.e.,
+epbase, epprec, epemin, epemax, eptiny, ephuge, epmrsp.
+
+22 Nov. 1989:
+ Workarounds for glitches on some Sun systems...
+ libf77: libF77/makefile modified to point out possible need
+to compile libF77/main.c with -Donexit=on_exit .
+ libi77: libI77/wref.c (and libI77/README) modified so non-ANSI
+systems can compile with USE_STRLEN defined, which will cause
+ sprintf(b = buf, "%#.*f", d, x);
+ n = strlen(b) + d1;
+rather than
+ n = sprintf(b = buf, "%#.*f", d, x) + d1;
+to be compiled.
+
+26 Nov. 1989:
+ Longer names are now accepted (up to 50 characters); names may
+contain underscores (in which case they will have two underscores
+appended, to avoid clashes with library names).
+
+28 Nov. 1989:
+ libi77 updated:
+ 1. Allow 3 (or, on Crays, 4) digit exponents under format Ew.d .
+ 2. Try to get things right on machines where ints have 16 bits.
+
+29 Nov. 1989:
+ Supplied missing semicolon in parameterless subroutines that
+have multiple entry points (all of them parameterless).
+
+30 Nov. 1989:
+ libf77 and libi77 revised to use types from f2c.h.
+ f2c now types floating-point valued C library routines as "double"
+rather than "doublereal" (for use with nonstandard C compilers for
+which "double" is IEEE double extended).
+
+1 Dec. 1989:
+ f2c.h updated to eliminate #defines rendered unnecessary (and,
+indeed, dangerous) by change of 26 Nov. to long names possibly
+containing underscores.
+ libi77 further revised: yesterday's change omitted two tweaks to fmt.h
+(tweaks which only matter if float and real or double and doublereal are
+different types).
+
+2 Dec. 1989:
+ Better error message (than "bad tag") for NAMELIST, which no longer
+inhibits C output.
+
+4 Dec. 1989:
+ Allow capital letters in hex constants (f77 extension; e.g.,
+x'a012BCd', X'A012BCD' and x'a012bcd' are all treated as the integer
+167848909).
+ libi77 further revised: lio.c lio.h lread.c wref.c wrtfmt.c tweaked
+again to allow float and real or double and doublereal to be different.
+
+6 Dec. 1989:
+ Revised f2c.h -- required for the following...
+ Simpler looking translations for abs, min, max, using #defines in
+revised f2c.h .
+ libi77: more corrections to types; additions for NAMELIST.
+ Corrected casts in some I/O calls.
+ Translation of NAMELIST; libi77 must still be revised. Currently
+libi77 gives you a run-time error message if you attempt NAMELIST I/O.
+
+7 Dec. 1989:
+ Fixed bug that prevented local integer variables that appear in DATA
+stmts from being ASSIGNed statement labels.
+ Fillers (for DATA statements initializing EQUIVALENCEd variables and
+variables in COMMON) typed integer rather than doublereal (for slightly
+more portability, e.g. to Crays).
+ libi77: missing return values supplied in a few places; some tests
+reordered for better working on the Cray.
+ libf77: better accuracy for complex divide, complex square root,
+real mod function (casts to double; double temporaries).
+
+9 Dec. 1989:
+ Fixed bug that caused needless (albeit harmless) empty lines to be
+inserted in the C output when a comment line contained trailing blanks.
+ Further tweak to type of fillers: allow doublereal fillers if the
+struct has doublereal data.
+
+11 Dec. 1989:
+ Alteration of rule for producing external (C) names from names that
+contain underscores. Now the external name is always obtained by
+appending a pair of underscores.
+
+12 Dec. 1989:
+ C production inhibited after most errors.
+
+15 Dec. 1989:
+ Fixed bug in headers for subroutines having two or more character
+strings arguments: the length arguments were reversed.
+
+19 Dec. 1989:
+ f2c.h libf77 libi77: adjusted so #undefs in f2c.h should not foil
+compilation of libF77 and libI77.
+ libf77: getenv_ adjusted to work with unsorted environments.
+ libi77: the iostat= specifier should now work right with internal I/O.
+
+20 Dec. 1989:
+ f2c bugs fixed: In the absence of an err= specifier, the iostat=
+specifier was generally set wrong. Character strings containing
+explicit nulls (\0) were truncated at the first null.
+ Unlabeled DO loops recognized; must be terminated by ENDDO.
+(Don't ask for CYCLE, EXIT, named DO loops, or DO WHILE.)
+
+29 Dec. 1989:
+ Nested unlabeled DO loops now handled properly; new warning for
+extraneous text at end of FORMAT.
+
+30 Dec. 1989:
+ Fixed bug in translating dble(real(...)), dble(sngl(...)), and
+dble(float(...)), where ... is either of type double complex or
+is an expression requiring assignment to intermediate variables (e.g.,
+dble(real(foo(x+1))), where foo is a function and x is a variable).
+Regard nonblank label fields on continuation lines as an error.
+
+3 Jan. 1990:
+ New option -C++ yields output that should be understood
+by C++ compilers.
+
+6 Jan. 1989:
+ -a now excludes variables that appear in a namelist from those
+that it makes automatic. (As before, it also excludes variables
+that appear in a common, data, equivalence, or save statement.)
+ The syntactically correct Fortran
+ read(*,i) x
+ end
+now yields syntactically correct C (even though both the Fortran
+and C are buggy -- no FORMAT has not been ASSIGNed to i).
+
+7 Jan. 1990:
+ libi77: routines supporting NAMELIST added. Surrounding quotes
+made optional when no ambiguity arises in a list or namelist READ
+of a character-string value.
+
+9 Jan. 1990:
+ f2c.src made available.
+
+16 Jan. 1990:
+ New options -P to produce ANSI C or C++ prototypes for procedures
+defined. Change to -A and -C++: f2c tries to infer prototypes for
+invoked procedures unless the new -!P option is given. New warning
+messages for inconsistent calling sequences among procedures within
+a single file. Most of f2c/src is affected.
+ f2c.h: typedefs for procedure arguments added; netlib's f2c service
+will insert appropriate typedefs for use with older versions of f2c.h.
+
+17 Jan. 1990:
+ f2c/src: defs.h exec.c format.c proc.c putpcc.c version.c xsum0.out
+updated. Castargs and protofile made extern in defs.h; exec.c
+modified so superfluous else clauses are diagnosed; unused variables
+omitted from declarations in format.c proc.c putpcc.c .
+
+21 Jan. 1990:
+ No C emitted for procedures declared external but not referenced.
+ f2c.h: more new types added for use with -P.
+ New feature: f2c accepts as arguments files ending in .p or .P;
+such files are assumed to be prototype files, such as produced by
+the -P option. All prototype files are read before any Fortran files
+and apply globally to all Fortran files. Suitable prototypes help f2c
+warn about calling-sequence errors and can tell f2c how to type
+procedures declared external but not explicitly typed; the latter is
+mainly of interest for users of the -A and -C++ options. (Prototype
+arguments are not available to netlib's "execute f2c" service.)
+ New option -it tells f2c to try to infer types of untyped external
+arguments from their use as parameters to prototyped or previously
+defined procedures.
+ f2c/src: many minor cleanups; most modules changed. Individual
+files in f2c/src are now in "bundle" format. The former f2c.1 is
+now f2c.1t; "f2c.1t from f2c" and "f2c.1t from f2c/src" are now the
+same, as are "f2c.1 from f2c" and "f2c.1 from f2c/src". People who
+do not obtain a new copy of "all from f2c/src" should at least add
+ fclose(sortfp);
+after the call on do_init_data(outfile, sortfp) in format_data.c .
+
+22 Jan. 1990:
+ Cleaner man page wording (thanks to Doug McIlroy).
+ -it now also applies to all untyped EXTERNAL procedures, not just
+arguments.
+
+23 Jan. 01:34:00 EST 1990:
+ Bug fixes: under -A and -C++, incorrect C was generated for
+subroutines having multiple entries but no arguments.
+ Under -A -P, subroutines of no arguments were given prototype
+calling sequence () rather than (void).
+ Character-valued functions elicited erroneous warning messages
+about inconsistent calling sequences when referenced by another
+procedure in the same file.
+ f2c.1t: omit first appearance of libF77.a in FILES section;
+load order of libraries is -lF77 -lI77, not vice versa (bug
+introduced in yesterday's edits); define .F macro for those whose
+-man lacks it. (For a while after yesterday's fixes were posted,
+f2c.1t was out of date. Sorry!)
+
+23 Jan. 9:53:24 EST 1990:
+ Character substring expressions involving function calls having
+character arguments (including the intrinsic len function) yielded
+incorrect C.
+ Procedures defined after invocation (in the same file) with
+conflicting argument types also got an erroneous message about
+the wrong number of arguments.
+
+24 Jan. 11:44:00 EST 1990:
+ Bug fixes: -p omitted #undefs; COMMON block names containing
+underscores had their C names incorrectly computed; a COMMON block
+having the name of a previously defined procedure wreaked havoc;
+if all arguments were .P files, f2c tried reading the second as a
+Fortran file.
+ New feature: -P emits comments showing COMMON block lengths, so one
+can get warnings of incompatible COMMON block lengths by having f2c
+read .P (or .p) files. Now by running f2c twice, first with -P -!c
+(or -P!c), then with *.P among the arguments, you can be warned of
+inconsistent COMMON usage, and COMMON blocks having inconsistent
+lengths will be given the maximum length. (The latter always did
+happen within each input file; now -P lets you extend this behavior
+across files.)
+
+26 Jan. 16:44:00 EST 1990:
+ Option -it made less aggressive: untyped external procedures that
+are invoked are now typed by the rules of Fortran, rather than by
+previous use of procedures to which they are passed as arguments
+before being invoked.
+ Option -P now includes information about references, i.e., called
+procedures, in the prototype files (in the form of special comments).
+This allows iterative invocations of f2c to infer more about untyped
+external names, particularly when multiple Fortran files are involved.
+ As usual, there are some obscure bug fixes:
+1. Repair of erroneous warning messages about inconsistent number of
+arguments that arose when a character dummy parameter was discovered
+to be a function or when multiple entry points involved character
+variables appearing in a previous entry point.
+2. Repair of memory fault after error msg about "adjustable character
+function".
+3. Under -U, allow MAIN_ as a subroutine name (in the same file as a
+main program).
+4. Change for consistency: a known function invoked as a subroutine,
+then as a function elicits a warning rather than an error.
+
+26 Jan. 22:32:00 EST 1990:
+ Fixed two bugs that resulted in incorrect C for substrings, within
+the body of a character-valued function, of the function's name, when
+those substrings were arguments to another function (even implicitly,
+as in character-string assignment).
+
+28 Jan. 18:32:00 EST 1990:
+ libf77, libi77: checksum files added; "make check" looks for
+transmission errors. NAMELIST read modified to allow $ rather than &
+to precede a namelist name, to allow $ rather than / to terminate
+input where the name of another variable would otherwise be expected,
+and to regard all nonprinting ASCII characters <= ' ' as spaces.
+
+29 Jan. 02:11:00 EST 1990:
+ "fc from f2c" added.
+ -it option made the default; -!it turns it off. Type information is
+now updated in a previously missed case.
+ -P option tweaked again; message about when rerunning f2c may change
+prototypes or declarations made more accurate.
+ New option -Ps implies -P and returns exit status 4 if rerunning
+f2c -P with prototype inputs might change prototypes or declarations.
+Now you can execute a crude script like
+
+ cat *.f >zap.F
+ rm -f zap.P
+ while :; do
+ f2c -Ps -!c zap.[FP]
+ case $? in 4) ;; *) break;; esac
+ done
+
+to get a file zap.P of the best prototypes f2c can determine for *.f .
+
+Jan. 29 07:30:21 EST 1990:
+ Forgot to check for error status when setting return code 4 under -Ps;
+error status (1, 2, 3, or, for caught signal, 126) now takes precedence.
+
+Jan 29 14:17:00 EST 1990:
+ Incorrect handling of
+ open(n,'filename')
+repaired -- now treated as
+ open(n,file='filename')
+(and, under -ext, given an error message).
+ New optional source file memset.c for people whose systems don't
+provide memset, memcmp, and memcpy; #include <string.h> in mem.c
+changed to #include "string.h" so BSD people can create a local
+string.h that simply says #include <strings.h> .
+
+Jan 30 10:34:00 EST 1990:
+ Fix erroneous warning at end of definition of a procedure with
+character arguments when the procedure had previously been called with
+a numeric argument instead of a character argument. (There were two
+warnings, the second one incorrectly complaining of a wrong number of
+arguments.)
+
+Jan 30 16:29:41 EST 1990:
+ Fix case where -P and -Ps erroneously reported another iteration
+necessary. (Only harm is the extra iteration.)
+
+Feb 3 01:40:00 EST 1990:
+ Supply semicolon occasionally omitted under -c .
+ Try to force correct alignment when numeric variables are initialized
+with character data (a non-standard and non-portable practice). You
+must use the -W option if your code has such data statements and is
+meant to run on a machine with other than 4 characters/word; e.g., for
+code meant to run on a Cray, you would specify -W8 .
+ Allow parentheses around expressions in output lists (in write and
+print statements).
+ Rename source files so their names are <= 12 characters long
+(so there's room to append .Z and still have <= 14 characters);
+renamed files: formatdata.c niceprintf.c niceprintf.h safstrncpy.c .
+ f2c material made available by anonymous ftp from research.att.com
+(look in dist/f2c ).
+
+Feb 3 03:49:00 EST 1990:
+ Repair memory fault that arose from use (in an assignment or
+call) of a non-argument variable declared CHARACTER*(*).
+
+Feb 9 01:35:43 EST 1990:
+ Fix erroneous error msg about bad types in
+ subroutine foo(a,adim)
+ dimension a(adim)
+ integer adim
+ Fix improper passing of character args (and possible memory fault)
+in the expression part of a computed goto.
+ Fix botched calling sequences in array references involving
+functions having character args.
+ Fix memory fault caused by invocation of character-valued functions
+of no arguments.
+ Fix botched calling sequence of a character*1-valued function
+assigned to a character*1 variable.
+ Fix bug in error msg for inconsistent number of args in prototypes.
+ Allow generation of C output despite inconsistencies in prototypes,
+but give exit code 8.
+ Simplify include logic (by removing some bogus logic); never
+prepend "/usr/include/" to file names.
+ Minor cleanups (that should produce no visible change in f2c's
+behavior) in intr.c parse.h main.c defs.h formatdata.c p1output.c .
+
+Feb 10 00:19:38 EST 1990:
+ Insert (integer) casts when floating-point expressions are used
+as subscripts.
+ Make SAVE stmt (with no variable list) override -a .
+ Minor cleanups: change field to Field in struct Addrblock (for the
+benefit of buggy C compilers); omit system("/bin/cp ...") in misc.c .
+
+Feb 13 00:39:00 EST 1990:
+ Error msg fix in gram.dcl: change "cannot make %s parameter"
+to "cannot make into parameter".
+
+Feb 14 14:02:00 EST 1990:
+ Various cleanups (invisible on systems with 4-byte ints), thanks
+to Dave Regan: vaxx.c eliminated; %d changed to %ld various places;
+external names adjusted for the benefit of stupid systems (that ignore
+case and recognize only 6 significant characters in external names);
+buffer shortened in xsum.c (e.g. for MS-DOS); fopen modes distinguish
+text and binary files; several unused functions eliminated; missing
+arg supplied to an unlikely fatalstr invocation.
+
+Thu Feb 15 19:15:53 EST 1990:
+ More cleanups (invisible on systems with 4 byte ints); casts inserted
+so most complaints from cyntax(1) and lint(1) go away; a few (int)
+versus (long) casts corrected.
+
+Fri Feb 16 19:55:00 EST 1990:
+ Recognize and translate unnamed Fortran 8x do while statements.
+ Fix bug that occasionally caused improper breaking of character
+strings.
+ New error message for attempts to provide DATA in a type-declaration
+statement.
+
+Sat Feb 17 11:43:00 EST 1990:
+ Fix infinite loop clf -> Fatal -> done -> clf after I/O error.
+ Change "if (addrp->vclass = CLPROC)" to "if (addrp->vclass == CLPROC)"
+in p1_addr (in p1output.c); this was probably harmless.
+ Move a misplaced } in lex.c (which slowed initkey()).
+ Thanks to Gary Word for pointing these things out.
+
+Sun Feb 18 18:07:00 EST 1990:
+ Detect overlapping initializations of arrays and scalar variables
+in previously missed cases.
+ Treat logical*2 as logical (after issuing a warning).
+ Don't pass string literals to p1_comment().
+ Correct a cast (introduced 16 Feb.) in gram.expr; this matters e.g.
+on a Cray.
+ Attempt to isolate UNIX-specific things in sysdep.c (a new source
+file). Unless sysdep.c is compiled with SYSTEM_SORT defined, the
+intermediate files created for DATA statements are now sorted in-core
+without invoking system().
+
+Tue Feb 20 16:10:35 EST 1990:
+ Move definition of binread and binwrite from init.c to sysdep.c .
+ Recognize Fortran 8x tokens < <= == >= > <> as synonyms for
+.LT. .LE. .EQ. .GE. .GT. .NE.
+ Minor cleanup in putpcc.c: fully remove simoffset().
+ More discussion of system dependencies added to libI77/README.
+
+Tue Feb 20 21:44:07 EST 1990:
+ Minor cleanups for the benefit of EBCDIC machines -- try to remove
+the assumption that 'a' through 'z' are contiguous. (Thanks again to
+Gary Word.) Also, change log2 to log_2 (shouldn't be necessary).
+
+Wed Feb 21 06:24:56 EST 1990:
+ Fix botch in init.c introduced in previous change; only matters
+to non-ASCII machines.
+
+Thu Feb 22 17:29:12 EST 1990:
+ Allow several entry points to mention the same array. Protect
+parameter adjustments with if's (for the case that an array is not
+an argument to all entrypoints).
+ Under -u, allow
+ subroutine foo(x,n)
+ real x(n)
+ integer n
+ Compute intermediate variables used to evaluate dimension expressions
+at the right time. Example previously mistranslated:
+ subroutine foo(x,k,m,n)
+ real x(min(k,m,n))
+ ...
+ write(*,*) x
+ Detect duplicate arguments. (The error msg points to the first
+executable stmt -- not wonderful, but not worth fixing.)
+ Minor cleanup of min/max computation (sometimes slightly simpler).
+
+Sun Feb 25 09:39:01 EST 1990:
+ Minor tweak to multiple entry points: protect parameter adjustments
+with if's only for (array) args that do not appear in all entry points.
+ Minor tweaks to format.c and io.c (invisible unless your compiler
+complained at the duplicate #defines of IOSUNIT and IOSFMT or at
+comparisons of p1gets(...) with NULL).
+
+Sun Feb 25 18:40:10 EST 1990:
+ Fix bug introduced Feb. 22: if a subprogram contained DATA and the
+first executable statement was labeled, then the label got lost.
+(Just change INEXEC to INDATA in p1output.c; it occurs just once.)
+
+Mon Feb 26 17:45:10 EST 1990:
+ Fix bug in handling of " and ' in comments.
+
+Wed Mar 28 01:43:06 EST 1990:
+libI77:
+ 1. Repair nasty I/O bug: opening two files and closing the first
+(after possibly reading or writing it), then writing the second caused
+the last buffer of the second to be lost.
+ 2. Formatted reads of logical values treated all letters other than
+t or T as f (false).
+ libI77 files changed: err.c rdfmt.c Version.c
+ (Request "libi77 from f2c" -- you can't get these files individually.)
+
+f2c itself:
+ Repair nasty bug in translation of
+ ELSE IF (condition involving complicated abs, min, or max)
+-- auxiliary statements were emitted at the wrong place.
+ Supply semicolon previously omitted from the translation of a label
+(of a CONTINUE) immediately preceding an ELSE IF or an ELSE. This
+bug made f2c produce invalid C.
+ Correct a memory fault that occurred (on some machines) when the
+error message "adjustable dimension on non-argument" should be given.
+ Minor tweaks to remove some harmless warnings by overly chatty C
+compilers.
+ Argument arays having constant dimensions but a variable lower bound
+(e.g., x(n+1:n+3)) had a * omitted from scalar arguments involved in
+the array offset computation.
+
+Wed Mar 28 18:47:59 EST 1990:
+libf77: add exit(0) to end of main [return(0) encounters a Cray bug]
+
+Sun Apr 1 16:20:58 EDT 1990:
+ Avoid dereferencing null when processing equivalences after an error.
+
+Fri Apr 6 08:29:49 EDT 1990:
+ Calls involving alternate return specifiers omitted processing
+needed for things like min, max, abs, and // (concatenation).
+ INTEGER*2 PARAMETERs were treated as INTEGER*4.
+ Convert some O(n^2) parsing to O(n).
+
+Tue Apr 10 20:07:02 EDT 1990:
+ When inconsistent calling sequences involve differing numbers of
+arguments, report the first differing argument rather than the numbers
+of arguments.
+ Fix bug under -a: formatted I/O in which either the unit or the
+format was a local character variable sometimes resulted in invalid C
+(a static struct initialized with an automatic component).
+ Improve error message for invalid flag after elided -.
+ Complain when literal table overflows, rather than infinitely
+looping. (The complaint mentions the new and otherwise undocumented
+-NL option for specifying a larger literal table.)
+ New option -h for forcing strings to word (or, with -hd, double-word)
+boundaries where possible.
+ Repair a bug that could cause improper splitting of strings.
+ Fix bug (cast of c to doublereal) in
+ subroutine foo(c,r)
+ double complex c
+ double precision r
+ c = cmplx(r,real(c))
+ end
+ New include file "sysdep.h" has some things from defs.h (and
+elsewhere) that one may need to modify on some systems.
+ Some large arrays that were previously statically allocated are now
+dynamically allocated when f2c starts running.
+ f2c/src files changed:
+ README cds.c defs.h f2c.1 f2c.1t format.c formatdata.c init.c
+ io.c lex.c main.c makefile mem.c misc.c names.c niceprintf.c
+ output.c parse_args.c pread.c put.c putpcc.c sysdep.h
+ version.c xsum0.out
+
+Wed Apr 11 18:27:12 EDT 1990:
+ Fix bug in argument consistency checking of character, complex, and
+double complex valued functions. If the same source file contained a
+definition of such a function with arguments not explicitly typed,
+then subsequent references to the function might get erroneous
+warnings of inconsistent calling sequences.
+ Tweaks to sysdep.h for partially ANSI systems.
+ New options -kr and -krd cause f2c to use temporary variables to
+enforce Fortran evaluation-order rules with pernicious, old-style C
+compilers that apply the associative law to floating-point operations.
+
+Sat Apr 14 15:50:15 EDT 1990:
+ libi77: libI77 adjusted to allow list-directed and namelist I/O
+of internal files; bug in namelist I/O of logical and character arrays
+fixed; list input of complex numbers adjusted to permit d or D to
+denote the start of the exponent field of a component.
+ f2c itself: fix bug in handling complicated lower-bound
+expressions for character substrings; e.g., min and max did not work
+right, nor did function invocations involving character arguments.
+ Switch to octal notation, rather than hexadecimal, for nonprinting
+characters in character and string constants.
+ Fix bug (when neither -A nor -C++ was specified) in typing of
+external arguments of type complex, double complex, or character:
+ subroutine foo(c)
+ external c
+ complex c
+now results in
+ /* Complex */ int (*c) ();
+(as, indeed, it once did) rather than
+ complex (*c) ();
+
+Sat Apr 14 22:50:39 EDT 1990:
+ libI77/makefile: updated "make check" to omit lio.c
+ lib[FI]77/makefile: trivial change: define CC = cc, reference $(CC).
+ (Request, e.g., "libi77 from f2c" -- you can't ask for individual
+files from lib[FI]77.)
+
+Wed Apr 18 00:56:37 EDT 1990:
+ Move declaration of atof() from defs.h to sysdep.h, where it is
+now not declared if stdlib.h is included. (NeXT's stdlib.h has a
+#define atof that otherwise wreaks havoc.)
+ Under -u, provide a more intelligible error message (than "bad tag")
+for an attempt to define a function without specifying its type.
+
+Wed Apr 18 17:26:27 EDT 1990:
+ Recognize \v (vertical tab) in Hollerith as well as quoted strings;
+add recognition of \r (carriage return).
+ New option -!bs turns off recognition of escapes in character strings
+(\0, \\, \b, \f, \n, \r, \t, \v).
+ Move to sysdep.c initialization of some arrays whose initialization
+assumed ASCII; #define Table_size in sysdep.h rather than using
+hard-coded 256 in allocating arrays of size 1 << (bits/byte).
+
+Thu Apr 19 08:13:21 EDT 1990:
+ Warn when escapes would make Hollerith extend beyond statement end.
+ Omit max() definition from misc.c (should be invisible except on
+systems that erroneously #define max in stdlib.h).
+
+Mon Apr 23 22:24:51 EDT 1990:
+ When producing default-style C (no -A or -C++), cast switch
+expressions to (int).
+ Move "-lF77 -lI77 -lm -lc" to link_msg, defined in sysdep.c .
+ Add #define scrub(x) to sysdep.h, with invocations in format.c and
+formatdata.c, so that people who have systems like VMS that would
+otherwise create multiple versions of intermediate files can
+#define scrub(x) unlink(x)
+
+Tue Apr 24 18:28:36 EDT 1990:
+ Pass string lengths once rather than twice to a function of character
+arguments involved in comparison of character strings of length 1.
+
+Fri Apr 27 13:11:52 EDT 1990:
+ Fix bug that made f2c gag on concatenations involving char(...) on
+some systems.
+
+Sat Apr 28 23:20:16 EDT 1990:
+ Fix control-stack bug in
+ if(...) then
+ else if (complicated condition)
+ else
+ endif
+(where the complicated condition causes assignment to an auxiliary
+variable, e.g., max(a*b,c)).
+
+Mon Apr 30 13:30:10 EDT 1990:
+ Change fillers for DATA with holes from substructures to arrays
+(in an attempt to make things work right with C compilers that have
+funny padding rules for substructures, e.g., Sun C compilers).
+ Minor cleanup of exec.c (should not affect generated C).
+
+Mon Apr 30 23:13:51 EDT 1990:
+ Fix bug in handling return values of functions having multiple
+entry points of differing return types.
+
+Sat May 5 01:45:18 EDT 1990:
+ Fix type inference bug in
+ subroutine foo(x)
+ call goo(x)
+ end
+ subroutine goo(i)
+ i = 3
+ end
+Instead of warning of inconsistent calling sequences for goo,
+f2c was simply making i a real variable; now i is correctly
+typed as an integer variable, and f2c issues an error message.
+ Adjust error messages issued at end of declarations so they
+don't blame the first executable statement.
+
+Sun May 6 01:29:07 EDT 1990:
+ Fix bug in -P and -Ps: warn when the definition of a subprogram adds
+information that would change prototypes or previous declarations.
+
+Thu May 10 18:09:15 EDT 1990:
+ Fix further obscure bug with (default) -it: inconsistent calling
+sequences and I/O statements could interact to cause a memory fault.
+Example:
+ SUBROUTINE FOO
+ CALL GOO(' Something') ! Forgot integer first arg
+ END
+ SUBROUTINE GOO(IUNIT,MSG)
+ CHARACTER*(*)MSG
+ WRITE(IUNIT,'(1X,A)') MSG
+ END
+
+Fri May 11 16:49:11 EDT 1990:
+ Under -!c, do not delete any .c files (when there are errors).
+ Avoid dereferencing 0 when a fatal error occurs while reading
+Fortran on stdin.
+
+Wed May 16 18:24:42 EDT 1990:
+ f2c.ps made available.
+
+Mon Jun 4 12:53:08 EDT 1990:
+ Diagnose I/O units of invalid type.
+ Add specific error msg about dummy arguments in common.
+
+Wed Jun 13 12:43:17 EDT 1990:
+ Under -A, supply a missing "[1]" for CHARACTER*1 variables that appear
+both in a DATA statement and in either COMMON or EQUIVALENCE.
+
+Mon Jun 18 16:58:31 EDT 1990:
+ Trivial updates to f2c.ps . ("Fortran 8x" --> "Fortran 90"; omit
+"(draft)" from "(draft) ANSI C".)
+
+Tue Jun 19 07:36:32 EDT 1990:
+ Fix incorrect code generated for ELSE IF(expression involving
+function call passing non-constant substring).
+ Under -h, preserve the property that strings are null-terminated
+where possible.
+ Remove spaces between # and define in lex.c output.c parse.h .
+
+Mon Jun 25 07:22:59 EDT 1990:
+ Minor tweak to makefile to reduce unnecessary recompilations.
+
+Tue Jun 26 11:49:53 EDT 1990:
+ Fix unintended truncation of some integer constants on machines
+where casting a long to (int) may change the value. E.g., when f2c
+ran on machines with 16-bit ints, "i = 99999" was being translated
+to "i = -31073;".
+
+Wed Jun 27 11:05:32 EDT 1990:
+ Arrange for CHARACTER-valued PARAMETERs to honor their length
+specifications. Allow CHAR(nn) in expressions defining such PARAMETERs.
+
+Fri Jul 20 09:17:30 EDT 1990:
+ Avoid dereferencing 0 when a FORMAT statement has no label.
+
+Thu Jul 26 11:09:39 EDT 1990:
+ Remarks about VOID and binread,binwrite added to README.
+ Tweaks to parse_args: should be invisible unless your compiler
+complained at (short)*store.
+
+Thu Aug 2 02:07:58 EDT 1990:
+ f2c.ps: change the first line of page 5 from
+ include stuff
+to
+ include 'stuff'
+
+Tue Aug 14 13:21:24 EDT 1990:
+ libi77: libI77 adjusted to treat tabs as spaces in list input.
+
+Fri Aug 17 07:24:53 EDT 1990:
+ libi77: libI77 adjusted so a blank='ZERO' clause (upper case Z)
+in an open of a currently open file works right.
+
+Tue Aug 28 01:56:44 EDT 1990:
+ Fix bug in warnings of inconsistent calling sequences: if an
+argument to a subprogram was never referenced, then a previous
+invocation of the subprogram (in the same source file) that
+passed something of the wrong type for that argument did not
+elicit a warning message.
+
+Thu Aug 30 09:46:12 EDT 1990:
+ libi77: prevent embedded blanks in list output of complex values;
+omit exponent field in list output of values of magnitude between
+10 and 1e8; prevent writing stdin and reading stdout or stderr;
+don't close stdin, stdout, or stderr when reopening units 5, 6, 0.
+
+Tue Sep 4 12:30:57 EDT 1990:
+ Fix bug in C emitted under -I2 or -i2 for INTEGER*4 FUNCTION.
+ Warn of missing final END even if there are previous errors.
+
+Fri Sep 7 13:55:34 EDT 1990:
+ Remark about "make xsum.out" and "make f2c" added to README.
+
+Tue Sep 18 23:50:01 EDT 1990:
+ Fix null dereference (and, on some systems, writing of bogus *_com.c
+files) under -ec or -e1c when a prototype file (*.p or *.P) describes
+COMMON blocks that do not appear in the Fortran source.
+ libi77:
+ Add some #ifdef lines (#ifdef MSDOS, #ifndef MSDOS) to avoid
+references to stat and fstat on non-UNIX systems.
+ On UNIX systems, add component udev to unit; decide that old
+and new files are the same iff both the uinode and udev components
+of unit agree.
+ When an open stmt specifies STATUS='OLD', use stat rather than
+access (on UNIX systems) to check the existence of the file (in case
+directories leading to the file have funny permissions and this is
+a setuid or setgid program).
+
+Thu Sep 27 16:04:09 EDT 1990:
+ Supply missing entry for Impldoblock in blksize array of cpexpr
+(in expr.c). No examples are known where this omission caused trouble.
+
+Tue Oct 2 22:58:09 EDT 1990:
+ libf77: test signal(...) == SIG_IGN rather than & 01 in main().
+ libi77: adjust rewind.c so two successive rewinds after a write
+don't clobber the file.
+
+Thu Oct 11 18:00:14 EDT 1990:
+ libi77: minor cleanups: add #include "fcntl.h" to endfile.c, err.c,
+open.c; adjust g_char in util.c for segmented memories; in f_inqu
+(inquire.c), define x appropriately when MSDOS is defined.
+
+Mon Oct 15 20:02:11 EDT 1990:
+ Add #ifdef MSDOS pointer adjustments to mem.c; treat NAME= as a
+synonym for FILE= in OPEN statements.
+
+Wed Oct 17 16:40:37 EDT 1990:
+ libf77, libi77: minor cleanups: _cleanup() and abort() invocations
+replaced by invocations of sig_die in main.c; some error messages
+previously lost in buffers will now appear.
+
+Mon Oct 22 16:11:27 EDT 1990:
+ libf77: separate sig_die from main (for folks who don't want to use
+the main in libF77).
+ libi77: minor tweak to comments in README.
+
+Fri Nov 2 13:49:35 EST 1990:
+ Use two underscores rather than one in generated temporary variable
+names to avoid conflict with COMMON names. f2c.ps updated to reflect
+this change and the NAME= extension introduced 15 Oct.
+ Repair a rare memory fault in io.c .
+
+Mon Nov 5 16:43:55 EST 1990:
+ libi77: changes to open.c (and err.c): complain if an open stmt
+specifies new= and the file already exists (as specified by Fortrans 77
+and 90); allow file= to be omitted in open stmts and allow
+status='replace' (Fortran 90 extensions).
+
+Fri Nov 30 10:10:14 EST 1990:
+ Adjust malloc.c for unusual systems whose sbrk() can return values
+not properly aligned for doubles.
+ Arrange for slightly more helpful and less repetitive warnings for
+non-character variables initialized with character data; these warnings
+are (still) suppressed by -w66.
+
+Fri Nov 30 15:57:59 EST 1990:
+ Minor tweak to README (about changing VOID in f2c.h).
+
+Mon Dec 3 07:36:20 EST 1990:
+ Fix spelling of "character" in f2c.1t.
+
+Tue Dec 4 09:48:56 EST 1990:
+ Remark about link_msg and libf2c added to f2c/README.
+
+Thu Dec 6 08:33:24 EST 1990:
+ Under -U, render label nnn as L_nnn rather than Lnnn.
+
+Fri Dec 7 18:05:00 EST 1990:
+ Add more names from f2c.h (e.g. integer, real) to the c_keywords
+list of names to which an underscore is appended to avoid confusion.
+
+Mon Dec 10 19:11:15 EST 1990:
+ Minor tweaks to makefile (./xsum) and README (binread/binwrite).
+ libi77: a few modifications for POSIX systems; meant to be invisible
+elsewhere.
+
+Sun Dec 16 23:03:16 EST 1990:
+ Fix null dereference caused by unusual erroneous input, e.g.
+ call foo('abc')
+ end
+ subroutine foo(msg)
+ data n/3/
+ character*(*) msg
+ end
+(Subroutine foo is illegal because the character statement comes after a
+data statement.)
+ Use decimal rather than hex constants in xsum.c (to prevent
+erroneous warning messages about constant overflow).
+
+Mon Dec 17 12:26:40 EST 1990:
+ Fix rare extra underscore in character length parameters passed
+for multiple entry points.
+
+Wed Dec 19 17:19:26 EST 1990:
+ Allow generation of C despite error messages about bad alignment
+forced by equivalence.
+ Allow variable-length concatenations in I/O statements, such as
+ open(3, file=bletch(1:n) // '.xyz')
+
+Fri Dec 28 17:08:30 EST 1990:
+ Fix bug under -p with formats and internal I/O "units" in COMMON,
+as in
+ COMMON /FIGLEA/F
+ CHARACTER*20 F
+ F = '(A)'
+ WRITE (*,FMT=F) 'Hello, world!'
+ END
+
+Tue Jan 15 12:00:24 EST 1991:
+ Fix bug when two equivalence groups are merged, the second with
+nonzero offset, and the result is then merged into a common block.
+Example:
+ INTEGER W(3), X(3), Y(3), Z(3)
+ COMMON /ZOT/ Z
+ EQUIVALENCE (W(1),X(1)), (X(2),Y(1)), (Z(3),X(1))
+***** W WAS GIVEN THE WRONG OFFSET
+ Recognize Fortran 90's optional NML= in NAMELIST READs and WRITEs.
+(Currently NML= and FMT= are treated as synonyms -- there's no
+error message if, e.g., NML= specifies a format.)
+ libi77: minor adjustment to allow internal READs from character
+string constants in read-only memory.
+
+Fri Jan 18 22:56:15 EST 1991:
+ Add comment to README about needing to comment out the typedef of
+size_t in sysdep.h on some systems, e.g. Sun 4.1.
+ Fix misspelling of "statement" in an error message in lex.c
+
+Wed Jan 23 00:38:48 EST 1991:
+ Allow hex, octal, and binary constants to have the qualifying letter
+(z, x, o, or b) either before or after the quoted string containing the
+digits. For now this change will not be reflected in f2c.ps .
+
+Tue Jan 29 16:23:45 EST 1991:
+ Arrange for character-valued statement functions to give results of
+the right length (that of the statement function's name).
+
+Wed Jan 30 07:05:32 EST 1991:
+ More tweaks for character-valued statement functions: an error
+check and an adjustment so a right-hand side of nonconstant length
+(e.g., a substring) is handled right.
+
+Wed Jan 30 09:49:36 EST 1991:
+ Fix p1_head to avoid printing (char *)0 with %s.
+
+Thu Jan 31 13:53:44 EST 1991:
+ Add a test after the cleanup call generated for I/O statements with
+ERR= or END= clauses to catch the unlikely event that the cleanup
+routine encounters an error.
+
+Mon Feb 4 08:00:58 EST 1991:
+ Minor cleanup: omit unneeded jumps and labels from code generated for
+some NAMELIST READs and WRITEs with IOSTAT=, ERR=, and/or END=.
+
+Tue Feb 5 01:39:36 EST 1991:
+ Change Mktemp to mktmp (for the benefit of systems so brain-damaged
+that they do not distinguish case in external names -- and that for
+some reason want to load mktemp). Try to get xsum0.out right this
+time (it somehow didn't get updated on 4 Feb. 1991).
+ Add note to libi77/README about adjusting the interpretation of
+RECL= specifiers in OPENs for direct unformatted I/O.
+
+Thu Feb 7 17:24:42 EST 1991:
+ New option -r casts values of REAL functions, including intrinsics,
+to REAL. This only matters for unportable code like
+ real r
+ r = asin(1.)
+ if (r .eq. asin(1.)) ...
+[The behavior of such code varies with the Fortran compiler used --
+and sometimes is affected by compiler options.] For now, the man page
+at the end of f2c.ps is the only part of f2c.ps that reflects this new
+option.
+
+Fri Feb 8 18:12:51 EST 1991:
+ Cast pointer differences passed as arguments to the appropriate type.
+This matters, e.g., with MSDOS compilers that yield a long pointer
+difference but have int == short.
+ Disallow nonpositive dimensions.
+
+Fri Feb 15 12:24:15 EST 1991:
+ Change %d to %ld in sprintf call in putpower in putpcc.c.
+ Free more memory (e.g. allowing translation of larger Fortran
+files under MS-DOS).
+ Recognize READ (character expression) and WRITE (character expression)
+as formatted I/O with the format given by the character expression.
+ Update year in Notice.
+
+Sat Feb 16 00:42:32 EST 1991:
+ Recant recognizing WRITE(character expression) as formatted output
+-- Fortran 77 is not symmetric in its syntax for READ and WRITE.
+
+Mon Mar 4 15:19:42 EST 1991:
+ Fix bug in passing the real part of a complex argument to an intrinsic
+function. Omit unneeded parentheses in nested calls to intrinsics.
+Example:
+ subroutine foo(x, y)
+ complex y
+ x = exp(sin(real(y))) + exp(imag(y))
+ end
+
+Fri Mar 8 15:05:42 EST 1991:
+ Fix a comment in expr.c; omit safstrncpy.c (which had bugs in
+cases not used by f2c).
+
+Wed Mar 13 02:27:23 EST 1991:
+ Initialize firstmemblock->next in mem_init in mem.c . [On most
+systems it was fortuituously 0, but with System V, -lmalloc could
+trip on this missed initialization.]
+
+Wed Mar 13 11:47:42 EST 1991:
+ Fix a reference to freed memory.
+
+Wed Mar 27 00:42:19 EST 1991:
+ Fix a memory fault caused by such illegal Fortran as
+ function foo
+ x = 3
+ logical foo ! declaration among executables
+ foo=.false. ! used to suffer memory fault
+ end
+
+Fri Apr 5 08:30:31 EST 1991:
+ Fix loss of % in some format expressions, e.g.
+ write(*,'(1h%)')
+ Fix botch introduced 27 March 1991 that caused subroutines with
+multiple entry points to have extraneous declarations of ret_val.
+
+Fri Apr 5 12:44:02 EST 1991
+ Try again to omit extraneous ret_val declarations -- this morning's
+fix was sometimes wrong.
+
+Mon Apr 8 13:47:06 EDT 1991:
+ Arrange for s_rnge to have the right prototype under -A -C .
+
+Wed Apr 17 13:36:03 EDT 1991:
+ New fatal error message for apparent invocation of a recursive
+statement function.
+
+Thu Apr 25 15:13:37 EDT 1991:
+ F2c and libi77 adjusted so NAMELIST works with -i2. (I forgot
+about -i2 when adding NAMELIST.) This required a change to f2c.h
+(that only affects NAMELIST I/O under -i2.) Man-page description of
+-i2 adjusted to reflect that -i2 stores array lengths in short ints.
+
+Fri Apr 26 02:54:41 EDT 1991:
+ Libi77: fix some bugs in NAMELIST reading of multi-dimensional arrays
+(file rsne.c).
+
+Thu May 9 02:13:51 EDT 1991:
+ Omit a trailing space in expr.c (could cause a false xsum value if
+a mailer drops the trailing blank).
+
+Thu May 16 13:14:59 EDT 1991:
+ Libi77: increase LEFBL in lio.h to overcome a NeXT bug.
+ Tweak for compilers that recognize "nested" comments: inside comments,
+turn /* into /+ (as well as */ into +/).
+
+Sat May 25 11:44:25 EDT 1991:
+ libf77: s_rnge: declare line long int rather than int.
+
+Fri May 31 07:51:50 EDT 1991:
+ libf77: system_: officially return status.
+
+Mon Jun 17 16:52:53 EDT 1991:
+ Minor tweaks: omit unnecessary declaration of strcmp (that caused
+trouble on a system where strcmp was a macro) from misc.c; add
+SHELL = /bin/sh to makefiles.
+ Fix a dereference of null when a CHARACTER*(*) declaration appears
+(illegally) after DATA. Complain only once per subroutine about
+declarations appearing after DATA.
+
+Mon Jul 1 00:28:13 EDT 1991:
+ Add test and error message for illegal use of subroutine names, e.g.
+ SUBROUTINE ZAP(A)
+ ZAP = A
+ END
+
+Mon Jul 8 21:49:20 EDT 1991:
+ Issue a warning about things like
+ integer i
+ i = 'abc'
+(which is treated as i = ichar('a')). [It might be nice to treat 'abc'
+as an integer initialized (in a DATA statement) with 'abc', but
+other matters have higher priority.]
+ Render
+ i = ichar('A')
+as
+ i = 'A';
+rather than
+ i = 65;
+(which assumes ASCII).
+
+Fri Jul 12 07:41:30 EDT 1991:
+ Note added to README about erroneous definitions of __STDC__ .
+
+Sat Jul 13 13:38:54 EDT 1991:
+ Fix bugs in double type convesions of complex values, e.g.
+sngl(real(...)) or dble(real(...)) (where ... is complex).
+
+Mon Jul 15 13:21:42 EDT 1991:
+ Fix bug introduced 8 July 1991 that caused erroneous warnings
+"ichar([first char. of] char. string) assumed for conversion to numeric"
+when a subroutine had an array of character strings as an argument.
+
+Wed Aug 28 01:12:17 EDT 1991:
+ Omit an unused function in format.c, an unused variable in proc.c .
+ Under -r8, promote complex to double complex (as the man page claims).
+
+Fri Aug 30 17:19:17 EDT 1991:
+ f2c.ps updated: slightly expand description of intrinsics and,or,xor,
+not; add mention of intrinsics lshift, rshift; add note about f2c
+accepting Fortran 90 inline comments (starting with !); update Cobalt
+Blue address.
+
+Tue Sep 17 07:17:33 EDT 1991:
+ libI77: err.c and open.c modified to use modes "rb" and "wb"
+when (f)opening unformatted files; README updated to point out
+that it may be necessary to change these modes to "r" and "w"
+on some non-ANSI systems.
+
+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.
--- /dev/null
+
+====== 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
--- /dev/null
+LIST
+libF77
+libI77
--- /dev/null
+LIST
+libF77
+libI77
public / ack.git / commitdiff