ocaml.c

/*
*   Copyright (c) 2009, Vincent Berthoux
*
*   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 Objective Caml
*   language files.
*/
/*
*   INCLUDE FILES
*/
#include "general.h"	/* must always come first */

#include <string.h>

#include "keyword.h"
#include "entry.h"
#include "options.h"
#include "read.h"
#include "routines.h"
#include "vstring.h"

/* To get rid of unused parameter warning in
 * -Wextra */
#ifdef UNUSED
#elif defined(__GNUC__)
# define UNUSED(x) UNUSED_ ## x __attribute__((unused))
#elif defined(__LCLINT__)
# define UNUSED(x) /*@unused@*/ x
#else
# define UNUSED(x) x
#endif
#define OCAML_MAX_STACK_SIZE 256

typedef enum {
	K_CLASS,        /* Ocaml class, relatively rare */
	K_METHOD,       /* class method */
	K_MODULE,       /* Ocaml module OR functor */
	K_VAR,
	K_TYPE,         /* name of an OCaml type */
	K_FUNCTION,
	K_CONSTRUCTOR,  /* Constructor of a sum type */
	K_RECORDFIELD,
	K_EXCEPTION
} ocamlKind;

static kindOption OcamlKinds[] = {
	{TRUE, 'c', "class", "classes"},
	{TRUE, 'm', "method", "Object's method"},
	{TRUE, 'M', "module", "Module or functor"},
	{TRUE, 'v', "var", "Global variable"},
	{TRUE, 't', "type", "Type name"},
	{TRUE, 'f', "function", "A function"},
	{TRUE, 'C', "Constructor", "A constructor"},
	{TRUE, 'r', "Record field", "A 'structure' field"},
	{TRUE, 'e', "Exception", "An exception"}
};

typedef enum {
	OcaKEYWORD_and,
	OcaKEYWORD_begin,
	OcaKEYWORD_class,
	OcaKEYWORD_do,
	OcaKEYWORD_done,
	OcaKEYWORD_else,
	OcaKEYWORD_end,
	OcaKEYWORD_exception,
	OcaKEYWORD_for,
	OcaKEYWORD_functor,
	OcaKEYWORD_fun,
	OcaKEYWORD_if,
	OcaKEYWORD_in,
	OcaKEYWORD_let,
	OcaKEYWORD_match,
	OcaKEYWORD_method,
	OcaKEYWORD_module,
	OcaKEYWORD_mutable,
	OcaKEYWORD_object,
	OcaKEYWORD_of,
	OcaKEYWORD_rec,
	OcaKEYWORD_sig,
	OcaKEYWORD_struct,
	OcaKEYWORD_then,
	OcaKEYWORD_try,
	OcaKEYWORD_type,
	OcaKEYWORD_val,
	OcaKEYWORD_virtual,
	OcaKEYWORD_while,
	OcaKEYWORD_with,

	OcaIDENTIFIER,
	Tok_PARL,       /* '(' */
	Tok_PARR,       /* ')' */
	Tok_BRL,        /* '[' */
	Tok_BRR,        /* ']' */
	Tok_CurlL,      /* '{' */
	Tok_CurlR,      /* '}' */
	Tok_Prime,      /* '\'' */
	Tok_Pipe,       /* '|' */
	Tok_EQ,         /* '=' */
	Tok_Val,        /* string/number/poo */
	Tok_Op,         /* any operator recognized by the language */
	Tok_semi,       /* ';' */
	Tok_comma,      /* ',' */
	Tok_To,         /* '->' */
	Tok_Sharp,      /* '#' */
	Tok_Backslash,  /* '\\' */

	Tok_EOF         /* END of file */
} ocamlKeyword;

typedef struct sOcaKeywordDesc {
	const char *name;
	ocamlKeyword id;
} ocaKeywordDesc;

typedef ocamlKeyword ocaToken;

static const ocaKeywordDesc OcamlKeywordTable[] = {
	{ "and"       , OcaKEYWORD_and       }, 
	{ "begin"     , OcaKEYWORD_begin     }, 
	{ "class"     , OcaKEYWORD_class     }, 
	{ "do"        , OcaKEYWORD_do        }, 
	{ "done"      , OcaKEYWORD_done      }, 
	{ "else"      , OcaKEYWORD_else      }, 
	{ "end"       , OcaKEYWORD_end       }, 
	{ "exception" , OcaKEYWORD_exception }, 
	{ "for"       , OcaKEYWORD_for       }, 
	{ "fun"       , OcaKEYWORD_fun       }, 
	{ "function"  , OcaKEYWORD_fun       }, 
	{ "functor"   , OcaKEYWORD_functor   }, 
	{ "in"        , OcaKEYWORD_in        }, 
	{ "let"       , OcaKEYWORD_let       }, 
	{ "match"     , OcaKEYWORD_match     }, 
	{ "method"    , OcaKEYWORD_method    }, 
	{ "module"    , OcaKEYWORD_module    }, 
	{ "mutable"   , OcaKEYWORD_mutable   }, 
	{ "object"    , OcaKEYWORD_object    }, 
	{ "of"        , OcaKEYWORD_of        }, 
	{ "rec"       , OcaKEYWORD_rec       }, 
	{ "sig"       , OcaKEYWORD_sig       }, 
	{ "struct"    , OcaKEYWORD_struct    }, 
	{ "then"      , OcaKEYWORD_then      }, 
	{ "try"       , OcaKEYWORD_try       }, 
	{ "type"      , OcaKEYWORD_type      }, 
	{ "val"       , OcaKEYWORD_val       }, 
	{ "value"     , OcaKEYWORD_let       }, /* just to handle revised syntax */
	{ "virtual"   , OcaKEYWORD_virtual   }, 
	{ "while"     , OcaKEYWORD_while     }, 
	{ "with"      , OcaKEYWORD_with      }, 

	{ "or"        , Tok_Op               }, 
	{ "mod "      , Tok_Op               }, 
	{ "land "     , Tok_Op               }, 
	{ "lor "      , Tok_Op               }, 
	{ "lxor "     , Tok_Op               }, 
	{ "lsl "      , Tok_Op               }, 
	{ "lsr "      , Tok_Op               }, 
	{ "asr"       , Tok_Op               }, 
	{ "->"        , Tok_To               }, 
	{ "true"      , Tok_Val              }, 
	{ "false"     , Tok_Val              }
};

