ocaml/camlp4/lib/gramext.ml

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

(* $Id$ *)

open Printf;

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

type g_entry =
  { egram : grammar;
    ename : string;
    estart : mutable int -> Stream.t Token.t -> Obj.t;
    econtinue : mutable int -> int -> Obj.t -> Stream.t Token.t -> Obj.t;
    edesc : mutable g_desc }
and g_desc =
  [ Dlevels of list g_level
  | Dparser of Stream.t Token.t -> Obj.t ]
and g_level =
  { assoc : g_assoc;
    lname : option string;
    lsuffix : g_tree;
    lprefix : g_tree }
and g_assoc =
  [ NonA
  | RightA
  | LeftA ]
and g_symbol =
  [ Snterm of g_entry
  | Snterml of g_entry and string
  | Slist0 of g_symbol
  | Slist0sep of g_symbol and g_symbol
  | Slist1 of g_symbol
  | Slist1sep of g_symbol and 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 and list g_action
  | 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 ]
;

value warning_verbose = ref True;

value rec derive_eps =
  fun
  [ Slist0 _ -> True
  | Slist0sep _ _ -> True
  | Sopt _ -> True
  | Stree t -> tree_derive_eps t
  | _ -> False ]
and tree_derive_eps =
  fun
  [ LocAct _ _ -> True
  | Node {node = s; brother = bro; son = son} ->
      derive_eps s && tree_derive_eps son || tree_derive_eps bro
  | _ -> False ]
;

value 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 ]
;

value 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 ]
;

value insert_tree entry_name 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 ->
            do {
              if warning_verbose.val then do {
                eprintf "<W> Grammar extension: ";
                if entry_name <> "" then eprintf "in [%s], " entry_name
                else ();
                eprintf "some rule has been masked\n";
                flush stderr
              }
              else ();
              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
          match try_insert s sl bro with
          [ Some bro ->
              let t = Node {node = s1; son = son; brother = bro} in
              Some t
          | None -> None ]
    | _ -> None ]
  and insert_new =
    fun
    [ [s :: sl] -> Node {node = s; son = insert_new sl; brother = DeadEnd}
    | [] -> LocAct action [] ]
  in
  insert gsymbols tree
;

value 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";

value is_level_labelled n lev =
  match lev.lname with
  [ Some n1 -> n = n1
  | None -> False ]
;

value insert_level entry_name e1 symbols action slev =
  match e1 with
  [ True ->
      {assoc = slev.assoc; lname = slev.lname;
       lsuffix = insert_tree entry_name symbols action slev.lsuffix;
       lprefix = slev.lprefix}
  | False ->
      {assoc = slev.assoc; lname = slev.lname; lsuffix = slev.lsuffix;
       lprefix = insert_tree entry_name symbols action slev.lprefix} ]
;

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

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

value get_level entry position levs =
  match position with
  [ Some First -> ([], empty_lev, levs)
  | Some Last -> (levs, empty_lev, [])
  | Some (Level n) ->
      let rec get =
        fun
        [ [] ->
            do {
              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 =
        fun
        [ [] ->
            do {
              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 =
        fun
        [ [] ->
            do {
              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, []) ] ]
;

value rec check_gram entry =
  fun
  [ Snterm e ->
      if e.egram != entry.egram then do {
        eprintf "\
Error: entries \"%s\" and \"%s\" do not belong to the same grammar.\n"
          entry.ename e.ename;
        flush stderr;
        failwith "Grammar.extend error"
      }
      else ()
  | Snterml e _ ->
      if e.egram != entry.egram then do {
        eprintf "\
Error: entries \"%s\" and \"%s\" do not belong to the same grammar.\n"
          entry.ename e.ename;
        flush stderr;
        failwith "Grammar.extend error"
      }
      else ()
  | Slist0sep s t -> do { check_gram entry t; check_gram entry s }
  | Slist1sep s t -> do { 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 =
  fun
  [ Node {node = n; brother = bro; son = son} ->
      do {
        check_gram entry n;
        tree_check_gram entry bro;
        tree_check_gram entry son
      }
  | _ -> () ]
;

value change_to_self entry =
  fun
  [ Snterm e when e == entry -> Sself
  | x -> x ]
;

value get_initial entry =
  fun
  [ [Sself :: symbols] -> (True, symbols)
  | symbols -> (False, symbols) ]
;

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

value levels_of_rules entry position rules =
  let elev =
    match entry.edesc with
    [ Dlevels elev -> elev
    | Dparser _ ->
        do {
          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
                  do {
                    List.iter (check_gram entry) symbols;
                    let (e1, symbols) = get_initial entry symbols in
                    insert_tokens entry.egram symbols;
                    insert_level entry.ename e1 symbols action lev
                  })
               lev level
           in
           ([lev :: levs], empty_lev))
        ([], make_lev) rules
    in
    levs1 @ List.rev levs @ levs2
;

value 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 *)

value 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
          match delete_in_tree symbols n.brother with
          [ Some (dsl, t) ->
              Some (dsl, Node {node = n.node; son = n.son; brother = t})
          | None -> None ]
    | ([s :: sl], _) -> None
    | ([], Node n) ->
        match delete_in_tree [] n.brother with
        [ Some (dsl, t) ->
            Some (dsl, Node {node = n.node; son = n.son; brother = t})
        | None -> None ]
    | ([], 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
;

value rec decr_keyw_use gram =
  fun
  [ Stoken tok ->
      let r = Hashtbl.find gram.gtokens tok in
      do {
        decr r;
        if r.val == 0 then do {
          Hashtbl.remove gram.gtokens tok; gram.glexer.Token.removing tok
        }
        else ()
      }
  | Slist0 s -> decr_keyw_use gram s
  | Slist1 s -> decr_keyw_use gram s
  | Slist0sep s1 s2 -> do { decr_keyw_use gram s1; decr_keyw_use gram s2 }
  | Slist1sep s1 s2 -> do { 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 =
  fun
  [ DeadEnd | LocAct _ _ -> ()
  | Node n ->
      do {
        decr_keyw_use gram n.node;
        decr_keyw_use_in_tree gram n.son;
        decr_keyw_use_in_tree gram n.brother
      } ]
;

value rec delete_rule_in_suffix entry symbols =
  fun
  [ [lev :: levs] ->
      match delete_rule_in_tree entry symbols lev.lsuffix with
      [ Some (dsl, t) ->
          do {
            match dsl with
            [ Some dsl -> List.iter (decr_keyw_use entry.egram) dsl
            | None -> () ];
            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] ]
          }
      | None ->
          let levs = delete_rule_in_suffix entry symbols levs in
          [lev :: levs] ]
  | [] -> raise Not_found ]
;

value rec delete_rule_in_prefix entry symbols =
  fun
  [ [lev :: levs] ->
      match delete_rule_in_tree entry symbols lev.lprefix with
      [ Some (dsl, t) ->
          do {
            match dsl with
            [ Some dsl -> List.iter (decr_keyw_use entry.egram) dsl
            | None -> () ];
            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] ]
          }
      | None ->
          let levs = delete_rule_in_prefix entry symbols levs in
          [lev :: levs] ]
  | [] -> raise Not_found ]
;

value 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 ]
;