(*
- * 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
| PC.TExpression -> "expression"
| PC.TIdExpression -> "idexpression"
| PC.TInitialiser -> "initialiser"
+ | PC.TSymbol -> "symbol"
| PC.TDeclaration -> "declaration"
| PC.TField -> "field"
| PC.TStatement -> "statement"
| PC.TPragma(Ast.Noindent s,_) -> s
| PC.TPragma(Ast.Indent s,_) -> s
+ | PC.TPragma(Ast.Space s,_) -> s
| PC.TIncludeL(s,clt) -> (pr "#include \"%s\"" s)^(line_type2c clt)
| PC.TIncludeNL(s,clt) -> (pr "#include <%s>" s)^(line_type2c clt)
| PC.TUndef(clt,_) -> "#undef"^(line_type2c clt)
| 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.TMetaIdExp(_,_,_,_,clt) -> "idexpmeta"^(line_type2c clt)
| PC.TMetaLocalIdExp(_,_,_,_,clt) -> "localidexpmeta"^(line_type2c clt)
| PC.TMetaExpList(_,_,_,clt) -> "explistmeta"^(line_type2c clt)
- | PC.TMetaId(_,_,_,clt) -> "idmeta"^(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.TMetaStm(_,_,clt) -> "stmmeta"^(line_type2c clt)
| PC.TMetaStmList(_,_,clt) -> "stmlistmeta"^(line_type2c clt)
| PC.TMetaFunc(_,_,_,clt) -> "funcmeta"^(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.TMetaStmList(_,_,clt) | PC.TMetaDecl(_,_,clt) | PC.TMetaField(_,_,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.TWhen(clt) | PC.TWhenTrue(clt) | PC.TWhenFalse(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.TMetaStmList(_,_,clt) | PC.TMetaDecl(_,_,clt) | PC.TMetaField(_,_,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.TMetaStm(a,b,_) -> (PC.TMetaStm(a,b,clt),x)
| PC.TMetaStmList(a,b,_) -> (PC.TMetaStmList(a,b,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)
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.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.TMetaFunc(_,_,_,clt) | PC.TMetaLocalFunc(_,_,_,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)
has no return type. Undoubtedly, this is not very nice, but it doesn't
seem very convenient to refactor the grammar to get around the problem. *)
-let rec find_function_names = function
- [] -> []
- | ((PC.TIdent(_,clt),info) as t1) :: ((PC.TOPar(_),_) as t2) :: rest
- | ((PC.TMeta(_,_,clt),info) as t1) :: ((PC.TOPar(_),_) as t2) :: rest
- | ((PC.TMetaId(_,_,_,clt),info) as t1) :: ((PC.TOPar(_),_) as t2) :: rest
- | ((PC.TMetaFunc(_,_,_,clt),info) as t1) :: ((PC.TOPar(_),_) as t2) :: rest
- | ((PC.TMetaLocalFunc(_,_,_,clt),info) as t1)::((PC.TOPar(_),_) as t2)::rest
- ->
- let rec skip level = function
- [] -> ([],false,[])
- | ((PC.TCPar(_),_) as t)::rest ->
- let level = level - 1 in
- if level = 0
- then ([t],true,rest)
- else let (pre,found,post) = skip level rest in (t::pre,found,post)
- | ((PC.TOPar(_),_) as t)::rest ->
- let level = level + 1 in
- let (pre,found,post) = skip level rest in (t::pre,found,post)
- | ((PC.TArobArob,_) as t)::rest
- | ((PC.TArob,_) as t)::rest
- | ((PC.EOF,_) as t)::rest -> ([t],false,rest)
- | t::rest ->
- let (pre,found,post) = skip level rest in (t::pre,found,post) in
- let (pre,found,post) = skip 1 rest in
- (match (found,post) with
- (true,((PC.TOBrace(_),_) as t3)::rest) ->
- (PC.TFunDecl(clt),info) :: t1 :: t2 :: pre @
- t3 :: (find_function_names rest)
- | _ -> t1 :: t2 :: pre @ find_function_names post)
- | t :: rest -> t :: find_function_names rest
+exception Irrelevant
+
+let rec find_function_names l =
+ let is_ident = function
+ (PC.TIdent(_,clt),info)
+ | (PC.TMeta(_,_,clt),info)
+ | (PC.TMetaId(_,_,_,_,clt),info)
+ | (PC.TMetaFunc(_,_,_,clt),info)
+ | (PC.TMetaLocalFunc(_,_,_,clt),info) -> true
+ | _ -> false in
+ let is_mid = function
+ (PC.TMid0(_),info) -> true
+ | _ -> false in
+ let is_par = function
+ (PC.TOPar0(_),info) -> true
+ | _ -> false in
+ let rec split acc = function
+ [] | [_] -> raise Irrelevant
+ | ((PC.TCPar(_),_) as t1) :: ((PC.TOBrace(_),_) as t2) :: rest ->
+ (List.rev (t1::acc),(t2::rest))
+ | x::xs -> split (x::acc) xs in
+ let rec balanced_name level = function
+ [] -> raise Irrelevant
+ | (PC.TCPar0(_),_)::rest ->
+ let level = level - 1 in
+ if level = 0
+ then rest
+ else balanced_name level rest
+ | (PC.TOPar0(_),_)::rest ->
+ let level = level + 1 in
+ balanced_name level rest
+ | (PC.TArobArob,_)::_ | (PC.TArob,_)::_ | (PC.EOF,_)::_ ->
+ raise Irrelevant
+ | t::rest when is_ident t && level = 0 -> rest
+ | t::rest when is_ident t or is_mid t -> balanced_name level rest
+ | _ -> raise Irrelevant in
+ let rec balanced_args level = function
+ [] -> raise Irrelevant
+ | (PC.TCPar(_),_)::rest ->
+ let level = level - 1 in
+ if level = 0
+ then rest
+ else balanced_args level rest
+ | (PC.TOPar(_),_)::rest ->
+ let level = level + 1 in
+ balanced_args level rest
+ | (PC.TArobArob,_)::_ | (PC.TArob,_)::_ | (PC.EOF,_)::_ ->
+ raise Irrelevant
+ | t::rest -> balanced_args level rest in
+ let rec loop = function
+ [] -> []
+ | t :: rest ->
+ if is_par t or is_mid t or is_ident t
+ then
+ let (t,rest) =
+ try
+ let (bef,aft) = split [] (t::rest) in
+ let rest = balanced_name 0 bef in
+ (match rest with
+ (PC.TOPar(_),_)::_ ->
+ (match balanced_args 0 rest with
+ [] ->
+ let (_,info) as h = List.hd bef in
+ let clt = get_clt h in
+ (((PC.TFunDecl(clt),info) :: bef), aft)
+ | _ -> raise Irrelevant)
+ | _ -> raise Irrelevant)
+ with Irrelevant -> ([t],rest) in
+ t @ (loop rest)
+ else t :: (loop rest) in
+ loop l
(* ----------------------------------------------------------------------- *)
(* an attribute is an identifier that preceeds another identifier and
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
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.TMetaStm(_,_,_),_)
| (PC.TMetaStmList(_,_,_),_)
| (PC.TMetaPos(_,_,_,_),_) -> in_meta_decls
| 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.TMetaLocalFunc(_,_,_,clt) | PC.TMetaPos(_,_,_,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)
(*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 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.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.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::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 =
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
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 =
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 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";
*)
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) =
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