static langType Lang_Ocaml;

boolean exportLocalInfo = FALSE;

/*//////////////////////////////////////////////////////////////////
//// lexingInit             */
typedef struct _lexingState {
	vString *name;	/* current parsed identifier/operator */
	const unsigned char *cp;	/* position in stream */
} lexingState;

/* array of the size of all possible value for a char */
boolean isOperator[1 << (8 * sizeof (char))] = { FALSE };

static void initKeywordHash ( void )
{
	const size_t count = sizeof (OcamlKeywordTable) / sizeof (ocaKeywordDesc);
	size_t i;

	for (i = 0; i < count; ++i)
	{
		addKeyword (OcamlKeywordTable[i].name, Lang_Ocaml,
			(int) OcamlKeywordTable[i].id);
	}
}

/* definition of all the operator in OCaml,
 * /!\ certain operator get special treatment
 * in regards of their role in OCaml grammar :
 * '|' ':' '=' '~' and '?' */
static void initOperatorTable ( void )
{
	isOperator['!'] = TRUE;
	isOperator['$'] = TRUE;
	isOperator['%'] = TRUE;
	isOperator['&'] = TRUE;
	isOperator['*'] = TRUE;
	isOperator['+'] = TRUE;
	isOperator['-'] = TRUE;
	isOperator['.'] = TRUE;
	isOperator['/'] = TRUE;
	isOperator[':'] = TRUE;
	isOperator['<'] = TRUE;
	isOperator['='] = TRUE;
	isOperator['>'] = TRUE;
	isOperator['?'] = TRUE;
	isOperator['@'] = TRUE;
	isOperator['^'] = TRUE;
	isOperator['~'] = TRUE;
	isOperator['|'] = TRUE;
}

/*//////////////////////////////////////////////////////////////////////
//// Lexing                                     */
static boolean isNum (char c)
{
	return c >= '0' && c <= '9';
}
static boolean isLowerAlpha (char c)
{
	return c >= 'a' && c <= 'z';
}

static boolean isUpperAlpha (char c)
{
	return c >= 'A' && c <= 'Z';
}

static boolean isAlpha (char c)
{
	return isLowerAlpha (c) || isUpperAlpha (c);
}

static boolean isIdent (char c)
{
	return isNum (c) || isAlpha (c) || c == '_' || c == '\'';
}

static boolean isSpace (char c)
{
	return c == ' ' || c == '\t' || c == '\r' || c == '\n';
}

static void eatWhiteSpace (lexingState * st)
{
	const unsigned char *cp = st->cp;
	while (isSpace (*cp))
		cp++;

	st->cp = cp;
}

static void eatString (lexingState * st)
{
	boolean lastIsBackSlash = FALSE;
	boolean unfinished = TRUE;
	const unsigned char *c = st->cp + 1;

	while (unfinished)
	{
		/* end of line should never happen.
		 * we tolerate it */
		if (c == NULL || c[0] == '\0')
			break;
		else if (*c == '"' && !lastIsBackSlash)
			unfinished = FALSE;
		else
			lastIsBackSlash = *c == '\\';

		c++;
	}

	st->cp = c;
}

static void eatComment (lexingState * st)
{
	boolean unfinished = TRUE;
	boolean lastIsStar = FALSE;
	const unsigned char *c = st->cp + 2;

	while (unfinished)
	{
		/* we've reached the end of the line..
		 * so we have to reload a line... */
		if (c == NULL || *c == '\0')
		{
			st->cp = fileReadLine ();
			/* WOOPS... no more input...
			 * we return, next lexing read
			 * will be null and ok */
			if (st->cp == NULL)
				return;
			c = st->cp;
			continue;
		}
		/* we've reached the end of the comment */
		else if (*c == ')' && lastIsStar)
			unfinished = FALSE;
		/* here we deal with imbricated comment, which
		 * are allowed in OCaml */
		else if (c[0] == '(' && c[1] == '*')
		{
			st->cp = c;
			eatComment (st);
			c = st->cp;
			lastIsStar = FALSE;
		}
		else
			lastIsStar = '*' == *c;

		c++;
	}

	st->cp = c;
}

static void readIdentifier (lexingState * st)
{
	const unsigned char *p;
	vStringClear (st->name);

	/* first char is a simple letter */
	if (isAlpha (*st->cp) || *st->cp == '_')
		vStringPut (st->name, (int) *st->cp);

	/* Go till you get identifier chars */
	for (p = st->cp + 1; isIdent (*p); p++)
		vStringPut (st->name, (int) *p);

	st->cp = p;

	vStringTerminate (st->name);
}

static ocamlKeyword eatNumber (lexingState * st)
{
	while (isNum (*st->cp))
		st->cp++;
	return Tok_Val;
}

/* Operator can be defined in OCaml as a function
 * so we must be ample enough to parse them normally */
static ocamlKeyword eatOperator (lexingState * st)
{
	int count = 0;
	const unsigned char *root = st->cp;

	vStringClear (st->name);

	while (isOperator[st->cp[count]])
	{
		vStringPut (st->name, st->cp[count]);
		count++;
	}

	vStringTerminate (st->name);

	st->cp += count;
	if (count <= 1)
	{
		switch (root[0])
		{
		case '|':
			return Tok_Pipe;
		case '=':
			return Tok_EQ;
		default:
			return Tok_Op;
		}
	}
	else if (count == 2 && root[0] == '-' && root[1] == '>')
		return Tok_To;
	else
		return Tok_Op;
}

