← Back to branch summary

~ubuntu-branches/ubuntu/vivid/menhir/vivid

« back to all changes in this revision

Viewing changes to unparameterizedPrinter.ml

  • Committer: Bazaar Package Importer
  • Author(s): Samuel Mimram
  • Date: 2006-07-11 12:26:18 UTC
  • Revision ID: james.westby@ubuntu.com-20060711122618-dea56bmjs3qlmsd8
Tags: upstream-20060615.dfsg
Import upstream version 20060615.dfsg

Show diffs side-by-side

added added

removed removed

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