1 /* 2 * Copyright (c) 1987, 1993, 1994 3 * The Regents of the University of California. All rights reserved. 4 * 5 * Redistribution and use in source and binary forms, with or without 6 * modification, are permitted provided that the following conditions 7 * are met: 8 * 1. Redistributions of source code must retain the above copyright 9 * notice, this list of conditions and the following disclaimer. 10 * 2. Redistributions in binary form must reproduce the above copyright 11 * notice, this list of conditions and the following disclaimer in the 12 * documentation and/or other materials provided with the distribution. 13 * 4. Neither the name of the University nor the names of its contributors 14 * may be used to endorse or promote products derived from this software 15 * without specific prior written permission. 16 * 17 * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND 18 * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 19 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 20 * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE 21 * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 22 * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 23 * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 24 * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 25 * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 26 * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 27 * SUCH DAMAGE. 28 */ 29 30 #if 0 31 #ifndef lint 32 static char sccsid[] = "@(#)fortran.c 8.3 (Berkeley) 4/2/94"; 33 #endif 34 #endif 35 36 #include <sys/cdefs.h> 37 __FBSDID("$FreeBSD$"); 38 39 #include <ctype.h> 40 #include <limits.h> 41 #include <stdio.h> 42 #include <string.h> 43 44 #include "ctags.h" 45 46 static void takeprec(void); 47 48 char *lbp; /* line buffer pointer */ 49 50 int 51 PF_funcs(void) 52 { 53 bool pfcnt; /* pascal/fortran functions found */ 54 char *cp; 55 char tok[MAXTOKEN]; 56 57 for (pfcnt = NO;;) { 58 lineftell = ftell(inf); 59 if (!fgets(lbuf, sizeof(lbuf), inf)) 60 return (pfcnt); 61 ++lineno; 62 lbp = lbuf; 63 if (*lbp == '%') /* Ratfor escape to fortran */ 64 ++lbp; 65 for (; isspace(*lbp); ++lbp) 66 continue; 67 if (!*lbp) 68 continue; 69 switch (*lbp | ' ') { /* convert to lower-case */ 70 case 'c': 71 if (cicmp("complex") || cicmp("character")) 72 takeprec(); 73 break; 74 case 'd': 75 if (cicmp("double")) { 76 for (; isspace(*lbp); ++lbp) 77 continue; 78 if (!*lbp) 79 continue; 80 if (cicmp("precision")) 81 break; 82 continue; 83 } 84 break; 85 case 'i': 86 if (cicmp("integer")) 87 takeprec(); 88 break; 89 case 'l': 90 if (cicmp("logical")) 91 takeprec(); 92 break; 93 case 'r': 94 if (cicmp("real")) 95 takeprec(); 96 break; 97 } 98 for (; isspace(*lbp); ++lbp) 99 continue; 100 if (!*lbp) 101 continue; 102 switch (*lbp | ' ') { 103 case 'f': 104 if (cicmp("function")) 105 break; 106 continue; 107 case 'p': 108 if (cicmp("program") || cicmp("procedure")) 109 break; 110 continue; 111 case 's': 112 if (cicmp("subroutine")) 113 break; 114 default: 115 continue; 116 } 117 for (; isspace(*lbp); ++lbp) 118 continue; 119 if (!*lbp) 120 continue; 121 for (cp = lbp + 1; *cp && intoken(*cp); ++cp) 122 continue; 123 if (cp == lbp + 1) 124 continue; 125 *cp = EOS; 126 (void)strlcpy(tok, lbp, sizeof(tok)); /* possible trunc */ 127 getline(); /* process line for ex(1) */ 128 pfnote(tok, lineno); 129 pfcnt = YES; 130 } 131 /*NOTREACHED*/ 132 } 133 134 /* 135 * cicmp -- 136 * do case-independent strcmp 137 */ 138 int 139 cicmp(const char *cp) 140 { 141 int len; 142 char *bp; 143 144 for (len = 0, bp = lbp; *cp && (*cp &~ ' ') == (*bp++ &~ ' '); 145 ++cp, ++len) 146 continue; 147 if (!*cp) { 148 lbp += len; 149 return (YES); 150 } 151 return (NO); 152 } 153 154 static void 155 takeprec(void) 156 { 157 for (; isspace(*lbp); ++lbp) 158 continue; 159 if (*lbp == '*') { 160 for (++lbp; isspace(*lbp); ++lbp) 161 continue; 162 if (!isdigit(*lbp)) 163 --lbp; /* force failure */ 164 else 165 while (isdigit(*++lbp)) 166 continue; 167 } 168 } 169