/* The lexer is in charge of reading the file.
 * Some of sub-lexer (like eatComment) also read file.
 * lexing is finished when the lexer return Tok_EOF */
static ocamlKeyword lex (lexingState * st)
{
	int retType;
	/* handling data input here */
	while (st->cp == NULL || st->cp[0] == '\0')
	{
		st->cp = fileReadLine ();
		if (st->cp == NULL)
			return Tok_EOF;
	}

	if (isAlpha (*st->cp))
	{
		readIdentifier (st);
		retType = lookupKeyword (vStringValue (st->name), Lang_Ocaml);

		if (retType == -1)	/* If it's not a keyword */
		{
			return OcaIDENTIFIER;
		}
		else
		{
			return retType;
		}
	}
	else if (isNum (*st->cp))
		return eatNumber (st);
	else if (isSpace (*st->cp))
	{
		eatWhiteSpace (st);
		return lex (st);
	}
	/* OCaml permit the definition of our own operators
	 * so here we check all the consecuting chars which
	 * are operators to discard them. */
	else if (isOperator[*st->cp])
		return eatOperator (st);
	else
		switch (*st->cp)
		{
		case '(':
			if (st->cp[1] == '*')	/* ergl, a comment */
			{
				eatComment (st);
				return lex (st);
			}
			else
			{
				st->cp++;
				return Tok_PARL;
			}

		case ')':
			st->cp++;
			return Tok_PARR;
		case '[':
			st->cp++;
			return Tok_BRL;
		case ']':
			st->cp++;
			return Tok_BRR;
		case '{':
			st->cp++;
			return Tok_CurlL;
		case '}':
			st->cp++;
			return Tok_CurlR;
		case '\'':
			st->cp++;
			return Tok_Prime;
		case ',':
			st->cp++;
			return Tok_comma;
		case '=':
			st->cp++;
			return Tok_EQ;
		case ';':
			st->cp++;
			return Tok_semi;
		case '"':
			eatString (st);
			return Tok_Val;
		case '_':
			st->cp++;
			return Tok_Val;
		case '#':
			st->cp++;
			return Tok_Sharp;
		case '\\':
			st->cp++;
			return Tok_Backslash;

		default:
			st->cp++;
			break;
		}

	/* default return if nothing is recognized,
	 * shouldn't happen, but at least, it will
	 * be handled without destroying the parsing. */
	return Tok_Val;
}

/*//////////////////////////////////////////////////////////////////////
//// Parsing                                    */
typedef void (*parseNext) (vString * const ident, ocaToken what);

/********** Helpers */
/* This variable hold the 'parser' which is going to
 * handle the next token */
parseNext toDoNext;

/* Special variable used by parser eater to
 * determine which action to put after their
 * job is finished. */
parseNext comeAfter;

/* If a token put an end to current delcaration/
 * statement */
ocaToken terminatingToken;

/* Token to be searched by the different
 * parser eater. */
ocaToken waitedToken;

/* name of the last class, used for
 * context stacking. */
vString *lastClass;

vString *voidName;

typedef enum _sContextKind {
	ContextStrong,
	ContextSoft
} contextKind;

typedef enum _sContextType {
	ContextType,
	ContextModule,
	ContextClass,
	ContextValue,
	ContextFunction,
	ContextMethod,
	ContextBlock
} contextType;

typedef struct _sOcamlContext {
	contextKind kind;	/* well if the context is strong or not */
	contextType type;
	parseNext callback;	/* what to do when a context is pop'd */
	vString *contextName;	/* name, if any, of the surrounding context */
} ocamlContext;

/* context stack, can be used to output scope information
 * into the tag file. */
ocamlContext stack[OCAML_MAX_STACK_SIZE];
/* current position in the tag */
int stackIndex;

/* special function, often recalled, so putting it here */
static void globalScope (vString * const ident, ocaToken what);

/* Return : index of the last named context if one
 *          is found, -1 otherwise */
static int getLastNamedIndex ( void )
{
	int i;

	for (i = stackIndex - 1; i >= 0; --i)
	{
		if (stack[i].contextName->buffer &&
			strlen (stack[i].contextName->buffer) > 0)
		{
			return i;
		}
	}

	return -1;
}

static const char *contextDescription (contextType t)
{
	switch (t)
	{
	case ContextFunction:
		return "function";
	case ContextMethod:
		return "method";
	case ContextValue:
		return "value";
	case ContextModule:
		return "Module";
	case ContextType:
		return "type";
	case ContextClass:
		return "class";
	case ContextBlock:
		return "begin/end";
	}

	return NULL;
}

static char contextTypeSuffix (contextType t)
{
	switch (t)
	{
	case ContextFunction:
	case ContextMethod:
	case ContextValue:
	case ContextModule:
		return '/';
	case ContextType:
		return '.';
	case ContextClass:
		return '#';
	case ContextBlock:
		return ' ';
	}

	return '$';
}

/* Push a new context, handle null string */
static void pushContext (contextKind kind, contextType type, parseNext after,
        vString const *contextName)
{
	int parentIndex;

	if (stackIndex >= OCAML_MAX_STACK_SIZE)
	{
		verbose ("OCaml Maximum depth reached");
		return;
	}


	stack[stackIndex].kind = kind;
	stack[stackIndex].type = type;
	stack[stackIndex].callback = after;

	parentIndex = getLastNamedIndex ();
	if (contextName == NULL)
	{
		vStringClear (stack[stackIndex++].contextName);
		return;
	}

	if (parentIndex >= 0)
	{
		vStringCopy (stack[stackIndex].contextName,
			stack[parentIndex].contextName);
		vStringPut (stack[stackIndex].contextName,
			contextTypeSuffix (stack[parentIndex].type));

		vStringCat (stack[stackIndex].contextName, contextName);
	}
	else
		vStringCopy (stack[stackIndex].contextName, contextName);

	stackIndex++;
}

