Extend ocaml.ml

candle/basis_ffi.c.patch

@@ -1,8 +1,8 @@
 --- basis_ffi.c
 +++ basis_ffi.c
-@@ -294,6 +294,13 @@
+@@ -294,8 +294,34 @@
  }
-
+ 
  void fficustom (unsigned char *c, long clen, unsigned char *a, long alen) {
 -  assert(0 <= alen);
 -  assert(0 <= clen);
@@ -12,9 +12,28 @@
 +  } else if (strcmp(c, "getcwd") == 0) {
 +    assert(1 <= alen);
 +    a[0] = getcwd(a + 1, alen - 1) == NULL;
-+  } else {
++  } else if (strcmp(c, "system") == 0) {
++    assert(2 <= alen);
++    assert(memchr(a, 0, alen) != NULL);
++    int ret = system((const char *)a);
++
++    // return convention:
++    // 0 < a[0] ==> no termination status for child
++    // a[0] = 0 ==> a[1] = termination status of child
++    if (ret == -1) {
++      a[0] = 1;
++      return;
++    }
++    if (!(WIFEXITED(ret))) {
++      a[0] = 2;
++      return;
++    }
++    a[0] = 0;
++    a[1] = WEXITSTATUS(ret);
 +    return;
++  } else {
++    return;  // Ignore unknown command
 +  }
  }
-
+ 
  // ---------------------------------------------------------------------------

candle/ocaml.ml

@@ -62,6 +62,7 @@ end;;
 module Int = struct
   let compare x y =
     if x < y then -1 else if x > y then 1 else 0
+  let max x y = if x > y then x else y
   let to_string x = Cake.Int.toString x
 end;;
 
@@ -169,6 +170,7 @@ end;;
 
 module Array = struct
   let make n x = Cake.Array.array n x
+  let length a = Cake.Array.length a
   let set a n x = try Cake.Array.update a n x
     with Subscript -> raise (Invalid_argument "Array.set")
   let get a n = try Cake.Array.sub a n
@@ -263,11 +265,39 @@ module Hashtbl = struct
     Cake.List.foldl (fun (x,y) acc -> f x y acc) init (Cake.Hashtable.toAscList tbl)
 end;;
 
+module Bytes = struct
+  let length s = Cake.Word8_array.length s
+  (* NOTE OCaml also raises Invalid_argument if  n > Sys.max_string_length;
+       additionally, OCaml returns an uninitialized sequence with
+       arbitrary bytes. *)
+  let create n =
+    if n < 0 then invalid_arg "Bytes.create: negative argument" else
+      Cake.Word8_array.array n (Cake.Word8.fromInt 0)
+  (* NOTE OCaml can raise Invalid_argument in get, set, blit_string.
+       Unsure how the CakeML handle out-of-bounds accesses. *)
+  let get s n = Cake.Word8_array.sub s n
+  let set s n c = Cake.Word8_array.update s n c
+  let blit_string src src_pos dst dst_pos len =
+    Cake.Word8_array.copyVec src src_pos len dst dst_pos
+  let to_string s = Cake.Word8_array.substring s 0 (length s)
+end;;
+
 module Sys = struct
   let remove (s: string) = print "TODO Sys.remove (noop)\n"
   let command (s: string) =
-    print_endline "TODO Sys.command (noop, always returns 1)";
-    1
+    let slen = String.length s in
+    (* slen + 1: null-terminated string; 2: status bytes *)
+    let blen = Int.max 2 (slen + 1) in
+    let bytes = Bytes.create blen in
+    (* Avoid recomputing length by using blit_string instead of of_string *)
+    let _ = Bytes.blit_string s 0 bytes 0 slen in
+    let _ = Cake.Runtime.customFFI "system" bytes in
+    let ret = Cake.Word8.toInt (Bytes.get bytes 0) in
+    let _ =
+      if 0 < ret
+      then raise (Sys_error "Sys.command: no termination status for child")
+      else () in
+    Cake.Word8.toInt (Bytes.get bytes 1);;
   let time () =
     print_endline "TODO Sys.time (always returns 0)";
     Float.zero;;