Logo Search packages:      
Sourcecode: tclex version File versions  Download package

tcLex.c

/* 
 * tcLex.c --
 *
 *    This module implements a lexer (or lexical analyzer) command
 *    for Tcl. A lexer is used to parse text for processing with
 *    the Tcl language. It is intended to ease the task of people
 *    already using Tcl for regexp-based text processing.
 *
 * Inspired by Unix and GNU lex and flex
 *
 * Copyright (c) 1998 Frédéric BONNET <frederic.bonnet@ciril.fr>
 *
 * See the file "license.txt" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 */

#include "tcLex.h"
#include "tcLexInt.h"
#include "tcLexRE.h"

#include <tclInt.h>



/*******************************************************
 *                                                     *
 *          Conditions management functions            *
 *                                                     *
 *******************************************************/

/*
 *--------------------------------------------------------------
 *
 * ConditionIndex --
 *
 *    This procedure returns the index of a lexer's condition from
 *    a string.
 *
 * Results:
 *    0 for the initial condition;
 *    -1 if the condition doesn't exist;
 *    Else a positive integer corresponding to an index.
 *
 * Side effects:
 *    None.
 *
 *--------------------------------------------------------------
 */

static int
ConditionIndex(lexer, string)
    TcLex_Lexer   *lexer;
    char    *string; /* Condition to search for */
{
    int           i;
    char    *cond;

    /* 
     * Initial condition
     */

    if (   strcmp(string, "initial") == 0
      || strcmp(string, "0") == 0) {
      return 0;
    }

    /* 
     * Search for the condition
     */

    for (i=0; i < lexer->nbInclusiveConditions+lexer->nbExclusiveConditions; i++) {
      cond = Tcl_GetStringFromObj(lexer->conditions[i], NULL);
      if (strcmp(string, cond) == 0) {
            return i+1;
      }
    }

    /* 
     * None found, error
     */

    return -1;
}


/*
 *--------------------------------------------------------------
 *
 * ConditionFromIndex --
 *
 *    This procedure returns the condition from its index.
 *
 * Results:
 *    A Tcl_Obj* containing the condition's string, or NULL if
 *    the condition doesn't exist.
 *
 * Side effects:
 *    None.
 *
 *--------------------------------------------------------------
 */

static Tcl_Obj *
ConditionFromIndex(lexer, index)
    TcLex_Lexer   *lexer;
    int           index;  /* Index of the condition */
{ 
    /* 
     * Sanity check
     */

    if (   index < 0 
      || index > lexer->nbInclusiveConditions+lexer->nbExclusiveConditions)
      return NULL;

    /* 
     * Initial condition
     */

    if (index == 0) 
      return InitialCond;

    return lexer->conditions[index-1];
}


/*
 *--------------------------------------------------------------
 *
 * ConditionIsExclusive --
 *
 *    Check if the condition (given its index) is exclusive.
 *
 * Results:
 *    -1 if the condition doesn't exist;
 *     0 if the condition is inclusive;
 *     1 if the condition is inclusive.
 *
 * Side effects:
 *    None.
 *
 *--------------------------------------------------------------
 */

static int
ConditionIsExclusive(lexer, index)
    TcLex_Lexer   *lexer;
    int           index;  /* Index of the condition */
{
    /*
     * Sanity check
     */

    if (   index < 0 
      || index > lexer->nbInclusiveConditions+lexer->nbExclusiveConditions)
      return -1;

    if (index <= lexer->nbInclusiveConditions)
      return 0;

    return 1;
}


/*
 *--------------------------------------------------------------
 *
 * ConditionCurrent --
 *
 *    Return the current condition, ie the top of the stack.
 *
 * Results:
 *    A standard Tcl result.
 *
 * Side effects:
 *    None.
 *
 *--------------------------------------------------------------
 */

int
ConditionCurrent(interp, lexer)
    Tcl_Interp    *interp;
    TcLex_Lexer   *lexer;
{
    TcLex_State   *statePtr = lexer->states[lexer->curState];

    if (statePtr->conditionsStackLength == 0)
      Tcl_SetObjResult(interp, InitialCond);
    else
      Tcl_SetObjResult(interp, 
          ConditionFromIndex(lexer,
            statePtr->conditionsStack[statePtr->conditionsStackLength-1]));
      
    return TCL_OK;
}


/*******************************************************
 *                                                     *
 *             State management functions              *
 *                                                     *
 *******************************************************/

/*
 *--------------------------------------------------------------
 *
 * StateNew --
 *
 *    Create a new state for the given lexer, associated with the
 *    given string.
 *
 * Results:
 *    The index of the newly created state.
 *
 * Side effects:
 *    The lexer's <states> array is modified.
 *
 *--------------------------------------------------------------
 */

static int
StateNew(lexer, string)
    TcLex_Lexer   *lexer;
    Tcl_Obj *string;    /* String being lexed in the new state */
{
    int           i, n;              /* Index of the new state */
    TcLex_State   *statePtr; /* Newly created state    */

    /* 
     * If states already exist...
     */

    if (lexer->states) {
      /*
       * Search for a free slot in the <states> array
       */

      for (n=0; n < lexer->nbStates; n++)
          if (!lexer->states[n])
            goto init;

      /*
       * No slot found, so grow the array
       */

      n = lexer->nbStates++;
      lexer->states = (TcLex_State **)Tcl_Realloc((char *)lexer->states, sizeof(TcLex_State *) * lexer->nbStates);

    } else {
      /*
       * Create one slot in the <states> array
       */

      lexer->nbStates = 1;
      n = 0;
      lexer->states = (TcLex_State **)Tcl_Alloc(sizeof(TcLex_State *) * lexer->nbStates);
    }

init:
    /*
     * Initialize the state 
     */

    statePtr = lexer->states[n] = (TcLex_State *)Tcl_Alloc(sizeof(TcLex_State));

    statePtr->conditionsStack       = NULL;
    statePtr->conditionsStackLength = 0;
    statePtr->lastMatched           = -1;
    statePtr->bFailed               = Tcl_Alloc(lexer->nbRules);
    for (i=0; i<lexer->nbRules; i++)
      statePtr->bFailed[i] = 0;

    statePtr->inputBuffer.chars = NULL;
    StateSetString(lexer, n, string);
    
    statePtr->inputBuffer.index     = 0;
    statePtr->inputBuffer.bMatchedEmpty = 0;
    
    statePtr->currentBuffer         = &statePtr->inputBuffer;

    statePtr->bRejected             = 0;


    statePtr->startIndices = statePtr->endIndices = NULL;
    statePtr->pendingResult = NULL;

    return n;
}


/*
 * Tcl8.1 compatibily procs: Unicode object type.
 * This object uses a Unicode string in a Tcl_DString as their
 * internal representation
 */

#if (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 1)

Tcl_FreeInternalRepProc FreeUnicode;
Tcl_DupInternalRepProc DupUnicode;
Tcl_UpdateStringProc UpdateUnicode;
Tcl_SetFromAnyProc SetUnicodeFromAny;

Tcl_ObjType UnicodeObjType = {
    "unicode",

    FreeUnicode,  /* freeIntRepProc */
    DupUnicode,         /* dupIntRepProc */
    UpdateUnicode,      /* updateIntRepProc */
    SetUnicodeFromAny   /* setFromAnyProc */
};

void
FreeUnicode(objPtr)
    Tcl_Obj *objPtr;
{
    register Tcl_DString *string = (Tcl_DString *) objPtr->internalRep.otherValuePtr;

    /* Free the DString */
    Tcl_DStringFree(string);
    Tcl_Free((char *) string);
}

void
DupUnicode(srcPtr, dupPtr)
    Tcl_Obj *srcPtr;
    Tcl_Obj *dupPtr;
{
    register Tcl_DString *srcString = (Tcl_DString *) srcPtr->internalRep.otherValuePtr;
    register Tcl_DString *dupString;

    /* Duplicate the DString */
    dupString = (Tcl_DString *) Tcl_Alloc(sizeof(Tcl_DString));
    Tcl_DStringInit(dupString);
    Tcl_DStringAppend(dupString, Tcl_DStringValue(srcString),
      Tcl_DStringLength(srcString));

    dupPtr->internalRep.otherValuePtr = (char *) dupString;
    dupPtr->typePtr = &UnicodeObjType;
}

void
UpdateUnicode(objPtr)
    Tcl_Obj *objPtr;
{
    register Tcl_DString *string = (Tcl_DString *) objPtr->internalRep.otherValuePtr;
    Tcl_DString strUtf;

    /*
     * Set the UTF string from the internal Unicode DString
     */

    /* Generate an UTF representation in a DString */
    Tcl_DStringInit(&strUtf);
    Tcl_UniCharToUtfDString((Tcl_UniChar *) Tcl_DStringValue(string),
      Tcl_DStringLength(string)/sizeof(Tcl_UniChar), &strUtf);

    /* Allocate and fill the UTF string */
    objPtr->length = Tcl_DStringLength(&strUtf);
    objPtr->bytes = Tcl_Alloc((unsigned) objPtr->length + 1);
    strcpy(objPtr->bytes, Tcl_DStringValue(&strUtf));

    Tcl_DStringFree(&strUtf);
}

int
SetUnicodeFromAny(interp, objPtr)
    Tcl_Interp *interp;
    Tcl_Obj *objPtr;
{
    register Tcl_ObjType *oldTypePtr = objPtr->typePtr;
    register Tcl_DString *string;

    /*
     * Free the old internalRep before setting the new one.
     */

    if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
      oldTypePtr->freeIntRepProc(objPtr);
    }

    /* Set the internal Unicode string from the UTF string */
    string = (Tcl_DString *) Tcl_Alloc(sizeof(Tcl_DString));
    Tcl_DStringInit(string);
    Tcl_UtfToUniCharDString(objPtr->bytes, objPtr->length, string);

    objPtr->internalRep.otherValuePtr = (char *) string;
    objPtr->typePtr = &UnicodeObjType;
    return TCL_OK;
}

int
Tcl_GetCharLength(objPtr)
    Tcl_Obj *objPtr;
{
    register Tcl_DString *string;
    
    if (objPtr->typePtr != &UnicodeObjType) {
      SetUnicodeFromAny(NULL, objPtr);
    }

    string = (Tcl_DString *) objPtr->internalRep.otherValuePtr;
    return Tcl_DStringLength(string)/sizeof(Tcl_UniChar);
}

