Commits

Sébastien Ferré  committed e850a59

Handling of files, by optimizing based on cuts.
Improvement on state of parsers.

  • Participants
  • Parent commits c2672eb

Comments (0)

Files changed (1)

 
 type ('ctx, 'res, 'cursor, 'msg) parse = 'ctx -> 'cursor -> ('ctx, 'res, 'cursor, 'msg) p
 
-let null =
-  object
-    method next = Failed []
-  end
-
 class ['ctx,'res,'cursor,'msg] fail (cursor : 'cursor) =
   object (self)
     method next : ('cursor, 'ctx, 'res, 'msg) result =
 
 class ['ctx, 'res0, 'res, 'cursor, 'msg] map (parse : ('ctx, 'res0, 'cursor, 'msg) parse) (f : 'res0 -> 'res) (ctx : 'ctx) (cursor : 'cursor) =
   object (self)
-    val mutable p = parse ctx cursor
+    val mutable state = `Begin (parse ctx cursor)
 
     method next =
-      match p # next with
-      | Parsed (ctx1, res0, cursor') ->
-	  Parsed (ctx1, f res0, cursor')
-      | Failed msgs ->
-	  p <- null; (* to help GC *)
-	  Failed msgs
+      match state with
+      | `Begin p ->
+	  ( match p # next with
+	  | Parsed (ctx1, res0, cursor') ->
+	      Parsed (ctx1, f res0, cursor')
+	  | Failed msgs ->
+	      state <- `End msgs;
+	      self#next)
+      | `End msgs -> Failed msgs
   end
 
 let map = new map
 
 class ['ctx, 'res, 'cursor, 'msg] alt (parse1 : ('ctx, 'res, 'cursor, 'msg) parse) (parse2 : ('ctx, 'res, 'cursor, 'msg) parse) (ctx : 'ctx) (cursor : 'cursor) =
   object (self)
-    val mutable state = `First
-    val mutable p = parse1 ctx cursor
-    val mutable msgs = []
+    val mutable state = `First (parse1 ctx cursor)
 
     method next =
       match state with
-      | `First ->
-	  ( match p # next with
+      | `First p1 ->
+	  ( match p1 # next with
 	  | Parsed _ as x -> x
 	  | Failed msgs1 ->
-	      state <- `Second;
-	      p <- parse2 ctx cursor;
-	      msgs <- msgs1 @ msgs;
+	      state <- `Second (msgs1, parse2 ctx cursor);
 	      self # next)
-      | `Second ->
-	  ( match p # next with
+      | `Second (msgs, p2) ->
+	  ( match p2 # next with
 	  | Parsed _ as x -> x
 	  | Failed msgs2 ->
-	      state <- `End;
-	      p <- null; (* to help GC *)
-	      msgs <- msgs2 @ msgs;
+	      state <- `End (msgs2 @ msgs);
 	      self # next)
-      | `End ->
-	  Failed msgs
+      | `End msgs -> Failed msgs
   end
 
 let alt = new alt
 
 class ['ctx, 'res1, 'res, 'cursor, 'msg] seq (parse1 : ('ctx,'res1,'cursor,'msg) parse) (parse2 : 'res1 -> ('ctx,'res,'cursor,'msg) parse) (ctx : 'ctx) (cursor : 'cursor) =
   object (self)
-    val mutable state = `First
-    val mutable p1 = parse1 ctx cursor
-    val mutable p2_opt = None (* delaying the creation of p2 because of possible loops *)
-    val mutable msgs = []
+    val mutable state = `First ([], parse1 ctx cursor)
 
     method next =
       match state with
-      | `First ->
+      | `First (msgs, p1) ->
 	  ( match p1 # next with
 	  | Parsed (ctx1, res1, cursor1) ->
-	      state <- `Second;
-	      p2_opt <- Some (parse2 res1 ctx1 cursor1);
+	      state <- `Second (msgs, p1, parse2 res1 ctx1 cursor1);
 	      self # next
 	  | Failed msgs1 ->
-	      state <- `End;
-	      p1 <- null;
-	      msgs <- msgs1 @ msgs;
+	      state <- `End (msgs1 @ msgs);
 	      self # next)
-      | `Second ->
-	  ( match p2_opt with
-	  | Some p2 ->
-	      ( match p2 # next with
-	      | Parsed _ as x -> x
-	      | Failed msgs2 ->
-		  state <- `First;
-		  p2_opt <- None;
-		  msgs <- msgs2 @ msgs;
-		  self # next)
-	  | None -> assert false)
-      | `End -> Failed msgs
+      | `Second (msgs, p1,p2) ->
+	  ( match p2 # next with
+	  | Parsed _ as x -> x
+	  | Failed msgs2 ->
+	      state <- `First (msgs2 @ msgs, p1);
+	      self # next)
+      | `End msgs -> Failed msgs
   end
 
 let seq = new seq
 
 class ['ctx,'res1,'res,'cursor,'msg] cut (parse1 : ('ctx,'res1,'cursor,'msg) parse) (parse2 : 'res1 -> ('ctx,'res,'cursor,'msg) parse) (parse3 : ('ctx,'res,'cursor,'msg) parse) (ctx : 'ctx) (cursor : 'cursor) =
   object (self)
-    val mutable state = `First
-    val mutable p1 = parse1 ctx cursor
-    val mutable p_opt = None
+    val mutable state = `First (parse1 ctx cursor)
 
     method next =
       match state with
-      | `First ->
+      | `First p1 ->
 	  ( match p1 # next with
 	  | Parsed (ctx1, res1, cursor1) ->
-	      state <- `Second;
-	      p_opt <- Some (parse2 res1 ctx1 cursor1);
+	      if cursor#at_init then cursor1#init; (* forgetting the past *)
+	      state <- `Second (parse2 res1 ctx1 cursor1);
 	      self # next
-	  | Failed _ ->
-	      state <- `Third;
-	      p_opt <- Some (parse3 ctx cursor);
+	  | Failed msgs1 ->
+	      state <- `Third (msgs1, parse3 ctx cursor);
 	      self # next)
-      | `Second ->
-	  ( match p_opt with
-	  | Some p -> 
-	      ( match p # next with
-	      | Parsed _ as x -> x
-	      | Failed _ as x ->
-		  state <- `End;
-		  p_opt <- None;
-		  p1 <- null;
-		  x)
-	  | None -> assert false)
-      | `Third ->
-	  ( match p_opt with
-	  | Some p ->
-	      ( match p # next with
-	      | Parsed _ as x -> x
-	      | Failed _ as x ->
-		  state <- `End;
-		  p_opt <- None;
-		  p1 <- null;
-		  x)
-	  | None -> assert false)
-      | `End -> Failed ([] : 'msg list)
+      | `Second p2 ->
+	  ( match p2 # next with
+	  | Parsed _ as x -> x
+	  | Failed msgs2 ->
+	      state <- `End msgs2;
+	      self#next)
+      | `Third (msgs, p3) ->
+	  ( match p3 # next with
+	  | Parsed _ as x -> x
+	  | Failed msgs3 ->
+	      state <- `End (msgs3 @ msgs);
+	      self#next)
+      | `End msgs -> Failed msgs
   end
 
 let cut = new cut
    if p1 then p2 else p3 ==> cut p1 (fun _ -> p2) p3
 *)
 
-class ['ctx,'res,'cursor,'msg] guard (parse : ('ctx,'res,'cursor,'msg) parse) (name : string) (pred : 'res -> bool) (ctx : 'ctx) (cursor : 'cursor) =
+class ['ctx,'res,'cursor,'msg] guard (parse1 : ('ctx,'res,'cursor,'msg) parse) (name : string) (pred : 'res -> bool) (ctx : 'ctx) (cursor : 'cursor) =
   object (self)
-    val mutable p = parse ctx cursor
+    val mutable state = `Begin ([], parse1 ctx cursor)
 
     method next =
-      match p # next with
-      | Parsed (ctx1, res1, cursor1) as x ->
-	  if pred res1
-	  then x
-	  else self # next
-      | Failed msgs ->
-	  p <- null;
-	  let coord = cursor#coord in
-	  let msg = Msg.make name [||] (Msg.Locator.Point coord) in
-	  Failed (msg::msgs)
+      match state with
+      | `Begin (msgs, p1) ->
+	  ( match p1 # next with
+	  | Parsed (ctx1, res1, cursor1) as x ->
+	      if pred res1
+	      then x
+	      else begin
+		let coord = cursor#coord in
+		let msg = Msg.make name [||] (Msg.Locator.Point coord) in
+		state <- `Begin (msg::msgs, p1);
+		self # next
+	      end
+	  | Failed msgs1 ->
+(*
+	      let coord = cursor#coord in
+	      let msg = Msg.make name [||] (Msg.Locator.Point coord) in
+*)
+	      state <- `End (msgs1 @ msgs);
+	      self#next)
+      | `End msgs -> Failed msgs
   end
 
 let guard = new guard
   match p # next with
   | Parsed (ctx, x, _) -> ctx, x
   | Failed [] ->
-      raise (SyntaxError (0,0,"Syntax error"))
+      raise (SyntaxError (1,1,"Syntax error"))
   | Failed (msg::msgs) ->
       let (line, col), best_msg =
 	List.fold_left
 	  (fun (best_coord, best_msg) msg ->
 	    let coord = Msg.Locator.start msg.Msg.loc in
-	    if best_coord < coord
-	    then (coord, msg)
+	    if best_coord < coord then (coord, msg.Msg.phrase)
+	    else if best_coord = coord then (best_coord, msg.Msg.phrase ^ "; " ^ best_msg)
 	    else (best_coord, best_msg))
-	  (Msg.Locator.start msg.Msg.loc, msg)
+	  (Msg.Locator.start msg.Msg.loc, msg.Msg.phrase)
 	  msgs in
-      raise (SyntaxError (line, col, Msg.toString best_msg))
+      raise (SyntaxError (line, col, best_msg))
 
 (* returns all parsing results *)
 let all parse ctx cursor =