1 /* 2 * Copyright (c) 1987 The Regents of the University of California. 3 * All rights reserved. 4 * 5 * Redistribution and use in source and binary forms are permitted 6 * provided that the above copyright notice and this paragraph are 7 * duplicated in all such forms and that any documentation, 8 * advertising materials, and other materials related to such 9 * distribution and use acknowledge that the software was developed 10 * by the University of California, Berkeley. The name of the 11 * University may not be used to endorse or promote products derived 12 * from this software without specific prior written permission. 13 * THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR 14 * IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED 15 * WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. 16 */ 17 18 #ifndef lint 19 static char sccsid[] = "@(#)fortran.c 5.2 (Berkeley) 12/31/88"; 20 #endif /* not lint */ 21 22 #include <ctags.h> 23 #include <strings.h> 24 25 char *lbp; /* line buffer pointer */ 26 27 PF_funcs() 28 { 29 register bool pfcnt; /* pascal/fortran functions found */ 30 register char *cp; 31 char tok[MAXTOKEN], 32 *gettoken(); 33 34 for (pfcnt = NO;;) { 35 lineftell = ftell(inf); 36 if (!fgets(lbuf,sizeof(lbuf),inf)) 37 return(pfcnt); 38 ++lineno; 39 lbp = lbuf; 40 if (*lbp == '%') /* Ratfor escape to fortran */ 41 ++lbp; 42 for (;isspace(*lbp);++lbp); 43 if (!*lbp) 44 continue; 45 switch (*lbp | ' ') { /* convert to lower-case */ 46 case 'c': 47 if (cicmp("complex") || cicmp("character")) 48 takeprec(); 49 break; 50 case 'd': 51 if (cicmp("double")) { 52 for (;isspace(*lbp);++lbp); 53 if (!*lbp) 54 continue; 55 if (cicmp("precision")) 56 break; 57 continue; 58 } 59 break; 60 case 'i': 61 if (cicmp("integer")) 62 takeprec(); 63 break; 64 case 'l': 65 if (cicmp("logical")) 66 takeprec(); 67 break; 68 case 'r': 69 if (cicmp("real")) 70 takeprec(); 71 break; 72 } 73 for (;isspace(*lbp);++lbp); 74 if (!*lbp) 75 continue; 76 switch (*lbp | ' ') { 77 case 'f': 78 if (cicmp("function")) 79 break; 80 continue; 81 case 'p': 82 if (cicmp("program") || cicmp("procedure")) 83 break; 84 continue; 85 case 's': 86 if (cicmp("subroutine")) 87 break; 88 default: 89 continue; 90 } 91 for (;isspace(*lbp);++lbp); 92 if (!*lbp) 93 continue; 94 for (cp = lbp + 1;*cp && intoken(*cp);++cp); 95 if (cp = lbp + 1) 96 continue; 97 *cp = EOS; 98 (void)strcpy(tok,lbp); 99 getline(); /* process line for ex(1) */ 100 pfnote(tok,lineno); 101 pfcnt = YES; 102 } 103 /*NOTREACHED*/ 104 } 105 106 /* 107 * cicmp -- 108 * do case-independent strcmp 109 */ 110 cicmp(cp) 111 register char *cp; 112 { 113 register int len; 114 register char *bp; 115 116 for (len = 0,bp = lbp;*cp && (*cp &~ ' ') == (*bp++ &~ ' '); 117 ++cp,++len); 118 if (!*cp) { 119 lbp += len; 120 return(YES); 121 } 122 return(NO); 123 } 124 125 static 126 takeprec() 127 { 128 for (;isspace(*lbp);++lbp); 129 if (*lbp == '*') { 130 for (++lbp;isspace(*lbp);++lbp); 131 if (!isdigit(*lbp)) 132 --lbp; /* force failure */ 133 else 134 while (isdigit(*++lbp)); 135 } 136 } 137