[eval] add VLazy

see #7196

src/macro/eval/evalDebugCLI.ml

@@ -51,6 +51,7 @@ let value_string value =
 		| VInstance vi -> rev_hash_s vi.iproto.ppath,instance_fields (depth + 1) vi
 		| VPrototype proto -> "Anonymous",Rope.to_string (s_proto_kind proto)
 		| VFunction _ | VFieldClosure _ -> "Function","fun"
+		| VLazy f -> value_string depth (!f())
 	in
 	let s_type,s_value = value_string 0 value in
 	Printf.sprintf "%s = %s" s_type s_value

src/macro/eval/evalDebugSocket.ml

@@ -19,7 +19,7 @@ let var_to_json name value access =
 		JObject ["name",JString name;"type",JString t;"value",JString v;"structured",JBool structured;"access",JString access]
 	in
 	let string_repr s = "\"" ^ (Ast.s_escape (Lazy.force s)) ^ "\"" in
-	let level2_value_repr = function
+	let rec level2_value_repr = function
 		| VNull -> "null"
 		| VTrue -> "true"
 		| VFalse -> "false"
@@ -37,6 +37,7 @@ let var_to_json name value access =
 		| VInstance vi -> (rev_hash_s vi.iproto.ppath) ^ " {...}"
 		| VPrototype proto -> Rope.to_string (s_proto_kind proto)
 		| VFunction _ | VFieldClosure _ -> "<fun>"
+		| VLazy f -> level2_value_repr (!f())
 	in
 	let fields_string fields =
 		let l = List.map (fun (name, value) -> Printf.sprintf "%s: %s" (rev_hash_s name) (level2_value_repr value)) fields in
@@ -46,7 +47,7 @@ let var_to_json name value access =
 		let l = List.map level2_value_repr l in
 		Printf.sprintf "[%s]" (String.concat ", " l)
 	in
-	let value_string v = match v with
+	let rec value_string v = match v with
 		| VNull -> jv "NULL" "null" false
 		| VTrue -> jv "Bool" "true" false
 		| VFalse -> jv "Bool" "false" false
@@ -72,6 +73,7 @@ let var_to_json name value access =
 			jv class_name (class_name ^ " " ^ (fields_string (instance_fields vi))) true
 		| VPrototype proto -> jv "Anonymous" (Rope.to_string (s_proto_kind proto)) false (* TODO: show statics *)
 		| VFunction _ | VFieldClosure _ -> jv "Function" "<fun>" false
+		| VLazy f -> value_string (!f())
 	in
 	value_string value
 
@@ -155,7 +157,7 @@ let output_scope_vars env scope =
 	JArray vars
 
 let output_inner_vars v access =
-	let children = match v with
+	let rec loop v = match v with
 		| VNull | VTrue | VFalse | VInt32 _ | VFloat _ | VFunction _ | VFieldClosure _ -> []
 		| VEnumValue ve ->
 			begin match ve.eargs with
@@ -197,7 +199,9 @@ let output_inner_vars v access =
 				n, v, a
 			) fields
 		| VPrototype proto -> [] (* TODO *)
+		| VLazy f -> loop (!f())
 	in
+	let children = loop v in
 	let vars = List.map (fun (n,v,a) -> var_to_json n v a) children in
 	JArray vars
 

src/macro/eval/evalDecode.ml

@@ -21,7 +21,7 @@ open Globals
 open EvalValue
 open EvalExceptions
 
-let decode_object v = match v with
+let decode_object v = match vresolve v with
 	| VObject o -> o
 	| _ -> unexpected_value v "object"
 

src/macro/eval/evalEmitter.ml

@@ -329,7 +329,7 @@ let emit_field_closure exec name env =
 	dynamic_field v name
 
 let emit_anon_field_read exec proto i name p env =
-	match exec env with
+	match vresolve (exec env) with
 	| VObject o ->
 		if proto == o.oproto then o.ofields.(i)
 		else object_field o name
@@ -401,7 +401,7 @@ let emit_instance_field_write exec1 i exec2 env = match exec1 env with
 let emit_anon_field_write exec1 proto i name exec2 env =
 	let v1 = exec1 env in
 	let v2 = exec2 env in
-	begin match v1 with
+	begin match vresolve v1 with
 		| VObject o ->
 			if proto == o.oproto then begin
 				o.ofields.(i) <- v2;
@@ -472,7 +472,7 @@ let emit_instance_field_read_write exec1 i exec2 fop prefix env = match exec1 en
 
 let emit_field_read_write exec1 name exec2 fop prefix env =
 	let v1 = exec1 env in
-	match v1 with
+	match vresolve v1 with
 	| VObject o ->
 		let vf = object_field o name in
 		let v2 = exec2 env in

