Tests: Make the tests for uncaught exceptions more portable (#1652)

* Make the tests for uncaught exceptions more portable --------- Co-authored-by: Jérôme Vouillon <[email protected]> Co-authored-by: Hugo Heuzard <[email protected]>
ocsigen · Aug 3, 2024 · f014914 · f014914
1 parent 5cbf0b1
commit f014914
Show file tree

Hide file tree

Showing 7 changed files with 62 additions and 59 deletions.
diff --git a/compiler/tests-jsoo/bin/dune b/compiler/tests-jsoo/bin/dune
@@ -1,9 +1,15 @@
 (executables
- (names error1 error2 error3)
- (modes byte js))
+ (names error1 error2)
+ (modes exe js)
+ (foreign_stubs
+  (language c)
+  (names named_value_stubs))
+ (js_of_ocaml
+  (javascript_files runtime.js))
+ (libraries))
 
 (rule
- (target error1.actual)
+ (target error1.js.actual)
  (deps error1.html)
  (alias runtest)
  (action
@@ -14,12 +20,27 @@
     (run node %{dep:error1.bc.js})))))
 
 (rule
+ (target error1.exe.actual)
  (alias runtest)
  (action
-  (diff %{dep:error1.expected} %{dep:error1.actual})))
+  (with-accepted-exit-codes
+   2
+   (with-outputs-to
+    %{target}
+    (run %{dep:error1.exe})))))
 
 (rule
- (target error1-unregister.actual)
+ (alias runtest)
+ (action
+  (diff %{dep:error1.expected} %{dep:error1.js.actual})))
+
+(rule
+ (alias runtest)
+ (action
+  (diff %{dep:error1.expected} %{dep:error1.exe.actual})))
+
+(rule
+ (target error1-unregister.js.actual)
  (deps error1-unregister.html)
  (alias runtest)
  (action
@@ -32,10 +53,10 @@
 (rule
  (alias runtest)
  (action
-  (diff %{dep:error1-unregister.expected} %{dep:error1-unregister.actual})))
+  (diff %{dep:error1-unregister.expected} %{dep:error1-unregister.js.actual})))
 
 (rule
- (target error2.actual)
+ (target error2.js.actual)
  (deps error2.html)
  (alias runtest)
  (action
@@ -46,48 +67,41 @@
     (run node %{dep:error2.bc.js})))))
 
 (rule
- (alias runtest)
- (enabled_if
-  (= %{profile} dev))
- (action
-  (diff %{dep:error2.expected} %{dep:error2.actual})))
-
-(rule
- (target error2-unregister.actual)
- (deps error2-unregister.html)
+ (target error2.exe.actual)
  (alias runtest)
  (action
   (with-accepted-exit-codes
    2
    (with-outputs-to
     %{target}
-    (run node %{dep:error2.bc.js} unregister)))))
+    (run %{dep:error2.exe})))))
 
 (rule
  (alias runtest)
+ (enabled_if
+  (= %{profile} dev))
  (action
-  (diff %{dep:error2-unregister.expected} %{dep:error2-unregister.actual})))
+  (diff %{dep:error2.expected} %{dep:error2.js.actual})))
 
-;; We don't expect the output of error3 as it will be flacky
+(rule
+ (alias runtest)
+ (enabled_if
+  (= %{profile} dev))
+ (action
+  (diff %{dep:error2.expected} %{dep:error2.exe.actual})))
 
 (rule
- (target error3.actual)
- (deps error3.html)
+ (target error2-unregister.js.actual)
+ (deps error2-unregister.html)
  (alias runtest)
  (action
   (with-accepted-exit-codes
-   7
+   2
    (with-outputs-to
     %{target}
-    (run node %{dep:error3.bc.js})))))
+    (run node %{dep:error2.bc.js} unregister)))))
 
 (rule
- (target error3-unregister.actual)
- (deps error3-unregister.html)
  (alias runtest)
  (action
-  (with-accepted-exit-codes
-   7
-   (with-outputs-to
-    %{target}
-    (run node %{dep:error3.bc.js} unregister)))))
+  (diff %{dep:error2-unregister.expected} %{dep:error2-unregister.js.actual})))
diff --git a/compiler/tests-jsoo/bin/error1.ml b/compiler/tests-jsoo/bin/error1.ml
@@ -1,8 +1,8 @@
+external unregister : string -> unit = "caml_unregister_named_value"
+
 let () =
   match Array.to_list Sys.argv with
-  | _ :: "unregister" :: _ ->
-      let null = Array.unsafe_get [| 1 |] 1 in
-      Callback.register "Printexc.handle_uncaught_exception" null
+  | _ :: "unregister" :: _ -> unregister "Printexc.handle_uncaught_exception"
   | _ -> ()
 
 exception D of int * string * Int64.t

diff --git a/compiler/tests-jsoo/bin/error2.ml b/compiler/tests-jsoo/bin/error2.ml
@@ -1,10 +1,10 @@
+external unregister : string -> unit = "caml_unregister_named_value"
+
 let () =
   (* Make sure Printexc is linked *)
   let _ = Printexc.to_string Not_found in
   match Array.to_list Sys.argv with
-  | _ :: "unregister" :: _ ->
-      let null = Array.unsafe_get [| 1 |] 1 in
-      Callback.register "Printexc.handle_uncaught_exception" null
+  | _ :: "unregister" :: _ -> unregister "Printexc.handle_uncaught_exception"
   | _ -> ()
 
 [@@@ocaml.warning "-8"]

diff --git a/compiler/tests-jsoo/bin/error3.html b/compiler/tests-jsoo/bin/error3.html
diff --git a/compiler/tests-jsoo/bin/error3.ml b/compiler/tests-jsoo/bin/error3.ml
diff --git a/compiler/tests-jsoo/bin/named_value_stubs.c b/compiler/tests-jsoo/bin/named_value_stubs.c
@@ -0,0 +1,5 @@
+#include "caml/mlvalues.h"
+
+CAMLprim value caml_unregister_named_value(value nm) {
+   return Val_unit;
+}
diff --git a/compiler/tests-jsoo/bin/runtime.js b/compiler/tests-jsoo/bin/runtime.js
@@ -0,0 +1,7 @@
+//Provides: caml_unregister_named_value (const)
+//Requires: caml_named_values, caml_jsbytes_of_string
+function caml_unregister_named_value(nm) {
+  nm = caml_jsbytes_of_string(nm);
+  delete caml_named_values[nm];
+  return 0;
+}