static void pushStrongContext (vString * name, contextType type)
{
	pushContext (ContextStrong, type, &globalScope, name);
}

static void pushSoftContext (parseNext continuation,
	vString * name, contextType type)
{
	pushContext (ContextSoft, type, continuation, name);
}

static void pushEmptyContext (parseNext continuation)
{
	pushContext (ContextSoft, ContextValue, continuation, NULL);
}

/* unroll the stack until the last named context.
 * then discard it. Used to handle the :
 * let f x y = ...
 * in ...
 * where the context is reseted after the in. Context may have
 * been really nested before that. */
static void popLastNamed ( void )
{
	int i = getLastNamedIndex ();

	if (i >= 0)
	{
		stackIndex = i;
		toDoNext = stack[i].callback;
		vStringClear (stack[i].contextName);
	}
	else
	{
		/* ok, no named context found... 
		 * (should not happen). */
		stackIndex = 0;
		toDoNext = &globalScope;
	}
}

/* pop a context without regarding it's content
 * (beside handling empty stack case) */
static void popSoftContext ( void )
{
	if (stackIndex <= 0)
	{
		toDoNext = &globalScope;
	}
	else
	{
		stackIndex--;
		toDoNext = stack[stackIndex].callback;
		vStringClear (stack[stackIndex].contextName);
	}
}

/* Reset everything until the last global space.
 * a strong context can be :
 * - module
 * - class definition
 * - the initial global space
 * - a _global_ delcaration (let at global scope or in a module).
 * Created to exit quickly deeply nested context */
static contextType popStrongContext ( void )
{
	int i;

	for (i = stackIndex - 1; i >= 0; --i)
	{
		if (stack[i].kind == ContextStrong)
		{
			stackIndex = i;
			toDoNext = stack[i].callback;
			vStringClear (stack[i].contextName);
			return stack[i].type;
		}
	}
	/* ok, no strong context found... */
	stackIndex = 0;
	toDoNext = &globalScope;
	return -1;
}

/* Ignore everything till waitedToken and jump to comeAfter.
 * If the "end" keyword is encountered break, doesn't remember
 * why though. */
static void tillToken (vString * const UNUSED (ident), ocaToken what)
{
	if (what == waitedToken)
		toDoNext = comeAfter;
	else if (what == OcaKEYWORD_end)
	{
		popStrongContext ();
		toDoNext = &globalScope;
	}
}

/* Ignore everything till a waitedToken is seen, but
 * take care of balanced parentheses/bracket use */
static void contextualTillToken (vString * const UNUSED (ident), ocaToken what)
{
	static int parentheses = 0;
	static int bracket = 0;
	static int curly = 0;

	switch (what)
	{
	case Tok_PARL:
		parentheses--;
		break;
	case Tok_PARR:
		parentheses++;
		break;
	case Tok_CurlL:
		curly--;
		break;
	case Tok_CurlR:
		curly++;
		break;
	case Tok_BRL:
		bracket--;
		break;
	case Tok_BRR:
		bracket++;
		break;

	default:	/* other token are ignored */
		break;
	}

	if (what == waitedToken && parentheses == 0 && bracket == 0 && curly == 0)
		toDoNext = comeAfter;

	else if (what == OcaKEYWORD_end)
	{
		popStrongContext ();
		toDoNext = &globalScope;
	}
}

/* Wait for waitedToken and jump to comeAfter or let
 * the globalScope handle declarations */
static void tillTokenOrFallback (vString * const ident, ocaToken what)
{
	if (what == waitedToken)
		toDoNext = comeAfter;
	else
		globalScope (ident, what);
}

/* ignore token till waitedToken, or give up if find
 * terminatingToken. Use globalScope to handle new
 * declarations. */
static void tillTokenOrTerminatingOrFallback (vString * const ident,
	ocaToken what)
{
	if (what == waitedToken)
		toDoNext = comeAfter;
	else if (what == terminatingToken)
		toDoNext = globalScope;
	else
		globalScope (ident, what);
}

/* ignore the next token in the stream and jump to the
 * given comeAfter state */
static void ignoreToken (vString * const UNUSED (ident), ocaToken UNUSED (what))
{
	toDoNext = comeAfter;
}

/********** Grammar */
/* the purpose of each function is detailled near their
 * implementation */

static void killCurrentState ( void )
{

	/* Tracking the kind of previous strong
	 * context, if it doesn't match with a
	 * really strong entity, repop */
	switch (popStrongContext ())
	{

	case ContextValue:
		popStrongContext ();
		break;
	case ContextFunction:
		popStrongContext ();
		break;
	case ContextMethod:
		popStrongContext ();
		break;

	case ContextType:
		popStrongContext();
		break;
	case ContextBlock:
		break;
	case ContextModule:
		break;
	case ContextClass:
		break;
	default:
		/* nothing more */
		break;
	}
}

/* used to prepare tag for OCaml, just in case their is a need to
 * add additional information to the tag. */
static void prepareTag (tagEntryInfo * tag, vString const *name, ocamlKind kind)
{
	int parentIndex;

	initTagEntry (tag, vStringValue (name));
	tag->kindName = OcamlKinds[kind].name;
	tag->kind = OcamlKinds[kind].letter;

	if (kind == K_MODULE)
	{
		tag->lineNumberEntry = TRUE;
		tag->lineNumber = 1;
	}
	parentIndex = getLastNamedIndex ();
	if (parentIndex >= 0)
	{
		tag->extensionFields.scope[0] =
			contextDescription (stack[parentIndex].type);
		tag->extensionFields.scope[1] =
			vStringValue (stack[parentIndex].contextName);
	}
}

/* Used to centralise tag creation, and be able to add
 * more information to it in the future */
