1 /****************************************************************
2 Copyright 1990 by AT&T Bell Laboratories, Bellcore.
4 Permission to use, copy, modify, and distribute this software
5 and its documentation for any purpose and without fee is hereby
6 granted, provided that the above copyright notice appear in all
7 copies and that both that the copyright notice and this
8 permission notice and warranty disclaimer appear in supporting
9 documentation, and that the names of AT&T Bell Laboratories or
10 Bellcore or any of their entities not be used in advertising or
11 publicity pertaining to distribution of the software without
12 specific, written prior permission.
14 AT&T and Bellcore disclaim all warranties with regard to this
15 software, including all implied warranties of merchantability
16 and fitness. In no event shall AT&T or Bellcore be liable for
17 any special, indirect or consequential damages or any damages
18 whatsoever resulting from loss of use, data or profits, whether
19 in an action of contract, negligence or other tortious action,
20 arising out of or in connection with the use or performance of
22 ****************************************************************/
37 #define MAXINCLUDES 10
38 #define MAXLITERALS 200 /* Max number of constants in the literal
40 #define MAXTOKENLEN 302 /* length of longest token */
46 #define MAXLABLIST 125 /* Max number of labels in an alternate
49 /* These are the primary pointer types used in the compiler */
51 typedef union Expression *expptr, *tagptr;
52 typedef struct Chain *chainp;
53 typedef struct Addrblock *Addrp;
54 typedef struct Constblock *Constp;
55 typedef struct Exprblock *Exprp;
56 typedef struct Nameblock *Namep;
60 extern FILEP diagfile;
61 extern FILEP textfile;
63 extern FILEP c_file; /* output file for all functions; extern
64 declarations will have to be prepended */
65 extern FILEP pass1_file; /* Temp file to hold the function bodies
67 extern FILEP expr_file; /* Debugging file */
68 extern FILEP initfile; /* Intermediate data file pointer */
69 extern FILEP blkdfile; /* BLOCK DATA file */
71 extern int current_ftn_file;
73 extern char *blkdfname, *initfname, *sortfname;
74 extern long int headoffset; /* Since the header block requires data we
75 don't know about until AFTER each
76 function has been processed, we keep a
77 pointer to the current (dummy) header
78 block (at the top of the assembly file)
81 extern char main_alias[]; /* name given to PROGRAM psuedo-op */
82 extern char token [ ];
87 extern struct Labelblock *thislabel;
89 /* Used to allow runtime expansion of internal tables. In particular,
90 these values can exceed their associated constants */
98 extern flag nowarnflag;
99 extern flag ftn66flag; /* Generate warnings when weird f77
100 features are used (undeclared dummy
101 procedure, non-char initialized with
102 string, 1-dim subscript in EQUIV) */
103 extern flag no66flag; /* Generate an error when a generic
104 function (f77 feature) is used */
105 extern flag noextflag; /* Generate an error when an extension to
106 Fortran 77 is used (hex/oct/bin
107 constants, automatic, static, double
109 extern flag zflag; /* enable double complex intrinsics */
110 extern flag shiftcase;
111 extern flag undeftype;
112 extern flag shortsubs; /* Use short subscripts on arrays? */
113 extern flag onetripflag; /* if true, always execute DO loop body */
114 extern flag checksubs;
115 extern flag debugflag;
120 extern flag headerdone; /* True iff the current procedure's header
121 data has been written */
124 extern flag substars; /* True iff some formal parameter is an
126 extern int impltype[ ];
127 extern ftnint implleng[ ];
128 extern int implstg[ ];
130 extern int tyint, tyioint, tyreal;
131 extern int tylogical; /* TY____ of the implementation of logical.
132 This will be LONG unless '-2' is given
133 on the command line */
134 extern int type_choice[];
135 extern char *typename[];
137 extern int typesize[]; /* size (in bytes) of an object of each
138 type. Indexed by TY___ macros */
139 extern int typealign[];
140 extern int proctype; /* Type of return value in this procedure */
141 extern char * procname; /* External name of the procedure, or last ENTRY name */
142 extern int rtvlabel[ ]; /* Return value labels, indexed by TY___ macros */
143 extern Addrp retslot;
144 extern Addrp xretslot[];
145 extern int cxslot; /* Complex return argument slot (frame pointer offset)*/
146 extern int chslot; /* Character return argument slot (fp offset) */
147 extern int chlgslot; /* Argument slot for length of character buffer */
148 extern int procclass; /* Class of the current procedure: either CLPROC,
149 CLMAIN, CLBLOCK or CLUNKNOWN */
150 extern ftnint procleng; /* Length of function return value (e.g. char
151 string length). If this is -1, then the length is
152 not known at compile time */
153 extern int nentry; /* Number of entry points (other than the original
154 function call) into this procedure */
155 extern flag multitype; /* YES iff there is more than one return value
158 extern long lastiolabno;
159 extern int lastlabno;
160 extern int lastvarno;
161 extern int lastargslot; /* integer offset pointing to the next free
162 location for an argument to the current routine */
164 extern int autonum[]; /* for numbering
165 automatic variables, e.g. temporaries */
167 extern int ret0label;
168 extern int dorange; /* Number of the label which terminates
169 the innermost DO loop */
170 extern int regnum[ ]; /* Numbers of DO indicies named in
172 extern Namep regnamep[ ]; /* List of DO indicies in registers */
173 extern int maxregvar; /* number of elts in regnamep */
174 extern int highregvar; /* keeps track of the highest register
175 number used by DO index allocator */
176 extern int nregvar; /* count of DO indicies in registers */
178 extern chainp templist[];
180 extern chainp earlylabs;
181 extern chainp holdtemps;
182 extern struct Entrypoint *entries;
183 extern struct Rplblock *rpllist;
184 extern struct Chain *curdtp;
185 extern ftnint curdtelt;
186 extern chainp allargs; /* union of args in entries */
187 extern int nallargs; /* total number of args */
188 extern int nallchargs; /* total number of character args */
189 extern flag toomanyinit; /* True iff too many initializers in a
197 extern int eqvstart; /* offset to eqv number to guarantee uniqueness
198 and prevent <something> from going negative */
199 extern int nintnames;
201 /* Chain of tagged blocks */
206 char * datap; /* Tagged block */
209 extern chainp chains;
211 /* Recall that field is intended to hold four-bit characters */
213 /* This structure exists only to defeat the type checking */
221 expptr vleng; /* Expression for length of char string -
222 this may be a constant, or an argument
223 generated by mkarg() */
226 /* Control construct info (for do loops, else, etc) */
231 unsigned dostepsign:8; /* 0 - variable, 1 - pos, 2 - neg */
233 int ctlabels[4]; /* Control labels, defined below */
234 int dolabel; /* label marking end of this DO loop */
235 Namep donamep; /* DO index variable */
236 expptr domax; /* constant or temp variable holding MAX
237 loop value; or expr of while(expr) */
238 expptr dostep; /* expression */
241 #define endlabel ctlabels[0]
242 #define elselabel ctlabels[1]
243 #define dobodylabel ctlabels[1]
244 #define doposlabel ctlabels[2]
245 #define doneglabel ctlabels[3]
246 extern struct Ctlframe *ctls; /* Keeps info on DO and BLOCK IF
247 structures - this is the stack
249 extern struct Ctlframe *ctlstack; /* Pointer to current nesting
251 extern struct Ctlframe *lastctl; /* Point to end of
252 dynamically-allocated array */
264 /* External Symbols */
268 char *fextname; /* Fortran version of external name */
269 char *cextname; /* C version of external name */
270 field extstg; /* STG -- should be COMMON, UNKNOWN or EXT
272 unsigned extype:4; /* for transmitting type to output routines */
273 unsigned used_here:1; /* Boolean - true on the second pass
274 through a function if the block has
276 unsigned exused:1; /* Has been used (for help with error msgs
277 about externals typed differently in
278 different modules) */
279 unsigned exproto:1; /* type specified in a .P file */
280 unsigned extinit:1; /* Procedure has been defined,
281 or COMMON has DATA */
282 unsigned extseen:1; /* True if previously referenced */
283 chainp extp; /* List of identifiers in the common
284 block for this function, stored as
285 Namep (hash table pointers) */
286 chainp allextp; /* List of lists of identifiers; we keep one
287 list for each layout of this common block */
288 int curno; /* current number for this common block,
289 used for constructing appending _nnn
290 to the common block name */
291 int maxno; /* highest curno value for this common block */
296 typedef struct Extsym Extsym;
298 extern Extsym *extsymtab; /* External symbol table */
299 extern Extsym *nextext;
300 extern Extsym *lastext;
301 extern int complex_seen, dcomplex_seen;
303 /* Statement labels */
307 int labelno; /* Internal label */
308 unsigned blklevel:8; /* level of nesting , for branch-in-loop
311 unsigned fmtlabused:1;
312 unsigned labinacc:1; /* inaccessible? (i.e. has its scope
314 unsigned labdefined:1; /* YES or NO */
315 unsigned labtype:2; /* LAB{FORMAT,EXEC,etc} */
316 ftnint stateno; /* Original label */
317 char *fmtstring; /* format string */
320 extern struct Labelblock *labeltab; /* Label table - keeps track of
321 all labels, including undefined */
322 extern struct Labelblock *labtabend;
323 extern struct Labelblock *highlabtab;
325 /* Entry point list */
329 struct Entrypoint *entnextp;
330 Extsym *entryname; /* Name of this ENTRY */
332 int typelabel; /* Label for function exit; this
333 will return the proper type of
335 Namep enamep; /* External name */
338 /* Primitive block, or Primary block. This is a general template returned
339 by the parser, which will be interpreted in context. It is a template
340 for an identifier (variable name, function name), parenthesized
341 arguments (array subscripts, function parameters) and substring
348 Namep namep; /* Pointer to structure Nameblock */
349 struct Listblock *argsp;
350 expptr fcharp; /* first-char-index-pointer (in
352 expptr lcharp; /* last-char-index-pointer (in
362 extern struct Hashentry *hashtab; /* Hash table */
363 extern struct Hashentry *lasthash;
365 struct Intrpacked /* bits for intrinsic function description */
379 expptr vleng; /* length of character string, if applicable */
380 char *fvarname; /* name in the Fortran source */
381 char *cvarname; /* name in the resulting C */
382 chainp vlastdim; /* datap points to new_vars entry for the */
383 /* system variable, if any, storing the final */
384 /* dimension; we zero the datap if this */
385 /* variable is needed */
386 unsigned vprocclass:3; /* P____ macros - selects the varxptr
388 unsigned vdovar:1; /* "is it a DO variable?" for register
389 and multi-level loop checking */
390 unsigned vdcldone:1; /* "do I think I'm done?" - set when the
391 context is sufficient to determine its
393 unsigned vadjdim:1; /* "adjustable dimension?" - needed for
394 information about copies */
396 unsigned vimpldovar:1; /* used to prevent erroneous error messages
397 for variables used only in DATA stmt
399 unsigned vis_assigned:1;/* True if this variable has had some
400 label ASSIGNED to it; hence
401 varxptr.assigned_values is valid */
402 unsigned vimplstg:1; /* True if storage type is assigned implicitly;
403 this allows a COMMON variable to participate
404 in a DIMENSION before the COMMON declaration.
406 unsigned vcommequiv:1; /* True if EQUIVALENCEd onto STGCOMMON */
407 unsigned vfmt_asg:1; /* True if char *var_fmt needed */
408 unsigned vpassed:1; /* True if passed as a character-variable arg */
409 unsigned vknownarg:1; /* True if seen in a previous entry point */
410 unsigned visused:1; /* True if variable is referenced -- so we */
411 /* can omit variables that only appear in DATA */
412 unsigned vnamelist:1; /* Appears in a NAMELIST */
413 unsigned vimpltype:1; /* True if implicitly typed and not
414 invoked as a function or subroutine
415 (so we can consistently type procedures
416 declared external and passed as args
419 unsigned vtypewarned:1; /* so we complain just once about
420 changed types of external procedures */
421 unsigned vinftype:1; /* so we can restore implicit type to a
422 procedure if it is invoked as a function
423 after being given a different type by -it */
424 unsigned vinfproc:1; /* True if -it infers this to be a procedure */
425 unsigned vcalled:1; /* has been invoked */
426 unsigned vdimfinish:1; /* need to invoke dim_finish() */
428 /* The vardesc union below is used to store the number of an intrinsic
429 function (when vstg == STGINTR and vprocclass == PINTRINSIC), or to
430 store the index of this external symbol in extsymtab (when vstg ==
431 STGEXT and vprocclass == PEXTERNAL) */
434 int varno; /* Return variable for a function.
435 This is used when a function is
436 assigned a return value. Also
437 used to point to the COMMON
438 block, when this is a field of
439 that block. Also points to
440 EQUIV block when STGEQUIV */
441 struct Intrpacked intrdesc; /* bits for intrinsic function*/
443 struct Dimblock *vdim; /* points to the dimensions if they exist */
444 ftnint voffset; /* offset in a storage block (the variable
445 name will be "v.%d", voffset in a
446 common blck on the vax). Also holds
447 pointers for automatic variables. When
448 STGEQUIV, this is -(offset from array
451 chainp namelist; /* points to names in the NAMELIST,
452 if this is a NAMELIST name */
453 chainp vstfdesc; /* points to (formals, expr) pair */
454 chainp assigned_values; /* list of integers, each being a
455 statement label assigned to
456 this variable in the current function */
458 int argno; /* for multiple entries */
463 /* PARAMETER statements */
478 /* Expression block */
486 expptr vleng; /* in the case of a character expression, this
487 value is inherited from the children */
500 ftnint ci; /* Constant long integer */
504 #define ccp ccp1.ccp0
511 field vstg; /* vstg = 1 when using Const.cds */
513 union Constant Const;
526 /* Address block - this is the FINAL form of identifiers before being
527 sent to pass 2. We'll want to add the original identifier here so that it can
528 be preserved in the translation.
530 An example identifier is q.7. The "q" refers to the storage class
531 (field vstg), the 7 to the variable number (int memno). */
540 /* put union...user here so the beginning of an Addrblock
541 * is the same as a Constblock.
544 Namep name; /* contains a pointer into the hash table */
545 char ident[IDENT_LEN + 1]; /* C string form of identifier */
547 union Constant Const; /* Constant value */
551 } kludge; /* so we can distinguish string vs binary
552 * floating-point constants */
554 long memno; /* when vstg == STGCONST, this is the
555 numeric part of the assembler label
556 where the constant value is stored */
557 expptr memoffset; /* used in subscript computations, usually */
558 unsigned istemp:1; /* used in stack management of temporary
560 unsigned isarray:1; /* used to show that memoffset is
561 meaningful, even if zero */
562 unsigned ntempelt:10; /* for representing temporary arrays, as
564 unsigned dbl_builtin:1; /* builtin to be declared double */
565 unsigned charleng:1; /* so saveargtypes can get i/o calls right */
566 ftnint varleng; /* holds a copy of a constant length which
567 is stored in the vleng field (e.g.
568 a double is 8 bytes) */
569 int uname_tag; /* Tag describing which of the unions()
571 char *Field; /* field name when dereferencing a struct */
572 }; /* struct Addrblock */
575 /* Errorbock - placeholder for errors, to allow the compilation to
585 /* Implicit DO block, especially related to DATA statements. This block
586 keeps track of the compiler's location in the implicit DO while it's
587 running. In particular, the isactive and isbusy flags tell where
603 struct Chain *datalist;
607 /* Each of these components has a first field called tag. This union
608 exists just for allocation simplicity */
613 struct Addrblock addrblock;
614 struct Constblock constblock;
615 struct Errorblock errorblock;
616 struct Exprblock exprblock;
617 struct Headblock headblock;
618 struct Impldoblock impldoblock;
619 struct Listblock listblock;
620 struct Nameblock nameblock;
621 struct Paramblock paramblock;
622 struct Primblock primblock;
630 expptr nelt; /* This is NULL if the array is unbounded */
631 expptr baseoffset; /* a constant or local variable holding
632 the offset in this procedure */
633 expptr basexpr; /* expression for comuting the offset, if
634 it's not constant. If this is
635 non-null, the register named in
636 baseoffset will get initialized to this
637 value in the procedure's prolog */
640 expptr dimsize; /* constant or register holding the size
642 expptr dimexpr; /* as above in basexpr, this is an
643 expression for computing a variable
645 } dims[1]; /* Dimblocks are allocated with enough
646 space for this to become dims[ndim] */
650 /* Statement function identifier stack - this holds the name and value of
651 the parameters in a statement function invocation. For example,
658 generates a stack of depth 3, with <x 1>, <y 2>, <z 3> AT THE INVOCATION, NOT
661 struct Rplblock /* name replacement block */
663 struct Rplblock *rplnextp;
664 Namep rplnp; /* Name of the formal parameter */
665 expptr rplvp; /* Value of the actual parameter */
666 expptr rplxp; /* Initialization of temporary variable,
667 if required; else null */
668 int rpltag; /* Tag on the value of the actual param */
673 /* Equivalence block */
677 struct Eqvchain *equivs; /* List (Eqvchain) of primblocks
678 holding variable identifiers */
684 #define eqvleng eqvtop
686 extern struct Equivblock *eqvclass;
691 struct Eqvchain *eqvnextp;
694 struct Primblock *eqvlhs;
702 /* For allocation purposes only, and to keep lint quiet. In particular,
703 don't count on the tag being able to tell you which structure is used */
706 /* There is a tradition in Fortran that the compiler not generate the same
707 bit pattern more than is necessary. This structure is used to do just
708 that; if two integer constants have the same bit pattern, just generate
709 it once. This could be expanded to optimize without regard to type, by
710 removing the type check in putconst() */
715 short litnum; /* numeric part of the assembler
716 label for this constant value */
717 int lituse; /* usage count */
725 extern struct Literal litpool[ ];
726 extern int nliterals;
727 extern char Letters[];
728 #define letter(x) Letters[x]
731 /* popular functions with non integer return values */
735 char *varstr(), *nounder(), *addunder();
736 char *copyn(), *copys();
737 chainp hookup(), mkchain(), revchain();
743 struct Labelblock *mklabel(), *execlab();
744 Extsym *mkext(), *newentry();
745 expptr addrof(), call1(), call2(), call3(), call4();
746 Addrp builtin(), Mktemp(), mktmp0(), mktmpn(), autovar();
747 Addrp mkplace(), mkaddr(), putconst(), memversion();
748 expptr mkprim(), mklhs(), mkexpr(), mkconv(), mkfunct(), fixexpr(), fixtype();
749 expptr errnode(), mkaddcon(), mkintcon(), putcxop();
751 ftnint lmin(), lmax(), iarrlen();
752 void *memcpy(), *memset();
753 char *strcat(), *strcpy(), *strncpy();
754 char *dbconst(), *flconst();
756 void puteq (), putex1 ();
757 expptr putx (), putsteq (), putassign ();
759 extern int forcedouble; /* force real functions to double */
760 extern int doin_setbound; /* special handling for array bounds */
762 extern double atof();
763 extern char *cds(), *cpstring(), *dtos(), *gmem(), *mem(), *string_num();
764 extern char *c_type_decl();
765 extern char hextoi_tab[];
766 #define hextoi(x) hextoi_tab[(x) & 0xff]
767 extern char *casttypes[], *ftn_types[], *protorettypes[], *usedcasts[];
768 extern int Castargs, infertypes;
769 extern FILE *protofile;
770 extern void exit(), inferdcl(), protowrite(), save_argtypes();
771 extern char binread[], binwrite[], textread[], textwrite[];
772 extern char *wh_first, *wh_last, *wh_next;
773 extern void putwhile();