| 1 |
(* TODO: |
(* TODO: |
| 2 |
rewrite type-checking of operators to propagate constraint *) |
- rewrite type-checking of operators to propagate constraint |
| 3 |
|
- rewrite translation of types and patterns -> hash cons |
| 4 |
|
*) |
| 5 |
|
|
| 6 |
|
|
| 7 |
(* I. Transform the abstract syntax of types and patterns into |
(* I. Transform the abstract syntax of types and patterns into |
| 8 |
the internal form *) |
the internal form *) |
| 168 |
defs := (n,d) :: !defs; |
defs := (n,d) :: !defs; |
| 169 |
v |
v |
| 170 |
|
|
|
(* |
|
|
type trans = [ `Alt of gnode * gnode | `Elem of Ast.ppat * gnode | `Final ] |
|
|
and gnode = |
|
|
{ |
|
|
mutable seen : bool; |
|
|
mutable compile : bool; |
|
|
name : string; |
|
|
mutable trans : trans; |
|
|
} |
|
|
|
|
|
let new_node() = { seen = false; compile = false; |
|
|
name = name(); trans = `Final } |
|
|
let to_compile = ref [] |
|
|
|
|
|
let rec compile after = function |
|
|
| `Epsilon -> after |
|
|
| `Elem (_,p) -> |
|
|
if not after.compile then (after.compile <- true; |
|
|
to_compile := after :: !to_compile); |
|
|
{ new_node () with trans = `Elem (p, after) } |
|
|
| `Seq(r1,r2) -> compile (compile after r2) r1 |
|
|
| `Alt(r1,r2) -> |
|
|
let r1 = compile after r1 and r2 = compile after r2 in |
|
|
{ new_node () with trans = `Alt (r1,r2) } |
|
|
| `Star r -> |
|
|
let n = new_node() in |
|
|
n.trans <- `Alt (compile n r, after); |
|
|
n |
|
|
| `WeakStar r -> |
|
|
let n = new_node() in |
|
|
n.trans <- `Alt (after, compile n r); |
|
|
n |
|
|
|
|
|
let seens = ref [] |
|
|
let rec collect_aux accu n = |
|
|
if n.seen then accu |
|
|
else ( seens := n :: !seens; |
|
|
match n.trans with |
|
|
| `Alt (n1,n2) -> collect_aux (collect_aux accu n2) n1 |
|
|
| _ -> n :: accu |
|
|
) |
|
|
|
|
|
let collect fin n = |
|
|
let l = collect_aux [] n in |
|
|
List.iter (fun n -> n.seen <- false) !seens; |
|
|
let l = List.map (fun n -> |
|
|
match n.trans with |
|
|
| `Final -> fin |
|
|
| `Elem (p,a) -> |
|
|
mk !re_loc (Prod(p, mk !re_loc (PatVar a.name))) |
|
|
| _ -> assert false |
|
|
) l in |
|
|
match l with |
|
|
| h::t -> |
|
|
List.fold_left (fun accu p -> mk !re_loc (Or (accu,p))) h t |
|
|
| _ -> assert false |
|
|
*) |
|
|
|
|
|
|
|
| 171 |
let constant_nil t v = |
let constant_nil t v = |
| 172 |
mk_loc !re_loc |
mk_loc !re_loc |
| 173 |
(And (t, (mk_loc !re_loc (Constant (v, Types.Atom Sequence.nil_atom))))) |
(And (t, (mk_loc !re_loc (Constant (v, Types.Atom Sequence.nil_atom))))) |
| 181 |
memo := Memo.empty; |
memo := Memo.empty; |
| 182 |
let d = !defs in |
let d = !defs in |
| 183 |
defs := []; |
defs := []; |
| 184 |
|
mk_loc !re_loc (Recurs (n,d)) |
| 185 |
|
|
| 186 |
(* |
module H = Hashtbl.Make( |
| 187 |
let after = new_node() in |
struct |
| 188 |
let n = collect queue (compile after re) in |
type t = Ast.regexp * Ast.ppat |
| 189 |
let d = List.map (fun n -> (n.name, collect queue n)) !to_compile in |
let equal (r1,p1) (r2,p2) = |
| 190 |
to_compile := []; |
(Ast.equal_regexp r1 r2) && |
| 191 |
*) |
(Ast.equal_ppat p1 p2) |
| 192 |
|
let hash (r,p) = |
| 193 |
|
(Ast.hash_regexp r) + 16637 * (Ast.hash_ppat p) |
| 194 |
|
end) |
| 195 |
|
let hash = H.create 67 |
| 196 |
|
|
| 197 |
mk_loc !re_loc (Recurs (n,d)) |
let compile loc regexp queue : ppat = |
| 198 |
|
try |
| 199 |
|
let c = H.find hash (regexp,queue) in |
| 200 |
|
(* Printf.eprintf "regexp cached\n"; flush stderr; *) |
| 201 |
|
c |
| 202 |
|
with |
| 203 |
|
Not_found -> |
| 204 |
|
let c = compile loc regexp queue in |
| 205 |
|
H.add hash (regexp,queue) c; |
| 206 |
|
c |
| 207 |
end |
end |
| 208 |
|
|
| 209 |
let compile_regexp = Regexp.compile noloc |
let compile_regexp = Regexp.compile noloc |
Parent Directory
| 
Revision Log
| 
Patch