Commit 67408062 authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2004-06-28 15:53:47 by afrisch] Path for fields and labels; Reither

Original author: afrisch
Date: 2004-06-28 15:53:48+00:00
parent 264d528d
...@@ -38,8 +38,8 @@ and typ_descr = function ...@@ -38,8 +38,8 @@ and typ_descr = function
| Arrow (t,s) -> Types.arrow (typ t) (typ s) | Arrow (t,s) -> Types.arrow (typ t) (typ s)
| Tuple tl -> Types.tuple (List.map typ tl) | Tuple tl -> Types.tuple (List.map typ tl)
| PVariant l -> bigcup pvariant l | PVariant l -> bigcup pvariant l
| Variant (l,_) -> bigcup variant l | Variant (_,l,_) -> bigcup variant l
| Record (l,_) -> | Record (_,l,_) ->
let l = List.map (fun (lab,t) -> label lab, typ t) l in let l = List.map (fun (lab,t) -> label lab, typ t) l in
Types.record' (false,(LabelMap.from_list_disj l)) Types.record' (false,(LabelMap.from_list_disj l))
| Abstract "int" -> Builtin_defs.caml_int | Abstract "int" -> Builtin_defs.caml_int
...@@ -199,10 +199,10 @@ and to_cd_descr e = function ...@@ -199,10 +199,10 @@ and to_cd_descr e = function
pair (atom_ascii lab) (to_cd <:expr< x >> t) pair (atom_ascii lab) (to_cd <:expr< x >> t)
) l in ) l in
pmatch e cases pmatch e cases
| Variant (l,_) -> | Variant (p,l,_) ->
(* match <...> with (* match <...> with
| A -> Value.atom_ascii "A" | P.A -> Value.atom_ascii "A"
| B (x1,x2,..) -> Value.Pair (Value.atom_ascii "B",...,Value.Pair(tn(x))) | P.B (x1,x2,..) -> Value.Pair (Value.atom_ascii "B",...,Value.Pair(tn(x)))
*) *)
let cases = let cases =
List.map List.map
...@@ -210,18 +210,18 @@ and to_cd_descr e = function ...@@ -210,18 +210,18 @@ and to_cd_descr e = function
| (lab,[]) -> <:patt< $uid:lab$ >>, atom_ascii lab | (lab,[]) -> <:patt< $uid:lab$ >>, atom_ascii lab
| (lab,tl) -> | (lab,tl) ->
let vars = mk_vars tl in let vars = mk_vars tl in
<:patt< $uid:lab$ $pat_tuple vars$ >>, <:patt< $lid:p^lab$ $pat_tuple vars$ >>,
tuple (atom_ascii lab :: tuple_to_cd tl vars) tuple (atom_ascii lab :: tuple_to_cd tl vars)
) l in ) l in
pmatch e cases pmatch e cases
| Record (l,_) -> | Record (p,l,_) ->
(* let x = <...> in Value.record [ l1,t1(x.l1); ...; ln,x.ln ] *) (* let x = <...> in Value.record [ l1,t1(x.P.l1); ...; ln,x.P.ln ] *)
protect e protect e
(fun x -> (fun x ->
let l = let l =
List.map List.map
(fun (lab,t) -> (fun (lab,t) ->
let e = to_cd <:expr<$x$.$lid:lab$>> t in let e = to_cd <:expr<$x$.$lid:p^lab$>> t in
<:expr< ($label_ascii lab$, $e$) >>) <:expr< ($label_ascii lab$, $e$) >>)
l l
in in
...@@ -306,13 +306,13 @@ and to_ml_descr e = function ...@@ -306,13 +306,13 @@ and to_ml_descr e = function
<:patt< ($str: String.escaped lab$, Some $lid:x$) >>, <:patt< ($str: String.escaped lab$, Some $lid:x$) >>,
<:expr< `$lid:lab$ $to_ml ex t$ >> <:expr< `$lid:lab$ $to_ml ex t$ >>
) l in ) l in
let cases = cases @ [ <:patt< _ >>, <:expr< assert false >> ] in let cases = cases @ [ <:patt< _ >>, <:expr< assert False >> ] in
pmatch <:expr< Value.get_variant $e$ >> cases pmatch <:expr< Value.get_variant $e$ >> cases
| Variant (l,false) -> | Variant (_,l,false) ->
failwith "Private Sum type" failwith "Private Sum type"
| Variant (l,true) -> | Variant (p,l,true) ->
(* match Value.get_variant <...> with (* match Value.get_variant <...> with
| "A",None -> A | "A",None -> P.A
| "B",Some x -> let (x1,r) = x in ... | "B",Some x -> let (x1,r) = x in ...
*) *)
let cases = let cases =
...@@ -323,33 +323,33 @@ and to_ml_descr e = function ...@@ -323,33 +323,33 @@ and to_ml_descr e = function
(match lab with (* Stupid Camlp4 *) (match lab with (* Stupid Camlp4 *)
| "true" -> <:expr< True >> | "true" -> <:expr< True >>
| "false" -> <:expr< False >> | "false" -> <:expr< False >>
| lab -> <:expr< $lid:lab$ >>) | lab -> <:expr< $lid:p^lab$ >>)
| (lab,[t]) -> | (lab,[t]) ->
let x = mk_var () in let x = mk_var () in
let ex = <:expr< $lid:x$ >> in let ex = <:expr< $lid:x$ >> in
<:patt< ($str: String.escaped lab$, Some $lid:x$) >>, <:patt< ($str: String.escaped lab$, Some $lid:x$) >>,
<:expr< $lid:lab$ $to_ml ex t$ >> <:expr< $lid:p^lab$ $to_ml ex t$ >>
| (lab,tl) -> | (lab,tl) ->
let vars = mk_vars tl in let vars = mk_vars tl in
let el = tuple_to_ml tl vars in let el = tuple_to_ml tl vars in
let x = mk_var () in let x = mk_var () in
<:patt< ($str: String.escaped lab$, Some $lid:x$) >>, <:patt< ($str: String.escaped lab$, Some $lid:x$) >>,
matches <:expr< $lid:x$ >> matches <:expr< $lid:x$ >>
<:expr< $lid:lab$ ($list:el$) >> vars <:expr< $lid:p^lab$ ($list:el$) >> vars
) l in ) l in
let cases = cases @ [ <:patt< _ >>, <:expr< assert False >> ] in let cases = cases @ [ <:patt< _ >>, <:expr< assert False >> ] in
pmatch <:expr< Value.get_variant $e$ >> cases pmatch <:expr< Value.get_variant $e$ >> cases
| Record (l,false) -> | Record (_,l,false) ->
failwith "Private Record type" failwith "Private Record type"
| Record (l,true) -> | Record (p,l,true) ->
(* let x = <...> in (* let x = <...> in
{ l1 = t1(Value.get_field x "l1"); ... } *) { P.l1 = t1(Value.get_field x "l1"); ... } *)
protect e protect e
(fun x -> (fun x ->
let l = let l =
List.map List.map
(fun (lab,t) -> (fun (lab,t) ->
(<:patt< $uid:lab$>>, (<:patt< $lid:p^lab$>>,
to_ml to_ml
<:expr< Value.get_field $x$ $label_ascii lab$ >> t)) l in <:expr< Value.get_field $x$ $label_ascii lab$ >> t)) l in
<:expr< {$list:l$} >>) <:expr< {$list:l$} >>)
......
...@@ -14,8 +14,8 @@ and def = ...@@ -14,8 +14,8 @@ and def =
| Arrow of t * t | Arrow of t * t
| Tuple of t list | Tuple of t list
| PVariant of (string * t option) list (* Polymorphic variant *) | PVariant of (string * t option) list (* Polymorphic variant *)
| Variant of (string * t list) list * bool | Variant of string * (string * t list) list * bool
| Record of (string * t) list * bool | Record of string * (string * t) list * bool
| Builtin of string * t list | Builtin of string * t list
| Abstract of string | Abstract of string
| Var of int | Var of int
...@@ -50,8 +50,8 @@ and print_def ppf = function ...@@ -50,8 +50,8 @@ and print_def ppf = function
| Arrow (t,s) -> Format.fprintf ppf "%a -> %a" print_slot t print_slot s | Arrow (t,s) -> Format.fprintf ppf "%a -> %a" print_slot t print_slot s
| Tuple tl -> Format.fprintf ppf "(%a)" (print_sep print_slot ",") tl | Tuple tl -> Format.fprintf ppf "(%a)" (print_sep print_slot ",") tl
| PVariant l -> Format.fprintf ppf "[%a]" (print_sep print_palt " | ") l | PVariant l -> Format.fprintf ppf "[%a]" (print_sep print_palt " | ") l
| Variant (l,_) -> Format.fprintf ppf "[%a]" (print_sep print_alt " | ") l | Variant (p,l,_) -> Format.fprintf ppf "[%s:%a]" p (print_sep print_alt " | ") l
| Record (l,_) -> Format.fprintf ppf "{%a}" (print_sep print_field " ; ") l | Record (p,l,_) -> Format.fprintf ppf "{%s:%a}" p (print_sep print_field " ; ") l
| Builtin (p,tl) -> Format.fprintf ppf "%s(%a)" p (print_sep print_slot ",") tl | Builtin (p,tl) -> Format.fprintf ppf "%s(%a)" p (print_sep print_slot ",") tl
| Abstract s -> Format.fprintf ppf "%s" s | Abstract s -> Format.fprintf ppf "%s" s
| Var i -> Format.fprintf ppf "'a%i" i | Var i -> Format.fprintf ppf "'a%i" i
...@@ -106,12 +106,16 @@ let rec unfold seen constrs ty = ...@@ -106,12 +106,16 @@ let rec unfold seen constrs ty =
| Ttuple tyl -> Tuple (List.map loop tyl) | Ttuple tyl -> Tuple (List.map loop tyl)
| Tvariant rd -> | Tvariant rd ->
let fields = let fields =
List.map List.fold_left
(fun (lab,f) -> (fun accu (lab,f) ->
match f with match f with
| Rpresent (Some t) -> (lab, Some (loop t)) | Rpresent (Some t)
| Rpresent None -> (lab, None) | Reither(true, [t], _, _) -> (lab, Some (loop t)) :: accu
| _ -> assert false) | Rpresent None
| Reither(true, [], _, _) -> (lab, None) :: accu
| Rabsent -> Printf.eprintf "Warning: Rabsent not supported"; accu
| Reither _ -> Printf.eprintf "Warning: Reither not supported"; accu
) []
rd.row_fields in rd.row_fields in
PVariant fields PVariant fields
| Tvar -> Var (get_var ty.id) | Tvar -> Var (get_var ty.id)
...@@ -140,14 +144,18 @@ let rec unfold seen constrs ty = ...@@ -140,14 +144,18 @@ let rec unfold seen constrs ty =
seen args decl.type_params in seen args decl.type_params in
let constrs = StringMap.add pn (slot,args) constrs in let constrs = StringMap.add pn (slot,args) constrs in
let loop = unfold seen constrs in let loop = unfold seen constrs in
let prefix = match p with
| Path.Pident _ -> ""
| Path.Pdot (p,_,_) -> Path.name p ^ "."
| _ -> assert false in
(match decl.type_kind, decl.type_manifest with (match decl.type_kind, decl.type_manifest with
| Type_variant (cstrs,pub), _ -> | Type_variant (cstrs,pub), _ ->
let cstrs = let cstrs =
List.map (fun (cst,f) -> (cst,List.map loop f)) cstrs in List.map (fun (cst,f) -> (cst,List.map loop f)) cstrs in
Variant (cstrs, pub = Public) Variant (prefix, cstrs, pub = Public)
| Type_record (f,_,pub), _ -> | Type_record (f,_,pub), _ ->
let f = List.map (fun (l,_,t) -> (l,loop t)) f in let f = List.map (fun (l,_,t) -> (l,loop t)) f in
Record (f, pub = Public) Record (prefix, f, pub = Public)
| Type_abstract, Some t -> | Type_abstract, Some t ->
Link (loop t) Link (loop t)
| Type_abstract, None -> | Type_abstract, None ->
......
...@@ -10,8 +10,8 @@ and def = ...@@ -10,8 +10,8 @@ and def =
| Arrow of t * t | Arrow of t * t
| Tuple of t list | Tuple of t list
| PVariant of (string * t option) list (* Polymorphic variant *) | PVariant of (string * t option) list (* Polymorphic variant *)
| Variant of (string * t list) list * bool | Variant of string * (string * t list) list * bool
| Record of (string * t) list * bool | Record of string * (string * t) list * bool
| Builtin of string * t list | Builtin of string * t list
| Abstract of string | Abstract of string
| Var of int | Var of int
......
...@@ -3,17 +3,26 @@ ...@@ -3,17 +3,26 @@
STATIC=-static STATIC=-static
CAML=ocamlopt CAML=ocamlopt
CDUCE=../../cduce
CDO2ML=../../cdo2ml
run: run:
ocamlc -c a.mli ocamlc -c a.mli
../../cduce --compile c.cd $(CDUCE) --compile c.cd
../../cduce --compile a.cd $(CDUCE) --compile a.cd
../../cdo2ml $(STATIC) c.cdo > c.ml $(CDO2ML) $(STATIC) c.cdo > c.ml
../../cdo2ml $(STATIC) a.cdo > a.ml $(CDO2ML) $(STATIC) a.cdo > a.ml
ocamlfind $(CAML) -package cduce -linkpkg -o a c.ml a.ml b.ml ocamlfind $(CAML) -package cduce -linkpkg -o a c.ml a.ml b.ml
ifeq ($(STATIC),-static) ifeq ($(STATIC),-static)
rm *.cdo rm *.cdo
endif endif
./a ./a
.PHONY: cdsdl
cdsdl:
$(CDUCE) --compile cdsdl.cd -I `ocamlfind query ocamlsdl`
ocamlfind ocamlc -o cdsdl -pp "$(CDO2ML) -static" -impl cdsdl.cdo -package cduce,ocamlsdl -linkpkg
./cdsdl
clean: clean:
rm -f *.cmo *.cmx *.o *.cdo *.cmi a.ml *~ a rm -f *.cmo *.cmx *.o *.cdo *.cmi a.ml *~ a
...@@ -244,7 +244,7 @@ Here is the protocol to compile a single CDuce module: ...@@ -244,7 +244,7 @@ Here is the protocol to compile a single CDuce module:
</li> </li>
<li> <li>
Compile the OCaml glue code Compile the OCaml glue code
<code>ocamlfind ocamlc -c -package cduce -pp cdo2ml foo.cdo</code>. <code>ocamlfind ocamlc -c -package cduce -pp cdo2ml -impl foo.cdo</code>.
The<code>cdo2ml</code> tool extracts the OCaml glue code from the The<code>cdo2ml</code> tool extracts the OCaml glue code from the
CDuce bytecode file. CDuce bytecode file.
</li> </li>
...@@ -263,7 +263,7 @@ Here is the protocol to compile a single CDuce module: ...@@ -263,7 +263,7 @@ Here is the protocol to compile a single CDuce module:
It might be preferable to include the CDuce bytecode directly into It might be preferable to include the CDuce bytecode directly into
the OCaml glue code. You can do this by giving <code>cdo2ml</code> the OCaml glue code. You can do this by giving <code>cdo2ml</code>
the <code>-static</code> option: the <code>-static</code> option:
<code>ocamlfind ocamlc -c -package cduce -pp "cdo2ml -static" foo.cdo</code>. <code>ocamlfind ocamlc -c -package cduce -pp "cdo2ml -static" -impl foo.cdo</code>.
Modules which have been compiled this way don't need the Modules which have been compiled this way don't need the
corresponding <code>.cdo</code> at runtime. corresponding <code>.cdo</code> at runtime.
</p> </p>
......
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