Tcl_UniChar *
Tcl_GetUnicode(objPtr)
    Tcl_Obj *objPtr;
{
    register Tcl_DString *string;
    
    if (objPtr->typePtr != &UnicodeObjType) {
      SetUnicodeFromAny(NULL, objPtr);
    }

    string = (Tcl_DString *) objPtr->internalRep.otherValuePtr;
    return (Tcl_UniChar *) Tcl_DStringValue(string);
}

Tcl_Obj *
Tcl_NewUnicodeObj(unicode, numChars)
    Tcl_UniChar *unicode;
    int numChars;
{
    register Tcl_Obj *objPtr;
    register Tcl_DString *string;

    objPtr = Tcl_NewObj();
    objPtr->bytes = NULL;
    
    string = (Tcl_DString *) Tcl_Alloc(sizeof(Tcl_DString));
    Tcl_DStringInit(string);
    Tcl_DStringAppend(string, (char *) unicode, numChars*sizeof(Tcl_UniChar));

    objPtr->internalRep.otherValuePtr = (char *) string;
    objPtr->typePtr = &UnicodeObjType;
    return objPtr;
}

#endif





/*
 *--------------------------------------------------------------
 *
 * StateSetString --
 *
 *    Given its index, modify a lexer state's string.
 *
 * Results:
 *    None
 *
 * Side effects:
 *    The state is modified.
 *
 *--------------------------------------------------------------
 */

static void
StateSetString(lexer, n, string)
    TcLex_Lexer   *lexer;
    int           n;          /* Index of the state */
    Tcl_Obj *string;    /* New string being lexed */
{
    TcLex_State   *statePtr = lexer->states[n];
    if (statePtr->inputBuffer.chars)
      Tcl_DecrRefCount(statePtr->inputBuffer.chars);
    statePtr->inputBuffer.chars = string;
    Tcl_IncrRefCount(statePtr->inputBuffer.chars);
}


/*
 *--------------------------------------------------------------
 *
 * StateGetString --
 *
 *    Given its index, modify a lexer state's string.
 *
 * Results:
 *    None
 *
 * Side effects:
 *    The state is modified.
 *
 *--------------------------------------------------------------
 */

static Char *
StateGetString(lexer, n, lengthPtr)
    TcLex_Lexer   *lexer;
    int           n;          /* Index of the state */
    int           *lengthPtr; /* Length of string */
{
    TcLex_State   *statePtr = lexer->states[n];

#if (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0)
    return Tcl_GetStringFromObj(statePtr->currentBuffer->chars, lengthPtr);
#else
    if (lengthPtr)
      *lengthPtr = Tcl_GetCharLength(statePtr->currentBuffer->chars);
    return Tcl_GetUnicode(statePtr->currentBuffer->chars);
#endif
}


/*
 *--------------------------------------------------------------
 *
 * StateDelete --
 *
 *    Delete a state given its index.
 *
 * Results:
 *    None
 *
 * Side effects:
 *    The lexer's <states> array is modified.
 *
 *--------------------------------------------------------------
 */

static void
StateDelete(lexer, n)
    TcLex_Lexer   *lexer;
    int           n;      /* Index of the state */
{
    TcLex_State   *statePtr = lexer->states[n];
    int           nb;

    /*
     * Free the state's structures
     */

    Tcl_Free((char*)statePtr->conditionsStack);
    Tcl_Free((char*)statePtr->bFailed);
    Tcl_DecrRefCount(statePtr->inputBuffer.chars);
    Tcl_Free((char*)statePtr->startIndices);
    Tcl_Free((char*)statePtr->endIndices);
    if (statePtr->pendingResult)
      Tcl_DecrRefCount(statePtr->pendingResult);

    lexer->states[n] = NULL;

    /*
     * Modify the states array: delete the upper empty elements
     */

    nb = lexer->nbStates;
    while (nb && !lexer->states[nb-1]) /* Search for nonempty elements */
      nb--;                            /* at the end of the array. */
    if (nb != lexer->nbStates) {       /* If any, shrink the array. */
      lexer->states = (TcLex_State **)Tcl_Realloc((char *)lexer->states, sizeof(TcLex_State *) * lexer->nbStates);
      lexer->nbStates = nb;
    }
}   



/*******************************************************
 *                                                     *
 *             Lexer management functions              *
 *                                                     *
 *******************************************************/


/*
 *--------------------------------------------------------------
 *
 * LexerDelete --
 *
 *    This procedure deletes a TcLex_Lexer structure.
 *
 * Results:
 *    None.
 *
 * Side effects:
 *    Tcl_Obj objects owned by the structure are freed.
 *
 *--------------------------------------------------------------
 */

void
LexerDelete(lexer)
    TcLex_Lexer   *lexer;
{
    int           i;
    
    /*
     * Free conditions
     */

    if (lexer->conditions) {
      for (i=0; i < lexer->nbInclusiveConditions+lexer->nbExclusiveConditions; i++) {
          Tcl_DecrRefCount(lexer->conditions[i]);
      }
      Tcl_Free((char *)lexer->conditions);
    }
    
    /*
     * Free active rules
     */

    for (i=0; i < lexer->nbInclusiveConditions+lexer->nbExclusiveConditions+1; i++) {
      Tcl_Free((char *)lexer->activeRules[i]);
    }
    Tcl_Free((char *)lexer->activeRules);

    /*
     * Free result variable
     */

    if (lexer->resultVariable)  Tcl_DecrRefCount(lexer->resultVariable);

    /*
     * Free args
     */

    if (lexer->args) Tcl_DecrRefCount(lexer->args);

    /*
     * Free scripts
     */

    if (lexer->preScript)  Tcl_DecrRefCount(lexer->preScript);
    if (lexer->midScript)  Tcl_DecrRefCount(lexer->midScript);
    if (lexer->postScript) Tcl_DecrRefCount(lexer->postScript);

    /*
     * Free rules
     */

    if (lexer->rules) {
      for (i=0; i < lexer->nbRules; i++) {
          RuleFree(lexer->rules+i);
      }
      Tcl_Free((char *)lexer->rules);
    }
    
    /*
     * Free states
     */

    if (lexer->states) {
      TcLex_State *statePtr;
      for (i=0; i < lexer->nbStates; i++) {
          if (statePtr = lexer->states[i]) {
            Tcl_Free((char*)statePtr->conditionsStack);
            Tcl_Free((char*)statePtr->bFailed);
            Tcl_DecrRefCount(statePtr->inputBuffer.chars);
            Tcl_Free((char*)statePtr->startIndices);
            Tcl_Free((char*)statePtr->endIndices);
            if (statePtr->pendingResult)
              Tcl_DecrRefCount(statePtr->pendingResult);
            
            Tcl_Free((char *)statePtr);
          }
      }
      Tcl_Free((char *)lexer->states);
    }
    
    /*
     * Free lexer
     */

    Tcl_Free((char *)lexer);

    return;
}


/*
 *--------------------------------------------------------------
 *
 * LexerNew --
 *
 *    This procedure creates a new TcLex_Lexer structure.
 *
 * Results:
 *    A pointer to the newly allocated TcLex_Lexer, or NULL
 *    if failed.
 *
 * Side effects:
 *    Some Tcl_Obj's are shared by the new structure.
 *
 *--------------------------------------------------------------
 */

