let debug_lex =
   Lm_debug.create_debug (**)
      { debug_name = "lex";
        debug_description = "Debug the lexer";
        debug_value = false
      }

let debug_lexgen =
   Lm_debug.create_debug (**)
      { debug_name = "lexgen";
        debug_description = "Debug the lexer generator";
        debug_value = false
      }

(*
 * We simulate the NFA using the normal subset construction.
 * That is, the state of the DFA is a set of states of the NFA.
 *
 * In addition, we have counters for the r{n,m} regular expressions.
 *
 * So, we model a state of the NFA as a state and the list of
 * counters.  A state of the DFA is a sorted list of NFA states.
 *)
module NfaStateCore =
struct
   type t = int * int list

   (*
    * Reset one of the counters.
    *)
   let rec reset_counter counters i =
      match counters with
      | counter :: counters ->
        if i = 0 then
          0 :: counters
        else
          counter :: reset_counter counters (pred i)
      | [] ->
            raise (Invalid_argument "reset_counter: illegal counter")

   (*
    * Increment one of the counters.
    * Return the new counter value too.
    *)
   let incr_counter counters i min final max start =
      let rec incr counters i =
         match counters with
            counter :: counters ->
               if i = 0 then
                  let counter = succ counter in
                     counter, counter :: counters
               else
                  let i, counters = incr counters (pred i) in
                     i, counter :: counters
          | [] ->
               raise (Invalid_argument "incr_counter: illegal counter")
      in
      let counter, counters' = incr counters i in
         if counter < min then
            [start, counters']
         else if counter = min then
            [final, counters'; start, counters']
         else if max >= min && counter > max then
            []
         else if max < min then (* This is an optimization: no need to increment the counter *)
            [final, counters; start, counters]
         else
            [final, counters'; start, counters']
end;;

(*
 * Hash them.
 *)
module NfaStateArg =
struct
  type t = NfaStateCore.t

  let debug = "NfaState"

  let hash (s, counters) =
    Lm_hash_code.hash_int_list (s lxor 0x2c18c4d5) counters

  let rec compare_int_list (l1 : int list) (l2 : int list) =
    match l1, l2 with
    | i1 :: l1, i2 :: l2 ->
      if i1 < i2 then
        -1
      else if i1 > i2 then
        1
      else
        compare_int_list l1 l2
    | [], _ ::_ ->
      -1
    | _ :: _, [] ->
      1
    | [], [] ->
      0

  let compare ((s1, counters1) : t) ((s2, counters2) : t) =
    if s1 < s2 then
      -1
    else if s1 > s2 then
      1
    else
      compare_int_list counters1 counters2
end;;

module NfaState = Lm_hash_cons.Make (NfaStateArg);;
module NfaStateSet = Lm_set.LmMake (NfaState);;
module NfaStateTable = Lm_map.LmMake (NfaState);;

(*
 * DFA states.
 *)
module DfaStateCore =
struct
   type t = NfaState.t list           (* Sorted *)

   (*
    * Empty set.
    *)
   let empty = ([] : t)

   (*
    * Membership.
    *)
   let mem (set : t) (state : NfaState.t) =
      List.mem state set

   (*
    * Add an element to the set.
    *)
   let rec add (set : t) (state : NfaState.t) =
      match set with
         j :: s ->
            if j > state then
               state :: set
            else if j = state then
               set
            else
               j :: add s state
       | [] ->
            [state]

   (*
    * Union of two sets.
    *)
   (* let rec union (s1 : t) (s2 : t) = *)
   (*    match s1, s2 with *)
   (*       i1 :: l1, i2 :: l2 -> *)
   (*          if i1 = i2 then *)
   (*             i1 :: union l1 l2 *)
   (*          else if i1 < i2 then *)
   (*             i1 :: union l1 s2 *)
   (*          else *)
   (*             i2 :: union s1 l2 *)
   (*     | _, [] -> *)
   (*          s1 *)
   (*     | [], _ -> *)
   (*          s2 *)
end;;

module DfaStateArg =
struct
   type t = DfaStateCore.t

   let debug = "DfaState"

   let hash state =
      let buf = Lm_hash_code.HashCode.create () in
         Lm_hash_code.HashCode.add_int buf 0x0affb3d4;
         List.iter (fun state -> Lm_hash_code.HashCode.add_int buf (NfaState.hash state)) state;
         Lm_hash_code.HashCode.code buf

   let rec compare l1 l2 =
      match l1, l2 with
         state1 :: l1, state2 :: l2 ->
            let cmp = NfaState.compare state1 state2 in
               if cmp = 0 then
                  compare l1 l2
               else
                  cmp
       | [], _ :: _ ->
            -1
       | _ :: _, [] ->
            1
       | [], [] ->
            0
end;;

module DfaState = 
  Lm_hash_cons.Make (DfaStateArg);;
module DfaStateTable = Lm_map.LmMake (DfaState);;

module IntCompare =
struct
   type t = int
   let compare = (-)
end

module IntSet   = Lm_set.LmMake (IntCompare);;
module IntTable = Lm_map.LmMake (IntCompare);;

(*
 * A argument has two parts.
 *)
type arg =
   ArgLeft of int
 | ArgRight of int
 | ArgSearch

module ArgCompare =
struct
   type t = arg

   let compare a1 a2 =
      match a1, a2 with
         ArgLeft i1, ArgLeft i2
       | ArgRight i1, ArgRight i2 ->
            if i1 < i2 then
               -1
            else if i1 > i2 then
               1
            else
               0
       | ArgSearch, ArgSearch ->
            0
       | ArgLeft _, ArgRight _
       | ArgLeft _, ArgSearch
       | ArgRight _, ArgSearch ->
            -1
       | ArgSearch, ArgRight _
       | ArgSearch, ArgLeft _
       | ArgRight _, ArgLeft _ ->
            1
end;;

module ArgTable = Lm_map.LmMake (ArgCompare);;

(*
 * A TransTable represents the transition function for a DFA.
 * We represent this as a sorted array of entries.
 *)

(*
 * Binary search returns the smallest element
 * that is no smaller than the key.
 *)
let rec binary_search table (key : int) i j =
   if i < j - 1 then
      let k = (i + j) lsr 1 in
      let key', _ = table.(k) in
         if key' < key then
            binary_search table key k j
         else
            binary_search table key i k
   else
      j

module TransTable =
struct
   type 'a t = (int * 'a) array

   let empty = [||]

   (*
    * Find an entry in the table,
    * returning the default value if not found.
    *)
   let find table key default =
      let len = Array.length table in
      let i = binary_search table key (-1) len in
         if i = len then
            default
         else
            let key', value = table.(i) in
               if key' = key then
                  value
               else
                  default

   (*
    * Add an entry to the table.
    * Assumes the entry does not already exist.
    *)
   let add table key value =
      let len = Array.length table in
         if len = 0 then
            [|key, value|]
         else
            let i = binary_search table key (-1) len in
            let new_array = Array.make (len + 1) (key, value) in
               Array.blit table 0 new_array 0 i;
               Array.blit table i new_array (i + 1) (len - i);
               new_array
end

(************************************************************************
 * Lexer construction.
 *)

(*
 * Argument types.
 *)
module type LexerInput =
sig
   (*
    * Input channel is a stream of integers.
    * Usually these are just the ASCII codes for characters.
    *)
   type t

   (*
    * The channel has two special characters.
    *    bof: the beginning of file
    *    eof: the end of file.
    *)
   val bof : int
   val eof : int

   (*
    * The next function returns the next character in the input stream.
    *)
   val lex_next : t -> int

   (*
    * The pos function returns the current position of
    * the input buffer within the lexeme
    * (used for collecting \( ... \) arguments).
    *)
   val lex_pos : t -> int

   (*
    * The lexer will call start when it begins lexing.
    * The integer should be the *previous* character in the
    * input channel, or bof if at the beginning.
    *)
   val lex_start : t -> int

   (*
    * In some cases, the lexer may want to restart scanning
    * from a previous point.  If so, it will call this function
    * to reset the start point.
    *)
   val lex_restart : t -> int -> unit

   (*
    * When the lexer is done, it calls lex_stop with
    * the number of characters in the final lexeme.  Note
    * that this can cause data to be pushed back onto the input stream.
    *)
   val lex_stop : t -> int -> unit

   (*
    * Before calling lex_stop, the lexer may ask for the
    * lexeme as a string.  The integer is the number of
    * characters in the lexeme, the same as the argument
    * to lex_stop.
    *)
   val lex_string    : t -> int -> string
   val lex_substring : t -> int -> int -> string
   val lex_loc       : t -> int -> Lm_location.t
end

module type LexerAction =
sig
   (*
    * Semantic actions.
    * Values of action type *must* be comparable with =,
    * hopefully quickly.
    *
    * For example, functions are not allowed.
    * If you want a function, you should make an array of functions,
    * and use the index for the action name.
    *)
   type action

   (* For debugging *)
   val pp_print_action : action Lm_printf.t 

   (* For creating sets and tables *)
   val hash : action -> int
   val compare : action -> action -> int

   (*
    * You can use the function to decide which clauses take
    * precedence for a match of equal length.  The function
    * gets two clause numbers.  If you use the min function,
    * then you get the first clause that matched.  If you
    * use the max function, you get the second clause that
    * matched.
    *)
   val choose : int -> int -> int
end

