/[svn]/ocamliface/mlstub.ml
ViewVC logotype

Diff of /ocamliface/mlstub.ml

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1171 by abate, Tue Jul 10 18:28:09 2007 UTC revision 1172 by abate, Tue Jul 10 18:28:15 2007 UTC
# Line 35  Line 35 
35    
36  and typ_descr = function  and typ_descr = function
37    | Link t -> typ_descr t.def    | Link t -> typ_descr t.def
38    | Arrow (t,s) -> Types.arrow (typ t) (typ s)    | Arrow (_,t,s) -> Types.arrow (typ t) (typ s)
39    | Tuple tl -> Types.tuple (List.map typ tl)    | Tuple tl -> Types.tuple (List.map typ tl)
40    | PVariant l -> bigcup pvariant l    | PVariant l -> bigcup pvariant l
41    | Variant (_,l,_) -> bigcup variant l    | Variant (_,l,_) -> bigcup variant l
# Line 161  Line 161 
161    <:patt< ($list:pl$) >>    <:patt< ($list:pl$) >>
162    
163    
164    let call_lab f l x =
165      if l = "" then <:expr< $f$ $x$ >>
166      else
167        if l.[0] = '?' then
168          let l = String.sub l 1 (String.length l - 1) in
169          <:expr< $f$ (? $l$ : $x$) >>
170        else
171          <:expr< $f$ (~ $l$ : $x$) >>
172    
173    let abstr_lab l x res =
174      if l = "" then <:expr< fun $lid:x$ -> $res$ >>
175      else
176        if l.[0] = '?' then
177          let l = String.sub l 1 (String.length l - 1) in
178          <:expr< fun ? $l$ : ( $lid:x$ ) -> $res$ >>
179        else
180          <:expr< fun ~ $l$ : $lid:x$ -> $res$ >>
181    
182    
183    
184  let rec to_cd e t =  let rec to_cd e t =
185  (*  Format.fprintf Format.std_formatter "to_cd %a [uid=%i; recurs=%i]@."  (*  Format.fprintf Format.std_formatter "to_cd %a [uid=%i; recurs=%i]@."
186      Mltypes.print t t.uid t.recurs; *)      Mltypes.print t t.uid t.recurs; *)
# Line 169  Line 189 
189    
190  and to_cd_descr e = function  and to_cd_descr e = function
191    | Link t -> to_cd e t    | Link t -> to_cd e t
192    | Arrow (t,s) ->    | Arrow (l,t,s) ->
193        (* let y = <...> in Value.Abstraction ([t,s], fun x -> s(y (t(x))) *)        (* let y = <...> in Value.Abstraction ([t,s], fun x -> s(y ~l:(t(x))) *)
194        protect e        protect e
195        (fun y ->        (fun y ->
196           let x = mk_var () in           let x = mk_var () in
197           let arg = to_ml <:expr< $lid:x$ >> t in           let arg = to_ml <:expr< $lid:x$ >> t in
198           let res = to_cd <:expr< $y$ $arg$ >> s in           let res = to_cd (call_lab y l arg) s in
199           let abs = <:expr< fun $lid:x$ -> $res$ >> in           let abs = <:expr< fun $lid:x$ -> $res$ >> in
200           let tt = register_type (Types.descr (typ t)) in           let tt = register_type (Types.descr (typ t)) in
201           let ss = register_type (Types.descr (typ s)) in           let ss = register_type (Types.descr (typ s)) in
# Line 267  Line 287 
287    
288  and to_ml_descr e = function  and to_ml_descr e = function
289    | Link t -> to_ml e t    | Link t -> to_ml e t
290    | Arrow (t,s) ->    | Arrow (l,t,s) ->
291        (* let y = <...> in fun x -> s(Eval.eval_apply y (t(x))) *)        (* let y = <...> in fun ~l:x -> s(Eval.eval_apply y (t(x))) *)
292        protect e        protect e
293        (fun y ->        (fun y ->
294           let x = mk_var () in           let x = mk_var () in
295           let arg = to_cd <:expr< $lid:x$ >> t in           let arg = to_cd <:expr< $lid:x$ >> t in
296           let res = to_ml <:expr< Eval.eval_apply $y$ $arg$ >> s in           let res = to_ml <:expr< Eval.eval_apply $y$ $arg$ >> s in
297           <:expr< fun $lid:x$ -> $res$ >>           abstr_lab l x res
298        )        )
299    
300    | Tuple tl ->    | Tuple tl ->
Legend:
Removed from v.1171  
changed lines
  Added in v.1172
CVS Admin">CVS Admin
 ViewVC Help
Powered by ViewVC 1.1.5