2 * Copyright 2010, INRIA, University of Copenhagen
3 * Julia Lawall, Rene Rydhof Hansen, Gilles Muller, Nicolas Palix
4 * Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
5 * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller, Nicolas Palix
6 * This file is part of Coccinelle.
8 * Coccinelle is free software: you can redistribute it and/or modify
9 * it under the terms of the GNU General Public License as published by
10 * the Free Software Foundation, according to version 2 of the License.
12 * Coccinelle is distributed in the hope that it will be useful,
13 * but WITHOUT ANY WARRANTY; without even the implied warranty of
14 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 * GNU General Public License for more details.
17 * You should have received a copy of the GNU General Public License
18 * along with Coccinelle. If not, see <http://www.gnu.org/licenses/>.
20 * The authors reserve the right to distribute this or future versions of
21 * Coccinelle under other licenses.
26 * Copyright 2010, INRIA, University of Copenhagen
27 * Julia Lawall, Rene Rydhof Hansen, Gilles Muller, Nicolas Palix
28 * Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
29 * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller, Nicolas Palix
30 * This file is part of Coccinelle.
32 * Coccinelle is free software: you can redistribute it and/or modify
33 * it under the terms of the GNU General Public License as published by
34 * the Free Software Foundation, according to version 2 of the License.
36 * Coccinelle is distributed in the hope that it will be useful,
37 * but WITHOUT ANY WARRANTY; without even the implied warranty of
38 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
39 * GNU General Public License for more details.
41 * You should have received a copy of the GNU General Public License
42 * along with Coccinelle. If not, see <http://www.gnu.org/licenses/>.
44 * The authors reserve the right to distribute this or future versions of
45 * Coccinelle under other licenses.
49 (* Detects subtrees that are all minus/plus and nodes that are "binding
50 context nodes". The latter is a node whose structure and immediate tokens
51 are the same in the minus and plus trees, and such that for every child,
52 the set of context nodes in the child subtree is the same in the minus and
55 module Ast
= Ast_cocci
56 module Ast0
= Ast0_cocci
57 module V0
= Visitor_ast0
58 module VT0
= Visitor_ast0_types
59 module U
= Unparse_ast0
61 (* --------------------------------------------------------------------- *)
62 (* Generic access to code *)
64 let set_mcodekind x mcodekind
=
66 Ast0.DotsExprTag
(d
) -> Ast0.set_mcodekind d mcodekind
67 | Ast0.DotsInitTag
(d
) -> Ast0.set_mcodekind d mcodekind
68 | Ast0.DotsParamTag
(d
) -> Ast0.set_mcodekind d mcodekind
69 | Ast0.DotsStmtTag
(d
) -> Ast0.set_mcodekind d mcodekind
70 | Ast0.DotsDeclTag
(d
) -> Ast0.set_mcodekind d mcodekind
71 | Ast0.DotsCaseTag
(d
) -> Ast0.set_mcodekind d mcodekind
72 | Ast0.IdentTag
(d
) -> Ast0.set_mcodekind d mcodekind
73 | Ast0.ExprTag
(d
) -> Ast0.set_mcodekind d mcodekind
74 | Ast0.ArgExprTag
(d
) | Ast0.TestExprTag
(d
) ->
75 failwith
"not possible - iso only"
76 | Ast0.TypeCTag
(d
) -> Ast0.set_mcodekind d mcodekind
77 | Ast0.ParamTag
(d
) -> Ast0.set_mcodekind d mcodekind
78 | Ast0.DeclTag
(d
) -> Ast0.set_mcodekind d mcodekind
79 | Ast0.InitTag
(d
) -> Ast0.set_mcodekind d mcodekind
80 | Ast0.StmtTag
(d
) -> Ast0.set_mcodekind d mcodekind
81 | Ast0.CaseLineTag
(d
) -> Ast0.set_mcodekind d mcodekind
82 | Ast0.TopTag
(d
) -> Ast0.set_mcodekind d mcodekind
83 | Ast0.IsoWhenTag
(_
) -> failwith
"only within iso phase"
84 | Ast0.IsoWhenTTag
(_
) -> failwith
"only within iso phase"
85 | Ast0.IsoWhenFTag
(_
) -> failwith
"only within iso phase"
86 | Ast0.MetaPosTag
(p
) -> failwith
"metapostag only within iso phase"
88 let set_index x index
=
90 Ast0.DotsExprTag
(d
) -> Ast0.set_index d index
91 | Ast0.DotsInitTag
(d
) -> Ast0.set_index d index
92 | Ast0.DotsParamTag
(d
) -> Ast0.set_index d index
93 | Ast0.DotsStmtTag
(d
) -> Ast0.set_index d index
94 | Ast0.DotsDeclTag
(d
) -> Ast0.set_index d index
95 | Ast0.DotsCaseTag
(d
) -> Ast0.set_index d index
96 | Ast0.IdentTag
(d
) -> Ast0.set_index d index
97 | Ast0.ExprTag
(d
) -> Ast0.set_index d index
98 | Ast0.ArgExprTag
(d
) | Ast0.TestExprTag
(d
) ->
99 failwith
"not possible - iso only"
100 | Ast0.TypeCTag
(d
) -> Ast0.set_index d index
101 | Ast0.ParamTag
(d
) -> Ast0.set_index d index
102 | Ast0.InitTag
(d
) -> Ast0.set_index d index
103 | Ast0.DeclTag
(d
) -> Ast0.set_index d index
104 | Ast0.StmtTag
(d
) -> Ast0.set_index d index
105 | Ast0.CaseLineTag
(d
) -> Ast0.set_index d index
106 | Ast0.TopTag
(d
) -> Ast0.set_index d index
107 | Ast0.IsoWhenTag
(_
) -> failwith
"only within iso phase"
108 | Ast0.IsoWhenTTag
(_
) -> failwith
"only within iso phase"
109 | Ast0.IsoWhenFTag
(_
) -> failwith
"only within iso phase"
110 | Ast0.MetaPosTag
(p
) -> failwith
"metapostag only within iso phase"
112 let get_index = function
113 Ast0.DotsExprTag
(d
) -> Index.expression_dots d
114 | Ast0.DotsInitTag
(d
) -> Index.initialiser_dots d
115 | Ast0.DotsParamTag
(d
) -> Index.parameter_dots d
116 | Ast0.DotsStmtTag
(d
) -> Index.statement_dots d
117 | Ast0.DotsDeclTag
(d
) -> Index.declaration_dots d
118 | Ast0.DotsCaseTag
(d
) -> Index.case_line_dots d
119 | Ast0.IdentTag
(d
) -> Index.ident d
120 | Ast0.ExprTag
(d
) -> Index.expression d
121 | Ast0.ArgExprTag
(d
) | Ast0.TestExprTag
(d
) ->
122 failwith
"not possible - iso only"
123 | Ast0.TypeCTag
(d
) -> Index.typeC d
124 | Ast0.ParamTag
(d
) -> Index.parameterTypeDef d
125 | Ast0.InitTag
(d
) -> Index.initialiser d
126 | Ast0.DeclTag
(d
) -> Index.declaration d
127 | Ast0.StmtTag
(d
) -> Index.statement d
128 | Ast0.CaseLineTag
(d
) -> Index.case_line d
129 | Ast0.TopTag
(d
) -> Index.top_level d
130 | Ast0.IsoWhenTag
(_
) -> failwith
"only within iso phase"
131 | Ast0.IsoWhenTTag
(_
) -> failwith
"only within iso phase"
132 | Ast0.IsoWhenFTag
(_
) -> failwith
"only within iso phase"
133 | Ast0.MetaPosTag
(p
) -> failwith
"metapostag only within iso phase"
135 (* --------------------------------------------------------------------- *)
136 (* Collect the line numbers of the plus code. This is used for disjunctions.
137 It is not completely clear why this is necessary, but it seems like an easy
138 fix for whatever is the problem that is discussed in disj_cases *)
140 let plus_lines = ref ([] : int list
)
143 let rec loop = function
146 match compare n x
with
150 | _
-> failwith
"not possible" in
151 plus_lines := loop !plus_lines
154 let rec loop = function
156 | [x
] -> if n
< x
then (min
,x
) else (x
,max
)
160 else if n
> x1
&& n
< x2
then (x1
,x2
) else loop (x2
::rest
) in
163 let collect_plus_lines top
=
166 let option_default = () in
167 let donothing r k e
= k e
in
168 let mcode (_
,_
,info
,mcodekind
,_
,_
) =
170 Ast0.PLUS _
-> insert info
.Ast0.pos_info
.Ast0.line_start
173 V0.flat_combiner
bind option_default
174 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
175 donothing donothing donothing donothing donothing donothing
176 donothing donothing donothing donothing donothing donothing donothing
177 donothing donothing in
178 fn.VT0.combiner_rec_top_level top
180 (* --------------------------------------------------------------------- *)
183 Neutral
| AllMarked
of Ast.count
| NotAllMarked
(* marked means + or - *)
185 (* --------------------------------------------------------------------- *)
186 (* The first part analyzes each of the minus tree and the plus tree
189 (* ints are unique token indices (offset field) *)
191 Token
(* tokens *) of kind
* int (* unique index *) * Ast0.mcodekind
*
192 int list
(* context tokens *)
193 | Recursor
(* children *) of kind
*
194 int list
(* indices of all tokens at the level below *) *
195 Ast0.mcodekind list
(* tokens at the level below *) *
197 | Bind
(* neighbors *) of kind
*
198 int list
(* indices of all tokens at current level *) *
199 Ast0.mcodekind list
(* tokens at current level *) *
200 int list
(* indices of all tokens at the level below *) *
201 Ast0.mcodekind list
(* tokens at the level below *)
204 let kind2c = function
206 | AllMarked _
-> "allmarked"
207 | NotAllMarked
-> "notallmarked"
209 let node2c = function
210 Token
(k
,_
,_
,_
) -> Printf.sprintf
"token %s\n" (kind2c k
)
211 | Recursor
(k
,_
,_
,_
) -> Printf.sprintf
"recursor %s\n" (kind2c k
)
212 | Bind
(k
,_
,_
,_
,_
,_
) -> Printf.sprintf
"bind %s\n" (kind2c k
)
214 (* goal: detect negative in both tokens and recursors, or context only in
218 (k1
,k2
) when k1
= k2
-> k1
219 | (Neutral
,AllMarked c
) -> AllMarked c
220 | (AllMarked c
,Neutral
) -> AllMarked c
221 | _
-> NotAllMarked
in
224 (* there are tokens at this level, so ignore the level below *)
225 (Token
(k1
,i1
,t1
,l1
),Token
(k2
,i2
,t2
,l2
)) ->
226 Bind
(lub(k1
,k2
),[i1
;i2
],[t1
;t2
],[],[],[l1
;l2
])
229 (* there are tokens at this level, so ignore the level below *)
230 | (Token
(k1
,i1
,t1
,l1
),Recursor
(k2
,_
,_
,l2
)) ->
231 Bind
(lub(k1
,k2
),[i1
],[t1
],[],[],[l1
;l2
])
232 | (Recursor
(k1
,_
,_
,l1
),Token
(k2
,i2
,t2
,l2
)) ->
233 Bind
(lub(k1
,k2
),[i2
],[t2
],[],[],[l1
;l2
])
236 (* there are tokens at this level, so ignore the level below *)
237 | (Token
(k1
,i1
,t1
,l1
),Bind
(k2
,i2
,t2
,_
,_
,l2
)) ->
238 Bind
(lub(k1
,k2
),i1
::i2
,t1
::t2
,[],[],l1
::l2
)
239 | (Bind
(k1
,i1
,t1
,_
,_
,l1
),Token
(k2
,i2
,t2
,l2
)) ->
240 Bind
(lub(k1
,k2
),i1
@[i2
],t1
@[t2
],[],[],l1
@[l2
])
243 | (Recursor
(k1
,bi1
,bt1
,l1
),Bind
(k2
,i2
,t2
,bi2
,bt2
,l2
)) ->
244 Bind
(lub(k1
,k2
),i2
,t2
,bi1
@bi2
,bt1
@bt2
,l1
::l2
)
245 | (Bind
(k1
,i1
,t1
,bi1
,bt1
,l1
),Recursor
(k2
,bi2
,bt2
,l2
)) ->
246 Bind
(lub(k1
,k2
),i1
,t1
,bi1
@bi2
,bt1
@bt2
,l1
@[l2
])
248 (* recursor/recursor and bind/bind - not likely to ever occur *)
249 | (Recursor
(k1
,bi1
,bt1
,l1
),Recursor
(k2
,bi2
,bt2
,l2
)) ->
250 Bind
(lub(k1
,k2
),[],[],bi1
@bi2
,bt1
@bt2
,[l1
;l2
])
251 | (Bind
(k1
,i1
,t1
,bi1
,bt1
,l1
),Bind
(k2
,i2
,t2
,bi2
,bt2
,l2
)) ->
252 Bind
(lub(k1
,k2
),i1
@i2
,t1
@t2
,bi1
@bi2
,bt1
@bt2
,l1
@l2
)
255 let option_default = (*Bind(Neutral,[],[],[],[],[])*)
256 Recursor
(Neutral
,[],[],[])
258 let mcode (_
,_
,info
,mcodekind
,pos
,_
) =
259 let offset = info
.Ast0.pos_info
.Ast0.offset in
261 Ast0.MINUS
(_
) -> Token
(AllMarked
Ast.ONE
,offset,mcodekind
,[])
262 | Ast0.PLUS c
-> Token
(AllMarked c
,offset,mcodekind
,[])
263 | Ast0.CONTEXT
(_
) -> Token
(NotAllMarked
,offset,mcodekind
,[offset])
264 | _
-> failwith
"not possible"
266 let neutral_mcode (_
,_
,info
,mcodekind
,pos
,_
) =
267 let offset = info
.Ast0.pos_info
.Ast0.offset in
269 Ast0.MINUS
(_
) -> Token
(Neutral
,offset,mcodekind
,[])
270 | Ast0.PLUS _
-> Token
(Neutral
,offset,mcodekind
,[])
271 | Ast0.CONTEXT
(_
) -> Token
(Neutral
,offset,mcodekind
,[offset])
272 | _
-> failwith
"not possible"
274 (* neutral for context; used for mcode in bef aft nodes that don't represent
275 anything if they don't contain some information *)
276 let nc_mcode (_
,_
,info
,mcodekind
,pos
,_
) =
277 (* distinguish from the offset of some real token *)
278 let offset = (-1) * info
.Ast0.pos_info
.Ast0.offset in
280 Ast0.MINUS
(_
) -> Token
(AllMarked
Ast.ONE
,offset,mcodekind
,[])
281 | Ast0.PLUS c
-> Token
(AllMarked c
,offset,mcodekind
,[])
283 (* Unlike the other mcode cases, we drop the offset from the context
284 offsets. This is because we don't know whether the term this is
285 associated with is - or context. In any case, the context offsets are
286 used for identification, and this invisible node should not be needed
288 Token
(Neutral
,offset,mcodekind
,[])
289 | _
-> failwith
"not possible"
291 let is_context = function Ast0.CONTEXT
(_
) -> true | _
-> false
293 let union_all l
= List.fold_left
Common.union_set
[] l
295 (* is minus is true when we are processing minus code that might be
296 intermingled with plus code. it is used in disj_cases *)
297 let classify is_minus all_marked table code
=
298 let mkres builder k il tl bil btl l e
=
301 Ast0.set_mcodekind e
(all_marked count
) (* definitive *)
303 let check_index il tl
=
304 if List.for_all
is_context tl
306 (let e1 = builder e
in
307 let index = (get_index e1)@il
in
309 let _ = Hashtbl.find table
index in
311 (Printf.sprintf
"line %d: index %s already used\n"
312 (Ast0.get_info e
).Ast0.pos_info
.Ast0.line_start
313 (String.concat
" " (List.map string_of_int
index)))
314 with Not_found
-> Hashtbl.add table
index (e1,l
)) in
315 if il
= [] then check_index bil btl
else check_index il tl
);
317 then Recursor
(k
, bil
, btl
, union_all l
)
318 else Recursor
(k
, il
, tl
, union_all l
) in
320 let compute_result builder e
= function
321 Bind
(k
,il
,tl
,bil
,btl
,l
) -> mkres builder k il tl bil btl l e
322 | Token
(k
,il
,tl
,l
) -> mkres builder k
[il
] [tl
] [] [] [l
] e
323 | Recursor
(k
,bil
,btl
,l
) -> mkres builder k
[] [] bil btl
[l
] e
in
325 let make_not_marked = function
326 Bind
(k
,il
,tl
,bil
,btl
,l
) -> Bind
(NotAllMarked
,il
,tl
,bil
,btl
,l
)
327 | Token
(k
,il
,tl
,l
) -> Token
(NotAllMarked
,il
,tl
,l
)
328 | Recursor
(k
,bil
,btl
,l
) -> Recursor
(NotAllMarked
,bil
,btl
,l
) in
330 let do_nothing builder r k e
= compute_result builder e
(k e
) in
332 let disj_cases disj starter code
fn ender
=
333 (* neutral_mcode used so starter and ender don't have an affect on
334 whether the code is considered all plus/minus, but so that they are
335 consider in the index list, which is needed to make a disj with
336 something in one branch and nothing in the other different from code
337 that just has the something (starter/ender enough, mids not needed
338 for this). Cannot agglomerate + code over | boundaries, because two -
339 cases might have different + code, and don't want to put the + code
340 together into one unit. *)
341 let make_not_marked =
344 (let min = Ast0.get_line disj
in
345 let max = Ast0.get_line_end disj
in
346 let (plus_min
,plus_max
) = find min (min-1) (max+1) in
347 if max > plus_max
then make_not_marked else (function x
-> x
))
348 else make_not_marked in
349 bind (neutral_mcode starter
)
350 (bind (List.fold_right
bind
351 (List.map
make_not_marked (List.map
fn code
))
353 (neutral_mcode ender
)) in
355 (* no whencode in plus tree so have to drop it *)
356 (* need special cases for dots, nests, and disjs *)
357 let expression r k e
=
358 compute_result Ast0.expr e
359 (match Ast0.unwrap e
with
360 Ast0.NestExpr
(starter
,exp
,ender
,whencode
,multi
) ->
361 k
(Ast0.rewrap e
(Ast0.NestExpr
(starter
,exp
,ender
,None
,multi
)))
362 | Ast0.Edots
(dots
,whencode
) ->
363 k
(Ast0.rewrap e
(Ast0.Edots
(dots
,None
)))
364 | Ast0.Ecircles
(dots
,whencode
) ->
365 k
(Ast0.rewrap e
(Ast0.Ecircles
(dots
,None
)))
366 | Ast0.Estars
(dots
,whencode
) ->
367 k
(Ast0.rewrap e
(Ast0.Estars
(dots
,None
)))
368 | Ast0.DisjExpr
(starter
,expr_list
,_,ender
) ->
369 disj_cases e starter expr_list r
.VT0.combiner_rec_expression ender
372 (* not clear why we have the next two cases, since DisjDecl and
373 DisjType shouldn't have been constructed yet, as they only come from isos *)
374 let declaration r k e
=
375 compute_result Ast0.decl e
376 (match Ast0.unwrap e
with
377 Ast0.DisjDecl
(starter
,decls
,_,ender
) ->
378 disj_cases e starter decls r
.VT0.combiner_rec_declaration ender
379 | Ast0.Ddots
(dots
,whencode
) ->
380 k
(Ast0.rewrap e
(Ast0.Ddots
(dots
,None
)))
381 (* Need special cases for the following so that the type will be
382 considered as a unit, rather than distributed around the
383 declared variable. This needs to be done because of the call to
384 compute_result, ie the processing of each term should make a
385 side-effect on the complete term structure as well as collecting
386 some information about it. So we have to visit each complete
387 term structure. In (all?) other such cases, we visit the terms
388 using rebuilder, which just visits the subterms, rather than
389 reordering their components. *)
390 | Ast0.Init
(stg
,ty
,id
,eq
,ini
,sem
) ->
391 bind (match stg
with Some stg
-> mcode stg
| _ -> option_default)
392 (bind (r
.VT0.combiner_rec_typeC ty
)
393 (bind (r
.VT0.combiner_rec_ident id
)
395 (bind (r
.VT0.combiner_rec_initialiser ini
) (mcode sem
)))))
396 | Ast0.UnInit
(stg
,ty
,id
,sem
) ->
397 bind (match stg
with Some stg
-> mcode stg
| _ -> option_default)
398 (bind (r
.VT0.combiner_rec_typeC ty
)
399 (bind (r
.VT0.combiner_rec_ident id
) (mcode sem
)))
403 compute_result Ast0.param e
404 (match Ast0.unwrap e
with
405 Ast0.Param
(ty
,Some id
) ->
406 (* needed for the same reason as in the Init and UnInit cases *)
407 bind (r
.VT0.combiner_rec_typeC ty
) (r
.VT0.combiner_rec_ident id
)
411 compute_result Ast0.typeC e
412 (match Ast0.unwrap e
with
413 Ast0.DisjType
(starter
,types
,_,ender
) ->
414 disj_cases e starter types r
.VT0.combiner_rec_typeC ender
417 let initialiser r k i
=
418 compute_result Ast0.ini i
419 (match Ast0.unwrap i
with
420 Ast0.Idots
(dots
,whencode
) ->
421 k
(Ast0.rewrap i
(Ast0.Idots
(dots
,None
)))
424 let case_line r k e
=
425 compute_result Ast0.case_line e
426 (match Ast0.unwrap e
with
427 Ast0.DisjCase
(starter
,case_list
,_,ender
) ->
428 disj_cases e starter case_list r
.VT0.combiner_rec_case_line ender
431 let statement r k s
=
432 compute_result Ast0.stmt s
433 (match Ast0.unwrap s
with
434 Ast0.Nest
(started
,stm_dots
,ender
,whencode
,multi
) ->
435 k
(Ast0.rewrap s
(Ast0.Nest
(started
,stm_dots
,ender
,[],multi
)))
436 | Ast0.Dots
(dots
,whencode
) ->
437 k
(Ast0.rewrap s
(Ast0.Dots
(dots
,[])))
438 | Ast0.Circles
(dots
,whencode
) ->
439 k
(Ast0.rewrap s
(Ast0.Circles
(dots
,[])))
440 | Ast0.Stars
(dots
,whencode
) ->
441 k
(Ast0.rewrap s
(Ast0.Stars
(dots
,[])))
442 | Ast0.Disj
(starter
,statement_dots_list
,_,ender
) ->
443 disj_cases s starter statement_dots_list r
.VT0.combiner_rec_statement_dots
445 (* cases for everything with extra mcode *)
446 | Ast0.FunDecl
((info
,bef
),_,_,_,_,_,_,_,_)
447 | Ast0.Decl
((info
,bef
),_) ->
448 bind (nc_mcode ((),(),info
,bef
,(),-1)) (k s
)
449 | Ast0.IfThen
(_,_,_,_,_,(info
,aft
))
450 | Ast0.IfThenElse
(_,_,_,_,_,_,_,(info
,aft
))
451 | Ast0.Iterator
(_,_,_,_,_,(info
,aft
))
452 | Ast0.While
(_,_,_,_,_,(info
,aft
))
453 | Ast0.For
(_,_,_,_,_,_,_,_,_,(info
,aft
)) ->
454 bind (k s
) (nc_mcode ((),(),info
,aft
,(),-1))
459 let do_top builder r k e
= compute_result builder e
(k e
) in
462 V0.flat_combiner
bind option_default
463 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
464 (do_nothing Ast0.dotsExpr
) (do_nothing Ast0.dotsInit
)
465 (do_nothing Ast0.dotsParam
) (do_nothing Ast0.dotsStmt
)
466 (do_nothing Ast0.dotsDecl
) (do_nothing Ast0.dotsCase
)
467 (do_nothing Ast0.ident
) expression typeC initialiser param declaration
468 statement case_line (do_top Ast0.top
) in
469 combiner.VT0.combiner_rec_top_level code
471 (* --------------------------------------------------------------------- *)
472 (* Traverse the hash tables and find corresponding context nodes that have
473 the same context children *)
475 (* this is just a sanity check - really only need to look at the top-level
477 let equal_mcode (_,_,info1
,_,_,_) (_,_,info2
,_,_,_) =
478 info1
.Ast0.pos_info
.Ast0.offset = info2
.Ast0.pos_info
.Ast0.offset
480 let equal_option e1 e2
=
482 (Some x
, Some y
) -> equal_mcode x y
483 | (None
, None
) -> true
487 match (Ast0.unwrap d1
,Ast0.unwrap d2
) with
488 (Ast0.DOTS
(l1
),Ast0.DOTS
(l2
)) -> List.length l1
= List.length l2
489 | (Ast0.CIRCLES
(l1
),Ast0.CIRCLES
(l2
)) -> List.length l1
= List.length l2
490 | (Ast0.STARS
(l1
),Ast0.STARS
(l2
)) -> List.length l1
= List.length l2
493 let rec equal_ident i1 i2
=
494 match (Ast0.unwrap i1
,Ast0.unwrap i2
) with
495 (Ast0.Id
(name1
),Ast0.Id
(name2
)) -> equal_mcode name1 name2
496 | (Ast0.MetaId
(name1
,_,_),Ast0.MetaId
(name2
,_,_)) ->
497 equal_mcode name1 name2
498 | (Ast0.MetaFunc
(name1
,_,_),Ast0.MetaFunc
(name2
,_,_)) ->
499 equal_mcode name1 name2
500 | (Ast0.MetaLocalFunc
(name1
,_,_),Ast0.MetaLocalFunc
(name2
,_,_)) ->
501 equal_mcode name1 name2
502 | (Ast0.OptIdent
(_),Ast0.OptIdent
(_)) -> true
503 | (Ast0.UniqueIdent
(_),Ast0.UniqueIdent
(_)) -> true
506 let rec equal_expression e1 e2
=
507 match (Ast0.unwrap
e1,Ast0.unwrap e2
) with
508 (Ast0.Ident
(_),Ast0.Ident
(_)) -> true
509 | (Ast0.Constant
(const1
),Ast0.Constant
(const2
)) -> equal_mcode const1 const2
510 | (Ast0.FunCall
(_,lp1
,_,rp1
),Ast0.FunCall
(_,lp2
,_,rp2
)) ->
511 equal_mcode lp1 lp2
&& equal_mcode rp1 rp2
512 | (Ast0.Assignment
(_,op1
,_,_),Ast0.Assignment
(_,op2
,_,_)) ->
514 | (Ast0.CondExpr
(_,why1
,_,colon1
,_),Ast0.CondExpr
(_,why2
,_,colon2
,_)) ->
515 equal_mcode why1 why2
&& equal_mcode colon1 colon2
516 | (Ast0.Postfix
(_,op1
),Ast0.Postfix
(_,op2
)) -> equal_mcode op1 op2
517 | (Ast0.Infix
(_,op1
),Ast0.Infix
(_,op2
)) -> equal_mcode op1 op2
518 | (Ast0.Unary
(_,op1
),Ast0.Unary
(_,op2
)) -> equal_mcode op1 op2
519 | (Ast0.Binary
(_,op1
,_),Ast0.Binary
(_,op2
,_)) -> equal_mcode op1 op2
520 | (Ast0.Paren
(lp1
,_,rp1
),Ast0.Paren
(lp2
,_,rp2
)) ->
521 equal_mcode lp1 lp2
&& equal_mcode rp1 rp2
522 | (Ast0.ArrayAccess
(_,lb1
,_,rb1
),Ast0.ArrayAccess
(_,lb2
,_,rb2
)) ->
523 equal_mcode lb1 lb2
&& equal_mcode rb1 rb2
524 | (Ast0.RecordAccess
(_,pt1
,_),Ast0.RecordAccess
(_,pt2
,_)) ->
526 | (Ast0.RecordPtAccess
(_,ar1
,_),Ast0.RecordPtAccess
(_,ar2
,_)) ->
528 | (Ast0.Cast
(lp1
,_,rp1
,_),Ast0.Cast
(lp2
,_,rp2
,_)) ->
529 equal_mcode lp1 lp2
&& equal_mcode rp1 rp2
530 | (Ast0.SizeOfExpr
(szf1
,_),Ast0.SizeOfExpr
(szf2
,_)) ->
531 equal_mcode szf1 szf2
532 | (Ast0.SizeOfType
(szf1
,lp1
,_,rp1
),Ast0.SizeOfType
(szf2
,lp2
,_,rp2
)) ->
533 equal_mcode szf1 szf2
&& equal_mcode lp1 lp2
&& equal_mcode rp1 rp2
534 | (Ast0.TypeExp
(_),Ast0.TypeExp
(_)) -> true
535 | (Ast0.MetaErr
(name1
,_,_),Ast0.MetaErr
(name2
,_,_))
536 | (Ast0.MetaExpr
(name1
,_,_,_,_),Ast0.MetaExpr
(name2
,_,_,_,_))
537 | (Ast0.MetaExprList
(name1
,_,_),Ast0.MetaExprList
(name2
,_,_)) ->
538 equal_mcode name1 name2
539 | (Ast0.EComma
(cm1
),Ast0.EComma
(cm2
)) -> equal_mcode cm1 cm2
540 | (Ast0.DisjExpr
(starter1
,_,mids1
,ender1
),
541 Ast0.DisjExpr
(starter2
,_,mids2
,ender2
)) ->
542 equal_mcode starter1 starter2
&&
543 List.for_all2
equal_mcode mids1 mids2
&&
544 equal_mcode ender1 ender2
545 | (Ast0.NestExpr
(starter1
,_,ender1
,_,m1
),
546 Ast0.NestExpr
(starter2
,_,ender2
,_,m2
)) ->
547 equal_mcode starter1 starter2
&& equal_mcode ender1 ender2
&& m1
= m2
548 | (Ast0.Edots
(dots1
,_),Ast0.Edots
(dots2
,_))
549 | (Ast0.Ecircles
(dots1
,_),Ast0.Ecircles
(dots2
,_))
550 | (Ast0.Estars
(dots1
,_),Ast0.Estars
(dots2
,_)) -> equal_mcode dots1 dots2
551 | (Ast0.OptExp
(_),Ast0.OptExp
(_)) -> true
552 | (Ast0.UniqueExp
(_),Ast0.UniqueExp
(_)) -> true
555 let rec equal_typeC t1 t2
=
556 match (Ast0.unwrap t1
,Ast0.unwrap t2
) with
557 (Ast0.ConstVol
(cv1
,_),Ast0.ConstVol
(cv2
,_)) -> equal_mcode cv1 cv2
558 | (Ast0.BaseType
(ty1
,stringsa
),Ast0.BaseType
(ty2
,stringsb
)) ->
559 List.for_all2
equal_mcode stringsa stringsb
560 | (Ast0.Signed
(sign1
,_),Ast0.Signed
(sign2
,_)) ->
561 equal_mcode sign1 sign2
562 | (Ast0.Pointer
(_,star1
),Ast0.Pointer
(_,star2
)) ->
563 equal_mcode star1 star2
564 | (Ast0.Array
(_,lb1
,_,rb1
),Ast0.Array
(_,lb2
,_,rb2
)) ->
565 equal_mcode lb1 lb2
&& equal_mcode rb1 rb2
566 | (Ast0.EnumName
(kind1
,_),Ast0.EnumName
(kind2
,_)) ->
567 equal_mcode kind1 kind2
568 | (Ast0.EnumDef
(_,lb1
,_,rb1
),Ast0.EnumDef
(_,lb2
,_,rb2
)) ->
569 equal_mcode lb1 lb2
&& equal_mcode rb1 rb2
570 | (Ast0.StructUnionName
(kind1
,_),Ast0.StructUnionName
(kind2
,_)) ->
571 equal_mcode kind1 kind2
572 | (Ast0.FunctionType
(ty1
,lp1
,p1
,rp1
),Ast0.FunctionType
(ty2
,lp2
,p2
,rp2
)) ->
573 equal_mcode lp1 lp2
&& equal_mcode rp1 rp2
574 | (Ast0.StructUnionDef
(_,lb1
,_,rb1
),
575 Ast0.StructUnionDef
(_,lb2
,_,rb2
)) ->
576 equal_mcode lb1 lb2
&& equal_mcode rb1 rb2
577 | (Ast0.TypeName
(name1
),Ast0.TypeName
(name2
)) -> equal_mcode name1 name2
578 | (Ast0.MetaType
(name1
,_),Ast0.MetaType
(name2
,_)) ->
579 equal_mcode name1 name2
580 | (Ast0.DisjType
(starter1
,_,mids1
,ender1
),
581 Ast0.DisjType
(starter2
,_,mids2
,ender2
)) ->
582 equal_mcode starter1 starter2
&&
583 List.for_all2
equal_mcode mids1 mids2
&&
584 equal_mcode ender1 ender2
585 | (Ast0.OptType
(_),Ast0.OptType
(_)) -> true
586 | (Ast0.UniqueType
(_),Ast0.UniqueType
(_)) -> true
589 let equal_declaration d1 d2
=
590 match (Ast0.unwrap d1
,Ast0.unwrap d2
) with
591 (Ast0.MetaDecl
(name1
,_),Ast0.MetaDecl
(name2
,_))
592 | (Ast0.MetaField
(name1
,_),Ast0.MetaField
(name2
,_)) ->
593 equal_mcode name1 name2
594 | (Ast0.Init
(stg1
,_,_,eq1
,_,sem1
),Ast0.Init
(stg2
,_,_,eq2
,_,sem2
)) ->
595 equal_option stg1 stg2
&& equal_mcode eq1 eq2
&& equal_mcode sem1 sem2
596 | (Ast0.UnInit
(stg1
,_,_,sem1
),Ast0.UnInit
(stg2
,_,_,sem2
)) ->
597 equal_option stg1 stg2
&& equal_mcode sem1 sem2
598 | (Ast0.MacroDecl
(nm1
,lp1
,_,rp1
,sem1
),Ast0.MacroDecl
(nm2
,lp2
,_,rp2
,sem2
)) ->
599 equal_mcode lp1 lp2
&& equal_mcode rp1 rp2
&& equal_mcode sem1 sem2
600 | (Ast0.TyDecl
(_,sem1
),Ast0.TyDecl
(_,sem2
)) -> equal_mcode sem1 sem2
601 | (Ast0.Ddots
(dots1
,_),Ast0.Ddots
(dots2
,_)) -> equal_mcode dots1 dots2
602 | (Ast0.OptDecl
(_),Ast0.OptDecl
(_)) -> true
603 | (Ast0.UniqueDecl
(_),Ast0.UniqueDecl
(_)) -> true
604 | (Ast0.DisjDecl
_,_) | (_,Ast0.DisjDecl
_) ->
605 failwith
"DisjDecl not expected here"
608 let equal_designator d1 d2
=
610 (Ast0.DesignatorField
(dot1
,_),Ast0.DesignatorField
(dot2
,_)) ->
611 equal_mcode dot1 dot2
612 | (Ast0.DesignatorIndex
(lb1
,_,rb1
),Ast0.DesignatorIndex
(lb2
,_,rb2
)) ->
613 (equal_mcode lb1 lb2
) && (equal_mcode rb1 rb2
)
614 | (Ast0.DesignatorRange
(lb1
,_,dots1
,_,rb1
),
615 Ast0.DesignatorRange
(lb2
,_,dots2
,_,rb2
)) ->
616 (equal_mcode lb1 lb2
) && (equal_mcode dots1 dots2
) &&
617 (equal_mcode rb1 rb2
)
620 let equal_initialiser i1 i2
=
621 match (Ast0.unwrap i1
,Ast0.unwrap i2
) with
622 (Ast0.MetaInit
(name1
,_),Ast0.MetaInit
(name2
,_)) ->
623 equal_mcode name1 name2
624 | (Ast0.InitExpr
(_),Ast0.InitExpr
(_)) -> true
625 | (Ast0.InitList
(lb1
,_,rb1
,o1
),Ast0.InitList
(lb2
,_,rb2
,o2
)) ->
626 (* can't compare orderedness, because this can differ between -
628 (equal_mcode lb1 lb2
) && (equal_mcode rb1 rb2
)
629 | (Ast0.InitGccExt
(designators1
,eq1
,_),
630 Ast0.InitGccExt
(designators2
,eq2
,_)) ->
631 (List.for_all2
equal_designator designators1 designators2
) &&
632 (equal_mcode eq1 eq2
)
633 | (Ast0.InitGccName
(_,eq1
,_),Ast0.InitGccName
(_,eq2
,_)) ->
635 | (Ast0.IComma
(cm1
),Ast0.IComma
(cm2
)) -> equal_mcode cm1 cm2
636 | (Ast0.Idots
(d1
,_),Ast0.Idots
(d2
,_)) -> equal_mcode d1 d2
637 | (Ast0.OptIni
(_),Ast0.OptIni
(_)) -> true
638 | (Ast0.UniqueIni
(_),Ast0.UniqueIni
(_)) -> true
641 let equal_parameterTypeDef p1 p2
=
642 match (Ast0.unwrap p1
,Ast0.unwrap p2
) with
643 (Ast0.VoidParam
(_),Ast0.VoidParam
(_)) -> true
644 | (Ast0.Param
(_,_),Ast0.Param
(_,_)) -> true
645 | (Ast0.MetaParam
(name1
,_),Ast0.MetaParam
(name2
,_))
646 | (Ast0.MetaParamList
(name1
,_,_),Ast0.MetaParamList
(name2
,_,_)) ->
647 equal_mcode name1 name2
648 | (Ast0.PComma
(cm1
),Ast0.PComma
(cm2
)) -> equal_mcode cm1 cm2
649 | (Ast0.Pdots
(dots1
),Ast0.Pdots
(dots2
))
650 | (Ast0.Pcircles
(dots1
),Ast0.Pcircles
(dots2
)) -> equal_mcode dots1 dots2
651 | (Ast0.OptParam
(_),Ast0.OptParam
(_)) -> true
652 | (Ast0.UniqueParam
(_),Ast0.UniqueParam
(_)) -> true
655 let rec equal_statement s1 s2
=
656 match (Ast0.unwrap s1
,Ast0.unwrap s2
) with
657 (Ast0.FunDecl
(_,fninfo1
,_,lp1
,_,rp1
,lbrace1
,_,rbrace1
),
658 Ast0.FunDecl
(_,fninfo2
,_,lp2
,_,rp2
,lbrace2
,_,rbrace2
)) ->
659 (List.length fninfo1
) = (List.length fninfo2
) &&
660 List.for_all2 equal_fninfo fninfo1 fninfo2
&&
661 equal_mcode lp1 lp2
&& equal_mcode rp1 rp2
&&
662 equal_mcode lbrace1 lbrace2
&& equal_mcode rbrace1 rbrace2
663 | (Ast0.Decl
(_,_),Ast0.Decl
(_,_)) -> true
664 | (Ast0.Seq
(lbrace1
,_,rbrace1
),Ast0.Seq
(lbrace2
,_,rbrace2
)) ->
665 equal_mcode lbrace1 lbrace2
&& equal_mcode rbrace1 rbrace2
666 | (Ast0.ExprStatement
(_,sem1
),Ast0.ExprStatement
(_,sem2
)) ->
667 equal_mcode sem1 sem2
668 | (Ast0.IfThen
(iff1
,lp1
,_,rp1
,_,_),Ast0.IfThen
(iff2
,lp2
,_,rp2
,_,_)) ->
669 equal_mcode iff1 iff2
&& equal_mcode lp1 lp2
&& equal_mcode rp1 rp2
670 | (Ast0.IfThenElse
(iff1
,lp1
,_,rp1
,_,els1
,_,_),
671 Ast0.IfThenElse
(iff2
,lp2
,_,rp2
,_,els2
,_,_)) ->
672 equal_mcode iff1 iff2
&&
673 equal_mcode lp1 lp2
&& equal_mcode rp1 rp2
&& equal_mcode els1 els2
674 | (Ast0.While
(whl1
,lp1
,_,rp1
,_,_),Ast0.While
(whl2
,lp2
,_,rp2
,_,_)) ->
675 equal_mcode whl1 whl2
&& equal_mcode lp1 lp2
&& equal_mcode rp1 rp2
676 | (Ast0.Do
(d1
,_,whl1
,lp1
,_,rp1
,sem1
),Ast0.Do
(d2
,_,whl2
,lp2
,_,rp2
,sem2
)) ->
677 equal_mcode whl1 whl2
&& equal_mcode d1 d2
&&
678 equal_mcode lp1 lp2
&& equal_mcode rp1 rp2
&& equal_mcode sem1 sem2
679 | (Ast0.For
(fr1
,lp1
,_,sem11
,_,sem21
,_,rp1
,_,_),
680 Ast0.For
(fr2
,lp2
,_,sem12
,_,sem22
,_,rp2
,_,_)) ->
681 equal_mcode fr1 fr2
&& equal_mcode lp1 lp2
&&
682 equal_mcode sem11 sem12
&& equal_mcode sem21 sem22
&&
684 | (Ast0.Iterator
(nm1
,lp1
,_,rp1
,_,_),Ast0.Iterator
(nm2
,lp2
,_,rp2
,_,_)) ->
685 equal_mcode lp1 lp2
&& equal_mcode rp1 rp2
686 | (Ast0.Switch
(switch1
,lp1
,_,rp1
,lb1
,_,_,rb1
),
687 Ast0.Switch
(switch2
,lp2
,_,rp2
,lb2
,_,_,rb2
)) ->
688 equal_mcode switch1 switch2
&& equal_mcode lp1 lp2
&&
689 equal_mcode rp1 rp2
&& equal_mcode lb1 lb2
&&
691 | (Ast0.Break
(br1
,sem1
),Ast0.Break
(br2
,sem2
)) ->
692 equal_mcode br1 br2
&& equal_mcode sem1 sem2
693 | (Ast0.Continue
(cont1
,sem1
),Ast0.Continue
(cont2
,sem2
)) ->
694 equal_mcode cont1 cont2
&& equal_mcode sem1 sem2
695 | (Ast0.Label
(_,dd1
),Ast0.Label
(_,dd2
)) ->
697 | (Ast0.Goto
(g1
,_,sem1
),Ast0.Goto
(g2
,_,sem2
)) ->
698 equal_mcode g1 g2
&& equal_mcode sem1 sem2
699 | (Ast0.Return
(ret1
,sem1
),Ast0.Return
(ret2
,sem2
)) ->
700 equal_mcode ret1 ret2
&& equal_mcode sem1 sem2
701 | (Ast0.ReturnExpr
(ret1
,_,sem1
),Ast0.ReturnExpr
(ret2
,_,sem2
)) ->
702 equal_mcode ret1 ret2
&& equal_mcode sem1 sem2
703 | (Ast0.MetaStmt
(name1
,_),Ast0.MetaStmt
(name2
,_))
704 | (Ast0.MetaStmtList
(name1
,_),Ast0.MetaStmtList
(name2
,_)) ->
705 equal_mcode name1 name2
706 | (Ast0.Disj
(starter1
,_,mids1
,ender1
),Ast0.Disj
(starter2
,_,mids2
,ender2
)) ->
707 equal_mcode starter1 starter2
&&
708 List.for_all2
equal_mcode mids1 mids2
&&
709 equal_mcode ender1 ender2
710 | (Ast0.Nest
(starter1
,_,ender1
,_,m1
),Ast0.Nest
(starter2
,_,ender2
,_,m2
)) ->
711 equal_mcode starter1 starter2
&& equal_mcode ender1 ender2
&& m1
= m2
712 | (Ast0.Exp
(_),Ast0.Exp
(_)) -> true
713 | (Ast0.TopExp
(_),Ast0.TopExp
(_)) -> true
714 | (Ast0.Ty
(_),Ast0.Ty
(_)) -> true
715 | (Ast0.TopInit
(_),Ast0.TopInit
(_)) -> true
716 | (Ast0.Dots
(d1
,_),Ast0.Dots
(d2
,_))
717 | (Ast0.Circles
(d1
,_),Ast0.Circles
(d2
,_))
718 | (Ast0.Stars
(d1
,_),Ast0.Stars
(d2
,_)) -> equal_mcode d1 d2
719 | (Ast0.Include
(inc1
,name1
),Ast0.Include
(inc2
,name2
)) ->
720 equal_mcode inc1 inc2
&& equal_mcode name1 name2
721 | (Ast0.Define
(def1
,_,_,_),Ast0.Define
(def2
,_,_,_)) ->
722 equal_mcode def1 def2
723 | (Ast0.OptStm
(_),Ast0.OptStm
(_)) -> true
724 | (Ast0.UniqueStm
(_),Ast0.UniqueStm
(_)) -> true
727 and equal_fninfo x y
=
729 (Ast0.FStorage
(s1
),Ast0.FStorage
(s2
)) -> equal_mcode s1 s2
730 | (Ast0.FType
(_),Ast0.FType
(_)) -> true
731 | (Ast0.FInline
(i1
),Ast0.FInline
(i2
)) -> equal_mcode i1 i2
732 | (Ast0.FAttr
(i1
),Ast0.FAttr
(i2
)) -> equal_mcode i1 i2
735 let equal_case_line c1 c2
=
736 match (Ast0.unwrap c1
,Ast0.unwrap c2
) with
737 (Ast0.Default
(def1
,colon1
,_),Ast0.Default
(def2
,colon2
,_)) ->
738 equal_mcode def1 def2
&& equal_mcode colon1 colon2
739 | (Ast0.Case
(case1
,_,colon1
,_),Ast0.Case
(case2
,_,colon2
,_)) ->
740 equal_mcode case1 case2
&& equal_mcode colon1 colon2
741 | (Ast0.DisjCase
(starter1
,_,mids1
,ender1
),
742 Ast0.DisjCase
(starter2
,_,mids2
,ender2
)) ->
743 equal_mcode starter1 starter2
&&
744 List.for_all2
equal_mcode mids1 mids2
&&
745 equal_mcode ender1 ender2
746 | (Ast0.OptCase
(_),Ast0.OptCase
(_)) -> true
749 let rec equal_top_level t1 t2
=
750 match (Ast0.unwrap t1
,Ast0.unwrap t2
) with
751 (Ast0.DECL
(_),Ast0.DECL
(_)) -> true
752 | (Ast0.FILEINFO
(old_file1
,new_file1
),Ast0.FILEINFO
(old_file2
,new_file2
)) ->
753 equal_mcode old_file1 old_file2
&& equal_mcode new_file1 new_file2
754 | (Ast0.CODE
(_),Ast0.CODE
(_)) -> true
755 | (Ast0.ERRORWORDS
(_),Ast0.ERRORWORDS
(_)) -> true
758 let root_equal e1 e2
=
760 (Ast0.DotsExprTag
(d1
),Ast0.DotsExprTag
(d2
)) -> dots equal_expression d1 d2
761 | (Ast0.DotsParamTag
(d1
),Ast0.DotsParamTag
(d2
)) ->
762 dots equal_parameterTypeDef d1 d2
763 | (Ast0.DotsStmtTag
(d1
),Ast0.DotsStmtTag
(d2
)) -> dots equal_statement d1 d2
764 | (Ast0.DotsDeclTag
(d1
),Ast0.DotsDeclTag
(d2
)) -> dots equal_declaration d1 d2
765 | (Ast0.DotsCaseTag
(d1
),Ast0.DotsCaseTag
(d2
)) -> dots equal_case_line d1 d2
766 | (Ast0.IdentTag
(i1
),Ast0.IdentTag
(i2
)) -> equal_ident i1 i2
767 | (Ast0.ExprTag
(e1),Ast0.ExprTag
(e2
)) -> equal_expression e1 e2
768 | (Ast0.ArgExprTag
(d
),_) -> failwith
"not possible - iso only"
769 | (Ast0.TypeCTag
(t1
),Ast0.TypeCTag
(t2
)) -> equal_typeC t1 t2
770 | (Ast0.ParamTag
(p1
),Ast0.ParamTag
(p2
)) -> equal_parameterTypeDef p1 p2
771 | (Ast0.InitTag
(d1
),Ast0.InitTag
(d2
)) -> equal_initialiser d1 d2
772 | (Ast0.DeclTag
(d1
),Ast0.DeclTag
(d2
)) -> equal_declaration d1 d2
773 | (Ast0.StmtTag
(s1
),Ast0.StmtTag
(s2
)) -> equal_statement s1 s2
774 | (Ast0.TopTag
(t1
),Ast0.TopTag
(t2
)) -> equal_top_level t1 t2
775 | (Ast0.IsoWhenTag
(_),_) | (_,Ast0.IsoWhenTag
(_))
776 | (Ast0.IsoWhenTTag
(_),_) | (_,Ast0.IsoWhenTTag
(_))
777 | (Ast0.IsoWhenFTag
(_),_) | (_,Ast0.IsoWhenFTag
(_)) ->
778 failwith
"only within iso phase"
781 let default_context _ =
782 Ast0.CONTEXT
(ref(Ast.NOTHING
,
783 Ast0.default_token_info
,Ast0.default_token_info
))
785 let traverse minus_table plus_table
=
790 let (plus_e
,plus_l
) = Hashtbl.find plus_table key
in
791 if root_equal e plus_e
&&
792 List.for_all
(function x
-> x
)
793 (List.map2
Common.equal_set l plus_l
)
795 let i = Ast0.fresh_index
() in
796 (set_index e
i; set_index plus_e
i;
797 set_mcodekind e
(default_context());
798 set_mcodekind plus_e
(default_context()))
799 with Not_found
-> ())
802 (* --------------------------------------------------------------------- *)
803 (* contextify the whencode *)
807 let option_default = () in
809 let do_nothing r k e
= Ast0.set_mcodekind e
(default_context()); k e
in
811 V0.flat_combiner
bind option_default
812 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
813 do_nothing do_nothing do_nothing do_nothing do_nothing do_nothing
814 do_nothing do_nothing do_nothing do_nothing do_nothing do_nothing
815 do_nothing do_nothing do_nothing
817 let contextify_whencode =
819 let option_default = () in
821 let expression r k e
=
823 match Ast0.unwrap e
with
824 Ast0.NestExpr
(_,_,_,Some whencode
,_)
825 | Ast0.Edots
(_,Some whencode
)
826 | Ast0.Ecircles
(_,Some whencode
)
827 | Ast0.Estars
(_,Some whencode
) ->
828 contextify_all.VT0.combiner_rec_expression whencode
831 let initialiser r k
i =
832 match Ast0.unwrap
i with
833 Ast0.Idots
(dots,Some whencode
) ->
834 contextify_all.VT0.combiner_rec_initialiser whencode
837 let whencode = function
838 Ast0.WhenNot sd
-> contextify_all.VT0.combiner_rec_statement_dots sd
839 | Ast0.WhenAlways s
-> contextify_all.VT0.combiner_rec_statement s
840 | Ast0.WhenModifier
(_) -> ()
841 | Ast0.WhenNotTrue
(e
) -> contextify_all.VT0.combiner_rec_expression e
842 | Ast0.WhenNotFalse
(e
) -> contextify_all.VT0.combiner_rec_expression e
in
844 let statement r k
(s
: Ast0.statement) =
846 match Ast0.unwrap s
with
847 Ast0.Nest
(_,_,_,whn
,_)
848 | Ast0.Dots
(_,whn
) | Ast0.Circles
(_,whn
) | Ast0.Stars
(_,whn
) ->
849 List.iter
whencode whn
853 V0.combiner bind option_default
854 {V0.combiner_functions
with
855 VT0.combiner_exprfn
= expression;
856 VT0.combiner_initfn
= initialiser;
857 VT0.combiner_stmtfn
= statement} in
858 combiner.VT0.combiner_rec_top_level
860 (* --------------------------------------------------------------------- *)
862 (* the first int list is the tokens in the node, the second is the tokens
863 in the descendents *)
865 (Hashtbl.create
(50) : (int list
, Ast0.anything
* int list list
) Hashtbl.t
)
867 (Hashtbl.create
(50) : (int list
, Ast0.anything
* int list list
) Hashtbl.t
)
870 match Ast0.unwrap t
with
872 | Ast0.FILEINFO
(_) -> true
873 | Ast0.ERRORWORDS
(_) -> false
874 | Ast0.CODE
(_) -> true
875 | Ast0.OTHER
(_) -> failwith
"unexpected top level code"
877 (* ------------------------------------------------------------------- *)
878 (* alignment of minus and plus *)
880 let concat = function
884 let rec loop = function
887 (match Ast0.unwrap x
with
888 Ast0.DECL
(s
) -> let stms = loop rest
in s
::stms
890 let stms = loop rest
in
891 (match Ast0.unwrap ss
with
892 Ast0.DOTS
(d
) -> d
@stms
893 | _ -> failwith
"no dots allowed in pure plus code")
894 | _ -> failwith
"plus code is being discarded") in
896 Compute_lines.compute_statement_dots_lines
false
897 (Ast0.rewrap
(List.hd l
) (Ast0.DOTS
(loop l
))) in
898 [Ast0.rewrap
res (Ast0.CODE
res)]
900 let collect_up_to m plus
=
901 let minfo = Ast0.get_info m
in
902 let mend = minfo.Ast0.pos_info
.Ast0.logical_end
in
903 let rec loop = function
906 let pinfo = Ast0.get_info p
in
907 let pstart = pinfo.Ast0.pos_info
.Ast0.logical_start
in
910 else let (plus
,rest
) = loop plus
in (p
::plus
,rest
) in
911 let (plus
,rest
) = loop plus
in
914 let realign minus plus
=
915 let rec loop = function
916 ([],_) -> failwith
"not possible, some context required"
917 | ([m
],p
) -> ([m
],concat p
)
919 let (p
,plus
) = collect_up_to m plus
in
920 let (minus
,plus
) = loop (minus
,plus
) in
924 (* ------------------------------------------------------------------- *)
925 (* check compatible: check that at the top level the minus and plus code is
926 of the same kind. Could go further and make the correspondence between the
927 code between ...s. *)
929 let isonly f l
= match Ast0.undots l
with [s
] -> f s
| _ -> false
931 let isall f l
= List.for_all
(isonly f
) l
934 match Ast0.unwrap s
with
936 | Ast0.Disj
(_,stmts
,_,_) -> isall is_exp stmts
940 match Ast0.unwrap s
with
942 | Ast0.Disj
(_,stmts
,_,_) -> isall is_ty stmts
946 match Ast0.unwrap s
with
947 Ast0.TopInit
(e
) -> true
948 | Ast0.Disj
(_,stmts
,_,_) -> isall is_init stmts
952 match Ast0.unwrap s
with
953 Ast0.Decl
(_,e
) -> true
954 | Ast0.FunDecl
(_,_,_,_,_,_,_,_,_) -> true
955 | Ast0.Disj
(_,stmts
,_,_) -> isall is_decl stmts
958 let rec is_fndecl s
=
959 match Ast0.unwrap s
with
960 Ast0.FunDecl
(_,_,_,_,_,_,_,_,_) -> true
961 | Ast0.Disj
(_,stmts
,_,_) -> isall is_fndecl stmts
964 let rec is_toplevel s
=
965 match Ast0.unwrap s
with
966 Ast0.Decl
(_,e
) -> true
967 | Ast0.FunDecl
(_,_,_,_,_,_,_,_,_) -> true
968 | Ast0.Disj
(_,stmts
,_,_) -> isall is_toplevel stmts
969 | Ast0.ExprStatement
(fc
,_) ->
970 (match Ast0.unwrap fc
with
971 Ast0.FunCall
(_,_,_,_) -> true
973 | Ast0.Include
(_,_) -> true
974 | Ast0.Define
(_,_,_,_) -> true
977 let check_compatible m p
=
981 "incompatible minus and plus code starting on lines %d and %d"
982 (Ast0.get_line m
) (Ast0.get_line p
)) in
983 match (Ast0.unwrap m
, Ast0.unwrap p
) with
984 (Ast0.DECL
(decl1
),Ast0.DECL
(decl2
)) ->
985 if not
(is_decl decl1
&& is_decl decl2
)
987 | (Ast0.DECL
(decl1
),Ast0.CODE
(code2
)) ->
988 let v1 = is_decl decl1
in
989 let v2 = List.for_all
is_toplevel (Ast0.undots code2
) in
990 if !Flag.make_hrule
= None
&& v1 && not
v2 then fail()
991 | (Ast0.CODE
(code1
),Ast0.DECL
(decl2
)) ->
992 let v1 = List.for_all
is_toplevel (Ast0.undots code1
) in
993 let v2 = is_decl decl2
in
994 if v1 && not
v2 then fail()
995 | (Ast0.CODE
(code1
),Ast0.CODE
(code2
)) ->
996 let v1 = isonly is_init code1
in
997 let v2a = isonly is_init code2
in
998 let v2b = isonly is_exp code2
in
1000 then (if not
(v2a || v2b) then fail())
1002 let testers = [is_exp;is_ty] in
1005 let v1 = isonly tester code1
in
1006 let v2 = isonly tester code2
in
1007 if (v1 && not
v2) or (!Flag.make_hrule
= None
&& v2 && not
v1)
1010 let v1 = isonly is_fndecl code1
in
1011 let v2 = List.for_all
is_toplevel (Ast0.undots code2
) in
1012 if !Flag.make_hrule
= None
&& v1 && not
v2 then fail()
1013 | (Ast0.FILEINFO
(_,_),Ast0.FILEINFO
(_,_)) -> ()
1014 | (Ast0.OTHER
(_),Ast0.OTHER
(_)) -> ()
1017 (* ------------------------------------------------------------------- *)
1019 (* returns a list of corresponding minus and plus trees *)
1020 let context_neg minus plus
=
1021 Hashtbl.clear
minus_table;
1022 Hashtbl.clear
plus_table;
1023 List.iter
contextify_whencode minus
;
1024 let (minus
,plus
) = realign minus plus
in
1025 let rec loop = function
1028 failwith
(Printf.sprintf
"%d plus things remaining" (List.length l
))
1035 (function _ -> Ast0.MINUS
(ref([],Ast0.default_token_info
)))
1039 | (((m
::minus
) as mall
),((p
::plus
) as pall
)) ->
1040 let minfo = Ast0.get_info m
in
1041 let pinfo = Ast0.get_info p
in
1042 let mstart = minfo.Ast0.pos_info
.Ast0.logical_start
in
1043 let mend = minfo.Ast0.pos_info
.Ast0.logical_end
in
1044 let pstart = pinfo.Ast0.pos_info
.Ast0.logical_start
in
1045 let pend = pinfo.Ast0.pos_info
.Ast0.logical_end
in
1046 if (iscode m
or iscode p
) &&
1047 (mend + 1 = pstart or pend + 1 = mstart or (* adjacent *)
1048 (mstart <= pstart && mend >= pstart) or
1049 (pstart <= mstart && pend >= mstart)) (* overlapping or nested *)
1052 (* ensure that the root of each tree has a unique index,
1053 although it might get overwritten if the node is a context
1055 let i = Ast0.fresh_index
() in
1056 Ast0.set_index m
i; Ast0.set_index p
i;
1057 check_compatible m p
;
1058 collect_plus_lines p
;
1061 (function _ -> Ast0.MINUS
(ref([],Ast0.default_token_info
)))
1063 let _ = classify false (function c
-> Ast0.PLUS c
) plus_table p
in
1064 traverse minus_table plus_table;
1065 (m
,p
)::loop(minus
,plus
)
1068 if not
(iscode m
or iscode p
)
1069 then loop(minus
,plus
)
1077 (function _ -> Ast0.MINUS
(ref([],Ast0.default_token_info
)))
1081 else loop(mall
,plus
) in