[r2004-06-28 16:42:00 by afrisch] Labelled arguments

Original author: afrisch
Date: 2004-06-28 16:42:49+00:00

ocamliface/mlstub.ml

@@ -35,7 +35,7 @@ let rec typ t =
 
 and typ_descr = function
   | Link t -> typ_descr t.def
-  | 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)
   | PVariant l -> bigcup pvariant l
   | Variant (_,l,_) -> bigcup variant l
@@ -161,6 +161,26 @@ let pat_tuple vars =
   <:patt< ($list:pl$) >>
 
 
+let call_lab f l x =
+  if l = "" then <:expr< $f$ $x$ >>
+  else
+    if l.[0] = '?' then 
+      let l = String.sub l 1 (String.length l - 1) in
+      <:expr< $f$ (? $l$ : $x$) >>
+    else 
+      <:expr< $f$ (~ $l$ : $x$) >>
+
+let abstr_lab l x res =
+  if l = "" then <:expr< fun $lid:x$ -> $res$ >>
+  else
+    if l.[0] = '?' then 
+      let l = String.sub l 1 (String.length l - 1) in
+      <:expr< fun ? $l$ : ( $lid:x$ ) -> $res$ >>
+    else
+      <:expr< fun ~ $l$ : $lid:x$ -> $res$ >>
+
+
+
 let rec to_cd e t =
 (*  Format.fprintf Format.std_formatter "to_cd %a [uid=%i; recurs=%i]@."
     Mltypes.print t t.uid t.recurs; *)
@@ -169,13 +189,13 @@ let rec to_cd e t =
 
 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))) *)
+  | Arrow (l,t,s) -> 
+      (* let y = <...> in Value.Abstraction ([t,s], fun x -> s(y ~l:(t(x))) *)
       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 res = to_cd (call_lab y l 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
@@ -267,14 +287,14 @@ and to_ml e t =
 
 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))) *)
+  | Arrow (l,t,s) -> 
+      (* let y = <...> in fun ~l:x -> s(Eval.eval_apply y (t(x))) *)
       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$ >>
+	 abstr_lab l x res
       )
 
   | Tuple tl -> 

ocamliface/mltypes.ml

@@ -11,7 +11,7 @@ let ocaml_env = ref Env.initial
 type t = { uid : int; mutable recurs : int; mutable def : def }
 and def =
   | Link of t
-  | Arrow of t * t
+  | 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
@@ -47,7 +47,7 @@ let rec print_slot ppf slot =
 
 and print_def ppf = function
   | Link t -> print_slot ppf t
-  | Arrow (t,s) -> Format.fprintf ppf "%a -> %a" print_slot t print_slot s
+  | Arrow (l,t,s) -> Format.fprintf ppf "%s:%a -> %a" l 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 (p,l,_) -> Format.fprintf ppf "[%s:%a]" p (print_sep print_alt " | ") l
@@ -102,7 +102,7 @@ let rec unfold seen constrs ty =
     let loop = unfold seen constrs in
     slot.def <-
     (match ty.desc with
-       | Tarrow (_,t1,t2,_) -> Arrow (loop t1, loop t2)
+       | Tarrow (l,t1,t2,_) -> Arrow (l, loop t1, loop t2)
        | Ttuple tyl -> Tuple (List.map loop tyl)
        | Tvariant rd ->
 	   let fields = 

ocamliface/mltypes.mli

@@ -7,7 +7,7 @@ exception Error of string
 type t = { uid : int; mutable recurs : int; mutable def : def }
 and def =
   | Link of t
-  | Arrow of t * t
+  | 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

web/manual/interface.xml

@@ -58,6 +58,7 @@ Basic OCaml types <code>char</code>, <code>int</code>, <code>string</code>,
 Tuple types <code>t1 * ... tn</code> are translated to nested CDuce
 product types <code>(T(t1),(...,T(tn))...)</code>. A function type
 <code>t -> s</code> is translated to <code>T(t) -> T(s)</code>.
+Labels and optional labels on the argument of the arrow are discarded.
 </p>
 
 <p>