1 /*
2 * Copyright (c) 2001-2002, Darren Hiebert
3 *
4 * This source code is released for free distribution under the terms of the
5 * GNU General Public License version 2 or (at your option) any later version.
6 *
7 * This module contains functions for generating tags for the Pascal language,
8 * including some extensions for Object Pascal.
9 */
10
11 /*
12 * INCLUDE FILES
13 */
14 #include "general.h" /* must always come first */
15
16 #include <string.h>
17
18 #include "entry.h"
19 #include "parse.h"
20 #include "read.h"
21 #include "routines.h"
22 #include "vstring.h"
23
24 /*
25 * DATA DEFINITIONS
26 */
27 typedef enum {
28 K_FUNCTION, K_PROCEDURE
29 } pascalKind;
30
31 static kindDefinition PascalKinds [] = {
32 { true, 'f', "function", "functions"},
33 { true, 'p', "procedure", "procedures"}
34 };
35
36 /*
37 * FUNCTION DEFINITIONS
38 */
39
createPascalTag(tagEntryInfo * const tag,const vString * const name,const int kind,const char * arglist,const char * vartype)40 static void createPascalTag (tagEntryInfo* const tag,
41 const vString* const name, const int kind,
42 const char *arglist, const char *vartype)
43 {
44 if (PascalKinds [kind].enabled && name != NULL && vStringLength (name) > 0)
45 {
46 initTagEntry (tag, vStringValue (name), kind);
47
48 tag->extensionFields.signature = arglist;
49 tag->extensionFields.varType = vartype;
50 }
51 else
52 {
53 /* TODO: Passing NULL as name makes an assertion behind initTagEntry failure */
54 /* initTagEntry (tag, NULL, NULL); */
55 }
56 }
57
makePascalTag(const tagEntryInfo * const tag)58 static void makePascalTag (const tagEntryInfo* const tag)
59 {
60 if (tag->name != NULL)
61 makeTagEntry (tag);
62 }
63
64 static const unsigned char* dbp;
65
66 #define starttoken(c) (isalpha ((int) c) || (int) c == '_')
67 #define intoken(c) (isalnum ((int) c) || (int) c == '_' || (int) c == '.')
68 #define endtoken(c) (! intoken (c) && ! isdigit ((int) c))
69
tail(const char * cp)70 static bool tail (const char *cp)
71 {
72 bool result = false;
73 register int len = 0;
74
75 while (*cp != '\0' && tolower ((int) *cp) == tolower ((int) dbp [len]))
76 cp++, len++;
77 if (*cp == '\0' && !intoken (dbp [len]))
78 {
79 dbp += len;
80 result = true;
81 }
82 return result;
83 }
84
parseArglist(const char * buf,char ** arglist,char ** vartype)85 static void parseArglist(const char *buf, char **arglist, char **vartype)
86 {
87 char *c, *start, *end;
88 int level;
89
90 if (NULL == buf || NULL == arglist)
91 return;
92
93 c = strdup(buf);
94 /* parse argument list which can be missing like in "function ginit:integer;" */
95 if (NULL != (start = strchr(c, '(')))
96 {
97 for (level = 1, end = start + 1; level > 0; ++end)
98 {
99 if ('\0' == *end)
100 break;
101 else if ('(' == *end)
102 ++ level;
103 else if (')' == *end)
104 -- level;
105 }
106 }
107 else /* if no argument list was found, continue looking for a return value */
108 {
109 start = "()";
110 end = c;
111 }
112
113 /* parse return type if requested by passing a non-NULL vartype argument */
114 if (NULL != vartype)
115 {
116 char *var, *var_start;
117
118 *vartype = NULL;
119
120 if (NULL != (var = strchr(end, ':')))
121 {
122 var++; /* skip ':' */
123 while (isspace((int) *var))
124 ++var;
125
126 if (starttoken(*var))
127 {
128 var_start = var;
129 var++;
130 while (intoken(*var))
131 var++;
132 if (endtoken(*var))
133 {
134 *var = '\0';
135 *vartype = strdup(var_start);
136 }
137 }
138 }
139 }
140
141 *end = '\0';
142 *arglist = strdup(start);
143
144 eFree(c);
145 }
146
147
148 /* Algorithm adapted from from GNU etags.
149 * Locates tags for procedures & functions. Doesn't do any type- or
150 * var-definitions. It does look for the keyword "extern" or "forward"
151 * immediately following the procedure statement; if found, the tag is
152 * skipped.
153 */
findPascalTags(void)154 static void findPascalTags (void)
155 {
156 vString *name = vStringNew ();
157 tagEntryInfo tag;
158 char *arglist = NULL;
159 char *vartype = NULL;
160 pascalKind kind = K_FUNCTION;
161 /* each of these flags is true iff: */
162 bool incomment = false; /* point is inside a comment */
163 int comment_char = '\0'; /* type of current comment */
164 bool inquote = false; /* point is inside '..' string */
165 bool get_tagname = false;/* point is after PROCEDURE/FUNCTION
166 keyword, so next item = potential tag */
167 bool found_tag = false; /* point is after a potential tag */
168 bool inparms = false; /* point is within parameter-list */
169 bool verify_tag = false;
170 /* point has passed the parm-list, so the next token will determine
171 * whether this is a FORWARD/EXTERN to be ignored, or whether it is a
172 * real tag
173 */
174
175 dbp = readLineFromInputFile ();
176 while (dbp != NULL)
177 {
178 int c = *dbp++;
179
180 if (c == '\0') /* if end of line */
181 {
182 dbp = readLineFromInputFile ();
183 if (dbp == NULL || *dbp == '\0')
184 continue;
185 if (!((found_tag && verify_tag) || get_tagname))
186 c = *dbp++;
187 /* only if don't need *dbp pointing to the beginning of
188 * the name of the procedure or function
189 */
190 }
191 if (incomment)
192 {
193 if (comment_char == '{' && c == '}')
194 incomment = false;
195 else if (comment_char == '(' && c == '*' && *dbp == ')')
196 {
197 dbp++;
198 incomment = false;
199 }
200 continue;
201 }
202 else if (inquote)
203 {
204 if (c == '\'')
205 inquote = false;
206 continue;
207 }
208 else switch (c)
209 {
210 case '\'':
211 inquote = true; /* found first quote */
212 continue;
213 case '{': /* found open { comment */
214 incomment = true;
215 comment_char = c;
216 continue;
217 case '(':
218 if (*dbp == '*') /* found open (* comment */
219 {
220 incomment = true;
221 comment_char = c;
222 dbp++;
223 }
224 else if (found_tag) /* found '(' after tag, i.e., parm-list */
225 inparms = true;
226 continue;
227 case ')': /* end of parms list */
228 if (inparms)
229 inparms = false;
230 continue;
231 case ';':
232 if (found_tag && !inparms) /* end of proc or fn stmt */
233 {
234 verify_tag = true;
235 break;
236 }
237 continue;
238 }
239 if (found_tag && verify_tag && *dbp != ' ')
240 {
241 /* check if this is an "extern" declaration */
242 if (*dbp == '\0')
243 continue;
244 if (tolower ((int) *dbp == 'e'))
245 {
246 if (tail ("extern")) /* superfluous, really! */
247 {
248 found_tag = false;
249 verify_tag = false;
250 }
251 }
252 else if (tolower ((int) *dbp) == 'f')
253 {
254 if (tail ("forward")) /* check for forward reference */
255 {
256 found_tag = false;
257 verify_tag = false;
258 }
259 }
260 else if (tolower ((int) *dbp) == 't')
261 {
262 if (tail ("type")) /* check for forward reference */
263 {
264 found_tag = false;
265 verify_tag = false;
266 }
267 }
268 if (found_tag && verify_tag) /* not external proc, so make tag */
269 {
270 found_tag = false;
271 verify_tag = false;
272 makePascalTag (&tag);
273 continue;
274 }
275 }
276 if (get_tagname) /* grab name of proc or fn */
277 {
278 const unsigned char *cp;
279
280 if (*dbp == '\0')
281 continue;
282
283 /* grab block name */
284 while (isspace ((int) *dbp))
285 ++dbp;
286 for (cp = dbp ; *cp != '\0' && !endtoken (*cp) ; cp++)
287 continue;
288 vStringNCopyS (name, (const char*) dbp, cp - dbp);
289 if (arglist != NULL)
290 eFree(arglist);
291 if (kind == K_FUNCTION && vartype != NULL)
292 eFree(vartype);
293 parseArglist((const char*) cp, &arglist, (kind == K_FUNCTION) ? &vartype : NULL);
294 createPascalTag (&tag, name, kind, arglist, (kind == K_FUNCTION) ? vartype : NULL);
295 dbp = cp; /* set dbp to e-o-token */
296 get_tagname = false;
297 found_tag = true;
298 /* and proceed to check for "extern" */
299 }
300 else if (!incomment && !inquote && !found_tag)
301 {
302 switch (tolower ((int) c))
303 {
304 case 'c':
305 if (tail ("onstructor"))
306 {
307 get_tagname = true;
308 kind = K_PROCEDURE;
309 }
310 break;
311 case 'd':
312 if (tail ("estructor"))
313 {
314 get_tagname = true;
315 kind = K_PROCEDURE;
316 }
317 break;
318 case 'p':
319 if (tail ("rocedure"))
320 {
321 get_tagname = true;
322 kind = K_PROCEDURE;
323 }
324 break;
325 case 'f':
326 if (tail ("unction"))
327 {
328 get_tagname = true;
329 kind = K_FUNCTION;
330 }
331 break;
332 case 't':
333 if (tail ("ype"))
334 {
335 get_tagname = true;
336 kind = K_FUNCTION;
337 }
338 break;
339 }
340 } /* while not eof */
341 }
342 if (arglist != NULL)
343 eFree(arglist);
344 if (vartype != NULL)
345 eFree(vartype);
346 vStringDelete (name);
347 }
348
PascalParser(void)349 extern parserDefinition* PascalParser (void)
350 {
351 static const char *const extensions [] = { "p", "pas", NULL };
352 parserDefinition* def = parserNew ("Pascal");
353 def->extensions = extensions;
354 def->kindTable = PascalKinds;
355 def->kindCount = ARRAY_SIZE (PascalKinds);
356 def->parser = findPascalTags;
357 return def;
358 }
359