src/macro/eval/evalEncode.ml

@@ -275,3 +275,11 @@ let encode_ref v convert tostr =
 		iproto = ref_proto;
 		ikind = IRef (Obj.repr v);
 	}
+
+let encode_lazy f =
+	let rec r = ref (fun () ->
+		let v = f() in
+		r := (fun () -> v);
+		v
+	) in
+	VLazy r

src/macro/eval/evalExceptions.ml

@@ -73,6 +73,7 @@ let s_value_kind = function
 	| VPrototype _ -> "VPrototype"
 	| VFunction _ -> "VFunction"
 	| VFieldClosure _ -> "VFieldClosure"
+	| VLazy _ -> "VLazy"
 
 let unexpected_value : 'a . value -> string -> 'a = fun v s ->
 	let str = Printf.sprintf "Unexpected value %s(%s), expected %s" (s_value_kind v) (value_string v) s in

src/macro/eval/evalField.ml

@@ -45,7 +45,7 @@ let object_field o name =
 	try object_field_raise o name with Not_found -> vnull
 
 let field_raise v f =
-	match v with
+	match vresolve v with
 	| VObject o -> object_field_raise o f
 	| VInstance {ikind = IBytes s} when f = key_length -> vint (Bytes.length s)
 	| VPrototype proto -> proto_field_raise proto f

src/macro/eval/evalMain.ml

@@ -316,6 +316,8 @@ let value_signature v =
 				add (string_of_int !function_count);
 				incr function_count
 			)
+		| VLazy f ->
+			loop (!f())
 	and loop_fields fields =
 		List.iter (fun (name,v) ->
 			adds (rev_hash_s name);
@@ -391,7 +393,7 @@ let rec value_to_expr v p =
 		in
 		make_path mt
 	in
-	match v with
+	match vresolve v with
 	| VNull -> (EConst (Ident "null"),p)
 	| VTrue -> (EConst (Ident "true"),p)
 	| VFalse -> (EConst (Ident "false"),p)

src/macro/eval/evalMisc.ml

@@ -67,7 +67,7 @@ let set_bytes_length_field v1 v2 =
 		vi.ikind <- IBytes b'
 	| _ -> unexpected_value v1 "bytes"
 
-let set_field v1 name v2 = match v1 with
+let set_field v1 name v2 = match vresolve v1 with
 	| VObject o -> set_object_field o name v2
 	| VPrototype proto -> set_proto_field proto name v2
 	| VArray va ->
@@ -115,6 +115,10 @@ let rec compare a b =
 	| VFieldClosure(v1,f1),VFieldClosure(v2,f2) ->
 		if f1 != f2 then CUndef
 		else compare v1 v2
+	| VLazy f1,_ ->
+		compare (!f1()) b
+	| _,VLazy f2 ->
+		compare a (!f2())
 	| _ -> CUndef
 
 let rec arrays_equal cmp a1 a2 =
@@ -141,6 +145,8 @@ and equals_structurally a b =
 	| VObject a,VObject b -> a == b || arrays_equal equals_structurally a.ofields b.ofields && IntMap.equal equals_structurally a.oextra b.oextra
 	| VEnumValue a,VEnumValue b -> a == b || a.eindex = b.eindex && arrays_equal equals_structurally a.eargs b.eargs && a.epath = b.epath
 	| VPrototype proto1,VPrototype proto2 -> proto1.ppath = proto2.ppath
+	| VLazy f1,_ -> equals_structurally (!f1()) b
+	| _,VLazy f2 -> equals_structurally a (!f2())
 	| _ -> a == b
 
 let is_true v = match v with

src/macro/eval/evalPrinting.ml

@@ -111,6 +111,7 @@ and s_value depth v =
 	| VInstance {ikind=IPos p} -> of_string ("#pos(" ^ Lexer.get_error_pos (Printf.sprintf "%s:%d:") p ^ ")")
 	| VInstance i -> (try call_to_string () with Not_found -> rev_hash i.iproto.ppath)
 	| VObject o -> (try call_to_string () with Not_found -> s_object (depth + 1) o)
+	| VLazy f -> s_value depth (!f())
 	| VPrototype proto ->
 		try
 			call_to_string()

src/macro/eval/evalStdLib.ml

@@ -1565,7 +1565,7 @@ module StdReflect = struct
 		vbool (loop a b)
 	)
 