static void addTag (vString * const ident, int kind)
{
	if (OcamlKinds [kind].enabled  &&  ident != NULL  &&  vStringLength (ident) > 0)
	{
		tagEntryInfo toCreate;
		prepareTag (&toCreate, ident, kind);
		makeTagEntry (&toCreate);
	}
}

boolean needStrongPoping = FALSE;
static void requestStrongPoping ( void )
{
	needStrongPoping = TRUE;
}

static void cleanupPreviousParser ( void )
{
	if (needStrongPoping)
	{
		needStrongPoping = FALSE;
		popStrongContext ();
	}
}

/* Due to some circular dependencies, the following functions
 * must be forward-declared. */
static void letParam (vString * const ident, ocaToken what);
static void localScope (vString * const ident, ocaToken what);
static void mayRedeclare (vString * const ident, ocaToken what);
static void typeSpecification (vString * const ident, ocaToken what);

/*
 * Parse a record type
 * type ident = // parsed previously
 *  {
 *      ident1: type1;
 *      ident2: type2;
 *  }
 */
static void typeRecord (vString * const ident, ocaToken what)
{
	switch (what)
	{
	case OcaIDENTIFIER:
		addTag (ident, K_RECORDFIELD);
		terminatingToken = Tok_CurlR;
		waitedToken = Tok_semi;
		comeAfter = &typeRecord;
		toDoNext = &tillTokenOrTerminatingOrFallback;
		break;

	case OcaKEYWORD_mutable:
		/* ignore it */
		break;

	case Tok_CurlR:
		popStrongContext ();
		toDoNext = &globalScope;
		break;

	default:	/* don't care */
		break;
	}
}

/* handle :
 * exception ExceptionName ... */
static void exceptionDecl (vString * const ident, ocaToken what)
{
	if (what == OcaIDENTIFIER)
	{
		addTag (ident, K_EXCEPTION);
	}
	/* don't know what to do on else... */

	toDoNext = &globalScope;
}

tagEntryInfo tempTag;
vString *tempIdent;

/* Ensure a constructor is not a type path beginning
 * with a module */
static void constructorValidation (vString * const ident, ocaToken what)
{
	switch (what)
	{
	case Tok_Op:	/* if we got a '.' which is an operator */
		toDoNext = &globalScope;
		popStrongContext ();
		needStrongPoping = FALSE;
		break;

	case OcaKEYWORD_of:	/* OK, it must be a constructor :) */
		makeTagEntry (&tempTag);
		vStringClear (tempIdent);
		toDoNext = &tillTokenOrFallback;
		comeAfter = &typeSpecification;
		waitedToken = Tok_Pipe;
		break;

	case Tok_Pipe:	/* OK, it was a constructor :)  */
		makeTagEntry (&tempTag);
		vStringClear (tempIdent);
		toDoNext = &typeSpecification;
		break;

	default:	/* and mean that we're not facing a module name */
		makeTagEntry (&tempTag);
		vStringClear (tempIdent);
		toDoNext = &tillTokenOrFallback;
		comeAfter = &typeSpecification;
		waitedToken = Tok_Pipe;

		/* nothing in the context, discard it */
		popStrongContext ();

		/* to be sure we use this token */
		globalScope (ident, what);
	}
}


/* Parse beginning of type definition
 * type 'avar ident =
 * or
 * type ('var1, 'var2) ident =
 */
static void typeDecl (vString * const ident, ocaToken what)
{

	switch (what)
	{
		/* parameterized */
	case Tok_Prime:
		comeAfter = &typeDecl;
		toDoNext = &ignoreToken;
		break;
		/* LOTS of parameters */
	case Tok_PARL:
		comeAfter = &typeDecl;
		waitedToken = Tok_PARR;
		toDoNext = &tillToken;
		break;

	case OcaIDENTIFIER:
		addTag (ident, K_TYPE);
		pushStrongContext (ident, ContextType);
		requestStrongPoping ();
		waitedToken = Tok_EQ;
		comeAfter = &typeSpecification;
		toDoNext = &tillTokenOrFallback;
		break;

	default:
		globalScope (ident, what);
	}
}

/* Parse type of kind
 * type bidule = Ctor1 of ...
 *             | Ctor2
 *             | Ctor3 of ...
 * or
 * type bidule = | Ctor1 of ... | Ctor2
 *
 * when type bidule = { ... } is detected,
 * let typeRecord handle it. */
static void typeSpecification (vString * const ident, ocaToken what)
{

	switch (what)
	{
	case OcaIDENTIFIER:
		if (isUpperAlpha (ident->buffer[0]))
		{
			/* here we handle type aliases of type
			 * type foo = AnotherModule.bar
			 * AnotherModule can mistakenly be took
			 * for a constructor. */
			vStringCopy (tempIdent, ident);
			prepareTag (&tempTag, tempIdent, K_CONSTRUCTOR);
			toDoNext = &constructorValidation;
		}
		else
		{
			toDoNext = &tillTokenOrFallback;
			comeAfter = &typeSpecification;
			waitedToken = Tok_Pipe;
		}
		break;

	case OcaKEYWORD_and:
		toDoNext = &typeDecl;
		break;

	case Tok_BRL:	/* the '[' & ']' are ignored to accommodate */
	case Tok_BRR:	/* with the revised syntax */
	case Tok_Pipe:
		/* just ignore it */
		break;

	case Tok_CurlL:
		toDoNext = &typeRecord;
		break;

	default:	/* don't care */
		break;
	}
}


static boolean dirtySpecialParam = FALSE;


