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