module MakeLexer (Input : LexerInput) (Action : LexerAction) =
struct
   open Action

   (*
    * For now, just create a default action set.
    *)
   module ActionCompare =
   struct
      type t = action
      let compare = Action.compare
   end

   module ActionSet = Lm_set.LmMake (ActionCompare);;

   (************************************************************************
    * Types.
    *)

   (*
    * A simplified regular expression.
    *)

   (* %%MAGICBEGIN%% *)
   type regex =
       RegexAnySymbol
     | RegexSymbol       of IntSet.t
     | RegexExceptSymbol of IntSet.t
     | RegexLimitPrev    of IntSet.t
     | RegexLimitNext    of IntSet.t
     | RegexChoice       of regex list
     | RegexSequence     of regex list
     | RegexStar         of regex
     | RegexPlus         of regex
     | RegexInterval     of regex * int * int       (* regex, min, max *)
     | RegexArg          of regex

   (*
    * Termination symbols.
    *)
   type regex_term =
       RegexTermEof
     | RegexTermRightParen of int
     | RegexTermRightArg   of int
     | RegexTermPipe       of int

   (*
    * An expression is nearly an NFA,
    * but designed to be built incrementally.
    * The id is an arbitrary int, but all clauses
    * must have unique ids.
    *)
   type exp =
     { exp_clauses : (action * int * regex) list;
       exp_id      : int
     }

   (*
    * An action specifies:
    *    ActionEpsilon state : epsilon transition to the given states
    *    ActionArgStart i    : start collecting the arguments for the rules
    *    ActionArgStop i     : stop collecting the arguments for the rules
    *    ActionStop i        : rule i is finished
    *    ActionSymbol table  : transition function
    *    ActionLimit syms    : normally an epsilon transition, but limited to syms
    *                          (this is to handle \< and \> symbols)
    *)
   type nfa_action =
       NfaActionEpsilon      of int list           (* next state list *)
     | NfaActionArgStart     of int * int          (* arg id, next state *)
     | NfaActionArgStop      of int * int          (* arg id, next state *)
     | NfaActionArgSearch    of int                (* next state *)
     | NfaActionStop         of int                (* clause id, next state *)
     | NfaActionSymbol       of IntSet.t * int     (* symbols, next state *)
     | NfaActionAnySymbol    of int                (* next state *)
     | NfaActionExceptSymbol of IntSet.t * int     (* symbols, next state *)
     | NfaActionLimitPrev    of IntSet.t * int     (* symbols, next state *)
     | NfaActionLimitNext    of IntSet.t * int     (* symbols, next state *)
     | NfaActionNone
     | NfaActionResetCounter of int * int list              (* counter, next state list *)
     | NfaActionIncrCounter  of int * int * int * int * int (* counter, min, final, max, restart *)


   (*
    * This is the info we accumulate during compilation.
    *    nfa_index       : the index of the next state to be allocated
    *    nfa_counter     : the total number of interval expression we have seen
    *    nfa_arg_index   : the identifier of the next argument
    *)
   type nfa_accum =
     { nfa_index       : int;
       nfa_counter     : int;
       nfa_arg_index   : int
     }

   (*
    * This is the info we pass left-to-right during compilation.
    *    nfa_clause       : the index of the current clause being compiled
    *    nfa_arg_number   : the index of the next argument
    *)
   type nfa_info =
     { nfa_clause        : int;
       nfa_arg_number    : int
     }

   (*
    * A state in the machine.
    *)
   type nfa_state =
     { nfa_state_index   : int;
       nfa_state_action  : nfa_action
     }

   type group_info = int * int
     (* GS: In the NFA and DFA, the groups are globally numbered, across all
        clauses. This pair [(offset,length)] selects the [length] number of
        global groups starting at [offset].
      *)

   (*
    * The NFA has a start state,
    * and an array of states.
    *)
   type nfa =
     { nfa_hash          : NfaState.state;
       nfa_actions       : (action * group_info) IntTable.t;
       nfa_start         : NfaState.t;
       nfa_search_start  : NfaState.t;
       nfa_search_states : NfaStateSet.t;
       nfa_table         : nfa_state array;
       nfa_args          : IntSet.t IntTable.t
     }

   (*
    * DFA actions.  The action include looking for final states
    * (the dfa_action_final field), as well as argument actions.
    *
    * The argument actions happen on the NfaState.t components of
    * the DFA state.  The action table gives the actions that must
    * be performed for each NFA component that is the *target*
    * of the transition.
    *
    * Invariant: there is an entry in the dfa_action_parts for each
    * NFA component of the state that is the target of the transition.
    *)
   type dfa_action_inst =
       DfaActionArgStart of int
     | DfaActionArgStop  of int
     | DfaActionArgSearch

   type dfa_action_arg =
     { dfa_action_off  : int;
       dfa_action_inst : dfa_action_inst
     }

   type dfa_action =
     { dfa_action_src        : NfaState.t;
       dfa_action_args       : dfa_action_arg list
     }

   type dfa_actions =
     { dfa_action_final      : (int * NfaState.t) option;      (* clause id, NFA state *)
       dfa_action_actions    : dfa_action NfaStateTable.t      (* Actions for each of the target NFA components *)
     }

   (*
    * A transition may specify a new state and some actions.
    * or it may not exist,
    * or it may be unknown.
    *)
   type dfa_transition =
       DfaTransition of int * dfa_actions
     | DfaNoTransition
     | DfaUnknownTransition

   (*
    * A DFA state has an index,
    * the subset of states for the NFA,
    * and a lazy transition function.
    *)
   type dfa_state =
     { dfa_state_index         : int;
       dfa_state_set           : DfaState.t;
       mutable dfa_state_delta : dfa_transition TransTable.t
     }

   (*
    * The DFA has:
    *)
   type dfa =
     { mutable dfa_states : dfa_state array;      (* May be partially filled *)
       mutable dfa_length : int;                  (* Index of the largest valid state *)
       mutable dfa_map    : int DfaStateTable.t;  (* Map from NFA state subsets to DFA states *)
       dfa_table          : nfa_state array;      (* The NFA *)
       dfa_action_table   : (action * group_info) IntTable.t;    (* The map from clause id to actions *)
       dfa_search_states  : NfaStateSet.t;        (* Set of states for searching *)
       dfa_nfa_hash       : NfaState.state;       (* HashCons table for NFA states *)
       dfa_dfa_hash       : DfaState.state        (* HashCons table for DFA states *)
     }

   (*
    * The actual type.
    *)
   type t =
     { lex_exp         : exp;
       mutable lex_dfa : dfa option
     }
   (* %%MAGICEND%% *)

   (*
    * The pre-action is a partial action computation before
    * the complete action is collected.
    *)
   type pre_action =
     { pre_action_final          : int option;                 (* clause id *)
       pre_action_args           : dfa_action_arg list
     }

   (*
    * When we are scanning, we also have state.
    *)
   type dfa_info =
     { mutable dfa_stop_clause    : int;                  (* Clause id of the last match, or 0 if none *)
       mutable dfa_stop_pos       : int;                  (* Position of the last match *)
       mutable dfa_stop_args      : int ArgTable.t;       (* Arguments in the final state *)
       mutable dfa_start_pos      : int;                  (* Starting position *)

       (* The current argument state *)
       mutable dfa_args           : int ArgTable.t NfaStateTable.t;

       (*
        * The channel we are scanning from.
        *)
       dfa_channel                : Input.t
     }

   (* Return values from the searchto function *)
   type searchto_info =
       LexEOF
     | LexSkipped of Lm_location.t * string
     | LexMatched of action * Lm_location.t * string * string * string list

   (************************************************************************
    * Characters and classes.
   *)

   let bof = Input.bof
   let eof = Input.eof

   let zero_char         = Char.code '0'
   let at_char           = Char.code '@'
   let alert_char        = Char.code 'G' - at_char
   let backspace_char    = Char.code 'H' - at_char
   let formfeed_char     = Char.code 'L' - at_char
   let newline_char      = Char.code '\n'
   let cr_char           = Char.code '\r'
   let tab_char          = Char.code '\t'
   let vertical_tab_char = Char.code 'K' - at_char
   let hex_a_char        = Char.code 'a' - 10
   let hex_A_char        = Char.code 'A' - 10

   let alert_chars       = IntSet.singleton alert_char
   let backspace_chars   = IntSet.singleton backspace_char
   let formfeed_chars    = IntSet.singleton formfeed_char
   let newline_chars     = IntSet.singleton newline_char
   let cr_chars          = IntSet.singleton cr_char
   let tab_chars         = IntSet.singleton tab_char
   let vertical_tab_chars = IntSet.singleton vertical_tab_char

   (*
    * Character sets.
    *)
   external omake_alnum : unit -> string = "omake_alnum"
   external omake_alpha : unit -> string = "omake_alpha"
   external omake_graph : unit -> string = "omake_graph"
   external omake_lower : unit -> string = "omake_lower"
   external omake_upper : unit -> string = "omake_upper"
   external omake_punct : unit -> string = "omake_punct"
   external omake_space : unit -> string = "omake_space"

   let singleton_char c =
     IntSet.singleton (Char.code c)

   let explode_chars_add chars s =
     let len = String.length s in
     let rec collect chars i =
       if i = len then
         chars
       else
         collect (IntSet.add chars (Char.code s.[i])) (succ i)
     in
     collect chars 0

   let explode_chars s =
     explode_chars_add IntSet.empty s

   let bof_char = IntSet.singleton bof
   let eof_char = IntSet.singleton eof

   let bof_chars s =
     explode_chars_add bof_char s

   let eof_chars s =
     explode_chars_add eof_char s

   let alnum_chars = explode_chars (omake_alnum ())
   let alpha_chars = explode_chars (omake_alpha ())
   let graph_chars = explode_chars (omake_graph ())
   let lower_chars = explode_chars (omake_lower ())
   let upper_chars = explode_chars (omake_upper ())
   let punct_chars = explode_chars (omake_punct ())
   let space_chars = explode_chars (omake_space ())

   let blank_chars = explode_chars " \t"

   let cntrl_chars =
     let rec collect chars i =
       if i != 32 then
         collect (IntSet.add chars i) (succ i)
       else
         chars
     in
     collect IntSet.empty 0

   let digit_chars  = explode_chars "01234565789"

   let print_chars  = IntSet.add graph_chars (Char.code ' ')

   let xdigit_chars = explode_chars_add digit_chars "abcdefABCDEF"

   (* let white_or_bof_chars = IntSet.add space_chars bof *)
   (* let white_or_eof_chars = IntSet.add space_chars eof *)
   let word_chars = IntSet.add alnum_chars (Char.code '_')

   let all_chars =
     let rec collect chars i =
       if i != 256 then
         collect (IntSet.add chars i) (succ i)
       else
         chars
     in
     collect IntSet.empty 0

   let invert_chars chars =
     IntSet.diff all_chars chars

   let nonword_chars = invert_chars word_chars

   let bof_or_nonword_chars = IntSet.add nonword_chars bof
   let eof_or_nonword_chars = IntSet.add nonword_chars eof

   (************************************************************************
    * Regular expressions.
   *)

   (*
    * Printer.
    *)
   let pp_print_char buf c =
     if c = bof then
       Lm_printf.pp_print_string buf "\\bof"
     else if c = eof then
       Lm_printf.pp_print_string buf "\\eof"
     else if c < 32 || c >= 127 then
       Format.fprintf buf "\\%03d" c
     else
       Lm_printf.pp_print_char buf (Char.chr c)

   let pp_print_chars buf cl =
     IntSet.iter (pp_print_char buf) cl

   let rec pp_print_regex buf regex =
     match regex with
     | RegexAnySymbol ->
       Lm_printf.pp_print_string buf "."
     | RegexSymbol cl ->
       Format.fprintf buf "(symbol ";
       IntSet.iter (fun c -> pp_print_char buf c) cl;
       Format.fprintf buf ")"
     | RegexExceptSymbol cl ->
       Format.fprintf buf "(^symbol ";
       IntSet.iter (fun c -> pp_print_char buf c) cl;
       Format.fprintf buf ")"
     | RegexLimitPrev cl ->
       Format.fprintf buf "(prev-symbol ";
       IntSet.iter (fun c -> pp_print_char buf c) cl;
       Format.fprintf buf ")"
     | RegexLimitNext cl ->
       Format.fprintf buf "(next-symbol ";
       IntSet.iter (fun c -> pp_print_char buf c) cl;
       Format.fprintf buf ")"
     | RegexChoice el ->
       Format.fprintf buf "@[<hv 3>(choice";
       List.iter (fun e -> Format.fprintf buf "@ %a" pp_print_regex e) el;
       Format.fprintf buf ")@]"
     | RegexSequence el ->
       Format.fprintf buf "@[<hv 3>(sequence";
       List.iter (fun e -> Format.fprintf buf "@ %a" pp_print_regex e) el;
       Format.fprintf buf ")@]"
     | RegexStar e ->
       Format.fprintf buf "(star %a)" pp_print_regex e
     | RegexPlus e ->
       Format.fprintf buf "(plus %a)" pp_print_regex e
     | RegexInterval (e, min, max) ->
       Format.fprintf buf "@[<hv 3>(interval{%d,%d}@ %a)@]" min max pp_print_regex e
     | RegexArg e ->
       Format.fprintf buf "@[<hv 1>\\(%a\\)@]" pp_print_regex e

   (*
    * Standard regular expressions.
    *)
   let left_word_delimiter   = RegexSequence  [RegexLimitPrev bof_or_nonword_chars; RegexLimitNext word_chars]
   let right_word_delimiter  = RegexSequence  [RegexLimitPrev word_chars; RegexLimitNext eof_or_nonword_chars]
   let word_delimiter        = RegexChoice    [left_word_delimiter; right_word_delimiter]
   let inside_word_delimiter = RegexSequence  [RegexLimitPrev word_chars; RegexLimitNext word_chars]

   let left_line_delimiter   = RegexLimitPrev (bof_chars "\r\n")
   let right_line_delimiter  = RegexChoice    [RegexSymbol (eof_chars "\r\n");
                                               RegexSequence [RegexSymbol (singleton_char '\r');
                                                              RegexSymbol (singleton_char '\n')]]
   let bof_delimiter         = RegexLimitPrev bof_char
   let eof_delimiter         = RegexSymbol    eof_char

   (*
    * Reduce a choice list.
    *)
   let regex_reduce_choices stack =
     match stack with
       [] ->
       RegexSequence []
     | [regex] ->
       regex
     | _ ->
       RegexChoice (List.rev stack)
   (*
    * Reduce the stack, its just a sequence.
    *)
   let regex_reduce_sequence stack =
     match stack with
       [regex] ->
       regex
     | _ ->
       RegexSequence (List.rev stack)

   (*
    * Just saw a +
    *)
   let regex_reduce_plus stack =
     match stack with
       elem :: stack ->
       RegexPlus elem :: stack
     | [] ->
       [RegexSymbol (singleton_char '+')]

   let regex_reduce_star stack =
     match stack with
       elem :: stack ->
       RegexStar elem :: stack
     | [] ->
       [RegexSymbol (singleton_char '*')]

   let regex_reduce_opt stack =
     match stack with
       elem :: stack ->
       RegexChoice [elem; RegexSequence []] :: stack
     | [] ->
       [RegexSymbol (singleton_char '?')]

   let regex_reduce_interval stack n m =
     match stack with
       elem :: stack ->
       RegexInterval (elem, n, m) :: stack
     | [] ->
       []

   (*
    * Interval expressions.
    *)
   let rec regex_interval n s i len =
     if i = len then
       raise (Failure "Lm_lexer: regex: interval expression is not terminated");
     let j = succ i in
     let c = s.[i] in
     match c with
       '0'..'9' ->
       regex_interval (n * 10 + (Char.code c - Char.code '0')) s j len
     | ',' ->
       regex_interval_bound n 0 s j len
     | '}' ->
       n, n, j
     | _ ->
       raise (Failure "Lm_lexer: regex: interval expression is not terminated")

   and regex_interval_bound n m s i len =
     if i = len then
       raise (Failure "Lm_lexer: regex: interval expression is not terminated");
     let j = succ i in
     let c = s.[i] in
     match c with
       '0'..'9' ->
       regex_interval_bound n (m * 10 + (Char.code c - Char.code '0')) s j len
     | '}' ->
       n, m, j
     | _ ->
       raise (Failure "Lm_lexer: regex: interval expression is not terminated")

   (*
    * Character constants.
    *)
   let rec regex_hex_const c s i len =
     if i = len then
       c, i
     else
       let c' = s.[i] in
       let j = succ i in
       match c' with
         '0'..'9' ->
         regex_hex_const (c * 16 + Char.code c' - zero_char) s j len
       | 'a'..'f' ->
         regex_hex_const (c * 16 + Char.code c' - hex_a_char) s j len
       | 'A'..'F' ->
         regex_hex_const (c * 16 + Char.code c' - hex_A_char) s j len
       | _ ->
         c, i

   let rec regex_octal_const c s i len =
     if i = len then
       c, i
     else
       let c' = s.[i] in
       match c' with
         '0'..'7' ->
         regex_octal_const (c * 8 + Char.code c' - zero_char) s (succ i) len
       | _ ->
         c, i

   (*
    * Literal characters [...]
    *)
   let rec regex_chars s i len =
     if i = len then
       raise (Failure "Lm_lexer: regex: character sequence is not terminated");
     let j = succ i in
     match s.[i] with
       '^' ->
       let chars, j = regex_chars_head s j len in
       RegexExceptSymbol chars, j
     | _ ->
       let chars, j = regex_chars_head s i len in
       RegexSymbol chars, j

   (*
    * At the head, allow a literal ]
    *)
   and regex_chars_head s i len =
     if i = len then
       raise (Failure "Lm_lexer: regex: character sequence is not terminated");
     match s.[i] with
       ']' ->
       regex_chars_rest (singleton_char ']') s (succ i) len
     | _ ->
       regex_chars_rest IntSet.empty s i len

   (*
    * Normal scanning.
    * Have to look for [:...:] sequences and ]
    *)
   and regex_chars_rest chars s i len =
     if i = len then
       raise (Failure "Lm_lexer: regex: character sequence is not terminated");
     let j = succ i in
     match s.[i] with
       '[' ->
       regex_chars_possible_class chars s j len
     | ']' ->
       chars, j
     | '\\' ->
       regex_chars_escape chars s j len
     | c ->
       regex_chars_possible_range chars (Char.code c) s j len

   (*
    * Just saw a backslash.
    *)
   and regex_chars_escape chars s i len =
     if i = len then
       raise (Failure "Lm_lexer: regex: character sequence is not terminated");
     let j = succ i in
     let c, j =
       match s.[i] with
         'a' ->
         alert_char, j
       | 'b' ->
         backspace_char, j
       | 'f' ->
         formfeed_char, j
       | 'n' ->
         newline_char, j
       | 'r' ->
         cr_char, j
       | 't' ->
         tab_char, j
       | 'v' ->
         vertical_tab_char, j
       | 'x' ->
         regex_hex_const 0 s j len
       | '0'..'9' ->
         regex_octal_const 0 s i (min (i + 3) len)
       | c ->
         Char.code c, j
     in
     regex_chars_rest (IntSet.add chars c) s j len

   (*
    * Just seen a character, look for a character range c-c
    *)
   and regex_chars_possible_range chars c1 s i len =
     if i = len then
       raise (Failure "Lm_lexer: regex: character sequence not terminated");
     let j = succ i in
     match s.[i] with
       '-' ->
       regex_chars_range chars c1 s j len
     | '[' ->
       regex_chars_possible_class (IntSet.add chars c1) s j len
     | ']' ->
       IntSet.add chars c1, j
     | '\\' ->
       regex_chars_escape (IntSet.add chars c1) s j len
     | c ->
       regex_chars_possible_range (IntSet.add chars c1) (Char.code c) s j len

   (*
    * Just seen a c-, get the remain char.
    *)
   and regex_chars_range chars c1 s i len =
     if i = len then
       raise (Failure "Lm_lexer: regex: character sequence not terminated");
     let j = succ i in
     let c2 = Char.code s.[i] in
     let rec collect chars i =
       if i > c2 then
         chars
       else
         collect (IntSet.add chars i) (succ i)
     in
     let chars = collect chars c1 in
     regex_chars_rest chars s j len

   (*
    * Just saw a [, look for the :
    *)
   and regex_chars_possible_class chars s i len =
     if i = len then
       raise (Failure "Lm_lexer: regex: character sequence is not terminated");
     let j = succ i in
     match s.[i] with
       ':' ->
       regex_chars_class chars s j len
     | '[' ->
       regex_chars_possible_class (IntSet.add chars (Char.code '[')) s j len
     | '\\' ->
       regex_chars_escape (IntSet.add chars (Char.code '[')) s j len
     | c ->
       regex_chars_rest (IntSet.add (IntSet.add chars (Char.code c)) (Char.code '[')) s j len

   (*
    * Get the character class specified by a sequence [:name:]
    *)
   and regex_chars_class chars s i len =
     let start = i in
     let rec get_name i =
       if i + 1 >= len then
         raise (Failure "Lm_lexer: regex: character class is not terminated");
       let c = s.[i] in
       let j = succ i in
       match c with
         'a'..'z'
       | 'A'..'Z' ->
         get_name j
       | ':' ->
         if s.[j] = ']' then
           regex_chars_get_class chars (String.sub s start (i - start)) s (succ j) len
         else
           raise (Failure "Lm_lexer: regex: character class: syntax error")
       | _ ->
         raise (Failure "Lm_lexer: regex: character class: syntax error")
     in
     get_name i

   (*
    * These are the standard classes.
    *)
   and regex_chars_get_class chars name s i len =
     let charclass =
       match String.lowercase_ascii name with
         "alnum" ->
         alnum_chars
       | "alpha" ->
         alpha_chars
       | "blank" ->
         blank_chars
       | "cntrl" ->
         cntrl_chars
       | "digit" ->
         digit_chars
       | "graph" ->
         graph_chars
       | "lower" ->
         lower_chars
       | "print" ->
         print_chars
       | "punct" ->
         punct_chars
       | "space" ->
         space_chars
       | "upper" ->
         upper_chars
       | "xdigit" ->
         xdigit_chars
       | name ->
         raise (Failure ("Lm_lexer: regex: unknown character class: " ^ name))
     in
     regex_chars_rest (IntSet.union charclass chars) s i len

   (*
    * Parse an expression block.
    *)
   let rec regex_choices choices s i len =
     let regex, term = regex_of_string [] s i len in
     let choices = regex :: choices in
     match term with
       RegexTermEof ->
       regex_reduce_choices choices, term
     | RegexTermRightParen _
     | RegexTermRightArg _ ->
       regex_reduce_choices choices, term
     | RegexTermPipe i ->
       regex_choices choices s i len

   and regex_left_paren s i len =
     let regex, term = regex_choices [] s i len in
     match term with
       RegexTermRightParen i ->
       regex, i
     | RegexTermRightArg _
     | RegexTermEof ->
       raise (Failure "Lm_lexer: regex: mismatched parenthesis")
     | RegexTermPipe _ ->
       raise (Invalid_argument "regex_left_paren")

   and regex_left_arg s i len =
     let regex, term = regex_choices [] s i len in
     match term with
       RegexTermRightArg i ->
       regex, i
     | RegexTermRightParen _
     | RegexTermEof ->
       raise (Failure "Lm_lexer: regex: mismatched parenthesis")
     | RegexTermPipe _ ->
       raise (Invalid_argument "regex_left_arg")

   (*
    * Parse the regular expression string.
    *)
   and regex_of_string stack s i len =
     if i = len then
       regex_reduce_sequence stack, RegexTermEof
     else
       let j = succ i in
       match s.[i] with
         '\\' ->
         regex_of_escape stack s j len
       | '.' ->
         let stack = RegexAnySymbol :: stack in
         regex_of_string stack s j len
       | '^' ->
         let stack = left_line_delimiter :: stack in
         regex_of_string stack s j len
       | '$' ->
         let stack = right_line_delimiter :: stack in
         regex_of_string stack s j len
       | '[' ->
         let regex, j = regex_chars s j len in
         let stack = regex :: stack in
         regex_of_string stack s j len
       | '+' ->
         let stack = regex_reduce_plus stack in
         regex_of_string stack s j len
       | '*' ->
         let stack = regex_reduce_star stack in
         regex_of_string stack s j len
       | '?' ->
         let stack = regex_reduce_opt stack in
         regex_of_string stack s j len
       | '(' ->
         let regex, j = regex_left_paren s j len in
         regex_of_string (regex :: stack) s j len
       | ')' ->
         regex_reduce_sequence stack, RegexTermRightParen j
       | '|' ->
         regex_reduce_sequence stack, RegexTermPipe j
       | '{' ->
         let min, max, j = regex_interval 0 s j len in
         let stack = regex_reduce_interval stack min max in
         regex_of_string stack s j len
       | c ->
         let stack = RegexSymbol (singleton_char c) :: stack in
         regex_of_string stack s j len

   (*
    * Escaped char.
    *)
   and regex_of_escape stack s i len =
     if i = len then
       raise (Failure "Lm_lexer: illegal backslash at end of string");

     let j = succ i in
     match s.[i] with
       '(' ->
       let regex, j = regex_left_arg s j len in
       let stack = RegexArg regex :: stack in
       regex_of_string stack s j len
     | ')' ->
       regex_reduce_sequence stack, RegexTermRightArg j
     | '<' ->
       let stack = left_word_delimiter :: stack in
       regex_of_string stack s j len
     | '>' ->
       let stack = right_word_delimiter :: stack in
       regex_of_string stack s j len
     | 'y' ->
       let stack = word_delimiter :: stack in
       regex_of_string stack s j len
     | 'B' ->
       let stack = inside_word_delimiter :: stack in
       regex_of_string stack s j len
     | 'w' ->
       let stack = RegexSymbol word_chars :: stack in
       regex_of_string stack s j len
     | 'W' ->
       let stack = RegexExceptSymbol word_chars :: stack in
       regex_of_string stack s j len
     | '`' ->
       let stack = bof_delimiter :: stack in
       regex_of_string stack s j len
     | '\'' ->
       let stack = eof_delimiter :: stack in
       regex_of_string stack s j len
     | 'a' ->
       let stack = RegexSymbol alert_chars :: stack in
       regex_of_string stack s j len
     | 'b' ->
       let stack = RegexSymbol backspace_chars :: stack in
       regex_of_string stack s j len
     | 'f' ->
       let stack = RegexSymbol formfeed_chars :: stack in
       regex_of_string stack s j len
     | 'n' ->
       let stack = RegexSymbol newline_chars :: stack in
       regex_of_string stack s j len
     | 'r' ->
       let stack = RegexSymbol cr_chars :: stack in
       regex_of_string stack s j len
     | 't' ->
       let stack = RegexSymbol tab_chars :: stack in
       regex_of_string stack s j len
     | 'v' ->
       let stack = RegexSymbol vertical_tab_chars :: stack in
       regex_of_string stack s j len
     | 'x' ->
       let c, j = regex_hex_const 0 s j len in
       let stack = RegexSymbol (IntSet.singleton c) :: stack in
       regex_of_string stack s j len
     | '0'..'9' ->
       let c, j = regex_octal_const 0 s i (min (i + 3) len) in
       let stack = RegexSymbol (IntSet.singleton c) :: stack in
       regex_of_string stack s j len
     | c ->
       let stack = RegexSymbol (IntSet.singleton (Char.code c)) :: stack in
       regex_of_string stack s j len

   (*
    * The toplevel function.
    *)
   let regex_of_string s =
     let regex, term = regex_choices [] s 0 (String.length s) in
     let regex =
       match term with
         RegexTermEof ->
         regex
       | RegexTermRightParen _
       | RegexTermRightArg _ ->
         raise (Failure "Lm_lexer: regex: mismatched parenthesis")
       | RegexTermPipe _ ->
         raise (Invalid_argument "regex_of_string")
     in
     if !debug_lexgen then
       Format.eprintf "@[<v 3>Regex:@ @[<hv 3>string: \"%s\"@]@ @[<hv 3>regex:@ %a@]@]@." (**)
         s pp_print_regex regex;
     regex

   (************************************************************************
    * Expressions.
   *)
   let pp_print_exp buf exp =
     let { exp_clauses = clauses;
           exp_id = id
         } = exp
     in
     Format.fprintf buf "Id: %d" id;
     List.iter (fun (action, id, regex) ->
         Format.fprintf buf "@ @[<hv 3>Clause:@ id = %d@ action = %a@ @[<hv 3>regex =@ %a@]@]" (**)
           id pp_print_action action pp_print_regex regex) clauses

   (*
    * An expression is a set of clauses.
    *)
   let empty_exp =
     { exp_clauses = [];
       exp_id      = 0
     }

   (*
    * Compute the number of arguments in the regex.
    *)
   let rec regex_arg_count count e =
     match e with
       RegexAnySymbol
     | RegexSymbol _
     | RegexExceptSymbol _
     | RegexLimitPrev _
     | RegexLimitNext _
     | RegexChoice [] ->
       count
     | RegexChoice (e :: _)
     | RegexStar e
     | RegexPlus e
     | RegexInterval (e, _, _) ->
       regex_arg_count count e
     | RegexSequence el ->
       List.fold_left regex_arg_count count el
     | RegexArg e ->
       regex_arg_count (succ count) e

   (*
    * Add a clause to the pre-NFA.
    *)
   let add_clause_exp exp action s =
     let regex = regex_of_string s in
     let arity = regex_arg_count 0 regex in
     let { exp_clauses = clauses;
           exp_id      = id
         } = exp
     in
     let exp =
       { exp_clauses = (action, id, regex) :: clauses;
         exp_id      = succ id
       }
     in
     arity, exp

   (*
    * Remove a clause.
    *)
   let remove_clause_exp exp action =
     let clauses =
       List.filter (fun (action', _, _) ->
           action' <> action) exp.exp_clauses
     in
     { exp with exp_clauses = clauses }

   (*
    * Take the union of two expression lists.
    *)
   let union_exp exp1 exp2 =
     let { exp_clauses = clauses1;
           exp_id = id1
         } = exp1
     in
     let { exp_clauses = clauses2; _ } = exp2 in
     let actions =
       List.fold_left (fun actions (action, _, _) ->
           ActionSet.add actions action) ActionSet.empty clauses1
     in
     let rec collect id clauses1 clauses2 =
       match clauses2 with
         (action, _, regex) :: clauses2 ->
         if ActionSet.mem actions action then
           collect id clauses1 clauses2
         else
           collect (succ id) ((action, id, regex) :: clauses1) clauses2
       | [] ->
         id, clauses1
     in
     let id, clauses1 = collect id1 clauses1 clauses2 in
     if id = id1 then
       false, exp1
     else
       true, { exp_clauses = clauses1; exp_id = id }

   (************************************************************************
    * NFA.
   *)
   let pp_print_nfa_id hash buf nid =
     match NfaState.get hash nid with
     | (nid, []) ->
       Lm_printf.pp_print_int buf nid
     | (nid, counters) ->
       Format.fprintf buf "<%d" nid;
       List.iter (fun counter -> Format.fprintf buf " %d" counter) counters;
       Format.fprintf buf ">"

   let pp_print_nfa_id_set hash buf states =
     NfaStateSet.iter (fun s ->
         Format.fprintf buf "@ %a" (pp_print_nfa_id hash) s) states

   (* let pp_print_choices buf choices = *)
   (*    IntSet.iter (fun i -> Format.fprintf buf " %d" i) choices *)

   let pp_print_nfa_action buf action =
     match action with
       NfaActionEpsilon next ->
       Format.fprintf buf "@[<hv 3>(epsilon goto";
       List.iter (fun i -> Format.fprintf buf "@ %d" i) next;
       Format.fprintf buf ")@]"
     | NfaActionArgStart (id, next) ->
       Format.fprintf buf "(arg-start %d goto %d)" id next
     | NfaActionArgStop (id, next) ->
       Format.fprintf buf "(arg-stop %d goto %d)" id next
     | NfaActionArgSearch next ->
       Format.fprintf buf "(arg-search goto %d)" next
     | NfaActionStop clause ->
       Format.fprintf buf "(stop [%d])" clause
     | NfaActionSymbol (syms, next) ->
       Format.fprintf buf "@[<hv 3>(symbols [%a]@ goto %d)@]" pp_print_chars syms next
     | NfaActionExceptSymbol (syms, next) ->
       Format.fprintf buf "@[<hv 3>(^symbols [%a]@ goto %d)@]" pp_print_chars syms next
     | NfaActionAnySymbol next ->
       Format.fprintf buf "(. goto %d)" next
     | NfaActionLimitPrev (syms, next) ->
       Format.fprintf buf "@[<hv 3>(limit-prev [%a]@ goto %d)@]" pp_print_chars syms next
     | NfaActionLimitNext (syms, next) ->
       Format.fprintf buf "@[<hv 3>(limit-next [%a]@ goto %d)@]" pp_print_chars syms next
     | NfaActionNone ->
       Format.fprintf buf "(final)"
     | NfaActionResetCounter (counter, next) ->
       Format.fprintf buf "@[<hv 3>(reset@ counter = %d@ goto" counter;
       List.iter (fun i -> Format.fprintf buf "@ %d" i) next;
       Format.fprintf buf ")@]"
     | NfaActionIncrCounter (counter, min, final, max, start) ->
       Format.fprintf buf "@[<hv 3>(increment@ counter = %d@ if count >= %d then goto %d@ if count <= %d then goto %d)@]" (**)
         counter min final max start

   let pp_print_nfa_state buf nfa_state =
     let { nfa_state_index = index;
           nfa_state_action = action
         } = nfa_state
     in
     Format.fprintf buf "@[<hv 3>NFA state %d:@ action %a@]" index pp_print_nfa_action action

   let pp_print_nfa buf nfa =
     let { nfa_hash  = hash;
           nfa_start = start;
           nfa_search_start = search;
           nfa_search_states = search_states;
           nfa_table = table;
           _
         } = nfa
     in
     Format.fprintf buf "@[<hv 3>NFA:@ start = %a@ search = %a@ @[<b 3>search-states =%a@]" (**)
       (pp_print_nfa_id hash) start
       (pp_print_nfa_id hash) search
       (pp_print_nfa_id_set hash) search_states;
     Array.iter (fun state ->
         Format.fprintf buf "@ %a" pp_print_nfa_state state) table;
     Format.fprintf buf "@]"

   (************************************************
    * Construct a new state.
   *)
   let nfa_state accum action =
     let { nfa_index = index ; _} = accum in
     let state =
       { nfa_state_index = index;
         nfa_state_action = action
       }
     in
     { accum with nfa_index = succ index }, state

   (*
    * Set the action.
    *)
   let set_action state action =
     { state with nfa_state_action = action }

   (*
    * Compile the NFA from a regex.
    * We are given a start and a final state,
    * and the task to to connect them according to the regex.
    *
    * Invariant: the provided start state is current NfaActionNone.
    * There is no such guarantee for the provided final state, and
    * it should not be modified.
    *
    * The states list contains all the states that are not the
    * start and final states.
    *)
   let rec compile (accum : nfa_accum) (info : nfa_info) start final states regex =
     match regex with
     (* Sequence *)
       RegexSequence regexl ->
       compile_sequence accum info start final states regexl

     (* Choice *)
     | RegexChoice [] ->
       let start = set_action start (NfaActionEpsilon [final.nfa_state_index]) in
       accum, info, start, states
     | RegexChoice [regex] ->
       compile accum info start final states regex
     | RegexChoice (regex :: regexl) ->
       let accum, info, starts, finals, states =
         compile_choice accum info states regex regexl
       in
       let start = set_action start (NfaActionEpsilon (List.map (fun state -> state.nfa_state_index) starts)) in
       let action = NfaActionEpsilon [final.nfa_state_index] in
       let finals = List.map (fun state -> set_action state action) finals in
       accum, info, start, starts @ finals @ states

     (* Symbols *)
     | RegexSymbol syms ->
       let start = set_action start (NfaActionSymbol (syms, final.nfa_state_index)) in
       accum, info, start, states
     | RegexExceptSymbol syms ->
       let start = set_action start (NfaActionExceptSymbol (syms, final.nfa_state_index)) in
       accum, info, start, states
     | RegexAnySymbol ->
       let start = set_action start (NfaActionAnySymbol final.nfa_state_index) in
       accum, info, start, states
     | RegexLimitPrev syms ->
       let start = set_action start (NfaActionLimitPrev (syms, final.nfa_state_index)) in
       accum, info, start, states
     | RegexLimitNext syms ->
       let start = set_action start (NfaActionLimitNext (syms, final.nfa_state_index)) in
       accum, info, start, states

     (* Kleene closure *)
     | RegexStar regex ->
       let accum, start1 = nfa_state accum NfaActionNone in
       let accum, final1 = nfa_state accum (NfaActionEpsilon [start1.nfa_state_index; final.nfa_state_index]) in
       let start = set_action start (NfaActionEpsilon [start1.nfa_state_index; final.nfa_state_index]) in
       let accum, info, start1, states =
         compile accum info start1 final1 states regex
       in
       accum, info, start, start1 :: final1 :: states
     | RegexPlus regex ->
       let accum, start1 = nfa_state accum NfaActionNone in
       let accum, final1 = nfa_state accum (NfaActionEpsilon [start1.nfa_state_index; final.nfa_state_index]) in
       let start = set_action start (NfaActionEpsilon [start1.nfa_state_index]) in
       let accum, info, start1, states =
         compile accum info start1 final1 states regex
       in
       accum, info, start, start1 :: final1 :: states
     | RegexInterval (regex, min, max) ->
       let { nfa_counter = counter; _ } = accum in
       let accum, start1 = nfa_state accum NfaActionNone in
       let accum, final1 =
         nfa_state accum (NfaActionIncrCounter (counter, min, final.nfa_state_index, max, start1.nfa_state_index))
       in
       let start =
         let states = [start1.nfa_state_index] in
         let states =
           if min = 0 then
             final.nfa_state_index :: states
           else
             states
         in
         set_action start (NfaActionResetCounter (counter, states))
       in
       let accum = { accum with nfa_counter = succ counter } in
       let accum, info, start1, states =
         compile accum info start1 final1 states regex
       in
       accum, info, start, start1 :: final1 :: states

     (* Arguments *)
     | RegexArg regex ->
       let { nfa_arg_index = argindex; _ } = accum in
       let accum, final1 = nfa_state accum (NfaActionArgStop (argindex, final.nfa_state_index)) in
       let accum, start1 = nfa_state accum NfaActionNone in
       let start = set_action start (NfaActionArgStart (argindex, start1.nfa_state_index)) in
       let { nfa_arg_number = argnumber; _ } = info in
       let accum = { accum with nfa_arg_index = succ argindex } in
       let info = { info with nfa_arg_number  = succ argnumber } in
       let accum, info, start1, states =
         compile accum info start1 final1 states regex
       in
       accum, info, start, start1 :: final1 :: states

   (*
    * Choice.
    * Map over all the choices; make sure the argument counts match.
    *)
   and compile_choice accum info_orig states regex regexl =
     let accum, start = nfa_state accum NfaActionNone in
     let accum, final = nfa_state accum NfaActionNone in
     let accum, info1, start, states =
       compile accum info_orig start final states regex
     in
     let accum, info, starts, finals, states =
       List.fold_left (fun (accum, info1, starts, finals, states) regex ->
           let accum, start = nfa_state accum NfaActionNone in
           let accum, final = nfa_state accum NfaActionNone in
           let accum, info2, start, states =
             compile accum info_orig start final states regex
           in
           let () =
             if info1.nfa_arg_number <> info2.nfa_arg_number then
               raise (Failure "Lm_lexer: Regular expression has mismatched argument counts")
           in
           accum, info1, start :: starts, final :: finals, states) (**)
         (accum, info1, [start], [final], states) regexl
     in
     accum, info, starts, finals, states

   (*
    * Sequence.
    * Chain together the expressions.
    *)
   and compile_sequence accum info start final states regexl =
     match regexl with
       [] ->
       let start = set_action start (NfaActionEpsilon [final.nfa_state_index]) in
       accum, info, start, states
     | [regex] ->
       compile accum info start final states regex
     | regex :: regexl ->
       let accum, middle = nfa_state accum NfaActionNone in
       let accum, info, start, states =
         compile accum info start middle states regex
       in
       let accum, info, middle, states =
         compile_sequence accum info middle final states regexl
       in
       accum, info, start, middle :: states

   (*
    * Compile a clause.
    *)
   let compile_clause accum info states regex =
     let accum, final = nfa_state accum (NfaActionStop info.nfa_clause) in
     let accum, start = nfa_state accum NfaActionNone in
     let accum, info, start, states =
       compile accum info start final states regex
     in
     accum, info, start, final :: states

   (*
    * Create an actual NFA from the regular expression.
    * When lexing, we always start with the previous character
    * in the input (so we can handle \< expressions).
    * Add a new start state with a full set of transitions.
    *)
   let create_nfa exp =
     (* Initial accumulator and info *)
     let accum =
       { nfa_index     = 0;
         nfa_counter   = 0;
         nfa_arg_index = 0
       }
     in

     (* Compile the expressions *)
     let accum, depends, actions, starts, states =
       List.fold_left
         (fun (accum, depends, actions, starts, states) (action, id, regex) ->
            let arg_offset = accum.nfa_arg_index in
            let info =
              { nfa_clause      = id;
                nfa_arg_number  = 0
              } in
            let accum, _info, start, states =
              compile_clause accum info states regex in
            let arg_length = accum.nfa_arg_index - arg_offset in
            let arg_info = (arg_offset, arg_length) in
            let actions = IntTable.add actions id (action, arg_info) in
            let starts = start.nfa_state_index :: starts in
            let states = start :: states in
            accum, depends, actions, starts, states
         )
         (accum, IntTable.empty, IntTable.empty, [], [])
         exp.exp_clauses
     in

     (* Add the normal start state *)
     let accum, choice = nfa_state accum (NfaActionEpsilon starts) in
     let accum, start  = nfa_state accum (NfaActionAnySymbol choice.nfa_state_index) in
     let states = start :: choice :: states in

     (* Add a start state for searching '.*\(r\)' *)
     let accum, search_final = nfa_state accum (NfaActionArgSearch choice.nfa_state_index) in
     let accum, search_loop2 = nfa_state accum NfaActionNone in
     let accum, search_loop1 = nfa_state accum (NfaActionEpsilon [search_loop2.nfa_state_index; search_final.nfa_state_index]) in
     let search_loop2 = set_action search_loop2 (NfaActionAnySymbol search_loop1.nfa_state_index) in
     let accum, search_start = nfa_state accum (NfaActionAnySymbol search_loop1.nfa_state_index) in
     let states = search_start :: search_loop1 :: search_loop2 :: search_final :: states in
     let search_states = [search_start; search_loop1; search_loop2; search_final] in

     (* Build the table *)
     let length = List.length states in
     let table = Array.make length start in
     let counters =
       let rec collect l i =
         if i = 0 then
           l
         else
           collect (0 :: l) (pred i)
       in
       collect [] accum.nfa_counter
     in

     (* Hash it *)
     let hash = NfaState.create_state () in
     let start = NfaState.create hash (start.nfa_state_index, counters) in
     let search_start = NfaState.create hash (search_start.nfa_state_index, counters) in
     let search_states =
       List.fold_left (fun states state ->
           NfaStateSet.add states (NfaState.create hash (state.nfa_state_index, counters))) NfaStateSet.empty search_states
     in
     (* Add all the states to the table *)
     List.iter (fun state ->
         table.(state.nfa_state_index) <- state) states;

     (* Check that the states had unique indexes *)
     Array.iteri (fun i state ->
         assert (state.nfa_state_index = i)) table;

     { nfa_hash          = hash;
       nfa_actions       = actions;
       nfa_start         = start;
       nfa_search_start  = search_start;
       nfa_search_states = search_states;
       nfa_table         = table;
       nfa_args          = depends
     }

   (************************************************************************
    * DFA
    *
    * The DFA is computed lazily from the NFA.
   *)

   (************************************************
    * Printing.
   *)
   let pp_print_dfa_set hash buf closure =
     Format.fprintf buf "@[<b 3>(set";
     List.iter (fun i -> Format.fprintf buf "@ %a" (pp_print_nfa_id hash) i) closure;
     Format.fprintf buf ")@]"

   let pp_print_dfa_arg_action buf action =
     let { dfa_action_off = off; dfa_action_inst = inst } = action in
     match inst with
       DfaActionArgStart i ->
       Format.fprintf buf "arg-start %d at %d" i off
     | DfaActionArgStop i ->
       Format.fprintf buf "arg-stop %d at %d" i off
     | DfaActionArgSearch ->
       Format.fprintf buf "search-stop at %d" off

   let pp_print_dfa_actions nfa_hash buf action =
     let { dfa_action_final = final;
           dfa_action_actions = actions
         } = action
     in
     let () =
       Format.fprintf buf "@[<hv 3>(action"
     in
     let () =
       match final with
         Some (clause_id, nfa_id) ->
         Format.fprintf buf "@ final [clause=%d, nfa-state=%a]" clause_id (pp_print_nfa_id nfa_hash) nfa_id
       | None ->
         ()
     in
     NfaStateTable.iter (fun dst action ->
         let { dfa_action_src = src;
               dfa_action_args = args
             } = action
         in
         Format.fprintf buf "@ @[<hv 3>(%a -> %a" (pp_print_nfa_id nfa_hash) src (pp_print_nfa_id nfa_hash) dst;
         List.iter (fun action -> Format.fprintf buf "@ %a" pp_print_dfa_arg_action action) args;
         Format.fprintf buf ")@]") actions;
     Format.fprintf buf ")@]"

   let pp_print_pre_actions buf action =
     let { pre_action_final = final;
           pre_action_args = args
         } = action
     in
     let () =
       Format.fprintf buf "@[<hv 3>(pre-action@ "
     in
     let () =
       match final with
         Some stop ->
         Format.fprintf buf "final [%d]@ " stop
       | None ->
         ()
     in
     Format.fprintf buf "@[<hv 3>argument actions:";
     List.iter (fun action -> Format.fprintf buf "@ %a" pp_print_dfa_arg_action action) args;
     Format.fprintf buf "@])@]"

   (* let pp_print_dfa_transition buf trans = *)
   (*    match trans with *)
   (*       DfaTransition (i, _) -> *)
   (*          Format.fprintf buf "goto %d" i *)
   (*     | DfaNoTransition -> *)
   (*          Format.fprintf buf "error" *)
   (*     | DfaUnknownTransition -> *)
   (*          Format.fprintf buf "unknown" *)

   (* let pp_print_trans_table buf table = *)
   (*    Format.fprintf buf "@[<hv 3>(trans"; *)
   (*    Array.iter (fun (key, trans) -> *)
   (*          Format.fprintf buf "@ %d -> %a" key pp_print_dfa_transition trans) table; *)
   (*    Format.fprintf buf ")@]" *)

   (*
    * Print an argument.
    *)
   let pp_print_arg buf arg =
     match arg with
       ArgLeft i ->
       Format.fprintf buf "left[%d]" i
     | ArgRight i ->
       Format.fprintf buf "right[%d]" i
     | ArgSearch ->
       Format.fprintf buf "searchreg"

   (*
    * Print the frontier.
    *)
   let pp_print_frontier nfa_hash buf table =
     Format.fprintf buf "@[<hv 3>frontier:";
     NfaStateTable.iter (fun id actions ->
         Format.fprintf buf "@ @[<hv 3>%a:@ %a@]" (pp_print_nfa_id nfa_hash) id pp_print_pre_actions actions) table;
     Format.fprintf buf "@]"

   (************************************************
    * DFA.
   *)

   (*
    * Action operations.
    *)
   let pre_action_empty =
     { pre_action_final          = None;
       pre_action_args           = []
     }

   let pre_action_add_stop action clause =
     match action.pre_action_final with
       Some clause' ->
       { action with pre_action_final = Some (Action.choose clause clause') }
     | None ->
       { action with pre_action_final = Some clause }

   let pre_action_add_arg actions arg =
     { actions with pre_action_args = arg :: actions.pre_action_args }

   let pre_action_add_arg_start actions off id =
     pre_action_add_arg actions { dfa_action_off = off; dfa_action_inst = DfaActionArgStart id }

   let pre_action_add_arg_stop actions off id =
     pre_action_add_arg actions { dfa_action_off = off; dfa_action_inst = DfaActionArgStop id }

   let pre_action_add_arg_search actions off =
     pre_action_add_arg actions { dfa_action_off = off; dfa_action_inst = DfaActionArgSearch }

   (*
    * DFA actions.
    *)
   let dfa_action_is_empty action =
     match action with
       { dfa_action_final = None; dfa_action_actions = actions } ->
       NfaStateTable.is_empty actions
     | { dfa_action_final = Some _ ; _  } ->
       false

   (*
    * Action evaluation.
    * We are given the argument info for each of the src states,
    * and we need to compute the argument info for each of the dst states.
    *)
   let dfa_apply_action pos args action =
     let { dfa_action_off = off; dfa_action_inst = inst } = action in
     let pos = pos + off in
     match inst with
       DfaActionArgStart i ->
       ArgTable.add args (ArgLeft i) pos
     | DfaActionArgStop i ->
       ArgTable.add args (ArgRight i) pos
     | DfaActionArgSearch ->
       ArgTable.add args ArgSearch pos

   let dfa_eval_action dfa info action =
     let { dfa_channel = channel;
           dfa_args = args_table;
           _
         } = info
     in
     let { dfa_action_final = final;
           dfa_action_actions = actions
         } = action
     in
     let pos = Input.lex_pos channel in
     let args_table =
       NfaStateTable.map (fun action ->
           let { dfa_action_src = src;
                 dfa_action_args = actions
               } = action
           in
           let args =
             try NfaStateTable.find args_table src with
               Not_found ->
               ArgTable.empty
           in
           List.fold_left (dfa_apply_action pos) args actions) actions
     in
     if !debug_lex then begin
       let pp_print_nfa_id = pp_print_nfa_id dfa.dfa_nfa_hash in
       Format.eprintf "@[<v 3>Args:";
       NfaStateTable.iter (fun id args ->
           Format.eprintf "@ @[<hv 3>state: %a" pp_print_nfa_id id;
           ArgTable.iter (fun arg i ->
               Format.eprintf "@ %a = %d" pp_print_arg arg i) args;
           Format.eprintf "@]") args_table;
       Format.eprintf "@]@."
     end;

     info.dfa_args <- args_table;

     (* Get final state *)
     match final with
       Some (clause_id, nid) ->
       info.dfa_stop_clause <- clause_id;
       info.dfa_stop_pos    <- pos;
       info.dfa_stop_args   <- NfaStateTable.find args_table nid
     | None ->
       ()

   (*
    * We just scanned a symbol c in NFA state nid.
    * Compute the forward epsilon closure, and return the frontier
    * with the actions we should take for each NFA state in the frontier.
    *)
   let rec close_prev nfa_hash table nid c closure frontier actions =
     if DfaStateCore.mem closure nid then
       frontier
     else
       let index, counters = NfaState.get nfa_hash nid in
       let closure = DfaStateCore.add closure nid in
       let action = table.(index).nfa_state_action in
       if !debug_lexgen then
         Format.eprintf "@[<v 3>close_prev:@ NFA state: %a@ Symbol: %a@ @[<hv 3>Closure:@ %a@]@ @[<hv 3>Frontier:@ %a@]@ @[<hv 3>NFA Action:@ %a@]@ @[<hv 3>Actions: %a@]@]@." (**)
           (pp_print_nfa_id nfa_hash) nid
           pp_print_char c
           (pp_print_dfa_set nfa_hash) closure
           (pp_print_frontier nfa_hash) frontier
           pp_print_nfa_action action
           pp_print_pre_actions actions;
       match action with
       (* Standard epsilon transitions *)
         NfaActionEpsilon nids ->
         let nids = List.map (fun index -> NfaState.create nfa_hash (index, counters)) nids in
         close_prev_list nfa_hash table nids c closure frontier actions

       (* Can only make progress if the current symbol is allowed *)
       | NfaActionLimitPrev (syms, nid) when IntSet.mem syms c ->
         let state = NfaState.create nfa_hash (nid, counters) in
         close_prev nfa_hash table state c closure frontier actions

       (* Arguments *)
       | NfaActionArgStart (id, nid) ->
         let actions = pre_action_add_arg_start actions 0 id in
         let state = NfaState.create nfa_hash (nid, counters) in
         close_prev nfa_hash table state c closure frontier actions

       | NfaActionArgStop (id, nid) ->
         let actions = pre_action_add_arg_stop actions 0 id in
         let state = NfaState.create nfa_hash (nid, counters) in
         close_prev nfa_hash table state c closure frontier actions

       | NfaActionArgSearch nid ->
         let actions = pre_action_add_arg_search actions 0 in
         let state = NfaState.create nfa_hash (nid, counters) in
         close_prev nfa_hash table state c closure frontier actions

       (* Counter operations *)
       | NfaActionResetCounter (i, nids) ->
         let counters = NfaStateCore.reset_counter counters i in
         let nids = List.map (fun index -> NfaState.create nfa_hash (index, counters)) nids in
         close_prev_list nfa_hash table nids c closure frontier actions

       | NfaActionIncrCounter (i, min, final, max, start) ->
         let nids = NfaStateCore.incr_counter counters i min final max start in
         let nids = List.map (NfaState.create nfa_hash) nids in
         close_prev_list nfa_hash table nids c closure frontier actions

       (* Reached a final state *)
       | NfaActionStop id ->
         let actions = pre_action_add_stop actions id in
         NfaStateTable.add frontier nid actions

       (* Reached the frontier, we can't make any more progress *)
       | NfaActionSymbol _
       | NfaActionAnySymbol _
       | NfaActionExceptSymbol _
       | NfaActionLimitNext _ ->
         NfaStateTable.add frontier nid actions

       (* Dead-ends *)
       | NfaActionLimitPrev _
       | NfaActionNone ->
         frontier

   and close_prev_list nfa_hash table nids c closure frontier actions =
     List.fold_left (fun frontier nid ->
         close_prev nfa_hash table nid c closure frontier actions) frontier nids

   (*
    * We are now processing symbol c in NFA state nid.
    * Search forward, computing the epsilon closure, until
    * we reach a transition on character c.
    *
    * pending: the actions that we take *only* if we eventually
    *    find a transition on character c.
    * committed: the actions that we will take no matter what.
    *)
   let rec close_next nfa_hash table nid c closure frontier actions =
     if DfaStateCore.mem closure nid then
       frontier
     else
       let closure = DfaStateCore.add closure nid in
       let index, counters = NfaState.get nfa_hash nid in
       let action = table.(index).nfa_state_action in
       if !debug_lexgen then
         Format.eprintf "@[<v 3>close_next:@ NFA state: %a@ Symbol: %a@ @[<hv 3>Closure:@ %a@]@ @[<hv 3>Frontier:@ %a@]@ @[<hv 3>NFA Action:@ %a@]@ @[<hv 3>Committed:@ %a@]@]@." (**)
           (pp_print_nfa_id nfa_hash) nid
           pp_print_char c
           (pp_print_dfa_set nfa_hash) closure
           (pp_print_frontier nfa_hash) frontier
           pp_print_nfa_action action
           pp_print_pre_actions actions;
       match action with
       (* These are the cases where we can make progress *)
         NfaActionSymbol (syms, nid) when IntSet.mem syms c ->
         let state = NfaState.create nfa_hash (nid, counters) in
         close_prev nfa_hash table state c DfaStateCore.empty frontier actions

       | NfaActionExceptSymbol (syms, nid) when not (c = eof || IntSet.mem syms c) ->
         let state = NfaState.create nfa_hash (nid, counters) in
         close_prev nfa_hash table state c DfaStateCore.empty frontier actions

       | NfaActionAnySymbol nid when c <> eof ->
         let state = NfaState.create nfa_hash (nid, counters) in
         close_prev nfa_hash table state c DfaStateCore.empty frontier actions

       | NfaActionLimitNext (syms, nid) when IntSet.mem syms c ->
         let state = NfaState.create nfa_hash (nid, counters) in
         close_next nfa_hash table state c closure frontier actions

       (* Standard epsilon transitions *)
       | NfaActionEpsilon nids ->
         let nids = List.map (fun index -> NfaState.create nfa_hash (index, counters)) nids in
         close_next_list nfa_hash table nids c closure frontier actions

       (* Arguments *)
       | NfaActionArgStart (id, nid) ->
         let actions = pre_action_add_arg_start actions (-1) id in
         let state = NfaState.create nfa_hash (nid, counters) in
         close_next nfa_hash table state c closure frontier actions

       | NfaActionArgStop (id, nid) ->
         let actions = pre_action_add_arg_stop actions (-1) id in
         let state = NfaState.create nfa_hash (nid, counters) in
         close_next nfa_hash table state c closure frontier actions

       | NfaActionArgSearch nid ->
         let actions = pre_action_add_arg_search actions (-1) in
         let state = NfaState.create nfa_hash (nid, counters) in
         close_next nfa_hash table state c closure frontier actions

       (* Counter operations *)
       | NfaActionResetCounter (i, nids) ->
         let counters = NfaStateCore.reset_counter counters i in
         let nids = List.map (fun index -> NfaState.create nfa_hash (index, counters)) nids in
         close_next_list nfa_hash table nids c closure frontier actions

       | NfaActionIncrCounter (i, min, final, max, start) ->
         let nids = NfaStateCore.incr_counter counters i min final max start in
         let nids = List.map (NfaState.create nfa_hash) nids in
         close_next_list nfa_hash table nids c closure frontier actions

       (* Dead-ends *)
       | NfaActionNone
       | NfaActionSymbol _
       | NfaActionAnySymbol _
       | NfaActionExceptSymbol _
       | NfaActionLimitNext _
       | NfaActionStop _ ->
         frontier

       (* These cases should never arise *)
       | NfaActionLimitPrev _ ->
         Format.eprintf "Illegal action: %a@." pp_print_nfa_action action;
         raise (Invalid_argument "close_next")

   and close_next_list nfa_hash table nids c closure frontier actions =
     List.fold_left (fun frontier nid ->
         close_next nfa_hash table nid c closure frontier actions) frontier nids

   (*
    * Compute the action table for each of the components of
    * the DFA state.
    *)
   let close_state dfa table nids c =
     let { dfa_search_states = search_states;
           dfa_nfa_hash = nfa_hash;
           _
         } = dfa
     in
     let final, actions =
       List.fold_left (fun final_actions nid ->
           let frontier =
             close_next nfa_hash table nid c DfaStateCore.empty NfaStateTable.empty pre_action_empty
           in
           if !debug_lexgen then
             Format.eprintf "@[<v 3>Frontier:@ %a@]@." (pp_print_frontier nfa_hash) frontier;
           NfaStateTable.fold (fun (final', actions) id action ->
               let { pre_action_final = final;
                     pre_action_args = args
                   } = action
               in
               let final =
                 match final', final with
                   Some (clause_id', _nid'), Some clause_id ->
                   let clause_id'' = Action.choose clause_id' clause_id in
                   if clause_id'' = clause_id' then
                     final'
                   else
                     Some (clause_id, id)
                 | Some _, None ->
                   final'
                 | None, Some clause_id ->
                   Some (clause_id, id)
                 | None, None ->
                   None
               in
               let action =
                 { dfa_action_src = nid;
                   dfa_action_args = args
                 }
               in
               let actions =
                           (*
                            * NOTE: currently we prefer states with smaller numbers,
                            * which will result in a shortest match in the search prefix.
                            * This works in many cases, but it may be wrong in general.
                            *)
                 NfaStateTable.filter_add actions id (fun action1 ->
                     match action1 with
                       Some action1 ->
                       let id1, _ = NfaState.get nfa_hash action1.dfa_action_src in
                       let id2, _ = NfaState.get nfa_hash nid in
                       if id1 < id2 then
                         action1
                       else
                         action
                     | None ->
                       action)
               in
               final, actions) final_actions frontier) (None, NfaStateTable.empty) nids
     in
     let () =
       if !debug_lexgen then
         let actions =
           { dfa_action_final = final;
             dfa_action_actions = actions
           }
         in
         Format.eprintf "@[<v 3>Computed actions:%a@]@." (pp_print_dfa_actions nfa_hash) actions
     in

      (*
       * If the state is final, and we have already scanned some text (not
       * including the initial bof),
       *    1. prune all states that correspond to the search
       *    2. prune all states that _came_ from the search, unless they
       *       are the final state we care about.
       *)
     let actions =
       match final with
         Some (_, id) when c <> bof ->
         (* Remove target states in the search *)
         let actions = NfaStateSet.fold NfaStateTable.remove actions search_states in
         (* Remove target states that came from the search *)
         NfaStateTable.fold (fun actions id' action ->
             if NfaStateSet.mem search_states action.dfa_action_src && id' <> id then
               NfaStateTable.remove actions id'
             else
               actions) actions actions
       | _ ->
         actions
     in
     { dfa_action_final = final;
       dfa_action_actions = actions
     }

   (*
    * The next state is the frontier.
    *)
   let close_next_state dfa table nids c =
     let actions = close_state dfa table nids c in
     let frontier =
       NfaStateTable.fold (fun frontier nid _ ->
           nid :: frontier) [] actions.dfa_action_actions
     in
     let nfa_hash = dfa.dfa_nfa_hash in
     if !debug_lex then
       Format.eprintf "@[<hv 3>NFA transition:@ @[<hv 3>current:@ %a@]@ symbol: %a@ @[<hv 3>next:@ %a@]@ @[<hv 3>actions:@ %a@]@." (**)
         (pp_print_dfa_set nfa_hash) nids
         pp_print_char c
         (pp_print_dfa_set nfa_hash) frontier
         (pp_print_dfa_actions nfa_hash) actions;
     frontier, actions

   (*
    * Get the argument values.
    *)
   type arg_info =
       ArgStart of int
     | ArgStop of int
     | ArgComplete of int * int

   let rec extend_args args len1 len2 =
     if len1 = len2 then
       args
     else
       extend_args ("" :: args) (succ len1) len2

   let dfa_args dfa_info group_select lexeme =
     let { dfa_start_pos = start;
           dfa_stop_pos = stop;
           dfa_stop_args = args;
           _
         } = dfa_info
     in
     let (group_offset, group_length) = group_select in

     (* Get the pairs of argument info *)
     let info, start_pos =
       ArgTable.fold
         (fun (info, start) arg pos ->
            match arg with
              | ArgLeft arg ->
                  let info =
                    IntTable.filter_add info arg
                      (fun entry ->
                         match entry with
                           | None ->
                               ArgStart pos
                           | Some (ArgStop right) ->
                               ArgComplete (pos, right)
                           | _ ->
                               raise (Invalid_argument "dfa_args:left")
                      ) in
                  info, start
              | ArgRight arg ->
                  let info =
                    IntTable.filter_add info arg
                      (fun entry ->
                         match entry with
                           | None ->
                               ArgStop pos
                           | Some (ArgStart left) ->
                               ArgComplete (left, pos)
                           | _ ->
                               raise (Invalid_argument "dfa_args:right")
                      ) in
                  info, start
              | ArgSearch ->
                  info, Some pos
         )
         (IntTable.empty, None)
         args in

     (* Flatten the arguments *)
     let args, _ =
       IntTable.fold
         (fun (args, len) arg entry ->
            if arg >= group_offset && arg < group_offset + group_length then
              let s =
                (* Get the argument text *)
                match entry with
                  | ArgComplete (left, right) ->
                      String.sub lexeme left (right - left)
                  | ArgStart left ->
                      String.sub lexeme left (stop - left)
                  | ArgStop right ->
                      String.sub lexeme start (right - start) in
              let args = 
                s :: extend_args args len (arg-group_offset) in
              args, succ (arg-group_offset)
            else
              args, len
         )
         ([], 0) info in
     start_pos, List.rev args

   (*
    * Add a state to the DFA.  It is initially empty.
    *)
   let dfa_find_state dfa nids =
     let { dfa_map    = map;
           dfa_length = dfa_id;
           dfa_states = states;
           _
         } = dfa
     in
     try DfaStateTable.find map nids with
       Not_found ->
       (* Make a new state *)
       let dfa_state =
         { dfa_state_index = dfa_id;
           dfa_state_set   = nids;
           dfa_state_delta = TransTable.empty
         }
       in
       let () =
         (* Add to the map *)
         dfa.dfa_map <- DfaStateTable.add map nids dfa_id
       in
       let () =
         (* Add to the state array *)
         let length = Array.length states in
         if dfa_id = length then
           let new_states = Array.make (length * 2) dfa_state in
           Array.blit states 0 new_states 0 length;
           dfa.dfa_states <- new_states
         else
           states.(dfa_id) <- dfa_state
       in
       dfa.dfa_length <- succ dfa_id;
       dfa_id

   (*
    * We are in DFA state i, processing symbol c, but we don't have
    * an entry in the transition table yet.
    *)
   let create_entry dfa dfa_state c =
     let { dfa_dfa_hash = dfa_hash;
           dfa_table = table;
           _
         } = dfa
     in
     let { dfa_state_set = nids;
           dfa_state_delta = delta;
           _
         } = dfa_state
     in
     let frontier, actions = close_next_state dfa table (DfaState.get dfa_hash nids) c in
     if frontier = [] && dfa_action_is_empty actions then
       dfa_state.dfa_state_delta <- TransTable.add delta c DfaNoTransition
     else
       let frontier = DfaState.create dfa_hash frontier in
       let dfa_id = dfa_find_state dfa frontier in
       let entry = DfaTransition (dfa_id, actions) in
       dfa_state.dfa_state_delta <- TransTable.add delta c entry

   (*
    * Transition function.
    * We are in DFA state dfa_id, processing symbol c.
    * Returns None if there is no transition.
    *)
   let rec dfa_delta dfa dfa_info dfa_state c =
     match TransTable.find dfa_state.dfa_state_delta c DfaUnknownTransition with
       DfaTransition (dfa_id, actions) ->
       if !debug_lex then
         Format.eprintf "State %d %a: symbol %a, goto %d@." (**)
           dfa_state.dfa_state_index
           (pp_print_dfa_set dfa.dfa_nfa_hash) (DfaState.get dfa.dfa_dfa_hash dfa_state.dfa_state_set)
           pp_print_char c dfa_id;
       dfa_eval_action dfa dfa_info actions;
       Some (dfa.dfa_states.(dfa_id))
     | DfaNoTransition ->
       if !debug_lex then
         Format.eprintf "State %d %a: no transition for symbol %a@." (**)
           dfa_state.dfa_state_index
           (pp_print_dfa_set dfa.dfa_nfa_hash) (DfaState.get dfa.dfa_dfa_hash dfa_state.dfa_state_set)
           pp_print_char c;
       None
     | DfaUnknownTransition ->
       if !debug_lex then
         Format.eprintf "State %d %a: computing transition on symbol %a@." (**)
           dfa_state.dfa_state_index
           (pp_print_dfa_set dfa.dfa_nfa_hash) (DfaState.get dfa.dfa_dfa_hash dfa_state.dfa_state_set)
           pp_print_char c;
       create_entry dfa dfa_state c;
       dfa_delta dfa dfa_info dfa_state c

   (*
    * Now the complete lexer.
    * We scan forward until no more transitions are possible.
    * Then return the last match.
    *)
   let lex dfa channel =
     let dfa_info =
       { dfa_stop_clause = -1;
         dfa_stop_pos    = 0;
         dfa_stop_args   = ArgTable.empty;
         dfa_start_pos   = 0;
         dfa_args        = NfaStateTable.empty;
         dfa_channel     = channel
       }
     in
     let rec loop dfa_state c =
       match dfa_delta dfa dfa_info dfa_state c with
         Some dfa_state ->
         loop dfa_state (Input.lex_next channel)
       | None ->
         ()
     in
     let dfa_state = dfa.dfa_states.(0) in
     let c = Input.lex_start channel in
     let () = loop dfa_state c in

     (* Now figure out what happened *)
     let { dfa_stop_clause = clause;
           dfa_stop_pos    = stop;
           _
         } = dfa_info
     in
         (*
          * If we did not get a match, return the channel to
          * the starting position, and raise an exception.
          *)
     if clause < 0 then
       begin
         Input.lex_stop channel 0;
         raise (Failure "Lm_lexer: lex: no clause matched")
       end;

         (*
          * We have the clause:
          *   1. Set the channel to the final position
          *   2. Get the entire string.
          *   3. Get the arguments.
          *)
     let action, group_info = IntTable.find dfa.dfa_action_table clause in
     let loc = Input.lex_loc channel stop in
     let lexeme = Input.lex_string channel stop in
     let _, args = dfa_args dfa_info group_info lexeme in
     Input.lex_stop channel stop;
     action, loc, lexeme, args

   (*
    * Return the input followed by a regular expression
    * terminator.
    *)
   let search dfa channel =
     let dfa_info =
       { dfa_stop_clause = -1;
         dfa_stop_pos    = 0;
         dfa_stop_args   = ArgTable.empty;
         dfa_start_pos   = 0;
         dfa_args        = NfaStateTable.empty;
         dfa_channel     = channel
       }
     in
     let rec loop dfa_state c =
       match dfa_delta dfa dfa_info dfa_state c with
         Some dfa_state ->
         loop dfa_state (Input.lex_next channel)
       | None ->
         ()
     in
     let dfa_state = dfa.dfa_states.(1) in
     let c = Input.lex_start channel in
     let () = loop dfa_state c in

     (* Now figure out what happened *)
     let { dfa_stop_clause = clause;
           dfa_stop_pos    = stop;
           _
         } = dfa_info
     in
         (*
          * If we did not get a match, return the channel to
          * the starting position, and raise an exception.
          *)
     if clause < 0 then begin
       Input.lex_stop channel 0;
       None
     end
     else
            (*
             * We have the clause:
             *   1. Set the channel to the final position
             *   2. Get the entire string.
             *   3. Get the arguments.
             *)
       let action, group_info = IntTable.find dfa.dfa_action_table clause in
       let loc = Input.lex_loc channel stop in
       let lexeme = Input.lex_string channel stop in
       let start, args = dfa_args dfa_info group_info lexeme in
       let skipped, lexeme =
         match start with
           Some pos ->
           String.sub lexeme 0 pos, String.sub lexeme pos (stop - pos)
         | None ->
           "", lexeme
       in
       Input.lex_stop channel stop;
       Some (action, loc, skipped, lexeme, args)

   (*
    * This is a slightly different version of searching,
    * where we skip to the EOF if there is no match.
    *
    * The reason for separating this is because it is a
    * hassle to deal with the 3 different return values
    * in the normal search function.
    *)
   let searchto dfa channel =
     let dfa_info =
       { dfa_stop_clause = -1;
         dfa_stop_pos    = 0;
         dfa_stop_args   = ArgTable.empty;
         dfa_start_pos   = 0;
         dfa_args        = NfaStateTable.empty;
         dfa_channel     = channel
       }
     in
     let rec loop dfa_state c =
       match dfa_delta dfa dfa_info dfa_state c with
         Some dfa_state ->
         loop dfa_state (Input.lex_next channel)
       | None ->
         ()
     in
     let dfa_state = dfa.dfa_states.(1) in
     let c = Input.lex_start channel in
     let () = loop dfa_state c in

     (* Now figure out what happened *)
     let { dfa_stop_clause = clause;
           dfa_stop_pos    = stop;
           _
         } = dfa_info
     in
         (*
          * If we did not get a match, return all the text to
          * the end of the channel.
          *)
     if clause < 0 then begin
       let stop = Input.lex_pos channel in
       if stop = 0 then begin
         Input.lex_stop channel stop;
         LexEOF
       end
       else
         let loc = Input.lex_loc channel stop in
         let lexeme = Input.lex_string channel stop in
         Input.lex_stop channel stop;
         LexSkipped (loc, lexeme)
     end
     else
            (*
             * We have the clause:
             *   1. Set the channel to the final position
             *   2. Get the entire string.
             *   3. Get the arguments.
             *)
       let action, group_info = IntTable.find dfa.dfa_action_table clause in
       let loc = Input.lex_loc channel stop in
       let lexeme = Input.lex_string channel stop in
       let start, args = dfa_args dfa_info group_info lexeme in
       let skipped, lexeme =
         match start with
           Some pos ->
           String.sub lexeme 0 pos, String.sub lexeme pos (stop - pos)
         | None ->
           "", lexeme
       in
       Input.lex_stop channel stop;
       LexMatched (action, loc, skipped, lexeme, args)

   (*
    * Just check for a string match.
    *)
   let matches dfa channel =
     match search dfa channel with
       None ->
       false
     | Some _ ->
       true

   (*
    * Create the DFA from a list of regular expressions.
    *)
   let create exp =
     let nfa = create_nfa exp in
     let () =
       if !debug_lexgen || !debug_lex then
         Format.eprintf "%a@." pp_print_nfa nfa
     in
     let { nfa_hash          = nfa_hash;
           nfa_table         = nfa_table;
           nfa_start         = nfa_start;
           nfa_actions       = actions;
           nfa_search_start  = nfa_search_start;
           nfa_search_states = nfa_search_states;
           _
         } = nfa
     in
     let dfa_hash = DfaState.create_state () in
     let nfa_start = DfaState.create dfa_hash [nfa_start] in
     let start =
       { dfa_state_index  = 0;
         dfa_state_set    = nfa_start;
         dfa_state_delta  = TransTable.empty
       }
     in
     let nfa_search_start = DfaState.create dfa_hash [nfa_search_start] in
     let search_start =
       { dfa_state_index   = 1;
         dfa_state_set     = nfa_search_start;
         dfa_state_delta   = TransTable.empty
       }
     in
     let map = DfaStateTable.empty in
     let map = DfaStateTable.add map nfa_start 0 in
     let map = DfaStateTable.add map nfa_search_start 1 in
     let states = Array.make 64 start in
     states.(1) <- search_start;

     { dfa_states        = states;
       dfa_length        = 2;
       dfa_map           = map;
       dfa_table         = nfa_table;
       dfa_action_table  = actions;
       dfa_nfa_hash      = nfa_hash;
       dfa_dfa_hash      = dfa_hash;
       dfa_search_states = nfa_search_states
     }

   (*
    * External functions.
    *)
   let empty =
     { lex_exp = empty_exp;
       lex_dfa = None
     }

   let add_clause lex action s =
     let arity, exp = add_clause_exp lex.lex_exp action s in
     let lex = { lex_exp = exp; lex_dfa = None } in
     arity, lex

   let remove_clause lex action =
     { lex_exp = remove_clause_exp lex.lex_exp action;
       lex_dfa = None
     }

   (*
    * Take the union of two lexers.
    * We assume that if we have seen a clause before,
    * then we have seen all the rest of the clauses too.
    *)
   let union info1 info2 =
     let { lex_exp = exp1 ; _} = info1 in
     let { lex_exp = exp2 ; _} = info2 in
     (* Catch degenerate cases first *)
     match exp1.exp_clauses, exp2.exp_clauses with
       [], _ -> info2
     | _, [] -> info1
     | _ ->
       let changed, exp = union_exp exp1 exp2 in
       if changed then
         { lex_exp = exp; lex_dfa = None }
       else
         info1

   let dfa_of_info info =
     match info.lex_dfa with
       Some dfa ->
       dfa
     | None ->
       let dfa = create info.lex_exp in
       info.lex_dfa <- Some dfa;
       dfa

   let lex info channel =
     lex (dfa_of_info info) channel

   let search info channel =
     search (dfa_of_info info) channel

   let searchto info channel =
     searchto (dfa_of_info info) channel

   let matches info channel =
     matches (dfa_of_info info) channel

   let compile info =
     ignore (dfa_of_info info)

   let pp_print_lexer buf info =
     let { lex_exp = exp ; _} = info in
     let dfa = dfa_of_info info in
     Format.fprintf buf "@[<v 0>@[<hv 3>Lexer:@ %a@]" pp_print_exp exp;
     Format.fprintf buf "@ @[<hv 3>NFA:";
     Array.iter (fun nfa_state -> Format.fprintf buf "@ %a" pp_print_nfa_state nfa_state) dfa.dfa_table;
     Format.fprintf buf "@]@]"

   let hash info =
     Hashtbl.hash_param max_int max_int info.lex_exp
end

(************************************************************************
 * Simplified Str replacement.
*)
module LmAction =
struct
   type action = int

   let pp_print_action = Lm_printf.pp_print_int

   let hash i = i
   let compare (i : int) (j : int) =
      if i < j then
         -1
      else if i > j then
         1
      else
         0

   let choose = min
end

module LmLexer = MakeLexer (Lm_channel.LexerInput) (LmAction)

module LmStr =
struct
   type t = LmLexer.t

   (*
    * Create a regular expression.
    *)
   let regexp s =
      snd (LmLexer.add_clause LmLexer.empty 0 s)

   (*
    * Perform the match.
    *)
   let string_match info s off =
      let input = Lm_channel.of_substring s off (String.length s - off) in
         try
            let _ = LmLexer.lex info input in
               true
         with
            Failure _ ->
               false
end