TcLex_Lexer *
LexerNew(interp, inclusiveConditions, exclusiveConditions, resultVariable,
       preScript, midScript, postScript, args, flags, rulec, rulev)
    Tcl_Interp          *interp;
    Tcl_Obj       *inclusiveConditions;
    Tcl_Obj       *exclusiveConditions;
    Tcl_Obj       *resultVariable;
    Tcl_Obj       *preScript;
    Tcl_Obj       *midScript;
    Tcl_Obj       *postScript;
    Tcl_Obj       *args;
    int                 flags;
    int                 rulec;
    Tcl_Obj *CONST      *rulev;
{
    TcLex_Lexer         *lexer;
    int                 i, j, k, l;
    int                 nbRules;
    int                 nbConds;
    int                 firstScript;      /* Used to handle script    */
    Tcl_Obj       *firstConditions; /* and conditions shortcuts */
    int                 cc;               /* Used to get   */
    Tcl_Obj       **cv;             /* list elements */
    char          ruleNb[32];       /* Rule number reported when an 
                                 * error occurs */

    /*
     * Sanity check
     */
     
    /* Rule list must be a multiple of 4: <conditions> <regexp> <match vars> <script> */
    if (rulec % 4 != 0)
      /* Error */
      goto misformedRuleError;
    
    nbRules = rulec/4;

    /* Conditions and arguments must be valid lists */
    {
      Tcl_ObjType *listObjTypePtr = Tcl_GetObjType("list");

      if (   inclusiveConditions && Tcl_ConvertToType(interp, inclusiveConditions, listObjTypePtr) == TCL_ERROR
            || exclusiveConditions && Tcl_ConvertToType(interp, exclusiveConditions, listObjTypePtr) == TCL_ERROR
            || args                && Tcl_ConvertToType(interp, args,                listObjTypePtr) == TCL_ERROR)
       /* Error */
          goto listConvertError;
    }
    

    /*
     * Allocate lexer
     */

    lexer = (TcLex_Lexer *)Tcl_Alloc(sizeof(TcLex_Lexer));
    
    /*
     * Initialization
     */

    lexer->flags = flags;

    /*
     * Allocate conditions
     */

    lexer->conditions = NULL;

    /* Inclusive conditions */
    if (inclusiveConditions) {
      Tcl_ListObjGetElements(interp, inclusiveConditions, &cc, &cv);
      lexer->nbInclusiveConditions = cc;
      
      /* Allocate the conditions array... */
      lexer->conditions = (Tcl_Obj **)Tcl_Alloc(sizeof(Tcl_Obj *) * cc);
      
      /* ... then fill it */
      for (k=0; k < cc; k++) {
          lexer->conditions[k] = cv[k];
          Tcl_IncrRefCount(cv[k]);
      }
    } else {
      lexer->nbInclusiveConditions = 0;
    }

    /* Exclusive conditions */
    if (exclusiveConditions) {
      Tcl_ListObjGetElements(interp, exclusiveConditions, &cc, &cv);
      lexer->nbExclusiveConditions = cc;
      
      /* (Re)allocate the conditions array... */
      if (lexer->conditions)
          lexer->conditions = (Tcl_Obj **)Tcl_Realloc((char *)lexer->conditions, 
                                sizeof(Tcl_Obj *) * (lexer->nbInclusiveConditions+cc));
      else
          lexer->conditions = (Tcl_Obj **)Tcl_Alloc(sizeof(Tcl_Obj *) * cc);

      /* ... then fill it */
      for (k=0; k < cc; k++) {
          lexer->conditions[k+lexer->nbInclusiveConditions] = cv[k];
          Tcl_IncrRefCount(cv[k]);
      }
    } else {
      lexer->nbExclusiveConditions = 0;
    }

    /*
     * Initialize active conditions
     */

    nbConds = lexer->nbInclusiveConditions+lexer->nbExclusiveConditions+1;
    lexer->activeRules = (int **)Tcl_Alloc(sizeof(int *) * nbConds);
    for (i=0; i < nbConds; i++) {
      /* Pre-allocation, we'll shrink later */
      lexer->activeRules[i] = (int *)Tcl_Alloc(sizeof(int) * nbRules);
      for (j=0; j < nbRules; j++)
          lexer->activeRules[i][j] = -1;
    }

    /*
     * Initialize result variable
     */

    if (resultVariable) {
      lexer->resultVariable = resultVariable;
      Tcl_IncrRefCount(resultVariable);
    } else {
      lexer->resultVariable = NULL;
    }

    /*
     * Initialize args
     */

    if (args) {
      lexer->args = args;
      Tcl_IncrRefCount(args);
    } else {
      lexer->args = NULL;
    }
    
    /*
     * Initialize scripts
     */

    if (preScript) {
      lexer->preScript = preScript;
      Tcl_IncrRefCount(preScript);
    } else {
      lexer->preScript = NULL;
    }
    if (midScript) {
      lexer->midScript = midScript;
      Tcl_IncrRefCount(midScript);
    } else {
      lexer->midScript = NULL;
    }
    if (postScript) {
      lexer->postScript = postScript;
      Tcl_IncrRefCount(postScript);
    } else {
      lexer->postScript = NULL;
    }

    /*
     * Initialize states information
     */

    lexer->nbStates = 0;
    lexer->states   = NULL;
    lexer->curState = -1;

    /* 
     * Allocate and initalize rules
     */

    lexer->rules = (TcLex_Rule *)Tcl_Alloc(sizeof(TcLex_Rule) * nbRules);
    lexer->nbRules = nbRules;
    for (i=0; i < nbRules; i++) {
      lexer->rules[i].conditionsIndices       = (int *)NULL;
      lexer->rules[i].conditionsIndicesLength = 0;
      lexer->rules[i].re                      = (Tcl_RegExp)NULL;
      lexer->rules[i].reObj                   = (Tcl_Obj *)NULL;
      lexer->rules[i].matchVars               = (Tcl_Obj *)NULL;
      lexer->rules[i].script                  = (Tcl_Obj *)NULL;
    }

    firstScript     = -1;   /* Used for "-" script shortcut */
    firstConditions = NULL; /* Used for "-" conditions shortcut */
    for (i=0,j=0; i < rulec; i+=4, j++) {
      Tcl_Obj    *conditions; /* Conditions list */

      /* 
       * Store regexps
       */

      if (RuleCompileRegexp(interp, &lexer->rules[j], rulev[i+1], flags) == TCL_ERROR)
          goto regexpCompileError;

      /*
       * Handle "-" conditions shortcut
       */

      if (strcmp(Tcl_GetStringFromObj(rulev[i], NULL), "-") == 0) {
          if (firstConditions == NULL)
            /* Error */
            goto missingFirstConditionError;
          conditions = firstConditions;
      } else {
          firstConditions = conditions = rulev[i];
      }

      if (Tcl_ListObjGetElements(interp, conditions, &cc, &cv) == TCL_ERROR)
          /* Error */
          goto conditionsConvertError;
      
      /* Allocate the conditions array... */
      lexer->rules[j].conditionsIndicesLength = cc;
      lexer->rules[j].conditionsIndices = (int *)Tcl_Alloc(sizeof(int) * cc);
      
      /* ... then fill it (with conditions indices) */
      for (k=0; k < cc; k++) {
          int ci = ConditionIndex(lexer, Tcl_GetStringFromObj(cv[k], NULL));
          if (   ci == -1
            && strcmp(Tcl_GetStringFromObj(cv[k], NULL), "*") != 0)
             /* Error, the condition doesn't exist and is not a wildcard */
             goto unknownConditionError;
          lexer->rules[j].conditionsIndices[k] = ci;
      }

      /*
       * Match vars
       */

      lexer->rules[j].matchVars = rulev[i+2];
      Tcl_IncrRefCount(rulev[i+2]);

      /*
       * Handle "-" script shortcut
       */

      if (strcmp(Tcl_GetStringFromObj(rulev[i+3], NULL), "-") == 0) {
          if (firstScript == -1)
            firstScript = j;
      } else {
          for (k=(firstScript == -1 ? j : firstScript); k <= j; k++) {
            lexer->rules[k].script = rulev[i+3];
            Tcl_IncrRefCount(rulev[i+3]);
          }
          firstScript = -1;
      }
    }
    
    if (firstScript != -1)
      /* Error, we used script shortcuts till the end without a script */
      goto missingScriptError;
    
    /*
     * Fill the active rules array
     */

    /* Scan all the rules */
    for (i=0; i < nbRules; i++) {
      char bActive;
      int cond;

      bActive = 0;

      if (lexer->rules[i].conditionsIndicesLength == 0) {
          /* No conditions, only initial and inclusive conditions will be active */
          for (k=0; k < lexer->nbInclusiveConditions+1; k++) {
            for (l=0; ; l++) {
                if (lexer->activeRules[k][l] == -1) {
                  lexer->activeRules[k][l] = i;
                  break;
                }
            }
          }
          continue;
      }

      for (j=0; j < lexer->rules[i].conditionsIndicesLength; j++) {
          cond = lexer->rules[i].conditionsIndices[j];

          if (cond == -1) { /* Match all conditions */
            /* Add the rule to all conditions */
            for (k=0; k < nbConds; k++) {
                for (l=0; ; l++) {
                  if (   lexer->activeRules[k][l] == i     /* Maybe the rule is already there */
                      || lexer->activeRules[k][l] == -1) {
                      lexer->activeRules[k][l] = i;
                      break;
                  }
              }
            }
            break;
          }

          /* Add the rule to the condition <cond> */
          for (l=0; ; l++) {
            if (   lexer->activeRules[cond][l] == i     /* Maybe the rule is already there */
                || lexer->activeRules[cond][l] == -1) {
                lexer->activeRules[cond][l] = i;
                break;
            }
          }
      }
    }

    /*
     * Shrink the activeRules sub-arrays
     */

    for (i=0; i < nbConds; i++) {
      for (j=0; j < nbRules && lexer->activeRules[i][j] != -1; j++);
      if (j < nbRules-1)
          /* Shrink the array */
          lexer->activeRules[i] = (int *)Tcl_Realloc((char *)lexer->activeRules[i],
                                    sizeof(int) * (j+1));
    }

    return lexer;


    /*
     * Error handling
     */

    /* These errors occur at the beginning and need no cleanup */

listConvertError:
    /* Error string is already set by Tcl */
    return NULL;

misformedRuleError:
    Tcl_SetResult(interp, "misformed rule: should be \"conditions regexp matchvars script\"", TCL_STATIC);
    return NULL;


    /* These error need cleanup */

regexpCompileError:
    sprintf(ruleNb, "%d", j);
    Tcl_AddErrorInfo(interp, "\n    (rule ");
    Tcl_AddErrorInfo(interp, ruleNb);
    Tcl_AddErrorInfo(interp, ")");
    goto cleanup;

missingFirstConditionError:
    Tcl_SetResult(interp, "invalid condition \"-\"", TCL_STATIC);
    sprintf(ruleNb, "%d", j);
    Tcl_AddErrorInfo(interp, "\n    (rule ");
    Tcl_AddErrorInfo(interp, ruleNb);
    Tcl_AddErrorInfo(interp, ")");
    goto cleanup;

conditionsConvertError:
    /* Error string is already set by Tcl, just add error info */
    sprintf(ruleNb, "%d", j);
    Tcl_AddErrorInfo(interp, "\n    (rule ");
    Tcl_AddErrorInfo(interp, ruleNb);
    Tcl_AddErrorInfo(interp, ")");
    goto cleanup;

unknownConditionError:
    Tcl_AppendResult(interp, "unknown condition \"",
                       Tcl_GetStringFromObj(cv[k], NULL), "\"", (char *) NULL);
    sprintf(ruleNb, "%d", j);
    Tcl_AddErrorInfo(interp, "\n    (rule ");
    Tcl_AddErrorInfo(interp, ruleNb);
    Tcl_AddErrorInfo(interp, ")");
    goto cleanup;

missingScriptError:
    Tcl_SetResult(interp, "missing script for last rule", TCL_STATIC);
    goto cleanup;

cleanup:
    LexerDelete(lexer);
    return NULL;
}


/*
 *--------------------------------------------------------------
 *
 * LexerCmdDeleteProc --
 *
 *    This procedure is invoked to delete the Tcl commands
 *    created by "lexer".
 *
 * Results:
 *    A standard Tcl result.
 *
 * Side effects:
 *    The Tcl command and all its structures are freed.
 *
 *--------------------------------------------------------------
 */

void
LexerCmdDeleteProc(clientData)
    ClientData    clientData;
{
    TcLex_Lexer   *lexer = (TcLex_Lexer*)clientData;
    if (lexer->nbStates != 0) {
      /* Lexer is active */
      /* Nothing to do, all is handled by Tcl. Life is beautiful :-)) */
      return;
    }

    /*
     * Just delete the lexer structure
     */

    LexerDelete((TcLex_Lexer *)clientData);
}   


/*
 *--------------------------------------------------------------
 *
 * LexerCurrentObjCmd --
 *
 *    This procedure is invoked to process the "lexer current" 
 *    Tcl subcommand. See the user documentation for details on
 *    what it does.
 *
 * Results:
 *    A standard Tcl result.
 *
 * Side effects:
 *    None.
 *
 *--------------------------------------------------------------
 */

