ocaml bindings for chibi-scheme VM
align test runner with upstream chibi behavior
+107
-16
+24
-1
lib/chibi.ml
+24
-1
lib/chibi.ml
···
204
204
let check_alive t =
205
205
if t.destroyed then raise Context_destroyed
206
206
207
+
let scheme_string_literal s =
208
+
let buf = Buffer.create (String.length s + 8) in
209
+
Buffer.add_char buf '"';
210
+
String.iter (function
211
+
| '"' -> Buffer.add_string buf "\\\""
212
+
| '\\' -> Buffer.add_string buf "\\\\"
213
+
| '\n' -> Buffer.add_string buf "\\n"
214
+
| '\r' -> Buffer.add_string buf "\\r"
215
+
| '\t' -> Buffer.add_string buf "\\t"
216
+
| c -> Buffer.add_char buf c
217
+
) s;
218
+
Buffer.add_char buf '"';
219
+
Buffer.contents buf
220
+
221
+
let initialize_command_line raw =
222
+
let argv0 =
223
+
if Array.length Sys.argv > 0 then Sys.argv.(0)
224
+
else Sys.executable_name
225
+
in
226
+
let expr = Printf.sprintf "(command-line '(%s))" (scheme_string_literal argv0) in
227
+
ignore (Chibi_ffi.eval_string raw expr)
228
+
207
229
(** Override a list of bindings with void in the current environment.
208
230
Silently ignores bindings that don't exist. *)
209
231
let nullify_bindings ctx names =
···
351
373
if Sandbox.has_capability config.sandbox Sandbox.Module_import then begin
352
374
Chibi_ffi.load_standard_env raw;
353
375
if Sandbox.has_capability config.sandbox Sandbox.Standard_io then
354
-
Chibi_ffi.load_standard_ports raw
376
+
Chibi_ffi.load_standard_ports raw;
377
+
initialize_command_line raw
355
378
end;
356
379
(* Apply sandbox restrictions *)
357
380
apply_sandbox t;
+1
lib/chibi_ffi.ml
+1
lib/chibi_ffi.ml
···
116
116
external set_context_env : context -> sexp -> unit = "caml_chibi_set_context_env"
117
117
external eval_in_env : context -> string -> sexp -> sexp = "caml_chibi_eval_in_env"
118
118
external load_standard_env_into : context -> sexp -> unit = "caml_chibi_load_standard_env_into"
119
+
external set_language : context -> string -> unit = "caml_chibi_set_language"
119
120
120
121
(* ---- Equality ---- *)
121
122
external sexp_equal : sexp -> sexp -> bool = "caml_chibi_sexp_equal"
+42
lib/chibi_stubs.c
+42
lib/chibi_stubs.c
···
140
140
return w;
141
141
}
142
142
143
+
static void chibi_add_import_binding(sexp ctx, sexp env) {
144
+
sexp_gc_var2(sym, tmp);
145
+
sexp_gc_preserve2(ctx, sym, tmp);
146
+
sym = sexp_intern(ctx, "repl-import", -1);
147
+
tmp = sexp_env_ref(ctx, sexp_global(ctx, SEXP_G_META_ENV), sym, SEXP_VOID);
148
+
sym = sexp_intern(ctx, "import", -1);
149
+
sexp_env_define(ctx, env, sym, tmp);
150
+
sexp_gc_release2(ctx);
151
+
}
152
+
143
153
/* ---------- Error handling ---------- */
144
154
145
155
static void raise_chibi_error(sexp ctx, sexp err) {
···
1106
1116
sexp res = sexp_load_standard_env(ctx, env, SEXP_SEVEN);
1107
1117
if (sexp_exceptionp(res))
1108
1118
raise_chibi_error(ctx, res);
1119
+
CAMLreturn(Val_unit);
1120
+
}
1121
+
1122
+
CAMLprim value caml_chibi_set_language(value v_ctx, value v_lang) {
1123
+
CAMLparam2(v_ctx, v_lang);
1124
+
sexp ctx = get_ctx(v_ctx);
1125
+
sexp meta_env = sexp_global(ctx, SEXP_G_META_ENV);
1126
+
size_t lang_len = caml_string_length(v_lang);
1127
+
size_t expr_len = strlen("(mutable-environment '())") + lang_len + 1;
1128
+
char *expr = caml_stat_alloc(expr_len);
1129
+
sexp env, ports;
1130
+
1131
+
if (!sexp_envp(meta_env))
1132
+
caml_failwith("Chibi: meta environment is not initialized");
1133
+
1134
+
snprintf(expr, expr_len, "(mutable-environment '(%s))", String_val(v_lang));
1135
+
env = sexp_eval_string(ctx, expr, -1, meta_env);
1136
+
caml_stat_free(expr);
1137
+
1138
+
if (sexp_exceptionp(env))
1139
+
raise_chibi_error(ctx, env);
1140
+
1141
+
sexp_set_parameter(ctx, meta_env,
1142
+
sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL),
1143
+
env);
1144
+
sexp_context_env(ctx) = env;
1145
+
chibi_add_import_binding(ctx, env);
1146
+
1147
+
ports = sexp_load_standard_ports(ctx, env, stdin, stdout, stderr, 1);
1148
+
if (sexp_exceptionp(ports))
1149
+
raise_chibi_error(ctx, ports);
1150
+
1109
1151
CAMLreturn(Val_unit);
1110
1152
}
1111
1153
+1
-1
test_runner/dune
+1
-1
test_runner/dune
+39
-14
test_runner/run_chibi_tests.ml
+39
-14
test_runner/run_chibi_tests.ml
···
5
5
can correctly execute all the standard tests. *)
6
6
7
7
open Chibi_ocaml.Chibi
8
+
module Ffi = Chibi_ocaml.Chibi_ffi
8
9
9
10
(* ---------- Helpers ---------- *)
10
11
11
-
let vendor_dir =
12
-
(* Find the vendor directory relative to this executable *)
12
+
let expand_home path =
13
+
if String.length path > 0 && path.[0] = '~' then
14
+
match Sys.getenv_opt "HOME" with
15
+
| Some home when String.length path = 1 -> home
16
+
| Some home when path.[1] = '/' -> home ^ String.sub path 1 (String.length path - 1)
17
+
| _ -> path
18
+
else
19
+
path
20
+
21
+
let test_root =
22
+
(* Prefer an external checkout when available, then fall back to the vendored copy. *)
13
23
let exe = Sys.executable_name in
14
24
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
25
+
let candidates =
26
+
(match Sys.getenv_opt "CHIBI_TEST_ROOT" with
27
+
| Some path -> [expand_home path]
28
+
| None -> [])
29
+
@ [
30
+
expand_home "~/data/src/chibi-scheme";
31
+
Filename.concat dir "../../../vendor/chibi-scheme";
32
+
Filename.concat dir "../../vendor/chibi-scheme";
33
+
Filename.concat dir "../vendor/chibi-scheme";
34
+
"vendor/chibi-scheme";
35
+
]
36
+
in
21
37
match List.find_opt (fun d ->
22
38
Sys.file_exists (Filename.concat d "lib/init-7.scm")) candidates
23
39
with
24
40
| Some d -> d
25
-
| None -> failwith "Cannot find vendor/chibi-scheme directory"
41
+
| None -> failwith "Cannot find chibi-scheme test root"
26
42
27
-
let tests_dir = Filename.concat vendor_dir "tests"
28
-
let lib_dir = Filename.concat vendor_dir "lib"
43
+
let tests_dir = Filename.concat test_root "tests"
44
+
let lib_dir = Filename.concat test_root "lib"
29
45
30
46
(** Create a context suitable for running tests.
31
47
Full access, with module path pointing at vendored lib. *)
32
48
let make_test_context ?(max_heap = 64 * 1024 * 1024) () =
49
+
Unix.putenv "CHIBI_MODULE_PATH" lib_dir;
33
50
let config = Context.{
34
51
default_config with
35
52
max_heap_size = max_heap;
···
153
170
let ctx = make_test_context () in
154
171
Fun.protect ~finally:(fun () -> Context.destroy ctx) (fun () ->
155
172
let expected = String.trim (read_file res_file) in
156
-
let (_result, stdout, stderr) = load_capturing_output ctx scm_file in
173
+
let raw = Context.raw ctx in
174
+
let original_env = Ffi.context_env raw in
175
+
let (_result, stdout, stderr) =
176
+
Fun.protect
177
+
~finally:(fun () -> Ffi.set_context_env raw original_env)
178
+
(fun () ->
179
+
Ffi.set_language raw "chibi";
180
+
load_capturing_output ctx scm_file)
181
+
in
157
182
let _ = stderr in
158
183
let actual = String.trim stdout in
159
184
if actual = expected then begin
···
332
357
if Sys.file_exists file then begin
333
358
(* chdir to the vendor dir so relative paths like "tests/re-tests.txt" work *)
334
359
let original_dir = Sys.getcwd () in
335
-
Sys.chdir vendor_dir;
360
+
Sys.chdir test_root;
336
361
Fun.protect ~finally:(fun () -> Sys.chdir original_dir) (fun () ->
337
362
run_chibi_test_suite "lib-tests (all SRFIs + chibi libs)" file)
338
363
end else begin
···
384
409
let () =
385
410
Printf.printf "chibi-scheme test runner (via chibi-ocaml)\n";
386
411
Printf.printf "==========================================\n";
387
-
Printf.printf "vendor dir: %s\n" vendor_dir;
412
+
Printf.printf "test root: %s\n" test_root;
388
413
Printf.printf "tests dir: %s\n" tests_dir;
389
414
Printf.printf "lib dir: %s\n%!" lib_dir;
390
415