diff --git a/hosts/ocaml/lib/sx_primitives.ml b/hosts/ocaml/lib/sx_primitives.ml index c6eb6eba..c1a90bca 100644 --- a/hosts/ocaml/lib/sx_primitives.ml +++ b/hosts/ocaml/lib/sx_primitives.ml @@ -239,6 +239,13 @@ let () = done; !eq) (* Parameters: same UID = same parameter *) | Parameter a, Parameter b -> a.pm_uid = b.pm_uid + (* Vectors: same length + element-wise equal *) + | Vector a, Vector b -> + Array.length a = Array.length b && + (let eq = ref true in + for i = 0 to Array.length a - 1 do + if not (safe_eq a.(i) b.(i)) then eq := false + done; !eq) (* Lambda/Component/Island/Signal/NativeFn: physical only *) | _ -> false in @@ -764,6 +771,9 @@ let () = | [Lambda _] -> String "" | [Record r] -> String (Printf.sprintf "#<%s>" r.r_type.rt_name) | [Parameter p] -> String (Printf.sprintf "#" p.pm_uid) + | [Vector arr] -> + let elts = Array.to_list (Array.map (fun v -> inspect v) arr) in + String (Printf.sprintf "#(%s)" (String.concat " " elts)) | [a] -> String (inspect a) (* used for dedup keys in compiler *) | _ -> raise (Eval_error "serialize: 1 arg")); register "make-symbol" (fun args -> @@ -1015,6 +1025,42 @@ let () = match args with | [Parameter p] -> (match p.pm_converter with Some c -> c | None -> Nil) | _ -> raise (Eval_error "parameter-converter: expected parameter")); + (* R7RS vectors — mutable fixed-size arrays *) + register "make-vector" (fun args -> + match args with + | [Number n] -> Vector (Array.make (int_of_float n) Nil) + | [Number n; fill] -> Vector (Array.make (int_of_float n) fill) + | _ -> raise (Eval_error "make-vector: expected (length) or (length fill)")); + register "vector" (fun args -> Vector (Array.of_list args)); + register "vector?" (fun args -> + match args with [Vector _] -> Bool true | [_] -> Bool false + | _ -> raise (Eval_error "vector?: 1 arg")); + register "vector-length" (fun args -> + match args with [Vector arr] -> Number (float_of_int (Array.length arr)) + | _ -> raise (Eval_error "vector-length: expected vector")); + register "vector-ref" (fun args -> + match args with + | [Vector arr; Number n] -> arr.(int_of_float n) + | _ -> raise (Eval_error "vector-ref: expected (vector index)")); + register "vector-set!" (fun args -> + match args with + | [Vector arr; Number n; v] -> arr.(int_of_float n) <- v; Nil + | _ -> raise (Eval_error "vector-set!: expected (vector index value)")); + register "vector->list" (fun args -> + match args with [Vector arr] -> List (Array.to_list arr) + | _ -> raise (Eval_error "vector->list: expected vector")); + register "list->vector" (fun args -> + match args with + | [List l] -> Vector (Array.of_list l) + | [ListRef { contents = l }] -> Vector (Array.of_list l) + | _ -> raise (Eval_error "list->vector: expected list")); + register "vector-fill!" (fun args -> + match args with + | [Vector arr; v] -> Array.fill arr 0 (Array.length arr) v; Nil + | _ -> raise (Eval_error "vector-fill!: expected (vector value)")); + register "vector-copy" (fun args -> + match args with [Vector arr] -> Vector (Array.copy arr) + | _ -> raise (Eval_error "vector-copy: expected vector")); register "is-else-clause?" (fun args -> match args with diff --git a/hosts/ocaml/lib/sx_types.ml b/hosts/ocaml/lib/sx_types.ml index f3f23e70..ce99bc15 100644 --- a/hosts/ocaml/lib/sx_types.ml +++ b/hosts/ocaml/lib/sx_types.ml @@ -71,6 +71,7 @@ and value = | VmMachine of vm_machine (** VM state — stack, frames, globals. *) | Record of record (** R7RS record — opaque, generative, field-indexed. *) | Parameter of parameter (** R7RS parameter — dynamic binding via kont-stack provide frames. *) + | Vector of value array (** R7RS vector — mutable fixed-size array. *) (** CEK machine state — record instead of Dict for performance. 5 fields × 55K steps/sec = 275K Hashtbl allocations/sec eliminated. *) @@ -430,6 +431,7 @@ let type_of = function | VmMachine _ -> "vm-machine" | Record r -> r.r_type.rt_name | Parameter _ -> "parameter" + | Vector _ -> "vector" let is_nil = function Nil -> true | _ -> false let is_lambda = function Lambda _ -> true | _ -> false @@ -770,5 +772,8 @@ let rec inspect = function ) r.r_fields) in Printf.sprintf "" r.r_type.rt_name (String.concat " " fields) | Parameter p -> Printf.sprintf "" p.pm_uid + | Vector arr -> + let elts = Array.to_list (Array.map inspect arr) in + Printf.sprintf "#(%s)" (String.concat " " elts) | VmFrame f -> Printf.sprintf "" f.vf_ip f.vf_base | VmMachine m -> Printf.sprintf "" m.vm_sp (List.length m.vm_frames) diff --git a/spec/tests/test-r7rs.sx b/spec/tests/test-r7rs.sx index e55ddec5..e996d220 100644 --- a/spec/tests/test-r7rs.sx +++ b/spec/tests/test-r7rs.sx @@ -434,3 +434,77 @@ (assert (integer? (ceil 3.2))) (assert (integer? (round 3.5))) (assert (integer? (truncate 3.7)))))) + +(defsuite + "vectors" + (deftest + "make-vector creates vector of given size" + (let + ((v (make-vector 5))) + (do (assert (vector? v)) (assert= 5 (vector-length v))))) + (deftest + "make-vector with fill value" + (let + ((v (make-vector 3 42))) + (do + (assert= 42 (vector-ref v 0)) + (assert= 42 (vector-ref v 1)) + (assert= 42 (vector-ref v 2))))) + (deftest + "vector constructor from args" + (let + ((v (vector 1 2 3))) + (do + (assert= 3 (vector-length v)) + (assert= 1 (vector-ref v 0)) + (assert= 2 (vector-ref v 1)) + (assert= 3 (vector-ref v 2))))) + (deftest + "vector-set! mutates in place" + (let + ((v (make-vector 3 0))) + (do + (vector-set! v 1 99) + (assert= 99 (vector-ref v 1)) + (assert= 0 (vector-ref v 0))))) + (deftest + "vector->list conversion" + (assert= (list 1 2 3) (vector->list (vector 1 2 3)))) + (deftest + "list->vector conversion" + (let + ((v (list->vector (list 10 20 30)))) + (do + (assert (vector? v)) + (assert= 3 (vector-length v)) + (assert= 20 (vector-ref v 1))))) + (deftest + "vector-fill! sets all elements" + (let + ((v (vector 1 2 3))) + (do + (vector-fill! v 0) + (assert= 0 (vector-ref v 0)) + (assert= 0 (vector-ref v 1)) + (assert= 0 (vector-ref v 2))))) + (deftest + "vector-copy creates independent copy" + (let + ((v1 (vector 1 2 3))) + (let + ((v2 (vector-copy v1))) + (do + (vector-set! v2 0 99) + (assert= 1 (vector-ref v1 0)) + (assert= 99 (vector-ref v2 0)))))) + (deftest + "vector? predicate" + (do + (assert (vector? (vector 1 2))) + (assert (not (vector? (list 1 2)))) + (assert (not (vector? 42))))) + (deftest + "vector equality" + (do + (assert= (vector 1 2 3) (vector 1 2 3)) + (assert (not (= (vector 1 2) (vector 1 3)))))))