1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187
|
(**************************************************************************)
(* *)
(* Menhir *)
(* *)
(* Franois Pottier and Yann Rgis-Gianas, INRIA Rocquencourt *)
(* *)
(* Copyright 2005 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed *)
(* under the terms of the Q Public License version 1.0, with the *)
(* change described in file LICENSE. *)
(* *)
(**************************************************************************)
open Positions
open Misc
open Syntax
open Stretch
open UnparameterizedSyntax
let print_preludes f g =
List.iter (fun prelude ->
Printf.fprintf f "%%{%s%%}\n" prelude.stretch_raw_content
) g.preludes
let print_start_symbols b g =
StringSet.iter (fun symbol ->
Printf.fprintf b "%%start %s\n" (Misc.normalize symbol)
) g.start_symbols
let rec insert_in_partitions item m = function
| [] ->
[ (m, [ item ]) ]
| (m', items) :: partitions when Mark.same m m' ->
(m', item :: items) :: partitions
| t :: partitions ->
t :: (insert_in_partitions item m partitions)
let insert (undefined, partitions) = function
| (item, UndefinedPrecedence) ->
((item, 0) :: undefined, partitions)
| (item, PrecedenceLevel (m, v, _, _)) ->
(undefined, insert_in_partitions (item, v) m partitions)
let print_ocamltype ocamltype =
Printf.sprintf " <%s>" (
match ocamltype with
| Declared stretch ->
stretch.stretch_raw_content
| Inferred t ->
t
)
let print_assoc = function
| LeftAssoc ->
Printf.sprintf "%%left"
| RightAssoc ->
Printf.sprintf "%%right"
| NonAssoc ->
Printf.sprintf "%%nonassoc"
| UndefinedAssoc ->
""
let print_tokens b g =
(* Sort tokens wrt precedence. *)
let undefined, partition_tokens =
StringMap.fold (fun token prop acu ->
insert acu (token, prop.tk_priority)
) g.tokens ([], [])
in
let ordered_tokens =
List.fold_left (fun acu (_, ms) ->
acu @ List.sort (fun (_, v) (_, v') -> compare v v') ms
) undefined partition_tokens
in
List.iter (fun (token, _) ->
let prop = StringMap.find token g.tokens in
if prop.tk_is_declared then
Printf.fprintf b "%%token%s %s\n"
(Misc.o2s prop.tk_ocamltype print_ocamltype) token
) ordered_tokens;
ignore (List.fold_left
(fun last_prop (token, v) ->
let prop = StringMap.find token g.tokens in
match last_prop with
| None ->
if prop.tk_associativity = UndefinedAssoc then
None
else (
Printf.fprintf b "%s %s "
(print_assoc prop.tk_associativity) token;
Some v)
| Some v' when v <> v' ->
if prop.tk_associativity = UndefinedAssoc then
None
else (
Printf.fprintf b "\n%s %s "
(print_assoc prop.tk_associativity) token;
Some v)
| Some v' ->
Printf.fprintf b "%s " token;
last_prop
) None ordered_tokens);
Printf.fprintf b "\n"
let print_types b g =
StringMap.iter (fun symbol ty ->
Printf.fprintf b "%%type%s %s\n"
(print_ocamltype ty) (Misc.normalize symbol)
) g.types
let string_of_producer (symbol, ido) =
(Misc.o2s ido (fun id -> id ^ " = ")) ^ (Misc.normalize symbol)
let print_branch f branch =
Printf.fprintf f "%s%s\n {"
(String.concat " " (List.map string_of_producer branch.producers))
(Misc.o2s branch.branch_shift_precedence (fun x -> " %prec "^x.value));
Action.print f branch.action;
Printf.fprintf f "}\n"
let print_trailers b g =
List.iter (Printf.fprintf b "%s\n") g.postludes
let branches_order r r' =
let branch_order b b' =
match b.branch_reduce_precedence, b'.branch_reduce_precedence with
| UndefinedPrecedence, _ | _, UndefinedPrecedence ->
0
| PrecedenceLevel (m, l, _, _), PrecedenceLevel (m', l', _, _) ->
if Mark.same m m' then
if l < l' then
-1
else if l > l' then
1
else
0
else 0
in
let rec lexical_order bs bs' =
match bs, bs' with
| [], [] ->
0
| [], _ ->
-1
| _, [] ->
1
| b :: bs, b' :: bs' ->
match branch_order b b' with
| 0 ->
lexical_order bs bs'
| x ->
x
in
lexical_order r.branches r'.branches
let print_rules b g =
let rules_as_list =
StringMap.fold (fun nt r acu -> (nt, r) :: acu) g.rules []
in
let ordered_rules =
List.sort (fun (nt, r) (nt', r') -> branches_order r r') rules_as_list
in
List.iter (fun (nt, r) ->
Printf.fprintf b "\n%s:\n" (Misc.normalize nt);
List.iter (fun br ->
Printf.fprintf b "| ";
print_branch b br
) r.branches
) ordered_rules
let print f g =
print_preludes f g;
print_start_symbols f g;
print_tokens f g;
print_types f g;
Printf.fprintf f "%%%%\n";
print_rules f g;
Printf.fprintf f "\n%%%%\n";
print_trailers f g
|