ceriel 33 years ago
parent
commit
b62d0feed1
69 changed files with 31026 additions and 0 deletions
  1. 7 0
      lang/fortran/.distr
  2. 1184 0
      lang/fortran/changes
  3. 60 0
      lang/fortran/comp/.distr
  4. 23 0
      lang/fortran/comp/Notice
  5. 73 0
      lang/fortran/comp/README
  6. 178 0
      lang/fortran/comp/cds.c
  7. 436 0
      lang/fortran/comp/data.c
  8. 289 0
      lang/fortran/comp/defines.h
  9. 769 0
      lang/fortran/comp/defs.h
  10. 372 0
      lang/fortran/comp/equiv.c
  11. 252 0
      lang/fortran/comp/error.c
  12. 831 0
      lang/fortran/comp/exec.c
  13. 2882 0
      lang/fortran/comp/expr.c
  14. 182 0
      lang/fortran/comp/f2c.1
  15. 326 0
      lang/fortran/comp/f2c.1t
  16. 317 0
      lang/fortran/comp/f2c.6
  17. 209 0
      lang/fortran/comp/f2c.h
  18. 2108 0
      lang/fortran/comp/format.c
  19. 10 0
      lang/fortran/comp/format.h
  20. 1037 0
      lang/fortran/comp/formatdata.c
  21. 39 0
      lang/fortran/comp/ftypes.h
  22. 399 0
      lang/fortran/comp/gram.dcl
  23. 143 0
      lang/fortran/comp/gram.exec
  24. 141 0
      lang/fortran/comp/gram.expr
  25. 299 0
      lang/fortran/comp/gram.head
  26. 173 0
      lang/fortran/comp/gram.io
  27. 446 0
      lang/fortran/comp/init.c
  28. 846 0
      lang/fortran/comp/intr.c
  29. 1416 0
      lang/fortran/comp/io.c
  30. 24 0
      lang/fortran/comp/iob.h
  31. 1453 0
      lang/fortran/comp/lex.c
  32. 31 0
      lang/fortran/comp/machdefs.h
  33. 590 0
      lang/fortran/comp/main.c
  34. 84 0
      lang/fortran/comp/makefile
  35. 142 0
      lang/fortran/comp/malloc.c
  36. 230 0
      lang/fortran/comp/mem.c
  37. 66 0
      lang/fortran/comp/memset.c
  38. 1041 0
      lang/fortran/comp/misc.c
  39. 711 0
      lang/fortran/comp/names.c
  40. 22 0
      lang/fortran/comp/names.h
  41. 367 0
      lang/fortran/comp/niceprintf.c
  42. 16 0
      lang/fortran/comp/niceprintf.h
  43. 1431 0
      lang/fortran/comp/output.c
  44. 65 0
      lang/fortran/comp/output.h
  45. 160 0
      lang/fortran/comp/p1defs.h
  46. 568 0
      lang/fortran/comp/p1output.c
  47. 39 0
      lang/fortran/comp/parse.h
  48. 499 0
      lang/fortran/comp/parse_args.c
  49. 64 0
      lang/fortran/comp/pccdefs.h
  50. 881 0
      lang/fortran/comp/pread.c
  51. 1562 0
      lang/fortran/comp/proc.c
  52. 373 0
      lang/fortran/comp/proto.make
  53. 399 0
      lang/fortran/comp/put.c
  54. 1781 0
      lang/fortran/comp/putpcc.c
  55. 16 0
      lang/fortran/comp/string.h
  56. 441 0
      lang/fortran/comp/sysdep.c
  57. 83 0
      lang/fortran/comp/sysdep.h
  58. 99 0
      lang/fortran/comp/tokens
  59. 7 0
      lang/fortran/comp/usignal.h
  60. 325 0
      lang/fortran/comp/vax.c
  61. 2 0
      lang/fortran/comp/version.c
  62. 174 0
      lang/fortran/comp/xsum.c
  63. 56 0
      lang/fortran/comp/xsum0.out
  64. 15 0
      lang/fortran/disclaimer
  65. 180 0
      lang/fortran/fc
  66. 1184 0
      lang/fortran/fixes
  67. 392 0
      lang/fortran/index
  68. 3 0
      lang/fortran/lib/.distr
  69. 3 0
      lang/fortran/lib/LIST

+ 7 - 0
lang/fortran/.distr

@@ -0,0 +1,7 @@
+changes
+comp
+disclaimer
+fc
+fixes
+index
+lib

+ 1184 - 0
lang/fortran/changes

@@ -0,0 +1,1184 @@
+31 Aug. 1989:
+   1. A(min(i,j)) now is translated correctly (where A is an array).
+   2. 7 and 8 character variable names are allowed (but elicit a
+      complaint under -ext).
+   3. LOGICAL*1 is treated as LOGICAL, with just one error message
+      per LOGICAL*1 statement (rather than one per variable declared
+      in that statement).  [Note that LOGICAL*1 is not in Fortran 77.]
+      Like f77, f2c now allows the format in a read or write statement
+      to be an integer array.
+
+5 Sept. 1989:
+   Fixed botch in argument passing of substrings of equivalenced
+variables.
+
+15 Sept. 1989:
+   Warn about incorrect code generated when a character-valued
+function is not declared external and is passed as a parameter
+(in violation of the Fortran 77 standard) before it is invoked.
+Example:
+
+	subroutine foo(a,b)
+	character*10 a,b
+	call goo(a,b)
+	b = a(3)
+	end
+
+18 Sept. 1989:
+   Complain about overlapping initializations.
+
+20 Sept. 1989:
+   Warn about names declared EXTERNAL but never referenced;
+include such names as externs in the generated C (even
+though most C compilers will discard them).
+
+24 Sept. 1989:
+   New option -w8 to suppress complaint when COMMON or EQUIVALENCE
+forces word alignment of a double.
+   Under -A (for ANSI C), ensure that floating constants (terminated
+by 'f') contain either a decimal point or an exponent field.
+   Repair bugs sometimes encountered with CHAR and ICHAR intrinsic
+functions.
+   Restore f77's optimizations for copying and comparing character
+strings of length 1.
+   Always assume floating-point valued routines in libF77 return
+doubles, even under -R.
+   Repair occasional omission of arguments in routines having multiple
+entry points.
+   Repair bugs in computing offsets of character strings involved
+in EQUIVALENCE.
+   Don't omit structure qualification when COMMON variables are used
+as FORMATs or internal files.
+
+2 Oct. 1989:
+   Warn about variables that appear only in data stmts; don't emit them.
+   Fix bugs in character DATA for noncharacter variables
+involved in EQUIVALENCE.
+   Treat noncharacter variables initialized (at least partly) with
+character data as though they were equivalenced -- put out a struct
+and #define the variables.  This eliminates the hideous and nonportable
+numeric values that were used to initialize such variables.
+   Treat IMPLICIT NONE as IMPLICIT UNDEFINED(A-Z) .
+   Quit when given invalid options.
+
+8 Oct. 1989:
+  Modified naming scheme for generated intermediate variables;
+more are recycled, fewer distinct ones used.
+  New option -W nn specifies nn characters/word for Hollerith
+data initializing non-character variables.
+  Bug fix: x(i:min(i+10,j)) used to elicit "Can't handle opcode 31 yet".
+  Integer expressions of the form (i+const1) - (i+const2), where
+i is a scalar integer variable, are now simplified to (const1-const2);
+this leads to simpler translation of some substring expressions.
+  Initialize uninitialized portions of character string arrays to 0
+rather than to blanks.
+
+9 Oct. 1989:
+  New option -c to insert comments showing original Fortran source.
+  New option -g to insert line numbers of original Fortran source.
+
+10 Oct. 1989:
+  ! recognized as in-line comment delimiter (a la Fortran 88).
+
+24 Oct. 1989:
+  New options to ease coping with systems that want the structs
+that result from COMMON blocks to be defined just once:
+  -E causes uninitialized COMMON blocks to be declared Extern;
+if Extern is undefined, f2c.h #defines it to be extern.
+  -ec causes a separate .c file to be emitted for each
+uninitialized COMMON block: COMMON /ABC/ yields abc_com.c;
+thus one can compile *_com.c into a library to ensure
+precisely one definition.
+  -e1c is similar to -ec, except that everything goes into
+one file, along with comments that give a sed script for
+splitting the file into the pieces that -ec would give.
+This is for use with netlib's "execute f2c" service (for which
+-ec is coerced into -e1c, and the sed script will put everything
+but the COMMON definitions into f2c_out.c ).
+
+28 Oct. 1989:
+  Convert "i = i op ..." into "i op= ...;" even when i is a
+dummy argument.
+
+13 Nov. 1989:
+  Name integer constants (passed as arguments) c__... rather
+than c_... so
+	common /c/stuff
+	call foo(1)
+	...
+is translated correctly.
+
+19 Nov. 1989:
+  Floating-point constants are now kept as strings unless they
+are involved in constant expressions that get simplified.  The
+floating-point constants kept as strings can have arbitrarily
+many significant figures and a very large exponent field (as
+large as long int allows on the machine on which f2c runs).
+Thus, for example, the body of
+
+	subroutine zot(x)
+	double precision x(6), pi
+	parameter (pi=3.1415926535897932384626433832795028841972)
+	x(1) = pi
+	x(2) = pi+1
+	x(3) = 9287349823749272.7429874923740978492734D-298374
+	x(4) = .89
+	x(5) = 4.0005
+	x(6) = 10D7
+	end
+
+now gets translated into
+
+    x[1] = 3.1415926535897932384626433832795028841972;
+    x[2] = 4.1415926535897931;
+    x[3] = 9.2873498237492727429874923740978492734e-298359;
+    x[4] = (float).89;
+    x[5] = (float)4.0005;
+    x[6] = 1e8;
+
+rather than the former
+
+    x[1] = 3.1415926535897931;
+    x[2] = 4.1415926535897931;
+    x[3] = 0.;
+    x[4] = (float)0.89000000000000003;
+    x[5] = (float)4.0004999999999997;
+    x[6] = 100000000.;
+
+  Recognition of f77 machine-constant intrinsics deleted, i.e.,
+epbase, epprec, epemin, epemax, eptiny, ephuge, epmrsp.
+
+22 Nov. 1989:
+  Workarounds for glitches on some Sun systems...
+  libf77: libF77/makefile modified to point out possible need
+to compile libF77/main.c with -Donexit=on_exit .
+  libi77: libI77/wref.c (and libI77/README) modified so non-ANSI
+systems can compile with USE_STRLEN defined, which will cause
+	sprintf(b = buf, "%#.*f", d, x);
+	n = strlen(b) + d1;
+rather than
+	n = sprintf(b = buf, "%#.*f", d, x) + d1;
+to be compiled.
+
+26 Nov. 1989:
+  Longer names are now accepted (up to 50 characters); names may
+contain underscores (in which case they will have two underscores
+appended, to avoid clashes with library names).
+
+28 Nov. 1989:
+  libi77 updated:
+	1. Allow 3 (or, on Crays, 4) digit exponents under format Ew.d .
+	2. Try to get things right on machines where ints have 16 bits.
+
+29 Nov. 1989:
+  Supplied missing semicolon in parameterless subroutines that
+have multiple entry points (all of them parameterless).
+
+30 Nov. 1989:
+  libf77 and libi77 revised to use types from f2c.h.
+  f2c now types floating-point valued C library routines as "double"
+rather than "doublereal" (for use with nonstandard C compilers for
+which "double" is IEEE double extended).
+
+1 Dec. 1989:
+  f2c.h updated to eliminate #defines rendered unnecessary (and,
+indeed, dangerous) by change of 26 Nov. to long names possibly
+containing underscores.
+  libi77 further revised: yesterday's change omitted two tweaks to fmt.h
+(tweaks which only matter if float and real or double and doublereal are
+different types).
+
+2 Dec. 1989:
+  Better error message (than "bad tag") for NAMELIST, which no longer
+inhibits C output.
+
+4 Dec. 1989:
+  Allow capital letters in hex constants (f77 extension; e.g.,
+x'a012BCd', X'A012BCD' and x'a012bcd' are all treated as the integer
+167848909).
+  libi77 further revised: lio.c lio.h lread.c wref.c wrtfmt.c tweaked
+again to allow float and real or double and doublereal to be different.
+
+6 Dec. 1989:
+  Revised f2c.h -- required for the following...
+  Simpler looking translations for abs, min, max, using #defines in
+revised f2c.h .
+  libi77: more corrections to types; additions for NAMELIST.
+  Corrected casts in some I/O calls.
+  Translation of NAMELIST; libi77 must still be revised.  Currently
+libi77 gives you a run-time error message if you attempt NAMELIST I/O.
+
+7 Dec. 1989:
+  Fixed bug that prevented local integer variables that appear in DATA
+stmts from being ASSIGNed statement labels.
+  Fillers (for DATA statements initializing EQUIVALENCEd variables and
+variables in COMMON) typed integer rather than doublereal (for slightly
+more portability, e.g. to Crays).
+  libi77: missing return values supplied in a few places; some tests
+reordered for better working on the Cray.
+  libf77: better accuracy for complex divide, complex square root,
+real mod function (casts to double; double temporaries).
+
+9 Dec. 1989:
+  Fixed bug that caused needless (albeit harmless) empty lines to be
+inserted in the C output when a comment line contained trailing blanks.
+  Further tweak to type of fillers: allow doublereal fillers if the
+struct has doublereal data.
+
+11 Dec. 1989:
+  Alteration of rule for producing external (C) names from names that
+contain underscores.  Now the external name is always obtained by
+appending a pair of underscores.
+
+12 Dec. 1989:
+  C production inhibited after most errors.
+
+15 Dec. 1989:
+  Fixed bug in headers for subroutines having two or more character
+strings arguments:  the length arguments were reversed.
+
+19 Dec. 1989:
+  f2c.h libf77 libi77: adjusted so #undefs in f2c.h should not foil
+compilation of libF77 and libI77.
+  libf77: getenv_ adjusted to work with unsorted environments.
+  libi77: the iostat= specifier should now work right with internal I/O.
+
+20 Dec. 1989:
+  f2c bugs fixed: In the absence of an err= specifier, the iostat=
+specifier was generally set wrong.  Character strings containing
+explicit nulls (\0) were truncated at the first null.
+  Unlabeled DO loops recognized; must be terminated by ENDDO.
+(Don't ask for CYCLE, EXIT, named DO loops, or DO WHILE.)
+
+29 Dec. 1989:
+  Nested unlabeled DO loops now handled properly; new warning for
+extraneous text at end of FORMAT.
+
+30 Dec. 1989:
+  Fixed bug in translating dble(real(...)), dble(sngl(...)), and
+dble(float(...)), where ... is either of type double complex or
+is an expression requiring assignment to intermediate variables (e.g.,
+dble(real(foo(x+1))), where foo is a function and x is a variable).
+Regard nonblank label fields on continuation lines as an error.
+
+3 Jan. 1990:
+  New option -C++ yields output that should be understood
+by C++ compilers.
+
+6 Jan. 1989:
+  -a now excludes variables that appear in a namelist from those
+that it makes automatic.  (As before, it also excludes variables
+that appear in a common, data, equivalence, or save statement.)
+  The syntactically correct Fortran
+	read(*,i) x
+	end
+now yields syntactically correct C (even though both the Fortran
+and C are buggy -- no FORMAT has not been ASSIGNed to i).
+
+7 Jan. 1990:
+  libi77: routines supporting NAMELIST added.  Surrounding quotes
+made optional when no ambiguity arises in a list or namelist READ
+of a character-string value.
+
+9 Jan. 1990:
+  f2c.src made available.
+
+16 Jan. 1990:
+  New options -P to produce ANSI C or C++ prototypes for procedures
+defined.  Change to -A and -C++: f2c tries to infer prototypes for
+invoked procedures unless the new -!P option is given.  New warning
+messages for inconsistent calling sequences among procedures within
+a single file.  Most of f2c/src is affected.
+  f2c.h: typedefs for procedure arguments added; netlib's f2c service
+will insert appropriate typedefs for use with older versions of f2c.h.
+
+17 Jan. 1990:
+  f2c/src: defs.h exec.c format.c proc.c putpcc.c version.c xsum0.out
+updated.  Castargs and protofile made extern in defs.h; exec.c
+modified so superfluous else clauses are diagnosed; unused variables
+omitted from declarations in format.c proc.c putpcc.c .
+
+21 Jan. 1990:
+  No C emitted for procedures declared external but not referenced.
+  f2c.h: more new types added for use with -P.
+  New feature: f2c accepts as arguments files ending in .p or .P;
+such files are assumed to be prototype files, such as produced by
+the -P option.  All prototype files are read before any Fortran files
+and apply globally to all Fortran files.  Suitable prototypes help f2c
+warn about calling-sequence errors and can tell f2c how to type
+procedures declared external but not explicitly typed; the latter is
+mainly of interest for users of the -A and -C++ options.  (Prototype
+arguments are not available to netlib's "execute f2c" service.)
+  New option -it tells f2c to try to infer types of untyped external
+arguments from their use as parameters to prototyped or previously
+defined procedures.
+  f2c/src: many minor cleanups; most modules changed.  Individual
+files in f2c/src are now in "bundle" format.  The former f2c.1 is
+now f2c.1t; "f2c.1t from f2c" and "f2c.1t from f2c/src" are now the
+same, as are "f2c.1 from f2c" and "f2c.1 from f2c/src".  People who
+do not obtain a new copy of "all from f2c/src" should at least add
+	fclose(sortfp);
+after the call on do_init_data(outfile, sortfp) in format_data.c .
+
+22 Jan. 1990:
+  Cleaner man page wording (thanks to Doug McIlroy).
+  -it now also applies to all untyped EXTERNAL procedures, not just
+arguments.
+
+23 Jan. 01:34:00 EST 1990:
+  Bug fixes: under -A and -C++, incorrect C was generated for
+subroutines having multiple entries but no arguments.
+  Under -A -P, subroutines of no arguments were given prototype
+calling sequence () rather than (void).
+  Character-valued functions elicited erroneous warning messages
+about inconsistent calling sequences when referenced by another
+procedure in the same file.
+  f2c.1t: omit first appearance of libF77.a in FILES section;
+load order of libraries is -lF77 -lI77, not vice versa (bug
+introduced in yesterday's edits); define .F macro for those whose
+-man lacks it.  (For a while after yesterday's fixes were posted,
+f2c.1t was out of date.  Sorry!)
+
+23 Jan. 9:53:24 EST 1990:
+  Character substring expressions involving function calls having
+character arguments (including the intrinsic len function) yielded
+incorrect C.
+  Procedures defined after invocation (in the same file) with
+conflicting argument types also got an erroneous message about
+the wrong number of arguments.
+
+24 Jan. 11:44:00 EST 1990:
+  Bug fixes: -p omitted #undefs; COMMON block names containing
+underscores had their C names incorrectly computed; a COMMON block
+having the name of a previously defined procedure wreaked havoc;
+if all arguments were .P files, f2c tried reading the second as a
+Fortran file.
+  New feature: -P emits comments showing COMMON block lengths, so one
+can get warnings of incompatible COMMON block lengths by having f2c
+read .P (or .p) files.  Now by running f2c twice, first with -P -!c
+(or -P!c),  then with *.P among the arguments, you can be warned of
+inconsistent COMMON usage, and COMMON blocks having inconsistent
+lengths will be given the maximum length.  (The latter always did
+happen within each input file; now -P lets you extend this behavior
+across files.)
+
+26 Jan. 16:44:00 EST 1990:
+  Option -it made less aggressive: untyped external procedures that
+are invoked are now typed by the rules of Fortran, rather than by
+previous use of procedures to which they are passed as arguments
+before being invoked.
+  Option -P now includes information about references, i.e., called
+procedures, in the prototype files (in the form of special comments).
+This allows iterative invocations of f2c to infer more about untyped
+external names, particularly when multiple Fortran files are involved.
+  As usual, there are some obscure bug fixes:
+1.  Repair of erroneous warning messages about inconsistent number of
+arguments that arose when a character dummy parameter was discovered
+to be a function or when multiple entry points involved character
+variables appearing in a previous entry point.
+2.  Repair of memory fault after error msg about "adjustable character
+function".
+3.  Under -U, allow MAIN_ as a subroutine name (in the same file as a
+main program).
+4.  Change for consistency: a known function invoked as a subroutine,
+then as a function elicits a warning rather than an error.
+
+26 Jan. 22:32:00 EST 1990:
+  Fixed two bugs that resulted in incorrect C for substrings, within
+the body of a character-valued function, of the function's name, when
+those substrings were arguments to another function (even implicitly,
+as in character-string assignment).
+
+28 Jan. 18:32:00 EST 1990:
+  libf77, libi77: checksum files added; "make check" looks for
+transmission errors.  NAMELIST read modified to allow $ rather than &
+to precede a namelist name, to allow $ rather than / to terminate
+input where the name of another variable would otherwise be expected,
+and to regard all nonprinting ASCII characters <= ' ' as spaces.
+
+29 Jan. 02:11:00 EST 1990:
+  "fc from f2c" added.
+  -it option made the default; -!it turns it off.  Type information is
+now updated in a previously missed case.
+  -P option tweaked again; message about when rerunning f2c may change
+prototypes or declarations made more accurate.
+  New option -Ps implies -P and returns exit status 4 if rerunning
+f2c -P with prototype inputs might change prototypes or declarations.
+Now you can execute a crude script like
+
+	cat *.f >zap.F
+	rm -f zap.P
+	while :; do
+		f2c -Ps -!c zap.[FP]
+		case $? in 4) ;; *) break;; esac
+		done
+
+to get a file zap.P of the best prototypes f2c can determine for *.f .
+
+Jan. 29 07:30:21 EST 1990:
+  Forgot to check for error status when setting return code 4 under -Ps;
+error status (1, 2, 3, or, for caught signal, 126) now takes precedence.
+
+Jan 29 14:17:00 EST 1990:
+  Incorrect handling of
+	open(n,'filename')
+repaired -- now treated as
+	open(n,file='filename')
+(and, under -ext, given an error message).
+  New optional source file memset.c for people whose systems don't
+provide memset, memcmp, and memcpy; #include <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.

+ 60 - 0
lang/fortran/comp/.distr

@@ -0,0 +1,60 @@
+Notice
+README
+cds.c
+data.c
+defines.h
+defs.h
+equiv.c
+error.c
+exec.c
+expr.c
+f2c.1
+f2c.1t
+f2c.6
+f2c.h
+format.c
+format.h
+formatdata.c
+ftypes.h
+gram.dcl
+gram.exec
+gram.expr
+gram.head
+gram.io
+init.c
+intr.c
+io.c
+iob.h
+lex.c
+machdefs.h
+main.c
+makefile
+malloc.c
+mem.c
+memset.c
+misc.c
+names.c
+names.h
+niceprintf.c
+niceprintf.h
+output.c
+output.h
+p1defs.h
+p1output.c
+parse.h
+parse_args.c
+pccdefs.h
+pread.c
+proc.c
+proto.make
+put.c
+putpcc.c
+string.h
+sysdep.c
+sysdep.h
+tokens
+usignal.h
+vax.c
+version.c
+xsum.c
+xsum0.out

+ 23 - 0
lang/fortran/comp/Notice

@@ -0,0 +1,23 @@
+/****************************************************************
+Copyright 1990, 1991 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+

+ 73 - 0
lang/fortran/comp/README

@@ -0,0 +1,73 @@
+Type "make" to check the validity of the f2c source and compile f2c.
+
+If (in accordance with what follows) you need to modify the makefile
+or any of the source files, first issue a "make xsum.out" to check
+the validity of the f2c source, then make your changes, then type
+"make f2c".
+
+The file usignal.h is for the benefit of strictly ANSI include files
+on a UNIX system -- the ANSI signal.h does not define SIGHUP or SIGQUIT.
+You may need to modify usignal.h if you are not running f2c on a UNIX
+system.
+
+Should you get the message "xsum0.out xsum1.out differ", see what lines
+are different (`diff xsum0.out xsum1.out`) and ask netlib to send you
+the files in question "from f2c/src".  For example, if exec.c and
+expr.c have incorrect check sums, you would send netlib the message
+	send exec.c expr.c from f2c/src
+
+On some systems, the malloc and free in malloc.c let f2c run faster
+than do the standard malloc and free.  Other systems cannot tolerate
+redefinition of malloc and free.  If yours is such a system, you may
+either modify the makefile appropriately, or simply execute
+	cc -c -DCRAY malloc.c
+before typing "make".  Still other systems have a -lmalloc that
+provides performance competitive with that from malloc.c; you may
+wish to compare the two on your system.
+
+On some BSD systems, you may need to create a file named "string.h"
+whose single line is
+#include <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.

+ 178 - 0
lang/fortran/comp/cds.c

@@ -0,0 +1,178 @@
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+/* Put strings representing decimal floating-point numbers
+ * into canonical form: always have a decimal point or
+ * exponent field; if using an exponent field, have the
+ * number before it start with a digit and decimal point
+ * (if the number has more than one digit); only have an
+ * exponent field if it saves space.
+ *
+ * Arrange that the return value, rv, satisfies rv[0] == '-' || rv[-1] == '-' .
+ */
+
+#include "sysdep.h"
+
+ char *
+cds(s, z0)
+ char *s, *z0;
+{
+	int ea, esign, et, i, k, nd = 0, sign = 0, tz;
+	char c, *z;
+	char ebuf[24];
+	long ex = 0;
+	static char etype[Table_size], *db;
+	static int dblen = 64;
+
+	if (!db) {
+		etype['E'] = 1;
+		etype['e'] = 1;
+		etype['D'] = 1;
+		etype['d'] = 1;
+		etype['+'] = 2;
+		etype['-'] = 3;
+		db = Alloc(dblen);
+		}
+
+	while((c = *s++) == '0');
+	if (c == '-')
+		{ sign = 1; c = *s++; }
+	else if (c == '+')
+		c = *s++;
+	k = strlen(s) + 2;
+	if (k >= dblen) {
+		do dblen <<= 1;
+			while(k >= dblen);
+		free(db);
+		db = Alloc(dblen);
+		}
+	if (etype[(unsigned char)c] >= 2)
+		while(c == '0') c = *s++;
+	tz = 0;
+	while(c >= '0' && c <= '9') {
+		if (c == '0')
+			tz++;
+		else {
+			if (nd)
+				for(; tz; --tz)
+					db[nd++] = '0';
+			else
+				tz = 0;
+			db[nd++] = c;
+			}
+		c = *s++;
+		}
+	ea = -tz;
+	if (c == '.') {
+		while((c = *s++) >= '0' && c <= '9') {
+			if (c == '0')
+				tz++;
+			else {
+				if (tz) {
+					ea += tz;
+					if (nd)
+						for(; tz; --tz)
+							db[nd++] = '0';
+					else
+						tz = 0;
+					}
+				db[nd++] = c;
+				ea++;
+				}
+			}
+		}
+	if (et = etype[(unsigned char)c]) {
+		esign = et == 3;
+		c = *s++;
+		if (et == 1) {
+			if(etype[(unsigned char)c] > 1) {
+				if (c == '-')
+					esign = 1;
+				c = *s++;
+				}
+			}
+		while(c >= '0' && c <= '9') {
+			ex = 10*ex + (c - '0');
+			c = *s++;
+			}
+		if (esign)
+			ex = -ex;
+		}
+	/* debug */ if (c)
+	/* debug*/	Fatal("unexpected character in cds");
+	ex -= ea;
+	if (!nd) {
+		if (!z0)
+			z0 = mem(4,0);
+		strcpy(z0, "-0.");
+		sign = 0;
+		}
+	else if (ex > 2 || ex + nd < -2) {
+		sprintf(ebuf, "%ld", ex + nd - 1);
+		k = strlen(ebuf) + nd + 3;
+		if (nd > 1)
+			k++;
+		if (!z0)
+			z0 = mem(k,0);
+		z = z0;
+		*z++ = '-';
+		*z++ = *db;
+		if (nd > 1) {
+			*z++ = '.';
+			for(k = 1; k < nd; k++)
+				*z++ = db[k];
+			}
+		*z++ = 'e';
+		strcpy(z, ebuf);
+		}
+	else {
+		k = (int)(ex + nd);
+		i = nd + 3;
+		if (k < 0)
+			i -= k;
+		else if (ex > 0)
+			i += ex;
+		if (!z0)
+			z0 = mem(i,0);
+		z = z0;
+		*z++ = '-';
+		if (ex >= 0) {
+			for(k = 0; k < nd; k++)
+				*z++ = db[k];
+			while(--ex >= 0)
+				*z++ = '0';
+			*z++ = '.';
+			}
+		else {
+			for(i = 0; i < k;)
+				*z++ = db[i++];
+			*z++ = '.';
+			while(++k <= 0)
+				*z++ = '0';
+			while(i < nd)
+				*z++ = db[i++];
+			}
+		*z = 0;
+		}
+	return sign ? z0 : z0+1;
+	}

+ 436 - 0
lang/fortran/comp/data.c

@@ -0,0 +1,436 @@
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+#include "defs.h"
+
+/* ROUTINES CALLED DURING DATA AND PARAMETER STATEMENT PROCESSING */
+
+static char datafmt[] = "%s\t%09ld\t%d";
+static char *cur_varname;
+
+/* another initializer, called from parser */
+dataval(repp, valp)
+register expptr repp, valp;
+{
+	int i, nrep;
+	ftnint elen;
+	register Addrp p;
+	Addrp nextdata();
+
+	if (parstate < INDATA) {
+		frexpr(repp);
+		goto ret;
+		}
+	if(repp == NULL)
+		nrep = 1;
+	else if (ISICON(repp) && repp->constblock.Const.ci >= 0)
+		nrep = repp->constblock.Const.ci;
+	else
+	{
+		err("invalid repetition count in DATA statement");
+		frexpr(repp);
+		goto ret;
+	}
+	frexpr(repp);
+
+	if( ! ISCONST(valp) )
+	{
+		err("non-constant initializer");
+		goto ret;
+	}
+
+	if(toomanyinit) goto ret;
+	for(i = 0 ; i < nrep ; ++i)
+	{
+		p = nextdata(&elen);
+		if(p == NULL)
+		{
+			err("too many initializers");
+			toomanyinit = YES;
+			goto ret;
+		}
+		setdata((Addrp)p, (Constp)valp, elen);
+		frexpr((expptr)p);
+	}
+
+ret:
+	frexpr(valp);
+}
+
+
+Addrp nextdata(elenp)
+ftnint *elenp;
+{
+	register struct Impldoblock *ip;
+	struct Primblock *pp;
+	register Namep np;
+	register struct Rplblock *rp;
+	tagptr p;
+	expptr neltp;
+	register expptr q;
+	int skip;
+	ftnint off, vlen;
+
+	while(curdtp)
+	{
+		p = (tagptr)curdtp->datap;
+		if(p->tag == TIMPLDO)
+		{
+			ip = &(p->impldoblock);
+			if(ip->implb==NULL || ip->impub==NULL || ip->varnp==NULL)
+				fatali("bad impldoblock 0%o", (int) ip);
+			if(ip->isactive)
+				ip->varvp->Const.ci += ip->impdiff;
+			else
+			{
+				q = fixtype(cpexpr(ip->implb));
+				if( ! ISICON(q) )
+					goto doerr;
+				ip->varvp = (Constp) q;
+
+				if(ip->impstep)
+				{
+					q = fixtype(cpexpr(ip->impstep));
+					if( ! ISICON(q) )
+						goto doerr;
+					ip->impdiff = q->constblock.Const.ci;
+					frexpr(q);
+				}
+				else
+					ip->impdiff = 1;
+
+				q = fixtype(cpexpr(ip->impub));
+				if(! ISICON(q))
+					goto doerr;
+				ip->implim = q->constblock.Const.ci;
+				frexpr(q);
+
+				ip->isactive = YES;
+				rp = ALLOC(Rplblock);
+				rp->rplnextp = rpllist;
+				rpllist = rp;
+				rp->rplnp = ip->varnp;
+				rp->rplvp = (expptr) (ip->varvp);
+				rp->rpltag = TCONST;
+			}
+
+			if( (ip->impdiff>0 && (ip->varvp->Const.ci <= ip->implim))
+			    || (ip->impdiff<0 && (ip->varvp->Const.ci >= ip->implim)) )
+			{ /* start new loop */
+				curdtp = ip->datalist;
+				goto next;
+			}
+
+			/* clean up loop */
+
+			if(rpllist)
+			{
+				rp = rpllist;
+				rpllist = rpllist->rplnextp;
+				free( (charptr) rp);
+			}
+			else
+				Fatal("rpllist empty");
+
+			frexpr((expptr)ip->varvp);
+			ip->isactive = NO;
+			curdtp = curdtp->nextp;
+			goto next;
+		}
+
+		pp = (struct Primblock *) p;
+		np = pp->namep;
+		cur_varname = np->fvarname;
+		skip = YES;
+
+		if(p->primblock.argsp==NULL && np->vdim!=NULL)
+		{   /* array initialization */
+			q = (expptr) mkaddr(np);
+			off = typesize[np->vtype] * curdtelt;
+			if(np->vtype == TYCHAR)
+				off *= np->vleng->constblock.Const.ci;
+			q->addrblock.memoffset =
+			    mkexpr(OPPLUS, q->addrblock.memoffset, mkintcon(off) );
+			if( (neltp = np->vdim->nelt) && ISCONST(neltp))
+			{
+				if(++curdtelt < neltp->constblock.Const.ci)
+					skip = NO;
+			}
+			else
+				err("attempt to initialize adjustable array");
+		}
+		else
+			q = mklhs( (struct Primblock *)cpexpr((expptr)pp) );
+		if(skip)
+		{
+			curdtp = curdtp->nextp;
+			curdtelt = 0;
+		}
+		if(q->headblock.vtype == TYCHAR)
+			if(ISICON(q->headblock.vleng))
+				*elenp = q->headblock.vleng->constblock.Const.ci;
+			else	{
+				err("initialization of string of nonconstant length");
+				continue;
+			}
+		else	*elenp = typesize[q->headblock.vtype];
+
+		if (np->vstg == STGBSS) {
+			vlen = np->vtype==TYCHAR
+				? np->vleng->constblock.Const.ci
+				: typesize[np->vtype];
+			if(vlen > 0)
+				np->vstg = STGINIT;
+			}
+		return( (Addrp) q );
+
+doerr:
+		err("nonconstant implied DO parameter");
+		frexpr(q);
+		curdtp = curdtp->nextp;
+
+next:
+		curdtelt = 0;
+	}
+
+	return(NULL);
+}
+
+
+
+LOCAL FILEP dfile;
+
+
+setdata(varp, valp, elen)
+register Addrp varp;
+ftnint elen;
+register Constp valp;
+{
+	struct Constblock con;
+	register int type;
+	int i, k, valtype;
+	ftnint offset;
+	char *dataname(), *varname;
+	static Addrp badvar;
+	register unsigned char *s;
+	static int last_lineno;
+	static char *last_varname;
+
+	if (varp->vstg == STGCOMMON) {
+		if (!(dfile = blkdfile))
+			dfile = blkdfile = opf(blkdfname, textwrite);
+		}
+	else {
+		if (procclass == CLBLOCK) {
+			if (varp != badvar) {
+				badvar = varp;
+				warn1("%s is not in a COMMON block",
+					varp->uname_tag == UNAM_NAME
+					? varp->user.name->fvarname
+					: "???");
+				}
+			return;
+			}
+		if (!(dfile = initfile))
+			dfile = initfile = opf(initfname, textwrite);
+		}
+	varname = dataname(varp->vstg, varp->memno);
+	offset = varp->memoffset->constblock.Const.ci;
+	type = varp->vtype;
+	valtype = valp->vtype;
+	if(type!=TYCHAR && valtype==TYCHAR)
+	{
+		if(! ftn66flag
+		&& (last_varname != cur_varname || last_lineno != lineno)) {
+			/* prevent multiple warnings */
+			last_lineno = lineno;
+			warn1(
+	"non-character datum %.42s initialized with character string",
+				last_varname = cur_varname);
+			}
+		varp->vleng = ICON(typesize[type]);
+		varp->vtype = type = TYCHAR;
+	}
+	else if( (type==TYCHAR && valtype!=TYCHAR) ||
+	    (cktype(OPASSIGN,type,valtype) == TYERROR) )
+	{
+		err("incompatible types in initialization");
+		return;
+	}
+	if(type == TYADDR)
+		con.Const.ci = valp->Const.ci;
+	else if(type != TYCHAR)
+	{
+		if(valtype == TYUNKNOWN)
+			con.Const.ci = valp->Const.ci;
+		else	consconv(type, &con, valp);
+	}
+
+	k = 1;
+
+	switch(type)
+	{
+	case TYLOGICAL:
+		if (tylogical != TYLONG)
+			type = tylogical;
+	case TYSHORT:
+	case TYLONG:
+		dataline(varname, offset, type);
+		prconi(dfile, con.Const.ci);
+		break;
+
+	case TYADDR:
+		dataline(varname, offset, type);
+		prcona(dfile, con.Const.ci);
+		break;
+
+	case TYCOMPLEX:
+	case TYDCOMPLEX:
+		k = 2;
+	case TYREAL:
+	case TYDREAL:
+		dataline(varname, offset, type);
+		prconr(dfile, &con, k);
+		break;
+
+	case TYCHAR:
+		k = valp -> vleng -> constblock.Const.ci;
+		if (elen < k)
+			k = elen;
+		s = (unsigned char *)valp->Const.ccp;
+		for(i = 0 ; i < k ; ++i) {
+			dataline(varname, offset++, TYCHAR);
+			fprintf(dfile, "\t%d\n", *s++);
+			}
+		k = elen - valp->vleng->constblock.Const.ci;
+		if(k > 0) {
+			dataline(varname, offset, TYBLANK);
+			fprintf(dfile, "\t%d\n", k);
+			}
+		break;
+
+	default:
+		badtype("setdata", type);
+	}
+
+}
+
+
+
+/*
+   output form of name is padded with blanks and preceded
+   with a storage class digit
+*/
+char *dataname(stg,memno)
+ int stg;
+ long memno;
+{
+	static char varname[64];
+	register char *s, *t;
+	char buf[16], *memname();
+
+	if (stg == STGCOMMON) {
+		varname[0] = '2';
+		sprintf(s = buf, "Q.%ld", memno);
+		}
+	else {
+		varname[0] = stg==STGEQUIV ? '1' : '0';
+		s = memname(stg, memno);
+		}
+	t = varname + 1;
+	while(*t++ = *s++);
+	*t = 0;
+	return(varname);
+}
+
+
+
+
+
+frdata(p0)
+chainp p0;
+{
+	register struct Chain *p;
+	register tagptr q;
+
+	for(p = p0 ; p ; p = p->nextp)
+	{
+		q = (tagptr)p->datap;
+		if(q->tag == TIMPLDO)
+		{
+			if(q->impldoblock.isbusy)
+				return;	/* circular chain completed */
+			q->impldoblock.isbusy = YES;
+			frdata(q->impldoblock.datalist);
+			free( (charptr) q);
+		}
+		else
+			frexpr(q);
+	}
+
+	frchain( &p0);
+}
+
+
+
+dataline(varname, offset, type)
+char *varname;
+ftnint offset;
+int type;
+{
+	fprintf(dfile, datafmt, varname, offset, type);
+}
+
+ void
+make_param(p, e)
+ register struct Paramblock *p;
+ expptr e;
+{
+	register expptr q;
+
+	p->vclass = CLPARAM;
+	impldcl((Namep)p);
+	p->paramval = q = mkconv(p->vtype, e);
+	if (p->vtype == TYCHAR) {
+		if (q->tag == TEXPR)
+			p->paramval = q = fixexpr(q);
+		if (!ISCONST(q) || q->constblock.vtype != TYCHAR) {
+			errstr("invalid value for character parameter %s",
+				p->fvarname);
+			return;
+			}
+		if (!(e = p->vleng))
+			p->vleng = ICON(q->constblock.vleng->constblock.Const.ci
+					+ q->constblock.Const.ccp1.blanks);
+		else if (q->constblock.vleng->constblock.Const.ci
+				> e->constblock.Const.ci) {
+			q->constblock.vleng->constblock.Const.ci
+				= e->constblock.Const.ci;
+			q->constblock.Const.ccp1.blanks = 0;
+			}
+		else
+			q->constblock.Const.ccp1.blanks
+				= e->constblock.Const.ci
+				- q->constblock.vleng->constblock.Const.ci;
+		}
+	}

+ 289 - 0
lang/fortran/comp/defines.h

@@ -0,0 +1,289 @@
+#define PDP11 4
+
+#define BIGGEST_SHORT	0x7fff		/* Assumes 32-bit arithmetic */
+#define BIGGEST_LONG	0x7fffffff	/* Assumes 32-bit arithmetic */
+
+#define M(x) (1<<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) )

+ 769 - 0
lang/fortran/comp/defs.h

@@ -0,0 +1,769 @@
+/****************************************************************
+Copyright 1990, 1991 by AT&T Bell Laboratories, Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+#include "sysdep.h"
+
+#include "ftypes.h"
+#include "defines.h"
+#include "machdefs.h"
+
+#define MAXDIM 20
+#define MAXINCLUDES 10
+#define MAXLITERALS 200		/* Max number of constants in the literal
+				   pool */
+#define MAXTOKENLEN 302		/* length of longest token */
+#define MAXCTL 20
+#define MAXHASH 401
+#define MAXSTNO 801
+#define MAXEXT 200
+#define MAXEQUIV 150
+#define MAXLABLIST 125		/* Max number of labels in an alternate
+				   return CALL */
+
+/* These are the primary pointer types used in the compiler */
+
+typedef union Expression *expptr, *tagptr;
+typedef struct Chain *chainp;
+typedef struct Addrblock *Addrp;
+typedef struct Constblock *Constp;
+typedef struct Exprblock *Exprp;
+typedef struct Nameblock *Namep;
+
+extern FILEP opf();
+extern FILEP infile;
+extern FILEP diagfile;
+extern FILEP textfile;
+extern FILEP asmfile;
+extern FILEP c_file;		/* output file for all functions; extern
+				   declarations will have to be prepended */
+extern FILEP pass1_file;	/* Temp file to hold the function bodies
+				   read on pass 1 */
+extern FILEP expr_file;		/* Debugging file */
+extern FILEP initfile;		/* Intermediate data file pointer */
+extern FILEP blkdfile;		/* BLOCK DATA file */
+
+extern int current_ftn_file;
+
+extern char *blkdfname, *initfname, *sortfname;
+extern long int headoffset;	/* Since the header block requires data we
+				   don't know about until AFTER each
+				   function has been processed, we keep a
+				   pointer to the current (dummy) header
+				   block (at the top of the assembly file)
+				   here */
+
+extern char main_alias[];	/* name given to PROGRAM psuedo-op */
+extern char token [ ];
+extern int toklen;
+extern long lineno;
+extern char *infname;
+extern int needkwd;
+extern struct Labelblock *thislabel;
+
+/* Used to allow runtime expansion of internal tables.  In particular,
+   these values can exceed their associated constants */
+
+extern int maxctl;
+extern int maxequiv;
+extern int maxstno;
+extern int maxhash;
+extern int maxext;
+
+extern flag nowarnflag;
+extern flag ftn66flag;		/* Generate warnings when weird f77
+				   features are used (undeclared dummy
+				   procedure, non-char initialized with
+				   string, 1-dim subscript in EQUIV) */
+extern flag no66flag;		/* Generate an error when a generic
+				   function (f77 feature) is used */
+extern flag noextflag;		/* Generate an error when an extension to
+				   Fortran 77 is used (hex/oct/bin
+				   constants, automatic, static, double
+				   complex types) */
+extern flag zflag;		/* enable double complex intrinsics */
+extern flag shiftcase;
+extern flag undeftype;
+extern flag shortsubs;		/* Use short subscripts on arrays? */
+extern flag onetripflag;	/* if true, always execute DO loop body */
+extern flag checksubs;
+extern flag debugflag;
+extern int nerr;
+extern int nwarn;
+
+extern int parstate;
+extern flag headerdone;		/* True iff the current procedure's header
+				   data has been written */
+extern int blklevel;
+extern flag saveall;
+extern flag substars;		/* True iff some formal parameter is an
+				   asterisk */
+extern int impltype[ ];
+extern ftnint implleng[ ];
+extern int implstg[ ];
+
+extern int tycomplex, tyint, tyioint, tyreal;
+extern int tylogical;		/* TY____ of the implementation of   logical.
+				   This will be LONG unless '-2' is given
+				   on the command line */
+extern int type_choice[];
+extern char *typename[];
+
+extern int typesize[];	/* size (in bytes) of an object of each
+				   type.  Indexed by TY___ macros */
+extern int typealign[];
+extern int proctype;	/* Type of return value in this procedure */
+extern char * procname;	/* External name of the procedure, or last ENTRY name */
+extern int rtvlabel[ ];	/* Return value labels, indexed by TY___ macros */
+extern Addrp retslot;
+extern Addrp xretslot[];
+extern int cxslot;	/* Complex return argument slot (frame pointer offset)*/
+extern int chslot;	/* Character return argument slot (fp offset) */
+extern int chlgslot;	/* Argument slot for length of character buffer */
+extern int procclass;	/* Class of the current procedure:  either CLPROC,
+			   CLMAIN, CLBLOCK or CLUNKNOWN */
+extern ftnint procleng;	/* Length of function return value (e.g. char
+			   string length).  If this is -1, then the length is
+			   not known at compile time */
+extern int nentry;	/* Number of entry points (other than the original
+			   function call) into this procedure */
+extern flag multitype;	/* YES iff there is more than one return value
+			   possible */
+extern int blklevel;
+extern long lastiolabno;
+extern int lastlabno;
+extern int lastvarno;
+extern int lastargslot;	/* integer offset pointing to the next free
+			   location for an argument to the current routine */
+extern int argloc;
+extern int autonum[];		/* for numbering
+				   automatic variables, e.g. temporaries */
+extern int retlabel;
+extern int ret0label;
+extern int dorange;		/* Number of the label which terminates
+				   the innermost DO loop */
+extern int regnum[ ];		/* Numbers of DO indicies named in
+				   regnamep   (below) */
+extern Namep regnamep[ ];	/* List of DO indicies in registers */
+extern int maxregvar;		/* number of elts in   regnamep   */
+extern int highregvar;		/* keeps track of the highest register
+				   number used by DO index allocator */
+extern int nregvar;		/* count of DO indicies in registers */
+
+extern chainp templist[];
+extern int maxdim;
+extern chainp earlylabs;
+extern chainp holdtemps;
+extern struct Entrypoint *entries;
+extern struct Rplblock *rpllist;
+extern struct Chain *curdtp;
+extern ftnint curdtelt;
+extern chainp allargs;		/* union of args in entries */
+extern int nallargs;		/* total number of args */
+extern int nallchargs;		/* total number of character args */
+extern flag toomanyinit;	/* True iff too many initializers in a
+				   DATA statement */
+
+extern flag inioctl;
+extern int iostmt;
+extern Addrp ioblkp;
+extern int nioctl;
+extern int nequiv;
+extern int eqvstart;	/* offset to eqv number to guarantee uniqueness
+			   and prevent <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;

+ 372 - 0
lang/fortran/comp/equiv.c

@@ -0,0 +1,372 @@
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+#include "defs.h"
+
+LOCAL eqvcommon(), eqveqv(), nsubs();
+
+/* ROUTINES RELATED TO EQUIVALENCE CLASS PROCESSING */
+
+/* called at end of declarations section to process chains
+   created by EQUIVALENCE statements
+ */
+doequiv()
+{
+	register int i;
+	int inequiv;			/* True if one namep occurs in
+					   several EQUIV declarations */
+	int comno;		/* Index into Extsym table of the last
+				   COMMON block seen (implicitly assuming
+				   that only one will be given) */
+	int ovarno;
+	ftnint comoffset;	/* Index into the COMMON block */
+	ftnint offset;		/* Offset from array base */
+	ftnint leng;
+	register struct Equivblock *equivdecl;
+	register struct Eqvchain *q;
+	struct Primblock *primp;
+	register Namep np;
+	int k, k1, ns, pref, t;
+	chainp cp;
+	extern int type_pref[];
+
+	for(i = 0 ; i < nequiv ; ++i)
+	{
+
+/* Handle each equivalence declaration */
+
+		equivdecl = &eqvclass[i];
+		equivdecl->eqvbottom = equivdecl->eqvtop = 0;
+		comno = -1;
+
+
+
+		for(q = equivdecl->equivs ; q ; q = q->eqvnextp)
+		{
+			offset = 0;
+			primp = q->eqvitem.eqvlhs;
+			vardcl(np = primp->namep);
+			if(primp->argsp || primp->fcharp)
+			{
+				expptr offp, suboffset();
+
+/* Pad ones onto the end of an array declaration when needed */
+
+				if(np->vdim!=NULL && np->vdim->ndim>1 &&
+				    nsubs(primp->argsp)==1 )
+				{
+					if(! ftn66flag)
+						warni
+			("1-dim subscript in EQUIVALENCE, %d-dim declared",
+						    np -> vdim -> ndim);
+					cp = NULL;
+					ns = np->vdim->ndim;
+					while(--ns > 0)
+						cp = mkchain((char *)ICON(1), cp);
+					primp->argsp->listp->nextp = cp;
+				}
+
+				offp = suboffset(primp);
+				if(ISICON(offp))
+					offset = offp->constblock.Const.ci;
+				else	{
+					dclerr
+			("nonconstant subscript in equivalence ",
+					    np);
+					np = NULL;
+				}
+				frexpr(offp);
+			}
+
+/* Free up the primblock, since we now have a hash table (Namep) entry */
+
+			frexpr((expptr)primp);
+
+			if(np && (leng = iarrlen(np))<0)
+			{
+				dclerr("adjustable in equivalence", np);
+				np = NULL;
+			}
+
+			if(np) switch(np->vstg)
+			{
+			case STGUNKNOWN:
+			case STGBSS:
+			case STGEQUIV:
+				break;
+
+			case STGCOMMON:
+
+/* The code assumes that all COMMON references in a given EQUIVALENCE will
+   be to the same COMMON block, and will all be consistent */
+
+				comno = np->vardesc.varno;
+				comoffset = np->voffset + offset;
+				break;
+
+			default:
+				dclerr("bad storage class in equivalence", np);
+				np = NULL;
+				break;
+			}
+
+			if(np)
+			{
+				q->eqvoffset = offset;
+
+/* eqvbottom   gets the largest difference between the array base address
+   and the address specified in the EQUIV declaration */
+
+				equivdecl->eqvbottom =
+				    lmin(equivdecl->eqvbottom, -offset);
+
+/* eqvtop   gets the largest difference between the end of the array and
+   the address given in the EQUIVALENCE */
+
+				equivdecl->eqvtop =
+				    lmax(equivdecl->eqvtop, leng-offset);
+			}
+			q->eqvitem.eqvname = np;
+		}
+
+/* Now all equivalenced variables are in the hash table with the proper
+   offset, and   eqvtop and eqvbottom   are set. */
+
+		if(comno >= 0)
+
+/* Get rid of all STGEQUIVS, they will be mapped onto STGCOMMON variables
+   */
+
+			eqvcommon(equivdecl, comno, comoffset);
+		else for(q = equivdecl->equivs ; q ; q = q->eqvnextp)
+		{
+			if(np = q->eqvitem.eqvname)
+			{
+				inequiv = NO;
+				if(np->vstg==STGEQUIV)
+					if( (ovarno = np->vardesc.varno) == i)
+					{
+
+/* Can't EQUIV different elements of the same array */
+
+						if(np->voffset + q->eqvoffset != 0)
+							dclerr
+			("inconsistent equivalence", np);
+					}
+					else	{
+						offset = np->voffset;
+						inequiv = YES;
+					}
+
+				np->vstg = STGEQUIV;
+				np->vardesc.varno = i;
+				np->voffset = - q->eqvoffset;
+
+				if(inequiv)
+
+/* Combine 2 equivalence declarations */
+
+					eqveqv(i, ovarno, q->eqvoffset + offset);
+			}
+		}
+	}
+
+/* Now each equivalence declaration is distinct (all connections have been
+   merged in eqveqv()), and some may be empty. */
+
+	for(i = 0 ; i < nequiv ; ++i)
+	{
+		equivdecl = & eqvclass[i];
+		if(equivdecl->eqvbottom!=0 || equivdecl->eqvtop!=0) {
+
+/* a live chain */
+
+			k = TYCHAR;
+			pref = 1;
+			for(q = equivdecl->equivs ; q; q = q->eqvnextp)
+			    if (np = q->eqvitem.eqvname){
+				np->voffset -= equivdecl->eqvbottom;
+				t = typealign[k1 = np->vtype];
+				if (pref < type_pref[k1]) {
+					k = k1;
+					pref = type_pref[k1];
+					}
+				if(np->voffset % t != 0) {
+					dclerr("bad alignment forced by equivalence", np);
+					--nerr; /* don't give bad return code for this */
+					}
+				}
+			equivdecl->eqvtype = k;
+		}
+		freqchain(equivdecl);
+	}
+}
+
+
+
+
+
+/* put equivalence chain p at common block comno + comoffset */
+
+LOCAL eqvcommon(p, comno, comoffset)
+struct Equivblock *p;
+int comno;
+ftnint comoffset;
+{
+	int ovarno;
+	ftnint k, offq;
+	register Namep np;
+	register struct Eqvchain *q;
+
+	if(comoffset + p->eqvbottom < 0)
+	{
+		errstr("attempt to extend common %s backward",
+		    extsymtab[comno].fextname);
+		freqchain(p);
+		return;
+	}
+
+	if( (k = comoffset + p->eqvtop) > extsymtab[comno].extleng)
+		extsymtab[comno].extleng = k;
+
+
+	for(q = p->equivs ; q ; q = q->eqvnextp)
+		if(np = q->eqvitem.eqvname)
+		{
+			switch(np->vstg)
+			{
+			case STGUNKNOWN:
+			case STGBSS:
+				np->vstg = STGCOMMON;
+				np->vcommequiv = 1;
+				np->vardesc.varno = comno;
+
+/* np -> voffset   will point to the base of the array */
+
+				np->voffset = comoffset - q->eqvoffset;
+				break;
+
+			case STGEQUIV:
+				ovarno = np->vardesc.varno;
+
+/* offq   will point to the current element, even if it's in an array */
+
+				offq = comoffset - q->eqvoffset - np->voffset;
+				np->vstg = STGCOMMON;
+				np->vcommequiv = 1;
+				np->vardesc.varno = comno;
+
+/* np -> voffset   will point to the base of the array */
+
+				np->voffset += offq;
+				if(ovarno != (p - eqvclass))
+					eqvcommon(&eqvclass[ovarno], comno, offq);
+				break;
+
+			case STGCOMMON:
+				if(comno != np->vardesc.varno ||
+				    comoffset != np->voffset+q->eqvoffset)
+					dclerr("inconsistent common usage", np);
+				break;
+
+
+			default:
+				badstg("eqvcommon", np->vstg);
+			}
+		}
+
+	freqchain(p);
+	p->eqvbottom = p->eqvtop = 0;
+}
+
+
+/* Move all items on ovarno chain to the front of   nvarno   chain.
+ * adjust offsets of ovarno elements and top and bottom of nvarno chain
+ */
+
+LOCAL eqveqv(nvarno, ovarno, delta)
+int ovarno, nvarno;
+ftnint delta;
+{
+	register struct Equivblock *neweqv, *oldeqv;
+	register Namep np;
+	struct Eqvchain *q, *q1;
+
+	neweqv = eqvclass + nvarno;
+	oldeqv = eqvclass + ovarno;
+	neweqv->eqvbottom = lmin(neweqv->eqvbottom, oldeqv->eqvbottom - delta);
+	neweqv->eqvtop = lmax(neweqv->eqvtop, oldeqv->eqvtop - delta);
+	oldeqv->eqvbottom = oldeqv->eqvtop = 0;
+
+	for(q = oldeqv->equivs ; q ; q = q1)
+	{
+		q1 = q->eqvnextp;
+		if( (np = q->eqvitem.eqvname) && np->vardesc.varno==ovarno)
+		{
+			q->eqvnextp = neweqv->equivs;
+			neweqv->equivs = q;
+			q->eqvoffset += delta;
+			np->vardesc.varno = nvarno;
+			np->voffset -= delta;
+		}
+		else	free( (charptr) q);
+	}
+	oldeqv->equivs = NULL;
+}
+
+
+
+
+freqchain(p)
+register struct Equivblock *p;
+{
+	register struct Eqvchain *q, *oq;
+
+	for(q = p->equivs ; q ; q = oq)
+	{
+		oq = q->eqvnextp;
+		free( (charptr) q);
+	}
+	p->equivs = NULL;
+}
+
+
+
+
+
+/* nsubs -- number of subscripts in this arglist (just the length of the
+   list) */
+
+LOCAL nsubs(p)
+register struct Listblock *p;
+{
+	register int n;
+	register chainp q;
+
+	n = 0;
+	if(p)
+		for(q = p->listp ; q ; q = q->nextp)
+			++n;
+
+	return(n);
+}

+ 252 - 0
lang/fortran/comp/error.c

@@ -0,0 +1,252 @@
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+#include "defs.h"
+
+warni(s,t)
+ char *s;
+ int t;
+{
+	char buf[100];
+	sprintf(buf,s,t);
+	warn(buf);
+	}
+
+warn1(s,t)
+char *s, *t;
+{
+	char buff[100];
+	sprintf(buff, s, t);
+	warn(buff);
+}
+
+
+warn(s)
+char *s;
+{
+	if(nowarnflag)
+		return;
+	if (infname && *infname)
+		fprintf(diagfile, "Warning on line %ld of %s: %s\n",
+			lineno, infname, s);
+	else
+		fprintf(diagfile, "Warning on line %ld: %s\n", lineno, s);
+	fflush(diagfile);
+	++nwarn;
+}
+
+
+errstr(s, t)
+char *s, *t;
+{
+	char buff[100];
+	sprintf(buff, s, t);
+	err(buff);
+}
+
+
+
+erri(s,t)
+char *s;
+int t;
+{
+	char buff[100];
+	sprintf(buff, s, t);
+	err(buff);
+}
+
+errl(s,t)
+char *s;
+long t;
+{
+	char buff[100];
+	sprintf(buff, s, t);
+	err(buff);
+}
+
+ char *err_proc = 0;
+
+err(s)
+char *s;
+{
+	if (err_proc)
+		fprintf(diagfile,
+			"Error processing %s before line %ld",
+			err_proc, lineno);
+	else
+		fprintf(diagfile, "Error on line %ld", lineno);
+	if (infname && *infname)
+		fprintf(diagfile, " of %s", infname);
+	fprintf(diagfile, ": %s\n", s);
+	fflush(diagfile);
+	++nerr;
+}
+
+
+yyerror(s)
+char *s;
+{
+	err(s);
+}
+
+
+
+dclerr(s, v)
+char *s;
+Namep v;
+{
+	char buff[100];
+
+	if(v)
+	{
+		sprintf(buff, "Declaration error for %s: %s", v->fvarname, s);
+		err(buff);
+	}
+	else
+		errstr("Declaration error %s", s);
+}
+
+
+
+execerr(s, n)
+char *s, *n;
+{
+	char buf1[100], buf2[100];
+
+	sprintf(buf1, "Execution error %s", s);
+	sprintf(buf2, buf1, n);
+	err(buf2);
+}
+
+
+Fatal(t)
+char *t;
+{
+	fprintf(diagfile, "Compiler error line %ld", lineno);
+	if (infname)
+		fprintf(diagfile, " of %s", infname);
+	fprintf(diagfile, ": %s\n", t);
+	done(3);
+}
+
+
+
+
+fatalstr(t,s)
+char *t, *s;
+{
+	char buff[100];
+	sprintf(buff, t, s);
+	Fatal(buff);
+}
+
+
+
+fatali(t,d)
+char *t;
+int d;
+{
+	char buff[100];
+	sprintf(buff, t, d);
+	Fatal(buff);
+}
+
+
+
+badthing(thing, r, t)
+char *thing, *r;
+int t;
+{
+	char buff[50];
+	sprintf(buff, "Impossible %s %d in routine %s", thing, t, r);
+	Fatal(buff);
+}
+
+
+
+badop(r, t)
+char *r;
+int t;
+{
+	badthing("opcode", r, t);
+}
+
+
+
+badtag(r, t)
+char *r;
+int t;
+{
+	badthing("tag", r, t);
+}
+
+
+
+
+
+badstg(r, t)
+char *r;
+int t;
+{
+	badthing("storage class", r, t);
+}
+
+
+
+
+badtype(r, t)
+char *r;
+int t;
+{
+	badthing("type", r, t);
+}
+
+
+many(s, c, n)
+char *s, c;
+int n;
+{
+	char buff[250];
+
+	sprintf(buff,
+	    "Too many %s.\nTable limit now %d.\nTry recompiling using the -N%c%d option\n",
+	    s, n, c, 2*n);
+	Fatal(buff);
+}
+
+
+err66(s)
+char *s;
+{
+	errstr("Fortran 77 feature used: %s", s);
+	--nerr;
+}
+
+
+
+errext(s)
+char *s;
+{
+	errstr("F77 compiler extension used: %s", s);
+	--nerr;
+}

+ 831 - 0
lang/fortran/comp/exec.c

@@ -0,0 +1,831 @@
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+#include "defs.h"
+#include "p1defs.h"
+#include "names.h"
+
+LOCAL void exar2(), popctl(), pushctl();
+
+/*   Logical IF codes
+*/
+
+
+exif(p)
+expptr p;
+{
+    pushctl(CTLIF);
+    putif(p, 0);	/* 0 => if, not elseif */
+}
+
+
+
+exelif(p)
+expptr p;
+{
+    if (ctlstack->ctltype == CTLIF || ctlstack->ctltype == CTLIFX)
+	putif(p, 1);	/* 1 ==> elseif */
+    else
+	execerr("elseif out of place", CNULL);
+}
+
+
+
+
+
+exelse()
+{
+	register struct Ctlframe *c;
+
+	for(c = ctlstack; c->ctltype == CTLIFX; --c);
+	if(c->ctltype == CTLIF) {
+		p1_else ();
+		c->ctltype = CTLELSE;
+		}
+	else
+		execerr("else out of place", CNULL);
+	}
+
+
+exendif()
+{
+	while(ctlstack->ctltype == CTLIFX) {
+		popctl();
+		p1else_end();
+		}
+	if(ctlstack->ctltype == CTLIF) {
+		popctl();
+		p1_endif ();
+		}
+	else if(ctlstack->ctltype == CTLELSE) {
+		popctl();
+		p1else_end ();
+		}
+	else
+		execerr("endif out of place", CNULL);
+	}
+
+
+new_endif()
+{
+	if (ctlstack->ctltype == CTLIF || ctlstack->ctltype == CTLIFX)
+		pushctl(CTLIFX);
+	else
+		err("new_endif bug");
+	}
+
+/* pushctl -- Start a new control construct, initialize the labels (to
+   zero) */
+
+ LOCAL void
+pushctl(code)
+ int code;
+{
+	register int i;
+
+	if(++ctlstack >= lastctl)
+		many("loops or if-then-elses", 'c', maxctl);
+	ctlstack->ctltype = code;
+	for(i = 0 ; i < 4 ; ++i)
+		ctlstack->ctlabels[i] = 0;
+	ctlstack->dowhile = 0;
+	++blklevel;
+}
+
+
+ LOCAL void
+popctl()
+{
+	if( ctlstack-- < ctls )
+		Fatal("control stack empty");
+	--blklevel;
+}
+
+
+
+/* poplab -- update the flags in   labeltab   */
+
+LOCAL poplab()
+{
+	register struct Labelblock  *lp;
+
+	for(lp = labeltab ; lp < highlabtab ; ++lp)
+		if(lp->labdefined)
+		{
+			/* mark all labels in inner blocks unreachable */
+			if(lp->blklevel > blklevel)
+				lp->labinacc = YES;
+		}
+		else if(lp->blklevel > blklevel)
+		{
+			/* move all labels referred to in inner blocks out a level */
+			lp->blklevel = blklevel;
+		}
+}
+
+
+/*  BRANCHING CODE
+*/
+
+exgoto(lab)
+struct Labelblock *lab;
+{
+	lab->labused = 1;
+	p1_goto (lab -> stateno);
+}
+
+
+
+
+
+
+
+exequals(lp, rp)
+register struct Primblock *lp;
+register expptr rp;
+{
+	if(lp->tag != TPRIM)
+	{
+		err("assignment to a non-variable");
+		frexpr((expptr)lp);
+		frexpr(rp);
+	}
+	else if(lp->namep->vclass!=CLVAR && lp->argsp)
+	{
+		if(parstate >= INEXEC)
+			err("statement function amid executables");
+		mkstfunct(lp, rp);
+	}
+	else
+	{
+		expptr new_lp, new_rp;
+
+		if(parstate < INDATA)
+			enddcl();
+		new_lp = mklhs (lp);
+		new_rp = fixtype (rp);
+		puteq(new_lp, new_rp);
+	}
+}
+
+
+
+/* Make Statement Function */
+
+long laststfcn = -1, thisstno;
+int doing_stmtfcn;
+
+mkstfunct(lp, rp)
+struct Primblock *lp;
+expptr rp;
+{
+	register struct Primblock *p;
+	register Namep np;
+	chainp args;
+
+	laststfcn = thisstno;
+	np = lp->namep;
+	if(np->vclass == CLUNKNOWN)
+		np->vclass = CLPROC;
+	else
+	{
+		dclerr("redeclaration of statement function", np);
+		return;
+	}
+	np->vprocclass = PSTFUNCT;
+	np->vstg = STGSTFUNCT;
+
+/* Set the type of the function */
+
+	impldcl(np);
+	if (np->vtype == TYCHAR && !np->vleng)
+		err("character statement function with length (*)");
+	args = (lp->argsp ? lp->argsp->listp : CHNULL);
+	np->varxptr.vstfdesc = mkchain((char *)args, (chainp)rp);
+
+	for(doing_stmtfcn = 1 ; args ; args = args->nextp)
+
+/* It is an error for the formal parameters to have arguments or
+   subscripts */
+
+		if( ((tagptr)(args->datap))->tag!=TPRIM ||
+		    (p = (struct Primblock *)(args->datap) )->argsp ||
+		    p->fcharp || p->lcharp )
+			err("non-variable argument in statement function definition");
+		else
+		{
+
+/* Replace the name on the left-hand side */
+
+			args->datap = (char *)p->namep;
+			vardcl(p -> namep);
+			free((char *)p);
+		}
+	doing_stmtfcn = 0;
+}
+
+ static void
+mixed_type(np)
+ Namep np;
+{
+	char buf[128];
+	sprintf(buf, "%s function %.90s invoked as subroutine",
+		ftn_types[np->vtype], np->fvarname);
+	warn(buf);
+	}
+
+
+excall(name, args, nstars, labels)
+Namep name;
+struct Listblock *args;
+int nstars;
+struct Labelblock *labels[ ];
+{
+	register expptr p;
+
+	if (name->vtype != TYSUBR) {
+		if (name->vinfproc && !name->vcalled) {
+			name->vtype = TYSUBR;
+			frexpr(name->vleng);
+			name->vleng = 0;
+			}
+		else if (!name->vimpltype && name->vtype != TYUNKNOWN)
+			mixed_type(name);
+		else
+			settype(name, TYSUBR, (ftnint)0);
+		}
+	p = mkfunct( mkprim(name, args, CHNULL) );
+
+/* Subroutines and their identifiers acquire the type INT */
+
+	p->exprblock.vtype = p->exprblock.leftp->headblock.vtype = TYINT;
+
+/* Handle the alternate return mechanism */
+
+	if(nstars > 0)
+		putcmgo(putx(fixtype(p)), nstars, labels);
+	else
+		putexpr(p);
+}
+
+
+
+exstop(stop, p)
+int stop;
+register expptr p;
+{
+	char *str;
+	int n;
+	expptr mkstrcon();
+
+	if(p)
+	{
+		if( ! ISCONST(p) )
+		{
+			execerr("pause/stop argument must be constant", CNULL);
+			frexpr(p);
+			p = mkstrcon(0, CNULL);
+		}
+		else if( ISINT(p->constblock.vtype) )
+		{
+			str = convic(p->constblock.Const.ci);
+			n = strlen(str);
+			if(n > 0)
+			{
+				p->constblock.Const.ccp = copyn(n, str);
+				p->constblock.Const.ccp1.blanks = 0;
+				p->constblock.vtype = TYCHAR;
+				p->constblock.vleng = (expptr) ICON(n);
+			}
+			else
+				p = (expptr) mkstrcon(0, CNULL);
+		}
+		else if(p->constblock.vtype != TYCHAR)
+		{
+			execerr("pause/stop argument must be integer or string", CNULL);
+			p = (expptr) mkstrcon(0, CNULL);
+		}
+	}
+	else	p = (expptr) mkstrcon(0, CNULL);
+
+    {
+	expptr subr_call;
+
+	subr_call = call1(TYSUBR, (stop ? "s_stop" : "s_paus"), p);
+	putexpr( subr_call );
+    }
+}
+
+/* DO LOOP CODE */
+
+#define DOINIT	par[0]
+#define DOLIMIT	par[1]
+#define DOINCR	par[2]
+
+
+/* Macros for   ctlstack -> dostepsign   */
+
+#define VARSTEP	0
+#define POSSTEP	1
+#define NEGSTEP	2
+
+
+/* exdo -- generate DO loop code.  In the case of a variable increment,
+   positive increment tests are placed above the body, negative increment
+   tests are placed below (see   enddo()   ) */
+
+exdo(range, loopname, spec)
+int range;			/* end label */
+Namep loopname;
+chainp spec;			/* input spec must have at least 2 exprs */
+{
+	register expptr p;
+	register Namep np;
+	chainp cp;		/* loops over the fields in   spec */
+	register int i;
+	int dotype;		/* type of the index variable */
+	int incsign;		/* sign of the increment, if it's constant
+				   */
+	Addrp dovarp;		/* loop index variable */
+	expptr doinit;		/* constant or register for init param */
+	expptr par[3];		/* local specification parameters */
+
+	expptr init, test, inc;	/* Expressions in the resulting FOR loop */
+
+
+	test = ENULL;
+
+	pushctl(CTLDO);
+	dorange = ctlstack->dolabel = range;
+	ctlstack->loopname = loopname;
+
+/* Declare the loop index */
+
+	np = (Namep)spec->datap;
+	ctlstack->donamep = NULL;
+	if (!np) { /* do while */
+		ctlstack->dowhile = 1;
+#if 0
+		if (loopname) {
+			if (loopname->vtype == TYUNKNOWN) {
+				loopname->vdcldone = 1;
+				loopname->vclass = CLLABEL;
+				loopname->vprocclass = PLABEL;
+				loopname->vtype = TYLABEL;
+				}
+			if (loopname->vtype == TYLABEL)
+				if (loopname->vdovar)
+					dclerr("already in use as a loop name",
+						loopname);
+				else
+					loopname->vdovar = 1;
+			else
+				dclerr("already declared; cannot be a loop name",
+					loopname);
+			}
+#endif
+		putwhile((expptr)spec->nextp);
+		NOEXT("do while");
+		spec->nextp = 0;
+		frchain(&spec);
+		return;
+		}
+	if(np->vdovar)
+	{
+		errstr("nested loops with variable %s", np->fvarname);
+		ctlstack->donamep = NULL;
+		return;
+	}
+
+/* Create a memory-resident version of the index variable */
+
+	dovarp = mkplace(np);
+	if( ! ONEOF(dovarp->vtype, MSKINT|MSKREAL) )
+	{
+		err("bad type on do variable");
+		return;
+	}
+	ctlstack->donamep = np;
+
+	np->vdovar = YES;
+
+/* Now   dovarp   points to the index to be used within the loop,   dostgp
+   points to the one which may need to be stored */
+
+	dotype = dovarp->vtype;
+
+/* Count the input specifications and type-check each one independently;
+   this just eliminates non-numeric values from the specification */
+
+	for(i=0 , cp = spec->nextp ; cp!=NULL && i<3 ; cp = cp->nextp)
+	{
+		p = par[i++] = fixtype((tagptr)cp->datap);
+		if( ! ONEOF(p->headblock.vtype, MSKINT|MSKREAL) )
+		{
+			err("bad type on DO parameter");
+			return;
+		}
+	}
+
+	frchain(&spec);
+	switch(i)
+	{
+	case 0:
+	case 1:
+		err("too few DO parameters");
+		return;
+
+	default:
+		err("too many DO parameters");
+		return;
+
+	case 2:
+		DOINCR = (expptr) ICON(1);
+
+	case 3:
+		break;
+	}
+
+
+/* Now all of the local specification fields are set, but their types are
+   not yet consistent */
+
+/* Declare the loop initialization value, casting it properly and declaring a
+   register if need be */
+
+	if (ISCONST (DOINIT) || !onetripflag)
+/* putx added 6-29-89 (mwm), not sure if fixtype is required, but I doubt it
+   since mkconv is called just before */
+		doinit = putx (mkconv (dotype, DOINIT));
+	else {
+	    doinit = (expptr) mktmp(dotype, ENULL);
+	    puteq (cpexpr (doinit), DOINIT);
+	} /* else */
+
+/* Declare the loop ending value, casting it to the type of the index
+   variable */
+
+	if( ISCONST(DOLIMIT) )
+		ctlstack->domax = mkconv(dotype, DOLIMIT);
+	else {
+		ctlstack->domax = (expptr) mktmp0(dotype, ENULL);
+		puteq (cpexpr (ctlstack -> domax), DOLIMIT);
+	} /* else */
+
+/* Declare the loop increment value, casting it to the type of the index
+   variable */
+
+	if( ISCONST(DOINCR) )
+	{
+		ctlstack->dostep = mkconv(dotype, DOINCR);
+		if( (incsign = conssgn(ctlstack->dostep)) == 0)
+			err("zero DO increment");
+		ctlstack->dostepsign = (incsign > 0 ? POSSTEP : NEGSTEP);
+	}
+	else
+	{
+		ctlstack->dostep = (expptr) mktmp0(dotype, ENULL);
+		ctlstack->dostepsign = VARSTEP;
+		puteq (cpexpr (ctlstack -> dostep), DOINCR);
+	}
+
+/* All data is now properly typed and in the   ctlstack,   except for the
+   initial value.  Assignments of temps have been generated already */
+
+	switch (ctlstack -> dostepsign) {
+	    case VARSTEP:
+		test = mkexpr (OPQUEST, mkexpr (OPLT,
+			cpexpr (ctlstack -> dostep), ICON(0)),
+			mkexpr (OPCOLON,
+			    mkexpr (OPGE, cpexpr((expptr)dovarp),
+				    cpexpr (ctlstack -> domax)),
+			    mkexpr (OPLE, cpexpr((expptr)dovarp),
+				    cpexpr (ctlstack -> domax))));
+		break;
+	    case POSSTEP:
+	        test = mkexpr (OPLE, cpexpr((expptr)dovarp),
+			cpexpr (ctlstack -> domax));
+	        break;
+	    case NEGSTEP:
+	        test = mkexpr (OPGE, cpexpr((expptr)dovarp),
+			cpexpr (ctlstack -> domax));
+	        break;
+	    default:
+	        erri ("exdo:  bad dostepsign '%d'", ctlstack -> dostepsign);
+	        break;
+	} /* switch (ctlstack -> dostepsign) */
+
+	if (onetripflag)
+	    test = mkexpr (OPOR, test,
+		    mkexpr (OPEQ, cpexpr((expptr)dovarp), cpexpr (doinit)));
+	init = mkexpr (OPASSIGN, cpexpr((expptr)dovarp), doinit);
+	inc = mkexpr (OPPLUSEQ, (expptr)dovarp, cpexpr (ctlstack -> dostep));
+
+	if (!onetripflag && ISCONST (ctlstack -> domax) && ISCONST (doinit)
+		&& ctlstack -> dostepsign != VARSTEP) {
+	    expptr tester;
+
+	    tester = mkexpr (OPMINUS, cpexpr (doinit),
+		    cpexpr (ctlstack -> domax));
+	    if (incsign == conssgn (tester))
+		warn ("DO range never executed");
+	    frexpr (tester);
+	} /* if !onetripflag && */
+
+	p1_for (init, test, inc);
+}
+
+exenddo(np)
+ Namep np;
+{
+	Namep np1;
+	int here;
+	struct Ctlframe *cf;
+
+	if( ctlstack < ctls )
+		Fatal("control stack empty");
+	here = ctlstack->dolabel;
+	if (ctlstack->ctltype != CTLDO || here >= 0) {
+		err("misplaced ENDDO");
+		return;
+		}
+	if (np != ctlstack->loopname) {
+		if (np1 = ctlstack->loopname)
+			errstr("expected \"enddo %s\"", np1->fvarname);
+		else
+			err("expected unnamed ENDDO");
+		for(cf = ctls; cf < ctlstack; cf++)
+			if (cf->ctltype == CTLDO && cf->loopname == np) {
+				here = cf->dolabel;
+				break;
+				}
+		}
+	enddo(here);
+	}
+
+
+enddo(here)
+int here;
+{
+	register struct Ctlframe *q;
+	Namep np;			/* name of the current DO index */
+	Addrp ap;
+	register int i;
+	register expptr e;
+
+/* Many DO's can end at the same statement, so keep looping over all
+   nested indicies */
+
+	while(here == dorange)
+	{
+		if(np = ctlstack->donamep)
+			{
+			p1for_end ();
+
+/* Now we're done with all of the tests, and the loop has terminated.
+   Store the index value back in long-term memory */
+
+			if(ap = memversion(np))
+				puteq((expptr)ap, (expptr)mkplace(np));
+			for(i = 0 ; i < 4 ; ++i)
+				ctlstack->ctlabels[i] = 0;
+			deregister(ctlstack->donamep);
+			ctlstack->donamep->vdovar = NO;
+			e = ctlstack->dostep;
+			if (e->tag == TADDR && e->addrblock.istemp)
+				frtemp((Addrp)e);
+			else
+				frexpr(e);
+			e = ctlstack->domax;
+			if (e->tag == TADDR && e->addrblock.istemp)
+				frtemp((Addrp)e);
+			else
+				frexpr(e);
+			}
+		else if (ctlstack->dowhile)
+			p1for_end ();
+
+/* Set   dorange   to the closing label of the next most enclosing DO loop
+   */
+
+		popctl();
+		poplab();
+		dorange = 0;
+		for(q = ctlstack ; q>=ctls ; --q)
+			if(q->ctltype == CTLDO)
+			{
+				dorange = q->dolabel;
+				break;
+			}
+	}
+}
+
+exassign(vname, labelval)
+ register Namep vname;
+struct Labelblock *labelval;
+{
+	Addrp p;
+	expptr mkaddcon();
+	register Addrp q;
+	static char nullstr[] = "";
+	char *fs;
+	register chainp cp, cpprev;
+	register ftnint k, stno;
+
+	p = mkplace(vname);
+	if( ! ONEOF(p->vtype, MSKINT|MSKADDR) ) {
+		err("noninteger assign variable");
+		return;
+		}
+
+	/* If the label hasn't been defined, then we do things twice:
+	 * once for an executable stmt label, once for a format
+	 */
+
+	/* code for executable label... */
+
+/* Now store the assigned value in a list associated with this variable.
+   This will be used later to generate a switch() statement in the C output */
+
+	if (!labelval->labdefined || !labelval->fmtstring) {
+
+		if (vname -> vis_assigned == 0) {
+			vname -> varxptr.assigned_values = CHNULL;
+			vname -> vis_assigned = 1;
+			}
+
+		/* don't duplicate labels... */
+
+		stno = labelval->stateno;
+		cpprev = 0;
+		for(k = 0, cp = vname->varxptr.assigned_values;
+				cp; cpprev = cp, cp = cp->nextp, k++)
+			if ((ftnint)cp->datap == stno)
+				break;
+		if (!cp) {
+			cp = mkchain((char *)stno, CHNULL);
+			if (cpprev)
+				cpprev->nextp = cp;
+			else
+				vname->varxptr.assigned_values = cp;
+			labelval->labused = 1;
+			}
+		putout(mkexpr(OPASSIGN, (expptr)p, mkintcon(k)));
+		}
+
+	/* Code for FORMAT label... */
+
+	fs = labelval->fmtstring;
+	if (!labelval->labdefined || fs && fs != nullstr) {
+		extern void fmtname();
+
+		if (!fs)
+			labelval->fmtstring = nullstr;
+		labelval->fmtlabused = 1;
+		p = ALLOC(Addrblock);
+		p->tag = TADDR;
+		p->vtype = TYCHAR;
+		p->vstg = STGAUTO;
+		p->memoffset = ICON(0);
+		fmtname(vname, p);
+		q = ALLOC(Addrblock);
+		q->tag = TADDR;
+		q->vtype = TYCHAR;
+		q->vstg = STGAUTO;
+		q->ntempelt = 1;
+		q->memoffset = ICON(0);
+		q->uname_tag = UNAM_IDENT;
+		sprintf(q->user.ident, "fmt_%ld", labelval->stateno);
+		putout(mkexpr(OPASSIGN, (expptr)p, (expptr)q));
+		}
+
+} /* exassign */
+
+
+
+exarif(expr, neglab, zerlab, poslab)
+expptr expr;
+struct Labelblock *neglab, *zerlab, *poslab;
+{
+    register int lm, lz, lp;
+
+    lm = neglab->stateno;
+    lz = zerlab->stateno;
+    lp = poslab->stateno;
+    expr = fixtype(expr);
+
+    if( ! ONEOF(expr->headblock.vtype, MSKINT|MSKREAL) )
+    {
+        err("invalid type of arithmetic if expression");
+        frexpr(expr);
+    }
+    else
+    {
+        if (lm == lz && lz == lp)
+            exgoto (neglab);
+        else if(lm == lz)
+            exar2(OPLE, expr, neglab, poslab);
+        else if(lm == lp)
+            exar2(OPNE, expr, neglab, zerlab);
+        else if(lz == lp)
+            exar2(OPGE, expr, zerlab, neglab);
+        else {
+            expptr t;
+
+	    if (!addressable (expr)) {
+		t = (expptr) mktmp(expr -> headblock.vtype, ENULL);
+		expr = mkexpr (OPASSIGN, cpexpr (t), expr);
+	    } else
+		t = (expptr) cpexpr (expr);
+
+	    p1_if(putx(fixtype(mkexpr (OPLT, expr, ICON (0)))));
+	    exgoto(neglab);
+	    p1_elif (mkexpr (OPEQ, t, ICON (0)));
+	    exgoto(zerlab);
+	    p1_else ();
+	    exgoto(poslab);
+	    p1else_end ();
+        } /* else */
+    }
+}
+
+
+
+/* exar2 -- Do arithmetic IF for only 2 distinct labels;   if !(e.op.0)
+   goto l2 else goto l1.  If this seems backwards, that's because it is,
+   in order to make the 1 pass algorithm work. */
+
+ LOCAL void
+exar2(op, e, l1, l2)
+ int op;
+ expptr e;
+ struct Labelblock *l1, *l2;
+{
+	expptr comp;
+
+	comp = mkexpr (op, e, ICON (0));
+	p1_if(putx(fixtype(comp)));
+	exgoto(l1);
+	p1_else ();
+	exgoto(l2);
+	p1else_end ();
+}
+
+
+/* exreturn -- return the value in   p  from a SUBROUTINE call -- used to
+   implement the alternate return mechanism */
+
+exreturn(p)
+register expptr p;
+{
+	if(procclass != CLPROC)
+		warn("RETURN statement in main or block data");
+	if(p && (proctype!=TYSUBR || procclass!=CLPROC) )
+	{
+		err("alternate return in nonsubroutine");
+		p = 0;
+	}
+
+	if (p || proctype == TYSUBR) {
+		if (p == ENULL) p = ICON (0);
+		p = mkconv (TYLONG, fixtype (p));
+		p1_subr_ret (p);
+	} /* if p || proctype == TYSUBR */
+	else
+	    p1_subr_ret((expptr)retslot);
+}
+
+
+exasgoto(labvar)
+Namep labvar;
+{
+	register Addrp p;
+	void p1_asgoto();
+
+	p = mkplace(labvar);
+	if( ! ISINT(p->vtype) )
+		err("assigned goto variable must be integer");
+	else {
+		p1_asgoto (p);
+	} /* else */
+}

+ 2882 - 0
lang/fortran/comp/expr.c

@@ -0,0 +1,2882 @@
+/****************************************************************
+Copyright 1990, 1991 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+#include "defs.h"
+#include "output.h"
+#include "names.h"
+
+LOCAL void conspower(), consbinop(), zdiv();
+LOCAL expptr fold(), mkpower(), stfcall();
+#ifndef stfcall_MAX
+#define stfcall_MAX 144
+#endif
+
+typedef struct { double dreal, dimag; } dcomplex;
+
+extern char dflttype[26];
+
+/* little routines to create constant blocks */
+
+Constp mkconst(t)
+register int t;
+{
+	register Constp p;
+
+	p = ALLOC(Constblock);
+	p->tag = TCONST;
+	p->vtype = t;
+	return(p);
+}
+
+
+/* mklogcon -- Make Logical Constant */
+
+expptr mklogcon(l)
+register int l;
+{
+	register Constp  p;
+
+	p = mkconst(TYLOGICAL);
+	p->Const.ci = l;
+	return( (expptr) p );
+}
+
+
+
+/* mkintcon -- Make Integer Constant */
+
+expptr mkintcon(l)
+ftnint l;
+{
+	register Constp p;
+
+	p = mkconst(tyint);
+	p->Const.ci = l;
+	return( (expptr) p );
+}
+
+
+
+
+/* mkaddcon -- Make Address Constant, given integer value */
+
+expptr mkaddcon(l)
+register long l;
+{
+	register Constp p;
+
+	p = mkconst(TYADDR);
+	p->Const.ci = l;
+	return( (expptr) p );
+}
+
+
+
+/* mkrealcon -- Make Real Constant.  The type t is assumed
+   to be TYREAL or TYDREAL */
+
+expptr mkrealcon(t, d)
+ register int t;
+ char *d;
+{
+	register Constp p;
+
+	p = mkconst(t);
+	p->Const.cds[0] = cds(d,CNULL);
+	p->vstg = 1;
+	return( (expptr) p );
+}
+
+
+/* mkbitcon -- Make bit constant.  Reads the input string, which is
+   assumed to correctly specify a number in base 2^shift (where   shift
+   is the input parameter).   shift   may not exceed 4, i.e. only binary,
+   quad, octal and hex bases may be input.  Constants may not exceed 32
+   bits, or whatever the size of (struct Constblock).ci may be. */
+
+expptr mkbitcon(shift, leng, s)
+int shift;
+int leng;
+char *s;
+{
+	register Constp p;
+	register long x;
+
+	p = mkconst(TYLONG);
+	x = 0;
+	while(--leng >= 0)
+		if(*s != ' ')
+			x = (x << shift) | hextoi(*s++);
+	/* mwm wanted to change the type to short for short constants,
+	 * but this is dangerous -- there is no syntax for long constants
+	 * with small values.
+	 */
+	p->Const.ci = x;
+	return( (expptr) p );
+}
+
+
+
+
+
+/* mkstrcon -- Make string constant.  Allocates storage and initializes
+   the memory for a copy of the input Fortran-string. */
+
+expptr mkstrcon(l,v)
+int l;
+register char *v;
+{
+	register Constp p;
+	register char *s;
+
+	p = mkconst(TYCHAR);
+	p->vleng = ICON(l);
+	p->Const.ccp = s = (char *) ckalloc(l+1);
+	p->Const.ccp1.blanks = 0;
+	while(--l >= 0)
+		*s++ = *v++;
+	*s = '\0';
+	return( (expptr) p );
+}
+
+
+
+/* mkcxcon -- Make complex contsant.  A complex number is a pair of
+   values, each of which may be integer, real or double. */
+
+expptr mkcxcon(realp,imagp)
+register expptr realp, imagp;
+{
+	int rtype, itype;
+	register Constp p;
+	expptr errnode();
+
+	rtype = realp->headblock.vtype;
+	itype = imagp->headblock.vtype;
+
+	if( ISCONST(realp) && ISNUMERIC(rtype) && ISCONST(imagp) && ISNUMERIC(itype) )
+	{
+		p = mkconst( (rtype==TYDREAL||itype==TYDREAL)
+				? TYDCOMPLEX : tycomplex);
+		if (realp->constblock.vstg || imagp->constblock.vstg) {
+			p->vstg = 1;
+			p->Const.cds[0] = ISINT(rtype)
+				? string_num("", realp->constblock.Const.ci)
+				: realp->constblock.vstg
+					? realp->constblock.Const.cds[0]
+					: dtos(realp->constblock.Const.cd[0]);
+			p->Const.cds[1] = ISINT(itype)
+				? string_num("", imagp->constblock.Const.ci)
+				: imagp->constblock.vstg
+					? imagp->constblock.Const.cds[0]
+					: dtos(imagp->constblock.Const.cd[0]);
+			}
+		else {
+			p->Const.cd[0] = ISINT(rtype)
+				? realp->constblock.Const.ci
+				: realp->constblock.Const.cd[0];
+			p->Const.cd[1] = ISINT(itype)
+				? imagp->constblock.Const.ci
+				: imagp->constblock.Const.cd[0];
+			}
+	}
+	else
+	{
+		err("invalid complex constant");
+		p = (Constp)errnode();
+	}
+
+	frexpr(realp);
+	frexpr(imagp);
+	return( (expptr) p );
+}
+
+
+/* errnode -- Allocate a new error block */
+
+expptr errnode()
+{
+	struct Errorblock *p;
+	p = ALLOC(Errorblock);
+	p->tag = TERROR;
+	p->vtype = TYERROR;
+	return( (expptr) p );
+}
+
+
+
+
+
+/* mkconv -- Make type conversion.  Cast expression   p   into type   t.
+   Note that casting to a character copies only the first sizeof(char)
+   bytes. */
+
+expptr mkconv(t, p)
+register int t;
+register expptr p;
+{
+	register expptr q;
+	register int pt, charwarn = 1;
+	expptr opconv();
+
+	if (t >= 100) {
+		t -= 100;
+		charwarn = 0;
+		}
+	if(t==TYUNKNOWN || t==TYERROR)
+		badtype("mkconv", t);
+	pt = p->headblock.vtype;
+
+/* Casting to the same type is a no-op */
+
+	if(t == pt)
+		return(p);
+
+/* If we're casting a constant which is not in the literal table ... */
+
+	else if( ISCONST(p) && pt!=TYADDR && pt != TYCHAR)
+	{
+		if (ISINT(t) && ISINT(pt) || ISREAL(t) && ISREAL(pt)) {
+			/* avoid trouble with -i2 */
+			p->headblock.vtype = t;
+			return p;
+			}
+		q = (expptr) mkconst(t);
+		consconv(t, &q->constblock, &p->constblock );
+		frexpr(p);
+	}
+	else {
+		if (pt == TYCHAR && t != TYADDR && charwarn)
+			warn(
+		 "ichar([first char. of] char. string) assumed for conversion to numeric");
+		q = opconv(p, t);
+		}
+
+	if(t == TYCHAR)
+		q->constblock.vleng = ICON(1);
+	return(q);
+}
+
+
+
+/* opconv -- Convert expression   p   to type   t   using the main
+   expression evaluator; returns an OPCONV expression, I think  14-jun-88 mwm */
+
+expptr opconv(p, t)
+expptr p;
+int t;
+{
+	register expptr q;
+
+	if (t == TYSUBR)
+		err("illegal use of subroutine name");
+	q = mkexpr(OPCONV, p, ENULL);
+	q->headblock.vtype = t;
+	return(q);
+}
+
+
+
+/* addrof -- Create an ADDR expression operation */
+
+expptr addrof(p)
+expptr p;
+{
+	return( mkexpr(OPADDR, p, ENULL) );
+}
+
+
+
+/* cpexpr - Returns a new copy of input expression   p   */
+
+tagptr cpexpr(p)
+register tagptr p;
+{
+	register tagptr e;
+	int tag;
+	register chainp ep, pp;
+	tagptr cpblock();
+
+/* This table depends on the ordering of the T macros, e.g. TNAME */
+
+	static int blksize[ ] =
+	{
+		0,
+		sizeof(struct Nameblock),
+		sizeof(struct Constblock),
+		sizeof(struct Exprblock),
+		sizeof(struct Addrblock),
+		sizeof(struct Primblock),
+		sizeof(struct Listblock),
+		sizeof(struct Impldoblock),
+		sizeof(struct Errorblock)
+	};
+
+	if(p == NULL)
+		return(NULL);
+
+/* TNAMEs are special, and don't get copied.  Each name in the current
+   symbol table has a unique TNAME structure. */
+
+	if( (tag = p->tag) == TNAME)
+		return(p);
+
+	e = cpblock(blksize[p->tag], (char *)p);
+
+	switch(tag)
+	{
+	case TCONST:
+		if(e->constblock.vtype == TYCHAR)
+		{
+			e->constblock.Const.ccp =
+			    copyn((int)e->constblock.vleng->constblock.Const.ci+1,
+				e->constblock.Const.ccp);
+			e->constblock.vleng =
+			    (expptr) cpexpr(e->constblock.vleng);
+		}
+	case TERROR:
+		break;
+
+	case TEXPR:
+		e->exprblock.leftp =  (expptr) cpexpr(p->exprblock.leftp);
+		e->exprblock.rightp = (expptr) cpexpr(p->exprblock.rightp);
+		break;
+
+	case TLIST:
+		if(pp = p->listblock.listp)
+		{
+			ep = e->listblock.listp =
+			    mkchain((char *)cpexpr((tagptr)pp->datap), CHNULL);
+			for(pp = pp->nextp ; pp ; pp = pp->nextp)
+				ep = ep->nextp =
+				    mkchain((char *)cpexpr((tagptr)pp->datap),
+						CHNULL);
+		}
+		break;
+
+	case TADDR:
+		e->addrblock.vleng = (expptr)  cpexpr(e->addrblock.vleng);
+		e->addrblock.memoffset = (expptr)cpexpr(e->addrblock.memoffset);
+		e->addrblock.istemp = NO;
+		break;
+
+	case TPRIM:
+		e->primblock.argsp = (struct Listblock *)
+		    cpexpr((expptr)e->primblock.argsp);
+		e->primblock.fcharp = (expptr) cpexpr(e->primblock.fcharp);
+		e->primblock.lcharp = (expptr) cpexpr(e->primblock.lcharp);
+		break;
+
+	default:
+		badtag("cpexpr", tag);
+	}
+
+	return(e);
+}
+
+/* frexpr -- Free expression -- frees up memory used by expression   p   */
+
+frexpr(p)
+register tagptr p;
+{
+	register chainp q;
+
+	if(p == NULL)
+		return;
+
+	switch(p->tag)
+	{
+	case TCONST:
+		if( ISCHAR(p) )
+		{
+			free( (charptr) (p->constblock.Const.ccp) );
+			frexpr(p->constblock.vleng);
+		}
+		break;
+
+	case TADDR:
+		if (p->addrblock.vtype > TYERROR)	/* i/o block */
+			break;
+		frexpr(p->addrblock.vleng);
+		frexpr(p->addrblock.memoffset);
+		break;
+
+	case TERROR:
+		break;
+
+/* TNAME blocks don't get free'd - probably because they're pointed to in
+   the hash table. 14-Jun-88 -- mwm */
+
+	case TNAME:
+		return;
+
+	case TPRIM:
+		frexpr((expptr)p->primblock.argsp);
+		frexpr(p->primblock.fcharp);
+		frexpr(p->primblock.lcharp);
+		break;
+
+	case TEXPR:
+		frexpr(p->exprblock.leftp);
+		if(p->exprblock.rightp)
+			frexpr(p->exprblock.rightp);
+		break;
+
+	case TLIST:
+		for(q = p->listblock.listp ; q ; q = q->nextp)
+			frexpr((tagptr)q->datap);
+		frchain( &(p->listblock.listp) );
+		break;
+
+	default:
+		badtag("frexpr", p->tag);
+	}
+
+	free( (charptr) p );
+}
+
+ void
+wronginf(np)
+ Namep np;
+{
+	int c, k;
+	warn1("fixing wrong type inferred for %.65s", np->fvarname);
+	np->vinftype = 0;
+	c = letter(np->fvarname[0]);
+	if ((np->vtype = impltype[c]) == TYCHAR
+	&& (k = implleng[c]))
+		np->vleng = ICON(k);
+	}
+
+/* fix up types in expression; replace subtrees and convert
+   names to address blocks */
+
+expptr fixtype(p)
+register tagptr p;
+{
+
+	if(p == 0)
+		return(0);
+
+	switch(p->tag)
+	{
+	case TCONST:
+		if(ONEOF(p->constblock.vtype,MSKINT|MSKLOGICAL|MSKADDR|
+		    MSKREAL) )
+			return( (expptr) p);
+
+		return( (expptr) putconst((Constp)p) );
+
+	case TADDR:
+		p->addrblock.memoffset = fixtype(p->addrblock.memoffset);
+		return( (expptr) p);
+
+	case TERROR:
+		return( (expptr) p);
+
+	default:
+		badtag("fixtype", p->tag);
+
+/* This case means that   fixexpr   can't call   fixtype   with any expr,
+   only a subexpr of its parameter. */
+
+	case TEXPR:
+		return( fixexpr((Exprp)p) );
+
+	case TLIST:
+		return( (expptr) p );
+
+	case TPRIM:
+		if(p->primblock.argsp && p->primblock.namep->vclass!=CLVAR)
+		{
+			if(p->primblock.namep->vtype == TYSUBR)
+			{
+				err("function invocation of subroutine");
+				return( errnode() );
+			}
+			else {
+				if (p->primblock.namep->vinftype)
+					wronginf(p->primblock.namep);
+				return( mkfunct(p) );
+				}
+		}
+
+/* The lack of args makes   p   a function name, substring reference
+   or variable name. */
+
+		else	return( mklhs((struct Primblock *) p) );
+	}
+}
+
+
+ static expptr
+cplenexpr(p)
+ expptr p;
+{
+	expptr rv;
+
+	rv = cpexpr(p->headblock.vleng);
+	if (ISCONST(p) && p->constblock.vtype == TYCHAR)
+		rv->constblock.Const.ci += p->constblock.Const.ccp1.blanks;
+	return rv;
+	}
+
+
+/* special case tree transformations and cleanups of expression trees.
+   Parameter   p   should have a TEXPR tag at its root, else an error is
+   returned */
+
+expptr fixexpr(p)
+register Exprp p;
+{
+	expptr lp;
+	register expptr rp;
+	register expptr q;
+	int opcode, ltype, rtype, ptype, mtype;
+
+	if( ISERROR(p) )
+		return( (expptr) p );
+	else if(p->tag != TEXPR)
+		badtag("fixexpr", p->tag);
+	opcode = p->opcode;
+
+/* First set the types of the left and right subexpressions */
+
+	lp = p->leftp;
+	if (!ISCONST(lp) || lp->constblock.vtype != TYCHAR)
+		lp = p->leftp = fixtype(lp);
+	ltype = lp->headblock.vtype;
+
+	if(opcode==OPASSIGN && lp->tag!=TADDR)
+	{
+		err("left side of assignment must be variable");
+		frexpr((expptr)p);
+		return( errnode() );
+	}
+
+	if(rp = p->rightp)
+	{
+		if (!ISCONST(rp) || rp->constblock.vtype != TYCHAR)
+			rp = p->rightp = fixtype(rp);
+		rtype = rp->headblock.vtype;
+	}
+	else
+		rtype = 0;
+
+	if(ltype==TYERROR || rtype==TYERROR)
+	{
+		frexpr((expptr)p);
+		return( errnode() );
+	}
+
+/* Now work on the whole expression */
+
+	/* force folding if possible */
+
+	if( ISCONST(lp) && (rp==NULL || ISCONST(rp)) )
+	{
+		q = opcode == OPCONV && lp->constblock.vtype == p->vtype
+			? lp : mkexpr(opcode, lp, rp);
+
+/* mkexpr is expected to reduce constant expressions */
+
+		if( ISCONST(q) ) {
+			p->leftp = p->rightp = 0;
+			frexpr(p);
+			return(q);
+			}
+		free( (charptr) q );	/* constants did not fold */
+	}
+
+	if( (ptype = cktype(opcode, ltype, rtype)) == TYERROR)
+	{
+		frexpr((expptr)p);
+		return( errnode() );
+	}
+
+	if (ltype == TYCHAR && ISCONST(lp))
+		p->leftp =  lp = (expptr)putconst((Constp)lp);
+	if (rtype == TYCHAR && ISCONST(rp))
+		p->rightp = rp = (expptr)putconst((Constp)rp);
+
+	switch(opcode)
+	{
+	case OPCONCAT:
+		if(p->vleng == NULL)
+			p->vleng = mkexpr(OPPLUS, cplenexpr(lp),
+					cplenexpr(rp) );
+		break;
+
+	case OPASSIGN:
+		if (rtype == TYREAL)
+			break;
+	case OPPLUSEQ:
+	case OPSTAREQ:
+		if(ltype == rtype)
+			break;
+		if( ! ISCONST(rp) && ISREAL(ltype) && ISREAL(rtype) )
+			break;
+		if( ISCOMPLEX(ltype) || ISCOMPLEX(rtype) )
+			break;
+		if( ONEOF(ltype, MSKADDR|MSKINT) && ONEOF(rtype, MSKADDR|MSKINT)
+		    && typesize[ltype]>=typesize[rtype] )
+			    break;
+
+/* Cast the right hand side to match the type of the expression */
+
+		p->rightp = fixtype( mkconv(ptype, rp) );
+		break;
+
+	case OPSLASH:
+		if( ISCOMPLEX(rtype) )
+		{
+			p = (Exprp) call2(ptype,
+
+/* Handle double precision complex variables */
+
+			    ptype == TYCOMPLEX ? "c_div" : "z_div",
+			    mkconv(ptype, lp), mkconv(ptype, rp) );
+			break;
+		}
+	case OPPLUS:
+	case OPMINUS:
+	case OPSTAR:
+	case OPMOD:
+		if(ptype==TYDREAL && ( (ltype==TYREAL && ! ISCONST(lp) ) ||
+		    (rtype==TYREAL && ! ISCONST(rp) ) ))
+			break;
+		if( ISCOMPLEX(ptype) )
+			break;
+
+/* Cast both sides of the expression to match the type of the whole
+   expression.  */
+
+		if(ltype != ptype && (ltype < TYSHORT || ptype > TYDREAL))
+			p->leftp = fixtype(mkconv(ptype,lp));
+		if(rtype != ptype && (rtype < TYSHORT || ptype > TYDREAL))
+			p->rightp = fixtype(mkconv(ptype,rp));
+		break;
+
+	case OPPOWER:
+		return( mkpower((expptr)p) );
+
+	case OPLT:
+	case OPLE:
+	case OPGT:
+	case OPGE:
+	case OPEQ:
+	case OPNE:
+		if(ltype == rtype)
+			break;
+		mtype = cktype(OPMINUS, ltype, rtype);
+		if(mtype==TYDREAL && ( (ltype==TYREAL && ! ISCONST(lp)) ||
+		    (rtype==TYREAL && ! ISCONST(rp)) ))
+			break;
+		if( ISCOMPLEX(mtype) )
+			break;
+		if(ltype != mtype)
+			p->leftp = fixtype(mkconv(mtype,lp));
+		if(rtype != mtype)
+			p->rightp = fixtype(mkconv(mtype,rp));
+		break;
+
+	case OPCONV:
+		ptype = cktype(OPCONV, p->vtype, ltype);
+		if(lp->tag==TEXPR && lp->exprblock.opcode==OPCOMMA)
+		{
+			lp->exprblock.rightp =
+			    fixtype( mkconv(ptype, lp->exprblock.rightp) );
+			free( (charptr) p );
+			p = (Exprp) lp;
+		}
+		break;
+
+	case OPADDR:
+		if(lp->tag==TEXPR && lp->exprblock.opcode==OPADDR)
+			Fatal("addr of addr");
+		break;
+
+	case OPCOMMA:
+	case OPQUEST:
+	case OPCOLON:
+		break;
+
+	case OPMIN:
+	case OPMAX:
+	case OPMIN2:
+	case OPMAX2:
+	case OPDMIN:
+	case OPDMAX:
+	case OPABS:
+	case OPDABS:
+		ptype = p->vtype;
+		break;
+
+	default:
+		break;
+	}
+
+	p->vtype = ptype;
+	return((expptr) p);
+}
+
+
+/* fix an argument list, taking due care for special first level cases */
+
+fixargs(doput, p0)
+int doput;	/* doput is true if constants need to be passed by reference */
+struct Listblock *p0;
+{
+	register chainp p;
+	register tagptr q, t;
+	register int qtag;
+	int nargs;
+	Addrp mkscalar();
+
+	nargs = 0;
+	if(p0)
+		for(p = p0->listp ; p ; p = p->nextp)
+		{
+			++nargs;
+			q = (tagptr)p->datap;
+			qtag = q->tag;
+			if(qtag == TCONST)
+			{
+
+/* Call putconst() to store values in a constant table.  Since even
+   constants must be passed by reference, this can optimize on the storage
+   required */
+
+				p->datap = doput ? (char *)putconst((Constp)q)
+						 : (char *)q;
+			}
+
+/* Take a function name and turn it into an Addr.  This only happens when
+   nothing else has figured out the function beforehand */
+
+			else if(qtag==TPRIM && q->primblock.argsp==0 &&
+			    q->primblock.namep->vclass==CLPROC &&
+			    q->primblock.namep->vprocclass != PTHISPROC)
+				p->datap = (char *)mkaddr(q->primblock.namep);
+
+			else if(qtag==TPRIM && q->primblock.argsp==0 &&
+			    q->primblock.namep->vdim!=NULL)
+				p->datap = (char *)mkscalar(q->primblock.namep);
+
+			else if(qtag==TPRIM && q->primblock.argsp==0 &&
+			    q->primblock.namep->vdovar &&
+			    (t = (tagptr) memversion(q->primblock.namep)) )
+				p->datap = (char *)fixtype(t);
+			else
+				p->datap = (char *)fixtype(q);
+		}
+	return(nargs);
+}
+
+
+
+/* mkscalar -- only called by   fixargs   above, and by some routines in
+   io.c */
+
+Addrp mkscalar(np)
+register Namep np;
+{
+	register Addrp ap;
+
+	vardcl(np);
+	ap = mkaddr(np);
+
+	/* The prolog causes array arguments to point to the
+	 * (0,...,0) element, unless subscript checking is on.
+	 */
+	if( !checksubs && np->vstg==STGARG)
+	{
+		register struct Dimblock *dp;
+		dp = np->vdim;
+		frexpr(ap->memoffset);
+		ap->memoffset = mkexpr(OPSTAR,
+		    (np->vtype==TYCHAR ?
+		    cpexpr(np->vleng) :
+		    (tagptr)ICON(typesize[np->vtype]) ),
+		    cpexpr(dp->baseoffset) );
+	}
+	return(ap);
+}
+
+
+ static void
+adjust_arginfo(np)	/* adjust arginfo to omit the length arg for the
+			   arg that we now know to be a character-valued
+			   function */
+ register Namep np;
+{
+	struct Entrypoint *ep;
+	register chainp args;
+	Argtypes *at;
+
+	for(ep = entries; ep; ep = ep->entnextp)
+		for(args = ep->arglist; args; args = args->nextp)
+			if (np == (Namep)args->datap
+			&& (at = ep->entryname->arginfo))
+				--at->nargs;
+	}
+
+
+
+expptr mkfunct(p0)
+ expptr p0;
+{
+	register struct Primblock *p = (struct Primblock *)p0;
+	struct Entrypoint *ep;
+	Addrp ap;
+	Extsym *extp;
+	register Namep np;
+	register expptr q;
+	expptr intrcall();
+	extern chainp new_procs;
+	int k, nargs;
+	int class;
+
+	if(p->tag != TPRIM)
+		return( errnode() );
+
+	np = p->namep;
+	class = np->vclass;
+
+
+	if(class == CLUNKNOWN)
+	{
+		np->vclass = class = CLPROC;
+		if(np->vstg == STGUNKNOWN)
+		{
+			if(np->vtype!=TYSUBR && (k = intrfunct(np->fvarname))
+				&& (zflag || !(*(struct Intrpacked *)&k).f4
+					|| dcomplex_seen))
+			{
+				np->vstg = STGINTR;
+				np->vardesc.varno = k;
+				np->vprocclass = PINTRINSIC;
+			}
+			else
+			{
+				extp = mkext(np->fvarname,
+					addunder(np->cvarname));
+				extp->extstg = STGEXT;
+				np->vstg = STGEXT;
+				np->vardesc.varno = extp - extsymtab;
+				np->vprocclass = PEXTERNAL;
+			}
+		}
+		else if(np->vstg==STGARG)
+		{
+		    if(np->vtype == TYCHAR) {
+			adjust_arginfo(np);
+			if (np->vpassed) {
+				char wbuf[160], *who;
+				who = np->fvarname;
+				sprintf(wbuf, "%s%s%s\n\t%s%s%s",
+					"Character-valued dummy procedure ",
+					who, " not declared EXTERNAL.",
+			"Code may be wrong for previous function calls having ",
+					who, " as a parameter.");
+				warn(wbuf);
+				}
+			}
+		    np->vprocclass = PEXTERNAL;
+		}
+	}
+
+	if(class != CLPROC)
+		fatali("invalid class code %d for function", class);
+
+/* F77 doesn't allow subscripting of function calls */
+
+	if(p->fcharp || p->lcharp)
+	{
+		err("no substring of function call");
+		goto error;
+	}
+	impldcl(np);
+	np->vimpltype = 0;	/* invoking as function ==> inferred type */
+	np->vcalled = 1;
+	nargs = fixargs( np->vprocclass!=PINTRINSIC,  p->argsp);
+
+	switch(np->vprocclass)
+	{
+	case PEXTERNAL:
+		if(np->vtype == TYUNKNOWN)
+		{
+			dclerr("attempt to use untyped function", np);
+			np->vtype = dflttype[letter(np->fvarname[0])];
+		}
+		ap = mkaddr(np);
+		if (!extsymtab[np->vardesc.varno].extseen) {
+			new_procs = mkchain((char *)np, new_procs);
+			extsymtab[np->vardesc.varno].extseen = 1;
+			}
+call:
+		q = mkexpr(OPCALL, (expptr)ap, (expptr)p->argsp);
+		q->exprblock.vtype = np->vtype;
+		if(np->vleng)
+			q->exprblock.vleng = (expptr) cpexpr(np->vleng);
+		break;
+
+	case PINTRINSIC:
+		q = intrcall(np, p->argsp, nargs);
+		break;
+
+	case PSTFUNCT:
+		q = stfcall(np, p->argsp);
+		break;
+
+	case PTHISPROC:
+		warn("recursive call");
+
+/* entries   is the list of multiple entry points */
+
+		for(ep = entries ; ep ; ep = ep->entnextp)
+			if(ep->enamep == np)
+				break;
+		if(ep == NULL)
+			Fatal("mkfunct: impossible recursion");
+
+		ap = builtin(np->vtype, ep->entryname->cextname, -2);
+		/* the negative last arg prevents adding */
+		/* this name to the list of used builtins */
+		goto call;
+
+	default:
+		fatali("mkfunct: impossible vprocclass %d",
+		    (int) (np->vprocclass) );
+	}
+	free( (charptr) p );
+	return(q);
+
+error:
+	frexpr((expptr)p);
+	return( errnode() );
+}
+
+
+
+LOCAL expptr stfcall(np, actlist)
+Namep np;
+struct Listblock *actlist;
+{
+	register chainp actuals;
+	int nargs;
+	chainp oactp, formals;
+	int type;
+	expptr Ln, Lq, q, q1, rhs, ap;
+	Namep tnp;
+	register struct Rplblock *rp;
+	struct Rplblock *tlist;
+	static int inv_count;
+
+	if (++inv_count > stfcall_MAX)
+		Fatal("Loop invoking recursive statement function?");
+	if(actlist)
+	{
+		actuals = actlist->listp;
+		free( (charptr) actlist);
+	}
+	else
+		actuals = NULL;
+	oactp = actuals;
+
+	nargs = 0;
+	tlist = NULL;
+	if( (type = np->vtype) == TYUNKNOWN)
+	{
+		dclerr("attempt to use untyped statement function", np);
+		type = np->vtype = dflttype[letter(np->fvarname[0])];
+	}
+	formals = (chainp) np->varxptr.vstfdesc->datap;
+	rhs = (expptr) (np->varxptr.vstfdesc->nextp);
+
+	/* copy actual arguments into temporaries */
+	while(actuals!=NULL && formals!=NULL)
+	{
+		rp = ALLOC(Rplblock);
+		rp->rplnp = tnp = (Namep) formals->datap;
+		ap = fixtype((tagptr)actuals->datap);
+		if(tnp->vtype==ap->headblock.vtype && tnp->vtype!=TYCHAR
+		    && (ap->tag==TCONST || ap->tag==TADDR) )
+		{
+
+/* If actuals are constants or variable names, no temporaries are required */
+			rp->rplvp = (expptr) ap;
+			rp->rplxp = NULL;
+			rp->rpltag = ap->tag;
+		}
+		else	{
+			rp->rplvp = (expptr) mktmp(tnp->vtype, tnp->vleng);
+			rp -> rplxp = NULL;
+			putexpr ( mkexpr(OPASSIGN, cpexpr(rp->rplvp), ap));
+			if((rp->rpltag = rp->rplvp->tag) == TERROR)
+				err("disagreement of argument types in statement function call");
+		}
+		rp->rplnextp = tlist;
+		tlist = rp;
+		actuals = actuals->nextp;
+		formals = formals->nextp;
+		++nargs;
+	}
+
+	if(actuals!=NULL || formals!=NULL)
+		err("statement function definition and argument list differ");
+
+	/*
+   now push down names involved in formal argument list, then
+   evaluate rhs of statement function definition in this environment
+*/
+
+	if(tlist)	/* put tlist in front of the rpllist */
+	{
+		for(rp = tlist; rp->rplnextp; rp = rp->rplnextp)
+			;
+		rp->rplnextp = rpllist;
+		rpllist = tlist;
+	}
+
+/* So when the expression finally gets evaled, that evaluator must read
+   from the globl   rpllist   14-jun-88 mwm */
+
+	q = (expptr) mkconv(type, fixtype(cpexpr(rhs)) );
+
+	/* get length right of character-valued statement functions... */
+	if (type == TYCHAR
+	 && (Ln = np->vleng)
+	 && q->tag != TERROR
+	 && (Lq = q->exprblock.vleng)
+	 && (Lq->tag != TCONST
+		|| Ln->constblock.Const.ci != Lq->constblock.Const.ci)) {
+		q1 = (expptr) mktmp(type, Ln);
+		putexpr ( mkexpr(OPASSIGN, cpexpr(q1), q));
+		q = q1;
+		}
+
+	/* now generate the tree ( t1=a1, (t2=a2,... , f))))) */
+	while(--nargs >= 0)
+	{
+		if(rpllist->rplxp)
+			q = mkexpr(OPCOMMA, rpllist->rplxp, q);
+		rp = rpllist->rplnextp;
+		frexpr(rpllist->rplvp);
+		free((char *)rpllist);
+		rpllist = rp;
+	}
+	frchain( &oactp );
+	--inv_count;
+	return(q);
+}
+
+
+static int replaced;
+
+/* mkplace -- Figure out the proper storage class for the input name and
+   return an addrp with the appropriate stuff */
+
+Addrp mkplace(np)
+register Namep np;
+{
+	register Addrp s;
+	register struct Rplblock *rp;
+	int regn;
+
+	/* is name on the replace list? */
+
+	for(rp = rpllist ; rp ; rp = rp->rplnextp)
+	{
+		if(np == rp->rplnp)
+		{
+			replaced = 1;
+			if(rp->rpltag == TNAME)
+			{
+				np = (Namep) (rp->rplvp);
+				break;
+			}
+			else	return( (Addrp) cpexpr(rp->rplvp) );
+		}
+	}
+
+	/* is variable a DO index in a register ? */
+
+	if(np->vdovar && ( (regn = inregister(np)) >= 0) )
+		if(np->vtype == TYERROR)
+			return((Addrp) errnode() );
+		else
+		{
+			s = ALLOC(Addrblock);
+			s->tag = TADDR;
+			s->vstg = STGREG;
+			s->vtype = TYIREG;
+			s->memno = regn;
+			s->memoffset = ICON(0);
+			s -> uname_tag = UNAM_NAME;
+			s -> user.name = np;
+			return(s);
+		}
+
+	vardcl(np);
+	return(mkaddr(np));
+}
+
+
+ static int doing_vleng;
+
+/* mklhs -- Compute the actual address of the given expression; account
+   for array subscripts, stack offset, and substring offsets.  The f -> C
+   translator will need this only to worry about the subscript stuff */
+
+expptr mklhs(p)
+register struct Primblock *p;
+{
+	expptr suboffset();
+	register Addrp s;
+	Namep np;
+
+	if(p->tag != TPRIM)
+		return( (expptr) p );
+	np = p->namep;
+
+	replaced = 0;
+	s = mkplace(np);
+	if(s->tag!=TADDR || s->vstg==STGREG)
+	{
+		free( (charptr) p );
+		return( (expptr) s );
+	}
+
+	/* compute the address modified by subscripts */
+
+	if (!replaced)
+		s->memoffset = mkexpr(OPPLUS, s->memoffset, suboffset(p) );
+	frexpr((expptr)p->argsp);
+	p->argsp = NULL;
+
+	/* now do substring part */
+
+	if(p->fcharp || p->lcharp)
+	{
+		if(np->vtype != TYCHAR)
+			errstr("substring of noncharacter %s", np->fvarname);
+		else	{
+			if(p->lcharp == NULL)
+				p->lcharp = (expptr) cpexpr(s->vleng);
+			if(p->fcharp) {
+				doing_vleng = 1;
+				s->vleng = fixtype(mkexpr(OPMINUS,
+						p->lcharp,
+					mkexpr(OPMINUS, p->fcharp, ICON(1) )));
+				doing_vleng = 0;
+				}
+			else	{
+				frexpr(s->vleng);
+				s->vleng = p->lcharp;
+			}
+		}
+	}
+
+	s->vleng = fixtype( s->vleng );
+	s->memoffset = fixtype( s->memoffset );
+	free( (charptr) p );
+	return( (expptr) s );
+}
+
+
+
+
+
+/* deregister -- remove a register allocation from the list; assumes that
+   names are deregistered in stack order (LIFO order - Last In First Out) */
+
+deregister(np)
+Namep np;
+{
+	if(nregvar>0 && regnamep[nregvar-1]==np)
+	{
+		--nregvar;
+	}
+}
+
+
+
+
+/* memversion -- moves a DO index REGISTER into a memory location; other
+   objects are passed through untouched */
+
+Addrp memversion(np)
+register Namep np;
+{
+	register Addrp s;
+
+	if(np->vdovar==NO || (inregister(np)<0) )
+		return(NULL);
+	np->vdovar = NO;
+	s = mkplace(np);
+	np->vdovar = YES;
+	return(s);
+}
+
+
+
+/* inregister -- looks for the input name in the global list   regnamep */
+
+inregister(np)
+register Namep np;
+{
+	register int i;
+
+	for(i = 0 ; i < nregvar ; ++i)
+		if(regnamep[i] == np)
+			return( regnum[i] );
+	return(-1);
+}
+
+
+
+/* suboffset -- Compute the offset from the start of the array, given the
+   subscripts as arguments */
+
+expptr suboffset(p)
+register struct Primblock *p;
+{
+	int n;
+	expptr si, size;
+	chainp cp;
+	expptr e, e1, offp, prod;
+	expptr subcheck();
+	struct Dimblock *dimp;
+	expptr sub[MAXDIM+1];
+	register Namep np;
+
+	np = p->namep;
+	offp = ICON(0);
+	n = 0;
+	if(p->argsp)
+		for(cp = p->argsp->listp ; cp ; cp = cp->nextp)
+		{
+			si = fixtype(cpexpr((tagptr)cp->datap));
+			if (!ISINT(si->headblock.vtype)) {
+				NOEXT("non-integer subscript");
+				si = mkconv(TYLONG, si);
+				}
+			sub[n++] = si;
+			if(n > maxdim)
+			{
+				erri("more than %d subscripts", maxdim);
+				break;
+			}
+		}
+
+	dimp = np->vdim;
+	if(n>0 && dimp==NULL)
+		errstr("subscripts on scalar variable %.68s", np->fvarname);
+	else if(dimp && dimp->ndim!=n)
+		errstr("wrong number of subscripts on %.68s", np->fvarname);
+	else if(n > 0)
+	{
+		prod = sub[--n];
+		while( --n >= 0)
+			prod = mkexpr(OPPLUS, sub[n],
+			    mkexpr(OPSTAR, prod, cpexpr(dimp->dims[n].dimsize)) );
+		if(checksubs || np->vstg!=STGARG)
+			prod = mkexpr(OPMINUS, prod, cpexpr(dimp->baseoffset));
+
+/* Add in the run-time bounds check */
+
+		if(checksubs)
+			prod = subcheck(np, prod);
+		size = np->vtype == TYCHAR ?
+		    (expptr) cpexpr(np->vleng) : ICON(typesize[np->vtype]);
+		prod = mkexpr(OPSTAR, prod, size);
+		offp = mkexpr(OPPLUS, offp, prod);
+	}
+
+/* Check for substring indicator */
+
+	if(p->fcharp && np->vtype==TYCHAR) {
+		e = p->fcharp;
+		e1 = mkexpr(OPMINUS, cpexpr(e), ICON(1));
+		if (!ISCONST(e) && (e->tag != TPRIM || e->primblock.argsp)) {
+			e = (expptr)mktmp(TYLONG, ENULL);
+			putout(putassign(cpexpr(e), e1));
+			p->fcharp = mkexpr(OPPLUS, cpexpr(e), ICON(1));
+			e1 = e;
+			}
+		offp = mkexpr(OPPLUS, offp, e1);
+		}
+	return(offp);
+}
+
+
+
+
+expptr subcheck(np, p)
+Namep np;
+register expptr p;
+{
+	struct Dimblock *dimp;
+	expptr t, checkvar, checkcond, badcall;
+
+	dimp = np->vdim;
+	if(dimp->nelt == NULL)
+		return(p);	/* don't check arrays with * bounds */
+	np->vlastdim = 0;
+	if( ISICON(p) )
+	{
+
+/* check for negative (constant) offset */
+
+		if(p->constblock.Const.ci < 0)
+			goto badsub;
+		if( ISICON(dimp->nelt) )
+
+/* see if constant offset exceeds the array declaration */
+
+			if(p->constblock.Const.ci < dimp->nelt->constblock.Const.ci)
+				return(p);
+			else
+				goto badsub;
+	}
+
+/* We know that the subscript offset   p   or   dimp -> nelt   is not a constant.
+   Now find a register to use for run-time bounds checking */
+
+	if(p->tag==TADDR && p->addrblock.vstg==STGREG)
+	{
+		checkvar = (expptr) cpexpr(p);
+		t = p;
+	}
+	else	{
+		checkvar = (expptr) mktmp(p->headblock.vtype, ENULL);
+		t = mkexpr(OPASSIGN, cpexpr(checkvar), p);
+	}
+	checkcond = mkexpr(OPLT, t, cpexpr(dimp->nelt) );
+	if( ! ISICON(p) )
+		checkcond = mkexpr(OPAND, checkcond,
+		    mkexpr(OPLE, ICON(0), cpexpr(checkvar)) );
+
+/* Construct the actual test */
+
+	badcall = call4(p->headblock.vtype, "s_rnge",
+	    mkstrcon(strlen(np->fvarname), np->fvarname),
+	    mkconv(TYLONG,  cpexpr(checkvar)),
+	    mkstrcon(strlen(procname), procname),
+	    ICON(lineno) );
+	badcall->exprblock.opcode = OPCCALL;
+	p = mkexpr(OPQUEST, checkcond,
+	    mkexpr(OPCOLON, checkvar, badcall));
+
+	return(p);
+
+badsub:
+	frexpr(p);
+	errstr("subscript on variable %s out of range", np->fvarname);
+	return ( ICON(0) );
+}
+
+
+
+
+Addrp mkaddr(p)
+register Namep p;
+{
+	Extsym *extp;
+	register Addrp t;
+	Addrp intraddr();
+	int k;
+
+	switch( p->vstg)
+	{
+	case STGAUTO:
+		if(p->vclass == CLPROC && p->vprocclass == PTHISPROC)
+			return (Addrp) cpexpr((expptr)xretslot[p->vtype]);
+		goto other;
+
+	case STGUNKNOWN:
+		if(p->vclass != CLPROC)
+			break;	/* Error */
+		extp = mkext(p->fvarname, addunder(p->cvarname));
+		extp->extstg = STGEXT;
+		p->vstg = STGEXT;
+		p->vardesc.varno = extp - extsymtab;
+		p->vprocclass = PEXTERNAL;
+		if ((extp->exproto || infertypes)
+		&& (p->vtype == TYUNKNOWN || p->vimpltype)
+		&& (k = extp->extype))
+			inferdcl(p, k);
+
+
+	case STGCOMMON:
+	case STGEXT:
+	case STGBSS:
+	case STGINIT:
+	case STGEQUIV:
+	case STGARG:
+	case STGLENG:
+ other:
+		t = ALLOC(Addrblock);
+		t->tag = TADDR;
+
+		t->vclass = p->vclass;
+		t->vtype = p->vtype;
+		t->vstg = p->vstg;
+		t->memno = p->vardesc.varno;
+		t->memoffset = ICON(p->voffset);
+		if (p->vdim)
+		    t->isarray = 1;
+		if(p->vleng)
+		{
+			t->vleng = (expptr) cpexpr(p->vleng);
+			if( ISICON(t->vleng) )
+				t->varleng = t->vleng->constblock.Const.ci;
+		}
+
+/* Keep the original name around for the C code generation */
+
+		t -> uname_tag = UNAM_NAME;
+		t -> user.name = p;
+		return(t);
+
+	case STGINTR:
+
+		return ( intraddr (p));
+	}
+	badstg("mkaddr", p->vstg);
+	/* NOT REACHED */ return 0;
+}
+
+
+
+
+/* mkarg -- create storage for a new parameter.  This is called when a
+   function returns a string (for the return value, which is the first
+   parameter), or when a variable-length string is passed to a function. */
+
+Addrp mkarg(type, argno)
+int type, argno;
+{
+	register Addrp p;
+
+	p = ALLOC(Addrblock);
+	p->tag = TADDR;
+	p->vtype = type;
+	p->vclass = CLVAR;
+
+/* TYLENG is the type of the field holding the length of a character string */
+
+	p->vstg = (type==TYLENG ? STGLENG : STGARG);
+	p->memno = argno;
+	return(p);
+}
+
+
+
+
+/* mkprim -- Create a PRIM (primary/primitive) block consisting of a
+   Nameblock (or Paramblock), arguments (actual params or array
+   subscripts) and substring bounds.  Requires that   v   have lots of
+   extra (uninitialized) storage, since it could be a paramblock or
+   nameblock */
+
+expptr mkprim(v0, args, substr)
+ Namep v0;
+ struct Listblock *args;
+ chainp substr;
+{
+	typedef union {
+		struct Paramblock paramblock;
+		struct Nameblock nameblock;
+		struct Headblock headblock;
+		} *Primu;
+	register Primu v = (Primu)v0;
+	register struct Primblock *p;
+
+	if(v->headblock.vclass == CLPARAM)
+	{
+
+/* v   is to be a Paramblock */
+
+		if(args || substr)
+		{
+			errstr("no qualifiers on parameter name %s",
+			    v->paramblock.fvarname);
+			frexpr((expptr)args);
+			if(substr)
+			{
+				frexpr((tagptr)substr->datap);
+				frexpr((tagptr)substr->nextp->datap);
+				frchain(&substr);
+			}
+			frexpr((expptr)v);
+			return( errnode() );
+		}
+		return( (expptr) cpexpr(v->paramblock.paramval) );
+	}
+
+	p = ALLOC(Primblock);
+	p->tag = TPRIM;
+	p->vtype = v->nameblock.vtype;
+
+/* v   is to be a Nameblock */
+
+	p->namep = (Namep) v;
+	p->argsp = args;
+	if(substr)
+	{
+		p->fcharp = (expptr) substr->datap;
+		p->lcharp = (expptr) substr->nextp->datap;
+		frchain(&substr);
+	}
+	return( (expptr) p);
+}
+
+
+
+/* vardcl -- attempt to fill out the Name template for variable   v.
+   This function is called on identifiers known to be variables or
+   recursive references to the same function */
+
+vardcl(v)
+register Namep v;
+{
+	struct Dimblock *t;
+	expptr neltp;
+	extern int doing_stmtfcn;
+
+	if(v->vclass == CLUNKNOWN) {
+		v->vclass = CLVAR;
+		if (v->vinftype) {
+			v->vtype = TYUNKNOWN;
+			if (v->vdcldone) {
+				v->vdcldone = 0;
+				impldcl(v);
+				}
+			}
+		}
+	if(v->vdcldone)
+		return;
+	if(v->vclass == CLNAMELIST)
+		return;
+
+	if(v->vtype == TYUNKNOWN)
+		impldcl(v);
+	else if(v->vclass!=CLVAR && v->vprocclass!=PTHISPROC)
+	{
+		dclerr("used as variable", v);
+		return;
+	}
+	if(v->vstg==STGUNKNOWN) {
+		if (doing_stmtfcn) {
+			/* neither declare this variable if its only use */
+			/* is in defining a stmt function, nor complain  */
+			/* that it is never used */
+			v->vimpldovar = 1;
+			return;
+			}
+		v->vstg = implstg[ letter(v->fvarname[0]) ];
+		v->vimplstg = 1;
+		}
+
+/* Compute the actual storage location, i.e. offsets from base addresses,
+   possibly the stack pointer */
+
+	switch(v->vstg)
+	{
+	case STGBSS:
+		v->vardesc.varno = ++lastvarno;
+		break;
+	case STGAUTO:
+		if(v->vclass==CLPROC && v->vprocclass==PTHISPROC)
+			break;
+		if(t = v->vdim)
+			if( (neltp = t->nelt) && ISCONST(neltp) ) ;
+			else
+				dclerr("adjustable automatic array", v);
+		break;
+
+	default:
+		break;
+	}
+	v->vdcldone = YES;
+}
+
+
+
+/* Set the implicit type declaration of parameter   p   based on its first
+   letter */
+
+impldcl(p)
+register Namep p;
+{
+	register int k;
+	int type;
+	ftnint leng;
+
+	if(p->vdcldone || (p->vclass==CLPROC && p->vprocclass==PINTRINSIC) )
+		return;
+	if(p->vtype == TYUNKNOWN)
+	{
+		k = letter(p->fvarname[0]);
+		type = impltype[ k ];
+		leng = implleng[ k ];
+		if(type == TYUNKNOWN)
+		{
+			if(p->vclass == CLPROC)
+				return;
+			dclerr("attempt to use undefined variable", p);
+			type = dflttype[k];
+			leng = 0;
+		}
+		settype(p, type, leng);
+		p->vimpltype = 1;
+	}
+}
+
+ void
+inferdcl(np,type)
+ Namep np;
+ int type;
+{
+	int k = impltype[letter(np->fvarname[0])];
+	if (k != type) {
+		np->vinftype = 1;
+		np->vtype = type;
+		frexpr(np->vleng);
+		np->vleng = 0;
+		}
+	np->vimpltype = 0;
+	np->vinfproc = 1;
+	}
+
+
+#define ICONEQ(z, c)  (ISICON(z) && z->constblock.Const.ci==c)
+#define COMMUTE	{ e = lp;  lp = rp;  rp = e; }
+
+
+
+/* mkexpr -- Make expression, and simplify constant subcomponents (tree
+   order is not preserved).  Assumes that   lp   is nonempty, and uses
+   fold()   to simplify adjacent constants */
+
+expptr mkexpr(opcode, lp, rp)
+int opcode;
+register expptr lp, rp;
+{
+	register expptr e, e1;
+	int etype;
+	int ltype, rtype;
+	int ltag, rtag;
+	long L;
+
+	ltype = lp->headblock.vtype;
+	ltag = lp->tag;
+	if(rp && opcode!=OPCALL && opcode!=OPCCALL)
+	{
+		rtype = rp->headblock.vtype;
+		rtag = rp->tag;
+	}
+	else rtype = 0;
+
+	etype = cktype(opcode, ltype, rtype);
+	if(etype == TYERROR)
+		goto error;
+
+	switch(opcode)
+	{
+		/* check for multiplication by 0 and 1 and addition to 0 */
+
+	case OPSTAR:
+		if( ISCONST(lp) )
+			COMMUTE
+
+			    if( ISICON(rp) )
+			{
+				if(rp->constblock.Const.ci == 0)
+					goto retright;
+				goto mulop;
+			}
+		break;
+
+	case OPSLASH:
+	case OPMOD:
+		if( ICONEQ(rp, 0) )
+		{
+			err("attempted division by zero");
+			rp = ICON(1);
+			break;
+		}
+		if(opcode == OPMOD)
+			break;
+
+/* Handle multiplying or dividing by 1, -1 */
+
+mulop:
+		if( ISICON(rp) )
+		{
+			if(rp->constblock.Const.ci == 1)
+				goto retleft;
+
+			if(rp->constblock.Const.ci == -1)
+			{
+				frexpr(rp);
+				return( mkexpr(OPNEG, lp, ENULL) );
+			}
+		}
+
+/* Group all constants together.  In particular,
+
+	(x * CONST1) * CONST2 ==> x * (CONST1 * CONST2)
+	(x * CONST1) / CONST2 ==> x * (CONST1 / CONST2)
+*/
+
+		if (lp->tag != TEXPR || !lp->exprblock.rightp
+				|| !ISICON(lp->exprblock.rightp))
+			break;
+
+		if (lp->exprblock.opcode == OPLSHIFT) {
+			L = 1 << lp->exprblock.rightp->constblock.Const.ci;
+			if (opcode == OPSTAR || ISICON(rp) &&
+					!(L % rp->constblock.Const.ci)) {
+				lp->exprblock.opcode = OPSTAR;
+				lp->exprblock.rightp->constblock.Const.ci = L;
+				}
+			}
+
+		if (lp->exprblock.opcode == OPSTAR) {
+			if(opcode == OPSTAR)
+				e = mkexpr(OPSTAR, lp->exprblock.rightp, rp);
+			else if(ISICON(rp) &&
+			    (lp->exprblock.rightp->constblock.Const.ci %
+			    rp->constblock.Const.ci) == 0)
+				e = mkexpr(OPSLASH, lp->exprblock.rightp, rp);
+			else	break;
+
+			e1 = lp->exprblock.leftp;
+			free( (charptr) lp );
+			return( mkexpr(OPSTAR, e1, e) );
+			}
+		break;
+
+
+	case OPPLUS:
+		if( ISCONST(lp) )
+			COMMUTE
+			    goto addop;
+
+	case OPMINUS:
+		if( ICONEQ(lp, 0) )
+		{
+			frexpr(lp);
+			return( mkexpr(OPNEG, rp, ENULL) );
+		}
+
+		if( ISCONST(rp) && is_negatable((Constp)rp))
+		{
+			opcode = OPPLUS;
+			consnegop((Constp)rp);
+		}
+
+/* Group constants in an addition expression (also subtraction, since the
+   subtracted value was negated above).  In particular,
+
+	(x + CONST1) + CONST2 ==> x + (CONST1 + CONST2)
+*/
+
+addop:
+		if( ISICON(rp) )
+		{
+			if(rp->constblock.Const.ci == 0)
+				goto retleft;
+			if( ISPLUSOP(lp) && ISICON(lp->exprblock.rightp) )
+			{
+				e = mkexpr(OPPLUS, lp->exprblock.rightp, rp);
+				e1 = lp->exprblock.leftp;
+				free( (charptr) lp );
+				return( mkexpr(OPPLUS, e1, e) );
+			}
+		}
+		if (opcode == OPMINUS && (ISINT(etype) || doing_vleng)) {
+			/* check for (i [+const]) - (i [+const]) */
+			if (lp->tag == TPRIM)
+				e = lp;
+			else if (lp->tag == TEXPR && lp->exprblock.opcode == OPPLUS
+					&& lp->exprblock.rightp->tag == TCONST) {
+				e = lp->exprblock.leftp;
+				if (e->tag != TPRIM)
+					break;
+				}
+			else
+				break;
+			if (e->primblock.argsp)
+				break;
+			if (rp->tag == TPRIM)
+				e1 = rp;
+			else if (rp->tag == TEXPR && rp->exprblock.opcode == OPPLUS
+					&& rp->exprblock.rightp->tag == TCONST) {
+				e1 = rp->exprblock.leftp;
+				if (e1->tag != TPRIM)
+					break;
+				}
+			else
+				break;
+			if (e->primblock.namep != e1->primblock.namep
+					|| e1->primblock.argsp)
+				break;
+			L = e == lp ? 0 : lp->exprblock.rightp->constblock.Const.ci;
+			if (e1 != rp)
+				L -= rp->exprblock.rightp->constblock.Const.ci;
+			frexpr(lp);
+			frexpr(rp);
+			return ICON(L);
+			}
+
+		break;
+
+
+	case OPPOWER:
+		break;
+
+/* Eliminate outermost double negations */
+
+	case OPNEG:
+	case OPNEG1:
+		if(ltag==TEXPR && lp->exprblock.opcode==OPNEG)
+		{
+			e = lp->exprblock.leftp;
+			free( (charptr) lp );
+			return(e);
+		}
+		break;
+
+/* Eliminate outermost double NOTs */
+
+	case OPNOT:
+		if(ltag==TEXPR && lp->exprblock.opcode==OPNOT)
+		{
+			e = lp->exprblock.leftp;
+			free( (charptr) lp );
+			return(e);
+		}
+		break;
+
+	case OPCALL:
+	case OPCCALL:
+		etype = ltype;
+		if(rp!=NULL && rp->listblock.listp==NULL)
+		{
+			free( (charptr) rp );
+			rp = NULL;
+		}
+		break;
+
+	case OPAND:
+	case OPOR:
+		if( ISCONST(lp) )
+			COMMUTE
+
+			    if( ISCONST(rp) )
+			{
+				if(rp->constblock.Const.ci == 0)
+					if(opcode == OPOR)
+						goto retleft;
+					else
+						goto retright;
+				else if(opcode == OPOR)
+					goto retright;
+				else
+					goto retleft;
+			}
+	case OPEQV:
+	case OPNEQV:
+
+	case OPBITAND:
+	case OPBITOR:
+	case OPBITXOR:
+	case OPBITNOT:
+	case OPLSHIFT:
+	case OPRSHIFT:
+
+	case OPLT:
+	case OPGT:
+	case OPLE:
+	case OPGE:
+	case OPEQ:
+	case OPNE:
+
+	case OPCONCAT:
+		break;
+	case OPMIN:
+	case OPMAX:
+	case OPMIN2:
+	case OPMAX2:
+	case OPDMIN:
+	case OPDMAX:
+
+	case OPASSIGN:
+	case OPASSIGNI:
+	case OPPLUSEQ:
+	case OPSTAREQ:
+	case OPMINUSEQ:
+	case OPSLASHEQ:
+	case OPMODEQ:
+	case OPLSHIFTEQ:
+	case OPRSHIFTEQ:
+	case OPBITANDEQ:
+	case OPBITXOREQ:
+	case OPBITOREQ:
+
+	case OPCONV:
+	case OPADDR:
+	case OPWHATSIN:
+
+	case OPCOMMA:
+	case OPCOMMA_ARG:
+	case OPQUEST:
+	case OPCOLON:
+	case OPDOT:
+	case OPARROW:
+	case OPIDENTITY:
+	case OPCHARCAST:
+	case OPABS:
+	case OPDABS:
+		break;
+
+	default:
+		badop("mkexpr", opcode);
+	}
+
+	e = (expptr) ALLOC(Exprblock);
+	e->exprblock.tag = TEXPR;
+	e->exprblock.opcode = opcode;
+	e->exprblock.vtype = etype;
+	e->exprblock.leftp = lp;
+	e->exprblock.rightp = rp;
+	if(ltag==TCONST && (rp==0 || rtag==TCONST) )
+		e = fold(e);
+	return(e);
+
+retleft:
+	frexpr(rp);
+	return(lp);
+
+retright:
+	frexpr(lp);
+	return(rp);
+
+error:
+	frexpr(lp);
+	if(rp && opcode!=OPCALL && opcode!=OPCCALL)
+		frexpr(rp);
+	return( errnode() );
+}
+
+#define ERR(s)   { errs = s; goto error; }
+
+/* cktype -- Check and return the type of the expression */
+
+cktype(op, lt, rt)
+register int op, lt, rt;
+{
+	char *errs;
+
+	if(lt==TYERROR || rt==TYERROR)
+		goto error1;
+
+	if(lt==TYUNKNOWN)
+		return(TYUNKNOWN);
+	if(rt==TYUNKNOWN)
+
+/* If not unary operation, return UNKNOWN */
+
+		if(!is_unary_op (op) && op != OPCALL && op != OPCCALL)
+			return(TYUNKNOWN);
+
+	switch(op)
+	{
+	case OPPLUS:
+	case OPMINUS:
+	case OPSTAR:
+	case OPSLASH:
+	case OPPOWER:
+	case OPMOD:
+		if( ISNUMERIC(lt) && ISNUMERIC(rt) )
+			return( maxtype(lt, rt) );
+		ERR("nonarithmetic operand of arithmetic operator")
+
+	case OPNEG:
+	case OPNEG1:
+		if( ISNUMERIC(lt) )
+			return(lt);
+		ERR("nonarithmetic operand of negation")
+
+	case OPNOT:
+		if(lt == TYLOGICAL)
+			return(TYLOGICAL);
+		ERR("NOT of nonlogical")
+
+	case OPAND:
+	case OPOR:
+	case OPEQV:
+	case OPNEQV:
+		if(lt==TYLOGICAL && rt==TYLOGICAL)
+			return(TYLOGICAL);
+		ERR("nonlogical operand of logical operator")
+
+	case OPLT:
+	case OPGT:
+	case OPLE:
+	case OPGE:
+	case OPEQ:
+	case OPNE:
+		if(lt==TYCHAR || rt==TYCHAR || lt==TYLOGICAL || rt==TYLOGICAL)
+		{
+			if(lt != rt)
+				ERR("illegal comparison")
+		}
+
+		else if( ISCOMPLEX(lt) || ISCOMPLEX(rt) )
+		{
+			if(op!=OPEQ && op!=OPNE)
+				ERR("order comparison of complex data")
+		}
+
+		else if( ! ISNUMERIC(lt) || ! ISNUMERIC(rt) )
+			ERR("comparison of nonarithmetic data")
+			    return(TYLOGICAL);
+
+	case OPCONCAT:
+		if(lt==TYCHAR && rt==TYCHAR)
+			return(TYCHAR);
+		ERR("concatenation of nonchar data")
+
+	case OPCALL:
+	case OPCCALL:
+	case OPIDENTITY:
+		return(lt);
+
+	case OPADDR:
+	case OPCHARCAST:
+		return(TYADDR);
+
+	case OPCONV:
+		if(rt == 0)
+			return(0);
+		if(lt==TYCHAR && ISINT(rt) )
+			return(TYCHAR);
+	case OPASSIGN:
+	case OPASSIGNI:
+	case OPMINUSEQ:
+	case OPPLUSEQ:
+	case OPSTAREQ:
+	case OPSLASHEQ:
+	case OPMODEQ:
+	case OPLSHIFTEQ:
+	case OPRSHIFTEQ:
+	case OPBITANDEQ:
+	case OPBITXOREQ:
+	case OPBITOREQ:
+		if( ISINT(lt) && rt==TYCHAR)
+			return(lt);
+		if(lt==TYCHAR || rt==TYCHAR || lt==TYLOGICAL || rt==TYLOGICAL)
+			if((op!=OPASSIGN && op != OPPLUSEQ && op != OPMINUSEQ)
+			    || (lt!=rt))
+			{
+				ERR("impossible conversion")
+			}
+		return(lt);
+
+	case OPMIN:
+	case OPMAX:
+	case OPDMIN:
+	case OPDMAX:
+	case OPMIN2:
+	case OPMAX2:
+	case OPBITOR:
+	case OPBITAND:
+	case OPBITXOR:
+	case OPBITNOT:
+	case OPLSHIFT:
+	case OPRSHIFT:
+	case OPWHATSIN:
+	case OPABS:
+	case OPDABS:
+		return(lt);
+
+	case OPCOMMA:
+	case OPCOMMA_ARG:
+	case OPQUEST:
+	case OPCOLON:		/* Only checks the rightmost type because
+				   of C language definition (rightmost
+				   comma-expr is the value of the expr) */
+		return(rt);
+
+	case OPDOT:
+	case OPARROW:
+	    return (lt);
+	    break;
+	default:
+		badop("cktype", op);
+	}
+error:
+	err(errs);
+error1:
+	return(TYERROR);
+}
+
+/* fold -- simplifies constant expressions; it assumes that e -> leftp and
+   e -> rightp are TCONST or NULL */
+
+ LOCAL expptr
+fold(e)
+ register expptr e;
+{
+	Constp p;
+	register expptr lp, rp;
+	int etype, mtype, ltype, rtype, opcode;
+	int i, bl, ll, lr;
+	char *q, *s;
+	struct Constblock lcon, rcon;
+	long L;
+	double d;
+
+	opcode = e->exprblock.opcode;
+	etype = e->exprblock.vtype;
+
+	lp = e->exprblock.leftp;
+	ltype = lp->headblock.vtype;
+	rp = e->exprblock.rightp;
+
+	if(rp == 0)
+		switch(opcode)
+		{
+		case OPNOT:
+			lp->constblock.Const.ci = ! lp->constblock.Const.ci;
+ retlp:
+			e->exprblock.leftp = 0;
+			frexpr(e);
+			return(lp);
+
+		case OPBITNOT:
+			lp->constblock.Const.ci = ~ lp->constblock.Const.ci;
+			goto retlp;
+
+		case OPNEG:
+		case OPNEG1:
+			consnegop((Constp)lp);
+			goto retlp;
+
+		case OPCONV:
+		case OPADDR:
+			return(e);
+
+		case OPABS:
+		case OPDABS:
+			switch(ltype) {
+			    case TYSHORT:
+			    case TYLONG:
+				if ((L = lp->constblock.Const.ci) < 0)
+					lp->constblock.Const.ci = -L;
+				goto retlp;
+			    case TYREAL:
+			    case TYDREAL:
+				if (lp->constblock.vstg) {
+				    s = lp->constblock.Const.cds[0];
+				    if (*s == '-')
+					lp->constblock.Const.cds[0] = s + 1;
+				    goto retlp;
+				}
+				if ((d = lp->constblock.Const.cd[0]) < 0.)
+					lp->constblock.Const.cd[0] = -d;
+			    case TYCOMPLEX:
+			    case TYDCOMPLEX:
+				return e;	/* lazy way out */
+			    }
+		default:
+			badop("fold", opcode);
+		}
+
+	rtype = rp->headblock.vtype;
+
+	p = ALLOC(Constblock);
+	p->tag = TCONST;
+	p->vtype = etype;
+	p->vleng = e->exprblock.vleng;
+
+	switch(opcode)
+	{
+	case OPCOMMA:
+	case OPCOMMA_ARG:
+	case OPQUEST:
+	case OPCOLON:
+		return(e);
+
+	case OPAND:
+		p->Const.ci = lp->constblock.Const.ci &&
+		    rp->constblock.Const.ci;
+		break;
+
+	case OPOR:
+		p->Const.ci = lp->constblock.Const.ci ||
+		    rp->constblock.Const.ci;
+		break;
+
+	case OPEQV:
+		p->Const.ci = lp->constblock.Const.ci ==
+		    rp->constblock.Const.ci;
+		break;
+
+	case OPNEQV:
+		p->Const.ci = lp->constblock.Const.ci !=
+		    rp->constblock.Const.ci;
+		break;
+
+	case OPBITAND:
+		p->Const.ci = lp->constblock.Const.ci &
+		    rp->constblock.Const.ci;
+		break;
+
+	case OPBITOR:
+		p->Const.ci = lp->constblock.Const.ci |
+		    rp->constblock.Const.ci;
+		break;
+
+	case OPBITXOR:
+		p->Const.ci = lp->constblock.Const.ci ^
+		    rp->constblock.Const.ci;
+		break;
+
+	case OPLSHIFT:
+		p->Const.ci = lp->constblock.Const.ci <<
+		    rp->constblock.Const.ci;
+		break;
+
+	case OPRSHIFT:
+		p->Const.ci = lp->constblock.Const.ci >>
+		    rp->constblock.Const.ci;
+		break;
+
+	case OPCONCAT:
+		ll = lp->constblock.vleng->constblock.Const.ci;
+		lr = rp->constblock.vleng->constblock.Const.ci;
+		bl = lp->constblock.Const.ccp1.blanks;
+		p->Const.ccp = q = (char *) ckalloc(ll+lr+bl);
+		p->Const.ccp1.blanks = rp->constblock.Const.ccp1.blanks;
+		p->vleng = ICON(ll+lr+bl);
+		s = lp->constblock.Const.ccp;
+		for(i = 0 ; i < ll ; ++i)
+			*q++ = *s++;
+		for(i = 0 ; i < bl ; i++)
+			*q++ = ' ';
+		s = rp->constblock.Const.ccp;
+		for(i = 0; i < lr; ++i)
+			*q++ = *s++;
+		break;
+
+
+	case OPPOWER:
+		if( ! ISINT(rtype) )
+			return(e);
+		conspower(p, (Constp)lp, rp->constblock.Const.ci);
+		break;
+
+
+	default:
+		if(ltype == TYCHAR)
+		{
+			lcon.Const.ci = cmpstr(lp->constblock.Const.ccp,
+			    rp->constblock.Const.ccp,
+			    lp->constblock.vleng->constblock.Const.ci,
+			    rp->constblock.vleng->constblock.Const.ci);
+			rcon.Const.ci = 0;
+			mtype = tyint;
+		}
+		else	{
+			mtype = maxtype(ltype, rtype);
+			consconv(mtype, &lcon, &lp->constblock);
+			consconv(mtype, &rcon, &rp->constblock);
+		}
+		consbinop(opcode, mtype, p, &lcon, &rcon);
+		break;
+	}
+
+	frexpr(e);
+	return( (expptr) p );
+}
+
+
+
+/* assign constant l = r , doing coercion */
+
+consconv(lt, lc, rc)
+ int lt;
+ register Constp lc, rc;
+{
+	int rt = rc->vtype;
+	register union Constant *lv = &lc->Const, *rv = &rc->Const;
+
+	lc->vtype = lt;
+	if (ONEOF(lt, MSKREAL|MSKCOMPLEX) && ONEOF(rt, MSKREAL|MSKCOMPLEX)) {
+		memcpy((char *)lv, (char *)rv, sizeof(union Constant));
+		lc->vstg = rc->vstg;
+		if (ISCOMPLEX(lt) && ISREAL(rt)) {
+			if (rc->vstg)
+				lv->cds[1] = cds("0",CNULL);
+			else
+				lv->cd[1] = 0.;
+			}
+		return;
+		}
+	lc->vstg = 0;
+
+	switch(lt)
+	{
+
+/* Casting to character means just copying the first sizeof (character)
+   bytes into a new 1 character string.  This is weird. */
+
+	case TYCHAR:
+		*(lv->ccp = (char *) ckalloc(1)) = rv->ci;
+		lv->ccp1.blanks = 0;
+		break;
+
+	case TYSHORT:
+	case TYLONG:
+		if(rt == TYCHAR)
+			lv->ci = rv->ccp[0];
+		else if( ISINT(rt) )
+			lv->ci = rv->ci;
+		else	lv->ci = rc->vstg ? atof(rv->cds[0]) : rv->cd[0];
+
+		break;
+
+	case TYCOMPLEX:
+	case TYDCOMPLEX:
+		lv->cd[1] = 0.;
+		lv->cd[0] = rv->ci;
+		break;
+
+	case TYREAL:
+	case TYDREAL:
+		lv->cd[0] = rv->ci;
+		break;
+
+	case TYLOGICAL:
+		lv->ci = rv->ci;
+		break;
+	}
+}
+
+
+
+/* Negate constant value -- changes the input node's value */
+
+consnegop(p)
+register Constp p;
+{
+	register char *s;
+
+	if (p->vstg) {
+		if (ISCOMPLEX(p->vtype)) {
+			s = p->Const.cds[1];
+			p->Const.cds[1] = *s == '-' ? s+1
+					: *s == '0' ? s : s-1;
+			}
+		s = p->Const.cds[0];
+		p->Const.cds[0] = *s == '-' ? s+1
+				: *s == '0' ? s : s-1;
+		return;
+		}
+	switch(p->vtype)
+	{
+	case TYSHORT:
+	case TYLONG:
+		p->Const.ci = - p->Const.ci;
+		break;
+
+	case TYCOMPLEX:
+	case TYDCOMPLEX:
+		p->Const.cd[1] = - p->Const.cd[1];
+		/* fall through and do the real parts */
+	case TYREAL:
+	case TYDREAL:
+		p->Const.cd[0] = - p->Const.cd[0];
+		break;
+	default:
+		badtype("consnegop", p->vtype);
+	}
+}
+
+
+
+/* conspower -- Expand out an exponentiation */
+
+ LOCAL void
+conspower(p, ap, n)
+ Constp p, ap;
+ ftnint n;
+{
+	register union Constant *powp = &p->Const;
+	register int type;
+	struct Constblock x, x0;
+
+	if (n == 1) {
+		memcpy((char *)powp, (char *)&ap->Const, sizeof(ap->Const));
+		return;
+		}
+
+	switch(type = ap->vtype)	/* pow = 1 */
+	{
+	case TYSHORT:
+	case TYLONG:
+		powp->ci = 1;
+		break;
+	case TYCOMPLEX:
+	case TYDCOMPLEX:
+		powp->cd[1] = 0;
+	case TYREAL:
+	case TYDREAL:
+		powp->cd[0] = 1;
+		break;
+	default:
+		badtype("conspower", type);
+	}
+
+	if(n == 0)
+		return;
+	switch(type)	/* x0 = ap */
+	{
+	case TYSHORT:
+	case TYLONG:
+		x0.Const.ci = ap->Const.ci;
+		break;
+	case TYCOMPLEX:
+	case TYDCOMPLEX:
+		x0.Const.cd[1] =
+			ap->vstg ? atof(ap->Const.cds[1]) : ap->Const.cd[1];
+	case TYREAL:
+	case TYDREAL:
+		x0.Const.cd[0] =
+			ap->vstg ? atof(ap->Const.cds[0]) : ap->Const.cd[0];
+		break;
+	}
+	x0.vtype = type;
+	x0.vstg = 0;
+	if(n < 0)
+	{
+		if( ISINT(type) )
+		{
+			err("integer ** negative number");
+			return;
+		}
+		else if (!x0.Const.cd[0]
+				&& (!ISCOMPLEX(type) || !x0.Const.cd[1])) {
+			err("0.0 ** negative number");
+			return;
+			}
+		n = -n;
+		consbinop(OPSLASH, type, &x, p, &x0);
+	}
+	else
+		consbinop(OPSTAR, type, &x, p, &x0);
+
+	for( ; ; )
+	{
+		if(n & 01)
+			consbinop(OPSTAR, type, p, p, &x);
+		if(n >>= 1)
+			consbinop(OPSTAR, type, &x, &x, &x);
+		else
+			break;
+	}
+}
+
+
+
+/* do constant operation cp = a op b -- assumes that   ap and bp   have data
+   matching the input   type */
+
+
+ LOCAL void
+consbinop(opcode, type, cpp, app, bpp)
+ int opcode, type;
+ Constp cpp, app, bpp;
+{
+	register union Constant *ap = &app->Const,
+				*bp = &bpp->Const,
+				*cp = &cpp->Const;
+	int k;
+	double ad[2], bd[2], temp;
+
+	cpp->vstg = 0;
+
+	if (ONEOF(type, MSKREAL|MSKCOMPLEX)) {
+		ad[0] = app->vstg ? atof(ap->cds[0]) : ap->cd[0];
+		bd[0] = bpp->vstg ? atof(bp->cds[0]) : bp->cd[0];
+		if (ISCOMPLEX(type)) {
+			ad[1] = app->vstg ? atof(ap->cds[1]) : ap->cd[1];
+			bd[1] = bpp->vstg ? atof(bp->cds[1]) : bp->cd[1];
+			}
+		}
+	switch(opcode)
+	{
+	case OPPLUS:
+		switch(type)
+		{
+		case TYSHORT:
+		case TYLONG:
+			cp->ci = ap->ci + bp->ci;
+			break;
+		case TYCOMPLEX:
+		case TYDCOMPLEX:
+			cp->cd[1] = ad[1] + bd[1];
+		case TYREAL:
+		case TYDREAL:
+			cp->cd[0] = ad[0] + bd[0];
+			break;
+		}
+		break;
+
+	case OPMINUS:
+		switch(type)
+		{
+		case TYSHORT:
+		case TYLONG:
+			cp->ci = ap->ci - bp->ci;
+			break;
+		case TYCOMPLEX:
+		case TYDCOMPLEX:
+			cp->cd[1] = ad[1] - bd[1];
+		case TYREAL:
+		case TYDREAL:
+			cp->cd[0] = ad[0] - bd[0];
+			break;
+		}
+		break;
+
+	case OPSTAR:
+		switch(type)
+		{
+		case TYSHORT:
+		case TYLONG:
+			cp->ci = ap->ci * bp->ci;
+			break;
+		case TYREAL:
+		case TYDREAL:
+			cp->cd[0] = ad[0] * bd[0];
+			break;
+		case TYCOMPLEX:
+		case TYDCOMPLEX:
+			temp = ad[0] * bd[0]  -  ad[1] * bd[1] ;
+			cp->cd[1] = ad[0] * bd[1]  +  ad[1] * bd[0] ;
+			cp->cd[0] = temp;
+			break;
+		}
+		break;
+	case OPSLASH:
+		switch(type)
+		{
+		case TYSHORT:
+		case TYLONG:
+			cp->ci = ap->ci / bp->ci;
+			break;
+		case TYREAL:
+		case TYDREAL:
+			cp->cd[0] = ad[0] / bd[0];
+			break;
+		case TYCOMPLEX:
+		case TYDCOMPLEX:
+			zdiv((dcomplex*)cp, (dcomplex*)ad, (dcomplex*)bd);
+			break;
+		}
+		break;
+
+	case OPMOD:
+		if( ISINT(type) )
+		{
+			cp->ci = ap->ci % bp->ci;
+			break;
+		}
+		else
+			Fatal("inline mod of noninteger");
+
+	case OPMIN2:
+	case OPDMIN:
+		switch(type)
+		{
+		case TYSHORT:
+		case TYLONG:
+			cp->ci = ap->ci <= bp->ci ? ap->ci : bp->ci;
+			break;
+		case TYREAL:
+		case TYDREAL:
+			cp->cd[0] = ad[0] <= bd[0] ? ad[0] : bd[0];
+			break;
+		default:
+			Fatal("inline min of exected type");
+		}
+		break;
+
+	case OPMAX2:
+	case OPDMAX:
+		switch(type)
+		{
+		case TYSHORT:
+		case TYLONG:
+			cp->ci = ap->ci >= bp->ci ? ap->ci : bp->ci;
+			break;
+		case TYREAL:
+		case TYDREAL:
+			cp->cd[0] = ad[0] >= bd[0] ? ad[0] : bd[0];
+			break;
+		default:
+			Fatal("inline max of exected type");
+		}
+		break;
+
+	default:	  /* relational ops */
+		switch(type)
+		{
+		case TYSHORT:
+		case TYLONG:
+			if(ap->ci < bp->ci)
+				k = -1;
+			else if(ap->ci == bp->ci)
+				k = 0;
+			else	k = 1;
+			break;
+		case TYREAL:
+		case TYDREAL:
+			if(ad[0] < bd[0])
+				k = -1;
+			else if(ad[0] == bd[0])
+				k = 0;
+			else	k = 1;
+			break;
+		case TYCOMPLEX:
+		case TYDCOMPLEX:
+			if(ad[0] == bd[0] &&
+			    ad[1] == bd[1] )
+				k = 0;
+			else	k = 1;
+			break;
+		}
+
+		switch(opcode)
+		{
+		case OPEQ:
+			cp->ci = (k == 0);
+			break;
+		case OPNE:
+			cp->ci = (k != 0);
+			break;
+		case OPGT:
+			cp->ci = (k == 1);
+			break;
+		case OPLT:
+			cp->ci = (k == -1);
+			break;
+		case OPGE:
+			cp->ci = (k >= 0);
+			break;
+		case OPLE:
+			cp->ci = (k <= 0);
+			break;
+		}
+		break;
+	}
+}
+
+
+
+/* conssgn - returns the sign of a Fortran constant */
+
+conssgn(p)
+register expptr p;
+{
+	register char *s;
+
+	if( ! ISCONST(p) )
+		Fatal( "sgn(nonconstant)" );
+
+	switch(p->headblock.vtype)
+	{
+	case TYSHORT:
+	case TYLONG:
+		if(p->constblock.Const.ci > 0) return(1);
+		if(p->constblock.Const.ci < 0) return(-1);
+		return(0);
+
+	case TYREAL:
+	case TYDREAL:
+		if (p->constblock.vstg) {
+			s = p->constblock.Const.cds[0];
+			if (*s == '-')
+				return -1;
+			if (*s == '0')
+				return 0;
+			return 1;
+			}
+		if(p->constblock.Const.cd[0] > 0) return(1);
+		if(p->constblock.Const.cd[0] < 0) return(-1);
+		return(0);
+
+
+/* The sign of a complex number is 0 iff the number is 0 + 0i, else it's 1 */
+
+	case TYCOMPLEX:
+	case TYDCOMPLEX:
+		if (p->constblock.vstg)
+			return *p->constblock.Const.cds[0] != '0'
+			    && *p->constblock.Const.cds[1] != '0';
+		return(p->constblock.Const.cd[0]!=0 || p->constblock.Const.cd[1]!=0);
+
+	default:
+		badtype( "conssgn", p->constblock.vtype);
+	}
+	/* NOT REACHED */ return 0;
+}
+
+char *powint[ ] = {
+	"pow_ii", "pow_ri", "pow_di", "pow_ci", "pow_zi" };
+
+LOCAL expptr mkpower(p)
+register expptr p;
+{
+	register expptr q, lp, rp;
+	int ltype, rtype, mtype, tyi;
+
+	lp = p->exprblock.leftp;
+	rp = p->exprblock.rightp;
+	ltype = lp->headblock.vtype;
+	rtype = rp->headblock.vtype;
+
+	if(ISICON(rp))
+	{
+		if(rp->constblock.Const.ci == 0)
+		{
+			frexpr(p);
+			if( ISINT(ltype) )
+				return( ICON(1) );
+			else if (ISREAL (ltype))
+				return mkconv (ltype, ICON (1));
+			else
+				return( (expptr) putconst((Constp)
+					mkconv(ltype, ICON(1))) );
+		}
+		if(rp->constblock.Const.ci < 0)
+		{
+			if( ISINT(ltype) )
+			{
+				frexpr(p);
+				err("integer**negative");
+				return( errnode() );
+			}
+			rp->constblock.Const.ci = - rp->constblock.Const.ci;
+			p->exprblock.leftp = lp
+				= fixexpr((Exprp)mkexpr(OPSLASH, ICON(1), lp));
+		}
+		if(rp->constblock.Const.ci == 1)
+		{
+			frexpr(rp);
+			free( (charptr) p );
+			return(lp);
+		}
+
+		if( ONEOF(ltype, MSKINT|MSKREAL) && !doin_setbound) {
+			p->exprblock.vtype = ltype;
+			return(p);
+		}
+	}
+	if( ISINT(rtype) )
+	{
+		if(ltype==TYSHORT && rtype==TYSHORT && (!ISCONST(lp) || tyint==TYSHORT) )
+			q = call2(TYSHORT, "pow_hh", lp, rp);
+		else	{
+			if(ltype == TYSHORT)
+			{
+				ltype = TYLONG;
+				lp = mkconv(TYLONG,lp);
+			}
+			rp = mkconv(TYLONG,rp);
+			if (ISCONST(rp)) {
+				tyi = tyint;
+				tyint = TYLONG;
+				rp = (expptr)putconst((Constp)rp);
+				tyint = tyi;
+				}
+			q = call2(ltype, powint[ltype-TYLONG], lp, rp);
+		}
+	}
+	else if( ISREAL( (mtype = maxtype(ltype,rtype)) )) {
+		extern int callk_kludge;
+		callk_kludge = TYDREAL;
+		q = call2(mtype, "pow_dd", mkconv(TYDREAL,lp), mkconv(TYDREAL,rp));
+		callk_kludge = 0;
+		}
+	else	{
+		q  = call2(TYDCOMPLEX, "pow_zz",
+		    mkconv(TYDCOMPLEX,lp), mkconv(TYDCOMPLEX,rp));
+		if(mtype == TYCOMPLEX)
+			q = mkconv(TYCOMPLEX, q);
+	}
+	free( (charptr) p );
+	return(q);
+}
+
+
+/* Complex Division.  Same code as in Runtime Library
+*/
+
+
+ LOCAL void
+zdiv(c, a, b)
+ register dcomplex *a, *b, *c;
+{
+	double ratio, den;
+	double abr, abi;
+
+	if( (abr = b->dreal) < 0.)
+		abr = - abr;
+	if( (abi = b->dimag) < 0.)
+		abi = - abi;
+	if( abr <= abi )
+	{
+		if(abi == 0)
+			Fatal("complex division by zero");
+		ratio = b->dreal / b->dimag ;
+		den = b->dimag * (1 + ratio*ratio);
+		c->dreal = (a->dreal*ratio + a->dimag) / den;
+		c->dimag = (a->dimag*ratio - a->dreal) / den;
+	}
+
+	else
+	{
+		ratio = b->dimag / b->dreal ;
+		den = b->dreal * (1 + ratio*ratio);
+		c->dreal = (a->dreal + a->dimag*ratio) / den;
+		c->dimag = (a->dimag - a->dreal*ratio) / den;
+	}
+}

+ 182 - 0
lang/fortran/comp/f2c.1

@@ -0,0 +1,182 @@
+
+     F2C(1)							F2C(1)
+
+     NAME
+	  f2c -	Convert	Fortran	77 to C	or C++
+
+     SYNOPSIS
+	  f2c [	option ... ] file ...
+
+     DESCRIPTION
+	  F2c converts Fortran 77 source code in files with names end-
+	  ing in `.f' or `.F' to C (or C++) source files in the
+	  current directory, with `.c' substituted for the final `.f'
+	  or `.F'.  If no Fortran files	are named, f2c reads Fortran
+	  from standard	input and writes C on standard output.	File
+	  names	that end with `.p' or `.P' are taken to	be prototype
+	  files, as produced by	option `-P', and are read first.
+
+	  The following	options	have the same meaning as in f77(1).
+
+	  -C   Compile code to check that subscripts are within
+	       declared	array bounds.
+
+	  -I2  Render INTEGER and LOGICAL as short, INTEGER*4 as long
+	       int.  Assume the	default	libF77 and libI77:  allow only
+	       INTEGER*4 (and no LOGICAL) variables in INQUIREs.
+	       Option `-I4' confirms the default rendering of INTEGER
+	       as long int.
+
+	  -onetrip
+	       Compile DO loops	that are performed at least once if
+	       reached.	 (Fortran 77 DO	loops are not performed	at all
+	       if the upper limit is smaller than the lower limit.)
+
+	  -U   Honor the case of variable and external names.  Fortran
+	       keywords	must be	in lower case.
+
+	  -u   Make the	default	type of	a variable `undefined' rather
+	       than using the default Fortran rules.
+
+	  -w   Suppress	all warning messages.  If the option is
+	       `-w66', only Fortran 66 compatibility warnings are
+	       suppressed.
+
+	  The following	options	are peculiar to	f2c.
+
+	  -A   Produce ANSI C.	Default	is old-style C.
+
+	  -a   Make local variables automatic rather than static
+	       unless they appear in a DATA, EQUIVALENCE, NAMELIST, or
+	       SAVE statement.
+
+	  -C++ Output C++ code.
+
+	  -c   Include original	Fortran	source as comments.
+
+     Page 1		       Tenth Edition	     (printed 4/25/91)
+
+     F2C(1)							F2C(1)
+
+	  -E   Declare uninitialized COMMON to be Extern (overridably
+	       defined in f2c.h	as extern).
+
+	  -ec  Place uninitialized COMMON blocks in separate files:
+	       COMMON /ABC/ appears in file abc_com.c.	Option `-e1c'
+	       bundles the separate files into the output file,	with
+	       comments	that give an unbundling	sed(1) script.
+
+	  -ext Complain	about f77(1) extensions.
+
+	  -g   Include original	Fortran	line numbers as	comments.
+
+	  -h   Try to align character strings on word (or, if the
+	       option is `-hd',	on double-word)	boundaries.
+
+	  -i2  Similar to -I2, but assume a modified libF77 and	libI77
+	       (compiled with -Df2c_i2), so INTEGER and	LOGICAL	vari-
+	       ables may be assigned by	INQUIRE	and array lengths are
+	       stored in short ints.
+
+	  -kr  Use temporary values to enforce Fortran expression
+	       evaluation where	K&R (first edition) parenthesization
+	       rules allow rearrangement.  If the option is `-krd',
+	       use double precision temporaries	even for single-
+	       precision operands.
+
+	  -P   Write a file.P of ANSI (or C++) prototypes for pro-
+	       cedures defined in each input file.f or file.F.	When
+	       reading Fortran from standard input, write prototypes
+	       at the beginning	of standard output.  Implies -A	unless
+	       option `-C++' is	present.  Option -Ps implies -P	, and
+	       gives exit status 4 if rerunning	f2c may	change proto-
+	       types or	declarations.
+
+	  -p   Supply preprocessor definitions to make common-block
+	       members look like local variables.
+
+	  -R   Do not promote REAL functions and operations to DOUBLE
+	       PRECISION.  Option `-!R'	confirms the default, which
+	       imitates	f77.
+
+	  -r   Cast values of REAL functions (including	intrinsics) to
+	       REAL.
+
+	  -r8  Promote REAL to DOUBLE PRECISION, COMPLEX to DOUBLE
+	       COMPLEX.
+
+	  -Tdir
+	       Put temporary files in directory	dir.
+
+	  -w8  Suppress	warnings when COMMON or	EQUIVALENCE forces
+	       odd-word	alignment of doubles.
+
+     Page 2		       Tenth Edition	     (printed 4/25/91)
+
+     F2C(1)							F2C(1)
+
+	  -Wn  Assume n	characters/word	(default 4) when initializing
+	       numeric variables with character	data.
+
+	  -z   Do not implicitly recognize DOUBLE COMPLEX.
+
+	  -!bs Do not recognize	backslash escapes (\", \', \0, \\, \b,
+	       \f, \n, \r, \t, \v) in character	strings.
+
+	  -!c  Inhibit C output, but produce -P	output.
+
+	  -!I  Reject include statements.
+
+	  -!it Don't infer types of untyped EXTERNAL procedures	from
+	       use as parameters to previously defined or prototyped
+	       procedures.
+
+	  -!P  Do not attempt to infer ANSI or C++ prototypes from
+	       usage.
+
+	  The resulting	C invokes the support routines of f77; object
+	  code should be loaded	by f77 or with ld(1) or	cc(1) options
+	  -lF77	-lI77 -lm.  Calling conventions	are those of f77: see
+	  the reference	below.
+
+     FILES
+	  file.[fF]
+	       input file
+
+	  *.c  output file
+
+	  /usr/include/f2c.h
+	       header file
+
+	  /usr/lib/libF77.a
+	       intrinsic function library
+
+	  /usr/lib/libI77.a
+	       Fortran I/O library
+
+	  /lib/libc.a
+	       C library, see section 3
+
+     SEE ALSO
+	  S. I.	Feldman	and P. J. Weinberger, `A Portable Fortran 77
+	  Compiler', UNIX Time Sharing System Programmer's Manual,
+	  Tenth	Edition, Volume	2, AT&T	Bell Laboratories, 1990.
+
+     DIAGNOSTICS
+	  The diagnostics produced by f2c are intended to be self-
+	  explanatory.
+
+     BUGS
+
+     Page 3		       Tenth Edition	     (printed 4/25/91)
+
+     F2C(1)							F2C(1)
+
+	  Floating-point constant expressions are simplified in	the
+	  floating-point arithmetic of the machine running f2c,	so
+	  they are typically accurate to at most 16 or 17 decimal
+	  places.
+	  Untypable EXTERNAL functions are declared int.
+
+     Page 4		       Tenth Edition	     (printed 4/25/91)
+

+ 326 - 0
lang/fortran/comp/f2c.1t

@@ -0,0 +1,326 @@
+. \" Definitions of F, L and LR for the benefit of systems
+. \" whose -man lacks them...
+.de F
+.nh
+.if n \%\&\\$1
+.if t \%\&\f(CW\\$1\fR
+.hy 14
+..
+.de L
+.nh
+.if n \%`\\$1'
+.if t \%\&\f(CW\\$1\fR
+.hy 14
+..
+.de LR
+.nh
+.if n \%`\\$1'\\$2
+.if t \%\&\f(CW\\$1\fR\\$2
+.hy 14
+..
+.TH F2C 1
+.CT 1 prog_other
+.SH NAME
+f\^2c \(mi Convert Fortran 77 to C or C++
+.SH SYNOPSIS
+.B f\^2c
+[
+.I option ...
+]
+.I file ...
+.SH DESCRIPTION
+.I F2c
+converts Fortran 77 source code in
+.I files
+with names ending in
+.L .f
+or
+.L .F
+to C (or C++) source files in the
+current directory, with
+.L .c
+substituted
+for the final
+.L .f
+or
+.LR .F .
+If no Fortran files are named,
+.I f\^2c
+reads Fortran from standard input and
+writes C on standard output.
+.I File
+names that end with
+.L .p
+or
+.L .P
+are taken to be prototype
+files, as produced by option
+.LR -P ,
+and are read first.
+.PP
+The following options have the same meaning as in
+.IR f\^77 (1).
+.TP
+.B -C
+Compile code to check that subscripts are within declared array bounds.
+.TP
+.B -I2
+Render INTEGER and LOGICAL as short,
+INTEGER\(**4 as long int.  Assume the default \fIlibF77\fR
+and \fIlibI77\fR:  allow only INTEGER\(**4 (and no LOGICAL)
+variables in INQUIREs.  Option
+.L -I4
+confirms the default rendering of INTEGER as long int.
+.TP
+.B -onetrip
+Compile DO loops that are performed at least once if reached.
+(Fortran 77 DO loops are not performed at all if the upper limit is smaller than the lower limit.)
+.TP
+.B -U
+Honor the case of variable and external names.  Fortran keywords must be in
+.I
+lower
+case.
+.TP
+.B -u
+Make the default type of a variable `undefined' rather than using the default Fortran rules.
+.TP
+.B -w
+Suppress all warning messages.
+If the option is
+.LR -w66 ,
+only Fortran 66 compatibility warnings are suppressed.
+.PP
+The following options are peculiar to
+.IR f\^2c .
+.TP
+.B -A
+Produce
+.SM ANSI
+C.
+Default is old-style C.
+.TP
+.B -a
+Make local variables automatic rather than static
+unless they appear in a
+.SM "DATA, EQUIVALENCE, NAMELIST,"
+or
+.SM SAVE
+statement.
+.TP
+.B -C++
+Output C++ code.
+.TP
+.B -c
+Include original Fortran source as comments.
+.TP
+.B -E
+Declare uninitialized
+.SM COMMON
+to be
+.B Extern
+(overridably defined in
+.F f2c.h
+as
+.B extern).
+.TP
+.B -ec
+Place uninitialized
+.SM COMMON
+blocks in separate files:
+.B COMMON /ABC/
+appears in file
+.BR abc_com.c .
+Option
+.LR -e1c
+bundles the separate files
+into the output file, with comments that give an unbundling
+.IR sed (1)
+script.
+.TP
+.B -ext
+Complain about
+.IR f\^77 (1)
+extensions.
+.TP
+.B -g
+Include original Fortran line numbers as comments.
+.TP
+.B -h
+Try to align character strings on word (or, if the option is
+.LR -hd ,
+on double-word) boundaries.
+.TP
+.B -i2
+Similar to
+.BR -I2 ,
+but assume a modified
+.I libF77
+and
+.I libI77
+(compiled with
+.BR -Df\^2c_i2 ),
+so
+.SM INTEGER
+and
+.SM LOGICAL
+variables may be assigned by
+.SM INQUIRE
+and array lengths are stored in short ints.
+.TP
+.B -kr
+Use temporary values to enforce Fortran expression evaluation
+where K&R (first edition) parenthesization rules allow rearrangement.
+If the option is
+.LR -krd ,
+use double precision temporaries even for single-precision operands.
+.TP
+.B -P
+Write a
+.IB file .P
+of ANSI (or C++) prototypes
+for procedures defined in each input
+.IB file .f
+or
+.IB file .F .
+When reading Fortran from standard input, write prototypes
+at the beginning of standard output.
+Implies
+.B -A
+unless option
+.L -C++
+is present.  Option
+.B -Ps
+implies
+.B -P ,
+and gives exit status 4 if rerunning
+.I f\^2c
+may change prototypes or declarations.
+.TP
+.B -p
+Supply preprocessor definitions to make common-block members
+look like local variables.
+.TP
+.B -R
+Do not promote
+.SM REAL
+functions and operations to
+.SM DOUBLE PRECISION.
+Option
+.L -!R
+confirms the default, which imitates
+.IR f\^77 .
+.TP
+.B -r
+Cast values of REAL functions (including intrinsics) to REAL.
+.TP
+.B -r8
+Promote
+.SM REAL
+to
+.SM DOUBLE PRECISION, COMPLEX
+to
+.SM DOUBLE COMPLEX.
+.TP
+.BI -T dir
+Put temporary files in directory
+.I dir.
+.TP
+.B -w8
+Suppress warnings when
+.SM COMMON
+or
+.SM EQUIVALENCE
+forces odd-word alignment of doubles.
+.TP
+.BI -W n
+Assume
+.I n
+characters/word (default 4)
+when initializing numeric variables with character data.
+.TP
+.B -z
+Do not implicitly recognize
+.SM DOUBLE COMPLEX.
+.TP
+.B -!bs
+Do not recognize \fIb\fRack\fIs\fRlash escapes
+(\e", \e', \e0, \e\e, \eb, \ef, \en, \er, \et, \ev) in character strings.
+.TP
+.B -!c
+Inhibit C output, but produce
+.B -P
+output.
+.TP
+.B -!I
+Reject
+.B include
+statements.
+.TP
+.B -!it
+Don't infer types of untyped
+.SM EXTERNAL
+procedures from use as parameters to previously defined or prototyped
+procedures.
+.TP
+.B -!P
+Do not attempt to infer
+.SM ANSI
+or C++
+prototypes from usage.
+.PP
+The resulting C invokes the support routines of
+.IR f\^77 ;
+object code should be loaded by
+.I f\^77
+or with
+.IR ld (1)
+or
+.IR cc (1)
+options
+.BR "-lF77 -lI77 -lm" .
+Calling conventions
+are those of
+.IR f\&77 :
+see the reference below.
+.br
+.SH FILES
+.TP
+.IB file .[fF]
+input file
+.TP
+.B *.c
+output file
+.TP
+.F /usr/include/f2c.h
+header file
+.TP
+.F /usr/lib/libF77.a
+intrinsic function library
+.TP
+.F /usr/lib/libI77.a
+Fortran I/O library
+.TP
+.F /lib/libc.a
+C library, see section 3
+.SH "SEE ALSO"
+S. I. Feldman and
+P. J. Weinberger,
+`A Portable Fortran 77 Compiler',
+\fIUNIX Time Sharing System Programmer's Manual\fR,
+Tenth Edition, Volume 2, AT&T Bell Laboratories, 1990.
+.SH DIAGNOSTICS
+The diagnostics produced by
+.I f\^2c
+are intended to be
+self-explanatory.
+.SH BUGS
+Floating-point constant expressions are simplified in
+the floating-point arithmetic of the machine running
+.IR f\^2c ,
+so they are typically accurate to at most 16 or 17 decimal places.
+.br
+Untypable
+.SM EXTERNAL
+functions are declared
+.BR int .

+ 317 - 0
lang/fortran/comp/f2c.6

@@ -0,0 +1,317 @@
+. \" Definitions of F, L and LR for the benefit of systems
+. \" whose -man lacks them...
+.de F
+.nh
+.if n \%\&\\$1
+.if t \%\&\f(CW\\$1\fR
+.hy 14
+..
+.de L
+.nh
+.if n \%`\\$1'
+.if t \%\&\f(CW\\$1\fR
+.hy 14
+..
+.de LR
+.nh
+.if n \%`\\$1'\\$2
+.if t \%\&\f(CW\\$1\fR\\$2
+.hy 14
+..
+.TH F2C 6
+.CT 1 prog_other
+.SH NAME
+f\^2c \(mi Convert Fortran 77 to C or C++
+.SH SYNOPSIS
+.B ~em/lib.bin/f\^2c
+[
+.I option ...
+]
+.I file ...
+.SH DESCRIPTION
+.I F2c
+converts Fortran 77 source code in
+.I files
+with names ending in
+.L .f
+or
+.L .F
+to C (or C++) source files in the
+current directory, with
+.L .c
+substituted
+for the final
+.L .f
+or
+.LR .F .
+If no Fortran files are named,
+.I f\^2c
+reads Fortran from standard input and
+writes C on standard output.
+.I File
+names that end with
+.L .p
+or
+.L .P
+are taken to be prototype
+files, as produced by option
+.LR -P ,
+and are read first.
+.PP
+The following options have the same meaning as in
+.IR f\^77 (1).
+.TP
+.B -C
+Compile code to check that subscripts are within declared array bounds.
+.TP
+.B -I2
+Render INTEGER and LOGICAL as short,
+INTEGER\(**4 as long int.  Assume the default \fIlibF77\fR
+and \fIlibI77\fR:  allow only INTEGER\(**4 (and no LOGICAL)
+variables in INQUIREs.  Option
+.L -I4
+confirms the default rendering of INTEGER as long int.
+.TP
+.B -onetrip
+Compile DO loops that are performed at least once if reached.
+(Fortran 77 DO loops are not performed at all if the upper limit is smaller than the lower limit.)
+.TP
+.B -U
+Honor the case of variable and external names.  Fortran keywords must be in
+.I
+lower
+case.
+.TP
+.B -u
+Make the default type of a variable `undefined' rather than using the default Fortran rules.
+.TP
+.B -w
+Suppress all warning messages.
+If the option is
+.LR -w66 ,
+only Fortran 66 compatibility warnings are suppressed.
+.PP
+The following options are peculiar to
+.IR f\^2c .
+.TP
+.B -A
+Produce
+.SM ANSI
+C.
+Default is old-style C.
+.TP
+.B -a
+Make local variables automatic rather than static
+unless they appear in a
+.SM "DATA, EQUIVALENCE, NAMELIST,"
+or
+.SM SAVE
+statement.
+.TP
+.B -C++
+Output C++ code.
+.TP
+.B -c
+Include original Fortran source as comments.
+.TP
+.B -E
+Declare uninitialized
+.SM COMMON
+to be
+.B Extern
+(overridably defined in
+.F f2c.h
+as
+.B extern).
+.TP
+.B -ec
+Place uninitialized
+.SM COMMON
+blocks in separate files:
+.B COMMON /ABC/
+appears in file
+.BR abc_com.c .
+Option
+.LR -e1c
+bundles the separate files
+into the output file, with comments that give an unbundling
+.IR sed (1)
+script.
+.TP
+.B -ext
+Complain about
+.IR f\^77 (1)
+extensions.
+.TP
+.B -g
+Include original Fortran line numbers as comments.
+.TP
+.B -h
+Try to align character strings on word (or, if the option is
+.LR -hd ,
+on double-word) boundaries.
+.TP
+.B -i2
+Similar to
+.BR -I2 ,
+but assume a modified
+.I libF77
+and
+.I libI77
+(compiled with
+.BR -Df\^2c_i2 ),
+so
+.SM INTEGER
+and
+.SM LOGICAL
+variables may be assigned by
+.SM INQUIRE
+and array lengths are stored in short ints.
+.TP
+.B -kr
+Use temporary values to enforce Fortran expression evaluation
+where K&R (first edition) parenthesization rules allow rearrangement.
+If the option is
+.LR -krd ,
+use double precision temporaries even for single-precision operands.
+.TP
+.B -P
+Write a
+.IB file .P
+of ANSI (or C++) prototypes
+for procedures defined in each input
+.IB file .f
+or
+.IB file .F .
+When reading Fortran from standard input, write prototypes
+at the beginning of standard output.
+Implies
+.B -A
+unless option
+.L -C++
+is present.  Option
+.B -Ps
+implies
+.B -P ,
+and gives exit status 4 if rerunning
+.I f\^2c
+may change prototypes or declarations.
+.TP
+.B -p
+Supply preprocessor definitions to make common-block members
+look like local variables.
+.TP
+.B -R
+Do not promote
+.SM REAL
+functions and operations to
+.SM DOUBLE PRECISION.
+Option
+.L -!R
+confirms the default, which imitates
+.IR f\^77 .
+.TP
+.B -r
+Cast values of REAL functions (including intrinsics) to REAL.
+.TP
+.B -r8
+Promote
+.SM REAL
+to
+.SM DOUBLE PRECISION, COMPLEX
+to
+.SM DOUBLE COMPLEX.
+.TP
+.BI -T dir
+Put temporary files in directory
+.I dir.
+.TP
+.B -w8
+Suppress warnings when
+.SM COMMON
+or
+.SM EQUIVALENCE
+forces odd-word alignment of doubles.
+.TP
+.BI -W n
+Assume
+.I n
+characters/word (default 4)
+when initializing numeric variables with character data.
+.TP
+.B -z
+Do not implicitly recognize
+.SM DOUBLE COMPLEX.
+.TP
+.B -!bs
+Do not recognize \fIb\fRack\fIs\fRlash escapes
+(\e", \e', \e0, \e\e, \eb, \ef, \en, \er, \et, \ev) in character strings.
+.TP
+.B -!c
+Inhibit C output, but produce
+.B -P
+output.
+.TP
+.B -!I
+Reject
+.B include
+statements.
+.TP
+.B -!it
+Don't infer types of untyped
+.SM EXTERNAL
+procedures from use as parameters to previously defined or prototyped
+procedures.
+.TP
+.B -!P
+Do not attempt to infer
+.SM ANSI
+or C++
+prototypes from usage.
+.PP
+The resulting C invokes the support routines of
+.IR f\^77 ;
+object code should be loaded by
+.I f\^77
+or with
+.IR ld (1)
+or
+.IR cc (1)
+options
+.BR "-lF77 -lI77 -lm" .
+Calling conventions
+are those of
+.IR f\&77 :
+see the reference below.
+.br
+.SH FILES
+.TP
+.IB file .[fF]
+input file
+.TP
+.B *.c
+output file
+.TP
+.F ~em/include/fortran/f2c.h
+header file
+.SH "SEE ALSO"
+S. I. Feldman and
+P. J. Weinberger,
+`A Portable Fortran 77 Compiler',
+\fIUNIX Time Sharing System Programmer's Manual\fR,
+Tenth Edition, Volume 2, AT&T Bell Laboratories, 1990.
+.SH DIAGNOSTICS
+The diagnostics produced by
+.I f\^2c
+are intended to be
+self-explanatory.
+.SH BUGS
+Floating-point constant expressions are simplified in
+the floating-point arithmetic of the machine running
+.IR f\^2c ,
+so they are typically accurate to at most 16 or 17 decimal places.
+.br
+Untypable
+.SM EXTERNAL
+functions are declared
+.BR int .

+ 209 - 0
lang/fortran/comp/f2c.h

@@ -0,0 +1,209 @@
+/* f2c.h  --  Standard Fortran to C header file */
+
+/**  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
+
+	- From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */
+
+#ifndef F2C_INCLUDE
+#define F2C_INCLUDE
+
+typedef long int integer;
+typedef char *address;
+typedef short int shortint;
+typedef float real;
+typedef double doublereal;
+typedef struct { real r, i; } complex;
+typedef struct { doublereal r, i; } doublecomplex;
+typedef long int logical;
+typedef short int shortlogical;
+
+#define TRUE_ (1)
+#define FALSE_ (0)
+
+/* Extern is for use with -E */
+#ifndef Extern
+#define Extern extern
+#endif
+
+/* I/O stuff */
+
+#ifdef f2c_i2
+/* for -i2 */
+typedef short flag;
+typedef short ftnlen;
+typedef short ftnint;
+#else
+typedef long flag;
+typedef long ftnlen;
+typedef long ftnint;
+#endif
+
+/*external read, write*/
+typedef struct
+{	flag cierr;
+	ftnint ciunit;
+	flag ciend;
+	char *cifmt;
+	ftnint cirec;
+} cilist;
+
+/*internal read, write*/
+typedef struct
+{	flag icierr;
+	char *iciunit;
+	flag iciend;
+	char *icifmt;
+	ftnint icirlen;
+	ftnint icirnum;
+} icilist;
+
+/*open*/
+typedef struct
+{	flag oerr;
+	ftnint ounit;
+	char *ofnm;
+	ftnlen ofnmlen;
+	char *osta;
+	char *oacc;
+	char *ofm;
+	ftnint orl;
+	char *oblnk;
+} olist;
+
+/*close*/
+typedef struct
+{	flag cerr;
+	ftnint cunit;
+	char *csta;
+} cllist;
+
+/*rewind, backspace, endfile*/
+typedef struct
+{	flag aerr;
+	ftnint aunit;
+} alist;
+
+/* inquire */
+typedef struct
+{	flag inerr;
+	ftnint inunit;
+	char *infile;
+	ftnlen infilen;
+	ftnint	*inex;	/*parameters in standard's order*/
+	ftnint	*inopen;
+	ftnint	*innum;
+	ftnint	*innamed;
+	char	*inname;
+	ftnlen	innamlen;
+	char	*inacc;
+	ftnlen	inacclen;
+	char	*inseq;
+	ftnlen	inseqlen;
+	char 	*indir;
+	ftnlen	indirlen;
+	char	*infmt;
+	ftnlen	infmtlen;
+	char	*inform;
+	ftnint	informlen;
+	char	*inunf;
+	ftnlen	inunflen;
+	ftnint	*inrecl;
+	ftnint	*innrec;
+	char	*inblank;
+	ftnlen	inblanklen;
+} inlist;
+
+#define VOID void
+
+union Multitype {	/* for multiple entry points */
+	shortint h;
+	integer i;
+	real r;
+	doublereal d;
+	complex c;
+	doublecomplex z;
+	};
+
+typedef union Multitype Multitype;
+
+typedef long Long;	/* No longer used; formerly in Namelist */
+
+struct Vardesc {	/* for Namelist */
+	char *name;
+	char *addr;
+	ftnlen *dims;
+	int  type;
+	};
+typedef struct Vardesc Vardesc;
+
+struct Namelist {
+	char *name;
+	Vardesc **vars;
+	int nvars;
+	};
+typedef struct Namelist Namelist;
+
+#define abs(x) ((x) >= 0 ? (x) : -(x))
+#define dabs(x) (doublereal)abs(x)
+#define min(a,b) ((a) <= (b) ? (a) : (b))
+#define max(a,b) ((a) >= (b) ? (a) : (b))
+#define dmin(a,b) (doublereal)min(a,b)
+#define dmax(a,b) (doublereal)max(a,b)
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef int /* Unknown procedure type */ (*U_fp)(...);
+typedef shortint (*J_fp)(...);
+typedef integer (*I_fp)(...);
+typedef real (*R_fp)(...);
+typedef doublereal (*D_fp)(...), (*E_fp)(...);
+typedef /* Complex */ VOID (*C_fp)(...);
+typedef /* Double Complex */ VOID (*Z_fp)(...);
+typedef logical (*L_fp)(...);
+typedef shortlogical (*K_fp)(...);
+typedef /* Character */ VOID (*H_fp)(...);
+typedef /* Subroutine */ int (*S_fp)(...);
+#else
+typedef int /* Unknown procedure type */ (*U_fp)();
+typedef shortint (*J_fp)();
+typedef integer (*I_fp)();
+typedef real (*R_fp)();
+typedef doublereal (*D_fp)(), (*E_fp)();
+typedef /* Complex */ VOID (*C_fp)();
+typedef /* Double Complex */ VOID (*Z_fp)();
+typedef logical (*L_fp)();
+typedef shortlogical (*K_fp)();
+typedef /* Character */ VOID (*H_fp)();
+typedef /* Subroutine */ int (*S_fp)();
+#endif
+/* E_fp is for real functions when -R is not specified */
+typedef VOID C_f;	/* complex function */
+typedef VOID H_f;	/* character function */
+typedef VOID Z_f;	/* double complex function */
+typedef doublereal E_f;	/* real function with -R not specified */
+
+/* undef any lower-case symbols that your C compiler predefines, e.g.: */
+
+#ifndef Skip_f2c_Undefs
+#undef cray
+#undef gcos
+#undef mc68010
+#undef mc68020
+#undef mips
+#undef pdp11
+#undef sgi
+#undef sparc
+#undef sun
+#undef sun2
+#undef sun3
+#undef sun4
+#undef u370
+#undef u3b
+#undef u3b2
+#undef u3b5
+#undef unix
+#undef vax
+#endif
+#endif

+ 2108 - 0
lang/fortran/comp/format.c

@@ -0,0 +1,2108 @@
+/****************************************************************
+Copyright 1990, 1991 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+/* Format.c -- this file takes an intermediate file (generated by pass 1
+   of the translator) and some state information about the contents of that
+   file, and generates C program text. */
+
+#include "defs.h"
+#include "p1defs.h"
+#include "format.h"
+#include "output.h"
+#include "names.h"
+#include "iob.h"
+
+int c_output_line_length = DEF_C_LINE_LENGTH;
+
+int last_was_label;	/* Boolean used to generate semicolons
+				   when a label terminates a block */
+static char this_proc_name[52];	/* Name of the current procedure.  This is
+				   probably too simplistic to handle
+				   multiple entry points */
+
+static int p1getd(), p1gets(), p1getf(), get_p1_token();
+static int p1get_const(), p1getn();
+static expptr do_format(), do_p1_name_pointer(), do_p1_const();
+static expptr do_p1_expr(), do_p1_ident(), do_p1_charp(), do_p1_extern();
+static expptr do_p1_head(), do_p1_list(), do_p1_literal();
+static void do_p1_label(), do_p1_asgoto(), do_p1_goto();
+static void do_p1_if(), do_p1_else(), do_p1_elif(), do_p1_endif();
+static void do_p1_endelse(), do_p1_subr_ret(), do_p1_comp_goto();
+static void do_p1_for(), do_p1_end_for(), do_p1_fortran();
+static void do_p1_1while(), do_p1_2while(), do_p1_elseifstart();
+static void do_p1_comment(), do_p1_set_line();
+static expptr do_p1_addr();
+static void proto();
+void list_arg_types();
+chainp length_comp();
+void listargs();
+extern chainp assigned_fmts;
+static long old_lineno;
+static char filename[P1_FILENAME_MAX];
+extern int gflag;
+extern char *parens;
+
+start_formatting ()
+{
+    FILE *infile;
+    static int wrote_one = 0;
+    extern int usedefsforcommon;
+    extern char *p1_file, *p1_bakfile;
+
+    this_proc_name[0] = '\0';
+    last_was_label = 0;
+    old_lineno = lineno;
+    ei_next = ei_first;
+    wh_next = wh_first;
+
+    (void) fclose (pass1_file);
+    if ((infile = fopen (p1_file, binread)) == NULL)
+	Fatal("start_formatting:  couldn't open the intermediate file\n");
+
+    if (wrote_one)
+	nice_printf (c_file, "\n");
+
+    while (!feof (infile)) {
+	expptr this_expr;
+
+	this_expr = do_format (infile, c_file);
+	if (this_expr) {
+	    out_and_free_statement (c_file, this_expr);
+	} /* if this_expr */
+    } /* while !feof infile */
+
+    (void) fclose (infile);
+
+    if (last_was_label)
+	nice_printf (c_file, ";\n");
+
+    prev_tab (c_file);
+    if (this_proc_name[0])
+	nice_printf (c_file, "} /* %s */\n", this_proc_name);
+
+
+/* Write the #undefs for common variable reference */
+
+    if (usedefsforcommon) {
+	Extsym *ext;
+	int did_one = 0;
+
+	for (ext = extsymtab; ext < nextext; ext++)
+	    if (ext -> extstg == STGCOMMON && ext -> used_here) {
+		ext -> used_here = 0;
+		if (!did_one)
+		    nice_printf (c_file, "\n");
+		wr_abbrevs(c_file, 0, ext->extp);
+		did_one = 1;
+		ext -> extp = CHNULL;
+	    } /* if */
+
+	if (did_one)
+	    nice_printf (c_file, "\n");
+    } /* if usedefsforcommon */
+
+    other_undefs(c_file);
+
+    wrote_one = 1;
+
+/* For debugging only */
+
+    if (debugflag && (pass1_file = fopen (p1_bakfile, binwrite)))
+	if (infile = fopen (p1_file, binread)) {
+	    ffilecopy (infile, pass1_file);
+	    fclose (infile);
+	    fclose (pass1_file);
+	} /* if infile */
+
+/* End of "debugging only" */
+
+    scrub(p1_file);	/* optionally unlink */
+
+    if ((pass1_file = fopen (p1_file, binwrite)) == NULL)
+	err ("start_formatting:  couldn't reopen the pass1 file");
+
+} /* start_formatting */
+
+
+ static void
+put_semi(outfile)
+ FILE *outfile;
+{
+	nice_printf (outfile, ";\n");
+	last_was_label = 0;
+	}
+
+#define SEM_CHECK(x) if (last_was_label) put_semi(x)
+
+/* do_format -- takes an input stream (a file in pass1 format) and writes
+   the appropriate C code to   outfile   when possible.  When reading an
+   expression, the expression tree is returned instead. */
+
+static expptr do_format (infile, outfile)
+FILE *infile, *outfile;
+{
+    int gsave, token_type, was_c_token;
+    expptr retval = ENULL;
+
+    token_type = get_p1_token (infile);
+    was_c_token = 1;
+    switch (token_type) {
+	case P1_COMMENT:
+	    do_p1_comment (infile, outfile);
+	    was_c_token = 0;
+	    break;
+	case P1_SET_LINE:
+	    do_p1_set_line (infile);
+	    was_c_token = 0;
+	    break;
+	case P1_FILENAME:
+	    p1gets(infile, filename, P1_FILENAME_MAX);
+	    was_c_token = 0;
+	    break;
+	case P1_NAME_POINTER:
+	    retval = do_p1_name_pointer (infile);
+	    break;
+	case P1_CONST:
+	    retval = do_p1_const (infile);
+	    break;
+	case P1_EXPR:
+	    retval = do_p1_expr (infile, outfile);
+	    break;
+	case P1_IDENT:
+	    retval = do_p1_ident(infile);
+	    break;
+	case P1_CHARP:
+		retval = do_p1_charp(infile);
+		break;
+	case P1_EXTERN:
+	    retval = do_p1_extern (infile);
+	    break;
+	case P1_HEAD:
+	    gsave = gflag;
+	    gflag = 0;
+	    retval = do_p1_head (infile, outfile);
+	    gflag = gsave;
+	    break;
+	case P1_LIST:
+	    retval = do_p1_list (infile, outfile);
+	    break;
+	case P1_LITERAL:
+	    retval = do_p1_literal (infile);
+	    break;
+	case P1_LABEL:
+	    do_p1_label (infile, outfile);
+	    /* last_was_label = 1; -- now set in do_p1_label */
+	    was_c_token = 0;
+	    break;
+	case P1_ASGOTO:
+	    do_p1_asgoto (infile, outfile);
+	    break;
+	case P1_GOTO:
+	    do_p1_goto (infile, outfile);
+	    break;
+	case P1_IF:
+	    do_p1_if (infile, outfile);
+	    break;
+	case P1_ELSE:
+	    SEM_CHECK(outfile);
+	    do_p1_else (outfile);
+	    break;
+	case P1_ELIF:
+	    SEM_CHECK(outfile);
+	    do_p1_elif (infile, outfile);
+	    break;
+	case P1_ENDIF:
+	    SEM_CHECK(outfile);
+	    do_p1_endif (outfile);
+	    break;
+	case P1_ENDELSE:
+	    SEM_CHECK(outfile);
+	    do_p1_endelse (outfile);
+	    break;
+	case P1_ADDR:
+	    retval = do_p1_addr (infile, outfile);
+	    break;
+	case P1_SUBR_RET:
+	    do_p1_subr_ret (infile, outfile);
+	    break;
+	case P1_COMP_GOTO:
+	    do_p1_comp_goto (infile, outfile);
+	    break;
+	case P1_FOR:
+	    do_p1_for (infile, outfile);
+	    break;
+	case P1_ENDFOR:
+	    SEM_CHECK(outfile);
+	    do_p1_end_for (outfile);
+	    break;
+	case P1_WHILE1START:
+		do_p1_1while(outfile);
+		break;
+	case P1_WHILE2START:
+		do_p1_2while(infile, outfile);
+		break;
+	case P1_PROCODE:
+		procode(outfile);
+		break;
+	case P1_ELSEIFSTART:
+		SEM_CHECK(outfile);
+		do_p1_elseifstart(outfile);
+		break;
+	case P1_FORTRAN:
+		do_p1_fortran(infile, outfile);
+		/* no break; */
+	case P1_EOF:
+	    was_c_token = 0;
+	    break;
+	case P1_UNKNOWN:
+	    Fatal("do_format:  Unknown token type in intermediate file");
+	    break;
+	default:
+	    Fatal("do_format:  Bad token type in intermediate file");
+	    break;
+   } /* switch */
+
+    if (was_c_token)
+	last_was_label = 0;
+    return retval;
+} /* do_format */
+
+
+ static void
+do_p1_comment (infile, outfile)
+FILE *infile, *outfile;
+{
+    extern int c_output_line_length, in_comment;
+
+    char storage[COMMENT_BUFFER_SIZE + 1];
+    int length;
+
+    if (!p1gets(infile, storage, COMMENT_BUFFER_SIZE + 1))
+	return;
+
+    length = strlen (storage);
+
+    in_comment = 1;
+    if (length > c_output_line_length - 6)
+	margin_printf (outfile, "/*%s*/\n", storage);
+    else
+	margin_printf (outfile, length ? "/* %s */\n" : "\n", storage);
+    in_comment = 0;
+} /* do_p1_comment */
+
+ static void
+do_p1_set_line (infile)
+FILE *infile;
+{
+    int status;
+    long new_line_number = -1;
+
+    status = p1getd (infile, &new_line_number);
+
+    if (status == EOF)
+	err ("do_p1_set_line:  Missing line number at end of file\n");
+    else if (status == 0 || new_line_number == -1)
+	errl("do_p1_set_line:  Illegal line number in intermediate file: %ld\n",
+		new_line_number);
+    else {
+	lineno = new_line_number;
+	if (gflag)
+		fprintf(c_file, "/*# %ld \"%s\"*/\n", lineno, filename);
+	}
+} /* do_p1_set_line */
+
+
+static expptr do_p1_name_pointer (infile)
+FILE *infile;
+{
+    Namep namep = (Namep) NULL;
+    int status;
+
+    status = p1getd (infile, (long *) &namep);
+
+    if (status == EOF)
+	err ("do_p1_name_pointer:  Missing pointer at end of file\n");
+    else if (status == 0 || namep == (Namep) NULL)
+	erri ("do_p1_name_pointer:  Illegal name pointer in p1 file: '%x'\n",
+		(int) namep);
+
+    return (expptr) namep;
+} /* do_p1_name_pointer */
+
+
+
+static expptr do_p1_const (infile)
+FILE *infile;
+{
+    struct Constblock *c = (struct Constblock *) NULL;
+    long type = -1;
+    int status;
+
+    status = p1getd (infile, &type);
+
+    if (status == EOF)
+	err ("do_p1_const:  Missing constant type at end of file\n");
+    else if (status == 0)
+	errl("do_p1_const:  Illegal constant type in p1 file: %ld\n", type);
+    else {
+	status = p1get_const (infile, (int)type, &c);
+
+	if (status == EOF) {
+	    err ("do_p1_const:  Missing constant value at end of file\n");
+	    c = (struct Constblock *) NULL;
+	} else if (status == 0) {
+	    err ("do_p1_const:  Illegal constant value in p1 file\n");
+	    c = (struct Constblock *) NULL;
+	} /* else */
+    } /* else */
+    return (expptr) c;
+} /* do_p1_const */
+
+
+static expptr do_p1_literal (infile)
+FILE *infile;
+{
+    int status;
+    long memno;
+    Addrp addrp;
+
+    status = p1getd (infile, &memno);
+
+    if (status == EOF)
+	err ("do_p1_literal:  Missing memno at end of file");
+    else if (status == 0)
+	err ("do_p1_literal:  Missing memno in p1 file");
+    else {
+	struct Literal *litp, *lastlit;
+
+	addrp = ALLOC (Addrblock);
+	addrp -> tag = TADDR;
+	addrp -> vtype = TYUNKNOWN;
+	addrp -> Field = NULL;
+
+	lastlit = litpool + nliterals;
+	for (litp = litpool; litp < lastlit; litp++)
+	    if (litp -> litnum == memno) {
+		addrp -> vtype = litp -> littype;
+		*((union Constant *) &(addrp -> user)) =
+			*((union Constant *) &(litp -> litval));
+		break;
+	    } /* if litp -> litnum == memno */
+
+	addrp -> memno = memno;
+	addrp -> vstg = STGMEMNO;
+	addrp -> uname_tag = UNAM_CONST;
+    } /* else */
+
+    return (expptr) addrp;
+} /* do_p1_literal */
+
+
+static void do_p1_label (infile, outfile)
+FILE *infile, *outfile;
+{
+    int status;
+    ftnint stateno;
+    char *user_label ();
+    struct Labelblock *L;
+    char *fmt;
+
+    status = p1getd (infile, &stateno);
+
+    if (status == EOF)
+	err ("do_p1_label:  Missing label at end of file");
+    else if (status == 0)
+	err ("do_p1_label:  Missing label in p1 file ");
+    else if (stateno < 0) {	/* entry */
+	margin_printf(outfile, "\n%s:\n", user_label(stateno));
+	last_was_label = 1;
+	}
+    else {
+	L = labeltab + stateno;
+	if (L->labused) {
+		fmt = "%s:\n";
+		last_was_label = 1;
+		}
+	else
+		fmt = "/* %s: */\n";
+	margin_printf(outfile, fmt, user_label(L->stateno));
+    } /* else */
+} /* do_p1_label */
+
+
+
+static void do_p1_asgoto (infile, outfile)
+FILE *infile, *outfile;
+{
+    expptr expr;
+
+    expr = do_format (infile, outfile);
+    out_asgoto (outfile, expr);
+
+} /* do_p1_asgoto */
+
+
+static void do_p1_goto (infile, outfile)
+FILE *infile, *outfile;
+{
+    int status;
+    long stateno;
+    char *user_label ();
+
+    status = p1getd (infile, &stateno);
+
+    if (status == EOF)
+	err ("do_p1_goto:  Missing goto label at end of file");
+    else if (status == 0)
+	err ("do_p1_goto:  Missing goto label in p1 file");
+    else {
+	nice_printf (outfile, "goto %s;\n", user_label (stateno));
+    } /* else */
+} /* do_p1_goto */
+
+
+static void do_p1_if (infile, outfile)
+FILE *infile, *outfile;
+{
+    expptr cond;
+
+    do {
+        cond = do_format (infile, outfile);
+    } while (cond == ENULL);
+
+    out_if (outfile, cond);
+} /* do_p1_if */
+
+
+static void do_p1_else (outfile)
+FILE *outfile;
+{
+    out_else (outfile);
+} /* do_p1_else */
+
+
+static void do_p1_elif (infile, outfile)
+FILE *infile, *outfile;
+{
+    expptr cond;
+
+    do {
+        cond = do_format (infile, outfile);
+    } while (cond == ENULL);
+
+    elif_out (outfile, cond);
+} /* do_p1_elif */
+
+static void do_p1_endif (outfile)
+FILE *outfile;
+{
+    endif_out (outfile);
+} /* do_p1_endif */
+
+
+static void do_p1_endelse (outfile)
+FILE *outfile;
+{
+    end_else_out (outfile);
+} /* do_p1_endelse */
+
+
+static expptr do_p1_addr (infile, outfile)
+FILE *infile, *outfile;
+{
+    Addrp addrp = (Addrp) NULL;
+    int status;
+
+    status = p1getn (infile, sizeof (struct Addrblock), (char **) &addrp);
+
+    if (status == EOF)
+	err ("do_p1_addr:  Missing Addrp at end of file");
+    else if (status == 0)
+	err ("do_p1_addr:  Missing Addrp in p1 file");
+    else if (addrp == (Addrp) NULL)
+	err ("do_p1_addr:  Null addrp in p1 file");
+    else if (addrp -> tag != TADDR)
+	erri ("do_p1_addr: bad tag in p1 file '%d'", addrp -> tag);
+    else {
+	addrp -> vleng = do_format (infile, outfile);
+	addrp -> memoffset = do_format (infile, outfile);
+    }
+
+    return (expptr) addrp;
+} /* do_p1_addr */
+
+
+
+static void do_p1_subr_ret (infile, outfile)
+FILE *infile, *outfile;
+{
+    expptr retval;
+
+    nice_printf (outfile, "return ");
+    retval = do_format (infile, outfile);
+    if (!multitype)
+	if (retval)
+		expr_out (outfile, retval);
+
+    nice_printf (outfile, ";\n");
+} /* do_p1_subr_ret */
+
+
+
+static void do_p1_comp_goto (infile, outfile)
+FILE *infile, *outfile;
+{
+    expptr index;
+    expptr labels;
+
+    index = do_format (infile, outfile);
+
+    if (index == ENULL) {
+	err ("do_p1_comp_goto:  no expression for computed goto");
+	return;
+    } /* if index == ENULL */
+
+    labels = do_format (infile, outfile);
+
+    if (labels && labels -> tag != TLIST)
+	erri ("do_p1_comp_goto:  expected list, got tag '%d'", labels -> tag);
+    else
+	compgoto_out (outfile, index, labels);
+} /* do_p1_comp_goto */
+
+
+static void do_p1_for (infile, outfile)
+FILE *infile, *outfile;
+{
+    expptr init, test, inc;
+
+    init = do_format (infile, outfile);
+    test = do_format (infile, outfile);
+    inc = do_format (infile, outfile);
+
+    out_for (outfile, init, test, inc);
+} /* do_p1_for */
+
+static void do_p1_end_for (outfile)
+FILE *outfile;
+{
+    out_end_for (outfile);
+} /* do_p1_end_for */
+
+
+ static void
+do_p1_fortran(infile, outfile)
+ FILE *infile, *outfile;
+{
+	char buf[P1_STMTBUFSIZE];
+	if (!p1gets(infile, buf, P1_STMTBUFSIZE))
+		return;
+	/* bypass nice_printf nonsense */
+	fprintf(outfile, "/*< %s >*/\n", buf+1);	/* + 1 to skip by '$' */
+	}
+
+
+static expptr do_p1_expr (infile, outfile)
+FILE *infile, *outfile;
+{
+    int status;
+    long opcode, type;
+    struct Exprblock *result = (struct Exprblock *) NULL;
+
+    status = p1getd (infile, &opcode);
+
+    if (status == EOF)
+	err ("do_p1_expr:  Missing expr opcode at end of file");
+    else if (status == 0)
+	err ("do_p1_expr:  Missing expr opcode in p1 file");
+    else {
+
+	status = p1getd (infile, &type);
+
+	if (status == EOF)
+	    err ("do_p1_expr:  Missing expr type at end of file");
+	else if (status == 0)
+	    err ("do_p1_expr:  Missing expr type in p1 file");
+	else if (opcode == 0)
+	    return ENULL;
+	else {
+	    result = ALLOC (Exprblock);
+
+	    result -> tag = TEXPR;
+	    result -> vtype = type;
+	    result -> opcode = opcode;
+	    result -> vleng = do_format (infile, outfile);
+
+	    if (is_unary_op (opcode))
+		result -> leftp = do_format (infile, outfile);
+	    else if (is_binary_op (opcode)) {
+		result -> leftp = do_format (infile, outfile);
+		result -> rightp = do_format (infile, outfile);
+	    } else
+		errl("do_p1_expr:  Illegal opcode %ld", opcode);
+	} /* else */
+    } /* else */
+
+    return (expptr) result;
+} /* do_p1_expr */
+
+
+static expptr do_p1_ident(infile)
+FILE *infile;
+{
+	Addrp addrp;
+	int status;
+	long vtype, vstg;
+
+	addrp = ALLOC (Addrblock);
+	addrp -> tag = TADDR;
+
+	status = p1getd (infile, &vtype);
+	if (status == EOF)
+	    err ("do_p1_ident:  Missing identifier type at end of file\n");
+	else if (status == 0 || vtype < 0 || vtype >= NTYPES)
+	    errl("do_p1_ident:  Bad type in intermediate file: %ld\n", vtype);
+	else
+	    addrp -> vtype = vtype;
+
+	status = p1getd (infile, &vstg);
+	if (status == EOF)
+	    err ("do_p1_ident:  Missing identifier storage at end of file\n");
+	else if (status == 0 || vstg < 0 || vstg > STGNULL)
+	    errl("do_p1_ident:  Bad storage in intermediate file: %ld\n", vtype);
+	else
+	    addrp -> vstg = vstg;
+
+	status = p1gets(infile, addrp->user.ident, IDENT_LEN);
+
+	if (status == EOF)
+	    err ("do_p1_ident:  Missing ident string at end of file");
+	else if (status == 0)
+	    err ("do_p1_ident:  Missing ident string in intermediate file");
+	addrp->uname_tag = UNAM_IDENT;
+	return (expptr) addrp;
+} /* do_p1_ident */
+
+static expptr do_p1_charp(infile)
+FILE *infile;
+{
+	Addrp addrp;
+	int status;
+	long vtype, vstg;
+	char buf[64];
+
+	addrp = ALLOC (Addrblock);
+	addrp -> tag = TADDR;
+
+	status = p1getd (infile, &vtype);
+	if (status == EOF)
+	    err ("do_p1_ident:  Missing identifier type at end of file\n");
+	else if (status == 0 || vtype < 0 || vtype >= NTYPES)
+	    errl("do_p1_ident:  Bad type in intermediate file: %ld\n", vtype);
+	else
+	    addrp -> vtype = vtype;
+
+	status = p1getd (infile, &vstg);
+	if (status == EOF)
+	    err ("do_p1_ident:  Missing identifier storage at end of file\n");
+	else if (status == 0 || vstg < 0 || vstg > STGNULL)
+	    errl("do_p1_ident:  Bad storage in intermediate file: %ld\n", vtype);
+	else
+	    addrp -> vstg = vstg;
+
+	status = p1gets(infile, buf, (int)sizeof(buf));
+
+	if (status == EOF)
+	    err ("do_p1_ident:  Missing charp ident string at end of file");
+	else if (status == 0)
+	    err ("do_p1_ident:  Missing charp ident string in intermediate file");
+	addrp->uname_tag = UNAM_CHARP;
+	addrp->user.Charp = strcpy(mem(strlen(buf)+1,0), buf);
+	return (expptr) addrp;
+}
+
+
+static expptr do_p1_extern (infile)
+FILE *infile;
+{
+    Addrp addrp;
+
+    addrp = ALLOC (Addrblock);
+    if (addrp) {
+	int status;
+
+	addrp->tag = TADDR;
+	addrp->vstg = STGEXT;
+	addrp->uname_tag = UNAM_EXTERN;
+	status = p1getd (infile, &(addrp -> memno));
+	if (status == EOF)
+	    err ("do_p1_extern:  Missing memno at end of file");
+	else if (status == 0)
+	    err ("do_p1_extern:  Missing memno in intermediate file");
+	if (addrp->vtype = extsymtab[addrp->memno].extype)
+		addrp->vclass = CLPROC;
+    } /* if addrp */
+
+    return (expptr) addrp;
+} /* do_p1_extern */
+
+
+
+static expptr do_p1_head (infile, outfile)
+FILE *infile, *outfile;
+{
+    int status;
+    int add_n_;
+    long class;
+    char storage[256];
+
+    status = p1getd (infile, &class);
+    if (status == EOF)
+	err ("do_p1_head:  missing header class at end of file");
+    else if (status == 0)
+	err ("do_p1_head:  missing header class in p1 file");
+    else {
+	status = p1gets (infile, storage, (int)sizeof(storage));
+	if (status == EOF || status == 0)
+	    storage[0] = '\0';
+    } /* else */
+
+    if (class == CLPROC || class == CLMAIN) {
+	chainp lengths;
+
+	add_n_ = nentry > 1;
+	lengths = length_comp(entries, add_n_);
+
+	if (!add_n_ && protofile && class != CLMAIN)
+		protowrite(protofile, proctype, storage, entries, lengths);
+
+	if (class == CLMAIN)
+	    nice_printf (outfile, "/* Main program */ ");
+	else
+	    nice_printf(outfile, "%s ", multitype ? "VOID"
+			: c_type_decl(proctype, 1));
+
+	nice_printf(outfile, add_n_ ? "%s0_" : "%s", storage);
+	if (!Ansi) {
+		listargs(outfile, entries, add_n_, lengths);
+		nice_printf (outfile, "\n");
+		}
+	list_arg_types (outfile, entries, lengths, add_n_, "\n");
+	nice_printf (outfile, "{\n");
+	frchain(&lengths);
+	next_tab (outfile);
+	strcpy(this_proc_name, storage);
+	list_decls (outfile);
+
+    } else if (class == CLBLOCK)
+        next_tab (outfile);
+    else
+	errl("do_p1_head: got class %ld", class);
+
+    return NULL;
+} /* do_p1_head */
+
+
+static expptr do_p1_list (infile, outfile)
+FILE *infile, *outfile;
+{
+    long tag, type, count;
+    int status;
+    expptr result;
+
+    status = p1getd (infile, &tag);
+    if (status == EOF)
+	err ("do_p1_list:  missing list tag at end of file");
+    else if (status == 0)
+	err ("do_p1_list:  missing list tag in p1 file");
+    else {
+	status = p1getd (infile, &type);
+	if (status == EOF)
+	    err ("do_p1_list:  missing list type at end of file");
+	else if (status == 0)
+	    err ("do_p1_list:  missing list type in p1 file");
+	else {
+	    status = p1getd (infile, &count);
+	    if (status == EOF)
+		err ("do_p1_list:  missing count at end of file");
+	    else if (status == 0)
+		err ("do_p1_list:  missing count in p1 file");
+	} /* else */
+    } /* else */
+
+    result = (expptr) ALLOC (Listblock);
+    if (result) {
+	chainp pointer;
+
+	result -> tag = tag;
+	result -> listblock.vtype = type;
+
+/* Assume there will be enough data */
+
+	if (count--) {
+	    pointer = result->listblock.listp =
+		mkchain((char *)do_format(infile, outfile), CHNULL);
+	    while (count--) {
+		pointer -> nextp =
+			mkchain((char *)do_format(infile, outfile), CHNULL);
+		pointer = pointer -> nextp;
+	    } /* while (count--) */
+	} /* if (count) */
+    } /* if (result) */
+
+    return result;
+} /* do_p1_list */
+
+
+chainp length_comp(e, add_n)	/* get lengths of characters args */
+ struct Entrypoint *e;
+ int add_n;
+{
+	chainp lengths;
+	chainp args, args1;
+	Namep arg, np;
+	int nchargs;
+	Argtypes *at;
+	Atype *a;
+	extern int init_ac[TYSUBR+1];
+
+	args = args1 = add_n ? allargs : e->arglist;
+	nchargs = 0;
+	for (lengths = NULL; args; args = args -> nextp)
+		if (arg = (Namep)args->datap) {
+			if (arg->vclass == CLUNKNOWN)
+				arg->vclass = CLVAR;
+			if (arg->vtype == TYCHAR && arg->vclass != CLPROC) {
+				lengths = mkchain((char *)arg, lengths);
+				nchargs++;
+				}
+			}
+	if (!add_n && (np = e->enamep)) {
+		/* one last check -- by now we know all we ever will
+		 * about external args...
+		 */
+		save_argtypes(e->arglist, &e->entryname->arginfo,
+			&np->arginfo, 0, np->fvarname, STGEXT, nchargs,
+			np->vtype, 1);
+		at = e->entryname->arginfo;
+		a = at->atypes + init_ac[np->vtype];
+		for(; args1; a++, args1 = args1->nextp) {
+			frchain(&a->cp);
+			if (arg = (Namep)args1->datap)
+			    switch(arg->vclass) {
+				case CLPROC:
+					if (arg->vimpltype
+					&& a->type >= 300)
+						a->type = TYUNKNOWN + 200;
+					break;
+				case CLUNKNOWN:
+					a->type %= 100;
+				}
+			}
+		}
+	return revchain(lengths);
+	}
+
+void listargs(outfile, entryp, add_n_, lengths)
+ FILE *outfile;
+ struct Entrypoint *entryp;
+ int add_n_;
+ chainp lengths;
+{
+	chainp args;
+	char *s;
+	Namep arg;
+	int did_one = 0;
+
+	nice_printf (outfile, "(");
+
+	if (add_n_) {
+		nice_printf(outfile, "n__");
+		did_one = 1;
+		args = allargs;
+		}
+	else
+		args = entryp->arglist;
+
+	if (multitype)
+		{
+		nice_printf(outfile, ", ret_val");
+		did_one = 1;
+		args = allargs;
+		}
+	else if (ONEOF(proctype, MSKCOMPLEX|MSKCHAR))
+		{
+		s = xretslot[proctype]->user.ident;
+		nice_printf(outfile, did_one ? ", %s" : "%s",
+			*s == '(' /*)*/ ? "r_v" : s);
+		did_one = 1;
+		if (proctype == TYCHAR)
+			nice_printf (outfile, ", ret_val_len");
+		}
+	for (; args; args = args -> nextp)
+		if (arg = (Namep)args->datap) {
+			nice_printf (outfile, "%s", did_one ? ", " : "");
+			out_name (outfile, arg);
+			did_one = 1;
+			}
+
+	for (args = lengths; args; args = args -> nextp)
+		nice_printf(outfile, ", %s",
+			new_arg_length((Namep)args->datap));
+	nice_printf (outfile, ")");
+} /* listargs */
+
+
+void list_arg_types(outfile, entryp, lengths, add_n_, finalnl)
+FILE *outfile;
+struct Entrypoint *entryp;
+chainp lengths;
+int add_n_;
+char *finalnl;
+{
+    chainp args;
+    int last_type = -1, last_class = -1;
+    int did_one = 0, done_one, is_ext;
+    char *s, *sep = "", *sep1;
+
+    if (outfile == (FILE *) NULL) {
+	err ("list_arg_types:  null output file");
+	return;
+    } else if (entryp == (struct Entrypoint *) NULL) {
+	err ("list_arg_types:  null procedure entry pointer");
+	return;
+    } /* else */
+
+    if (Ansi) {
+	done_one = 0;
+	sep1 = ", ";
+	nice_printf(outfile, "(" /*)*/);
+	}
+    else {
+	done_one = 1;
+	sep1 = ";\n";
+	}
+    args = entryp->arglist;
+    if (add_n_) {
+	nice_printf(outfile, "int n__");
+	did_one = done_one;
+	sep = sep1;
+	args = allargs;
+	}
+    if (multitype) {
+	nice_printf(outfile, "%sMultitype *ret_val", sep);
+	did_one = done_one;
+	sep = sep1;
+	}
+    else if (ONEOF (proctype, MSKCOMPLEX|MSKCHAR)) {
+	s = xretslot[proctype]->user.ident;
+	nice_printf(outfile, "%s%s *%s", sep, c_type_decl(proctype, 0),
+			*s == '(' /*)*/ ? "r_v" : s);
+	did_one = done_one;
+	sep = sep1;
+	if (proctype == TYCHAR)
+	    nice_printf (outfile, "%sftnlen ret_val_len", sep);
+    } /* if ONEOF proctype */
+    for (; args; args = args -> nextp) {
+	Namep arg = (Namep) args->datap;
+
+/* Scalars are passed by reference, and arrays will have their lower bound
+   adjusted, so nearly everything is printed with a star in front.  The
+   exception is character lengths, which are passed by value. */
+
+	if (arg) {
+	    int type = arg -> vtype, class = arg -> vclass;
+
+	    if (class == CLPROC)
+		if (arg->vimpltype)
+			type = Castargs ? TYUNKNOWN : TYSUBR;
+		else if (type == TYREAL && forcedouble && !Castargs)
+			type = TYDREAL;
+
+	    if (type == last_type && class == last_class && did_one)
+		nice_printf (outfile, ", ");
+	    else
+		if ((is_ext = class == CLPROC) && Castargs)
+			nice_printf(outfile, "%s%s ", sep,
+				usedcasts[type] = casttypes[type]);
+		else
+			nice_printf(outfile, "%s%s ", sep,
+				c_type_decl(type, is_ext));
+	    if (class == CLPROC)
+		if (Castargs)
+			out_name(outfile, arg);
+		else {
+			nice_printf(outfile, "(*");
+			out_name(outfile, arg);
+			nice_printf(outfile, ") %s", parens);
+			}
+	    else {
+		nice_printf (outfile, "*");
+		out_name (outfile, arg);
+		}
+
+	    last_type = type;
+	    last_class = class;
+	    did_one = done_one;
+	    sep = sep1;
+	} /* if (arg) */
+    } /* for args = entryp -> arglist */
+
+    for (args = lengths; args; args = args -> nextp)
+	nice_printf(outfile, "%sftnlen %s", sep,
+			new_arg_length((Namep)args->datap));
+    if (did_one)
+	nice_printf (outfile, ";\n");
+    else if (Ansi)
+	nice_printf(outfile,
+		/*((*/ sep != sep1 && Ansi == 1 ? "void)%s" : ")%s",
+		finalnl);
+} /* list_arg_types */
+
+ static void
+write_formats(outfile)
+ FILE *outfile;
+{
+	register struct Labelblock *lp;
+	int first = 1;
+	char *fs;
+
+	for(lp = labeltab ; lp < highlabtab ; ++lp)
+		if (lp->fmtlabused) {
+			if (first) {
+				first = 0;
+				nice_printf(outfile, "/* Format strings */\n");
+				}
+			nice_printf(outfile, "static char fmt_%ld[] = \"",
+				lp->stateno);
+			if (!(fs = lp->fmtstring))
+				fs = "";
+			nice_printf(outfile, "%s\";\n", fs);
+			}
+	if (!first)
+		nice_printf(outfile, "\n");
+	}
+
+ static void
+write_ioblocks(outfile)
+ FILE *outfile;
+{
+	register iob_data *L;
+	register char *f, **s, *sep;
+
+	nice_printf(outfile, "/* Fortran I/O blocks */\n");
+	L = iob_list = (iob_data *)revchain((chainp)iob_list);
+	do {
+		nice_printf(outfile, "static %s %s = { ",
+			L->type, L->name);
+		sep = 0;
+		for(s = L->fields; f = *s; s++) {
+			if (sep)
+				nice_printf(outfile, sep);
+			sep = ", ";
+			if (*f == '"') {	/* kludge */
+				nice_printf(outfile, "\"");
+				nice_printf(outfile, "%s\"", f+1);
+				}
+			else
+				nice_printf(outfile, "%s", f);
+			}
+		nice_printf(outfile, " };\n");
+		}
+		while(L = L->next);
+	nice_printf(outfile, "\n\n");
+	}
+
+ static void
+write_assigned_fmts(outfile)
+ FILE *outfile;
+{
+	register chainp cp;
+	Namep np;
+	int did_one = 0;
+
+	cp = assigned_fmts = revchain(assigned_fmts);
+	nice_printf(outfile, "/* Assigned format variables */\nchar ");
+	do {
+		np = (Namep)cp->datap;
+		if (did_one)
+			nice_printf(outfile, ", ");
+		did_one = 1;
+		nice_printf(outfile, "*%s_fmt", np->fvarname);
+		}
+		while(cp = cp->nextp);
+	nice_printf(outfile, ";\n\n");
+	}
+
+ static char *
+to_upper(s)
+ register char *s;
+{
+	static char buf[64];
+	register char *t = buf;
+	register int c;
+	while(*t++ = (c = *s++) >= 'a' && c <= 'z' ? c + 'A' - 'a' : c);
+	return buf;
+	}
+
+
+/* This routine creates static structures representing a namelist.
+   Declarations of the namelist and related structures are:
+
+	struct Vardesc {
+		char *name;
+		char *addr;
+		ftnlen *dims;	/* laid out as struct dimensions below *//*
+		int  type;
+		};
+	typedef struct Vardesc Vardesc;
+
+	struct Namelist {
+		char *name;
+		Vardesc **vars;
+		int nvars;
+		};
+
+	struct dimensions
+		{
+		ftnlen numberofdimensions;
+		ftnlen numberofelements
+		ftnlen baseoffset;
+		ftnlen span[numberofdimensions-1];
+		};
+
+   If dims is not null, then the corner element of the array is at
+   addr.  However,  the element with subscripts (i1,...,in) is at
+   addr + sizeoftype * (i1+span[0]*(i2+span[1]*...) - dimp->baseoffset)
+*/
+
+ static void
+write_namelists(nmch, outfile)
+ chainp nmch;
+ FILE *outfile;
+{
+	Namep var;
+	struct Hashentry *entry;
+	struct Dimblock *dimp;
+	int i, nd, type;
+	char *comma, *name;
+	register chainp q;
+	register Namep v;
+
+	nice_printf(outfile, "/* Namelist stuff */\n\n");
+	for (entry = hashtab; entry < lasthash; ++entry) {
+		if (!(v = entry->varp) || !v->vnamelist)
+			continue;
+		type = v->vtype;
+		name = v->cvarname;
+		if (dimp = v->vdim) {
+			nd = dimp->ndim;
+			nice_printf(outfile,
+				"static ftnlen %s_dims[] = { %d, %ld, %ld",
+				name, nd,
+				dimp->nelt->constblock.Const.ci,
+				dimp->baseoffset->constblock.Const.ci);
+			for(i = 0, --nd; i < nd; i++)
+				nice_printf(outfile, ", %ld",
+				  dimp->dims[i].dimsize->constblock.Const.ci);
+			nice_printf(outfile, " };\n");
+			}
+		nice_printf(outfile, "static Vardesc %s_dv = { \"%s\", %s",
+			name, to_upper(name),
+			type == TYCHAR ? "" : dimp ? "(char *)" : "(char *)&");
+		out_name(outfile, v);
+		nice_printf(outfile, dimp ? ", %s_dims" : ", (ftnlen *)0", name);
+		nice_printf(outfile, ", %ld };\n",
+			type != TYCHAR  ? (long)type
+					: -v->vleng->constblock.Const.ci);
+		}
+
+	do {
+		var = (Namep)nmch->datap;
+		name = var->cvarname;
+		nice_printf(outfile, "\nstatic Vardesc *%s_vl[] = ", name);
+		comma = "{";
+		i = 0;
+		for(q = var->varxptr.namelist ; q ; q = q->nextp) {
+			v = (Namep)q->datap;
+			if (!v->vnamelist)
+				continue;
+			i++;
+			nice_printf(outfile, "%s &%s_dv", comma, v->cvarname);
+			comma = ",";
+			}
+		nice_printf(outfile, " };\n");
+		nice_printf(outfile,
+			"static Namelist %s = { \"%s\", %s_vl, %d };\n",
+			name, to_upper(name), name, i);
+		}
+		while(nmch = nmch->nextp);
+	nice_printf(outfile, "\n");
+	}
+
+/* fixextype tries to infer from usage in previous procedures
+   the type of an external procedure declared
+   external and passed as an argument but never typed or invoked.
+ */
+
+ static int
+fixexttype(var)
+ Namep var;
+{
+	Extsym *e;
+	int type, type1;
+	extern void changedtype();
+
+	type = var->vtype;
+	e = &extsymtab[var->vardesc.varno];
+	if ((type1 = e->extype) && type == TYUNKNOWN)
+		return var->vtype = type1;
+	if (var->visused) {
+		if (e->exused && type != type1)
+			changedtype(var);
+		e->exused = 1;
+		e->extype = type;
+		}
+	return type;
+	}
+
+list_decls (outfile)
+FILE *outfile;
+{
+    extern chainp used_builtins;
+    extern struct Hashentry *hashtab;
+    extern ftnint wr_char_len();
+    struct Hashentry *entry;
+    int write_header = 1;
+    int last_class = -1, last_stg = -1;
+    Namep var;
+    int Alias, Define, did_one, last_type, type;
+    extern int def_equivs, useauto;
+    extern chainp new_vars;	/* Compiler-generated locals */
+    chainp namelists = 0;
+    char *ctype;
+    long lineno_save = lineno;
+    int useauto1 = useauto && !saveall;
+    long x;
+    extern int hsize;
+
+    lineno = old_lineno;
+
+/* First write out the statically initialized data */
+
+    if (initfile)
+	list_init_data(&initfile, initfname, outfile);
+
+/* Next come formats */
+    write_formats(outfile);
+
+/* Now write out the system-generated identifiers */
+
+    if (new_vars || nequiv) {
+	chainp args, next_var, this_var;
+	chainp nv[TYVOID], nv1[TYVOID];
+	int i, j;
+	Addrp Var;
+	Namep arg;
+
+	/* zap unused dimension variables */
+
+	for(args = allargs; args; args = args->nextp) {
+		arg = (Namep)args->datap;
+		if (this_var = arg->vlastdim) {
+			frexpr((tagptr)this_var->datap);
+			this_var->datap = 0;
+			}
+		}
+
+	/* sort new_vars by type, skipping entries just zapped */
+
+	for(i = TYADDR; i < TYVOID; i++)
+		nv[i] = 0;
+	for(this_var = new_vars; this_var; this_var = next_var) {
+		next_var = this_var->nextp;
+		if (Var = (Addrp)this_var->datap) {
+			if (!(this_var->nextp = nv[j = Var->vtype]))
+				nv1[j] = this_var;
+			nv[j] = this_var;
+			}
+		else {
+			this_var->nextp = 0;
+			frchain(&this_var);
+			}
+		}
+	new_vars = 0;
+	for(i = TYVOID; --i >= TYADDR;)
+		if (this_var = nv[i]) {
+			nv1[i]->nextp = new_vars;
+			new_vars = this_var;
+			}
+
+	/* write the declarations */
+
+	did_one = 0;
+	last_type = -1;
+
+	for (this_var = new_vars; this_var; this_var = this_var -> nextp) {
+	    Var = (Addrp) this_var->datap;
+
+	    if (Var == (Addrp) NULL)
+		err ("list_decls:  null variable");
+	    else if (Var -> tag != TADDR)
+		erri ("list_decls:  bad tag on new variable '%d'",
+			Var -> tag);
+
+	    type = nv_type (Var);
+	    if (Var->vstg == STGINIT
+	    ||  Var->uname_tag == UNAM_IDENT
+			&& *Var->user.ident == ' '
+			&& multitype)
+		continue;
+	    if (!did_one)
+		nice_printf (outfile, "/* System generated locals */\n");
+
+	    if (last_type == type && did_one)
+		nice_printf (outfile, ", ");
+	    else {
+		if (did_one)
+		    nice_printf (outfile, ";\n");
+		nice_printf (outfile, "%s ",
+			c_type_decl (type, Var -> vclass == CLPROC));
+	    } /* else */
+
+/* Character type is really a string type.  Put out a '*' for parameters
+   with unknown length and functions returning character */
+
+	    if (Var -> vtype == TYCHAR && (!ISICON ((Var -> vleng))
+		    || Var -> vclass == CLPROC))
+		nice_printf (outfile, "*");
+
+	    write_nv_ident(outfile, (Addrp)this_var->datap);
+	    if (Var -> vtype == TYCHAR && Var->vclass != CLPROC &&
+		    ISICON((Var -> vleng))
+			&& (i = Var->vleng->constblock.Const.ci) > 0)
+		nice_printf (outfile, "[%d]", i);
+
+	    did_one = 1;
+	    last_type = nv_type (Var);
+	} /* for this_var */
+
+/* Handle the uninitialized equivalences */
+
+	do_uninit_equivs (outfile, &did_one);
+
+	if (did_one)
+	    nice_printf (outfile, ";\n\n");
+    } /* if new_vars */
+
+/* Write out builtin declarations */
+
+    if (used_builtins) {
+	chainp cp;
+	Extsym *es;
+
+	last_type = -1;
+	did_one = 0;
+
+	nice_printf (outfile, "/* Builtin functions */");
+
+	for (cp = used_builtins; cp; cp = cp -> nextp) {
+	    Addrp e = (Addrp)cp->datap;
+
+	    switch(type = e->vtype) {
+		case TYDREAL:
+		case TYREAL:
+			/* if (forcedouble || e->dbl_builtin) */
+			/* libF77 currently assumes everything double */
+			type = TYDREAL;
+			ctype = "double";
+			break;
+		case TYCOMPLEX:
+		case TYDCOMPLEX:
+			type = TYVOID;
+			/* no break */
+		default:
+			ctype = c_type_decl(type, 0);
+		}
+
+	    if (did_one && last_type == type)
+		nice_printf(outfile, ", ");
+	    else
+		nice_printf(outfile, "%s\n%s ", did_one ? ";" : "", ctype);
+
+	    extern_out(outfile, es = &extsymtab[e -> memno]);
+	    proto(outfile, es->arginfo, es->fextname);
+	    last_type = type;
+	    did_one = 1;
+	} /* for cp = used_builtins */
+
+	nice_printf (outfile, ";\n\n");
+    } /* if used_builtins */
+
+    last_type = -1;
+    for (entry = hashtab; entry < lasthash; ++entry) {
+	var = entry -> varp;
+
+	if (var) {
+	    int procclass = var -> vprocclass;
+	    char *comment = NULL;
+	    int stg = var -> vstg;
+	    int class = var -> vclass;
+	    type = var -> vtype;
+
+	    if (ONEOF(stg, M(STGARG)|M(STGLENG)|M(STGINIT)))
+		continue;
+
+	    if (useauto1 && stg == STGBSS && !var->vsave)
+		stg = STGAUTO;
+
+	    switch (class) {
+	        case CLVAR:
+		    break;
+		case CLPROC:
+		    switch(procclass) {
+			case PTHISPROC:
+				extsymtab[var->vardesc.varno].extype = type;
+				continue;
+			case PSTFUNCT:
+			case PINTRINSIC:
+				continue;
+			case PUNKNOWN:
+				err ("list_decls:  unknown procedure class");
+				continue;
+			case PEXTERNAL:
+				if (stg == STGUNKNOWN) {
+					warn1(
+					"%.64s declared EXTERNAL but never used.",
+						var->fvarname);
+					/* to retain names declared EXTERNAL */
+					/* but not referenced, change
+					/* "continue" to "stg = STGEXT" */
+					continue;
+					}
+				else
+					type = fixexttype(var);
+			}
+		    break;
+		case CLUNKNOWN:
+			/* declared but never used */
+			continue;
+		case CLPARAM:
+			continue;
+		case CLNAMELIST:
+			if (var->visused)
+				namelists = mkchain((char *)var, namelists);
+			continue;
+		default:
+		    erri("list_decls:  can't handle class '%d' yet",
+			    class);
+		    Fatal(var->fvarname);
+		    continue;
+	    } /* switch */
+
+	    /* Might be equivalenced to a common.  If not, don't process */
+	    if (stg == STGCOMMON && !var->vcommequiv)
+		continue;
+
+/* Only write the header if system-generated locals, builtins, or
+   uninitialized equivs were already output */
+
+	    if (write_header == 1 && (new_vars || nequiv || used_builtins)
+		    && oneof_stg ( var, stg,
+		    M(STGBSS)|M(STGEXT)|M(STGAUTO)|M(STGCOMMON)|M(STGEQUIV))) {
+		nice_printf (outfile, "/* Local variables */\n");
+		write_header = 2;
+		}
+
+
+	    Alias = oneof_stg(var, stg, M(STGEQUIV)|M(STGCOMMON));
+	    if (Define = (Alias && def_equivs)) {
+		if (!write_header)
+			nice_printf(outfile, ";\n");
+		def_start(outfile, var->cvarname, CNULL, "(");
+		goto Alias1;
+		}
+	    else if (type == last_type && class == last_class &&
+		    stg == last_stg && !write_header)
+		nice_printf (outfile, ", ");
+	    else {
+		if (!write_header && ONEOF(stg, M(STGBSS)|
+		    M(STGEXT)|M(STGAUTO)|M(STGEQUIV)|M(STGCOMMON)))
+		    nice_printf (outfile, ";\n");
+
+		switch (stg) {
+		    case STGARG:
+		    case STGLENG:
+			/* Part of the argument list, don't write them out
+			   again */
+			continue;	    /* Go back to top of the loop */
+		    case STGBSS:
+		    case STGEQUIV:
+		    case STGCOMMON:
+			nice_printf (outfile, "static ");
+			break;
+		    case STGEXT:
+			nice_printf (outfile, "extern ");
+			break;
+		    case STGAUTO:
+			break;
+		    case STGINIT:
+		    case STGUNKNOWN:
+			/* Don't want to touch the initialized data, that will
+			   be handled elsewhere.  Unknown data have
+			   already been complained about, so skip them */
+			continue;
+		    default:
+			erri("list_decls:  can't handle storage class %d",
+				stg);
+			continue;
+		} /* switch */
+
+		if (type == TYCHAR && halign && class != CLPROC
+		&& ISICON(var->vleng)) {
+			nice_printf(outfile, "struct { %s fill; char val",
+				halign);
+			x = wr_char_len(outfile, var->vdim,
+				var->vleng->constblock.Const.ci, 1);
+			if (x %= hsize)
+				nice_printf(outfile, "; char fill2[%ld]",
+					hsize - x);
+			nice_printf(outfile, "; } %s_st;\n", var->cvarname);
+			def_start(outfile, var->cvarname, CNULL, var->cvarname);
+			ind_printf(0, outfile, "_st.val\n");
+			last_type = -1;
+			write_header = 2;
+			continue;
+			}
+		nice_printf(outfile, "%s ",
+			c_type_decl(type, class == CLPROC));
+	    } /* else */
+
+/* Character type is really a string type.  Put out a '*' for variable
+   length strings, and also for equivalences */
+
+	    if (type == TYCHAR && class != CLPROC
+		    && (!var->vleng || !ISICON (var -> vleng))
+	    || oneof_stg(var, stg, M(STGEQUIV)|M(STGCOMMON)))
+		nice_printf (outfile, "*%s", var->cvarname);
+	    else {
+		nice_printf (outfile, "%s", var->cvarname);
+		if (class == CLPROC)
+			proto(outfile, var->arginfo, var->fvarname);
+		else if (type == TYCHAR && ISICON ((var -> vleng)))
+			wr_char_len(outfile, var->vdim,
+				(int)var->vleng->constblock.Const.ci, 0);
+		else if (var -> vdim &&
+		    !oneof_stg (var, stg, M(STGEQUIV)|M(STGCOMMON)))
+			comment = wr_ardecls(outfile, var->vdim, 1L);
+		}
+
+	    if (comment)
+		nice_printf (outfile, "%s", comment);
+ Alias1:
+	    if (Alias) {
+		char *amp, *lp, *name, *rp;
+		char *equiv_name ();
+		ftnint voff = var -> voffset;
+		int et0, expr_type, k;
+		Extsym *E;
+		struct Equivblock *eb;
+		char buf[16];
+
+/* We DON'T want to use oneof_stg here, because we need to distinguish
+   between them */
+
+		if (stg == STGEQUIV) {
+			name = equiv_name(k = var->vardesc.varno, CNULL);
+			eb = eqvclass + k;
+			if (eb->eqvinit) {
+				amp = "&";
+				et0 = TYERROR;
+				}
+			else {
+				amp = "";
+				et0 = eb->eqvtype;
+				}
+			expr_type = et0;
+		    }
+		else {
+			E = &extsymtab[var->vardesc.varno];
+			sprintf(name = buf, "%s%d", E->cextname, E->curno);
+			expr_type = type;
+			et0 = -1;
+			amp = "&";
+		} /* else */
+
+		if (!Define)
+			nice_printf (outfile, " = ");
+		if (voff) {
+			k = typesize[type];
+			switch((int)(voff % k)) {
+				case 0:
+					voff /= k;
+					expr_type = type;
+					break;
+				case SZSHORT:
+				case SZSHORT+SZLONG:
+					expr_type = TYSHORT;
+					voff /= SZSHORT;
+					break;
+				case SZLONG:
+					expr_type = TYLONG;
+					voff /= SZLONG;
+					break;
+				default:
+					expr_type = TYCHAR;
+				}
+			}
+
+		if (expr_type == type) {
+			lp = rp = "";
+			if (et0 == -1 && !voff)
+				goto cast;
+			}
+		else {
+			lp = "(";
+			rp = ")";
+ cast:
+			nice_printf(outfile, "(%s *)", c_type_decl(type, 0));
+			}
+
+/* Now worry about computing the offset */
+
+		if (voff) {
+		    if (expr_type == et0)
+			nice_printf (outfile, "%s%s + %ld%s",
+				lp, name, voff, rp);
+		    else
+			nice_printf(outfile, "%s(%s *)%s%s + %ld%s", lp,
+				c_type_decl (expr_type, 0), amp,
+				name, voff, rp);
+		} else
+		    nice_printf(outfile, "%s%s", amp, name);
+/* Always put these at the end of the line */
+		last_type = last_class = last_stg = -1;
+		write_header = 0;
+		if (Define) {
+			ind_printf(0, outfile, ")\n");
+			write_header = 2;
+			}
+		continue;
+		}
+	    write_header = 0;
+	    last_type = type;
+	    last_class = class;
+	    last_stg = stg;
+	} /* if (var) */
+    } /* for (entry = hashtab */
+
+    if (!write_header)
+	nice_printf (outfile, ";\n\n");
+    else if (write_header == 2)
+	nice_printf(outfile, "\n");
+
+/* Next, namelists, which may reference equivs */
+
+    if (namelists) {
+	write_namelists(namelists = revchain(namelists), outfile);
+	frchain(&namelists);
+	}
+
+/* Finally, ioblocks (which may reference equivs and namelists) */
+    if (iob_list)
+	write_ioblocks(outfile);
+    if (assigned_fmts)
+	write_assigned_fmts(outfile);
+    lineno = lineno_save;
+} /* list_decls */
+
+do_uninit_equivs (outfile, did_one)
+FILE *outfile;
+int *did_one;
+{
+    extern int nequiv;
+    struct Equivblock *eqv, *lasteqv = eqvclass + nequiv;
+    int k, last_type = -1, t;
+
+    for (eqv = eqvclass; eqv < lasteqv; eqv++)
+	if (!eqv -> eqvinit && eqv -> eqvtop != eqv -> eqvbottom) {
+	    if (!*did_one)
+		nice_printf (outfile, "/* System generated locals */\n");
+	    t = eqv->eqvtype;
+	    if (last_type == t)
+		nice_printf (outfile, ", ");
+	    else {
+		if (*did_one)
+		    nice_printf (outfile, ";\n");
+		nice_printf (outfile, "static %s ", c_type_decl(t, 0));
+		k = typesize[t];
+	    } /* else */
+	    nice_printf(outfile, "%s", equiv_name((int)(eqv - eqvclass), CNULL));
+	    nice_printf(outfile, "[%ld]",
+		(eqv->eqvtop - eqv->eqvbottom + k - 1) / k);
+	    last_type = t;
+	    *did_one = 1;
+	} /* if !eqv -> eqvinit */
+} /* do_uninit_equivs */
+
+
+/* wr_ardecls -- Writes the brackets and size for an array
+   declaration.  Because of the inner workings of the compiler,
+   multi-dimensional arrays get mapped directly into a one-dimensional
+   array, so we have to compute the size of the array here.  When the
+   dimension is greater than 1, a string comment about the original size
+   is returned */
+
+char *wr_ardecls(outfile, dimp, size)
+FILE *outfile;
+struct Dimblock *dimp;
+long size;
+{
+    int i, k;
+    static char buf[1000];
+
+    if (dimp == (struct Dimblock *) NULL)
+	return NULL;
+
+    sprintf(buf, "\t/* was ");	/* would like to say  k = sprintf(...), but */
+    k = strlen(buf);		/* BSD doesn't return char transmitted count */
+
+    for (i = 0; i < dimp -> ndim; i++) {
+	expptr this_size = dimp -> dims[i].dimsize;
+
+	if (!ISICON (this_size))
+	    err ("wr_ardecls:  nonconstant array size");
+	else {
+	    size *= this_size -> constblock.Const.ci;
+	    sprintf(buf+k, "[%ld]", this_size -> constblock.Const.ci);
+	    k += strlen(buf+k);	/* BSD prevents combining this with prev stmt */
+	} /* else */
+    } /* for i = 0 */
+
+    nice_printf (outfile, "[%ld]", size);
+    strcat(buf+k, " */");
+
+    return (i > 1) ? buf : NULL;
+} /* wr_ardecls */
+
+
+
+/* ----------------------------------------------------------------------
+
+	The following routines read from the p1 intermediate file.  If
+   that format changes, only these routines need be changed
+
+   ---------------------------------------------------------------------- */
+
+static int get_p1_token (infile)
+FILE *infile;
+{
+    int token = P1_UNKNOWN;
+
+/* NOT PORTABLE!! */
+
+    if (fscanf (infile, "%d", &token) == EOF)
+	return P1_EOF;
+
+/* Skip over the ": " */
+
+    if (getc (infile) != '\n')
+	getc (infile);
+
+    return token;
+} /* get_p1_token */
+
+
+
+/* Returns a (null terminated) string from the input file */
+
+static int p1gets (fp, str, size)
+FILE *fp;
+char *str;
+int size;
+{
+    char *fgets ();
+    char c;
+
+    if (str == NULL)
+	return 0;
+
+    if ((c = getc (fp)) != ' ')
+	ungetc (c, fp);
+
+    if (fgets (str, size, fp)) {
+	int length;
+
+	str[size - 1] = '\0';
+	length = strlen (str);
+
+/* Get rid of the newline */
+
+	if (str[length - 1] == '\n')
+	    str[length - 1] = '\0';
+	return 1;
+
+    } else if (feof (fp))
+	return EOF;
+    else
+	return 0;
+} /* p1gets */
+
+
+static int p1get_const (infile, type, resultp)
+FILE *infile;
+int type;
+struct Constblock **resultp;
+{
+    int status;
+    struct Constblock *result;
+
+	if (type != TYCHAR) {
+		*resultp = result = ALLOC(Constblock);
+		result -> tag = TCONST;
+		result -> vtype = type;
+		}
+
+    switch (type) {
+        case TYSHORT:
+	case TYLONG:
+	case TYLOGICAL:
+	    status = p1getd (infile, &(result -> Const.ci));
+	    break;
+	case TYREAL:
+	case TYDREAL:
+	    status = p1getf(infile, &result->Const.cds[0]);
+	    result->vstg = 1;
+	    break;
+	case TYCOMPLEX:
+	case TYDCOMPLEX:
+	    status = p1getf(infile, &result->Const.cds[0]);
+	    if (status && status != EOF)
+		status = p1getf(infile, &result->Const.cds[1]);
+	    result->vstg = 1;
+	    break;
+	case TYCHAR:
+	    status = fscanf(infile, "%lx", resultp);
+	    break;
+	default:
+	    erri ("p1get_const:  bad constant type '%d'", type);
+	    status = 0;
+	    break;
+    } /* switch */
+
+    return status;
+} /* p1get_const */
+
+static int p1getd (infile, result)
+FILE *infile;
+long *result;
+{
+    return fscanf (infile, "%ld", result);
+} /* p1getd */
+
+ static int
+p1getf(infile, result)
+ FILE *infile;
+ char **result;
+{
+
+	char buf[1324];
+	register int k;
+
+	k = fscanf (infile, "%s", buf);
+	if (k < 1)
+		k = EOF;
+	else
+		strcpy(*result = mem(strlen(buf)+1,0), buf);
+	return k;
+}
+
+static int p1getn (infile, count, result)
+FILE *infile;
+int count;
+char **result;
+{
+
+    char *bufptr;
+    extern ptr ckalloc ();
+
+    bufptr = (char *) ckalloc (count);
+
+    if (result)
+	*result = bufptr;
+
+    for (; !feof (infile) && count > 0; count--)
+	*bufptr++ = getc (infile);
+
+    return feof (infile) ? EOF : 1;
+} /* p1getn */
+
+ static void
+proto(outfile, at, fname)
+ FILE *outfile;
+ Argtypes *at;
+ char *fname;
+{
+	int i, j, k, n;
+	char *comma;
+	Atype *atypes;
+	Namep np;
+	chainp cp;
+	extern void bad_atypes();
+
+	if (at) {
+		/* Correct types that we learn on the fly, e.g.
+			subroutine gotcha(foo)
+			external foo
+			call zap(...,foo,...)
+			call foo(...)
+		*/
+		atypes = at->atypes;
+		n = at->nargs;
+		for(i = 0; i++ < n; atypes++) {
+			if (!(cp = atypes->cp))
+				continue;
+			j = atypes->type;
+			do {
+				np = (Namep)cp->datap;
+				k = np->vtype;
+				if (np->vclass == CLPROC) {
+					if (!np->vimpltype && k)
+						k += 200;
+					else {
+						if (j >= 300)
+							j = TYUNKNOWN + 200;
+						continue;
+						}
+					}
+				if (j == k)
+					continue;
+				if (j >= 300
+				||  j == 200 && k >= 200)
+					j = k;
+				else {
+					bad_atypes(at,fname,i,j,k,""," and");
+					goto break2;
+					}
+				}
+				while(cp = cp->nextp);
+			atypes->type = j;
+			frchain(&atypes->cp);
+			}
+		}
+ break2:
+	if (parens) {
+		nice_printf(outfile, parens);
+		return;
+		}
+
+	if (!at || (n = at->nargs) < 0) {
+		nice_printf(outfile, Ansi == 1 ? "()" : "(...)");
+		return;
+		}
+
+	if (n == 0) {
+		nice_printf(outfile, Ansi == 1 ? "(void)" : "()");
+		return;
+		}
+
+	atypes = at->atypes;
+	nice_printf(outfile, "(");
+	comma = "";
+	for(; --n >= 0; atypes++) {
+		k = atypes->type;
+		if (k == TYADDR)
+			nice_printf(outfile, "%schar **", comma);
+		else if (k >= 200) {
+			k -= 200;
+			nice_printf(outfile, "%s%s", comma,
+				usedcasts[k] = casttypes[k]);
+			}
+		else if (k >= 100)
+			nice_printf(outfile,
+					k == TYCHAR + 100 ? "%s%s *" : "%s%s",
+					comma, c_type_decl(k-100, 0));
+		else
+			nice_printf(outfile, "%s%s *", comma,
+					c_type_decl(k, 0));
+		comma = ", ";
+		}
+	nice_printf(outfile, ")");
+	}
+
+ void
+protowrite(protofile, type, name, e, lengths)
+ FILE *protofile;
+ char *name;
+ struct Entrypoint *e;
+ chainp lengths;
+{
+	extern char used_rets[];
+
+	nice_printf(protofile, "extern %s %s", protorettypes[type], name);
+	list_arg_types(protofile, e, lengths, 0, ";\n");
+	used_rets[type] = 1;
+	}
+
+ static void
+do_p1_1while(outfile)
+ FILE *outfile;
+{
+	if (*wh_next) {
+		nice_printf(outfile,
+			"for(;;) { /* while(complicated condition) */\n" /*}*/ );
+		next_tab(outfile);
+		}
+	else
+		nice_printf(outfile, "while(" /*)*/ );
+	}
+
+ static void
+do_p1_2while(infile, outfile)
+ FILE *infile, *outfile;
+{
+	expptr test;
+
+	test = do_format(infile, outfile);
+	if (*wh_next)
+		nice_printf(outfile, "if (!(");
+	expr_out(outfile, test);
+	if (*wh_next++)
+		nice_printf(outfile, "))\n\tbreak;\n");
+	else {
+		nice_printf(outfile, /*(*/ ") {\n");
+		next_tab(outfile);
+		}
+	}
+
+ static void
+do_p1_elseifstart(outfile)
+ FILE *outfile;
+{
+	if (*ei_next++) {
+		prev_tab(outfile);
+		nice_printf(outfile, /*{*/
+			"} else /* if(complicated condition) */ {\n" /*}*/ );
+		next_tab(outfile);
+		}
+	}

+ 10 - 0
lang/fortran/comp/format.h

@@ -0,0 +1,10 @@
+#define DEF_C_LINE_LENGTH 77
+/* actual max will be 79 */
+
+extern int c_output_line_length;	/* max # chars per line in C source
+					   code */
+
+char *wr_ardecls (/* FILE *, struct Dimblock * */);
+void list_init_data (), wr_one_init (), wr_output_values ();
+int do_init_data ();
+chainp data_value ();

+ 1037 - 0
lang/fortran/comp/formatdata.c

@@ -0,0 +1,1037 @@
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+#include "defs.h"
+#include "output.h"
+#include "names.h"
+#include "format.h"
+
+#define MAX_INIT_LINE 100
+#define NAME_MAX 64
+
+static int memno2info();
+
+extern char *initbname;
+extern void def_start();
+
+void list_init_data(Infile, Inname, outfile)
+ FILE **Infile, *outfile;
+ char *Inname;
+{
+    FILE *sortfp;
+    int status;
+
+    fclose(*Infile);
+    *Infile = 0;
+
+    if (status = dsort(Inname, sortfname))
+	fatali ("sort failed, status %d", status);
+
+    scrub(Inname); /* optionally unlink Inname */
+
+    if ((sortfp = fopen(sortfname, textread)) == NULL)
+	Fatal("Couldn't open sorted initialization data");
+
+    do_init_data(outfile, sortfp);
+    fclose(sortfp);
+    scrub(sortfname);
+
+/* Insert a blank line after any initialized data */
+
+	nice_printf (outfile, "\n");
+
+    if (debugflag && infname)
+	 /* don't back block data file up -- it won't be overwritten */
+	backup(initfname, initbname);
+} /* list_init_data */
+
+
+
+/* do_init_data -- returns YES when at least one declaration has been
+   written */
+
+int do_init_data(outfile, infile)
+FILE *outfile, *infile;
+{
+    char varname[NAME_MAX], ovarname[NAME_MAX];
+    ftnint offset;
+    ftnint type;
+    int vargroup;	/* 0 --> init, 1 --> equiv, 2 --> common */
+    int did_one = 0;		/* True when one has been output */
+    chainp values = CHNULL;	/* Actual data values */
+    int keepit = 0;
+    Namep np;
+
+    ovarname[0] = '\0';
+
+    while (rdname (infile, &vargroup, varname) && rdlong (infile, &offset)
+	    && rdlong (infile, &type)) {
+	if (strcmp (varname, ovarname)) {
+
+	/* If this is a new variable name, the old initialization has been
+	   completed */
+
+		wr_one_init(outfile, ovarname, &values, keepit);
+
+		strcpy (ovarname, varname);
+		values = CHNULL;
+		if (vargroup == 0) {
+			if (memno2info(atoi(varname+2), &np)) {
+				if (((Addrp)np)->uname_tag != UNAM_NAME) {
+					err("do_init_data: expected NAME");
+					goto Keep;
+					}
+				np = ((Addrp)np)->user.name;
+				}
+			if (!(keepit = np->visused) && !np->vimpldovar)
+				warn1("local variable %s never used",
+					np->fvarname);
+			}
+		else {
+ Keep:
+			keepit = 1;
+			}
+		if (keepit && !did_one) {
+			nice_printf (outfile, "/* Initialized data */\n\n");
+			did_one = YES;
+			}
+	} /* if strcmp */
+
+	values = mkchain((char *)data_value(infile, offset, (int)type), values);
+    } /* while */
+
+/* Write out the last declaration */
+
+    wr_one_init (outfile, ovarname, &values, keepit);
+
+    return did_one;
+} /* do_init_data */
+
+
+ ftnint
+wr_char_len(outfile, dimp, n, extra1)
+ FILE *outfile;
+ int n;
+ struct Dimblock *dimp;
+ int extra1;
+{
+	int i, nd;
+	expptr e;
+	ftnint rv;
+
+	if (!dimp) {
+		nice_printf (outfile, extra1 ? "[%d+1]" : "[%d]", n);
+		return n + extra1;
+		}
+	nice_printf(outfile, "[%d", n);
+	nd = dimp->ndim;
+	rv = n;
+	for(i = 0; i < nd; i++) {
+		e = dimp->dims[i].dimsize;
+		if (!ISICON (e))
+			err ("wr_char_len:  nonconstant array size");
+		else {
+			nice_printf(outfile, "*%ld", e->constblock.Const.ci);
+			rv *= e->constblock.Const.ci;
+			}
+		}
+	/* extra1 allows for stupid C compilers that complain about
+	 * too many initializers in
+	 *	char x[2] = "ab";
+	 */
+	nice_printf(outfile, extra1 ? "+1]" : "]");
+	return extra1 ? rv+1 : rv;
+	}
+
+ static int ch_ar_dim = -1; /* length of each element of char string array */
+ static int eqvmemno;	/* kludge */
+
+ static void
+write_char_init(outfile, Values, namep)
+ FILE *outfile;
+ chainp *Values;
+ Namep namep;
+{
+	struct Equivblock *eqv;
+	long size;
+	struct Dimblock *dimp;
+	int i, nd, type;
+	expptr ds;
+
+	if (!namep)
+		return;
+	if(nequiv >= maxequiv)
+		many("equivalences", 'q', maxequiv);
+	eqv = &eqvclass[nequiv];
+	eqv->eqvbottom = 0;
+	type = namep->vtype;
+	size = type == TYCHAR
+		? namep->vleng->constblock.Const.ci
+		: typesize[type];
+	if (dimp = namep->vdim)
+		for(i = 0, nd = dimp->ndim; i < nd; i++) {
+			ds = dimp->dims[i].dimsize;
+			if (!ISICON(ds))
+				err("write_char_values: nonconstant array size");
+			else
+				size *= ds->constblock.Const.ci;
+			}
+	*Values = revchain(*Values);
+	eqv->eqvtop = size;
+	eqvmemno = ++lastvarno;
+	eqv->eqvtype = type;
+	wr_equiv_init(outfile, nequiv, Values, 0);
+	def_start(outfile, namep->cvarname, CNULL, "");
+	if (type == TYCHAR)
+		ind_printf(0, outfile, "((char *)&equiv_%d)\n\n", eqvmemno);
+	else
+		ind_printf(0, outfile, dimp
+			? "((%s *)&equiv_%d)\n\n" : "(*(%s *)&equiv_%d)\n\n",
+			c_type_decl(type,0), eqvmemno);
+	}
+
+/* wr_one_init -- outputs the initialization of the variable pointed to
+   by   info.   When   is_addr   is true,   info   is an Addrp; otherwise,
+   treat it as a Namep */
+
+void wr_one_init (outfile, varname, Values, keepit)
+FILE *outfile;
+char *varname;
+chainp *Values;
+int keepit;
+{
+    static int memno;
+    static union {
+	Namep name;
+	Addrp addr;
+    } info;
+    Namep namep;
+    int is_addr, size, type;
+    ftnint last, loc;
+    int is_scalar = 0;
+    char *array_comment = NULL, *name;
+    chainp cp, values;
+    extern char datachar[];
+    static int e1[3] = {1, 0, 1};
+    ftnint x;
+    extern int hsize;
+
+    if (!keepit)
+	goto done;
+    if (varname == NULL || varname[1] != '.')
+	goto badvar;
+
+/* Get back to a meaningful representation; find the given   memno in one
+   of the appropriate tables (user-generated variables in the hash table,
+   system-generated variables in a separate list */
+
+    memno = atoi(varname + 2);
+    switch(varname[0]) {
+	case 'q':
+		/* Must subtract eqvstart when the source file
+		 * contains more than one procedure.
+		 */
+		wr_equiv_init(outfile, eqvmemno = memno - eqvstart, Values, 0);
+		goto done;
+	case 'Q':
+		/* COMMON initialization (BLOCK DATA) */
+		wr_equiv_init(outfile, memno, Values, 1);
+		goto done;
+	case 'v':
+		break;
+	default:
+ badvar:
+		errstr("wr_one_init:  unknown variable name '%s'", varname);
+		goto done;
+	}
+
+    is_addr = memno2info (memno, &info.name);
+    if (info.name == (Namep) NULL) {
+	err ("wr_one_init -- unknown variable");
+	return;
+	}
+    if (is_addr) {
+	if (info.addr -> uname_tag != UNAM_NAME) {
+	    erri ("wr_one_init -- couldn't get name pointer; tag is %d",
+		    info.addr -> uname_tag);
+	    namep = (Namep) NULL;
+	    nice_printf (outfile, " /* bad init data */");
+	} else
+	    namep = info.addr -> user.name;
+    } else
+	namep = info.name;
+
+	/* check for character initialization */
+
+    *Values = values = revchain(*Values);
+    type = info.name->vtype;
+    if (type == TYCHAR) {
+	for(last = 0; values; values = values->nextp) {
+		cp = (chainp)values->datap;
+		loc = (ftnint)cp->datap;
+		if (loc > last) {
+			write_char_init(outfile, Values, namep);
+			goto done;
+			}
+		last = (int)cp->nextp->datap == TYBLANK
+			? loc + (int)cp->nextp->nextp->datap
+			: loc + 1;
+		}
+	if (halign && info.name->tag == TNAME) {
+		nice_printf(outfile, "static struct { %s fill; char val",
+			halign);
+		x = wr_char_len(outfile, namep->vdim, ch_ar_dim =
+			info.name -> vleng -> constblock.Const.ci, 1);
+		if (x %= hsize)
+			nice_printf(outfile, "; char fill2[%ld]", hsize - x);
+		name = info.name->cvarname;
+		nice_printf(outfile, "; } %s_st = { 0,", name);
+		wr_output_values(outfile, namep, *Values);
+		nice_printf(outfile, " };\n");
+		ch_ar_dim = -1;
+		def_start(outfile, name, CNULL, name);
+		ind_printf(0, outfile, "_st.val\n");
+		goto done;
+		}
+	}
+    else {
+	size = typesize[type];
+	loc = 0;
+	for(; values; values = values->nextp) {
+		if ((int)((chainp)values->datap)->nextp->datap == TYCHAR) {
+			write_char_init(outfile, Values, namep);
+			goto done;
+			}
+		last = ((long) ((chainp) values->datap)->datap) / size;
+		if (last - loc > 4) {
+			write_char_init(outfile, Values, namep);
+			goto done;
+			}
+		loc = last;
+		}
+	}
+    values = *Values;
+
+    nice_printf (outfile, "static %s ", c_type_decl (type, 0));
+
+    if (is_addr)
+	write_nv_ident (outfile, info.addr);
+    else
+	out_name (outfile, info.name);
+
+    if (namep)
+	is_scalar = namep -> vdim == (struct Dimblock *) NULL;
+
+    if (namep && !is_scalar)
+	array_comment = type == TYCHAR
+		? 0 : wr_ardecls(outfile, namep->vdim, 1L);
+
+    if (type == TYCHAR)
+	if (ISICON (info.name -> vleng))
+
+/* We'll make single strings one character longer, so that we can use the
+   standard C initialization.  All this does is pad an extra zero onto the
+   end of the string */
+		wr_char_len(outfile, namep->vdim, ch_ar_dim =
+			info.name -> vleng -> constblock.Const.ci, e1[Ansi]);
+	else
+		err ("variable length character initialization");
+
+    if (array_comment)
+	nice_printf (outfile, "%s", array_comment);
+
+    nice_printf (outfile, " = ");
+    wr_output_values (outfile, namep, values);
+    ch_ar_dim = -1;
+    nice_printf (outfile, ";\n");
+ done:
+    frchain(Values);
+} /* wr_one_init */
+
+
+
+
+chainp data_value (infile, offset, type)
+FILE *infile;
+ftnint offset;
+int type;
+{
+    char line[MAX_INIT_LINE + 1], *pointer;
+    chainp vals, prev_val;
+    long atol();
+    char *newval;
+
+    if (fgets (line, MAX_INIT_LINE, infile) == NULL) {
+	err ("data_value:  error reading from intermediate file");
+	return CHNULL;
+    } /* if fgets */
+
+/* Get rid of the trailing newline */
+
+    if (line[0])
+	line[strlen (line) - 1] = '\0';
+
+#define iswhite(x) (isspace (x) || (x) == ',')
+
+    pointer = line;
+    prev_val = vals = CHNULL;
+
+    while (*pointer) {
+	register char *end_ptr, old_val;
+
+/* Move   pointer   to the start of the next word */
+
+	while (*pointer && iswhite (*pointer))
+	    pointer++;
+	if (*pointer == '\0')
+	    break;
+
+/* Move   end_ptr   to the end of the current word */
+
+	for (end_ptr = pointer + 1; *end_ptr && !iswhite (*end_ptr);
+		end_ptr++)
+	    ;
+
+	old_val = *end_ptr;
+	*end_ptr = '\0';
+
+/* Add this value to the end of the list */
+
+	if (ONEOF(type, MSKREAL|MSKCOMPLEX))
+		newval = cpstring(pointer);
+	else
+		newval = (char *)atol(pointer);
+	if (vals) {
+	    prev_val->nextp = mkchain(newval, CHNULL);
+	    prev_val = prev_val -> nextp;
+	} else
+	    prev_val = vals = mkchain(newval, CHNULL);
+	*end_ptr = old_val;
+	pointer = end_ptr;
+    } /* while *pointer */
+
+    return mkchain((char *)offset, mkchain((char *)type, vals));
+} /* data_value */
+
+ static void
+overlapping()
+{
+	extern char *filename0;
+	static int warned = 0;
+
+	if (warned)
+		return;
+	warned = 1;
+
+	fprintf(stderr, "Error");
+	if (filename0)
+		fprintf(stderr, " in file %s", filename0);
+	fprintf(stderr, ": overlapping initializations\n");
+	nerr++;
+	}
+
+ static void make_one_const();
+ static long charlen;
+
+void wr_output_values (outfile, namep, values)
+FILE *outfile;
+Namep namep;
+chainp values;
+{
+	int type = TYUNKNOWN;
+	struct Constblock Const;
+	static expptr Vlen;
+
+	if (namep)
+		type = namep -> vtype;
+
+/* Handle array initializations away from scalars */
+
+	if (namep && namep -> vdim)
+		wr_array_init (outfile, namep -> vtype, values);
+
+	else if (values->nextp && type != TYCHAR)
+		overlapping();
+
+	else {
+		make_one_const(type, &Const.Const, values);
+		Const.vtype = type;
+		Const.vstg = ONEOF(type, MSKREAL|MSKCOMPLEX);
+		if (type== TYCHAR) {
+			if (!Vlen)
+				Vlen = ICON(0);
+			Const.vleng = Vlen;
+			Vlen->constblock.Const.ci = charlen;
+			out_const (outfile, &Const);
+			free (Const.Const.ccp);
+			}
+		else
+			out_const (outfile, &Const);
+		}
+	}
+
+
+wr_array_init (outfile, type, values)
+FILE *outfile;
+int type;
+chainp values;
+{
+    int size = typesize[type];
+    long index, main_index = 0;
+    int k;
+
+    if (type == TYCHAR) {
+	nice_printf(outfile, "\"");
+	k = 0;
+	if (Ansi != 1)
+		ch_ar_dim = -1;
+	}
+    else
+	nice_printf (outfile, "{ ");
+    while (values) {
+	struct Constblock Const;
+
+	index = ((long) ((chainp) values->datap)->datap) / size;
+	while (index > main_index) {
+
+/* Fill with zeros.  The structure shorthand works because the compiler
+   will expand the "0" in braces to fill the size of the entire structure
+   */
+
+	    switch (type) {
+	        case TYREAL:
+		case TYDREAL:
+		    nice_printf (outfile, "0.0,");
+		    break;
+		case TYCOMPLEX:
+		case TYDCOMPLEX:
+		    nice_printf (outfile, "{0},");
+		    break;
+		case TYCHAR:
+			nice_printf(outfile, " ");
+			break;
+		default:
+		    nice_printf (outfile, "0,");
+		    break;
+	    } /* switch */
+	    main_index++;
+	} /* while index > main_index */
+
+	if (index < main_index)
+		overlapping();
+	else switch (type) {
+	    case TYCHAR:
+		{ int this_char;
+
+		if (k == ch_ar_dim) {
+			nice_printf(outfile, "\" \"");
+			k = 0;
+			}
+		this_char = (int) ((chainp) values->datap)->
+				nextp->nextp->datap;
+		if ((int)((chainp)values->datap)->nextp->datap == TYBLANK) {
+			main_index += this_char;
+			k += this_char;
+			while(--this_char >= 0)
+				nice_printf(outfile, " ");
+			values = values -> nextp;
+			continue;
+			}
+		nice_printf(outfile, str_fmt[this_char], this_char);
+		k++;
+		} /* case TYCHAR */
+	        break;
+
+	    case TYSHORT:
+	    case TYLONG:
+	    case TYREAL:
+	    case TYDREAL:
+	    case TYLOGICAL:
+	    case TYCOMPLEX:
+	    case TYDCOMPLEX:
+		make_one_const(type, &Const.Const, values);
+		Const.vtype = type;
+		Const.vstg = ONEOF(type, MSKREAL|MSKCOMPLEX);
+		out_const(outfile, &Const);
+	        break;
+	    default:
+	        erri("wr_array_init: bad type '%d'", type);
+	        break;
+	} /* switch */
+	values = values->nextp;
+
+	main_index++;
+	if (values && type != TYCHAR)
+	    nice_printf (outfile, ",");
+    } /* while values */
+
+    if (type == TYCHAR) {
+	nice_printf(outfile, "\"");
+	}
+    else
+	nice_printf (outfile, " }");
+} /* wr_array_init */
+
+
+ static void
+make_one_const(type, storage, values)
+ int type;
+ union Constant *storage;
+ chainp values;
+{
+    union Constant *Const;
+    register char **L;
+
+    if (type == TYCHAR) {
+	char *str, *str_ptr;
+	chainp v, prev;
+	int b = 0, k, main_index = 0;
+
+/* Find the max length of init string, by finding the highest offset
+   value stored in the list of initial values */
+
+	for(k = 1, prev = CHNULL, v = values; v; prev = v, v = v->nextp)
+	    ;
+	if (prev != CHNULL)
+	    k = ((int) (((chainp) prev->datap)->datap)) + 2;
+		/* + 2 above for null char at end */
+	str = Alloc (k);
+	for (str_ptr = str; values; str_ptr++) {
+	    int index = (int) (((chainp) values->datap)->datap);
+
+	    if (index < main_index)
+		overlapping();
+	    while (index > main_index++)
+		*str_ptr++ = ' ';
+
+		k = (int) (((chainp) values->datap)->nextp->nextp->datap);
+		if ((int)((chainp)values->datap)->nextp->datap == TYBLANK) {
+			b = k;
+			break;
+			}
+		*str_ptr = k;
+		values = values -> nextp;
+	} /* for str_ptr */
+	*str_ptr = '\0';
+	Const = storage;
+	Const -> ccp = str;
+	Const -> ccp1.blanks = b;
+	charlen = str_ptr - str;
+    } else {
+	int i = 0;
+	chainp vals;
+
+	vals = ((chainp)values->datap)->nextp->nextp;
+	if (vals) {
+		L = (char **)storage;
+		do L[i++] = vals->datap;
+			while(vals = vals->nextp);
+		}
+
+    } /* else */
+
+} /* make_one_const */
+
+
+
+rdname (infile, vargroupp, name)
+FILE *infile;
+int *vargroupp;
+char *name;
+{
+    register int i, c;
+
+    c = getc (infile);
+
+    if (feof (infile))
+	return NO;
+
+    *vargroupp = c - '0';
+    for (i = 1;; i++) {
+	if (i >= NAME_MAX)
+		Fatal("rdname: oversize name");
+	c = getc (infile);
+	if (feof (infile))
+	    return NO;
+	if (c == '\t')
+		break;
+	*name++ = c;
+    }
+    *name = 0;
+    return YES;
+} /* rdname */
+
+rdlong (infile, n)
+FILE *infile;
+ftnint *n;
+{
+    register int c;
+
+    for (c = getc (infile); !feof (infile) && isspace (c); c = getc (infile))
+	;
+
+    if (feof (infile))
+	return NO;
+
+    for (*n = 0; isdigit (c); c = getc (infile))
+	*n = 10 * (*n) + c - '0';
+    return YES;
+} /* rdlong */
+
+
+ static int
+memno2info (memno, info)
+ int memno;
+ Namep *info;
+{
+    chainp this_var;
+    extern chainp new_vars;
+    extern struct Hashentry *hashtab, *lasthash;
+    struct Hashentry *entry;
+
+    for (this_var = new_vars; this_var; this_var = this_var -> nextp) {
+	Addrp var = (Addrp) this_var->datap;
+
+	if (var == (Addrp) NULL)
+	    Fatal("memno2info:  null variable");
+	else if (var -> tag != TADDR)
+	    Fatal("memno2info:  bad tag");
+	if (memno == var -> memno) {
+	    *info = (Namep) var;
+	    return 1;
+	} /* if memno == var -> memno */
+    } /* for this_var = new_vars */
+
+    for (entry = hashtab; entry < lasthash; ++entry) {
+	Namep var = entry -> varp;
+
+	if (var && var -> vardesc.varno == memno && var -> vstg == STGINIT) {
+	    *info = (Namep) var;
+	    return 0;
+	} /* if entry -> vardesc.varno == memno */
+    } /* for entry = hashtab */
+
+    Fatal("memno2info:  couldn't find memno");
+    return 0;
+} /* memno2info */
+
+ static chainp
+do_string(outfile, v, nloc)
+ FILEP outfile;
+ register chainp v;
+ ftnint *nloc;
+{
+	register chainp cp, v0;
+	ftnint dloc, k, loc;
+	unsigned long uk;
+	char buf[8], *comma;
+
+	nice_printf(outfile, "{");
+	cp = (chainp)v->datap;
+	loc = (ftnint)cp->datap;
+	comma = "";
+	for(v0 = v;;) {
+		switch((int)cp->nextp->datap) {
+			case TYBLANK:
+				k = (ftnint)cp->nextp->nextp->datap;
+				loc += k;
+				while(--k >= 0) {
+					nice_printf(outfile, "%s' '", comma);
+					comma = ", ";
+					}
+				break;
+			case TYCHAR:
+				uk = (ftnint)cp->nextp->nextp->datap;
+				sprintf(buf, chr_fmt[uk], uk);
+				nice_printf(outfile, "%s'%s'", comma, buf);
+				comma = ", ";
+				loc++;
+				break;
+			default:
+				goto done;
+			}
+		v0 = v;
+		if (!(v = v->nextp))
+			break;
+		cp = (chainp)v->datap;
+		dloc = (ftnint)cp->datap;
+		if (loc != dloc)
+			break;
+		}
+ done:
+	nice_printf(outfile, "}");
+	*nloc = loc;
+	return v0;
+	}
+
+ static chainp
+Ado_string(outfile, v, nloc)
+ FILEP outfile;
+ register chainp v;
+ ftnint *nloc;
+{
+	register chainp cp, v0;
+	ftnint dloc, k, loc;
+
+	nice_printf(outfile, "\"");
+	cp = (chainp)v->datap;
+	loc = (ftnint)cp->datap;
+	for(v0 = v;;) {
+		switch((int)cp->nextp->datap) {
+			case TYBLANK:
+				k = (ftnint)cp->nextp->nextp->datap;
+				loc += k;
+				while(--k >= 0)
+					nice_printf(outfile, " ");
+				break;
+			case TYCHAR:
+				k = (ftnint)cp->nextp->nextp->datap;
+				nice_printf(outfile, str_fmt[k], k);
+				loc++;
+				break;
+			default:
+				goto done;
+			}
+		v0 = v;
+		if (!(v = v->nextp))
+			break;
+		cp = (chainp)v->datap;
+		dloc = (ftnint)cp->datap;
+		if (loc != dloc)
+			break;
+		}
+ done:
+	nice_printf(outfile, "\"");
+	*nloc = loc;
+	return v0;
+	}
+
+ static char *
+Len(L,type)
+ long L;
+ int type;
+{
+	static char buf[24];
+	if (L == 1 && type != TYCHAR)
+		return "";
+	sprintf(buf, "[%ld]", L);
+	return buf;
+	}
+
+wr_equiv_init(outfile, memno, Values, iscomm)
+ FILE *outfile;
+ int memno;
+ chainp *Values;
+ int iscomm;
+{
+	struct Equivblock *eqv;
+	char *equiv_name ();
+	int curtype, dtype, filltype, filltype1, j, k, wasblank, xtype;
+	static char Blank[] = "";
+	register char *comma = Blank;
+	register chainp cp, v;
+	chainp sentinel, values, v1;
+	ftnint L, L1, dL, dloc, loc, loc0;
+	union Constant Const;
+	char imag_buf[50], real_buf[50];
+	int szshort = typesize[TYSHORT];
+	static char typepref[] = {0, 0, TYSHORT, TYLONG, TYREAL, TYDREAL,
+				  TYREAL, TYDREAL, TYLOGICAL, TYCHAR};
+	extern int htype;
+	char *z;
+
+	/* add sentinel */
+	if (iscomm) {
+		L = extsymtab[memno].maxleng;
+		xtype = extsymtab[memno].extype;
+		}
+	else {
+		eqv = &eqvclass[memno];
+		L = eqv->eqvtop - eqv->eqvbottom;
+		xtype = eqv->eqvtype;
+		}
+
+	if (halign && typealign[typepref[xtype]] < typealign[htype])
+		xtype = htype;
+
+	if (xtype != TYCHAR) {
+
+		/* unless the data include a value of the appropriate
+		 * type, we add an extra element in an attempt
+		 * to force correct alignment */
+
+		for(v = *Values;;v = v->nextp) {
+			if (!v) {
+				dtype = typepref[xtype];
+				z = ISREAL(dtype) ? cpstring("0.") : (char *)0;
+				k = typesize[dtype];
+				if (j = L % k)
+					L += k - j;
+				v = mkchain((char *)L,
+					mkchain((char *)dtype,
+						mkchain(z, CHNULL)));
+				*Values = mkchain((char *)v, *Values);
+				L += k;
+				break;
+				}
+			if ((int)((chainp)v->datap)->nextp->datap == xtype)
+				break;
+			}
+		}
+
+	sentinel = mkchain((char *)L, mkchain((char *)TYERROR,CHNULL));
+	*Values = values = revchain(mkchain((char *)sentinel, *Values));
+
+	/* use doublereal fillers only if there are doublereal values */
+
+	k = TYLONG;
+	for(v = values; v; v = v->nextp)
+		if (ONEOF((int)((chainp)v->datap)->nextp->datap,
+				M(TYDREAL)|M(TYDCOMPLEX))) {
+			k = TYDREAL;
+			break;
+			}
+	type_choice[0] = k;
+
+	nice_printf(outfile, "%sstruct {\n", iscomm ? "" : "static ");
+	next_tab(outfile);
+	loc = loc0 = k = 0;
+	curtype = -1;
+	for(v = values; v; v = v->nextp) {
+		cp = (chainp)v->datap;
+		dloc = (ftnint)cp->datap;
+		L = dloc - loc;
+		if (L < 0) {
+			overlapping();
+			v1 = cp;
+			frchain(&v1);
+			v->datap = 0;
+			continue;
+			}
+		dtype = (int)cp->nextp->datap;
+		if (dtype == TYBLANK) {
+			dtype = TYCHAR;
+			wasblank = 1;
+			}
+		else
+			wasblank = 0;
+		if (curtype != dtype || L > 0) {
+			if (curtype != -1) {
+				L1 = (loc - loc0)/dL;
+				nice_printf(outfile, "%s e_%d%s;\n",
+					typename[curtype], ++k,
+					Len(L1,curtype));
+				}
+			curtype = dtype;
+			loc0 = dloc;
+			}
+		if (L > 0) {
+			if (xtype == TYCHAR)
+				filltype = TYCHAR;
+			else {
+				filltype = L % szshort ? TYCHAR
+						: type_choice[L/szshort % 4];
+				filltype1 = loc % szshort ? TYCHAR
+						: type_choice[loc/szshort % 4];
+				if (typesize[filltype] > typesize[filltype1])
+					filltype = filltype1;
+				}
+			L1 = L / typesize[filltype];
+			nice_printf(outfile, "%s fill_%d[%ld];\n",
+				typename[filltype], ++k, L1);
+			loc = dloc;
+			}
+		if (wasblank) {
+			loc += (ftnint)cp->nextp->nextp->datap;
+			dL = 1;
+			}
+		else {
+			dL = typesize[dtype];
+			loc += dL;
+			}
+		}
+	nice_printf(outfile, "} %s = { ", iscomm
+		? extsymtab[memno].cextname
+		: equiv_name(eqvmemno, CNULL));
+	loc = 0;
+	for(v = values; ; v = v->nextp) {
+		cp = (chainp)v->datap;
+		if (!cp)
+			continue;
+		dtype = (int)cp->nextp->datap;
+		if (dtype == TYERROR)
+			break;
+		dloc = (ftnint)cp->datap;
+		if (dloc > loc) {
+			nice_printf(outfile, "%s{0}", comma);
+			comma = ", ";
+			loc = dloc;
+			}
+		if (comma != Blank)
+			nice_printf(outfile, ", ");
+		comma = ", ";
+		if (dtype == TYCHAR || dtype == TYBLANK) {
+			v =  Ansi == 1  ? Ado_string(outfile, v, &loc)
+					:  do_string(outfile, v, &loc);
+			continue;
+			}
+		make_one_const(dtype, &Const, v);
+		switch(dtype) {
+			case TYLOGICAL:
+				if (Const.ci < 0 || Const.ci > 1)
+					errl(
+			  "wr_equiv_init: unexpected logical value %ld",
+						Const.ci);
+				nice_printf(outfile,
+					Const.ci ? "TRUE_" : "FALSE_");
+				break;
+			case TYSHORT:
+			case TYLONG:
+				nice_printf(outfile, "%ld", Const.ci);
+				break;
+			case TYREAL:
+				nice_printf(outfile, "%s",
+					flconst(real_buf, Const.cds[0]));
+				break;
+			case TYDREAL:
+				nice_printf(outfile, "%s", Const.cds[0]);
+				break;
+			case TYCOMPLEX:
+				nice_printf(outfile, "%s, %s",
+					flconst(real_buf, Const.cds[0]),
+					flconst(imag_buf, Const.cds[1]));
+				break;
+			case TYDCOMPLEX:
+				nice_printf(outfile, "%s, %s",
+					Const.cds[0], Const.cds[1]);
+				break;
+			default:
+				erri("unexpected type %d in wr_equiv_init",
+					dtype);
+			}
+		loc += typesize[dtype];
+		}
+	nice_printf(outfile, " };\n\n");
+	prev_tab(outfile);
+	frchain(&sentinel);
+	}

+ 39 - 0
lang/fortran/comp/ftypes.h

@@ -0,0 +1,39 @@
+
+/* variable types (stored in the   vtype  field of   expptr)
+ * numeric assumptions:
+ *	int < reals < complexes
+ *	TYDREAL-TYREAL = TYDCOMPLEX-TYCOMPLEX
+ */
+
+#define TYUNKNOWN 0
+#define TYADDR 1
+#define TYSHORT 2
+#define TYLONG 3
+#define TYREAL 4
+#define TYDREAL 5
+#define TYCOMPLEX 6
+#define TYDCOMPLEX 7
+#define TYLOGICAL 8
+#define TYCHAR 9
+#define TYSUBR 10
+#define TYERROR 11
+#define TYCILIST 12
+#define TYICILIST 13
+#define TYOLIST 14
+#define TYCLLIST 15
+#define TYALIST 16
+#define TYINLIST 17
+#define TYVOID 18
+#define TYLABEL 19
+#define TYFTNLEN 20
+/* TYVOID is not in any tables. */
+
+/* NTYPES, NTYPES0 -- Total number of types, used to allocate tables indexed by
+   type.  Such tables can include the size (in bytes) of objects of a given
+   type, or labels for returning objects of different types from procedures
+   (see array   rtvlabels)   */
+
+#define NTYPES TYVOID
+#define NTYPES0 TYCILIST
+#define TYBLANK TYSUBR		/* Huh? */
+

+ 399 - 0
lang/fortran/comp/gram.dcl

@@ -0,0 +1,399 @@
+spec:	  dcl
+	| common
+	| external
+	| intrinsic
+	| equivalence
+	| data
+	| implicit
+	| namelist
+	| SSAVE
+		{ NO66("SAVE statement");
+		  saveall = YES; }
+	| SSAVE savelist
+		{ NO66("SAVE statement"); }
+	| SFORMAT
+		{ fmtstmt(thislabel); setfmt(thislabel); }
+	| SPARAM in_dcl SLPAR paramlist SRPAR
+		{ NO66("PARAMETER statement"); }
+	;
+
+dcl:	  type opt_comma name in_dcl new_dcl dims lengspec
+		{ settype($3, $1, $7);
+		  if(ndim>0) setbound($3,ndim,dims);
+		}
+	| dcl SCOMMA name dims lengspec
+		{ settype($3, $1, $5);
+		  if(ndim>0) setbound($3,ndim,dims);
+		}
+	| dcl SSLASHD datainit vallist SSLASHD
+		{ if (new_dcl == 2) {
+			err("attempt to give DATA in type-declaration");
+			new_dcl = 1;
+			}
+		}
+	;
+
+new_dcl:	{ new_dcl = 2; }
+
+type:	  typespec lengspec
+		{ varleng = $2;
+		  if (vartype == TYLOGICAL && varleng == 1) {
+			varleng = 0;
+			err("treating LOGICAL*1 as LOGICAL");
+			--nerr;	/* allow generation of .c file */
+			}
+		}
+	;
+
+typespec:  typename
+		{ varleng = ($1<0 || $1==TYLONG ? 0 : typesize[$1]);
+		  vartype = $1; }
+	;
+
+typename:    SINTEGER	{ $$ = TYLONG; }
+	| SREAL		{ $$ = tyreal; }
+	| SCOMPLEX	{ ++complex_seen; $$ = tycomplex; }
+	| SDOUBLE	{ $$ = TYDREAL; }
+	| SDCOMPLEX	{ ++dcomplex_seen; NOEXT("DOUBLE COMPLEX statement"); $$ = TYDCOMPLEX; }
+	| SLOGICAL	{ $$ = TYLOGICAL; }
+	| SCHARACTER	{ NO66("CHARACTER statement"); $$ = TYCHAR; }
+	| SUNDEFINED	{ $$ = TYUNKNOWN; }
+	| SDIMENSION	{ $$ = TYUNKNOWN; }
+	| SAUTOMATIC	{ NOEXT("AUTOMATIC statement"); $$ = - STGAUTO; }
+	| SSTATIC	{ NOEXT("STATIC statement"); $$ = - STGBSS; }
+	;
+
+lengspec:
+		{ $$ = varleng; }
+	| SSTAR intonlyon expr intonlyoff
+		{
+		expptr p;
+		p = $3;
+		NO66("length specification *n");
+		if( ! ISICON(p) || p->constblock.Const.ci <= 0 )
+			{
+			$$ = 0;
+			dclerr("length must be a positive integer constant",
+				NPNULL);
+			}
+		else {
+			if (vartype == TYCHAR)
+				$$ = p->constblock.Const.ci;
+			else switch((int)p->constblock.Const.ci) {
+				case 1:	$$ = 1; break;
+				case 2: $$ = typesize[TYSHORT];	break;
+				case 4: $$ = typesize[TYLONG];	break;
+				case 8: $$ = typesize[TYDREAL];	break;
+				case 16: $$ = typesize[TYDCOMPLEX]; break;
+				default:
+					dclerr("invalid length",NPNULL);
+					$$ = varleng;
+				}
+			}
+		}
+	| SSTAR intonlyon SLPAR SSTAR SRPAR intonlyoff
+		{ NO66("length specification *(*)"); $$ = -1; }
+	;
+
+common:	  SCOMMON in_dcl var
+		{ incomm( $$ = comblock("") , $3 ); }
+	| SCOMMON in_dcl comblock var
+		{ $$ = $3;  incomm($3, $4); }
+	| common opt_comma comblock opt_comma var
+		{ $$ = $3;  incomm($3, $5); }
+	| common SCOMMA var
+		{ incomm($1, $3); }
+	;
+
+comblock:  SCONCAT
+		{ $$ = comblock(""); }
+	| SSLASH SNAME SSLASH
+		{ $$ = comblock(token); }
+	;
+
+external: SEXTERNAL in_dcl name
+		{ setext($3); }
+	| external SCOMMA name
+		{ setext($3); }
+	;
+
+intrinsic:  SINTRINSIC in_dcl name
+		{ NO66("INTRINSIC statement"); setintr($3); }
+	| intrinsic SCOMMA name
+		{ setintr($3); }
+	;
+
+equivalence:  SEQUIV in_dcl equivset
+	| equivalence SCOMMA equivset
+	;
+
+equivset:  SLPAR equivlist SRPAR
+		{
+		struct Equivblock *p;
+		if(nequiv >= maxequiv)
+			many("equivalences", 'q', maxequiv);
+		p  =  & eqvclass[nequiv++];
+		p->eqvinit = NO;
+		p->eqvbottom = 0;
+		p->eqvtop = 0;
+		p->equivs = $2;
+		}
+	;
+
+equivlist:  lhs
+		{ $$=ALLOC(Eqvchain);
+		  $$->eqvitem.eqvlhs = (struct Primblock *)$1;
+		}
+	| equivlist SCOMMA lhs
+		{ $$=ALLOC(Eqvchain);
+		  $$->eqvitem.eqvlhs = (struct Primblock *) $3;
+		  $$->eqvnextp = $1;
+		}
+	;
+
+data:	  SDATA in_data datalist
+	| data opt_comma datalist
+	;
+
+in_data:
+		{ if(parstate == OUTSIDE)
+			{
+			newproc();
+			startproc(ESNULL, CLMAIN);
+			}
+		  if(parstate < INDATA)
+			{
+			enddcl();
+			parstate = INDATA;
+			datagripe = 1;
+			}
+		}
+	;
+
+datalist:  datainit datavarlist SSLASH datapop vallist SSLASH
+		{ ftnint junk;
+		  if(nextdata(&junk) != NULL)
+			err("too few initializers");
+		  frdata($2);
+		  frrpl();
+		}
+	;
+
+datainit: /* nothing */ { frchain(&datastack); curdtp = 0; }
+
+datapop: /* nothing */ { pop_datastack(); }
+
+vallist:  { toomanyinit = NO; }  val
+	| vallist SCOMMA val
+	;
+
+val:	  value
+		{ dataval(ENULL, $1); }
+	| simple SSTAR value
+		{ dataval($1, $3); }
+	;
+
+value:	  simple
+	| addop simple
+		{ if( $1==OPMINUS && ISCONST($2) )
+			consnegop((Constp)$2);
+		  $$ = $2;
+		}
+	| complex_const
+	;
+
+savelist: saveitem
+	| savelist SCOMMA saveitem
+	;
+
+saveitem: name
+		{ int k;
+		  $1->vsave = YES;
+		  k = $1->vstg;
+		if( ! ONEOF(k, M(STGUNKNOWN)|M(STGBSS)|M(STGINIT)) )
+			dclerr("can only save static variables", $1);
+		}
+	| comblock
+	;
+
+paramlist:  paramitem
+	| paramlist SCOMMA paramitem
+	;
+
+paramitem:  name SEQUALS expr
+		{ if($1->vclass == CLUNKNOWN)
+			make_param((struct Paramblock *)$1, $3);
+		  else dclerr("cannot make into parameter", $1);
+		}
+	;
+
+var:	  name dims
+		{ if(ndim>0) setbound($1, ndim, dims); }
+	;
+
+datavar:	  lhs
+		{ Namep np;
+		  np = ( (struct Primblock *) $1) -> namep;
+		  vardcl(np);
+		  if(np->vstg == STGCOMMON)
+			extsymtab[np->vardesc.varno].extinit = YES;
+		  else if(np->vstg==STGEQUIV)
+			eqvclass[np->vardesc.varno].eqvinit = YES;
+		  else if(np->vstg!=STGINIT && np->vstg!=STGBSS)
+			dclerr("inconsistent storage classes", np);
+		  $$ = mkchain((char *)$1, CHNULL);
+		}
+	| SLPAR datavarlist SCOMMA dospec SRPAR
+		{ chainp p; struct Impldoblock *q;
+		pop_datastack();
+		q = ALLOC(Impldoblock);
+		q->tag = TIMPLDO;
+		(q->varnp = (Namep) ($4->datap))->vimpldovar = 1;
+		p = $4->nextp;
+		if(p)  { q->implb = (expptr)(p->datap); p = p->nextp; }
+		if(p)  { q->impub = (expptr)(p->datap); p = p->nextp; }
+		if(p)  { q->impstep = (expptr)(p->datap); }
+		frchain( & ($4) );
+		$$ = mkchain((char *)q, CHNULL);
+		q->datalist = hookup($2, $$);
+		}
+	;
+
+datavarlist: datavar
+		{ if (!datastack)
+			curdtp = 0;
+		  datastack = mkchain((char *)curdtp, datastack);
+		  curdtp = $1; curdtelt = 0;
+		  }
+	| datavarlist SCOMMA datavar
+		{ $$ = hookup($1, $3); }
+	;
+
+dims:
+		{ ndim = 0; }
+	| SLPAR dimlist SRPAR
+	;
+
+dimlist:   { ndim = 0; }   dim
+	| dimlist SCOMMA dim
+	;
+
+dim:	  ubound
+		{
+		  if(ndim == maxdim)
+			err("too many dimensions");
+		  else if(ndim < maxdim)
+			{ dims[ndim].lb = 0;
+			  dims[ndim].ub = $1;
+			}
+		  ++ndim;
+		}
+	| expr SCOLON ubound
+		{
+		  if(ndim == maxdim)
+			err("too many dimensions");
+		  else if(ndim < maxdim)
+			{ dims[ndim].lb = $1;
+			  dims[ndim].ub = $3;
+			}
+		  ++ndim;
+		}
+	;
+
+ubound:	  SSTAR
+		{ $$ = 0; }
+	| expr
+	;
+
+labellist: label
+		{ nstars = 1; labarray[0] = $1; }
+	| labellist SCOMMA label
+		{ if(nstars < MAXLABLIST)  labarray[nstars++] = $3; }
+	;
+
+label:	  SICON
+		{ $$ = execlab( convci(toklen, token) ); }
+	;
+
+implicit:  SIMPLICIT in_dcl implist
+		{ NO66("IMPLICIT statement"); }
+	| implicit SCOMMA implist
+	;
+
+implist:  imptype SLPAR letgroups SRPAR
+	| imptype
+		{ if (vartype != TYUNKNOWN)
+			dclerr("-- expected letter range",NPNULL);
+		  setimpl(vartype, varleng, 'a', 'z'); }
+	;
+
+imptype:   { needkwd = 1; } type
+		/* { vartype = $2; } */
+	;
+
+letgroups: letgroup
+	| letgroups SCOMMA letgroup
+	;
+
+letgroup:  letter
+		{ setimpl(vartype, varleng, $1, $1); }
+	| letter SMINUS letter
+		{ setimpl(vartype, varleng, $1, $3); }
+	;
+
+letter:  SNAME
+		{ if(toklen!=1 || token[0]<'a' || token[0]>'z')
+			{
+			dclerr("implicit item must be single letter", NPNULL);
+			$$ = 0;
+			}
+		  else $$ = token[0];
+		}
+	;
+
+namelist:	SNAMELIST
+	| namelist namelistentry
+	;
+
+namelistentry:  SSLASH name SSLASH namelistlist
+		{
+		if($2->vclass == CLUNKNOWN)
+			{
+			$2->vclass = CLNAMELIST;
+			$2->vtype = TYINT;
+			$2->vstg = STGBSS;
+			$2->varxptr.namelist = $4;
+			$2->vardesc.varno = ++lastvarno;
+			}
+		else dclerr("cannot be a namelist name", $2);
+		}
+	;
+
+namelistlist:  name
+		{ $$ = mkchain((char *)$1, CHNULL); }
+	| namelistlist SCOMMA name
+		{ $$ = hookup($1, mkchain((char *)$3, CHNULL)); }
+	;
+
+in_dcl:
+		{ switch(parstate)
+			{
+			case OUTSIDE:	newproc();
+					startproc(ESNULL, CLMAIN);
+			case INSIDE:	parstate = INDCL;
+			case INDCL:	break;
+
+			case INDATA:
+				if (datagripe) {
+					errstr(
+				"Statement order error: declaration after DATA",
+						CNULL);
+					datagripe = 0;
+					}
+				break;
+
+			default:
+				dclerr("declaration among executables", NPNULL);
+			}
+		}
+	;

+ 143 - 0
lang/fortran/comp/gram.exec

@@ -0,0 +1,143 @@
+exec:	  iffable
+	| SDO end_spec intonlyon label intonlyoff opt_comma dospecw
+		{
+		if($4->labdefined)
+			execerr("no backward DO loops", CNULL);
+		$4->blklevel = blklevel+1;
+		exdo($4->labelno, NPNULL, $7);
+		}
+	| SDO end_spec opt_comma dospecw
+		{
+		exdo((int)(ctls - ctlstack - 2), NPNULL, $4);
+		NOEXT("DO without label");
+		}
+	| SENDDO
+		{ exenddo(NPNULL); }
+	| logif iffable
+		{ exendif();  thiswasbranch = NO; }
+	| logif STHEN
+	| SELSEIF end_spec SLPAR expr SRPAR STHEN
+		{ exelif($4); lastwasbranch = NO; }
+	| SELSE end_spec
+		{ exelse(); lastwasbranch = NO; }
+	| SENDIF end_spec
+		{ exendif(); lastwasbranch = NO; }
+	;
+
+logif:	  SLOGIF end_spec SLPAR expr SRPAR
+		{ exif($4); }
+	;
+
+dospec:	  name SEQUALS exprlist
+		{ $$ = mkchain((char *)$1, $3); }
+	;
+
+dospecw:  dospec
+	| SWHILE SLPAR expr SRPAR
+		{ $$ = mkchain(CNULL, (chainp)$3); }
+	;
+
+iffable:  let lhs SEQUALS expr
+		{ exequals((struct Primblock *)$2, $4); }
+	| SASSIGN end_spec assignlabel STO name
+		{ exassign($5, $3); }
+	| SCONTINUE end_spec
+	| goto
+	| io
+		{ inioctl = NO; }
+	| SARITHIF end_spec SLPAR expr SRPAR label SCOMMA label SCOMMA label
+		{ exarif($4, $6, $8, $10);  thiswasbranch = YES; }
+	| call
+		{ excall($1, LBNULL, 0, labarray); }
+	| call SLPAR SRPAR
+		{ excall($1, LBNULL, 0, labarray); }
+	| call SLPAR callarglist SRPAR
+		{ if(nstars < MAXLABLIST)
+			excall($1, mklist(revchain($3)), nstars, labarray);
+		  else
+			err("too many alternate returns");
+		}
+	| SRETURN end_spec opt_expr
+		{ exreturn($3);  thiswasbranch = YES; }
+	| stop end_spec opt_expr
+		{ exstop($1, $3);  thiswasbranch = $1; }
+	;
+
+assignlabel:   SICON
+		{ $$ = mklabel( convci(toklen, token) ); }
+	;
+
+let:	  SLET
+		{ if(parstate == OUTSIDE)
+			{
+			newproc();
+			startproc(ESNULL, CLMAIN);
+			}
+		}
+	;
+
+goto:	  SGOTO end_spec label
+		{ exgoto($3);  thiswasbranch = YES; }
+	| SASGOTO end_spec name
+		{ exasgoto($3);  thiswasbranch = YES; }
+	| SASGOTO end_spec name opt_comma SLPAR labellist SRPAR
+		{ exasgoto($3);  thiswasbranch = YES; }
+	| SCOMPGOTO end_spec SLPAR labellist SRPAR opt_comma expr
+		{ if(nstars < MAXLABLIST)
+			putcmgo(putx(fixtype($7)), nstars, labarray);
+		  else
+			err("computed GOTO list too long");
+		}
+	;
+
+opt_comma:
+	| SCOMMA
+	;
+
+call:	  SCALL end_spec name
+		{ nstars = 0; $$ = $3; }
+	;
+
+callarglist:  callarg
+		{ $$ = $1 ? mkchain((char *)$1,CHNULL) : CHNULL; }
+	| callarglist SCOMMA callarg
+		{ $$ = $3 ? mkchain((char *)$3, $1) : $1; }
+	;
+
+callarg:  expr
+	| SSTAR label
+		{ if(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; }
+	;

+ 141 - 0
lang/fortran/comp/gram.expr

@@ -0,0 +1,141 @@
+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); }
+	;

+ 299 - 0
lang/fortran/comp/gram.head

@@ -0,0 +1,299 @@
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories, Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+%{
+#	include "defs.h"
+#	include "p1defs.h"
+
+static int nstars;			/* Number of labels in an
+					   alternate return CALL */
+static int datagripe;
+static int ndim;
+static int vartype;
+int new_dcl;
+static ftnint varleng;
+static struct Dims dims[MAXDIM+1];
+static struct Labelblock *labarray[MAXLABLIST];	/* Labels in an alternate
+						   return CALL */
+
+/* The next two variables are used to verify that each statement might be reached
+   during runtime.   lastwasbranch   is tested only in the defintion of the
+   stat:   nonterminal. */
+
+int lastwasbranch = NO;
+static int thiswasbranch = NO;
+extern ftnint yystno;
+extern flag intonly;
+static chainp datastack;
+extern long laststfcn, thisstno;
+extern int can_include;	/* for netlib */
+
+ftnint convci();
+Addrp nextdata();
+expptr mklogcon(), mkaddcon(), mkrealcon(), mkstrcon(), mkbitcon();
+expptr mkcxcon();
+struct Listblock *mklist();
+struct Listblock *mklist();
+struct Impldoblock *mkiodo();
+Extsym *comblock();
+#define ESNULL (Extsym *)0
+#define NPNULL (Namep)0
+#define LBNULL (struct Listblock *)0
+extern void freetemps(), make_param();
+
+ static void
+pop_datastack() {
+	chainp d0 = datastack;
+	if (d0->datap)
+		curdtp = (chainp)d0->datap;
+	datastack = d0->nextp;
+	d0->nextp = 0;
+	frchain(&d0);
+	}
+
+%}
+
+/* Specify precedences and associativities. */
+
+%union	{
+	int ival;
+	ftnint lval;
+	char *charpval;
+	chainp chval;
+	tagptr tagval;
+	expptr expval;
+	struct Labelblock *labval;
+	struct Nameblock *namval;
+	struct Eqvchain *eqvval;
+	Extsym *extval;
+	}
+
+%left SCOMMA
+%nonassoc SCOLON
+%right SEQUALS
+%left SEQV SNEQV
+%left SOR
+%left SAND
+%left SNOT
+%nonassoc SLT SGT SLE SGE SEQ SNE
+%left SCONCAT
+%left SPLUS SMINUS
+%left SSTAR SSLASH
+%right SPOWER
+
+%start program
+%type <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;
+		}
+	;

+ 173 - 0
lang/fortran/comp/gram.io

@@ -0,0 +1,173 @@
+  /*  Input/Output Statements */
+
+io:	  io1
+		{ endio(); }
+	;
+
+io1:	  iofmove ioctl
+	| iofmove unpar_fexpr
+		{ ioclause(IOSUNIT, $2); endioctl(); }
+	| iofmove SSTAR
+		{ ioclause(IOSUNIT, ENULL); endioctl(); }
+	| iofmove SPOWER
+		{ ioclause(IOSUNIT, IOSTDERR); endioctl(); }
+	| iofctl ioctl
+	| read ioctl
+		{ doio(CHNULL); }
+	| read infmt
+		{ doio(CHNULL); }
+	| read ioctl inlist
+		{ doio(revchain($3)); }
+	| read infmt SCOMMA inlist
+		{ doio(revchain($4)); }
+	| read ioctl SCOMMA inlist
+		{ doio(revchain($4)); }
+	| write ioctl
+		{ doio(CHNULL); }
+	| write ioctl outlist
+		{ doio(revchain($3)); }
+	| print
+		{ doio(CHNULL); }
+	| print SCOMMA outlist
+		{ doio(revchain($3)); }
+	;
+
+iofmove:   fmkwd end_spec in_ioctl
+	;
+
+fmkwd:	  SBACKSPACE
+		{ iostmt = IOBACKSPACE; }
+	| SREWIND
+		{ iostmt = IOREWIND; }
+	| SENDFILE
+		{ iostmt = IOENDFILE; }
+	;
+
+iofctl:  ctlkwd end_spec in_ioctl
+	;
+
+ctlkwd:	  SINQUIRE
+		{ iostmt = IOINQUIRE; }
+	| SOPEN
+		{ iostmt = IOOPEN; }
+	| SCLOSE
+		{ iostmt = IOCLOSE; }
+	;
+
+infmt:	  unpar_fexpr
+		{
+		ioclause(IOSUNIT, ENULL);
+		ioclause(IOSFMT, $1);
+		endioctl();
+		}
+	| SSTAR
+		{
+		ioclause(IOSUNIT, ENULL);
+		ioclause(IOSFMT, ENULL);
+		endioctl();
+		}
+	;
+
+ioctl:	  SLPAR fexpr SRPAR
+		{
+		  ioclause(IOSUNIT, $2);
+		  endioctl();
+		}
+	| SLPAR ctllist SRPAR
+		{ endioctl(); }
+	;
+
+ctllist:  ioclause
+	| ctllist SCOMMA ioclause
+	;
+
+ioclause:  fexpr
+		{ ioclause(IOSPOSITIONAL, $1); }
+	| SSTAR
+		{ ioclause(IOSPOSITIONAL, ENULL); }
+	| SPOWER
+		{ ioclause(IOSPOSITIONAL, IOSTDERR); }
+	| nameeq expr
+		{ ioclause($1, $2); }
+	| nameeq SSTAR
+		{ ioclause($1, ENULL); }
+	| nameeq SPOWER
+		{ ioclause($1, IOSTDERR); }
+	;
+
+nameeq:  SNAMEEQ
+		{ $$ = iocname(); }
+	;
+
+read:	  SREAD end_spec in_ioctl
+		{ iostmt = IOREAD; }
+	;
+
+write:	  SWRITE end_spec in_ioctl
+		{ iostmt = IOWRITE; }
+	;
+
+print:	  SPRINT end_spec fexpr in_ioctl
+		{
+		iostmt = IOWRITE;
+		ioclause(IOSUNIT, ENULL);
+		ioclause(IOSFMT, $3);
+		endioctl();
+		}
+	| SPRINT end_spec SSTAR in_ioctl
+		{
+		iostmt = IOWRITE;
+		ioclause(IOSUNIT, ENULL);
+		ioclause(IOSFMT, ENULL);
+		endioctl();
+		}
+	;
+
+inlist:	  inelt
+		{ $$ = mkchain((char *)$1, CHNULL); }
+	| inlist SCOMMA inelt
+		{ $$ = mkchain((char *)$3, $1); }
+	;
+
+inelt:	  lhs
+		{ $$ = (tagptr) $1; }
+	| SLPAR inlist SCOMMA dospec SRPAR
+		{ $$ = (tagptr) mkiodo($4,revchain($2)); }
+	;
+
+outlist:  uexpr
+		{ $$ = mkchain((char *)$1, CHNULL); }
+	| other
+		{ $$ = mkchain((char *)$1, CHNULL); }
+	| out2
+	;
+
+out2:	  uexpr SCOMMA uexpr
+		{ $$ = mkchain((char *)$3, mkchain((char *)$1, CHNULL) ); }
+	| uexpr SCOMMA other
+		{ $$ = mkchain((char *)$3, mkchain((char *)$1, CHNULL) ); }
+	| other SCOMMA uexpr
+		{ $$ = mkchain((char *)$3, mkchain((char *)$1, CHNULL) ); }
+	| other SCOMMA other
+		{ $$ = mkchain((char *)$3, mkchain((char *)$1, CHNULL) ); }
+	| out2  SCOMMA uexpr
+		{ $$ = mkchain((char *)$3, $1); }
+	| out2  SCOMMA other
+		{ $$ = mkchain((char *)$3, $1); }
+	;
+
+other:	  complex_const
+		{ $$ = (tagptr) $1; }
+	| SLPAR expr SRPAR
+		{ $$ = (tagptr) $2; }
+	| SLPAR uexpr SCOMMA dospec SRPAR
+		{ $$ = (tagptr) mkiodo($4, mkchain((char *)$2, CHNULL) ); }
+	| SLPAR other SCOMMA dospec SRPAR
+		{ $$ = (tagptr) mkiodo($4, mkchain((char *)$2, CHNULL) ); }
+	| SLPAR out2  SCOMMA dospec SRPAR
+		{ $$ = (tagptr) mkiodo($4, revchain($2)); }
+	;
+
+in_ioctl:
+		{ startioctl(); }
+	;

+ 446 - 0
lang/fortran/comp/init.c

@@ -0,0 +1,446 @@
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+#include "defs.h"
+#include "output.h"
+#include "iob.h"
+
+/* State required for the C output */
+char *fl_fmt_string;		/* Float format string */
+char *db_fmt_string;	    	/* Double format string */
+char *cm_fmt_string;		/* Complex format string */
+char *dcm_fmt_string;		/* Double complex format string */
+
+chainp new_vars = CHNULL;	/* List of newly created locals in this
+				   function.  These may have identifiers
+				   which have underscores and more than VL
+				   characters */
+chainp used_builtins = CHNULL;	/* List of builtins used by this function.
+				   These are all Addrps with UNAM_EXTERN
+				   */
+chainp assigned_fmts = CHNULL;	/* assigned formats */
+chainp allargs;			/* union of args in all entry points */
+chainp earlylabs;		/* labels seen before enddcl() */
+char main_alias[52];		/* PROGRAM name, if any is given */
+int tab_size = 4;
+
+
+FILEP infile;
+FILEP diagfile;
+
+FILEP c_file;
+FILEP pass1_file;
+FILEP initfile;
+FILEP blkdfile;
+
+
+char token[MAXTOKENLEN];
+int toklen;
+long lineno;			/* Current line in the input file, NOT the
+				   Fortran statement label number */
+char *infname;
+int needkwd;
+struct Labelblock *thislabel	= NULL;
+int nerr;
+int nwarn;
+
+flag saveall;
+flag substars;
+int parstate	= OUTSIDE;
+flag headerdone	= NO;
+int blklevel;
+int doin_setbound;
+int impltype[26];
+ftnint implleng[26];
+int implstg[26];
+
+int tyint	= TYLONG ;
+int tylogical	= TYLONG;
+int typesize[NTYPES] = {
+	1, SZADDR, SZSHORT, SZLONG, SZLONG, 2*SZLONG,
+	    2*SZLONG, 4*SZLONG, SZLONG, 1, 1, 0,
+		4*SZLONG + SZADDR,	/* sizeof(cilist) */
+		4*SZLONG + 2*SZADDR,	/* sizeof(icilist) */
+		4*SZLONG + 5*SZADDR,	/* sizeof(olist) */
+		2*SZLONG + SZADDR,	/* sizeof(cllist) */
+		2*SZLONG,		/* sizeof(alist) */
+		11*SZLONG + 15*SZADDR	/* sizeof(inlist) */
+		};
+
+int typealign[NTYPES] = {
+	1, ALIADDR, ALISHORT, ALILONG, ALILONG, ALIDOUBLE,
+	ALILONG, ALIDOUBLE, ALILONG, 1, 1, 1,
+	ALILONG, ALILONG, ALILONG, ALILONG, ALILONG, ALILONG};
+
+int type_choice[4] = { TYDREAL, TYSHORT, TYLONG,  TYSHORT };
+
+char *typename[] = {
+	"<<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;
+				}
+			}
+		}
+	}

+ 846 - 0
lang/fortran/comp/intr.c

@@ -0,0 +1,846 @@
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+#include "defs.h"
+#include "names.h"
+
+void cast_args ();
+
+union
+	{
+	int ijunk;
+	struct Intrpacked bits;
+	} packed;
+
+struct Intrbits
+	{
+	char intrgroup /* :3 */;
+	char intrstuff /* result type or number of generics */;
+	char intrno /* :7 */;
+	char dblcmplx;
+	char dblintrno;	/* for -r8 */
+	};
+
+/* List of all intrinsic functions.  */
+
+LOCAL struct Intrblock
+	{
+	char intrfname[8];
+	struct Intrbits intrval;
+	} intrtab[ ] =
+{
+"int", 		{ INTRCONV, TYLONG },
+"real", 	{ INTRCONV, TYREAL, 1 },
+		/* 1 ==> real(TYDCOMPLEX) yields TYDREAL */
+"dble", 	{ INTRCONV, TYDREAL },
+"cmplx", 	{ INTRCONV, TYCOMPLEX },
+"dcmplx", 	{ INTRCONV, TYDCOMPLEX, 0, 1 },
+"ifix", 	{ INTRCONV, TYLONG },
+"idint", 	{ INTRCONV, TYLONG },
+"float", 	{ INTRCONV, TYREAL },
+"dfloat",	{ INTRCONV, TYDREAL },
+"sngl", 	{ INTRCONV, TYREAL },
+"ichar", 	{ INTRCONV, TYLONG },
+"iachar", 	{ INTRCONV, TYLONG },
+"char", 	{ INTRCONV, TYCHAR },
+"achar", 	{ INTRCONV, TYCHAR },
+
+/* any MAX or MIN can be used with any types; the compiler will cast them
+   correctly.  So rules against bad syntax in these expressions are not
+   enforced */
+
+"max", 		{ INTRMAX, TYUNKNOWN },
+"max0", 	{ INTRMAX, TYLONG },
+"amax0", 	{ INTRMAX, TYREAL },
+"max1", 	{ INTRMAX, TYLONG },
+"amax1", 	{ INTRMAX, TYREAL },
+"dmax1", 	{ INTRMAX, TYDREAL },
+
+"and",		{ INTRBOOL, TYUNKNOWN, OPBITAND },
+"or",		{ INTRBOOL, TYUNKNOWN, OPBITOR },
+"xor",		{ INTRBOOL, TYUNKNOWN, OPBITXOR },
+"not",		{ INTRBOOL, TYUNKNOWN, OPBITNOT },
+"lshift",	{ INTRBOOL, TYUNKNOWN, OPLSHIFT },
+"rshift",	{ INTRBOOL, TYUNKNOWN, OPRSHIFT },
+
+"min", 		{ INTRMIN, TYUNKNOWN },
+"min0", 	{ INTRMIN, TYLONG },
+"amin0", 	{ INTRMIN, TYREAL },
+"min1", 	{ INTRMIN, TYLONG },
+"amin1", 	{ INTRMIN, TYREAL },
+"dmin1", 	{ INTRMIN, TYDREAL },
+
+"aint", 	{ INTRGEN, 2, 0 },
+"dint", 	{ INTRSPEC, TYDREAL, 1 },
+
+"anint", 	{ INTRGEN, 2, 2 },
+"dnint", 	{ INTRSPEC, TYDREAL, 3 },
+
+"nint", 	{ INTRGEN, 4, 4 },
+"idnint", 	{ INTRGEN, 2, 6 },
+
+"abs", 		{ INTRGEN, 6, 8 },
+"iabs", 	{ INTRGEN, 2, 9 },
+"dabs", 	{ INTRSPEC, TYDREAL, 11 },
+"cabs", 	{ INTRSPEC, TYREAL, 12, 0, 13 },
+"zabs", 	{ INTRSPEC, TYDREAL, 13, 1 },
+
+"mod", 		{ INTRGEN, 4, 14 },
+"amod", 	{ INTRSPEC, TYREAL, 16, 0, 17 },
+"dmod", 	{ INTRSPEC, TYDREAL, 17 },
+
+"sign", 	{ INTRGEN, 4, 18 },
+"isign", 	{ INTRGEN, 2, 19 },
+"dsign", 	{ INTRSPEC, TYDREAL, 21 },
+
+"dim", 		{ INTRGEN, 4, 22 },
+"idim", 	{ INTRGEN, 2, 23 },
+"ddim", 	{ INTRSPEC, TYDREAL, 25 },
+
+"dprod", 	{ INTRSPEC, TYDREAL, 26 },
+
+"len", 		{ INTRSPEC, TYLONG, 27 },
+"index", 	{ INTRSPEC, TYLONG, 29 },
+
+"imag", 	{ INTRGEN, 2, 31 },
+"aimag", 	{ INTRSPEC, TYREAL, 31, 0, 32 },
+"dimag", 	{ INTRSPEC, TYDREAL, 32 },
+
+"conjg", 	{ INTRGEN, 2, 33 },
+"dconjg", 	{ INTRSPEC, TYDCOMPLEX, 34, 1 },
+
+"sqrt", 	{ INTRGEN, 4, 35 },
+"dsqrt", 	{ INTRSPEC, TYDREAL, 36 },
+"csqrt", 	{ INTRSPEC, TYCOMPLEX, 37, 0, 38 },
+"zsqrt", 	{ INTRSPEC, TYDCOMPLEX, 38, 1 },
+
+"exp", 		{ INTRGEN, 4, 39 },
+"dexp", 	{ INTRSPEC, TYDREAL, 40 },
+"cexp", 	{ INTRSPEC, TYCOMPLEX, 41, 0, 42 },
+"zexp", 	{ INTRSPEC, TYDCOMPLEX, 42, 1 },
+
+"log", 		{ INTRGEN, 4, 43 },
+"alog", 	{ INTRSPEC, TYREAL, 43, 0, 44 },
+"dlog", 	{ INTRSPEC, TYDREAL, 44 },
+"clog", 	{ INTRSPEC, TYCOMPLEX, 45, 0, 46 },
+"zlog", 	{ INTRSPEC, TYDCOMPLEX, 46, 1 },
+
+"log10", 	{ INTRGEN, 2, 47 },
+"alog10", 	{ INTRSPEC, TYREAL, 47, 0, 48 },
+"dlog10", 	{ INTRSPEC, TYDREAL, 48 },
+
+"sin", 		{ INTRGEN, 4, 49 },
+"dsin", 	{ INTRSPEC, TYDREAL, 50 },
+"csin", 	{ INTRSPEC, TYCOMPLEX, 51, 0, 52 },
+"zsin", 	{ INTRSPEC, TYDCOMPLEX, 52, 1 },
+
+"cos", 		{ INTRGEN, 4, 53 },
+"dcos", 	{ INTRSPEC, TYDREAL, 54 },
+"ccos", 	{ INTRSPEC, TYCOMPLEX, 55, 0, 56 },
+"zcos", 	{ INTRSPEC, TYDCOMPLEX, 56, 1 },
+
+"tan", 		{ INTRGEN, 2, 57 },
+"dtan", 	{ INTRSPEC, TYDREAL, 58 },
+
+"asin", 	{ INTRGEN, 2, 59 },
+"dasin", 	{ INTRSPEC, TYDREAL, 60 },
+
+"acos", 	{ INTRGEN, 2, 61 },
+"dacos", 	{ INTRSPEC, TYDREAL, 62 },
+
+"atan", 	{ INTRGEN, 2, 63 },
+"datan", 	{ INTRSPEC, TYDREAL, 64 },
+
+"atan2", 	{ INTRGEN, 2, 65 },
+"datan2", 	{ INTRSPEC, TYDREAL, 66 },
+
+"sinh", 	{ INTRGEN, 2, 67 },
+"dsinh", 	{ INTRSPEC, TYDREAL, 68 },
+
+"cosh", 	{ INTRGEN, 2, 69 },
+"dcosh", 	{ INTRSPEC, TYDREAL, 70 },
+
+"tanh", 	{ INTRGEN, 2, 71 },
+"dtanh", 	{ INTRSPEC, TYDREAL, 72 },
+
+"lge",		{ INTRSPEC, TYLOGICAL, 73},
+"lgt",		{ INTRSPEC, TYLOGICAL, 75},
+"lle",		{ INTRSPEC, TYLOGICAL, 77},
+"llt",		{ INTRSPEC, TYLOGICAL, 79},
+
+#if 0
+"epbase",	{ INTRCNST, 4, 0 },
+"epprec",	{ INTRCNST, 4, 4 },
+"epemin",	{ INTRCNST, 2, 8 },
+"epemax",	{ INTRCNST, 2, 10 },
+"eptiny",	{ INTRCNST, 2, 12 },
+"ephuge",	{ INTRCNST, 4, 14 },
+"epmrsp",	{ INTRCNST, 2, 18 },
+#endif
+
+"fpexpn",	{ INTRGEN, 4, 81 },
+"fpabsp",	{ INTRGEN, 2, 85 },
+"fprrsp",	{ INTRGEN, 2, 87 },
+"fpfrac",	{ INTRGEN, 2, 89 },
+"fpmake",	{ INTRGEN, 2, 91 },
+"fpscal",	{ INTRGEN, 2, 93 },
+
+"" };
+
+
+LOCAL struct Specblock
+	{
+	char atype;		/* Argument type; every arg must have
+				   this type */
+	char rtype;		/* Result type */
+	char nargs;		/* Number of arguments */
+	char spxname[8];	/* Name of the function in Fortran */
+	char othername;		/* index into callbyvalue table */
+	} spectab[ ] =
+{
+	{ TYREAL,TYREAL,1,"r_int" },
+	{ TYDREAL,TYDREAL,1,"d_int" },
+
+	{ TYREAL,TYREAL,1,"r_nint" },
+	{ TYDREAL,TYDREAL,1,"d_nint" },
+
+	{ TYREAL,TYSHORT,1,"h_nint" },
+	{ TYREAL,TYLONG,1,"i_nint" },
+
+	{ TYDREAL,TYSHORT,1,"h_dnnt" },
+	{ TYDREAL,TYLONG,1,"i_dnnt" },
+
+	{ TYREAL,TYREAL,1,"r_abs" },
+	{ TYSHORT,TYSHORT,1,"h_abs" },
+	{ TYLONG,TYLONG,1,"i_abs" },
+	{ TYDREAL,TYDREAL,1,"d_abs" },
+	{ TYCOMPLEX,TYREAL,1,"c_abs" },
+	{ TYDCOMPLEX,TYDREAL,1,"z_abs" },
+
+	{ TYSHORT,TYSHORT,2,"h_mod" },
+	{ TYLONG,TYLONG,2,"i_mod" },
+	{ TYREAL,TYREAL,2,"r_mod" },
+	{ TYDREAL,TYDREAL,2,"d_mod" },
+
+	{ TYREAL,TYREAL,2,"r_sign" },
+	{ TYSHORT,TYSHORT,2,"h_sign" },
+	{ TYLONG,TYLONG,2,"i_sign" },
+	{ TYDREAL,TYDREAL,2,"d_sign" },
+
+	{ TYREAL,TYREAL,2,"r_dim" },
+	{ TYSHORT,TYSHORT,2,"h_dim" },
+	{ TYLONG,TYLONG,2,"i_dim" },
+	{ TYDREAL,TYDREAL,2,"d_dim" },
+
+	{ TYREAL,TYDREAL,2,"d_prod" },
+
+	{ TYCHAR,TYSHORT,1,"h_len" },
+	{ TYCHAR,TYLONG,1,"i_len" },
+
+	{ TYCHAR,TYSHORT,2,"h_indx" },
+	{ TYCHAR,TYLONG,2,"i_indx" },
+
+	{ TYCOMPLEX,TYREAL,1,"r_imag" },
+	{ TYDCOMPLEX,TYDREAL,1,"d_imag" },
+	{ TYCOMPLEX,TYCOMPLEX,1,"r_cnjg" },
+	{ TYDCOMPLEX,TYDCOMPLEX,1,"d_cnjg" },
+
+	{ TYREAL,TYREAL,1,"r_sqrt", 1 },
+	{ TYDREAL,TYDREAL,1,"d_sqrt", 1 },
+	{ TYCOMPLEX,TYCOMPLEX,1,"c_sqrt" },
+	{ TYDCOMPLEX,TYDCOMPLEX,1,"z_sqrt" },
+
+	{ TYREAL,TYREAL,1,"r_exp", 2 },
+	{ TYDREAL,TYDREAL,1,"d_exp", 2 },
+	{ TYCOMPLEX,TYCOMPLEX,1,"c_exp" },
+	{ TYDCOMPLEX,TYDCOMPLEX,1,"z_exp" },
+
+	{ TYREAL,TYREAL,1,"r_log", 3 },
+	{ TYDREAL,TYDREAL,1,"d_log", 3 },
+	{ TYCOMPLEX,TYCOMPLEX,1,"c_log" },
+	{ TYDCOMPLEX,TYDCOMPLEX,1,"z_log" },
+
+	{ TYREAL,TYREAL,1,"r_lg10" },
+	{ TYDREAL,TYDREAL,1,"d_lg10" },
+
+	{ TYREAL,TYREAL,1,"r_sin", 4 },
+	{ TYDREAL,TYDREAL,1,"d_sin", 4 },
+	{ TYCOMPLEX,TYCOMPLEX,1,"c_sin" },
+	{ TYDCOMPLEX,TYDCOMPLEX,1,"z_sin" },
+
+	{ TYREAL,TYREAL,1,"r_cos", 5 },
+	{ TYDREAL,TYDREAL,1,"d_cos", 5 },
+	{ TYCOMPLEX,TYCOMPLEX,1,"c_cos" },
+	{ TYDCOMPLEX,TYDCOMPLEX,1,"z_cos" },
+
+	{ TYREAL,TYREAL,1,"r_tan", 6 },
+	{ TYDREAL,TYDREAL,1,"d_tan", 6 },
+
+	{ TYREAL,TYREAL,1,"r_asin", 7 },
+	{ TYDREAL,TYDREAL,1,"d_asin", 7 },
+
+	{ TYREAL,TYREAL,1,"r_acos", 8 },
+	{ TYDREAL,TYDREAL,1,"d_acos", 8 },
+
+	{ TYREAL,TYREAL,1,"r_atan", 9 },
+	{ TYDREAL,TYDREAL,1,"d_atan", 9 },
+
+	{ TYREAL,TYREAL,2,"r_atn2", 10 },
+	{ TYDREAL,TYDREAL,2,"d_atn2", 10 },
+
+	{ TYREAL,TYREAL,1,"r_sinh", 11 },
+	{ TYDREAL,TYDREAL,1,"d_sinh", 11 },
+
+	{ TYREAL,TYREAL,1,"r_cosh", 12 },
+	{ TYDREAL,TYDREAL,1,"d_cosh", 12 },
+
+	{ TYREAL,TYREAL,1,"r_tanh", 13 },
+	{ TYDREAL,TYDREAL,1,"d_tanh", 13 },
+
+	{ TYCHAR,TYLOGICAL,2,"hl_ge" },
+	{ TYCHAR,TYLOGICAL,2,"l_ge" },
+
+	{ TYCHAR,TYLOGICAL,2,"hl_gt" },
+	{ TYCHAR,TYLOGICAL,2,"l_gt" },
+
+	{ TYCHAR,TYLOGICAL,2,"hl_le" },
+	{ TYCHAR,TYLOGICAL,2,"l_le" },
+
+	{ TYCHAR,TYLOGICAL,2,"hl_lt" },
+	{ TYCHAR,TYLOGICAL,2,"l_lt" },
+
+	{ TYREAL,TYSHORT,1,"hr_expn" },
+	{ TYREAL,TYLONG,1,"ir_expn" },
+	{ TYDREAL,TYSHORT,1,"hd_expn" },
+	{ TYDREAL,TYLONG,1,"id_expn" },
+
+	{ TYREAL,TYREAL,1,"r_absp" },
+	{ TYDREAL,TYDREAL,1,"d_absp" },
+
+	{ TYREAL,TYDREAL,1,"r_rrsp" },
+	{ TYDREAL,TYDREAL,1,"d_rrsp" },
+
+	{ TYREAL,TYREAL,1,"r_frac" },
+	{ TYDREAL,TYDREAL,1,"d_frac" },
+
+	{ TYREAL,TYREAL,2,"r_make" },
+	{ TYDREAL,TYDREAL,2,"d_make" },
+
+	{ TYREAL,TYREAL,2,"r_scal" },
+	{ TYDREAL,TYDREAL,2,"d_scal" },
+	{ 0 }
+} ;
+
+#if 0
+LOCAL struct Incstblock
+	{
+	char atype;
+	char rtype;
+	char constno;
+	} consttab[ ] =
+{
+	{ TYSHORT, TYLONG, 0 },
+	{ TYLONG, TYLONG, 1 },
+	{ TYREAL, TYLONG, 2 },
+	{ TYDREAL, TYLONG, 3 },
+
+	{ TYSHORT, TYLONG, 4 },
+	{ TYLONG, TYLONG, 5 },
+	{ TYREAL, TYLONG, 6 },
+	{ TYDREAL, TYLONG, 7 },
+
+	{ TYREAL, TYLONG, 8 },
+	{ TYDREAL, TYLONG, 9 },
+
+	{ TYREAL, TYLONG, 10 },
+	{ TYDREAL, TYLONG, 11 },
+
+	{ TYREAL, TYREAL, 0 },
+	{ TYDREAL, TYDREAL, 1 },
+
+	{ TYSHORT, TYLONG, 12 },
+	{ TYLONG, TYLONG, 13 },
+	{ TYREAL, TYREAL, 2 },
+	{ TYDREAL, TYDREAL, 3 },
+
+	{ TYREAL, TYREAL, 4 },
+	{ TYDREAL, TYDREAL, 5 }
+};
+#endif
+
+char *callbyvalue[ ] =
+	{0,
+	"sqrt",
+	"exp",
+	"log",
+	"sin",
+	"cos",
+	"tan",
+	"asin",
+	"acos",
+	"atan",
+	"atan2",
+	"sinh",
+	"cosh",
+	"tanh"
+	};
+
+ void
+r8fix()	/* adjust tables for -r8 */
+{
+	register struct Intrblock *I;
+	register struct Specblock *S;
+
+	for(I = intrtab; I->intrfname[0]; I++)
+		if (I->intrval.intrgroup != INTRGEN)
+		    switch(I->intrval.intrstuff) {
+			case TYREAL:
+				I->intrval.intrstuff = TYDREAL;
+				I->intrval.intrno = I->intrval.dblintrno;
+				break;
+			case TYCOMPLEX:
+				I->intrval.intrstuff = TYDCOMPLEX;
+				I->intrval.intrno = I->intrval.dblintrno;
+				I->intrval.dblcmplx = 1;
+			}
+
+	for(S = spectab; S->atype; S++)
+	    switch(S->atype) {
+		case TYCOMPLEX:
+			S->atype = TYDCOMPLEX;
+			if (S->rtype == TYREAL)
+				S->rtype = TYDREAL;
+			else if (S->rtype == TYCOMPLEX)
+				S->rtype = TYDCOMPLEX;
+			switch(S->spxname[0]) {
+				case 'r':
+					S->spxname[0] = 'd';
+					break;
+				case 'c':
+					S->spxname[0] = 'z';
+					break;
+				default:
+					Fatal("r8fix bug");
+				}
+			break;
+		case TYREAL:
+			S->atype = TYDREAL;
+			switch(S->rtype) {
+			    case TYREAL:
+				S->rtype = TYDREAL;
+				if (S->spxname[0] != 'r')
+					Fatal("r8fix bug");
+				S->spxname[0] = 'd';
+			    case TYDREAL:	/* d_prod */
+				break;
+
+			    case TYSHORT:
+				if (!strcmp(S->spxname, "hr_expn"))
+					S->spxname[1] = 'd';
+				else if (!strcmp(S->spxname, "h_nint"))
+					strcpy(S->spxname, "h_dnnt");
+				else Fatal("r8fix bug");
+				break;
+
+			    case TYLONG:
+				if (!strcmp(S->spxname, "ir_expn"))
+					S->spxname[1] = 'd';
+				else if (!strcmp(S->spxname, "i_nint"))
+					strcpy(S->spxname, "i_dnnt");
+				else Fatal("r8fix bug");
+				break;
+
+			    default:
+				Fatal("r8fix bug");
+			    }
+		}
+	}
+
+expptr intrcall(np, argsp, nargs)
+Namep np;
+struct Listblock *argsp;
+int nargs;
+{
+	int i, rettype;
+	Addrp ap;
+	register struct Specblock *sp;
+	register struct Chain *cp;
+	expptr Inline(), mkcxcon(), mkrealcon();
+	expptr q, ep;
+	int mtype;
+	int op;
+	int f1field, f2field, f3field;
+
+	packed.ijunk = np->vardesc.varno;
+	f1field = packed.bits.f1;
+	f2field = packed.bits.f2;
+	f3field = packed.bits.f3;
+	if(nargs == 0)
+		goto badnargs;
+
+	mtype = 0;
+	for(cp = argsp->listp ; cp ; cp = cp->nextp)
+	{
+		ep = (expptr)cp->datap;
+		if( ISCONST(ep) && ep->headblock.vtype==TYSHORT )
+			cp->datap = (char *) mkconv(tyint, ep);
+		mtype = maxtype(mtype, ep->headblock.vtype);
+	}
+
+	switch(f1field)
+	{
+	case INTRBOOL:
+		op = f3field;
+		if( ! ONEOF(mtype, MSKINT|MSKLOGICAL) )
+			goto badtype;
+		if(op == OPBITNOT)
+		{
+			if(nargs != 1)
+				goto badnargs;
+			q = mkexpr(OPBITNOT, (expptr)argsp->listp->datap, ENULL);
+		}
+		else
+		{
+			if(nargs != 2)
+				goto badnargs;
+			q = mkexpr(op, (expptr)argsp->listp->datap,
+			    		(expptr)argsp->listp->nextp->datap);
+		}
+		frchain( &(argsp->listp) );
+		free( (charptr) argsp);
+		return(q);
+
+	case INTRCONV:
+		rettype = f2field;
+		if(rettype == TYLONG)
+			rettype = tyint;
+		if( ISCOMPLEX(rettype) && nargs==2)
+		{
+			expptr qr, qi;
+			qr = (expptr) argsp->listp->datap;
+			qi = (expptr) argsp->listp->nextp->datap;
+			if(ISCONST(qr) && ISCONST(qi))
+				q = mkcxcon(qr,qi);
+			else	q = mkexpr(OPCONV,mkconv(rettype-2,qr),
+			    mkconv(rettype-2,qi));
+		}
+		else if(nargs == 1) {
+			if (f3field && ((Exprp)argsp->listp->datap)->vtype
+					== TYDCOMPLEX)
+				rettype = TYDREAL;
+			q = mkconv(rettype+100, (expptr)argsp->listp->datap);
+			}
+		else goto badnargs;
+
+		q->headblock.vtype = rettype;
+		frchain(&(argsp->listp));
+		free( (charptr) argsp);
+		return(q);
+
+
+#if 0
+	case INTRCNST:
+
+/* Machine-dependent f77 stuff that f2c omits:
+
+intcon contains
+	radix for short int
+	radix for long int
+	radix for single precision
+	radix for double precision
+	precision for short int
+	precision for long int
+	precision for single precision
+	precision for double precision
+	emin for single precision
+	emin for double precision
+	emax for single precision
+	emax for double prcision
+	largest short int
+	largest long int
+
+realcon contains
+	tiny for single precision
+	tiny for double precision
+	huge for single precision
+	huge for double precision
+	mrsp (epsilon) for single precision
+	mrsp (epsilon) for double precision
+*/
+	{	register struct Incstblock *cstp;
+		extern ftnint intcon[14];
+		extern double realcon[6];
+
+		cstp = consttab + f3field;
+		for(i=0 ; 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);
+}

+ 1416 - 0
lang/fortran/comp/io.c

@@ -0,0 +1,1416 @@
+/****************************************************************
+Copyright 1990, 1991 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+/* Routines to generate code for I/O statements.
+   Some corrections and improvements due to David Wasley, U. C. Berkeley
+*/
+
+/* TEMPORARY */
+#define TYIOINT TYLONG
+#define SZIOINT SZLONG
+
+#include "defs.h"
+#include "names.h"
+#include "iob.h"
+
+extern int inqmask;
+
+LOCAL void dofclose(), dofinquire(), dofinquire(), dofmove(), dofopen(),
+	doiolist(), ioset(), ioseta(), iosetc(), iosetip(), iosetlc(),
+	putio(), putiocall();
+
+iob_data *iob_list;
+Addrp io_structs[9];
+
+LOCAL char ioroutine[12];
+
+LOCAL long ioendlab;
+LOCAL long ioerrlab;
+LOCAL int endbit;
+LOCAL int errbit;
+LOCAL long jumplab;
+LOCAL long skiplab;
+LOCAL int ioformatted;
+LOCAL int statstruct = NO;
+LOCAL struct Labelblock *skiplabel;
+Addrp ioblkp;
+
+#define UNFORMATTED 0
+#define FORMATTED 1
+#define LISTDIRECTED 2
+#define NAMEDIRECTED 3
+
+#define V(z)	ioc[z].iocval
+
+#define IOALL 07777
+
+LOCAL struct Ioclist
+{
+	char *iocname;
+	int iotype;
+	expptr iocval;
+}
+ioc[ ] =
+{
+	{ "", 0 },
+	{ "unit", IOALL },
+	{ "fmt", M(IOREAD) | M(IOWRITE) },
+	{ "err", IOALL },
+	{ "end", M(IOREAD) },
+	{ "iostat", IOALL },
+	{ "rec", M(IOREAD) | M(IOWRITE) },
+	{ "recl", M(IOOPEN) | M(IOINQUIRE) },
+	{ "file", M(IOOPEN) | M(IOINQUIRE) },
+	{ "status", M(IOOPEN) | M(IOCLOSE) },
+	{ "access", M(IOOPEN) | M(IOINQUIRE) },
+	{ "form", M(IOOPEN) | M(IOINQUIRE) },
+	{ "blank", M(IOOPEN) | M(IOINQUIRE) },
+	{ "exist", M(IOINQUIRE) },
+	{ "opened", M(IOINQUIRE) },
+	{ "number", M(IOINQUIRE) },
+	{ "named", M(IOINQUIRE) },
+	{ "name", M(IOINQUIRE) },
+	{ "sequential", M(IOINQUIRE) },
+	{ "direct", M(IOINQUIRE) },
+	{ "formatted", M(IOINQUIRE) },
+	{ "unformatted", M(IOINQUIRE) },
+	{ "nextrec", M(IOINQUIRE) },
+	{ "nml", M(IOREAD) | M(IOWRITE) }
+};
+
+#define NIOS (sizeof(ioc)/sizeof(struct Ioclist) - 1)
+#define MAXIO	SZFLAG + 10*SZIOINT + 15*SZADDR
+
+/* #define IOSUNIT 1 */
+/* #define IOSFMT 2 */
+#define IOSERR 3
+#define IOSEND 4
+#define IOSIOSTAT 5
+#define IOSREC 6
+#define IOSRECL 7
+#define IOSFILE 8
+#define IOSSTATUS 9
+#define IOSACCESS 10
+#define IOSFORM 11
+#define IOSBLANK 12
+#define IOSEXISTS 13
+#define IOSOPENED 14
+#define IOSNUMBER 15
+#define IOSNAMED 16
+#define IOSNAME 17
+#define IOSSEQUENTIAL 18
+#define IOSDIRECT 19
+#define IOSFORMATTED 20
+#define IOSUNFORMATTED 21
+#define IOSNEXTREC 22
+#define IOSNML 23
+
+#define IOSTP V(IOSIOSTAT)
+
+
+/* offsets in generated structures */
+
+#define SZFLAG SZIOINT
+
+/* offsets for external READ and WRITE statements */
+
+#define XERR 0
+#define XUNIT	SZFLAG
+#define XEND	SZFLAG + SZIOINT
+#define XFMT	2*SZFLAG + SZIOINT
+#define XREC	2*SZFLAG + SZIOINT + SZADDR
+#define XRLEN	2*SZFLAG + 2*SZADDR
+#define XRNUM	2*SZFLAG + 2*SZADDR + SZIOINT
+
+/* offsets for internal READ and WRITE statements */
+
+#define XIERR	0
+#define XIUNIT	SZFLAG
+#define XIEND	SZFLAG + SZADDR
+#define XIFMT	2*SZFLAG + SZADDR
+#define XIRLEN	2*SZFLAG + 2*SZADDR
+#define XIRNUM	2*SZFLAG + 2*SZADDR + SZIOINT
+#define XIREC	2*SZFLAG + 2*SZADDR + 2*SZIOINT
+
+/* offsets for OPEN statements */
+
+#define XFNAME	SZFLAG + SZIOINT
+#define XFNAMELEN	SZFLAG + SZIOINT + SZADDR
+#define XSTATUS	SZFLAG + 2*SZIOINT + SZADDR
+#define XACCESS	SZFLAG + 2*SZIOINT + 2*SZADDR
+#define XFORMATTED	SZFLAG + 2*SZIOINT + 3*SZADDR
+#define XRECLEN	SZFLAG + 2*SZIOINT + 4*SZADDR
+#define XBLANK	SZFLAG + 3*SZIOINT + 4*SZADDR
+
+/* offset for CLOSE statement */
+
+#define XCLSTATUS	SZFLAG + SZIOINT
+
+/* offsets for INQUIRE statement */
+
+#define XFILE	SZFLAG + SZIOINT
+#define XFILELEN	SZFLAG + SZIOINT + SZADDR
+#define XEXISTS	SZFLAG + 2*SZIOINT + SZADDR
+#define XOPEN	SZFLAG + 2*SZIOINT + 2*SZADDR
+#define XNUMBER	SZFLAG + 2*SZIOINT + 3*SZADDR
+#define XNAMED	SZFLAG + 2*SZIOINT + 4*SZADDR
+#define XNAME	SZFLAG + 2*SZIOINT + 5*SZADDR
+#define XNAMELEN	SZFLAG + 2*SZIOINT + 6*SZADDR
+#define XQACCESS	SZFLAG + 3*SZIOINT + 6*SZADDR
+#define XQACCLEN	SZFLAG + 3*SZIOINT + 7*SZADDR
+#define XSEQ	SZFLAG + 4*SZIOINT + 7*SZADDR
+#define XSEQLEN	SZFLAG + 4*SZIOINT + 8*SZADDR
+#define XDIRECT	SZFLAG + 5*SZIOINT + 8*SZADDR
+#define XDIRLEN	SZFLAG + 5*SZIOINT + 9*SZADDR
+#define XFORM	SZFLAG + 6*SZIOINT + 9*SZADDR
+#define XFORMLEN	SZFLAG + 6*SZIOINT + 10*SZADDR
+#define XFMTED	SZFLAG + 7*SZIOINT + 10*SZADDR
+#define XFMTEDLEN	SZFLAG + 7*SZIOINT + 11*SZADDR
+#define XUNFMT	SZFLAG + 8*SZIOINT + 11*SZADDR
+#define XUNFMTLEN	SZFLAG + 8*SZIOINT + 12*SZADDR
+#define XQRECL	SZFLAG + 9*SZIOINT + 12*SZADDR
+#define XNEXTREC	SZFLAG + 9*SZIOINT + 13*SZADDR
+#define XQBLANK	SZFLAG + 9*SZIOINT + 14*SZADDR
+#define XQBLANKLEN	SZFLAG + 9*SZIOINT + 15*SZADDR
+
+LOCAL char *cilist_names[] = {
+	"cilist",
+	"cierr",
+	"ciunit",
+	"ciend",
+	"cifmt",
+	"cirec"
+	};
+LOCAL char *icilist_names[] = {
+	"icilist",
+	"icierr",
+	"iciunit",
+	"iciend",
+	"icifmt",
+	"icirlen",
+	"icirnum"
+	};
+LOCAL char *olist_names[] = {
+	"olist",
+	"oerr",
+	"ounit",
+	"ofnm",
+	"ofnmlen",
+	"osta",
+	"oacc",
+	"ofm",
+	"orl",
+	"oblnk"
+	};
+LOCAL char *cllist_names[] = {
+	"cllist",
+	"cerr",
+	"cunit",
+	"csta"
+	};
+LOCAL char *alist_names[] = {
+	"alist",
+	"aerr",
+	"aunit"
+	};
+LOCAL char *inlist_names[] = {
+	"inlist",
+	"inerr",
+	"inunit",
+	"infile",
+	"infilen",
+	"inex",
+	"inopen",
+	"innum",
+	"innamed",
+	"inname",
+	"innamlen",
+	"inacc",
+	"inacclen",
+	"inseq",
+	"inseqlen",
+	"indir",
+	"indirlen",
+	"infmt",
+	"infmtlen",
+	"inform",
+	"informlen",
+	"inunf",
+	"inunflen",
+	"inrecl",
+	"innrec",
+	"inblank",
+	"inblanklen"
+	};
+
+LOCAL char **io_fields;
+
+#define zork(n,t) n, sizeof(n)/sizeof(char *) - 1, t
+
+LOCAL io_setup io_stuff[] = {
+	zork(cilist_names, TYCILIST),	/* external read/write */
+	zork(inlist_names, TYINLIST),	/* inquire */
+	zork(olist_names,  TYOLIST),	/* open */
+	zork(cllist_names, TYCLLIST),	/* close */
+	zork(alist_names,  TYALIST),	/* rewind */
+	zork(alist_names,  TYALIST),	/* backspace */
+	zork(alist_names,  TYALIST),	/* endfile */
+	zork(icilist_names,TYICILIST),	/* internal read */
+	zork(icilist_names,TYICILIST)	/* internal write */
+	};
+
+#undef zork
+
+
+fmtstmt(lp)
+register struct Labelblock *lp;
+{
+	if(lp == NULL)
+	{
+		execerr("unlabeled format statement" , CNULL);
+		return(-1);
+	}
+	if(lp->labtype == LABUNKNOWN)
+	{
+		lp->labtype = LABFORMAT;
+		lp->labelno = newlabel();
+	}
+	else if(lp->labtype != LABFORMAT)
+	{
+		execerr("bad format number", CNULL);
+		return(-1);
+	}
+	return(lp->labelno);
+}
+
+
+setfmt(lp)
+struct Labelblock *lp;
+{
+	int n;
+	char *s0, *lexline();
+	register char *s, *se, *t;
+	register k;
+
+	s0 = s = lexline(&n);
+	se = t = s + n;
+
+	/* warn of trivial errors, e.g. "  11 CONTINUE" (one too few spaces) */
+	/* following FORMAT... */
+
+	if (n <= 0)
+		warn("No (...) after FORMAT");
+	else if (*s != '(')
+		warni("%c rather than ( after FORMAT", *s);
+	else if (se[-1] != ')') {
+		*se = 0;
+		while(--t > s && *t != ')') ;
+		if (t <= s)
+			warn("No ) at end of FORMAT statement");
+		else if (se - t > 30)
+			warn1("Extraneous text at end of FORMAT: ...%s", se-12);
+		else
+			warn1("Extraneous text at end of FORMAT: %s", t+1);
+		t = se;
+		}
+
+	/* fix MYQUOTES (\002's) and \\'s */
+
+	while(s < se)
+		switch(*s++) {
+			case 2:
+				t += 3; break;
+			case '"':
+			case '\\':
+				t++; break;
+			}
+	s = s0;
+	if (lp) {
+		lp->fmtstring = t = mem((int)(t - s + 1), 0);
+		while(s < se)
+			switch(k = *s++) {
+				case 2:
+					t[0] = '\\';
+					t[1] = '0';
+					t[2] = '0';
+					t[3] = '2';
+					t += 4;
+					break;
+				case '"':
+				case '\\':
+					*t++ = '\\';
+					/* no break */
+				default:
+					*t++ = k;
+				}
+		*t = 0;
+		}
+	flline();
+}
+
+
+
+startioctl()
+{
+	register int i;
+
+	inioctl = YES;
+	nioctl = 0;
+	ioformatted = UNFORMATTED;
+	for(i = 1 ; i<=NIOS ; ++i)
+		V(i) = NULL;
+}
+
+ static long
+newiolabel() {
+	long rv;
+	rv = ++lastiolabno;
+	skiplabel = mklabel(rv);
+	skiplabel->labdefined = 1;
+	return rv;
+	}
+
+
+endioctl()
+{
+	int i;
+	expptr p;
+	struct io_setup *ios;
+
+	inioctl = NO;
+
+	/* set up for error recovery */
+
+	ioerrlab = ioendlab = skiplab = jumplab = 0;
+
+	if(p = V(IOSEND))
+		if(ISICON(p))
+			execlab(ioendlab = p->constblock.Const.ci);
+		else
+			err("bad end= clause");
+
+	if(p = V(IOSERR))
+		if(ISICON(p))
+			execlab(ioerrlab = p->constblock.Const.ci);
+		else
+			err("bad err= clause");
+
+	if(IOSTP)
+		if(IOSTP->tag!=TADDR || ! ISINT(IOSTP->addrblock.vtype) )
+		{
+			err("iostat must be an integer variable");
+			frexpr(IOSTP);
+			IOSTP = NULL;
+		}
+
+	if(iostmt == IOREAD)
+	{
+		if(IOSTP)
+		{
+			if(ioerrlab && ioendlab && ioerrlab==ioendlab)
+				jumplab = ioerrlab;
+			else
+				skiplab = jumplab = newiolabel();
+		}
+		else	{
+			if(ioerrlab && ioendlab && ioerrlab!=ioendlab)
+			{
+				IOSTP = (expptr) mktmp(TYINT, ENULL);
+				skiplab = jumplab = newiolabel();
+			}
+			else
+				jumplab = (ioerrlab ? ioerrlab : ioendlab);
+		}
+	}
+	else if(iostmt == IOWRITE)
+	{
+		if(IOSTP && !ioerrlab)
+			skiplab = jumplab = newiolabel();
+		else
+			jumplab = ioerrlab;
+	}
+	else
+		jumplab = ioerrlab;
+
+	endbit = IOSTP!=NULL || ioendlab!=0;	/* for use in startrw() */
+	errbit = IOSTP!=NULL || ioerrlab!=0;
+	if (jumplab && !IOSTP)
+		IOSTP = (expptr) mktmp(TYINT, ENULL);
+
+	if(iostmt!=IOREAD && iostmt!=IOWRITE)
+	{
+		ios = io_stuff + iostmt;
+		io_fields = ios->fields;
+		ioblkp = io_structs[iostmt];
+		if(ioblkp == NULL)
+			io_structs[iostmt] = ioblkp =
+				autovar(1, ios->type, ENULL, "");
+		ioset(TYIOINT, XERR, ICON(errbit));
+	}
+
+	switch(iostmt)
+	{
+	case IOOPEN:
+		dofopen();
+		break;
+
+	case IOCLOSE:
+		dofclose();
+		break;
+
+	case IOINQUIRE:
+		dofinquire();
+		break;
+
+	case IOBACKSPACE:
+		dofmove("f_back");
+		break;
+
+	case IOREWIND:
+		dofmove("f_rew");
+		break;
+
+	case IOENDFILE:
+		dofmove("f_end");
+		break;
+
+	case IOREAD:
+	case IOWRITE:
+		startrw();
+		break;
+
+	default:
+		fatali("impossible iostmt %d", iostmt);
+	}
+	for(i = 1 ; i<=NIOS ; ++i)
+		if(i!=IOSIOSTAT && V(i)!=NULL)
+			frexpr(V(i));
+}
+
+
+
+iocname()
+{
+	register int i;
+	int found, mask;
+
+	found = 0;
+	mask = M(iostmt);
+	for(i = 1 ; i <= NIOS ; ++i)
+		if(!strcmp(ioc[i].iocname, token))
+			if(ioc[i].iotype & mask)
+				return(i);
+			else {
+				found = i;
+				break;
+				}
+	if(found) {
+		if (iostmt == IOOPEN && !strcmp(ioc[i].iocname, "name")) {
+			NOEXT("open with \"name=\" treated as \"file=\"");
+			for(i = 1; strcmp(ioc[i].iocname, "file"); i++);
+			return i;
+			}
+		errstr("invalid control %s for statement", ioc[found].iocname);
+		}
+	else
+		errstr("unknown iocontrol %s", token);
+	return(IOSBAD);
+}
+
+
+ioclause(n, p)
+register int n;
+register expptr p;
+{
+	struct Ioclist *iocp;
+
+	++nioctl;
+	if(n == IOSBAD)
+		return;
+	if(n == IOSPOSITIONAL)
+		{
+		n = nioctl;
+		if (n == IOSFMT) {
+			if (iostmt == IOOPEN) {
+				n = IOSFILE;
+				NOEXT("file= specifier omitted from open");
+				}
+			else if (iostmt < IOREAD)
+				goto illegal;
+			}
+		else if(n > IOSFMT)
+			{
+ illegal:
+			err("illegal positional iocontrol");
+			return;
+			}
+		}
+	else if (n == IOSNML)
+		n = IOSFMT;
+
+	if(p == NULL)
+	{
+		if(n == IOSUNIT)
+			p = (expptr) (iostmt==IOREAD ? IOSTDIN : IOSTDOUT);
+		else if(n != IOSFMT)
+		{
+			err("illegal * iocontrol");
+			return;
+		}
+	}
+	if(n == IOSFMT)
+		ioformatted = (p==NULL ? LISTDIRECTED : FORMATTED);
+
+	iocp = & ioc[n];
+	if(iocp->iocval == NULL)
+	{
+		if(n!=IOSFMT && ( n!=IOSUNIT || (p && p->headblock.vtype!=TYCHAR) ) )
+			p = fixtype(p);
+		else if (p && p->tag == TPRIM
+			   && p->primblock.namep->vclass == CLUNKNOWN) {
+			/* kludge made necessary by attempt to infer types
+			 * for untyped external parameters: given an error
+			 * in calling sequences, an integer argument might
+			 * tentatively be assumed TYCHAR; this would otherwise
+			 * be corrected too late in startrw after startrw
+			 * had decided this to be an internal file.
+			 */
+			vardcl(p->primblock.namep);
+			p->primblock.vtype = p->primblock.namep->vtype;
+			}
+		iocp->iocval = p;
+	}
+	else
+		errstr("iocontrol %s repeated", iocp->iocname);
+}
+
+/* io list item */
+
+doio(list)
+chainp list;
+{
+	expptr call0();
+
+	if(ioformatted == NAMEDIRECTED)
+	{
+		if(list)
+			err("no I/O list allowed in NAMELIST read/write");
+	}
+	else
+	{
+		doiolist(list);
+		ioroutine[0] = 'e';
+		if (skiplab || ioroutine[4] == 'l')
+			jumplab = 0;
+		putiocall( call0(TYINT, ioroutine) );
+	}
+}
+
+
+
+
+
+ LOCAL void
+doiolist(p0)
+ chainp p0;
+{
+	chainp p;
+	register tagptr q;
+	register expptr qe;
+	register Namep qn;
+	Addrp tp, mkscalar();
+	int range;
+	extern char *ohalign;
+
+	for (p = p0 ; p ; p = p->nextp)
+	{
+		q = (tagptr)p->datap;
+		if(q->tag == TIMPLDO)
+		{
+			exdo(range=newlabel(), (Namep)0,
+				q->impldoblock.impdospec);
+			doiolist(q->impldoblock.datalist);
+			enddo(range);
+			free( (charptr) q);
+		}
+		else	{
+			if(q->tag==TPRIM && q->primblock.argsp==NULL
+			    && q->primblock.namep->vdim!=NULL)
+			{
+				vardcl(qn = q->primblock.namep);
+				if(qn->vdim->nelt) {
+					putio( fixtype(cpexpr(qn->vdim->nelt)),
+					    (expptr)mkscalar(qn) );
+					qn->vlastdim = 0;
+					}
+				else
+					err("attempt to i/o array of unknown size");
+			}
+			else if(q->tag==TPRIM && q->primblock.argsp==NULL &&
+			    (qe = (expptr) memversion(q->primblock.namep)) )
+				putio(ICON(1),qe);
+			else if (ISCONST(q) && q->constblock.vtype == TYCHAR) {
+				halign = 0;
+				putio(ICON(1), qe = fixtype(cpexpr(q)));
+				halign = ohalign;
+				}
+			else if(((qe = fixtype(cpexpr(q)))->tag==TADDR &&
+			    (qe->addrblock.uname_tag != UNAM_CONST ||
+			    !ISCOMPLEX(qe -> addrblock.vtype))) ||
+			    (qe -> tag == TCONST && !ISCOMPLEX(qe ->
+			    headblock.vtype))) {
+				if (qe -> tag == TCONST)
+					qe = (expptr) putconst((Constp)qe);
+				putio(ICON(1), qe);
+			}
+			else if(qe->headblock.vtype != TYERROR)
+			{
+				if(iostmt == IOWRITE)
+				{
+					ftnint lencat();
+					expptr qvl;
+					qvl = NULL;
+					if( ISCHAR(qe) )
+					{
+						qvl = (expptr)
+						    cpexpr(qe->headblock.vleng);
+						tp = mktmp(qe->headblock.vtype,
+						    ICON(lencat(qe)));
+					}
+					else
+						tp = mktmp(qe->headblock.vtype,
+						    qe->headblock.vleng);
+					puteq( cpexpr((expptr)tp), qe);
+					if(qvl)	/* put right length on block */
+					{
+						frexpr(tp->vleng);
+						tp->vleng = qvl;
+					}
+					putio(ICON(1), (expptr)tp);
+				}
+				else
+					err("non-left side in READ list");
+			}
+			frexpr(q);
+		}
+	}
+	frchain( &p0 );
+}
+
+ int iocalladdr = TYADDR;	/* for fixing TYADDR in saveargtypes */
+
+ LOCAL void
+putio(nelt, addr)
+ expptr nelt;
+ register expptr addr;
+{
+	int type;
+	register expptr q;
+	extern Constp mkconst();
+	register Addrp c = 0;
+
+	type = addr->headblock.vtype;
+	if(ioformatted!=LISTDIRECTED && ISCOMPLEX(type) )
+	{
+		nelt = mkexpr(OPSTAR, ICON(2), nelt);
+		type -= (TYCOMPLEX-TYREAL);
+	}
+
+	/* pass a length with every item.  for noncharacter data, fake one */
+	if(type != TYCHAR)
+	{
+
+		if( ISCONST(addr) )
+			addr = (expptr) putconst((Constp)addr);
+		c = ALLOC(Addrblock);
+		c->tag = TADDR;
+		c->vtype = TYLENG;
+		c->vstg = STGAUTO;
+		c->ntempelt = 1;
+		c->isarray = 1;
+		c->memoffset = ICON(0);
+		c->uname_tag = UNAM_IDENT;
+		c->charleng = 1;
+		sprintf(c->user.ident, "(ftnlen)sizeof(%s)", typename[type]);
+		addr = mkexpr(OPCHARCAST, addr, ENULL);
+		}
+
+	nelt = fixtype( mkconv(tyioint,nelt) );
+	if(ioformatted == LISTDIRECTED) {
+		expptr mc = mkconv(tyioint, ICON(type));
+		q = c	? call4(TYINT, "do_lio", mc, nelt, addr, (expptr)c)
+			: call3(TYINT, "do_lio", mc, nelt, addr);
+		}
+	else {
+		char *s = ioformatted==FORMATTED ? "do_fio" : "do_uio";
+		q = c	? call3(TYINT, s, nelt, addr, (expptr)c)
+			: call2(TYINT, s, nelt, addr);
+		}
+	iocalladdr = TYCHAR;
+	putiocall(q);
+	iocalladdr = TYADDR;
+}
+
+
+
+
+endio()
+{
+	extern void p1_label();
+
+	if(skiplab)
+	{
+		if (ioformatted != NAMEDIRECTED)
+			p1_label((long)(skiplabel - labeltab));
+		if(ioendlab) {
+			exif( mkexpr(OPLT, cpexpr(IOSTP), ICON(0)));
+			exgoto(execlab(ioendlab));
+			exendif();
+			}
+		if(ioerrlab) {
+			exif( mkexpr(iostmt==IOREAD||iostmt==IOWRITE
+					? OPGT : OPNE,
+				cpexpr(IOSTP), ICON(0)));
+			exgoto(execlab(ioerrlab));
+			exendif();
+			}
+	}
+
+	if(IOSTP)
+		frexpr(IOSTP);
+}
+
+
+
+ LOCAL void
+putiocall(q)
+ register expptr q;
+{
+	int tyintsave;
+
+	tyintsave = tyint;
+	tyint = tyioint;	/* for -I2 and -i2 */
+
+	if(IOSTP)
+	{
+		q->headblock.vtype = TYINT;
+		q = fixexpr((Exprp)mkexpr(OPASSIGN, cpexpr(IOSTP), q));
+	}
+	putexpr(q);
+	if(jumplab) {
+		exif(mkexpr(OPNE, cpexpr(IOSTP), ICON(0)));
+		exgoto(execlab(jumplab));
+		exendif();
+		}
+	tyint = tyintsave;
+}
+
+ void
+fmtname(np, q)
+ Namep np;
+ register Addrp q;
+{
+	register int k;
+	register char *s, *t;
+	extern chainp assigned_fmts;
+
+	if (!np->vfmt_asg) {
+		np->vfmt_asg = 1;
+		assigned_fmts = mkchain((char *)np, assigned_fmts);
+		}
+	k = strlen(s = np->fvarname);
+	if (k < IDENT_LEN - 4) {
+		q->uname_tag = UNAM_IDENT;
+		t = q->user.ident;
+		}
+	else {
+		q->uname_tag = UNAM_CHARP;
+		q->user.Charp = t = mem(k + 5,0);
+		}
+	sprintf(t, "%s_fmt", s);
+	}
+
+LOCAL Addrp asg_addr(p)
+ union Expression *p;
+{
+	register Addrp q;
+
+	if (p->tag != TPRIM)
+		badtag("asg_addr", p->tag);
+	q = ALLOC(Addrblock);
+	q->tag = TADDR;
+	q->vtype = TYCHAR;
+	q->vstg = STGAUTO;
+	q->ntempelt = 1;
+	q->isarray = 0;
+	q->memoffset = ICON(0);
+	fmtname(p->primblock.namep, q);
+	return q;
+	}
+
+startrw()
+{
+	register expptr p;
+	register Namep np;
+	register Addrp unitp, fmtp, recp;
+	register expptr nump;
+	Addrp mkscalar();
+	expptr mkaddcon();
+	int iostmt1;
+	flag intfile, sequential, ok, varfmt;
+	struct io_setup *ios;
+
+	/* First look at all the parameters and determine what is to be done */
+
+	ok = YES;
+	statstruct = YES;
+
+	intfile = NO;
+	if(p = V(IOSUNIT))
+	{
+		if( ISINT(p->headblock.vtype) ) {
+ int_unit:
+			unitp = (Addrp) cpexpr(p);
+			}
+		else if(p->headblock.vtype == TYCHAR)
+		{
+			if (nioctl == 1 && iostmt == IOREAD) {
+				/* kludge to recognize READ(format expr) */
+				V(IOSFMT) = p;
+				V(IOSUNIT) = p = (expptr) IOSTDIN;
+				ioformatted = FORMATTED;
+				goto int_unit;
+				}
+			intfile = YES;
+			if(p->tag==TPRIM && p->primblock.argsp==NULL &&
+			    (np = p->primblock.namep)->vdim!=NULL)
+			{
+				vardcl(np);
+				if(np->vdim->nelt)
+				{
+					nump = (expptr) cpexpr(np->vdim->nelt);
+					if( ! ISCONST(nump) )
+						statstruct = NO;
+				}
+				else
+				{
+					err("attempt to use internal unit array of unknown size");
+					ok = NO;
+					nump = ICON(1);
+				}
+				unitp = mkscalar(np);
+			}
+			else	{
+				nump = ICON(1);
+				unitp = (Addrp /*pjw */) fixtype(cpexpr(p));
+			}
+			if(! isstatic((expptr)unitp) )
+				statstruct = NO;
+		}
+		else {
+			err("unit specifier not of type integer or character");
+			ok = NO;
+			}
+	}
+	else
+	{
+		err("bad unit specifier");
+		ok = NO;
+	}
+
+	sequential = YES;
+	if(p = V(IOSREC))
+		if( ISINT(p->headblock.vtype) )
+		{
+			recp = (Addrp) cpexpr(p);
+			sequential = NO;
+		}
+		else	{
+			err("bad REC= clause");
+			ok = NO;
+		}
+	else
+		recp = NULL;
+
+
+	varfmt = YES;
+	fmtp = NULL;
+	if(p = V(IOSFMT))
+	{
+		if(p->tag==TPRIM && p->primblock.argsp==NULL)
+		{
+			np = p->primblock.namep;
+			if(np->vclass == CLNAMELIST)
+			{
+				ioformatted = NAMEDIRECTED;
+				fmtp = (Addrp) fixtype(p);
+				V(IOSFMT) = (expptr)fmtp;
+				if (skiplab)
+					jumplab = 0;
+				goto endfmt;
+			}
+			vardcl(np);
+			if(np->vdim)
+			{
+				if( ! ONEOF(np->vstg, MSKSTATIC) )
+					statstruct = NO;
+				fmtp = mkscalar(np);
+				goto endfmt;
+			}
+			if( ISINT(np->vtype) )	/* ASSIGNed label */
+			{
+				statstruct = NO;
+				varfmt = YES;
+				fmtp = asg_addr(p);
+				goto endfmt;
+			}
+		}
+		p = V(IOSFMT) = fixtype(p);
+		if(p->headblock.vtype == TYCHAR
+			/* Since we allow write(6,n)		*/
+			/* we may as well allow write(6,n(2))	*/
+		|| p->tag == TADDR && ISINT(p->addrblock.vtype))
+		{
+			if( ! isstatic(p) )
+				statstruct = NO;
+			fmtp = (Addrp) cpexpr(p);
+		}
+		else if( ISICON(p) )
+		{
+			struct Labelblock *lp;
+			lp = mklabel(p->constblock.Const.ci);
+			if (fmtstmt(lp) > 0)
+			{
+				fmtp = (Addrp)mkaddcon(lp->stateno);
+				/* lp->stateno for names fmt_nnn */
+				lp->fmtlabused = 1;
+				varfmt = NO;
+			}
+			else
+				ioformatted = UNFORMATTED;
+		}
+		else	{
+			err("bad format descriptor");
+			ioformatted = UNFORMATTED;
+			ok = NO;
+		}
+	}
+	else
+		fmtp = NULL;
+
+endfmt:
+	if(intfile) {
+		if (ioformatted==UNFORMATTED) {
+			err("unformatted internal I/O not allowed");
+			ok = NO;
+			}
+		if (recp) {
+			err("direct internal I/O not allowed");
+			ok = NO;
+			}
+		}
+	if(!sequential && ioformatted==LISTDIRECTED)
+	{
+		err("direct list-directed I/O not allowed");
+		ok = NO;
+	}
+	if(!sequential && ioformatted==NAMEDIRECTED)
+	{
+		err("direct namelist I/O not allowed");
+		ok = NO;
+	}
+
+	if( ! ok ) {
+		statstruct = NO;
+		return;
+		}
+
+	/*
+   Now put out the I/O structure, statically if all the clauses
+   are constants, dynamically otherwise
+*/
+
+	if (intfile) {
+		ios = io_stuff + iostmt;
+		iostmt1 = IOREAD;
+		}
+	else {
+		ios = io_stuff;
+		iostmt1 = 0;
+		}
+	io_fields = ios->fields;
+	if(statstruct)
+	{
+		ioblkp = ALLOC(Addrblock);
+		ioblkp->tag = TADDR;
+		ioblkp->vtype = ios->type;
+		ioblkp->vclass = CLVAR;
+		ioblkp->vstg = STGINIT;
+		ioblkp->memno = ++lastvarno;
+		ioblkp->memoffset = ICON(0);
+		ioblkp -> uname_tag = UNAM_IDENT;
+		new_iob_data(ios,
+			temp_name("io_", lastvarno, ioblkp->user.ident));			}
+	else if(!(ioblkp = io_structs[iostmt1]))
+		io_structs[iostmt1] = ioblkp =
+			autovar(1, ios->type, ENULL, "");
+
+	ioset(TYIOINT, XERR, ICON(errbit));
+	if(iostmt == IOREAD)
+		ioset(TYIOINT, (intfile ? XIEND : XEND), ICON(endbit) );
+
+	if(intfile)
+	{
+		ioset(TYIOINT, XIRNUM, nump);
+		ioset(TYIOINT, XIRLEN, cpexpr(unitp->vleng) );
+		ioseta(XIUNIT, unitp);
+	}
+	else
+		ioset(TYIOINT, XUNIT, (expptr) unitp);
+
+	if(recp)
+		ioset(TYIOINT, /* intfile ? XIREC : */ XREC, (expptr) recp);
+
+	if(varfmt)
+		ioseta( intfile ? XIFMT : XFMT , fmtp);
+	else
+		ioset(TYADDR, intfile ? XIFMT : XFMT, (expptr) fmtp);
+
+	ioroutine[0] = 's';
+	ioroutine[1] = '_';
+	ioroutine[2] = iostmt==IOREAD ? 'r' : 'w';
+	ioroutine[3] = "ds"[sequential];
+	ioroutine[4] = "ufln"[ioformatted];
+	ioroutine[5] = "ei"[intfile];
+	ioroutine[6] = '\0';
+
+	putiocall( call1(TYINT, ioroutine, cpexpr((expptr)ioblkp) ));
+
+	if(statstruct)
+	{
+		frexpr((expptr)ioblkp);
+		statstruct = NO;
+		ioblkp = 0;	/* unnecessary */
+	}
+}
+
+
+
+ LOCAL void
+dofopen()
+{
+	register expptr p;
+
+	if( (p = V(IOSUNIT)) && ISINT(p->headblock.vtype) )
+		ioset(TYIOINT, XUNIT, cpexpr(p) );
+	else
+		err("bad unit in open");
+	if( (p = V(IOSFILE)) )
+		if(p->headblock.vtype == TYCHAR)
+			ioset(TYIOINT, XFNAMELEN, cpexpr(p->headblock.vleng) );
+		else
+			err("bad file in open");
+
+	iosetc(XFNAME, p);
+
+	if(p = V(IOSRECL))
+		if( ISINT(p->headblock.vtype) )
+			ioset(TYIOINT, XRECLEN, cpexpr(p) );
+		else
+			err("bad recl");
+	else
+		ioset(TYIOINT, XRECLEN, ICON(0) );
+
+	iosetc(XSTATUS, V(IOSSTATUS));
+	iosetc(XACCESS, V(IOSACCESS));
+	iosetc(XFORMATTED, V(IOSFORM));
+	iosetc(XBLANK, V(IOSBLANK));
+
+	putiocall( call1(TYINT, "f_open", cpexpr((expptr)ioblkp) ));
+}
+
+
+ LOCAL void
+dofclose()
+{
+	register expptr p;
+
+	if( (p = V(IOSUNIT)) && ISINT(p->headblock.vtype) )
+	{
+		ioset(TYIOINT, XUNIT, cpexpr(p) );
+		iosetc(XCLSTATUS, V(IOSSTATUS));
+		putiocall( call1(TYINT, "f_clos", cpexpr((expptr)ioblkp)) );
+	}
+	else
+		err("bad unit in close statement");
+}
+
+
+ LOCAL void
+dofinquire()
+{
+	register expptr p;
+	if(p = V(IOSUNIT))
+	{
+		if( V(IOSFILE) )
+			err("inquire by unit or by file, not both");
+		ioset(TYIOINT, XUNIT, cpexpr(p) );
+	}
+	else if( ! V(IOSFILE) )
+		err("must inquire by unit or by file");
+	iosetlc(IOSFILE, XFILE, XFILELEN);
+	iosetip(IOSEXISTS, XEXISTS);
+	iosetip(IOSOPENED, XOPEN);
+	iosetip(IOSNUMBER, XNUMBER);
+	iosetip(IOSNAMED, XNAMED);
+	iosetlc(IOSNAME, XNAME, XNAMELEN);
+	iosetlc(IOSACCESS, XQACCESS, XQACCLEN);
+	iosetlc(IOSSEQUENTIAL, XSEQ, XSEQLEN);
+	iosetlc(IOSDIRECT, XDIRECT, XDIRLEN);
+	iosetlc(IOSFORM, XFORM, XFORMLEN);
+	iosetlc(IOSFORMATTED, XFMTED, XFMTEDLEN);
+	iosetlc(IOSUNFORMATTED, XUNFMT, XUNFMTLEN);
+	iosetip(IOSRECL, XQRECL);
+	iosetip(IOSNEXTREC, XNEXTREC);
+	iosetlc(IOSBLANK, XQBLANK, XQBLANKLEN);
+
+	putiocall( call1(TYINT,  "f_inqu", cpexpr((expptr)ioblkp) ));
+}
+
+
+
+ LOCAL void
+dofmove(subname)
+ char *subname;
+{
+	register expptr p;
+
+	if( (p = V(IOSUNIT)) && ISINT(p->headblock.vtype) )
+	{
+		ioset(TYIOINT, XUNIT, cpexpr(p) );
+		putiocall( call1(TYINT, subname, cpexpr((expptr)ioblkp) ));
+	}
+	else
+		err("bad unit in I/O motion statement");
+}
+
+static int ioset_assign = OPASSIGN;
+
+ LOCAL void
+ioset(type, offset, p)
+ int type, offset;
+ register expptr p;
+{
+	offset /= SZLONG;
+	if(statstruct && ISCONST(p)) {
+		register char *s;
+		switch(type) {
+			case TYADDR:	/* stmt label */
+				s = "fmt_";
+				break;
+			case TYIOINT:
+				s = "";
+				break;
+			default:
+				badtype("ioset", type);
+			}
+		iob_list->fields[offset] =
+			string_num(s, p->constblock.Const.ci);
+		frexpr(p);
+		}
+	else {
+		register Addrp q;
+
+		q = ALLOC(Addrblock);
+		q->tag = TADDR;
+		q->vtype = type;
+		q->vstg = STGAUTO;
+		q->ntempelt = 1;
+		q->isarray = 0;
+		q->memoffset = ICON(0);
+		q->uname_tag = UNAM_IDENT;
+		sprintf(q->user.ident, "%s.%s",
+			statstruct ? iob_list->name : ioblkp->user.ident,
+			io_fields[offset + 1]);
+		if (type == TYADDR && p->tag == TCONST
+				   && p->constblock.vtype == TYADDR) {
+			/* kludge */
+			register Addrp p1;
+			p1 = ALLOC(Addrblock);
+			p1->tag = TADDR;
+			p1->vtype = type;
+			p1->vstg = STGAUTO;	/* wrong, but who cares? */
+			p1->ntempelt = 1;
+			p1->isarray = 0;
+			p1->memoffset = ICON(0);
+			p1->uname_tag = UNAM_IDENT;
+			sprintf(p1->user.ident, "fmt_%ld",
+				p->constblock.Const.ci);
+			frexpr(p);
+			p = (expptr)p1;
+			}
+		if (type == TYADDR && p->headblock.vtype == TYCHAR)
+			q->vtype = TYCHAR;
+		putexpr(mkexpr(ioset_assign, (expptr)q, p));
+		}
+}
+
+
+
+
+ LOCAL void
+iosetc(offset, p)
+ int offset;
+ register expptr p;
+{
+	extern Addrp putchop();
+
+	if(p == NULL)
+		ioset(TYADDR, offset, ICON(0) );
+	else if(p->headblock.vtype == TYCHAR) {
+		p = putx(fixtype((expptr)putchop(cpexpr(p))));
+		ioset(TYADDR, offset, addrof(p));
+		}
+	else
+		err("non-character control clause");
+}
+
+
+
+ LOCAL void
+ioseta(offset, p)
+ int offset;
+ register Addrp p;
+{
+	char *s, *s1;
+	static char who[] = "ioseta";
+	expptr e, mo;
+	Namep np;
+	ftnint ci;
+	int k;
+	char buf[24], buf1[24];
+	Extsym *comm;
+	extern int usedefsforcommon;
+
+	if(statstruct)
+	{
+		if (!p)
+			return;
+		if (p->tag != TADDR)
+			badtag(who, p->tag);
+		offset /= SZLONG;
+		switch(p->uname_tag) {
+		    case UNAM_NAME:
+			mo = p->memoffset;
+			if (mo->tag != TCONST)
+				badtag("ioseta/memoffset", mo->tag);
+			np = p->user.name;
+			np->visused = 1;
+			ci = mo->constblock.Const.ci - np->voffset;
+			if (np->vstg == STGCOMMON
+			&& !np->vcommequiv
+			&& !usedefsforcommon) {
+				comm = &extsymtab[np->vardesc.varno];
+				sprintf(buf, "%d.", comm->curno);
+				k = strlen(buf) + strlen(comm->cextname)
+					+ strlen(np->cvarname);
+				if (ci) {
+					sprintf(buf1, "+%ld", ci);
+					k += strlen(buf1);
+					}
+				else
+					buf1[0] = 0;
+				s = mem(k + 1, 0);
+				sprintf(s, "%s%s%s%s", comm->cextname, buf,
+					np->cvarname, buf1);
+				}
+			else if (ci) {
+				sprintf(buf,"%ld", ci);
+				s1 = p->user.name->cvarname;
+				k = strlen(buf) + strlen(s1);
+				sprintf(s = mem(k+2,0), "%s+%s", s1, buf);
+				}
+			else
+				s = cpstring(np->cvarname);
+			break;
+		    case UNAM_CONST:
+			s = tostring(p->user.Const.ccp1.ccp0,
+				(int)p->vleng->constblock.Const.ci);
+			break;
+		    default:
+			badthing("uname_tag", who, p->uname_tag);
+		    }
+		/* kludge for Hollerith */
+		if (p->vtype != TYCHAR) {
+			s1 = mem(strlen(s)+10,0);
+			sprintf(s1, "(char *)%s%s", p->isarray ? "" : "&", s);
+			s = s1;
+			}
+		iob_list->fields[offset] = s;
+	}
+	else {
+		if (!p)
+			e = ICON(0);
+		else if (p->vtype != TYCHAR) {
+			NOEXT("non-character variable as format or internal unit");
+			e = mkexpr(OPCHARCAST, (expptr)p, ENULL);
+			}
+		else
+			e = addrof((expptr)p);
+		ioset(TYADDR, offset, e);
+		}
+}
+
+
+
+
+ LOCAL void
+iosetip(i, offset)
+ int i, offset;
+{
+	register expptr p;
+
+	if(p = V(i))
+		if(p->tag==TADDR &&
+		    ONEOF(p->addrblock.vtype, inqmask) ) {
+			ioset_assign = OPASSIGNI;
+			ioset(TYADDR, offset, addrof(cpexpr(p)) );
+			ioset_assign = OPASSIGN;
+			}
+		else
+			errstr("impossible inquire parameter %s", ioc[i].iocname);
+	else
+		ioset(TYADDR, offset, ICON(0) );
+}
+
+
+
+ LOCAL void
+iosetlc(i, offp, offl)
+ int i, offp, offl;
+{
+	register expptr p;
+	if( (p = V(i)) && p->headblock.vtype==TYCHAR)
+		ioset(TYIOINT, offl, cpexpr(p->headblock.vleng) );
+	iosetc(offp, p);
+}

+ 24 - 0
lang/fortran/comp/iob.h

@@ -0,0 +1,24 @@
+struct iob_data {
+	struct iob_data *next;
+	char *type;
+	char *name;
+	char *fields[1];
+	};
+struct io_setup {
+	char **fields;
+	int nelt, type;
+	};
+
+struct defines {
+	struct defines *next;
+	char defname[1];
+	};
+
+typedef struct iob_data iob_data;
+typedef struct io_setup io_setup;
+typedef struct defines defines;
+
+extern iob_data *iob_list;
+extern struct Addrblock *io_structs[9];
+extern void def_start(), new_iob_data(), other_undefs();
+extern char *tostring();

+ 1453 - 0
lang/fortran/comp/lex.c

@@ -0,0 +1,1453 @@
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+#include "defs.h"
+#include "tokdefs.h"
+#include "p1defs.h"
+
+#define BLANK	' '
+#define MYQUOTE (2)
+#define SEOF 0
+
+/* card types */
+
+#define STEOF 1
+#define STINITIAL 2
+#define STCONTINUE 3
+
+/* lex states */
+
+#define NEWSTMT	1
+#define FIRSTTOKEN	2
+#define OTHERTOKEN	3
+#define RETEOS	4
+
+
+LOCAL int stkey;	/* Type of the current statement (DO, END, IF, etc) */
+extern char token[];	/* holds the actual token text */
+static int needwkey;
+ftnint yystno;
+flag intonly;
+extern int new_dcl;
+LOCAL long int stno;
+LOCAL long int nxtstno;	/* Statement label */
+LOCAL int parlev;	/* Parentheses level */
+LOCAL int parseen;
+LOCAL int expcom;
+LOCAL int expeql;
+LOCAL char *nextch;
+LOCAL char *lastch;
+LOCAL char *nextcd 	= NULL;
+LOCAL char *endcd;
+LOCAL long prevlin;
+LOCAL long thislin;
+LOCAL int code;		/* Card type; INITIAL, CONTINUE or EOF */
+LOCAL int lexstate	= NEWSTMT;
+LOCAL char sbuf[1390];	/* Main buffer for Fortran source input.  The number
+			   comes from lines of at most 66 characters, with at
+			   most 20 continuation cards (or something); this is
+			   part of the defn of the standard */
+LOCAL char *send	= sbuf+20*66;
+LOCAL int nincl	= 0;	/* Current number of include files */
+LOCAL long firstline;
+LOCAL char *laststb, *stb0;
+extern int addftnsrc;
+#define CONTMAX 100	/* max continuation lines for ! processing */
+char *linestart[CONTMAX];
+LOCAL int ncont;
+LOCAL char comstart[Table_size];
+#define USC (unsigned char *)
+
+static char anum_buf[Table_size];
+#define isalnum_(x) anum_buf[x]
+#define isalpha_(x) (anum_buf[x] == 1)
+
+#define COMMENT_BUF_STORE 4088
+
+typedef struct comment_buf {
+	struct comment_buf *next;
+	char *last;
+	char buf[COMMENT_BUF_STORE];
+	} comment_buf;
+static comment_buf *cbfirst, *cbcur;
+static char *cbinit, *cbnext, *cblast;
+static void flush_comments();
+extern flag use_bs;
+
+
+/* Comment buffering data
+
+	Comments are kept in a list until the statement before them has
+   been parsed.  This list is implemented with the above comment_buf
+   structure and the pointers cbnext and cblast.
+
+	The comments are stored with terminating NULL, and no other
+   intervening space.  The last few bytes of each block are likely to
+   remain unused.
+*/
+
+/* struct Inclfile   holds the state information for each include file */
+struct Inclfile
+{
+	struct Inclfile *inclnext;
+	FILEP inclfp;
+	char *inclname;
+	int incllno;
+	char *incllinp;
+	int incllen;
+	int inclcode;
+	ftnint inclstno;
+};
+
+LOCAL struct Inclfile *inclp	=  NULL;
+struct Keylist {
+	char *keyname;
+	int keyval;
+	char notinf66;
+};
+struct Punctlist {
+	char punchar;
+	int punval;
+};
+struct Fmtlist {
+	char fmtchar;
+	int fmtval;
+};
+struct Dotlist {
+	char *dotname;
+	int dotval;
+	};
+LOCAL struct Keylist *keystart[26], *keyend[26];
+
+/* KEYWORD AND SPECIAL CHARACTER TABLES
+*/
+
+static struct Punctlist puncts[ ] =
+{
+	'(', SLPAR,
+	')', SRPAR,
+	'=', SEQUALS,
+	',', SCOMMA,
+	'+', SPLUS,
+	'-', SMINUS,
+	'*', SSTAR,
+	'/', SSLASH,
+	'$', SCURRENCY,
+	':', SCOLON,
+	'<', SLT,
+	'>', SGT,
+	0, 0 };
+
+LOCAL struct Dotlist  dots[ ] =
+{
+	"and.", SAND,
+	    "or.", SOR,
+	    "not.", SNOT,
+	    "true.", STRUE,
+	    "false.", SFALSE,
+	    "eq.", SEQ,
+	    "ne.", SNE,
+	    "lt.", SLT,
+	    "le.", SLE,
+	    "gt.", SGT,
+	    "ge.", SGE,
+	    "neqv.", SNEQV,
+	    "eqv.", SEQV,
+	    0, 0 };
+
+LOCAL struct Keylist  keys[ ] =
+{
+	{ "assign",  SASSIGN  },
+	{ "automatic",  SAUTOMATIC, YES  },
+	{ "backspace",  SBACKSPACE  },
+	{ "blockdata",  SBLOCK  },
+	{ "call",  SCALL  },
+	{ "character",  SCHARACTER, YES  },
+	{ "close",  SCLOSE, YES  },
+	{ "common",  SCOMMON  },
+	{ "complex",  SCOMPLEX  },
+	{ "continue",  SCONTINUE  },
+	{ "data",  SDATA  },
+	{ "dimension",  SDIMENSION  },
+	{ "doubleprecision",  SDOUBLE  },
+	{ "doublecomplex", SDCOMPLEX, YES  },
+	{ "elseif",  SELSEIF, YES  },
+	{ "else",  SELSE, YES  },
+	{ "endfile",  SENDFILE  },
+	{ "endif",  SENDIF, YES  },
+	{ "enddo", SENDDO, YES },
+	{ "end",  SEND  },
+	{ "entry",  SENTRY, YES  },
+	{ "equivalence",  SEQUIV  },
+	{ "external",  SEXTERNAL  },
+	{ "format",  SFORMAT  },
+	{ "function",  SFUNCTION  },
+	{ "goto",  SGOTO  },
+	{ "implicit",  SIMPLICIT, YES  },
+	{ "include",  SINCLUDE, YES  },
+	{ "inquire",  SINQUIRE, YES  },
+	{ "intrinsic",  SINTRINSIC, YES  },
+	{ "integer",  SINTEGER  },
+	{ "logical",  SLOGICAL  },
+	{ "namelist", SNAMELIST, YES },
+	{ "none", SUNDEFINED, YES },
+	{ "open",  SOPEN, YES  },
+	{ "parameter",  SPARAM, YES  },
+	{ "pause",  SPAUSE  },
+	{ "print",  SPRINT  },
+	{ "program",  SPROGRAM, YES  },
+	{ "punch",  SPUNCH, YES  },
+	{ "read",  SREAD  },
+	{ "real",  SREAL  },
+	{ "return",  SRETURN  },
+	{ "rewind",  SREWIND  },
+	{ "save",  SSAVE, YES  },
+	{ "static",  SSTATIC, YES  },
+	{ "stop",  SSTOP  },
+	{ "subroutine",  SSUBROUTINE  },
+	{ "then",  STHEN, YES  },
+	{ "undefined", SUNDEFINED, YES  },
+	{ "while", SWHILE, YES  },
+	{ "write",  SWRITE  },
+	{ 0, 0 }
+};
+
+LOCAL void analyz(), crunch(), store_comment();
+LOCAL int getcd(), getcds(), getkwd(), gettok();
+LOCAL char *stbuf[3];
+
+inilex(name)
+char *name;
+{
+	stbuf[0] = Alloc(3*P1_STMTBUFSIZE);
+	stbuf[1] = stbuf[0] + P1_STMTBUFSIZE;
+	stbuf[2] = stbuf[1] + P1_STMTBUFSIZE;
+	nincl = 0;
+	inclp = NULL;
+	doinclude(name);
+	lexstate = NEWSTMT;
+	return(NO);
+}
+
+
+
+/* throw away the rest of the current line */
+flline()
+{
+	lexstate = RETEOS;
+}
+
+
+
+char *lexline(n)
+int *n;
+{
+	*n = (lastch - nextch) + 1;
+	return(nextch);
+}
+
+
+
+
+
+doinclude(name)
+char *name;
+{
+	FILEP fp;
+	struct Inclfile *t;
+
+	if(inclp)
+	{
+		inclp->incllno = thislin;
+		inclp->inclcode = code;
+		inclp->inclstno = nxtstno;
+		if(nextcd)
+			inclp->incllinp = copyn(inclp->incllen = endcd-nextcd , nextcd);
+		else
+			inclp->incllinp = 0;
+	}
+	nextcd = NULL;
+
+	if(++nincl >= MAXINCLUDES)
+		Fatal("includes nested too deep");
+	if(name[0] == '\0')
+		fp = stdin;
+	else
+		fp = fopen(name, textread);
+	if (fp)
+	{
+		t = inclp;
+		inclp = ALLOC(Inclfile);
+		inclp->inclnext = t;
+		prevlin = thislin = 0;
+		infname = inclp->inclname = name;
+		infile = inclp->inclfp = fp;
+	}
+	else
+	{
+		fprintf(diagfile, "Cannot open file %s\n", name);
+		done(1);
+	}
+}
+
+
+
+
+LOCAL popinclude()
+{
+	struct Inclfile *t;
+	register char *p;
+	register int k;
+
+	if(infile != stdin)
+		clf(&infile, infname, 1);	/* Close the input file */
+	free(infname);
+
+	--nincl;
+	t = inclp->inclnext;
+	free( (charptr) inclp);
+	inclp = t;
+	if(inclp == NULL) {
+		infname = 0;
+		return(NO);
+		}
+
+	infile = inclp->inclfp;
+	infname = inclp->inclname;
+	prevlin = thislin = inclp->incllno;
+	code = inclp->inclcode;
+	stno = nxtstno = inclp->inclstno;
+	if(inclp->incllinp)
+	{
+		endcd = nextcd = sbuf;
+		k = inclp->incllen;
+		p = inclp->incllinp;
+		while(--k >= 0)
+			*endcd++ = *p++;
+		free( (charptr) (inclp->incllinp) );
+	}
+	else
+		nextcd = NULL;
+	return(YES);
+}
+
+ static void
+putlineno()
+{
+	static long lastline;
+	static char *lastfile = "??", *lastfile0 = "?";
+	static char fbuf[P1_FILENAME_MAX];
+	extern int gflag;
+	register char *s0, *s1;
+
+	if (gflag) {
+		if (lastline) {
+			if (lastfile != lastfile0) {
+				p1puts(P1_FILENAME, fbuf);
+				lastfile0 = lastfile;
+				}
+			p1_line_number(lastline);
+			}
+		lastline = firstline;
+		if (lastfile != infname)
+			if (lastfile = infname) {
+				strncpy(fbuf, lastfile, sizeof(fbuf));
+				fbuf[sizeof(fbuf)-1] = 0;
+				}
+			else
+				fbuf[0] = 0;
+		}
+	if (addftnsrc) {
+		if (laststb && *laststb) {
+			for(s1 = laststb; *s1; s1++) {
+				for(s0 = s1; *s1 != '\n'; s1++)
+					if (*s1 == '*' && s1[1] == '/')
+						*s1 = '+';
+				*s1 = 0;
+				p1puts(P1_FORTRAN, s0);
+				}
+			*laststb = 0;	/* prevent trouble after EOF */
+			}
+		laststb = stb0;
+		}
+	}
+
+
+yylex()
+{
+	static int  tokno;
+	int retval;
+
+	switch(lexstate)
+	{
+	case NEWSTMT :	/* need a new statement */
+		retval = getcds();
+		putlineno();
+		if(retval == STEOF) {
+			retval = SEOF;
+			break;
+		} /* if getcds() == STEOF */
+		crunch();
+		tokno = 0;
+		lexstate = FIRSTTOKEN;
+		yystno = stno;
+		stno = nxtstno;
+		toklen = 0;
+		retval = SLABEL;
+		break;
+
+first:
+	case FIRSTTOKEN :	/* first step on a statement */
+		analyz();
+		lexstate = OTHERTOKEN;
+		tokno = 1;
+		retval = stkey;
+		break;
+
+	case OTHERTOKEN :	/* return next token */
+		if(nextch > lastch)
+			goto reteos;
+		++tokno;
+		if( (stkey==SLOGIF || stkey==SELSEIF) && parlev==0 && tokno>3)
+			goto first;
+
+		if(stkey==SASSIGN && tokno==3 && nextch<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);
+	}

+ 31 - 0
lang/fortran/comp/machdefs.h

@@ -0,0 +1,31 @@
+#define TYLENG	TYLONG		/* char string length field */
+
+#define TYINT	TYLONG
+#define SZADDR	4
+#define SZSHORT	2
+#define SZINT	4
+
+#define SZLONG	4
+#define SZLENG	SZLONG
+
+#define SZDREAL 8
+
+/* Alignment restrictions */
+
+#define ALIADDR SZADDR
+#define ALISHORT SZSHORT
+#define ALILONG 4
+#define ALIDOUBLE 8
+#define ALIINT	ALILONG
+#define ALILENG	ALILONG
+
+#define BLANKCOMMON "_BLNK__"		/* Name for the unnamed
+					   common block; this is unique
+					   because of underscores */
+
+#define LABELFMT "%s:\n"
+
+#define MAXREGVAR 4
+#define TYIREG TYLONG
+#define MSKIREG  (M(TYSHORT)|M(TYLONG))	/* allowed types of DO indicies
+					   which can be put in registers */

+ 590 - 0
lang/fortran/comp/main.c

@@ -0,0 +1,590 @@
+/****************************************************************
+Copyright 1990, 1991 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+extern char F2C_version[];
+
+#include "defs.h"
+#include "parse.h"
+
+int complex_seen, dcomplex_seen;
+
+LOCAL int Max_ftn_files;
+
+char **ftn_files;
+int current_ftn_file = 0;
+
+flag ftn66flag = NO;
+flag nowarnflag = NO;
+flag noextflag = NO;
+flag  no66flag = NO;		/* Must also set noextflag to this
+					   same value */
+flag zflag = YES;		/* recognize double complex intrinsics */
+flag debugflag = NO;
+flag onetripflag = NO;
+flag shiftcase = YES;
+flag undeftype = NO;
+flag checksubs = NO;
+flag r8flag = NO;
+flag use_bs = YES;
+int tyreal = TYREAL;
+int tycomplex = TYCOMPLEX;
+extern void r8fix(), read_Pfiles();
+
+int maxregvar = MAXREGVAR;	/* if maxregvar > MAXREGVAR, error */
+int maxequiv = MAXEQUIV;
+int maxext = MAXEXT;
+int maxstno = MAXSTNO;
+int maxctl = MAXCTL;
+int maxhash = MAXHASH;
+int maxliterals = MAXLITERALS;
+int extcomm, ext1comm, useauto;
+int can_include = YES;	/* so we can disable includes for netlib */
+
+static char *def_i2 = "";
+
+static int useshortints = NO;	/* YES => tyint = TYSHORT */
+static int uselongints = NO;	/* YES => tyint = TYLONG */
+int addftnsrc = NO;		/* Include ftn source in output */
+int usedefsforcommon = NO;	/* Use #defines for common reference */
+int forcedouble = YES;		/* force real functions to double */
+int Ansi = NO;
+int def_equivs = YES;
+int tyioint = TYLONG;
+int szleng = SZLENG;
+int inqmask = M(TYLONG)|M(TYLOGICAL);
+int wordalign = NO;
+int forcereal = NO;
+static int skipC, skipversion;
+char *filename0, *parens;
+int Castargs = 1;
+static int typedefs = 0;
+int chars_per_wd, gflag, protostatus;
+int infertypes = 1;
+char used_rets[TYSUBR+1];
+extern char *tmpdir;
+static int h0align = 0;
+char *halign, *ohalign;
+int krparens = NO;
+int hsize;	/* for padding under -h */
+int htype;	/* for wr_equiv_init under -h */
+
+#define f2c_entry(swit,count,type,store,size) \
+	p_entry ("-", swit, 0, count, type, store, size)
+
+static arg_info table[] = {
+    f2c_entry ("w66", P_NO_ARGS, P_INT, &ftn66flag, YES),
+    f2c_entry ("w", P_NO_ARGS, P_INT, &nowarnflag, YES),
+    f2c_entry ("66", P_NO_ARGS, P_INT, &no66flag, YES),
+    f2c_entry ("d", P_ONE_ARG, P_INT, &debugflag, YES),
+    f2c_entry ("1", P_NO_ARGS, P_INT, &onetripflag, YES),
+    f2c_entry ("onetrip", P_NO_ARGS, P_INT, &onetripflag, YES),
+    f2c_entry ("I2", P_NO_ARGS, P_INT, &useshortints, YES),
+    f2c_entry ("I4", P_NO_ARGS, P_INT, &uselongints, YES),
+    f2c_entry ("U", P_NO_ARGS, P_INT, &shiftcase, NO),
+    f2c_entry ("u", P_NO_ARGS, P_INT, &undeftype, YES),
+    f2c_entry ("O", P_ONE_ARG, P_INT, &maxregvar, 0),
+    f2c_entry ("C", P_NO_ARGS, P_INT, &checksubs, YES),
+    f2c_entry ("Nq", P_ONE_ARG, P_INT, &maxequiv, 0),
+    f2c_entry ("Nx", P_ONE_ARG, P_INT, &maxext, 0),
+    f2c_entry ("Ns", P_ONE_ARG, P_INT, &maxstno, 0),
+    f2c_entry ("Nc", P_ONE_ARG, P_INT, &maxctl, 0),
+    f2c_entry ("Nn", P_ONE_ARG, P_INT, &maxhash, 0),
+    f2c_entry ("NL", P_ONE_ARG, P_INT, &maxliterals, 0),
+    f2c_entry ("c", P_NO_ARGS, P_INT, &addftnsrc, YES),
+    f2c_entry ("p", P_NO_ARGS, P_INT, &usedefsforcommon, YES),
+    f2c_entry ("R", P_NO_ARGS, P_INT, &forcedouble, NO),
+    f2c_entry ("!R", P_NO_ARGS, P_INT, &forcedouble, YES),
+    f2c_entry ("A", P_NO_ARGS, P_INT, &Ansi, YES),
+    f2c_entry ("ext", P_NO_ARGS, P_INT, &noextflag, YES),
+    f2c_entry ("z", P_NO_ARGS, P_INT, &zflag, NO),
+    f2c_entry ("a", P_NO_ARGS, P_INT, &useauto, YES),
+    f2c_entry ("r8", P_NO_ARGS, P_INT, &r8flag, YES),
+    f2c_entry ("i2", P_NO_ARGS, P_INT, &tyioint, NO),
+    f2c_entry ("w8", P_NO_ARGS, P_INT, &wordalign, YES),
+    f2c_entry ("!I", P_NO_ARGS, P_INT, &can_include, NO),
+    f2c_entry ("W", P_ONE_ARG, P_INT, &chars_per_wd, 0),
+    f2c_entry ("g", P_NO_ARGS, P_INT, &gflag, YES),
+    f2c_entry ("T", P_ONE_ARG, P_STRING, &tmpdir, 0),
+    f2c_entry ("E", P_NO_ARGS, P_INT, &extcomm, 1),
+    f2c_entry ("e1c", P_NO_ARGS, P_INT, &ext1comm, 1),
+    f2c_entry ("ec", P_NO_ARGS, P_INT, &ext1comm, 2),
+    f2c_entry ("C++", P_NO_ARGS, P_INT, &Ansi, 2),
+    f2c_entry ("P", P_NO_ARGS, P_INT, &Castargs, 3),
+    f2c_entry ("Ps", P_NO_ARGS, P_INT, &protostatus, 1),
+    f2c_entry ("!P", P_NO_ARGS, P_INT, &Castargs, 0),
+    f2c_entry ("!c", P_NO_ARGS, P_INT, &skipC, 1),
+    f2c_entry ("!it", P_NO_ARGS, P_INT, &infertypes, 0),
+    f2c_entry ("h", P_NO_ARGS, P_INT, &h0align, 1),
+    f2c_entry ("hd", P_NO_ARGS, P_INT, &h0align, 2),
+    f2c_entry ("kr", P_NO_ARGS, P_INT, &krparens, 1),
+    f2c_entry ("krd", P_NO_ARGS, P_INT, &krparens, 2),
+    f2c_entry ("!bs", P_NO_ARGS, P_INT, &use_bs, NO),
+    f2c_entry ("r", P_NO_ARGS, P_INT, &forcereal, YES),
+
+	/* options omitted from man pages */
+
+	/* -ev ==> implement equivalence with initialized pointers */
+    f2c_entry ("ev", P_NO_ARGS, P_INT, &def_equivs, NO),
+
+	/* -!it used to be the default when -it was more agressive */
+
+    f2c_entry ("it", P_NO_ARGS, P_INT, &infertypes, 1),
+
+	/* -Pd is similar to -P, but omits :ref: lines */
+    f2c_entry ("Pd", P_NO_ARGS, P_INT, &Castargs, 2),
+
+	/* -t ==> emit typedefs (under -A or -C++) for procedure
+		argument types used.  This is meant for netlib's
+		f2c service, so -A and -C++ will work with older
+		versions of f2c.h
+		*/
+    f2c_entry ("t", P_NO_ARGS, P_INT, &typedefs, 1),
+
+	/* -!V ==> omit version msg (to facilitate using diff in
+		regression testing)
+		*/
+    f2c_entry ("!V", P_NO_ARGS, P_INT, &skipversion, 1)
+
+}; /* table */
+
+extern char *c_functions;	/* "c_functions"	*/
+extern char *coutput;		/* "c_output"		*/
+extern char *initfname;		/* "raw_data"		*/
+extern char *blkdfname;		/* "block_data"		*/
+extern char *p1_file;		/* "p1_file"		*/
+extern char *p1_bakfile;	/* "p1_file.BAK"	*/
+extern char *sortfname;		/* "init_file"		*/
+static char *proto_fname;	/* "proto_file"		*/
+FILE *protofile;
+
+extern void list_init_data(), set_tmp_names(), sigcatch(), Un_link_all();
+extern char *c_name();
+
+
+set_externs ()
+{
+    static char *hset[3] = { 0, "integer", "doublereal" };
+
+/* Adjust the global flags according to the command line parameters */
+
+    if (chars_per_wd > 0) {
+	typesize[TYADDR] = typesize[TYLONG] = typesize[TYREAL] =
+		typesize[TYLOGICAL] = chars_per_wd;
+	typesize[TYDREAL] = typesize[TYCOMPLEX] = chars_per_wd << 1;
+	typesize[TYDCOMPLEX] = chars_per_wd << 2;
+	typesize[TYSHORT] = chars_per_wd >> 1;
+	typesize[TYCILIST] = 5*chars_per_wd;
+	typesize[TYICILIST] = 6*chars_per_wd;
+	typesize[TYOLIST] = 9*chars_per_wd;
+	typesize[TYCLLIST] = 3*chars_per_wd;
+	typesize[TYALIST] = 2*chars_per_wd;
+	typesize[TYINLIST] = 26*chars_per_wd;
+	}
+
+    if (wordalign)
+	typealign[TYDREAL] = typealign[TYDCOMPLEX] = typealign[TYREAL];
+    if (!tyioint) {
+	tyioint = TYSHORT;
+	szleng = typesize[TYSHORT];
+	def_i2 = "#define f2c_i2 1\n";
+	inqmask = M(TYSHORT)|M(TYLOGICAL);
+	goto checklong;
+	}
+    else
+	szleng = typesize[TYLONG];
+    if (useshortints) {
+	inqmask = M(TYLONG);
+ checklong:
+	protorettypes[TYLOGICAL] = typename[TYLOGICAL] = "shortlogical";
+	typesize[TYLOGICAL] = typesize[TYSHORT];
+	casttypes[TYLOGICAL] = "K_fp";
+	if (uselongints)
+	    err ("Can't use both long and short ints");
+	else
+	    tyint = tylogical = TYSHORT;
+	}
+    else if (uselongints)
+	tyint = TYLONG;
+
+    if (h0align) {
+	if (tyint == TYLONG && wordalign)
+		h0align = 1;
+    	ohalign = halign = hset[h0align];
+	htype = h0align == 1 ? tyint : TYDREAL;
+	hsize = typesize[htype];
+	}
+
+    if (no66flag)
+	noextflag = no66flag;
+    if (noextflag)
+	zflag = 0;
+
+    if (r8flag) {
+	tyreal = TYDREAL;
+	tycomplex = TYDCOMPLEX;
+	r8fix();
+	}
+    if (forcedouble) {
+	protorettypes[TYREAL] = "E_f";
+	casttypes[TYREAL] = "E_fp";
+	}
+
+    if (maxregvar > MAXREGVAR) {
+	warni("-O%d: too many register variables", maxregvar);
+	maxregvar = MAXREGVAR;
+    } /* if maxregvar > MAXREGVAR */
+
+/* Check the list of input files */
+
+    {
+	int bad, i, cur_max = Max_ftn_files;
+
+	for (i = bad = 0; i < cur_max && ftn_files[i]; i++)
+	    if (ftn_files[i][0] == '-') {
+		errstr ("Invalid flag '%s'", ftn_files[i]);
+		bad++;
+		}
+	if (bad)
+		exit(1);
+
+    } /* block */
+} /* set_externs */
+
+
+ static int
+comm2dcl()
+{
+	Extsym *ext;
+	if (ext1comm)
+		for(ext = extsymtab; ext < nextext; ext++)
+			if (ext->extstg == STGCOMMON && !ext->extinit)
+				return ext1comm;
+	return 0;
+	}
+
+ static void
+write_typedefs(outfile)
+ FILE *outfile;
+{
+	register int i;
+	register char *s, *p = 0;
+	static char st[4] = { TYREAL, TYCOMPLEX, TYDCOMPLEX, TYCHAR };
+	static char stl[4] = { 'E', 'C', 'Z', 'H' };
+
+	for(i = 0; i <= TYSUBR; i++)
+		if (s = usedcasts[i]) {
+			if (!p) {
+				p = Ansi == 1 ? "()" : "(...)";
+				nice_printf(outfile,
+				"/* Types for casting procedure arguments: */\
+\n\n#ifndef F2C_proc_par_types\n");
+				if (i == 0) {
+					nice_printf(outfile,
+			"typedef int /* Unknown procedure type */ (*%s)%s;\n",
+						 s, p);
+					continue;
+					}
+				}
+			nice_printf(outfile, "typedef %s (*%s)%s;\n",
+					c_type_decl(i,1), s, p);
+			}
+	for(i = !forcedouble; i < 4; i++)
+		if (used_rets[st[i]])
+			nice_printf(outfile,
+				"typedef %s %c_f; /* %s function */\n",
+				p = i ? "VOID" : "doublereal",
+				stl[i], ftn_types[st[i]]);
+	if (p)
+		nice_printf(outfile, "#endif\n\n");
+	}
+
+ static void
+commonprotos(outfile)
+ register FILE *outfile;
+{
+	register Extsym *e, *ee;
+	register Argtypes *at;
+	Atype *a, *ae;
+	int k;
+	extern int proc_protochanges;
+
+	if (!outfile)
+		return;
+	for (e = extsymtab, ee = nextext; e < ee; e++)
+		if (e->extstg == STGCOMMON && e->allextp)
+			nice_printf(outfile, "/* comlen %s %ld */\n",
+				e->cextname, e->maxleng);
+	if (Castargs < 3)
+		return;
+
+	/* -Pr: special comments conveying current knowledge
+	    of external references */
+
+	k = proc_protochanges;
+	for (e = extsymtab, ee = nextext; e < ee; e++)
+		if (e->extstg == STGEXT
+		&& e->cextname != e->fextname)	/* not a library function */
+		    if (at = e->arginfo) {
+			if ((!e->extinit || at->changes & 1)
+				/* not defined here or
+					changed since definition */
+			&& at->nargs >= 0) {
+				nice_printf(outfile, "/*:ref: %s %d %d",
+					e->cextname, e->extype, at->nargs);
+				a = at->atypes;
+				for(ae = a + at->nargs; a < ae; a++)
+					nice_printf(outfile, " %d", a->type);
+				nice_printf(outfile, " */\n");
+				if (at->changes & 1)
+					k++;
+				}
+			}
+		    else if (e->extype)
+			/* typed external, never invoked */
+			nice_printf(outfile, "/*:ref: %s %d :*/\n",
+				e->cextname, e->extype);
+	if (k) {
+		nice_printf(outfile,
+	"/* Rerunning f2c -P may change prototypes or declarations. */\n");
+		if (nerr)
+			return;
+		if (protostatus)
+			done(4);
+		if (protofile != stdout) {
+			fprintf(diagfile,
+	"Rerunning \"f2c -P ... %s %s\" may change prototypes or declarations.\n",
+				filename0, proto_fname);
+			fflush(diagfile);
+			}
+		}
+	}
+
+ int retcode = 0;
+
+main(argc, argv)
+int argc;
+char **argv;
+{
+	int c2d, k;
+	FILE *c_output;
+	char *filename, *cdfilename;
+	static char stderrbuf[BUFSIZ];
+	extern void def_commons();
+	extern char **dfltproc, *dflt1proc[];
+	extern char link_msg[];
+
+	diagfile = stderr;
+	setbuf(stderr, stderrbuf);	/* arrange for fast error msgs */
+
+	Max_ftn_files = argc - 1;
+	ftn_files = (char **)ckalloc((argc+1)*sizeof(char *));
+
+	parse_args (argc, argv, table, sizeof(table)/sizeof(arg_info),
+		ftn_files, Max_ftn_files);
+	if (!can_include && ext1comm == 2)
+		ext1comm = 1;
+	if (ext1comm && !extcomm)
+		extcomm = 2;
+	if (protostatus)
+		Castargs = 3;
+	else if (Castargs == 1 && !Ansi)
+		Castargs = 0;
+	if (Castargs >= 2 && !Ansi)
+		Ansi = 1;
+
+	if (!Ansi)
+		parens = "()";
+	else if (!Castargs)
+		parens = Ansi == 1 ? "()" : "(...)";
+	else
+		dfltproc = dflt1proc;
+
+	set_externs();
+	fileinit();
+	read_Pfiles(ftn_files);
+
+	for(k = 1; ftn_files[k]; k++)
+		if (dofork())
+			break;
+	filename0 = filename = ftn_files[current_ftn_file = k - 1];
+
+	set_tmp_names();
+	sigcatch();
+
+	c_file   = opf(c_functions, textwrite);
+	pass1_file=opf(p1_file, binwrite);
+	initkey();
+	if (filename && *filename) {
+		if (debugflag != 1) {
+			coutput = c_name(filename,'c');
+			if (Castargs >= 2)
+				proto_fname = c_name(filename,'P');
+			}
+		cdfilename = coutput;
+		if (skipC)
+			coutput = 0;
+		else if (!(c_output = fopen(coutput, textwrite))) {
+			filename = coutput;
+			coutput = 0;	/* don't delete read-only .c file */
+			fatalstr("can't open %.86s", filename);
+			}
+
+		if (Castargs >= 2
+		&& !(protofile = fopen(proto_fname, textwrite)))
+			fatalstr("Can't open %.84s\n", proto_fname);
+		}
+	else {
+		filename = "";
+		cdfilename = "f2c_out.c";
+		c_output = stdout;
+		coutput = 0;
+		if (Castargs >= 2) {
+			protofile = stdout;
+			if (!skipC)
+				printf("#ifdef P_R_O_T_O_T_Y_P_E_S\n");
+			}
+		}
+
+	if(inilex( copys(filename) ))
+		done(1);
+	if (filename0) {
+		fprintf(diagfile, "%s:\n", filename);
+		fflush(diagfile);
+		}
+
+	procinit();
+	if(k = yyparse())
+	{
+		fprintf(diagfile, "Bad parse, return code %d\n", k);
+		done(1);
+	}
+
+	commonprotos(protofile);
+	if (protofile == stdout && !skipC)
+		printf("#endif\n\n");
+
+	if (nerr || skipC)
+		goto C_skipped;
+
+
+/* Write out the declarations which are global to this file */
+
+	if ((c2d = comm2dcl()) == 1)
+		nice_printf(c_output, "/*>>>'/dev/null'<<<*/\n\n\
+/* Split this into several files by piping it through\n\n\
+sed \"s/^\\/\\*>>>'\\(.*\\)'<<<\\*\\/\\$/cat >'\\1' <<'\\/*<<<\\1>>>*\\/'/\" | /bin/sh\n\
+ */\n\
+/*<<</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);
+}

+ 84 - 0
lang/fortran/comp/makefile

@@ -0,0 +1,84 @@
+#	Makefile for f2c, a Fortran 77 to C converter
+
+g = -g
+CFLAGS = $g
+SHELL = /bin/sh
+
+OBJECTSd = main.o init.o gram.o lex.o proc.o equiv.o data.o format.o \
+	  expr.o exec.o intr.o io.o misc.o error.o mem.o names.o \
+	  output.o p1output.o pread.o put.o putpcc.o vax.o formatdata.o \
+	  parse_args.o niceprintf.o cds.o sysdep.o version.o
+OBJECTS = $(OBJECTSd) malloc.o
+
+all: xsum.out f2c
+
+f2c: $(OBJECTS)
+	$(CC) $(LDFLAGS) $(OBJECTS) -o f2c
+	size f2c
+
+gram.c:	gram.head gram.dcl gram.expr gram.exec gram.io defs.h tokdefs.h
+	( sed <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

+ 142 - 0
lang/fortran/comp/malloc.c

@@ -0,0 +1,142 @@
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+#ifndef CRAY
+#define STACKMIN 512
+#define MINBLK (2*sizeof(struct mem) + 16)
+#define MSTUFF _malloc_stuff_
+#define F MSTUFF.free
+#define B MSTUFF.busy
+#define SBGULP 8192
+char *memcpy();
+
+struct mem {
+	struct mem *next;
+	unsigned len;
+	};
+
+struct {
+	struct mem *free;
+	char *busy;
+	} MSTUFF;
+
+char *
+malloc(size)
+register unsigned size;
+{
+	register struct mem *p, *q, *r, *s;
+	unsigned register k, m;
+	extern char *sbrk();
+	char *top, *top1;
+
+	size = (size+7) & ~7;
+	r = (struct mem *) &F;
+	for (p = F, q = 0; p; r = p, p = p->next) {
+		if ((k = p->len) >= size && (!q || m > k)) { m = k; q = p; s = r; }
+		}
+	if (q) {
+		if (q->len - size >= MINBLK) { /* split block */
+			p = (struct mem *) (((char *) (q+1)) + size);
+			p->next = q->next;
+			p->len = q->len - size - sizeof(struct mem);
+			s->next = p;
+			q->len = size;
+			}
+		else s->next = q->next;
+		}
+	else {
+		top = B ? B : (char *)(((long)sbrk(0) + 7) & ~7);
+		if (F && (char *)(F+1) + F->len == B)
+			{ q = F; F = F->next; }
+		else q = (struct mem *) top;
+		top1 = (char *)(q+1) + size;
+		if (top1 > top) {
+			if (sbrk((int)(top1-top+SBGULP)) == (char *) -1)
+				return 0;
+			r = (struct mem *)top1;
+			r->len = SBGULP - sizeof(struct mem);
+			r->next = F;
+			F = r;
+			top1 += SBGULP;
+			}
+		q->len = size;
+		B = top1;
+		}
+	return (char *) (q+1);
+	}
+
+free(f)
+char *f;
+{
+	struct mem *p, *q, *r;
+	char *pn, *qn;
+
+	if (!f) return;
+	q = (struct mem *) (f - sizeof(struct mem));
+	qn = f + q->len;
+	for (p = F, r = (struct mem *) &F; ; r = p, p = p->next) {
+		if (qn == (char *) p) {
+			q->len += p->len + sizeof(struct mem);
+			p = p->next;
+			}
+		pn = p ? ((char *) (p+1)) + p->len : 0;
+		if (pn == (char *) q) {
+			p->len += sizeof(struct mem) + q->len;
+			q->len = 0;
+			q->next = p;
+			r->next = p;
+			break;
+			}
+		if (pn < (char *) q) {
+			r->next = q;
+			q->next = p;
+			break;
+			}
+		}
+	}
+
+char *
+realloc(f, size)
+char *f;
+unsigned size;
+{
+	struct mem *p;
+	char *q, *f1;
+	unsigned s1;
+
+	if (!f) return malloc(size);
+	p = (struct mem *) (f - sizeof(struct mem));
+	s1 = p->len;
+	free(f);
+	if (s1 > size) s1 = size + 7 & ~7;
+	if (!p->len) {
+		f1 = (char *)(p->next + 1);
+		memcpy(f1, f, s1);
+		f = f1;
+		}
+	q = malloc(size);
+	if (q && q != f)
+		memcpy(q, f, s1);
+	return q;
+	}
+#endif

+ 230 - 0
lang/fortran/comp/mem.c

@@ -0,0 +1,230 @@
+/****************************************************************
+Copyright 1990, 1991 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+#include "defs.h"
+#include "iob.h"
+
+#define MEMBSIZE	32000
+#define GMEMBSIZE	16000
+
+ extern void exit();
+
+ char *
+gmem(n, round)
+ int n, round;
+{
+	static char *last, *next;
+	char *rv;
+	if (round)
+#ifdef CRAY
+		if ((long)next & 0xe000000000000000)
+			next = (char *)(((long)next & 0x1fffffffffffffff) + 1);
+#else
+#ifdef MSDOS
+		if ((int)next & 1)
+			next++;
+#else
+		next = (char *)(((long)next + sizeof(char *)-1)
+				& ~((long)sizeof(char *)-1));
+#endif
+#endif
+	rv = next;
+	if ((next += n) > last) {
+		rv = Alloc(n + GMEMBSIZE);
+
+		next = rv + n;
+		last = next + GMEMBSIZE;
+		}
+	return rv;
+	}
+
+ struct memblock {
+	struct memblock *next;
+	char buf[MEMBSIZE];
+	};
+ typedef struct memblock memblock;
+
+ static memblock *mem0;
+ memblock *curmemblock, *firstmemblock;
+
+ char *mem_first, *mem_next, *mem_last, *mem0_last;
+
+ void
+mem_init()
+{
+	curmemblock = firstmemblock = mem0
+		= (memblock *)Alloc(sizeof(memblock));
+	mem_first = mem0->buf;
+	mem_next  = mem0->buf;
+	mem_last  = mem0->buf + MEMBSIZE;
+	mem0_last = mem0->buf + MEMBSIZE;
+	mem0->next = 0;
+	}
+
+ char *
+mem(n, round)
+ int n, round;
+{
+	memblock *b;
+	register char *rv, *s;
+
+	if (round)
+#ifdef CRAY
+		if ((long)mem_next & 0xe000000000000000)
+			mem_next = (char *)(((long)mem_next & 0x1fffffffffffffff) + 1);
+#else
+#ifdef MSDOS
+		if ((int)mem_next & 1)
+			mem_next++;
+#else
+		mem_next = (char *)(((long)mem_next + sizeof(char *)-1)
+				& ~((long)sizeof(char *)-1));
+#endif
+#endif
+	rv = mem_next;
+	s = rv + n;
+	if (s >= mem_last) {
+		if (n > MEMBSIZE)  {
+			fprintf(stderr, "mem(%d) failure!\n", n);
+			exit(1);
+			}
+		if (!(b = curmemblock->next)) {
+			b = (memblock *)Alloc(sizeof(memblock));
+			curmemblock->next = b;
+			b->next = 0;
+			}
+		curmemblock = b;
+		rv = b->buf;
+		mem_last = rv + sizeof(b->buf);
+		s = rv + n;
+		}
+	mem_next = s;
+	return rv;
+	}
+
+ char *
+tostring(s,n)
+ register char *s;
+ int n;
+{
+	register char *s1, *se, **sf;
+	char *rv, *s0;
+	register int k = n + 2, t;
+
+	sf = str_fmt;
+	sf['%'] = "%";
+	s0 = s;
+	se = s + n;
+	for(; s < se; s++) {
+		t = *(unsigned char *)s;
+		s1 = sf[t];
+		while(*++s1)
+			k++;
+		}
+	sf['%'] = "%%";
+	rv = s1 = mem(k,0);
+	*s1++ = '"';
+	for(s = s0; s < se; s++) {
+		t = *(unsigned char *)s;
+		sprintf(s1, sf[t], t);
+		s1 += strlen(s1);
+		}
+	*s1 = 0;
+	return rv;
+	}
+
+ char *
+cpstring(s)
+ register char *s;
+{
+	return strcpy(mem(strlen(s)+1,0), s);
+	}
+
+ void
+new_iob_data(ios, name)
+ register io_setup *ios;
+ char *name;
+{
+	register iob_data *iod;
+	register char **s, **se;
+
+	iod = (iob_data *)
+		mem(sizeof(iob_data) + ios->nelt*sizeof(char *), 1);
+	iod->next = iob_list;
+	iob_list = iod;
+	iod->type = ios->fields[0];
+	iod->name = cpstring(name);
+	s = iod->fields;
+	se = s + ios->nelt;
+	while(s < se)
+		*s++ = "0";
+	*s = 0;
+	}
+
+ char *
+string_num(pfx, n)
+ char *pfx;
+ long n;
+{
+	char buf[32];
+	sprintf(buf, "%s%ld", pfx, n);
+	/* can't trust return type of sprintf -- BSD gets it wrong */
+	return strcpy(mem(strlen(buf)+1,0), buf);
+	}
+
+static defines *define_list;
+
+ void
+def_start(outfile, s1, s2, post)
+ FILE *outfile;
+ char *s1, *s2, *post;
+{
+	defines *d;
+	int n, n1;
+
+	n = n1 = strlen(s1);
+	if (s2)
+		n += strlen(s2);
+	d = (defines *)mem(sizeof(defines)+n, 1);
+	d->next = define_list;
+	define_list = d;
+	strcpy(d->defname, s1);
+	if (s2)
+		strcpy(d->defname + n1, s2);
+	nice_printf(outfile, "#define %s %s", d->defname, post);
+	}
+
+ void
+other_undefs(outfile)
+ FILE *outfile;
+{
+	defines *d;
+	if (d = define_list) {
+		define_list = 0;
+		nice_printf(outfile, "\n");
+		do
+			nice_printf(outfile, "#undef %s\n", d->defname);
+			while(d = d->next);
+		nice_printf(outfile, "\n");
+		}
+	}

+ 66 - 0
lang/fortran/comp/memset.c

@@ -0,0 +1,66 @@
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+/* This is for the benefit of people whose systems don't provide
+ * memset, memcpy, and memcmp.  If yours is such a system, adjust
+ * the makefile by adding memset.o to the "OBJECTS =" assignment.
+ * WARNING: the memcpy below is adequate for f2c, but is not a
+ * general memcpy routine (which must correctly handle overlapping
+ * fields).
+ */
+
+ int
+memcmp(s1, s2, n)
+ register char *s1, *s2;
+ int n;
+{
+	register char *se;
+
+	for(se = s1 + n; s1 < se; s1++, s2++)
+		if (*s1 != *s2)
+			return *s1 - *s2;
+	return 0;
+	}
+
+ char *
+memcpy(s1, s2, n)
+ register char *s1, *s2;
+ int n;
+{
+	register char *s0 = s1, *se = s1 + n;
+
+	while(s1 < se)
+		*s1++ = *s2++;
+	return s0;
+	}
+
+memset(s, c, n)
+ register char *s;
+ register int c;
+ int n;
+{
+	register char *se = s + n;
+
+	while(s < se)
+		*s++ = c;
+	}

+ 1041 - 0
lang/fortran/comp/misc.c

@@ -0,0 +1,1041 @@
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+#include "defs.h"
+
+int oneof_stg (name, stg, mask)
+ Namep name;
+ int stg, mask;
+{
+	if (stg == STGCOMMON && name) {
+		if ((mask & M(STGEQUIV)))
+			return name->vcommequiv;
+		if ((mask & M(STGCOMMON)))
+			return !name->vcommequiv;
+		}
+	return ONEOF(stg, mask);
+	}
+
+
+/* op_assign -- given a binary opcode, return the associated assignment
+   operator */
+
+int op_assign (opcode)
+int opcode;
+{
+    int retval = -1;
+
+    switch (opcode) {
+        case OPPLUS: retval = OPPLUSEQ; break;
+	case OPMINUS: retval = OPMINUSEQ; break;
+	case OPSTAR: retval = OPSTAREQ; break;
+	case OPSLASH: retval = OPSLASHEQ; break;
+	case OPMOD: retval = OPMODEQ; break;
+	case OPLSHIFT: retval = OPLSHIFTEQ; break;
+	case OPRSHIFT: retval = OPRSHIFTEQ; break;
+	case OPBITAND: retval = OPBITANDEQ; break;
+	case OPBITXOR: retval = OPBITXOREQ; break;
+	case OPBITOR: retval = OPBITOREQ; break;
+	default:
+	    erri ("op_assign:  bad opcode '%d'", opcode);
+	    break;
+    } /* switch */
+
+    return retval;
+} /* op_assign */
+
+
+ char *
+Alloc(n)	/* error-checking version of malloc */
+		/* ckalloc initializes memory to 0; Alloc does not */
+ int n;
+{
+	char errbuf[32];
+	register char *rv;
+
+	rv = malloc(n);
+	if (!rv) {
+		sprintf(errbuf, "malloc(%d) failure!", n);
+		Fatal(errbuf);
+		}
+	return rv;
+	}
+
+
+cpn(n, a, b)
+register int n;
+register char *a, *b;
+{
+	while(--n >= 0)
+		*b++ = *a++;
+}
+
+
+
+eqn(n, a, b)
+register int n;
+register char *a, *b;
+{
+	while(--n >= 0)
+		if(*a++ != *b++)
+			return(NO);
+	return(YES);
+}
+
+
+
+
+
+
+
+cmpstr(a, b, la, lb)	/* compare two strings */
+register char *a, *b;
+ftnint la, lb;
+{
+	register char *aend, *bend;
+	aend = a + la;
+	bend = b + lb;
+
+
+	if(la <= lb)
+	{
+		while(a < aend)
+			if(*a != *b)
+				return( *a - *b );
+			else
+			{
+				++a;
+				++b;
+			}
+
+		while(b < bend)
+			if(*b != ' ')
+				return(' ' - *b);
+			else
+				++b;
+	}
+
+	else
+	{
+		while(b < bend)
+			if(*a != *b)
+				return( *a - *b );
+			else
+			{
+				++a;
+				++b;
+			}
+		while(a < aend)
+			if(*a != ' ')
+				return(*a - ' ');
+			else
+				++a;
+	}
+	return(0);
+}
+
+
+/* hookup -- Same as LISP NCONC, that is a destructive append of two lists */
+
+chainp hookup(x,y)
+register chainp x, y;
+{
+	register chainp p;
+
+	if(x == NULL)
+		return(y);
+
+	for(p = x ; p->nextp ; p = p->nextp)
+		;
+	p->nextp = y;
+	return(x);
+}
+
+
+
+struct Listblock *mklist(p)
+chainp p;
+{
+	register struct Listblock *q;
+
+	q = ALLOC(Listblock);
+	q->tag = TLIST;
+	q->listp = p;
+	return(q);
+}
+
+
+chainp mkchain(p,q)
+register char * p;
+register chainp q;
+{
+	register chainp r;
+
+	if(chains)
+	{
+		r = chains;
+		chains = chains->nextp;
+	}
+	else
+		r = ALLOC(Chain);
+
+	r->datap = p;
+	r->nextp = q;
+	return(r);
+}
+
+ chainp
+revchain(next)
+ register chainp next;
+{
+	register chainp p, prev = 0;
+
+	while(p = next) {
+		next = p->nextp;
+		p->nextp = prev;
+		prev = p;
+		}
+	return prev;
+	}
+
+
+/* addunder -- turn a cvarname into an external name */
+/* The cvarname may already end in _ (to avoid C keywords); */
+/* if not, it has room for appending an _. */
+
+ char *
+addunder(s)
+ register char *s;
+{
+	register int c, i;
+	char *s0 = s;
+
+	i = 0;
+	while(c = *s++)
+		if (c == '_')
+			i++;
+		else
+			i = 0;
+	if (!i) {
+		*s-- = 0;
+		*s = '_';
+		}
+	return( s0 );
+	}
+
+
+/* copyn -- return a new copy of the input Fortran-string */
+
+char *copyn(n, s)
+register int n;
+register char *s;
+{
+	register char *p, *q;
+
+	p = q = (char *) Alloc(n);
+	while(--n >= 0)
+		*q++ = *s++;
+	return(p);
+}
+
+
+
+/* copys -- return a new copy of the input C-string */
+
+char *copys(s)
+char *s;
+{
+	return( copyn( strlen(s)+1 , s) );
+}
+
+
+
+/* convci -- Convert Fortran-string to integer; assumes that input is a
+   legal number, with no trailing blanks */
+
+ftnint convci(n, s)
+register int n;
+register char *s;
+{
+	ftnint sum;
+	sum = 0;
+	while(n-- > 0)
+		sum = 10*sum + (*s++ - '0');
+	return(sum);
+}
+
+/* convic - Convert Integer constant to string */
+
+char *convic(n)
+ftnint n;
+{
+	static char s[20];
+	register char *t;
+
+	s[19] = '\0';
+	t = s+19;
+
+	do	{
+		*--t = '0' + n%10;
+		n /= 10;
+	} while(n > 0);
+
+	return(t);
+}
+
+
+
+/* mkname -- add a new identifier to the environment, including the closed
+   hash table. */
+
+Namep mkname(s)
+register char *s;
+{
+	struct Hashentry *hp;
+	register Namep q;
+	register int c, hash, i;
+	register char *t;
+	char *s0;
+	char errbuf[64];
+
+	hash = i = 0;
+	s0 = s;
+	while(c = *s++) {
+		hash += c;
+		if (c == '_')
+			i = 1;
+		}
+	hash %= maxhash;
+
+/* Add the name to the closed hash table */
+
+	hp = hashtab + hash;
+
+	while(q = hp->varp)
+		if( hash == hp->hashval && !strcmp(s0,q->fvarname) )
+			return(q);
+		else if(++hp >= lasthash)
+			hp = hashtab;
+
+	if(++nintnames >= maxhash-1)
+		many("names", 'n', maxhash);	/* Fatal error */
+	hp->varp = q = ALLOC(Nameblock);
+	hp->hashval = hash;
+	q->tag = TNAME;	/* TNAME means the tag type is NAME */
+	c = s - s0;
+	if (c > 7 && noextflag) {
+		sprintf(errbuf, "\"%.35s%s\" over 6 characters long", s0,
+			c > 36 ? "..." : "");
+		errext(errbuf);
+		}
+	q->fvarname = strcpy(mem(c,0), s0);
+	t = q->cvarname = mem(c + i + 1, 0);
+	s = s0;
+	/* add __ to the end of any name containing _ */
+	while(*t = *s++)
+		t++;
+	if (i) {
+		t[0] = t[1] = '_';
+		t[2] = 0;
+		}
+	else if (in_vector(s0) >= 0) {
+		t[0] = '_';
+		t[1] = 0;
+		}
+	return(q);
+}
+
+
+struct Labelblock *mklabel(l)
+ftnint l;
+{
+	register struct Labelblock *lp;
+
+	if(l <= 0)
+		return(NULL);
+
+	for(lp = labeltab ; lp < highlabtab ; ++lp)
+		if(lp->stateno == l)
+			return(lp);
+
+	if(++highlabtab > labtabend)
+		many("statement labels", 's', maxstno);
+
+	lp->stateno = l;
+	lp->labelno = newlabel();
+	lp->blklevel = 0;
+	lp->labused = NO;
+	lp->fmtlabused = NO;
+	lp->labdefined = NO;
+	lp->labinacc = NO;
+	lp->labtype = LABUNKNOWN;
+	lp->fmtstring = 0;
+	return(lp);
+}
+
+
+newlabel()
+{
+	return( ++lastlabno );
+}
+
+
+/* this label appears in a branch context */
+
+struct Labelblock *execlab(stateno)
+ftnint stateno;
+{
+	register struct Labelblock *lp;
+
+	if(lp = mklabel(stateno))
+	{
+		if(lp->labinacc)
+			warn1("illegal branch to inner block, statement label %s",
+			    convic(stateno) );
+		else if(lp->labdefined == NO)
+			lp->blklevel = blklevel;
+		if(lp->labtype == LABFORMAT)
+			err("may not branch to a format");
+		else
+			lp->labtype = LABEXEC;
+	}
+	else
+		execerr("illegal label %s", convic(stateno));
+
+	return(lp);
+}
+
+
+/* find or put a name in the external symbol table */
+
+Extsym *mkext(f,s)
+char *f, *s;
+{
+	Extsym *p;
+
+	for(p = extsymtab ; 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 */

+ 711 - 0
lang/fortran/comp/names.c

@@ -0,0 +1,711 @@
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+#include "defs.h"
+#include "output.h"
+#include "names.h"
+#include "iob.h"
+
+
+/* Names generated by the translator are guaranteed to be unique from the
+   Fortan names because Fortran does not allow underscores in identifiers,
+   and all of the system generated names do have underscores.  The various
+   naming conventions are outlined below:
+
+	FORMAT		APPLICATION
+   ----------------------------------------------------------------------
+	io_#		temporaries generated by IO calls; these will
+			contain the device number (e.g. 5, 6, 0)
+	ret_val		function return value, required for complex and
+			character functions.
+	ret_val_len	length of the return value in character functions
+
+	ssss_len	length of character argument "ssss"
+
+	c_#		member of the literal pool, where # is an
+			arbitrary label assigned by the system
+	cs_#		short integer constant in the literal pool
+	t_#		expression temporary, # is the depth of arguments
+			on the stack.
+	L#		label "#", given by user in the Fortran program.
+			This is unique because Fortran labels are numeric
+	pad_#		label on an init field required for alignment
+	xxx_init	label on a common block union, if a block data
+			requires a separate declaration
+*/
+
+/* generate variable references */
+
+char *c_type_decl (type, is_extern)
+int type, is_extern;
+{
+    static char buff[100];
+
+    switch (type) {
+	case TYADDR:	strcpy (buff, "address");	break;
+	case TYSHORT:	strcpy (buff, "shortint");	break;
+	case TYLONG:	strcpy (buff, "integer");	break;
+	case TYREAL:	if (!is_extern || !forcedouble)
+				{ strcpy (buff, "real");break; }
+	case TYDREAL:	strcpy (buff, "doublereal");	break;
+	case TYCOMPLEX:	if (is_extern)
+			    strcpy (buff, Ansi	? "/* Complex */ VOID"
+						: "/* Complex */ int");
+			else
+			    strcpy (buff, "complex");
+			break;
+	case TYDCOMPLEX:if (is_extern)
+			    strcpy (buff, Ansi	? "/* Double Complex */ VOID"
+						: "/* Double Complex */ int");
+			else
+			    strcpy (buff, "doublecomplex");
+			break;
+	case TYLOGICAL:	strcpy(buff, typename[TYLOGICAL]);
+			break;
+	case TYCHAR:	if (is_extern)
+			    strcpy (buff, Ansi	? "/* Character */ VOID"
+						: "/* Character */ int");
+			else
+			    strcpy (buff, "char");
+			break;
+
+        case TYUNKNOWN:	strcpy (buff, "UNKNOWN");
+
+/* If a procedure's type is unknown, assume it's a subroutine */
+
+			if (!is_extern)
+			    break;
+
+/* Subroutines must return an INT, because they might return a label
+   value.  Even if one doesn't, the caller will EXPECT it to. */
+
+	case TYSUBR:	strcpy (buff, "/* Subroutine */ int");
+							break;
+	case TYERROR:	strcpy (buff, "ERROR");		break;
+	case TYVOID:	strcpy (buff, "void");		break;
+	case TYCILIST:	strcpy (buff, "cilist");	break;
+	case TYICILIST:	strcpy (buff, "icilist");	break;
+	case TYOLIST:	strcpy (buff, "olist");		break;
+	case TYCLLIST:	strcpy (buff, "cllist");	break;
+	case TYALIST:	strcpy (buff, "alist");		break;
+	case TYINLIST:	strcpy (buff, "inlist");	break;
+	case TYFTNLEN:	strcpy (buff, "ftnlen");	break;
+	default:	sprintf (buff, "BAD DECL '%d'", type);
+							break;
+    } /* switch */
+
+    return buff;
+} /* c_type_decl */
+
+
+char *new_func_length()
+{ return "ret_val_len"; }
+
+char *new_arg_length(arg)
+ Namep arg;
+{
+	static char buf[64];
+	sprintf (buf, "%s_len", arg->fvarname);
+
+	return buf;
+} /* new_arg_length */
+
+
+/* declare_new_addr -- Add a new local variable to the function, given a
+   pointer to an Addrblock structure (which must have the uname_tag set)
+   This list of idents will be printed in reverse (i.e., chronological)
+   order */
+
+ void
+declare_new_addr (addrp)
+struct Addrblock *addrp;
+{
+    extern chainp new_vars;
+
+    new_vars = mkchain((char *)cpexpr((expptr)addrp), new_vars);
+} /* declare_new_addr */
+
+
+wr_nv_ident_help (outfile, addrp)
+FILE *outfile;
+struct Addrblock *addrp;
+{
+    int eltcount = 0;
+
+    if (addrp == (struct Addrblock *) NULL)
+	return;
+
+    if (addrp -> isarray) {
+	frexpr (addrp -> memoffset);
+	addrp -> memoffset = ICON(0);
+	eltcount = addrp -> ntempelt;
+	addrp -> ntempelt = 0;
+	addrp -> isarray = 0;
+    } /* if */
+    out_addr (outfile, addrp);
+    if (eltcount)
+	nice_printf (outfile, "[%d]", eltcount);
+} /* wr_nv_ident_help */
+
+int nv_type_help (addrp)
+struct Addrblock *addrp;
+{
+    if (addrp == (struct Addrblock *) NULL)
+	return -1;
+
+    return addrp -> vtype;
+} /* nv_type_help */
+
+
+/* lit_name -- returns a unique identifier for the given literal.  Make
+   the label useful, when possible.  For example:
+
+	1 -> c_1		(constant 1)
+	2 -> c_2		(constant 2)
+	1000 -> c_1000		(constant 1000)
+	1000000 -> c_b<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 *);

+ 22 - 0
lang/fortran/comp/names.h

@@ -0,0 +1,22 @@
+#define CONST_IDENT_MAX 30
+#define IO_IDENT_MAX 30
+#define ARGUMENT_MAX 30
+#define USER_LABEL_MAX 30
+
+#define EQUIV_INIT_NAME "equiv"
+
+#define write_nv_ident(fp,a) wr_nv_ident_help ((fp), (struct Addrblock *) (a))
+#define nv_type(x) nv_type_help ((struct Addrblock *) x)
+
+extern char *c_keywords[];
+
+char *new_io_ident (/* char * */);
+char *new_func_length (/* char * */);
+char *new_arg_length (/* Namep */);
+void declare_new_addr (/* struct Addrblock * */);
+char *nv_ident_help (/* struct Addrblock * */);
+int nv_type_help (/* struct Addrblock */);
+char *user_label (/* int */);
+char *temp_name (/* int, char */);
+char *c_type_decl (/* int, int */);
+char *equiv_name (/* int, char * */);

+ 367 - 0
lang/fortran/comp/niceprintf.c

@@ -0,0 +1,367 @@
+/****************************************************************
+Copyright 1990, 1991 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+#include "defs.h"
+#include "names.h"
+#include "output.h"
+
+#define TOO_LONG_INDENT (2 * tab_size)
+#define MAX_INDENT 44
+#define MIN_INDENT 22
+static int last_was_newline = 0;
+int indent = 0;
+int in_comment = 0;
+
+ static int
+write_indent(fp, use_indent, extra_indent, start, end)
+ FILE *fp;
+ int use_indent, extra_indent;
+ char *start, *end;
+{
+    int ind, tab;
+
+    if (last_was_newline && use_indent) {
+	if (*start == '\n') do {
+		putc('\n', fp);
+		if (++start > end)
+			return;
+		}
+		while(*start == '\n');
+
+	ind = indent <= MAX_INDENT
+		? indent
+		: MIN_INDENT + indent % (MAX_INDENT - MIN_INDENT);
+
+	tab = ind + extra_indent;
+
+	while (tab > 7) {
+	    putc ('\t', fp);
+	    tab -= 8;
+	} /* while */
+
+	while (tab-- > 0)
+	    putc (' ', fp);
+    } /* if last_was_newline */
+
+    while (start <= end)
+	putc (*start++, fp);
+} /* write_indent */
+
+
+/*VARARGS2*/
+int margin_printf (fp, a, b, c, d, e, f, g)
+FILE *fp;
+char *a;
+long b, c, d, e, f, g;
+{
+    ind_printf (0, fp, a, b, c, d, e, f, g);
+} /* margin_printf */
+
+/*VARARGS2*/
+int nice_printf (fp, a, b, c, d, e, f, g)
+FILE *fp;
+char *a;
+long b, c, d, e, f, g;
+{
+    ind_printf (1, fp, a, b, c, d, e, f, g);
+} /* nice_printf */
+
+
+#define  max_line_len c_output_line_length
+ 		/* 74Number of characters allowed on an output
+			           line.  This assumes newlines are handled
+			           nicely, i.e. a newline after a full text
+			           line on a terminal is ignored */
+
+/* output_buf   holds the text of the next line to be printed.  It gets
+   flushed when a newline is printed.   next_slot   points to the next
+   available location in the output buffer, i.e. where the next call to
+   nice_printf will have its output stored */
+
+static char *output_buf;
+static char *next_slot;
+static char *string_start;
+
+static char *word_start = NULL;
+static int cursor_pos = 0;
+static int In_string = 0;
+
+ void
+np_init()
+{
+	next_slot = output_buf = Alloc(MAX_OUTPUT_SIZE);
+	memset(output_buf, 0, MAX_OUTPUT_SIZE);
+	}
+
+ static char *
+adjust_pointer_in_string(pointer)
+ register char *pointer;
+{
+	register char *s, *s1, *se, *s0;
+
+	/* arrange not to break \002 */
+	s1 = string_start ? string_start : output_buf;
+	for(s = s1; s < pointer; s++) {
+		s0 = s1;
+		s1 = s;
+		if (*s == '\\') {
+			se = s++ + 4;
+			if (se > pointer)
+				break;
+			if (*s < '0' || *s > '7')
+				continue;
+			while(++s < se)
+				if (*s < '0' || *s > '7')
+					break;
+			--s;
+			}
+		}
+	return s0 - 1;
+	}
+
+/* ANSI says strcpy's behavior is undefined for overlapping args,
+ * so we roll our own fwd_strcpy: */
+
+ static void
+fwd_strcpy(t, s)
+ register char *t, *s;
+{ while(*t++ = *s++); }
+
+/* isident -- true iff character could belong to a unit.  C allows
+   letters, numbers and underscores in identifiers.  This also doubles as
+   a check for numeric constants, since we include the decimal point and
+   minus sign.  The minus has to be here, since the constant "10e-2"
+   cannot be broken up.  The '.' also prevents structure references from
+   being broken, which is a quite acceptable side effect */
+
+#define isident(x) (Tr[x] & 1)
+#define isntident(x) (!Tr[x])
+
+int ind_printf (use_indent, fp, a, b, c, d, e, f, g)
+int use_indent;
+FILE *fp;
+char *a;
+long b, c, d, e, f, g;
+{
+    extern int max_line_len;
+    extern FILEP c_file;
+    extern char tr_tab[];	/* in output.c */
+    register char *Tr = tr_tab;
+    int ch, inc, ind;
+    static int extra_indent, last_indent, set_cursor = 1;
+
+    cursor_pos += indent - last_indent;
+    last_indent = indent;
+    sprintf (next_slot, a, b, c, d, e, f, g);
+
+    if (fp != c_file) {
+	fprintf (fp,"%s", next_slot);
+	return 1;
+    } /* if fp != c_file */
+
+    do {
+	char *pointer;
+
+/* The   for   loop will parse one output line */
+
+	if (set_cursor) {
+		ind = indent <= MAX_INDENT
+			? indent
+			: MIN_INDENT + indent % (MAX_INDENT - MIN_INDENT);
+		cursor_pos = ind + extra_indent;
+		set_cursor = 0;
+		}
+	if (in_comment)
+        	for (pointer = next_slot; *pointer && *pointer != '\n' &&
+				cursor_pos <= max_line_len; pointer++)
+			cursor_pos++;
+	else
+          for (pointer = next_slot; *pointer && *pointer != '\n' &&
+		cursor_pos <= max_line_len; pointer++) {
+
+	    /* Update state variables here */
+
+	    if (In_string) {
+		switch(*pointer) {
+			case '\\':
+				if (++cursor_pos > max_line_len) {
+					cursor_pos -= 2;
+					--pointer;
+					goto overflow;
+					}
+				++pointer;
+				break;
+			case '"':
+				In_string = 0;
+				word_start = 0;
+			}
+		}
+	    else switch (*pointer) {
+	        case '"':
+			if (cursor_pos + 5 > max_line_len) {
+				word_start = 0;
+				--pointer;
+				goto overflow;
+				}
+			In_string = 1;
+			string_start = word_start = pointer;
+		    	break;
+	        case '\'':
+			if (pointer[1] == '\\')
+				if ((ch = pointer[2]) >= '0' && ch <= '7')
+					for(inc = 3; pointer[inc] != '\''
+						&& ++inc < 5;);
+				else
+					inc = 3;
+			else
+				inc = 2;
+			/*debug*/ if (pointer[inc] != '\'')
+			/*debug*/  fatalstr("Bad character constant %.10s",
+					pointer);
+			if ((cursor_pos += inc) > max_line_len) {
+				cursor_pos -= inc;
+				word_start = 0;
+				--pointer;
+				goto overflow;
+				}
+			word_start = pointer;
+			pointer += inc;
+			break;
+		case '\t':
+		    cursor_pos = 8 * ((cursor_pos + 8) / 8) - 1;
+		    break;
+		default: {
+
+/* HACK  Assumes that all characters in an atomic C token will be written
+   at the same time.  Must check for tokens first, since '-' is considered
+   part of an identifier; checking isident first would mean breaking up "->" */
+
+		    if (!word_start && isident(*(unsigned char *)pointer))
+			word_start = pointer;
+		    else if (word_start && isntident(*(unsigned char *)pointer))
+			word_start = NULL;
+		    break;
+		} /* default */
+	    } /* switch */
+	    cursor_pos++;
+	} /* for pointer = next_slot */
+ overflow:
+	if (*pointer == '\0') {
+
+/* The output line is not complete, so break out and don't output
+   anything.  The current line fragment will be stored in the buffer */
+
+	    next_slot = pointer;
+	    break;
+	} else {
+	    char last_char;
+	    int in_string0 = In_string;
+
+/* If the line was too long, move   pointer   back to the character before
+   the current word.  This allows line breaking on word boundaries.  Make
+   sure that 80 character comment lines get broken up somehow.  We assume
+   that any non-string 80 character identifier must be in a comment.
+*/
+
+	    if (word_start && *pointer != '\n' && word_start > output_buf)
+		if (In_string)
+			if (string_start && pointer - string_start < 5)
+				pointer = string_start - 1;
+			else {
+				pointer = adjust_pointer_in_string(pointer);
+				string_start = 0;
+				}
+		else if (word_start == string_start
+				&& pointer - string_start >= 5) {
+			pointer = adjust_pointer_in_string(next_slot);
+			In_string = 1;
+			string_start = 0;
+			}
+		else
+			pointer = word_start - 1;
+	    else if (cursor_pos > max_line_len) {
+		extern char *strchr();
+		if (In_string) {
+			pointer = adjust_pointer_in_string(pointer);
+			if (string_start && pointer > string_start)
+				string_start = 0;
+			}
+		else if (strchr("&*+-/<=>|", *pointer)
+			&& strchr("!%&*+-/<=>^|", pointer[-1])) {
+			pointer -= 2;
+			if (strchr("<>", *pointer)) /* <<=, >>= */
+				pointer--;
+			}
+		else
+			pointer--;
+		}
+	    last_char = *pointer;
+	    write_indent(fp, use_indent, extra_indent, output_buf, pointer);
+	    next_slot = output_buf;
+	    if (In_string && !string_start && Ansi == 1 && last_char != '\n')
+		*next_slot++ = '"';
+	    fwd_strcpy(next_slot, pointer + 1);
+
+/* insert a line break */
+
+	    if (last_char == '\n') {
+		if (In_string)
+			last_was_newline = 0;
+		else {
+			last_was_newline = 1;
+			extra_indent = 0;
+			}
+		}
+	    else {
+		extra_indent = TOO_LONG_INDENT;
+		if (In_string && !string_start) {
+			if (Ansi == 1) {
+				fprintf(fp, "\"\n");
+				use_indent = 1;
+				last_was_newline = 1;
+				}
+			else {
+				fprintf(fp, "\\\n");
+				last_was_newline = 0;
+				}
+			In_string = in_string0;
+			}
+		else {
+			putc ('\n', fp);
+			last_was_newline = 1;
+			}
+	    } /* if *pointer != '\n' */
+
+	    if (In_string && Ansi != 1 && !string_start)
+		cursor_pos = 0;
+	    else
+		set_cursor = 1;
+
+	    string_start = word_start = NULL;
+
+	} /* else */
+
+    } while (*next_slot);
+
+    return 0;
+} /* ind_printf */

+ 16 - 0
lang/fortran/comp/niceprintf.h

@@ -0,0 +1,16 @@
+/* niceprintf.h -- contains constants and macros from the output filter
+   for the generated C code.  We use macros for increased speed, less
+   function overhead.  */
+
+#define MAX_OUTPUT_SIZE 6000	/* Number of chars on one output line PLUS
+				   the length of the longest string
+				   printed using   nice_printf   */
+
+
+
+#define next_tab(fp) (indent += tab_size)
+
+#define prev_tab(fp) (indent -= tab_size)
+
+
+

+ 1431 - 0
lang/fortran/comp/output.c

@@ -0,0 +1,1431 @@
+/****************************************************************
+Copyright 1990, 1991 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+#include "defs.h"
+#include "names.h"
+#include "output.h"
+
+#ifndef TRUE
+#define TRUE 1
+#endif
+#ifndef FALSE
+#define FALSE 0
+#endif
+
+char _assoc_table[] = { 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0 };
+
+/* Opcode table -- This array is indexed by the OP_____ macros defined in
+   defines.h; these macros are expected to be adjacent integers, so that
+   this table is as small as possible. */
+
+table_entry opcode_table[] = {
+				{ 0, 0, NULL },
+	/* OPPLUS 1 */		{ BINARY_OP, 12, "%l + %r" },
+	/* OPMINUS 2 */		{ BINARY_OP, 12, "%l - %r" },
+	/* OPSTAR 3 */		{ BINARY_OP, 13, "%l * %r" },
+	/* OPSLASH 4 */		{ BINARY_OP, 13, "%l / %r" },
+	/* OPPOWER 5 */		{ BINARY_OP,  0, "power (%l, %r)" },
+	/* OPNEG 6 */		{ UNARY_OP,  14, "-%l" },
+	/* OPOR 7 */		{ BINARY_OP,  4, "%l || %r" },
+	/* OPAND 8 */		{ BINARY_OP,  5, "%l && %r" },
+	/* OPEQV 9 */		{ BINARY_OP,  9, "%l == %r" },
+	/* OPNEQV 10 */		{ BINARY_OP,  9, "%l != %r" },
+	/* OPNOT 11 */		{ UNARY_OP,  14, "! %l" },
+	/* OPCONCAT 12 */	{ BINARY_OP,  0, "concat (%l, %r)" },
+	/* OPLT 13 */		{ BINARY_OP, 10, "%l < %r" },
+	/* OPEQ 14 */		{ BINARY_OP,  9, "%l == %r" },
+	/* OPGT 15 */		{ BINARY_OP, 10, "%l > %r" },
+	/* OPLE 16 */		{ BINARY_OP, 10, "%l <= %r" },
+	/* OPNE 17 */		{ BINARY_OP,  9, "%l != %r" },
+	/* OPGE 18 */		{ BINARY_OP, 10, "%l >= %r" },
+	/* OPCALL 19 */		{ BINARY_OP, 15, SPECIAL_FMT },
+	/* OPCCALL 20 */	{ BINARY_OP, 15, SPECIAL_FMT },
+
+/* Left hand side of an assignment cannot have outermost parens */
+
+	/* OPASSIGN 21 */	{ BINARY_OP,  2, "%l = %r" },
+	/* OPPLUSEQ 22 */	{ BINARY_OP,  2, "%l += %r" },
+	/* OPSTAREQ 23 */	{ BINARY_OP,  2, "%l *= %r" },
+	/* OPCONV 24 */		{ BINARY_OP, 14, "%l" },
+	/* OPLSHIFT 25 */	{ BINARY_OP, 11, "%l << %r" },
+	/* OPMOD 26 */		{ BINARY_OP, 13, "%l %% %r" },
+	/* OPCOMMA 27 */	{ BINARY_OP,  1, "%l, %r" },
+
+/* Don't want to nest the colon operator in parens */
+
+	/* OPQUEST 28 */	{ BINARY_OP, 3, "%l ? %r" },
+	/* OPCOLON 29 */	{ BINARY_OP, 3, "%l : %r" },
+	/* OPABS 30 */		{ UNARY_OP,  0, "abs(%l)" },
+	/* OPMIN 31 */		{ BINARY_OP,   0, SPECIAL_FMT },
+	/* OPMAX 32 */		{ BINARY_OP,   0, SPECIAL_FMT },
+	/* OPADDR 33 */		{ UNARY_OP, 14, "&%l" },
+
+	/* OPCOMMA_ARG 34 */	{ BINARY_OP, 15, SPECIAL_FMT },
+	/* OPBITOR 35 */	{ BINARY_OP,  6, "%l | %r" },
+	/* OPBITAND 36 */	{ BINARY_OP,  8, "%l & %r" },
+	/* OPBITXOR 37 */	{ BINARY_OP,  7, "%l ^ %r" },
+	/* OPBITNOT 38 */	{ UNARY_OP,  14, "~ %l" },
+	/* OPRSHIFT 39 */	{ BINARY_OP, 11, "%l >> %r" },
+
+/* This isn't quite right -- it doesn't handle arrays, for instance */
+
+	/* OPWHATSIN 40 */	{ UNARY_OP,  14, "*%l" },
+	/* OPMINUSEQ 41 */	{ BINARY_OP,  2, "%l -= %r" },
+	/* OPSLASHEQ 42 */	{ BINARY_OP,  2, "%l /= %r" },
+	/* OPMODEQ 43 */	{ BINARY_OP,  2, "%l %%= %r" },
+	/* OPLSHIFTEQ 44 */	{ BINARY_OP,  2, "%l <<= %r" },
+	/* OPRSHIFTEQ 45 */	{ BINARY_OP,  2, "%l >>= %r" },
+	/* OPBITANDEQ 46 */	{ BINARY_OP,  2, "%l &= %r" },
+	/* OPBITXOREQ 47 */	{ BINARY_OP,  2, "%l ^= %r" },
+	/* OPBITOREQ 48 */	{ BINARY_OP,  2, "%l |= %r" },
+	/* OPPREINC 49 */	{ UNARY_OP,  14, "++%l" },
+	/* OPPREDEC 50 */	{ UNARY_OP,  14, "--%l" },
+	/* OPDOT 51 */		{ BINARY_OP, 15, "%l.%r" },
+	/* OPARROW 52 */	{ BINARY_OP, 15, "%l -> %r"},
+	/* OPNEG1 53 */		{ UNARY_OP,  14, "-%l" },
+	/* OPDMIN 54 */		{ BINARY_OP, 0, "dmin(%l,%r)" },
+	/* OPDMAX 55 */		{ BINARY_OP, 0, "dmax(%l,%r)" },
+	/* OPASSIGNI 56 */	{ BINARY_OP,  2, "%l = &%r" },
+	/* OPIDENTITY 57 */	{ UNARY_OP, 15, "%l" },
+	/* OPCHARCAST 58 */	{ UNARY_OP, 14, "(char *)&%l" },
+	/* OPDABS 59 */		{ UNARY_OP, 0, "dabs(%l)" },
+	/* OPMIN2 60 */		{ BINARY_OP,   0, "min(%l,%r)" },
+	/* OPMAX2 61 */		{ BINARY_OP,   0, "max(%l,%r)" },
+
+/* kludge to imitate (under forcedouble) f77's bizarre treatement of OPNEG... */
+
+	/* OPNEG KLUDGE */	{ UNARY_OP,  14, "-(doublereal)%l" }
+}; /* opcode_table */
+
+#define OPNEG_KLUDGE (sizeof(opcode_table)/sizeof(table_entry) - 1)
+
+static char opeqable[sizeof(opcode_table)/sizeof(table_entry)];
+
+
+static void output_prim ();
+static void output_unary (), output_binary (), output_arg_list ();
+static void output_list (), output_literal ();
+
+
+void expr_out (fp, e)
+FILE *fp;
+expptr e;
+{
+    if (e == (expptr) NULL)
+	return;
+
+    switch (e -> tag) {
+	case TNAME:	out_name (fp, (struct Nameblock *) e);
+			return;
+
+	case TCONST:	out_const(fp, &e->constblock);
+			goto end_out;
+	case TEXPR:
+	    		break;
+
+	case TADDR:	out_addr (fp, &(e -> addrblock));
+			goto end_out;
+
+	case TPRIM:	warn ("expr_out: got TPRIM");
+			output_prim (fp, &(e -> primblock));
+			return;
+
+	case TLIST:	output_list (fp, &(e -> listblock));
+ end_out:		frexpr(e);
+			return;
+
+	case TIMPLDO:	err ("expr_out: got TIMPLDO");
+			return;
+
+	case TERROR:
+	default:
+			erri ("expr_out: bad tag '%d'", e -> tag);
+    } /* switch */
+
+/* Now we know that the tag is TEXPR */
+
+/* Optimize on simple expressions, such as "a = a + b" ==> "a += b" */
+
+    if (e -> exprblock.opcode == OPASSIGN && e -> exprblock.rightp &&
+	e -> exprblock.rightp -> tag == TEXPR) {
+	int opcode;
+
+	opcode = e -> exprblock.rightp -> exprblock.opcode;
+
+	if (opeqable[opcode]) {
+	    expptr leftp, rightp;
+
+	    if ((leftp = e -> exprblock.leftp) &&
+		(rightp = e -> exprblock.rightp -> exprblock.leftp)) {
+
+		if (same_ident (leftp, rightp)) {
+		    expptr temp = e -> exprblock.rightp;
+
+		    e -> exprblock.opcode = op_assign(opcode);
+
+		    e -> exprblock.rightp = temp -> exprblock.rightp;
+		    temp->exprblock.rightp = 0;
+		    frexpr(temp);
+		} /* if same_ident (leftp, rightp) */
+	    } /* if leftp && rightp */
+	} /* if opcode == OPPLUS || */
+    } /* if e -> exprblock.opcode == OPASSIGN */
+
+
+/* Optimize on increment or decrement by 1 */
+
+    {
+	int opcode = e -> exprblock.opcode;
+	expptr leftp = e -> exprblock.leftp;
+	expptr rightp = e -> exprblock.rightp;
+
+	if (leftp && rightp && (leftp -> headblock.vstg == STGARG ||
+		ISINT (leftp -> headblock.vtype)) &&
+		(opcode == OPPLUSEQ || opcode == OPMINUSEQ) &&
+		ISINT (rightp -> headblock.vtype) &&
+		ISICON (e -> exprblock.rightp) &&
+		(ISONE (e -> exprblock.rightp) ||
+		e -> exprblock.rightp -> constblock.Const.ci == -1)) {
+
+/* Allow for the '-1' constant value */
+
+	    if (!ISONE (e -> exprblock.rightp))
+		opcode = (opcode == OPPLUSEQ) ? OPMINUSEQ : OPPLUSEQ;
+
+/* replace the existing opcode */
+
+	    if (opcode == OPPLUSEQ)
+		e -> exprblock.opcode = OPPREINC;
+	    else
+		e -> exprblock.opcode = OPPREDEC;
+
+/* Free up storage used by the right hand side */
+
+	    frexpr (e -> exprblock.rightp);
+	    e->exprblock.rightp = 0;
+	} /* if opcode == OPPLUS */
+    } /* block */
+
+
+    if (is_unary_op (e -> exprblock.opcode))
+	output_unary (fp, &(e -> exprblock));
+    else if (is_binary_op (e -> exprblock.opcode))
+	output_binary (fp, &(e -> exprblock));
+    else
+	erri ("expr_out: bad opcode '%d'", (int) e -> exprblock.opcode);
+
+    free((char *)e);
+
+} /* expr_out */
+
+
+void out_and_free_statement (outfile, expr)
+FILE *outfile;
+expptr expr;
+{
+    if (expr)
+	expr_out (outfile, expr);
+
+    nice_printf (outfile, ";\n");
+} /* out_and_free_statement */
+
+
+
+int same_ident (left, right)
+expptr left, right;
+{
+    if (!left || !right)
+	return 0;
+
+    if (left -> tag == TNAME && right -> tag == TNAME && left == right)
+	return 1;
+
+    if (left -> tag == TADDR && right -> tag == TADDR &&
+	    left -> addrblock.uname_tag == right -> addrblock.uname_tag)
+	switch (left -> addrblock.uname_tag) {
+	    case UNAM_NAME:
+
+/* Check for array subscripts */
+
+		if (left -> addrblock.user.name -> vdim ||
+			right -> addrblock.user.name -> vdim)
+		    if (left -> addrblock.user.name !=
+			    right -> addrblock.user.name ||
+			    !same_expr (left -> addrblock.memoffset,
+			    right -> addrblock.memoffset))
+			return 0;
+
+		return same_ident ((expptr) (left -> addrblock.user.name),
+			(expptr) right -> addrblock.user.name);
+	    case UNAM_IDENT:
+		return strcmp(left->addrblock.user.ident,
+				right->addrblock.user.ident) == 0;
+	    case UNAM_CHARP:
+		return strcmp(left->addrblock.user.Charp,
+				right->addrblock.user.Charp) == 0;
+	    default:
+	        return 0;
+	} /* switch */
+
+    if (left->tag == TEXPR && left->exprblock.opcode == OPWHATSIN
+	&& right->tag == TEXPR && right->exprblock.opcode == OPWHATSIN)
+		return same_ident(left->exprblock.leftp,
+				 right->exprblock.leftp);
+
+    return 0;
+} /* same_ident */
+
+ static int
+samefpconst(c1, c2, n)
+ register Constp c1, c2;
+ register int n;
+{
+	char *s1, *s2;
+	if (!c1->vstg && !c2->vstg)
+		return c1->Const.cd[n] == c2->Const.cd[n];
+	s1 = c1->vstg ? c1->Const.cds[n] : dtos(c1->Const.cd[n]);
+	s2 = c2->vstg ? c2->Const.cds[n] : dtos(c2->Const.cd[n]);
+	return !strcmp(s1, s2);
+	}
+
+ static int
+sameconst(c1, c2)
+ register Constp c1, c2;
+{
+	switch(c1->vtype) {
+		case TYCOMPLEX:
+		case TYDCOMPLEX:
+			if (!samefpconst(c1,c2,1))
+				return 0;
+		case TYREAL:
+		case TYDREAL:
+			return samefpconst(c1,c2,0);
+		case TYCHAR:
+			return c1->Const.ccp1.blanks == c2->Const.ccp1.blanks
+			    &&	   c1->vleng->constblock.Const.ci
+				== c2->vleng->constblock.Const.ci
+			    && !memcmp(c1->Const.ccp, c2->Const.ccp,
+					(int)c1->vleng->constblock.Const.ci);
+		case TYSHORT:
+		case TYINT:
+		case TYLOGICAL:
+			return c1->Const.ci == c2->Const.ci;
+		}
+	err("unexpected type in sameconst");
+	return 0;
+	}
+
+/* same_expr -- Returns true only if   e1 and e2   match.  This is
+   somewhat pessimistic, but can afford to be because it's just used to
+   optimize on the assignment operators (+=, -=, etc). */
+
+int same_expr (e1, e2)
+expptr e1, e2;
+{
+    if (!e1 || !e2)
+	return !e1 && !e2;
+
+    if (e1 -> tag != e2 -> tag || e1 -> headblock.vtype != e2 -> headblock.vtype)
+	return 0;
+
+    switch (e1 -> tag) {
+        case TEXPR:
+	    if (e1 -> exprblock.opcode != e2 -> exprblock.opcode)
+		return 0;
+
+	    return same_expr (e1 -> exprblock.leftp, e2 -> exprblock.leftp) &&
+		   same_expr (e1 -> exprblock.rightp, e2 -> exprblock.rightp);
+	case TNAME:
+	case TADDR:
+	    return same_ident (e1, e2);
+	case TCONST:
+	    return sameconst(&e1->constblock, &e2->constblock);
+	default:
+	    return 0;
+    } /* switch */
+} /* same_expr */
+
+
+
+void out_name (fp, namep)
+ FILE *fp;
+ Namep namep;
+{
+    extern int usedefsforcommon;
+    Extsym *comm;
+
+    if (namep == NULL)
+	return;
+
+/* DON'T want to use oneof_stg() here; need to find the right common name
+   */
+
+    if (namep->vstg == STGCOMMON && !namep->vcommequiv && !usedefsforcommon) {
+	comm = &extsymtab[namep->vardesc.varno];
+	extern_out(fp, comm);
+	nice_printf(fp, "%d.", comm->curno);
+    } /* if namep -> vstg == STGCOMMON */
+
+    if (namep->vprocclass == PTHISPROC && namep->vtype != TYSUBR)
+	nice_printf(fp, xretslot[namep->vtype]->user.ident);
+    else
+	nice_printf (fp, "%s", namep->cvarname);
+} /* out_name */
+
+
+static char *Longfmt = "%ld";
+
+#define cpd(n) cp->vstg ? cp->Const.cds[n] : dtos(cp->Const.cd[n])
+
+void out_const(fp, cp)
+ FILE *fp;
+ register Constp cp;
+{
+    static char real_buf[50], imag_buf[50];
+    unsigned int k;
+    int type = cp->vtype;
+
+    switch (type) {
+        case TYSHORT:
+	    nice_printf (fp, "%ld", cp->Const.ci);	/* don't cast ci! */
+	    break;
+	case TYLONG:
+	    nice_printf (fp, Longfmt, cp->Const.ci);	/* don't cast ci! */
+	    break;
+	case TYREAL:
+	    nice_printf(fp, "%s", flconst(real_buf, cpd(0)));
+	    break;
+	case TYDREAL:
+	    nice_printf(fp, "%s", cpd(0));
+	    break;
+	case TYCOMPLEX:
+	    nice_printf(fp, cm_fmt_string, flconst(real_buf, cpd(0)),
+			flconst(imag_buf, cpd(1)));
+	    break;
+	case TYDCOMPLEX:
+	    nice_printf(fp, dcm_fmt_string, cpd(0), cpd(1));
+	    break;
+	case TYLOGICAL:
+	    nice_printf (fp, "%s", cp->Const.ci ? "TRUE_" : "FALSE_");
+	    break;
+	case TYCHAR: {
+	    char *c = cp->Const.ccp, *ce;
+
+	    if (c == NULL) {
+		nice_printf (fp, "\"\"");
+		break;
+	    } /* if c == NULL */
+
+	    nice_printf (fp, "\"");
+	    ce = c + cp->vleng->constblock.Const.ci;
+	    while(c < ce) {
+		k = *(unsigned char *)c++;
+		nice_printf(fp, str_fmt[k], k);
+		}
+	    for(k = cp->Const.ccp1.blanks; k > 0; k--)
+		nice_printf(fp, " ");
+	    nice_printf (fp, "\"");
+	    break;
+	} /* case TYCHAR */
+	default:
+	    erri ("out_const:  bad type '%d'", (int) type);
+	    break;
+    } /* switch */
+
+} /* out_const */
+#undef cpd
+
+
+/* out_addr -- this routine isn't local because it is called by the
+   system-generated identifier printing routines */
+
+void out_addr (fp, addrp)
+FILE *fp;
+struct Addrblock *addrp;
+{
+	extern Extsym *extsymtab;
+	int was_array = 0;
+	char *s;
+
+
+	if (addrp == NULL)
+		return;
+	if (doin_setbound
+			&& addrp->vstg == STGARG
+			&& addrp->vtype != TYCHAR
+			&& ISICON(addrp->memoffset)
+			&& !addrp->memoffset->constblock.Const.ci)
+		nice_printf(fp, "*");
+
+	switch (addrp -> uname_tag) {
+	    case UNAM_NAME:
+		out_name (fp, addrp -> user.name);
+		break;
+	    case UNAM_IDENT:
+		if (*(s = addrp->user.ident) == ' ') {
+			if (multitype)
+				nice_printf(fp, "%s",
+					xretslot[addrp->vtype]->user.ident);
+			else
+				nice_printf(fp, "%s", s+1);
+			}
+		else {
+			nice_printf(fp, "%s", s);
+			}
+		break;
+	    case UNAM_CHARP:
+		nice_printf(fp, "%s", addrp->user.Charp);
+		break;
+	    case UNAM_EXTERN:
+		extern_out (fp, &extsymtab[addrp -> memno]);
+		break;
+	    case UNAM_CONST:
+		switch(addrp->vstg) {
+			case STGCONST:
+				out_const(fp, (Constp)addrp);
+				break;
+			case STGMEMNO:
+				output_literal (fp, (int)addrp->memno,
+					(Constp)addrp);
+				break;
+			default:
+			Fatal("unexpected vstg in out_addr");
+			}
+		break;
+	    case UNAM_UNKNOWN:
+	    default:
+		nice_printf (fp, "Unknown Addrp");
+		break;
+	} /* switch */
+
+/* It's okay to just throw in the brackets here because they have a
+   precedence level of 15, the highest value.  */
+
+    if ((addrp->uname_tag == UNAM_NAME && addrp->user.name->vdim
+			|| addrp->ntempelt > 1 || addrp->isarray)
+	&& addrp->vtype != TYCHAR) {
+	expptr offset;
+
+	was_array = 1;
+
+	offset = addrp -> memoffset;
+	addrp->memoffset = 0;
+	if (ONEOF(addrp->vstg, M(STGCOMMON)|M(STGEQUIV)) &&
+		addrp -> uname_tag == UNAM_NAME)
+	    offset = mkexpr (OPMINUS, offset, mkintcon (
+		    addrp -> user.name -> voffset));
+
+	nice_printf (fp, "[");
+
+	offset = mkexpr (OPSLASH, offset,
+		ICON (typesize[addrp -> vtype] * (addrp -> Field ? 2 : 1)));
+	expr_out (fp, offset);
+	nice_printf (fp, "]");
+	}
+
+/* Check for structure field reference */
+
+    if (addrp -> Field && addrp -> uname_tag != UNAM_CONST &&
+	    addrp -> uname_tag != UNAM_UNKNOWN) {
+	if (oneof_stg((addrp -> uname_tag == UNAM_NAME ? addrp -> user.name :
+		(Namep) NULL), addrp -> vstg, M(STGARG)|M(STGEQUIV))
+		&& !was_array && (addrp->vclass != CLPROC || !multitype))
+	    nice_printf (fp, "->%s", addrp -> Field);
+	else
+	    nice_printf (fp, ".%s", addrp -> Field);
+    } /* if */
+
+/* Check for character subscripting */
+
+    if (addrp->vtype == TYCHAR &&
+	    (addrp->vclass != CLPROC || addrp->uname_tag == UNAM_NAME
+			&& addrp->user.name->vprocclass == PTHISPROC) &&
+	    addrp -> memoffset &&
+	    (addrp -> uname_tag != UNAM_NAME ||
+	     addrp -> user.name -> vtype == TYCHAR) &&
+	    (!ISICON (addrp -> memoffset) ||
+	     (addrp -> memoffset -> constblock.Const.ci))) {
+
+	int use_paren = 0;
+	expptr e = addrp -> memoffset;
+
+	if (!e)
+		return;
+	addrp->memoffset = 0;
+
+	if (ONEOF(addrp->vstg, M(STGCOMMON)|M(STGEQUIV))
+	 && addrp -> uname_tag == UNAM_NAME) {
+	    e = mkexpr (OPMINUS, e, mkintcon (addrp -> user.name -> voffset));
+
+/* mkexpr will simplify it to zero if possible */
+	    if (e->tag == TCONST && e->constblock.Const.ci == 0)
+		return;
+	} /* if addrp -> vstg == STGCOMMON */
+
+/* In the worst case, parentheses might be needed OUTSIDE the expression,
+   too.  But since I think this subscripting can only appear as a
+   parameter in a procedure call, I don't think outside parens will ever
+   be needed.  INSIDE parens are handled below */
+
+	nice_printf (fp, " + ");
+	if (e -> tag == TEXPR) {
+	    int arg_prec = op_precedence (e -> exprblock.opcode);
+	    int prec = op_precedence (OPPLUS);
+	    use_paren = arg_prec && (arg_prec < prec || (arg_prec == prec &&
+		    is_left_assoc (OPPLUS)));
+	} /* if e -> tag == TEXPR */
+	if (use_paren) nice_printf (fp, "(");
+	expr_out (fp, e);
+	if (use_paren) nice_printf (fp, ")");
+    } /* if */
+} /* out_addr */
+
+
+static void output_literal (fp, memno, cp)
+ FILE *fp;
+ int memno;
+ Constp cp;
+{
+    struct Literal *litp, *lastlit;
+    extern char *lit_name ();
+
+    lastlit = litpool + nliterals;
+
+    for (litp = litpool; litp < lastlit; litp++) {
+	if (litp -> litnum == memno)
+	    break;
+    } /* for litp */
+
+    if (litp >= lastlit)
+	out_const (fp, cp);
+    else {
+	nice_printf (fp, "%s", lit_name (litp));
+	litp->lituse++;
+	}
+} /* output_literal */
+
+
+static void output_prim (fp, primp)
+FILE *fp;
+struct Primblock *primp;
+{
+    if (primp == NULL)
+	return;
+
+    out_name (fp, primp -> namep);
+    if (primp -> argsp)
+	output_arg_list (fp, primp -> argsp);
+
+    if (primp -> fcharp != (expptr) NULL || primp -> lcharp != (expptr) NULL)
+	nice_printf (fp, "Sorry, no substrings yet");
+}
+
+
+
+static void output_arg_list (fp, listp)
+FILE *fp;
+struct Listblock *listp;
+{
+    chainp arg_list;
+
+    if (listp == (struct Listblock *) NULL || listp -> listp == (chainp) NULL)
+	return;
+
+    nice_printf (fp, "(");
+
+    for (arg_list = listp -> listp; arg_list; arg_list = arg_list -> nextp) {
+	expr_out (fp, (expptr) arg_list -> datap);
+	if (arg_list -> nextp != (chainp) NULL)
+
+/* Might want to add a hook in here to accomodate the style setting which
+   wants spaces after commas */
+
+	    nice_printf (fp, ",");
+    } /* for arg_list */
+
+    nice_printf (fp, ")");
+} /* output_arg_list */
+
+
+
+static void output_unary (fp, e)
+FILE *fp;
+struct Exprblock *e;
+{
+    if (e == NULL)
+	return;
+
+    switch (e -> opcode) {
+        case OPNEG:
+		if (e->vtype == TYREAL && forcedouble) {
+			e->opcode = OPNEG_KLUDGE;
+			output_binary(fp,e);
+			e->opcode = OPNEG;
+			break;
+			}
+	case OPNEG1:
+	case OPNOT:
+	case OPABS:
+	case OPBITNOT:
+	case OPWHATSIN:
+	case OPPREINC:
+	case OPPREDEC:
+	case OPADDR:
+	case OPIDENTITY:
+	case OPCHARCAST:
+	case OPDABS:
+	    output_binary (fp, e);
+	    break;
+	case OPCALL:
+	case OPCCALL:
+	    nice_printf (fp, "Sorry, no OPCALL yet");
+	    break;
+	default:
+	    erri ("output_unary: bad opcode", (int) e -> opcode);
+	    break;
+    } /* switch */
+} /* output_unary */
+
+
+ static char *
+findconst(m)
+ register long m;
+{
+	register struct Literal *litp, *litpe;
+
+	litp = litpool;
+	for(litpe = litp + nliterals; litp < litpe; litp++)
+		if (litp->litnum ==  m)
+			return litp->cds[0];
+	Fatal("findconst failure!");
+	return 0;
+	}
+
+ static int
+opconv_fudge(fp,e)
+ FILE *fp;
+ struct Exprblock *e;
+{
+	/* special handling for ichar and character*1 */
+	register expptr lp = e->leftp;
+	register union Expression *Offset;
+	register char *cp;
+	int lt = lp->headblock.vtype;
+	char buf[8];
+	unsigned int k;
+	Namep np;
+
+	if (lp->addrblock.vtype == TYCHAR) {
+		switch(lp->tag) {
+			case TNAME:
+				nice_printf(fp, "*");
+				out_name(fp, (Namep)lp);
+				return 1;
+			case TCONST:
+ tconst:
+				cp = lp->constblock.Const.ccp;
+ tconst1:
+				k = *(unsigned char *)cp;
+				sprintf(buf, chr_fmt[k], k);
+				nice_printf(fp, "'%s'", buf);
+				return 1;
+			case TADDR:
+				switch(lp->addrblock.vstg) {
+				    case STGMEMNO:
+					cp = findconst(lp->addrblock.memno);
+					goto tconst1;
+				    case STGCONST:
+					goto tconst;
+				    }
+				lt = lp->addrblock.vtype = tyint;
+				Offset = lp->addrblock.memoffset;
+				if (lp->addrblock.uname_tag == UNAM_NAME) {
+					np = lp->addrblock.user.name;
+					if (ONEOF(np->vstg,
+					    M(STGCOMMON)|M(STGEQUIV)))
+						Offset = mkexpr(OPMINUS, Offset,
+							ICON(np->voffset));
+					}
+				lp->addrblock.memoffset = Offset ?
+					mkexpr(OPSTAR, Offset,
+						ICON(typesize[tyint]))
+					: ICON(0);
+				lp->addrblock.isarray = 1;
+				/* STGCOMMON or STGEQUIV would cause */
+				/* voffset to be added in a second time */
+				lp->addrblock.vstg = STGUNKNOWN;
+				break;
+			default:
+				badtag("opconv_fudge", lp->tag);
+			}
+		}
+	if (lt != e->vtype)
+		nice_printf(fp, "(%s) ",
+			c_type_decl(e->vtype, 0));
+	return 0;
+	}
+
+
+static void output_binary (fp, e)
+FILE *fp;
+struct Exprblock *e;
+{
+    char *format;
+    extern table_entry opcode_table[];
+    int prec;
+
+    if (e == NULL || e -> tag != TEXPR)
+	return;
+
+/* Instead of writing a huge switch, I've incorporated the output format
+   into a table.  Things like "%l" and "%r" stand for the left and
+   right subexpressions.  This should allow both prefix and infix
+   functions to be specified (e.g. "(%l * %r", "z_div (%l, %r").  Of
+   course, I should REALLY think out the ramifications of writing out
+   straight text, as opposed to some intermediate format, which could
+   figure out and optimize on the the number of required blanks (we don't
+   want "x - (-y)" to become "x --y", for example).  Special cases (such as
+   incomplete implementations) could still be implemented as part of the
+   switch, they will just have some dummy value instead of the string
+   pattern.  Another difficulty is the fact that the complex functions
+   will differ from the integer and real ones */
+
+/* Handle a special case.  We don't want to output "x + - 4", or "y - - 3"
+*/
+    if ((e -> opcode == OPPLUS || e -> opcode == OPMINUS) &&
+	    e -> rightp && e -> rightp -> tag == TCONST &&
+	    isnegative_const (&(e -> rightp -> constblock)) &&
+	    is_negatable (&(e -> rightp -> constblock))) {
+
+	e -> opcode = (e -> opcode == OPPLUS) ? OPMINUS : OPPLUS;
+	negate_const (&(e -> rightp -> constblock));
+    } /* if e -> opcode == PLUS or MINUS */
+
+    prec = op_precedence (e -> opcode);
+    format = op_format (e -> opcode);
+
+    if (format != SPECIAL_FMT) {
+	while (*format) {
+	    if (*format == '%') {
+		int arg_prec, use_paren = 0;
+		expptr lp, rp;
+
+		switch (*(format + 1)) {
+		    case 'l':
+			lp = e->leftp;
+			if (lp && lp->tag == TEXPR) {
+			    arg_prec = op_precedence(lp->exprblock.opcode);
+
+			    use_paren = arg_prec &&
+			        (arg_prec < prec || (arg_prec == prec &&
+				    is_right_assoc (prec)));
+			} /* if e -> leftp */
+			if (e->opcode == OPCONV && opconv_fudge(fp,e))
+				break;
+			if (use_paren)
+			    nice_printf (fp, "(");
+		        expr_out(fp, lp);
+			if (use_paren)
+			    nice_printf (fp, ")");
+		        break;
+		    case 'r':
+			rp = e->rightp;
+			if (rp && rp->tag == TEXPR) {
+			    arg_prec = op_precedence(rp->exprblock.opcode);
+
+			    use_paren = arg_prec &&
+			        (arg_prec < prec || (arg_prec == prec &&
+				    is_left_assoc (prec)));
+			    use_paren = use_paren ||
+				(rp->exprblock.opcode == OPNEG
+				&& prec >= op_precedence(OPMINUS));
+			} /* if e -> rightp */
+			if (use_paren)
+			    nice_printf (fp, "(");
+		        expr_out(fp, rp);
+			if (use_paren)
+			    nice_printf (fp, ")");
+		        break;
+		    case '\0':
+		    case '%':
+		        nice_printf (fp, "%%");
+		        break;
+		    default:
+		        erri ("output_binary: format err: '%%%c' illegal",
+				(int) *(format + 1));
+		        break;
+		} /* switch */
+		format += 2;
+	    } else
+		nice_printf (fp, "%c", *format++);
+	} /* while *format */
+    } else {
+
+/* Handle Special cases of formatting */
+
+	switch (e -> opcode) {
+		case OPCCALL:
+		case OPCALL:
+			out_call (fp, (int) e -> opcode, e -> vtype,
+					e -> vleng, e -> leftp, e -> rightp);
+			break;
+
+		case OPCOMMA_ARG:
+			doin_setbound = 1;
+			nice_printf(fp, "(");
+			expr_out(fp, e->leftp);
+			nice_printf(fp, ", &");
+			doin_setbound = 0;
+			expr_out(fp, e->rightp);
+			nice_printf(fp, ")");
+			break;
+
+		case OPADDR:
+		default:
+	        	nice_printf (fp, "Sorry, can't format OPCODE '%d'",
+				e -> opcode);
+	        	break;
+		}
+
+    } /* else */
+} /* output_binary */
+
+
+out_call (outfile, op, ftype, len, name, args)
+FILE *outfile;
+int op, ftype;
+expptr len, name, args;
+{
+    chainp arglist;		/* Pointer to any actual arguments */
+    chainp cp;			/* Iterator over argument lists */
+    Addrp ret_val = (Addrp) NULL;
+				/* Function return value buffer, if any is
+				   required */
+    int byvalue;		/* True iff we're calling a C library
+				   routine */
+    int done_once;		/* Used for writing commas to   outfile   */
+    int narg, t;
+    register expptr q;
+    long L;
+    Argtypes *at;
+    Atype *A;
+    Namep np;
+    extern int forcereal;
+
+/* Don't use addresses if we're calling a C function */
+
+    byvalue = op == OPCCALL;
+
+    if (args)
+	arglist = args -> listblock.listp;
+    else
+	arglist = CHNULL;
+
+/* If this is a CHARACTER function, the first argument is the result */
+
+    if (ftype == TYCHAR)
+	if (ISICON (len)) {
+	    ret_val = (Addrp) (arglist -> datap);
+	    arglist = arglist -> nextp;
+	} else {
+	    err ("adjustable character function");
+	    return;
+	} /* else */
+
+/* If this is a COMPLEX function, the first argument is the result */
+
+    else if (ISCOMPLEX (ftype)) {
+	ret_val = (Addrp) (arglist -> datap);
+	arglist = arglist -> nextp;
+    } /* if ISCOMPLEX */
+
+/* Now we can actually start to write out the function invocation */
+
+    if (ftype == TYREAL && forcereal)
+	nice_printf(outfile, "(real)");
+    if (name -> tag == TEXPR && name -> exprblock.opcode == OPWHATSIN) {
+	nice_printf (outfile, "(");
+	np = (Namep)name->exprblock.leftp; /*expr_out will free name */
+	expr_out (outfile, name);
+	nice_printf (outfile, ")");
+	}
+    else {
+	np = (Namep)name;
+	expr_out(outfile, name);
+	}
+
+    /* prepare to cast procedure parameters -- set A if we know how */
+
+    A = np->tag == TNAME && (at = np->arginfo) && at->nargs > 0
+	? at->atypes : 0;
+
+    nice_printf(outfile, "(");
+
+    if (ret_val) {
+	if (ISCOMPLEX (ftype))
+	    nice_printf (outfile, "&");
+	expr_out (outfile, (expptr) ret_val);
+
+/* The length of the result of a character function is the second argument */
+/* It should be in place from putcall(), so we won't touch it explicitly */
+
+    } /* if ret_val */
+    done_once = ret_val ? TRUE : FALSE;
+
+/* Now run through the named arguments */
+
+    narg = -1;
+    for (cp = arglist; cp; cp = cp -> nextp, done_once = TRUE) {
+
+	if (done_once)
+	    nice_printf (outfile, ", ");
+	narg++;
+
+	if (!( q = (expptr)cp->datap) )
+		continue;
+
+	if (q->tag == TADDR) {
+		if (q->addrblock.vtype > TYERROR) {
+			/* I/O block */
+			nice_printf(outfile, "&%s", q->addrblock.user.ident);
+			continue;
+			}
+		if (!byvalue && q->addrblock.isarray
+		&& q->addrblock.vtype != TYCHAR
+		&& q->addrblock.memoffset->tag == TCONST) {
+
+			/* check for 0 offset -- after */
+			/* correcting for equivalence. */
+			L = q->addrblock.memoffset->constblock.Const.ci;
+			if (ONEOF(q->addrblock.vstg, M(STGCOMMON)|M(STGEQUIV))
+					&& q->addrblock.uname_tag == UNAM_NAME)
+				L -= q->addrblock.user.name->voffset;
+			if (L)
+				goto skip_deref;
+
+			/* &x[0] == x */
+			/* This also prevents &sizeof(doublereal)[0] */
+			switch(q->addrblock.uname_tag) {
+			    case UNAM_NAME:
+				out_name(outfile, q->addrblock.user.name);
+				continue;
+			    case UNAM_IDENT:
+				nice_printf(outfile, "%s",
+					q->addrblock.user.ident);
+				continue;
+			    case UNAM_CHARP:
+				nice_printf(outfile, "%s",
+					q->addrblock.user.Charp);
+				continue;
+			    case UNAM_EXTERN:
+				extern_out(outfile,
+					&extsymtab[q->addrblock.memno]);
+				continue;
+			    }
+			}
+		}
+
+/* Skip over the dereferencing operator generated only for the
+   intermediate file */
+ skip_deref:
+	if (q -> tag == TEXPR && q -> exprblock.opcode == OPWHATSIN)
+	    q = q -> exprblock.leftp;
+
+	if (q->headblock.vclass == CLPROC
+			&& Castargs
+			&& (q->tag != TNAME
+				|| q->nameblock.vprocclass != PTHISPROC))
+		{
+		if (A && (t = A[narg].type) >= 200)
+			t %= 100;
+		else {
+			t = q->headblock.vtype;
+			if (q->tag == TNAME && q->nameblock.vimpltype)
+				t = TYUNKNOWN;
+			}
+		nice_printf(outfile, "(%s)", usedcasts[t] = casttypes[t]);
+		}
+
+	if ((q -> tag == TADDR || q-> tag == TNAME) &&
+		(byvalue || q -> headblock.vstg != STGREG)) {
+	    if (q -> headblock.vtype != TYCHAR)
+	      if (byvalue) {
+
+		if (q -> tag == TADDR &&
+			q -> addrblock.uname_tag == UNAM_NAME &&
+			! q -> addrblock.user.name -> vdim &&
+			oneof_stg(q -> addrblock.user.name, q -> addrblock.vstg,
+					M(STGARG)|M(STGEQUIV)) &&
+			! ISCOMPLEX(q->addrblock.user.name->vtype))
+		    nice_printf (outfile, "*");
+		else if (q -> tag == TNAME
+			&& oneof_stg(&q->nameblock, q -> nameblock.vstg,
+				M(STGARG)|M(STGEQUIV))
+			&& !(q -> nameblock.vdim))
+		    nice_printf (outfile, "*");
+
+	      } else {
+		expptr memoffset;
+
+		if (q->tag == TADDR &&
+			!ONEOF (q -> addrblock.vstg, M(STGEXT)|M(STGLENG))
+			&& (
+			ONEOF(q->addrblock.vstg,
+				M(STGCOMMON)|M(STGEQUIV)|M(STGMEMNO))
+			|| ((memoffset = q->addrblock.memoffset)
+				&& (!ISICON(memoffset)
+				|| memoffset->constblock.Const.ci)))
+			|| ONEOF(q->addrblock.vstg,
+					M(STGINIT)|M(STGAUTO)|M(STGBSS))
+				&& !q->addrblock.isarray)
+		    nice_printf (outfile, "&");
+		else if (q -> tag == TNAME
+			&& !oneof_stg(&q->nameblock, q -> nameblock.vstg,
+				M(STGARG)|M(STGEXT)|M(STGEQUIV)))
+		    nice_printf (outfile, "&");
+	    } /* else */
+
+	    expr_out (outfile, q);
+	} /* if q -> tag == TADDR || q -> tag == TNAME */
+
+/* Might be a Constant expression, e.g. string length, character constants */
+
+	else if (q -> tag == TCONST) {
+	    if (tyioint == TYLONG)
+	   	Longfmt = "%ldL";
+	    out_const(outfile, &q->constblock);
+	    Longfmt = "%ld";
+	    }
+
+/* Must be some other kind of expression, or register var, or constant.
+   In particular, this is likely to be a temporary variable assignment
+   which was generated in p1put_call */
+
+	else if (!ISCOMPLEX (q -> headblock.vtype) && !ISCHAR (q)){
+	    int use_paren = q -> tag == TEXPR &&
+		    op_precedence (q -> exprblock.opcode) <=
+		    op_precedence (OPCOMMA);
+
+	    if (use_paren) nice_printf (outfile, "(");
+	    expr_out (outfile, q);
+	    if (use_paren) nice_printf (outfile, ")");
+	} /* if !ISCOMPLEX */
+	else
+	    err ("out_call:  unknown parameter");
+
+    } /* for (cp = arglist */
+
+    if (arglist)
+	frchain (&arglist);
+
+    nice_printf (outfile, ")");
+
+} /* out_call */
+
+
+ char *
+flconst(buf, x)
+ char *buf, *x;
+{
+	sprintf(buf, fl_fmt_string, x);
+	return buf;
+	}
+
+ char *
+dtos(x)
+ double x;
+{
+	static char buf[64];
+	sprintf(buf, db_fmt_string, x);
+	return buf;
+	}
+
+char tr_tab[Table_size];
+
+/* out_init -- Initialize the data structures used by the routines in
+   output.c.  These structures include the output format to be used for
+   Float, Double, Complex, and Double Complex constants. */
+
+void out_init ()
+{
+    extern int tab_size;
+    register char *s;
+
+    s = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_+-.";
+    while(*s)
+	tr_tab[*s++] = 3;
+    tr_tab['>'] = 1;
+
+	opeqable[OPPLUS] = 1;
+	opeqable[OPMINUS] = 1;
+	opeqable[OPSTAR] = 1;
+	opeqable[OPSLASH] = 1;
+	opeqable[OPMOD] = 1;
+	opeqable[OPLSHIFT] = 1;
+	opeqable[OPBITAND] = 1;
+	opeqable[OPBITXOR] = 1;
+	opeqable[OPBITOR ] = 1;
+
+
+/* Set the output format for both types of floating point constants */
+
+    if (fl_fmt_string == NULL || *fl_fmt_string == '\0')
+	fl_fmt_string = Ansi == 1 ? "%sf" : "(float)%s";
+
+    if (db_fmt_string == NULL || *db_fmt_string == '\0')
+	db_fmt_string = "%.17g";
+
+/* Set the output format for both types of complex constants.  They will
+   have string parameters rather than float or double so that the decimal
+   point may be added to the strings generated by the {db,fl}_fmt_string
+   formats above */
+
+    if (cm_fmt_string == NULL || *cm_fmt_string == '\0') {
+	cm_fmt_string = "{%s,%s}";
+    } /* if cm_fmt_string == NULL */
+
+    if (dcm_fmt_string == NULL || *dcm_fmt_string == '\0') {
+	dcm_fmt_string = "{%s,%s}";
+    } /* if dcm_fmt_string == NULL */
+
+    tab_size = 4;
+} /* out_init */
+
+
+void extern_out (fp, extsym)
+FILE *fp;
+Extsym *extsym;
+{
+    if (extsym == (Extsym *) NULL)
+	return;
+
+    nice_printf (fp, "%s", extsym->cextname);
+
+} /* extern_out */
+
+
+
+static void output_list (fp, listp)
+FILE *fp;
+struct Listblock *listp;
+{
+    int did_one = 0;
+    chainp elts;
+
+    nice_printf (fp, "(");
+    if (listp)
+	for (elts = listp -> listp; elts; elts = elts -> nextp) {
+	    if (elts -> datap) {
+		if (did_one)
+		    nice_printf (fp, ", ");
+		expr_out (fp, (expptr) elts -> datap);
+		did_one = 1;
+	    } /* if elts -> datap */
+	} /* for elts */
+    nice_printf (fp, ")");
+} /* output_list */
+
+
+void out_asgoto (outfile, expr)
+FILE *outfile;
+expptr expr;
+{
+    char *user_label();
+    chainp value;
+    Namep namep;
+    int k;
+
+    if (expr == (expptr) NULL) {
+	err ("out_asgoto:  NULL variable expr");
+	return;
+    } /* if expr */
+
+    nice_printf (outfile, Ansi ? "switch (" : "switch ((int)"); /*)*/
+    expr_out (outfile, expr);
+    nice_printf (outfile, ") {\n");
+    next_tab (outfile);
+
+/* The initial addrp value will be stored as a namep pointer */
+
+    switch(expr->tag) {
+	case TNAME:
+		/* local variable */
+		namep = &expr->nameblock;
+		break;
+	case TEXPR:
+		if (expr->exprblock.opcode == OPWHATSIN
+		 && expr->exprblock.leftp->tag == TNAME)
+			/* argument */
+			namep = &expr->exprblock.leftp->nameblock;
+		else
+			goto bad;
+		break;
+	case TADDR:
+		if (expr->addrblock.uname_tag == UNAM_NAME) {
+			/* initialized local variable */
+			namep = expr->addrblock.user.name;
+			break;
+			}
+	default:
+ bad:
+		err("out_asgoto:  bad expr");
+		return;
+	}
+
+    for(k = 0, value = namep -> varxptr.assigned_values; value;
+	    value = value->nextp, k++) {
+	nice_printf (outfile, "case %d: goto %s;\n", k,
+		user_label((long)value->datap));
+    } /* for value */
+    prev_tab (outfile);
+
+    nice_printf (outfile, "}\n");
+} /* out_asgoto */
+
+void out_if (outfile, expr)
+FILE *outfile;
+expptr expr;
+{
+    nice_printf (outfile, "if (");
+    expr_out (outfile, expr);
+    nice_printf (outfile, ") {\n");
+    next_tab (outfile);
+} /* out_if */
+
+ static void
+output_rbrace(outfile, s)
+ FILE *outfile;
+ char *s;
+{
+	extern int last_was_label;
+	register char *fmt;
+
+	if (last_was_label) {
+		last_was_label = 0;
+		fmt = ";%s";
+		}
+	else
+		fmt = "%s";
+	nice_printf(outfile, fmt, s);
+	}
+
+void out_else (outfile)
+FILE *outfile;
+{
+    prev_tab (outfile);
+    output_rbrace(outfile, "} else {\n");
+    next_tab (outfile);
+} /* out_else */
+
+void elif_out (outfile, expr)
+FILE *outfile;
+expptr expr;
+{
+    prev_tab (outfile);
+    output_rbrace(outfile, "} else ");
+    out_if (outfile, expr);
+} /* elif_out */
+
+void endif_out (outfile)
+FILE *outfile;
+{
+    prev_tab (outfile);
+    output_rbrace(outfile, "}\n");
+} /* endif_out */
+
+void end_else_out (outfile)
+FILE *outfile;
+{
+    prev_tab (outfile);
+    output_rbrace(outfile, "}\n");
+} /* end_else_out */
+
+
+
+void compgoto_out (outfile, index, labels)
+FILE *outfile;
+expptr index, labels;
+{
+    char *s1, *s2;
+
+    if (index == ENULL)
+	err ("compgoto_out:  null index for computed goto");
+    else if (labels && labels -> tag != TLIST)
+	erri ("compgoto_out:  expected label list, got tag '%d'",
+		labels -> tag);
+    else {
+	extern char *user_label ();
+	chainp elts;
+	int i = 1;
+
+	s2 = /*(*/ ") {\n"; /*}*/
+	if (Ansi)
+		s1 = "switch ("; /*)*/
+	else if (index->tag == TNAME || index->tag == TEXPR
+				&& index->exprblock.opcode == OPWHATSIN)
+		s1 = "switch ((int)"; /*)*/
+	else {
+		s1 = "switch ((int)(";
+		s2 = ")) {\n"; /*}*/
+		}
+	nice_printf(outfile, s1);
+	expr_out (outfile, index);
+	nice_printf (outfile, s2);
+	next_tab (outfile);
+
+	for (elts = labels -> listblock.listp; elts; elts = elts -> nextp, i++) {
+	    if (elts -> datap) {
+		if (ISICON(((expptr) (elts -> datap))))
+		    nice_printf (outfile, "case %d:  goto %s;\n", i,
+			user_label(((expptr)(elts->datap))->constblock.Const.ci));
+		else
+		    err ("compgoto_out:  bad label in label list");
+	    } /* if (elts -> datap) */
+	} /* for elts */
+	prev_tab (outfile);
+	nice_printf (outfile, /*{*/ "}\n");
+    } /* else */
+} /* compgoto_out */
+
+
+void out_for (outfile, init, test, inc)
+FILE *outfile;
+expptr init, test, inc;
+{
+    nice_printf (outfile, "for (");
+    expr_out (outfile, init);
+    nice_printf (outfile, "; ");
+    expr_out (outfile, test);
+    nice_printf (outfile, "; ");
+    expr_out (outfile, inc);
+    nice_printf (outfile, ") {\n");
+    next_tab (outfile);
+} /* out_for */
+
+
+void out_end_for (outfile)
+FILE *outfile;
+{
+    prev_tab (outfile);
+    nice_printf (outfile, "}\n");
+} /* out_end_for */

+ 65 - 0
lang/fortran/comp/output.h

@@ -0,0 +1,65 @@
+/* nice_printf -- same arguments as fprintf.
+
+	All output which is to become C code must be directed through this
+   function.  For now, no buffering is done.  Later on, every line of
+   output will be filtered to accomodate the style definitions (e.g. one
+   statement per line, spaces between function names and argument lists,
+   etc.)
+*/
+#include "niceprintf.h"
+
+extern int nice_printf ();
+
+
+/* Definitions for the opcode table.  The table is indexed by the macros
+   which are #defined in   defines.h   */
+
+#define UNARY_OP 01
+#define BINARY_OP 02
+
+#define SPECIAL_FMT NULL
+
+#define is_unary_op(x) (opcode_table[x].type == UNARY_OP)
+#define is_binary_op(x) (opcode_table[x].type == BINARY_OP)
+#define op_precedence(x) (opcode_table[x].prec)
+#define op_format(x) (opcode_table[x].format)
+
+/* _assoc_table -- encodes left-associativity and right-associativity
+   information; indexed by precedence level.  Only 2, 3, 14 are
+   right-associative.  Source:  Kernighan & Ritchie, p. 49 */
+
+extern char _assoc_table[];
+
+#define is_right_assoc(x) (_assoc_table [x])
+#define is_left_assoc(x) (! _assoc_table [x])
+
+
+typedef struct {
+    int type;			/* UNARY_OP or BINARY_OP */
+    int prec;			/* Precedence level, useful for adjusting
+				   number of parens to insert.  Zero is a
+				   special level, and 2, 3, 14 are
+				   right-associative */
+    char *format;
+} table_entry;
+
+
+extern char *fl_fmt_string;	/* Float constant format string */
+extern char *db_fmt_string;	/* Double constant format string */
+extern char *cm_fmt_string;	/* Complex constant format string */
+extern char *dcm_fmt_string;	/* Double Complex constant format string */
+
+extern int indent;		/* Number of spaces to indent; this is a
+				   temporary fix */
+extern int tab_size;		/* Number of spaces in each tab */
+extern int in_string;
+
+extern table_entry opcode_table[];
+
+
+void expr_out (), out_init (), out_addr (), out_const ();
+void out_name (), extern_out (), out_asgoto ();
+void out_if (), out_else (), elif_out ();
+void endif_out (), end_else_out ();
+void compgoto_out (), out_for ();
+void out_end_for (), out_and_free_statement ();

+ 160 - 0
lang/fortran/comp/p1defs.h

@@ -0,0 +1,160 @@
+#define P1_UNKNOWN 0
+#define P1_COMMENT 1		/* Fortan comment string */
+#define P1_EOF 2		/* End of file dummy token */
+#define P1_SET_LINE 3		/* Reset the line counter */
+#define P1_FILENAME 4		/* Name of current input file */
+#define P1_NAME_POINTER 5	/* Pointer to hash table entry */
+#define P1_CONST 6		/* Some constant value */
+#define P1_EXPR 7		/* Followed by opcode */
+
+/* The next two tokens could be grouped together, since they always come
+   from an Addr structure */
+
+#define P1_IDENT 8		/* Char string identifier in addrp->user
+				   field */
+#define P1_EXTERN 9		/* Pointer to external symbol entry */
+
+#define P1_HEAD 10		/* Function header info */
+#define P1_LIST 11		/* A list of data (e.g. arguments) will
+				   follow the tag, type, and count */
+#define P1_LITERAL 12		/* Hold the index into the literal pool */
+#define P1_LABEL 13		/* label value */
+#define P1_ASGOTO 14		/* Store the hash table pointer of
+				   variable used in assigned goto */
+#define P1_GOTO 15		/* Store the statement number */
+#define P1_IF 16		/* store the condition as an expression */
+#define P1_ELSE 17		/* No data */
+#define P1_ELIF 18		/* store the condition as an expression */
+#define P1_ENDIF 19		/* Marks the end of a block IF */
+#define P1_ENDELSE 20		/* Marks the end of a block ELSE */
+#define P1_ADDR 21		/* Addr data; used for arrays, common and
+				   equiv addressing, NOT for names, idents
+				   or externs */
+#define P1_SUBR_RET 22		/* Subroutine return; the return expression
+				   follows */
+#define P1_COMP_GOTO 23		/* Computed goto; has expr, label list */
+#define P1_FOR 24		/* C FOR loop; three expressions follow */
+#define P1_ENDFOR 25		/* End of C FOR loop */
+#define P1_FORTRAN 26		/* original Fortran source */
+#define P1_CHARP 27		/* user.Charp field -- for long names */
+#define P1_WHILE1START 28	/* start of DO WHILE */
+#define P1_WHILE2START 29	/* rest of DO WHILE */
+#define P1_PROCODE 30		/* invoke procode() -- to adjust params */
+#define P1_ELSEIFSTART 31	/* handle extra code for abs, min, max
+				   in else if() */
+
+#define P1_FILENAME_MAX	256	/* max filename length to retain (for -g) */
+#define P1_STMTBUFSIZE 1400
+
+
+
+#define COMMENT_BUFFER_SIZE 255	/* max number of chars in each comment */
+#define CONSTANT_STR_MAX 1000	/* max number of chars in string constant */
+
+extern void p1put (/* int */);
+extern void p1_comment (/* char * */);
+extern void p1_label (/* int */);
+extern void p1_line_number (/* int */);
+extern void p1put_filename();
+extern void p1_expr (/* expptr */);
+extern void p1_head (/* int, char * */);
+extern void p1_if (/* expptr */);
+extern void p1_else ();
+extern void p1_elif (/* expptr */);
+extern void p1_endif ();
+extern void p1else_end ();
+extern void p1_subr_ret (/* expptr */);
+extern void p1_goto(/* long */);
+extern void p1comp_goto (/* expptr, int, struct Labelblock *[] */);
+extern void p1_for (/* expptr, expptr, expptr */);
+extern void p1for_end ();
+
+
+extern void p1puts (/* int, char * */);
+
+/* The pass 1 intermediate file has the following format:
+
+	<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
+
+*/

+ 568 - 0
lang/fortran/comp/p1output.c

@@ -0,0 +1,568 @@
+/****************************************************************
+Copyright 1990, 1991 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+#include "defs.h"
+#include "p1defs.h"
+#include "output.h"
+#include "names.h"
+
+
+static void p1_addr(), p1_big_addr(), p1_binary(), p1_const(), p1_list(),
+	p1_literal(), p1_name(), p1_unary(), p1putn();
+static void p1putd (/* int, int */);
+static void p1putds (/* int, int, char * */);
+static void p1putdds (/* int, int, int, char * */);
+static void p1putdd (/* int, int, int */);
+static void p1putddd (/* int, int, int, int */);
+
+
+/* p1_comment -- save the text of a Fortran comment in the intermediate
+   file.  Make sure that there are no spurious "/ *" or "* /" characters by
+   mapping them onto "/+" and "+/".   str   is assumed to hold no newlines and be
+   null terminated; it may be modified by this function. */
+
+void p1_comment (str)
+char *str;
+{
+    register unsigned char *pointer, *ustr;
+
+    if (!str)
+	return;
+
+/* Get rid of any open or close comment combinations that may be in the
+   Fortran input */
+
+	ustr = (unsigned char *)str;
+	for(pointer = ustr; *pointer; pointer++)
+		if (*pointer == '*' && (pointer[1] == '/'
+					|| pointer > ustr && pointer[-1] == '/'))
+			*pointer = '+';
+	/* trim trailing white space */
+#ifdef isascii
+	while(--pointer >= ustr && (!isascii(*pointer) || isspace(*pointer)));
+#else
+	while(--pointer >= ustr && isspace(*pointer));
+#endif
+	pointer[1] = 0;
+	p1puts (P1_COMMENT, str);
+} /* p1_comment */
+
+void p1_line_number (line_number)
+long line_number;
+{
+
+    p1putd (P1_SET_LINE, line_number);
+} /* p1_line_number */
+
+/* p1_name -- Writes the address of a hash table entry into the
+   intermediate file */
+
+static void p1_name (namep)
+Namep namep;
+{
+	p1putd (P1_NAME_POINTER, (long) namep);
+	namep->visused = 1;
+} /* p1_name */
+
+
+
+void p1_expr (expr)
+expptr expr;
+{
+/* An opcode of 0 means a null entry */
+
+    if (expr == ENULL) {
+	p1putdd (P1_EXPR, 0, TYUNKNOWN);	/* Should this be TYERROR? */
+	return;
+    } /* if (expr == ENULL) */
+
+    switch (expr -> tag) {
+        case TNAME:
+		p1_name ((Namep) expr);
+		return;
+	case TCONST:
+		p1_const(&expr->constblock);
+		return;
+	case TEXPR:
+		/* Fall through the switch */
+		break;
+	case TADDR:
+		p1_addr (&(expr -> addrblock));
+		goto freeup;
+	case TPRIM:
+		warn ("p1_expr:  got TPRIM");
+		return;
+	case TLIST:
+		p1_list (&(expr->listblock));
+		frchain( &(expr->listblock.listp) );
+		return;
+	case TERROR:
+		return;
+	default:
+		erri ("p1_expr: bad tag '%d'", (int) (expr -> tag));
+		return;
+	}
+
+/* Now we know that the tag is TEXPR */
+
+    if (is_unary_op (expr -> exprblock.opcode))
+	p1_unary (&(expr -> exprblock));
+    else if (is_binary_op (expr -> exprblock.opcode))
+	p1_binary (&(expr -> exprblock));
+    else
+	erri ("p1_expr:  bad opcode '%d'", (int) expr -> exprblock.opcode);
+ freeup:
+    free((char *)expr);
+
+} /* p1_expr */
+
+
+
+static void p1_const(cp)
+ register Constp cp;
+{
+	int type = cp->vtype;
+	expptr vleng = cp->vleng;
+	union Constant *c = &cp->Const;
+	char cdsbuf0[64], cdsbuf1[64];
+	char *cds0, *cds1;
+
+    switch (type) {
+        case TYSHORT:
+	case TYLONG:
+	case TYLOGICAL:
+	    fprintf(pass1_file, "%d: %d %ld\n", P1_CONST, type, c->ci);
+	    break;
+	case TYREAL:
+	case TYDREAL:
+		fprintf(pass1_file, "%d: %d %s\n", P1_CONST, type,
+			cp->vstg ? c->cds[0] : cds(dtos(c->cd[0]), cdsbuf0));
+	    break;
+	case TYCOMPLEX:
+	case TYDCOMPLEX:
+		if (cp->vstg) {
+			cds0 = c->cds[0];
+			cds1 = c->cds[1];
+			}
+		else {
+			cds0 = cds(dtos(c->cd[0]), cdsbuf0);
+			cds1 = cds(dtos(c->cd[1]), cdsbuf1);
+			}
+		fprintf(pass1_file, "%d: %d %s %s\n", P1_CONST, type,
+			cds0, cds1);
+	    break;
+	case TYCHAR:
+	    if (vleng && !ISICON (vleng))
+		erri("p1_const:  bad vleng '%d'\n", (int) vleng);
+	    else
+		fprintf(pass1_file, "%d: %d %lx\n", P1_CONST, type,
+			cpexpr((expptr)cp));
+	    break;
+	default:
+	    erri ("p1_const:  bad constant type '%d'", type);
+	    break;
+    } /* switch */
+} /* p1_const */
+
+
+void p1_asgoto (addrp)
+Addrp addrp;
+{
+    p1put (P1_ASGOTO);
+    p1_addr (addrp);
+} /* p1_asgoto */
+
+
+void p1_goto (stateno)
+ftnint stateno;
+{
+    p1putd (P1_GOTO, stateno);
+} /* p1_goto */
+
+
+static void p1_addr (addrp)
+ register struct Addrblock *addrp;
+{
+    int stg;
+
+    if (addrp == (struct Addrblock *) NULL)
+	return;
+
+    stg = addrp -> vstg;
+
+    if (ONEOF(stg, M(STGINIT)|M(STGREG))
+	|| ONEOF(stg, M(STGCOMMON)|M(STGEQUIV)) &&
+		(!ISICON(addrp->memoffset)
+		|| (addrp->uname_tag == UNAM_NAME
+			? addrp->memoffset->constblock.Const.ci
+				!= addrp->user.name->voffset
+			: addrp->memoffset->constblock.Const.ci))
+	|| ONEOF(stg, M(STGBSS)|M(STGINIT)|M(STGAUTO)|M(STGARG)) &&
+		(!ISICON(addrp->memoffset)
+			|| addrp->memoffset->constblock.Const.ci)
+	|| addrp->Field || addrp->isarray || addrp->vstg == STGLENG)
+	{
+		p1_big_addr (addrp);
+		return;
+	}
+
+/* Write out a level of indirection for non-array arguments, which have
+   addrp -> memoffset   set and are handled by   p1_big_addr().
+   Lengths are passed by value, so don't check STGLENG
+   28-Jun-89 (dmg)  Added the check for != TYCHAR
+ */
+
+    if (oneof_stg ( addrp -> uname_tag == UNAM_NAME ? addrp -> user.name : NULL,
+	    stg, M(STGARG)|M(STGEQUIV)) && addrp->vtype != TYCHAR) {
+	p1putdd (P1_EXPR, OPWHATSIN, addrp -> vtype);
+	p1_expr (ENULL);	/* Put dummy   vleng   */
+    } /* if stg == STGARG */
+
+    switch (addrp -> uname_tag) {
+        case UNAM_NAME:
+	    p1_name (addrp -> user.name);
+	    break;
+	case UNAM_IDENT:
+	    p1putdds(P1_IDENT, addrp->vtype, addrp->vstg,
+				addrp->user.ident);
+	    break;
+	case UNAM_CHARP:
+		p1putdds(P1_CHARP, addrp->vtype, addrp->vstg,
+				addrp->user.Charp);
+		break;
+	case UNAM_EXTERN:
+	    p1putd (P1_EXTERN, (long) addrp -> memno);
+	    if (addrp->vclass == CLPROC)
+		extsymtab[addrp->memno].extype = addrp->vtype;
+	    break;
+	case UNAM_CONST:
+	    if (addrp -> memno != BAD_MEMNO)
+		p1_literal (addrp -> memno);
+	    else
+		p1_const((struct Constblock *)addrp);
+	    break;
+	case UNAM_UNKNOWN:
+	default:
+	    erri ("p1_addr:  unknown uname_tag '%d'", addrp -> uname_tag);
+	    break;
+    } /* switch */
+} /* p1_addr */
+
+
+static void p1_list (listp)
+struct Listblock *listp;
+{
+    chainp lis;
+    int count = 0;
+
+    if (listp == (struct Listblock *) NULL)
+	return;
+
+/* Count the number of parameters in the list */
+
+    for (lis = listp -> listp; lis; lis = lis -> nextp)
+	count++;
+
+    p1putddd (P1_LIST, listp -> tag, listp -> vtype, count);
+
+    for (lis = listp -> listp; lis; lis = lis -> nextp)
+	p1_expr ((expptr) lis -> datap);
+
+} /* p1_list */
+
+
+void p1_label (lab)
+long lab;
+{
+	if (parstate < INDATA)
+		earlylabs = mkchain((char *)lab, earlylabs);
+	else
+		p1putd (P1_LABEL, lab);
+	}
+
+
+
+static void p1_literal (memno)
+long memno;
+{
+    p1putd (P1_LITERAL, memno);
+} /* p1_literal */
+
+
+void p1_if (expr)
+expptr expr;
+{
+    p1put (P1_IF);
+    p1_expr (expr);
+} /* p1_if */
+
+
+
+
+void p1_elif (expr)
+expptr expr;
+{
+    p1put (P1_ELIF);
+    p1_expr (expr);
+} /* p1_elif */
+
+
+
+
+void p1_else ()
+{
+    p1put (P1_ELSE);
+} /* p1_else */
+
+
+
+
+void p1_endif ()
+{
+    p1put (P1_ENDIF);
+} /* p1_endif */
+
+
+
+
+void p1else_end ()
+{
+    p1put (P1_ENDELSE);
+} /* p1else_end */
+
+
+static void p1_big_addr (addrp)
+Addrp addrp;
+{
+    if (addrp == (Addrp) NULL)
+	return;
+
+    p1putn (P1_ADDR, sizeof (struct Addrblock), (char *) addrp);
+    p1_expr (addrp -> vleng);
+    p1_expr (addrp -> memoffset);
+    if (addrp->uname_tag == UNAM_NAME)
+	addrp->user.name->visused = 1;
+} /* p1_big_addr */
+
+
+
+static void p1_unary (e)
+struct Exprblock *e;
+{
+    if (e == (struct Exprblock *) NULL)
+	return;
+
+    p1putdd (P1_EXPR, (int) e -> opcode, e -> vtype);
+    p1_expr (e -> vleng);
+
+    switch (e -> opcode) {
+        case OPNEG:
+	case OPNEG1:
+	case OPNOT:
+	case OPABS:
+	case OPBITNOT:
+	case OPPREINC:
+	case OPPREDEC:
+	case OPADDR:
+	case OPIDENTITY:
+	case OPCHARCAST:
+	case OPDABS:
+	    p1_expr(e -> leftp);
+	    break;
+	default:
+	    erri ("p1_unary: bad opcode '%d'", (int) e -> opcode);
+	    break;
+    } /* switch */
+
+} /* p1_unary */
+
+
+static void p1_binary (e)
+struct Exprblock *e;
+{
+    if (e == (struct Exprblock *) NULL)
+	return;
+
+    p1putdd (P1_EXPR, e -> opcode, e -> vtype);
+    p1_expr (e -> vleng);
+    p1_expr (e -> leftp);
+    p1_expr (e -> rightp);
+} /* p1_binary */
+
+
+void p1_head (class, name)
+int class;
+char *name;
+{
+    p1putds (P1_HEAD, class, name ? name : "");
+} /* p1_head */
+
+
+void p1_subr_ret (retexp)
+expptr retexp;
+{
+
+    p1put (P1_SUBR_RET);
+    p1_expr (cpexpr(retexp));
+} /* p1_subr_ret */
+
+
+
+void p1comp_goto (index, count, labels)
+expptr index;
+int count;
+struct Labelblock *labels[];
+{
+    struct Constblock c;
+    int i;
+    register struct Labelblock *L;
+
+    p1put (P1_COMP_GOTO);
+    p1_expr (index);
+
+/* Write out a P1_LIST directly, to avoid the overhead of allocating a
+   list before it's needed HACK HACK HACK */
+
+    p1putddd (P1_LIST, TLIST, TYUNKNOWN, count);
+    c.vtype = TYLONG;
+    c.vleng = 0;
+
+    for (i = 0; i < count; i++) {
+	L = labels[i];
+	L->labused = 1;
+	c.Const.ci = L->stateno;
+	p1_const(&c);
+    } /* for i = 0 */
+} /* p1comp_goto */
+
+
+
+void p1_for (init, test, inc)
+expptr init, test, inc;
+{
+    p1put (P1_FOR);
+    p1_expr (init);
+    p1_expr (test);
+    p1_expr (inc);
+} /* p1_for */
+
+
+void p1for_end ()
+{
+    p1put (P1_ENDFOR);
+} /* p1for_end */
+
+
+
+
+/* ----------------------------------------------------------------------
+   The intermediate file actually gets written ONLY by the routines below.
+   To change the format of the file, you need only change these routines.
+   ----------------------------------------------------------------------
+*/
+
+
+/* p1puts -- Put a typed string into the Pass 1 intermediate file.  Assumes that
+   str   contains no newlines and is null-terminated. */
+
+void p1puts (type, str)
+int type;
+char *str;
+{
+    fprintf (pass1_file, "%d: %s\n", type, str);
+} /* p1puts */
+
+
+/* p1putd -- Put a typed integer into the Pass 1 intermediate file. */
+
+static void p1putd (type, value)
+int type;
+long value;
+{
+    fprintf (pass1_file, "%d: %ld\n", type, value);
+} /* p1_putd */
+
+
+/* p1putdd -- Put a typed pair of integers into the intermediate file. */
+
+static void p1putdd (type, v1, v2)
+int type, v1, v2;
+{
+    fprintf (pass1_file, "%d: %d %d\n", type, v1, v2);
+} /* p1putdd */
+
+
+/* p1putddd -- Put a typed triple of integers into the intermediate file. */
+
+static void p1putddd (type, v1, v2, v3)
+int type, v1, v2, v3;
+{
+    fprintf (pass1_file, "%d: %d %d %d\n", type, v1, v2, v3);
+} /* p1putddd */
+
+ union dL {
+	double d;
+	long L[2];
+	};
+
+static void p1putn (type, count, str)
+int type, count;
+char *str;
+{
+    int i;
+
+    fprintf (pass1_file, "%d: ", type);
+
+    for (i = 0; i < count; i++)
+	putc (str[i], pass1_file);
+
+    putc ('\n', pass1_file);
+} /* p1putn */
+
+
+
+/* p1put -- Put a type marker into the intermediate file. */
+
+void p1put(type)
+int type;
+{
+    fprintf (pass1_file, "%d:\n", type);
+} /* p1put */
+
+
+
+static void p1putds (type, i, str)
+int type;
+int i;
+char *str;
+{
+    fprintf (pass1_file, "%d: %d %s\n", type, i, str);
+} /* p1putds */
+
+
+static void p1putdds (token, type, stg, str)
+int token, type, stg;
+char *str;
+{
+    fprintf (pass1_file, "%d: %d %d %s\n", token, type, stg, str);
+} /* p1putdds */

+ 39 - 0
lang/fortran/comp/parse.h

@@ -0,0 +1,39 @@
+#ifndef PARSE_INCLUDE
+#define PARSE_INCLUDE
+
+/* macros for the   parse_args   routine */
+
+#define P_STRING 1		/* Macros for the result_type attribute */
+#define P_CHAR 2
+#define P_SHORT 3
+#define P_INT 4
+#define P_LONG 5
+#define P_FILE 6
+#define P_OLD_FILE 7
+#define P_NEW_FILE 8
+#define P_FLOAT 9
+#define P_DOUBLE 10
+
+#define P_CASE_INSENSITIVE 01	/* Macros for the   flags   attribute */
+#define P_REQUIRED_PREFIX 02
+
+#define P_NO_ARGS 0		/* Macros for the   arg_count   attribute */
+#define P_ONE_ARG 1
+#define P_INFINITE_ARGS 2
+
+#define p_entry(pref,swit,flag,count,type,store,size) \
+    { (pref), (swit), (flag), (count), (type), (int *) (store), (size) }
+
+typedef struct {
+    char *prefix;
+    char *string;
+    int flags;
+    int count;
+    int result_type;
+    int *result_ptr;
+    int table_size;
+} arg_info;
+
+extern int parse_args ();
+
+#endif

+ 499 - 0
lang/fortran/comp/parse_args.c

@@ -0,0 +1,499 @@
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+/* parse_args
+
+	This function will parse command line input into appropriate data
+   structures, output error messages when appropriate and provide some
+   minimal type conversion.
+
+	Input to the function consists of the standard   argc,argv
+   values, and a table which directs the parser.  Each table entry has the
+   following components:
+
+	prefix -- the (optional) switch character string, e.g. "-" "/" "="
+	switch -- the command string, e.g. "o" "data" "file" "F"
+	flags -- control flags, e.g.   CASE_INSENSITIVE, REQUIRED_PREFIX
+	arg_count -- number of arguments this command requires, e.g. 0 for
+		     booleans, 1 for filenames, INFINITY for input files
+	result_type -- how to interpret the switch arguments, e.g. STRING,
+		       CHAR, FILE, OLD_FILE, NEW_FILE
+	result_ptr -- pointer to storage for the result, be it a table or
+		      a string or whatever
+	table_size -- if the arguments fill a table, the maximum number of
+		      entries; if there are no arguments, the value to
+		      load into the result storage
+
+	Although the table can be used to hold a list of filenames, only
+   scalar values (e.g. pointers) can be stored in the table.  No vector
+   processing will be done, only pointers to string storage will be moved.
+
+	An example entry, which could be used to parse input filenames, is:
+
+	"-", "o", 0, oo, OLD_FILE, infilenames, INFILE_TABLE_SIZE
+
+*/
+
+#include <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 */
+

+ 64 - 0
lang/fortran/comp/pccdefs.h

@@ -0,0 +1,64 @@
+/* The following numbers are strange, and implementation-dependent */
+
+#define P2BAD -1
+#define P2NAME 2
+#define P2ICON 4		/* Integer constant */
+#define P2PLUS 6
+#define P2PLUSEQ 7
+#define P2MINUS 8
+#define P2NEG 10
+#define P2STAR 11
+#define P2STAREQ 12
+#define P2INDIRECT 13
+#define P2BITAND 14
+#define P2BITOR 17
+#define P2BITXOR 19
+#define P2QUEST 21
+#define P2COLON 22
+#define P2ANDAND 23
+#define P2OROR 24
+#define P2GOTO 37
+#define P2LISTOP 56
+#define P2ASSIGN 58
+#define P2COMOP 59
+#define P2SLASH 60
+#define P2MOD 62
+#define P2LSHIFT 64
+#define P2RSHIFT 66
+#define P2CALL 70
+#define P2CALL0 72
+
+#define P2NOT 76
+#define P2BITNOT 77
+#define P2EQ 80
+#define P2NE 81
+#define P2LE 82
+#define P2LT 83
+#define P2GE 84
+#define P2GT 85
+#define P2REG 94
+#define P2OREG 95
+#define P2CONV 104
+#define P2FORCE 108
+#define P2CBRANCH 109
+
+/* special operators included only for fortran's use */
+
+#define P2PASS 200
+#define P2STMT 201
+#define P2SWITCH 202
+#define P2LBRACKET 203
+#define P2RBRACKET 204
+#define P2EOF 205
+#define P2ARIF 206
+#define P2LABEL 207
+
+#define P2SHORT 3
+#define P2INT 4
+#define P2LONG 4
+
+#define P2CHAR 2
+#define P2REAL 6
+#define P2DREAL 7
+#define P2PTR 020
+#define P2FUNCT 040

+ 881 - 0
lang/fortran/comp/pread.c

@@ -0,0 +1,881 @@
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+#include "defs.h"
+
+ static char Ptok[128], Pct[Table_size];
+ static char *Pfname;
+ static long Plineno;
+ static int Pbad;
+ static int *tfirst, *tlast, *tnext, tmax;
+
+#define P_space	1
+#define P_anum	2
+#define P_delim	3
+#define P_slash	4
+
+#define TGULP	100
+
+ static void
+trealloc()
+{
+	int k = tmax;
+	tfirst = (int *)realloc((char *)tfirst,
+		(tmax += TGULP)*sizeof(int));
+	if (!tfirst) {
+		fprintf(stderr,
+		"Pfile: realloc failure!\n");
+		exit(2);
+		}
+	tlast = tfirst + tmax;
+	tnext = tfirst + k;
+	}
+
+ static void
+badchar(c)
+ int c;
+{
+	fprintf(stderr,
+		"unexpected character 0x%.2x = '%c' on line %ld of %s\n",
+		c, c, Plineno, Pfname);
+	exit(2);
+	}
+
+ static void
+bad_type()
+{
+	fprintf(stderr,
+		"unexpected type \"%s\" on line %ld of %s\n",
+		Ptok, Plineno, Pfname);
+	exit(2);
+	}
+
+ static void
+badflag(tname, option)
+ char *tname, *option;
+{
+	fprintf(stderr, "%s type from `f2c -%s` on line %ld of %s\n",
+		tname, option, Plineno, Pfname);
+	Pbad++;
+	}
+
+ static void
+detected(msg)
+ char *msg;
+{
+	fprintf(stderr,
+	"%sdetected on line %ld of %s\n", msg, Plineno, Pfname);
+	Pbad++;
+	}
+
+ static void
+checklogical(k)
+ int k;
+{
+	static int lastmsg = 0;
+	static int seen[2] = {0,0};
+
+	seen[k] = 1;
+	if (seen[1-k]) {
+		if (lastmsg < 3) {
+			lastmsg = 3;
+			detected(
+	"Illegal combination of LOGICAL types -- mixing -I4 with -I2 or -i2\n\t");
+			}
+		return;
+		}
+	if (k) {
+		if (tylogical == TYLONG || lastmsg >= 2)
+			return;
+		if (!lastmsg) {
+			lastmsg = 2;
+			badflag("LOGICAL", "I4");
+			}
+		}
+	else {
+		if (tylogical == TYSHORT || lastmsg & 1)
+			return;
+		if (!lastmsg) {
+			lastmsg = 1;
+			badflag("LOGICAL", "i2` or `f2c -I2");
+			}
+		}
+	}
+
+ static void
+checkreal(k)
+{
+	static int warned = 0;
+	static int seen[2] = {0,0};
+
+	seen[k] = 1;
+	if (seen[1-k]) {
+		if (warned < 2)
+			detected("Illegal mixture of -R and -!R ");
+		warned = 2;
+		return;
+		}
+	if (k == forcedouble || warned)
+		return;
+	warned = 1;
+	badflag("REAL return", k ? "!R" : "R");
+	}
+
+ static void
+Pnotboth(e)
+ Extsym *e;
+{
+	if (e->curno)
+		return;
+	Pbad++;
+	e->curno = 1;
+	fprintf(stderr,
+	"%s cannot be both a procedure and a common block (line %ld of %s)\n",
+		e->fextname, Plineno, Pfname);
+	}
+
+ static int
+numread(pf, n)
+ register FILE *pf;
+ int *n;
+{
+	register int c, k;
+
+	if ((c = getc(pf)) < '0' || c > '9')
+		return c;
+	k = c - '0';
+	for(;;) {
+		if ((c = getc(pf)) == ' ') {
+			*n = k;
+			return c;
+			}
+		if (c < '0' || c > '9')
+			break;
+		k = 10*k + c - '0';
+		}
+	return c;
+	}
+
+ static void argverify(), Pbadret();
+
+ static int
+readref(pf, e, ftype)
+ register FILE *pf;
+ Extsym *e;
+ int ftype;
+{
+	register int c, *t;
+	int i, nargs, type;
+	Argtypes *at;
+	Atype *a, *ae;
+
+	if (ftype > TYSUBR)
+		return 0;
+	if ((c = numread(pf, &nargs)) != ' ') {
+		if (c != ':')
+			return c == EOF;
+		/* just a typed external */
+		if (e->extstg == STGUNKNOWN) {
+			at = 0;
+			goto justsym;
+			}
+		if (e->extstg == STGEXT) {
+			if (e->extype != ftype)
+				Pbadret(ftype, e);
+			}
+		else
+			Pnotboth(e);
+		return 0;
+		}
+
+	tnext = tfirst;
+	for(i = 0; i < nargs; i++) {
+		if ((c = numread(pf, &type)) != ' '
+		|| type >= 500
+		|| type != TYFTNLEN + 100 && type % 100 > TYSUBR)
+			return c == EOF;
+		if (tnext >= tlast)
+			trealloc();
+		*tnext++ = type;
+		}
+
+	if (e->extstg == STGUNKNOWN) {
+ save_at:
+		at = (Argtypes *)
+			gmem(sizeof(Argtypes) + (nargs-1)*sizeof(Atype), 1);
+		at->nargs = nargs;
+		at->changes = 0;
+		t = tfirst;
+		a = at->atypes;
+		for(ae = a + nargs; a < ae; a++) {
+			a->type = *t++;
+			a->cp = 0;
+			}
+ justsym:
+		e->extstg = STGEXT;
+		e->extype = ftype;
+		e->arginfo = at;
+		}
+	else if (e->extstg != STGEXT) {
+		Pnotboth(e);
+		}
+	else if (!e->arginfo) {
+		if (e->extype != ftype)
+			Pbadret(ftype, e);
+		else
+			goto save_at;
+		}
+	else
+		argverify(ftype, e);
+	return 0;
+	}
+
+ static int
+comlen(pf)
+ register FILE *pf;
+{
+	register int c;
+	register char *s, *se;
+	char buf[128], cbuf[128];
+	int refread;
+	long L;
+	Extsym *e;
+
+	if ((c = getc(pf)) == EOF)
+		return 1;
+	if (c == ' ') {
+		refread = 0;
+		s = "comlen ";
+		}
+	else if (c == ':') {
+		refread = 1;
+		s = "ref: ";
+		}
+	else {
+ ret0:
+		if (c == '*')
+			ungetc(c,pf);
+		return 0;
+		}
+	while(*s) {
+		if ((c = getc(pf)) == EOF)
+			return 1;
+		if (c != *s++)
+			goto ret0;
+		}
+	s = buf;
+	se = buf + sizeof(buf) - 1;
+	for(;;) {
+		if ((c = getc(pf)) == EOF)
+			return 1;
+		if (c == ' ')
+			break;
+		if (s >= se || Pct[c] != P_anum)
+			goto ret0;
+		*s++ = c;
+		}
+	*s-- = 0;
+	if (s <= buf || *s != '_')
+		return 0;
+	strcpy(cbuf,buf);
+	*s-- = 0;
+	if (*s == '_') {
+		*s-- = 0;
+		if (s <= buf)
+			return 0;
+		}
+	for(L = 0;;) {
+		if ((c = getc(pf)) == EOF)
+			return 1;
+		if (c == ' ')
+			break;
+		if (c < '0' && c > '9')
+			goto ret0;
+		L = 10*L + c - '0';
+		}
+	if (!L && !refread)
+		return 0;
+	e = mkext(buf, cbuf);
+	if (refread)
+		return readref(pf, e, (int)L);
+	if (e->extstg == STGUNKNOWN) {
+		e->extstg = STGCOMMON;
+		e->maxleng = L;
+		}
+	else if (e->extstg != STGCOMMON)
+		Pnotboth(e);
+	else if (e->maxleng != L) {
+		fprintf(stderr,
+	"incompatible lengths for common block %s (line %ld of %s)\n",
+				    buf, Plineno, Pfname);
+		if (e->maxleng < L)
+			e->maxleng = L;
+		}
+	return 0;
+	}
+
+ static int
+Ptoken(pf, canend)
+ FILE *pf;
+ int canend;
+{
+	register int c;
+	register char *s, *se;
+
+ top:
+	for(;;) {
+		c = getc(pf);
+		if (c == EOF) {
+			if (canend)
+				return 0;
+			goto badeof;
+			}
+		if (Pct[c] != P_space)
+			break;
+		if (c == '\n')
+			Plineno++;
+		}
+	switch(Pct[c]) {
+		case P_anum:
+			if (c == '_')
+				badchar(c);
+			s = Ptok;
+			se = s + sizeof(Ptok) - 1;
+			do {
+				if (s < se)
+					*s++ = c;
+				if ((c = getc(pf)) == EOF) {
+ badeof:
+					fprintf(stderr,
+					"unexpected end of file in %s\n",
+						Pfname);
+					exit(2);
+					}
+				}
+				while(Pct[c] == P_anum);
+			ungetc(c,pf);
+			*s = 0;
+			return P_anum;
+
+		case P_delim:
+			return c;
+
+		case P_slash:
+			if ((c = getc(pf)) != '*') {
+				if (c == EOF)
+					goto badeof;
+				badchar('/');
+				}
+			if (canend && comlen(pf))
+				goto badeof;
+			for(;;) {
+				while((c = getc(pf)) != '*') {
+					if (c == EOF)
+						goto badeof;
+					if (c == '\n')
+						Plineno++;
+					}
+ slashseek:
+				switch(getc(pf)) {
+					case '/':
+						goto top;
+					case EOF:
+						goto badeof;
+					case '*':
+						goto slashseek;
+					}
+				}
+		default:
+			badchar(c);
+		}
+	/* NOT REACHED */
+	return 0;
+	}
+
+ static int
+Pftype()
+{
+	switch(Ptok[0]) {
+		case 'C':
+			if (!strcmp(Ptok+1, "_f"))
+				return TYCOMPLEX;
+			break;
+		case 'E':
+			if (!strcmp(Ptok+1, "_f")) {
+				/* TYREAL under forcedouble */
+				checkreal(1);
+				return TYREAL;
+				}
+			break;
+		case 'H':
+			if (!strcmp(Ptok+1, "_f"))
+				return TYCHAR;
+			break;
+		case 'Z':
+			if (!strcmp(Ptok+1, "_f"))
+				return TYDCOMPLEX;
+			break;
+		case 'd':
+			if (!strcmp(Ptok+1, "oublereal"))
+				return TYDREAL;
+			break;
+		case 'i':
+			if (!strcmp(Ptok+1, "nt"))
+				return TYSUBR;
+			if (!strcmp(Ptok+1, "nteger"))
+				return TYLONG;
+			break;
+		case 'l':
+			if (!strcmp(Ptok+1, "ogical")) {
+				checklogical(1);
+				return TYLOGICAL;
+				}
+			break;
+		case 'r':
+			if (!strcmp(Ptok+1, "eal")) {
+				checkreal(0);
+				return TYREAL;
+				}
+			break;
+		case 's':
+			if (!strcmp(Ptok+1, "hortint"))
+				return TYSHORT;
+			if (!strcmp(Ptok+1, "hortlogical")) {
+				checklogical(0);
+				return TYLOGICAL;
+				}
+			break;
+		}
+	bad_type();
+	/* NOT REACHED */
+	return 0;
+	}
+
+ static void
+wanted(i, what)
+ int i;
+ char *what;
+{
+	if (i != P_anum) {
+		Ptok[0] = i;
+		Ptok[1] = 0;
+		}
+	fprintf(stderr,"Error: expected %s, not \"%s\" (line %ld of %s)\n",
+		what, Ptok, Plineno, Pfname);
+	exit(2);
+	}
+
+ static int
+Ptype(pf)
+ FILE *pf;
+{
+	int i, rv;
+
+	i = Ptoken(pf,0);
+	if (i == ')')
+		return 0;
+	if (i != P_anum)
+		badchar(i);
+
+	rv = 0;
+	switch(Ptok[0]) {
+		case 'C':
+			if (!strcmp(Ptok+1, "_fp"))
+				rv = TYCOMPLEX+200;
+			break;
+		case 'D':
+			if (!strcmp(Ptok+1, "_fp"))
+				rv = TYDREAL+200;
+			break;
+		case 'E':
+		case 'R':
+			if (!strcmp(Ptok+1, "_fp"))
+				rv = TYREAL+200;
+			break;
+		case 'H':
+			if (!strcmp(Ptok+1, "_fp"))
+				rv = TYCHAR+200;
+			break;
+		case 'I':
+			if (!strcmp(Ptok+1, "_fp"))
+				rv = TYLONG+200;
+			break;
+		case 'J':
+			if (!strcmp(Ptok+1, "_fp"))
+				rv = TYSHORT+200;
+			break;
+		case 'K':
+			checklogical(0);
+			goto Logical;
+		case 'L':
+			checklogical(1);
+ Logical:
+			if (!strcmp(Ptok+1, "_fp"))
+				rv = TYLOGICAL+200;
+			break;
+		case 'S':
+			if (!strcmp(Ptok+1, "_fp"))
+				rv = TYSUBR+200;
+			break;
+		case 'U':
+			if (!strcmp(Ptok+1, "_fp"))
+				rv = TYUNKNOWN+300;
+			break;
+		case 'Z':
+			if (!strcmp(Ptok+1, "_fp"))
+				rv = TYDCOMPLEX+200;
+			break;
+		case 'c':
+			if (!strcmp(Ptok+1, "har"))
+				rv = TYCHAR;
+			else if (!strcmp(Ptok+1, "omplex"))
+				rv = TYCOMPLEX;
+			break;
+		case 'd':
+			if (!strcmp(Ptok+1, "oublereal"))
+				rv = TYDREAL;
+			else if (!strcmp(Ptok+1, "oublecomplex"))
+				rv = TYDCOMPLEX;
+			break;
+		case 'f':
+			if (!strcmp(Ptok+1, "tnlen"))
+				rv = TYFTNLEN+100;
+			break;
+		case 'i':
+			if (!strcmp(Ptok+1, "nteger"))
+				rv = TYLONG;
+			break;
+		case 'l':
+			if (!strcmp(Ptok+1, "ogical")) {
+				checklogical(1);
+				rv = TYLOGICAL;
+				}
+			break;
+		case 'r':
+			if (!strcmp(Ptok+1, "eal"))
+				rv = TYREAL;
+			break;
+		case 's':
+			if (!strcmp(Ptok+1, "hortint"))
+				rv = TYSHORT;
+			else if (!strcmp(Ptok+1, "hortlogical")) {
+				checklogical(0);
+				rv = TYLOGICAL;
+				}
+			break;
+		case 'v':
+			if (tnext == tfirst && !strcmp(Ptok+1, "oid")) {
+				if ((i = Ptoken(pf,0)) != /*(*/ ')')
+					wanted(i, /*(*/ "\")\"");
+				return 0;
+				}
+		}
+	if (!rv)
+		bad_type();
+	if (rv < 100 && (i = Ptoken(pf,0)) != '*')
+			wanted(i, "\"*\"");
+	if ((i = Ptoken(pf,0)) == P_anum)
+		i = Ptoken(pf,0);	/* skip variable name */
+	switch(i) {
+		case ')':
+			ungetc(i,pf);
+			break;
+		case ',':
+			break;
+		default:
+			wanted(i, "\",\" or \")\"");
+		}
+	return rv;
+	}
+
+ static char *
+trimunder()
+{
+	register char *s;
+	register int n;
+	static char buf[128];
+
+	s = Ptok + strlen(Ptok) - 1;
+	if (*s != '_') {
+		fprintf(stderr,
+			"warning: %s does not end in _ (line %ld of %s)\n",
+			Ptok, Plineno, Pfname);
+		return Ptok;
+		}
+	if (s[-1] == '_')
+		s--;
+	strncpy(buf, Ptok, n = s - Ptok);
+	buf[n] = 0;
+	return buf;
+	}
+
+ static void
+Pbadmsg(msg, p)
+ char *msg;
+ Extsym *p;
+{
+	Pbad++;
+	fprintf(stderr, "%s for %s (line %ld of %s):\n\t", msg,
+		p->fextname, Plineno, Pfname);
+	p->arginfo->nargs = -1;
+	}
+
+ char *Argtype();
+
+ static void
+Pbadret(ftype, p)
+ int ftype;
+ Extsym *p;
+{
+	char buf1[32], buf2[32];
+
+	Pbadmsg("inconsistent types",p);
+	fprintf(stderr, "here %s, previously %s\n",
+		Argtype(ftype+200,buf1),
+		Argtype(p->extype+200,buf2));
+	}
+
+ static void
+argverify(ftype, p)
+ int ftype;
+ Extsym *p;
+{
+	Argtypes *at;
+	register Atype *aty;
+	int i, j, k;
+	register int *t, *te;
+	char buf1[32], buf2[32];
+	int type_fixup();
+
+	at = p->arginfo;
+	if (at->nargs < 0)
+		return;
+	if (p->extype != ftype) {
+		Pbadret(ftype, p);
+		return;
+		}
+	t = tfirst;
+	te = tnext;
+	i = te - t;
+	if (at->nargs != i) {
+		j = at->nargs;
+		Pbadmsg("differing numbers of arguments",p);
+		fprintf(stderr, "here %d, previously %d\n",
+			i, j);
+		return;
+		}
+	for(aty = at->atypes; t < te; t++, aty++) {
+		if (*t == aty->type)
+			continue;
+		j = aty->type;
+		k = *t;
+		if (k >= 300 || k == j)
+			continue;
+		if (j >= 300) {
+			if (k >= 200) {
+				if (k == TYUNKNOWN + 200)
+					continue;
+				if (j % 100 != k - 200
+				 && k != TYSUBR + 200
+				 && j != TYUNKNOWN + 300
+				 && !type_fixup(at,aty,k))
+					goto badtypes;
+				}
+			else if (j % 100 % TYSUBR != k % TYSUBR
+					&& !type_fixup(at,aty,k))
+				goto badtypes;
+			}
+		else if (k < 200 || j < 200)
+			goto badtypes;
+		else if (k == TYUNKNOWN+200)
+			continue;
+		else if (j != TYUNKNOWN+200)
+			{
+ badtypes:
+			Pbadmsg("differing calling sequences",p);
+			i = t - tfirst + 1;
+			fprintf(stderr,
+				"arg %d: here %s, prevously %s\n",
+				i, Argtype(k,buf1), Argtype(j,buf2));
+			return;
+			}
+		/* We've subsequently learned the right type,
+		   as in the call on zoo below...
+
+			subroutine foo(x, zap)
+			external zap
+			call goo(zap)
+			x = zap(3)
+			call zoo(zap)
+			end
+		 */
+		aty->type = k;
+		at->changes = 1;
+		}
+	}
+
+ static void
+newarg(ftype, p)
+ int ftype;
+ Extsym *p;
+{
+	Argtypes *at;
+	register Atype *aty;
+	register int *t, *te;
+	int i, k;
+
+	if (p->extstg == STGCOMMON) {
+		Pnotboth(p);
+		return;
+		}
+	p->extstg = STGEXT;
+	p->extype = ftype;
+	p->exproto = 1;
+	t = tfirst;
+	te = tnext;
+	i = te - t;
+	k = sizeof(Argtypes) + (i-1)*sizeof(Atype);
+	at = p->arginfo = (Argtypes *)gmem(k,1);
+	at->nargs = i;
+	at->changes = 0;
+	for(aty = at->atypes; t < te; aty++) {
+		aty->type = *t++;
+		aty->cp = 0;
+		}
+	}
+
+ static int
+Pfile(fname)
+ char *fname;
+{
+	char *s;
+	int ftype, i;
+	FILE *pf;
+	Extsym *p;
+
+	for(s = fname; *s; s++);
+	if (s - fname < 2
+	|| s[-2] != '.'
+	|| (s[-1] != 'P' && s[-1] != 'p'))
+		return 0;
+
+	if (!(pf = fopen(fname, textread))) {
+		fprintf(stderr, "can't open %s\n", fname);
+		exit(2);
+		}
+	Pfname = fname;
+	Plineno = 1;
+	if (!Pct[' ']) {
+		for(s = " \t\n\r\v\f"; *s; s++)
+			Pct[*s] = P_space;
+		for(s = "*,();"; *s; s++)
+			Pct[*s] = P_delim;
+		for(i = '0'; i <= '9'; i++)
+			Pct[i] = P_anum;
+		for(s = "abcdefghijklmnopqrstuvwxyz"; i = *s; s++)
+			Pct[i] = Pct[i+'A'-'a'] = P_anum;
+		Pct['_'] = P_anum;
+		Pct['/'] = P_slash;
+		}
+
+	for(;;) {
+		if (!(i = Ptoken(pf,1)))
+			break;
+		if (i != P_anum
+		|| !strcmp(Ptok, "extern")
+		&& (i = Ptoken(pf,0)) != P_anum)
+			badchar(i);
+		ftype = Pftype();
+ getname:
+		if ((i = Ptoken(pf,0)) != P_anum)
+			badchar(i);
+		p = mkext(trimunder(), Ptok);
+
+		if ((i = Ptoken(pf,0)) != '(')
+			badchar(i);
+		tnext = tfirst;
+		while(i = Ptype(pf)) {
+			if (tnext >= tlast)
+				trealloc();
+			*tnext++ = i;
+			}
+		if (p->arginfo)
+			argverify(ftype, p);
+		else
+			newarg(ftype, p);
+		i = Ptoken(pf,0);
+		switch(i) {
+			case ';':
+				break;
+			case ',':
+				goto getname;
+			default:
+				wanted(i, "\";\" or \",\"");
+			}
+		}
+	fclose(pf);
+	return 1;
+	}
+
+ void
+read_Pfiles(ffiles)
+ char **ffiles;
+{
+	char **f1files, **f1files0, *s;
+	int k;
+	register Extsym *e, *ee;
+	register Argtypes *at;
+	extern int retcode;
+
+	f1files0 = f1files = ffiles;
+	while(s = *ffiles++)
+		if (!Pfile(s))
+			*f1files++ = s;
+	if (Pbad)
+		retcode = 8;
+	if (tfirst) {
+		free((char *)tfirst);
+		/* following should be unnecessary, as we won't be back here */
+		tfirst = tnext = tlast = 0;
+		tmax = 0;
+		}
+	*f1files = 0;
+	if (f1files == f1files0)
+		f1files[1] = 0;
+
+	k = 0;
+	ee = nextext;
+	for (e = extsymtab; e < ee; e++)
+		if (e->extstg == STGEXT
+		&& (at = e->arginfo)) {
+			if (at->nargs < 0 || at->changes)
+				k++;
+			at->changes = 2;
+			}
+	if (k) {
+		fprintf(diagfile,
+		"%d prototype%s updated while reading prototypes.\n", k,
+			k > 1 ? "s" : "");
+		}
+	fflush(diagfile);
+	}

+ 1562 - 0
lang/fortran/comp/proc.c

@@ -0,0 +1,1562 @@
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+#include "defs.h"
+#include "names.h"
+#include "output.h"
+#include "p1defs.h"
+
+#define EXNULL (union Expression *)0
+
+LOCAL dobss(), docomleng(), docommon(), doentry(),
+	epicode(), nextarg(), retval();
+
+static char Blank[] = BLANKCOMMON;
+
+ static char *postfix[] = { "h", "i", "r", "d", "c", "z", "i" };
+
+ chainp new_procs;
+ int prev_proc, proc_argchanges, proc_protochanges;
+
+ void
+changedtype(q)
+ Namep q;
+{
+	char buf[200];
+	int qtype, type1;
+	register Extsym *e;
+	Argtypes *at;
+
+	if (q->vtypewarned)
+		return;
+	q->vtypewarned = 1;
+	qtype = q->vtype;
+	e = &extsymtab[q->vardesc.varno];
+	if (!(at = e->arginfo)) {
+		if (!e->exused)
+			return;
+		}
+	else if (at->changes & 2 && qtype != TYUNKNOWN)
+		proc_protochanges++;
+	type1 = e->extype;
+	if (type1 == TYUNKNOWN)
+		return;
+	if (qtype == TYUNKNOWN)
+		/* e.g.,
+			subroutine foo
+			end
+			external foo
+			call goo(foo)
+			end
+		*/
+		return;
+	sprintf(buf, "%.90s: inconsistent declarations:\n\
+	here %s%s, previously %s%s.", q->fvarname, ftn_types[qtype],
+		qtype == TYSUBR ? "" : " function",
+		ftn_types[type1], type1 == TYSUBR ? "" : " function");
+	warn(buf);
+	}
+
+ void
+unamstring(q, s)
+ register Addrp q;
+ register char *s;
+{
+	register int k;
+	register char *t;
+
+	k = strlen(s);
+	if (k < IDENT_LEN) {
+		q->uname_tag = UNAM_IDENT;
+		t = q->user.ident;
+		}
+	else {
+		q->uname_tag = UNAM_CHARP;
+		q->user.Charp = t = mem(k+1, 0);
+		}
+	strcpy(t, s);
+	}
+
+ static void
+fix_entry_returns()	/* for multiple entry points */
+{
+	Addrp a;
+	int i;
+	struct Entrypoint *e;
+	Namep np;
+
+	e = entries = (struct Entrypoint *)revchain((chainp)entries);
+	allargs = revchain(allargs);
+	if (!multitype)
+		return;
+
+	/* TYLOGICAL should have been turned into TYLONG or TYSHORT by now */
+
+	for(i = TYSHORT; i <= TYLOGICAL; i++)
+		if (a = xretslot[i])
+			sprintf(a->user.ident, "(*ret_val).%s",
+				postfix[i-TYSHORT]);
+
+	do {
+		np = e->enamep;
+		switch(np->vtype) {
+			case TYSHORT:
+			case TYLONG:
+			case TYREAL:
+			case TYDREAL:
+			case TYCOMPLEX:
+			case TYDCOMPLEX:
+			case TYLOGICAL:
+				np->vstg = STGARG;
+			}
+		}
+		while(e = e->entnextp);
+	}
+
+ static void
+putentries(outfile)	/* put out wrappers for multiple entries */
+ FILE *outfile;
+{
+	char base[IDENT_LEN];
+	struct Entrypoint *e;
+	Namep *A, *Ae, *Ae1, **Alp, *a, **a1, np;
+	chainp args, lengths, length_comp();
+	void listargs(), list_arg_types();
+	int i, k, mt, nL, type;
+	extern char *dfltarg[], **dfltproc;
+
+	nL = (nallargs + nallchargs) * sizeof(Namep *);
+	A = (Namep *)ckalloc(nL + nallargs*sizeof(Namep **));
+	Ae = A + nallargs;
+	Alp = (Namep **)(Ae1 = Ae + nallchargs);
+	i = k = 0;
+	for(a1 = Alp, args = allargs; args; a1++, args = args->nextp) {
+		np = (Namep)args->datap;
+		if (np->vtype == TYCHAR && np->vclass != CLPROC)
+			*a1 = &Ae[i++];
+		}
+
+	e = entries;
+	mt = multitype;
+	multitype = 0;
+	sprintf(base, "%s0_", e->enamep->cvarname);
+	do {
+		np = e->enamep;
+		lengths = length_comp(e, 0);
+		proctype = type = np->vtype;
+		if (protofile)
+			protowrite(protofile, type, np->cvarname, e, lengths);
+		nice_printf(outfile, "\n%s ", c_type_decl(type, 1));
+		nice_printf(outfile, "%s", np->cvarname);
+		if (!Ansi) {
+			listargs(outfile, e, 0, lengths);
+			nice_printf(outfile, "\n");
+			}
+	    	list_arg_types(outfile, e, lengths, 0, "\n");
+		nice_printf(outfile, "{\n");
+		frchain(&lengths);
+		next_tab(outfile);
+		if (mt)
+			nice_printf(outfile,
+				"Multitype ret_val;\n%s(%d, &ret_val",
+				base, k); /*)*/
+		else if (ISCOMPLEX(type))
+			nice_printf(outfile, "%s(%d,%s", base, k,
+				xretslot[type]->user.ident); /*)*/
+		else if (type == TYCHAR)
+			nice_printf(outfile,
+				"%s(%d, ret_val, ret_val_len", base, k); /*)*/
+		else
+			nice_printf(outfile, "return %s(%d", base, k); /*)*/
+		k++;
+		memset((char *)A, 0, nL);
+		for(args = e->arglist; args; args = args->nextp) {
+			np = (Namep)args->datap;
+			A[np->argno] = np;
+			if (np->vtype == TYCHAR && np->vclass != CLPROC)
+				*Alp[np->argno] = np;
+			}
+		args = allargs;
+		for(a = A; a < Ae; a++, args = args->nextp)
+			nice_printf(outfile, ", %s", (np = *a)
+				? np->cvarname
+				: ((Namep)args->datap)->vclass == CLPROC
+				? dfltproc[((Namep)args->datap)->vtype]
+				: dfltarg[((Namep)args->datap)->vtype]);
+		for(; a < Ae1; a++)
+			if (np = *a)
+				nice_printf(outfile, ", %s_len", np->fvarname);
+			else
+				nice_printf(outfile, ", (ftnint)0");
+		nice_printf(outfile, /*(*/ ");\n");
+		if (mt) {
+			if (type == TYCOMPLEX)
+				nice_printf(outfile,
+		    "r_v->r = ret_val.c.r; r_v->i = ret_val.c.i;\nreturn 0;\n");
+			else if (type == TYDCOMPLEX)
+				nice_printf(outfile,
+		    "r_v->r = ret_val.z.r; r_v->i = ret_val.z.i;\nreturn 0;\n");
+			else nice_printf(outfile, "return ret_val.%s;\n",
+				postfix[type-TYSHORT]);
+			}
+		else if (ONEOF(type, M(TYCHAR)|M(TYCOMPLEX)|M(TYDCOMPLEX)))
+			nice_printf(outfile, "return 0;\n");
+		nice_printf(outfile, "}\n");
+		prev_tab(outfile);
+		}
+		while(e = e->entnextp);
+	free((char *)A);
+	}
+
+ static void
+entry_goto(outfile)
+ FILEP outfile;
+{
+	struct Entrypoint *e = entries;
+	int k = 0;
+
+	nice_printf(outfile, "switch(n__) {\n");
+	next_tab(outfile);
+	while(e = e->entnextp)
+		nice_printf(outfile, "case %d: goto %s;\n", ++k,
+			user_label((long)(extsymtab - e->entryname - 1)));
+	nice_printf(outfile, "}\n\n");
+	prev_tab(outfile);
+	}
+
+/* start a new procedure */
+
+newproc()
+{
+	if(parstate != OUTSIDE)
+	{
+		execerr("missing end statement", CNULL);
+		endproc();
+	}
+
+	parstate = INSIDE;
+	procclass = CLMAIN;	/* default */
+}
+
+ static void
+zap_changes()
+{
+	register chainp cp;
+	register Argtypes *at;
+
+	/* arrange to get correct count of prototypes that would
+	   change by running f2c again */
+
+	if (prev_proc && proc_argchanges)
+		proc_protochanges++;
+	prev_proc = proc_argchanges = 0;
+	for(cp = new_procs; cp; cp = cp->nextp)
+		if (at = ((Namep)cp->datap)->arginfo)
+			at->changes &= ~1;
+	frchain(&new_procs);
+	}
+
+/* end of procedure. generate variables, epilogs, and prologs */
+
+endproc()
+{
+	struct Labelblock *lp;
+	Extsym *ext;
+
+	if(parstate < INDATA)
+		enddcl();
+	if(ctlstack >= ctls)
+		err("DO loop or BLOCK IF not closed");
+	for(lp = labeltab ; lp < labtabend ; ++lp)
+		if(lp->stateno!=0 && lp->labdefined==NO)
+			errstr("missing statement label %s",
+				convic(lp->stateno) );
+
+/* Save copies of the common variables in extptr -> allextp */
+
+	for (ext = extsymtab; ext < nextext; ext++)
+		if (ext -> extstg == STGCOMMON && ext -> extp) {
+			extern int usedefsforcommon;
+
+/* Write out the abbreviations for common block reference */
+
+			copy_data (ext -> extp);
+			if (usedefsforcommon) {
+				wr_abbrevs (c_file, 1, ext -> extp);
+				ext -> used_here = 1;
+				}
+			else
+				ext -> extp = CHNULL;
+
+			}
+
+	if (nentry > 1)
+		fix_entry_returns();
+	epicode();
+	donmlist();
+	dobss();
+	start_formatting ();
+	if (nentry > 1)
+		putentries(c_file);
+
+	zap_changes();
+	procinit();	/* clean up for next procedure */
+}
+
+
+
+/* End of declaration section of procedure.  Allocate storage. */
+
+enddcl()
+{
+	register struct Entrypoint *ep;
+	struct Entrypoint *ep0;
+	extern void freetemps();
+	chainp cp;
+	extern char *err_proc;
+	static char comblks[] = "common blocks";
+
+	err_proc = comblks;
+	docommon();
+
+/* Now the hash table entries for fields of common blocks have STGCOMMON,
+   vdcldone, voffset, and varno.  And the common blocks themselves have
+   their full sizes in extleng. */
+
+	err_proc = "equivalences";
+	doequiv();
+
+	err_proc = comblks;
+	docomleng();
+
+/* This implies that entry points in the declarations are buffered in
+   entries   but not written out */
+
+	err_proc = "entries";
+	if (ep = ep0 = (struct Entrypoint *)revchain((chainp)entries)) {
+		/* entries could be 0 in case of an error */
+		do doentry(ep);
+			while(ep = ep->entnextp);
+		entries = (struct Entrypoint *)revchain((chainp)ep0);
+		}
+
+	err_proc = 0;
+	parstate = INEXEC;
+	p1put(P1_PROCODE);
+	freetemps();
+	if (earlylabs) {
+		for(cp = earlylabs = revchain(earlylabs); cp; cp = cp->nextp)
+			p1_label((long)cp->datap);
+		frchain(&earlylabs);
+		}
+}
+
+/* ROUTINES CALLED WHEN ENCOUNTERING ENTRY POINTS */
+
+/* Main program or Block data */
+
+startproc(progname, class)
+Extsym * progname;
+int class;
+{
+	register struct Entrypoint *p;
+
+	p = ALLOC(Entrypoint);
+	if(class == CLMAIN) {
+		puthead(CNULL, CLMAIN);
+		if (progname)
+		    strcpy (main_alias, progname->cextname);
+	} else
+		puthead(CNULL, CLBLOCK);
+	if(class == CLMAIN)
+		newentry( mkname(" MAIN"), 0 )->extinit = 1;
+	p->entryname = progname;
+	entries = p;
+
+	procclass = class;
+	fprintf(diagfile, "   %s", (class==CLMAIN ? "MAIN" : "BLOCK DATA") );
+	if(progname) {
+		fprintf(diagfile, " %s", progname->fextname);
+		procname = progname->cextname;
+		}
+	fprintf(diagfile, ":\n");
+	fflush(diagfile);
+}
+
+/* subroutine or function statement */
+
+Extsym *newentry(v, substmsg)
+ register Namep v;
+ int substmsg;
+{
+	register Extsym *p;
+	char buf[128], badname[64];
+	static int nbad = 0;
+	static char already[] = "external name already used";
+
+	p = mkext(v->fvarname, addunder(v->cvarname));
+
+	if(p->extinit || ! ONEOF(p->extstg, M(STGUNKNOWN)|M(STGEXT)) )
+	{
+		sprintf(badname, "%s_bad%d", v->fvarname, ++nbad);
+		if (substmsg) {
+			sprintf(buf,"%s\n\tsubstituting \"%s\"",
+				already, badname);
+			dclerr(buf, v);
+			}
+		else
+			dclerr(already, v);
+		p = mkext(v->fvarname, badname);
+	}
+	v->vstg = STGAUTO;
+	v->vprocclass = PTHISPROC;
+	v->vclass = CLPROC;
+	if (p->extstg == STGEXT)
+		prev_proc = 1;
+	else
+		p->extstg = STGEXT;
+	p->extinit = YES;
+	v->vardesc.varno = p - extsymtab;
+	return(p);
+}
+
+
+entrypt(class, type, length, entry, args)
+int class, type;
+ftnint length;
+Extsym *entry;
+chainp args;
+{
+	register Namep q;
+	register struct Entrypoint *p;
+	extern int types3[];
+
+	if(class != CLENTRY)
+		puthead( procname = entry->cextname, class);
+	else
+		fprintf(diagfile, "       entry ");
+	fprintf(diagfile, "   %s:\n", entry->fextname);
+	fflush(diagfile);
+	q = mkname(entry->fextname);
+	if (type == TYSUBR)
+		q->vstg = STGEXT;
+
+	type = lengtype(type, length);
+	if(class == CLPROC)
+	{
+		procclass = CLPROC;
+		proctype = type;
+		procleng = type == TYCHAR ? length : 0;
+	}
+
+	p = ALLOC(Entrypoint);
+
+	p->entnextp = entries;
+	entries = p;
+
+	p->entryname = entry;
+	p->arglist = revchain(args);
+	p->enamep = q;
+
+	if(class == CLENTRY)
+	{
+		class = CLPROC;
+		if(proctype == TYSUBR)
+			type = TYSUBR;
+	}
+
+	q->vclass = class;
+	q->vprocclass = 0;
+	settype(q, type, length);
+	q->vprocclass = PTHISPROC;
+	/* hold all initial entry points till end of declarations */
+	if(parstate >= INDATA)
+		doentry(p);
+}
+
+/* generate epilogs */
+
+/* epicode -- write out the proper function return mechanism at the end of
+   the procedure declaration.  Handles multiple return value types, as
+   well as cooercion into the proper value */
+
+LOCAL epicode()
+{
+	extern int lastwasbranch;
+
+	if(procclass==CLPROC)
+	{
+		if(proctype==TYSUBR)
+		{
+
+/* Return a zero only when the alternate return mechanism has been
+   specified in the function header */
+
+			if (substars && lastwasbranch == NO)
+			    p1_subr_ret (ICON(0));
+		}
+		else if (!multitype && lastwasbranch == NO)
+			retval(proctype);
+	}
+	lastwasbranch = NO;
+}
+
+
+/* generate code to return value of type  t */
+
+LOCAL retval(t)
+register int t;
+{
+	register Addrp p;
+
+	switch(t)
+	{
+	case TYCHAR:
+	case TYCOMPLEX:
+	case TYDCOMPLEX:
+		break;
+
+	case TYLOGICAL:
+		t = tylogical;
+	case TYADDR:
+	case TYSHORT:
+	case TYLONG:
+	case TYREAL:
+	case TYDREAL:
+		p = (Addrp) cpexpr((expptr)retslot);
+		p->vtype = t;
+		p1_subr_ret (mkconv (t, fixtype((expptr)p)));
+		break;
+
+	default:
+		badtype("retval", t);
+	}
+}
+
+
+/* Do parameter adjustments */
+
+procode(outfile)
+FILE *outfile;
+{
+	prolog(outfile, allargs);
+
+	if (nentry > 1)
+		entry_goto(outfile);
+	}
+
+/* Finish bound computations now that all variables are declared.
+ * This used to be in setbound(), but under -u the following incurred
+ * an erroneous error message:
+ *	subroutine foo(x,n)
+ *	real x(n)
+ *	integer n
+ */
+
+ static void
+dim_finish(v)
+ Namep v;
+{
+	register struct Dimblock *p;
+	register expptr q;
+	register int i, nd;
+	extern expptr make_int_expr();
+
+	p = v->vdim;
+	v->vdimfinish = 0;
+	nd = p->ndim;
+	doin_setbound = 1;
+	for(i = 0; i < nd; i++)
+		if (q = p->dims[i].dimexpr)
+			p->dims[i].dimexpr = make_int_expr(putx(fixtype(q)));
+	if (q = p->basexpr)
+		p->basexpr = make_int_expr(putx(fixtype(q)));
+	doin_setbound = 0;
+	}
+
+ static void
+duparg(q)
+ Namep q;
+{ errstr("duplicate argument %.80s", q->fvarname); }
+
+/*
+   manipulate argument lists (allocate argument slot positions)
+ * keep track of return types and labels
+ */
+
+LOCAL doentry(ep)
+struct Entrypoint *ep;
+{
+	register int type;
+	register Namep np;
+	chainp p, p1;
+	register Namep q;
+	Addrp mkarg(), rs;
+	int it, k;
+	extern char dflttype[26];
+	Extsym *entryname = ep->entryname;
+
+	if (++nentry > 1)
+		p1_label((long)(extsymtab - entryname - 1));
+
+/* The main program isn't allowed to have parameters, so any given
+   parameters are ignored */
+
+	if(procclass == CLMAIN || procclass == CLBLOCK)
+		return;
+
+/* So now we're working with something other than CLMAIN or CLBLOCK.
+   Determine the type of its return value. */
+
+	impldcl( np = mkname(entryname->fextname) );
+	type = np->vtype;
+	proc_argchanges = prev_proc && type != entryname->extype;
+	entryname->extseen = 1;
+	if(proctype == TYUNKNOWN)
+		if( (proctype = type) == TYCHAR)
+			procleng = np->vleng ? np->vleng->constblock.Const.ci
+					     : (ftnint) (-1);
+
+	if(proctype == TYCHAR)
+	{
+		if(type != TYCHAR)
+			err("noncharacter entry of character function");
+
+/* Functions returning type   char   can only have multiple entries if all
+   entries return the same length */
+
+		else if( (np->vleng ? np->vleng->constblock.Const.ci :
+		    (ftnint) (-1)) != procleng)
+			err("mismatched character entry lengths");
+	}
+	else if(type == TYCHAR)
+		err("character entry of noncharacter function");
+	else if(type != proctype)
+		multitype = YES;
+	if(rtvlabel[type] == 0)
+		rtvlabel[type] = newlabel();
+	ep->typelabel = rtvlabel[type];
+
+	if(type == TYCHAR)
+	{
+		if(chslot < 0)
+		{
+			chslot = nextarg(TYADDR);
+			chlgslot = nextarg(TYLENG);
+		}
+		np->vstg = STGARG;
+
+/* Put a new argument in the function, one which will hold the result of
+   a character function.  This will have to be named sometime, probably in
+   mkarg(). */
+
+		if(procleng < 0) {
+			np->vleng = (expptr) mkarg(TYLENG, chlgslot);
+			np->vleng->addrblock.uname_tag = UNAM_IDENT;
+			strcpy (np -> vleng -> addrblock.user.ident,
+				new_func_length());
+			}
+		if (!xretslot[TYCHAR]) {
+			xretslot[TYCHAR] = rs =
+				autovar(0, type, ISCONST(np->vleng)
+					? np->vleng : ICON(0), "");
+			strcpy(rs->user.ident, "ret_val");
+			}
+	}
+
+/* Handle a   complex   return type -- declare a new parameter (pointer to
+   a complex value) */
+
+	else if( ISCOMPLEX(type) ) {
+		if (!xretslot[type])
+			xretslot[type] =
+				autovar(0, type, EXNULL, " ret_val");
+				/* the blank is for use in out_addr */
+		np->vstg = STGARG;
+		if(cxslot < 0)
+			cxslot = nextarg(TYADDR);
+		}
+	else if (type != TYSUBR) {
+		if (type == TYUNKNOWN) {
+			dclerr("untyped function", np);
+			proctype = type = np->vtype =
+				dflttype[letter(np->fvarname[0])];
+			}
+		if (!xretslot[type])
+			xretslot[type] = retslot =
+				autovar(1, type, EXNULL, " ret_val");
+				/* the blank is for use in out_addr */
+		np->vstg = STGAUTO;
+		}
+
+	for(p = ep->arglist ; p ; p = p->nextp)
+		if(! (( q = (Namep) (p->datap) )->vknownarg) ) {
+			q->vknownarg = 1;
+			q->vardesc.varno = nextarg(TYADDR);
+			allargs = mkchain((char *)q, allargs);
+			q->argno = nallargs++;
+			}
+		else if (nentry == 1)
+			duparg(q);
+		else for(p1 = ep->arglist ; p1 != p; p1 = p1->nextp)
+			if ((Namep)p1->datap == q)
+				duparg(q);
+
+	k = 0;
+	for(p = ep->arglist ; p ; p = p->nextp) {
+		if(! (( q = (Namep) (p->datap) )->vdcldone) )
+			{
+			impldcl(q);
+			q->vdcldone = YES;
+			if(q->vtype == TYCHAR)
+				{
+
+/* If we don't know the length of a char*(*) (i.e. a string), we must add
+   in this additional length argument. */
+
+				++nallchargs;
+				if (q->vclass == CLPROC)
+					nallchargs--;
+				else if (q->vleng == NULL) {
+					/* character*(*) */
+					q->vleng = (expptr)
+					    mkarg(TYLENG, nextarg(TYLENG) );
+					unamstring((Addrp)q->vleng,
+						new_arg_length(q));
+					}
+				}
+			}
+		if (q->vdimfinish)
+			dim_finish(q);
+		if (q->vtype == TYCHAR && q->vclass != CLPROC)
+			k++;
+		}
+
+	if (entryname->extype != type)
+		changedtype(np);
+
+	/* save information for checking consistency of arg lists */
+
+	it = infertypes;
+	if (entryname->exproto)
+		infertypes = 1;
+	save_argtypes(ep->arglist, &entryname->arginfo, &np->arginfo,
+			0, np->fvarname, STGEXT, k, np->vtype, 0);
+	infertypes = it;
+}
+
+
+
+LOCAL nextarg(type)
+int type;
+{
+	int k;
+	k = lastargslot;
+	lastargslot += typesize[type];
+	return(k);
+}
+
+ LOCAL
+dim_check(q)
+ Namep q;
+{
+	register struct Dimblock *vdim = q->vdim;
+
+	if(!vdim->nelt || !ISICON(vdim->nelt))
+		dclerr("adjustable dimension on non-argument", q);
+	else if (vdim->nelt->constblock.Const.ci <= 0)
+		dclerr("nonpositive dimension", q);
+	}
+
+LOCAL dobss()
+{
+	register struct Hashentry *p;
+	register Namep q;
+	int qstg, qclass, qtype;
+	Extsym *e;
+
+	for(p = hashtab ; 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 */

+ 373 - 0
lang/fortran/comp/proto.make

@@ -0,0 +1,373 @@
+# $Header$
+
+# Makefile for f2c, a Fortran 77 to C converter
+
+#PARAMS		do not remove this line!
+
+UTIL_BIN = \
+	$(UTIL_HOME)/bin
+SRC_DIR = \
+	$(SRC_HOME)/lang/fortran/comp
+INCLUDES = -I$(SRC_DIR) -I.
+CFLAGS = $(COPTIONS) $(INCLUDES)
+LINTFLAGS = $(LINTOPTIONS) $(INCLUDES)
+LDFLAGS = $(LDOPTIONS)
+
+OBJECTS = main.$(SUF) init.$(SUF) gram.$(SUF) lex.$(SUF) proc.$(SUF) \
+	  equiv.$(SUF) data.$(SUF) format.$(SUF) expr.$(SUF) exec.$(SUF) \
+	  intr.$(SUF) io.$(SUF) misc.$(SUF) error.$(SUF) mem.$(SUF) \
+	  names.$(SUF) output.$(SUF) p1output.$(SUF) pread.$(SUF) put.$(SUF) \
+	  putpcc.$(SUF) vax.$(SUF) formatdata.$(SUF) parse_args.$(SUF) \
+	  niceprintf.$(SUF) cds.$(SUF) sysdep.$(SUF) version.$(SUF)
+
+
+GSRC = \
+	$(SRC_DIR)/gram.head \
+	$(SRC_DIR)/gram.dcl \
+	$(SRC_DIR)/gram.expr \
+	$(SRC_DIR)/gram.exec \
+	$(SRC_DIR)/gram.io
+CSRC = \
+	$(SRC_DIR)/main.c \
+	$(SRC_DIR)/init.c \
+	$(SRC_DIR)/lex.c \
+	$(SRC_DIR)/proc.c \
+	$(SRC_DIR)/equiv.c \
+	$(SRC_DIR)/data.c \
+	$(SRC_DIR)/format.c \
+	$(SRC_DIR)/expr.c \
+	$(SRC_DIR)/exec.c \
+	$(SRC_DIR)/intr.c \
+	$(SRC_DIR)/io.c \
+	$(SRC_DIR)/misc.c \
+	$(SRC_DIR)/error.c \
+	$(SRC_DIR)/mem.c \
+	$(SRC_DIR)/names.c \
+	$(SRC_DIR)/output.c \
+	$(SRC_DIR)/p1output.c \
+	$(SRC_DIR)/pread.c \
+	$(SRC_DIR)/put.c \
+	$(SRC_DIR)/putpcc.c \
+	$(SRC_DIR)/vax.c \
+	$(SRC_DIR)/formatdata.c \
+	$(SRC_DIR)/parse_args.c \
+	$(SRC_DIR)/niceprintf.c \
+	$(SRC_DIR)/cds.c \
+	$(SRC_DIR)/sysdep.c \
+	$(SRC_DIR)/version.c
+HSRC = \
+	$(SRC_DIR)/defines.h \
+	$(SRC_DIR)/defs.h \
+	$(SRC_DIR)/f2c.h \
+	$(SRC_DIR)/format.h \
+	$(SRC_DIR)/ftypes.h \
+	$(SRC_DIR)/iob.h \
+	$(SRC_DIR)/machdefs.h \
+	$(SRC_DIR)/names.h \
+	$(SRC_DIR)/niceprintf.h \
+	$(SRC_DIR)/output.h \
+	$(SRC_DIR)/p1defs.h \
+	$(SRC_DIR)/parse.h \
+	$(SRC_DIR)/pccdefs.h \
+	$(SRC_DIR)/sysdep.h \
+	$(SRC_DIR)/usignal.h
+
+SRC = 	$(SRC_DIR)/tokens $(GSRC) $(HSRC) $(CSRC)
+
+CFILES = gram.c $(CSRC)
+
+all:	f2c
+
+install:	all
+	rm -f $(TARGET_HOME)/lib.bin/f2c
+	cp f2c $(TARGET_HOME)/lib.bin/f2c
+	rm -f $(TARGET_HOME)/man/f2c.6
+	cp $(SRC_DIR)/f2c.6 $(TARGET_HOME)/man/f2c.6
+	rm -f $(TARGET_HOME)/include/_tail_cc/f2c.h
+	cp $(SRC_DIR)/f2c.h $(TARGET_HOME)/include/_tail_cc/f2c.h
+
+cmp:	all
+	-cmp f2c $(TARGET_HOME)/lib.bin/f2c
+	-cmp $(SRC_DIR)/f2c.6 $(TARGET_HOME)/man/f2c.6
+	-cmp $(SRC_DIR)/f2c.h $(TARGET_HOME)/include/_tail_cc/f2c.h
+
+lint:	$(CFILES) tokdefs.h
+	$(LINT) $(LINTFLAGS) $(CFILES)
+
+pr:
+	@pr $(SRC_DIR)/proto.make $(SRC)
+
+pr:
+	make pr | opr
+
+depend:	$(CFILES) tokdefs.h
+	sed '/^#DEPENDENCIES/,$$d' Makefile >Makefile.new
+	echo '#DEPENDENCIES' >>Makefile.new
+	for i in $(CFILES) ; do \
+		echo "`basename $$i .c`.$$(SUF):	$$i" >> Makefile.new ; \
+		echo '	$$(CC) -c $$(CFLAGS)' $$i >> Makefile.new ; \
+		$(UTIL_HOME)/lib.bin/cpp -d $(INCLUDES) $$i | sed "s/^/`basename $$i .c`.$$(SUF):	/" >> Makefile.new ; \
+	done
+	mv Makefile Makefile.old
+	mv Makefile.new Makefile
+
+f2c:	$(OBJECTS)
+	$(CC) $(LDFLAGS) $(OBJECTS) $(TARGET_HOME)/modules/lib/libstring.$(LIBSUF) -o f2c
+
+gram.c:	$(GSRC) $(SRC_DIR)/defs.h tokdefs.h
+	( sed <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

+ 399 - 0
lang/fortran/comp/put.c

@@ -0,0 +1,399 @@
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+/*
+ * INTERMEDIATE CODE GENERATION PROCEDURES COMMON TO BOTH
+ * JOHNSON (PORTABLE) AND RITCHIE FAMILIES OF SECOND PASSES
+*/
+
+#include "defs.h"
+#include "names.h"		/* For LOCAL_CONST_NAME */
+#include "pccdefs.h"
+#include "p1defs.h"
+
+/* Definitions for   putconst()   */
+
+#define LIT_CHAR 1
+#define LIT_FLOAT 2
+#define LIT_INT 3
+
+
+/*
+char *ops [ ] =
+	{
+	"??", "+", "-", "*", "/", "**", "-",
+	"OR", "AND", "EQV", "NEQV", "NOT",
+	"CONCAT",
+	"<", "==", ">", "<=", "!=", ">=",
+	" of ", " ofC ", " = ", " += ", " *= ", " CONV ", " << ", " % ",
+	" , ", " ? ", " : "
+	" abs ", " min ", " max ", " addr ", " indirect ",
+	" bitor ", " bitand ", " bitxor ", " bitnot ", " >> ",
+	};
+*/
+
+/* Each of these values is defined in   pccdefs   */
+
+int ops2 [ ] =
+{
+	P2BAD, P2PLUS, P2MINUS, P2STAR, P2SLASH, P2BAD, P2NEG,
+	P2OROR, P2ANDAND, P2EQ, P2NE, P2NOT,
+	P2BAD,
+	P2LT, P2EQ, P2GT, P2LE, P2NE, P2GE,
+	P2CALL, P2CALL, P2ASSIGN, P2PLUSEQ, P2STAREQ, P2CONV, P2LSHIFT, P2MOD,
+	P2COMOP, P2QUEST, P2COLON,
+	1, P2BAD, P2BAD, P2BAD, P2BAD,
+	P2BITOR, P2BITAND, P2BITXOR, P2BITNOT, P2RSHIFT,
+	P2BAD, P2BAD, P2BAD, P2BAD, P2BAD, P2BAD, P2BAD, P2BAD, P2BAD,
+	P2BAD, P2BAD, P2BAD, P2BAD,
+	1,1,1,1,1, /* OPNEG1, OPDMIN, OPDMAX, OPASSIGNI, OPIDENTITY */
+	1,1,1,1	/* OPCHARCAST, OPDABS, OPMIN2, OPMAX2 */
+};
+
+
+int types2 [ ] =
+{
+	P2BAD, P2INT|P2PTR, P2SHORT, P2LONG, P2REAL, P2DREAL,
+	P2REAL, P2DREAL, P2LONG, P2CHAR, P2INT, P2BAD
+};
+
+
+setlog()
+{
+	types2[TYLOGICAL] = types2[tylogical];
+	typesize[TYLOGICAL] = typesize[tylogical];
+	typealign[TYLOGICAL] = typealign[tylogical];
+}
+
+
+void putex1(p)
+expptr p;
+{
+/* Write the expression to the p1 file */
+
+	p = (expptr) putx (fixtype (p));
+	p1_expr (p);
+}
+
+
+
+
+
+expptr putassign(lp, rp)
+expptr lp, rp;
+{
+	return putx(fixexpr((Exprp)mkexpr(OPASSIGN, lp, rp)));
+}
+
+
+
+
+void puteq(lp, rp)
+expptr lp, rp;
+{
+	putexpr(mkexpr(OPASSIGN, lp, rp) );
+}
+
+
+
+
+/* put code for  a *= b */
+
+expptr putsteq(a, b)
+Addrp a, b;
+{
+	return putx( fixexpr((Exprp)
+		mkexpr(OPSTAREQ, cpexpr((expptr)a), cpexpr((expptr)b))));
+}
+
+
+
+
+Addrp mkfield(res, f, ty)
+register Addrp res;
+char *f;
+int ty;
+{
+    res -> vtype = ty;
+    res -> Field = f;
+    return res;
+} /* mkfield */
+
+
+Addrp realpart(p)
+register Addrp p;
+{
+	register Addrp q;
+	expptr mkrealcon();
+
+	if (p -> uname_tag == UNAM_CONST && ISCOMPLEX (p->vtype)) {
+		return (Addrp)mkrealcon (p -> vtype + TYREAL - TYCOMPLEX,
+			p->user.kludge.vstg1 ? p->user.Const.cds[0]
+				: cds(dtos(p->user.Const.cd[0]),CNULL));
+	} /* if p -> uname_tag */
+
+	q = (Addrp) cpexpr((expptr) p);
+	if( ISCOMPLEX(p->vtype) )
+		q = mkfield (q, "r", p -> vtype + TYREAL - TYCOMPLEX);
+
+	return(q);
+}
+
+
+
+
+expptr imagpart(p)
+register Addrp p;
+{
+	register Addrp q;
+	expptr mkrealcon();
+
+	if( ISCOMPLEX(p->vtype) )
+	{
+		if (p -> uname_tag == UNAM_CONST)
+			return mkrealcon (p -> vtype + TYREAL - TYCOMPLEX,
+				p->user.kludge.vstg1 ? p->user.Const.cds[1]
+				: cds(dtos(p->user.Const.cd[1]),CNULL));
+		q = (Addrp) cpexpr((expptr) p);
+		q = mkfield (q, "i", p -> vtype + TYREAL - TYCOMPLEX);
+		return( (expptr) q );
+	}
+	else
+
+/* Cast an integer type onto a Double Real type */
+
+		return( mkrealcon( ISINT(p->vtype) ? TYDREAL : p->vtype , "0"));
+}
+
+
+
+
+
+/* ncat -- computes the number of adjacent concatenation operations */
+
+ncat(p)
+register expptr p;
+{
+	if(p->tag==TEXPR && p->exprblock.opcode==OPCONCAT)
+		return( ncat(p->exprblock.leftp) + ncat(p->exprblock.rightp) );
+	else	return(1);
+}
+
+
+
+
+/* lencat -- returns the length of the concatenated string.  Each
+   substring must have a static (i.e. compile-time) fixed length */
+
+ftnint lencat(p)
+register expptr p;
+{
+	if(p->tag==TEXPR && p->exprblock.opcode==OPCONCAT)
+		return( lencat(p->exprblock.leftp) + lencat(p->exprblock.rightp) );
+	else if( p->headblock.vleng!=NULL && ISICON(p->headblock.vleng) )
+		return(p->headblock.vleng->constblock.Const.ci);
+	else if(p->tag==TADDR && p->addrblock.varleng!=0)
+		return(p->addrblock.varleng);
+	else
+	{
+		err("impossible element in concatenation");
+		return(0);
+	}
+}
+
+/* putconst -- Creates a new Addrp value which maps onto the input
+   constant value.  The Addrp doesn't retain the value of the constant,
+   instead that value is copied into a table of constants (called
+   litpool,   for pool of literal values).  The only way to retrieve the
+   actual value of the constant is to look at the   memno   field of the
+   Addrp result.  You know that the associated literal is the one referred
+   to by   q   when   (q -> memno == litp -> litnum).
+*/
+
+Addrp putconst(p)
+register Constp p;
+{
+	register Addrp q;
+	struct Literal *litp, *lastlit;
+	int k, len, type;
+	int litflavor;
+	double cd[2];
+	ftnint nblanks;
+	char *strp;
+	char cdsbuf0[64], cdsbuf1[64], *ds[2];
+
+	if (p->tag != TCONST)
+		badtag("putconst", p->tag);
+
+	q = ALLOC(Addrblock);
+	q->tag = TADDR;
+	type = p->vtype;
+	q->vtype = ( type==TYADDR ? tyint : type );
+	q->vleng = (expptr) cpexpr(p->vleng);
+	q->vstg = STGCONST;
+
+/* Create the new label for the constant.  This is wasteful of labels
+   because when the constant value already exists in the literal pool,
+   this label gets thrown away and is never reclaimed.  It might be
+   cleaner to move this down past the first   switch()   statement below */
+
+	q->memno = newlabel();
+	q->memoffset = ICON(0);
+	q -> uname_tag = UNAM_CONST;
+
+/* Copy the constant info into the Addrblock; do this by copying the
+   largest storage elts */
+
+	q -> user.Const = p -> Const;
+	q->user.kludge.vstg1 = p->vstg;	/* distinguish string from binary fp */
+
+	/* check for value in literal pool, and update pool if necessary */
+
+	k = 1;
+	switch(type)
+	{
+	case TYCHAR:
+		if (halign) {
+			strp = p->Const.ccp;
+			nblanks = p->Const.ccp1.blanks;
+			len = p->vleng->constblock.Const.ci;
+			litflavor = LIT_CHAR;
+			goto loop;
+			}
+		else
+			q->memno = BAD_MEMNO;
+		break;
+	case TYCOMPLEX:
+	case TYDCOMPLEX:
+		k = 2;
+		if (p->vstg)
+			cd[1] = atof(ds[1] = p->Const.cds[1]);
+		else
+			ds[1] = cds(dtos(cd[1] = p->Const.cd[1]), cdsbuf1);
+	case TYREAL:
+	case TYDREAL:
+		litflavor = LIT_FLOAT;
+		if (p->vstg)
+			cd[0] = atof(ds[0] = p->Const.cds[0]);
+		else
+			ds[0] = cds(dtos(cd[0] = p->Const.cd[0]), cdsbuf0);
+		goto loop;
+
+	case TYLOGICAL:
+		type = tylogical;
+		goto lit_int_flavor;
+	case TYLONG:
+		type = tyint;
+	case TYSHORT:
+ lit_int_flavor:
+		litflavor = LIT_INT;
+
+/* Scan the literal pool for this constant value.  If this same constant
+   has been assigned before, use the same label.  Note that this routine
+   does NOT consider two differently-typed constants with the same bit
+   pattern to be the same constant */
+
+ loop:
+		lastlit = litpool + nliterals;
+		for(litp = litpool ; 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 );
+}

+ 1781 - 0
lang/fortran/comp/putpcc.c

@@ -0,0 +1,1781 @@
+/****************************************************************
+Copyright 1990, 1991 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+/* INTERMEDIATE CODE GENERATION FOR S. C. JOHNSON C COMPILERS */
+/* NEW VERSION USING BINARY POLISH POSTFIX INTERMEDIATE */
+
+#include "defs.h"
+#include "pccdefs.h"
+#include "output.h"		/* for nice_printf */
+#include "names.h"
+#include "p1defs.h"
+
+Addrp realpart();
+LOCAL Addrp intdouble(), putcx1(), putcxeq (), putch1 ();
+LOCAL putct1 ();
+
+expptr putcxop();
+LOCAL expptr putcall (), putmnmx (), putcheq(), putcat ();
+LOCAL expptr putaddr(), putchcmp (), putpower(), putop();
+LOCAL expptr putcxcmp ();
+expptr imagpart();
+ftnint lencat();
+
+#define FOUR 4
+extern int ops2[];
+extern int types2[];
+extern int proc_argchanges, proc_protochanges;
+extern int krparens;
+
+#define P2BUFFMAX 128
+
+/* Puthead -- output the header information about subroutines, functions
+   and entry points */
+
+puthead(s, class)
+char *s;
+int class;
+{
+	if (headerdone == NO) {
+		if (class == CLMAIN)
+			s = "MAIN__";
+		p1_head (class, s);
+		headerdone = YES;
+		}
+}
+
+putif(p, else_if_p)
+ register expptr p;
+ int else_if_p;
+{
+	register int k;
+	int n;
+	long where;
+
+	if (else_if_p) {
+		p1put(P1_ELSEIFSTART);
+		where = ftell(pass1_file);
+		}
+	if( ( k = (p = fixtype(p))->headblock.vtype) != TYLOGICAL)
+	{
+		if(k != TYERROR)
+			err("non-logical expression in IF statement");
+		}
+	else {
+		if (else_if_p) {
+			if (ei_next >= ei_last)
+				{
+				k = ei_last - ei_first;
+				n = k + 100;
+				ei_next = mem(n,0);
+				ei_last = ei_first + n;
+				if (k)
+					memcpy(ei_next, ei_first, k);
+				ei_first =  ei_next;
+				ei_next += k;
+				ei_last = ei_first + n;
+				}
+			p = putx(p);
+			if (*ei_next++ = ftell(pass1_file) > where) {
+				p1_if(p);
+				new_endif();
+				}
+			else
+				p1_elif(p);
+			}
+		else {
+			p = putx(p);
+			p1_if(p);
+			}
+		}
+	}
+
+
+putexpr(p)
+expptr p;
+{
+	putex1(p);
+}
+
+
+putout(p)
+expptr p;
+{
+	p1_expr (p);
+
+/* Used to make temporaries in holdtemps available here, but they */
+/* may be reused too soon (e.g. when multiple **'s are involved). */
+}
+
+
+
+putcmgo(index, nlab, labs)
+expptr index;
+int nlab;
+struct Labelblock *labs[];
+{
+	if(! ISINT(index->headblock.vtype) )
+	{
+		execerr("computed goto index must be integer", CNULL);
+		return;
+	}
+
+	p1comp_goto (index, nlab, labs);
+}
+
+ static expptr
+krput(p)
+ register expptr p;
+{
+	register expptr e, e1;
+	register unsigned op;
+	int t = krparens == 2 ? TYDREAL : p->exprblock.vtype;
+
+	op = p->exprblock.opcode;
+	e = p->exprblock.leftp;
+	if (e->tag == TEXPR && e->exprblock.opcode == op) {
+		e1 = (expptr)mktmp(t, ENULL);
+		putout(putassign(cpexpr(e1), e));
+		p->exprblock.leftp = e1;
+		}
+	else
+		p->exprblock.leftp = putx(e);
+
+	e = p->exprblock.rightp;
+	if (e->tag == TEXPR && e->exprblock.opcode == op) {
+		e1 = (expptr)mktmp(t, ENULL);
+		putout(putassign(cpexpr(e1), e));
+		p->exprblock.rightp = e1;
+		}
+	else
+		p->exprblock.rightp = putx(e);
+	return p;
+	}
+
+expptr putx(p)
+ register expptr p;
+{
+	int opc;
+	int k;
+
+	if (p)
+	  switch(p->tag)
+	{
+	case TERROR:
+		break;
+
+	case TCONST:
+		switch(p->constblock.vtype)
+		{
+		case TYLOGICAL:
+		case TYLONG:
+		case TYSHORT:
+			break;
+
+		case TYADDR:
+			break;
+		case TYREAL:
+		case TYDREAL:
+
+/* Don't write it out to the p2 file, since you'd need to call putconst,
+   which is just what we need to avoid in the translator */
+
+			break;
+		default:
+			p = putx( (expptr)putconst((Constp)p) );
+			break;
+		}
+		break;
+
+	case TEXPR:
+		switch(opc = p->exprblock.opcode)
+		{
+		case OPCALL:
+		case OPCCALL:
+			if( ISCOMPLEX(p->exprblock.vtype) )
+				p = putcxop(p);
+			else	p = putcall(p, (Addrp *)NULL);
+			break;
+
+		case OPMIN:
+		case OPMAX:
+			p = putmnmx(p);
+			break;
+
+
+		case OPASSIGN:
+			if(ISCOMPLEX(p->exprblock.leftp->headblock.vtype)
+			    || ISCOMPLEX(p->exprblock.rightp->headblock.vtype)) {
+				(void) putcxeq(p);
+				p = ENULL;
+			} else if( ISCHAR(p) )
+				p = putcheq(p);
+			else
+				goto putopp;
+			break;
+
+		case OPEQ:
+		case OPNE:
+			if( ISCOMPLEX(p->exprblock.leftp->headblock.vtype) ||
+			    ISCOMPLEX(p->exprblock.rightp->headblock.vtype) )
+			{
+				p = putcxcmp(p);
+				break;
+			}
+		case OPLT:
+		case OPLE:
+		case OPGT:
+		case OPGE:
+			if(ISCHAR(p->exprblock.leftp))
+			{
+				p = putchcmp(p);
+				break;
+			}
+			goto putopp;
+
+		case OPPOWER:
+			p = putpower(p);
+			break;
+
+		case OPSTAR:
+			/*   m * (2**k) -> m<<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);
+		}
+	}

+ 16 - 0
lang/fortran/comp/string.h

@@ -0,0 +1,16 @@
+#ifndef NULL
+#define	NULL		0
+#endif
+
+#define strchr	strindex
+#define strrchr strrindex
+
+extern char *	strcat();
+extern char *	strchr();
+extern int	strcmp();
+extern char *	strcpy();
+extern int	strlen();
+extern char *	strncat();
+extern int	strncmp();
+extern char *	strncpy();
+extern char *	strrchr();

+ 441 - 0
lang/fortran/comp/sysdep.c

@@ -0,0 +1,441 @@
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+#include "defs.h"
+#include "usignal.h"
+
+char binread[] = "rb", textread[] = "r";
+char binwrite[] = "wb", textwrite[] = "w";
+char *c_functions	= "c_functions";
+char *coutput		= "c_output";
+char *initfname		= "raw_data";
+char *initbname		= "raw_data.b";
+char *blkdfname		= "block_data";
+char *p1_file		= "p1_file";
+char *p1_bakfile	= "p1_file.BAK";
+char *sortfname		= "init_file";
+
+char link_msg[]		= "-lF77 -lI77 -lm -lc";
+
+#ifndef TMPDIR
+#ifdef MSDOS
+#define TMPDIR ""
+#else
+#define TMPDIR "/tmp"
+#endif
+#endif
+
+char *tmpdir = TMPDIR;
+
+ void
+Un_link_all(cdelete)
+{
+	if (!debugflag) {
+		unlink(c_functions);
+		unlink(initfname);
+		unlink(p1_file);
+		unlink(sortfname);
+		unlink(blkdfname);
+		if (cdelete && coutput)
+			unlink(coutput);
+		}
+	}
+
+ void
+set_tmp_names()
+{
+	int k;
+	if (debugflag == 1)
+		return;
+	k = strlen(tmpdir) + 16;
+	c_functions = (char *)ckalloc(7*k);
+	initfname = c_functions + k;
+	initbname = initfname + k;
+	blkdfname = initbname + k;
+	p1_file = blkdfname + k;
+	p1_bakfile = p1_file + k;
+	sortfname = p1_bakfile + k;
+	{
+#ifdef MSDOS
+	char buf[64], *s, *t;
+	if (!*tmpdir || *tmpdir == '.' && !tmpdir[1])
+		t = "";
+	else {
+		/* substitute \ for / to avoid confusion with a
+		 * switch indicator in the system("sort ...")
+		 * call in formatdata.c
+		 */
+		for(s = tmpdir, t = buf; *s; s++, t++)
+			if ((*t = *s) == '/')
+				*t = '\\';
+		if (t[-1] != '\\')
+			*t++ = '\\';
+		*t = 0;
+		t = buf;
+		}
+	sprintf(c_functions, "%sf2c_func", t);
+	sprintf(initfname, "%sf2c_rd", t);
+	sprintf(blkdfname, "%sf2c_blkd", t);
+	sprintf(p1_file, "%sf2c_p1f", t);
+	sprintf(p1_bakfile, "%sf2c_p1fb", t);
+	sprintf(sortfname, "%sf2c_sort", t);
+#else
+	int pid = getpid();
+	sprintf(c_functions, "%s/f2c%d_func", tmpdir, pid);
+	sprintf(initfname, "%s/f2c%d_rd", tmpdir, pid);
+	sprintf(blkdfname, "%s/f2c%d_blkd", tmpdir, pid);
+	sprintf(p1_file, "%s/f2c%d_p1f", tmpdir, pid);
+	sprintf(p1_bakfile, "%s/f2c%d_p1fb", tmpdir, pid);
+	sprintf(sortfname, "%s/f2c%d_sort", tmpdir, pid);
+#endif
+	sprintf(initbname, "%s.b", initfname);
+	}
+	if (debugflag)
+		fprintf(diagfile, "%s %s %s %s %s %s\n", c_functions,
+			initfname, blkdfname, p1_file, p1_bakfile, sortfname);
+	}
+
+ char *
+c_name(s,ft)char *s;
+{
+	char *b, *s0;
+	int c;
+
+	b = s0 = s;
+	while(c = *s++)
+		if (c == '/')
+			b = s;
+	if (--s < s0 + 3 || s[-2] != '.'
+			 || ((c = *--s) != 'f' && c != 'F')) {
+		infname = s0;
+		Fatal("file name must end in .f or .F");
+		}
+	*s = ft;
+	b = copys(b);
+	*s = c;
+	return b;
+	}
+
+ static void
+killed()
+{
+	signal(SIGINT, SIG_IGN);
+#ifdef SIGQUIT
+	signal(SIGQUIT, SIG_IGN);
+#endif
+#ifdef SIGHUP
+	signal(SIGHUP, SIG_IGN);
+#endif
+	signal(SIGTERM, SIG_IGN);
+	Un_link_all(1);
+	exit(126);
+	}
+
+ static void
+sig1catch(sig) int sig;
+{
+	if (signal(sig, SIG_IGN) != SIG_IGN)
+		signal(sig, killed);
+	}
+
+ static void
+flovflo()
+{
+	Fatal("floating exception during constant evaluation; cannot recover");
+	/* vax returns a reserved operand that generates
+	   an illegal operand fault on next instruction,
+	   which if ignored causes an infinite loop.
+	*/
+	signal(SIGFPE, flovflo);
+}
+
+ void
+sigcatch()
+{
+	sig1catch(SIGINT);
+#ifdef SIGQUIT
+	sig1catch(SIGQUIT);
+#endif
+#ifdef SIGHUP
+	sig1catch(SIGHUP);
+#endif
+	sig1catch(SIGTERM);
+	signal(SIGFPE, flovflo);  /* catch overflows */
+	}
+
+
+dofork()
+{
+#ifdef MSDOS
+	Fatal("Only one Fortran input file allowed under MS-DOS");
+#else
+	int pid, status, w;
+	extern int retcode;
+
+	if (!(pid = fork()))
+		return 1;
+	if (pid == -1)
+		Fatal("bad fork");
+	while((w = wait(&status)) != pid)
+		if (w == -1)
+			Fatal("bad wait code");
+	retcode |= status >> 8;
+#endif
+	return 0;
+	}
+
+/* Initialization of tables that change with the character set... */
+
+char escapes[Table_size];
+
+#ifdef non_ASCII
+char *str_fmt[Table_size];
+static char *str0fmt[127] = { /*}*/
+#else
+char *str_fmt[Table_size] = {
+#endif
+ "\\000", "\\001", "\\002", "\\003", "\\004", "\\005", "\\006", "\\007",
+   "\\b",   "\\t",   "\\n", "\\013",   "\\f",   "\\r", "\\016", "\\017",
+ "\\020", "\\021", "\\022", "\\023", "\\024", "\\025", "\\026", "\\027",
+ "\\030", "\\031", "\\032", "\\033", "\\034", "\\035", "\\036", "\\037",
+     " ",     "!",  "\\\"",     "#",     "$",     "%%",    "&",     "'",
+     "(",     ")",     "*",     "+",     ",",     "-",     ".",     "/",
+     "0",     "1",     "2",     "3",     "4",     "5",     "6",     "7",
+     "8",     "9",     ":",     ";",     "<",     "=",     ">",     "?",
+     "@",     "A",     "B",     "C",     "D",     "E",     "F",     "G",
+     "H",     "I",     "J",     "K",     "L",     "M",     "N",     "O",
+     "P",     "Q",     "R",     "S",     "T",     "U",     "V",     "W",
+     "X",     "Y",     "Z",     "[",  "\\\\",     "]",     "^",     "_",
+     "`",     "a",     "b",     "c",     "d",     "e",     "f",     "g",
+     "h",     "i",     "j",     "k",     "l",     "m",     "n",     "o",
+     "p",     "q",     "r",     "s",     "t",     "u",     "v",     "w",
+     "x",     "y",     "z",     "{",     "|",     "}",     "~"
+     };
+
+#ifdef non_ASCII
+char *chr_fmt[Table_size];
+static char *chr0fmt[127] = {	/*}*/
+#else
+char *chr_fmt[Table_size] = {
+#endif
+   "\\0",   "\\1",   "\\2",   "\\3",   "\\4",   "\\5",   "\\6",   "\\7",
+   "\\b",   "\\t",   "\\n",  "\\13",   "\\f",   "\\r",  "\\16",  "\\17",
+  "\\20",  "\\21",  "\\22",  "\\23",  "\\24",  "\\25",  "\\26",  "\\27",
+  "\\30",  "\\31",  "\\32",  "\\33",  "\\34",  "\\35",  "\\36",  "\\37",
+     " ",     "!",    "\"",     "#",     "$",     "%%",    "&",   "\\'",
+     "(",     ")",     "*",     "+",     ",",     "-",     ".",     "/",
+     "0",     "1",     "2",     "3",     "4",     "5",     "6",     "7",
+     "8",     "9",     ":",     ";",     "<",     "=",     ">",     "?",
+     "@",     "A",     "B",     "C",     "D",     "E",     "F",     "G",
+     "H",     "I",     "J",     "K",     "L",     "M",     "N",     "O",
+     "P",     "Q",     "R",     "S",     "T",     "U",     "V",     "W",
+     "X",     "Y",     "Z",     "[",  "\\\\",     "]",     "^",     "_",
+     "`",     "a",     "b",     "c",     "d",     "e",     "f",     "g",
+     "h",     "i",     "j",     "k",     "l",     "m",     "n",     "o",
+     "p",     "q",     "r",     "s",     "t",     "u",     "v",     "w",
+     "x",     "y",     "z",     "{",     "|",     "}",     "~"
+     };
+
+ void
+fmt_init()
+{
+	static char *str1fmt[6] =
+		{ "\\b", "\\t", "\\n", "\\f", "\\r", "\\%03o" };
+	register int i, j;
+	register char *s;
+
+	/* str_fmt */
+
+#ifdef non_ASCII
+	i = 0;
+#else
+	i = 127;
+#endif
+	for(; i < Table_size; i++)
+		str_fmt[i] = "\\%03o";
+#ifdef non_ASCII
+	for(i = 32; i < 127; i++) {
+		s = str0fmt[i];
+		str_fmt[*(unsigned char *)s] = s;
+		}
+	str_fmt['"'] = "\\\"";
+#else
+	if (Ansi == 1)
+		str_fmt[7] = chr_fmt[7] = "\\a";
+#endif
+
+	/* chr_fmt */
+
+#ifdef non_ASCII
+	for(i = 0; i < 32; i++)
+		chr_fmt[i] = chr0fmt[i];
+#else
+	i = 127;
+#endif
+	for(; i < Table_size; i++)
+		chr_fmt[i] = "\\%o";
+#ifdef non_ASCII
+	for(i = 32; i < 127; i++) {
+		s = chr0fmt[i];
+		j = *(unsigned char *)s;
+		if (j == '\\')
+			j = *(unsigned char *)(s+1);
+		chr_fmt[j] = s;
+		}
+#endif
+
+	/* escapes (used in lex.c) */
+
+	for(i = 0; i < Table_size; i++)
+		escapes[i] = i;
+	for(s = "btnfr0", i = 0; i < 6; i++)
+		escapes[*(unsigned char *)s++] = "\b\t\n\f\r"[i];
+	/* finish str_fmt and chr_fmt */
+
+	if (Ansi)
+		str1fmt[5] = "\\v";
+	if ('\v' == 'v') { /* ancient C compiler */
+		str1fmt[5] = "v";
+#ifndef non_ASCII
+		escapes['v'] = 11;
+#endif
+		}
+	else
+		escapes['v'] = '\v';
+	for(s = "\b\t\n\f\r\v", i = 0; j = *(unsigned char *)s++;)
+		str_fmt[j] = chr_fmt[j] = str1fmt[i++];
+	/* '\v' = 11 for both EBCDIC and ASCII... */
+	chr_fmt[11] = Ansi ? "\\v" : "\\13";
+	}
+
+
+
+/* Unless SYSTEM_SORT is defined, the following gives a simple
+ * in-core version of dsort().  On Fortran source with huge DATA
+ * statements, the in-core version may exhaust the available memory,
+ * in which case you might either recompile this source file with
+ * SYSTEM_SORT defined (if that's reasonable on your system), or
+ * replace the dsort below with a more elaborate version that
+ * does a merging sort with the help of auxiliary files.
+ */
+
+#ifdef SYSTEM_SORT
+
+dsort(from, to)
+ char *from, *to;
+{
+	char buf[200];
+	sprintf(buf, "sort <%s >%s", from, to);
+	return system(buf) >> 8;
+	}
+#else
+
+ static int
+compare(a,b)
+ char *a, *b;
+{ return strcmp(*(char **)a, *(char **)b); }
+
+dsort(from, to)
+ char *from, *to;
+{
+	extern char *Alloc();
+
+	struct Memb {
+		struct Memb *next;
+		int n;
+		char buf[32000];
+		};
+	typedef struct Memb memb;
+	memb *mb, *mb1;
+	register char *x, *x0, *xe;
+	register int c, n;
+	FILE *f;
+	char **z, **z0;
+	int nn = 0;
+
+	f = opf(from, textread);
+	mb = (memb *)Alloc(sizeof(memb));
+	mb->next = 0;
+	x0 = x = mb->buf;
+	xe = x + sizeof(mb->buf);
+	n = 0;
+	for(;;) {
+		c = getc(f);
+		if (x >= xe && (c != EOF || x != x0)) {
+			if (!n)
+				return 126;
+			nn += n;
+			mb->n = n;
+			mb1 = (memb *)Alloc(sizeof(memb));
+			mb1->next = mb;
+			mb = mb1;
+			memcpy(mb->buf, x0, n = x-x0);
+			x0 = mb->buf;
+			x = x0 + n;
+			xe = x0 + sizeof(mb->buf);
+			n = 0;
+			}
+		if (c == EOF)
+			break;
+		if (c == '\n') {
+			++n;
+			*x++ = 0;
+			x0 = x;
+			}
+		else
+			*x++ = c;
+		}
+	clf(&f, from, 1);
+	f = opf(to, textwrite);
+	if (x > x0) { /* shouldn't happen */
+		*x = 0;
+		++n;
+		}
+	mb->n = n;
+	nn += n;
+	if (!nn) /* shouldn't happen */
+		goto done;
+	z = z0 = (char **)Alloc(nn*sizeof(char *));
+	for(mb1 = mb; mb1; mb1 = mb1->next) {
+		x = mb1->buf;
+		n = mb1->n;
+		for(;;) {
+			*z++ = x;
+			if (--n <= 0)
+				break;
+			while(*x++);
+			}
+		}
+	qsort((char *)z0, nn, sizeof(char *), compare);
+	for(n = nn, z = z0; n > 0; n--)
+		fprintf(f, "%s\n", *z++);
+	free((char *)z0);
+ done:
+	clf(&f, to, 1);
+	do {
+		mb1 = mb->next;
+		free((char *)mb);
+		}
+		while(mb = mb1);
+	return 0;
+	}
+#endif

+ 83 - 0
lang/fortran/comp/sysdep.h

@@ -0,0 +1,83 @@
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories, Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+/* This file is included at the start of defs.h; this file
+ * is an initial attempt to gather in one place some declarations
+ * that may need to be tweaked on some systems.
+ */
+
+#ifdef __STDC__
+#ifndef ANSI_Libraries
+#define ANSI_Libraries
+#endif
+#ifndef ANSI_Prototypes
+#define ANSI_Prototypes
+#endif
+#endif
+
+#include <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) */

+ 99 - 0
lang/fortran/comp/tokens

@@ -0,0 +1,99 @@
+SEOS
+SCOMMENT
+SLABEL
+SUNKNOWN
+SHOLLERITH
+SICON
+SRCON
+SDCON
+SBITCON
+SOCTCON
+SHEXCON
+STRUE
+SFALSE
+SNAME
+SNAMEEQ
+SFIELD
+SSCALE
+SINCLUDE
+SLET
+SASSIGN
+SAUTOMATIC
+SBACKSPACE
+SBLOCK
+SCALL
+SCHARACTER
+SCLOSE
+SCOMMON
+SCOMPLEX
+SCONTINUE
+SDATA
+SDCOMPLEX
+SDIMENSION
+SDO
+SDOUBLE
+SELSE
+SELSEIF
+SEND
+SENDFILE
+SENDIF
+SENTRY
+SEQUIV
+SEXTERNAL
+SFORMAT
+SFUNCTION
+SGOTO
+SASGOTO
+SCOMPGOTO
+SARITHIF
+SLOGIF
+SIMPLICIT
+SINQUIRE
+SINTEGER
+SINTRINSIC
+SLOGICAL
+SNAMELIST
+SOPEN
+SPARAM
+SPAUSE
+SPRINT
+SPROGRAM
+SPUNCH
+SREAD
+SREAL
+SRETURN
+SREWIND
+SSAVE
+SSTATIC
+SSTOP
+SSUBROUTINE
+STHEN
+STO
+SUNDEFINED
+SWRITE
+SLPAR
+SRPAR
+SEQUALS
+SCOLON
+SCOMMA
+SCURRENCY
+SPLUS
+SMINUS
+SSTAR
+SSLASH
+SPOWER
+SCONCAT
+SAND
+SOR
+SNEQV
+SEQV
+SNOT
+SEQ
+SLT
+SGT
+SLE
+SGE
+SNE
+SENDDO
+SWHILE
+SSLASHD

+ 7 - 0
lang/fortran/comp/usignal.h

@@ -0,0 +1,7 @@
+#include <signal.h>
+#ifndef SIGHUP
+#define	SIGHUP	1	/* hangup */
+#endif
+#ifndef SIGQUIT
+#define	SIGQUIT	3	/* quit */
+#endif

+ 325 - 0
lang/fortran/comp/vax.c

@@ -0,0 +1,325 @@
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+#include "defs.h"
+#include "pccdefs.h"
+#include "output.h"
+
+int regnum[] =  {
+	11, 10, 9, 8, 7, 6 };
+
+/* Put out a constant integer */
+
+prconi(fp, n)
+FILEP fp;
+ftnint n;
+{
+	fprintf(fp, "\t%ld\n", n);
+}
+
+
+
+/* Put out a constant address */
+
+prcona(fp, a)
+FILEP fp;
+ftnint a;
+{
+	fprintf(fp, "\tL%ld\n", a);
+}
+
+
+
+prconr(fp, x, k)
+ FILEP fp;
+ int k;
+ Constp x;
+{
+	char *x0, *x1;
+	char cdsbuf0[64], cdsbuf1[64];
+
+	if (k > 1) {
+		if (x->vstg) {
+			x0 = x->Const.cds[0];
+			x1 = x->Const.cds[1];
+			}
+		else {
+			x0 = cds(dtos(x->Const.cd[0]), cdsbuf0);
+			x1 = cds(dtos(x->Const.cd[1]), cdsbuf1);
+			}
+		fprintf(fp, "\t%s %s\n", x0, x1);
+		}
+	else
+		fprintf(fp, "\t%s\n", x->vstg ? x->Const.cds[0]
+				: cds(dtos(x->Const.cd[0]), cdsbuf0));
+}
+
+
+char *memname(stg, mem)
+ int stg;
+ long mem;
+{
+	static char s[20];
+
+	switch(stg)
+	{
+	case STGCOMMON:
+	case STGEXT:
+		sprintf(s, "_%s", extsymtab[mem].cextname);
+		break;
+
+	case STGBSS:
+	case STGINIT:
+		sprintf(s, "v.%ld", mem);
+		break;
+
+	case STGCONST:
+		sprintf(s, "L%ld", mem);
+		break;
+
+	case STGEQUIV:
+		sprintf(s, "q.%ld", mem+eqvstart);
+		break;
+
+	default:
+		badstg("memname", stg);
+	}
+	return(s);
+}
+
+/* make_int_expr -- takes an arbitrary expression, and replaces all
+   occurrences of arguments with indirection */
+
+expptr make_int_expr (e)
+expptr e;
+{
+    if (e != ENULL)
+	switch (e -> tag) {
+	    case TADDR:
+	        if (e -> addrblock.vstg == STGARG)
+		    e = mkexpr (OPWHATSIN, e, ENULL);
+	        break;
+	    case TEXPR:
+	        e -> exprblock.leftp = make_int_expr (e -> exprblock.leftp);
+	        e -> exprblock.rightp = make_int_expr (e -> exprblock.rightp);
+	        break;
+	    default:
+	        break;
+	} /* switch */
+
+    return e;
+} /* make_int_expr */
+
+
+
+/* prune_left_conv -- used in prolog() to strip type cast away from
+   left-hand side of parameter adjustments.  This is necessary to avoid
+   error messages from cktype() */
+
+expptr prune_left_conv (e)
+expptr e;
+{
+    struct Exprblock *leftp;
+
+    if (e && e -> tag == TEXPR && e -> exprblock.leftp &&
+	    e -> exprblock.leftp -> tag == TEXPR) {
+	leftp = &(e -> exprblock.leftp -> exprblock);
+	if (leftp -> opcode == OPCONV) {
+	    e -> exprblock.leftp = leftp -> leftp;
+	    free ((charptr) leftp);
+	}
+    }
+
+    return e;
+} /* prune_left_conv */
+
+
+ static int wrote_comment;
+ static FILE *comment_file;
+
+ static void
+write_comment()
+{
+	if (!wrote_comment) {
+		wrote_comment = 1;
+		nice_printf (comment_file, "/* Parameter adjustments */\n");
+		}
+	}
+
+ static int *
+count_args()
+{
+	register int *ac;
+	register chainp cp;
+	register struct Entrypoint *ep;
+	register Namep q;
+
+	ac = (int *)ckalloc(nallargs*sizeof(int));
+
+	for(ep = entries; ep; ep = ep->entnextp)
+		for(cp = ep->arglist; cp; cp = cp->nextp)
+			if (q = (Namep)cp->datap)
+				ac[q->argno]++;
+	return ac;
+	}
+
+prolog(outfile, p)
+ FILE *outfile;
+ register chainp p;
+{
+	int addif, addif0, i, nd, size;
+	int *ac;
+	register Namep q;
+	register struct Dimblock *dp;
+
+	if(procclass == CLBLOCK)
+		return;
+	wrote_comment = 0;
+	comment_file = outfile;
+	ac = 0;
+
+/* Compute the base addresses and offsets for the array parameters, and
+   assign these values to local variables */
+
+	addif = addif0 = nentry > 1;
+	for(; p ; p = p->nextp)
+	{
+	    q = (Namep) p->datap;
+	    if(dp = q->vdim)	/* if this param is an array ... */
+	    {
+		expptr Q, expr;
+
+		/* See whether to protect the following with an if. */
+		/* This only happens when there are multiple entries. */
+
+		nd = dp->ndim - 1;
+		if (addif0) {
+			if (!ac)
+				ac = count_args();
+			if (ac[q->argno] == nentry)
+				addif = 0;
+			else if (dp->basexpr
+				    || dp->baseoffset->constblock.Const.ci)
+				addif = 1;
+			else for(addif = i = 0; i <= nd; i++)
+				if (dp->dims[i].dimexpr
+				&& (i < nd || !q->vlastdim)) {
+					addif = 1;
+					break;
+					}
+			if (addif) {
+				write_comment();
+				nice_printf(outfile, "if (%s) {\n", /*}*/
+						q->cvarname);
+				next_tab(outfile);
+				}
+			}
+		for(i = 0 ; i <= nd; ++i)
+
+/* Store the variable length of each dimension (which is fixed upon
+   runtime procedure entry) into a local variable */
+
+		    if ((Q = dp->dims[i].dimexpr)
+			&& (i < nd || !q->vlastdim)) {
+			expr = (expptr)cpexpr(Q);
+			write_comment();
+			out_and_free_statement (outfile, mkexpr (OPASSIGN,
+				fixtype(cpexpr(dp->dims[i].dimsize)), expr));
+		    } /* if dp -> dims[i].dimexpr */
+
+/* size   will equal the size of a single element, or -1 if the type is
+   variable length character type */
+
+		size = typesize[ q->vtype ];
+		if(q->vtype == TYCHAR)
+		    if( ISICON(q->vleng) )
+			size *= q->vleng->constblock.Const.ci;
+		    else
+			size = -1;
+
+		/* Fudge the argument pointers for arrays so subscripts
+		 * are 0-based. Not done if array bounds are being checked.
+		 */
+		if(dp->basexpr) {
+
+/* Compute the base offset for this procedure */
+
+		    write_comment();
+		    out_and_free_statement (outfile, mkexpr (OPASSIGN,
+			    cpexpr(fixtype(dp->baseoffset)),
+			    cpexpr(fixtype(dp->basexpr))));
+		} /* if dp -> basexpr */
+
+		if(! checksubs) {
+		    if(dp->basexpr) {
+			expptr tp;
+
+/* If the base of this array has a variable adjustment ... */
+
+			tp = (expptr) cpexpr (dp -> baseoffset);
+			if(size < 0 || q -> vtype == TYCHAR)
+			    tp = mkexpr (OPSTAR, tp, cpexpr (q -> vleng));
+
+			write_comment();
+			tp = mkexpr (OPMINUSEQ,
+				mkconv (TYADDR, (expptr)p->datap),
+				mkconv(TYINT, fixtype
+				(fixtype (tp))));
+/* Avoid type clash by removing the type conversion */
+			tp = prune_left_conv (tp);
+			out_and_free_statement (outfile, tp);
+		    } else if(dp->baseoffset->constblock.Const.ci != 0) {
+
+/* if the base of this array has a nonzero constant adjustment ... */
+
+			expptr tp;
+
+			write_comment();
+			if(size > 0 && q -> vtype != TYCHAR) {
+			    tp = prune_left_conv (mkexpr (OPMINUSEQ,
+				    mkconv (TYADDR, (expptr)p->datap),
+				    mkconv (TYINT, fixtype
+				    (cpexpr (dp->baseoffset)))));
+			    out_and_free_statement (outfile, tp);
+			} else {
+			    tp = prune_left_conv (mkexpr (OPMINUSEQ,
+				    mkconv (TYADDR, (expptr)p->datap),
+				    mkconv (TYINT, fixtype
+				    (mkexpr (OPSTAR, cpexpr (dp -> baseoffset),
+				    cpexpr (q -> vleng))))));
+			    out_and_free_statement (outfile, tp);
+			} /* else */
+		    } /* if dp -> baseoffset -> const */
+		} /* if !checksubs */
+
+		if (addif) {
+			nice_printf(outfile, /*{*/ "}\n");
+			prev_tab(outfile);
+			}
+	    }
+	}
+	if (wrote_comment)
+	    nice_printf (outfile, "\n/* Function Body */\n");
+	if (ac)
+		free((char *)ac);
+} /* prolog */

+ 2 - 0
lang/fortran/comp/version.c

@@ -0,0 +1,2 @@
+char F2C_version[] = "28 August 1991  0:07:02";
+char xxxvers[] = "\n@(#) FORTRAN 77 to C Translator, VERSION 28 August 1991  0:07:02\n";

+ 174 - 0
lang/fortran/comp/xsum.c

@@ -0,0 +1,174 @@
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+#include "stdio.h"
+
+ char *progname;
+
+ void
+usage(rc)
+{
+	fprintf(stderr, "usage: %s [file [file...]]\n", progname);
+	exit(rc);
+	}
+
+main(argc, argv)
+ char **argv;
+{
+	int x;
+	char *s;
+	static int rc;
+
+	progname = *argv;
+	s = *++argv;
+	if (s && *s == '-') {
+		switch(s[1]) {
+			case '?':
+				usage(0);
+			case '-':
+				break;
+			default:
+				fprintf(stderr, "invalid option %s\n", s);
+				usage(1);
+			}
+		s = *++argv;
+		}
+	if (s) do {
+		x = open(s,0);
+		if (x < 0) {
+			fprintf(stderr, "%s: can't open %s\n", progname, s);
+			rc |= 1;
+			}
+		else
+			process(s, x);
+		}
+		while(s = *++argv);
+	else {
+		process("/dev/stdin", fileno(stdin));
+		}
+	exit(rc);
+	}
+
+typedef unsigned char uchar;
+
+ long
+sum32(sum, x, n)
+ register long sum;
+ register uchar *x;
+ int n;
+{
+	register uchar *xe;
+	static long crc_table[256] = {
+		0,		151466134,	302932268,	453595578,
+		-9583591,	-160762737,	-312236747,	-463170141,
+		-19167182,	-136529756,	-321525474,	-439166584,
+		28724267,	145849533,	330837255,	448732561,
+		-38334364,	-189783822,	-273059512,	-423738914,
+		47895677,	199091435,	282375505,	433292743,
+		57448534,	174827712,	291699066,	409324012,
+		-67019697,	-184128295,	-300991133,	-418902539,
+		-76668728,	-227995554,	-379567644,	-530091662,
+		67364049,	218420295,	369985021,	520795499,
+		95791354,	213031020,	398182870,	515701056,
+		-86479645,	-203465611,	-388624945,	-506380967,
+		114897068,	266207290,	349655424,	500195606,
+		-105581387,	-256654301,	-340093543,	-490887921,
+		-134039394,	-251295736,	-368256590,	-485758684,
+		124746887,	241716241,	358686123,	476458301,
+		-153337456,	-2395898,	-455991108,	-304803798,
+		162629001,	11973919,	465560741,	314102835,
+		134728098,	16841012,	436840590,	319723544,
+		-144044613,	-26395347,	-446403433,	-329032703,
+		191582708,	40657250,	426062040,	274858062,
+		-200894995,	-50223749,	-435620671,	-284179369,
+		-172959290,	-55056048,	-406931222,	-289830788,
+		182263263,	64630089,	416513267,	299125861,
+		229794136,	78991822,	532414580,	381366498,
+		-220224191,	-69691945,	-523123603,	-371788549,
+		-211162774,	-93398532,	-513308602,	-396314416,
+		201600371,	84090341,	503991391,	386759881,
+		-268078788,	-117292630,	-502591472,	-351526778,
+		258520357,	107972019,	493278217,	341959839,
+		249493774,	131713432,	483432482,	366454964,
+		-239911657,	-122417791,	-474129349,	-356881235,
+		-306674912,	-457198666,	-4791796,	-156118374,
+		315967289,	466778031,	14362133,	165418627,
+		325258002,	442776452,	23947838,	141187752,
+		-334573813,	-452329571,	-33509849,	-150495567,
+		269456196,	419996626,	33682024,	184992510,
+		-278767779,	-429561909,	-43239823,	-194312473,
+		-288089226,	-405591072,	-52790694,	-170046772,
+		297394031,	415166457,	62373443,	179343061,
+		383165416,	533828478,	81314500,	232780370,
+		-373594127,	-524527769,	-72022307,	-223201717,
+		-401789990,	-519431348,	-100447498,	-217810336,
+		392228803,	510123861,	91131631,	208256633,
+		-345918580,	-496598246,	-110112096,	-261561802,
+		336361365,	487278339,	100800185,	251995695,
+		364526526,	482151208,	129260178,	246639108,
+		-354943065,	-472854735,	-119955829,	-237064675,
+		459588272,	308539942,	157983644,	7181066,
+		-469170519,	-317835713,	-167286907,	-16754925,
+		-440448382,	-323454444,	-139383890,	-21619912,
+		450006683,	332774925,	148697015,	31186721,
+		-422325548,	-271261118,	-186797064,	-36011154,
+		431888077,	280569435,	196114401,	45565815,
+		403200742,	286222960,	168180682,	50400092,
+		-412770561,	-295522711,	-177471533,	-59977915,
+		-536157576,	-384970002,	-234585260,	-83643454,
+		526853729,	375396087,	225003341,	74348507,
+		517040714,	399923932,	215944038,	98057200,
+		-507728301,	-390357307,	-206385281,	-88735767,
+		498987548,	347783818,	263426864,	112501670,
+		-489671163,	-338229613,	-253864151,	-103192641,
+		-479823314,	-362722632,	-244835582,	-126932076,
+		470531639,	353144481,	235265819,	117632909
+		};
+
+	xe = x + n;
+	while(x < xe)
+		sum = crc_table[(sum ^ *x++) & 0xff] ^ (sum >> 8 & 0xffffff);
+	return sum;
+	}
+
+process(s, x)
+ char *s;
+ int x;
+{
+	register int n;
+	uchar buf[16*1024];
+	long fsize, sum;
+
+	sum = 0;
+	fsize = 0;
+	while((n = read(x, (char *)buf, sizeof(buf))) > 0) {
+		fsize += n;
+		sum = sum32(sum, buf, n);
+		}
+	sum &= 0xffffffff;
+        if (n==0)
+		printf("%s\t%lx\t%ld\n", s, sum & 0xffffffff, fsize);
+        else { perror(s); }
+	close(x);
+	return(0);
+	}

+ 56 - 0
lang/fortran/comp/xsum0.out

@@ -0,0 +1,56 @@
+Notice	fb5a412e	1183
+README	fe10cd03	3340
+cds.c	e93849b8	3884
+data.c	e552a480	9278
+defines.h	ef026e5f	8179
+defs.h	e74a0285	23464
+equiv.c	e7eb3399	8552
+error.c	111d9ebf	3653
+exec.c	18ed4ede	18027
+expr.c	e2bc323c	57458
+f2c.1	e65632a	5799
+f2c.1t	1aad289	5706
+f2c.h	ed0a0173	4138
+format.c	e7b58fa8	49914
+format.h	e861ad39	300
+formatdata.c	eeebb124	23833
+ftypes.h	e5db6a7c	941
+gram.dcl	fac72441	8102
+gram.exec	ff121afb	2996
+gram.expr	1cdcf8c5	3081
+gram.head	e6859fc0	7539
+gram.io	1b7c281c	3294
+init.c	f7ca02f1	10347
+intr.c	e2b8e4ab	19647
+io.c	c474aae	28975
+iob.h	fe479ed3	459
+lex.c	fe1e63b6	29374
+machdefs.h	4950e5b	659
+main.c	1e4ec3a1	16300
+makefile	12f58dbe	2510
+malloc.c	5c2be2a	3422
+mem.c	5b007b2	4761
+memset.c	17404d52	1964
+misc.c	19c4624d	17758
+names.c	e5184875	19122
+names.h	f25436a3	689
+niceprintf.c	f9d80b51	9355
+niceprintf.h	c31f08c	412
+output.c	f97db62	37044
+output.h	edfe9e59	2113
+p1defs.h	e4e11c4e	5776
+p1output.c	e60446f5	12198
+parse.h	e457df2e	855
+parse_args.c	f3e5da4d	13015
+pccdefs.h	1b4fbbee	1195
+pread.c	135e64ca	15796
+proc.c	f5df26ff	34052
+put.c	1f22b2c0	9499
+putpcc.c	1f96161e	38473
+sysdep.c	197e669f	10864
+sysdep.h	e602b6fd	2532
+tokens	194fccfe	727
+usignal.h	1c4ce909	124
+vax.c	b060552	7649
+version.c	f7b72f6f	137
+xsum.c	bd02396	5479

+ 15 - 0
lang/fortran/disclaimer

@@ -0,0 +1,15 @@
+f2c is a Fortran to C converter under development by
+	David Gay (AT&T Bell Labs)
+	Stu Feldman (Bellcore)
+	Mark Maimone (Carnegie-Mellon University)
+	Norm Schryer (AT&T Bell Labs)
+Please send bug reports to dmg@research.att.com or uunet!research!dmg.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.

+ 180 - 0
lang/fortran/fc

@@ -0,0 +1,180 @@
+#!/bin/sh
+PATH=/v/bin:/bin:/usr/bin
+# f77-style shell script to compile and load fortran, C, and assembly codes
+
+#	usage:	f77 [-O] [-o absfile] [-c] files [-l library]
+
+#		-o objfile	Override default executable name a.out.
+
+#		-c		Do not call linker, leave relocatables in *.o.
+
+#		-S		leave assembler output on file.s
+
+#		-l library	(passed to ld).
+
+#		-u		complain about undeclared variables
+
+#		-w		omit all warning messages
+
+#		-w66		omit Fortran 66 compatibility warning messages
+
+#		files		FORTRAN source files ending in .f .
+#				C source files ending in .c .
+#				Assembly language files ending in .s .
+#				efl source files ending in .e .
+
+#		-D def		passed to C compiler (for .c files)
+
+#		-I includepath	passed to C compiler (for .c files)
+
+#		-Ntnnn		allow nnn entries in table t
+
+s=/tmp/stderr_$$
+t=/tmp/f77_$$.o
+CC=${CC_f2c:-'/v/bin/lcc -Wfdouble=8,4,1'}
+EFL=${EFL:-/v/bin/efl}
+EFLFLAGS=${EFLFLAGS:-'system=portable deltastno=10'}
+F2C=${F2C:-/v/bin/f2c}
+F2CFLAGS=${F2CFLAGS:='-ARw8'}
+rc=0
+trap "rm -f $s $t; exit \$rc" 0
+lib=/lib/num/lib.lo
+OUTF=a.out
+cOPT=1
+set -- `getopt cD:gI:N:Oo:Suw6 "$@"`
+case $? in 0);; *) exit 1;; esac
+CCFLAGS=
+while
+	test X"$1" != X--
+do
+	case "$1"
+	in
+	-c)	cOPT=0
+		shift
+		;;
+
+	-D)	CCFLAGS="$CCFLAGS -D$2"
+		shift 2
+		;;
+
+	-g)	CFLAGS="$CFLAGS -g"
+		shift;;
+
+	-I)	CCFLAGS="$CCFLAGS -I$2"
+		shift 2
+		;;
+
+	-o)	OUTF=$2
+		shift 2
+		;;
+
+	-O)	case $2 in -1) O=-O1;; -2) O=-O2;; -3) O=-O3;; *) O=-O;; esac
+		case $O in -O);; *) shift;; esac
+		# lcc ignores -O...
+		shift
+		;;
+
+	-u)	F2CFLAGS="$F2CFLAGS -u"
+		shift
+		;;
+
+	-w)	F2CFLAGS="$F2CFLAGS -w"
+		case $2 in -6) F2CFLAGS="$F2CFLAGS"66; shift
+			case $2 in -6) shift;; esac;; esac
+		shift
+		;;
+
+	-N)	F2CFLAGS="$F2CFLAGS $1""$2"
+		shift 2
+		;;
+
+	-S)	CFLAGS="$CFLAGS -S"
+		cOPT=0
+		shift
+		;;
+
+	*)
+		echo "invalid parameter $1" 1>&2
+		shift
+		;;
+	esac
+done
+shift
+while
+	test -n "$1"
+do
+	case "$1"
+	in
+	*.[fF])
+		case "$1" in *.f) f=".f";; *.F) f=".F";; esac
+		b=`basename $1 $f`
+		$F2C $F2CFLAGS $1
+		case $? in 0);; *) exit;; esac
+                $CC -c $CFLAGS $b.c 2>$s
+		rc=$?
+		sed '/parameter .* is not referenced/d;/warning: too many parameters/d' $s 1>&2
+		case $rc in 0);; *) exit;; esac
+		OFILES="$OFILES $b.o"
+		rm $b.c
+		case $cOPT in 1) cOPT=2;; esac
+		shift
+		;;
+	*.e)
+		b=`basename $1 .e`
+		$EFL $EFLFLAGS $1 >$b.f
+		case $? in 0);; *) exit;; esac
+		$F2C $F2CFLAGS $b.f
+		case $? in 0);; *) exit;; esac
+                $CC -c $CFLAGS $b.c
+		case $? in 0);; *) exit;; esac
+		OFILES="$OFILES $b.o"
+		rm $b.[cf]
+		case $cOPT in 1) cOPT=2;; esac
+		shift
+		;;
+	*.s)
+		echo $1: 1>&2
+		OFILE=`basename $1 .s`.o
+		${AS:-/usr/bin/as} -o $OFILE $AFLAGS $1
+		case $? in 0);; *) exit;; esac
+		OFILES="$OFILES $OFILE"
+		case $cOPT in 1) cOPT=2;; esac
+		shift
+		;;
+	*.c)
+		echo $1: 1>&2
+		OFILE=`basename $1 .c`.o
+                $CC -c $CFLAGS $CCFLAGS $1
+		rc=$?; case $rc in 0);; *) exit;; esac
+		OFILES="$OFILES $OFILE"
+		case $cOPT in 1) cOPT=2;; esac
+		shift
+		;;
+	*.o)
+		OFILES="$OFILES $1"
+		case $cOPT in 1) cOPT=2;; esac
+		shift
+		;;
+	-l)
+		OFILES="$OFILES -l$2"
+		shift 2
+		case $cOPT in 1) cOPT=2;; esac
+		;;
+	-l*)
+		OFILES="$OFILES $1"
+		shift
+		case $cOPT in 1) cOPT=2;; esac
+		;;
+	-o)
+		OUTF=$2; shift 2;;
+	*)
+		OFILES="$OFILES $1"
+		shift
+		case $cOPT in 1) cOPT=2;; esac
+		;;
+	esac
+done
+
+case $cOPT in 2) $CC -o $OUTF -u MAIN__ $OFILES -lf2c -lm;; esac
+rc=$?
+exit $rc

+ 1184 - 0
lang/fortran/fixes

@@ -0,0 +1,1184 @@
+31 Aug. 1989:
+   1. A(min(i,j)) now is translated correctly (where A is an array).
+   2. 7 and 8 character variable names are allowed (but elicit a
+      complaint under -ext).
+   3. LOGICAL*1 is treated as LOGICAL, with just one error message
+      per LOGICAL*1 statement (rather than one per variable declared
+      in that statement).  [Note that LOGICAL*1 is not in Fortran 77.]
+      Like f77, f2c now allows the format in a read or write statement
+      to be an integer array.
+
+5 Sept. 1989:
+   Fixed botch in argument passing of substrings of equivalenced
+variables.
+
+15 Sept. 1989:
+   Warn about incorrect code generated when a character-valued
+function is not declared external and is passed as a parameter
+(in violation of the Fortran 77 standard) before it is invoked.
+Example:
+
+	subroutine foo(a,b)
+	character*10 a,b
+	call goo(a,b)
+	b = a(3)
+	end
+
+18 Sept. 1989:
+   Complain about overlapping initializations.
+
+20 Sept. 1989:
+   Warn about names declared EXTERNAL but never referenced;
+include such names as externs in the generated C (even
+though most C compilers will discard them).
+
+24 Sept. 1989:
+   New option -w8 to suppress complaint when COMMON or EQUIVALENCE
+forces word alignment of a double.
+   Under -A (for ANSI C), ensure that floating constants (terminated
+by 'f') contain either a decimal point or an exponent field.
+   Repair bugs sometimes encountered with CHAR and ICHAR intrinsic
+functions.
+   Restore f77's optimizations for copying and comparing character
+strings of length 1.
+   Always assume floating-point valued routines in libF77 return
+doubles, even under -R.
+   Repair occasional omission of arguments in routines having multiple
+entry points.
+   Repair bugs in computing offsets of character strings involved
+in EQUIVALENCE.
+   Don't omit structure qualification when COMMON variables are used
+as FORMATs or internal files.
+
+2 Oct. 1989:
+   Warn about variables that appear only in data stmts; don't emit them.
+   Fix bugs in character DATA for noncharacter variables
+involved in EQUIVALENCE.
+   Treat noncharacter variables initialized (at least partly) with
+character data as though they were equivalenced -- put out a struct
+and #define the variables.  This eliminates the hideous and nonportable
+numeric values that were used to initialize such variables.
+   Treat IMPLICIT NONE as IMPLICIT UNDEFINED(A-Z) .
+   Quit when given invalid options.
+
+8 Oct. 1989:
+  Modified naming scheme for generated intermediate variables;
+more are recycled, fewer distinct ones used.
+  New option -W nn specifies nn characters/word for Hollerith
+data initializing non-character variables.
+  Bug fix: x(i:min(i+10,j)) used to elicit "Can't handle opcode 31 yet".
+  Integer expressions of the form (i+const1) - (i+const2), where
+i is a scalar integer variable, are now simplified to (const1-const2);
+this leads to simpler translation of some substring expressions.
+  Initialize uninitialized portions of character string arrays to 0
+rather than to blanks.
+
+9 Oct. 1989:
+  New option -c to insert comments showing original Fortran source.
+  New option -g to insert line numbers of original Fortran source.
+
+10 Oct. 1989:
+  ! recognized as in-line comment delimiter (a la Fortran 88).
+
+24 Oct. 1989:
+  New options to ease coping with systems that want the structs
+that result from COMMON blocks to be defined just once:
+  -E causes uninitialized COMMON blocks to be declared Extern;
+if Extern is undefined, f2c.h #defines it to be extern.
+  -ec causes a separate .c file to be emitted for each
+uninitialized COMMON block: COMMON /ABC/ yields abc_com.c;
+thus one can compile *_com.c into a library to ensure
+precisely one definition.
+  -e1c is similar to -ec, except that everything goes into
+one file, along with comments that give a sed script for
+splitting the file into the pieces that -ec would give.
+This is for use with netlib's "execute f2c" service (for which
+-ec is coerced into -e1c, and the sed script will put everything
+but the COMMON definitions into f2c_out.c ).
+
+28 Oct. 1989:
+  Convert "i = i op ..." into "i op= ...;" even when i is a
+dummy argument.
+
+13 Nov. 1989:
+  Name integer constants (passed as arguments) c__... rather
+than c_... so
+	common /c/stuff
+	call foo(1)
+	...
+is translated correctly.
+
+19 Nov. 1989:
+  Floating-point constants are now kept as strings unless they
+are involved in constant expressions that get simplified.  The
+floating-point constants kept as strings can have arbitrarily
+many significant figures and a very large exponent field (as
+large as long int allows on the machine on which f2c runs).
+Thus, for example, the body of
+
+	subroutine zot(x)
+	double precision x(6), pi
+	parameter (pi=3.1415926535897932384626433832795028841972)
+	x(1) = pi
+	x(2) = pi+1
+	x(3) = 9287349823749272.7429874923740978492734D-298374
+	x(4) = .89
+	x(5) = 4.0005
+	x(6) = 10D7
+	end
+
+now gets translated into
+
+    x[1] = 3.1415926535897932384626433832795028841972;
+    x[2] = 4.1415926535897931;
+    x[3] = 9.2873498237492727429874923740978492734e-298359;
+    x[4] = (float).89;
+    x[5] = (float)4.0005;
+    x[6] = 1e8;
+
+rather than the former
+
+    x[1] = 3.1415926535897931;
+    x[2] = 4.1415926535897931;
+    x[3] = 0.;
+    x[4] = (float)0.89000000000000003;
+    x[5] = (float)4.0004999999999997;
+    x[6] = 100000000.;
+
+  Recognition of f77 machine-constant intrinsics deleted, i.e.,
+epbase, epprec, epemin, epemax, eptiny, ephuge, epmrsp.
+
+22 Nov. 1989:
+  Workarounds for glitches on some Sun systems...
+  libf77: libF77/makefile modified to point out possible need
+to compile libF77/main.c with -Donexit=on_exit .
+  libi77: libI77/wref.c (and libI77/README) modified so non-ANSI
+systems can compile with USE_STRLEN defined, which will cause
+	sprintf(b = buf, "%#.*f", d, x);
+	n = strlen(b) + d1;
+rather than
+	n = sprintf(b = buf, "%#.*f", d, x) + d1;
+to be compiled.
+
+26 Nov. 1989:
+  Longer names are now accepted (up to 50 characters); names may
+contain underscores (in which case they will have two underscores
+appended, to avoid clashes with library names).
+
+28 Nov. 1989:
+  libi77 updated:
+	1. Allow 3 (or, on Crays, 4) digit exponents under format Ew.d .
+	2. Try to get things right on machines where ints have 16 bits.
+
+29 Nov. 1989:
+  Supplied missing semicolon in parameterless subroutines that
+have multiple entry points (all of them parameterless).
+
+30 Nov. 1989:
+  libf77 and libi77 revised to use types from f2c.h.
+  f2c now types floating-point valued C library routines as "double"
+rather than "doublereal" (for use with nonstandard C compilers for
+which "double" is IEEE double extended).
+
+1 Dec. 1989:
+  f2c.h updated to eliminate #defines rendered unnecessary (and,
+indeed, dangerous) by change of 26 Nov. to long names possibly
+containing underscores.
+  libi77 further revised: yesterday's change omitted two tweaks to fmt.h
+(tweaks which only matter if float and real or double and doublereal are
+different types).
+
+2 Dec. 1989:
+  Better error message (than "bad tag") for NAMELIST, which no longer
+inhibits C output.
+
+4 Dec. 1989:
+  Allow capital letters in hex constants (f77 extension; e.g.,
+x'a012BCd', X'A012BCD' and x'a012bcd' are all treated as the integer
+167848909).
+  libi77 further revised: lio.c lio.h lread.c wref.c wrtfmt.c tweaked
+again to allow float and real or double and doublereal to be different.
+
+6 Dec. 1989:
+  Revised f2c.h -- required for the following...
+  Simpler looking translations for abs, min, max, using #defines in
+revised f2c.h .
+  libi77: more corrections to types; additions for NAMELIST.
+  Corrected casts in some I/O calls.
+  Translation of NAMELIST; libi77 must still be revised.  Currently
+libi77 gives you a run-time error message if you attempt NAMELIST I/O.
+
+7 Dec. 1989:
+  Fixed bug that prevented local integer variables that appear in DATA
+stmts from being ASSIGNed statement labels.
+  Fillers (for DATA statements initializing EQUIVALENCEd variables and
+variables in COMMON) typed integer rather than doublereal (for slightly
+more portability, e.g. to Crays).
+  libi77: missing return values supplied in a few places; some tests
+reordered for better working on the Cray.
+  libf77: better accuracy for complex divide, complex square root,
+real mod function (casts to double; double temporaries).
+
+9 Dec. 1989:
+  Fixed bug that caused needless (albeit harmless) empty lines to be
+inserted in the C output when a comment line contained trailing blanks.
+  Further tweak to type of fillers: allow doublereal fillers if the
+struct has doublereal data.
+
+11 Dec. 1989:
+  Alteration of rule for producing external (C) names from names that
+contain underscores.  Now the external name is always obtained by
+appending a pair of underscores.
+
+12 Dec. 1989:
+  C production inhibited after most errors.
+
+15 Dec. 1989:
+  Fixed bug in headers for subroutines having two or more character
+strings arguments:  the length arguments were reversed.
+
+19 Dec. 1989:
+  f2c.h libf77 libi77: adjusted so #undefs in f2c.h should not foil
+compilation of libF77 and libI77.
+  libf77: getenv_ adjusted to work with unsorted environments.
+  libi77: the iostat= specifier should now work right with internal I/O.
+
+20 Dec. 1989:
+  f2c bugs fixed: In the absence of an err= specifier, the iostat=
+specifier was generally set wrong.  Character strings containing
+explicit nulls (\0) were truncated at the first null.
+  Unlabeled DO loops recognized; must be terminated by ENDDO.
+(Don't ask for CYCLE, EXIT, named DO loops, or DO WHILE.)
+
+29 Dec. 1989:
+  Nested unlabeled DO loops now handled properly; new warning for
+extraneous text at end of FORMAT.
+
+30 Dec. 1989:
+  Fixed bug in translating dble(real(...)), dble(sngl(...)), and
+dble(float(...)), where ... is either of type double complex or
+is an expression requiring assignment to intermediate variables (e.g.,
+dble(real(foo(x+1))), where foo is a function and x is a variable).
+Regard nonblank label fields on continuation lines as an error.
+
+3 Jan. 1990:
+  New option -C++ yields output that should be understood
+by C++ compilers.
+
+6 Jan. 1989:
+  -a now excludes variables that appear in a namelist from those
+that it makes automatic.  (As before, it also excludes variables
+that appear in a common, data, equivalence, or save statement.)
+  The syntactically correct Fortran
+	read(*,i) x
+	end
+now yields syntactically correct C (even though both the Fortran
+and C are buggy -- no FORMAT has not been ASSIGNed to i).
+
+7 Jan. 1990:
+  libi77: routines supporting NAMELIST added.  Surrounding quotes
+made optional when no ambiguity arises in a list or namelist READ
+of a character-string value.
+
+9 Jan. 1990:
+  f2c.src made available.
+
+16 Jan. 1990:
+  New options -P to produce ANSI C or C++ prototypes for procedures
+defined.  Change to -A and -C++: f2c tries to infer prototypes for
+invoked procedures unless the new -!P option is given.  New warning
+messages for inconsistent calling sequences among procedures within
+a single file.  Most of f2c/src is affected.
+  f2c.h: typedefs for procedure arguments added; netlib's f2c service
+will insert appropriate typedefs for use with older versions of f2c.h.
+
+17 Jan. 1990:
+  f2c/src: defs.h exec.c format.c proc.c putpcc.c version.c xsum0.out
+updated.  Castargs and protofile made extern in defs.h; exec.c
+modified so superfluous else clauses are diagnosed; unused variables
+omitted from declarations in format.c proc.c putpcc.c .
+
+21 Jan. 1990:
+  No C emitted for procedures declared external but not referenced.
+  f2c.h: more new types added for use with -P.
+  New feature: f2c accepts as arguments files ending in .p or .P;
+such files are assumed to be prototype files, such as produced by
+the -P option.  All prototype files are read before any Fortran files
+and apply globally to all Fortran files.  Suitable prototypes help f2c
+warn about calling-sequence errors and can tell f2c how to type
+procedures declared external but not explicitly typed; the latter is
+mainly of interest for users of the -A and -C++ options.  (Prototype
+arguments are not available to netlib's "execute f2c" service.)
+  New option -it tells f2c to try to infer types of untyped external
+arguments from their use as parameters to prototyped or previously
+defined procedures.
+  f2c/src: many minor cleanups; most modules changed.  Individual
+files in f2c/src are now in "bundle" format.  The former f2c.1 is
+now f2c.1t; "f2c.1t from f2c" and "f2c.1t from f2c/src" are now the
+same, as are "f2c.1 from f2c" and "f2c.1 from f2c/src".  People who
+do not obtain a new copy of "all from f2c/src" should at least add
+	fclose(sortfp);
+after the call on do_init_data(outfile, sortfp) in format_data.c .
+
+22 Jan. 1990:
+  Cleaner man page wording (thanks to Doug McIlroy).
+  -it now also applies to all untyped EXTERNAL procedures, not just
+arguments.
+
+23 Jan. 01:34:00 EST 1990:
+  Bug fixes: under -A and -C++, incorrect C was generated for
+subroutines having multiple entries but no arguments.
+  Under -A -P, subroutines of no arguments were given prototype
+calling sequence () rather than (void).
+  Character-valued functions elicited erroneous warning messages
+about inconsistent calling sequences when referenced by another
+procedure in the same file.
+  f2c.1t: omit first appearance of libF77.a in FILES section;
+load order of libraries is -lF77 -lI77, not vice versa (bug
+introduced in yesterday's edits); define .F macro for those whose
+-man lacks it.  (For a while after yesterday's fixes were posted,
+f2c.1t was out of date.  Sorry!)
+
+23 Jan. 9:53:24 EST 1990:
+  Character substring expressions involving function calls having
+character arguments (including the intrinsic len function) yielded
+incorrect C.
+  Procedures defined after invocation (in the same file) with
+conflicting argument types also got an erroneous message about
+the wrong number of arguments.
+
+24 Jan. 11:44:00 EST 1990:
+  Bug fixes: -p omitted #undefs; COMMON block names containing
+underscores had their C names incorrectly computed; a COMMON block
+having the name of a previously defined procedure wreaked havoc;
+if all arguments were .P files, f2c tried reading the second as a
+Fortran file.
+  New feature: -P emits comments showing COMMON block lengths, so one
+can get warnings of incompatible COMMON block lengths by having f2c
+read .P (or .p) files.  Now by running f2c twice, first with -P -!c
+(or -P!c),  then with *.P among the arguments, you can be warned of
+inconsistent COMMON usage, and COMMON blocks having inconsistent
+lengths will be given the maximum length.  (The latter always did
+happen within each input file; now -P lets you extend this behavior
+across files.)
+
+26 Jan. 16:44:00 EST 1990:
+  Option -it made less aggressive: untyped external procedures that
+are invoked are now typed by the rules of Fortran, rather than by
+previous use of procedures to which they are passed as arguments
+before being invoked.
+  Option -P now includes information about references, i.e., called
+procedures, in the prototype files (in the form of special comments).
+This allows iterative invocations of f2c to infer more about untyped
+external names, particularly when multiple Fortran files are involved.
+  As usual, there are some obscure bug fixes:
+1.  Repair of erroneous warning messages about inconsistent number of
+arguments that arose when a character dummy parameter was discovered
+to be a function or when multiple entry points involved character
+variables appearing in a previous entry point.
+2.  Repair of memory fault after error msg about "adjustable character
+function".
+3.  Under -U, allow MAIN_ as a subroutine name (in the same file as a
+main program).
+4.  Change for consistency: a known function invoked as a subroutine,
+then as a function elicits a warning rather than an error.
+
+26 Jan. 22:32:00 EST 1990:
+  Fixed two bugs that resulted in incorrect C for substrings, within
+the body of a character-valued function, of the function's name, when
+those substrings were arguments to another function (even implicitly,
+as in character-string assignment).
+
+28 Jan. 18:32:00 EST 1990:
+  libf77, libi77: checksum files added; "make check" looks for
+transmission errors.  NAMELIST read modified to allow $ rather than &
+to precede a namelist name, to allow $ rather than / to terminate
+input where the name of another variable would otherwise be expected,
+and to regard all nonprinting ASCII characters <= ' ' as spaces.
+
+29 Jan. 02:11:00 EST 1990:
+  "fc from f2c" added.
+  -it option made the default; -!it turns it off.  Type information is
+now updated in a previously missed case.
+  -P option tweaked again; message about when rerunning f2c may change
+prototypes or declarations made more accurate.
+  New option -Ps implies -P and returns exit status 4 if rerunning
+f2c -P with prototype inputs might change prototypes or declarations.
+Now you can execute a crude script like
+
+	cat *.f >zap.F
+	rm -f zap.P
+	while :; do
+		f2c -Ps -!c zap.[FP]
+		case $? in 4) ;; *) break;; esac
+		done
+
+to get a file zap.P of the best prototypes f2c can determine for *.f .
+
+Jan. 29 07:30:21 EST 1990:
+  Forgot to check for error status when setting return code 4 under -Ps;
+error status (1, 2, 3, or, for caught signal, 126) now takes precedence.
+
+Jan 29 14:17:00 EST 1990:
+  Incorrect handling of
+	open(n,'filename')
+repaired -- now treated as
+	open(n,file='filename')
+(and, under -ext, given an error message).
+  New optional source file memset.c for people whose systems don't
+provide memset, memcmp, and memcpy; #include <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.

+ 392 - 0
lang/fortran/index

@@ -0,0 +1,392 @@
+
+====== index for f2c ============
+
+FILES:
+
+f2c.h	Include file necessary for compiling output of the converter.
+	See the second NOTE below.
+
+f2c.1	Man page for f2c.
+
+f2c.1t	Source for f2c.1 (to be processed by troff -man or nroff -man).
+
+libf77	Library of non I/O support routines the generated C may need.
+	Fortran main programs result in a C function named MAIN__ that
+	is meant to be invoked by the main() in libf77.
+
+libi77	Library of Fortran I/O routines the generated C may need.
+	Note that some vendors (e.g., BSD, Sun and MIPS) provide a
+	libF77 and libI77 that are incompatible with f2c -- they
+	provide some differently named routines or routines with the
+	names that f2c expects, but with different calling sequences.
+	On such systems, the recommended procedure is to merge
+	libf77 and libi77 into a single library, say libf2c, to install
+	it where you can access it by specifying -lf2c , and to adjust
+	the definition of link_msg in sysdep.c appropriately.
+
+f2c.ps	Postscript for a technical report on f2c.  After you strip the
+	mail header, the first line should be "%!PS".
+
+fixes	The complete change log, reporting bug fixes and other changes.
+	(Some recent change-log entries are given below).
+
+fc	A shell script that uses f2c and imitates much of the behavior
+	of commonly found f77 commands.  You will almost certainly
+	need to adjust some of the shell-variable assignments to make
+	this script work on your system.
+
+
+SUBDIRECTORY:
+
+f2c/src	Source for the converter itself, including a file of checksums
+	and source for a program to compute the checksums (to verify
+	correct transmission of the source), is available: ask netlib to
+		send all from f2c/src
+	If the checksums show damage to just a few source files, or if
+	the change log file (see "fixes" below) reports corrections to
+	some source files, you can request those files individually
+	"from f2c/src".  For example, to get defs.h and xsum0.out, you
+	would ask netlib to
+		send defs.h xsum0.out from f2c/src
+	"all from f2c/src" is 649642 bytes long.
+
+	Tip: if asked to send over 99,000 bytes in one request, netlib
+	breaks the shipment into 1000 line pieces and sends each piece
+	separately (since otherwise some mailers might gag).  To avoid
+	the hassle of reassembling the pieces, try to keep each request
+	under 99,000 bytes long.  The final number in each line of
+	xsum0.out gives the length of each file in f2c/src.  For
+	example,
+		send exec.c expr.c from f2c/src
+		send format.c format_data.c from f2c/src
+	will give you slightly less hassle than
+		send exec.c expr.c format.c format_data.c from f2c/src
+
+	If you have trouble generating gram.c, you can ask netlib to
+		send gram.c from f2c/src
+	Then `xsum gram.c` should report
+		gram.c	efa337b3	57282
+
+NOTE:	For now, you may exercise f2c by sending netlib a message whose
+	first line is "execute f2c" and whose remaining lines are
+	the Fortran 77 source that you wish to have converted.
+	Return mail brings you the resulting C, with f2c's error
+	messages between #ifdef uNdEfInEd and #endif at the end.
+	(To understand line numbers in the error messages, regard
+	the "execute f2c" line as line 0.  It is stripped away by
+	the netlib software before f2c sees your Fortran input.)
+	Options described in the man page may be transmitted to
+	netlib by having the first line of input be a comment
+	whose first 6 characters are "c$f2c " and whose remaining
+	characters are the desired options, e.g., "c$f2c -R -u".
+	This scheme may change -- ask netlib to
+               send index from f2c
+        if you do not get the behavior you expect.
+
+	During the initial experimental period, incoming Fortran
+	will be saved in a file.  Don't send any secrets!
+
+
+BUGS:	Please send bug reports (including the shortest example
+	you can find that illustrates the bug) to research!dmg
+	or dmg@research.att.com .  You might first check whether
+	the bug goes away when you turn optimization off.
+
+
+NOTE:	f2c.h defines several types, e.g., real, integer, doublereal.
+	The definitions in f2c.h are suitable for most machines, but if
+	your machine has sizeof(double) > 2*sizeof(long), you may need
+	to adjust f2c.h appropriately.  f2c assumes
+		sizeof(doublecomplex) = 2*sizeof(doublereal)
+		sizeof(doublereal) = sizeof(complex)
+		sizeof(doublereal) = 2*sizeof(real)
+		sizeof(real) = sizeof(integer)
+		sizeof(real) = sizeof(logical)
+		sizeof(real) = 2*sizeof(shortint)
+	EQUIVALENCEs may not be translated correctly if these
+	assumptions are violated.
+
+	There exists a C compiler that objects to the lines
+		typedef VOID C_f;	/* complex function */
+		typedef VOID H_f;	/* character function */
+		typedef VOID Z_f;	/* double complex function */
+	in f2c.h .  If yours is such a compiler, do two things:
+	1. Complain to your vendor about this compiler bug.
+	2. Find the line
+		#define VOID void
+	   in f2c.h and change it to
+		#define VOID int
+	(For readability, the f2c.h lines shown above have had two
+	tabs inserted before their first character.)
+
+FTP:	All the material described above is now available by ftp from
+	research.att.com (login: netlib; Password: your E-mail address;
+	cd f2c).  You must uncompress the .Z files once you have a
+	copy of them, e.g., by
+		uncompress *.Z
+
+-----------------
+Recent change log (partial)
+-----------------
+
+Tue Jan 15 12:00:24 EST 1991:
+  Fix bug when two equivalence groups are merged, the second with
+nonzero offset, and the result is then merged into a common block.
+Example:
+      INTEGER W(3), X(3), Y(3), Z(3)
+      COMMON /ZOT/ Z
+      EQUIVALENCE (W(1),X(1)), (X(2),Y(1)), (Z(3),X(1))
+***** W WAS GIVEN THE WRONG OFFSET
+  Recognize Fortran 90's optional NML= in NAMELIST READs and WRITEs.
+(Currently NML= and FMT= are treated as synonyms -- there's no
+error message if, e.g., NML= specifies a format.)
+  libi77: minor adjustment to allow internal READs from character
+string constants in read-only memory.
+
+Wed Jan 23 00:38:48 EST 1991:
+  Allow hex, octal, and binary constants to have the qualifying letter
+(z, x, o, or b) either before or after the quoted string containing the
+digits.  For now this change will not be reflected in f2c.ps .
+
+Tue Jan 29 16:23:45 EST 1991:
+  Arrange for character-valued statement functions to give results of
+the right length (that of the statement function's name).
+
+Wed Jan 30 07:05:32 EST 1991:
+  More tweaks for character-valued statement functions: an error
+check and an adjustment so a right-hand side of nonconstant length
+(e.g., a substring) is handled right.
+
+Thu Jan 31 13:53:44 EST 1991:
+  Add a test after the cleanup call generated for I/O statements with
+ERR= or END= clauses to catch the unlikely event that the cleanup
+routine encounters an error.
+
+Tue Feb  5 01:39:36 EST 1991:
+  Change Mktemp to mktmp (for the benefit of systems so brain-damaged
+that they do not distinguish case in external names -- and that for
+some reason want to load mktemp).  Try to get xsum0.out right this
+time (it somehow didn't get updated on 4 Feb. 1991).
+  Add note to libi77/README about adjusting the interpretation of
+RECL= specifiers in OPENs for direct unformatted I/O.
+
+Thu Feb  7 17:24:42 EST 1991:
+  New option -r casts values of REAL functions, including intrinsics,
+to REAL.  This only matters for unportable code like
+	real r
+	r = asin(1.)
+	if (r .eq. asin(1.)) ...
+[The behavior of such code varies with the Fortran compiler used --
+and sometimes is affected by compiler options.]  For now, the man page
+at the end of f2c.ps is the only part of f2c.ps that reflects this new
+option.
+
+Fri Feb  8 18:12:51 EST 1991:
+  Cast pointer differences passed as arguments to the appropriate type.
+This matters, e.g., with MSDOS compilers that yield a long pointer
+difference but have int == short.
+  Disallow nonpositive dimensions.
+
+Fri Feb 15 12:24:15 EST 1991:
+  Change %d to %ld in sprintf call in putpower in putpcc.c.
+  Free more memory (e.g. allowing translation of larger Fortran
+files under MS-DOS).
+  Recognize READ (character expression)
+as formatted I/O with the format given by the character expression.
+  Update year in Notice.
+
+Mon Mar  4 15:19:42 EST 1991:
+  Fix bug in passing the real part of a complex argument to an intrinsic
+function.  Omit unneeded parentheses in nested calls to intrinsics.
+Example:
+	subroutine foo(x, y)
+	complex y
+	x = exp(sin(real(y))) + exp(imag(y))
+	end
+
+Fri Mar  8 15:05:42 EST 1991:
+  Fix a comment in expr.c; omit safstrncpy.c (which had bugs in
+cases not used by f2c).
+
+Wed Mar 13 02:27:23 EST 1991:
+  Initialize firstmemblock->next in mem_init in mem.c .  [On most
+systems it was fortuituously 0, but with System V, -lmalloc could
+trip on this missed initialization.]
+
+Wed Mar 13 11:47:42 EST 1991:
+  Fix a reference to freed memory.
+
+Wed Mar 27 00:42:19 EST 1991:
+  Fix a memory fault caused by such illegal Fortran as
+       function foo
+       x = 3
+       logical foo	! declaration among executables
+       foo=.false.	! used to suffer memory fault
+       end
+
+Fri Apr  5 08:30:31 EST 1991:
+  Fix loss of % in some format expressions, e.g.
+	write(*,'(1h%)')
+  Fix botch introduced 27 March 1991 that caused subroutines with
+multiple entry points to have extraneous declarations of ret_val.
+
+Fri Apr  5 12:44:02 EST 1991
+  Try again to omit extraneous ret_val declarations -- this morning's
+fix was sometimes wrong.
+
+Mon Apr  8 13:47:06 EDT 1991:
+  Arrange for s_rnge to have the right prototype under -A -C .
+
+Wed Apr 17 13:36:03 EDT 1991:
+  New fatal error message for apparent invocation of a recursive
+statement function.
+
+Thu Apr 25 15:13:37 EDT 1991:
+  F2c and libi77 adjusted so NAMELIST works with -i2.  (I forgot
+about -i2 when adding NAMELIST.)  This required a change to f2c.h
+(that only affects NAMELIST I/O under -i2.)  Man-page description of
+-i2 adjusted to reflect that -i2 stores array lengths in short ints.
+
+Fri Apr 26 02:54:41 EDT 1991:
+  Libi77: fix some bugs in NAMELIST reading of multi-dimensional arrays
+(file rsne.c).
+
+Tue May  7 09:04:48 EDT 1991:
+  gram.c added to f2c/src (for folks who have trouble generating it.  It
+is not in "all from f2c", nor in the list of current timestamps below.)
+
+Thu May  9 02:13:51 EDT 1991:
+  Omit a trailing space in expr.c (could cause a false xsum value if
+a mailer drops the trailing blank).
+
+Thu May 16 13:14:59 EDT 1991:
+  libi77: increase LEFBL in lio.h to overcome a NeXT bug.
+  Tweak for compilers that recognize "nested" comments: inside comments,
+turn /* into /+ (as well as */ into +/).
+
+Sat May 25 11:44:25 EDT 1991:
+  libf77: s_rnge: declare line long int rather than int.
+
+Fri May 31 07:51:50 EDT 1991:
+  libf77: system_: officially return status.
+
+Mon Jun 17 16:52:53 EDT 1991:
+  Minor tweaks: omit unnecessary declaration of strcmp (that caused
+trouble on a system where strcmp was a macro) from misc.c; add
+SHELL = /bin/sh to makefiles.
+  Fix a dereference of null when a CHARACTER*(*) declaration appears
+(illegally) after DATA.  Complain only once per subroutine about
+declarations appearing after DATA.
+
+Mon Jul  1 00:28:13 EDT 1991:
+  Add test and error message for illegal use of subroutine names, e.g.
+      SUBROUTINE ZAP(A)
+      ZAP = A
+      END
+
+Mon Jul  8 21:49:20 EDT 1991:
+  Issue a warning about things like
+	integer i
+	i = 'abc'
+(which is treated as i = ichar('a')).  [It might be nice to treat 'abc'
+as an integer initialized (in a DATA statement) with 'abc', but
+other matters have higher priority.]
+  Render
+	i = ichar('A')
+as
+	i = 'A';
+rather than
+	i = 65;
+(which assumes ASCII).
+
+Fri Jul 12 07:41:30 EDT 1991:
+  Note added to README about erroneous definitions of __STDC__ .
+
+Sat Jul 13 13:38:54 EDT 1991:
+  Fix bugs in double type convesions of complex values, e.g.
+sngl(real(...)) or dble(real(...)) (where ... is complex).
+
+Mon Jul 15 13:21:42 EDT 1991:
+  Fix bug introduced 8 July 1991 that caused erroneous warnings
+"ichar([first char. of] char. string) assumed for conversion to numeric"
+when a subroutine had an array of character strings as an argument.
+
+Wed Aug 28 01:12:17 EDT 1991:
+  Omit an unused function in format.c, an unused variable in proc.c .
+  Under -r8, promote complex to double complex (as the man page claims).
+
+Fri Aug 30 17:19:17 EDT 1991:
+  f2c.ps updated: slightly expand description of intrinsics and,or,xor,
+not; add mention of intrinsics lshift, rshift; add note about f2c
+accepting Fortran 90 inline comments (starting with !); update Cobalt
+Blue address.
+
+Tue Sep 17 07:17:33 EDT 1991:
+  libI77: err.c and open.c modified to use modes "rb" and "wb"
+when (f)opening unformatted files; README updated to point out
+that it may be necessary to change these modes to "r" and "w"
+on some non-ANSI systems.
+
+Current timestamps of files in "all from f2c/src", sorted by time,
+appear below (mm/dd/year hh:mm:ss).  To bring your source up to date,
+obtain source files with a timestamp later than the time shown in your
+version.c.  Note that the time shown in the current version.c is the
+timestamp of the source module that immediately follows version.c below:
+
+ 8/28/1991   0:29:01  xsum0.out
+ 8/28/1991   0:23:26  version.c
+ 8/28/1991   0:07:02  main.c
+ 8/28/1991   0:07:01  gram.dcl
+ 8/28/1991   0:07:01  expr.c
+ 8/28/1991   0:07:00  defs.h
+ 8/13/1991   9:06:09  format.c
+ 8/13/1991   9:04:25  proc.c
+ 7/13/1991  12:58:37  putpcc.c
+ 7/12/1991   7:25:33  README
+ 7/05/1991   7:16:57  intr.c
+ 6/17/1991  16:43:01  gram.head
+ 6/06/1991   0:41:56  makefile
+ 6/05/1991   8:34:09  misc.c
+ 5/16/1991  13:06:06  p1output.c
+ 4/25/1991  13:20:26  f2c.1
+ 4/25/1991  12:56:19  f2c.h
+ 4/25/1991  12:51:27  f2c.1t
+ 4/25/1991  12:10:22  io.c
+ 4/05/1991   7:43:45  mem.c
+ 3/13/1991  11:18:09  output.c
+ 3/08/1991  10:14:45  niceprintf.c
+ 2/15/1991  12:08:26  Notice
+ 2/08/1991  11:29:18  gram.exec
+ 2/08/1991  11:29:18  malloc.c
+ 2/05/1991   0:52:39  exec.c
+ 1/22/1991  19:25:10  lex.c
+ 1/15/1991   1:21:00  equiv.c
+12/16/1990  16:46:20  xsum.c
+12/07/1990  17:37:08  names.c
+11/30/1990   9:47:48  data.c
+ 7/26/1990  10:54:47  parse_args.c
+ 7/26/1990  10:44:26  parse.h
+ 6/19/1990   0:18:23  formatdata.c
+ 5/11/1990  14:17:04  error.c
+ 4/23/1990  17:35:47  sysdep.h
+ 4/23/1990  16:37:50  sysdep.c
+ 4/18/1990  12:25:19  init.c
+ 4/18/1990  12:25:19  pread.c
+ 4/18/1990  12:25:18  cds.c
+ 4/10/1990   0:00:38  put.c
+ 4/06/1990   0:00:57  gram.io
+ 4/05/1990  23:40:09  gram.expr
+ 3/27/1990  16:39:18  names.h
+ 3/27/1990  10:05:15  p1defs.h
+ 3/27/1990  10:05:14  defines.h
+ 2/25/1990   9:04:30  vax.c
+ 2/16/1990  10:37:27  tokens
+ 2/14/1990   2:00:20  format.h
+ 2/14/1990   1:38:46  output.h
+ 2/14/1990   0:54:06  iob.h
+ 2/03/1990   0:58:26  niceprintf.h
+ 1/29/1990  13:26:52  memset.c
+ 1/11/1990  18:02:51  ftypes.h
+ 1/07/1990   1:20:01  usignal.h
+11/27/1989   8:27:37  machdefs.h
+ 7/01/1989  11:59:44  pccdefs.h

+ 3 - 0
lang/fortran/lib/.distr

@@ -0,0 +1,3 @@
+LIST
+libF77
+libI77

+ 3 - 0
lang/fortran/lib/LIST

@@ -0,0 +1,3 @@
+LIST
+libF77
+libI77