ocaml/camlp4/ocaml_src/lib/gramext.ml

(* camlp4r *)
(***********************************************************************)
(*                                                                     *)
(*                             Camlp4                                  *)
(*                                                                     *)
(*        Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt     *)
(*                                                                     *)
(*  Copyright 2001 Institut National de Recherche en Informatique et   *)
(*  Automatique.  Distributed only by permission.                      *)
(*                                                                     *)
(***********************************************************************)

(* Id *)

type grammar =
  { gtokens : (Token.pattern, int ref) Hashtbl.t;
    mutable glexer : Token.lexer }
;;

type g_entry =
  { egram : grammar;
    ename : string;
    mutable estart : int -> Token.t Stream.t -> Obj.t;
    mutable econtinue : int -> int -> Obj.t -> Token.t Stream.t -> Obj.t;
    mutable edesc : g_desc }
and g_desc = Dlevels of g_level list | Dparser of (Token.t Stream.t -> Obj.t)
and g_level =
  { assoc : g_assoc;
    lname : string option;
    lsuffix : g_tree;
    lprefix : g_tree }
and g_assoc = NonA | RightA | LeftA
and g_symbol =
    Snterm of g_entry
  | Snterml of g_entry * string
  | Slist0 of g_symbol
  | Slist0sep of g_symbol * g_symbol
  | Slist1 of g_symbol
  | Slist1sep of g_symbol * g_symbol
  | Sopt of g_symbol
  | Sself
  | Snext
  | Stoken of Token.pattern
  | Stree of g_tree
and g_action = Obj.t
and g_tree = Node of g_node | LocAct of g_action * g_action list | DeadEnd
and g_node = { node : g_symbol; son : g_tree; brother : g_tree }
;;

type position =
  First | Last | Before of string | After of string | Level of string
;;

let warning_verbose = ref true;;

let rec derive_eps =
  function
    Slist0 _ -> true
  | Slist0sep (_, _) -> true
  | Sopt _ -> true
  | Stree t -> tree_derive_eps t
  | _ -> false
and tree_derive_eps =
  function
    LocAct (_, _) -> true
  | Node {node = s; brother = bro; son = son} ->
      derive_eps s && tree_derive_eps son || tree_derive_eps bro
  | _ -> false
;;

let rec eq_symbol s1 s2 =
  match s1, s2 with
    Snterm e1, Snterm e2 -> e1 == e2
  | Snterml (e1, l1), Snterml (e2, l2) -> e1 == e2 && l1 = l2
  | Slist0 s1, Slist0 s2 -> eq_symbol s1 s2
  | Slist0sep (s1, sep1), Slist0sep (s2, sep2) ->
      eq_symbol s1 s2 && eq_symbol sep1 sep2
  | Slist1 s1, Slist1 s2 -> eq_symbol s1 s2
  | Slist1sep (s1, sep1), Slist1sep (s2, sep2) ->
      eq_symbol s1 s2 && eq_symbol sep1 sep2
  | Sopt s1, Sopt s2 -> eq_symbol s1 s2
  | Stree _, Stree _ -> false
  | _ -> s1 = s2
;;

let is_before s1 s2 =
  match s1, s2 with
    Stoken ("ANY", _), _ -> false
  | _, Stoken ("ANY", _) -> true
  | Stoken (_, s), Stoken (_, "") when s <> "" -> true
  | Stoken _, Stoken _ -> false
  | Stoken _, _ -> true
  | _ -> false
;;

let insert_tree gsymbols action tree =
  let rec insert symbols tree =
    match symbols with
      s :: sl -> insert_in_tree s sl tree
    | [] ->
        match tree with
          Node {node = s; son = son; brother = bro} ->
            Node {node = s; son = son; brother = insert [] bro}
        | LocAct (old_action, action_list) ->
            if !warning_verbose then
              begin
                Printf.eprintf
                  "<W> Grammar extension: some rule has been masked\n";
                flush stderr
              end;
            LocAct (action, (old_action :: action_list))
        | DeadEnd -> LocAct (action, [])
  and insert_in_tree s sl tree =
    match try_insert s sl tree with
      Some t -> t
    | None -> Node {node = s; son = insert sl DeadEnd; brother = tree}
  and try_insert s sl tree =
    match tree with
      Node {node = s1; son = son; brother = bro} ->
        if eq_symbol s s1 then
          let t = Node {node = s1; son = insert sl son; brother = bro} in
          Some t
        else if is_before s1 s || derive_eps s && not (derive_eps s1) then
          let bro =
            match try_insert s sl bro with
              Some bro -> bro
            | None -> Node {node = s; son = insert sl DeadEnd; brother = bro}
          in
          let t = Node {node = s1; son = son; brother = bro} in Some t
        else
          begin match try_insert s sl bro with
            Some bro ->
              let t = Node {node = s1; son = son; brother = bro} in Some t
          | None -> None
          end
    | _ -> None
  and insert_new =
    function
      s :: sl -> Node {node = s; son = insert_new sl; brother = DeadEnd}
    | [] -> LocAct (action, [])
  in
  insert gsymbols tree
