Sébastien Ferré avatar Sébastien Ferré committed bd642c3

Git

Comments (0)

Files changed (13)

 let get_trace () = !trace
 let set_trace b = trace := b
 
+let union_msgs msgs1 msgs2 =
+  List.filter (fun msg1 -> not (List.mem msg1 msgs2)) msgs1 @ msgs2
+
 
 type ('cursor, 'ctx, 'res, 'msg) result = Parsed of 'ctx * 'res * 'cursor | Failed of 'msg list
 
 
 type ('ctx, 'res, 'cursor, 'msg) parse = 'ctx -> 'cursor -> ('ctx, 'res, 'cursor, 'msg) p
 
-class ['ctx,'res,'cursor,'msg] fail (cursor : 'cursor) =
+class ['ctx,'res,'cursor,'msg] fail (ctx : 'ctx) (cursor : 'cursor) =
   object (self)
     method next : ('cursor, 'ctx, 'res, 'msg) result =
       Failed ([] : 'msg list)
 	  ( match p2 # next with
 	  | Parsed _ as x -> x
 	  | Failed msgs2 ->
-	      state <- `End (msgs2 @ msgs);
+	      state <- `End (union_msgs msgs2 msgs);
 	      self # next)
       | `End msgs -> Failed msgs
   end
 	      state <- `Second (msgs, p1, parse2 res1 ctx1 cursor1);
 	      self # next
 	  | Failed msgs1 ->
-	      state <- `End (msgs1 @ msgs);
+	      state <- `End (union_msgs msgs1 msgs);
 	      self # next)
       | `Second (msgs, p1,p2) ->
 	  ( match p2 # next with
 	  | Parsed _ as x -> x
 	  | Failed msgs2 ->
-	      state <- `First (msgs2 @ msgs, p1);
+	      state <- `First (union_msgs msgs2 msgs, p1);
 	      self # next)
       | `End msgs -> Failed msgs
   end
 	  ( match p3 # next with
 	  | Parsed _ as x -> x
 	  | Failed msgs3 ->
-	      state <- `End (msgs3 @ msgs);
+	      state <- `End (union_msgs msgs3 msgs);
 	      self#next)
       | `End msgs -> Failed msgs
   end
 	      let coord = cursor#coord in
 	      let msg = Msg.make name [||] (Msg.Locator.Point coord) in
 *)
-	      state <- `End (msgs1 @ msgs);
+	      state <- `End (union_msgs msgs1 msgs);
 	      self#next)
       | `End msgs -> Failed msgs
   end
 
 let check = new check
 
+class ['ctx,'res,'cursor,'msg] trial (f : unit -> 'res) (ctx : 'ctx) (cursor : 'cursor) =
+  object (self)
+    val mutable state = `Begin
+
+    method next =
+      match state with
+      | `Begin ->
+	  state <- `End;
+	  begin
+	    try
+	      let x = f () in
+	      Parsed (ctx, x, cursor)
+	    with exn ->
+	      let name = Printexc.to_string exn in
+	      let coord = cursor#coord in
+	      let msg = Msg.make name [||] (Msg.Locator.Point coord) in
+	      Failed [msg]
+	  end
+      | `End -> Failed []
+  end
+
+let trial = new trial
+
 class ['ctx,'res,'cursor,'msg] enum (name : string) (f : unit -> 'res list) (ctx : 'ctx) (cursor : 'cursor) =
   object (self)
     val mutable state : 'res list option = None
     method set_init p =
       let pos = p-offset in
       assert (pos >= 0 && pos <= len);
+(* debug *)
+(*
       prerr_endline ("Matcher: buffer length = " ^ string_of_int len);
       prerr_endline s;
+*)
       s <- String.sub s pos (len - pos);
       len <- String.length s;
       offset <- p
     method shift (m : string) : cursor =
       let len = String.length m in
       let p' = p + len in
-      new cursor skip str p' (shiftPos coord m 0 len)
+      let coord' = shiftPos coord m 0 len in
+      new cursor skip str p' coord'
 
     method init : unit =
 (*      print_endline (Token.toString ("init", coord)); *)
+(*print_endline (Msg.Coord.toString coord); *)
       str#set_init p
+
+(*
+    initializer
+      print_endline (Msg.Coord.toString coord);
+*)
+
   end
 
 let cursor_of_string skip s = new cursor skip (new str_string s) 0 (1,1)

dcg/old/pa_dcg2.ml

   expr: LEVEL "top"
     [ [ "dcg"; pcl = parser_case_list ->
           ( match pcl with
-	  | [] -> <:expr< Dcg.eps >>
+	  | [] -> assert false
 	  | pc::pcl' ->
               let p = List.fold_left (fun res pc -> <:expr< Dcg.alt $res$ $pc$ >>) pc pcl' in
 	      <:expr< fun str -> $p$ str >>)
       ] ];
 
   parser_case_list:
+    [ [ pc = parser_case -> pc
+      | pc = parser_case; "|"; pcl = parser_case_list -> pc pcl
+      ] ]
+
+(*
+  parser_case_list:
     [ [ OPT "|"; pcl = LIST1 parser_case SEP "|" -> pcl
       ] ];
+*)
 
   parser_case:
     [ [ stream_begin; sp = stream_patt; stream_end; "->"; e = expr ->
       | s = str ->
           <:patt< _ >>, <:expr< Matcher.look $s$ >>
       | x = ipatt; ff = binding ->
-        x, ff x
+	  x, ff x
+(* does not work because non-empty intersection between patterns and expressions (e.g., identifiers)
+      | p = quantif ->
+	  <:patt< _ >>, p
+*)
       ] ];
  
   binding:
     val is_empty : t -> bool
     val cardinal : t -> int
     val mem : int -> t -> bool
+    val choose : t -> int (* may raise Not_found *)
     val singleton : int -> t
     val add : int -> t -> t
     val remove : int -> t -> t
     val compl : t -> t
   end
 
+module Set : T =
+  struct
+    module S = Set.Make (struct type t = int let compare x y = Pervasives.compare y x end)
+    type t = S.t
+    let empty = S.empty
+    let is_empty = S.is_empty
+    let cardinal = S.cardinal
+    let mem = S.mem
+    let choose = S.choose
+    let singleton = S.singleton
+    let add = S.add
+    let remove = S.remove
+    let subset = S.subset
+    let union = S.union
+    let inter = S.inter
+    let diff = S.diff
+    let union_r l = List.fold_left (fun res set -> union res set) empty l
+    let inter_r = function
+      | [] -> raise (Invalid_argument "Intset.Set.inter_r : empty list of sets")
+      | set::sets -> List.fold_right (fun set res -> inter set res) sets set
+    let fold f s init = S.fold (fun x res -> f res x) init s
+    let iter = S.iter
+    let map f s = S.fold (fun x res -> f x :: res) s []
+    let filter = S.filter
+    let elements = S.elements
+    let memory_size s = 1 + 4 * S.cardinal s
+  end
+
 module Cis : T =
 (* Cis implementation of extents *)
   struct
     let is_empty = Cis.is_empty
     let cardinal = Cis.cardinal
     let mem = Cis.mem
+    let choose = Cis.choose
     let singleton = Cis.singleton
     let add = Cis.add
     let remove = Cis.remove
     let is_empty = LSet.is_empty
     let cardinal = LSet.cardinal
     let mem = LSet.mem
+    let choose = List.hd
     let singleton = LSet.singleton
     let add = LSet.add
     let remove = LSet.remove
     let map = List.map
     let filter = List.filter
     let elements l = l
-    let memory_size l = 1 + (4 * LSet.cardinal l)
+    let memory_size l = 1 + (3 * LSet.cardinal l)
+  end
+
+module Bitmap1 : T_BOUNDED =
+  struct
+    let bound = 1
+
+    type t = bool
+
+    let cardinal i = if i then 1 else 0
+
+    let empty = false
+
+    let is_empty i = not i
+
+    let full = true
+
+    let is_full i = i
+
+    let choose i = if i then 0 else raise Not_found
+
+    let mem x i = i
+
+    let singleton x =
+      assert (x < bound);
+      true
+
+    let add x i =
+      assert (x < bound);
+      true
+
+    let remove x i =
+      false
+
+    let subset i1 i2 =  (not i1) || i2
+
+    let compl i = not i
+
+    let union i1 i2 = i1 || i2
+
+    let inter i1 i2 = i1 && i2
+
+    let diff i1 i2 = i1 && (not i2)
+
+    let union_r l = List.fold_left (fun res set -> union res set) empty l
+
+    let inter_r = function
+      | [] -> raise (Invalid_argument "Intset.Bitmap31.inter_r : empty list of sets")
+      | set::sets -> List.fold_right (fun set res -> inter set res) sets set
+
+    let fold f init i = f init 0
+
+    let iter f i = f 0
+
+    let map f e = fold (fun res x -> f x::res) [] e
+	
+    let filter p i = i && (p 0)
+	  
+    let elements e =
+      List.rev (fold (fun res x -> x::res) [] e)
+
+    let memory_size e = 1
   end
 
 module Bitmap31 : T_BOUNDED = (* intsets on [0..31[ *)
     let mem x i =
       (i lsr x) land 1 <> 0
 
+    let choose i =
+      if i = 0
+      then raise Not_found
+      else begin
+	let x = ref 0 in
+	while not (mem !x i) do
+	  incr x
+	done;
+	!x end
+
     let singleton x =
       assert (x < bound);
       (1 lsl x)
   end
 
 
+module Intmap : T with type t = unit Intmap.M.t =
+  struct
+    module M = Intmap.M
+    type t = unit M.t
+    let empty = M.empty
+    let is_empty = M.is_empty
+    let cardinal = M.cardinal
+    let mem = M.mem
+    let choose = M.choose
+    let singleton = M.singleton
+    let add = M.add
+    let remove = M.remove
+    let subset a b = M.subset a b
+    let union a b = M.domain_union a b
+(*
+      let insert a b = M.fold (fun res x _ -> M.add x res) b a in
+      let na, nb = M.cardinal a, M.cardinal b in
+      if na > nb
+      then insert b a
+      else insert a b
+*)
+    let inter a b = M.domain_inter a b
+(*
+      let select a b = M.domain_filter (fun x _ -> M.mem x a) b in
+      let na, nb = M.cardinal a, M.cardinal b in
+      if na > nb
+      then select a b
+      else select b a
+*)
+    let diff a b = M.domain_diff ~filter:(fun x v1 v2 -> v2 = None) a b
+(*
+      let na, nb = M.cardinal a, M.cardinal b in
+      if na > nb
+      then M.fold (fun res x _ -> M.remove x res) a b
+      else M.domain ~filter:(fun x _ -> not (M.mem x b)) a
+*)
+    let union_r l = List.fold_left (fun res set -> union res set) empty l
+    let inter_r = function
+      | [] -> raise (Invalid_argument "Intset.Bitmap961.inter_r : empty list of sets")
+      | set::sets -> List.fold_right (fun set res -> inter set res) sets set
+    let fold f = M.fold (fun res x (_ : unit) -> f res x)
+    let iter f = M.iter (fun x (_ : unit) -> f x)
+    let map f = M.fold (fun res x (_ : unit) -> f x :: res) []
+    let filter f = M.domain ~filter:(fun x (_ : unit) -> f x)
+    let elements = M.fold (fun res x (_ : unit) -> x :: res) []
+    let memory_size a = M.memory_size a
+  end
+
+
+(* deprecated
+
 module Bitmap (X : T_BOUNDED) : T_BOUNDED =
   struct
     let bound = 31 * X.bound
       assert (x < bound);
       Obj.repr x
 
-    let simpl e =
-      let e_mask = get_mask e in
-      if e_mask = 0
-      then empty
-      else
-	let n = cardinal_word e_mask in
-	if n = 1 && X.cardinal (get_field e 1) = 1
-	then singleton (List.hd (elements e))
-	else sub e 0 (1 + n) (* for removing extra words *)
-
     let add x e =
       assert (x < bound);
       match kind e with
 	    else e
 	  else e
 
+    let simpl e =
+      let e_mask = get_mask e in
+      if e_mask = 0
+      then empty
+      else
+	let n = cardinal_word e_mask in
+	if n = 1 && X.cardinal (get_field e 1) = 1
+	then singleton (List.hd (elements e))
+	else sub e 0 (1 + n) (* for removing extra words *)
+
 
     let subset e1 e2 =
       let subset_word i1 i2 = i1 land (lnot i2) = 0 in
 	  !res
   end
 
+deprecated *)
+
+
 (* for test *)
 (*
 module M = Bitmap (Bitmap (Bitmap31))
 
 let make l = List.fold_right M.add l M.empty
 *)
-
-(*
-module Bitmaprec (X : T_BOUNDED) : T_BOUNDED =
-  struct
-    let bound = 31 * X.bound
-
-    type t = Obj.t
-       (* empty set : -1 *)
-       (* full set : -2 *)
-       (* singleton : non-negative integer representing unique element *)
-       (* other sets : blocks *)
-	  (* tag indicates level *)
-	  (* field 0 is bitmap of non-empty subsets *)
-	  (* each 1-bit of field 0 refers to a subset *)
-	  (* the number of 1-bits in 'e.(0) lsr (x/X.bound)' gives the field containing the bit x *)
-
-    type kind = Empty | Full | Single of int | Other of Obj.t (* block *)
-
-    let kind e =
-      if Obj.is_int e
-      then
-	let i = (Obj.obj e : int) in
-	if i = -1 then Empty
-	else if i = -2 then Full
-	else Single i
-      else
-	Other e
-
-    (* computing efficiently number of 1-bits in bytes and words *)
-
-    let card_byte =
-      let t = Array.make 256 0 in
-      for i = 0 to 255 do
-	for j = 0 to 7 do
-	  if (i lsr j) land 1 <> 0
-	  then t.(i) <- t.(i) + 1
-	done
-      done;
-      t
-
-    let cardinal_word i =
-      card_byte.(i land 0xFF)
-	+ card_byte.((i lsr 8) land 0xFF)
-	+ card_byte.((i lsr 16) land 0xFF)
-	+ card_byte.((i lsr 24) land 0xFF)
-
-    (* low level access to representations as arrays *)
-	
-    let make m n = (* m is the initial mask, and n the number of fields, comprising the mask *)
-      assert (n > 0);
-      let e = Obj.new_block 0 n in
-      Obj.set_field e 0 (Obj.repr m);
-      e
-
-    let copy e = Obj.dup e
-
-    let sub e pos len =
-      let e' = Obj.new_block 0 len in
-      for i = 0 to len - 1 do
-	Obj.set_field e' i (Obj.field e (pos + i))
-      done;
-      e'
-
-    let length e = Obj.size e
-
-    let get_mask e = (Obj.obj (Obj.field e 0) : int)
-
-    let set_mask e m = Obj.set_field e 0 (Obj.repr m)
-
-    let get_field e i = (Obj.obj (Obj.field e i) : X.t)
-
-    let set_field e i s = Obj.set_field e i (Obj.repr s)
-
-
-    let get_i x1 e =
-      let b = (get_mask e) lsr x1 in
-      assert (b land 1 <> 0);
-      cardinal_word b
-
-    let get_subset x1 e =
-      let b = (get_mask e) lsr x1 in
-      if b land 1 = 0
-      then X.empty
-      else get_field e (cardinal_word b)
-
-    let get_index x e = (* returns coordinates of bit x in e *)
-      let x1, x2 = x / X.bound, x mod X.bound in
-      let b = (get_mask e) lsr x1 in
-      if b land 1 = 0
-      then (cardinal_word b + 1, x1, x2, false)
-      else (cardinal_word b, x1, x2, true)
-      
-    (* bitwise operations *)
-
-    let test i x2 =
-      (i lsr x2) land 1 <> 0
-
-    let set i x2 =
-      i lor (1 lsl x2)
-
-    let reset i x2 =
-      i land ((-1) - (1 lsl x2))
-
-    (* intset interface *)
-
-    let fold f init e =
-      match kind e with
-      | Empty -> init
-      | Full ->
-	  let res = ref init in
-	  for x = 0 to bound - 1 do
-	    res := f !res x
-	  done;
-	  !res
-      | Single x -> f init x
-      | Other e ->
-	  let e_mask = get_mask e in
-	  let res = ref init in
-	  for x1 = 0 to 31 - 1 do
-	    if test e_mask x1 then begin
-	      let i = get_subset x1 e in
-	      let x0 = X.bound * x1 in
-	      res := X.fold (fun res2 x2 -> f res2 (x0 + x2)) !res i
-	    end
-	  done;
-	  !res
-
-    let elements e =
-      List.rev (fold (fun res x -> x::res) [] e)
-
-    let empty = Obj.repr (-1)
-
-    let is_empty e =
-      match kind e with
-      | Empty -> true
-      | Full -> false
-      | Single _ -> false
-      | Other e -> get_mask e = 0
-
-    let full = Obj.repr (-2)
-(*
-      let n = 31 in
-      let e = make (-1) (n + 1) in
-      for i = 1 to n-1 do
-	set_field e i X.full
-      done;
-      e
-*)
-
-    let is_full e =
-      match kind e with
-      | Empty -> false
-      | Full -> true
-      | Single _ -> false
-      | Other e ->
-	  let n = length e in
-	  let res = ref (get_mask e = (-1)) in
-	  let i = ref 1 in
-	  while !res && !i < n do
-	    res := !res && X.is_full (get_field e !i);
-	    incr i
-	  done;
-	  !res
-
-    let cardinal e =
-      match kind e with
-      | Empty -> 0
-      | Full -> bound
-      | Single _ -> 1
-      | Other e ->
-	  let n = length e in
-	  let res = ref 0 in
-	  for i = 1 to n-1 do
-	    res := !res + X.cardinal (get_field e i)
-	  done;
-	  !res
-
-    let mem x e =
-      match kind e with
-      | Empty -> false
-      | Full -> x < bound
-      | Single y -> x = y
-      | Other e ->
-	  let i, _, x2, present = get_index x e in
-	  present && X.mem x2 (get_field e i)
-
-    let singleton x =
-      assert (x < bound);
-      Obj.repr x
-
-    let simpl e =
-      let e_mask = get_mask e in
-      if e_mask = 0
-      then empty
-      else
-	let n = cardinal_word e_mask in
-	if n = 1 && X.cardinal (get_field e 1) = 1
-	then singleton (List.hd (elements e))
-	else sub e 0 (1 + n) (* for removing extra words *)
-
-    let add x e =
-      assert (x < bound);
-      match kind e with
-      | Empty -> singleton x
-      | Full -> e
-      | Single y ->
-	  let x1, x2 = x / X.bound, x mod X.bound in
-	  let y1, y2 = y / X.bound, y mod X.bound in
-	  if x1 = y1
-	  then begin
-	    let e = make (1 lsl x1) 2 in
-	    set_field e 1 (X.add x2 (X.singleton y2));
-	    e end
-	  else begin
-	    let e = make ((1 lsl x1) lor (1 lsl y1)) 3 in
-	    let ix, iy = if x1 < y1 then 2, 1 else 1, 2 in
-	    set_field e ix (X.singleton x2);
-	    set_field e iy (X.singleton y2);
-	    e
-	  end
-      | Other e ->
-	  let i, x1, x2, present = get_index x e in
-	  if present
-	  then
-	    if X.mem x2 (get_field e i)
-	    then e
-	    else begin
-	      let e' = copy e in (* unsafe not to make a copy *)
-	      let e'_x1 = X.add x2 (get_field e' i) in
-	      set_field e' i e'_x1;
-	      if X.is_full e'_x1 && is_full e'
-	      then full
-	      else e'
-	    end
-	  else begin
-	    let n = length e in
-	    let e' = make (set (get_mask e) x1) (n+1) in
-	    for k = 1 to i-1 do
-	      Obj.set_field e' k (Obj.field e k)
-	      (* set_field e' k (get_field e k) *)
-	    done;
-	    for k = n downto i+1 do
-	      Obj.set_field e' k (Obj.field e (k-1))
-	      (* set_field e' k (get_field e (k-1)) *)
-	    done;
-	    set_field e' i (X.singleton x2);
-	    e' end
-
-    let remove x e =
-      match kind e with
-      | Empty -> e
-      | Full ->
-	  if x < bound
-	  then begin
-	    let x1, x2 = x / X.bound, x mod X.bound in
-	    let i = x1 + 1 in
-	    let n = 31 in
-	    let e' = make (-1) (n+1) in
-	    for k = 1 to i-1 do
-	      set_field e' k X.full
-	    done;
-	    set_field e' i (X.remove x2 X.full);
-	    for k = i+1 to n-1 do
-	      set_field e' k X.full
-	    done;
-	    e' end
-	  else e
-      | Single y ->
-	  if x = y
-	  then empty
-	  else e
-      | Other e ->
-	  let i, x1, x2, present = get_index x e in
-	  if present
-	  then
-	    if X.mem x2 (get_field e i)
-	    then
-	      let e'_i = X.remove x2 (get_field e i) in
-	      if X.is_empty e'_i
-	      then begin
-		let n' = length e - 1 in
-		let e' = make (reset (get_mask e) x1) n' in
-		for k = 1 to i-1 do
-		  Obj.set_field e' k (Obj.field e k)
-		  (* set_field e' k (get_field e k) *)
-		done;
-		for k = i to n'-1 do
-		  Obj.set_field e' k (Obj.field e (k+1))
-		  (* set_field e' k (get_field e (k+1)) *)
-		done;
-		if n' = 1
-		then empty
-		else
-		  if n' = 2 && X.cardinal (get_field e' 1) = 1
-		  then singleton (List.hd (elements e'))
-		  else e' end
-	      else begin
-		let e' = copy e in
-		set_field e' i e'_i;
-		e'
-	      end
-	    else e
-	  else e
-
-
-    let subset e1 e2 =
-      let subset_word i1 i2 = i1 land (lnot i2) = 0 in
-      match kind e1, kind e2 with
-      | Empty, _ -> true
-      | _, Full -> true
-      | _, Empty -> is_empty e1
-      | Full, _ -> is_full e2
-      | Single x1, _ -> mem x1 e2
-      | Other e1, Single y ->
-	  let y1, y2 = y / X.bound, y mod X.bound in
-	  if subset_word (get_mask e1) (1 lsl y1)
-	  then X.subset (get_subset y1 e1) (X.singleton y2)
-	  else false
-      | Other e1, Other e2 ->
-	  if not (subset_word (get_mask e1) (get_mask e2))
-	  then false
-	  else begin
-	    let res = ref true in
-	    let x1 = ref 0 in
-	    while !res && !x1 < 31 do
-	      res := not (test (get_mask e1) !x1) || X.subset (get_subset !x1 e1) (get_subset !x1 e2);
-	      incr x1
-	    done;
-	    !res
-	  end
-
-    let compl e1 =
-      match kind e1 with
-      | Empty -> full
-      | Full -> empty
-      | Single x -> remove x full
-      | Other e1 ->
-	  let e1_mask = get_mask e1 in
-	  if e1_mask = 0
-	  then full
-	  else begin
-	    let e = make (-1) (31+1) in
-	    for x1 = 31 - 1 downto 0 do
-	      if test e1_mask x1
-	      then
-		let e_x1 = X.compl (get_subset x1 e1) in
-		if X.is_empty e_x1
-		then set_mask e (reset (get_mask e) x1)
-		else set_field e (get_i x1 e) e_x1
-	      else set_field e (get_i x1 e) X.full
-	    done;
-	    simpl e
-	  end
-
-    let union e1 e2 =
-      let union_word i1 i2 = i1 lor i2 in
-      match kind e1, kind e2 with
-      | Empty, _ -> e2
-      | _, Empty -> e1
-      | Full, _
-      | _, Full -> full
-      | Single x, _ -> add x e2
-      | _, Single y -> add y e1
-      | Other e1, Other e2 ->
-	  let e_mask = union_word (get_mask e1) (get_mask e2) in
-	  let n = cardinal_word e_mask in
-	  let e = make e_mask (n+1) in
-	  for x1 = 0 to 31 - 1 do
-	    if test (get_mask e) x1
-	    then set_field e (get_i x1 e) (X.union (get_subset x1 e1) (get_subset x1 e2))
-	  done;
-	  e
-
-    let inter e1 e2 =
-      let inter_word i1 i2 = i1 land i2 in
-      match kind e1, kind e2 with
-      | Empty, _
-      | _, Empty -> empty
-      | Full, _ -> e2
-      | _, Full -> e1
-      | Single x, _ -> if mem x e2 then e1 else empty
-      | _, Single y -> if mem y e1 then e2 else empty
-      | Other e1, Other e2 ->
-	  let e_mask = inter_word (get_mask e1) (get_mask e2) in
-	  if e_mask = 0
-	  then empty
-	  else begin
-	    let n = cardinal_word e_mask in
-	    let e = make e_mask (n+1) in
-	    for x1 = 31 - 1 downto 0 do
-	      if test (get_mask e) x1
-	      then
-		let e_x1 = X.inter (get_subset x1 e1) (get_subset x1 e2) in
-		if X.is_empty e_x1
-		then set_mask e (reset (get_mask e) x1)
-		else set_field e (get_i x1 e) e_x1
-	    done;
-	    simpl e
-	  end
-
-    let diff e1 e2 =
-(*      let diff_word i1 i2 = i1 land (lnot i2) in *)
-      match kind e1, kind e2 with
-      | Empty, _ -> empty
-      | _, Empty -> e1
-      | Full, _ -> compl e2
-      | _, Full -> empty
-      | Single x, _ -> if mem x e2 then empty else e1
-      | _, Single y -> remove y e1
-      | Other e1, Other e2 ->
-	  let e_mask = get_mask e1 in
-	  let n = cardinal_word e_mask in
-	  let e = make e_mask (n+1) in
-	  for x1 = 31 - 1 downto 0 do
-	    if test (get_mask e) x1
-	    then
-	      let e_x1 = X.diff (get_subset x1 e1) (get_subset x1 e2) in
-	      if X.is_empty e_x1
-	      then set_mask e (reset (get_mask e) x1)
-	      else set_field e (get_i x1 e) e_x1
-	  done;
-	  simpl e
-
-    let union_r l = List.fold_left (fun res set -> union res set) empty l
-
-    let inter_r = function
-      | [] -> raise (Invalid_argument "Intset.Bitmap961.inter_r : empty list of sets")
-      | set::sets -> List.fold_right (fun set res -> inter set res) sets set
-
-    let iter f e =
-      match kind e with
-      | Empty -> ()
-      | Full ->
-	  for x = 0 to bound - 1 do
-	    f x
-	  done
-      | Single x -> f x
-      | Other e ->
-	  let e_mask = get_mask e in
-	  for x1 = 0 to 31 - 1 do
-	    if test e_mask x1 then begin
-	      let i = get_subset x1 e in
-	      let x0 = X.bound * x1 in
-	      X.iter (fun x2 -> f (x0 + x2)) i
-	    end
-	  done
-
-    let map f e = fold (fun res x -> f x::res) [] e
-
-    let filter p e1 =
-      match kind e1 with
-      | Empty -> e1
-      | Full ->
-	  let e_mask = (-1) in
-	  let n = 31 in
-	  let e = make e_mask (n+1) in
-	  for x1 = 31 - 1 downto 0 do
-	    let x0 = X.bound * x1 in
-	    let e_x1 = X.filter (fun x2 -> p (x0 + x2)) X.full in
-	    if X.is_empty e_x1
-	    then set_mask e (reset (get_mask e) x1)
-	    else set_field e (get_i x1 e) e_x1
-	  done;
-	  simpl e
-      | Single x -> if p x then e1 else empty
-      | Other e1 ->
-	  let e_mask = get_mask e1 in
-	  let n = cardinal_word e_mask in
-	  let e = make e_mask (n+1) in
-	  for x1 = 31 - 1 downto 0 do
-	    if test (get_mask e) x1
-	    then
-	      let x0 = X.bound * x1 in
-	      let e_x1 = X.filter (fun x2 -> p (x0 + x2)) (get_subset x1 e1) in
-	      if X.is_empty e_x1
-	      then set_mask e (reset (get_mask e) x1)
-	      else set_field e (get_i x1 e) e_x1
-	  done;
-	  simpl e
-
-    let memory_size e =
-      match kind e with
-      | Empty -> 1
-      | Full -> 1
-      | Single _ -> 1
-      | Other e ->
-	  let n = length e in
-	  let res = ref (1 + n) in
-	  for i = 1 to n-1 do
-	    res := !res + X.memory_size (get_field e i)
-	  done;
-	  !res
-  end
-*)
 open Ipp
 
 class virtual cursor =
+  object (self : 'cursor)
+    method virtual print_string : string -> 'cursor
+    method at_init : bool = false
+    method init : 'cursor = self
+    method print_flush : unit = ()
+  end
+
+(*
+class virtual cursor =
   object
     method virtual print_string : string -> cursor
     method print_flush : unit = ()
     method virtual at_init : bool
     method virtual init : cursor
   end
+*)
 
 let print_string (v : string) = new operation (fun cursor -> cursor#print_string v)
 let eof () = new operation (fun cursor -> cursor#init)
 
 
+class buffer_cursor =
+  object (self)
+    inherit cursor
+
+    val buf = Buffer.create 255
+    val offset = 0
+    val suf = ""
+    val p = 0
+
+    method print_string s =
+      {< suf = suf ^ s; p = p + String.length s >}
+
+    method at_init = (p = offset)
+
+    method init =
+      Buffer.add_string buf suf;
+      {< offset = p; suf = ""; p = p >}
+
+    method contents = Buffer.contents buf
+  end
+let buffer_cursor = new buffer_cursor
+
+(*
 class cursor_buffer (buf : Buffer.t) (offset : int) (suf : string) (p : int) =
   object (self)
     inherit cursor
       new cursor_buffer buf p "" p
   end
 let cursor_of_buffer buf = new cursor_buffer buf 0 "" 0
-
+*)
+(*
 class cursor_string_ref (text : string ref) (offset : int) (suf : string) (p : int) =
   object (self)
     inherit cursor
       new cursor_string_ref text p "" p
   end
 let cursor_of_string_ref r = new cursor_string_ref r 0 "" 0
+*)
+
+class formatter_cursor (fmt : Format.formatter) =
+  (* invariant : result string = buf ^ suf; offset + String.length suf = p *)
+  object (self)
+    inherit cursor
 
+    val fmt = fmt
+    val offset = 0
+    val suf = ""
+    val p = 0
+
+    method print_string (s : string) =
+      {< suf = suf ^ s; p = p + String.length s >}
+
+    method print_flush = Format.pp_print_flush fmt ()
+
+    method at_init : bool = (p = offset)
+
+    method init =
+      Format.pp_print_string fmt suf;
+      {< offset = p; suf = "" >}
+  end
+let cursor_of_formatter fmt = new formatter_cursor fmt
+
+(*
 class cursor_formatter (fmt : Format.formatter) (offset : int) (suf : string) (p : int) =
   (* invariant : result string = buf ^ suf; offset + String.length suf = p *)
   object (self)
       new cursor_formatter fmt p "" p
   end
 let cursor_of_formatter fmt = new cursor_formatter fmt 0 "" 0
-
+*)
 
     val is_empty : t -> bool
     val compare_head : t -> t -> int
-    val empty : t
     val append : t -> t -> t
+(*     val cardinal : t -> int *)
+    val empty : t
+    val inter : t -> t -> t
     val iter : (elt -> unit) -> t -> unit
 
     val tail : t -> t -> t
     val prefix_inter : t -> t -> t * t
   end
 
-module PathLSet : PATH with type elt = int and type t = int LSet.t =
+(* UNSAFE
+module PathCis =
+  (* BEWARE: sensitive to changes in Cis *)
+  struct
+(*
+    type elt = int
+    type t = Cis.t
+*)
+
+    include Cis
+
+    let from_lset l =
+      List.fold_left
+	(fun res x -> add x res)
+	empty
+	(List.rev l)
+
+(*    let is_empty = Cis.is_empty *)
+
+    let compare_head xs ys = compare (max_elt xs) (max_elt ys)
+
+(*    let empty = Cis.empty *)
+
+(*     let append = Cis.append *)
+
+(*    let iter = Cis.iter *)
+
+    let rec tail xs ys =
+      (* assert (not (is_empty ys)); *)
+      let y = max_elt ys in
+      tail2 xs y
+    and tail2 xs y =
+      step xs
+	~nil:(fun () -> empty)
+	~single:(fun x l' ->
+	  let c = compare x y in
+	  if c < 0
+	  then tail2 l' y
+	  else xs)
+	~interv:(fun (xmax,xmin) l' ->
+	  let cmin = compare xmin y in
+	  if cmin < 0
+	  then tail2 l' y
+	  else
+	    let cmax = compare xmax y in
+	    if cmax < 0
+	    then cons_interv (y,xmin) l'
+	    else xs)
+
+    let rec rev l =
+      rev_aux empty l
+    and rev_aux acc l =
+      step l
+	~nil:(fun () -> acc)
+	~single:(fun x l -> rev_aux (cons_single x acc) l)
+	~interv:(fun (xmax,xmin) l -> rev_aux (cons_interv (xmax,xmin) acc) l)
+
+(*
+    let rec rev l =
+      rev_aux Nil l
+    and rev_aux acc = function
+      | Nil -> acc
+      | Single (x,l) -> rev_aux (Single (x,acc)) l
+      | Interv (xmax,xmin,l) -> rev_aux (Interv (xmax,xmin,acc)) l
+*)
+
+    let rec prefix_zip xs ys =
+      prefix_zip_aux empty xs ys
+    and prefix_zip_aux acc xs ys =
+      let base () = rev acc, xs, ys in
+      step xs
+	~nil:base
+	~single:(fun x1 l1 ->
+	  step ys
+	    ~nil:base
+	    ~single:(fun x2 l2 ->
+	      if x1 = x2 then prefix_zip_aux (cons_single x1 acc) l1 l2 else base ())
+	    ~interv:(fun (xmax2, xmin2) l2 ->
+	      if x1 = xmax2 then
+		let l2' = cons_interv (xmax2-1,xmin2) l2 in
+		rev (cons_single x1 acc), l1, l2'
+	      else base ()))
+	~interv:(fun (xmax1,xmin1) l1 ->
+	  step ys
+	    ~nil:base
+	    ~single:(fun x2 l2 ->
+	      if xmax1 = x2 then
+		let l1' = cons_interv (xmax1-1,xmin1) l1 in
+		rev (cons_single x2 acc), l1', l2
+	      else base ())
+	    ~interv:(fun (xmax2,xmin2) l2 ->
+	      if xmax1 = xmax2 then
+		let c = Cis.compare xmin1 xmin2 in
+		if c = 0 then
+		  prefix_zip_aux (cons_interv (xmax1,xmin1) acc) l1 l2
+		else if c < 0 then
+		  let l2' = cons_interv (xmin1-1,xmin2) l2 in
+		  rev (cons_interv (xmax1,xmin1) acc), l1, l2'
+		else (* c > 0 *)
+		  let l1' = cons_interv (xmin2-1,xmin1) l1 in
+		  rev (cons_interv (xmax2,xmin2) acc), l1', l2
+	      else base ()))
+
+    let rec prefix_inter xs ys =
+      prefix_inter_aux Nil xs ys
+    and prefix_inter_aux =
+      fun acc l1 l2 ->
+	step l1
+	  ~nil:(fun () -> l1, rev acc)
+	  ~single:(fun x1 l1_tail ->
+	    step l2
+	      ~nil:(fun () -> l1, rev acc)
+	      ~single:(fun x2 l2_tail ->
+		if x1 > 1+x2 then prefix_inter_aux acc l1_tail l2
+		else if x2 > 1+x1 then prefix_inter_aux acc l1 l2_tail
+		else if x1 = 1+x2 then prefix_inter_aux acc l1_tail l2_tail
+		else if x2 = 1+x1 then prefix_inter_aux acc l1_tail l2_tail
+		else (* x1=x2 *) prefix_inter_aux (Single (x1,acc)) l1_tail l2_tail)
+	      ~interv:(fun (xmax2,xmin2) l2_tail ->
+		if x1 > xmax2 then prefix_inter_aux acc l1_tail l2
+		else if xmin2 > x1 then prefix_inter_aux acc l1 l2_tail
+		else (* xmax2 >= x1 & x1 >= xmin2 *) prefix_inter_aux (Single (x1,acc)) l1_tail l2))
+	  ~interv:(fun (xmax1,xmin1) l1_tail ->
+	    step l2
+	      ~nil:(fun () -> l1, rev acc)
+	      ~single:(fun x2 l2_tail ->
+		if x2 > xmax1 then prefix_inter_aux acc l1 l2_tail
+		else if xmin1 > x2 then prefix_inter_aux acc l1_tail l2
+		else (* xmax1 >= x2 & x2 >= xmin1 *) prefix_inter_aux (Single (x2,acc)) l1 l2_tail)
+	      ~interv:(fun (xmax2,xmin2) l2_tail ->
+		if xmin2 > xmax1 then prefix_inter_aux acc l1 l2_tail
+		else if xmin1 > xmax2 then prefix_inter_aux acc l1_tail l2
+		else
+		  let xmax, xmin = min xmax1 xmax2, max xmin1 xmin2 in
+		  let acc' = if xmax = xmin then Single (xmax,acc) else Interv (xmax,xmin,acc) in
+		  if xmin1 >= xmin2 then prefix_inter_aux acc' l1_tail l2 else prefix_inter_aux acc' l1 l2_tail))
+
+  end
+*)
+
+
+module PathLSet (* : PATH with type elt = int *) =
   struct
     type elt = int
     type t = elt LSet.t
     let compare_head xs ys =
       LSet.compare (List.hd xs) (List.hd ys)
 
+    let append l1 l2 = l1 @ l2
+
+    let cardinal = LSet.cardinal
+
     let empty = []
 
-    let append =  (@)
+    let singleton = LSet.singleton
+
+    let add = LSet.add
+
+    let inter = LSet.inter
+
+    let fold_right = LSet.fold_right
+
+    let fold_left = LSet.fold_left
 
     let iter = List.iter
 
       | _, [] -> xs0, (List.rev s)
   end
 
+(*
 module PathLSetLast : PATH with type elt = int =
   struct
     type elt = int
     let compare_head (xs,ex) (ys,ey) =
       LSet.compare (List.hd xs) (List.hd ys)
 
+    let cardinal (l,e) = LSet.cardinal l
+
     let empty = [], 0
 
     let append (l1,e1) (l2,e2) =
       | [], _ -> [], (List.rev s,e)
       | _, [] -> xs0, (List.rev s,e)
   end
+*)
 
 module Make (Path : PATH) =
   struct
 	  match t with
 	  | Nil -> vopt, Node (xs, Some v, Nil, Nil)
 	  | Node (ys, vopt2, c2, b2) as tree ->
+	      (* assert (not (Path.is_empty ys)); *)
 	      let c = Path.compare_head xs ys in
 	      if c = 0 then
 		let prefix, xs1', ys2' = Path.prefix_zip xs ys in
       | Nil, _ -> t2
       | _, Nil -> t1
       | Node (ys1, vopt1, c1, b1), Node (ys2, vopt2, c2, b2) ->
+	  (* assert (not (Path.is_empty ys1)); *)
+	  (* assert (not (Path.is_empty ys2)); *)
 	  let c = Path.compare_head ys1 ys2 in
 	  if c = 0 then
 	    let prefix, ys1', ys2' = Path.prefix_zip ys1 ys2 in
       | Some v -> f ys v ys'
 	    
 
-    let rec mapmin_inter : (Path.t -> 'b -> 'b option) -> 'b t -> Path.t -> 'b t =
+    let rec mapmin_inter : ((*Path.t ->*) 'b -> 'b option) -> 'b t -> Path.t -> 'b t =
       fun f (vopt,t) xs ->
-	let child_vopt, t' = mapmin_inter2 f t xs Path.empty in
-	let vopt' = mapmin_inter_vopt f (first_vopt [vopt; child_vopt]) Path.empty in
+	let child_vopt, t' = mapmin_inter2 f t xs (*Path.empty*) in
+	let vopt' = mapmin_inter_vopt f (first_vopt [vopt; child_vopt]) (*Path.empty*) in
 	vopt', t'
-    and mapmin_inter2 f t xs path' =
+    and mapmin_inter2 f t xs (*path'*) =
       match t with
       | Nil -> None, Nil
       | Node (ys, vopt, child, brother) ->
 	  if Path.is_empty xs
 	  then
 	    let return_vopt =
-	      let brother_vopt, _ (* Nil *) = mapmin_inter2 f brother xs path' in
+	      let brother_vopt, _ (* Nil *) = mapmin_inter2 f brother xs (*path'*) in
 	      if brother_vopt <> None then brother_vopt
 	      else if vopt <> None then vopt
 	      else
-		let child_vopt, _ (* Nil *) = mapmin_inter2 f child xs path' in
+		let child_vopt, _ (* Nil *) = mapmin_inter2 f child xs (*path'*) in
 		child_vopt in
 	    return_vopt, Nil
-	  else 
-	    let c = Path.compare_head xs ys in
+	  else
+	    let c = (* assert (not (Path.is_empty ys)); *) Path.compare_head xs ys in
 	    if c = 0 then
 	      let xs', ys' = Path.prefix_inter xs ys in (* we know that ys' is not empty *)
-	      let path1' = Path.append path' ys' in
-	      let child_vopt, child' = mapmin_inter2 f child xs' path1' in
-	      let brother_vopt, brother' = mapmin_inter2 f brother xs path' in
-	      let vopt' = mapmin_inter_vopt f (first_vopt [vopt; child_vopt]) path1' in
+	      (*let path1' = Path.append path' ys' in*)
+	      let child_vopt, child' = mapmin_inter2 f child xs' (*path1'*) in
+	      let brother_vopt, brother' = mapmin_inter2 f brother xs (*path'*) in
+	      let vopt' = mapmin_inter_vopt f (first_vopt [vopt; child_vopt]) (*path1'*) in
 	      brother_vopt, Node (ys', vopt', child', brother')
 	    else if c < 0 then
-	      mapmin_inter2 f t (Path.tail xs ys) path'
+	      mapmin_inter2 f t (Path.tail xs ys) (*path'*)
 	    else (* c > 0 *)
 	      let xs', ys' = Path.prefix_inter xs ys in (* ys' may be empty *)
-	      let path1' = Path.append path' ys' in
-	      let child_vopt, child' = mapmin_inter2 f child xs' path1' in
-	      let brother_vopt, brother' = mapmin_inter2 f brother xs path' in
+	      (*let path1' = Path.append path' ys' in*)
+	      let child_vopt, child' = mapmin_inter2 f child xs' (*path1'*) in
+	      let brother_vopt, brother' = mapmin_inter2 f brother xs (*path'*) in
 	      let t1 =
 		let vopt1 = first_vopt [vopt; child_vopt] in
 		if Path.is_empty ys'
 		  let return_vopt = if brother_vopt = None then vopt1 else None in
 		  return_vopt, child'
 		else
-		  let vopt' = mapmin_inter_vopt f vopt1 path1' in
+		  let vopt' = mapmin_inter_vopt f vopt1 (*path1'*) in
 		  None, Node (ys', vopt', child', Nil) in
 	      let t2 = brother_vopt, brother' in
 	      union (fun _ v2 -> v2) t1 t2
-    and mapmin_inter_vopt f vopt ys' =
+    and mapmin_inter_vopt f vopt (*ys'*) =
       match vopt with
       | None -> None
-      | Some v -> f ys' v
+      | Some v -> f (*ys'*) v
 	    
   end
 
-(** Sets of sets represented by tries. *)
+(** 
+   Sets of sets represented by tries.
+ 
+   author: Sebastien Ferre <ferre@irisa.fr>
+*)
 
 let compare x y = Pervasives.compare y x (* for compatibility with LSet (Oops!) *)
 
-type ('a,'b) t = Add of (('a * ('a,'b) t * ('a,'b) t) * 'b option) | Empty of 'b option
+type ('a,'b) t = Add of ('a * ('a,'b) t * ('a,'b) t) * 'b option | Empty of 'b option
 
 let yss_vopt : ('a,'b) t -> ('a,'b) t * 'b option =
   function
 let mem : ('a,'b) t -> 'a LSet.t -> bool =
   fun yss xs ->
     try ignore (find yss xs); true
-    with Not_found -> true
+    with Not_found -> false
 
 let rec fold_contained : ('a LSet.t -> 'b -> 'c -> 'c) -> ('a,'b) t -> 'a LSet.t -> 'c -> 'c =
   fun f yss xs e -> fold_contained2 f yss xs e []

syndesc/ex_expr.ml

 let is_letter = function 'a'..'z' | 'A'..'Z' -> true | _ -> false
 let is_digit = function '0'..'9' -> true | _ -> false
 
-open Syndesc
+open Syndesc.Lazy
 
-let letter : char Syndesc.t = map token (Iso.subset is_letter)
-let digit : char Syndesc.t = map token (Iso.subset is_digit)
+let letter : char t = map token (Iso.subset is_letter)
+let digit : char t = map token (Iso.subset is_digit)
 
-let identifier : string Syndesc.t =
+let identifier : string t =
   map
     (seq letter (many (alt letter digit)))
     (Iso.seq Iso.cons (Iso.seq Iso.string_of_list (Iso.subset (fun id -> not (List.mem id keywords)))))
 
-let keyword (kwd : string) : unit Syndesc.t =
+let keyword (kwd : string) : unit t =
   map
     (either identifier (text kwd))
     (Iso.inverse Iso.right)
 
-let integer : int Syndesc.t =
+let integer : int t =
   map
     (some digit)
     (Iso.seq Iso.string_of_list Iso.int_of_string)
 
-let parens (p : 'a t) : 'a Syndesc.t = between (text "(") p (text ")")
+let parens (p : 'a t) : 'a t = between (text "(") p (text ")")
 
 let ops =
   alt
     (Iso.subset (fun (x, (op, y)) -> priority op = n))
     binOp
 
-let del_exp2 = delegate ()
-
-let rec exp0 () =
-  alt (map integer literal)
+let rec exp0 = lazy (
+  Syndesc.alt (map integer literal)
     (alt (map identifier variable)
-       (alt (map (ifzero ()) ifZero)
-	  (parens (between skip_space (del_exp2 :> expr Syndesc.t) skip_space))))
-and exp1 () =
-  chainl1 (exp0 ()) spaced_ops (binOpPrio 1)
-and exp2 () =
-  chainl1 (exp1 ()) spaced_ops (binOpPrio 2)
-and ifzero () =
-  prefix (keyword "ifzero")
+       (alt (map ifzero ifZero)
+	  (parens (between skip_space exp2 skip_space)))))
+and exp1 = lazy (
+  Syndesc.chainl1 exp0 spaced_ops (binOpPrio 1))
+and exp2 = lazy (
+  Syndesc.chainl1 exp1 spaced_ops (binOpPrio 2))
+and ifzero = lazy (
+  Syndesc.prefix (keyword "ifzero")
     (prefix opt_space
-       (seq (parens (del_exp2 :> expr Syndesc.t))
+       (seq (parens exp2)
 	  (prefix opt_space
-	     (seq (parens (del_exp2 :> expr Syndesc.t))
+	     (seq (parens exp2)
 		(prefix opt_space
 		   (prefix (keyword "else")
 		      (prefix opt_space
-			 (parens (del_exp2 :> expr Syndesc.t)))))))))
+			 (parens exp2)))))))))
 
 
 let expression =
-  del_exp2#set (exp2 ());
-  close (del_exp2 :> expr Syndesc.t)
+  Lazy.force (close exp2)
+
+let _ =
+  List.iter
+    (fun e ->
+      match expression#print e with
+      | Some s -> print_endline s
+      | None -> ())
+    (expression#parse "2 + x*y")
+
+(* custom syntax: sequential *)
+(*
+
+let mulOp n = iso [ CONSTR MulOp 0 -> op when priority op = 2 ]
+let addOp n = iso [ CONSTR AddOp 0 -> op when priority op = 1 ]
+let variable = iso [ CONSTR Variable 1 ]
+let literal = iso [ CONSTR Literal 1 ]
+let binOp = iso [ CONSTR BinOp 3 ]
+let ifZero = iso [ CONSTR IfZero 3 ]
+
+let rec exp2 = syndesc 
+   [ LIST1 exp1 SEP spaced_ops 2 ISO binOp ]
+and exp1 = syndesc
+   [ LIST1 exp0 SEP spaced_ops 1 ISO binOp ]
+and exp0 = syndesc
+   [ integer -> literal
+   | identifier -> variable
+   | !keyword "ifzero"; !opt_space; parens exp2; !opt_space; parens exp2; !opt_space;
+     !keyword "else"; !opt_space; parens exp2 -> ifZero ]
+   | parens [ !skip_space; exp2; !skip_space ] ]
+and integer = syndesc
+   [ SOME digit -> string_of_list; int_of_string ]
+and identifier = syndesc
+   [ letter :: MANY [ letter | digit ] -> string_of_list; id when not (List.mem id keywords) ]
+and keyword kwd = syndesc
+   [ 'kwd -> w when List.mem w keywords ]
+and parens p = syndesc
+   [ !"("; p; !")" ]
+and ops n = syndesc
+   [ "*" -> mulOp n
+   | "+" -> addOp n ]
+and spaced_ops n = syndesc
+   [ !opt_space; ops n; !opt_space ]
+and letter = syndesc
+   [ token -> when is_letter ]
+and digit = syndesc
+   [ token -> when is_digit ]
+
+let expression = Lazy.force (close exp2)
+
+*)
+
+(* custom syntax: functional *)
+(*
+
+let mulOp n = iso [ subset (fun op -> priority op = 2) of CONSTR MulOp 0]
+let addOp n = iso [ subset (fun op -> priority op = 1) of CONSTR AddOp 0]
+let variable = iso [ CONSTR Variable 1 ]
+let literal = iso [ CONSTR Literal 1 ]
+let binOp = iso [ CONSTR BinOp 3 ]
+let ifZero = iso [ CONSTR IfZero 3 ]
+(*let binOpPrio n = iso [ binOp of subset (fun (x, (op, y)) -> priority op = n) ] *)
+
+let rec exp2 = syndesc 
+   [ LIST1 exp1 SEP spaced_ops 2 ISO binOp ]
+and exp1 = syndesc
+   [ LIST1 exp0 SEP spaced_ops 1 ISO binOp ]
+and exp0 = syndesc
+   [ literal of integer
+   | variable of identifier
+   | ifZero of [ !keyword "ifzero"; !opt_space; parens exp2; !opt_space; parens exp2; !opt_space;
+     !keyword "else"; !opt_space; parens exp2 ]
+   | parens [ !skip_space; exp2; !skip_space ] ]
+and integer = syndesc
+   [ int_of_string of string_of_list of SOME digit ]
+and identifier = syndesc
+   [ subset (fun id -> not (List.mem id keywords)) of
+       string_of_list of letter :: MANY [ letter | digit ] ]
+and keyword kwd = syndesc
+   [ subset (fun w -> List.mem w keywords) of 'kwd ]
+and parens p = syndesc
+   [ !"("; p; !")" ]
+and ops n = syndesc
+   [ mulOp n of "*"
+   | addOp n of "+" ]
+and spaced_ops n = syndesc
+   [ !opt_space; ops n; !opt_space ]
+and letter = syndesc
+   [ subset is_letter of token ]
+and digit = syndesc
+   [ subset is_digit of token ]
+
+let expression = Lazy.force (close exp2)
+
+*)
+
+(* custom syntax (old) *)
+(*
+
+let mulOp = iso [ 'MulOp ] = iso [ CONSTR MulOp 0 ]
+let addOp = iso [ 'AddOp ]
+let variable = iso [ CONSTR Variable 1 ]
+let literal = iso [ CONSTR Literal 1 ]
+let binOp = iso [ CONSTR BinOp 3 ]
+let ifZero = iso [ CONSTR IfZero 3 ]
+let binOpPrio n = iso [ subset (fun (x, (op, y)) -> priority op = n); binOp ]
+
+let rec exp2 = syndesc 
+   [ LIST1 exp1 SEP spaced_ops ISO binOpPrio 2 ]
+and exp1 = syndesc
+   [ LIST1 exp0 SEP spaced_ops ISO binOpPrio 1 ]
+and exp0 = syndesc
+   [ integer -> literal
+   | identifier -> variable
+   | !keyword "ifzero"; !opt_space; parens exp2; !opt_space; parens exp2; !opt_space; 
+     !keyword "else"; !opt_space; parens exp2 -> ifZero
+   | parens [ !skip_space; exp2; !skip_space ] ]
+and integer = syndesc
+   [ SOME digit -> string_of_list; int_of_string ]
+and identifier = syndesc
+   [ letter; MANY [ letter | digit ] -> cons; string_of_list; subset (fun id -> not (List.mem id keywords)) ]
+and keyword kwd = syndesc
+   [ 'kwd -> subset (fun w -> List.mem w keywords) ]
+and parens p = syndesc
+   [ "("; p; ")" ]
+and ops = syndesc
+   [ "*" -> mulOp
+   | "+" -> addOp ]
+and spaced_ops = syndesc
+   [ !opt_space; ops; !opt_space ]
+and letter = syndesc
+   [ token -> subset is_letter ]
+and digit = syndesc
+   [ token -> subset is_digit ]
+
+let expression = Lazy.force (close exp2)
+
+*)
 
 let rec driver (f : 'a -> 'a MOption.t) (state : 'a) : 'a =
   match f state with
-  | Some state' -> driver f state'
+  | Some state' -> assert (state' <> state); driver f state'
   | None -> state
 
 class ['a] iterate (step : ('a,'a) t) : ['a,'a] t =

syndesc/syndesc.ml

     method parse : string -> ('a * string) MList.t
     method print : 'a -> string MOption.t
   end
-
-class ['a] close (p : 'a t) =
+class ['a] close (p : 'a t Lazy.t) =
   object
     method parse s =
-      MList.bind (p#parse s) (function (x,"") -> MList.one x | _ -> MList.zero)
+      MList.bind ((Lazy.force p)#parse s) (function (x,"") -> MList.one x | _ -> MList.zero)
     method print x =
-      p#print x
+      (Lazy.force p)#print x
   end
 let close p = new close p
 
+(*
 exception Undefined
 
 let undef : 'a t =
     method print = del#print
   end
 let delegate () = new delegate
+*)
 
-class ['a,'b] map (p : 'a t) (f : ('a,'b) Iso.t) : ['b] t =
+class ['a,'b] map (p : 'a t Lazy.t) (f : ('a,'b) Iso.t) : ['b] t =
   object
     method parse s =
-      MList.bind (p#parse s) (fun (x,s') ->
+      MList.bind ((Lazy.force p)#parse s) (fun (x,s') ->
 	match f#apply x with
 	| Some y -> MList.one (y,s')
 	| None -> MList.zero)
     method print y =
-      MOption.bind (f#unapply y) p#print
+      MOption.bind (f#unapply y) (Lazy.force p)#print
   end
 let map p f = new map p f
 let (<$>) = map
+(* p -> f *)
 
-class ['a,'b] seq (p : 'a t) (q : 'b t) : ['a * 'b] t =
+class ['a,'b] seq (p : 'a t Lazy.t) (q : 'b t Lazy.t) : ['a * 'b] t =
   object
     method parse s =
-      MList.bind (p#parse s) (fun (x,s') ->
-	MList.bind (q#parse s') (fun (y,s'') ->
+      MList.bind ((Lazy.force p)#parse s) (fun (x,s') ->
+	MList.bind ((Lazy.force q)#parse s') (fun (y,s'') ->
 	  MList.one ((x,y),s'')))
     method print (x,y) =
-      MOption.bind (p#print x) (fun s ->
-	MOption.bind (q#print y) (fun s' ->
+      MOption.bind ((Lazy.force p)#print x) (fun s ->
+	MOption.bind ((Lazy.force q)#print y) (fun s' ->
 	  MOption.some (s ^ s')))
   end
 let seq p q = new seq p q
 let (<*>) = seq
+(* p; q *)
 
-class ['a] alt (p : 'a t) (q : 'a t) : ['a] t =
+class ['a] alt (p : 'a t Lazy.t) (q : 'a t Lazy.t) : ['a] t =
   object
     method parse s =
-      (p#parse s) @ (q#parse s)
+      ((Lazy.force p)#parse s) @ ((Lazy.force q)#parse s)
     method print x =
-      MOption.plus (p#print x) (q#print x)
+      MOption.plus ((Lazy.force p)#print x) (fun () -> (Lazy.force q)#print x)
   end
 let alt p q = new alt p q
 let (<|>) = alt
+(* p | q *)
 
+(*
 let empty : 'a t =
   object
     method parse s =
     method print (x : 'a) =
       MOption.none
   end
+(* <vide> *)
+*)
 
 class ['a] pure (e : 'a) : ['a] t =
   object
       if x = e then MOption.some "" else MOption.none
   end
 let pure e = new pure e
+(* -> e *)
 
 (*
 let eof : unit t =
   end
 *)
 
-let either (p : 'a t) (q : 'b t) : ('a,'b) Iso.either t =
-  alt (map p Iso.left) (map q Iso.right)
+let either (p : 'a t Lazy.t) (q : 'b t Lazy.t) : ('a,'b) Iso.either t =
+  alt (lazy (map p Iso.left)) (lazy (map q Iso.right))
 let (<+>) = either
+(* p -> left | q -> right *)
+(* p else q *)
 
-let fixpoint (f : 'a t -> 'a t) : 'a t =
+(*
+let rec fixpoint (f : 'a t Lazy.t -> 'a t Lazy.t) : 'a t Lazy.t =
+  lazy (Lazy.force (f (fixpoint f)))
+(*
   let p0 = delegate () in
   let p1 = f (p0 :> 'a t) in
   p0#set p1;
   p1
+*)
+(* FIXPOINT x -> f x *)
+*)
 
-let many (p : 'a t) : 'a list t =
+let rec many (p : 'a t Lazy.t) : 'a list t =
+  map (lazy (either (lazy (pure ())) (lazy (seq p (lazy (many p)))))) Iso.list_cases
+(*
   fixpoint (fun self ->
     map (either (pure ()) (seq p self)) Iso.list_cases)
+*)
+(* MANY p *)
 
-let some (p : 'a t) : 'a list t =
+let some (p : 'a t Lazy.t) : 'a list t =
   map
-    (seq p (many p))
+    (lazy (seq p (lazy (many p))))
     Iso.cons
+(* SOME p *)
 
 (* for left-associative chain of operators *)
-let chainl1 (arg : 'a t) (op : 'b t) (f : ('a * ('b * 'a), 'a) Iso.t) : 'a t =
+let chainl1 (arg : 'a t Lazy.t) (op : 'b t Lazy.t) (f : ('a * ('b * 'a), 'a) Iso.t) : 'a t =
   map
-    (seq arg (many (seq op arg)))
+    (lazy (seq arg (lazy (many (lazy (seq op arg))))))
     (Iso.fold_left f)
+(* CHAIN1 arg SEP op -> f *)
 
-
-let prefix (pre : unit t) (p : 'a t) : 'a t =
+let prefix (pre : unit t Lazy.t) (p : 'a t Lazy.t) : 'a t =
   map
-    (seq pre p)
+    (lazy (seq pre p))
     (Iso.seq Iso.comm (Iso.inverse Iso.unit))
+(* 'pre; p *)
 
-let suffix (p : 'a t) (suf : unit t) : 'a t =
+let suffix (p : 'a t Lazy.t) (suf : unit t Lazy.t) : 'a t =
   map
-    (seq p suf)
+    (lazy (seq p suf))
     (Iso.inverse Iso.unit)
+(* p; 'suf *)
 
-let between (pre : unit t) (p : 'a t) (suf : unit t) : 'a t =
-  prefix pre (suffix p suf)
+let between (pre : unit t Lazy.t) (p : 'a t Lazy.t) (suf : unit t Lazy.t) : 'a t =
+  prefix pre (lazy (suffix p suf))
+(* 'pre; p; 'suf *)
 
-let list1 (sep : unit t) (p : 'a t) : 'a list t =
+let list1 (sep : unit t Lazy.t) (p : 'a t Lazy.t) : 'a list t =
   map
-    (seq p (many (prefix sep p)))
+    (lazy (seq p (lazy (many (lazy (prefix sep p))))))
     Iso.cons
-
+(* LIST1 p SEP sep *)
 
 let token : char t =
   object
     method print c =
       MOption.some (String.make 1 c)
   end
+(* token *)
 
 class text (w : string) : [unit] t =
   object
       MOption.some w
   end
 let text w = new text w
+(* "w" *)
 
 let skip_space : unit t =
   object
       MOption.some " "
   end
 
+
+type 'a lazy_t = 'a t Lazy.t
+
+module Lazy =
+  struct
+    type 'a t = 'a lazy_t
+
+    let close p = lazy (close p)
+    let map p f = lazy (map p f)
+    let seq p q = lazy (seq p q)
+    let alt p q = lazy (alt p q)
+    let pure e = lazy (pure e)
+    let either p q = lazy (either p q)
+    let many p = lazy (many p)
+    let some p = lazy (some p)
+    let chainl1 arg op f = lazy (chainl1 arg op f)
+    let prefix pre p = lazy (prefix pre p)
+    let suffix p suf = lazy (suffix p suf)
+    let between pre p suf = lazy (between pre p suf)
+    let list1 sep p = lazy (list1 sep p)
+    let token = Lazy.lazy_from_val token
+    let text w = lazy (text w)
+    let skip_space = Lazy.lazy_from_val skip_space
+    let opt_space = Lazy.lazy_from_val opt_space
+    let sep_space = Lazy.lazy_from_val sep_space
+  end
 
 type id = int (* >0 for terms, <0 for idents *)
 
-let h_term2id : (string,id) Hashtbl.t = Hashtbl.create 100
-let h_ident2id : (string,id) Hashtbl.t = Hashtbl.create 100
+let h_s2id : (string,id) Hashtbl.t = Hashtbl.create 100
     
 let h_id2s : (id,string) Hashtbl.t = Hashtbl.create 100
 
-let term_exists s = Hashtbl.mem h_term2id s
+let exists s = Hashtbl.mem h_s2id s
 
-let ident_exists s = Hashtbl.mem h_ident2id s
-
-let term2id s =
-  try Hashtbl.find h_term2id s
+let s2id s =
+  try Hashtbl.find h_s2id s
   with Not_found ->
     incr cpt;
     let id = !cpt in
-    Hashtbl.add h_term2id s id;
-    Hashtbl.add h_id2s id s;
-    id
-
-let ident2id s =
-  try Hashtbl.find h_ident2id s
-  with Not_found ->
-    incr cpt;
-    let id = - !cpt in
-    Hashtbl.add h_ident2id s id;
+    Hashtbl.add h_s2id s id;
     Hashtbl.add h_id2s id s;
     id
 
 (* rename a term/ident *)
 let rename : int -> string -> unit =
   fun id s ->
-    if id > 0
-    then begin
-      assert (not (Hashtbl.mem h_term2id s));
-      let old_term = Hashtbl.find h_id2s id in
-      Hashtbl.remove h_term2id old_term;
-      Hashtbl.add h_term2id s id;
-      Hashtbl.replace h_id2s id s end
-    else begin
-      assert (not (Hashtbl.mem h_ident2id s));
-      let old_ident = Hashtbl.find h_id2s id in
-      Hashtbl.remove h_ident2id old_ident;
-      Hashtbl.add h_ident2id s id;
-      Hashtbl.replace h_id2s id s
-    end
+    assert (not (Hashtbl.mem h_s2id s));
+    let old_s = Hashtbl.find h_id2s id in
+    Hashtbl.remove h_s2id old_s;
+    Hashtbl.add h_s2id s id;
+    Hashtbl.replace h_id2s id s
 
 (* load and save *)
 
 let init () =
   cpt := 0;
   Hashtbl.clear h_id2s;
-  Hashtbl.clear h_term2id;
-  Hashtbl.clear h_ident2id;
+  Hashtbl.clear h_s2id;
   Hashtbl.clear tbl
 
 let load (t : data) =
   List.iter
     (fun (id,s) ->
       Hashtbl.add h_id2s id s;
-      if id > 0
-      then Hashtbl.add h_term2id s id
-      else Hashtbl.add h_ident2id s id)
+      Hashtbl.add h_s2id s id)
     t.id2s;
   List.iter
     (fun (id,x) ->
 (* predicate filtering PP_* tokens *)
 let is_PP = function PP_tilda | PP_space | PP_cut | PP_break _ | PP_newline -> true | _ -> false
 
-(* get the precision of a float number from its writing *)
-let prec_of_sfloat : string -> int =
-  fun s ->
-      let l = String.length s in
-      let i_dot =
-        try String.index s '.'
-        with Not_found -> try String.index s 'e' - 1
-        with Not_found -> l - 1 in
-      let i_e,p =
-        try
-          let i_e = String.index s 'e' in
-          i_e,
-          match s.[i_e+1] with
-          | '+' -> int_of_string (String.sub s (i_e+2) (l-(i_e+2)))
-          | _ -> int_of_string (String.sub s (i_e+1) (l-(i_e+1)))
-        with Not_found -> l, 0 in
-      p - (i_e - (i_dot+1))
-
 (* predicate for testing whether a symbol needs quotes *)
 let symbol_needs_quotes s =
   let is_ident = Str.string_match (Str.regexp "^[A-Za-z_][A-Za-z0-9_]*$") s 0 in
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.