You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
124 lines
3.4 KiB
124 lines
3.4 KiB
module MenhirFolder(M: MenhirLib.IncrementalEngine.INCREMENTAL_ENGINE)(F : sig
|
|
type 'a state
|
|
type 'a frame
|
|
val reduce : 'a state -> M.production -> pop:'a frame -> goto:'a M.env -> 'a frame * 'a state
|
|
val shift : 'a state -> 'a M.env -> 'a frame * 'a state
|
|
end): sig
|
|
open F
|
|
type 'a t
|
|
val make : 'a M.checkpoint -> 'a frame -> 'a state -> 'a t
|
|
val update : 'a t -> 'a M.checkpoint -> 'a t option
|
|
val observe : 'a t -> 'a state
|
|
end =
|
|
struct
|
|
open F
|
|
|
|
type 'a t =
|
|
| Normal of {
|
|
state: 'a state;
|
|
stack: ('a M.env * 'a frame) list }
|
|
| Reduction of {
|
|
state: 'a state;
|
|
stack: ('a M.env * 'a frame) list;
|
|
prod : M.production;
|
|
}
|
|
|
|
let make cp frame state =
|
|
match cp with
|
|
| M.InputNeeded env -> Normal { state; stack = [env, frame] }
|
|
| _ -> invalid_arg
|
|
"MenhirFolder: initial checkpoint should be in InputNeeded state"
|
|
|
|
let rec pop_until stack env =
|
|
match stack with
|
|
| [] -> assert false
|
|
| (env', f') :: _ when M.equal env env' -> f', stack
|
|
| _ :: tl -> pop_until tl env
|
|
|
|
let reduce_to state stack prod env =
|
|
match M.pop env with
|
|
| Some env' ->
|
|
let frame, stack = pop_until stack env' in
|
|
let frame', state' = reduce state prod ~pop:frame ~goto:env in
|
|
state', (env, frame') :: stack
|
|
| None -> assert false
|
|
|
|
let get_stack t env =
|
|
match t with
|
|
| Normal { state; stack } -> state, stack
|
|
| Reduction { state; stack; prod } -> reduce_to state stack prod env
|
|
|
|
let update t = function
|
|
| M.HandlingError _ | M.Rejected | M.Accepted _ -> None
|
|
| M.InputNeeded env ->
|
|
let state, stack = get_stack t env in
|
|
Some (Normal {state; stack})
|
|
| M.AboutToReduce (env, prod) ->
|
|
let state, stack = get_stack t env in
|
|
Some (Reduction {state; stack; prod})
|
|
| M.Shifting (env, env', _) ->
|
|
let state0, stack = get_stack t env in
|
|
let frame', state = shift state0 env' in
|
|
let stack = (env', frame') :: stack in
|
|
Some (Normal {state; stack})
|
|
|
|
let observe (Normal {state; _} | Reduction {state; _}) = state
|
|
end
|
|
|
|
|
|
type lr1_state = int
|
|
type production = int
|
|
|
|
type frame = {
|
|
origin: lr1_state;
|
|
reductions: int list;
|
|
}
|
|
|
|
type cell =
|
|
| Shift of lr1_state
|
|
| Reduce of production * cell
|
|
|
|
module Recorder(M: MenhirLib.IncrementalEngine.INCREMENTAL_ENGINE) = struct
|
|
|
|
module Tracker : sig
|
|
type 'a state = {
|
|
transitions: (cell * lr1_state, int ref) Hashtbl.t;
|
|
cell: cell;
|
|
}
|
|
|
|
type 'a frame = cell
|
|
|
|
val reduce : 'a state -> M.production -> pop:'a frame -> goto:'a M.env -> 'a frame * 'a state
|
|
val shift : 'a state -> 'a M.env -> 'a frame * 'a state
|
|
end = struct
|
|
type 'a state = {
|
|
transitions: (cell * lr1_state, int ref) Hashtbl.t;
|
|
cell: cell;
|
|
}
|
|
|
|
type 'a frame = cell
|
|
|
|
let incr transitions cell target =
|
|
let key = (cell, target) in
|
|
match Hashtbl.find transitions key with
|
|
| r -> incr r
|
|
| exception Not_found ->
|
|
Hashtbl.add transitions key (ref 1)
|
|
|
|
let incr_state state target =
|
|
incr state.transitions state.cell target
|
|
|
|
let shift state env =
|
|
let target = M.current_state_number env in
|
|
incr_state state target;
|
|
let cell = Shift target in
|
|
cell, {state with cell}
|
|
|
|
let reduce state prod ~pop ~goto =
|
|
let target = M.current_state_number goto in
|
|
incr state.transitions pop target;
|
|
let cell = Reduce (M.production_index prod, state.cell) in
|
|
cell, {state with cell}
|
|
end
|
|
end
|