;;

let srules rl =
  let t =
    List.fold_left
      (fun tree (symbols, action) -> insert_tree symbols action tree) DeadEnd
      rl
  in
  Stree t
;;

external action : 'a -> g_action = "%identity";;

let is_level_labelled n lev =
  match lev.lname with
    Some n1 -> n = n1
  | None -> false
;;

let insert_level e1 symbols action slev =
  match e1 with
    true ->
      {assoc = slev.assoc; lname = slev.lname;
       lsuffix = insert_tree symbols action slev.lsuffix;
       lprefix = slev.lprefix}
  | false ->
      {assoc = slev.assoc; lname = slev.lname; lsuffix = slev.lsuffix;
       lprefix = insert_tree symbols action slev.lprefix}
;;

let empty_lev lname assoc =
  let assoc =
    match assoc with
      Some a -> a
    | None -> LeftA
  in
  {assoc = assoc; lname = lname; lsuffix = DeadEnd; lprefix = DeadEnd}
;;

let change_lev lev n lname assoc =
  let a =
    match assoc with
      None -> lev.assoc
    | Some a ->
        if a <> lev.assoc && !warning_verbose then
          begin
            Printf.eprintf "<W> Changing associativity of level \"%s\"\n" n;
            flush stderr
          end;
        a
  in
  begin match lname with
    Some n ->
      if lname <> lev.lname && !warning_verbose then
        begin
          Printf.eprintf "<W> Level label \"%s\" ignored\n" n; flush stderr
        end
  | _ -> ()
  end;
  {assoc = a; lname = lev.lname; lsuffix = lev.lsuffix; lprefix = lev.lprefix}
;;

let get_level entry position levs =
  match position with
    Some First -> [], empty_lev, levs
  | Some Last -> levs, empty_lev, []
  | Some (Level n) ->
      let rec get =
        function
          [] ->
            Printf.eprintf "No level labelled \"%s\" in entry \"%s\"\n" n
              entry.ename;
            flush stderr;
            failwith "Grammar.extend"
        | lev :: levs ->
            if is_level_labelled n lev then [], change_lev lev n, levs
            else
              let (levs1, rlev, levs2) = get levs in lev :: levs1, rlev, levs2
      in
      get levs
  | Some (Before n) ->
      let rec get =
        function
          [] ->
            Printf.eprintf "No level labelled \"%s\" in entry \"%s\"\n" n
              entry.ename;
            flush stderr;
            failwith "Grammar.extend"
        | lev :: levs ->
            if is_level_labelled n lev then [], empty_lev, lev :: levs
            else
              let (levs1, rlev, levs2) = get levs in lev :: levs1, rlev, levs2
      in
      get levs
  | Some (After n) ->
      let rec get =
        function
          [] ->
            Printf.eprintf "No level labelled \"%s\" in entry \"%s\"\n" n
              entry.ename;
            flush stderr;
            failwith "Grammar.extend"
        | lev :: levs ->
            if is_level_labelled n lev then [lev], empty_lev, levs
            else
              let (levs1, rlev, levs2) = get levs in lev :: levs1, rlev, levs2
      in
      get levs
  | None ->
      match levs with
        lev :: levs -> [], change_lev lev "<top>", levs
      | [] -> [], empty_lev, []
;;

