Step 10b: capability-based sandboxing

Capability primitives promoted from mcp_tree.ml to sx_primitives.ml:
- with-capabilities — push cap set, eval body, restore on exit/error
- current-capabilities — returns active capability list (nil = unrestricted)
- has-capability? — check if capability granted (true when unrestricted)
- require-capability! — raise if capability missing
- capability-restricted? — check if any restrictions active

Infrastructure: _cek_call_ref in sx_types.ml (forward ref pattern)
allows primitives to invoke the CEK evaluator without dependency cycles.

10 new tests: unrestricted defaults, scoping, nesting, restore-on-exit.
2693 total tests, 0 regressions.

Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>

hosts/ocaml/lib/sx_primitives.ml

@@ -1062,6 +1062,55 @@ let () =
     match args with [Vector arr] -> Vector (Array.copy arr)
     | _ -> raise (Eval_error "vector-copy: expected vector"));
 
+  (* Capability-based sandboxing — gate IO operations *)
+  let cap_stack : string list ref = ref [] in
+  register "with-capabilities" (fun args ->
+    match args with
+    | [List caps; body] ->
+      let cap_set = List.filter_map (fun v -> match v with
+        | Symbol s | String s | Keyword s -> Some s | _ -> None) caps in
+      let prev = !cap_stack in
+      cap_stack := cap_set;
+      (match body with
+       | Lambda _ | NativeFn _ | VmClosure _ ->
+         let result = (try !Sx_types._cek_call_ref body Nil
+           with exn -> cap_stack := prev; raise exn) in
+         cap_stack := prev; result
+       | _ -> cap_stack := prev; body)
+    | [ListRef { contents = caps }; body] ->
+      (* Handle mutable lists too *)
+      let cap_set = List.filter_map (fun v -> match v with
+        | Symbol s | String s | Keyword s -> Some s | _ -> None) caps in
+      let prev = !cap_stack in
+      cap_stack := cap_set;
+      (match body with
+       | Lambda _ | NativeFn _ | VmClosure _ ->
+         let result = (try !Sx_types._cek_call_ref body Nil
+           with exn -> cap_stack := prev; raise exn) in
+         cap_stack := prev; result
+       | _ -> cap_stack := prev; body)
+    | _ -> raise (Eval_error "with-capabilities: expected (cap-list body-fn)"));
+  register "current-capabilities" (fun _args ->
+    if !cap_stack = [] then Nil
+    else List (List.map (fun s -> String s) !cap_stack));
+  register "has-capability?" (fun args ->
+    match args with
+    | [String cap] | [Keyword cap] | [Symbol cap] ->
+      if !cap_stack = [] then Bool true  (* unrestricted *)
+      else Bool (List.mem cap !cap_stack)
+    | _ -> Bool true);
+  register "require-capability!" (fun args ->
+    match args with
+    | [String cap] | [Keyword cap] | [Symbol cap] ->
+      if !cap_stack = [] then Nil  (* unrestricted *)
+      else if List.mem cap !cap_stack then Nil
+      else raise (Eval_error (Printf.sprintf
+        "Capability '%s' not available. Current capabilities: [%s]"
+        cap (String.concat ", " !cap_stack)))
+    | _ -> Nil);
+  register "capability-restricted?" (fun _args ->
+    Bool (!cap_stack <> []));
+
   register "is-else-clause?" (fun args ->
     match args with
     | [Keyword "else"] -> Bool true

hosts/ocaml/lib/sx_ref.ml

@@ -818,6 +818,9 @@ let () = trampoline_fn := (fun v ->
 (* Wire up the primitives trampoline so call_any in HO forms resolves Thunks *)
 let () = Sx_primitives._sx_trampoline_fn := !trampoline_fn
 
+(* Wire up CEK call ref so primitives (e.g. with-capabilities) can invoke the evaluator *)
+let () = Sx_types._cek_call_ref := cek_call
+
 (* Override recursive cek_run with iterative loop.
    On error, capture the kont from the last state for comp-trace. *)
 let cek_run_iterative state =

hosts/ocaml/lib/sx_types.ml

@@ -223,6 +223,10 @@ and vm_machine = {
 let _vm_call_closure_ref : (vm_closure -> value list -> value) ref =
   ref (fun _ _ -> raise (Failure "VM call_closure not initialized"))
 
+(** Forward ref for calling CEK evaluator from primitives (avoids dependency cycle). *)
+let _cek_call_ref : (value -> value -> value) ref =
+  ref (fun _ _ -> raise (Failure "CEK call not initialized"))
+
 
 (** {1 Errors} *)
 

spec/tests/test-r7rs.sx

@@ -508,3 +508,72 @@
     (do
       (assert= (vector 1 2 3) (vector 1 2 3))
       (assert (not (= (vector 1 2) (vector 1 3)))))))
+
+(defsuite
+  "capabilities"
+  (deftest
+    "current-capabilities nil when unrestricted"
+    (assert= nil (current-capabilities)))
+  (deftest
+    "has-capability? true when unrestricted"
+    (assert (has-capability? "anything")))
+  (deftest
+    "with-capabilities sets capabilities"
+    (with-capabilities
+      (list "io-fetch" "io-query")
+      (fn () (assert= (list "io-fetch" "io-query") (current-capabilities)))))
+  (deftest
+    "has-capability? checks active set"
+    (with-capabilities
+      (list "io-fetch")
+      (fn
+        ()
+        (do
+          (assert (has-capability? "io-fetch"))
+          (assert (not (has-capability? "io-query")))))))
+  (deftest
+    "require-capability! passes when granted"
+    (with-capabilities
+      (list "io-fetch")
+      (fn () (require-capability! "io-fetch"))))
+  (deftest
+    "require-capability! raises when missing"
+    (with-capabilities
+      (list "io-fetch")
+      (fn () (assert (not (has-capability? "io-query"))))))
+  (deftest
+    "capabilities restore after body"
+    (do
+      (with-capabilities (list "io-fetch") (fn () nil))
+      (assert= nil (current-capabilities))))
+  (deftest
+    "capabilities restore after nested call"
+    (do
+      (with-capabilities
+        (list "io-fetch")
+        (fn
+          ()
+          (with-capabilities
+            (list "io-query")
+            (fn () (assert (has-capability? "io-query"))))))
+      (assert= nil (current-capabilities))))
+  (deftest
+    "nested capabilities narrow scope"
+    (with-capabilities
+      (list "io-fetch" "io-query")
+      (fn
+        ()
+        (with-capabilities
+          (list "io-fetch")
+          (fn
+            ()
+            (do
+              (assert (has-capability? "io-fetch"))
+              (assert (not (has-capability? "io-query")))))))))
+  (deftest
+    "capability-restricted? predicate"
+    (do
+      (assert (not (capability-restricted?)))
+      (with-capabilities
+        (list "pure")
+        (fn () (assert (capability-restricted?)))))))