Skip to content

C
cduce
Commit f0acfd04 authored by Julien Lopez's avatar Julien Lopez
Browse files
Options

CDuce compiles with OCaml 4. However it has not been fully tested at 

this point. Besides, CDuce doesn't compile here with OCaml 3.12 as
the old types have been replaced by the new ones.
parent c3c01f2f
Hide whitespace changes
Inline Side-by-side
Showing with 104 additions and 69 deletions
ocamliface/mlstub.ml
View file @ f0acfd04
......@@ -47,6 +47,13 @@ let consId s =
in
aux 0
let ident_to_string list =
let rec _ident_to_string list res = match list with
| (id, x) :: rest -> _ident_to_string rest (res @ [id.Caml_cduce.Ident.name, x])
| [] -> res
in
_ident_to_string list [];;
let rec typ t =
try IntHash.find memo_typ t.uid
with Not_found ->
......@@ -62,9 +69,9 @@ and typ_descr = function
| Tuple tl -> Types.tuple (List.map typ tl)
| PVariant l -> bigcup pvariant l
| Variant (_,l,_) -> bigcup variant l
| Record (_,l,_) ->
let l = List.map (fun (lab,t) -> label lab, typ t) l in
Types.record_fields (false,(LabelMap.from_list_disj l))
| Record (_,l,_) -> let l = ident_to_string l in
let l = List.map (fun (lab,t) -> label lab, typ t) l in
Types.record_fields (false, (LabelMap.from_list_disj l))
| Abstract "int" -> Builtin_defs.caml_int
| Abstract "char" -> Builtin_defs.char_latin1
| Abstract "string" -> Builtin_defs.string_latin1
......@@ -86,8 +93,10 @@ and pvariant = function
| (lab, Some t) -> Types.times (Types.cons (atom lab)) (typ t)
and variant = function
| (lab, []) -> atom lab
| (lab, c) -> Types.tuple (Types.cons (atom lab) :: List.map typ c)
| (lab, [], None) -> atom lab.Caml_cduce.Ident.name
| (lab, [], Some o) -> Types.tuple (Types.cons (atom lab.Caml_cduce.Ident.name) :: List.map typ [o])
| (lab, c, Some o) -> Types.tuple (Types.cons (atom lab.Caml_cduce.Ident.name) :: List.map typ (c@[o]))
| (lab, c, None) -> Types.tuple (Types.cons (atom lab.Caml_cduce.Ident.name) :: List.map typ c)
(* Syntactic tools *)
......@@ -218,70 +227,74 @@ and to_cd_descr e = function
| Link t -> to_cd e t
| Arrow (l,t,s) ->
(* let y = <...> in Value.Abstraction ([t,s], fun x -> s(y ~l:(t(x))) *)
protect e
protect e
(fun y ->
let x = mk_var () in
let arg = to_ml <:expr< $lid:x$ >> t in
let res = to_cd (call_lab y l arg) s in
let abs = <:expr< fun $lid:x$ -> $res$ >> in
let iface =
if !gen_types then
let tt = register_type (Types.descr (typ t)) in
let ss = register_type (Types.descr (typ s)) in
<:expr< Some [($tt$,$ss$)] >>
else <:expr< None >> in
<:expr< Value.Abstraction ($iface$,$abs$) >>
let x = mk_var () in
let arg = to_ml <:expr< $lid:x$ >> t in
let res = to_cd (call_lab y l arg) s in
let abs = <:expr< fun $lid:x$ -> $res$ >> in
let iface =
if !gen_types then
let tt = register_type (Types.descr (typ t)) in
let ss = register_type (Types.descr (typ s)) in
<:expr< Some [($tt$,$ss$)] >>
else <:expr< None >> in
<:expr< Value.Abstraction ($iface$,$abs$) >>
)
| Tuple tl ->
(* let (x1,...,xn) = ... in Value.Pair (t1(x1), Value.Pair(...,tn(xn))) *)
let vars = mk_vars tl in
<:expr< let $pat_tuple vars$ = $e$ in $tuple (tuple_to_cd tl vars)$ >>
let vars = mk_vars tl in
<:expr< let $pat_tuple vars$ = $e$ in $tuple (tuple_to_cd tl vars)$ >>
| PVariant l ->
(* match <...> with
| `A -> Value.atom_ascii "A"
| `B x -> Value.Pair (Value.atom_ascii "B",t(x))
*)
let cases =
List.map
(function
| (lab,None) -> <:match_case< `$lid:lab$ -> $atom_ascii lab$ >>
| (lab,Some t) -> <:match_case< `$lid:lab$ x ->
$pair (atom_ascii lab) (to_cd <:expr< x >> t)$ >>
) l in
pmatch e cases
let cases =
List.map
(function
| (lab,None) -> <:match_case< `$lid:lab$ -> $atom_ascii lab$ >>
| (lab,Some t) -> <:match_case< `$lid:lab$ x ->
$pair (atom_ascii lab) (to_cd <:expr< x >> t)$ >>
) l in
pmatch e cases
| Variant (p,l,_) ->
(* match <...> with
| P.A -> Value.atom_ascii "A"
| P.B (x1,x2,..) -> Value.Pair (Value.atom_ascii "B",...,Value.Pair(tn(x)))
*)
let cases =
List.map
(function
| (lab,[]) ->
let pat = match lab with (* Stupid Camlp4 *)
| "true" -> <:patt< True >>
| "false" -> <:patt< False >>
| lab -> <:patt< $id: id (p^lab)$ >>
in
<:match_case< $pat$ -> $atom_ascii lab$ >>
| (lab,tl) ->
let vars = mk_vars tl in
<:match_case< $id: id (p^lab)$ $pat_tuple vars$ ->
$tuple (atom_ascii lab :: tuple_to_cd tl vars)$ >>
) l in
pmatch e cases
let cases =
List.map
(function
| (lab,[],None) ->
let pat = match lab.Caml_cduce.Ident.name with (* Stupid Camlp4 *)
| "true" -> <:patt< True >>
| "false" -> <:patt< False >>
| lab -> <:patt< $id: id (p^lab)$ >>
in
<:match_case< $pat$ -> $atom_ascii lab.Caml_cduce.Ident.name$ >>
| (lab,tl,Some o) ->
let vars = mk_vars (tl@[o]) in
<:match_case< $id: id (p^(lab.Caml_cduce.Ident.name))$ $pat_tuple vars$ ->
$tuple (atom_ascii lab.Caml_cduce.Ident.name :: tuple_to_cd (tl@[o]) vars)$ >>
| (lab,tl,None) ->
let vars = mk_vars tl in
<:match_case< $id: id (p^(lab.Caml_cduce.Ident.name))$ $pat_tuple vars$ ->
$tuple (atom_ascii lab.Caml_cduce.Ident.name :: tuple_to_cd tl vars)$ >>
) l in
pmatch e cases
| Record (p,l,_) ->
(* let x = <...> in Value.record [ l1,t1(x.P.l1); ...; ln,x.P.ln ] *)
protect e
protect e
(fun x ->
let l =
List.map
(fun (lab,t) ->
let e = to_cd <:expr<$x$.$id:id (p^lab)$>> t in
<:expr< ($label_ascii lab$, $e$) >>)
l
in
<:expr< Value.record $list_lit l$ >>)
let l =
List.map
(fun (lab,t) ->
let lab = lab.Caml_cduce.Ident.name in
let e = to_cd <:expr<$x$.$id:id (p^lab)$>> t in
<:expr< ($label_ascii lab$, $e$) >>) l
in
<:expr< Value.record $list_lit l$ >>)
| Abstract "int" -> <:expr< Value.ocaml2cduce_int $e$ >>
| Abstract "char" -> <:expr< Value.ocaml2cduce_char $e$ >>
......@@ -387,19 +400,41 @@ and to_ml_descr e = function
let cases =
List.map
(function
| (lab,[]) ->
| (lab,[],None) ->
let lab = lab.Caml_cduce.Ident.name in
let pa = <:patt< ($str: String.escaped lab$, None) >>
and e = match lab with (* Stupid Camlp4 *)
| "true" -> <:expr< True >>
| "false" -> <:expr< False >>
| lab -> <:expr< $id:id (p ^ lab)$ >> in
<:match_case< $pa$ -> $e$ >>
| (lab,[t]) ->
| (lab,[t],None) ->
let lab = lab.Caml_cduce.Ident.name in
let x = mk_var () in
let ex = <:expr< $lid:x$ >> in
<:match_case< ($str: String.escaped lab$, Some $lid:x$) ->
$id:id (p ^ lab)$ $to_ml ex t$ >>
| (lab,tl) ->
| (lab,[],Some o) ->
let lab = lab.Caml_cduce.Ident.name in
let x = mk_var () in
let ex = <:expr< $lid:x$ >> in
<:match_case< ($str: String.escaped lab$, Some $lid:x$) ->
$id:id (p ^ lab)$ $to_ml ex o$ >>
| (lab,tl,Some o) ->
let lab = lab.Caml_cduce.Ident.name in
let vars = mk_vars (tl@[o]) in
let x = mk_var () in
<:match_case< ($str: String.escaped lab$, Some $lid:x$) ->
$ matches
<:expr< $lid:x$ >> (
List.fold_left
(fun x (t, id) ->
Ast.ExApp(_loc, x, <:expr<$to_ml <:expr< $lid:id$ >> t$>>))
<:expr< $id:consId (p ^ lab)$ >>
(List.combine (tl@[o]) vars))
vars $ >>
| (lab,tl,None) ->
let lab = lab.Caml_cduce.Ident.name in
let vars = mk_vars tl in
let x = mk_var () in
<:match_case< ($str: String.escaped lab$, Some $lid:x$) ->
......@@ -424,6 +459,7 @@ and to_ml_descr e = function
let l =
List.map
(fun (lab,t) ->
let lab = lab.Caml_cduce.Ident.name in
let e =
to_ml <:expr< Value.get_field $x$ $label_ascii lab$ >> t in
<:rec_binding< $id: id (p^lab)$ = $e$ >>) l in
......
ocamliface/mltypes.ml
View file @ f0acfd04
......@@ -211,7 +211,7 @@ and unfold env ty =
) []
rd.row_fields in
PVariant fields
| Tvar ->
| Tvar s ->
(try Link (IntMap.find ty.id env.vars)
with Not_found -> Var (get_var ty.id))
| Tconstr (p,args,_) ->
......@@ -249,7 +249,7 @@ let find_value v =
let values_of_sig name sg =
List.fold_left
(fun accu v -> match v with
| Tsig_value (id,_) ->
| Sig_value (id,_) ->
let id = Ident.name id in
(match id.[0] with
| 'a'..'z' | '_' ->
......@@ -267,7 +267,7 @@ let load_module name =
ocaml_env := Env.initial;
let (_,mty) = Env.lookup_module li Env.initial in
match mty with
| Tmty_signature sg -> values_of_sig name sg
| Mty_signature sg -> values_of_sig name sg
| _ -> raise (Loc.Generic
(Printf.sprintf "Module %s is not a structure" name))
......@@ -296,19 +296,19 @@ let read_cmi name =
let values = ref [] in
List.iter
(function
| Tsig_value (id, {val_type=t;val_kind=Val_reg}) ->
| Sig_value (id, {val_type=t;val_kind=Val_reg}) ->
let (unf,n) = unfold t in
if n !=0 then unsupported "polymorphic value";
values := (Ident.name id, t, unf) :: !values
| Tsig_type (id,t,rs) ->
| Sig_type (id,t,rs) ->
Format.fprintf ppf "%a@."
!Oprint.out_sig_item (Printtyp.tree_of_type_declaration id t rs);
| Tsig_value _ -> unsupported "external value"
| Tsig_exception _ -> unsupported "exception"
| Tsig_module _ -> unsupported "module"
| Tsig_modtype _ -> unsupported "module type"
| Tsig_class _ -> unsupported "class"
| Tsig_cltype _ -> unsupported "class type"
| Sig_value _ -> unsupported "external value"
| Sig_exception _ -> unsupported "exception"
| Sig_module _ -> unsupported "module"
| Sig_modtype _ -> unsupported "module type"
| Sig_class _ -> unsupported "class"
| Sig_class_type _ -> unsupported "class type"
) sg;
(Buffer.contents buf, !values)
......
ocamliface/mltypes.mli
View file @ f0acfd04
......@@ -10,13 +10,12 @@ and def =
| Arrow of string * t * t
| Tuple of t list
| PVariant of (string * t option) list (* Polymorphic variant *)
| Variant of string * (string * t list) list * bool
| Record of string * (string * t) list * bool
| Variant of string * (Ident.t * t list * t option) list * bool
| Record of string * (Ident.t * t) list * bool
| Builtin of string * t list
| Abstract of string
| Var of int
val reg_uid: t -> unit
(* Load an external .cmi *)
......
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