int
LexerCurrentObjCmd(clientData, interp, objc, objv)
    ClientData    clientData;
    Tcl_Interp    *interp;
    int           objc;
    Tcl_Obj *CONST objv[];
{
    TcLex_Lexer   *currentLexer;

    /*
     * Sanity check
     */

    if (objc != 2)
      goto numberArgsError;
    
    currentLexer = LexerGetCurrent(interp);
    if (currentLexer) {
      if (((Command*)currentLexer->command)->deleted)
          /* If command has been deleted, the token is meaningless. Return no result */
          Tcl_ResetResult(interp);
      else
          Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_GetCommandName(interp, currentLexer->command), -1));
      return TCL_OK;
    } else {
      Tcl_SetResult(interp, "no active lexer", TCL_STATIC);
      return TCL_ERROR;
    }

    
    /*
     * Error handling
     */

numberArgsError:
    Tcl_WrongNumArgs(interp, 2, objv, NULL);
    return TCL_ERROR;
}


/*
 *--------------------------------------------------------------
 *
 * LexerCreateObjCmd --
 *
 *    This procedure is invoked to process the "lexer create" 
 *    Tcl subcommand. See the user documentation for details on
 *    what it does.
 *
 * Results:
 *    A standard Tcl result.
 *
 * Side effects:
 *    Creates a new Tcl command in the current interpreter,
 *    replacing any existing one. Allocate related structures.
 *
 *--------------------------------------------------------------
 */

int
LexerCreateObjCmd(clientData, interp, objc, objv, start)
    ClientData    clientData;
    Tcl_Interp    *interp;
    int           objc;
    Tcl_Obj *CONST objv[];
    int           start;
{
    static char * options[] = {
      "-inclusiveconditions",       "-ic",
      "-exclusiveconditions",       "-ec",
      "-resultvariable",
      "-prescript",         "-midscript", "-postscript",
      "-args",        "-lines",           "-nocase",  "-longest", 
      "--",
      NULL
    };
    static enum {
      OPTION_INCLUSIVECONDITIONS,   OPTION_IC,
      OPTION_EXCLUSIVECONDITIONS,   OPTION_EC,
      OPTION_RESULTVARIABLE,
      OPTION_PRESCRIPT,   OPTION_MIDSCRIPT,     OPTION_POSTSCRIPT,
      OPTION_ARGS,          OPTION_LINES, OPTION_NOCASE,    OPTION_LONGEST,
      OPTION_END
    } optionIndex;
    int           i;
    char    *option;     /*                           */
    int           length;      /* Used for argument parsing */
    TcLex_Lexer   *lexer;
    Tcl_Obj *lexerName;
    char    *name;
    Tcl_Obj *inclusiveConditions = NULL,
            *exclusiveConditions = NULL;
    Tcl_Obj *resultVariable = NULL;
    Tcl_Obj *preScript  = NULL,
            *midScript  = NULL,
            *postScript = NULL,
            *args       = NULL;
    int           flags = 0;
    int           rulec;
    Tcl_Obj *CONST *rulev;
    

    /*
     * Sanity check
     */

    if (objc <= start+1)
      goto numberArgsError;


    /*
     * Initialization
     */
    
    lexerName = objv[start];
    name = Tcl_GetStringFromObj(lexerName, NULL);


    /*
     * Argument parsing
     */  

    i = start+1;

    for (;;) {
      if (i >= objc)
          goto numberArgsError;
      
      option = Tcl_GetStringFromObj(objv[i], &length);

      /* 
       * Check for end of switches
       */

      if (length < 2 || option[0] != '-' || option[1] == '-') {
          if (option[1] == '-')
            i++;
          break;
      }

      /*
       * Get the switch
       */

      if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", 0, &optionIndex) == TCL_ERROR)
          return TCL_ERROR;

      switch (optionIndex) {
          case OPTION_INCLUSIVECONDITIONS:
          case OPTION_IC:
            if (++i >= objc)
              goto optionValueMissingError;

            inclusiveConditions = objv[i++];
            Tcl_IncrRefCount(inclusiveConditions);
            break;

          case OPTION_EXCLUSIVECONDITIONS:
          case OPTION_EC:
            if (++i >= objc)
              goto optionValueMissingError;

            exclusiveConditions = objv[i++];
            Tcl_IncrRefCount(exclusiveConditions);
            break;

          case OPTION_RESULTVARIABLE:
            if (++i >= objc)
              goto optionValueMissingError;

            resultVariable = objv[i++];
            Tcl_IncrRefCount(resultVariable);
            break;

          case OPTION_PRESCRIPT:
            if (++i >= objc)
              goto optionValueMissingError;

            preScript = objv[i++];
            Tcl_IncrRefCount(preScript);
            break;

          case OPTION_MIDSCRIPT:
            if (++i >= objc)
              goto optionValueMissingError;

            midScript = objv[i++];
            Tcl_IncrRefCount(midScript);
            break;

          case OPTION_POSTSCRIPT:
            if (++i >= objc)
              goto optionValueMissingError;

            postScript = objv[i++];
            Tcl_IncrRefCount(postScript);
            break;

          case OPTION_ARGS:
            if (++i >= objc)
              goto optionValueMissingError;

            args = objv[i++];
            Tcl_IncrRefCount(args);
            break;

          case OPTION_LINES:
            flags |= LEXER_FLAG_LINES;
            i++;
            break;

          case OPTION_NOCASE:
            flags |= LEXER_FLAG_NOCASE;
            i++;
            break;

          case OPTION_LONGEST:
            flags |= LEXER_FLAG_LONGEST;
            i++;
            break;
      }
    }

    /*
     * There should be arguments remaining (rules)
     */

    if (i >= objc)
      goto numberArgsError;

    /*
     * We can have rules as a single list or as the remaining arguments
     */

    if (objc-i == 1) {
      /* Single list */
      if (Tcl_ListObjGetElements(interp, objv[i], &rulec, (Tcl_Obj ***)&rulev) == TCL_ERROR)
          goto rulesListConvertError;
    } else {
      rulec = objc-i;
      rulev = objv+i;
    }
    
    /*
     * Create the lexer
     */

    if ((lexer = LexerNew(interp, inclusiveConditions, exclusiveConditions,
                    resultVariable, preScript, midScript, postScript,
                    args, flags, 
                    rulec, rulev)) == (VOID *)NULL)
      return TCL_ERROR;
    
    /*
     * Create the lexer Tcl command
     */

    if (strncmp(name, "::", 2) != 0) { /* Lexer isn't created in the global namespace */
      lexerName = Tcl_NewStringObj(Tcl_GetCurrentNamespace(interp)->fullName, -1);
      Tcl_AppendStringsToObj(lexerName, "::", name, NULL);
      name = Tcl_GetStringFromObj(lexerName, NULL);
    }
    Tcl_IncrRefCount(lexerName);
    lexer->command = Tcl_CreateObjCommand(interp, name,
                  (Tcl_ObjCmdProc *)LexerObjCmd,
                  (ClientData)lexer,
                  (Tcl_CmdDeleteProc *)LexerCmdDeleteProc);
    Tcl_DecrRefCount(lexerName);

    Tcl_ResetResult(interp);

    return TCL_OK;


    /*
     * Error handling
     */

rulesListConvertError:
    /* Error string is already set by Tcl */
    return TCL_ERROR;

optionValueMissingError:
    Tcl_AppendResult(interp, "value for \"", option, "\" missing", NULL);
    return TCL_ERROR;

numberArgsError:
    Tcl_WrongNumArgs(interp, start, objv, "name ?switches? rule ... ?rule?");
    return TCL_ERROR;
}


/*
 *--------------------------------------------------------------
 *
 * LexerMainObjCmd --
 *
 *    This procedure is invoked to process the "lexer" Tcl
 *    command. See the user documentation for details on what
 *    it does.
 *
 * Results:
 *    A standard Tcl result.
 *
 * Side effects:
 *    Depends on subcommand.
 *
 *--------------------------------------------------------------
 */

int
LexerMainObjCmd(clientData, interp, objc, objv)
    ClientData     clientData;
    Tcl_Interp     *interp;
    int            objc;
    Tcl_Obj *CONST objv[];
{
    static char * options[] = {
      "create",   "current", 
      NULL
    };
    static enum {
      OPTION_CREATE,    OPTION_CURRENT
    } optionIndex;
    static Tcl_ObjCmdProc * commands[] = {
      (Tcl_ObjCmdProc *)NULL,
      (Tcl_ObjCmdProc *)LexerCurrentObjCmd
    };


    /*
     * Sanity check
     */

    if (objc < 2)
      goto numberArgsError;

     
    /*
     * Get the switch
     */

    if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, &optionIndex) == TCL_ERROR) {
      /*
       * For now, an unknown subcommand is interpreted as the name of a new lexer
       * to create. This is for compatibility issues, and is likely to change when
       * more subcommands will be added in a future major version.
       */
      Tcl_ResetResult(interp);
      return LexerCreateObjCmd(clientData, interp, objc, objv, 1);
    }


    if (optionIndex == OPTION_CREATE)
      return LexerCreateObjCmd(clientData, interp, objc, objv, 2);

    return (commands[optionIndex])(clientData, interp, objc, objv);


    /*
     * Error handling
     */

numberArgsError:
    Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
    return TCL_ERROR;
}




/*******************************************************
 *                                                     *
 *             Lexer evaluation functions              *
 *                                                     *
 *******************************************************/

/*
 *--------------------------------------------------------------
 *
 * RuleTry --
 *
 *    This procedure tests if the given rule match the string at
 *    the current index.
 *
 * Results:
 *    An integer code:
 *        LEXER_RULETRY_ERROR   : an error has occured
 *        LEXER_RULETRY_NOMATCH : the rule didn't match
 *        LEXER_RULETRY_MATCHED : the rule matched
 *        LEXER_RULETRY_OVERRUN : the rule didn't match but the
 *                          string was overrun
 *
 * Side effects:
 *    Modifies the state's matched indices.
 *
 *--------------------------------------------------------------
 */

