Commit b8755776 authored by Pietro Abate's avatar Pietro Abate

[r2002-10-26 16:18:24 by cvscast] Empty log message

Original author: cvscast
Date: 2002-10-26 16:18:25+00:00
parent 7598af7d
......@@ -13,15 +13,17 @@ TYPES = types/recursive.cmo types/sortedList.cmo \
types/sequence.cmo \
types/builtin.cmo
RUNTIME = runtime/value.cmo
DRIVER = driver/cduce.cmo
DIRS = parser typing types driver
OBJECTS = $(TYPES) $(PARSER) $(TYPING)
OBJECTS = $(TYPES) $(PARSER) $(TYPING) $(RUNTIME)
XOBJECTS = $(OBJECTS:.cmo=.cmx)
XDRIVER = $(DRIVER:.cmo=.cmx)
DEPEND = parser/*.ml parser/*.mli typing/*.ml typing/*.mli types/*.ml types/*.mli driver/*.mli driver/*.ml
DEPEND = parser/*.ml parser/*.mli typing/*.ml typing/*.mli types/*.ml types/*.mli runtime/*.mli runtime/*.ml driver/*.mli driver/*.ml
INCLUDES = -I +camlp4 -I parser -I types -I typing
SYNTAX_PARSER = -pp 'camlp4o pa_extend.cmo'
......
......@@ -59,7 +59,12 @@ types/sortedMap.cmi: types/sortedList.cmi
types/syntax.cmi: types/patterns.cmi types/types.cmi
types/types.cmi: types/atoms.cmi types/chars.cmi types/intervals.cmi \
types/sortedMap.cmi
runtime/value.cmi: types/chars.cmi typing/typed.cmo types/types.cmi
runtime/value.cmo: types/chars.cmi typing/typed.cmo types/types.cmi \
runtime/value.cmi
runtime/value.cmx: types/chars.cmx typing/typed.cmx types/types.cmx \
runtime/value.cmi
driver/cduce.cmo: parser/ast.cmo types/builtin.cmo parser/location.cmi \
parser/parser.cmi typing/typer.cmi types/types.cmi
parser/parser.cmi types/patterns.cmi typing/typer.cmi types/types.cmi
driver/cduce.cmx: parser/ast.cmx types/builtin.cmx parser/location.cmx \
parser/parser.cmx typing/typer.cmx types/types.cmx
parser/parser.cmx types/patterns.cmx typing/typer.cmx types/types.cmx
type t
type env
type descr =
| Pair of t * t
| Record of (Types.label * t) list
| Atom of Types.atom
| Integer of int
| String of string
| Fun of unit (* TODO ... *)
val print: Format.formatter -> t -> unit
val descr: t -> descr
val run_dispatcher: Patterns.Compile.dispatcher -> t -> int * t array
val eval: env -> Typed.texpr -> t
......@@ -19,7 +19,7 @@ val atom : Unichar.t -> t
val is_empty : t -> bool
val contains : int -> t -> bool
val contains : Unichar.t -> t -> bool
val sample : t -> Unichar.t
val print : t -> (Format.formatter -> unit) list
......@@ -331,8 +331,13 @@ struct
[ `Label of Types.label * record dispatch * record option
| `Result of result ]
and 'a dispatch = dispatcher * 'a array
and result = int * source list
and 'a dispatch =
[ `Dispatch of dispatcher * 'a array
| `TailCall of dispatcher
| `Ignore of 'a
| `None ]
and result = int * source array
and source =
[ `Catch | `Const of Types.const
| `Left of int | `Right of int | `Recompose of int * int
......@@ -356,7 +361,70 @@ struct
codes : return_code array;
mutable actions : actions option
}
let array_for_all f a =
let rec aux f a i =
if i = Array.length a then true
else f a.(i) && (aux f a (succ i))
in
aux f a 0
let array_for_all_i f a =
let rec aux f a i =
if i = Array.length a then true
else f i a.(i) && (aux f a (succ i))
in
aux f a 0
let combine disp act =
if Array.length act = 0 then `None
else
if (array_for_all (fun (_,ar,_) -> ar = 0) disp.codes)
&& (array_for_all ( (=) act.(0) ) act) then
`Ignore act.(0)
else
`Dispatch (disp, act)
let combine_record l present absent =
match (present,absent) with
| (`Ignore r1, Some r2) when r1 = r2 -> r1
| (`Ignore r, None) -> r
| _ -> `Label (l, present, absent)
let detect_right_tail_call = function
| `Dispatch (disp,branches)
when
array_for_all_i
(fun i (code,ret) ->
(i = code) &&
(array_for_all_i
(fun pos ->
function `Right j when pos = j -> true | _ -> false)
ret
)
) branches
-> `TailCall disp
| x -> x
let detect_left_tail_call = function
| `Dispatch (disp,branches)
when
array_for_all_i
(fun i ->
function
| `Ignore (code,ret) ->
(i = code) &&
(array_for_all_i
(fun pos ->
function `Left j when pos = j -> true | _ -> false)
ret
)
| _ -> false
) branches
->
`TailCall disp
| x -> x
let cur_id = ref 0
module DispMap = Map.Make(
......@@ -428,11 +496,13 @@ struct
aux 0 d.interface
let create_result pl =
Array.fold_right
(fun x accu -> match x with
| Some b -> b @ accu
| None -> accu)
pl []
Array.of_list (
Array.fold_right
(fun x accu -> match x with
| Some b -> b @ accu
| None -> accu)
pl []
)
let return disp pl f =
let aux = function [x] -> Some (f x) | [] -> None | _ -> assert false in
......@@ -484,7 +554,7 @@ struct
!accu
let get_tests pl f t d =
let get_tests pl f t d post =
let accu = ref [] in
let unselect = Array.create (Array.length pl) [] in
let aux i x =
......@@ -505,7 +575,7 @@ struct
d t selected unselect
in
let res = Array.map result disp.codes in
(disp,res)
post (combine disp res)
......@@ -516,12 +586,14 @@ struct
(fun (res,(p,q)) -> [p, (res,q)], [])
(Types.Product.pi1 t)
(dispatch_prod1 disp t)
detect_left_tail_call
and dispatch_prod1 disp t t1 pl _ =
let t = Types.Product.restrict_1 t t1 in
get_tests pl
(fun (ret1, (res,q)) -> [q, (ret1,res)], [] )
(Types.Product.pi2 t)
(dispatch_prod2 disp t)
detect_right_tail_call
and dispatch_prod2 disp t t2 pl _ =
let aux_final (ret2, (ret1, res)) =
List.map (conv_source_prod ret1 ret2) res in
......@@ -584,13 +656,14 @@ struct
| x -> [],[x])
(Types.Record.project_field t l)
(dispatch_record_field l disp t)
(fun x -> x)
in
let absent =
let pl = label_not_found l pl in
let t = Types.Record.restrict_label_absent t l in
dispatch_record_opt disp t pl
in
`Label (l, present, absent)
combine_record l present absent
and dispatch_record_field l disp t tfield pl others =
let t = Types.Record.restrict_field t l tfield in
let aux (ret, (res, catch, rem)) = (res, (l,ret) :: catch, rem) in
......@@ -629,16 +702,17 @@ struct
| `Recompose (i,j) -> Format.fprintf ppf "(l%i,r%i)" i j
| `Field (l,i) -> Format.fprintf ppf "%s%i" (Types.label_name l) i
in
let rec print_result ppf = function
| [] -> ()
| [s] -> print_source ppf s
| s :: rem ->
Format.fprintf ppf "%a," print_source s;
print_result ppf rem
let print_result ppf =
Array.iteri
(fun i s ->
if i > 0 then Format.fprintf ppf ",";
print_source ppf s;
)
in
let print_ret ppf (code,ret) =
Format.fprintf ppf "$%i" code;
if ret <> [] then Format.fprintf ppf "(%a)" print_result ret in
if Array.length ret <> 0 then
Format.fprintf ppf "(%a)" print_result ret in
let print_lhs ppf (code,prefix,d) =
let arity = match d.codes.(code) with (_,a,_) -> a in
Format.fprintf ppf "$%i(" code;
......@@ -652,30 +726,45 @@ struct
Types.Print.print_descr t
print_ret ret
in
let print_prod2 (d,rem) =
queue d;
Format.fprintf ppf " match v2 with disp_%i@\n" d.id;
Array.iteri
(fun code r ->
Format.fprintf ppf " | %a -> %a\n"
print_lhs (code, "r", d)
print_ret r;
)
rem
let print_prod2 = function
| `None -> assert false
| `Ignore r ->
Format.fprintf ppf " %a\n"
print_ret r
| `TailCall d ->
queue d;
Format.fprintf ppf " disp_%i v2@\n" d.id
| `Dispatch (d, branches) ->
queue d;
Format.fprintf ppf " match v2 with disp_%i@\n" d.id;
Array.iteri
(fun code r ->
Format.fprintf ppf " | %a -> %a\n"
print_lhs (code, "r", d)
print_ret r;
)
branches
in
let print_prod (d,rem) =
if Array.length rem > 0 then (
queue d;
Format.fprintf ppf " | (v1,v2) -> @\n";
Format.fprintf ppf " match v1 with disp_%i@\n" d.id;
Array.iteri
(fun code d2 ->
Format.fprintf ppf " | %a -> @\n"
print_lhs (code, "l", d);
print_prod2 d2;
)
rem
)
let print_prod = function
| `None -> ()
| `Ignore d2 ->
Format.fprintf ppf " | (v1,v2) -> @\n";
print_prod2 d2
| `TailCall d ->
queue d;
Format.fprintf ppf " | (v1,v2) -> @\n";
Format.fprintf ppf " disp_%i v1@\n" d.id
| `Dispatch (d,branches) ->
queue d;
Format.fprintf ppf " | (v1,v2) -> @\n";
Format.fprintf ppf " match v1 with disp_%i@\n" d.id;
Array.iteri
(fun code d2 ->
Format.fprintf ppf " | %a -> @\n"
print_lhs (code, "l", d);
print_prod2 d2;
)
branches
in
let rec print_record_opt ppf = function
| None -> ()
......@@ -684,23 +773,33 @@ struct
Format.fprintf ppf " @[%a@]@\n" print_record r
and print_record ppf = function
| `Result r -> print_ret ppf r
| `Label (l, (d,present), absent) ->
| `Label (l, present, absent) ->
let l = Types.label_name l in
Format.fprintf ppf "check label %s:@\n" l;
Format.fprintf ppf "Present => @[%a@]@\n" (print_present l) present;
match absent with
| Some r ->
Format.fprintf ppf "Absent => @[%a@]@\n"
print_record r
| None -> ()
and print_present l ppf = function
| `None -> assert false
| `TailCall d ->
queue d;
Format.fprintf ppf " check label %s:@\n" l;
Format.fprintf ppf " Present => match with disp_%i@\n" d.id;
Format.fprintf ppf "disp_%i@\n" d.id
| `Dispatch (d,branches) ->
queue d;
Format.fprintf ppf "match with disp_%i@\n" d.id;
Array.iteri
(fun code r ->
Format.fprintf ppf " | %a -> @\n"
Format.fprintf ppf "| %a -> @\n"
print_lhs (code, l, d);
Format.fprintf ppf " @[%a@]@\n"
Format.fprintf ppf " @[%a@]@\n"
print_record r
) present;
match absent with
| Some r ->
Format.fprintf ppf " Absent => @[%a@]@\n"
print_record r
| None -> ()
) branches
| `Ignore r ->
Format.fprintf ppf "@[%a@]@\n"
print_record r
in
List.iter print_basic actions.basic;
......@@ -747,46 +846,3 @@ struct
end
(*
let test_filter t p =
let t = Syntax.make_type (Syntax.parse t)
and p = Syntax.make_pat (Syntax.parse p) in
let r = Patterns.filter (Types.descr t) p in
List.iter (fun (v,t) ->
let t = Types.normalize t in
Format.fprintf Format.std_formatter "@[%s => %a@]@\n"
v Types.Print.print t) r;;
test_filter "[ (1 2 3?)* ]" "[ (x::(1 2) 3?)* ]";;
*)
(*
disp " [(`A `B `C?)*] " [" [ (((x::`A) `B (x::`C))|_)* ] "];;
disp " [(`A)*] " [" [ (x::`A)* ] "];;
disp "_" ["{x=`A;y=`B}"];;
disp "_" [" [((x::1)|(y::2))*] "];;
disp "_" [ "((x,_),_)"; "((_,x),_)" ];;
disp " [ (1 3?)* ]" [ " [(x::1 3?)*] " ];;
disp " [ (1 3?)* ]" [ " [(1 (x::3)?)*] " ];;
*)
(*
#install_printer Types.Print.print_descr;;
let pat s = Patterns.descr (Typer.pat (Parser.From_string.pat s));;
let typ s = Types.descr (Typer.typ (Parser.From_string.pat s));;
let disp t l =
let l = Array.of_list (
List.map (fun p -> Patterns.Compile.normal (pat p)) l) in
let t = typ t in
Patterns.Compile.show Format.std_formatter t l;;
let () = disp "_" ["(x,y,z)"];;
disp "_" ["`A"];;
disp "_" ["((x,y),z) | ((x := 1) & (y := 2), z)"];;
*)
......@@ -39,5 +39,31 @@ module Compile: sig
val normal : descr -> normal
type dispatcher
val dispatcher: Types.descr -> normal array -> dispatcher
type actions = {
basic: (Types.descr * result) list;
prod: result dispatch dispatch;
record: record option;
}
and record =
[ `Label of Types.label * record dispatch * record option
| `Result of result ]
and 'a dispatch =
[ `Dispatch of dispatcher * 'a array
| `TailCall of dispatcher
| `Ignore of 'a
| `None ]
and result = int * source array
and source =
[ `Catch | `Const of Types.const
| `Left of int | `Right of int | `Recompose of int * int
| `Field of Types.label * int
]
val actions: dispatcher -> actions
val show : Format.formatter -> Types.descr -> normal array -> unit
end
......@@ -716,9 +716,9 @@ struct
let rec aux accu1 accu2 = function
| (t1,t2)::left ->
let accu1' = diff_t accu1 t1 in
if not (empty_rec accu1') then aux accu1 accu2 left;
if non_empty accu1' then aux accu1 accu2 left;
let accu2' = cap_t accu2 t2 in
if not (empty_rec accu2') then aux accu1 accu2 left
if non_empty accu2' then aux accu1 accu2 left
| [] -> raise NotEmpty
in
let accu1 = descr s1 in
......@@ -737,6 +737,29 @@ struct
in
aux s.arrow
let check_simple_iface left s1 s2 =
let rec aux accu1 accu2 = function
| (t1,t2)::left ->
let accu1' = diff accu1 t1 in
if non_empty accu1' then aux accu1 accu2 left;
let accu2' = cap accu2 t2 in
if non_empty accu2' then aux accu1 accu2 left
| [] -> raise NotEmpty
in
let accu1 = descr s1 in
(is_empty accu1) ||
(try aux accu1 (diff any (descr s2)) left; true with NotEmpty -> false)
let check_iface iface s =
let rec aux = function
| [] -> false
| (p,n) :: rem ->
((List.for_all (fun (a,b) -> check_simple_iface iface a b) p) &&
(List.for_all (fun (a,b) -> not (check_simple_iface iface a b)) n))
|| (aux rem)
in
aux s.arrow
type t = descr * (descr * descr) list list
let get t =
......@@ -796,6 +819,8 @@ end
module Int = struct
let has_int d i = Intervals.contains i d.ints
let get d = d.ints
let put i = { empty with ints = i }
let is_int d = is_empty { d with ints = Intervals.empty }
......@@ -806,6 +831,10 @@ module Atom = struct
let has_atom d a = Atoms.contains a d.atoms
end
module Char = struct
let has_char d c = Chars.contains c d.chars
end
(*
let rec print_normal_record ppf = function
| Success -> Format.fprintf ppf "Yes"
......
......@@ -122,6 +122,8 @@ module Arrow : sig
and returns a refined type for this abstraction.
*)
val check_iface: (descr * descr) list -> descr -> bool
type t
val is_empty: t -> bool
val get: descr -> t
......@@ -140,6 +142,8 @@ end
module Int : sig
val has_int : descr -> Big_int.big_int -> bool
val any : descr
val is_int : descr -> bool
......@@ -151,6 +155,10 @@ module Atom : sig
val has_atom : descr -> atom -> bool
end
module Char : sig
val has_char : descr -> Chars.Unichar.t -> bool
end
val normalize : descr -> descr
(** Subtyping and sample values **)
......
......@@ -48,10 +48,16 @@ and abstr = {
and branches = {
mutable br_typ : Types.descr;
br_accept : Types.descr;
br_branches: branch list
br_branches: branch list;
mutable br_compiled : compiled_branches option;
}
and branch = {
mutable br_used : bool;
br_pat : tpat;
br_body : texpr
}
and compiled_branches = {
actions : Patterns.Compile.actions;
rhs : (texpr * (string * int) list) array
}
......@@ -387,7 +387,8 @@ let rec expr { loc = loc; descr = d } =
{
Typed.br_typ = Types.empty;
Typed.br_branches = b;
Typed.br_accept = !accept
Typed.br_accept = !accept;
Typed.br_compiled = None;
}
)
......
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