diff options
Diffstat (limited to 'lib')
| -rw-r--r-- | lib/kernel/Initialization.ml | 5 | ||||
| -rw-r--r-- | lib/kernel/Initialization.mli | 5 | ||||
| -rw-r--r-- | lib/kernel/Path.ml | 15 |
3 files changed, 16 insertions, 9 deletions
diff --git a/lib/kernel/Initialization.ml b/lib/kernel/Initialization.ml index 54bb76d..86c6882 100644 --- a/lib/kernel/Initialization.ml +++ b/lib/kernel/Initialization.ml @@ -20,12 +20,11 @@ let namespace entries = evaluators, and whatever else it registers beside them. *) let mount root name = match Path.lookup root Path.(name @/ this) with - | Ok mounted -> Ok mounted + | Ok mounted -> Ok (Protocols.Handle.release mounted) | Error _ -> let open Utilities.Result in let* mounted = namespace ["evaluator", Namespace.make ()] in - let* () = bind root (name, mounted) in - Ok mounted + bind root (name, mounted) module Make (S : Abstract.Storage.STORAGE) = struct module BM = BranchManager.Make (S) diff --git a/lib/kernel/Initialization.mli b/lib/kernel/Initialization.mli index a6e6ae0..02db00f 100644 --- a/lib/kernel/Initialization.mli +++ b/lib/kernel/Initialization.mli @@ -1,7 +1,6 @@ (** a subsystem's root, \[name], holding \[name]\evaluator for the - evaluators it registers. Mounting it again gives the one there. *) -val mount : - Protocols.Handle.t -> string -> (Protocols.Handle.t, Concepts.Condition.condition) result + evaluators it registers. Mounting it again keeps the one there. *) +val mount : Protocols.Handle.t -> string -> (unit, Concepts.Condition.condition) result module Make (S : Abstract.Storage.STORAGE) : sig (** the root of the object tree, holding \system: its branches, of diff --git a/lib/kernel/Path.ml b/lib/kernel/Path.ml index 512cfb0..2a9b053 100644 --- a/lib/kernel/Path.ml +++ b/lib/kernel/Path.ml @@ -22,6 +22,10 @@ module Error = struct condition "overlapping-change" "A batch of changes both replaced an object and changed inside it" ("path" |=| Concepts.Value.String (to_string path)) + + let unheld path = + condition "path-unheld" "The object at the path could not be held" + ("path" |=| Concepts.Value.String (to_string path)) end let walking ?missing f g handle path = @@ -42,7 +46,11 @@ let walking ?missing f g handle path = | Some elem -> f x handle (fun () -> walk elem xs) ) in Handle.with_autorelease (fun () -> - walk handle path + begin match path with + | [] -> ( + match Handle.copy handle with Some copy -> g copy | None -> Error (Error.unheld path) ) + | _ -> walk handle path + end |> Result.map_error Concepts.Condition.(complement ("path" |=| Concepts.Value.String (to_string path))) ) @@ -55,8 +63,9 @@ let update handle path key reference value = let open Utilities.Result in let open Protocols in let* target = lookup handle path in - let* registry = Handle.require Registry.from target in - Registry.update registry key reference value + Handle.releasing target (fun () -> + let* registry = Handle.require Registry.from target in + Registry.update registry key reference value ) (* The changes at this object, and those beneath each child they reach. *) let split changes = |