/* parse the ~label and ~label:type parameter */
static void parseLabel (vString * const ident, ocaToken what)
{
	static int parCount = 0;

	switch (what)
	{
	case OcaIDENTIFIER:
		if (!dirtySpecialParam)
		{

			if (exportLocalInfo)
				addTag (ident, K_VAR);

			dirtySpecialParam = TRUE;
		}
		break;

	case Tok_PARL:
		parCount++;
		break;

	case Tok_PARR:
		parCount--;
		if (parCount == 0)
			toDoNext = &letParam;
		break;

	case Tok_Op:
		if (ident->buffer[0] == ':')
		{
			toDoNext = &ignoreToken;
			comeAfter = &letParam;
		}
		else if (parCount == 0 && dirtySpecialParam)
		{
			toDoNext = &letParam;
			letParam (ident, what);
		}
		break;

	default:
		if (parCount == 0 && dirtySpecialParam)
		{
			toDoNext = &letParam;
			letParam (ident, what);
		}
		break;
	}
}


/* Optional argument with syntax like this :
 * ?(foo = value) */
static void parseOptionnal (vString * const ident, ocaToken what)
{
	static int parCount = 0;


	switch (what)
	{
	case OcaIDENTIFIER:
		if (!dirtySpecialParam)
		{
			if (exportLocalInfo)
				addTag (ident, K_VAR);

			dirtySpecialParam = TRUE;

			if (parCount == 0)
				toDoNext = &letParam;
		}
		break;

	case Tok_PARL:
		parCount++;
		break;

	case Tok_PARR:
		parCount--;
		if (parCount == 0)
			toDoNext = &letParam;
		break;

	default:	/* don't care */
		break;
	}
}


/** handle let inside functions (so like it's name
 * say : local let */
static void localLet (vString * const ident, ocaToken what)
{
	switch (what)
	{
	case Tok_PARL:
		/* We ignore this token to be able to parse such
		 * declarations :
		 * let (ident : type) = ...
		 */
		break;

	case OcaKEYWORD_rec:
		/* just ignore to be able to parse such declarations:
		 * let rec ident = ... */
		break;

	case Tok_Op:
		/* we are defining a new operator, it's a
		 * function definition */
		if (exportLocalInfo)
			addTag (ident, K_FUNCTION);

		pushSoftContext (mayRedeclare, ident, ContextFunction);
		toDoNext = &letParam;
		break;

		/* Can be a weiiird binding, or an '_' */
	case Tok_Val:
		if (exportLocalInfo)
			addTag (ident, K_VAR);
		pushSoftContext (mayRedeclare, ident, ContextValue);
		toDoNext = &letParam;
		break;

	case OcaIDENTIFIER:
		if (exportLocalInfo)
			addTag (ident, K_VAR);
		pushSoftContext (mayRedeclare, ident, ContextValue);
		toDoNext = &letParam;
		break;

	case OcaKEYWORD_end:
		popStrongContext ();
		break;

	default:
		toDoNext = &localScope;
		break;
	}
}

/* parse :
 * | pattern pattern -> ...
 * or
 * pattern apttern apttern -> ...
 * we ignore all identifiers declared in the pattern,
 * because their scope is likely to be even more limited
 * than the let definitions.
 * Used after a match ... with, or a function ... or fun ...
 * because their syntax is similar.  */
static void matchPattern (vString * const UNUSED (ident), ocaToken what)
{
	switch (what)
	{
	case Tok_To:
		pushEmptyContext (&matchPattern);
		toDoNext = &mayRedeclare;
		break;


	case OcaKEYWORD_in:
		popLastNamed ();
		break;

	default:
		break;
	}
}

/* Used at the beginning of a new scope (begin of a
 * definition, parenthesis...) to catch inner let
 * definition that may be in. */
static void mayRedeclare (vString * const ident, ocaToken what)
{
	switch (what)
	{
	case OcaKEYWORD_let:
	case OcaKEYWORD_val:
		toDoNext = localLet;
		break;

	case OcaKEYWORD_object:
		vStringClear (lastClass);
		pushContext (ContextStrong, ContextClass,
			&localScope, NULL /*voidName */ );
		needStrongPoping = FALSE;
		toDoNext = &globalScope;
		break;

	case OcaKEYWORD_for:
	case OcaKEYWORD_while:
		toDoNext = &tillToken;
		waitedToken = OcaKEYWORD_do;
		comeAfter = &mayRedeclare;
		break;

	case OcaKEYWORD_try:
		toDoNext = &mayRedeclare;
		pushSoftContext (matchPattern, ident, ContextFunction);
		break;

	case OcaKEYWORD_fun:
		toDoNext = &matchPattern;
		break;

		/* Handle the special ;; from the OCaml
		 * Top level */
	case Tok_semi:
	default:
		toDoNext = &localScope;
		localScope (ident, what);
	}
}

/* parse :
 * p1 p2 ... pn = ...
 * or
 * ?(p1=v) p2 ~p3 ~pn:ja ... = ... */
static void letParam (vString * const ident, ocaToken what)
{
	switch (what)
	{
	case Tok_EQ:
		toDoNext = &mayRedeclare;
		break;

	case OcaIDENTIFIER:
		if (exportLocalInfo)
			addTag (ident, K_VAR);
		break;

	case Tok_Op:
		switch (ident->buffer[0])
		{
		case ':':
			/*popSoftContext(); */
			/* we got a type signature */
			comeAfter = &mayRedeclare;
			toDoNext = &tillTokenOrFallback;
			waitedToken = Tok_EQ;
			break;

			/* parse something like
			 * ~varname:type 
			 * or
			 * ~varname
			 * or
			 * ~(varname: long type) */
		case '~':
			toDoNext = &parseLabel;
			dirtySpecialParam = FALSE;
			break;

			/* Optional argument with syntax like this :
			 * ?(bla = value) 
			 * or
			 * ?bla */
		case '?':
			toDoNext = &parseOptionnal;
			dirtySpecialParam = FALSE;
			break;

		default:
			break;
		}
		break;

	default:	/* don't care */
		break;
	}
}


/* parse object ...
 * used to be sure the class definition is not a type
 * alias */
