[r2004-06-28 01:53:47 by afrisch] References, avoid let x1 = x2 in ...

Original author: afrisch
Date: 2004-06-28 01:53:48+00:00

depend

@@ -72,12 +72,12 @@ compile/lambda.cmo: types/ident.cmo types/patterns.cmi misc/serialize.cmi \
     types/types.cmi 
 compile/lambda.cmx: types/ident.cmx types/patterns.cmx misc/serialize.cmx \
     types/types.cmx 
-runtime/value.cmo: types/atoms.cmi types/chars.cmi misc/encodings.cmi \
-    types/ident.cmo types/intervals.cmi compile/lambda.cmo misc/ns.cmi \
-    types/sequence.cmi types/types.cmi runtime/value.cmi 
-runtime/value.cmx: types/atoms.cmx types/chars.cmx misc/encodings.cmx \
-    types/ident.cmx types/intervals.cmx compile/lambda.cmx misc/ns.cmx \
-    types/sequence.cmx types/types.cmx runtime/value.cmi 
+runtime/value.cmo: types/atoms.cmi types/builtin_defs.cmi types/chars.cmi \
+    misc/encodings.cmi types/ident.cmo types/intervals.cmi compile/lambda.cmo \
+    misc/ns.cmi types/sequence.cmi types/types.cmi runtime/value.cmi 
+runtime/value.cmx: types/atoms.cmx types/builtin_defs.cmx types/chars.cmx \
+    misc/encodings.cmx types/ident.cmx types/intervals.cmx compile/lambda.cmx \
+    misc/ns.cmx types/sequence.cmx types/types.cmx runtime/value.cmi 
 schema/schema_types.cmo: misc/encodings.cmi types/intervals.cmi misc/ns.cmi \
     runtime/value.cmi schema/schema_types.cmi 
 schema/schema_types.cmx: misc/encodings.cmx types/intervals.cmx misc/ns.cmx \
@@ -180,14 +180,14 @@ runtime/print_xml.cmx: types/atoms.cmx misc/encodings.cmx types/ident.cmx \
     types/intervals.cmx parser/location.cmx misc/ns.cmx \
     schema/schema_builtin.cmx types/sequence.cmx runtime/value.cmx \
     runtime/print_xml.cmi 
-runtime/eval.cmo: types/builtin_defs.cmi types/ident.cmo compile/lambda.cmo \
-    types/patterns.cmi runtime/run_dispatch.cmi schema/schema_common.cmi \
-    schema/schema_types.cmi schema/schema_validator.cmi types/sequence.cmi \
-    typing/typer.cmi types/types.cmi runtime/value.cmi runtime/eval.cmi 
-runtime/eval.cmx: types/builtin_defs.cmx types/ident.cmx compile/lambda.cmx \
-    types/patterns.cmx runtime/run_dispatch.cmx schema/schema_common.cmx \
-    schema/schema_types.cmx schema/schema_validator.cmx types/sequence.cmx \
-    typing/typer.cmx types/types.cmx runtime/value.cmx runtime/eval.cmi 
+runtime/eval.cmo: types/ident.cmo compile/lambda.cmo types/patterns.cmi \
+    runtime/run_dispatch.cmi schema/schema_common.cmi schema/schema_types.cmi \
+    schema/schema_validator.cmi typing/typer.cmi types/types.cmi \
+    runtime/value.cmi runtime/eval.cmi 
+runtime/eval.cmx: types/ident.cmx compile/lambda.cmx types/patterns.cmx \
+    runtime/run_dispatch.cmx schema/schema_common.cmx schema/schema_types.cmx \
+    schema/schema_validator.cmx typing/typer.cmx types/types.cmx \
+    runtime/value.cmx runtime/eval.cmi 
 compile/compile.cmo: parser/ast.cmo runtime/eval.cmi types/ident.cmo \
     compile/lambda.cmo parser/location.cmi types/patterns.cmi \
     misc/serialize.cmi typing/typed.cmo typing/typer.cmi types/types.cmi \
@@ -226,12 +226,12 @@ ocamliface/mltypes.cmx: cdo2cmo/asttypes.cmx types/ident.cmx \
     driver/librarian.cmx types/types.cmx ocamliface/mltypes.cmi 
 ocamliface/mlstub.cmo: types/atoms.cmi types/builtin_defs.cmi \
     compile/compile.cmi types/ident.cmo driver/librarian.cmi \
-    ocamliface/mltypes.cmi misc/ns.cmi types/sequence.cmi typing/typer.cmi \
-    types/types.cmi ocamliface/mlstub.cmi 
+    parser/location.cmi ocamliface/mltypes.cmi misc/ns.cmi types/sequence.cmi \
+    typing/typer.cmi types/types.cmi ocamliface/mlstub.cmi 
 ocamliface/mlstub.cmx: types/atoms.cmx types/builtin_defs.cmx \
     compile/compile.cmx types/ident.cmx driver/librarian.cmx \
