diff --git a/lib/js_of_ocaml/js_of_ocaml_stubs.c b/lib/js_of_ocaml/js_of_ocaml_stubs.c index b325541db..4617e0720 100644 --- a/lib/js_of_ocaml/js_of_ocaml_stubs.c +++ b/lib/js_of_ocaml/js_of_ocaml_stubs.c @@ -1,5 +1,9 @@ #include #include +void caml_custom_identifier () { + fprintf(stderr, "Unimplemented Javascript primitive caml_custom_identifier!\n"); + exit(1); +} void caml_js_error_of_exception () { fprintf(stderr, "Unimplemented Javascript primitive caml_js_error_of_exception!\n"); exit(1); diff --git a/lib/js_of_ocaml/json.ml b/lib/js_of_ocaml/json.ml index 3d666ab96..1c05ce58c 100644 --- a/lib/js_of_ocaml/json.ml +++ b/lib/js_of_ocaml/json.ml @@ -20,6 +20,88 @@ open Js open! Import +(****) + +let write_string buffer s = + Buffer.add_char buffer '\"'; + for i = 0 to String.length s - 1 do + match s.[i] with + | '\"' -> Buffer.add_string buffer "\\\"" + | '\\' -> Buffer.add_string buffer "\\\\" + | '\b' -> Buffer.add_string buffer "\\b" + | '\x0C' -> Buffer.add_string buffer "\\f" + | '\n' -> Buffer.add_string buffer "\\n" + | '\r' -> Buffer.add_string buffer "\\r" + | '\t' -> Buffer.add_string buffer "\\t" + | c when Poly.(c <= '\x1F') -> + (* Other control characters are escaped. *) + Printf.bprintf buffer "\\u%04X" (int_of_char c) + | c when Poly.(c < '\x80') -> Buffer.add_char buffer s.[i] + | _c (* >= '\x80' *) -> + (* Bytes greater than 127 are embedded in a UTF-8 sequence. *) + Buffer.add_char buffer (Char.chr (0xC2 lor (Char.code s.[i] lsr 6))); + Buffer.add_char buffer (Char.chr (0x80 lor (Char.code s.[i] land 0x3F))) + done; + Buffer.add_char buffer '\"' + +let write_float buffer f = + (* "%.15g" can be (much) shorter; "%.17g" is round-trippable *) + let s = Printf.sprintf "%.15g" f in + if Poly.(float_of_string s = f) + then Buffer.add_string buffer s + else Printf.bprintf buffer "%.17g" f + +external custom_identifier : Obj.t -> string = "caml_custom_identifier" + +let rec write b v = + if Obj.is_int v + then Printf.bprintf b "%d" (Obj.obj v : int) + else + let t = Obj.tag v in + if t <= Obj.last_non_constant_constructor_tag + then ( + Printf.bprintf b "[%d" t; + for i = 0 to Obj.size v - 1 do + Buffer.add_char b ','; + write b (Obj.field v i) + done; + Buffer.add_char b ']') + else if t = Obj.string_tag + then write_string b (Obj.obj v : string) + else if t = Obj.double_tag + then write_float b (Obj.obj v : float) + else if t = Obj.double_array_tag + then ( + Printf.bprintf b "[%d" t; + for i = 0 to Obj.size v - 1 do + Buffer.add_char b ','; + write_float b (Obj.double_field v i) + done; + Buffer.add_char b ']') + else if t = Obj.custom_tag + then + match custom_identifier v with + | "_i" -> Printf.bprintf b "%ld" (Obj.obj v : int32) + | "_j" -> + let i : int64 = Obj.obj v in + let mask16 = Int64.of_int 0xffff in + let mask24 = Int64.of_int 0xffffff in + Printf.bprintf + b + "[255,%Ld,%Ld,%Ld]" + (Int64.logand i mask24) + (Int64.logand (Int64.shift_right i 24) mask24) + (Int64.logand (Int64.shift_right i 48) mask16) + | id -> failwith (Printf.sprintf "Json.output: unsupported custom value %s " id) + else failwith (Printf.sprintf "Json.output: unsupported tag %d " t) + +let to_json v = + let buf = Buffer.create 50 in + write buf v; + Buffer.contents buf + +(****) + class type json = object method parse : 'a. js_string t -> 'a meth @@ -52,7 +134,10 @@ let input_reviver = in wrap_meth_callback reviver -let unsafe_input s = json##parse_ s input_reviver +let unsafe_input s = + match Sys.backend_type with + | Other "wasm_of_ocaml" -> failwith "Json.unsafe_input: not implemented" + | _ -> json##parse_ s input_reviver class type obj = object @@ -73,4 +158,7 @@ let output_reviver _key (value : Unsafe.any) : Obj.t = Obj.repr (array [| 255; value##.lo; value##.mi; value##.hi |]) else Obj.repr value -let output obj = json##stringify_ obj (Js.wrap_callback output_reviver) +let output obj = + match Sys.backend_type with + | Other "wasm_of_ocaml" -> Js.string (to_json (Obj.repr obj)) + | _ -> json##stringify_ obj (Js.wrap_callback output_reviver) diff --git a/runtime/obj.js b/runtime/obj.js index fa1cbda2b..9ed63d8db 100644 --- a/runtime/obj.js +++ b/runtime/obj.js @@ -214,3 +214,9 @@ function caml_is_continuation_tag(t) { function caml_is_continuation_tag(t) { return (t == 245) ? 1 : 0; } + +//Provides: caml_custom_identifier +//Requires: caml_string_of_jsstring +function caml_custom_identifier (o) { + return caml_string_of_jsstring(o.custom_tag); +} diff --git a/runtime/wasm/custom.wat b/runtime/wasm/custom.wat index 0583a91f8..f4dd7cd82 100644 --- a/runtime/wasm/custom.wat +++ b/runtime/wasm/custom.wat @@ -109,4 +109,8 @@ (call $caml_register_custom_operations (global.get $int64_ops)) (call $caml_register_custom_operations (global.get $bigarray_ops)) (global.set $initialized (i32.const 1))) + + (func (export "caml_custom_identifier") (param $v (ref eq)) (result (ref eq)) + (struct.get $custom_operations $id + (struct.get $custom 0 (ref.cast (ref $custom) (local.get $v))))) )