+3

test/dune

reviewed

··· 1 1 + (test 2 2 + (name test_chibi_ocaml) 3 3 + (libraries chibi_ocaml))

+758

test/test_chibi_ocaml.ml

reviewed

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

+98

test_runner/diagnose.ml

reviewed

··· 1 1 + (** Diagnose specific test failures by dumping full output *) 2 2 + 3 3 + open Chibi_ocaml.Chibi 4 4 + 5 5 + let vendor_dir = 6 6 + let exe = Sys.executable_name in 7 7 + let dir = Filename.dirname exe in 8 8 + let candidates = [ 9 9 + Filename.concat dir "../../../vendor/chibi-scheme"; 10 10 + Filename.concat dir "../../vendor/chibi-scheme"; 11 11 + "vendor/chibi-scheme"; 12 12 + ] in 13 13 + match List.find_opt (fun d -> 14 14 + Sys.file_exists (Filename.concat d "lib/init-7.scm")) candidates 15 15 + with Some d -> d | None -> failwith "vendor dir not found" 16 16 + 17 17 + let tests_dir = Filename.concat vendor_dir "tests" 18 18 + 19 19 + let read_file path = 20 20 + let ic = open_in path in 21 21 + Fun.protect ~finally:(fun () -> close_in ic) (fun () -> 22 22 + really_input_string ic (in_channel_length ic)) 23 23 + 24 24 + let run_test name file = 25 25 + Printf.printf "\n=== %s ===\n%!" name; 26 26 + let config = Context.{ default_config with max_heap_size = 128 * 1024 * 1024 } in 27 27 + let ctx = Context.create ~config () in 28 28 + Fun.protect ~finally:(fun () -> Context.destroy ctx) (fun () -> 29 29 + let (result, stdout, stderr) = Io.capture ctx (fun () -> 30 30 + Eval.load_direct ctx file) in 31 31 + (* Print only FAIL lines from stdout *) 32 32 + let lines = String.split_on_char '\n' stdout in 33 33 + let fail_lines = List.filter (fun l -> 34 34 + let t = String.trim l in 35 35 + String.length t > 0 && 36 36 + (try String.sub t 0 4 = "FAIL" with _ -> false) || 37 37 + (try String.sub t 0 8 = "expected" with _ -> false) || 38 38 + (try let _ = String.index t '[' in 39 39 + String.contains l 'F' && String.contains l 'A' && String.contains l 'I' && String.contains l 'L' 40 40 + with _ -> false) 41 41 + ) lines in 42 42 + Printf.printf "FAIL lines from stdout:\n"; 43 43 + List.iter (fun l -> Printf.printf " %s\n" l) fail_lines; 44 44 + (* Print stderr warnings *) 45 45 + if stderr <> "" then begin 46 46 + Printf.printf "\nStderr (first 500 chars):\n %s\n" 47 47 + (String.sub stderr 0 (min 500 (String.length stderr))) 48 48 + end; 49 49 + (match result with 50 50 + | Ok _ -> Printf.printf "\nResult: OK\n%!" 51 51 + | Error e -> Printf.printf "\nResult: ERROR %s\n%!" (Printexc.to_string e)); 52 52 + (* Summary counts *) 53 53 + List.iter (fun l -> 54 54 + try Scanf.sscanf l " %d out of %d " (fun p t -> 55 55 + Printf.printf " => %d/%d\n" p t) 56 56 + with _ -> () 57 57 + ) lines) 58 58 + 59 59 + let () = 60 60 + Printf.printf "=== Diagnosing test failures ===\n%!"; 61 61 + 62 62 + (* R7RS *) 63 63 + run_test "R7RS" (Filename.concat tests_dir "r7rs-tests.scm"); 64 64 + 65 65 + (* Division *) 66 66 + run_test "Division" (Filename.concat tests_dir "division-tests.scm"); 67 67 + 68 68 + (* Lib tests *) 69 69 + run_test "Lib Tests" (Filename.concat tests_dir "lib-tests.scm"); 70 70 + 71 71 + (* Basic test10 *) 72 72 + Printf.printf "\n=== basic/test10-unhygiene ===\n%!"; 73 73 + let ctx = Context.create () in 74 74 + let file = Filename.concat tests_dir "basic/test10-unhygiene.scm" in 75 75 + let (_, stdout, _) = Io.capture ctx (fun () -> Eval.load_direct ctx file) in 76 76 + Printf.printf "Output:\n%s\n" stdout; 77 77 + Printf.printf "Expected:\n%s\n" (read_file (Filename.concat tests_dir "basic/test10-unhygiene.res")); 78 78 + Context.destroy ctx; 79 79 + 80 80 + (* Syntax tests *) 81 81 + Printf.printf "\n=== Syntax Tests ===\n%!"; 82 82 + let ctx = Context.create ~config:Context.{ default_config with max_heap_size = 128 * 1024 * 1024 } () in 83 83 + let file = Filename.concat tests_dir "syntax-tests.scm" in 84 84 + let (result, stdout, stderr) = Io.capture ctx (fun () -> Eval.load_direct ctx file) in 85 85 + Printf.printf "stdout[%d]: %s\n" (String.length stdout) (String.sub stdout 0 (min 500 (String.length stdout))); 86 86 + Printf.printf "stderr[%d]: %s\n" (String.length stderr) (String.sub stderr 0 (min 500 (String.length stderr))); 87 87 + (match result with Ok _ -> Printf.printf "OK\n%!" | Error e -> Printf.printf "ERROR: %s\n%!" (Printexc.to_string e)); 88 88 + Context.destroy ctx; 89 89 + 90 90 + (* Unicode tests *) 91 91 + Printf.printf "\n=== Unicode Tests ===\n%!"; 92 92 + let ctx = Context.create ~config:Context.{ default_config with max_heap_size = 128 * 1024 * 1024 } () in 93 93 + let file = Filename.concat tests_dir "unicode-tests.scm" in 94 94 + let (result, stdout, stderr) = Io.capture ctx (fun () -> Eval.load_direct ctx file) in 95 95 + Printf.printf "stdout[%d]: %s\n" (String.length stdout) (String.sub stdout 0 (min 500 (String.length stdout))); 96 96 + Printf.printf "stderr[%d]: %s\n" (String.length stderr) (String.sub stderr 0 (min 500 (String.length stderr))); 97 97 + (match result with Ok _ -> Printf.printf "OK\n%!" | Error e -> Printf.printf "ERROR: %s\n%!" (Printexc.to_string e)); 98 98 + Context.destroy ctx

