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.
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 kindOption 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
));
48 tag
->kindName
= PascalKinds
[kind
].name
;
49 tag
->kind
= PascalKinds
[kind
].letter
;
50 tag
->extensionFields
.arglist
= arglist
;
51 tag
->extensionFields
.varType
= vartype
;
54 initTagEntry (tag
, NULL
);
57 static void makePascalTag (const tagEntryInfo
* const tag
)
59 if (tag
->name
!= NULL
)
63 static const unsigned char* dbp
;
65 #define starttoken(c) (isalpha ((int) c) || (int) c == '_')
66 #define intoken(c) (isalnum ((int) c) || (int) c == '_' || (int) c == '.')
67 #define endtoken(c) (! intoken (c) && ! isdigit ((int) c))
69 static boolean
tail (const char *cp
)
71 boolean result
= FALSE
;
74 while (*cp
!= '\0' && tolower ((int) *cp
) == tolower ((int) dbp
[len
]))
76 if (*cp
== '\0' && !intoken (dbp
[len
]))
84 static void parseArglist(const char *buf
, char **arglist
, char **vartype
)
86 char *c
, *start
, *end
;
89 if (NULL
== buf
|| NULL
== arglist
)
93 /* parse argument list which can be missing like in "function ginit:integer;" */
94 if (NULL
!= (start
= strchr(c
, '(')))
96 for (level
= 1, end
= start
+ 1; level
> 0; ++end
)
100 else if ('(' == *end
)
102 else if (')' == *end
)
106 else /* if no argument list was found, continue looking for a return value */
112 /* parse return type if requested by passing a non-NULL vartype argument */
115 char *var
, *var_start
;
119 if (NULL
!= (var
= strchr(end
, ':')))
121 var
++; /* skip ':' */
122 while (isspace((int) *var
))
125 if (starttoken(*var
))
129 while (intoken(*var
))
134 *vartype
= strdup(var_start
);
141 *arglist
= strdup(start
);
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
153 static void findPascalTags (void)
155 vString
*name
= vStringNew ();
157 char *arglist
= NULL
;
158 char *vartype
= NULL
;
159 pascalKind kind
= K_FUNCTION
;
160 /* each of these flags is TRUE iff: */
161 boolean incomment
= FALSE
; /* point is inside a comment */
162 int comment_char
= '\0'; /* type of current comment */
163 boolean inquote
= FALSE
; /* point is inside '..' string */
164 boolean get_tagname
= FALSE
;/* point is after PROCEDURE/FUNCTION
165 keyword, so next item = potential tag */
166 boolean found_tag
= FALSE
; /* point is after a potential tag */
167 boolean inparms
= FALSE
; /* point is within parameter-list */
168 boolean verify_tag
= FALSE
; /* point has passed the parm-list, so the
169 next token will determine whether this
170 is a FORWARD/EXTERN to be ignored, or
171 whether it is a real tag */
173 dbp
= fileReadLine ();
178 if (c
== '\0') /* if end of line */
180 dbp
= fileReadLine ();
181 if (dbp
== NULL
|| *dbp
== '\0')
183 if (!((found_tag
&& verify_tag
) || get_tagname
))
184 c
= *dbp
++; /* only if don't need *dbp pointing
185 to the beginning of the name of
186 the procedure or function */
190 if (comment_char
== '{' && c
== '}')
192 else if (comment_char
== '(' && c
== '*' && *dbp
== ')')
208 inquote
= TRUE
; /* found first quote */
210 case '{': /* found open { comment */
215 if (*dbp
== '*') /* found open (* comment */
221 else if (found_tag
) /* found '(' after tag, i.e., parm-list */
224 case ')': /* end of parms list */
229 if (found_tag
&& !inparms
) /* end of proc or fn stmt */
236 if (found_tag
&& verify_tag
&& *dbp
!= ' ')
238 /* check if this is an "extern" declaration */
241 if (tolower ((int) *dbp
== 'e'))
243 if (tail ("extern")) /* superfluous, really! */
249 else if (tolower ((int) *dbp
) == 'f')
251 if (tail ("forward")) /* check for forward reference */
257 else if (tolower ((int) *dbp
) == 't')
259 if (tail ("type")) /* check for forward reference */
265 if (found_tag
&& verify_tag
) /* not external proc, so make tag */
269 makePascalTag (&tag
);
273 if (get_tagname
) /* grab name of proc or fn */
275 const unsigned char *cp
;
280 /* grab block name */
281 while (isspace ((int) *dbp
))
283 for (cp
= dbp
; *cp
!= '\0' && !endtoken (*cp
) ; cp
++)
285 vStringNCopyS (name
, (const char*) dbp
, cp
- dbp
);
288 if (kind
== K_FUNCTION
&& vartype
!= NULL
)
290 parseArglist((const char*) cp
, &arglist
, (kind
== K_FUNCTION
) ? &vartype
: NULL
);
291 createPascalTag (&tag
, name
, kind
, arglist
, (kind
== K_FUNCTION
) ? vartype
: NULL
);
292 dbp
= cp
; /* set dbp to e-o-token */
295 /* and proceed to check for "extern" */
297 else if (!incomment
&& !inquote
&& !found_tag
)
299 switch (tolower ((int) c
))
302 if (tail ("onstructor"))
309 if (tail ("estructor"))
316 if (tail ("rocedure"))
323 if (tail ("unction"))
337 } /* while not eof */
346 extern parserDefinition
* PascalParser (void)
348 static const char *const extensions
[] = { "p", "pas", NULL
};
349 parserDefinition
* def
= parserNew ("Pascal");
350 def
->extensions
= extensions
;
351 def
->kinds
= PascalKinds
;
352 def
->kindCount
= KIND_COUNT (PascalKinds
);
353 def
->parser
= findPascalTags
;
357 /* vi:set tabstop=8 shiftwidth=4: */