#define LEXER_RULETRY_ERROR      -1
#define LEXER_RULETRY_NOMATCH     0
#define LEXER_RULETRY_MATCHED     1
#define LEXER_RULETRY_OVERRUN     2

int
RuleTry(interp, lexer, iRule, bCheckOverrun, pMinLength)
    Tcl_Interp    *interp;
    TcLex_Lexer   *lexer;
    int           iRule;         /* Index of the rule to try */
    int           bCheckOverrun; /* Whether to check for string overrun */
                         /* (eg. for incremental processing) */
    int           *pMinLength;   /* if -longest, minimum # chara to match */
{
    TcLex_State   *statePtr = lexer->states[lexer->curState];
    int           len;
    Char    *str = StateGetString(lexer, lexer->curState, &len);
    int           bol;
    TcLex_Rule  *rule = &lexer->rules[iRule];
    int           i, s, e;
    int           overrun;
    
    if (   (lexer->flags & LEXER_FLAG_LINES)
      && (str[statePtr->currentBuffer->index-1] == '\n'))
      bol = statePtr->currentBuffer->index;
    else
      bol = 0;

    switch (RuleExec(interp, lexer, rule,
            statePtr->currentBuffer->chars, statePtr->currentBuffer->index, bol,
            &overrun)) {
      case -1:
          return LEXER_RULETRY_ERROR;

      case 0:
          if (bCheckOverrun && overrun)
            return LEXER_RULETRY_OVERRUN;
          return LEXER_RULETRY_NOMATCH;
    }

    if (bCheckOverrun && overrun)
      return LEXER_RULETRY_OVERRUN;
    
    /*
     * Get info about the matched string
     */

    RuleGetRange(interp, lexer, rule, statePtr->currentBuffer->chars, statePtr->currentBuffer->index, 0, &s, &e);
    if (   (lexer->flags & LEXER_FLAG_LONGEST)
      && (e-s+1 <= *pMinLength))
      /* We want a longer match */
      return LEXER_RULETRY_NOMATCH;

    if (e < s) { /* Empty string matched */
      if (   iRule == statePtr->lastMatched
          || statePtr->currentBuffer->bMatchedEmpty)
          /* The previous rule can't match an empty string again.
           * Also we can't match two consecutive empty strings
           * else we'll run into an infinite loop */
          return LEXER_RULETRY_NOMATCH;

      statePtr->currentBuffer->bMatchedEmpty = 1;
    } else {
      statePtr->currentBuffer->bMatchedEmpty = 0;
    }
    *pMinLength = e-s+1;

    /*
     * Get matched string and substrings' indices
     */

    statePtr->nbRanges     = lexer->rules[iRule].nbRanges;
    statePtr->startIndices = (int *)Tcl_Realloc((char *)statePtr->startIndices, statePtr->nbRanges * sizeof(int));
    statePtr->endIndices   = (int *)Tcl_Realloc((char *)statePtr->endIndices, statePtr->nbRanges * sizeof(int));

    for (i=0; i < statePtr->nbRanges; i++) {
      RuleGetRange(interp, lexer, rule, statePtr->currentBuffer->chars, statePtr->currentBuffer->index, i, &statePtr->startIndices[i], &statePtr->endIndices[i]);
    }

    statePtr->currentBuffer->nextIndex = statePtr->endIndices[0]+1;

    /* Store the rule's index */
    statePtr->lastMatched = iRule;

    return LEXER_RULETRY_MATCHED;
}


/*
 *--------------------------------------------------------------
 *
 * RuleEvalDefault --
 *
 *    This procedure evaluates the default rule.
 *
 * Results:
 *    None.
 *
 * Side effects:
 *    Consumes one char from the lexed string.
 *
 *--------------------------------------------------------------
 */

void
RuleEvalDefault(interp, lexer)
    Tcl_Interp    *interp;
    TcLex_Lexer   *lexer;
{
    TcLex_State   *statePtr = lexer->states[lexer->curState];

    /*
     * Consume one char
     */

    statePtr->currentBuffer->bMatchedEmpty = 0; /* Non-empty match */

    statePtr->currentBuffer->nextIndex = statePtr->currentBuffer->index+1;

    statePtr->nbRanges     = 1;
    statePtr->startIndices = (int *)Tcl_Realloc((char*)statePtr->startIndices, statePtr->nbRanges * sizeof(int));
    statePtr->endIndices   = (int *)Tcl_Realloc((char*)statePtr->endIndices, statePtr->nbRanges * sizeof(int));

    statePtr->startIndices[0] = statePtr->currentBuffer->index;
    statePtr->endIndices[0]   = statePtr->currentBuffer->nextIndex-1;

    /* Store -1 as the rule's index */
    statePtr->lastMatched = -1;
}


/*
 *--------------------------------------------------------------
 *
 * LexerMatchVars --
 *
 *    This procedure is used to set a series of variables to
 *    the matched subranges values.
 *
 * Results:
 *    A standard Tcl result.
 *
 * Side effects:
 *    The specified variables get modified.
 *
 *--------------------------------------------------------------
 */

int
LexerMatchVars(interp, lexer, bIndices, matchc, matchv)
    Tcl_Interp    *interp;
    TcLex_Lexer   *lexer;
    int           bIndices;
    int           matchc;
    Tcl_Obj *CONST matchv[];
{
    TcLex_State   *statePtr = lexer->states[lexer->curState];
    int           i, result;
    Char    *str;

    if (!bIndices) {
#if (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0)
      str = Tcl_GetStringFromObj(statePtr->currentBuffer->chars, NULL)+statePtr->startIndices[0];
#else
      str = Tcl_GetUnicode(statePtr->currentBuffer->chars)+statePtr->startIndices[0];
#endif
    }

    /* 
     * Set every matchvar to its value
     */

    result = TCL_OK;
    for (i=0; i < matchc; i++) {
      Tcl_Obj *val;
      if (bIndices) {
          /* We want indices */
          Tcl_Obj *res[2];
          if (i < statePtr->nbRanges) {
            res[0] = Tcl_NewIntObj(statePtr->startIndices[i]);
            res[1] = Tcl_NewIntObj(statePtr->endIndices[i]);
          } else {
            res[0] = Tcl_NewIntObj(-1);
            res[1] = Tcl_NewIntObj(-1);
          }
          val = Tcl_NewListObj(2, res);
      } else {        
          /* We want strings */
          if (i >= statePtr->nbRanges || statePtr->startIndices[i] < 0) {
            /* Substring not matched, return empty string */
            val = Tcl_NewObj();
          } else {
            Char *s = str+statePtr->startIndices[i]-statePtr->startIndices[0];
            Char *e = str+statePtr->endIndices[i]-statePtr->startIndices[0]+1;
#if (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0)
            val = Tcl_NewStringObj(s, e-s);
#else
            val = Tcl_NewUnicodeObj(s, e-s);
#endif
          }
      }
      if (Tcl_ObjSetVar2(interp, matchv[i], NULL, val, TCL_PARSE_PART1 | TCL_LEAVE_ERR_MSG) == NULL) {
          return TCL_ERROR;
      }
    }

    return result;
}

/*
 *--------------------------------------------------------------
 *
 * LexerEval --
 *
 *    This procedure is used to eval the lexer with a given
 *    string. It can be used on a whole or partial string,
 *    depending on the "op" argument.
 *
 * Results:
 *    A standard Tcl result.
 *
 * Side effects:
 *    See the user documentation.
 *
 *--------------------------------------------------------------
 */

int
BufferNotStarving(buffer)
    TcLex_Buffer *buffer;
{
    int length;

#if (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0)
    Tcl_GetStringFromObj(buffer->chars, &length);
#else
    length = Tcl_GetCharLength(buffer->chars);
#endif
    return (buffer->index <= length);
}

int
BufferAtEnd(buffer)
    TcLex_Buffer *buffer;
{
    int length;

#if (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0)
    Tcl_GetStringFromObj(buffer->chars, &length);
#else
    length = Tcl_GetCharLength(buffer->chars);
#endif
    return (buffer->index >= length);
}

