home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / f2csrc.zip / f2csrc / src / gram.head < prev    next >
Text File  |  1994-02-25  |  8KB  |  291 lines
  1. /****************************************************************
  2. Copyright 1990, 1993 by AT&T Bell Laboratories, Bellcore.
  3.  
  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.
  13.  
  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
  21. this software.
  22. ****************************************************************/
  23.  
  24. %{
  25. #include "defs.h"
  26. #include "p1defs.h"
  27.  
  28. static int nstars;            /* Number of labels in an
  29.                        alternate return CALL */
  30. static int datagripe;
  31. static int ndim;
  32. static int vartype;
  33. int new_dcl;
  34. static ftnint varleng;
  35. static struct Dims dims[MAXDIM+1];
  36. extern struct Labelblock **labarray;    /* Labels in an alternate
  37.                            return CALL */
  38. extern int maxlablist;
  39.  
  40. /* The next two variables are used to verify that each statement might be reached
  41.    during runtime.   lastwasbranch   is tested only in the defintion of the
  42.    stat:   nonterminal. */
  43.  
  44. int lastwasbranch = NO;
  45. static int thiswasbranch = NO;
  46. extern ftnint yystno;
  47. extern flag intonly;
  48. static chainp datastack;
  49. extern long laststfcn, thisstno;
  50. extern int can_include;    /* for netlib */
  51.  
  52. #define ESNULL (Extsym *)0
  53. #define NPNULL (Namep)0
  54. #define LBNULL (struct Listblock *)0
  55.  
  56.  static void
  57. pop_datastack(Void) {
  58.     chainp d0 = datastack;
  59.     if (d0->datap)
  60.         curdtp = (chainp)d0->datap;
  61.     datastack = d0->nextp;
  62.     d0->nextp = 0;
  63.     frchain(&d0);
  64.     }
  65.  
  66. %}
  67.  
  68. /* Specify precedences and associativities. */
  69.  
  70. %union    {
  71.     int ival;
  72.     ftnint lval;
  73.     char *charpval;
  74.     chainp chval;
  75.     tagptr tagval;
  76.     expptr expval;
  77.     struct Labelblock *labval;
  78.     struct Nameblock *namval;
  79.     struct Eqvchain *eqvval;
  80.     Extsym *extval;
  81.     }
  82.  
  83. %left SCOMMA
  84. %nonassoc SCOLON
  85. %right SEQUALS
  86. %left SEQV SNEQV
  87. %left SOR
  88. %left SAND
  89. %left SNOT
  90. %nonassoc SLT SGT SLE SGE SEQ SNE
  91. %left SCONCAT
  92. %left SPLUS SMINUS
  93. %left SSTAR SSLASH
  94. %right SPOWER
  95.  
  96. %start program
  97. %type <labval> thislabel label assignlabel
  98. %type <tagval> other inelt
  99. %type <ival> type typespec typename dcl letter addop relop stop nameeq
  100. %type <lval> lengspec
  101. %type <charpval> filename
  102. %type <chval> datavar datavarlist namelistlist funarglist funargs
  103. %type <chval> dospec dospecw
  104. %type <chval> callarglist arglist args exprlist inlist outlist out2 substring
  105. %type <namval> name arg call var
  106. %type <expval> lhs expr uexpr opt_expr fexpr unpar_fexpr
  107. %type <expval> ubound simple value callarg complex_const simple_const bit_const
  108. %type <extval> common comblock entryname progname
  109. %type <eqvval> equivlist
  110.  
  111. %%
  112.  
  113. program:
  114.     | program stat SEOS
  115.     ;
  116.  
  117. stat:      thislabel  entry
  118.         {
  119. /* stat:   is the nonterminal for Fortran statements */
  120.  
  121.           lastwasbranch = NO; }
  122.     | thislabel  spec
  123.     | thislabel  exec
  124.         { /* forbid further statement function definitions... */
  125.           if (parstate == INDATA && laststfcn != thisstno)
  126.             parstate = INEXEC;
  127.           thisstno++;
  128.           if($1 && ($1->labelno==dorange))
  129.             enddo($1->labelno);
  130.           if(lastwasbranch && thislabel==NULL)
  131.             warn("statement cannot be reached");
  132.           lastwasbranch = thiswasbranch;
  133.           thiswasbranch = NO;
  134.           if($1)
  135.             {
  136.             if($1->labtype == LABFORMAT)
  137.                 err("label already that of a format");
  138.             else
  139.                 $1->labtype = LABEXEC;
  140.             }
  141.           freetemps();
  142.         }
  143.     | thislabel SINCLUDE filename
  144.         { if (can_include)
  145.             doinclude( $3 );
  146.           else {
  147.             fprintf(diagfile, "Cannot open file %s\n", $3);
  148.             done(1);
  149.             }
  150.         }
  151.     | thislabel  SEND  end_spec
  152.         { if ($1)
  153.             lastwasbranch = NO;
  154.           endproc(); /* lastwasbranch = NO; -- set in endproc() */
  155.         }
  156.     | thislabel SUNKNOWN
  157.         { unclassifiable();
  158.  
  159. /* flline flushes the current line, ignoring the rest of the text there */
  160.  
  161.           flline(); }
  162.     | error
  163.         { flline();  needkwd = NO;  inioctl = NO;
  164.           yyerrok; yyclearin; }
  165.     ;
  166.  
  167. thislabel:  SLABEL
  168.         {
  169.         if(yystno != 0)
  170.             {
  171.             $$ = thislabel =  mklabel(yystno);
  172.             if( ! headerdone ) {
  173.                 if (procclass == CLUNKNOWN)
  174.                     procclass = CLMAIN;
  175.                 puthead(CNULL, procclass);
  176.                 }
  177.             if(thislabel->labdefined)
  178.                 execerr("label %s already defined",
  179.                     convic(thislabel->stateno) );
  180.             else    {
  181.                 if(thislabel->blklevel!=0 && thislabel->blklevel<blklevel
  182.                     && thislabel->labtype!=LABFORMAT)
  183.                     warn1("there is a branch to label %s from outside block",
  184.                           convic( (ftnint) (thislabel->stateno) ) );
  185.                 thislabel->blklevel = blklevel;
  186.                 thislabel->labdefined = YES;
  187.                 if(thislabel->labtype != LABFORMAT)
  188.                     p1_label((long)(thislabel - labeltab));
  189.                 }
  190.             }
  191.         else    $$ = thislabel = NULL;
  192.         }
  193.     ;
  194.  
  195. entry:      SPROGRAM new_proc progname
  196.            {startproc($3, CLMAIN); }
  197.     | SPROGRAM new_proc progname progarglist
  198.            {    warn("ignoring arguments to main program");
  199.             /* hashclear(); */
  200.             startproc($3, CLMAIN); }
  201.     | SBLOCK new_proc progname
  202.         { if($3) NO66("named BLOCKDATA");
  203.           startproc($3, CLBLOCK); }
  204.     | SSUBROUTINE new_proc entryname arglist
  205.         { entrypt(CLPROC, TYSUBR, (ftnint) 0,  $3, $4); }
  206.     | SFUNCTION new_proc entryname arglist
  207.         { entrypt(CLPROC, TYUNKNOWN, (ftnint) 0, $3, $4); }
  208.     | type SFUNCTION new_proc entryname arglist
  209.         { entrypt(CLPROC, $1, varleng, $4, $5); }
  210.     | SENTRY entryname arglist
  211.          { if(parstate==OUTSIDE || procclass==CLMAIN
  212.             || procclass==CLBLOCK)
  213.                 execerr("misplaced entry statement", CNULL);
  214.           entrypt(CLENTRY, 0, (ftnint) 0, $2, $3);
  215.         }
  216.     ;
  217.  
  218. new_proc:
  219.         { newproc(); }
  220.     ;
  221.  
  222. entryname:  name
  223.         { $$ = newentry($1, 1); }
  224.     ;
  225.  
  226. name:      SNAME
  227.         { $$ = mkname(token); }
  228.     ;
  229.  
  230. progname:        { $$ = NULL; }
  231.     | entryname
  232.     ;
  233.  
  234. progarglist:
  235.       SLPAR SRPAR
  236.     | SLPAR progargs SRPAR
  237.     ;
  238.  
  239. progargs: progarg
  240.     | progargs SCOMMA progarg
  241.     ;
  242.  
  243. progarg:  SNAME
  244.     | SNAME SEQUALS SNAME
  245.     ;
  246.  
  247. arglist:
  248.         { $$ = 0; }
  249.     | SLPAR SRPAR
  250.         { NO66(" () argument list");
  251.           $$ = 0; }
  252.     | SLPAR args SRPAR
  253.         {$$ = $2; }
  254.     ;
  255.  
  256. args:      arg
  257.         { $$ = ($1 ? mkchain((char *)$1,CHNULL) : CHNULL ); }
  258.     | args SCOMMA arg
  259.         { if($3) $1 = $$ = mkchain((char *)$3, $1); }
  260.     ;
  261.  
  262. arg:      name
  263.         { if($1->vstg!=STGUNKNOWN && $1->vstg!=STGARG)
  264.             dclerr("name declared as argument after use", $1);
  265.           $1->vstg = STGARG;
  266.         }
  267.     | SSTAR
  268.         { NO66("altenate return argument");
  269.  
  270. /* substars   means that '*'ed formal parameters should be replaced.
  271.    This is used to specify alternate return labels; in theory, only
  272.    parameter slots which have '*' should accept the statement labels.
  273.    This compiler chooses to ignore the '*'s in the formal declaration, and
  274.    always return the proper value anyway.
  275.  
  276.    This variable is only referred to in   proc.c   */
  277.  
  278.           $$ = 0;  substars = YES; }
  279.     ;
  280.  
  281.  
  282.  
  283. filename:   SHOLLERITH
  284.         {
  285.         char *s;
  286.         s = copyn(toklen+1, token);
  287.         s[toklen] = '\0';
  288.         $$ = s;
  289.         }
  290.     ;
  291.