1 (* Copyright (C) 2006, 2007, 2008 Yoann Padioleau
3 * This program is free software; you can redistribute it and/or
4 * modify it under the terms of the GNU General Public License (GPL)
5 * version 2 as published by the Free Software Foundation.
7 * This program is distributed in the hope that it will be useful,
8 * but WITHOUT ANY WARRANTY; without even the implied warranty of
9 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
10 * file license.txt for more details.
16 module F
= Control_flow_c
18 (*****************************************************************************)
19 (* Functions to visit the Ast, and now also the CFG nodes *)
20 (*****************************************************************************)
23 (* Visitor based on continuation. Cleaner than the one based on mutable
24 * pointer functions that I had before.
25 * src: based on a (vague) idea from Remy Douence.
29 * Diff with Julia's visitor ? She does:
33 * let expression r k e =
35 * ... (List.map r.V0.combiner_expression expr_list) ...
37 * let res = V0.combiner bind option_default
38 * mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
39 * donothing donothing donothing donothing
40 * ident expression typeC donothing parameter declaration statement
43 * collect_unitary_nonunitary
44 * (List.concat (List.map res.V0.combiner_top_level t))
48 * So she has to remember at which position you must put the 'expression'
49 * function. I use record which is easier.
51 * When she calls recursively, her res.V0.combiner_xxx does not take bigf
52 * in param whereas I do
53 * | F.Decl decl -> Visitor_c.vk_decl bigf decl
54 * And with the record she gets, she does not have to do my
55 * multiple defs of function such as 'let al_type = V0.vk_type_s bigf'
57 * The code of visitor.ml is cleaner with julia because mutual recursive calls
58 * are clean such as ... 'expression e' ... and not 'f (k, bigf) e'
59 * or 'vk_expr bigf e'.
62 * - I give a record but then I must handle bigf.
63 * - She gets a record, and gives a list of function
68 (* old: first version (only visiting expr)
70 let (iter_expr:((expression -> unit) -> expression -> unit) -> expression -> unit)
75 | FunCall (e, es) -> f k e; List.iter (f k) es
76 | CondExpr (e1, e2, e3) -> f k e1; f k e2; f k e3
77 | Sequence (e1, e2) -> f k e1; f k e2;
78 | Assignment (e1, op, e2) -> f k e1; f k e2;
80 | Postfix (e, op) -> f k e
81 | Infix (e, op) -> f k e
82 | Unary (e, op) -> f k e
83 | Binary (e1, op, e2) -> f k e1; f k e2;
85 | ArrayAccess (e1, e2) -> f k e1; f k e2;
86 | RecordAccess (e, s) -> f k e
87 | RecordPtAccess (e, s) -> f k e
89 | SizeOfExpr e -> f k e
91 | _ -> failwith "to complete"
95 let ex1 = Sequence (Sequence (Constant (Ident "1"), Constant (Ident "2")),
98 iter_expr (fun k e -> match e with
99 | Constant (Ident x) -> Common.pr2 x
109 (*****************************************************************************)
110 (* Side effect style visitor *)
111 (*****************************************************************************)
113 (* Visitors for all langage concept, not just for expression.
115 * Note that I don't visit necesserally in the order of the token
116 * found in the original file. So don't assume such hypothesis!
118 * todo? parameter ? onedecl ?
122 kexpr
: (expression -> unit) * visitor_c
-> expression -> unit;
123 kstatement
: (statement
-> unit) * visitor_c
-> statement
-> unit;
124 ktype
: (fullType
-> unit) * visitor_c
-> fullType
-> unit;
126 kdecl
: (declaration
-> unit) * visitor_c
-> declaration
-> unit;
127 kdef
: (definition
-> unit) * visitor_c
-> definition
-> unit;
128 kini
: (initialiser
-> unit) * visitor_c
-> initialiser
-> unit;
130 kcppdirective
: (cpp_directive
-> unit) * visitor_c
-> cpp_directive
-> unit;
131 kdefineval
: (define_val
-> unit) * visitor_c
-> define_val
-> unit;
132 kstatementseq
: (statement_sequencable
-> unit) * visitor_c
-> statement_sequencable
-> unit;
135 knode
: (F.node
-> unit) * visitor_c
-> F.node
-> unit;
137 ktoplevel
: (toplevel
-> unit) * visitor_c
-> toplevel
-> unit;
139 kinfo
: (info
-> unit) * visitor_c
-> info
-> unit;
142 let default_visitor_c =
143 { kexpr
= (fun (k,_
) e
-> k e
);
144 kstatement
= (fun (k,_
) st
-> k st
);
145 ktype
= (fun (k,_
) t
-> k t
);
146 kdecl
= (fun (k,_
) d
-> k d
);
147 kdef
= (fun (k,_
) d
-> k d
);
148 kini
= (fun (k,_
) ie
-> k ie
);
149 kinfo
= (fun (k,_
) ii
-> k ii
);
150 knode
= (fun (k,_
) n
-> k n
);
151 ktoplevel
= (fun (k,_
) p
-> k p
);
152 kcppdirective
= (fun (k,_
) p
-> k p
);
153 kdefineval
= (fun (k,_
) p
-> k p
);
154 kstatementseq
= (fun (k,_
) p
-> k p
);
158 (* ------------------------------------------------------------------------ *)
161 let rec vk_expr = fun bigf expr
->
162 let iif ii
= vk_ii bigf ii
in
164 let rec exprf e
= bigf
.kexpr
(k,bigf
) e
165 (* dont go in _typ *)
166 and k ((e
,_typ
), ii
) =
173 vk_argument_list bigf es
;
174 | CondExpr
(e1
, e2
, e3
) ->
175 exprf e1
; do_option
(exprf) e2
; exprf e3
176 | Sequence
(e1
, e2
) -> exprf e1
; exprf e2
;
177 | Assignment
(e1
, op
, e2
) -> exprf e1
; exprf e2
;
179 | Postfix
(e
, op
) -> exprf e
180 | Infix
(e
, op
) -> exprf e
181 | Unary
(e
, op
) -> exprf e
182 | Binary
(e1
, op
, e2
) -> exprf e1
; exprf e2
;
184 | ArrayAccess
(e1
, e2
) -> exprf e1
; exprf e2
;
185 | RecordAccess
(e
, s
) -> exprf e
186 | RecordPtAccess
(e
, s
) -> exprf e
188 | SizeOfExpr
(e
) -> exprf e
189 | SizeOfType
(t
) -> vk_type bigf t
190 | Cast
(t
, e
) -> vk_type bigf t
; exprf e
192 (* old: | StatementExpr (((declxs, statxs), is)), is2 ->
193 * List.iter (vk_decl bigf) declxs;
194 * List.iter (vk_statement bigf) statxs
196 | StatementExpr
((statxs
, is
)) ->
198 statxs
+> List.iter
(vk_statement_sequencable bigf
);
200 (* TODO, we will certainly have to then do a special visitor for
203 | Constructor
(t
, initxs
) ->
205 initxs
+> List.iter
(fun (ini
, ii
) ->
210 | ParenExpr
(e
) -> exprf e
219 and vk_statement
= fun bigf
(st
: Ast_c.statement
) ->
220 let iif ii
= vk_ii bigf ii
in
222 let rec statf x
= bigf
.kstatement
(k,bigf
) x
224 let (unwrap_st
, ii
) = st
in
227 | Labeled
(Label
(s
, st
)) -> statf st
;
228 | Labeled
(Case
(e
, st
)) -> vk_expr bigf e
; statf st
;
229 | Labeled
(CaseRange
(e
, e2
, st
)) ->
230 vk_expr bigf e
; vk_expr bigf e2
; statf st
;
231 | Labeled
(Default st
) -> statf st
;
234 statxs
+> List.iter
(vk_statement_sequencable bigf
)
235 | ExprStatement
(eopt
) -> do_option
(vk_expr bigf
) eopt
;
237 | Selection
(If
(e
, st1
, st2
)) ->
238 vk_expr bigf e
; statf st1
; statf st2
;
239 | Selection
(Switch
(e
, st
)) ->
240 vk_expr bigf e
; statf st
;
241 | Iteration
(While
(e
, st
)) ->
242 vk_expr bigf e
; statf st
;
243 | Iteration
(DoWhile
(st
, e
)) -> statf st
; vk_expr bigf e
;
244 | Iteration
(For
((e1opt
,i1
), (e2opt
,i2
), (e3opt
,i3
), st
)) ->
245 statf (ExprStatement
(e1opt
),i1
);
246 statf (ExprStatement
(e2opt
),i2
);
247 statf (ExprStatement
(e3opt
),i3
);
250 | Iteration
(MacroIteration
(s
, es
, st
)) ->
251 vk_argument_list bigf es
;
254 | Jump
(Goto s
) -> ()
255 | Jump
((Continue
|Break
|Return
)) -> ()
256 | Jump
(ReturnExpr e
) -> vk_expr bigf e
;
257 | Jump
(GotoComputed e
) -> vk_expr bigf e
;
259 | Decl decl
-> vk_decl bigf decl
260 | Asm asmbody
-> vk_asmbody bigf asmbody
261 | NestedFunc def
-> vk_def bigf def
266 and vk_statement_sequencable
= fun bigf stseq
->
267 let f = bigf
.kstatementseq
in
271 | StmtElem st
-> vk_statement bigf st
272 | CppDirectiveStmt directive
->
273 vk_cpp_directive bigf directive
275 vk_ifdef_directive bigf ifdef
276 | IfdefStmt2
(ifdef
, xxs
) ->
277 ifdef
+> List.iter
(vk_ifdef_directive bigf
);
278 xxs
+> List.iter
(fun xs
->
279 xs
+> List.iter
(vk_statement_sequencable bigf
)
286 and vk_type
= fun bigf t
->
287 let iif ii
= vk_ii bigf ii
in
289 let rec typef x
= bigf
.ktype
(k, bigf
) x
292 let (unwrap_q
, iiq
) = q
in
293 let (unwrap_t
, iit
) = t
in
298 | Pointer t
-> typef t
300 do_option
(vk_expr bigf
) eopt
;
302 | FunctionType
(returnt
, paramst
) ->
305 | (ts
, (b
,iihas3dots
)) ->
307 vk_param_list bigf ts
310 | Enum
(sopt
, enumt
) ->
311 enumt
+> List.iter
(fun (((s
, eopt
),ii_s_eq
), iicomma
) ->
312 iif ii_s_eq
; iif iicomma
;
313 eopt
+> do_option
(vk_expr bigf
)
316 | StructUnion
(sopt
, _su
, fields
) ->
317 vk_struct_fields bigf fields
319 | StructUnionName
(s
, structunion
) -> ()
322 (* dont go in _typ *)
323 | TypeName
(s
, _typ
) -> ()
325 | ParenType t
-> typef t
326 | TypeOfExpr e
-> vk_expr bigf e
327 | TypeOfType t
-> typef t
332 and vk_attribute
= fun bigf attr
->
333 let iif ii
= vk_ii bigf ii
in
339 (* ------------------------------------------------------------------------ *)
341 and vk_decl
= fun bigf d
->
342 let iif ii
= vk_ii bigf ii
in
344 let f = bigf
.kdecl
in
347 | DeclList
(xs
,ii
) -> iif ii
; List.iter aux xs
348 | MacroDecl
((s
, args
),ii
) ->
350 vk_argument_list bigf args
;
353 and aux
({v_namei
= var
; v_type
= t
;
354 v_storage
= _sto
; v_attr
= attrs
}, iicomma
) =
357 attrs
+> List.iter
(vk_attribute bigf
);
358 var
+> do_option
(fun ((s
, ini
), ii_s_ini
) ->
360 ini
+> do_option
(vk_ini bigf
)
364 and vk_ini
= fun bigf ini
->
365 let iif ii
= vk_ii bigf ii
in
367 let rec inif x
= bigf
.kini
(k, bigf
) x
371 | InitExpr e
-> vk_expr bigf e
373 initxs
+> List.iter
(fun (ini
, ii
) ->
377 | InitDesignators
(xs
, e
) ->
378 xs
+> List.iter
(vk_designator bigf
);
381 | InitFieldOld
(s
, e
) -> inif e
382 | InitIndexOld
(e1
, e
) ->
383 vk_expr bigf e1
; inif e
389 and vk_designator
= fun bigf design
->
390 let iif ii
= vk_ii bigf ii
in
391 let (designator
, ii
) = design
in
393 match designator
with
394 | DesignatorField s
-> ()
395 | DesignatorIndex e
-> vk_expr bigf e
396 | DesignatorRange
(e1
, e2
) -> vk_expr bigf e1
; vk_expr bigf e2
399 (* ------------------------------------------------------------------------ *)
401 and vk_struct_fields
= fun bigf fields
->
402 let iif ii
= vk_ii bigf ii
in
404 fields
+> List.iter
(fun (xfield
, ii
) ->
408 (FieldDeclList
(onefield_multivars
, iiptvirg
)) ->
409 vk_struct_fieldkinds bigf onefield_multivars
;
412 | MacroStructDeclTodo
->
413 pr2
"MacroStructDeclTodo";
416 | CppDirectiveStruct directive
->
417 vk_cpp_directive bigf directive
418 | IfdefStruct ifdef
->
419 vk_ifdef_directive bigf ifdef
423 and vk_struct_fieldkinds
= fun bigf onefield_multivars
->
424 let iif ii
= vk_ii bigf ii
in
425 onefield_multivars
+> List.iter
(fun (field
, iicomma
) ->
428 | Simple
(s
, t
), ii
-> iif ii
; vk_type bigf t
;
429 | BitField
(sopt
, t
, expr
), ii
->
435 (* ------------------------------------------------------------------------ *)
438 and vk_def
= fun bigf d
->
439 let iif ii
= vk_ii bigf ii
in
445 f_type
= (returnt
, (paramst
, (b
, iib
)));
453 attrs
+> List.iter
(vk_attribute bigf
);
454 vk_type bigf returnt
;
455 paramst
+> List.iter
(fun (param
,iicomma
) ->
459 statxs
+> List.iter
(vk_statement_sequencable bigf
)
465 and vk_toplevel
= fun bigf p
->
466 let f = bigf
.ktoplevel
in
467 let iif ii
= vk_ii bigf ii
in
470 | Declaration decl
-> (vk_decl bigf decl
)
471 | Definition def
-> (vk_def bigf def
)
472 | EmptyDef ii
-> iif ii
473 | MacroTop
(s
, xs
, ii
) ->
474 vk_argument_list bigf xs
;
477 | CppTop top
-> vk_cpp_directive bigf top
478 | IfdefTop ifdefdir
-> vk_ifdef_directive bigf ifdefdir
480 | NotParsedCorrectly ii
-> iif ii
481 | FinalDef info
-> vk_info bigf info
484 and vk_program
= fun bigf xs
->
485 xs
+> List.iter
(vk_toplevel bigf
)
487 and vk_ifdef_directive bigf directive
=
488 let iif ii
= vk_ii bigf ii
in
490 | IfdefDirective
(ifkind
, ii
) -> iif ii
493 and vk_cpp_directive bigf directive
=
494 let iif ii
= vk_ii bigf ii
in
495 let f = bigf
.kcppdirective
in
496 let rec k directive
=
498 | Include
{i_include
= (s
, ii
);
504 copt
+> Common.do_option
(fun (file
, asts
) ->
507 | Define
((s
,ii
), (defkind
, defval
)) ->
509 vk_define_kind bigf defkind
;
510 vk_define_val bigf defval
513 | PragmaAndCo
(ii
) ->
515 in f (k, bigf
) directive
518 and vk_define_kind bigf defkind
=
521 | DefineFunc
(params
, ii
) ->
523 params
+> List.iter
(fun ((s
,iis
), iicomma
) ->
528 and vk_define_val bigf defval
=
529 let f = bigf
.kdefineval
in
535 | DefineStmt stmt
-> vk_statement bigf stmt
536 | DefineDoWhileZero
((stmt
, e
), ii
) ->
537 vk_statement bigf stmt
;
540 | DefineFunction def
-> vk_def bigf def
541 | DefineType ty
-> vk_type bigf ty
542 | DefineText
(s
, ii
) -> vk_ii bigf ii
544 | DefineInit ini
-> vk_ini bigf ini
549 in f (k, bigf
) defval
554 (* ------------------------------------------------------------------------ *)
555 (* Now keep fullstatement inside the control flow node,
556 * so that can then get in a MetaStmtVar the fullstatement to later
557 * pp back when the S is in a +. But that means that
558 * Exp will match an Ifnode even if there is no such exp
559 * inside the condition of the Ifnode (because the exp may
560 * be deeper, in the then branch). So have to not visit
561 * all inside a node anymore.
563 * update: j'ai choisi d'accrocher au noeud du CFG a la
564 * fois le fullstatement et le partialstatement et appeler le
565 * visiteur que sur le partialstatement.
568 and vk_node
= fun bigf node
->
569 let iif ii
= vk_ii bigf ii
in
570 let infof info
= vk_info bigf info
in
572 let f = bigf
.knode
in
574 match F.unwrap n
with
576 | F.FunHeader
({f_name
=idb
;
577 f_type
= (rett
, (paramst
,(isvaargs
,iidotsb
)));
580 f_attr
= attrs
},ii
) ->
585 attrs
+> List.iter
(vk_attribute bigf
);
587 paramst
+> List.iter
(fun (param
, iicomma
) ->
593 | F.Decl decl
-> vk_decl bigf decl
594 | F.ExprStatement
(st
, (eopt
, ii
)) ->
596 eopt
+> do_option
(vk_expr bigf
)
598 | F.IfHeader
(_
, (e
,ii
))
599 | F.SwitchHeader
(_
, (e
,ii
))
600 | F.WhileHeader
(_
, (e
,ii
))
601 | F.DoWhileTail
(e
,ii
) ->
605 | F.ForHeader
(_st
, (((e1opt
,i1
), (e2opt
,i2
), (e3opt
,i3
)), ii
)) ->
606 iif i1
; iif i2
; iif i3
;
608 e1opt
+> do_option
(vk_expr bigf
);
609 e2opt
+> do_option
(vk_expr bigf
);
610 e3opt
+> do_option
(vk_expr bigf
);
611 | F.MacroIterHeader
(_s
, ((s
,es
), ii
)) ->
613 vk_argument_list bigf es
;
615 | F.ReturnExpr
(_st
, (e
,ii
)) -> iif ii
; vk_expr bigf e
617 | F.Case
(_st
, (e
,ii
)) -> iif ii
; vk_expr bigf e
618 | F.CaseRange
(_st
, ((e1
, e2
),ii
)) ->
619 iif ii
; vk_expr bigf e1
; vk_expr bigf e2
624 | F.DefineExpr e
-> vk_expr bigf e
625 | F.DefineType ft
-> vk_type bigf ft
626 | F.DefineHeader
((s
,ii
), (defkind
)) ->
628 vk_define_kind bigf defkind
;
630 | F.DefineDoWhileZeroHeader
(((),ii
)) -> iif ii
636 | F.Include
{i_include
= (s
, ii
);} -> iif ii
;
638 | F.MacroTop
(s
, args
, ii
) ->
640 vk_argument_list bigf args
642 | F.IfdefHeader
(info
) -> vk_ifdef_directive bigf info
643 | F.IfdefElse
(info
) -> vk_ifdef_directive bigf info
644 | F.IfdefEndif
(info
) -> vk_ifdef_directive bigf info
646 | F.Break
(st
,((),ii
)) -> iif ii
647 | F.Continue
(st
,((),ii
)) -> iif ii
648 | F.Default
(st
,((),ii
)) -> iif ii
649 | F.Return
(st
,((),ii
)) -> iif ii
650 | F.Goto
(st
, (s
,ii
)) -> iif ii
651 | F.Label
(st
, (s
,ii
)) -> iif ii
653 | F.DoHeader
(st
, info
) -> infof info
655 | F.Else info
-> infof info
656 | F.EndStatement iopt
-> do_option
infof iopt
658 | F.SeqEnd
(i
, info
) -> infof info
659 | F.SeqStart
(st
, i
, info
) -> infof info
661 | F.MacroStmt
(st
, ((),ii
)) -> iif ii
662 | F.Asm
(st
, (asmbody
,ii
)) ->
664 vk_asmbody bigf asmbody
668 F.ErrorExit
|F.Exit
|F.Enter
|
669 F.FallThroughNode
|F.AfterNode
|F.FalseNode
|F.TrueNode
|F.InLoopNode
|
678 (* ------------------------------------------------------------------------ *)
679 and vk_info
= fun bigf info
->
680 let rec infof ii
= bigf
.kinfo
(k, bigf
) ii
685 and vk_ii
= fun bigf ii
->
686 List.iter
(vk_info bigf
) ii
689 (* ------------------------------------------------------------------------ *)
690 and vk_argument
= fun bigf arg
->
691 let rec do_action = function
692 | (ActMisc ii
) -> vk_ii bigf ii
695 | Left e
-> (vk_expr bigf
) e
696 | Right
(ArgType param
) -> vk_param bigf param
697 | Right
(ArgAction action
) -> do_action action
699 and vk_argument_list
= fun bigf es
->
700 let iif ii
= vk_ii bigf ii
in
701 es
+> List.iter
(fun (e
, ii
) ->
708 and vk_param
= fun bigf
(((b
, s
, t
), ii_b_s
)) ->
709 let iif ii
= vk_ii bigf ii
in
713 and vk_param_list
= fun bigf ts
->
714 let iif ii
= vk_ii bigf ii
in
715 ts
+> List.iter
(fun (param
,iicomma
) ->
722 (* ------------------------------------------------------------------------ *)
723 and vk_asmbody
= fun bigf
(string_list
, colon_list
) ->
724 let iif ii
= vk_ii bigf ii
in
727 colon_list
+> List.iter
(fun (Colon xs
, ii
) ->
729 xs
+> List.iter
(fun (x
,iicomma
) ->
732 | ColonMisc
, ii
-> iif ii
740 (* ------------------------------------------------------------------------ *)
741 let vk_args_splitted = fun bigf args_splitted
->
742 let iif ii
= vk_ii bigf ii
in
743 args_splitted
+> List.iter
(function
744 | Left arg
-> vk_argument bigf arg
749 let vk_define_params_splitted = fun bigf args_splitted
->
750 let iif ii
= vk_ii bigf ii
in
751 args_splitted
+> List.iter
(function
752 | Left
(s
, iis
) -> vk_ii bigf iis
758 let vk_params_splitted = fun bigf args_splitted
->
759 let iif ii
= vk_ii bigf ii
in
760 args_splitted
+> List.iter
(function
761 | Left arg
-> vk_param bigf arg
765 (* ------------------------------------------------------------------------ *)
766 let vk_cst = fun bigf
(cst
, ii
) ->
767 let iif ii
= vk_ii bigf ii
in
777 (*****************************************************************************)
778 (* "syntetisized attributes" style *)
779 (*****************************************************************************)
781 (* TODO port the xxs_s to new cpp construct too *)
783 type 'a inout
= 'a
-> 'a
785 (* _s for synthetizized attributes
787 * Note that I don't visit necesserally in the order of the token
788 * found in the original file. So don't assume such hypothesis!
791 kexpr_s
: (expression inout
* visitor_c_s
) -> expression inout
;
792 kstatement_s
: (statement inout
* visitor_c_s
) -> statement inout
;
793 ktype_s
: (fullType inout
* visitor_c_s
) -> fullType inout
;
795 kdecl_s
: (declaration inout
* visitor_c_s
) -> declaration inout
;
796 kdef_s
: (definition inout
* visitor_c_s
) -> definition inout
;
798 kini_s
: (initialiser inout
* visitor_c_s
) -> initialiser inout
;
800 kcppdirective_s
: (cpp_directive inout
* visitor_c_s
) -> cpp_directive inout
;
801 kdefineval_s
: (define_val inout
* visitor_c_s
) -> define_val inout
;
802 kstatementseq_s
: (statement_sequencable inout
* visitor_c_s
) -> statement_sequencable inout
;
803 kstatementseq_list_s
: (statement_sequencable list inout
* visitor_c_s
) -> statement_sequencable list inout
;
805 knode_s
: (F.node inout
* visitor_c_s
) -> F.node inout
;
808 ktoplevel_s
: (toplevel inout
* visitor_c_s
) -> toplevel inout
;
809 kinfo_s
: (info inout
* visitor_c_s
) -> info inout
;
812 let default_visitor_c_s =
813 { kexpr_s
= (fun (k,_
) e
-> k e
);
814 kstatement_s
= (fun (k,_
) st
-> k st
);
815 ktype_s
= (fun (k,_
) t
-> k t
);
816 kdecl_s
= (fun (k,_
) d
-> k d
);
817 kdef_s
= (fun (k,_
) d
-> k d
);
818 kini_s
= (fun (k,_
) d
-> k d
);
819 ktoplevel_s
= (fun (k,_
) p
-> k p
);
820 knode_s
= (fun (k,_
) n
-> k n
);
821 kinfo_s
= (fun (k,_
) i
-> k i
);
822 kdefineval_s
= (fun (k,_
) x
-> k x
);
823 kstatementseq_s
= (fun (k,_
) x
-> k x
);
824 kstatementseq_list_s
= (fun (k,_
) x
-> k x
);
825 kcppdirective_s
= (fun (k,_
) x
-> k x
);
828 let rec vk_expr_s = fun bigf expr
->
829 let iif ii
= vk_ii_s bigf ii
in
830 let rec exprf e
= bigf
.kexpr_s
(k, bigf
) e
832 let ((unwrap_e
, typ
), ii
) = e
in
833 (* don't analyse optional type
834 * old: typ +> map_option (vk_type_s bigf) in
839 | Ident
(s
) -> Ident
(s
)
840 | Constant
(c
) -> Constant
(c
)
843 es
+> List.map
(fun (e,ii
) ->
844 vk_argument_s bigf
e, iif ii
847 | CondExpr
(e1
, e2
, e3
) -> CondExpr
(exprf e1
, fmap
exprf e2
, exprf e3
)
848 | Sequence
(e1
, e2
) -> Sequence
(exprf e1
, exprf e2
)
849 | Assignment
(e1
, op
, e2
) -> Assignment
(exprf e1
, op
, exprf e2
)
851 | Postfix
(e, op
) -> Postfix
(exprf e, op
)
852 | Infix
(e, op
) -> Infix
(exprf e, op
)
853 | Unary
(e, op
) -> Unary
(exprf e, op
)
854 | Binary
(e1
, op
, e2
) -> Binary
(exprf e1
, op
, exprf e2
)
856 | ArrayAccess
(e1
, e2
) -> ArrayAccess
(exprf e1
, exprf e2
)
857 | RecordAccess
(e, s
) -> RecordAccess
(exprf e, s
)
858 | RecordPtAccess
(e, s
) -> RecordPtAccess
(exprf e, s
)
860 | SizeOfExpr
(e) -> SizeOfExpr
(exprf e)
861 | SizeOfType
(t
) -> SizeOfType
(vk_type_s bigf t
)
862 | Cast
(t
, e) -> Cast
(vk_type_s bigf t
, exprf e)
864 | StatementExpr
(statxs
, is
) ->
866 vk_statement_sequencable_list_s bigf statxs
,
868 | Constructor
(t
, initxs
) ->
871 (initxs
+> List.map
(fun (ini
, ii
) ->
872 vk_ini_s bigf ini
, vk_ii_s bigf ii
)
875 | ParenExpr
(e) -> ParenExpr
(exprf e)
881 and vk_argument_s bigf argument
=
882 let iif ii
= vk_ii_s bigf ii
in
883 let rec do_action = function
884 | (ActMisc ii
) -> ActMisc
(iif ii
)
887 | Left
e -> Left
(vk_expr_s bigf
e)
888 | Right
(ArgType param
) -> Right
(ArgType
(vk_param_s bigf param
))
889 | Right
(ArgAction action
) -> Right
(ArgAction
(do_action action
))
897 and vk_statement_s
= fun bigf st
->
898 let rec statf st
= bigf
.kstatement_s
(k, bigf
) st
900 let (unwrap_st
, ii
) = st
in
903 | Labeled
(Label
(s
, st)) ->
904 Labeled
(Label
(s
, statf st))
905 | Labeled
(Case
(e, st)) ->
906 Labeled
(Case
((vk_expr_s bigf
) e , statf st))
907 | Labeled
(CaseRange
(e, e2
, st)) ->
908 Labeled
(CaseRange
((vk_expr_s bigf
) e,
911 | Labeled
(Default
st) -> Labeled
(Default
(statf st))
913 Compound
(vk_statement_sequencable_list_s bigf statxs
)
914 | ExprStatement
(None
) -> ExprStatement
(None
)
915 | ExprStatement
(Some
e) -> ExprStatement
(Some
((vk_expr_s bigf
) e))
916 | Selection
(If
(e, st1
, st2
)) ->
917 Selection
(If
((vk_expr_s bigf
) e, statf st1
, statf st2
))
918 | Selection
(Switch
(e, st)) ->
919 Selection
(Switch
((vk_expr_s bigf
) e, statf st))
920 | Iteration
(While
(e, st)) ->
921 Iteration
(While
((vk_expr_s bigf
) e, statf st))
922 | Iteration
(DoWhile
(st, e)) ->
923 Iteration
(DoWhile
(statf st, (vk_expr_s bigf
) e))
924 | Iteration
(For
((e1opt
,i1
), (e2opt
,i2
), (e3opt
,i3
), st)) ->
925 let e1opt'
= statf (ExprStatement
(e1opt),i1
) in
926 let e2opt'
= statf (ExprStatement
(e2opt),i2
) in
927 let e3opt'
= statf (ExprStatement
(e3opt),i3
) in
928 (match (e1opt'
, e2opt'
, e3opt'
) with
929 | ((ExprStatement x1
,i1
), (ExprStatement x2
,i2
), ((ExprStatement x3
,i3
))) ->
930 Iteration
(For
((x1
,i1
), (x2
,i2
), (x3
,i3
), statf st))
931 | x
-> failwith
"cant be here if iterator keep ExprStatement as is"
934 | Iteration
(MacroIteration
(s
, es
, st)) ->
938 es
+> List.map
(fun (e, ii
) ->
939 vk_argument_s bigf
e, vk_ii_s bigf ii
945 | Jump
(Goto s
) -> Jump
(Goto s
)
946 | Jump
(((Continue
|Break
|Return
) as x
)) -> Jump
(x
)
947 | Jump
(ReturnExpr
e) -> Jump
(ReturnExpr
((vk_expr_s bigf
) e))
948 | Jump
(GotoComputed
e) -> Jump
(GotoComputed
(vk_expr_s bigf
e));
950 | Decl decl
-> Decl
(vk_decl_s bigf decl
)
951 | Asm asmbody
-> Asm
(vk_asmbody_s bigf asmbody
)
952 | NestedFunc def
-> NestedFunc
(vk_def_s bigf def
)
953 | MacroStmt
-> MacroStmt
959 and vk_statement_sequencable_s
= fun bigf stseq
->
960 let f = bigf
.kstatementseq_s
in
965 StmtElem
(vk_statement_s bigf
st)
966 | CppDirectiveStmt directive
->
967 CppDirectiveStmt
(vk_cpp_directive_s bigf directive
)
969 IfdefStmt
(vk_ifdef_directive_s bigf ifdef
)
970 | IfdefStmt2
(ifdef
, xxs
) ->
971 let ifdef'
= List.map
(vk_ifdef_directive_s bigf
) ifdef in
972 let xxs'
= xxs +> List.map
(fun xs
->
973 xs
+> List.map
(vk_statement_sequencable_s bigf
)
976 IfdefStmt2
(ifdef'
, xxs'
)
979 and vk_statement_sequencable_list_s
= fun bigf statxs
->
980 let f = bigf
.kstatementseq_list_s
in
982 xs
+> List.map
(vk_statement_sequencable_s bigf
)
988 and vk_asmbody_s
= fun bigf
(string_list
, colon_list
) ->
989 let iif ii
= vk_ii_s bigf ii
in
992 colon_list
+> List.map
(fun (Colon xs
, ii
) ->
994 (xs
+> List.map
(fun (x
, iicomma
) ->
996 | ColonMisc
, ii
-> ColonMisc
, iif ii
997 | ColonExpr
e, ii
-> ColonExpr
(vk_expr_s bigf
e), iif ii
1006 and vk_type_s
= fun bigf t
->
1007 let rec typef t
= bigf
.ktype_s
(k,bigf
) t
1008 and iif ii
= vk_ii_s bigf ii
1011 let (unwrap_q
, iiq
) = q
in
1012 let q'
= unwrap_q
in (* todo? a visitor for qualifier *)
1013 let (unwrap_t
, iit
) = t
in
1016 | BaseType x
-> BaseType x
1017 | Pointer
t -> Pointer
(typef t)
1018 | Array
(eopt
, t) -> Array
(fmap
(vk_expr_s bigf
) eopt
, typef t)
1019 | FunctionType
(returnt
, paramst
) ->
1023 | (ts
, (b
, iihas3dots
)) ->
1024 (ts
+> List.map
(fun (param
,iicomma
) ->
1025 (vk_param_s bigf param
, iif iicomma
)),
1026 (b
, iif iihas3dots
))
1029 | Enum
(sopt
, enumt
) ->
1031 enumt
+> List.map
(fun (((s
, eopt
),ii_s_eq
), iicomma
) ->
1032 ((s
, fmap
(vk_expr_s bigf
) eopt
), iif ii_s_eq
),
1036 | StructUnion
(sopt
, su
, fields
) ->
1037 StructUnion
(sopt
, su
, vk_struct_fields_s bigf fields
)
1040 | StructUnionName
(s
, structunion
) -> StructUnionName
(s
, structunion
)
1041 | EnumName s
-> EnumName s
1042 | TypeName
(s
, typ) -> TypeName
(s
, typ)
1044 | ParenType
t -> ParenType
(typef t)
1045 | TypeOfExpr
e -> TypeOfExpr
(vk_expr_s bigf
e)
1046 | TypeOfType
t -> TypeOfType
(typef t)
1054 and vk_attribute_s
= fun bigf attr
->
1055 let iif ii
= vk_ii_s bigf ii
in
1057 | Attribute s
, ii
->
1062 and vk_decl_s
= fun bigf d
->
1063 let f = bigf
.kdecl_s
in
1064 let iif ii
= vk_ii_s bigf ii
in
1067 | DeclList
(xs
, ii
) ->
1068 DeclList
(List.map aux xs
, iif ii
)
1069 | MacroDecl
((s
, args
),ii
) ->
1072 args
+> List.map
(fun (e,ii
) -> vk_argument_s bigf
e, iif ii
)
1077 and aux
({v_namei
= var
; v_type
= t;
1078 v_storage
= sto
; v_local
= local
; v_attr
= attrs
}, iicomma
) =
1080 (var
+> map_option
(fun ((s
, ini
), ii_s_ini
) ->
1081 (s
, ini
+> map_option
(fun init
-> vk_ini_s bigf init
)),
1085 v_type
= vk_type_s bigf
t;
1088 v_attr
= attrs
+> List.map
(vk_attribute_s bigf
);
1094 and vk_ini_s
= fun bigf ini
->
1095 let rec inif ini
= bigf
.kini_s
(k,bigf
) ini
1097 let (unwrap_ini
, ii
) = ini
in
1099 match unwrap_ini
with
1100 | InitExpr
e -> InitExpr
(vk_expr_s bigf
e)
1101 | InitList initxs
->
1102 InitList
(initxs
+> List.map
(fun (ini, ii
) ->
1103 inif ini, vk_ii_s bigf ii
)
1107 | InitDesignators
(xs
, e) ->
1109 (xs
+> List.map
(vk_designator_s bigf
),
1113 | InitFieldOld
(s
, e) -> InitFieldOld
(s
, inif e)
1114 | InitIndexOld
(e1
, e) -> InitIndexOld
(vk_expr_s bigf e1
, inif e)
1117 in ini'
, vk_ii_s bigf ii
1121 and vk_designator_s
= fun bigf design
->
1122 let iif ii
= vk_ii_s bigf ii
in
1123 let (designator
, ii
) = design
in
1124 (match designator
with
1125 | DesignatorField s
-> DesignatorField s
1126 | DesignatorIndex
e -> DesignatorIndex
(vk_expr_s bigf
e)
1127 | DesignatorRange
(e1
, e2
) ->
1128 DesignatorRange
(vk_expr_s bigf e1
, vk_expr_s bigf e2
)
1134 and vk_struct_fieldkinds_s
= fun bigf onefield_multivars
->
1135 let iif ii
= vk_ii_s bigf ii
in
1137 onefield_multivars
+> List.map
(fun (field
, iicomma
) ->
1139 | Simple
(s
, t), iis
-> Simple
(s
, vk_type_s bigf
t), iif iis
1140 | BitField
(sopt
, t, expr
), iis
->
1141 BitField
(sopt
, vk_type_s bigf
t, vk_expr_s bigf expr
),
1146 and vk_struct_fields_s
= fun bigf fields
->
1148 let iif ii
= vk_ii_s bigf ii
in
1150 fields
+> List.map
(fun (xfield
, iiptvirg
) ->
1153 | (DeclarationField
(FieldDeclList
(onefield_multivars
, iiptvirg
))) ->
1156 (vk_struct_fieldkinds_s bigf onefield_multivars
, iif iiptvirg
))
1157 | EmptyField
-> EmptyField
1158 | MacroStructDeclTodo
->
1159 pr2
"MacroStructDeclTodo";
1162 | CppDirectiveStruct directive
->
1163 CppDirectiveStruct
(vk_cpp_directive_s bigf directive
)
1164 | IfdefStruct
ifdef ->
1165 IfdefStruct
(vk_ifdef_directive_s bigf
ifdef)
1171 and vk_def_s
= fun bigf d
->
1172 let f = bigf
.kdef_s
in
1173 let iif ii
= vk_ii_s bigf ii
in
1177 f_type
= (returnt
, (paramst
, (b
, iib
)));
1185 (vk_type_s bigf returnt
,
1186 (paramst
+> List.map
(fun (param
, iicomma
) ->
1187 (vk_param_s bigf param
, iif iicomma
)
1191 vk_statement_sequencable_list_s bigf statxs
;
1193 attrs
+> List.map
(vk_attribute_s bigf
)
1199 and vk_toplevel_s
= fun bigf p
->
1200 let f = bigf
.ktoplevel_s
in
1201 let iif ii
= vk_ii_s bigf ii
in
1204 | Declaration decl
-> Declaration
(vk_decl_s bigf decl
)
1205 | Definition def
-> Definition
(vk_def_s bigf def
)
1206 | EmptyDef ii
-> EmptyDef
(iif ii
)
1207 | MacroTop
(s
, xs
, ii
) ->
1210 xs
+> List.map
(fun (elem
, iicomma
) ->
1211 vk_argument_s bigf elem
, iif iicomma
1215 | CppTop top
-> CppTop
(vk_cpp_directive_s bigf top
)
1216 | IfdefTop ifdefdir
-> IfdefTop
(vk_ifdef_directive_s bigf ifdefdir
)
1218 | NotParsedCorrectly ii
-> NotParsedCorrectly
(iif ii
)
1219 | FinalDef info
-> FinalDef
(vk_info_s bigf info
)
1222 and vk_program_s
= fun bigf xs
->
1223 xs
+> List.map
(vk_toplevel_s bigf
)
1226 and vk_cpp_directive_s
= fun bigf top
->
1227 let iif ii
= vk_ii_s bigf ii
in
1228 let f = bigf
.kcppdirective_s
in
1232 | Include
{i_include
= (s
, ii
);
1233 i_rel_pos
= h_rel_pos
;
1237 -> Include
{i_include
= (s
, iif ii
);
1238 i_rel_pos
= h_rel_pos
;
1240 i_content
= copt
+> Common.map_option
(fun (file
, asts
) ->
1241 file
, vk_program_s bigf asts
1244 | Define
((s
,ii
), (defkind
, defval
)) ->
1245 Define
((s
, iif ii
),
1246 (vk_define_kind_s bigf defkind
, vk_define_val_s bigf defval
))
1247 | Undef
(s
, ii
) -> Undef
(s
, iif ii
)
1248 | PragmaAndCo
(ii
) -> PragmaAndCo
(iif ii
)
1252 and vk_ifdef_directive_s
= fun bigf
ifdef ->
1253 let iif ii
= vk_ii_s bigf ii
in
1255 | IfdefDirective
(ifkind
, ii
) -> IfdefDirective
(ifkind
, iif ii
)
1259 and vk_define_kind_s
= fun bigf defkind
->
1261 | DefineVar
-> DefineVar
1262 | DefineFunc
(params
, ii
) ->
1264 (params
+> List.map
(fun ((s
,iis
),iicomma
) ->
1265 ((s
, vk_ii_s bigf iis
), vk_ii_s bigf iicomma
)
1271 and vk_define_val_s
= fun bigf x
->
1272 let f = bigf
.kdefineval_s
in
1273 let iif ii
= vk_ii_s bigf ii
in
1276 | DefineExpr
e -> DefineExpr
(vk_expr_s bigf
e)
1277 | DefineStmt
st -> DefineStmt
(vk_statement_s bigf
st)
1278 | DefineDoWhileZero
((st,e),ii
) ->
1279 let st'
= vk_statement_s bigf
st in
1280 let e'
= vk_expr_s bigf
e in
1281 DefineDoWhileZero
((st'
,e'
), iif ii
)
1282 | DefineFunction def
-> DefineFunction
(vk_def_s bigf def
)
1283 | DefineType ty
-> DefineType
(vk_type_s bigf ty
)
1284 | DefineText
(s
, ii
) -> DefineText
(s
, iif ii
)
1285 | DefineEmpty
-> DefineEmpty
1286 | DefineInit
ini -> DefineInit
(vk_ini_s bigf
ini)
1295 and vk_info_s
= fun bigf info
->
1296 let rec infof ii
= bigf
.kinfo_s
(k, bigf
) ii
1301 and vk_ii_s
= fun bigf ii
->
1302 List.map
(vk_info_s bigf
) ii
1304 (* ------------------------------------------------------------------------ *)
1305 and vk_node_s
= fun bigf node
->
1306 let iif ii
= vk_ii_s bigf ii
in
1307 let infof info
= vk_info_s bigf info
in
1309 let rec nodef n
= bigf
.knode_s
(k, bigf
) n
1312 match F.unwrap node
with
1313 | F.FunHeader
({f_name
= idb
;
1314 f_type
=(rett
, (paramst
,(isvaargs
,iidotsb
)));
1324 (vk_type_s bigf rett
,
1325 (paramst
+> List.map
(fun (param
, iicomma
) ->
1326 (vk_param_s bigf param
, iif iicomma
)
1327 ), (isvaargs
,iif iidotsb
)));
1331 attrs
+> List.map
(vk_attribute_s bigf
)
1336 | F.Decl declb
-> F.Decl
(vk_decl_s bigf declb
)
1337 | F.ExprStatement
(st, (eopt
, ii
)) ->
1338 F.ExprStatement
(st, (eopt
+> map_option
(vk_expr_s bigf
), iif ii
))
1340 | F.IfHeader
(st, (e,ii
)) ->
1341 F.IfHeader
(st, (vk_expr_s bigf
e, iif ii
))
1342 | F.SwitchHeader
(st, (e,ii
)) ->
1343 F.SwitchHeader
(st, (vk_expr_s bigf
e, iif ii
))
1344 | F.WhileHeader
(st, (e,ii
)) ->
1345 F.WhileHeader
(st, (vk_expr_s bigf
e, iif ii
))
1346 | F.DoWhileTail
(e,ii
) ->
1347 F.DoWhileTail
(vk_expr_s bigf
e, iif ii
)
1349 | F.ForHeader
(st, (((e1opt,i1
), (e2opt,i2
), (e3opt,i3
)), ii
)) ->
1351 (((e1opt +> Common.map_option
(vk_expr_s bigf
), iif i1
),
1352 (e2opt +> Common.map_option
(vk_expr_s bigf
), iif i2
),
1353 (e3opt +> Common.map_option
(vk_expr_s bigf
), iif i3
)),
1356 | F.MacroIterHeader
(st, ((s
,es
), ii
)) ->
1359 ((s
, es
+> List.map
(fun (e, ii
) -> vk_argument_s bigf
e, iif ii
)),
1363 | F.ReturnExpr
(st, (e,ii
)) ->
1364 F.ReturnExpr
(st, (vk_expr_s bigf
e, iif ii
))
1366 | F.Case
(st, (e,ii
)) -> F.Case
(st, (vk_expr_s bigf
e, iif ii
))
1367 | F.CaseRange
(st, ((e1
, e2
),ii
)) ->
1368 F.CaseRange
(st, ((vk_expr_s bigf e1
, vk_expr_s bigf e2
), iif ii
))
1370 | F.CaseNode i
-> F.CaseNode i
1372 | F.DefineHeader
((s
,ii
), (defkind
)) ->
1373 F.DefineHeader
((s
, iif ii
), (vk_define_kind_s bigf defkind
))
1375 | F.DefineExpr
e -> F.DefineExpr
(vk_expr_s bigf
e)
1376 | F.DefineType ft
-> F.DefineType
(vk_type_s bigf ft
)
1377 | F.DefineDoWhileZeroHeader
((),ii
) ->
1378 F.DefineDoWhileZeroHeader
((),iif ii
)
1379 | F.DefineTodo
-> F.DefineTodo
1381 | F.Include
{i_include
= (s
, ii
);
1382 i_rel_pos
= h_rel_pos
;
1387 assert (copt
= None
);
1388 F.Include
{i_include
= (s
, iif ii
);
1389 i_rel_pos
= h_rel_pos
;
1394 | F.MacroTop
(s
, args
, ii
) ->
1397 args
+> List.map
(fun (e, ii
) -> vk_argument_s bigf
e, iif ii
),
1401 | F.MacroStmt
(st, ((),ii
)) -> F.MacroStmt
(st, ((),iif ii
))
1402 | F.Asm
(st, (body
,ii
)) -> F.Asm
(st, (vk_asmbody_s bigf body
,iif ii
))
1404 | F.Break
(st,((),ii
)) -> F.Break
(st,((),iif ii
))
1405 | F.Continue
(st,((),ii
)) -> F.Continue
(st,((),iif ii
))
1406 | F.Default
(st,((),ii
)) -> F.Default
(st,((),iif ii
))
1407 | F.Return
(st,((),ii
)) -> F.Return
(st,((),iif ii
))
1408 | F.Goto
(st, (s
,ii
)) -> F.Goto
(st, (s
,iif ii
))
1409 | F.Label
(st, (s
,ii
)) -> F.Label
(st, (s
,iif ii
))
1410 | F.EndStatement iopt
-> F.EndStatement
(map_option
infof iopt
)
1411 | F.DoHeader
(st, info
) -> F.DoHeader
(st, infof info
)
1412 | F.Else info
-> F.Else
(infof info
)
1413 | F.SeqEnd
(i
, info
) -> F.SeqEnd
(i
, infof info
)
1414 | F.SeqStart
(st, i
, info
) -> F.SeqStart
(st, i
, infof info
)
1416 | F.IfdefHeader
(info
) -> F.IfdefHeader
(vk_ifdef_directive_s bigf info
)
1417 | F.IfdefElse
(info
) -> F.IfdefElse
(vk_ifdef_directive_s bigf info
)
1418 | F.IfdefEndif
(info
) -> F.IfdefEndif
(vk_ifdef_directive_s bigf info
)
1422 F.TopNode
|F.EndNode
|
1423 F.ErrorExit
|F.Exit
|F.Enter
|
1424 F.FallThroughNode
|F.AfterNode
|F.FalseNode
|F.TrueNode
|F.InLoopNode
|
1433 (* ------------------------------------------------------------------------ *)
1434 and vk_param_s
= fun bigf
((b
, s
, t), ii_b_s
) ->
1435 let iif ii
= vk_ii_s bigf ii
in
1436 ((b
, s
, vk_type_s bigf
t), iif ii_b_s
)
1438 let vk_args_splitted_s = fun bigf args_splitted
->
1439 let iif ii
= vk_ii_s bigf ii
in
1440 args_splitted
+> List.map
(function
1441 | Left arg
-> Left
(vk_argument_s bigf arg
)
1442 | Right ii
-> Right
(iif ii
)
1445 let vk_arguments_s = fun bigf args
->
1446 let iif ii
= vk_ii_s bigf ii
in
1447 args
+> List.map
(fun (e, ii
) -> vk_argument_s bigf
e, iif ii
)
1450 let vk_params_splitted_s = fun bigf args_splitted
->
1451 let iif ii
= vk_ii_s bigf ii
in
1452 args_splitted
+> List.map
(function
1453 | Left arg
-> Left
(vk_param_s bigf arg
)
1454 | Right ii
-> Right
(iif ii
)
1457 let vk_params_s = fun bigf args
->
1458 let iif ii
= vk_ii_s bigf ii
in
1459 args
+> List.map
(fun (p
,ii
) -> vk_param_s bigf p
, iif ii
)
1461 let vk_define_params_splitted_s = fun bigf args_splitted
->
1462 let iif ii
= vk_ii_s bigf ii
in
1463 args_splitted
+> List.map
(function
1464 | Left
(s
, iis
) -> Left
(s
, vk_ii_s bigf iis
)
1465 | Right ii
-> Right
(iif ii
)
1468 let vk_cst_s = fun bigf
(cst
, ii
) ->
1469 let iif ii
= vk_ii_s bigf ii
in
1471 | Left cst
-> Left cst
1472 | Right s
-> Right s