1 /* 2 * Copyright (c) 1987 The Regents of the University of California. 3 * All rights reserved. 4 * 5 * %sccs.include.redist.c% 6 */ 7 8 #ifndef lint 9 static char sccsid[] = "@(#)fortran.c 5.4 (Berkeley) 06/01/90"; 10 #endif /* not lint */ 11 12 #include <ctags.h> 13 #include <string.h> 14 15 char *lbp; /* line buffer pointer */ 16 17 PF_funcs() 18 { 19 register bool pfcnt; /* pascal/fortran functions found */ 20 register char *cp; 21 char tok[MAXTOKEN], 22 *gettoken(); 23 24 for (pfcnt = NO;;) { 25 lineftell = ftell(inf); 26 if (!fgets(lbuf,sizeof(lbuf),inf)) 27 return(pfcnt); 28 ++lineno; 29 lbp = lbuf; 30 if (*lbp == '%') /* Ratfor escape to fortran */ 31 ++lbp; 32 for (;isspace(*lbp);++lbp); 33 if (!*lbp) 34 continue; 35 switch (*lbp | ' ') { /* convert to lower-case */ 36 case 'c': 37 if (cicmp("complex") || cicmp("character")) 38 takeprec(); 39 break; 40 case 'd': 41 if (cicmp("double")) { 42 for (;isspace(*lbp);++lbp); 43 if (!*lbp) 44 continue; 45 if (cicmp("precision")) 46 break; 47 continue; 48 } 49 break; 50 case 'i': 51 if (cicmp("integer")) 52 takeprec(); 53 break; 54 case 'l': 55 if (cicmp("logical")) 56 takeprec(); 57 break; 58 case 'r': 59 if (cicmp("real")) 60 takeprec(); 61 break; 62 } 63 for (;isspace(*lbp);++lbp); 64 if (!*lbp) 65 continue; 66 switch (*lbp | ' ') { 67 case 'f': 68 if (cicmp("function")) 69 break; 70 continue; 71 case 'p': 72 if (cicmp("program") || cicmp("procedure")) 73 break; 74 continue; 75 case 's': 76 if (cicmp("subroutine")) 77 break; 78 default: 79 continue; 80 } 81 for (;isspace(*lbp);++lbp); 82 if (!*lbp) 83 continue; 84 for (cp = lbp + 1;*cp && intoken(*cp);++cp); 85 if (cp = lbp + 1) 86 continue; 87 *cp = EOS; 88 (void)strcpy(tok,lbp); 89 getline(); /* process line for ex(1) */ 90 pfnote(tok,lineno); 91 pfcnt = YES; 92 } 93 /*NOTREACHED*/ 94 } 95 96 /* 97 * cicmp -- 98 * do case-independent strcmp 99 */ 100 cicmp(cp) 101 register char *cp; 102 { 103 register int len; 104 register char *bp; 105 106 for (len = 0,bp = lbp;*cp && (*cp &~ ' ') == (*bp++ &~ ' '); 107 ++cp,++len); 108 if (!*cp) { 109 lbp += len; 110 return(YES); 111 } 112 return(NO); 113 } 114 115 static 116 takeprec() 117 { 118 for (;isspace(*lbp);++lbp); 119 if (*lbp == '*') { 120 for (++lbp;isspace(*lbp);++lbp); 121 if (!isdigit(*lbp)) 122 --lbp; /* force failure */ 123 else 124 while (isdigit(*++lbp)); 125 } 126 } 127