*** empty log message ***

14 files changed, 1917 insertions, 0 deletions

diff --git a/perl_checker.src/Makefile b/perl_checker.src/Makefile
new file mode 100644
index 0000000..0dc65c2
--- /dev/null
+++ b/perl_checker.src/Makefile
@@ -0,0 +1,84 @@
+CSLC = ocamlcp -p a
+CSLC = ocamlc
+CSLOPT = ocamlopt
+CSLDEP = ocamldep
+CSLLEX = ocamllex
+CSLYACC = ocamlyacc
+CSLFLAGS = -w A -g
+CSLOPTFLAGS =
+
+LEX_FILES = $(wildcard *.mll)
+YACC_FILES = $(wildcard *.mly)
+TMP_MLFILES = $(YACC_FILES:%.mly=%.ml) $(LEX_FILES:%.mll=%.ml)
+TMP_MLIFILES = $(YACC_FILES:%.mly=%.mli)
+
+ALL_PROGS = perl_checker
+
+PROG_OBJS_WITH_CMI = parser.cmo print.cmo perl_checker.cmo
+PROG_OBJS = common.cmo flags.cmo info.cmo $(LEX_FILES:%.mll=%.cmo) $(PROG_OBJS_WITH_CMI)
+CMA_FILES = 
+
+PROG_OBJX_WITH_CMI = $(PROG_OBJS_WITH_CMI:%.cmo=%.cmx)
+PROG_OBJX = $(PROG_OBJS:%.cmo=%.cmx)
+CMXA_FILES = $(CMA_FILES:%.cma=%.cmxa)
+
+.PHONY: depend tags clean 
+
+default: .compiling TAGS $(ALL_PROGS)
+	rm -f .compiling
+
+all: perl_checker
+
+perl_checker: .depend $(PROG_OBJS)
+	$(CSLC) -custom $(CSLFLAGS) $(LIBDIRS) -o $@ $(CMA_FILES) $(PROG_OBJS)
+	cp -f perl_checker perl_checker_debug
+
+perl_checker_opt: .depend $(PROG_OBJX)
+	$(CSLOPT) $(CSLOPTFLAGS) $(LIBDIRS) -o $@ $(CMXA_FILES) $(PROG_OBJX)
+
+.compiling:
+	touch $@
+
+# Common rules
+.SUFFIXES: .ml .mli .cmo .cmi .cmx .mll .mly
+
+%.ml: %.mll types.cmi parser.cmi
+	$(CSLLEX) $<
+
+%.mli %.ml: %.mly
+	$(CSLYACC) $<
+
+$(PROG_OBJS_WITH_CMI): %.cmo: %.cmi
+
+$(PROG_OBJX_WITH_CMI): %.cmx: %.cmi
+
+%.cmo: %.ml
+	$(CSLC) $(CSLFLAGS) -c $<
+
+%.cmx: %.ml
+	$(CSLOPT) $(CSLOPTFLAGS) -c $<
+
+.mli.cmi:
+	$(CSLC) $(CSLFLAGS) -c $<
+
+clean:
+	rm -f $(ALL_PROGS) *~ *.o *.cm[iox] $(TMP_MLIFILES) $(TMP_MLFILES) .depend .compiling TAGS gmon.out ocamlprof.dump
+
+tags: 
+	ocamltags *.ml
+
+TAGS:
+	ocamltags *.ml
+
+# Dependencies
+depend: .depend
+.depend:
+	$(CSLDEP) $(INCLUDES) *.mli *.mll *.ml > .depend
+
+# missing dependencies:
+perl_checker.cmo: lexer.cmi
+perl_checker.cmx: lexer.cmi
+lexer.cmx: common.cmi
+lexer.cmo: common.cmi
+
+-include .depend
diff --git a/perl_checker.src/common.ml b/perl_checker.src/common.ml
new file mode 100644
index 0000000..4b33f8f
--- /dev/null
+++ b/perl_checker.src/common.ml
@@ -0,0 +1,798 @@
+open Stack
+open List
+
+exception Found
+exception Not_comparable
+exception GraphSort_circular_deps
+
+type ('a, 'b) either = Left of 'a | Right of 'b
+type ('a, 'b) or_option = Or_some of 'a | Or_error of 'b
+
+let bpos = "",-1,-1
+
+let norm (a,b) = if a = -1 then b else a
+let unipos (s,a,b) (s2,c,d) = 
+  if (a,b) = (-1,-1) then s2,c,d else
+  if (c,d) = (-1,-1) then s,a,b else
+  if s <> s2 then bpos else s, min (norm(a,c)) (norm(c,a)), max (norm(b,d)) (norm(d,b))
+
+let uniposl l = match l with
+  | [] -> bpos
+  | e::l -> fold_left unipos e l
+
+(**********************************************************************************)
+
+let internal_error s = failwith ("internal error: " ^ s)
+
+let id x = x
+let double a = a,a
+let swap (x,y) = (y,x)
+let safe_tl l = try tl l with _ -> []
+
+let o f g x = f (g x)
+let curry f x y = f (x,y)
+let uncurry f (x, y) = f x y
+
+let is_int n = ceil n = n
+
+let uncons = function
+  | [] -> failwith "uncons"
+  | e::l -> e,l
+
+let has_env var = 
+  try 
+    let _ = Sys.getenv var in true
+  with Not_found -> false
+
+let some = function Some e -> e | None -> failwith "some"
+
+let some_or = function
+  | None -> id
+  | Some e -> fun _ -> e
+
+let option2l = function
+  | None -> []
+  | Some e -> [e]
+
+let prefer_some f a b =
+  match a, b with
+  | Some a, Some b -> Some (f a b)
+  | None, _ -> b
+  | _, None -> a
+
+let rec collect_accu f accu = function
+  | [] -> accu
+  | e::l -> collect_accu f (rev_append (f e) accu) l
+
+let collect f l = rev (collect_accu f [] l)
+
+let merge_some merge a b = 
+  match a,b with
+  | None, None -> None
+  | _, None -> a
+  | None, _ -> b
+  | Some(a), Some(b) -> Some(merge a b)
+
+let rec uniq = function
+  | [] -> []
+  | e::l -> if mem e l then uniq l else e :: uniq l
+
+let rec uniq_ eq = function
+  | [] -> []
+  | e::l -> 
+      try 
+	let _ = find (eq e) l in
+	uniq_ eq l
+      with Not_found -> e :: uniq_ eq l
+
+let rec non_uniq = function
+  | [] -> []
+  | e::l -> if mem e l then e :: non_uniq l else non_uniq l
+
+let rec member_ eq e = function
+  | [] -> false
+  | e'::l -> if eq e e' then true else member_ eq e l
+
+let rec find_some p = function
+  | [] -> raise Not_found
+  | x :: l -> 
+      match p x with
+      |	Some v -> v
+      |	None -> find_some p l
+
+let fold_left1 f = function
+  | [] -> failwith "fold_left1"
+  | e :: l -> fold_left f e l
+
+let find_index e l =
+  let rec find_index_ i = function
+    | [] -> raise Not_found
+    | e'::l -> if e=e' then i else find_index_ (i+1) l
+  in
+  find_index_ 0 l
+
+let rec find_some_ p = function
+  | [] -> None
+  | x :: l -> 
+      match p x with
+      |	Some v -> Some v
+      |	None -> find_some_ p l
+
+let rec fpartition p l =
+  let rec part yes no = function
+  | [] -> (rev yes, rev no)
+  | x :: l -> 
+      (match p x with
+      |	None -> part yes (x :: no) l
+      |	Some v -> part (v :: yes) no l) in
+  part [] [] l
+
+let partition_either f l =
+  let rec part_either left right = function
+  | [] -> (rev left, rev right)
+  | x :: l -> 
+      (match f x with
+      |	Left  e -> part_either (e :: left) right l
+      |	Right e -> part_either left (e :: right) l) in
+  part_either [] [] l
+
+let rec keep_best f = 
+  let rec partition e = function
+    | [] -> e, []
+    | e' :: l ->
+	match f(e,e') with
+	| None -> let (e'', l') = partition e l in e'', e' :: l'
+	| Some e'' -> partition e'' l
+  in function
+  | [] -> []
+  | e::l -> 
+      let (e', l') = partition e l in
+      e' :: keep_best f l'
+
+let rec keep_bests f l = 
+  let rec once e unchanged = function
+    | [] -> None
+    | e' :: l ->
+	match f(e,e') with
+	| None -> once e (e' :: unchanged) l
+	| Some e'' -> Some(e'', unchanged @ l)
+  in
+  let rec as_many_as_possible e l =
+    match once e [] l with
+    | None -> None
+    | Some(e', l') -> Some(some_or (as_many_as_possible e' l') (e', l'))
+  in
+  let rec try_with e l_done l_next =
+    match as_many_as_possible e l_next with
+    | None -> try_with_next (e :: l_done) l_next
+    | Some(e2, l_next2) -> 
+	match as_many_as_possible e2 l_done with
+	| None -> try_with_next (e2 :: l_done) l_next2
+	| Some(e3, l_done2) -> try_with e3 l_done2 l_next2
+  and try_with_next l_done = function
+    | [] -> rev l_done
+    | e::l_next -> try_with e l_done l_next
+  in
+  try_with_next [] l
+
+let rec fold_right1 f = function
+  | [] -> failwith "fold_right1"
+  | [e] -> e
+  | e::l -> f e (fold_right1 f l)
+
+let rec for_all2_ p l1 l2 =
+  match (l1, l2) with
+    ([], []) -> true
+  | (a1::l1, a2::l2) -> p a1 a2 && for_all2_ p l1 l2
+  | (_, _) -> false
+
+let maxl l = fold_right1 max l
+  
+let rec stack2list s =
+  let l = ref [] in
+  Stack.iter (fun e -> l := e :: !l) s ;
+  !l
+
+let rec fix_point f p =
+  let p' = f p in
+  if p = p' then p else fix_point f p'
+
+let rec fix_point_withenv f env p =
+  let p', env' = f env p in
+  if p = p' then (p, env') else fix_point_withenv f env' p'
+
+let rec fix_point_ nb f p =
+  let p' = f p in
+  if p = p' then p, nb else fix_point_ (nb+1) f p'
+
+(*
+let rec lfix_point f e =
+  let e' = f(e) in
+  if e = e' then e :: lfix_point f e' else [e]
+*)
+
+let do0_withenv doit f env l =
+  let r_env = ref env in
+  doit (fun e -> r_env := f !r_env e) l ;
+  !r_env
+
+let do0_withenv2 doit f env l =
+  let r_env = ref env in
+  doit (fun e e' -> r_env := f !r_env e e') l ;
+  !r_env
+
+let do_withenv doit f env l =
+  let r_env = ref env in
+  let l' = doit (fun e -> 
+    let e', env' = f !r_env e in
+    r_env := env' ; e'
+  ) l in
+  l', !r_env
+
+let do2_withenv doit f env l1 l2 =
+  let r_env = ref env in
+  let l' = doit (fun e1 e2 -> 
+    let e', env' = f !r_env e1 e2 in
+    r_env := env' ; e'
+  ) l1 l2 in
+  l', !r_env
+
+let do_collect doit f l1 =
+  let l = ref [] in
+  doit (fun i t -> l := f i t @ !l) l1 ;
+  !l
+
+let map_withitself f l =
+  let rec map_withitself_ done_ = function
+    | [] -> done_
+    | e :: l -> 
+	let e' = f (done_ @ e :: l) e in
+	map_withitself_ (done_ @ [ e' ]) l
+  in map_withitself_ [] l
+
+let map_t2 f (x,y) = f x, f y
+let map_t3 f (x,y,z) = f x, f y, f z
+let map_option f = function
+  | Some e -> Some (f e)
+  | None -> None
+let map_optionoption f = function
+  | Some e -> f e
+  | None -> None
+let t2_option2option_t2 = function
+  | (Some x, Some y) -> Some(x,y)
+  | _ -> None
+let rec l_option2option_l = function
+  | [] -> Some []
+  | None :: _l -> None
+  | Some e :: l -> map_option (fun l -> e :: l) (l_option2option_l l)
+let map_option_env f (e, env) = map_option f e, env
+
+let if_some bool val_ = if bool then Some val_ else None
+
+let rec fold_left_option f val_ = function
+  | [] -> Some val_
+  | e::l ->
+      match f val_ e with
+      |	None -> None
+      |	Some val_' -> fold_left_option f val_' l
+
+let collect_some_withenv f env l = 
+  let rec collect accu env = function
+    | [] -> rev accu, env
+    | e::l -> 
+	let e', env' = f env e in
+	let accu' = 
+	  match e' with 
+	  | Some e' -> e'::accu 
+	  | None -> accu in
+	collect accu' env' l
+  in collect [] env l
+	  
+let for_all_option_withenv remap f env l =
+  let rec for_all env accu = function
+    | [] -> Some(remap (rev accu)), env
+    | e::l ->
+	(match f env e with
+	| None, env' -> None, env'
+	| Some e', env' -> for_all env' (e' :: accu) l)
+  in
+  for_all env [] l
+
+let for_all2_option_withenv remap f env la lb =
+  let rec for_all env accu = function
+    | [], [] -> Some(remap (rev accu)), env
+    | a::la, b::lb ->
+	(match f env a b with
+	| None, env' -> None, env'
+	| Some ab, env' -> for_all env' (ab :: accu) (la, lb))
+    | _ -> None, env
+  in
+  for_all env [] (la, lb)
+
+let map_or_option f = function
+  | Or_some e -> Or_some (f e)
+  | Or_error err -> Or_error err
+
+let map_index f l =
+  let rec map_ n = function
+    | [] -> []
+    | e::l -> f e n :: map_ (n+1) l
+  in map_ 0 l
+
+let filter_index f l =
+  let rec filter_ n = function
+    | [] -> []
+    | e::l -> 
+	let l' = filter_ (n+1) l in
+	if f e n then e :: l' else l'
+  in filter_ 0 l
+
+let iter_index f l =
+  let rec iter_ n = function
+    | [] -> ()
+    | e::l -> f e n ; iter_ (n+1) l
+  in iter_ 0 l
+
+let map_fst f (x, y) = f x, y
+let map_snd f (x, y) = x, f y
+
+let map_withenv      f env e = do_withenv map f env e
+let find_withenv     f env e = do_withenv find f env e
+let filter_withenv   f env e = do_withenv filter f env e
+let exists_withenv   f env e = do_withenv exists f env e
+let map_t2_withenv   f env e = do_withenv map_t2 f env e
+let for_all_withenv  f env e = do_withenv for_all f env e
+let collect_withenv  f env e = do_withenv collect f env e
+let partition_either_withenv f env e = do_withenv partition_either f env e
+
+let map2_withenv     f env l1 l2 = do2_withenv map2 f env l1 l2
+let for_all2_withenv f env l1 l2 = do2_withenv for_all2 f env l1 l2
+
+let rec take n l =
+  if n = 0 then []
+  else match l with
+  | [] -> raise Not_found
+  | e::l -> e :: take (n-1) l
+let last_n n l = rev (take n (rev l))
+let last l = hd (last_n 1 l)
+
+let rec skipfirst e = function
+  | [] -> []
+  | e'::l when e = e' -> skipfirst e l
+  | l -> l
+
+let rec removelast = function
+  | [] -> failwith "removelast"
+  | [_] -> []
+  | e::l -> e :: removelast l
+
+let rec split_last l = 
+  let rec spl accu = function
+  | [] -> failwith "split_last"
+  | [e] -> rev accu, e
+  | e::l -> spl (e :: accu) l
+  in spl [] l
+
+let iter_assoc_val f l = iter (fun (_,v) -> f v) l
+let map_assoc_val f l = map (fun (k,v) -> k, f v) l
+
+let assoc_or_fail e l =
+  try assoc e l with Not_found -> failwith "assoc failed"
+
+let assoc_has_key e l =
+  try let _ = assoc e l in true with Not_found -> false  
+
+let assoc_by is_same e l = 
+  find_some (fun (a,b) -> if is_same e a then Some b else None) l
+
+let rec update_assoc_by is_same f e = function
+  | [] -> raise Not_found
+  | (a,b) :: l when is_same e a -> (a, f b) :: l
+  | (a,b) :: l -> (a,b) :: update_assoc_by is_same f e l
+
+let update_assoc f e = update_assoc_by (=) f e
+
+let rec update_assoc_by_with_default default is_same f e = function
+  | [] -> [ e, f default ]
+  | (a,b) :: l when is_same e a -> (a, f b) :: l
+  | (a,b) :: l -> (a,b) :: update_assoc_by_with_default default is_same f e l
+
+let update_all_assoc_by is_same f e l =
+  map (fun (a,b) -> a, if is_same e a then f b else b) l
+
+let rec rassoc e = function
+  | [] -> raise Not_found
+  | (k,v) :: l -> if e = v then k else rassoc e l
+
+let rec all_assoc e = function
+  | [] -> []
+  | (e',v) :: l when e=e' -> v :: all_assoc e l
+  | _ :: l -> all_assoc e l
+
+let rec all_assoc_by is_same e = function
+  | [] -> []
+  | (e',v) :: l when is_same e e' -> v :: all_assoc_by is_same e l
+  | _ :: l -> all_assoc_by is_same e l
+
+let prepare_want_all_assoc l =
+  map (fun n -> n, uniq (all_assoc n l)) (uniq (map fst l))
+
+let prepare_want_all_assoc_by is_same l =
+  map (fun n -> n, uniq_ is_same (all_assoc_by is_same n l)) (uniq_ is_same (map fst l))
+
+let prepare_want_all_assoc_by_ is_same_a is_same_b l =
+  map (fun n -> n, uniq_ is_same_b (all_assoc_by is_same_a n l)) (uniq_ is_same_a (map fst l))
+
+let rec count_uniq = function
+  | [] -> []
+  | e::l -> 
+      let has, l' = partition ((=) e) l in
+      (e, length has + 1) :: count_uniq l'
+
+let rec repeat e = function
+  | 0 -> []
+  | n -> e :: repeat e (n-1)
+
+let rec inits = function
+  | [] -> [[]]
+  | e::l -> [] :: map (fun l -> e::l) (inits l)
+let rec tails = function
+  | [] -> [[]]
+  | (_::xs) as xxs -> xxs :: tails xs
+
+let apply f x = f x;;
+
+let rec map3 f l1 l2 l3 =
+  match (l1, l2, l3) with
+    ([], [], []) -> []
+  | (a1::l1, a2::l2, a3::l3) -> let r = f a1 a2 a3 in r :: map3 f l1 l2 l3
+  | (_, _, _) -> invalid_arg "map3"
+
+let filter2 f l1 l2 =
+  split (filter f (combine l1 l2))
+
+let break_at f l =
+  let rec b l1 = function
+  | [] -> l1, []
+  | e::l2 -> if f e then (l1, e :: l2) else b (l1 @ [e]) l2
+  in b [] l
+let break v l = break_at ((=) v) l
+
+(* break_at_indice 0 [1;2] gives [], [1;2]
+   break_at_indice 1 [1;2] gives [1], [2]
+ *)
+let rec break_at_indice i l =
+  if i = 0 then [], l else
+   match l with
+   | [] -> raise Not_found
+   | e::l2 ->
+     let a, b = break_at_indice (i-1) l2 in
+     e::a, b
+
+let rev_nth e l =
+  let rec rev_nth' i = function
+  | [] -> raise Not_found
+  | e'::_ when e'=e -> i
+  | _::l -> rev_nth' (i+1) l
+  in  rev_nth' 0 l
+
+let rec getset_nth l i f =
+  match l, i with
+  | e::l', 0 -> f e :: l'
+  | [], _ -> failwith "getset_nth"
+  | e::l', _ -> e :: getset_nth l' (i - 1) f
+
+let set_nth l i v = getset_nth l i (fun _ -> v)
+    
+let adjustModDown m n = n - (n mod m)
+let adjustModUp m n = adjustModDown m (n + m - 1)
+
+
+let hashtbl_set h k v =
+  Hashtbl.remove h k;
+  Hashtbl.add h k v
+
+let hashtbl_find f h =
+  let r = ref None in
+  Hashtbl.iter (fun v c -> if f v c then r := Some v) h ;
+  match !r with
+  | Some v -> v
+  | None -> raise Not_found
+
+let hashtbl_filter f h =
+  Hashtbl.iter (fun v c -> hashtbl_set h v (f v c)) h
+
+let array_shift a = Array.sub a 1 (Array.length a - 1)
+let array_last_n n a = 
+  let len = Array.length a in
+  Array.sub a (len - n) n
+
+let array_collect f a = Array.fold_left (fun l e -> f e @ l) [] a
+
+let rec lvector_product = 
+  let rec vector_product a b = match a with
+  | [] -> []
+  | e::l -> map (fun e' -> e :: e') b :: vector_product l b
+  in function
+  | [] -> []
+  | [e] -> map (fun e -> [e]) e
+  | e::l -> flatten (vector_product e (lvector_product l))
+
+let vector_product2 a b =
+  map (function
+  | [a;b] -> a,b
+  | _ -> failwith "vector_product2"
+  ) (lvector_product [ a ; b ])
+
+let rec transpose = function
+  | [] :: _ -> []
+  | ll -> 
+      let l, ll' = split (map (function e::l -> e,l | _ -> raise Not_found) ll) in
+      l :: transpose ll'
+
+let rec range min max =
+  if min >= max then [] else min :: range (min + 1) max
+
+let rec filter_some_with f = function
+  | [] -> []
+  | e :: l -> 
+      match f e with
+      |	None -> filter_some_with f l
+      | Some e' -> e' :: filter_some_with f l
+
+let rec filter_some = function
+  | [] -> []
+  | None :: l -> filter_some l
+  | Some e :: l -> e :: filter_some l
+
+let rec difference l = function
+  | [] -> l
+  | e::l' -> difference (filter ((<>) e) l) l'
+
+let rec difference_ eq l = function
+  | [] -> l
+  | e::l' -> 
+      let l2 = filter (fun e' -> not (eq e e')) l in
+      difference_ eq l2 l'
+
+let intersection_by is_same l1 l2 = filter (fun e -> exists (is_same e) l2) l1
+
+let intersection_and_differences eq l1 l2 =
+  let rec both inter l2_only = function
+    | [], l2 -> inter, [], rev l2_only @ l2
+    | l1, [] -> inter, l1, rev l2_only
+    | l1, e2 :: l2' ->
+	match partition (eq e2) l1 with
+	| [], _ -> both inter (e2 :: l2_only) (l1, l2')
+	| _, l1' -> both (e2 :: inter) l2_only (l1', l2')
+  in both [] [] (l1, l2)
+
+let rec triangularize = function
+  | [] -> []
+  | e::l -> (e,l) :: triangularize l
+
+let diagonalize l =
+  map_index (fun a i ->
+    a, filter_index (fun _ j -> i <> j) l
+  ) l
+
+let rec list_of_nonempty_sublists = function
+  | [] -> []
+  | e :: l -> 
+      let l' = list_of_nonempty_sublists l in
+      [e] :: l' @ map (fun l -> e :: l) l'
+
+let rec graph_is_sorted_by eq = function
+  | [] -> true
+  | (_,deps) :: l -> 
+      for_all (fun e -> try let _ = assoc_by eq e l in false with Not_found -> true) deps && graph_is_sorted_by eq l
+
+let graph_closure_by eq graph =
+  let err = ref None in
+  try
+    let graph_rev = collect (fun (i, l) -> map (fun e -> (e, i)) l) graph in
+    let bothway = map (fun (i,l) -> i, (l, all_assoc_by eq i graph_rev)) graph in
+    let closed = fold_left (fun graph j ->
+        let next, prev = assoc_by eq j graph in
+        let graph2 = fold_left (fun graph i ->
+        if member_ eq i next then (err := Some(j,i); raise GraphSort_circular_deps) else
+        update_assoc_by eq (fun (i_next,i_prev) -> i_next @ next, i_prev) i graph
+      ) graph (filter (fun a -> not (eq a j)) prev) in
+      let graph3 = fold_left (fun graph k ->
+        if member_ eq k prev then (err := Some(j,k); raise GraphSort_circular_deps) else
+        update_assoc_by eq (fun (k_next,k_prev) -> k_next, k_prev @ prev) k graph
+      ) graph2 (filter (fun a -> not (eq a j)) next) in
+      graph3
+    ) bothway (map fst bothway) in
+    Or_some (map (fun (e,(next,_)) -> e, uniq_ eq next) closed)
+  with GraphSort_circular_deps ->
+    Or_error (some !err)
+
+let rec graph_sort_by eq l =
+  let cmp (_, deps_a) (b, _) = if member_ eq b deps_a then 1 else -1 in 
+  let rec sort_it = function
+    | [] -> []
+    | [e] -> [e]
+    | e::l ->
+	let l' = sort_it l in
+	let gt, lt = break_at (fun ((_, deps) as e') -> deps = [] or cmp e e' = 1) l' in
+	gt @ [e] @ lt
+  in 
+  map_or_option (fun l' ->
+    let l_sorted = rev (sort_it l') in
+    if not (graph_is_sorted_by eq l_sorted) then internal_error "graph_sort failed" else
+    l_sorted
+  ) (graph_closure_by eq l)
+
+let int_sort l = sort (fun a b -> a - b) l
+
+let str_begins_with s prefix =
+  String.sub s 0 (min (String.length s) (String.length prefix)) = prefix
+
+let rec str_contains s1 s2 =
+  match s1 with
+  | "" -> false
+  | _ -> 
+      if str_begins_with s1 s2 then true
+      else str_contains (String.sub s1 1 (String.length s1 - 1)) s2
+
+let str_ends_with s suffix =
+  let len = min (String.length s) (String.length suffix) in
+  String.sub s (String.length s - len) len = suffix
+
+let chop = function
+  | "" -> ""
+  | s -> String.sub s 0 (String.length s - 1)
+
+let chomps s =
+  let i = ref (String.length s - 1) in
+  while !i >= 0 && (s.[!i] = ' ' || s.[!i] = '\t') do decr i done ;
+  String.sub s 0 (!i+1)
+
+let skip_n_char_ beg end_ s =
+  String.sub s beg (String.length s - beg - end_)
+let skip_n_char n s = skip_n_char_ n 0 s
+
+let rec explode_string = function
+  | "" -> []
+  | s -> (String.get s 0) :: explode_string (String.sub s 1 (String.length s - 1))
+
+let is_uppercase c = Char.lowercase c <> c
+let is_lowercase c = Char.uppercase c <> c
+
+let starts_with_non_lowercase s = s <> "" && s.[0] <> '_' && not (is_lowercase s.[0])
+
+let get_package_name s = 
+  try Some (String.sub s 0 (String.rindex s ':' - 1)) with Not_found -> None
+
+let split_at_two_colons s =
+  let i_fq = String.rindex s ':' in
+  String.sub s 0 (i_fq - 1), skip_n_char (i_fq + 1) s
+
+let to_CamelCase s_ =
+  let l = ref [] in
+  let s = String.copy s_ in
+  for i = 1 to String.length s - 1 do 
+      if is_uppercase (String.unsafe_get s i) && is_lowercase (String.unsafe_get s (i-1)) then (
+	String.set s i (Char.lowercase (String.get s i)) ;
+        l := i :: !l
+      )
+  done ;
+  if !l = [] then None else
+  let offset, s' = fold_left (fun (offset, s') i -> 
+    i, s' ^ String.sub s offset (i-offset) ^ "_"
+  ) (0, "") (rev !l) in
+  Some (s' ^ String.sub s offset (String.length s - offset))
+
+let (string_of_ref : 'a ref -> string) = fun r ->
+  Printf.sprintf "0x%x" (Obj.magic r : int)
+
+let is_int n = n = floor n
+
+(* total order *)
+let rec compare_lists cmp l1 l2 =
+  match l1, l2 with
+  | [], [] -> 0
+  | [], _ -> -1
+  | _, [] -> 1
+  | e1::l1, e2::l2 ->
+      match cmp e1 e2 with
+      |	0 -> compare_lists cmp l1 l2
+      |	v -> v
+
+let compare_best a b =
+  match a, b with
+  |  0,  0 -> 0
+  |  1,  1 |  1, 0 | 0,  1 ->  1
+  | -1, -1 | -1, 0 | 0, -1 -> -1
+  |  1, -1 | -1, 1 -> raise Not_comparable
+  | _ -> failwith "uh?"
+
+(* partial order *)
+let combine_comparison_list l =
+  fold_left compare_best 0 l
+
+let min_with_cmp less_than a b =
+  if less_than a b then a
+  else if less_than b a then b
+  else raise Not_comparable
+
+let max_with_cmp less_than a b =
+  if less_than a b then b
+  else if less_than b a then a
+  else raise Not_comparable
+
+let rec fold_left2_compare f e l1 l2 =
+  match l1, l2 with
+  | [], [] -> e
+  | e1::l1, e2::l2 -> fold_left2_compare f (f e e1 e2) l1 l2
+  | _ -> raise Not_comparable
+
+let rec exists_compare cmp = function
+  | [] -> raise Not_comparable
+  | e :: l -> try cmp e with Not_comparable -> exists_compare cmp l
+
+let forall_compare cmp = fold_left (fun n e -> compare_best n (cmp e)) 0
+let forall2_compare cmp = fold_left2_compare (fun n e1 e2 -> compare_best n (cmp e1 e2)) 0
+
+let exists2_compare left_dropping cmp l1 l2 =
+  let rec forall_compare_ n = function
+    | [], [] -> n
+    | _, [] -> compare_best n left_dropping
+    | [], _ -> compare_best n (-left_dropping)
+    | e1::l1, e2::l2 ->
+	match try Some (cmp e1 e2) with Not_comparable -> None with
+	| Some n' -> forall_compare_ (compare_best n n') (l1, l2)
+	| None ->
+	    if n = left_dropping then
+	      forall_compare_ left_dropping (l1, e2::l2)
+	    else if n = -left_dropping then
+	      forall_compare_ (-left_dropping) (e1::l1, l2)
+	    else
+	      (* need to try both *)
+	      try forall_compare_ left_dropping (l1, e2::l2)
+	      with Not_comparable -> forall_compare_ (-left_dropping) (e1::l1, l2)
+  in forall_compare_ 0 (l1, l2)
+
+
+let rec compare_sorted_sets is_same l1 l2 =
+  match l1, l2 with
+  | [], [] -> 0
+  | [], _ -> -1
+  | _, [] -> 1
+  | e1::l1, e2::l2 -> if is_same e1 e2 then compare_sorted_sets is_same l1 l2 else raise Not_found
+
+let scan_list_while_modifying f l =
+  let rec scan_list_while_modifying_ prev = function
+    | [] -> prev
+    | e :: next -> 
+	let prev', next' = some_or (f prev next e) (prev @ [e], next) in
+	scan_list_while_modifying_ prev' next'
+  in scan_list_while_modifying_ [] l
+
+let bools2compare = function
+  | true, true -> 0
+  | true, false -> -1
+  | false, true -> 1
+  | _ -> raise Not_comparable
+
+let lpush l e = l := e :: !l
+
+(*
+let is_greater2compare is_greater a b =
+  match is_greater a b, is_greater b a with
+
+  *)
+
+module OrderedString =
+  struct
+    type t = string
+    let compare = compare
+  end;;
+
+module StringSet = Set.Make(OrderedString);;
+
+let stringSet_to_list = StringSet.elements
+let stringSet_add set e = StringSet.add e set
+let stringSet_difference = StringSet.diff
+let list_to_StringSet l = fold_left stringSet_add StringSet.empty l
diff --git a/perl_checker.src/common.mli b/perl_checker.src/common.mli
new file mode 100644
index 0000000..5fe8ade
--- /dev/null
+++ b/perl_checker.src/common.mli
@@ -0,0 +1,236 @@
+exception Found
+exception Not_comparable
+exception GraphSort_circular_deps
+type ('a, 'b) either = Left of 'a | Right of 'b
+and ('a, 'b) or_option = Or_some of 'a | Or_error of 'b
+val bpos : string * int * int
+val norm : int * int -> int
+val unipos : string * int * int -> string * int * int -> string * int * int
+val uniposl : (string * int * int) list -> string * int * int
+val internal_error : string -> 'a
+val id : 'a -> 'a
+val double : 'a -> 'a * 'a
+val swap : 'a * 'b -> 'b * 'a
+val safe_tl : 'a list -> 'a list
+val o : ('a -> 'b) -> ('c -> 'a) -> 'c -> 'b
+val curry : ('a * 'b -> 'c) -> 'a -> 'b -> 'c
+val uncurry : ('a -> 'b -> 'c) -> 'a * 'b -> 'c
+val is_int : float -> bool
+val uncons : 'a list -> 'a * 'a list
+val has_env : string -> bool
+val some : 'a option -> 'a
+val some_or : 'a option -> 'a -> 'a
+val option2l : 'a option -> 'a list
+val prefer_some : ('a -> 'a -> 'a) -> 'a option -> 'a option -> 'a option
+val collect_accu : ('a -> 'b list) -> 'b list -> 'a list -> 'b list
+val collect : ('a -> 'b list) -> 'a list -> 'b list
+val merge_some : ('a -> 'a -> 'a) -> 'a option -> 'a option -> 'a option
+val uniq : 'a list -> 'a list
+val uniq_ : ('a -> 'a -> bool) -> 'a list -> 'a list
+val non_uniq : 'a list -> 'a list
+val member_ : ('a -> 'b -> bool) -> 'a -> 'b list -> bool
+val find_some : ('a -> 'b option) -> 'a list -> 'b
+val fold_left1 : ('a -> 'a -> 'a) -> 'a list -> 'a
+val find_index : 'a -> 'a list -> int
+val find_some_ : ('a -> 'b option) -> 'a list -> 'b option
+val fpartition : ('a -> 'b option) -> 'a list -> 'b list * 'a list
+val partition_either :
+  ('a -> ('b, 'c) either) -> 'a list -> 'b list * 'c list
+val keep_best : ('a * 'a -> 'a option) -> 'a list -> 'a list
+val keep_bests : ('a * 'a -> 'a option) -> 'a list -> 'a list
+val fold_right1 : ('a -> 'a -> 'a) -> 'a list -> 'a
+val for_all2_ : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool
+val maxl : 'a list -> 'a
+val stack2list : 'a Stack.t -> 'a list
+val fix_point : ('a -> 'a) -> 'a -> 'a
+val fix_point_withenv : ('a -> 'b -> 'b * 'a) -> 'a -> 'b -> 'b * 'a
+val fix_point_ : int -> ('a -> 'a) -> 'a -> 'a * int
+val do0_withenv :
+  (('a -> unit) -> 'b -> 'c) -> ('d -> 'a -> 'd) -> 'd -> 'b -> 'd
+val do0_withenv2 :
+  (('a -> 'b -> unit) -> 'c -> 'd) ->
+  ('e -> 'a -> 'b -> 'e) -> 'e -> 'c -> 'e
+val do_withenv :
+  (('a -> 'b) -> 'c -> 'd) -> ('e -> 'a -> 'b * 'e) -> 'e -> 'c -> 'd * 'e
+val do2_withenv :
+  (('a -> 'b -> 'c) -> 'd -> 'e -> 'f) ->
+  ('g -> 'a -> 'b -> 'c * 'g) -> 'g -> 'd -> 'e -> 'f * 'g
+val do_collect :
+  (('a -> 'b -> unit) -> 'c -> 'd) -> ('a -> 'b -> 'e list) -> 'c -> 'e list
+val map_withitself : ('a list -> 'a -> 'a) -> 'a list -> 'a list
+val map_t2 : ('a -> 'b) -> 'a * 'a -> 'b * 'b
+val map_t3 : ('a -> 'b) -> 'a * 'a * 'a -> 'b * 'b * 'b
+val map_option : ('a -> 'b) -> 'a option -> 'b option
+val map_optionoption : ('a -> 'b option) -> 'a option -> 'b option
+val t2_option2option_t2 : 'a option * 'b option -> ('a * 'b) option
+val l_option2option_l : 'a option list -> 'a list option
+val map_option_env : ('a -> 'b) -> 'a option * 'c -> 'b option * 'c
+val if_some : bool -> 'a -> 'a option
+val fold_left_option : ('a -> 'b -> 'a option) -> 'a -> 'b list -> 'a option
+val collect_some_withenv :
+  ('a -> 'b -> 'c option * 'a) -> 'a -> 'b list -> 'c list * 'a
+val for_all_option_withenv :
+  ('a list -> 'b) ->
+  ('c -> 'd -> 'a option * 'c) -> 'c -> 'd list -> 'b option * 'c
+val for_all2_option_withenv :
+  ('a list -> 'b) ->
+  ('c -> 'd -> 'e -> 'a option * 'c) ->
+  'c -> 'd list -> 'e list -> 'b option * 'c
+val map_or_option : ('a -> 'b) -> ('a, 'c) or_option -> ('b, 'c) or_option
+val map_index : ('a -> int -> 'b) -> 'a list -> 'b list
+val filter_index : ('a -> int -> bool) -> 'a list -> 'a list
+val iter_index : ('a -> int -> 'b) -> 'a list -> unit
+val map_fst : ('a -> 'b) -> 'a * 'c -> 'b * 'c
+val map_snd : ('a -> 'b) -> 'c * 'a -> 'c * 'b
+val map_withenv : ('a -> 'b -> 'c * 'a) -> 'a -> 'b list -> 'c list * 'a
+val find_withenv : ('a -> 'b -> bool * 'a) -> 'a -> 'b list -> 'b * 'a
+val filter_withenv : ('a -> 'b -> bool * 'a) -> 'a -> 'b list -> 'b list * 'a
+val exists_withenv : ('a -> 'b -> bool * 'a) -> 'a -> 'b list -> bool * 'a
+val map_t2_withenv : ('a -> 'b -> 'c * 'a) -> 'a -> 'b * 'b -> ('c * 'c) * 'a
+val for_all_withenv : ('a -> 'b -> bool * 'a) -> 'a -> 'b list -> bool * 'a
+val collect_withenv :
+  ('a -> 'b -> 'c list * 'a) -> 'a -> 'b list -> 'c list * 'a
+val partition_either_withenv :
+  ('a -> 'b -> ('c, 'd) either * 'a) ->
+  'a -> 'b list -> ('c list * 'd list) * 'a
+val map2_withenv :
+  ('a -> 'b -> 'c -> 'd * 'a) -> 'a -> 'b list -> 'c list -> 'd list * 'a
+val for_all2_withenv :
+  ('a -> 'b -> 'c -> bool * 'a) -> 'a -> 'b list -> 'c list -> bool * 'a
+val take : int -> 'a list -> 'a list
+val last_n : int -> 'a list -> 'a list
+val last : 'a list -> 'a
+val skipfirst : 'a -> 'a list -> 'a list
+val removelast : 'a list -> 'a list
+val split_last : 'a list -> 'a list * 'a
+val iter_assoc_val : ('a -> unit) -> ('b * 'a) list -> unit
+val map_assoc_val : ('a -> 'b) -> ('c * 'a) list -> ('c * 'b) list
+val assoc_or_fail : 'a -> ('a * 'b) list -> 'b
+val assoc_has_key : 'a -> ('a * 'b) list -> bool
+val assoc_by : ('a -> 'b -> bool) -> 'a -> ('b * 'c) list -> 'c
+val update_assoc_by :
+  ('a -> 'b -> bool) -> ('c -> 'c) -> 'a -> ('b * 'c) list -> ('b * 'c) list
+val update_assoc : ('a -> 'a) -> 'b -> ('b * 'a) list -> ('b * 'a) list
+val update_assoc_by_with_default :
+  'a ->
+  ('b -> 'b -> bool) -> ('a -> 'a) -> 'b -> ('b * 'a) list -> ('b * 'a) list
+val update_all_assoc_by :
+  ('a -> 'b -> bool) -> ('c -> 'c) -> 'a -> ('b * 'c) list -> ('b * 'c) list
+val rassoc : 'a -> ('b * 'a) list -> 'b
+val all_assoc : 'a -> ('a * 'b) list -> 'b list
+val all_assoc_by : ('a -> 'b -> bool) -> 'a -> ('b * 'c) list -> 'c list
+val prepare_want_all_assoc : ('a * 'b) list -> ('a * 'b list) list
+val prepare_want_all_assoc_by :
+  ('a -> 'a -> bool) -> ('a * 'a) list -> ('a * 'a list) list
+val prepare_want_all_assoc_by_ :
+  ('a -> 'a -> bool) ->
+  ('b -> 'b -> bool) -> ('a * 'b) list -> ('a * 'b list) list
+val count_uniq : 'a list -> ('a * int) list
+val repeat : 'a -> int -> 'a list
+val inits : 'a list -> 'a list list
+val tails : 'a list -> 'a list list
+val apply : ('a -> 'b) -> 'a -> 'b
+val map3 : ('a -> 'b -> 'c -> 'd) -> 'a list -> 'b list -> 'c list -> 'd list
+val filter2 : ('a * 'b -> bool) -> 'a list -> 'b list -> 'a list * 'b list
+val break_at : ('a -> bool) -> 'a list -> 'a list * 'a list
+val break : 'a -> 'a list -> 'a list * 'a list
+val break_at_indice : int -> 'a list -> 'a list * 'a list
+val rev_nth : 'a -> 'a list -> int
+val getset_nth : 'a list -> int -> ('a -> 'a) -> 'a list
+val set_nth : 'a list -> int -> 'a -> 'a list
+val adjustModDown : int -> int -> int
+val adjustModUp : int -> int -> int
+val hashtbl_set : ('a, 'b) Hashtbl.t -> 'a -> 'b -> unit
+val hashtbl_find : ('a -> 'b -> bool) -> ('a, 'b) Hashtbl.t -> 'a
+val hashtbl_filter : ('a -> 'b -> 'b) -> ('a, 'b) Hashtbl.t -> unit
+val array_shift : 'a array -> 'a array
+val array_last_n : int -> 'a array -> 'a array
+val array_collect : ('a -> 'b list) -> 'a array -> 'b list
+val lvector_product : 'a list list -> 'a list list
+val vector_product2 : 'a list -> 'a list -> ('a * 'a) list
+val transpose : 'a list list -> 'a list list
+val range : int -> int -> int list
+val filter_some_with : ('a -> 'b option) -> 'a list -> 'b list
+val filter_some : 'a option list -> 'a list
+val difference : 'a list -> 'a list -> 'a list
+val difference_ : ('a -> 'b -> bool) -> 'b list -> 'a list -> 'b list
+val intersection_by : ('a -> 'b -> bool) -> 'a list -> 'b list -> 'a list
+val intersection_and_differences :
+  ('a -> 'b -> bool) -> 'b list -> 'a list -> 'a list * 'b list * 'a list
+val triangularize : 'a list -> ('a * 'a list) list
+val diagonalize : 'a list -> ('a * 'a list) list
+val list_of_nonempty_sublists : 'a list -> 'a list list
+val graph_is_sorted_by : ('a -> 'b -> bool) -> ('b * 'a list) list -> bool
+val graph_closure_by :
+  ('a -> 'a -> bool) ->
+  ('a * 'a list) list -> (('a * 'a list) list, 'a * 'a) or_option
+val graph_sort_by :
+  ('a -> 'a -> bool) ->
+  ('a * 'a list) list -> (('a * 'a list) list, 'a * 'a) or_option
+val int_sort : int list -> int list
+val str_begins_with : string -> string -> bool
+val str_contains : string -> string -> bool
+val str_ends_with : string -> string -> bool
+val chop : string -> string
+val chomps : string -> string
+val skip_n_char_ : int -> int -> string -> string
+val skip_n_char : int -> string -> string
+val explode_string : string -> char list
+val is_uppercase : char -> bool
+val is_lowercase : char -> bool
+val starts_with_non_lowercase : string -> bool
+val get_package_name : string -> string option
+val split_at_two_colons : string -> string * string
+val to_CamelCase : string -> string option
+val string_of_ref : 'a ref -> string
+val is_int : float -> bool
+val compare_lists : ('a -> 'b -> int) -> 'a list -> 'b list -> int
+val compare_best : int -> int -> int
+val combine_comparison_list : int list -> int
+val min_with_cmp : ('a -> 'a -> bool) -> 'a -> 'a -> 'a
+val max_with_cmp : ('a -> 'a -> bool) -> 'a -> 'a -> 'a
+val fold_left2_compare :
+  ('a -> 'b -> 'c -> 'a) -> 'a -> 'b list -> 'c list -> 'a
+val exists_compare : ('a -> 'b) -> 'a list -> 'b
+val forall_compare : ('a -> int) -> 'a list -> int
+val forall2_compare : ('a -> 'b -> int) -> 'a list -> 'b list -> int
+val exists2_compare : int -> ('a -> 'b -> int) -> 'a list -> 'b list -> int
+val compare_sorted_sets : ('a -> 'b -> bool) -> 'a list -> 'b list -> int
+val scan_list_while_modifying :
+  ('a list -> 'a list -> 'a -> ('a list * 'a list) option) ->
+  'a list -> 'a list
+val bools2compare : bool * bool -> int
+val lpush : 'a list ref -> 'a -> unit
+module OrderedString : sig type t = string val compare : 'a -> 'a -> int end
+module StringSet :
+  sig
+    type elt = OrderedString.t
+    and t = Set.Make(OrderedString).t
+    val empty : t
+    val is_empty : t -> bool
+    val mem : elt -> t -> bool
+    val add : elt -> t -> t
+    val singleton : elt -> t
+    val remove : elt -> t -> t
+    val union : t -> t -> t
+    val inter : t -> t -> t
+    val diff : t -> t -> t
+    val compare : t -> t -> int
+    val equal : t -> t -> bool
+    val subset : t -> t -> bool
+    val iter : (elt -> unit) -> t -> unit
+    val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a
+    val for_all : (elt -> bool) -> t -> bool
+    val exists : (elt -> bool) -> t -> bool
+    val filter : (elt -> bool) -> t -> t
+    val partition : (elt -> bool) -> t -> t * t
+    val cardinal : t -> int
+    val elements : t -> elt list
+    val min_elt : t -> elt
+    val max_elt : t -> elt
+    val choose : t -> elt
+  end
+val stringSet_to_list : StringSet.t -> StringSet.elt list
+val stringSet_add : StringSet.t -> StringSet.elt -> StringSet.t
+val stringSet_difference : StringSet.t -> StringSet.t -> StringSet.t
+val list_to_StringSet : StringSet.elt list -> StringSet.t
diff --git a/perl_checker.src/flags.ml b/perl_checker.src/flags.ml
new file mode 100644
index 0000000..e69de29
--- /dev/null
+++ b/perl_checker.src/flags.ml
diff --git a/perl_checker.src/flags.mli b/perl_checker.src/flags.mli
new file mode 100644
index 0000000..8b13789
--- /dev/null
+++ b/perl_checker.src/flags.mli
@@ -0,0 +1 @@
+
diff --git a/perl_checker.src/info.ml b/perl_checker.src/info.ml
new file mode 100644
index 0000000..5c002ae
--- /dev/null
+++ b/perl_checker.src/info.ml
@@ -0,0 +1,25 @@
+open List
+open Printf
+open Common
+
+let (lines_starts : (string * int list ref) list ref) = ref []
+let current_file_lines_starts = ref []
+let current_file = ref ""
+
+let start_a_new_file file = 
+  current_file := file ;
+  current_file_lines_starts := [0] ;
+  lines_starts := (file, current_file_lines_starts) :: !lines_starts
+
+let pos2line (file, a, b) = 
+  let starts = map_index (fun a b -> a,b) (rev !(assoc file !lines_starts)) in
+  let ((offset, line), _) = find (fun (_,(e,_)) -> e > a) (combine starts (tl starts @ [99999, 99999])) in
+  file, line, a - offset, b - offset
+
+let pos2sfull pos = 
+  try
+    let (file, line, n1,n2) = pos2line pos in
+    sprintf "File \"%s\", line %d, character %d-%d\n" file (line + 1) n1 n2
+  with Not_found -> ""
+
+let pos2sfull_current a b = pos2sfull (!current_file, a, b)
diff --git a/perl_checker.src/info.mli b/perl_checker.src/info.mli
new file mode 100644
index 0000000..5751d2b
--- /dev/null
+++ b/perl_checker.src/info.mli
@@ -0,0 +1,7 @@
+val lines_starts : (string * int list ref) list ref
+val current_file_lines_starts : int list ref
+val current_file : string ref
+val start_a_new_file : string -> unit
+val pos2line : string * int * int -> string * int * int * int
+val pos2sfull : string * int * int -> string
+val pos2sfull_current : int -> int -> string
diff --git a/perl_checker.src/lexer.mll b/perl_checker.src/lexer.mll
new file mode 100644
index 0000000..73c40bb
--- /dev/null
+++ b/perl_checker.src/lexer.mll
@@ -0,0 +1,423 @@
+{ (* -*- caml -*- *)
+open Parser
+open Common
+open Lexing
+open Info
+
+
+let next_rule = ref None
+
+let here_docs = Queue.create()
+let current_here_doc_mark = ref ""
+
+let delimit_char = ref '/'
+let not_ok_for_match = ref (-1)
+let string_nestness = ref 0
+
+let building_current_string = ref ""
+let current_string_start_pos = ref 0
+
+let ins_with_offset offset t lexbuf = 
+  building_current_string := ""; current_string_start_pos := lexeme_start lexbuf + offset;
+  t lexbuf ;
+  !building_current_string, (!current_file, !current_string_start_pos, lexeme_end lexbuf)
+let ins t lexbuf = ins_with_offset 0 t lexbuf
+let ins_to_string t lexbuf =
+  let s, pos = ins t lexbuf in
+  not_ok_for_match := lexeme_end lexbuf; 
+  STRING(s, pos)
+
+let next_s s t lexbuf =
+  building_current_string := !building_current_string ^ s ;
+  t lexbuf
+let next t lexbuf = next_s (lexeme lexbuf) t lexbuf
+
+let pos lexbuf = !current_file, lexeme_start lexbuf, lexeme_end lexbuf
+
+let pos2sfull_with start end_ = Info.pos2sfull (!current_file, start, end_)
+
+let pos2sfull lexbuf = pos2sfull_with (lexeme_start lexbuf) (lexeme_end lexbuf)
+
+let die lexbuf err = failwith (pos2sfull_with !current_string_start_pos (lexeme_end lexbuf) ^ err)
+
+let rec lexbuf2list t lexbuf =
+  let rec f () =
+    match t lexbuf with
+    | EOF -> []
+    | e -> e :: f()
+  in
+  let l = f() in
+  l
+
+let ident_type_from_char fq name lexbuf c = 
+  not_ok_for_match := lexeme_end lexbuf; 
+  match c with
+  | '$' -> SCALAR_IDENT(fq, name, pos lexbuf)
+  | '@' -> ARRAY_IDENT (fq, name, pos lexbuf)
+  | '%' -> HASH_IDENT  (fq, name, pos lexbuf)
+  | '&' -> FUNC_IDENT  (fq, name, pos lexbuf)
+  | '*' -> STAR_IDENT  (fq, name, pos lexbuf)
+  | _ -> internal_error "ident_type_from_char"
+
+let ident_from_lexbuf lexbuf = 
+  let fq, name = split_at_two_colons (lexeme lexbuf) in
+  RAW_IDENT(Some fq, name, pos lexbuf)
+  
+let typed_ident_from_lexbuf lexbuf = 
+  let s = lexeme lexbuf in
+  ident_type_from_char None (skip_n_char 1 s) lexbuf s.[0]
+
+let typed_fqident_from_lexbuf lexbuf = 
+  let s = lexeme lexbuf in
+  let fq, name = split_at_two_colons (skip_n_char 1 s) in
+  ident_type_from_char (Some fq) name lexbuf s.[0]
+  
+let arraylen_ident_from_lexbuf lexbuf = 
+  not_ok_for_match := lexeme_end lexbuf; 
+  let s = lexeme lexbuf in
+  ARRAYLEN_IDENT(None, skip_n_char 2 s, pos lexbuf)
+
+let arraylen_fqident_from_lexbuf lexbuf = 
+  let s = lexeme lexbuf in
+  let fq, name = split_at_two_colons (skip_n_char 2 s) in
+  ARRAYLEN_IDENT(Some fq, name, pos lexbuf)
+
+}
+
+let space = [' ' '\t']
+let stash = [ '$' '@' '%' '&' '*' ]
+let ident_start = ['a'-'z' 'A'-'Z' '_']
+let ident = ident_start ['0'-'9' 'A'-'Z' 'a'-'z' '_'] *
+let pattern_separator = [ '/' '!' ',' '|' ]
+
+rule token = parse
+| space+ { 
+    (* propagate not_ok_for_match when it was set by the previous token *)
+    if lexeme_start lexbuf = !not_ok_for_match then not_ok_for_match := lexeme_end lexbuf; 
+    (*SPACE(pos lexbuf) *) token lexbuf
+  }
+| '#' [^ '\n']* { (*COMMENT(lexeme lexbuf, pos lexbuf)*) token lexbuf }
+
+| "\n=" { 
+  let s, pos = ins_with_offset 1 pod_command lexbuf in POD(s, pos) }
+
+| '\n' { 
+    lpush current_file_lines_starts (lexeme_end lexbuf);
+    (try
+      let (interpolate, mark, r) = Queue.pop here_docs in
+      current_here_doc_mark := mark ;
+      r := ins (if interpolate then here_doc else raw_here_doc) lexbuf
+    with Queue.Empty -> ());
+    token lexbuf
+  }
+| "->" { ARROW }
+| "++" { INCR }
+| "--" { DECR }
+| "**" { POWER }
+| "!" { TIGHT_NOT }
+| "~" { BIT_NEG }
+| "=~" { PATTERN_MATCH }
+| "!~" { PATTERN_MATCH_NOT }
+| "*" { MULT }
+| "%" { MODULO }
+| "x" { REPLICATE }
+| "+" { PLUS }
+| "-" { MINUS }
+| "." { CONCAT }
+| "<<" { BIT_SHIFT_LEFT }
+| ">>" { BIT_SHIFT_RIGHT }
+| "<" | ">" | "<=" | ">=" | "lt" | "gt" | "le" | "ge" { COMPARE_OP(lexeme lexbuf) }
+| "==" | "!=" | "<=>" | "eq" | "ne" | "cmp" { EQ_OP(lexeme lexbuf) }
+| "&" { BIT_AND }
+| "|" { BIT_OR }
+| "^" { BIT_XOR }
+| "&&" { AND_TIGHT }
+| "||" { OR_TIGHT }
+| ".." { DOTDOT }
+| "..." { DOTDOTDOT }
+| "?" { QUESTION_MARK }
+| ":" { COLON }
+| "::" { PKG_SCOPE }
+
+| "=" | "+=" | "-=" | "*=" | "/=" | ".=" | "|=" | "&=" | "^=" | "||=" | "&&=" { ASSIGN(lexeme lexbuf) }
+
+| "," { COMMA }
+| "=>" { RIGHT_ARROW }
+| "not" { NOT }
+| "and" { AND }
+| "or" { OR }
+| "xor" { XOR }
+
+| "if"       { IF }
+| "unless"   { UNLESS }
+| "do"       { DO }
+| "while"    { WHILE }
+| "until"    { UNTIL }
+| "foreach"  { FOR("foreach") }
+| "for"      { FOR("for") }
+| "my"       { MY }
+| "local"    { LOCAL }
+| "continue" { CONTINUE }
+| "sub"      { SUB }
+| "format"   { FORMAT }
+| "package"  { PACKAGE }
+| "use"      { USE }
+| "print"    { PRINT(pos lexbuf) }
+| "new"      { NEW(pos lexbuf) }
+
+| '@' { AT }
+| '$' { DOLLAR }
+| '%' { PERCENT }
+| '&' { AMPERSAND }
+| '*' { STAR }
+| "$#" { ARRAYLEN }
+
+
+| ';' { SEMI_COLON }
+| '(' { PAREN }
+| '{' { BRACKET }
+| '[' { ARRAYREF }
+| ')' { not_ok_for_match := lexeme_end lexbuf; PAREN_END }
+| '}' { not_ok_for_match := lexeme_end lexbuf; BRACKET_END }
+| ']' { not_ok_for_match := lexeme_end lexbuf; ARRAYREF_END }
+
+| '(' [ '$' '@' '\\' '&' ';' ]+ ')' {
+    (* bloody prototypes, must be caught especially otherwise "($)" is badly tokenized *)
+    PROTOTYPE(lexeme lexbuf, pos lexbuf)
+  }
+
+| "/" {
+    if lexeme_start lexbuf = !not_ok_for_match then DIVISION 
+    else (
+      delimit_char := '/' ;
+      let s, pos = ins delimited_string lexbuf in
+      let opts, _ = ins pattern_options lexbuf in
+      PATTERN(s, opts, pos)
+    ) 
+  }
+
+| "m" pattern_separator {
+  delimit_char := lexeme_char lexbuf 1 ;
+  let s, pos = ins delimited_string lexbuf in
+  let opts, _ = ins pattern_options lexbuf in
+  PATTERN(s, opts, pos)
+}
+
+| "qr" pattern_separator {
+  delimit_char := lexeme_char lexbuf 2 ;
+  let s, pos = ins delimited_string lexbuf in
+  let opts, _ = ins pattern_options lexbuf in
+  PATTERN(s, opts, pos)
+}
+
+| "s" pattern_separator {
+  delimit_char := lexeme_char lexbuf 1 ;
+  let s1, (_, start, _) = ins delimited_string lexbuf in 
+  let s2, (_, _, end_)  = ins delimited_string lexbuf in 
+  let opts, _ = ins pattern_options lexbuf in
+  PATTERN_SUBST(s1, s2, opts, (!current_file, start, end_))
+}
+
+| "tr" pattern_separator {
+  delimit_char := lexeme_char lexbuf 2 ;
+  let s1, (_, start, _) = ins delimited_string lexbuf in 
+  let s2, (_, _, end_)  = ins delimited_string lexbuf in 
+  let opts, _ = ins pattern_options lexbuf in
+  PATTERN_SUBST(s1, s2, opts, (!current_file, start, end_))
+}
+    
+| "<<" ident { 
+    let here_doc_ref = ref("", bpos) in
+    Queue.push (true, skip_n_char 2 (lexeme lexbuf), here_doc_ref) here_docs ;
+    HERE_DOC here_doc_ref
+  }
+| "<<'" ident "'" { 
+    not_ok_for_match := lexeme_end lexbuf; 
+    let here_doc_ref = ref("", bpos) in
+    Queue.push (false, skip_n_char_ 3 1 (lexeme lexbuf), here_doc_ref) here_docs ;
+    HERE_DOC here_doc_ref
+  }
+| "<<" space+ "'"
+| "<<" space+ ident { 
+    failwith (pos2sfull_with (lexeme_start lexbuf + 2) (lexeme_end lexbuf) ^ "No space allowed between \"<<\" and the marker")
+  }
+| "<<" space* '"' { 
+    failwith (pos2sfull_with (lexeme_start lexbuf + 2) (lexeme_end lexbuf) ^ "Don't use <<\"MARK\", use <<MARK instead")
+  }
+
+| "\\" stash
+| "\\" ['0'-'9' 'A'-'Z' 'a'-'z']
+| "\\" space* '('
+    { lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_curr_pos - 1; REF }
+
+| "$#" ident? ("::" ident)+ { arraylen_fqident_from_lexbuf lexbuf }
+| "$#" ident { arraylen_ident_from_lexbuf lexbuf }
+
+| stash ident? ("::" ident)+ { typed_fqident_from_lexbuf lexbuf }
+| stash ident
+| stash '^'? [^ '{' ' ' '\t' '\n'] { typed_ident_from_lexbuf lexbuf }
+
+| ident? ("::" ident)+ { ident_from_lexbuf lexbuf }
+| ident { BAREWORD(lexeme lexbuf, pos lexbuf) }
+
+| ident ":" { LABEL(lexeme lexbuf, pos lexbuf) }
+
+| ['0'-'9'] ['0'-'9' '_']* ('.' ['0'-'9'] ['0'-'9' '_']*)+ 
+| 'v' ['0'-'9'] ['0'-'9' '_']* ('.' ['0'-'9'] ['0'-'9' '_']*)* 
+  { 
+    not_ok_for_match := lexeme_end lexbuf; 
+    REVISION(lexeme lexbuf, pos lexbuf)
+  }
+
+| ['0'-'9']* '.' ['0'-'9']+ (['e' 'E']['-' '+']?['0'-'9']+)? { 
+    not_ok_for_match := lexeme_end lexbuf; 
+    NUM(lexeme lexbuf, pos lexbuf) 
+  }
+| ['0'-'9'] ['0'-'9' '_']* { 
+    not_ok_for_match := lexeme_end lexbuf; 
+    NUM(lexeme lexbuf, pos lexbuf)
+  }
+| "0x" ['0'-'9' 'a'-'f' 'A'-'F']+ { 
+    not_ok_for_match := lexeme_end lexbuf; 
+    NUM(lexeme lexbuf, pos lexbuf)
+  }
+
+| '"'   { ins_to_string string lexbuf }
+| "'"   { ins_to_string rawstring lexbuf }
+| '`'   { delimit_char := '`'; 
+	  not_ok_for_match := lexeme_end lexbuf; 
+	  let s, pos = ins delimited_string lexbuf in COMMAND_STRING(s, pos) }
+| "q("  { ins_to_string qstring lexbuf }
+| "qq(" { ins_to_string qqstring lexbuf }
+| "qw(" { let s, pos = ins qstring lexbuf in QUOTEWORDS(s, pos) }
+
+| eof   { EOF }
+| _ { failwith (Printf.sprintf "%serror tokenizing <<%s>>" (pos2sfull lexbuf) (lexeme lexbuf)) }
+
+and string = parse
+  '"' { () }
+| '\\' { next_rule := Some string ; string_escape lexbuf }
+| '\n' { 
+    lpush current_file_lines_starts (lexeme_end lexbuf);
+    next string lexbuf
+  }
+| [^ '\n' '\\' '"']+ { next string lexbuf }
+| eof { die lexbuf "Unterminated_string" }
+
+and delimited_string = parse
+| '\\' { next_rule := Some delimited_string ; string_escape lexbuf }
+| '\n' { 
+    lpush current_file_lines_starts (lexeme_end lexbuf);
+    next delimited_string lexbuf
+  }
+| eof { die lexbuf "Unterminated_delimited_string" }
+| [ ^ '\\' '\n' ] { if lexeme_char lexbuf 0 <> !delimit_char then next delimited_string lexbuf }
+
+and rawstring = parse
+  ''' { () }
+| '\n' { 
+    lpush current_file_lines_starts (lexeme_end lexbuf);
+    next rawstring lexbuf
+  }
+| "\\'"
+| [^ '\n' ''']+ { next rawstring lexbuf }
+| eof { die lexbuf "Unterminated_rawstring" }
+
+and qqstring = parse
+  ')' { 
+    if !string_nestness <> 0 then (decr string_nestness; next qqstring lexbuf)
+  }
+| '(' {
+    incr string_nestness;
+    next qqstring lexbuf
+  }
+| '\\' { next_rule := Some qqstring ; string_escape lexbuf }
+| '\n' { 
+    lpush current_file_lines_starts (lexeme_end lexbuf);
+    next qqstring lexbuf
+  }
+| [^ '\n' '(' ')' '\\']+ { next qqstring lexbuf }
+| eof { die lexbuf "Unterminated_qqstring" }
+
+and qstring = parse
+| ')' { 
+    if !string_nestness <> 0 then (decr string_nestness ; next qstring lexbuf) 
+  }
+| '(' {
+    incr string_nestness;
+    next qstring lexbuf
+  }
+| '\n' { 
+    lpush current_file_lines_starts (lexeme_end lexbuf);
+    next qstring lexbuf
+  }
+| [^ '\n' '(' ')']+ { next qstring lexbuf }
+| eof { die lexbuf "Unterminated_qstring" }
+
+and here_doc = parse
+| '\\' { next_rule := Some here_doc ; string_escape lexbuf }
+| [ ^ '\n' '\\' ]* {
+    let s = lexeme lexbuf in
+    if chomps s <> !current_here_doc_mark
+    then next_s s here_doc lexbuf 
+    else if s <> !current_here_doc_mark then Printf.eprintf "%sTrailing spaces after HERE-document mark\n" (pos2sfull lexbuf)
+  }
+| '\n' { 
+    lpush current_file_lines_starts (lexeme_end lexbuf);
+    next here_doc lexbuf
+  }
+| eof { die lexbuf "Unterminated_here_doc" }
+
+and raw_here_doc = parse
+| [ ^ '\n' ]* {
+    let s = lexeme lexbuf in
+    if chomps s <> !current_here_doc_mark
+    then next_s s raw_here_doc lexbuf 
+    else if s <> !current_here_doc_mark then Printf.eprintf "%sTrailing spaces after HERE-document mark\n" (pos2sfull lexbuf)
+  }
+| '\n' { 
+    lpush current_file_lines_starts (lexeme_end lexbuf);
+    next raw_here_doc lexbuf
+  }
+| eof { die lexbuf "Unterminated_raw_here_doc" }
+
+
+and string_escape = parse
+| '0' { next_s "\000" (some !next_rule) lexbuf }
+| '"' { next_s "\"" (some !next_rule) lexbuf }
+| ''' { next_s "'"  (some !next_rule) lexbuf }
+| 'n' { next_s "\n" (some !next_rule) lexbuf }
+| 't' { next_s "\t" (some !next_rule) lexbuf }
+| 'x' _ _ { 
+  try
+    let s = String.make 1 (Char.chr (int_of_string ("0" ^ lexeme lexbuf))) in
+    next_s s (some !next_rule) lexbuf 
+  with Failure("int_of_string") -> die lexbuf ("Bad_hex_in_string \"" ^ lexeme lexbuf ^ "\"")
+  }
+| _ { next_s ("\\" ^ lexeme lexbuf) (some !next_rule) lexbuf }
+
+and pattern_options = parse
+| [ 'g' 'i' 'm' 'o' 's' 'x' 'e' ] { next pattern_options lexbuf }
+| _ { lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_curr_pos - 1; () }
+
+and pod_command = parse
+| [^ '\n' ]+ {
+  let s = lexeme lexbuf in
+  if String.contains s '\t' then failwith(pos2sfull lexbuf ^ "tabulations not accepted in POD commands") else
+  let command = String.sub s 0 (try String.index s ' ' with Not_found -> String.length s) in
+  match command with
+  | "cut" ->
+    if !building_current_string = "" then
+      failwith(pos2sfull lexbuf ^ "found POD command \"=cut\" but it is not a POD block")
+  | "head1" | "head2" | "head3" | "head4" | "over" | "item" | "back" | "pod" | "begin" | "end" | "for" ->
+      next pod lexbuf
+  | s -> failwith(pos2sfull lexbuf ^ "unknown POD command \"" ^ s ^ "\"")
+ }
+| _ { failwith(pos2sfull lexbuf ^ "POD command expected") }
+
+and pod = parse
+| "\n=" { next pod_command lexbuf }
+| "\n" [^ '=' '\n'] [^ '\n']*
+| "\n" { next pod lexbuf }
+| eof
+| _ { failwith(pos2sfull_with !current_string_start_pos (lexeme_end lexbuf) ^ "POD block still open") }
diff --git a/perl_checker.src/parser.mly b/perl_checker.src/parser.mly
new file mode 100644
index 0000000..0f5f34b
--- /dev/null
+++ b/perl_checker.src/parser.mly
@@ -0,0 +1,307 @@
+%{ (* -*- caml -*- *)
+  open Types
+  open Common
+
+  let parse_error _ =
+   failwith (Info.pos2sfull_current (Parsing.symbol_start()) (Parsing.symbol_end()) ^ "parse error")   
+
+  let to_Ident = function
+   | BAREWORD(name, pos) -> Ident(I_raw, None, name, pos)
+   | SCALAR_IDENT(fq, name, pos) -> Ident(I_scalar, fq, name, pos)
+   | ARRAY_IDENT (fq, name, pos) -> Ident(I_array,  fq, name, pos)
+   | HASH_IDENT  (fq, name, pos) -> Ident(I_hash,   fq, name, pos)
+   | FUNC_IDENT  (fq, name, pos) -> Ident(I_func,   fq, name, pos)
+   | STAR_IDENT  (fq, name, pos) -> Ident(I_star,   fq, name, pos)
+   | RAW_IDENT   (fq, name, pos) -> Ident(I_raw,    fq, name, pos)
+   | _ -> internal_error "Parser.to_Ident"
+%}
+
+
+%token EOF
+%token <Types.pos> SPACE
+%token <string * Types.pos> NUM STRING BAREWORD PROTOTYPE REVISION COMMENT POD LABEL
+%token <string * Types.pos> COMMAND_STRING QUOTEWORDS
+%token <(string * Types.pos) ref> HERE_DOC
+%token <string * string * Types.pos> PATTERN
+%token <string * string * string * Types.pos> PATTERN_SUBST
+
+%token <string option * string * Types.pos> SCALAR_IDENT ARRAY_IDENT HASH_IDENT FUNC_IDENT STAR_IDENT RAW_IDENT ARRAYLEN_IDENT
+
+%token IF ELSIF ELSE UNLESS DO WHILE UNTIL MY CONTINUE SUB LOCAL
+%token <string> FOR
+%token USE PACKAGE FORMAT
+%token <Types.pos> PRINT NEW
+%token AT DOLLAR PERCENT AMPERSAND STAR ARRAYLEN
+%token SEMI_COLON PKG_SCOPE
+%token PAREN PAREN_END
+%token BRACKET BRACKET_END
+%token ARRAYREF ARRAYREF_END
+
+
+%token ARROW
+%token INCR DECR
+%token POWER
+%token TIGHT_NOT BIT_NEG REF
+%token PATTERN_MATCH PATTERN_MATCH_NOT
+%token MULT DIVISION MODULO REPLICATE
+%token PLUS MINUS CONCAT
+%token BIT_SHIFT_LEFT BIT_SHIFT_RIGHT
+%token <string> COMPARE_OP EQ_OP
+%token BIT_AND
+%token BIT_OR BIT_XOR
+%token AND_TIGHT
+%token OR_TIGHT
+%token DOTDOT DOTDOTDOT
+%token QUESTION_MARK COLON
+%token <string> ASSIGN
+%token COMMA RIGHT_ARROW
+%token NOT
+%token AND
+%token OR XOR
+
+%nonassoc PREC_LOW
+%nonassoc LOOPEX
+
+%left       OR XOR
+%left       AND
+%right      NOT
+%nonassoc   LSTOP
+%left   COMMA RIGHT_ARROW
+
+%right      ASSIGN
+%right      QUESTION_MARK COLON
+%nonassoc   DOTDOT DOTDOTDOT
+%left       OR_TIGHT
+%left       AND_TIGHT
+%left       BIT_OR BIT_XOR
+%left       BIT_AND
+%nonassoc   EQ_OP
+%nonassoc   COMPARE_OP
+%nonassoc   UNIOP
+%left       BIT_SHIFT_LEFT BIT_SHIFT_RIGHT
+%left       PLUS MINUS CONCAT
+%left       MULT DIVISION MODULO REPLICATE
+%left       PATTERN_MATCH PATTERN_MATCH_NOT
+%right      TIGHT_NOT BIT_NEG REF UNARY_MINUS
+%right      POWER
+%nonassoc   INCR DECR
+%left       ARROW
+
+%nonassoc PAREN_END
+%left PAREN
+%left ARRAYREF BRACKET
+
+%type <string> prog
+
+%start prog
+
+
+%%
+prog: lineseq EOF { "" }
+
+block: BRACKET lineseq BRACKET_END { $2 }
+
+lineseq: /* A collection of "lines" in the program */
+|              {[]}
+| decl lineseq {[]}
+| label line {[]}
+
+line:
+| if_then_else lineseq { [] }
+| loop lineseq { [] }
+| SEMI_COLON lineseq { [] }
+| sideff SEMI_COLON lineseq { [] }
+
+| sideff { [] }
+
+
+if_then_else: /* Real conditional expressions */
+| IF     PAREN expr PAREN_END block elsif else_ {[]}
+| UNLESS PAREN expr PAREN_END block elsif else_ {[]}
+
+elsif:
+|  { [] }
+| ELSIF PAREN expr PAREN_END block elsif { [ $3, $5 ] @ $6 }
+
+else_: 
+|            { None }
+| ELSE block { Some $2 }
+
+loop:
+| WHILE PAREN expr_or_empty PAREN_END block cont {[]}
+| UNTIL PAREN expr PAREN_END block cont {[]}
+| FOR MY SCALAR_IDENT PAREN expr PAREN_END block cont {[]}
+| FOR SCALAR_IDENT PAREN expr PAREN_END block cont {[]}
+| FOR PAREN expr PAREN_END block cont {[]}
+| FOR PAREN expr_or_empty ';' expr_or_empty ';' expr_or_empty PAREN_END block {[]}
+| block cont {[]} /* a block is a loop that happens once */
+
+cont: /* Continue blocks */
+|  {[]}
+| CONTINUE block {[]}
+
+sideff: /* An expression which may have a side-effect */
+| error { [] }
+| expr { $1 }
+| expr   IF    expr { [ (*Binary("if",      $1, $3)*) ] }
+| expr UNLESS  expr { [ (*Binary("unless",  $1, $3)*) ] }
+| expr  WHILE  expr { [ (*Binary("while",   $1, $3)*) ] }
+| expr  UNTIL  expr { [ (*Binary("until",   $1, $3)*) ] }
+| expr  FOR    expr { [ (*Binary($2,        $1, $3)*) ] }
+
+decl:
+| FORMAT formname block {[]}
+| SUB word prototype_or_empty subbody {[]}
+| PACKAGE word SEMI_COLON {[]}
+| USE word_or_empty revision_or_empty listexpr SEMI_COLON {[]}
+
+formname: {[]} | BAREWORD {[]}
+subbody: block { $1 } | SEMI_COLON {[]}
+
+
+listexpr: /* Basic list expressions */
+| %prec PREC_LOW {[]}
+| argexpr %prec PREC_LOW {[]}
+
+expr: /* Ordinary expressions; logical combinations */
+| expr AND expr {[]}
+| expr OR expr {[]}
+| argexpr %prec PREC_LOW {[]}
+
+argexpr: /* Expressions are a list of terms joined by commas */
+| argexpr comma {[]}
+| argexpr comma term {[]}
+| term %prec PREC_LOW {[]}
+
+term:
+| term binop term {[]}
+| termunop {[]}
+| anonymous {[]}
+| termdo {[]}
+| term QUESTION_MARK term COLON term {[]}
+| REF term {[]} /* \$x, \@y, \%z */
+| MY myterm     %prec UNIOP {[]}
+| LOCAL term    %prec UNIOP {[]}
+| PAREN expr_or_empty PAREN_END {[]}
+
+| scalar        %prec PAREN {[]}
+| star          %prec PAREN {[]}
+| hash          %prec PAREN {[]}
+| array         %prec PAREN {[]}
+| arraylen      %prec PAREN {[]} /* $#x, $#{ something } */
+
+| subscripted {[]}
+
+| PAREN expr_or_empty PAREN_END ARRAYREF expr ARRAYREF_END {[]} /* list slice */
+| array ARRAYREF expr ARRAYREF_END {[]} /* array slice */
+| array BRACKET expr BRACKET_END {[]} /* @hash{@keys} */
+
+| function_call {[]}
+
+| word {[]}
+| NUM {[]}
+| STRING {[]}
+| REVISION {[]}
+| COMMAND_STRING {[]}
+| QUOTEWORDS {[]}
+| HERE_DOC {[]}
+
+function_call:
+| func {[]} /* &foo; */
+| func PAREN expr_or_empty PAREN_END {[]} /* &foo(@args) */
+| word argexpr {[]} /* foo(@args) */
+| word block listexpr %prec LSTOP {[]} /* map { foo } @bar */
+
+| term ARROW word_or_scalar PAREN expr_or_empty PAREN_END {[]} /* $foo->bar(list) */
+| term ARROW word_or_scalar {[]} /* $foo->bar */
+
+| NEW word listexpr {[]} /* new Class @args */
+| PRINT word_or_scalar argexpr {[]} /* print $fh @args */
+
+termdo: /* Things called with "do" */
+| DO term %prec UNIOP                               {[]} /* do $filename */
+| DO block %prec PAREN                   {[]} /* do { code */
+
+termunop: /* Unary operators and terms */
+| MINUS term %prec UNARY_MINUS {[]}
+| TIGHT_NOT term {[]}
+| BIT_NEG term {[]}
+| INCR term    {[]}
+| DECR term    {[]}
+| term INCR    {[]}
+| term DECR    {[]}
+
+| NOT argexpr  {[]}
+
+myterm: /* Things that can be "my"'d */
+| PAREN expr_or_empty PAREN_END {[]}
+| scalar {[]}
+| hash {[]}
+| array {[]}
+
+subscripted: /* Some kind of subscripted expression */
+| star PKG_SCOPE BRACKET expr BRACKET_END {[]} /* *main::{something} */
+| scalar ARRAYREF expr ARRAYREF_END         {[]} /* $array[$element] */
+| scalar BRACKET expr BRACKET_END           {[]} /* $foo{bar} */
+| term ARROW ARRAYREF expr ARRAYREF_END     {[]} /* somearef->[$element] */
+| term ARROW BRACKET expr BRACKET_END       {[]} /* somehref->{bar} */
+| term ARROW PAREN expr_or_empty PAREN_END  {[]} /* $subref->(@args) */
+| subscripted ARRAYREF expr ARRAYREF_END    {[]} /* $foo->[$bar][$baz] */
+| subscripted BRACKET expr BRACKET_END      {[]} /* $foo->[bar]{baz;} */
+| subscripted PAREN expr_or_empty PAREN_END {[]} /* $foo->{bar}(@args) */
+
+binop:
+| ASSIGN {[]}
+| POWER {[]}
+| MULT {[]} | DIVISION {[]} | MODULO {[]} | REPLICATE {[]}
+| PLUS {[]} | MINUS {[]} | CONCAT {[]}
+| BIT_SHIFT_LEFT {[]} | BIT_SHIFT_RIGHT {[]}
+| COMPARE_OP {[]}
+| EQ_OP {[]}
+| BIT_AND {[]}
+| BIT_OR {[]} | BIT_XOR {[]}
+| DOTDOT {[]} | DOTDOTDOT {[]}
+| AND_TIGHT {[]}
+| OR_TIGHT {[]} | XOR {[]}
+| PATTERN_MATCH {[]} | PATTERN_MATCH_NOT {[]}
+
+anonymous: /* Constructors for anonymous data */
+| ARRAYREF expr_or_empty ARRAYREF_END {[]}
+| BRACKET expr_or_empty BRACKET_END %prec PAREN {[]} /* { foo => "Bar" } */
+| SUB prototype_or_empty block %prec PAREN {[]}
+
+label:
+|                 { None }
+| BAREWORD COLON { Some $1 }
+
+word:
+| bareword { fst $1 }
+| RAW_IDENT { 
+    match $1 with
+    | None, name, _ -> name
+    | Some s, name, _ -> s ^ "::" ^ name
+  }
+
+comma: COMMA {[]} | RIGHT_ARROW {[]}
+
+word_or_scalar:
+| bareword     { [] }
+| RAW_IDENT    { [] }
+| SCALAR_IDENT { [] }
+
+bareword:
+| NEW { "new", $1 }
+| PRINT { "print", $1 }
+| BAREWORD { $1 }
+
+arraylen: ARRAYLEN_IDENT {[]} | ARRAYLEN block {[]}
+scalar: SCALAR_IDENT {[]} | DOLLAR    block {[]}
+func:   FUNC_IDENT   {[]} | AMPERSAND block {[]}
+array:  ARRAY_IDENT  {[]} | AT        block {[]}
+hash:   HASH_IDENT   {[]} | PERCENT   block {[]}
+star:   STAR_IDENT   {[]} | STAR      block {[]}
+
+expr_or_empty: {[]} | expr {[]}
+word_or_empty: {[]} | word {[]}
+prototype_or_empty: {[]} | PROTOTYPE {[]}
+revision_or_empty: {[]} | REVISION {[]}
diff --git a/perl_checker.src/perl_checker.ml b/perl_checker.src/perl_checker.ml
new file mode 100644
index 0000000..dd7b75e
--- /dev/null
+++ b/perl_checker.src/perl_checker.ml
@@ -0,0 +1,18 @@
+open Types
+
+let _ = 
+  let file = try Sys.argv.(2) with _ -> try Sys.argv.(1) with _ -> "/tmp/t.pl" in
+  let lexbuf = Lexing.from_channel (open_in file) in
+  let _ = 
+    try
+      Info.start_a_new_file file ;
+      if false then
+	let tokens = Lexer.lexbuf2list Lexer.token lexbuf in
+	let _,_ = tokens, tokens in ""
+      else
+	Parser.prog Lexer.token lexbuf
+    with Failure s -> (
+      prerr_endline s ;
+      exit 1
+     ) in
+  ()
diff --git a/perl_checker.src/perl_checker.mli b/perl_checker.src/perl_checker.mli
new file mode 100644
index 0000000..8b13789
--- /dev/null
+++ b/perl_checker.src/perl_checker.mli
@@ -0,0 +1 @@
+
diff --git a/perl_checker.src/print.ml b/perl_checker.src/print.ml
new file mode 100644
index 0000000..e69de29
--- /dev/null
+++ b/perl_checker.src/print.ml
diff --git a/perl_checker.src/print.mli b/perl_checker.src/print.mli
new file mode 100644
index 0000000..8b13789
--- /dev/null
+++ b/perl_checker.src/print.mli
@@ -0,0 +1 @@
+
diff --git a/perl_checker.src/types.mli b/perl_checker.src/types.mli
new file mode 100644
index 0000000..570da0f
--- /dev/null
+++ b/perl_checker.src/types.mli
@@ -0,0 +1,16 @@
+exception TooMuchRParen
+
+type pos = string * int * int
+
+type ident_type = I_scalar | I_hash | I_array | I_func | I_raw | I_star
+
+type fromparser = 
+   | Ident of ident_type * string option * string * pos
+
+   | Num of float * pos
+   | String of string * pos
+   | Nil
+
+   | Binary of string * fromparser * fromparser
+   | If_then_else of string * (fromparser * fromparser) list * fromparser option
+