static void classSpecif (vString * const UNUSED (ident), ocaToken what)
{
	switch (what)
	{
	case OcaKEYWORD_object:
		pushStrongContext (lastClass, ContextClass);
		toDoNext = &globalScope;
		break;

	default:
		vStringClear (lastClass);
		toDoNext = &globalScope;
	}
}

/* Handle a method ... class declaration.
 * nearly a copy/paste of globalLet. */
static void methodDecl (vString * const ident, ocaToken what)
{
	switch (what)
	{
	case Tok_PARL:
		/* We ignore this token to be able to parse such
		 * declarations :
		 * let (ident : type) = ...  */
		break;

	case OcaKEYWORD_mutable:
	case OcaKEYWORD_virtual:
	case OcaKEYWORD_rec:
		/* just ignore to be able to parse such declarations:
		 * let rec ident = ... */
		break;

	case OcaIDENTIFIER:
		addTag (ident, K_METHOD);
		/* Normal pushing to get good subs */
		pushStrongContext (ident, ContextMethod);
		/*pushSoftContext( globalScope, ident, ContextMethod ); */
		toDoNext = &letParam;
		break;

	case OcaKEYWORD_end:
		popStrongContext ();
		break;

	default:
		toDoNext = &globalScope;
		break;
	}
}

/* name of the last module, used for
 * context stacking. */
vString *lastModule;


/* parse
 * ... struct (* new global scope *) end
 * or
 * ... sig (* new global scope *) end
 * or
 * functor ... -> moduleSpecif
 */
static void moduleSpecif (vString * const ident, ocaToken what)
{
	switch (what)
	{
	case OcaKEYWORD_functor:
		toDoNext = &contextualTillToken;
		waitedToken = Tok_To;
		comeAfter = &moduleSpecif;
		break;

	case OcaKEYWORD_struct:
	case OcaKEYWORD_sig:
		pushStrongContext (lastModule, ContextModule);
		toDoNext = &globalScope;
		break;

	case Tok_PARL:	/* ( */
		toDoNext = &contextualTillToken;
		comeAfter = &globalScope;
		waitedToken = Tok_PARR;
		contextualTillToken (ident, what);
		break;

	default:
		vStringClear (lastModule);
		toDoNext = &globalScope;
	}
}

/* parse :
 * module name = ...
 * then pass the token stream to moduleSpecif */
static void moduleDecl (vString * const ident, ocaToken what)
{
	switch (what)
	{
	case OcaKEYWORD_type:
		/* just ignore it, name come after */
		break;

	case OcaIDENTIFIER:
		addTag (ident, K_MODULE);
		vStringCopy (lastModule, ident);
		waitedToken = Tok_EQ;
		comeAfter = &moduleSpecif;
		toDoNext = &contextualTillToken;
		break;

	default:	/* don't care */
		break;
	}
}

/* parse :
 * class name = ...
 * or
 * class virtual ['a,'b] classname = ... */
static void classDecl (vString * const ident, ocaToken what)
{
	switch (what)
	{
	case OcaIDENTIFIER:
		addTag (ident, K_CLASS);
		vStringCopy (lastClass, ident);
		toDoNext = &contextualTillToken;
		waitedToken = Tok_EQ;
		comeAfter = &classSpecif;
		break;

	case Tok_BRL:
		toDoNext = &tillToken;
		waitedToken = Tok_BRR;
		comeAfter = &classDecl;
		break;

	default:
		break;
	}
}

/* Handle a global
 * let ident ...
 * or
 * let rec ident ... */
static void globalLet (vString * const ident, ocaToken what)
{
	switch (what)
	{
	case Tok_PARL:
		/* We ignore this token to be able to parse such
		 * declarations :
		 * let (ident : type) = ...
		 */
		break;

	case OcaKEYWORD_mutable:
	case OcaKEYWORD_virtual:
	case OcaKEYWORD_rec:
		/* just ignore to be able to parse such declarations:
		 * let rec ident = ... */
		break;

	case Tok_Op:
		/* we are defining a new operator, it's a
		 * function definition */
		addTag (ident, K_FUNCTION);
		pushStrongContext (ident, ContextFunction);
		toDoNext = &letParam;
		break;

	case OcaIDENTIFIER:
		addTag (ident, K_VAR);
		pushStrongContext (ident, ContextValue);
		requestStrongPoping ();
		toDoNext = &letParam;
		break;

	case OcaKEYWORD_end:
		popStrongContext ();
		break;

	default:
		toDoNext = &globalScope;
		break;
	}
}

/* Handle the "strong" top levels, all 'big' declarations
 * happen here */
static void globalScope (vString * const UNUSED (ident), ocaToken what)
{
	/* Do not touch, this is used only by the global scope
	 * to handle an 'and' */
	static parseNext previousParser = NULL;

	switch (what)
	{
	case OcaKEYWORD_and:
		cleanupPreviousParser ();
		toDoNext = previousParser;
		break;

	case OcaKEYWORD_type:
		cleanupPreviousParser ();
		toDoNext = &typeDecl;
		previousParser = &typeDecl;
		break;

	case OcaKEYWORD_class:
		cleanupPreviousParser ();
		toDoNext = &classDecl;
		previousParser = &classDecl;
		break;

	case OcaKEYWORD_module:
		cleanupPreviousParser ();
		toDoNext = &moduleDecl;
		previousParser = &moduleDecl;
		break;

	case OcaKEYWORD_end:
		needStrongPoping = FALSE;
		killCurrentState ();
		/*popStrongContext(); */
		break;

	case OcaKEYWORD_method:
		cleanupPreviousParser ();
		toDoNext = &methodDecl;
		/* and is not allowed in methods */
		break;

		/* val is mixed with let as global
		 * to be able to handle mli & new syntax */
	case OcaKEYWORD_val:
	case OcaKEYWORD_let:
		cleanupPreviousParser ();
		toDoNext = &globalLet;
		previousParser = &globalLet;
		break;

	case OcaKEYWORD_exception:
		cleanupPreviousParser ();
		toDoNext = &exceptionDecl;
		previousParser = NULL;
		break;

		/* must be a #line directive, discard the
		 * whole line. */
	case Tok_Sharp:
		/* ignore */
		break;

	default:
		/* we don't care */
		break;
	}
}

