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