This commit is contained in:
parent
aa2ff7b2f0
commit
2f3113f55d
11742 changed files with 1223940 additions and 0 deletions
835
unikernel/duniverse/ocaml-re/lib/compile.ml
Normal file
835
unikernel/duniverse/ocaml-re/lib/compile.ml
Normal file
|
|
@ -0,0 +1,835 @@
|
|||
open Import
|
||||
|
||||
let rec iter n f v = if Int.equal n 0 then v else iter (n - 1) f (f v)
|
||||
|
||||
module Idx : sig
|
||||
type t [@@immediate]
|
||||
|
||||
val unknown : t
|
||||
val make_break : Automata.Idx.t -> t
|
||||
val of_idx : Automata.Idx.t -> t
|
||||
val is_idx : t -> bool
|
||||
val is_break : t -> bool
|
||||
val is_unknown : t -> bool
|
||||
val idx : t -> int
|
||||
val break_idx : t -> int
|
||||
end = struct
|
||||
type t = int
|
||||
|
||||
let unknown = -2
|
||||
let break = -3
|
||||
let of_idx (x : Automata.Idx.t) = Automata.Idx.to_int x [@@inline always]
|
||||
let is_idx t = t >= 0 [@@inline always]
|
||||
let is_break x = x <= break [@@inline always]
|
||||
let is_unknown x = x = unknown [@@inline always]
|
||||
let idx t = t [@@inline always]
|
||||
let make_break (idx : Automata.Idx.t) = -5 - Automata.Idx.to_int idx [@@inline always]
|
||||
let break_idx t = (t + 5) * -1 [@@inline always]
|
||||
end
|
||||
|
||||
type match_info =
|
||||
| Match of Group.t
|
||||
| Failed
|
||||
| Running of { no_match_starts_before : int }
|
||||
|
||||
type state_info =
|
||||
{ idx : Idx.t
|
||||
; (* Index of the current position in the position table.
|
||||
Not yet computed transitions point to a dummy state where
|
||||
[idx] is set to [unknown];
|
||||
If [idx] is set to [break] for states that either always
|
||||
succeed or always fail. *)
|
||||
mutable final : (Category.t * (Automata.Idx.t * Automata.Status.t)) list
|
||||
; (* Mapping from the category of the next character to
|
||||
- the index where the next position should be saved
|
||||
- possibly, the list of marks (and the corresponding indices)
|
||||
corresponding to the best match *)
|
||||
desc : Automata.State.t (* Description of this state of the automata *)
|
||||
}
|
||||
|
||||
(* Thread-safety: we use double-checked locking to access field [final]. *)
|
||||
|
||||
(* A state [t] is a pair composed of some information about the
|
||||
state [state_info] and a transition table [t array], indexed by
|
||||
color. For performance reason, to avoid an indirection, we manually
|
||||
unbox the transition table: we allocate a single array, with the
|
||||
state information at index 0, followed by the transitions. *)
|
||||
module State : sig
|
||||
type t
|
||||
|
||||
val make : ncol:int -> state_info -> t
|
||||
val make_break : state_info -> t
|
||||
val get_info : t -> state_info
|
||||
val follow_transition : t -> color:Cset.c -> t
|
||||
val set_transition : t -> color:Cset.c -> t -> unit
|
||||
val is_unknown_transition : t -> color:Cset.c -> bool
|
||||
end = struct
|
||||
type t = Table of t array [@@unboxed]
|
||||
|
||||
(* Thread-safety:
|
||||
We store the state information at index 0. For other elements
|
||||
of the transition table, which are lazily computed, we use
|
||||
double-checked locking. *)
|
||||
|
||||
let get_info (Table st) : state_info = Obj.magic (Array.unsafe_get st 0)
|
||||
[@@inline always]
|
||||
;;
|
||||
|
||||
let set_info (Table st) (info : state_info) = st.(0) <- Obj.magic info
|
||||
|
||||
let follow_transition (Table st) ~color = Array.unsafe_get st (1 + Cset.to_int color)
|
||||
[@@inline always]
|
||||
;;
|
||||
|
||||
let set_transition (Table st) ~color st' = st.(1 + Cset.to_int color) <- st'
|
||||
|
||||
let is_unknown_transition st ~color =
|
||||
let st' = follow_transition st ~color in
|
||||
let info = get_info st' in
|
||||
Idx.is_unknown info.idx
|
||||
;;
|
||||
|
||||
let dummy (info : state_info) = Table [| Obj.magic info |]
|
||||
let unknown_state = dummy { idx = Idx.unknown; final = []; desc = Automata.State.dummy }
|
||||
|
||||
let make ~ncol state =
|
||||
let st = Table (Array.make (ncol + 1) unknown_state) in
|
||||
set_info st state;
|
||||
st
|
||||
;;
|
||||
|
||||
let make_break state = Table [| Obj.magic state |]
|
||||
end
|
||||
|
||||
(* Automata (compiled regular expression) *)
|
||||
type re =
|
||||
{ initial : Automata.expr
|
||||
; (* The whole regular expression *)
|
||||
mutable initial_states : (Category.t * State.t) list
|
||||
; (* Initial states, indexed by initial category *)
|
||||
colors : Color_map.Table.t
|
||||
; (* Color table *)
|
||||
color_repr : Color_map.Repr.t
|
||||
; (* Table from colors to one character of this color *)
|
||||
ncolor : int
|
||||
; (* Number of colors. *)
|
||||
lnl : Cset.c
|
||||
; (* Color of the last newline. [Cset.null_char] if unnecessary *)
|
||||
tbl : Automata.Working_area.t
|
||||
; (* Temporary table used to compute the first available index
|
||||
when computing a new state *)
|
||||
states : State.t Automata.State.Table.t
|
||||
; (* States of the deterministic automata *)
|
||||
group_names : (string * int) list
|
||||
; (* Named groups in the regular expression *)
|
||||
group_count : int
|
||||
; (* Number of groups in the regular expression *)
|
||||
mutex : Mutex.t
|
||||
}
|
||||
|
||||
(* Thread-safety:
|
||||
We use double-checked locking to access field [initial_states]. The
|
||||
state table [states] and the working area [tbl] are only accessed
|
||||
with the mutex [mutex] locked.
|
||||
The working area is shared between all threads. This might be
|
||||
inefficient if many threads are updating the automaton. It seems
|
||||
complicated to manage a working area per domain and per regular
|
||||
expression. So, if this becomes an issue, it might just be simpler
|
||||
to allocate a fresh working area whenever needed.
|
||||
*)
|
||||
|
||||
let pp_re ch re = Automata.pp ch re.initial
|
||||
let group_count re = re.group_count
|
||||
let group_names re = re.group_names
|
||||
|
||||
module Positions = struct
|
||||
(* Information used during matching *)
|
||||
type t =
|
||||
{ mutable positions : int array
|
||||
; (* Array of mark positions
|
||||
The mark are off by one for performance reasons *)
|
||||
mutable length : int
|
||||
}
|
||||
|
||||
let empty = { positions = [||]; length = 0 }
|
||||
let length t = t.length
|
||||
let unsafe_set t idx pos = Array.unsafe_set t.positions idx pos
|
||||
|
||||
let rec resize idx t =
|
||||
t.length <- 2 * t.length;
|
||||
if idx >= t.length
|
||||
then resize idx t
|
||||
else (
|
||||
let pos = t.positions in
|
||||
t.positions <- Array.make t.length 0;
|
||||
Array.blit pos 0 t.positions 0 (Array.length pos))
|
||||
;;
|
||||
|
||||
let set t idx pos =
|
||||
if idx >= length t then resize idx t;
|
||||
unsafe_set t idx pos
|
||||
;;
|
||||
|
||||
let all t = t.positions
|
||||
let first t = t.positions.(0)
|
||||
|
||||
let make ~groups re =
|
||||
if groups
|
||||
then (
|
||||
(* We initialize this table with a reasonable size. The required
|
||||
size may change when the automaton gets updated. So we are
|
||||
always checking whether it is large enough before modifying it. *)
|
||||
let length = Automata.Working_area.index_count re.tbl + 1 in
|
||||
{ positions = Array.make length 0; length })
|
||||
else empty
|
||||
;;
|
||||
end
|
||||
|
||||
(****)
|
||||
|
||||
let category re ~color =
|
||||
if Cset.equal_c color Cset.null_char
|
||||
then Category.inexistant (* Special category for the last newline *)
|
||||
else if Cset.equal_c color re.lnl
|
||||
then Category.(lastnewline ++ newline ++ not_letter)
|
||||
else Category.from_char (Color_map.Repr.repr re.color_repr color)
|
||||
;;
|
||||
|
||||
(****)
|
||||
|
||||
let find_state re desc =
|
||||
try Automata.State.Table.find re.states desc with
|
||||
| Not_found ->
|
||||
let st =
|
||||
let break_state =
|
||||
match Automata.State.status_no_mutex desc with
|
||||
| Running -> false
|
||||
| Failed | Match _ -> true
|
||||
in
|
||||
let st =
|
||||
{ idx =
|
||||
(let idx = Automata.State.idx desc in
|
||||
if break_state then Idx.make_break idx else Idx.of_idx idx)
|
||||
; final = []
|
||||
; desc
|
||||
}
|
||||
in
|
||||
if break_state then State.make_break st else State.make ~ncol:re.ncolor st
|
||||
in
|
||||
Automata.State.Table.add re.states desc st;
|
||||
st
|
||||
;;
|
||||
|
||||
(**** Match with marks ****)
|
||||
|
||||
let delta re cat ~color st = Automata.delta re.tbl cat color st.desc
|
||||
|
||||
let validate re (s : string) ~pos st =
|
||||
let color = Color_map.Table.get re.colors s.[pos] in
|
||||
Mutex.lock re.mutex;
|
||||
if State.is_unknown_transition st ~color
|
||||
then (
|
||||
let st' =
|
||||
let desc' =
|
||||
let cat = category re ~color in
|
||||
delta re cat ~color (State.get_info st)
|
||||
in
|
||||
find_state re desc'
|
||||
in
|
||||
State.set_transition st ~color st');
|
||||
Mutex.unlock re.mutex
|
||||
;;
|
||||
|
||||
let next colors st s pos =
|
||||
State.follow_transition st ~color:(Color_map.Table.get colors (String.unsafe_get s pos))
|
||||
;;
|
||||
|
||||
let rec loop re ~colors ~positions s ~pos ~last st0 st =
|
||||
if pos < last
|
||||
then (
|
||||
let st' = next colors st s pos in
|
||||
let idx = (State.get_info st').idx in
|
||||
if Idx.is_idx idx
|
||||
then
|
||||
if Idx.idx idx < Positions.length positions
|
||||
then (
|
||||
Positions.unsafe_set positions (Idx.idx idx) pos;
|
||||
loop re ~colors ~positions s ~pos:(pos + 1) ~last st' st')
|
||||
else (
|
||||
(* Resize position array *)
|
||||
Positions.set positions (Idx.idx idx) pos;
|
||||
loop re ~colors ~positions s ~pos:(pos + 1) ~last st' st')
|
||||
else if Idx.is_break idx
|
||||
then (
|
||||
Positions.set positions (Idx.break_idx idx) pos;
|
||||
st')
|
||||
else (
|
||||
(* Unknown *)
|
||||
validate re s ~pos st0;
|
||||
loop re ~colors ~positions s ~pos ~last st0 st0))
|
||||
else st
|
||||
;;
|
||||
|
||||
let rec loop_no_mark re ~colors s ~pos ~last st0 st =
|
||||
if pos < last
|
||||
then (
|
||||
let st' = next colors st s pos in
|
||||
let idx = (State.get_info st').idx in
|
||||
if Idx.is_idx idx
|
||||
then loop_no_mark re ~colors s ~pos:(pos + 1) ~last st' st'
|
||||
else if Idx.is_break idx
|
||||
then st'
|
||||
else (
|
||||
(* Unknown *)
|
||||
validate re s ~pos st0;
|
||||
loop_no_mark re ~colors s ~pos ~last st0 st0))
|
||||
else st
|
||||
;;
|
||||
|
||||
let final re st cat =
|
||||
try List.assq cat st.final with
|
||||
| Not_found ->
|
||||
Mutex.lock re.mutex;
|
||||
let res =
|
||||
try List.assq cat st.final with
|
||||
| Not_found ->
|
||||
let st' = delta re cat ~color:Cset.null_char st in
|
||||
let res = Automata.State.idx st', Automata.State.status_no_mutex st' in
|
||||
st.final <- (cat, res) :: st.final;
|
||||
res
|
||||
in
|
||||
Mutex.unlock re.mutex;
|
||||
res
|
||||
;;
|
||||
|
||||
let find_initial_state re cat =
|
||||
try List.assq cat re.initial_states with
|
||||
| Not_found ->
|
||||
Mutex.lock re.mutex;
|
||||
let res =
|
||||
try List.assq cat re.initial_states with
|
||||
| Not_found ->
|
||||
let st = find_state re (Automata.State.create cat re.initial) in
|
||||
re.initial_states <- (cat, st) :: re.initial_states;
|
||||
st
|
||||
in
|
||||
Mutex.unlock re.mutex;
|
||||
res
|
||||
;;
|
||||
|
||||
let get_color re (s : string) pos =
|
||||
if pos < 0
|
||||
then Cset.null_char
|
||||
else (
|
||||
let slen = String.length s in
|
||||
if pos >= slen
|
||||
then Cset.null_char
|
||||
else if pos = slen - 1
|
||||
&& (not (Cset.equal_c re.lnl Cset.null_char))
|
||||
&& Char.equal (String.unsafe_get s pos) '\n'
|
||||
then (* Special case for the last newline *)
|
||||
re.lnl
|
||||
else Color_map.Table.get re.colors (String.unsafe_get s pos))
|
||||
;;
|
||||
|
||||
let rec handle_last_newline re positions ~pos st ~groups =
|
||||
let st' = State.follow_transition st ~color:re.lnl in
|
||||
let info = State.get_info st' in
|
||||
if Idx.is_idx info.idx
|
||||
then (
|
||||
if groups then Positions.set positions (Idx.idx info.idx) pos;
|
||||
st')
|
||||
else if Idx.is_break info.idx
|
||||
then (
|
||||
if groups then Positions.set positions (Idx.break_idx info.idx) pos;
|
||||
st')
|
||||
else (
|
||||
(* Unknown *)
|
||||
let color = re.lnl in
|
||||
Mutex.lock re.mutex;
|
||||
if State.is_unknown_transition st ~color
|
||||
then (
|
||||
let st' =
|
||||
let desc =
|
||||
let cat = category re ~color in
|
||||
let real_c = Color_map.Table.get re.colors '\n' in
|
||||
delta re cat ~color:real_c (State.get_info st)
|
||||
in
|
||||
find_state re desc
|
||||
in
|
||||
State.set_transition st ~color st');
|
||||
Mutex.unlock re.mutex;
|
||||
handle_last_newline re positions ~pos st ~groups)
|
||||
;;
|
||||
|
||||
let rec scan_str re positions (s : string) initial_state ~last ~pos ~groups =
|
||||
if last = String.length s
|
||||
&& (not (Cset.equal_c re.lnl Cset.null_char))
|
||||
&& last > pos
|
||||
&& Char.equal (String.get s (last - 1)) '\n'
|
||||
then (
|
||||
let last = last - 1 in
|
||||
let st = scan_str re positions ~pos s initial_state ~last ~groups in
|
||||
if Idx.is_break (State.get_info st).idx
|
||||
then st
|
||||
else handle_last_newline re positions ~pos:last st ~groups)
|
||||
else if groups
|
||||
then loop re ~colors:re.colors ~positions s ~pos ~last initial_state initial_state
|
||||
else loop_no_mark re ~colors:re.colors s ~pos ~last initial_state initial_state
|
||||
;;
|
||||
|
||||
(* This function adds a final boundary check on the input.
|
||||
This is useful to indicate that the output failed because
|
||||
of insufficient input, or to verify that the output actually
|
||||
matches for regex that have boundary conditions with respect
|
||||
to the input string.
|
||||
*)
|
||||
let final_boundary_check re positions ~last ~slen s state_info ~groups =
|
||||
let idx, res =
|
||||
let final_cat =
|
||||
Category.(
|
||||
search_boundary
|
||||
++ if last = slen then inexistant else category re ~color:(get_color re s last))
|
||||
in
|
||||
final re state_info final_cat
|
||||
in
|
||||
(match groups, res with
|
||||
| true, Match _ -> Positions.set positions (Automata.Idx.to_int idx) last
|
||||
| _ -> ());
|
||||
res
|
||||
;;
|
||||
|
||||
let make_match_str re positions ~len ~groups ~partial s ~pos =
|
||||
let slen = String.length s in
|
||||
let last = if len = -1 then slen else pos + len in
|
||||
let st =
|
||||
let initial_state =
|
||||
let initial_cat =
|
||||
Category.(
|
||||
search_boundary
|
||||
++ if pos = 0 then inexistant else category re ~color:(get_color re s (pos - 1)))
|
||||
in
|
||||
find_initial_state re initial_cat
|
||||
in
|
||||
scan_str re positions s initial_state ~pos ~last ~groups
|
||||
in
|
||||
let state_info = State.get_info st in
|
||||
if Idx.is_break state_info.idx || (partial && not groups)
|
||||
then Automata.State.status re.mutex state_info.desc
|
||||
else if partial && groups
|
||||
then (
|
||||
match Automata.State.status re.mutex state_info.desc with
|
||||
| (Match _ | Failed) as status -> status
|
||||
| Running ->
|
||||
(* This could be because it's still not fully matched, or it
|
||||
could be that because we need to run special end of input
|
||||
checks. *)
|
||||
(match final_boundary_check re positions ~last ~slen s state_info ~groups with
|
||||
| Match _ as status -> status
|
||||
| Failed | Running ->
|
||||
(* A failure here just means that we need more data, i.e.
|
||||
it's a partial match. *)
|
||||
Running))
|
||||
else final_boundary_check re positions ~last ~slen s state_info ~groups
|
||||
;;
|
||||
|
||||
module Stream = struct
|
||||
type nonrec t =
|
||||
{ state : State.t
|
||||
; re : re
|
||||
}
|
||||
|
||||
type 'a feed =
|
||||
| Ok of 'a
|
||||
| No_match
|
||||
|
||||
let create re =
|
||||
let category = Category.(search_boundary ++ inexistant) in
|
||||
let state = find_initial_state re category in
|
||||
{ state; re }
|
||||
;;
|
||||
|
||||
let feed t s ~pos ~len =
|
||||
(* TODO bound checks? *)
|
||||
let last = pos + len in
|
||||
let state = loop_no_mark t.re ~colors:t.re.colors s ~last ~pos t.state t.state in
|
||||
let info = State.get_info state in
|
||||
if Idx.is_break info.idx
|
||||
&&
|
||||
match Automata.State.status t.re.mutex info.desc with
|
||||
| Failed -> true
|
||||
| Match _ | Running -> false
|
||||
then No_match
|
||||
else Ok { t with state }
|
||||
;;
|
||||
|
||||
let finalize t s ~pos ~len =
|
||||
(* TODO bound checks? *)
|
||||
let last = pos + len in
|
||||
let state = scan_str t.re Positions.empty s t.state ~last ~pos ~groups:false in
|
||||
let info = State.get_info state in
|
||||
match
|
||||
let _idx, res =
|
||||
let final_cat = Category.(search_boundary ++ inexistant) in
|
||||
final t.re info final_cat
|
||||
in
|
||||
res
|
||||
with
|
||||
| Running | Failed -> false
|
||||
| Match _ -> true
|
||||
;;
|
||||
|
||||
module Group = struct
|
||||
type nonrec t =
|
||||
{ t : t
|
||||
; positions : Positions.t
|
||||
; slices : Slice.L.t
|
||||
; abs_pos : int
|
||||
; first_match_pos : int
|
||||
}
|
||||
|
||||
let no_match_starts_before t = t.first_match_pos
|
||||
|
||||
let create t =
|
||||
{ t
|
||||
; positions = Positions.make ~groups:true t.re
|
||||
; slices = []
|
||||
; abs_pos = 0
|
||||
; first_match_pos = 0
|
||||
}
|
||||
;;
|
||||
|
||||
module Match = struct
|
||||
type t =
|
||||
{ pmarks : Pmark.Set.t
|
||||
; slices : Slice.L.t
|
||||
; marks : Mark_infos.t
|
||||
; positions : int array
|
||||
; start_pos : int
|
||||
}
|
||||
|
||||
let test_mark t mark = Pmark.Set.mem mark t.pmarks
|
||||
|
||||
let get t i =
|
||||
Mark_infos.offset t.marks i
|
||||
|> Option.map (fun (start, stop) ->
|
||||
let start = t.positions.(start) - t.start_pos in
|
||||
let stop = t.positions.(stop) - t.start_pos in
|
||||
Slice.L.get_substring t.slices ~start ~stop)
|
||||
;;
|
||||
|
||||
let make ~start_pos ~pmarks ~slices ~marks ~positions =
|
||||
let positions = Positions.all positions in
|
||||
{ pmarks; slices; positions; marks; start_pos }
|
||||
;;
|
||||
end
|
||||
|
||||
let rec loop re ~abs_pos ~colors ~positions s ~pos ~last st0 st =
|
||||
if pos < last
|
||||
then (
|
||||
let st' = next colors st s pos in
|
||||
let idx = (State.get_info st').idx in
|
||||
if Idx.is_idx idx
|
||||
then
|
||||
if Idx.idx idx < Positions.length positions
|
||||
then (
|
||||
Positions.unsafe_set positions (Idx.idx idx) (abs_pos + pos);
|
||||
loop re ~abs_pos ~colors ~positions s ~pos:(pos + 1) ~last st' st')
|
||||
else (
|
||||
(* Resize position array *)
|
||||
Positions.set positions (Idx.idx idx) (abs_pos + pos);
|
||||
loop re ~abs_pos ~colors ~positions s ~pos:(pos + 1) ~last st' st')
|
||||
else if Idx.is_break idx
|
||||
then (
|
||||
Positions.set positions (Idx.break_idx idx) (abs_pos + pos);
|
||||
st')
|
||||
else (
|
||||
(* Unknown *)
|
||||
validate re s ~pos st0;
|
||||
loop re ~abs_pos ~colors ~positions s ~pos ~last st0 st0))
|
||||
else st
|
||||
;;
|
||||
|
||||
let feed ({ t; positions; slices; abs_pos; first_match_pos = _ } as tt) s ~pos ~len =
|
||||
let state =
|
||||
(* TODO bound checks? *)
|
||||
let last = pos + len in
|
||||
loop t.re ~abs_pos ~colors:t.re.colors s ~positions ~last ~pos t.state t.state
|
||||
in
|
||||
let info = State.get_info state in
|
||||
if Idx.is_break info.idx
|
||||
&&
|
||||
match Automata.State.status t.re.mutex info.desc with
|
||||
| Failed -> true
|
||||
| Match _ | Running -> false
|
||||
then No_match
|
||||
else (
|
||||
let t = { t with state } in
|
||||
let slices = { Slice.s; pos; len } :: slices in
|
||||
let first_match_pos = Positions.first positions in
|
||||
let slices = Slice.L.drop_rev slices (first_match_pos - tt.first_match_pos) in
|
||||
let abs_pos = abs_pos + len in
|
||||
Ok { tt with t; slices; abs_pos; first_match_pos })
|
||||
;;
|
||||
|
||||
let finalize
|
||||
({ t; positions; slices; abs_pos; first_match_pos = _ } as tt)
|
||||
s
|
||||
~pos
|
||||
~len
|
||||
: Match.t feed
|
||||
=
|
||||
(* TODO bound checks? *)
|
||||
let last = pos + len in
|
||||
let info =
|
||||
let state =
|
||||
loop t.re ~abs_pos ~colors:t.re.colors s ~positions ~last ~pos t.state t.state
|
||||
in
|
||||
State.get_info state
|
||||
in
|
||||
match
|
||||
match Automata.State.status t.re.mutex info.desc with
|
||||
| (Match _ | Failed) as s -> s
|
||||
| Running ->
|
||||
let idx, res =
|
||||
let final_cat = Category.(search_boundary ++ inexistant) in
|
||||
final t.re info final_cat
|
||||
in
|
||||
(match res with
|
||||
| Running | Failed -> ()
|
||||
| Match _ -> Positions.set positions (Automata.Idx.to_int idx) (abs_pos + last));
|
||||
res
|
||||
with
|
||||
| Running | Failed -> No_match
|
||||
| Match (marks, pmarks) ->
|
||||
let first_match_position = Positions.first positions in
|
||||
let slices =
|
||||
let slices =
|
||||
let slices = { Slice.s; pos; len } :: slices in
|
||||
Slice.L.drop_rev slices (first_match_position - tt.first_match_pos)
|
||||
in
|
||||
List.rev slices
|
||||
in
|
||||
Ok (Match.make ~start_pos:first_match_position ~pmarks ~marks ~slices ~positions)
|
||||
;;
|
||||
end
|
||||
end
|
||||
|
||||
let match_str_no_bounds ~groups ~partial re s ~pos ~len =
|
||||
let positions = Positions.make ~groups re in
|
||||
match make_match_str re positions ~len ~groups ~partial s ~pos with
|
||||
| Match (marks, pmarks) ->
|
||||
Match
|
||||
(Group.create s marks pmarks ~gpos:(Positions.all positions) ~gcount:re.group_count)
|
||||
| Failed -> Failed
|
||||
| Running ->
|
||||
let no_match_starts_before = if groups then Positions.first positions else 0 in
|
||||
Running { no_match_starts_before }
|
||||
;;
|
||||
|
||||
let match_str_p re s ~pos ~len =
|
||||
if pos < 0 || len < -1 || pos + len > String.length s
|
||||
then invalid_arg "Re.exec: out of bounds";
|
||||
match make_match_str re Positions.empty ~len ~groups:false ~partial:false s ~pos with
|
||||
| Match _ -> true
|
||||
| _ -> false
|
||||
;;
|
||||
|
||||
let match_str ~groups ~partial re s ~pos ~len =
|
||||
if pos < 0 || len < -1 || pos + len > String.length s
|
||||
then invalid_arg "Re.exec: out of bounds";
|
||||
match_str_no_bounds ~groups ~partial re s ~pos ~len
|
||||
;;
|
||||
|
||||
let mk_re ~initial ~colors ~color_repr ~ncolor ~lnl ~group_names ~group_count =
|
||||
{ initial
|
||||
; initial_states = []
|
||||
; colors
|
||||
; color_repr
|
||||
; ncolor
|
||||
; lnl
|
||||
; tbl = Automata.Working_area.create ()
|
||||
; states = Automata.State.Table.create 97
|
||||
; group_names
|
||||
; group_count
|
||||
; mutex = Mutex.create ()
|
||||
}
|
||||
;;
|
||||
|
||||
(**** Compilation ****)
|
||||
|
||||
module A = Automata
|
||||
|
||||
let enforce_kind ids kind kind' cr =
|
||||
match kind, kind' with
|
||||
| `First, `First -> cr
|
||||
| `First, k -> A.seq ids k cr (A.eps ids)
|
||||
| _ -> cr
|
||||
;;
|
||||
|
||||
type context =
|
||||
{ ids : A.Ids.t
|
||||
; kind : A.Sem.t
|
||||
; ign_group : bool
|
||||
; greedy : A.Rep_kind.t
|
||||
; pos : A.Mark.t ref
|
||||
; names : (string * int) list ref
|
||||
; cache : Cset.t Cset.CSetMap.t ref
|
||||
; colors : Color_map.Table.t
|
||||
}
|
||||
|
||||
let trans_set cache (cm : Color_map.Table.t) s =
|
||||
match Cset.one_char s with
|
||||
| Some i -> Cset.csingle (Color_map.Table.get_char cm i)
|
||||
| None ->
|
||||
let v = Cset.hash s, s in
|
||||
(try Cset.CSetMap.find v !cache with
|
||||
| Not_found ->
|
||||
let l = Color_map.Table.translate_colors cm s in
|
||||
cache := Cset.CSetMap.add v l !cache;
|
||||
l)
|
||||
;;
|
||||
|
||||
let make_repeater ids cr kind greedy =
|
||||
match greedy with
|
||||
| `Greedy -> fun rem -> A.alt ids [ A.seq ids kind (A.rename ids cr) rem; A.eps ids ]
|
||||
| `Non_greedy ->
|
||||
fun rem -> A.alt ids [ A.eps ids; A.seq ids kind (A.rename ids cr) rem ]
|
||||
;;
|
||||
|
||||
(* XXX should probably compute a category mask *)
|
||||
let rec translate
|
||||
({ ids; kind; ign_group; greedy; pos; names; cache; colors } as ctx)
|
||||
(ast : Ast.no_case)
|
||||
=
|
||||
match ast with
|
||||
| Set s -> A.cst ids (trans_set cache colors s), kind
|
||||
| Sequence l -> trans_seq ctx l, kind
|
||||
| Ast (Alternative l) ->
|
||||
(match Ast.merge_sequences l with
|
||||
| [ r' ] ->
|
||||
let cr, kind' = translate ctx r' in
|
||||
enforce_kind ids kind kind' cr, kind
|
||||
| merged_sequences ->
|
||||
( A.alt
|
||||
ids
|
||||
(List.map merged_sequences ~f:(fun r' ->
|
||||
let cr, kind' = translate ctx r' in
|
||||
enforce_kind ids kind kind' cr))
|
||||
, kind ))
|
||||
| Repeat (r', i, j) ->
|
||||
let cr, kind' = translate ctx r' in
|
||||
let rem =
|
||||
match j with
|
||||
| None -> A.rep ids greedy kind' cr
|
||||
| Some j ->
|
||||
let f = make_repeater ids cr kind' greedy in
|
||||
iter (j - i) f (A.eps ids)
|
||||
in
|
||||
iter i (fun rem -> A.seq ids kind' (A.rename ids cr) rem) rem, kind
|
||||
| Beg_of_line -> A.after ids Category.(inexistant ++ newline), kind
|
||||
| End_of_line -> A.before ids Category.(inexistant ++ newline), kind
|
||||
| Beg_of_word ->
|
||||
( A.seq
|
||||
ids
|
||||
`First
|
||||
(A.after ids Category.(inexistant ++ not_letter))
|
||||
(A.before ids Category.letter)
|
||||
, kind )
|
||||
| End_of_word ->
|
||||
( A.seq
|
||||
ids
|
||||
`First
|
||||
(A.after ids Category.letter)
|
||||
(A.before ids Category.(inexistant ++ not_letter))
|
||||
, kind )
|
||||
| Not_bound ->
|
||||
( A.alt
|
||||
ids
|
||||
[ A.seq ids `First (A.after ids Category.letter) (A.before ids Category.letter)
|
||||
; (let cat = Category.(inexistant ++ not_letter) in
|
||||
A.seq ids `First (A.after ids cat) (A.before ids cat))
|
||||
]
|
||||
, kind )
|
||||
| Beg_of_str -> A.after ids Category.inexistant, kind
|
||||
| End_of_str -> A.before ids Category.inexistant, kind
|
||||
| Last_end_of_line -> A.before ids Category.(inexistant ++ lastnewline), kind
|
||||
| Start -> A.after ids Category.search_boundary, kind
|
||||
| Stop -> A.before ids Category.search_boundary, kind
|
||||
| Sem (kind', r') ->
|
||||
let cr, kind'' = translate { ctx with kind = kind' } r' in
|
||||
enforce_kind ids kind' kind'' cr, kind'
|
||||
| Sem_greedy (greedy', r') -> translate { ctx with greedy = greedy' } r'
|
||||
| Group (n, r') ->
|
||||
if ign_group
|
||||
then translate ctx r'
|
||||
else (
|
||||
let p = !pos in
|
||||
let () =
|
||||
match n with
|
||||
| Some name -> names := (name, A.Mark.group_count p) :: !names
|
||||
| None -> ()
|
||||
in
|
||||
pos := A.Mark.next2 !pos;
|
||||
let cr, kind' = translate ctx r' in
|
||||
( A.seq ids `First (A.mark ids p) (A.seq ids `First cr (A.mark ids (A.Mark.next p)))
|
||||
, kind' ))
|
||||
| No_group r' -> translate { ctx with ign_group = true } r'
|
||||
| Nest r' ->
|
||||
let b = !pos in
|
||||
let cr, kind' = translate ctx r' in
|
||||
let e = A.Mark.prev !pos in
|
||||
if A.Mark.compare e b = -1
|
||||
then cr, kind'
|
||||
else A.seq ids `First (A.erase ids b e) cr, kind'
|
||||
| Pmark (i, r') ->
|
||||
let cr, kind' = translate ctx r' in
|
||||
A.seq ids `First (A.pmark ids i) cr, kind'
|
||||
|
||||
and trans_seq ({ ids; kind; _ } as ctx) = function
|
||||
| [] -> A.eps ids
|
||||
| [ r ] ->
|
||||
let cr', kind' = translate ctx r in
|
||||
enforce_kind ids kind kind' cr'
|
||||
| r :: rem ->
|
||||
let cr', kind' = translate ctx r in
|
||||
let cr'' = trans_seq ctx rem in
|
||||
if A.is_eps cr'' then cr' else if A.is_eps cr' then cr'' else A.seq ids kind' cr' cr''
|
||||
;;
|
||||
|
||||
let compile_1 regexp =
|
||||
let regexp = Ast.handle_case false regexp in
|
||||
let color_map = Color_map.make () in
|
||||
let need_lnl = Ast.colorize color_map regexp in
|
||||
let colors, color_repr = Color_map.flatten color_map in
|
||||
let ncolor = Color_map.Repr.length color_repr in
|
||||
let lnl = if need_lnl then Cset.of_int ncolor else Cset.null_char in
|
||||
let ncolor = if need_lnl then ncolor + 1 else ncolor in
|
||||
let ctx =
|
||||
{ ids = A.Ids.create ()
|
||||
; kind = `First
|
||||
; ign_group = false
|
||||
; greedy = `Greedy
|
||||
; pos = ref A.Mark.start
|
||||
; names = ref []
|
||||
; cache = ref Cset.CSetMap.empty
|
||||
; colors
|
||||
}
|
||||
in
|
||||
let r, kind = translate ctx regexp in
|
||||
let r = enforce_kind ctx.ids `First kind r in
|
||||
(*Format.eprintf "<%d %d>@." !ids ncol;*)
|
||||
mk_re
|
||||
~initial:r
|
||||
~colors
|
||||
~color_repr
|
||||
~ncolor
|
||||
~lnl
|
||||
~group_names:(List.rev !(ctx.names))
|
||||
~group_count:(A.Mark.group_count !(ctx.pos))
|
||||
;;
|
||||
|
||||
let compile r =
|
||||
let open Ast.Export in
|
||||
compile_1 (if Ast.anchored r then group r else seq [ shortest (rep any); group r ])
|
||||
;;
|
||||
Loading…
Add table
Add a link
Reference in a new issue