From 7286629cf7323156001e826c2a10edc631731a5c Mon Sep 17 00:00:00 2001 From: giles Date: Fri, 1 May 2026 10:01:22 +0000 Subject: [PATCH] =?UTF-8?q?ocaml:=20sequence=20protocol=20=E2=80=94=20seq?= =?UTF-8?q?=5Fto=5Flist=20coercion=20in=20HO=20dispatch=20+=20sequence-*?= =?UTF-8?q?=20primitives?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-Authored-By: Claude Sonnet 4.6 --- hosts/ocaml/lib/sx_primitives.ml | 87 +++++++++++++++++++++++++++++++- hosts/ocaml/lib/sx_ref.ml | 14 ++++- 2 files changed, 99 insertions(+), 2 deletions(-) diff --git a/hosts/ocaml/lib/sx_primitives.ml b/hosts/ocaml/lib/sx_primitives.ml index 325cfa33..15a64de7 100644 --- a/hosts/ocaml/lib/sx_primitives.ml +++ b/hosts/ocaml/lib/sx_primitives.ml @@ -2112,4 +2112,89 @@ let () = | [HashTable dst; HashTable src] -> Hashtbl.iter (fun k v -> Hashtbl.replace dst k v) src; Nil - | _ -> raise (Eval_error "hash-table-merge!: expected (dst src)")) + | _ -> raise (Eval_error "hash-table-merge!: expected (dst src)")); + (* Phase 11: sequence protocol *) + let seq_to_list v = + match v with + | Nil -> List [] + | List _ -> v + | Vector arr -> List (Array.to_list arr) + | String s -> + let chars = ref [] in + String.iter (fun c -> chars := String (String.make 1 c) :: !chars) s; + List (List.rev !chars) + | _ -> v + in + register "seq-to-list" (fun args -> + match args with + | [v] -> seq_to_list v + | _ -> raise (Eval_error "seq-to-list: expected 1 arg")); + register "sequence-to-list" (fun args -> + match args with + | [v] -> seq_to_list v + | _ -> raise (Eval_error "sequence-to-list: expected 1 arg")); + register "sequence-to-vector" (fun args -> + match args with + | [v] -> (match seq_to_list v with List xs -> Vector (Array.of_list xs) | x -> x) + | _ -> raise (Eval_error "sequence-to-vector: expected 1 arg")); + register "sequence-length" (fun args -> + match args with + | [String s] -> Integer (String.length s) + | [Vector arr] -> Integer (Array.length arr) + | [v] -> (match seq_to_list v with + | List xs -> Integer (List.length xs) + | _ -> raise (Eval_error "sequence-length: expected sequence")) + | _ -> raise (Eval_error "sequence-length: expected 1 arg")); + register "sequence-ref" (fun args -> + match args with + | [String s; Integer i] -> + if i < 0 || i >= String.length s + then raise (Eval_error (Printf.sprintf "sequence-ref: index %d out of bounds" i)) + else String (String.make 1 (String.get s i)) + | [String s; Number n] -> + let i = int_of_float n in + if i < 0 || i >= String.length s + then raise (Eval_error (Printf.sprintf "sequence-ref: index %d out of bounds" i)) + else String (String.make 1 (String.get s i)) + | [v; idx] -> + let lst = seq_to_list v in + let i = (match idx with Integer n -> n | Number n -> int_of_float n | _ -> raise (Eval_error "sequence-ref: index must be number")) in + (match lst with + | List xs -> + (try List.nth xs i + with _ -> raise (Eval_error (Printf.sprintf "sequence-ref: index %d out of bounds" i))) + | _ -> raise (Eval_error "sequence-ref: expected sequence")) + | _ -> raise (Eval_error "sequence-ref: expected (seq index)")); + register "sequence-append" (fun args -> + match args with + | [String s1; String s2] -> String (s1 ^ s2) + | [v1; v2] -> + let l1 = seq_to_list v1 in + let l2 = seq_to_list v2 in + (match l1, l2 with + | List xs1, List xs2 -> List (xs1 @ xs2) + | _ -> raise (Eval_error "sequence-append: expected sequences")) + | _ -> raise (Eval_error "sequence-append: expected 2 args")); + register "in-range" (fun args -> + match args with + | [Integer n] -> + let rec build i acc = if i < 0 then acc else build (i-1) (Integer i :: acc) in + List (build (n-1) []) + | [Number n] -> + let hi = int_of_float n in + let rec build i acc = if i < 0 then acc else build (i-1) (Integer i :: acc) in + List (build (hi-1) []) + | [Integer lo; Integer hi] -> + let rec build i acc = if i < lo then acc else build (i-1) (Integer i :: acc) in + List (build (hi-1) []) + | [Number lo; Number hi] -> + let lo_i = int_of_float lo and hi_i = int_of_float hi in + let rec build i acc = if i < lo_i then acc else build (i-1) (Integer i :: acc) in + List (build (hi_i-1) []) + | [Integer lo; Integer hi; Integer step] -> + if step = 0 then raise (Eval_error "in-range: step cannot be zero"); + let rec build i acc = + if (step > 0 && i >= hi) || (step < 0 && i <= hi) then acc + else build (i + step) (Integer i :: acc) in + List (List.rev (build lo [])) + | _ -> raise (Eval_error "in-range: expected (end) or (start end) or (start end step)")) diff --git a/hosts/ocaml/lib/sx_ref.ml b/hosts/ocaml/lib/sx_ref.ml index bdb0988f..6327d635 100644 --- a/hosts/ocaml/lib/sx_ref.ml +++ b/hosts/ocaml/lib/sx_ref.ml @@ -24,6 +24,18 @@ let _protocol_registry_ = Dict (Hashtbl.create 0) (* === Transpiled from evaluator (frames + eval + CEK) === *) +(* seq-to-list: coerce list/vector/string/nil to list for HO dispatch *) +let seq_to_list v = + match v with + | Nil -> List [] + | List _ -> v + | Vector arr -> List (Array.to_list arr) + | String s -> + let chars = ref [] in + String.iter (fun c -> chars := String (String.make 1 c) :: !chars) s; + List (List.rev !chars) + | _ -> v + (* make-cek-state *) let rec make_cek_state control env kont = (CekState { cs_control = control; cs_env = env; cs_kont = kont; cs_phase = "eval"; cs_value = Nil }) @@ -890,7 +902,7 @@ and ho_swap_args ho_type evaled = (* ho-setup-dispatch *) and ho_setup_dispatch ho_type evaled env kont = - (let ordered = (ho_swap_args (ho_type) (evaled)) in (let f = (first (ordered)) in (let _match_val = ho_type in (if sx_truthy ((prim_call "=" [_match_val; (String "map")])) then (if sx_truthy ((prim_call ">" [(len (ordered)); (Number 2.0)])) then (let colls = (rest (ordered)) in (if sx_truthy ((Bool (List.exists (fun c -> sx_truthy ((empty_p (c)))) (sx_to_list colls)))) then (make_cek_value ((List [])) (env) (kont)) else (let heads = (List (List.map (fun c -> (first (c))) (sx_to_list colls))) in let tails = (List (List.map (fun c -> (rest (c))) (sx_to_list colls))) in (continue_with_call (f) (heads) (env) ((List [])) ((kont_push ((make_multi_map_frame (f) (tails) ((List [])) (env))) (kont))))))) else (let coll = (nth (ordered) ((Number 1.0))) in (if sx_truthy ((empty_p (coll))) then (make_cek_value ((List [])) (env) (kont)) else (continue_with_call (f) ((List [(first (coll))])) (env) ((List [])) ((kont_push ((make_map_frame (f) ((rest (coll))) ((List [])) (env))) (kont))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "map-indexed")])) then (let coll = (nth (ordered) ((Number 1.0))) in (if sx_truthy ((empty_p (coll))) then (make_cek_value ((List [])) (env) (kont)) else (continue_with_call (f) ((List [(Number 0.0); (first (coll))])) (env) ((List [])) ((kont_push ((make_map_indexed_frame (f) ((rest (coll))) ((List [])) (env))) (kont)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "filter")])) then (let coll = (nth (ordered) ((Number 1.0))) in (if sx_truthy ((empty_p (coll))) then (make_cek_value ((List [])) (env) (kont)) else (continue_with_call (f) ((List [(first (coll))])) (env) ((List [])) ((kont_push ((make_filter_frame (f) ((rest (coll))) ((List [])) ((first (coll))) (env))) (kont)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "reduce")])) then (let init = (nth (ordered) ((Number 1.0))) in let coll = (nth (ordered) ((Number 2.0))) in (if sx_truthy ((empty_p (coll))) then (make_cek_value (init) (env) (kont)) else (continue_with_call (f) ((List [init; (first (coll))])) (env) ((List [])) ((kont_push ((make_reduce_frame (f) ((rest (coll))) (env))) (kont)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "some")])) then (let coll = (nth (ordered) ((Number 1.0))) in (if sx_truthy ((empty_p (coll))) then (make_cek_value ((Bool false)) (env) (kont)) else (continue_with_call (f) ((List [(first (coll))])) (env) ((List [])) ((kont_push ((make_some_frame (f) ((rest (coll))) (env))) (kont)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "every")])) then (let coll = (nth (ordered) ((Number 1.0))) in (if sx_truthy ((empty_p (coll))) then (make_cek_value ((Bool true)) (env) (kont)) else (continue_with_call (f) ((List [(first (coll))])) (env) ((List [])) ((kont_push ((make_every_frame (f) ((rest (coll))) (env))) (kont)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "for-each")])) then (let coll = (nth (ordered) ((Number 1.0))) in (if sx_truthy ((empty_p (coll))) then (make_cek_value (Nil) (env) (kont)) else (continue_with_call (f) ((List [(first (coll))])) (env) ((List [])) ((kont_push ((make_for_each_frame (f) ((rest (coll))) (env))) (kont)))))) else (raise (Eval_error (value_to_str (String (sx_str [(String "Unknown HO type: "); ho_type]))))))))))))))) + (let ordered = (ho_swap_args (ho_type) (evaled)) in (let f = (first (ordered)) in (let _match_val = ho_type in (if sx_truthy ((prim_call "=" [_match_val; (String "map")])) then (if sx_truthy ((prim_call ">" [(len (ordered)); (Number 2.0)])) then (let colls = (rest (ordered)) in (if sx_truthy ((Bool (List.exists (fun c -> sx_truthy ((empty_p (c)))) (sx_to_list colls)))) then (make_cek_value ((List [])) (env) (kont)) else (let heads = (List (List.map (fun c -> (first (c))) (sx_to_list colls))) in let tails = (List (List.map (fun c -> (rest (c))) (sx_to_list colls))) in (continue_with_call (f) (heads) (env) ((List [])) ((kont_push ((make_multi_map_frame (f) (tails) ((List [])) (env))) (kont))))))) else (let coll = seq_to_list (nth (ordered) ((Number 1.0))) in (if sx_truthy ((empty_p (coll))) then (make_cek_value ((List [])) (env) (kont)) else (continue_with_call (f) ((List [(first (coll))])) (env) ((List [])) ((kont_push ((make_map_frame (f) ((rest (coll))) ((List [])) (env))) (kont))))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "map-indexed")])) then (let coll = seq_to_list (nth (ordered) ((Number 1.0))) in (if sx_truthy ((empty_p (coll))) then (make_cek_value ((List [])) (env) (kont)) else (continue_with_call (f) ((List [(Number 0.0); (first (coll))])) (env) ((List [])) ((kont_push ((make_map_indexed_frame (f) ((rest (coll))) ((List [])) (env))) (kont)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "filter")])) then (let coll = seq_to_list (nth (ordered) ((Number 1.0))) in (if sx_truthy ((empty_p (coll))) then (make_cek_value ((List [])) (env) (kont)) else (continue_with_call (f) ((List [(first (coll))])) (env) ((List [])) ((kont_push ((make_filter_frame (f) ((rest (coll))) ((List [])) ((first (coll))) (env))) (kont)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "reduce")])) then (let init = (nth (ordered) ((Number 1.0))) in let coll = seq_to_list (nth (ordered) ((Number 2.0))) in (if sx_truthy ((empty_p (coll))) then (make_cek_value (init) (env) (kont)) else (continue_with_call (f) ((List [init; (first (coll))])) (env) ((List [])) ((kont_push ((make_reduce_frame (f) ((rest (coll))) (env))) (kont)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "some")])) then (let coll = seq_to_list (nth (ordered) ((Number 1.0))) in (if sx_truthy ((empty_p (coll))) then (make_cek_value ((Bool false)) (env) (kont)) else (continue_with_call (f) ((List [(first (coll))])) (env) ((List [])) ((kont_push ((make_some_frame (f) ((rest (coll))) (env))) (kont)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "every")])) then (let coll = seq_to_list (nth (ordered) ((Number 1.0))) in (if sx_truthy ((empty_p (coll))) then (make_cek_value ((Bool true)) (env) (kont)) else (continue_with_call (f) ((List [(first (coll))])) (env) ((List [])) ((kont_push ((make_every_frame (f) ((rest (coll))) (env))) (kont)))))) else (if sx_truthy ((prim_call "=" [_match_val; (String "for-each")])) then (let coll = seq_to_list (nth (ordered) ((Number 1.0))) in (if sx_truthy ((empty_p (coll))) then (make_cek_value (Nil) (env) (kont)) else (continue_with_call (f) ((List [(first (coll))])) (env) ((List [])) ((kont_push ((make_for_each_frame (f) ((rest (coll))) (env))) (kont)))))) else (raise (Eval_error (value_to_str (String (sx_str [(String "Unknown HO type: "); ho_type]))))))))))))))) (* step-ho-map *) and step_ho_map args env kont =