-	let copy = vfun1 (fun o -> match o with
+	let copy = vfun1 (fun o -> match vresolve o with
 		| VObject o -> VObject { o with ofields = Array.copy o.ofields }
 		| VInstance vi -> vinstance {
 			ifields = Array.copy vi.ifields;
@@ -1580,7 +1580,7 @@ module StdReflect = struct
 
 	let deleteField = vfun2 (fun o name ->
 		let name = hash (decode_rope name) in
-		match o with
+		match vresolve o with
 		| VObject o ->
 			if IntMap.mem name o.oextra then begin
 				o.oextra <- IntMap.remove name o.oextra;
@@ -1602,7 +1602,7 @@ module StdReflect = struct
 
 	let fields = vfun1 (fun o ->
 		let proto_fields proto = IntMap.fold (fun name _ acc -> name :: acc) proto.pnames [] in
-		let fields = match o with
+		let fields = match vresolve o with
 			| VObject o -> List.map fst (object_fields o)
 			| VInstance vi -> IntMap.fold (fun name _ acc -> name :: acc) vi.iproto.pinstance_names []
 			| VPrototype proto -> proto_fields proto
@@ -1622,7 +1622,7 @@ module StdReflect = struct
 
 	let hasField = vfun2 (fun o field ->
 		let name = hash (decode_rope field) in
-		let b = match o with
+		let b = match vresolve o with
 			| VObject o -> (IntMap.mem name o.oproto.pinstance_names && not (IntMap.mem name o.oremoved)) || IntMap.mem name o.oextra
 			| VInstance vi -> IntMap.mem name vi.iproto.pinstance_names || IntMap.mem name vi.iproto.pnames
 			| VPrototype proto -> IntMap.mem name proto.pnames
@@ -1642,7 +1642,7 @@ module StdReflect = struct
 		| _ -> vfalse
 	)
 
-	let isObject = vfun1 (fun v -> match v with
+	let isObject = vfun1 (fun v -> match vresolve v with
 		| VObject _ | VString _ | VArray _ | VVector _ | VInstance _ | VPrototype _ -> vtrue
 		| _ -> vfalse
 	)
@@ -2461,7 +2461,7 @@ module StdType = struct
 
 	let typeof = vfun1 (fun v ->
 		let ctx = (get_ctx()) in
-		let i,vl = match v with
+		let rec loop v = match v with
 			| VNull -> 0,[||]
 			| VInt32 _ -> 1,[||]
 			| VFloat _ -> 2,[||]
@@ -2477,7 +2477,10 @@ module StdType = struct
 				5,[||]
 			| VEnumValue ve ->
 				7,[|get_static_prototype_as_value ctx ve.epath null_pos|]
+			| VLazy f ->
+				loop (!f())
 		in
+		let i,vl = loop v in
 		encode_enum_value key_ValueType i vl None
 	)
 end

src/macro/eval/evalValue.ml

@@ -69,6 +69,7 @@ type value =
 	| VPrototype of vprototype
 	| VFunction of vfunc * bool
 	| VFieldClosure of value * vfunc
+	| VLazy of (unit -> value) ref
 
 and vfunc = value list -> value
 
@@ -153,7 +154,7 @@ and venum_value = {
 	enpos : pos option;
 }
 
-let equals a b = match a,b with
+let rec equals a b = match a,b with
 	| VTrue,VTrue
 	| VFalse,VFalse
 	| VNull,VNull -> true
@@ -169,6 +170,8 @@ let equals a b = match a,b with
 	| VVector vv1,VVector vv2 -> vv1 == vv2
 	| VFunction(vf1,_),VFunction(vf2,_) -> vf1 == vf2
 	| VPrototype proto1,VPrototype proto2 -> proto1.ppath = proto2.ppath
+	| VLazy f1,_ -> equals (!f1()) b
+	| _,VLazy f2 -> equals a (!f2())
 	| _ -> a == b
 
 module ValueHashtbl = Hashtbl.Make(struct
@@ -194,4 +197,8 @@ let vint32 i = VInt32 i
 let vfloat f = VFloat f
 let venum_value e = VEnumValue e
 
-let s_expr_pretty e = (Type.s_expr_pretty false "" false (Type.s_type (Type.print_context())) e)
+let s_expr_pretty e = (Type.s_expr_pretty false "" false (Type.s_type (Type.print_context())) e)
+
+let rec vresolve v = match v with
+	| VLazy f -> vresolve (!f())
+	| _ -> v

src/macro/macroApi.ml

@@ -145,6 +145,7 @@ module type InterpApi = sig
 	val encode_array : value list -> value
 	val encode_string  : string -> value
 	val encode_obj : obj_type -> (string * value) list -> value
+	val encode_lazy : (unit -> value) -> value
 
 	val vfun0 : (unit -> value) -> value
 	val vfun1 : (value -> value) -> value
@@ -577,7 +578,7 @@ and encode_expr e =
 			"expr", encode_enum IExpr tag pl;
 		]
 	in
-	loop e
+	encode_lazy (fun () -> loop e)
 
 and encode_null_expr e =
 	match e with