279 lines
8.5 KiB
OCaml
279 lines
8.5 KiB
OCaml
(****************************************************************************)
|
|
(* *)
|
|
(* Objective Caml *)
|
|
(* *)
|
|
(* INRIA Rocquencourt *)
|
|
(* *)
|
|
(* Copyright 2006 Institut National de Recherche en Informatique et *)
|
|
(* en Automatique. All rights reserved. This file is distributed under *)
|
|
(* the terms of the GNU Library General Public License, with the special *)
|
|
(* exception on linking described in LICENSE at the top of the Objective *)
|
|
(* Caml source tree. *)
|
|
(* *)
|
|
(****************************************************************************)
|
|
|
|
(* Authors:
|
|
* - Daniel de Rauglaudre: initial version
|
|
* - Nicolas Pouillard: refactoring
|
|
*)
|
|
open Sig.Grammar.Structure;
|
|
module type S = sig
|
|
module Loc : Sig.Loc.S;
|
|
module Token : Sig.Token.S with module Loc = Loc;
|
|
module Lexer : Sig.Lexer.S
|
|
with module Loc = Loc
|
|
and module Token = Token;
|
|
module Context : Context.S with module Token = Token;
|
|
module Action : Sig.Grammar.Action.S;
|
|
|
|
type gram =
|
|
{ gfilter : Token.Filter.t;
|
|
gkeywords : Hashtbl.t string (ref int);
|
|
glexer : Loc.t -> Stream.t char -> Stream.t (Token.t * Loc.t);
|
|
warning_verbose : ref bool;
|
|
error_verbose : ref bool };
|
|
|
|
type efun = Context.t -> Stream.t (Token.t * Loc.t) -> Action.t;
|
|
|
|
type token_pattern = ((Token.t -> bool) * string);
|
|
|
|
type internal_entry =
|
|
{ egram : gram;
|
|
ename : string;
|
|
estart : mutable int -> efun;
|
|
econtinue : mutable int -> Loc.t -> Action.t -> efun;
|
|
edesc : mutable desc }
|
|
and desc =
|
|
[ Dlevels of list level
|
|
| Dparser of Stream.t (Token.t * Loc.t) -> Action.t ]
|
|
and level =
|
|
{ assoc : assoc ;
|
|
lname : option string ;
|
|
lsuffix : tree ;
|
|
lprefix : tree }
|
|
and symbol =
|
|
[ Smeta of string and list symbol and Action.t
|
|
| Snterm of internal_entry
|
|
| Snterml of internal_entry and string
|
|
| Slist0 of symbol
|
|
| Slist0sep of symbol and symbol
|
|
| Slist1 of symbol
|
|
| Slist1sep of symbol and symbol
|
|
| Sopt of symbol
|
|
| Sself
|
|
| Snext
|
|
| Stoken of token_pattern
|
|
| Skeyword of string
|
|
| Stree of tree ]
|
|
and tree =
|
|
[ Node of node
|
|
| LocAct of Action.t and list Action.t
|
|
| DeadEnd ]
|
|
and node =
|
|
{ node : symbol ;
|
|
son : tree ;
|
|
brother : tree };
|
|
|
|
type production_rule = (list symbol * Action.t);
|
|
type single_extend_statment =
|
|
(option string * option assoc * list production_rule);
|
|
type extend_statment =
|
|
(option position * list single_extend_statment);
|
|
type delete_statment = list symbol;
|
|
|
|
type fold 'a 'b 'c =
|
|
internal_entry -> list symbol ->
|
|
(Stream.t 'a -> 'b) -> Stream.t 'a -> 'c;
|
|
|
|
type foldsep 'a 'b 'c =
|
|
internal_entry -> list symbol ->
|
|
(Stream.t 'a -> 'b) -> (Stream.t 'a -> unit) -> Stream.t 'a -> 'c;
|
|
|
|
(* Accessors *)
|
|
value get_filter : gram -> Token.Filter.t;
|
|
|
|
(* Useful functions *)
|
|
value using : gram -> string -> unit;
|
|
value removing : gram -> string -> unit;
|
|
end;
|
|
|
|
module Make (Lexer : Sig.Lexer.S) = struct
|
|
module Loc = Lexer.Loc;
|
|
module Token = Lexer.Token;
|
|
module Action : Sig.Grammar.Action.S = struct
|
|
type t = Obj.t ;
|
|
value mk = Obj.repr;
|
|
value get = Obj.obj ;
|
|
value getf = Obj.obj ;
|
|
value getf2 = Obj.obj ;
|
|
end;
|
|
module Lexer = Lexer;
|
|
|
|
type gram =
|
|
{ gfilter : Token.Filter.t;
|
|
gkeywords : Hashtbl.t string (ref int);
|
|
glexer : Loc.t -> Stream.t char -> Stream.t (Token.t * Loc.t);
|
|
warning_verbose : ref bool;
|
|
error_verbose : ref bool };
|
|
|
|
module Context = Context.Make Token;
|
|
|
|
type efun = Context.t -> Stream.t (Token.t * Loc.t) -> Action.t;
|
|
|
|
type token_pattern = ((Token.t -> bool) * string);
|
|
|
|
type internal_entry =
|
|
{ egram : gram;
|
|
ename : string;
|
|
estart : mutable int -> efun;
|
|
econtinue : mutable int -> Loc.t -> Action.t -> efun;
|
|
edesc : mutable desc }
|
|
and desc =
|
|
[ Dlevels of list level
|
|
| Dparser of Stream.t (Token.t * Loc.t) -> Action.t ]
|
|
and level =
|
|
{ assoc : assoc ;
|
|
lname : option string ;
|
|
lsuffix : tree ;
|
|
lprefix : tree }
|
|
and symbol =
|
|
[ Smeta of string and list symbol and Action.t
|
|
| Snterm of internal_entry
|
|
| Snterml of internal_entry and string
|
|
| Slist0 of symbol
|
|
| Slist0sep of symbol and symbol
|
|
| Slist1 of symbol
|
|
| Slist1sep of symbol and symbol
|
|
| Sopt of symbol
|
|
| Sself
|
|
| Snext
|
|
| Stoken of token_pattern
|
|
| Skeyword of string
|
|
| Stree of tree ]
|
|
and tree =
|
|
[ Node of node
|
|
| LocAct of Action.t and list Action.t
|
|
| DeadEnd ]
|
|
and node =
|
|
{ node : symbol ;
|
|
son : tree ;
|
|
brother : tree };
|
|
|
|
type production_rule = (list symbol * Action.t);
|
|
type single_extend_statment =
|
|
(option string * option assoc * list production_rule);
|
|
type extend_statment =
|
|
(option position * list single_extend_statment);
|
|
type delete_statment = list symbol;
|
|
|
|
type fold 'a 'b 'c =
|
|
internal_entry -> list symbol ->
|
|
(Stream.t 'a -> 'b) -> Stream.t 'a -> 'c;
|
|
|
|
type foldsep 'a 'b 'c =
|
|
internal_entry -> list symbol ->
|
|
(Stream.t 'a -> 'b) -> (Stream.t 'a -> unit) -> Stream.t 'a -> 'c;
|
|
|
|
value get_filter g = g.gfilter;
|
|
|
|
type not_filtered 'a = 'a;
|
|
value using { gkeywords = table; gfilter = filter } kwd =
|
|
let r = try Hashtbl.find table kwd with
|
|
[ Not_found ->
|
|
let r = ref 0 in do { Hashtbl.add table kwd r; r } ]
|
|
in do { Token.Filter.keyword_added filter kwd (r.val = 0);
|
|
incr r };
|
|
|
|
value removing { gkeywords = table; gfilter = filter } kwd =
|
|
let r = Hashtbl.find table kwd in
|
|
let () = decr r in
|
|
if r.val = 0 then do {
|
|
Token.Filter.keyword_removed filter kwd;
|
|
Hashtbl.remove table kwd
|
|
} else ();
|
|
end;
|
|
|
|
(*
|
|
value iter_entry f e =
|
|
let treated = ref [] in
|
|
let rec do_entry e =
|
|
if List.memq e treated.val then ()
|
|
else do {
|
|
treated.val := [e :: treated.val];
|
|
f e;
|
|
match e.edesc with
|
|
[ Dlevels ll -> List.iter do_level ll
|
|
| Dparser _ -> () ]
|
|
}
|
|
and do_level lev = do { do_tree lev.lsuffix; do_tree lev.lprefix }
|
|
and do_tree =
|
|
fun
|
|
[ Node n -> do_node n
|
|
| LocAct _ _ | DeadEnd -> () ]
|
|
and do_node n = do { do_symbol n.node; do_tree n.son; do_tree n.brother }
|
|
and do_symbol =
|
|
fun
|
|
[ Smeta _ sl _ -> List.iter do_symbol sl
|
|
| Snterm e | Snterml e _ -> do_entry e
|
|
| Slist0 s | Slist1 s | Sopt s -> do_symbol s
|
|
| Slist0sep s1 s2 | Slist1sep s1 s2 -> do { do_symbol s1; do_symbol s2 }
|
|
| Stree t -> do_tree t
|
|
| Sself | Snext | Stoken _ | Stoken_fun _ -> () ]
|
|
in
|
|
do_entry e
|
|
;
|
|
|
|
value fold_entry f e init =
|
|
let treated = ref [] in
|
|
let rec do_entry accu e =
|
|
if List.memq e treated.val then accu
|
|
else do {
|
|
treated.val := [e :: treated.val];
|
|
let accu = f e accu in
|
|
match e.edesc with
|
|
[ Dlevels ll -> List.fold_left do_level accu ll
|
|
| Dparser _ -> accu ]
|
|
}
|
|
and do_level accu lev =
|
|
let accu = do_tree accu lev.lsuffix in
|
|
do_tree accu lev.lprefix
|
|
and do_tree accu =
|
|
fun
|
|
[ Node n -> do_node accu n
|
|
| LocAct _ _ | DeadEnd -> accu ]
|
|
and do_node accu n =
|
|
let accu = do_symbol accu n.node in
|
|
let accu = do_tree accu n.son in
|
|
do_tree accu n.brother
|
|
and do_symbol accu =
|
|
fun
|
|
[ Smeta _ sl _ -> List.fold_left do_symbol accu sl
|
|
| Snterm e | Snterml e _ -> do_entry accu e
|
|
| Slist0 s | Slist1 s | Sopt s -> do_symbol accu s
|
|
| Slist0sep s1 s2 | Slist1sep s1 s2 ->
|
|
let accu = do_symbol accu s1 in
|
|
do_symbol accu s2
|
|
| Stree t -> do_tree accu t
|
|
| Sself | Snext | Stoken _ | Stoken_fun _ -> accu ]
|
|
in
|
|
do_entry init e
|
|
;
|
|
|
|
value is_level_labelled n lev =
|
|
match lev.lname with
|
|
[ Some n1 -> n = n1
|
|
| None -> False ]
|
|
;
|
|
|
|
value tokens g con =
|
|
let list = ref [] in
|
|
do {
|
|
Hashtbl.iter
|
|
(fun (p_con, p_prm) c ->
|
|
if p_con = con then list.val := [(p_prm, c.val) :: list.val] else ())
|
|
g.gtokens;
|
|
list.val
|
|
}
|
|
;
|
|
*)
|