Commits

camlspotter  committed 22a168b Merge

update and complete pa expand

  • Participants
  • Parent commits 7f3530d, 4a2a99b
  • Branches p4hack

Comments (0)

Files changed (14)

     sexplib
     spotlib
 
-# OCAMLDEPFLAGS= -syntax camlp4o -package sexplib.syntax
-# OCAMLPPFLAGS= -syntax camlp4o -package sexplib.syntax
+%.out.ml: %.ml pa_bind_inline/pa_bind_inline.cmo
+	camlp4o -printer OCaml pa_bind_inline/pa_bind_inline.cmo $< > $@
+
 OCAMLDEPFLAGS= -syntax camlp4o -package sexplib.syntax -ppopt pa_bind_inline/pa_bind_inline.cmo
 OCAMLPPFLAGS= -syntax camlp4o -package sexplib.syntax -ppopt pa_bind_inline/pa_bind_inline.cmo
 
    pbase
 #   pbaseexn
 #   pbaseref
+#   pbasetpl
    pchar
    pbuffer
    pmemo

File ocaml/lex.ml

       if src >= l then
         if dst >= l then s else String.sub s 0 dst
       else
-        match s.[src] with
+        match String.unsafe_get s src with
           '_' -> remove (src + 1) dst
-        |  c  -> s.[dst] <- c; remove (src + 1) (dst + 1)
+        |  c  -> String.unsafe_set s dst c; remove (src + 1) (dst + 1)
     in remove 0 0
 
   let char_for_backslash = function
 let char_internal = 
   (perform
      s <-- matched newline;
-     return s.[0] (* Funny that only the first char is used *))
+     return (String.unsafe_get s 0) (* Funny that only the first char is used *))
   <|> tokenp (function '\\' | '\'' | '\010' | '\013' -> false
                      | _ -> true)
   <|> (* '\\' case *)
        <!> (matched (token '*' >>= fun _ -> ignore (takeWhile  is_symbolchar)) >>= function
               | "*" -> return_with_pos STAR
               | s ->
-                  if s.[1] = '*' then return_with_pos (INFIXOP4 s) (* ** case *)
+                  if String.unsafe_get s 1 = '*' then return_with_pos (INFIXOP4 s) (* ** case *)
                   else return_with_pos (INFIXOP3 s)))
 
   <|> (* case of '#' *)

File ocaml/lextest.ml

 open Planck
 
 let rec parse_and_print stream = 