+3

test_runner/dune

reviewed

··· 1 1 + (executables 2 2 + (names run_chibi_tests diagnose) 3 3 + (libraries chibi_ocaml))

+404

test_runner/run_chibi_tests.ml

reviewed

··· 1 1 + (** Run the chibi-scheme test suites through our OCaml bindings. 2 2 + 3 3 + This program exercises the full chibi-scheme test infrastructure 4 4 + through the chibi-ocaml library, verifying that the embedded VM 5 5 + can correctly execute all the standard tests. *) 6 6 + 7 7 + open Chibi_ocaml.Chibi 8 8 + 9 9 + (* ---------- Helpers ---------- *) 10 10 + 11 11 + let vendor_dir = 12 12 + (* Find the vendor directory relative to this executable *) 13 13 + let exe = Sys.executable_name in 14 14 + let dir = Filename.dirname exe in 15 15 + let candidates = [ 16 16 + Filename.concat dir "../../../vendor/chibi-scheme"; 17 17 + Filename.concat dir "../../vendor/chibi-scheme"; 18 18 + Filename.concat dir "../vendor/chibi-scheme"; 19 19 + "vendor/chibi-scheme"; 20 20 + ] in 21 21 + match List.find_opt (fun d -> 22 22 + Sys.file_exists (Filename.concat d "lib/init-7.scm")) candidates 23 23 + with 24 24 + | Some d -> d 25 25 + | None -> failwith "Cannot find vendor/chibi-scheme directory" 26 26 + 27 27 + let tests_dir = Filename.concat vendor_dir "tests" 28 28 + let lib_dir = Filename.concat vendor_dir "lib" 29 29 + 30 30 + (** Create a context suitable for running tests. 31 31 + Full access, with module path pointing at vendored lib. *) 32 32 + let make_test_context ?(max_heap = 64 * 1024 * 1024) () = 33 33 + let config = Context.{ 34 34 + default_config with 35 35 + max_heap_size = max_heap; 36 36 + } in 37 37 + Context.create ~config () 38 38 + 39 39 + (** Read a file's contents *) 40 40 + let read_file path = 41 41 + let ic = open_in path in 42 42 + Fun.protect ~finally:(fun () -> close_in ic) (fun () -> 43 43 + let n = in_channel_length ic in 44 44 + really_input_string ic n) 45 45 + 46 46 + (** Capture the output of evaluating a single expression *) 47 47 + let eval_capturing_output ctx code = 48 48 + Io.capture ctx (fun () -> Eval.string ctx code) 49 49 + 50 50 + (** Load a .scm file and capture its output. 51 51 + Uses load_direct to properly handle top-level import forms. *) 52 52 + let load_capturing_output ctx file = 53 53 + Io.capture ctx (fun () -> Eval.load_direct ctx file) 54 54 + 55 55 + (** Evaluate multi-expression code by writing to a temp file and loading. 56 56 + This properly handles import and other top-level forms. *) 57 57 + let eval_multi_capturing_output ctx code = 58 58 + let tmpfile = Filename.temp_file "chibi_test_" ".scm" in 59 59 + Fun.protect ~finally:(fun () -> Sys.remove tmpfile) (fun () -> 60 60 + let oc = open_out tmpfile in 61 61 + output_string oc code; 62 62 + close_out oc; 63 63 + Io.capture ctx (fun () -> Eval.load_direct ctx tmpfile)) 64 64 + 65 65 + (* ---------- Result tracking ---------- *) 66 66 + 67 67 + type suite_result = { 68 68 + name : string; 69 69 + passed : bool; 70 70 + stdout : string; 71 71 + stderr : string; 72 72 + error : string option; 73 73 + details : string; 74 74 + } 75 75 + 76 76 + let suites_run = ref 0 77 77 + let suites_passed = ref 0 78 78 + let suites_failed = ref 0 79 79 + let suites_skipped = ref 0 80 80 + let all_results : suite_result list ref = ref [] 81 81 + 82 82 + let record_result r = 83 83 + all_results := r :: !all_results; 84 84 + incr suites_run; 85 85 + if r.passed then incr suites_passed 86 86 + else incr suites_failed 87 87 + 88 88 + let record_skip name reason = 89 89 + all_results := { name; passed = true; stdout = ""; stderr = ""; 90 90 + error = None; details = "SKIPPED: " ^ reason } :: !all_results; 91 91 + incr suites_skipped 92 92 + 93 93 + (* ---------- Parse (chibi test) output ---------- *) 94 94 + 95 95 + (** Strip ANSI escape codes from a string *) 96 96 + let strip_ansi s = 97 97 + let buf = Buffer.create (String.length s) in 98 98 + let i = ref 0 in 99 99 + while !i < String.length s do 100 100 + if !i + 1 < String.length s && s.[!i] = '\027' && s.[!i + 1] = '[' then begin 101 101 + (* Skip until we find a letter *) 102 102 + i := !i + 2; 103 103 + while !i < String.length s && 104 104 + not (Char.code s.[!i] >= Char.code 'A' && Char.code s.[!i] <= Char.code 'z') do 105 105 + incr i 106 106 + done; 107 107 + if !i < String.length s then incr i (* skip the final letter *) 108 108 + end else begin 109 109 + Buffer.add_char buf s.[!i]; 110 110 + incr i 111 111 + end 112 112 + done; 113 113 + Buffer.contents buf 114 114 + 115 115 + (** Extract pass/fail counts from (chibi test) output. 116 116 + We strip ANSI codes first, then find the LAST "N out of M ... tests passed" 117 117 + line (which is the top-level summary). We also look for "subgroups" lines 118 118 + and skip those. *) 119 119 + let parse_chibi_test_output output = 120 120 + let clean = strip_ansi output in 121 121 + let lines = String.split_on_char '\n' clean in 122 122 + let last_pass = ref 0 in 123 123 + let last_total = ref 0 in 124 124 + let failures = Buffer.create 256 in 125 125 + List.iter (fun line -> 126 126 + let trimmed = String.trim line in 127 127 + (* Skip "subgroups passed" lines *) 128 128 + if not (try ignore (Scanf.sscanf trimmed "%_d out of %_d %_s@subgroups" ()); true 129 129 + with _ -> false) then begin 130 130 + (* Look for "N out of M (X%) tests passed" - the standard summary format *) 131 131 + (try 132 132 + Scanf.sscanf trimmed "%d out of %d (%_f%%) tests passed" (fun passed total -> 133 133 + (* Always take the last "tests passed" line = top-level summary *) 134 134 + last_pass := passed; 135 135 + last_total := total) 136 136 + with _ -> ()) 137 137 + end; 138 138 + (* Collect FAIL lines *) 139 139 + if String.length trimmed > 4 then begin 140 140 + if (try String.sub trimmed 0 5 = "FAIL:" with _ -> false) then begin 141 141 + Buffer.add_string failures trimmed; 142 142 + Buffer.add_char failures '\n' 143 143 + end 144 144 + end 145 145 + ) lines; 146 146 + (!last_pass, !last_total, Buffer.contents failures) 147 147 + 148 148 + (* ---------- Test suite runners ---------- *) 149 149 + 150 150 + (** Run a basic test: load .scm file, compare output to .res file *) 151 151 + let run_basic_test name scm_file res_file = 152 152 + Printf.printf " %-50s" name; 153 153 + let ctx = make_test_context () in 154 154 + Fun.protect ~finally:(fun () -> Context.destroy ctx) (fun () -> 155 155 + let expected = String.trim (read_file res_file) in 156 156 + let (_result, stdout, stderr) = load_capturing_output ctx scm_file in 157 157 + let _ = stderr in 158 158 + let actual = String.trim stdout in 159 159 + if actual = expected then begin 160 160 + Printf.printf " [PASS]\n%!"; 161 161 + record_result { name; passed = true; stdout; stderr; 162 162 + error = None; details = "" } 163 163 + end else begin 164 164 + Printf.printf " [FAIL]\n%!"; 165 165 + let details = Printf.sprintf 166 166 + "Expected:\n%s\nGot:\n%s" expected actual in 167 167 + record_result { name; passed = false; stdout; stderr; 168 168 + error = None; details } 169 169 + end) 170 170 + 171 171 + (** Run a (chibi test)-based test suite from a .scm file *) 172 172 + let run_chibi_test_suite name scm_file = 173 173 + Printf.printf " %-50s" name; 174 174 + let ctx = make_test_context ~max_heap:(128 * 1024 * 1024) () in 175 175 + Fun.protect ~finally:(fun () -> Context.destroy ctx) (fun () -> 176 176 + let (_result, stdout, stderr) = load_capturing_output ctx scm_file in 177 177 + let (passed, total, fail_details) = parse_chibi_test_output stdout in 178 178 + if total = 0 then begin 179 179 + (* Might have errored before running any tests *) 180 180 + let err_msg = if stderr <> "" then stderr 181 181 + else match _result with 182 182 + | Error e -> Printexc.to_string e 183 183 + | Ok _ -> "no tests found in output" in 184 184 + Printf.printf " [ERROR] %s\n%!" (String.sub err_msg 0 (min 60 (String.length err_msg))); 185 185 + record_result { name; passed = false; stdout; stderr; 186 186 + error = Some err_msg; 187 187 + details = "No test results found" } 188 188 + end else if passed = total then begin 189 189 + Printf.printf " [PASS] %d/%d\n%!" passed total; 190 190 + record_result { name; passed = true; stdout; stderr; 191 191 + error = None; 192 192 + details = Printf.sprintf "%d/%d tests passed" passed total } 193 193 + end else begin 194 194 + Printf.printf " [FAIL] %d/%d\n%!" passed total; 195 195 + record_result { name; passed = false; stdout; stderr; 196 196 + error = None; 197 197 + details = Printf.sprintf "%d/%d tests passed\n%s" 198 198 + passed total fail_details } 199 199 + end) 200 200 + 201 201 + (** Run a (chibi test)-based test suite from inline Scheme code *) 202 202 + let run_inline_test_suite name code = 203 203 + Printf.printf " %-50s" name; 204 204 + let ctx = make_test_context ~max_heap:(128 * 1024 * 1024) () in 205 205 + Fun.protect ~finally:(fun () -> Context.destroy ctx) (fun () -> 206 206 + let (_result, stdout, stderr) = eval_multi_capturing_output ctx code in 207 207 + let (passed, total, fail_details) = parse_chibi_test_output stdout in 208 208 + if total = 0 then begin 209 209 + let err_msg = if stderr <> "" then stderr 210 210 + else match _result with 211 211 + | Error e -> Printexc.to_string e 212 212 + | Ok _ -> "no tests found in output" in 213 213 + Printf.printf " [ERROR] %s\n%!" (String.sub err_msg 0 (min 80 (String.length err_msg))); 214 214 + record_result { name; passed = false; stdout; stderr; 215 215 + error = Some err_msg; 216 216 + details = "No test results found" } 217 217 + end else if passed = total then begin 218 218 + Printf.printf " [PASS] %d/%d\n%!" passed total; 219 219 + record_result { name; passed = true; stdout; stderr; 220 220 + error = None; 221 221 + details = Printf.sprintf "%d/%d tests passed" passed total } 222 222 + end else begin 223 223 + Printf.printf " [FAIL] %d/%d\n%!" passed total; 224 224 + record_result { name; passed = false; stdout; stderr; 225 225 + error = None; 226 226 + details = Printf.sprintf "%d/%d tests passed\n%s" 227 227 + passed total fail_details } 228 228 + end) 229 229 + 230 230 + (* ---------- Test Suite Definitions ---------- *) 231 231 + 232 232 + let run_basic_tests () = 233 233 + Printf.printf "\n=== Basic Tests ===\n%!"; 234 234 + let basic_dir = Filename.concat tests_dir "basic" in 235 235 + if Sys.file_exists basic_dir then begin 236 236 + let files = Sys.readdir basic_dir in 237 237 + let scm_files = Array.to_list files 238 238 + |> List.filter (fun f -> Filename.check_suffix f ".scm") 239 239 + |> List.sort String.compare in 240 240 + List.iter (fun scm -> 241 241 + let base = Filename.chop_suffix scm ".scm" in 242 242 + let scm_path = Filename.concat basic_dir scm in 243 243 + let res_path = Filename.concat basic_dir (base ^ ".res") in 244 244 + if Sys.file_exists res_path then 245 245 + run_basic_test (Printf.sprintf "basic/%s" base) scm_path res_path 246 246 + else 247 247 + record_skip (Printf.sprintf "basic/%s" base) "no .res file" 248 248 + ) scm_files 249 249 + end else 250 250 + Printf.printf " (basic test directory not found, skipping)\n%!" 251 251 + 252 252 + let run_r5rs_tests () = 253 253 + Printf.printf "\n=== R5RS Tests ===\n%!"; 254 254 + let file = Filename.concat tests_dir "r5rs-tests.scm" in 255 255 + if Sys.file_exists file then begin 256 256 + Printf.printf " %-50s" "r5rs-tests"; 257 257 + let ctx = make_test_context () in 258 258 + Fun.protect ~finally:(fun () -> Context.destroy ctx) (fun () -> 259 259 + let (_result, stdout, stderr) = load_capturing_output ctx file in 260 260 + (* R5RS tests use their own format: "N out of M passed (X%)" *) 261 261 + let lines = String.split_on_char '\n' stdout in 262 262 + let summary = List.find_opt (fun l -> 263 263 + try let _ = Scanf.sscanf l "%d out of %d passed" (fun _ _ -> ()) in true 264 264 + with _ -> false) lines in 265 265 + match summary with 266 266 + | Some line -> 267 267 + let (passed, total) = Scanf.sscanf line "%d out of %d passed" (fun a b -> (a, b)) in 268 268 + if passed = total then begin 269 269 + Printf.printf " [PASS] %d/%d\n%!" passed total; 270 270 + record_result { name = "r5rs-tests"; passed = true; stdout; stderr; 271 271 + error = None; 272 272 + details = Printf.sprintf "%d/%d passed" passed total } 273 273 + end else begin 274 274 + Printf.printf " [FAIL] %d/%d\n%!" passed total; 275 275 + (* Find [FAIL] lines *) 276 276 + let fails = List.filter (fun l -> 277 277 + try ignore (Scanf.sscanf l "%_s [FAIL]" ()); true 278 278 + with _ -> String.length l > 6 && 279 279 + String.sub l (String.length l - 6) 6 = "[FAIL]" 280 280 + ) lines in 281 281 + record_result { name = "r5rs-tests"; passed = false; stdout; stderr; 282 282 + error = None; 283 283 + details = Printf.sprintf "%d/%d passed\n%s" 284 284 + passed total (String.concat "\n" fails) } 285 285 + end 286 286 + | None -> 287 287 + let err_msg = if stderr <> "" then stderr else "no summary line found" in 288 288 + Printf.printf " [ERROR]\n%!"; 289 289 + record_result { name = "r5rs-tests"; passed = false; stdout; stderr; 290 290 + error = Some err_msg; details = "Could not parse output" }) 291 291 + end else 292 292 + record_skip "r5rs-tests" "file not found" 293 293 + 294 294 + let run_r7rs_tests () = 295 295 + Printf.printf "\n=== R7RS Tests ===\n%!"; 296 296 + let file = Filename.concat tests_dir "r7rs-tests.scm" in 297 297 + if Sys.file_exists file then 298 298 + run_chibi_test_suite "r7rs-tests" file 299 299 + else 300 300 + record_skip "r7rs-tests" "file not found" 301 301 + 302 302 + let run_division_tests () = 303 303 + Printf.printf "\n=== Division Tests ===\n%!"; 304 304 + let file = Filename.concat tests_dir "division-tests.scm" in 305 305 + if Sys.file_exists file then 306 306 + run_chibi_test_suite "division-tests" file 307 307 + else 308 308 + record_skip "division-tests" "file not found" 309 309 + 310 310 + let run_syntax_tests () = 311 311 + Printf.printf "\n=== Syntax Tests ===\n%!"; 312 312 + let file = Filename.concat tests_dir "syntax-tests.scm" in 313 313 + if Sys.file_exists file then 314 314 + run_chibi_test_suite "syntax-tests" file 315 315 + else 316 316 + record_skip "syntax-tests" "file not found" 317 317 + 318 318 + let run_unicode_tests () = 319 319 + Printf.printf "\n=== Unicode Tests ===\n%!"; 320 320 + let file = Filename.concat tests_dir "unicode-tests.scm" in 321 321 + if Sys.file_exists file then 322 322 + run_chibi_test_suite "unicode-tests" file 323 323 + else 324 324 + record_skip "unicode-tests" "file not found" 325 325 + 326 326 + (** Run the combined library tests using chibi's own lib-tests.scm. 327 327 + This runs all SRFI + chibi library tests in one shot. 328 328 + This is how chibi-scheme's own test infrastructure works. *) 329 329 + let run_library_tests () = 330 330 + Printf.printf "\n=== Library Tests (lib-tests.scm) ===\n%!"; 331 331 + let file = Filename.concat tests_dir "lib-tests.scm" in 332 332 + if Sys.file_exists file then begin 333 333 + (* chdir to the vendor dir so relative paths like "tests/re-tests.txt" work *) 334 334 + let original_dir = Sys.getcwd () in 335 335 + Sys.chdir vendor_dir; 336 336 + Fun.protect ~finally:(fun () -> Sys.chdir original_dir) (fun () -> 337 337 + run_chibi_test_suite "lib-tests (all SRFIs + chibi libs)" file) 338 338 + end else begin 339 339 + Printf.printf " lib-tests.scm not found, skipping\n%!"; 340 340 + record_skip "lib-tests" "file not found" 341 341 + end 342 342 + 343 343 + (* ---------- Summary ---------- *) 344 344 + 345 345 + let print_summary () = 346 346 + Printf.printf "\n"; 347 347 + Printf.printf "========================================================\n"; 348 348 + Printf.printf " SUMMARY\n"; 349 349 + Printf.printf "========================================================\n"; 350 350 + Printf.printf " Suites run: %d\n" !suites_run; 351 351 + Printf.printf " Suites passed: %d\n" !suites_passed; 352 352 + Printf.printf " Suites failed: %d\n" !suites_failed; 353 353 + Printf.printf " Suites skipped: %d\n" !suites_skipped; 354 354 + Printf.printf "========================================================\n"; 355 355 + 356 356 + if !suites_failed > 0 then begin 357 357 + Printf.printf "\nFailed suites:\n"; 358 358 + List.iter (fun r -> 359 359 + if not r.passed then begin 360 360 + Printf.printf " - %s\n" r.name; 361 361 + if r.details <> "" then begin 362 362 + let lines = String.split_on_char '\n' r.details in 363 363 + List.iter (fun l -> 364 364 + if l <> "" then Printf.printf " %s\n" l 365 365 + ) (List.filteri (fun i _ -> i < 10) lines); 366 366 + if List.length lines > 10 then 367 367 + Printf.printf " ... (%d more lines)\n" (List.length lines - 10) 368 368 + end; 369 369 + (match r.error with 370 370 + | Some e -> 371 371 + let lines = String.split_on_char '\n' e in 372 372 + List.iter (fun l -> 373 373 + if l <> "" then Printf.printf " error: %s\n" l 374 374 + ) (List.filteri (fun i _ -> i < 5) lines) 375 375 + | None -> ()) 376 376 + end 377 377 + ) (List.rev !all_results) 378 378 + end; 379 379 + 380 380 + Printf.printf "\n" 381 381 + 382 382 + (* ---------- Main ---------- *) 383 383 + 384 384 + let () = 385 385 + Printf.printf "chibi-scheme test runner (via chibi-ocaml)\n"; 386 386 + Printf.printf "==========================================\n"; 387 387 + Printf.printf "vendor dir: %s\n" vendor_dir; 388 388 + Printf.printf "tests dir: %s\n" tests_dir; 389 389 + Printf.printf "lib dir: %s\n%!" lib_dir; 390 390 + 391 391 + run_basic_tests (); 392 392 + run_r5rs_tests (); 393 393 + run_r7rs_tests (); 394 394 + run_division_tests (); 395 395 + run_syntax_tests (); 396 396 + run_unicode_tests (); 397 397 + run_library_tests (); 398 398 + 399 399 + print_summary (); 400 400 + 401 401 + if !suites_failed > 0 then 402 402 + exit 1 403 403 + else 404 404 + Printf.printf "All test suites passed!\n%!"