/*
*   $Id: pascal.c 536 2007-06-02 06:09:00Z elliotth $
*
*   Copyright (c) 2001-2002, Darren Hiebert
*
*   This source code is released for free distribution under the terms of the
*   GNU General Public License.
*
*   This module contains functions for generating tags for the Pascal language,
*   including some extensions for Object Pascal.
*/

/*
*   INCLUDE FILES
*/
#include "general.h"  /* must always come first */

#include <string.h>

#include "entry.h"
#include "parse.h"
#include "read.h"
#include "vstring.h"

/*
*   DATA DEFINITIONS
*/
typedef enum {
	K_FUNCTION, K_PROCEDURE
} pascalKind;

static kindOption PascalKinds [] = {
	{ TRUE, 'f', "function",  "functions"},
	{ TRUE, 'p', "procedure", "procedures"}
};

/*
*   FUNCTION DEFINITIONS
*/

static void createPascalTag (
		tagEntryInfo* const tag, const vString* const name, const int kind)
{
	if (PascalKinds [kind].enabled  &&  name != NULL  &&  vStringLength (name) > 0)
	{
	    initTagEntry (tag, vStringValue (name));
	    tag->kindName = PascalKinds [kind].name;
	    tag->kind     = PascalKinds [kind].letter;
	}
	else
	    initTagEntry (tag, NULL);
}

static void makePascalTag (const tagEntryInfo* const tag)
{
	if (tag->name != NULL)
		makeTagEntry (tag);
}

static const unsigned char* dbp;

#define starttoken(c) (isalpha ((int) c) || (int) c == '_')
#define intoken(c)    (isalnum ((int) c) || (int) c == '_' || (int) c == '.')
#define endtoken(c)   (! intoken (c)  &&  ! isdigit ((int) c))

static boolean tail (const char *cp)
{
	boolean result = FALSE;
	register int len = 0;

	while (*cp != '\0' && tolower ((int) *cp) == tolower ((int) dbp [len]))
		cp++, len++;
	if (*cp == '\0' && !intoken (dbp [len]))
	{
		dbp += len;
		result = TRUE;
	}
	return result;
}

/* Algorithm adapted from from GNU etags.
 * Locates tags for procedures & functions.  Doesn't do any type- or
 * var-definitions.  It does look for the keyword "extern" or "forward"
 * immediately following the procedure statement; if found, the tag is
 * skipped.
 */
static void findPascalTags (void)
{
	vString *name = vStringNew ();
	tagEntryInfo tag;
	pascalKind kind = K_FUNCTION;
		/* each of these flags is TRUE iff: */
	boolean incomment = FALSE;  /* point is inside a comment */
	int comment_char = '\0';    /* type of current comment */
	boolean inquote = FALSE;    /* point is inside '..' string */
	boolean get_tagname = FALSE;/* point is after PROCEDURE/FUNCTION
		keyword, so next item = potential tag */
	boolean found_tag = FALSE;  /* point is after a potential tag */
	boolean inparms = FALSE;    /* point is within parameter-list */
	boolean verify_tag = FALSE;
		/* point has passed the parm-list, so the next token will determine
		 * whether this is a FORWARD/EXTERN to be ignored, or whether it is a
		 * real tag
		 */

	dbp = fileReadLine ();
	while (dbp != NULL)
	{
		int c = *dbp++;

		if (c == '\0')  /* if end of line */
		{
			dbp = fileReadLine ();
			if (dbp == NULL  ||  *dbp == '\0')
				continue;
			if (!((found_tag && verify_tag) || get_tagname))
				c = *dbp++;
					/* only if don't need *dbp pointing to the beginning of
					 * the name of the procedure or function
					 */
		}
		if (incomment)
		{
			if (comment_char == '{' && c == '}')
				incomment = FALSE;
			else if (comment_char == '(' && c == '*' && *dbp == ')')
			{
				dbp++;
				incomment = FALSE;
			}
			continue;
		}
		else if (inquote)
		{
			if (c == '\'')
				inquote = FALSE;
			continue;
		}
		else switch (c)
		{
			case '\'':
				inquote = TRUE;  /* found first quote */
				continue;
			case '{':  /* found open { comment */
				incomment = TRUE;
				comment_char = c;
				continue;
			case '(':
				if (*dbp == '*')  /* found open (* comment */
				{
					incomment = TRUE;
					comment_char = c;
					dbp++;
				}
				else if (found_tag)  /* found '(' after tag, i.e., parm-list */
					inparms = TRUE;
				continue;
			case ')':  /* end of parms list */
				if (inparms)
					inparms = FALSE;
				continue;
			case ';':
				if (found_tag && !inparms)  /* end of proc or fn stmt */
				{
					verify_tag = TRUE;
					break;
				}
				continue;
		}
		if (found_tag && verify_tag && *dbp != ' ')
		{
			/* check if this is an "extern" declaration */
			if (*dbp == '\0')
				continue;
			if (tolower ((int) *dbp == 'e'))
			{
				if (tail ("extern"))  /* superfluous, really! */
				{
					found_tag = FALSE;
					verify_tag = FALSE;
				}
			}
			else if (tolower ((int) *dbp) == 'f')
			{
				if (tail ("forward"))  /*  check for forward reference */
				{
					found_tag = FALSE;
					verify_tag = FALSE;
				}
			}
			if (found_tag && verify_tag)  /* not external proc, so make tag */
			{
				found_tag = FALSE;
				verify_tag = FALSE;
				makePascalTag (&tag);
				continue;
			}
		}
		if (get_tagname)  /* grab name of proc or fn */
		{
			const unsigned char *cp;

			if (*dbp == '\0')
				continue;

			/* grab block name */
			while (isspace ((int) *dbp))
				++dbp;
			for (cp = dbp  ;  *cp != '\0' && !endtoken (*cp)  ;  cp++)
				continue;
			vStringNCopyS (name, (const char*) dbp,  cp - dbp);
			createPascalTag (&tag, name, kind);
			dbp = cp;  /* set dbp to e-o-token */
			get_tagname = FALSE;
			found_tag = TRUE;
			/* and proceed to check for "extern" */
		}
		else if (!incomment && !inquote && !found_tag)
		{
			switch (tolower ((int) c))
			{
				case 'c':
					if (tail ("onstructor"))
					{
						get_tagname = TRUE;
						kind = K_PROCEDURE;
					}
					break;
				case 'd':
					if (tail ("estructor"))
					{
						get_tagname = TRUE;
						kind = K_PROCEDURE;
					}
					break;
				case 'p':
					if (tail ("rocedure"))
					{
						get_tagname = TRUE;
						kind = K_PROCEDURE;
					}
					break;
				case 'f':
					if (tail ("unction"))
					{
						get_tagname = TRUE;
						kind = K_FUNCTION;
					}
					break;
			}
		}  /* while not eof */
	}
	vStringDelete (name);
}

extern parserDefinition* PascalParser (void)
{
	static const char *const extensions [] = { "p", "pas", NULL };
	parserDefinition* def = parserNew ("Pascal");
	def->extensions = extensions;
	def->kinds      = PascalKinds;
	def->kindCount  = KIND_COUNT (PascalKinds);
	def->parser     = findPascalTags;
	return def;
}

/* vi:set tabstop=4 shiftwidth=4: */