4 files changed, 157 insertions, 0 deletions
diff --git a/testsuite/tests/callback/Makefile b/testsuite/tests/callback/Makefile
new file mode 100644
index 000000000..bbbe08e51
--- /dev/null
+++ b/testsuite/tests/callback/Makefile
@@ -0,0 +1,27 @@
+CC=$(NATIVECC) -I $(TOPDIR)/byterun
+
+default: run-byte run-opt
+
+common:
+	@$(CC) -c callbackprim.c
+
+run-byte: common
+	@echo -n " ... testing 'bytecode':"
+	@$(OCAMLC) -c tcallback.ml
+	@$(OCAMLC) -o ./program -custom unix.cma callbackprim.$(O) tcallback.cmo
+	@./program > bytecode.result
+	@diff -q reference bytecode.result || (echo " => failed" && exit 1) 
+	@echo " => passed"
+
+run-opt: common
+	@echo -n " ... testing 'native':"
+	@$(OCAMLOPT) -c tcallback.ml
+	@$(OCAMLOPT) -o ./program unix.cmxa callbackprim.$(O) tcallback.cmx
+	@./program > native.result
+	@diff -q reference native.result || (echo " => failed" && exit 1) 
+	@echo " => passed"
+
+clean: defaultclean
+	@rm -f *.result ./program
+
+include ../../makefiles/Makefile.common
diff --git a/testsuite/tests/callback/callbackprim.c b/testsuite/tests/callback/callbackprim.c
new file mode 100644
index 000000000..f1a4ccfa1
--- /dev/null
+++ b/testsuite/tests/callback/callbackprim.c
@@ -0,0 +1,54 @@
+#include "mlvalues.h"
+#include "memory.h"
+#include "callback.h"
+
+value mycallback1(value fun, value arg)
+{
+  value res;
+  res = callback(fun, arg);
+  return res;
+}
+
+value mycallback2(value fun, value arg1, value arg2)
+{
+  value res;
+  res = callback2(fun, arg1, arg2);
+  return res;
+}
+
+value mycallback3(value fun, value arg1, value arg2, value arg3)
+{
+  value res;
+  res = callback3(fun, arg1, arg2, arg3);
+  return res;
+}
+
+value mycallback4(value fun, value arg1, value arg2, value arg3, value arg4)
+{
+  value args[4];
+  value res;
+  args[0] = arg1;
+  args[1] = arg2;
+  args[2] = arg3;
+  args[3] = arg4;
+  res = callbackN(fun, 4, args);
+  return res;
+}
+
+value mypushroot(value v, value fun, value arg)
+{
+  Begin_root(v)
+    callback(fun, arg);
+  End_roots();
+  return v;
+}
+
+value mycamlparam (value v, value fun, value arg)
+{
+  CAMLparam3 (v, fun, arg);
+  CAMLlocal2 (x, y);
+  x = v;
+  y = callback (fun, arg);
+  v = x;
+  CAMLreturn (v);
+}
diff --git a/testsuite/tests/callback/reference b/testsuite/tests/callback/reference
new file mode 100644
index 000000000..b35993aa2
--- /dev/null
+++ b/testsuite/tests/callback/reference
@@ -0,0 +1,8 @@
+7
+7
+7
+7
+7
+aaaaa
+aaaaa
+bbbbb
diff --git a/testsuite/tests/callback/tcallback.ml b/testsuite/tests/callback/tcallback.ml
new file mode 100644
index 000000000..32914119b
--- /dev/null
+++ b/testsuite/tests/callback/tcallback.ml
@@ -0,0 +1,68 @@
+external mycallback1 : ('a -> 'b) -> 'a -> 'b = "mycallback1"
+external mycallback2 : ('a -> 'b -> 'c) -> 'a -> 'b -> 'c = "mycallback2"
+external mycallback3 : ('a -> 'b -> 'c -> 'd) -> 'a -> 'b -> 'c -> 'd = "mycallback3"
+external mycallback4 : ('a -> 'b -> 'c -> 'd -> 'e) -> 'a -> 'b -> 'c -> 'd -> 'e = "mycallback4"
+
+let rec tak (x, y, z as _tuple) =
+  if x > y then tak(tak (x-1, y, z), tak (y-1, z, x), tak (z-1, x, y))
+           else z
+
+let tak2 x (y, z) = tak (x, y, z)
+
+let tak3 x y z = tak (x, y, z)
+
+let tak4 x y z u = tak (x, y, z + u)
+
+let raise_exit () = (raise Exit : unit)
+
+let trapexit () =
+  begin try
+    mycallback1 raise_exit ()
+  with Exit ->
+    ()
+  end;
+  tak (18, 12, 6)
+
+external mypushroot : 'a -> ('b -> 'c) -> 'b -> 'a = "mypushroot"
+external mycamlparam : 'a -> ('b -> 'c) -> 'b -> 'a = "mycamlparam"
+
+let tripwire f =
+  let s = String.make 5 'a' in
+  f s trapexit ()
+
+(* Test callbacks performed to handle signals *)
+
+let sighandler signo =
+(*
+  print_string "Got signal, triggering garbage collection...";
+  print_newline();
+*)
+  (* Thoroughly wipe the minor heap *)
+  ignore (tak (18, 12, 6))
+
+external unix_getpid : unit -> int = "unix_getpid" "noalloc"
+external unix_kill : int -> int -> unit = "unix_kill" "noalloc"
+
+let callbacksig () =
+  let pid = unix_getpid() in
+  (* Allocate a block in the minor heap *)
+  let s = String.make 5 'b' in
+  (* Send a signal to self.  We want s to remain in a register and
+     not be spilled on the stack, hence we declare unix_kill
+     "noalloc". *)
+  unix_kill pid Sys.sigusr1;
+  (* Allocate some more so that the signal will be tested *)
+  let u = (s, s) in
+  fst u
+
+let _ =
+  print_int(mycallback1 tak (18, 12, 6)); print_newline();
+  print_int(mycallback2 tak2 18 (12, 6)); print_newline();
+  print_int(mycallback3 tak3 18 12 6); print_newline();
+  print_int(mycallback4 tak4 18 12 3 3); print_newline();
+  print_int(trapexit ()); print_newline();
+  print_string(tripwire mypushroot); print_newline();
+  print_string(tripwire mycamlparam); print_newline();
+  Sys.set_signal Sys.sigusr1 (Sys.Signal_handle sighandler);
+  print_string(callbacksig ()); print_newline()
+