-    ocamliface/mltypes.cmx misc/ns.cmx types/sequence.cmx typing/typer.cmx \
-    types/types.cmx ocamliface/mlstub.cmi 
+    parser/location.cmx ocamliface/mltypes.cmx misc/ns.cmx types/sequence.cmx \
+    typing/typer.cmx types/types.cmx ocamliface/mlstub.cmi 
 driver/cduce.cmo: parser/ast.cmo types/builtin.cmi compile/compile.cmi \
     misc/encodings.cmi runtime/eval.cmi runtime/explain.cmi types/ident.cmo \
     driver/librarian.cmi parser/location.cmi misc/ns.cmi parser/parser.cmi \
@@ -318,9 +318,8 @@ compile/compile.cmi: parser/ast.cmo types/ident.cmo compile/lambda.cmo \
 compile/operators.cmi: misc/custom.cmo parser/location.cmi misc/serialize.cmi \
     typing/typer.cmi types/types.cmi runtime/value.cmi 
 types/builtin.cmi: typing/typer.cmi runtime/value.cmi 
-driver/librarian.cmi: types/types.cmi 
+driver/librarian.cmi: compile/compile.cmi typing/typer.cmi types/types.cmi 
 ocamliface/mltypes.cmi: cdo2cmo/asttypes.cmo types/types.cmi 
-ocamliface/mlstub.cmi: ocamliface/mltypes.cmi types/types.cmi 
 query/query.cmi: parser/ast.cmo 
 schema/schema_types.cmi: misc/encodings.cmi types/intervals.cmi misc/ns.cmi \
     runtime/value.cmi 

ocamliface/mlstub.ml

@@ -103,6 +103,14 @@ let rec matches ine oute = function
 let list_lit el =
   List.fold_right (fun a e -> <:expr< [$a$ :: $e$] >>) el <:expr< [] >>
 
+let protect e f =
+  match e with
+    | <:expr< $lid:x$ >> -> f e
+    | e ->
+	let x = mk_var () in
+	let r = f <:expr< $lid:x$ >> in
+	<:expr< let $lid:x$ = $e$ in $r$ >> 
+
 (* Registered types *)
 
 module HashTypes = Hashtbl.Make(Types)
