Commit bf691e70 authored by POTTIER Francois's avatar POTTIER Francois

Renaming of the three modes.

parent e600b6d0
type 'env mode =
| OutsideRec (* updating [current] and visiting [outer] subterms *)
| ExtendAndVisit (* updating [current] and visiting [outer] subterms *)
(* we are outside [rec] and outside [repeated] *)
| InsideRecDiscovery (* updating [current] and doing nothing else; embedded subterms not visited *)
| ExtendNoVisit (* updating [current] and doing nothing else; embedded subterms not visited *)
(* we are under [rec] in the discovery phase *)
| InsideRecVisit (* [current] not updated; [inner] is [current]; embedded subterms visited *)
| LookupAndVisit (* [current] not updated; [inner] is [current]; embedded subterms visited *)
(* we are either under [rec] in the visit phase, or under [repeated] *)
type 'env penv = {
current: 'env ref; (* threaded left to right *)
current: 'env ref; (* threaded left to right; do NOT use a mutable field! *)
outer: 'env; (* sent down only *)
mode: 'env mode;
}
......@@ -49,7 +49,7 @@ class virtual ['self] libmap = object (self : 'self)
('env penv -> 'p1 -> 'p2) ->
'env -> 'p1 abstraction -> 'p2 abstraction
= fun visit_p env p1 ->
let penv = { current = ref env; outer = env; mode = OutsideRec } in
let penv = { current = ref env; outer = env; mode = ExtendAndVisit } in
visit_p penv p1
method private visit_outer: 'env 't1 't2 .
......@@ -57,10 +57,10 @@ class virtual ['self] libmap = object (self : 'self)
'env penv -> 't1 outer -> 't2 outer
= fun visit_t penv t1 ->
match penv.mode with
| OutsideRec
| InsideRecVisit ->
| ExtendAndVisit
| LookupAndVisit ->
visit_t penv.outer t1
| InsideRecDiscovery ->
| ExtendNoVisit ->
(* An [outer] subterm is NOT visited in discovery mode. *)
Obj.magic ()
......@@ -69,14 +69,14 @@ class virtual ['self] libmap = object (self : 'self)
'env penv -> 'bn1 binder -> 'bn2 binder
= fun _ penv x1 ->
match penv.mode with
| OutsideRec
| InsideRecDiscovery ->
| ExtendAndVisit
| ExtendNoVisit ->
let current = penv.current in
let env = !current in
let x2, env = self#extend x1 env in
current := env;
x2
| InsideRecVisit ->
| LookupAndVisit ->
(* The environment should not be extended when in visit mode.
It has been extended already during the discovery phase. *)
self#lookup x1 !(penv.current)
......@@ -87,15 +87,15 @@ class virtual ['self] libmap = object (self : 'self)
'env penv -> ('p1, 'q1) rebind -> ('p2, 'q2) rebind
= fun visit_p visit_q penv (p1, q1) ->
match penv.mode with
| OutsideRec ->
| ExtendAndVisit ->
let p2 = visit_p penv p1 in
(* Copy [current] into [outer]. This changes the meaning of [outer]
in the right-hand side of [rebind]. *)
let penv = { penv with outer = !(penv.current) } in
let q2 = visit_q penv q1 in
p2, q2
| InsideRecDiscovery
| InsideRecVisit ->
| ExtendNoVisit
| LookupAndVisit ->
(* [rebind] forbidden under [rec] and [repeated] *)
assert false
......@@ -116,11 +116,11 @@ class virtual ['self] libmap = object (self : 'self)
'env penv -> 't1 inner -> 't2 inner
= fun visit_t penv t1 ->
match penv.mode with
| InsideRecDiscovery ->
| ExtendNoVisit ->
(* An [inner] subterm is NOT visited in discovery mode. *)
Obj.magic ()
| OutsideRec
| InsideRecVisit ->
| ExtendAndVisit
| LookupAndVisit ->
visit_t !(penv.current) t1
method private visit_recursive: 'env 'p1 'p2 .
......@@ -128,16 +128,16 @@ class virtual ['self] libmap = object (self : 'self)
'env penv -> 'p1 recursive -> 'p2 recursive
= fun visit_p penv p1 ->
match penv.mode with
| OutsideRec ->
| ExtendAndVisit ->
(* Discovery phase. Result is discarded (fortunately, since we have used
[magic] to produce it, and it is entirely meaningless). *)
let penv = { penv with mode = InsideRecDiscovery } in
let penv = { penv with mode = ExtendNoVisit } in
let _ = visit_p penv p1 in
(* [!current] becomes [inner] *)
let penv = { penv with mode = InsideRecVisit } in
let penv = { penv with mode = LookupAndVisit } in
visit_p penv p1
| InsideRecDiscovery
| InsideRecVisit ->
| ExtendNoVisit
| LookupAndVisit ->
(* [rec] forbidden under [rec] or [repeated] *)
assert false
......@@ -145,7 +145,7 @@ class virtual ['self] libmap = object (self : 'self)
('env penv -> 'p1 -> 'p2) ->
'env penv -> 'p1 repeated -> 'p2 repeated
= fun visit_p penv p1 ->
let penv = { penv with mode = InsideRecVisit } in
let penv = { penv with mode = LookupAndVisit } in
visit_p penv p1
end
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment