+let satisfies_regexpconstraint c id : bool =
+ match c with
+ A.IdRegExp (_,recompiled) -> Str.string_match recompiled id 0
+ | A.IdNotRegExp (_,recompiled) -> not (Str.string_match recompiled id 0)
+
+let satisfies_iconstraint c id : bool =
+ not (List.mem id c)
+
+let satisfies_econstraint c exp : bool =
+ let warning s = pr2_once ("WARNING: "^s); false in
+ match Ast_c.unwrap_expr exp with
+ Ast_c.Ident (name) ->
+ (match name with
+ Ast_c.RegularName rname ->
+ satisfies_regexpconstraint c (Ast_c.unwrap_st rname)
+ | Ast_c.CppConcatenatedName _ ->
+ warning
+ "Unable to apply a constraint on a CppConcatenatedName identifier!"
+ | Ast_c.CppVariadicName _ ->
+ warning
+ "Unable to apply a constraint on a CppVariadicName identifier!"
+ | Ast_c.CppIdentBuilder _ ->
+ warning
+ "Unable to apply a constraint on a CppIdentBuilder identifier!")
+ | Ast_c.Constant cst ->
+ (match cst with
+ | Ast_c.String (str, _) -> satisfies_regexpconstraint c str
+ | Ast_c.MultiString strlist ->
+ warning "Unable to apply a constraint on an multistring constant!"
+ | Ast_c.Char (char , _) -> satisfies_regexpconstraint c char
+ | Ast_c.Int (int , _) -> satisfies_regexpconstraint c int
+ | Ast_c.Float (float, _) -> satisfies_regexpconstraint c float)
+ | _ -> warning "Unable to apply a constraint on an expression!"
+
+
+(* ------------------------------------------------------------------------- *)
+(* This has to be up here to allow adequate polymorphism *)
+
+let list_matcher match_dots rebuild_dots match_comma rebuild_comma
+ match_metalist rebuild_metalist mktermval special_cases
+ element distrf get_iis = fun eas ebs ->
+ let rec loop = function
+ [], [] -> return ([], [])
+ | [], eb::ebs -> fail
+ | ea::eas, ebs ->
+ X.all_bound (A.get_inherited ea) >&&>
+ let try_matches =
+ (match match_dots ea, ebs with
+ Some (mcode, optexpr), ys ->
+ (* todo: if optexpr, then a WHEN and so may have to filter yys *)
+ if optexpr <> None then failwith "not handling when in a list";
+
+ (* '...' can take more or less the beginnings of the arguments *)
+ let startendxs =
+ Common.zip (Common.inits ys) (Common.tails ys) in
+ Some
+ (startendxs +> List.fold_left (fun acc (startxs, endxs) ->
+ acc >||> (
+
+ (* allow '...', and maybe its associated ',' to match nothing.
+ * for the associated ',' see below how we handle the EComma
+ * to match nothing.
+ *)
+ (if null startxs
+ then
+ if mcode_contain_plus (mcodekind mcode)
+ then fail
+ (*failwith
+ "I have no token that I could accroche myself on"*)
+ else return (dots2metavar mcode, [])
+ else
+ (* subtil: we dont want the '...' to match until the
+ * comma. cf -test pb_params_iso. We would get at
+ * "already tagged" error.
+ * this is because both f (... x, ...) and f (..., x, ...)
+ * would match a f(x,3) with our "optional-comma" strategy.
+ *)
+ (match Common.last startxs with
+ | Right _ -> fail
+ | Left _ -> distrf (dots2metavar mcode) startxs))
+
+ >>= (fun mcode startxs ->
+ let mcode = metavar2dots mcode in
+ loop (eas, endxs) >>= (fun eas endxs ->
+ return (
+ (rebuild_dots (mcode, optexpr) +> A.rewrap ea) ::eas,
+ startxs ++ endxs
+ )))
+ )
+ ) fail)
+
+ | None,_ -> None)
+ +++
+ (match match_comma ea, ebs with
+ | Some ia1, Right ii::ebs ->
+ Some
+ (let ib1 = tuple_of_list1 ii in
+ tokenf ia1 ib1 >>= (fun ia1 ib1 ->
+ loop (eas, ebs) >>= (fun eas ebs ->
+ return (
+ (rebuild_comma ia1 +> A.rewrap ea)::eas,
+ (Right [ib1])::ebs
+ )
+ )))
+ | Some ia1, ebs ->
+ (* allow ',' to maching nothing. optional comma trick *)
+ Some
+ (if mcode_contain_plus (mcodekind ia1)
+ then fail
+ else loop (eas, ebs))
+ | None,_ -> None)
+ +++
+ (match match_metalist ea, ebs with
+ Some (ida,leninfo,keep,inherited), ys ->
+ let startendxs =
+ Common.zip (Common.inits ys) (Common.tails ys) in
+ Some
+ (startendxs +> List.fold_left (fun acc (startxs, endxs) ->
+ acc >||> (
+ let ok =
+ if null startxs
+ then
+ if mcode_contain_plus (mcodekind ida)
+ then false
+ (* failwith "no token that I could accroche myself on" *)
+ else true
+ else
+ (match Common.last startxs with
+ | Right _ -> false
+ | Left _ -> true)
+ in
+ if not ok
+ then fail
+ else
+ let startxs' = Ast_c.unsplit_comma startxs in
+ let len = List.length startxs' in
+
+ (match leninfo with
+ | A.MetaListLen (lenname,lenkeep,leninherited) ->
+ let max_min _ = failwith "no pos" in
+ X.envf lenkeep leninherited
+ (lenname, Ast_c.MetaListlenVal (len), max_min)
+ | A.CstListLen n ->
+ if len = n
+ then (function f -> f())
+ else (function f -> fail)
+ | A.AnyListLen -> function f -> f()
+ )
+ (fun () ->
+ let max_min _ =
+ Lib_parsing_c.lin_col_by_pos (get_iis startxs) in
+ X.envf keep inherited
+ (ida, mktermval startxs', max_min)
+ (fun () ->
+ if null startxs
+ then return (ida, [])
+ else distrf ida (Ast_c.split_comma startxs'))
+ >>= (fun ida startxs ->
+ loop (eas, endxs) >>= (fun eas endxs ->
+ return (
+ (rebuild_metalist(ida,leninfo,keep,inherited))
+ +> A.rewrap ea::eas,
+ startxs ++ endxs
+ ))
+ )
+ )
+ )) fail)
+ | None,_ -> None)
+ +++
+ special_cases ea eas ebs in
+ match try_matches with
+ Some res -> res
+ | None ->
+ (match ebs with
+ | (Left eb)::ebs ->
+ element ea eb >>= (fun ea eb ->
+ loop (eas, ebs) >>= (fun eas ebs ->
+ return (ea::eas, Left eb::ebs)))
+ | (Right y)::ys -> raise Impossible
+ | [] -> fail) in
+ loop (eas,ebs)
+