1 /* $OpenBSD: fortran.c,v 1.9 2013/11/26 13:18:55 deraadt Exp $ */
2 /* $NetBSD: fortran.c,v 1.3 1995/03/26 20:14:08 glass Exp $ */
3
4 /*
5 * Copyright (c) 1987, 1993, 1994
6 * The Regents of the University of California. All rights reserved.
7 *
8 * Redistribution and use in source and binary forms, with or without
9 * modification, are permitted provided that the following conditions
10 * are met:
11 * 1. Redistributions of source code must retain the above copyright
12 * notice, this list of conditions and the following disclaimer.
13 * 2. Redistributions in binary form must reproduce the above copyright
14 * notice, this list of conditions and the following disclaimer in the
15 * documentation and/or other materials provided with the distribution.
16 * 3. Neither the name of the University nor the names of its contributors
17 * may be used to endorse or promote products derived from this software
18 * without specific prior written permission.
19 *
20 * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
21 * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
22 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
23 * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
24 * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
25 * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
26 * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
27 * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
28 * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
29 * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
30 * SUCH DAMAGE.
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
PF_funcs(void)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((unsigned char)*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((unsigned char)*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((unsigned char)*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((unsigned char)*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 (void)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
cicmp(char * cp)133 cicmp(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
takeprec(void)149 takeprec(void)
150 {
151 for (; isspace((unsigned char)*lbp); ++lbp)
152 continue;
153 if (*lbp == '*') {
154 for (++lbp; isspace((unsigned char)*lbp); ++lbp)
155 continue;
156 if (!isdigit((unsigned char)*lbp))
157 --lbp; /* force failure */
158 else
159 while (isdigit((unsigned char)*++lbp))
160 continue;
161 }
162 }
163