ocaml bindings for chibi-scheme VM
0
fork

Configure Feed

Select the types of activity you want to include in your feed.

Add test suite and chibi test runner

+1266
+3
test/dune
··· 1 + (test 2 + (name test_chibi_ocaml) 3 + (libraries chibi_ocaml))
+758
test/test_chibi_ocaml.ml
··· 1 + open Chibi_ocaml.Chibi 2 + 3 + (* Simple test framework *) 4 + let test_count = ref 0 5 + let fail_count = ref 0 6 + 7 + let test name f = 8 + incr test_count; 9 + Printf.printf " [%d] %s... " !test_count name; 10 + try 11 + f (); 12 + Printf.printf "OK\n%!" 13 + with e -> 14 + incr fail_count; 15 + Printf.printf "FAIL: %s\n%!" (Printexc.to_string e) 16 + 17 + let assert_equal_int expected actual = 18 + if expected <> actual then 19 + failwith (Printf.sprintf "expected %d, got %d" expected actual) 20 + 21 + let assert_equal_float expected actual = 22 + if Float.abs (expected -. actual) > 1e-10 then 23 + failwith (Printf.sprintf "expected %f, got %f" expected actual) 24 + 25 + let assert_equal_string expected actual = 26 + if expected <> actual then 27 + failwith (Printf.sprintf "expected %S, got %S" expected actual) 28 + 29 + let assert_equal_bool expected actual = 30 + if expected <> actual then 31 + failwith (Printf.sprintf "expected %b, got %b" expected actual) 32 + 33 + let assert_true b = 34 + if not b then failwith "expected true" 35 + 36 + let assert_false b = 37 + if b then failwith "expected false" 38 + 39 + (* ---- Test suites ---- *) 40 + 41 + let test_context_lifecycle () = 42 + Printf.printf "\n=== Context Lifecycle ===\n%!"; 43 + 44 + test "create and destroy context" (fun () -> 45 + let ctx = Context.create () in 46 + assert_true (Context.is_alive ctx); 47 + Context.destroy ctx; 48 + assert_false (Context.is_alive ctx)); 49 + 50 + test "with_context ensures cleanup" (fun () -> 51 + let alive_ref = ref false in 52 + with_context (fun ctx -> 53 + alive_ref := Context.is_alive ctx; 54 + assert_true !alive_ref); 55 + ()); 56 + 57 + test "double destroy is safe" (fun () -> 58 + let ctx = Context.create () in 59 + Context.destroy ctx; 60 + Context.destroy ctx); 61 + 62 + test "context with memory limits" (fun () -> 63 + let config = Context.{ 64 + default_config with 65 + heap_size = 1024 * 1024; (* 1MB initial *) 66 + max_heap_size = 4 * 1024 * 1024; (* 4MB max *) 67 + } in 68 + with_context ~config (fun ctx -> 69 + let max = Context.heap_max_size ctx in 70 + assert_true (max > 0))); 71 + 72 + test "multiple independent contexts" (fun () -> 73 + let ctx1 = Context.create () in 74 + let ctx2 = Context.create () in 75 + assert_true (Context.is_alive ctx1); 76 + assert_true (Context.is_alive ctx2); 77 + (* Define different values in each *) 78 + let _ = Eval.string ctx1 "(define x 42)" in 79 + let _ = Eval.string ctx2 "(define x 99)" in 80 + let v1 = Eval.to_int ctx1 "x" in 81 + let v2 = Eval.to_int ctx2 "x" in 82 + assert_equal_int 42 v1; 83 + assert_equal_int 99 v2; 84 + Context.destroy ctx1; 85 + Context.destroy ctx2); 86 + 87 + test "with_context cleans up context on exception" (fun () -> 88 + let ctx_ref = ref None in 89 + (try 90 + with_context (fun ctx -> 91 + ctx_ref := Some ctx; 92 + failwith "deliberate") 93 + with Failure _ -> ()); 94 + match !ctx_ref with 95 + | None -> failwith "context was never created" 96 + | Some ctx -> assert_false (Context.is_alive ctx)) 97 + 98 + let test_basic_eval () = 99 + Printf.printf "\n=== Basic Evaluation ===\n%!"; 100 + 101 + with_context (fun ctx -> 102 + test "eval integer arithmetic" (fun () -> 103 + let result = Eval.to_int ctx "(+ 2 3)" in 104 + assert_equal_int 5 result); 105 + 106 + test "eval float arithmetic" (fun () -> 107 + let result = Eval.to_float ctx "(+ 1.5 2.5)" in 108 + assert_equal_float 4.0 result); 109 + 110 + test "eval boolean" (fun () -> 111 + assert_equal_bool true (Eval.to_bool ctx "(= 1 1)"); 112 + assert_equal_bool false (Eval.to_bool ctx "(= 1 2)")); 113 + 114 + test "eval string" (fun () -> 115 + let result = Eval.string ctx "\"hello world\"" in 116 + assert_equal_string "hello world" (Sexp.to_string result)); 117 + 118 + test "define and use variable" (fun () -> 119 + let _ = Eval.string ctx "(define pi 3.14159)" in 120 + let result = Eval.to_float ctx "pi" in 121 + assert_equal_float 3.14159 result); 122 + 123 + test "define and call function" (fun () -> 124 + let _ = Eval.string ctx "(define (square x) (* x x))" in 125 + let result = Eval.to_int ctx "(square 7)" in 126 + assert_equal_int 49 result); 127 + 128 + test "eval list operations" (fun () -> 129 + let result = Eval.string ctx "(list 1 2 3)" in 130 + let items = Sexp.to_list result in 131 + assert_equal_int 3 (List.length items); 132 + assert_equal_int 1 (Sexp.to_int (List.nth items 0)); 133 + assert_equal_int 2 (Sexp.to_int (List.nth items 1)); 134 + assert_equal_int 3 (Sexp.to_int (List.nth items 2))); 135 + 136 + test "eval error raises Chibi_error" (fun () -> 137 + try 138 + let _ = Eval.string ctx "(/ 1 0)" in 139 + failwith "should have raised" 140 + with Chibi_error _ -> ()); 141 + 142 + test "eval syntax error" (fun () -> 143 + try 144 + let _ = Eval.string ctx "(define)" in 145 + failwith "should have raised" 146 + with Chibi_error _ -> ())) 147 + 148 + let test_value_construction () = 149 + Printf.printf "\n=== Value Construction ===\n%!"; 150 + 151 + with_context (fun ctx -> 152 + test "construct and extract int" (fun () -> 153 + let v = Value.of_int ctx 42 in 154 + assert_true (Sexp.is_fixnum v); 155 + assert_equal_int 42 (Sexp.to_int v)); 156 + 157 + test "construct and extract float" (fun () -> 158 + let v = Value.of_float ctx 3.14 in 159 + assert_true (Sexp.is_flonum v); 160 + assert_equal_float 3.14 (Sexp.to_float v)); 161 + 162 + test "construct and extract string" (fun () -> 163 + let v = Value.of_string ctx "hello" in 164 + assert_true (Sexp.is_string v); 165 + assert_equal_string "hello" (Sexp.to_string v)); 166 + 167 + test "construct and extract symbol" (fun () -> 168 + let v = Value.of_symbol ctx "foo" in 169 + assert_true (Sexp.is_symbol v); 170 + assert_equal_string "foo" (Sexp.to_symbol v)); 171 + 172 + test "construct and extract boolean" (fun () -> 173 + let t = Value.of_bool ctx true in 174 + let f = Value.of_bool ctx false in 175 + assert_true (Sexp.is_boolean t); 176 + assert_true (Sexp.is_boolean f); 177 + assert_equal_bool true (Sexp.to_bool t); 178 + assert_equal_bool false (Sexp.to_bool f)); 179 + 180 + test "construct null" (fun () -> 181 + let v = Value.null ctx in 182 + assert_true (Sexp.is_null v)); 183 + 184 + test "construct void" (fun () -> 185 + let v = Value.void ctx in 186 + assert_true (Sexp.is_void v)); 187 + 188 + test "construct list" (fun () -> 189 + let items = [Value.of_int ctx 1; Value.of_int ctx 2; Value.of_int ctx 3] in 190 + let lst = Value.of_list ctx items in 191 + assert_true (Sexp.is_pair lst); 192 + assert_equal_int 3 (Sexp.list_length lst); 193 + assert_equal_int 1 (Sexp.to_int (Sexp.car lst))); 194 + 195 + test "construct cons pair" (fun () -> 196 + let p = Value.cons ctx (Value.of_int ctx 1) (Value.of_int ctx 2) in 197 + assert_true (Sexp.is_pair p); 198 + assert_equal_int 1 (Sexp.to_int (Sexp.car p)); 199 + assert_equal_int 2 (Sexp.to_int (Sexp.cdr p))); 200 + 201 + test "of_int_list" (fun () -> 202 + let lst = Value.of_int_list ctx [10; 20; 30] in 203 + let items = Sexp.to_list lst in 204 + assert_equal_int 3 (List.length items); 205 + assert_equal_int 20 (Sexp.to_int (List.nth items 1))); 206 + 207 + test "of_string_list" (fun () -> 208 + let lst = Value.of_string_list ctx ["a"; "b"; "c"] in 209 + let items = Sexp.to_list lst in 210 + assert_equal_int 3 (List.length items); 211 + assert_equal_string "b" (Sexp.to_string (List.nth items 1)))) 212 + 213 + let test_sexp_classify () = 214 + Printf.printf "\n=== Sexp Classification ===\n%!"; 215 + 216 + with_context (fun ctx -> 217 + test "classify fixnum" (fun () -> 218 + match Sexp.classify (Value.of_int ctx 42) with 219 + | Sexp.Fixnum 42 -> () 220 + | _ -> failwith "wrong tag"); 221 + 222 + test "classify flonum" (fun () -> 223 + match Sexp.classify (Value.of_float ctx 3.14) with 224 + | Sexp.Flonum f -> assert_equal_float 3.14 f 225 + | _ -> failwith "wrong tag"); 226 + 227 + test "classify string" (fun () -> 228 + match Sexp.classify (Value.of_string ctx "hi") with 229 + | Sexp.String "hi" -> () 230 + | _ -> failwith "wrong tag"); 231 + 232 + test "classify symbol" (fun () -> 233 + match Sexp.classify (Value.of_symbol ctx "foo") with 234 + | Sexp.Symbol "foo" -> () 235 + | _ -> failwith "wrong tag"); 236 + 237 + test "classify boolean" (fun () -> 238 + match Sexp.classify (Value.of_bool ctx true) with 239 + | Sexp.Boolean true -> () 240 + | _ -> failwith "wrong tag"); 241 + 242 + test "classify null" (fun () -> 243 + match Sexp.classify (Value.null ctx) with 244 + | Sexp.Null -> () 245 + | _ -> failwith "wrong tag"); 246 + 247 + test "classify void" (fun () -> 248 + match Sexp.classify (Value.void ctx) with 249 + | Sexp.Void -> () 250 + | _ -> failwith "wrong tag"); 251 + 252 + test "classify pair" (fun () -> 253 + let p = Value.cons ctx (Value.of_int ctx 1) (Value.of_int ctx 2) in 254 + match Sexp.classify p with 255 + | Sexp.Pair -> () 256 + | _ -> failwith "wrong tag"); 257 + 258 + test "classify procedure" (fun () -> 259 + let proc = Eval.string ctx "(lambda (x) x)" in 260 + match Sexp.classify proc with 261 + | Sexp.Procedure -> () 262 + | _ -> failwith "wrong tag")) 263 + 264 + let test_env_bindings () = 265 + Printf.printf "\n=== Environment Bindings ===\n%!"; 266 + 267 + with_context (fun ctx -> 268 + test "define and lookup" (fun () -> 269 + Env.define ctx "my-val" (Value.of_int ctx 123); 270 + match Env.lookup ctx "my-val" with 271 + | Some v -> assert_equal_int 123 (Sexp.to_int v) 272 + | None -> failwith "binding not found"); 273 + 274 + test "lookup nonexistent returns None" (fun () -> 275 + match Env.lookup ctx "nonexistent-xyz-abc" with 276 + | None -> () 277 + | Some _ -> failwith "should be None"); 278 + 279 + test "lookup_exn raises on missing" (fun () -> 280 + try 281 + let _ = Env.lookup_exn ctx "nonexistent-xyz-abc" in 282 + failwith "should have raised" 283 + with Chibi_error _ -> ()); 284 + 285 + test "use OCaml-defined value in Scheme" (fun () -> 286 + Env.define ctx "ocaml-answer" (Value.of_int ctx 42); 287 + let result = Eval.to_int ctx "(+ ocaml-answer 8)" in 288 + assert_equal_int 50 result)) 289 + 290 + let test_foreign_functions () = 291 + Printf.printf "\n=== Foreign Functions ===\n%!"; 292 + 293 + with_context (fun ctx -> 294 + test "define and call foreign function (arity 2)" (fun () -> 295 + Env.define_fn2 ctx "ocaml-add" (fun a b -> 296 + let x = Sexp.to_int a in 297 + let y = Sexp.to_int b in 298 + Value.of_int ctx (x + y)); 299 + let result = Eval.to_int ctx "(ocaml-add 3 4)" in 300 + assert_equal_int 7 result); 301 + 302 + test "foreign function returning string" (fun () -> 303 + Env.define_fn1 ctx "ocaml-greet" (fun name -> 304 + let s = Sexp.to_string name in 305 + Value.of_string ctx ("Hello, " ^ s ^ "!")); 306 + let result = Eval.string ctx "(ocaml-greet \"World\")" in 307 + assert_equal_string "Hello, World!" (Sexp.to_string result)); 308 + 309 + test "foreign function with 0 args" (fun () -> 310 + Env.define_fn0 ctx "ocaml-version" (fun () -> 311 + Value.of_string ctx "1.0.0"); 312 + let result = Eval.string ctx "(ocaml-version)" in 313 + assert_equal_string "1.0.0" (Sexp.to_string result)); 314 + 315 + test "foreign function composing with scheme" (fun () -> 316 + Env.define_fn1 ctx "double" (fun x -> 317 + Value.of_int ctx (Sexp.to_int x * 2)); 318 + let result = Eval.to_int ctx "(+ (double 5) (double 3))" in 319 + assert_equal_int 16 result)) 320 + 321 + let test_write_display () = 322 + Printf.printf "\n=== Write / Display ===\n%!"; 323 + 324 + with_context (fun ctx -> 325 + test "write integer" (fun () -> 326 + let s = Eval.write ctx (Value.of_int ctx 42) in 327 + assert_equal_string "42" s); 328 + 329 + test "write string includes quotes" (fun () -> 330 + let s = Eval.write ctx (Value.of_string ctx "hello") in 331 + assert_equal_string "\"hello\"" s); 332 + 333 + test "display string omits quotes" (fun () -> 334 + let s = Eval.display ctx (Value.of_string ctx "hello") in 335 + assert_equal_string "hello" s); 336 + 337 + test "write list" (fun () -> 338 + let lst = Value.of_int_list ctx [1; 2; 3] in 339 + let s = Eval.write ctx lst in 340 + assert_equal_string "(1 2 3)" s); 341 + 342 + test "write symbol" (fun () -> 343 + let s = Eval.write ctx (Value.of_symbol ctx "foo") in 344 + assert_equal_string "foo" s); 345 + 346 + test "write boolean" (fun () -> 347 + assert_equal_string "#t" (Eval.write ctx (Value.of_bool ctx true)); 348 + assert_equal_string "#f" (Eval.write ctx (Value.of_bool ctx false))); 349 + 350 + test "to_string on eval result" (fun () -> 351 + let s = Eval.to_string ctx "(list 'a 'b 'c)" in 352 + assert_equal_string "(a b c)" s)) 353 + 354 + let test_read_parse () = 355 + Printf.printf "\n=== Read / Parse ===\n%!"; 356 + 357 + with_context (fun ctx -> 358 + test "read integer" (fun () -> 359 + let v = Eval.read ctx "42" in 360 + assert_true (Sexp.is_fixnum v); 361 + assert_equal_int 42 (Sexp.to_int v)); 362 + 363 + test "read symbol" (fun () -> 364 + let v = Eval.read ctx "hello" in 365 + assert_true (Sexp.is_symbol v); 366 + assert_equal_string "hello" (Sexp.to_symbol v)); 367 + 368 + test "read list" (fun () -> 369 + let v = Eval.read ctx "(1 2 3)" in 370 + assert_true (Sexp.is_pair v); 371 + assert_equal_int 3 (Sexp.list_length v)); 372 + 373 + test "read and eval" (fun () -> 374 + let expr = Eval.read ctx "(+ 1 2)" in 375 + let result = Eval.sexp ctx expr in 376 + assert_equal_int 3 (Sexp.to_int result))) 377 + 378 + let test_apply () = 379 + Printf.printf "\n=== Apply ===\n%!"; 380 + 381 + with_context (fun ctx -> 382 + test "apply scheme procedure" (fun () -> 383 + let proc = Eval.string ctx "(lambda (x y) (+ x y))" in 384 + let args = Value.of_list ctx [Value.of_int ctx 10; Value.of_int ctx 20] in 385 + let result = Eval.apply ctx proc args in 386 + assert_equal_int 30 (Sexp.to_int result)); 387 + 388 + test "apply built-in" (fun () -> 389 + let proc = Env.lookup_exn ctx "+" in 390 + let args = Value.of_list ctx [Value.of_int ctx 3; Value.of_int ctx 4] in 391 + let result = Eval.apply ctx proc args in 392 + assert_equal_int 7 (Sexp.to_int result))) 393 + 394 + let test_gc () = 395 + Printf.printf "\n=== Garbage Collection ===\n%!"; 396 + 397 + with_context (fun ctx -> 398 + test "manual gc doesn't crash" (fun () -> 399 + let _ = Context.gc ctx in 400 + ()); 401 + 402 + test "heap_size returns positive" (fun () -> 403 + let size = Context.heap_size ctx in 404 + assert_true (size > 0)); 405 + 406 + test "heap_max_size is 0 when no limit set" (fun () -> 407 + assert_equal_int 0 (Context.heap_max_size ctx)); 408 + 409 + test "gc after allocations" (fun () -> 410 + for _ = 1 to 1000 do 411 + let _ = Value.of_string ctx "temporary string value" in 412 + () 413 + done; 414 + let _ = Context.gc ctx in 415 + ())) 416 + 417 + let test_sandbox () = 418 + Printf.printf "\n=== Sandbox ===\n%!"; 419 + 420 + test "sandboxed context runs pure computation" (fun () -> 421 + let config = Context.sandboxed_config 422 + ~capabilities:[Sandbox.Module_import] () in 423 + with_context ~config (fun ctx -> 424 + let result = Eval.to_int ctx "(+ 1 2 3)" in 425 + assert_equal_int 6 result)); 426 + 427 + test "sandbox restricts file access" (fun () -> 428 + let config = Context.sandboxed_config 429 + ~capabilities:[Sandbox.Module_import] () in 430 + with_context ~config (fun ctx -> 431 + (* open-input-file should be overridden *) 432 + let v = Eval.string ctx "open-input-file" in 433 + assert_true (Sexp.is_void v))); 434 + 435 + test "sandbox restricts process execution" (fun () -> 436 + let config = Context.sandboxed_config 437 + ~capabilities:[Sandbox.Module_import] () in 438 + with_context ~config (fun ctx -> 439 + let v = Eval.string ctx "exit" in 440 + assert_true (Sexp.is_void v))); 441 + 442 + test "sandbox restricts file-exists?" (fun () -> 443 + let config = Context.sandboxed_config 444 + ~capabilities:[Sandbox.Module_import] () in 445 + with_context ~config (fun ctx -> 446 + let v = Eval.string ctx "file-exists?" in 447 + assert_true (Sexp.is_void v))); 448 + 449 + test "sandbox restricts delete-file" (fun () -> 450 + let config = Context.sandboxed_config 451 + ~capabilities:[Sandbox.Module_import] () in 452 + with_context ~config (fun ctx -> 453 + let v = Eval.string ctx "delete-file" in 454 + assert_true (Sexp.is_void v))); 455 + 456 + test "sandbox restricts environment access" (fun () -> 457 + let config = Context.sandboxed_config 458 + ~capabilities:[Sandbox.Module_import] () in 459 + with_context ~config (fun ctx -> 460 + let v = Eval.string ctx "get-environment-variable" in 461 + assert_true (Sexp.is_void v))); 462 + 463 + test "sandbox allows file_read when granted" (fun () -> 464 + let config = Context.sandboxed_config 465 + ~capabilities:[Sandbox.Module_import; Sandbox.File_read] () in 466 + with_context ~config (fun ctx -> 467 + let v = Eval.string ctx "open-input-file" in 468 + assert_false (Sexp.is_void v))); 469 + 470 + test "sandbox allows process when granted" (fun () -> 471 + let config = Context.sandboxed_config 472 + ~capabilities:[Sandbox.Module_import; Sandbox.Process_exec; 473 + Sandbox.Env_access] () in 474 + with_context ~config (fun ctx -> 475 + (* command-line is from (scheme process-context), available 476 + in the interaction env when not blocked *) 477 + let v = Eval.string ctx "command-line" in 478 + assert_false (Sexp.is_void v))); 479 + 480 + test "sandbox with no capabilities runs pure code" (fun () -> 481 + let config = Context.sandboxed_config 482 + ~capabilities:[Sandbox.Module_import] () in 483 + with_context ~config (fun ctx -> 484 + (* Pure computation: map, filter, fold *) 485 + let result = Eval.to_int ctx 486 + "(apply + (map (lambda (x) (* x x)) '(1 2 3 4 5)))" in 487 + assert_equal_int 55 result)); 488 + 489 + test "sandbox without standard_io captures nothing" (fun () -> 490 + let config = Context.sandboxed_config 491 + ~capabilities:[Sandbox.Module_import] () in 492 + with_context ~config (fun ctx -> 493 + (* display goes to the null output port *) 494 + let _ = Eval.string ctx "(display \"hidden\")" in 495 + (* This should not crash; output just goes to /dev/null *) 496 + ())); 497 + 498 + test "full sandbox has all capabilities" (fun () -> 499 + assert_true (Sandbox.has_capability Sandbox.full Sandbox.File_read); 500 + assert_true (Sandbox.has_capability Sandbox.full Sandbox.Process_exec); 501 + assert_true (Sandbox.has_capability Sandbox.full Sandbox.Net_access)); 502 + 503 + test "none sandbox has no capabilities" (fun () -> 504 + assert_false (Sandbox.has_capability Sandbox.none Sandbox.File_read); 505 + assert_false (Sandbox.has_capability Sandbox.none Sandbox.Process_exec); 506 + assert_false (Sandbox.has_capability Sandbox.none Sandbox.Net_access)) 507 + 508 + let test_multiple_vms () = 509 + Printf.printf "\n=== Multiple VMs ===\n%!"; 510 + 511 + test "three independent VMs" (fun () -> 512 + let ctx1 = Context.create () in 513 + let ctx2 = Context.create () in 514 + let ctx3 = Context.create () in 515 + let _ = Eval.string ctx1 "(define counter 1)" in 516 + let _ = Eval.string ctx2 "(define counter 2)" in 517 + let _ = Eval.string ctx3 "(define counter 3)" in 518 + assert_equal_int 1 (Eval.to_int ctx1 "counter"); 519 + assert_equal_int 2 (Eval.to_int ctx2 "counter"); 520 + assert_equal_int 3 (Eval.to_int ctx3 "counter"); 521 + Context.destroy ctx1; 522 + (* ctx2 and ctx3 should still work *) 523 + assert_equal_int 2 (Eval.to_int ctx2 "counter"); 524 + assert_equal_int 3 (Eval.to_int ctx3 "counter"); 525 + Context.destroy ctx2; 526 + Context.destroy ctx3) 527 + 528 + let test_streaming () = 529 + Printf.printf "\n=== Streaming ===\n%!"; 530 + 531 + with_context (fun ctx -> 532 + test "fold over int sequence" (fun () -> 533 + let numbers = List.to_seq [1; 2; 3; 4; 5] in 534 + let sexp_seq = Stream.of_int_seq ctx numbers in 535 + let result = Stream.fold ctx 536 + ~expr:"(lambda (x acc) (+ acc x))" 537 + ~init:(Value.of_int ctx 0) 538 + sexp_seq in 539 + assert_equal_int 15 (Sexp.to_int result)); 540 + 541 + test "map over sequence" (fun () -> 542 + let numbers = List.to_seq [1; 2; 3] in 543 + let sexp_seq = Stream.of_int_seq ctx numbers in 544 + let proc = Eval.string ctx "(lambda (x) (* x 10))" in 545 + let mapped = Stream.map ctx ~proc sexp_seq in 546 + let results = Stream.to_int_list mapped in 547 + assert_equal_int 3 (List.length results); 548 + assert_equal_int 10 (List.nth results 0); 549 + assert_equal_int 20 (List.nth results 1); 550 + assert_equal_int 30 (List.nth results 2)); 551 + 552 + test "filter sequence" (fun () -> 553 + let numbers = List.to_seq [1; 2; 3; 4; 5; 6] in 554 + let sexp_seq = Stream.of_int_seq ctx numbers in 555 + let pred = Eval.string ctx "(lambda (x) (even? x))" in 556 + let filtered = Stream.filter ctx ~pred sexp_seq in 557 + let results = Stream.to_int_list filtered in 558 + assert_equal_int 3 (List.length results); 559 + assert_equal_int 2 (List.nth results 0); 560 + assert_equal_int 4 (List.nth results 1); 561 + assert_equal_int 6 (List.nth results 2)); 562 + 563 + test "string sequence" (fun () -> 564 + let words = List.to_seq ["hello"; "world"; "foo"] in 565 + let sexp_seq = Stream.of_string_seq ctx words in 566 + let proc = Eval.string ctx "(lambda (s) (string-length s))" in 567 + let mapped = Stream.map ctx ~proc sexp_seq in 568 + let results = Stream.to_int_list mapped in 569 + assert_equal_int 5 (List.nth results 0); 570 + assert_equal_int 5 (List.nth results 1); 571 + assert_equal_int 3 (List.nth results 2)); 572 + 573 + test "to_scheme_list" (fun () -> 574 + let numbers = List.to_seq [10; 20; 30] in 575 + let sexp_seq = Stream.of_int_seq ctx numbers in 576 + let lst = Stream.to_scheme_list ctx sexp_seq in 577 + assert_true (Sexp.is_pair lst); 578 + assert_equal_int 3 (Sexp.list_length lst)); 579 + 580 + test "effect-based producer" (fun () -> 581 + let producer = Stream.from_producer (fun () -> 582 + Effect.perform (Stream.Yield (Value.of_int ctx 1)); 583 + Effect.perform (Stream.Yield (Value.of_int ctx 2)); 584 + Effect.perform (Stream.Yield (Value.of_int ctx 3))) in 585 + let results = Stream.to_int_list producer in 586 + assert_equal_int 3 (List.length results); 587 + assert_equal_int 1 (List.nth results 0); 588 + assert_equal_int 2 (List.nth results 1); 589 + assert_equal_int 3 (List.nth results 2)); 590 + 591 + test "of_channel reads lines as scheme strings" (fun () -> 592 + let tmp = Filename.temp_file "chibi_test" ".txt" in 593 + (let oc = open_out tmp in 594 + output_string oc "alpha\nbeta\ngamma\n"; 595 + close_out oc); 596 + let ic = open_in tmp in 597 + let stream = Stream.of_channel ctx ic in 598 + let results = Stream.to_string_list stream in 599 + close_in ic; 600 + Sys.remove tmp; 601 + assert_equal_int 3 (List.length results); 602 + assert_equal_string "alpha" (List.nth results 0); 603 + assert_equal_string "beta" (List.nth results 1); 604 + assert_equal_string "gamma" (List.nth results 2))) 605 + 606 + let test_bytes () = 607 + Printf.printf "\n=== Bytes / Bytevectors ===\n%!"; 608 + 609 + with_context (fun ctx -> 610 + test "construct and extract bytes" (fun () -> 611 + let data = Bytes.of_string "\x01\x02\x03\x04" in 612 + let bv = Value.of_bytes ctx data in 613 + assert_true (Sexp.is_bytevector bv); 614 + let extracted = Sexp.to_bytes bv in 615 + assert_equal_int 4 (Bytes.length extracted); 616 + assert_equal_int 1 (Char.code (Bytes.get extracted 0)); 617 + assert_equal_int 4 (Char.code (Bytes.get extracted 3)))) 618 + 619 + let test_destroyed_context_safety () = 620 + Printf.printf "\n=== Destroyed Context Safety ===\n%!"; 621 + 622 + test "eval on destroyed context raises" (fun () -> 623 + let ctx = Context.create () in 624 + Context.destroy ctx; 625 + try 626 + let _ = Eval.string ctx "(+ 1 2)" in 627 + failwith "should have raised" 628 + with Context_destroyed -> ()); 629 + 630 + test "value construction on destroyed context raises" (fun () -> 631 + let ctx = Context.create () in 632 + Context.destroy ctx; 633 + try 634 + let _ = Value.of_int ctx 42 in 635 + failwith "should have raised" 636 + with Context_destroyed -> ()) 637 + 638 + let test_sexp_extras () = 639 + Printf.printf "\n=== Sexp Extras (char / eof / vector / equal / accessors) ===\n%!"; 640 + 641 + with_context (fun ctx -> 642 + test "of_char constructs and extracts char" (fun () -> 643 + let c = Value.of_char ctx 'Z' in 644 + assert_true (Sexp.is_char c); 645 + assert_equal_int (Char.code 'Z') (Sexp.to_char c)); 646 + 647 + test "of_char_code constructs char from code point" (fun () -> 648 + let c = Value.of_char_code ctx 955 in (* U+03BB lambda *) 649 + assert_true (Sexp.is_char c); 650 + assert_equal_int 955 (Sexp.to_char c)); 651 + 652 + test "classify char tag" (fun () -> 653 + match Sexp.classify (Value.of_char ctx 'a') with 654 + | Sexp.Char 97 -> () 655 + | _ -> failwith "wrong tag"); 656 + 657 + test "eof value is recognised" (fun () -> 658 + let v = Value.eof ctx in 659 + assert_true (Sexp.is_eof v)); 660 + 661 + test "classify eof tag" (fun () -> 662 + match Sexp.classify (Value.eof ctx) with 663 + | Sexp.Eof -> () 664 + | _ -> failwith "wrong tag"); 665 + 666 + test "of_array constructs an extractable vector" (fun () -> 667 + let arr = [| Value.of_int ctx 10; Value.of_int ctx 20; Value.of_int ctx 30 |] in 668 + let vec = Value.of_array ctx arr in 669 + assert_true (Sexp.is_vector vec); 670 + let back = Sexp.to_array vec in 671 + assert_equal_int 3 (Array.length back); 672 + assert_equal_int 20 (Sexp.to_int back.(1))); 673 + 674 + test "classify vector tag" (fun () -> 675 + let vec = Value.of_array ctx [| Value.of_int ctx 1 |] in 676 + match Sexp.classify vec with 677 + | Sexp.Vector -> () 678 + | _ -> failwith "wrong tag"); 679 + 680 + test "cadr extracts second element" (fun () -> 681 + let lst = Value.of_int_list ctx [1; 2; 3] in 682 + assert_equal_int 2 (Sexp.to_int (Sexp.cadr lst))); 683 + 684 + test "sexp equal - interned symbols are eq" (fun () -> 685 + let a = Value.of_symbol ctx "mysym" in 686 + let b = Value.of_symbol ctx "mysym" in 687 + assert_true (Sexp.equal a b)); 688 + 689 + test "sexp equal - distinct string objects are not eq" (fun () -> 690 + let a = Value.of_string ctx "hello" in 691 + let b = Value.of_string ctx "hello" in 692 + assert_false (Sexp.equal a b))) 693 + 694 + let test_io () = 695 + Printf.printf "\n=== IO / Port Capture ===\n%!"; 696 + 697 + (* Io.capture saves and restores ports, so multiple calls share one ctx *) 698 + with_context (fun ctx -> 699 + test "capture redirects scheme stdout and returns result" (fun () -> 700 + let (result, stdout, _stderr) = Io.capture ctx (fun () -> 701 + Eval.string ctx {|(begin (display "hello") 42)|}) in 702 + (match result with 703 + | Ok v -> assert_equal_int 42 (Sexp.to_int v) 704 + | Error e -> raise e); 705 + assert_equal_string "hello" stdout); 706 + 707 + test "capture restores ports so subsequent captures are independent" (fun () -> 708 + let (_, s1, _) = Io.capture ctx (fun () -> 709 + Eval.string ctx "(display \"first\")") in 710 + let (_, s2, _) = Io.capture ctx (fun () -> 711 + Eval.string ctx "(display \"second\")") in 712 + assert_equal_string "first" s1; 713 + assert_equal_string "second" s2)); 714 + 715 + (* set_input_string permanently replaces the input port - use its own ctx *) 716 + test "set_input_string lets scheme (read) from a string" (fun () -> 717 + with_context (fun ctx -> 718 + Io.set_input_string ctx "99"; 719 + let v = Eval.string ctx "(read)" in 720 + assert_equal_int 99 (Sexp.to_int v))); 721 + 722 + (* redirect_output permanently replaces the output port - use its own ctx *) 723 + test "redirect_output captures scheme display output" (fun () -> 724 + with_context (fun ctx -> 725 + let get = Io.redirect_output ctx in 726 + let _ = Eval.string ctx "(display \"captured\")" in 727 + assert_equal_string "captured" (get ()))) 728 + 729 + (* ---- Main ---- *) 730 + let () = 731 + Printf.printf "chibi-ocaml test suite\n"; 732 + Printf.printf "======================\n%!"; 733 + 734 + test_context_lifecycle (); 735 + test_basic_eval (); 736 + test_value_construction (); 737 + test_sexp_classify (); 738 + test_sexp_extras (); 739 + test_env_bindings (); 740 + test_foreign_functions (); 741 + test_write_display (); 742 + test_read_parse (); 743 + test_apply (); 744 + test_gc (); 745 + test_sandbox (); 746 + test_multiple_vms (); 747 + test_streaming (); 748 + test_bytes (); 749 + test_io (); 750 + test_destroyed_context_safety (); 751 + 752 + Printf.printf "\n======================\n"; 753 + Printf.printf "Results: %d/%d passed\n%!" (!test_count - !fail_count) !test_count; 754 + if !fail_count > 0 then begin 755 + Printf.printf "%d FAILURES\n%!" !fail_count; 756 + exit 1 757 + end else 758 + Printf.printf "All tests passed!\n%!"
+98
test_runner/diagnose.ml
··· 1 + (** Diagnose specific test failures by dumping full output *) 2 + 3 + open Chibi_ocaml.Chibi 4 + 5 + let vendor_dir = 6 + let exe = Sys.executable_name in 7 + let dir = Filename.dirname exe in 8 + let candidates = [ 9 + Filename.concat dir "../../../vendor/chibi-scheme"; 10 + Filename.concat dir "../../vendor/chibi-scheme"; 11 + "vendor/chibi-scheme"; 12 + ] in 13 + match List.find_opt (fun d -> 14 + Sys.file_exists (Filename.concat d "lib/init-7.scm")) candidates 15 + with Some d -> d | None -> failwith "vendor dir not found" 16 + 17 + let tests_dir = Filename.concat vendor_dir "tests" 18 + 19 + let read_file path = 20 + let ic = open_in path in 21 + Fun.protect ~finally:(fun () -> close_in ic) (fun () -> 22 + really_input_string ic (in_channel_length ic)) 23 + 24 + let run_test name file = 25 + Printf.printf "\n=== %s ===\n%!" name; 26 + let config = Context.{ default_config with max_heap_size = 128 * 1024 * 1024 } in 27 + let ctx = Context.create ~config () in 28 + Fun.protect ~finally:(fun () -> Context.destroy ctx) (fun () -> 29 + let (result, stdout, stderr) = Io.capture ctx (fun () -> 30 + Eval.load_direct ctx file) in 31 + (* Print only FAIL lines from stdout *) 32 + let lines = String.split_on_char '\n' stdout in 33 + let fail_lines = List.filter (fun l -> 34 + let t = String.trim l in 35 + String.length t > 0 && 36 + (try String.sub t 0 4 = "FAIL" with _ -> false) || 37 + (try String.sub t 0 8 = "expected" with _ -> false) || 38 + (try let _ = String.index t '[' in 39 + String.contains l 'F' && String.contains l 'A' && String.contains l 'I' && String.contains l 'L' 40 + with _ -> false) 41 + ) lines in 42 + Printf.printf "FAIL lines from stdout:\n"; 43 + List.iter (fun l -> Printf.printf " %s\n" l) fail_lines; 44 + (* Print stderr warnings *) 45 + if stderr <> "" then begin 46 + Printf.printf "\nStderr (first 500 chars):\n %s\n" 47 + (String.sub stderr 0 (min 500 (String.length stderr))) 48 + end; 49 + (match result with 50 + | Ok _ -> Printf.printf "\nResult: OK\n%!" 51 + | Error e -> Printf.printf "\nResult: ERROR %s\n%!" (Printexc.to_string e)); 52 + (* Summary counts *) 53 + List.iter (fun l -> 54 + try Scanf.sscanf l " %d out of %d " (fun p t -> 55 + Printf.printf " => %d/%d\n" p t) 56 + with _ -> () 57 + ) lines) 58 + 59 + let () = 60 + Printf.printf "=== Diagnosing test failures ===\n%!"; 61 + 62 + (* R7RS *) 63 + run_test "R7RS" (Filename.concat tests_dir "r7rs-tests.scm"); 64 + 65 + (* Division *) 66 + run_test "Division" (Filename.concat tests_dir "division-tests.scm"); 67 + 68 + (* Lib tests *) 69 + run_test "Lib Tests" (Filename.concat tests_dir "lib-tests.scm"); 70 + 71 + (* Basic test10 *) 72 + Printf.printf "\n=== basic/test10-unhygiene ===\n%!"; 73 + let ctx = Context.create () in 74 + let file = Filename.concat tests_dir "basic/test10-unhygiene.scm" in 75 + let (_, stdout, _) = Io.capture ctx (fun () -> Eval.load_direct ctx file) in 76 + Printf.printf "Output:\n%s\n" stdout; 77 + Printf.printf "Expected:\n%s\n" (read_file (Filename.concat tests_dir "basic/test10-unhygiene.res")); 78 + Context.destroy ctx; 79 + 80 + (* Syntax tests *) 81 + Printf.printf "\n=== Syntax Tests ===\n%!"; 82 + let ctx = Context.create ~config:Context.{ default_config with max_heap_size = 128 * 1024 * 1024 } () in 83 + let file = Filename.concat tests_dir "syntax-tests.scm" in 84 + let (result, stdout, stderr) = Io.capture ctx (fun () -> Eval.load_direct ctx file) in 85 + Printf.printf "stdout[%d]: %s\n" (String.length stdout) (String.sub stdout 0 (min 500 (String.length stdout))); 86 + Printf.printf "stderr[%d]: %s\n" (String.length stderr) (String.sub stderr 0 (min 500 (String.length stderr))); 87 + (match result with Ok _ -> Printf.printf "OK\n%!" | Error e -> Printf.printf "ERROR: %s\n%!" (Printexc.to_string e)); 88 + Context.destroy ctx; 89 + 90 + (* Unicode tests *) 91 + Printf.printf "\n=== Unicode Tests ===\n%!"; 92 + let ctx = Context.create ~config:Context.{ default_config with max_heap_size = 128 * 1024 * 1024 } () in 93 + let file = Filename.concat tests_dir "unicode-tests.scm" in 94 + let (result, stdout, stderr) = Io.capture ctx (fun () -> Eval.load_direct ctx file) in 95 + Printf.printf "stdout[%d]: %s\n" (String.length stdout) (String.sub stdout 0 (min 500 (String.length stdout))); 96 + Printf.printf "stderr[%d]: %s\n" (String.length stderr) (String.sub stderr 0 (min 500 (String.length stderr))); 97 + (match result with Ok _ -> Printf.printf "OK\n%!" | Error e -> Printf.printf "ERROR: %s\n%!" (Printexc.to_string e)); 98 + Context.destroy ctx
+3
test_runner/dune
··· 1 + (executables 2 + (names run_chibi_tests diagnose) 3 + (libraries chibi_ocaml))
+404
test_runner/run_chibi_tests.ml
··· 1 + (** Run the chibi-scheme test suites through our OCaml bindings. 2 + 3 + This program exercises the full chibi-scheme test infrastructure 4 + through the chibi-ocaml library, verifying that the embedded VM 5 + can correctly execute all the standard tests. *) 6 + 7 + open Chibi_ocaml.Chibi 8 + 9 + (* ---------- Helpers ---------- *) 10 + 11 + let vendor_dir = 12 + (* Find the vendor directory relative to this executable *) 13 + let exe = Sys.executable_name in 14 + let dir = Filename.dirname exe in 15 + let candidates = [ 16 + Filename.concat dir "../../../vendor/chibi-scheme"; 17 + Filename.concat dir "../../vendor/chibi-scheme"; 18 + Filename.concat dir "../vendor/chibi-scheme"; 19 + "vendor/chibi-scheme"; 20 + ] in 21 + match List.find_opt (fun d -> 22 + Sys.file_exists (Filename.concat d "lib/init-7.scm")) candidates 23 + with 24 + | Some d -> d 25 + | None -> failwith "Cannot find vendor/chibi-scheme directory" 26 + 27 + let tests_dir = Filename.concat vendor_dir "tests" 28 + let lib_dir = Filename.concat vendor_dir "lib" 29 + 30 + (** Create a context suitable for running tests. 31 + Full access, with module path pointing at vendored lib. *) 32 + let make_test_context ?(max_heap = 64 * 1024 * 1024) () = 33 + let config = Context.{ 34 + default_config with 35 + max_heap_size = max_heap; 36 + } in 37 + Context.create ~config () 38 + 39 + (** Read a file's contents *) 40 + let read_file path = 41 + let ic = open_in path in 42 + Fun.protect ~finally:(fun () -> close_in ic) (fun () -> 43 + let n = in_channel_length ic in 44 + really_input_string ic n) 45 + 46 + (** Capture the output of evaluating a single expression *) 47 + let eval_capturing_output ctx code = 48 + Io.capture ctx (fun () -> Eval.string ctx code) 49 + 50 + (** Load a .scm file and capture its output. 51 + Uses load_direct to properly handle top-level import forms. *) 52 + let load_capturing_output ctx file = 53 + Io.capture ctx (fun () -> Eval.load_direct ctx file) 54 + 55 + (** Evaluate multi-expression code by writing to a temp file and loading. 56 + This properly handles import and other top-level forms. *) 57 + let eval_multi_capturing_output ctx code = 58 + let tmpfile = Filename.temp_file "chibi_test_" ".scm" in 59 + Fun.protect ~finally:(fun () -> Sys.remove tmpfile) (fun () -> 60 + let oc = open_out tmpfile in 61 + output_string oc code; 62 + close_out oc; 63 + Io.capture ctx (fun () -> Eval.load_direct ctx tmpfile)) 64 + 65 + (* ---------- Result tracking ---------- *) 66 + 67 + type suite_result = { 68 + name : string; 69 + passed : bool; 70 + stdout : string; 71 + stderr : string; 72 + error : string option; 73 + details : string; 74 + } 75 + 76 + let suites_run = ref 0 77 + let suites_passed = ref 0 78 + let suites_failed = ref 0 79 + let suites_skipped = ref 0 80 + let all_results : suite_result list ref = ref [] 81 + 82 + let record_result r = 83 + all_results := r :: !all_results; 84 + incr suites_run; 85 + if r.passed then incr suites_passed 86 + else incr suites_failed 87 + 88 + let record_skip name reason = 89 + all_results := { name; passed = true; stdout = ""; stderr = ""; 90 + error = None; details = "SKIPPED: " ^ reason } :: !all_results; 91 + incr suites_skipped 92 + 93 + (* ---------- Parse (chibi test) output ---------- *) 94 + 95 + (** Strip ANSI escape codes from a string *) 96 + let strip_ansi s = 97 + let buf = Buffer.create (String.length s) in 98 + let i = ref 0 in 99 + while !i < String.length s do 100 + if !i + 1 < String.length s && s.[!i] = '\027' && s.[!i + 1] = '[' then begin 101 + (* Skip until we find a letter *) 102 + i := !i + 2; 103 + while !i < String.length s && 104 + not (Char.code s.[!i] >= Char.code 'A' && Char.code s.[!i] <= Char.code 'z') do 105 + incr i 106 + done; 107 + if !i < String.length s then incr i (* skip the final letter *) 108 + end else begin 109 + Buffer.add_char buf s.[!i]; 110 + incr i 111 + end 112 + done; 113 + Buffer.contents buf 114 + 115 + (** Extract pass/fail counts from (chibi test) output. 116 + We strip ANSI codes first, then find the LAST "N out of M ... tests passed" 117 + line (which is the top-level summary). We also look for "subgroups" lines 118 + and skip those. *) 119 + let parse_chibi_test_output output = 120 + let clean = strip_ansi output in 121 + let lines = String.split_on_char '\n' clean in 122 + let last_pass = ref 0 in 123 + let last_total = ref 0 in 124 + let failures = Buffer.create 256 in 125 + List.iter (fun line -> 126 + let trimmed = String.trim line in 127 + (* Skip "subgroups passed" lines *) 128 + if not (try ignore (Scanf.sscanf trimmed "%_d out of %_d %_s@subgroups" ()); true 129 + with _ -> false) then begin 130 + (* Look for "N out of M (X%) tests passed" - the standard summary format *) 131 + (try 132 + Scanf.sscanf trimmed "%d out of %d (%_f%%) tests passed" (fun passed total -> 133 + (* Always take the last "tests passed" line = top-level summary *) 134 + last_pass := passed; 135 + last_total := total) 136 + with _ -> ()) 137 + end; 138 + (* Collect FAIL lines *) 139 + if String.length trimmed > 4 then begin 140 + if (try String.sub trimmed 0 5 = "FAIL:" with _ -> false) then begin 141 + Buffer.add_string failures trimmed; 142 + Buffer.add_char failures '\n' 143 + end 144 + end 145 + ) lines; 146 + (!last_pass, !last_total, Buffer.contents failures) 147 + 148 + (* ---------- Test suite runners ---------- *) 149 + 150 + (** Run a basic test: load .scm file, compare output to .res file *) 151 + let run_basic_test name scm_file res_file = 152 + Printf.printf " %-50s" name; 153 + let ctx = make_test_context () in 154 + Fun.protect ~finally:(fun () -> Context.destroy ctx) (fun () -> 155 + let expected = String.trim (read_file res_file) in 156 + let (_result, stdout, stderr) = load_capturing_output ctx scm_file in 157 + let _ = stderr in 158 + let actual = String.trim stdout in 159 + if actual = expected then begin 160 + Printf.printf " [PASS]\n%!"; 161 + record_result { name; passed = true; stdout; stderr; 162 + error = None; details = "" } 163 + end else begin 164 + Printf.printf " [FAIL]\n%!"; 165 + let details = Printf.sprintf 166 + "Expected:\n%s\nGot:\n%s" expected actual in 167 + record_result { name; passed = false; stdout; stderr; 168 + error = None; details } 169 + end) 170 + 171 + (** Run a (chibi test)-based test suite from a .scm file *) 172 + let run_chibi_test_suite name scm_file = 173 + Printf.printf " %-50s" name; 174 + let ctx = make_test_context ~max_heap:(128 * 1024 * 1024) () in 175 + Fun.protect ~finally:(fun () -> Context.destroy ctx) (fun () -> 176 + let (_result, stdout, stderr) = load_capturing_output ctx scm_file in 177 + let (passed, total, fail_details) = parse_chibi_test_output stdout in 178 + if total = 0 then begin 179 + (* Might have errored before running any tests *) 180 + let err_msg = if stderr <> "" then stderr 181 + else match _result with 182 + | Error e -> Printexc.to_string e 183 + | Ok _ -> "no tests found in output" in 184 + Printf.printf " [ERROR] %s\n%!" (String.sub err_msg 0 (min 60 (String.length err_msg))); 185 + record_result { name; passed = false; stdout; stderr; 186 + error = Some err_msg; 187 + details = "No test results found" } 188 + end else if passed = total then begin 189 + Printf.printf " [PASS] %d/%d\n%!" passed total; 190 + record_result { name; passed = true; stdout; stderr; 191 + error = None; 192 + details = Printf.sprintf "%d/%d tests passed" passed total } 193 + end else begin 194 + Printf.printf " [FAIL] %d/%d\n%!" passed total; 195 + record_result { name; passed = false; stdout; stderr; 196 + error = None; 197 + details = Printf.sprintf "%d/%d tests passed\n%s" 198 + passed total fail_details } 199 + end) 200 + 201 + (** Run a (chibi test)-based test suite from inline Scheme code *) 202 + let run_inline_test_suite name code = 203 + Printf.printf " %-50s" name; 204 + let ctx = make_test_context ~max_heap:(128 * 1024 * 1024) () in 205 + Fun.protect ~finally:(fun () -> Context.destroy ctx) (fun () -> 206 + let (_result, stdout, stderr) = eval_multi_capturing_output ctx code in 207 + let (passed, total, fail_details) = parse_chibi_test_output stdout in 208 + if total = 0 then begin 209 + let err_msg = if stderr <> "" then stderr 210 + else match _result with 211 + | Error e -> Printexc.to_string e 212 + | Ok _ -> "no tests found in output" in 213 + Printf.printf " [ERROR] %s\n%!" (String.sub err_msg 0 (min 80 (String.length err_msg))); 214 + record_result { name; passed = false; stdout; stderr; 215 + error = Some err_msg; 216 + details = "No test results found" } 217 + end else if passed = total then begin 218 + Printf.printf " [PASS] %d/%d\n%!" passed total; 219 + record_result { name; passed = true; stdout; stderr; 220 + error = None; 221 + details = Printf.sprintf "%d/%d tests passed" passed total } 222 + end else begin 223 + Printf.printf " [FAIL] %d/%d\n%!" passed total; 224 + record_result { name; passed = false; stdout; stderr; 225 + error = None; 226 + details = Printf.sprintf "%d/%d tests passed\n%s" 227 + passed total fail_details } 228 + end) 229 + 230 + (* ---------- Test Suite Definitions ---------- *) 231 + 232 + let run_basic_tests () = 233 + Printf.printf "\n=== Basic Tests ===\n%!"; 234 + let basic_dir = Filename.concat tests_dir "basic" in 235 + if Sys.file_exists basic_dir then begin 236 + let files = Sys.readdir basic_dir in 237 + let scm_files = Array.to_list files 238 + |> List.filter (fun f -> Filename.check_suffix f ".scm") 239 + |> List.sort String.compare in 240 + List.iter (fun scm -> 241 + let base = Filename.chop_suffix scm ".scm" in 242 + let scm_path = Filename.concat basic_dir scm in 243 + let res_path = Filename.concat basic_dir (base ^ ".res") in 244 + if Sys.file_exists res_path then 245 + run_basic_test (Printf.sprintf "basic/%s" base) scm_path res_path 246 + else 247 + record_skip (Printf.sprintf "basic/%s" base) "no .res file" 248 + ) scm_files 249 + end else 250 + Printf.printf " (basic test directory not found, skipping)\n%!" 251 + 252 + let run_r5rs_tests () = 253 + Printf.printf "\n=== R5RS Tests ===\n%!"; 254 + let file = Filename.concat tests_dir "r5rs-tests.scm" in 255 + if Sys.file_exists file then begin 256 + Printf.printf " %-50s" "r5rs-tests"; 257 + let ctx = make_test_context () in 258 + Fun.protect ~finally:(fun () -> Context.destroy ctx) (fun () -> 259 + let (_result, stdout, stderr) = load_capturing_output ctx file in 260 + (* R5RS tests use their own format: "N out of M passed (X%)" *) 261 + let lines = String.split_on_char '\n' stdout in 262 + let summary = List.find_opt (fun l -> 263 + try let _ = Scanf.sscanf l "%d out of %d passed" (fun _ _ -> ()) in true 264 + with _ -> false) lines in 265 + match summary with 266 + | Some line -> 267 + let (passed, total) = Scanf.sscanf line "%d out of %d passed" (fun a b -> (a, b)) in 268 + if passed = total then begin 269 + Printf.printf " [PASS] %d/%d\n%!" passed total; 270 + record_result { name = "r5rs-tests"; passed = true; stdout; stderr; 271 + error = None; 272 + details = Printf.sprintf "%d/%d passed" passed total } 273 + end else begin 274 + Printf.printf " [FAIL] %d/%d\n%!" passed total; 275 + (* Find [FAIL] lines *) 276 + let fails = List.filter (fun l -> 277 + try ignore (Scanf.sscanf l "%_s [FAIL]" ()); true 278 + with _ -> String.length l > 6 && 279 + String.sub l (String.length l - 6) 6 = "[FAIL]" 280 + ) lines in 281 + record_result { name = "r5rs-tests"; passed = false; stdout; stderr; 282 + error = None; 283 + details = Printf.sprintf "%d/%d passed\n%s" 284 + passed total (String.concat "\n" fails) } 285 + end 286 + | None -> 287 + let err_msg = if stderr <> "" then stderr else "no summary line found" in 288 + Printf.printf " [ERROR]\n%!"; 289 + record_result { name = "r5rs-tests"; passed = false; stdout; stderr; 290 + error = Some err_msg; details = "Could not parse output" }) 291 + end else 292 + record_skip "r5rs-tests" "file not found" 293 + 294 + let run_r7rs_tests () = 295 + Printf.printf "\n=== R7RS Tests ===\n%!"; 296 + let file = Filename.concat tests_dir "r7rs-tests.scm" in 297 + if Sys.file_exists file then 298 + run_chibi_test_suite "r7rs-tests" file 299 + else 300 + record_skip "r7rs-tests" "file not found" 301 + 302 + let run_division_tests () = 303 + Printf.printf "\n=== Division Tests ===\n%!"; 304 + let file = Filename.concat tests_dir "division-tests.scm" in 305 + if Sys.file_exists file then 306 + run_chibi_test_suite "division-tests" file 307 + else 308 + record_skip "division-tests" "file not found" 309 + 310 + let run_syntax_tests () = 311 + Printf.printf "\n=== Syntax Tests ===\n%!"; 312 + let file = Filename.concat tests_dir "syntax-tests.scm" in 313 + if Sys.file_exists file then 314 + run_chibi_test_suite "syntax-tests" file 315 + else 316 + record_skip "syntax-tests" "file not found" 317 + 318 + let run_unicode_tests () = 319 + Printf.printf "\n=== Unicode Tests ===\n%!"; 320 + let file = Filename.concat tests_dir "unicode-tests.scm" in 321 + if Sys.file_exists file then 322 + run_chibi_test_suite "unicode-tests" file 323 + else 324 + record_skip "unicode-tests" "file not found" 325 + 326 + (** Run the combined library tests using chibi's own lib-tests.scm. 327 + This runs all SRFI + chibi library tests in one shot. 328 + This is how chibi-scheme's own test infrastructure works. *) 329 + let run_library_tests () = 330 + Printf.printf "\n=== Library Tests (lib-tests.scm) ===\n%!"; 331 + let file = Filename.concat tests_dir "lib-tests.scm" in 332 + if Sys.file_exists file then begin 333 + (* chdir to the vendor dir so relative paths like "tests/re-tests.txt" work *) 334 + let original_dir = Sys.getcwd () in 335 + Sys.chdir vendor_dir; 336 + Fun.protect ~finally:(fun () -> Sys.chdir original_dir) (fun () -> 337 + run_chibi_test_suite "lib-tests (all SRFIs + chibi libs)" file) 338 + end else begin 339 + Printf.printf " lib-tests.scm not found, skipping\n%!"; 340 + record_skip "lib-tests" "file not found" 341 + end 342 + 343 + (* ---------- Summary ---------- *) 344 + 345 + let print_summary () = 346 + Printf.printf "\n"; 347 + Printf.printf "========================================================\n"; 348 + Printf.printf " SUMMARY\n"; 349 + Printf.printf "========================================================\n"; 350 + Printf.printf " Suites run: %d\n" !suites_run; 351 + Printf.printf " Suites passed: %d\n" !suites_passed; 352 + Printf.printf " Suites failed: %d\n" !suites_failed; 353 + Printf.printf " Suites skipped: %d\n" !suites_skipped; 354 + Printf.printf "========================================================\n"; 355 + 356 + if !suites_failed > 0 then begin 357 + Printf.printf "\nFailed suites:\n"; 358 + List.iter (fun r -> 359 + if not r.passed then begin 360 + Printf.printf " - %s\n" r.name; 361 + if r.details <> "" then begin 362 + let lines = String.split_on_char '\n' r.details in 363 + List.iter (fun l -> 364 + if l <> "" then Printf.printf " %s\n" l 365 + ) (List.filteri (fun i _ -> i < 10) lines); 366 + if List.length lines > 10 then 367 + Printf.printf " ... (%d more lines)\n" (List.length lines - 10) 368 + end; 369 + (match r.error with 370 + | Some e -> 371 + let lines = String.split_on_char '\n' e in 372 + List.iter (fun l -> 373 + if l <> "" then Printf.printf " error: %s\n" l 374 + ) (List.filteri (fun i _ -> i < 5) lines) 375 + | None -> ()) 376 + end 377 + ) (List.rev !all_results) 378 + end; 379 + 380 + Printf.printf "\n" 381 + 382 + (* ---------- Main ---------- *) 383 + 384 + let () = 385 + Printf.printf "chibi-scheme test runner (via chibi-ocaml)\n"; 386 + Printf.printf "==========================================\n"; 387 + Printf.printf "vendor dir: %s\n" vendor_dir; 388 + Printf.printf "tests dir: %s\n" tests_dir; 389 + Printf.printf "lib dir: %s\n%!" lib_dir; 390 + 391 + run_basic_tests (); 392 + run_r5rs_tests (); 393 + run_r7rs_tests (); 394 + run_division_tests (); 395 + run_syntax_tests (); 396 + run_unicode_tests (); 397 + run_library_tests (); 398 + 399 + print_summary (); 400 + 401 + if !suites_failed > 0 then 402 + exit 1 403 + else 404 + Printf.printf "All test suites passed!\n%!"