00001 /****************************************************************
00002 Copyright 1990 - 1996 by AT&T, Lucent Technologies and Bellcore.
00003 
00004 Permission to use, copy, modify, and distribute this software
00005 and its documentation for any purpose and without fee is hereby
00006 granted, provided that the above copyright notice appear in all
00007 copies and that both that the copyright notice and this
00008 permission notice and warranty disclaimer appear in supporting
00009 documentation, and that the names of AT&T, Bell Laboratories,
00010 Lucent or Bellcore or any of their entities not be used in
00011 advertising or publicity pertaining to distribution of the
00012 software without specific, written prior permission.
00013 
00014 AT&T, Lucent and Bellcore disclaim all warranties with regard to
00015 this software, including all implied warranties of
00016 merchantability and fitness.  In no event shall AT&T, Lucent or
00017 Bellcore be liable for any special, indirect or consequential
00018 damages or any damages whatsoever resulting from loss of use,
00019 data or profits, whether in an action of contract, negligence or
00020 other tortious action, arising out of or in connection with the
00021 use or performance of this software.
00022 ****************************************************************/
00023 
00024 #include "sysdep.h"
00025 
00026 #include "ftypes.h"
00027 #include "defines.h"
00028 #include "machdefs.h"
00029 
00030 #define MAXDIM 20
00031 #define MAXINCLUDES 10
00032 #define MAXLITERALS 200         /* Max number of constants in the literal
00033                                    pool */
00034 #define MAXCTL 20
00035 #define MAXHASH 401
00036 #define MAXSTNO 801
00037 #define MAXEXT 200
00038 #define MAXEQUIV 150
00039 #define MAXLABLIST 258          /* Max number of labels in an alternate
00040                                    return CALL or computed GOTO */
00041 #define MAXCONTIN 99            /* Max continuation lines */
00042 
00043 /* These are the primary pointer types used in the compiler */
00044 
00045 typedef union Expression *expptr, *tagptr;
00046 typedef struct Chain *chainp;
00047 typedef struct Addrblock *Addrp;
00048 typedef struct Constblock *Constp;
00049 typedef struct Exprblock *Exprp;
00050 typedef struct Nameblock *Namep;
00051 
00052 extern FILEP infile;
00053 extern FILEP diagfile;
00054 extern FILEP textfile;
00055 extern FILEP asmfile;
00056 extern FILEP c_file;            /* output file for all functions; extern
00057                                    declarations will have to be prepended */
00058 extern FILEP pass1_file;        /* Temp file to hold the function bodies
00059                                    read on pass 1 */
00060 extern FILEP expr_file;         /* Debugging file */
00061 extern FILEP initfile;          /* Intermediate data file pointer */
00062 extern FILEP blkdfile;          /* BLOCK DATA file */
00063 
00064 extern int current_ftn_file;
00065 extern int maxcontin;
00066 
00067 extern char *blkdfname, *initfname, *sortfname;
00068 extern long headoffset;         /* Since the header block requires data we
00069                                    don't know about until AFTER each
00070                                    function has been processed, we keep a
00071                                    pointer to the current (dummy) header
00072                                    block (at the top of the assembly file)
00073                                    here */
00074 
00075 extern char main_alias[];       /* name given to PROGRAM psuedo-op */
00076 extern char *token;
00077 extern int maxtoklen, toklen;
00078 extern long err_lineno, lineno;
00079 extern char *infname;
00080 extern int needkwd;
00081 extern struct Labelblock *thislabel;
00082 
00083 /* Used to allow runtime expansion of internal tables.  In particular,
00084    these values can exceed their associated constants */
00085 
00086 extern int maxctl;
00087 extern int maxequiv;
00088 extern int maxstno;
00089 extern int maxhash;
00090 extern int maxext;
00091 
00092 extern flag nowarnflag;
00093 extern flag ftn66flag;          /* Generate warnings when weird f77
00094                                    features are used (undeclared dummy
00095                                    procedure, non-char initialized with
00096                                    string, 1-dim subscript in EQUIV) */
00097 extern flag no66flag;           /* Generate an error when a generic
00098                                    function (f77 feature) is used */
00099 extern flag noextflag;          /* Generate an error when an extension to
00100                                    Fortran 77 is used (hex/oct/bin
00101                                    constants, automatic, static, double
00102                                    complex types) */
00103 extern flag zflag;              /* enable double complex intrinsics */
00104 extern flag shiftcase;
00105 extern flag undeftype;
00106 extern flag shortsubs;          /* Use short subscripts on arrays? */
00107 extern flag onetripflag;        /* if true, always execute DO loop body */
00108 extern flag checksubs;
00109 extern flag debugflag;
00110 extern int nerr;
00111 extern int nwarn;
00112 
00113 extern int parstate;
00114 extern flag headerdone;         /* True iff the current procedure's header
00115                                    data has been written */
00116 extern int blklevel;
00117 extern flag saveall;
00118 extern flag substars;           /* True iff some formal parameter is an
00119                                    asterisk */
00120 extern int impltype[ ];
00121 extern ftnint implleng[ ];
00122 extern int implstg[ ];
00123 
00124 extern int tycomplex, tyint, tyioint, tyreal;
00125 extern int tylog, tylogical;    /* TY____ of the implementation of   logical.
00126                                    This will be LONG unless '-2' is given
00127                                    on the command line */
00128 extern int type_choice[];
00129 extern char *typename[];
00130 
00131 extern int typesize[];  /* size (in bytes) of an object of each
00132                                    type.  Indexed by TY___ macros */
00133 extern int typealign[];
00134 extern int proctype;    /* Type of return value in this procedure */
00135 extern char * procname; /* External name of the procedure, or last ENTRY name */
00136 extern int rtvlabel[ ]; /* Return value labels, indexed by TY___ macros */
00137 extern Addrp retslot;
00138 extern Addrp xretslot[];
00139 extern int cxslot;      /* Complex return argument slot (frame pointer offset)*/
00140 extern int chslot;      /* Character return argument slot (fp offset) */
00141 extern int chlgslot;    /* Argument slot for length of character buffer */
00142 extern int procclass;   /* Class of the current procedure:  either CLPROC,
00143                            CLMAIN, CLBLOCK or CLUNKNOWN */
00144 extern ftnint procleng; /* Length of function return value (e.g. char
00145                            string length).  If this is -1, then the length is
00146                            not known at compile time */
00147 extern int nentry;      /* Number of entry points (other than the original
00148                            function call) into this procedure */
00149 extern flag multitype;  /* YES iff there is more than one return value
00150                            possible */
00151 extern int blklevel;
00152 extern long lastiolabno;
00153 extern long lastlabno;
00154 extern int lastvarno;
00155 extern int lastargslot; /* integer offset pointing to the next free
00156                            location for an argument to the current routine */
00157 extern int argloc;
00158 extern int autonum[];           /* for numbering
00159                                    automatic variables, e.g. temporaries */
00160 extern int retlabel;
00161 extern int ret0label;
00162 extern int dorange;             /* Number of the label which terminates
00163                                    the innermost DO loop */
00164 extern int regnum[ ];           /* Numbers of DO indicies named in
00165                                    regnamep   (below) */
00166 extern Namep regnamep[ ];       /* List of DO indicies in registers */
00167 extern int maxregvar;           /* number of elts in   regnamep   */
00168 extern int highregvar;          /* keeps track of the highest register
00169                                    number used by DO index allocator */
00170 extern int nregvar;             /* count of DO indicies in registers */
00171 
00172 extern chainp templist[];
00173 extern int maxdim;
00174 extern chainp earlylabs;
00175 extern chainp holdtemps;
00176 extern struct Entrypoint *entries;
00177 extern struct Rplblock *rpllist;
00178 extern struct Chain *curdtp;
00179 extern ftnint curdtelt;
00180 extern chainp allargs;          /* union of args in entries */
00181 extern int nallargs;            /* total number of args */
00182 extern int nallchargs;          /* total number of character args */
00183 extern flag toomanyinit;        /* True iff too many initializers in a
00184                                    DATA statement */
00185 
00186 extern flag inioctl;
00187 extern int iostmt;
00188 extern Addrp ioblkp;
00189 extern int nioctl;
00190 extern int nequiv;
00191 extern int eqvstart;    /* offset to eqv number to guarantee uniqueness
00192                            and prevent <something> from going negative */
00193 extern int nintnames;
00194 
00195 /* Chain of tagged blocks */
00196 
00197 struct Chain
00198         {
00199         chainp nextp;
00200         char * datap;           /* Tagged block */
00201         };
00202 
00203 extern chainp chains;
00204 
00205 /* Recall that   field   is intended to hold four-bit characters */
00206 
00207 /* This structure exists only to defeat the type checking */
00208 
00209 struct Headblock
00210         {
00211         field tag;
00212         field vtype;
00213         field vclass;
00214         field vstg;
00215         expptr vleng;           /* Expression for length of char string -
00216                                    this may be a constant, or an argument
00217                                    generated by mkarg() */
00218         } ;
00219 
00220 /* Control construct info (for do loops, else, etc) */
00221 
00222 struct Ctlframe
00223         {
00224         unsigned ctltype:8;
00225         unsigned dostepsign:8;  /* 0 - variable, 1 - pos, 2 - neg */
00226         unsigned dowhile:1;
00227         int ctlabels[4];        /* Control labels, defined below */
00228         int dolabel;            /* label marking end of this DO loop */
00229         Namep donamep;          /* DO index variable */
00230         expptr doinit;          /* for use with -onetrip */
00231         expptr domax;           /* constant or temp variable holding MAX
00232                                    loop value; or expr of while(expr) */
00233         expptr dostep;          /* expression */
00234         Namep loopname;
00235         };
00236 #define endlabel ctlabels[0]
00237 #define elselabel ctlabels[1]
00238 #define dobodylabel ctlabels[1]
00239 #define doposlabel ctlabels[2]
00240 #define doneglabel ctlabels[3]
00241 extern struct Ctlframe *ctls;           /* Keeps info on DO and BLOCK IF
00242                                            structures - this is the stack
00243                                            bottom */
00244 extern struct Ctlframe *ctlstack;       /* Pointer to current nesting
00245                                            level */
00246 extern struct Ctlframe *lastctl;        /* Point to end of
00247                                            dynamically-allocated array */
00248 
00249 typedef struct {
00250         int type;
00251         chainp cp;
00252         } Atype;
00253 
00254 typedef struct {
00255         int defined, dnargs, nargs, changes;
00256         Atype atypes[1];
00257         } Argtypes;
00258 
00259 /* External Symbols */
00260 
00261 struct Extsym
00262         {
00263         char *fextname;         /* Fortran version of external name */
00264         char *cextname;         /* C version of external name */
00265         field extstg;           /* STG -- should be COMMON, UNKNOWN or EXT
00266                                    */
00267         unsigned extype:4;      /* for transmitting type to output routines */
00268         unsigned used_here:1;   /* Boolean - true on the second pass
00269                                    through a function if the block has
00270                                    been referenced */
00271         unsigned exused:1;      /* Has been used (for help with error msgs
00272                                    about externals typed differently in
00273                                    different modules) */
00274         unsigned exproto:1;     /* type specified in a .P file */
00275         unsigned extinit:1;     /* Procedure has been defined,
00276                                    or COMMON has DATA */
00277         unsigned extseen:1;     /* True if previously referenced */
00278         chainp extp;            /* List of identifiers in the common
00279                                    block for this function, stored as
00280                                    Namep (hash table pointers) */
00281         chainp allextp;         /* List of lists of identifiers; we keep one
00282                                    list for each layout of this common block */
00283         int curno;              /* current number for this common block,
00284                                    used for constructing appending _nnn
00285                                    to the common block name */
00286         int maxno;              /* highest curno value for this common block */
00287         ftnint extleng;
00288         ftnint maxleng;
00289         Argtypes *arginfo;
00290         };
00291 typedef struct Extsym Extsym;
00292 
00293 extern Extsym *extsymtab;       /* External symbol table */
00294 extern Extsym *nextext;
00295 extern Extsym *lastext;
00296 extern int complex_seen, dcomplex_seen;
00297 
00298 /* Statement labels */
00299 
00300 struct Labelblock
00301         {
00302         int labelno;            /* Internal label */
00303         unsigned blklevel:8;    /* level of nesting, for branch-in-loop
00304                                    checking */
00305         unsigned labused:1;
00306         unsigned fmtlabused:1;
00307         unsigned labinacc:1;    /* inaccessible? (i.e. has its scope
00308                                    vanished) */
00309         unsigned labdefined:1;  /* YES or NO */
00310         unsigned labtype:2;     /* LAB{FORMAT,EXEC,etc} */
00311         ftnint stateno;         /* Original label */
00312         char *fmtstring;        /* format string */
00313         };
00314 
00315 extern struct Labelblock *labeltab;     /* Label table - keeps track of
00316                                            all labels, including undefined */
00317 extern struct Labelblock *labtabend;
00318 extern struct Labelblock *highlabtab;
00319 
00320 /* Entry point list */
00321 
00322 struct Entrypoint
00323         {
00324         struct Entrypoint *entnextp;
00325         Extsym *entryname;      /* Name of this ENTRY */
00326         chainp arglist;
00327         int typelabel;                  /* Label for function exit; this
00328                                            will return the proper type of
00329                                            object */
00330         Namep enamep;                   /* External name */
00331         };
00332 
00333 /* Primitive block, or Primary block.  This is a general template returned
00334    by the parser, which will be interpreted in context.  It is a template
00335    for an identifier (variable name, function name), parenthesized
00336    arguments (array subscripts, function parameters) and substring
00337    specifications. */
00338 
00339 struct Primblock
00340         {
00341         field tag;
00342         field vtype;
00343         unsigned parenused:1;           /* distinguish (a) from a */
00344         Namep namep;                    /* Pointer to structure Nameblock */
00345         struct Listblock *argsp;
00346         expptr fcharp;                  /* first-char-index-pointer (in
00347                                            substring) */
00348         expptr lcharp;                  /* last-char-index-pointer (in
00349                                            substring) */
00350         };
00351 
00352 
00353 struct Hashentry
00354         {
00355         int hashval;
00356         Namep varp;
00357         };
00358 extern struct Hashentry *hashtab;       /* Hash table */
00359 extern struct Hashentry *lasthash;
00360 
00361 struct Intrpacked       /* bits for intrinsic function description */
00362         {
00363         unsigned f1:4;
00364         unsigned f2:4;
00365         unsigned f3:7;
00366         unsigned f4:1;
00367         };
00368 
00369 struct Nameblock
00370         {
00371         field tag;
00372         field vtype;
00373         field vclass;
00374         field vstg;
00375         expptr vleng;           /* length of character string, if applicable */
00376         char *fvarname;         /* name in the Fortran source */
00377         char *cvarname;         /* name in the resulting C */
00378         chainp vlastdim;        /* datap points to new_vars entry for the */
00379                                 /* system variable, if any, storing the final */
00380                                 /* dimension; we zero the datap if this */
00381                                 /* variable is needed */
00382         unsigned vprocclass:3;  /* P____ macros - selects the   varxptr
00383                                    field below */
00384         unsigned vdovar:1;      /* "is it a DO variable?" for register
00385                                    and multi-level loop checking */
00386         unsigned vdcldone:1;    /* "do I think I'm done?" - set when the
00387                                    context is sufficient to determine its
00388                                    status */
00389         unsigned vadjdim:1;     /* "adjustable dimension?" - needed for
00390                                    information about copies */
00391         unsigned vsave:1;
00392         unsigned vimpldovar:1;  /* used to prevent erroneous error messages
00393                                    for variables used only in DATA stmt
00394                                    implicit DOs */
00395         unsigned vis_assigned:1;/* True if this variable has had some
00396                                    label ASSIGNED to it; hence
00397                                    varxptr.assigned_values is valid */
00398         unsigned vimplstg:1;    /* True if storage type is assigned implicitly;
00399                                    this allows a COMMON variable to participate
00400                                    in a DIMENSION before the COMMON declaration.
00401                                    */
00402         unsigned vcommequiv:1;  /* True if EQUIVALENCEd onto STGCOMMON */
00403         unsigned vfmt_asg:1;    /* True if char *var_fmt needed */
00404         unsigned vpassed:1;     /* True if passed as a character-variable arg */
00405         unsigned vknownarg:1;   /* True if seen in a previous entry point */
00406         unsigned visused:1;     /* True if variable is referenced -- so we */
00407                                 /* can omit variables that only appear in DATA */
00408         unsigned vnamelist:1;   /* Appears in a NAMELIST */
00409         unsigned vimpltype:1;   /* True if implicitly typed and not
00410                                    invoked as a function or subroutine
00411                                    (so we can consistently type procedures
00412                                    declared external and passed as args
00413                                    but never invoked).
00414                                    */
00415         unsigned vtypewarned:1; /* so we complain just once about
00416                                    changed types of external procedures */
00417         unsigned vinftype:1;    /* so we can restore implicit type to a
00418                                    procedure if it is invoked as a function
00419                                    after being given a different type by -it */
00420         unsigned vinfproc:1;    /* True if -it infers this to be a procedure */
00421         unsigned vcalled:1;     /* has been invoked */
00422         unsigned vdimfinish:1;  /* need to invoke dim_finish() */
00423         unsigned vrefused:1;    /* Need to #define name_ref (for -s) */
00424         unsigned vsubscrused:1; /* Need to #define name_subscr (for -2) */
00425         unsigned veqvadjust:1;  /* voffset has been adjusted for equivalence */
00426 
00427 /* The   vardesc   union below is used to store the number of an intrinsic
00428    function (when vstg == STGINTR and vprocclass == PINTRINSIC), or to
00429    store the index of this external symbol in   extsymtab   (when vstg ==
00430    STGEXT and vprocclass == PEXTERNAL) */
00431 
00432         union   {
00433                 int varno;              /* Return variable for a function.
00434                                            This is used when a function is
00435                                            assigned a return value.  Also
00436                                            used to point to the COMMON
00437                                            block, when this is a field of
00438                                            that block.  Also points to
00439                                            EQUIV block when STGEQUIV */
00440                 struct Intrpacked intrdesc;     /* bits for intrinsic function*/
00441                 } vardesc;
00442         struct Dimblock *vdim;  /* points to the dimensions if they exist */
00443         ftnint voffset;         /* offset in a storage block (the variable
00444                                    name will be "v.%d", voffset in a
00445                                    common blck on the vax).  Also holds
00446                                    pointers for automatic variables.  When
00447                                    STGEQUIV, this is -(offset from array
00448                                    base) */
00449         union   {
00450                 chainp namelist;        /* points to names in the NAMELIST,
00451                                            if this is a NAMELIST name */
00452                 chainp vstfdesc;        /* points to (formals, expr) pair */
00453                 chainp assigned_values; /* list of integers, each being a
00454                                            statement label assigned to
00455                                            this variable in the current function */
00456                 } varxptr;
00457         int argno;              /* for multiple entries */
00458         Argtypes *arginfo;
00459         };
00460 
00461 
00462 /* PARAMETER statements */
00463 
00464 struct Paramblock
00465         {
00466         field tag;
00467         field vtype;
00468         field vclass;
00469         field vstg;
00470         expptr vleng;
00471         char *fvarname;
00472         char *cvarname;
00473         expptr paramval;
00474         } ;
00475 
00476 
00477 /* Expression block */
00478 
00479 struct Exprblock
00480         {
00481         field tag;
00482         field vtype;
00483         field vclass;
00484         field vstg;
00485         expptr vleng;           /* in the case of a character expression, this
00486                                    value is inherited from the children */
00487         unsigned opcode;
00488         expptr leftp;
00489         expptr rightp;
00490         int typefixed;
00491         };
00492 
00493 
00494 union Constant
00495         {
00496         struct {
00497                 char *ccp0;
00498                 ftnint blanks;
00499                 } ccp1;
00500         ftnint ci;              /* Constant longeger */
00501         double cd[2];
00502         char *cds[2];
00503         };
00504 #define ccp ccp1.ccp0
00505 
00506 struct Constblock
00507         {
00508         field tag;
00509         field vtype;
00510         field vclass;
00511         field vstg;             /* vstg = 1 when using Const.cds */
00512         expptr vleng;
00513         union Constant Const;
00514         };
00515 
00516 
00517 struct Listblock
00518         {
00519         field tag;
00520         field vtype;
00521         chainp listp;
00522         };
00523 
00524 
00525 
00526 /* Address block - this is the FINAL form of identifiers before being
00527    sent to pass 2.  We'll want to add the original identifier here so that it can
00528    be preserved in the translation.
00529 
00530    An example identifier is q.7.  The "q" refers to the storage class
00531    (field vstg), the 7 to the variable number (int memno). */
00532 
00533 struct Addrblock
00534         {
00535         field tag;
00536         field vtype;
00537         field vclass;
00538         field vstg;
00539         expptr vleng;
00540         /* put union...user here so the beginning of an Addrblock
00541          * is the same as a Constblock.
00542          */
00543         union {
00544             Namep name;         /* contains a pointer into the hash table */
00545             char ident[IDENT_LEN + 1];  /* C string form of identifier */
00546             char *Charp;
00547             union Constant Const;       /* Constant value */
00548             struct {
00549                 double dfill[2];
00550                 field vstg1;
00551                 } kludge;       /* so we can distinguish string vs binary
00552                                  * floating-point constants */
00553         } user;
00554         long memno;             /* when vstg == STGCONST, this is the
00555                                    numeric part of the assembler label
00556                                    where the constant value is stored */
00557         expptr memoffset;       /* used in subscript computations, usually */
00558         unsigned istemp:1;      /* used in stack management of temporary
00559                                    variables */
00560         unsigned isarray:1;     /* used to show that memoffset is
00561                                    meaningful, even if zero */
00562         unsigned ntempelt:10;   /* for representing temporary arrays, as
00563                                    in concatenation */
00564         unsigned dbl_builtin:1; /* builtin to be declared double */
00565         unsigned charleng:1;    /* so saveargtypes can get i/o calls right */
00566         unsigned cmplx_sub:1;   /* used in complex arithmetic under -s */
00567         unsigned skip_offset:1; /* used in complex arithmetic under -s */
00568         unsigned parenused:1;   /* distinguish (a) from a */
00569         ftnint varleng;         /* holds a copy of a constant length which
00570                                    is stored in the   vleng   field (e.g.
00571                                    a double is 8 bytes) */
00572         int uname_tag;          /* Tag describing which of the unions()
00573                                    below to use */
00574         char *Field;            /* field name when dereferencing a struct */
00575 }; /* struct Addrblock */
00576 
00577 
00578 /* Errorbock - placeholder for errors, to allow the compilation to
00579    continue */
00580 
00581 struct Errorblock
00582         {
00583         field tag;
00584         field vtype;
00585         };
00586 
00587 
00588 /* Implicit DO block, especially related to DATA statements.  This block
00589    keeps track of the compiler's location in the implicit DO while it's
00590    running.  In particular, the   isactive and isbusy   flags tell where
00591    it is */
00592 
00593 struct Impldoblock
00594         {
00595         field tag;
00596         unsigned isactive:1;
00597         unsigned isbusy:1;
00598         Namep varnp;
00599         Constp varvp;
00600         chainp impdospec;
00601         expptr implb;
00602         expptr impub;
00603         expptr impstep;
00604         ftnint impdiff;
00605         ftnint implim;
00606         struct Chain *datalist;
00607         };
00608 
00609 
00610 /* Each of these components has a first field called   tag.   This union
00611    exists just for allocation simplicity */
00612 
00613 union Expression
00614         {
00615         field tag;
00616         struct Addrblock addrblock;
00617         struct Constblock constblock;
00618         struct Errorblock errorblock;
00619         struct Exprblock exprblock;
00620         struct Headblock headblock;
00621         struct Impldoblock impldoblock;
00622         struct Listblock listblock;
00623         struct Nameblock nameblock;
00624         struct Paramblock paramblock;
00625         struct Primblock primblock;
00626         } ;
00627 
00628 
00629 
00630 struct Dimblock
00631         {
00632         int ndim;
00633         expptr nelt;            /* This is NULL if the array is unbounded */
00634         expptr baseoffset;      /* a constant or local variable holding
00635                                    the offset in this procedure */
00636         expptr basexpr;         /* expression for comuting the offset, if
00637                                    it's not constant.  If this is
00638                                    non-null, the register named in
00639                                    baseoffset will get initialized to this
00640                                    value in the procedure's prolog */
00641         struct
00642                 {
00643                 expptr dimsize; /* constant or register holding the size
00644                                    of this dimension */
00645                 expptr dimexpr; /* as above in basexpr, this is an
00646                                    expression for computing a variable
00647                                    dimension */
00648                 } dims[1];      /* Dimblocks are allocated with enough
00649                                    space for this to become dims[ndim] */
00650         };
00651 
00652 
00653 /* Statement function identifier stack - this holds the name and value of
00654    the parameters in a statement function invocation.  For example,
00655 
00656         f(x,y,z)=x+y+z
00657                 .
00658                 .
00659         y = f(1,2,3)
00660 
00661    generates a stack of depth 3, with <x 1>, <y 2>, <z 3> AT THE INVOCATION, NOT
00662    at the definition */
00663 
00664 struct Rplblock /* name replacement block */
00665         {
00666         struct Rplblock *rplnextp;
00667         Namep rplnp;            /* Name of the formal parameter */
00668         expptr rplvp;           /* Value of the actual parameter */
00669         expptr rplxp;           /* Initialization of temporary variable,
00670                                    if required; else null */
00671         int rpltag;             /* Tag on the value of the actual param */
00672         };
00673 
00674 
00675 
00676 /* Equivalence block */
00677 
00678 struct Equivblock
00679         {
00680         struct Eqvchain *equivs;        /* List (Eqvchain) of primblocks
00681                                            holding variable identifiers */
00682         flag eqvinit;
00683         long eqvtop;
00684         long eqvbottom;
00685         int eqvtype;
00686         } ;
00687 #define eqvleng eqvtop
00688 
00689 extern struct Equivblock *eqvclass;
00690 
00691 
00692 struct Eqvchain
00693         {
00694         struct Eqvchain *eqvnextp;
00695         union
00696                 {
00697                 struct Primblock *eqvlhs;
00698                 Namep eqvname;
00699                 } eqvitem;
00700         long eqvoffset;
00701         } ;
00702 
00703 
00704 
00705 /* For allocation purposes only, and to keep lint quiet.  In particular,
00706    don't count on the tag being able to tell you which structure is used */
00707 
00708 
00709 /* There is a tradition in Fortran that the compiler not generate the same
00710    bit pattern more than is necessary.  This structure is used to do just
00711    that; if two integer constants have the same bit pattern, just generate
00712    it once.  This could be expanded to optimize without regard to type, by
00713    removing the type check in   putconst()   */
00714 
00715 struct Literal
00716         {
00717         short littype;
00718         short lituse;           /* usage count */
00719         long litnum;                    /* numeric part of the assembler
00720                                            label for this constant value */
00721         union   {
00722                 ftnint litival;
00723                 double litdval[2];
00724                 ftnint litival2[2];     /* length, nblanks for strings */
00725                 } litval;
00726         char *cds[2];
00727         };
00728 
00729 extern struct Literal *litpool;
00730 extern int maxliterals, nliterals;
00731 extern char Letters[];
00732 #define letter(x) Letters[x]
00733 
00734 struct Dims { expptr lb, ub; };
00735 
00736 extern int forcedouble;         /* force real functions to double */
00737 extern int doin_setbound;       /* special handling for array bounds */
00738 extern int Ansi;
00739 extern char hextoi_tab[];
00740 #define hextoi(x) hextoi_tab[(x) & 0xff]
00741 extern char *casttypes[], *ftn_types[], *protorettypes[], *usedcasts[];
00742 extern int Castargs, infertypes;
00743 extern FILE *protofile;
00744 extern char binread[], binwrite[], textread[], textwrite[];
00745 extern char *ei_first, *ei_last, *ei_next;
00746 extern char *wh_first, *wh_last, *wh_next;
00747 extern char *halign, *outbuf, *outbtail;
00748 extern flag keepsubs;
00749 #ifdef TYQUAD
00750 extern flag use_tyquad;
00751 #endif
00752 extern int n_keywords;
00753 extern char *c_keywords[];
00754 
00755 #ifdef KR_headers
00756 #define Argdcl(x) ()
00757 #define Void /* void */
00758 #else
00759 #define Argdcl(x) x
00760 #define Void void
00761 #endif
00762 
00763 char*   Alloc Argdcl((int));
00764 char*   Argtype Argdcl((int, char*));
00765 void    Fatal Argdcl((char*));
00766 struct  Impldoblock* mkiodo Argdcl((chainp, chainp));
00767 tagptr  Inline Argdcl((int, int, chainp));
00768 struct  Labelblock* execlab Argdcl((long));
00769 struct  Labelblock* mklabel Argdcl((long));
00770 struct  Listblock* mklist Argdcl((chainp));
00771 void    Un_link_all Argdcl((int));
00772 void    add_extern_to_list Argdcl((Addrp, chainp*));
00773 int     addressable Argdcl((tagptr));
00774 tagptr  addrof Argdcl((tagptr));
00775 char*   addunder Argdcl((char*));
00776 Addrp   autovar Argdcl((int, int, tagptr, char*));
00777 void    backup Argdcl((char*, char*));
00778 void    bad_atypes Argdcl((Argtypes*, char*, int, int, int, char*, char*));
00779 int     badchleng Argdcl((tagptr));
00780 void    badop Argdcl((char*, int));
00781 void    badstg Argdcl((char*, int));
00782 void    badtag Argdcl((char*, int));
00783 void    badthing Argdcl((char*, char*, int));
00784 void    badtype Argdcl((char*, int));
00785 Addrp   builtin Argdcl((int, char*, int));
00786 char*   c_name Argdcl((char*, int));
00787 tagptr  call0 Argdcl((int, char*));
00788 tagptr  call1 Argdcl((int, char*, tagptr));
00789 tagptr  call2 Argdcl((int, char*, tagptr, tagptr));
00790 tagptr  call3 Argdcl((int, char*, tagptr, tagptr, tagptr));
00791 tagptr  call4 Argdcl((int, char*, tagptr, tagptr, tagptr, tagptr));
00792 tagptr  callk Argdcl((int, char*, chainp));
00793 void    cast_args Argdcl((int, chainp));
00794 char*   cds Argdcl((char*, char*));
00795 void    changedtype Argdcl((Namep));
00796 ptr     ckalloc Argdcl((int));
00797 int     cktype Argdcl((int, int, int));
00798 void    clf Argdcl((FILEP*, char*, int));
00799 int     cmpstr Argdcl((char*, char*, long, long));
00800 char*   c_type_decl Argdcl((int, int));
00801 Extsym* comblock Argdcl((char*));
00802 char*   comm_union_name Argdcl((int));
00803 void    consconv Argdcl((int, Constp, Constp));
00804 void    consnegop Argdcl((Constp));
00805 int     conssgn Argdcl((tagptr));
00806 char*   convic Argdcl((long));
00807 void    copy_data Argdcl((chainp));
00808 char*   copyn Argdcl((int, char*));
00809 char*   copys Argdcl((char*));
00810 tagptr  cpblock Argdcl((int, char*));
00811 tagptr  cpexpr Argdcl((tagptr));
00812 void    cpn Argdcl((int, char*, char*));
00813 char*   cpstring Argdcl((char*));
00814 void    dataline Argdcl((char*, long, int));
00815 char*   dataname Argdcl((int, long));
00816 void    dataval Argdcl((tagptr, tagptr));
00817 void    dclerr Argdcl((char*, Namep));
00818 void    def_commons Argdcl((FILEP));
00819 void    def_start Argdcl((FILEP, char*, char*, char*));
00820 void    deregister Argdcl((Namep));
00821 void    do_uninit_equivs Argdcl((FILEP, ptr));
00822 void    doequiv(Void);
00823 int     dofork(Void);
00824 void    doinclude Argdcl((char*));
00825 void    doio Argdcl((chainp));
00826 void    done Argdcl((int));
00827 void    donmlist(Void);
00828 int     dsort Argdcl((char*, char*));
00829 char*   dtos Argdcl((double));
00830 void    elif_out Argdcl((FILEP, tagptr));
00831 void    end_else_out Argdcl((FILEP));
00832 void    enddcl(Void);
00833 void    enddo Argdcl((int));
00834 void    endio(Void);
00835 void    endioctl(Void);
00836 void    endproc(Void);
00837 void    entrypt Argdcl((int, int, long, Extsym*, chainp));
00838 int     eqn Argdcl((int, char*, char*));
00839 char*   equiv_name Argdcl((int, char*));
00840 void    err Argdcl((char*));
00841 void    err66 Argdcl((char*));
00842 void    errext Argdcl((char*));
00843 void    erri Argdcl((char*, int));
00844 void    errl Argdcl((char*, long));
00845 tagptr  errnode(Void);
00846 void    errstr Argdcl((char*, char*));
00847 void    exarif Argdcl((tagptr, struct Labelblock*, struct Labelblock*, struct Labelblock*));
00848 void    exasgoto Argdcl((Namep));
00849 void    exassign Argdcl((Namep, struct Labelblock*));
00850 void    excall Argdcl((Namep, struct Listblock*, int, struct Labelblock**));
00851 void    exdo Argdcl((int, Namep, chainp));
00852 void    execerr Argdcl((char*, char*));
00853 void    exelif Argdcl((tagptr));
00854 void    exelse(Void);
00855 void    exenddo Argdcl((Namep));
00856 void    exendif(Void);
00857 void    exequals Argdcl((struct Primblock*, tagptr));
00858 void    exgoto Argdcl((struct Labelblock*));
00859 void    exif Argdcl((tagptr));
00860 void    exreturn Argdcl((tagptr));
00861 void    exstop Argdcl((int, tagptr));
00862 void    extern_out Argdcl((FILEP, Extsym*));
00863 void    fatali Argdcl((char*, int));
00864 void    fatalstr Argdcl((char*, char*));
00865 void    ffilecopy Argdcl((FILEP, FILEP));
00866 void    fileinit(Void);
00867 int     fixargs Argdcl((int, struct Listblock*));
00868 tagptr  fixexpr Argdcl((Exprp));
00869 tagptr  fixtype Argdcl((tagptr));
00870 char*   flconst Argdcl((char*, char*));
00871 void    flline(Void);
00872 void    fmt_init(Void);
00873 void    fmtname Argdcl((Namep, Addrp));
00874 int     fmtstmt Argdcl((struct Labelblock*));
00875 tagptr  fold Argdcl((tagptr));
00876 void    frchain Argdcl((chainp*));
00877 void    frdata Argdcl((chainp));
00878 void    freetemps(Void);
00879 void    freqchain Argdcl((struct Equivblock*));
00880 void    frexchain Argdcl((chainp*));
00881 void    frexpr Argdcl((tagptr));
00882 void    frrpl(Void);
00883 void    frtemp Argdcl((Addrp));
00884 char*   gmem Argdcl((int, int));
00885 void    hashclear(Void);
00886 chainp  hookup Argdcl((chainp, chainp));
00887 expptr  imagpart Argdcl((Addrp));
00888 void    impldcl Argdcl((Namep));
00889 int     in_vector Argdcl((char*, char**, int));
00890 void    incomm Argdcl((Extsym*, Namep));
00891 void    inferdcl Argdcl((Namep, int));
00892 int     inilex Argdcl((char*));
00893 void    initkey(Void);
00894 int     inregister Argdcl((Namep));
00895 long    int commlen Argdcl((chainp));
00896 long    int convci Argdcl((int, char*));
00897 long    int iarrlen Argdcl((Namep));
00898 long    int lencat Argdcl((expptr));
00899 long    int lmax Argdcl((long, long));
00900 long    int lmin Argdcl((long, long));
00901 long    int wr_char_len Argdcl((FILEP, struct Dimblock*, int, int));
00902 Addrp   intraddr Argdcl((Namep));
00903 tagptr  intrcall Argdcl((Namep, struct Listblock*, int));
00904 int     intrfunct Argdcl((char*));
00905 void    ioclause Argdcl((int, expptr));
00906 int     iocname(Void);
00907 int     is_negatable Argdcl((Constp));
00908 int     isaddr Argdcl((tagptr));
00909 int     isnegative_const Argdcl((Constp));
00910 int     isstatic Argdcl((tagptr));
00911 chainp  length_comp Argdcl((struct Entrypoint*, int));
00912 int     lengtype Argdcl((int, long));
00913 char*   lexline Argdcl((ptr));
00914 void    list_arg_types Argdcl((FILEP, struct Entrypoint*, chainp, int, char*));
00915 void    list_decls Argdcl((FILEP));
00916 void    list_init_data Argdcl((FILE **, char *, FILE *));
00917 void    listargs Argdcl((FILEP, struct Entrypoint*, int, chainp));
00918 char*   lit_name Argdcl((struct Literal*));
00919 int     log_2 Argdcl((long));
00920 char*   lower_string Argdcl((char*, char*));
00921 int     main Argdcl((int, char**));
00922 expptr  make_int_expr Argdcl((expptr));
00923 void    make_param Argdcl((struct Paramblock*, tagptr));
00924 void    many Argdcl((char*, char, int));
00925 void    margin_printf Argdcl((FILEP, char*, ...));
00926 int     maxtype Argdcl((int, int));
00927 char*   mem Argdcl((int, int));
00928 void    mem_init(Void);
00929 char*   memname Argdcl((int, long));
00930 Addrp   memversion Argdcl((Namep));
00931 tagptr  mkaddcon Argdcl((long));
00932 Addrp   mkaddr Argdcl((Namep));
00933 Addrp   mkarg Argdcl((int, int));
00934 tagptr  mkbitcon Argdcl((int, int, char*));
00935 chainp  mkchain Argdcl((char*, chainp));
00936 Constp  mkconst Argdcl((int));
00937 tagptr  mkconv Argdcl((int, tagptr));
00938 tagptr  mkcxcon Argdcl((tagptr, tagptr));
00939 tagptr  mkexpr Argdcl((int, tagptr, tagptr));
00940 Extsym* mkext Argdcl((char*, char*));
00941 Extsym* mkext1 Argdcl((char*, char*));
00942 Addrp   mkfield Argdcl((Addrp, char*, int));
00943 tagptr  mkfunct Argdcl((tagptr));
00944 tagptr  mkintcon Argdcl((long));
00945 tagptr  mklhs Argdcl((struct Primblock*, int));
00946 tagptr  mklogcon Argdcl((int));
00947 Namep   mkname Argdcl((char*));
00948 Addrp   mkplace Argdcl((Namep));
00949 tagptr  mkprim Argdcl((Namep, struct Listblock*, chainp));
00950 tagptr  mkrealcon Argdcl((int, char*));
00951 Addrp   mkscalar Argdcl((Namep));
00952 void    mkstfunct Argdcl((struct Primblock*, tagptr));
00953 tagptr  mkstrcon Argdcl((int, char*));
00954 Addrp   mktmp Argdcl((int, tagptr));
00955 Addrp   mktmp0 Argdcl((int, tagptr));
00956 Addrp   mktmpn Argdcl((int, int, tagptr));
00957 void    namelist Argdcl((Namep));
00958 int     ncat Argdcl((expptr));
00959 void    negate_const Argdcl((Constp));
00960 void    new_endif(Void);
00961 Extsym* newentry Argdcl((Namep, int));
00962 long    newlabel(Void);
00963 void    newproc(Void);
00964 Addrp   nextdata Argdcl((long*));
00965 void    nice_printf Argdcl((FILEP, char*, ...));
00966 void    not_both Argdcl((char*));
00967 void    np_init(Void);
00968 int     oneof_stg Argdcl((Namep, int, int));
00969 int     op_assign Argdcl((int));
00970 tagptr  opconv Argdcl((tagptr, int));
00971 FILEP   opf Argdcl((char*, char*));
00972 void    out_addr Argdcl((FILEP, Addrp));
00973 void    out_asgoto Argdcl((FILEP, tagptr));
00974 void    out_call Argdcl((FILEP, int, int, tagptr, tagptr, tagptr));
00975 void    out_const Argdcl((FILEP, Constp));
00976 void    out_else Argdcl((FILEP));
00977 void    out_for Argdcl((FILEP, tagptr, tagptr, tagptr));
00978 void    out_init(Void);
00979 void    outbuf_adjust(Void);
00980 void    p1_label Argdcl((long));
00981 void    prcona Argdcl((FILEP, long));
00982 void    prconi Argdcl((FILEP, long));
00983 void    prconr Argdcl((FILEP, Constp, int));
00984 void    procinit(Void);
00985 void    procode Argdcl((FILEP));
00986 void    prolog Argdcl((FILEP, chainp));
00987 void    protowrite Argdcl((FILEP, int, char*, struct Entrypoint*, chainp));
00988 expptr  prune_left_conv Argdcl((expptr));
00989 int     put_one_arg Argdcl((int, char*, char**, char*, char*));
00990 expptr  putassign Argdcl((expptr, expptr));
00991 Addrp   putchop Argdcl((tagptr));
00992 void    putcmgo Argdcl((tagptr, int, struct Labelblock**));
00993 Addrp   putconst Argdcl((Constp));
00994 tagptr  putcxop Argdcl((tagptr));
00995 void    puteq Argdcl((expptr, expptr));
00996 void    putexpr Argdcl((expptr));
00997 void    puthead Argdcl((char*, int));
00998 void    putif Argdcl((tagptr, int));
00999 void    putout Argdcl((tagptr));
01000 expptr  putsteq Argdcl((Addrp, Addrp));
01001 void    putwhile Argdcl((tagptr));
01002 tagptr  putx Argdcl((tagptr));
01003 void    r8fix(Void);
01004 int     rdlong Argdcl((FILEP, long*));
01005 int     rdname Argdcl((FILEP, ptr, char*));
01006 void    read_Pfiles Argdcl((char**));
01007 Addrp   realpart Argdcl((Addrp));
01008 chainp  revchain Argdcl((chainp));
01009 int     same_expr Argdcl((tagptr, tagptr));
01010 int     same_ident Argdcl((tagptr, tagptr));
01011 void    save_argtypes Argdcl((chainp, Argtypes**, Argtypes**, int, char*, int, int, int, int));
01012 void    saveargtypes Argdcl((Exprp));
01013 void    set_externs(Void);
01014 void    set_tmp_names(Void);
01015 void    setbound Argdcl((Namep, int, struct Dims*));
01016 void    setdata Argdcl((Addrp, Constp, long));
01017 void    setext Argdcl((Namep));
01018 void    setfmt Argdcl((struct Labelblock*));
01019 void    setimpl Argdcl((int, long, int, int));
01020 void    setintr Argdcl((Namep));
01021 void    settype Argdcl((Namep, int, long));
01022 void    sigcatch Argdcl((int));
01023 void    sserr Argdcl((Namep));
01024 void    start_formatting(Void);
01025 void    startioctl(Void);
01026 void    startproc Argdcl((Extsym*, int));
01027 void    startrw(Void);
01028 char*   string_num Argdcl((char*, long));
01029 int     struct_eq Argdcl((chainp, chainp));
01030 tagptr  subcheck Argdcl((Namep, tagptr));
01031 tagptr  suboffset Argdcl((struct Primblock*));
01032 int     type_fixup Argdcl((Argtypes*, Atype*, int));
01033 void    unamstring Argdcl((Addrp, char*));
01034 void    unclassifiable(Void);
01035 void    vardcl Argdcl((Namep));
01036 void    warn Argdcl((char*));
01037 void    warn1 Argdcl((char*, char*));
01038 void    warni Argdcl((char*, int));
01039 void    wr_abbrevs Argdcl((FILEP, int, chainp));
01040 char*   wr_ardecls Argdcl((FILE*, struct Dimblock*, long));
01041 void    wr_array_init Argdcl((FILEP, int, chainp));
01042 void    wr_common_decls Argdcl((FILEP));
01043 void    wr_equiv_init Argdcl((FILEP, int, chainp*, int));
01044 void    wr_globals Argdcl((FILEP));
01045 void    wr_nv_ident_help Argdcl((FILEP, Addrp));
01046 void    wr_struct Argdcl((FILEP, chainp));
01047 void    wronginf Argdcl((Namep));
01048 void    yyerror Argdcl((char*));
01049 int     yylex(Void);
01050 int     yyparse(Void);
01051 
01052 #ifdef USE_DTOA
01053 #define atof(x) strtod(x,0)
01054 void    g_fmt Argdcl((char*, double));
01055 #endif