int
LexerEval(interp, lexer, bCheckOverrun)
    Tcl_Interp    *interp;
    TcLex_Lexer   *lexer;
    int           bCheckOverrun; /* Whether to check for string overrun */
                                    /* (for incremental processing) */
{
    TcLex_State   *statePtr = lexer->states[lexer->curState];
    int           result;
    int           nbRules = lexer->nbRules;
    int           i;
    int           iRule, iRule2;
    char    ruleNb[32];    /* Rule number reported when an error occurs */
    int           matchc;        /* Match vars */
    Tcl_Obj **matchv;      /*            */
    int           cond;          /* Current condition index */
    int           minLength;     /* Minimum string length to match */
    int           matchedRule;

    /*
     * Initialization
     */

    result = TCL_OK; /* Variable holding the result */

    /*
     * Get info about the conditions
     */

    if (statePtr->conditionsStackLength == 0) { /* initial state */
      cond = 0;
    } else {
      cond = statePtr->conditionsStack[statePtr->conditionsStackLength-1];
    }


    /*
     * Main loop
     */

    while (BufferNotStarving(statePtr->currentBuffer)) {
      minLength = -1;
      matchedRule = -1;

      /*
       * Look for the first matching rule
       */

      for (iRule2 = 0; iRule2 < nbRules; iRule2++) {
          int matchRes;

          /*
           * Compute the real rule number
           */

          iRule = lexer->activeRules[cond][iRule2];
          if (iRule == -1) /* No more active rules */
            break;
          
          /*
           * If the rule is known to fail (eg. if it has been rejected
           * or already tested), then continue
           */

          if (statePtr->bFailed[iRule])
            continue;

          /*
           * Try to match the string
           */

          matchRes = RuleTry(interp, lexer, iRule, bCheckOverrun, &minLength);

          if (matchRes == LEXER_RULETRY_ERROR) {
            /* Error, stop there */
            result = TCL_ERROR;
            goto cleanup;
          }
          
          if (matchRes == LEXER_RULETRY_NOMATCH) { /* No match */
            /* Rule failed, continue */
            statePtr->bFailed[iRule] = 1;
            continue;
          }

          if (matchRes == LEXER_RULETRY_OVERRUN) { /* String overrun */
            /* Just return without consuming chars */
            result = TCL_OK;
            goto cleanup;
          }

          matchedRule = iRule;
          if (!(lexer->flags & LEXER_FLAG_LONGEST))
            /* If we don't want the longest match, we take
               the first: just stop there. */
            break;
      }

      if (matchedRule == -1) { /* No rule matched */
          /* We reached the end of the buffer */
          if (BufferAtEnd(statePtr->currentBuffer)) {
            result = TCL_OK;
            goto cleanup;
          }

          /* Default rule */
          statePtr->bRejected = 0;
          RuleEvalDefault(interp, lexer);

      } else {
          /*
           * Set matchvars
           */

          Tcl_ListObjGetElements(NULL, lexer->rules[matchedRule].matchVars, &matchc, &matchv);
          if (LexerMatchVars(interp, lexer, 0, matchc, matchv) == TCL_ERROR) {
            result = TCL_ERROR;
            goto cleanup;
          }

          /*
           * Eval the rule's script
           */

          statePtr->bRejected = 0;
          switch (Tcl_EvalObj(interp, lexer->rules[matchedRule].script)) {
            case TCL_ERROR:
              goto scriptEvalError;

            case TCL_RETURN:
              result = TCL_RETURN;
              goto cleanup;
          }

          /*
           * Conditions may have changed, update info
           */

          if (statePtr->conditionsStackLength == 0) { /* initial state */
            cond = 0;
          } else {
            cond = statePtr->conditionsStack[statePtr->conditionsStackLength-1];
          }

          /* We reached the end of the buffer */
          if (BufferAtEnd(statePtr->currentBuffer)) {
            result = TCL_OK;
            goto cleanup;
          }

      }

      if (statePtr->bRejected) { /* If the rule has been rejected */
          statePtr->bFailed[matchedRule] = 1;
          statePtr->currentBuffer->nextIndex = statePtr->currentBuffer->index;
      } else {
          /* Clear the rule failure indicators */
          for (i=0; i<nbRules; i++) statePtr->bFailed[i] = 0;

          /* Consume the matched string */
          statePtr->currentBuffer->index = statePtr->currentBuffer->nextIndex;
      }
    }

    goto cleanup;


    /*
     * Error handling
     */

scriptEvalError:
    /* Error string is already set by Tcl, just add error info */
    sprintf(ruleNb, "%d", iRule);
    Tcl_AddErrorInfo(interp, "\n    (rule ");
    Tcl_AddErrorInfo(interp, ruleNb);
    Tcl_AddErrorInfo(interp, ")");
    result = TCL_ERROR;


cleanup:
    return result;
}

/*
 *--------------------------------------------------------------
 *
 * LexerEvalObjCmd --
 *
 *    This procedure is invoked to process the "eval", "start",
 *    "continue" and "finish" subcommands for lexers. See the
 *    user documentation for details on what it does.
 *
 * Results:
 *    A standard Tcl result.
 *
 * Side effects:
 *    See the user documentation.
 *
 *--------------------------------------------------------------
 */

int LexerEvalObjCmd(interp, lexer, objc, objv, op)
    Tcl_Interp    *interp;
    TcLex_Lexer   *lexer;
    int           objc;
    Tcl_Obj *CONST objv[];
    int           op;
{
    TcLex_Lexer   *oldLexer;
    int           result;
    int           oldState;
    int           curState;
    CallFrame     cf;       /* Used to open a */
    Proc    proc;     /* new call frame */
    Tcl_CmdInfo   cmdInfo;  /* Used to get current namespace */
    Tcl_Obj *command, *token, *string;
    int           argc = 0;
    Tcl_Obj *CONST *argv = NULL;


    /*
     * Sanity check
     */

    switch (op) {
      case LEXER_EVAL:
          if (objc < 3)
            goto numberArgsErrorEval;
          token  = NULL;
          string = objv[2];
          argc = objc-3;
          break;

      case LEXER_START:
          if (objc < 4)
            goto numberArgsErrorStart;
          token  = objv[2];
          string = objv[3];
          argc = objc-4;
          break;

      case LEXER_CONTINUE:
          if (objc != 4)
            goto numberArgsErrorContinue;
          token  = objv[2];
          string = objv[3];
          break;

      case LEXER_FINISH:
          if (objc != 4)
            goto numberArgsErrorFinish;
          token  = objv[2];
          string = objv[3];
          break;
    }
    command = objv[0];

    switch (op) {
      case LEXER_CONTINUE:
      case LEXER_FINISH:
          if (   Tcl_GetIntFromObj(NULL, token, &curState) == TCL_ERROR
            || curState >= lexer->nbStates
            || lexer->states[curState] == NULL)
            /* The token (ie state number) is invalid */
            goto badTokenError;

          /*
           * If there is a pending result, return now
           */

          if (lexer->states[curState]->pendingResult) {
            Tcl_SetObjResult(interp, lexer->states[curState]->pendingResult);
            return TCL_OK;
          }
    }

    /*
     * Set the current lexer to this one.
     */

    oldLexer = LexerGetCurrent(interp);
    LexerSetCurrent(interp, lexer);

    /*
     * Open a new call frame
     */

    Tcl_GetCommandInfo(interp, Tcl_GetStringFromObj(command, NULL), &cmdInfo);
    if (Tcl_PushCallFrame(interp, (Tcl_CallFrame *)&cf, cmdInfo.namespacePtr, 1) == TCL_ERROR)
      return TCL_ERROR;

    proc.numCompiledLocals = 0;
    proc.firstLocalPtr = 0;
    proc.lastLocalPtr = 0;
    cf.procPtr = &proc;
    cf.objc = objc;
    cf.objv = objv;


    /*
     * Save the old state number
     */

    oldState = lexer->curState;

    /*
     * Initialize the state 
     */

    switch (op) {
      case LEXER_EVAL:
      case LEXER_START:
          lexer->curState = curState = StateNew(lexer, string);
          break;

      case LEXER_CONTINUE:
      case LEXER_FINISH:
          lexer->curState = curState;
          StateSetString(lexer, curState, string); /* Update the string */

          /*
           * Restore old local variables
           */

          cf.varTablePtr = lexer->states[curState]->varTablePtr;
    }


    /*
     * Initialize arguments
     */

    if (   lexer->args
          && (op == LEXER_EVAL || op == LEXER_START)) {
      int i, ac;
      Tcl_Obj **av;

      argv = objv+objc-argc;

      Tcl_ListObjGetElements(interp, lexer->args, &ac, &av);
      if (argc > ac) {
          Tcl_AppendResult(interp, "called lexer \"", Tcl_GetStringFromObj(command, NULL),
                  "\" with too many arguments", NULL);
          result = TCL_ERROR;
          goto cleanup;
      }

      for (i=0; i<ac; i++) {
          int c;
          Tcl_Obj **v;

          Tcl_ListObjGetElements(interp, av[i], &c, &v);
          if (i < argc) { /* Value is specified */
            Tcl_ObjSetVar2(interp, v[0], NULL, argv[i], 0);
          } else {
            if (c <= 1) { /* No default value */
              Tcl_AppendResult(interp, "no value given for parameter\"", Tcl_GetStringFromObj(v[0], NULL),
                  "\" to \"", Tcl_GetStringFromObj(command, NULL), "\"", NULL);
              result = TCL_ERROR;
              goto cleanup;
            }
            Tcl_ObjSetVar2(interp, v[0], NULL, v[1], 0);
          }
      }
    } else {
      if (argc != 0) {
          Tcl_WrongNumArgs(interp, 2, objv, "string");
          result = TCL_ERROR;
          goto cleanup;
      }
    }


    /*
     * Pre-script
     */

    if ((op == LEXER_EVAL || op == LEXER_START) && lexer->preScript) 
    switch (Tcl_EvalObj(interp, lexer->preScript)) {
      case TCL_ERROR:
          result = TCL_ERROR;
          goto cleanup;

      case TCL_RETURN:
          result = TCL_OK;

          if (op == LEXER_START || op == LEXER_CONTINUE) {
            /*
             * Save pending result, we will return it with a "finish" command
             */

            lexer->states[curState]->pendingResult = Tcl_GetObjResult(interp);
            Tcl_IncrRefCount(lexer->states[curState]->pendingResult);
          }
          goto cleanup;

      default:
          result = TCL_OK;
    }

    /*
     * Eval the lexer
     */

    result = LexerEval(interp, lexer, (op == LEXER_START || op == LEXER_CONTINUE));

    switch (result) {
      case TCL_ERROR:
          result = TCL_ERROR;
          goto cleanup;

      case TCL_RETURN:
          result = TCL_OK;

          if (op == LEXER_START || op == LEXER_CONTINUE) {
            /*
             * Save pending result, we will return it with a "finish" command
             */

            lexer->states[curState]->pendingResult = Tcl_GetObjResult(interp);
            Tcl_IncrRefCount(lexer->states[curState]->pendingResult);
          }
          goto cleanup;

      default:
          result = TCL_OK;
    }

    /*
     * Mid-script
     */

    if ((op == LEXER_START || op == LEXER_CONTINUE) && lexer->midScript) 
    switch (Tcl_EvalObj(interp, lexer->midScript)) {
      case TCL_ERROR:
          result = TCL_ERROR;
          goto cleanup;

      case TCL_RETURN:
          result = TCL_OK;
          goto cleanup;

      default:
          result = TCL_OK;
    }

    /*
     * Post-script
     */

    if ((op == LEXER_EVAL || op == LEXER_FINISH) && lexer->postScript) 
    switch (Tcl_EvalObj(interp, lexer->postScript)) {
      case TCL_ERROR:
          result = TCL_ERROR;
          goto cleanup;

      case TCL_RETURN:
          result = TCL_OK;
          goto cleanup;

      default:
          result = TCL_OK;
    }

    /*
     * If no result, we use the "-resultvariable" variable content as the result
     */

    if (lexer->resultVariable) {
      Tcl_Obj *res;
      
      if ((res = Tcl_ObjGetVar2(interp, lexer->resultVariable, NULL, TCL_PARSE_PART1 | TCL_LEAVE_ERR_MSG)) == NULL) {
          result = TCL_ERROR;
          goto cleanup;
      }
      Tcl_SetObjResult(interp, res);
    }

cleanup:

    /*
     * Restore the old state and delete current
     */

    lexer->curState = oldState;


    switch (op) {
      case LEXER_EVAL:
      case LEXER_FINISH:
          /*
           * Delete current state
           */

          StateDelete(lexer, curState);
          break;

      case LEXER_START:
      case LEXER_CONTINUE:
          if (result == TCL_ERROR) {
            /* An error interrupts the processing */
            StateDelete(lexer, curState);
            break;
          }

          /*
           * Save local variables for continuation
           */

          if (result == TCL_OK) {
            lexer->states[curState]->varTablePtr = cf.varTablePtr;
            cf.varTablePtr = NULL;
          }
    }

    /*
     * Close the call frame
     */

    Tcl_PopCallFrame(interp);

    /*
     * Restore the old current lexer.
     */

    LexerSetCurrent(interp, oldLexer);

    switch (op) {
      case LEXER_START:
          /*
           * Set the token variable to the state index for continuation
           */

          if (result == TCL_OK) {
            Tcl_Obj *res = Tcl_GetObjResult(interp); /* Save the current result */
            Tcl_IncrRefCount(res);

            /* This sets an error message in the result */
            if (Tcl_ObjSetVar2(interp, token, NULL, Tcl_NewIntObj(curState),
                  TCL_PARSE_PART1 | TCL_LEAVE_ERR_MSG) == NULL) {
                result = TCL_ERROR;
            } else {
                /* Restore the old result */
                Tcl_SetObjResult(interp, res);
                Tcl_DecrRefCount(res);
            }
          }
    }

    return result;


    /*
     * Error handling
     */

numberArgsErrorEval:
    Tcl_WrongNumArgs(interp, 2, objv, "string");
    return TCL_ERROR;

numberArgsErrorStart:
    Tcl_WrongNumArgs(interp, 2, objv, "tokenname string");
    return TCL_ERROR;

numberArgsErrorContinue:
numberArgsErrorFinish:
    Tcl_WrongNumArgs(interp, 2, objv, "token string");
    return TCL_ERROR;

badTokenError:
    Tcl_AppendResult(interp, "bad token: \"", Tcl_GetStringFromObj(token, NULL), "\"", NULL);
    return TCL_ERROR;
}


