(*
- * Copyright 2010, INRIA, University of Copenhagen
+ * Copyright 2012, INRIA
+ * Julia Lawall, Gilles Muller
+ * Copyright 2010-2011, INRIA, University of Copenhagen
* Julia Lawall, Rene Rydhof Hansen, Gilles Muller, Nicolas Palix
* Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
* Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller, Nicolas Palix
*)
+# 0 "./parse_cocci.ml"
(* splits the entire file into minus and plus fragments, and parses each
separately (thus duplicating work for the parsing of the context elements) *)
| PC.TExpression -> "expression"
| PC.TIdExpression -> "idexpression"
| PC.TInitialiser -> "initialiser"
+ | PC.TSymbol -> "symbol"
| PC.TDeclaration -> "declaration"
| PC.TField -> "field"
| PC.TStatement -> "statement"
| PC.TPosition -> "position"
+ | PC.TAnalysis -> "analysis"
| PC.TPosAny -> "any"
| PC.TFunction -> "function"
| PC.TLocal -> "local"
| PC.TTypeId(s,clt) -> (pr "typename-%s" s)^(line_type2c clt)
| PC.TDeclarerId(s,clt) -> (pr "declarername-%s" s)^(line_type2c clt)
| PC.TIteratorId(s,clt) -> (pr "iteratorname-%s" s)^(line_type2c clt)
+ | PC.TSymId(s,clt) -> (pr "symbol-%s" s)^(line_type2c clt)
| PC.TMetaDeclarer(_,_,_,clt) -> "declmeta"^(line_type2c clt)
| PC.TMetaIterator(_,_,_,clt) -> "itermeta"^(line_type2c clt)
| PC.TDmOp(op,clt) ->
(match op with
Ast.Div -> "/"
+ | Ast.Min -> "<?"
+ | Ast.Max -> ">?"
| Ast.Mod -> "%"
| _ -> failwith "not possible")
^(line_type2c clt)
| PC.TMetaIdExp(_,_,_,_,clt) -> "idexpmeta"^(line_type2c clt)
| PC.TMetaLocalIdExp(_,_,_,_,clt) -> "localidexpmeta"^(line_type2c clt)
| PC.TMetaExpList(_,_,_,clt) -> "explistmeta"^(line_type2c clt)
- | PC.TMetaId(nm,_,_,clt) -> "idmeta-"^(Dumper.dump nm)^(line_type2c clt)
+ | PC.TMetaId(nm,_,_,_,clt) -> "idmeta-"^(Dumper.dump nm)^(line_type2c clt)
| PC.TMetaType(_,_,clt) -> "typemeta"^(line_type2c clt)
| PC.TMetaInit(_,_,clt) -> "initmeta"^(line_type2c clt)
+ | PC.TMetaInitList(_,_,_,clt) -> "initlistmeta"^(line_type2c clt)
| PC.TMetaDecl(_,_,clt) -> "declmeta"^(line_type2c clt)
| PC.TMetaField(_,_,clt) -> "fieldmeta"^(line_type2c clt)
| PC.TMetaFieldList(_,_,_,clt) -> "fieldlistmeta"^(line_type2c clt)
| PC.TMPtVirg -> ";"
| PC.TArobArob -> "@@"
| PC.TArob -> "@"
- | PC.TPArob -> "P@"
+ | PC.TPArob clt -> "P@"
| PC.TScript -> "script"
| PC.TInitialize -> "initialize"
| PC.TFinalize -> "finalize"
let print_tokens s tokens =
Printf.printf "%s\n" s;
- List.iter (function x -> Printf.printf "%s " (token2c x)) tokens;
+ List.iter (function x -> Printf.printf "|%s| " (token2c x)) tokens;
Printf.printf "\n\n";
flush stdout
| PC.TMetaExp(_,_,_,_,clt) | PC.TMetaIdExp(_,_,_,_,clt)
| PC.TMetaLocalIdExp(_,_,_,_,clt)
| PC.TMetaExpList(_,_,_,clt)
- | PC.TMetaId(_,_,_,clt)
- | PC.TMetaType(_,_,clt) | PC.TMetaInit(_,_,clt) | PC.TMetaStm(_,_,clt)
+ | PC.TMetaId(_,_,_,_,clt)
+ | PC.TMetaType(_,_,clt) | PC.TMetaInit(_,_,clt) | PC.TMetaInitList(_,_,_,clt)
+ | PC.TMetaStm(_,_,clt)
| PC.TMetaStmList(_,_,clt)
| PC.TMetaDecl(_,_,clt) | PC.TMetaField(_,_,clt)
| PC.TMetaFieldList(_,_,_,clt)
| PC.TIf(clt) | PC.TElse(clt) | PC.TWhile(clt) | PC.TFor(clt) | PC.TDo(clt)
| PC.TSwitch(clt) | PC.TCase(clt) | PC.TDefault(clt) | PC.TReturn(clt)
| PC.TBreak(clt) | PC.TContinue(clt) | PC.TGoto(clt) | PC.TIdent(_,clt)
- | PC.TTypeId(_,clt) | PC.TDeclarerId(_,clt) | PC.TIteratorId(_,clt)
-
+ | PC.TTypeId(_,clt) | PC.TSymId(_,clt)
+ | PC.TDeclarerId(_,clt) | PC.TIteratorId(_,clt)
+
| PC.TSizeof(clt)
| PC.TString(_,clt) | PC.TChar(_,clt) | PC.TFloat(_,clt) | PC.TInt(_,clt)
| PC.TMetaExp(_,_,_,_,clt) | PC.TMetaIdExp(_,_,_,_,clt)
| PC.TMetaLocalIdExp(_,_,_,_,clt)
| PC.TMetaExpList(_,_,_,clt)
- | PC.TMetaId(_,_,_,clt)
- | PC.TMetaType(_,_,clt) | PC.TMetaInit(_,_,clt) | PC.TMetaStm(_,_,clt)
+ | PC.TMetaId(_,_,_,_,clt)
+ | PC.TMetaType(_,_,clt) | PC.TMetaInit(_,_,clt) | PC.TMetaInitList(_,_,_,clt)
+ | PC.TMetaStm(_,_,clt)
| PC.TMetaStmList(_,_,clt)
| PC.TMetaDecl(_,_,clt) | PC.TMetaField(_,_,clt)
| PC.TMetaFieldList(_,_,_,clt)
| PC.TMetaFunc(_,_,_,clt) | PC.TMetaLocalFunc(_,_,_,clt)
| PC.TMetaPos(_,_,_,clt)
+ | PC.TMetaDeclarer(_,_,_,clt) | PC.TMetaIterator(_,_,_,clt)
| PC.TWhen(clt) | PC.TWhenTrue(clt) | PC.TWhenFalse(clt) |
PC.TAny(clt) | PC.TStrict(clt) | PC.TEllipsis(clt)
| PC.TPtrOp(clt)
| PC.TEq(clt) | PC.TAssign(_,clt) | PC.TDot(clt) | PC.TComma(clt)
- | PC.TPtVirg(clt)
+ | PC.TPArob(clt) | PC.TPtVirg(clt)
| PC.TOPar0(clt) | PC.TMid0(clt) | PC.TCPar0(clt)
| PC.TOEllipsis(clt) | PC.TCEllipsis(clt)
| PC.TTypeId(s,_) -> (PC.TTypeId(s,clt),x)
| PC.TDeclarerId(s,_) -> (PC.TDeclarerId(s,clt),x)
| PC.TIteratorId(s,_) -> (PC.TIteratorId(s,clt),x)
+ | PC.TSymId(a,_) -> (PC.TSymId(a,clt),x)
| PC.TSizeof(_) -> (PC.TSizeof(clt),x)
| PC.TMetaIdExp(a,b,c,d,_) -> (PC.TMetaIdExp(a,b,c,d,clt),x)
| PC.TMetaLocalIdExp(a,b,c,d,_) -> (PC.TMetaLocalIdExp(a,b,c,d,clt),x)
| PC.TMetaExpList(a,b,c,_) -> (PC.TMetaExpList(a,b,c,clt),x)
- | PC.TMetaId(a,b,c,_) -> (PC.TMetaId(a,b,c,clt),x)
+ | PC.TMetaId(a,b,c,d,_) -> (PC.TMetaId(a,b,c,d,clt),x)
| PC.TMetaType(a,b,_) -> (PC.TMetaType(a,b,clt),x)
| PC.TMetaInit(a,b,_) -> (PC.TMetaInit(a,b,clt),x)
+ | PC.TMetaInitList(a,b,c,_) -> (PC.TMetaInitList(a,b,c,clt),x)
| PC.TMetaDecl(a,b,_) -> (PC.TMetaDecl(a,b,clt),x)
| PC.TMetaField(a,b,_) -> (PC.TMetaField(a,b,clt),x)
| PC.TMetaFieldList(a,b,c,_) -> (PC.TMetaFieldList(a,b,c,clt),x)
| PC.TMetaFunc(a,b,c,_) -> (PC.TMetaFunc(a,b,c,clt),x)
| PC.TMetaLocalFunc(a,b,c,_) -> (PC.TMetaLocalFunc(a,b,c,clt),x)
+ | PC.TMetaDeclarer(a,b,c,_) -> (PC.TMetaDeclarer(a,b,c,clt),x)
+ | PC.TMetaIterator(a,b,c,_) -> (PC.TMetaIterator(a,b,c,clt),x)
+
| PC.TWhen(_) -> (PC.TWhen(clt),x)
| PC.TWhenTrue(_) -> (PC.TWhenTrue(clt),x)
| PC.TWhenFalse(_) -> (PC.TWhenFalse(clt),x)
| PC.TAssign(s,_) -> (PC.TAssign(s,clt),x)
| PC.TDot(_) -> (PC.TDot(clt),x)
| PC.TComma(_) -> (PC.TComma(clt),x)
+ | PC.TPArob(_) -> (PC.TPArob(clt),x)
| PC.TPtVirg(_) -> (PC.TPtVirg(clt),x)
| PC.TLineEnd(_) -> (PC.TLineEnd(clt),x)
let wrap_lexbuf_info lexbuf =
(Lexing.lexeme lexbuf, Lexing.lexeme_start lexbuf)
-let tokens_all_full token table file get_ats lexbuf end_markers :
+let tokens_all_full token table file get_ats lexbuf end_predicate :
(bool * ((PC.token * (string * (int * int) * (int * int))) list)) =
try
let rec aux () =
if get_ats
then failwith "unexpected end of file in a metavariable declaration"
else (false,[(result,info)])
- else if List.mem result end_markers
+ else if end_predicate result
then (true,[(result,info)])
else
let (more,rest) = aux() in
with
e -> pr2 (Common.error_message file (wrap_lexbuf_info lexbuf) ); raise e
+let in_list list tok =
+ List.mem tok list
+
let tokens_all table file get_ats lexbuf end_markers :
(bool * ((PC.token * (string * (int * int) * (int * int))) list)) =
tokens_all_full Lexer_cocci.token table file get_ats lexbuf end_markers
PC.TMetavariable | PC.TIdentifier
| PC.TConstant | PC.TExpression | PC.TIdExpression
| PC.TDeclaration | PC.TField
- | PC.TStatement | PC.TPosition | PC.TPosAny | PC.TInitialiser
+ | PC.TStatement | PC.TPosition | PC.TAnalysis | PC.TPosAny | PC.TInitialiser | PC.TSymbol
| PC.TFunction | PC.TTypedef | PC.TDeclarer | PC.TIterator | PC.TName
| PC.TType | PC.TParameter | PC.TLocal | PC.Tlist | PC.TFresh
| PC.TCppConcatOp | PC.TPure
| PC.TReturn(clt) | PC.TBreak(clt) | PC.TContinue(clt) | PC.TGoto(clt)
| PC.TIdent(_,clt)
| PC.TTypeId(_,clt) | PC.TDeclarerId(_,clt) | PC.TIteratorId(_,clt)
+ | PC.TSymId(_,clt)
| PC.TMeta(_,_,clt) | PC.TMetaConst(_,_,_,_,clt) | PC.TMetaExp(_,_,_,_,clt)
| PC.TMetaIdExp(_,_,_,_,clt) | PC.TMetaLocalIdExp(_,_,_,_,clt)
| PC.TMetaExpList(_,_,_,clt)
| PC.TMetaParam(_,_,clt) | PC.TMetaParamList(_,_,_,clt)
- | PC.TMetaId(_,_,_,clt) | PC.TMetaType(_,_,clt) | PC.TMetaInit(_,_,clt)
+ | PC.TMetaId(_,_,_,_,clt) | PC.TMetaType(_,_,clt)
+ | PC.TMetaInit(_,_,clt) | PC.TMetaInitList(_,_,_,clt)
| PC.TMetaDecl(_,_,clt) | PC.TMetaField(_,_,clt)
| PC.TMetaFieldList(_,_,_,clt)
| PC.TMetaStm(_,_,clt) | PC.TMetaStmList(_,_,clt) | PC.TMetaErr(_,_,_,clt)
| PC.TMetaDeclarer(_,_,_,clt) | PC.TMetaIterator(_,_,_,clt) -> split t clt
| PC.TMPtVirg | PC.TArob | PC.TArobArob | PC.TScript
| PC.TInitialize | PC.TFinalize -> ([t],[t])
- | PC.TPArob | PC.TMetaPos(_,_,_,_) -> ([t],[])
+ | PC.TPArob clt | PC.TMetaPos(_,_,_,clt) -> split t clt
| PC.TFunDecl(clt)
| PC.TWhen(clt) | PC.TWhenTrue(clt) | PC.TWhenFalse(clt)
let is_ident = function
(PC.TIdent(_,clt),info)
| (PC.TMeta(_,_,clt),info)
- | (PC.TMetaId(_,_,_,clt),info)
+ | (PC.TMetaId(_,_,_,_,clt),info)
| (PC.TMetaFunc(_,_,_,clt),info)
| (PC.TMetaLocalFunc(_,_,_,clt),info) -> true
| _ -> false in
let rec detect_attr l =
let is_id = function
- (PC.TIdent(_,_),_) | (PC.TMetaId(_,_,_,_),_) | (PC.TMetaFunc(_,_,_,_),_)
+ (PC.TIdent(_,_),_) | (PC.TMetaId(_,_,_,_,_),_) | (PC.TMetaFunc(_,_,_,_),_)
| (PC.TMetaLocalFunc(_,_,_,_),_) -> true
| _ -> false in
let rec loop = function
[] -> []
| [x] -> [x]
+ | ((PC.Tstruct _,_) as t1)::x::rest ->
+ t1::x::loop rest
+ | ((PC.Tunion _,_) as t1)::x::rest ->
+ t1::x::loop rest
| ((PC.TIdent(nm,clt),info) as t1)::id::rest when is_id id ->
if String.length nm > 2 && String.sub nm 0 2 = "__"
then (PC.Tattr(nm,clt),info)::(loop (id::rest))
let is_choices_delim = function
(PC.TOBrace(_),_) | (PC.TComma(_),_) -> true | _ -> false in
let is_id = function
- (PC.TIdent(_,_),_) | (PC.TMetaId(_,_,_,_),_) | (PC.TMetaFunc(_,_,_,_),_)
+ (PC.TIdent(_,_),_) | (PC.TMetaId(_,_,_,_,_),_) | (PC.TMetaFunc(_,_,_,_),_)
| (PC.TMetaLocalFunc(_,_,_,_),_) -> true
| (PC.TMetaParam(_,_,_),_)
| (PC.TMetaParamList(_,_,_,_),_)
| (PC.TMetaExpList(_,_,_,_),_)
| (PC.TMetaType(_,_,_),_)
| (PC.TMetaInit(_,_,_),_)
+ | (PC.TMetaInitList(_,_,_,_),_)
| (PC.TMetaDecl(_,_,_),_)
| (PC.TMetaField(_,_,_),_)
| (PC.TMetaFieldList(_,_,_,_),_)
| PC.TTypeId(_,clt) | PC.TDeclarerId(_,clt) | PC.TIteratorId(_,clt)
| PC.TMetaDeclarer(_,_,_,clt) | PC.TMetaIterator(_,_,_,clt)
+ | PC.TSymId(_,clt)
+
| PC.TString(_,clt) | PC.TChar(_,clt) | PC.TFloat(_,clt) | PC.TInt(_,clt)
| PC.TOrLog(clt) | PC.TAndLog(clt) | PC.TOr(clt) | PC.TXor(clt)
| PC.TMetaConst(_,_,_,_,clt) | PC.TMetaExp(_,_,_,_,clt)
| PC.TMetaIdExp(_,_,_,_,clt) | PC.TMetaLocalIdExp(_,_,_,_,clt)
| PC.TMetaExpList(_,_,_,clt)
- | PC.TMetaId(_,_,_,clt) | PC.TMetaType(_,_,clt) | PC.TMetaInit(_,_,clt)
+ | PC.TMetaId(_,_,_,_,clt) | PC.TMetaType(_,_,clt)
+ | PC.TMetaInit(_,_,clt) | PC.TMetaInitList(_,_,_,clt)
| PC.TMetaDecl(_,_,clt) | PC.TMetaField(_,_,clt)
| PC.TMetaFieldList(_,_,_,clt)
| PC.TMetaStm(_,_,clt) | PC.TMetaStmList(_,_,clt) | PC.TMetaFunc(_,_,_,clt)
| PC.TIncludeL(_,clt) | PC.TIncludeNL(_,clt)
| PC.TEq(clt) | PC.TAssign(_,clt) | PC.TDot(clt) | PC.TComma(clt)
- | PC.TPtVirg(clt) ->
+ | PC.TPArob(clt) | PC.TPtVirg(clt) ->
let (_,line,_,_,_,_,_,_) = clt in Some line
| _ -> None
(PC.TExists,a) :: (find_line_end inwhen line clt q xs)
| ((PC.TComma(clt),a) as x)::xs when token2line x = line ->
(PC.TComma(clt),a) :: (find_line_end inwhen line clt q xs)
- | ((PC.TPArob,a) as x)::xs -> (* no line #, just assume on the same line *)
- x :: (find_line_end inwhen line clt q xs)
+ | ((PC.TPArob(clt),a) as x)::xs when token2line x = line ->
+ (PC.TPArob(clt),a) :: (find_line_end inwhen line clt q xs)
| x::xs when token2line x = line -> x :: (find_line_end inwhen line clt q xs)
| xs -> (PC.TLineEnd(clt),q)::(insert_line_end xs)
(* ----------------------------------------------------------------------- *)
-(* In a nest, if the nest is -, all of the nested code must also be -.
-All are converted to context, because the next takes care of the -. *)
+(* In a nest, if the nest is -, all of the nested code must also be -. *)
let check_nests tokens =
let is_minus t =
let (line_type,a,b,c,d,e,f,g) = get_clt t in
List.mem line_type [D.MINUS;D.OPTMINUS;D.UNIQUEMINUS] in
- let drop_minus t =
+ let check_minus t =
let clt = try Some(get_clt t) with Failure _ -> None in
match clt with
Some (line_type,a,b,c,d,e,f,g) ->
(match line_type with
- D.MINUS -> update_clt t (D.CONTEXT,a,b,c,d,e,f,g)
- | D.OPTMINUS -> update_clt t (D.OPT,a,b,c,d,e,f,g)
- | D.UNIQUEMINUS -> update_clt t (D.UNIQUE,a,b,c,d,e,f,g)
+ D.MINUS | D.OPTMINUS | D.UNIQUEMINUS -> t
| _ -> failwith "minus token expected")
| None -> t in
let rec outside = function
and inside stack = function
[] -> failwith "missing nest end"
| ((PC.TPCEllipsis(clt),q) as t)::r ->
- (drop_minus t)
+ (check_minus t)
:: (if stack = 0 then outside r else inside (stack - 1) r)
| ((PC.TPOEllipsis(clt),q) as t)::r ->
- (drop_minus t) :: (inside (stack + 1) r)
- | t :: r -> (drop_minus t) :: (inside stack r) in
+ (check_minus t) :: (inside (stack + 1) r)
+ | t :: r -> (check_minus t) :: (inside stack r) in
outside tokens
let check_parentheses tokens =
(*skips should be things like line end
skips is things before pragmas that can't be attached to, pass is things
-after. pass is used immediately. skips accumulates. *)
+after. pass is used immediately. skips accumulates.
+When stuff is added before some + code, the logical line of the + code
+becomes that of the pragma. context_neg relies on things that are adjacent
+having sequential logical lines. Not sure that this is good enough,
+as it might result in later gaps in the logical lines... *)
let rec process_pragmas bef skips = function
[] -> add_bef bef @ List.rev skips
| ((PC.TPragma(s,i),_)::_) as l ->
let (pragmas,rest) = collect_all_pragmas [] l in
let (pass,rest0) = collect_pass rest in
+ let (_,_,prag_lline,_,_,_,_,_) = i in
let (next,rest) =
match rest0 with [] -> (None,[]) | next::rest -> (Some next,rest) in
(match (bef,plus_attach true bef,next,plus_attach true next) with
(update_clt bef (a,b,c,d,e,strbef,pragmas,pos))::List.rev skips@
pass@process_pragmas None [] rest0
| (_,_,Some next,PLUS) ->
- let (a,b,c,d,e,strbef,straft,pos) = get_clt next in
+ let (a,b,lline,d,e,strbef,straft,pos) = get_clt next in
(add_bef bef) @ List.rev skips @ pass @
(process_pragmas
- (Some (update_clt next (a,b,c,d,e,pragmas,straft,pos)))
+ (Some (update_clt next (a,b,prag_lline,d,e,pragmas,straft,pos)))
[] rest)
| _ ->
(match (bef,plus_attach false bef,next,plus_attach false next) with
(update_clt bef (a,b,c,d,e,strbef,pragmas,pos))::List.rev skips@
pass@process_pragmas None [] rest0
| (_,_,Some next,PLUS) ->
- let (a,b,c,d,e,strbef,straft,pos) = get_clt next in
+ let (a,b,lline,d,e,strbef,straft,pos) = get_clt next in
(add_bef bef) @ List.rev skips @ pass @
(process_pragmas
- (Some (update_clt next (a,b,c,d,e,pragmas,straft,pos)))
+ (Some
+ (update_clt next (a,b,prag_lline,d,e,pragmas,straft,pos)))
[] rest)
| _ -> failwith "nothing to attach pragma to"))
| x::xs ->
[] -> []
| (x::xs) -> x :: loop x xs
-let rec fix f l =
- let cur = f l in
- if l = cur then l else fix f cur
+(* ignore uncomparable pcre regular expressions *)
+let strip_for_fix l =
+ List.map
+ (function
+ (PC.TMetaId(nm,_,seed,pure,clt),info) ->
+ (PC.TMetaId(nm,Ast.IdNoConstraint,seed,pure,clt),info)
+ | (PC.TMetaFunc(nm,_,pure,clt),info) ->
+ (PC.TMetaFunc(nm,Ast.IdNoConstraint,pure,clt),info)
+ | (PC.TMetaLocalFunc(nm,_,pure,clt),info) ->
+ (PC.TMetaLocalFunc(nm,Ast.IdNoConstraint,pure,clt),info)
+ | (PC.TMetaErr(nm,_,pure,clt),info) ->
+ (PC.TMetaErr(nm,Ast0.NoConstraint,pure,clt),info)
+ | (PC.TMetaExp(nm,_,pure,ty,clt),info) ->
+ (PC.TMetaExp(nm,Ast0.NoConstraint,pure,ty,clt),info)
+ | (PC.TMetaIdExp(nm,_,pure,ty,clt),info) ->
+ (PC.TMetaIdExp(nm,Ast0.NoConstraint,pure,ty,clt),info)
+ | (PC.TMetaLocalIdExp(nm,_,pure,ty,clt),info) ->
+ (PC.TMetaLocalIdExp(nm,Ast0.NoConstraint,pure,ty,clt),info)
+ | (PC.TMetaConst(nm,_,pure,ty,clt),info) ->
+ (PC.TMetaConst(nm,Ast0.NoConstraint,pure,ty,clt),info)
+ | t -> t)
+ l
+
+let fix f l =
+ let rec loop f l stripped_l =
+ let cur = f l in
+ let stripped_cur = strip_for_fix cur in
+ if stripped_l = stripped_cur then l else loop f cur stripped_cur in
+ loop f l (strip_for_fix l)
(* ( | ... | ) also causes parsing problems *)
let reinit _ =
PC.reinit (function _ -> PC.TArobArob (* a handy token *))
(Lexing.from_function
- (function buf -> function n -> raise Common.Impossible))
+ (function buf -> function n -> raise (Common.Impossible 157)))
let parse_one str parsefn file toks =
let all_tokens = ref toks in
let lexbuf_fake =
Lexing.from_function
- (function buf -> function n -> raise Common.Impossible)
+ (function buf -> function n -> raise (Common.Impossible 158))
in
reinit();
let prepare_mv_tokens tokens =
detect_types false (detect_attr tokens)
-let rec consume_minus_positions = function
+let unminus (d,x1,x2,x3,x4,x5,x6,x7) = (* for hidden variables *)
+ match d with
+ D.MINUS | D.OPTMINUS | D.UNIQUEMINUS -> (D.CONTEXT,x1,x2,x3,x4,x5,x6,x7)
+ | D.PLUS -> failwith "unexpected plus code"
+ | D.PLUSPLUS -> failwith "unexpected plus code"
+ | D.CONTEXT | D.UNIQUE | D.OPT -> (D.CONTEXT,x1,x2,x3,x4,x5,x6,x7)
+
+let process_minus_positions x name clt meta =
+ let (arity,ln,lln,offset,col,strbef,straft,pos) = get_clt x in
+ let name = Parse_aux.clt2mcode name (unminus clt) in
+ update_clt x (arity,ln,lln,offset,col,strbef,straft,meta name::pos)
+
+(* first attach positions, then the others, so that positions can refer to
+the larger term represented by the preceding metavariable *)
+let rec consume_minus_positions toks =
+ let rec loop_pos = function
+ [] -> []
+ | ((PC.TOPar0(_),_) as x)::xs | ((PC.TCPar0(_),_) as x)::xs
+ | ((PC.TMid0(_),_) as x)::xs -> x::loop_pos xs
+ | x::(PC.TPArob _,_)::(PC.TMetaPos(name,constraints,per,clt),_)::xs ->
+ let x =
+ process_minus_positions x name clt
+ (function name ->
+ Ast0.MetaPosTag(Ast0.MetaPos(name,constraints,per))) in
+ (loop_pos (x::xs))
+ | x::xs -> x::loop_pos xs in
+ let rec loop_other = function
+ [] -> []
+ | ((PC.TOPar0(_),_) as x)::xs | ((PC.TCPar0(_),_) as x)::xs
+ | ((PC.TMid0(_),_) as x)::xs -> x::loop_other xs
+ | x::(PC.TPArob _,_)::(PC.TMetaId(name,constraints,seed,pure,clt),_)::xs ->
+ let x =
+ process_minus_positions x name clt
+ (function name ->
+ Ast0.IdentTag
+ (Ast0.wrap
+ (Ast0.MetaId(name,constraints,seed,pure)))) in
+ (loop_other (x::xs))
+ | x::(PC.TPArob _,_)::(PC.TMetaExp(name,constraints,pure,ty,clt),_)::xs ->
+ let x =
+ process_minus_positions x name clt
+ (function name ->
+ Ast0.ExprTag
+ (Ast0.wrap
+ (Ast0.MetaExpr(name,constraints,ty,Ast.ANY,pure)))) in
+ (loop_other (x::xs))
+ | x::(PC.TPArob _,_)::(PC.TMetaExpList(name,len,pure,clt),_)::xs ->
+ let x =
+ process_minus_positions x name clt
+ (function name ->
+ let len =
+ match len with
+ Ast.AnyLen -> Ast0.AnyListLen
+ | Ast.MetaLen nm ->
+ Ast0.MetaListLen(Parse_aux.clt2mcode nm clt)
+ | Ast.CstLen n -> Ast0.CstListLen n in
+ Ast0.ExprTag
+ (Ast0.wrap
+ (Ast0.MetaExprList(name,len,pure)))) in
+ (loop_other (x::xs))
+ | x::(PC.TPArob _,_)::(PC.TMetaInit(name,pure,clt),_)::xs ->
+ let x =
+ process_minus_positions x name clt
+ (function name ->
+ Ast0.InitTag(Ast0.wrap(Ast0.MetaInit(name,pure)))) in
+ (loop_other (x::xs))
+ | x::(PC.TPArob _,_)::(PC.TMetaType(name,pure,clt),_)::xs ->
+ let x =
+ process_minus_positions x name clt
+ (function name ->
+ Ast0.TypeCTag(Ast0.wrap(Ast0.MetaType(name,pure)))) in
+ (loop_other (x::xs))
+ | x::(PC.TPArob _,_)::(PC.TMetaDecl(name,pure,clt),_)::xs ->
+ let x =
+ process_minus_positions x name clt
+ (function name ->
+ Ast0.DeclTag(Ast0.wrap(Ast0.MetaDecl(name,pure)))) in
+ (loop_other (x::xs))
+ | x::(PC.TPArob _,_)::(PC.TMetaStm(name,pure,clt),_)::xs ->
+ let x =
+ process_minus_positions x name clt
+ (function name ->
+ Ast0.StmtTag(Ast0.wrap(Ast0.MetaStmt(name,pure)))) in
+ (loop_other (x::xs))
+ | x::(PC.TPArob _,_)::(PC.TMetaIdExp(name,constraints,pure,ty,clt),_)::xs ->
+ let x =
+ process_minus_positions x name clt
+ (function name ->
+ Ast0.ExprTag
+ (Ast0.wrap
+ (Ast0.MetaExpr(name,constraints,ty,Ast.ANY,pure)))) in
+ (loop_other (x::xs))
+
+ | x::((PC.TPArob _,_) as x')::x''::xs ->
+ x::loop_other (x'::x''::xs)
+
+ | x::xs -> x::loop_other xs in
+ loop_other(loop_pos toks)
+
+let rec consume_plus_positions = function
[] -> []
- | ((PC.TOPar0(_),_) as x)::xs | ((PC.TCPar0(_),_) as x)::xs
- | ((PC.TMid0(_),_) as x)::xs -> x::consume_minus_positions xs
- | x::(PC.TPArob,_)::(PC.TMetaPos(name,constraints,per,clt),_)::xs ->
- let (arity,ln,lln,offset,col,strbef,straft,_) = get_clt x in
- let name = Parse_aux.clt2mcode name clt in
- let x =
- update_clt x
- (arity,ln,lln,offset,col,strbef,straft,
- Ast0.MetaPos(name,constraints,per)) in
- x::(consume_minus_positions xs)
- | x::xs -> x::consume_minus_positions xs
+ | (PC.TPArob _,_)::x::xs -> consume_plus_positions xs
+ | x::xs -> x::consume_plus_positions xs
let any_modif rule =
let mcode x =
mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
donothing donothing donothing donothing donothing donothing
donothing donothing donothing donothing donothing donothing donothing
- donothing donothing in
+ donothing donothing donothing in
List.exists fn.VT0.combiner_rec_top_level rule
let eval_virt virt =
| Common.Right e -> part_either left (e :: right) l) in
part_either [] [] l
+let rec collect_script_tokens = function
+ [(PC.EOF,_)] | [(PC.TArobArob,_)] | [(PC.TArob,_)] -> ""
+ | (PC.TScriptData(s),_)::[] ->
+ s
+ | (PC.TScriptData(s),_)::xs ->
+ s^(collect_script_tokens xs)
+ | toks ->
+ List.iter
+ (function x ->
+ Printf.printf "%s\n" (token2c x))
+ toks;
+ failwith "Malformed script rule"
+
let get_metavars parse_fn table file lexbuf =
let rec meta_loop acc (* read one decl at a time *) =
let (_,tokens) =
Data.call_in_meta
(function _ ->
- tokens_all table file true lexbuf [PC.TArobArob;PC.TMPtVirg]) in
+ tokens_all table file true lexbuf (in_list [PC.TArobArob;PC.TMPtVirg;PC.TAnalysis])) in
let tokens = prepare_mv_tokens tokens in
match tokens with
[(PC.TArobArob,_)] -> List.rev acc
+ | (PC.TAnalysis _, _) :: tl ->
+ Lexer_script.file := file;
+ Lexer_script.language := "ocaml";
+ let get_tokens = tokens_script_all table file false lexbuf in
+ let rec loop n toks =
+ let (more, newtoks) = get_tokens (in_list [PC.TScriptData ")"]) in
+ (* we stop at the first close paren*)
+ let n = n - 1 in
+ (* count open parens *)
+ let count str toks =
+ List.fold_left (fun n (t, _) ->
+ if t = PC.TScriptData str
+ then n + 1
+ else n) 0 toks in
+ let n = n + count "(" newtoks in
+ (* continue parsing *)
+ if n = 0
+ then toks @ newtoks
+ else loop n (toks @ newtoks) in
+ begin
+ match get_tokens (in_list [PC.TScriptData "("]) with
+ | (_, ([(s, _)] as toks)) ->
+ let data = collect_script_tokens (loop 1 toks) in
+ let (_,tokens) =
+ Data.call_in_meta
+ (function _ ->
+ tokens_all table file true lexbuf (in_list [PC.TArobArob;PC.TMPtVirg])) in
+ begin
+ match tokens with
+ | [(PC.TIdent (id, _), _); (PC.TMPtVirg, _)] ->
+ let metavar = Common.Left (Ast.MetaAnalysisDecl (data, (!Ast0.rule_name, id))) in
+ meta_loop (metavar :: acc)
+ | _ -> failwith "'analysis' can only have one variable"
+ end
+ | (_, toks) -> failwith ("'analysis' should be followed by an '(', but was followed by:\n"^(collect_script_tokens toks))
+ end
+
| _ ->
let metavars = parse_one "meta" parse_fn file tokens in
meta_loop (metavars@acc) in
let get_script_metavars parse_fn table file lexbuf =
let rec meta_loop acc =
let (_, tokens) =
- tokens_all table file true lexbuf [PC.TArobArob; PC.TMPtVirg] in
+ tokens_all table file true lexbuf (in_list [PC.TArobArob; PC.TMPtVirg]) in
let tokens = prepare_tokens tokens in
match tokens with
[(PC.TArobArob, _)] -> List.rev acc
let name_res =
if starts_with_name
then
- let (_,tokens) = get_tokens [PC.TArob] in
+ let (_,tokens) = get_tokens (in_list [PC.TArob]) in
let check_name = function
None -> Some (mknm())
| Some nm ->
let lexbuf = Lexing.from_channel channel in
let get_tokens = tokens_all table file false lexbuf in
let res =
- match get_tokens [PC.TArobArob;PC.TArob] with
+ match get_tokens (in_list [PC.TArobArob;PC.TArob]) with
(true,start) ->
let parse_start start =
let rev = List.rev start in
(* get the rule *)
let (more,tokens) =
get_tokens
- [PC.TIsoStatement;PC.TIsoExpression;PC.TIsoArgExpression;
+ (in_list [PC.TIsoStatement;PC.TIsoExpression;PC.TIsoArgExpression;
PC.TIsoTestExpression; PC.TIsoToTestExpression;
- PC.TIsoDeclaration;PC.TIsoType;PC.TIsoTopLevel] in
+ PC.TIsoDeclaration;PC.TIsoType;PC.TIsoTopLevel]) in
let next_start = List.hd(List.rev tokens) in
let dummy_info = ("",(-1,-1),(-1,-1)) in
let tokens = drop_last [(PC.EOF,dummy_info)] tokens in
let tokens = prepare_tokens (start@tokens) in
(*
print_tokens "iso tokens" tokens;
- å*)
+ *)
let entry = parse_one "iso main" PC.iso_main file tokens in
let entry = List.map (List.map Test_exps.process_anything) entry in
if more
then (* The code below allows a header like Statement list,
which is more than one word. We don't have that any more,
but the code is left here in case it is put back. *)
- match get_tokens [PC.TArobArob;PC.TArob] with
+ match get_tokens (in_list [PC.TArobArob;PC.TArob]) with
(true,start) ->
let (starts_with_name,start) = parse_start start in
(iso_metavars,entry,rule_name) ::
else [(iso_metavars,entry,rule_name)] in
loop starts_with_name start
| (false,_) -> [] in
+ List.iter Iso_compile.process res;
res)
let parse_iso_files existing_isos iso_files extra_path =
List.fold_left
(function (prev,names) ->
function file ->
- Lexer_cocci.init ();
let file =
match file with
Common.Left(fl) -> Filename.concat extra_path fl
| Common.Right(fl) -> Filename.concat Config.path fl in
+ Lexer_cocci.init ();
let current = parse_iso file in
let new_names = get_names current in
if List.exists (function x -> List.mem x names) new_names
if List.mem req virt
then
if List.mem req !Flag.defined_virtual_rules
- then Some Ast.NoDep
- else None
- else Some dep
+ then Ast.NoDep
+ else Ast.FailDep
+ else dep
| Ast.AntiDep antireq | Ast.NeverDep antireq ->
if List.mem antireq virt
then
if not(List.mem antireq !Flag.defined_virtual_rules)
- then Some Ast.NoDep
- else None
- else Some dep
+ then Ast.NoDep
+ else Ast.FailDep
+ else dep
| Ast.AndDep(d1,d2) ->
(match (loop d1, loop d2) with
- (None,_) | (_,None) -> None
- | (Some Ast.NoDep,x) | (x,Some Ast.NoDep) -> x
- | (Some x,Some y) -> Some (Ast.AndDep(x,y)))
+ (Ast.NoDep,x) | (x,Ast.NoDep) -> x
+ | (Ast.FailDep,x) | (x,Ast.FailDep) -> Ast.FailDep
+ | (x,y) -> Ast.AndDep(x,y))
| Ast.OrDep(d1,d2) ->
(match (loop d1, loop d2) with
- (None,None) -> None
- | (Some Ast.NoDep,x) | (x,Some Ast.NoDep) -> Some Ast.NoDep
- | (None,x) | (x,None) -> x
- | (Some x,Some y) -> Some (Ast.OrDep(x,y)))
- | Ast.NoDep | Ast.FailDep -> Some dep
+ (Ast.NoDep,x) | (x,Ast.NoDep) -> Ast.NoDep
+ | (Ast.FailDep,x) | (x,Ast.FailDep) -> x
+ | (x,y) -> Ast.OrDep(x,y))
+ | Ast.NoDep | Ast.FailDep -> dep
in
loop dep
let parse file =
- Lexer_cocci.init();
+ Lexer_cocci.init ();
let rec parse_loop file =
Lexer_cocci.include_init ();
let table = Common.full_charpos_to_pos file in
let lexbuf = Lexing.from_channel channel in
let get_tokens = tokens_all table file false lexbuf in
Data.in_prolog := true;
- let initial_tokens = get_tokens [PC.TArobArob;PC.TArob] in
+ let initial_tokens = get_tokens (in_list [PC.TArobArob;PC.TArob]) in
Data.in_prolog := false;
let res =
match initial_tokens with
Lexer_cocci.metavariables []);
(* get transformation rules *)
- let (more, tokens) = get_tokens [PC.TArobArob; PC.TArob] in
+ let (more, tokens) = get_tokens (in_list [PC.TArobArob; PC.TArob]) in
let (minus_tokens, _) = split_token_stream tokens in
let (_, plus_tokens) =
split_token_stream (minus_to_nothing tokens) in
*)
let minus_tokens = consume_minus_positions minus_tokens in
+ let plus_tokens = consume_plus_positions plus_tokens in
let minus_tokens = prepare_tokens minus_tokens in
let plus_tokens = prepare_tokens plus_tokens in
then (* not actually used for anything, except context_neg *)
List.map
(Iso_pattern.rebuild_mcode None).VT0.rebuilder_rec_top_level
- minus_res
+ (Top_level.top_level false minus_res)
else
if is_expression
then parse_one "plus" PC.plus_exp_main file plus_tokens
else parse_one "plus" PC.plus_main file plus_tokens in
+ let plus_res = Top_level.top_level false plus_res in
+ (* minus code has to be CODE if the + code is CODE, otherwise
+ doesn't matter if + code is CODE or DECL or TOPCODE *)
+ let minus_res =
+ let any_code =
+ List.exists
+ (function x ->
+ match Ast0.unwrap x with Ast0.CODE _ -> true | _ -> false)
+ plus_res in
+ if any_code
+ then Top_level.top_level true minus_res
+ else Top_level.top_level false minus_res in
+ let minus_res = Top_level.clean minus_res in
+ let plus_res = Top_level.clean plus_res in
(*
+ Unparse_ast0.unparse plus_res;
Printf.printf "after plus parse\n";
*)
(iso, dropiso, dependencies, rule_name, exists)),
(plus_res, metavars), ruletype), metavars, tokens) in
- let rec collect_script_tokens = function
- [(PC.EOF,_)] | [(PC.TArobArob,_)] | [(PC.TArob,_)] -> ""
- | (PC.TScriptData(s),_)::xs -> s^(collect_script_tokens xs)
- | toks ->
- List.iter
- (function x ->
- Printf.printf "%s\n" (token2c x))
- toks;
- failwith "Malformed script rule" in
-
let parse_script_rule name language old_metas deps =
+ Lexer_script.file := file;
+ Lexer_script.language := language;
let get_tokens = tokens_script_all table file false lexbuf in
(* meta-variables *)
metavars;
*)
(* script code *)
- let (more, tokens) = get_tokens [PC.TArobArob; PC.TArob] in
+ let (more, tokens) = get_tokens (in_list [PC.TArobArob; PC.TArob]) in
let data = collect_script_tokens tokens in
(more,
Ast0.ScriptRule(name, language, deps, metavars,
[],tokens) in
let parse_if_script_rule k name language _ deps =
+ Lexer_script.file := file;
+ Lexer_script.language := language;
let get_tokens = tokens_script_all table file false lexbuf in
(* script code *)
- let (more, tokens) = get_tokens [PC.TArobArob; PC.TArob] in
+ let (more, tokens) = get_tokens (in_list [PC.TArobArob; PC.TArob]) in
let data = collect_script_tokens tokens in
(more,k (name, language, deps, data),[],tokens) in
Ast0.FinalScriptRule(name,language,deps,data)) in
let do_parse_script_rule fn name l old_metas deps =
- match eval_depend deps virt with
- Some deps -> fn name l old_metas deps
- | None -> fn name l old_metas Ast.FailDep in
+ fn name l old_metas (eval_depend deps virt) in
let parse_rule old_metas starts_with_name =
let rulename =
match rulename with
Ast.CocciRulename (Some s, dep, b, c, d, e) ->
(match eval_depend dep virt with
- Some (dep) ->
- parse_cocci_rule Ast.Normal old_metas (s,dep,b,c,d,e)
- | None ->
+ Ast.FailDep ->
D.ignore_patch_or_match := true;
let res =
parse_cocci_rule Ast.Normal old_metas
(s, Ast.FailDep, b, c, d, e) in
D.ignore_patch_or_match := false;
- res)
+ res
+ | dep -> parse_cocci_rule Ast.Normal old_metas (s,dep,b,c,d,e))
| Ast.GeneratedRulename (Some s, dep, b, c, d, e) ->
(match eval_depend dep virt with
- Some (dep) ->
- Data.in_generating := true;
- let res =
- parse_cocci_rule Ast.Generated old_metas
- (s,dep,b,c,d,e) in
- Data.in_generating := false;
- res
- | None ->
+ Ast.FailDep ->
D.ignore_patch_or_match := true;
Data.in_generating := true;
let res =
(s, Ast.FailDep, b, c, d, e) in
D.ignore_patch_or_match := false;
Data.in_generating := false;
+ res
+ | dep ->
+ Data.in_generating := true;
+ let res =
+ parse_cocci_rule Ast.Generated old_metas
+ (s,dep,b,c,d,e) in
+ Data.in_generating := false;
res)
| Ast.ScriptRulename(Some s,l,deps) ->
do_parse_script_rule parse_script_rule s l old_metas deps
List.filter
(function (_,_,nm) -> not (List.mem nm dropiso))
chosen_isos in
- List.iter Iso_compile.process chosen_isos;
let dropped_isos =
match reserved_names with
"all"::others ->
(* warning! context_neg side-effects its arguments *)
let (m,p) = List.split (Context_neg.context_neg minus plus) in
Type_infer.type_infer p;
- (if not !Flag.sgrep_mode2
+ (if not (!Flag.sgrep_mode2 or dependencies = Ast.FailDep)
then Insert_plus.insert_plus m p (chosen_isos = []));
Type_infer.type_infer minus;
let (extra_meta, minus) =
some restrictions on the -+ code *)
([],_) | (_,Ast.Generated) -> ([],minus)
| _ -> Iso_pattern.apply_isos chosen_isos minus rule_name in
+ (* must be before adj *)
+ let minus = Commas_on_lists.process minus in
(* after iso, because iso can intro ... *)
let minus = Adjacency.compute_adjacency minus in
let minus = Comm_assoc.comm_assoc minus rule_name dropiso in
if !Flag.sgrep_mode2 then minus
else Single_statement.single_statement minus in
let minus = Simple_assignments.simple_assignments minus in
+ (* has to be last, introduced AsExpr, etc *)
+ let minus = Get_metas.process minus in
let minus_ast =
Ast0toast.ast0toast rule_name dependencies dropped_isos
exists minus is_exp ruletype in
HCoop / bpt / coccinelle.git / blobdiff