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
32static 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
46static void takeprec(void);
47
48char *lbp;				/* line buffer pointer */
49
50int
51PF_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 */
138int
139cicmp(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
154static void
155takeprec(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