/*******************************************************
 *                                                     *
 *             Lexer state info functions              *
 *                                                     *
 *******************************************************/

/*
 *--------------------------------------------------------------
 *
 * LexerBeginObjCmd --
 *
 *    Push a condition on the current state's condition stack.
 *
 * Results:
 *    A standard Tcl result.
 *
 * Side effects:
 *    The conditions stack of the current state is modified.
 *
 *--------------------------------------------------------------
 */

int
LexerBeginObjCmd(clientData, interp, objc, objv)
    ClientData    clientData;
    Tcl_Interp    *interp;
    int           objc;
    Tcl_Obj *CONST objv[];
{
    TcLex_Lexer   *lexer    = (TcLex_Lexer *)clientData;
    TcLex_State   *statePtr = lexer->states[lexer->curState];
    int           ci; /* Index of the condition */

    /* 
     * Sanity check
     */

    if (objc != 3) {
      Tcl_WrongNumArgs(interp, 2, objv, "condition");
      return TCL_ERROR;
    }
    
    if ((ci = ConditionIndex(lexer, Tcl_GetStringFromObj(objv[2], NULL))) < 0)
      /* Error */
      goto unknownConditionError;

    /*
     * Add the new condition to the stack: allocate or grow the array
     */

    if (ci == 0) {
      /* 
       * Initial condition
       * Empty the whole conditions stack, that way "<lexer> begin initial"
       * will reset the lexer to the original condition state.
       */
      statePtr->conditionsStackLength = 0;
      Tcl_Free((char *) statePtr->conditionsStack);
      statePtr->conditionsStack = NULL;
      return TCL_OK;
    }

    statePtr->conditionsStackLength++;

    if (statePtr->conditionsStack)
      statePtr->conditionsStack
          = (int *)Tcl_Realloc((char *)statePtr->conditionsStack,
                               sizeof(int) * statePtr->conditionsStackLength);
    else
      statePtr->conditionsStack
          = (int *)Tcl_Alloc(sizeof(int) * statePtr->conditionsStackLength);
    
    statePtr->conditionsStack[statePtr->conditionsStackLength-1] = ci;

    return TCL_OK;


    /*
     * Error handling
     */

unknownConditionError:
    Tcl_AppendResult(interp, "unknown condition: \"", Tcl_GetStringFromObj(objv[2], NULL), "\"", (char *) NULL);
    return TCL_ERROR;
}


/*
 *--------------------------------------------------------------
 *
 * LexerEndObjCmd --
 *
 *    Pop a condition from the current state's condition stack.
 *
 * Results:
 *    A standard Tcl result.
 *
 * Side effects:
 *    The conditions stack of the current state is modified.
 *
 *--------------------------------------------------------------
 */

int
LexerEndObjCmd(clientData, interp, objc, objv)
    ClientData    clientData;
    Tcl_Interp    *interp;
    int           objc;
    Tcl_Obj *CONST objv[];
{
    TcLex_Lexer   *lexer    = (TcLex_Lexer *)clientData;
    TcLex_State   *statePtr = lexer->states[lexer->curState];

    /* 
     * Sanity check
     */

    if (objc != 2) {
      Tcl_WrongNumArgs(interp, 2, objv, NULL);
      return TCL_ERROR;
    }
    
    if (statePtr->conditionsStackLength == 0)
      /* Error */
      goto emptyConditionsStackError;

    /*
     * Delete the last condition from the stack
     *
     * We don'really need to realloc conditionsStack, since it is realloc'd 
     * with ConditionBegin and is freed when the lexer ends. So we just
     * decrement conditionsStackLength.
     */

    statePtr->conditionsStackLength--;
    
    return TCL_OK;


    /*
     * Error handling
     */

emptyConditionsStackError:
    Tcl_SetResult(interp, "empty conditions stack", TCL_STATIC);
    return TCL_ERROR;
}


/*
 *--------------------------------------------------------------
 *
 * ConditionsObjCmd --
 *
 *    This procedure is invoked to process the "conditions"
 *    subcommand for lexers. See the user documentation for
 *    details on what it does.
 *
 * Results:
 *    A standard Tcl result.
 *
 * Side effects:
 *    None.
 *
 *--------------------------------------------------------------
 */

int
LexerConditionsObjCmd(clientData, interp, objc, objv)
    ClientData    clientData;
    Tcl_Interp    *interp;
    int           objc;
    Tcl_Obj *CONST objv[];
{
    TcLex_Lexer   *lexer    = (TcLex_Lexer *)clientData;
    TcLex_State   *statePtr = lexer->states[lexer->curState];
    static char   *options[] = {
      "-current",
      NULL};
    static enum {
      OPTION_CURRENT
    } optionIndex;

    if (objc == 2) {
      /*
       * No subcommands, we return the current conditions stack
       */

      int     i;
      Tcl_Obj *cond = Tcl_NewObj(); /* List returned */

      /* Build the list */
      for (i=0; i < statePtr->conditionsStackLength; i++) {
          Tcl_ListObjAppendElement(interp, cond,
                                   ConditionFromIndex(lexer, statePtr->conditionsStack[i]));
      }

      Tcl_SetObjResult(interp, cond);
      return TCL_OK;
    }

    /*
     * Switch to distinct subfunctions depending on the option
     */

    if (Tcl_GetIndexFromObj(interp, objv[2], options, "option", 0, &optionIndex) == TCL_ERROR)
      return TCL_ERROR;

    switch (optionIndex) {
      case OPTION_CURRENT:
          if (objc != 3) {
            Tcl_WrongNumArgs(interp, 3, objv, NULL);
            return TCL_ERROR;
          }
          return ConditionCurrent(interp, lexer);
    }
} 


/*
 *--------------------------------------------------------------
 *
 * LexerRejectObjCmd --
 *
 *    This procedure is invoked to process the "reject" subcommand
 *    for lexers. See the user documentation for details on what
 *    it does.
 *
 * Results:
 *    A standard Tcl result.
 *
 * Side effects:
 *    See the user documentation.
 *
 *--------------------------------------------------------------
 */

int
LexerRejectObjCmd(clientData, interp, objc, objv)
    ClientData    clientData;
    Tcl_Interp    *interp;
    int           objc;
    Tcl_Obj *CONST objv[];
{
    TcLex_Lexer   *lexer    = (TcLex_Lexer *)clientData;
    TcLex_State   *statePtr = lexer->states[lexer->curState];
    
    /*
     * Sanity check
     */

    if (objc != 2)
      goto numberArgsError;

    /* Set the reject state tot true */
    statePtr->bRejected = 1;

    return TCL_OK;

    
    /*
     * Error handling
     */

numberArgsError:
    Tcl_WrongNumArgs(interp, 2, objv, "");
    return TCL_ERROR;
}


/*
 *--------------------------------------------------------------
 *
 * LexerIndexObjCmd --
 *
 *    This procedure is invoked to process the "index" subcommand
 *    for lexers. See the user documentation for details on what
 *    it does.
 *
 * Results:
 *    A standard Tcl result.
 *
 * Side effects:
 *    None.
 *
 *--------------------------------------------------------------
 */

int
LexerIndexObjCmd(clientData, interp, objc, objv)
    ClientData    clientData;
    Tcl_Interp    *interp;
    int           objc;
    Tcl_Obj *CONST objv[];
{
    TcLex_Lexer   *lexer    = (TcLex_Lexer *)clientData;
    TcLex_State   *statePtr = lexer->states[lexer->curState];
    
    /*
     * Sanity check
     */
    if (objc != 2)
      goto numberArgsError;

    /* Return the current index */
    Tcl_SetObjResult(interp, Tcl_NewIntObj(statePtr->currentBuffer->index));
    return TCL_OK;


    /*
     * Error handling
     */
numberArgsError:
    Tcl_WrongNumArgs(interp, 2, objv, "");
    return TCL_ERROR;
}


/*
 *--------------------------------------------------------------
 *
 * LexerInputObjCmd --
 *
 *    This procedure is invoked to process the "input" subcommand
 *    for lexers. See the user documentation for details on what
 *    it does.
 *
 * Results:
 *    A standard Tcl result.
 *
 * Side effects:
 *    See the user documentation.
 *
 *--------------------------------------------------------------
 */

