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