Commit 2e0eb048 authored by Pietro Abate's avatar Pietro Abate
Browse files

[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
parent 7acdee2d
......@@ -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
......
......@@ -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$ >>
......
......@@ -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
......
......@@ -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)
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment