Commit 49e2a7f9 authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2003-03-10 00:14:19 by cvscast] Empty log message

Original author: cvscast
Date: 2003-03-10 00:14:19+00:00
parent 0d9202f8
...@@ -25,6 +25,12 @@ let make_result_basic v (code,r) = ...@@ -25,6 +25,12 @@ let make_result_basic v (code,r) =
) r in ) r in
(code,ret) (code,ret)
let rec run_disp_basic v f = function
| [(_,r)] -> make_result_basic v r
| (t,r)::rem -> if f t then make_result_basic v r else run_disp_basic v f rem
| _ ->
assert false
let dummy_r = [||] let dummy_r = [||]
let rec run_dispatcher d v = let rec run_dispatcher d v =
...@@ -56,12 +62,6 @@ and run_disp_kind actions v = ...@@ -56,12 +62,6 @@ and run_disp_kind actions v =
run_disp_kind actions (normalize v) run_disp_kind actions (normalize v)
and run_disp_basic v f = function
(* | [(_,r)] -> make_result_basic v r *)
| (t,r)::rem -> if f t then make_result_basic v r else run_disp_basic v f rem
| _ ->
assert false
and run_disp_prod v v1 v2 = function and run_disp_prod v v1 v2 = function
| Impossible -> assert false | Impossible -> assert false
...@@ -81,7 +81,7 @@ and run_disp_prod2 v1 r1 v v2 = function ...@@ -81,7 +81,7 @@ and run_disp_prod2 v1 r1 v v2 = function
and run_disp_record other v fields = function and run_disp_record other v fields = function
| None -> assert false | None -> assert false
| Some (`Label (l,d)) -> | Some (RecLabel (l,d)) ->
let rec aux other = function let rec aux other = function
| (l1,_) :: rem when l1 < l -> aux true rem | (l1,_) :: rem when l1 < l -> aux true rem
| (l1,vl) :: rem when l1 = l -> | (l1,vl) :: rem when l1 = l ->
...@@ -90,7 +90,7 @@ and run_disp_record other v fields = function ...@@ -90,7 +90,7 @@ and run_disp_record other v fields = function
run_disp_record1 other Absent rem d run_disp_record1 other Absent rem d
in in
aux other fields aux other fields
| Some (`Nolabel (some,none)) -> | Some (RecNolabel (some,none)) ->
let r = if other then some else none in let r = if other then some else none in
match r with match r with
| Some r -> make_result_basic v r | Some r -> make_result_basic v r
......
...@@ -187,8 +187,8 @@ module Normal : sig ...@@ -187,8 +187,8 @@ module Normal : sig
type nnf = node sl * Types.descr type nnf = node sl * Types.descr
type 'a nline = (result * 'a) list type 'a nline = (result * 'a) list
type record = type record =
[ `Nolabel of result option * result option | RecNolabel of result option * result option
| `Label of Types.label * (nnf * nnf) nline ] | RecLabel of Types.label * (nnf * nnf) nline
type t = { type t = {
nfv : fv; nfv : fv;
ncatchv: fv; ncatchv: fv;
...@@ -223,8 +223,8 @@ struct ...@@ -223,8 +223,8 @@ struct
type nnf = node sl * Types.descr (* pl,t; t <= \accept{pl} *) type nnf = node sl * Types.descr (* pl,t; t <= \accept{pl} *)
type 'a nline = (result * 'a) sl type 'a nline = (result * 'a) sl
type record = type record =
[ `Nolabel of result option * result option | RecNolabel of result option * result option
| `Label of Types.label * (nnf * nnf) nline ] | RecLabel of Types.label * (nnf * nnf) nline
type t = { type t = {
nfv : fv; nfv : fv;
ncatchv: fv; ncatchv: fv;
...@@ -235,18 +235,6 @@ struct ...@@ -235,18 +235,6 @@ struct
nrecord: record nrecord: record
} }
(*
let rec print_record ppf = function
| `Success -> Format.fprintf ppf "Success"
| `SomeField -> Format.fprintf ppf "SomeField"
| `NoField -> Format.fprintf ppf "NoField"
| `Fail -> Format.fprintf ppf "Fail"
| `Dispatch _ -> Format.fprintf ppf "Dispatch"
| `Label (l,pr) ->
Format.fprintf ppf "Label(%s@[" (Types.LabelPool.value l);
List.iter (fun (_,(_,r)) -> Format.fprintf ppf ",%a" print_record r) pr;
Format.fprintf ppf ",%a@])" print_record ab
*)
let fus = IdMap.union_disj let fus = IdMap.union_disj
let slcup = SortedList.cup let slcup = SortedList.cup
...@@ -256,8 +244,8 @@ struct ...@@ -256,8 +244,8 @@ struct
na = Types.empty; na = Types.empty;
nbasic = []; nprod = []; nxml = []; nbasic = []; nprod = []; nxml = [];
nrecord = (match lab with nrecord = (match lab with
| Some l -> `Label (l,[]) | Some l -> RecLabel (l,[])
| None -> `Nolabel (None,None)) | None -> RecNolabel (None,None))
} }
...@@ -271,10 +259,10 @@ struct ...@@ -271,10 +259,10 @@ struct
nprod = SortedList.cup nf1.nprod nf2.nprod; nprod = SortedList.cup nf1.nprod nf2.nprod;
nxml = SortedList.cup nf1.nxml nf2.nxml; nxml = SortedList.cup nf1.nxml nf2.nxml;
nrecord = (match (nf1.nrecord,nf2.nrecord) with nrecord = (match (nf1.nrecord,nf2.nrecord) with
| `Label (l1,r1), `Label (l2,r2) -> | RecLabel (l1,r1), RecLabel (l2,r2) ->
assert (l1 = l2); `Label (l1, slcup r1 r2) assert (l1 = l2); RecLabel (l1, slcup r1 r2)
| `Nolabel (x1,y1), `Nolabel (x2,y2) -> | RecNolabel (x1,y1), RecNolabel (x2,y2) ->
`Nolabel((if x1 = None then x2 else x1), RecNolabel((if x1 = None then x2 else x1),
(if y1 = None then y2 else y1)) (if y1 = None then y2 else y1))
| _ -> assert false) | _ -> assert false)
} }
...@@ -304,17 +292,17 @@ struct ...@@ -304,17 +292,17 @@ struct
(fus res1 res2, t) :: accu (fus res1 res2, t) :: accu
in in
let do_record r1 r2 = match r1,r2 with let do_record r1 r2 = match r1,r2 with
| `Label (l1,r1), `Label (l2,r2) -> | RecLabel (l1,r1), RecLabel (l2,r2) ->
assert (l1 = l2); assert (l1 = l2);
`Label(l1, double_fold prod r1 r2) RecLabel(l1, double_fold prod r1 r2)
| `Nolabel (x1,y1), `Nolabel (x2,y2) -> | RecNolabel (x1,y1), RecNolabel (x2,y2) ->
let x = match x1,x2 with let x = match x1,x2 with
| Some res1, Some res2 -> Some (fus res1 res2) | Some res1, Some res2 -> Some (fus res1 res2)
| _ -> None | _ -> None
and y = match y1,y2 with and y = match y1,y2 with
| Some res1, Some res2 -> Some (fus res1 res2) | Some res1, Some res2 -> Some (fus res1 res2)
| _ -> None in | _ -> None in
`Nolabel (x,y) RecNolabel (x,y)
| _ -> assert false | _ -> assert false
in in
{ nfv = IdSet.cup nf1.nfv nf2.nfv; { nfv = IdSet.cup nf1.nfv nf2.nfv;
...@@ -362,7 +350,7 @@ struct ...@@ -362,7 +350,7 @@ struct
{ nempty lab with { nempty lab with
nfv = p.fv; nfv = p.fv;
na = acc; na = acc;
nrecord = `Label(label, nrecord = RecLabel(label,
[ (src,(nnode p, ([], Types.any))) ])} [ (src,(nnode p, ([], Types.any))) ])}
else else
let src = IdMap.constant SRight p.fv in let src = IdMap.constant SRight p.fv in
...@@ -372,7 +360,7 @@ struct ...@@ -372,7 +360,7 @@ struct
{ nempty lab with { nempty lab with
nfv = p.fv; nfv = p.fv;
na = acc; na = acc;
nrecord = `Label(label, nrecord = RecLabel(label,
[ (src,(([], Types.Record.any_or_absent), [ (src,(([], Types.Record.any_or_absent),
nnode p')) ])} nnode p')) ])}
...@@ -384,10 +372,10 @@ struct ...@@ -384,10 +372,10 @@ struct
| None -> | None ->
(* Should check that r has only empty_cases *) (* Should check that r has only empty_cases *)
let (x,y) = Types.Record.empty_cases t in let (x,y) = Types.Record.empty_cases t in
`Nolabel ((if x then Some empty_res else None), RecNolabel ((if x then Some empty_res else None),
(if y then Some empty_res else None)) (if y then Some empty_res else None))
| Some l -> | Some l ->
`Label (l,aux (Types.Record.split_normal t l)) RecLabel (l,aux (Types.Record.split_normal t l))
in in
{ nempty lab with { nempty lab with
na = t; na = t;
...@@ -406,9 +394,9 @@ struct ...@@ -406,9 +394,9 @@ struct
nprod = [ (l,(([], Types.any),([], Types.any))) ]; nprod = [ (l,(([], Types.any),([], Types.any))) ];
nxml = [ (l,(([], Types.any),([], Types.any))) ]; nxml = [ (l,(([], Types.any),([], Types.any))) ];
nrecord = match lab with nrecord = match lab with
| None -> `Nolabel (Some l, Some l) | None -> RecNolabel (Some l, Some l)
| Some lab -> | Some lab ->
`Label (lab, [ (l,(([], Types.Record.any_or_absent), RecLabel (lab, [ (l,(([], Types.Record.any_or_absent),
([], Types.any))) ]) ([], Types.any))) ])
} }
...@@ -421,9 +409,9 @@ struct ...@@ -421,9 +409,9 @@ struct
nprod = [ (l,(([], Types.any),([], Types.any))) ]; nprod = [ (l,(([], Types.any),([], Types.any))) ];
nxml = [ (l,(([], Types.any),([], Types.any))) ]; nxml = [ (l,(([], Types.any),([], Types.any))) ];
nrecord = match lab with nrecord = match lab with
| None -> `Nolabel (Some l, Some l) | None -> RecNolabel (Some l, Some l)
| Some lab -> | Some lab ->
`Label (lab, [ (l,(([], Types.Record.any_or_absent),([], Types.any))) ]) RecLabel (lab, [ (l,(([], Types.Record.any_or_absent),([], Types.any))) ])
} }
let rec nnormal lab (acc,fv,d) = let rec nnormal lab (acc,fv,d) =
...@@ -469,15 +457,15 @@ struct ...@@ -469,15 +457,15 @@ struct
nprod = nlines n.nprod; nprod = nlines n.nprod;
nxml = nlines n.nxml; nxml = nlines n.nxml;
nrecord = (match n.nrecord with nrecord = (match n.nrecord with
| `Nolabel (x,y) -> | RecNolabel (x,y) ->
let x = match x with let x = match x with
| Some res -> Some (IdMap.diff res ncv) | Some res -> Some (IdMap.diff res ncv)
| None -> None in | None -> None in
let y = match y with let y = match y with
| Some res -> Some (IdMap.diff res ncv) | Some res -> Some (IdMap.diff res ncv)
| None -> None in | None -> None in
`Nolabel (x,y) RecNolabel (x,y)
| `Label (lab,l) -> `Label (lab, nlines l)) | RecLabel (lab,l) -> RecLabel (lab, nlines l))
} }
let normal l t pl = let normal l t pl =
...@@ -501,8 +489,8 @@ struct ...@@ -501,8 +489,8 @@ struct
record: record option; record: record option;
} }
and record = and record =
[ `Label of Types.label * result dispatch dispatch | RecLabel of Types.label * result dispatch dispatch
| `Nolabel of result option * result option ] | RecNolabel of result option * result option
and 'a dispatch = and 'a dispatch =
| Dispatch of dispatcher * 'a array | Dispatch of dispatcher * 'a array
...@@ -566,8 +554,8 @@ struct ...@@ -566,8 +554,8 @@ struct
| _ -> raise Exit in | _ -> raise Exit in
let rs = match record with let rs = match record with
| None -> rs | None -> rs
| Some (`Label (_,Ignore (Ignore r))) -> r :: rs | Some (RecLabel (_,Ignore (Ignore r))) -> r :: rs
| Some (`Nolabel (Some r1, Some r2)) -> r1 :: r2 :: rs | Some (RecNolabel (Some r1, Some r2)) -> r1 :: r2 :: rs
| _ -> raise Exit in | _ -> raise Exit in
match rs with match rs with
| ((_, ret) as r) :: rs when | ((_, ret) as r) :: rs when
...@@ -836,8 +824,8 @@ struct ...@@ -836,8 +824,8 @@ struct
let some = let some =
if some then if some then
let pl = Array.map (fun p -> match p.Normal.nrecord with let pl = Array.map (fun p -> match p.Normal.nrecord with
| `Nolabel (Some x,_) -> [x] | Normal.RecNolabel (Some x,_) -> [x]
| `Nolabel (None,_) -> [] | Normal.RecNolabel (None,_) -> []
| _ -> assert false) disp.pl in | _ -> assert false) disp.pl in
Some (return disp pl (IdMap.map_to_list conv_source_basic)) Some (return disp pl (IdMap.map_to_list conv_source_basic))
else None else None
...@@ -845,19 +833,19 @@ struct ...@@ -845,19 +833,19 @@ struct
let none = let none =
if none then if none then
let pl = Array.map (fun p -> match p.Normal.nrecord with let pl = Array.map (fun p -> match p.Normal.nrecord with
| `Nolabel (_,Some x) -> [x] | Normal.RecNolabel (_,Some x) -> [x]
| `Nolabel (_,None) -> [] | Normal.RecNolabel (_,None) -> []
| _ -> assert false) disp.pl in | _ -> assert false) disp.pl in
Some (return disp pl (IdMap.map_to_list conv_source_basic)) Some (return disp pl (IdMap.map_to_list conv_source_basic))
else None else None
in in
Some (`Nolabel (some,none)) Some (RecNolabel (some,none))
| Some lab -> | Some lab ->
let t = Types.Record.split t lab in let t = Types.Record.split t lab in
let pl = Array.map (fun p -> match p.Normal.nrecord with let pl = Array.map (fun p -> match p.Normal.nrecord with
| `Label (_,l) -> l | Normal.RecLabel (_,l) -> l
| _ -> assert false) disp.pl in | _ -> assert false) disp.pl in
Some (`Label (lab,dispatch_prod0 disp t pl)) Some (RecLabel (lab,dispatch_prod0 disp t pl))
(* soucis avec les ncatchv ?? *) (* soucis avec les ncatchv ?? *)
...@@ -973,10 +961,10 @@ struct ...@@ -973,10 +961,10 @@ struct
Format.fprintf ppf " | Record -> @\n"; Format.fprintf ppf " | Record -> @\n";
Format.fprintf ppf " @[%a@]@\n" print_record r Format.fprintf ppf " @[%a@]@\n" print_record r
and print_record ppf = function and print_record ppf = function
| `Nolabel (r1,r2) -> | RecNolabel (r1,r2) ->
Format.fprintf ppf "SomeField:%a;NoField:%a" Format.fprintf ppf "SomeField:%a;NoField:%a"
print_ret_opt r1 print_ret_opt r2 print_ret_opt r1 print_ret_opt r2
| `Label (l, d) -> | RecLabel (l, d) ->
let l = Types.LabelPool.value l in let l = Types.LabelPool.value l in
Format.fprintf ppf "check label %s:@\n" l; Format.fprintf ppf "check label %s:@\n" l;
Format.fprintf ppf "Present => @[%a@]@\n" (print_prod "record") d Format.fprintf ppf "Present => @[%a@]@\n" (print_prod "record") d
......
...@@ -56,8 +56,8 @@ module Compile: sig ...@@ -56,8 +56,8 @@ module Compile: sig
record: record option; record: record option;
} }
and record = and record =
[ `Label of Types.label * result dispatch dispatch | RecLabel of Types.label * result dispatch dispatch
| `Nolabel of result option * result option ] | RecNolabel of result option * result option
and 'a dispatch = and 'a dispatch =
| Dispatch of dispatcher * 'a array | Dispatch of dispatcher * 'a array
| TailCall of dispatcher | TailCall of dispatcher
......
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