00001
00002
00003
00004
00005
00006
00007
00008
00009
00010
00011
00012
00013
00014
00015
00016
00017
00018
00019
00020
00021
00022
00023
00024 #include "defs.h"
00025 #include "tokdefs.h"
00026 #include "p1defs.h"
00027
00028 #ifdef NO_EOF_CHAR_CHECK
00029 #undef EOF_CHAR
00030 #else
00031 #ifndef EOF_CHAR
00032 #define EOF_CHAR 26
00033 #endif
00034 #endif
00035
00036 #define BLANK ' '
00037 #define MYQUOTE (2)
00038 #define SEOF 0
00039
00040
00041
00042 #define STEOF 1
00043 #define STINITIAL 2
00044 #define STCONTINUE 3
00045
00046
00047
00048 #define NEWSTMT 1
00049 #define FIRSTTOKEN 2
00050 #define OTHERTOKEN 3
00051 #define RETEOS 4
00052
00053
00054 LOCAL int stkey;
00055 static int needwkey;
00056 ftnint yystno;
00057 flag intonly;
00058 extern int new_dcl;
00059 LOCAL long int stno;
00060 LOCAL long int nxtstno;
00061 LOCAL int parlev;
00062 LOCAL int parseen;
00063 LOCAL int expcom;
00064 LOCAL int expeql;
00065 LOCAL char *nextch;
00066 LOCAL char *lastch;
00067 LOCAL char *nextcd = NULL;
00068 LOCAL char *endcd;
00069 LOCAL long prevlin;
00070 LOCAL long thislin;
00071 LOCAL int code;
00072 LOCAL int lexstate = NEWSTMT;
00073 LOCAL char *sbuf;
00074 LOCAL char *send;
00075 LOCAL int maxcont;
00076 LOCAL int nincl = 0;
00077 LOCAL long firstline;
00078 LOCAL char *laststb, *stb0;
00079 extern int addftnsrc;
00080 static char **linestart;
00081 LOCAL int ncont;
00082 LOCAL char comstart[Table_size];
00083 #define USC (unsigned char *)
00084
00085 static char anum_buf[Table_size];
00086 #define isalnum_(x) anum_buf[x]
00087 #define isalpha_(x) (anum_buf[x] == 1)
00088
00089 #define COMMENT_BUF_STORE 4088
00090
00091 typedef struct comment_buf {
00092 struct comment_buf *next;
00093 char *last;
00094 char buf[COMMENT_BUF_STORE];
00095 } comment_buf;
00096 static comment_buf *cbfirst, *cbcur;
00097 static char *cbinit, *cbnext, *cblast;
00098 static void flush_comments Argdcl((void));
00099 extern flag use_bs;
00100 static char *lastfile = "??", *lastfile0 = "?";
00101 static char fbuf[P1_FILENAME_MAX];
00102 static long lastline;
00103 static void putlineno(Void);
00104
00105
00106
00107
00108
00109
00110
00111
00112
00113
00114
00115
00116
00117
00118 struct Inclfile
00119 {
00120 struct Inclfile *inclnext;
00121 FILEP inclfp;
00122 char *inclname;
00123 int incllno;
00124 char *incllinp;
00125 int incllen;
00126 int inclcode;
00127 ftnint inclstno;
00128 };
00129
00130 LOCAL struct Inclfile *inclp = NULL;
00131 struct Keylist {
00132 char *keyname;
00133 int keyval;
00134 char notinf66;
00135 };
00136 struct Punctlist {
00137 char punchar;
00138 int punval;
00139 };
00140 struct Fmtlist {
00141 char fmtchar;
00142 int fmtval;
00143 };
00144 struct Dotlist {
00145 char *dotname;
00146 int dotval;
00147 };
00148 LOCAL struct Keylist *keystart[26], *keyend[26];
00149
00150
00151
00152
00153 static struct Punctlist puncts[ ] =
00154 {
00155 '(', SLPAR,
00156 ')', SRPAR,
00157 '=', SEQUALS,
00158 ',', SCOMMA,
00159 '+', SPLUS,
00160 '-', SMINUS,
00161 '*', SSTAR,
00162 '/', SSLASH,
00163 '$', SCURRENCY,
00164 ':', SCOLON,
00165 '<', SLT,
00166 '>', SGT,
00167 0, 0 };
00168
00169 LOCAL struct Dotlist dots[ ] =
00170 {
00171 "and.", SAND,
00172 "or.", SOR,
00173 "not.", SNOT,
00174 "true.", STRUE,
00175 "false.", SFALSE,
00176 "eq.", SEQ,
00177 "ne.", SNE,
00178 "lt.", SLT,
00179 "le.", SLE,
00180 "gt.", SGT,
00181 "ge.", SGE,
00182 "neqv.", SNEQV,
00183 "eqv.", SEQV,
00184 0, 0 };
00185
00186 LOCAL struct Keylist keys[ ] =
00187 {
00188 { "assign", SASSIGN },
00189 { "automatic", SAUTOMATIC, YES },
00190 { "backspace", SBACKSPACE },
00191 { "blockdata", SBLOCK },
00192 { "byte", SBYTE },
00193 { "call", SCALL },
00194 { "character", SCHARACTER, YES },
00195 { "close", SCLOSE, YES },
00196 { "common", SCOMMON },
00197 { "complex", SCOMPLEX },
00198 { "continue", SCONTINUE },
00199 { "data", SDATA },
00200 { "dimension", SDIMENSION },
00201 { "doubleprecision", SDOUBLE },
00202 { "doublecomplex", SDCOMPLEX, YES },
00203 { "elseif", SELSEIF, YES },
00204 { "else", SELSE, YES },
00205 { "endfile", SENDFILE },
00206 { "endif", SENDIF, YES },
00207 { "enddo", SENDDO, YES },
00208 { "end", SEND },
00209 { "entry", SENTRY, YES },
00210 { "equivalence", SEQUIV },
00211 { "external", SEXTERNAL },
00212 { "format", SFORMAT },
00213 { "function", SFUNCTION },
00214 { "goto", SGOTO },
00215 { "implicit", SIMPLICIT, YES },
00216 { "include", SINCLUDE, YES },
00217 { "inquire", SINQUIRE, YES },
00218 { "intrinsic", SINTRINSIC, YES },
00219 { "integer", SINTEGER },
00220 { "logical", SLOGICAL },
00221 { "namelist", SNAMELIST, YES },
00222 { "none", SUNDEFINED, YES },
00223 { "open", SOPEN, YES },
00224 { "parameter", SPARAM, YES },
00225 { "pause", SPAUSE },
00226 { "print", SPRINT },
00227 { "program", SPROGRAM, YES },
00228 { "punch", SPUNCH, YES },
00229 { "read", SREAD },
00230 { "real", SREAL },
00231 { "return", SRETURN },
00232 { "rewind", SREWIND },
00233 { "save", SSAVE, YES },
00234 { "static", SSTATIC, YES },
00235 { "stop", SSTOP },
00236 { "subroutine", SSUBROUTINE },
00237 { "then", STHEN, YES },
00238 { "undefined", SUNDEFINED, YES },
00239 { "while", SWHILE, YES },
00240 { "write", SWRITE },
00241 { 0, 0 }
00242 };
00243
00244 static void analyz Argdcl((void));
00245 static void crunch Argdcl((void));
00246 static int getcd Argdcl((char*, int));
00247 static int getcds Argdcl((void));
00248 static int getkwd Argdcl((void));
00249 static int gettok Argdcl((void));
00250 static void store_comment Argdcl((char*));
00251 LOCAL char *stbuf[3];
00252
00253 int
00254 #ifdef KR_headers
00255 inilex(name)
00256 char *name;
00257 #else
00258 inilex(char *name)
00259 #endif
00260 {
00261 stbuf[0] = Alloc(3*P1_STMTBUFSIZE);
00262 stbuf[1] = stbuf[0] + P1_STMTBUFSIZE;
00263 stbuf[2] = stbuf[1] + P1_STMTBUFSIZE;
00264 nincl = 0;
00265 inclp = NULL;
00266 doinclude(name);
00267 lexstate = NEWSTMT;
00268 return(NO);
00269 }
00270
00271
00272
00273
00274 void
00275 flline(Void)
00276 {
00277 lexstate = RETEOS;
00278 }
00279
00280
00281
00282 char *
00283 #ifdef KR_headers
00284 lexline(n)
00285 int *n;
00286 #else
00287 lexline(int *n)
00288 #endif
00289 {
00290 *n = (lastch - nextch) + 1;
00291 return(nextch);
00292 }
00293
00294
00295
00296
00297 void
00298 #ifdef KR_headers
00299 doinclude(name)
00300 char *name;
00301 #else
00302 doinclude(char *name)
00303 #endif
00304 {
00305 FILEP fp;
00306 struct Inclfile *t;
00307 char *name0, *lastslash, *s, *s0, *temp;
00308 int j, k;
00309 chainp I;
00310 extern chainp Iargs;
00311
00312 err_lineno = -1;
00313 if(inclp)
00314 {
00315 inclp->incllno = thislin;
00316 inclp->inclcode = code;
00317 inclp->inclstno = nxtstno;
00318 if(nextcd && (j = endcd - nextcd) > 0)
00319 inclp->incllinp = copyn(inclp->incllen = j, nextcd);
00320 else
00321 inclp->incllinp = 0;
00322 }
00323 nextcd = NULL;
00324
00325 if(++nincl >= MAXINCLUDES)
00326 Fatal("includes nested too deep");
00327 if(name[0] == '\0')
00328 fp = stdin;
00329 else if(name[0] == '/' || inclp == NULL
00330 #ifdef MSDOS
00331 || name[0] == '\\'
00332 || name[1] == ':'
00333 #endif
00334 )
00335 fp = fopen(name, textread);
00336 else {
00337 lastslash = NULL;
00338 s = s0 = inclp->inclname;
00339 #ifdef MSDOS
00340 if (s[1] == ':')
00341 lastslash = s + 1;
00342 #endif
00343 for(; *s ; ++s)
00344 if(*s == '/'
00345 #ifdef MSDOS
00346 || *s == '\\'
00347 #endif
00348 )
00349 lastslash = s;
00350 name0 = name;
00351 if(lastslash) {
00352 k = lastslash - s0 + 1;
00353 temp = Alloc(k + strlen(name) + 1);
00354 strncpy(temp, s0, k);
00355 strcpy(temp+k, name);
00356 name = temp;
00357 }
00358 fp = fopen(name, textread);
00359 if (!fp && (I = Iargs)) {
00360 k = strlen(name0) + 2;
00361 for(; I; I = I->nextp) {
00362 j = strlen(s = I->datap);
00363 name = Alloc(j + k);
00364 strcpy(name, s);
00365 switch(s[j-1]) {
00366 case '/':
00367 #ifdef MSDOS
00368 case ':':
00369 case '\\':
00370 #endif
00371 break;
00372 default:
00373 name[j++] = '/';
00374 }
00375 strcpy(name+j, name0);
00376 if (fp = fopen(name, textread)) {
00377 free(name0);
00378 goto havefp;
00379 }
00380 free(name);
00381 name = name0;
00382 }
00383 }
00384 }
00385 if (fp)
00386 {
00387 havefp:
00388 t = inclp;
00389 inclp = ALLOC(Inclfile);
00390 inclp->inclnext = t;
00391 prevlin = thislin = 0;
00392 infname = inclp->inclname = name;
00393 infile = inclp->inclfp = fp;
00394 lastline = 0;
00395 putlineno();
00396 lastline = 0;
00397 }
00398 else
00399 {
00400 fprintf(diagfile, "Cannot open file %s\n", name);
00401 done(1);
00402 }
00403 }
00404
00405
00406
00407
00408 LOCAL int
00409 popinclude(Void)
00410 {
00411 struct Inclfile *t;
00412 register char *p;
00413 register int k;
00414
00415 if(infile != stdin)
00416 clf(&infile, infname, 1);
00417 free(infname);
00418
00419 --nincl;
00420 err_lineno = -1;
00421 t = inclp->inclnext;
00422 free( (charptr) inclp);
00423 inclp = t;
00424 if(inclp == NULL) {
00425 infname = 0;
00426 return(NO);
00427 }
00428
00429 infile = inclp->inclfp;
00430 infname = inclp->inclname;
00431 lineno = prevlin = thislin = inclp->incllno;
00432 code = inclp->inclcode;
00433 stno = nxtstno = inclp->inclstno;
00434 if(inclp->incllinp)
00435 {
00436 lastline = 0;
00437 putlineno();
00438 lastline = lineno;
00439 endcd = nextcd = sbuf;
00440 k = inclp->incllen;
00441 p = inclp->incllinp;
00442 while(--k >= 0)
00443 *endcd++ = *p++;
00444 free( (charptr) (inclp->incllinp) );
00445 }
00446 else
00447 nextcd = NULL;
00448 return(YES);
00449 }
00450
00451
00452 void
00453 #ifdef KR_headers
00454 p1_line_number(line_number)
00455 long line_number;
00456 #else
00457 p1_line_number(long line_number)
00458 #endif
00459 {
00460 if (lastfile != lastfile0) {
00461 p1puts(P1_FILENAME, fbuf);
00462 lastfile0 = lastfile;
00463 }
00464 fprintf(pass1_file, "%d: %ld\n", P1_SET_LINE, line_number);
00465 }
00466
00467 static void
00468 putlineno(Void)
00469 {
00470 extern int gflag;
00471 register char *s0, *s1;
00472
00473 if (gflag) {
00474 if (lastline)
00475 p1_line_number(lastline);
00476 lastline = firstline;
00477 if (lastfile != infname)
00478 if (lastfile = infname) {
00479 strncpy(fbuf, lastfile, sizeof(fbuf));
00480 fbuf[sizeof(fbuf)-1] = 0;
00481 }
00482 else
00483 fbuf[0] = 0;
00484 }
00485 if (addftnsrc) {
00486 if (laststb && *laststb) {
00487 for(s1 = laststb; *s1; s1++) {
00488 for(s0 = s1; *s1 != '\n'; s1++)
00489 if (*s1 == '*' && s1[1] == '/')
00490 *s1 = '+';
00491 *s1 = 0;
00492 p1puts(P1_FORTRAN, s0);
00493 }
00494 *laststb = 0;
00495 }
00496 laststb = stb0;
00497 }
00498 }
00499
00500 int
00501 yylex(Void)
00502 {
00503 static int tokno;
00504 int retval;
00505
00506 switch(lexstate)
00507 {
00508 case NEWSTMT :
00509 retval = getcds();
00510 putlineno();
00511 if(retval == STEOF) {
00512 retval = SEOF;
00513 break;
00514 }
00515 crunch();
00516 tokno = 0;
00517 lexstate = FIRSTTOKEN;
00518 yystno = stno;
00519 stno = nxtstno;
00520 toklen = 0;
00521 retval = SLABEL;
00522 break;
00523
00524 first:
00525 case FIRSTTOKEN :
00526 analyz();
00527 lexstate = OTHERTOKEN;
00528 tokno = 1;
00529 retval = stkey;
00530 break;
00531
00532 case OTHERTOKEN :
00533 if(nextch > lastch)
00534 goto reteos;
00535 ++tokno;
00536 if( (stkey==SLOGIF || stkey==SELSEIF) && parlev==0 && tokno>3)
00537 goto first;
00538
00539 if(stkey==SASSIGN && tokno==3 && nextch<lastch &&
00540 nextch[0]=='t' && nextch[1]=='o')
00541 {
00542 nextch+=2;
00543 retval = STO;
00544 break;
00545 }
00546 retval = gettok();
00547 break;
00548
00549 reteos:
00550 case RETEOS:
00551 lexstate = NEWSTMT;
00552 retval = SEOS;
00553 break;
00554 default:
00555 fatali("impossible lexstate %d", lexstate);
00556 break;
00557 }
00558
00559 if (retval == SEOF)
00560 flush_comments ();
00561
00562 return retval;
00563 }
00564
00565 LOCAL void
00566 contmax(Void)
00567 {
00568 lineno = thislin;
00569 many("continuation lines", 'C', maxcontin);
00570 }
00571
00572
00573
00574
00575
00576
00577 LOCAL int
00578 getcds(Void)
00579 {
00580 register char *p, *q;
00581
00582 flush_comments ();
00583 top:
00584 if(nextcd == NULL)
00585 {
00586 code = getcd( nextcd = sbuf, 1 );
00587 stno = nxtstno;
00588 prevlin = thislin;
00589 }
00590 if(code == STEOF)
00591 if( popinclude() )
00592 goto top;
00593 else
00594 return(STEOF);
00595
00596 if(code == STCONTINUE)
00597 {
00598 lineno = thislin;
00599 nextcd = NULL;
00600 goto top;
00601 }
00602
00603
00604
00605 if(nextcd > sbuf)
00606 {
00607 q = nextcd;
00608 p = sbuf;
00609 while(q < endcd)
00610 *p++ = *q++;
00611 endcd = p;
00612 }
00613
00614
00615
00616
00617
00618
00619
00620
00621 ncont = 0;
00622 for(;;) {
00623 nextcd = endcd;
00624 if (ncont >= maxcont || nextcd+66 > send)
00625 contmax();
00626 linestart[ncont++] = nextcd;
00627 if ((code = getcd(nextcd,0)) != STCONTINUE)
00628 break;
00629 if (ncont == 20 && noextflag) {
00630 lineno = thislin;
00631 errext("more than 19 continuation lines");
00632 }
00633 }
00634 nextch = sbuf;
00635 lastch = nextcd - 1;
00636
00637 lineno = prevlin;
00638 prevlin = thislin;
00639 return(STINITIAL);
00640 }
00641
00642 static void
00643 #ifdef KR_headers
00644 bang(a, b, c, d, e)
00645 char *a;
00646 char *b;
00647 char *c;
00648 register char *d;
00649 register char *e;
00650 #else
00651 bang(char *a, char *b, char *c, register char *d, register char *e)
00652 #endif
00653
00654 {
00655 char buf[COMMENT_BUFFER_SIZE + 1];
00656 register char *p, *pe;
00657
00658 p = buf;
00659 pe = buf + COMMENT_BUFFER_SIZE;
00660 *pe = 0;
00661 while(a < b)
00662 if (!(*p++ = *a++))
00663 p[-1] = 0;
00664 if (b < c)
00665 *p++ = '\t';
00666 while(d < e) {
00667 if (!(*p++ = *d++))
00668 p[-1] = ' ';
00669 if (p == pe) {
00670 store_comment(buf);
00671 p = buf;
00672 }
00673 }
00674 if (p > buf) {
00675 while(--p >= buf && *p == ' ');
00676 p[1] = 0;
00677 store_comment(buf);
00678 }
00679 }
00680
00681
00682
00683
00684
00685
00686
00687 LOCAL int
00688 #ifdef KR_headers
00689 getcd(b, nocont)
00690 register char *b;
00691 int nocont;
00692 #else
00693 getcd(register char *b, int nocont)
00694 #endif
00695 {
00696 register int c;
00697 register char *p, *bend;
00698 int speclin;
00699
00700
00701
00702 static char a[6];
00703 static char *aend = a+6;
00704 static char *stb, *stbend;
00705 static int nst;
00706 char *atend, *endcd0;
00707 extern int warn72;
00708 char buf72[24];
00709 int amp, i;
00710 char storage[COMMENT_BUFFER_SIZE + 1];
00711 char *pointer;
00712 long L;
00713
00714 top:
00715 endcd = b;
00716 bend = b+66;
00717 amp = speclin = NO;
00718 atend = aend;
00719
00720
00721
00722
00723 if( (c = getc(infile)) == '&')
00724 {
00725 a[0] = c;
00726 a[1] = 0;
00727 a[5] = 'x';
00728 amp = speclin = YES;
00729 bend = send;
00730 p = aend;
00731 }
00732
00733
00734
00735 else if(comstart[c & (Table_size-1)])
00736 {
00737 if (feof (infile)
00738 #ifdef EOF_CHAR
00739 || c == EOF_CHAR
00740 #endif
00741 )
00742 return STEOF;
00743
00744 if (c == '#') {
00745 *endcd++ = c;
00746 while((c = getc(infile)) != '\n')
00747 if (c == EOF)
00748 return STEOF;
00749 else if (endcd < bend)
00750 *endcd++ = c;
00751 ++thislin;
00752 *endcd = 0;
00753 if (b[1] == ' ')
00754 p = b + 2;
00755 else if (!strncmp(b,"#line ",6))
00756 p = b + 6;
00757 else {
00758 bad_cpp:
00759 errstr("Bad # line: \"%s\"", b);
00760 goto top;
00761 }
00762 if (*p < '1' || *p > '9')
00763 goto bad_cpp;
00764 L = *p - '0';
00765 while((c = *++p) >= '0' && c <= '9')
00766 L = 10*L + c - '0';
00767 if (c != ' ' || *++p != '"')
00768 goto bad_cpp;
00769 bend = p;
00770 while(*++p != '"')
00771 if (!*p)
00772 goto bad_cpp;
00773 *p = 0;
00774 i = p - bend++;
00775 thislin = L - 1;
00776 if (!infname || strcmp(infname, bend)) {
00777 if (infname)
00778 free(infname);
00779 lastfile = 0;
00780 infname = Alloc(i);
00781 strcpy(infname, bend);
00782 if (inclp)
00783 inclp->inclname = infname;
00784 }
00785 goto top;
00786 }
00787
00788 storage[COMMENT_BUFFER_SIZE] = c = '\0';
00789 pointer = storage;
00790 while( !feof (infile) && (*pointer++ = c = getc(infile)) != '\n') {
00791
00792
00793
00794 if (feof (infile) && (c == '\377' || c == EOF)) {
00795 pointer--;
00796 break;
00797 }
00798
00799 if (c == '\0')
00800 *(pointer - 1) = ' ';
00801
00802 if (pointer == &storage[COMMENT_BUFFER_SIZE]) {
00803 store_comment (storage);
00804 pointer = storage;
00805 }
00806 }
00807
00808 if (pointer > storage) {
00809 if (c == '\n')
00810
00811
00812
00813 pointer[-1] = 0;
00814 else
00815 *pointer = 0;
00816
00817 store_comment (storage);
00818 }
00819
00820 if (feof (infile))
00821 if (c != '\n')
00822
00823 return STEOF;
00824
00825 ++thislin;
00826 goto top;
00827 }
00828
00829 else if(c != EOF)
00830 {
00831
00832
00833
00834
00835 ungetc(c, infile);
00836 for(p=a; p<aend && (c=getc(infile)) != '\n' && c!=EOF; )
00837 if(c == '\t')
00838
00839
00840
00841 {
00842 atend = p;
00843 while(p < aend)
00844 *p++ = BLANK;
00845 speclin = YES;
00846 bend = send;
00847 }
00848 else
00849 *p++ = c;
00850 }
00851
00852
00853
00854
00855 if(c == EOF)
00856 return(STEOF);
00857
00858
00859
00860 if(c == '\n')
00861 {
00862 while(p < aend)
00863 *p++ = BLANK;
00864
00865
00866
00867 endcd0 = endcd;
00868 if( ! speclin )
00869 while(endcd < bend)
00870 *endcd++ = BLANK;
00871 }
00872 else {
00873 if (warn72 & 2) {
00874 speclin = YES;
00875 bend = send;
00876 }
00877 while( endcd<bend && (c=getc(infile)) != '\n' && c!=EOF )
00878 *endcd++ = c;
00879 if(c == EOF)
00880 return(STEOF);
00881
00882
00883
00884
00885 if(c != '\n')
00886 {
00887 i = 0;
00888 while( (c=getc(infile)) != '\n' && c != EOF)
00889 if (i < 23)
00890 buf72[i++] = c;
00891 if (warn72 && i && !speclin) {
00892 buf72[i] = 0;
00893 if (i >= 23)
00894 strcpy(buf72+20, "...");
00895 lineno = thislin + 1;
00896 errstr("text after column 72: %s", buf72);
00897 }
00898 if(c == EOF)
00899 return(STEOF);
00900 }
00901
00902 endcd0 = endcd;
00903 if( ! speclin )
00904 while(endcd < bend)
00905 *endcd++ = BLANK;
00906 }
00907
00908
00909
00910
00911 ++thislin;
00912
00913
00914
00915
00916 if( !isspace(a[5]) && a[5]!='0') {
00917 if (!amp)
00918 for(p = a; p < aend;)
00919 if (*p++ == '!' && p != aend)
00920 goto initcheck;
00921 if (addftnsrc && stb) {
00922 if (stbend > stb + 7) {
00923
00924 *stb++ = '$';
00925 if (amp)
00926 *stb++ = '&';
00927 else
00928 for(p = a; p < atend;)
00929 *stb++ = *p++;
00930 }
00931 if (endcd0 - b > stbend - stb) {
00932 if (stb > stbend)
00933 stb = stbend;
00934 endcd0 = b + (stbend - stb);
00935 }
00936 for(p = b; p < endcd0;)
00937 *stb++ = *p++;
00938 *stb++ = '\n';
00939 *stb = 0;
00940 }
00941 if (nocont) {
00942 lineno = thislin;
00943 errstr("illegal continuation card (starts \"%.6s\")",a);
00944 }
00945 else if (!amp && strncmp(a," ",5)) {
00946 lineno = thislin;
00947 errstr("labeled continuation line (starts \"%.6s\")",a);
00948 }
00949 return(STCONTINUE);
00950 }
00951 initcheck:
00952 for(p=a; p<atend; ++p)
00953 if( !isspace(*p) ) {
00954 if (*p++ != '!')
00955 goto initline;
00956 bang(p, atend, aend, b, endcd);
00957 goto top;
00958 }
00959 for(p = b ; p<endcd ; ++p)
00960 if( !isspace(*p) ) {
00961 if (*p++ != '!')
00962 goto initline;
00963 bang(a, a, a, p, endcd);
00964 goto top;
00965 }
00966
00967
00968
00969 goto top;
00970
00971 initline:
00972 if (!lastline)
00973 lastline = thislin;
00974 if (addftnsrc) {
00975 nst = (nst+1)%3;
00976 if (!laststb && stb0)
00977 laststb = stb0;
00978 stb0 = stb = stbuf[nst];
00979 *stb++ = '$';
00980 stbend = stb + sizeof(stbuf[0])-2;
00981 for(p = a; p < atend;)
00982 *stb++ = *p++;
00983 if (atend < aend)
00984 *stb++ = '\t';
00985 for(p = b; p < endcd0;)
00986 *stb++ = *p++;
00987 *stb++ = '\n';
00988 *stb = 0;
00989 }
00990
00991
00992
00993 nxtstno = 0;
00994 bend = a + 5;
00995 for(p = a ; p < bend ; ++p)
00996 if( !isspace(*p) )
00997 if(isdigit(*p))
00998 nxtstno = 10*nxtstno + (*p - '0');
00999 else if (*p == '!') {
01000 if (!addftnsrc)
01001 bang(p+1,atend,aend,b,endcd);
01002 endcd = b;
01003 break;
01004 }
01005 else {
01006 lineno = thislin;
01007 errstr(
01008 "nondigit in statement label field \"%.5s\"", a);
01009 nxtstno = 0;
01010 break;
01011 }
01012 firstline = thislin;
01013 return(STINITIAL);
01014 }
01015
01016 LOCAL void
01017 #ifdef KR_headers
01018 adjtoklen(newlen)
01019 int newlen;
01020 #else
01021 adjtoklen(int newlen)
01022 #endif
01023 {
01024 while(maxtoklen < newlen)
01025 maxtoklen = 2*maxtoklen + 2;
01026 if (token = (char *)realloc(token, maxtoklen))
01027 return;
01028 fprintf(stderr, "adjtoklen: realloc(%d) failure!\n", maxtoklen);
01029 exit(2);
01030 }
01031
01032
01033
01034
01035 LOCAL void
01036 crunch(Void)
01037 {
01038 register char *i, *j, *j0, *j1, *prvstr;
01039 int k, ten, nh, nh0, quote;
01040
01041
01042
01043
01044 new_dcl = needwkey = parlev = parseen = 0;
01045 expcom = 0;
01046 expeql = 0;
01047 j = sbuf;
01048 prvstr = sbuf;
01049 k = 0;
01050 for(i=sbuf ; i<=lastch ; ++i)
01051 {
01052 if(isspace(*i) )
01053 continue;
01054 if (*i == '!') {
01055 while(i >= linestart[k])
01056 if (++k >= maxcont)
01057 contmax();
01058 j0 = linestart[k];
01059 if (!addftnsrc)
01060 bang(sbuf,sbuf,sbuf,i+1,j0);
01061 i = j0-1;
01062 continue;
01063 }
01064
01065
01066
01067 if(*i=='\'' || *i=='"')
01068 {
01069 int len = 0;
01070
01071 quote = *i;
01072 *j = MYQUOTE;
01073 for(;;)
01074 {
01075 if(++i > lastch)
01076 {
01077 err("unbalanced quotes; closing quote supplied");
01078 if (j >= lastch)
01079 j = lastch - 1;
01080 break;
01081 }
01082 if(*i == quote)
01083 if(i<lastch && i[1]==quote) ++i;
01084 else break;
01085 else if(*i=='\\' && i<lastch && use_bs) {
01086 ++i;
01087 *i = escapes[*(unsigned char *)i];
01088 }
01089 *++j = *i;
01090 len++;
01091 }
01092
01093 if ((len = j - sbuf) > maxtoklen)
01094 adjtoklen(len);
01095 j[1] = MYQUOTE;
01096 j += 2;
01097 prvstr = j;
01098 }
01099 else if( (*i=='h' || *i=='H') && j>prvstr)
01100 {
01101 j0 = j - 1;
01102 if( ! isdigit(*j0)) goto copychar;
01103 nh = *j0 - '0';
01104 ten = 10;
01105 j1 = prvstr;
01106 if (j1+4 < j)
01107 j1 = j-4;
01108 for(;;) {
01109 if (j0-- <= j1)
01110 goto copychar;
01111 if( ! isdigit(*j0 ) ) break;
01112 nh += ten * (*j0-'0');
01113 ten*=10;
01114 }
01115
01116
01117
01118
01119
01120 if( !(*j0=='*'&&sbuf[0]=='d') && *j0!='/'
01121 && *j0!='(' && *j0!=',' && *j0!='=' && *j0!='.')
01122 goto copychar;
01123 nh0 = nh;
01124 if(i+nh > lastch)
01125 {
01126 erri("%dH too big", nh);
01127 nh = lastch - i;
01128 nh0 = -1;
01129 }
01130 if (nh > maxtoklen)
01131 adjtoklen(nh);
01132 j0[1] = MYQUOTE;
01133 j = j0 + 1;
01134 while(nh-- > 0)
01135 {
01136 if (++i > lastch) {
01137 hol_overflow:
01138 if (nh0 >= 0)
01139 erri("escapes make %dH too big",
01140 nh0);
01141 break;
01142 }
01143 if(*i == '\\' && use_bs) {
01144 if (++i > lastch)
01145 goto hol_overflow;
01146 *i = escapes[*(unsigned char *)i];
01147 }
01148 *++j = *i;
01149 }
01150 j[1] = MYQUOTE;
01151 j+=2;
01152 prvstr = j;
01153 }
01154 else {
01155 if(*i == '(') parseen = ++parlev;
01156 else if(*i == ')') --parlev;
01157 else if(parlev == 0)
01158 if(*i == '=') expeql = 1;
01159 else if(*i == ',') expcom = 1;
01160 copychar:
01161 if(shiftcase && isupper(*i))
01162 *j++ = tolower(*i);
01163 else *j++ = *i;
01164 }
01165 }
01166 lastch = j - 1;
01167 nextch = sbuf;
01168 }
01169
01170 LOCAL void
01171 analyz(Void)
01172 {
01173 register char *i;
01174
01175 if(parlev != 0)
01176 {
01177 err("unbalanced parentheses, statement skipped");
01178 stkey = SUNKNOWN;
01179 lastch = sbuf - 1;
01180 return;
01181 }
01182 if(nextch+2<=lastch && nextch[0]=='i' && nextch[1]=='f' && nextch[2]=='(')
01183 {
01184
01185 parlev = 1;
01186 for(i=nextch+3 ; i<=lastch; ++i)
01187 if(*i == (MYQUOTE))
01188 {
01189 while(*++i != MYQUOTE)
01190 ;
01191 }
01192 else if(*i == '(')
01193 ++parlev;
01194 else if(*i == ')')
01195 {
01196 if(--parlev == 0)
01197 break;
01198 }
01199 if(i >= lastch)
01200 stkey = SLOGIF;
01201 else if(i[1] == '=')
01202 stkey = SLET;
01203 else if( isdigit(i[1]) )
01204 stkey = SARITHIF;
01205 else stkey = SLOGIF;
01206 if(stkey != SLET)
01207 nextch += 2;
01208 }
01209 else if(expeql)
01210 {
01211 if(expcom && nextch<lastch &&
01212 nextch[0]=='d' && nextch[1]=='o')
01213 {
01214 stkey = SDO;
01215 nextch += 2;
01216 }
01217 else stkey = SLET;
01218 }
01219 else if (parseen && nextch + 7 < lastch
01220 && nextch[2] != 'u'
01221 && nextch[0] == 'd' && nextch[1] == 'o'
01222 && ((nextch[2] >= '0' && nextch[2] <= '9')
01223 || nextch[2] == ','
01224 || nextch[2] == 'w'))
01225 {
01226 stkey = SDO;
01227 nextch += 2;
01228 needwkey = 1;
01229 }
01230
01231 else {
01232 stkey = getkwd();
01233 if(stkey==SGOTO && lastch>=nextch)
01234 if(nextch[0]=='(')
01235 stkey = SCOMPGOTO;
01236 else if(isalpha_(* USC nextch))
01237 stkey = SASGOTO;
01238 }
01239 parlev = 0;
01240 }
01241
01242
01243
01244 LOCAL int
01245 getkwd(Void)
01246 {
01247 register char *i, *j;
01248 register struct Keylist *pk, *pend;
01249 int k;
01250
01251 if(! isalpha_(* USC nextch) )
01252 return(SUNKNOWN);
01253 k = letter(nextch[0]);
01254 if(pk = keystart[k])
01255 for(pend = keyend[k] ; pk<=pend ; ++pk )
01256 {
01257 i = pk->keyname;
01258 j = nextch;
01259 while(*++i==*++j && *i!='\0')
01260 ;
01261 if(*i=='\0' && j<=lastch+1)
01262 {
01263 nextch = j;
01264 if(no66flag && pk->notinf66)
01265 errstr("Not a Fortran 66 keyword: %s",
01266 pk->keyname);
01267 return(pk->keyval);
01268 }
01269 }
01270 return(SUNKNOWN);
01271 }
01272
01273 void
01274 initkey(Void)
01275 {
01276 register struct Keylist *p;
01277 register int i,j;
01278 register char *s;
01279
01280 for(i = 0 ; i<26 ; ++i)
01281 keystart[i] = NULL;
01282
01283 for(p = keys ; p->keyname ; ++p) {
01284 j = letter(p->keyname[0]);
01285 if(keystart[j] == NULL)
01286 keystart[j] = p;
01287 keyend[j] = p;
01288 }
01289 i = (maxcontin + 2) * 66;
01290 sbuf = (char *)ckalloc(i + 70);
01291 send = sbuf + i;
01292 maxcont = maxcontin + 1;
01293 linestart = (char **)ckalloc(maxcont*sizeof(char*));
01294 comstart['c'] = comstart['C'] = comstart['*'] = comstart['!'] =
01295 comstart['#'] = 1;
01296 #ifdef EOF_CHAR
01297 comstart[EOF_CHAR] = 1;
01298 #endif
01299 s = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_";
01300 while(i = *s++)
01301 anum_buf[i] = 1;
01302 s = "0123456789";
01303 while(i = *s++)
01304 anum_buf[i] = 2;
01305 }
01306
01307 LOCAL int
01308 #ifdef KR_headers
01309 hexcheck(key)
01310 int key;
01311 #else
01312 hexcheck(int key)
01313 #endif
01314 {
01315 register int radix;
01316 register char *p;
01317 char *kind;
01318
01319 switch(key) {
01320 case 'z':
01321 case 'Z':
01322 case 'x':
01323 case 'X':
01324 radix = 16;
01325 key = SHEXCON;
01326 kind = "hexadecimal";
01327 break;
01328 case 'o':
01329 case 'O':
01330 radix = 8;
01331 key = SOCTCON;
01332 kind = "octal";
01333 break;
01334 case 'b':
01335 case 'B':
01336 radix = 2;
01337 key = SBITCON;
01338 kind = "binary";
01339 break;
01340 default:
01341 err("bad bit identifier");
01342 return(SNAME);
01343 }
01344 for(p = token; *p; p++)
01345 if (hextoi(*p) >= radix) {
01346 errstr("invalid %s character", kind);
01347 break;
01348 }
01349 return key;
01350 }
01351
01352
01353
01354
01355 LOCAL int
01356 gettok(Void)
01357 {
01358 int havdot, havexp, havdbl;
01359 int radix, val;
01360 struct Punctlist *pp;
01361 struct Dotlist *pd;
01362 register int ch;
01363 static char Exp_mi[] = "X**-Y treated as X**(-Y)",
01364 Exp_pl[] = "X**+Y treated as X**(+Y)";
01365
01366 char *i, *j, *n1, *p;
01367
01368 ch = * USC nextch;
01369 if(ch == (MYQUOTE))
01370 {
01371 ++nextch;
01372 p = token;
01373 while(*nextch != MYQUOTE)
01374 *p++ = *nextch++;
01375 toklen = p - token;
01376 *p = 0;
01377
01378 if (++nextch <= lastch && isalpha_(val = * USC nextch)) {
01379 ++nextch;
01380 return hexcheck(val);
01381 }
01382 return (SHOLLERITH);
01383 }
01384
01385 if(needkwd)
01386 {
01387 needkwd = 0;
01388 return( getkwd() );
01389 }
01390
01391 for(pp=puncts; pp->punchar; ++pp)
01392 if(ch == pp->punchar) {
01393 val = pp->punval;
01394 if (++nextch <= lastch)
01395 switch(ch) {
01396 case '/':
01397 switch(*nextch) {
01398 case '/':
01399 nextch++;
01400 val = SCONCAT;
01401 break;
01402 case '=':
01403 goto sne;
01404 default:
01405 if (new_dcl && parlev == 0)
01406 val = SSLASHD;
01407 }
01408 return val;
01409 case '*':
01410 if (*nextch == '*') {
01411 nextch++;
01412 if (noextflag
01413 && nextch <= lastch)
01414 switch(*nextch) {
01415 case '-':
01416 errext(Exp_mi);
01417 break;
01418 case '+':
01419 errext(Exp_pl);
01420 }
01421 return SPOWER;
01422 }
01423 break;
01424 case '<':
01425 switch(*nextch) {
01426 case '=':
01427 nextch++;
01428 val = SLE;
01429 break;
01430 case '>':
01431 sne:
01432 nextch++;
01433 val = SNE;
01434 }
01435 goto extchk;
01436 case '=':
01437 if (*nextch == '=') {
01438 nextch++;
01439 val = SEQ;
01440 goto extchk;
01441 }
01442 break;
01443 case '>':
01444 if (*nextch == '=') {
01445 nextch++;
01446 val = SGE;
01447 }
01448 extchk:
01449 NOEXT("Fortran 8x comparison operator");
01450 return val;
01451 }
01452 else if (ch == '/' && new_dcl && parlev == 0)
01453 return SSLASHD;
01454 switch(val) {
01455 case SLPAR:
01456 ++parlev;
01457 break;
01458 case SRPAR:
01459 --parlev;
01460 }
01461 return(val);
01462 }
01463 if(ch == '.')
01464 if(nextch >= lastch) goto badchar;
01465 else if(isdigit(nextch[1])) goto numconst;
01466 else {
01467 for(pd=dots ; (j=pd->dotname) ; ++pd)
01468 {
01469 for(i=nextch+1 ; i<=lastch ; ++i)
01470 if(*i != *j) break;
01471 else if(*i != '.') ++j;
01472 else {
01473 nextch = i+1;
01474 return(pd->dotval);
01475 }
01476 }
01477 goto badchar;
01478 }
01479 if( isalpha_(ch) )
01480 {
01481 p = token;
01482 *p++ = *nextch++;
01483 while(nextch<=lastch)
01484 if( isalnum_(* USC nextch) )
01485 *p++ = *nextch++;
01486 else break;
01487 toklen = p - token;
01488 *p = 0;
01489 if (needwkey) {
01490 needwkey = 0;
01491 if (toklen == 5
01492 && nextch <= lastch && *nextch == '('
01493 && !strcmp(token,"while"))
01494 return(SWHILE);
01495 }
01496 if(inioctl && nextch<=lastch && *nextch=='=')
01497 {
01498 ++nextch;
01499 return(SNAMEEQ);
01500 }
01501 if(toklen>8 && eqn(8,token,"function")
01502 && isalpha_(* USC (token+8)) &&
01503 nextch<lastch && nextch[0]=='(' &&
01504 (nextch[1]==')' || isalpha_(* USC (nextch+1))) )
01505 {
01506 nextch -= (toklen - 8);
01507 return(SFUNCTION);
01508 }
01509
01510 if(toklen > MAXNAMELEN)
01511 {
01512 char buff[MAXNAMELEN+50];
01513 sprintf(buff, toklen >= MAXNAMELEN+10
01514 ? "name %.*s... too long, truncated to %.*s"
01515 : "name %s too long, truncated to %.*s",
01516 MAXNAMELEN+6, token, MAXNAMELEN, token);
01517 err(buff);
01518 toklen = MAXNAMELEN;
01519 token[MAXNAMELEN] = '\0';
01520 }
01521 if(toklen==1 && *nextch==MYQUOTE) {
01522 val = token[0];
01523 ++nextch;
01524 for(p = token ; *nextch!=MYQUOTE ; )
01525 *p++ = *nextch++;
01526 ++nextch;
01527 toklen = p - token;
01528 *p = 0;
01529 return hexcheck(val);
01530 }
01531 return(SNAME);
01532 }
01533
01534 if (isdigit(ch)) {
01535
01536
01537
01538 if (nextch[1] == '#' && nextch < lastch
01539 || nextch[2] == '#' && isdigit(nextch[1])
01540 && lastch - nextch >= 2) {
01541
01542 radix = atoi (nextch);
01543 if (*++nextch != '#')
01544 nextch++;
01545 if (radix != 2 && radix != 8 && radix != 16) {
01546 erri("invalid base %d for constant, defaulting to hex",
01547 radix);
01548 radix = 16;
01549 }
01550 if (++nextch > lastch)
01551 goto badchar;
01552 for (p = token; hextoi(*nextch) < radix;) {
01553 *p++ = *nextch++;
01554 if (nextch > lastch)
01555 break;
01556 }
01557 toklen = p - token;
01558 *p = 0;
01559 return (radix == 16) ? SHEXCON : ((radix == 8) ? SOCTCON :
01560 SBITCON);
01561 }
01562 }
01563 else
01564 goto badchar;
01565 numconst:
01566 havdot = NO;
01567 havexp = NO;
01568 havdbl = NO;
01569 for(n1 = nextch ; nextch<=lastch ; ++nextch)
01570 {
01571 if(*nextch == '.')
01572 if(havdot) break;
01573 else if(nextch+2<=lastch && isalpha_(* USC (nextch+1))
01574 && isalpha_(* USC (nextch+2)))
01575 break;
01576 else havdot = YES;
01577 else if( !intonly && (*nextch=='d' || *nextch=='e') )
01578 {
01579 p = nextch;
01580 havexp = YES;
01581 if(*nextch == 'd')
01582 havdbl = YES;
01583 if(nextch<lastch)
01584 if(nextch[1]=='+' || nextch[1]=='-')
01585 ++nextch;
01586 if( ! isdigit(*++nextch) )
01587 {
01588 nextch = p;
01589 havdbl = havexp = NO;
01590 break;
01591 }
01592 for(++nextch ;
01593 nextch<=lastch && isdigit(* USC nextch);
01594 ++nextch);
01595 break;
01596 }
01597 else if( ! isdigit(* USC nextch) )
01598 break;
01599 }
01600 p = token;
01601 i = n1;
01602 while(i < nextch)
01603 *p++ = *i++;
01604 toklen = p - token;
01605 *p = 0;
01606 if(havdbl) return(SDCON);
01607 if(havdot || havexp) return(SRCON);
01608 return(SICON);
01609 badchar:
01610 sbuf[0] = *nextch++;
01611 return(SUNKNOWN);
01612 }
01613
01614
01615
01616 static void
01617 #ifdef KR_headers
01618 store_comment(str)
01619 char *str;
01620 #else
01621 store_comment(char *str)
01622 #endif
01623 {
01624 int len;
01625 comment_buf *ncb;
01626
01627 if (nextcd == sbuf) {
01628 flush_comments();
01629 p1_comment(str);
01630 return;
01631 }
01632 len = strlen(str) + 1;
01633 if (cbnext + len > cblast) {
01634 if (!cbcur || !(ncb = cbcur->next)) {
01635 ncb = (comment_buf *) Alloc(sizeof(comment_buf));
01636 if (cbcur) {
01637 cbcur->last = cbnext;
01638 cbcur->next = ncb;
01639 }
01640 else {
01641 cbfirst = ncb;
01642 cbinit = ncb->buf;
01643 }
01644 ncb->next = 0;
01645 }
01646 cbcur = ncb;
01647 cbnext = ncb->buf;
01648 cblast = cbnext + COMMENT_BUF_STORE;
01649 }
01650 strcpy(cbnext, str);
01651 cbnext += len;
01652 }
01653
01654 static void
01655 flush_comments(Void)
01656 {
01657 register char *s, *s1;
01658 register comment_buf *cb;
01659 if (cbnext == cbinit)
01660 return;
01661 cbcur->last = cbnext;
01662 for(cb = cbfirst;; cb = cb->next) {
01663 for(s = cb->buf; s < cb->last; s = s1) {
01664
01665
01666 s1 = s + strlen(s) + 1;
01667 p1_comment(s);
01668 }
01669 if (cb == cbcur)
01670 break;
01671 }
01672 cbcur = cbfirst;
01673 cbnext = cbinit;
01674 cblast = cbnext + COMMENT_BUF_STORE;
01675 }
01676
01677 void
01678 unclassifiable(Void)
01679 {
01680 register char *s, *se;
01681
01682 s = sbuf;
01683 se = lastch;
01684 if (se < sbuf)
01685 return;
01686 lastch = s - 1;
01687 if (++se - s > 10)
01688 se = s + 10;
01689 for(; s < se; s++)
01690 if (*s == MYQUOTE) {
01691 se = s;
01692 break;
01693 }
01694 *se = 0;
01695 errstr("unclassifiable statement (starts \"%s\")", sbuf);
01696 }
