1 (* exports everything, used only by parser_cocci_menhir.mly *)
2 module Ast0
= Ast0_cocci
5 (* types for metavariable tokens *)
6 type info
= Ast.meta_name
* Ast0.pure
* Data.clt
7 type idinfo
= Ast.meta_name
* Data.iconstraints
* Ast0.pure
* Data.clt
8 type expinfo
= Ast.meta_name
* Data.econstraints
* Ast0.pure
* Data.clt
9 type tyinfo
= Ast.meta_name
* Ast0.typeC list
* Ast0.pure
* Data.clt
10 type list_info
= Ast.meta_name
* Ast.meta_name
option * Ast0.pure
* Data.clt
12 Ast.meta_name
* Data.econstraints
* Ast0.pure
*
13 Type_cocci.typeC list
option * Data.clt
14 type pos_info
= Ast.meta_name
* Data.pconstraints
* Ast.meta_collect
* Data.clt
17 let get_option fn
= function
19 | Some x
-> Some
(fn x
)
21 let make_info line logical_line offset col strbef straft
=
23 {Ast0.line_start
= line
; Ast0.line_end
= line
;
24 Ast0.logical_start
= logical_line
; Ast0.logical_end
= logical_line
;
25 Ast0.column
= col
; Ast0.offset
= offset
; } in
26 { Ast0.pos_info
= new_pos_info;
27 Ast0.attachable_start
= true; Ast0.attachable_end
= true;
28 Ast0.mcode_start
= []; Ast0.mcode_end
= [];
29 Ast0.strings_before
= strbef
; Ast0.strings_after
= straft
; }
31 let clt2info (_
,line
,logical_line
,offset
,col
,strbef
,straft
,pos
) =
32 make_info line logical_line offset col strbef straft
34 let drop_bef (arity
,line
,lline
,offset
,col
,strbef
,straft
,pos
) =
35 (arity
,line
,lline
,offset
,col
,[],straft
,pos
)
37 let drop_aft (arity
,line
,lline
,offset
,col
,strbef
,straft
,pos
) =
38 (arity
,line
,lline
,offset
,col
,strbef
,[],pos
)
40 let drop_pos (arity
,line
,lline
,offset
,col
,strbef
,straft
,pos
) =
41 (arity
,line
,lline
,offset
,col
,strbef
,straft
,Ast0.NoMetaPos
)
43 let clt2mcode str
= function
44 (Data.MINUS
,line
,lline
,offset
,col
,strbef
,straft
,pos
) ->
45 (str
,Ast0.NONE
,make_info line lline offset col strbef straft
,
46 Ast0.MINUS
(ref([],Ast0.default_token_info
)),ref pos
,-1)
47 | (Data.OPTMINUS
,line
,lline
,offset
,col
,strbef
,straft
,pos
) ->
48 (str
,Ast0.OPT
,make_info line lline offset col strbef straft
,
49 Ast0.MINUS
(ref([],Ast0.default_token_info
)),ref pos
,-1)
50 | (Data.UNIQUEMINUS
,line
,lline
,offset
,col
,strbef
,straft
,pos
) ->
51 (str
,Ast0.UNIQUE
,make_info line lline offset col strbef straft
,
52 Ast0.MINUS
(ref([],Ast0.default_token_info
)),ref pos
,-1)
53 | (Data.PLUS
,line
,lline
,offset
,col
,strbef
,straft
,pos
) ->
54 (str
,Ast0.NONE
,make_info line lline offset col strbef straft
,
55 Ast0.PLUS
(Ast.ONE
),ref pos
,-1)
56 | (Data.PLUSPLUS
,line
,lline
,offset
,col
,strbef
,straft
,pos
) ->
57 (str
,Ast0.NONE
,make_info line lline offset col strbef straft
,
58 Ast0.PLUS
(Ast.MANY
),ref pos
,-1)
59 | (Data.CONTEXT
,line
,lline
,offset
,col
,strbef
,straft
,pos
) ->
60 (str
,Ast0.NONE
,make_info line lline offset col strbef straft
,
61 Ast0.CONTEXT
(ref(Ast.NOTHING
,
62 Ast0.default_token_info
,Ast0.default_token_info
)),
64 | (Data.OPT
,line
,lline
,offset
,col
,strbef
,straft
,pos
) ->
65 (str
,Ast0.OPT
,make_info line lline offset col strbef straft
,
66 Ast0.CONTEXT
(ref(Ast.NOTHING
,
67 Ast0.default_token_info
,Ast0.default_token_info
)),
69 | (Data.UNIQUE
,line
,lline
,offset
,col
,strbef
,straft
,pos
) ->
70 (str
,Ast0.UNIQUE
,make_info line lline offset col strbef straft
,
71 Ast0.CONTEXT
(ref(Ast.NOTHING
,
72 Ast0.default_token_info
,Ast0.default_token_info
)),
75 let id2name (name
, clt
) = name
76 let id2clt (name
, clt
) = clt
77 let id2mcode (name
, clt
) = clt2mcode name clt
79 let mkdots str
(dot
,whencode
) =
81 "..." -> Ast0.wrap
(Ast0.Dots
(clt2mcode str dot
, whencode
))
82 | "ooo" -> Ast0.wrap
(Ast0.Circles
(clt2mcode str dot
, whencode
))
83 | "***" -> Ast0.wrap
(Ast0.Stars
(clt2mcode str dot
, whencode
))
84 | _
-> failwith
"cannot happen"
86 let mkedots str
(dot
,whencode
) =
88 "..." -> Ast0.wrap
(Ast0.Edots
(clt2mcode str dot
, whencode
))
89 | "ooo" -> Ast0.wrap
(Ast0.Ecircles
(clt2mcode str dot
, whencode
))
90 | "***" -> Ast0.wrap
(Ast0.Estars
(clt2mcode str dot
, whencode
))
91 | _
-> failwith
"cannot happen"
93 let mkdpdots str dot
=
95 "..." -> Ast0.wrap
(Ast0.DPdots
(clt2mcode str dot
))
96 | "ooo" -> Ast0.wrap
(Ast0.DPcircles
(clt2mcode str dot
))
97 | _
-> failwith
"cannot happen"
99 let mkidots str
(dot
,whencode
) =
101 "..." -> Ast0.wrap
(Ast0.Idots
(clt2mcode str dot
, whencode
))
102 | _
-> failwith
"cannot happen"
104 let mkddots str
(dot
,whencode
) =
105 match (str
,whencode
) with
106 ("...",None
) -> Ast0.wrap
(Ast0.Ddots
(clt2mcode str dot
, None
))
107 | ("...",Some
[w
]) -> Ast0.wrap
(Ast0.Ddots
(clt2mcode str dot
, Some w
))
108 | _
-> failwith
"cannot happen"
110 let mkpdots str dot
=
112 "..." -> Ast0.wrap
(Ast0.Pdots
(clt2mcode str dot
))
113 | "ooo" -> Ast0.wrap
(Ast0.Pcircles
(clt2mcode str dot
))
114 | _
-> failwith
"cannot happen"
116 let arith_op ast_op left op right
=
118 (Ast0.Binary
(left
, clt2mcode (Ast.Arith ast_op
) op
, right
))
120 let logic_op ast_op left op right
=
122 (Ast0.Binary
(left
, clt2mcode (Ast.Logical ast_op
) op
, right
))
125 match cv
with None
-> ty
| Some x
-> Ast0.wrap
(Ast0.ConstVol
(x
,ty
))
129 match Ast0.unwrap x
with Ast0.Circles
(_
) -> true | _
-> false in
131 match Ast0.unwrap x
with Ast0.Stars
(_
) -> true | _
-> false in
132 if List.exists
circle l
133 then Ast0.wrap
(Ast0.CIRCLES
(l
))
135 if List.exists
star l
136 then Ast0.wrap
(Ast0.STARS
(l
))
137 else Ast0.wrap
(Ast0.DOTS
(l
))
139 (* here the offset is that of the first in the sequence of *s, not that of
140 each * individually *)
141 let pointerify ty m
=
145 Ast0.wrap
(Ast0.Pointer
(inner
,clt2mcode "*" cur
)))
148 let ty_pointerify ty m
=
150 (function inner
-> function cur
-> Type_cocci.Pointer
(inner
))
153 (* Left is <=>, Right is =>. Collect <=>s. *)
154 (* The parser should have done this, with precedences. But whatever... *)
155 let iso_adjust fn first rest
=
156 let rec loop = function
158 | (Common.Left x
)::rest
->
159 (match loop rest
with
160 front
::after
-> (fn x
::front
)::after
161 | _
-> failwith
"not possible")
162 | (Common.Right x
)::rest
->
163 (match loop rest
with
164 front
::after
-> []::(fn x
::front
)::after
165 | _
-> failwith
"not possible") in
167 front
::after
-> (fn first
::front
)::after
168 | _
-> failwith
"not possible"
171 let lookup rule name
=
173 let info = Hashtbl.find
Data.all_metadecls rule
in
174 List.find
(function mv
-> Ast.get_meta_name mv
= (rule
,name
)) info
178 (Semantic_cocci.Semantic
179 ("bad rule "^rule^
" or bad variable "^name
)) in
181 Ast.MetaIdDecl
(Ast.NONE
,(rule
,name
)) ->
182 (match lookup rule name
with
183 Ast.MetaIdDecl
(_
,_
) | Ast.MetaFreshIdDecl
(_
,_
) -> ()
186 (Semantic_cocci.Semantic
187 ("incompatible inheritance declaration "^name
)))
188 | Ast.MetaFreshIdDecl
((rule
,name
),seed
) ->
190 (Semantic_cocci.Semantic
191 "can't inherit the freshness of an identifier")
192 | Ast.MetaListlenDecl
((rule
,name
)) ->
193 (match lookup rule name
with
194 Ast.MetaListlenDecl
(_
) -> ()
197 (Semantic_cocci.Semantic
198 ("incompatible inheritance declaration "^name
)))
199 | Ast.MetaTypeDecl
(Ast.NONE
,(rule
,name
)) ->
200 (match lookup rule name
with
201 Ast.MetaTypeDecl
(_
,_
) -> ()
204 (Semantic_cocci.Semantic
205 ("incompatible inheritance declaration "^name
)))
206 | Ast.MetaInitDecl
(Ast.NONE
,(rule
,name
)) ->
207 (match lookup rule name
with
208 Ast.MetaInitDecl
(_
,_
) -> ()
211 (Semantic_cocci.Semantic
212 ("incompatible inheritance declaration "^name
)))
213 | Ast.MetaParamDecl
(Ast.NONE
,(rule
,name
)) ->
214 (match lookup rule name
with
215 Ast.MetaParamDecl
(_
,_
) -> ()
218 (Semantic_cocci.Semantic
219 ("incompatible inheritance declaration "^name
)))
220 | Ast.MetaParamListDecl
(Ast.NONE
,(rule
,name
),len_name
) ->
221 (match lookup rule name
with
222 Ast.MetaParamListDecl
(_
,_
,_
) -> ()
225 (Semantic_cocci.Semantic
226 ("incompatible inheritance declaration "^name
)))
227 | Ast.MetaErrDecl
(Ast.NONE
,(rule
,name
)) ->
228 (match lookup rule name
with
229 Ast.MetaErrDecl
(_
,_
) -> ()
232 (Semantic_cocci.Semantic
233 ("incompatible inheritance declaration "^name
)))
234 | Ast.MetaExpDecl
(Ast.NONE
,(rule
,name
),ty
) ->
235 (match lookup rule name
with
236 Ast.MetaExpDecl
(_
,_
,ty1
) when ty
= ty1
-> ()
239 (Semantic_cocci.Semantic
240 ("incompatible inheritance declaration "^name
)))
241 | Ast.MetaIdExpDecl
(Ast.NONE
,(rule
,name
),ty
) ->
242 (match lookup rule name
with
243 Ast.MetaIdExpDecl
(_
,_
,ty1
) when ty
= ty1
-> ()
246 (Semantic_cocci.Semantic
247 ("incompatible inheritance declaration "^name
)))
248 | Ast.MetaLocalIdExpDecl
(Ast.NONE
,(rule
,name
),ty
) ->
249 (match lookup rule name
with
250 Ast.MetaLocalIdExpDecl
(_
,_
,ty1
) when ty
= ty1
-> ()
253 (Semantic_cocci.Semantic
254 ("incompatible inheritance declaration "^name
)))
255 | Ast.MetaExpListDecl
(Ast.NONE
,(rule
,name
),len_name
) ->
256 (match lookup rule name
with
257 Ast.MetaExpListDecl
(_
,_
,_
) -> ()
258 | Ast.MetaParamListDecl
(_
,_
,_
) when not
(!Flag.make_hrule
= None
) -> ()
261 (Semantic_cocci.Semantic
262 ("incompatible inheritance declaration "^name
)))
263 | Ast.MetaStmDecl
(Ast.NONE
,(rule
,name
)) ->
264 (match lookup rule name
with
265 Ast.MetaStmDecl
(_
,_
) -> ()
268 (Semantic_cocci.Semantic
269 ("incompatible inheritance declaration "^name
)))
270 | Ast.MetaStmListDecl
(Ast.NONE
,(rule
,name
)) ->
271 (match lookup rule name
with
272 Ast.MetaStmListDecl
(_
,_
) -> ()
275 (Semantic_cocci.Semantic
276 ("incompatible inheritance declaration "^name
)))
277 | Ast.MetaFuncDecl
(Ast.NONE
,(rule
,name
)) ->
278 (match lookup rule name
with
279 Ast.MetaFuncDecl
(_
,_
) -> ()
282 (Semantic_cocci.Semantic
283 ("incompatible inheritance declaration "^name
)))
284 | Ast.MetaLocalFuncDecl
(Ast.NONE
,(rule
,name
)) ->
285 (match lookup rule name
with
286 Ast.MetaLocalFuncDecl
(_
,_
) -> ()
289 (Semantic_cocci.Semantic
290 ("incompatible inheritance declaration "^name
)))
291 | Ast.MetaConstDecl
(Ast.NONE
,(rule
,name
),ty
) ->
292 (match lookup rule name
with
293 Ast.MetaConstDecl
(_
,_
,ty1
) when ty
= ty1
-> ()
296 (Semantic_cocci.Semantic
297 ("incompatible inheritance declaration "^name
)))
298 | Ast.MetaPosDecl
(Ast.NONE
,(rule
,name
)) ->
299 (match lookup rule name
with
300 Ast.MetaPosDecl
(_
,_
) ->
301 if not
(List.mem rule
!Data.inheritable_positions
)
304 (Semantic_cocci.Semantic
305 ("position cannot be inherited over modifications: "^name
))
308 (Semantic_cocci.Semantic
309 ("incompatible inheritance declaration "^name
)))
312 (Semantic_cocci.Semantic
("arity not allowed on imported declaration"))
314 let create_metadec ar ispure kindfn ids current_rule
=
317 (function (rule
,nm
) ->
320 None
-> ((current_rule
,nm
),function x
-> [Common.Left x
])
323 function x
-> check_meta x
; [Common.Right x
]) in
324 kindfn ar rule ispure checker
)
327 let create_fresh_metadec kindfn ids current_rule
=
330 (function ((rule
,nm
),seed
) ->
333 None
-> ((current_rule
,nm
),function x
-> [Common.Left x
])
336 function x
-> check_meta x
; [Common.Right x
]) in
337 kindfn rule checker seed
)
340 let create_metadec_with_constraints ar ispure kindfn ids current_rule
=
343 (function ((rule
,nm
),constraints
) ->
346 None
-> ((current_rule
,nm
),function x
-> [Common.Left x
])
349 function x
-> check_meta x
; [Common.Right x
]) in
350 kindfn ar rule ispure checker constraints
)
353 let create_metadec_ty ar ispure kindfn ids current_rule
=
356 (function ((rule
,nm
),constraints
) ->
359 None
-> ((current_rule
,nm
),function x
-> [Common.Left x
])
362 function x
-> check_meta x
; [Common.Right x
]) in
363 kindfn ar rule ispure checker constraints
)
366 let create_len_metadec ar ispure kindfn lenid ids current_rule
=
368 create_metadec Ast.NONE
Ast0.Impure
369 (fun _ name _
check_meta -> check_meta(Ast.MetaListlenDecl
(name
)))
370 [lenid
] current_rule
in
373 [Common.Left
(Ast.MetaListlenDecl
(x
))] -> x
374 | [Common.Right
(Ast.MetaListlenDecl
(x
))] -> x
375 | _
-> failwith
"unexpected length declaration" in
376 lendec@(create_metadec ar ispure
(kindfn
lenname) ids current_rule
)
378 (* ---------------------------------------------------------------------- *)
381 let elements = Str.split
(Str.regexp
"/") s
in
382 List.map
(function "..." -> Ast.IncDots
| s
-> Ast.IncPath s
) elements
384 (* ---------------------------------------------------------------------- *)
388 let (nm
,pure
,clt
) = name
in
389 Ast0.wrap
(Ast0.MetaStmt
(clt2mcode nm clt
,pure
))
392 Ast0.wrap
(Ast0.ExprStatement
(exp
, clt2mcode ";" pv
))
394 let ifthen iff lp tst rp thn
=
395 Ast0.wrap
(Ast0.IfThen
(clt2mcode "if" iff
,
396 clt2mcode "(" lp
,tst
,clt2mcode ")" rp
,thn
,
397 (Ast0.default_info
(),Ast0.context_befaft
())))
399 let ifthenelse iff lp tst rp thn e els
=
400 Ast0.wrap
(Ast0.IfThenElse
(clt2mcode "if" iff
,
401 clt2mcode "(" lp
,tst
,clt2mcode ")" rp
,thn
,
402 clt2mcode "else" e
,els
,
403 (Ast0.default_info
(),Ast0.context_befaft
())))
405 let forloop fr lp e1 sc1 e2 sc2 e3 rp s
=
406 Ast0.wrap
(Ast0.For
(clt2mcode "for" fr
,clt2mcode "(" lp
,e1
,
407 clt2mcode ";" sc1
,e2
,
408 clt2mcode ";" sc2
,e3
,clt2mcode ")" rp
,s
,
409 (Ast0.default_info
(),Ast0.context_befaft
())))
411 let whileloop w lp e rp s
=
412 Ast0.wrap
(Ast0.While
(clt2mcode "while" w
,clt2mcode "(" lp
,
413 e
,clt2mcode ")" rp
,s
,
414 (Ast0.default_info
(),Ast0.context_befaft
())))
416 let doloop d s w lp e rp pv
=
417 Ast0.wrap
(Ast0.Do
(clt2mcode "do" d
,s
,clt2mcode "while" w
,
418 clt2mcode "(" lp
,e
,clt2mcode ")" rp
,
421 let iterator i lp e rp s
=
422 Ast0.wrap
(Ast0.Iterator
(i
,clt2mcode "(" lp
,e
,clt2mcode ")" rp
,s
,
423 (Ast0.default_info
(),Ast0.context_befaft
())))
425 let switch s lp e rp lb d c rb
=
429 Ast0.wrap
(Ast0.Decl
((Ast0.default_info
(),Ast0.context_befaft
()),d)))
431 Ast0.wrap
(Ast0.Switch
(clt2mcode "switch" s
,clt2mcode "(" lp
,e
,
432 clt2mcode ")" rp
,clt2mcode "{" lb
,
433 Ast0.wrap
(Ast0.DOTS
(d)),
434 Ast0.wrap
(Ast0.DOTS
(c
)),clt2mcode "}" rb
))
437 Ast0.wrap
(Ast0.ReturnExpr
(clt2mcode "return" r
,e
,clt2mcode ";" pv
))
440 Ast0.wrap
(Ast0.Return
(clt2mcode "return" r
,clt2mcode ";" pv
))
443 Ast0.wrap
(Ast0.Break
(clt2mcode "break" b
,clt2mcode ";" pv
))
446 Ast0.wrap
(Ast0.Continue
(clt2mcode "continue" c
,clt2mcode ";" pv
))
449 Ast0.wrap
(Ast0.Label
(i
,clt2mcode ":" dd
))
452 Ast0.wrap
(Ast0.Goto
(clt2mcode "goto" g
,i
,clt2mcode ";" pv
))
455 Ast0.wrap
(Ast0.Seq
(clt2mcode "{" lb
,s
,clt2mcode "}" rb
))
457 (* ---------------------------------------------------------------------- *)
459 let make_iso_rule_name_result n
=
460 (try let _ = Hashtbl.find
Data.all_metadecls n
in
461 raise
(Semantic_cocci.Semantic
("repeated rule name"))
462 with Not_found
-> ());
463 Ast.CocciRulename
(Some n
,Ast.NoDep
,[],[],Ast.Undetermined
,false (*discarded*))
465 let make_cocci_rule_name_result nm
d i a e ee
=
468 let n = id2name nm
in
469 (try let _ = Hashtbl.find
Data.all_metadecls
n in
470 raise
(Semantic_cocci.Semantic
("repeated rule name"))
471 with Not_found
-> ());
472 Ast.CocciRulename
(Some
n,d,i
,a
,e
,ee
)
473 | None
-> Ast.CocciRulename
(None
,d,i
,a
,e
,ee
)
475 let make_generated_rule_name_result nm
d i a e ee
=
478 let n = id2name nm
in
479 (try let _ = Hashtbl.find
Data.all_metadecls
n in
480 raise
(Semantic_cocci.Semantic
("repeated rule name"))
481 with Not_found
-> ());
482 Ast.GeneratedRulename
(Some
n,d,i
,a
,e
,ee
)
483 | None
-> Ast.GeneratedRulename
(None
,d,i
,a
,e
,ee
)
485 let make_script_rule_name_result lang deps
=
486 let l = id2name lang
in
487 Ast.ScriptRulename
(l,deps
)
489 let make_initial_script_rule_name_result lang
=
490 let l = id2name lang
in
491 Ast.InitialScriptRulename
(l)
493 let make_final_script_rule_name_result lang
=
494 let l = id2name lang
in
495 Ast.FinalScriptRulename
(l)
497 (* Allows type alone only when it is void and only when there is only one
498 parameter. This avoids ambiguity problems in the parser. *)
499 let verify_parameter_declarations = function
502 (match Ast0.unwrap x
with
503 Ast0.Param
(t
, None
) ->
504 (match Ast0.unwrap t
with
505 Ast0.BaseType
(Ast.VoidType
,_) -> ()
509 "%d: only void can be a parameter without an identifier"
515 match Ast0.unwrap x
with
516 Ast0.Param
(t
, None
) ->
519 "%d: only void alone can be a parameter without an identifier"