let rec check_gram entry =
  function
    Snterm e ->
      if e.egram != entry.egram then
        begin
          Printf.eprintf "\
Error: entries \"%s\" and \"%s\" do not belong to the same grammar.\n"
            entry.ename e.ename;
          flush stderr;
          failwith "Grammar.extend error"
        end
  | Snterml (e, _) ->
      if e.egram != entry.egram then
        begin
          Printf.eprintf "\
Error: entries \"%s\" and \"%s\" do not belong to the same grammar.\n"
            entry.ename e.ename;
          flush stderr;
          failwith "Grammar.extend error"
        end
  | Slist0sep (s, t) -> check_gram entry t; check_gram entry s
  | Slist1sep (s, t) -> check_gram entry t; check_gram entry s
  | Slist0 s -> check_gram entry s
  | Slist1 s -> check_gram entry s
  | Sopt s -> check_gram entry s
  | Stree t -> tree_check_gram entry t
  | _ -> ()
and tree_check_gram entry =
  function
    Node {node = n; brother = bro; son = son} ->
      check_gram entry n; tree_check_gram entry bro; tree_check_gram entry son
  | _ -> ()
;;

let change_to_self entry =
  function
    Snterm e when e == entry -> Sself
  | x -> x
;;

let get_initial entry =
  function
    Sself :: symbols -> true, symbols
  | symbols -> false, symbols
;;

let insert_tokens gram symbols =
  let rec insert =
    function
      Slist0 s -> insert s
    | Slist1 s -> insert s
    | Slist0sep (s, t) -> insert s; insert t
    | Slist1sep (s, t) -> insert s; insert t
    | Sopt s -> insert s
    | Stree t -> tinsert t
    | Stoken ("ANY", _) -> ()
    | Stoken tok ->
        gram.glexer.Token.using tok;
        let r =
          try Hashtbl.find gram.gtokens tok with
            Not_found -> let r = ref 0 in Hashtbl.add gram.gtokens tok r; r
        in
        incr r
    | _ -> ()
  and tinsert =
    function
      Node {node = s; brother = bro; son = son} ->
        insert s; tinsert bro; tinsert son
    | _ -> ()
  in
  List.iter insert symbols
;;

let levels_of_rules entry position rules =
  let elev =
    match entry.edesc with
      Dlevels elev -> elev
    | Dparser _ ->
        Printf.eprintf "Error: entry not extensible: \"%s\"\n" entry.ename;
        flush stderr;
        failwith "Grammar.extend"
  in
  if rules = [] then elev
  else
    let (levs1, make_lev, levs2) = get_level entry position elev in
    let (levs, _) =
      List.fold_left
        (fun (levs, make_lev) (lname, assoc, level) ->
           let lev = make_lev lname assoc in
           let lev =
             List.fold_left
               (fun lev (symbols, action) ->
                  let symbols = List.map (change_to_self entry) symbols in
                  List.iter (check_gram entry) symbols;
                  let (e1, symbols) = get_initial entry symbols in
                  insert_tokens entry.egram symbols;
                  insert_level e1 symbols action lev)
               lev level
           in
           lev :: levs, empty_lev)
        ([], make_lev) rules
    in
    levs1 @ List.rev levs @ levs2
;;

let logically_eq_symbols entry =
  let rec eq_symbols s1 s2 =
    match s1, s2 with
      Snterm e1, Snterm e2 -> e1.ename = e2.ename
    | Snterm e1, Sself -> e1.ename = entry.ename
    | Sself, Snterm e2 -> entry.ename = e2.ename
    | Snterml (e1, l1), Snterml (e2, l2) -> e1.ename = e2.ename && l1 = l2
    | Slist0 s1, Slist0 s2 -> eq_symbols s1 s2
    | Slist0sep (s1, sep1), Slist0sep (s2, sep2) ->
        eq_symbols s1 s2 && eq_symbols sep1 sep2
    | Slist1 s1, Slist1 s2 -> eq_symbols s1 s2
    | Slist1sep (s1, sep1), Slist1sep (s2, sep2) ->
        eq_symbols s1 s2 && eq_symbols sep1 sep2
    | Sopt s1, Sopt s2 -> eq_symbols s1 s2
    | Stree t1, Stree t2 -> eq_trees t1 t2
    | _ -> s1 = s2
  and eq_trees t1 t2 =
    match t1, t2 with
      Node n1, Node n2 ->
        eq_symbols n1.node n2.node && eq_trees n1.son n2.son &&
        eq_trees n1.brother n2.brother
    | (LocAct (_, _) | DeadEnd), (LocAct (_, _) | DeadEnd) -> true
    | _ -> false
  in
  eq_symbols
;;

