2 * Copyright (c) 2001-2002, Darren Hiebert
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.
7 * This module contains functions for generating tags for the Pascal language,
8 * including some extensions for Object Pascal.
14 #include "general.h" /* must always come first */
28 K_FUNCTION
, K_PROCEDURE
31 static kindDefinition PascalKinds
[] = {
32 { true, 'f', "function", "functions"},
33 { true, 'p', "procedure", "procedures"}
37 * FUNCTION DEFINITIONS
40 static void createPascalTag (tagEntryInfo
* const tag
,
41 const vString
* const name
, const int kind
,
42 const char *arglist
, const char *vartype
)
44 if (PascalKinds
[kind
].enabled
&& name
!= NULL
&& vStringLength (name
) > 0)
46 initTagEntry (tag
, vStringValue (name
), kind
);
48 tag
->extensionFields
.signature
= arglist
;
49 tag
->extensionFields
.typeRef
[1] = vartype
;
53 /* TODO: Passing NULL as name makes an assertion behind initTagEntry failure */
54 /* initTagEntry (tag, NULL, NULL); */
58 static void makePascalTag (const tagEntryInfo
* const tag
)
60 if (tag
->name
!= NULL
)
64 static const unsigned char* dbp
;
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))
70 static bool tail (const char *cp
)
75 while (*cp
!= '\0' && tolower ((int) *cp
) == tolower ((int) dbp
[len
]))
77 if (*cp
== '\0' && !intoken (dbp
[len
]))
85 static void parseArglist(const char *buf
, char **arglist
, char **vartype
)
87 char *c
, *start
, *end
;
90 if (NULL
== buf
|| NULL
== arglist
)
94 /* parse argument list which can be missing like in "function ginit:integer;" */
95 if (NULL
!= (start
= strchr(c
, '(')))
97 for (level
= 1, end
= start
+ 1; level
> 0; ++end
)
101 else if ('(' == *end
)
103 else if (')' == *end
)
107 else /* if no argument list was found, continue looking for a return value */
113 /* parse return type if requested by passing a non-NULL vartype argument */
116 char *var
, *var_start
;
120 if (NULL
!= (var
= strchr(end
, ':')))
122 var
++; /* skip ':' */
123 while (isspace((int) *var
))
126 if (starttoken(*var
))
130 while (intoken(*var
))
135 *vartype
= strdup(var_start
);
142 *arglist
= strdup(start
);
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
154 static void findPascalTags (void)
156 vString
*name
= vStringNew ();
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
175 dbp
= readLineFromInputFile ();
180 if (c
== '\0') /* if end of line */
182 dbp
= readLineFromInputFile ();
183 if (dbp
== NULL
|| *dbp
== '\0')
185 if (!((found_tag
&& verify_tag
) || get_tagname
))
187 /* only if don't need *dbp pointing to the beginning of
188 * the name of the procedure or function
193 if (comment_char
== '{' && c
== '}')
195 else if (comment_char
== '(' && c
== '*' && *dbp
== ')')
211 inquote
= true; /* found first quote */
213 case '{': /* found open { comment */
218 if (*dbp
== '*') /* found open (* comment */
224 else if (found_tag
) /* found '(' after tag, i.e., parm-list */
227 case ')': /* end of parms list */
232 if (found_tag
&& !inparms
) /* end of proc or fn stmt */
239 if (found_tag
&& verify_tag
&& *dbp
!= ' ')
241 /* check if this is an "extern" declaration */
244 if (tolower ((int) *dbp
== 'e'))
246 if (tail ("extern")) /* superfluous, really! */
252 else if (tolower ((int) *dbp
) == 'f')
254 if (tail ("forward")) /* check for forward reference */
260 else if (tolower ((int) *dbp
) == 't')
262 if (tail ("type")) /* check for forward reference */
268 if (found_tag
&& verify_tag
) /* not external proc, so make tag */
272 makePascalTag (&tag
);
276 if (get_tagname
) /* grab name of proc or fn */
278 const unsigned char *cp
;
283 /* grab block name */
284 while (isspace ((int) *dbp
))
286 for (cp
= dbp
; *cp
!= '\0' && !endtoken (*cp
) ; cp
++)
288 vStringNCopyS (name
, (const char*) dbp
, cp
- dbp
);
291 if (kind
== K_FUNCTION
&& vartype
!= NULL
)
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 */
298 /* and proceed to check for "extern" */
300 else if (!incomment
&& !inquote
&& !found_tag
)
302 switch (tolower ((int) c
))
305 if (tail ("onstructor"))
312 if (tail ("estructor"))
319 if (tail ("rocedure"))
326 if (tail ("unction"))
340 } /* while not eof */
346 vStringDelete (name
);
349 extern parserDefinition
* PascalParser (void)
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
;