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 * 3. 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 * @(#)fortran.c 8.3 (Berkeley) 4/2/94 30 * $FreeBSD: src/usr.bin/ctags/fortran.c,v 1.3.6.2 2002/07/30 00:55:07 tjr Exp $ 31 * $DragonFly: src/usr.bin/ctags/fortran.c,v 1.3 2003/10/02 17:42:27 hmp Exp $ 32 */ 33 34 #include <ctype.h> 35 #include <limits.h> 36 #include <stdio.h> 37 #include <string.h> 38 39 #include "ctags.h" 40 41 static void takeprec(void); 42 43 char *lbp; /* line buffer pointer */ 44 45 int 46 PF_funcs(void) 47 { 48 bool pfcnt; /* pascal/fortran functions found */ 49 char *cp; 50 char tok[MAXTOKEN]; 51 52 for (pfcnt = NO;;) { 53 lineftell = ftell(inf); 54 if (!fgets(lbuf, sizeof(lbuf), inf)) 55 return (pfcnt); 56 ++lineno; 57 lbp = lbuf; 58 if (*lbp == '%') /* Ratfor escape to fortran */ 59 ++lbp; 60 for (; isspace(*lbp); ++lbp) 61 continue; 62 if (!*lbp) 63 continue; 64 switch (*lbp | ' ') { /* convert to lower-case */ 65 case 'c': 66 if (cicmp("complex") || cicmp("character")) 67 takeprec(); 68 break; 69 case 'd': 70 if (cicmp("double")) { 71 for (; isspace(*lbp); ++lbp) 72 continue; 73 if (!*lbp) 74 continue; 75 if (cicmp("precision")) 76 break; 77 continue; 78 } 79 break; 80 case 'i': 81 if (cicmp("integer")) 82 takeprec(); 83 break; 84 case 'l': 85 if (cicmp("logical")) 86 takeprec(); 87 break; 88 case 'r': 89 if (cicmp("real")) 90 takeprec(); 91 break; 92 } 93 for (; isspace(*lbp); ++lbp) 94 continue; 95 if (!*lbp) 96 continue; 97 switch (*lbp | ' ') { 98 case 'f': 99 if (cicmp("function")) 100 break; 101 continue; 102 case 'p': 103 if (cicmp("program") || cicmp("procedure")) 104 break; 105 continue; 106 case 's': 107 if (cicmp("subroutine")) 108 break; 109 default: 110 continue; 111 } 112 for (; isspace(*lbp); ++lbp) 113 continue; 114 if (!*lbp) 115 continue; 116 for (cp = lbp + 1; *cp && intoken(*cp); ++cp) 117 continue; 118 if ((cp = lbp + 1)) 119 continue; 120 *cp = EOS; 121 (void)strlcpy(tok, lbp, sizeof(tok)); /* possible trunc */ 122 getline(); /* process line for ex(1) */ 123 pfnote(tok, lineno); 124 pfcnt = YES; 125 } 126 /*NOTREACHED*/ 127 } 128 129 /* 130 * cicmp -- 131 * do case-independent strcmp 132 */ 133 int 134 cicmp(const char *cp) 135 { 136 int len; 137 char *bp; 138 139 for (len = 0, bp = lbp; *cp && (*cp &~ ' ') == (*bp++ &~ ' '); 140 ++cp, ++len) 141 continue; 142 if (!*cp) { 143 lbp += len; 144 return (YES); 145 } 146 return (NO); 147 } 148 149 static void 150 takeprec(void) 151 { 152 for (; isspace(*lbp); ++lbp) 153 continue; 154 if (*lbp == '*') { 155 for (++lbp; isspace(*lbp); ++lbp) 156 continue; 157 if (!isdigit(*lbp)) 158 --lbp; /* force failure */ 159 else 160 while (isdigit(*++lbp)) 161 continue; 162 } 163 } 164