[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

ocamliface/mlstub.ml

@@ -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$} >>)

ocamliface/mltypes.ml

@@ -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 ->

ocamliface/mltypes.mli

@@ -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

tests/ocaml/Makefile

@@ -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

web/manual/interface.xml

@@ -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>