Add several macros for making the runtime easier to maintain

compiler/lib/linker.ml

@@ -297,6 +297,7 @@ let add_file f =
         match provides with
         | None -> always_included := {filename = f; program = code} :: !always_included
         | Some (pi, name, kind, ka) ->
+            let code = Macro.f code in
             let module J = Javascript in
             let rec find = function
               | [] -> None

compiler/lib/macro.ml

@@ -0,0 +1,51 @@
+(* Js_of_ocaml compiler
+ * http://www.ocsigen.org/js_of_ocaml/
+ * Copyright (C) 2019 Ty Overby, Jane Street Group LLC
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published by
+ * the Free Software Foundation, with linking exception;
+ * either version 2.1 of the License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+*)
+
+open Stdlib
+
+class macro_mapper =
+  object (m)
+    inherit Js_traverse.map as super
+
+    method expression x =
+      let module J = Javascript in
+      match x with
+      | J.ECall (J.EVar (J.S {name; _}), args, _) -> (
+        match name, args with
+        | "BLOCK", J.ENum tag :: (_ :: _ as args) ->
+            let tag = Int32.to_int (J.Num.to_int32 tag) in
+            let args = List.map args ~f:m#expression in
+            Mlvalue.Block.make ~tag ~args
+        | "TAG", [e] -> Mlvalue.Block.tag (m#expression e)
+        | "LENGTH", [e] -> Mlvalue.Array.length (m#expression e)
+        | "FIELD", [e; J.ENum n] ->
+            let idx = Int32.to_int (J.Num.to_int32 n) in
+            Mlvalue.Block.field (m#expression e) idx
+        | "FIELD", [_; J.EUn (J.Neg, _)] ->
+            failwith "Negative field indexes are not allowed"
+        | "ISBLOCK", [e] -> Mlvalue.is_block (m#expression e)
+        | ("BLOCK" | "TAG" | "LENGTH" | "FIELD" | "ISBLOCK"), _ ->
+            failwith (Format.sprintf "macro %s called with inappropriate arguments" name)
+        | _ -> super#expression x)
+      | _ -> super#expression x
+  end
+
+let f js =
+  let trav = new macro_mapper in
+  trav#program js

compiler/lib/macro.mli

@@ -0,0 +1,20 @@
+(* Js_of_ocaml compiler
+ * http://www.ocsigen.org/js_of_ocaml/
+ * Copyright (C) 2019 Ty Overby, Jane Street Group LLC
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published by
+ * the Free Software Foundation, with linking exception;
+ * either version 2.1 of the License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+*)
+
+val f : Javascript.program -> Javascript.program

compiler/tests/macro.ml

@@ -0,0 +1,109 @@
+(* Js_of_ocaml compiler
+ * http://www.ocsigen.org/js_of_ocaml/
+ * Copyright (C) 2019 Ty Overby
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published by
+ * the Free Software Foundation, with linking exception;
+ * either version 2.1 of the License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+*)
+
+module Jsoo = Js_of_ocaml_compiler
+
+let print_macro_transformed source =
+  let buffer = Buffer.create (String.length source) in
+  let pp = Jsoo.Pretty_print.to_buffer buffer in
+  Jsoo.Pretty_print.set_compact pp false;
+  let source = source |> Util.Filetype.js_text_of_string |> Util.Filetype.write_js in
+  let parsed = Util.parse_js source in
+  let transformed = Jsoo.Macro.f parsed in
+  Jsoo.Js_output.program pp transformed;
+  print_endline (Buffer.contents buffer)
+
+let print_macro_transformed source =
+  try print_macro_transformed source with Failure s -> Format.printf "failure: %s" s
+
+let%expect_test "BLOCK()" =
+  print_macro_transformed "BLOCK()";
+  [%expect {| failure: macro BLOCK called with inappropriate arguments |}]
+
+let%expect_test "TAG()" =
+  print_macro_transformed "TAG()";
+  [%expect {| failure: macro TAG called with inappropriate arguments |}]
+
+let%expect_test "LENGTH()" =
+  print_macro_transformed "LENGTH()";
+  [%expect {| failure: macro LENGTH called with inappropriate arguments |}]
+
+let%expect_test "FIELD()" =
+  print_macro_transformed "FIELD()";
+  [%expect {| failure: macro FIELD called with inappropriate arguments |}]
+
+let%expect_test "ISBLOCK()" =
+  print_macro_transformed "ISBLOCK()";
+  [%expect {| failure: macro ISBLOCK called with inappropriate arguments |}]
+
+let%expect_test "BLOCK(1)" =
+  print_macro_transformed "BLOCK(1)";
+  [%expect {| failure: macro BLOCK called with inappropriate arguments |}]
+
+let%expect_test "BLOCK(tag)" =
+  print_macro_transformed "BLOCK(tag)";
+  [%expect {| failure: macro BLOCK called with inappropriate arguments |}]
+
+let%expect_test "BLOCK(1, a)" =
+  print_macro_transformed "BLOCK(1, a)";
+  [%expect {| [1,a]; |}]
+
+let%expect_test "BLOCK(1, a, b, c)" =
+  print_macro_transformed "BLOCK(1, a, b, c)";
+  [%expect {| [1,a,b,c]; |}]
+
+let%expect_test "BLOCK(077, a)" =
+  print_macro_transformed "BLOCK(077, a)";
+  [%expect {| [63,a]; |}]
+
+let%expect_test "BLOCK(0779, a)" =
+  print_macro_transformed "BLOCK(0779, a)";
+  [%expect {| [779,a]; |}]
+
+let%expect_test "TAG(a)" =
+  print_macro_transformed "TAG(a)";
+  [%expect {| a[0]; |}]
+
+let%expect_test "LENGTH(a)" =
+  print_macro_transformed "LENGTH(a)";
+  [%expect {| a.length - 1; |}]
+
+let%expect_test "FIELD(a)" =
+  print_macro_transformed "FIELD(a)";
+  [%expect {| failure: macro FIELD called with inappropriate arguments |}]
+
+let%expect_test "FIELD(a, b)" =
+  print_macro_transformed "FIELD(a, b)";
+  [%expect {| failure: macro FIELD called with inappropriate arguments |}]
+
+let%expect_test "FIELD(a, b << 5)" =
+  print_macro_transformed "FIELD(a, b << 5)";
+  [%expect {| failure: macro FIELD called with inappropriate arguments |}]
+
+let%expect_test "FIELD(a, 0)" =
+  print_macro_transformed "FIELD(a, 0)";
+  [%expect {| a[1]; |}]
+
+let%expect_test "FIELD(a, -1)" =
+  print_macro_transformed "FIELD(a, -1)";
+  [%expect {| failure: Negative field indexes are not allowed |}]
+
+let%expect_test "ISBLOCK(a)" =
+  print_macro_transformed "ISBLOCK(a)";
+  [%expect {| typeof a !== "number"; |}]

runtime/unix.js

@@ -15,10 +15,10 @@ function unix_gmtime (t) {
   var d_num = d.getTime();
   var januaryfirst = (new Date(Date.UTC(d.getUTCFullYear(), 0, 1))).getTime();
   var doy = Math.floor((d_num - januaryfirst) / 86400000);
-  return [0, d.getUTCSeconds(), d.getUTCMinutes(), d.getUTCHours(),
+  return BLOCK(0, d.getUTCSeconds(), d.getUTCMinutes(), d.getUTCHours(),
           d.getUTCDate(), d.getUTCMonth(), d.getUTCFullYear() - 1900,
           d.getUTCDay(), doy,
-          false | 0 /* for UTC daylight savings time is false */]
+          false | 0 /* for UTC daylight savings time is false */)
 }
 
 //Provides: unix_localtime
@@ -30,10 +30,10 @@ function unix_localtime (t) {
   var jan = new Date(d.getFullYear(), 0, 1);
   var jul = new Date(d.getFullYear(), 6, 1);
   var stdTimezoneOffset = Math.max(jan.getTimezoneOffset(), jul.getTimezoneOffset());
-  return [0, d.getSeconds(), d.getMinutes(), d.getHours(),
+  return BLOCK(0, d.getSeconds(), d.getMinutes(), d.getHours(),
           d.getDate(), d.getMonth(), d.getFullYear() - 1900,
           d.getDay(), doy,
-          (d.getTimezoneOffset() < stdTimezoneOffset) | 0 /* daylight savings time  field. */]
+          (d.getTimezoneOffset() < stdTimezoneOffset) | 0 /* daylight savings time  field. */)
 }
 
 //Provides: unix_mktime
@@ -42,7 +42,7 @@ function unix_mktime(tm){
   var d = (new Date(tm[6]+1900,tm[5],tm[4],tm[3],tm[2],tm[1])).getTime();
   var t = Math.floor(d / 1000);
   var tm2 = unix_localtime(t);
-  return [0,t,tm2];
+  return BLOCK(0,t,tm2);
 }
 
 //Provides: win_startup const