Commit 4728d2b7 authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2002-12-02 23:05:47 by cvscast] Empty log message

Original author: cvscast
Date: 2002-12-02 23:05:47+00:00
parent 27c6e232
(* Running dispatchers *)
(* TODO: remove `Absent and clean .... *)
open Value
......@@ -94,28 +96,27 @@ and run_disp_prod2 v1 r1 v v2 x =
and run_disp_record f v bindings fields other = function
| None -> assert false
| Some record -> run_disp_record' f v bindings None fields other record
| Some record -> run_disp_record' f v bindings fields other record
and run_disp_record' f v bindings abs fields other = function
and run_disp_record' f v bindings fields other = function
| `Result r ->
make_result_record f v bindings r
| `Result_other (r1,r2) ->
| `Result_other (_,r1,r2) ->
let other = other || fields <> [] in
make_result_record f v bindings (if other then r1 else r2)
| `Absent -> run_disp_record f v bindings fields other abs
| `Label (l, present, absent) ->
let rec aux other = function
| (l1,_) :: rem when l1 < l -> aux true rem
| (l1,vl) :: rem when l1 = l ->
run_disp_field f v bindings abs rem other l vl present
run_disp_field f v bindings rem other l vl present
| _ -> run_disp_record f v bindings fields other absent
in
aux other fields
and run_disp_field f v bindings abs fields other l vl = function
and run_disp_field f v bindings fields other l vl = function
| `None -> assert false
| `Ignore r -> run_disp_record' f v bindings abs fields other r
| `Ignore r -> run_disp_record' f v bindings fields other r
| `TailCall d -> run_dispatcher d vl
| `Dispatch (dl,bl) ->
let (codel,rl) = run_dispatcher dl vl in
run_disp_record' f v ((l,rl)::bindings) abs fields other bl.(codel)
run_disp_record' f v ((l,rl)::bindings) fields other bl.(codel)
......@@ -1046,8 +1046,7 @@ struct
and record =
[ `Label of Types.label * record dispatch * record option
| `Result of result
| `Result_other of result * result
| `Absent ]
| `Result_other of Types.label list * result * result ]
and 'a dispatch =
[ `Dispatch of dispatcher * 'a array
......@@ -1135,8 +1134,8 @@ struct
let combine_record l present absent =
match (present,absent) with
| (`Ignore r1, Some r2) when r1 = r2 -> r1
| (`Ignore `Absent, Some r) -> r
| (`Ignore r, None) -> r
| (`Ignore r, None) -> r
| (`None, Some r) -> r
| _ -> `Label (l, present, absent)
let detect_right_tail_call = function
......@@ -1231,13 +1230,8 @@ struct
aux 0 d.interface
let create_result pl =
Array.of_list (
Array.fold_right
(fun x accu -> match x with
| Some b -> b @ accu
| None -> accu)
pl []
)
let aux x accu = match x with Some b -> b @ accu | None -> accu in
Array.of_list (Array.fold_right aux pl [])
let return disp pl f =
let aux = function [x] -> Some (f x) | [] -> None | _ -> assert false in
......@@ -1441,12 +1435,12 @@ struct
let prep p = List.map (fun (res,r) -> (res,[],r)) p.Normal.nrecord in
let pl0 = Array.map prep disp.pl in
let t = Types.Record.get disp.t in
let r = dispatch_record_opt disp t pl0 in
let r = dispatch_record_opt disp t pl0 [] in
(* memo_dispatch_record := []; *)
r
and dispatch_record_opt disp t pl =
and dispatch_record_opt disp t pl labs =
if Types.Record.is_empty t then None
else Some (dispatch_record_label disp t pl)
else Some (dispatch_record_label disp t pl labs)
(* and dispatch_record_label disp t pl =
try List.assoc (t,pl) !memo_dispatch_record
with Not_found ->
......@@ -1458,7 +1452,7 @@ struct
let r = !memo_dr_count, r in
memo_dispatch_record := ((t,pl),r) :: !memo_dispatch_record;
r *)
and dispatch_record_label disp t pl =
and dispatch_record_label disp t pl labs =
match collect_first_label pl with
| None ->
let aux_final (res, catch, x) =
......@@ -1479,36 +1473,32 @@ struct
in
(match (somefield,nofield) with
| Some r1, Some r2 ->
if r1 = r2 then `Result r1 else `Result_other(r1,r2)
if r1 = r2 then `Result r1 else `Result_other(labs,r1,r2)
| Some r1, None -> `Result r1
| None, Some r2 -> `Result r2
| _ -> assert false)
| Some l ->
let labs = l :: labs in
let (plabs,absent) =
let pl = label_not_found l pl in
let t = Types.Record.restrict_label_absent t l in
pl, dispatch_record_opt disp t pl
pl, dispatch_record_opt disp t pl labs
in
let present =
let pl = label_found l pl in
let t = Types.Record.restrict_label_present t l in
if Types.Record.is_empty t then None else
Some (
get_tests pl
(function
| (res,catch, `Dispatch d) ->
List.map (fun (p, r) -> p, (res, catch, r)) d, []
| x -> [],[x])
(Types.Record.project_field t l)
(dispatch_record_field l disp t plabs)
(fun x -> combine x)
)
if Types.Record.is_empty t then `None else
get_tests pl
(function
| (res,catch, `Dispatch d) ->
List.map (fun (p, r) -> p, (res, catch, r)) d, []
| x -> [],[x])
(Types.Record.project_field t l)
(dispatch_record_field l disp t plabs labs)
(fun x -> combine x)
in
(match (present,absent) with
| (Some present, absent) -> combine_record l present absent
| (None, Some absent) -> absent
| _ -> assert false)
and dispatch_record_field l disp t plabs tfield pl others =
combine_record l present absent
and dispatch_record_field l disp t plabs labs tfield pl others =
let t = Types.Record.restrict_field t l tfield in
let aux (ret, ncatchv, (res, catch, rem)) =
let catch = if ret = [] then catch else (l,ret) :: catch in
......@@ -1526,7 +1516,7 @@ struct
Need to investigate ....
*)
dispatch_record_label disp t pl
dispatch_record_label disp t pl labs
let actions disp =
......@@ -1638,9 +1628,8 @@ struct
Format.fprintf ppf " @[%a@]@\n" print_record r
and print_record ppf = function
| `Result r -> Format.fprintf ppf "%a" print_ret r
| `Result_other (r1,r2) -> Format.fprintf ppf "SomeField:%a;NoField:%a"
| `Result_other (_,r1,r2) -> Format.fprintf ppf "SomeField:%a;NoField:%a"
print_ret r1 print_ret r2
| `Absent -> Format.fprintf ppf "Jump to Absent"
| `Label (l, present, absent) ->
let l = Types.LabelPool.value l in
Format.fprintf ppf "check label %s:@\n" l;
......
......@@ -60,8 +60,7 @@ module Compile: sig
and record =
[ `Label of Types.label * record dispatch * record option
| `Result of result
| `Result_other of result * result
| `Absent ]
| `Result_other of Types.label list * result * result ]
and 'a dispatch =
[ `Dispatch of dispatcher * 'a array
......
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