Commit 25ffd4d5 authored by Pietro Abate's avatar Pietro Abate
Browse files

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

Original author: afrisch
Date: 2004-06-28 16:42:49+00:00
parent 33f317c5
......@@ -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 ->
......
......@@ -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 =
......
......@@ -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
......
......@@ -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>
......
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