@@ -166,14 +174,16 @@ and to_cd_descr e = function
   | Link t -> to_cd e t
   | Arrow (t,s) -> 
       (* let y = <...> in Value.Abstraction ([t,s], fun x -> s(y (t(x))) *)
-      let y = mk_var () in
-      let x = mk_var () in
-      let arg = to_ml <:expr< $lid:x$ >> t in
-      let res = to_cd <:expr< $lid:y$ $arg$ >> s in
-      let abs = <:expr< fun $lid:x$ -> $res$ >> in
-      let tt = register_type (Types.descr (typ t)) in
-      let ss = register_type (Types.descr (typ s)) in
-      <:expr< let $lid:y$ = $e$ in Value.Abstraction ([($tt$,$ss$)],$abs$) >>
+      protect e 
+      (fun y ->
+	 let x = mk_var () in
+	 let arg = to_ml <:expr< $lid:x$ >> t in
+	 let res = to_cd <:expr< $y$ $arg$ >> s in
+	 let abs = <:expr< fun $lid:x$ -> $res$ >> in
+	 let tt = register_type (Types.descr (typ t)) in
+	 let ss = register_type (Types.descr (typ s)) in
+	 <:expr< Value.Abstraction ([($tt$,$ss$)],$abs$) >>
+      )
   | Tuple tl -> 
       (* let (x1,...,xn) = ... in Value.Pair (t1(x1), Value.Pair(...,tn(xn))) *)
       let vars = mk_vars tl in
@@ -209,15 +219,16 @@ and to_cd_descr e = function
       pmatch e cases
   | Record (l,_) ->
       (* let x = <...> in Value.record [ l1,t1(x.l1); ...; ln,x.ln ] *)
-      let x = mk_var () in
-      let l = 
-	List.map
-	  (fun (lab,t) ->
-	     let e = to_cd <:expr<$lid:x$.$lid:lab$>> t in
-	     <:expr< ($label_ascii lab$, $e$) >>)
-	  l
-      in
-      let_in <:patt< $lid:x$ >> e <:expr< Value.record $list_lit l$ >>
+      protect e
+      (fun x ->
+	 let l = 
+	   List.map
+	     (fun (lab,t) ->
+		let e = to_cd <:expr<$x$.$lid:lab$>> t in
+		<:expr< ($label_ascii lab$, $e$) >>)
+	     l
+	 in
+	 <:expr< Value.record $list_lit l$ >>)
       
   | Abstract "int" -> <:expr< ocaml2cduce_int $e$ >>
   | Abstract "char" -> <:expr< ocaml2cduce_char $e$ >>
@@ -227,7 +238,19 @@ and to_cd_descr e = function
       (* Value.sequence_rev (List.rev_map fun_t <...>) *)
       <:expr< Value.sequence_rev (List.rev_map $lid:to_cd_fun t$ $e$) >>
   | Builtin ("Pervasives.ref",[t]) ->
-       failwith "to_cd: Reference. TODO"
+      (* let x = <...> in 
+         Value.mk_ext_ref t (fun () -> t(!x)) (fun y -> x := t'(y)) *)
+      protect e 
+      (fun e ->
+	 let y = mk_var () in
+	 let tt = register_type (Types.descr (typ t)) in
+	 let get_x = <:expr< $e$.val >> in
+	 let get = <:expr< fun () -> $to_cd get_x t$ >> in
+	 let tr_y = to_ml <:expr< $lid:y$ >> t in
+	 let set = <:expr< fun $lid:y$ -> $e$.val := $tr_y$ >> in
+	 <:expr< Value.mk_ext_ref $tt$ $get$ $set$ >>
+      )
+
   | Builtin ("CDuce_all.Value.t", []) -> e
   | Builtin ("unit", []) -> <:expr< do { $e$; Value.nil } >>
   | _ -> assert false
@@ -248,11 +271,13 @@ and to_ml_descr e = function
   | Link t -> to_ml e t
   | Arrow (t,s) -> 
       (* let y = <...> in fun x -> s(Eval.eval_apply y (t(x))) *)
-      let y = mk_var () in
-      let x = mk_var () in
-      let arg = to_cd <:expr< $lid:x$ >> t in
-      let res = to_ml <:expr< Eval.eval_apply $lid:y$ $arg$ >> s in
-      <:expr< let $lid:y$ = $e$ in fun $lid:x$ -> $res$ >>
+      protect e 
+      (fun y ->
+	 let x = mk_var () in
+	 let arg = to_cd <:expr< $lid:x$ >> t in
+	 let res = to_ml <:expr< Eval.eval_apply $y$ $arg$ >> s in
+	 <:expr< fun $lid:x$ -> $res$ >>
+      )
 
   | Tuple tl -> 
       (* let (x1,r) = Value.get_pair <...> in
@@ -318,13 +343,15 @@ and to_ml_descr e = function
   | Record (l,true) ->
       (* let x = <...> in
 	 { l1 = t1(Value.get_field x "l1"); ... } *)
-      let x = mk_var () in
-      let l = 
-	List.map
-	  (fun (lab,t) ->
-	     (<:patt< $uid:lab$>>,
-	      to_ml <:expr< Value.get_field $lid:x$ $label_ascii lab$ >> t)) l in
-      let_in <:patt< $lid:x$ >> e <:expr< {$list:l$} >>
+      protect e 
+      (fun x ->
+	 let l = 
+	   List.map
+	     (fun (lab,t) ->
+		(<:patt< $uid:lab$>>,
+		 to_ml 
+		 <:expr< Value.get_field $x$ $label_ascii lab$ >> t)) l in
+	 <:expr< {$list:l$} >>)
 
   | Abstract "int" -> <:expr< cduce2ocaml_int $e$ >>
   | Abstract "char" -> <:expr< cduce2ocaml_char $e$ >>

runtime/eval.ml

@@ -164,13 +164,7 @@ and eval_branches env brs arg =
     | Patterns.Compile.Fail -> Value.Absent
 
 and eval_ref env e t=
-  let r = ref (eval env e) in
-  let get = 
-    Value.Abstraction ([Sequence.nil_type, Types.descr t], fun _ -> !r)
-  and set = 
-    Value.Abstraction 
-      ([Types.descr t, Sequence.nil_type], fun x -> r := x; nil) in
-  Value.Record (Builtin_defs.mk_ref ~get ~set)
+  Value.mk_ref (Types.descr t) (eval env e)
 
 and eval_validate env e kind schema_name name = 
   let schema = Typer.get_schema schema_name in

runtime/value.ml

@@ -576,3 +576,16 @@ let get_abstract = function
   | Abstract (_,v) -> Obj.magic v
   | _ -> assert false
   
+
+let mk_ref t v =
+  let r = ref v in
+  let get = Abstraction ([Sequence.nil_type, t], fun _ -> !r)
+  and set = Abstraction ([t, Sequence.nil_type], fun x -> r := x; nil) in
+  Record (Builtin_defs.mk_ref ~get ~set)
+
+
+let mk_ext_ref t get set =
+  let get = Abstraction ([Sequence.nil_type, t], fun _ -> get ())
+  and set = Abstraction ([t, Sequence.nil_type], fun v -> set v; nil) in
+  Record (Builtin_defs.mk_ref ~get ~set)
+  

runtime/value.mli

@@ -64,6 +64,9 @@ val get_variant : t -> string * t option
 val abstract : Types.Abstract.abs -> 'a -> t
 val get_abstract : t -> 'a
 
+val mk_ref : Types.t -> t -> t
+val mk_ext_ref : Types.t -> (unit -> t) -> (t -> unit) -> t
+
   (* iterator on the content of an Xml value. First callback is invoked on Utf8
   character children; second callback is invoked on other children values *)
 val iter_xml : (U.t -> unit) -> (t -> unit) -> t -> unit