home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso / unix / volume13 / ratfor / rat4.c < prev    next >
C/C++ Source or Header  |  1988-02-27  |  34KB  |  1,933 lines
  1. /*
  2.  * ratfor - A ratfor pre-processor in C. 
  3.  * Derived from a pre-processor distributed by the
  4.  * University of Arizona. Closely corresponds to the
  5.  * pre-processor described in the "SOFTWARE TOOLS" book.
  6.  *
  7.  * By: oz
  8.  *
  9.  * Not deived from AT&T code.
  10.  *
  11.  * This code is in the public domain. In other words, all rights
  12.  * are granted to all recipients, "public" at large.
  13.  *
  14.  * Modification history:
  15.  * 
  16.  * June 1985
  17.  *    - Ken Yap's mods for F77 output. Currently
  18.  *      available thru #define F77.
  19.  *    - Two minor bug-fixes for sane output.
  20.  * June 1985
  21.  *    - Improve front-end with getopt().
  22.  *      User may specify -l n for starting label.
  23.  *    - Retrofit switch statement handling. This code 
  24.  *      is borrowed from the SWTOOLS Ratfor.
  25.  *
  26.  */
  27.  
  28. #include <stdio.h>
  29. #include "ratdef.h"
  30. #include "ratcom.h"
  31.  
  32. /* keywords: */
  33.  
  34. char sdo[3] = {
  35.     LETD,LETO,EOS};
  36. char vdo[2] = {
  37.     LEXDO,EOS};
  38.  
  39. char sif[3] = {
  40.     LETI,LETF,EOS};
  41. char vif[2] = {
  42.     LEXIF,EOS};
  43.  
  44. char selse[5] = {
  45.     LETE,LETL,LETS,LETE,EOS};
  46. char velse[2] = {
  47.     LEXELSE,EOS};
  48.  
  49. #ifdef F77
  50. char sthen[5] = {
  51.     LETT,LETH,LETE,LETN,EOS};
  52.  
  53. char sendif[6] = {
  54.     LETE,LETN,LETD,LETI,LETF,EOS};
  55.  
  56. #endif F77
  57. char swhile[6] = {
  58.     LETW, LETH, LETI, LETL, LETE, EOS};
  59. char vwhile[2] = {
  60.     LEXWHILE, EOS};
  61.  
  62. char sbreak[6] = {
  63.     LETB, LETR, LETE, LETA, LETK, EOS};
  64. char vbreak[2] = {
  65.     LEXBREAK, EOS};
  66.  
  67. char snext[5] = {
  68.     LETN,LETE, LETX, LETT, EOS};
  69. char vnext[2] = {
  70.     LEXNEXT, EOS};
  71.  
  72. char sfor[4] = {
  73.     LETF,LETO, LETR, EOS};
  74. char vfor[2] = {
  75.     LEXFOR, EOS};
  76.  
  77. char srept[7] = {
  78.     LETR, LETE, LETP, LETE, LETA, LETT, EOS};
  79. char vrept[2] = {
  80.     LEXREPEAT, EOS};
  81.  
  82. char suntil[6] = {
  83.     LETU, LETN, LETT, LETI, LETL, EOS};
  84. char vuntil[2] = {
  85.     LEXUNTIL, EOS};
  86.  
  87. char sswitch[7] = {
  88.     LETS, LETW, LETI, LETT, LETC, LETH, EOS};
  89. char vswitch[2] = {
  90.     LEXSWITCH, EOS};
  91.  
  92. char scase[5] = {
  93.     LETC, LETA, LETS, LETE, EOS};
  94. char vcase[2] = {
  95.     LEXCASE, EOS};
  96.  
  97. char sdefault[8] = {
  98.     LETD, LETE, LETF, LETA, LETU, LETL, LETT, EOS};
  99. char vdefault[2] = {
  100.     LEXDEFAULT, EOS};
  101.  
  102. char sret[7] = {
  103.     LETR, LETE, LETT, LETU, LETR, LETN, EOS};
  104. char vret[2] = {
  105.     LEXRETURN, EOS};
  106.  
  107. char sstr[7] = {
  108.     LETS, LETT, LETR, LETI, LETN, LETG, EOS};
  109. char vstr[2] = {
  110.     LEXSTRING, EOS};
  111.  
  112. char deftyp[2] = {
  113.     DEFTYPE, EOS};
  114.  
  115. /* constant strings */
  116.  
  117. char *errmsg = "error at line ";
  118. char *in     = " in ";
  119. char *ifnot  = "if(.not.";
  120. char *incl   = "include";
  121. char *fncn   = "function";
  122. char *def    = "define";
  123. char *bdef   = "DEFINE";
  124. char *contin = "continue";
  125. char *rgoto  = "goto ";
  126. char *dat    = "data ";
  127. char *eoss   = "EOS/";
  128.  
  129. extern char ngetch();
  130. char *progname;
  131. int startlab = 23000;        /* default start label */
  132.  
  133. /* 
  134.  * M A I N   L I N E  &  I N I T
  135.  */
  136.  
  137. main(argc,argv)
  138. int argc;
  139. char *argv[];
  140. {
  141.     int c, errflg = 0;
  142.     extern int optind;
  143.     extern char *optarg;
  144.  
  145.     progname = argv[0];
  146.  
  147.     while ((c=getopt(argc, argv, "Chn:o:6:")) != EOF)
  148.     switch (c) {
  149.         case 'C':
  150.                 /* not written yet */
  151.             break;
  152.         case 'h':
  153.                 /* not written yet */
  154.             break;
  155.         case 'l':    /* user sets label */
  156.             startlab = atoi(optarg);
  157.             break;
  158.         case 'o':
  159.             if ((freopen(optarg, "w", stdout)) == NULL)
  160.                 error("can't write %s\n", optarg);
  161.             break;
  162.         case '6':
  163.                 /* not written yet */
  164.             break;
  165.         default:
  166.             ++errflg;
  167.     }
  168.     
  169.     if (errflg) {
  170.         fprintf(stderr,
  171.             "usage: %s [-C][-hx][-l n][-o file][-6x] [file...]\n");
  172.         exit(1);
  173.     }
  174.  
  175.     /*
  176.      * present version can only process one file, sadly.
  177.      */
  178.     if (optind >= argc)
  179.         infile[0] = stdin;
  180.     else if ((infile[0] = fopen(argv[optind], "r")) == NULL)
  181.         error("cannot read %s\n", argv[optind]);
  182.  
  183.     initvars();
  184.  
  185.     parse();        /* call parser.. */
  186.  
  187.     exit(1);
  188. }
  189.  
  190. /*
  191.  * initialise 
  192.  */
  193. initvars()
  194. {
  195.     int i;
  196.  
  197.     outp = 0;        /* output character pointer */
  198.     level = 0;        /* file control */
  199.     linect[0] = 1;        /* line count of first file */
  200.     fnamp = 0;
  201.     fnames[0] = EOS;
  202.     bp = -1;        /* pushback buffer pointer */
  203.     fordep = 0;        /* for stack */
  204.     swtop = 0;        /* switch stack index */
  205.     swlast = 1;        /* switch stack index */
  206.     for( i = 0; i <= 126; i++)
  207.         tabptr[i] = 0;
  208.     install(def, deftyp);    /* default definitions */
  209.     install(bdef, deftyp);
  210.     fcname[0] = EOS;    /* current function name */
  211.     label = startlab;    /* next generated label */
  212. }
  213.  
  214. /*
  215.  * P A R S E R
  216.  */
  217.  
  218. parse()
  219. {
  220.     char lexstr[MAXTOK];
  221.     int lab, labval[MAXSTACK], lextyp[MAXSTACK], sp, i, token;
  222.  
  223.     sp = 0;
  224.     lextyp[0] = EOF;
  225.     for (token = lex(lexstr); token != EOF; token = lex(lexstr)) {
  226.         if (token == LEXIF)
  227.             ifcode(&lab);
  228.         else if (token == LEXDO)
  229.             docode(&lab);
  230.         else if (token == LEXWHILE)
  231.             whilec(&lab);
  232.         else if (token == LEXFOR)
  233.             forcod(&lab);
  234.         else if (token == LEXREPEAT)
  235.             repcod(&lab);
  236.         else if (token == LEXSWITCH)
  237.             swcode(&lab);
  238.         else if (token == LEXCASE || token == LEXDEFAULT) {
  239.             for (i = sp; i >= 0; i--)
  240.                 if (lextyp[i] == LEXSWITCH)
  241.                     break;
  242.             if (i < 0)
  243.                 synerr("illegal case of default.");
  244.             else
  245.                 cascod(labval[i], token);
  246.         }
  247.         else if (token == LEXDIGITS)
  248.             labelc(lexstr);
  249.         else if (token == LEXELSE) {
  250.             if (lextyp[sp] == LEXIF)
  251.                 elseif(labval[sp]);
  252.             else
  253.                 synerr("illegal else.");
  254.         }
  255.         if (token == LEXIF || token == LEXELSE || token == LEXWHILE
  256.             || token == LEXFOR || token == LEXREPEAT
  257.             || token == LEXDO || token == LEXDIGITS 
  258.             || token == LEXSWITCH || token == LBRACE) {
  259.             sp++;         /* beginning of statement */
  260.             if (sp > MAXSTACK)
  261.                 baderr("stack overflow in parser.");
  262.             lextyp[sp] = token;     /* stack type and value */
  263.             labval[sp] = lab;
  264.         }
  265.         else if (token != LEXCASE && token != LEXDEFAULT) {
  266.             /* 
  267.                  * end of statement - prepare to unstack 
  268.              */
  269.             if (token == RBRACE) {
  270.                 if (lextyp[sp] == LBRACE)
  271.                     sp--;
  272.                 else if (lextyp[sp] == LEXSWITCH) {
  273.                     swend(labval[sp]);
  274.                     sp--;
  275.                 }
  276.                 else
  277.                     synerr("illegal right brace.");
  278.             }
  279.             else if (token == LEXOTHER)
  280.                 otherc(lexstr);
  281.             else if (token == LEXBREAK || token == LEXNEXT)
  282.                 brknxt(sp, lextyp, labval, token);
  283.             else if (token == LEXRETURN)
  284.                 retcod();
  285.              else if (token == LEXSTRING)
  286.                 strdcl();
  287.             token = lex(lexstr);      /* peek at next token */
  288.             pbstr(lexstr);
  289.             unstak(&sp, lextyp, labval, token);
  290.         }
  291.     }
  292.     if (sp != 0)
  293.         synerr("unexpected EOF.");
  294. }
  295.  
  296. /*
  297.  * L E X I C A L  A N A L Y S E R
  298.  */
  299.  
  300. /*
  301.  *  alldig - return YES if str is all digits
  302.  *
  303.  */
  304. int
  305. alldig(str)
  306. char str[];
  307. {
  308.     int i,j;
  309.  
  310.     j = NO;
  311.     if (str[0] == EOS)
  312.         return(j);
  313.     for (i = 0; str[i] != EOS; i++)
  314.         if (type(str[i]) != DIGIT)
  315.             return(j);
  316.     j = YES;
  317.     return(j);
  318. }
  319.  
  320.  
  321. /*
  322.  * balpar - copy balanced paren string
  323.  *
  324.  */
  325. balpar()
  326. {
  327.     char token[MAXTOK];
  328.     int t,nlpar;
  329.  
  330.     if (gnbtok(token, MAXTOK) != LPAREN) {
  331.         synerr("missing left paren.");
  332.         return;
  333.     }
  334.     outstr(token);
  335.     nlpar = 1;
  336.     do {
  337.         t = gettok(token, MAXTOK);
  338.         if (t==SEMICOL || t==LBRACE || t==RBRACE || t==EOF) {
  339.             pbstr(token);
  340.             break;
  341.         }
  342.         if (t == NEWLINE)      /* delete newlines */
  343.             token[0] = EOS;
  344.         else if (t == LPAREN)
  345.             nlpar++;
  346.         else if (t == RPAREN)
  347.             nlpar--;
  348.         /* else nothing special */
  349.         outstr(token);
  350.     } 
  351.     while (nlpar > 0);
  352.     if (nlpar != 0)
  353.         synerr("missing parenthesis in condition.");
  354. }
  355.  
  356. /*
  357.  * deftok - get token; process macro calls and invocations
  358.  *
  359.  */
  360. int
  361. deftok(token, toksiz, fd)
  362. char token[];
  363. int toksiz;
  364. FILE *fd;
  365. {
  366.     char defn[MAXDEF];
  367.     int t;
  368.  
  369.     for (t=gtok(token, toksiz, fd); t!=EOF; t=gtok(token, toksiz, fd)) {
  370.         if (t != ALPHA)   /* non-alpha */
  371.             break;
  372.         if (look(token, defn) == NO)   /* undefined */
  373.             break;
  374.         if (defn[0] == DEFTYPE) {   /* get definition */
  375.             getdef(token, toksiz, defn, MAXDEF, fd);
  376.             install(token, defn);
  377.         }
  378.         else
  379.             pbstr(defn);   /* push replacement onto input */
  380.     }
  381.     if (t == ALPHA)   /* convert to single case */
  382.         fold(token);
  383.     return(t);
  384. }
  385.  
  386.  
  387. /*
  388.  * eatup - process rest of statement; interpret continuations
  389.  *
  390.  */
  391. eatup()
  392. {
  393.  
  394.     char ptoken[MAXTOK], token[MAXTOK];
  395.     int nlpar, t;
  396.  
  397.     nlpar = 0;
  398.     do {
  399.         t = gettok(token, MAXTOK);
  400.         if (t == SEMICOL || t == NEWLINE)
  401.             break;
  402.         if (t == RBRACE || t == LBRACE) {
  403.             pbstr(token);
  404.             break;
  405.         }
  406.         if (t == EOF) {
  407.             synerr("unexpected EOF.");
  408.             pbstr(token);
  409.             break;
  410.         }
  411.         if (t == COMMA || t == PLUS 
  412.                    || t == MINUS || t == STAR || t == LPAREN
  413.                        || t == AND || t == BAR || t == BANG
  414.                    || t == EQUALS || t == UNDERLINE ) {
  415.             while (gettok(ptoken, MAXTOK) == NEWLINE)
  416.                 ;
  417.             pbstr(ptoken);
  418.             if (t == UNDERLINE)
  419.                 token[0] = EOS;
  420.         }
  421.         if (t == LPAREN)
  422.             nlpar++;
  423.         else if (t == RPAREN)
  424.             nlpar--;
  425.         outstr(token);
  426.  
  427.     } while (nlpar >= 0);
  428.  
  429.     if (nlpar != 0)
  430.         synerr("unbalanced parentheses.");
  431. }
  432.  
  433. /*
  434.  * getdef (for no arguments) - get name and definition
  435.  *
  436.  */
  437. getdef(token, toksiz, defn, defsiz, fd)
  438. char token[];
  439. int toksiz;
  440. char defn[];
  441. int defsiz;
  442. FILE *fd;
  443. {
  444.     int i, nlpar, t;
  445.     char c, ptoken[MAXTOK];
  446.  
  447.     skpblk(fd);
  448.     /*
  449.      * define(name,defn) or
  450.      * define name defn
  451.      *
  452.      */
  453.     if ((t = gtok(ptoken, MAXTOK, fd)) != LPAREN) {;
  454.         t = BLANK;              /* define name defn */
  455.         pbstr(ptoken);
  456.     }
  457.     skpblk(fd);
  458.     if (gtok(token, toksiz, fd) != ALPHA)
  459.         baderr("non-alphanumeric name.");
  460.     skpblk(fd);
  461.     c = (char) gtok(ptoken, MAXTOK, fd);
  462.     if (t == BLANK) {         /* define name defn */
  463.         pbstr(ptoken);
  464.         i = 0;
  465.         do {
  466.             c = ngetch(&c, fd);
  467.             if (i > defsiz)
  468.                 baderr("definition too long.");
  469.             defn[i++] = c;
  470.         } 
  471.         while (c != SHARP && c != NEWLINE && c != EOF);
  472.         if (c == SHARP)
  473.             putbak(c);
  474.     }
  475.     else if (t == LPAREN) {   /* define (name, defn) */
  476.         if (c != COMMA)
  477.             baderr("missing comma in define.");
  478.         /* else got (name, */
  479.         nlpar = 0;
  480.         for (i = 0; nlpar >= 0; i++)
  481.             if (i > defsiz)
  482.                 baderr("definition too long.");
  483.             else if (ngetch(&defn[i], fd) == EOF)
  484.                 baderr("missing right paren.");
  485.             else if (defn[i] == LPAREN)
  486.                 nlpar++;
  487.             else if (defn[i] == RPAREN)
  488.                 nlpar--;
  489.         /* else normal character in defn[i] */
  490.     }
  491.     else
  492.         baderr("getdef is confused.");
  493.     defn[i-1] = EOS;
  494. }
  495.  
  496. /*
  497.  * gettok - get token. handles file inclusion and line numbers
  498.  *
  499.  */
  500. int
  501. gettok(token, toksiz)
  502. char token[];
  503. int toksiz;
  504. {
  505.     int t, i;
  506.     int tok;
  507.     char name[MAXNAME];
  508.  
  509.     for ( ; level >= 0; level--) {
  510.         for (tok = deftok(token, toksiz, infile[level]); tok != EOF;
  511.              tok = deftok(token, toksiz, infile[level])) {
  512.                 if (equal(token, fncn) == YES) {
  513.                 skpblk(infile[level]);
  514.                 t = deftok(fcname, MAXNAME, infile[level]);
  515.                 pbstr(fcname);
  516.                 if (t != ALPHA)
  517.                     synerr("missing function name.");
  518.                 putbak(BLANK);
  519.                 return(tok);
  520.             }
  521.             else if (equal(token, incl) == NO)
  522.                 return(tok);
  523.             for (i = 0 ;; i = strlen(name)) {
  524.                 t = deftok(&name[i], MAXNAME, infile[level]);
  525.                 if (t == NEWLINE || t == SEMICOL) {
  526.                     pbstr(&name[i]);
  527.                     break;
  528.                 }
  529.             }
  530.             name[i] = EOS;
  531.             if (name[1] == SQUOTE) {
  532.                 outtab();
  533.                 outstr(token);
  534.                 outstr(name);
  535.                 outdon();
  536.                 eatup();
  537.                 return(tok);
  538.             }
  539.             if (level >= NFILES)
  540.                 synerr("includes nested too deeply.");
  541.             else {
  542.                 infile[level+1] = fopen(name, "r");
  543.                 linect[level+1] = 1;
  544.                 if (infile[level+1] == NULL)
  545.                     synerr("can't open include.");
  546.                 else {
  547.                     level++;
  548.                     if (fnamp + i <= MAXFNAMES) {
  549.                         scopy(name, 0, fnames, fnamp);
  550.                         fnamp = fnamp + i;    /* push file name stack */
  551.                     }
  552.                 }
  553.             }
  554.         }
  555.         if (level > 0) {      /* close include and pop file name stack */
  556.             fclose(infile[level]);
  557.             for (fnamp--; fnamp > 0; fnamp--)
  558.                 if (fnames[fnamp-1] == EOS)
  559.                     break;
  560.         }
  561.     }
  562.     token[0] = EOF;   /* in case called more than once */
  563.     token[1] = EOS;
  564.     tok = EOF;
  565.     return(tok);
  566. }
  567.  
  568. /*
  569.  * gnbtok - get nonblank token
  570.  *
  571.  */
  572. int
  573. gnbtok(token, toksiz)
  574. char token[];
  575. int toksiz;
  576. {
  577.     int tok;
  578.  
  579.     skpblk(infile[level]);
  580.     tok = gettok(token, toksiz);
  581.     return(tok);
  582. }
  583.  
  584. /*
  585.  * gtok - get token for Ratfor
  586.  *
  587.  */
  588. int
  589. gtok(lexstr, toksiz, fd)
  590. char lexstr[];
  591. int toksiz;
  592. FILE *fd;
  593. {
  594.     int i, b, n, tok; 
  595.     char c;
  596.     c = ngetch(&lexstr[0], fd);
  597.     if (c == BLANK || c == TAB) {
  598.         lexstr[0] = BLANK;
  599.         while (c == BLANK || c == TAB)    /* compress many blanks to one */
  600.             c = ngetch(&c, fd);
  601.         if (c == SHARP)
  602.             while (ngetch(&c, fd) != NEWLINE)   /* strip comments */
  603.                 ;
  604.         if (c != NEWLINE)
  605.             putbak(c);
  606.         else
  607.             lexstr[0] = NEWLINE;
  608.         lexstr[1] = EOS;
  609.         return((int)lexstr[0]);
  610.     }
  611.     i = 0;
  612.     tok = type(c);
  613.     if (tok == LETTER) {    /* alpha */
  614.         for (i = 0; i < toksiz - 3; i++) {
  615.             tok = type(ngetch(&lexstr[i+1], fd));
  616.             /* Test for DOLLAR added by BM, 7-15-80 */
  617.             if (tok != LETTER && tok != DIGIT 
  618.                 && tok != UNDERLINE && tok!=DOLLAR
  619.                 && tok != PERIOD)
  620.                 break;
  621.         }
  622.         putbak(lexstr[i+1]);
  623.         tok = ALPHA;
  624.     }
  625.     else if (tok == DIGIT) {    /* digits */
  626.         b = c - DIG0;    /* in case alternate base number */
  627.         for (i = 0; i < toksiz - 3; i++) {
  628.             if (type(ngetch(&lexstr[i+1], fd)) != DIGIT)
  629.                 break;
  630.             b = 10*b + lexstr[i+1] - DIG0;
  631.         }
  632.         if (lexstr[i+1] == RADIX && b >= 2 && b <= 36) {   
  633.             /* n%ddd... */
  634.             for (n = 0;; n = b*n + c - DIG0) {
  635.                 c = ngetch(&lexstr[0], fd);
  636.                 if (c >= LETA && c <= LETZ)
  637.                     c = c - LETA + DIG9 + 1;
  638.                 else if (c >= BIGA && c <= BIGZ)
  639.                     c = c - BIGA + DIG9 + 1;
  640.                 if (c < DIG0 || c >= DIG0 + b)
  641.                     break;
  642.             }
  643.             putbak(lexstr[0]);
  644.             i = itoc(n, lexstr, toksiz);
  645.         }
  646.         else
  647.             putbak(lexstr[i+1]);
  648.         tok = DIGIT;
  649.     }
  650. #ifdef SQUAREB
  651.     else if (c == LBRACK) {   /* allow [ for { */
  652.         lexstr[0] = LBRACE;
  653.         tok = LBRACE;
  654.     }
  655.     else if (c == RBRACK) {   /* allow ] for } */
  656.         lexstr[0] = RBRACE;
  657.         tok = RBRACE;
  658.     }
  659. #endif
  660.     else if (c == SQUOTE || c == DQUOTE) {
  661.         for (i = 1; ngetch(&lexstr[i], fd) != lexstr[0]; i++) {
  662.             if (lexstr[i] == UNDERLINE)
  663.                 if (ngetch(&c, fd) == NEWLINE) {
  664.                     while (c == NEWLINE || c == BLANK || c == TAB)
  665.                         c = ngetch(&c, fd);
  666.                     lexstr[i] = c;
  667.                 }
  668.                 else
  669.                     putbak(c);
  670.             if (lexstr[i] == NEWLINE || i >= toksiz-1) {
  671.                 synerr("missing quote.");
  672.                 lexstr[i] = lexstr[0];
  673.                 putbak(NEWLINE);
  674.                 break;
  675.             }
  676.         }
  677.     }
  678.     else if (c == SHARP) {   /* strip comments */
  679.         while (ngetch(&lexstr[0], fd) != NEWLINE)
  680.             ;
  681.         tok = NEWLINE;
  682.     }
  683.     else if (c == GREATER || c == LESS || c == NOT 
  684.          || c == BANG || c == CARET || c == EQUALS 
  685.          || c == AND || c == OR)
  686.         i = relate(lexstr, fd);
  687.     if (i >= toksiz-1)
  688.         synerr("token too long.");
  689.     lexstr[i+1] = EOS;
  690.     if (lexstr[0] == NEWLINE)
  691.         linect[level] = linect[level] + 1;
  692.     return(tok);
  693. }
  694.  
  695. /*
  696.  * lex - return lexical type of token
  697.  *
  698.  */
  699. int
  700. lex(lexstr)
  701. char lexstr[];
  702. {
  703.  
  704.     int tok;
  705.  
  706.     for (tok = gnbtok(lexstr, MAXTOK);
  707.          tok == NEWLINE; tok = gnbtok(lexstr, MAXTOK))
  708.             ;
  709.     if (tok == EOF || tok == SEMICOL || tok == LBRACE || tok == RBRACE)
  710.         return(tok);
  711.     if (tok == DIGIT)
  712.         tok = LEXDIGITS;
  713.     else if (equal(lexstr, sif) == YES)
  714.         tok = vif[0];
  715.     else if (equal(lexstr, selse) == YES)
  716.         tok = velse[0];
  717.     else if (equal(lexstr, swhile) == YES)
  718.         tok = vwhile[0];
  719.     else if (equal(lexstr, sdo) == YES)
  720.         tok = vdo[0];
  721.     else if (equal(lexstr, sbreak) == YES)
  722.         tok = vbreak[0];
  723.     else if (equal(lexstr, snext) == YES)
  724.         tok = vnext[0];
  725.     else if (equal(lexstr, sfor) == YES)
  726.         tok = vfor[0];
  727.     else if (equal(lexstr, srept) == YES)
  728.         tok = vrept[0];
  729.     else if (equal(lexstr, suntil) == YES)
  730.         tok = vuntil[0];
  731.     else if (equal(lexstr, sswitch) == YES)
  732.         tok = vswitch[0];
  733.     else if (equal(lexstr, scase) == YES)
  734.         tok = vcase[0];
  735.     else if (equal(lexstr, sdefault) == YES)
  736.         tok = vdefault[0];
  737.     else if (equal(lexstr, sret) == YES)
  738.         tok = vret[0];
  739.     else if (equal(lexstr, sstr) == YES)
  740.         tok = vstr[0];
  741.     else
  742.         tok = LEXOTHER;
  743.     return(tok);
  744. }
  745.  
  746. /*
  747.  * ngetch - get a (possibly pushed back) character
  748.  *
  749.  */
  750. char
  751. ngetch(c, fd)
  752. char *c;
  753. FILE *fd;
  754. {
  755.  
  756.     if (bp >= 0) {
  757.         *c = buf[bp];
  758.         bp--;
  759.     }
  760.     else
  761.         *c = (char) getc(fd);
  762.     
  763.     return(*c);
  764. }
  765. /*
  766.  * pbstr - push string back onto input
  767.  *
  768.  */
  769. pbstr(in)
  770. char in[];
  771. {
  772.     int i;
  773.  
  774.     for (i = strlen(in) - 1; i >= 0; i--)
  775.         putbak(in[i]);
  776. }
  777.  
  778. /*
  779.  * putbak - push char back onto input
  780.  *
  781.  */
  782. putbak(c)
  783. char c;
  784. {
  785.  
  786.     bp++;
  787.     if (bp > BUFSIZE)
  788.         baderr("too many characters pushed back.");
  789.     buf[bp] = c;
  790. }
  791.  
  792.  
  793. /*
  794.  * relate - convert relational shorthands into long form
  795.  *
  796.  */
  797. int
  798. relate(token, fd)
  799. char token[];
  800. FILE *fd;
  801. {
  802.  
  803.     if (ngetch(&token[1], fd) != EQUALS) {
  804.         putbak(token[1]);
  805.         token[2] = LETT;
  806.     }
  807.     else
  808.         token[2] = LETE;
  809.     token[3] = PERIOD;
  810.     token[4] = EOS;
  811.     token[5] = EOS;    /* for .not. and .and. */
  812.     if (token[0] == GREATER)
  813.         token[1] = LETG;
  814.     else if (token[0] == LESS)
  815.         token[1] = LETL;
  816.     else if (token[0] == NOT || token[0] == BANG || token[0] == CARET) {
  817.         if (token[1] != EQUALS) {
  818.             token[2] = LETO;
  819.             token[3] = LETT;
  820.             token[4] = PERIOD;
  821.         }
  822.         token[1] = LETN;
  823.     }
  824.     else if (token[0] == EQUALS) {
  825.         if (token[1] != EQUALS) {
  826.             token[2] = EOS;
  827.             return(0);
  828.         }
  829.         token[1] = LETE;
  830.         token[2] = LETQ;
  831.     }
  832.     else if (token[0] == AND) {
  833.         token[1] = LETA;
  834.         token[2] = LETN;
  835.         token[3] = LETD;
  836.         token[4] = PERIOD;
  837.     }
  838.     else if (token[0] == OR) {
  839.         token[1] = LETO;
  840.         token[2] = LETR;
  841.     }
  842.     else   /* can't happen */
  843.         token[1] = EOS;
  844.     token[0] = PERIOD;
  845.     return(strlen(token)-1);
  846. }
  847.  
  848. /*
  849.  * skpblk - skip blanks and tabs in file  fd
  850.  *
  851.  */
  852. skpblk(fd)
  853. FILE *fd;
  854. {
  855.     char c;
  856.  
  857.     for (c = ngetch(&c, fd); c == BLANK || c == TAB; c = ngetch(&c, fd))
  858.         ;
  859.     putbak(c);
  860. }
  861.  
  862.  
  863. /* 
  864.  * type - return LETTER, DIGIT or char; works with ascii alphabet
  865.  *
  866.  */
  867. int
  868. type(c)
  869. char c;
  870. {
  871.     int t;
  872.  
  873.     if (c >= DIG0 && c <= DIG9)
  874.         t = DIGIT;
  875.     else if (c >= LETA && c <= LETZ)
  876.         t = LETTER;
  877.     else if (c >= BIGA && c <= BIGZ)
  878.         t = LETTER;
  879.     else
  880.         t = c;
  881.     return(t);
  882. }
  883.  
  884. /*
  885.  * C O D E  G E N E R A T I O N 
  886.  */
  887.  
  888. /*
  889.  * brknxt - generate code for break n and next n; n = 1 is default
  890.  */
  891. brknxt(sp, lextyp, labval, token)
  892. int sp;
  893. int lextyp[];
  894. int labval[];
  895. int token;
  896. {
  897.     int i, n;
  898.     char t, ptoken[MAXTOK];
  899.  
  900.     n = 0;
  901.     t = gnbtok(ptoken, MAXTOK);
  902.     if (alldig(ptoken) == YES) {     /* have break n or next n */
  903.         i = 0;
  904.         n = ctoi(ptoken, &i) - 1;
  905.     }
  906.     else if (t != SEMICOL)      /* default case */
  907.         pbstr(ptoken);
  908.     for (i = sp; i >= 0; i--)
  909.         if (lextyp[i] == LEXWHILE || lextyp[i] == LEXDO
  910.             || lextyp[i] == LEXFOR || lextyp[i] == LEXREPEAT) {
  911.             if (n > 0) {
  912.                 n--;
  913.                 continue;             /* seek proper level */
  914.             }
  915.             else if (token == LEXBREAK)
  916.                 outgo(labval[i]+1);
  917.             else
  918.                 outgo(labval[i]);
  919.             xfer = YES;
  920.             return;
  921.         }
  922.     if (token == LEXBREAK)
  923.         synerr("illegal break.");
  924.     else
  925.         synerr("illegal next.");
  926.     return;
  927. }
  928.  
  929. /*
  930.  * docode - generate code for beginning of do
  931.  *
  932.  */
  933. docode(lab)
  934. int *lab;
  935. {
  936.     xfer = NO;
  937.     outtab();
  938.     outstr(sdo);
  939.     *lab = labgen(2);
  940.     outnum(*lab);
  941.     eatup();
  942.     outdon();
  943. }
  944.  
  945. /*
  946.  * dostat - generate code for end of do statement
  947.  *
  948.  */
  949. dostat(lab)
  950. int lab;
  951. {
  952.     outcon(lab);
  953.     outcon(lab+1);
  954. }
  955.  
  956. /*
  957.  * elseif - generate code for end of if before else
  958.  *
  959.  */
  960. elseif(lab)
  961. int lab;
  962. {
  963.  
  964. #ifdef F77
  965.     outtab();
  966.     outstr(selse);
  967.     outdon();
  968. #else
  969.     outgo(lab+1);
  970.     outcon(lab);
  971. #endif F77
  972. }
  973.  
  974. /*
  975.  * forcod - beginning of for statement
  976.  *
  977.  */
  978. forcod(lab)
  979. int *lab;
  980. {
  981.     char t, token[MAXTOK];
  982.     int i, j, nlpar,tlab;
  983.  
  984.     tlab = *lab;
  985.     tlab = labgen(3);
  986.     outcon(0);
  987.     if (gnbtok(token, MAXTOK) != LPAREN) {
  988.         synerr("missing left paren.");
  989.         return;
  990.     }
  991.     if (gnbtok(token, MAXTOK) != SEMICOL) {   /* real init clause */
  992.         pbstr(token);
  993.         outtab();
  994.         eatup();
  995.         outdon();
  996.     }
  997.     if (gnbtok(token, MAXTOK) == SEMICOL)   /* empty condition */
  998.         outcon(tlab);
  999.     else {   /* non-empty condition */
  1000.         pbstr(token);
  1001.         outnum(tlab);
  1002.         outtab();
  1003.         outstr(ifnot);
  1004.         outch(LPAREN);
  1005.         nlpar = 0;
  1006.         while (nlpar >= 0) {
  1007.             t = gettok(token, MAXTOK);
  1008.             if (t == SEMICOL)
  1009.                 break;
  1010.             if (t == LPAREN)
  1011.                 nlpar++;
  1012.             else if (t == RPAREN)
  1013.                 nlpar--;
  1014.             if (t == EOF) {
  1015.                 pbstr(token);
  1016.                 return;
  1017.             }
  1018.             if (t != NEWLINE && t != UNDERLINE)
  1019.                 outstr(token);
  1020.         }
  1021.         outch(RPAREN);
  1022.         outch(RPAREN);
  1023.         outgo((tlab)+2);
  1024.         if (nlpar < 0)
  1025.             synerr("invalid for clause.");
  1026.     }
  1027.     fordep++;        /* stack reinit clause */
  1028.     j = 0;
  1029.     for (i = 1; i < fordep; i++)   /* find end *** should i = 1 ??? *** */
  1030.         j = j + strlen(&forstk[j]) + 1;
  1031.     forstk[j] = EOS;   /* null, in case no reinit */
  1032.     nlpar = 0;
  1033.     t = gnbtok(token, MAXTOK);
  1034.     pbstr(token);
  1035.     while (nlpar >= 0) {
  1036.         t = gettok(token, MAXTOK);
  1037.         if (t == LPAREN)
  1038.             nlpar++;
  1039.         else if (t == RPAREN)
  1040.             nlpar--;
  1041.         if (t == EOF) {
  1042.             pbstr(token);
  1043.             break;
  1044.         }
  1045.         if (nlpar >= 0 && t != NEWLINE && t != UNDERLINE) {
  1046.             if (j + strlen(token) >= MAXFORSTK)
  1047.                 baderr("for clause too long.");
  1048.             scopy(token, 0, forstk, j);
  1049.             j = j + strlen(token);
  1050.         }
  1051.     }
  1052.     tlab++;   /* label for next's */
  1053.     *lab = tlab;
  1054. }
  1055.  
  1056. /*
  1057.  * fors - process end of for statement
  1058.  *
  1059.  */
  1060. fors(lab)
  1061. int lab;
  1062. {
  1063.     int i, j;
  1064.  
  1065.     xfer = NO;
  1066.     outnum(lab);
  1067.     j = 0;
  1068.     for (i = 1; i < fordep; i++)
  1069.         j = j + strlen(&forstk[j]) + 1;
  1070.     if (strlen(&forstk[j]) > 0) {
  1071.         outtab();
  1072.         outstr(&forstk[j]);
  1073.         outdon();
  1074.     }
  1075.     outgo(lab-1);
  1076.     outcon(lab+1);
  1077.     fordep--;
  1078. }
  1079.  
  1080. /*
  1081.  * ifcode - generate initial code for if
  1082.  *
  1083.  */
  1084. ifcode(lab)
  1085. int *lab;
  1086. {
  1087.  
  1088.     xfer = NO;
  1089.     *lab = labgen(2);
  1090. #ifdef F77
  1091.     ifthen();
  1092. #else
  1093.     ifgo(*lab);
  1094. #endif F77
  1095. }
  1096.  
  1097. #ifdef F77
  1098. /*
  1099.  * ifend - generate code for end of if
  1100.  *
  1101.  */
  1102. ifend()
  1103. {
  1104.     outtab();
  1105.     outstr(sendif);
  1106.     outdon();
  1107. }
  1108. #endif F77
  1109.  
  1110. /*
  1111.  * ifgo - generate "if(.not.(...))goto lab"
  1112.  *
  1113.  */
  1114. ifgo(lab)
  1115. int lab;
  1116. {
  1117.  
  1118.     outtab();      /* get to column 7 */
  1119.     outstr(ifnot);      /* " if(.not. " */
  1120.     balpar();      /* collect and output condition */
  1121.     outch(RPAREN);      /* " ) " */
  1122.     outgo(lab);         /* " goto lab " */
  1123. }
  1124.  
  1125. #ifdef F77
  1126. /*
  1127.  * ifthen - generate "if((...))then"
  1128.  *
  1129.  */
  1130. ifthen()
  1131. {
  1132.     outtab();
  1133.     outstr(sif);
  1134.     balpar();
  1135.     outstr(sthen);
  1136.     outdon();
  1137. }
  1138. #endif F77
  1139.  
  1140. /*
  1141.  * labelc - output statement number
  1142.  *
  1143.  */
  1144. labelc(lexstr)
  1145. char lexstr[];
  1146. {
  1147.  
  1148.     xfer = NO;   /* can't suppress goto's now */
  1149.     if (strlen(lexstr) == 5)   /* warn about 23xxx labels */
  1150.         if (atoi(lexstr) >= startlab)
  1151.             synerr("warning: possible label conflict.");
  1152.     outstr(lexstr);
  1153.     outtab();
  1154. }
  1155.  
  1156. /*
  1157.  * labgen - generate  n  consecutive labels, return first one
  1158.  *
  1159.  */
  1160. int
  1161. labgen(n)
  1162. int n;
  1163. {
  1164.     int i;
  1165.  
  1166.     i = label;
  1167.     label = label + n;
  1168.     return(i);
  1169. }
  1170.  
  1171. /*
  1172.  * otherc - output ordinary Fortran statement
  1173.  *
  1174.  */
  1175. otherc(lexstr)
  1176. char lexstr[];
  1177. {
  1178.     xfer = NO;
  1179.     outtab();
  1180.     outstr(lexstr);
  1181.     eatup();
  1182.     outdon();
  1183. }
  1184.  
  1185. /*
  1186.  * outch - put one char into output buffer
  1187.  *
  1188.  */
  1189. outch(c)
  1190. char c;
  1191. {
  1192.     int i;
  1193.  
  1194.     if (outp >= 72) {   /* continuation card */
  1195.         outdon();
  1196.         for (i = 0; i < 6; i++)
  1197.             outbuf[i] = BLANK;
  1198.         outp = 6;
  1199.     }
  1200.     outbuf[outp] = c;
  1201.     outp++;
  1202. }
  1203.  
  1204. /*
  1205.  * outcon - output "n   continue"
  1206.  *
  1207.  */
  1208. outcon(n)
  1209. int n;
  1210. {
  1211.     xfer = NO;
  1212.     if (n <= 0 && outp == 0)
  1213.         return;            /* don't need unlabeled continues */
  1214.     if (n > 0)
  1215.         outnum(n);
  1216.     outtab();
  1217.     outstr(contin);
  1218.     outdon();
  1219. }
  1220.  
  1221. /*
  1222.  * outdon - finish off an output line
  1223.  *
  1224.  */
  1225. outdon()
  1226. {
  1227.  
  1228.     outbuf[outp] = NEWLINE;
  1229.     outbuf[outp+1] = EOS;
  1230.     printf("%s", outbuf);
  1231.     outp = 0;
  1232. }
  1233.  
  1234. /*
  1235.  * outgo - output "goto  n"
  1236.  *
  1237.  */
  1238. outgo(n)
  1239. int n;
  1240. {
  1241.     if (xfer == YES)
  1242.         return;
  1243.     outtab();
  1244.     outstr(rgoto);
  1245.     outnum(n);
  1246.     outdon();
  1247. }
  1248.  
  1249. /*
  1250.  * outnum - output decimal number
  1251.  *
  1252.  */
  1253. outnum(n)
  1254. int n;
  1255. {
  1256.  
  1257.     char chars[MAXCHARS];
  1258.     int i, m;
  1259.  
  1260.     m = abs(n);
  1261.     i = -1;
  1262.     do {
  1263.         i++;
  1264.         chars[i] = (m % 10) + DIG0;
  1265.         m = m / 10;
  1266.     } 
  1267.     while (m > 0 && i < MAXCHARS);
  1268.     if (n < 0)
  1269.         outch(MINUS);
  1270.     for ( ; i >= 0; i--)
  1271.         outch(chars[i]);
  1272. }
  1273.  
  1274.  
  1275.  
  1276. /*
  1277.  * outstr - output string
  1278.  *
  1279.  */
  1280. outstr(str)
  1281. char str[];
  1282. {
  1283.     int i;
  1284.  
  1285.     for (i=0; str[i] != EOS; i++)
  1286.         outch(str[i]);
  1287. }
  1288.  
  1289. /*
  1290.  * outtab - get past column 6
  1291.  *
  1292.  */
  1293. outtab()
  1294. {
  1295.     while (outp < 6)
  1296.         outch(BLANK);
  1297. }
  1298.  
  1299.  
  1300. /*
  1301.  * repcod - generate code for beginning of repeat
  1302.  *
  1303.  */
  1304. repcod(lab)
  1305. int *lab;
  1306. {
  1307.  
  1308.     int tlab;
  1309.  
  1310.     tlab = *lab;
  1311.     outcon(0);   /* in case there was a label */
  1312.     tlab = labgen(3);
  1313.     outcon(tlab);
  1314.     *lab = ++tlab;        /* label to go on next's */
  1315. }
  1316.  
  1317. /*
  1318.  * retcod - generate code for return
  1319.  *
  1320.  */
  1321. retcod()
  1322. {
  1323.     char token[MAXTOK], t;
  1324.  
  1325.     t = gnbtok(token, MAXTOK);
  1326.     if (t != NEWLINE && t != SEMICOL && t != RBRACE) {
  1327.         pbstr(token);
  1328.         outtab();
  1329.         outstr(fcname);
  1330.         outch(EQUALS);
  1331.         eatup();
  1332.         outdon();
  1333.     }
  1334.     else if (t == RBRACE)
  1335.         pbstr(token);
  1336.     outtab();
  1337.     outstr(sret);
  1338.     outdon();
  1339.     xfer = YES;
  1340. }
  1341.  
  1342.  
  1343. /* strdcl - generate code for string declaration */
  1344. strdcl()
  1345. {
  1346.     char t, name[MAXNAME], init[MAXTOK];
  1347.     int i, len;
  1348.  
  1349.     t = gnbtok(name, MAXNAME);
  1350.     if (t != ALPHA)
  1351.         synerr("missing string name.");
  1352.     if (gnbtok(init, MAXTOK) != LPAREN) {  /* make size same as initial value */
  1353.         len = strlen(init) + 1;
  1354.         if (init[1] == SQUOTE || init[1] == DQUOTE)
  1355.             len = len - 2;
  1356.     }
  1357.     else {    /* form is string name(size) init */
  1358.         t = gnbtok(init, MAXTOK);
  1359.         i = 0;
  1360.         len = ctoi(init, &i);
  1361.         if (init[i] != EOS)
  1362.             synerr("invalid string size.");
  1363.         if (gnbtok(init, MAXTOK) != RPAREN)
  1364.             synerr("missing right paren.");
  1365.         else
  1366.             t = gnbtok(init, MAXTOK);
  1367.     }
  1368.     outtab();
  1369.     /*
  1370.     *   outstr(int);
  1371.     */
  1372.     outstr(name);
  1373.     outch(LPAREN);
  1374.     outnum(len);
  1375.     outch(RPAREN);
  1376.     outdon();
  1377.     outtab();
  1378.     outstr(dat);
  1379.     len = strlen(init) + 1;
  1380.     if (init[0] == SQUOTE || init[0] == DQUOTE) {
  1381.         init[len-1] = EOS;
  1382.         scopy(init, 1, init, 0);
  1383.         len = len - 2;
  1384.     }
  1385.     for (i = 1; i <= len; i++) {    /* put out variable names */
  1386.         outstr(name);
  1387.         outch(LPAREN);
  1388.         outnum(i);
  1389.         outch(RPAREN);
  1390.         if (i < len)
  1391.             outch(COMMA);
  1392.         else
  1393.             outch(SLASH);
  1394.         ;
  1395.     }
  1396.     for (i = 0; init[i] != EOS; i++) {    /* put out init */
  1397.         outnum(init[i]);
  1398.         outch(COMMA);
  1399.     }
  1400.     pbstr(eoss);    /* push back EOS for subsequent substitution */
  1401. }
  1402.  
  1403.  
  1404. /*
  1405.  * unstak - unstack at end of statement
  1406.  *
  1407.  */
  1408. unstak(sp, lextyp, labval, token)
  1409. int *sp;
  1410. int lextyp[];
  1411. int labval[];
  1412. char token;
  1413. {
  1414.     int tp;
  1415.  
  1416.     tp = *sp;
  1417.     for ( ; tp > 0; tp--) {
  1418.         if (lextyp[tp] == LBRACE)
  1419.             break;
  1420.         if (lextyp[tp] == LEXSWITCH)
  1421.             break;
  1422.         if (lextyp[tp] == LEXIF && token == LEXELSE)
  1423.             break;
  1424.         if (lextyp[tp] == LEXIF)
  1425. #ifdef F77
  1426.             ifend();
  1427. #else
  1428.             outcon(labval[tp]);
  1429. #endif F77
  1430.         else if (lextyp[tp] == LEXELSE) {
  1431.             if (*sp > 1)
  1432.                 tp--;
  1433. #ifdef F77
  1434.             ifend();
  1435. #else
  1436.             outcon(labval[tp]+1);
  1437. #endif F77
  1438.         }
  1439.         else if (lextyp[tp] == LEXDO)
  1440.             dostat(labval[tp]);
  1441.         else if (lextyp[tp] == LEXWHILE)
  1442.             whiles(labval[tp]);
  1443.         else if (lextyp[tp] == LEXFOR)
  1444.             fors(labval[tp]);
  1445.         else if (lextyp[tp] == LEXREPEAT)
  1446.             untils(labval[tp], token);
  1447.     }
  1448.     *sp = tp;
  1449. }
  1450.  
  1451. /*
  1452.  * untils - generate code for until or end of repeat
  1453.  *
  1454.  */
  1455. untils(lab, token)
  1456. int lab;
  1457. int token;
  1458. {
  1459.     char ptoken[MAXTOK];
  1460.  
  1461.     xfer = NO;
  1462.     outnum(lab);
  1463.     if (token == LEXUNTIL) {
  1464.         lex(ptoken);
  1465.         ifgo(lab-1);
  1466.     }
  1467.     else
  1468.         outgo(lab-1);
  1469.     outcon(lab+1);
  1470. }
  1471.  
  1472. /* 
  1473.  * whilec - generate code for beginning of while 
  1474.  *
  1475.  */
  1476. whilec(lab)
  1477. int *lab;
  1478. {
  1479.     int tlab;
  1480.  
  1481.     tlab = *lab;
  1482.     outcon(0);         /* unlabeled continue, in case there was a label */
  1483.     tlab = labgen(2);
  1484.     outnum(tlab);
  1485. #ifdef F77
  1486.     ifthen();
  1487. #else
  1488.     ifgo(tlab+1);
  1489. #endif F77
  1490.     *lab = tlab;
  1491. }
  1492.  
  1493. /* 
  1494.  * whiles - generate code for end of while 
  1495.  *
  1496.  */
  1497. whiles(lab)
  1498. int lab;
  1499. {
  1500.  
  1501.     outgo(lab);
  1502. #ifdef F77
  1503.     ifend();
  1504. #endif F77
  1505.     outcon(lab+1);
  1506. }
  1507.  
  1508. /*
  1509.  * E R R O R  M E S S A G E S 
  1510.  */
  1511.  
  1512. /*
  1513.  *  baderr - print error message, then die
  1514.  */
  1515. baderr(msg)
  1516. char msg[];
  1517. {
  1518.     synerr(msg);
  1519.     exit(1);
  1520. }
  1521.  
  1522. /*
  1523.  * error - print error message with one parameter, then die
  1524.  */
  1525. error(msg, s)
  1526. char *msg, *s;
  1527. {
  1528.     fprintf(stderr, msg,s);
  1529.     exit(1);
  1530. }
  1531.  
  1532. /* 
  1533.  * synerr - report Ratfor syntax error
  1534.  */
  1535. synerr(msg)
  1536. char *msg;
  1537. {
  1538.     char lc[MAXCHARS];
  1539.     int i;
  1540.  
  1541.     fprintf(stderr,errmsg);
  1542.     if (level >= 0)
  1543.         i = level;
  1544.     else
  1545.         i = 0;   /* for EOF errors */
  1546.     itoc(linect[i], lc, MAXCHARS);
  1547.     fprintf(stderr,lc);
  1548.     for (i = fnamp - 1; i > 1; i = i - 1)
  1549.         if (fnames[i-1] == EOS) {   /* print file name */
  1550.             fprintf(stderr,in);
  1551.             fprintf(stderr,&fnames[i]);
  1552.             break;
  1553.         }
  1554.     fprintf(stderr,": \n      %s\n",msg);
  1555. }
  1556.  
  1557.  
  1558. /*
  1559.  * U T I L I T Y  R O U T I N E S
  1560.  */
  1561.  
  1562. /*
  1563.  * ctoi - convert string at in[i] to int, increment i
  1564.  */
  1565. int
  1566. ctoi(in, i)
  1567. char in[];
  1568. int *i;
  1569. {
  1570.     int k, j;
  1571.  
  1572.     j = *i;
  1573.     while (in[j] == BLANK || in[j] == TAB)
  1574.         j++;
  1575.     for (k = 0; in[j] != EOS; j++) {
  1576.         if (in[j] < DIG0 || in[j] > DIG9)
  1577.             break;
  1578.         k = 10 * k + in[j] - DIG0;
  1579.     }
  1580.     *i = j;
  1581.     return(k);
  1582. }
  1583.  
  1584. /*
  1585.  * fold - convert alphabetic token to single case
  1586.  *
  1587.  */
  1588. fold(token)
  1589. char token[];
  1590. {
  1591.  
  1592.     int i;
  1593.  
  1594.     /* WARNING - this routine depends heavily on the */
  1595.     /* fact that letters have been mapped into internal */
  1596.     /* right-adjusted ascii. god help you if you */
  1597.     /* have subverted this mechanism. */
  1598.  
  1599.     for (i = 0; token[i] != EOS; i++)
  1600.         if (token[i] >= BIGA && token[i] <= BIGZ)
  1601.             token[i] = token[i] - BIGA + LETA;
  1602. }
  1603.  
  1604. /*
  1605.  * equal - compare str1 to str2; return YES if equal, NO if not
  1606.  *
  1607.  */
  1608. int
  1609. equal(str1, str2)
  1610. char str1[];
  1611. char str2[];
  1612. {
  1613.     int i;
  1614.  
  1615.     for (i = 0; str1[i] == str2[i]; i++)
  1616.         if (str1[i] == EOS)
  1617.             return(YES);
  1618.     return(NO);
  1619. }
  1620.  
  1621. /*
  1622.  * scopy - copy string at from[i] to to[j]
  1623.  *
  1624.  */
  1625. scopy(from, i, to, j)
  1626. char from[];
  1627. int i;
  1628. char to[];
  1629. int j;
  1630. {
  1631.     int k1, k2;
  1632.  
  1633.     k2 = j;
  1634.     for (k1 = i; from[k1] != EOS; k1++) {
  1635.         to[k2] = from[k1];
  1636.         k2++;
  1637.     }
  1638.     to[k2] = EOS;
  1639. }
  1640.  
  1641. #include "lookup.h"
  1642. /*
  1643.  * look - look-up a definition
  1644.  *
  1645.  */
  1646. int
  1647. look(name,defn)
  1648. char name[];
  1649. char defn[];
  1650. {
  1651.     extern struct hashlist *lookup();
  1652.     struct hashlist *p;
  1653.  
  1654.     if ((p = lookup(name)) == NULL)
  1655.         return(NO);
  1656.     (void) strcpy(defn,p->def);
  1657.     return(YES);
  1658. }
  1659.  
  1660. /*
  1661.  * itoc - special version of itoa
  1662.  */
  1663. int
  1664. itoc(n,str,size)
  1665. int n;
  1666. char str[];
  1667. int size;
  1668. {
  1669.     int i,j,k,sign;
  1670.     char c;
  1671.  
  1672.     if ((sign = n) < 0)
  1673.         n = -n;
  1674.     i = 0;
  1675.     do {
  1676.         str[i++] = n % 10 + '0'; 
  1677.     } 
  1678.     while ((n /= 10) > 0 && i < size-2);
  1679.     if (sign < 0 && i < size-1)
  1680.         str[i++] = '-';
  1681.     str[i] = EOS;
  1682.     /*
  1683.      * reverse the string and plug it back in
  1684.      */
  1685.     for (j = 0, k = strlen(str) - 1; j < k; j++, k--) {
  1686.         c = str[j];
  1687.         str[j] = str[k];
  1688.         str[k] = c;
  1689.     }
  1690.     return(i-1);
  1691. }
  1692.  
  1693. /*
  1694.  * cascod - generate code for case or default label
  1695.  *
  1696.  */
  1697. cascod (lab, token)
  1698. int lab;
  1699. int token;
  1700. {
  1701.     int t, l, lb, ub, i, j, junk;
  1702.     char scrtok[MAXTOK];
  1703.  
  1704.     if (swtop <= 0) {
  1705.         synerr ("illegal case or default.");
  1706.         return;
  1707.     }
  1708.     outgo(lab + 1);        /* # terminate previous case */
  1709.     xfer = YES;
  1710.     l = labgen(1);
  1711.     if (token == LEXCASE) {     /* # case n[,n]... : ... */
  1712.         while (caslab (&lb, &t) != EOF) {
  1713.             ub = lb;
  1714.             if (t == MINUS)
  1715.                 junk = caslab (&ub, &t);
  1716.             if (lb > ub) {
  1717.                 synerr ("illegal range in case label.");
  1718.                 ub = lb;
  1719.             }
  1720.             if (swlast + 3 > MAXSWITCH)
  1721.                 baderr ("switch table overflow.");
  1722.             for (i = swtop + 3; i < swlast; i = i + 3)
  1723.                 if (lb <= swstak[i])
  1724.                     break;
  1725.                 else if (lb <= swstak[i+1])
  1726.                     synerr ("duplicate case label.");
  1727.             if (i < swlast && ub >= swstak[i])
  1728.                 synerr ("duplicate case label.");
  1729.             for (j = swlast; j > i; j--)       /* # insert new entry */
  1730.                 swstak[j+2] = swstak[j-1];
  1731.             swstak[i] = lb;
  1732.             swstak[i + 1] = ub;
  1733.             swstak[i + 2] = l;
  1734.             swstak[swtop + 1] = swstak[swtop + 1]  +  1;
  1735.             swlast = swlast + 3;
  1736.             if (t == COLON)
  1737.                 break;
  1738.             else if (t != COMMA)
  1739.                 synerr ("illegal case syntax.");
  1740.         }
  1741.     }
  1742.     else {                       /* # default : ... */
  1743.         t = gnbtok (scrtok, MAXTOK);
  1744.         if (swstak[swtop + 2] != 0)
  1745.             baderr ("multiple defaults in switch statement.");
  1746.         else
  1747.             swstak[swtop + 2] = l;
  1748.     }
  1749.  
  1750.     if (t == EOF)
  1751.         synerr ("unexpected EOF.");
  1752.     else if (t != COLON)
  1753.         baderr ("missing colon in case or default label.");
  1754.  
  1755.     xfer = NO;
  1756.     outcon (l);
  1757. }
  1758.  
  1759. /*
  1760.  * caslab - get one case label
  1761.  *
  1762.  */
  1763. int
  1764. caslab (n, t)
  1765. int *n; 
  1766. int *t;
  1767. {
  1768.     char tok[MAXTOK];
  1769.     int i, s;
  1770.  
  1771.     *t = gnbtok (tok, MAXTOK);
  1772.     while (*t == NEWLINE)
  1773.         *t = gnbtok (tok, MAXTOK);
  1774.     if (*t == EOF)
  1775.         return (*t);
  1776.     if (*t == MINUS)
  1777.         s = -1;
  1778.     else
  1779.         s = 1;
  1780.     if (*t == MINUS || *t == PLUS)
  1781.         *t = gnbtok (tok, MAXTOK);
  1782.     if (*t != DIGIT) {
  1783.         synerr ("invalid case label.");
  1784.         *n = 0;
  1785.     }
  1786.     else {
  1787.         i = 0;
  1788.         *n = s * ctoi (tok, &i);
  1789.     }
  1790.     *t = gnbtok (tok, MAXTOK);
  1791.     while (*t == NEWLINE)
  1792.         *t = gnbtok (tok, MAXTOK);
  1793. }
  1794.  
  1795. /*
  1796.  * swcode - generate code for switch stmt.
  1797.  *
  1798.  */
  1799. swcode (lab)
  1800. int *lab;
  1801. {
  1802.     char scrtok[MAXTOK];
  1803.  
  1804.     *lab = labgen (2);
  1805.     if (swlast + 3 > MAXSWITCH)
  1806.         baderr ("switch table overflow.");
  1807.     swstak[swlast] = swtop;
  1808.     swstak[swlast + 1] = 0;
  1809.     swstak[swlast + 2] = 0;
  1810.     swtop = swlast;
  1811.     swlast = swlast + 3;
  1812.     xfer = NO;
  1813.     outtab();      /* # Innn=(e) */
  1814.     swvar(*lab);
  1815.     outch(EQUALS);
  1816.     balpar();
  1817.     outdon();
  1818.     outgo(*lab);     /* # goto L */
  1819.     xfer = YES;
  1820.     while (gnbtok (scrtok, MAXTOK) == NEWLINE)
  1821.         ;
  1822.     if (scrtok[0] != LBRACE) {
  1823.         synerr ("missing left brace in switch statement.");
  1824.         pbstr (scrtok);
  1825.     }
  1826. }
  1827.  
  1828. /*
  1829.  * swend  - finish off switch statement; generate dispatch code
  1830.  *
  1831.  */
  1832. swend(lab)
  1833. int lab;
  1834. {
  1835.     int lb, ub, n, i, j;
  1836.  
  1837. static    char *sif       = "if (";
  1838. static    char *slt       = ".lt.1.or.";
  1839. static    char *sgt       = ".gt.";
  1840. static    char *sgoto     = "goto (";
  1841. static    char *seq       = ".eq.";
  1842. static    char *sge       = ".ge.";
  1843. static    char *sle       = ".le.";
  1844. static    char *sand      = ".and.";
  1845.  
  1846.     lb = swstak[swtop + 3];
  1847.     ub = swstak[swlast - 2];
  1848.     n = swstak[swtop + 1];
  1849.     outgo(lab + 1);             /* # terminate last case */
  1850.     if (swstak[swtop + 2] == 0)
  1851.         swstak[swtop + 2] = lab + 1;    /* # default default label */
  1852.     xfer = NO;
  1853.     outcon (lab);              /*  L   continue */
  1854.     /* output branch table */
  1855.     if (n >= CUTOFF && ub - lb < DENSITY * n) {  
  1856.         if (lb != 0) {            /* L  Innn=Innn-lb */
  1857.             outtab();
  1858.             swvar  (lab);
  1859.             outch (EQUALS);
  1860.             swvar  (lab);
  1861.             if (lb < 0)
  1862.                 outch (PLUS);
  1863.             outnum (-lb + 1);
  1864.             outdon();
  1865.         }
  1866.         outtab();  /*  if (Innn.lt.1.or.Innn.gt.ub-lb+1)goto default */
  1867.         outstr (sif);
  1868.         swvar  (lab);
  1869.         outstr (slt);
  1870.         swvar  (lab);
  1871.         outstr (sgt);
  1872.         outnum (ub - lb + 1);
  1873.         outch (RPAREN);
  1874.         outgo (swstak[swtop + 2]);
  1875.         outtab();
  1876.         outstr (sgoto);        /* goto ... */
  1877.         j = lb;
  1878.         for (i = swtop + 3; i < swlast; i = i + 3) {
  1879.             /* # fill in vacancies */
  1880.             for ( ; j < swstak[i]; j++) {
  1881.                 outnum(swstak[swtop + 2]);
  1882.                 outch(COMMA);
  1883.             }
  1884.             for (j = swstak[i + 1] - swstak[i]; j >= 0; j--)
  1885.                 outnum(swstak[i + 2]);    /* # fill in range */
  1886.             j = swstak[i + 1] + 1;
  1887.             if (i < swlast - 3) 
  1888.                 outch(COMMA);
  1889.         }
  1890.         outch(RPAREN);
  1891.         outch(COMMA);
  1892.         swvar(lab);
  1893.         outdon();
  1894.     }
  1895.     else if (n > 0) {         /* # output linear search form */
  1896.         for (i = swtop + 3; i < swlast; i = i + 3) {
  1897.             outtab();        /* # if (Innn */
  1898.             outstr (sif);
  1899.             swvar  (lab);
  1900.             if (swstak[i] == swstak[i+1]) {
  1901.                 outstr (seq);     /* #   .eq....*/
  1902.                 outnum (swstak[i]);
  1903.             }
  1904.             else {
  1905.                 outstr (sge);    /* #   .ge.lb.and.Innn.le.ub */
  1906.                 outnum (swstak[i]);
  1907.                 outstr (sand);
  1908.                 swvar  (lab);
  1909.                 outstr (sle);
  1910.                 outnum (swstak[i + 1]);
  1911.             }
  1912.             outch (RPAREN);        /* #    ) goto ... */
  1913.             outgo (swstak[i + 2]);
  1914.         }
  1915.         if (lab + 1 != swstak[swtop + 2])
  1916.             outgo (swstak[swtop + 2]);
  1917.     }
  1918.     outcon (lab + 1);               /* # L+1  continue */
  1919.     swlast = swtop;                /* # pop switch stack */
  1920.     swtop = swstak[swtop];
  1921. }
  1922.  
  1923. /*
  1924.  * swvar  - output switch variable Innn, where nnn = lab
  1925.  */
  1926. swvar  (lab)
  1927. int lab;
  1928. {
  1929.  
  1930.     outch ('I');
  1931.     outnum (lab);
  1932. }
  1933.