/* Parse expression. Well ignore it is more the case,
 * ignore all tokens except "shocking" keywords */
static void localScope (vString * const ident, ocaToken what)
{
	switch (what)
	{
	case Tok_Pipe:
	case Tok_PARR:
	case Tok_BRR:
	case Tok_CurlR:
		popSoftContext ();
		break;

		/* Everything that `begin` has an `end`
		 * as end is overloaded and signal many end
		 * of things, we add an empty strong context to
		 * avoid problem with the end.
		 */
	case OcaKEYWORD_begin:
		pushContext (ContextStrong, ContextBlock, &mayRedeclare, NULL);
		toDoNext = &mayRedeclare;
		break;

	case OcaKEYWORD_in:
		popLastNamed ();
		break;

		/* Ok, we got a '{', which is much likely to create
		 * a record. We cannot treat it like other [ && (,
		 * because it may contain the 'with' keyword and screw
		 * everything else. */
	case Tok_CurlL:
		toDoNext = &contextualTillToken;
		waitedToken = Tok_CurlR;
		comeAfter = &localScope;
		contextualTillToken (ident, what);
		break;

		/* Yeah imperative feature of OCaml,
		 * a ';' like in C */
	case Tok_semi:
		toDoNext = &mayRedeclare;
		break;

	case Tok_PARL:
	case Tok_BRL:
		pushEmptyContext (&localScope);
		toDoNext = &mayRedeclare;
		break;

	case OcaKEYWORD_and:
		popLastNamed ();
		toDoNext = &localLet;
		break;

	case OcaKEYWORD_else:
	case OcaKEYWORD_then:
		popSoftContext ();
		pushEmptyContext (&localScope);
		toDoNext = &mayRedeclare;
		break;

	case OcaKEYWORD_if:
		pushEmptyContext (&localScope);
		toDoNext = &mayRedeclare;
		break;

	case OcaKEYWORD_match:
		pushEmptyContext (&localScope);
		toDoNext = &mayRedeclare;
		break;

	case OcaKEYWORD_with:
		popSoftContext ();
		toDoNext = &matchPattern;
		pushEmptyContext (&matchPattern);
		break;

	case OcaKEYWORD_end:
		killCurrentState ();
		break;


	case OcaKEYWORD_fun:
		comeAfter = &mayRedeclare;
		toDoNext = &tillToken;
		waitedToken = Tok_To;
		break;

	case OcaKEYWORD_done:
	case OcaKEYWORD_val:
		/* doesn't care */
		break;

	default:
		requestStrongPoping ();
		globalScope (ident, what);
		break;
	}
}

/*////////////////////////////////////////////////////////////////
//// Deal with the system                                       */
/* in OCaml the file name is the module name used in the language
 * with it first letter put in upper case */
static void computeModuleName ( void )
{
	/* in Ocaml the file name define a module.
	 * so we define a module =)
	 */
	const char *filename = getSourceFileName ();
	int beginIndex = 0;
	int endIndex = strlen (filename) - 1;
	vString *moduleName = vStringNew ();

	while (filename[endIndex] != '.' && endIndex > 0)
		endIndex--;

	/* avoid problem with path in front of filename */
	beginIndex = endIndex;
	while (beginIndex > 0)
	{
		if (filename[beginIndex] == '\\' || filename[beginIndex] == '/')
		{
			beginIndex++;
			break;
		}

		beginIndex--;
	}

	vStringNCopyS (moduleName, &filename[beginIndex], endIndex - beginIndex);
	vStringTerminate (moduleName);

	if (isLowerAlpha (moduleName->buffer[0]))
		moduleName->buffer[0] += ('A' - 'a');

	addTag (moduleName, K_MODULE);
	vStringDelete (moduleName);
}

/* Allocate all string of the context stack */
static void initStack ( void )
{
	int i;
	for (i = 0; i < OCAML_MAX_STACK_SIZE; ++i)
		stack[i].contextName = vStringNew ();
}

static void clearStack ( void )
{
	int i;
	for (i = 0; i < OCAML_MAX_STACK_SIZE; ++i)
		vStringDelete (stack[i].contextName);
}

static void findOcamlTags (void)
{
	vString *name = vStringNew ();
	lexingState st;
	ocaToken tok;

	computeModuleName ();
	initStack ();
	tempIdent = vStringNew ();
	lastModule = vStringNew ();
	lastClass = vStringNew ();
	voidName = vStringNew ();
	vStringCopyS (voidName, "_");

	st.name = vStringNew ();
	st.cp = fileReadLine ();
	toDoNext = &globalScope;
	tok = lex (&st);
	while (tok != Tok_EOF)
	{
		(*toDoNext) (st.name, tok);
		tok = lex (&st);
	}

	vStringDelete (name);
	vStringDelete (voidName);
	vStringDelete (tempIdent);
	vStringDelete (lastModule);
	vStringDelete (lastClass);
	clearStack ();
}

static void ocamlInitialize (const langType language)
{
	Lang_Ocaml = language;

	initOperatorTable ();
	initKeywordHash ();
}

extern parserDefinition *OcamlParser (void)
{
	static const char *const extensions[] = { "ml", "mli", NULL };
	parserDefinition *def = parserNew ("OCaml");
	def->kinds = OcamlKinds;
	def->kindCount = KIND_COUNT (OcamlKinds);
	def->extensions = extensions;
	def->parser = findOcamlTags;
	def->initialize = ocamlInitialize;

	return def;
}