int
LexerInputObjCmd(clientData, interp, objc, objv)
    ClientData    clientData;
    Tcl_Interp    *interp;
    int           objc;
    Tcl_Obj *CONST objv[];
{
    TcLex_Lexer   *lexer    = (TcLex_Lexer *)clientData;
    TcLex_State   *statePtr = lexer->states[lexer->curState];
    int           strLen;
    Char    *str = StateGetString(lexer, lexer->curState, &strLen);
    int           nbChars = 1;
    int           oldIndex;
    Tcl_Obj *val;
    
    /*
     * Sanity check
     */
    if (objc > 3)
      goto numberArgsError;

    if (objc == 3) {
      if (Tcl_GetIntFromObj(interp, objv[2], &nbChars) == TCL_ERROR)
          return TCL_ERROR;
    }
    if (nbChars < 0)
      nbChars = 0;


    /* Consume and return the next nbChars characters */
    oldIndex = statePtr->currentBuffer->nextIndex;
    statePtr->currentBuffer->nextIndex += nbChars;

    /* TODO: handle overrun. Seems very difficult */
    if (statePtr->currentBuffer->nextIndex > strLen) {
      statePtr->currentBuffer->nextIndex = strLen-1;
    }

#if (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0)
    val = Tcl_NewStringObj(str+oldIndex, statePtr->currentBuffer->nextIndex-oldIndex);
#else
    val = Tcl_NewUnicodeObj(str+oldIndex, statePtr->currentBuffer->nextIndex-oldIndex);
#endif

    Tcl_SetObjResult(interp, val);
    return TCL_OK;


    /*
     * Error handling
     */

numberArgsError:
    Tcl_WrongNumArgs(interp, 2, objv, "?nbChars?");
    return TCL_ERROR;
}


/*
 *--------------------------------------------------------------
 *
 * LexerUnputObjCmd --
 *
 *    This procedure is invoked to process the "unput" subcommand
 *    for lexers. See the user documentation for details on what
 *    it does.
 *
 * Results:
 *    A standard Tcl result.
 *
 * Side effects:
 *    See the user documentation.
 *
 *--------------------------------------------------------------
 */

int
LexerUnputObjCmd(clientData, interp, objc, objv)
    ClientData    clientData;
    Tcl_Interp    *interp;
    int           objc;
    Tcl_Obj *CONST objv[];
{
    TcLex_Lexer   *lexer    = (TcLex_Lexer *)clientData;
    TcLex_State   *statePtr = lexer->states[lexer->curState];
    int           nbChars = 1;
    int           oldIndex;
    
    /*
     * Sanity check
     */

    if (objc > 3)
      goto numberArgsError;

    if (objc == 3) {
      if (Tcl_GetIntFromObj(interp, objv[2], &nbChars) == TCL_ERROR)
          return TCL_ERROR;
    }
    if (nbChars < 0)
      nbChars = 0;


    /* Unput the previous nbChars characters */
    oldIndex = statePtr->currentBuffer->nextIndex;
    statePtr->currentBuffer->nextIndex -= nbChars;
    if (statePtr->currentBuffer->nextIndex < statePtr->currentBuffer->index) {
      statePtr->currentBuffer->nextIndex = statePtr->currentBuffer->index;
    }
    return TCL_OK;


    /*
     * Error handling
     */

numberArgsError:
    Tcl_WrongNumArgs(interp, 2, objv, "?nbChars?");
    return TCL_ERROR;
}


/*
 *--------------------------------------------------------------
 *
 * LexerSetCurrent --
 *
 *    This procedure sets the current active lexer. Used with the
 *    "eval" et al subcommands.
 *
 * Results:
 *    None.
 *
 * Side effects:
 *    The current lexer for the current interpreter gets modified.
 *
 *--------------------------------------------------------------
 */

void
LexerSetCurrent(interp, lexer)
    Tcl_Interp    *interp;
    TcLex_Lexer   *lexer;
{
    int created;
    Tcl_HashEntry *e = Tcl_CreateHashEntry(&CurrentLexersTable, (char*)interp, &created);
    Tcl_SetHashValue(e, (ClientData)lexer);
}

 
/*
 *--------------------------------------------------------------
 *
 * LexerGetCurrent --
 *
 *    This procedure gets the current active lexer. Used with the
 *    "current" subcommand.
 *
 * Results:
 *    A pointer to the current lexer.
 *
 * Side effects:
 *    None.
 *
 *--------------------------------------------------------------
 */

TcLex_Lexer*
LexerGetCurrent(interp)
    Tcl_Interp    *interp;
{
    int created;
    Tcl_HashEntry *e = Tcl_CreateHashEntry(&CurrentLexersTable, (char*)interp, &created);
    return (TcLex_Lexer*)Tcl_GetHashValue(e);
}

 
/*
 *--------------------------------------------------------------
 *
 * LexerObjCmd --
 *
 *    This procedure is invoked to process the Tcl commands
 *    created by "lexer", and serves as a switchbox between the
 *    different subcommands.
 *
 * Results:
 *    A standard Tcl result.
 *
 * Side effects:
 *    Depend on subcommand.
 *
 *--------------------------------------------------------------
 */

int
LexerObjCmd(clientData, interp, objc, objv)
    ClientData    clientData;
    Tcl_Interp    *interp;
    int           objc;
    Tcl_Obj *CONST objv[];
{
    TcLex_Lexer   *lexer = (TcLex_Lexer *)clientData;
    static char *options[] = {
      "eval",               "start",          "continue",         "finish",
      "begin",        "end",
      "conditions",         "reject",
      "index",        "input",          "unput", 
      NULL
    };
    static enum {
      OPTION_EVAL,          OPTION_START,   OPTION_CONTINUE,      OPTION_FINISH,
      OPTION_BEGIN,         OPTION_END,
      OPTION_CONDITIONS,  OPTION_REJECT,
      OPTION_INDEX,         OPTION_INPUT,   OPTION_UNPUT
    } optionIndex;
    static int ops[] = {
      /* Lexer evaluation functions */
      LEXER_EVAL, LEXER_START, LEXER_CONTINUE, LEXER_FINISH,
    };
    static Tcl_ObjCmdProc *commands[] = {
      /* Lexer state functions */
      (Tcl_ObjCmdProc *)LexerBeginObjCmd,
      (Tcl_ObjCmdProc *)LexerEndObjCmd,
      (Tcl_ObjCmdProc *)LexerConditionsObjCmd,
      (Tcl_ObjCmdProc *)LexerRejectObjCmd,
      (Tcl_ObjCmdProc *)LexerIndexObjCmd,
      (Tcl_ObjCmdProc *)LexerInputObjCmd,
      (Tcl_ObjCmdProc *)LexerUnputObjCmd
    };
    
    /*
     * Sanity check
     */

    if (objc < 2)
      goto numberArgsError;

    /*
     * Get the subcommand
     */

    if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, &optionIndex) == TCL_ERROR)
      return TCL_ERROR;

    /*
     * Switchbox
     */

    if (optionIndex < 4) {
      return LexerEvalObjCmd(interp, lexer, objc, objv, ops[optionIndex]);
    } else {
      /*
       * If subcommand needs state, check if lexer is active
       */

      if (lexer->curState == -1)
          goto inactiveLexerError;
      return (commands[optionIndex-4])(clientData, interp, objc, objv);
    }

    
    /*
     * Error handling
     */

inactiveLexerError:
    Tcl_AppendResult(interp, "lexer \"", Tcl_GetStringFromObj(objv[0], NULL), "\" is inactive", NULL);
    return TCL_ERROR;
    
numberArgsError:
    Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
    return TCL_ERROR;
}   


/*
 *----------------------------------------------------------------------
 *
 * Tclex_Init --
 *
 *    This function is used to initialize the package. Here we check
 *    dependencies with other packages (eg Tcl), create new commands,
 *    and register our packages
 *
 * Results:
 *    A standard Tcl result.
 *
 * Side effects:
 *    New commands created, and package registered (see documentation).
 *
 *----------------------------------------------------------------------
 */

int Tclex_Init(interp)
    Tcl_Interp *interp;
{  
#ifdef USE_TCL_STUBS
    if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) {
      return TCL_ERROR;
    }
#endif


    /* Dependencies */
    if (Tcl_PkgRequire(interp, "Tcl", TCL_VERSION, 0) == NULL)
      return TCL_ERROR;

    /* Initialization */
    InitialCond = Tcl_NewStringObj("initial", -1);
    Tcl_IncrRefCount(InitialCond);

    Tcl_InitHashTable(&CurrentLexersTable, TCL_ONE_WORD_KEYS);


    /* Commands creation */
    Tcl_CreateObjCommand(interp, "lexer", (Tcl_ObjCmdProc *)LexerMainObjCmd,
                           (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);

    /* Package provided */
    if (Tcl_PkgProvide(interp, "tcLex", TCLEX_VERSION) == TCL_ERROR)
      return TCL_ERROR;

    return TCL_OK;
}


/*
 *----------------------------------------------------------------------
 *
 * Tclex_SafeInit --
 *
 *    This function is used to initialize the package in the special case
 *    of safe interpreters (like the Tcl Plugin). Here we check
 *    dependencies with other packages (eg Tcl), create new commands,
 *    and register our packages
 *
 * Results:
 *    A standard Tcl result.
 *
 * Side effects:
 *    New commands created, and package registered (see documentation).
 *
 *----------------------------------------------------------------------
 */

int Tclex_SafeInit(interp)
    Tcl_Interp *interp;
{  
    /* For now, do the same as with unsafe interpreters */
    return Tclex_Init(interp);
}

#ifdef WIN32
/*
 *----------------------------------------------------------------------
 *
 * DllEntryPoint --
 *
 *    This wrapper function is used by Windows to invoke the
 *    initialization code for the DLL.  If we are compiling
 *    with Visual C++, this routine will be renamed to DllMain.
 *    routine.
 *
 * Results:
 *    Returns TRUE;
 *
 * Side effects:
 *    None.
 *
 *----------------------------------------------------------------------
 */

BOOL APIENTRY
DllEntryPoint(hInst, reason, reserved)
    HINSTANCE hInst; /* Library instance handle. */
    DWORD reason;    /* Reason this function is being called. */
    LPVOID reserved; /* Not used. */
{
    return TRUE;
}
#endif /* WIN32 */


Generated by  Doxygen 1.6.0   Back to index