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