-  match (Input.Parser.eos_as_none Lex.ocaml_token) stream with
+  match Input.Parser.run (Input.Parser.eos_as_none Lex.ocaml_token) stream with
   | Result.Ok (None, _) -> () (* EOS *)
   | Result.Ok (Some (v, pos), stream') ->
       let show t = Sexplib.Sexp.to_string_hum (Token.sexp_of_t t) in

File ocaml/parsertest.ml

   let parse = new Plparser.rules in
   try
     match Token.Parser.run parse#implementation stream with
-    | Result.Ok v -> (Obj.magic v : Xparsetree.structure)
+    | Result.Ok (v, _st') -> (Obj.magic v : Xparsetree.structure)
     | Result.Error (pos, s) -> 
         Format.eprintf "%a: syntax error: %s@." Position.Region.format pos s;
         raise Exit
   let parse = new Plparser.rules in
   try
     match Token.Parser.run parse#interface stream with
-    | Result.Ok v -> (Obj.magic v : Xparsetree.signature)
+    | Result.Ok (v, _st') -> (Obj.magic v : Xparsetree.signature)
     | Result.Error (pos, s) -> 
         Format.eprintf "%a: syntax error: %s@." Position.Region.format pos s;
         raise Exit

File ocaml/plparser.ml

   mkexp(Pexp_apply(mkoperator name 2, ["", arg1; "", arg2]))
 
 let neg_float_string f =
-  if String.length f > 0 && f.[0] = '-'
+  if String.length f > 0 && String.unsafe_get f 0 = '-'
   then String.sub f 1 (String.length f - 1)
   else "-" ^ f
 

File ocaml/plphelper.ml

 *)
 
 let rule (name : string) (m : unit -> ('a * Position.Region.t) Token.Parser.t) : 'a Token.Parser.t = 
-<<<<<<< local
-  with_rhs name (memoize name (m ()))
-||||||| base
-  fun st -> with_rhs name (memoize name (m ())) st
-=======
   (* This eta is required to avoid inf loop and segfault by stack overflow *) 
   fun st -> with_rhs name (memoize name (m ())) st
->>>>>>> other
 
 let get_poses () = 
   match !rhs_tbl_stack with
       in
       fold [] (!rhs_counter - 1)
 
-<<<<<<< base
-=======
-(*
->>>>>>> other
-let case (name : string) (t : (unit -> 'a) Token.Parser.t) : ('a * Planck.Position.Region.t) Token.Parser.t = fun st -> 
-<<<<<<< base
-=======
-  Profile.incr ();
-  if !do_debug then prerr_endline (String.make (!level*2) ' ' ^ "-> " ^ name);
-  let st_start = if !do_debug then Some st else None in (* Make [st] GCed as early as possible *) 
-
-  incr level;
-
-  let t = perform
-    last_pos <-- last_position; (* bad for nonleftrec... *)
-    f <-- t;
-    let poses = get_poses () in
-    (* action require symbol_rloc_ref is set *)
-    let symbol_rloc = calc_symbol_rloc last_pos poses in 
-    \ symbol_rloc_ref := symbol_rloc;
-    return (f (), 
-            calc_rhs_loc last_pos poses)
-  in
-
-  (result t >>= fun res ->
-   
-   decr level;
-
-   match res with
-   | Result.Ok (_, rhs_loc as v) -> 
-       if !do_debug then begin perform
-         st' <-- stream;
-         \ begin match st_start with
-         | None -> assert false
-         | Some st -> 
-             let elts = List.map fst (Token.Stream.between st st') in
-             Format.eprintf "%s<- %s : %s@."
-               (String.make (!level*2) ' ') 
-               name 
-               (Sexplib.Sexp.to_string_hum (Sexplib.Conv.sexp_of_list Token.sexp_of_t elts));
-             Format.eprintf "%s   symbol_rloc: %a@."
-               (String.make (!level*2) ' ') 
-              Planck.Position.Region.format !symbol_rloc_ref;
-             Format.eprintf "%s   rhs_loc:     %a@."
-               (String.make (!level*2) ' ') 
-               Planck.Position.Region.format rhs_loc;
-             match !rhs_tbl_stack with
-             | [] -> assert false
-             | (rhs_counter, rhs_tbl, _) :: _ ->
-                 for i = 1 to !rhs_counter-1 do
-                   Format.eprintf "%s   %d : %a@."
-                     (String.make (!level*2) ' ') 
-                     i
-                     Planck.Position.Region.format 
-                     (try Hashtbl.find rhs_tbl i with Not_found -> Position.Region.none);
-                 done;
-                 Format.eprintf "%s   END@." (String.make (!level*2) ' ') 
-         end;
-         return v
-       end else return v
-
-  | Result.Error err ->
-      if !do_debug then prerr_endline (String.make (!level*2) ' ' ^ "X- " ^ name);
-      throw err
-
-  ) st
-*)
 let case (name : string) (t : (unit -> 'a) Token.Parser.t) : ('a * Planck.Position.Region.t) Token.Parser.t = fun st -> 
   Profile.incr ();
->>>>>>> other
   if !do_debug then prerr_endline (String.make (!level*2) ' ' ^ "-> " ^ name);
   let st_start = if !do_debug then Some st else None in (* Make [st] GCed as early as possible *) 
 
           NEW NATIVEINT PREFIXOP STRING TRUE UIDENT
 *)
     | _ -> 
-        match op.[0] with
+        match String.unsafe_get op 0 with
         | '!' | '~' | '?' -> { prec = 100.0; kind = `Prefix }
         | '=' | '<' | '>' | '|' | '&' | '$' -> infixop0
         | '@' | '^' -> infixop1

File ocaml/token.ml

   (* CR jfuruse: generalize it and port back to Planck.Core *)
   let create (m : ('a option * Position.Region.t) Input.Parser.t) = fun st ->
     let rec f last_pos st = lazy begin
-      match m st with
+      match Input.Parser.run m st with
       | Result.Ok ((None, pos), _st') -> null_desc (last_pos, pos, Smemo.create 107) (* EOS case *)
       | Result.Ok ((Some v, pos), st') -> cons_desc v (last_pos, pos, Smemo.create 107) (f (Some pos) st')
       | Result.Error (pos, s) -> raise (Input.Parser.Critical_error (pos, s))

File pa_bind_inline/pa_bind_inline.ml

                  | Error s -> Error s
           *)
           <:expr< fun st__ -> 
-            Profile.incr ();
+            (* Profile.incr (); *)
             match $t$ st__ with 
             | Result.Ok ($lid:x$, $lid:st$) -> $e$
             | (Result.Error _ as res) -> Obj.magic res >>
                  | Error s -> Error s
           *)
           <:expr< fun st__ -> 
-            Profile.incr ();
+            (* Profile.incr (); *)
             match $t$ st__ with 
             | Result.Ok ($lid:x$, $lid:st$) -> $e$
             | (Result.Error _ as res) -> Obj.magic res >>
                  | Error s -> Error s
           *)
           <:expr< fun st__ -> 
-            Profile.incr ();
+            (* Profile.incr (); *)
             match $t$ st__ with 
             | Result.Ok ($lid:x$, st__') -> $e$ st__'
             | (Result.Error _ as res) -> Obj.magic res >>
                  | Error s -> Error s         <--- Use Obj.magic to avoid creating a new block
           *)
           <:expr< fun st__ -> 
-            Profile.incr ();
+            (* Profile.incr (); *)
             match $t$ st__ with 
             | Result.Ok (r__, st__') -> $f$ r__ st__'
             | (Result.Error _ as res) -> Obj.magic res >>
   
     (* return v st = Ok (v, st) *)
-    let return _loc t = <:expr< fun st__ -> Profile.incr (); Result.Ok ($t$, st__) >>
+    let return _loc t = <:expr< fun st__ -> (* Profile.incr (); *) Result.Ok ($t$, st__) >>
     let return_st _loc t st = <:expr< Result.Ok ($t$, $st$) >>
 
 (*
         | <:expr@_loc< (<|>) dummy $t$ >>-> t
         | <:expr@_loc< $lid:x$ $t$ $f$ >> when x = "<|>" -> (<|>) _loc t f
         | <:expr@_loc< __must_be_unit; $t$ >>-> t
+        | <:expr@_loc< Profile.incr (); $e$ >>-> <:expr< (); $e$ >>
         | x -> x
     end
     in AstFilters.register_str_item_filter simplify#str_item
   end
 
   type param = Str.t
-  type 'a result = ('a * Str.t, error) Result.t
+  type +'a result = ('a * Str.t, error) Result.t 
 
   include Monad.Make(struct 
 
   let error s : 'a t = fun st -> Profile.incr (); Error (Str.position st, s)
   let throw err = fun _st -> Profile.incr (); Error err
 
-  let critical_error pos s = Profile.incr (); raise (Critical_error (pos, s))
-
-  let throw e : 'a t = fun _st -> Profile.incr (); Error e
+  let critical_error pos s = raise (Critical_error (pos, s))
 
   let stream : Str.t t = fun st -> Profile.incr (); Ok (st, st)
 
 
   let set_stream new_st _st = Profile.incr (); Ok ((), new_st)
 
-  let run : 'a t -> Str.t -> ('a, error) Result.t = fun t st ->
-    Profile.incr ();
-    match t st with
-    | Ok (v, _) -> Ok v
-    | Error err -> Error err
+  let run : 'a t -> Str.t -> ('a * Str.t, error) Result.t = fun t st ->
+    t st
 end
   with type Str.elem = S.elem
   and  module Str.Pos = S.Pos
   and  type Str.attr = S.attr
-  and  type param = S.t
-
+  and  type 'a t = S.t -> ('a * S.t, S.Pos.t * string) Result.t
       wasted := !all_wasted
   end
 
-  type param = Str.t
-  type 'a result = 'a * Str.t
-
   include Monad.Make(struct 
 
     type 'a t = Str.t -> 'a * Str.t
 
   let set_stream new_st _st = ok ((), new_st)
 
-  let run t st = try Ok (fst (t st)) with Exn err -> Error err
+  let run t st = try Ok (t st) with Exn err -> Error err
 end
       wasted := !all_wasted
   end
 
-  type param = unit
-  type 'a result = 'a
-
   include Monad.Make(struct 
 
     type 'a t = unit -> 'a
 
   let run t st = 
     set st;
-    try Ok (t ()) with Exn err -> Error err
+    try let res = t () in Ok (res, get ()) with Exn err -> Error err
 end
+open Spotlib.Spot
+open Planck_intf
+open Result
+
+module Make(Str : Stream_intf.S) = struct
+  module Str = Str
+
+  type error = Str.Pos.t * string
+  exception Critical_error of error
+
+  module Profile = struct
+    let all_total = ref 0
+    let all_wasted = ref 0
+    let total = ref 0
+    let wasted = ref 0
+    let top_ref = ref (ref 0)
+    let stack = ref [!top_ref]
+    let start () = 
+      top_ref := ref 0;
+      stack := !top_ref :: !stack
+    let stop () = 
+      match !stack with
+      | r::r'::rs -> 
+          top_ref := r';
+          stack := (r'::rs); 
+          !r
+      | _ -> assert false
+    let incr () =
+      incr total;
+      incr !top_ref
+
+    let add n =
+      !top_ref := !(!top_ref) + n
+
+    let format ppf = 
+      Format.fprintf ppf "Bind total %d, wasted %d, ratio %f"
+        !total !wasted (float !wasted /. float !total)
+
+    let reset () =
+      all_total := !all_total + !total;
+      all_wasted := !all_wasted + !wasted;
+      top_ref := ref 0;
+      total := 0;
+      wasted := 0;
+      stack := [!top_ref]
+
+    let recover_all () =
+      reset ();
+      total := !all_total;
+      wasted := !all_wasted
+  end
+
+  type 'a monad = 
+    | Return of (Str.t -> ('a * Str.t, error) Result.t)
+    | Bind of Obj.t monad * (Obj.t -> 'a monad) (* nasty hack *)
+  
+  include Monad.Make(struct 
+
+    type 'a t = 'a monad
+
+    let return v = Return (fun st -> Ok (v, st))
+  
+    let bind (t : 'a t) (f : 'a -> 'b t) = Bind (Obj.magic t, Obj.magic f)
+  end)
+
+  open Open
+
+  let rec run : 'a t -> Str.t -> ('a * Str.t, error) Result.t = fun t st ->
+    match t with
+    | Return f -> f st
+    | Bind (m, f) ->
+        match run (Obj.magic m) st with
+        | Ok (o, st') -> run ((Obj.magic f) o) st'
+        | Error err -> Error err
+
+  let result : 'a t -> ('a, error) Result.t t = fun c -> Return (fun st ->
+    Profile.incr ();
+    match run c st with
+    | Ok (res, st) -> Ok (Ok res, st)
+    | Error e -> Ok (Error e, st))
+
+  let take : Str.elem t = Return (fun s -> 
+    Profile.incr ();
+    match Str.peek s with
+    | None -> Error (Str.position s, "unexpected end of stream")
+    | Some (elem, _pos, s') -> Ok (elem, s'))
+
+  let take_ : unit t = Return (fun s -> 
+    Profile.incr ();
+    match Str.peek s with
+    | None -> Error (Str.position s, "unexpected end of stream")
+    | Some (_, _, s') -> Ok ((),s'))
+
+  let position : Str.Pos.t t = Return (fun st -> Profile.incr (); Ok (Str.position st, st))
+
+  let error s : 'a t = Return (fun st -> Profile.incr (); Error (Str.position st, s))
+  let throw err = Return (fun _st -> Profile.incr (); Error err)
+
+  let critical_error pos s = raise (Critical_error (pos, s))
+
+  let stream : Str.t t = Return (fun st -> Profile.incr (); Ok (st, st))
+
+  let eos : unit t = Return (fun s -> 
+    Profile.incr ();
+    match Str.peek s with
+    | Some _ -> Error (Str.position s, "end of stream expected")
+    | None -> Ok ((), s))
+
+  let (<?>) : 'a t -> string -> 'a t = fun c mes -> 
+    result c >>= function
+      | Ok v -> return v
+      | Error (pos, _) -> throw (pos, "expected " ^ mes)
+
+  let (<?!>) : 'a t -> string -> 'a t = fun c mes -> 
+    result c >>= function
+      | Ok v -> return v
+      | Error (pos, _) -> throw (pos, mes)
+
+  let (<?@>) : 'a t -> Str.Pos.t -> 'a t = fun c pos -> 
+    result c >>= function
+      | Ok v -> return v
+      | Error (_, mes) -> throw (pos, mes)
+
+  (* [take] advances the stream. If we use [take] and some predicate to check the result,
+     the error position must be fixed as the one at the use of [take]. *)
+
+  let tokenp : (Str.elem -> bool) -> Str.elem t = fun p ->
+    position >>= fun pos ->
+    take >>= fun elem -> if p elem then return elem else error "tokenp" <?@> pos
+
+  let token_option : (Str.elem -> 'a option) -> 'a t = fun p ->
+    position >>= fun pos ->
+    take >>= fun elem -> 
+    match p elem with
+    | Some v -> return v
+    | None -> error "tokenop" <?@> pos
+
+  let token_result : (Str.elem -> ('a, string) Result.t) -> 'a t = fun p ->
+    position >>= fun pos ->
+    take >>= fun elem ->
+    match p elem with
+    | Ok v -> return v
+    | Error err -> error err <?@> pos
+
+  let token : Str.elem -> unit t = fun tkn ->
+    ignore (tokenp (fun x -> Str.equal_elem tkn x)) <?>  Str.show_elem tkn
+
+  (* CR jfuruss: optimization oppotunity for char *)     
+  let one_of : Str.elem list -> Str.elem t = fun tkns ->
+    tokenp (fun x -> List.exists (Str.equal_elem x) tkns)
+    <?> Printf.sprintf "expected one of %s"
+         (String.concat " " (List.map Str.show_elem tkns))
+
+  let tokens : Str.elem list -> unit t = fun elems -> 
+    let rec aux = function
+      | [] -> return ()
+      | x::xs ->
+          take >>= fun y ->
+          if Str.equal_elem x y then aux xs
+          else error (Printf.sprintf "expected %s" (Str.show_elem x))
+    in
+    aux elems
+  
+  let option : 'a t -> 'a option t = fun com -> 
+    result com >>= function
+      | Error _ -> return None
+      | Ok v -> return (Some v)
+
+  let option_ : unit t -> unit t = fun com -> ignore (result com)
+
+  let try_finally : 'a t -> (('a, error) Result.t -> unit) -> 'a t = fun c f -> 
+    result c >>= fun res ->
+    f res;
+    match res with
+    | Ok v -> return v
+    | Error err -> throw err
+
+  let ( ?** ) : 'a t -> 'a list t = fun com ->
+    let rec aux st = 
+      result com >>= function
+        | Error _ -> return (List.rev st)
+        | Ok v -> aux (v :: st)
+    in
+    aux []
+  
+  let ( ?* ) : 'a t -> unit t = fun com ->
+    let rec aux () = 
+      result com >>= function
+        | Error _ -> return ()
+        | Ok _ -> aux ()
+    in
+    aux ()
+  
+  let (?++) : 'a t -> 'a list t = fun com ->
+    com >>= fun v -> 
+    ?** com >>= fun vs -> 
+    return (v :: vs)
+  
+  let (?+) : 'a t -> unit t = fun com ->
+    com >>= fun _v -> 
+    ?* com >>= fun () -> 
+    return ()
+
+  let list_with_sep ?(optional_head=false) ~sep t = 
+    (if optional_head then option_ sep else return ()) >>= fun () ->
+    t >>= fun v -> 
+    ?** (sep >>= fun () -> t) >>= fun vs ->
+    return (v :: vs)
+
+  let surrounded left right content =
+    left >>= fun _ ->
+    content >>= fun res ->
+    right >>= fun _ ->
+    return res
+  
+  let critical : 'a t -> 'a t = fun t -> 
+    result t >>= function
+      | Ok v -> return v
+      | Error (pos, s) -> raise (Critical_error (pos, s))
+
+  let (<|>) : 'a t -> 'a t -> 'a t = fun c1 c2 -> 
+    position >>= fun pos0 ->
+    result c1 >>= function
+      | Ok v -> return v
+      | Error (pos, _ as err) -> if pos = pos0 then c2 else throw err
+
+  let (<!>) : 'a t -> 'a t -> 'a t = fun c1 c2 -> 
+    position >>= fun pos ->
+    Profile.start ();
+    result c1 >>= function
+      | Ok v ->
+          Profile.add (Profile.stop ());
+          return v
+      | Error (pos', _) -> 
+          if pos = pos' then Profile.add (Profile.stop ())
+          else begin
+            Profile.wasted := !Profile.wasted + Profile.stop ();
+          end;
+          c2
+
+  (* CR jfuruse: _ is used in a different meaning than option_ *)
+  let try_ : 'a t -> 'a t = fun c -> Return (fun st ->
+    Profile.incr ();
+    let pos0 = Str.position st in
+    let res = run c st in
+    match res with
+    | Ok _ -> res
+    | Error (_, err) -> Error (pos0, err))
+
+  let (<<>) : 'a t -> 'a t -> 'a t = fun c1 c2 -> Return (fun st ->
+    Profile.incr ();
+    let pos = Str.position st in
+    let res1 = run c1 st in
+    match res1 with
+    | Ok _ -> 
+        Profile.add (Profile.stop ());
+        res1
+    | Error (pos', _) ->
+        let binds_in_c1 = Profile.stop () in
+        Profile.start (); 
+        let res2 = run c2 st in
+        match res2 with
+        | Ok _ -> 
+            if pos = pos' then Profile.add binds_in_c1
+            else Profile.wasted := !Profile.wasted + binds_in_c1;
+            res2
+        | Error (pos'', _) -> 
+            if pos' = pos'' then Profile.add (Profile.stop ())
+            else Profile.wasted := !Profile.wasted + Profile.stop ();
+            res1)
+
+  let eos_as_none : 'a t -> 'a option t = fun t ->
+    (eos >>= fun _ -> return None)
+    <|> (t >>= fun x -> return (Some x))
+
+  (* Used for push back *)          
+  let (<&>) : 'a t -> ('a -> 'b t) -> 'b t = fun c1 c2 -> 
+    Return (fun st ->
+      Profile.incr ();
+      match run c1 st with
+      | Ok (v, _) -> run (c2 v) st
+      | (Error _ as res) -> res)
+
+
+  let rec (/**/) : 'a list t -> 'a list t -> 'a list t = fun c1 c2 ->
+    (c1 >>= fun x -> (/**/) c1 c2 >>= fun y -> return (x @ y)) <!> c2
+        
+  let rec ( /*/ ) : unit t -> unit t -> unit t = fun c1 c2 ->
+    (c1 >>= fun () -> (/*/) c1 c2) <!> c2
+        
+  let rec (/++/) : 'a list t -> 'a list t -> 'a list t = fun c1 c2 ->
+    c1 >>= fun x -> (/**/) c1  c2 >>= fun y -> return (x @ y)
+
+  let rec (/+/) : unit t -> unit t -> unit t = fun c1 c2 ->
+    c1 >>= fun () -> (/*/) c1  c2 
+
+  let (/?/) : 'a list t -> 'a list t -> 'a list t = fun c1 c2 ->
+    (c1 >>= fun x -> c2 >>= fun y -> return (x @ y)) <!> c2
+
+  let begin_with c1 c2 =
+    option c1 >>= function
+      | None -> return None
+      | Some _ -> c2 >>= fun v -> return (Some v)
+
+  let set_stream new_st = Return (fun _st -> Profile.incr (); Ok ((), new_st))
+
+end

File planck_intf.ml

   (** [begin_with b w]: if [b] matches then try [w] and returns [w]'s result.
       Otherwise, it returns [None]. *)
 
-  val run : 'a t -> Str.t -> ('a, error) Result.t
+  val run : 'a t -> Str.t -> ('a * Str.t, error) Result.t
   (** Run the monad over the stream *)
 end