src/grammar.ml

   1 INCLUDE "utils.ml"
   2 INCLUDE "debug.ml"
   3 INCLUDE "trace.ml"
   4
   5
   6 type t
   7
   8 type node = [ `Grammar ] Node.t
   9
  10 type p_type  = [ `Parameter ]
  11 type n_type = [ `NonTerminal ]
  12 type t_type = [ `Terminal ]
  13 type any_type = [ p_type | n_type | t_type ]
  14 type symbol = [ any_type ] Node.t
  15
  16 type p_symbol = p_type Node.t
  17 type n_symbol = n_type Node.t
  18 type t_symbol = t_type Node.t
  19 type tn_symbol = [ n_type | t_type ] Node.t
  20
  21 type partial = Node of tn_symbol * partial array | Leaf of node
  22
  23
  24
  25
  26 external is_nil : t -> t_symbol -> bool = "caml_grammar_is_nil"
  27 external translate_tag : t -> Tag.t -> Tag.t = "caml_grammar_translate_tag"
  28 external to_string : t -> Tag.t -> string = "caml_grammar_get_tag"
  29 external register_tag : t -> string -> Tag.t = "caml_grammar_register_tag"
  30
  31
  32
  33 let tag_operations t = {
  34   Tag.tag = (fun s -> register_tag t s);
  35   Tag.to_string = (fun s -> to_string t s);
  36   Tag.translate = (fun s -> translate_tag t s);
  37 }
  38
  39 external get_symbol_at : t -> symbol -> node -> symbol = "caml_grammar_get_symbol_at"
  40 external first_child : t -> symbol -> node -> node = "caml_grammar_first_child"
  41 external next_sibling : t -> symbol -> node -> node = "caml_grammar_next_sibling"
  42
  43
  44 let is_non_terminal (n : [< any_type ] Node.t) =
  45   let n = Node.to_int n in
  46   n land 3 == 0
  47
  48 let is_terminal (n : [< any_type ] Node.t) =
  49   let n = Node.to_int n in
  50   n land 3 == 1
  51
  52 let is_parameter (n : [< any_type ] Node.t) =
  53   let n = Node.to_int n in
  54   n land 3 == 2
  55
  56
  57 let symbol_tag (n : t_symbol) = (Node.to_int n) lsr 2
  58 ;;
  59 let tag = symbol_tag
  60 let get_tag g (n : t_symbol) = to_string g (symbol_tag n)
  61
  62
  63
  64 external parameter : [< any_type ] Node.t -> p_symbol = "%identity"
  65 external terminal : [< any_type ] Node.t -> t_symbol = "%identity"
  66 external non_terminal : [< any_type ] Node.t -> n_symbol = "%identity"
  67
  68 external get_id1 : t -> n_symbol -> tn_symbol = "caml_grammar_get_id1"
  69 external get_id2 : t -> n_symbol -> tn_symbol = "caml_grammar_get_id2"
  70 external get_param_pos : t -> n_symbol -> int = "caml_grammar_get_param_pos"
  71
  72
  73 let num_params (n : n_symbol) =
  74   let n = Node.to_int n in
  75   (n lsr 2) land 0xf
  76
  77 let num_children (n : [< t_type | n_type ] Node.t ) =
  78   if is_non_terminal n then
  79     num_params (non_terminal n)
  80   else
  81     2
  82
  83
  84 external load : Unix.file_descr -> bool -> t = "caml_grammar_load"
  85
  86 let traversal g =
  87   let start_symbol = (Node.of_int 0) in
  88   let dummy_leaf = Leaf (Node.nil) in
  89   let rec start_loop idx =
  90     TRACE("grammar", 2, __ "start_loop %a\n%!" Node.print idx);
  91     if idx >= Node.null then begin
  92       let symbol = get_symbol_at g start_symbol idx in
  93       if is_terminal symbol then
  94         let () = ();TRACE("grammar", 2, __ "Symbol %a is terminal\n%!" Node.print symbol); in
  95         let ts = terminal symbol in
  96         if is_nil g ts then (TRACE("grammar", 2, __ "Symbol %a is nil\n%!" Node.print symbol)) else
  97 (*        let str = get_tag g ts in
  98           Printf.printf "<%s>%!" str; *)
  99           let fs = first_child g start_symbol idx in
 100           start_loop fs;
 101           start_loop (next_sibling g start_symbol fs);
 102 (*        Printf.printf "</%s>%!" str; *)
 103       else
 104         let tn = non_terminal symbol in
 105         let nparam = num_params tn in
 106         let child = ref (first_child g start_symbol idx) in
 107         let a_param = Array.init nparam
 108           (fun _ -> let c = !child in
 109                     child := next_sibling g start_symbol c;
 110                     Leaf c)
 111         in
 112         rule_loop tn a_param
 113     end
 114
 115   and rule_loop (t : n_symbol) a_param =
 116     TRACE("grammar", 2, __ "rule_loop %a, (%i) \n%!" Node.print t (Array.length a_param));
 117     let id1 = get_id1 g t in
 118     let id2 = get_id2 g t in
 119     let param_pos = get_param_pos g t in
 120     let nparam1 = num_children id1 in
 121     let nparam2 = if is_terminal id2 && is_nil g (terminal id2) then 0 else num_children id2 in
 122     let a_param1 = Array.create nparam1 dummy_leaf in
 123     let a_param2 = Array.create nparam2 dummy_leaf in
 124     let i = param_pos - 2 in
 125     TRACE("grammar", 2, __ "id1: %i, id2: %i, param_pos: %i, nparam1: %i, nparam2: %i, i: %i\n%!"
 126       (Node.to_int id1) (Node.to_int id2) param_pos nparam1 nparam2 i);
 127
 128     TRACE("grammar", 2, __ "blit a(%i) %i b(%i) %i %i\n%!"
 129       (Array.length a_param) 0 (Array.length a_param1) 0 (i+1));
 130
 131     Array.blit a_param 0 a_param1 0 (i+1);  (* Pass parameters before id2 *)
 132     a_param1.(i+1) <- Node(id2, a_param2);  (* id2( ... ) *)
 133
 134     TRACE("grammar", 2, __ "blit a(%i) %i b(%i) %i %i\n%!"
 135       (Array.length a_param) (i + nparam2 + 1) (Array.length a_param1) (i+2) (nparam1 - i - 2));
 136     Array.blit a_param (i + nparam2 + 1) a_param1 (i+2) (nparam1 - i - 2); (* Pass parameters after id2 *)
 137
 138
 139
 140     TRACE("grammar", 2, __ "blit a(%i) %i b(%i) %i %i\n\n\n%!"
 141       (Array.length a_param) (i + 1) (Array.length a_param2) 0 (nparam2));
 142     Array.blit a_param (i + 1) a_param2 0 nparam2; (* parameters below id2 *)
 143     if is_non_terminal id1 then
 144       let id1 = non_terminal id1 in
 145       rule_loop id1 a_param1
 146     else
 147       let id1 = terminal id1 in
 148       terminal_loop id1 a_param1
 149
 150   and terminal_loop (t : t_symbol) a_param =
 151     if is_nil g t then () else begin
 152 (*      let str = get_tag g t in *)
 153 (*      Printf.printf "<%s>%!" str; *)
 154       partial_loop a_param.(0);
 155       partial_loop a_param.(1)
 156 (*      Printf.printf "</%s>%!" str *)
 157     end
 158   and partial_loop = function
 159     | Leaf id -> start_loop id
 160     | Node (id, a_param) ->
 161       if is_terminal id then terminal_loop (terminal id) a_param
 162       else rule_loop (non_terminal id) a_param
 163   in
 164
 165   start_loop (Node.null)
 166 ;;
 167
 168
 169
 170 let load filename bp =
 171   let fd = Unix.openfile filename [ Unix.O_RDONLY ] 0o600 in
 172   let g =
 173     try load fd bp with
 174     | e -> (Unix.close fd; raise e)
 175   in
 176   Unix.close fd;
 177   Tag.init (tag_operations g);
 178   g
 179
 180