Commit 2d02b1e9 authored by Pietro Abate's avatar Pietro Abate

[r2002-11-01 20:09:48 by cvscast] Empty log message

Original author: cvscast
Date: 2002-11-01 20:09:49+00:00
parent 58ace5ad
......@@ -58,6 +58,9 @@ toplevel: $(OBJECTS) $(TOPLEVEL)
$(OCAMLC) $(DEBUG) -linkpkg -o $@ gramlib.cma $(OBJECTS) $(TOPLEVEL)
dtd2cduce: tools/dtd2cduce.cmo
$(OCAMLC) $(DEBUG) -linkpkg -o $@ $<
cduce.opt: all.cmxa $(XDRIVER)
$(OCAMLOPT) -linkpkg -o $@ gramlib.cmxa $(XOBJECTS) $(XDRIVER)
......
......@@ -52,20 +52,18 @@ types/types.cmo: types/atoms.cmi types/boolean.cmi types/chars.cmi \
types/types.cmx: types/atoms.cmx types/boolean.cmx types/chars.cmx \
types/intervals.cmx types/recursive.cmx types/recursive_noshare.cmx \
types/sortedList.cmx types/sortedMap.cmx types/types.cmi
runtime/eval.cmo: types/chars.cmi runtime/load_xml.cmi \
runtime/run_dispatch.cmi typing/typed.cmo types/types.cmi \
runtime/value.cmi runtime/eval.cmi
runtime/eval.cmx: types/chars.cmx runtime/load_xml.cmx \
runtime/run_dispatch.cmx typing/typed.cmx types/types.cmx \
runtime/value.cmx runtime/eval.cmi
runtime/eval.cmo: runtime/load_xml.cmi runtime/run_dispatch.cmi \
typing/typed.cmo types/types.cmi runtime/value.cmi runtime/eval.cmi
runtime/eval.cmx: runtime/load_xml.cmx runtime/run_dispatch.cmx \
typing/typed.cmx types/types.cmx runtime/value.cmx runtime/eval.cmi
runtime/load_xml.cmo: types/sortedMap.cmi types/types.cmi runtime/value.cmi \
runtime/load_xml.cmi
runtime/load_xml.cmx: types/sortedMap.cmx types/types.cmx runtime/value.cmx \
runtime/load_xml.cmi
runtime/run_dispatch.cmo: types/patterns.cmi types/types.cmi \
runtime/run_dispatch.cmi
runtime/value.cmi runtime/run_dispatch.cmi
runtime/run_dispatch.cmx: types/patterns.cmx types/types.cmx \
runtime/run_dispatch.cmi
runtime/value.cmx runtime/run_dispatch.cmi
runtime/value.cmo: types/chars.cmi types/sequence.cmi types/sortedMap.cmi \
types/types.cmi runtime/value.cmi
runtime/value.cmx: types/chars.cmx types/sequence.cmx types/sortedMap.cmx \
......
......@@ -50,14 +50,14 @@ let rec print_exn ppf = function
Format.fprintf ppf "but its infered type is: %a@\n"
print_norm s;
Format.fprintf ppf "which is not a subtype, as shown by the value %a@\n"
Types.Print.print_sample (Types.Sample.get (Types.diff s t));
Types.Sample.print (Types.Sample.get (Types.diff s t));
Format.fprintf ppf "%s@\n" msg
| Typer.NonExhaustive t ->
Format.fprintf ppf "This pattern matching is not exhaustive@\n";
Format.fprintf ppf "Residual type: %a@\n"
print_norm t;
Format.fprintf ppf "Sample value: %a@\n"
Types.Print.print_sample (Types.Sample.get t)
Types.Sample.print (Types.Sample.get t)
| Typer.UnboundId x ->
Format.fprintf ppf "Unbound identifier %s@\n" x
| exn ->
......@@ -93,7 +93,7 @@ let eval_env = ref Eval.Env.empty
let insert_type_bindings =
List.iter (fun (x,t) ->
typing_env := Typer.Env.add x t !typing_env;
Format.fprintf ppf "|- %s : %a@\n" x print_norm t)
Format.fprintf ppf "|- %s : %a@\n@." x print_norm t)
let type_decl decl =
insert_type_bindings (Typer.type_let_decl !typing_env decl)
......@@ -103,7 +103,7 @@ let eval_decl decl =
List.iter
(fun (x,v) ->
Eval.enter_global x v;
Format.fprintf ppf "=> %s : @[%a@]@\n" x Value.print v
Format.fprintf ppf "=> %s : @[%a@]@\n@." x Value.print v
) bindings
let phrase ph =
......@@ -111,9 +111,9 @@ let phrase ph =
| Ast.EvalStatement e ->
let (fv,e) = Typer.expr e in
let t = Typer.type_check !typing_env e Types.any true in
Format.fprintf ppf "|- %a@\n" print_norm t;
Format.fprintf ppf "|- %a@\n@." print_norm t;
let v = Eval.eval !eval_env e in
Format.fprintf ppf "=> @[%a@]@\n" Value.print v
Format.fprintf ppf "=> @[%a@]@\n@." Value.print v
| Ast.LetDecl (p,{descr=Ast.Abstraction _}) -> ()
| Ast.LetDecl (p,e) ->
let decl = Typer.let_decl p e in
......
......@@ -173,7 +173,7 @@ EXTEND
| x = regexp; "*?" -> WeakStar x
| x = regexp; "+" -> Seq (x, Star x)
| x = regexp; "+?" -> Seq (x, WeakStar x)
| x = regexp; "?" -> Alt (x, Epsilon)
| x = regexp; "?" -> Alt (x, Epsilon)
| x = regexp; "??" -> Alt (Epsilon, x) ]
| [ "("; x = regexp; ")" -> x
| UIDENT "PCDATA" -> string_regexp
......
......@@ -130,14 +130,3 @@ and eval_int_of e =
try Integer (Big_int.big_int_of_string s)
with Failure _ -> raise exn_int_of
and get_string e =
let rec compute_len accu = function
| Pair (_,y) -> compute_len (accu + 1) y
| String (i,j,_,y) -> compute_len (accu + j - i) y
| _ -> accu in
let rec fill pos s = function
| Pair (Char x,y) -> s.[pos] <- Chars.Unichar.to_char x; fill (pos + 1) s y
| String (i,j,src,y) ->
String.blit src i s pos (j - i); fill (pos + j - i) s y
| _ -> s in
fill 0 (String.create (compute_len 0 e)) e
......@@ -10,3 +10,4 @@ val eval: env -> Typed.texpr -> t
val eval_let_decl: env -> Typed.let_decl -> (string * t) list
......@@ -46,7 +46,8 @@ let rec run_dispatcher d v =
| `Ignore r -> make_result_basic v r
| `Kind k -> run_disp_kind k v
and run_disp_kind actions v = match v with
and run_disp_kind actions v =
match v with
| Pair (v1,v2) -> run_disp_prod v v1 v2 actions.Patterns.Compile.prod
| Record r -> run_disp_record r v [] r actions.Patterns.Compile.record
| Atom a ->
......@@ -65,13 +66,15 @@ and run_disp_kind actions v = match v with
run_disp_kind actions (normalize v)
and run_disp_basic v f = function
and run_disp_basic v f x =
match x with
| [(_,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 x =
match x with
| `None -> assert false
| `TailCall d1 -> run_dispatcher d1 v1
| `Ignore d2 -> run_disp_prod2 v1 dummy_r v v2 d2
......@@ -79,7 +82,8 @@ and run_disp_prod v v1 v2 = function
let (code1,r1) = run_dispatcher d1 v1 in
run_disp_prod2 v1 r1 v v2 b1.(code1)
and run_disp_prod2 v1 r1 v v2 = function
and run_disp_prod2 v1 r1 v v2 x =
match x with
| `None -> assert false
| `Ignore r -> make_result_prod v1 r1 v2 dummy_r v r
| `TailCall d2 -> run_dispatcher d2 v2
......
......@@ -18,6 +18,18 @@ let const = function
| Types.Atom a -> Atom a
| Types.Char c -> Char c
let get_string e =
let rec compute_len accu = function
| Pair (_,y) -> compute_len (accu + 1) y
| String (i,j,_,y) -> compute_len (accu + j - i) y
| _ -> accu in
let rec fill pos s = function
| Pair (Char x,y) -> s.[pos] <- Chars.Unichar.to_char x; fill (pos + 1) s y
| String (i,j,src,y) ->
String.blit src i s pos (j - i); fill (pos + j - i) s y
| _ -> s in
fill 0 (String.create (compute_len 0 e)) e
let rec is_seq = function
| Pair (_, y) when is_seq y -> true
| Atom a when a = Sequence.nil_atom -> true
......@@ -88,4 +100,4 @@ let normalize = function
if i = j then q else
Pair (Char (Chars.Unichar.from_char s.[i]),
String (succ i,j,s,q))
| v -> v
| v -> assert false
......@@ -21,3 +21,5 @@ val normalize: t -> t
val const : Types.const -> t
val string : string -> t
val nil : t
val get_string : t -> string
open Pxp_yacc
open Pxp_lexer_types
open Pxp_types
let import_dtd ppf name filename =
let config = default_config in
let mgr = create_entity_manager config (from_file filename) in
let next_event =
create_pull_parser config (`Entry_document [`Extend_dtd_fully]) mgr in
let event = ref (Some E_end_of_stream) in
let rec regexp ppf = function
| Optional re -> Format.fprintf ppf "%a?" regexp re
| Repeated re -> Format.fprintf ppf "%a*" regexp re
| Repeated1 re -> Format.fprintf ppf "%a+" regexp re
| Seq (re1 :: res) ->
Format.fprintf ppf "(@[%a" regexp re1;
List.iter (fun re -> Format.fprintf ppf "@ %a" regexp re) res;
Format.fprintf ppf "@])"
| Alt (re1 :: res) ->
Format.fprintf ppf "(@[%a" regexp re1;
List.iter (fun re -> Format.fprintf ppf "@ | %a" regexp re) res;
Format.fprintf ppf "@])"
| Child s -> Format.fprintf ppf "%s" (name s)
| _ -> assert false
in
let content ppf = function
| Unspecified | Any -> Format.fprintf ppf "Any*"
| Empty -> Format.fprintf ppf ""
| Mixed l ->
let l = List.map
(function
| MPCDATA -> "Char"
| MChild s -> name s) l in
Format.fprintf ppf "(%s)*" (String.concat " | " l)
| Regexp r -> regexp ppf r
in
let elt ppf e =
Format.fprintf ppf "type %s = <%s>[@[%a@]];;@\n"
(name (e # name))
(e # name)
content (e # content_model)
in
let handle = function
| E_start_doc(_,_,dtd) ->
List.iter (fun x -> elt ppf (dtd # element x)) (dtd # element_names);
exit 1
| _ -> ()
in
let rec loop () =
match next_event () with
| None -> ()
| Some e -> handle e; loop ()
in
loop ()
let () =
let name s = Sys.argv.(1) ^ s in
import_dtd Format.std_formatter name Sys.argv.(2)
let wrap s f x =
Printf.eprintf "%s start\n" s; flush stderr;
let r = f x in
Printf.eprintf "%s stop\n" s; flush stderr;
r
type capture = string
type fv = capture SortedList.t
......@@ -283,7 +289,6 @@ struct
let bigcap = List.fold_left (fun a p -> cap a (nf (descr p))) any
let normal nf =
let basic =
List.map (fun ((res,()),acc) -> (res,acc))
......@@ -292,8 +297,10 @@ struct
let line accu (((res,(pl,ql)),acc)) =
let p = bigcap pl and q = bigcap ql in
let aux accu (t1,t2) = (res,(restrict t1 p,restrict t2 q))::accu in
List.fold_left aux accu (Types.Product.normal acc) in
let t = Types.Product.normal acc in
List.fold_left aux accu t in
List.fold_left line []
and record =
let rec aux nr fields =
......@@ -332,6 +339,7 @@ struct
nprod = nlines (prod nf.prod);
nrecord = nlines (record nf.record);
}
end
......@@ -617,8 +625,9 @@ struct
let aux i x =
let yes, no = f x in
List.iter (fun (p,info) ->
let p = Normal.normal (Normal.restrict t p) in
accu := (p,[i, info]) :: !accu
let p = Normal.restrict t p in
let p = Normal.normal p in
accu := (p,[i, info]) :: !accu;
) yes;
unselect.(i) <- no @ unselect.(i) in
Array.iteri (fun i -> List.iter (aux i)) pl;
......@@ -632,10 +641,10 @@ struct
List.iter (fun (j,r) -> List.iter (add r) infos.(j)) m;
d t selected unselect
in
let res = Array.map result disp.codes in
post (disp,res)
let make_branches t brs =
let (_,brs) =
List.fold_left
......
This diff is collapsed.
......@@ -187,6 +187,8 @@ sig
Extract a sample value from a non empty type;
raise Not_found for an empty type
**)
val print : Format.formatter -> t -> unit
end
module Print :
......@@ -195,7 +197,6 @@ sig
val print_const : Format.formatter -> const -> unit
val print : Format.formatter -> node -> unit
val print_descr: Format.formatter -> descr -> unit
val print_sample : Format.formatter -> Sample.t -> unit
end
val check: descr -> unit
......@@ -87,14 +87,26 @@ module Regexp = struct
| Star r | WeakStar r -> seq_vars accu r
| SeqCapture (v,r) -> seq_vars (StringSet.add v accu) r
let rec propagate vars = function
let uniq_id = let r = ref 0 in fun () -> incr r; !r
type flat = [ `Epsilon
| `Elem of int * Ast.ppat (* the int arg is used to
to stop generic comparison *)
| `Seq of flat * flat
| `Alt of flat * flat
| `Star of flat
| `WeakStar of flat ]
let rec propagate vars : regexp -> flat = function
| Epsilon -> `Epsilon
| Elem x -> `Elem (vars,x)
| Elem x -> let p = vars x in `Elem (uniq_id (),p)
| Seq (r1,r2) -> `Seq (propagate vars r1,propagate vars r2)
| Alt (r1,r2) -> `Alt (propagate vars r1, propagate vars r2)
| Star r -> `Star (propagate vars r)
| WeakStar r -> `WeakStar (propagate vars r)
| SeqCapture (v,x) -> propagate (StringSet.add v vars) x
| SeqCapture (v,x) ->
let v= mk noloc (Capture v) in
propagate (fun p -> mk noloc (And (vars p,v,true))) x
let cup r1 r2 =
match (r1,r2) with
......@@ -102,35 +114,41 @@ module Regexp = struct
| (`Empty, _) -> r2
| (`Res t1, `Res t2) -> `Res (mk noloc (Or (t1,t2)))
(*TODO: review this compilation schema to avoid explosion when
coding (Optional x) by (Or(Epsilon,x)); memoization ... *)
module Memo = Map.Make(struct type t = flat list let compare = compare end)
module Coind = Set.Make(struct type t = flat list let compare = compare end)
let memo = ref Memo.empty
let rec compile fin e seq : [`Res of Ast.ppat | `Empty] =
if List.mem seq e then `Empty
else
let e = seq :: e in
if Coind.mem seq !e then `Empty
else (
e := Coind.add seq !e;
match seq with
| [] ->
`Res fin
| `Epsilon :: rest ->
compile fin e rest
| `Elem (vars,x) :: rest ->
let capt = StringSet.fold
(fun v t -> mk noloc (And (t, (mk noloc (Capture v)), true)))
vars x in
`Res (mk noloc (Prod (capt, guard_compile fin rest)))
| `Elem (_,p) :: rest ->
`Res (mk noloc (Prod (p, guard_compile fin rest)))
| `Seq (r1,r2) :: rest ->
compile fin e (r1 :: r2 :: rest)
| `Alt (r1,r2) :: rest ->
cup (compile fin e (r1::rest)) (compile fin e (r2::rest))
| `Star r :: rest -> cup (compile fin e (r::seq)) (compile fin e rest)
| `WeakStar r :: rest -> cup (compile fin e rest) (compile fin e (r::seq))
| `Star r :: rest ->
cup (compile fin e (r::seq)) (compile fin e rest)
| `WeakStar r :: rest ->
cup (compile fin e rest) (compile fin e (r::seq))
)
and guard_compile fin seq =
try Hashtbl.find memo seq
try Memo.find seq !memo
with
Not_found ->
let n = name () in
let v = mk noloc (PatVar n) in
Hashtbl.add memo seq v;
let d = compile fin [] seq in
memo := Memo.add seq v !memo;
let d = compile fin (ref Coind.empty) seq in
(match d with
| `Empty -> assert false
| `Res d -> defs := (n,d) :: !defs);
......@@ -143,9 +161,9 @@ module Regexp = struct
let compile regexp queue : ppat =
let vars = seq_vars StringSet.empty regexp in
let fin = StringSet.fold constant_nil vars queue in
let n = guard_compile fin [propagate StringSet.empty regexp] in
Hashtbl.clear memo;
let fin = StringSet.fold constant_nil vars queue in
let n = guard_compile fin [propagate (fun p -> p) regexp] in
memo := Memo.empty;
let d = !defs in
defs := [];
mk noloc (Recurs (n,d))
......@@ -181,29 +199,40 @@ and compile_many env b =
env
let rec comp_fv seen s =
let comp_fv_seen = ref []
let comp_fv_res = ref []
let rec comp_fv s =
if List.memq s !comp_fv_seen then ()
else (
comp_fv_seen := s :: !comp_fv_seen;
(match s.descr' with
| `Alias (_,x) -> comp_fv x
| `Or (s1,s2)
| `And (s1,s2,_)
| `Diff (s1,s2)
| `Times (s1,s2)
| `Arrow (s1,s2) -> comp_fv s1; comp_fv s2
| `Record (l,opt,s) -> comp_fv s
| `Type _ -> ()
| `Capture x
| `Constant (x,_) -> comp_fv_res := x :: !comp_fv_res);
if (!comp_fv_res = []) then s.fv <- Some [];
(* TODO: check that the above line is correct *)
)
let fv s =
match s.fv with
| Some l -> l
| None ->
let l =
match s.descr' with
| `Alias (_,x) -> if List.memq s seen then [] else comp_fv (s :: seen) x
| `Or (s1,s2)
| `And (s1,s2,_)
| `Diff (s1,s2)
| `Times (s1,s2)
| `Arrow (s1,s2) -> SortedList.cup (comp_fv seen s1) (comp_fv seen s2)
| `Record (l,opt,s) -> comp_fv seen s
| `Type _ -> []
| `Capture x
| `Constant (x,_) -> [x]
in
if seen = [] then s.fv <- Some l;
| None ->
comp_fv s;
let l = SortedList.from_list !comp_fv_res in
comp_fv_res := [];
comp_fv_seen := [];
s.fv <- Some l;
l
let fv = comp_fv []
let rec typ seen s : Types.descr =
match s.descr' with
| `Alias (v,x) ->
......@@ -231,7 +260,11 @@ and typ_node s : Types.node =
Types.define x t;
x
let type_node s = Types.internalize (typ_node s)
let type_node s =
let s = typ_node s in
let s = Types.internalize s in
(* Types.define s (Types.normalize (Types.descr s)); *)
s
let rec pat seen s : Patterns.descr =
if fv s = [] then Patterns.constr (type_node s) else
......@@ -273,7 +306,7 @@ and pat_node s : Patterns.node =
let global_types = ref StringMap.empty
let mk_typ e =
if fv e = [] then type_node e
if fv e = [] then type_node e
else raise_loc e.loc' (Pattern "Capture variables are not allowed in types")
......@@ -288,8 +321,9 @@ let register_global_types b =
let env = compile_many !global_types b in
List.iter (fun (v,_) ->
let d = Types.descr (mk_typ (StringMap.find v env)) in
let d = Types.normalize d in
Types.Print.register_global v d
(* let d = Types.normalize d in*)
Types.Print.register_global v d;
()
) b;
global_types := env
......
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