Une MAJ de sécurité est nécessaire sur notre version actuelle. Elle sera effectuée lundi 02/08 entre 12h30 et 13h. L'interruption de service devrait durer quelques minutes (probablement moins de 5 minutes).

Commit 86639b79 authored by Frédéric Bour's avatar Frédéric Bour
Browse files

proof-of-concept

parent d1026227
...@@ -19,9 +19,9 @@ let rec loop lexbuf (checkpoint : int I.checkpoint) = ...@@ -19,9 +19,9 @@ let rec loop lexbuf (checkpoint : int I.checkpoint) =
and offer it to the parser, which will produce a new and offer it to the parser, which will produce a new
checkpoint. Then, repeat. *) checkpoint. Then, repeat. *)
let token = Lexer.token lexbuf in let token = Lexer.token lexbuf in
let startp = lexbuf.lex_start_p let startp = lexbuf.lex_start_pos
and endp = lexbuf.lex_curr_p in and endp = lexbuf.lex_curr_pos in
let checkpoint = I.offer checkpoint (token, startp, endp) in let checkpoint = I.offer checkpoint (token, (startp, endp)) in
loop lexbuf checkpoint loop lexbuf checkpoint
| I.Shifting _ | I.Shifting _
| I.AboutToReduce _ -> | I.AboutToReduce _ ->
...@@ -57,7 +57,8 @@ let fail lexbuf (_ : int I.checkpoint) = ...@@ -57,7 +57,8 @@ let fail lexbuf (_ : int I.checkpoint) =
(lexeme_start lexbuf) (lexeme_start lexbuf)
let loop lexbuf result = let loop lexbuf result =
let supplier = I.lexer_lexbuf_to_supplier Lexer.token lexbuf in let get_location l = (l.Lexing.lex_start_pos, l.Lexing.lex_curr_pos) in
let supplier = I.lexer_lexbuf_to_supplier Lexer.token get_location lexbuf in
I.loop_handle succeed (fail lexbuf) supplier result I.loop_handle succeed (fail lexbuf) supplier result
(* -------------------------------------------------------------------------- *) (* -------------------------------------------------------------------------- *)
...@@ -66,8 +67,9 @@ let loop lexbuf result = ...@@ -66,8 +67,9 @@ let loop lexbuf result =
let process (line : string) = let process (line : string) =
let lexbuf = from_string line in let lexbuf = from_string line in
let loc = (lexbuf.lex_start_pos, lexbuf.lex_curr_pos) in
try try
loop lexbuf (Parser.Incremental.main lexbuf.lex_curr_p) loop lexbuf (Parser.Incremental.main loc)
with with
| Lexer.Error msg -> | Lexer.Error msg ->
Printf.fprintf stderr "%s%!" msg Printf.fprintf stderr "%s%!" msg
...@@ -89,7 +91,7 @@ let rec repeat channel = ...@@ -89,7 +91,7 @@ let rec repeat channel =
process optional_line; process optional_line;
if continue then if continue then
repeat channel repeat channel
let () = let () =
repeat (from_channel stdin) repeat (from_channel stdin)
%location<MyLocation>
%token <int> INT %token <int> INT
%token PLUS MINUS TIMES DIV %token PLUS MINUS TIMES DIV
%token LPAREN RPAREN %token LPAREN RPAREN
...@@ -17,17 +19,17 @@ main: ...@@ -17,17 +19,17 @@ main:
expr: expr:
| i = INT | i = INT
{ i } { prerr_endline (MyLocation.trace $loc);i }
| LPAREN e = expr RPAREN | LPAREN e = expr RPAREN
{ e } { prerr_endline (MyLocation.trace $loc);e }
| e1 = expr PLUS e2 = expr | e1 = expr PLUS e2 = expr
{ e1 + e2 } { prerr_endline (MyLocation.trace $loc); e1 + e2 }
| e1 = expr MINUS e2 = expr | e1 = expr MINUS e2 = expr
{ e1 - e2 } { prerr_endline (MyLocation.trace $loc);e1 - e2 }
| e1 = expr TIMES e2 = expr | e1 = expr TIMES e2 = expr
{ e1 * e2 } { prerr_endline (MyLocation.trace $loc);e1 * e2 }
| e1 = expr DIV e2 = expr | e1 = expr DIV e2 = expr
{ e1 / e2 } { prerr_endline (MyLocation.trace $loc);e1 / e2 }
| MINUS e = expr %prec UMINUS | MINUS e = expr %prec UMINUS
{ - e } { prerr_endline (MyLocation.trace $loc);- e }
...@@ -5,7 +5,7 @@ ifndef MENHIR ...@@ -5,7 +5,7 @@ ifndef MENHIR
MENHIR := $(shell ../find-menhir.sh) MENHIR := $(shell ../find-menhir.sh)
endif endif
MENHIRFLAGS := --infer MENHIRFLAGS := --infer --table
OCAMLBUILD := ocamlbuild -use-ocamlfind -use-menhir -menhir "$(MENHIR) $(MENHIRFLAGS)" OCAMLBUILD := ocamlbuild -use-ocamlfind -use-menhir -menhir "$(MENHIR) $(MENHIRFLAGS)"
......
...@@ -2,6 +2,7 @@ ...@@ -2,6 +2,7 @@
%token PLUS MINUS TIMES DIV %token PLUS MINUS TIMES DIV
%token LPAREN RPAREN %token LPAREN RPAREN
%token EOL %token EOL
%location<MyLocation>
%left PLUS MINUS /* lowest precedence */ %left PLUS MINUS /* lowest precedence */
%left TIMES DIV /* medium precedence */ %left TIMES DIV /* medium precedence */
......
...@@ -406,3 +406,18 @@ module type ENGINE = sig ...@@ -406,3 +406,18 @@ module type ENGINE = sig
and type location := location and type location := location
end end
(* --------------------------------------------------------------------------- *)
(* This signature describes the signature of locations manipulated by Menhir. *)
module type LOCATION = sig
type t
val empty_after : t -> t
val join : t array -> t
val trace : t -> string
val get : Lexing.lexbuf -> t
end
module As_location(M : LOCATION) : LOCATION with type t = M.t = M
...@@ -29,6 +29,7 @@ and interface_item = ...@@ -29,6 +29,7 @@ and interface_item =
| IIInclude of module_type | IIInclude of module_type
(* Submodule. *) (* Submodule. *)
| IIModule of string * module_type | IIModule of string * module_type
| IIModuleAlias of string * Stretch.t
(* Comment. *) (* Comment. *)
| IIComment of string | IIComment of string
...@@ -239,6 +240,7 @@ and modexpr = ...@@ -239,6 +240,7 @@ and modexpr =
| MVar of string | MVar of string
| MStruct of structure | MStruct of structure
| MApp of modexpr * modexpr | MApp of modexpr * modexpr
| MTextual of Stretch.t
(* Structures. *) (* Structures. *)
......
...@@ -75,8 +75,14 @@ let tposition = ...@@ -75,8 +75,14 @@ let tposition =
(* A location is a pair of positions. This might change in the future. *) (* A location is a pair of positions. This might change in the future. *)
let tlocation = let default_tlocation = tpair tposition tposition
tpair tposition tposition
let tlocation ~public grammar =
match grammar.UnparameterizedSyntax.location with
| None -> default_tlocation
| Some _path ->
let path = if public then "Location.t" else "Menhir__Location.t" in
TypApp (path, [])
(* The type of lexer buffers. *) (* The type of lexer buffers. *)
...@@ -252,6 +258,7 @@ let interface_item_to_structure_item = function ...@@ -252,6 +258,7 @@ let interface_item_to_structure_item = function
| IIValDecls _ | IIValDecls _
| IIInclude _ | IIInclude _
| IIModule (_, _) | IIModule (_, _)
| IIModuleAlias (_, _)
| IIComment _ -> | IIComment _ ->
[] []
......
...@@ -35,7 +35,8 @@ val tint: typ ...@@ -35,7 +35,8 @@ val tint: typ
val tstring: typ val tstring: typ
val texn: typ val texn: typ
val tposition: typ val tposition: typ
val tlocation: typ val default_tlocation: typ
val tlocation: public:bool -> UnparameterizedSyntax.grammar -> typ
val tlexbuf: typ val tlexbuf: typ
val tobj : typ val tobj : typ
......
...@@ -72,6 +72,9 @@ let startp = ...@@ -72,6 +72,9 @@ let startp =
let endp = let endp =
"_endpos" "_endpos"
let loc =
"_loc"
(* ------------------------------------------------------------------------ *) (* ------------------------------------------------------------------------ *)
(* Types for semantic values. *) (* Types for semantic values. *)
......
...@@ -53,6 +53,7 @@ val token: string ...@@ -53,6 +53,7 @@ val token: string
val beforeendp: string val beforeendp: string
val startp: string val startp: string
val endp: string val endp: string
val loc: string
(* ------------------------------------------------------------------------ *) (* ------------------------------------------------------------------------ *)
......
...@@ -1581,6 +1581,12 @@ module OnErrorReduce = struct ...@@ -1581,6 +1581,12 @@ module OnErrorReduce = struct
end end
(* ------------------------------------------------------------------------ *)
(* [%location] declaration. *)
let location_module = G.grammar.location
(* ------------------------------------------------------------------------ *) (* ------------------------------------------------------------------------ *)
end (* module Make *) end (* module Make *)
...@@ -588,6 +588,11 @@ module OnErrorReduce : sig ...@@ -588,6 +588,11 @@ module OnErrorReduce : sig
end end
(* ------------------------------------------------------------------------ *)
(* [%location] declaration. *)
val location_module : Stretch.t option
(* ------------------------------------------------------------------------ *) (* ------------------------------------------------------------------------ *)
(* Diagnostics. *) (* Diagnostics. *)
......
...@@ -112,7 +112,7 @@ let actiondef grammar symbol branch = ...@@ -112,7 +112,7 @@ let actiondef grammar symbol branch =
PAnnot (PVar endp, tposition) :: PAnnot (PVar endp, tposition) ::
PAnnot (PVar starto, tint) :: PAnnot (PVar starto, tint) ::
PAnnot (PVar endo, tint) :: PAnnot (PVar endo, tint) ::
PAnnot (PVar loc, tlocation) :: PAnnot (PVar loc, tlocation ~public:false grammar) ::
formals formals
) [] branch.producers ) [] branch.producers
in in
...@@ -130,8 +130,8 @@ let actiondef grammar symbol branch = ...@@ -130,8 +130,8 @@ let actiondef grammar symbol branch =
PAnnot (PVar "_endofs", tint) :: PAnnot (PVar "_endofs", tint) ::
PAnnot (PVar "_endofs__0_", tint) :: PAnnot (PVar "_endofs__0_", tint) ::
PAnnot (PVar "_symbolstartofs", tint) :: PAnnot (PVar "_symbolstartofs", tint) ::
PAnnot (PVar "_sloc", tlocation) :: PAnnot (PVar "_sloc", tlocation ~public:false grammar) ::
PAnnot (PVar "_loc", tlocation) :: PAnnot (PVar "_loc", tlocation ~public:false grammar) ::
formals formals
in in
...@@ -151,6 +151,13 @@ let actiondef grammar symbol branch = ...@@ -151,6 +151,13 @@ let actiondef grammar symbol branch =
| _ -> | _ ->
EFun (formals, body) EFun (formals, body)
let location_module grammar =
match grammar.UnparameterizedSyntax.location with
| None -> []
| Some path ->
let md = MApp (MVar "MenhirLib.EngineTypes.As_location", MTextual path) in
[SIModuleDef ("Menhir__Location", md)]
(* [program] turns an entire grammar into a test program. *) (* [program] turns an entire grammar into a test program. *)
let program grammar = let program grammar =
...@@ -209,6 +216,7 @@ let program grammar = ...@@ -209,6 +216,7 @@ let program grammar =
[ SIFunctor (grammar.parameters, [ SIFunctor (grammar.parameters,
interface_to_structure (tokentypedef grammar) @ interface_to_structure (tokentypedef grammar) @
location_module grammar @
SIStretch grammar.preludes :: SIStretch grammar.preludes ::
SIValDefs (false, [ begindef; def; enddef ]) :: SIValDefs (false, [ begindef; def; enddef ]) ::
SIStretch grammar.postludes :: SIStretch grammar.postludes ::
......
...@@ -311,6 +311,8 @@ and inline_modexpr = function ...@@ -311,6 +311,8 @@ and inline_modexpr = function
MStruct (inline_structure s) MStruct (inline_structure s)
| MApp (e1, e2) -> | MApp (e1, e2) ->
MApp (inline_modexpr e1, inline_modexpr e2) MApp (inline_modexpr e1, inline_modexpr e2)
| MTextual stretch ->
MTextual stretch
(* The external entry point. *) (* The external entry point. *)
......
...@@ -15,6 +15,11 @@ open UnparameterizedSyntax ...@@ -15,6 +15,11 @@ open UnparameterizedSyntax
open IL open IL
open CodeBits open CodeBits
(* -------------------------------------------------------------------------- *)
(* The type of locations. *)
(* -------------------------------------------------------------------------- *) (* -------------------------------------------------------------------------- *)
(* The [Error] exception. *) (* The [Error] exception. *)
...@@ -64,7 +69,7 @@ let incremental = ...@@ -64,7 +69,7 @@ let incremental =
let entrytypescheme_incremental grammar symbol = let entrytypescheme_incremental grammar symbol =
let t = TypTextual (ocamltype_of_start_symbol grammar symbol) in let t = TypTextual (ocamltype_of_start_symbol grammar symbol) in
type2scheme (marrow [ tlocation ] (checkpoint t)) type2scheme (marrow [ tlocation ~public:true grammar ] (checkpoint t))
(* -------------------------------------------------------------------------- *) (* -------------------------------------------------------------------------- *)
...@@ -128,7 +133,7 @@ let inspection_api grammar () = ...@@ -128,7 +133,7 @@ let inspection_api grammar () =
(* The incremental API. *) (* The incremental API. *)
let incremental_engine () : module_type = let incremental_engine grammar : module_type =
with_types WKNonDestructive with_types WKNonDestructive
"MenhirLib.IncrementalEngine.INCREMENTAL_ENGINE" "MenhirLib.IncrementalEngine.INCREMENTAL_ENGINE"
[ [
...@@ -136,8 +141,7 @@ let incremental_engine () : module_type = ...@@ -136,8 +141,7 @@ let incremental_engine () : module_type =
"token", (* NOT [tctoken], which is qualified if [--external-tokens] is used *) "token", (* NOT [tctoken], which is qualified if [--external-tokens] is used *)
TokenType.ttoken; TokenType.ttoken;
[], [],
"location", "location", tlocation ~public:true grammar
CodeBits.tlocation
] ]
let incremental_entry_points grammar : interface = let incremental_entry_points grammar : interface =
...@@ -159,7 +163,7 @@ let incremental_api grammar () : interface = ...@@ -159,7 +163,7 @@ let incremental_api grammar () : interface =
interpreter, interpreter,
MTSigEnd ( MTSigEnd (
IIComment "The incremental API." :: IIComment "The incremental API." ::
IIInclude (incremental_engine()) :: IIInclude (incremental_engine grammar) ::
listiflazy Settings.inspection (inspection_api grammar) listiflazy Settings.inspection (inspection_api grammar)
) )
) :: ) ::
...@@ -170,11 +174,19 @@ let incremental_api grammar () : interface = ...@@ -170,11 +174,19 @@ let incremental_api grammar () : interface =
(* -------------------------------------------------------------------------- *) (* -------------------------------------------------------------------------- *)
let location_module grammar =
match grammar.UnparameterizedSyntax.location with
| None -> []
| Some mpath -> [IIModuleAlias ("Location", mpath)]
(* -------------------------------------------------------------------------- *)
(* The complete interface of the generated parser. *) (* The complete interface of the generated parser. *)
let interface grammar = [ let interface grammar = [
IIFunctor (grammar.parameters, IIFunctor (grammar.parameters,
monolithic_api grammar @ monolithic_api grammar @
location_module grammar @
listiflazy Settings.table (incremental_api grammar) listiflazy Settings.table (incremental_api grammar)
) )
] ]
......
...@@ -676,19 +676,32 @@ let () = ...@@ -676,19 +676,32 @@ let () =
(* [$startpos] and [$endpos] have been expanded away. *) (* [$startpos] and [$endpos] have been expanded away. *)
assert false assert false
| Position (_, _, FlavorLocation) -> | Position (_, _, FlavorLocation) ->
(* [$loc] and [$sloc] have been expanded away. *) begin match Grammar.location_module with
assert false | None ->
(* [$loc] and [$sloc] have been expanded away. *)
assert false
| Some _ ->
(* $loc has been kept for custom locations. *)
()
end
| Position (RightNamed _, WhereSymbolStart, _) -> | Position (RightNamed _, WhereSymbolStart, _) ->
(* [$symbolstartpos(x)] does not exist. *) (* [$symbolstartpos(x)] does not exist. *)
assert false assert false
| Position (RightNamed id, where, _) -> | Position (RightNamed id, where, _) ->
(* If the semantic action mentions [$startpos($i)], then the begin match Grammar.location_module with
[i]-th symbol in the right-hand side must keep track of | None ->
its start position. Similarly for end positions. *) (* If the semantic action mentions [$startpos($i)], then the
Array.iteri (fun i id' -> [i]-th symbol in the right-hand side must keep track of
if id = id' then its start position. Similarly for end positions. *)
record_ConVar true (rhs.(i), where) Array.iteri (fun i id' ->
) ids if id = id' then
record_ConVar true (rhs.(i), where)
) ids
| Some _ ->
(* $startpos when using custom locations should have been
rejected before. *)
()
end
) (Action.keywords action) ) (Action.keywords action)
); (* end of loop on productions *) ); (* end of loop on productions *)
......
...@@ -696,6 +696,8 @@ and modexpr f = function ...@@ -696,6 +696,8 @@ and modexpr f = function
structend f s structend f s
| MApp (e1, e2) -> | MApp (e1, e2) ->
fprintf f "%a (%a)" modexpr e1 modexpr e2 fprintf f "%a (%a)" modexpr e1 modexpr e2
| MTextual mpath ->
fprintf f "(%a)" (stretch true) mpath
let valdecl f (x, ts) = let valdecl f (x, ts) =
fprintf f "val %s: %a" x typ ts.body fprintf f "val %s: %a" x typ ts.body
...@@ -743,6 +745,8 @@ and interface_item f item = ...@@ -743,6 +745,8 @@ and interface_item f item =
fprintf f "include %a" module_type mt fprintf f "include %a" module_type mt
| IIModule (name, mt) -> | IIModule (name, mt) ->
fprintf f "module %s : %a" name module_type mt fprintf f "module %s : %a" name module_type mt
| IIModuleAlias (name, mpath) ->
fprintf f "module %s = %a" name (stretch true) mpath
| IIComment comment -> | IIComment comment ->
fprintf f "(* %s *)" comment fprintf f "(* %s *)" comment
end; end;
......
...@@ -159,10 +159,14 @@ let reducecellparams prod i _symbol (next : pattern) : pattern = ...@@ -159,10 +159,14 @@ let reducecellparams prod i _symbol (next : pattern) : pattern =
let ids = Production.identifiers prod in let ids = Production.identifiers prod in
let loc = let loc =
PTuple [ match Grammar.location_module with
PVar (Printf.sprintf "_startpos_%s_" ids.(i)); | None ->
PVar (Printf.sprintf "_endpos_%s_" ids.(i)); PTuple [
] PVar (Printf.sprintf "_startpos_%s_" ids.(i));
PVar (Printf.sprintf "_endpos_%s_" ids.(i));
]
| Some _ ->
PVar (Printf.sprintf "_loc_%s_" ids.(i))
in in
PRecord [ PRecord [
...@@ -199,8 +203,11 @@ let reducecellcasts prod i symbol casts = ...@@ -199,8 +203,11 @@ let reducecellcasts prod i symbol casts =
(* 2015/11/04. The start and end positions of an epsilon production are obtained (* 2015/11/04. The start and end positions of an epsilon production are obtained
by taking the end position stored in the top stack cell (whatever it is). *) by taking the end position stored in the top stack cell (whatever it is). *)
let location_of_top_stack_cell =
ERecordAccess(EVar stack, flocation)
let endpos_of_top_stack_cell = let endpos_of_top_stack_cell =
EApp (EVar "Pervasives.snd", [ERecordAccess(EVar stack, flocation)]) EApp (EVar "Pervasives.snd", [location_of_top_stack_cell])
(* This is the body of the [reduce] function associated with (* This is the body of the [reduce] function associated with
production [prod]. It assumes that the variables [env] and [stack] production [prod]. It assumes that the variables [env] and [stack]
...@@ -236,21 +243,36 @@ let reducebody prod = ...@@ -236,21 +243,36 @@ let reducebody prod =
by the OCaml compiler. *) by the OCaml compiler. *)
let posbindings = let posbindings =
( PVar beforeendp, match Grammar.location_module with
endpos_of_top_stack_cell | None ->
) :: [ PVar beforeendp,
( PVar startp,
if length > 0 then
EVar (Printf.sprintf "_startpos_%s_" ids.(0))
else
endpos_of_top_stack_cell endpos_of_top_stack_cell
) :: ; PVar startp,
( PVar endp, if length > 0 then
if length > 0 then EVar (Printf.sprintf "_startpos_%s_" ids.(0))
EVar (Printf.sprintf "_endpos_%s_" ids.(length - 1)) else
else endpos_of_top_stack_cell
EVar startp ; PVar endp,
) :: [] if length > 0 then
EVar (Printf.sprintf "_endpos_%s_" ids.(length - 1))
else
EVar startp