Skip to content

GitLab

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