4 * Copyright (c) 2001-2002, Darren Hiebert
6 * This source code is released for free distribution under the terms of the
7 * GNU General Public License.
9 * This module contains functions for generating tags for the Pascal language,
10 * including some extensions for Object Pascal.
16 #include "general.h" /* must always come first */
30 K_FUNCTION
, K_PROCEDURE
33 static kindOption PascalKinds
[] = {
34 { TRUE
, 'f', "function", "functions"},
35 { TRUE
, 'f', "function", "procedures"}
39 * FUNCTION DEFINITIONS
42 static void createPascalTag (tagEntryInfo
* const tag
,
43 const vString
* const name
, const int kind
,
44 const char *arglist
, const char *vartype
)
46 if (PascalKinds
[kind
].enabled
&& name
!= NULL
&& vStringLength (name
) > 0)
48 initTagEntry (tag
, vStringValue (name
));
50 tag
->kindName
= PascalKinds
[kind
].name
;
51 tag
->kind
= PascalKinds
[kind
].letter
;
52 tag
->extensionFields
.arglist
= arglist
;
53 tag
->extensionFields
.varType
= vartype
;
56 initTagEntry (tag
, NULL
);
59 static void makePascalTag (const tagEntryInfo
* const tag
)
61 if (tag
->name
!= NULL
)
65 static const unsigned char* dbp
;
67 #define starttoken(c) (isalpha ((int) c) || (int) c == '_')
68 #define intoken(c) (isalnum ((int) c) || (int) c == '_' || (int) c == '.')
69 #define endtoken(c) (! intoken (c) && ! isdigit ((int) c))
71 static boolean
tail (const char *cp
)
73 boolean result
= FALSE
;
76 while (*cp
!= '\0' && tolower ((int) *cp
) == tolower ((int) dbp
[len
]))
78 if (*cp
== '\0' && !intoken (dbp
[len
]))
86 static void parseArglist(const char *buf
, char **arglist
, char **vartype
)
88 char *c
, *start
, *end
;
91 if (NULL
== buf
|| NULL
== arglist
)
95 /* parse argument list which can be missing like in "function ginit:integer;" */
96 if (NULL
!= (start
= strchr(c
, '(')))
98 for (level
= 1, end
= start
+ 1; level
> 0; ++end
)
102 else if ('(' == *end
)
104 else if (')' == *end
)
108 else /* if no argument list was found, continue looking for a return value */
114 /* parse return type if requested by passing a non-NULL vartype argument */
117 char *var
, *var_start
;
121 if (NULL
!= (var
= strchr(end
, ':')))
123 var
++; /* skip ':' */
124 while (isspace((int) *var
))
127 if (starttoken(*var
))
131 while (intoken(*var
))
136 *vartype
= strdup(var_start
);
143 *arglist
= strdup(start
);
149 /* Algorithm adapted from from GNU etags.
150 * Locates tags for procedures & functions. Doesn't do any type- or
151 * var-definitions. It does look for the keyword "extern" or "forward"
152 * immediately following the procedure statement; if found, the tag is
155 static void findPascalTags (void)
157 vString
*name
= vStringNew ();
159 char *arglist
= NULL
;
160 char *vartype
= NULL
;
161 pascalKind kind
= K_FUNCTION
;
162 /* each of these flags is TRUE iff: */
163 boolean incomment
= FALSE
; /* point is inside a comment */
164 int comment_char
= '\0'; /* type of current comment */
165 boolean inquote
= FALSE
; /* point is inside '..' string */
166 boolean get_tagname
= FALSE
;/* point is after PROCEDURE/FUNCTION
167 keyword, so next item = potential tag */
168 boolean found_tag
= FALSE
; /* point is after a potential tag */
169 boolean inparms
= FALSE
; /* point is within parameter-list */
170 boolean verify_tag
= FALSE
; /* point has passed the parm-list, so the
171 next token will determine whether this
172 is a FORWARD/EXTERN to be ignored, or
173 whether it is a real tag */
175 dbp
= fileReadLine ();
180 if (c
== '\0') /* if end of line */
182 dbp
= fileReadLine ();
183 if (dbp
== NULL
|| *dbp
== '\0')
185 if (!((found_tag
&& verify_tag
) || get_tagname
))
186 c
= *dbp
++; /* only if don't need *dbp pointing
187 to the beginning of the name of
188 the procedure or function */
192 if (comment_char
== '{' && c
== '}')
194 else if (comment_char
== '(' && c
== '*' && *dbp
== ')')
210 inquote
= TRUE
; /* found first quote */
212 case '{': /* found open { comment */
217 if (*dbp
== '*') /* found open (* comment */
223 else if (found_tag
) /* found '(' after tag, i.e., parm-list */
226 case ')': /* end of parms list */
231 if (found_tag
&& !inparms
) /* end of proc or fn stmt */
238 if (found_tag
&& verify_tag
&& *dbp
!= ' ')
240 /* check if this is an "extern" declaration */
243 if (tolower ((int) *dbp
== 'e'))
245 if (tail ("extern")) /* superfluous, really! */
251 else if (tolower ((int) *dbp
) == 'f')
253 if (tail ("forward")) /* check for forward reference */
259 else if (tolower ((int) *dbp
) == 't')
261 if (tail ("type")) /* check for forward reference */
267 if (found_tag
&& verify_tag
) /* not external proc, so make tag */
271 makePascalTag (&tag
);
275 if (get_tagname
) /* grab name of proc or fn */
277 const unsigned char *cp
;
282 /* grab block name */
283 while (isspace ((int) *dbp
))
285 for (cp
= dbp
; *cp
!= '\0' && !endtoken (*cp
) ; cp
++)
287 vStringNCopyS (name
, (const char*) dbp
, cp
- dbp
);
289 if (kind
== K_FUNCTION
)
291 parseArglist((const char*) cp
, &arglist
, (kind
== K_FUNCTION
) ? &vartype
: NULL
);
292 createPascalTag (&tag
, name
, kind
, arglist
, (kind
== K_FUNCTION
) ? vartype
: NULL
);
293 dbp
= cp
; /* set dbp to e-o-token */
296 /* and proceed to check for "extern" */
298 else if (!incomment
&& !inquote
&& !found_tag
)
300 switch (tolower ((int) c
))
303 if (tail ("onstructor"))
310 if (tail ("estructor"))
317 if (tail ("rocedure"))
324 if (tail ("unction"))
338 } /* while not eof */
345 extern parserDefinition
* PascalParser (void)
347 static const char *const extensions
[] = { "p", "pas", NULL
};
348 parserDefinition
* def
= parserNew ("Pascal");
349 def
->extensions
= extensions
;
350 def
->kinds
= PascalKinds
;
351 def
->kindCount
= KIND_COUNT (PascalKinds
);
352 def
->parser
= findPascalTags
;
356 /* vi:set tabstop=8 shiftwidth=4: */