(* [delete_rule_in_tree] returns
     [Some (dsl, t)] if success
        [dsl] =
           Some (list of deleted nodes) if branch deleted
           None if action replaced by previous version of action
        [t] = remaining tree
     [None] if failure *)

let delete_rule_in_tree entry =
  let rec delete_in_tree symbols tree =
    match symbols, tree with
      s :: sl, Node n ->
        if logically_eq_symbols entry s n.node then delete_son sl n
        else
          begin match delete_in_tree symbols n.brother with
            Some (dsl, t) ->
              Some (dsl, Node {node = n.node; son = n.son; brother = t})
          | None -> None
          end
    | s :: sl, _ -> None
    | [], Node n ->
        begin match delete_in_tree [] n.brother with
          Some (dsl, t) ->
            Some (dsl, Node {node = n.node; son = n.son; brother = t})
        | None -> None
        end
    | [], DeadEnd -> None
    | [], LocAct (_, []) -> Some (Some [], DeadEnd)
    | [], LocAct (_, (action :: list)) -> Some (None, LocAct (action, list))
  and delete_son sl n =
    match delete_in_tree sl n.son with
      Some (Some dsl, DeadEnd) -> Some (Some (n.node :: dsl), n.brother)
    | Some (Some dsl, t) ->
        let t = Node {node = n.node; son = t; brother = n.brother} in
        Some (Some (n.node :: dsl), t)
    | Some (None, t) ->
        let t = Node {node = n.node; son = t; brother = n.brother} in
        Some (None, t)
    | None -> None
  in
  delete_in_tree
;;

let rec decr_keyw_use gram =
  function
    Stoken tok ->
      let r = Hashtbl.find gram.gtokens tok in
      decr r;
      if !r == 0 then
        begin
          Hashtbl.remove gram.gtokens tok; gram.glexer.Token.removing tok
        end
  | Slist0 s -> decr_keyw_use gram s
  | Slist1 s -> decr_keyw_use gram s
  | Slist0sep (s1, s2) -> decr_keyw_use gram s1; decr_keyw_use gram s2
  | Slist1sep (s1, s2) -> decr_keyw_use gram s1; decr_keyw_use gram s2
  | Sopt s -> decr_keyw_use gram s
  | Stree t -> decr_keyw_use_in_tree gram t
  | _ -> ()
and decr_keyw_use_in_tree gram =
  function
    DeadEnd | LocAct (_, _) -> ()
  | Node n ->
      decr_keyw_use gram n.node;
      decr_keyw_use_in_tree gram n.son;
      decr_keyw_use_in_tree gram n.brother
;;

let rec delete_rule_in_suffix entry symbols =
  function
    lev :: levs ->
      begin match delete_rule_in_tree entry symbols lev.lsuffix with
        Some (dsl, t) ->
          begin match dsl with
            Some dsl -> List.iter (decr_keyw_use entry.egram) dsl
          | None -> ()
          end;
          begin match t with
            DeadEnd when lev.lprefix == DeadEnd -> levs
          | _ ->
              let lev =
                {assoc = lev.assoc; lname = lev.lname; lsuffix = t;
                 lprefix = lev.lprefix}
              in
              lev :: levs
          end
      | None ->
          let levs = delete_rule_in_suffix entry symbols levs in lev :: levs
      end
  | [] -> raise Not_found
;;

let rec delete_rule_in_prefix entry symbols =
  function
    lev :: levs ->
      begin match delete_rule_in_tree entry symbols lev.lprefix with
        Some (dsl, t) ->
          begin match dsl with
            Some dsl -> List.iter (decr_keyw_use entry.egram) dsl
          | None -> ()
          end;
          begin match t with
            DeadEnd when lev.lsuffix == DeadEnd -> levs
          | _ ->
              let lev =
                {assoc = lev.assoc; lname = lev.lname; lsuffix = lev.lsuffix;
                 lprefix = t}
              in
              lev :: levs
          end
      | None ->
          let levs = delete_rule_in_prefix entry symbols levs in lev :: levs
      end
  | [] -> raise Not_found
;;

let rec delete_rule_in_level_list entry symbols levs =
  match symbols with
    Sself :: symbols -> delete_rule_in_suffix entry symbols levs
  | Snterm e :: symbols when e == entry ->
      delete_rule_in_suffix entry symbols levs
  | _ -> delete_rule_in_prefix entry symbols levs
;;