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.
123 lines
3.4 KiB
123 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
|
|
|