diff options
Diffstat (limited to 'camlp4/lib/token.ml')
| -rw-r--r-- | camlp4/lib/token.ml | 72 |
1 files changed, 48 insertions, 24 deletions
diff --git a/camlp4/lib/token.ml b/camlp4/lib/token.ml index e26798af9c..5bfc6541f1 100644 --- a/camlp4/lib/token.ml +++ b/camlp4/lib/token.ml @@ -17,9 +17,23 @@ type pattern = (string * string); exception Error of string; -type location = (int * int); -type location_function = int -> (int * int); -type lexer_func 'te = Stream.t char -> (Stream.t 'te * location_function); +value make_loc (bp, ep) = + ({ (Lexing.dummy_pos) with Lexing.pos_cnum = bp; Lexing.pos_lnum = 1 }, + { (Lexing.dummy_pos) with Lexing.pos_cnum = ep; Lexing.pos_lnum = 1 }) +; + +value nowhere = { (Lexing.dummy_pos) with Lexing.pos_cnum = 0 }; + +value dummy_loc = (Lexing.dummy_pos, Lexing.dummy_pos); + +value succ_pos p = + { ( p ) with Lexing.pos_cnum = p.Lexing.pos_cnum + 1}; +value lt_pos p1 p2 = p1.Lexing.pos_cnum < p2.Lexing.pos_cnum; + +type flocation = (Lexing.position * Lexing.position); + +type flocation_function = int -> flocation; +type lexer_func 'te = Stream.t char -> (Stream.t 'te * flocation_function); type glexer 'te = { tok_func : lexer_func 'te; @@ -27,7 +41,7 @@ type glexer 'te = tok_removing : pattern -> unit; tok_match : pattern -> 'te -> string; tok_text : pattern -> string; - tok_comm : mutable option (list location) } + tok_comm : mutable option (list flocation) } ; type lexer = { func : lexer_func t; @@ -43,31 +57,41 @@ value lexer_text (con, prm) = else con ^ " '" ^ prm ^ "'" ; -value locerr () = invalid_arg "Lexer: location function"; -value loct_create () = (ref (Array.create 1024 None), ref False); +value locerr () = invalid_arg "Lexer: flocation function"; + +value tsz = 256; (* up to 2^29 entries on a 32-bit machine, 2^61 on 64-bit *) + +value loct_create () = (ref [| |], ref False); + value loct_func (loct, ov) i = match - if i < 0 || i >= Array.length loct.val then - if ov.val then Some (0, 0) else None - else Array.unsafe_get loct.val i + if i < 0 || i/tsz >= Array.length loct.val then None + else if loct.val.(i/tsz) = [| |] then + if ov.val then Some (nowhere, nowhere) else None + else Array.unsafe_get (Array.unsafe_get loct.val (i/tsz)) (i mod tsz) with [ Some loc -> loc | _ -> locerr () ] ; -value loct_add (loct, ov) i loc = - if i >= Array.length loct.val then - let new_tmax = Array.length loct.val * 2 in + +value loct_add (loct, ov) i loc = do { + while i/tsz >= Array.length loct.val && (not ov.val) do { + let new_tmax = Array.length loct.val * 2 + 1 in if new_tmax < Sys.max_array_length then do { - let new_loct = Array.create new_tmax None in + let new_loct = Array.make new_tmax [| |] in Array.blit loct.val 0 new_loct 0 (Array.length loct.val); - loct.val := new_loct; - loct.val.(i) := Some loc - } - else ov.val := True - else loct.val.(i) := Some loc -; + loct.val := new_loct + } else ov.val := True + }; + if not(ov.val) then do { + if loct.val.(i/tsz) = [| |] then + loct.val.(i/tsz) := Array.make tsz None + else (); + loct.val.(i/tsz).(i mod tsz) := Some loc + } else () +}; -value make_stream_and_location next_token_loc = +value make_stream_and_flocation next_token_loc = let loct = loct_create () in let ts = Stream.from @@ -79,7 +103,7 @@ value make_stream_and_location next_token_loc = ; value lexer_func_of_parser next_token_loc cs = - make_stream_and_location (fun () -> next_token_loc cs) + make_stream_and_flocation (fun () -> next_token_loc cs) ; value lexer_func_of_ocamllex lexfun cs = @@ -90,10 +114,10 @@ value lexer_func_of_ocamllex lexfun cs = in let next_token_loc _ = let tok = lexfun lb in - let loc = (Lexing.lexeme_start lb, Lexing.lexeme_end lb) in + let loc = (Lexing.lexeme_start_p lb, Lexing.lexeme_end_p lb) in (tok, loc) in - make_stream_and_location next_token_loc + make_stream_and_flocation next_token_loc ; (* Char and string tokens to real chars and string *) @@ -209,7 +233,7 @@ value eval_string (bp, ep) s = [ Not_found -> do { Printf.eprintf "Warning: char %d, Invalid backslash escape in string\n%!" - (bp+i+1); + (bp.Lexing.pos_cnum + i + 1); (store (store len '\\') c, i + 1) } ] ] else (store len s.[i], i + 1) in |