Commit 33f317c5 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 b35ebc6a
......@@ -38,8 +38,8 @@ and typ_descr = function
| Arrow (t,s) -> Types.arrow (typ t) (typ s)
| Tuple tl -> Types.tuple (List.map typ tl)
| PVariant l -> bigcup pvariant l
| Variant (l,_) -> bigcup variant l
| Record (l,_) ->
| Variant (_,l,_) -> bigcup variant l
| Record (_,l,_) ->
let l = List.map (fun (lab,t) -> label lab, typ t) l in
Types.record' (false,(LabelMap.from_list_disj l))
| Abstract "int" -> Builtin_defs.caml_int
......@@ -199,10 +199,10 @@ and to_cd_descr e = function
pair (atom_ascii lab) (to_cd <:expr< x >> t)
) l in
pmatch e cases
| Variant (l,_) ->
| Variant (p,l,_) ->
(* match <...> with
| A -> Value.atom_ascii "A"
| B (x1,x2,..) -> Value.Pair (Value.atom_ascii "B",...,Value.Pair(tn(x)))
| P.A -> Value.atom_ascii "A"
| P.B (x1,x2,..) -> Value.Pair (Value.atom_ascii "B",...,Value.Pair(tn(x)))
*)
let cases =
List.map
......@@ -210,18 +210,18 @@ and to_cd_descr e = function
| (lab,[]) -> <:patt< $uid:lab$ >>, atom_ascii lab
| (lab,tl) ->
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)
) l in
pmatch e cases
| Record (l,_) ->
(* let x = <...> in Value.record [ l1,t1(x.l1); ...; ln,x.ln ] *)
| Record (p,l,_) ->
(* let x = <...> in Value.record [ l1,t1(x.P.l1); ...; ln,x.P.ln ] *)
protect e
(fun x ->
let l =
List.map
(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$) >>)
l
in
......@@ -306,13 +306,13 @@ and to_ml_descr e = function
<:patt< ($str: String.escaped lab$, Some $lid:x$) >>,
<:expr< `$lid:lab$ $to_ml ex t$ >>
) 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
| Variant (l,false) ->
| Variant (_,l,false) ->
failwith "Private Sum type"
| Variant (l,true) ->
| Variant (p,l,true) ->
(* match Value.get_variant <...> with
| "A",None -> A
| "A",None -> P.A
| "B",Some x -> let (x1,r) = x in ...
*)
let cases =
......@@ -323,33 +323,33 @@ and to_ml_descr e = function
(match lab with (* Stupid Camlp4 *)
| "true" -> <:expr< True >>
| "false" -> <:expr< False >>
| lab -> <:expr< $lid:lab$ >>)
| lab -> <:expr< $lid:p^lab$ >>)
| (lab,[t]) ->
let x = mk_var () in
let ex = <:expr< $lid:x$ >> in
<: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) ->
let vars = mk_vars tl in
let el = tuple_to_ml tl vars in
let x = mk_var () in
<:patt< ($str: String.escaped lab$, Some $lid:x$) >>,
matches <:expr< $lid:x$ >>
<:expr< $lid:lab$ ($list:el$) >> vars
<:expr< $lid:p^lab$ ($list:el$) >> vars
) l in
let cases = cases @ [ <:patt< _ >>, <:expr< assert False >> ] in
pmatch <:expr< Value.get_variant $e$ >> cases
| Record (l,false) ->
| Record (_,l,false) ->
failwith "Private Record type"
| Record (l,true) ->
| Record (p,l,true) ->
(* let x = <...> in
{ l1 = t1(Value.get_field x "l1"); ... } *)
{ P.l1 = t1(Value.get_field x "l1"); ... } *)
protect e
(fun x ->
let l =
List.map
(fun (lab,t) ->
(<:patt< $uid:lab$>>,
(<:patt< $lid:p^lab$>>,
to_ml
<:expr< Value.get_field $x$ $label_ascii lab$ >> t)) l in
<:expr< {$list:l$} >>)
......
......@@ -14,8 +14,8 @@ and def =
| Arrow of t * t
| Tuple of t list
| PVariant of (string * t option) list (* Polymorphic variant *)
| Variant of (string * t list) list * bool
| Record of (string * t) list * bool
| Variant of string * (string * t list) list * bool
| Record of string * (string * t) list * bool
| Builtin of string * t list
| Abstract of string
| Var of int
......@@ -50,8 +50,8 @@ and print_def ppf = function
| 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
| PVariant l -> Format.fprintf ppf "[%a]" (print_sep print_palt " | ") l
| Variant (l,_) -> Format.fprintf ppf "[%a]" (print_sep print_alt " | ") l
| Record (l,_) -> Format.fprintf ppf "{%a}" (print_sep print_field " ; ") l
| Variant (p,l,_) -> Format.fprintf ppf "[%s:%a]" p (print_sep print_alt " | ") 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
| Abstract s -> Format.fprintf ppf "%s" s
| Var i -> Format.fprintf ppf "'a%i" i
......@@ -106,12 +106,16 @@ let rec unfold seen constrs ty =
| Ttuple tyl -> Tuple (List.map loop tyl)
| Tvariant rd ->
let fields =
List.map
(fun (lab,f) ->
List.fold_left
(fun accu (lab,f) ->
match f with
| Rpresent (Some t) -> (lab, Some (loop t))
| Rpresent None -> (lab, None)
| _ -> assert false)
| Rpresent (Some t)
| Reither(true, [t], _, _) -> (lab, Some (loop t)) :: accu
| 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
PVariant fields
| Tvar -> Var (get_var ty.id)
......@@ -140,14 +144,18 @@ let rec unfold seen constrs ty =
seen args decl.type_params in
let constrs = StringMap.add pn (slot,args) 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
| Type_variant (cstrs,pub), _ ->
let cstrs =
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), _ ->
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 ->
Link (loop t)
| Type_abstract, None ->
......
......@@ -10,8 +10,8 @@ and def =
| Arrow of t * t
| Tuple of t list
| PVariant of (string * t option) list (* Polymorphic variant *)
| Variant of (string * t list) list * bool
| Record of (string * t) list * bool
| Variant of string * (string * t list) list * bool
| Record of string * (string * t) list * bool
| Builtin of string * t list
| Abstract of string
| Var of int
......
......@@ -3,17 +3,26 @@
STATIC=-static
CAML=ocamlopt
CDUCE=../../cduce
CDO2ML=../../cdo2ml
run:
ocamlc -c a.mli
../../cduce --compile c.cd
../../cduce --compile a.cd
../../cdo2ml $(STATIC) c.cdo > c.ml
../../cdo2ml $(STATIC) a.cdo > a.ml
$(CDUCE) --compile c.cd
$(CDUCE) --compile a.cd
$(CDO2ML) $(STATIC) c.cdo > c.ml
$(CDO2ML) $(STATIC) a.cdo > a.ml
ocamlfind $(CAML) -package cduce -linkpkg -o a c.ml a.ml b.ml
ifeq ($(STATIC),-static)
rm *.cdo
endif
./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:
rm -f *.cmo *.cmx *.o *.cdo *.cmi a.ml *~ a
......@@ -244,7 +244,7 @@ Here is the protocol to compile a single CDuce module:
</li>
<li>
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
CDuce bytecode file.
</li>
......@@ -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
the OCaml glue code. You can do this by giving <code>cdo2ml</code>
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
corresponding <code>.cdo</code> at runtime.
</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