diff --git a/Fixpoint.hs b/Fixpoint.hs deleted file mode 100644 --- a/Fixpoint.hs +++ /dev/null @@ -1,12 +0,0 @@ -import Language.Fixpoint.Interface (solveFQ) -import Language.Fixpoint.Config (getOpts) -import System.Exit -import System.Console.CmdArgs.Verbosity (whenLoud) - -main :: IO ExitCode -main = do - cfg <- getOpts - whenLoud $ putStrLn $ "Options: " ++ show cfg - e <- solveFQ cfg - putStrLn $ "EXIT: " ++ show e - exitWith e diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,55 +1,2 @@ -import Control.Monad -import Data.Maybe -import Distribution.PackageDescription import Distribution.Simple -import Distribution.Simple.LocalBuildInfo -import Distribution.Simple.Setup -import Distribution.System -import System.Directory -import System.Environment -import System.Exit -import System.FilePath -import System.Process - -main = defaultMainWithHooks fixHooks - where - fixHooks = simpleUserHooks { postBuild = buildFixpoint - , postCopy = copyFixpoint - , postInst = copyFixpoint - } - -copyFixpoint _ _ pkg lbi = do - copyFile fixpoint bin - where - allDirs = absoluteInstallDirs pkg lbi NoCopyDest - bin = bindir allDirs "fixpoint.native" - ++ if system == "i686-w64-mingw32" then ".exe" else "" - fixpoint = "external" "fixpoint" "fixpoint.native" - ++ if build then "" else "-" ++ system - system = case hostPlatform lbi of - Platform I386 Linux -> "i386-linux" - Platform X86_64 Linux -> "x86_64-linux" - Platform X86_64 OSX -> "x86_64-darwin" - Platform _ Windows -> "i686-w64-mingw32" - _ -> error "We don't have a prebuilt fixpoint.native for your system, please install with -fbuild-external (requires ocaml)" - flags = configConfigurationsFlags $ configFlags lbi - build = fromMaybe False $ lookup (FlagName "build-external") flags - - -buildFixpoint _ _ pkg lbi = when build $ do - setEnv "Z3MEM" (show z3mem) - executeShellCommand "./configure" - executeShellCommand "./build.sh" - executeShellCommand "chmod a+x external/fixpoint/fixpoint.native" - where - allDirs = absoluteInstallDirs pkg lbi NoCopyDest - binDir = bindir allDirs ++ "/" - flags = configConfigurationsFlags $ configFlags lbi - z3mem = fromMaybe False $ lookup (FlagName "z3mem") flags - build = fromMaybe False $ lookup (FlagName "build-external") flags - -executeShellCommand cmd = putStrLn ("EXEC: " ++ cmd) >> system cmd >>= check - where - check (ExitSuccess) = return () - check (ExitFailure n) = error $ "cmd: " ++ cmd ++ " failure code " ++ show n - +main = defaultMain diff --git a/bin/Fixpoint.hs b/bin/Fixpoint.hs new file mode 100644 --- /dev/null +++ b/bin/Fixpoint.hs @@ -0,0 +1,11 @@ +import Language.Fixpoint.Solver (solveFQ) +import Language.Fixpoint.Types.Config (getOpts) +import System.Exit +import Language.Fixpoint.Misc (writeLoud) + +main = do + cfg <- getOpts + writeLoud $ "Options: " ++ show cfg + e <- solveFQ cfg + exitWith e + diff --git a/configure b/configure deleted file mode 100644 --- a/configure +++ /dev/null @@ -1,45 +0,0 @@ -#!/usr/bin/env bash - -ROOTHOME=`pwd` -GHCBIN=`which ghc` -GHCHOME=`dirname $GHCBIN` -OCAMLLIB=`ocamlc -v | tail -1 | cut -d : -f 2 | tr -d " "` - -if [[ $Z3MEM = 'True' ]] -then - Z3HOME=$ROOTHOME/external/z3 -else - Z3HOME= -fi - -cat - > external/fixpoint/config.make < build.sh < Sy.SMap.add v e edefs, pdefs - | Ast.And [Ast.Imp ((Ast.Bexp (Ast.Var v1, _), _), p1), _; - Ast.Imp (p2, (Ast.Bexp (Ast.Var v2, _), _)), _] when v1 = v2 && p1 = p2 && not(P.is_tauto pred) -> - edefs, Sy.SMap.add v1 p1 pdefs - | Ast.And preds -> List.fold_left defs_of_pred (edefs, pdefs) preds - | _ -> edefs, pdefs - -let some_def_applied = ref false -let rec expr_apply_defs edefs pdefs ((e, _) as expr) = - let current_some_def_applied = !some_def_applied in - some_def_applied := false; - let expr'' = - match e with - | Ast.Con _ -> expr - | Ast.Var v -> - begin - try - let expr' = Sy.SMap.find v edefs in - some_def_applied := true; - expr' - with Not_found -> expr - end - | Ast.App (v, es) -> - let edefs' = Sy.SMap.remove v edefs in - Ast.eApp (v, List.map (expr_apply_defs edefs' pdefs) es) - | Ast.Bin (e1, op, e2) -> - Ast.eBin (expr_apply_defs edefs pdefs e1, op, expr_apply_defs edefs pdefs e2) - | Ast.Ite (p, e1, e2) -> - Ast.eIte (pred_apply_defs edefs pdefs p, - expr_apply_defs edefs pdefs e1, - expr_apply_defs edefs pdefs e2) - | Ast.Fld (v, e) -> - let v' = - try - match Sy.SMap.find v edefs with - | (Ast.Var v'', _) -> - some_def_applied := true; - v'' - | _ -> v - with Not_found -> v - in - Ast.eFld (v', expr_apply_defs edefs pdefs e) - | _ -> assertf "Simplification.expr_apply_defs TODO" - in - if !some_def_applied then - let expr''' = expr_apply_defs edefs pdefs expr'' in - some_def_applied := current_some_def_applied; - expr''' - else - begin - some_def_applied := current_some_def_applied; - expr'' - end - -and pred_apply_defs edefs pdefs ((p, _) as pred) = - let current_some_def_applied = !some_def_applied in - some_def_applied := false; - let pred'' = - match p with - | Ast.And ps -> List.map (pred_apply_defs edefs pdefs) ps |> Ast.pAnd - | Ast.Or ps -> List.map (pred_apply_defs edefs pdefs) ps |> Ast.pOr - | Ast.Not p -> pred_apply_defs edefs pdefs p |> Ast.pNot - | Ast.Imp (p, q) -> Ast.pImp (pred_apply_defs edefs pdefs p, pred_apply_defs edefs pdefs q) - | Ast.Bexp (Ast.Var v, _) -> - begin - try - let expr' = Sy.SMap.find v edefs in - some_def_applied := true; - Ast.pBexp expr' - with Not_found -> - try - let pred' = Sy.SMap.find v pdefs in - some_def_applied := true; - pred' - with Not_found -> - pred - end - | Ast.Atom (e1, brel, e2) -> - Ast.pAtom (expr_apply_defs edefs pdefs e1, brel, expr_apply_defs edefs pdefs e2) - | Ast.Forall (qs, p) -> - let vs = List.map fst qs in - let edefs' = List.fold_left (fun defs v -> Sy.SMap.remove v defs) edefs vs in - let pdefs' = List.fold_left (fun defs v -> Sy.SMap.remove v defs) pdefs vs in - Ast.pForall (qs, pred_apply_defs edefs' pdefs' p) - | _ -> pred - in - if !some_def_applied then - let pred''' = pred_apply_defs edefs pdefs pred'' in - some_def_applied := current_some_def_applied; - pred''' - else - begin - some_def_applied := current_some_def_applied; - pred'' - end - -let subs_apply_defs edefs pdefs subs = - List.map (fun (s, e) -> s, expr_apply_defs edefs pdefs e) subs - -let kvar_apply_defs edefs pdefs (subs, sym) = - subs_apply_defs edefs pdefs subs, sym - -let simplify_subs subs = - List.filter (fun (s, e) -> not(P.is_tauto (Ast.pAtom (Ast.eVar s, Ast.Eq, e)))) subs - -let simplify_kvar (subs, sym) = - simplify_subs subs, sym - -let simplify_t t = - let env_ps, pfree_env = (* separate concrete predicates from refinement templates *) - Sy.SMap.fold - (fun bv reft (ps, env) -> - let vv = C.vv_of_reft reft in - let bv_expr = Ast.eVar bv in - let sort = C.sort_of_reft reft in - let reft_ps, reft_ks = C.preds_kvars_of_reft reft in - (List.rev_append (List.map (fun p -> P.subst p vv bv_expr) reft_ps) ps, - if reft_ks = [] then env else Sy.SMap.add bv (vv, sort, reft_ks) env) - ) (C.env_of_t t) ([], Sy.SMap.empty) in - let lhs = C.lhs_of_t t in - let lhs_vv = C.vv_of_reft lhs in - let lhs_ps, lhs_ks = C.preds_kvars_of_reft lhs in - let body_pred = Ast.pAnd (C.grd_of_t t :: List.rev_append lhs_ps env_ps) in - let edefs, pdefs = defs_of_pred (Sy.SMap.empty, Sy.SMap.empty) body_pred in - (* - Printf.printf "\nbody_pred edefs map for %d\n" (C.id_of_t t); - Sy.SMap.iter (fun v exp -> - Printf.printf "%s -> %s\n" (Sy.to_string v) (E.to_string exp) - ) edefs; - Printf.printf "edef for lhs_vv %s = %s (simplified %s)\n" (Sy.to_string lhs_vv) - (try Sy.SMap.find lhs_vv edefs |> E.to_string with Not_found -> "none") - (try - Sy.SMap.find lhs_vv edefs - |> expr_apply_defs edefs pdefs - |> E.to_string with Not_found -> "none"); - *) - let kvar_to_simple_Kvar (subs, sym) = C.Kvar (subs |> Su.to_list |> subs_apply_defs edefs pdefs |> simplify_subs |> Su.of_list, sym) in - let senv = - Sy.SMap.mapi (fun bv (vv, sort, ks) -> - List.map kvar_to_simple_Kvar ks |> C.make_reft vv sort) pfree_env in -(* Printf.printf "body_pred: %s\n" (P.to_string body_pred); *) - let sgrd' = pred_apply_defs edefs pdefs body_pred |> Ast.simplify_pred in - let sgrd = - try - Ast.pAnd [sgrd'; Ast.pAtom (Ast.eVar lhs_vv, Ast.Eq, Sy.SMap.find lhs_vv edefs |> expr_apply_defs edefs pdefs)] - with Not_found -> sgrd' in -(* Printf.printf "simplified body_pred: %s\n" (P.to_string sgrd); *) - let slhs = List.map kvar_to_simple_Kvar lhs_ks |> C.make_reft (C.vv_of_reft lhs) (C.sort_of_reft lhs) in - let rhs = C.rhs_of_t t in - let rhs_ps, rhs_ks = C.preds_kvars_of_reft rhs in - let srhs_pred = pred_apply_defs edefs pdefs (Ast.pAnd rhs_ps) |> Ast.simplify_pred in - let srhs_ks = List.map kvar_to_simple_Kvar rhs_ks in - let srhs = (if P.is_tauto srhs_pred then srhs_ks else (C.Conc srhs_pred) :: srhs_ks) |> - C.make_reft (C.vv_of_reft rhs) (C.sort_of_reft rhs) in - C.make_t senv sgrd slhs srhs (Some (C.id_of_t t)) (C.tag_of_t t) - -let simplify_ts ts = - (* drop t if its rhs is a k variable that is not read *) - let ts_sofar = ref ts in - let pruned = ref true in - while !pruned && !ts_sofar <> [] do - let pruned_ts, rest_ts = - List.partition - (fun t -> - match C.rhs_of_t t |> C.preds_kvars_of_reft with - | [], [(_, sy)] -> - List.for_all - (fun t' -> - List.for_all (fun (_, sy') -> sy <> sy') - (Sy.SMap.fold - (fun _ reft sofar -> List.rev_append (C.kvars_of_reft reft) sofar) - (C.env_of_t t') (C.lhs_of_t t' |> C.kvars_of_reft)) - ) !ts_sofar - | _ -> false - ) !ts_sofar in - ts_sofar := rest_ts; - pruned := pruned_ts <> [] - done; - !ts_sofar - -let is_tauto_t t = - match C.rhs_of_t t |> C.ras_of_reft with - | [] -> true - | [C.Conc p] -> P.is_tauto p - | _ -> false - - diff --git a/external/fixpoint/Simplification.mli b/external/fixpoint/Simplification.mli deleted file mode 100644 --- a/external/fixpoint/Simplification.mli +++ /dev/null @@ -1,5 +0,0 @@ - -val simplify_t : FixConstraint.t -> FixConstraint.t -val simplify_ts : FixConstraint.t list -> FixConstraint.t list -val is_tauto_t : FixConstraint.t -> bool - diff --git a/external/fixpoint/ast.ml b/external/fixpoint/ast.ml deleted file mode 100644 --- a/external/fixpoint/ast.ml +++ /dev/null @@ -1,1882 +0,0 @@ -(* - * Copyright © 2009 The Regents of the University of California. All rights reserved. - * - * Permission is hereby granted, without written agreement and without - * license or royalty fees, to use, copy, modify, and distribute this - * software and its documentation for any purpose, provided that the - * above copyright notice and the following two paragraphs appear in - * all copies of this software. - * - * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY - * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES - * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN - * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY - * OF SUCH DAMAGE. - * - * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, - * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY - * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS - * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION - * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. - * - *) - -(** - * This module implements a DAG representation for expressions and - * predicates: each sub-predicate or sub-expression is paired with - * a unique int ID, which enables constant time hashing. - * However, one must take care when using DAGS: - * (1) they can only be constructed using the appropriate functions - * (2) when destructed via pattern-matching, one must discard the ID - *) - -(* random touch *) - -module F = Format -module Misc = FixMisc -open Misc.Ops -module SM = Misc.StringMap - -let mydebug = false - -module Cone = struct - type 'a t = Empty | Cone of ('a * 'a t) list - - let rec map f = function - | Empty -> Empty - | Cone xcs -> Cone (List.map (f <**> map f) xcs) -end - -module Sort = - struct - type loc = - | Loc of string - | Lvar of int - | LFun - - type tycon = string - - type t = - | Int - | Real - | Bool - | Obj - | Var of int (* type-var *) - | Ptr of loc (* c-pointer *) - | Func of int * t list (* type-var-arity, in-types @ [out-type] *) - | Num (* kind, for numeric tyvars -- ptr(loc(s)) -- *) - | Frac (* kind, for fractional tyvars -- ptr(loc(s)) -- *) - | App of tycon * t list (* type constructors *) - - type sub = { locs: (int * string) list; - vars: (int * t) list; } - - - let tycon_string x = x - (* - let is_loc_string s = - let re = Str.regexp "[a-zA-Z]+[0-9]+" in - Str.string_match re s 0 - - let loc_of_string = fun s -> let _ = asserts (is_loc_string s) in Loc s - let loc_of_index = fun i -> Lvar i - *) - - let t_num = Num - let t_frac = Frac - let t_obj = Obj - let t_bool = Bool - let t_int = Int - let t_real = Real - let t_generic = fun i -> let _ = asserts (0 <= i) "t_generic: %d" i in Var i - let t_ptr = fun l -> Ptr l - let t_func = fun i ts -> Func (i, ts) - let tycon s = s - let tc_app = "FAppTy" - - (* let tycon_re = Str.regexp "[A-Z][0-9 a-z A-Z '.']" - * function | s when Str.string_match tycon_re s 0 -> s - | s -> assertf "Error: Invalid tycon: %s" s - *) - - let t_app c ts = if c = tc_app then App (c, ts) else - List.fold_left (fun t1 t2 -> App (tc_app, [t1; t2])) (App (c, [])) ts - (* let t_app c ts = List.fold_left (fun t1 t2 -> App ("FAppTy", [t1; t2])) (App (c, [])) ts *) - (* let t_app c ts = App (c, ts) *) - - let loc_to_string = function - | Loc s -> s - | Lvar i -> string_of_int i - | LFun -> "" - - let rec to_string = function - | Var i -> Printf.sprintf "@(%d)" i - | Int -> "int" - | Real -> "real" - | Bool -> "bool" - | Obj -> "obj" - | Num -> "num" - | Frac -> "frac" - | Ptr l -> loc_to_string l - (* Printf.sprintf "ptr(%s)" (loc_to_string l) *) - | Func (n, ts) -> ts |> List.map to_string - |> String.concat " ; " - |> Printf.sprintf "func(%d, [%s])" n - | App (c, ts) -> ts |> List.map to_string_arg - |> String.concat " " - |> Printf.sprintf "%s %s" c - - and to_string_arg t = match t with - | App (_, _) -> Printf.sprintf "(%s)" (to_string t) - | _ -> to_string t - - let to_string_short = function - | Func _ -> "func" - (* | Ptr _ -> "ptr" *) - | t -> to_string t - - let print fmt t = - t |> to_string - |> Format.fprintf fmt "%s" - - let sub_to_string {locs = ls; vars = vs} = - let lts = fun (i, s) -> Printf.sprintf "(%d := %s)" i s in - let vts = fun (i, t) -> Printf.sprintf "(%d := %s)" i (to_string t) in - Printf.sprintf "locs := %s, vars := %s \n" - (String.concat "" (List.map lts ls)) - (String.concat "" (List.map vts vs)) - - let rec map f = function - | Func (n, ts) -> Func (n, List.map (map f) ts) - | App (c, ts) -> App (c, List.map (map f) ts) - | t -> f t - - let rec fold f b = function - | Func (n, ts) as t -> List.fold_left (fold f) (f b t) ts - | t -> f b t - - let subs_tvar ts = - map begin function - | Var i -> Misc.do_catchf "ERROR: subs_tvar" (List.nth ts) i - | t -> t - end - - let is_bool = function - | Bool -> true - | _ -> false - - let is_int = function - | Int -> true - | _ -> false - - let is_real = function - | Real -> true - | _ -> false - - let is_func = function - | Func _ -> true - | _ -> false - - let is_kind = function - | Num -> true - | _ -> false - - let app_of_t = function - | App (c, ts) -> Some (c, ts) - | _ -> None - - (* (L t1 t2 t3) is now encoded as - ---> (((L @ t1) @ t2) @ t3) - ---> App(@, [App(@, [App(@, [L[]; t1]); t2]); t3]) - The following decodes the above as - *) - let rec app_args_of_t acc = function - | App (c, [t1; t2]) when c = tc_app -> app_args_of_t (t2 :: acc) t1 - | App (c, []) -> (c, acc) - | t -> (tc_app, t :: acc) - - (* - | Ptr (Loc s) -> (tycon s, acc) - | t -> assertf "app_args_of_t: unexpected t1 = %s" (to_string t) - *) - - let app_of_t = function - | App (c, _) as t when c = tc_app -> Some (app_args_of_t [] t) - | App (c, ts) -> Some (c, ts) - | _ -> None - - let func_of_t = function - | Func (i, ts) -> let (xts, t) = ts |> Misc.list_snoc |> Misc.swap in - Some (i, xts, t) - | _ -> None - - let ptr_of_t = function - | Ptr l -> Some l - | _ -> None - - (* Sleazy Hack for C pointers. Make this go away... *) - - let compat t1 t2 = match t1, t2 with - | Int, (Ptr _) -> true - | (Ptr _), Int -> true - | _ -> t1 = t2 - - (* {{{ - let concretize ts = function - | Func (n, ats) when n = List.length ts -> - Func (n, List.map (subs_tvar ts) ats) - | _ -> - assertf "ERROR: bad application" - - let is_monotype t = - fold (fun b t -> b && (match t with Var _ -> false | _ -> true)) true t - }}} *) - - - let lookup_var = fun s i -> try Some (List.assoc i s.vars) with Not_found -> None - let lookup_loc = fun s j -> try Some (List.assoc j s.locs) with Not_found -> None - - let rec unifyt s = function - | Num,_ | _, Num -> None -(* NIKI: Unifycation of two variables should always succeed, -but the bellow code crashes tests/zipper0.hs.fq -*) -(* - | (Var i), (Var j) -> - begin match lookup_var s i with - | Some ct -> Some {s with vars = (j,ct) :: s.vars} - | None -> begin match lookup_var s j with - | Some ct -> Some {s with vars = (i, ct) :: s.vars} - | None -> Some {s with vars = (i, Var j) :: s.vars} - end - end -*) - | ct, (Var i) - | (Var i), ct - (* when ct != Bool *) -> - begin match lookup_var s i with - | Some ct' when ct = ct' -> (*let _ = F.printf "\nUnify YES! %s \t - \t %s" (to_string ct) (to_string (Var i)) in *) Some s - | Some ct'' -> (*let _ = F.printf "\nUnify No! %s \t /= %s \t - \t %s" (to_string ct) (to_string ct'') (to_string (Var i)) in *) None - | None -> (*let _ = F.printf "\nUnify Add! %s \t - \t %s" (to_string ct) (to_string (Var i)) in *) Some {s with vars = (i,ct) :: s.vars} - end - - | Ptr LFun, Ptr _ - | Ptr _, Ptr LFun -> Some s - | Ptr (Loc cl), Ptr (Lvar j) - | Ptr (Lvar j), Ptr (Loc cl) -> - begin match lookup_loc s j with - | Some cl' when cl' = cl -> Some s - | Some _ -> None - | None -> Some {s with locs = (j,cl) :: s.locs} - end - - | App (c1, t1s), App (c2, t2s) - when c1 = c2 && List.length t1s = List.length t2s -> - Misc.maybe_fold unifyt s (List.combine t1s t2s) - - | (t1, t2) when t1 = t2 -> - Some s - | _ -> None - - let empty_sub = {vars = []; locs = []} - - let unifyWith s ats cts = - let _ = asserts (List.length ats = List.length cts) "ERROR: unify sorts" in - List.combine ats cts - |> Misc.maybe_fold unifyt s - (* >> (fun so -> Printf.printf "unify: [%s] ~ [%s] = %s \n" - (String.concat "; " (List.map to_string ats)) - (String.concat "; " (List.map to_string cts)) - (match so with None -> "NONE" | Some s -> sub_to_string s)) - *) - - let unify = unifyWith empty_sub - - let apply s = - map begin fun t -> match t with - | Var i -> (match lookup_var s i with Some t' -> t' | _ -> t) - | Ptr (Lvar j) -> (match lookup_loc s j with Some l -> Ptr (Loc l) | _ -> t) - | _ -> t - end - - let rec fold f acc t = match t with - | Var _ | Int | Real | Bool | Obj | Num | Ptr _ - -> f acc t - | Func (_, ts) | App (_, ts) - -> List.fold_left (fold f) (f acc t) ts - - let vars_of_t = fold begin fun acc -> function - | Var i -> i :: acc - | _ -> acc - end [] - - let locs_of_t = fold begin fun acc -> function - | Ptr (Loc l) -> l :: acc - | _ -> acc - end [] - - let subst_locs_vars lim = map begin function - | Ptr (Loc l) when SM.mem l lim -> Var (SM.find l lim) - | t -> t - end - - (* API *) - let generalize ts = - let locs = ts |> Misc.flap locs_of_t |> Misc.sort_and_compact in - let idx = ts |> Misc.flap vars_of_t |> Misc.list_max (-1) |> (+) 1 in - let lim = Misc.index_from idx locs |>: Misc.swap |> SM.of_list in - List.map (subst_locs_vars lim) ts - - (* API *) - let sub_args s = List.sort compare s.vars - - (* API *) - let check_arity n s = - let n_vars = s.vars |>: fst |> Misc.sort_and_compact |> List.length in - n == n_vars - - let index = ref 0 - - let makeFresh n = - let rec go i = - if i < n then (let x = !index in incr index; (i,x)::go (i+1)) else [] in - go 0 - - let rec refresh su = function - | Int -> Int - | Real -> Real - | Bool -> Bool - | Obj -> Obj - | Var i -> (try (Var (snd (List.find (fun (j, _) -> j == i) su))) - with Not_found -> Var i) - | Ptr l -> Ptr l - | Func(n, ts) -> let su' = List.filter (fun (i,_) -> i>= n) su in Func(n, List.map (refresh su') ts) - | Num -> Num - | Frac -> Frac - | App(tc, ts) -> App(tc, List.map (refresh su) ts) - - end - -module Symbol = - struct - type t = string - - let mk_wild = - let t,_ = Misc.mk_int_factory () in - t <+> string_of_int <+> (^) "~A" - - let is_wild_fresh s = s = "_" - let is_wild_any s = s.[0] = '~' - let is_wild_pre s = s.[0] = '@' - let is_wild s = is_wild_fresh s || is_wild_any s || is_wild_pre s - - let is_safe s = - let re = Str.regexp "[A-Za-z '~' '_' '\'' '@' ][0-9 a-z A-Z '_' '@' '\'' '.' '#']*$" in - Str.string_match re s 0 - - let of_string, to_string = - let of_t = Hashtbl.create 117 in - let to_t = Hashtbl.create 117 in - let bind = fun s sy -> Hashtbl.replace of_t s sy; Hashtbl.replace to_t sy s in - let f,_ = Misc.mk_string_factory "FIXPOINTSYMBOL_" in - ((fun s -> - if is_wild_fresh s then mk_wild () else - if is_safe s then s else - try Hashtbl.find of_t s with Not_found -> - let sy = f () in - let _ = bind s sy in sy), - (fun sy -> try Hashtbl.find to_t sy with Not_found -> sy)) - - let to_string = fun s -> s (* if is_safe s then s else "'" ^ s ^ "'" *) - - let suffix = fun s suff -> of_string ((to_string s) ^ suff) - - let print fmt s = - to_string s |> Format.fprintf fmt "%s" - - let vvprefix = "VV_" - let vvsuffix = function - | Sort.Ptr l -> Sort.loc_to_string l - | t -> Sort.to_string_short t - - - - let is_value_variable = Misc.is_prefix vvprefix - let value_variable t = vvprefix ^ (vvsuffix t) - - (* DEBUG *) - let vvprefix = "VV" - let is_value_variable = (=) vvprefix - let value_variable _ = vvprefix - - module SMap = Misc.EMap (struct type t = string - let compare i1 i2 = compare i1 i2 - let print = print end) - - module SSet = Misc.ESet (struct type t = string - let compare i1 i2 = compare i1 i2 end) - - (* let sm_length m = - SMap.fold (fun _ _ i -> i+1) m 0 - - let sm_filter f sm = - SMap.fold begin fun x y sm -> - if f x y then SMap.add x y sm else sm - end sm SMap.empty - - let sm_to_list sm = - SMap.fold (fun x y acc -> (x,y)::acc) sm [] - - let sm_of_list xs = - List.fold_left (fun sm (k,v) -> SMap.add k v sm) SMap.empty xs - *) - - end - -module Constant = - struct - - type t = Int of int - | Real of float - | Lit of string * Sort.t - - let to_string = function - | Int i -> string_of_int i - | Real i -> string_of_float i ^ "0" - | Lit (s,t) -> Printf.sprintf "(lit \"%s\" %s)" s (Sort.to_string t) - - let print fmt s = - to_string s |> Format.fprintf fmt "%s" - end - - -type tag = int - -type brel = Eq (* equal *) - | Ne (* not-equal *) - | Gt (* greater than *) - | Ge (* greater than or equal *) - | Lt (* less than *) - | Le (* less than or equal *) - | Ueq (* unsorted-equality *) - | Une (* unsorted-disequality *) - -type bop = Plus | Minus | Times | Div | Mod (* NOTE: For "Mod" 2nd expr should be a constant or a var *) - -type expr = expr_int * tag - -and expr_int = - | Con of Constant.t - | Var of Symbol.t - | App of Symbol.t * expr list - | Bin of expr * bop * expr - | Ite of pred * expr * expr - | Fld of Symbol.t * expr (* NOTE: Fld (s, e) == App ("field"^s,[e]) *) - | Cst of expr * Sort.t - | Bot - | MExp of expr list - | MBin of expr * bop list * expr - -and pred = pred_int * tag - -and pred_int = - | True - | False - | And of pred list - | Or of pred list - | Not of pred - | Imp of pred * pred - | Iff of pred * pred - | Bexp of expr - | Atom of expr * brel * expr - | MAtom of expr * brel list * expr - | Forall of ((Symbol.t * Sort.t) list) * pred - -let list_hash b xs = - List.fold_left (fun v (_,id) -> 2*v + id) b xs - -module Hashcons (X : sig type t - val sub_equal : t -> t -> bool - val hash : t -> int end) = struct - - module HashStruct = struct - type t = X.t * int - let equal (x,_) (y,_) = X.sub_equal x y - let hash (x,_) = X.hash x - end - - module Hash = Weak.Make(HashStruct) - - let wrap = - let tab = Hash.create 251 in - let ctr = ref 0 in - fun e -> - let res = Hash.merge tab (e, !ctr) in - let _ = if snd res = !ctr then incr ctr in - res - - let unwrap (e,_) = e - -end - -module ExprHashconsStruct = struct - type t = expr_int - let sub_equal e1 e2 = - match e1, e2 with - | Con c1, Con c2 -> - c1 = c2 - | MExp es1, MExp es2 -> - es1 = es2 - | Var x1, Var x2 -> - x1 = x2 - | App (s1, e1s), App (s2, e2s) -> - (s1 = s2) && - (try List.for_all2 (==) e1s e2s with _ -> false) - | Bin (e1, op1, e1'), Bin (e2, op2, e2') -> - op1 = op2 && e1 == e2 && e1' == e2' - | MBin (e1, ops1, e1'), MBin (e2, ops2, e2') -> - ops1 = ops2 && e1 == e2 && e1' == e2' - | Ite (ip1,te1,ee1), Ite (ip2,te2,ee2) -> - ip1 == ip2 && te1 == te2 && ee1 == ee2 - | Fld (s1, e1), Fld (s2, e2) -> - s1 = s2 && e1 == e2 - | Cst (e1, s1), Cst (e2, s2) -> - s1 = s2 && e1 == e2 - | _ -> - false - - let hash = function - | Con (Constant.Int x) -> - x - | Con (Constant.Real x) -> - 64 + int_of_float x - | Con (Constant.Lit (s,_)) -> - 32 + Hashtbl.hash s - | MExp es -> - list_hash 6 es - | Var x -> - Hashtbl.hash x - | App (s, es) -> - list_hash ((Hashtbl.hash s) + 1) es - | Bin ((_,id1), op, (_,id2)) -> - (Hashtbl.hash op) + 1 + (2 * id1) + id2 - | MBin ((_,id1), op::_ , (_,id2)) -> - (Hashtbl.hash op) + 1 + (2 * id1) + id2 - | Ite ((_,id1), (_,id2), (_,id3)) -> - 32 + (4 * id1) + (2 * id2) + id3 - | Fld (s, (_,id)) -> - (Hashtbl.hash s) + 12 + id - | Cst ((_, id), t) -> - id + Hashtbl.hash (Sort.to_string t) - | Bot -> - 0 - | _ -> assertf "pattern error in A.pred hash" - -end - -module ExprHashcons = Hashcons(ExprHashconsStruct) - -module PredHashconsStruct = struct - - type t = pred_int - - let sub_equal p1 p2 = - match p1, p2 with - | True, True | False, False -> - true - | And p1s, And p2s | Or p1s, Or p2s -> - (try List.for_all2 (==) p1s p2s with _ -> false) - | Not p1, Not p2 -> - p1 == p2 - | Imp (p1, p1'), Imp (p2, p2') -> - p1 == p2 && p1' == p2' - | Iff (p1,p1'), Iff (p2,p2') -> - p1 == p2 && p1' == p2' - | Bexp e1, Bexp e2 -> - e1 == e2 - | Atom (e1, r1, e1'), Atom (e2, r2, e2') -> - r1 = r2 && e1 == e2 && e1' == e2' - | MAtom (e1, r1, e1'), MAtom (e2, r2, e2') -> - r1 = r2 && e1 == e2 && e1' == e2' - | Forall(q1s,p1), Forall(q2s,p2) -> - q1s = q2s && p1 == p2 - | _ -> - false - - let hash = function - | True -> - 0 - | False -> - 1 - | And ps -> - list_hash 2 ps - | Or ps -> - list_hash 3 ps - | Not (_,id) -> - 8 + id - | Imp ((_,id1), (_,id2)) -> - 20 + (2 * id1) + id2 - | Iff ((_,id1), (_,id2)) -> - 28 + (2 * id1) + id2 - | Bexp (_, id) -> - 32 + id - | Atom ((_,id1), r, (_,id2)) -> - 36 + (Hashtbl.hash r) + (2 * id1) + id2 - | MAtom ((_,id1), r, (_,id2)) -> - 42 + (Hashtbl.hash r) + (2 * id1) + id2 - | Forall(qs,(_,id)) -> - 50 + (2 * (Hashtbl.hash qs)) + id -end - -module PredHashcons = Hashcons(PredHashconsStruct) - -let ewr = ExprHashcons.wrap -let euw = ExprHashcons.unwrap -let pwr = PredHashcons.wrap -let puw = PredHashcons.unwrap - -(* Constructors: Expressions *) -let eCon = fun c -> ewr (Con c) -let eMExp = fun es -> ewr (MExp es) -let eInt = fun i -> eCon (Constant.Int i) -let zero = eInt 0 -let one = eInt 1 -let bot = ewr Bot -let eMod = fun (e, e') -> ewr (Bin (e, Mod, e')) - -(* let eMod = fun (e, m) -> ewr (Bin (e, Mod, eInt m)) *) - -let eModExp = fun (e, m) -> ewr (Bin (e, Mod, m)) -let eVar = fun s -> ewr (Var s) -let eApp = fun (s, es) -> ewr (App (s, es)) -let eBin = fun (e1, op, e2) -> ewr (Bin (e1, op, e2)) - -let eMBin = fun (e1, ops, e2) -> ewr (MBin (e1, ops, e2)) -let eIte = fun (ip,te,ee) -> ewr (Ite(ip,te,ee)) -let eFld = fun (s,e) -> ewr (Fld (s,e)) -let eCst = fun (e,t) -> ewr (Cst (e, t)) - -let eTim = function - | (Con (Constant.Int n1), _), (Con (Constant.Int n2), _) -> - ewr (Con (Constant.Int (n1 * n2))) - | (Con (Constant.Int 1), _), e2 -> - e2 - | (Con (Constant.Int (-1)), _), e2 -> - eBin (zero, Minus, e2) - | (e1, e2) -> eBin (e1, Times, e2) - - -let rec conjuncts = function - | And ps, _ -> Misc.flap conjuncts ps - | True, _ -> [] - | p -> [p] - - -(* Constructors: Predicates *) -let pTrue = pwr True -let pFalse = pwr False -let pAtom = fun (e1, r, e2) -> pwr (Atom (e1, r, e2)) -let pMAtom = fun (e1, r, e2) -> pwr (MAtom (e1, r, e2)) -let pOr = fun ps -> pwr (Or ps) -let pNot = fun p -> pwr (Not p) -let pBexp = fun e -> pwr (Bexp e) -let pImp = fun (p1,p2) -> pwr (Imp (p1,p2)) -let pIff = fun (p1,p2) -> pwr (Iff (p1,p2)) -let pForall = fun (qs, p) -> pwr (Forall (qs, p)) -let pEqual = fun (e1,e2) -> pAtom (e1, Eq, e2) -let pUequal = fun (e1,e2) -> pAtom (e1, Ueq, e2) - - -let pAnd = fun ps -> match Misc.flap conjuncts ps with - | [] -> pTrue - | [p] -> p - | ps -> pwr (And (Misc.flap conjuncts ps)) - - - -module ExprHash = Hashtbl.Make(struct - type t = expr - let equal (_,x) (_,y) = (x = y) - let hash (_,x) = x -end) - -module PredHash = Hashtbl.Make(struct - type t = pred - let equal (_,x) (_,y) = (x = y) - let hash (_,x) = x -end) - -let bop_to_string = function - | Plus -> "+" - | Minus -> "-" - | Times -> "*" - | Div -> "/" - | Mod -> "mod" - -let brel_to_string = function - | Eq -> "=" - | Ne -> "!=" - | Gt -> ">" - | Ge -> ">=" - | Lt -> "<" - | Le -> "<=" - | Ueq -> "~~" - | Une -> "!~" - -let print_brel ppf r = - F.fprintf ppf "%s" (brel_to_string r) - -let print_binding ppf (s,t) = - F.fprintf ppf "%a:%a" Symbol.print s Sort.print t - -let bind_to_string (s,t) = - Printf.sprintf "%s:%s" (Symbol.to_string s) (Sort.to_string t) - -let rec print_expr ppf e = match euw e with - | Con c -> - F.fprintf ppf "%a" Constant.print c - | MExp es -> - F.fprintf ppf "[%a]" (Misc.pprint_many false " ; " print_expr) es - | Var s -> - F.fprintf ppf "%a" Symbol.print s - | App (s, es) -> - F.fprintf ppf "%a([%a])" - Symbol.print s - (Misc.pprint_many false "; " print_expr) es - | Bin (e1, op, e2) -> - F.fprintf ppf "(%a %s %a)" - print_expr e1 - (bop_to_string op) - print_expr e2 - | MBin (e1, ops, e2) -> - F.fprintf ppf "(%a [%s] %a)" - print_expr e1 - (ops |>: bop_to_string |> String.concat " ; ") - print_expr e2 - - | Ite (ip, te, ee) -> - F.fprintf ppf "if %a then %a else %a" - print_pred ip - print_expr te - print_expr ee - - (* DEPRECATED TO HELP HS Parser - | Ite(ip,te,ee) -> - F.fprintf ppf "(%a ? %a : %a)" - print_pred ip - print_expr te - print_expr ee - *) - - | Fld(s, e) -> - F.fprintf ppf "%a.%s" print_expr e s - | Cst(e,t) -> - F.fprintf ppf "(%a : %a)" - print_expr e - Sort.print t - | Bot -> - F.fprintf ppf "_|_" - -and print_pred ppf p = match puw p with - | True -> - F.fprintf ppf "true" - | False -> - F.fprintf ppf "false" - | Bexp (App (s, es), _) -> - F.fprintf ppf "%a(%a)" Symbol.print s (Misc.pprint_many false ", " print_expr) es - | Bexp e -> - F.fprintf ppf "(Bexp %a)" print_expr e - | Not p -> - F.fprintf ppf "(~ (%a))" print_pred p - | Imp (p1, p2) -> - F.fprintf ppf "(%a => %a)" print_pred p1 print_pred p2 - | Iff (p1, p2) -> - F.fprintf ppf "(%a <=> %a)" print_pred p1 print_pred p2 - | And ps -> begin match ps with [] -> F.fprintf ppf "true" | _ -> - F.fprintf ppf "&& %a" (Misc.pprint_many_brackets true print_pred) ps - end - | Or ps -> begin match ps with [] -> F.fprintf ppf "false" | _ -> - F.fprintf ppf "|| %a" (Misc.pprint_many_brackets true print_pred) ps - end - - | Atom (e1, r, e2) -> - (* F.fprintf ppf "@[(%a %s %a)@]" *) - F.fprintf ppf "(%a %s %a)" - print_expr e1 - (brel_to_string r) - print_expr e2 - | MAtom (e1, rs, e2) -> - F.fprintf ppf "(%a [%a] %a)" - (* F.fprintf ppf "@[(%a [%a] %a)@]" *) - print_expr e1 - (Misc.pprint_many false " ; " print_brel) rs - print_expr e2 - | Forall (qs, p) -> - F.fprintf ppf "forall [%a] . %a" - (Misc.pprint_many false "; " print_binding) qs - print_pred p - -let rec expr_to_string e = - match euw e with - | Con c -> - Constant.to_string c - | MExp es -> - Printf.sprintf "[%s]" (es |>: expr_to_string |> String.concat " ; ") - | Var s -> - Symbol.to_string s - | App (s, es) -> - Printf.sprintf "%s([%s])" - (Symbol.to_string s) - (es |> List.map expr_to_string |> String.concat "; ") - | Bin (e1, op, e2) -> - Printf.sprintf "(%s %s %s)" - (expr_to_string e1) (bop_to_string op) (expr_to_string e2) - | MBin (e1, ops, e2) -> - Printf.sprintf "(%s [%s] %s)" - (expr_to_string e1) - (ops |> List.map bop_to_string |> String.concat "; ") - (expr_to_string e2) - | Ite(ip,te,ee) -> - Printf.sprintf "(%s ? %s : %s)" - (pred_to_string ip) (expr_to_string te) (expr_to_string ee) - | Fld(s,e) -> - Printf.sprintf "%s.%s" (expr_to_string e) s - | Cst(e,t) -> - Printf.sprintf "(%s : %s)" (expr_to_string e) (Sort.to_string t) - | Bot -> - Printf.sprintf "_|_" - - -and pred_to_string p = - match puw p with - | True -> - "true" - | False -> - "false" - | Bexp e -> - Printf.sprintf "(Bexp %s)" (expr_to_string e) - | Not p -> - Printf.sprintf "(~ (%s))" (pred_to_string p) - | Imp (p1, p2) -> - Printf.sprintf "(%s => %s)" (pred_to_string p1) (pred_to_string p2) - | Iff (p1, p2) -> - Printf.sprintf "(%s <=> %s)" (pred_to_string p1) (pred_to_string p2) - | And ps -> - Printf.sprintf "&& [%s]" (List.map pred_to_string ps |> String.concat " ; ") - | Or ps -> - Printf.sprintf "|| [%s]" (List.map pred_to_string ps |> String.concat ";") - | Atom (e1, r, e2) -> - Printf.sprintf "(%s %s %s)" - (expr_to_string e1) (brel_to_string r) (expr_to_string e2) - | MAtom (e1, rs, e2) -> - Printf.sprintf "(%s [%s] %s)" - (expr_to_string e1) - (List.map brel_to_string rs |> String.concat " ; ") - (expr_to_string e2) - | Forall (qs,p) -> - Printf.sprintf "forall [%s] . %s" - (List.map bind_to_string qs |> String.concat "; ") (pred_to_string p) - -let rec pred_map hp he fp fe p = - let rec pm p = - try PredHash.find hp p with Not_found -> begin - let p' = - match puw p with - | True | False as p1 -> - p1 - | And ps -> - And (List.map pm ps) - | Or ps -> - Or (List.map pm ps) - | Not p -> - Not (pm p) - | Imp (p1, p2) -> - Imp (pm p1, pm p2) - | Iff (p1, p2) -> - Iff (pm p1, pm p2) - | Bexp e -> - Bexp (expr_map hp he fp fe e) - | Atom (e1, r, e2) -> - Atom (expr_map hp he fp fe e1, r, expr_map hp he fp fe e2) - | MAtom (e1, rs, e2) -> - MAtom (expr_map hp he fp fe e1, rs, expr_map hp he fp fe e2) - | Forall (qs, p) -> - Forall (qs, pm p) in - let rv = fp (pwr p') in - let _ = PredHash.add hp p rv in - rv - end in pm p - -and expr_map hp he fp fe e = - let rec em e = - try ExprHash.find he e with Not_found -> begin - let e' = - match euw e with - | Con _ | Var _ | Bot as e1 -> - e1 - | MExp es -> - MExp (List.map em es) - | App (f, es) -> - App (f, List.map em es) - | Bin (e1, op, e2) -> - Bin (em e1, op, em e2) - | MBin (e1, ops, e2) -> - MBin (em e1, ops, em e2) - | Ite (ip, te, ee) -> - Ite (pred_map hp he fp fe ip, em te, em ee) - | Fld (s, e1) -> - Fld (s, em e1) - | Cst (e1, t) -> - Cst (em e1, t) - in - let rv = fe (ewr e') in - let _ = ExprHash.add he e rv in - rv - end in em e - -let rec pred_iter fp fe pw = - begin match puw pw with - | True | False -> () - | Bexp e -> expr_iter fp fe e - | Not p -> pred_iter fp fe p - | Imp (p1, p2) -> pred_iter fp fe p1; pred_iter fp fe p2 - | Iff (p1, p2) -> pred_iter fp fe p1; pred_iter fp fe p2 - | And ps | Or ps -> List.iter (pred_iter fp fe) ps - | Atom (e1, _, e2) -> expr_iter fp fe e1; expr_iter fp fe e2 - | MAtom (e1, _, e2) -> expr_iter fp fe e1; expr_iter fp fe e2 - | Forall (_, p) -> pred_iter fp fe p (* pmr: looks wrong, but so does pred_map *) - end; - fp pw - -and expr_iter fp fe ew = - begin match puw ew with - | Con _ | Var _ | Bot -> - () - | MExp es -> - List.iter (expr_iter fp fe) es - | App (_, es) -> - List.iter (expr_iter fp fe) es - | Bin (e1, _, e2) -> - expr_iter fp fe e1; expr_iter fp fe e2 - | MBin (e1, _, e2) -> - expr_iter fp fe e1; expr_iter fp fe e2 - | Ite (ip, te, ee) -> - pred_iter fp fe ip; expr_iter fp fe te; expr_iter fp fe ee - | Fld (_, e1) | Cst (e1, _) -> - expr_iter fp fe e1 - end; - fe ew - -let esub x e = function - | (Var y), _ when x = y -> e - | _ as e1 -> e1 - -let expr_subst hp he e x e' = - expr_map hp he id (esub x e') e - -let pred_subst hp he p x e' = - pred_map hp he id (esub x e') p - -module Expression = - struct - - module Hash = ExprHash - - let to_string = expr_to_string - - (* let print = fun fmt e -> Format.pp_print_string fmt (to_string e) - *) - let print = print_expr - - let show = print Format.std_formatter - - let map fp fe e = - let hp = PredHash.create 251 in - let he = ExprHash.create 251 in - expr_map hp he fp fe e - - let iter fp fe e = - expr_iter fp fe e - - let subst e x e' = - map id (esub x e') e - - let substs e xes = - map id (fun e -> List.fold_left (esub |> Misc.uncurry |> Misc.flip) e xes) e - - let support e = - let xs = ref Symbol.SSet.empty in - iter un begin function - | (Var x), _ - | (App (x,_)),_ -> xs := Symbol.SSet.add x !xs - | _ -> () - end e; - Symbol.SSet.elements !xs |> List.sort compare - - let unwrap = euw - - let has_bot p = - let r = ref false in - iter un begin function - | Bot, _ -> r := true - | _ -> () - end p; - !r - - end - -module Predicate = struct - module Hash = PredHash - - let to_string = pred_to_string - let print = print_pred - let show = print Format.std_formatter - - let map fp fe p = - let hp = PredHash.create 251 in - let he = ExprHash.create 251 in - pred_map hp he fp fe p - - let iter fp fe p = - pred_iter fp fe p - - let subst p x e' = - map id (esub x e') p - - let substs p xes = - map id (fun e -> List.fold_left (esub |> Misc.uncurry |> Misc.flip) e xes) p - - let support p = - let xs = ref Symbol.SSet.empty in - iter un begin function - | (Var x), _ - | (App (x,_)),_ -> xs := Symbol.SSet.add x !xs; - | _ -> () - end p; - Symbol.SSet.elements !xs |> List.sort compare - - (* - let size p = - let c = ref 0 in - let f = fun _ -> incr c in - let _ = iter f f p in - !c - - let size p = - let c = ref 0 in - let _ = iter (fun _ -> incr c) p in - !c - *) - - let unwrap = puw - - let is_contra = - let t = PredHash.create 17 in - let _ = [pFalse; pNot pTrue; pAtom (zero, Eq, one); pAtom (one, Eq, zero)] - |> List.iter (fun p-> PredHash.replace t p ()) in - fun p -> PredHash.mem t p - - - let rec is_tauto = function - | Atom(e1, Eq, e2), _ -> snd e1 == snd e2 - | Atom(e1, Ueq, e2), _ -> snd e1 == snd e2 - | Imp (p1, p2), _ -> snd p1 == snd p2 - | And ps, _ -> List.for_all is_tauto ps - | Or ps, _ -> List.exists is_tauto ps - | True, _ -> true - | _ -> false - - let has_bot p = - let r = ref false in - iter un begin function - | Bot, _ -> r := true - | _ -> () - end p; - !r - - end - -let print_stats _ = - Printf.printf "Ast Stats. [none] \n" - - -(********************************************************************************) -(************************** Rationalizing Division ******************************) -(********************************************************************************) - -let expr_isdiv = function - | Bin (_, Div, _), _ -> true - | _ -> false - -let pull_divisor = function - | Bin (_, Div, (Con (Constant.Int i),_)), _ -> i - | _ -> 1 - -let calc_cm e1 e2 = - pull_divisor e1 * pull_divisor e2 - -let rec apply_mult m = function - | Bin (e, Div, (Con (Constant.Int d),_)), _ -> - let _ = assert ((m/d) * d = m) in - eTim ((eCon (Constant.Int (m/d))), e) - | Bin (e1, op, e2), _ -> - eBin (apply_mult m e1, op, apply_mult m e2) - | Con (Constant.Int i), _ -> - eCon (Constant.Int (i*m)) - | e -> - eTim (eCon (Constant.Int m), e) - -let rec pred_isdiv = function - | True,_ | False,_ -> - false - | And ps,_ | Or ps,_ -> - List.exists pred_isdiv ps - | Not p, _ | Forall (_, p), _ -> - pred_isdiv p - | Imp (p1, p2), _ -> - pred_isdiv p1 || pred_isdiv p2 - | Iff (p1, p2), _ -> - pred_isdiv p1 || pred_isdiv p2 - | Bexp e, _ -> - expr_isdiv e - | Atom (e1, _, e2), _ -> - expr_isdiv e1 || expr_isdiv e2 - | _ -> failwith "Unexpected: pred_isdiv" - -let bound m e e1 e2 = - pAnd [pAtom (apply_mult m e, Gt, apply_mult m e2); - pAtom(apply_mult m e, Le, apply_mult m e1)] - -let rec fixdiv = function - | p when not (pred_isdiv p) -> - p - | Atom ((Var _,_) as e, Eq, e1), _ | Atom ((Con _, _) as e, Eq, e1), _ -> - bound (calc_cm e e1) e e1 (eBin (e1, Minus, one)) - | And ps, _ -> - pAnd (List.map fixdiv ps) - | Or ps, _ -> - pOr (List.map fixdiv ps) - | Imp (p1, p2), _ -> - pImp (fixdiv p1, fixdiv p2) - | Iff (p1, p2), _ -> - pIff (fixdiv p1, fixdiv p2) - | Not p, _ -> - pNot (fixdiv p) - | p -> p - -(***************************************************************************) -(************* Type Checking Expressions and Predicates ********************) -(***************************************************************************) - -let sortcheck_sym f s = f s - (* try Some (f s) with _ -> None *) - -let sortcheck_loc f = function - | Sort.Loc s -> sortcheck_sym f (Symbol.of_string s) - | Sort.Lvar _ -> None - | Sort.LFun -> None - -let uf_arity f uf = - match sortcheck_sym f uf with None -> None | Some t -> - match Sort.func_of_t t with None -> None | Some (i,_,_) -> - Some i - -let solved_app f uf = function - | Some (s, t) -> begin match uf_arity f uf with - | Some n -> if Sort.check_arity n s then Some t else None - | _ -> None - end - | None -> None - -let checkArity f uf = function - | None -> None - | Some (s, t) -> begin match uf_arity f uf with - | Some n -> if Sort.check_arity n s then Some (s, t) else None - | _ -> None - end - -let unifiable t1 t2 = - match Sort.unify [t1] [t2] with - | Some _ -> true - | _ -> false - - -(* added for sortcheck of Nothing([]) - it used to fail, as (su, Some (Just @0)) = sortcheck_expr (Nothing ([])) - but su.vars is empty - *) -let updateArity env f = function - | None -> None - | Some (su, t) -> begin match uf_arity f env with - | Some n -> - let rec go n - = if n < 0 - then [] - else match Sort.lookup_var su n with - | Some _ -> go (n-1) - | None -> (n, Sort.Var n) :: go (n-1) - in Some({su with Sort.vars = List.append su.Sort.vars (go n) }, t) - | None -> None - end - -let rec sortcheck_expr g f expected_t e = - match euw e with - | Bot -> - None - | Con (Constant.Int _) -> - Some Sort.Int - | Con (Constant.Real _) -> - Some Sort.Real - | Con (Constant.Lit (_, t)) -> - Some t - | Var s -> - sortcheck_sym f s - | Bin (e1, op, e2) -> - sortcheck_op g f (e1, op, e2) - | Ite (p, e1, e2) -> - if sortcheck_pred g f p then - match Misc.map_pair (sortcheck_expr g f None) (e1, e2) with - | (Some t1, Some t2) -> - begin - match Sort.unify [t1] [t2] with - | Some s -> Some (Sort.apply s t1) - | None -> None - end - | _ -> None - else None - | Cst (e1, t) -> - begin match euw e1 with - | App (uf, es) -> sortcheck_app g f (Some t) uf es - | _ -> - match sortcheck_expr g f None e1 with - | Some t1 when Sort.compat t t1 -> Some t - | _ -> None - end - - | App (uf, es) -> - sortcheck_app g f expected_t uf es - - | _ -> assertf "Ast.sortcheck_expr: unhandled expr = %s" (Expression.to_string e) - -(* TODO: OMG! 5 levels of matching!!!!! *) -and sortcheck_app_sub g f so_expected uf es = - let yikes uf = F.printf "sortcheck_app_sub: unknown sym = %s \n" (Symbol.to_string uf) in - sortcheck_sym f uf - |> function None -> (* yikes uf; *) None | Some t -> - Sort.func_of_t t - |> function None -> None | Some (tyArity, i_ts', o_t') -> - let freshMap = Sort.makeFresh tyArity in - let i_ts = List.map (Sort.refresh freshMap) i_ts' in - let o_t = Sort.refresh freshMap o_t' in - let _ = asserts (List.length es = List.length i_ts) - "ERROR: uf arg-arity error: uf=%s" uf in - let e_ts = (List.map (fun x -> Some x) i_ts, es) |> Misc.zipWith (sortcheck_expr g f) |> Misc.map_partial id in - if List.length e_ts <> List.length i_ts then - (* let _ = F.printf "OUT2 \n es = %s \n e_ts = %s \n i_ts = %s" - (String.concat "\t" (List.map Expression.to_string es)) - (String.concat "\t" (List.map Sort.to_string e_ts)) - (String.concat "\t" (List.map Sort.to_string i_ts)) - in*) None - else - match Sort.unify e_ts i_ts with - | None -> None - | Some s -> - let t = Sort.apply s o_t in - match so_expected with - | None -> Some (s, t) - | Some t' -> - match Sort.unifyWith s [t] [t'] with - | None -> (*let _ = F.printf "\nOUT5 Cannot unify: %s \t\t with \t\t %s" (Sort.to_string t) (Sort.to_string t') in *) - None - | Some s' -> Some (s', Sort.apply s' t) - -and sortcheck_app g f tExp uf es = - - sortcheck_app_sub g f tExp uf es - |> updateArity uf f (* THIS CHECK IS NEW, but will it break a bunch of tests? *) - |> Misc.maybe_map snd - (* - >> begin function - | Some t -> Format.printf "sortcheck_app: e = %s , t = %s \n" - (expr_to_string (eApp (uf, es))) (Sort.to_string t) - | None -> Format.printf "sortcheck_app: e = %s FAILS\n" - (expr_to_string (eApp (uf, es))) - end - *) - -and sortcheck_op g f (e1, op, e2) = -(* DEBUGGING - let (s1, s2) = Misc.map_pair (sortcheck_expr g f) (e1, e2) in - let _ = match (s1, s2) with - | (Some t1, Some t2) -> F.printf "sortcheck_op : \n%s - %s\n" (Sort.to_string t1) (Sort.to_string t2) - | (_, Some t2) -> F.printf "sortcheck_op1 : \n - %s\n" (Sort.to_string t2) - | (Some t1, _) -> F.printf "sortcheck_op2 : \n%s \n" (Sort.to_string t1) - | (_, _) -> F.printf "sortcheck_op3 : \n" - in *) - match Misc.map_pair (sortcheck_expr g f None) (e1, e2) with - | (Some Sort.Int, Some Sort.Int) - -> Some Sort.Int - - | (Some Sort.Real, Some Sort.Real) - -> Some Sort.Real - - (* only allow when language is Haskell *) - | (Some (Sort.Ptr l), Some (Sort.Ptr l')) - when (l = l' && sortcheck_loc f l = Some Sort.Num) - -> Some (Sort.Ptr l) - - (* only allow when language is C *) - | (Some (Sort.Ptr s), Some Sort.Int) - | (Some Sort.Int, Some (Sort.Ptr s)) - -> Some (Sort.Ptr s) - - (* only allow when language is C *) - | (Some (Sort.Ptr s), Some (Sort.Ptr s')) - when op = Minus && s = s' - -> Some Sort.Int - - | (Some (Sort.Var v), Some t) - | (Some t, Some (Sort.Var v)) - -> begin match Sort.unify [Sort.Var v] [t] with - | None -> None - | Some _ -> Some t (* PV: subst is lost here *) - end - - | _ -> None - - -and sortcheck_rel g f (e1, r, e2) = - let t1o, t2o = (e1,e2) |> Misc.map_pair (sortcheck_expr g f None) in - match r, t1o, t2o with - | Ueq, Some (_), Some (_) - | Une, Some (_), Some (_) - -> true - | _, Some (Sort.Ptr _) , Some (Sort.Ptr Sort.LFun) - | _, Some (Sort.Ptr Sort.LFun), Some (Sort.Ptr _) - -> true - | _ , Some Sort.Int, Some (Sort.Ptr l) - | _ , Some (Sort.Ptr l), Some Sort.Int - -> (sortcheck_loc f l = Some Sort.Num) - | _ , Some (Sort.Ptr l1), Some (Sort.Ptr l2) - when ((sortcheck_loc f l1 = Some Sort.Num) - && (sortcheck_loc f l2 = Some Sort.Num)) - || ((sortcheck_loc f l1 = Some Sort.Frac) - && (sortcheck_loc f l2 = Some Sort.Frac)) - -> true - | _ , Some Sort.Real, Some (Sort.Ptr l) - | _ , Some (Sort.Ptr l), Some Sort.Real - -> sortcheck_loc f l = Some Sort.Frac - | Eq, Some t1, Some t2 - | Ne, Some t1, Some t2 - -> unifiable t1 t2 - | _ , Some (Sort.App (tc,_)), _ - when (g tc) (* tc is an interpreted tycon *) - -> false - | _ , Some t1, Some t2 - -> unifiable t1 t2 && t1 != Sort.Bool - | _ -> false - -and sortcheck_pred g f p = - match puw p with - | True - | False -> - true - | Bexp e -> - sortcheck_expr g f (Some Sort.Bool) e = Some Sort.Bool - | Not p -> - sortcheck_pred g f p - | Imp (p1, p2) | Iff (p1, p2) -> - List.for_all (sortcheck_pred g f) [p1; p2] - | And ps - | Or ps -> - List.for_all (sortcheck_pred g f) ps - | Atom (e1, Ueq, e2) - when !Constants.ueq_all_sorts - -> (not (None = sortcheck_expr g f None e1)) && - (not (None = sortcheck_expr g f None e2)) - - | Atom ((Con (Constant.Int(0)),_), _, e) - | Atom (e, _, (Con (Constant.Int(0)),_)) - when not (!Constants.strictsortcheck) - -> not (None = sortcheck_expr g f None e) - - | Atom (((Con _, _) as e), Eq, (App (uf, es), _)) - | Atom ((App (uf, es), _), Eq, ((Con _, _) as e)) - | Atom (((Var _, _) as e), Eq, (App (uf, es), _)) - | Atom ((App (uf, es), _), Eq, ((Var _, _) as e)) - (* -> begin match sortcheck_sym f x with *) - -> begin match sortcheck_expr g f None e with - | None -> false - | Some t -> not (None = sortcheck_app g f (Some t) uf es) - end - - | Atom (((App (uf1, e1s), _) as e1), Eq, ((App (uf2, e2s), _) as e2)) - -> let t1o = solved_app f uf1 <| sortcheck_app_sub g f None uf1 e1s in - let t2o = solved_app f uf2 <| sortcheck_app_sub g f None uf2 e2s in - begin match t1o, t2o with - | (Some t1, Some t2) -> (* let _ = F.printf "sortcheck Eq App1 %s" (Predicate.to_string p) in *) unifiable t1 t2 - | (None, None) -> (* let _ = F.printf "sortcheck Eq App2 %s" (Predicate.to_string p) in *) false - | (None, Some t2) -> (* let _ = F.printf "sortcheck Eq App3 %s" (Predicate.to_string p) in *) not (None = sortcheck_app g f (Some t2) uf1 e1s) - | (Some t1, None) -> (* let _ = F.printf "sortcheck Eq App4 %s :: %s" - (Predicate.to_string p) (Sort.to_string t1) in *) - not (None = sortcheck_app g f (Some t1) uf2 e2s) - end - - | Atom (e1, r, e2) -> - sortcheck_rel g f (e1, r, e2) - | Forall (qs,p) -> - (* let f' = fun x -> try List.assoc x qs with _ -> f x in *) - let f' = fun x -> match Misc.list_assoc_maybe x qs with None -> f x | y -> y - in sortcheck_pred g f' p - | _ -> failwith "Unexpected: sortcheck_pred" - -(* and sortcheck_pred f p = - sortcheck_pred' f p - >> (fun b -> if not b then F.eprintf "WARNING: Malformed Lhs Pred (%a)\n" Predicate.print p) - *) - -let opt_to_string p = function - | None -> "none" - | Some x -> p x - - -(* API *) -let sortcheck_app g f tExp uf es = - sortcheck_app_sub g f tExp uf es - |> checkArity f uf - -let sortcheck_expr g f e = sortcheck_expr g f None e - - (* - match uf_arity f uf, sortcheck_app_sub g f tExp uf es with - | (Some n, Some (s, t)) -> - if Sort.check_arity n s then - Some (s, t) - else - None - (* - let msg = Printf.sprintf "Ast.sortcheck_app: type params not instantiated %s: n = %d, s = %s, t = %s, tExp = %s" - (expr_to_string (eApp (uf, es))) - n - (Sort.sub_to_string s) - (Sort.to_string t) - (opt_to_string Sort.to_string tExp) - in - assertf "%s" msg - *) - | _ -> None - *) - - -let sortcheck_pred g f p = - sortcheck_pred g f p -(* >> (fun b -> ignore <| F.printf "DEBUG: sortcheck_pred: p = %a, res = %b\n" Predicate.print p b) -*) - -(***************************************************************************) -(************* Simplifying Expressions and Predicates **********************) -(***************************************************************************) - -let pred_of_bool = function true -> pTrue | false -> pFalse - -let rec remove_bot pol ((p, _) as pred) = - match p with - | Not p -> - pNot (remove_bot (not pol) p) - | Imp (p, q) -> - pImp (remove_bot (not pol) p, remove_bot pol q) - | Forall (qs, p) -> - pForall (qs, remove_bot pol p) - | And ps -> - ps |> List.map (remove_bot pol) |> pAnd - | Or ps -> - ps |> List.map (remove_bot pol) |> pOr - | Bexp e when Expression.has_bot e -> - pred_of_bool pol - | Atom (e1, _, e2) when Expression.has_bot e1 || Expression.has_bot e2 -> - pred_of_bool pol - | _ -> - pred - -let remove_bot p = - if Predicate.has_bot p - then remove_bot true p - else p - -let symm_brel = function - | Eq -> Eq - | Ueq -> Ueq - | Ne -> Ne - | Une -> Une - | Gt -> Lt - | Ge -> Le - | Lt -> Gt - | Le -> Ge - -let neg_brel = function - | Eq -> Ne - | Ueq -> Une - | Ne -> Eq - | Une -> Ueq - | Gt -> Le - | Ge -> Lt - | Lt -> Ge - | Le -> Gt - -let rec push_neg ?(neg=false) ((p, _) as pred) = - match p with - | True -> - if neg then pFalse else pred - | False -> - if neg then pTrue else pred - | Bexp _ -> - if neg then pNot pred else pred - | Not p -> - push_neg ~neg:(not neg) p - | Imp (p, q) -> - if neg then pAnd [push_neg p; push_neg ~neg:true q] - else pImp (push_neg p, push_neg q) - | Iff (p, q) -> - if neg then pIff (p, push_neg ~neg:true q) - else pIff (push_neg p, push_neg q) - | Forall (qs, p) -> - let pred' = pForall (qs, push_neg ~neg:false p) in - if neg then pNot pred' else pred' - | And ps -> - List.map (push_neg ~neg:neg) ps - |> if neg then pOr else pAnd - | Or ps -> - List.map (push_neg ~neg:neg) ps - |> if neg then pAnd else pOr - | Atom (e1, brel, e2) -> - if neg then pAtom (e1, neg_brel brel, e2) else pred - | _ -> failwith "Unexpected: push_neg" - -(* Andrey: TODO flatten nested conjunctions/disjunctions *) -let rec simplify_pred ((p, _) as pred) = - match p with - | Not p -> pNot (simplify_pred p) - | Imp (p, q) -> pImp (simplify_pred p, simplify_pred q) - | Forall (qs, p) -> pForall (qs, simplify_pred p) - | And ps -> ps |> List.map simplify_pred - |> List.filter (not <.> Predicate.is_tauto) - |> (function | [] -> pTrue - | [p] -> p - | _ when List.exists Predicate.is_contra ps -> pFalse - | _ -> pAnd ps) - | Or ps -> ps |> List.map simplify_pred - |> List.filter (not <.> Predicate.is_contra) - |> (function [] -> pFalse - | [p] -> p - | ps when List.exists Predicate.is_tauto ps -> pTrue - | ps -> pOr ps) - | _ -> pred - -(**************************************************************************) -(*************************** Substitutions ********************************) -(**************************************************************************) - -module Subst = struct - - type t = expr Symbol.SMap.t - - let valid xes = - xes |> List.split - |> Misc.app_snd (Misc.flap Expression.support) - |> Misc.uncurry Misc.disjoint - - - let extend s (x, e) = - let s = Symbol.SMap.map (esub x e) s in - if Symbol.SMap.mem x s then - s - else - match e with - | Var x', _ when x = x' -> s - | _ -> Symbol.SMap.add x e s - - let empty = Symbol.SMap.empty - let is_empty = Symbol.SMap.is_empty - let to_list = Symbol.SMap.to_list - let apply = Misc.flip Symbol.SMap.maybe_find - let of_list = fun xes -> List.fold_left extend empty xes - let simultaneous_of_list = Symbol.SMap.of_list - let compose s t = - let s' = Symbol.SMap.fold (fun x e s -> Symbol.SMap.map (esub x e) s) t s - in Symbol.SMap.fold (fun x e s -> if Symbol.SMap.mem x s - then s else Symbol.SMap.add x e s) - t s' - let print_sub = fun ppf (x,e) -> F.fprintf ppf "[%a:=%a]" Symbol.print x Expression.print e - let print = fun ppf -> to_list <+> F.fprintf ppf "%a" (Misc.pprint_many false "" print_sub) - -(* fun s1 s2 -> Symbol.SMap.fold (fun x e s -> extend s (x, e)) s2 s1 *) -(* let apply = Misc.flip Symbol.SMap.maybe_find *) - -end - - -(**************************************************************************) -(******************* Horn Clauses: Parsing ARMC files *********************) -(**************************************************************************) - -module Horn = struct - - type pr = string * string list - type gd = C of pred | K of pr - type t = pr * gd list - - let print_pr ppf (x, xs) = - Format.fprintf ppf "%s(%s)" x (String.concat "," xs) - - let print_gd ppf = function - | C p -> Predicate.print ppf p - | K x -> print_pr ppf x - - let print ppf (hd, gds) = - Format.fprintf ppf "%a :- %a." - print_pr hd - (Misc.pprint_many false "," print_gd) gds - - let support_pr = snd - let support_gd = function K pr -> support_pr pr | C p -> p |> Predicate.support |> List.map Symbol.to_string - let support = fun (hd, gds) -> (support_pr hd) ++ (Misc.flap support_gd gds) -end - -(* API *) -let simplify_pred = remove_bot <+> simplify_pred - - -let esub_su su e = match e with - | ((Var y), _) -> Misc.maybe_default (Subst.apply su y) e - | _ -> e - -(* ORIG - let substs_pred = fun p su -> su |> Subst.to_list |> Predicate.substs p |> simplify_pred -*) - -let substs_pred p su = Predicate.map id (esub_su su) p -let substs_expr e su = Expression.map id (esub_su su) e - -(****************************************************************************) -(******************** Unification of Predicates *****************************) -(****************************************************************************) - - -exception DoesNotUnify - -let rec pUnify (p1, p2) = - let res = - match p1, p2 with - | (Atom (e1, r1, e1'), _), (Atom (e2, r2, e2'), _) when r1 = r2 -> - let s1 = eUnify (e1, e2) in - let e1', e2' = Misc.map_pair ((Misc.flip Expression.substs) s1) (e1', e2') in - let s2 = eUnify (e1', e2') in - s1 ++ s2 - | (Bexp e1, _), (Bexp e2, _) -> - eUnify (e1, e2) - | (Not p1, _), (Not p2, _) -> - pUnify (p1, p2) - | (Imp (p1, p1'), _), (Imp (p2, p2'), _) -> - psUnify ([p1; p1'], [p2; p2']) - - | (And p1s, _), (And p2s, _) - | (Or p1s, _), (Or p2s, _) - when List.length p1s = List.length p2s -> - psUnify (p1s, p2s) - | _, _ -> raise DoesNotUnify - in - let _ = if mydebug then - (Format.printf "pUnify: p1 is %a, p2 is %a, subst = %a \n" - Predicate.print p1 Predicate.print p2 Subst.print (Subst.of_list res)) in - res - -and psUnify (p1s, p2s) = - let _ = asserts (List.length p1s = List.length p2s) "psUnify" in - List.fold_left2 begin fun s p1 p2 -> - (p1, p2) - |> Misc.map_pair (fun p -> Predicate.substs p s) - |> pUnify - |> (fun s' -> s' ++ s) - end [] p1s p2s - -and eUnify = function - | (Con c1, _), (Con c2, _) when c1 = c2 -> - [] - | (Var x1, _), (Var x2, _) when x1 = x2 -> - [] - | (Bin (e1, op1, e1'),_), (Bin (e2, op2, e2'), _) when op1 = op2 -> - esUnify ([e1; e1'], [e2; e2']) - | (Ite (p1, e1, e1'),_), (Ite (p2, e2, e2'), _) -> - let s = pUnify (p1, p2) in - let [e1; e1'; e2; e2'] = List.map ((Misc.flip Expression.substs) s) [e1; e1'; e2; e2'] in - esUnify ([e1; e1'], [e2; e2']) - | (Cst (e1, t1),_), (Cst (e2, t2),_) when t1 = t2 -> - eUnify (e1, e2) - | (App (uf1, e1s), _), (App (uf2, e2s),_) when uf1 = uf2 -> - esUnify (e1s, e2s) - | e, (Var x, _) | (Var x, _), e when Symbol.is_wild x -> - [(x, e)] - | _, _ -> raise DoesNotUnify - -and esUnify (e1s, e2s) = - let _ = asserts (List.length e1s = List.length e2s) "esUnify" in - List.fold_left2 begin fun s e1 e2 -> - (e1, e2) - |> Misc.map_pair (fun e -> Expression.substs e s) - |> eUnify - |> (fun s' -> s' ++ s) - end [] e1s e2s - -(* API *) -let unify_pred p1 p2 = try pUnify (p1, p2) |> Subst.of_list |> some with DoesNotUnify -> None -let into_of_expr = function Con (Constant.Int i), _ -> Some i | _ -> None - -let symm_pred = function - | Atom (e1, r, e2), _ -> pAtom (e2, symm_brel r, e1) - | p -> p - -(* {{{ -let rec expr_subst hp he e x e' = - let rec esub e = - try ExprHash.find he e with Not_found -> begin - let rv = - match euw e with - | Var y when x = y -> - e' - | Con _ | Var _ -> - e - | App (s, es) -> - App (s, List.map esub es) |> ewr - | Bin (e1, op, e2) -> - Bin (esub e1, op, esub e2) |> ewr - | Ite (ip, te, ee) -> - Ite (pred_subst hp he ip x e', esub te, esub ee) |> ewr - | Fld (s, e1) -> - Fld (s, esub e1) |> ewr in - let _ = ExprHash.add he e rv in - rv - end in esub e - -and pred_subst hp he e x e' = - let rec s e = - try PredHash.find h e with - Not_found -> (let foo = s1 e in PredHash.add h e foo; foo) - and s1 e = - match puw e with - True -> e - | False -> e - | And plist -> pwr (And(List.map s plist)) - | Or plist -> pwr (Or(List.map s plist)) - | Not p -> pwr (Not(s p)) - | Implies (p1, p2) -> pwr (Implies (s p1, s p2)) - | Equality (x,y) -> pwr (Equality(expr_subst h he x v vv,expr_subst h he y v vv)) - | Atom (_) -> e - | Leq(x,y) -> pwr (Leq(expr_subst h he x v vv, expr_subst h he y v vv)) - in s e -}}} *) -(** {{{ - let rec support pred = - let h = Hash.create 251 in - let eh = Expression.Hash.create 251 in - let sh = Hashtbl.create 251 in - let res = ref [] in - let add s = if not(Hashtbl.mem sh s) then Hashtbl.add sh s (); res := s :: !res in - - let se exp = - let rec s exp = - try Expression.Hash.find eh exp with - Not_found -> Expression.Hash.add eh exp (); s1 exp - and s1 exp = - match euw exp with - Constant(_) -> () - | Application (func, args) -> - add func; List.iter s args - | Variable(sym) -> add sym - | Sum(args) -> List.iter s args - | Coeff(c,t) -> s t - | Ite _ -> failwith "ite not supported" - in s exp in - - let rec s exp = - try Hash.find h exp with - Not_found -> Hash.add h exp (); s1 exp - and s1 pred = - match puw pred with - True -> () - | False -> () - | And plist -> List.iter s plist - | Or plist -> List.iter s plist - | Not p -> s p - | Implies (p1, p2) -> s p1; s p2 - | Equality (x,y) -> se x; se y - | Leq (x,y) -> se x; se y - | Atom (s) -> () - in s pred; List.rev !res - - let h = PredHash.create 251 in - let rec ip p = - let _ = f p in - if not (PredHash.mem h p) then begin - let _ = PredHash.add h p () in - match puw p with - | And ps | Or ps -> - List.iter ip plist - | Not p | Forall (_,p) -> - ip p - | Imp (p1, p2) -> - ip p1; ip p2 - | _ -> () - end in - ip p - }}} *) -(* {{{ - - (* Translate predicate to a satisfiability-equivalent predicate without Ite *) - - let temp_ctr = ref 0 - let new_temp () = - let n = "$$$" ^ (string_of_int !temp_ctr) in - (temp_ctr := !temp_ctr + 1; n) - - let elim_ite sp = - let cnsts = ref [] in - let he = Expression.Hash.create 251 in - let hp = Hash.create 251 in - let rec te e = - try Expression.Hash.find he e - with Not_found -> (let foo = te1 e in Expression.Hash.add he e foo; foo) - and te1 e = - match euw e with - Constant(c) -> e - | Application (func, args) -> - ewr (Application (func, List.map te args)) - | Variable(v) -> ewr (Variable(v)) - | Sum(args) -> ewr (Sum(List.map te args)) - | Coeff(c,t) -> ewr (Coeff(c,te t)) - | Ite(si,st,se) -> - let temp = ewr (Variable(new_temp())) in - let i = tp si in - let tv = te st and ev = te se in - begin - cnsts := pwr (Or [pwr (Not i); pwr (Equality(temp,(tv)))]) :: (!cnsts); - cnsts := pwr (Or [i; pwr (Equality(temp,(ev)))]) :: (!cnsts); - temp - end - and tp p = - try Hash.find hp p - with Not_found -> (let foo = tp1 p in Hash.add hp p foo; foo) - and tp1 p = - match puw p with - True -> p - | False -> p - | And plist -> pwr (And (List.map tp plist)) - | Or plist -> pwr (Or (List.map tp plist)) - | Not p -> pwr (Not (tp p)) - | Implies (p1, p2) -> pwr (Implies((tp p1),(tp p2))) - | Equality (x,y) -> pwr(Equality((te x),(te y))) - | Leq (x,y) -> pwr(Leq((te x),(te y))) - | Atom (s) -> p - in - let foo = tp sp in - pwr (And(foo :: !cnsts)) - }}} *) diff --git a/external/fixpoint/ast.mli b/external/fixpoint/ast.mli deleted file mode 100644 --- a/external/fixpoint/ast.mli +++ /dev/null @@ -1,255 +0,0 @@ -(* - * Copyright © 2009 The Regents of the University of California. All rights reserved. - * - * Permission is hereby granted, without written agreement and without - * license or royalty fees, to use, copy, modify, and distribute this - * software and its documentation for any purpose, provided that the - * above copyright notice and the following two paragraphs appear in - * all copies of this software. - * - * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY - * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES - * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN - * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY - * OF SUCH DAMAGE. - * - * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, - * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY - * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS - *) - -(** - * This module implements a DAG representation for expressions and - * predicates: each sub-predicate or sub-expression is paired with - * a unique int ID, which enables constant time hashing. - * However, one must take care when using DAGS: - * (1) they can only be constructed using the appropriate functions - * (2) when destructed via pattern-matching, one must discard the ID - *) - -(*******************************************************) -(********************** Base Logic ********************) -(*******************************************************) - -module Cone : sig - type 'a t = Empty | Cone of ('a * 'a t) list - val map : ('a -> 'b) -> 'a t -> 'b t -end - -module Sort : - sig - type loc = - | Loc of string - | Lvar of int - | LFun - - type tycon - type t - type sub - - val tycon : string -> tycon - val tycon_string: tycon -> string - - val to_string : t -> string - val print : Format.formatter -> t -> unit - val t_num : t - val t_frac : t - val t_obj : t - val t_bool : t - val t_int : t - val t_real : t - val t_generic : int -> t - val t_ptr : loc -> t - val t_func : int -> t list -> t - val t_app : tycon -> t list -> t - (* val t_fptr : t *) - - val is_bool : t -> bool - val is_int : t -> bool - val is_real : t -> bool - val is_func : t -> bool - val is_kind : t -> bool - val app_of_t : t -> (tycon * t list) option - val func_of_t : t -> (int * t list * t) option - val ptr_of_t : t -> loc option - - val compat : t -> t -> bool - val empty_sub : sub - val unifyWith : sub -> t list -> t list -> sub option - val unify : t list -> t list -> sub option - val apply : sub -> t -> t - val generalize : t list -> t list - val sub_args : sub -> (int * t) list - (* val check_arity : int -> sub -> bool *) - val makeFresh : int -> (int * int) list - val refresh : (int * int) list -> t -> t - end - -module Symbol : - sig - type t - module SMap : FixMisc.EMapType with type key = t - module SSet : FixMisc.ESetType with type elt = t - val mk_wild : unit -> t - val of_string : string -> t - val to_string : t -> string - val is_wild_any : t -> bool - val is_wild_fresh : t -> bool - val is_wild : t -> bool - val print : Format.formatter -> t -> unit - val value_variable : Sort.t -> t - val is_value_variable : t -> bool - val suffix : t -> string -> t - end - -module Constant : - sig - type t = Int of int - | Real of float - | Lit of string * Sort.t - - val to_string : t -> string - val print : Format.formatter -> t -> unit - end - -type tag (* externally opaque *) - -type brel = Eq | Ne | Gt | Ge | Lt | Le | Ueq | Une - -type bop = Plus | Minus | Times | Div | Mod (* NOTE: For "Mod" 2nd expr should be a constant or a var *) - -type expr = expr_int * tag - -and expr_int = - | Con of Constant.t - | Var of Symbol.t - | App of Symbol.t * expr list - | Bin of expr * bop * expr - | Ite of pred * expr * expr - | Fld of Symbol.t * expr (* NOTE: Fld (s, e) == App ("field"^s,[e]) *) - | Cst of expr * Sort.t - | Bot - | MExp of expr list - | MBin of expr * bop list * expr - -and pred = pred_int * tag - -and pred_int = - | True - | False - | And of pred list - | Or of pred list - | Not of pred - | Imp of pred * pred - | Iff of pred * pred - | Bexp of expr - | Atom of expr * brel * expr - | MAtom of expr * brel list * expr - | Forall of ((Symbol.t * Sort.t) list) * pred - -(* Constructors : expressions *) -val eTim : expr * expr -> expr -val eInt : int -> expr -val eCon : Constant.t -> expr -val eMExp : expr list -> expr -val eMod : expr * expr -> expr -val eModExp : expr * expr -> expr -val eVar : Symbol.t -> expr -val eApp : Symbol.t * expr list -> expr -val eBin : expr * bop * expr -> expr -val eMBin : expr * bop list * expr -> expr -val eIte : pred * expr * expr -> expr -val eFld : Symbol.t * expr -> expr -val eCst : expr * Sort.t -> expr -(* Constructors : predicates *) -val pTrue : pred -val pFalse : pred -val pAtom : expr * brel * expr -> pred -val pMAtom : expr * brel list * expr -> pred -val pAnd : pred list -> pred -val pOr : pred list -> pred -val pNot : pred -> pred -val pImp : (pred * pred) -> pred -val pIff : (pred * pred) -> pred -val pBexp : expr -> pred -val pForall: ((Symbol.t * Sort. t) list) * pred -> pred -val pEqual : expr * expr -> pred -val pUequal : expr * expr -> pred -val neg_brel : brel -> brel - -module Expression : -sig - module Hash : Hashtbl.S with type key = expr - - val print : Format.formatter -> expr -> unit - val show : expr -> unit - val to_string : expr -> string - - val unwrap : expr -> expr_int - val support : expr -> Symbol.t list - val subst : expr -> Symbol.t -> expr -> expr - val map : (pred -> pred) -> (expr -> expr) -> expr -> expr - val iter : (pred -> unit) -> (expr -> unit) -> expr -> unit -end - - -module Predicate : -sig - module Hash : Hashtbl.S with type key = pred - - val print : Format.formatter -> pred -> unit - val show : pred -> unit - val to_string : pred -> string - - val unwrap : pred -> pred_int - val support : pred -> Symbol.t list - val subst : pred -> Symbol.t -> expr -> pred - val map : (pred -> pred) -> (expr -> expr) -> pred -> pred - val iter : (pred -> unit) -> (expr -> unit) -> pred -> unit - val is_contra : pred -> bool - val is_tauto : pred -> bool -end - -module Subst : - sig - type t - val empty : t - val is_empty : t -> bool - val extend : t -> (Symbol.t * expr) -> t - val compose : t -> t -> t - val of_list : (Symbol.t * expr) list -> t - val simultaneous_of_list : (Symbol.t * expr) list -> t - val to_list : t -> (Symbol.t * expr) list - val print : Format.formatter -> t -> unit - val apply : t -> Symbol.t -> expr option - end - - -module Horn : - sig - type pr = string * string list - type gd = C of pred | K of pr - type t = pr * gd list - val print: Format.formatter -> t -> unit - val support: t -> string list - end - -val print_stats : unit -> unit -val fixdiv : pred -> pred -val zero : expr -val one : expr -val bot : expr - -val symm_pred : pred -> pred -val unify_pred : pred -> pred -> Subst.t option -val substs_expr : expr -> Subst.t -> expr -val substs_pred : pred -> Subst.t -> pred -val simplify_pred : pred -> pred -val conjuncts : pred -> pred list - -val sortcheck_expr : (Sort.tycon -> bool) -> (Symbol.t -> Sort.t option) -> expr -> Sort.t option -val sortcheck_pred : (Sort.tycon -> bool) -> (Symbol.t -> Sort.t option) -> pred -> bool -val sortcheck_app : (Sort.tycon -> bool) -> (Symbol.t -> Sort.t option) -> Sort.t option -> Symbol.t -> expr list -> (Sort.sub * Sort.t) option - -val into_of_expr : expr -> int option - diff --git a/external/fixpoint/cindex.ml b/external/fixpoint/cindex.ml deleted file mode 100644 --- a/external/fixpoint/cindex.ml +++ /dev/null @@ -1,427 +0,0 @@ -(* - * Copyright © 2009 The Regents of the University of California. All rights reserved. - * - * Permission is hereby granted, without written agreement and without - * license or royalty fees, to use, copy, modify, and distribute this - * software and its documentation for any purpose, provided that the - * above copyright notice and the following two paragraphs appear in - * all copies of this software. - * - * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY - * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES - * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN - * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY - * OF SUCH DAMAGE. - * - * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, - * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY - * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS - * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION - * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. - * - *) - -(***************************************************************) -(**** This module implements constraint indexing ***************) -(***************************************************************) -module H = Hashtbl -module F = Format -module BS = BNstats -module Co = Constants -module C = FixConstraint -module Misc = FixMisc -module IM = Misc.IntMap -module IS = Misc.IntSet -module SM = Ast.Symbol.SMap -module SS = Ast.Symbol.SSet -module P = Ast.Predicate - -open Misc.Ops - -let mydebug = false - -(* TODO: Describe the SCC ordering scheme! *) - -(***********************************************************************) -(***************** Index Data Structures and Accessors *****************) -(***********************************************************************) - -type rank = { - id : C.id - ; scc : int (* SCC number with ALL dependencies *) - ; iscc : int (* SCC number without CUT dependencies *) - ; simpl : bool (* Is the RHS simple ? *) - ; cut : bool (* Is the RHS a CUT-VAR *) - ; tag : C.tag; -} - -let string_of_tag t = - Printf.sprintf "[%s]" (Misc.map_to_string string_of_int t) - -let pprint_rank ppf r = - Format.fprintf ppf "id=%d, scc=%d, iscc=%d, cut=%b, tag=%a" - r.id r.scc r.iscc r.cut C.print_tag r.tag - -module WH = - Heaps.Functional (struct - type t = int * rank - let compare (ts,r) (ts',r') = - if r.scc <> r'.scc then compare r.scc r'.scc else - if ts <> ts' then - (compare ts ts') else - if r.iscc <> r'.iscc then compare r.iscc r'.iscc else - if !Constants.ptag && r.tag <> r'.tag then compare r.tag r'.tag else - compare r.simpl r'.simpl - end) - -type wkl = WH.t - -type t = - { cnst : FixConstraint.t IM.t (* id -> refinement_constraint *) - ; rnkm : rank IM.t (* id -> dependency rank *) - ; depm : C.id list IM.t (* id -> successor ids *) - ; pend : (C.id, unit) H.t (* id -> is in wkl ? *) - ; rts : IS.t (* {rank} members are "root" sccs *) - ; ds : C.dep list (* add/del dep list *) - ; rdeps : (int * int) list (* real dependencies *) - ; kuts : Ast.Symbol.t list (* CUT KVars *) - } - -let get_ref_rank me c = - Misc.do_catch "ERROR: Cindex.get_ref_rank" (IM.find (C.id_of_t c)) me.rnkm - -let get_ref_constraint me i = - Misc.do_catch "ERROR: Cindex.get_ref_constraint" (IM.find i) me.cnst - -(***********************************************************************) -(******************** Building Real Dependencies ***********************) -(***********************************************************************) - -let refa_ko = function C.Kvar (_,k) -> Some k | _ -> None - -let reft_ks = function (_,_,ras) -> Misc.map_partial refa_ko ras - -let lhs_ks c = - c |> C.lhs_of_t - |> reft_ks - |> SM.fold (fun _ (r:C.reft) l -> (reft_ks r) ++ l) (C.env_of_t c) - -let rhs_ks c = - c |> C.rhs_of_t |> reft_ks - -let make_kread_map cm = - cm |> IM.to_list - |> Misc.flap (fun (id, c) -> lhs_ks c |>: (fun k -> (k, id))) - |> SM.of_alist -(* >> SM.iter (fun k ids -> Co.bprintf mydebug "ReadIn %a := %a\n" Ast.Symbol.print k Misc.pprint_pretty_ints ids) - *) - -let make_deps cm = - let km = make_kread_map cm in - cm |> IM.to_list - |> Misc.flap (fun (id, c) -> rhs_ks c |> Misc.flap (fun k -> SM.finds k km |>: (fun id' -> (id, id')))) - |> Misc.pad_fst IM.of_alist -(* >> (fst <+> IM.iter (fun i js -> Co.bprintf mydebug "DepsOf (id = %d) = @[%a@]\n" i Misc.pprint_pretty_ints js)) -*) - -(* IM.fold begin fun id c acc -> - List.fold_left begin fun (dm, deps) k -> - let rd_ids = SM.finds k km in - let deps' = List.map (fun rd_id -> (id, rd_id)) rd_ids in - (IM.adds id rd_ids dm, (deps' ++ deps)) - end acc (rhs_ks c) - end cm (IM.empty, []) - *) - -(***********************************************************************) -(************* Adjusting Dependencies with Provided Tag-Deps ***********) -(***********************************************************************) - -let delete_deps cm dds = - let delf = C.matches_deps dds in - let tagf = fun x -> IM.find x cm |> C.tag_of_t in - List.filter (not <.> delf <.> Misc.map_pair tagf) - -let add_deps cm ads ijs = - let tt = H.create 37 in - let _ = IM.iter (fun id c -> H.add tt (C.tag_of_t c) id) cm in - ads |> Misc.map C.tags_of_dep - |> Misc.map (Misc.map_pair (H.find_all tt)) - |> Misc.flap (Misc.uncurry Misc.cross_product) - |> (++) ijs - -let adjust_deps cm ds = - let ads, dds = List.partition C.pol_of_dep ds in - !Constants.adjdeps (add_deps cm ads <.> delete_deps cm dds) - -(***********************************************************************) -(**************************** Dependency SCCs **************************) -(***********************************************************************) - -let string_of_ints is = is |> List.map string_of_int |> String.concat ", " - -let print_rank_groups f rs = - rs |> Misc.kgroupby f - |> List.sort compare - |> List.iter begin fun (g, rs) -> - Format.printf "Group=%s size=%d ids=%s\n" - g (List.length rs) (string_of_ints (List.map (fun r -> r.id) rs)) - end - -let string_of_cid cm id = - try - IM.find id cm - |> C.tag_of_t - |> Misc.fsprintf C.print_tag - |> Printf.sprintf "%d: %s" id - with _ -> assertf "string_of_cid: impossible" - -let make_rankm cm ranks iranks = - let rm = IM.of_list ranks in - let irm = IM.of_list iranks in - IM.domain cm - |>: begin fun id -> - let c = IM.find id cm in - let r = IM.find id rm in - let (ir, cut) = IM.find id irm in - id, { id = id; scc = r; iscc = ir; cut = cut; tag = C.tag_of_t c - ; simpl = (not !Co.psimple) || (C.is_simple c) } - end - |> IM.of_list - (* >> (IM.range <+> print_rank_groups (fun r -> Printf.sprintf "(%d/%d)" r.scc r.iscc )) *) - -(* returns a predicate which is true of ids whose RHS kvar is a kut-var *) -let is_cut_cst cm kuts = - let id_cstr = fun i -> IM.find i cm in - let is_cut_kvar = let ks = SS.of_list kuts in - fun k -> SS.mem k ks - in List.exists is_cut_kvar <.> List.map snd <.> C.kvars_of_reft <.> C.rhs_of_t <.> id_cstr - -let inner_ranks cm deps irs = function - | [] -> (* if no kuts specified, use dummys *) - irs |>: (fun (i, r) -> (i, (r, false))) - | kuts -> (* else, redo the SCC computation without cut-dependencies *) - let is_eq_rank = let rm = IM.of_list irs in fun i j -> (IM.find i rm = IM.find j rm) in - let is_cut_id = is_cut_cst cm kuts in - let is_cut_dep = fun (i, j) -> is_cut_id i && is_eq_rank i j in - deps |> List.filter (not <.> is_cut_dep) - |> Fcommon.scc_rank "inner" (string_of_cid cm) (IM.domain cm) - |>: (fun (i, ir) -> (i, (ir, is_cut_id i))) - -let make_ranks cm deps kuts = - let ranks = Fcommon.scc_rank "constraint" (string_of_cid cm) (IM.domain cm) deps in - let iranks = inner_ranks cm deps ranks kuts in - make_rankm cm ranks iranks - -let make_roots rankm ijs = - let sccs = rankm |> IM.to_list |> Misc.map (fun (_,r) -> r.scc) in - let sccm = List.fold_left (fun is scc -> IS.add scc is) IS.empty sccs in - List.fold_left begin fun sccm (i,j) -> - let ir = (IM.find i rankm).scc in - let jr = (IM.find j rankm).scc in - if ir <> jr then IS.remove jr sccm else sccm - end sccm ijs - - -(* A constraint c is non-live if its rhs is a k variable that is not - * (transitively) read. - * roots := { c | (rhs_of_t c) has a concrete predicate } - * lives := Pre*(roots) where Pre* is refl-trans-clos of the depends-on relation *) - -let make_lives cm real_deps = - let dm = real_deps |> List.rev_map Misc.swap |> IM.of_alist in - let js = cm |> IM.filter (fun _ -> C.is_conc_rhs) |> IM.domain |> IS.of_list in - (js, IS.empty) - |> Misc.fixpoint begin fun (js, vm) -> - let vm = IS.fold (fun j vm -> IS.add j vm) js vm in - let js = IS.fold begin fun j js -> - IM.finds j dm - |> List.filter (fun j -> not (IS.mem j vm)) - |> IS.of_list - |> IS.union js - end js IS.empty - in ((js, vm), not (IS.is_empty js)) - end - |> (fst <+> snd) - >> (IS.cardinal <+> Co.bprintf mydebug "#Live Constraints: %d \n") - -let create_raw kuts ds cm dm real_deps = - let deps = adjust_deps cm ds real_deps in - let rnkm = make_ranks cm deps kuts in - { cnst = cm; ds = ds; kuts = kuts; rdeps = real_deps; rnkm = rnkm - ; depm = dm; rts = make_roots rnkm deps ; pend = H.create 17} - -(***********************************************************************) -(**************************** API **************************************) -(***********************************************************************) - -(* API *) -let print ppf me = - List.iter (Format.fprintf ppf "@[%a@] \n" C.print_dep) me.ds; - IM.iter (fun _ c -> Format.fprintf ppf "@[%a@] \n" (C.print_t None) c) me.cnst - -let save fname me = - Misc.with_out_file fname begin fun oc -> - let ppf = F.formatter_of_out_channel oc in - F.fprintf ppf "//Sliced Constraints@."; - F.fprintf ppf "@[%a@] \n" print me - end - -(* The "adjusted" dependencies are used to create the SCC ranks ONLY. - * For soundness, the "real" dependencies must be used to push - * "successors" into the worklist. *) - -(* API *) -let create kuts ds cs = - let cm = cs |>: (Misc.pad_fst C.id_of_t) |> IM.of_list in - let dm, real_deps = make_deps cm in - create_raw kuts ds cm dm real_deps - -(* API *) -let slice me = - let lives = BS.time "make_lives" (make_lives me.cnst) me.rdeps in - let cm = me.cnst - |> IM.filter (fun i _ -> IS.mem i lives) in - let dm = me.depm - |> IM.filter (fun i _ -> IS.mem i lives) - |> IM.map (List.filter (fun j -> IS.mem j lives)) in - let rdeps = me.rdeps - |> Misc.filter (fun (i,j) -> IS.mem i lives && IS.mem j lives) in - (BS.time "create_raw" (create_raw me.kuts me.ds cm dm) rdeps) - >> (fun z -> if !Co.save_slice then save (Co.get_save_file ()) z) - -(* -let slice me = - let lives = BS.time "make_lives" (make_lives me.cnst) me.rdeps in - let cm = BS.time "slice-filter-1" (IM.filter (fun i _ -> IS.mem i lives)) me.cnst in - let dm0 = me.depm in - let dm1 = BS.time "slice-filter-2" (IM.filter (fun i _ -> IS.mem i lives)) dm0 in - let dm2 = BS.time "slice-filter-2" (IM.map (List.filter (fun j -> IS.mem j lives))) dm1 in - let rdeps = BS.time "slice-filter-4" (Misc.filter (fun (i,j) -> IS.mem i lives && IS.mem j lives)) me.rdeps in - let rv = (BS.time "create_raw" (create_raw me.kuts me.ds cm dm2) rdeps) in - let _ = if !Co.save_slice then BS.time "save slice" (save (Co.get_save_file ())) rv in - rv - -*) - - -(* API *) -let slice_wf me ws = - let ks = me.cnst - |> IM.range - |> Misc.flap C.kvars_of_t - |> Misc.map snd - |> SS.of_list - >> (SS.cardinal <+> Co.bprintf mydebug "#Live KVars: %d \n") - in - Misc.filter (C.reft_of_wf <+> C.kvars_of_reft <+> List.exists (fun (_,k) -> SS.mem k ks)) ws - >> (List.length <+> Co.bprintf mydebug "#Live WF: %d \n") - -let pp_cstr_id ppf c = F.fprintf ppf "%d" (C.id_of_t c) -let pp_cstr_ids ppf cs = F.fprintf ppf "@[%a@.@]" (Misc.pprint_many false "," pp_cstr_id) cs - -(* API *) -let deps me c = - (try IM.find (C.id_of_t c) me.depm with Not_found -> []) - |> List.map (get_ref_constraint me) - (* >> (List.map C.id_of_t <+> Co.logPrintf "Deps %d = [%a]\n" (C.id_of_t c) Misc.pprint_pretty_ints) *) - -(* API *) -let to_list me = IM.range me.cnst - -(* -(* API *) -let to_live_list me = - me.cnst |> IM.to_list - |> Misc.map_partial (fun (i,c) -> if IS.mem i me.livs then Some c else None) - -*) - -let sort_iter_ref_constraints me f = - me.rnkm |> IM.to_list - |> List.sort (fun (_,r) (_,r') -> compare r.tag r'.tag) - |> List.iter (fun (id,_) -> f (IM.find id me.cnst)) - -(* API *) -let wpush = - let timestamp = ref 0 in - fun me w cs -> - incr timestamp; - List.fold_left begin fun w c -> - let id = C.id_of_t c in - if Hashtbl.mem me.pend id then w else begin - Co.cprintf Co.ol_solve "Pushing %d at %d \n" id !timestamp; - Hashtbl.replace me.pend id (); - WH.add (!timestamp, get_ref_rank me c) w - end - end w cs - -let wstring w = - WH.fold (fun (_,r) acc -> r.id :: acc) w [] - |> List.sort compare - |> Misc.map_to_string string_of_int - -(* API *) -let wpop me w = - try - let _, r = WH.maximum w in - let _ = Hashtbl.remove me.pend r.id in - let c = get_ref_constraint me r.id in - let _ = Co.cprintf Co.ol_solve "popping (%a) " pprint_rank r in - let _ = Co.cprintf Co.ol_solve "from wkl = %s \n" (wstring w) in - (Some c, WH.remove w) - with Heaps.EmptyHeap -> (None, w) - -let roots me = - IM.fold begin fun id r sccm -> - (* if not (IM.mem r.scc me.rts) then sccm else *) - let rs = try IM.find r.scc sccm with Not_found -> [] in - IM.add r.scc (r::rs) sccm - end me.rnkm IM.empty - |> IM.map (List.hd <.> List.sort compare) - |> IM.to_list - |> Misc.map (fun (_,r) -> get_ref_constraint me r.id) - -(* API *) -let winit me = - roots me |> wpush me WH.empty - - - -(***************************************************************) -(*********** A Operations for Constraint Cones *****************) -(***************************************************************) - -let rec cone_height = function - | Ast.Cone.Empty -> - 0 - | Ast.Cone.Cone xcs -> - xcs |> List.map (snd <+> cone_height <+> (+) 1) |> Misc.list_max 0 - -let rec cone_size = function - | Ast.Cone.Empty -> - 0 - | Ast.Cone.Cone xcs -> - let ns = List.map (snd <+> cone_size) xcs in - List.fold_left (+) (List.length ns) ns - -let cone (cm, dm) = - let rec go seen cid = - if IS.mem cid seen then Ast.Cone.Empty else - let seen' = IS.add cid seen in - match IM.finds cid dm with - | [] -> Ast.Cone.Empty - | cids' -> Ast.Cone.Cone (List.map (Misc.pad_snd (go seen')) cids') - in begin fun id -> - (Ast.Cone.Cone [(id, go IS.empty id)]) - |> (Ast.Cone.map (fun i -> C.tag_of_t <| IM.safeFind i cm "Cindex.cone")) - >> (fun c -> Format.printf "CONE: %d size=%d height=%d" id (cone_size c) (cone_height c)) - end - -let data_sliced_deps cs = - let cs = FixSimplify.WeakFixpoint.simplify_ts cs in - let cm = cs |>: Misc.pad_fst C.id_of_t |> IM.of_list in - let dm = make_deps cm |> snd |>: Misc.swap |> IM.of_alist in - (cm, dm) - -(* API *) -let data_cones cs = cs |> data_sliced_deps |> cone diff --git a/external/fixpoint/cindex.mli b/external/fixpoint/cindex.mli deleted file mode 100644 --- a/external/fixpoint/cindex.mli +++ /dev/null @@ -1,54 +0,0 @@ -(* - * Copyright © 2009 The Regents of the University of California. All rights reserved. - * - * Permission is hereby granted, without written agreement and without - * license or royalty fees, to use, copy, modify, and distribute this - * software and its documentation for any purpose, provided that the - * above copyright notice and the following two paragraphs appear in - * all copies of this software. - * - * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY - * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES - * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN - * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY - * OF SUCH DAMAGE. - * - * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, - * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY - * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS - * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION - * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. - * - *) - -(***************************************************************) -(**** This module implements constraint indexing ***************) -(***************************************************************) - -type t -type wkl - -(** indexing and dependencies *) -val to_list : t -> FixConstraint.t list - -(* val to_live_list : t -> FixConstraint.t list *) -val create : Ast.Symbol.t list -> FixConstraint.dep list -> FixConstraint.t list -> t -val deps : t -> FixConstraint.t -> FixConstraint.t list -val slice : t -> t -val slice_wf : t -> FixConstraint.wf list -> FixConstraint.wf list - -(** worklist manipulation *) -val wpush : t -> wkl -> FixConstraint.t list -> wkl -val wpop : t -> wkl -> FixConstraint.t option * wkl -val winit : t -> wkl - -(** printing *) -val print : Format.formatter -> t -> unit - - -(***************************************************************) -(*********** Some Operations for Constraint Cones **************) -(***************************************************************) - -val data_cones: FixConstraint.t list -> FixConstraint.id -> FixConstraint.tag Ast.Cone.t - diff --git a/external/fixpoint/counterexample.ml b/external/fixpoint/counterexample.ml deleted file mode 100644 --- a/external/fixpoint/counterexample.ml +++ /dev/null @@ -1,323 +0,0 @@ -(* - * Copyright © 2009-12 The Regents of the University of California. All rights reserved. - * - * Permission is hereby granted, without written agreement and without - * license or royalty fees, to use, copy, modify, and distribute this - * software and its documentation for any purpose, provided that the - * above copyright notice and the following two paragraphs appear in - * all copies of this software. - * - * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY - * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES - * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN - * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY - * OF SUCH DAMAGE. - * - * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, - * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY - * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS - * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION - * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. - * - *) - -(***************************************************************) -(* Counterexample Generation (cf. Lahiri-Vanegue, VMCAI 2011) **) -(***************************************************************) - -module F = Format -module BS = BNstats -module C = FixConstraint - -module Misc = FixMisc -module IM = Misc.IntMap -module IS = Misc.IntSet - -module A = Ast -module Sy = A.Symbol -module SM = Sy.SMap -module SS = Sy.SSet -module P = A.Predicate -module Su = A.Subst -module Q = Qualifier - -open Misc.Ops - -let mydebug = false - -(***************************************************************************) -(************** Type Aliases ***********************************************) -(***************************************************************************) - -type step = int -type kvar = Sy.t -type fact = Abs of kvar * Qualifier.t | Conc of C.id -type cause = step * C.id * ((Sy.t * fact) list) - -(* [k |-> [(i0, [q_i0_1...]),...]] - * where q_i0_1... are killed at timestep i0 for kvar k sorted by step *) -type lifespan = (step * Q.t list) list SM.t - -(* [id |-> i0,...] - * where the constraint id is selected at steps i0... by solver *) -type ctrace = step list IM.t - -(* [((x1,k1,q1), c1);...;((xn,kn,qn),cn)] - * where each k_i+1, q_i+1, c_i+1 is the "cause" for why k_i, q_i is killed *) -(* type cex = (Sy.t * fact * C.id) list *) -type cex = Cause of Sy.t * fact * C.id * cex list - -(****************************************************************************) -(******************** Printing Counterexamples ******************************) -(****************************************************************************) - -let print_fact ppf = function - | Abs (k, q) -> F.fprintf ppf "(%a/%a)" Sy.print k Q.print_args q - | Conc i -> F.fprintf ppf "(id %d)" i - -let print_step ppf (x, f, cid) = - F.fprintf ppf "%a: %a @@ %d" Sy.print x print_fact f cid - -(* -let print_cex = Misc.pprint_many_box true "" "---> " "" print_step -*) - -let rec print_cex spaces ppf (Cause (x, f, cid, cs)) = - F.fprintf ppf "%s `-> %a\n%a" - (String.concat "" (Misc.clone " " spaces)) - print_step (x, f, cid) - (Misc.pprint_many false "\n\n" (print_cex (spaces + 4))) cs - -let print_cex = print_cex 0 - -let print_fact_causes n ppf (f, xfs) = - F.fprintf ppf "fact %a killed at %d by: %a \n" - print_fact f - n - (Misc.pprint_many_brackets false (Misc.pprint_tuple Sy.print print_fact)) xfs - -(****************************************************************************) -(******************** Instance Type *****************************************) -(****************************************************************************) - -let compare_fact f1 f2 = - compare (Misc.fsprintf print_fact f1) (Misc.fsprintf print_fact f2) - -module FactMap = Misc.EMap (struct - type t = fact - let compare = compare_fact - let print = print_fact -end) - -type t = { tpc : ProverArch.prover - ; n : int (* number of solver iters *) - ; s : FixConstraint.soln - ; cm : FixConstraint.t IM.t - ; ctrace : ctrace - ; lifespan : lifespan (* builds soln at n *) - ; fsm : step FactMap.t (* fact |-> step at which killed *) - ; scm : int IM.t (* step |-> constr at step *) - } - -let scm_of_ctrace ctrace = - ctrace - |> IM.to_list - |> Misc.flap (fun (cid, is) -> List.map (fun i -> (i, cid)) is) - |> Misc.fsort fst - |> IM.of_list - -let fsm_of_lifespan lifetime = - SM.fold begin fun k sqs fsm -> - List.fold_left begin fun fsm (step, qs) -> - List.fold_left begin fun fsm q -> - FactMap.add (Abs (k, q)) step fsm - end fsm qs - end fsm sqs - end lifetime FactMap.empty - -(************************************************************************) -(*********** Helpers to Reconstitute Solutions and Candidates ***********) -(************************************************************************) - -let constrOfId me cid = - IM.safeFind cid me.cm "Cex.constrOfId" - -let solutionAt me n k = - SM.safeFind k me.lifespan "solutionAt: bad kvar" - |> List.filter (fun (m,_) -> n <= m) - |> Misc.flap snd - |> Misc.map Q.pred_of_t - |> (++) (me.s k) - -let isUnsatAt me c n = - let s = solutionAt me n in - let rhsp = A.pAnd <| C.preds_of_reft s (C.rhs_of_t c) in - let query = A.pAnd <| (A.pNot rhsp) :: (C.preds_of_lhs s c) in - not <| me.tpc#is_contra (C.senv_of_t c) query - -let prevStep_conc me c : int = - let _ = asserts (C.is_conc_rhs c) in - let no = Misc.find_first_true (isUnsatAt me c) 0 me.n in - Misc.maybe_apply (+) no (-1) - -let prevStep_abs me cid n : int = - let rec go n = function - | m1 :: _ when m1 = n -> (-1) - | m1 :: (m2 :: _ as rest) -> if n = m2 then m1 else go n rest - | _ -> assertf "prevStep with bad ctrace" - in go n (IM.safeFind cid me.ctrace "prevStep: bad cid") - -let prevStep me c n = - if C.is_conc_rhs c then - prevStep_conc me c - else - prevStep_abs me (C.id_of_t c) n - -let killstep_of_fact me f = - FactMap.safeFind f me.fsm "Cex.killstep_of_fact" - -let delta me c n k : fact list = - let _n = prevStep me c n in - SM.safeFind k me.lifespan "delta: bad kvar" - |> List.filter (fun (m,_) -> _n <= m && m < n) - |> Misc.flap snd - |> Misc.map (fun q -> Abs (k, q)) - -(************************************************************************) -(************************************************************************) -(************************************************************************) - -let killerCands me c n : (int * (((Sy.t * fact) * A.pred)) list) list = - foreach (C.kbindings_of_lhs c) begin fun (x, (vv, t, ras)) -> - foreach ras begin function C.Kvar (su, k) -> - foreach (delta me c n k) begin function (Abs (_, q) as f) -> - let su' = Su.extend su (vv, A.eVar x) in - let p' = A.substs_pred (Q.pred_of_t q) su' in - (x, f), p' - end - end |> Misc.flatten - end |> Misc.flatten - |> Misc.kgroupby (fst <+> snd <+> killstep_of_fact me) - -(************************************************************************) -(******************** Lazy Explanations *********************************) -(************************************************************************) - -let killedPred me c f = - match f, C.rhs_of_t c with - | Abs (k, q), (_,_, [C.Kvar (su, k')]) - when k = k' - -> A.substs_pred (Q.pred_of_t q) su - | Conc cid, (_,_,[C.Conc p]) - when C.id_of_t c = cid - -> p - | _ -> failwith "Counterexample.killed" - -let getKillStep me c bgp iks = - let iks = Misc.fsort fst iks in - let ps = iks |>: (snd <+> List.map snd <+> A.pAnd) in - match me.tpc#unsat_suffix (C.senv_of_t c) bgp ps with - | Some j when 0 <= j && j < List.length iks - -> List.nth iks j - | io -> let _ = F.printf - "getKillStep failure: (cid = %d) (|iks| = %d) (io = %a)\n bgp = %a\nps = %a\n" - (C.id_of_t c) - (List.length iks) - (Misc.pprint_maybe Misc.pprint_int) io - P.print bgp - (Misc.pprint_many_brackets true P.print) ps - in assertf "getKillStep" - -let killinfo me = function - | Conc cid -> me.n, cid - | f -> let n = killstep_of_fact me f in - (n, IM.safeFind n me.scm "Cex.killinfo") - -(* {{{ ORIGINAL: simply use unsat core. - -let is_bot_killer = function - | (f, p) when P.is_contra p -> Some f - | _ -> None - - -let getKillers_cands me c bgp cands = - match cands, Misc.exists_maybe is_bot_killer cands with - | [], _ -> - None - | _, Some g -> - Some g - | _, _ -> - TP.unsat_core me.tpc (C.senv_of_t c) bgp cands - |> Misc.do_catch "ERROR: empty unsat core" List.hd - |> some - -let getKillers_fact (me: t) (f: fact) = - let n, cid = killinfo me f in - let c = IM.safeFind cid me.cm "Cex.getKillers 3" in - match killerCands me c n with [] -> (cid, None) | iks -> - let bgps = C.preds_of_lhs (solutionAt me n) c - |> (++) [A.pNot (killedPred me c f)] in - let (j, cands) = getKillStep me c (A.pAnd bgps) iks in - let bgps' = iks - |> List.filter (fun (i,_) -> j < i) - |> Misc.flap (snd <+> List.map snd) in - (cid, getKillers_cands me c (A.pAnd (bgps ++ bgps')) cands) - -let maxCubeSize = 1 - -let underApproxCubes me (p:pred) (q:pred) (rs: ('a * pred) list) : 'a option = - Misc.exists_maybe begin fun (f, fp) -> - if SAT (p /\ fp) && UNSAT (p /\ fp /\ q) - then Some f - else None - end rs - -}}} *) - -let getKillers_cands me c p q rs = - let env = C.senv_of_t c in - let contra = fun p -> me.tpc#is_contra env p in - Misc.map_partial begin fun (f, fp) -> - if contra (A.pAnd [p; fp; q]) && not (contra (A.pAnd [p; fp])) - then Some f - else None - end rs - -let getKillers_fact (me: t) (f: fact) = - let n, cid = killinfo me f in - let c = IM.safeFind cid me.cm "Cex.getKillers 3" in - match killerCands me c n with [] -> (cid, []) | iks -> - let bgps = C.preds_of_lhs (solutionAt me n) c in - let killedp = A.pNot (killedPred me c f) in - let (j, cands) = getKillStep me c (A.pAnd bgps) iks in - let bgps' = iks - |> List.filter (fun (i,_) -> j < i) - |> Misc.flap (snd <+> List.map snd) in - (cid, getKillers_cands me c (A.pAnd (bgps ++ bgps')) killedp cands) - -let rec explain me f = - let cid, xfs = getKillers_fact me f in - List.map (fun (x',f') -> Cause (x', f', cid, explain me f')) xfs - -(********************************************************************) -(*********************** API ****************************************) -(********************************************************************) - -(* API *) -let create tpc s cs ctrace lifespan = - let scm = scm_of_ctrace ctrace in - { tpc = tpc - ; s = s - ; cm = cs |>: Misc.pad_fst C.id_of_t |> IM.of_list - ; n = 1 + Misc.list_max 0 (IM.domain scm) - ; ctrace = IM.map Misc.sort_and_compact ctrace - ; lifespan = lifespan - ; fsm = fsm_of_lifespan lifespan - ; scm = scm - } - -(* API *) -let explain me c = - let cid0 = C.id_of_t c in - let f0 = Conc cid0 in - Cause (Sy.of_string "ERROR", f0, cid0, explain me f0) diff --git a/external/fixpoint/counterexample.mli b/external/fixpoint/counterexample.mli deleted file mode 100644 --- a/external/fixpoint/counterexample.mli +++ /dev/null @@ -1,51 +0,0 @@ -(* - * Copyright © 2009-12 The Regents of the University of California. All rights reserved. - * - * Permission is hereby granted, without written agreement and without - * license or royalty fees, to use, copy, modify, and distribute this - * software and its documentation for any purpose, provided that the - * above copyright notice and the following two paragraphs appear in - * all copies of this software. - * - * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY - * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES - * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN - * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY - * OF SUCH DAMAGE. - * - * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, - * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY - * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS - * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION - * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. - * - *) - -(***************************************************************) -(* Counterexample Generation (cf. Lahiri-Vanegue, VMCAI 2011) **) -(***************************************************************) - -type t - -type kvar = Ast.Symbol.t -type fact = Abs of kvar * Qualifier.t | Conc of FixConstraint.id -type step = int - -(* [k |-> [(i0, [q_i0_1...]),...]] - * where q_i0_1... are killed at timestep i0 for kvar k sorted by step *) -type lifespan = (step * Qualifier.t list) list Ast.Symbol.SMap.t - -(* [cid |-> i0,...] cid is selected at steps i0... by solver *) -type ctrace = step list FixMisc.IntMap.t - -type cex - -val create : ProverArch.prover (* tp context *) - -> FixConstraint.soln (* assumes *) - -> FixConstraint.t list (* all constraints *) - -> ctrace - -> lifespan - -> t - -val explain : t -> FixConstraint.t -> cex -val print_cex : Format.formatter -> cex -> unit diff --git a/external/fixpoint/fix.ml b/external/fixpoint/fix.ml deleted file mode 100644 --- a/external/fixpoint/fix.ml +++ /dev/null @@ -1,36 +0,0 @@ -(* - * Copyright © 2009 The Regents of the University of California. All rights reserved. - * - * Permission is hereby granted, without written agreement and without - * license or royalty fees, to use, copy, modify, and distribute this - * software and its documentation for any purpose, provided that the - * above copyright notice and the following two paragraphs appear in - * all copies of this software. - * - * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY - * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES - * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN - * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY - * OF SUCH DAMAGE. - * - * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, - * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY - * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS - * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION - * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. - * - *) - -module Ast = Ast -module Symbol = Ast.Symbol -module Constant = Ast.Constant - -module Sort = Ast.Sort -module Predicate = Ast.Sort -module Expression = Ast.Expression - -module FixConstraint = FixConstraint -module Solve = Solve - - - diff --git a/external/fixpoint/fixConfig.ml b/external/fixpoint/fixConfig.ml deleted file mode 100644 --- a/external/fixpoint/fixConfig.ml +++ /dev/null @@ -1,162 +0,0 @@ -(* - * Copyright © 2009 The Regents of the University of California. All rights reserved. - * - * Permission is hereby granted, without written agreement and without - * license or royalty fees, to use, copy, modify, and distribute this - * software and its documentation for any purpose, provided that the - * above copyright notice and the following two paragraphs appear in - * all copies of this software. - * - * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY - * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES - * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN - * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY - * OF SUCH DAMAGE. - * - * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, - * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY - * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS - * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION - * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. - *) - -module Sy = Ast.Symbol -module SM = Sy.SMap -module Q = Qualifier -module C = FixConstraint -module So = Ast.Sort -module Co = Constants - -module Misc = FixMisc open Misc.Ops - -exception UnmappedKvar of Ast.Symbol.t - -let mydebug = false - -type qbind = Q.t list - -type solbind = Ast.Symbol.t * ((Ast.Symbol.t * (Ast.expr list)) list) - -type deft = Srt of Ast.Sort.t - | Axm of Ast.pred - | Cst of FixConstraint.t - | Wfc of FixConstraint.wf - | Con of Ast.Symbol.t * Ast.Sort.t - | Sol of solbind - (* | Sol of Ast.Symbol.t * (Ast.pred * (Ast.Symbol.t * Ast.Subst.t)) list *) - | Qul of Q.t - | Dep of FixConstraint.dep - | Kut of Ast.Symbol.t - | IBind of int * Ast.Symbol.t * FixConstraint.reft - -type 'bind cfg = { - a : int (* Tag arity *) - ; ts : Ast.Sort.t list (* New sorts, now = [] *) - ; ps : Ast.pred list (* New axioms, now = [] *) - ; cs : FixConstraint.t list (* Implication Constraints *) - ; ws : FixConstraint.wf list (* Well-formedness Constraints *) - ; ds : FixConstraint.dep list (* Constraint Dependencies *) - ; qs : Q.t list (* Qualifiers *) - ; kuts : Ast.Symbol.t list (* "Cut"-Kvars, which break cycles *) - ; bm : 'bind SM.t (* Initial Sol Bindings *) - ; uops : Ast.Sort.t Ast.Symbol.SMap.t (* Globals: measures + distinct consts) *) - ; cons : Ast.Symbol.t list (* Distinct Constants, defined in uops *) - ; assm : FixConstraint.soln (* Seed Solution -- must be a fixpoint over constraints *) -} - -let get_arity = function - | [] -> Constants.bprintflush mydebug "WARNING: NO CONSTRAINTS!"; 0 - | c::_ -> c |> FixConstraint.tag_of_t |> fst |> List.length - -let sift_quals qs = - qs >> (fun _ -> Co.bprintflush mydebug "BEGIN: Q.normalize\n") - |> Q.normalize - (* >> (Format.printf "Normalized Quals: \n%a" (Misc.pprint_many true "\n" Q.print)) *) - >> (fun _ -> Co.bprintflush mydebug "DONE: Q.normalize\n") - |> Misc.map (Misc.pad_fst Q.name_of_t) - |> SM.of_list - -let extend f cfg = function - | Srt t -> {cfg with ts = t :: cfg.ts } - | Axm p -> {cfg with ps = p :: cfg.ps } - | Cst c -> {cfg with cs = c :: cfg.cs } - | Wfc w -> {cfg with ws = w :: cfg.ws } - | Dep d -> {cfg with ds = d :: cfg.ds } - | Kut k -> {cfg with kuts = k :: cfg.kuts } - | Qul q -> {cfg with qs = q :: cfg.qs } - | Sol (k, fess) -> {cfg with bm = SM.add k (List.map f fess) cfg.bm } - | Con (s,t) -> {cfg with cons = if So.is_func t then cfg.cons else s :: cfg.cons - ; uops = SM.add s t cfg.uops} - | IBind _ -> cfg - - -let empty = - { a = 0 - ; ts = [] - ; ps = [] - ; cs = [] - ; ws = [] - ; ds = [] - ; qs = [] - ; kuts = [] - ; bm = SM.empty - ; cons = [] - ; uops = SM.empty - ; assm = FixConstraint.empty_solution - } - -let fes2q qm (f, es) = - let q = SM.safeFind f qm "name2qual" in - q |> Q.all_params_of_t - |> List.map fst - |> Misc.flip (Misc.combine "FixConfig.fes2q") es - |> Q.inst q - -let normalize_defts ds = - let qs, ds' = Misc.either_partition begin function - | Qul q -> Left q - | d -> Right d - end ds in - let qm = sift_quals qs in - let ds'' = qm |> SM.range - |>: (fun q -> Qul q) - |> (++) ds' in - (qm, ds'') - -(* API *) -let create ds = - let qm, ds' = normalize_defts ds in - ds' |> List.fold_left (extend (fes2q qm)) empty - |> (fun cfg -> {cfg with a = get_arity cfg.cs}) - |> (fun cfg -> {cfg with ws = C.add_wf_ids cfg.ws}) - -(* API *) -let create_raw ts env ps a ds cs ws qs kuts assm = - { empty with - a = a - ; ts = ts - ; uops = env - ; ps = ps - ; ds = ds - ; cs = cs - ; ws = C.add_wf_ids ws - ; kuts = kuts - ; qs = Q.normalize qs - ; assm = assm - } - -module type SIMPLIFIER = sig - val simplify_ts: FixConstraint.t list -> FixConstraint.t list -end - - -(* type t = Ast.Qualifier.def list list cfg *) - -let print ppf me = - (* Print cs *) - Format.fprintf ppf "@[%a@] \n" (Misc.pprint_many true "\n" (C.print_t None)) me.cs; - (* Print ws *) - Format.fprintf ppf "@[%a@] \n" (Misc.pprint_many true "\n" (C.print_wf None)) me.ws; - (* Print qs *) - Format.fprintf ppf "@[%a@] \n" (Misc.pprint_many true "\n" Q.print) (Q.normalize me.qs) - diff --git a/external/fixpoint/fixConfig.mli b/external/fixpoint/fixConfig.mli deleted file mode 100644 --- a/external/fixpoint/fixConfig.mli +++ /dev/null @@ -1,54 +0,0 @@ -(* This module deals with top-level parsing of fq files and such *) - -(* -exception UnmappedKvar of Ast.Symbol.t -*) -type solbind = Ast.Symbol.t * ((Ast.Symbol.t * (Ast.expr list)) list) - -type deft = Srt of Ast.Sort.t - | Axm of Ast.pred - | Cst of FixConstraint.t - | Wfc of FixConstraint.wf - | Con of Ast.Symbol.t * Ast.Sort.t - | Sol of solbind - | Qul of Qualifier.t - | Dep of FixConstraint.dep - | Kut of Ast.Symbol.t - | IBind of int * Ast.Symbol.t * FixConstraint.reft - -type 'bind cfg = { - a : int (* Tag arity *) - ; ts : Ast.Sort.t list (* New sorts, now = [] *) - ; ps : Ast.pred list (* New axioms, now = [] *) - ; cs : FixConstraint.t list (* Implication Constraints *) - ; ws : FixConstraint.wf list (* Well-formedness Constraints *) - ; ds : FixConstraint.dep list (* Constraint Dependencies *) - ; qs : Qualifier.t list (* Qualifiers *) - ; kuts : Ast.Symbol.t list (* "Cut"-Kvars, which break cycles *) - ; bm : 'bind Ast.Symbol.SMap.t (* Initial Sol Bindings *) - ; uops : Ast.Sort.t Ast.Symbol.SMap.t (* Globals: measures + distinct consts) *) - ; cons : Ast.Symbol.t list (* Distinct Constants, defined in uops *) - ; assm : FixConstraint.soln (* Seed Solution -- must be a fixpoint over constraints *) -} - - - - -module type SIMPLIFIER = sig - val simplify_ts: FixConstraint.t list -> FixConstraint.t list -end - -val empty : 'a cfg -val create : deft list -> (Qualifier.t list) cfg -val print : Format.formatter -> 'a cfg -> unit -val create_raw: Ast.Sort.t list - -> Ast.Sort.t Ast.Symbol.SMap.t - -> Ast.pred list - -> int - -> FixConstraint.dep list - -> FixConstraint.t list - -> FixConstraint.wf list - -> Qualifier.t list - -> Ast.Symbol.t list - -> FixConstraint.soln - -> 'a cfg diff --git a/external/fixpoint/fixConstraint.ml b/external/fixpoint/fixConstraint.ml deleted file mode 100644 --- a/external/fixpoint/fixConstraint.ml +++ /dev/null @@ -1,559 +0,0 @@ -(* - * Copyright © 2009 The Regents of the University of California. All rights reserved. - * - * Permission is hereby granted, without written agreement and without - * license or royalty fees, to use, copy, modify, and distribute this - * software and its documentation for any purpose, provided that the - * above copyright notice and the following two paragraphs appear in - * all copies of this software. - * - * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY - * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES - * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN - * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY - * OF SUCH DAMAGE. - * - * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, - * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY - * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS - * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION - * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONSy. - * - *) - -(* This module implements basic datatypes and operations on constraints *) -module F = Format -module H = Hashtbl -module A = Ast -module E = A.Expression -module P = A.Predicate -module Sy = A.Symbol -module So = A.Sort -module SM = Sy.SMap -module BS = BNstats -module Su = Ast.Subst -module Co = Constants -module Misc = FixMisc -module MSM = Misc.StringMap - -open Misc.Ops - -type tag = int list * string -type id = int -type dep = Adp of tag * tag | Ddp of tag * tag | Ddp_s of tag | Ddp_t of tag - -type refa = Conc of A.pred | Kvar of Su.t * Sy.t -type reft = Sy.t * A.Sort.t * refa list (* { VV: t | [ra] } *) -type envt = reft SM.t -type senvt = So.t SM.t -type wf = envt * reft * (id option) * (Qualifier.t -> bool) -type t = { full : envt; - nontriv : envt; - guard : A.pred; - iguard : A.pred; - lhs : reft; - rhs : reft; - ido : id option; - tag : tag; } - -type soln = Ast.Symbol.t -> Ast.pred list - -exception BadConstraint of (id * tag * string) - - -(* -type soln = Ast.pred list Ast.Symbol.SMap.t -type soln = { read : Ast.Symbol.t -> Ast.pred list - ; kvars : Ast.Symbol.SSet.t } -*) - -let mydebug = false - -(***************************************************************) -(*********************** Getter/Setter *************************) -(***************************************************************) - -let vv_of_reft = fst3 -let sort_of_reft = snd3 -let ras_of_reft = thd3 -let shape_of_reft = fun (v, so, _) -> (v, so, []) - - -(* API *) -let env_of_t = fun t -> t.full -let grd_of_t = fun t -> t.guard -let lhs_of_t = fun t -> t.lhs -let rhs_of_t = fun t -> t.rhs -let tag_of_t = fun t -> t.tag -let ido_of_t = fun t -> t.ido -let id_of_t = fun t -> match t.ido with Some i -> i | _ -> assertf "C.id_of_t" -let vv_of_t = fun t -> fst3 t.lhs -let sort_of_t = fun t -> snd3 t.lhs -let senv_of_t = fun t -> SM.map snd3 t.full |> SM.add (vv_of_t t) (sort_of_t t) - -(* -let make_t = fun env p ((v,t,ras1) as r1) r2 io is -> - let p = A.simplify_pred p in - let po, kras = split_ras ras1 in - let ne, ps = non_trivial env in - let gps = match po with Some p' -> p' :: p :: ps | _ -> p :: ps in - { full = env - ; nontriv = ne - ; guard = p - ; iguard = A.pAnd gps - ; lhs = (v, t, kras) - ; rhs = r2 - ; ido = io - ; tag = is } -*) - -(* API *) -let make_wf = fun env r io -> (env, r, io, fun _ -> true) -let make_filtered_wf = fun env r io fltr -> (env, r, io, fltr) -let env_of_wf = fst4 -let reft_of_wf = snd4 -let id_of_wf = function (_,_,Some i,_) -> i | _ -> assertf "C.id_of_wf" -let filter_of_wf = fth4 - - -(*************************************************************) -(************************** Misc. ***************************) -(*************************************************************) - -let is_simple_refatom = function - | Kvar (s, _) -> Ast.Subst.is_empty s - | _ -> false - -let is_tauto_refatom = function - | Conc p -> P.is_tauto p - | _ -> false - -(* API *) -let is_tauto = rhs_of_t <+> ras_of_reft <+> List.for_all is_tauto_refatom - -(* API *) -let fresh_kvar = - let tick, _ = Misc.mk_int_factory () in - tick <+> string_of_int <+> (^) "k_" <+> Sy.of_string - -(* API *) -let kvars_of_reft (_, _, rs) = - Misc.map_partial begin function - | Kvar (subs, k) -> Some (subs,k) - | _ -> None - end rs - -let meet x (v1, t1, ra1s) (v2, t2, ra2s) = - asserts (v1=v2 && t1=t2) "ERROR: FixConstraint.meet x=%s (v1=%s, t1=%s) (v2=%s, t2=%s)" - (Sy.to_string x) (Sy.to_string v1) (A.Sort.to_string t1) (Sy.to_string v2) (A.Sort.to_string t2) ; - (v1, t1, Misc.sort_and_compact (ra1s ++ ra2s)) - -let env_of_bindings_ meetb xrs = - List.fold_left begin fun env (x, r) -> - let r = if meetb && SM.mem x env then meet x r (SM.find x env) else r in - SM.add x r env - end SM.empty xrs - -(* API *) -let env_of_bindings = env_of_bindings_ true -let env_of_ordered_bindings = env_of_bindings_ false - -(* -let env_of_bindings xrs = - List.fold_left begin fun env (x, r) -> - let r = if SM.mem x env then meet x r (SM.find x env) else r in - SM.add x r env - end SM.empty xrs -*) - -let bindings_of_env = SM.to_list - -(* let bindings_of_env env = - SM.fold (fun x y bs -> (x,y)::bs) env [] -*) - -let split_ras ras = - let cras, kras = List.partition (function (Conc _) -> true | _ -> false) ras in - cras |> Misc.map_partial (function Conc p -> Some p | _ -> None) - |> (function [] -> (None, kras) | ps -> (Some (A.pAnd ps), kras)) - - -let kbindings_of_lhs {nontriv = ne; lhs = (v, t, ras)} = - let xkss = SM.to_list ne in - let _, kras = split_ras ras in - (v, (v,t,kras)) :: xkss - -let map_env = SM.mapi -let lookup_env = Misc.flip SM.maybe_find -(* let lookup_env env x = try Some (SM.find x env) with Not_found -> None *) - - - -(* API *) -let is_simple {lhs = (_,_,ra1s); rhs = (_,_,ra2s)} = - List.for_all is_simple_refatom ra1s - && List.for_all is_simple_refatom ra2s - && !Co.simple - -let is_conc_refa = function Conc p -> not (P.is_tauto p) | _ -> false - -(* API *) -let kvars_of_t {nontriv = env; lhs = lhs; rhs = rhs} = - [lhs; rhs] - |> SM.fold (fun _ r acc -> r :: acc) env - |> Misc.flap kvars_of_reft - - - - -(*************************************************************) -(*********************** Logic Embedding *********************) -(*************************************************************) - -let canon_ras ras = - match split_ras ras with - | None, kras -> kras - | Some p, kras -> Conc p :: kras - -(* -let non_trivial env = - SM.fold begin fun x r sm -> match thd3 r with - | [] -> sm - | _::_ -> SM.add x r sm - end env SM.empty -*) - -let non_trivial env = - SM.fold begin fun x (v,t,ras) ((ne, ps) as acc) -> match ras with - | [] -> acc - | _ -> let po, kras = split_ras ras in - let ne' = match kras with [] -> ne | _ -> SM.add x (v,t,kras) ne in - let ps' = match po with None -> ps | Some p -> (P.subst p v (A.eVar x)) :: ps in - ne', ps' - end env (SM.empty, []) - -(* API *) -let make_t = fun env p r1 r2 io is -> - let p = A.simplify_pred p in - let ne, ps = non_trivial env in - { full = env - ; nontriv = ne - ; guard = p - ; iguard = A.pAnd (p::ps) - ; lhs = r1 - ; rhs = r2 - ; ido = io - ; tag = is } - - -(* API *) -let is_conc_refa = function - | Conc _ -> true - | _ -> false - -let soln_read s k = s k (* SM.find k s *) - -(* API *) -let preds_of_refa s = function - | Conc p -> [p] - | Kvar (su,k) -> soln_read s k |> List.map (Misc.flip A.substs_pred su) - -(* API *) -let preds_of_reft f (_,_,ras) = - Misc.flap (preds_of_refa f) ras - -(* API *) -let meet_solution s1 s2 = fun k -> s1 k ++ s2 k (* SM.extendWith (fun _ -> (++)) *) -let empty_solution = fun _ -> [] - -let apply_solution_refa f ra = - Conc (A.pAnd (preds_of_refa f ra)) - -(* API *) -let apply_solution f (v, t, ras) = - (v, t, List.map (apply_solution_refa f) ras) - -let preds_of_envt f env = - SM.fold - (fun x ((vv, t, ras) as r) ps -> - let vps = preds_of_reft f r in - let xps = List.map (fun p -> P.subst p vv (A.eVar x)) vps in - xps ++ ps) - env [] - -(* API *) -let wellformed_pred senv = - A.sortcheck_pred Theories.is_interp (Misc.flip SM.maybe_find senv) - -(* API *) -let preds_of_lhs_nofilter f c = - let envps = preds_of_envt f c.nontriv in - let r1ps = preds_of_reft f c.lhs in - (c.iguard :: envps) ++ r1ps - - -(* let preds_of_lhs f c = - let env = SM.add (fst3 c.lhs) c.lhs c.full in - let wfp p = wellformed_pred env p - >> (fun b -> if not b then F.eprintf "WARNING: Malformed Lhs Pred (%a)\n" P.print p) in - let ps = preds_of_lhs_nofilter f c in - let ps' = List.filter wfp ps in - if !Co.strictsortcheck && List.length ps != List.length ps' - then raise (BadConstraint (Misc.maybe c.ido, c.tag, "Malformed Lhs Pred")) - else ps -*) - -let pred_context senv p = - P.support p - |> List.filter (fun x -> SM.mem x senv) - |> List.map (fun x -> (x, SM.find x senv)) - - -let report_wellformed senv c p wf = - if not wf then - let msg = F.sprintf "WARNING: Malformed Lhs Pred (%s)\n" (P.to_string p) in - let _ = F.eprintf "%s" msg in - let _ = pred_context senv p - |> List.iter (fun (s,t) -> F.eprintf "@[%a :: %a@]@." Sy.print s So.print t) in - let _ = F.eprintf "@[%a@]@.@." P.print p in - if !Co.strictsortcheck then raise (BadConstraint (Misc.maybe c.ido, c.tag, msg)) - -(* API *) -let preds_of_lhs f c = - let senv = senv_of_t c in (* SM.add (fst3 c.lhs) c.lhs c.full in *) - preds_of_lhs_nofilter f c - |> Misc.flap A.conjuncts - |> List.filter (fun p -> wellformed_pred senv p >> report_wellformed senv c p) - -(* API *) -let vars_of_t f ({rhs = r2} as c) = - (preds_of_reft f r2) ++ (preds_of_lhs f c) - |> Misc.flap P.support - -(**************************************************************) -(********************** Pretty Printing ***********************) -(**************************************************************) - -let print_refineatom ppf = function - | Conc p -> F.fprintf ppf "%a" P.print p - | Kvar (su, k) -> F.fprintf ppf "%a%a" Sy.print k Su.print su - -(* -(* API *) -let print_ras so ppf = function - | [] -> F.fprintf ppf "true" - | ras -> begin match so with - | None -> - F.fprintf ppf "%a" (Misc.pprint_many_box false "" "; " "" print_refineatom) ras - | Some s -> let ps = Misc.flap (preds_of_refa s) ras in - (match ps with - | [] -> F.fprintf ppf "[]" - | _ -> F.fprintf ppf "%a" P.print (A.pAnd ps)) - end -*) - -(* API *) -let print_ras so ppf ras = match so with - | None -> - Misc.pprint_many_box false "[" "; " "]" print_refineatom ppf ras - | Some s -> - begin match Misc.flap (preds_of_refa s) ras with - | [] -> F.fprintf ppf "[]" - | ps -> F.fprintf ppf "[%a]" P.print (A.pAnd ps) - end - - -(* API *) -let print_reft_pred so ppf (v,t,ras) = - F.fprintf ppf "@[{%a:%a | %a}@]" - Sy.print v - Ast.Sort.print t - (print_ras so) ras - -(* -let print_reft_pred so ppf = function - | (v,_,[]) -> F.fprintf ppf "@[{%a | true }@]" Sy.print v - | (v,_,ras) -> F.fprintf ppf "@[{%a | @[%a@]}@]" Sy.print v (print_ras so) ras -*) - -(* API *) -let print_reft so ppf (v, t, ras) = - F.fprintf ppf "@[{%a : %a | %a}@]" - Sy.print v - Ast.Sort.print t - (print_ras so) ras - -(* API *) -let print_binding so ppf (x, r) = - F.fprintf ppf "@[%a:%a@]" Sy.print x (print_reft so) r - -(* API *) -let print_env so ppf env = - bindings_of_env env - |> F.fprintf ppf "@[%a@]" (Misc.pprint_many_brackets true (print_binding so)) - - -let pprint_id ppf = function - | Some id -> F.fprintf ppf "id %d" id - | None -> F.fprintf ppf "" - - -let string_of_intlist = (String.concat ";") <.> (List.map string_of_int) - -(* API *) -let print_tag ppf = function - | [],_ -> F.fprintf ppf "" - | is,s -> F.fprintf ppf "tag [%s] //%s" (string_of_intlist is) s - -(* API *) -let print_dep ppf = function - | Adp ((t,_), (t',_)) - -> F.fprintf ppf "add_dep: [%s] => [%s]" (string_of_intlist t) (string_of_intlist t') - | Ddp ((t,_), (t',_)) - -> F.fprintf ppf "del_dep: [%s] => [%s]" (string_of_intlist t) (string_of_intlist t') - | Ddp_s (t,_) - -> F.fprintf ppf "del_dep: [%s] => *" (string_of_intlist t) - | Ddp_t (t',_) - -> F.fprintf ppf "del_dep: * => [%s]" (string_of_intlist t') - -(* API *) -let print_wf so ppf (env, r, io, _) = - F.fprintf ppf "wf: env @[%a@] @\n reft %a @\n %a @\n" - (print_env so) env - (print_reft so) r - pprint_id io - -let print_t so ppf c = - let env, g = if !Co.print_nontriv then c.nontriv, c.iguard else c.full, c.guard in - F.fprintf ppf - "constraint:@. env @[%a@] @\n grd @[%a@] @\n lhs @[%a@] @\n rhs @[%a@] @\n %a %a @\n" - (print_env so) env - P.print g - (print_reft so) c.lhs - (print_reft so) c.rhs - pprint_id c.ido - print_tag c.tag - -(* API *) -let to_string = Misc.fsprintf (print_t None) -let refa_to_string = Misc.fsprintf print_refineatom -let reft_to_string = Misc.fsprintf (print_reft None) -let binding_to_string = Misc.fsprintf (print_binding None) - - - -let intersect_maps m1 m2 = SM.filter begin fun k elt -> - SM.mem k m2 && SM.find k m2 = elt -end m1 - -let intersect_wfs (e1, r1, id1, qf1) (e2, r2, id2, qf2) = - let _ = assert (r1 = r2) in - let env = intersect_maps e1 e2 in - (env, r1, id1, fun x -> (qf1 x && qf2 x)) - -let reduce_wfs wfs = - wfs - |> Misc.groupby reft_of_wf - |>: (fun wfs -> List.fold_left intersect_wfs (List.hd wfs) (List.tl wfs)) - - -(* API *) -let matches_deps ds = - let tt = H.create 37 in - let s_tt = H.create 37 in - let t_tt = H.create 37 in - List.iter begin function - | Adp (t, t') - | Ddp (t, t') -> H.add tt (t,t') () - | Ddp_s t -> H.add s_tt t () - | Ddp_t t' -> H.add t_tt t' () - end ds; - (fun (t, t') -> H.mem tt (t, t') || H.mem s_tt t || H.mem t_tt t') - -(* API *) -let pol_of_dep = function Adp (_,_) -> true | _ -> false - -(* API *) -let tags_of_dep = function - | Adp (t, t') | Ddp (t, t') -> t,t' - | _ -> assertf "tags_of_dep" - -(* API *) -let make_dep b xo yo = - match (b, xo, yo) with - | true , Some t, Some t' -> Adp (t, t') - | false, Some t, Some t' -> Ddp (t, t') - | false, Some t, None -> Ddp_s t - | false, None , Some t' -> Ddp_t t' - | _ -> assertf "FixConstraint.make_dep: match failure" - -(* API *) -let preds_kvars_of_reft reft = - List.fold_left begin fun (ps, ks) -> function - | Conc p -> p :: ps, ks - | Kvar (xes, kvar) -> ps, (xes, kvar) :: ks - end ([], []) (ras_of_reft reft) - -(***************************************************************************************) -(***************************************************************************************) -(***************************************************************************************) - -let theta_ra (su': Su.t) = function - | Conc p -> Conc (A.substs_pred p su') - | Kvar (su, k) -> Kvar (Su.compose su su', k) - -(* API *) -let make_reft = fun v so ras -> (v, so, List.map (theta_ra Su.empty) (canon_ras ras)) -let theta = fun subs (v, so, ras) -> (v, so, Misc.map (theta_ra subs) ras) - -let reft_of_sort so = make_reft (Sy.value_variable so) so [] - -let add_consts_env consts env = - consts - |> List.map (Misc.app_snd reft_of_sort) - |> List.fold_left (fun env (x,r) -> SM.add x r env) env - -(* API *) -let add_consts_wf consts (env,x,y,z) = (add_consts_env consts env, x, y, z) - -(* API *) -let add_consts_t consts t = {t with full = add_consts_env consts t.full} - - - -(***************************************************************) -(************* Add Distinct Ids to Constraints *****************) -(***************************************************************) - -let max_id n cs = - cs |> Misc.map_partial ido_of_t - >> (fun ids -> asserts (Misc.distinct ids) "Duplicate Ids") - |> List.fold_left max n - -let max_wf_id n ws = - ws |> Misc.map_partial (fun (_,_,ido,_) -> ido) - >> (fun ids -> asserts (Misc.distinct ids) "Duplicate WF Ids") - |> List.fold_left max n - -(* API *) -let add_wf_ids ws = - Misc.mapfold begin fun j wf -> match wf with - | (x,y,None,z) -> j+1, (x, y, Some j, z) - | _ -> j, wf - end ((max_wf_id 0 ws) + 1) ws - |> snd - -(* API *) -let add_ids n cs = - Misc.mapfold begin fun j c -> match c with - | {ido = None} -> j+1, {c with ido = Some j} - | c -> j, c - end ((max_id n cs) + 1) cs - - - -(* API *) -let is_conc_rhs {ido = i; rhs = (_,_,ras)} = - let idn = match i with Some i -> i | None -> (-1) in - List.exists is_conc_refa ras - >> (fun rv -> if rv then (asserts (List.for_all is_conc_refa ras) "is_conc_rhs: id = %d" idn)) diff --git a/external/fixpoint/fixConstraint.mli b/external/fixpoint/fixConstraint.mli deleted file mode 100644 --- a/external/fixpoint/fixConstraint.mli +++ /dev/null @@ -1,142 +0,0 @@ -(* - * Copyright © 2009 The Regents of the University of California. All rights reserved. - * - * Permission is hereby granted, without written agreement and without - * license or royalty fees, to use, copy, modify, and distribute this - * software and its documentation for any purpose, provided that the - * above copyright notice and the following two paragraphs appear in - * all copies of this software. - * - * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY - * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES - * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN - * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY - * OF SUCH DAMAGE. - * - * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, - * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY - * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS - * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION - * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONAst.Symbol. - * - *) - -(* This module implements basic datatypes and operations on constraints *) - - -type t (* NEVER EVER expose! *) -type wf (* NEVER EVER expose! *) -type dep (* NEVER EVER expose! dependencies between constraints *) - -type tag = int list * string (* for ordering: must have same dim, lexico-ordered *) -type id = int (* for identifying: must be unique *) - -exception BadConstraint of (id * tag * string) - -type soln = Ast.Symbol.t -> Ast.pred list -type refa = Conc of Ast.pred | Kvar of Ast.Subst.t * Ast.Symbol.t -type reft = Ast.Symbol.t * Ast.Sort.t * refa list (* { VV: t | [ra] } *) -type envt = reft Ast.Symbol.SMap.t -type senvt = Ast.Sort.t Ast.Symbol.SMap.t - - -val fresh_kvar : unit -> Ast.Symbol.t -val kvars_of_reft : reft -> (Ast.Subst.t * Ast.Symbol.t) list -val kvars_of_t : t -> (Ast.Subst.t * Ast.Symbol.t) list - -val is_conc_refa : refa -> bool -val is_conc_rhs : t -> bool - -val empty_solution : soln -val meet_solution : soln -> soln -> soln -val apply_solution : soln -> reft -> reft - -val wellformed_pred : senvt -> Ast.pred -> bool -val preds_of_refa : soln -> refa -> Ast.pred list -val preds_of_reft : soln -> reft -> Ast.pred list -val preds_of_lhs : soln -> t -> Ast.pred list -val preds_of_lhs_nofilter : soln -> t -> Ast.pred list - -val vars_of_t : soln -> t -> Ast.Symbol.t list -val is_tauto : t -> bool - -val preds_kvars_of_reft : reft -> (Ast.pred list * (Ast.Subst.t * Ast.Symbol.t) list) -val env_of_bindings : (Ast.Symbol.t * reft) list -> envt -val env_of_ordered_bindings : (Ast.Symbol.t * reft) list -> envt - -(* TODO: Deprecate *) -val bindings_of_env : envt -> (Ast.Symbol.t * reft) list - -val kbindings_of_lhs : t -> (Ast.Symbol.t * reft) list - -val is_simple : t -> bool -val map_env : (Ast.Symbol.t -> reft -> reft) -> envt -> envt -val lookup_env : envt -> Ast.Symbol.t -> reft option - -(* to print a constraint "c" do: - Format.printf "%a" (print_t None) c - - to print an env "env" do: - Format.printf "%a" (print_env None) c - - to print a wf constraint wf do: - Format.printf "%a" (print_wf None) wf - - to convert a constraint c to a string do: - to_string c - - to print a list of constraints cs do: - Format.printf "%a" (FixMisc.pprint_many true "\n" (C.print_t None)) cs - *) - -val print_env : soln option -> Format.formatter -> envt -> unit -val print_wf : soln option -> Format.formatter -> wf -> unit -val print_t : soln option -> Format.formatter -> t -> unit -val print_ras : soln option -> Format.formatter -> refa list -> unit -val print_reft : soln option -> Format.formatter -> reft -> unit -val print_reft_pred : soln option -> Format.formatter -> reft -> unit -val print_binding : soln option -> Format.formatter -> (Ast.Symbol.t * reft) -> unit -val print_tag : Format.formatter -> tag -> unit -val print_dep : Format.formatter -> dep -> unit - -val to_string : t -> string -val refa_to_string : refa -> string -val reft_to_string : reft -> string -val binding_to_string: (Ast.Symbol.t * reft) -> string - -val make_reft : Ast.Symbol.t -> Ast.Sort.t -> refa list -> reft -val vv_of_reft : reft -> Ast.Symbol.t -val sort_of_reft : reft -> Ast.Sort.t -val ras_of_reft : reft -> refa list -val shape_of_reft : reft -> reft -val theta : Ast.Subst.t -> reft -> reft - -val add_consts_wf : (Ast.Symbol.t * Ast.Sort.t) list -> wf -> wf -val add_consts_t : (Ast.Symbol.t * Ast.Sort.t) list -> t -> t -val make_t : envt -> Ast.pred -> reft -> reft -> id option -> tag -> t - -val sort_of_t : t -> Ast.Sort.t -val vv_of_t : t -> Ast.Symbol.t -val senv_of_t : t -> senvt -val env_of_t : t -> envt -val grd_of_t : t -> Ast.pred -val lhs_of_t : t -> reft -val rhs_of_t : t -> reft -val id_of_t : t -> id -val ido_of_t : t -> id option -val tag_of_t : t -> tag -val add_ids : id -> t list -> id * t list -val add_wf_ids : wf list -> wf list -val make_wf : envt -> reft -> id option -> wf -val make_filtered_wf : envt -> reft -> id option -> (Qualifier.t -> bool) -> wf -val env_of_wf : wf -> envt -val reft_of_wf : wf -> reft -val id_of_wf : wf -> id -val filter_of_wf : wf -> (Qualifier.t -> bool) - -val reduce_wfs : wf list -> wf list - -val make_dep : bool -> tag option -> tag option -> dep -val matches_deps : dep list -> tag * tag -> bool -val tags_of_dep : dep -> tag * tag -val pol_of_dep : dep -> bool diff --git a/external/fixpoint/fixLex.mll b/external/fixpoint/fixLex.mll deleted file mode 100644 --- a/external/fixpoint/fixLex.mll +++ /dev/null @@ -1,177 +0,0 @@ -(* - * Copyright © 1990-2002 The Regents of the University of California. All rights reserved. - * - * Permission is hereby granted, without written agreement and without - * license or royalty fees, to use, copy, modify, and distribute this - * software and its documentation for any purpose, provided that the - * above copyright notice and the following two paragraphs appear in - * all copies of this software. - * - * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY - * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES - * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN - * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY - * OF SUCH DAMAGE. - * - * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, - * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY - * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS - * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION - * d - * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. - * - *) - -{ - module Misc = FixMisc - - open Misc.Ops - module E = Errorline - open E - open FixParse - - let lexerror msg lexbuf = - E.error (Lexing.lexeme_start lexbuf) msg - - (* - let int_of_lexbuf lb = - let str = Lexing.lexeme lb in - let len = String.length str in - let zero = Char.code '0' in - let rec accum a d = - let acc c = a + (d * ((Char.code c) - zero)) in - function 0 -> let c = str.[0] in - if c='-' then - a else (acc c) - | i -> accum (acc str.[i]) (d * 10) (i - 1) - in accum 0 1 (len-1) - *) - let safe_float_of_string s = - try float_of_string s with ex -> - let _ = Printf.printf "safe_float_of_string crashes on: %s (error = %s)" s (Printexc.to_string ex) in - raise ex - - let safe_int_of_string s = - try int_of_string s with ex -> - let _ = Printf.printf "safe_int_of_string crashes on: %s (error = %s)" s (Printexc.to_string ex) in - raise ex - - let string_suffix_from s n = String.sub s n (String.length s - n) - - let snip_begin_end str = - let len = String.length str in - String.sub str 1 (len-2) - - (* let safe_big_int_of_string s = - try Big_int.big_int_of_string (string_suffix_from s 2) with ex -> - let _ = Printf.printf "safe_big_int_of_string crashes on: %s (error = %s)" s (Printexc.to_string ex) in - raise ex - *) - - -} - -let digit = ['0'-'9' '-'] -let letdig = ['0'-'9' 'a'-'z' 'A'-'Z' '_' '@' ''' '.' '#'] -let alphlet = ['A'-'Z' 'a'-'z' '~' '_' ''' '@'] -let capital = ['A'-'Z'] -let small = ['a'-'z' '$' '_'] -let ws = [' ' '\009' '\012'] -let pathname = ['a'-'z' 'A'-'Z' '0'-'9' '.' '/' '\\' '-'] - -rule token = parse - ['\r''\t'' '] { token lexbuf} - | '\n' { begin - E.startNewline (Lexing.lexeme_end lexbuf); - token lexbuf - end } - | "//"[^'\n']*'\n' - { begin - E.startNewline (Lexing.lexeme_end lexbuf); - token lexbuf - end - } - | '_' { UNDERSCORE } - | '[' { LB } - | ']' { RB } - | '(' { LPAREN } - | ')' { RPAREN } - | '{' { LC } - | '}' { RC } - | '~' { NOT } - | ';' { SEMI } - | ',' { COMMA } - | ':' { COLON } - | '|' { MID } - | '+' { PLUS } - | '-' { MINUS } - | '*' { TIMES } - | '/' { DIV } - | '?' { QM } - | '$' { DOL } - | '.' { DOT } - | "iff" { IFFWORD } - | "if" { IFWORD } - | "then" { THENWORD } - | "else" { ELSEWORD } - | "not" { NOTWORD } - | "tag" { TAG } - | "id" { ID } - | "Bexp" { BEXP } - | "false" { FALSE } - | "true" { TRUE } - | ":=" { ASGN } - | "&&" { AND } - | "||" { OR } - - | "<=>" { IFF } - | "=>" { IMPL } - | "!=" { NE } - | "=" { EQ } - | "~~" { UEQ } - | "!~" { UNE } - | "<=" { LE } - | "<" { LT } - | ">=" { GE } - | ">" { GT } - | "mod" { MOD } - | "obj" { OBJ } - | "num" { NUM } - | "frac" { FRAC } - | "int" { INT } - | "real" { REAL } - | "ptr" { PTR } - | "" { LFUN } - (* | "fptr" { FPTR } *) - | "lit" { LIT } - | "bool" { BOOL } - | "uit" { UNINT } - | "func" { FUNC } - | "sort" { SRT } - | "axiom" { AXM } - | "constant" { CON } - | "constraint" { CST } - | "wf" { WF } - | "solution" { SOL } - | "qualif" { QUL } - | "cut" { KUT } - | "bind" { BIND } - | "add_dep" { ADP } - | "del_dep" { DDP } - | "env" { ENV } - | "grd" { GRD } - | "lhs" { LHS } - | "rhs" { RHS } - | "reft" { REF } - | "@" { TVAR } - | (digit)+'.'(digit)+ { Real (safe_float_of_string (Lexing.lexeme lexbuf)) } - | (digit)+ { Num (safe_int_of_string (Lexing.lexeme lexbuf)) } - | (alphlet)letdig* { Id (Lexing.lexeme lexbuf) } - | '''[^''']*''' { Id (snip_begin_end (Lexing.lexeme lexbuf)) } - | '"'[^'"']*'"' { StringLit (snip_begin_end (Lexing.lexeme lexbuf)) } - | eof { EOF } - | _ { begin - lexerror ("Illegal Character '" ^ - (Lexing.lexeme lexbuf) ^ "'") lexbuf; - token lexbuf - end } - diff --git a/external/fixpoint/fixParse.mly b/external/fixpoint/fixParse.mly deleted file mode 100644 --- a/external/fixpoint/fixParse.mly +++ /dev/null @@ -1,435 +0,0 @@ - -%{ -module A = Ast -module So = A.Sort -module Sy = A.Symbol -module E = A.Expression -module P = A.Predicate -module H = A.Horn -module Su = A.Subst -module C = FixConstraint -module Co = Constants -open FixMisc.Ops - -(* - * - %token Tycon - | (capital)letdig* { Tycon (Lexing.lexeme lexbuf) } - | Tycon { So.t_app (So.tycon $1) [] } - | Tycon tyconargsne { So.t_app (So.tycon $1) $2 } - *) - (* | Id { So.t_ptr (So.Loc $1) } - -(* -pExprs: - LPAREN RPAREN { [] } - | LPAREN expr RPAREN { [$2] } - | LPAREN exprsCommaNe RPAREN { $2 } - ; - -exprsCommaNe: - expr { [$1] } - | expr COMMA exprsCommaNe { $1 :: $3 } - ; - *) - -*) -let parse_error msg = - Errorline.error (symbol_start ()) msg - -let create_qual name vv = Qualifier.create (Sy.of_string name) (Sy.of_string vv) - -let set_ibind, get_ibind = - let bindt = Hashtbl.create 37 in - ( (fun (i, x, t) -> Hashtbl.replace bindt i (x, t)) - , (fun i -> try Hashtbl.find bindt i with Not_found -> assertf "Unknown binding: %d\n" i) - ) - -let env_of_ibindings is = - is |> FixMisc.sort_and_compact - |> FixMisc.map get_ibind - |> C.env_of_ordered_bindings - -%} - -%token Id -%token Num -%token Real -%token StringLit -%token TVAR -%token TAG ID -%token BEXP -%token TRUE FALSE -%token UNDERSCORE -%token LPAREN RPAREN LB RB LC RC -%token EQ NE GT GE LT LE UEQ UNE -%token AND OR NOT NOTWORD IMPL IFF IFFWORD FORALL SEMI COMMA COLON MID -%token EOF -%token MOD -%token PLUS -%token MINUS -%token TIMES -%token DIV -%token DOL QM DOT ASGN -%token OBJ REAL INT NUM PTR LFUN BOOL UNINT FUNC LIT FRAC -%token SRT AXM CON CST WF SOL QUL KUT BIND ADP DDP -%token ENV GRD LHS RHS REF -%token IFWORD THENWORD ELSEWORD -%right IFF IFFWORD -%right IMPL -%left PLUS -%left MINUS -%left DIV -%left TIMES -%left DOT -%right NOT - -%start defs -%start sols -%start reft - -%type defs -%type def -%type sols -%type sorts, sortsne -%type sort -%type <(Sy.t * So.t) list> binds, bindsne -%type preds, predsne -%type pred -%type exprs, exprsne -%type expr -%type cstr -%type env -%type reft -%type refas, refasne -%type refa -%type subs - -%% -defs: - { [] } - | def defs { $1 :: $2 } - ; - - - -qual: - Id LPAREN Id COLON sort RPAREN COLON pred { create_qual $1 $3 $5 [] $8 } - | Id LPAREN Id RPAREN COLON pred { create_qual $1 $3 So.t_int [] $6 } - | Id LPAREN Id COLON sort qbindsne RPAREN COLON pred { create_qual $1 $3 $5 $6 $9 } - ; - -qbindsne: - COMMA bind { [$2] } - | COMMA bind qbindsne { $2 :: $3 } - ; - -def: - SRT COLON sort { FixConfig.Srt $3 } - | AXM COLON pred { FixConfig.Axm $3 } - | CST COLON cstr { FixConfig.Cst $3 } - | CON Id COLON sort { FixConfig.Con (Sy.of_string $2, $4) } - | WF COLON wf { FixConfig.Wfc $3 } - | sol { FixConfig.Sol $1 } - | QUL qual { FixConfig.Qul $2 } - | KUT kvid { FixConfig.Kut $2 } - | dep { FixConfig.Dep $1 } - | BIND Num Id COLON reft { let (i, x, r) = ($2, Sy.of_string $3, $5) - >> set_ibind - in FixConfig.IBind (i,x,r) } - ; - - -sorts: - LB RB { [] } - | LB sortsne RB { $2 } - ; - -sortsne: - sort { [$1] } - | sort SEMI sortsne { $1 :: $3 } - ; - -tyconargsne: - | bsort { [$1] } - | bsort tyconargsne { $1 :: $2 } - ; - -sort: - | bsort { $1 } - | Id tyconargsne { So.t_app (So.tycon $1) $2 } - | LB sort RB { So.t_app (So.tycon "List") [$2] } - - ; - -bsort: - | INT { So.t_int } - | REAL { So.t_real } - | BOOL { So.t_bool } - | PTR { So.t_ptr (So.Lvar 0) } - | PTR LPAREN LFUN RPAREN { So.t_ptr (So.LFun) } - | PTR LPAREN Num RPAREN { So.t_ptr (So.Lvar $3) } - | PTR LPAREN Id RPAREN { So.t_ptr (So.Loc $3) } - | OBJ { So.t_obj } - | NUM { So.t_num } - | FRAC { So.t_frac } - | TVAR LPAREN Num RPAREN { So.t_generic $3 } - | FUNC LPAREN sorts RPAREN { So.t_func 0 $3 } - | FUNC LPAREN Num COMMA sorts RPAREN { So.t_func $3 $5 } - | Id { let s = $1 in - if !Co.gen_qual_sorts || FixMisc.stringIsLower s then - So.t_ptr (So.Loc s) (* tyvar *) - else - So.t_app (So.tycon s) [] (* tycon *) - } - | LPAREN sort RPAREN { $2 } - | LB RB { So.t_app (So.tycon "List") [] } - ; - - -binds: - LB RB { [] } - | LB bindsne RB { $2 } - ; - -bindsne: - bind { [$1] } - | bind SEMI bindsne { $1::$3 } - ; - - -bind: - Id COLON sort { ((Sy.of_string $1), $3) } - ; - -rels: - LB RB { [] } - | LB relsne RB { $2 } - ; - -relsne: - rel { [$1]} - | rel SEMI relsne { $1 :: $3} - ; - -rel: - EQ { A.Eq } - | NE { A.Ne } - | UEQ { A.Ueq } - | UNE { A.Une } - | GT { A.Gt } - | GE { A.Ge } - | LT { A.Lt } - | LE { A.Le } - ; - - -preds: - LB RB { [] } - | LB predsne RB { $2 } - ; - -predsne: - pred { [$1] } - | pred SEMI predsne { $1 :: $3 } -; - -pred: - TRUE { A.pTrue } - | FALSE { A.pFalse } - | BEXP expr { A.pBexp $2 } - | QM expr { A.pBexp $2 } - | Id LPAREN argsne RPAREN { A.pBexp (A.eApp ((Sy.of_string $1), $3)) } - | AND preds { A.pAnd ($2) } - | OR preds { A.pOr ($2) } - | NOT pred { A.pNot ($2) } - | NOTWORD pred { A.pNot ($2) } - | LPAREN pred AND pred RPAREN { A.pAnd [$2; $4] } - | LPAREN pred OR pred RPAREN { A.pOr [$2; $4] } - | expr rel expr { A.pAtom ($1, $2, $3) } - | expr rels expr { A.pMAtom ($1, $2, $3) } - | FORALL binds DOT pred { A.pForall ($2, $4) } - | pred IMPL pred { A.pImp ($1, $3) } - | pred IFF pred { A.pIff ($1, $3) } - | pred IFFWORD pred { A.pIff ($1, $3) } - | LPAREN pred RPAREN { $2 } - ; - -argsne: - expr { [$1] } - | expr COMMA argsne { $1::$3 } - ; - - - -exprs: - LB RB { [] } - | LB exprsne RB { $2 } - ; - -exprsne: - expr { [$1] } - | expr SEMI exprsne { $1 :: $3 } - ; - -expr: - Id { A.eVar (Sy.of_string $1) } - | con { A.eCon $1 } - | exprs { A.eMExp $1 } - | LPAREN expr MOD expr RPAREN { A.eMod ($2, $4) } - | MINUS expr { A.eBin (A.zero, A.Minus, $2) } - | expr op expr { A.eBin ($1, $2, $3) } - | expr ops expr { A.eMBin ($1, $2, $3) } - | Id LPAREN exprs RPAREN { A.eApp ((Sy.of_string $1), $3) } - | Id Id { A.eApp ((Sy.of_string $1), [A.eVar (Sy.of_string $2)]) } - | LPAREN pred QM expr COLON expr RPAREN { A.eIte ($2,$4,$6) } - | IFWORD pred THENWORD expr ELSEWORD expr { A.eIte ($2,$4,$6) } - | expr DOT Id { A.eFld ((Sy.of_string $3), $1) } - | LPAREN expr COLON sort RPAREN { A.eCst ($2, $4) } - | LPAREN expr RPAREN { $2 } - ; - -op: - | PLUS { A.Plus } - | MINUS { A.Minus } - | TIMES { A.Times } - | DIV { A.Div } - ; - -ops: - LB RB { [] } - | LB opsne RB { $2 } - ; - -opsne: - op { [$1] } - | op SEMI opsne { $1 :: $3 } - ; - - - -con: - | Real { (A.Constant.Real $1) } - | Num { (A.Constant.Int $1) } - | MINUS Num { (A.Constant.Int (-1 * $2)) } - | MINUS Real { (A.Constant.Real (-. $2)) } - | LIT StringLit sort { (A.Constant.Lit ($2, $3)) } - ; - -cons: - LB RB { [] } - | LB consne RB { $2 } - ; - -consne: - con { [$1] } - | con SEMI consne { $1 :: $3 } - ; - -wf: - ENV env REF reft { C.make_wf $2 $4 None } - | ENV env REF reft ID Num { C.make_wf $2 $4 (Some $6) } - ; - -tagsne: - Num { [$1] } - | Num SEMI tagsne { $1 :: $3 } - ; - -tag: - | LB tagsne RB { ($2, "") } - ; - -dep: - | ADP COLON tag IMPL tag {C.make_dep true (Some $3) (Some $5) } - | DDP COLON tag IMPL tag {C.make_dep false (Some $3) (Some $5) } - | DDP COLON TIMES IMPL tag {C.make_dep false None (Some $5) } - | DDP COLON tag IMPL TIMES {C.make_dep false (Some $3) None } - ; - -info: - ID Num { ((Some $2), ([],"")) } - | TAG tag { (None , $2)} - | ID Num TAG tag { ((Some $2), $4) } - ; - -cstr: - | ENV env GRD pred LHS reft RHS reft { C.make_t $2 $4 $6 $8 None ([],"") } - | ENV env GRD pred LHS reft RHS reft info { C.make_t $2 $4 $6 $8 (fst $9) (snd $9)} - ; - -env: - LB RB { C.env_of_bindings [] } - | LB envne RB { C.env_of_bindings $2 } - | LB ienvne RB { env_of_ibindings $2 } - ; - -ienvne: - Num { [$1] } - | Num SEMI ienvne { $1 :: $3 } - ; - -envne: - rbind { [$1] } - | rbind SEMI envne { $1 :: $3 } - ; - - -rbind: - Id COLON reft { (Sy.of_string $1, $3) } - ; - -ibind: - Num Id COLON reft { ($1, Sy.of_string $2, $4) } - ; - -reft: - LC Id COLON sort MID refas RC { ((Sy.of_string $2), $4, $6) } - ; - -refas: - LB RB { [] } - | LB refasne RB { $2 } - ; - -refasne: - refa { [$1] } - | refa SEMI refasne { $1 :: $3 } - ; - -kvid: - DOL Id { Sy.of_string $2 } - | Id { Sy.of_string $1 } - ; - -refa: - | kvid subs { C.Kvar ($2, $1) } - | pred { C.Conc $1 } - ; - -subs: - { Su.empty } - | LB Id ASGN expr RB subs { Su.extend $6 ((Sy.of_string $2), $4) } - ; - -npred: - LPAREN pred COMMA Id LPAREN argsne RPAREN RPAREN { ((* $2, *) (Sy.of_string $4, $6)) } - ; - -npreds: - LB RB { [] } - | LB npredsne RB { $2 } - ; - -npredsne: - npred { [$1] } - | npred SEMI npredsne { $1 :: $3 } -; - -sol: - SOL COLON Id ASGN npreds { ((Sy.of_string $3), $5) } - -sols: - { [] } - | sol sols { $1 :: $2 } - diff --git a/external/fixpoint/fixSimplify.ml b/external/fixpoint/fixSimplify.ml deleted file mode 100644 --- a/external/fixpoint/fixSimplify.ml +++ /dev/null @@ -1,455 +0,0 @@ -(* - * Copyright © 2009 The Regents of the University of California. All rights reserved. - * - * Permission is hereby granted, without written agreement and without - * license or royalty fees, to use, copy, modify, and distribute this - * software and its documentation for any purpose, provided that the - * above copyright notice and the following two paragraphs appear in - * all copies of this software. - * - * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY - * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES - * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN - * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY - * OF SUCH DAMAGE. - * - * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, - * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY - * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS - * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION - * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. - * - *) - -module BS = BNstats -module Co = Constants -module C = FixConstraint -module P = Ast.Predicate -module E = Ast.Expression -module Sy = Ast.Symbol -module Kg = Kvgraph -module Su = Ast.Subst -module SM = Ast.Symbol.SMap -module SS = Ast.Symbol.SSet - -module Misc = FixMisc -module IM = Misc.IntMap -open Misc.Ops -open Ast - -let mydebug = false - - -(****************************************************************************) -(*********************************** Misc. **********************************) -(****************************************************************************) - -let add_cm = List.fold_left (fun cm c -> IM.add (C.id_of_t c) c cm) -let find_cm = fun cm id -> IM.find id cm -let refas_of_k = fun k -> [C.Kvar (Su.empty, k)] - -(****************************************************************************) -(************** Generic Simplification/Transformation API *******************) -(****************************************************************************) - -module type SIMPLIFIER = sig - val simplify_ts: FixConstraint.t list -> FixConstraint.t list -end - -(****************************************************************************) -(******************* Syntactic Simplification *******************************) -(****************************************************************************) - -module Syntactic : SIMPLIFIER = struct - -let defs_of_pred = - let rec dofp (em, pm) p = match p with - | Atom ((Var v, _), Eq, e), _ - when not (P.is_tauto p) -> - Sy.SMap.add v e em, pm - | And [Imp ((Bexp (Var v1, _), _), p1), _; - Imp (p2, (Bexp (Var v2, _), _)), _], _ - when v1 = v2 && p1 = p2 && not(P.is_tauto p) -> - em, Sy.SMap.add v1 p1 pm - | And ps, _ -> - List.fold_left dofp (em, pm) ps - | _ -> em, pm - in dofp (Sy.SMap.empty, Sy.SMap.empty) - -let rec expr_apply_defs em pm expr = - let ef = expr_apply_defs em pm in - let pf = pred_apply_defs em pm in - match expr with - | Var v, _ when Sy.SMap.mem v em -> - Sy.SMap.find v em, true - | Var _, _ | Con _, _ | Bot, _ -> - expr, false - | App (v, es), _ -> - let _ = asserts (not (Sy.SMap.mem v em)) "binding for UF" in - es |> List.map ef - |> List.split - |> (fun (es', bs') -> (eApp (v, es'), List.fold_left (||) false bs')) - | Bin (e1, op, e2), _ -> - let e1', b1' = ef e1 in - let e2', b2' = ef e2 in - eBin (e1', op, e2'), (b1' || b2') - | Ite (p, e1, e2), _ -> - let p', b' = pf p in - let e1', b1' = ef e1 in - let e2', b2' = ef e2 in - eIte (p', e1', e2'), (b' || b1' || b2') - | Fld (v, e), _ -> - let e', b' = ef e in - eFld (v, e'), b' - | Cst (e, t), _ -> - let e', b' = ef e in - eCst (e', t), b' - | _ -> failwith "Pattern: expr_apply_defs" - -and pred_apply_defs em pm pred = - let ef = expr_apply_defs em pm in - let pf = pred_apply_defs em pm in - match pred with - | And ps, _ -> - ps |> List.map pf - |> List.split - |> (fun (ps', bs') -> pAnd ps', List.exists id bs') - | Or ps, _ -> - ps |> List.map pf - |> List.split - |> (fun (ps', bs') -> pOr ps', List.exists id bs') - | Not p, _ -> - p |> pf - |> Misc.app_fst pNot - | Imp (p1, p2), _ -> - let p1', b1' = pf p1 in - let p2', b2' = pf p2 in - pImp (p1', p2'), b1' || b2' - | Bexp (Var v, _), _ when Sy.SMap.mem v pm -> - Sy.SMap.find v pm, true - | Bexp e, _ -> - e |> ef |> Misc.app_fst pBexp - | Atom (e1, brel, e2), _ -> - let e1', b1' = ef e1 in - let e2', b2' = ef e2 in - pAtom (e1', brel, e2'), b1' || b2' - | Forall (qs, p), _ -> - assertf "Forall in Simplify!" - | _ -> - pred, false - -(* Why does this fixpointing terminate? - * close em, pm under substitution so that - for all x in dom(em), support(em(x)) \cap dom(em) = empty *) - -(* Assume: em is well-formed, - * i.e. exists an ordering on vars of dom(em) - * x1 < x2 < ... < xn s.t. if xj \in em(xi) then xj < xi *) - -let expr_apply_defs em fm e = - e |> Misc.fixpoint (expr_apply_defs em fm) - |> fst - -let pred_apply_defs em fm p = - p |> Misc.fixpoint (pred_apply_defs em fm) - |> fst - |> simplify_pred - -let subs_apply_defs em pm xes = List.map (Misc.app_snd (expr_apply_defs em pm)) xes - - -let print_em_pm t (em, pm) = - let id = t |> C.id_of_t in - let vv = t |> C.lhs_of_t |> C.vv_of_reft in - let vve = try Sy.SMap.find vv em with Not_found -> bot in - let vve' = expr_apply_defs em pm vve in - Co.bprintf mydebug "\nbodyp em map for %d\n" id ; - Sy.SMap.iter (fun x e -> Co.bprintf mydebug "%a -> %a\n" Sy.print x E.print e) em; - Co.bprintf mydebug "\nbodyp pm map for %d\n" id ; - Sy.SMap.iter (fun x p -> Co.bprintf mydebug "%a -> %a\n" Sy.print x P.print p) pm; - Co.bprintf mydebug "edef for vv %a = %a (simplified %a)\n" Sy.print vv E.print vve E.print vve' - -let preds_kvars_of_env env = - Sy.SMap.fold begin fun x r (ps, env) -> - let vv = C.vv_of_reft r in - let xe = Ast.eVar x in - let t = C.sort_of_reft r in - let rps, rks = C.preds_kvars_of_reft r in - let ps' = List.map (fun p -> P.subst p vv xe) rps ++ ps in - let env' = (* match rks with [] -> env | _ -> *) Sy.SMap.add x (vv, t, rks) env in - ps', env' - end env ([], Sy.SMap.empty) - -let simplify_kvar em pm (su, sym) = - su |> Su.to_list - |> subs_apply_defs em pm - |> Su.of_list - |> (fun su -> C.Kvar (su, sym)) - -let simplify_env em pm ks_env = - Sy.SMap.map begin fun (vv, t, ks) -> - ks |> List.map (simplify_kvar em pm) |> C.make_reft vv t - end ks_env - -let simplify_grd em pm vv t p = - let _ = Co.bprintf mydebug "simplify_grd [1]: %a \n" P.print p in - let p = pred_apply_defs em pm p in - let _ = Co.bprintf mydebug "simplify_grd [2]: %a \n" P.print p in - begin try - Sy.SMap.find vv em - |> expr_apply_defs em pm - |> (fun vve -> pAnd [p; pAtom (eVar vv, Eq, vve)]) - with Not_found -> p end - >> Co.bprintf mydebug "simplify_grd [3]: %a \n" P.print - -let simplify_refa em pm = function - | C.Conc p -> C.Conc (pred_apply_defs em pm p) - | C.Kvar (xes, sym) -> simplify_kvar em pm (xes, sym) - -(* API *) -let simplify_t c = - let id = c |> C.id_of_t in - let _ = Co.bprintf mydebug "============== Simplifying %d ============== \n"id in - let env_ps, ks_env = c |> C.env_of_t |> preds_kvars_of_env in - let l_ps, l_ks = c |> C.lhs_of_t |> C.preds_kvars_of_reft in - let vv, t = c |> C.lhs_of_t |> Misc.tmap2 (C.vv_of_reft, C.sort_of_reft) in - let bodyp = Ast.pAnd ([C.grd_of_t c] ++ l_ps ++ env_ps) - >> Co.bprintf mydebug "body_pred: %a \n" P.print in - let em, pm = defs_of_pred bodyp - >> print_em_pm c in - - let senv = simplify_env em pm ks_env in - let sgrd = simplify_grd em pm vv t bodyp in - let slhs = l_ks |> List.map (simplify_kvar em pm) |> C.make_reft vv t in - let srhs = c |> C.rhs_of_t |> C.ras_of_reft |> List.map (simplify_refa em pm) |> C.make_reft vv t in - - C.make_t senv sgrd slhs srhs (C.ido_of_t c) (C.tag_of_t c) - -(* API *) -let simplify_ts cs = - cs |> List.map simplify_t - (* |> List.filter (not <.> C.is_tauto) *) -end - -(****************************************************************************) -(*** Cone-of-Influence: Remove Constraints that don't reach constant-pred ***) -(****************************************************************************) - -module Cone : SIMPLIFIER = struct - let simplify_ts cs = - let cm = add_cm IM.empty cs in - cs |> Kg.add Kg.empty - >> Kg.print_stats - |> Kg.cone_ids - |> List.map (find_cm cm) -end - -(**************************************************************************) -(*** Direct-Dependencies: Remove non-data-dependent binders****************) -(*************************************************************************) - -module WeakFixpoint : SIMPLIFIER = struct - - let weaken_env c e = - C.make_t e - (C.grd_of_t c) (C.lhs_of_t c) (C.rhs_of_t c) - (C.ido_of_t c) (C.tag_of_t c) - - let support_of_refa = function - | C.Conc p -> P.support p - | _ -> [] - - let support_of_reft = - Misc.flap support_of_refa <.> thd3 - - let rec data_cone env m n xs = match xs with - | _::_ -> let m' = List.fold_left (fun m' x -> Sy.SMap.add x n m') m xs in - xs |> Misc.map_partial (C.lookup_env env) - |> Misc.flap support_of_reft - |> Misc.filter (fun x -> not (Sy.SMap.mem x m)) - |> data_cone env m' (n+1) - | [] -> m - - let data_cone c = - (P.support (C.grd_of_t c)) - |> (++) (support_of_reft (C.lhs_of_t c)) - |> data_cone (C.env_of_t c) Sy.SMap.empty 0 - - let project_cone m x ((v,t,ras) as r) = - if Sy.SMap.mem x m then r else (v, t, List.filter C.is_conc_refa ras) - - let simplify_t c = - c |> data_cone |> project_cone |> C.map_env - |> (fun f -> f (C.env_of_t c)) - |> weaken_env c - - let simplify_ts = Misc.map simplify_t -end - -(****************************************************************************) -(***** Merge Write and Read of Kvar: A |- k and B, k |- C iff A,B |- C ****) -(****************************************************************************) - -module EliminateK : SIMPLIFIER = struct - - type t = { g : Kg.t; - cm : FixConstraint.t IM.t; - id : int; } - - let print_k ppf k = - Format.fprintf ppf "%s" (C.refa_to_string k) - - let empty = - { g = Kg.empty; - cm = IM.empty; - id = 0; } - - let add me cs = - let n, cs = C.add_ids me.id cs in - { g = Kg.add me.g cs; - cm = add_cm me.cm cs; - id = n+1 } - - let remove me (k, cs) = - { g = Kg.remove me.g [k]; - cm = List.map C.id_of_t cs |> List.fold_left (Misc.flip IM.remove) me.cm; - id = me.id; } - - let of_ts = add empty - let to_ts = fun me -> me.cm |> IM.to_list |> List.map snd - let cs_of_k = fun f me k -> f me.g [k] |> List.map (find_cm me.cm) - - (* Assume that k is written in (1) and read once in (2) - - (1) env1, g1, k_v:l1 |- k[xi := ai] - (2) env2, g2, y:k[xi := bi] |- r2 - - Now, (1) equiv (1') and (2) equiv (2') - - (1') env1, g1, #i:{v=ai}, k_v:l1 |- k[xi := #i] - (2') env2, g2, #i:{v=bi}, y:k2[xi := #i] |- r2 - - Next, we can merge (1') and (2') - - (1'+2') env1 ++ env2, g1 && g2, #i:{v=ai}, #i:{v=bi}, y:l1 |- r2 - - Which simplifies to: - - (1'+2') env1 ++ env2, g1 && g2 && {ai = bi}, y:l1 |- r2 - *) - - let meet_env env1 env2 xrs = - [env1; env2] - |> Misc.flap C.bindings_of_env - |> (++) xrs - |> C.env_of_bindings - - let meet_sub su1 su2 = - [su1; su2] - |> Misc.flap Su.to_list - |> Misc.groupby fst - |> List.map (function [(x,e)] -> pEqual (eVar x, e)| [(_,e1);(_,e2)] -> pEqual (e1,e2)) - |> pAnd - - let merge_one me k (wc, rc) = - let env1, env2 = Misc.map_pair C.env_of_t (wc, rc) in - let g1, g2 = Misc.map_pair C.grd_of_t (wc, rc) in - let l1 = C.lhs_of_t wc in - let [C.Kvar(su1, k)] = C.rhs_of_t wc |> thd3 in - let su2, yr', l' = match Kg.k_reads me.g (C.id_of_t rc) (C.Kvar (Su.empty, k)) with - | [Kg.Bnd (y, su2)] -> su2, [(y,l1)], (C.lhs_of_t rc) - | [Kg.Lhs su2] -> su2, [], l1 - | _ -> assertf "EliminateK.merge_one (k=%s, id=%d)" (Sy.to_string k) (C.id_of_t rc) in - let env' = meet_env env1 env2 yr' in - let g' = pAnd [g1; g2; meet_sub su1 su2] in - let r' = C.rhs_of_t rc in - C.make_t env' g' l' r' None (C.tag_of_t rc) - - let eliminate me (k, wcs, rcs) = - me >> (fun _ -> Format.printf "EliminateK.eliminate %s \n" (C.refa_to_string k)) - |> Misc.flip add (Misc.cross_product wcs rcs |> List.map (merge_one me k)) - |> Misc.flip remove (k, wcs ++ rcs) - - let select_ks me = - me.g - |> Kg.filter_kvars (Kg.is_single_wr me.g) - |> List.filter (Kg.is_single_rd me.g) - |> List.map (fun k -> (k, cs_of_k Kg.writes me k, cs_of_k Kg.reads me k)) - |> List.filter (fun (_,wcs, rcs) -> Misc.disjoint wcs rcs) - >> (List.map fst3 <+> Format.printf "EliminateK.select_ks [OUT]: %a \n" - (Misc.pprint_many false "," print_k)) - - let simplify_ts cs = - let me = of_ts cs in - me |> select_ks - |> List.fold_left eliminate me - |> to_ts -end - - -(****************************************************************************) -(***** Copy Propagation *****************************************************) -(****************************************************************************) - -module CopyProp : SIMPLIFIER = struct - - let subst_theta = - List.map <.> Misc.app_snd <.> (fun (x, e) e' -> E.subst e' x e) - - let subst_bind su x y ((v, t, ras) as r) = - if x = y then (v, t, []) else C.theta su r - - let subst_cstr (x, e) c = - let su = Su.of_list [(x, e)] in - let env' = C.env_of_t c |> C.map_env (subst_bind su x) in - let grd' = C.grd_of_t c |> (fun p -> P.subst p x e) in - let lhs' = C.lhs_of_t c |> C.theta su in - let rhs' = C.rhs_of_t c |> C.theta su in - C.make_t env' grd' lhs' rhs' (C.ido_of_t c) (C.tag_of_t c) - - let rec eliminate c = function - | (x, e) :: theta' when List.mem x (E.support e) - -> eliminate c theta' - | xe :: theta' (* x not in e *) - -> eliminate (subst_cstr xe c) (subst_theta xe theta') - | [] -> c - - let rigid_vars c = - c |> C.kvars_of_t - |> List.map fst - |> Misc.flap Su.to_list - |> List.map fst - |> SS.of_list - - let equalities_of_binding = function - | (x, (v, _, [C.Conc ( Atom ((Var v', _), Eq, e), _ )])) - when v = v' -> Some (x, e) - | (x, (v, _, [C.Conc ( Atom (e, Eq, (Var v', _)), _ )])) - when v = v' -> Some (x, e) - | _ -> None - - let equalities_of_t c = - c |> C.env_of_t - |> (fun _ -> failwith "CopyProp.equalities_of_t") (* C.bindings_of_env *) - |> Misc.map_partial equalities_of_binding - - let simplify_t c = - let ys = rigid_vars c in - c |> equalities_of_t - |> List.filter (fun (x,_) -> not (SS.mem x ys)) - |> eliminate c - - let simplify_ts = Misc.map simplify_t -end - -(* API *) -let simplify_ts cs = - cs - |> Misc.filter (not <.> C.is_tauto) - |> ((not !Co.lfp) BS.time "simplify 0" WeakFixpoint.simplify_ts) - |> BS.time "add ids 1" (C.add_ids 0) - |> snd - (* |> (!Co.copyprop BS.time "simplify CP" CopyProp.simplify_ts) *) - |> (!Co.simplify_t BS.time "simplify 1" Syntactic.simplify_ts) (* termination bug, tickled by C benchmarks *) - |> (!Co.simplify_t BS.time "simplify 2" Cone.simplify_ts) - |> (!Co.simplify_t BS.time "simplify 3" EliminateK.simplify_ts) diff --git a/external/fixpoint/fixSimplify.mli b/external/fixpoint/fixSimplify.mli deleted file mode 100644 --- a/external/fixpoint/fixSimplify.mli +++ /dev/null @@ -1,28 +0,0 @@ -(* - * Copyright © 2009 The Regents of the University of California. All rights reserved. - * - * Permission is hereby granted, without written agreement and without - * license or royalty fees, to use, copy, modify, and distribute this - * software and its documentation for any purpose, provided that the - * above copyright notice and the following two paragraphs appear in - * all copies of this software. - * - * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY - * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES - * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN - * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY - * OF SUCH DAMAGE. - * - * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, - * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY - * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS - * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION - * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. - * - *) - - -module WeakFixpoint : FixConfig.SIMPLIFIER -include FixConfig.SIMPLIFIER - -(* val simplify_ts : FixConstraint.t list -> FixConstraint.t list *) diff --git a/external/fixpoint/fixpoint.ml b/external/fixpoint/fixpoint.ml deleted file mode 100644 --- a/external/fixpoint/fixpoint.ml +++ /dev/null @@ -1,148 +0,0 @@ -(* - * Copyright © 2009 The Regents of the University of California. All rights reserved. - * - * Permission is hereby granted, without written agreement and without - * license or royalty fees, to use, copy, modify, and distribute this - * software and its documentation for any purpose, provided that the - * above copyright notice and the following two paragraphs appear in - * all copies of this software. - * - * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY - * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES - * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN - * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY - * OF SUCH DAMAGE. - * - * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, - * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY - * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS - * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION - * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. - * - *) - - -(** read a set of constraints, solve, and dump out the solution *) - -module CX = Counterexample -module BS = BNstats -module SM = Ast.Symbol.SMap -module Co = Constants -module C = FixConstraint -module F = Format -module T = Toplevel -module PA = PredAbs -module SPA = Solve.Make (PA) -module Cg = FixConfig - -module Misc = FixMisc open Misc.Ops - -let mydebug = false - -(*****************************************************************) -(********************* Hooking into Solver ***********************) -(*****************************************************************) - -let print_raw_cs ppf = function - | [] -> F.fprintf ppf "SAT \n \n \n" - | cs -> F.fprintf ppf "UNSAT [%s] \n \n \n" (Misc.map_to_string (C.id_of_t <+> string_of_int) cs) - -let save_raw fname cs s = - Misc.with_out_formatter fname begin fun ppf -> - F.fprintf ppf "%a \n" print_raw_cs cs; - F.fprintf ppf "%a \n" PA.print s; - F.fprintf ppf "@."; - F.print_flush () - end - -let save_crash fname (id, tag, msg) = - Misc.with_out_formatter fname begin fun ppf -> - F.fprintf ppf "CRASH %d (%s)\n" id msg; - F.fprintf ppf "//%a\n" C.print_tag tag; - F.fprintf ppf "@."; - F.print_flush () - end - -let solve ac = - let _ = Co.bprintflush mydebug "Fixpoint: Creating CI\n" in - let ctx, s = BS.time "create" SPA.create ac None in - let _ = Co.bprintflush mydebug "Fixpoint: Solving \n" in - let s, cs',_ = BS.time "solve" (SPA.solve ctx) s in - - let _ = Co.bprintflush mydebug "Fixpoint: Saving Result \n" in - let _ = BS.time "save" (save_raw (Co.get_out_file ()) cs') s in - let _ = Co.bprintflush mydebug "Fixpoint: Saving Result DONE \n" in - cs' - -let dump_solve ac = - try - let cs' = solve { ac with Cg.bm = SM.map PA.mkbind ac.Cg.bm } in - let _ = if Co.ck_olev 1 then BNstats.print stdout "Fixpoint Solver Time \n" in - match cs' with - | [] -> (F.printf "\nSAT\n" ; exit 0) - | _ -> (F.printf "\nUNSAT\n" ; exit 1) - with (C.BadConstraint (id, tag, msg)) -> begin - Format.printf "Fixpoint: Bad Constraint! id = %d (%s) tag = %a \n" - id msg C.print_tag tag; - save_crash (Co.get_out_file ()) (id, tag, msg); - end - -(*****************************************************************) -(********************* Generate Imp Program **********************) -(*****************************************************************) - -let dump_imp a = - (List.map (fun c -> Cg.Cst c) a.Cg.cs ++ List.map (fun c -> Cg.Wfc c) a.Cg.ws) - |> ToImp.render F.std_formatter - |> fun _ -> exit 1 - -(*****************************************************************) -(***************** Generate Simplified Constraints ***************) -(*****************************************************************) - -let hook_simplify_ts = function - | "andrey" -> List.map Simplification.simplify_t - <+> List.filter (not <.> Simplification.is_tauto_t) - <+> Simplification.simplify_ts - | "jhala" -> FixSimplify.simplify_ts - (* put other transforms here *) - | _ -> id - -let simplify_ts cs = hook_simplify_ts !Co.dump_simp cs - -let dump_simp ac = - let ac = {ac with Cg.cs = simplify_ts ac.Cg.cs; Cg.bm = SM.empty} in - Misc.with_out_formatter (Co.get_save_file ()) (fun ppf -> Cg.print ppf ac) - -(* -let dump_simp ac = - (* let ac = {ac with Cg.cs = simplify_ts ac.Cg.cs; Cg.bm = SM.empty; Cg.qs = []} in *) - let ac = {ac with Cg.cs = simplify_ts ac.Cg.cs; Cg.bm = SM.empty} in - Misc.with_out_formatter !Co.save_file (fun ppf -> Cg.print ppf ac) - - let ctx,_ = BS.time "create" SPA.create ac None in - let s0 = PA.empty (* PA.create ac None *) in - let _ = BS.time "save" (SPA.save !Co.save_file ctx) s0 in - exit 1 -*) - -(*****************************************************************) -(*********************** Main ************************************) -(*****************************************************************) - -let usage = "Usage: fixpoint.native [source-files]\noptions are:" - -let main () = - let cfg = usage |> Toplevel.read_inputs |> snd in - if !Co.dump_imp then - dump_imp cfg - else if !Co.dump_smtlib then - ToSmtLib.dump_smtlib cfg - else if !Co.dump_simp <> "" then - dump_simp cfg - else - dump_solve cfg - - - -let _ = main () diff --git a/external/fixpoint/fixpoint.native-i386-linux b/external/fixpoint/fixpoint.native-i386-linux deleted file mode 100644 Binary files a/external/fixpoint/fixpoint.native-i386-linux and /dev/null differ diff --git a/external/fixpoint/fixpoint.native-i686-w64-mingw32 b/external/fixpoint/fixpoint.native-i686-w64-mingw32 deleted file mode 100644 # file too large to diff: external/fixpoint/fixpoint.native-i686-w64-mingw32 diff --git a/external/fixpoint/fixpoint.native-x86_64-darwin b/external/fixpoint/fixpoint.native-x86_64-darwin deleted file mode 100644 # file too large to diff: external/fixpoint/fixpoint.native-x86_64-darwin diff --git a/external/fixpoint/fixpoint.native-x86_64-linux b/external/fixpoint/fixpoint.native-x86_64-linux deleted file mode 100644 # file too large to diff: external/fixpoint/fixpoint.native-x86_64-linux diff --git a/external/fixpoint/fixtop.ml b/external/fixpoint/fixtop.ml deleted file mode 100644 --- a/external/fixpoint/fixtop.ml +++ /dev/null @@ -1,123 +0,0 @@ -(* - * Copyright © 2009 The Regents of the University of California. All rights reserved. - * - * Permission is hereby granted, without written agreement and without - * license or royalty fees, to use, copy, modify, and distribute this - * software and its documentation for any purpose, provided that the - * above copyright notice and the following two paragraphs appear in - * all copies of this software. - * - * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY - * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES - * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN - * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY - * OF SUCH DAMAGE. - * - * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, - * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY - * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS - * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION - * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. - * - *) - - -(** read a set of constraints, solve, and dump out the solution *) - -module SM = Ast.Symbol.SMap -module Co = Constants -module C = FixConstraint -module F = Format -(*module Si = Simplification *) -module Misc = FixMisc -open Misc.Ops - -let _ = FixLex.token (Lexing.from_string "int");; - -let parse_string f = f FixLex.token <.> Lexing.from_string - - -let dump cs ws = - Format.printf "Printing Out Parsed Constraints \n \n \n" ; - Format.printf "%a" (Misc.pprint_many true "\n" (FixConstraint.print_t None)) cs; - Format.printf "\n \n"; - Format.printf "%a" (Misc.pprint_many true "\n" (FixConstraint.print_wf None)) ws; - Format.printf "\n \n" - -let usage = "Usage: fixtop [source-files]\noptions are:" - -let main () = print_string "Hello World \n" - -(* -let main () = - let fs, config = Toplevel.read_inputs usage in - let cs = config.C.cs in - let ws = config.C.ws in - let cs = - if !Co.simplify_t then - Misc.map_partial begin fun t -> - let st = Si.simplify_t t in - if Si.is_tauto_t st then None else Some st - end cs |> Si.simplify_ts - else cs in - begin - match !Co.latex_file with - | Some f -> - let out = open_out f in - ToLatex.to_latex out cs ws; - close_out out - | None -> () - end; - (* - begin - match !Co.armc_file with - | Some f -> - let out = open_out f in - Printf.fprintf out "%% %s\n" (String.concat ", " fs); - ToHC.to_dataflow_armc out cs ws sol; - close_out out - | None -> () - end; - *) - (* - begin - match !Co.horn_file with - | Some f -> - let out = open_out f in - Printf.fprintf out "%% %s\n" (String.concat ", " fs); - ToHC.to_horn out cs ws sol; - close_out out - | None -> () - end; - *) - begin - match !Co.q_armc_file with - | Some f -> - let out = open_out f in - Printf.fprintf out "%% %s\n" (String.concat ", " fs); - ToQARMC.to_qarmc out cs ws; - close_out out - | None -> () - end; -(* - begin - match !Co.raw_horn_file with - | Some f -> - let out = open_out f in - Printf.fprintf out "%% %s\n" (String.concat ", " fs); - ToRawHorn.to_raw_horn out cs ws sol; - close_out out - | None -> () - end; -*) - begin - match !Co.dot_file with - | Some f -> - let oc = open_out f in - ToDot.to_dot oc cs; - close_out oc - | None -> () - end -*) - -let _ = main () diff --git a/external/fixpoint/hornLex.mll b/external/fixpoint/hornLex.mll deleted file mode 100644 --- a/external/fixpoint/hornLex.mll +++ /dev/null @@ -1,99 +0,0 @@ -(* - * Copyright © 1990-2002 The Regents of the University of California. All rights reserved. - * - * Permission is hereby granted, without written agreement and without - * license or royalty fees, to use, copy, modify, and distribute this - * software and its documentation for any purpose, provided that the - * above copyright notice and the following two paragraphs appear in - * all copies of this software. - * - * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY - * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES - * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN - * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY - * OF SUCH DAMAGE. - * - * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, - * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY - * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS - * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION - * d - * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. - * - *) - -{ - module E = Errorline - open E - open HornParse - - let lexerror msg lexbuf = - E.error (Lexing.lexeme_start lexbuf) msg - -} - -let letdig = ['0'-'9' 'a'-'z' 'A'-'Z' '_' '@' ''' '.' '#'] -let small = ['a'-'z'] -let digit = ['0'-'9'] - -rule token = parse - ['\r''\t'' '] { token lexbuf} - | '\n' { begin - E.startNewline (Lexing.lexeme_end lexbuf); - token lexbuf - end } - | "//"[^'\n']*'\n' - { begin - E.startNewline (Lexing.lexeme_end lexbuf); - token lexbuf - end } - | '[' { LB } - | ']' { RB } - | '(' { LPAREN } - | ')' { RPAREN } - | '{' { LC } - | '}' { RC } - | '~' { NOT } - | ';' { SEMI } - | ',' { COMMA } - | ':' { COLON } - | '+' { PLUS } - | '-' { MINUS } - | '*' { TIMES } - | '/' { DIV } - | '.' { DOT } - | "hc" { HC } - | "Bexp" { BEXP } - | "false" { FALSE } - | "true" { TRUE } - | "&&" { AND } - | "||" { OR } - | "!=" { NE } - | "=" { EQ } - | "=<" { LE } - | "<" { LT } - | ">=" { GE } - | ">" { GT } - | "->" { IMPL } - | (digit)+ { let str = Lexing.lexeme lexbuf in - let len = String.length str in - let zero = Char.code '0' in - let rec accum a d = - let acc c = a + (d * ((Char.code c) - zero)) in - function - 0 -> let c = str.[0] in - if c='-' then - a else (acc c) - | i -> accum (acc str.[i]) (d * 10) (i - 1) - in - Num (accum 0 1 (len-1)) } - - | '_'(digit)+ { Id (Lexing.lexeme lexbuf) } - | (small)letdig+ { Var (Lexing.lexeme lexbuf) } - | eof { EOF } - | _ { - begin - lexerror ("Illegal Character '" ^ - (Lexing.lexeme lexbuf) ^ "'") lexbuf; - token lexbuf - end } - diff --git a/external/fixpoint/hornParse.mly b/external/fixpoint/hornParse.mly deleted file mode 100644 --- a/external/fixpoint/hornParse.mly +++ /dev/null @@ -1,147 +0,0 @@ - -%{ -module A = Ast -module So = A.Sort -module Sy = A.Symbol -module E = A.Expression -module P = A.Predicate -module H = A.Horn -module Su = A.Subst -module C = FixConstraint - -let parse_error msg = - Errorline.error (symbol_start ()) msg - -%} - -%token Var -%token Id -%token Num -%token BEXP -%token TRUE FALSE -%token LPAREN RPAREN LB RB LC RC -%token EQ NE GT GE LT LE -%token AND OR NOT IMPL FORALL SEMI COMMA COLON DOT -%token EOF -%token PLUS -%token MINUS -%token TIMES -%token DIV -%token HC - -%right PLUS -%right MINUS -%right TIMES -%right DIV - - -%start horns - -%type preds, predsne -%type pred -%type exprs, exprsne -%type expr -%type brel -%type bop - -%type pr -%type guard -%type guards, guardsne -%type hc -%type horns - -%% -preds: - LB RB { [] } - | LB predsne RB { $2 } - ; - -predsne: - pred { [$1] } - | pred SEMI predsne { $1 :: $3 } -; - -pred: - TRUE { A.pTrue } - | FALSE { A.pFalse } - | BEXP expr { A.pBexp $2 } - | AND preds { A.pAnd ($2) } - | OR preds { A.pOr ($2) } - | NOT pred { A.pNot ($2) } - | pred IMPL pred { A.pImp ($1, $3) } - | expr brel expr { A.pAtom ($1, $2, $3) } - | LPAREN pred RPAREN { $2 } - ; - -exprs: - LB RB { [] } - | LB exprsne RB { $2 } - ; - -exprsne: - expr { [$1] } - | expr SEMI exprsne { $1 :: $3 } - ; - -expr: - Id { A.eVar (Sy.of_string $1) } - | Num { A.eCon (A.Constant.Int $1) } - | MINUS Num { A.eCon (A.Constant.Int (-1 * $2)) } - | MINUS LPAREN expr RPAREN { A.eBin (A.zero, A.Minus, $3) } - | expr bop expr { A.eBin ($1, $2, $3) } - | Id LPAREN exprs RPAREN { A.eApp ((Sy.of_string $1), $3) } - | LPAREN expr RPAREN { $2 } - ; - -brel: - EQ { A.Eq } - | NE { A.Ne } - | GT { A.Gt } - | GE { A.Ge } - | LT { A.Lt } - | LE { A.Le } - ; - -bop: - PLUS { A.Plus } - | MINUS { A.Minus } - | TIMES { A.Times } - | DIV { A.Div } - ; - - -idsne: - Id { [$1] } - | Id COMMA idsne { $1 :: $3 } - ; - -pr: - Var LPAREN RPAREN { ($1, []) } - | Var LPAREN idsne RPAREN { ($1, $3) } - | Var { ($1, []) } - ; - -guard: - pr { H.K ($1) } - | pred { H.C ($1) } - ; - -guards: - LB RB { [] } - | LB guardsne RB { $2 } - ; - -guardsne: - guard { [$1] } - | guard COMMA guardsne { $1 :: $3 } - ; - -hc: - HC LPAREN pr COMMA guards RPAREN DOT {($3, $5)} - ; - - -horns: - { [] } - | hc horns { $1 :: $2 } - diff --git a/external/fixpoint/hornToInterproc.ml b/external/fixpoint/hornToInterproc.ml deleted file mode 100644 --- a/external/fixpoint/hornToInterproc.ml +++ /dev/null @@ -1,154 +0,0 @@ - -module F = Format -module BS = BNstats -module Co = Constants -module SM = Misc.StringMap -module H = Ast.Horn -module Misc = FixMisc open Misc.Ops - - -let tmpname1 = "tmp" - -(***************************************************************************) -(************************* Parse Horn Clauses ******************************) -(***************************************************************************) - -let clean f = - Misc.map_lines_of_file f tmpname1 begin fun s -> - if String.length s > 3 && String.sub s 0 3 = "hc(" then - let ss = Misc.chop s ", " in - match ss with - | [s1; s2; _] -> Printf.sprintf "%s, %s).\n\n" s1 s2 - | ss -> assertf "bad string: %s" (String.concat "####" ss) - else "" - end; - tmpname1 - -let parse f : H.t list = - let ic = f |> clean >> Errorline.startFile |> open_in in - let rv = Lexing.from_channel ic |> HornParse.horns HornLex.token in - let _ = close_in ic in - rv - -(****************************************************************************) -(******************* Preprocess HC to get global information ****************) -(****************************************************************************) - -type t = { - aritym : int SM.t; (* k -> arity *) - bindm : string list SM.t; (* k -> local bindings *) - argn : int; (* max-fun-args across all ks *) - cm : H.t list SM.t; (* k -> cs *) -} - -let create (cs: H.t list) : t = - let cm = cs |> Misc.kgroupby (fun ((k,_),_) -> k) - |> List.fold_left (fun cm (k,cs) -> SM.add k cs cm) SM.empty in - let aritym = SM.map (function ((k, xs),_)::_ -> - let n = List.length xs in - (* let _ = Printf.printf "Arity(%s) using %s is %d \n" k - (String.concat "," xs) n in *) - n) cm in - let bindm = SM.map ((Misc.flap H.support) <+> Misc.sort_and_compact) cm in - let argn = SM.fold (fun _ a n -> max a n) aritym 0 in - { aritym = aritym; bindm = bindm; argn = argn; cm = cm } - -(****************************************************************************) -(**************************** Generic Sequencers ****************************) -(****************************************************************************) - -let gen f sep xs = - xs |> Misc.map f |> String.concat sep - -let geni f sep xs = - xs |> Misc.mapi f |> String.concat sep - -let defn x n = - geni (fun i _ -> Printf.sprintf "%s%d : int" x i) ", " (Misc.range 0 n) - -(****************************************************************************) -(********************************* Translation ******************************) -(****************************************************************************) - -let tx_gd = function - | H.C p -> Printf.sprintf " assume %s;" (Misc.fsprintf Ast.Predicate.print p) - | H.K (k, xs) -> Printf.sprintf "%s\n () = %s(%s);" - (geni (Printf.sprintf " a%d = %s;") "\n" xs) - k - (geni (fun i _ -> Printf.sprintf "a%d" i) "," xs) - -let tx_hd = function - | "error", _ -> " fail;" - | _, xs -> Printf.sprintf " assume %s;" - (geni (fun i x -> Printf.sprintf " z%d == %s " i x) " and " xs) - -let tx_t k (head, guards) : string = - Printf.sprintf " if brandom then\n%s\n%s\n else" (gen tx_gd "\n" guards) (tx_hd head) - -let tx_def me = function - | "error" -> - "" - | k -> - let n = try SM.find k me.aritym with Not_found -> assertf "ERROR:no arity for %s" k in - let _ = Printf.printf "Arity(%s) := %d \n" k n in - Printf.sprintf "proc %s(%s) returns ()" k (defn "z" n) - -let tx_k me (k, cs) = - Printf.sprintf -" -%s -var %s, %s; -begin -%s - halt; - %s -end -" -(tx_def me k) -(defn "a" me.argn) -(gen (Printf.sprintf "%s : int") ", " (SM.find k me.bindm)) -(gen (tx_t me) "\n" cs) -(gen (fun _ -> "endif;") " " cs) - -let rewrite_eq s = - if Misc.is_substring s "assume" then - Misc.replace_substring " = " " == " s - else s - -let tx cs = - let me = create cs in - me.cm - |> Misc.sm_to_list - |> List.map (tx_k me) - |> String.concat "\n\n" - |> Misc.flip Misc.chop "\n" - |> List.map rewrite_eq - |> String.concat "\n" - -(***************************************************************************) -(***************************** Output Clauses ******************************) -(***************************************************************************) - -let dump f cs = - cs >> Format.printf "*************Horn Clauses************\n\n%a\n\n\n" (Misc.pprint_many true "\n" H.print) - |> tx - >> Format.printf "***********Interproc Program*********\n\n%s\n\n\n" - |> Misc.write_to_file (f^".ipc") - -let usage = "hornToInterproc.native [filename.pl]" - -let main usage = - print_now "\n \n \n \n \n"; - print_now "========================================================\n"; - print_now "© Copyright 2009 Regents of the University of California.\n"; - print_now "All Rights Reserved.\n"; - print_now "========================================================\n"; - print_now (Sys.argv |> Array.to_list |> String.concat " "); - print_now "\n========================================================\n"; - let fs = ref [] in - let _ = Arg.parse Co.arg_spec (fun s -> fs := s::!fs) usage in - match !fs with - | [f] -> parse f |> dump f - | _ -> assertf "I choke on too many/few files!" - -let _ = main usage diff --git a/external/fixpoint/kvgraph.ml b/external/fixpoint/kvgraph.ml deleted file mode 100644 --- a/external/fixpoint/kvgraph.ml +++ /dev/null @@ -1,211 +0,0 @@ -(* - * Copyright © 2009 The Regents of the University of California. All rights reserved. - * - * Permission is hereby granted, without written agreement and without - * license or royalty fees, to use, copy, modify, and distribute this - * software and its documentation for any purpose, provided that the - * above copyright notice and the following two paragraphs appear in - * all copies of this software. - * - * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY - * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES - * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN - * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY - * OF SUCH DAMAGE. - * - * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, - * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY - * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS - * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION - * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. - *) - -module Sy = Ast.Symbol -module P = Ast.Predicate -module Su = Ast.Subst -module C = FixConstraint -module Misc = FixMisc open Misc.Ops - -type rd = Bnd of Sy.t * Su.t | Lhs of Su.t | Grd | Junk - -let print_rd ppf = function - | Bnd (x, su) -> Format.fprintf ppf "Bnd (%a, %a)" Sy.print x Su.print su - | Lhs su -> Format.fprintf ppf "Lhs (%a)" Su.print su - | Grd -> Format.fprintf ppf "Grd" - | Junk -> Format.fprintf ppf "Junk" - -(************************************************************************) -(********************* Build Graph of Kvar Dependencies *****************) -(************************************************************************) - -module V : Graph.Sig.COMPARABLE with type t = C.refa = struct - type t = C.refa - let hash = C.refa_to_string <+> Hashtbl.hash - let compare = fun x y -> compare (C.refa_to_string x) (C.refa_to_string y) - let equal = fun x y -> C.refa_to_string x = C.refa_to_string y -end - -module Id : Graph.Sig.ORDERED_TYPE_DFT with type t = int * rd = struct - type t = int * rd - let default = 0, Junk - let compare = compare -end - -module G = Graph.Persistent.Digraph.ConcreteLabeled(V)(Id) -module VS = Set.Make(V) - -type t = G.t - -(************************************************************************) -(*************************** Dumping to Dot *****************************) -(************************************************************************) - -module DotGraph = struct - type t = G.t - module V = G.V - module E = G.E - let iter_vertex = G.iter_vertex - let iter_edges_e = G.iter_edges_e - let graph_attributes = fun _ -> [`Size (11.0, 8.5); `Ratio (`Float 1.29)] - let default_vertex_attributes = fun _ -> [`Shape `Box] - let vertex_name = function C.Kvar (_,k) -> Sy.to_string k | ra -> "C"^(string_of_int (V.hash ra)) - let vertex_attributes = fun ra -> [`Label (C.refa_to_string ra)] - let default_edge_attributes = fun _ -> [] - let edge_attributes = fun (_,(i,r),_) -> [`Label (Printf.sprintf "%d:%s" i (Misc.fsprintf print_rd r))] - let get_subgraph = fun _ -> None -end - -module Dot = Graph.Graphviz.Dot(DotGraph) - -let dump_graph s g = - s |> open_out - >> (fun oc -> Dot.output_graph oc g) - |> close_out - -(************************************************************************) -(********************* Constraints-to-Graph *****************************) -(************************************************************************) - -let xkvars_of_env env = - Sy.SMap.fold begin fun x r acc -> - r |> C.kvars_of_reft - |> List.map (fun z -> x,z) - |> (fun xks -> xks ++ acc) - end env [] - -let dsts_of_t c = - c |> C.rhs_of_t - |> C.ras_of_reft - |> List.map (function C.Kvar (_,k) -> C.Kvar (Su.empty, k) | ra -> ra) - -let edges_of_t c = - let eks = c |> C.env_of_t - |> xkvars_of_env - |> List.map (fun (x, (su, k)) -> (C.Kvar (Su.empty, k)), Bnd (x, su)) in - let gps = c |> C.grd_of_t - |> (fun p -> if P.is_tauto p then [] else [(C.Conc p, Grd)]) in - let lks = c |> C.lhs_of_t - |> C.ras_of_reft - |> List.map (function C.Kvar (su, k) -> (C.Kvar (Su.empty, k), Lhs su) | ra -> (ra, Grd)) in - c |> dsts_of_t - |> Misc.cross_product (lks ++ gps ++ eks) - |> List.map (fun ((ra, l), ra') -> (ra, (C.id_of_t c, l), ra')) - -(************************************************************************) -(*************************** Misc. Accessors ****************************) -(************************************************************************) - -let vertices_of_graph = fun g -> G.fold_vertex (fun v acc -> v::acc) g [] - -(* API *) -let filter_kvars f g = - g |> vertices_of_graph - |> List.filter (not <.> C.is_conc_refa) - |> List.filter f - |> Misc.sort_and_compact - -let get_edges f g vs = - vs |> Misc.flap (f g) - |> List.map (fun (_,(i,_),_) -> i) - |> Misc.sort_and_compact - -(* APU *) -let writes = get_edges G.pred_e -let reads = get_edges G.succ_e - -(* API *) -let k_reads g i k = - k >> (C.refa_to_string <+> Format.printf "Kvgraph.k_reads [IN] id=%d, k=%s\n" i) - |> G.succ_e g - |> Misc.map_partial (function (_,(j,x),_) when i=j -> Some x | _ -> None) - >> (Format.printf "Kvgraph.k_reads [OUT] %a \n" (Misc.pprint_many false "," print_rd)) - -(************************************************************************) -(********************* (Backwards) Reachability *************************) -(************************************************************************) - -let vset_of_list vs = List.fold_left (fun s v -> VS.add v s) VS.empty vs -let pre_star g vs = - (vs, VS.empty) - |> Misc.fixpoint begin function - | [], r -> ([], r), false - | ws, r -> ws |> List.filter (fun v -> not (VS.mem v r)) - |> Misc.tmap2 (Misc.flap (G.pred g), vset_of_list <+> VS.union r) - |> (fun x -> x, true) - end - |> fst |> snd - |> VS.elements - -(************************************************************************) -(****************************** Predicates ******************************) -(************************************************************************) - -let is_num_write g f v = - [v] |> writes g - |> List.length - |> f - -let undef_ks = fun g -> filter_kvars (is_num_write g ((=) 0)) g -let multi_wr_ks = fun g -> filter_kvars (is_num_write g ((<) 1)) g -let single_wr_ks = fun g -> filter_kvars (is_num_write g ((=) 1)) g - -let cone_nodes g = - g |> vertices_of_graph - |> List.filter C.is_conc_refa - |> pre_star g - -(*************************************************************************) -(******************************* API *************************************) -(*************************************************************************) - -let print_ks s ks = - ks |> Misc.map_partial (function C.Kvar (_,k) -> Some k | _ -> None) - |> Format.printf "[KVG] %s %a \n" s (Misc.pprint_many false "," Sy.print) - -(* API *) -let is_single_wr = fun g -> is_num_write g ((=) 1) -let is_single_rd = fun g -> G.succ_e g <+> Misc.groupby (snd3 <+> fst) <+> List.for_all (function [_] -> true | _ -> false) - -(* API *) -let empty = G.empty -let add = List.fold_left (fun g -> List.fold_left G.add_edge_e g <.> edges_of_t) -let remove = List.fold_left G.remove_vertex - -(* API *) -let cone_ks g = - g |> cone_nodes - |> List.filter (not <.> C.is_conc_refa) - -(* API *) -let cone_ids g = - g |> cone_nodes - |> writes g - -(* API *) -let print_stats g = - g >> dump_graph ((Constants.get_out_file ())^".dot") - >> (single_wr_ks <+> print_ks "single write kvs:") - >> (multi_wr_ks <+> print_ks "multi write kvs:") - >> (undef_ks <+> print_ks "undefined kvs:") - >> (cone_ks <+> print_ks "cone kvs:") - |> ignore diff --git a/external/fixpoint/kvgraph.mli b/external/fixpoint/kvgraph.mli deleted file mode 100644 --- a/external/fixpoint/kvgraph.mli +++ /dev/null @@ -1,37 +0,0 @@ -(* - * Copyright © 2009 The Regents of the University of California. All rights reserved. - * - * Permission is hereby granted, without written agreement and without - * license or royalty fees, to use, copy, modify, and distribute this - * software and its documentation for any purpose, provided that the - * above copyright notice and the following two paragraphs appear in - * all copies of this software. - * - * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY - * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES - * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN - * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY - * OF SUCH DAMAGE. - * - * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, - * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY - * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS - * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION - * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. - *) - -type t - -type rd = Bnd of Ast.Symbol.t * Ast.Subst.t | Lhs of Ast.Subst.t | Grd | Junk - -val empty : t -val remove : t -> FixConstraint.refa list -> t -val add : t -> FixConstraint.t list -> t -val print_stats : t -> unit -val cone_ids : t -> FixConstraint.id list -val writes : t -> FixConstraint.refa list -> FixConstraint.id list -val reads : t -> FixConstraint.refa list -> FixConstraint.id list -val k_reads : t -> FixConstraint.id -> FixConstraint.refa -> rd list -val filter_kvars : (FixConstraint.refa -> bool) -> t -> FixConstraint.refa list -val is_single_wr : t -> FixConstraint.refa -> bool -val is_single_rd : t -> FixConstraint.refa -> bool diff --git a/external/fixpoint/predAbs.ml b/external/fixpoint/predAbs.ml deleted file mode 100644 --- a/external/fixpoint/predAbs.ml +++ /dev/null @@ -1,1048 +0,0 @@ -(* - * Copyright © 2009 The Regents of the University of California. All rights reserved. - * - * Permission is hereby granted, without written agreement and without - * license or royalty fees, to use, copy, modify, and distribute this - * software and its documentation for any purpose, provided that the - * above copyright notice and the following two paragraphs appear in - * all copies of this software. - * - * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY - * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES - * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN - * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY - * OF SUCH DAMAGE. - * - * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, - * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY - * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS - * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION - * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. - *) - - -(*************************************************************) -(******************** Solution Management ********************) -(*************************************************************) - -module F = Format -module A = Ast -module E = A.Expression -module P = A.Predicate - -module Q = Qualifier -module QS = Q.QSet -module Sy = A.Symbol -module Su = A.Subst -module SM = Sy.SMap -module SS = Sy.SSet -module C = FixConstraint - -module BS = BNstats -module Co = Constants -module Cg = FixConfig -module H = Hashtbl -module PH = A.Predicate.Hash - -module CX = Counterexample -module Misc = FixMisc -module IM = Misc.IntMap -module IS = Misc.IntSet -open Misc.Ops - -let mydebug = false - -module Q2S = Misc.ESet (struct - type t = Sy.t * Sy.t - let compare x y = compare x y -end) - -module V : Graph.Sig.COMPARABLE with type t = Sy.t = struct - type t = Sy.t - let hash = Sy.to_string <+> H.hash - let compare = compare - let equal = (=) -end - - - -(* -let tag_of_qual2 = Misc.map_pair tag_of_qual - -module Q2S = Misc.ESet (struct - type t = Q.t * Q.t - let compare x y = compare (tag_of_qual2 x) (tag_of_qual2 y) -end) - -module V : Graph.Sig.COMPARABLE with type t = Q.t = struct - type t = Q.t - let hash = tag_of_qual <+> H.hash - let compare = fun q1 q2 -> compare (tag_of_qual q1) (tag_of_qual q2) - let equal = fun q1 q2 -> tag_of_qual q1 = tag_of_qual q2 -end - -*) - -module Id : Graph.Sig.ORDERED_TYPE_DFT with type t = unit = struct - type t = unit - let default = () - let compare = compare -end - -module G = Graph.Persistent.Digraph.ConcreteLabeled(V)(Id) - -module SCC = Graph.Components.Make(G) - -type bind = Bot | NonBot of Q.t list - -(* API *) -let meet_bind b1 b2 = match (b1, b2) with - | (Bot, _) -> b2 - | (_, Bot) -> b1 - | (NonBot x, NonBot y) -> NonBot (x ++ y) - -type t = - { tpc : ProverArch.prover - ; m : bind SM.t - ; om : (Q.t list) SM.t - ; wm : (Ast.Sort.t SM.t * Ast.Symbol.t * Ast.Sort.t) SM.t - ; assm : FixConstraint.soln (* invariant assumption for K, must be a fixpoint wrt constraints *) - (* ; qm : Q.t SM.t *) (* map from names to qualifiers *) - ; qs : Q.t list (* list of qualifiers *) - ; qleqs : Q2S.t (* (q1,q2) \in qleqs implies q1 => q2 *) - ; seen : IS.t (* constraint (ids) that have been "refined" once *) - (* counterexamples *) - ; step : CX.step (* which iteration *) - ; ctrace : CX.ctrace - ; lifespan : CX.lifespan - - (* stats *) - ; stat_simple_refines : int ref - ; stat_tp_refines : int ref - ; stat_imp_queries : int ref - ; stat_valid_queries : int ref - ; stat_matches : int ref - ; stat_umatches : int ref - ; stat_unsatLHS : int ref - ; stat_emptyRHS : int ref -} - -let lookup_bind k m = SM.find_default Bot k m - -let pprint_ps = - Misc.pprint_many false ";" P.print - -let pprint_dep ppf q = - F.fprintf ppf "(%a, %a)" P.print (Q.pred_of_t q) Q.print_args q - -let pprint_ds = - Misc.pprint_many false ";" pprint_dep - -let pprint_bind ppf = function - | Bot -> F.fprintf ppf "(false, BOT())" - | NonBot qs -> pprint_ds ppf qs - -let pprint_qs ppf = - F.fprintf ppf "[%a]" (Misc.pprint_many false ";" Q.print) - -let pprint_qs' ppf = - List.map (fst <+> snd <+> snd <+> fst) <+> pprint_qs ppf - - -(*************************************************************) -(************* Breadcrumbs for Cex Generation ****************) -(*************************************************************) - -let cx_iter c me = - { me with step = me.step + 1 } - -let cx_ctrace b c me = - let _ = if mydebug then F.printf "\nPredAbs.refine iter = %d cid = %d b = %b\n" - me.step (C.id_of_t c) b in - if b then { me with ctrace = IM.adds (C.id_of_t c) [me.step] me.ctrace } else me - - -let lookup_qualifiers k m = - lookup_bind k m - |> function | Bot -> [] - | NonBot qs -> qs - - -let cx_update ks kqsm' me : t = - List.fold_left begin fun me k -> - let qs = QS.of_list (lookup_qualifiers k me.m) in - let qs' = QS.of_list (SM.finds k kqsm') in - let kills = QS.elements (QS.diff qs qs') in - if Misc.nonnull kills - then {me with lifespan = SM.adds k [(me.step, kills)] me.lifespan} - else me - end me ks - -(*************************************************************) -(************* Constructing Initial Solution *****************) -(*************************************************************) - -(* - -let def_of_pred_qual (p, q) = - let qp = Q.pred_of_t q in - match A.unify_pred qp p with - | Some su -> (p, q, su) - | None -> assertf "ERROR: unify q=%s p=%s" (P.to_string qp) (P.to_string p) - -let map_of_bindings bs = - List.fold_left begin fun s (k, ds) -> - ds |> List.map Misc.single - |> Misc.flip (SM.add k) s - end SM.empty bs -*) - -let quals_of_bindings bm = - bm |> SM.range - |> Misc.flatten - (* |> Misc.map (snd <+> fst) *) - |> Misc.sort_and_compact - >> (fun qs -> Co.bprintf mydebug "Quals of Bindings: \n%a" (Misc.pprint_many true "\n" Q.print) qs; flush stdout) - -(************************************************************************) -(*************************** Dumping to Dot *****************************) -(************************************************************************) - -module DotGraph = struct - type t = G.t - module V = G.V - module E = G.E - let iter_vertex = G.iter_vertex - let iter_edges_e = G.iter_edges_e - let graph_attributes = fun _ -> [`Size (11.0, 8.5); `Ratio (`Fill (* Float 1.29*))] - let default_vertex_attributes = fun _ -> [`Shape `Box] - let vertex_name = Sy.to_string - let vertex_attributes = fun q -> [`Label (Sy.to_string q)] - let default_edge_attributes = fun _ -> [] - let edge_attributes = fun (_,(),_) -> [] - let get_subgraph = fun _ -> None -end - -module Dot = Graph.Graphviz.Dot(DotGraph) - -let dump_graph s g = - s |> open_out - >> (fun oc -> Dot.output_graph oc g) - |> close_out - - - -(* INV: qs' \subseteq qs *) -let update m k ds' = - let n' = List.length ds' in - let n = match SM.find_default Bot k m with - | Bot -> 1 + n' - | NonBot qs -> List.length qs in - let _ = asserts (n = 0 || n' <= n) "PredAbs.update: Non-monotone k = %s |ds| = %d |ds'| = %d \n" (Sy.to_string k) n n' in - ((n != n'), SM.add k (NonBot ds') m) - (* >> begin fun _ -> - if n' > n && n > 0 then - Co.bprintflush mydebug <| Printf.sprintf "OMFG: update k = %s |ds| = %d |ds'| = %d \n" - (Sy.to_string k) n n' - end - *) - -(* We must ensure there are NO duplicate k-q pairs in the update list. - * If there are duplicate KVars in the ks then the kqs must be grouped: - * a "k-q" binding is ONLY preserved IF #bindings = #copies-of-k - * If there are NO duplicate KVars there SHOULD BE no duplicate k-q pairs. *) - -let group_ks_kqs ks kqs = - if (Misc.cardinality ks = List.length ks) then - kqs (* no duplicate kvars *) - else - let km = SM.frequency ks in - kqs |> Misc.frequency - |> Misc.filter (fun ((k, _), n) -> n = SM.find_default 0 k km) - |> Misc.map fst - -let p_update me ks kqs = - (* let _ = Co.bprintflush mydebug (Printf.sprintf "p_update A: |kqs| = %d \n" (List.length kqs)) in *) - let kqs = group_ks_kqs ks kqs in - (* let _ = Co.bprintflush mydebug (Printf.sprintf "p_update B: |kqs| = %d \n" (List.length kqs)) in *) - let kqsm = SM.of_alist kqs in - let me = me |> (!Co.cex BS.time "cx_update" (cx_update ks) kqsm) in - List.fold_left begin fun (b, m) k -> - SM.finds k kqsm - |> update m k - |> Misc.app_fst ((||) b) - end (false, me.m) ks - |> Misc.app_snd (fun m -> { me with m = m }) - - -(* API *) -let top s ks = - ks (* |> List.partition (fun k -> SM.mem k s.m) - >> (fun (_, badks) -> Co.bprintf mydebug "WARNING: Trueing Unbound KVars = %s \n" (Misc.fsprintf (Misc.pprint_many false "," Sy.print) badks)) - |> fst *) - |> Misc.flip (p_update s) [] - |> snd - -(***************************************************************) -(**************** Query Current Solution ***********************) -(***************************************************************) - -let preds_of_bind = function - | Bot -> [A.pFalse] - | NonBot qs -> List.rev_map Q.pred_of_t qs - -let raw_read me k = match SM.maybe_find k me.m with - | None -> [] - | Some z -> preds_of_bind z - -(* API *) -let read me k = (me.assm k) ++ (raw_read me k) - -(* API *) -let read_bind s k = failwith "PredAbs.read_bind" - - -(***************************************************************) -(******************** Qualifier Instantiation ******************) -(***************************************************************) - - -(* DEBUG ONLY *) -let print_param ppf (x, t) = - F.fprintf ppf "%a:%a" Sy.print x Ast.Sort.print t -let print_params ppf args = - F.fprintf ppf "%a" (Misc.pprint_many false ", " print_param) args -let print_valid_binding ppf (x,y) = - F.fprintf ppf "[%a := %a]" Sy.print x Sy.print y -let print_valid_bindings ppf xys = - F.printf "[%a]" (Misc.pprint_many false "" print_valid_binding) xys - -(* -let dupfree_binding xys : bool = - let ys = List.map snd xys in - let ys' = Misc.sort_and_compact ys in - List.length ys = List.length ys' -*) - -let varmatch_ctr = ref 0 - -let varmatch (x, y) = - let _ = varmatch_ctr += 1 in - let (x,y) = Misc.map_pair Sy.to_string (x,y) in - if x.[0] = '@' then - let x' = Misc.suffix_of_string x 1 in - Misc.is_prefix x' y - else true - -let sort_compat t1 t2 = A.Sort.unify [t1] [t2] <> None - -let wellformed_qual f q = - Q.pred_of_t q - |> A.sortcheck_pred Theories.is_interp f -(* >> (F.printf "\nwellformed: id = %d q = @[%a@] result %b\n" (C.id_of_wf wf) Q.print q) *) -(* NEVER uncomment out the above. *) - -(***************************************************************) -(**************** Lazy Instantiation: WF-Index *****************) -(***************************************************************) - -let kvars_of_wf wf = - let check_trivial su = asserts (Su.is_empty su) "non-trivial substitution in WF constraint!" in - wf |> C.reft_of_wf - |> C.kvars_of_reft - >> List.iter (fst <+> check_trivial) - |> List.map snd - -let meet_wf_index k = function - | (Some (env, v, t), (env', (v', t', _))) when (v=v' && t=t') -> - env |> SM.filter (fun x _ -> SM.mem x env') - |> (fun env' -> (env', v, t)) - | (None, (env, (v, t, _))) -> - (env, v, t) - | _ -> - assertf "Conflicting v,t for WF %s" (Sy.to_string k) - -let upds_wf_index z wm ks = - List.fold_left begin fun wm k -> - SM.add k (meet_wf_index k (SM.maybe_find k wm, z)) wm - end wm ks - -(* API *) -let valid_after_substitution f su y = - Su.apply su y - |> (function None -> [y] | Some ye -> E.support ye) - |> List.for_all f - -let kvars_of_bind (x, r) = - let xv = (C.vv_of_reft r, A.eVar x) in - C.kvars_of_reft r |>: (fun (su, k) -> (Su.extend su xv, k)) - -let kvars_of_c c = - (C.kvars_of_reft <| C.rhs_of_t c) ++ - (Misc.flap kvars_of_bind <| C.kbindings_of_lhs c) - -(* MORE DEBUG NOISE -- NEVER DELETE! *) -let pp_ikxts i k xts = F.printf "\n refine_wf_index removes at id = %d, k = %a, xs = %a\n" i Sy.print k - (Misc.pprint_many false ", " Sy.print) (List.map fst xts) - -let refine_wf_index wm c = - let senv = C.senv_of_t c in - let ok z = SM.mem z senv in - let ksus = kvars_of_c c in (* [(su, k)] *) - List.fold_left begin fun wm (su, k) -> - let (xts, v, t) = SM.safeFind k wm "refine_wf_index" in - let (xts', dts) = Misc.tr_partition begin fun (x,t) -> A.Sort.is_kind t || - valid_after_substitution ok su x - end xts - in SM.add k (xts', v, t) wm - (* let xts' = Misc.filter (fun (x,t) -> A.Sort.is_kind t || valid_after_substitution ok su x) xts in - let _ = pp k xts; pp k xts' in - let _ = pp_ikxts (C.id_of_t c) k dts in - *) - end wm ksus - -let create_wf_index_basic ws = - List.fold_left begin fun wm w -> - let env = SM.map C.sort_of_reft <| C.env_of_wf w in - let r = C.reft_of_wf w in - upds_wf_index (env, r) wm (kvars_of_wf w) - end SM.empty ws - -let create_wf_index_refine_sort cs wm = - wm |> SM.map (fun (env,v,t) -> ((SM.to_list env), v, t)) - |> Misc.flip (List.fold_left refine_wf_index) cs - |> SM.map (fun (xts,v,t) -> (SM.of_list xts, v, t)) - -(* API *) -let create_wf_index cs ws = - ws |> create_wf_index_basic - |> ((!Constants.refine_sort) (create_wf_index_refine_sort cs)) - -(********************************************************************************) -(****** Brute Force (Post-Selection based) Qualifier Instantiation **************) -(********************************************************************************) - -type qual_binding = (Sy.t * Sy.t) list - -let is_valid_binding (xys : qual_binding) : bool = - List.for_all varmatch xys - -let valid_bindings ys (x,_) = - ys |> List.map (fun y -> (x, y)) - |> List.filter varmatch - -let inst_qual env ys evv (q : Q.t) : Q.t list = - let vve = (Q.vv_of_t q, evv) in - match Q.params_of_t q with - | [] -> - [(Q.inst q [vve])] - | xts -> - xts - (* >> F.printf "\n\ninst_qual: params q = %a: %a" Q.print q print_params *) - |> List.map (valid_bindings ys) (* candidate bindings *) - |> Misc.product (* generate combinations *) - (* >> (List.iter (F.printf "\ninst_qual: pre-binds = %a\n" print_valid_bindings)) *) - |> List.filter is_valid_binding (* remove bogus bindings *) - (* >> (List.iter (F.printf "\ninst_qual: post-binds = %a\n" print_valid_bindings)) *) - |> List.rev_map (List.map (Misc.app_snd A.eVar)) (* instantiations *) - |> List.rev_map (fun xes -> Q.inst q (vve::xes)) (* quals *) - (* >> (F.printf "\n\ninst_qual: result q = %a:\n%a DONE\n" Q.print q (Misc.pprint_many true "" Q.print)) *) - -let inst_binds env = - env |> SM.to_list - |> Misc.filter (not <.> A.Sort.is_func <.> snd) - -let inst_ext env vv t qs = - let _ = Misc.display_tick () in - let ys = inst_binds env |>: fst in - let env' = Misc.flip SM.maybe_find (SM.add vv t env) in - qs |> List.filter (Q.sort_of_t <+> sort_compat t) - |> Misc.flap (inst_qual env ys (A.eVar vv)) - |> Misc.filter (wellformed_qual env') - -(********************************************************************************) -(****** Sort Based Qualifier Instantiation **************************************) -(********************************************************************************) - -(* [ (su', (x,y) : xys) | (su, xys) <- wkl - , (y, ty) <- yts - , varmatch (x, y) - , Some su' <- unifyWith su [tx] [ty] ] *) - -let ext_bindings yts wkl (x, tx) = - let yts = List.filter (fun (y,_) -> varmatch (x, y)) yts in - Misc.tr_rev_flap (fun (su, xys) -> - Misc.map_partial (fun (y, ty) -> - match A.Sort.unifyWith su [tx] [ty] with - | None -> None - | Some su' -> Some (su', (x,y) :: xys) - ) yts - ) wkl - -let inst_qual_sorted yts vv t q = - let (qvv0, t0) :: xts = Q.all_params_of_t q in - match A.Sort.unify [t0] [t] with - | Some su0 -> - xts |> List.fold_left (ext_bindings yts) [(su0, [(qvv0, vv)])] (* generate subs-bindings *) - |> List.rev_map (List.rev <.> snd) (* extract sorted bindings *) - |> List.rev_map (List.map (Misc.app_snd A.eVar)) (* instantiations *) - |> List.rev_map (Q.inst q) (* quals *) - | None -> [] - -let inst_ext_sorted env vv t qs = - let _ = Misc.display_tick () in - let yts = inst_binds env in - Misc.flap (inst_qual_sorted yts vv t) qs - -(***************************************************************) -(**************** Lazy Instantiation ***************************) -(***************************************************************) - -let inst_ext qs ckEnv env v t : Q.t list = - let instf = if !Co.sorted_quals then inst_ext_sorted else inst_ext in - let env' = Misc.flip SM.maybe_find (SM.add v t ckEnv) in - qs |> instf env v t - |> Misc.filter (wellformed_qual env') - - -(* -let is_non_trivial_var me lps su = - let cxs = SS.of_list <| Misc.flap P.support lps in - let ok z = SS.mem z cxs in - fun y _ -> valid_after_substitution ok su y -*) - -let is_non_trivial_var me c su = - let senv = C.senv_of_t c in - let ok z = SM.mem z senv in - fun y _ -> valid_after_substitution ok su y - - -(* RJ: DO NOT DELETE EVER! *) -let ppBinding k zs = - F.printf "ppBind %a := %a \n" - Sy.print k - (Misc.pprint_many false ", " Q.print) zs - -(* API *) -let lazy_instantiate_with me c lps k su : Q.t list = - let (env,v,t) = SM.safeFind k me.wm "lazy_instantiate" in - let env' = SM.filter (is_non_trivial_var me c (* lps *) su) env in - inst_ext me.qs env env' v t - (* >> ppBinding k *) - |> ((++) (SM.find_default [] k me.om)) - - -(***************************************************************) -(**************** Refinement ***********************************) -(***************************************************************) - -(*** {{{ KEEP AROUND FOR DEBUG PRINTING SIGH. -let rhs_cands me = function - | C.Kvar (su, k) -> - k - (* >> (fun k -> Co.bprintflush mydebug ("rhs_cands: k = "^(Sy.to_string k)^"\n")) *) - |> p_read me - (* >> (fun xs -> Co.bprintflush mydebug ("rhs_cands: size="^(string_of_int (List.length xs))^" BEGIN \n")) *) - |>: (Misc.app_snd (Misc.flip A.substs_pred su)) - (* >> (fun xs -> Co.bprintflush mydebug ("rhs_cands: size="^(string_of_int (List.length xs))^" DONE\n")) *) - | _ -> [] -}}} *) - -let get_lhs me c = BS.time "preds_of_lhs" (C.preds_of_lhs (read me)) c - -let bind_read me k = SM.find_default Bot k me.m - -let is_bot_reft me (_,_,ras) = - List.exists begin function C.Conc _ -> false | C.Kvar (_,k) -> - (bind_read me k = Bot) - end ras - -let is_bot_lhs me c = - C.kbindings_of_lhs c - |>: snd - |> List.exists (is_bot_reft me) - -let is_bot_rhs me c = - is_bot_reft me <| C.rhs_of_t c - -let make_cand k su q = - let qp = Q.pred_of_t q in - let qp' = A.substs_pred qp su in - ((k, q), qp') - -let quals_of_bind me c lhs k su = function - | NonBot qs -> - (qs, me) - | Bot -> - let qs = lazy_instantiate_with me c lhs k su in - let (_, me) = p_update me [k] (qs |>: (fun q -> (k,q))) in - (qs, me) - -(* only called when ALL RHS k are NONBOT *) -let rhs_cands_noinst me = function - | C.Kvar (su, k) -> begin match bind_read me k with - | Bot -> assertf "rhs_cands_noinst" - | NonBot qs -> qs |>: make_cand k su - end - | _ -> [] - -let rhs_cands_noinst me c = - c |> C.rhs_of_t - |> thd3 - |> BS.time "rhs_cands" (Misc.flap (rhs_cands_noinst me)) - -(* only called when SOME RHS k is BOT *) -let rhs_cands_inst c lhs me = function - | C.Conc _ -> - (me, []) - | C.Kvar (su, k) -> - let (qs, me) = SM.safeFind k me.m "rhs_cands" |> quals_of_bind me c lhs k su in - (me, qs |>: make_cand k su) - -let rhs_cands_inst me c lps = - let (_, _, ras) = C.rhs_of_t c in - let (me, zs) = Misc.mapfold (rhs_cands_inst c lps) me ras in - (Misc.flatten zs, me) - -let lhs_preds me c = - let lps = BS.time "preds_of_lhs" (C.preds_of_lhs (read me)) c in - (lps, me) - -let refine_sort_bot_rhs me c = - let (lps, me) = lhs_preds me c in - let (rcs, me) = rhs_cands_inst me c lps in - let senv = C.senv_of_t c in - let rcs = Misc.filter (fun (_,p) -> C.wellformed_pred senv p) rcs in - (true, me, lps, rcs) - -let refine_sort_first_time me c = - let (lps, me) = lhs_preds me c in - let rcs = rhs_cands_noinst me c in - let senv = C.senv_of_t c in - let rcs' = Misc.filter (fun (_,p) -> C.wellformed_pred senv p) rcs in - (List.length rcs != List.length rcs', me, lps, rcs') - -let refine_sort_default me c = - let (lps, me) = lhs_preds me c in - let rcs = rhs_cands_noinst me c in - (false, me, lps, rcs) - -let refine_sort me c = - if is_bot_rhs me c then - refine_sort_bot_rhs me c - else if not (IS.mem (C.id_of_t c) (me.seen)) then - refine_sort_first_time me c - else - refine_sort_default me c - -let is_trivial_rhs me c = - let is_trivial_refa me = function - | C.Conc _ -> true - | C.Kvar (_,k) -> bind_read me k = NonBot [] - in - C.rhs_of_t c - |> C.ras_of_reft - |> List.for_all (is_trivial_refa me) - -let is_trivial_c me c = is_bot_lhs me c || is_trivial_rhs me c - -let refine_match me lps rcs = - let lt = PH.create 17 in - let _ = List.iter (fun p -> PH.add lt p ()) lps in - let (x1,x2) = List.partition (fun (_,p) -> PH.mem lt p) rcs in - let _ = me.stat_matches += (List.length x1) in - (List.map fst x1, x2) - -let check_tp me env vv t lps = function [] -> [] | rcs -> - me.tpc#set_filter env vv lps rcs - >> (fun _ -> me.stat_tp_refines += 1) - >> (fun _ -> me.stat_imp_queries += List.length rcs) - >> (fun rv -> me.stat_valid_queries += List.length rv) - -let refine_tp me c lps x2 = - if C.is_simple c then - (me.stat_simple_refines += 1) >| [] - else - let senv = C.senv_of_t c in - let vv = C.vv_of_t c in - let t = C.sort_of_t c in - BS.time "check tp" (check_tp me senv vv t lps) x2 - -let refine me c = - if is_trivial_c me c then - (false, me) - else - let (ch, me, lps, rcs) = refine_sort me c in - if BS.time "lhs_contra" (List.exists P.is_contra) lps then - let _ = me.stat_unsatLHS += 1 in - let _ = me.stat_umatches += List.length rcs in - (ch, me) - else - let rcs = List.filter (fun (_,p) -> not (P.is_contra p)) rcs in - let (kqs1, x2) = refine_match me lps rcs in - let kqs2 = refine_tp me c lps x2 in - let ks = C.rhs_of_t c |> C.kvars_of_reft |>: snd in - let (ch', me) = p_update me ks (kqs1 ++ kqs2) in - (ch || ch', me) - -let refine me c = - let (ch, me) = refine me c in - (ch, {me with seen = IS.add (C.id_of_t c) me.seen}) - -let refine me c = - let me = me |> (!Co.cex cx_iter c) in - let (b, me) = refine me c in - let me = me |> (!Co.cex cx_ctrace b c) in - (b, me) - - - -(***************************************************************) -(************************* Satisfaction ************************) -(***************************************************************) - -let unsat me c = - let s = read me in - let (vv,t,_) = C.lhs_of_t c in - let lps = C.preds_of_lhs s c in - let rhsp = c |> C.rhs_of_t |> C.preds_of_reft s |> A.pAnd in - let k = Sy.of_string "k" in - let kq = (k, Q.create k k Ast.Sort.t_int [] A.pTrue) in - not ((check_tp me (C.senv_of_t c) vv t lps [(kq, rhsp)]) = [kq]) - -(****************************************************************) -(************* Minimization: For Prettier Output ****************) -(****************************************************************) - -(* -let canonize_subs = - Su.to_list <+> List.sort (fun (x,_) (y,_) -> compare x y) - -let subst_leq = - Misc.map_pair canonize_subs <+> Misc.isPrefix -*) - -let args_leq q1 q2 = - let qArgs = List.map snd <.> Q.args_of_t in - try List.for_all2 (=) (qArgs q1) (qArgs q2) with _ -> false - -(* P(v,x,y,z) => Q(v,x) if P => Q held and _intersection_ of args match. *) -let def_leq s q1 q2 = - Q2S.mem (Q.name_of_t q1, Q.name_of_t q2) s.qleqs && args_leq q1 q2 - -let pred_of_bind_name q = - let name = q |> Q.name_of_t in - let args = q |> Q.args_of_t |> List.map snd in - A.pBexp (A.eApp (name, args)) - -let pred_of_bind_raw = Q.pred_of_t - -let pred_of_bind q = - if !Co.shortannots - then pred_of_bind_name q - else pred_of_bind_raw q - -let min_binds_bot ds = - match Misc.list_find_maybe (P.is_contra <.> pred_of_bind_raw) ds with - | None -> ds - | Some d -> [d] - -(* API *) -let min_binds s ds = ds |> min_binds_bot |> Misc.rootsBy (def_leq s) -let min_read s k = SM.find_default Bot k s.m |> function - | Bot -> [A.pFalse] - | NonBot qs -> qs |> min_binds s |>: pred_of_bind -let min_read s k = if !Co.minquals then min_read s k else read s k -let min_read s k = BS.time "min_read" (min_read s) k - -let close_env qs sm = - qs |> Misc.flap (Q.pred_of_t <+> P.support) - |> Misc.filter (not <.> Misc.flip SM.mem sm) - |> Misc.map (fun x -> (x, Ast.Sort.t_int)) - |> SM.of_list - |> SM.extend sm - -let rename_vv q q' = - List.combine (Q.all_params_of_t q |>: fst) (Q.all_params_of_t q' |>: fst) - |> List.filter (fun (x, y) -> not (x = y)) - |> List.map (fun (x, y) -> (y, A.eVar x)) - |> Su.of_list - |> A.substs_pred (Q.pred_of_t q') - |> (fun p' -> (q', p')) - -let sm_of_qual sm q = - q |> Q.all_params_of_t - |> SM.of_list - |> SM.extend sm - -(* check_leq tp sm q qs = [q' | q' <- qs, Z3 |- q => q'] *) -let check_leq (tp : ProverArch.prover) sm (q : Q.t) (qs : Q.t list) : Q.t list = - let vv = Q.vv_of_t q in - let lps = [Q.pred_of_t q] in - let sm = q |> sm_of_qual sm |> close_env qs in - qs |> List.map (rename_vv q) (* (fun q -> (q, Q.pred_of_t q)) *) - (* >> (List.map fst <+> F.printf "CHECK_TP: %a IN %a \n" Q.print q pprint_qs) *) - |> tp#set_filter sm vv lps - (* >> F.printf "CHECK_TP: %a OUT %a \n" Q.print q pprint_qs *) - -let qimps_of_partition tp sm qs = - foreach qs begin fun q -> - let qs' = check_leq tp sm q qs in - foreach qs' begin fun q' -> - (q, q') - end - end - -let wellformed_qual sm q = - let sm = sm_of_qual sm q in - A.sortcheck_pred Theories.is_interp (fun x -> SM.maybe_find x sm) (Q.pred_of_t q) -(* >> (fun res ->F.printf "wellformed_qual: q = %a, res = %b\n" Q.print q res) - *) - -let qleqs_of_qs ts sm cs ps qs = - let tp = TpNull.create ts sm cs ps in - qs |> Misc.filter (wellformed_qual sm) - |> Misc.groupby (List.map snd <.> Q.all_params_of_t) (* Q.sort_of_t *) - |> Misc.flap (qimps_of_partition tp sm) - |> Misc.flatten - |> Misc.map (Misc.map_pair Q.name_of_t) - |> Q2S.of_list - - -(*************************************************************************) -(*************************** Creation ************************************) -(*************************************************************************) - -let create_qleqs ts sm ps consts qs = - if !Co.minquals - then BS.time "Annots: make qleqs" (qleqs_of_qs ts sm consts ps) qs - else Q2S.empty - -let create obm cs ws ts sm ps consts assm qs bm = - { m = bm - ; om = SM.map (function Bot -> [] | NonBot qs -> qs) obm - ; wm = create_wf_index cs ws - ; assm = assm -(*; qm = qs |>: Misc.pad_fst Q.name_of_t |> SM.of_list *) - ; qs = qs - ; qleqs = Misc.with_ref_at Constants.strictsortcheck false - (fun () -> create_qleqs ts sm consts ps qs) - ; tpc = TpNull.create ts sm ps consts - ; seen = IS.empty - - (* Counterexamples *) - ; step = 0 - ; ctrace = IM.empty - ; lifespan = SM.empty - - (* Stats *) - ; stat_simple_refines = ref 0 - ; stat_tp_refines = ref 0; stat_imp_queries = ref 0 - ; stat_valid_queries = ref 0; stat_matches = ref 0 - ; stat_umatches = ref 0; stat_unsatLHS = ref 0 - ; stat_emptyRHS = ref 0 - } - -(***************************************************************) -(****************** Sort Check Based Refinement ****************) -(***************************************************************) -(* LAZYINST -let refts_of_c c = - [ C.lhs_of_t c ; C.rhs_of_t c] ++ (C.env_of_t c |> C.bindings_of_env |>: snd) - -let refine_sort_reft env me ((vv, so, ras) as r) = - let env' = SM.add vv r env in - let ks = r |> C.kvars_of_reft |>: snd in - (* let _ = let s = String.concat ", " (List.map Sy.to_string ks) in Co.bprintflush mydebug ("\n refine_sort_reft ks = "^s^"\n") in *) - ras - |> Misc.flap (rhs_cands me) (* OMFG blowup due to FLAP if kv appears multiple times...*) - |> Misc.filter (fun (_, p) -> C.wellformed_pred env' p) - |> List.rev_map fst -(* |> (fun xs -> Co.bprintflush mydebug (Printf.sprintf "refine_sort_reft map: size = %d\n" (List.length xs)); - List.rev_map fst xs) - >> (fun _ -> Co.bprintflush mydebug "\n refine_sort_reft TICK 4 \n") - *) - |> p_update me ks - |> snd - -let refine_sort me c = - let env = C.env_of_t c in - c (* >> (fun _ -> Co.bprintflush mydebug ("\n refine_sort TICK 0 id = "^(string_of_int (C.id_of_t c))^"\n")) *) - |> refts_of_c - |> List.fold_left (refine_sort_reft env) me - (* >> (fun _ -> Co.bprintflush mydebug "\n refine_sort TICK 2 \n") *) -*) - -(****************************************************************************) -(****************** APPLYING FACTS FOR INCREMENTAL SOLVING ******************) -(****************************************************************************) - -(* LAZYINST - -(* Take in a solution of things that are known to be true, kf. Using - this, we can prune qualifiers whose negations are implied by - information in kf *) -let update_pruned ks me fqm = - List.fold_left begin fun m k -> - if not (SM.mem k fqm) then m else - let false_qs = SM.safeFind k fqm "update_pruned 1" in - let qs = SM.safeFind k m "update_pruned 2" - |> List.filter (fun q -> (not (List.mem (k, q) false_qs))) - in SM.add k qs m - end me.m ks - -let apply_facts_c kf me c = - let env = C.senv_of_t c in - let (vv, t, lras) = C.lhs_of_t c in - let (_,_,ras) as rhs = C.rhs_of_t c in - let ks = rhs |> C.kvars_of_reft |> List.map snd in - let lps = C.preds_of_lhs kf c in (* Use the known facts here *) - let rcs = Misc.flap (rhs_cands me) ras in - if rcs = [] then (* Nothing on the right hand side *) - me - else if check_tp me env vv t lps [(0, A.pFalse)] = [0] then - me - else - let rcs = List.filter (fun (_,p) -> not (P.is_contra p)) rcs - |> List.map (fun (x,p) -> (x, A.pNot p)) in - (* can we prove anything on lhs implies something on rhs is false? *) - let fqs = BS.time "apply_facts tp" (check_tp me env vv t lps) rcs in - let fqm = fqs |> Misc.kgroupby fst |> SM.of_list in - {me with m = BS.time "update pruned" (update_pruned ks me) fqm} - -let apply_facts cs kf me = - let numqs = me.m |> Ast.Symbol.SMap.to_list - |> List.map snd |> List.concat |> List.length in - let sol = List.fold_left (apply_facts_c kf) me cs in - let numqs' = sol.m |> Ast.Symbol.SMap.to_list - |> List.map snd |> List.concat |> List.length in - let _ = Printf.printf "Started with %d, proved %d false\n" numqs (numqs-numqs') in - sol - -*) - -(* LAZYINST: map each KVAR to BOT *) -let initial_solution c = - c.Cg.ws - |> Misc.flap kvars_of_wf - |>: (fun k -> (k, Bot)) - |> SM.of_list - -(* API *) -let create c = function - | None -> - initial_solution c - |> create c.Cg.bm c.Cg.cs c.Cg.ws c.Cg.ts c.Cg.uops c.Cg.ps c.Cg.cons c.Cg.assm c.Cg.qs - (* LAZYINST: this is factored into the canonical env for each K - >> (fun _ -> Co.bprintflush mydebug "\nBEGIN: refine_sort\n") - |> ((!Constants.refine_sort) Misc.flip (List.fold_left refine_sort) c.Cg.cs) - >> (fun _ -> Co.bprintflush mydebug "\nEND: refine_sort\n") - *) - | _ -> assertf "PredAbs.create: does not support facts" - -(* API *) -let empty () = create Cg.empty None - -(* API *) -let meet me you = {me with m = SM.extendWith (fun _ -> meet_bind) me.m you.m} - -(****************************************************************) -(************* Simplify Solution Using min_read *****************) -(****************************************************************) - -(* let minb s bs = min_binds s bs - >> Printf.printf "minBinds: [%a] \n\n" pprint_ds - *) - -let simplify s = { s with m = SM.map begin function - | Bot -> Bot - | NonBot qs -> NonBot (min_binds s qs) - end s.m - } - -(************************************************************************) -(****************** Counterexample Generation ***************************) -(************************************************************************) - - -let ctr_examples me cs ucs = - let cx = CX.create me.tpc (read me) cs me.ctrace me.lifespan in - List.map (CX.explain cx) ucs - - -(*******************************************************************************) -(******************************** Profile/Stats ********************************) -(*******************************************************************************) - -let print_m ppf s = - SM.iter begin fun k -> function - | Bot -> F.fprintf ppf "solution: %a := [%a] \n\n" Sy.print k pprint_bind Bot - | NonBot ds -> ds - |> () (!Co.minquals) (min_binds s) - |> F.fprintf ppf "solution: %a := [%a] \n\n" Sy.print k pprint_ds - end s.m - -let print_qs ppf s = - s.qs >> (fun _ -> F.fprintf ppf "//QUALIFIERS \n\n") - |> F.fprintf ppf "%a" (Misc.pprint_many true "\n" Q.print) -(* |> List.iter (F.fprintf ppf "%a" Q.print) *) - |> ignore - -(* API *) -let print ppf s = s >> print_m ppf >> print_qs ppf |> ignore - - -let botInt = function - | Bot -> 1 - | NonBot qs -> if List.exists (Q.pred_of_t <+> P.is_contra) qs then 1 else 0 - -let bindSize = function - | Bot -> 0 - | NonBot x -> List.length x - -(* API *) -let print_stats ppf me = - let (sum, max, min, bot) = - (SM.fold (fun _ b x -> (+) x (bindSize b)) me.m 0, - SM.fold (fun _ b x -> max x (bindSize b)) me.m min_int, - SM.fold (fun _ b x -> min x (bindSize b)) me.m max_int, - SM.fold (fun _ b x -> x + botInt b) me.m 0) in - let n = SM.length me.m in - let avg = (float_of_int sum) /. (float_of_int n) in - F.fprintf ppf "# Vars: (Total=%d, False=%d) Quals: (Total=%d, Avg=%f, Max=%d, Min=%d)\n" - n bot sum avg max min; - F.fprintf ppf "#Iteration Profile = (si=%d tp=%d unsatLHS=%d emptyRHS=%d) \n" - !(me.stat_simple_refines) !(me.stat_tp_refines) - !(me.stat_unsatLHS) !(me.stat_emptyRHS); - F.fprintf ppf "#Queries: umatch=%d, match=%d, ask=%d, valid=%d\n" - !(me.stat_umatches) !(me.stat_matches) !(me.stat_imp_queries) - !(me.stat_valid_queries); - me.tpc#print_stats ppf - -(* API *) -let save fname s = - let oc = open_out fname in - let ppf = F.formatter_of_out_channel oc in - F.fprintf ppf "@[%a@] \n" print s; - close_out oc - -let key_of_quals qs = - qs |> List.map P.to_string - |> List.sort compare - |> String.concat "," - -(* API *) -let mkbind qs = assertf "PredAbs.mkBind not supported in lazyinst" (* NonBot qs *)(* Misc.flatten <+> Misc.sort_and_compact *) - -(* API *) -let dump s = - s.m - |> SM.to_list - |> List.map (snd <+> preds_of_bind) - |> Misc.groupby key_of_quals - |> List.map begin function - | [] -> assertf "impossible" - | (ps::_ as pss) -> Co.bprintf mydebug "SolnCluster: preds %d = size %d \n" (List.length ps) (List.length pss) - end - |> ignore diff --git a/external/fixpoint/predAbs.mli b/external/fixpoint/predAbs.mli deleted file mode 100644 --- a/external/fixpoint/predAbs.mli +++ /dev/null @@ -1,16 +0,0 @@ -(* - * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY - * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES - * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN - * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY - * OF SUCH DAMAGE. - * - * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, - * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY - * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS - * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION - * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. - * - *) - -include SolverArch.DOMAIN diff --git a/external/fixpoint/prepass.ml b/external/fixpoint/prepass.ml deleted file mode 100644 --- a/external/fixpoint/prepass.ml +++ /dev/null @@ -1,238 +0,0 @@ -(* - * Copyright © 2009 The Regents of the University of California. All rights reserved. - * - * Permission is hereby granted, without written agreement and without - * license or royalty fees, to use, copy, modify, and distribute this - * software and its documentation for any purpose, provided that the - * above copyright notice and the following two paragraphs appear in - * all copies of this software. - * - * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY - * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES - * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN - * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY - * OF SUCH DAMAGE. - * - * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, - * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY - * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS - * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION - * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. - *) - - -(** This module implements various constraint validation and simplification - * prepasses *) - -module BS = BNstats -module F = Format -module A = Ast -module Co = Constants -module P = A.Predicate -module E = A.Expression -module So = A.Sort -module Q = Qualifier -module PH = A.Predicate.Hash -module Sy = A.Symbol -module SM = Sy.SMap -module C = FixConstraint - -module Misc = FixMisc -module IM = Misc.IntMap - -open Misc.Ops -let mydebug = false - -(***************************************************************) -(*********** Input Constraint & Solution Validation ************) -(***************************************************************) - - -(* 3a. check that lhs/rhs have same sort *) -let phase3a = - List.iter begin fun c -> - let (vv1,t1,_) = C.lhs_of_t c in - let (vv2,t2,_) = C.rhs_of_t c in - if not (vv1 = vv2 && t1 = t2) then - let msg = "Invalid Constraints 3a (LHS/RHS sort mismatch)" in - let _ = Format.printf "%s in \n %a " msg (C.print_t None) c in - raise (C.BadConstraint (C.id_of_t c, C.tag_of_t c, msg)) - end - -(* 3b. check that sorts are consistent across constraints. - * DEPRECATED, due to the following counterexample. - * Suppose you have a function: - - concatMap :: forall a, t. (a -> [t]) -> [a] -> [t] - concatMap f [] = [] - concatMap f (y:ys) = (f y) ++ (concatMap f ys) - - * Now, "f" gets a template - - (y:a) -> [t] - - * And inside the body of concatMap, the recursive call - * creates a function subtyping on "f" - - ... |- (y:a) -> [t] <: (y:a) -> t - - * which after splitting gives a constraint - - ...,(y:a) |- t <: t (1) - - * Now, suppose you have a call to concatMap - - baz = concatMap (\x -> [x]) - - * Here, concatMap is actually "instantiated" with a - * different type variable, so at this instance, - - concatMap :: ((y:b) -> [b]) -> [b] -> [b] - - * That is, a, t are instantiated with b, b. Now, the - * application creates another function subtyping, and - * this time you end up with - - ...,(y:b) |- b <: b (2) - -let phase3b cs = - let memo = Hashtbl.create 17 in - List.iter begin fun c -> - let env = C.env_of_t c in - let id = C.id_of_t c in - SM.iter begin fun x (_,t,_) -> - if Hashtbl.mem memo x then - let xt = Hashtbl.find memo x in - asserts (t = xt) "Invalid Constraints 3b: %d (%s is %s and %s)" - id (Sy.to_string x) (So.to_string t) (So.to_string xt) - else - Hashtbl.replace memo x t - end env - end cs -*) - -(* 4. check that each tag has the same arity [a] *) -let phase4 a = - List.iter begin fun c -> - if (a = List.length (fst (C.tag_of_t c))) then () else - raise (C.BadConstraint (C.id_of_t c, C.tag_of_t c, "Tag Arity Error")) - end - -(* 5. check that all refinements are well-formed *) -let validate_vars env msg vs = - List.iter begin fun v -> - if not (SM.mem v env) then - let _ = F.printf "ERROR: out_of_scope variable %a (%s)" Sy.print v (Lazy.force msg) in - failwith ("Out_of_scope: "^(Sy.to_string v)) - end vs - -let validate_pred env msg p = - P.support p - |> BS.time "validate_vars" (validate_vars env msg) - -let validate_reft s env msg ((vv,t,_) as r) = - let env = SM.add vv t env in - r |> BS.time "preds_of_reft" (C.preds_of_reft s) - |> List.iter (validate_pred env msg) - -let phase5 s cs = - Misc.filter begin fun c -> - try - let msg = C.to_string c in - let env = C.senv_of_t c in - let rhs = C.rhs_of_t c in - List.iter (validate_pred env (lazy (msg^" BAD LHS"))) (C.preds_of_lhs s c); - BS.time "valid rhs" (validate_reft s env (lazy (msg^"\n BAD RHS"))) rhs; - true - with ex -> begin - let id = C.id_of_t c in - let tag = C.tag_of_t c in - let msg = Printexc.to_string ex in - Format.printf "Phase5: exn = %s on constraint: %a \n" msg (C.print_t None) c; - raise (C.BadConstraint (id, tag, msg)) - end - end cs - - -(* API *) -let validate a s cs = - cs >> phase3a - (* >> phase3b : RJ: this invariant need not hold! *) - >> phase4 a - |> phase5 s - |> (fun cs' -> asserts (List.length cs = List.length cs') "Validation") - -(******************************************************************************) -(******************* Validating Well-Formedness Constraints *******************) -(******************************************************************************) - -let validate_wf wfvs = - C.reft_of_wf - <+> C.kvars_of_reft - <+> List.fold_left (fun wfvars (_, k) -> Sy.SSet.add k wfvars) wfvs - (* if Sy.SSet.mem k wfvars then - let _ = F.printf "ERROR: variable %a is checked for WF twice\n" Sy.print k in - assert false - else *) - -(* API *) -let validate_wfs ws = - ws |> List.fold_left begin fun (ws, wfvars) wf -> - (wf :: ws, validate_wf wfvars wf) - end ([], Sy.SSet.empty) - |> fst - - -(***************************************************************) -(*********************** Constraint Profiling *****************) -(***************************************************************) - -let profile_cstr im c = - SM.fold begin fun _ (_,_,rs) ((a, b, c, d) as pfl) -> - match rs with [] -> (a+1, b, c, d+1) | _::_ -> begin - List.fold_left begin fun (sz, csz, ksz, esz) r -> match r with - | C.Conc _ -> (sz+1, csz+1, ksz, esz) - | _ -> (sz+1, csz, ksz+1, esz) - end pfl rs - end - end (C.env_of_t c) (0,0,0,0) - |> fun pfl -> IM.add (C.id_of_t c) pfl im - -let dump_profile im = - let (tsz, tcsz, tksz, tesz) = - IM.fold begin fun i (sz, csz, ksz, esz) (tsz, tcsz, tksz, tesz) -> - Co.bprintf mydebug - "ctag %d: binds=%d, cbinds=%d, kbinds=%d, ebinds=%d \n" - i sz csz ksz esz; - (tsz + sz, tcsz + csz, tksz + ksz, tesz + esz) - end im (0,0,0,0) in - Co.bprintf mydebug - "Total binds=%d, cbinds=%d, kbinds=%d, ebinds=%d \n" - tsz tcsz tksz tesz - -let profile1 sri = - sri |> Cindex.to_list - |> List.fold_left profile_cstr IM.empty - |> dump_profile - -let key_of_cstr c = - c |> C.env_of_t - |> C.bindings_of_env - |> List.map fst - |> List.map Sy.to_string - |> List.sort compare - |> String.concat "," - -let profile2 sri = - sri |> Cindex.to_list - |> Misc.groupby key_of_cstr - |> List.length - |> fun n -> Co.bprintf mydebug "Constraint Clusters = %d \n" n - -(* API *) -let profile sri = - sri - >> profile1 - >> profile2 - |> ignore - diff --git a/external/fixpoint/prepass.mli b/external/fixpoint/prepass.mli deleted file mode 100644 --- a/external/fixpoint/prepass.mli +++ /dev/null @@ -1,31 +0,0 @@ -(* - * Copyright © 2009 The Regents of the University of California. All rights reserved. - * - * Permission is hereby granted, without written agreement and without - * license or royalty fees, to use, copy, modify, and distribute this - * software and its documentation for any purpose, provided that the - * above copyright notice and the following two paragraphs appear in - * all copies of this software. - * - * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY - * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES - * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN - * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY - * OF SUCH DAMAGE. - * - * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, - * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY - * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS - * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION - * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. - *) - - -(** This module implements various constraint validation and simplification - * prepasses *) - -val validate : int -> FixConstraint.soln -> FixConstraint.t list -> unit -val validate_wfs : FixConstraint.wf list -> FixConstraint.wf list -(* val true_unconstrained : FixSolution.t -> Cindex.t -> FixSolution.t -*) -val profile : Cindex.t -> unit diff --git a/external/fixpoint/proverArch.ml b/external/fixpoint/proverArch.ml deleted file mode 100644 --- a/external/fixpoint/proverArch.ml +++ /dev/null @@ -1,221 +0,0 @@ -(* - * Copyright © 2009 The Regents of the University of California. All rights reserved. - * - * Permission is hereby granted, without written agreement and without - * license or royalty fees, to use, copy, modify, and distribute this - * software and its documentation for any purpose, provided that the - * above copyright notice and the following two paragraphs appear in - * all copies of this software. - * - * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY - * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES - * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN - * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY - * OF SUCH DAMAGE. - * - * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, - * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY - * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS - * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION - * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. - *) - -(* Theories API *) - -module type THEORY = sig - type context - type sort - type ast - type appDef - type sortDef - - val sym_sort : appDef -> Ast.Sort.t - val sym_name : appDef -> Ast.Symbol.t - val sort_name : sortDef -> Ast.Sort.tycon - val mk_thy_sort : sortDef -> context -> sort list -> sort - val mk_thy_app : appDef -> context -> sort list -> ast list -> ast - val theories : unit -> sortDef list * appDef list -end - -module type SMTSOLVER = sig - - (* Types *) - type context - type symbol - type ast - type sort - type fun_decl - - (* Sorts *) - val mkIntSort : context -> sort - val mkRealSort : context -> sort - val mkBoolSort : context -> sort - - (* Expression *) - val mkAll : context -> sort array -> symbol array -> ast -> ast - val mkApp : context -> fun_decl -> ast list -> ast - val mkMul : context -> ast -> ast -> ast - val mkDiv : context -> ast -> ast -> ast - val mkAdd : context -> ast -> ast -> ast - val mkSub : context -> ast -> ast -> ast - val mkMod : context -> ast -> ast -> ast - - (* Predicates *) - val mkIte : context -> ast -> ast -> ast -> ast - val mkInt : context -> int -> sort -> ast - val mkReal : context -> float -> sort -> ast - val mkLit : context -> string -> sort -> ast - val mkTrue : context -> ast - val mkFalse : context -> ast - val mkNot : context -> ast -> ast - val mkAnd : context -> ast list -> ast - val mkOr : context -> ast list -> ast - val mkImp : context -> ast -> ast -> ast - val mkIff : context -> ast -> ast -> ast - val mkRel : context -> Ast.brel -> ast -> ast -> ast - - (* Conversions *) - val astString : context -> ast -> string - val sortString : context -> sort -> string - - (* Set Theory Operations *) - val mkSetSort : context -> sort -> sort - val mkEmptySet : context -> sort -> ast - val mkSetAdd : context -> ast -> ast -> ast - val mkSetMem : context -> ast -> ast -> ast - val mkSetCup : context -> ast -> ast -> ast - val mkSetCap : context -> ast -> ast -> ast - val mkSetDif : context -> ast -> ast -> ast - val mkSetSub : context -> ast -> ast -> ast - - (* Map Theory Operations *) - - val mkMapSort : context -> sort -> sort -> sort - val mkMapSelect : context -> ast -> ast -> ast - val mkMapStore : context -> ast -> ast -> ast -> ast - - - (* BitVector Theory Operations *) - val mkSizeSort : context -> int -> sort - val mkBitSort : context -> sort -> sort - val mkBitAnd : context -> ast -> ast -> ast - val mkBitOr : context -> ast -> ast -> ast - - - - (* Constructors *) - val mkContext : (string * string) array -> context - - val stringSymbol : context -> string -> symbol - val isBool : context -> ast -> bool - val boundVar : context -> int -> sort -> ast - - (* Declarations *) - val var : context -> symbol -> sort -> ast - val funcDecl : context -> symbol -> sort array -> sort -> fun_decl - - (* Queries *) - val bracket : context -> (unit -> 'a) -> 'a - val assertAxiom : context -> ast -> unit - val assertPreds : context -> ast list -> unit - val assertDistinct : context -> ast list -> unit - val unsat : context -> bool - - (* Stats *) - val print_stats : Format.formatter -> unit -> unit -end - -class type prover = - object - (* AST/TC Interface *) - method interp_syms : unit -> (Ast.Symbol.t * Ast.Sort.t) list - - (* Query Interface *) - method set_filter : 'a . Ast.Sort.t Ast.Symbol.SMap.t - -> Ast.Symbol.t - -> Ast.pred list - -> ('a * Ast.pred) list - -> 'a list - - - (* method set_filter : Ast.Sort.t Ast.Symbol.SMap.t - -> Ast.Symbol.t - -> Ast.pred list - -> ((Ast.Symbol.t * Qualifier.t) * Ast.pred) list - -> (Ast.Symbol.t * Qualifier.t) list - *) - - method print_stats : Format.formatter -> unit - - (* Counterexample Interface *) - method is_contra : Ast.Sort.t Ast.Symbol.SMap.t - -> Ast.pred - -> bool - - - method unsat_suffix : Ast.Sort.t Ast.Symbol.SMap.t - -> Ast.pred (* background predicate *) - -> Ast.pred list (* [p0,...,pn] *) - -> int option (* max j st. p /\i=j..n pi unsat *) - - (* method unsat_core : Ast.Sort.t Ast.Symbol.SMap.t - -> Ast.pred (* background predicate *) - -> ('a * Ast.pred) list (* [(index, killer-fact)] *) - -> 'a list (* [unsat-core-index] *) - *) -end - -module type PROVER = sig - - val mkProver : Ast.Sort.t list (* sorts *) - -> Ast.Sort.t Ast.Symbol.SMap.t (* environment *) - -> Ast.pred list (* axioms *) - -> Ast.Symbol.t list (* distinct constants, sorts in env *) - -> prover - -(* {{{ - type t - - (* theory interface *) - val is_interp : Ast.Sort.tycon -> bool - val interp_syms : unit -> (Ast.Symbol.t * Ast.Sort.t) list - - (* constraint solving interface *) - val create : Ast.Sort.t list (* sorts *) - -> Ast.Sort.t Ast.Symbol.SMap.t (* environment *) - -> Ast.pred list (* axioms *) - -> Ast.Symbol.t list (* distinct constants, sorts in env *) - -> t - - val set_filter : t - -> Ast.Sort.t Ast.Symbol.SMap.t - -> Ast.Symbol.t - -> Ast.pred list - -> ('a * Ast.pred) list - -> 'a list - - val print_stats : Format.formatter -> t -> unit - - (* Counterexample Interface *) - - val is_contra : t - -> Ast.Sort.t Ast.Symbol.SMap.t - -> Ast.pred - -> bool - - val unsat_core : t - -> Ast.Sort.t Ast.Symbol.SMap.t - -> Ast.pred (* background predicate *) - -> ('a * Ast.pred) list (* [(index, killer-fact)] *) - -> 'a list (* [unsat-core-index] *) - - val unsat_suffix : t - -> Ast.Sort.t Ast.Symbol.SMap.t - -> Ast.pred (* background predicate *) - -> Ast.pred list (* [p0,...,pn] *) - -> int option (* max j st. p /\i=j..n pi unsat *) -}}} *) - -end - - diff --git a/external/fixpoint/qualifier.ml b/external/fixpoint/qualifier.ml deleted file mode 100644 --- a/external/fixpoint/qualifier.ml +++ /dev/null @@ -1,365 +0,0 @@ -(* - * Copyright © 2009-11 The Regents of the University of California. - * All rights reserved. - * - * Permission is hereby granted, without written agreement and without - * license or royalty fees, to use, copy, modify, and distribute this - * software and its documentation for any purpose, provided that the - * above copyright notice and the following two paragraphs appear in - * all copies of this software. - * - * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY - * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES - * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN - * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY - * OF SUCH DAMAGE. - * - * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, - * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY - * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS - * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION - * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. - * - *) - -(** - * This module implements a module for representing and manipulating Qualifiers. - * *) -module Co = Constants - -module F = Format - -module P = Ast.Predicate -module E = Ast.Expression -module Sy = Ast.Symbol -module So = Ast.Sort -module Su = Ast.Subst -module SM = Sy.SMap -module SS = Sy.SSet - -module Misc = FixMisc open Misc.Ops -module IM = Misc.IntMap -open Ast - -let mydebug = false - -(**************************************************************************) -(***************************** Qualifiers *********************************) -(**************************************************************************) - -type q = { name : Sy.t - ; vvar : Sy.t - ; vsort : So.t - ; params : (Sy.t * So.t) list - ; pred : pred - ; args : expr list option - (* when args = Some es, es = vv'::[e1;...;en] - where vv' is the applied vv and e1...en are the args applied to ~A1,...,~An *) - } - - -type t = q (* to appease the functor gods. *) - -let rename = fun n -> fun q -> {q with name = n} -let name_of_t = fun q -> q.name -let vv_of_t = fun q -> q.vvar -let sort_of_t = fun q -> q.vsort -let pred_of_t = fun q -> q.pred -let params_of_t = fun q -> q.params -let all_params_of_t = fun q -> (q.vvar, q.vsort) :: q.params - -let args_of_t q = - let xs = all_params_of_t q |> List.map fst in - let es = match q.args with - | Some es -> es - | None -> List.map eVar xs - in Misc.combine "Qualifier.args_of_t" xs es - -let print_param ppf (x, t) = - F.fprintf ppf "%a:%a" Sy.print x So.print t - -let print_params ppf args = - F.fprintf ppf "%a" (Misc.pprint_many false ", " print_param) args - -let print_args ppf q = - q |> args_of_t |> List.map snd - |> F.fprintf ppf "%a(%a)" Sy.print q.name (Misc.pprint_many false ", " E.print) - -(* API *) -let print ppf q = - F.fprintf ppf "qualif %a(%a):%a" - Sy.print q.name - print_params (all_params_of_t q) - P.print q.pred - - -(**********************************************************************) -(****************** Canonizing Wildcards (e.g. _ ---> ~A) *************) -(**********************************************************************) - -let is_free params x = Misc.list_assoc_maybe x params |> Misc.maybe_bool |> not - -let canonizer params = - let fresh = Misc.mk_string_factory "~AA" |> fst |> (fun f -> f <+> Sy.of_string <+> eVar) in - let memo = Hashtbl.create 7 in - function - | (Var x, _) when is_free params x && Hashtbl.mem memo x -> - Hashtbl.find memo x - | (Var x, _) when is_free params x && Sy.is_wild_fresh x -> - fresh () - | (Var x, _) when is_free params x && Sy.is_wild_any x -> - fresh () >> Hashtbl.replace memo x - | e -> e - -(**************************************************************************) -(*************** Expanding Away Sets of Ops and Rels **********************) -(**************************************************************************) - -let expand_with_list f g = - List.map f <+> Misc.cross_flatten <+> Misc.map g - -let expand_with_pair f g = - Misc.map_pair f <+> Misc.uncurry Misc.cross_product <+> Misc.map g - -let crunchExpr f e1s xs e2s = - List.map begin fun e1 -> - List.map begin fun e2 -> - List.map begin fun x -> - f (e1, x, e2) - end xs - end e2s - end e1s - |> List.flatten |> List.flatten - -let rec expand_p ((p,_) as pred) = match p with - | And ps -> expand_ps pAnd ps - | Or ps -> expand_ps pOr ps - | Not p -> expand_p p |> List.map pNot - | Imp (p1,p2) -> expand_pp pImp (p1, p2) - | Iff (p1,p2) -> expand_pp pIff (p1, p2) - | Forall(qs, p) -> expand_p p |> List.map (fun p -> pForall (qs, p)) - | Bexp e -> expand_e e |> List.map pBexp - | MAtom (e1, rs, e2) -> let (e1s, e2s) = Misc.map_pair expand_e (e1,e2) in - crunchExpr pAtom e1s rs e2s - | Atom (e1, r, e2) -> let (e1s, e2s) = Misc.map_pair expand_e (e1,e2) in - crunchExpr pAtom e1s [r] e2s - | _ -> [pred] - -and expand_e ((e,_) as expr) = match e with - | MExp es -> Misc.flap expand_e es - | App (f, es) -> expand_es (fun es -> eApp (f, es)) es - | Bin (e1, op, e2) -> expand_ep (fun (e1,e2) -> eBin (e1, op, e2)) (e1, e2) - | MBin (e1, ops, e2) -> let e1s, e2s = Misc.map_pair expand_e (e1, e2) in - crunchExpr eBin e1s ops e2s - | Fld (s, e) -> expand_e e |> List.map (fun e -> eFld (s,e)) - | Cst (e, t) -> expand_e e |> List.map (fun e -> eCst (e,t)) - | Ite (p,e1,e2) -> let e1s, e2s = Misc.map_pair expand_e (e1, e2) in - let ps = expand_p p in - List.map begin fun e1 -> - List.map begin fun e2 -> - List.map begin fun p -> - eIte (p, e1, e2) - end ps - end e2s - end e1s - |> List.flatten |> List.flatten - | _ -> [expr] - -and expand_ps x = expand_with_list expand_p x -and expand_pp x = expand_with_pair expand_p x -and expand_es x = expand_with_list expand_e x -and expand_ep x = expand_with_pair expand_e x - -(* API *) -let expand_qual q = - expand_p q.pred - |> List.map (fun p -> {q with pred = p}) - -(**************************************************************************) -(*************** Expanding Away Sets of Ops and Rels **********************) -(**************************************************************************) - -let make_def_deps qnames q = - let res = ref [] in - let p' : pred = P.map begin function - | Bexp (App (f, args),_), _ - when SS.mem f qnames -> res := (f, args) :: !res; pTrue - | p -> p - end id q.pred - in (q.name, !res) -(* >> (fun (n, xs) -> F.printf "qdep %a = %a \n" Sy.print n (Misc.pprint_many false ", " Sy.print) (List.map fst xs) ) - *) - -let check_def_deps qm = - List.iter begin fun (n, fargs) -> - List.iter begin fun (f, args) -> - match SM.finds f qm with - | [q] -> asserts (List.length args = 1 + List.length q.params) - "Malformed Qualifier: %s with incorrect application of %s" - (Sy.to_string n) (Sy.to_string f) - | _::_::_ -> assertf "Malformed Qualifier: %s refers to multiply defined %s" - (Sy.to_string n) (Sy.to_string f) - | _ -> () -(* | [] -> assertf "Malformed Qualifier: %s refers to unknown %s" - (Sy.to_string n) (Sy.to_string f) *) - - end fargs - end - -let order_by_defs qm qs = - let is = Misc.range 0 (List.length qs) in - let qis = List.combine qs is in - let i2q = qis |>: Misc.swap |> IM.of_list |> Misc.flip IM.find in - let i2s = i2q <+> name_of_t <+> Sy.to_string in - let n2i = qis |>: Misc.app_fst name_of_t |> SM.of_list - |> (fun m n -> SM.safeFind n m "order_by_defs") in - - let qnams= qs |>: name_of_t |> SS.of_list in - let deps = qs |>: make_def_deps qnams >> check_def_deps qm in - let ijs = deps |> Misc.flap (fun (n, fargs) -> fargs |>: (fun (f,_) -> (n, f))) - |> List.map (Misc.map_pair n2i) in - let irs = Fcommon.scc_rank "qualifier-deps" i2s is ijs in - Misc.fsort snd irs - |>: (fst <+> i2q) -(* >> (F.printf "ORDERED QUALS:\n%a\n" (Misc.pprint_many true "\n" print)) *) - -let expand_def qm p = match p with - | Bexp (App (f, args),_), _ -> begin - match SM.finds f qm with - | _::_::_ -> assertf "Ambiguous Qualifier: %s" (Sy.to_string f) - | [q] -> q |> all_params_of_t - |> List.map fst - |> Misc.flip (Misc.combine ("Q.expand_def "^ (P.to_string p))) args - |> Su.of_list - |> substs_pred q.pred - | [] -> p (* assertf "Unknown Qualifier: %s" (Sy.to_string f) *) - end - | _ -> p - -(* this MUST precede any renaming as renaming can screw up name resolution *) -let compile_definitions qs = - let qm = List.fold_left (fun qm q -> SM.adds q.name [q] qm) SM.empty qs in - let qs' = order_by_defs qm qs in - List.fold_left begin fun qm q -> - let q' = {q with pred = P.map (expand_def qm) id q.pred } in - SM.adds q.name [q'] qm - end SM.empty qs' - |> SM.range |> Misc.flatten - -(**************************************************************************) -(************************* Normalize Qualifier Sets ***********************) -(**************************************************************************) - -let remove_duplicates qs = - qs |> Misc.kgroupby (all_params_of_t <*> pred_of_t) - |> List.map (fun (_,x::_) -> x) - -let rename_qual q i = - {q with name = Sy.suffix q.name (string_of_int i)} - -let uniquely_rename qs = - Misc.mapfold begin fun m q -> - if SM.mem q.name m then - let i = SM.safeFind q.name m "uniquelyRename" in - (SM.add q.name (i+1) m, rename_qual q i) - else - (SM.add q.name 0 m, q) - end SM.empty qs - |> snd - - -let check_dup t q = - try - let q' = Hashtbl.find t q.name in - if (pred_of_t q' = pred_of_t q) then () else - Format.printf "WARNING: duplicate qualifiers after normalization! (q = %a) (q' = %a)" - print q - print q' - with Not_found -> () - -let qualifMap_set, qualifMap_get = - let t = Hashtbl.create 37 in - ( (fun qs -> Hashtbl.clear t; List.iter (fun q -> check_dup t q; Hashtbl.replace t q.name q) qs) - , (fun n -> try Some (Hashtbl.find t n) - with Not_found -> (Format.printf "qualifMap_get fails on %a" Sy.print n; assert false) - ) - ) - -let ticker = ref 0 - -(* API *) -let normalize qs = - qs |> Misc.flap expand_qual - |> compile_definitions - |> remove_duplicates - |> uniquely_rename - >> qualifMap_set -(* >> (fun qs -> ticker += 1; Co.logPrintf "normalize (%d):\n%a" (!ticker) - (Misc.pprint_many true "\n" print) qs; flush stdout) *) - -(* API *) -let expandPred n es = - n |> qualifMap_get - |> Misc.maybe_map begin fun q -> - let xs = List.map fst <| args_of_t q in - Misc.combine "expandPred" xs es - |> Ast.Subst.of_list - |> Ast.substs_pred (pred_of_t q) - end - -(*********************************************************************) -(***************************** Create ********************************) -(*********************************************************************) - -let generalize_sorts vts = - let vs, ts = List.split vts in - let ts' = So.generalize ts in - List.combine vs ts' - -(* let generalize_sorts z = if !Co.gen_qual_sorts then generalize_sorts z else z *) - -let close_params vts p = - p |> P.support - |> List.filter (Sy.is_wild <&&> is_free vts) - |> List.map (fun x -> (x, So.t_int (* t_generic 0 causes blowup? *))) - |> (@) vts (* Sy.SMap.of_list *) - -(* API *) -let create n v t vts p = - let p = P.map id (canonizer vts) p in - let vts = close_params vts p in - let (v,t)::vts = generalize_sorts ((v,t)::vts) in - let _ = asserts (Misc.distinct vts) "Error: Q.create duplicate params %s \n" (Sy.to_string n) - in { name = n - ; vvar = v - ; vsort = t - ; pred = p - ; params = vts - ; args = None } - -(* DEBUG ONLY *) -let printb ppf (x, e) = - F.fprintf ppf "%a:%a" Sy.print x E.print e -let printbs ppf args = - F.fprintf ppf "%a" (Misc.pprint_many false ", " printb) args - -(* API *) -let inst q args = - let _ = if mydebug then F.printf "\nQ.inst with <<%a>>\n" printbs args in - let xes = try q |> all_params_of_t |> List.map (fun (x,_) -> (x, List.assoc x args)) - with Not_found -> - let _ = F.printf "Error: Q.inst with bad args %a <<%a>>" print q printbs args - in assertf "Error: Q.inst with bad args \n" - in - let v = match xes with (_, (Var v, _)) :: _ -> v | _ -> assertf "Error: Q.inst with non-vvar arg" in - let p = xes |> Su.of_list |> Ast.substs_pred q.pred in - { q with vvar = v; pred = p; args = Some (List.map snd xes)} - - -module QSet = Misc.ESet (struct - type t = q - let compare q1 q2 = - if (q1.name = q2.name) - then compare q1.args q2.args - else compare q1.name q2.name -end) diff --git a/external/fixpoint/qualifier.mli b/external/fixpoint/qualifier.mli deleted file mode 100644 --- a/external/fixpoint/qualifier.mli +++ /dev/null @@ -1,53 +0,0 @@ -(* - * Copyright © 2009-11 The Regents of the University of California. - * All rights reserved. - * - * Permission is hereby granted, without written agreement and without - * license or royalty fees, to use, copy, modify, and distribute this - * software and its documentation for any purpose, provided that the - * above copyright notice and the following two paragraphs appear in - * all copies of this software. - * - * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY - * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES - * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN - * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY - * OF SUCH DAMAGE. - * - * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, - * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY - * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS - * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION - * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. - * - *) - -(** - * This module implements a module for representing and manipulating Qualifiers. - * *) - -type t -module QSet : FixMisc.ESetType with type elt = t - -val create : Ast.Symbol.t - -> Ast.Symbol.t - -> Ast.Sort.t - -> (Ast.Symbol.t * Ast.Sort.t) list - -> Ast.pred - -> t - -val name_of_t : t -> Ast.Symbol.t -val vv_of_t : t -> Ast.Symbol.t -val pred_of_t : t -> Ast.pred -val sort_of_t : t -> Ast.Sort.t -val params_of_t : t -> (Ast.Symbol.t * Ast.Sort.t) list (* Ast.Sort.t Ast.Symbol.SMap.t *) -val all_params_of_t : t -> (Ast.Symbol.t * Ast.Sort.t) list -val vv_of_t : t -> Ast.Symbol.t -val args_of_t : t -> (Ast.Symbol.t * Ast.expr) list -val normalize : t list -> t list -val inst : t -> (Ast.Symbol.t * Ast.expr) list -> t -val print : Format.formatter -> t -> unit -val print_args : Format.formatter -> t -> unit -val expandPred : Ast.Symbol.t -> Ast.expr list -> Ast.pred option - - diff --git a/external/fixpoint/smtLIB2.ml b/external/fixpoint/smtLIB2.ml deleted file mode 100644 --- a/external/fixpoint/smtLIB2.ml +++ /dev/null @@ -1,513 +0,0 @@ -(* - * Copyright © 2008 The Regents of the University of California. All rights reserved. - * - * Permission is hereby granted, without written agreement and without - * license or royalty fees, to use, copy, modify, and distribute this - * software and its documentation for any purpose, provided that the - * above copyright notice and the following two paragraphs appear in - * all copies of this software. - * - * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY - * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES - * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN - * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY - * OF SUCH DAMAGE. - * - * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, - * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY - * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS - * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION - * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. - *) - -(********************************************************************************) -(*********** This module implements the binary interface with SMTLIB2 *********) -(*********** http://www.smt-lib.org/ *********) -(*********** http://www.grammatech.com/resource/smt/SMTLIBTutorial.pdf *********) -(********************************************************************************) - - -module H = Hashtbl -module F = Format -module Co = Constants -module BS = BNstats -module A = Ast -module Sy = A.Symbol -module So = A.Sort -module SM = Sy.SMap -module P = A.Predicate -module E = A.Expression -module Misc = FixMisc open Misc.Ops -module SSM = Misc.StringMap -module Th = Theories - -module SMTLib2 : ProverArch.SMTSOLVER = struct - -let spr = Printf.sprintf - -let mydebug = false - -let nb_unsat = ref 0 -let nb_pop = ref 0 -let nb_push = ref 0 - -(***************************************************************) -(********************** Types **********************************) -(***************************************************************) - -type symbol = string (* Sy.t *) -type sort = string (* So.t *) -type ast = string (* E of A.expr | P of A.pred *) -type fun_decl = symbol - -type cmd = Push - | Pop - | CheckSat - | Declare of symbol * sort list * sort - | AssertCnstr of ast - | Distinct of ast list (* {v: ast list | (len v) >= 2} *) - -type resp = Ok - | Sat - | Unsat - | Unknown - | Error of string - -type solver = Z3 | Mathsat | Cvc4 - -type context = { cin : in_channel - ; cout : out_channel - ; clog : out_channel } - -let respString = function - | Ok -> "Ok" - | Sat -> "Sat" - | Unsat -> "Unsat" - | Unknown -> "Unknown" - | Error s -> "Error " ^ s - -let solverString = function - | Z3 -> "z3" - | Mathsat -> "mathsat" - | Cvc4 -> "cvc4" - -(*******************************************************************) -(*********************** Set Theory ********************************) -(*******************************************************************) - -let elt = "SMT_Elt" -let set = "SMT_Set" -let emp = "smt_set_emp" -let add = "smt_set_add" -let cup = "smt_set_cup" -let cap = "smt_set_cap" -let mem = "smt_set_mem" -let dif = "smt_set_dif" -let sub = "smt_set_sub" -let com = "smt_set_com" - -let map = "SMT_Map" -let sel = "smt_map_sel" -let sto = "smt_map_sto" - -(* - (define-fun smt_set_emp () Set ((as const Set) false)) - (define-fun smt_set_mem ((x Elt) (s Set)) Bool (select s x)) - (define-fun smt_set_add ((s Set) (x Elt)) Set (store s x true)) - (define-fun smt_set_cap ((s1 Set) (s2 Set)) Set ((_ map and) s1 s2)) - (define-fun smt_set_cup ((s1 Set) (s2 Set)) Set ((_ map or) s1 s2)) - (define-fun smt_set_com ((s Set)) Set ((_ map not) s)) - (define-fun smt_set_dif ((s1 Set) (s2 Set)) Set (smt_set_cap s1 (smt_set_com s2))) - (define-fun smt_set_sub ((s1 Set) (s2 Set)) Bool (= smt_set_emp (smt_set_dif s1 s2))) -*) - -let (++) = List.append - -(* array preamble *) -let array_preamble _ = - if not !Co.map_theory then [] else - [ spr "(define-sort %s () (Array %s %s))" - map elt elt - ; spr "(define-fun %s ((m %s) (k %s)) %s (select m k))" - sel map elt elt - ; spr "(define-fun %s ((m %s) (k %s) (v %s)) %s (store m k v))" - sto map elt elt map - ] - - -(* z3 specific *) -let z3_preamble _ - = [ "(set-option :auto-config false)" - ; "(set-option :model true)" - ; "(set-option :model.partial false)" - ; "(set-option :smt.mbqi false)" - ] ++ if not !Co.set_theory then [] else - [ spr "(define-sort %s () Int)" - elt - ; spr "(define-sort %s () (Array %s Bool))" - set elt - ; spr "(define-fun %s () %s ((as const %s) false))" - emp set set - ; spr "(define-fun %s ((x %s) (s %s)) Bool (select s x))" - mem elt set - ; spr "(define-fun %s ((s %s) (x %s)) %s (store s x true))" - add set elt set - ; spr "(define-fun %s ((s1 %s) (s2 %s)) %s ((_ map or) s1 s2))" - cup set set set - ; spr "(define-fun %s ((s1 %s) (s2 %s)) %s ((_ map and) s1 s2))" - cap set set set - ; spr "(define-fun %s ((s %s)) %s ((_ map not) s))" - com set set - ; spr "(define-fun %s ((s1 %s) (s2 %s)) %s (%s s1 (%s s2)))" - dif set set set cap com - ; spr "(define-fun %s ((s1 %s) (s2 %s)) Bool (= %s (%s s1 s2)))" - sub set set emp dif - ] ++ array_preamble () - - -(* cvc4 specific *) -let cvc4_preamble _ - = if not !Co.set_theory then [] else - [ spr "(set-logic QF_AUFNIRAFS)" - ; spr "(define-sort %s () Int)" - elt - ; spr "(define-sort %s () (Set %s))" - set elt - ; spr "(define-fun %s () %s (as emptyset (Set %s)))" - emp set elt - ; spr "(define-fun %s ((x %s) (s %s)) Bool (member x s))" - mem elt set - ; spr "(define-fun %s ((s %s) (x %s)) %s (insert x s))" - add set elt set - ; spr "(define-fun %s ((s1 %s) (s2 %s)) %s (union s1 s2))" - cup set set set - ; spr "(define-fun %s ((s1 %s) (s2 %s)) %s (intersection s1 s2))" - cap set set set - ; spr "(declare-fun %s (%s) %s)" - com set set - ; spr "(define-fun %s ((s1 %s) (s2 %s)) %s (setminus s1 s2))" - dif set set set - ; spr "(define-fun %s ((s1 %s) (s2 %s)) Bool (subset s1 s2))" - sub set set - ] ++ array_preamble () - -let smtlib_preamble - = [ spr "(set-logic QF_UFLIA)" - ; spr "(define-sort %s () Int)" elt - ; spr "(define-sort %s () Int)" set - ; spr "(declare-fun %s () %s)" emp set - ; spr "(declare-fun %s (%s %s) %s)" add set elt set - ; spr "(declare-fun %s (%s %s) %s)" cup set set set - ; spr "(declare-fun %s (%s %s) %s)" cap set set set - ; spr "(declare-fun %s (%s %s) %s)" dif set set set - ; spr "(declare-fun %s (%s %s) Bool)" sub set set - ; spr "(declare-fun %s (%s %s) Bool)" mem elt set - ; spr "(declare-fun %s (%s %s) %s)" sel map elt elt - ; spr "(declare-fun %s (%s %s %s) %s)" sto map elt elt map - - (* HIDE? - ; spr "(assert (forall ((x %s)) (not (%s x %s))))" - elt mem emp - ; spr "(assert (forall ((x %s) (s1 %s) (s2 %s)) - (= (%s x (%s s1 s2)) (or (%s x s1) (%s x s2)))))" - elt set set mem cup mem mem - ; spr "(assert (forall ((x %s) (s1 %s) (s2 %s)) - (= (%s x (%s s1 s2)) (and (%s x s1) (%s x s2)))))" - elt set set mem cap mem mem - ; spr "(assert (forall ((x %s) (s1 %s) (s2 %s)) - (= (%s x (%s s1 s2)) (and (%s x s1) (not (%s x s2))))))" - elt set set mem dif mem mem - ; spr "(assert (forall ((x %s) (s %s) (y %s)) - (= (%s x (%s s y)) (or (%s x s) (= x y)))))" - elt set elt mem add mem - *) - ] - - -let mkSetSort _ _ = set -let mkEmptySet _ _ = emp -let mkSetAdd _ s x = spr "(%s %s %s)" add s x -let mkSetMem _ x s = spr "(%s %s %s)" mem x s -let mkSetCup _ s t = spr "(%s %s %s)" cup s t -let mkSetCap _ s t = spr "(%s %s %s)" cap s t -let mkSetDif _ s t = spr "(%s %s %s)" dif s t -let mkSetSub _ s t = spr "(%s %s %s)" sub s t - -let mkMapSort c k v = map -let mkMapSelect c m k = spr "(%s %s %s)" sel m k -let mkMapStore c m k v = spr "(%s %s %s %s)" sto m k v - -let mkSizeSort _ n = spr "%d" n -let mkBitSort _ s = spr "(_ BitVec %s)" s -let mkBitAnd _ x y = spr "(bvand %s %s)" x y -let mkBitOr _ x y = spr "(bvor %s %s)" x y - - -(******************************************************************) -(**************** SMT IO ******************************************) -(** https://raw.github.com/ravichugh/djs/master/src/zzz.ml ********) -(******************************************************************) - -(* "z3 -smt2 -in" *) -(* "z3 -smtc SOFT_TIMEOUT=1000 -in" *) -(* "z3 -smtc -in MBQI=false" *) - -let smt_cmd = function - | Z3 -> "z3 -smt2 -in MODEL=false MODEL.PARTIAL=true smt.mbqi=false auto-config=false" - | Mathsat -> "mathsat -input=smt2" - | Cvc4 -> "cvc4 --incremental -L smtlib2" - -let smt_preamble = function - | Z3 -> z3_preamble () - | Cvc4 -> cvc4_preamble () - | _ -> smtlib_preamble - - -let smt_write_raw me s = - output_now me.clog s; - output_now me.cout s - -(* copied from String.trim in ocaml-4.0 since mingw-ocaml uses 3.x *) -let trim s = - let is_space = function - | ' ' | '\012' | '\n' | '\r' | '\t' -> true - | _ -> false in - let len = String.length s in - let i = ref 0 in - while !i < len && is_space (String.get s !i) do - incr i - done; - let j = ref (len - 1) in - while !j >= !i && is_space (String.get s !j) do - decr j - done; - if !i = 0 && !j = len - 1 then - s - else if !j >= !i then - String.sub s !i (!j - !i + 1) - else - "" - -(* strip off trailing whitespace, e.g. \r on windows.. *) -let smt_read_raw me = - trim (input_line me.cin) - -let smt_write me ?nl:(nl=true) ?tab:(tab=false) s = - let pre = if tab then " " else "" in - let suf = if nl then "\n" else "" in - smt_write_raw me (pre^s^suf) - -let rec smt_read me - = match smt_read_raw me with - | "sat" -> Sat - | "unsat" -> Unsat - | "success" -> smt_read me - | "unknown" -> Unknown - | s -> Error s - - -(* val interact : context -> cmd -> resp *) -let interact me = function - | Declare (x, ts, t) -> - let _ = smt_write me <| spr "(declare-fun %s (%s) %s)" x (String.concat " " ts) t in - Ok - | Push -> - let _ = smt_write me <| "(push 1)" in - Ok - | Pop -> - let _ = smt_write me <| "(pop 1)" in - Ok - | CheckSat -> - let _ = smt_write me <| "(check-sat)" in - smt_read me - | AssertCnstr a -> - let _ = smt_write me <| spr "(assert %s)" a in - Ok - | Distinct az -> - let _ = smt_write me <| spr "(assert (distinct %s))" (String.concat " " az) in - Ok - - -(* API *) -let smt_decl me x ts t - = match interact me (Declare (x, ts, t)) with - | Ok -> () - | _ -> assertf "crash: SMTLIB2 smt_decl" - -(* API *) -let smt_push me - = match interact me Push with - | Ok -> incr nb_push; () - | _ -> assertf "crash: SMTLIB2 smt_push" - -(* API *) -let smt_pop me - = match interact me Pop with - | Ok -> incr nb_pop; () - | _ -> assertf "crash: SMTLIB2 smt_pop" - -(* API *) -let smt_check_unsat me - = match interact me CheckSat with - | Unsat -> true - | Sat -> false - | Unknown -> false - | e -> assertf "crash: SMTLIB2 smt_check_unsat %s" (respString e) - -(* API *) -let smt_assert_cnstr me p - = match interact me (AssertCnstr p) with - | Ok -> () - | _ -> assertf "crash: SMTLIB2 smt_assert_cnstr" - -(* API *) -let smt_assert_distinct me az - = match interact me (Distinct az) with - | Ok -> () - | _ -> assertf "crash: SMTLIB2 smt_assert_distinct" - -let solver () = - match !Co.smt_solver with - | Some "z3" -> Z3 - | Some "mathsat" -> Mathsat - | Some "cvc4" -> Cvc4 - | Some str -> assertf "ERROR: fixpoint does not yet support SMTSOLVER: %s" str - | None -> assertf "ERROR: undefined solver for smtLIB2" - -let mkContext _ = - let s = solver () in - let ci, co = Unix.open_process <| smt_cmd s in - let cl = open_out <| Co.get_smt2_file () in - let pre = smt_preamble s in - let ctx = { cin = ci; cout = co; clog = cl } in - let _ = List.iter (smt_write ctx) pre in - ctx - -(***********************************************************************) -(*********************** AST Constructors ******************************) -(***********************************************************************) - -let stringSymbol _ s = s -let astString _ a = a -let sortString _ s = s -let isBool c a = failwith "TODO:SMTLib2.isBool" -let boundVar me i t = failwith "TODO:SMTLib2.boundVar" - -let var me x t = - let _ = smt_decl me x [] t in - x - -let funcDecl me s ta t = - let _ = smt_decl me s (Array.to_list ta) t in - s - -let mkIntSort _ = "Int" -let mkRealSort _ = "Real" -let mkBoolSort _ = "Bool" - -let mkInt _ i _ = if i >= 0 then string_of_int i - else spr "(- %d)" (abs i) -let mkReal _ i _ = if i >= 0. then string_of_float i ^ "0" (* add trailing 0 for floats like 1. *) - else spr "(- %s)" (string_of_float (i *. -1.0) ^ "0") - -let mkLit _ l _ = l - -let mkTrue _ = "true" -let mkFalse _ = "false" - -let mkAll _ _ _ _ = failwith "TODO:SMTLib2.mkAll" - -let mkRel _ r a1 a2 - = match r with - | A.Eq - | A.Ueq -> spr "(= %s %s)" a1 a2 - | A.Ne - | A.Une -> spr "(not (= %s %s))" a1 a2 - | A.Gt -> spr "(> %s %s)" a1 a2 - | A.Ge -> spr "(>= %s %s)" a1 a2 - | A.Lt -> spr "(< %s %s)" a1 a2 - | A.Le -> spr "(<= %s %s)" a1 a2 - - - -let mkApp _ f = function - | [] -> f - | az -> spr "(%s %s)" f (String.concat " " az) - -let opStr = function - | A.Plus -> "+" - | A.Minus -> "-" - | A.Times -> "*" - | A.Div -> "/" - | A.Mod -> "mod" - -let mkOp op a1 a2 - = spr "(%s %s %s)" (opStr op) a1 a2 - -let mkMul _ = mkOp A.Times -let mkDiv _ = mkOp A.Div -let mkAdd _ = mkOp A.Plus -let mkSub _ = mkOp A.Minus -let mkMod _ = mkOp A.Mod - -let mkIte _ a1 a2 a3 - = spr "(ite %s %s %s)" a1 a2 a3 - -let mkNot _ a - = spr "(not %s)" a - -let mkAnd _ az - = spr "(and %s)" (String.concat " " az) - -let mkOr _ az - = spr "(or %s)" (String.concat " " az) - -let mkImp _ a1 a2 - = spr "(=> %s %s)" a1 a2 - -let mkIff _ a1 a2 - = spr "(= %s %s)" a1 a2 - -(*******************************************************************) -(*********************** Queries ***********************************) -(*******************************************************************) - -let us_ref = ref 0 - -(* API *) -let unsat me = - let _ = if mydebug then begin - Printf.printf "[%d] UNSAT 1 " (us_ref += 1); - flush stdout - end - in - let rv = BS.time "SMT.check_unsat" smt_check_unsat me in - let _ = if mydebug then (Printf.printf "UNSAT 2 \n"; flush stdout) in - let _ = if rv then ignore (nb_unsat += 1) in - rv - -(* API *) -let assertAxiom me p - = (* Co.bprintf mydebug "@[Pushing axiom %s@]@." (astString me p); *) - BS.time "assertAxiom" (smt_assert_cnstr me) p; - asserts (not (unsat me)) "ERROR: Axiom makes background theory inconsistent!" - -(* API *) -let assertDistinct me = function - | ((x1::x2::_) as az) -> smt_assert_distinct me az - | _ -> () - -(* API *) -let bracket me f - = Misc.bracket (fun _ -> smt_push me) (fun _ -> smt_pop me) f - -(* API *) -let assertPreds me ps - = List.iter (fun p -> BS.time "assertPreds" (smt_assert_cnstr me) p) ps - -(* API *) -let print_stats ppf () = - F.fprintf ppf "SMT stats: pushes=%d, pops=%d, unsats=%d \n" - !nb_push !nb_pop !nb_unsat - -end diff --git a/external/fixpoint/smtZ3.mem.ml b/external/fixpoint/smtZ3.mem.ml deleted file mode 100644 --- a/external/fixpoint/smtZ3.mem.ml +++ /dev/null @@ -1,180 +0,0 @@ -(* - * Copyright © 2008 The Regents of the University of California. All rights reserved. - * - * Permission is hereby granted, without written agreement and without - * license or royalty fees, to use, copy, modify, and distribute this - * software and its documentation for any purpose, provided that the - * above copyright notice and the following two paragraphs appear in - * all copies of this software. - * - * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY - * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES - * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN - * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY - * OF SUCH DAMAGE. - * - * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, - * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY - * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS - * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION - * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. - *) - -(* This file is part of the LiquidC Project *) - -module H = Hashtbl -module F = Format -module Co = Constants -module BS = BNstats -module A = Ast -module Sy = A.Symbol -module So = A.Sort -module SM = Sy.SMap -module P = A.Predicate -module E = A.Expression -module Misc = FixMisc open Misc.Ops -module SSM = Misc.StringMap -module Th = Theories - -module SMTZ3 : ProverArch.SMTSOLVER = struct - -let mydebug = false - -(********************************************************************************) -(************ SMT INTERFACE *****************************************************) -(********************************************************************************) - -let nb_unsat = ref 0 -let nb_pop = ref 0 -let nb_push = ref 0 - -type context = Z3.context -type symbol = Z3.symbol -type sort = Z3.sort -type ast = Z3.ast -type fun_decl = Z3.func_decl - -let var = Z3.mk_const -let boundVar = Z3.mk_bound -let stringSymbol = Z3.mk_string_symbol -let funcDecl = Z3.mk_func_decl - -let isBool c a = - a |> Z3.get_sort c - |> Z3.sort_to_string c - |> (=) "bool" - -let isInt me a = - a |> Z3.get_sort me - |> Z3.sort_to_string me - |> (=) "int" - -let mkAll me = Z3.mk_forall me 0 [||] - -let mkRel c r a1 a2 - = match r with - | A.Eq - | A.Ueq -> Z3.mk_eq c a1 a2 - | A.Ne - | A.Une -> Z3.mk_distinct c [| a1; a2 |] - | A.Gt -> Z3.mk_gt c a1 a2 - | A.Ge -> Z3.mk_ge c a1 a2 - | A.Lt -> Z3.mk_lt c a1 a2 - | A.Le -> Z3.mk_le c a1 a2 - -let mkApp c f az = Z3.mk_app c f (Array.of_list az) -let mkMul c a1 a2 = Z3.mk_mul c [| a1; a2|] -let mkDiv c a1 a2 = Z3.mk_div c a1 a2 -let mkAdd c a1 a2 = Z3.mk_add c [| a1; a2|] -let mkSub c a1 a2 = Z3.mk_sub c [| a1; a2|] -let mkMod = Z3.mk_mod -let mkIte = Z3.mk_ite - -let mkInt = Z3.mk_int -let mkReal c f = Z3.mk_numeral c (string_of_float f) -let mkTrue = Z3.mk_true -let mkFalse = Z3.mk_false -let mkNot = Z3.mk_not -let mkAnd c az = Z3.mk_and c (Array.of_list az) -let mkOr c az = Z3.mk_or c (Array.of_list az) -let mkImp = Z3.mk_implies -let mkIff = Z3.mk_iff -let astString = Z3.ast_to_string -let mkIntSort = Z3.mk_int_sort -let mkRealSort = Z3.mk_real_sort -let mkBoolSort = Z3.mk_bool_sort -let mkSetSort = Z3.mk_set_sort -let mkEmptySet = Z3.mk_empty_set -let mkSetAdd = Z3.mk_set_add -let mkSetMem = Z3.mk_set_member -let mkSetCup = fun me s1 s2 -> Z3.mk_set_union me [| s1; s2 |] -let mkSetCap = fun me s1 s2 -> Z3.mk_set_intersect me [| s1; s2 |] -let mkSetDif = Z3.mk_set_difference -let mkSetSub = Z3.mk_set_subset -let mkContext = Z3.mk_context_x - - -let mkMapSort = fun _ _ _ -> failwith "TODO: smtZ3.mem : mkMapSort" -let mkMapSelect = fun _ _ _ -> failwith "TODO: smtZ3.mem : mkMapSelect" -let mkMapStore = fun _ _ _ _ -> failwith "TODO: smtZ3.mem : mkMapStore" - - -(*********************************************************) - -let z3push me = - let _ = nb_push += 1 in - let _ = BS.time "Z3.push" Z3.push me in - () - -let z3pop me = - let _ = incr nb_pop in - BS.time "Z3.pop" (Z3.pop me) 1 - - -(* Z3 API *) -let unsat = - let us_ref = ref 0 in - fun me -> - let _ = if mydebug then (Printf.printf "[%d] UNSAT 1 " (us_ref += 1); flush stdout) in - let rv = (BS.time "Z3.check" Z3.check me) = Z3.L_FALSE in - let _ = if mydebug then (Printf.printf "UNSAT 2 \n"; flush stdout) in - let _ = if rv then ignore (nb_unsat += 1) in - rv - -(* API *) -let assertAxiom me p = - Co.bprintf mydebug "@[Pushing axiom %s@]@." (astString me p); - BS.time "Z3 assert axiom" (Z3.assert_cnstr me) p; - asserts (not (unsat me)) "ERROR: Axiom makes background theory inconsistent!" - -(* API *) -let assertDistinct me xs = - xs |> Array.of_list |> Z3.mk_distinct me |> assertAxiom me - -(* Z3 API *) -let bracket me f = Misc.bracket (fun _ -> z3push me) (fun _ -> z3pop me) f - -(* Z3 API *) -let assertPreds me ps = List.iter (fun p -> BS.time "Z3.ass_cst" (Z3.assert_cnstr me) p) ps - -(* Z3 API *) -let valid me p = - bracket me begin fun _ -> - assertPreds me [Z3.mk_not me p]; - BS.time "unsat" unsat me - end - -(* Z3 API *) -let contra me p = - bracket me begin fun _ -> - assertPreds me [p]; - BS.time "unsat" unsat me - end - -(* API *) -let print_stats ppf () = - F.fprintf ppf - "SMT stats: pushes=%d, pops=%d, unsats=%d \n" - !nb_push !nb_pop !nb_unsat - -end diff --git a/external/fixpoint/smtZ3.ml b/external/fixpoint/smtZ3.ml deleted file mode 100644 --- a/external/fixpoint/smtZ3.ml +++ /dev/null @@ -1,93 +0,0 @@ -(* - * Copyright © 2008 The Regents of the University of California. All rights reserved. - * - * Permission is hereby granted, without written agreement and without - * license or royalty fees, to use, copy, modify, and distribute this - * software and its documentation for any purpose, provided that the - * above copyright notice and the following two paragraphs appear in - * all copies of this software. - * - * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY - * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES - * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN - * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY - * OF SUCH DAMAGE. - * - * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, - * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY - * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS - * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION - * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. - *) - -(********************************************************************************) -(** DUMMY SMT-Z3 Solver (for non Z3MEM builds) **********************************) -(********************************************************************************) - -let assertf = FixMisc.Ops.assertf -let msg = "This build is NOT linked against Z3. Please rebuild with Z3MEM=true. Only possible on linux" - -module SMTZ3 : ProverArch.SMTSOLVER = struct - -type context = () -type symbol = () -type sort = () -type ast = () -type fun_decl = () - -let var _ = failwith msg -let boundVar _ = failwith msg -let stringSymbol _ = failwith msg -let funcDecl _ = failwith msg -let isBool _ = failwith msg -let isInt _ = failwith msg -let mkAll _ = failwith msg -let mkRel _ = failwith msg -let mkApp _ = failwith msg -let mkMul _ = failwith msg -let mkDiv _ = failwith msg -let mkAdd _ = failwith msg -let mkSub _ = failwith msg -let mkMod _ = failwith msg -let mkIte _ = failwith msg -let mkInt _ = failwith msg -let mkLit _ = failwith msg -let mkReal _ = failwith msg -let mkTrue _ = failwith msg -let mkFalse _ = failwith msg -let mkNot _ = failwith msg -let mkAnd _ = failwith msg -let mkOr _ = failwith msg -let mkImp _ = failwith msg -let mkIff _ = failwith msg -let astString _ = failwith msg -let sortString _ = failwith msg -let mkIntSort _ = failwith msg -let mkRealSort _ = failwith msg -let mkBoolSort _ = failwith msg -let mkSetSort _ = failwith msg -let mkEmptySet _ = failwith msg -let mkSetAdd _ = failwith msg -let mkSetMem _ = failwith msg -let mkSetCup _ = failwith msg -let mkSetCap _ = failwith msg -let mkSetDif _ = failwith msg -let mkSetSub _ = failwith msg -let mkMapSort _ = failwith msg -let mkMapSelect _ = failwith msg -let mkMapStore _ = failwith msg -let mkSizeSort _ = failwith msg -let mkBitSort _ = failwith msg -let mkBitAnd _ = failwith msg -let mkBitOr _ = failwith msg -let mkContext _ = failwith msg -let unsat _ = failwith msg -let assertAxiom _ = failwith msg -let assertDistinct _ = failwith msg -let bracket _ = failwith msg -let assertPreds _ = failwith msg -let valid _ = failwith msg -let contra _ = failwith msg -let print_stats _ = failwith msg - -end diff --git a/external/fixpoint/smtZ3.nomem.ml b/external/fixpoint/smtZ3.nomem.ml deleted file mode 100644 --- a/external/fixpoint/smtZ3.nomem.ml +++ /dev/null @@ -1,93 +0,0 @@ -(* - * Copyright © 2008 The Regents of the University of California. All rights reserved. - * - * Permission is hereby granted, without written agreement and without - * license or royalty fees, to use, copy, modify, and distribute this - * software and its documentation for any purpose, provided that the - * above copyright notice and the following two paragraphs appear in - * all copies of this software. - * - * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY - * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES - * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN - * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY - * OF SUCH DAMAGE. - * - * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, - * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY - * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS - * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION - * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. - *) - -(********************************************************************************) -(** DUMMY SMT-Z3 Solver (for non Z3MEM builds) **********************************) -(********************************************************************************) - -let assertf = FixMisc.Ops.assertf -let msg = "This build is NOT linked against Z3. Please rebuild with Z3MEM=true. Only possible on linux" - -module SMTZ3 : ProverArch.SMTSOLVER = struct - -type context = () -type symbol = () -type sort = () -type ast = () -type fun_decl = () - -let var _ = failwith msg -let boundVar _ = failwith msg -let stringSymbol _ = failwith msg -let funcDecl _ = failwith msg -let isBool _ = failwith msg -let isInt _ = failwith msg -let mkAll _ = failwith msg -let mkRel _ = failwith msg -let mkApp _ = failwith msg -let mkMul _ = failwith msg -let mkDiv _ = failwith msg -let mkAdd _ = failwith msg -let mkSub _ = failwith msg -let mkMod _ = failwith msg -let mkIte _ = failwith msg -let mkInt _ = failwith msg -let mkLit _ = failwith msg -let mkReal _ = failwith msg -let mkTrue _ = failwith msg -let mkFalse _ = failwith msg -let mkNot _ = failwith msg -let mkAnd _ = failwith msg -let mkOr _ = failwith msg -let mkImp _ = failwith msg -let mkIff _ = failwith msg -let astString _ = failwith msg -let sortString _ = failwith msg -let mkIntSort _ = failwith msg -let mkRealSort _ = failwith msg -let mkBoolSort _ = failwith msg -let mkSetSort _ = failwith msg -let mkEmptySet _ = failwith msg -let mkSetAdd _ = failwith msg -let mkSetMem _ = failwith msg -let mkSetCup _ = failwith msg -let mkSetCap _ = failwith msg -let mkSetDif _ = failwith msg -let mkSetSub _ = failwith msg -let mkMapSort _ = failwith msg -let mkMapSelect _ = failwith msg -let mkMapStore _ = failwith msg -let mkSizeSort _ = failwith msg -let mkBitSort _ = failwith msg -let mkBitAnd _ = failwith msg -let mkBitOr _ = failwith msg -let mkContext _ = failwith msg -let unsat _ = failwith msg -let assertAxiom _ = failwith msg -let assertDistinct _ = failwith msg -let bracket _ = failwith msg -let assertPreds _ = failwith msg -let valid _ = failwith msg -let contra _ = failwith msg -let print_stats _ = failwith msg - -end diff --git a/external/fixpoint/solve.ml b/external/fixpoint/solve.ml deleted file mode 100644 --- a/external/fixpoint/solve.ml +++ /dev/null @@ -1,271 +0,0 @@ -(* - * Copyright © 2009 The Regents of the University of California. All rights reserved. - * - * Permission is hereby granted, without written agreement and without - * license or royalty fees, to use, copy, modify, and distribute this - * software and its documentation for any purpose, provided that the - * above copyright notice and the following two paragraphs appear in - * all copies of this software. - * - * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY - * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES - * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN - * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY - * OF SUCH DAMAGE. - * - * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, - * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY - * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS - * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION - * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. - *) - - -(** This module implements a fixpoint solver *) -module BS = BNstats -module F = Format -module A = Ast -module Co = Constants -module P = A.Predicate -module E = A.Expression -module So = A.Sort -module Su = A.Subst -module Q = Qualifier -module Sy = A.Symbol -module SM = Sy.SMap -module C = FixConstraint -module Ci = Cindex -module PP = Prepass -module Cg = FixConfig -module Misc = FixMisc open Misc.Ops - - -let mydebug = false - -type t = { - sri : Ci.t - ; ws : C.wf list - ; tt : Timer.t - - (* Stats *) - ; stat_refines : int ref - ; stat_cfreqt : (int * bool, int) Hashtbl.t -} - -module type SOLVER = sig - type soln - type bind - val create : bind Cg.cfg -> FixConstraint.soln option -> (t * soln) - val solve : t -> soln -> (soln * (FixConstraint.t list) * Counterexample.cex list) - val save : string -> t -> soln -> unit - val read : soln -> FixConstraint.soln - val min_read : soln -> FixConstraint.soln - val read_bind : soln -> Ast.Symbol.t -> bind - val cone : t -> FixConstraint.id -> FixConstraint.tag Ast.Cone.t - (* val meet : soln -> soln -> soln *) -end - -module Make (Dom : SolverArch.DOMAIN) = struct - type soln = Dom.t - type bind = Dom.bind - let min_read = Dom.min_read - let read = Dom.read - let read_bind = Dom.read_bind -(* let meet = Dom.meet *) - - -(*************************************************************) -(********************* Stats *********************************) -(*************************************************************) - -let hashtbl_incr_frequency t k = - let n = try Hashtbl.find t k with Not_found -> 0 in - Hashtbl.replace t k (n+1) - -let hashtbl_print_frequency t = - Misc.hashtbl_to_list t - |> Misc.kgroupby (fun ((k,b),n) -> (n,b)) - |> List.map (fun ((n,b), xs) -> (n, b, List.map (fst <+> fst) xs)) - |> List.sort compare - |> List.iter begin fun (n, b, xs) -> - Co.bprintf mydebug "ITERFREQ: %d times (ch = %b) %d constraints %s \n" - n b (List.length xs) (Misc.map_to_string string_of_int xs) - end - -(***************************************************************) -(************************ Debugging/Stats **********************) -(***************************************************************) - -let print_constr_stats ppf cs = - let cn = List.length cs in - let scn = List.length (List.filter C.is_simple cs) in - F.fprintf ppf "#Constraints: %d (simple = %d) \n" cn scn - -let print_solver_stats ppf me = - print_constr_stats ppf (Ci.to_list me.sri); - F.fprintf ppf "#Iterations = %d\n" !(me.stat_refines); - F.fprintf ppf "Iteration Frequency: \n"; - hashtbl_print_frequency me.stat_cfreqt; - F.fprintf ppf "Iteration Periods: @[%a@] \n" Timer.print me.tt - -let dump me s = - Co.bprintf mydebug "%a \n" print_solver_stats me; - Co.bprintf mydebug "%a \n" Dom.print_stats s; - Dom.dump s - -let log_iter_stats me s = - (if Co.ck_olev Co.ol_insane then Co.bprintf mydebug "log_iter_stats\n%a" Dom.print s); - (if !(me.stat_refines) mod 100 = 0 then - let msg = Printf.sprintf "\n num refines=%d" !(me.stat_refines) in - let _ = Timer.log_event me.tt (Some msg) in - let _ = Co.bprintf mydebug "%s\n %a\n" msg Dom.print_stats s in - let _ = Format.print_flush () in - ()); - () - -(***************************************************************) -(******************** Iterative Refinement *********************) -(***************************************************************) - -let is_solved s c = - let sol = read s in - c |> C.rhs_of_t - |> C.kvars_of_reft - |> List.map (sol <.> snd) - |> List.for_all ((=) []) - -let refine_constraint s c = - try BS.time "refine" (Dom.refine s) c with ex -> - let _ = F.printf "constraint refinement fails with: %s\n" (Printexc.to_string ex) in - let _ = F.printf "Failed on constraint:\n%a\n" (C.print_t None) c in - raise ex - (* assert false *) - -let update_worklist me s' c w' = - c |> Ci.deps me.sri - |> Misc.filter (not <.> is_solved s') - |> Ci.wpush me.sri w' - -let rec acsolve me w s = - let _ = log_iter_stats me s in - let _ = Misc.display_tick () in - match Ci.wpop me.sri w with - | (None,_) -> - let _ = Timer.log_event me.tt (Some "Finished") in - s - | (Some c, w') -> - let _ = me.stat_refines += 1 in - let (ch, s') = BS.time "refine" (refine_constraint s) c in - let _ = hashtbl_incr_frequency me.stat_cfreqt (C.id_of_t c, ch) in - let _ = Co.bprintf mydebug "iter=%d id=%d ch=%b %a \n" - !(me.stat_refines) (C.id_of_t c) ch C.print_tag (C.tag_of_t c) in - let w'' = if ch then update_worklist me s' c w' else w' in - acsolve me w'' s' - -let unsat_constraints me s = - me.sri |> Ci.to_list |> List.filter (Dom.unsat s) - -let simplify_solution me s = Dom.simplify s - - -(***************************************************************) -(****************** Pruning Unconstrained Vars *****************) -(***************************************************************) - -let rhs_ks cs = - cs |> Misc.flap (Misc.compose C.kvars_of_reft C.rhs_of_t) - |> List.fold_left (fun rhss (_, kv) -> Sy.SSet.add kv rhss) Sy.SSet.empty - -let unconstrained_kvars cs = - let rhss = rhs_ks cs in - cs |> Misc.flap C.kvars_of_t - |> List.map snd - |> List.filter (fun kv -> not (Sy.SSet.mem kv rhss)) - -let true_unconstrained sri s = - sri |> Ci.to_list - |> unconstrained_kvars - |> Dom.top s - -(* -let true_unconstrained sri s = - if !Co.true_unconstrained then - let _ = Co.logPrintf "Fixpoint: Pruning unconstrained kvars \n" - in true_unconstrained sri s - else - let _ = Co.logPrintf "Fixpoint: NOT Pruning unconstrained kvars \n" - in s -*) - -(* API *) -let solve me s = - let _ = Co.bprintflush mydebug "Fixpoint: Validating Initial Solution \n" in - (* let _ = F.printf "create: SOLUTION \n %a \n" Dom.print s in *) - let _ = BS.time "Prepass.profile" PP.profile me.sri in - let _ = Co.bprintflush mydebug "\nBEGIN: Fixpoint: Trueing Unconstrained Variables \n" in - let s = s |> (!Co.true_unconstrained BS.time "Prepass.true_unconstr" (true_unconstrained me.sri)) in - let _ = Co.bprintflush mydebug "\nDONE: Fixpoint: Trueing Unconstrained Variables \n" in - (* let _ = F.printf "create: SOLUTION1 \n %a \n" Dom.print s in *) - let _ = Co.bprintflush mydebug "\nBEGIN: Fixpoint: Initialize Worklist \n" in - let w = BS.time "Cindex.winit" Ci.winit me.sri in - let _ = Co.bprintflush mydebug "\nDONE: Fixpoint: Initialize Worklist \n" in - let _ = Co.bprintflush mydebug "\nBEGIN: Fixpoint Refinement Loop \n" in - let s = BS.time "Solve.acsolve" (acsolve me w) s in - let _ = Co.bprintflush mydebug "\nDONE: Fixpoint Refinement Loop \n" in - (* let _ = F.printf "create: SOLUTION2 \n %a \n" Dom.print s in *) - let s = if !Co.minquals then simplify_solution me s else s in - let _ = Co.bprintflush mydebug "\nDONE: Simplify Solution \n" in - let _ = BS.time "Solve.dump" (dump me) s in - let _ = Co.bprintflush mydebug "Fixpoint: Testing Solution \n" in - let u = BS.time "Solve.unsatcs" (unsat_constraints me) s in - let _ = if u != [] then F.printf "Unsatisfied Constraints:\n %a" (Misc.pprint_many true "\n" (C.print_t None)) u in - let cx = if !Co.cex && Misc.nonnull u then Dom.ctr_examples s (Ci.to_list me.sri) u else [] in - (s, u, cx) - -let global_symbols cfg = - (SM.to_list cfg.Cg.uops) (* specified globals *) - ++ (Theories.interp_syms ()) (* theory globals *) - -(* API *) -let create cfg kf = - let gts = global_symbols cfg in - let sri = cfg.Cg.cs - >> Co.bprintf mydebug "Pre-Simplify Stats\n%a" print_constr_stats - |> BS.time "Constant Env" (List.map (C.add_consts_t gts)) - |> BS.time "Simplify" FixSimplify.simplify_ts - >> Co.bprintf mydebug "Post-Simplify Stats\n%a" print_constr_stats - |> BS.time "Ref Index" Ci.create cfg.Cg.kuts cfg.Cg.ds - |> (!Co.slice BS.time "Slice" Ci.slice) in - let ws = cfg.Cg.ws - |> (!Co.slice BS.time "slice_wf" (Ci.slice_wf sri)) - |> BS.time "Constant EnvWF" (List.map (C.add_consts_wf gts)) - |> PP.validate_wfs in - let cfg = { cfg with Cg.cs = Ci.to_list sri; Cg.ws = ws } in - let s = if !Constants.dump_simp <> "" then Dom.empty () else BS.time "Dom.create" (Dom.create cfg) kf in - let _ = Co.bprintflush mydebug "\nDONE: Dom.create\n" in - let _ = Co.bprintflush mydebug "\nBEGIN: PP.validate\n" in - let _ = Ci.to_list sri - |> BS.time "Validate" (PP.validate cfg.Cg.a (Dom.read s)) in - let _ = Co.bprintflush mydebug "\nEND: PP.validate\n" in - ({ sri = sri - ; ws = ws - (* stat *) - ; tt = Timer.create "fixpoint iters" - ; stat_refines = ref 0 - ; stat_cfreqt = Hashtbl.create 37 - }, s) - >> (fun _ -> Co.bprintflush mydebug "DONE: Solve.create\n") - -(* API *) -let save fname me s = - let oc = open_out fname in - let ppf = F.formatter_of_out_channel oc in - F.fprintf ppf "@[%a@] \n" Ci.print me.sri; - F.fprintf ppf "@[%a@] \n" (Misc.pprint_many true "\n" (C.print_wf None)) me.ws; - F.fprintf ppf "@[%a@] \n" Dom.print s; - close_out oc - -(* API *) -let cone me = Cindex.data_cones (Ci.to_list me.sri) - -end diff --git a/external/fixpoint/solve.mli b/external/fixpoint/solve.mli deleted file mode 100644 --- a/external/fixpoint/solve.mli +++ /dev/null @@ -1,34 +0,0 @@ -(* - * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY - * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES - * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN - * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY - * OF SUCH DAMAGE. - * - * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, - * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY - * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS - * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION - * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. - * - *) - -type t - -module type SOLVER = sig - type soln - type bind - val create : bind FixConfig.cfg -> FixConstraint.soln option -> (t * soln) - val solve : t -> soln -> (soln * (FixConstraint.t list) * Counterexample.cex list) - val save : string -> t -> soln -> unit - val read : soln -> FixConstraint.soln - val min_read : soln -> FixConstraint.soln - val read_bind : soln -> Ast.Symbol.t -> bind - val cone : t -> FixConstraint.id -> FixConstraint.tag Ast.Cone.t - (* val meet : soln -> soln -> soln *) - -end - -module Make (Dom : SolverArch.DOMAIN) : SOLVER - with type bind = Dom.bind - with type soln = Dom.t diff --git a/external/fixpoint/solverArch.ml b/external/fixpoint/solverArch.ml deleted file mode 100644 --- a/external/fixpoint/solverArch.ml +++ /dev/null @@ -1,44 +0,0 @@ -(* - * Copyright © 2009 The Regents of the University of California. All rights reserved. - * - * Permission is hereby granted, without written agreement and without - * license or royalty fees, to use, copy, modify, and distribute this - * software and its documentation for any purpose, provided that the - * above copyright notice and the following two paragraphs appear in - * all copies of this software. - * - * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY - * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES - * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN - * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY - * OF SUCH DAMAGE. - * - * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, - * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY - * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS - * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION - * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. - * - *) - -type qbind = Qualifier.t list - -module type DOMAIN = sig - type t - type bind - val empty : unit -> t - (* val meet : t -> t -> t *) - val min_read : t -> FixConstraint.soln - val read : t -> FixConstraint.soln - val read_bind : t -> Ast.Symbol.t -> bind - val top : t -> Ast.Symbol.t list -> t - val refine : t -> FixConstraint.t -> (bool * t) - val unsat : t -> FixConstraint.t -> bool - val create : bind FixConfig.cfg -> FixConstraint.soln option -> t - val print : Format.formatter -> t -> unit - val print_stats : Format.formatter -> t -> unit - val dump : t -> unit - val simplify : t -> t - val ctr_examples : t -> FixConstraint.t list -> FixConstraint.t list -> Counterexample.cex list - val mkbind : qbind -> bind -end diff --git a/external/fixpoint/theories.ml b/external/fixpoint/theories.ml deleted file mode 100644 --- a/external/fixpoint/theories.ml +++ /dev/null @@ -1,347 +0,0 @@ -(* - * Copyright © 2009 The Regents of the University of California. All rights reserved. - * - * Permission is hereby granted, without written agreement and without - * license or royalty fees, to use, copy, modify, and distribute this - * software and its documentation for any purpose, provided that the - * above copyright notice and the following two paragraphs appear in - * all copies of this software. - * - * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY - * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES - * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN - * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY - * OF SUCH DAMAGE. - * - * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, - * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY - * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS - * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION - * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. - *) - -module So = Ast.Sort -module Sy = Ast.Symbol - -open ProverArch -open FixMisc.Ops - -(***************************************************************************) -(********************* NAMES (independent of SMT) **************************) -(***************************************************************************) - -(********************* Sets ************************************************) - -let set_tycon = So.tycon "Set_Set" -let t_set a = So.t_app set_tycon [a] - -(* API *) -let emp0 = ( Sy.of_string "Set_empty" - , So.t_func 1 [So.t_int; t_set (So.t_generic 0)] ) - -let emp = ( Sy.of_string "Set_emp" - , So.t_func 1 [t_set (So.t_generic 0); So.t_bool] ) - -let sng = ( Sy.of_string "Set_sng" - , So.t_func 1 [So.t_generic 0; t_set (So.t_generic 0)] ) - -let mem = ( Sy.of_string "Set_mem" - , So.t_func 1 [So.t_generic 0; t_set (So.t_generic 0); So.t_bool] ) - -let cup = ( Sy.of_string "Set_cup" - , So.t_func 1 [t_set (So.t_generic 0); t_set (So.t_generic 0); t_set (So.t_generic 0)]) - -let cap = ( Sy.of_string "Set_cap" - , So.t_func 1 [t_set (So.t_generic 0); t_set (So.t_generic 0); t_set (So.t_generic 0)]) - -let dif = ( Sy.of_string "Set_dif" - , So.t_func 1 [t_set (So.t_generic 0); t_set (So.t_generic 0); t_set (So.t_generic 0)]) - -let sub = ( Sy.of_string "Set_sub" - , So.t_func 1 [t_set (So.t_generic 0); t_set (So.t_generic 0); So.t_bool] ) - -(********************* Maps ************************************************) - -let map_tycon = So.tycon "Map_t" - -let t_map k v = So.t_app map_tycon [k; v] - -let select = let k = So.t_generic 0 in - let v = So.t_generic 1 in - ( Sy.of_string "Map_select" - , So.t_func 2 [t_map k v; k; v] ) - -let store = let k = So.t_generic 0 in - let v = So.t_generic 1 in - ( Sy.of_string "Map_store" - , So.t_func 2 [t_map k v; k; v; t_map k v] ) - - - -(********************* Maps ************************************************) - -let bv_tycon = So.tycon "BitVec" -let sz32_tycon = So.tycon "Size32" -let sz64_tycon = So.tycon "Size64" -let t_bv a = So.t_app bv_tycon [a] - -let bv_binop op = let k = So.t_generic 0 in - ( Sy.of_string op - , So.t_func 1 [t_bv k; t_bv k; t_bv k] ) - -let bvand = bv_binop "bvand" -let bvor = bv_binop "bvor" - - -(********************* All Theories ****************************************) -(** WARNING: DO NOT PUT INSIDE MakeTheory; adds SMT dependency *************) -(***************************************************************************) - -(* API *) -let is_interp t = List.mem t [set_tycon; map_tycon; sz32_tycon; sz64_tycon; bv_tycon] - -(* API *) -let interp_syms _ - = [] - |> (!Constants.set_theory (++) [emp0 ; emp; sng; mem; cup; cap; dif; sub]) - |> (!Constants.map_theory (++) [select; store]) - |> (!Constants.bit_theory (++) [bvand ; bvor]) - - -(***************************************************************************) -(***************************************************************************) -(***************************************************************************) - -module MakeTheory(SMT : SMTSOLVER): - (THEORY with type context = SMT.context - and type sort = SMT.sort - and type ast = SMT.ast) - = struct - -type context = SMT.context -type sort = SMT.sort -type ast = SMT.ast - - -type appDef = { sy_name : Sy.t - ; sy_sort : So.t - ; sy_emb : SMT.context -> SMT.sort list -> SMT.ast list -> SMT.ast - } - -type sortDef = { so_name : Ast.Sort.tycon - ; so_arity : int - ; so_emb : SMT.context -> SMT.sort list -> SMT.sort - } - -(* API *) -let sort_name d = d.so_name -let sym_name d = d.sy_name -let sym_sort d = d.sy_sort - -(***************************************************************************) -(********* Wrappers Around Z3 Constructors For Last-Minute Checking ********) -(***************************************************************************) - -let app_sort_arity def = match So.func_of_t def.sy_sort with - | Some (n,_,_) -> n - | None -> assertf "Theories: app with non-function symbol %s" - (Sy.to_string def.sy_name) - -let check_app_arities def tArgs eArgs = match So.func_of_t def.sy_sort with - | Some (n, ts,_) - -> asserts (n = List.length tArgs) - "Theories: app with mismatched sorts %s" (Sy.to_string def.sy_name); - asserts (List.length ts = List.length eArgs) - "Theories: app with mismatched args %s" (Sy.to_string def.sy_name) - | None - -> assertf "Theories: app with non-function symbol %s" - (Sy.to_string def.sy_name) - - -(* API *) -let mk_thy_app def c ts es = - check_app_arities def ts es; - def.sy_emb c ts es - -(* API *) -let mk_thy_sort def c ts = - asserts (List.length ts = def.so_arity) - "Theories: app with mismatched sorts %s" (So.tycon_string def.so_name); - def.so_emb c ts - - -(** Theory of Sets *********************************************************) - - -let set_t : sortDef = - { so_name = set_tycon - ; so_arity = 1 - ; so_emb = fun c -> function - [t] -> SMT.mkSetSort c t - | _ -> assertf "Set_set: type mismatch" - } - -let set_empty : appDef = - { sy_name = fst emp0 - ; sy_sort = snd emp0 - ; sy_emb = fun c ts es -> match ts, es with - | [t], [_] -> SMT.mkEmptySet c t - | _ -> assertf "Set_empty: type mismatch" - } - -let set_emp : appDef = - { sy_name = fst emp - ; sy_sort = snd emp - ; sy_emb = fun c ts es -> match ts, es with - | [t], [e] -> SMT.mkRel c Ast.Eq e (SMT.mkEmptySet c t) - | _ -> assertf "Set_emp: type mismatch" - } - -let set_sng : appDef = - { sy_name = fst sng - ; sy_sort = snd sng - ; sy_emb = fun c ts es -> match ts, es with - | [t], [e] -> SMT.mkSetAdd c (SMT.mkEmptySet c t) e - | _ -> assertf "Set_sng: type mismatch" - } - - -let set_mem : appDef = - { sy_name = fst mem - ; sy_sort = snd mem - ; sy_emb = fun c ts es -> match ts, es with - | [_], [e;es] -> SMT.mkSetMem c e es - | _ -> assertf "Set_mem: type mismatch" - } - -let set_cup : appDef = - { sy_name = fst cup - ; sy_sort = snd cup - ; sy_emb = fun c ts es -> match ts, es with - | [t], [e1;e2] -> SMT.mkSetCup c e1 e2 - | _ -> assertf "Set_cup: type mismatch" - } - -let set_cap : appDef = - { sy_name = fst cap - ; sy_sort = snd cap - ; sy_emb = fun c ts es -> match ts, es with - | [t], [e1;e2] -> SMT.mkSetCap c e1 e2 - | _ -> assertf "Set_cap: type mismatch" - } - -let set_dif : appDef = - { sy_name = fst dif - ; sy_sort = snd dif - ; sy_emb = fun c ts es -> match ts, es with - | [t], [e1;e2] -> SMT.mkSetDif c e1 e2 - | _ -> assertf "Set_dif: type mismatch" - } - -let set_sub : appDef = - { sy_name = fst sub - ; sy_sort = snd sub - ; sy_emb = fun c ts es -> match ts, es with - | [t], [e1;e2] -> SMT.mkSetSub c e1 e2 - | _ -> assertf "Set_dif: type mismatch" - } - -(* API *) -let theory_set - = ([ set_t ] - ,[ set_emp - ; set_empty - ; set_sng - ; set_mem - ; set_cup - ; set_cap - ; set_dif - ; set_sub ]) - -(** Theory of Maps *********************************************************) - -let map_t : sortDef = - { so_name = map_tycon - ; so_arity = 2 - ; so_emb = fun c -> function - | [k; v] -> SMT.mkMapSort c k v - | _ -> assertf "Map_t: type mismatch" - } - -let map_select : appDef = - { sy_name = fst select - ; sy_sort = snd select - ; sy_emb = fun c ts es -> match ts, es with - | [_; _], [m; k] -> SMT.mkMapSelect c m k - | _ -> assertf "Map_select: type mismatch" - } - -let map_store : appDef = - { sy_name = fst store - ; sy_sort = snd store - ; sy_emb = fun c ts es -> match ts, es with - | [_; _], [m; k; v] -> SMT.mkMapStore c m k v - | _ -> assertf "Map_store: type mismatch" - } - -(* API *) -let theory_map - = ([map_t], [map_select; map_store]) - -(** Theory of Bitvectors ***************************************************) - -let size32_t : sortDef = - { so_name = sz32_tycon - ; so_arity = 1 - ; so_emb = fun c -> function - | [_] -> SMT.mkSizeSort c 32 - | _ -> assertf "Map_t: type mismatch" - } - -let size64_t : sortDef = - { so_name = sz64_tycon - ; so_arity = 1 - ; so_emb = fun c -> function - | [_] -> SMT.mkSizeSort c 64 - | _ -> assertf "Map_t: type mismatch" - } - -let bit_t : sortDef = - { so_name = bv_tycon - ; so_arity = 1 - ; so_emb = fun c -> function - | [n] -> SMT.mkBitSort c n - | _ -> assertf "BitVector: type mismatch" - } - -let bit_and : appDef = - { sy_name = fst bvand - ; sy_sort = snd bvand - ; sy_emb = fun c ts es -> match ts, es with - | [_], [x; y] -> SMT.mkBitAnd c x y - | _ -> assertf "bit_and: type mismatch" - } - -let bit_or : appDef = - { sy_name = fst bvor - ; sy_sort = snd bvor - ; sy_emb = fun c ts es -> match ts, es with - | [_], [x; y] -> SMT.mkBitOr c x y - | _ -> assertf "bit_or: type mismatch" - } - -(* API *) -let theory_bit - = ([size32_t; size64_t; bit_t], [bit_and; bit_or]) - -(** Theory Composition *****************************************************) - -(* API *) -let theories () = - let add_thy (t1,s1) (t2,s2) = (t1 ++ t2, s1 ++ s2) in - ([], []) - |> (!Constants.set_theory add_thy theory_set) - |> (!Constants.map_theory add_thy theory_map) - |> (!Constants.bit_theory add_thy theory_bit) - -end diff --git a/external/fixpoint/theories.mli b/external/fixpoint/theories.mli deleted file mode 100644 --- a/external/fixpoint/theories.mli +++ /dev/null @@ -1,27 +0,0 @@ -(* - * Copyright © 2009 The Regents of the University of California. All rights reserved. - * - * Permission is hereby granted, without written agreement and without - * license or royalty fees, to use, copy, modify, and distribute this - * software and its documentation for any purpose, provided that the - * above copyright notice and the following two paragraphs appear in - * all copies of this software. - * - * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY - * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES - * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN - * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY - * OF SUCH DAMAGE. - * - * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, - * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY - * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS - * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION - * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. - *) - -val is_interp : Ast.Sort.tycon -> bool -val interp_syms : unit -> (Ast.Symbol.t * Ast.Sort.t) list - -module MakeTheory(SMT : ProverArch.SMTSOLVER): (ProverArch.THEORY with type context = SMT.context and type sort = SMT.sort and type ast = SMT.ast) - diff --git a/external/fixpoint/timeout.ml b/external/fixpoint/timeout.ml deleted file mode 100644 --- a/external/fixpoint/timeout.ml +++ /dev/null @@ -1,30 +0,0 @@ - - -module M = Mutex -module T = Thread - -let get_time () = int_of_float (Unix.time ()) - -let mk_task = - fun f x lk (ret, rd) -> let rv = f x in - M.lock lk; ret := Some rv; rd := true; M.unlock lk - -let not_done lk (ret, rd) = - M.lock lk; let trd = !rd in (M.unlock lk; not(trd)) - -let fail thread (ret, rd) = - T.kill thread; ret := None; rd := true - -let do_timeout i f x = - let task = mk_task f x in - let (ret, rd) as rr = (ref None, ref false) in - let stime = get_time () in - let lk = M.create () in - let t = T.create (task lk) rr in - while not_done lk rr do - if (get_time () - stime < i) then - T.yield () - else - fail t rr - done; !ret - diff --git a/external/fixpoint/timeout.mli b/external/fixpoint/timeout.mli deleted file mode 100644 --- a/external/fixpoint/timeout.mli +++ /dev/null @@ -1,4 +0,0 @@ -(* simple timeout mechanism executes a function for a number of seconds - * specified by the first argument *) - -val do_timeout: int -> ('a -> 'b) -> 'a -> 'b option diff --git a/external/fixpoint/toARMC.ml b/external/fixpoint/toARMC.ml deleted file mode 100644 --- a/external/fixpoint/toARMC.ml +++ /dev/null @@ -1,333 +0,0 @@ -(* translation to ARMC *) - -module C = FixConstraint -module StrMap = Map.Make (struct type t = string let compare = compare end) -module StrSet = Set.Make (struct type t = string let compare = compare end) -module Misc = FixMisc open Misc.Ops - - -(* Andrey: TODO get rid of grd in t? grd p is a binding v:{v:b|p} *) -(* Andrey: TODO move to fixConstraint.ml? *) - - -(* Andrey: TODO move to ast.ml? *) -let pred_is_atomic (p, _) = - match p with - | Ast.True | Ast.False | Ast.Bexp _ | Ast.Atom _ -> true - | Ast.And _ | Ast.Or _ | Ast.Not _ | Ast.Imp _ | Ast.Forall _ -> false - -(* -let negate_brel = function - | Ast.Eq -> Ast.Ne - | Ast.Ne -> Ast.Eq - | Ast.Gt -> Ast.Le - | Ast.Ge -> Ast.Lt - | Ast.Lt -> Ast.Ge - | Ast.Le -> Ast.Gt - -let deep_negate_pred (p, t) = - match p with - | Ast.True -> Ast.pFalse - | Ast.False -> Ast.pTrue - | Ast.Atom (e1, r, e2) -> Ast.pAtom (e1, negate_brel r, e2) - | _ -> Ast.pNot (p, t) -*) - -let start_pc = "start" -let loop_pc = "loop" -let error_pc = "error" -let val_vname = "VVVV" -let card_vname = "CARD" -let exists_kv = "EX" -let primed_suffix = "p" -let str__cil_tmp = "__cil_tmp" - -type kv_scope = { - kvs : string list; - kv_scope : string list StrMap.t -} - -let sanitize_symbol s = - Str.global_replace (Str.regexp "@") "_at_" s |> Str.global_replace (Str.regexp "#") "_hash_" - -let symbol_to_armc s = Ast.Symbol.to_string s |> sanitize_symbol - -let mk_data_var ?(suffix = "") kv v = - Printf.sprintf "_%s_%s%s%s" - (sanitize_symbol kv) (sanitize_symbol v) (if suffix = "" then "" else "_") suffix - -let constant_to_armc = Ast.Constant.to_string -let bop_to_armc = function - | Ast.Plus -> "+" - | Ast.Minus -> "-" - | Ast.Times -> "*" - | Ast.Div -> "/" -let brel_to_armc = function - | Ast.Eq -> "=" - | Ast.Ne -> "=\\=" - | Ast.Gt -> ">" (* ">= 1+" *) - | Ast.Ge -> ">=" - | Ast.Lt -> "<" (* "+1 =<" *) - | Ast.Le -> "=<" -let bind_to_armc (s, t) = (* Andrey: TODO support binders *) - Printf.sprintf "%s:%s" (symbol_to_armc s) (Ast.Sort.to_string t |> sanitize_symbol) -let rec expr_to_armc (e, _) = - match e with - | Ast.Con c -> constant_to_armc c - | Ast.Var s -> mk_data_var exists_kv (symbol_to_armc s) - | Ast.App (s, es) -> - let str = symbol_to_armc s in - if es = [] then str else - Printf.sprintf "f_%s(%s)" str (List.map expr_to_armc es |> String.concat ", ") - | Ast.Bin (e1, op, e2) -> - Printf.sprintf "(%s %s %s)" - (expr_to_armc e1) (bop_to_armc op) (expr_to_armc e2) - | Ast.Ite (ip, te, ee) -> - Printf.sprintf "ite(%s, %s, %s)" - (pred_to_armc ip) (expr_to_armc te) (expr_to_armc ee) - | Ast.Fld (s, e) -> - Printf.sprintf "fld(%s, %s)" (expr_to_armc e) (symbol_to_armc s) -and pred_to_armc (p, _) = - match p with - | Ast.True -> "1=1" - | Ast.False -> "0=1" - | Ast.Bexp e -> expr_to_armc e - | Ast.Not p -> Printf.sprintf "neg(%s)" (pred_to_armc p) - | Ast.Imp (p1, p2) -> Printf.sprintf "(neg(%s); %s)" (pred_to_armc p1) (pred_to_armc p2) - | Ast.And [] -> "1=1" - | Ast.And [p] -> pred_to_armc p - | Ast.And (_::_ as ps) -> Printf.sprintf "(%s)" (List.map pred_to_armc ps |> String.concat ", ") - | Ast.Or [] -> "0=1" - | Ast.Or [p] -> pred_to_armc p - | Ast.Or (_::_ as ps) -> Printf.sprintf "(%s)" (List.map pred_to_armc ps |> String.concat "; ") - | Ast.Atom (e1, r, e2) -> - Printf.sprintf "%s %s %s" - (expr_to_armc e1) (brel_to_armc r) (expr_to_armc e2) - | Ast.Forall (qs,p) -> (* Andrey: TODO support forall *) - Printf.sprintf "forall([%s], %s)" - (List.map bind_to_armc qs |> String.concat ", ") - (pred_to_armc p) - - -let mk_kv_scope out ts wfs = - output_string out "% kv -> scope:\n"; - let kvs = List.map C.kvars_of_t ts |> List.flatten |> List.map snd - |> List.map symbol_to_armc |> Misc.sort_and_compact in - let kv_scope = - List.fold_left - (fun m wf -> - match C.reft_of_wf wf |> C.ras_of_reft with - | [C.Kvar([], kvar)] -> - let v = symbol_to_armc kvar in - let scope = - card_vname :: val_vname :: - (C.env_of_wf wf |> C.bindings_of_env |> List.map fst |> List.map symbol_to_armc - |> List.filter (fun s -> not (Misc.is_prefix str__cil_tmp s)) |> List.sort compare) in - Printf.fprintf out "%% %s -> %s\n" - v (String.concat ", " scope); - StrMap.add v scope m - | _ -> (* Andrey: TODO print ill-formed wf *) - failure "ERROR: kname_scope_map: ill-formed wf" - ) StrMap.empty wfs in - {kvs = kvs; kv_scope = kv_scope} - -let mk_data ?(suffix = "") ?(skip_kvs = []) s = - Printf.sprintf "[%s]" - (List.map - (fun kv -> - try - StrMap.find kv s.kv_scope |> - List.map (mk_data_var ~suffix:(if List.mem kv skip_kvs then "" else suffix) kv) - with Not_found -> failure "ERROR: rel_state_vs: scope not found for %s" kv - ) s.kvs |> List.flatten |> String.concat ", ") - -let mk_var2names state = - List.map - (fun kv -> - List.map - (fun v -> - Printf.sprintf "(%s, \'%s_%s\')" - (mk_data_var kv v) kv v - ) (StrMap.find kv state.kv_scope) |> String.concat ", " - ) state.kvs |> String.concat ", " - -let mk_skip_update state kvs = - if kvs = [] then "1=1" else - List.map - (fun kv -> - List.map - (fun v -> - Printf.sprintf "%s = %s" - (mk_data_var ~suffix:primed_suffix kv v) (mk_data_var kv v) - ) (StrMap.find kv state.kv_scope) |> String.concat ", " - ) kvs |> String.concat ", " - -let mk_update_str from_vs to_vs updates = - List.map2 - (fun v vp -> - Printf.sprintf "%s = %s" vp (try StrMap.find v updates with Not_found -> v) - ) from_vs to_vs |> String.concat ", " - -let split_scope scope = - match scope with - | card :: value :: data -> card, value, data - | _ -> failure "ERROR: split_scope: empty scope %s" (String.concat ", " scope) - -let reft_to_armc ?(suffix = "") state reft = - let vv = C.vv_of_reft reft |> symbol_to_armc in - let rs = C.ras_of_reft reft in - if rs = [] then "1=1" else - List.map - (function - | C.Conc pred -> pred_to_armc pred - | C.Kvar (subs, sym) -> - let subs_map = List.fold_left - (fun m (s, e) -> StrMap.add (symbol_to_armc s) e m) StrMap.empty subs in - let find_subst v default = - try StrMap.find v subs_map |> expr_to_armc with Not_found -> default in - let kv = symbol_to_armc sym in - let card, value, data = StrMap.find kv state.kv_scope |> split_scope in - Printf.sprintf "%s = 1" (mk_data_var ~suffix:suffix kv card) - :: Printf.sprintf "%s = %s" - (mk_data_var ~suffix:suffix kv value) - (find_subst vv (mk_data_var exists_kv vv)) - :: List.map - (fun v -> - Printf.sprintf "%s = %s" - (mk_data_var ~suffix:suffix kv v) - (find_subst v (mk_data_var exists_kv v)) - ) data |> String.concat ", " - ) rs |> String.concat ", " - -let mk_rule from_pc from_data to_pc to_data annot_guards annot_updates id = -(* - let unless_error l = if to_pc = error_pc then to_pc else l in - let from_pc, to_pc = - if id = "t_init" then - from_pc, unless_error "l0" - else if List.mem id ["11"; "12"; "13"; "14"; "15"; "16"; "17"; "18"; "19"] then - "l0", unless_error "l1" - else if List.mem id ["1"; "2"; "3"; "4"; "5"; "6"; "7"; "8"; "9"; "10"; "20"; "21"; "22"; "23"; "24"; "25"; "26"; "27"; "28"] then - "l1", unless_error "l1" - else if List.mem id ["29"; "30"; "31"; "32"; "33"; "34"; "35"; "36"; "37"; "38"; "39"; "40"; "41"; "42"; "43"; "44"; "45"] then - "l1", unless_error "l2" - else - "l2", unless_error "l2" - in -*) - let rec annot_conj_to_armc = function - | (g, a) :: rest -> - if rest = [] then Printf.sprintf "\n %s \t%% %s\n ]," g a - else Printf.sprintf "\n %s, \t%% %s%s" g a (annot_conj_to_armc rest) - | [] -> "]," - in - Printf.sprintf - " -r(p(pc(%s), data(%s)), - p(pc(%s), data(%s)), - [%s - [%s - %s). -" - from_pc from_data to_pc to_data - (annot_conj_to_armc annot_guards) - (annot_conj_to_armc annot_updates) - id - -let t_to_armc from_data to_data state t = - let grd = C.grd_of_t t in - let lhs = C.lhs_of_t t in - let rhs = C.rhs_of_t t in - let rhs_s = C.reft_to_string rhs in - let tag = try string_of_int (C.id_of_t t) with _ -> - failure "ERROR: t_to_armc: anonymous constraint %s" (C.to_string t) in - let annot_guards = - List.map - (fun (bv, reft) -> - reft_to_armc state (C.theta [(C.vv_of_reft reft, Ast.eVar bv)] reft), - C.binding_to_string (bv, reft) - ) (C.env_of_t t |> C.bindings_of_env) - ++ [(pred_to_armc grd, Ast.Predicate.to_string grd); - (reft_to_armc state lhs, "|- " ^ (C.reft_to_string lhs))] in - let ps, kvs = - List.fold_left (fun (ps', kvs') refa -> - match refa with - | C.Conc p -> p::ps', kvs' - | C.Kvar (subs, sym) -> ps', (subs, sym)::kvs' - ) ([], []) (C.ras_of_reft rhs) in - (if ps <> [] then - [mk_rule loop_pc from_data error_pc to_data annot_guards - [(Ast.pAnd ps |> Ast.pNot |> pred_to_armc, "<: " ^ rhs_s)] - tag] - else - []) - ++ - (List.map - (fun (_, sym) -> - let kv = symbol_to_armc sym in - let skip_kvs = List.filter (fun kv' -> kv <> kv') state.kvs in - mk_rule loop_pc from_data loop_pc - (mk_data ~suffix:primed_suffix ~skip_kvs:skip_kvs state) - annot_guards - [(reft_to_armc ~suffix:primed_suffix state rhs, "<: " ^ rhs_s)] - tag - ) kvs) - -let to_armc out ts wfs = - print_endline "Translating to ARMC."; - let state = mk_kv_scope out ts wfs in - let from_data = mk_data state in - let to_data = mk_data ~suffix:primed_suffix state in - Printf.fprintf out - ":- multifile r/5,implicit_updates/0,var2names/2,preds/2,trans_preds/3,cube_size/1,start/1,error/1,refinement/1,cutpoint/1,invgen_template/2,invgen_template/1,cfg_exit_relation/1,stmtsrc/2,strengthening/2. - -refinement(inter). -cube_size(1). - -start(pc(%s)). -error(pc(%s)). -cutpoint(pc(%s)). - -preds(p(_, data(%s)), [%s]). - -trans_preds(p(_, data(%s)), p(_, data(%s)), []). - -var2names(p(_, data(%s)), [%s]). -" - start_pc error_pc loop_pc - from_data (List.map (fun kv -> - let card, _, _ = StrMap.find kv state.kv_scope |> split_scope in - let kv_card = mk_data_var kv card in - Printf.sprintf "%s = 0, %s = 1" kv_card kv_card - ) state.kvs |> String.concat ", ") (* preds *) - from_data to_data (* trans_preds *) - from_data (mk_var2names state); (* var2names *) - output_string out - (mk_rule start_pc from_data loop_pc to_data [] - [(List.map - (fun kv -> - let card, _, _ = StrMap.find kv state.kv_scope |> split_scope in - Printf.sprintf "%s = 0" (mk_data_var ~suffix:primed_suffix kv card) - ) state.kvs |> String.concat ", ", - "")] - "t_init"); - List.iter (fun t -> t_to_armc from_data to_data state t |> List.iter (output_string out)) ts - - -(* - make -f Makefile.fixtop && ./f -latex /tmp/main.tex -armc /tmp/a.pl tests/pldi08-max.fq && cat /tmp/a.pl - -tests: - -for file in `ls pldi08-*-atom.fq`; do ../f -latex /tmp/main.tex -armc /tmp/a.pl $file; head -n 1 /tmp/a.pl; armc a.pl | grep correct; done - -pldi08-arraymax-atom.fq pass -pldi08-max-atom.fq pass -pldi08-foldn-atom.fq pass -pldi08-sum-atom.fq pass -mask-atom.fq pass -samples-atom.fq pass - -test00.c pass - -*) diff --git a/external/fixpoint/toDot.ml b/external/fixpoint/toDot.ml deleted file mode 100644 --- a/external/fixpoint/toDot.ml +++ /dev/null @@ -1,173 +0,0 @@ -module C = FixConstraint -module StrSet = Set.Make (struct type t = string let compare = compare end) -module StrStrSet = Set.Make (struct type t = StrSet.t let compare = StrSet.compare end) - -module S2 = StrSet -module S3 = StrStrSet -module Misc = FixMisc open Misc.Ops - - -module V = struct - type t = string - let compare = Pervasives.compare - let hash = Hashtbl.hash - let equal = (=) -end -module E = struct - type t = string - let compare = Pervasives.compare - let default = "" -end - - -module G = Graph.Persistent.Digraph.ConcreteLabeled(V)(E) - -module Display = struct - include G - let vertex_name v = "\"" ^ String.escaped v ^ "\"" - let graph_attributes _ = [] - let default_vertex_attributes _ = [] - let vertex_attributes _ = [] - let default_edge_attributes _ = [] - let edge_attributes e = [`Label (G.E.label e)] - let get_subgraph _ = None -end - -module DotOutput = Graph.Graphviz.Dot(Display) - -module SCC = Graph.Components.Make(G) - -let vertices_of_graph g = G.fold_vertex (fun v vs -> v::vs) g [] -let edges_e_of_graph g = G.fold_edges_e (fun e es -> e::es) g [] - -let set_of_strings = List.fold_left (fun s x -> StrSet.add x s) StrSet.empty - -let set_to_string default s = - if StrSet.is_empty s then default else StrSet.elements s |> List.map String.escaped |> String.concat ", " - -let edges_e_to_graph es = List.fold_left (fun g e -> G.add_edge_e g e) G.empty es - -(* k_1, ..., k_n <: k_0 depends on l_1, ..., l_m <: l_0 iff l_0 = k_i for some 1 \leq i \leq n *) - - -let t_to_dep t = - let env = C.env_of_t t in - let lhs = C.lhs_of_t t in - let rhs = C.rhs_of_t t in - let tag = try string_of_int (C.id_of_t t) with _ -> - failure "ERROR: t_to_edge: anonymous constraint %s" (C.to_string t) in - let src = - C.kvars_of_reft lhs :: List.map (fun b -> snd b |> C.kvars_of_reft) (C.bindings_of_env env) |> - List.flatten |> List.map snd |> List.map Ast.Symbol.to_string |> set_of_strings in - let dst = C.kvars_of_reft rhs |> List.map snd |> List.map Ast.Symbol.to_string |> set_of_strings in - src, tag, dst - -let sccs_to_dot g prefix = - let n, scc_of = SCC.scc g in - let vs = vertices_of_graph g in - Printf.printf "%s #scc = %d\n" prefix n; - for i = 0 to n-1 do - let scc, rest = List.partition (fun v -> scc_of v = i) vs in - let g' = List.fold_left (fun g'' v -> G.remove_vertex g'' v) g rest in - let out = open_out (Printf.sprintf "/tmp/%s-scc-%d.dot" prefix i) in - Printf.printf "%s scc %d %s\n" prefix i (String.concat ", " scc); - DotOutput.output_graph out g'; - close_out out - done - - -let mk_dep_graph ts = - let ds' = List.map t_to_dep ts in - let ds = List.map (fun (src, tag, dst) -> - (if StrSet.is_empty src then StrSet.singleton "start" else src), - tag, - (if StrSet.is_empty dst then StrSet.singleton "error" else dst) - ) ds' in - let g = - List.map - (fun (src, tag, dst) -> - Misc.map_partial - (fun (src', tag', dst') -> - let inter = StrSet.inter dst src' in - if StrSet.is_empty inter then - None - else - begin - Printf.printf "self loop %s\n" tag; - Some(G.E.create tag (set_to_string "" inter) tag') (* tag depends on tag' via inter *) - end - ) ds - ) ds |> List.flatten |> edges_e_to_graph in - let srcs = List.fold_left (fun xs (src, tag, dst) -> src::xs) [] ds' in - -(* - let veanu = - List.fold_left (fun xs src -> - S3.fold (fun x ys -> - ys |> S3.add (S2.diff x src) |> S3.add (S2.diff src x) |> S3.add (S2.inter x src) - ) xs S3.empty - ) (List.hd srcs |> S3.singleton) (List.tl srcs) in -*) - let oc = open_out "/tmp/dep.dot" in - DotOutput.output_graph oc g; - close_out oc; - sccs_to_dot g "dep"; - print_endline "start deps"; - List.iter (fun (src, tag, dst) -> - Printf.printf "%s <: %s (%s)\n" (set_to_string "" src) (set_to_string "" dst) tag) ds; - print_endline "end deps"; - print_endline "start dep graph"; - List.iter (fun e -> - Printf.printf "%s - %s -> %s\n" (G.E.src e) (G.E.label e) (G.E.dst e)) (edges_e_of_graph g); - print_endline "end dep graph" -(* - Printf.printf "Veanu %d sets\n%s\n" - (S3.cardinal veanu) - (S3.fold (fun x s -> - (Printf.sprintf "{%s}" (set_to_string "empty" x))::s - ) veanu [] |> String.concat ",\n") -*) - - -let other_graph ts = - let deps = List.map t_to_dep ts in - let srcs, dsts = List.map (fun (s, _, d) -> s, d) deps |> List.split in - let es = List.map (fun (src, tag, dst) -> - G.E.create (set_to_string "start" src) tag (set_to_string "error" dst) - ) deps in - let es' = List.fold_left (fun es'' dst -> - Misc.map_partial (fun src -> - if StrSet.diff dst src |> StrSet.is_empty then - Some (G.E.create (set_to_string "error" dst) "" (set_to_string "start" src)) - else - None - ) srcs ++ es'' - ) es dsts in - let g = List.fold_left (fun g e -> G.add_edge_e g e) G.empty es' in - g - -let t_to_edge t = - let srcs', tag, dsts' = t_to_dep t in - let srcs = if StrSet.is_empty srcs' then ["start"] else StrSet.elements srcs' in - let dsts = if StrSet.is_empty dsts' then ["error"] else StrSet.elements dsts' in - List.fold_left (fun es src -> List.map (G.E.create src tag) dsts ++ es) [] srcs - - - - -let to_dot oc ts = - let _ = List.fold_left (fun g e -> G.add_edge_e g e ) G.empty (List.map t_to_edge ts |> List.flatten) in - let g = other_graph ts in - let vs = G.fold_vertex (fun v vs' -> v::vs') g [] in - let n, scc_of = SCC.scc g in - DotOutput.output_graph oc g; - Printf.printf "#scc = %d\n" n; - for i = 0 to n-1 do - let scc, rest = List.partition (fun v -> scc_of v = i) vs in - let g' = List.fold_left (fun g'' v -> G.remove_vertex g'' v) g rest in - let out = open_out (Printf.sprintf "/tmp/scc-%d.dot" i) in - Printf.printf "scc %d %s\n" i (String.concat ", " scc); - DotOutput.output_graph out g'; - close_out out - done; - mk_dep_graph ts diff --git a/external/fixpoint/toHC.ml b/external/fixpoint/toHC.ml deleted file mode 100644 --- a/external/fixpoint/toHC.ml +++ /dev/null @@ -1,613 +0,0 @@ -(* translation to HC'ARMC *) - - -module C = FixConstraint -module Co = Constants -module Sy = Ast.Symbol -module Su = Ast.Subst -module P = Ast.Predicate -module E = Ast.Expression -module StrMap = Map.Make (struct type t = string let compare = compare end) -module StrSet = Set.Make (struct type t = string let compare = compare end) -module Misc = FixMisc open Misc.Ops - -let strlist_to_strset = List.fold_left (fun s x -> StrSet.add x s) StrSet.empty - - -let armc_true = "1=1" -let armc_false = "0=1" -(* -let armc_true = "true" -let armc_false = "false" -*) -let loop_pc = "loop" -let start_pc = "start" -let error_pc = "error" -let val_vname = "AA_0" -let card_vname = "CARD" -let exists_kv = "EX" -let primed_suffix = "p" -let str__cil_tmp = "__cil_tmp" - -type kv_scope = { - kvs : string list; - kv_scope : string list StrMap.t; - sol : Ast.pred list Sy.SMap.t; -} - -type horn_clause = { - body_pred : Ast.pred; - body_kvars : (Su.t * Sy.t) list; - head_pred : Ast.pred; - head_kvar_opt : (Su.t * Sy.t) option; - tag : string; -} - -let sanitize_symbol s = - Str.global_replace (Str.regexp "@") "_at_" s |> Str.global_replace (Str.regexp "#") "_hash_" |> - Str.global_replace (Str.regexp "\\.") "_dot_" |> Str.global_replace (Str.regexp "'") "_q_" - -let symbol_to_armc s = Sy.to_string s |> sanitize_symbol - -let mk_data_var ?(suffix = "") kv v = - Printf.sprintf "_%s_%s%s%s" - (sanitize_symbol v) (sanitize_symbol kv) (if suffix = "" then "" else "_") suffix - -let mk_data ?(suffix = "") ?(skip_kvs = []) s = - Printf.sprintf "[%s]" - (List.map - (fun kv -> - try - StrMap.find kv s.kv_scope |> - List.map (mk_data_var ~suffix:(if List.mem kv skip_kvs then "" else suffix) kv) - with Not_found -> failure "ERROR: rel_state_vs: scope not found for %s" kv - ) s.kvs |> List.flatten |> String.concat ", ") - -let constant_to_armc = Ast.Constant.to_string -let bop_to_armc = function - | Ast.Plus -> "+" - | Ast.Minus -> "-" - | Ast.Times -> "*" - | Ast.Div -> "/" -let brel_to_armc = function - | Ast.Eq -> "=" - | Ast.Ne -> "=\\=" - | Ast.Gt -> ">" - | Ast.Ge -> ">=" - | Ast.Lt -> "<" - | Ast.Le -> "=<" -let bind_to_armc (s, t) = (* Andrey: TODO support binders *) - Printf.sprintf "%s:%s" (symbol_to_armc s) (Ast.Sort.to_string t |> sanitize_symbol) -let rec expr_to_armc expr = - let e = E.unwrap expr in - match e with - | Ast.Con c -> constant_to_armc c - | Ast.Var s -> mk_data_var exists_kv (symbol_to_armc s) - | Ast.App (s, es) -> - if !Co.purify_function_application then "_" else - let str = symbol_to_armc s in - if es = [] then str else - Printf.sprintf "f_%s(%s)" str (List.map expr_to_armc es |> String.concat ", ") - | Ast.Bin (e1, op, e2) -> - Printf.sprintf "(%s %s %s)" - (expr_to_armc e1) (bop_to_armc op) (expr_to_armc e2) - | Ast.Ite (ip, te, ee) -> - Printf.sprintf "ite(%s, %s, %s)" - (pred_to_armc ip) (expr_to_armc te) (expr_to_armc ee) - | Ast.Fld (s, e) -> - Printf.sprintf "fld(%s, %s)" (expr_to_armc e) (symbol_to_armc s) - | _ -> failwith (Printf.sprintf "expr_to_armc: %s" (E.to_string expr)) -and pred_to_armc pred = - let p = P.unwrap pred in - match p with - | Ast.True -> armc_true - | Ast.False -> armc_false - | Ast.Bexp e -> Printf.sprintf "%s = 1" (expr_to_armc e) - | Ast.Not (Ast.True, _) -> armc_false - | Ast.Not (Ast.False, _) -> armc_true - | Ast.Not p -> Printf.sprintf "neg(%s)" (pred_to_armc p) - | Ast.Imp (p1, p2) -> Printf.sprintf "imp(%s, %s)" (pred_to_armc p1) (pred_to_armc p2) - | Ast.And [] -> armc_true - | Ast.And [p] -> pred_to_armc p - | Ast.And (_::_ as ps) -> - Printf.sprintf "(%s)" (List.map pred_to_armc ps |> String.concat ", ") - | Ast.Or [] -> armc_false - | Ast.Or [p] -> pred_to_armc p - | Ast.Or (_::_ as ps) -> Printf.sprintf "(%s)" (List.map pred_to_armc ps |> String.concat "; ") - | Ast.Atom (e1, Ast.Eq, (Ast.Ite(ip, te, ee), _)) -> - let ip_str = pred_to_armc ip in - let e1_str = expr_to_armc e1 in - Printf.sprintf "((%s, %s = %s); (neg(%s), %s = %s))" - ip_str e1_str (expr_to_armc te) - ip_str e1_str (expr_to_armc ee) - | Ast.Atom (e1, r, e2) -> - Printf.sprintf "%s %s %s" - (expr_to_armc e1) (brel_to_armc r) (expr_to_armc e2) - | Ast.Forall (qs,p) -> (* Andrey: TODO support forall *) - Printf.sprintf "forall([%s], %s)" - (List.map bind_to_armc qs |> String.concat ", ") - (pred_to_armc p) - -let preds_kvars_of_reft reft = - List.fold_left - (fun (ps, ks) r -> - match r with - | C.Conc p -> p :: ps, ks - | C.Kvar (subs, kvar) -> ps, (subs, kvar) :: ks - ) ([], []) (C.ras_of_reft reft) - -let preds_to_pred ps = - match ps with - | [] -> Ast.pTrue - | [p] -> p - | _ :: _ -> Ast.pAnd ps - -let rec flatten_pAnd pred = - match P.unwrap pred with - | Ast.And [] -> [] - | Ast.And [p] -> flatten_pAnd p - | Ast.And ps -> List.map flatten_pAnd ps |> List.flatten - | _ -> [pred] - -let t_to_horn_clause t = - let lhs_ps, lhs_ks = C.lhs_of_t t |> preds_kvars_of_reft in - let body_ps, body_ks = - Sy.SMap.fold - (fun bv reft (ps, ks) -> - let ps', ks' = preds_kvars_of_reft (C.theta (Su.of_list [(C.vv_of_reft reft, Ast.eVar bv)]) reft) in - List.rev_append ps' ps, List.rev_append ks' ks - ) (C.env_of_t t) (C.grd_of_t t :: lhs_ps, lhs_ks) in - let head_ps, head_ks = C.rhs_of_t t |> preds_kvars_of_reft in - let head_kvar_opt = - match head_ks with - | [] -> None - | [head_kvar] -> Some head_kvar - | _ -> - failwith (Printf.sprintf "t_to_horn_clause: multiple k's in rhs of %d" (C.id_of_t t)); - in - { - body_pred = Ast.pAnd body_ps |> flatten_pAnd |> preds_to_pred; - body_kvars = body_ks; - head_pred = Ast.pAnd head_ps |> flatten_pAnd |> preds_to_pred; - head_kvar_opt = head_kvar_opt; - tag = C.id_of_t t |> string_of_int; - } - -let horn_clause_to_string hc = - Printf.sprintf "%s: %s, %s :- %s, %s." - hc.tag - (P.to_string hc.head_pred) - (match hc.head_kvar_opt with - | Some (subs, kvar) -> C.refa_to_string (C.Kvar (subs, kvar)) - | None -> "none" - ) - (P.to_string hc.body_pred) - (List.map (fun (subs, kvar) -> C.refa_to_string (C.Kvar (subs, kvar))) hc.body_kvars |> String.concat ", ") - - -module CFGNodeSet = Set.Make (struct type t = StrSet.t let compare = StrSet.compare end) - - -module DepV = struct - type t = string - let compare = Pervasives.compare - let hash = Hashtbl.hash - let equal = (=) -end -module DepE = struct - type t = string - let compare = Pervasives.compare - let default = "" -end -module DepG = Graph.Persistent.Digraph.ConcreteLabeled(DepV)(DepE) - -module Display = struct - include DepG - let vertex_name v = DepG.V.label v - let graph_attributes _ = [] - let default_vertex_attributes _ = [] - let vertex_attributes _ = [] - let default_edge_attributes _ = [] - let edge_attributes _ = [] - let get_subgraph _ = None -end -module DepGToDot = Graph.Graphviz.Dot(Display) -module DepGOper = Graph.Oper.P(DepG) - -module DepGSCC = Graph.Components.Make(DepG) - -module G = Graph.Pack.Digraph - -let hc_to_dep hc = - (match hc.head_kvar_opt with - | Some (_, sym) -> Some (symbol_to_armc sym) - | None -> None - ), - List.map (fun (_, sym) -> symbol_to_armc sym) hc.body_kvars |> List.sort compare - -(* -let mk_cfg state hcs = - let nodes = ref (CFGNodeSet.singleton StrSet.empty) in - let nodes_size = ref 0 in - let nodes_size' = ref 1 in - while !nodes_size < !nodes_size' do - nodes_size := CFGNodeSet.cardinal !nodes; - List.iter (fun hc -> - let heads, body = hc_to_dep hc in - let body_set = List.fold_left (fun sofar b -> StrSet.add b sofar) StrSet.empty body in - List.iter (fun node -> - List.iter (fun head -> - if StrSet.subset body_set node then - nodes := CFGNodeSet.add (StrSet.add head node) !nodes - ) heads - ) (CFGNodeSet.elements !nodes) - ) hcs; - nodes_size' := CFGNodeSet.cardinal !nodes - done; - Printf.printf "nodes: %s\n" (List.sort compare state.kvs |> String.concat ", "); - CFGNodeSet.iter (fun node -> - Printf.printf "node: %s\n" (StrSet.elements node |> List.sort compare |> String.concat ", ") - ) !nodes; - let g = G.create () in - List.iter (fun hc -> - let heads, body = hc_to_dep hc in - List.iter (fun b -> - List.iter (fun head -> - G.add_edge g (G.V.create 1) (G.V.create 2) - ) heads - ) body - ) hcs; - let depg = - List.fold_left - (fun g hc -> - let heads, body = hc_to_dep hc in - List.fold_left - (fun g' b -> - List.fold_left - (fun g'' head -> - DepG.add_edge_e g'' (DepG.E.create b (* hc.tag *) "" head) - ) g' heads - ) g body - ) DepG.empty hcs in - let dep_cs = - List.fold_left - (fun g hc -> - let heads, _ = hc_to_dep hc in - List.fold_left - (fun g' hc' -> - (* check if heads intersect body' *) - let _, body' = hc_to_dep hc' in - if hc.tag <> hc'.tag && List.exists (fun head -> List.mem head body') heads then - DepG.add_edge g' hc.tag hc'.tag - else - g' - ) g hcs - ) DepG.empty hcs in - let out = open_out "/var/tmp/awesome/g.dot" in - DepGToDot.output_graph out depg; - close_out out; - let out = open_out "/var/tmp/awesome/t.dot" in - DepGToDot.output_graph out (DepGOper.transitive_closure depg); - close_out out; - let out = open_out "/var/tmp/awesome/cs.dot" in - DepGToDot.output_graph out dep_cs; - close_out out -*) - - -let kvar_to_hc_armcs ?(suffix = "") state (subs, sym) = - let subs_map = List.fold_left (fun m (s, e) -> StrMap.add (symbol_to_armc s) e m) StrMap.empty (Su.to_list subs) in - let find_subst v default = try StrMap.find v subs_map |> expr_to_armc with Not_found -> default in - let kv = symbol_to_armc sym in - try - let scope = StrMap.find kv state.kv_scope in - Printf.sprintf "%s(%s)" - kv (List.map (mk_data_var ~suffix:suffix kv) scope |> String.concat ", ") - :: List.map (fun v -> - Printf.sprintf "%s = %s" - (mk_data_var ~suffix:suffix kv v) (find_subst v (mk_data_var exists_kv v)) - ) scope - with Not_found -> [armc_true] (* input variable *) - -let kvar_to_armcs ?(suffix = "") ?(with_card=true) state (subs, sym) = - let subs_map = - List.fold_left (fun m (s, e) -> StrMap.add (symbol_to_armc s) (expr_to_armc e) m) StrMap.empty (Su.to_list subs) in - let find_subst v default = try StrMap.find v subs_map with Not_found -> default in - let kv = symbol_to_armc sym in - try - let scope = StrMap.find kv state.kv_scope in - let card_armc, data = - if with_card then - [Printf.sprintf "%s = 1" (mk_data_var ~suffix:suffix kv card_vname)], List.tl scope - else - [], scope - in - card_armc - @ List.map (fun v -> - Printf.sprintf "%s = %s" - (mk_data_var ~suffix:suffix kv v) (find_subst v (mk_data_var exists_kv v)) - ) data |> String.concat ", " - with Not_found -> armc_true (* input variable *) - -let hc_to_rule state hc = - let mk_rule head body tag = Printf.sprintf "rule(%s, %s, [%s])." tag head body in - let body = - pred_to_armc hc.body_pred :: (List.map (kvar_to_hc_armcs state) hc.body_kvars |> List.flatten) |> - String.concat ", " in - let prules = - if P.is_tauto hc.head_pred then [] - else [mk_rule error_pc (Printf.sprintf "%s, %s" body (Ast.pNot hc.head_pred |> pred_to_armc)) hc.tag] in - let krules = - match hc.head_kvar_opt with - | Some kvar -> - let head_armcs = kvar_to_hc_armcs ~suffix:primed_suffix state kvar in - [mk_rule - (List.hd head_armcs) (* kv *) - (body :: (List.tl head_armcs (* subs *)) |> String.concat ", ") - hc.tag] - | None -> [] - in - krules @ prules - -let mk_rule from_pc from_data to_pc to_data guard update tag = - Printf.sprintf "r(p(pc(%s), data(%s)),\np(pc(%s), data(%s)),\n[%s],\n[%s], %s).%s" - from_pc from_data to_pc to_data guard update tag - (if guard = "" && update = "" then Printf.sprintf "\nid_trans(%s)." tag else "") - -let hc_to_armc ?(cfg=false) ?(with_card=true) ?(with_dataflow=false) state hc = - let from_data = mk_data state in - let to_data = mk_data ~suffix:primed_suffix state in - let body = pred_to_armc hc.body_pred :: List.map (kvar_to_armcs ~with_card:with_card state) hc.body_kvars in - let body_kv_strs = hc_to_dep hc |> snd |> List.filter (fun kv -> StrMap.mem kv state.kv_scope) in - let prules = - if P.is_tauto hc.head_pred then [] - else - mk_rule - (if cfg then Printf.sprintf "src_%s" hc.tag else loop_pc) - from_data error_pc to_data - ((Ast.pNot hc.head_pred |> pred_to_armc) :: body |> String.concat ",\n") "" hc.tag - :: - if with_dataflow then - [Printf.sprintf "dataflow_transition(%s, [%s], [])." hc.tag (String.concat ", " body_kv_strs)] - else [] in - let krules = - match hc.head_kvar_opt with - | Some ((subs, sym) as kvar) -> - let kv = symbol_to_armc sym in - let skip_kvs = List.filter (fun kv' -> kv <> kv') state.kvs in - mk_rule - (if cfg then Printf.sprintf "src_%s" hc.tag else loop_pc) - from_data - (if cfg then Printf.sprintf "dst_%s" hc.tag else loop_pc) - (mk_data ~suffix:primed_suffix ~skip_kvs:skip_kvs state) - (body |> String.concat ",\n") - (kvar_to_armcs ~with_card:with_card ~suffix:primed_suffix state kvar) - hc.tag - :: - if with_dataflow then - [Printf.sprintf "dataflow_transition(%s, [%s], [%s])." hc.tag (String.concat ", " body_kv_strs) kv] - else [] - | None -> [] - in - krules @ prules - -let mk_hc_var2names state = - List.map - (fun kv -> - Printf.sprintf "var2names(p(pc(%s), data(%s)), [%s])." - kv - (List.map (mk_data_var kv) (StrMap.find kv state.kv_scope) |> String.concat ", ") - (List.map - (fun v -> - Printf.sprintf "(%s, \'%s_%s\')" (mk_data_var kv v) v kv - ) (StrMap.find kv state.kv_scope) |> String.concat ", ") - ) state.kvs |> String.concat "\n" - -let mk_var2names state = - Printf.sprintf "var2names(p(pc(_), data(%s)), [%s])." - (mk_data state) - (List.map - (fun kv -> - List.map - (fun v -> - Printf.sprintf "(%s, \'%s_%s\')" (mk_data_var kv v) v kv - ) (StrMap.find kv state.kv_scope) |> String.concat ", " - ) state.kvs |> String.concat ", ") - -let mk_hc_preds state = - List.map - (fun kv -> - Printf.sprintf "preds(p(pc(%s), data(%s)), [])." - kv - (List.map (mk_data_var kv) (StrMap.find kv state.kv_scope) |> String.concat ", ") - ) state.kvs |> String.concat "\n" - -let mk_preds ?(with_card = true) state = - let preds = - if with_card then - List.map (fun kv -> - let card = StrMap.find kv state.kv_scope |> List.hd in - let kv_card = mk_data_var kv card in - Printf.sprintf "%s = 0, %s = 1" kv_card kv_card - ) state.kvs |> String.concat ", " - else - "" - in - Printf.sprintf "preds(p(pc(_), data(%s)), [%s])." (mk_data state) preds - -let mk_start_rule state = - mk_rule start_pc (mk_data state) loop_pc (mk_data ~suffix:primed_suffix state) "" - (List.map (fun kv -> - let card = StrMap.find kv state.kv_scope |> List.hd in - Printf.sprintf "%s = 0" (mk_data_var ~suffix:primed_suffix kv card) - ) state.kvs |> String.concat ", ") - "start_t" - -let find_kv_wf_scope wfs kv = - let wf = - try List.find (fun wf -> - match C.reft_of_wf wf |> C.kvars_of_reft with - | [(subs, kvar)] -> Su.is_empty subs && kv = symbol_to_armc kvar - | _ -> false - ) wfs - with Not_found -> failwith (Printf.sprintf "find_wf_scope: %s" kv) - in - Sy.SMap.fold (fun kvar _ sofar -> StrSet.add (symbol_to_armc kvar) sofar) (C.env_of_wf wf) StrSet.empty - -(* map each k variable to variables in its scope *) -(* k variables no appearing in any rhs don't have any scope *) -let mk_kv_scope ?(with_card=true) ?(hcs=[]) out ts wfs sol = - (* - List.iter (fun wf -> - let env = C.env_of_wf wf in - let bvs = Sy.SMap.fold (fun bv _ sofar -> symbol_to_armc bv :: sofar) env [] in - Printf.printf "wf: %s : %s\n" (C.reft_of_wf wf |> C.reft_to_string) (String.concat ", " bvs) - ) wfs; - *) - let hcs = if hcs = [] then List.map t_to_horn_clause ts else hcs in - let hc_deps = List.map hc_to_dep hcs in - let kv_scope_aux = - ref (List.fold_left (fun kv_scope' t -> - (* collect bound vars of t *) - let scope = - Sy.SMap.fold (fun bv _ scope' -> - StrSet.add (symbol_to_armc bv) scope' - ) (C.env_of_t t) StrSet.empty in - let _, rhs_kvs = C.rhs_of_t t |> C.preds_kvars_of_reft in - (* add these bound vars to the scope of each k var in rhs of t *) - List.fold_left (fun kv_scope'' kv -> - StrMap.add kv (StrSet.union - (try StrMap.find kv kv_scope'' with Not_found -> StrSet.empty) - scope) kv_scope'' - ) kv_scope' (List.map snd rhs_kvs |> List.map symbol_to_armc) - ) StrMap.empty ts) in - let done_flag = ref false in - (* if k' depends on k then scope(k') contains scope(k) *) - while not(!done_flag) do - done_flag := true; - List.iter (fun (head_opt, body) -> - match head_opt with - | Some kv' -> - let scope_kv' = StrMap.find kv' !kv_scope_aux in - let size_scope_kv' = StrSet.cardinal scope_kv' in - let upd_scope_kv' = - List.fold_left (fun sofar kv -> - StrSet.union (try StrMap.find kv !kv_scope_aux with Not_found -> StrSet.empty) sofar - ) scope_kv' body - in - if size_scope_kv' < StrSet.cardinal upd_scope_kv' then - begin - kv_scope_aux := StrMap.add kv' upd_scope_kv' !kv_scope_aux; - done_flag := false - end - | None -> () - ) hc_deps - done; - let kv_scope = - (* sort scope, add value variable and, if needed, cardinality variable *) - StrMap.mapi (fun kv scope -> - let scope' = val_vname :: (StrSet.inter scope (find_kv_wf_scope wfs kv) |> StrSet.elements |> List.sort compare) in - if with_card then card_vname :: scope' else scope' - ) !kv_scope_aux in - let kvs = StrMap.fold (fun kv _ kvs -> kv :: kvs) kv_scope [] in - StrMap.iter (fun kv scope -> - Printf.fprintf out "%% %s -> %s\n" kv (String.concat ", " scope)) kv_scope; - {kvs = kvs; kv_scope = kv_scope; sol = sol} - - -let to_horn out ts wfs sol = - print_endline "Translating to Horn clauses."; -(* let cex = [1;2;4;5;9;23;24] in *) - let cex = [] in - let ts = if cex = [] then ts else List.filter (fun t -> List.mem (C.id_of_t t) cex) ts in - let state = mk_kv_scope out ~with_card:false ts wfs sol in - Printf.fprintf out - ":- multifile rule/3, var2names/2, preds/2, error/1. - -error(%s). -%s -%s -" - error_pc - (mk_hc_var2names state) - (mk_hc_preds state); - List.iter (fun t -> - Printf.fprintf out "/*\n%s\n%s\n*/\n" (C.to_string t) (t_to_horn_clause t |> horn_clause_to_string); - List.iter (fun r -> - output_string out r; - output_string out "\n\n" - ) (t_to_horn_clause t |> hc_to_rule state) - ) ts - -let to_armc out ts wfs sol = - print_endline "Translating to ARMC. ToHC.to_armc"; -(* let cex = [1;5;13;14;68;69;54] in *) - let cex = [] in - let state = mk_kv_scope out ts wfs sol in - Printf.fprintf out - ":- multifile r/5,implicit_updates/0,var2names/2,preds/2,trans_preds/3,cube_size/1,start/1,error/1,refinement/1,cutpoint/1,invgen_template/2,invgen_template/1,cfg_exit_relation/1,stmtsrc/2,strengthening/2. -refinement(inter). -cube_size(1). - -start(pc(%s)). -error(pc(%s)). -cutpoint(pc(%s)). -\n%s\n\n%s\n -" - start_pc error_pc loop_pc - (mk_var2names state) - (mk_preds state); - Printf.fprintf out "%s\n\n" (mk_start_rule state); - List.iter (fun t -> - if List.mem (C.id_of_t t) cex || List.length cex = 0 then - let hc = t_to_horn_clause t in - Printf.fprintf out "/*\n%s%s\n*/\n" (C.to_string t) (horn_clause_to_string hc); - List.iter (fun r -> - output_string out r; - output_string out "\n\n" - ) (hc_to_armc state hc) - else - () - ) ts; - List.iter (fun id -> - List.iter (fun t -> - if List.mem (C.id_of_t t) cex then - Printf.printf "%s\n" (C.to_string t) - ) ts - ) cex - - -let to_dataflow_armc out ts wfs sol = - print_endline "Translating to ARMC. ToHC.to_dataflow_armc "; - let with_card_flag = false in -(* let cex = [1;2;4;5;9;23;24] in *) - let cex = [] in - let ts = (if cex = [] then ts else List.filter (fun t -> List.mem (C.id_of_t t) cex) ts) in - let hcs = List.map t_to_horn_clause ts in - let state = mk_kv_scope ~with_card:with_card_flag ~hcs:hcs out ts wfs sol in - Printf.fprintf out - ":- multifile r/5,implicit_updates/0,var2names/2,preds/2,trans_preds/3,cube_size/1,start/1,error/1,refinement/1,cutpoint/1,invgen_template/2,invgen_template/1,cfg_exit_relation/1,stmtsrc/2,strengthening/2,id_trans/1,dataflow_transition/3. -refinement(inter). -cube_size(1). - -start(pc(%s)). -error(pc(%s)). - -\n%s\n\n%s\n -" - start_pc error_pc - (mk_var2names state) - (mk_preds ~with_card:with_card_flag state); - (* connect the start with the loop *) - Printf.fprintf out "%s\n\n" (mk_rule start_pc (mk_data state) loop_pc (mk_data state) "" "" "start"); - Printf.fprintf out "dataflow_transition(%s, [], []).\n\n" "start"; - List.iter - (fun hc -> - Printf.fprintf out "/*\n%s\n*/\n" (horn_clause_to_string hc); - (* the actual transition relation, each disjunct *) - List.iter (Printf.fprintf out "%s\n\n") (hc_to_armc ~cfg:false ~with_card:with_card_flag ~with_dataflow:true state hc) - ) hcs; - output_string out "/*\n"; - List.iter (fun t -> Printf.fprintf out "%s\n" (C.to_string t)) ts; - List.iter (fun hc -> Printf.fprintf out "%s\n\n" (horn_clause_to_string hc)) hcs; - output_string out "*/\n" diff --git a/external/fixpoint/toImp.ml b/external/fixpoint/toImp.ml deleted file mode 100644 --- a/external/fixpoint/toImp.ml +++ /dev/null @@ -1,380 +0,0 @@ -(* - * Copyright © 2009 The Regents of the University of California. All rights reserved. - * - * Permission is hereby granted, without written agreement and without - * license or royalty fees, to use, copy, modify, and distribute this - * software and its documentation for any purpose, provided that the - * above copyright notice and the following two paragraphs appear in - * all copies of this software. - * - * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY - * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES - * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN - * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY - * OF SUCH DAMAGE. - * - * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, - * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY - * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS - * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION - * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONAst.Symbol. - * - *) - -(* This module implements the IMP language and translation from fixpoint constraints *) - - -module F = Format -module H = Hashtbl -module A = Ast -module E = A.Expression -module P = A.Predicate -module Sy = A.Symbol -module SM = Sy.SMap -module C = FixConstraint -module Cg = FixConfig -(*module BS = BNstats*) - -module Misc = FixMisc open Misc.Ops - -(**********************************************************************) -(************* Datatypes for IMP Representation ***********************) -(**********************************************************************) - -(* vars are always in lex order *) -(* We can have at most one set of temporaries in scope at a time - * so we share names and mark temporaries *) - -type var = PVar of Sy.t - | TVar of Sy.t - -type kvar = Ast.Subst.t * Sy.t - -type decl = RDecl of Sy.t * Sy.t list - | PDecl of Sy.t - -(* IMP commands *) - -type tupl = var list - -type instr = Assm of A.pred list - | Asst of A.pred list - | Asgn of var * var - | Rget of Sy.t * tupl - | Rset of tupl * Sy.t - | Havc of var - -type block = instr list - -type program = decl list * block list - -(**********************************************************************) -(************* Datatypes for IMP Representation ***********************) -(**********************************************************************) - -(* Convenience *) - -let mk_temp = function - | TVar v -> TVar v - | PVar v -> TVar v - -let rv_append v1 = function - | TVar v2 | PVar v2 -> - PVar (Sy.of_string (Sy.to_string v1 ^ "_" ^ Sy.to_string v2)) - -let collect_apps_from_pred p = - let apps = ref [] in - let f_exp e = - match E.unwrap e with - | A.App (s, es) -> apps := (s, List.length es) :: !apps - | t -> () in - P.iter (fun _ -> ()) f_exp p; !apps - -let collect_apps_from_instr = function - | Assm ps - | Asst ps -> - Misc.flap collect_apps_from_pred ps - | _ -> [] - -let collect_apps_from_block block = - Misc.flap collect_apps_from_instr block - -let collect_apps_from_program (_, blocks) = - Misc.flap collect_apps_from_block blocks - -(*************************************************************************) -(************* Rendering IMP to String ***********************************) -(*************************************************************************) - -let print_var ppf = function - | PVar v -> F.fprintf ppf "%a" Sy.print v - | TVar v -> F.fprintf ppf "'%a" Sy.print v - -let print_tuple ppf = - F.fprintf ppf "(%a)" (Misc.pprint_many false ", " print_var) - -let print_instr ppf = function - | Assm ps -> - F.fprintf ppf "@[assume %a;@]" P.print (A.pAnd ps) - | Asst ps -> - F.fprintf ppf "@[assert %a;@]" P.print (A.pAnd ps) - | Asgn (lhs, rhs) -> - F.fprintf ppf "@[%a@ :=@ %a;@]" print_var lhs print_var rhs - | Rget (rv, tupl) -> - F.fprintf ppf "@[%a@ <|@ %a;@]" print_tuple tupl Sy.print rv - | Rset (tupl, rv) -> - F.fprintf ppf "@[%a@ |>@ %a;@]" print_tuple tupl Sy.print rv - | Havc v -> - F.fprintf ppf "@[havoc@ %a;@]" print_var v - -let print_decl ppf = function - | RDecl (r, vs) -> - F.fprintf ppf "@[rel@ (%a)@ (%a);@]" Sy.print r - (Misc.pprint_many false ", " Sy.print) vs - | PDecl v -> - F.fprintf ppf "@[var@ %a;@]" Sy.print v - -let print_block ppf block = - F.fprintf ppf "@[%a@]" - (Misc.pprint_many false "\n" print_instr) block - -let print_program ppf (decls, blocks) = - F.fprintf ppf "@[%a@.%a@]" - (Misc.pprint_many false "\n" print_decl) decls - (Misc.pprint_many false "\n" print_block) blocks - -(* Printing as C syntax *) - -let print_brel_as_c ppf = function - | A.Eq -> F.fprintf ppf "==" - | A.Ne -> F.fprintf ppf "!=" - | A.Gt -> F.fprintf ppf ">" - | A.Ge -> F.fprintf ppf ">=" - | A.Lt -> F.fprintf ppf "<" - | A.Le -> F.fprintf ppf "<=" - -let print_bop_as_c ppf = function - | A.Plus -> F.fprintf ppf "+" - | A.Minus -> F.fprintf ppf "-" - | A.Times -> F.fprintf ppf "*" - | A.Div -> F.fprintf ppf "/" - -let rec print_predicate_as_c ppf pred = - match P.unwrap pred with - | A.True -> - F.fprintf ppf "True" - | A.False -> - F.fprintf ppf "False" - | A.Atom (e1, r, e2) -> - F.fprintf ppf "(%a %a %a)" print_expr_as_c e1 print_brel_as_c r print_expr_as_c e2 - | A.And ps -> - Misc.pprint_many false " && " P.print ppf ps - | A.Or ps -> - Misc.pprint_many false " || " P.print ppf ps - | A.Not p -> - F.fprintf ppf "!(%a)" print_predicate_as_c p - | A.Imp (p1, p2) -> - print_predicate_as_c ppf (A.pOr [A.pNot p1; p2]) - | A.Iff (p1, p2) -> - print_predicate_as_c ppf (A.pAnd [A.pImp (p1, p2); A.pImp (p2, p1)]) - | A.Bexp e -> - print_expr_as_c ppf e - | A.Forall (ds, p) -> - assert false - -and print_expr_as_c ppf expr = - match E.unwrap expr with - | A.Con c -> - F.fprintf ppf "%a" A.Constant.print c - | A.Var v -> - F.fprintf ppf "%a" Sy.print v - | A.App (f, es) -> - F.fprintf ppf "%a(%a)" Sy.print f - (Misc.pprint_many false ", " print_expr_as_c) es - | A.Bin (e1, op, e2) -> - F.fprintf ppf "(%a %a %a)" - print_expr_as_c e1 - print_bop_as_c op - print_expr_as_c e2 - | A.Ite (p, e1, e2) -> - F.fprintf ppf "(%a ? %a : %a)" - print_predicate_as_c p - print_expr_as_c e1 - print_expr_as_c e2 - | A.Fld (s, e) -> - print_expr_as_c ppf (A.eApp (Sy.of_string ("field" ^ Sy.to_string s), [e])) -(* | A.Mod (e1, i) -> - F.fprintf ppf "(%a mod %d)" print_expr_as_c e1 i -*) - -let print_var_as_c ppf = function - | PVar v -> F.fprintf ppf "%a" Sy.print v - | TVar v -> F.fprintf ppf "_%a" Sy.print v - -let sy_append v1 v2 = - Sy.of_string ((Sy.to_string v1) ^ "_" ^ (Sy.to_string v2)) - -let print_decl_as_c ppf = function - | RDecl (rv, tupl) -> - let pv v1 = (fun v2 -> F.fprintf ppf "@[int %a;@]@\n" Sy.print (sy_append v1 v2)) in - List.iter (pv rv) tupl - | PDecl v -> - F.fprintf ppf "@[int %a;@]@\n" Sy.print v - -let rec print_instr_as_c ppf = function - | Havc v -> - F.fprintf ppf "@[%a = nondet();@]" print_var_as_c v - | Asgn (v1, v2) -> - F.fprintf ppf "@[%a = %a@]" print_var_as_c v1 print_var_as_c v2 - | Assm ps -> - F.fprintf ppf "@[if (!(%a)) { diverge(); }@]" print_predicate_as_c (A.pAnd ps) - | Asst ps -> - F.fprintf ppf "@[if (!(%a)) { error(); }@]" print_predicate_as_c (A.pAnd ps) - | Rget (rv, tupl) -> - List.map (fun v -> Asgn (mk_temp v, rv_append rv v)) tupl |> - print_block_as_c ppf - | Rset (tupl, rv) -> - List.map (fun v -> Asgn (rv_append rv v, mk_temp v)) tupl |> - print_block_as_c ppf - -and print_block_as_c ppf block = - F.fprintf ppf "@[%a@]" - (Misc.pprint_many false "\n" print_instr_as_c) block - -let print_list ppf = List.iter (F.fprintf ppf "%s") - -let generate_uf (name, numargs) = - let rec mkargs n s = - if numargs > 0 then - mkargs (n-1) ("int, " ^ s) - else - s in - "int " ^ (Sy.to_string name) ^ "(" ^ (mkargs (numargs-1) "int") ^ ") {}" - -let prologue = - [ "void error() { ERROR: goto ERROR; }" - ; "void diverge() { DIV: goto DIV; }" - ; "int nondet() { int x; return x; }" - ; "int main() {" - ] - -let epilogue = - ["return 0; }"] - -let print_program_as_c ppf ((decls, blocks) as program) = - F.fprintf ppf "@[%a@.%a@.%a@.%a@.%a@.@]" - print_list (collect_apps_from_program program |> List.map generate_uf) - print_list prologue - (Misc.pprint_many false "\n" print_decl_as_c) decls - (Misc.pprint_many false "\n" print_block_as_c) blocks - print_list epilogue - -let check_imp (decls, instrs) = true -(* Translation from fixpoint to IMP *) - -(*************************************************************************) -(************* Converting FixConfig.deft to SMTLIB ***********************) -(*************************************************************************) - -(* Declarations *) - -let filter_wfs cs = - (* Misc.maybe_list (List.map (function Cg.Wfc x -> Some x | _ -> None) cs) *) - Misc.map_partial (function Cg.Wfc x -> Some x | _ -> None) cs - -let filter_subt cs = - Misc.map_partial (function Cg.Cst x -> Some x | _ -> None) cs - (* Misc.maybe_list (List.map (function Cg.Cst x -> Some x | _ -> None) cs) - *) - -let wf_to_decls wf = - let vars = wf |> C.env_of_wf - |> C.bindings_of_env - |> List.map fst - |> Misc.sort_and_compact - in - let kvars = C.kvars_of_reft (C.reft_of_wf wf) in - ( List.map (fun k -> RDecl (snd k, vars)) kvars - , List.map (fun v -> PDecl v) vars) - -let constraints_to_decls cs = - let decls = List.map wf_to_decls (filter_wfs cs) in - let (rdecls, pdecls) = (Misc.flap fst decls, Misc.flap snd decls) in - rdecls @ pdecls - -(* Constraint translation *) - -let rec get_kdecl kvar decls = - match decls with - | RDecl (k, vars) :: decls -> - if k = kvar then - vars - else - get_kdecl kvar decls - | _ :: decls -> get_kdecl kvar decls - | [] -> raise Not_found - -let sub_to_assume (var, expr) = - Assm [A.pAtom (A.eVar var, A.Eq, expr)] - -(* [[{t | p}]]_get *) - -let get_instrs vv decls (subs, kvar) = - let vars = get_kdecl kvar decls |> List.map (fun v -> TVar v) in - let assumes = subs |> Ast.Subst.to_list |> List.map sub_to_assume in - Rget (kvar, vars) :: assumes @ - [Asgn (PVar vv, List.hd vars)] - -let set_instr decls (subs, kvar) = - Rset (List.map (fun v -> TVar v) (get_kdecl kvar decls), kvar) - -let emptySol () = PredAbs.read (PredAbs.empty ()) - -let reft_to_get_instrs decls reft = - let vv = C.vv_of_reft reft in - let kvars = C.kvars_of_reft reft in - let sol0 = emptySol () in - let preds = C.preds_of_reft sol0 reft in - match (kvars, preds) with - | ([], preds) -> Havc (PVar vv) :: Assm preds :: [] - | (kvars, []) -> Misc.flap (get_instrs vv decls) kvars - | (kvars, preds) -> Misc.flap (get_instrs vv decls) kvars @ ([Assm preds]) - -(* [[{t | p}]]_set *) - -let reft_to_set_instrs decls reft = - let sol0 = emptySol () in - let kvars = C.kvars_of_reft reft in - let preds = C.preds_of_reft sol0 reft in - match (kvars, preds) with - | ([], preds) -> Asst preds :: [] - | (kvars, []) -> List.map (set_instr decls) kvars - | (kvars, preds) -> List.map (set_instr decls) kvars @ [(Asst preds)] - -(* [[x:T; G]] *) - -let binding_to_instrs decls (var, reft) = - reft_to_get_instrs decls reft @ [Asgn (PVar var, PVar (C.vv_of_reft reft))] - -let envt_to_instrs decls envt = - Misc.flap (binding_to_instrs decls) (C.bindings_of_env envt) - -let constraint_to_block decls c = - let (env, grd, lhs, rhs) = - (C.env_of_t c, C.grd_of_t c, C.lhs_of_t c, C.rhs_of_t c) in - Assm [grd] :: - envt_to_instrs decls env @ - reft_to_get_instrs decls lhs @ - reft_to_set_instrs decls rhs - -let constraints_to_blocks decls cs = - List.map (constraint_to_block decls) (filter_subt cs) - -let mk_program cs = - let decls = constraints_to_decls cs in - (decls, constraints_to_blocks decls cs) - -(* API *) -let render ppf cs = - cs |> mk_program - |> F.fprintf ppf "%a" print_program_as_c diff --git a/external/fixpoint/toImp.mli b/external/fixpoint/toImp.mli deleted file mode 100644 --- a/external/fixpoint/toImp.mli +++ /dev/null @@ -1,26 +0,0 @@ -(* - * Copyright © 2009 The Regents of the University of California. All rights reserved. - * - * Permission is hereby granted, without written agreement and without - * license or royalty fees, to use, copy, modify, and distribute this - * software and its documentation for any purpose, provided that the - * above copyright notice and the following two paragraphs appear in - * all copies of this software. - * - * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY - * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES - * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN - * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY - * OF SUCH DAMAGE. - * - * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, - * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY - * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS - * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION - * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONAst.Symbol. - * - *) - -val render : Format.formatter -> FixConfig.deft list -> unit - - diff --git a/external/fixpoint/toLatex.ml b/external/fixpoint/toLatex.ml deleted file mode 100644 --- a/external/fixpoint/toLatex.ml +++ /dev/null @@ -1,149 +0,0 @@ -(* translation of constraints to latex *) - -module C = FixConstraint -module Su = Ast.Subst -module Misc = FixMisc open Misc.Ops - -(* print linebreak after each connective in constraint *) -let c_linebreak = ref true - -let q_mathit = Printf.sprintf "\\mathit{%s}" - -let sort_to_latex s = Ast.Sort.to_string s |> q_mathit -let symbol_to_latex s = - Ast.Symbol.to_string s - |> Str.global_replace (Str.regexp "_") "\\_" - |> Str.global_replace (Str.regexp "#") "\\#" |> q_mathit -let constant_to_latex = Ast.Constant.to_string - -let bop_to_latex = function - | Ast.Plus -> "+" - | Ast.Minus -> "-" - | Ast.Times -> "" - | Ast.Div -> "/" -let brel_to_latex = function - | Ast.Eq -> "=" - | Ast.Ne -> "!=" - | Ast.Gt -> ">" - | Ast.Ge -> "\\geq" - | Ast.Lt -> "<" - | Ast.Le -> "\\leq" -let bind_to_latex (s, t) = - Printf.sprintf "%s:%s" (symbol_to_latex s) (sort_to_latex t) -let rec expr_to_latex (e, _) = - match e with - | Ast.Con c -> constant_to_latex c - | Ast.Var s -> symbol_to_latex s - | Ast.App (s, es) -> - Printf.sprintf "%s([%s])" - (symbol_to_latex s) (List.map expr_to_latex es |> String.concat " ") - | Ast.Bin (e1, op, e2) -> - Printf.sprintf "(%s %s %s)" - (expr_to_latex e1) (bop_to_latex op) (expr_to_latex e2) - | Ast.Ite (ip, te, ee) -> - Printf.sprintf "%s ? %s : %s" - (pred_to_latex ip) (expr_to_latex te) (expr_to_latex ee) - | Ast.Fld (s, e) -> - Printf.sprintf "%s.%s" (expr_to_latex e) (symbol_to_latex s) -and pred_to_latex (p, _) = - match p with - | Ast.True -> "\\ltrue" - | Ast.False -> "\\lfalse" - | Ast.Bexp e -> expr_to_latex e - | Ast.Not p -> Printf.sprintf "\\neg (%s)" (pred_to_latex p) - | Ast.Imp (p1, p2) -> - Printf.sprintf "(%s \\limp %s)" (pred_to_latex p1) (pred_to_latex p2) - | Ast.And ps -> - if ps = [] then "\\ltrue" else - List.map pred_to_latex ps |> String.concat " \\land " - | Ast.Or ps -> - if ps = [] then "\\lfalse" else - List.map pred_to_latex ps |> String.concat " \\lor " - | Ast.Atom (e1, r, e2) -> - Printf.sprintf "(%s %s %s)" - (expr_to_latex e1) (brel_to_latex r) (expr_to_latex e2) - | Ast.Forall (qs,p) -> - Printf.sprintf "\\forall %s: %s" - (List.map bind_to_latex qs |> String.concat ", ") (pred_to_latex p) -let subst_to_latex (s, e) = - Printf.sprintf "[%s/%s]" (expr_to_latex e) (symbol_to_latex s) -let refa_to_latex refa = - match refa with - | C.Conc pred -> pred_to_latex pred - | C.Kvar (subs, sym) -> - Printf.sprintf "%s%s" - (symbol_to_latex sym) - (List.map subst_to_latex (Su.to_list subs) |> String.concat "") -let reft_to_latex (v, b, r) = - Printf.sprintf "\\{ %s:%s \\mid %s \\}" - (symbol_to_latex v) (sort_to_latex b) - (if r = [] then "\\ltrue" else - (List.map refa_to_latex r |> String.concat " \\land ")) -let envt_to_latex envt = - if Ast.Symbol.SMap.is_empty envt then - "\\ltrue;\\ " - else - Ast.Symbol.SMap.fold - (fun sym reft sofar -> - Printf.sprintf "%s:%s;%s%s" - (symbol_to_latex sym) (reft_to_latex reft) - (if !c_linebreak then "\\\\\n" else "\\ ") - sofar) envt "" - -let c_to_latex out c = - Printf.fprintf out - "\\begin{footnotesize} - \\begin{verbatim} -%s - \\end{verbatim} -\\end{footnotesize} -" (C.to_string c); - Printf.fprintf out - "\\begin{displaymath} - \\begin{array}[t]{l} - %s %s\\ \\deriv\\\\ %s\\ <:\\\\ %s\\qquad %s - \\end{array} -\\end{displaymath} -\\hrule -" - (C.env_of_t c |> envt_to_latex) - (C.grd_of_t c |> pred_to_latex) - (C.lhs_of_t c |> reft_to_latex) - (C.rhs_of_t c |> reft_to_latex) - (try string_of_int (C.id_of_t c) with _ -> "") - -let wf_to_latex out wf = - Printf.fprintf out - "\\begin{displaymath} - \\begin{array}[t]{l} - %s\\ \\deriv\\ %s\\qquad %s - \\end{array} -\\end{displaymath} -\\hrule -" - (C.env_of_wf wf |> envt_to_latex) - (C.reft_of_wf wf |> reft_to_latex) - (try string_of_int (C.id_of_wf wf) with _ -> "") - - -let to_latex out cs ws = - print_endline "Translating to LaTeX."; - Printf.fprintf out -"\\documentclass[10pt]{llncs} -\\pagestyle{plain} -\\usepackage{amsmath} -\\newcommand{\\ltrue}{\\mathit{true}} -\\newcommand{\\lfalse}{\\mathit{false}} -\\newcommand{\\limp}{\\rightarrow} -\\newcommand{\\deriv}{\\vdash} -\\begin{document} -"; - List.iter (c_to_latex out) cs; - List.iter (wf_to_latex out) ws; - Printf.fprintf out -"\\end{document} -%%%%%% Local Variables: -%%%%%% mode: latex -%%%%%% TeX-master: t -%%%%%% End: -" diff --git a/external/fixpoint/toQARMC.ml b/external/fixpoint/toQARMC.ml deleted file mode 100644 --- a/external/fixpoint/toQARMC.ml +++ /dev/null @@ -1,721 +0,0 @@ -(* translation to Q'ARMC *) - - -module C = FixConstraint -module Co = Constants -module Sy = Ast.Symbol -module Su = Ast.Subst -module P = Ast.Predicate -module E = Ast.Expression -module StrMap = Map.Make (struct type t = string let compare = compare end) -module StrSet = Set.Make (struct type t = string let compare = compare end) -module Misc = FixMisc open Misc.Ops - -let strlist_to_strset = List.fold_left (fun s x -> StrSet.add x s) StrSet.empty - -(* Andrey: TODO move to ast.ml? *) -let pred_is_atomic (p, _) = - match p with - | Ast.True | Ast.False | Ast.Bexp _ | Ast.Atom _ -> true - | Ast.And _ | Ast.Or _ | Ast.Not _ | Ast.Imp _ | Ast.Forall _ -> false - -let pred_is_true (p, _) = - match p with - | Ast.True -> true - | Ast.Atom (e1, Ast.Eq, e2) -> E.to_string e1 = E.to_string e2 - | _ -> false - -let neg_brel = function - | Ast.Eq -> Ast.Ne - | Ast.Ne -> Ast.Eq - | Ast.Gt -> Ast.Le - | Ast.Ge -> Ast.Lt - | Ast.Lt -> Ast.Ge - | Ast.Le -> Ast.Gt - -let rec push_neg ?(neg=false) ((p, _) as pred) = - match p with - | Ast.True -> if neg then Ast.pFalse else pred - | Ast.False -> if neg then Ast.pTrue else pred - | Ast.Bexp _ -> if neg then Ast.pNot pred else pred - | Ast.Not p -> push_neg ~neg:(not neg) p - | Ast.Imp (p, q) -> - if neg then Ast.pAnd [push_neg p; push_neg ~neg:true q] - else Ast.pImp (push_neg p, push_neg q) - | Ast.Forall (qs, p) -> - let pred' = Ast.pForall (qs, push_neg ~neg:false p) in - if neg then Ast.pNot pred' else pred' - | Ast.And ps -> List.map (push_neg ~neg:neg) ps |> if neg then Ast.pOr else Ast.pAnd - | Ast.Or ps -> List.map (push_neg ~neg:neg) ps |> if neg then Ast.pAnd else Ast.pOr - | Ast.Atom (e1, brel, e2) -> if neg then Ast.pAtom (e1, neg_brel brel, e2) else pred - -(* Andrey: TODO flatten nested conjunctions/disjunctions *) -let rec simplify_tauto ((p, _) as pred) = - match p with - | Ast.Not p -> Ast.pNot (simplify_tauto p) - | Ast.Imp (p, q) -> Ast.pImp (simplify_tauto p, simplify_tauto q) - | Ast.Forall (qs, p) -> Ast.pForall (qs, simplify_tauto p) - | Ast.And ps -> - let ps' = List.map simplify_tauto ps |> List.filter (fun p -> not(P.is_tauto p)) in - if List.mem Ast.pFalse ps' then Ast.pFalse else - begin - match ps' with - | [] -> Ast.pTrue - | [p'] -> p' - | _ :: _ -> Ast.pAnd ps' - end - | Ast.Or ps -> - let ps' = List.map simplify_tauto ps in - if List.exists P.is_tauto ps' then Ast.pTrue else - begin - match ps' with - | [] -> Ast.pFalse - | [p'] -> p' - | _ :: _ -> Ast.pOr ps' - end - | _ -> pred - -let rec partition_pred_defs edefs pdefs ((p, _) as pred) = - match p with - | Ast.Atom ((Ast.Var v, _), Ast.Eq, e) -> Ast.pTrue, Sy.SMap.add v e edefs, pdefs - | Ast.And [Ast.Imp ((Ast.Bexp (Ast.Var v1, _), _), p1), _; - Ast.Imp (p2, (Ast.Bexp (Ast.Var v2, _), _)), _] when v1 = v2 && p1 = p2 -> - Ast.pTrue, edefs, Sy.SMap.add v1 p1 pdefs - | Ast.And preds -> - let preds', edefs', pdefs' = List.fold_left - (fun (preds_sofar, edefs_sofar, pdefs_sofar) p -> - let p'', edefs'', pdefs'' = partition_pred_defs edefs_sofar pdefs_sofar p in - p'' :: preds_sofar, edefs'', pdefs'' - ) ([], edefs, pdefs) preds in - (Ast.pAnd preds'), edefs', pdefs' - | _ -> pred, edefs, pdefs - -let rec defs_of_pred edefs pdefs (p, _) = - match p with - | Ast.Atom ((Ast.Var v, _), Ast.Eq, e) -> Sy.SMap.add v e edefs, pdefs - | Ast.And [Ast.Imp ((Ast.Bexp (Ast.Var v1, _), _), p1), _; - Ast.Imp (p2, (Ast.Bexp (Ast.Var v2, _), _)), _] when v1 = v2 && p1 = p2 -> - edefs, Sy.SMap.add v1 p1 pdefs - | Ast.And preds -> - let edefs', pdefs' = List.fold_left - (fun (edefs_sofar, pdefs_sofar) p -> - let edefs'', pdefs'' = defs_of_pred edefs_sofar pdefs_sofar p in - edefs'', pdefs'' - ) (edefs, pdefs) preds in - edefs', pdefs' - | _ -> edefs, pdefs - - -let some_def_applied = ref false -let rec expr_apply_defs edefs pdefs ((e, _) as expr) = - let current_some_def_applied = !some_def_applied in - some_def_applied := false; - let expr'' = - match e with - | Ast.Con _ -> expr - | Ast.Var v -> - begin - try - let expr' = Sy.SMap.find v edefs in - some_def_applied := true; - expr' - with Not_found -> expr - end - | Ast.App (v, es) -> - let edefs' = Sy.SMap.remove v edefs in - Ast.eApp (v, List.map (expr_apply_defs edefs' pdefs) es) - | Ast.Bin (e1, op, e2) -> - Ast.eBin (expr_apply_defs edefs pdefs e1, op, expr_apply_defs edefs pdefs e2) - | Ast.Ite (p, e1, e2) -> - Ast.eIte (pred_apply_defs edefs pdefs p, - expr_apply_defs edefs pdefs e1, - expr_apply_defs edefs pdefs e2) - | Ast.Fld (v, e) -> - let v' = - try - match Sy.SMap.find v edefs with - | (Ast.Var v'', _) -> - some_def_applied := true; - v'' - | _ -> v - with Not_found -> v - in - Ast.eFld (v', expr_apply_defs edefs pdefs e) - in - if !some_def_applied then - let expr''' = expr_apply_defs edefs pdefs expr'' in - some_def_applied := current_some_def_applied; - expr''' - else - begin - some_def_applied := current_some_def_applied; - expr'' - end -and pred_apply_defs edefs pdefs ((p, _) as pred) = - let current_some_def_applied = !some_def_applied in - some_def_applied := false; - let pred'' = - match p with - | Ast.And ps -> List.map (pred_apply_defs edefs pdefs) ps |> Ast.pAnd - | Ast.Or ps -> List.map (pred_apply_defs edefs pdefs) ps |> Ast.pOr - | Ast.Not p -> pred_apply_defs edefs pdefs p |> Ast.pNot - | Ast.Imp (p, q) -> Ast.pImp (pred_apply_defs edefs pdefs p, pred_apply_defs edefs pdefs q) - | Ast.Bexp (Ast.Var v, _) -> - begin - Printf.printf "Applying on Bexp: %s\n" (P.to_string pred); - (* Andrey: TODO also consider edefs *) - try - let expr' = Sy.SMap.find v edefs in - some_def_applied := true; - Ast.pBexp expr' - with Not_found -> - try - let pred' = Sy.SMap.find v pdefs in - some_def_applied := true; - pred' - with Not_found -> - pred - end - | Ast.Atom (e1, brel, e2) -> - Ast.pAtom (expr_apply_defs edefs pdefs e1, brel, expr_apply_defs edefs pdefs e2) - | Ast.Forall (qs, p) -> - let vs = List.map fst qs in - let edefs' = List.fold_left (fun defs v -> Sy.SMap.remove v defs) edefs vs in - let pdefs' = List.fold_left (fun defs v -> Sy.SMap.remove v defs) pdefs vs in - Ast.pForall (qs, pred_apply_defs edefs' pdefs' p) - | _ -> pred - in - if !some_def_applied then - let pred''' = pred_apply_defs edefs pdefs pred'' in - some_def_applied := current_some_def_applied; - pred''' - else - begin - some_def_applied := current_some_def_applied; - pred'' - end - - -let support_of_env sol env = - Sy.SMap.fold - (fun ksym reft sup -> - let vv = C.vv_of_reft reft in - let kv = Ast.eVar ksym in - let syms = C.preds_of_reft sol reft |> - List.map (fun p -> P.subst p vv kv) |> List.filter (fun p -> not(pred_is_true p)) |> - List.map P.support |> List.flatten - in - List.fold_left (fun sup' sym -> Sy.SSet.add sym sup') sup syms - ) env Sy.SSet.empty - - - -let armc_true = "true" -let armc_false = "false" -let loop_pc = "loop" -let start_pc = "start" -let error_pc = "error" -let val_vname = "VVVV" -let exists_kv = "EX" -let primed_suffix = "p" -let str__cil_tmp = "__cil_tmp" - -type kv_scope = { - kvs : string list; - kv_scope : string list StrMap.t -} - -type horn_clause = { - body_pred : Ast.pred; - body_kvars : (Su.t * Sy.t) list; - head_pred : Ast.pred; - head_kvars : (Su.t * Sy.t) list; - tag : string; -} - -let sanitize_symbol s = - Str.global_replace (Str.regexp "@") "_at_" s |> Str.global_replace (Str.regexp "#") "_hash_" |> - Str.global_replace (Str.regexp "\\.") "_dot_" |> Str.global_replace (Str.regexp "'") "_q_" - -let symbol_to_armc s = Sy.to_string s |> sanitize_symbol - -let var_to_armc s = Sy.to_string s |> sanitize_symbol |> String.capitalize - -let subs_to_map subs = - List.fold_left - (fun m (s, e) -> - StrMap.add (symbol_to_armc s) e m - ) StrMap.empty (Su.to_list subs) - -let mk_data_var ?(suffix = "") kv v = - Printf.sprintf "_%s_%s%s%s" - (sanitize_symbol v) (sanitize_symbol kv) (if suffix = "" then "" else "_") suffix - - -(* -let defs_of_env state env = - Sy.SMap.fold - (fun ksym reft defs -> - let vv = C.vv_of_reft reft in - let kv = Ast.eVar ksym in - let defs' = C.preds_of_reft state.sol reft |> - List.map (fun p -> P.subst p vv kv) |> List.filter (fun p -> not(pred_is_true p)) |> - List.map (defs_of_pred state) |> List.flatten - in - defs' ++ defs - ) env [] -*) - -let constant_to_armc = Ast.Constant.to_string -let bop_to_armc = function - | Ast.Plus -> "+" - | Ast.Minus -> "-" - | Ast.Times -> "*" - | Ast.Div -> "/" -let brel_to_armc = function - | Ast.Eq -> "=" - | Ast.Ne -> "=\\=" - | Ast.Gt -> ">" - | Ast.Ge -> ">=" - | Ast.Lt -> "<" - | Ast.Le -> "=<" -let bind_to_armc (s, t) = (* Andrey: TODO support binders *) - Printf.sprintf "%s:%s" (symbol_to_armc s) (Ast.Sort.to_string t |> sanitize_symbol) -let rec expr_to_armc (e, _) = - match e with - | Ast.Con c -> constant_to_armc c - | Ast.Var s -> var_to_armc s - | Ast.App (s, es) -> - if !Co.purify_function_application then "_" else - let str = symbol_to_armc s in - if es = [] then str else - Printf.sprintf "f_%s(%s)" str (List.map expr_to_armc es |> String.concat ", ") - | Ast.Bin (e1, op, e2) -> - Printf.sprintf "(%s %s %s)" - (expr_to_armc e1) (bop_to_armc op) (expr_to_armc e2) - | Ast.Ite (ip, te, ee) -> - Printf.sprintf "ite(%s, %s, %s)" - (pred_to_armc ip) (expr_to_armc te) (expr_to_armc ee) - | Ast.Fld (s, e) -> - Printf.sprintf "fld(%s, %s)" (expr_to_armc e) (symbol_to_armc s) -and pred_to_armc ((p, _) as pred) = - if pred_is_true pred then - armc_true - else - match p with - | Ast.True -> armc_true - | Ast.False -> armc_false - | Ast.Bexp e -> Printf.sprintf "bexp(%s)" (expr_to_armc e) - | Ast.Not (Ast.True, _) -> armc_false - | Ast.Not (Ast.False, _) -> armc_true - | Ast.Not p -> Printf.sprintf "neg(%s)" (pred_to_armc p) - | Ast.Imp (p1, p2) -> Printf.sprintf "imp(%s, %s)" (pred_to_armc p1) (pred_to_armc p2) - | Ast.And [] -> armc_true - | Ast.And [p] -> pred_to_armc p - | Ast.And [Ast.Imp ((Ast.Bexp e1, _) as p, p1), _; - Ast.Imp (p2, (Ast.Bexp e2, _)), _] when e1 = e2 && p1 = p2 -> - Printf.sprintf "bexp_def(%s, %s)" (pred_to_armc p) (pred_to_armc p1) - | Ast.And (_::_ as ps) -> - Printf.sprintf "(%s)" (List.map pred_to_armc ps |> String.concat ", ") - | Ast.Or [] -> armc_false - | Ast.Or [p] -> pred_to_armc p - | Ast.Or (_::_ as ps) -> Printf.sprintf "(%s)" (List.map pred_to_armc ps |> String.concat "; ") - | Ast.Atom (e1, Ast.Eq, (Ast.Ite(ip, te, ee), _)) -> - let ip_str = pred_to_armc ip in - let e1_str = expr_to_armc e1 in - Printf.sprintf "((%s, %s = %s); (neg(%s), %s = %s))" - ip_str e1_str (expr_to_armc te) - ip_str e1_str (expr_to_armc ee) - | Ast.Atom (e1, r, e2) -> - Printf.sprintf "%s %s %s" - (expr_to_armc e1) (brel_to_armc r) (expr_to_armc e2) - | Ast.Forall (qs,p) -> (* Andrey: TODO support forall *) - Printf.sprintf "forall([%s], %s)" - (List.map bind_to_armc qs |> String.concat ", ") - (pred_to_armc p) - - -let mk_kv_scope out ts wfs = - (* let kvs = List.map C.kvars_of_t ts |> List.flatten |> List.map snd |> - List.map symbol_to_armc |> (* (fun s -> Printf.sprintf "k%s" (symbol_to_armc s)) |> *) - Misc.sort_and_compact in - *) - let kv_scope_wf = - List.fold_left - (fun m wf -> - match C.reft_of_wf wf |> C.ras_of_reft with - | [C.Kvar (subs, kvar)] when Su.is_empty subs -> - let v = symbol_to_armc kvar in - let scope = -(* val_vname :: *) - (C.env_of_wf wf - |> C.bindings_of_env - |> List.filter - (fun (_, (_, typ, _)) -> - Ast.Sort.t_int = typ - ) - |> List.map fst - |> List.map symbol_to_armc - |> List.filter - (fun s -> - not(Misc.is_prefix str__cil_tmp s - || Misc.is_prefix "FP_" s - || Misc.is_prefix "Open_" s - || Misc.is_prefix "None_0" s - || Misc.is_prefix "Some_0" s - || Misc.is_prefix "true_0" s - || Misc.is_prefix "false_0" s - || Misc.is_prefix "Pervasives_" s - || Misc.is_prefix "FIXPOINTSYMBOL_" s)) - |> List.sort compare) - in - StrMap.add v scope m - | _ -> m - (* Andrey: TODO handle ill-formed wf *) - (* Format.printf "%a" (C.print_wf None) wf; - - failure "ERROR: kname_scope_map: ill-formed wf" - *) - ) StrMap.empty wfs in - let kv_scope_t = - List.fold_left - (fun m (subs, kvar) -> - let v = symbol_to_armc kvar in - let scope = - List.filter (fun (v, (e, _)) -> - match e with - | Ast.Var v' -> v <> v' - | _ -> true - ) (Su.to_list subs) |> - List.map fst |> List.map symbol_to_armc |> strlist_to_strset in - let scope' = try StrMap.find v m with Not_found -> StrSet.empty in - StrMap.add v (StrSet.union scope scope') m - ) StrMap.empty (List.map C.kvars_of_t ts |> List.flatten) in - let kv_scope = kv_scope_wf in - let kv_scope_old = - StrMap.map (fun scope -> val_vname :: (StrSet.elements scope |> List.sort compare)) kv_scope_t in - let kvs = StrMap.fold (fun kv _ kvs -> kv :: kvs) kv_scope [] in - (* - StrMap.iter (fun kv scope -> - Printf.fprintf out "%% %s -> %s\n" kv (String.concat ", " scope)) kv_scope; - *) - {kvs = kvs; kv_scope = kv_scope} - -let mk_data ?(suffix = "") ?(skip_kvs = []) s = - Printf.sprintf "[%s]" - (List.map - (fun kv -> - try - StrMap.find kv s.kv_scope |> - List.map (mk_data_var ~suffix:(if List.mem kv skip_kvs then "" else suffix) kv) - with Not_found -> failure "ERROR: mk_data: scope not found for %s" kv - ) s.kvs |> List.flatten |> String.concat ", ") - -let mk_query ?(suffix = "") s kv = - Printf.sprintf "k%s(%s)" - kv (List.map (mk_data_var ~suffix:suffix kv) (StrMap.find kv s.kv_scope) |> String.concat ", ") - -let mk_var2names state = - List.map - (fun kv -> - Printf.sprintf "var2names(p(pc(k%s), data(%s)), [%s])." - kv - (List.map (mk_data_var kv) (StrMap.find kv state.kv_scope) |> String.concat ", ") - (List.map - (fun v -> - Printf.sprintf "(%s, \'%s_%s\')" (mk_data_var kv v) v kv - ) (StrMap.find kv state.kv_scope) |> String.concat ", ") - ) state.kvs |> String.concat "\n" - -let mk_skip_update state kvs = - if kvs = [] then armc_true else - List.map - (fun kv -> - List.map - (fun v -> - Printf.sprintf "%s = %s" - (mk_data_var ~suffix:primed_suffix kv v) (mk_data_var kv v) - ) (StrMap.find kv state.kv_scope) |> String.concat ", " - ) kvs |> String.concat ", " - -let mk_update_str from_vs to_vs updates = - List.map2 - (fun v vp -> - Printf.sprintf "%s = %s" vp (try StrMap.find v updates with Not_found -> v) - ) from_vs to_vs |> String.concat ", " - -let split_scope scope = - match scope with - | value :: data -> value, data - | _ -> failure "ERROR: split_scope: empty scope %s" (String.concat ", " scope) - -let reft_to_armc ?(noquery = false) ?(suffix = "") state reft = - let vv = C.vv_of_reft reft |> symbol_to_armc in - let rs = C.ras_of_reft reft in - if rs = [] then armc_true else - List.map - (function - | C.Conc pred -> pred_to_armc pred - | C.Kvar (subs, sym) -> - failwith "AR: toQARMC.ml reft_to_armc"; - if true (* Sy.SMap.mem sym state.sol && Sy.SMap.find sym state.sol = [] *)then - armc_true (* skip true *) - else - let subs_map = subs_to_map subs in - let find_subst v default = - try StrMap.find v subs_map |> expr_to_armc with Not_found -> default in - let kv = symbol_to_armc sym in - let value, data = StrMap.find kv state.kv_scope |> split_scope in - Printf.sprintf "%s%s = %s" - (if noquery then "" else (mk_query ~suffix:suffix state kv) ^ ", ") - (mk_data_var ~suffix:suffix kv value) - (find_subst vv (mk_data_var exists_kv vv)) - :: List.map - (fun v -> - Printf.sprintf "%s = %s" - (mk_data_var ~suffix:suffix kv v) - (find_subst v (mk_data_var exists_kv v)) - ) data |> String.concat ", " - ) rs |> String.concat ", " - -let mk_rule head annot_guards annot_updates id = - let rec annot_conj_to_armc = function - | (g, a) :: rest -> - if rest = [] then Printf.sprintf "\n %s \t%% %s\n ]," g a - else Printf.sprintf "\n %s, \t%% %s%s" g a (annot_conj_to_armc rest) - | [] -> "]," - in - Printf.sprintf - " -hc(%s, [%s %s). -" - head (annot_guards @ annot_updates |> List.filter (fun (g, _) -> g <> armc_true) |> annot_conj_to_armc) id - -let preds_kvars_of_reft reft = - List.fold_left - (fun (ps, ks) r -> - match r with - | C.Conc p -> p :: ps, ks - | C.Kvar (subs, kvar) -> ps, (subs, kvar) :: ks - ) ([], []) (C.ras_of_reft reft) - -let t_to_horn_clause t = - let lhs_ps, lhs_ks = C.lhs_of_t t |> preds_kvars_of_reft in - let body_ps, body_ks = - Sy.SMap.fold - (fun bv reft (ps, ks) -> - let ps', ks' = preds_kvars_of_reft (C.theta (Su.of_list [(C.vv_of_reft reft, Ast.eVar bv)]) reft) in - List.rev_append ps' ps, List.rev_append ks' ks - ) (C.env_of_t t) (C.grd_of_t t :: lhs_ps, lhs_ks) in - let head_ps, head_ks = C.rhs_of_t t |> preds_kvars_of_reft in - { - body_pred = Ast.pAnd body_ps |> simplify_tauto; - body_kvars = body_ks; - head_pred = Ast.pAnd head_ps |> simplify_tauto; - head_kvars = head_ks; - tag = try string_of_int (C.id_of_t t) with _ -> failure "ERROR: t_to_horn_clause: anonymous constraint %s" (C.to_string t) - } - -let simplify_horn_clause hc = - let body_edefs, body_pdefs = defs_of_pred Sy.SMap.empty Sy.SMap.empty hc.body_pred in - let edefs, pdefs = defs_of_pred body_edefs body_pdefs hc.head_pred in - { - body_pred = pred_apply_defs edefs pdefs hc.body_pred |> simplify_tauto; - body_kvars = hc.body_kvars; - head_pred = pred_apply_defs edefs pdefs hc.head_pred |> simplify_tauto; - head_kvars = hc.head_kvars; - tag = hc.tag - } - -let print_horn_clause hc = - Printf.printf "%s: %s, %s :- %s, #%d %s\n" - hc.tag - (P.to_string hc.head_pred) - (List.map (fun (subs, kvar) -> C.refa_to_string (C.Kvar (subs, kvar))) hc.head_kvars |> String.concat ", ") - (P.to_string hc.body_pred) - (List.length hc.body_kvars) - (List.map (fun (subs, kvar) -> C.refa_to_string (C.Kvar (subs, kvar))) hc.body_kvars |> String.concat ", ") - - -let t_to_armc state t = - t_to_horn_clause t |> simplify_horn_clause |> print_horn_clause; - let env = C.env_of_t t in - let grd = C.grd_of_t t in - let lhs = C.lhs_of_t t in - let rhs = C.rhs_of_t t in - let rhs_s = C.reft_to_string rhs in - let tag = try string_of_int (C.id_of_t t) with _ -> - failure "ERROR: t_to_armc: anonymous constraint %s" (C.to_string t) in -(* let defs = defs_of_env state env in *) - let annot_guards = - Misc.map_partial - (fun (bv, reft) -> - if C.ras_of_reft reft <> [] then - Some (reft_to_armc state (C.theta (Su.of_list [(C.vv_of_reft reft, Ast.eVar bv)]) reft), - C.binding_to_string (bv, reft)) - else - None - ) (env |> C.bindings_of_env) - ++ [(pred_to_armc grd, P.to_string grd); - (reft_to_armc state lhs, "|- " ^ (C.reft_to_string lhs))] in - let ps, kvs = - List.fold_left (fun (ps', kvs') refa -> - match refa with - | C.Conc p -> p::ps', kvs' - | C.Kvar (subs, sym) -> ps', (subs, sym)::kvs' - ) ([], []) (C.ras_of_reft rhs) in -(* Andrey: obsolete code - let env_sup = support_of_env state.sol env |> Sy.SSet.elements in - Printf.printf "Rule %s\n" tag; - Printf.printf "Env support #%d: %s\n" - (List.length env_sup) (env_sup |> List.map Sy.to_string |> String.concat ", "); - Printf.printf "Guard support %s: %s\n" - (P.to_string grd) - (P.support grd |> List.map Sy.to_string |> String.concat ", "); -*) - (if ps <> [] then - [mk_rule error_pc annot_guards [(Ast.pAnd ps |> Ast.pNot |> pred_to_armc, "<: " ^ rhs_s)] tag] - else - []) - ++ - (List.map - (fun (_, sym) -> - mk_rule (mk_query ~suffix:primed_suffix state (symbol_to_armc sym)) - annot_guards - [(reft_to_armc ~noquery:true ~suffix:primed_suffix state rhs, "<: " ^ rhs_s)] - tag - ) kvs) - - -(* - make -f Makefile.fixtop && ./f -latex /tmp/main.tex -armc /tmp/a.pl tests/pldi08-max.fq && cat /tmp/a.pl - -tests: - -for file in `ls pldi08-*-atom.fq`; do ../f -latex /tmp/main.tex -armc /tmp/a.pl $file; head -n 1 /tmp/a.pl; armc a.pl | grep correct; done - -pldi08-arraymax-atom.fq pass -pldi08-max-atom.fq pass -pldi08-foldn-atom.fq pass -pldi08-sum-atom.fq pass -mask-atom.fq pass -samples-atom.fq pass - -test00.c pass - -*) - -let subs_kvar_to_strs state ?(suffix = "") subs kvar = - let kv = symbol_to_armc kvar in - let scope = StrMap.find kv state.kv_scope in - let scope_set = strlist_to_strset scope in - let subs_map = subs_to_map subs in - let kvar_str = - Printf.sprintf "%s(%s)" kv - (List.map - (fun v -> - let v_cap = String.capitalize v in - let v_cap_suffix = v_cap ^ suffix in - try - match StrMap.find v subs_map with - | (Ast.Var s, _) -> - let v_exp = var_to_armc s in - if StrSet.mem v_exp scope_set then v_cap_suffix - else v_exp - | _ -> v_cap_suffix - with Not_found -> v_cap - ) scope |> String.concat ", ") - in - let subs_strs = - StrMap.fold (fun v e acc -> - let subs_str = - Printf.sprintf "%s%s = %s" - (String.capitalize v) suffix (StrMap.find v subs_map |> expr_to_armc) - in - match e with - | (Ast.Var s, _) -> - let v_exp = var_to_armc s in - if StrSet.mem v_exp scope_set then subs_str :: acc - else acc - | _ -> subs_str :: acc - ) subs_map [] - in - kvar_str, subs_strs - -let mk_query_naming state = - List.map - (fun kv -> - Printf.sprintf "query_naming(%s(%s))." kv - (StrMap.find kv state.kv_scope - |> List.map - (fun v -> - if 'a' <= v.[0] && v.[0] <= 'z' then v - else Printf.sprintf "'%s'" v - ) - |> String.concat ", ") - ) state.kvs |> String.concat "\n" - -exception ValidClause -let horn_clause_to_tc state hc = - let head_str, head_grd_strs = -(* - match hc.head_kvars with - | [(subs, kvar)] -> - let head_kvar_str, head_subs_strs = - subs_kvar_to_strs state ~suffix:"_0" subs kvar - in - head_kvar_str, head_subs_strs - | [] -> - let head_pred = push_neg ~neg:true hc.head_pred |> simplify_tauto in - "false", if P.is_tauto head_pred then [] else [pred_to_armc head_pred] - | _ :: _ -> - print_horn_clause hc; - failwith ("horn_clause_to_tc: unexpected clause " ^ hc.tag) -*) - match P.is_tauto hc.head_pred, hc.head_kvars with - | true, [(subs, kvar)] -> - let head_kvar_str, head_subs_strs = - subs_kvar_to_strs state ~suffix:"_0" subs kvar - in - head_kvar_str, head_subs_strs - | true, [] -> raise ValidClause - | false, [] -> - let head_pred = push_neg ~neg:true hc.head_pred |> simplify_tauto in - "false", if P.is_tauto head_pred then [] else [pred_to_armc head_pred] - | _, _ -> - print_horn_clause hc; - failwith ("horn_clause_to_tc: unexpected clause " ^ hc.tag) - in - let tag_str = Printf.sprintf "id(%s)" hc.tag in - let simple_body_pred = hc.body_pred |> push_neg ~neg:false |> simplify_tauto in - let grd_tag_strs = - if P.is_tauto simple_body_pred then tag_str :: head_grd_strs - else pred_to_armc simple_body_pred :: tag_str :: head_grd_strs - in - let body_strs, _ = - List.fold_left (fun (s, n) (subs, kvar) -> - let kvar_str, subs_strs = subs_kvar_to_strs state ~suffix:("_" ^ string_of_int n) subs kvar in - kvar_str :: (subs_strs ++ s), - n+1 - ) (grd_tag_strs, 1) hc.body_kvars - in - Printf.sprintf "%s :- %s.\n" head_str (body_strs |> List.rev |> String.concat ", ") - -let to_qarmc out ts wfs = - print_endline "Translating to QARMC."; - - print_endline "========================="; - List.iter (Format.printf "%a" (C.print_t None)) ts; - print_endline "========================="; - - let state = mk_kv_scope out ts wfs in -(* let hcs = List.map (fun t -> t_to_horn_clause t |> simplify_horn_clause) ts in *) - let hcs = List.map t_to_horn_clause ts in - output_string out (mk_query_naming state); - output_string out "\n\n"; - List.iter (fun hc -> - try horn_clause_to_tc state hc |> output_string out - with ValidClause -> () - ) hcs; - print_endline "heheheheh"; - List.iter (fun hc -> print_horn_clause hc; output_string out "\n") hcs diff --git a/external/fixpoint/toRawHorn.ml b/external/fixpoint/toRawHorn.ml deleted file mode 100644 --- a/external/fixpoint/toRawHorn.ml +++ /dev/null @@ -1,200 +0,0 @@ -(* Dumping constraints as Horn clauses without any simplifications *) - -module C = FixConstraint -module Co = Constants -module Sy = Ast.Symbol -module Su = Ast.Subst -module P = Ast.Predicate -module E = Ast.Expression -module StrMap = Map.Make (struct type t = string let compare = compare end) -module StrSet = Set.Make (struct type t = string let compare = compare end) -module Misc = FixMisc open Misc.Ops - -let raw_true = "1=1" -let raw_false = "0=1" - - -let sanitize_symbol s = - Str.global_replace (Str.regexp "@") "_at_" s |> Str.global_replace (Str.regexp "#") "_hash_" |> - Str.global_replace (Str.regexp "\\.") "_dot_" |> Str.global_replace (Str.regexp "'") "_q_" - -let symbol_to_raw s = Sy.to_string s |> sanitize_symbol -let constant_to_raw = Ast.Constant.to_string -let bop_to_raw = function - | Ast.Plus -> "+" - | Ast.Minus -> "-" - | Ast.Times -> "*" - | Ast.Div -> "/" -let brel_to_raw = function - | Ast.Eq -> "=" - | Ast.Ne -> "=\\=" - | Ast.Gt -> ">" - | Ast.Ge -> ">=" - | Ast.Lt -> "<" - | Ast.Le -> "=<" -let bind_to_raw (s, t) = (* Andrey: TODO support binders *) - Printf.sprintf "%s:%s" (symbol_to_raw s) (Ast.Sort.to_string t |> sanitize_symbol) -let rec expr_to_raw expr = - let e = E.unwrap expr in - match e with - | Ast.Con c -> constant_to_raw c - | Ast.Var s -> symbol_to_raw s - | Ast.App (s, es) -> - if !Co.purify_function_application then "_" else - let str = symbol_to_raw s in - if es = [] then str else - Printf.sprintf "f_%s(%s)" str (List.map expr_to_raw es |> String.concat ", ") - | Ast.Bin (e1, op, e2) -> - Printf.sprintf "(%s %s %s)" - (expr_to_raw e1) (bop_to_raw op) (expr_to_raw e2) - | Ast.Ite (ip, te, ee) -> - Printf.sprintf "ite(%s, %s, %s)" - (pred_to_raw ip) (expr_to_raw te) (expr_to_raw ee) - | Ast.Fld (s, e) -> - Printf.sprintf "fld(%s, %s)" (expr_to_raw e) (symbol_to_raw s) - | _ -> failwith (Printf.sprintf "expr_to_raw: %s" (E.to_string expr)) -and pred_to_raw pred = - if P.is_tauto pred then - raw_true - else - let p = P.unwrap pred in - match p with - | Ast.True -> raw_true - | Ast.False -> raw_false - | Ast.Bexp e -> Printf.sprintf "%s = 1" (expr_to_raw e) - | Ast.Not (Ast.True, _) -> raw_false - | Ast.Not (Ast.False, _) -> raw_true - | Ast.Not p -> Printf.sprintf "neg(%s)" (pred_to_raw p) - | Ast.Imp (p1, p2) -> Printf.sprintf "imp(%s, %s)" (pred_to_raw p1) (pred_to_raw p2) - | Ast.And [] -> raw_true - | Ast.And [p] -> pred_to_raw p - | Ast.And (_::_ as ps) -> - Printf.sprintf "(%s)" (List.map pred_to_raw ps |> String.concat ", ") - | Ast.Or [] -> raw_false - | Ast.Or [p] -> pred_to_raw p - | Ast.Or (_::_ as ps) -> Printf.sprintf "(%s)" (List.map pred_to_raw ps |> String.concat "; ") - | Ast.Atom (e1, Ast.Eq, (Ast.Ite(ip, te, ee), _)) -> - let ip_str = pred_to_raw ip in - let e1_str = expr_to_raw e1 in - Printf.sprintf "((%s, %s = %s); (neg(%s), %s = %s))" - ip_str e1_str (expr_to_raw te) - ip_str e1_str (expr_to_raw ee) - | Ast.Atom (e1, r, e2) -> - Printf.sprintf "%s %s %s" - (expr_to_raw e1) (brel_to_raw r) (expr_to_raw e2) - | Ast.Forall (qs,p) -> (* Andrey: TODO support forall *) - Printf.sprintf "forall([%s], %s)" - (List.map bind_to_raw qs |> String.concat ", ") - (pred_to_raw p) - -let subst_to_raw subst = - Misc.map_to_string - (fun (sym, expr) -> - Printf.sprintf "%s = %s" (symbol_to_raw sym) (expr_to_raw expr) - ) (Ast.Subst.to_list subst) - -let kvar_to_scope_tbl = Hashtbl.create 100 - -let wfs_option = ref None - -let is_upper c = c = Char.uppercase c - -let find_scope wfs sym = - match Misc.map_partial - (fun wf -> - let reft = C.reft_of_wf wf in - let vv = C.vv_of_reft reft in - match C.ras_of_reft reft with - | [C.Kvar (subst, sym')] when (Ast.Subst.is_empty subst) && sym = sym' -> - let vv_raw = symbol_to_raw vv in - Some (vv_raw, - StrSet.remove vv_raw - (Sy.SMap.fold (fun bv reft sofar -> - if not(C.sort_of_reft reft |> Ast.Sort.is_int) -(* is_upper (Sy.to_string bv).[0] *) - then - sofar - else - StrSet.add (symbol_to_raw bv) sofar - ) (C.env_of_wf wf) StrSet.empty)) - | _ -> None - ) wfs with - | (vv, scope) :: _ -> vv, scope - | [] -> failwith (Printf.sprintf "Not found wf constraint for %s" (Sy.to_string sym)) - -let scope_of_ksym ksym = - try - Hashtbl.find kvar_to_scope_tbl ksym - with Not_found -> - begin - match !wfs_option with - | Some wfs -> - let scope = find_scope wfs ksym in - Hashtbl.add kvar_to_scope_tbl ksym scope; - scope - | None -> failwith "Uninitialized wfs_option reference" - end - -let refa_to_raw = function - | C.Conc pred -> pred_to_raw pred - | C.Kvar (subst, sym) -> - let vv, scope = scope_of_ksym sym in - let subs = Ast.Subst.to_list subst in - let params = - List.map (fun param -> - try - let _, exp = - List.find (fun (v, _) -> - symbol_to_raw v = param - ) subs in - match exp with - | Ast.Var param', _ -> symbol_to_raw param' - | _ -> failwith (Printf.sprintf "substition by a non-variable %s" (E.to_string exp)) - with Not_found -> param - ) (vv :: (StrSet.elements scope |> List.sort compare)) - in - Printf.sprintf "%s(%s)" (symbol_to_raw sym) (String.concat ", " params) - -let reft_to_raw reft = - if C.sort_of_reft reft |> Ast.Sort.is_func then - raw_true - else - let ras = C.ras_of_reft reft in - match ras with - | [] -> raw_true - | _ :: _ -> - Misc.map_to_string refa_to_raw ras - -let subst_refa refa sym exp = - match refa with - | C.Conc pred -> C.Conc (P.subst pred sym exp) - | C.Kvar (subst, sym') -> C.Kvar (Ast.Subst.extend subst (sym, exp), sym') - -let subst_reft reft sym exp = - C.make_reft - (C.vv_of_reft reft) (C.sort_of_reft reft) - (List.map (fun refa -> subst_refa refa sym exp) (C.ras_of_reft reft)) - -let env_to_raw env = - Sy.SMap.fold - (fun bv reft sofar -> - [subst_reft reft (C.vv_of_reft reft) (Ast.eVar bv) |> reft_to_raw] ++ sofar - ) env [] |> List.filter ((<>) "1=1") |> String.concat ", " - - -let c_to_raw c = - Printf.sprintf "rule(%d, %s, [\n%s,\n%s,\n%s\n]).\n\n" - (C.id_of_t c) - (C.rhs_of_t c |> reft_to_raw) - (C.lhs_of_t c |> reft_to_raw) - (C.grd_of_t c |> pred_to_raw) - (C.env_of_t c |> env_to_raw) - -let to_raw_horn out cs wfs sol = - let cs = FixSimplify.simplify_ts cs in - wfs_option := Some wfs; - print_endline "Translating to raw Horn clauses."; - List.iter (fun c -> - Printf.fprintf out "/*\n%s*/\n" (C.to_string c); - output_string out (c_to_raw c) - ) cs diff --git a/external/fixpoint/toSmtLib.ml b/external/fixpoint/toSmtLib.ml deleted file mode 100644 --- a/external/fixpoint/toSmtLib.ml +++ /dev/null @@ -1,504 +0,0 @@ -(* - * Copyright © 2009 The Regents of the University of California. All rights reserved. - * - * Permission is hereby granted, without written agreement and without - * license or royalty fees, to use, copy, modify, and distribute this - * software and its documentation for any purpose, provided that the - * above copyright notice and the following two paragraphs appear in - * all copies of this software. - * - * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY - * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES - * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN - * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY - * OF SUCH DAMAGE. - * - * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, - * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY - * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS - * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION - * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONAst.Symbol. - * - *) - -(* This module implements the IMP language and translation from fixpoint constraints *) - - -module F = Format -module H = Hashtbl -module A = Ast -module E = A.Expression -module P = A.Predicate -module Sy = A.Symbol -module So = A.Sort -module SM = Sy.SMap -module SS = Sy.SSet -module C = FixConstraint -module Cg = FixConfig -module Co = Constants -(*module BS = BNstats*) - -module Misc = FixMisc open Misc.Ops - -let mydebug = false - -(*************************************************************************) -(************* Datatypes for SMTLIB Representation ***********************) -(*************************************************************************) -(* -type sort = Int | Bool | Func of (sort list * sort) -*) -type rpred - = A.pred (* Bexp (App (k, es)) *) - -type vdef - = Sy.t * So.t (* variable, sort *) - -type kdef - = Sy.t * (vdef list) - -type cstr - = { lhs : A.pred - ; rhs : rpred option - ; id : int - } - -type smtlib - = { vars : vdef list - ; kvars : kdef list - ; cstrs : cstr list - ; consts : vdef list - } - -type kmap - = kdef SM.t - -let is_kvar x = Misc.is_prefix "k_" (Sy.to_string x) - -(*************************************************************************) -(************* Rendering SMTLIB to String ********************************) -(*************************************************************************) - -(* Printing as C syntax *) - -let print_brel ppf = function - | A.Eq -> F.fprintf ppf "=" - | A.Ne -> F.fprintf ppf "!=" - | A.Gt -> F.fprintf ppf ">" - | A.Ge -> F.fprintf ppf ">=" - | A.Lt -> F.fprintf ppf "<" - | A.Le -> F.fprintf ppf "<=" - -let print_bop ppf = function - | A.Plus -> F.fprintf ppf "+" - | A.Minus -> F.fprintf ppf "-" - | A.Times -> F.fprintf ppf "*" - | A.Div -> F.fprintf ppf "/" - | A.Mod -> F.fprintf ppf "mod" - -let rec print_pred ppf pred = - match P.unwrap pred with - | A.True -> - F.fprintf ppf "true" - | A.False -> - F.fprintf ppf "false" - | A.Atom (e1, A.Ne, e2) -> - F.fprintf ppf "(not (= %a %a))" - print_expr e1 - print_expr e2 - | A.Atom (e1, r, e2) -> - F.fprintf ppf "(%a %a %a)" - print_brel r - print_expr e1 - print_expr e2 - | A.And ps -> - Misc.pprint_many_prefix "and" A.pTrue print_pred ppf ps - | A.Or ps -> - Misc.pprint_many_prefix "or" A.pFalse print_pred ppf ps - | A.Not p -> - F.fprintf ppf "(not %a)" print_pred p - | A.Imp (p1, p2) -> - F.fprintf ppf "(=> %a %a)" - print_pred p1 - print_pred p2 - | A.Iff (p1, p2) -> - F.fprintf ppf "(= %a %a)" - print_pred p1 - print_pred p2 - | A.Bexp e -> - print_expr ppf e - | _ -> assertf "ERROR: ToSmtLib.print_pred %s" (P.to_string pred) - -and print_expr_app f ppf = function - | [e] -> - F.fprintf ppf "(select %a %a)" - Sy.print f - print_expr e - | e::es -> - F.fprintf ppf "(select %a %a)" - (print_expr_app f) es - print_expr e - -and print_expr ppf expr = - match E.unwrap expr with - | A.Con c -> - F.fprintf ppf "%a" A.Constant.print c - | A.App (v, []) - | A.Var v -> - F.fprintf ppf "%a" Sy.print v - | A.App (f, es) when is_kvar f -> - F.fprintf ppf "(%a %a)" - Sy.print f - (Misc.pprint_many false " " print_expr) es - - | A.App (f, es) -> - print_expr_app f ppf (List.rev es) - - (* - print_expr_app f ppf (List.rev es) - F.fprintf ppf "(%a %a)" - Sy.print f - (Misc.pprint_many false " " print_expr) es *) - | A.Bin (e1, op, e2) -> - F.fprintf ppf "(%a %a %a)" - print_bop op - print_expr e1 - print_expr e2 - | A.Ite (p, e1, e2) -> - F.fprintf ppf "(ite %a %a %a)" - print_pred p - print_expr e1 - print_expr e2 - | A.Cst (e, _) -> - F.fprintf ppf "%a" print_expr e - | _ -> assertf "ERROR: ToSmtLib.print_expr %s" (E.to_string expr) - -let print_sort_base ppf t = - if So.is_bool t then - Format.fprintf ppf "Bool" - else - Format.fprintf ppf "Int" - -let rec print_sort ppf t = match So.func_of_t t with - | Some (_, [], t) -> - print_sort_base ppf t - - | Some (_, ts, t) -> - Format.fprintf ppf "%a %a" - (Misc.pprint_many false " " print_sort) ts - print_sort t - | None -> - print_sort_base ppf t - - -(* -let print_vdef ppf (x, t) = match So.func_of_t t with - | Some (_, ts, t') when So.is_bool t' -> - Format.fprintf ppf ":extrapreds ((%a %a))" - Sy.print x - (Misc.pprint_many false " " print_sort) ts - | _ -> - Format.fprintf ppf ":extrafuns ((%a %a))" - Sy.print x - print_sort t -*) - -let rec print_fun_sorts ppf = function - | [t] -> print_sort ppf t - | t::ts -> Format.fprintf ppf "(Array %a %a)" - print_sort t - print_fun_sorts ts - -let print_vdef ppf (x, t) = match So.func_of_t t with - | Some (_, ts, t') -> - Format.fprintf ppf "(%a %a)" - Sy.print x - print_fun_sorts (ts @ [t']) - | _ -> - Format.fprintf ppf "(%a %a)" - Sy.print x - print_sort t - -let print_const ppf c = - Format.fprintf ppf "; constant \n%a\n" print_vdef c - -let groupConsts cs = - cs |> Misc.kgroupby snd - |> Misc.map (Misc.app_snd (List.map fst)) - |> List.filter (snd <+> List.length <+> (>) 0) - -let print_distinct ppf (t, cs) = - Format.fprintf ppf - "; distinct constants of sort: %a\n(distinct %a)\n" - print_sort t - (Misc.pprint_many false " " Sy.print) cs - -(* -let print_kdef ppf (kf, xts) = - Format.fprintf ppf ":extrapreds ((%a %a))" - Sy.print kf - (Misc.pprint_many false " " print_sort) (List.map snd xts) -*) -let print_kdef ppf (kf, xts) = - Format.fprintf ppf "(declare-fun %a (%a) Bool)" - Sy.print kf - (Misc.pprint_many false " " print_sort) (List.map snd xts) - - -let print_rhs ppf = function - | None -> Format.fprintf ppf "false" - | Some p -> Format.fprintf ppf "%a" print_pred p - -(* -let print_cstr ppf c = - Format.fprintf ppf "\n; cid = %d\n:assumption\n(implies (%a) %a)\n" - c.id print_pred c.lhs print_rhs c.rhs -*) - -let binds_of_cstr env c = - let lsyms = P.support c.lhs in - let rsyms = match c.rhs with None -> [] | Some p -> P.support p in - Misc.sort_and_compact (lsyms ++ rsyms) - |> List.filter (fun x -> SM.mem x env) - |> List.map (fun x -> (x, SM.safeFind x env "binds_of_cstr")) - -let print_cstr env ppf c = - Format.fprintf ppf "\n; cid = %d\n(assert (forall (%a) \n (=> %a %a))\n)" - c.id - (Misc.pprint_many true " " print_vdef) (binds_of_cstr env c) - print_pred c.lhs - print_rhs c.rhs - - -(* -let print ppf smt = - Format.fprintf ppf - "(benchmark unknown\n:status unsat\n:logic AUFLIA\n%a\n%a\n%a\n%a\n%a\n)" - (Misc.pprint_many true "\n" print_vdef) smt.vars - (Misc.pprint_many true "\n" print_const) smt.consts - (Misc.pprint_many true "\n" print_kdef) smt.kvars - (Misc.pprint_many true "\n" print_distinct) (groupConsts smt.consts) - (Misc.pprint_many true "\n" print_cstr) smt.cstrs -*) - -let print ppf smt = - let env = SM.of_list (smt.vars ++ smt.consts) in - Format.fprintf ppf - "(set-logic HORN)\n; KVARS\n\n%a\n\n; CONSTRAINTS\n%a\n" - (Misc.pprint_many true "\n" print_kdef) smt.kvars - (Misc.pprint_many true "\n" (print_cstr env)) smt.cstrs - - - -(*************************************************************************) -(************* Helpers for extracting var-sort bindings ******************) -(*************************************************************************) - -let sort_compat x t t' = - Ast.Sort.compat t t' - >> (fun b -> if not b then - Printf.printf "WARNING: k-sort incompatible for %s" - (Sy.to_string x)) - -(* HACKY sort_compat because in the end everything is an Int *) -let sort_compat x t1 t2 = - not (So.is_bool t1) - && not (So.is_bool t2) - && (not (So.is_func t1) || (t1 = t2)) - && (not (So.is_func t2) || (t1 = t2)) - -let vdefs_of_env env r = - env |> C.bindings_of_env - |> (++) [(C.vv_of_reft r, r)] - |> List.map (Misc.app_snd C.sort_of_reft) - (* |> List.filter (not <.> So.is_func <.> snd) *) - |> Misc.fsort fst - -(*************************************************************************) -(************* Build VMap : gather all vars/sorts for regular vars *******) -(*************************************************************************) - -let update_vmap vm (x, t) = - Misc.maybe_iter begin fun t' -> - asserts (sort_compat x t t') "ERROR: v-sort incompatible %s" (Sy.to_string x) - end (SM.maybe_find x vm); - SM.add x t vm - -let update_vmap_int vm (x, t) = - SM.add x So.t_int vm - -let add_c_var_to_vmap vm c = - let vvl = C.vv_of_reft (C.lhs_of_t c) in - let vvr = C.vv_of_reft (C.rhs_of_t c) in - let _ = asserts (vvl = vvr) "Different VVs in Constr: %d" (C.id_of_t c) in - vdefs_of_env (C.env_of_t c) (C.lhs_of_t c) - |> List.fold_left update_vmap_int vm - -let add_wf_var_to_vmap vm w = - vdefs_of_env (C.env_of_wf w) (C.reft_of_wf w) - |> List.fold_left update_vmap_int vm - -(*************************************************************************) -(************ Build KMap: gather scopes for each kvar from wfs** *********) -(*************************************************************************) - -let check_no_subs wid suks = - asserts - (List.for_all (fst <+> A.Subst.is_empty) suks) - "NonTriv Subst wid=%d" wid - -let join vds vds' = - let xm = SM.of_list vds in - List.filter begin fun (x, t) -> - match SM.maybe_find x xm with - | None -> false - | Some t' -> sort_compat x t t' - end vds' - -let update_kmap vdefs km k : kmap = - match SM.maybe_find k km with - | None -> SM.add k (k, vdefs) km - | Some (_,vdefs') -> SM.add k (k, join vdefs vdefs') km - -let add_wf_to_kmap km wf = - let vdefs = vdefs_of_env (C.env_of_wf wf) (C.reft_of_wf wf) - |> List.filter (snd <+> So.is_func <+> not) - in - C.reft_of_wf wf - |> C.kvars_of_reft - >> check_no_subs (C.id_of_wf wf) - |> List.map snd - |> List.fold_left (update_kmap vdefs) km - -let make_kmap defs : kmap = - defs - |> Misc.map_partial (function Cg.Wfc x -> Some x | _ -> None) - |> List.fold_left add_wf_to_kmap SM.empty - -let mkFreshI, _ = Misc.mk_int_factory () -let mkFresh cid x = - Sy.of_string (Format.sprintf "%s_smt_%d_%d" (Sy.to_string x) cid (mkFreshI ())) -(* >> (fun x' -> Format.printf "fresh_var: %a \n" Sy.print x') - *) - -let fresh_vars env cid es = - let t = Hashtbl.create 17 in - let msg = "fresh_vars: cid = "^(string_of_int cid) in - let es' = List.map begin fun e -> match e with - | (A.Var x, _) -> - if Hashtbl.mem t x then - x |> mkFresh cid >> Hashtbl.add t x |> A.eVar - else let _ = Hashtbl.add t x x in e - | _ -> failwith ("ERROR: " ^ msg) - end es in - let l' = Misc.hashtbl_keys t - |> Misc.flap begin fun x -> - let so = SM.safeFind x env msg in - foreach (Hashtbl.find_all t x) begin fun x' -> - (x', so), A.pEqual ((A.eVar x), (A.eVar x')) - end - end - |> List.split - |> Misc.app_snd A.pAnd in - l', es' - -(*************************************************************************) -(************* Translating using the KMap ********************************) -(*************************************************************************) - -let pred_of_kdef (kf, xts) = - A.pBexp <| A.eApp (kf, List.map (fst <+> A.eVar) xts) - -let soln_of_kmap km k = - [pred_of_kdef <| SM.safeFind k km "soln_of_kmap"] - (* >> (Format.printf "soln_of_kmap: k = %a ps = %a \n" Sy.print k (Misc.pprint_many false " " P.print)) - *) - -let tx_constraint s c = - let cid = C.id_of_t c in - let lps = C.preds_of_lhs_nofilter s c in - let v,t,ras = C.rhs_of_t c in - ras |>: begin function - | C.Conc p -> { lhs = A.pAnd ((A.pNot p) :: lps) - ; rhs = None - ; id = cid } - | ra -> { lhs = A.pAnd lps - ; rhs = (match C.preds_of_refa s ra with - | [p] -> Some p - | _ -> failwith "tx_constraint") - ; id = cid} - end - - |>: begin function - (* Ken needed this tx but it messes up with typeclasses... maybe not - * needed any more? - - | { rhs = Some (A.Bexp (A.App (f, es),_), _) } as c' -> - let (xts, eqp), es' = fresh_vars (C.senv_of_t c) cid es in - let r' = A.pBexp (A.eApp (f, es')) in - (xts, {c' with lhs = A.pAnd [eqp; c'.lhs]; rhs = Some r' }) - *) - | c' -> ([], c') - end - -let tx_defs cfg = - let defs = List.map (fun c -> Cg.Cst c) cfg.Cg.cs ++ - List.map (fun c -> Cg.Wfc c) cfg.Cg.ws in - let km = defs |> make_kmap in - let s = soln_of_kmap km in - let cs = cfg.Cg.cs in - let ws = cfg.Cg.ws in - let xts,cs' = List.split <| Misc.flap (tx_constraint s) cs in - { vars = Misc.flatten xts - ++ (SM.to_list <| List.fold_left add_c_var_to_vmap SM.empty cs) - ++ (SM.to_list <| List.fold_left add_wf_var_to_vmap SM.empty ws) - ; kvars = SM.range km - ; cstrs = cs' - ; consts = SM.to_list cfg.Cg.uops - } - -(*************************************************************************) -(************* Slicing into Single Assertions ****************************) -(*************************************************************************) - - -let split_by_assertion cfg = - let ccs, kcs = Misc.tr_partition C.is_conc_rhs cfg.Cg.cs in - Misc.map (fun c -> { cfg with Cg.cs = c :: kcs }) ccs - -let slice_by_assertion cfg = - let cs' = cfg.Cg.cs - |> Cindex.create cfg.Cg.kuts cfg.Cg.ds - |> Cindex.slice - |> Cindex.to_list - in {cfg with Cg.cs = cs' } - - -(*************************************************************************) -(************* API *******************************************************) -(*************************************************************************) - -let dump_smtlib_indexed (no, cfg) = - let su = Misc.maybe_apply (fun x _ -> "." ^ (string_of_int x)) no "" in - let fo = Constants.get_out_file () in - let fn = fo ^ su ^ ".smt2" in - let _ = Co.bprintflush mydebug ("BEGIN: Dump SMTLIB \n") in - let me = tx_defs cfg in - let _ = Misc.with_out_formatter fn (fun ppf -> F.fprintf ppf "%a" print me) in - let _ = Co.bprintflush mydebug ("DONE: Dump SMTLIB to " ^ fo ^"\n") in - () - -let dump_smtlib_mono cfg = - dump_smtlib_indexed (None, cfg); - exit 1 - -let dump_smtlib_sliced cfg = - cfg |> split_by_assertion - |>: slice_by_assertion - |> Misc.index_from 0 - |>: (Misc.app_fst some) - |> List.iter dump_smtlib_indexed - |> (fun _ -> exit 1) - -let dump_smtlib = dump_smtlib_sliced - diff --git a/external/fixpoint/toSmtLib.mli b/external/fixpoint/toSmtLib.mli deleted file mode 100644 --- a/external/fixpoint/toSmtLib.mli +++ /dev/null @@ -1,86 +0,0 @@ -(* - * Copyright © 2009 The Regents of the University of California. All rights reserved. - * - * Permission is hereby granted, without written agreement and without - * license or royalty fees, to use, copy, modify, and distribute this - * software and its documentation for any purpose, provided that the - * above copyright notice and the following two paragraphs appear in - * all copies of this software. - * - * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY - * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES - * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN - * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY - * OF SUCH DAMAGE. - * - * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, - * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY - * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS - * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION - * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONAst.Symbol. - * - *) - -(* HIDE: all the sigs for defined binders - -type rpred = A.pred -type vdef = Sy.t * So.t -type kdef = Sy.t * vdef list -type cstr = { lhs : A.pred; rhs : rpred option; id : int; } -type smtlib = { - vars : vdef list; - kvars : kdef list; - cstrs : cstr list; - consts : vdef list; -} -type kmap = kdef SM.t -val is_kvar : Sy.t -> bool -val print_brel : F.formatter -> A.brel -> unit -val print_bop : F.formatter -> A.bop -> unit -val print_pred : F.formatter -> A.pred -> unit -val print_expr_app : Sy.t -> F.formatter -> A.expr list -> unit -val print_expr : F.formatter -> A.expr -> unit -val print_sort_base : Format.formatter -> So.t -> unit -val print_sort : Format.formatter -> So.t -> unit -val print_fun_sorts : Format.formatter -> So.t list -> unit -val print_vdef : Format.formatter -> Sy.t * So.t -> unit -val print_const : Format.formatter -> Sy.t * So.t -> unit -val groupConsts : ('a * 'b) list -> ('b * 'a list) list -val print_distinct : Format.formatter -> So.t * Sy.t list -> unit -val print_kdef : Format.formatter -> Sy.t * ('a * So.t) list -> unit -val print_rhs : Format.formatter -> A.pred option -> unit -val binds_of_cstr : 'a SM.t -> cstr -> (SM.key * 'a) list -val print_cstr : So.t SM.t -> Format.formatter -> cstr -> unit -val print : Format.formatter -> smtlib -> unit -val sort_compat : 'a -> So.t -> So.t -> bool -val vdefs_of_env : C.envt -> C.reft -> (Ast.Symbol.t * Ast.Sort.t) list -val update_vmap : So.t SM.t -> Sy.t * So.t -> So.t SM.t -val update_vmap_int : So.t SM.t -> SM.key * 'a -> So.t SM.t -val add_c_var_to_vmap : So.t SM.t -> C.t -> So.t SM.t -val add_wf_var_to_vmap : So.t SM.t -> C.wf -> So.t SM.t -val check_no_subs : int -> (A.Subst.t * 'a) list -> unit -val join : (SM.key * So.t) list -> (SM.key * So.t) list -> (SM.key * So.t) list -val update_kmap : vdef list -> kdef SM.t -> SM.key -> kmap -val add_wf_to_kmap : kdef SM.t -> C.wf -> kdef SM.t -val make_kmap : Cg.deft list -> kmap -val mkFreshI : unit -> int -val mkFresh : int -> Sy.t -> Sy.t -val fresh_vars : 'a SM.t -> int -> A.expr list -> ((Sy.t * 'a) list * A.pred) * A.expr list -val pred_of_kdef : A.Symbol.t * (A.Symbol.t * 'a) list -> A.pred -val soln_of_kmap : (A.Symbol.t * (A.Symbol.t * 'a) list) SM.t -> SM.key -> A.pred list -val tx_constraint : C.soln -> C.t -> ('a list * cstr) list -val tx_defs : 'a Cg.cfg -> smtlib -val split_by_assertion : 'a Cg.cfg -> 'a Cg.cfg list -val slice_by_assertion : 'a Cg.cfg -> 'a Cg.cfg -val dump_smtlib_indexed : int option * 'a Cg.cfg -> unit -val dump_smtlib_mono : 'a Cg.cfg -> 'b -val dump_smtlib_sliced : 'a Cg.cfg -> 'b -val dump_smtlib : 'a Cg.cfg -> 'b - -*) - -(* val render : Format.formatter -> FixConfig.deft list -> unit -val render : Format.formatter -> 'a FixConfig.cfg -> unit -*) -val dump_smtlib : 'a FixConfig.cfg -> unit - diff --git a/external/fixpoint/toplevel.ml b/external/fixpoint/toplevel.ml deleted file mode 100644 --- a/external/fixpoint/toplevel.ml +++ /dev/null @@ -1,48 +0,0 @@ -module BS = BNstats -module SM = Ast.Symbol.SMap -module Co = Constants -module C = FixConstraint -module F = Format -module Misc = FixMisc open Misc.Ops - - -(* -let parse_string str = - let lb = Lexing.from_string str in - ArithParser.aexpr ArithLexer.token lb - -let token_list_of_string s = - let lb = Lexing.from_string s in - let rec helper l = - try - let t = ArithLexer.token lb in - if t = ArithParser.EOF then List.rev l else helper (t::l) - with _ -> List.rev l - in helper [] - -let eval_string env str = ArithInterpreter.eval env (parse_string str) -*) - -(*****************************************************************) -(********************* Command line options **********************) -(*****************************************************************) - -let parse f = - let _ = Errorline.startFile f in - let ic = open_in f in - let rv = Lexing.from_channel ic |> FixParse.defs FixLex.token in - let _ = close_in ic in - rv - -let read_inputs usage = - Co.bprintflush true "\n\n"; - Co.bprintflush true "========================================================\n"; - Co.bprintflush true "© Copyright 2009 Regents of the University of California.\n"; - Co.bprintflush true "All Rights Reserved.\n"; - Co.bprintflush true "========================================================\n"; - Co.bprintflush false (Sys.argv |> Array.to_list |> String.concat " "); - Co.bprintflush false "\n========================================================\n"; - let fs = ref [] in - let _ = Arg.parse Co.arg_spec (fun s -> fs := s::!fs) usage in - let fq = !fs |> BS.time "parse" (Misc.flap parse) |> FixConfig.create in - (!fs, fq) diff --git a/external/fixpoint/toplevel.mli b/external/fixpoint/toplevel.mli deleted file mode 100644 --- a/external/fixpoint/toplevel.mli +++ /dev/null @@ -1,25 +0,0 @@ -(* - * Copyright © 2009 The Regents of the University of California. All rights reserved. - * - * Permission is hereby granted, without written agreement and without - * license or royalty fees, to use, copy, modify, and distribute this - * software and its documentation for any purpose, provided that the - * above copyright notice and the following two paragraphs appear in - * all copies of this software. - * - * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY - * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES - * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN - * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY - * OF SUCH DAMAGE. - * - * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, - * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY - * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS - * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION - * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONAst.Symbol. - * - *) - -val read_inputs : string -> (string list * SolverArch.qbind FixConfig.cfg) - diff --git a/external/fixpoint/tpGen.ml b/external/fixpoint/tpGen.ml deleted file mode 100644 --- a/external/fixpoint/tpGen.ml +++ /dev/null @@ -1,574 +0,0 @@ -(* - * Copyright © 2008 The Regents of the University of California. All rights reserved. - * - * Permission is hereby granted, without written agreement and without - * license or royalty fees, to use, copy, modify, and distribute this - * software and its documentation for any purpose, provided that the - * above copyright notice and the following two paragraphs appear in - * all copies of this software. - * - * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY - * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES - * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN - * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY - * OF SUCH DAMAGE. - * - * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, - * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY - * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS - * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION - * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. - *) - -(* This file is part of the LiquidC Project *) - -module H = Hashtbl -module F = Format -module Co = Constants -module BS = BNstats -module A = Ast -module Sy = A.Symbol -module So = A.Sort -module SM = Sy.SMap -module P = A.Predicate -module E = A.Expression -module Misc = FixMisc -module SSM = Misc.StringMap -module SMT = SmtZ3.SMTZ3 - -open Misc.Ops -open ProverArch - -let mydebug = false - -module MakeProver(SMT : SMTSOLVER) : PROVER = struct - - module Th = Theories.MakeTheory(SMT) - -(*************************************************************************) -(*************************** Type Definitions ****************************) -(*************************************************************************) - -type decl = Vbl of (Sy.t * So.t) | Fun of Sy.t * int | Barrier - -type var_ast = Const of SMT.ast | Bound of int * So.t - -type t = { - c : SMT.context; - tint : SMT.sort; - treal : SMT.sort; - tbool : SMT.sort; - vart : (decl, var_ast) H.t; - funt : (decl, SMT.fun_decl) H.t; - tydt : (So.t, SMT.sort) H.t; - mutable vars : decl list ; - mutable bnd : int; - thy_sortm : (So.tycon, Th.sortDef) H.t; - thy_symm : (Sy.t, Th.appDef) H.t; -} - -(*************************************************************************) -(************************** Pretty Printing ******************************) -(*************************************************************************) - -let pprint_decl ppf = function - | Vbl (x, t) -> F.fprintf ppf "%a:%a" Sy.print x So.print t - | Barrier -> F.fprintf ppf "----@." - | Fun (s, i) -> F.fprintf ppf "%a[%i]" Sy.print s i - -let dump_decls me = - F.printf "Vars: %a" (Misc.pprint_many true "," pprint_decl) me.vars - -(************************************************************************) -(***************************** Stats Counters **************************) -(************************************************************************) - -let nb_set = ref 0 -let nb_query = ref 0 - -(************************************************************************) -(********************** Misc. Constants *********************************) -(************************************************************************) - -let div_n = Sy.of_string "_DIV" -let tag_n = Sy.of_string "_TAG" -let mul_n = Sy.of_string "_MUL" - -let axioms = [] - -(* TBD these are related to ML and should be in DSOLVE, not here *) -let builtins = - SM.empty - |> SM.add tag_n (So.t_func 0 [So.t_obj; So.t_int]) - |> SM.add div_n (So.t_func 0 [So.t_int; So.t_int; So.t_int]) - |> SM.add mul_n (So.t_func 0 [So.t_int; So.t_int; So.t_int]) - -let select_t = So.t_func 0 [So.t_int; So.t_int] - -let mk_select, is_select = - let ss = "SELECT" in - (fun f -> Sy.to_string f |> (^) (ss ^ "_") |> Sy.of_string), - (fun s -> Sy.to_string s |> Misc.is_prefix ss) - -let fresh = - let x = ref 0 in - fun v -> incr x; (v^(string_of_int !x)) - -(*************************************************************************) -(********************** Typing *******************************************) -(*************************************************************************) - -let varSort env s = - try SM.find s env with Not_found -> - failure "ERROR: varSort cannot type %s in TPZ3 \n" (Sy.to_string s) - -let funSort env s = - try SM.find s builtins with Not_found -> - try SM.find s env with Not_found -> - if is_select s then select_t else - failure "ERROR: could not type function %s in TPZ3 \n" (Sy.to_string s) - -let rec z3Type me t = - Misc.do_memo me.tydt begin fun t -> - if So.is_bool t then me.tbool else - if So.is_int t then me.tint else - if So.is_real t then me.treal else - Misc.maybe_default (z3TypeThy me t) me.tint - (* match z3TypeThy me t with - | Some t' -> t' - | None -> me.tint *) - end t t - -and z3TypeThy me t = - match So.app_of_t t with - | Some (c, ts) when H.mem me.thy_sortm c -> - let def = H.find me.thy_sortm c in - let zts = List.map (z3Type me) ts in - Some (Th.mk_thy_sort def me.c zts) - | _ -> - None - -(***********************************************************************) -(********************** Identifiers ************************************) -(***********************************************************************) - -let getVbl env x = Vbl (x, varSort env x) - -let z3Var_memo me env x = - let vx = getVbl env x in - Misc.do_memo me.vart - (fun () -> - let t = x |> varSort env |> z3Type me in - let sym = fresh "z3v" - (* >> F.printf "z3Var_memo: %a :-> %s\n" Sy.print x *) - |> SMT.stringSymbol me.c in - let rv = Const (SMT.var me.c sym t) in - let _ = me.vars <- vx :: me.vars in - rv) - () vx - -let z3Var me env x = - match BS.time "z3Var memo" (z3Var_memo me env) x with - | Const v -> v - | Bound (b, t) -> SMT.boundVar me.c (me.bnd - b) (z3Type me t) - - -let z3Fun me env p t k = - Misc.do_memo me.funt begin fun _ -> - match So.func_of_t t with - | None -> assertf "MATCH ERROR: z3ArgTypes" - | Some (_, ts, rt) -> - let ts = List.map (z3Type me) ts in - let rt = z3Type me rt in - let cf = SMT.stringSymbol me.c (fresh "z3f") in - let rv = SMT.funcDecl me.c cf (Array.of_list ts) rt in - let _ = me.vars <- (Fun (p,k))::me.vars in - rv - end () (Fun (p, k)) - -(**********************************************************************) -(********************** Pred/Expr Transl ******************************) -(**********************************************************************) - -let opt_to_string p = function - | None -> "none" - | Some x -> p x - -exception Z3RelTypeError - -let pred_sort env p = - A.sortcheck_pred Theories.is_interp (Misc.flip SM.maybe_find env) p - -let app_sort env tyo f es = - A.sortcheck_app Theories.is_interp (Misc.flip SM.maybe_find env) tyo f es -(* >> (fun so -> let _ = F.printf "app_sort [f = %a es = %a] = %a\n" - Sy.print f - (Misc.pprint_many false ", " E.print) es - (Misc.pprint_maybe So.print) (Misc.maybe_map snd so) - in - () - ) - *) - -let expr_sort env = function - | A.App (f, es), _ -> Misc.maybe_map snd <| app_sort env None f es - | e -> A.sortcheck_expr Theories.is_interp (Misc.flip SM.maybe_find env) e - - -let z3Bind me env x t = - let vx = Vbl (x, varSort env x) in - me.bnd <- me.bnd + 1; - H.replace me.vart vx (Bound (me.bnd, t)); - me.vars <- vx :: me.vars; - SMT.stringSymbol me.c (fresh "z3b") - -let rec z3Rel me env (e1, r, e2) = - let p = A.pAtom (e1, r, e2) in - let ok = pred_sort env p in - (* let _ = F.printf "z3Rel: e = %a, res = %b \n" P.print p ok in - let _ = F.print_flush () in *) - - if ok then - z3Rel_cast me env (e1, r, e2) - (* z3Rel_real me env (e1, r, e2) *) - (* SMT.mkRel me.c r (z3Exp me env e1) (z3Exp me env e2) *) - else begin - SM.iter (fun s t -> F.printf "@[%a :: %a@]@." Sy.print s So.print t) env; - F.printf "@[%a@]@.@." P.print (A.pAtom (e1, r, e2)); - F.print_flush (); - raise Z3RelTypeError - end - - - - -and z3Rel_cast me env = function - | (e1, A.Eq, e2) -> begin - let (t1o, t2o) = (expr_sort env e1, expr_sort env e2) in - (* - let _ = F.printf "z3Rel_cast: t1o = %s, t2o = %s \n" - (opt_to_string So.to_string t1o) - (opt_to_string So.to_string t2o) in - *) - match (t1o, t2o) with - | (Some t , None ) -> z3Rel_real me env (e1, A.Eq, A.eCst (e2, t)) - | (None , Some t) -> z3Rel_real me env (A.eCst (e1, t), A.Eq, e2) - | (_ , _ ) -> z3Rel_real me env (e1, A.Eq, e2) - end - | (e1, r, e2) -> - z3Rel_real me env (e1, r, e2) - -and z3Rel_real me env (e1, r, e2) = - (* let _ = F.printf "z3Rel_real: e1 = %s, e2 = %s \n" - (E.to_string e1) - (E.to_string e2) in - *) - SMT.mkRel me.c r (z3Exp me env e1) (z3Exp me env e2) - -and z3App me env p zes = - let t = funSort env p in - let cf = z3Fun me env p t (List.length zes) in - SMT.mkApp me.c cf zes - -and z3AppThy me env def tyo f es = - (* match A.sortcheck_app Theories.is_interp (Misc.flip SM.maybe_find env) tyo f es with *) - match app_sort env tyo f es with - | Some (s, t) -> - let zts = So.sub_args s |> List.map (snd <+> z3Type me) in - let zes = es |> List.map (z3Exp me env) in - Th.mk_thy_app def me.c zts zes - | None -> - A.eApp (f, es) - |> E.to_string - |> assertf "z3AppThy: sort error %s" - -and z3Div me env = function - | (e1, e2) when !Co.uif_divide -> - z3App me env div_n (List.map (z3Exp me env) [e1; e2]) - | (e1, e2) -> - SMT.mkDiv me.c (z3Exp me env e1) (z3Exp me env e2) - -and z3Mul me env = function - | ((A.Con (A.Constant.Int i), _), e) - | (e, (A.Con (A.Constant.Int i), _)) -> - SMT.mkMul me.c (SMT.mkInt me.c i me.tint) (z3Exp me env e) - | (e1, e2) when !Co.uif_multiply -> - z3App me env mul_n (List.map (z3Exp me env) [e1; e2]) - | (e1, e2) -> - SMT.mkMul me.c (z3Exp me env e1) (z3Exp me env e2) - -and z3Con me env = function - | A.Constant.Int i -> - SMT.mkInt me.c i me.tint - | A.Constant.Real i -> - SMT.mkReal me.c i me.treal - | A.Constant.Lit (l, t) -> - SMT.mkLit me.c l (z3Type me t) - -and z3Exp me env = function - | A.Con c, _ -> - z3Con me env c - | A.Var s, _ -> - z3Var me env s - | A.Cst ((A.App (f, es), _), t), _ when (H.mem me.thy_symm f) -> - z3AppThy me env (H.find me.thy_symm f) (Some t) f es - | A.App (f, es), _ when (H.mem me.thy_symm f) -> - z3AppThy me env (H.find me.thy_symm f) None f es - | A.App (f, es), _ -> - z3App me env f (List.map (z3Exp me env) es) - | A.Bin (e1, A.Plus, e2), _ -> - SMT.mkAdd me.c (z3Exp me env e1) (z3Exp me env e2) - | A.Bin (e1, A.Minus, e2), _ -> - SMT.mkSub me.c (z3Exp me env e1) (z3Exp me env e2) - | A.Bin((A.Con (A.Constant.Int n1), _), A.Times, (A.Con (A.Constant.Int n2), _)),_ -> - SMT.mkInt me.c (n1 * n2) me.tint - | A.Bin (e1, A.Times, e2), _ -> - z3Mul me env (e1, e2) - | A.Bin (e1, A.Div, e2), _ -> - z3Div me env (e1, e2) - | A.Bin (e, A.Mod, (A.Con (A.Constant.Int i), _)), _ -> - SMT.mkMod me.c (z3Exp me env e) (SMT.mkInt me.c i me.tint) - | A.Bin (e1, A.Mod, e2), _ -> - SMT.mkMod me.c (z3Exp me env e1) (z3Exp me env e2) - | A.Ite (e1, e2, e3), _ -> - SMT.mkIte me.c (z3Pred me env e1) (z3Exp me env e2) (z3Exp me env e3) - - | A.Fld (f, e), _ -> - z3App me env (mk_select f) [z3Exp me env e] (** REQUIRES: disjoint field names *) - | A.Cst (e, _), _ -> - z3Exp me env e - | e -> - assertf "z3Exp: Cannot Convert %s!" (E.to_string e) - -and z3Pred me env = function - | A.True, _ -> - SMT.mkTrue me.c - | A.False, _ -> - SMT.mkFalse me.c - | A.Not p, _ -> - SMT.mkNot me.c (z3Pred me env p) - | A.And ps, _ -> - SMT.mkAnd me.c (List.map (z3Pred me env) ps) - | A.Or ps, _ -> - SMT.mkOr me.c (List.map (z3Pred me env) ps) - | A.Imp (p1, p2), _ -> - SMT.mkImp me.c (z3Pred me env p1) (z3Pred me env p2) - | A.Iff (p1, p2), _ -> - SMT.mkIff me.c (z3Pred me env p1) (z3Pred me env p2) - | A.Atom (e1, r, e2), _ -> - z3Rel me env (e1, r, e2) - | A.Bexp e, _ -> - let a = z3Exp me env e in - let s2 = E.to_string e in - let so = match expr_sort env e with - | Some so -> so - | _ -> let _ = F.printf "No type for %s" (E.to_string e) in assert false - in - let sos = So.to_string so in - (* let s1 = SMT.astString me.c a in - let _ = asserts (SMT.isBool me.c a) - "Bexp is not bool (e = %s)! z3=%s, fix=%s, sort=%s" - (E.to_string e) s1 s2 sos - in *) - a - - | A.Forall (xts, p), _ -> - let (xs, ts) = List.split xts in - let zargs = Array.of_list (List.map2 (z3Bind me env) xs ts) in - let zts = Array.of_list (List.map (z3Type me) ts) in - let rv = SMT.mkAll me.c zts zargs (z3Pred me env p) in - let _ = me.bnd <- me.bnd - (List.length xs) in - rv - | p -> - assertf "z3Pred: Cannot Convert %s!" (P.to_string p) - - - -let z3Pred me env p = - try - let p = p in (*BS.time "fixdiv" A.fixdiv p in *) - BS.time "z3Pred" (z3Pred me env) p - with ex -> (F.printf "z3Pred: error converting %a\n" P.print p) ; raise ex - -(***************************************************************************) -(***************** Binder/Stack Management *********************************) -(***************************************************************************) - -let rec vpop (cs,s) = - match s with - | [] -> (cs,s) - | Barrier :: t -> (cs,t) - | h :: t -> vpop (h::cs,t) - -let clean_decls me = - let cs, vars' = vpop ([],me.vars) in - let _ = me.vars <- vars' in - List.iter begin function - | Barrier -> failure "ERROR: TPZ3-cleanDecls" - | Vbl _ as d -> H.remove me.vart d - | Fun _ as d -> H.remove me.funt d - end cs - -let handle_vv me env vv = - H.remove me.vart (getVbl env vv) (* RJ: why are we removing this? *) - - -(************************************************************************) -(********************************* API **********************************) -(************************************************************************) - -let create_theories () = - Th.theories () - |> (Misc.hashtbl_of_list_with Th.sort_name <**> Misc.hashtbl_of_list_with Th.sym_name) - -let assert_distinct_constants me env = function [] -> () | cs -> - cs |> Misc.kgroupby (varSort env) - |> List.iter begin fun (_, xs) -> - xs >> Co.bprintf mydebug "Distinct Constants: %a \n" (Misc.pprint_many false ", " Sy.print) - |> List.map (z3Var me env) - |> SMT.assertDistinct me.c - end - -let prep_preds me env ps = - let ps = List.rev_map (z3Pred me env) ps in - let _ = me.vars <- Barrier :: me.vars in - ps - -let valid me p = - SMT.bracket me begin fun _ -> - SMT.assertPreds me [SMT.mkNot me p]; - BS.time "unsat" SMT.unsat me - end - -(* API *) -let set_filter (me: t) (env: So.t SM.t) (vv: Sy.t) ps qs = - let _ = ignore(nb_set += 1); ignore (nb_query += List.length qs) in - let _ = handle_vv me env vv in - let zps = prep_preds me env ps in (* DO NOT PUSH INSIDE SMT.bracket or z3 blocks postests/ll3.c *) - SMT.bracket me.c begin fun _ -> - let _ = SMT.assertPreds me.c zps in - let tqs, fqs = List.partition (snd <+> P.is_tauto) qs in - let fqs = fqs |> List.rev_map (Misc.app_snd (z3Pred me env)) - |> Misc.filter (snd <+> valid me.c) in - let _ = clean_decls me in - (List.map fst tqs) ++ (List.map fst fqs) - end - -(* API *) -let print_stats ppf me = - SMT.print_stats ppf (); - F.fprintf ppf "TP stats: sets=%d, queries=%d, count=%d\n" - !nb_set !nb_query (List.length me.vars) - -(*************************************************************************) -(****************** Unsat Core for CEX generation ************************) -(*************************************************************************) - -let mk_prop_var me pfx i : SMT.ast = - i |> string_of_int - |> (^) pfx - |> SMT.stringSymbol me.c - |> Misc.flip (SMT.var me.c) me.tbool - -let mk_prop_var_idx me ipa : (SMT.ast array * (SMT.ast -> 'a option)) = - let va = Array.mapi (fun i _ -> mk_prop_var me "uc_p_" i) ipa in - let vm = va - |> Array.map (SMT.astString me.c) - |> Misc.array_to_index_list - |> List .map Misc.swap - |> SSM.of_list in - let f z = SSM.maybe_find (SMT.astString me.c z) vm - |> Misc.maybe_map (fst <.> Array.get ipa) in - (va, f) - -let mk_pa me p2z pfx ics = - ics |> List.map (Misc.app_snd p2z) - |> Array.of_list - |> Array.mapi (fun i (x, p) -> (x, p, mk_prop_var me pfx i)) - -(* API *) -let unsat_core me env bgp ips = - let _ = H.clear me.vart in - let p2z = (*A.fixdiv <+>*) z3Pred me env in - let ipa = ips |> List.map (Misc.app_snd p2z) |> Array.of_list in - let va, f = mk_prop_var_idx me ipa in - let zp = ipa |> Array.mapi (fun i (_, p) -> SMT.mkIff me.c va.(i) p) - |> Array.to_list - |> (++) [p2z bgp] - |> SMT.mkAnd me.c in - SMT.bracket me.c begin fun _ -> - let _ = SMT.assertPreds me.c [zp] in - let n = Array.length va in - let va' = Array.map id va in - failwith "SMT-UNSAT-CORE-TODO" - (************************************ - match SMT.check_assumptions me.c va n va' with - | (Z3.L_FALSE, m,_, n, ucore) - -> Array.map f ucore |> Array.to_list |> Misc.map_partial id - | _ -> [] - ************************************) - end - -let contra me p = - SMT.bracket me begin fun _ -> - SMT.assertPreds me [p]; - BS.time "unsat" SMT.unsat me - end - -(* API *) -let is_contra me env = z3Pred me env <+> contra me.c - -(* API *) -let unsat_suffix me env p ps = - let _ = if SMT.unsat me.c then assertf "ERROR: unsat_suffix" in - SMT.bracket me.c begin fun _ -> - let rec loop j = function [] -> None | zp' :: zps' -> - SMT.assertPreds me.c [zp']; - if SMT.unsat me.c then Some j else loop (j-1) zps' - in loop (List.length ps) (List.map (z3Pred me env) (p :: List.rev ps)) - end - -(***********************************************************************) -(******** Prover Object ************************************************) -(***********************************************************************) - -(* API *) -let create ts env ps consts = - let _ = asserts (ts = []) "ERROR: TPGEN-create non-empty sorts!" in - let c = SMT.mkContext [|("MODEL", "false"); ("MODEL_PARTIAL", "true")|] in - let som, sym = create_theories () in - let me = { c = c; - tint = SMT.mkIntSort c; - treal = SMT.mkRealSort c; - tbool = SMT.mkBoolSort c; - tydt = H.create 37; - vart = H.create 37; - funt = H.create 37; - vars = []; - bnd = 0; - thy_sortm = som; - thy_symm = sym - } - in - let _ = List.iter (z3Pred me env <+> SMT.assertAxiom me.c) (axioms ++ ps) in - let _ = assert_distinct_constants me env consts in - me - -class tprover ts env ps consts : prover = - object (self) - val me = create ts env ps consts - method interp_syms = Theories.interp_syms - method set_filter : 'a. Ast.Sort.t Ast.Symbol.SMap.t - -> Ast.Symbol.t - -> Ast.pred list - -> ('a * Ast.pred) list - -> 'a list - = set_filter me - method print_stats = fun ppf -> print_stats ppf me - method is_contra = is_contra me - method unsat_suffix = unsat_suffix me - end - -let mkProver ts env ps consts = new tprover ts env ps consts - -end diff --git a/external/fixpoint/tpNull.ml b/external/fixpoint/tpNull.ml deleted file mode 100644 --- a/external/fixpoint/tpNull.ml +++ /dev/null @@ -1,39 +0,0 @@ -(* - * Copyright © 2008 The Regents of the University of California. All rights reserved. - * - * Permission is hereby granted, without written agreement and without - * license or royalty fees, to use, copy, modify, and distribute this - * software and its documentation for any purpose, provided that the - * above copyright notice and the following two paragraphs appear in - * all copies of this software. - * - * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY - * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES - * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN - * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY - * OF SUCH DAMAGE. - * - * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, - * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY - * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS - * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION - * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. - *) - -open FixMisc.Ops - -module Mem : ProverArch.PROVER = TpGen.MakeProver(SmtZ3.SMTZ3) -module Smt : ProverArch.PROVER = TpGen.MakeProver(SmtLIB2.SMTLib2) - -let mydebug = false - -let create ts env ps cs - = let xxx = Constants.get_smt2_file () in - match !Constants.smt_solver with - | None -> - Constants.bprintflush mydebug "\nUSING z3 bindings \n"; - Mem.mkProver ts env ps cs - | Some s -> - Constants.bprintflush mydebug ("\nUSING SMTLIB bindings -- " ^ xxx ^ " -- with " ^ s ^ "\n"); - Smt.mkProver ts env ps cs - diff --git a/external/misc/bNstats.ml b/external/misc/bNstats.ml deleted file mode 100644 --- a/external/misc/bNstats.ml +++ /dev/null @@ -1,118 +0,0 @@ -(* - * - * Copyright (c) 2001 by - * George C. Necula necula@cs.berkeley.edu - * Scott McPeak smcpeak@cs.berkeley.edu - * Wes Weimer weimer@cs.berkeley.edu - * - * All rights reserved. Permission to use, copy, modify and distribute - * this software for research purposes only is hereby granted, - * provided that the following conditions are met: - * 1. XSRedistributions of source code must retain the above copyright notice, - * this list of conditions and the following disclaimer. - * 2. Redistributions in binary form must reproduce the above copyright notice, - * this list of conditions and the following disclaimer in the documentation - * and/or other materials provided with the distribution. - * 3. The name of the authors may not be used to endorse or promote products - * derived from this software without specific prior written permission. - * - * DISCLAIMER: - * THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR - * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES - * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. - * IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT, - * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, - * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS - * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON - * ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT - * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF - * THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - - (* A hierarchy of timings *) -type t = { name : string; - mutable time : float; - mutable sub : t list} - - (* Create the top level *) -let top = { name = "TOTAL"; - time = 0.0; - sub = []; } - - (* The stack of current path through - * the hierarchy. The first is the - * leaf. *) -let current : t list ref = ref [top] - -let reset () = top.sub <- [] - -let do_time = ref true - -let dont_time () = do_time := false - -let print chn msg = - (* Total up *) - top.time <- List.fold_left (fun sum f -> sum +. f.time) 0.0 top.sub; - let rec prTree ind node = - Printf.fprintf chn "%s%-20s %6.3f s\n" - (String.make ind ' ') node.name node.time ; - List.iter (prTree (ind + 2)) node.sub - in - Printf.fprintf chn "%s" msg; - List.iter (prTree 0) [ top ] - -let time str f arg = - (* Find the right stat *) - let stat : t = - let curr = match !current with h :: _ -> h | _ -> assert false in - let rec loop = function - h :: _ when h.name = str -> h - | _ :: rest -> loop rest - | [] -> - let nw = {name = str; time = 0.0; sub = []} in - curr.sub <- nw :: curr.sub; - nw - in - loop curr.sub - in - let oldcurrent = !current in - current := stat :: oldcurrent; - let start = (Unix.times ()).Unix.tms_utime in - let _ = if str == "interp" then Printf.printf "interp start = %6.3f\n" start in - let res = - try (f arg) with - x -> (let finish = Unix.times () in - let diff = finish.Unix.tms_utime -. start in - let _ = if str == "interp" then Printf.printf "interp elapsed = %6.3f\n" diff in - stat.time <- stat.time +. (diff); - current := oldcurrent; - raise x) (* Pop the current stat *) - in - let finish = Unix.times () in - let diff = finish.Unix.tms_utime -. start in - let _ = if str == "interp" then Printf.printf "interp elapsed = %6.3f\n" diff in - stat.time <- stat.time +. (diff); - current := oldcurrent; - res - - -let time str f arg = if !do_time then time str f arg else f arg - -let print chn msg = if !do_time then print chn msg else () - - - - - - - - - - - - - - - - diff --git a/external/misc/bNstats.mli b/external/misc/bNstats.mli deleted file mode 100644 --- a/external/misc/bNstats.mli +++ /dev/null @@ -1,48 +0,0 @@ -(* - * - * Copyright (c) 2001 by - * George C. Necula necula@cs.berkeley.edu - * Scott McPeak smcpeak@cs.berkeley.edu - * Wes Weimer weimer@cs.berkeley.edu - * - * All rights reserved. Permission to use, copy, modify and distribute - * this software for research purposes only is hereby granted, - * provided that the following conditions are met: - * 1. XSRedistributions of source code must retain the above copyright notice, - * this list of conditions and the following disclaimer. - * 2. Redistributions in binary form must reproduce the above copyright notice, - * this list of conditions and the following disclaimer in the documentation - * and/or other materials provided with the distribution. - * 3. The name of the authors may not be used to endorse or promote products - * derived from this software without specific prior written permission. - * - * DISCLAIMER: - * THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR - * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES - * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. - * IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT, - * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, - * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS - * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON - * ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT - * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF - * THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - -(** Utilities for maintaining timing statistics *) - -val dont_time : unit -> unit - -(** Reset all the timings *) -val reset : unit -> unit - -(** Time a function and associate the time with the given string. If some - timing information is already associated with that string, then accumulate - the times. If this function is invoked within another timed function then - you can have a hierarchy of timings *) -val time : string -> ('a -> 'b) -> 'a -> 'b - -(** Print the current stats preceeded by a message *) -val print : out_channel -> string -> unit - diff --git a/external/misc/constants.ml b/external/misc/constants.ml deleted file mode 100644 --- a/external/misc/constants.ml +++ /dev/null @@ -1,441 +0,0 @@ -(* - * Copyright © 2009 The Regents of the University of California. - * All rights reserved. Permission is hereby granted, without written - * agreement and without - * license or royalty fees, to use, copy, modify, and distribute this - * software and its documentation for any purpose, provided that the - * above copyright notice and the following two paragraphs appear in - * all copies of this software. - * - * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY - * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES - * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN - * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY - * OF SUCH DAMAGE. - * - * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, - * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY - * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS - * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION - * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. - *) - -open FixMisc.Ops -module SS = FixMisc.StringSet - -(******* This module contains globals representing "flags" **************) -let lib_path = Sys.argv.(0) |> Filename.dirname |> ref -let annotsep_name = "\n\n=+=\n\n" -let global_name = "GLOBAL" - - -let file: string option ref = ref None (* last commandline param*) -let csolve_file_prefix = ref "csolve" (* where to find/place csolve-related files *) -let safe = ref false (* -safe *) -let manual = ref false (* -manual *) -let out_file_name = ref "out" (* -out *) -(* -let save_file = ref "out.fq" (* -save *) -*) -let save_slice = ref false (* -save-slice *) -let dump_ref_constraints= ref false (* -drconstr *) -let ctypes_only = ref false (* -ctypes *) -let verbose_level = ref 0 (* -v *) -let inccheck = ref SS.empty (* -inccheck *) -let cex = ref false (* -counterexamples *) -let shortannots = ref true (* -shortannots *) -let strictsortcheck = ref false (* -strictsortcheck *) -let latex_file: string option ref = ref None (* translate to LaTeX *) -let armc_file: string option ref = ref None (* translate to ARMC *) -let horn_file: string option ref = ref None (* translate to Horn clauses *) -let raw_horn_file: string option ref = ref None (* translate to raw Horn clauses *) -let q_armc_file: string option ref = ref None (* OBSOLETE translate to Q'ARMC file *) -let dot_file: string option ref = ref None (* translate to dot file *) -let purify_function_application = ref true (* replace fun-terms by existentially quantified variables *) -let z3_timeout = ref 25 - -let fastscalar = ref false (* -fastscalar *) -let vannots = ref true (* -noannots *) -let minquals = ref true (* -allquals *) -let ptag = ref true (* -ptag *) -let genspec = ref false (* -genspec *) -let simplify_t = ref false (* simplify and prune vacuous FixConstraint.t constraints *) -let copyprop = ref true (* perform copyprop to eliminate tempvars *) -let root = ref "" (* root function *) -let refine_sort = ref false (* -refinesort *) -let sorted_quals = ref false (* -sortedquals *) -let true_unconstrained = ref true (* -true_unconstrained *) -let do_nothing = ref false (* -nop *) -let smt_solver = ref (Some "z3") (* -smtsolver [z3, yices, cvc4, ...] *) -let dump_imp = ref false (* -imp *) -let dump_smtlib = ref false (* -smtlib *) -let dump_simp = ref "" (* -simp *) -let prune_live = ref false (* -prunelive *) -let print_nontriv = ref false (* -print_nontriv *) -let heapify_nonarrays = ref true (* heapify all stack variables *) -let timeout = ref (-1) -let lfp = ref true (* -nolfp *) -let slice = ref true (* -slice *) -let no_lib_hquals = ref false (* -no-lib-hquals *) -let gen_qual_sorts = ref true (* -no-gen-qual-sorts *) -let web_demo = ref false (* -web-demo *) -let simple = ref true (* -simple *) -let bit_theory = ref true (* -bit-theory *) -let set_theory = ref true (* -set-theory *) -let map_theory = ref true (* -map-theory *) -let ueq_all_sorts = ref false (* -ueq-all-sorts *) - -(* JHALA: what do these do ? *) -let psimple = ref true (* -psimple *) -let dump_graph = ref false (* -dgraph :: this probably caused the dsolve solver to dump the constraint graph *) -let dropcalls = ref false (* -dropcalls *) -let adjdeps = ref true (* -origdeps *) -let check_is = ref false (* -check-indices *) -let trace_scalar = ref false (* -trace-scalar *) -let prune_index = ref false (* -prune-index *) -let uif_multiply = ref true (* -no-uif-multiply *) -let uif_divide = ref true (* -no-uif-multiply *) - -(****************************************************************) -(************* Output levels ************************************) -(****************************************************************) - -(* verbosity levels by purpose *) -let ol_always = 0 -let ol_solve_error = 1 -let ol_warning = 1 -let ol_solve_master = 2 -let ol_solve_stats = 2 -let ol_timing = 2 -let ol_warn_mlqs = 3 -let ol_normalized = 3 -let ol_finals = 3 -let ol_ctypes = 3 -let ol_dquals = 4 -let ol_unique_names = 5 (* must be > ol_dquals *) -let ol_solve = 10 -let ol_refine = 11 -let ol_scc = 12 -let ol_dump_env = 10 -let ol_axioms = 5 -let ol_dump_prover = 20 -let ol_verb_constrs = 21 -let ol_dump_wfs = 22 -let ol_dump_meas = 30 -let ol_dump_quals = 50 -let ol_insane = 200 - -let verb_stack = ref [] -let ck_olev l = l <= !verbose_level -let null_formatter = Format.make_formatter (fun a b c -> ()) ignore -let nprintf a = Format.fprintf null_formatter a -let cprintf l = if ck_olev l then Format.printf else nprintf -let ecprintf l = if ck_olev l then Format.eprintf else nprintf -let fcprintf ppf l = if ck_olev l then Format.fprintf ppf else nprintf -let icprintf printer l ppf = if ck_olev l then printer ppf else printer null_formatter -let cprintln l s = if ck_olev l then Printf.ksprintf (Format.printf "@[%s@\n@]") s else nprintf -let elevate_olev l = if ck_olev l then () else verb_stack := !verbose_level :: !verb_stack; verbose_level := l -let restore_olev = match !verb_stack with - | x :: xs -> verbose_level := x; verb_stack := xs - | _ -> () - -let bprintf b = if b || ck_olev 1 then Format.printf else nprintf -let bprintflush b s = bprintf b "%s" s; flush stdout - - - -(******************************************************************************) -(*********************************** Logging **********************************) -(******************************************************************************) - -let logChannel = ref stdout -let logFormatter = ref (Format.formatter_of_out_channel stdout) - -let setLogChannel lc = - logChannel := lc; - logFormatter := Format.formatter_of_out_channel lc - -let logPrintf a = Format.fprintf !logFormatter a -let blogPrintf b = if b then logPrintf else nprintf -let cLogPrintf l = if ck_olev l then logPrintf else nprintf - -let get_out_file = fun () -> !out_file_name -let get_save_file = fun () -> (!out_file_name ^ ".fq") -let get_smt2_file = fun () -> (!out_file_name ^ ".smt2") - -(*****************************************************************) -(*********** Command Line Options ********************************) -(*****************************************************************) - -(* taken from dsolve/liquid/liquid.ml *) - -let arg_spec = - [("-out", - Arg.String (fun s -> out_file_name := s), - " Save solution to file [out]"); - - (* - ("-save", - Arg.String (fun s -> save_file := s), - " Save constraints to file [out.fq]"); - *) - - ("-inccheck", - Arg.String (fun s -> true_unconstrained := false; - inccheck := SS.add s !inccheck), - " Incrementally check the specified function"); - ("-noslice", - Arg.Clear slice, - " Compute fixpoint for all kvars, not just those affecting property"); - ("-nolfp", - Arg.Clear lfp, - " Weaken environment (do not produce least fixed-point solution)"); - ("-origdeps", - Arg.Clear adjdeps, - " Don't adjust constraint dependencies [true]"); - ("-dropcalls", - Arg.Set dropcalls, - " Ignore function calls during consgen [false]"); - ("-drconstr", - Arg.Set dump_ref_constraints, - " Dump refinement constraints [false]"); - ("-noshortannots", - Arg.Clear shortannots, - " Annotations with full predicates (not names) [false]"); - ("-strictsortcheck", - Arg.Set strictsortcheck, - " Strict Sort Checking -- e.g. ptr/int comparisons -- for non-C constraints - [false]"); - ("-ctypes", - Arg.Set ctypes_only, - " Infer ctypes only [false]"); - ("-saveslice", - Arg.Set save_slice, - " save slices to file [false]"); - - ("-safe", - Arg.Set safe, - " run in failsafe mode [false]"); - ("-manual", - Arg.Set manual, - " only verify manually-inserted checks"); - ("-fastscalar", - Arg.Set fastscalar, - " use new (experimental) fastscalar solver, eventually will be default"); - ("-counterexamples", - Arg.Set cex, - " generate counterexamples [false] "); - ("-noannots", - Arg.Unit (fun () -> vannots := false; minquals := false), - " generate vim readable annotation file [true] "); - ("-allquals", - Arg.Clear minquals, - " don't minimize qualifiers by using pre-computed one-level implication [true] "); - ("-timeout", - Arg.Set_int timeout, - " limit total time (in seconds, default no limit)"); - ("-ptag", - Arg.Set ptag, - " prioritize constraints using lexico-ordering on tags [true]"); - ("-genspec", - Arg.Set genspec, - " Generate spec file only [false]"); - ("-root", - Arg.String (fun s -> root := s), - " Use root function []"); - ( "-nosimple" - , Arg.Clear simple - , " Directly propagate qualifiers for simple constraints (K1 <: K2) [true]"); - ( "-nobittheory" - , Arg.Clear bit_theory - , " Support for SMT bitvector theory [true]"); - ( "-nosettheory" - , Arg.Clear set_theory - , " Support for SMT set theory [true]"); - ( "-nomaptheory" - , Arg.Clear map_theory - , " Support for SMT map theory [true]"); - ("-psimple", - Arg.Set psimple, - " prioritize simple constraints [true]"); - ("-dgraph", - Arg.Set dump_graph, - " dump constraints SCC to constraints.dot [false]"); - ("-sortedquals", - Arg.Set sorted_quals, - " use sorted parameters in the qualifiers, to speed up instantiation. Should - become default after vetting."); - ("-refinesort", - Arg.Set refine_sort, - " use sortchecking to refine constraints -- and toss out badly instantiated quals. - Shouldn't need except for backward compatibility with dsolve constraints, DONT USE!"); - ("-notruekvars", - Arg.Clear true_unconstrained, - " don't true unconstrained kvars [true]"); - ("-v", Arg.Int (fun c -> verbose_level := c), - " Set degree of analyzer verbosity:\n\ - \032 0 No output\n\ - \032 1 +Verbose errors\n\ - \032 [2] +Verbose stats, timing\n\ - \032 3 +Print normalized source\n\ - \032 11 +Verbose solver\n\ - \032 13 +Dump constraint graph\n\ - \032 64 +Drowning in output"); - ("-latex", - Arg.String (fun s -> - let l = String.length s in - if l = 0 || String.sub s (l-4) 4 <> ".tex" then - print_endline "-latex: invalid parameter" - else - latex_file := Some s), - " translates constraints to LaTeX file" - ); - ("-armc", - Arg.String (fun s -> - let l = String.length s in - if l = 0 then - print_endline "-armc: invalid parameter" - else - armc_file := Some s), - " translate constraints to ARMC file" - ); - ("-horn", - Arg.String (fun s -> - let l = String.length s in - if l = 0 then - print_endline "-rules: invalid parameter" - else - horn_file := Some s), - " translate constraints to Horn clauses" - ); - ("-raw-horn", - Arg.String (fun s -> - let l = String.length s in - if l = 0 then - print_endline "-rules: invalid parameter" - else - raw_horn_file := Some s), - " translate constraints to raw Horn clauses" - ); - ("-qarmc", - Arg.String (fun s -> - let l = String.length s in - if l = 0 then - print_endline "-qarmc: invalid parameter" - else - q_armc_file := Some s), - " translate constraints to Q'ARMC file" - ); - ("-dot", - Arg.String (fun s -> - let l = String.length s in - if l = 0 || String.sub s (l-4) 4 <> ".dot" then - print_endline "-dot: invalid parameter" - else - dot_file := Some s), - " translate constraints to dot file" - ); - ("-keep-uif", - Arg.Clear purify_function_application, - " do not replace function terms by existentially quantified variables" - ); - ("-no-simplify-t", - Arg.Clear simplify_t, - " do not simplify constraints" - ); - ("-simplify-t", - Arg.Set simplify_t, - " simplify constraints" - ); - ("-nocopyprop", - Arg.Clear copyprop, - " simplify constraints via local copy propagation [true]" - ); - ("-libpath", - Arg.String (fun s -> lib_path := s), - (" library path for default spec, quals ["^(!lib_path)^"]") - ); - ("-nop", - Arg.Set do_nothing, - " do nothing (useful for regression tests known to be broken)"; - ); - ("-imp", - Arg.Set dump_imp, - " print constraints as IMP program (experimental)" - ); - ("-smtsolver", - Arg.String (fun s -> smt_solver := if s = "z3mem" then None else Some s), - (" SMT solver (default: Z3 SMTLIB2. z3mem for bindings)") - ); - ("-smtlib", - Arg.Set dump_smtlib, - " print constraints as SMTLIB query (experimental)" - ); - ("-prunelive", - Arg.Set prune_live, - " Restrict liquid types to live variables (experimental)" - ); - ("-no-uif-multiply", - Arg.Clear uif_multiply, - " Don't encode non-linear multiplication with UIFs [true]" - ); - ("-no-uif-divide", - Arg.Clear uif_divide, - " Don't encode non-linear division with UIFs [true]" - ); - ("-simp", - Arg.String ((:=) dump_simp), - " print simplified constraints to save-file (experimental) use [andrey] or [jhala] or [id]" - ); - ("-print-nontriv", - Arg.Set (print_nontriv), - " print non-trivial bindings in each environment [false]" - ); - ("-trace-scalar", - Arg.Set(trace_scalar), - " print constraints and index values in the Index solver"); - ("-check-indices", - Arg.Set(check_is), - " sanity check computed indices"); - ("-prune-index", - Arg.Set(prune_index), - " use the index domain to prune initial solution"); - ("-no-lib-hquals", - Arg.Set(no_lib_hquals), - " don't use qualifier library in type inference"); - ("-no-gen-qual-sorts", - Arg.Clear(gen_qual_sorts), - " don't generalize parameter sorts in qualifiers"); - ("-web-demo", - Arg.Set(web_demo), - " set HTML output to web demo mode"); - ("-ueq-all-sorts", - Arg.Set(ueq_all_sorts), - " make ~~ (UEq) accept all inputs [false]"); - ] - - -let is_prefix p s = - let reg = Str.regexp p in - Str.string_match reg s 0 - -(******************************************************************) -(*************** Paths for builtin specs, quals etc ***************) -(******************************************************************) - -let get_lib_squals = fun () -> Filename.concat !lib_path "lib.squals" -let get_lib_hquals = fun () -> Filename.concat !lib_path "lib.hquals" -let get_lib_spec = fun () -> Filename.concat !lib_path "lib.spec" -let get_lib_h = fun () -> Filename.concat !lib_path "lib.h" -let get_csolve_h = fun () -> Filename.concat !lib_path "../lib/csolve.h" -let get_c2html = fun () -> Filename.concat !lib_path "../demo/jquery/cs2html.py" - -(* TODO: FIX SHADY HACK *) -let set_csolve_file_prefix fn = csolve_file_prefix := fn -(* - let fn' = try (Filename.chop_extension fn)^".c" with _ -> fn in - if Filename.check_suffix fn ".o" && Sys.file_exists fn' then - csolve_file_prefix := fn' - else - csolve_file_prefix := fn - *) diff --git a/external/misc/errorline.ml b/external/misc/errorline.ml deleted file mode 100644 --- a/external/misc/errorline.ml +++ /dev/null @@ -1,31 +0,0 @@ -type info = - { mutable linenum: int; (* current line number *) - mutable linepos: int; (* char position of beginning of current line *) - fileName : string (* current file name *) - } - -let current : info ref = - ref - { linenum = 1 ; - linepos = 0 ; - fileName = "" - } - -let startFile fname = - current := { linenum = 1 ; - linepos = 0 ; - fileName = fname} - -let startNewline n = - let i = !current in - begin - i.linenum <- i.linenum + 1 ; - i.linepos <- n - end - - -let error n msg = - let i = !current in - Printf.eprintf "%s at %s: %d.%d\n" - msg i.fileName i.linenum (n - i.linepos) - diff --git a/external/misc/fcommon.ml b/external/misc/fcommon.ml deleted file mode 100644 --- a/external/misc/fcommon.ml +++ /dev/null @@ -1,148 +0,0 @@ -(* - * Copyright © 2008 The Regents of the University of California. All rights reserved. - * - * Permission is hereby granted, without written agreement and without - * license or royalty fees, to use, copy, modify, and distribute this - * software and its documentation for any purpose, provided that the - * above copyright notice and the following two paragraphs appear in - * all copies of this software. - * - * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY - * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES - * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN - * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY - * OF SUCH DAMAGE. - * - * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, - * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY - * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS - * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION - * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. - * - *) - -module F = Format -module C = Constants - -let mydebug = false - -(****************************************************************) -(************* SCC Ranking **************************************) -(****************************************************************) - -module Int : Graph.Sig.COMPARABLE with type t = int = -struct - type t = int - let compare = compare - let hash = Hashtbl.hash - let equal = (=) -end - -module G = Graph.Imperative.Digraph.Concrete(Int) - -module SCC = Graph.Components.Make(G) - -(* Use of Graphviz *) - -let io_to_string = function - | Some i -> string_of_int i - | None -> "*" - -module DotGraph = -struct - type t = G.t - module V = G.V - module E = G.E - let iter_vertex = G.iter_vertex - let iter_edges_e = G.iter_edges_e - let graph_attributes g = [`Size (11.0, 8.5); `Ratio (`Float 1.29)] - let default_vertex_attributes g = [`Shape `Box] - let vertex_name i = string_of_int i (* Printf.sprintf "V_%d" i *) - let vertex_attributes _ = [] (* [`Label s] *) - let default_edge_attributes g = [] - let edge_attributes e = [] - let get_subgraph v = None -end - -module Dot = Graph.Graphviz.Dot(DotGraph) - -let dump_graph s g = - let oc = open_out (s^".dot") in - Dot.output_graph oc g; - close_out oc - - (* -let int_s_to_string ppf (i,s) = - F.fprintf ppf "(%d,%s)" i s -*) - -let int_s_to_string ppf i = - F.fprintf ppf "(%d)" i - - -let scc_print s g a = - C.bprintf mydebug "dep graph (%s): vertices= %d, sccs= %d \n" s (G.nb_vertex g) (Array.length a); - C.bprintf mydebug "scc sizes: \n"; - Array.iteri begin fun i xs -> - C.bprintf mydebug "%d : [%a] \n" i (FixMisc.pprint_many false "," int_s_to_string) xs - end a; - C.bprintf mydebug "\n" - - -let make_graph s f is ijs = - let g = G.create () in - let _ = List.iter (G.add_vertex g) is in - let _ = List.iter (fun (i,j) -> G.add_edge g i j) ijs in - let _ = if !Constants.dump_graph then dump_graph s g in - g - - - (* -let make_graph s f is ijs = - let g = G.create () in - let _ = List.iter (fun i -> G.add_vertex g (i, (f i))) is in - let _ = List.iter (fun (i,j) -> G.add_edge g (i,(f i)) (j,(f j))) ijs in - let _ = if !Constants.dump_graph then dump_graph s g in - g - - *) - -let my_scc_array _ g = SCC.scc_array g - -(* Given list [(u,v)] returns a numbering [(ui,ri)] s.t. - * 1. if ui,uj in same SCC then ri = rj - * 2. if ui -> uj then ui >= uj *) -let scc_rank s f is ijs = - let g = BNstats.time "making_graph" (make_graph s f is) ijs in - let a = BNstats.time "scc_array" (my_scc_array ()) g in - let _ = scc_print s g a in - let sccs = FixMisc.array_to_index_list a in - FixMisc.flap (fun (i,vs) -> List.map (fun j -> (j,i)) vs) sccs - -(* -let g1 = [(1,2);(2,3);(3,1);(2,4);(3,4);(4,5)];; -let g2 = [(0,1);(1,2);(2,0);(1,3);(4,3); - (5,6);(5,7);(6,9);(7,9);(7,8);(8,5)];; -let g3 = (6,2)::g2;; -let g4 = (2,6)::g2;; - -let n1 = make_scc_num g1 ;; -let n2 = make_scc_num g2 ;; -let n3 = make_scc_num g3 ;; -let n4 = make_scc_num g4 ;; *) - -(* -type fc_id = int option -type subref_id = int - -module WH = - Heaps.Functional(struct - type t = subref_id * int * (int * bool * fc_id) - let compare (_,ts,(i,j,k)) (_,ts',(i',j',k')) = - if i <> i' then compare i i' else - if ts <> ts' then -(compare ts ts') else - if j <> j' then compare j j' else - compare k' k - end) -*) - diff --git a/external/misc/fcommon.mli b/external/misc/fcommon.mli deleted file mode 100644 --- a/external/misc/fcommon.mli +++ /dev/null @@ -1,24 +0,0 @@ -(* - * Copyright © 2008 The Regents of the University of California. All rights reserved. - * - * Permission is hereby granted, without written agreement and without - * license or royalty fees, to use, copy, modify, and distribute this - * software and its documentation for any purpose, provided that the - * above copyright notice and the following two paragraphs appear in - * all copies of this software. - * - * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY - * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES - * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN - * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY - * OF SUCH DAMAGE. - * - * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, - * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY - * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS - * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION - * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. - * - *) - -val scc_rank : string -> (int -> string) -> int list -> (int * int) list -> (int * int) list diff --git a/external/misc/fixMisc.ml b/external/misc/fixMisc.ml deleted file mode 100644 --- a/external/misc/fixMisc.ml +++ /dev/null @@ -1,1365 +0,0 @@ -(* - * Copyright ? 1990-2007 The Regents of the University of California. All rights reserved. - * - * Permission is hereby granted, without written agreement and without - * license or royalty fees, to use, copy, modify, and distribute this - * software and its documentation for any purpose, provided that the - * above copyright notice and the following two paragraphs appear in - * all copies of this software. - * - * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY - * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES - * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN - * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY - * OF SUCH DAMAGE. - * - * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, - * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY - * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS - * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION - * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. - * - *) - -(* $Id: misc.ml,v 1.14 2006/09/26 01:47:01 jhala Exp $ - * - * This file is part of the SIMPLE Project. - *) - -(** - * This module provides some miscellaneous useful helper functions. - *) - -module Ops = struct - - type ('a, 'b) either = Left of 'a | Right of 'b - - let (>|) _ x = x - - let (|>) x f = f x - - let (<|) f x = f x - - let (>>) x f = f x; x - - let (|>>) xo f = match xo with None -> None | Some x -> f x - - let (|>:) xs f = List.map f xs - - let (=+) x n = let v = !x in (x := v + n; v) - - let (+=) x n = x := !x + n; !x - - let (++) = List.rev_append - - let (+++)= fun (x1s, y1s) (x2s, y2s) -> (x1s ++ x2s, y1s ++ y2s) - - let id = fun x -> x - - let un = fun x -> () - - let const x = fun _ -> x - - let (<.>) f g = fun x -> x |> g |> f - - let (<+>) f g = fun x -> x |> f |> g - - let () b f = fun x -> if b then f x else x - - let wwhen b f = fun x -> if b then f x - - let (<*>) f g = fun x -> (f x, g x) - - let (<**>) f g = fun (x, y) -> (f x, g y) - - let (<&&>) f g = fun x -> f x && g x - - let failure fmt = Printf.ksprintf failwith fmt - - let foreach xs f = List.map f xs - - let asserts p fmt = - Printf.ksprintf (fun x -> if not p then failwith x) fmt - -let asserti = asserts - (* -let asserti p fmt = - Printf.ksprintf (fun x -> if not p then (print_string (x^"\n"); ignore(0/0)) else ()) fmt -*) - -let assertf fmt = - Printf.ksprintf failwith fmt - -let halt _ = - assert false - -let fst3 (x,_,_) = x -let snd3 (_,x,_) = x -let thd3 (_,_,x) = x - -let fst4 (x, _, _, _) = x -let snd4 (_, x, _, _) = x -let thd4 (_, _, x, _) = x -let fth4 (_, _, _, x) = x - -let withfst3 (_,y,z) x = (x,y,z) -let withsnd3 (x,_,z) y = (x,y,z) -let withthd3 (x,y,_) z = (x,y,z) - -let print_now s = - print_string s; - flush stdout - -let print_now_error msg = - prerr_string msg; - flush stderr - -let output_now c s = - output_string c s; - flush c - -let some = fun x -> Some x - -end - -open Ops - - -let debugTicker msg = - let x = ref 0 in - fun () -> print_now ("\nDEBUG TICKER " ^ msg ^ " : " ^ (string_of_int (x += 1))) - - - - -let maybe_fold f b xs = - let fo = fun bo x -> match bo with Some b -> f b x | _ -> None in - List.fold_left fo (Some b) xs - -let maybe_map f = function Some x -> Some (f x) | None -> None - -let maybe_iter f = function Some x -> f x | None -> () - -let safe_maybe msg = function Some x -> x | _ -> assertf msg - -let maybe = function Some x -> x | _ -> assertf "maybe called with None" - -let maybe_apply f xo v = match xo with Some x -> f x v | None -> v - -let maybe_default xo y = match xo with Some x -> x | None -> y - -let maybe_string f = function Some x -> "Some " ^ (f x) | None -> "None" - -let rec maybe_chain x d = function - | f::fs -> (match f x with - | Some y -> y - | None -> maybe_chain x d fs) - | [] -> d - - - - - -let trace s f x = - let _ = print_now <| Printf.sprintf "BEGIN: %s \n" s in - let r = f x in - let _ = print_now <| Printf.sprintf "END: %s \n" s in - r - -(* ORIG -let rec pprint_many_box s f ppf = function - | [] -> () - | x::[] -> Format.fprintf ppf "%a" f x - | x::xs' -> (Format.fprintf ppf "%a%s@\n" f x s; pprint_many_box s f ppf xs') -*) -let rec pprint_many_prefix sep base f ppf = function - | x::xs -> Format.fprintf ppf "(%s %a %a)" - sep f x (pprint_many_prefix sep base f) xs - | [] -> Format.fprintf ppf "%a" f base - - -let rec pprint_many_box brk s f ppf = function - | [] -> () - | [x] -> Format.fprintf ppf "%a" f x - | x::xs' when brk -> Format.fprintf ppf "%a@\n%s" f x s; - pprint_many_box brk s f ppf xs' - | x::xs' -> Format.fprintf ppf "%a@,%s" f x s; - pprint_many_box brk s f ppf xs' - -let pprint_many_box brk l s r f ppf = function - | [] -> Format.fprintf ppf "[]" - | xs -> Format.fprintf ppf "@[%s%a%s@]" l (pprint_many_box brk s f) xs r - -let pprint_many_brackets brk f ppf x = - Format.fprintf ppf "%a" (pprint_many_box brk "[ " "; " "]" f) x - -let rec pprint_many brk s f ppf = function - | [] -> () - | [x] -> Format.fprintf ppf "%a" f x - | x::xs' when brk -> Format.fprintf ppf "%a%s@," f x s; pprint_many brk s f ppf xs' - | x::xs' -> Format.fprintf ppf "%a%s" f x s ; pprint_many brk s f ppf xs' - -let pprint_maybe f ppf = function - | Some x -> Format.fprintf ppf "Some %a" f x - | None -> Format.fprintf ppf "None" - -let pprint_int ppf i = - Format.fprintf ppf "%d" i - -let pprint_int_o = pprint_maybe pprint_int -(* -let pprint_int_o ppf = function - | None -> Format.fprintf ppf "None" - | Some d -> Format.fprintf ppf "Some(%d)" d -*) - -let pprint_str ppf s = - Format.fprintf ppf "%s" s - -let pprint_ints ppf is = - pprint_many_brackets false (fun ppf i -> Format.fprintf ppf "%d" i) ppf is - -let pprint_pretty_ints ppf is = - is |> List.map string_of_int |> String.concat ";" |> Format.fprintf ppf "[%s]" - -let pprint_tuple pp1 pp2 ppf (x1, x2) = - Format.fprintf ppf "(%a, %a)" pp1 x1 pp2 x2 - -let rec subsets n = function - | _ when n <= 0 - -> [[]] - | xs when n > List.length xs-> - [] - | x::xs - -> (List.map (fun ys -> x :: ys) (subsets (n-1) xs)) - ++ (subsets n xs) - | _ -> assertf "Misc.subsets" - -let choose b f g = if b then f else g - -let liftfst2 (f: 'a -> 'a -> 'b) (x: 'a * 'c) (y: 'a * 'c): 'b = - f (fst x) (fst y) - -let curry = fun f x y -> f (x,y) -let uncurry = fun f (x,y) -> f x y -let flip = fun f x y -> f y x - -let maybe_bool = function - | Some _ -> true - | None -> false - -module type EMapType = sig - include Map.S - val extendWith : (key -> 'a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t - val extend : 'a t -> 'a t -> 'a t - val filter : (key -> 'a -> bool) -> 'a t -> 'a t - val of_list : (key * 'a) list -> 'a t - val to_list : 'a t -> (key * 'a) list - val length : 'a t -> int - val domain : 'a t -> key list - val range : 'a t -> 'a list - val join : 'a t -> 'b t -> ('a * 'b) t - val adds : key -> 'a list -> 'a list t -> 'a list t - val of_alist : (key * 'a) list -> 'a list t - val finds : key -> 'a list t -> 'a list - val safeFind : key -> 'a t -> string -> 'a - val safeAdd : key -> 'a -> 'a t -> string -> 'a t - val single : key -> 'a -> 'a t - val map_partial : ('a -> 'b option) -> 'a t -> 'b t - val maybe_find : key -> 'a t -> 'a option - val find_default : 'a -> key -> 'a t -> 'a - val frequency : key list -> int t -end - -module type ESetType = sig - include Set.S - val of_list : elt list -> t -end - -module ESet (K: Set.OrderedType) = - struct - include Set.Make(K) - let of_list = List.fold_left (flip add) empty -end - -module type EOrderedType = sig - include Map.OrderedType - val print : Format.formatter -> t -> unit -end - -(* module EMap (K: Map.OrderedType) = *) -module EMap (K: EOrderedType) = - struct - include Map.Make(K) - - let extendWith (f: key -> 'a -> 'a -> 'a) (m1: 'a t) (m2: 'a t) = - fold begin fun k v m -> - let v' = if mem k m then f k v (find k m) else v in - add k v' m - end m2 m1 - - let extend (m1: 'a t) (m2: 'a t) : 'a t = fold add m2 m1 - - (* in 3.12 *) - let filter (f: key -> 'a -> bool) (m: 'a t) : 'a t = - fold (fun x y m -> if f x y then add x y m else m) m empty - - let of_list (kvs : (key * 'a) list) = - List.fold_left (fun m (k, v) -> add k v m) empty kvs - - (* in 3.12 -- bindings *) - let to_list (m : 'a t) : (key * 'a) list = - fold (fun k v acc -> (k,v)::acc) m [] - - (* in 3.12 -- cardinality *) - let length (m : 'a t) : int = - fold (fun _ _ i -> i+1) m 0 - - (* in 3.12 -- singleton *) - let single k v = add k v empty - - let domain m = - fold (fun k _ acc -> k :: acc) m [] - - let range (m : 'a t) : 'a list = - fold (fun _ v acc -> v :: acc) m [] - - let join (m1 : 'a t) (m2 : 'b t) : ('a * 'b) t = - mapi begin fun k v1 -> - let _ = asserts (mem k m2) "EMap.join" in - (v1, find k m2) - end m1 - - let maybe_find k m = - try Some (find k m) with Not_found -> None - - let find_default d k m = - maybe_default (maybe_find k m) d - - (* let finds k m = try find k m with Not_found -> [] *) - let finds k m = find_default [] k m - - let adds (k: key) (vs: 'a list) (m : ('a list) t) : 'a list t = - add k (vs ++ find_default [] k m) m - - let of_alist (kvs : (key * 'a) list) = - List.fold_left (fun m (k, v) -> adds k [v] m) empty kvs - - let frequency (ks : key list) : int t = - List.fold_left (fun m k -> - add k (1 + (find_default 0 k m)) m - ) empty ks - - let safeFind k m msg = - try find k m with Not_found -> - let err = Format.fprintf Format.str_formatter - "ERROR: safeFind (%s): %a" msg K.print k; - Format.flush_str_formatter () - in failwith err - - let safeAdd k v m msg = - if mem k m then - let err = Format.fprintf Format.str_formatter - "ERROR: safeAdd (%s): %a" msg K.print k; - Format.flush_str_formatter () - in failwith err - else add k v m - - let map_partial f m = - fold (fun x yo m -> match yo with Some y -> add x y m | _ -> m) (map f m) empty - end - -module type KeyValType = - sig - type t - val compare : t -> t -> int - val print : Format.formatter -> t -> unit - - type v - val default : v - end - -module MapWithDefault (K: KeyValType) = - struct - include EMap(K) - let find (i: K.t) (m: K.v t): K.v = - try find i m with Not_found -> K.default - end - -module IntMap = - EMap - (struct - type t = int - let compare i1 i2 = compare i1 i2 - let print = pprint_int - end) - -module IntSet = - ESet - (struct - type t = int - let compare i1 i2 = - compare i1 i2 - end) - -module IntIntMap = - EMap - (struct - type t = int * int - let compare i1 i2 = compare i1 i2 - let print ppf (i1, i2) = Format.fprintf ppf "(%d, %d)" i1 i2 - end) - -module StringMap = - EMap - (struct - type t = string - let compare i1 i2 = compare i1 i2 - let print ppf s = Format.fprintf ppf "%s" s - end) - -module StringSet = - ESet - (struct - type t = string - let compare i1 i2 = compare i1 i2 - end) - -(* -let sm_join sm1 sm2 = - StringMap.mapi (fun k v1 -> - let v2 = asserts (StringMap.mem k sm2) "sm_join"; StringMap.find k sm2 in - (v1, v2) - ) sm1 - -let sm_extend sm1 sm2 = - StringMap.fold StringMap.add sm2 sm1 - -let sm_filter f sm = - StringMap.fold begin fun x y sm -> - if f x y then StringMap.add x y sm else sm - end sm StringMap.empty - -let sm_of_list kvs = - List.fold_left (fun sm (k,v) -> StringMap.add k v sm) StringMap.empty kvs - -let sm_to_list sm = - StringMap.fold (fun k v acc -> (k,v)::acc) sm [] - -let sm_to_range sm = - sm |> sm_to_list |> List.map snd -*) - -let sm_print_keys name sm = - sm |> StringMap.to_list - |> List.map fst - |> String.concat ", " - |> Printf.printf "%s : %s \n" name - -let foldn f n b = - let rec foo acc i = - if i >= n then acc else foo (f acc i) (i+1) - in foo b 0 - -let rec range i j = - if i >= j then [] else i::(range (i+1) j) - -let dump s = - print_string s; flush stdout - -let mapn f n = - foldn (fun acc i -> (f i) :: acc) n [] - |> List.rev - -let chop_last = function - | [] -> failure "ERROR: Misc.chop_last" - | xs -> xs |> List.rev |> List.tl |> List.rev - -let list_snoc xs = - match List.rev xs with - | [] -> assertf "list_snoc with empty list!" - | h::t -> h, List.rev t - -let negfilter f xs = - List.fold_left (fun acc x -> if f x then acc else x::acc) [] xs - |> List.rev - -let get_option d = function - | Some x -> x - | None -> d - -let list_somes xs = - xs |> List.fold_left begin fun acc -> function - | Some x -> x :: acc - | None -> acc - end [] - |> List.rev - -(* let map_partial f = list_somes <.> List.map f *) - -let map_partial f xs = - List.rev - (List.fold_left - (fun acc x -> - match f x with - | None -> acc - | Some z -> (z::acc)) [] xs) - - -let fold_left_partial f b xs = - List.fold_left begin fun b xo -> - match xo with - | Some x -> f b x - | None -> b - end b xs - -let list_reduce msg f = function - | [] -> assertf "ERROR: list_reduce with empty list: %s" msg - | x::xs -> List.fold_left f x xs - -let nonnull = function - | [] -> false - | _ -> true - -(* -let list_is_empty = function - | [] -> true - | _::_ -> false -*) - -let list_max x xs = - List.fold_left max x xs - -let list_min x xs = - List.fold_left min x xs - -let list_max_with msg f = function - | [] -> assertf "ERROR: list_max_with with empty list: %s" msg - | x::xs -> List.fold_left (fun acc x -> if f x > f acc then x else acc) x xs - -let rec take_max n = function - | x :: xs when n > 0 -> x :: take_max (n - 1) xs - | _ -> [] - -let rec drop n = function - | x :: xs when n > 0 -> drop (n - 1) xs - | [] when n > 0 -> assertf "ERROR: dropped too many" - | xs -> xs - -let getf a i fmt = - try a.(i) with ex -> assertf fmt - -let do_catchu f x g = - try f x with ex -> (g ex; raise ex) - -let do_catchf s f x = - try f x with ex -> - assertf "%s hits exn: %s \n" s (Printexc.to_string ex) - -let do_catch s f x = - try f x with ex -> - (Printf.printf "%s hits exn: %s \n" s (Printexc.to_string ex); raise ex) - -let do_catch_ret s f x y = - try f x with ex -> - (Printf.printf "%s hits exn: %s \n" s (Printexc.to_string ex); y) - -let do_memo memo f args key = - try Hashtbl.find memo key with Not_found -> - let rv = f args in - let _ = Hashtbl.replace memo key rv in - rv - -let do_bimemo fmemo rmemo f args key = - try Hashtbl.find fmemo key with Not_found -> - let rv = f args in - let _ = Hashtbl.replace fmemo key rv in - let _ = Hashtbl.replace rmemo rv key in - rv - -let rec exists_maybe f = function - | [] -> None - | x::xs -> (match f x with None -> exists_maybe f xs | z -> z) - -let map_pair = fun f (x1, x2) -> (f x1, f x2) -let map_triple = fun f (x1, x2, x3) -> (f x1, f x2, f x3) -let app_fst = fun f (a, b) -> (f a, b) -let app_snd = fun f (a, b) -> (a, f b) -let app_fst3 = fun f (a, b, c) -> (f a, b, c) - -let app_snd3 = fun f (a, b, c) -> (a, f b, c) - -let app_thd3 = fun f (a, b, c) -> (a, b, f c) -let pad_snd = fun f x -> (x, f x) -let pad_fst = fun f y -> (f y, y) -let tmap2 = fun (f, g) x -> (f x, g x) -let tmap3 = fun (f, g, h) x -> (f x, g x, h x) -let iter_fst = fun f (a, b) -> f a -let iter_snd = fun f (a, b) -> f b - -let split3 lst = - List.fold_right (fun (x, y, z) (xs, ys, zs) -> (x :: xs, y :: ys, z :: zs)) lst ([], [], []) - -let split4 lst = - List.fold_right (fun (w, x, y, z) (ws, xs, ys, zs) -> (w :: ws, x :: xs, y :: ys, z :: zs)) lst ([], [], [], []) - -let twrap s f x = - let _ = Printf.printf "calling %s \n" s in - let rv = f x in - let _ = Printf.printf "returned from %s \n" s in - rv - -let mapfold_rev f b xs = - List.fold_left begin fun (acc, ys) x -> - let (acc', y) = f acc x in - (acc', y::ys) - end (b, []) xs - -let mapfold f b xs = - mapfold_rev f b xs - |> app_snd List.rev - -let rootsBy leq xs = - let notDomBy x = not <.> (leq x) in - let rec loop acc = function - | [] -> - acc - | (x::xs) -> - let acc', xs' = map_pair (List.filter (notDomBy x)) (acc, xs) in - loop (x::acc') xs' - in loop [] xs - -let cov_filter cov f xs = - let rec loop acc = function - | [] -> - acc - | (x::xs) when f x -> - let covs, uncovs = List.partition (cov x) xs in - loop ((x, covs) :: acc) uncovs - | (_::xs) -> - loop acc xs - in loop [] xs - -let filter f xs = - List.fold_left (fun xs' x -> if f x then x::xs' else xs') [] xs - |> List.rev - -let iter f xs = - List.fold_left (fun () x -> f x) () xs - -let map2 f xs ys = - let _ = asserti (List.length xs = List.length ys) "Misc.map2" in - List.map2 f xs ys - -let map f xs = - List.rev_map f xs |> List.rev - -let flatten xss = - xss - |> List.fold_left (fun acc xs -> xs ++ acc) [] - |> List.rev - -let flatsingles xss = - xss |> List.fold_left (fun acc -> function [x] -> x::acc | _ -> assertf "flatsingles") [] - |> List.rev - -let splitflatten xsyss = - let xss, yss = List.split xsyss in - (flatten xss, flatten yss) - -let splitflatten3 xsyszss = - let xss, yss, zss = split3 xsyszss in - (flatten xss, flatten yss, flatten zss) - -let flap f xs = - xs |> List.rev_map f |> flatten |> List.rev - -let flap_pair f = splitflatten <.> map f - -let tr_rev_flatten xs = - List.fold_left (fun x xs -> x ++ xs) [] xs - -let tr_rev_flap f xs = - List.fold_left (fun xs x -> (f x) ++ xs) [] xs - -let rec fast_unflat ys = function - | x :: xs -> fast_unflat ([x] :: ys) xs - | [] -> ys - -let dup x = (x, x) - - -let rec rev_perms s = function - | [] -> s - | e :: es -> rev_perms - (tr_rev_flap (fun e -> List.rev_map (fun s -> e :: s) s) e) es - -let product = function - | e :: es -> rev_perms (fast_unflat [] e) es - | es -> es - -let pairs xs = - let rec pairs_aux ps = function - | [] -> ps - | x :: xs -> pairs_aux (List.fold_left (fun ps y -> (x, y) :: ps) ps xs) xs - in pairs_aux [] xs - -let cross_product xs ys = - map begin fun x -> - map begin fun y -> - (x,y) - end ys - end xs - |> flatten - -let rec cross_flatten = function - | [] -> - [[]] - | xs::xss -> - map begin fun x -> - map begin fun ys -> - (x::ys) - end (cross_flatten xss) - end xs - |> flatten - - -let append_pref p s = - (p ^ "." ^ s) - - -let fsort f xs = - let cmp = fun (k1,_) (k2,_) -> compare k1 k2 in - xs |> map (fun x -> ((f x), x)) - |> List.sort cmp - |> map snd - -let sort_and_compact ls = - let rec _sorted_compact l = - match l with - h1::h2::tl -> - let rest = _sorted_compact (h2::tl) in - if h1 = h2 then rest else h1::rest - | tl -> tl - in - _sorted_compact (List.sort compare ls) - -let sort_and_compact xs = - List.sort compare xs - |> List.fold_left - (fun ys x -> match ys with - | y::_ when x=y -> ys - | _::_ -> x::ys - | [] -> [x]) - [] - |> List.rev - -let hashtbl_to_list t = - Hashtbl.fold (fun x y l -> (x,y)::l) t [] - -let hashtbl_keys t = - Hashtbl.fold (fun x y l -> x::l) t [] - |> sort_and_compact - -let hashtbl_invert t = - let t' = Hashtbl.create 17 in - hashtbl_to_list t - |> List.iter (fun (x,y) -> Hashtbl.replace t' y x) - |> fun _ -> t' - - -let distinct xs = - List.length xs = List.length (sort_and_compact xs) - -(** repeats f: unit - > unit i times *) -let rec repeat_fn f i = - if i = 0 then () - else (f (); repeat_fn f (i-1)) - -(* chop s chopper returns ([x;y;z...]) if s = x.chopper.y.chopper ...*) -let chop s chopper = Str.split (Str.regexp chopper) s - -(* like chop only the chop is by chop+ *) -let chop_star chopper s = - Str.split (Str.regexp (Printf.sprintf "[%s+]" chopper)) s - -let bounded_chop s chopper i = Str.bounded_split (Str.regexp chopper) s i - -let is_prefix p s = - let (ls, lp) = (String.length s, String.length p) in - if ls < lp - then false - else - (String.sub s 0 lp) = p - -let is_substring s subs = - let reg = Str.regexp subs in - try ignore(Str.search_forward reg s 0); true - with Not_found -> false - -let replace_substring src dst s = - Str.global_replace (Str.regexp src) dst s - -let is_suffix suffix s = - let k = String.length suffix - and n = String.length s in - (n-k >= 0) && Str.string_match (Str.regexp suffix) s (n-k) - -let iteri f xs = - List.fold_left (fun i x -> f i x; i+1) 0 xs - |> ignore - -let numbered_list xs = - xs |> List.fold_left (fun (i, acc) x -> (i+1, (i,x)::acc)) (0,[]) - |> snd - |> List.rev - -exception FalseException - -let sm_protected_add fail k v sm = - if not (StringMap.mem k sm) then StringMap.add k v sm else - if not fail then sm else - assertf "protected_add: duplicate binding for %s \n" k - -let hashtbl_to_list_all t = - hashtbl_keys t |> map (Hashtbl.find_all t) - -let clone x n = - let rec f n xs = if n <= 0 then xs else f (n-1) (x::xs) in - f n [] - -let single x = [x] - -let distinct xs = - List.length (sort_and_compact xs) = List.length xs - -let trunc i j = - let (ai,aj) = (abs i, abs j) in - if aj <= ai then j else ai*j/aj - -let map_to_string f xs = - String.concat "," (List.map f xs) - -let suffix_of_string = fun s i -> String.sub s i (String.length s - 1) - -(* [count_map xs] = fun x -> number of times x appears in xs if non-zero *) -let count_map rs = - List.fold_left begin fun m r -> - let c = try IntMap.find r m with Not_found -> 0 in - IntMap.add r (c+1) m - end IntMap.empty rs - -let o2s f = function - | Some x -> "Some "^ (f x) - | None -> "None" - -let fixpoint f x = - let rec acf b x = - let x', b' = f x in - if b' then acf true x' else (x', b) in - acf false x - - -let fsprintf f p = - Format.fprintf Format.str_formatter "@[%a@]" f p; - Format.flush_str_formatter () - -let rec same_length l1 l2 = match l1, l2 with - | [], [] -> true - | _ :: xs, _ :: ys -> same_length xs ys - | _ -> false - -let ex_one s = function - | [x] -> x - | _ :: _ -> failwith s - | _ -> failwith (s ^ ". empty") - -let only_one s = function - x :: [] -> Some x - | _ :: _ -> failwith s - | [] -> None - -let maybe_one = function - | [x] -> Some x - | _ -> None - - -let int_of_bool b = if b then 1 else 0 - -(*****************************************************************) -(******************** Mem Management *****************************) -(*****************************************************************) - -open Gc -(* open Format *) - -let pprint_gc s = - (*printf "@[Gc@ Stats:@]@."; - printf "@[minor@ words:@ %f@]@." s.minor_words; - printf "@[promoted@ words:@ %f@]@." s.promoted_words; - printf "@[major@ words:@ %f@]@." s.major_words;*) - (*printf "@[total allocated:@ %fMB@]@." (floor ((s.major_words +. s.minor_words -. s.promoted_words) *. (4.0) /. (1024.0 *. 1024.0)));*) - - Format.printf "@[total allocated:@ %fMB@]@." (floor ((allocated_bytes ()) /. (1024.0 *. 1024.0))); - Format.printf "@[minor@ collections:@ %i@]@." s.minor_collections; - Format.printf "@[major@ collections:@ %i@]@." s.major_collections; - Format.printf "@[heap@ size:@ %iMB@]@." (s.heap_words * 4 / (1024 * 1024)); - (*printf "@[heap@ chunks:@ %i@]@." s.heap_chunks; - (*printf "@[live@ words:@ %i@]@." s.live_words; - printf "@[live@ blocks:@ %i@]@." s.live_blocks; - printf "@[free@ words:@ %i@]@." s.free_words; - printf "@[free@ blocks:@ %i@]@." s.free_blocks; - printf "@[largest@ free:@ %i@]@." s.largest_free; - printf "@[fragments:@ %i@]@." s.fragments;*)*) - Format.printf "@[compactions:@ %i@]@." s.compactions; - (*printf "@[top@ heap@ words:@ %i@]@." s.top_heap_words*) () - -let dump_gc s = - Format.printf "@[%s@]@." s; - pprint_gc (Gc.quick_stat ()) - - -let append_to_file f s = - let oc = Unix.openfile f [Unix.O_WRONLY; Unix.O_APPEND; Unix.O_CREAT] 420 in - ignore (Unix.write oc s 0 ((String.length s)-1) ); - Unix.close oc - -(* -let with_out_file file f = - let oc = open_out file in - f oc; - close_out oc -*) - -let display_tick = fun () -> print_now "." - -let display_tick = - let icona = [| "|"; "/" ; "-"; "\\" |] in - let n = ref 0 in - let pos = ref 0 in - fun () -> - let k = !pos in - let _ = pos := (k + 1) mod 4 in - let _ = incr n in - let suf = if (!n mod 76) = 0 - then "\n" - else icona.(k) in - let _ = print_now ("\b."^suf) in - () - - - -let with_out_file file f = file |> open_out >> f |> close_out - -let write_to_file f s = - with_out_file f (fun oc -> output_string oc s) - -let with_out_formatter file f = - with_out_file file (fun oc -> f (Format.formatter_of_out_channel oc)) - -let get_unique = - let cnt = ref 0 in - (fun () -> let rv = !cnt in incr cnt; rv) - -let lines_of_file filename = - let lines = ref [] in - let chan = open_in filename in - try - while true; do - lines := input_line chan :: !lines - done; [] - with End_of_file -> - close_in chan; - List.rev !lines - -let map_lines_of_file infile outfile f = - let ic = open_in infile in - let oc = open_out outfile in - try - while true; do - ic |> input_line |> f |> output_string oc - done; - with End_of_file -> - (close_in ic; close_out oc) - -let maybe_cons m xs = match m with - | None -> xs - | Some x -> x :: xs - -let maybe_list xs = - List.fold_right maybe_cons xs [] - -let rec list_first_maybe f = function - | x::xs -> begin match f x with - | Some y -> Some y - | _ -> list_first_maybe f xs - end - | [] -> None - -let list_find_maybe f xs = - try some <| List.find f xs with Not_found -> None - -let list_assoc_maybe k kvs = - try Some (List.assoc k kvs) with Not_found -> None - -let list_assoc_default d kvs k = - try List.assoc k kvs with Not_found -> d - -let list_assoc_flip xs = - let r (x, y) = (y, x) in - List.map r xs - -let fold_lefti f b xs = - List.fold_left (fun (i,b) x -> ((i+1), f i b x)) (0,b) xs - -let mapi f xs = - xs |> fold_lefti (fun i acc x -> (f i x) :: acc) [] - |> snd |> List.rev - -let index_from n xs = - let is = range n (n + List.length xs) in - List.combine is xs - -let fold_left_flip f b xs = - List.fold_left (flip f) b xs - -let fold_left_swap f xs b = - List.fold_left f b xs - -let rec map3 f xs ys zs = match (xs, ys, zs) with - | ([], [], []) -> [] - | (x :: xs, y :: ys, z :: zs) -> f x y z :: map3 f xs ys zs - | _ -> assert false - -let rec fold_right3 f xs ys zs acc = match xs, ys, zs with - | x :: xs, y :: ys, z :: zs -> f x y z (fold_right3 f xs ys zs acc) - | [], [], [] -> acc - | _ -> assert false - -let rec fold_left3 f acc xs ys zs = match xs, ys, zs with - | x :: xs, y :: ys, z :: zs -> fold_left3 f (f acc x y z) xs ys zs - | [], [], [] -> acc - | _ -> assert false - -let zip_partition xs bs = - let (xbs, xbs') = List.partition snd (List.combine xs bs) in - (List.map fst xbs, List.map fst xbs') - -let rec map4 f ws xs ys zs = match ws, xs, ys, zs with - | [], [], [], [] -> [] - | w :: ws, x :: xs, y :: ys, z :: zs -> f w x y z :: map4 f ws xs ys zs - | _ -> asserti false "map4"; assert false - - -let rec perms es = - match es with - | s :: [] -> - List.map (fun c -> [c]) s - | s :: es -> - flap (fun c -> List.map (fun d -> c :: d) (perms es)) s - | [] -> - [] - -let flap2 f xs ys = - List.flatten (List.map2 f xs ys) - -let flap3 f xs ys zs = - List.flatten (map3 f xs ys zs) - -let combine msg xs ys = - let _ = asserts (List.length xs = List.length ys) "%s" msg in - List.combine xs ys - -let combine3 xs ys zs = - map3 (fun x y z -> (x, y, z)) xs ys zs - -let combine4 ws xs ys zs = - map4 (fun w x y z -> (w, x, y, z)) ws xs ys zs - -let tr_partition f xs = - List.fold_left begin fun (xs,ys) z -> - if f z - then (z::xs, ys) - else (xs, z::ys) - end ([],[]) xs - -let either_partition f xs = - List.fold_left begin fun (xs, ys) z -> - match f z with - | Left x -> (x::xs, ys) - | Right y -> (xs, y::ys) - end ([], []) xs - -(* these do odd things with order for performance - * it is possible that fast is a misnomer *) -let fast_flatten xs = - List.fold_left (++) [] xs - -let fast_append v v' = - let (v, v') = if List.length v > List.length v' then (v', v) else (v, v') in - List.rev_append v v' - -let fast_flap f xs = - List.fold_left (fun xs x -> List.rev_append (f x) xs) [] xs - -let rec fast_unflat ys = function - | x :: xs -> fast_unflat ([x] :: ys) xs - | [] -> ys - -let rec rev_perms s = function - | [] -> s - | e :: es -> rev_perms - (fast_flap (fun e -> List.rev_map (fun s -> e :: s) s) e) es - -let rev_perms = function - | e :: es -> rev_perms (fast_unflat [] e) es - | es -> es - -let tflap2 (e1, e2) f = - List.fold_left (fun bs b -> List.fold_left (fun aas a -> f a b :: aas) bs e1) [] e2 - -let tflap3 (e1, e2, e3) f = - List.fold_left begin fun cs c -> - List.fold_left begin fun bs b -> - List.fold_left begin fun aas a -> - f a b c :: aas - end bs e1 - end cs e2 - end[] e3 - -let rec expand f xs ys = - match xs with - | [] -> ys - | x::xs -> let (xs', ys') = f x in - expand f (xs' ++ xs) (ys' ++ ys) - -let rec get_first f = function - | x::xs when f x -> Some x - | _::xs -> get_first f xs - | [] -> None - -let join f xs ys = - let rec fuse acc xs ys = - match xs, ys with - | [],_ | _, [] -> List.rev acc - | ((kx, _)::xs', (ky,_)::_ ) when kx < ky -> fuse acc xs' ys - | ((kx, _)::_ , (ky,_)::ys') when kx > ky -> fuse acc xs ys' - | ((kx, x)::xs', (ky,y)::ys') (* kx = ky *) -> fuse ((x,y)::acc) xs' ys' in - let xs' = List.map (fun x -> (f x, x)) xs |> List.sort compare in - let ys' = List.map (fun y -> (f y, y)) ys |> List.sort compare in - fuse [] xs' ys' - -let hashtbl_find_default d t x = - try Hashtbl.find t x with Not_found -> d - -let frequency (xs : 'a list) : ('a * int) list = - let t = Hashtbl.create 17 in - List.iter begin fun x -> - let n = hashtbl_find_default 0 t x in - Hashtbl.replace t x (n + 1) - end xs; - hashtbl_to_list t - -let kgroupby (f: 'a -> 'b) (xs: 'a list): ('b * 'a list) list = - let t = Hashtbl.create 17 in - let lookup x = try Hashtbl.find t x with Not_found -> [] in - (* build table *) - List.iter begin fun x -> - Hashtbl.replace t (f x) (x :: lookup (f x)) - end xs; - (* build cluster *) - Hashtbl.fold (fun k xs xxs -> (k, xs) :: xxs) t [] - - - -let groupby (f: 'a -> 'b) (xs: 'a list): 'a list list = - kgroupby f xs |> List.map (snd <+> List.rev) - -let full_join f xs ys = - (xs, ys) - |> map_pair (kgroupby f) - |> uncurry (join fst) - |> flap (map_pair snd <+> uncurry cross_product) - -let exists_pair (f: 'a -> 'a -> bool) (xs: 'a list): bool = - fst (List.fold_left (fun (b, ys) x -> (b || List.exists (f x) ys, x :: ys)) (false, []) xs) - -let rec find_pair (f: 'a -> 'a -> bool): 'a list -> 'a * 'a = function - | [] -> raise Not_found - | x::xs -> try (x, List.find (f x) xs) with Not_found -> find_pair f xs - -let rec is_unique = function - | [] -> true - | x :: xs -> if List.mem x xs then false else is_unique xs - -let map_opt f = function - | Some o -> Some (f o) - | None -> None - -let resl_opt f = function - | Some o -> f o - | None -> [] - -let resi_opt f = function - | Some o -> f o - | None -> () - -let opt_iter f l = - List.iter (resi_opt f) l - -let array_findi p arr = - let rec look i = - if i < 0 then raise Not_found else - if p arr.(i) then i else look i - 1 - in look (Array.length arr - 1) - -let array_to_index_list a = - Array.fold_left (fun (i, rv) v -> (i+1,(i,v)::rv)) (0,[]) a - |> snd - |> List.rev - - -let hashtbl_of_list xys = - let t = Hashtbl.create 37 in - let _ = List.iter (fun (x,y) -> Hashtbl.add t x y) xys in - t - -let hashtbl_of_list_with kf xs = - xs |>: pad_fst kf |> hashtbl_of_list - -let array_flapi f a = - Array.fold_left (fun (i, acc) x -> (i+1, (f i x) :: acc)) (0,[]) a - |> snd - |> List.rev - |> flatten - -let array_fold_lefti f acc a = - Array.fold_left (fun (i, acc) x -> (i + 1, f i acc x)) (0, acc) a |> snd - -let array_map2 f xa ya = - Array.mapi (fun i x -> f x (ya.(i))) xa - -let array_rev_iteri f a = - for i = Array.length a - 1 downto 0 do - f i a.(i) - done - -exception NotForall - -let array_forall f a = - try - Array.iter (fun e -> if f e then () else raise NotForall) a; true - with NotForall -> - false - -let array_combine a1 a2 = - asserts (Array.length a1 = Array.length a2) "array_combine"; - Array.init (Array.length a1) (fun i -> (a1.(i), a2.(i))) - - -let compose f g a = f (g a) - - -let rec gcd (a: int) (b: int): int = - if b = 0 then a else gcd b (a mod b) - -let lcm (a: int) (b: int): int = - if a = 0 then a else (abs (a * b)) / (gcd a b) - -let mk_int_factory () = - let id = ref (-1) in - ((fun () -> incr id; !id), (fun () -> id := -1)) - -let mk_char_factory () = - let (fresh_int, reset_fresh_int) = mk_int_factory () in - ((fun () -> Char.chr (fresh_int () + Char.code 'a')), reset_fresh_int) - -let mk_string_factory s = - let (fresh_int, reset_fresh_int) = mk_int_factory () in - ((fun () -> s^(string_of_int (fresh_int ()))), reset_fresh_int) - -let swap (x,y) = (y,x) - -(* ('a * (int * 'b) list) list -> (int * ('a * 'b) list) list *) -let transpose x_iys_s = - let t = Hashtbl.create 17 in - List.iter begin fun (x, iys) -> - List.iter begin fun (i, y) -> - Hashtbl.add t i (x,y) - end iys - end x_iys_s; - hashtbl_keys t |> List.map (fun i -> (i, Hashtbl.find_all t i)) - -let basename_no_extension fname = - fname |> Filename.basename |> Filename.chop_extension - -let absolute_name name = - if not (Filename.is_relative name) then name else - let b = Filename.basename name in - let d = Filename.dirname name in - let dir = Sys.getcwd () in - let _ = Sys.chdir (Filename.concat dir d) in - let dir' = Sys.getcwd () in - let rv = Filename.concat dir' b in - let _ = Sys.chdir dir in - rv - -let cardinality = fun xs -> xs |> sort_and_compact |> List.length -let disjoint = fun xs ys -> cardinality xs + cardinality ys = cardinality (xs ++ ys) - -let bracket (l : unit -> unit) (r : unit -> unit) (f : unit -> 'a) : 'a = - try l () |> f >> (fun _ -> r ()) - with ex -> assertf "bracket hits exn: %s \n" (Printexc.to_string ex) - -(* -let with_ref_at x v f = - let oldv = !x in - bracket (fun _ -> x := v) (fun _ -> x := oldv) f -*) - -let with_ref_at x v f = - let oldv = !x in - let _ = x := v in - let res = f () in - let _ = x := oldv in - res - - - -let rec isPrefix = function - | ([], _) -> true - | (x::xs, y::ys) when x = y -> isPrefix (xs, ys) - | _ -> false - -let find_first_true f lo hi = - let rec go lo hi = - let mid = lo + ((hi - lo) / 2) in - match () with - | _ when lo >= hi -> None - | _ when lo = hi - 1 -> Some hi - | _ when f mid -> go lo mid - | _ -> go mid hi - in if f lo then Some lo - else if not (f hi) then None - else go lo hi - -let safeHead msg = function - | [x] -> x - | _ -> failwith ("ERROR: safeHead" ^ msg) - -let safeApply pp f x = match f x with - | Some y -> y - | None -> failwith ("ERROR: safeApply " ^ (pp x)) - -let stringIsUpper = function - | "" -> false - | s -> let c = s.[0] in c = Char.uppercase c - -let stringIsLower = function - | "" -> false - | s -> let c = s.[0] in c = Char.lowercase c - - -let rec zipWith f = function - | (x::xs, y::ys) -> f x y::zipWith f (xs, ys) - | _ -> [] diff --git a/external/misc/heaps.ml b/external/misc/heaps.ml deleted file mode 100644 --- a/external/misc/heaps.ml +++ /dev/null @@ -1,223 +0,0 @@ -(**************************************************************************) -(* *) -(* Copyright (C) Jean-Christophe Filliatre *) -(* *) -(* This software is free software; you can redistribute it and/or *) -(* modify it under the terms of the GNU Library General Public *) -(* License version 2, with the special exception on linking *) -(* described in file LICENSE. *) -(* *) -(* This software is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) -(* *) -(**************************************************************************) - -(*s Heaps *) - -module type Ordered = sig - type t - val compare : t -> t -> int -end - -exception EmptyHeap - -(*s Imperative implementation *) - -module Imperative(X : Ordered) = struct - - (* The heap is encoded in the array [data], where elements are stored - from [0] to [size - 1]. From an element stored at [i], the left - (resp. right) subtree, if any, is rooted at [2*i+1] (resp. [2*i+2]). *) - - type t = { mutable size : int; mutable data : X.t array } - - (* When [create n] is called, we cannot allocate the array, since there is - no known value of type [X.t]; we'll wait for the first addition to - do it, and we remember this situation with a negative size. *) - - let create n = - if n <= 0 then invalid_arg "create"; - { size = -n; data = [||] } - - let is_empty h = h.size <= 0 - - (* [resize] doubles the size of [data] *) - - let resize h = - let n = h.size in - assert (n > 0); - let n' = 2 * n in - let d = h.data in - let d' = Array.create n' d.(0) in - Array.blit d 0 d' 0 n; - h.data <- d' - - let add h x = - (* first addition: we allocate the array *) - if h.size < 0 then begin - h.data <- Array.create (- h.size) x; h.size <- 0 - end; - let n = h.size in - (* resizing if needed *) - if n == Array.length h.data then resize h; - let d = h.data in - (* moving [x] up in the heap *) - let rec moveup i = - let fi = (i - 1) / 2 in - if i > 0 && X.compare d.(fi) x < 0 then begin - d.(i) <- d.(fi); - moveup fi - end else - d.(i) <- x - in - moveup n; - h.size <- n + 1 - - let maximum h = - if h.size <= 0 then raise EmptyHeap; - h.data.(0) - - let remove h = - if h.size <= 0 then raise EmptyHeap; - let n = h.size - 1 in - h.size <- n; - let d = h.data in - let x = d.(n) in - (* moving [x] down in the heap *) - let rec movedown i = - let j = 2 * i + 1 in - if j < n then - let j = - let j' = j + 1 in - if j' < n && X.compare d.(j') d.(j) > 0 then j' else j - in - if X.compare d.(j) x > 0 then begin - d.(i) <- d.(j); - movedown j - end else - d.(i) <- x - else - d.(i) <- x - in - movedown 0 - - let pop_maximum h = let m = maximum h in remove h; m - - let iter f h = - let d = h.data in - for i = 0 to h.size - 1 do f d.(i) done - - let fold f h x0 = - let n = h.size in - let d = h.data in - let rec foldrec x i = - if i >= n then x else foldrec (f d.(i) x) (succ i) - in - foldrec x0 0 - -end - - -(*s Functional implementation *) - -module type FunctionalSig = sig - type elt - type t - val empty : t - val add : elt -> t -> t - val maximum : t -> elt - val remove : t -> t - val iter : (elt -> unit) -> t -> unit - val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a -end - -module Functional(X : Ordered) = struct - - (* Heaps are encoded as complete binary trees, i.e., binary trees - which are full expect, may be, on the bottom level. - These trees also enjoy the heap property, namely the value of any node - is greater or equal than those of its left and right subtrees. - - The representation invariant is the following: the number of nodes in - the left subtree is equal to the number of nodes in the right - subtree, or exceeds it by exactly once. In the first case, we use - the constructor [Same] and in the second the constructor [Diff]. - Then it can be proved that [2^(h-1) <= n <= 2^h] when [n] is the - number of elements and [h] the height of the tree. *) - - type elt = X.t - - type t = - | Empty - | Same of t * X.t * t (* same number of elements on both sides *) - | Diff of t * X.t * t (* left has [n+1] nodes and right has [n] *) - - let empty = Empty - - let rec add x = function - | Empty -> - Same (Empty, x, Empty) - (* insertion to the left *) - | Same (l, y, r) -> - if X.compare x y > 0 then Diff (add y l, x, r) else Diff (add x l, y,r) - (* insertion to the right *) - | Diff (l, y, r) -> - if X.compare x y > 0 then Same (l, x, add y r) else Same (l,y, add x r) - - let maximum = function - | Empty -> raise EmptyHeap - | Same (_, x, _) | Diff (_, x, _) -> x - - (* extracts one element on the bottom level of the tree, while - maintaining the representation invariant *) - let rec extract_last = function - | Empty -> raise EmptyHeap - | Same (Empty, x, Empty) -> x, Empty - | Same (l, x, r) -> let y,r' = extract_last r in y, Diff (l, x, r') - | Diff (l, x, r) -> let y,l' = extract_last l in y, Same (l', x, r) - - (* removes the topmost element of the tree and inserts a new element [x] *) - let rec descent x = function - | Empty -> - assert false - | Same (Empty, _, Empty) -> - Same (Empty, x, Empty) - | Diff (Same (_, z, _) as l, _, Empty) -> - if X.compare x z > 0 then Diff (l, x, Empty) - else Diff (Same (Empty, x, Empty), z, Empty) - | Same (l, _, r) -> - let ml = maximum l in - let mr = maximum r in - if X.compare x ml > 0 && X.compare x mr > 0 then - Same (l, x, r) - else - if X.compare ml mr > 0 then - Same (descent x l, ml, r) - else - Same (l, mr, descent x r) - | Diff (l, _, r) -> - let ml = maximum l in - let mr = maximum r in - if X.compare x ml > 0 && X.compare x mr > 0 then - Diff (l, x, r) - else - if X.compare ml mr > 0 then - Diff (descent x l, ml, r) - else - Diff (l, mr, descent x r) - - let remove = function - | Empty -> raise EmptyHeap - | Same (Empty, x, Empty) -> Empty - | h -> let y,h' = extract_last h in descent y h' - - let rec iter f = function - | Empty -> () - | Same (l, x, r) | Diff (l, x, r) -> iter f l; f x; iter f r - - let rec fold f h x0 = match h with - | Empty -> x0 - | Same (l, x, r) | Diff (l, x, r) -> fold f l (fold f r (f x x0)) - -end diff --git a/external/misc/heaps.mli b/external/misc/heaps.mli deleted file mode 100644 --- a/external/misc/heaps.mli +++ /dev/null @@ -1,98 +0,0 @@ -(**************************************************************************) -(* *) -(* Copyright (C) Jean-Christophe Filliatre *) -(* *) -(* This software is free software; you can redistribute it and/or *) -(* modify it under the terms of the GNU Library General Public *) -(* License version 2, with the special exception on linking *) -(* described in file LICENSE. *) -(* *) -(* This software is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) -(* *) -(**************************************************************************) - -(* Heaps *) - -module type Ordered = sig - type t - val compare : t -> t -> int -end - -exception EmptyHeap - -(*S Imperative implementation. *) - -module Imperative(X: Ordered) : sig - - (* Type of imperative heaps. - (In the following [n] refers to the number of elements in the heap) *) - - type t - - (* [create c] creates a new heap, with initial capacity of [c] *) - val create : int -> t - - (* [is_empty h] checks the emptiness of [h] *) - val is_empty : t -> bool - - (* [add x h] adds a new element [x] in heap [h]; size of [h] is doubled - when maximum capacity is reached; complexity $O(log(n))$ *) - val add : t -> X.t -> unit - - (* [maximum h] returns the maximum element of [h]; raises [EmptyHeap] - when [h] is empty; complexity $O(1)$ *) - val maximum : t -> X.t - - (* [remove h] removes the maximum element of [h]; raises [EmptyHeap] - when [h] is empty; complexity $O(log(n))$ *) - val remove : t -> unit - - (* [pop_maximum h] removes the maximum element of [h] and returns it; - raises [EmptyHeap] when [h] is empty; complexity $O(log(n))$ *) - val pop_maximum : t -> X.t - - (* usual iterators and combinators; elements are presented in - arbitrary order *) - val iter : (X.t -> unit) -> t -> unit - - val fold : (X.t -> 'a -> 'a) -> t -> 'a -> 'a - -end - -(*S Functional implementation. *) - -module type FunctionalSig = sig - - (* heap elements *) - type elt - - (* Type of functional heaps *) - type t - - (* The empty heap *) - val empty : t - - (* [add x h] returns a new heap containing the elements of [h], plus [x]; - complexity $O(log(n))$ *) - val add : elt -> t -> t - - (* [maximum h] returns the maximum element of [h]; raises [EmptyHeap] - when [h] is empty; complexity $O(1)$ *) - val maximum : t -> elt - - (* [remove h] returns a new heap containing the elements of [h], except - the maximum of [h]; raises [EmptyHeap] when [h] is empty; - complexity $O(log(n))$ *) - val remove : t -> t - - (* usual iterators and combinators; elements are presented in - arbitrary order *) - val iter : (elt -> unit) -> t -> unit - - val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a - -end - -module Functional(X: Ordered) : FunctionalSig with type elt = X.t diff --git a/external/misc/tagtime.ml b/external/misc/tagtime.ml deleted file mode 100644 --- a/external/misc/tagtime.ml +++ /dev/null @@ -1,125 +0,0 @@ -(* - * - * Copyright (c) 2001 by - * George C. Necula necula@cs.berkeley.edu - * Scott McPeak smcpeak@cs.berkeley.edu - * Wes Weimer weimer@cs.berkeley.edu - * - * All rights reserved. Permission to use, copy, modify and distribute - * this software for research purposes only is hereby granted, - * provided that the following conditions are met: - * 1. XSRedistributions of source code must retain the above copyright notice, - * this list of conditions and the following disclaimer. - * 2. Redistributions in binary form must reproduce the above copyright notice, - * this list of conditions and the following disclaimer in the documentation - * and/or other materials provided with the distribution. - * 3. The name of the authors may not be used to endorse or promote products - * derived from this software without specific prior written permission. - * - * DISCLAIMER: - * THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR - * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES - * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. - * IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT, - * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, - * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS - * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON - * ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT - * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF - * THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - *) - -open Misc.Ops - -(******************************************************************) -(************************* Definitions ****************************) -(******************************************************************) - - (* A hierarchy of timings *) -type t = { name : string * (string list); - mutable time : float; - mutable sub : t list} - - (* Create the top level *) -let top = { name = "TOTAL", []; - time = 0.0; - sub = []; } - - (* The stack of current path through - * the hierarchy. The head is the - * leaf. *) -let current : t list ref = ref [top] - -let subtime x = - x.sub |> List.map (fun y -> y.time) - |> List.fold_left (+.) 0.0 - -(******************************************************************) -(************************* Printing *******************************) -(******************************************************************) - -let _print x chn msg = - x.time <- subtime x; - let rec prTree ind node = - Printf.fprintf chn "%s%-20s %6.3f s\n" - (String.make ind ' ') (fst node.name) node.time ; - List.iter (prTree (ind + 2)) node.sub - in Printf.fprintf chn "%s" msg; prTree 0 x - -let collapse (x: t) : t = failwith "TBD: Tagtime.collapse" - -(* API *) -let print chn msg = _print (collapse top) chn msg - -(******************************************************************) -(************************* Timing *********************************) -(******************************************************************) - -let restore_stat (oldcurrent, start, stat) = - let stop = Unix.times () in - let diff = stop.Unix.tms_utime -. start in - stat.time <- stat.time +. diff; - current := oldcurrent - -let find_stat stags = - let curr = (match !current with h :: _ -> h | _ -> assert false) in - let rec loop = function - | h :: _ when h.name = stags -> h - | _ :: rest -> loop rest - | [] -> let nw = {name = stags; time = 0.0; sub = []} in - curr.sub <- nw :: curr.sub; - nw - in loop curr.sub - -(* API *) -let time (str, tags) f arg = - let stat = find_stat (str, List.sort compare tags) in - let oldcurrent = !current in - let _ = current := stat :: oldcurrent in - let start = (Unix.times ()).Unix.tms_utime in - try - let res = f arg in - restore_stat (oldcurrent, start, stat); - res - with x -> begin - restore_stat (oldcurrent, start, stat); - raise x - end - -(******************************************************************) -(************************* Logging ********************************) -(******************************************************************) - -let dump_to_channel chn = - top.time <- subtime top; - let rec prTree tags node = - let s, ts = node.name in - let tags' = [s] ++ ts ++ tags in - let time' = max 0.0 (node.time -. (subtime node)) in - Printf.fprintf chn "%s,%6.3f\n" (String.concat "," tags') time'; - List.iter (prTree tags') node.sub - in prTree [] top - -(* API *) -let dump = fun fn -> fn |> open_out >> dump_to_channel |> close_out diff --git a/external/misc/tagtime.mli b/external/misc/tagtime.mli deleted file mode 100644 --- a/external/misc/tagtime.mli +++ /dev/null @@ -1,37 +0,0 @@ -(* - * Copyright ? 1990-2007 The Regents of the University of California. All rights reserved. - * - * Permission is hereby granted, without written agreement and without - * license or royalty fees, to use, copy, modify, and distribute this - * software and its documentation for any purpose, provided that the - * above copyright notice and the following two paragraphs appear in - * all copies of this software. - * - * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY - * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES - * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN - * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY - * OF SUCH DAMAGE. - * - * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, - * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY - * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS - * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION - * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. - * - *) - -(* Based on "Stats" by George Necula, Westley Weimer and Scott McPeak *) - -(** Time a function and associate the time with the given - (key) string and the list of (tags) strings. If some - timing information is already associated with the key - string, then accumulate the times. If this function is - invoked within another timed function then you can have - a hierarchy of timings *) -val time : string * string list -> ('a -> 'b) -> 'a -> 'b - -(** [dump fname] saves the tagged profile to file *) -val dump : string -> unit - -val print: out_channel -> string -> unit diff --git a/external/misc/timer.ml b/external/misc/timer.ml deleted file mode 100644 --- a/external/misc/timer.ml +++ /dev/null @@ -1,59 +0,0 @@ -(* - * Copyright ? 1990-2010 The Regents of the University of California. All rights reserved. - * - * Permission is hereby granted, without written agreement and without - * license or royalty fees, to use, copy, modify, and distribute this - * software and its documentation for any purpose, provided that the - * above copyright notice and the following two paragraphs appear in - * all copies of this software. - * - * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY - * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES - * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN - * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY - * OF SUCH DAMAGE. - * - * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, - * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY - * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS - * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION - * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. - *) - -open FixMisc.Ops - -type t = { - name : string; - mutable last : float; - mutable events: (int * string option * float) list; -} - -let get_time = fun _ -> (Unix.times ()).Unix.tms_utime - -let create n = - let now = get_time () in - { name = n; - events = [(0, None, 0.0)]; - last = now; - } - -let log_event t so = - match t.events with - | [] -> assertf "impossible" - | (i,_,_)::_ -> let now = get_time () in - t.events <- (i+1, so, now -. t.last)::t.events; - t.last <- now - -let to_events = fun t -> List.rev t.events -let to_name = fun t -> t.name - -let print_event ppf = function - | (i, Some s, f) -> Format.fprintf ppf "<%6d, %6.3f, %s>@\n" i f s - | (i, None , f) -> Format.fprintf ppf "<%6d, %6.3f, *>@\n" i f - -let print ppf t = - Format.fprintf ppf "Timer %s :: @[%a@] \n" - t.name - (FixMisc.pprint_many false "" print_event) (to_events t) - - diff --git a/external/misc/timer.mli b/external/misc/timer.mli deleted file mode 100644 --- a/external/misc/timer.mli +++ /dev/null @@ -1,28 +0,0 @@ -(* - * Copyright ? 1990-2010 The Regents of the University of California. All rights reserved. - * - * Permission is hereby granted, without written agreement and without - * license or royalty fees, to use, copy, modify, and distribute this - * software and its documentation for any purpose, provided that the - * above copyright notice and the following two paragraphs appear in - * all copies of this software. - * - * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY - * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES - * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN - * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY - * OF SUCH DAMAGE. - * - * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, - * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY - * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS - * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION - * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. - * - *) - -type t -val create : string -> t -val log_event: t -> string option -> unit -val print : Format.formatter -> t -> unit - diff --git a/external/misc/timetest.ml b/external/misc/timetest.ml deleted file mode 100644 --- a/external/misc/timetest.ml +++ /dev/null @@ -1,29 +0,0 @@ -(**************************************************************) -(*************** Unit Test For Time Modules *******************) -(**************************************************************) - -open Misc.Ops - -let rec repeat f n = if n > 0 then (f (); repeat f (n-1)) - -let pause_1_sec () = repeat (fun () -> ()) 112516096 -let pause_n_sec n = repeat pause_1_sec n - -let rec sim n c b t = - if n > 0 then begin - let id = "downtick "^(string_of_int n) in - let _ = Printf.printf "%s \n" id in - Timer.log_event t (Some id); - Tagtime.time ("pause",[id]) pause_n_sec b; - sim (n-1) c (c*b) t - end - -let sim n c b t = - sim n c b t; - Timer.log_event t None - -let c = try Sys.argv.(1) |> int_of_string with _ -> 1 -let _ = Timer.create "boo" - >> (fun t -> Tagtime.time ("sim", []) (sim 4 c 1) t) - |> Format.printf "%a" Timer.print -let _ = Tagtime.dump "timetest.stat" diff --git a/external/ocamlgraph/META.in b/external/ocamlgraph/META.in deleted file mode 100644 --- a/external/ocamlgraph/META.in +++ /dev/null @@ -1,5 +0,0 @@ -version = "VERSION" -description = "Generic Graph Library" -requires="" -archive(byte) = "CMA" -archive(native) = "CMXA" diff --git a/external/ocamlgraph/Makefile.in b/external/ocamlgraph/Makefile.in deleted file mode 100644 --- a/external/ocamlgraph/Makefile.in +++ /dev/null @@ -1,386 +0,0 @@ -########################################################################## -# # -# Ocamlgraph: a generic graph library for OCaml # -# Copyright (C) 2004-2007 # -# Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles # -# # -# This software is free software; you can redistribute it and/or # -# modify it under the terms of the GNU Library General Public # -# License version 2, with the special exception on linking # -# described in file LICENSE. # -# # -# This software is distributed in the hope that it will be useful, # -# but WITHOUT ANY WARRANTY; without even the implied warranty of # -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. # -# # -########################################################################## - -# Where to install the binaries -prefix=@prefix@ -exec_prefix=@exec_prefix@ -BINDIR=@bindir@ - -# Where to install the man page -MANDIR=@mandir@ - -# Other variables set by ./configure -OCAMLC = @OCAMLC@ -OCAMLOPT = @OCAMLOPT@ -OCAMLDEP = @OCAMLDEP@ -OCAMLDOC = @OCAMLDOC@ -OCAMLLEX = @OCAMLLEX@ -OCAMLYACC= @OCAMLYACC@ -OCAMLLIB = @OCAMLLIB@ -OCAMLBEST= @OCAMLBEST@ -OCAMLVERSION = @OCAMLVERSION@ -OCAMLWEB = @OCAMLWEB@ -OCAMLWIN32 = @OCAMLWIN32@ -OCAMLFIND = @OCAMLFIND@ -EXE = @EXE@ -LIBEXT = @LIBEXT@ -OBJEXT = @OBJEXT@ - -# Others global variables -SRCDIR = src -LIBDIR = lib - -INCLUDES= -I $(SRCDIR) -I $(LIBDIR) -BFLAGS = $(INCLUDES) -OFLAGS = $(INCLUDES) @FORPACK@ - -# main target -############# - -NAME=ocamlgraph - -all: byte $(OCAMLBEST) -#all: byte $(OCAMLBEST) editor-@LABLGTK2@ - -# bytecode and native-code compilation -###################################### - -LIB= unionfind heap bitv -LIB:=$(patsubst %, $(LIBDIR)/%.cmo, $(LIB)) - -CMO = util blocks persistent imperative \ - delaunay builder classic rand oper \ - gpath traverse gcoloring topological components kruskal flow \ - graphviz gml dot_parser dot_lexer dot pack \ - gmap minsep cliquetree mcs_m md strat -CMO := $(LIB) $(patsubst %, $(SRCDIR)/%.cmo, $(CMO)) - -CMX = $(CMO:.cmo=.cmx) -CMA = graph.cma -CMXA = graph.cmxa - -CMI = sig dot_ast sig_pack -CMI := $(patsubst %, src/%.cmi, $(CMI)) - -GENERATED = META \ - src/gml.ml src/version.ml \ - src/dot_parser.ml src/dot_parser.mli src/dot_lexer.ml - -byte: $(CMA) -opt: $(CMXA) - -graph.cma: graph.cmo - $(OCAMLC) $(INCLUDES) -a -o $@ $^ - -graph.cmxa: graph.cmx - $(OCAMLOPT) $(INCLUDES) -a -o $@ $^ - -graph.cmo: $(CMI) $(CMO) - $(OCAMLC) $(INCLUDES) -pack -o $@ $^ - -graph.cmx: $(CMI) $(CMX) - $(OCAMLOPT) $(INCLUDES) -pack -o $@ $^ - -EXAMPLESBIN=bin/demo.$(OCAMLBEST) bin/demo_planar.$(OCAMLBEST) \ - bin/bench.$(OCAMLBEST) bin/color.$(OCAMLBEST) bin/sudoku.$(OCAMLBEST) \ - bin/test.$(OCAMLBEST) - -.PHONY: examples -examples: $(EXAMPLESBIN) - -.PHONY: demo -demo: bin/demo.$(OCAMLBEST) - -bin/demo.byte: $(CMA) examples/demo.cmo - $(OCAMLC) -o $@ $^ - -bin/demo.opt: $(CMXA) examples/demo.cmx - $(OCAMLOPT) -o $@ $^ - -bin/demo_planar.byte: $(CMA) examples/demo_planar.cmo - $(OCAMLC) -o $@ graphics.cma unix.cma $^ - -bin/demo_planar.opt: $(CMXA) examples/demo_planar.cmx - $(OCAMLOPT) -o $@ graphics.cmxa unix.cmxa $^ - -bin/color.byte: $(CMA) examples/color.cmo - $(OCAMLC) -o $@ graphics.cma unix.cma $^ - -bin/color.opt: $(CMXA) examples/color.cmx - $(OCAMLOPT) -o $@ graphics.cmxa unix.cmxa $^ - -bin/sudoku.byte: $(CMA) examples/sudoku.cmo - $(OCAMLC) -o $@ graphics.cma unix.cma $^ - -bin/sudoku.opt: $(CMXA) examples/sudoku.cmx - $(OCAMLOPT) -o $@ graphics.cmxa unix.cmxa $^ - -test: $(CMA) tests/test.ml - ocaml unix.cma graphics.cma $^ - -bin/test.byte: $(CMA) tests/test.cmo - $(OCAMLC) -g -unsafe -o $@ unix.cma graphics.cma $^ - -bin/test.opt: $(CMXA) tests/test.cmx - $(OCAMLOPT) -unsafe -inline 100 -o $@ unix.cmxa graphics.cmxa $^ - -bench: bin/bench.$(OCAMLBEST) - bin/bench.opt - -bin/bench.opt: $(CMXA) tests/bench.ml - $(OCAMLOPT) -unsafe -inline 100 -o $@ unix.cmxa $^ - -check: $(CMA) tests/check.ml - ocaml $^ - -# gtk2 graph editor - -ED_DIR=editor - -editor-no: -editor-yes: $(ED_DIR)/editor.$(OCAMLBEST) - -editor: $(ED_DIR)/editor.byte editor-yes - -ED_CMO = ed_hyper ed_graph ed_draw ed_display ed_main -ED_CMO:= $(patsubst %, $(ED_DIR)/%.cmo, $(ED_CMO)) -ED_CMX = $(ED_CMO:.cmo=.cmx) - -ED_INCLUDES = @INCLUDEGTK2@ -I +threads -I $(ED_DIR) - -$(ED_CMO): BFLAGS+= $(ED_INCLUDES) -$(ED_CMX): OFLAGS+= $(ED_INCLUDES) - -$(ED_DIR)/editor.byte: $(CMA) $(ED_CMO) - $(OCAMLC) -g -o $@ @INCLUDEGTK2@ \ - lablgtk.cma lablgnomecanvas.cma unix.cma $^ - -$(ED_DIR)/editor.opt: $(CMXA) $(ED_CMX) - $(OCAMLOPT) -o $@ @INCLUDEGTK2@ \ - lablgtk.cmxa lablgnomecanvas.cmxa unix.cmxa $^ - -VERSION=0.99b - -src/version.ml: Makefile - echo "let version = \""$(VERSION)"\"" > $@ - echo "let date = \""`date`"\"" >> $@ - -META: META.in Makefile - sed -e s/VERSION/$(VERSION)/ -e s/CMA/$(CMA)/ -e s/CMXA/$(CMXA)/ \ - $@.in > $@ - -# Additional rules -################## - -EXAMPLES = demo color demo_planar sudoku -EXAMPLES:= $(patsubst %, examples/%.ml, $(EXAMPLES)) - -TESTS = test check -TESTS := $(patsubst %, tests/%.ml, $(TESTS)) - -DPD_GRAPH_ML= $(TESTS) $(EXAMPLES) - -$(DPD_GRAPH_ML:.ml=.cmo): $(CMA) -$(DPD_GRAPH_ML:.ml=.cmx): $(CMXA) - -# installation -############## - -install: install-$(OCAMLBEST) install-byte - -install-byte: - cp -f graph.cmo graph.cmi $(CMA) "$(OCAMLLIB)" - -install-opt: install-byte - cp -f graph$(LIBEXT) graph.cmx $(CMXA) "$(OCAMLLIB)" - -install-findlib: META -ifdef OCAMLFIND - $(OCAMLFIND) install ocamlgraph META *.mli \ - graph$(LIBEXT) graph.cmx graph.cmo graph.cmi $(CMA) $(CMXA) -endif - -# documentation -############### - -DOCFILES=$(NAME).ps $(NAME).html - -NODOC = util blocks dot_parser dot_lexer -NODOC := $(patsubst %, $(SRCDIR)/%.cmo, $(NODOC)) -DOC_CMO = $(filter-out $(NODOC) $(LIB), $(CMO)) -DOC_SRC = $(CMI:.cmi=.mli) $(DOC_CMO:.cmo=.mli) $(DOC_CMO:.cmo=.ml) - -.PHONY: doc -doc: $(DOC_CMO) - mkdir -p doc - rm -f doc/* - $(OCAMLDOC) -d doc -html $(INCLUDES) $(DOC_SRC) - -# literate programming -$(NAME).tex: $(DOC_SRC) - $(OCAMLWEB) -o $@ $^ - -wc: - ocamlwc -p $(SRCDIRC)/*.mli $(SRCDIRC)/*.ml - -# file headers -############## -headers: - headache -c misc/headache_config.txt -h misc/header.txt \ - Makefile.in configure.in README \ - $(LIBDIR)*.ml $(LIBDIR)*.ml[ily] \ - $(SRCDIR)*.ml $(SRCDIR)*.ml[ily] \ - $(ED_DIR)/*.ml $(ED_DIR)/*.mli \ - -# export -######## - -EXPORTDIR=$(NAME)-$(VERSION) -TAR=$(EXPORTDIR).tar - -FTP = $$HOME/ftp/$(NAME) -WWW = $$HOME/WWW/$(NAME) - -FILES = src/*.ml* lib/*.ml* Makefile.in configure configure.in META.in \ - .depend editor/ed_*.ml* editor/Makefile \ - editor/tests/*.dot editor/tests/*.gml \ - examples/*.ml tests/*.ml \ - .depend README FAQ CREDITS INSTALL COPYING LICENSE CHANGES - -export: source export-doc export-web export-delaunay - -source: - mkdir -p export - cd export; rm -rf $(EXPORTDIR) - mkdir -p export/$(EXPORTDIR)/bin - cp --parents $(FILES) export/$(EXPORTDIR) - cd export ; tar cf $(TAR) $(EXPORTDIR) ; gzip -f --best $(TAR) - cp export/$(TAR).gz $(FTP) - cp README FAQ CREDITS COPYING LICENSE CHANGES $(EXAMPLES) $(FTP) - -www/version.prehtml: Makefile.in - echo "<#def version>$(VERSION)" > www/version.prehtml - -export-web: www/version.prehtml - make -C www install - -export-doc: $(DOC_CMO) - rm -f $(WWW)/doc/* - -$(OCAMLDOC) -d $(WWW)/doc -html $(INCLUDES) $(DOC_SRC) - -MISCFTP = $(HOME)/WWW/ftp/ocaml/misc -DELAUNAY=delaunay.ml delaunay.mli -export-delaunay: - cd src; cp -f $(DELAUNAY) $(MISCFTP) - cd src; caml2html -d $(MISCFTP) $(DELAUNAY) - -# generic rules -############### - -.SUFFIXES: .mli .ml .cmi .cmo .cmx .mll .mly .tex .dvi .ps .html - -.mli.cmi: - $(OCAMLC) -c $(BFLAGS) $< - -.ml.cmo: - $(OCAMLC) -c $(BFLAGS) $< - -.ml.o: - $(OCAMLOPT) -c $(OFLAGS) $< - -.ml.cmx: - $(OCAMLOPT) -c $(OFLAGS) $< - -.mll.ml: - $(OCAMLLEX) $< - -.mly.ml: - $(OCAMLYACC) -v $< - -.mly.mli: - $(OCAMLYACC) -v $< - -.tex.dvi: - latex $< && latex $< - -.dvi.ps: - dvips $< -o $@ - -.tex.html: - hevea $< - -# Emacs tags -############ - -otags: - otags -r src editor - -tags: - find . -name "*.ml*" | sort -r | xargs \ - etags "--regex=/let[ \t]+\([^ \t]+\)/\1/" \ - "--regex=/let[ \t]+rec[ \t]+\([^ \t]+\)/\1/" \ - "--regex=/and[ \t]+\([^ \t]+\)/\1/" \ - "--regex=/type[ \t]+\([^ \t]+\)/\1/" \ - "--regex=/exception[ \t]+\([^ \t]+\)/\1/" \ - "--regex=/val[ \t]+\([^ \t]+\)/\1/" \ - "--regex=/module[ \t]+\([^ \t]+\)/\1/" - -# Makefile is rebuilt whenever Makefile.in or configure.in is modified -###################################################################### - -Makefile: Makefile.in config.status - if test -e $@; then chmod a+w $@; fi - ./config.status - chmod a-w $@ - -config.status: configure - ./config.status --recheck - -configure: configure.in - autoconf - -# clean -####### - -clean: - rm -f *~ - for d in $(SRCDIR) $(LIBDIR) $(ED_DIR) tests examples; do \ - rm -f $$d/*.cm[iox] $$d/*$(OBJEXT) $$d/*~; \ - done - rm -f $(GENERATED) $(SRCDIR)/dot_parser.output - rm -f graph.*a graph$(LIBEXT) bin/$(NAME).byte bin/$(NAME).opt - rm -f *.haux *.aux *.log $(NAME).tex $(NAME).dvi $(DOCFILES) - rm -f $(EXAMPLESBIN) - -dist-clean distclean:: clean - rm -f Makefile config.cache config.log config.status *.byte *.opt - -svnclean svn-clean:: dist-clean - rm -f config.* configure configure.lineno - -# depend -######## - -.PHONY: depend -.depend depend: $(GENERATED) - rm -f .depend - $(OCAMLDEP) $(INCLUDES) \ - $(LIBDIR)/*.ml $(LIBDIR)/*.mli \ - $(SRCDIR)/*.ml $(SRCDIR)/*.mli \ - $(ED_DIR)/*.mli $(ED_DIR)/*.ml > .depend - -include .depend diff --git a/external/ocamlgraph/configure b/external/ocamlgraph/configure deleted file mode 100644 --- a/external/ocamlgraph/configure +++ /dev/null @@ -1,3485 +0,0 @@ -#! /bin/sh -# Guess values for system-dependent variables and create Makefiles. -# Generated by GNU Autoconf 2.68. -# -# -# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001, -# 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software -# Foundation, Inc. -# -# -# This configure script is free software; the Free Software Foundation -# gives unlimited permission to copy, distribute and modify it. -## -------------------- ## -## M4sh Initialization. ## -## -------------------- ## - -# Be more Bourne compatible -DUALCASE=1; export DUALCASE # for MKS sh -if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then : - emulate sh - NULLCMD=: - # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which - # is contrary to our usage. Disable this feature. - alias -g '${1+"$@"}'='"$@"' - setopt NO_GLOB_SUBST -else - case `(set -o) 2>/dev/null` in #( - *posix*) : - set -o posix ;; #( - *) : - ;; -esac -fi - - -as_nl=' -' -export as_nl -# Printing a long string crashes Solaris 7 /usr/bin/printf. -as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' -as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo -as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo -# Prefer a ksh shell builtin over an external printf program on Solaris, -# but without wasting forks for bash or zsh. -if test -z "$BASH_VERSION$ZSH_VERSION" \ - && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then - as_echo='print -r --' - as_echo_n='print -rn --' -elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then - as_echo='printf %s\n' - as_echo_n='printf %s' -else - if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then - as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' - as_echo_n='/usr/ucb/echo -n' - else - as_echo_body='eval expr "X$1" : "X\\(.*\\)"' - as_echo_n_body='eval - arg=$1; - case $arg in #( - *"$as_nl"*) - expr "X$arg" : "X\\(.*\\)$as_nl"; - arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; - esac; - expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" - ' - export as_echo_n_body - as_echo_n='sh -c $as_echo_n_body as_echo' - fi - export as_echo_body - as_echo='sh -c $as_echo_body as_echo' -fi - -# The user is always right. -if test "${PATH_SEPARATOR+set}" != set; then - PATH_SEPARATOR=: - (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { - (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || - PATH_SEPARATOR=';' - } -fi - - -# IFS -# We need space, tab and new line, in precisely that order. Quoting is -# there to prevent editors from complaining about space-tab. -# (If _AS_PATH_WALK were called with IFS unset, it would disable word -# splitting by setting IFS to empty value.) -IFS=" "" $as_nl" - -# Find who we are. Look in the path if we contain no directory separator. -as_myself= -case $0 in #(( - *[\\/]* ) as_myself=$0 ;; - *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break - done -IFS=$as_save_IFS - - ;; -esac -# We did not find ourselves, most probably we were run as `sh COMMAND' -# in which case we are not to be found in the path. -if test "x$as_myself" = x; then - as_myself=$0 -fi -if test ! -f "$as_myself"; then - $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 - exit 1 -fi - -# Unset variables that we do not need and which cause bugs (e.g. in -# pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" -# suppresses any "Segmentation fault" message there. '((' could -# trigger a bug in pdksh 5.2.14. -for as_var in BASH_ENV ENV MAIL MAILPATH -do eval test x\${$as_var+set} = xset \ - && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : -done -PS1='$ ' -PS2='> ' -PS4='+ ' - -# NLS nuisances. -LC_ALL=C -export LC_ALL -LANGUAGE=C -export LANGUAGE - -# CDPATH. -(unset CDPATH) >/dev/null 2>&1 && unset CDPATH - -if test "x$CONFIG_SHELL" = x; then - as_bourne_compatible="if test -n \"\${ZSH_VERSION+set}\" && (emulate sh) >/dev/null 2>&1; then : - emulate sh - NULLCMD=: - # Pre-4.2 versions of Zsh do word splitting on \${1+\"\$@\"}, which - # is contrary to our usage. Disable this feature. - alias -g '\${1+\"\$@\"}'='\"\$@\"' - setopt NO_GLOB_SUBST -else - case \`(set -o) 2>/dev/null\` in #( - *posix*) : - set -o posix ;; #( - *) : - ;; -esac -fi -" - as_required="as_fn_return () { (exit \$1); } -as_fn_success () { as_fn_return 0; } -as_fn_failure () { as_fn_return 1; } -as_fn_ret_success () { return 0; } -as_fn_ret_failure () { return 1; } - -exitcode=0 -as_fn_success || { exitcode=1; echo as_fn_success failed.; } -as_fn_failure && { exitcode=1; echo as_fn_failure succeeded.; } -as_fn_ret_success || { exitcode=1; echo as_fn_ret_success failed.; } -as_fn_ret_failure && { exitcode=1; echo as_fn_ret_failure succeeded.; } -if ( set x; as_fn_ret_success y && test x = \"\$1\" ); then : - -else - exitcode=1; echo positional parameters were not saved. -fi -test x\$exitcode = x0 || exit 1" - as_suggested=" as_lineno_1=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_1a=\$LINENO - as_lineno_2=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_2a=\$LINENO - eval 'test \"x\$as_lineno_1'\$as_run'\" != \"x\$as_lineno_2'\$as_run'\" && - test \"x\`expr \$as_lineno_1'\$as_run' + 1\`\" = \"x\$as_lineno_2'\$as_run'\"' || exit 1" - if (eval "$as_required") 2>/dev/null; then : - as_have_required=yes -else - as_have_required=no -fi - if test x$as_have_required = xyes && (eval "$as_suggested") 2>/dev/null; then : - -else - as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -as_found=false -for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - as_found=: - case $as_dir in #( - /*) - for as_base in sh bash ksh sh5; do - # Try only shells that exist, to save several forks. - as_shell=$as_dir/$as_base - if { test -f "$as_shell" || test -f "$as_shell.exe"; } && - { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$as_shell"; } 2>/dev/null; then : - CONFIG_SHELL=$as_shell as_have_required=yes - if { $as_echo "$as_bourne_compatible""$as_suggested" | as_run=a "$as_shell"; } 2>/dev/null; then : - break 2 -fi -fi - done;; - esac - as_found=false -done -$as_found || { if { test -f "$SHELL" || test -f "$SHELL.exe"; } && - { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$SHELL"; } 2>/dev/null; then : - CONFIG_SHELL=$SHELL as_have_required=yes -fi; } -IFS=$as_save_IFS - - - if test "x$CONFIG_SHELL" != x; then : - # We cannot yet assume a decent shell, so we have to provide a - # neutralization value for shells without unset; and this also - # works around shells that cannot unset nonexistent variables. - # Preserve -v and -x to the replacement shell. - BASH_ENV=/dev/null - ENV=/dev/null - (unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV - export CONFIG_SHELL - case $- in # (((( - *v*x* | *x*v* ) as_opts=-vx ;; - *v* ) as_opts=-v ;; - *x* ) as_opts=-x ;; - * ) as_opts= ;; - esac - exec "$CONFIG_SHELL" $as_opts "$as_myself" ${1+"$@"} -fi - - if test x$as_have_required = xno; then : - $as_echo "$0: This script requires a shell more modern than all" - $as_echo "$0: the shells that I found on your system." - if test x${ZSH_VERSION+set} = xset ; then - $as_echo "$0: In particular, zsh $ZSH_VERSION has bugs and should" - $as_echo "$0: be upgraded to zsh 4.3.4 or later." - else - $as_echo "$0: Please tell bug-autoconf@gnu.org about your system, -$0: including any error possibly output before this -$0: message. Then install a modern shell, or manually run -$0: the script under such a shell if you do have one." - fi - exit 1 -fi -fi -fi -SHELL=${CONFIG_SHELL-/bin/sh} -export SHELL -# Unset more variables known to interfere with behavior of common tools. -CLICOLOR_FORCE= GREP_OPTIONS= -unset CLICOLOR_FORCE GREP_OPTIONS - -## --------------------- ## -## M4sh Shell Functions. ## -## --------------------- ## -# as_fn_unset VAR -# --------------- -# Portably unset VAR. -as_fn_unset () -{ - { eval $1=; unset $1;} -} -as_unset=as_fn_unset - -# as_fn_set_status STATUS -# ----------------------- -# Set $? to STATUS, without forking. -as_fn_set_status () -{ - return $1 -} # as_fn_set_status - -# as_fn_exit STATUS -# ----------------- -# Exit the shell with STATUS, even in a "trap 0" or "set -e" context. -as_fn_exit () -{ - set +e - as_fn_set_status $1 - exit $1 -} # as_fn_exit - -# as_fn_mkdir_p -# ------------- -# Create "$as_dir" as a directory, including parents if necessary. -as_fn_mkdir_p () -{ - - case $as_dir in #( - -*) as_dir=./$as_dir;; - esac - test -d "$as_dir" || eval $as_mkdir_p || { - as_dirs= - while :; do - case $as_dir in #( - *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( - *) as_qdir=$as_dir;; - esac - as_dirs="'$as_qdir' $as_dirs" - as_dir=`$as_dirname -- "$as_dir" || -$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ - X"$as_dir" : 'X\(//\)[^/]' \| \ - X"$as_dir" : 'X\(//\)$' \| \ - X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || -$as_echo X"$as_dir" | - sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ - s//\1/ - q - } - /^X\(\/\/\)[^/].*/{ - s//\1/ - q - } - /^X\(\/\/\)$/{ - s//\1/ - q - } - /^X\(\/\).*/{ - s//\1/ - q - } - s/.*/./; q'` - test -d "$as_dir" && break - done - test -z "$as_dirs" || eval "mkdir $as_dirs" - } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" - - -} # as_fn_mkdir_p -# as_fn_append VAR VALUE -# ---------------------- -# Append the text in VALUE to the end of the definition contained in VAR. Take -# advantage of any shell optimizations that allow amortized linear growth over -# repeated appends, instead of the typical quadratic growth present in naive -# implementations. -if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then : - eval 'as_fn_append () - { - eval $1+=\$2 - }' -else - as_fn_append () - { - eval $1=\$$1\$2 - } -fi # as_fn_append - -# as_fn_arith ARG... -# ------------------ -# Perform arithmetic evaluation on the ARGs, and store the result in the -# global $as_val. Take advantage of shells that can avoid forks. The arguments -# must be portable across $(()) and expr. -if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then : - eval 'as_fn_arith () - { - as_val=$(( $* )) - }' -else - as_fn_arith () - { - as_val=`expr "$@" || test $? -eq 1` - } -fi # as_fn_arith - - -# as_fn_error STATUS ERROR [LINENO LOG_FD] -# ---------------------------------------- -# Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are -# provided, also output the error to LOG_FD, referencing LINENO. Then exit the -# script with STATUS, using 1 if that was 0. -as_fn_error () -{ - as_status=$1; test $as_status -eq 0 && as_status=1 - if test "$4"; then - as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack - $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 - fi - $as_echo "$as_me: error: $2" >&2 - as_fn_exit $as_status -} # as_fn_error - -if expr a : '\(a\)' >/dev/null 2>&1 && - test "X`expr 00001 : '.*\(...\)'`" = X001; then - as_expr=expr -else - as_expr=false -fi - -if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then - as_basename=basename -else - as_basename=false -fi - -if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then - as_dirname=dirname -else - as_dirname=false -fi - -as_me=`$as_basename -- "$0" || -$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ - X"$0" : 'X\(//\)$' \| \ - X"$0" : 'X\(/\)' \| . 2>/dev/null || -$as_echo X/"$0" | - sed '/^.*\/\([^/][^/]*\)\/*$/{ - s//\1/ - q - } - /^X\/\(\/\/\)$/{ - s//\1/ - q - } - /^X\/\(\/\).*/{ - s//\1/ - q - } - s/.*/./; q'` - -# Avoid depending upon Character Ranges. -as_cr_letters='abcdefghijklmnopqrstuvwxyz' -as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' -as_cr_Letters=$as_cr_letters$as_cr_LETTERS -as_cr_digits='0123456789' -as_cr_alnum=$as_cr_Letters$as_cr_digits - - - as_lineno_1=$LINENO as_lineno_1a=$LINENO - as_lineno_2=$LINENO as_lineno_2a=$LINENO - eval 'test "x$as_lineno_1'$as_run'" != "x$as_lineno_2'$as_run'" && - test "x`expr $as_lineno_1'$as_run' + 1`" = "x$as_lineno_2'$as_run'"' || { - # Blame Lee E. McMahon (1931-1989) for sed's syntax. :-) - sed -n ' - p - /[$]LINENO/= - ' <$as_myself | - sed ' - s/[$]LINENO.*/&-/ - t lineno - b - :lineno - N - :loop - s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/ - t loop - s/-\n.*// - ' >$as_me.lineno && - chmod +x "$as_me.lineno" || - { $as_echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2; as_fn_exit 1; } - - # Don't try to exec as it changes $[0], causing all sort of problems - # (the dirname of $[0] is not the place where we might find the - # original and so on. Autoconf is especially sensitive to this). - . "./$as_me.lineno" - # Exit status is that of the last command. - exit -} - -ECHO_C= ECHO_N= ECHO_T= -case `echo -n x` in #((((( --n*) - case `echo 'xy\c'` in - *c*) ECHO_T=' ';; # ECHO_T is single tab character. - xy) ECHO_C='\c';; - *) echo `echo ksh88 bug on AIX 6.1` > /dev/null - ECHO_T=' ';; - esac;; -*) - ECHO_N='-n';; -esac - -rm -f conf$$ conf$$.exe conf$$.file -if test -d conf$$.dir; then - rm -f conf$$.dir/conf$$.file -else - rm -f conf$$.dir - mkdir conf$$.dir 2>/dev/null -fi -if (echo >conf$$.file) 2>/dev/null; then - if ln -s conf$$.file conf$$ 2>/dev/null; then - as_ln_s='ln -s' - # ... but there are two gotchas: - # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. - # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. - # In both cases, we have to default to `cp -p'. - ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || - as_ln_s='cp -p' - elif ln conf$$.file conf$$ 2>/dev/null; then - as_ln_s=ln - else - as_ln_s='cp -p' - fi -else - as_ln_s='cp -p' -fi -rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file -rmdir conf$$.dir 2>/dev/null - -if mkdir -p . 2>/dev/null; then - as_mkdir_p='mkdir -p "$as_dir"' -else - test -d ./-p && rmdir ./-p - as_mkdir_p=false -fi - -if test -x / >/dev/null 2>&1; then - as_test_x='test -x' -else - if ls -dL / >/dev/null 2>&1; then - as_ls_L_option=L - else - as_ls_L_option= - fi - as_test_x=' - eval sh -c '\'' - if test -d "$1"; then - test -d "$1/."; - else - case $1 in #( - -*)set "./$1";; - esac; - case `ls -ld'$as_ls_L_option' "$1" 2>/dev/null` in #(( - ???[sx]*):;;*)false;;esac;fi - '\'' sh - ' -fi -as_executable_p=$as_test_x - -# Sed expression to map a string onto a valid CPP name. -as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" - -# Sed expression to map a string onto a valid variable name. -as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" - - -test -n "$DJDIR" || exec 7<&0 &1 - -# Name of the host. -# hostname on some systems (SVR3.2, old GNU/Linux) returns a bogus exit status, -# so uname gets run too. -ac_hostname=`(hostname || uname -n) 2>/dev/null | sed 1q` - -# -# Initializations. -# -ac_default_prefix=/usr/local -ac_clean_files= -ac_config_libobj_dir=. -LIBOBJS= -cross_compiling=no -subdirs= -MFLAGS= -MAKEFLAGS= - -# Identity of this package. -PACKAGE_NAME= -PACKAGE_TARNAME= -PACKAGE_VERSION= -PACKAGE_STRING= -PACKAGE_BUGREPORT= -PACKAGE_URL= - -ac_unique_file="src/sig.mli" -ac_subst_vars='LTLIBOBJS -LIBOBJS -INCLUDEGTK2 -FORPACK -OBJEXT -LIBEXT -EXE -OCAMLWIN32 -OCAMLLIB -OCAMLVERSION -OCAMLBEST -LABLGTK2 -OCAMLFIND -OCAMLWEB -OCAMLDOCOPT -OCAMLDOC -OCAMLYACC -OCAMLLEXDOTOPT -OCAMLLEX -OCAMLDEP -OCAMLOPTDOTOPT -OCAMLCDOTOPT -OCAMLOPT -OCAMLC -target_alias -host_alias -build_alias -LIBS -ECHO_T -ECHO_N -ECHO_C -DEFS -mandir -localedir -libdir -psdir -pdfdir -dvidir -htmldir -infodir -docdir -oldincludedir -includedir -localstatedir -sharedstatedir -sysconfdir -datadir -datarootdir -libexecdir -sbindir -bindir -program_transform_name -prefix -exec_prefix -PACKAGE_URL -PACKAGE_BUGREPORT -PACKAGE_STRING -PACKAGE_VERSION -PACKAGE_TARNAME -PACKAGE_NAME -PATH_SEPARATOR -SHELL' -ac_subst_files='' -ac_user_opts=' -enable_option_checking -' - ac_precious_vars='build_alias -host_alias -target_alias' - - -# Initialize some variables set by options. -ac_init_help= -ac_init_version=false -ac_unrecognized_opts= -ac_unrecognized_sep= -# The variables have the same names as the options, with -# dashes changed to underlines. -cache_file=/dev/null -exec_prefix=NONE -no_create= -no_recursion= -prefix=NONE -program_prefix=NONE -program_suffix=NONE -program_transform_name=s,x,x, -silent= -site= -srcdir= -verbose= -x_includes=NONE -x_libraries=NONE - -# Installation directory options. -# These are left unexpanded so users can "make install exec_prefix=/foo" -# and all the variables that are supposed to be based on exec_prefix -# by default will actually change. -# Use braces instead of parens because sh, perl, etc. also accept them. -# (The list follows the same order as the GNU Coding Standards.) -bindir='${exec_prefix}/bin' -sbindir='${exec_prefix}/sbin' -libexecdir='${exec_prefix}/libexec' -datarootdir='${prefix}/share' -datadir='${datarootdir}' -sysconfdir='${prefix}/etc' -sharedstatedir='${prefix}/com' -localstatedir='${prefix}/var' -includedir='${prefix}/include' -oldincludedir='/usr/include' -docdir='${datarootdir}/doc/${PACKAGE}' -infodir='${datarootdir}/info' -htmldir='${docdir}' -dvidir='${docdir}' -pdfdir='${docdir}' -psdir='${docdir}' -libdir='${exec_prefix}/lib' -localedir='${datarootdir}/locale' -mandir='${datarootdir}/man' - -ac_prev= -ac_dashdash= -for ac_option -do - # If the previous option needs an argument, assign it. - if test -n "$ac_prev"; then - eval $ac_prev=\$ac_option - ac_prev= - continue - fi - - case $ac_option in - *=?*) ac_optarg=`expr "X$ac_option" : '[^=]*=\(.*\)'` ;; - *=) ac_optarg= ;; - *) ac_optarg=yes ;; - esac - - # Accept the important Cygnus configure options, so we can diagnose typos. - - case $ac_dashdash$ac_option in - --) - ac_dashdash=yes ;; - - -bindir | --bindir | --bindi | --bind | --bin | --bi) - ac_prev=bindir ;; - -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*) - bindir=$ac_optarg ;; - - -build | --build | --buil | --bui | --bu) - ac_prev=build_alias ;; - -build=* | --build=* | --buil=* | --bui=* | --bu=*) - build_alias=$ac_optarg ;; - - -cache-file | --cache-file | --cache-fil | --cache-fi \ - | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) - ac_prev=cache_file ;; - -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ - | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*) - cache_file=$ac_optarg ;; - - --config-cache | -C) - cache_file=config.cache ;; - - -datadir | --datadir | --datadi | --datad) - ac_prev=datadir ;; - -datadir=* | --datadir=* | --datadi=* | --datad=*) - datadir=$ac_optarg ;; - - -datarootdir | --datarootdir | --datarootdi | --datarootd | --dataroot \ - | --dataroo | --dataro | --datar) - ac_prev=datarootdir ;; - -datarootdir=* | --datarootdir=* | --datarootdi=* | --datarootd=* \ - | --dataroot=* | --dataroo=* | --dataro=* | --datar=*) - datarootdir=$ac_optarg ;; - - -disable-* | --disable-*) - ac_useropt=`expr "x$ac_option" : 'x-*disable-\(.*\)'` - # Reject names that are not valid shell variable names. - expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && - as_fn_error $? "invalid feature name: $ac_useropt" - ac_useropt_orig=$ac_useropt - ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` - case $ac_user_opts in - *" -"enable_$ac_useropt" -"*) ;; - *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--disable-$ac_useropt_orig" - ac_unrecognized_sep=', ';; - esac - eval enable_$ac_useropt=no ;; - - -docdir | --docdir | --docdi | --doc | --do) - ac_prev=docdir ;; - -docdir=* | --docdir=* | --docdi=* | --doc=* | --do=*) - docdir=$ac_optarg ;; - - -dvidir | --dvidir | --dvidi | --dvid | --dvi | --dv) - ac_prev=dvidir ;; - -dvidir=* | --dvidir=* | --dvidi=* | --dvid=* | --dvi=* | --dv=*) - dvidir=$ac_optarg ;; - - -enable-* | --enable-*) - ac_useropt=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'` - # Reject names that are not valid shell variable names. - expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && - as_fn_error $? "invalid feature name: $ac_useropt" - ac_useropt_orig=$ac_useropt - ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` - case $ac_user_opts in - *" -"enable_$ac_useropt" -"*) ;; - *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--enable-$ac_useropt_orig" - ac_unrecognized_sep=', ';; - esac - eval enable_$ac_useropt=\$ac_optarg ;; - - -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ - | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ - | --exec | --exe | --ex) - ac_prev=exec_prefix ;; - -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \ - | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \ - | --exec=* | --exe=* | --ex=*) - exec_prefix=$ac_optarg ;; - - -gas | --gas | --ga | --g) - # Obsolete; use --with-gas. - with_gas=yes ;; - - -help | --help | --hel | --he | -h) - ac_init_help=long ;; - -help=r* | --help=r* | --hel=r* | --he=r* | -hr*) - ac_init_help=recursive ;; - -help=s* | --help=s* | --hel=s* | --he=s* | -hs*) - ac_init_help=short ;; - - -host | --host | --hos | --ho) - ac_prev=host_alias ;; - -host=* | --host=* | --hos=* | --ho=*) - host_alias=$ac_optarg ;; - - -htmldir | --htmldir | --htmldi | --htmld | --html | --htm | --ht) - ac_prev=htmldir ;; - -htmldir=* | --htmldir=* | --htmldi=* | --htmld=* | --html=* | --htm=* \ - | --ht=*) - htmldir=$ac_optarg ;; - - -includedir | --includedir | --includedi | --included | --include \ - | --includ | --inclu | --incl | --inc) - ac_prev=includedir ;; - -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \ - | --includ=* | --inclu=* | --incl=* | --inc=*) - includedir=$ac_optarg ;; - - -infodir | --infodir | --infodi | --infod | --info | --inf) - ac_prev=infodir ;; - -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*) - infodir=$ac_optarg ;; - - -libdir | --libdir | --libdi | --libd) - ac_prev=libdir ;; - -libdir=* | --libdir=* | --libdi=* | --libd=*) - libdir=$ac_optarg ;; - - -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \ - | --libexe | --libex | --libe) - ac_prev=libexecdir ;; - -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \ - | --libexe=* | --libex=* | --libe=*) - libexecdir=$ac_optarg ;; - - -localedir | --localedir | --localedi | --localed | --locale) - ac_prev=localedir ;; - -localedir=* | --localedir=* | --localedi=* | --localed=* | --locale=*) - localedir=$ac_optarg ;; - - -localstatedir | --localstatedir | --localstatedi | --localstated \ - | --localstate | --localstat | --localsta | --localst | --locals) - ac_prev=localstatedir ;; - -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \ - | --localstate=* | --localstat=* | --localsta=* | --localst=* | --locals=*) - localstatedir=$ac_optarg ;; - - -mandir | --mandir | --mandi | --mand | --man | --ma | --m) - ac_prev=mandir ;; - -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*) - mandir=$ac_optarg ;; - - -nfp | --nfp | --nf) - # Obsolete; use --without-fp. - with_fp=no ;; - - -no-create | --no-create | --no-creat | --no-crea | --no-cre \ - | --no-cr | --no-c | -n) - no_create=yes ;; - - -no-recursion | --no-recursion | --no-recursio | --no-recursi \ - | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) - no_recursion=yes ;; - - -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \ - | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \ - | --oldin | --oldi | --old | --ol | --o) - ac_prev=oldincludedir ;; - -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \ - | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \ - | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*) - oldincludedir=$ac_optarg ;; - - -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) - ac_prev=prefix ;; - -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) - prefix=$ac_optarg ;; - - -program-prefix | --program-prefix | --program-prefi | --program-pref \ - | --program-pre | --program-pr | --program-p) - ac_prev=program_prefix ;; - -program-prefix=* | --program-prefix=* | --program-prefi=* \ - | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*) - program_prefix=$ac_optarg ;; - - -program-suffix | --program-suffix | --program-suffi | --program-suff \ - | --program-suf | --program-su | --program-s) - ac_prev=program_suffix ;; - -program-suffix=* | --program-suffix=* | --program-suffi=* \ - | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*) - program_suffix=$ac_optarg ;; - - -program-transform-name | --program-transform-name \ - | --program-transform-nam | --program-transform-na \ - | --program-transform-n | --program-transform- \ - | --program-transform | --program-transfor \ - | --program-transfo | --program-transf \ - | --program-trans | --program-tran \ - | --progr-tra | --program-tr | --program-t) - ac_prev=program_transform_name ;; - -program-transform-name=* | --program-transform-name=* \ - | --program-transform-nam=* | --program-transform-na=* \ - | --program-transform-n=* | --program-transform-=* \ - | --program-transform=* | --program-transfor=* \ - | --program-transfo=* | --program-transf=* \ - | --program-trans=* | --program-tran=* \ - | --progr-tra=* | --program-tr=* | --program-t=*) - program_transform_name=$ac_optarg ;; - - -pdfdir | --pdfdir | --pdfdi | --pdfd | --pdf | --pd) - ac_prev=pdfdir ;; - -pdfdir=* | --pdfdir=* | --pdfdi=* | --pdfd=* | --pdf=* | --pd=*) - pdfdir=$ac_optarg ;; - - -psdir | --psdir | --psdi | --psd | --ps) - ac_prev=psdir ;; - -psdir=* | --psdir=* | --psdi=* | --psd=* | --ps=*) - psdir=$ac_optarg ;; - - -q | -quiet | --quiet | --quie | --qui | --qu | --q \ - | -silent | --silent | --silen | --sile | --sil) - silent=yes ;; - - -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) - ac_prev=sbindir ;; - -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ - | --sbi=* | --sb=*) - sbindir=$ac_optarg ;; - - -sharedstatedir | --sharedstatedir | --sharedstatedi \ - | --sharedstated | --sharedstate | --sharedstat | --sharedsta \ - | --sharedst | --shareds | --shared | --share | --shar \ - | --sha | --sh) - ac_prev=sharedstatedir ;; - -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \ - | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \ - | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \ - | --sha=* | --sh=*) - sharedstatedir=$ac_optarg ;; - - -site | --site | --sit) - ac_prev=site ;; - -site=* | --site=* | --sit=*) - site=$ac_optarg ;; - - -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) - ac_prev=srcdir ;; - -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) - srcdir=$ac_optarg ;; - - -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \ - | --syscon | --sysco | --sysc | --sys | --sy) - ac_prev=sysconfdir ;; - -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \ - | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*) - sysconfdir=$ac_optarg ;; - - -target | --target | --targe | --targ | --tar | --ta | --t) - ac_prev=target_alias ;; - -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*) - target_alias=$ac_optarg ;; - - -v | -verbose | --verbose | --verbos | --verbo | --verb) - verbose=yes ;; - - -version | --version | --versio | --versi | --vers | -V) - ac_init_version=: ;; - - -with-* | --with-*) - ac_useropt=`expr "x$ac_option" : 'x-*with-\([^=]*\)'` - # Reject names that are not valid shell variable names. - expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && - as_fn_error $? "invalid package name: $ac_useropt" - ac_useropt_orig=$ac_useropt - ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` - case $ac_user_opts in - *" -"with_$ac_useropt" -"*) ;; - *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--with-$ac_useropt_orig" - ac_unrecognized_sep=', ';; - esac - eval with_$ac_useropt=\$ac_optarg ;; - - -without-* | --without-*) - ac_useropt=`expr "x$ac_option" : 'x-*without-\(.*\)'` - # Reject names that are not valid shell variable names. - expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && - as_fn_error $? "invalid package name: $ac_useropt" - ac_useropt_orig=$ac_useropt - ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` - case $ac_user_opts in - *" -"with_$ac_useropt" -"*) ;; - *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--without-$ac_useropt_orig" - ac_unrecognized_sep=', ';; - esac - eval with_$ac_useropt=no ;; - - --x) - # Obsolete; use --with-x. - with_x=yes ;; - - -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \ - | --x-incl | --x-inc | --x-in | --x-i) - ac_prev=x_includes ;; - -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \ - | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*) - x_includes=$ac_optarg ;; - - -x-libraries | --x-libraries | --x-librarie | --x-librari \ - | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l) - ac_prev=x_libraries ;; - -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ - | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) - x_libraries=$ac_optarg ;; - - -*) as_fn_error $? "unrecognized option: \`$ac_option' -Try \`$0 --help' for more information" - ;; - - *=*) - ac_envvar=`expr "x$ac_option" : 'x\([^=]*\)='` - # Reject names that are not valid shell variable names. - case $ac_envvar in #( - '' | [0-9]* | *[!_$as_cr_alnum]* ) - as_fn_error $? "invalid variable name: \`$ac_envvar'" ;; - esac - eval $ac_envvar=\$ac_optarg - export $ac_envvar ;; - - *) - # FIXME: should be removed in autoconf 3.0. - $as_echo "$as_me: WARNING: you should use --build, --host, --target" >&2 - expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null && - $as_echo "$as_me: WARNING: invalid host type: $ac_option" >&2 - : "${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option}" - ;; - - esac -done - -if test -n "$ac_prev"; then - ac_option=--`echo $ac_prev | sed 's/_/-/g'` - as_fn_error $? "missing argument to $ac_option" -fi - -if test -n "$ac_unrecognized_opts"; then - case $enable_option_checking in - no) ;; - fatal) as_fn_error $? "unrecognized options: $ac_unrecognized_opts" ;; - *) $as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2 ;; - esac -fi - -# Check all directory arguments for consistency. -for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \ - datadir sysconfdir sharedstatedir localstatedir includedir \ - oldincludedir docdir infodir htmldir dvidir pdfdir psdir \ - libdir localedir mandir -do - eval ac_val=\$$ac_var - # Remove trailing slashes. - case $ac_val in - */ ) - ac_val=`expr "X$ac_val" : 'X\(.*[^/]\)' \| "X$ac_val" : 'X\(.*\)'` - eval $ac_var=\$ac_val;; - esac - # Be sure to have absolute directory names. - case $ac_val in - [\\/$]* | ?:[\\/]* ) continue;; - NONE | '' ) case $ac_var in *prefix ) continue;; esac;; - esac - as_fn_error $? "expected an absolute directory name for --$ac_var: $ac_val" -done - -# There might be people who depend on the old broken behavior: `$host' -# used to hold the argument of --host etc. -# FIXME: To remove some day. -build=$build_alias -host=$host_alias -target=$target_alias - -# FIXME: To remove some day. -if test "x$host_alias" != x; then - if test "x$build_alias" = x; then - cross_compiling=maybe - $as_echo "$as_me: WARNING: if you wanted to set the --build type, don't use --host. - If a cross compiler is detected then cross compile mode will be used" >&2 - elif test "x$build_alias" != "x$host_alias"; then - cross_compiling=yes - fi -fi - -ac_tool_prefix= -test -n "$host_alias" && ac_tool_prefix=$host_alias- - -test "$silent" = yes && exec 6>/dev/null - - -ac_pwd=`pwd` && test -n "$ac_pwd" && -ac_ls_di=`ls -di .` && -ac_pwd_ls_di=`cd "$ac_pwd" && ls -di .` || - as_fn_error $? "working directory cannot be determined" -test "X$ac_ls_di" = "X$ac_pwd_ls_di" || - as_fn_error $? "pwd does not report name of working directory" - - -# Find the source files, if location was not specified. -if test -z "$srcdir"; then - ac_srcdir_defaulted=yes - # Try the directory containing this script, then the parent directory. - ac_confdir=`$as_dirname -- "$as_myself" || -$as_expr X"$as_myself" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ - X"$as_myself" : 'X\(//\)[^/]' \| \ - X"$as_myself" : 'X\(//\)$' \| \ - X"$as_myself" : 'X\(/\)' \| . 2>/dev/null || -$as_echo X"$as_myself" | - sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ - s//\1/ - q - } - /^X\(\/\/\)[^/].*/{ - s//\1/ - q - } - /^X\(\/\/\)$/{ - s//\1/ - q - } - /^X\(\/\).*/{ - s//\1/ - q - } - s/.*/./; q'` - srcdir=$ac_confdir - if test ! -r "$srcdir/$ac_unique_file"; then - srcdir=.. - fi -else - ac_srcdir_defaulted=no -fi -if test ! -r "$srcdir/$ac_unique_file"; then - test "$ac_srcdir_defaulted" = yes && srcdir="$ac_confdir or .." - as_fn_error $? "cannot find sources ($ac_unique_file) in $srcdir" -fi -ac_msg="sources are in $srcdir, but \`cd $srcdir' does not work" -ac_abs_confdir=`( - cd "$srcdir" && test -r "./$ac_unique_file" || as_fn_error $? "$ac_msg" - pwd)` -# When building in place, set srcdir=. -if test "$ac_abs_confdir" = "$ac_pwd"; then - srcdir=. -fi -# Remove unnecessary trailing slashes from srcdir. -# Double slashes in file names in object file debugging info -# mess up M-x gdb in Emacs. -case $srcdir in -*/) srcdir=`expr "X$srcdir" : 'X\(.*[^/]\)' \| "X$srcdir" : 'X\(.*\)'`;; -esac -for ac_var in $ac_precious_vars; do - eval ac_env_${ac_var}_set=\${${ac_var}+set} - eval ac_env_${ac_var}_value=\$${ac_var} - eval ac_cv_env_${ac_var}_set=\${${ac_var}+set} - eval ac_cv_env_${ac_var}_value=\$${ac_var} -done - -# -# Report the --help message. -# -if test "$ac_init_help" = "long"; then - # Omit some internal or obsolete options to make the list less imposing. - # This message is too long to be a string in the A/UX 3.1 sh. - cat <<_ACEOF -\`configure' configures this package to adapt to many kinds of systems. - -Usage: $0 [OPTION]... [VAR=VALUE]... - -To assign environment variables (e.g., CC, CFLAGS...), specify them as -VAR=VALUE. See below for descriptions of some of the useful variables. - -Defaults for the options are specified in brackets. - -Configuration: - -h, --help display this help and exit - --help=short display options specific to this package - --help=recursive display the short help of all the included packages - -V, --version display version information and exit - -q, --quiet, --silent do not print \`checking ...' messages - --cache-file=FILE cache test results in FILE [disabled] - -C, --config-cache alias for \`--cache-file=config.cache' - -n, --no-create do not create output files - --srcdir=DIR find the sources in DIR [configure dir or \`..'] - -Installation directories: - --prefix=PREFIX install architecture-independent files in PREFIX - [$ac_default_prefix] - --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX - [PREFIX] - -By default, \`make install' will install all the files in -\`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc. You can specify -an installation prefix other than \`$ac_default_prefix' using \`--prefix', -for instance \`--prefix=\$HOME'. - -For better control, use the options below. - -Fine tuning of the installation directories: - --bindir=DIR user executables [EPREFIX/bin] - --sbindir=DIR system admin executables [EPREFIX/sbin] - --libexecdir=DIR program executables [EPREFIX/libexec] - --sysconfdir=DIR read-only single-machine data [PREFIX/etc] - --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com] - --localstatedir=DIR modifiable single-machine data [PREFIX/var] - --libdir=DIR object code libraries [EPREFIX/lib] - --includedir=DIR C header files [PREFIX/include] - --oldincludedir=DIR C header files for non-gcc [/usr/include] - --datarootdir=DIR read-only arch.-independent data root [PREFIX/share] - --datadir=DIR read-only architecture-independent data [DATAROOTDIR] - --infodir=DIR info documentation [DATAROOTDIR/info] - --localedir=DIR locale-dependent data [DATAROOTDIR/locale] - --mandir=DIR man documentation [DATAROOTDIR/man] - --docdir=DIR documentation root [DATAROOTDIR/doc/PACKAGE] - --htmldir=DIR html documentation [DOCDIR] - --dvidir=DIR dvi documentation [DOCDIR] - --pdfdir=DIR pdf documentation [DOCDIR] - --psdir=DIR ps documentation [DOCDIR] -_ACEOF - - cat <<\_ACEOF -_ACEOF -fi - -if test -n "$ac_init_help"; then - - cat <<\_ACEOF - -Report bugs to the package provider. -_ACEOF -ac_status=$? -fi - -if test "$ac_init_help" = "recursive"; then - # If there are subdirs, report their specific --help. - for ac_dir in : $ac_subdirs_all; do test "x$ac_dir" = x: && continue - test -d "$ac_dir" || - { cd "$srcdir" && ac_pwd=`pwd` && srcdir=. && test -d "$ac_dir"; } || - continue - ac_builddir=. - -case "$ac_dir" in -.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; -*) - ac_dir_suffix=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'` - # A ".." for each directory in $ac_dir_suffix. - ac_top_builddir_sub=`$as_echo "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` - case $ac_top_builddir_sub in - "") ac_top_builddir_sub=. ac_top_build_prefix= ;; - *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; - esac ;; -esac -ac_abs_top_builddir=$ac_pwd -ac_abs_builddir=$ac_pwd$ac_dir_suffix -# for backward compatibility: -ac_top_builddir=$ac_top_build_prefix - -case $srcdir in - .) # We are building in place. - ac_srcdir=. - ac_top_srcdir=$ac_top_builddir_sub - ac_abs_top_srcdir=$ac_pwd ;; - [\\/]* | ?:[\\/]* ) # Absolute name. - ac_srcdir=$srcdir$ac_dir_suffix; - ac_top_srcdir=$srcdir - ac_abs_top_srcdir=$srcdir ;; - *) # Relative name. - ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix - ac_top_srcdir=$ac_top_build_prefix$srcdir - ac_abs_top_srcdir=$ac_pwd/$srcdir ;; -esac -ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix - - cd "$ac_dir" || { ac_status=$?; continue; } - # Check for guested configure. - if test -f "$ac_srcdir/configure.gnu"; then - echo && - $SHELL "$ac_srcdir/configure.gnu" --help=recursive - elif test -f "$ac_srcdir/configure"; then - echo && - $SHELL "$ac_srcdir/configure" --help=recursive - else - $as_echo "$as_me: WARNING: no configuration information is in $ac_dir" >&2 - fi || ac_status=$? - cd "$ac_pwd" || { ac_status=$?; break; } - done -fi - -test -n "$ac_init_help" && exit $ac_status -if $ac_init_version; then - cat <<\_ACEOF -configure -generated by GNU Autoconf 2.68 - -Copyright (C) 2010 Free Software Foundation, Inc. -This configure script is free software; the Free Software Foundation -gives unlimited permission to copy, distribute and modify it. -_ACEOF - exit -fi - -## ------------------------ ## -## Autoconf initialization. ## -## ------------------------ ## -cat >config.log <<_ACEOF -This file contains any messages produced by compilers while -running configure, to aid debugging if configure makes a mistake. - -It was created by $as_me, which was -generated by GNU Autoconf 2.68. Invocation command line was - - $ $0 $@ - -_ACEOF -exec 5>>config.log -{ -cat <<_ASUNAME -## --------- ## -## Platform. ## -## --------- ## - -hostname = `(hostname || uname -n) 2>/dev/null | sed 1q` -uname -m = `(uname -m) 2>/dev/null || echo unknown` -uname -r = `(uname -r) 2>/dev/null || echo unknown` -uname -s = `(uname -s) 2>/dev/null || echo unknown` -uname -v = `(uname -v) 2>/dev/null || echo unknown` - -/usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null || echo unknown` -/bin/uname -X = `(/bin/uname -X) 2>/dev/null || echo unknown` - -/bin/arch = `(/bin/arch) 2>/dev/null || echo unknown` -/usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null || echo unknown` -/usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null || echo unknown` -/usr/bin/hostinfo = `(/usr/bin/hostinfo) 2>/dev/null || echo unknown` -/bin/machine = `(/bin/machine) 2>/dev/null || echo unknown` -/usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null || echo unknown` -/bin/universe = `(/bin/universe) 2>/dev/null || echo unknown` - -_ASUNAME - -as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - $as_echo "PATH: $as_dir" - done -IFS=$as_save_IFS - -} >&5 - -cat >&5 <<_ACEOF - - -## ----------- ## -## Core tests. ## -## ----------- ## - -_ACEOF - - -# Keep a trace of the command line. -# Strip out --no-create and --no-recursion so they do not pile up. -# Strip out --silent because we don't want to record it for future runs. -# Also quote any args containing shell meta-characters. -# Make two passes to allow for proper duplicate-argument suppression. -ac_configure_args= -ac_configure_args0= -ac_configure_args1= -ac_must_keep_next=false -for ac_pass in 1 2 -do - for ac_arg - do - case $ac_arg in - -no-create | --no-c* | -n | -no-recursion | --no-r*) continue ;; - -q | -quiet | --quiet | --quie | --qui | --qu | --q \ - | -silent | --silent | --silen | --sile | --sil) - continue ;; - *\'*) - ac_arg=`$as_echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; - esac - case $ac_pass in - 1) as_fn_append ac_configure_args0 " '$ac_arg'" ;; - 2) - as_fn_append ac_configure_args1 " '$ac_arg'" - if test $ac_must_keep_next = true; then - ac_must_keep_next=false # Got value, back to normal. - else - case $ac_arg in - *=* | --config-cache | -C | -disable-* | --disable-* \ - | -enable-* | --enable-* | -gas | --g* | -nfp | --nf* \ - | -q | -quiet | --q* | -silent | --sil* | -v | -verb* \ - | -with-* | --with-* | -without-* | --without-* | --x) - case "$ac_configure_args0 " in - "$ac_configure_args1"*" '$ac_arg' "* ) continue ;; - esac - ;; - -* ) ac_must_keep_next=true ;; - esac - fi - as_fn_append ac_configure_args " '$ac_arg'" - ;; - esac - done -done -{ ac_configure_args0=; unset ac_configure_args0;} -{ ac_configure_args1=; unset ac_configure_args1;} - -# When interrupted or exit'd, cleanup temporary files, and complete -# config.log. We remove comments because anyway the quotes in there -# would cause problems or look ugly. -# WARNING: Use '\'' to represent an apostrophe within the trap. -# WARNING: Do not start the trap code with a newline, due to a FreeBSD 4.0 bug. -trap 'exit_status=$? - # Save into config.log some information that might help in debugging. - { - echo - - $as_echo "## ---------------- ## -## Cache variables. ## -## ---------------- ##" - echo - # The following way of writing the cache mishandles newlines in values, -( - for ac_var in `(set) 2>&1 | sed -n '\''s/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'\''`; do - eval ac_val=\$$ac_var - case $ac_val in #( - *${as_nl}*) - case $ac_var in #( - *_cv_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 -$as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; - esac - case $ac_var in #( - _ | IFS | as_nl) ;; #( - BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( - *) { eval $ac_var=; unset $ac_var;} ;; - esac ;; - esac - done - (set) 2>&1 | - case $as_nl`(ac_space='\'' '\''; set) 2>&1` in #( - *${as_nl}ac_space=\ *) - sed -n \ - "s/'\''/'\''\\\\'\'''\''/g; - s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\''\\2'\''/p" - ;; #( - *) - sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" - ;; - esac | - sort -) - echo - - $as_echo "## ----------------- ## -## Output variables. ## -## ----------------- ##" - echo - for ac_var in $ac_subst_vars - do - eval ac_val=\$$ac_var - case $ac_val in - *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; - esac - $as_echo "$ac_var='\''$ac_val'\''" - done | sort - echo - - if test -n "$ac_subst_files"; then - $as_echo "## ------------------- ## -## File substitutions. ## -## ------------------- ##" - echo - for ac_var in $ac_subst_files - do - eval ac_val=\$$ac_var - case $ac_val in - *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; - esac - $as_echo "$ac_var='\''$ac_val'\''" - done | sort - echo - fi - - if test -s confdefs.h; then - $as_echo "## ----------- ## -## confdefs.h. ## -## ----------- ##" - echo - cat confdefs.h - echo - fi - test "$ac_signal" != 0 && - $as_echo "$as_me: caught signal $ac_signal" - $as_echo "$as_me: exit $exit_status" - } >&5 - rm -f core *.core core.conftest.* && - rm -f -r conftest* confdefs* conf$$* $ac_clean_files && - exit $exit_status -' 0 -for ac_signal in 1 2 13 15; do - trap 'ac_signal='$ac_signal'; as_fn_exit 1' $ac_signal -done -ac_signal=0 - -# confdefs.h avoids OS command line length limits that DEFS can exceed. -rm -f -r conftest* confdefs.h - -$as_echo "/* confdefs.h */" > confdefs.h - -# Predefined preprocessor variables. - -cat >>confdefs.h <<_ACEOF -#define PACKAGE_NAME "$PACKAGE_NAME" -_ACEOF - -cat >>confdefs.h <<_ACEOF -#define PACKAGE_TARNAME "$PACKAGE_TARNAME" -_ACEOF - -cat >>confdefs.h <<_ACEOF -#define PACKAGE_VERSION "$PACKAGE_VERSION" -_ACEOF - -cat >>confdefs.h <<_ACEOF -#define PACKAGE_STRING "$PACKAGE_STRING" -_ACEOF - -cat >>confdefs.h <<_ACEOF -#define PACKAGE_BUGREPORT "$PACKAGE_BUGREPORT" -_ACEOF - -cat >>confdefs.h <<_ACEOF -#define PACKAGE_URL "$PACKAGE_URL" -_ACEOF - - -# Let the site file select an alternate cache file if it wants to. -# Prefer an explicitly selected file to automatically selected ones. -ac_site_file1=NONE -ac_site_file2=NONE -if test -n "$CONFIG_SITE"; then - # We do not want a PATH search for config.site. - case $CONFIG_SITE in #(( - -*) ac_site_file1=./$CONFIG_SITE;; - */*) ac_site_file1=$CONFIG_SITE;; - *) ac_site_file1=./$CONFIG_SITE;; - esac -elif test "x$prefix" != xNONE; then - ac_site_file1=$prefix/share/config.site - ac_site_file2=$prefix/etc/config.site -else - ac_site_file1=$ac_default_prefix/share/config.site - ac_site_file2=$ac_default_prefix/etc/config.site -fi -for ac_site_file in "$ac_site_file1" "$ac_site_file2" -do - test "x$ac_site_file" = xNONE && continue - if test /dev/null != "$ac_site_file" && test -r "$ac_site_file"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: loading site script $ac_site_file" >&5 -$as_echo "$as_me: loading site script $ac_site_file" >&6;} - sed 's/^/| /' "$ac_site_file" >&5 - . "$ac_site_file" \ - || { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} -as_fn_error $? "failed to load site script $ac_site_file -See \`config.log' for more details" "$LINENO" 5; } - fi -done - -if test -r "$cache_file"; then - # Some versions of bash will fail to source /dev/null (special files - # actually), so we avoid doing that. DJGPP emulates it as a regular file. - if test /dev/null != "$cache_file" && test -f "$cache_file"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: loading cache $cache_file" >&5 -$as_echo "$as_me: loading cache $cache_file" >&6;} - case $cache_file in - [\\/]* | ?:[\\/]* ) . "$cache_file";; - *) . "./$cache_file";; - esac - fi -else - { $as_echo "$as_me:${as_lineno-$LINENO}: creating cache $cache_file" >&5 -$as_echo "$as_me: creating cache $cache_file" >&6;} - >$cache_file -fi - -# Check that the precious variables saved in the cache have kept the same -# value. -ac_cache_corrupted=false -for ac_var in $ac_precious_vars; do - eval ac_old_set=\$ac_cv_env_${ac_var}_set - eval ac_new_set=\$ac_env_${ac_var}_set - eval ac_old_val=\$ac_cv_env_${ac_var}_value - eval ac_new_val=\$ac_env_${ac_var}_value - case $ac_old_set,$ac_new_set in - set,) - { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5 -$as_echo "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;} - ac_cache_corrupted=: ;; - ,set) - { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was not set in the previous run" >&5 -$as_echo "$as_me: error: \`$ac_var' was not set in the previous run" >&2;} - ac_cache_corrupted=: ;; - ,);; - *) - if test "x$ac_old_val" != "x$ac_new_val"; then - # differences in whitespace do not lead to failure. - ac_old_val_w=`echo x $ac_old_val` - ac_new_val_w=`echo x $ac_new_val` - if test "$ac_old_val_w" != "$ac_new_val_w"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' has changed since the previous run:" >&5 -$as_echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;} - ac_cache_corrupted=: - else - { $as_echo "$as_me:${as_lineno-$LINENO}: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&5 -$as_echo "$as_me: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&2;} - eval $ac_var=\$ac_old_val - fi - { $as_echo "$as_me:${as_lineno-$LINENO}: former value: \`$ac_old_val'" >&5 -$as_echo "$as_me: former value: \`$ac_old_val'" >&2;} - { $as_echo "$as_me:${as_lineno-$LINENO}: current value: \`$ac_new_val'" >&5 -$as_echo "$as_me: current value: \`$ac_new_val'" >&2;} - fi;; - esac - # Pass precious variables to config.status. - if test "$ac_new_set" = set; then - case $ac_new_val in - *\'*) ac_arg=$ac_var=`$as_echo "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;; - *) ac_arg=$ac_var=$ac_new_val ;; - esac - case " $ac_configure_args " in - *" '$ac_arg' "*) ;; # Avoid dups. Use of quotes ensures accuracy. - *) as_fn_append ac_configure_args " '$ac_arg'" ;; - esac - fi -done -if $ac_cache_corrupted; then - { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} - { $as_echo "$as_me:${as_lineno-$LINENO}: error: changes in the environment can compromise the build" >&5 -$as_echo "$as_me: error: changes in the environment can compromise the build" >&2;} - as_fn_error $? "run \`make distclean' and/or \`rm $cache_file' and start over" "$LINENO" 5 -fi -## -------------------- ## -## Main body of script. ## -## -------------------- ## - -ac_ext=c -ac_cpp='$CPP $CPPFLAGS' -ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_c_compiler_gnu - - - -# Check for Ocaml compilers - -# we first look for ocamlc in the path; if not present, we fail -# Extract the first word of "ocamlc", so it can be a program name with args. -set dummy ocamlc; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_prog_OCAMLC+:} false; then : - $as_echo_n "(cached) " >&6 -else - if test -n "$OCAMLC"; then - ac_cv_prog_OCAMLC="$OCAMLC" # Let the user override the test. -else -as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then - ac_cv_prog_OCAMLC="ocamlc" - $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 - break 2 - fi -done - done -IFS=$as_save_IFS - - test -z "$ac_cv_prog_OCAMLC" && ac_cv_prog_OCAMLC="no" -fi -fi -OCAMLC=$ac_cv_prog_OCAMLC -if test -n "$OCAMLC"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLC" >&5 -$as_echo "$OCAMLC" >&6; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -fi - - -if test "$OCAMLC" = no ; then - as_fn_error $? "Cannot find ocamlc." "$LINENO" 5 -fi - -# we extract Ocaml version number and library path -OCAMLVERSION=`$OCAMLC -v | sed -n -e 's|.*version *\(.*\)$|\1|p' ` -echo "ocaml version is $OCAMLVERSION" - -case $OCAMLVERSION in - 0.*|1.*|2.*|3.00*|3.01*|3.02*|3.03*|3.04*|3.05*|3.06*|3.07*) - as_fn_error $? "ocamlgraph needs ocaml version 3.08.0 or higher" "$LINENO" 5;; - 3.08*) - FORPACK="";; - *) - FORPACK="-for-pack Graph";; -esac - -# OCAMLLIB=`$OCAMLC -v | tail -n 1 | cut -f 4 -d " "` -# OCAMLLIB=`$OCAMLC -v | tail -n 1 | sed -e 's|[[^:]]*: \(.*\)|\1|' ` -OCAMLLIB=`$OCAMLC -where` -echo "ocaml library path is $OCAMLLIB" - -# then we look for ocamlopt; if not present, we issue a warning -# if the version is not the same, we also discard it -# we set OCAMLBEST to "opt" or "byte", whether ocamlopt is available or not -# Extract the first word of "ocamlopt", so it can be a program name with args. -set dummy ocamlopt; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_prog_OCAMLOPT+:} false; then : - $as_echo_n "(cached) " >&6 -else - if test -n "$OCAMLOPT"; then - ac_cv_prog_OCAMLOPT="$OCAMLOPT" # Let the user override the test. -else -as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then - ac_cv_prog_OCAMLOPT="ocamlopt" - $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 - break 2 - fi -done - done -IFS=$as_save_IFS - - test -z "$ac_cv_prog_OCAMLOPT" && ac_cv_prog_OCAMLOPT="no" -fi -fi -OCAMLOPT=$ac_cv_prog_OCAMLOPT -if test -n "$OCAMLOPT"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLOPT" >&5 -$as_echo "$OCAMLOPT" >&6; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -fi - - -OCAMLBEST=byte -if test "$OCAMLOPT" = no ; then - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: Cannot find ocamlopt; bytecode compilation only." >&5 -$as_echo "$as_me: WARNING: Cannot find ocamlopt; bytecode compilation only." >&2;} -else - { $as_echo "$as_me:${as_lineno-$LINENO}: checking ocamlopt version" >&5 -$as_echo_n "checking ocamlopt version... " >&6; } - TMPVERSION=`$OCAMLOPT -v | sed -n -e 's|.*version *\(.*\)$|\1|p' ` - if test "$TMPVERSION" != "$OCAMLVERSION" ; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: differs from ocamlc; ocamlopt discarded." >&5 -$as_echo "differs from ocamlc; ocamlopt discarded." >&6; } - OCAMLOPT=no - else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: ok" >&5 -$as_echo "ok" >&6; } - OCAMLBEST=opt - fi -fi - -# checking for ocamlc.opt -# Extract the first word of "ocamlc.opt", so it can be a program name with args. -set dummy ocamlc.opt; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_prog_OCAMLCDOTOPT+:} false; then : - $as_echo_n "(cached) " >&6 -else - if test -n "$OCAMLCDOTOPT"; then - ac_cv_prog_OCAMLCDOTOPT="$OCAMLCDOTOPT" # Let the user override the test. -else -as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then - ac_cv_prog_OCAMLCDOTOPT="ocamlc.opt" - $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 - break 2 - fi -done - done -IFS=$as_save_IFS - - test -z "$ac_cv_prog_OCAMLCDOTOPT" && ac_cv_prog_OCAMLCDOTOPT="no" -fi -fi -OCAMLCDOTOPT=$ac_cv_prog_OCAMLCDOTOPT -if test -n "$OCAMLCDOTOPT"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLCDOTOPT" >&5 -$as_echo "$OCAMLCDOTOPT" >&6; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -fi - - -if test "$OCAMLCDOTOPT" != no ; then - { $as_echo "$as_me:${as_lineno-$LINENO}: checking ocamlc.opt version" >&5 -$as_echo_n "checking ocamlc.opt version... " >&6; } - TMPVERSION=`$OCAMLCDOTOPT -v | sed -n -e 's|.*version *\(.*\)$|\1|p' ` - if test "$TMPVERSION" != "$OCAMLVERSION" ; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: differs from ocamlc; ocamlc.opt discarded." >&5 -$as_echo "differs from ocamlc; ocamlc.opt discarded." >&6; } - else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: ok" >&5 -$as_echo "ok" >&6; } - OCAMLC=$OCAMLCDOTOPT - fi -fi - -# checking for ocamlopt.opt -if test "$OCAMLOPT" != no ; then - # Extract the first word of "ocamlopt.opt", so it can be a program name with args. -set dummy ocamlopt.opt; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_prog_OCAMLOPTDOTOPT+:} false; then : - $as_echo_n "(cached) " >&6 -else - if test -n "$OCAMLOPTDOTOPT"; then - ac_cv_prog_OCAMLOPTDOTOPT="$OCAMLOPTDOTOPT" # Let the user override the test. -else -as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then - ac_cv_prog_OCAMLOPTDOTOPT="ocamlopt.opt" - $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 - break 2 - fi -done - done -IFS=$as_save_IFS - - test -z "$ac_cv_prog_OCAMLOPTDOTOPT" && ac_cv_prog_OCAMLOPTDOTOPT="no" -fi -fi -OCAMLOPTDOTOPT=$ac_cv_prog_OCAMLOPTDOTOPT -if test -n "$OCAMLOPTDOTOPT"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLOPTDOTOPT" >&5 -$as_echo "$OCAMLOPTDOTOPT" >&6; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -fi - - - if test "$OCAMLOPTDOTOPT" != no ; then - { $as_echo "$as_me:${as_lineno-$LINENO}: checking ocamlc.opt version" >&5 -$as_echo_n "checking ocamlc.opt version... " >&6; } - TMPVER=`$OCAMLOPTDOTOPT -v | sed -n -e 's|.*version *\(.*\)$|\1|p' ` - if test "$TMPVER" != "$OCAMLVERSION" ; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: differs from ocamlc; ocamlopt.opt discarded." >&5 -$as_echo "differs from ocamlc; ocamlopt.opt discarded." >&6; } - else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: ok" >&5 -$as_echo "ok" >&6; } - OCAMLOPT=$OCAMLOPTDOTOPT - fi - fi -fi - -# ocamldep, ocamllex and ocamlyacc should also be present in the path -# Extract the first word of "ocamldep", so it can be a program name with args. -set dummy ocamldep; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_prog_OCAMLDEP+:} false; then : - $as_echo_n "(cached) " >&6 -else - if test -n "$OCAMLDEP"; then - ac_cv_prog_OCAMLDEP="$OCAMLDEP" # Let the user override the test. -else -as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then - ac_cv_prog_OCAMLDEP="ocamldep" - $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 - break 2 - fi -done - done -IFS=$as_save_IFS - - test -z "$ac_cv_prog_OCAMLDEP" && ac_cv_prog_OCAMLDEP="no" -fi -fi -OCAMLDEP=$ac_cv_prog_OCAMLDEP -if test -n "$OCAMLDEP"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLDEP" >&5 -$as_echo "$OCAMLDEP" >&6; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -fi - - -if test "$OCAMLDEP" = no ; then - as_fn_error $? "Cannot find ocamldep." "$LINENO" 5 -fi - -# Extract the first word of "ocamllex", so it can be a program name with args. -set dummy ocamllex; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_prog_OCAMLLEX+:} false; then : - $as_echo_n "(cached) " >&6 -else - if test -n "$OCAMLLEX"; then - ac_cv_prog_OCAMLLEX="$OCAMLLEX" # Let the user override the test. -else -as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then - ac_cv_prog_OCAMLLEX="ocamllex" - $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 - break 2 - fi -done - done -IFS=$as_save_IFS - - test -z "$ac_cv_prog_OCAMLLEX" && ac_cv_prog_OCAMLLEX="no" -fi -fi -OCAMLLEX=$ac_cv_prog_OCAMLLEX -if test -n "$OCAMLLEX"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLLEX" >&5 -$as_echo "$OCAMLLEX" >&6; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -fi - - -if test "$OCAMLLEX" = no ; then - as_fn_error $? "Cannot find ocamllex." "$LINENO" 5 -else - # Extract the first word of "ocamllex.opt", so it can be a program name with args. -set dummy ocamllex.opt; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_prog_OCAMLLEXDOTOPT+:} false; then : - $as_echo_n "(cached) " >&6 -else - if test -n "$OCAMLLEXDOTOPT"; then - ac_cv_prog_OCAMLLEXDOTOPT="$OCAMLLEXDOTOPT" # Let the user override the test. -else -as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then - ac_cv_prog_OCAMLLEXDOTOPT="ocamllex.opt" - $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 - break 2 - fi -done - done -IFS=$as_save_IFS - - test -z "$ac_cv_prog_OCAMLLEXDOTOPT" && ac_cv_prog_OCAMLLEXDOTOPT="no" -fi -fi -OCAMLLEXDOTOPT=$ac_cv_prog_OCAMLLEXDOTOPT -if test -n "$OCAMLLEXDOTOPT"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLLEXDOTOPT" >&5 -$as_echo "$OCAMLLEXDOTOPT" >&6; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -fi - - - if test "$OCAMLLEXDOTOPT" != no ; then - OCAMLLEX=$OCAMLLEXDOTOPT - fi -fi - -# Extract the first word of "ocamlyacc", so it can be a program name with args. -set dummy ocamlyacc; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_prog_OCAMLYACC+:} false; then : - $as_echo_n "(cached) " >&6 -else - if test -n "$OCAMLYACC"; then - ac_cv_prog_OCAMLYACC="$OCAMLYACC" # Let the user override the test. -else -as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then - ac_cv_prog_OCAMLYACC="ocamlyacc" - $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 - break 2 - fi -done - done -IFS=$as_save_IFS - - test -z "$ac_cv_prog_OCAMLYACC" && ac_cv_prog_OCAMLYACC="no" -fi -fi -OCAMLYACC=$ac_cv_prog_OCAMLYACC -if test -n "$OCAMLYACC"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLYACC" >&5 -$as_echo "$OCAMLYACC" >&6; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -fi - - -if test "$OCAMLYACC" = no ; then - as_fn_error $? "Cannot find ocamlyacc." "$LINENO" 5 -fi - -# Extract the first word of "ocamldoc", so it can be a program name with args. -set dummy ocamldoc; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_prog_OCAMLDOC+:} false; then : - $as_echo_n "(cached) " >&6 -else - if test -n "$OCAMLDOC"; then - ac_cv_prog_OCAMLDOC="$OCAMLDOC" # Let the user override the test. -else -as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then - ac_cv_prog_OCAMLDOC="ocamldoc" - $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 - break 2 - fi -done - done -IFS=$as_save_IFS - - test -z "$ac_cv_prog_OCAMLDOC" && ac_cv_prog_OCAMLDOC="true" -fi -fi -OCAMLDOC=$ac_cv_prog_OCAMLDOC -if test -n "$OCAMLDOC"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLDOC" >&5 -$as_echo "$OCAMLDOC" >&6; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -fi - - -if test "$OCAMLDOC" = true ; then - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: Cannot find ocamldoc" >&5 -$as_echo "$as_me: WARNING: Cannot find ocamldoc" >&2;} -else - # Extract the first word of "ocamldoc.opt", so it can be a program name with args. -set dummy ocamldoc.opt; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_prog_OCAMLDOCOPT+:} false; then : - $as_echo_n "(cached) " >&6 -else - if test -n "$OCAMLDOCOPT"; then - ac_cv_prog_OCAMLDOCOPT="$OCAMLDOCOPT" # Let the user override the test. -else -as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then - ac_cv_prog_OCAMLDOCOPT="ocamldoc.opt" - $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 - break 2 - fi -done - done -IFS=$as_save_IFS - - test -z "$ac_cv_prog_OCAMLDOCOPT" && ac_cv_prog_OCAMLDOCOPT="no" -fi -fi -OCAMLDOCOPT=$ac_cv_prog_OCAMLDOCOPT -if test -n "$OCAMLDOCOPT"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLDOCOPT" >&5 -$as_echo "$OCAMLDOCOPT" >&6; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -fi - - - if test "$OCAMLDOCOPT" != no ; then - OCAMLDOC=$OCAMLDOCOPT - fi -fi - -# Extract the first word of "ocamlweb", so it can be a program name with args. -set dummy ocamlweb; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_prog_OCAMLWEB+:} false; then : - $as_echo_n "(cached) " >&6 -else - if test -n "$OCAMLWEB"; then - ac_cv_prog_OCAMLWEB="$OCAMLWEB" # Let the user override the test. -else -as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then - ac_cv_prog_OCAMLWEB="ocamlweb" - $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 - break 2 - fi -done - done -IFS=$as_save_IFS - - test -z "$ac_cv_prog_OCAMLWEB" && ac_cv_prog_OCAMLWEB="true" -fi -fi -OCAMLWEB=$ac_cv_prog_OCAMLWEB -if test -n "$OCAMLWEB"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLWEB" >&5 -$as_echo "$OCAMLWEB" >&6; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -fi - - - -# Extract the first word of "ocamlfind", so it can be a program name with args. -set dummy ocamlfind; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_prog_OCAMLFIND+:} false; then : - $as_echo_n "(cached) " >&6 -else - if test -n "$OCAMLFIND"; then - ac_cv_prog_OCAMLFIND="$OCAMLFIND" # Let the user override the test. -else -as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then - ac_cv_prog_OCAMLFIND="ocamlfind" - $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 - break 2 - fi -done - done -IFS=$as_save_IFS - -fi -fi -OCAMLFIND=$ac_cv_prog_OCAMLFIND -if test -n "$OCAMLFIND"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLFIND" >&5 -$as_echo "$OCAMLFIND" >&6; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -fi - - - -# checking for lablgtk2 -# Extract the first word of "lablgtk2", so it can be a program name with args. -set dummy lablgtk2; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_prog_LABLGTK2+:} false; then : - $as_echo_n "(cached) " >&6 -else - if test -n "$LABLGTK2"; then - ac_cv_prog_LABLGTK2="$LABLGTK2" # Let the user override the test. -else -as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then - ac_cv_prog_LABLGTK2="yes" - $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 - break 2 - fi -done - done -IFS=$as_save_IFS - - test -z "$ac_cv_prog_LABLGTK2" && ac_cv_prog_LABLGTK2="no" -fi -fi -LABLGTK2=$ac_cv_prog_LABLGTK2 -if test -n "$LABLGTK2"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $LABLGTK2" >&5 -$as_echo "$LABLGTK2" >&6; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -fi - - -if test "$LABLGTK2" = yes ; then - if test -d "$OCAMLLIB/lablgtk2" ; then - INCLUDEGTK2="-I +lablgtk2" - else - LABLGTK2=no - fi -fi - -# platform -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking Win32 platform" >&5 -$as_echo_n "checking Win32 platform... " >&6; } -if echo "let _ = Sys.os_type;;" | ocaml | grep -q Win32; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 -$as_echo "yes" >&6; } - OCAMLWIN32=yes - EXE=.exe - LIBEXT=.lib - OBJEXT=.obj -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } - OCAMLWIN32=no - EXE= - LIBEXT=.a - OBJEXT=.o -fi - -# substitutions to perform - - - - - - - - - - - - - - - - - - -# Finally create the Makefile from Makefile.in -ac_config_files="$ac_config_files Makefile" - -cat >confcache <<\_ACEOF -# This file is a shell script that caches the results of configure -# tests run on this system so they can be shared between configure -# scripts and configure runs, see configure's option --config-cache. -# It is not useful on other systems. If it contains results you don't -# want to keep, you may remove or edit it. -# -# config.status only pays attention to the cache file if you give it -# the --recheck option to rerun configure. -# -# `ac_cv_env_foo' variables (set or unset) will be overridden when -# loading this file, other *unset* `ac_cv_foo' will be assigned the -# following values. - -_ACEOF - -# The following way of writing the cache mishandles newlines in values, -# but we know of no workaround that is simple, portable, and efficient. -# So, we kill variables containing newlines. -# Ultrix sh set writes to stderr and can't be redirected directly, -# and sets the high bit in the cache file unless we assign to the vars. -( - for ac_var in `(set) 2>&1 | sed -n 's/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'`; do - eval ac_val=\$$ac_var - case $ac_val in #( - *${as_nl}*) - case $ac_var in #( - *_cv_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 -$as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; - esac - case $ac_var in #( - _ | IFS | as_nl) ;; #( - BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( - *) { eval $ac_var=; unset $ac_var;} ;; - esac ;; - esac - done - - (set) 2>&1 | - case $as_nl`(ac_space=' '; set) 2>&1` in #( - *${as_nl}ac_space=\ *) - # `set' does not quote correctly, so add quotes: double-quote - # substitution turns \\\\ into \\, and sed turns \\ into \. - sed -n \ - "s/'/'\\\\''/g; - s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\\2'/p" - ;; #( - *) - # `set' quotes correctly as required by POSIX, so do not add quotes. - sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" - ;; - esac | - sort -) | - sed ' - /^ac_cv_env_/b end - t clear - :clear - s/^\([^=]*\)=\(.*[{}].*\)$/test "${\1+set}" = set || &/ - t end - s/^\([^=]*\)=\(.*\)$/\1=${\1=\2}/ - :end' >>confcache -if diff "$cache_file" confcache >/dev/null 2>&1; then :; else - if test -w "$cache_file"; then - if test "x$cache_file" != "x/dev/null"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: updating cache $cache_file" >&5 -$as_echo "$as_me: updating cache $cache_file" >&6;} - if test ! -f "$cache_file" || test -h "$cache_file"; then - cat confcache >"$cache_file" - else - case $cache_file in #( - */* | ?:*) - mv -f confcache "$cache_file"$$ && - mv -f "$cache_file"$$ "$cache_file" ;; #( - *) - mv -f confcache "$cache_file" ;; - esac - fi - fi - else - { $as_echo "$as_me:${as_lineno-$LINENO}: not updating unwritable cache $cache_file" >&5 -$as_echo "$as_me: not updating unwritable cache $cache_file" >&6;} - fi -fi -rm -f confcache - -test "x$prefix" = xNONE && prefix=$ac_default_prefix -# Let make expand exec_prefix. -test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' - -# Transform confdefs.h into DEFS. -# Protect against shell expansion while executing Makefile rules. -# Protect against Makefile macro expansion. -# -# If the first sed substitution is executed (which looks for macros that -# take arguments), then branch to the quote section. Otherwise, -# look for a macro that doesn't take arguments. -ac_script=' -:mline -/\\$/{ - N - s,\\\n,, - b mline -} -t clear -:clear -s/^[ ]*#[ ]*define[ ][ ]*\([^ (][^ (]*([^)]*)\)[ ]*\(.*\)/-D\1=\2/g -t quote -s/^[ ]*#[ ]*define[ ][ ]*\([^ ][^ ]*\)[ ]*\(.*\)/-D\1=\2/g -t quote -b any -:quote -s/[ `~#$^&*(){}\\|;'\''"<>?]/\\&/g -s/\[/\\&/g -s/\]/\\&/g -s/\$/$$/g -H -:any -${ - g - s/^\n// - s/\n/ /g - p -} -' -DEFS=`sed -n "$ac_script" confdefs.h` - - -ac_libobjs= -ac_ltlibobjs= -U= -for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue - # 1. Remove the extension, and $U if already installed. - ac_script='s/\$U\././;s/\.o$//;s/\.obj$//' - ac_i=`$as_echo "$ac_i" | sed "$ac_script"` - # 2. Prepend LIBOBJDIR. When used with automake>=1.10 LIBOBJDIR - # will be set to the directory where LIBOBJS objects are built. - as_fn_append ac_libobjs " \${LIBOBJDIR}$ac_i\$U.$ac_objext" - as_fn_append ac_ltlibobjs " \${LIBOBJDIR}$ac_i"'$U.lo' -done -LIBOBJS=$ac_libobjs - -LTLIBOBJS=$ac_ltlibobjs - - - -: "${CONFIG_STATUS=./config.status}" -ac_write_fail=0 -ac_clean_files_save=$ac_clean_files -ac_clean_files="$ac_clean_files $CONFIG_STATUS" -{ $as_echo "$as_me:${as_lineno-$LINENO}: creating $CONFIG_STATUS" >&5 -$as_echo "$as_me: creating $CONFIG_STATUS" >&6;} -as_write_fail=0 -cat >$CONFIG_STATUS <<_ASEOF || as_write_fail=1 -#! $SHELL -# Generated by $as_me. -# Run this file to recreate the current configuration. -# Compiler output produced by configure, useful for debugging -# configure, is in config.log if it exists. - -debug=false -ac_cs_recheck=false -ac_cs_silent=false - -SHELL=\${CONFIG_SHELL-$SHELL} -export SHELL -_ASEOF -cat >>$CONFIG_STATUS <<\_ASEOF || as_write_fail=1 -## -------------------- ## -## M4sh Initialization. ## -## -------------------- ## - -# Be more Bourne compatible -DUALCASE=1; export DUALCASE # for MKS sh -if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then : - emulate sh - NULLCMD=: - # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which - # is contrary to our usage. Disable this feature. - alias -g '${1+"$@"}'='"$@"' - setopt NO_GLOB_SUBST -else - case `(set -o) 2>/dev/null` in #( - *posix*) : - set -o posix ;; #( - *) : - ;; -esac -fi - - -as_nl=' -' -export as_nl -# Printing a long string crashes Solaris 7 /usr/bin/printf. -as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' -as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo -as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo -# Prefer a ksh shell builtin over an external printf program on Solaris, -# but without wasting forks for bash or zsh. -if test -z "$BASH_VERSION$ZSH_VERSION" \ - && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then - as_echo='print -r --' - as_echo_n='print -rn --' -elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then - as_echo='printf %s\n' - as_echo_n='printf %s' -else - if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then - as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' - as_echo_n='/usr/ucb/echo -n' - else - as_echo_body='eval expr "X$1" : "X\\(.*\\)"' - as_echo_n_body='eval - arg=$1; - case $arg in #( - *"$as_nl"*) - expr "X$arg" : "X\\(.*\\)$as_nl"; - arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; - esac; - expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" - ' - export as_echo_n_body - as_echo_n='sh -c $as_echo_n_body as_echo' - fi - export as_echo_body - as_echo='sh -c $as_echo_body as_echo' -fi - -# The user is always right. -if test "${PATH_SEPARATOR+set}" != set; then - PATH_SEPARATOR=: - (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { - (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || - PATH_SEPARATOR=';' - } -fi - - -# IFS -# We need space, tab and new line, in precisely that order. Quoting is -# there to prevent editors from complaining about space-tab. -# (If _AS_PATH_WALK were called with IFS unset, it would disable word -# splitting by setting IFS to empty value.) -IFS=" "" $as_nl" - -# Find who we are. Look in the path if we contain no directory separator. -as_myself= -case $0 in #(( - *[\\/]* ) as_myself=$0 ;; - *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break - done -IFS=$as_save_IFS - - ;; -esac -# We did not find ourselves, most probably we were run as `sh COMMAND' -# in which case we are not to be found in the path. -if test "x$as_myself" = x; then - as_myself=$0 -fi -if test ! -f "$as_myself"; then - $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 - exit 1 -fi - -# Unset variables that we do not need and which cause bugs (e.g. in -# pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" -# suppresses any "Segmentation fault" message there. '((' could -# trigger a bug in pdksh 5.2.14. -for as_var in BASH_ENV ENV MAIL MAILPATH -do eval test x\${$as_var+set} = xset \ - && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : -done -PS1='$ ' -PS2='> ' -PS4='+ ' - -# NLS nuisances. -LC_ALL=C -export LC_ALL -LANGUAGE=C -export LANGUAGE - -# CDPATH. -(unset CDPATH) >/dev/null 2>&1 && unset CDPATH - - -# as_fn_error STATUS ERROR [LINENO LOG_FD] -# ---------------------------------------- -# Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are -# provided, also output the error to LOG_FD, referencing LINENO. Then exit the -# script with STATUS, using 1 if that was 0. -as_fn_error () -{ - as_status=$1; test $as_status -eq 0 && as_status=1 - if test "$4"; then - as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack - $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 - fi - $as_echo "$as_me: error: $2" >&2 - as_fn_exit $as_status -} # as_fn_error - - -# as_fn_set_status STATUS -# ----------------------- -# Set $? to STATUS, without forking. -as_fn_set_status () -{ - return $1 -} # as_fn_set_status - -# as_fn_exit STATUS -# ----------------- -# Exit the shell with STATUS, even in a "trap 0" or "set -e" context. -as_fn_exit () -{ - set +e - as_fn_set_status $1 - exit $1 -} # as_fn_exit - -# as_fn_unset VAR -# --------------- -# Portably unset VAR. -as_fn_unset () -{ - { eval $1=; unset $1;} -} -as_unset=as_fn_unset -# as_fn_append VAR VALUE -# ---------------------- -# Append the text in VALUE to the end of the definition contained in VAR. Take -# advantage of any shell optimizations that allow amortized linear growth over -# repeated appends, instead of the typical quadratic growth present in naive -# implementations. -if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then : - eval 'as_fn_append () - { - eval $1+=\$2 - }' -else - as_fn_append () - { - eval $1=\$$1\$2 - } -fi # as_fn_append - -# as_fn_arith ARG... -# ------------------ -# Perform arithmetic evaluation on the ARGs, and store the result in the -# global $as_val. Take advantage of shells that can avoid forks. The arguments -# must be portable across $(()) and expr. -if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then : - eval 'as_fn_arith () - { - as_val=$(( $* )) - }' -else - as_fn_arith () - { - as_val=`expr "$@" || test $? -eq 1` - } -fi # as_fn_arith - - -if expr a : '\(a\)' >/dev/null 2>&1 && - test "X`expr 00001 : '.*\(...\)'`" = X001; then - as_expr=expr -else - as_expr=false -fi - -if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then - as_basename=basename -else - as_basename=false -fi - -if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then - as_dirname=dirname -else - as_dirname=false -fi - -as_me=`$as_basename -- "$0" || -$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ - X"$0" : 'X\(//\)$' \| \ - X"$0" : 'X\(/\)' \| . 2>/dev/null || -$as_echo X/"$0" | - sed '/^.*\/\([^/][^/]*\)\/*$/{ - s//\1/ - q - } - /^X\/\(\/\/\)$/{ - s//\1/ - q - } - /^X\/\(\/\).*/{ - s//\1/ - q - } - s/.*/./; q'` - -# Avoid depending upon Character Ranges. -as_cr_letters='abcdefghijklmnopqrstuvwxyz' -as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' -as_cr_Letters=$as_cr_letters$as_cr_LETTERS -as_cr_digits='0123456789' -as_cr_alnum=$as_cr_Letters$as_cr_digits - -ECHO_C= ECHO_N= ECHO_T= -case `echo -n x` in #((((( --n*) - case `echo 'xy\c'` in - *c*) ECHO_T=' ';; # ECHO_T is single tab character. - xy) ECHO_C='\c';; - *) echo `echo ksh88 bug on AIX 6.1` > /dev/null - ECHO_T=' ';; - esac;; -*) - ECHO_N='-n';; -esac - -rm -f conf$$ conf$$.exe conf$$.file -if test -d conf$$.dir; then - rm -f conf$$.dir/conf$$.file -else - rm -f conf$$.dir - mkdir conf$$.dir 2>/dev/null -fi -if (echo >conf$$.file) 2>/dev/null; then - if ln -s conf$$.file conf$$ 2>/dev/null; then - as_ln_s='ln -s' - # ... but there are two gotchas: - # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. - # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. - # In both cases, we have to default to `cp -p'. - ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || - as_ln_s='cp -p' - elif ln conf$$.file conf$$ 2>/dev/null; then - as_ln_s=ln - else - as_ln_s='cp -p' - fi -else - as_ln_s='cp -p' -fi -rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file -rmdir conf$$.dir 2>/dev/null - - -# as_fn_mkdir_p -# ------------- -# Create "$as_dir" as a directory, including parents if necessary. -as_fn_mkdir_p () -{ - - case $as_dir in #( - -*) as_dir=./$as_dir;; - esac - test -d "$as_dir" || eval $as_mkdir_p || { - as_dirs= - while :; do - case $as_dir in #( - *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( - *) as_qdir=$as_dir;; - esac - as_dirs="'$as_qdir' $as_dirs" - as_dir=`$as_dirname -- "$as_dir" || -$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ - X"$as_dir" : 'X\(//\)[^/]' \| \ - X"$as_dir" : 'X\(//\)$' \| \ - X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || -$as_echo X"$as_dir" | - sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ - s//\1/ - q - } - /^X\(\/\/\)[^/].*/{ - s//\1/ - q - } - /^X\(\/\/\)$/{ - s//\1/ - q - } - /^X\(\/\).*/{ - s//\1/ - q - } - s/.*/./; q'` - test -d "$as_dir" && break - done - test -z "$as_dirs" || eval "mkdir $as_dirs" - } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" - - -} # as_fn_mkdir_p -if mkdir -p . 2>/dev/null; then - as_mkdir_p='mkdir -p "$as_dir"' -else - test -d ./-p && rmdir ./-p - as_mkdir_p=false -fi - -if test -x / >/dev/null 2>&1; then - as_test_x='test -x' -else - if ls -dL / >/dev/null 2>&1; then - as_ls_L_option=L - else - as_ls_L_option= - fi - as_test_x=' - eval sh -c '\'' - if test -d "$1"; then - test -d "$1/."; - else - case $1 in #( - -*)set "./$1";; - esac; - case `ls -ld'$as_ls_L_option' "$1" 2>/dev/null` in #(( - ???[sx]*):;;*)false;;esac;fi - '\'' sh - ' -fi -as_executable_p=$as_test_x - -# Sed expression to map a string onto a valid CPP name. -as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" - -# Sed expression to map a string onto a valid variable name. -as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" - - -exec 6>&1 -## ----------------------------------- ## -## Main body of $CONFIG_STATUS script. ## -## ----------------------------------- ## -_ASEOF -test $as_write_fail = 0 && chmod +x $CONFIG_STATUS || ac_write_fail=1 - -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 -# Save the log message, to keep $0 and so on meaningful, and to -# report actual input values of CONFIG_FILES etc. instead of their -# values after options handling. -ac_log=" -This file was extended by $as_me, which was -generated by GNU Autoconf 2.68. Invocation command line was - - CONFIG_FILES = $CONFIG_FILES - CONFIG_HEADERS = $CONFIG_HEADERS - CONFIG_LINKS = $CONFIG_LINKS - CONFIG_COMMANDS = $CONFIG_COMMANDS - $ $0 $@ - -on `(hostname || uname -n) 2>/dev/null | sed 1q` -" - -_ACEOF - -case $ac_config_files in *" -"*) set x $ac_config_files; shift; ac_config_files=$*;; -esac - - - -cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 -# Files that config.status was made for. -config_files="$ac_config_files" - -_ACEOF - -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 -ac_cs_usage="\ -\`$as_me' instantiates files and other configuration actions -from templates according to the current configuration. Unless the files -and actions are specified as TAGs, all are instantiated by default. - -Usage: $0 [OPTION]... [TAG]... - - -h, --help print this help, then exit - -V, --version print version number and configuration settings, then exit - --config print configuration, then exit - -q, --quiet, --silent - do not print progress messages - -d, --debug don't remove temporary files - --recheck update $as_me by reconfiguring in the same conditions - --file=FILE[:TEMPLATE] - instantiate the configuration file FILE - -Configuration files: -$config_files - -Report bugs to the package provider." - -_ACEOF -cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 -ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`" -ac_cs_version="\\ -config.status -configured by $0, generated by GNU Autoconf 2.68, - with options \\"\$ac_cs_config\\" - -Copyright (C) 2010 Free Software Foundation, Inc. -This config.status script is free software; the Free Software Foundation -gives unlimited permission to copy, distribute and modify it." - -ac_pwd='$ac_pwd' -srcdir='$srcdir' -test -n "\$AWK" || AWK=awk -_ACEOF - -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 -# The default lists apply if the user does not specify any file. -ac_need_defaults=: -while test $# != 0 -do - case $1 in - --*=?*) - ac_option=`expr "X$1" : 'X\([^=]*\)='` - ac_optarg=`expr "X$1" : 'X[^=]*=\(.*\)'` - ac_shift=: - ;; - --*=) - ac_option=`expr "X$1" : 'X\([^=]*\)='` - ac_optarg= - ac_shift=: - ;; - *) - ac_option=$1 - ac_optarg=$2 - ac_shift=shift - ;; - esac - - case $ac_option in - # Handling of the options. - -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) - ac_cs_recheck=: ;; - --version | --versio | --versi | --vers | --ver | --ve | --v | -V ) - $as_echo "$ac_cs_version"; exit ;; - --config | --confi | --conf | --con | --co | --c ) - $as_echo "$ac_cs_config"; exit ;; - --debug | --debu | --deb | --de | --d | -d ) - debug=: ;; - --file | --fil | --fi | --f ) - $ac_shift - case $ac_optarg in - *\'*) ac_optarg=`$as_echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;; - '') as_fn_error $? "missing file argument" ;; - esac - as_fn_append CONFIG_FILES " '$ac_optarg'" - ac_need_defaults=false;; - --he | --h | --help | --hel | -h ) - $as_echo "$ac_cs_usage"; exit ;; - -q | -quiet | --quiet | --quie | --qui | --qu | --q \ - | -silent | --silent | --silen | --sile | --sil | --si | --s) - ac_cs_silent=: ;; - - # This is an error. - -*) as_fn_error $? "unrecognized option: \`$1' -Try \`$0 --help' for more information." ;; - - *) as_fn_append ac_config_targets " $1" - ac_need_defaults=false ;; - - esac - shift -done - -ac_configure_extra_args= - -if $ac_cs_silent; then - exec 6>/dev/null - ac_configure_extra_args="$ac_configure_extra_args --silent" -fi - -_ACEOF -cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 -if \$ac_cs_recheck; then - set X '$SHELL' '$0' $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion - shift - \$as_echo "running CONFIG_SHELL=$SHELL \$*" >&6 - CONFIG_SHELL='$SHELL' - export CONFIG_SHELL - exec "\$@" -fi - -_ACEOF -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 -exec 5>>config.log -{ - echo - sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX -## Running $as_me. ## -_ASBOX - $as_echo "$ac_log" -} >&5 - -_ACEOF -cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 -_ACEOF - -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 - -# Handling of arguments. -for ac_config_target in $ac_config_targets -do - case $ac_config_target in - "Makefile") CONFIG_FILES="$CONFIG_FILES Makefile" ;; - - *) as_fn_error $? "invalid argument: \`$ac_config_target'" "$LINENO" 5;; - esac -done - - -# If the user did not use the arguments to specify the items to instantiate, -# then the envvar interface is used. Set only those that are not. -# We use the long form for the default assignment because of an extremely -# bizarre bug on SunOS 4.1.3. -if $ac_need_defaults; then - test "${CONFIG_FILES+set}" = set || CONFIG_FILES=$config_files -fi - -# Have a temporary directory for convenience. Make it in the build tree -# simply because there is no reason against having it here, and in addition, -# creating and moving files from /tmp can sometimes cause problems. -# Hook for its removal unless debugging. -# Note that there is a small window in which the directory will not be cleaned: -# after its creation but before its name has been assigned to `$tmp'. -$debug || -{ - tmp= ac_tmp= - trap 'exit_status=$? - : "${ac_tmp:=$tmp}" - { test ! -d "$ac_tmp" || rm -fr "$ac_tmp"; } && exit $exit_status -' 0 - trap 'as_fn_exit 1' 1 2 13 15 -} -# Create a (secure) tmp directory for tmp files. - -{ - tmp=`(umask 077 && mktemp -d "./confXXXXXX") 2>/dev/null` && - test -d "$tmp" -} || -{ - tmp=./conf$$-$RANDOM - (umask 077 && mkdir "$tmp") -} || as_fn_error $? "cannot create a temporary directory in ." "$LINENO" 5 -ac_tmp=$tmp - -# Set up the scripts for CONFIG_FILES section. -# No need to generate them if there are no CONFIG_FILES. -# This happens for instance with `./config.status config.h'. -if test -n "$CONFIG_FILES"; then - - -ac_cr=`echo X | tr X '\015'` -# On cygwin, bash can eat \r inside `` if the user requested igncr. -# But we know of no other shell where ac_cr would be empty at this -# point, so we can use a bashism as a fallback. -if test "x$ac_cr" = x; then - eval ac_cr=\$\'\\r\' -fi -ac_cs_awk_cr=`$AWK 'BEGIN { print "a\rb" }' /dev/null` -if test "$ac_cs_awk_cr" = "a${ac_cr}b"; then - ac_cs_awk_cr='\\r' -else - ac_cs_awk_cr=$ac_cr -fi - -echo 'BEGIN {' >"$ac_tmp/subs1.awk" && -_ACEOF - - -{ - echo "cat >conf$$subs.awk <<_ACEOF" && - echo "$ac_subst_vars" | sed 's/.*/&!$&$ac_delim/' && - echo "_ACEOF" -} >conf$$subs.sh || - as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 -ac_delim_num=`echo "$ac_subst_vars" | grep -c '^'` -ac_delim='%!_!# ' -for ac_last_try in false false false false false :; do - . ./conf$$subs.sh || - as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 - - ac_delim_n=`sed -n "s/.*$ac_delim\$/X/p" conf$$subs.awk | grep -c X` - if test $ac_delim_n = $ac_delim_num; then - break - elif $ac_last_try; then - as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 - else - ac_delim="$ac_delim!$ac_delim _$ac_delim!! " - fi -done -rm -f conf$$subs.sh - -cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 -cat >>"\$ac_tmp/subs1.awk" <<\\_ACAWK && -_ACEOF -sed -n ' -h -s/^/S["/; s/!.*/"]=/ -p -g -s/^[^!]*!// -:repl -t repl -s/'"$ac_delim"'$// -t delim -:nl -h -s/\(.\{148\}\)..*/\1/ -t more1 -s/["\\]/\\&/g; s/^/"/; s/$/\\n"\\/ -p -n -b repl -:more1 -s/["\\]/\\&/g; s/^/"/; s/$/"\\/ -p -g -s/.\{148\}// -t nl -:delim -h -s/\(.\{148\}\)..*/\1/ -t more2 -s/["\\]/\\&/g; s/^/"/; s/$/"/ -p -b -:more2 -s/["\\]/\\&/g; s/^/"/; s/$/"\\/ -p -g -s/.\{148\}// -t delim -' >$CONFIG_STATUS || ac_write_fail=1 -rm -f conf$$subs.awk -cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 -_ACAWK -cat >>"\$ac_tmp/subs1.awk" <<_ACAWK && - for (key in S) S_is_set[key] = 1 - FS = "" - -} -{ - line = $ 0 - nfields = split(line, field, "@") - substed = 0 - len = length(field[1]) - for (i = 2; i < nfields; i++) { - key = field[i] - keylen = length(key) - if (S_is_set[key]) { - value = S[key] - line = substr(line, 1, len) "" value "" substr(line, len + keylen + 3) - len += length(value) + length(field[++i]) - substed = 1 - } else - len += 1 + keylen - } - - print line -} - -_ACAWK -_ACEOF -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 -if sed "s/$ac_cr//" < /dev/null > /dev/null 2>&1; then - sed "s/$ac_cr\$//; s/$ac_cr/$ac_cs_awk_cr/g" -else - cat -fi < "$ac_tmp/subs1.awk" > "$ac_tmp/subs.awk" \ - || as_fn_error $? "could not setup config files machinery" "$LINENO" 5 -_ACEOF - -# VPATH may cause trouble with some makes, so we remove sole $(srcdir), -# ${srcdir} and @srcdir@ entries from VPATH if srcdir is ".", strip leading and -# trailing colons and then remove the whole line if VPATH becomes empty -# (actually we leave an empty line to preserve line numbers). -if test "x$srcdir" = x.; then - ac_vpsub='/^[ ]*VPATH[ ]*=[ ]*/{ -h -s/// -s/^/:/ -s/[ ]*$/:/ -s/:\$(srcdir):/:/g -s/:\${srcdir}:/:/g -s/:@srcdir@:/:/g -s/^:*// -s/:*$// -x -s/\(=[ ]*\).*/\1/ -G -s/\n// -s/^[^=]*=[ ]*$// -}' -fi - -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 -fi # test -n "$CONFIG_FILES" - - -eval set X " :F $CONFIG_FILES " -shift -for ac_tag -do - case $ac_tag in - :[FHLC]) ac_mode=$ac_tag; continue;; - esac - case $ac_mode$ac_tag in - :[FHL]*:*);; - :L* | :C*:*) as_fn_error $? "invalid tag \`$ac_tag'" "$LINENO" 5;; - :[FH]-) ac_tag=-:-;; - :[FH]*) ac_tag=$ac_tag:$ac_tag.in;; - esac - ac_save_IFS=$IFS - IFS=: - set x $ac_tag - IFS=$ac_save_IFS - shift - ac_file=$1 - shift - - case $ac_mode in - :L) ac_source=$1;; - :[FH]) - ac_file_inputs= - for ac_f - do - case $ac_f in - -) ac_f="$ac_tmp/stdin";; - *) # Look for the file first in the build tree, then in the source tree - # (if the path is not absolute). The absolute path cannot be DOS-style, - # because $ac_f cannot contain `:'. - test -f "$ac_f" || - case $ac_f in - [\\/$]*) false;; - *) test -f "$srcdir/$ac_f" && ac_f="$srcdir/$ac_f";; - esac || - as_fn_error 1 "cannot find input file: \`$ac_f'" "$LINENO" 5;; - esac - case $ac_f in *\'*) ac_f=`$as_echo "$ac_f" | sed "s/'/'\\\\\\\\''/g"`;; esac - as_fn_append ac_file_inputs " '$ac_f'" - done - - # Let's still pretend it is `configure' which instantiates (i.e., don't - # use $as_me), people would be surprised to read: - # /* config.h. Generated by config.status. */ - configure_input='Generated from '` - $as_echo "$*" | sed 's|^[^:]*/||;s|:[^:]*/|, |g' - `' by configure.' - if test x"$ac_file" != x-; then - configure_input="$ac_file. $configure_input" - { $as_echo "$as_me:${as_lineno-$LINENO}: creating $ac_file" >&5 -$as_echo "$as_me: creating $ac_file" >&6;} - fi - # Neutralize special characters interpreted by sed in replacement strings. - case $configure_input in #( - *\&* | *\|* | *\\* ) - ac_sed_conf_input=`$as_echo "$configure_input" | - sed 's/[\\\\&|]/\\\\&/g'`;; #( - *) ac_sed_conf_input=$configure_input;; - esac - - case $ac_tag in - *:-:* | *:-) cat >"$ac_tmp/stdin" \ - || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;; - esac - ;; - esac - - ac_dir=`$as_dirname -- "$ac_file" || -$as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ - X"$ac_file" : 'X\(//\)[^/]' \| \ - X"$ac_file" : 'X\(//\)$' \| \ - X"$ac_file" : 'X\(/\)' \| . 2>/dev/null || -$as_echo X"$ac_file" | - sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ - s//\1/ - q - } - /^X\(\/\/\)[^/].*/{ - s//\1/ - q - } - /^X\(\/\/\)$/{ - s//\1/ - q - } - /^X\(\/\).*/{ - s//\1/ - q - } - s/.*/./; q'` - as_dir="$ac_dir"; as_fn_mkdir_p - ac_builddir=. - -case "$ac_dir" in -.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; -*) - ac_dir_suffix=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'` - # A ".." for each directory in $ac_dir_suffix. - ac_top_builddir_sub=`$as_echo "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` - case $ac_top_builddir_sub in - "") ac_top_builddir_sub=. ac_top_build_prefix= ;; - *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; - esac ;; -esac -ac_abs_top_builddir=$ac_pwd -ac_abs_builddir=$ac_pwd$ac_dir_suffix -# for backward compatibility: -ac_top_builddir=$ac_top_build_prefix - -case $srcdir in - .) # We are building in place. - ac_srcdir=. - ac_top_srcdir=$ac_top_builddir_sub - ac_abs_top_srcdir=$ac_pwd ;; - [\\/]* | ?:[\\/]* ) # Absolute name. - ac_srcdir=$srcdir$ac_dir_suffix; - ac_top_srcdir=$srcdir - ac_abs_top_srcdir=$srcdir ;; - *) # Relative name. - ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix - ac_top_srcdir=$ac_top_build_prefix$srcdir - ac_abs_top_srcdir=$ac_pwd/$srcdir ;; -esac -ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix - - - case $ac_mode in - :F) - # - # CONFIG_FILE - # - -_ACEOF - -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 -# If the template does not know about datarootdir, expand it. -# FIXME: This hack should be removed a few years after 2.60. -ac_datarootdir_hack=; ac_datarootdir_seen= -ac_sed_dataroot=' -/datarootdir/ { - p - q -} -/@datadir@/p -/@docdir@/p -/@infodir@/p -/@localedir@/p -/@mandir@/p' -case `eval "sed -n \"\$ac_sed_dataroot\" $ac_file_inputs"` in -*datarootdir*) ac_datarootdir_seen=yes;; -*@datadir@*|*@docdir@*|*@infodir@*|*@localedir@*|*@mandir@*) - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&5 -$as_echo "$as_me: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&2;} -_ACEOF -cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 - ac_datarootdir_hack=' - s&@datadir@&$datadir&g - s&@docdir@&$docdir&g - s&@infodir@&$infodir&g - s&@localedir@&$localedir&g - s&@mandir@&$mandir&g - s&\\\${datarootdir}&$datarootdir&g' ;; -esac -_ACEOF - -# Neutralize VPATH when `$srcdir' = `.'. -# Shell code in configure.ac might set extrasub. -# FIXME: do we really want to maintain this feature? -cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 -ac_sed_extra="$ac_vpsub -$extrasub -_ACEOF -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 -:t -/@[a-zA-Z_][a-zA-Z_0-9]*@/!b -s|@configure_input@|$ac_sed_conf_input|;t t -s&@top_builddir@&$ac_top_builddir_sub&;t t -s&@top_build_prefix@&$ac_top_build_prefix&;t t -s&@srcdir@&$ac_srcdir&;t t -s&@abs_srcdir@&$ac_abs_srcdir&;t t -s&@top_srcdir@&$ac_top_srcdir&;t t -s&@abs_top_srcdir@&$ac_abs_top_srcdir&;t t -s&@builddir@&$ac_builddir&;t t -s&@abs_builddir@&$ac_abs_builddir&;t t -s&@abs_top_builddir@&$ac_abs_top_builddir&;t t -$ac_datarootdir_hack -" -eval sed \"\$ac_sed_extra\" "$ac_file_inputs" | $AWK -f "$ac_tmp/subs.awk" \ - >$ac_tmp/out || as_fn_error $? "could not create $ac_file" "$LINENO" 5 - -test -z "$ac_datarootdir_hack$ac_datarootdir_seen" && - { ac_out=`sed -n '/\${datarootdir}/p' "$ac_tmp/out"`; test -n "$ac_out"; } && - { ac_out=`sed -n '/^[ ]*datarootdir[ ]*:*=/p' \ - "$ac_tmp/out"`; test -z "$ac_out"; } && - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file contains a reference to the variable \`datarootdir' -which seems to be undefined. Please make sure it is defined" >&5 -$as_echo "$as_me: WARNING: $ac_file contains a reference to the variable \`datarootdir' -which seems to be undefined. Please make sure it is defined" >&2;} - - rm -f "$ac_tmp/stdin" - case $ac_file in - -) cat "$ac_tmp/out" && rm -f "$ac_tmp/out";; - *) rm -f "$ac_file" && mv "$ac_tmp/out" "$ac_file";; - esac \ - || as_fn_error $? "could not create $ac_file" "$LINENO" 5 - ;; - - - - esac - -done # for ac_tag - - -as_fn_exit 0 -_ACEOF -ac_clean_files=$ac_clean_files_save - -test $ac_write_fail = 0 || - as_fn_error $? "write failure creating $CONFIG_STATUS" "$LINENO" 5 - - -# configure is writing to config.log, and then calls config.status. -# config.status does its own redirection, appending to config.log. -# Unfortunately, on DOS this fails, as config.log is still kept open -# by configure, so config.status won't be able to write to it; its -# output is simply discarded. So we exec the FD to /dev/null, -# effectively closing config.log, so it can be properly (re)opened and -# appended to by config.status. When coming back to configure, we -# need to make the FD available again. -if test "$no_create" != yes; then - ac_cs_success=: - ac_config_status_args= - test "$silent" = yes && - ac_config_status_args="$ac_config_status_args --quiet" - exec 5>/dev/null - $SHELL $CONFIG_STATUS $ac_config_status_args || ac_cs_success=false - exec 5>>config.log - # Use ||, not &&, to avoid exiting from the if with $? = 1, which - # would make configure fail if this is the last instruction. - $ac_cs_success || as_fn_exit 1 -fi -if test -n "$ac_unrecognized_opts" && test "$enable_option_checking" != no; then - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: unrecognized options: $ac_unrecognized_opts" >&5 -$as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2;} -fi - -chmod a-w Makefile diff --git a/external/ocamlgraph/configure.in b/external/ocamlgraph/configure.in deleted file mode 100644 --- a/external/ocamlgraph/configure.in +++ /dev/null @@ -1,193 +0,0 @@ -########################################################################## -# # -# Ocamlgraph: a generic graph library for OCaml # -# Copyright (C) 2004-2007 # -# Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles # -# # -# This software is free software; you can redistribute it and/or # -# modify it under the terms of the GNU Library General Public # -# License version 2, with the special exception on linking # -# described in file LICENSE. # -# # -# This software is distributed in the hope that it will be useful, # -# but WITHOUT ANY WARRANTY; without even the implied warranty of # -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. # -# # -########################################################################## - -# the script generated by autoconf from this input will set the following -# variables: -# OCAMLC "ocamlc" if present in the path, or a failure -# or "ocamlc.opt" if present with same version number as ocamlc -# OCAMLOPT "ocamlopt" (or "ocamlopt.opt" if present), or "no" -# OCAMLBEST either "byte" if no native compiler was found, -# or "opt" otherwise -# OCAMLDEP "ocamldep" -# OCAMLLEX "ocamllex" (or "ocamllex.opt" if present) -# OCAMLYACC "ocamlyac" -# OCAMLLIB the path to the ocaml standard library -# OCAMLVERSION the ocaml version number -# OCAMLWEB "ocamlweb" (not mandatory) -# OCAMLWIN32 "yes"/"no" depending on Sys.os_type = "Win32" -# EXE ".exe" if OCAMLWIN32=yes, "" otherwise - -# check for one particular file of the sources -# ADAPT THE FOLLOWING LINE TO YOUR SOURCES! -AC_INIT(src/sig.mli) - -# Check for Ocaml compilers - -# we first look for ocamlc in the path; if not present, we fail -AC_CHECK_PROG(OCAMLC,ocamlc,ocamlc,no) -if test "$OCAMLC" = no ; then - AC_MSG_ERROR(Cannot find ocamlc.) -fi - -# we extract Ocaml version number and library path -OCAMLVERSION=`$OCAMLC -v | sed -n -e 's|.*version *\(.*\)$|\1|p' ` -echo "ocaml version is $OCAMLVERSION" - -case $OCAMLVERSION in - 0.*|1.*|2.*|3.00*|3.01*|3.02*|3.03*|3.04*|3.05*|3.06*|3.07*) - AC_MSG_ERROR(ocamlgraph needs ocaml version 3.08.0 or higher);; - 3.08*) - FORPACK="";; - *) - FORPACK="-for-pack Graph";; -esac - -# OCAMLLIB=`$OCAMLC -v | tail -n 1 | cut -f 4 -d " "` -# OCAMLLIB=`$OCAMLC -v | tail -n 1 | sed -e 's|[[^:]]*: \(.*\)|\1|' ` -OCAMLLIB=`$OCAMLC -where` -echo "ocaml library path is $OCAMLLIB" - -# then we look for ocamlopt; if not present, we issue a warning -# if the version is not the same, we also discard it -# we set OCAMLBEST to "opt" or "byte", whether ocamlopt is available or not -AC_CHECK_PROG(OCAMLOPT,ocamlopt,ocamlopt,no) -OCAMLBEST=byte -if test "$OCAMLOPT" = no ; then - AC_MSG_WARN(Cannot find ocamlopt; bytecode compilation only.) -else - AC_MSG_CHECKING(ocamlopt version) - TMPVERSION=`$OCAMLOPT -v | sed -n -e 's|.*version *\(.*\)$|\1|p' ` - if test "$TMPVERSION" != "$OCAMLVERSION" ; then - AC_MSG_RESULT(differs from ocamlc; ocamlopt discarded.) - OCAMLOPT=no - else - AC_MSG_RESULT(ok) - OCAMLBEST=opt - fi -fi - -# checking for ocamlc.opt -AC_CHECK_PROG(OCAMLCDOTOPT,ocamlc.opt,ocamlc.opt,no) -if test "$OCAMLCDOTOPT" != no ; then - AC_MSG_CHECKING(ocamlc.opt version) - TMPVERSION=`$OCAMLCDOTOPT -v | sed -n -e 's|.*version *\(.*\)$|\1|p' ` - if test "$TMPVERSION" != "$OCAMLVERSION" ; then - AC_MSG_RESULT(differs from ocamlc; ocamlc.opt discarded.) - else - AC_MSG_RESULT(ok) - OCAMLC=$OCAMLCDOTOPT - fi -fi - -# checking for ocamlopt.opt -if test "$OCAMLOPT" != no ; then - AC_CHECK_PROG(OCAMLOPTDOTOPT,ocamlopt.opt,ocamlopt.opt,no) - if test "$OCAMLOPTDOTOPT" != no ; then - AC_MSG_CHECKING(ocamlc.opt version) - TMPVER=`$OCAMLOPTDOTOPT -v | sed -n -e 's|.*version *\(.*\)$|\1|p' ` - if test "$TMPVER" != "$OCAMLVERSION" ; then - AC_MSG_RESULT(differs from ocamlc; ocamlopt.opt discarded.) - else - AC_MSG_RESULT(ok) - OCAMLOPT=$OCAMLOPTDOTOPT - fi - fi -fi - -# ocamldep, ocamllex and ocamlyacc should also be present in the path -AC_CHECK_PROG(OCAMLDEP,ocamldep,ocamldep,no) -if test "$OCAMLDEP" = no ; then - AC_MSG_ERROR(Cannot find ocamldep.) -fi - -AC_CHECK_PROG(OCAMLLEX,ocamllex,ocamllex,no) -if test "$OCAMLLEX" = no ; then - AC_MSG_ERROR(Cannot find ocamllex.) -else - AC_CHECK_PROG(OCAMLLEXDOTOPT,ocamllex.opt,ocamllex.opt,no) - if test "$OCAMLLEXDOTOPT" != no ; then - OCAMLLEX=$OCAMLLEXDOTOPT - fi -fi - -AC_CHECK_PROG(OCAMLYACC,ocamlyacc,ocamlyacc,no) -if test "$OCAMLYACC" = no ; then - AC_MSG_ERROR(Cannot find ocamlyacc.) -fi - -AC_CHECK_PROG(OCAMLDOC,ocamldoc,ocamldoc,true) -if test "$OCAMLDOC" = true ; then - AC_MSG_WARN(Cannot find ocamldoc) -else - AC_CHECK_PROG(OCAMLDOCOPT,ocamldoc.opt,ocamldoc.opt,no) - if test "$OCAMLDOCOPT" != no ; then - OCAMLDOC=$OCAMLDOCOPT - fi -fi - -AC_CHECK_PROG(OCAMLWEB,ocamlweb,ocamlweb,true) - -AC_CHECK_PROG(OCAMLFIND,ocamlfind,ocamlfind) - -# checking for lablgtk2 -AC_CHECK_PROG(LABLGTK2,lablgtk2,yes,no) -if test "$LABLGTK2" = yes ; then - if test -d "$OCAMLLIB/lablgtk2" ; then - INCLUDEGTK2="-I +lablgtk2" - else - LABLGTK2=no - fi -fi - -# platform -AC_MSG_CHECKING(Win32 platform) -if echo "let _ = Sys.os_type;;" | ocaml | grep -q Win32; then - AC_MSG_RESULT(yes) - OCAMLWIN32=yes - EXE=.exe - LIBEXT=.lib - OBJEXT=.obj -else - AC_MSG_RESULT(no) - OCAMLWIN32=no - EXE= - LIBEXT=.a - OBJEXT=.o -fi - -# substitutions to perform -AC_SUBST(OCAMLC) -AC_SUBST(OCAMLOPT) -AC_SUBST(OCAMLDEP) -AC_SUBST(OCAMLLEX) -AC_SUBST(OCAMLDOC) -AC_SUBST(OCAMLYACC) -AC_SUBST(OCAMLBEST) -AC_SUBST(OCAMLVERSION) -AC_SUBST(OCAMLLIB) -AC_SUBST(OCAMLWEB) -AC_SUBST(LABLGTK2) -AC_SUBST(OCAMLWIN32) -AC_SUBST(EXE) -AC_SUBST(LIBEXT) -AC_SUBST(OBJEXT) -AC_SUBST(FORPACK) -AC_SUBST(INCLUDEGTK2) - -# Finally create the Makefile from Makefile.in -AC_OUTPUT(Makefile) -chmod a-w Makefile diff --git a/external/ocamlgraph/lib/bitv.ml b/external/ocamlgraph/lib/bitv.ml deleted file mode 100644 --- a/external/ocamlgraph/lib/bitv.ml +++ /dev/null @@ -1,610 +0,0 @@ -(**************************************************************************) -(* *) -(* Ocamlgraph: a generic graph library for OCaml *) -(* Copyright (C) 2004-2007 *) -(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) -(* *) -(* This software is free software; you can redistribute it and/or *) -(* modify it under the terms of the GNU Library General Public *) -(* License version 2, with the special exception on linking *) -(* described in file LICENSE. *) -(* *) -(* This software is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) -(* *) -(**************************************************************************) - -(*i $Id: bitv.ml,v 1.3 2004-07-13 12:54:42 filliatr Exp $ i*) - -(*s Bit vectors. The interface and part of the code are borrowed from the - [Array] module of the ocaml standard library (but things are simplified - here since we can always initialize a bit vector). This module also - provides bitwise operations. *) - -(*s We represent a bit vector by a vector of integers (field [bits]), - and we keep the information of the size of the bit vector since it - can not be found out with the size of the array (field [length]). *) - -type t = { - length : int; - bits : int array } - -let length v = v.length - -(*s Each element of the array is an integer containing [bpi] bits, where - [bpi] is determined according to the machine word size. Since we do not - use the sign bit, [bpi] is 30 on a 32-bits machine and 62 on a 64-bits - machines. We maintain the following invariant: - {\em The unused bits of the last integer are always - zeros.} This is ensured by [create] and maintained in other functions - using [normalize]. [bit_j], [bit_not_j], [low_mask] and [up_mask] - are arrays used to extract and mask bits in a single integer. *) - -let bpi = Sys.word_size - 2 - -let max_length = Sys.max_array_length * bpi - -let bit_j = Array.init bpi (fun j -> 1 lsl j) -let bit_not_j = Array.init bpi (fun j -> max_int - bit_j.(j)) - -let low_mask = Array.create (succ bpi) 0 -let _ = - for i = 1 to bpi do low_mask.(i) <- low_mask.(i-1) lor bit_j.(pred i) done - -let keep_lowest_bits a j = a land low_mask.(j) - -let high_mask = Array.init (succ bpi) (fun j -> low_mask.(j) lsl (bpi-j)) - -let keep_highest_bits a j = a land high_mask.(j) - -(*s Creating and normalizing a bit vector is easy: it is just a matter of - taking care of the invariant. Copy is immediate. *) - -let create n b = - let initv = if b then max_int else 0 in - let r = n mod bpi in - if r = 0 then - { length = n; bits = Array.create (n / bpi) initv } - else begin - let s = n / bpi in - let b = Array.create (succ s) initv in - b.(s) <- b.(s) land low_mask.(r); - { length = n; bits = b } - end - -let normalize v = - let r = v.length mod bpi in - if r > 0 then - let b = v.bits in - let s = Array.length b in - b.(s-1) <- b.(s-1) land low_mask.(r) - -let copy v = { length = v.length; bits = Array.copy v.bits } - -(*s Access and assignment. The [n]th bit of a bit vector is the [j]th - bit of the [i]th integer, where [i = n / bpi] and [j = n mod - bpi]. Both [i] and [j] and computed by the function [pos]. - Accessing a bit is testing whether the result of the corresponding - mask operation is non-zero, and assigning it is done with a - bitwiwe operation: an {\em or} with [bit_j] to set it, and an {\em - and} with [bit_not_j] to unset it. *) - -let pos n = - let i = n / bpi and j = n mod bpi in - if j < 0 then (i - 1, j + bpi) else (i,j) - -let unsafe_get v n = - let (i,j) = pos n in - ((Array.unsafe_get v.bits i) land (Array.unsafe_get bit_j j)) > 0 - -let unsafe_set v n b = - let (i,j) = pos n in - if b then - Array.unsafe_set v.bits i - ((Array.unsafe_get v.bits i) lor (Array.unsafe_get bit_j j)) - else - Array.unsafe_set v.bits i - ((Array.unsafe_get v.bits i) land (Array.unsafe_get bit_not_j j)) - -(*s The corresponding safe operations test the validiy of the access. *) - -let get v n = - if n < 0 or n >= v.length then invalid_arg "Bitv.get"; - let (i,j) = pos n in - ((Array.unsafe_get v.bits i) land (Array.unsafe_get bit_j j)) > 0 - -let set v n b = - if n < 0 or n >= v.length then invalid_arg "Bitv.set"; - let (i,j) = pos n in - if b then - Array.unsafe_set v.bits i - ((Array.unsafe_get v.bits i) lor (Array.unsafe_get bit_j j)) - else - Array.unsafe_set v.bits i - ((Array.unsafe_get v.bits i) land (Array.unsafe_get bit_not_j j)) - -(*s [init] is implemented naively using [unsafe_set]. *) - -let init n f = - let v = create n false in - for i = 0 to pred n do - unsafe_set v i (f i) - done; - v - -(*s Handling bits by packets is the key for efficiency of functions - [append], [concat], [sub] and [blit]. - We start by a very general function [blit_bits a i m v n] which blits - the bits [i] to [i+m-1] of a native integer [a] - onto the bit vector [v] at index [n]. It assumes that [i..i+m-1] and - [n..n+m-1] are respectively valid subparts of [a] and [v]. - It is optimized when the bits fit the lowest boundary of an integer - (case [j == 0]). *) - -let blit_bits a i m v n = - let (i',j) = pos n in - if j == 0 then - Array.unsafe_set v i' - ((keep_lowest_bits (a lsr i) m) lor - (keep_highest_bits (Array.unsafe_get v i') (bpi - m))) - else - let d = m + j - bpi in - if d > 0 then begin - Array.unsafe_set v i' - (((keep_lowest_bits (a lsr i) (bpi - j)) lsl j) lor - (keep_lowest_bits (Array.unsafe_get v i') j)); - Array.unsafe_set v (succ i') - ((keep_lowest_bits (a lsr (i + bpi - j)) d) lor - (keep_highest_bits (Array.unsafe_get v (succ i')) (bpi - d))) - end else - Array.unsafe_set v i' - (((keep_lowest_bits (a lsr i) m) lsl j) lor - ((Array.unsafe_get v i') land (low_mask.(j) lor high_mask.(-d)))) - -(*s [blit_int] implements [blit_bits] in the particular case when - [i=0] and [m=bpi] i.e. when we blit all the bits of [a]. *) - -let blit_int a v n = - let (i,j) = pos n in - if j == 0 then - Array.unsafe_set v i a - else begin - Array.unsafe_set v i - ( (keep_lowest_bits (Array.unsafe_get v i) j) lor - ((keep_lowest_bits a (bpi - j)) lsl j)); - Array.unsafe_set v (succ i) - ((keep_highest_bits (Array.unsafe_get v (succ i)) (bpi - j)) lor - (a lsr (bpi - j))) - end - -(*s When blitting a subpart of a bit vector into another bit vector, there - are two possible cases: (1) all the bits are contained in a single integer - of the first bit vector, and a single call to [blit_bits] is the - only thing to do, or (2) the source bits overlap on several integers of - the source array, and then we do a loop of [blit_int], with two calls - to [blit_bits] for the two bounds. *) - -let unsafe_blit v1 ofs1 v2 ofs2 len = - let (bi,bj) = pos ofs1 in - let (ei,ej) = pos (ofs1 + len - 1) in - if bi == ei then - blit_bits (Array.unsafe_get v1 bi) bj len v2 ofs2 - else begin - blit_bits (Array.unsafe_get v1 bi) bj (bpi - bj) v2 ofs2; - let n = ref (ofs2 + bpi - bj) in - for i = succ bi to pred ei do - blit_int (Array.unsafe_get v1 i) v2 !n; - n := !n + bpi - done; - blit_bits (Array.unsafe_get v1 ei) 0 (succ ej) v2 !n - end - -let blit v1 ofs1 v2 ofs2 len = - if len < 0 or ofs1 < 0 or ofs1 + len > v1.length - or ofs2 < 0 or ofs2 + len > v2.length - then invalid_arg "Bitv.blit"; - unsafe_blit v1.bits ofs1 v2.bits ofs2 len - -(*s Extracting the subvector [ofs..ofs+len-1] of [v] is just creating a - new vector of length [len] and blitting the subvector of [v] inside. *) - -let sub v ofs len = - if ofs < 0 or len < 0 or ofs + len > v.length then invalid_arg "Bitv.sub"; - let r = create len false in - unsafe_blit v.bits ofs r.bits 0 len; - r - -(*s The concatenation of two bit vectors [v1] and [v2] is obtained by - creating a vector for the result and blitting inside the two vectors. - [v1] is copied directly. *) - -let append v1 v2 = - let l1 = v1.length - and l2 = v2.length in - let r = create (l1 + l2) false in - let b1 = v1.bits in - let b2 = v2.bits in - let b = r.bits in - for i = 0 to Array.length b1 - 1 do - Array.unsafe_set b i (Array.unsafe_get b1 i) - done; - unsafe_blit b2 0 b l1 l2; - r - -(*s The concatenation of a list of bit vectors is obtained by iterating - [unsafe_blit]. *) - -let concat vl = - let size = List.fold_left (fun sz v -> sz + v.length) 0 vl in - let res = create size false in - let b = res.bits in - let pos = ref 0 in - List.iter - (fun v -> - let n = v.length in - unsafe_blit v.bits 0 b !pos n; - pos := !pos + n) - vl; - res - -(*s Filling is a particular case of blitting with a source made of all - ones or all zeros. Thus we instanciate [unsafe_blit], with 0 and - [max_int]. *) - -let blit_zeros v ofs len = - let (bi,bj) = pos ofs in - let (ei,ej) = pos (ofs + len - 1) in - if bi == ei then - blit_bits 0 bj len v ofs - else begin - blit_bits 0 bj (bpi - bj) v ofs; - let n = ref (ofs + bpi - bj) in - for i = succ bi to pred ei do - blit_int 0 v !n; - n := !n + bpi - done; - blit_bits 0 0 (succ ej) v !n - end - -let blit_ones v ofs len = - let (bi,bj) = pos ofs in - let (ei,ej) = pos (ofs + len - 1) in - if bi == ei then - blit_bits max_int bj len v ofs - else begin - blit_bits max_int bj (bpi - bj) v ofs; - let n = ref (ofs + bpi - bj) in - for i = succ bi to pred ei do - blit_int max_int v !n; - n := !n + bpi - done; - blit_bits max_int 0 (succ ej) v !n - end - -let fill v ofs len b = - if ofs < 0 or len < 0 or ofs + len > v.length then invalid_arg "Bitv.fill"; - if b then blit_ones v.bits ofs len else blit_zeros v.bits ofs len - -(*s All the iterators are implemented as for traditional arrays, using - [unsafe_get]. For [iter] and [map], we do not precompute [(f - true)] and [(f false)] since [f] is likely to have - side-effects. *) - -let iter f v = - for i = 0 to v.length - 1 do f (unsafe_get v i) done - -let map f v = - let l = v.length in - let r = create l false in - for i = 0 to l - 1 do - unsafe_set r i (f (unsafe_get v i)) - done; - r - -let iteri f v = - for i = 0 to v.length - 1 do f i (unsafe_get v i) done - -let mapi f v = - let l = v.length in - let r = create l false in - for i = 0 to l - 1 do - unsafe_set r i (f i (unsafe_get v i)) - done; - r - -let fold_left f x v = - let r = ref x in - for i = 0 to v.length - 1 do - r := f !r (unsafe_get v i) - done; - !r - -let fold_right f v x = - let r = ref x in - for i = v.length - 1 downto 0 do - r := f (unsafe_get v i) !r - done; - !r - -let foldi_left f x v = - let r = ref x in - for i = 0 to v.length - 1 do - r := f !r i (unsafe_get v i) - done; - !r - -let foldi_right f v x = - let r = ref x in - for i = v.length - 1 downto 0 do - r := f i (unsafe_get v i) !r - done; - !r - -(*s Bitwise operations. It is straigthforward, since bitwise operations - can be realized by the corresponding bitwise operations over integers. - However, one has to take care of normalizing the result of [bwnot] - which introduces ones in highest significant positions. *) - -let bw_and v1 v2 = - let l = v1.length in - if l <> v2.length then invalid_arg "Bitv.bw_and"; - let b1 = v1.bits - and b2 = v2.bits in - let n = Array.length b1 in - let a = Array.create n 0 in - for i = 0 to n - 1 do - a.(i) <- b1.(i) land b2.(i) - done; - { length = l; bits = a } - -let bw_or v1 v2 = - let l = v1.length in - if l <> v2.length then invalid_arg "Bitv.bw_or"; - let b1 = v1.bits - and b2 = v2.bits in - let n = Array.length b1 in - let a = Array.create n 0 in - for i = 0 to n - 1 do - a.(i) <- b1.(i) lor b2.(i) - done; - { length = l; bits = a } - -let bw_xor v1 v2 = - let l = v1.length in - if l <> v2.length then invalid_arg "Bitv.bw_xor"; - let b1 = v1.bits - and b2 = v2.bits in - let n = Array.length b1 in - let a = Array.create n 0 in - for i = 0 to n - 1 do - a.(i) <- b1.(i) lxor b2.(i) - done; - { length = l; bits = a } - -let bw_not v = - let b = v.bits in - let n = Array.length b in - let a = Array.create n 0 in - for i = 0 to n - 1 do - a.(i) <- max_int land (lnot b.(i)) - done; - let r = { length = v.length; bits = a } in - normalize r; - r - -(*s Shift operations. It is easy to reuse [unsafe_blit], although it is - probably slightly less efficient than a ad-hoc piece of code. *) - -let rec shiftl v d = - if d == 0 then - copy v - else if d < 0 then - shiftr v (-d) - else begin - let n = v.length in - let r = create n false in - if d < n then unsafe_blit v.bits 0 r.bits d (n - d); - r - end - -and shiftr v d = - if d == 0 then - copy v - else if d < 0 then - shiftl v (-d) - else begin - let n = v.length in - let r = create n false in - if d < n then unsafe_blit v.bits d r.bits 0 (n - d); - r - end - -(*s Testing for all zeros and all ones. *) - -let all_zeros v = - let b = v.bits in - let n = Array.length b in - let rec test i = - (i == n) || ((Array.unsafe_get b i == 0) && test (succ i)) - in - test 0 - -let all_ones v = - let b = v.bits in - let n = Array.length b in - let rec test i = - if i == n - 1 then - let m = v.length mod bpi in - (Array.unsafe_get b i) == (if m == 0 then max_int else low_mask.(m)) - else - ((Array.unsafe_get b i) == max_int) && test (succ i) - in - test 0 - -(*s Conversions to and from strings. *) - -let to_string v = - let n = v.length in - let s = String.make n '0' in - for i = 0 to n - 1 do - if unsafe_get v i then s.[i] <- '1' - done; - s - -let print fmt v = Format.pp_print_string fmt (to_string v) - -let of_string s = - let n = String.length s in - let v = create n false in - for i = 0 to n - 1 do - let c = String.unsafe_get s i in - if c = '1' then - unsafe_set v i true - else - if c <> '0' then invalid_arg "Bitv.of_string" - done; - v - -(*s Iteration on all bit vectors of length [n] using a Gray code. *) - -let first_set v n = - let rec lookup i = - if i = n then raise Not_found ; - if unsafe_get v i then i else lookup (i + 1) - in - lookup 0 - -let gray_iter f n = - let bv = create n false in - let rec iter () = - f bv; - unsafe_set bv 0 (not (unsafe_get bv 0)); - f bv; - let pos = succ (first_set bv n) in - if pos < n then begin - unsafe_set bv pos (not (unsafe_get bv pos)); - iter () - end - in - if n > 0 then iter () - - -(*s Coercions to/from lists of integers *) - -let of_list l = - let n = List.fold_left max 0 l in - let b = create (succ n) false in - let add_element i = - (* negative numbers are invalid *) - if i < 0 then invalid_arg "Bitv.of_list"; - unsafe_set b i true - in - List.iter add_element l; - b - -let of_list_with_length l len = - let b = create len false in - let add_element i = - if i < 0 || i >= len then invalid_arg "Bitv.of_list_with_length"; - unsafe_set b i true - in - List.iter add_element l; - b - -let to_list b = - let n = length b in - let rec make i acc = - if i < 0 then acc - else make (pred i) (if unsafe_get b i then i :: acc else acc) - in - make (pred n) [] - - -(*s To/from integers. *) - -(* [int] *) -let of_int_us i = - { length = bpi; bits = [| i land max_int |] } -let to_int_us v = - if v.length < bpi then invalid_arg "Bitv.to_int_us"; - v.bits.(0) - -let of_int_s i = - { length = succ bpi; bits = [| i land max_int; (i lsr bpi) land 1 |] } -let to_int_s v = - if v.length < succ bpi then invalid_arg "Bitv.to_int_s"; - v.bits.(0) lor (v.bits.(1) lsl bpi) - -(* [Int32] *) -let of_int32_us i = match Sys.word_size with - | 32 -> { length = 31; - bits = [| (Int32.to_int i) land max_int; - let hi = Int32.shift_right_logical i 30 in - (Int32.to_int hi) land 1 |] } - | 64 -> { length = 31; bits = [| (Int32.to_int i) land 0x7fffffff |] } - | _ -> assert false -let to_int32_us v = - if v.length < 31 then invalid_arg "Bitv.to_int32_us"; - match Sys.word_size with - | 32 -> - Int32.logor (Int32.of_int v.bits.(0)) - (Int32.shift_left (Int32.of_int (v.bits.(1) land 1)) 30) - | 64 -> - Int32.of_int (v.bits.(0) land 0x7fffffff) - | _ -> assert false - -(* this is 0xffffffff (ocaml >= 3.08 checks for literal overflow) *) -let ffffffff = (0xffff lsl 16) lor 0xffff - -let of_int32_s i = match Sys.word_size with - | 32 -> { length = 32; - bits = [| (Int32.to_int i) land max_int; - let hi = Int32.shift_right_logical i 30 in - (Int32.to_int hi) land 3 |] } - | 64 -> { length = 32; bits = [| (Int32.to_int i) land ffffffff |] } - | _ -> assert false - -let to_int32_s v = - if v.length < 32 then invalid_arg "Bitv.to_int32_s"; - match Sys.word_size with - | 32 -> - Int32.logor (Int32.of_int v.bits.(0)) - (Int32.shift_left (Int32.of_int (v.bits.(1) land 3)) 30) - | 64 -> - Int32.of_int (v.bits.(0) land ffffffff) - | _ -> assert false - -(* [Int64] *) -let of_int64_us i = match Sys.word_size with - | 32 -> { length = 63; - bits = [| (Int64.to_int i) land max_int; - (let mi = Int64.shift_right_logical i 30 in - (Int64.to_int mi) land max_int); - let hi = Int64.shift_right_logical i 60 in - (Int64.to_int hi) land 1 |] } - | 64 -> { length = 63; - bits = [| (Int64.to_int i) land max_int; - let hi = Int64.shift_right_logical i 62 in - (Int64.to_int hi) land 1 |] } - | _ -> assert false -let to_int64_us v = failwith "todo" - -let of_int64_s i = failwith "todo" -let to_int64_s v = failwith "todo" - -(* [Nativeint] *) -let select_of f32 f64 = match Sys.word_size with - | 32 -> (fun i -> f32 (Nativeint.to_int32 i)) - | 64 -> (fun i -> f64 (Int64.of_nativeint i)) - | _ -> assert false -let of_nativeint_s = select_of of_int32_s of_int64_s -let of_nativeint_us = select_of of_int32_us of_int64_us -let select_to f32 f64 = match Sys.word_size with - | 32 -> (fun i -> Nativeint.of_int32 (f32 i)) - | 64 -> (fun i -> Int64.to_nativeint (f64 i)) - | _ -> assert false -let to_nativeint_s = select_to to_int32_s to_int64_s -let to_nativeint_us = select_to to_int32_us to_int64_us - - diff --git a/external/ocamlgraph/lib/bitv.mli b/external/ocamlgraph/lib/bitv.mli deleted file mode 100644 --- a/external/ocamlgraph/lib/bitv.mli +++ /dev/null @@ -1,195 +0,0 @@ -(**************************************************************************) -(* *) -(* Ocamlgraph: a generic graph library for OCaml *) -(* Copyright (C) 2004-2007 *) -(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) -(* *) -(* This software is free software; you can redistribute it and/or *) -(* modify it under the terms of the GNU Library General Public *) -(* License version 2, with the special exception on linking *) -(* described in file LICENSE. *) -(* *) -(* This software is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) -(* *) -(**************************************************************************) - -(*s {\bf Module Bitv}. - This module implements bit vectors, as an abstract datatype [t]. - Since bit vectors are particular cases of arrays, this module provides - the same operations as the module [Array] (Sections~\ref{barray} - up to \ref{earray}). It also provides bitwise operations - (Section~\ref{bitwise}). In the following, [false] stands for the bit 0 - and [true] for the bit 1. *) - -type t - -(*s {\bf Creation, access and assignment.} \label{barray} - [(Bitv.create n b)] creates a new bit vector of length [n], - initialized with [b]. - [(Bitv.init n f)] returns a fresh vector of length [n], - with bit number [i] initialized to the result of [(f i)]. - [(Bitv.set v n b)] sets the [n]th bit of [v] to the value [b]. - [(Bitv.get v n)] returns the [n]th bit of [v]. - [Bitv.length] returns the length (number of elements) of the given - vector. *) - -val create : int -> bool -> t - -val init : int -> (int -> bool) -> t - -val set : t -> int -> bool -> unit - -val get : t -> int -> bool - -val length : t -> int - -(*s [max_length] is the maximum length of a bit vector (System dependent). *) - -val max_length : int - -(*s {\bf Copies and concatenations.} - [(Bitv.copy v)] returns a copy of [v], - that is, a fresh vector containing the same elements as - [v]. [(Bitv.append v1 v2)] returns a fresh vector containing the - concatenation of the vectors [v1] and [v2]. [Bitv.concat] is - similar to [Bitv.append], but catenates a list of vectors. *) - -val copy : t -> t - -val append : t -> t -> t - -val concat : t list -> t - -(*s {\bf Sub-vectors and filling.} - [(Bitv.sub v start len)] returns a fresh - vector of length [len], containing the bits number [start] to - [start + len - 1] of vector [v]. Raise [Invalid_argument - "Bitv.sub"] if [start] and [len] do not designate a valid - subvector of [v]; that is, if [start < 0], or [len < 0], or [start - + len > Bitv.length a]. - - [(Bitv.fill v ofs len b)] modifies the vector [v] in place, - storing [b] in elements number [ofs] to [ofs + len - 1]. Raise - [Invalid_argument "Bitv.fill"] if [ofs] and [len] do not designate - a valid subvector of [v]. - - [(Bitv.blit v1 o1 v2 o2 len)] copies [len] elements from vector - [v1], starting at element number [o1], to vector [v2], starting at - element number [o2]. It {\em does not work} correctly if [v1] and [v2] are - the same vector with the source and destination chunks overlapping. - Raise [Invalid_argument "Bitv.blit"] if [o1] and [len] do not - designate a valid subvector of [v1], or if [o2] and [len] do not - designate a valid subvector of [v2]. *) - -val sub : t -> int -> int -> t - -val fill : t -> int -> int -> bool -> unit - -val blit : t -> int -> t -> int -> int -> unit - -(*s {\bf Iterators.} \label{earray} - [(Bitv.iter f v)] applies function [f] in turn to all - the elements of [v]. Given a function [f], [(Bitv.map f v)] applies - [f] to all - the elements of [v], and builds a vector with the results returned - by [f]. [Bitv.iteri] and [Bitv.mapi] are similar to [Bitv.iter] - and [Bitv.map] respectively, but the function is applied to the - index of the element as first argument, and the element itself as - second argument. - - [(Bitv.fold_left f x v)] computes [f (... (f (f x (get v 0)) (get - v 1)) ...) (get v (n-1))], where [n] is the length of the vector - [v]. - - [(Bitv.fold_right f a x)] computes [f (get v 0) (f (get v 1) - ( ... (f (get v (n-1)) x) ...))], where [n] is the length of the - vector [v]. *) - -val iter : (bool -> unit) -> t -> unit -val map : (bool -> bool) -> t -> t - -val iteri : (int -> bool -> unit) -> t -> unit -val mapi : (int -> bool -> bool) -> t -> t - -val fold_left : ('a -> bool -> 'a) -> 'a -> t -> 'a -val fold_right : (bool -> 'a -> 'a) -> t -> 'a -> 'a -val foldi_left : ('a -> int -> bool -> 'a) -> 'a -> t -> 'a -val foldi_right : (int -> bool -> 'a -> 'a) -> t -> 'a -> 'a - -(*s [gray_iter f n] iterates function [f] on all bit vectors - of length [n], once each, using a Gray code. The order in which - bit vectors are processed is unspecified. *) - -val gray_iter : (t -> unit) -> int -> unit - -(*s {\bf Bitwise operations.} \label{bitwise} [bwand], [bwor] and - [bwxor] implement logical and, or and exclusive or. They return - fresh vectors and raise [Invalid_argument "Bitv.xxx"] if the two - vectors do not have the same length (where \texttt{xxx} is the - name of the function). [bwnot] implements the logical negation. - It returns a fresh vector. - [shiftl] and [shiftr] implement shifts. They return fresh vectors. - [shiftl] moves bits from least to most significant, and [shiftr] - from most to least significant (think [lsl] and [lsr]). - [all_zeros] and [all_ones] respectively test for a vector only - containing zeros and only containing ones. *) - -val bw_and : t -> t -> t -val bw_or : t -> t -> t -val bw_xor : t -> t -> t -val bw_not : t -> t - -val shiftl : t -> int -> t -val shiftr : t -> int -> t - -val all_zeros : t -> bool -val all_ones : t -> bool - -(*s {\bf Conversions to and from strings.} - Least significant bit comes first. *) - -val to_string : t -> string -val of_string : string -> t -val print : Format.formatter -> t -> unit - -(*s {\bf Conversions to and from lists of integers.} - The list gives the indices of bits which are set (ie [true]). *) - -val to_list : t -> int list -val of_list : int list -> t -val of_list_with_length : int list -> int -> t - -(*s Interpretation of bit vectors as integers. Least significant bit - comes first (ie is at index 0 in the bit vector). - [to_xxx] functions truncate when the bit vector is too wide, - and raise [Invalid_argument] when it is too short. - Suffix [_s] indicates that sign bit is kept, - and [_us] that it is discarded. *) - -(* type [int] (length 31/63 with sign, 30/62 without) *) -val of_int_s : int -> t -val to_int_s : t -> int -val of_int_us : int -> t -val to_int_us : t -> int -(* type [Int32.t] (length 32 with sign, 31 without) *) -val of_int32_s : Int32.t -> t -val to_int32_s : t -> Int32.t -val of_int32_us : Int32.t -> t -val to_int32_us : t -> Int32.t -(* type [Int64.t] (length 64 with sign, 63 without) *) -val of_int64_s : Int64.t -> t -val to_int64_s : t -> Int64.t -val of_int64_us : Int64.t -> t -val to_int64_us : t -> Int64.t -(* type [Nativeint.t] (length 32/64 with sign, 31/63 without) *) -val of_nativeint_s : Nativeint.t -> t -val to_nativeint_s : t -> Nativeint.t -val of_nativeint_us : Nativeint.t -> t -val to_nativeint_us : t -> Nativeint.t - -(*s Only if you know what you are doing... *) - -val unsafe_set : t -> int -> bool -> unit -val unsafe_get : t -> int -> bool diff --git a/external/ocamlgraph/lib/heap.ml b/external/ocamlgraph/lib/heap.ml deleted file mode 100644 --- a/external/ocamlgraph/lib/heap.ml +++ /dev/null @@ -1,236 +0,0 @@ -(**************************************************************************) -(* *) -(* Ocamlgraph: a generic graph library for OCaml *) -(* Copyright (C) 2004-2007 *) -(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) -(* *) -(* This software is free software; you can redistribute it and/or *) -(* modify it under the terms of the GNU Library General Public *) -(* License version 2, with the special exception on linking *) -(* described in file LICENSE. *) -(* *) -(* This software is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) -(* *) -(**************************************************************************) - -(* $Id:$ *) - -module type Ordered = sig - type t - val compare : t -> t -> int -end - -exception EmptyHeap - -(*s Imperative implementation *) - -module Imperative(X : Ordered) = struct - - (* The heap is encoded in the array [data], where elements are stored - from [0] to [size - 1]. From an element stored at [i], the left - (resp. right) subtree, if any, is rooted at [2*i+1] (resp. [2*i+2]). *) - - type t = { mutable size : int; mutable data : X.t array } - - (* When [create n] is called, we cannot allocate the array, since there is - no known value of type [X.t]; we'll wait for the first addition to - do it, and we remember this situation with a negative size. *) - - let create n = - if n <= 0 then invalid_arg "create"; - { size = -n; data = [||] } - - let is_empty h = h.size <= 0 - - (* [resize] doubles the size of [data] *) - - let resize h = - let n = h.size in - assert (n > 0); - let n' = 2 * n in - let d = h.data in - let d' = Array.create n' d.(0) in - Array.blit d 0 d' 0 n; - h.data <- d' - - let add h x = - (* first addition: we allocate the array *) - if h.size < 0 then begin - h.data <- Array.create (- h.size) x; h.size <- 0 - end; - let n = h.size in - (* resizing if needed *) - if n == Array.length h.data then resize h; - let d = h.data in - (* moving [x] up in the heap *) - let rec moveup i = - let fi = (i - 1) / 2 in - if i > 0 && X.compare d.(fi) x < 0 then begin - d.(i) <- d.(fi); - moveup fi - end else - d.(i) <- x - in - moveup n; - h.size <- n + 1 - - let maximum h = - if h.size <= 0 then raise EmptyHeap; - h.data.(0) - - let remove h = - if h.size <= 0 then raise EmptyHeap; - let n = h.size - 1 in - h.size <- n; - let d = h.data in - let x = d.(n) in - (* moving [x] down in the heap *) - let rec movedown i = - let j = 2 * i + 1 in - if j < n then - let j = - let j' = j + 1 in - if j' < n && X.compare d.(j') d.(j) > 0 then j' else j - in - if X.compare d.(j) x > 0 then begin - d.(i) <- d.(j); - movedown j - end else - d.(i) <- x - else - d.(i) <- x - in - movedown 0 - - let pop_maximum h = let m = maximum h in remove h; m - - let iter f h = - let d = h.data in - for i = 0 to h.size - 1 do f d.(i) done - - let fold f h x0 = - let n = h.size in - let d = h.data in - let rec foldrec x i = - if i >= n then x else foldrec (f d.(i) x) (succ i) - in - foldrec x0 0 - -end - - -(*s Functional implementation *) - -module type FunctionalSig = sig - type elt - type t - val empty : t - val add : elt -> t -> t - val maximum : t -> elt - val remove : t -> t - val iter : (elt -> unit) -> t -> unit - val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a -end - -module Functional(X : Ordered) = struct - - (* Heaps are encoded as complete binary trees, i.e., binary trees - which are full expect, may be, on the bottom level where it is filled - from the left. - These trees also enjoy the heap property, namely the value of any node - is greater or equal than those of its left and right subtrees. - - There are 4 kinds of complete binary trees, denoted by 4 constructors: - [FFF] for a full binary tree (and thus 2 full subtrees); - [PPF] for a partial tree with a partial left subtree and a full - right subtree; - [PFF] for a partial tree with a full left subtree and a full right subtree - (but of different heights); - and [PFP] for a partial tree with a full left subtree and a partial - right subtree. *) - - type elt = X.t - - type t = - | Empty - | FFF of t * X.t * t (* full (full, full) *) - | PPF of t * X.t * t (* partial (partial, full) *) - | PFF of t * X.t * t (* partial (full, full) *) - | PFP of t * X.t * t (* partial (full, partial) *) - - let empty = Empty - - (* smart constructors for insertion *) - let p_f l x r = match l with - | Empty | FFF _ -> PFF (l, x, r) - | _ -> PPF (l, x, r) - - let pf_ l x = function - | Empty | FFF _ as r -> FFF (l, x, r) - | r -> PFP (l, x, r) - - let rec add x = function - | Empty -> - FFF (Empty, x, Empty) - (* insertion to the left *) - | FFF (l, y, r) | PPF (l, y, r) -> - if X.compare x y > 0 then p_f (add y l) x r else p_f (add x l) y r - (* insertion to the right *) - | PFF (l, y, r) | PFP (l, y, r) -> - if X.compare x y > 0 then pf_ l x (add y r) else pf_ l y (add x r) - - let maximum = function - | Empty -> raise EmptyHeap - | FFF (_, x, _) | PPF (_, x, _) | PFF (_, x, _) | PFP (_, x, _) -> x - - (* smart constructors for removal; note that they are different - from the ones for insertion! *) - let p_f l x r = match l with - | Empty | FFF _ -> FFF (l, x, r) - | _ -> PPF (l, x, r) - - let pf_ l x = function - | Empty | FFF _ as r -> PFF (l, x, r) - | r -> PFP (l, x, r) - - let rec remove = function - | Empty -> - raise EmptyHeap - | FFF (Empty, _, Empty) -> - Empty - | PFF (l, _, Empty) -> - l - (* remove on the left *) - | PPF (l, x, r) | PFF (l, x, r) -> - let xl = maximum l in - let xr = maximum r in - let l' = remove l in - if X.compare xl xr >= 0 then - p_f l' xl r - else - p_f l' xr (add xl (remove r)) - (* remove on the right *) - | FFF (l, x, r) | PFP (l, x, r) -> - let xl = maximum l in - let xr = maximum r in - let r' = remove r in - if X.compare xl xr > 0 then - pf_ (add xr (remove l)) xl r' - else - pf_ l xr r' - - let rec iter f = function - | Empty -> - () - | FFF (l, x, r) | PPF (l, x, r) | PFF (l, x, r) | PFP (l, x, r) -> - iter f l; f x; iter f r - - let rec fold f h x0 = match h with - | Empty -> - x0 - | FFF (l, x, r) | PPF (l, x, r) | PFF (l, x, r) | PFP (l, x, r) -> - fold f l (fold f r (f x x0)) - -end diff --git a/external/ocamlgraph/lib/heap.mli b/external/ocamlgraph/lib/heap.mli deleted file mode 100644 --- a/external/ocamlgraph/lib/heap.mli +++ /dev/null @@ -1,99 +0,0 @@ -(**************************************************************************) -(* *) -(* Ocamlgraph: a generic graph library for OCaml *) -(* Copyright (C) 2004-2007 *) -(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) -(* *) -(* This software is free software; you can redistribute it and/or *) -(* modify it under the terms of the GNU Library General Public *) -(* License version 2, with the special exception on linking *) -(* described in file LICENSE. *) -(* *) -(* This software is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) -(* *) -(**************************************************************************) - - -module type Ordered = sig - type t - val compare : t -> t -> int -end - -exception EmptyHeap - -(*S Imperative implementation. *) - -module Imperative(X: Ordered) : sig - - (* Type of imperative heaps. - (In the following [n] refers to the number of elements in the heap) *) - - type t - - (* [create c] creates a new heap, with initial capacity of [c] *) - val create : int -> t - - (* [is_empty h] checks the emptiness of [h] *) - val is_empty : t -> bool - - (* [add x h] adds a new element [x] in heap [h]; size of [h] is doubled - when maximum capacity is reached; complexity $O(log(n))$ *) - val add : t -> X.t -> unit - - (* [maximum h] returns the maximum element of [h]; raises [EmptyHeap] - when [h] is empty; complexity $O(1)$ *) - val maximum : t -> X.t - - (* [remove h] removes the maximum element of [h]; raises [EmptyHeap] - when [h] is empty; complexity $O(log(n))$ *) - val remove : t -> unit - - (* [pop_maximum h] removes the maximum element of [h] and returns it; - raises [EmptyHeap] when [h] is empty; complexity $O(log(n))$ *) - val pop_maximum : t -> X.t - - (* usual iterators and combinators; elements are presented in - arbitrary order *) - val iter : (X.t -> unit) -> t -> unit - - val fold : (X.t -> 'a -> 'a) -> t -> 'a -> 'a - -end - -(*S Functional implementation. *) - -module type FunctionalSig = sig - - (* heap elements *) - type elt - - (* Type of functional heaps *) - type t - - (* The empty heap *) - val empty : t - - (* [add x h] returns a new heap containing the elements of [h], plus [x]; - complexity $O(log(n))$ *) - val add : elt -> t -> t - - (* [maximum h] returns the maximum element of [h]; raises [EmptyHeap] - when [h] is empty; complexity $O(1)$ *) - val maximum : t -> elt - - (* [remove h] returns a new heap containing the elements of [h], except - the maximum of [h]; raises [EmptyHeap] when [h] is empty; - complexity $O(log(n))$ *) - val remove : t -> t - - (* usual iterators and combinators; elements are presented in - arbitrary order *) - val iter : (elt -> unit) -> t -> unit - - val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a - -end - -module Functional(X: Ordered) : FunctionalSig with type elt = X.t diff --git a/external/ocamlgraph/lib/unionfind.ml b/external/ocamlgraph/lib/unionfind.ml deleted file mode 100644 --- a/external/ocamlgraph/lib/unionfind.ml +++ /dev/null @@ -1,117 +0,0 @@ -(**************************************************************************) -(* *) -(* Ocamlgraph: a generic graph library for OCaml *) -(* Copyright (C) 2004-2007 *) -(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) -(* *) -(* This software is free software; you can redistribute it and/or *) -(* modify it under the terms of the GNU Library General Public *) -(* License version 2, with the special exception on linking *) -(* described in file LICENSE. *) -(* *) -(* This software is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) -(* *) -(**************************************************************************) - -(* $Id:$ *) - -module type HashedOrderedType = sig - type t - val equal : t -> t -> bool - val hash : t -> int - val compare : t -> t -> int -end - -module type S = sig - type elt - type t - - val init : elt list -> t - val find : elt -> t -> elt - val union : elt -> elt -> t -> unit -end - -module Make(X:HashedOrderedType) = struct - - type elt = X.t - - module H = Hashtbl.Make(X) - - type cell = { - mutable c : int; - data : elt; - mutable father : cell - } - - type t = cell H.t (* a forest *) - - let init l = - let h = H.create 997 in - List.iter - (fun x -> - let rec cell = { c = 0; data = x; father = cell } in - H.add h x cell) - l; - h - - let rec find_aux cell = - if cell.father == cell then - cell - else - let r = find_aux cell.father in - cell.father <- r; - r - - let find x h = (find_aux (H.find h x)).data - - let union x y h = - let rx = find_aux (H.find h x) in - let ry = find_aux (H.find h y) in - if rx != ry then begin - if rx.c > ry.c then - ry.father <- rx - else if rx.c < ry.c then - rx.father <- ry - else begin - rx.c <- rx.c + 1; - ry.father <- rx - end - end -end - -(*** test ***) -(*** - -module M = Make (struct - type t = int let - hash = Hashtbl.hash - let compare = compare - let equal = (=) - end) - -open Printf - -let saisir s = - printf "%s = " s; flush stdout; - let x = read_int () in - x - -let h = M.init [0;1;2;3;4;5;6;7;8;9] -let () = if not !Sys.interactive then - while true do - printf "1) find\n2) union\n"; - match read_int () with - 1 -> begin - let x = saisir "x" in - printf "%d\n" (M.find x h) - end - | 2 -> begin - let x, y = saisir "x", saisir "y" in - M.union x y h - end - | _ -> () - done - -***) diff --git a/external/ocamlgraph/lib/unionfind.mli b/external/ocamlgraph/lib/unionfind.mli deleted file mode 100644 --- a/external/ocamlgraph/lib/unionfind.mli +++ /dev/null @@ -1,49 +0,0 @@ -(**************************************************************************) -(* *) -(* Ocamlgraph: a generic graph library for OCaml *) -(* Copyright (C) 2004-2007 *) -(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) -(* *) -(* This software is free software; you can redistribute it and/or *) -(* modify it under the terms of the GNU Library General Public *) -(* License version 2, with the special exception on linking *) -(* described in file LICENSE. *) -(* *) -(* This software is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) -(* *) -(**************************************************************************) - - - -(* Unionfind structure over hash-ordered types. - - This module implements a unionfind data structure, given a total ordering - function and a hash function over the elements. - -*) - - -module type HashedOrderedType = sig - (* The type of the elements*) - type t - val equal : t -> t -> bool - val hash : t -> int - val compare : t -> t -> int -end - -(* Input signature of the functor Unionfind.Make *) - -module type S = sig - type elt - type t - - val init : elt list -> t - val find : elt -> t -> elt - val union : elt -> elt -> t -> unit -end - -module Make (X : HashedOrderedType) : S with type elt = X.t - - diff --git a/external/ocamlgraph/src/blocks.ml b/external/ocamlgraph/src/blocks.ml deleted file mode 100644 --- a/external/ocamlgraph/src/blocks.ml +++ /dev/null @@ -1,650 +0,0 @@ -(**************************************************************************) -(* *) -(* Ocamlgraph: a generic graph library for OCaml *) -(* Copyright (C) 2004-2007 *) -(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) -(* *) -(* This software is free software; you can redistribute it and/or *) -(* modify it under the terms of the GNU Library General Public *) -(* License version 2, with the special exception on linking *) -(* described in file LICENSE. *) -(* *) -(* This software is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) -(* *) -(**************************************************************************) - -(* $Id: per_imp.ml,v 1.32 2006-02-03 09:27:29 filliatr Exp $ *) - -(** Common implementation to persistent and imperative graphs. *) - -open Sig -open Util - -let cpt_vertex = ref min_int - (* global counter for abstract vertex *) - -(* ************************************************************************* *) -(** {2 Association table builder} *) -(* ************************************************************************* *) - -(** Common signature to an imperative/persistent association table *) -module type HM = sig - type 'a return - type 'a t - type key - val create : int -> 'a t - val create_from : 'a t -> 'a t - val empty : 'a return - val is_empty : 'a t -> bool - val add : key -> 'a -> 'a t -> 'a t - val remove : key -> 'a t -> 'a t - val mem : key -> 'a t -> bool - val find : key -> 'a t -> 'a - val find_and_raise : key -> 'a t -> string -> 'a - (** [find_and_raise k t s] is equivalent to [find k t] but - raises [Invalid_argument s] when [find k t] raises [Not_found] *) - - val iter : (key -> 'a -> unit) -> 'a t -> unit - val map : (key -> 'a -> key * 'a) -> 'a t -> 'a t - val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b - val copy : 'a t -> 'a t -end - -module type TBL_BUILDER = functor(X: COMPARABLE) -> HM with type key = X.t - -(** [HM] implementation using hashtbl. *) -module Make_Hashtbl(X: COMPARABLE) = struct - - include Hashtbl.Make(X) - - type 'a return = unit - let empty = () - (* never call and not visible for the user thank's to signature - constraints *) - - let create_from h = create (length h) - - let is_empty h = (length h = 0) - - let find_and_raise k h s = try find h k with Not_found -> invalid_arg s - - let map f h = - let h' = create_from h in - iter (fun k v -> let k, v = f k v in add h' k v) h; - h' - - let add k v h = replace h k v; h - let remove k h = remove h k; h - let mem k h = mem h k - let find k h = find h k - -end - -(** [HM] implementation using map *) -module Make_Map(X: COMPARABLE) = struct - include Map.Make(X) - type 'a return = 'a t - let is_empty m = (m = empty) - let create _ = assert false - (* never call and not visible for the user thank's to - signature constraints *) - let create_from _ = empty - let copy m = m - let map f m = fold (fun k v m -> let k, v = f k v in add k v m) m empty - let find_and_raise k h s = try find k h with Not_found -> invalid_arg s -end - -(* ************************************************************************* *) -(** {2 Blocks builder} *) -(* ************************************************************************* *) - -(** Common implementation to all (directed) graph implementations. *) -module Minimal(S: Set.S)(HM: HM) = struct - - type vertex = HM.key - - let is_directed = true - let empty = HM.empty - let create = HM.create - let is_empty = HM.is_empty - - let nb_vertex g = HM.fold (fun _ _ -> succ) g 0 - let nb_edges g = HM.fold (fun _ s n -> n + S.cardinal s) g 0 - let out_degree g v = - S.cardinal (try HM.find v g with Not_found -> invalid_arg "out_degree") - - let mem_vertex g v = HM.mem v g - - let unsafe_add_vertex g v = HM.add v S.empty g - let unsafe_add_edge g v1 v2 = HM.add v1 (S.add v2 (HM.find v1 g)) g - - let add_vertex g v = if HM.mem v g then g else unsafe_add_vertex g v - - let iter_vertex f = HM.iter (fun v _ -> f v) - let fold_vertex f = HM.fold (fun v _ -> f v) - -end - -(** All the predecessor operations from the iterators on the edges *) -module Pred(S: sig - module PV: COMPARABLE - module PE: EDGE with type vertex = PV.t - type t - val mem_vertex : PV.t -> t -> bool - val iter_edges : (PV.t -> PV.t -> unit) -> t -> unit - val fold_edges : (PV.t -> PV.t -> 'a -> 'a) -> t -> 'a -> 'a - val iter_edges_e : (PE.t -> unit) -> t -> unit - val fold_edges_e : (PE.t -> 'a -> 'a) -> t -> 'a -> 'a - end) = -struct - - open S - - let iter_pred f g v = - if not (mem_vertex v g) then invalid_arg "iter_pred"; - iter_edges (fun v1 v2 -> if PV.equal v v2 then f v1) g - - let fold_pred f g v = - if not (mem_vertex v g) then invalid_arg "fold_pred"; - fold_edges (fun v1 v2 a -> if PV.equal v v2 then f v1 a else a) g - - let pred g v = fold_pred (fun v l -> v :: l) g v [] - - let in_degree g v = - if not (mem_vertex v g) then invalid_arg "in_degree"; - fold_pred (fun v n -> n + 1) g v 0 - - let iter_pred_e f g v = - if not (mem_vertex v g) then invalid_arg "iter_pred_e"; - iter_edges_e (fun e -> if PV.equal v (PE.dst e) then f e) g - - let fold_pred_e f g v = - if not (mem_vertex v g) then invalid_arg "fold_pred_e"; - fold_edges_e (fun e a -> if PV.equal v (PE.dst e) then f e a else a) g - - let pred_e g v = fold_pred_e (fun v l -> v :: l) g v [] - -end - -(** Common implementation to all the unlabeled (directed) graphs. *) -module Unlabeled(V: COMPARABLE)(HM: HM with type key = V.t) = struct - - module S = Set.Make(V) - - module E = struct - type vertex = V.t - include OTProduct(V)(V) - let src = fst - let dst = snd - type label = unit - let label _ = () - let create v1 () v2 = v1, v2 - end - - type edge = E.t - - let mem_edge g v1 v2 = - try - S.mem v2 (HM.find v1 g) - with Not_found -> - false - - let mem_edge_e g (v1, v2) = mem_edge g v1 v2 - - let find_edge g v1 v2 = if mem_edge g v1 v2 then v1, v2 else raise Not_found - - let unsafe_remove_edge g v1 v2 = HM.add v1 (S.remove v2 (HM.find v1 g)) g - let unsafe_remove_edge_e g (v1, v2) = unsafe_remove_edge g v1 v2 - - let remove_edge g v1 v2 = - if not (HM.mem v2 g) then invalid_arg "remove_edge"; - HM.add v1 (S.remove v2 (HM.find_and_raise v1 g "remove_edge")) g - - let remove_edge_e g (v1, v2) = remove_edge g v1 v2 - - let iter_succ f g v = S.iter f (HM.find_and_raise v g "iter_succ") - let fold_succ f g v = S.fold f (HM.find_and_raise v g "fold_succ") - - let iter_succ_e f g v = iter_succ (fun v2 -> f (v, v2)) g v - let fold_succ_e f g v = fold_succ (fun v2 -> f (v, v2)) g v - - let succ g v = S.elements (HM.find_and_raise v g "succ") - let succ_e g v = fold_succ_e (fun e l -> e :: l) g v [] - - let map_vertex f = - HM.map (fun v s -> f v, S.fold (fun v s -> S.add (f v) s) s S.empty) - - module I = struct - type t = S.t HM.t - module PV = V - module PE = E - let iter_edges f = HM.iter (fun v -> S.iter (f v)) - let fold_edges f = HM.fold (fun v -> S.fold (f v)) - let iter_edges_e f = iter_edges (fun v1 v2 -> f (v1, v2)) - let fold_edges_e f = fold_edges (fun v1 v2 a -> f (v1, v2) a) - end - include I - - include Pred(struct include I let mem_vertex = HM.mem end) - -end - -(** Common implementation to all the labeled (directed) graphs. *) -module Labeled(V: COMPARABLE)(E: ORDERED_TYPE)(HM: HM with type key = V.t) = -struct - - module VE = OTProduct(V)(E) - - module S = Set.Make(VE) - - module E = struct - type vertex = V.t - type label = E.t - type t = vertex * label * vertex - let src (v, _, _) = v - let dst (_, _, v) = v - let label (_, l, _) = l - let create v1 l v2 = v1, l, v2 - module C = OTProduct(V)(VE) - let compare (x1, x2, x3) (y1, y2, y3) = - C.compare (x1, (x3, x2)) (y1, (y3, y2)) - end - - type edge = E.t - - let mem_edge g v1 v2 = - try - S.exists (fun (v2', _) -> V.equal v2 v2') (HM.find v1 g) - with Not_found -> - false - - let mem_edge_e g (v1, l, v2) = - try - let ve = v2, l in - S.exists (fun ve' -> VE.compare ve ve' == 0) (HM.find v1 g) - with Not_found -> - false - - exception Found of edge - let find_edge g v1 v2 = - try - S.iter - (fun (v2', l) -> if V.equal v2 v2' then raise (Found (v1, l, v2'))) - (HM.find v1 g); - raise Not_found - with Found e -> - e - - let unsafe_remove_edge g v1 v2 = - HM.add v1 (S.filter - (fun (v2', _) -> not (V.equal v2 v2')) (HM.find v1 g)) g - - let unsafe_remove_edge_e g (v1, l, v2) = - HM.add v1 (S.remove (v2, l) (HM.find v1 g)) g - - let remove_edge g v1 v2 = - if not (HM.mem v2 g) then invalid_arg "remove_edge"; - HM.add v1 (S.filter - (fun (v2', _) -> not (V.equal v2 v2')) - (HM.find_and_raise v1 g "remove_edge")) g - - let remove_edge_e g (v1, l, v2) = - if not (HM.mem v2 g) then invalid_arg "remove_edge_e"; - HM.add v1 (S.remove (v2, l) (HM.find_and_raise v1 g "remove_edge_e")) g - - let iter_succ f g v = - S.iter (fun (w, _) -> f w) (HM.find_and_raise v g "iter_succ") - let fold_succ f g v = - S.fold (fun (w, _) -> f w) (HM.find_and_raise v g "fold_succ") - - let iter_succ_e f g v = - S.iter (fun (w, l) -> f (v, l, w)) (HM.find_and_raise v g "iter_succ_e") - let fold_succ_e f g v = - S.fold (fun (w, l) -> f (v, l, w)) (HM.find_and_raise v g "fold_succ_e") - - let succ g v = fold_succ (fun w l -> w :: l) g v [] - let succ_e g v = fold_succ_e (fun e l -> e :: l) g v [] - - let map_vertex f = - HM.map (fun v s -> - f v, S.fold (fun (v, l) s -> S.add (f v, l) s) s S.empty) - - module I = struct - type t = S.t HM.t - module PV = V - module PE = E - - let iter_edges f = HM.iter (fun v -> S.iter (fun (w, _) -> f v w)) - let fold_edges f = HM.fold (fun v -> S.fold (fun (w, _) -> f v w)) - let iter_edges_e f = - HM.iter (fun v -> S.iter (fun (w, l) -> f (v, l, w))) - let fold_edges_e f = - HM.fold (fun v -> S.fold (fun (w, l) -> f (v, l, w))) - end - include I - - include Pred(struct include I let mem_vertex = HM.mem end) - -end - -(** The vertex module and the vertex table for the concrete graphs. *) -module ConcreteVertex(F : TBL_BUILDER)(V: COMPARABLE) = struct - - module V = struct - include V - type label = t - let label v = v - let create v = v - end - - module HM = F(V) - -end - -(* Support for explicitly maintaining edge set of - predecessors. Crucial for algorithms that do a lot of backwards - traversal. *) - -module BidirectionalMinimal(S:Set.S)(HM:HM with type key = S.elt) = -struct - - type vertex = HM.key - - let is_directed = true - let empty = HM.empty - let create = HM.create - let is_empty = HM.is_empty - - let nb_vertex g = HM.fold (fun _ _ -> succ) g 0 - let nb_edges g = HM.fold (fun _ (_,s) n -> n + S.cardinal s) g 0 - let out_degree g v = - S.cardinal (snd (try HM.find v g with Not_found -> invalid_arg "out_degree")) - - let mem_vertex g v = HM.mem v g - - let unsafe_add_vertex g v = HM.add v (S.empty,S.empty) g - let unsafe_add_edge g v1 v2 = - let (in_set,out_set) = HM.find v1 g - in - ignore ( HM.add v1 (in_set,S.add v2 out_set) g ) ; - let (in_set,out_set) = HM.find v2 g - in - HM.add v2 (S.add v1 in_set,out_set) g - - let iter_vertex f = HM.iter (fun v _ -> f v) - let fold_vertex f = HM.fold (fun v _ -> f v) -end - -module BidirectionalUnlabeled(V:COMPARABLE)(HM:HM with type key = V.t) = -struct - - module S = Set.Make(V) - - (* Edge definition *) - - module E = struct - type vertex = V.t - include OTProduct(V)(V) - let src = fst - let dst = snd - type label = unit - let label _ = () - let create v1 () v2 = v1, v2 - end - - type edge = E.t - - let mem_edge g v1 v2 = - try S.mem v2 (snd (HM.find v1 g)) - with Not_found -> false - - let mem_edge_e g (v1,v2) = mem_edge g v1 v2 - - let find_edge g v1 v2 = if mem_edge g v1 v2 then v1, v2 else raise Not_found - - let unsafe_remove_edge g v1 v2 = - let (in_set,out_set) = HM.find v1 g in - ignore ( HM.add v1 (in_set,( S.remove v2 out_set )) g ) ; - let (in_set,out_set) = HM.find v2 g in - HM.add v2 (S.remove v1 in_set,out_set) g - - let unsafe_remove_edge_e g (v1,v2) = unsafe_remove_edge g v1 v2 - - let remove_edge g v1 v2 = - if not (HM.mem v2 g) then invalid_arg "remove_edge"; - unsafe_remove_edge g v1 v2 - (* HM.add v1 (S.remove v2 (HM.find_and_raise v1 g "remove_edge")) g *) - - let remove_edge_e g (v1, v2) = remove_edge g v1 v2 - - let iter_succ f g v = S.iter f (snd (HM.find_and_raise v g "iter_succ")) - let fold_succ f g v = S.fold f (snd (HM.find_and_raise v g "fold_succ")) - - let iter_succ_e f g v = iter_succ (fun v2 -> f (v, v2)) g v - let fold_succ_e f g v = fold_succ (fun v2 -> f (v, v2)) g v - - let succ g v = S.elements (snd (HM.find_and_raise v g "succ")) - let succ_e g v = fold_succ_e (fun e l -> e :: l) g v [] - - let map_vertex f = - HM.map (fun v (s1,s2) -> - f v, - ( S.fold (fun v s -> S.add (f v) s) s1 S.empty, - S.fold (fun v s -> S.add (f v) s) s2 S.empty ) - ) - - module I = struct - (* we keep sets for both incoming and outgoing edges *) - type t = (S.t * S.t) HM.t - module PV = V - module PE = E - let iter_edges f = HM.iter (fun v (_,outset) -> S.iter (f v) outset ) - let fold_edges f = HM.fold (fun v (_,outset) -> S.fold (f v) outset ) - let iter_edges_e f = iter_edges (fun v1 v2 -> f (v1, v2)) - let fold_edges_e f = fold_edges (fun v1 v2 a -> f (v1, v2) a) - end - include I - - let iter_pred f g v = S.iter f (fst (HM.find_and_raise v g "iter_pred")) - let fold_pred f g v = S.fold f (fst (HM.find_and_raise v g "fold_pred")) - - let pred g v = S.elements (fst (HM.find_and_raise v g "pred")) - - let in_degree g v = - S.cardinal - (fst (try HM.find v g with Not_found -> invalid_arg "in_degree")) - - let iter_pred_e f g v = iter_pred (fun v2 -> f (v2,v)) g v - let fold_pred_e f g v = fold_pred (fun v2 -> f (v2,v)) g v - - let pred_e g v = fold_pred_e (fun e l -> e :: l) g v [] -end - -module Make_Abstract - (G: sig - module HM: HM - module S: Set.S - include G with type t = S.t HM.t and type V.t = HM.key - val remove_edge: t -> vertex -> vertex -> t - val remove_edge_e: t -> edge -> t - val unsafe_add_vertex: t -> vertex -> t - val unsafe_add_edge: t -> vertex -> S.elt -> t - val unsafe_remove_edge: t -> vertex -> vertex -> t - val unsafe_remove_edge_e: t -> edge -> t - val empty: S.t HM.return - val create: int -> t - end) = -struct - - module I = struct - type t = { edges : G.t; mutable size : int } - (* BE CAREFUL: [size] is only mutable in the imperative version. - As there is no extensible records in current ocaml version, - and for genericity purpose, [size] is mutable in both the - imperative and persistent implementation. - Do not modify size in the persistent implementation! *) - - type vertex = G.vertex - type edge = G.edge - - module PV = G.V - module PE = G.E - - let iter_edges f g = G.iter_edges f g.edges - let fold_edges f g = G.fold_edges f g.edges - let iter_edges_e f g = G.iter_edges_e f g.edges - let fold_edges_e f g = G.fold_edges_e f g.edges - let mem_vertex v g = G.mem_vertex g.edges v - end - include I - - include Pred(I) - - (* optimisations *) - - let is_empty g = g.size = 0 - let nb_vertex g = g.size - - (* redefinitions *) - module V = G.V - module E = G.E - module HM = G.HM - module S = G.S - - let unsafe_add_edge = G.unsafe_add_edge - let unsafe_remove_edge = G.unsafe_remove_edge - let unsafe_remove_edge_e = G.unsafe_remove_edge_e - let is_directed = G.is_directed - - let remove_edge g = G.remove_edge g.edges - let remove_edge_e g = G.remove_edge_e g.edges - - let out_degree g = G.out_degree g.edges - let in_degree g = G.in_degree g.edges - - let nb_edges g = G.nb_edges g.edges - let succ g = G.succ g.edges - let mem_vertex g = G.mem_vertex g.edges - let mem_edge g = G.mem_edge g.edges - let mem_edge_e g = G.mem_edge_e g.edges - let find_edge g = G.find_edge g.edges - - let iter_vertex f g = G.iter_vertex f g.edges - let fold_vertex f g = G.fold_vertex f g.edges - let iter_succ f g = G.iter_succ f g.edges - let fold_succ f g = G.fold_succ f g.edges - let succ_e g = G.succ_e g.edges - let iter_succ_e f g = G.iter_succ_e f g.edges - let fold_succ_e f g = G.fold_succ_e f g.edges - let map_vertex f g = { g with edges = G.map_vertex f g.edges } - -end - -(** Build persistent (resp. imperative) graphs from a persistent (resp. - imperative) association table *) -module Make(F : TBL_BUILDER) = struct - - module Digraph = struct - - module Concrete(V: COMPARABLE) = struct - include ConcreteVertex(F)(V) - include Unlabeled(V)(HM) - include Minimal(S)(HM) - - let add_edge g v1 v2 = - let g = add_vertex g v1 in - let g = add_vertex g v2 in - unsafe_add_edge g v1 v2 - - let add_edge_e g (v1, v2) = add_edge g v1 v2 - - let remove_vertex g v = - if HM.mem v g then - let g = HM.remove v g in - HM.fold - (fun k s g -> HM.add k (S.remove v s) g) - g - (HM.create_from g) - else - g - - end - - module ConcreteBidirectional(V: COMPARABLE) = struct - include ConcreteVertex(F)(V) - include BidirectionalUnlabeled(V)(HM) - include BidirectionalMinimal(S)(HM) - end - - module ConcreteLabeled(V: COMPARABLE)(E: ORDERED_TYPE_DFT) = struct - include ConcreteVertex(F)(V) - include Labeled(V)(E)(HM) - include Minimal(S)(HM) - end - - module Abstract(V: VERTEX) = struct - module G = struct - module V = V - module HM = F(V) - include Unlabeled(V)(HM) - include Minimal(S)(HM) - end - include Make_Abstract(G) - end - - module AbstractLabeled(V: VERTEX)(E: ORDERED_TYPE_DFT) = struct - module G = struct - module V = V - module HM = F(V) - include Labeled(V)(E)(HM) - include Minimal(S)(HM) - end - include Make_Abstract(G) - end - - end - -end - -(** Implementation of undirected graphs from implementation of directed - graphs. *) -module Graph(G: Sig.G) = struct - - include G - - let is_directed = false - - (* Redefine iterators and [nb_edges]. *) - - let iter_edges f = - iter_edges (fun v1 v2 -> if V.compare v1 v2 >= 0 then f v1 v2) - - let fold_edges f = - fold_edges - (fun v1 v2 acc -> if V.compare v1 v2 >= 0 then f v1 v2 acc else acc) - - let iter_edges_e f = - iter_edges_e - (fun e -> if V.compare (E.src e) (E.dst e) >= 0 then f e) - - let fold_edges_e f = - fold_edges_e - (fun e acc -> - if V.compare (E.src e) (E.dst e) >= 0 then f e acc else acc) - - let nb_edges g = fold_edges_e (fun _ -> (+) 1) g 0 - - (* Redefine operations on predecessors: - predecessors are successors in an undirected graph. *) - - let pred = succ - let in_degree = out_degree - let iter_pred = iter_succ - let fold_pred = fold_succ - let pred_e = succ_e - let iter_pred_e = iter_succ_e - let fold_pred_e = fold_succ_e - -end diff --git a/external/ocamlgraph/src/builder.ml b/external/ocamlgraph/src/builder.ml deleted file mode 100644 --- a/external/ocamlgraph/src/builder.ml +++ /dev/null @@ -1,49 +0,0 @@ -(**************************************************************************) -(* *) -(* Ocamlgraph: a generic graph library for OCaml *) -(* Copyright (C) 2004-2007 *) -(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) -(* *) -(* This software is free software; you can redistribute it and/or *) -(* modify it under the terms of the GNU Library General Public *) -(* License version 2, with the special exception on linking *) -(* described in file LICENSE. *) -(* *) -(* This software is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) -(* *) -(**************************************************************************) - -(* $Id: builder.ml,v 1.12 2004-02-20 14:37:40 signoles Exp $ *) - -open Sig - -module type S = sig - module G : Sig.G - val empty : unit -> G.t - val copy : G.t -> G.t - val add_vertex : G.t -> G.V.t -> G.t - val add_edge : G.t -> G.V.t -> G.V.t -> G.t - val add_edge_e : G.t -> G.E.t -> G.t -end - -module type INT = S with type G.V.label = int - -module P(G : Sig.P) = struct - module G = G - let empty () = G.empty - let copy g = g - let add_vertex = G.add_vertex - let add_edge = G.add_edge - let add_edge_e = G.add_edge_e -end - -module I(G : Sig.I) = struct - module G = G - let empty () = G.create ~size:997 () - let copy = G.copy - let add_vertex g v = G.add_vertex g v; g - let add_edge g v1 v2 = G.add_edge g v1 v2; g - let add_edge_e g e = G.add_edge_e g e; g -end diff --git a/external/ocamlgraph/src/builder.mli b/external/ocamlgraph/src/builder.mli deleted file mode 100644 --- a/external/ocamlgraph/src/builder.mli +++ /dev/null @@ -1,47 +0,0 @@ -(**************************************************************************) -(* *) -(* Ocamlgraph: a generic graph library for OCaml *) -(* Copyright (C) 2004-2007 *) -(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) -(* *) -(* This software is free software; you can redistribute it and/or *) -(* modify it under the terms of the GNU Library General Public *) -(* License version 2, with the special exception on linking *) -(* described in file LICENSE. *) -(* *) -(* This software is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) -(* *) -(**************************************************************************) - -(* $Id: builder.mli,v 1.13 2004-02-20 14:37:40 signoles Exp $ *) - -(** Graph builders *) - -open Sig - -(** {1 Common interface for graph builders}. - - Note: the following functions always return graphs but this is meaningless - for imperative implementations (the graph is modified in-place). - This is just to provide a common interface. *) - -module type S = sig - module G : Sig.G - val empty : unit -> G.t - val copy : G.t -> G.t - val add_vertex : G.t -> G.V.t -> G.t - val add_edge : G.t -> G.V.t -> G.V.t -> G.t - val add_edge_e : G.t -> G.E.t -> G.t -end - -module type INT = S with type G.V.label = int - -(** {1 Builders for the various graph implementations} *) - -module P(G : Sig.P) : S with module G = G - (** Persistent Graphs Builders *) - -module I(G : Sig.I) : S with module G = G - (** Imperative Graphs Builders *) diff --git a/external/ocamlgraph/src/classic.ml b/external/ocamlgraph/src/classic.ml deleted file mode 100644 --- a/external/ocamlgraph/src/classic.ml +++ /dev/null @@ -1,85 +0,0 @@ -(**************************************************************************) -(* *) -(* Ocamlgraph: a generic graph library for OCaml *) -(* Copyright (C) 2004-2007 *) -(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) -(* *) -(* This software is free software; you can redistribute it and/or *) -(* modify it under the terms of the GNU Library General Public *) -(* License version 2, with the special exception on linking *) -(* described in file LICENSE. *) -(* *) -(* This software is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) -(* *) -(**************************************************************************) - -(* $Id: classic.ml,v 1.9 2004-02-02 08:11:14 filliatr Exp $ *) - -module type S = sig - type graph - val divisors : int -> graph - val de_bruijn : int -> graph - val vertex_only : int -> graph - val full : ?self:bool -> int -> graph -end - -module Generic(B : Builder.INT) = struct - - type graph = B.G.t - - let divisors n = - if n < 2 then invalid_arg "divisors"; - let v = Array.init (n + 1) (fun i -> B.G.V.create i) in - let rec loop g i = - let sqrt_i = truncate (sqrt (float i)) in - let rec loop_i g d = - if d > sqrt_i then - g - else if i mod d == 0 then - loop_i (B.add_edge (B.add_edge g v.(i / d) v.(i)) v.(d) v.(i)) (d+1) - else - loop_i g (succ d) - in - if i > n then g else loop (loop_i (B.add_vertex g v.(i)) 2) (i+1) - in - loop (B.empty ()) 2 - - let fold_for i0 i1 f = - let rec loop i v = if i > i1 then v else loop (i + 1) (f v i) in - loop i0 - - let de_bruijn n = - if n < 1 || n > Sys.word_size - 1 then invalid_arg "de_bruijn"; - let v = Array.init (1 lsl n) (fun i -> B.G.V.create i) in - let all_1 = 1 lsl n - 1 in (* 11...1 *) - let g = fold_for 0 all_1 (fun g i -> B.add_vertex g v.(i)) (B.empty ()) in - let rec loop g i = - if i > all_1 then - g - else - let si = (i lsl 1) land all_1 in - let g = B.add_edge g v.(i) v.(si) in - let g = B.add_edge g v.(i) v.(si lor 1) in - loop g (i + 1) - in - loop g 0 - - let vertex_only n = - fold_for 1 n (fun g i -> B.add_vertex g (B.G.V.create i)) (B.empty ()) - - let full ?(self=true) n = - let v = Array.init (n + 1) (fun i -> B.G.V.create i) in - fold_for 1 n - (fun g i -> - fold_for 1 n - (fun g j -> if self || i <> j then B.add_edge g v.(i) v.(j) else g) - g) - (fold_for 1 n (fun g i -> B.add_vertex g v.(i)) (B.empty ())) - -end - -module P (G : Sig.P with type V.label = int) = Generic(Builder.P(G)) - -module I (G : Sig.I with type V.label = int) = Generic(Builder.I(G)) diff --git a/external/ocamlgraph/src/classic.mli b/external/ocamlgraph/src/classic.mli deleted file mode 100644 --- a/external/ocamlgraph/src/classic.mli +++ /dev/null @@ -1,54 +0,0 @@ -(**************************************************************************) -(* *) -(* Ocamlgraph: a generic graph library for OCaml *) -(* Copyright (C) 2004-2007 *) -(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) -(* *) -(* This software is free software; you can redistribute it and/or *) -(* modify it under the terms of the GNU Library General Public *) -(* License version 2, with the special exception on linking *) -(* described in file LICENSE. *) -(* *) -(* This software is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) -(* *) -(**************************************************************************) - -(* $Id: classic.mli,v 1.12 2005-02-25 13:54:33 signoles Exp $ *) - -(** Some classic graphs *) - -module type S = sig - - type graph - - val divisors : int -> graph - (** [divisors n] builds the graph of divisors. - Vertices are integers from [2] to [n]. [i] is connected to [j] if - and only if [i] divides [j]. - @raise Invalid_argument is [n < 2]. *) - - val de_bruijn : int -> graph - (** [de_bruijn n] builds the de Bruijn graph of order [n]. - Vertices are bit sequences of length [n] (encoded as their - interpretation as binary integers). The sequence [xw] is connected - to the sequence [wy] for any bits [x] and [y] and any bit sequence - [w] of length [n-1]. - @raise Invalid_argument is [n < 1] or [n > Sys.word_size-1]. *) - - val vertex_only : int -> graph - (** [vertex_only n] builds a graph with [n] vertices and no edge. *) - - val full : ?self:bool -> int -> graph - (** [full n] builds a graph with [n] vertices and all possible edges. - The optional argument [self] indicates if loop edges should be added - (default value is [true]). *) - -end - -module P (G : Sig.P with type V.label = int) : S with type graph = G.t - (** Classic Persistent Graphs *) - -module I (G : Sig.I with type V.label = int) : S with type graph = G.t - (** Classic Imperative Graphs *) diff --git a/external/ocamlgraph/src/cliquetree.ml b/external/ocamlgraph/src/cliquetree.ml deleted file mode 100644 --- a/external/ocamlgraph/src/cliquetree.ml +++ /dev/null @@ -1,343 +0,0 @@ -(**************************************************************************) -(* *) -(* Ocamlgraph: a generic graph library for OCaml *) -(* Copyright (C) 2004-2007 *) -(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) -(* *) -(* This software is free software; you can redistribute it and/or *) -(* modify it under the terms of the GNU Library General Public *) -(* License version 2, with the special exception on linking *) -(* described in file LICENSE. *) -(* *) -(* This software is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) -(* *) -(**************************************************************************) - -(** - Clique tree of a graph. - - @author Matthieu Sozeau -*) - -(*i $Id: cliquetree.ml,v 1.6 2005-11-02 13:43:35 filliatr Exp $ i*) - -module CliqueTree(Gr : Sig.G) = struct - - (* Original vertex set (of Gr) *) - module OVSet = Set.Make(Gr.V) - - (* Vertex signature *) - module rec CliqueV : - sig - type t - val compare : t -> t -> int - val hash : t -> int - val equal : t -> t -> bool - val label : t -> t - val create : Gr.V.t -> t - val vertex : t -> Gr.V.t - val number : t -> int - val set_number : t -> int -> unit - val clique : t -> int - val set_clique : t -> int -> unit - val mark : t -> int - val incr_mark : t -> unit - val m : t -> CVS.t - val set_m : t -> CVS.t -> unit - val last : t -> t - val set_last : t -> t -> unit - end = - struct - type t = { - mutable mark: int; - orig: Gr.V.t; - mutable m: CVS.t; - mutable last: t option; - mutable number: int; - mutable clique: int; - } - - let compare x y = Gr.V.compare x.orig y.orig - let hash x = Gr.V.hash x.orig - let equal x y = Gr.V.equal x.orig y.orig - - type label = t - let label x = x - - let create o = { - mark = 0; - orig = o; - m = CVS.empty; - last = None; - number = 0; - clique = -1; - } - - let vertex x = x.orig - - let clique x = x.clique - let set_clique x v = x.clique <- v - - let number x = x.number - let set_number x v = x.number <- v - - let mark x = x.mark - let incr_mark x = - (*Printf.printf "Increasing mark of %s to %i\n%!" - (Gr.v_to_string x.orig) (succ x.mark);*) - x.mark <- succ x.mark - - let m x = x.m - let set_m x v = x.m <- v - - let last x = - match x.last with - Some v -> v - | None -> failwith "last not set" - - let set_last x v = x.last <- Some v - - end - (* Clique tree vertex set *) - and CVS : Set.S with type elt = CliqueV.t = Set.Make(CliqueV) - - (* The final clique tree vertex type: - - set of original vertexes ordered by mark. - - clique number. - *) - module CliqueTreeV = - Util.DataV - (struct type t = CliqueV.t list * CVS.t end) - (struct - type t = int - type label = int - let compare x y = Pervasives.compare x y - let hash = Hashtbl.hash - let equal x y = x = y - let label x = x - let create lbl = lbl - end) - - module CliqueTreeE = struct - type t = int * CVS.t - - let compare (x, _) (y, _) = Pervasives.compare x y - - let default = (0, CVS.empty) - - let create n s = (n, s) - - let vertices = snd - - let width g tri (_, x) = - let vertices = List.map CliqueV.vertex (CVS.elements x) in - let w = - List.fold_left - (fun w v -> - List.fold_left - (fun w v' -> - if v <> v' then - if not (Gr.mem_edge g v v') && Gr.mem_edge tri v v' - then succ w - else w - else w) - w vertices) - 0 vertices - in - assert(w mod 2 = 0); - w / 2 - end - - (* The returned tree *) - module CliqueTree = - Persistent.Digraph.ConcreteLabeled(CliqueTreeV)(CliqueTreeE) - - (* Intermediate graph *) - module G = Persistent.Graph.Concrete(CliqueV) - - (* Convenient types *) - module EdgeSet = Set.Make(G.E) - module H = Hashtbl.Make(CliqueV) - - (* Used to choose some vertex in the intermediate graph *) - module Choose = Oper.Choose(G) - - (* Creates the intermediate graph from the original *) - module Copy = Gmap.Vertex(Gr)(struct include G include Builder.P(G) end) - - open CliqueV - - let vertices_list x = - let l = CVS.elements x in - List.sort - (fun x y -> - (*let markx = mark x and marky = mark y in*) - - Pervasives.compare (number x) (number y)) - l - - let mcs_clique g = - (* initializations *) - let n = Gr.nb_vertex g in - let g' = Copy.map CliqueV.create g in - let unnumbered = ref (G.fold_vertex CVS.add g' CVS.empty) in - let pmark = ref (-1) in - let order = ref [] in - let cliques = Array.make n ([], CVS.empty) in - let ties = ref [] in - let j = ref 0 in - (* loop, taking each unnumbered vertex in turn *) - for i = n downto 1 do - (* Find greatest unnumbered vertex - if CVS.is_empty !unnumbered then - Printf.printf "No more unnumbered vertices\n%!" - else - Printf.printf "%i unnumbered vertices remaining\n%!" - (CVS.cardinal !unnumbered); - *) - let x, mark = - let choosed = CVS.choose !unnumbered in - CVS.fold - (fun x ((maxx, maxv) as max) -> - let v = mark x in - if v > maxv then (x, v) else max) - !unnumbered (choosed, mark choosed) - in - (* peo construction *) - order := x :: !order; - (* now numbered *) - unnumbered := CVS.remove x !unnumbered; - if mark <= !pmark then begin - (* Create a new clique (lemma 8) *) - incr j; - (* m x is the neighborhoud of x in the previous clique *) - cliques.(!j) <- ([x], CVS.add x (m x)); - (* Use reverse map of cliques to find what clique - we're connected to. m x is the width of the ties *) - let clast = clique (last x) in - ties := (clast, m x, !j) :: !ties; - end else begin - let l, c = cliques.(!j) in - cliques.(!j) <- (x::l, CVS.add x c); - end; - G.iter_succ - (fun y -> - if number y == 0 then begin - incr_mark y; - set_m y (CVS.add x (m y)); - end; - set_last y x) - g' x; - pmark := mark; - set_number x i; - set_clique x !j; - done; - let cliques = - Array.mapi - (fun i (l, c) -> CliqueTreeV.create (List.rev l, c) i) - (Array.sub cliques 0 (succ !j)) - in - let tree = - Array.fold_left CliqueTree.add_vertex CliqueTree.empty cliques - in - let tree, _ = - List.fold_left - (fun (g, n) (i, verts, j) -> - let label = CliqueTreeE.create n verts in - let edge = CliqueTree.E.create cliques.(i) label cliques.(j) in - (CliqueTree.add_edge_e g edge, succ n)) - (tree, 1) !ties - in - List.map CliqueV.vertex !order, tree, cliques.(0) - - let sons g x = CliqueTree.fold_succ (fun x y -> x :: y) g x [] - - exception NotClique - - let rec drop_while p l = - match l with - | x :: tl -> - if p x then drop_while p tl - else l - | [] -> [] - - let test_simpliciality_first l sons = - let takeOne l = match !l with - | x :: xs -> l := xs; Some x - | [] -> None - in - let vertices = ref l in - let sons = ref sons in - try - while !vertices <> [] && not (List.for_all (fun c -> !c = []) !sons) do - (match takeOne vertices with - Some v -> - let mark = CliqueV.mark v in - List.iter - (fun s -> - match !s with - | y :: tl -> - let ymark = CliqueV.mark y in - if ymark > mark then - () - else if ymark = mark then - s := drop_while - (fun y -> CliqueV.mark y = mark) tl - else raise NotClique - | [] -> ()) - !sons - | None -> assert false); - done; - !vertices <> [] - with NotClique -> false - - let test_simpliciality_first' l sons = - List.for_all - (fun son -> - match !son with - | [] -> false - | xi :: tl -> - let other = m xi in - CVS.subset other l) - sons - - let test_simpliciality_next vertices sons = - match vertices with - | x :: tl -> - begin - try - ignore( - List.fold_left - (fun vm v' -> - let vm' = CliqueV.m v' in - if CVS.equal vm' vm then - CVS.add v' vm' - else raise NotClique) - (CVS.add x (m x)) tl); - true - with NotClique -> false - end - | _ -> true - - let is_chordal g = - let order, tree, root = mcs_clique g in - let rec aux c = - let csons = sons tree c in - let s = List.map CliqueTreeV.data csons in - let l = CliqueTreeV.data c in - let sons () = List.map (fun (x,y) -> ref x) s in - let first = test_simpliciality_first' (snd l) (sons ()) in - let next = test_simpliciality_next (fst l) (sons ()) in - first && next && (List.for_all aux csons) - in - aux root - - let maxwidth g tri tree = - CliqueTree.fold_edges_e - (fun e res -> - let w = CliqueTreeE.width g tri (CliqueTree.E.label e) in - max res w) - tree 0 - -end diff --git a/external/ocamlgraph/src/cliquetree.mli b/external/ocamlgraph/src/cliquetree.mli deleted file mode 100644 --- a/external/ocamlgraph/src/cliquetree.mli +++ /dev/null @@ -1,90 +0,0 @@ -(**************************************************************************) -(* *) -(* Ocamlgraph: a generic graph library for OCaml *) -(* Copyright (C) 2004-2007 *) -(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) -(* *) -(* This software is free software; you can redistribute it and/or *) -(* modify it under the terms of the GNU Library General Public *) -(* License version 2, with the special exception on linking *) -(* described in file LICENSE. *) -(* *) -(* This software is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) -(* *) -(**************************************************************************) - -(** - Construction of the clique tree of a graph and recognition - of chordal graphs. - - Based on the article: - Chordal graphs and their clique graph - by P. Galinier, M. Habib and C. Paul. - - @author Matthieu Sozeau -*) - -(*i $Id: cliquetree.mli,v 1.4 2004-10-19 15:22:47 signoles Exp $ i*) - -module CliqueTree(G : Sig.G) : sig - - (** Original graph vertex *) - module CliqueV : - sig - type t - val compare : t -> t -> int - val hash : t -> int - val equal : t -> t -> bool - val label : t -> t - val create : G.V.t -> t - val vertex : t -> G.V.t - end - - (** Set of original vertices *) - module CVS : Set.S with type elt = CliqueV.t - - (** Clique tree vertex type *) - module CliqueTreeV : sig - (** Trace of the algorithm as a list of markers Clique vertices *) - type data = CliqueV.t list * CVS.t - type label - type t - - val compare : t -> t -> int - val hash : t -> int - val equal : t -> t -> bool - - val create : data -> label -> t - val label : t -> label - val data : t -> data - end - - module CliqueTreeE : sig - type t = int * CVS.t - val compare : t -> t -> int - val default : t - val create : int -> CVS.t -> t - - (** Vertices in the clique tree edge - (intersection of the two clique extremities). *) - val vertices : t -> CVS.t - end - - (** The clique tree graph type *) - module CliqueTree : Sig.G with type V.t = CliqueTreeV.t - and type E.label = CliqueTreeE.t - - (** [mcs_clique g] return an perfect elimination order of [g] - (if it is chordal), the clique tree of [g] and its root. *) - val mcs_clique : G.t -> G.V.t list * CliqueTree.t * CliqueTree.V.t - - (** [is_chordal g] uses the clique tree construction to test if a graph is - chordal or not. *) - val is_chordal : G.t -> bool - - (** [maxwidth g tri tree] returns the maxwidth characteristic of the - triangulation [tri] of graph [g] given the clique tree [tree] of [tri]. *) - val maxwidth : G.t -> G.t -> CliqueTree.t -> int -end diff --git a/external/ocamlgraph/src/components.ml b/external/ocamlgraph/src/components.ml deleted file mode 100644 --- a/external/ocamlgraph/src/components.ml +++ /dev/null @@ -1,90 +0,0 @@ -(**************************************************************************) -(* *) -(* Ocamlgraph: a generic graph library for OCaml *) -(* Copyright (C) 2004-2007 *) -(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) -(* *) -(* This software is free software; you can redistribute it and/or *) -(* modify it under the terms of the GNU Library General Public *) -(* License version 2, with the special exception on linking *) -(* described in file LICENSE. *) -(* *) -(* This software is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) -(* *) -(**************************************************************************) - -(* $Id: components.ml,v 1.9 2004-10-22 14:42:06 signoles Exp $ *) - -open Util - -module type G = sig - type t - module V : Sig.COMPARABLE - val iter_vertex : (V.t -> unit) -> t -> unit - val iter_succ : (V.t -> unit) -> t -> V.t -> unit -end - -module Make(G: G) = struct - - module H = Hashtbl.Make(G.V) - module S = Set.Make(G.V) - - let scc g = - let root = H.create 997 in - let hashcomp = H.create 997 in - let stack = ref [] in - let numdfs = ref 0 in - let numcomp = ref 0 in - let rec pop x c = function - | (y, w) :: l when y > x -> - H.add hashcomp w !numcomp; - pop x (S.add w c) l - | l -> c,l - in - let rec visit v = - if not (H.mem root v) then - begin - let n = incr numdfs; !numdfs in - H.add root v n; - G.iter_succ - (fun w -> - visit w; - if not (H.mem hashcomp w) then - H.replace root v (min (H.find root v) (H.find root w))) - g v; - if H.find root v = n then - (H.add hashcomp v !numcomp; - let comp,s = pop n (S.add v S.empty) !stack in - stack:= s; - incr numcomp) - else stack := (n,v)::!stack; - end - in - G.iter_vertex visit g; - (!numcomp,(fun v -> H.find hashcomp v)) - - let scc_array g = - let n,f = scc g in - let t = Array.make n [] in - G.iter_vertex - (fun v -> let i = f v in t.(i) <- v::t.(i)) g; - t - - let scc_list g = - let _,scc = scc g in - let tbl = Hashtbl.create 97 in - G.iter_vertex - (fun v -> - let n = scc v in - try - let l = Hashtbl.find tbl n in - l := v :: !l - with Not_found -> - Hashtbl.add tbl n (ref [ v ])) - g; - Hashtbl.fold (fun _ v l -> !v :: l) tbl [] - - -end diff --git a/external/ocamlgraph/src/components.mli b/external/ocamlgraph/src/components.mli deleted file mode 100644 --- a/external/ocamlgraph/src/components.mli +++ /dev/null @@ -1,53 +0,0 @@ -(**************************************************************************) -(* *) -(* Ocamlgraph: a generic graph library for OCaml *) -(* Copyright (C) 2004-2007 *) -(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) -(* *) -(* This software is free software; you can redistribute it and/or *) -(* modify it under the terms of the GNU Library General Public *) -(* License version 2, with the special exception on linking *) -(* described in file LICENSE. *) -(* *) -(* This software is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) -(* *) -(**************************************************************************) - -(* $Id: components.mli,v 1.12 2004-10-22 14:42:06 signoles Exp $ *) - -(** Strongly connected components *) - -open Util - -(** Minimal graph signature for [scc] *) -module type G = sig - type t - module V : Sig.COMPARABLE - val iter_vertex : (V.t -> unit) -> t -> unit - val iter_succ : (V.t -> unit) -> t -> V.t -> unit -end - -module Make (G: G) : sig - - val scc : G.t -> int*(G.V.t -> int) - (** [scc g] computes the strongly connected components of [g]. - The result is a pair [(n,f)] where [n] is the number of - components. Components are numbered from [0] to [n-1], and - [f] is a function mapping each vertex to its component - number. In particular, [f u = f v] if and only if [u] and - [v] are in the same component. Another property of the - numbering is that components are numbered in a topological - order: if there is an arc from [u] to [v], then [f u >= f u] *) - - val scc_array : G.t -> G.V.t list array - (** [scc_array] computes the strongly connected components of [g]. - Components are stored in the resulting array, indexed with a - numbering with the same properties as for [scc] above. *) - - val scc_list : G.t -> G.V.t list list - (** [scc_list] computes the strongly connected components of [g]. - The result is a partition of the set of the vertices of [g]. *) - -end diff --git a/external/ocamlgraph/src/delaunay.ml b/external/ocamlgraph/src/delaunay.ml deleted file mode 100644 --- a/external/ocamlgraph/src/delaunay.ml +++ /dev/null @@ -1,344 +0,0 @@ -(**************************************************************************) -(* *) -(* Ocamlgraph: a generic graph library for OCaml *) -(* Copyright (C) 2004-2007 *) -(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) -(* *) -(* This software is free software; you can redistribute it and/or *) -(* modify it under the terms of the GNU Library General Public *) -(* License version 2, with the special exception on linking *) -(* described in file LICENSE. *) -(* *) -(* This software is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) -(* *) -(**************************************************************************) - -(* $Id: delaunay.ml,v 1.12 2005-11-02 13:43:35 filliatr Exp $ *) - -(** Code follows Don Knuth's algorithm - from ``Axioms and hulls'' (LNCS 606, Springer-Verlag, 1992), pp. 73-77 *) - -open Printf - -module type CCC = sig - type point - val ccw : point -> point -> point -> bool - val in_circle : point -> point -> point -> point -> bool -end - -module type Triangulation = sig - module S : CCC - type triangulation - val triangulate : S.point array -> triangulation - val iter : (S.point -> S.point -> unit) -> triangulation -> unit - val fold : (S.point -> S.point -> 'a -> 'a) -> triangulation -> 'a -> 'a -end - -module Make (S : CCC) = struct - - module S = S - - type point = Point of int | Infinity - - type arc = { mutable vert : point; - mutable next : arc; - mutable inst : node ref; - mate : int } - and node = - | Branch of int * int * node ref * node ref - | Terminal of arc - - type triangulation = { - points : S.point array; - arcs : arc array; - last_used_arc : int - } - - let rec dummy_arc = - { vert = Infinity; next = dummy_arc; - inst = ref (Terminal dummy_arc); mate = -1 } - - let make_arc n i = - { vert = Infinity; next = dummy_arc; - inst = ref (Terminal dummy_arc); mate = 6 * n - 7 - i } - - let finite = function Point p -> p | Infinity -> assert false - - (* [flip] will be used in both steps T4 and T5 *) - let flip c d e t'' p n n' = - let e' = e.next in - let c' = c.next in - let c'' = c'.next in - e.next <- c; - c.next <- c''; - c''.next <- e; - c''.inst <- n; c.inst <- n; e.inst <- n; - c.vert <- Point p; - d.next <- e'; - e'.next <- c'; - c'.next <- d; - c'.inst <- n'; e'.inst <- n'; d.inst <- n'; - d.vert <- Point t'' - - let triangulate points = - let ccw p q r = S.ccw points.(p) points.(q) points.(r) in - let in_circle p q r s = - S.in_circle points.(p) points.(q) points.(r) points.(s) - in - let n = Array.length points in - if n < 2 then invalid_arg "triangulate"; - let arcs = Array.init (6 * n - 6) (make_arc n) in - let mate i = 6 * n - 7 - i in - - (*i DEBUG - let rec dump d l = - eprintf "%s" (String.make (2*d) ' '); - match !l with - | Terminal a -> - eprintf "T %d\n" (mate a.mate) - | Branch (u, v, l, r) -> - eprintf "N %d %d\n" u v; - dump (d+1) l; - dump (d+1) r - in - i*) - - (* initialization: - create a trivial triangulation for the first 2 vertices *) - let u = 0 in - let v = 1 in - let a1 = arcs.(0) in - let a2 = arcs.(1) in - let a3 = arcs.(2) in - let b1 = arcs.(mate 0) in - let b2 = arcs.(mate 1) in - let b3 = arcs.(mate 2) in - let l1 = ref (Terminal a2) in - let l2 = ref (Terminal b3) in - a1.vert <- Point v; a1.next <- a2; a1.inst <- l1; - a2.vert <- Infinity; a2.next <- a3; a2.inst <- l1; - a3.vert <- Point u; a3.next <- a1; a3.inst <- l1; - b1.vert <- Point u; b1.next <- b3; b1.inst <- l2; - b2.vert <- Point v; b2.next <- b1; b2.inst <- l2; - b3.vert <- Infinity; b3.next <- b2; b3.inst <- l2; - let l0 = ref (Branch (u, v, l1, l2)) in - let j = ref 2 in (* last used arc *) - - (* then for each new vertex [p] *) - for p = 2 to n - 1 do - (* Step T1 *) - let rec step_T1 l p = match !l with - | Terminal al -> - l, al - | Branch (pl, ql, al, bl) -> - step_T1 (if ccw pl ql p then al else bl) p - in - let l, al = step_T1 l0 p in - - (* Step T2 *) - let a = al in - let b = a.next in - let c = b.next in - let q = a.vert in - let r = b.vert in - let s = c.vert in - j := !j + 3; - let aj = arcs.(!j) in - let aj_1 = arcs.(!j - 1) in - let aj_2 = arcs.(!j - 2) in - let bj = arcs.(aj.mate) in - let bj_1 = arcs.(aj_1.mate) in - let bj_2 = arcs.(aj_2.mate) in - let l' = ref (Terminal a) in - let l'' = ref (Terminal aj) in - let l''' = ref (Terminal c) in - aj.vert <- q; aj.next <- b; aj.inst <- l''; - aj_1.vert <- r; aj_1.next <- c; aj_1.inst <- l'''; - aj_2.vert <- s; aj_2.next <- a; aj_2.inst <- l'; - bj.vert <- Point p; bj.next <- aj_2; bj.inst <- l'; - bj_1.vert <- Point p; bj_1.next <- aj; bj_1.inst <- l''; - bj_2.vert <- Point p; bj_2.next <- aj_1; bj_2.inst <- l'''; - a.next <- bj; a.inst <- l'; - b.next <- bj_1; b.inst <- l''; - c.next <- bj_2; c.inst <- l'''; - let r = finite r in - let s = finite s in - - (* steps T3 or T4 depending on [q] *) - let r = match q with - | Point q -> (* Step T3 *) - let n = ref (Branch (q, p, l', l'')) in - let n' = ref (Branch (s, p, l''', l')) in - l := Branch (r, p, n, n'); - r - | Infinity -> (* Step T4 *) - let n = ref (Branch (s, p, l''', l')) in - l := Branch (r, p, l'', n); - let rec loop m a d s t = - if t <> r && ccw p s t then begin - let n = ref (Terminal d) in - match !m with - | Branch (mu, mv, ml, is_l') -> - assert (is_l' == l'); - m := Branch (mu, mv, ml, d.inst); - d.inst := Branch (t, p, n, l'); - let m = d.inst in - flip a arcs.(a.mate) d t p n l'; - let a = arcs.(a.mate).next in - let d = arcs.(a.mate).next in - let s = t in - let t = finite d.vert in - l' := Terminal a; - loop m a d s t - | Terminal _ -> - assert false - end else begin - (* at exit of while loop *) - let n = ref (Terminal d.next) in - d.inst := Branch (s, p, n, l'); - d.inst <- n; d.next.inst <- n; d.next.next.inst <- n; - s - end - in - let d = arcs.(a.mate).next in - loop n a d s (finite d.vert) - in - - (* Step T5 *) - let rec loop c = - let d = arcs.(c.mate) in - let e = d.next in - let t = finite d.vert in - let t' = finite c.vert in - let t'' = e.vert in - if t'' <> Infinity && in_circle (finite t'') t' t p then begin - let t'' = finite t'' in - let n = ref (Terminal e) in - let n' = ref (Terminal d) in - c.inst := Branch (t'', p, n, n'); - d.inst := Branch (t'', p, n, n'); - flip c d e t'' p n n'; - loop e - end else if t' <> r then - loop arcs.(c.next.mate).next - else - () (* break *) - in - loop c - - done; - { points = points; arcs = arcs; last_used_arc = !j } - - let iter f t = - let points = t.points in - let n = Array.length t.arcs in - for i = 0 to t.last_used_arc do - match t.arcs.(i).vert, t.arcs.(n - 1 - i).vert with - | Point u, Point v -> f points.(u) points.(v) - | _ -> () - done - - let fold f t a = - let points = t.points in - let n = Array.length t.arcs in - let rec loop i a = - if i <= t.last_used_arc then - match t.arcs.(i).vert, t.arcs.(n - 1 - i).vert with - | Point u, Point v -> loop (succ i) (f points.(u) points.(v) a) - | _ -> loop (succ i) a - else - a - in - loop 0 a - -end - -(** Points with floating point coordinates *) - -module FloatPoints = struct - - type point = float * float - - let ( + ) = ( +. ) - let ( - ) = ( -. ) - let ( * ) = ( *. ) - - let det = function - | [| [| a00; a01 |]; - [| a10; a11 |] |] -> - a00 * a11 - a01 * a10 - | [| [| a00; a01; a02 |]; - [| a10; a11; a12 |]; - [| a20; a21; a22 |] |] -> - a00*a11*a22 - a00*a12*a21 - a10*a01*a22 + - a10*a02*a21 + a20*a01*a12 - a20*a02*a11 - | [| [| a00; a01; a02; a03 |]; - [| a10; a11; a12; a13 |]; - [| a20; a21; a22; a23 |]; - [| a30; a31; a32; a33 |] |] -> - a00*a11*a22*a33 - a00*a11*a23*a32 - a00*a21*a12*a33 + - a00*a21*a13*a32 + a00*a31*a12*a23 - a00*a31*a13*a22 - - a10*a01*a22*a33 + a10*a01*a23*a32 + a10*a21*a02*a33 - - a10*a21*a03*a32 - a10*a31*a02*a23 + a10*a31*a03*a22 + - a20*a01*a12*a33 - a20*a01*a13*a32 - a20*a11*a02*a33 + - a20*a11*a03*a32 + a20*a31*a02*a13 - a20*a31*a03*a12 - - a30*a01*a12*a23 + a30*a01*a13*a22 + a30*a11*a02*a23 - - a30*a11*a03*a22 - a30*a21*a02*a13 + a30*a21*a03*a12 - | _ -> assert false - - let ccw (xu,yu) (xv,yv) (xw,yw) = - det [| [| xu; yu; 1.0 |]; - [| xv; yv; 1.0 |]; - [| xw; yw; 1.0 |] |] > 0.0 - - (*i DEBUG - let ccw (xu,yu) (xv,yv) (xw,yw) = - eprintf "ccw((%.0f,%.0f),(%.0f,%.0f),(%.0f,%.0f)) -> " - xu yu xv yv xw yw; - let r = ccw (xu,yu) (xv,yv) (xw,yw) in - eprintf "%b\n" r; flush stderr; - r - i*) - - let in_circle (xt,yt) (xu,yu) (xv,yv) (xw,yw) = - det [| [| xt; yt; (xt * xt + yt * yt); 1.0 |]; - [| xu; yu; (xu * xu + yu * yu); 1.0 |]; - [| xv; yv; (xv * xv + yv * yv); 1.0 |]; - [| xw; yw; (xw * xw + yw * yw); 1.0 |]; |] > 0.0 - - (*i DEBUG - let in_circle (xt,yt) (xu,yu) (xv,yv) (xw,yw) = - eprintf "in_circle((%.0f,%.0f),(%.0f,%.0f),(%.0f,%.0f),(%.0f,%.0f)) -> " - xt yt xu yu xv yv xw yw; - let r = in_circle (xt,yt) (xu,yu) (xv,yv) (xw,yw) in - eprintf "%b\n" r; flush stderr; - r - i*) - -end - -module Float = Make(FloatPoints) - -(** Points with integer coordinates. - We approximate using module [FloatPoints] but this could be made exact - following Knuth's code in Axioms and Hulls *) - -module IntPoints = struct - - type point = int * int - - let ccw (xu,yu) (xv,yv) (xw,yw) = - FloatPoints.ccw - (float xu, float yu) (float xv, float yv) (float xw, float yw) - - let in_circle (xt,yt) (xu,yu) (xv,yv) (xw,yw) = - FloatPoints.in_circle - (float xt, float yt) - (float xu, float yu) (float xv, float yv) (float xw, float yw) - -end - -module Int = Make(IntPoints) - diff --git a/external/ocamlgraph/src/delaunay.mli b/external/ocamlgraph/src/delaunay.mli deleted file mode 100644 --- a/external/ocamlgraph/src/delaunay.mli +++ /dev/null @@ -1,76 +0,0 @@ -(**************************************************************************) -(* *) -(* Ocamlgraph: a generic graph library for OCaml *) -(* Copyright (C) 2004-2007 *) -(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) -(* *) -(* This software is free software; you can redistribute it and/or *) -(* modify it under the terms of the GNU Library General Public *) -(* License version 2, with the special exception on linking *) -(* described in file LICENSE. *) -(* *) -(* This software is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) -(* *) -(**************************************************************************) - -(* $Id: delaunay.mli,v 1.8 2004-02-20 14:37:40 signoles Exp $ *) - -(** Delaunay triangulation *) - -(** Delaunay triangulation is available for any CCC system in the sense - of Knuth's ``Axioms and Hulls'' *) -module type CCC = sig - - type point - - val ccw : point -> point -> point -> bool - (** The counterclockwise relation [ccw p q r] states that the - circle through points [(p,q,r)] is traversed counterclockwise - when we encounter the points in cyclic order [p,q,r,p,...] **) - - val in_circle : point -> point -> point -> point -> bool - (** The relation [in_circle p q r s] states that [s] lies - inside the circle [(p,q,r)] if [ccw p q r] is true, or outside that - circle if [ccw p q r] is false. *) - -end - -(** The result of triangulation is an abstract value of type [triangulation]. - Then one can iterate over all edges of the triangulation. *) -module type Triangulation = sig - - module S : CCC - - type triangulation - - val triangulate : S.point array -> triangulation - (** [triangulate a] computes the Delaunay triangulation of a set of - points, given as an array [a]. If [N] is the number of points - (that is [Array.length a]), then the running time is $O(N \log N)$ - on the average and $O(N^2)$ on the worst-case. The space used is - always $O(N)$. *) - - val iter : (S.point -> S.point -> unit) -> triangulation -> unit - (** [iter f t] iterates over all edges of the triangulation [t]. - [f u v] is called once for each undirected edge [(u,v)]. *) - - val fold : (S.point -> S.point -> 'a -> 'a) -> triangulation -> 'a -> 'a - -end - -(** Generic Delaunay triangulation *) -module Make(S : CCC) : Triangulation with module S = S - -(** Points with integer coordinates *) -module IntPoints : CCC with type point = int * int - -(** Delaunay triangulation with integer coordinates *) -module Int : Triangulation with module S = IntPoints - -(** Points with floating point coordinates *) -module FloatPoints : CCC with type point = float * float - -(** Delaunay triangulation with floating point coordinates *) -module Float : Triangulation with module S = FloatPoints diff --git a/external/ocamlgraph/src/dot.ml b/external/ocamlgraph/src/dot.ml deleted file mode 100644 --- a/external/ocamlgraph/src/dot.ml +++ /dev/null @@ -1,78 +0,0 @@ -(**************************************************************************) -(* *) -(* Ocamlgraph: a generic graph library for OCaml *) -(* Copyright (C) 2004-2007 *) -(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) -(* *) -(* This software is free software; you can redistribute it and/or *) -(* modify it under the terms of the GNU Library General Public *) -(* License version 2, with the special exception on linking *) -(* described in file LICENSE. *) -(* *) -(* This software is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) -(* *) -(**************************************************************************) - -(* $Id:$ *) - -(** Parser for DOT file format *) - -open Dot_ast - -module Parse - (B : Builder.S) - (L : sig - val node : node_id -> attr list -> B.G.V.label - (** how to build the node label out of the set of attributes *) - val edge : attr list -> B.G.E.label - (** how to build the edge label out of the set of attributes *) - end) = -struct - - let create_graph dot = - let nodes = Hashtbl.create 97 in - let node g id l = - try - g, Hashtbl.find nodes id - with Not_found -> - let n = B.G.V.create (L.node id l) in - Hashtbl.add nodes id n; - B.add_vertex g n, n - in - List.fold_left - (fun g s -> match s with - | Node_stmt (id, al) -> - let g,_ = node g id al in g - | Edge_stmt (NodeId id, nl, al) -> - let el = L.edge al in - let g,vn = node g id [] in - List.fold_left - (fun g m -> match m with - | NodeId idm -> - let g,vm = node g idm [] in - let e = B.G.E.create vn el vm in - B.add_edge_e g e - | NodeSub _ -> - g) - g nl - | _ -> - g) - (B.empty ()) - dot.stmts - - let parse f = - let c = open_in f in - let lb = Lexing.from_channel c in - let dot = - try - Dot_parser.file Dot_lexer.token lb - with Parsing.Parse_error -> - let n = Lexing.lexeme_start lb in - failwith (Printf.sprintf "Dot.parse: parse error character %d" n) - in - close_in c; - create_graph dot - -end diff --git a/external/ocamlgraph/src/dot.mli b/external/ocamlgraph/src/dot.mli deleted file mode 100644 --- a/external/ocamlgraph/src/dot.mli +++ /dev/null @@ -1,34 +0,0 @@ -(**************************************************************************) -(* *) -(* Ocamlgraph: a generic graph library for OCaml *) -(* Copyright (C) 2004-2007 *) -(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) -(* *) -(* This software is free software; you can redistribute it and/or *) -(* modify it under the terms of the GNU Library General Public *) -(* License version 2, with the special exception on linking *) -(* described in file LICENSE. *) -(* *) -(* This software is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) -(* *) -(**************************************************************************) - -(** Parser for DOT file format *) - -open Dot_ast - -module Parse - (B : Builder.S) - (L : sig - val node : node_id -> attr list -> B.G.V.label - (** how to build the node label out of the set of attributes *) - val edge : attr list -> B.G.E.label - (** how to build the edge label out of the set of attributes *) - end) : -sig - - val parse : string -> B.G.t - -end diff --git a/external/ocamlgraph/src/dot_ast.mli b/external/ocamlgraph/src/dot_ast.mli deleted file mode 100644 --- a/external/ocamlgraph/src/dot_ast.mli +++ /dev/null @@ -1,57 +0,0 @@ -(**************************************************************************) -(* *) -(* Ocamlgraph: a generic graph library for OCaml *) -(* Copyright (C) 2004-2007 *) -(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) -(* *) -(* This software is free software; you can redistribute it and/or *) -(* modify it under the terms of the GNU Library General Public *) -(* License version 2, with the special exception on linking *) -(* described in file LICENSE. *) -(* *) -(* This software is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) -(* *) -(**************************************************************************) - -(* $Id:$ *) - -type id = - | Ident of string - | Number of string - | String of string - | Html of string - -type attr = (id * id option) list - -type compass_pt = N | Ne | E | Se | S | Sw | W | Nw - -type port = - | PortId of id * compass_pt option - | PortC of compass_pt - -type node_id = id * port option - -type subgraph = - | SubgraphId of id - | SubgraphDef of id option * stmt list - -and node = - | NodeId of node_id - | NodeSub of subgraph - -and stmt = - | Node_stmt of node_id * attr list - | Edge_stmt of node * node list * attr list - | Attr_graph of attr list - | Attr_node of attr list - | Attr_edge of attr list - | Equal of id * id - | Subgraph of subgraph - -type file = - { strict : bool; - digraph : bool; - id : id option; - stmts : stmt list } diff --git a/external/ocamlgraph/src/dot_lexer.ml b/external/ocamlgraph/src/dot_lexer.ml deleted file mode 100644 --- a/external/ocamlgraph/src/dot_lexer.ml +++ /dev/null @@ -1,386 +0,0 @@ -# 20 "src/dot_lexer.mll" - - open Lexing - open Dot_ast - open Dot_parser - - let string_buf = Buffer.create 1024 - - let keyword = - let h = Hashtbl.create 17 in - List.iter - (fun (s,k) -> Hashtbl.add h s k) - [ - "strict", STRICT; - "graph", GRAPH; - "digraph", DIGRAPH; - "subgraph", SUBGRAPH; - "node", NODE; - "edge", EDGE; - ]; - fun s -> let s = String.lowercase s in Hashtbl.find h s - - -# 25 "src/dot_lexer.ml" -let __ocaml_lex_tables = { - Lexing.lex_base = - "\000\000\238\255\239\255\240\255\241\255\078\000\088\000\098\000\ - \176\000\245\255\246\255\247\255\248\255\249\255\250\255\251\255\ - \252\255\114\000\001\000\005\000\254\255\002\000\253\255\191\000\ - \244\255\211\000\221\000\157\000\252\255\253\255\002\000\255\255\ - \254\255\032\000\252\255\253\255\254\255\255\255\054\000\253\255\ - \254\255\015\000\255\255"; - Lexing.lex_backtrk = - "\255\255\255\255\255\255\255\255\255\255\013\000\017\000\012\000\ - \017\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\017\000\017\000\000\000\255\255\255\255\255\255\255\255\ - \255\255\013\000\013\000\255\255\255\255\255\255\002\000\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\001\000\255\255"; - Lexing.lex_default = - "\001\000\000\000\000\000\000\000\000\000\255\255\255\255\255\255\ - \255\255\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\255\255\021\000\255\255\000\000\021\000\000\000\255\255\ - \000\000\255\255\255\255\029\000\000\000\000\000\255\255\000\000\ - \000\000\035\000\000\000\000\000\000\000\000\000\040\000\000\000\ - \000\000\255\255\000\000"; - Lexing.lex_trans = - "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\019\000\019\000\020\000\020\000\019\000\019\000\019\000\ - \000\000\000\000\019\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \019\000\000\000\004\000\018\000\032\000\019\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\015\000\008\000\006\000\017\000\ - \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ - \005\000\005\000\016\000\014\000\003\000\013\000\042\000\000\000\ - \000\000\007\000\007\000\007\000\007\000\007\000\007\000\007\000\ - \007\000\007\000\007\000\007\000\007\000\007\000\007\000\007\000\ - \007\000\007\000\007\000\007\000\007\000\007\000\007\000\007\000\ - \007\000\007\000\007\000\010\000\036\000\009\000\037\000\007\000\ - \041\000\007\000\007\000\007\000\007\000\007\000\007\000\007\000\ - \007\000\007\000\007\000\007\000\007\000\007\000\007\000\007\000\ - \007\000\007\000\007\000\007\000\007\000\007\000\007\000\007\000\ - \007\000\007\000\007\000\012\000\026\000\011\000\005\000\005\000\ - \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ - \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\007\000\007\000\007\000\007\000\007\000\007\000\ - \007\000\007\000\007\000\007\000\022\000\000\000\000\000\000\000\ - \000\000\021\000\000\000\007\000\007\000\007\000\007\000\007\000\ - \007\000\007\000\007\000\007\000\007\000\007\000\007\000\007\000\ - \007\000\007\000\007\000\007\000\007\000\007\000\007\000\007\000\ - \007\000\007\000\007\000\007\000\007\000\000\000\000\000\031\000\ - \000\000\007\000\000\000\007\000\007\000\007\000\007\000\007\000\ - \007\000\007\000\007\000\007\000\007\000\007\000\007\000\007\000\ - \007\000\007\000\007\000\007\000\007\000\007\000\007\000\007\000\ - \007\000\007\000\007\000\007\000\007\000\024\000\023\000\000\000\ - \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ - \005\000\005\000\000\000\000\000\000\000\000\000\024\000\025\000\ - \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ - \025\000\030\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \002\000\255\255\255\255\025\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\025\000\025\000\025\000\026\000\026\000\026\000\ - \026\000\026\000\026\000\026\000\026\000\026\000\026\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \034\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\039\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\028\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000"; - Lexing.lex_check = - "\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\000\000\000\000\018\000\021\000\000\000\019\000\019\000\ - \255\255\255\255\019\000\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \000\000\255\255\000\000\000\000\030\000\019\000\255\255\255\255\ - \255\255\255\255\255\255\255\255\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\041\000\255\255\ - \255\255\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\033\000\000\000\033\000\000\000\ - \038\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\005\000\000\000\005\000\005\000\ - \005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\ - \006\000\006\000\006\000\006\000\006\000\006\000\006\000\006\000\ - \006\000\006\000\007\000\007\000\007\000\007\000\007\000\007\000\ - \007\000\007\000\007\000\007\000\017\000\255\255\255\255\255\255\ - \255\255\017\000\255\255\007\000\007\000\007\000\007\000\007\000\ - \007\000\007\000\007\000\007\000\007\000\007\000\007\000\007\000\ - \007\000\007\000\007\000\007\000\007\000\007\000\007\000\007\000\ - \007\000\007\000\007\000\007\000\007\000\255\255\255\255\027\000\ - \255\255\007\000\255\255\007\000\007\000\007\000\007\000\007\000\ - \007\000\007\000\007\000\007\000\007\000\007\000\007\000\007\000\ - \007\000\007\000\007\000\007\000\007\000\007\000\007\000\007\000\ - \007\000\007\000\007\000\007\000\007\000\008\000\008\000\255\255\ - \008\000\008\000\008\000\008\000\008\000\008\000\008\000\008\000\ - \008\000\008\000\255\255\255\255\255\255\255\255\008\000\023\000\ - \023\000\023\000\023\000\023\000\023\000\023\000\023\000\023\000\ - \023\000\027\000\255\255\255\255\255\255\255\255\255\255\255\255\ - \000\000\018\000\021\000\025\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\025\000\025\000\025\000\026\000\026\000\026\000\ - \026\000\026\000\026\000\026\000\026\000\026\000\026\000\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \033\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\038\000\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\027\000\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255"; - Lexing.lex_base_code = - ""; - Lexing.lex_backtrk_code = - ""; - Lexing.lex_default_code = - ""; - Lexing.lex_trans_code = - ""; - Lexing.lex_check_code = - ""; - Lexing.lex_code = - ""; -} - -let rec token lexbuf = - __ocaml_lex_token_rec lexbuf 0 -and __ocaml_lex_token_rec lexbuf __ocaml_lex_state = - match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf with - | 0 -> -# 52 "src/dot_lexer.mll" - ( token lexbuf ) -# 191 "src/dot_lexer.ml" - - | 1 -> -# 54 "src/dot_lexer.mll" - ( token lexbuf ) -# 196 "src/dot_lexer.ml" - - | 2 -> -# 56 "src/dot_lexer.mll" - ( comment lexbuf; token lexbuf ) -# 201 "src/dot_lexer.ml" - - | 3 -> -# 58 "src/dot_lexer.mll" - ( COLON ) -# 206 "src/dot_lexer.ml" - - | 4 -> -# 60 "src/dot_lexer.mll" - ( COMMA ) -# 211 "src/dot_lexer.ml" - - | 5 -> -# 62 "src/dot_lexer.mll" - ( SEMICOLON ) -# 216 "src/dot_lexer.ml" - - | 6 -> -# 64 "src/dot_lexer.mll" - ( EQUAL ) -# 221 "src/dot_lexer.ml" - - | 7 -> -# 66 "src/dot_lexer.mll" - ( LBRA ) -# 226 "src/dot_lexer.ml" - - | 8 -> -# 68 "src/dot_lexer.mll" - ( RBRA ) -# 231 "src/dot_lexer.ml" - - | 9 -> -# 70 "src/dot_lexer.mll" - ( LSQ ) -# 236 "src/dot_lexer.ml" - - | 10 -> -# 72 "src/dot_lexer.mll" - ( RSQ ) -# 241 "src/dot_lexer.ml" - - | 11 -> -# 74 "src/dot_lexer.mll" - ( EDGEOP ) -# 246 "src/dot_lexer.ml" - - | 12 -> -let -# 75 "src/dot_lexer.mll" - s -# 252 "src/dot_lexer.ml" -= Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos lexbuf.Lexing.lex_curr_pos in -# 76 "src/dot_lexer.mll" - ( try keyword s with Not_found -> ID (Ident s) ) -# 256 "src/dot_lexer.ml" - - | 13 -> -let -# 77 "src/dot_lexer.mll" - s -# 262 "src/dot_lexer.ml" -= Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos lexbuf.Lexing.lex_curr_pos in -# 78 "src/dot_lexer.mll" - ( ID (Number s) ) -# 266 "src/dot_lexer.ml" - - | 14 -> -# 80 "src/dot_lexer.mll" - ( Buffer.clear string_buf; - let s = string lexbuf in - ID (String s) ) -# 273 "src/dot_lexer.ml" - - | 15 -> -# 84 "src/dot_lexer.mll" - ( Buffer.clear string_buf; - html lexbuf; - ID (Html (Buffer.contents string_buf)) ) -# 280 "src/dot_lexer.ml" - - | 16 -> -# 88 "src/dot_lexer.mll" - ( EOF ) -# 285 "src/dot_lexer.ml" - - | 17 -> -let -# 89 "src/dot_lexer.mll" - c -# 291 "src/dot_lexer.ml" -= Lexing.sub_lexeme_char lexbuf lexbuf.Lexing.lex_start_pos in -# 90 "src/dot_lexer.mll" - ( failwith ("Dot_lexer: invalid character " ^ String.make 1 c) ) -# 295 "src/dot_lexer.ml" - - | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_token_rec lexbuf __ocaml_lex_state - -and string lexbuf = - __ocaml_lex_string_rec lexbuf 27 -and __ocaml_lex_string_rec lexbuf __ocaml_lex_state = - match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf with - | 0 -> -# 94 "src/dot_lexer.mll" - ( Buffer.contents string_buf ) -# 306 "src/dot_lexer.ml" - - | 1 -> -# 96 "src/dot_lexer.mll" - ( Buffer.add_char string_buf '"'; - string lexbuf ) -# 312 "src/dot_lexer.ml" - - | 2 -> -let -# 98 "src/dot_lexer.mll" - c -# 318 "src/dot_lexer.ml" -= Lexing.sub_lexeme_char lexbuf lexbuf.Lexing.lex_start_pos in -# 99 "src/dot_lexer.mll" - ( Buffer.add_char string_buf c; - string lexbuf ) -# 323 "src/dot_lexer.ml" - - | 3 -> -# 102 "src/dot_lexer.mll" - ( failwith ("Dot_lexer: unterminated string literal") ) -# 328 "src/dot_lexer.ml" - - | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_string_rec lexbuf __ocaml_lex_state - -and html lexbuf = - __ocaml_lex_html_rec lexbuf 33 -and __ocaml_lex_html_rec lexbuf __ocaml_lex_state = - match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf with - | 0 -> -# 106 "src/dot_lexer.mll" - ( () ) -# 339 "src/dot_lexer.ml" - - | 1 -> -# 108 "src/dot_lexer.mll" - ( Buffer.add_char string_buf '<'; html lexbuf; - Buffer.add_char string_buf '>'; html lexbuf ) -# 345 "src/dot_lexer.ml" - - | 2 -> -let -# 110 "src/dot_lexer.mll" - c -# 351 "src/dot_lexer.ml" -= Lexing.sub_lexeme_char lexbuf lexbuf.Lexing.lex_start_pos in -# 111 "src/dot_lexer.mll" - ( Buffer.add_char string_buf c; - html lexbuf ) -# 356 "src/dot_lexer.ml" - - | 3 -> -# 114 "src/dot_lexer.mll" - ( failwith ("Dot_lexer: unterminated html literal") ) -# 361 "src/dot_lexer.ml" - - | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_html_rec lexbuf __ocaml_lex_state - -and comment lexbuf = - __ocaml_lex_comment_rec lexbuf 38 -and __ocaml_lex_comment_rec lexbuf __ocaml_lex_state = - match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf with - | 0 -> -# 118 "src/dot_lexer.mll" - ( () ) -# 372 "src/dot_lexer.ml" - - | 1 -> -# 120 "src/dot_lexer.mll" - ( comment lexbuf ) -# 377 "src/dot_lexer.ml" - - | 2 -> -# 122 "src/dot_lexer.mll" - ( failwith "Dot_lexer: unterminated comment" ) -# 382 "src/dot_lexer.ml" - - | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_comment_rec lexbuf __ocaml_lex_state - -;; - diff --git a/external/ocamlgraph/src/dot_lexer.mll b/external/ocamlgraph/src/dot_lexer.mll deleted file mode 100644 --- a/external/ocamlgraph/src/dot_lexer.mll +++ /dev/null @@ -1,122 +0,0 @@ -(**************************************************************************) -(* *) -(* Ocamlgraph: a generic graph library for OCaml *) -(* Copyright (C) 2004-2007 *) -(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) -(* *) -(* This software is free software; you can redistribute it and/or *) -(* modify it under the terms of the GNU Library General Public *) -(* License version 2, with the special exception on linking *) -(* described in file LICENSE. *) -(* *) -(* This software is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) -(* *) -(**************************************************************************) - -(* $Id:$ *) - -{ - open Lexing - open Dot_ast - open Dot_parser - - let string_buf = Buffer.create 1024 - - let keyword = - let h = Hashtbl.create 17 in - List.iter - (fun (s,k) -> Hashtbl.add h s k) - [ - "strict", STRICT; - "graph", GRAPH; - "digraph", DIGRAPH; - "subgraph", SUBGRAPH; - "node", NODE; - "edge", EDGE; - ]; - fun s -> let s = String.lowercase s in Hashtbl.find h s - -} - -let alpha = ['a'-'z' 'A'-'Z' '_'] -let digit = ['0'-'9'] -let ident = alpha (alpha | digit)* -let number = '-'? ('.'['0'-'9']+ | ['0'-'9']+('.'['0'-'9']*)? ) - -let space = [' ' '\t' '\r' '\n']+ - -rule token = parse - | space - { token lexbuf } - | ('#' | "//") [^ '\n']* '\n' - { token lexbuf } - | "/*" - { comment lexbuf; token lexbuf } - | ":" - { COLON } - | "," - { COMMA } - | ";" - { SEMICOLON } - | "=" - { EQUAL } - | "{" - { LBRA } - | "}" - { RBRA } - | "[" - { LSQ } - | "]" - { RSQ } - | "--" | "->" - { EDGEOP } - | ident as s - { try keyword s with Not_found -> ID (Ident s) } - | number as s - { ID (Number s) } - | "\"" - { Buffer.clear string_buf; - let s = string lexbuf in - ID (String s) } - | "<" - { Buffer.clear string_buf; - html lexbuf; - ID (Html (Buffer.contents string_buf)) } - | eof - { EOF } - | _ as c - { failwith ("Dot_lexer: invalid character " ^ String.make 1 c) } - -and string = parse - | "\"" - { Buffer.contents string_buf } - | "\\" "\"" - { Buffer.add_char string_buf '"'; - string lexbuf } - | _ as c - { Buffer.add_char string_buf c; - string lexbuf } - | eof - { failwith ("Dot_lexer: unterminated string literal") } - -and html = parse - | ">" - { () } - | "<" - { Buffer.add_char string_buf '<'; html lexbuf; - Buffer.add_char string_buf '>'; html lexbuf } - | _ as c - { Buffer.add_char string_buf c; - html lexbuf } - | eof - { failwith ("Dot_lexer: unterminated html literal") } - -and comment = parse - | "*/" - { () } - | _ - { comment lexbuf } - | eof - { failwith "Dot_lexer: unterminated comment" } diff --git a/external/ocamlgraph/src/dot_parser.ml b/external/ocamlgraph/src/dot_parser.ml deleted file mode 100644 --- a/external/ocamlgraph/src/dot_parser.ml +++ /dev/null @@ -1,551 +0,0 @@ -type token = - | ID of (Dot_ast.id) - | COLON - | COMMA - | EQUAL - | SEMICOLON - | EDGEOP - | STRICT - | GRAPH - | DIGRAPH - | LBRA - | RBRA - | LSQ - | RSQ - | NODE - | EDGE - | SUBGRAPH - | EOF - -open Parsing;; -# 23 "src/dot_parser.mly" - open Dot_ast - open Parsing - - let compass_pt = function - | Ident "n" -> N - | Ident "ne" -> Ne - | Ident "e" -> E - | Ident "se" -> Se - | Ident "s" -> S - | Ident "sw" -> Sw - | Ident "w" -> W - | Ident "nw" -> Nw - | _ -> invalid_arg "compass_pt" - -# 37 "src/dot_parser.ml" -let yytransl_const = [| - 258 (* COLON *); - 259 (* COMMA *); - 260 (* EQUAL *); - 261 (* SEMICOLON *); - 262 (* EDGEOP *); - 263 (* STRICT *); - 264 (* GRAPH *); - 265 (* DIGRAPH *); - 266 (* LBRA *); - 267 (* RBRA *); - 268 (* LSQ *); - 269 (* RSQ *); - 270 (* NODE *); - 271 (* EDGE *); - 272 (* SUBGRAPH *); - 0 (* EOF *); - 0|] - -let yytransl_block = [| - 257 (* ID *); - 0|] - -let yylhs = "\255\255\ -\001\000\002\000\002\000\003\000\003\000\005\000\005\000\006\000\ -\006\000\008\000\008\000\007\000\007\000\007\000\007\000\007\000\ -\009\000\010\000\011\000\011\000\011\000\016\000\018\000\018\000\ -\015\000\015\000\013\000\019\000\019\000\020\000\020\000\014\000\ -\014\000\017\000\017\000\004\000\004\000\021\000\021\000\022\000\ -\022\000\023\000\023\000\012\000\012\000\012\000\012\000\000\000" - -let yylen = "\002\000\ -\007\000\000\000\001\000\001\000\001\000\000\000\001\000\002\000\ -\003\000\000\000\001\000\001\000\001\000\001\000\003\000\001\000\ -\002\000\003\000\002\000\002\000\002\000\003\000\000\000\003\000\ -\001\000\001\000\002\000\000\000\001\000\002\000\004\000\000\000\ -\001\000\003\000\004\000\000\000\001\000\002\000\003\000\001\000\ -\003\000\000\000\001\000\002\000\005\000\004\000\003\000\002\000" - -let yydefred = "\000\000\ -\000\000\000\000\003\000\048\000\000\000\004\000\005\000\000\000\ -\037\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\007\000\000\000\012\000\013\000\014\000\000\000\ -\000\000\000\000\000\000\000\000\027\000\029\000\000\000\019\000\ -\000\000\020\000\021\000\000\000\000\000\000\000\011\000\000\000\ -\017\000\033\000\000\000\000\000\000\000\015\000\000\000\000\000\ -\000\000\047\000\000\000\000\000\001\000\009\000\000\000\026\000\ -\025\000\000\000\018\000\000\000\000\000\000\000\043\000\000\000\ -\000\000\046\000\000\000\022\000\031\000\041\000\035\000\039\000\ -\045\000\000\000\024\000" - -let yydgoto = "\002\000\ -\004\000\005\000\008\000\010\000\018\000\019\000\020\000\040\000\ -\021\000\022\000\023\000\024\000\025\000\041\000\026\000\044\000\ -\042\000\068\000\029\000\030\000\048\000\049\000\064\000" - -let yysindex = "\009\000\ -\024\255\000\000\000\000\000\000\000\255\000\000\000\000\031\255\ -\000\000\029\255\131\255\011\255\033\255\131\255\033\255\033\255\ -\051\255\040\255\000\000\048\255\000\000\000\000\000\000\000\000\ -\033\255\050\255\057\255\067\255\000\000\000\000\069\255\000\000\ -\062\255\000\000\000\000\070\255\131\255\091\000\000\000\131\255\ -\000\000\000\000\018\255\033\255\090\255\000\000\099\255\081\255\ -\101\255\000\000\131\255\095\255\000\000\000\000\107\255\000\000\ -\000\000\110\255\000\000\114\255\117\255\033\255\000\000\069\255\ -\111\255\000\000\018\255\000\000\000\000\000\000\000\000\000\000\ -\000\000\110\255\000\000" - -let yyrindex = "\000\000\ -\074\255\000\000\000\000\000\000\000\000\000\000\000\000\116\255\ -\000\000\000\000\118\255\006\255\000\000\118\255\000\000\000\000\ -\000\000\000\000\000\000\120\255\000\000\000\000\000\000\049\255\ -\061\255\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\073\255\118\255\000\000\000\000\122\255\ -\000\000\000\000\000\000\097\255\032\255\000\000\023\255\000\000\ -\022\255\000\000\118\255\000\000\000\000\000\000\006\255\000\000\ -\000\000\085\255\000\000\000\000\000\000\109\255\000\000\124\255\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\085\255\000\000" - -let yygindex = "\000\000\ -\000\000\000\000\000\000\000\000\246\255\087\000\000\000\000\000\ -\000\000\000\000\000\000\214\255\218\255\094\000\219\255\000\000\ -\243\255\066\000\000\000\000\000\078\000\000\000\000\000" - -let yytablesize = 147 -let yytable = "\032\000\ -\056\000\034\000\035\000\033\000\057\000\058\000\028\000\006\000\ -\007\000\001\000\028\000\028\000\027\000\028\000\028\000\028\000\ -\028\000\028\000\055\000\028\000\028\000\028\000\042\000\040\000\ -\056\000\040\000\052\000\014\000\057\000\074\000\003\000\009\000\ -\030\000\017\000\042\000\040\000\030\000\030\000\011\000\030\000\ -\065\000\030\000\030\000\030\000\031\000\030\000\030\000\030\000\ -\071\000\016\000\038\000\036\000\039\000\016\000\026\000\043\000\ -\016\000\045\000\016\000\016\000\037\000\032\000\016\000\016\000\ -\016\000\032\000\025\000\046\000\032\000\047\000\032\000\032\000\ -\050\000\044\000\032\000\032\000\032\000\044\000\044\000\051\000\ -\044\000\002\000\002\000\044\000\044\000\023\000\044\000\044\000\ -\044\000\023\000\053\000\060\000\023\000\062\000\023\000\023\000\ -\023\000\032\000\023\000\023\000\023\000\032\000\061\000\063\000\ -\032\000\066\000\032\000\032\000\027\000\034\000\032\000\032\000\ -\032\000\034\000\069\000\067\000\034\000\070\000\034\000\034\000\ -\010\000\073\000\034\000\034\000\034\000\036\000\054\000\010\000\ -\006\000\010\000\010\000\012\000\008\000\010\000\010\000\010\000\ -\038\000\059\000\013\000\075\000\014\000\072\000\000\000\000\000\ -\015\000\016\000\017\000" - -let yycheck = "\013\000\ -\043\000\015\000\016\000\014\000\043\000\043\000\001\001\008\001\ -\009\001\001\000\005\001\006\001\002\001\008\001\004\001\010\001\ -\011\001\012\001\001\001\014\001\015\001\016\001\001\001\001\001\ -\067\000\003\001\037\000\010\001\067\000\067\000\007\001\001\001\ -\001\001\016\001\013\001\013\001\005\001\006\001\010\001\008\001\ -\051\000\010\001\011\001\012\001\012\001\014\001\015\001\016\001\ -\062\000\001\001\011\001\001\001\005\001\005\001\006\001\006\001\ -\008\001\001\001\010\001\011\001\010\001\001\001\014\001\015\001\ -\016\001\005\001\006\001\001\001\008\001\001\001\010\001\011\001\ -\011\001\001\001\014\001\015\001\016\001\005\001\006\001\010\001\ -\008\001\008\001\009\001\011\001\012\001\001\001\014\001\015\001\ -\016\001\005\001\000\000\002\001\008\001\013\001\010\001\011\001\ -\012\001\001\001\014\001\015\001\016\001\005\001\004\001\003\001\ -\008\001\011\001\010\001\011\001\002\001\001\001\014\001\015\001\ -\016\001\005\001\001\001\006\001\008\001\001\001\010\001\011\001\ -\001\001\011\001\014\001\015\001\016\001\010\001\040\000\008\001\ -\011\001\010\001\011\001\001\001\011\001\014\001\015\001\016\001\ -\013\001\044\000\008\001\074\000\010\001\064\000\255\255\255\255\ -\014\001\015\001\016\001" - -let yynames_const = "\ - COLON\000\ - COMMA\000\ - EQUAL\000\ - SEMICOLON\000\ - EDGEOP\000\ - STRICT\000\ - GRAPH\000\ - DIGRAPH\000\ - LBRA\000\ - RBRA\000\ - LSQ\000\ - RSQ\000\ - NODE\000\ - EDGE\000\ - SUBGRAPH\000\ - EOF\000\ - " - -let yynames_block = "\ - ID\000\ - " - -let yyact = [| - (fun _ -> failwith "parser") -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 6 : 'strict_opt) in - let _2 = (Parsing.peek_val __caml_parser_env 5 : 'graph_or_digraph) in - let _3 = (Parsing.peek_val __caml_parser_env 4 : 'id_opt) in - let _5 = (Parsing.peek_val __caml_parser_env 2 : 'stmt_list) in - Obj.repr( -# 49 "src/dot_parser.mly" - ( { strict = _1; digraph = _2; id = _3; stmts = _5 } ) -# 199 "src/dot_parser.ml" - : Dot_ast.file)) -; (fun __caml_parser_env -> - Obj.repr( -# 53 "src/dot_parser.mly" - ( false ) -# 205 "src/dot_parser.ml" - : 'strict_opt)) -; (fun __caml_parser_env -> - Obj.repr( -# 54 "src/dot_parser.mly" - ( true ) -# 211 "src/dot_parser.ml" - : 'strict_opt)) -; (fun __caml_parser_env -> - Obj.repr( -# 58 "src/dot_parser.mly" - ( false ) -# 217 "src/dot_parser.ml" - : 'graph_or_digraph)) -; (fun __caml_parser_env -> - Obj.repr( -# 59 "src/dot_parser.mly" - ( true ) -# 223 "src/dot_parser.ml" - : 'graph_or_digraph)) -; (fun __caml_parser_env -> - Obj.repr( -# 63 "src/dot_parser.mly" - ( [] ) -# 229 "src/dot_parser.ml" - : 'stmt_list)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'list1_stmt) in - Obj.repr( -# 64 "src/dot_parser.mly" - ( _1 ) -# 236 "src/dot_parser.ml" - : 'stmt_list)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : 'stmt) in - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'semicolon_opt) in - Obj.repr( -# 68 "src/dot_parser.mly" - ( [_1] ) -# 244 "src/dot_parser.ml" - : 'list1_stmt)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'stmt) in - let _2 = (Parsing.peek_val __caml_parser_env 1 : 'semicolon_opt) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'list1_stmt) in - Obj.repr( -# 69 "src/dot_parser.mly" - ( _1 :: _3 ) -# 253 "src/dot_parser.ml" - : 'list1_stmt)) -; (fun __caml_parser_env -> - Obj.repr( -# 73 "src/dot_parser.mly" - ( () ) -# 259 "src/dot_parser.ml" - : 'semicolon_opt)) -; (fun __caml_parser_env -> - Obj.repr( -# 74 "src/dot_parser.mly" - ( () ) -# 265 "src/dot_parser.ml" - : 'semicolon_opt)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'node_stmt) in - Obj.repr( -# 78 "src/dot_parser.mly" - ( _1 ) -# 272 "src/dot_parser.ml" - : 'stmt)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'edge_stmt) in - Obj.repr( -# 79 "src/dot_parser.mly" - ( _1 ) -# 279 "src/dot_parser.ml" - : 'stmt)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'attr_stmt) in - Obj.repr( -# 80 "src/dot_parser.mly" - ( _1 ) -# 286 "src/dot_parser.ml" - : 'stmt)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : Dot_ast.id) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : Dot_ast.id) in - Obj.repr( -# 81 "src/dot_parser.mly" - ( Equal (_1, _3) ) -# 294 "src/dot_parser.ml" - : 'stmt)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'subgraph) in - Obj.repr( -# 82 "src/dot_parser.mly" - ( Subgraph _1 ) -# 301 "src/dot_parser.ml" - : 'stmt)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : 'node_id) in - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'attr_list_opt) in - Obj.repr( -# 86 "src/dot_parser.mly" - ( Node_stmt (_1, _2) ) -# 309 "src/dot_parser.ml" - : 'node_stmt)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'node) in - let _2 = (Parsing.peek_val __caml_parser_env 1 : 'edge_rhs) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'attr_list_opt) in - Obj.repr( -# 90 "src/dot_parser.mly" - ( Edge_stmt (_1, _2, _3) ) -# 318 "src/dot_parser.ml" - : 'edge_stmt)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'attr_list) in - Obj.repr( -# 94 "src/dot_parser.mly" - ( Attr_graph _2 ) -# 325 "src/dot_parser.ml" - : 'attr_stmt)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'attr_list) in - Obj.repr( -# 95 "src/dot_parser.mly" - ( Attr_node _2 ) -# 332 "src/dot_parser.ml" - : 'attr_stmt)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'attr_list) in - Obj.repr( -# 96 "src/dot_parser.mly" - ( Attr_edge _2 ) -# 339 "src/dot_parser.ml" - : 'attr_stmt)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 1 : 'node) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'edge_rhs_opt) in - Obj.repr( -# 100 "src/dot_parser.mly" - ( _2 :: _3 ) -# 347 "src/dot_parser.ml" - : 'edge_rhs)) -; (fun __caml_parser_env -> - Obj.repr( -# 104 "src/dot_parser.mly" - ( [] ) -# 353 "src/dot_parser.ml" - : 'edge_rhs_opt)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 1 : 'node) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'edge_rhs_opt) in - Obj.repr( -# 105 "src/dot_parser.mly" - ( _2 :: _3 ) -# 361 "src/dot_parser.ml" - : 'edge_rhs_opt)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'node_id) in - Obj.repr( -# 109 "src/dot_parser.mly" - ( NodeId _1 ) -# 368 "src/dot_parser.ml" - : 'node)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'subgraph) in - Obj.repr( -# 110 "src/dot_parser.mly" - ( NodeSub _1 ) -# 375 "src/dot_parser.ml" - : 'node)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : Dot_ast.id) in - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'port_opt) in - Obj.repr( -# 114 "src/dot_parser.mly" - ( _1, _2 ) -# 383 "src/dot_parser.ml" - : 'node_id)) -; (fun __caml_parser_env -> - Obj.repr( -# 118 "src/dot_parser.mly" - ( None ) -# 389 "src/dot_parser.ml" - : 'port_opt)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'port) in - Obj.repr( -# 119 "src/dot_parser.mly" - ( Some _1 ) -# 396 "src/dot_parser.ml" - : 'port_opt)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 0 : Dot_ast.id) in - Obj.repr( -# 123 "src/dot_parser.mly" - ( try PortC (compass_pt _2) - with Invalid_argument _ -> PortId (_2, None) ) -# 404 "src/dot_parser.ml" - : 'port)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 2 : Dot_ast.id) in - let _4 = (Parsing.peek_val __caml_parser_env 0 : Dot_ast.id) in - Obj.repr( -# 126 "src/dot_parser.mly" - ( let cp = - try compass_pt _4 with Invalid_argument _ -> raise Parse_error - in - PortId (_2, Some cp) ) -# 415 "src/dot_parser.ml" - : 'port)) -; (fun __caml_parser_env -> - Obj.repr( -# 133 "src/dot_parser.mly" - ( [] ) -# 421 "src/dot_parser.ml" - : 'attr_list_opt)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'attr_list) in - Obj.repr( -# 134 "src/dot_parser.mly" - ( _1 ) -# 428 "src/dot_parser.ml" - : 'attr_list_opt)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 1 : 'a_list) in - Obj.repr( -# 138 "src/dot_parser.mly" - ( [_2] ) -# 435 "src/dot_parser.ml" - : 'attr_list)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 2 : 'a_list) in - let _4 = (Parsing.peek_val __caml_parser_env 0 : 'attr_list) in - Obj.repr( -# 139 "src/dot_parser.mly" - ( _2 :: _4 ) -# 443 "src/dot_parser.ml" - : 'attr_list)) -; (fun __caml_parser_env -> - Obj.repr( -# 143 "src/dot_parser.mly" - ( None ) -# 449 "src/dot_parser.ml" - : 'id_opt)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : Dot_ast.id) in - Obj.repr( -# 144 "src/dot_parser.mly" - ( Some _1 ) -# 456 "src/dot_parser.ml" - : 'id_opt)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : 'equality) in - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'comma_opt) in - Obj.repr( -# 148 "src/dot_parser.mly" - ( [_1] ) -# 464 "src/dot_parser.ml" - : 'a_list)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'equality) in - let _2 = (Parsing.peek_val __caml_parser_env 1 : 'comma_opt) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'a_list) in - Obj.repr( -# 149 "src/dot_parser.mly" - ( _1 :: _3 ) -# 473 "src/dot_parser.ml" - : 'a_list)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : Dot_ast.id) in - Obj.repr( -# 153 "src/dot_parser.mly" - ( _1, None ) -# 480 "src/dot_parser.ml" - : 'equality)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : Dot_ast.id) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : Dot_ast.id) in - Obj.repr( -# 154 "src/dot_parser.mly" - ( _1, Some _3 ) -# 488 "src/dot_parser.ml" - : 'equality)) -; (fun __caml_parser_env -> - Obj.repr( -# 158 "src/dot_parser.mly" - ( () ) -# 494 "src/dot_parser.ml" - : 'comma_opt)) -; (fun __caml_parser_env -> - Obj.repr( -# 159 "src/dot_parser.mly" - ( () ) -# 500 "src/dot_parser.ml" - : 'comma_opt)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 0 : Dot_ast.id) in - Obj.repr( -# 164 "src/dot_parser.mly" - ( SubgraphId _2 ) -# 507 "src/dot_parser.ml" - : 'subgraph)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 3 : Dot_ast.id) in - let _4 = (Parsing.peek_val __caml_parser_env 1 : 'stmt_list) in - Obj.repr( -# 165 "src/dot_parser.mly" - ( SubgraphDef (Some _2, _4) ) -# 515 "src/dot_parser.ml" - : 'subgraph)) -; (fun __caml_parser_env -> - let _3 = (Parsing.peek_val __caml_parser_env 1 : 'stmt_list) in - Obj.repr( -# 166 "src/dot_parser.mly" - ( SubgraphDef (None, _3) ) -# 522 "src/dot_parser.ml" - : 'subgraph)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 1 : 'stmt_list) in - Obj.repr( -# 167 "src/dot_parser.mly" - ( SubgraphDef (None, _2) ) -# 529 "src/dot_parser.ml" - : 'subgraph)) -(* Entry file *) -; (fun __caml_parser_env -> raise (Parsing.YYexit (Parsing.peek_val __caml_parser_env 0))) -|] -let yytables = - { Parsing.actions=yyact; - Parsing.transl_const=yytransl_const; - Parsing.transl_block=yytransl_block; - Parsing.lhs=yylhs; - Parsing.len=yylen; - Parsing.defred=yydefred; - Parsing.dgoto=yydgoto; - Parsing.sindex=yysindex; - Parsing.rindex=yyrindex; - Parsing.gindex=yygindex; - Parsing.tablesize=yytablesize; - Parsing.table=yytable; - Parsing.check=yycheck; - Parsing.error_function=parse_error; - Parsing.names_const=yynames_const; - Parsing.names_block=yynames_block } -let file (lexfun : Lexing.lexbuf -> token) (lexbuf : Lexing.lexbuf) = - (Parsing.yyparse yytables 1 lexfun lexbuf : Dot_ast.file) diff --git a/external/ocamlgraph/src/dot_parser.mli b/external/ocamlgraph/src/dot_parser.mli deleted file mode 100644 --- a/external/ocamlgraph/src/dot_parser.mli +++ /dev/null @@ -1,21 +0,0 @@ -type token = - | ID of (Dot_ast.id) - | COLON - | COMMA - | EQUAL - | SEMICOLON - | EDGEOP - | STRICT - | GRAPH - | DIGRAPH - | LBRA - | RBRA - | LSQ - | RSQ - | NODE - | EDGE - | SUBGRAPH - | EOF - -val file : - (Lexing.lexbuf -> token) -> Lexing.lexbuf -> Dot_ast.file diff --git a/external/ocamlgraph/src/dot_parser.mly b/external/ocamlgraph/src/dot_parser.mly deleted file mode 100644 --- a/external/ocamlgraph/src/dot_parser.mly +++ /dev/null @@ -1,168 +0,0 @@ -/**************************************************************************/ -/* */ -/* Ocamlgraph: a generic graph library for OCaml */ -/* Copyright (C) 2004-2007 */ -/* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles */ -/* */ -/* This software is free software; you can redistribute it and/or */ -/* modify it under the terms of the GNU Library General Public */ -/* License version 2, with the special exception on linking */ -/* described in file LICENSE. */ -/* */ -/* This software is distributed in the hope that it will be useful, */ -/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ -/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. */ -/* */ -/**************************************************************************/ - -/* $Id:$ */ - -/* DOT parser, following http://www.graphviz.org/doc/info/lang.html */ - -%{ - open Dot_ast - open Parsing - - let compass_pt = function - | Ident "n" -> N - | Ident "ne" -> Ne - | Ident "e" -> E - | Ident "se" -> Se - | Ident "s" -> S - | Ident "sw" -> Sw - | Ident "w" -> W - | Ident "nw" -> Nw - | _ -> invalid_arg "compass_pt" - -%} - -%token ID -%token COLON COMMA EQUAL SEMICOLON EDGEOP -%token STRICT GRAPH DIGRAPH LBRA RBRA LSQ RSQ NODE EDGE SUBGRAPH EOF - -%type file -%start file -%% - -file: -| strict_opt graph_or_digraph id_opt LBRA stmt_list RBRA EOF - { { strict = $1; digraph = $2; id = $3; stmts = $5 } } -; - -strict_opt: -| /* epsilon */ { false } -| STRICT { true } -; - -graph_or_digraph: -| GRAPH { false } -| DIGRAPH { true } -; - -stmt_list: -| /* epsilon */ { [] } -| list1_stmt { $1 } -; - -list1_stmt: -| stmt semicolon_opt { [$1] } -| stmt semicolon_opt list1_stmt { $1 :: $3 } -; - -semicolon_opt: -| /* epsilon */ { () } -| SEMICOLON { () } -; - -stmt: -| node_stmt { $1 } -| edge_stmt { $1 } -| attr_stmt { $1 } -| ID EQUAL ID { Equal ($1, $3) } -| subgraph { Subgraph $1 } -; - -node_stmt: -| node_id attr_list_opt { Node_stmt ($1, $2) } -; - -edge_stmt: -| node edge_rhs attr_list_opt { Edge_stmt ($1, $2, $3) } -; - -attr_stmt: -| GRAPH attr_list { Attr_graph $2 } -| NODE attr_list { Attr_node $2 } -| EDGE attr_list { Attr_edge $2 } -; - -edge_rhs: -| EDGEOP node edge_rhs_opt { $2 :: $3 } -; - -edge_rhs_opt: -| /* epsilon */ { [] } -| EDGEOP node edge_rhs_opt { $2 :: $3 } -; - -node: -| node_id { NodeId $1 } -| subgraph { NodeSub $1 } -; - -node_id: -| ID port_opt { $1, $2 } -; - -port_opt: -| /* epsilon */ { None } -| port { Some $1 } -; - -port: -| COLON ID { try PortC (compass_pt $2) - with Invalid_argument _ -> PortId ($2, None) } -| COLON ID COLON ID - { let cp = - try compass_pt $4 with Invalid_argument _ -> raise Parse_error - in - PortId ($2, Some cp) } -; - -attr_list_opt: -| /* epsilon */ { [] } -| attr_list { $1 } -; - -attr_list: -| LSQ a_list RSQ { [$2] } -| LSQ a_list RSQ attr_list { $2 :: $4 } -; - -id_opt: -| /* epsilon */ { None } -| ID { Some $1 } -; - -a_list: -| equality comma_opt { [$1] } -| equality comma_opt a_list { $1 :: $3 } -; - -equality: -| ID { $1, None } -| ID EQUAL ID { $1, Some $3 } -; - -comma_opt: -| /* epsilon */ { () } -| COMMA { () } -; - -/* one shift/reduce conflict here, which is ok */ -subgraph: -| SUBGRAPH ID { SubgraphId $2 } -| SUBGRAPH ID LBRA stmt_list RBRA { SubgraphDef (Some $2, $4) } -| SUBGRAPH LBRA stmt_list RBRA { SubgraphDef (None, $3) } -| LBRA stmt_list RBRA { SubgraphDef (None, $2) } -; diff --git a/external/ocamlgraph/src/flow.ml b/external/ocamlgraph/src/flow.ml deleted file mode 100644 --- a/external/ocamlgraph/src/flow.ml +++ /dev/null @@ -1,329 +0,0 @@ -(**************************************************************************) -(* *) -(* Ocamlgraph: a generic graph library for OCaml *) -(* Copyright (C) 2004-2007 *) -(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) -(* *) -(* This software is free software; you can redistribute it and/or *) -(* modify it under the terms of the GNU Library General Public *) -(* License version 2, with the special exception on linking *) -(* described in file LICENSE. *) -(* *) -(* This software is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) -(* *) -(**************************************************************************) - -module type FLOW = sig - type label - type t - val max_capacity : label -> t - val min_capacity : label -> t - val flow : label -> t - val add : t -> t -> t - val sub : t -> t -> t - val zero : t - val compare : t -> t -> int -end - -module type G_GOLDBERG = sig - type t - module V : Sig.COMPARABLE - module E : Sig.EDGE with type vertex = V.t - val nb_vertex : t -> int - val iter_vertex : (V.t -> unit) -> t -> unit - val iter_edges_e : (E.t -> unit) -> t -> unit - val fold_succ_e : (E.t -> 'a -> 'a) -> t -> V.t -> 'a -> 'a - val fold_pred_e : (E.t -> 'a -> 'a) -> t -> V.t -> 'a -> 'a -end - -module Goldberg(G: G_GOLDBERG)(F: FLOW with type label = G.E.label) = -struct - - module V = Hashtbl.Make(G.V) - module E = Hashtbl.Make(Util.HTProduct(G.V)(G.V)) - module Se = Set.Make(G.E) - module Sv = Set.Make(G.V) - - let excedents = V.create 997 - let hauteur = V.create 997 - let flot = E.create 997 - - let fold_booleen f = List.fold_left (fun r x->(f x) or r) false - - let capacite_restante g e = - F.sub (F.max_capacity (G.E.label e)) (E.find flot (G.E.src e, G.E.dst e)) - - let reste_excedent x = F.compare (V.find excedents x) F.zero > 0 - - let flux_et_reflux g x = - let s = - G.fold_succ_e - (fun e s-> - if F.compare - (capacite_restante g e) (F.min_capacity (G.E.label e)) - > 0 - then e::s else s) - g x [] - in - G.fold_pred_e - (fun e s -> - if F.compare - (E.find flot (G.E.src e, G.E.dst e)) (F.min_capacity (G.E.label e)) - > 0 - then (G.E.create (G.E.dst e) (G.E.label e) (G.E.src e))::s else s) - g x s - - let pousser g e l = - let x, y = G.E.src e, G.E.dst e in - let ex = V.find excedents x in - let cxy = capacite_restante g e in - if F.compare ex F.zero > 0 && - F.compare cxy (F.min_capacity (G.E.label e)) > 0 && - V.find hauteur x = (V.find hauteur y + 1) - then - let d = if F.compare ex cxy < 0 then ex else cxy in - let fxy = E.find flot (x,y) in - let ex = V.find excedents x in - let ey = V.find excedents y in - E.replace flot (x,y) (F.add fxy d); - E.replace flot (y,x) (F.sub F.zero (F.add fxy d)); - V.replace excedents x (F.sub ex d); - V.replace excedents y (F.add ey d); - if reste_excedent x then l:=Sv.add x !l; - if reste_excedent y then l:=Sv.add y !l; - true - else - (if F.compare ex F.zero > 0 then l:=Sv.add x !l; - false) - - let elever g p x = - let u = flux_et_reflux g x in - reste_excedent x - && not (G.V.equal x p) - && - List.for_all - (fun e -> (V.find hauteur (G.E.src e)) <= (V.find hauteur (G.E.dst e))) u - && - (let min = - List.fold_left (fun m e -> min (V.find hauteur (G.E.dst e)) m) max_int u - in - V.replace hauteur x (1+min); - true) - - let init_preflot g s p = - G.iter_vertex (fun x -> V.add excedents x F.zero; V.add hauteur x 0) g; - G.iter_edges_e - (fun e -> - let x,y = G.E.src e, G.E.dst e in - E.add flot (x,y) (F.flow (G.E.label e)); - E.add flot (y,x) (F.sub F.zero (F.flow (G.E.label e)))) - g; - V.add hauteur s (G.nb_vertex g); - G.fold_succ_e - (fun e l -> - let y = G.E.dst e in - let c = F.max_capacity (G.E.label e) in - E.add flot (s,y) c; - E.add flot (y,s) (F.sub F.zero c); - V.add excedents y c; - y::l) - g s [] - - let maxflow g s p = - let push_and_pull l x = - G.fold_succ_e (fun e r->pousser g e l or r) g x false - or G.fold_pred_e (fun e r->pousser g e l or r) g x false - in - let todo = ref (init_preflot g s p) in - while - (fold_booleen (elever g p) !todo) or - (let l = ref Sv.empty in - let r = fold_booleen (push_and_pull l) !todo in - todo:=Sv.elements !l; r) - do () done; - let flot_max = - G.fold_pred_e (fun e f -> F.add (E.find flot (G.E.src e,p)) f) g p F.zero - in - let flot_init = - G.fold_pred_e (fun e f -> F.add (F.flow (G.E.label e)) f) g p F.zero - in - let f e = - let x,y = G.E.src e, G.E.dst e in - try E.find flot (x,y) - with Not_found -> F.flow (G.E.label e) - in - f, F.sub flot_max flot_init -end - -(*****************************************************************************) - -module type G_FORD_FULKERSON = sig - type t - module V : Sig.HASHABLE - module E : sig - type t - type label - val src : t -> V.t - val dst : t -> V.t - val label : t -> label - end - val iter_succ_e : (E.t -> unit) -> t -> V.t -> unit - val iter_pred_e : (E.t -> unit) -> t -> V.t -> unit -end - -module Ford_Fulkerson - (G: G_FORD_FULKERSON) - (F: FLOW with type label = G.E.label) = -struct - - (* redefinition of F *) - module F = struct - include F - - type u = - | Flow of F.t - | Infinity - - let min x y = match x, y with - | Flow _, Infinity -> x - | Flow fx, Flow fy when F.compare fx fy < 0 -> x - | (Infinity, _) | (Flow _, Flow _) -> y - end - - module Mark = struct - module H = Hashtbl.Make(G.V) - type mark = Plus | Minus - - let marked = H.create 997 - let unvisited = Queue.create () - - let clear () = H.clear marked - - let mem = H.mem marked - - let set s e tag = - assert (not (mem s)); - H.add marked s (e, tag); - Queue.add s unvisited - - let get s : G.E.t * mark = - let e, tag = H.find marked s in - (match e with None -> assert false | Some e -> e), tag - - exception Empty = Queue.Empty - let next () = Queue.pop unvisited - end - - module Result = struct - module H = - Hashtbl.Make - (struct - open G - type t = E.t - module U = Util.HTProduct(V)(V) - let equal e1 e2 = U.equal (E.src e1, E.dst e1) (E.src e2, E.dst e2) - let hash e = U.hash (E.src e, E.dst e) - end) - - let create () = H.create 997 - - let find = H.find - - let flow r e = - try - find r e - with Not_found -> - let f = F.flow (G.E.label e) in - H.add r e f; - f - - let change op r e f = - try - H.replace r e (op (find r e) f); - with Not_found -> - assert false - - let grow = change F.add - let reduce = change F.sub - end - - let is_full r e = - F.compare (F.max_capacity (G.E.label e)) (Result.flow r e) = 0 - - let is_empty r e = - F.compare (F.min_capacity (G.E.label e)) (Result.flow r e) = 0 - - let set_flow r s t a = - let rec loop t = - if not (G.V.equal s t) then - let e, tag = Mark.get t in - match tag with - | Mark.Plus -> Result.grow r e a; loop (G.E.src e) - | Mark.Minus -> Result.reduce r e a; loop (G.E.dst e) - in - loop t - - let grow_flow r s t a = - let rec loop u b = - if G.V.equal s u then begin - match b with - | F.Infinity -> (* source = destination *) - assert (G.V.equal s t); - a - | F.Flow f -> - set_flow r s t f; - F.add a f - end else - let e, tag = Mark.get u in - let l = G.E.label e in - match tag with - | Mark.Plus -> - loop - (G.E.src e) - (F.min b (F.Flow (F.sub (F.max_capacity l) (Result.flow r e)))) - | Mark.Minus -> - loop - (G.E.dst e) - (F.min b (F.Flow (F.sub (Result.flow r e) (F.min_capacity l)))) - in - loop t F.Infinity - - let maxflow g s t = - let r = Result.create () in - let succ s = - G.iter_succ_e - (fun e -> - assert (G.V.equal s (G.E.src e)); - let t = G.E.dst e in - if not (Mark.mem t || is_full r e) then - Mark.set t (Some e) Mark.Plus) - g s - in - let pred s = - G.iter_pred_e - (fun e -> - assert (G.V.equal s (G.E.dst e)); - let t = G.E.src e in - if not (Mark.mem t || is_empty r e) then - Mark.set t (Some e) Mark.Minus) - g s - in - let internal_loop a = - try - while true do let s = Mark.next () in succ s; pred s done; - assert false - with Mark.Empty -> - if Mark.mem t then grow_flow r s t a else a - in - let rec external_loop a = - Mark.clear (); - Mark.set s None Mark.Plus; - let a' = internal_loop a in - if a = a' then a else external_loop a' - in - let a = external_loop F.zero in - (fun e -> try Result.find r e with Not_found -> F.flow (G.E.label e)), a - -end diff --git a/external/ocamlgraph/src/flow.mli b/external/ocamlgraph/src/flow.mli deleted file mode 100644 --- a/external/ocamlgraph/src/flow.mli +++ /dev/null @@ -1,107 +0,0 @@ -(**************************************************************************) -(* *) -(* Ocamlgraph: a generic graph library for OCaml *) -(* Copyright (C) 2004-2007 *) -(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) -(* *) -(* This software is free software; you can redistribute it and/or *) -(* modify it under the terms of the GNU Library General Public *) -(* License version 2, with the special exception on linking *) -(* described in file LICENSE. *) -(* *) -(* This software is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) -(* *) -(**************************************************************************) - -(** Algorithms on flows - - The following flow algorithms only apply to networks, that are - directed graphs together with a source (a 0 in-degree vertex) and a - terminal (a 0 out-degree vertex). *) - -(** {1 Maximum flow algorithms} *) - -(** Signature for edges' flow *) -module type FLOW = sig - type label - type t - - (** maximum and minimum capacities for a label on an edge *) - - val max_capacity : label -> t - val min_capacity : label -> t - - (** current flow for a label on an edge *) - - val flow : label -> t - - (** [+] and [-] on flows. *) - - val add : t -> t -> t - val sub : t -> t -> t - - (** neutral element for [add] and [sub]. *) - - val zero : t - - (** a total ordering over flows *) - - val compare : t -> t -> int - -end - -(** {2 Goldberg maximal flow algorithm} *) - -(** Minimal digraph signature for Goldberg *) -module type G_GOLDBERG = sig - type t - module V : Sig.COMPARABLE - module E : Sig.EDGE with type vertex = V.t - val nb_vertex : t -> int - val iter_vertex : (V.t -> unit) -> t -> unit - val iter_edges_e : (E.t -> unit) -> t -> unit - val fold_succ_e : (E.t -> 'a -> 'a) -> t -> V.t -> 'a -> 'a - val fold_pred_e : (E.t -> 'a -> 'a) -> t -> V.t -> 'a -> 'a -end - -module Goldberg(G: G_GOLDBERG)(F: FLOW with type label = G.E.label) : -sig - - val maxflow : G.t -> G.V.t -> G.V.t -> (G.E.t -> F.t) * F.t - (** [maxflow g v1 v2] searchs the maximal flow from source [v1] to - terminal [v2] using the Goldberg algorithm. It returns the new - flows on each edges and the growth of the flow. *) - -end - -(** {2 Ford-Fulkerson maximal flow algorithm} *) - -(** Minimal digraph signature for Ford-Fulkerson *) -module type G_FORD_FULKERSON = sig - type t - module V : Sig.HASHABLE - module E : sig - type t - type label - val src : t -> V.t - val dst : t -> V.t - val label : t -> label - end - val iter_succ_e : (E.t -> unit) -> t -> V.t -> unit - val iter_pred_e : (E.t -> unit) -> t -> V.t -> unit -end - -module Ford_Fulkerson - (G: G_FORD_FULKERSON) - (F: FLOW with type label = G.E.label) : -sig - - val maxflow : G.t -> G.V.t -> G.V.t -> (G.E.t -> F.t) * F.t - (** [maxflow g v1 v2] searchs the maximal flow from source [v1] - to terminal [v2] using the Ford-Fulkerson algorithm. It - returns the new flows on each edges and the growth of the - flow. *) - -end diff --git a/external/ocamlgraph/src/gcoloring.ml b/external/ocamlgraph/src/gcoloring.ml deleted file mode 100644 --- a/external/ocamlgraph/src/gcoloring.ml +++ /dev/null @@ -1,123 +0,0 @@ -(**************************************************************************) -(* *) -(* Ocamlgraph: a generic graph library for OCaml *) -(* Copyright (C) 2004-2007 *) -(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) -(* *) -(* This software is free software; you can redistribute it and/or *) -(* modify it under the terms of the GNU Library General Public *) -(* License version 2, with the special exception on linking *) -(* described in file LICENSE. *) -(* *) -(* This software is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) -(* *) -(**************************************************************************) - -exception NoColoring - -module type GM = sig - type t - val nb_vertex : t -> int - module V : Sig.COMPARABLE - val out_degree : t -> V.t -> int - val iter_vertex : (V.t -> unit) -> t -> unit - val fold_vertex : (V.t -> 'a -> 'a) -> t -> 'a -> 'a - val iter_succ : (V.t -> unit) -> t -> V.t -> unit - val fold_succ : (V.t -> 'a -> 'a) -> t -> V.t -> 'a -> 'a - module Mark : sig - val get : V.t -> int - val set : V.t -> int -> unit - end -end - -(** Graph coloring with marking. - Only applies to imperative graphs with marks. *) -module Mark(G : GM) = struct - - module Bfs = Traverse.Bfs(G) - - let coloring g k = - (* first step: we eliminate vertices with less than [k] successors *) - let stack = Stack.create () in - let nb_to_color = ref (G.nb_vertex g) in - let count = ref 1 in - while !count > 0 do - count := 0; - let erase v = incr count; G.Mark.set v (k+1); Stack.push v stack in - G.iter_vertex - (fun v -> if G.Mark.get v = 0 && G.out_degree g v < k then erase v) - g; - (*Format.printf "eliminating %d nodes@." !count;*) - nb_to_color := !nb_to_color - !count - done; - (* second step: we k-color the remaining of the graph *) - (* [try_color v i] tries to assign color [i] to vertex [v] *) - let try_color v i = - G.Mark.set v i; - G.iter_succ (fun w -> if G.Mark.get w = i then raise NoColoring) g v - in - let uncolor v = G.Mark.set v 0 in - if !nb_to_color > 0 then begin - let rec iterate iter = - let v = Bfs.get iter in - let m = G.Mark.get v in - if m > 0 then - iterate (Bfs.step iter) - else begin - for i = 1 to k do - try try_color v i; iterate (Bfs.step iter) - with NoColoring -> () - done; - uncolor v; - raise NoColoring - end - in - try iterate (Bfs.start g) with Exit -> () - end; - (* third step: we color the eliminated vertices, in reverse order *) - Stack.iter - (fun v -> - try - for i = 1 to k do - try try_color v i; raise Exit with NoColoring -> () - done; - raise NoColoring (* it may still fail on a self edge v->v *) - with Exit -> ()) - stack - -end - -(** Graph coloring for graphs without marks: we use an external hashtbl *) - -module type G = sig - type t - val nb_vertex : t -> int - module V : Sig.COMPARABLE - val out_degree : t -> V.t -> int - val iter_vertex : (V.t -> unit) -> t -> unit - val fold_vertex : (V.t -> 'a -> 'a) -> t -> 'a -> 'a - val iter_succ : (V.t -> unit) -> t -> V.t -> unit - val fold_succ : (V.t -> 'a -> 'a) -> t -> V.t -> 'a -> 'a -end - -module Make(G: G) = struct - - module H = Hashtbl.Make(G.V) - - let coloring g k = - let h = H.create 97 in - let module M = - Mark(struct - include G - module Mark = struct - let get v = try H.find h v with Not_found -> 0 - let set v n = H.replace h v n - end - end ) - in - M.coloring g k; - h - -end diff --git a/external/ocamlgraph/src/gcoloring.mli b/external/ocamlgraph/src/gcoloring.mli deleted file mode 100644 --- a/external/ocamlgraph/src/gcoloring.mli +++ /dev/null @@ -1,79 +0,0 @@ -(**************************************************************************) -(* *) -(* Ocamlgraph: a generic graph library for OCaml *) -(* Copyright (C) 2004-2007 *) -(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) -(* *) -(* This software is free software; you can redistribute it and/or *) -(* modify it under the terms of the GNU Library General Public *) -(* License version 2, with the special exception on linking *) -(* described in file LICENSE. *) -(* *) -(* This software is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) -(* *) -(**************************************************************************) - -(** k-coloring of undirected graphs. - - A k-coloring of a graph g is a mapping c from nodes to \{1,...,k\} such - that c(u)<>c(v) for any edge u-v in g. *) - -exception NoColoring - -(** Graph coloring for graph with integer marks. *) - -module type GM = sig - type t - val nb_vertex : t -> int - module V : Sig.COMPARABLE - val out_degree : t -> V.t -> int - val iter_vertex : (V.t -> unit) -> t -> unit - val fold_vertex : (V.t -> 'a -> 'a) -> t -> 'a -> 'a - val iter_succ : (V.t -> unit) -> t -> V.t -> unit - val fold_succ : (V.t -> 'a -> 'a) -> t -> V.t -> 'a -> 'a - module Mark : sig - val get : V.t -> int - val set : V.t -> int -> unit - end -end - -module Mark(G : GM) : sig - - val coloring : G.t -> int -> unit - (** [coloring g k] colors the nodes of graph [g] using k colors, - assigning the marks integer values between 1 and k. - raises [NoColoring] when there is no possible coloring. - - The graph marks may be partially set before starting; the meaning of - initial values is as follows: - - 0: a node to be colored - - any value between 1 and k: a color already assigned - - any value greater than k: a node to be ignored *) - -end - -(** Graph coloring for graphs without marks *) - -module type G = sig - type t - val nb_vertex : t -> int - module V : Sig.COMPARABLE - val out_degree : t -> V.t -> int - val iter_vertex : (V.t -> unit) -> t -> unit - val fold_vertex : (V.t -> 'a -> 'a) -> t -> 'a -> 'a - val iter_succ : (V.t -> unit) -> t -> V.t -> unit - val fold_succ : (V.t -> 'a -> 'a) -> t -> V.t -> 'a -> 'a -end - -module Make(G: G) : sig - - module H : Hashtbl.S with type key = G.V.t - (** hash tables used to store the coloring *) - - val coloring : G.t -> int -> int H.t - (** [coloring g k] colors the graph [g] with [k] colors and returns the - coloring as a hash table mapping nodes to their colors. *) - -end diff --git a/external/ocamlgraph/src/gmap.ml b/external/ocamlgraph/src/gmap.ml deleted file mode 100644 --- a/external/ocamlgraph/src/gmap.ml +++ /dev/null @@ -1,68 +0,0 @@ -(**************************************************************************) -(* *) -(* Ocamlgraph: a generic graph library for OCaml *) -(* Copyright (C) 2004-2007 *) -(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) -(* *) -(* This software is free software; you can redistribute it and/or *) -(* modify it under the terms of the GNU Library General Public *) -(* License version 2, with the special exception on linking *) -(* described in file LICENSE. *) -(* *) -(* This software is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) -(* *) -(**************************************************************************) - -(* $Id: gmap.ml,v 1.1 2004-10-20 09:59:56 signoles Exp $ *) - -module Vertex - (G_Init : sig - type t - module V : Sig.HASHABLE - val fold_vertex : (V.t -> 'a -> 'a) -> t -> 'a -> 'a - end) - (G_Dest : sig - type t - type vertex - val empty : unit -> t - val add_vertex : t -> vertex -> t - end) = -struct - - module H = Hashtbl.Make(G_Init.V) - - let vertices = H.create 97 - - let convert_vertex f x = - try - H.find vertices x - with Not_found -> - let x' = f x in - H.add vertices x x'; - x' - - let map f g = - H.clear vertices; - G_Init.fold_vertex - (fun x g -> G_Dest.add_vertex g (convert_vertex f x)) - g (G_Dest.empty ()) - -end - -module Edge - (G_Init : sig - type t - module E : Sig.HASHABLE - val fold_edges_e : (E.t -> 'a -> 'a) -> t -> 'a -> 'a - end) - (G_Dest : sig - type t - type edge - val empty : unit -> t - val add_edge_e : t -> edge -> t - end) = - Vertex - (struct include G_Init module V = E let fold_vertex = fold_edges_e end) - (struct include G_Dest type vertex = edge let add_vertex = add_edge_e end) diff --git a/external/ocamlgraph/src/gmap.mli b/external/ocamlgraph/src/gmap.mli deleted file mode 100644 --- a/external/ocamlgraph/src/gmap.mli +++ /dev/null @@ -1,60 +0,0 @@ -(**************************************************************************) -(* *) -(* Ocamlgraph: a generic graph library for OCaml *) -(* Copyright (C) 2004-2007 *) -(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) -(* *) -(* This software is free software; you can redistribute it and/or *) -(* modify it under the terms of the GNU Library General Public *) -(* License version 2, with the special exception on linking *) -(* described in file LICENSE. *) -(* *) -(* This software is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) -(* *) -(**************************************************************************) - -(* $Id: gmap.mli,v 1.1 2004-10-20 09:59:56 signoles Exp $ *) - -(** Graph mapping *) - -module Vertex - (G_Init : sig - type t - module V : Sig.HASHABLE - val fold_vertex : (V.t -> 'a -> 'a) -> t -> 'a -> 'a - end) - (G_Dest : sig - type t - type vertex - val empty : unit -> t - val add_vertex : t -> vertex -> t - end) : -sig - - val map : (G_Init.V.t -> G_Dest.vertex) -> G_Init.t -> G_Dest.t - (** [map f g] applies [f] to each vertex of [g] and so builds a new graph - based on [g] *) - -end - -module Edge - (G_Init : sig - type t - module E : Sig.HASHABLE - val fold_edges_e : (E.t -> 'a -> 'a) -> t -> 'a -> 'a - end) - (G_Dest : sig - type t - type edge - val empty : unit -> t - val add_edge_e : t -> edge -> t - end) : -sig - - val map : (G_Init.E.t -> G_Dest.edge) -> G_Init.t -> G_Dest.t - (** [map f g] applies [f] to each edge of [g] and so builds a new graph - based on [g] *) - -end diff --git a/external/ocamlgraph/src/gml.ml b/external/ocamlgraph/src/gml.ml deleted file mode 100644 --- a/external/ocamlgraph/src/gml.ml +++ /dev/null @@ -1,670 +0,0 @@ -# 20 "src/gml.mll" - - - open Lexing - - type value = - | Int of int - | Float of float - | String of string - | List of value_list - - and value_list = (string * value) list - - -# 16 "src/gml.ml" -let __ocaml_lex_tables = { - Lexing.lex_base = - "\000\000\252\255\253\255\114\000\002\000\007\000\228\000\086\001\ - \252\255\253\255\200\001\009\000\014\000\058\002\002\000\251\255\ - \252\255\001\000\080\000\102\000\194\000\216\000\052\001\071\001\ - \253\255\006\000"; - Lexing.lex_backtrk = - "\255\255\255\255\255\255\003\000\000\000\001\000\255\255\255\255\ - \255\255\255\255\003\000\000\000\001\000\255\255\255\255\255\255\ - \255\255\004\000\001\000\000\000\004\000\255\255\001\000\255\255\ - \255\255\255\255"; - Lexing.lex_default = - "\001\000\000\000\000\000\255\255\255\255\255\255\255\255\008\000\ - \000\000\000\000\255\255\255\255\255\255\255\255\015\000\000\000\ - \000\000\025\000\255\255\255\255\255\255\255\255\255\255\255\255\ - \000\000\025\000"; - Lexing.lex_trans = - "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\004\000\004\000\004\000\004\000\004\000\000\000\004\000\ - \005\000\005\000\011\000\011\000\005\000\000\000\011\000\012\000\ - \012\000\000\000\000\000\012\000\000\000\000\000\000\000\000\000\ - \004\000\000\000\004\000\024\000\017\000\000\000\000\000\005\000\ - \024\000\011\000\000\000\000\000\000\000\020\000\012\000\020\000\ - \018\000\000\000\019\000\019\000\019\000\019\000\019\000\019\000\ - \019\000\019\000\019\000\019\000\000\000\000\000\000\000\000\000\ - \000\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ - \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ - \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ - \003\000\003\000\003\000\000\000\000\000\016\000\000\000\000\000\ - \000\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ - \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ - \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ - \003\000\003\000\003\000\005\000\005\000\000\000\000\000\005\000\ - \018\000\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ - \018\000\018\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\005\000\000\000\018\000\021\000\019\000\019\000\ - \019\000\019\000\019\000\019\000\019\000\019\000\019\000\019\000\ - \000\000\000\000\006\000\006\000\006\000\006\000\006\000\006\000\ - \006\000\006\000\006\000\006\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\006\000\006\000\006\000\006\000\006\000\ - \006\000\006\000\006\000\006\000\006\000\006\000\006\000\006\000\ - \006\000\006\000\006\000\006\000\006\000\006\000\006\000\006\000\ - \006\000\006\000\006\000\006\000\006\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\006\000\006\000\006\000\006\000\006\000\ - \006\000\006\000\006\000\006\000\006\000\006\000\006\000\006\000\ - \006\000\006\000\006\000\006\000\006\000\006\000\006\000\006\000\ - \006\000\006\000\006\000\006\000\006\000\005\000\005\000\000\000\ - \018\000\005\000\019\000\019\000\019\000\019\000\019\000\019\000\ - \019\000\019\000\019\000\019\000\000\000\000\000\000\000\000\000\ - \002\000\255\255\255\255\023\000\005\000\023\000\255\255\000\000\ - \022\000\022\000\022\000\022\000\022\000\022\000\022\000\022\000\ - \022\000\022\000\000\000\000\000\006\000\006\000\006\000\006\000\ - \006\000\006\000\006\000\006\000\006\000\006\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\006\000\006\000\006\000\ - \006\000\006\000\006\000\006\000\006\000\006\000\006\000\006\000\ - \006\000\006\000\006\000\006\000\006\000\006\000\006\000\006\000\ - \006\000\006\000\006\000\006\000\006\000\006\000\006\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\006\000\006\000\006\000\ - \006\000\006\000\006\000\006\000\006\000\006\000\006\000\006\000\ - \006\000\006\000\006\000\006\000\006\000\006\000\006\000\006\000\ - \006\000\006\000\006\000\006\000\006\000\006\000\006\000\011\000\ - \011\000\000\000\000\000\011\000\022\000\022\000\022\000\022\000\ - \022\000\022\000\022\000\022\000\022\000\022\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\011\000\022\000\ - \022\000\022\000\022\000\022\000\022\000\022\000\022\000\022\000\ - \022\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\010\000\ - \010\000\010\000\010\000\010\000\010\000\010\000\010\000\010\000\ - \010\000\010\000\010\000\010\000\010\000\010\000\010\000\010\000\ - \010\000\010\000\010\000\010\000\010\000\010\000\010\000\010\000\ - \010\000\000\000\000\000\009\000\000\000\000\000\000\000\010\000\ - \010\000\010\000\010\000\010\000\010\000\010\000\010\000\010\000\ - \010\000\010\000\010\000\010\000\010\000\010\000\010\000\010\000\ - \010\000\010\000\010\000\010\000\010\000\010\000\010\000\010\000\ - \010\000\012\000\012\000\000\000\000\000\012\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \012\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \013\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ - \013\000\013\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ - \013\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ - \013\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ - \013\000\013\000\013\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ - \013\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ - \013\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ - \013\000\013\000\013\000\012\000\012\000\000\000\000\000\012\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\255\255\000\000\ - \000\000\000\000\012\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\013\000\013\000\013\000\013\000\013\000\013\000\ - \013\000\013\000\013\000\013\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\013\000\013\000\013\000\013\000\013\000\ - \013\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ - \013\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ - \013\000\013\000\013\000\013\000\013\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\013\000\013\000\013\000\013\000\013\000\ - \013\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ - \013\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ - \013\000\013\000\013\000\013\000\013\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000"; - Lexing.lex_check = - "\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\000\000\000\000\004\000\004\000\000\000\255\255\004\000\ - \005\000\005\000\011\000\011\000\005\000\255\255\011\000\012\000\ - \012\000\255\255\255\255\012\000\255\255\255\255\255\255\255\255\ - \000\000\255\255\004\000\017\000\014\000\255\255\255\255\005\000\ - \025\000\011\000\255\255\255\255\255\255\014\000\012\000\014\000\ - \014\000\255\255\014\000\014\000\014\000\014\000\014\000\014\000\ - \014\000\014\000\014\000\014\000\255\255\255\255\255\255\255\255\ - \255\255\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\255\255\255\255\014\000\255\255\255\255\ - \255\255\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\003\000\003\000\255\255\255\255\003\000\ - \018\000\018\000\018\000\018\000\018\000\018\000\018\000\018\000\ - \018\000\018\000\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\003\000\255\255\019\000\018\000\019\000\019\000\ - \019\000\019\000\019\000\019\000\019\000\019\000\019\000\019\000\ - \255\255\255\255\003\000\003\000\003\000\003\000\003\000\003\000\ - \003\000\003\000\003\000\003\000\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\003\000\003\000\003\000\003\000\003\000\ - \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ - \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ - \003\000\003\000\003\000\003\000\003\000\255\255\255\255\255\255\ - \255\255\255\255\255\255\003\000\003\000\003\000\003\000\003\000\ - \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ - \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ - \003\000\003\000\003\000\003\000\003\000\006\000\006\000\255\255\ - \020\000\006\000\020\000\020\000\020\000\020\000\020\000\020\000\ - \020\000\020\000\020\000\020\000\255\255\255\255\255\255\255\255\ - \000\000\017\000\014\000\021\000\006\000\021\000\025\000\255\255\ - \021\000\021\000\021\000\021\000\021\000\021\000\021\000\021\000\ - \021\000\021\000\255\255\255\255\006\000\006\000\006\000\006\000\ - \006\000\006\000\006\000\006\000\006\000\006\000\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\006\000\006\000\006\000\ - \006\000\006\000\006\000\006\000\006\000\006\000\006\000\006\000\ - \006\000\006\000\006\000\006\000\006\000\006\000\006\000\006\000\ - \006\000\006\000\006\000\006\000\006\000\006\000\006\000\255\255\ - \255\255\255\255\255\255\255\255\255\255\006\000\006\000\006\000\ - \006\000\006\000\006\000\006\000\006\000\006\000\006\000\006\000\ - \006\000\006\000\006\000\006\000\006\000\006\000\006\000\006\000\ - \006\000\006\000\006\000\006\000\006\000\006\000\006\000\007\000\ - \007\000\255\255\255\255\007\000\022\000\022\000\022\000\022\000\ - \022\000\022\000\022\000\022\000\022\000\022\000\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\007\000\023\000\ - \023\000\023\000\023\000\023\000\023\000\023\000\023\000\023\000\ - \023\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\007\000\ - \007\000\007\000\007\000\007\000\007\000\007\000\007\000\007\000\ - \007\000\007\000\007\000\007\000\007\000\007\000\007\000\007\000\ - \007\000\007\000\007\000\007\000\007\000\007\000\007\000\007\000\ - \007\000\255\255\255\255\007\000\255\255\255\255\255\255\007\000\ - \007\000\007\000\007\000\007\000\007\000\007\000\007\000\007\000\ - \007\000\007\000\007\000\007\000\007\000\007\000\007\000\007\000\ - \007\000\007\000\007\000\007\000\007\000\007\000\007\000\007\000\ - \007\000\010\000\010\000\255\255\255\255\010\000\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \010\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \010\000\010\000\010\000\010\000\010\000\010\000\010\000\010\000\ - \010\000\010\000\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\010\000\010\000\010\000\010\000\010\000\010\000\010\000\ - \010\000\010\000\010\000\010\000\010\000\010\000\010\000\010\000\ - \010\000\010\000\010\000\010\000\010\000\010\000\010\000\010\000\ - \010\000\010\000\010\000\255\255\255\255\255\255\255\255\255\255\ - \255\255\010\000\010\000\010\000\010\000\010\000\010\000\010\000\ - \010\000\010\000\010\000\010\000\010\000\010\000\010\000\010\000\ - \010\000\010\000\010\000\010\000\010\000\010\000\010\000\010\000\ - \010\000\010\000\010\000\013\000\013\000\255\255\255\255\013\000\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\007\000\255\255\ - \255\255\255\255\013\000\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\013\000\013\000\013\000\013\000\013\000\013\000\ - \013\000\013\000\013\000\013\000\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\013\000\013\000\013\000\013\000\013\000\ - \013\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ - \013\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ - \013\000\013\000\013\000\013\000\013\000\255\255\255\255\255\255\ - \255\255\255\255\255\255\013\000\013\000\013\000\013\000\013\000\ - \013\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ - \013\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ - \013\000\013\000\013\000\013\000\013\000\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255"; - Lexing.lex_base_code = - "\000\000\000\000\000\000\075\000\000\000\000\000\150\000\208\000\ - \000\000\000\000\027\001\000\000\000\000\102\001\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000"; - Lexing.lex_backtrk_code = - "\000\000\000\000\000\000\000\000\000\000\004\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\004\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000"; - Lexing.lex_default_code = - "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000"; - Lexing.lex_trans_code = - "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ - \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ - \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ - \001\000\001\000\001\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ - \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ - \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ - \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ - \001\000\001\000\001\000\001\000\001\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\001\000\001\000\001\000\001\000\ - \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ - \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ - \001\000\001\000\001\000\001\000\001\000\001\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\001\000\001\000\001\000\001\000\ - \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ - \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ - \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ - \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\000\ - \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ - \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ - \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ - \001\000\000\000\000\000\000\000\000\000\000\000\000\000\001\000\ - \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ - \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ - \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ - \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ - \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ - \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ - \001\000\001\000\001\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ - \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ - \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ - \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ - \001\000\001\000\001\000\001\000\001\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\001\000\001\000\001\000\001\000\ - \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ - \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ - \001\000\001\000\001\000\001\000\001\000\001\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\001\000\001\000\001\000\001\000\ - \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ - \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ - \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ - \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\000\ - \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ - \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ - \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ - \001\000\000\000\000\000\000\000\000\000\000\000\000\000\001\000\ - \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ - \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ - \001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ - \001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000"; - Lexing.lex_check_code = - "\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\255\255\255\255\255\255\255\255\255\255\ - \255\255\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\003\000\003\000\003\000\003\000\003\000\ - \003\000\003\000\003\000\003\000\003\000\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\003\000\003\000\003\000\003\000\ - \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ - \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ - \003\000\003\000\003\000\003\000\003\000\003\000\255\255\255\255\ - \255\255\255\255\255\255\255\255\003\000\003\000\003\000\003\000\ - \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ - \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ - \003\000\003\000\003\000\003\000\003\000\003\000\006\000\006\000\ - \006\000\006\000\006\000\006\000\006\000\006\000\006\000\006\000\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\006\000\ - \006\000\006\000\006\000\006\000\006\000\006\000\006\000\006\000\ - \006\000\006\000\006\000\006\000\006\000\006\000\006\000\006\000\ - \006\000\006\000\006\000\006\000\006\000\006\000\006\000\006\000\ - \006\000\255\255\255\255\255\255\255\255\255\255\255\255\006\000\ - \006\000\006\000\006\000\006\000\006\000\006\000\006\000\006\000\ - \006\000\006\000\006\000\006\000\006\000\006\000\006\000\006\000\ - \006\000\006\000\006\000\006\000\006\000\006\000\006\000\006\000\ - \006\000\007\000\007\000\007\000\007\000\007\000\007\000\007\000\ - \007\000\007\000\007\000\007\000\007\000\007\000\007\000\007\000\ - \007\000\007\000\007\000\007\000\007\000\007\000\007\000\007\000\ - \007\000\007\000\007\000\255\255\255\255\255\255\255\255\255\255\ - \255\255\007\000\007\000\007\000\007\000\007\000\007\000\007\000\ - \007\000\007\000\007\000\007\000\007\000\007\000\007\000\007\000\ - \007\000\007\000\007\000\007\000\007\000\007\000\007\000\007\000\ - \007\000\007\000\007\000\010\000\010\000\010\000\010\000\010\000\ - \010\000\010\000\010\000\010\000\010\000\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\010\000\010\000\010\000\010\000\ - \010\000\010\000\010\000\010\000\010\000\010\000\010\000\010\000\ - \010\000\010\000\010\000\010\000\010\000\010\000\010\000\010\000\ - \010\000\010\000\010\000\010\000\010\000\010\000\255\255\255\255\ - \255\255\255\255\255\255\255\255\010\000\010\000\010\000\010\000\ - \010\000\010\000\010\000\010\000\010\000\010\000\010\000\010\000\ - \010\000\010\000\010\000\010\000\010\000\010\000\010\000\010\000\ - \010\000\010\000\010\000\010\000\010\000\010\000\013\000\013\000\ - \013\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\013\000\ - \013\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ - \013\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ - \013\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ - \013\000\255\255\255\255\255\255\255\255\255\255\255\255\013\000\ - \013\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ - \013\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ - \013\000\013\000\013\000\013\000\013\000\013\000\013\000\013\000\ - \013\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255"; - Lexing.lex_code = - "\255\001\255\255\000\001\255"; -} - -let rec file lexbuf = - lexbuf.Lexing.lex_mem <- Array.create 2 (-1) ; __ocaml_lex_file_rec lexbuf 0 -and __ocaml_lex_file_rec lexbuf __ocaml_lex_state = - match Lexing.new_engine __ocaml_lex_tables __ocaml_lex_state lexbuf with - | 0 -> -# 45 "src/gml.mll" - ( file lexbuf ) -# 425 "src/gml.ml" - - | 1 -> -let -# 46 "src/gml.mll" - key -# 431 "src/gml.ml" -= Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos lexbuf.Lexing.lex_mem.(0) in -# 47 "src/gml.mll" - ( let v = value lexbuf in - (key, v) :: file lexbuf ) -# 436 "src/gml.ml" - - | 2 -> -# 50 "src/gml.mll" - ( [] ) -# 441 "src/gml.ml" - - | 3 -> -let -# 51 "src/gml.mll" - c -# 447 "src/gml.ml" -= Lexing.sub_lexeme_char lexbuf lexbuf.Lexing.lex_start_pos in -# 52 "src/gml.mll" - ( failwith ("Gml: invalid character " ^ String.make 1 c) ) -# 451 "src/gml.ml" - - | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_file_rec lexbuf __ocaml_lex_state - -and value_list lexbuf = - lexbuf.Lexing.lex_mem <- Array.create 2 (-1) ; __ocaml_lex_value_list_rec lexbuf 7 -and __ocaml_lex_value_list_rec lexbuf __ocaml_lex_state = - match Lexing.new_engine __ocaml_lex_tables __ocaml_lex_state lexbuf with - | 0 -> -# 56 "src/gml.mll" - ( value_list lexbuf ) -# 462 "src/gml.ml" - - | 1 -> -let -# 57 "src/gml.mll" - key -# 468 "src/gml.ml" -= Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos lexbuf.Lexing.lex_mem.(0) in -# 58 "src/gml.mll" - ( let v = value lexbuf in - (key, v) :: value_list lexbuf ) -# 473 "src/gml.ml" - - | 2 -> -# 61 "src/gml.mll" - ( [] ) -# 478 "src/gml.ml" - - | 3 -> -let -# 62 "src/gml.mll" - c -# 484 "src/gml.ml" -= Lexing.sub_lexeme_char lexbuf lexbuf.Lexing.lex_start_pos in -# 63 "src/gml.mll" - ( failwith ("Gml: invalid character " ^ String.make 1 c) ) -# 488 "src/gml.ml" - - | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_value_list_rec lexbuf __ocaml_lex_state - -and value lexbuf = - __ocaml_lex_value_rec lexbuf 14 -and __ocaml_lex_value_rec lexbuf __ocaml_lex_state = - match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf with - | 0 -> -let -# 66 "src/gml.mll" - i -# 500 "src/gml.ml" -= Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos lexbuf.Lexing.lex_curr_pos in -# 67 "src/gml.mll" - ( Int (int_of_string i) ) -# 504 "src/gml.ml" - - | 1 -> -let -# 68 "src/gml.mll" - r -# 510 "src/gml.ml" -= Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos lexbuf.Lexing.lex_curr_pos in -# 69 "src/gml.mll" - ( Float (float_of_string r) ) -# 514 "src/gml.ml" - - | 2 -> -let -# 70 "src/gml.mll" - s -# 520 "src/gml.ml" -= Lexing.sub_lexeme lexbuf (lexbuf.Lexing.lex_start_pos + 1) (lexbuf.Lexing.lex_curr_pos + -1) in -# 71 "src/gml.mll" - ( String s ) -# 524 "src/gml.ml" - - | 3 -> -# 73 "src/gml.mll" - ( let l = value_list lexbuf in List l ) -# 529 "src/gml.ml" - - | 4 -> -let -# 74 "src/gml.mll" - c -# 535 "src/gml.ml" -= Lexing.sub_lexeme_char lexbuf lexbuf.Lexing.lex_start_pos in -# 75 "src/gml.mll" - ( failwith ("Gml: invalid character " ^ String.make 1 c) ) -# 539 "src/gml.ml" - - | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_value_rec lexbuf __ocaml_lex_state - -;; - -# 77 "src/gml.mll" - - - let parse f = - let c = open_in f in - let lb = from_channel c in - let v = file lb in - close_in c; - v - - module Parse - (B : Builder.S) - (L : sig val node : value_list -> B.G.V.label - val edge : value_list -> B.G.E.label end) = - struct - - let create_graph l = - let nodes = Hashtbl.create 97 in - let g = B.empty () in - (* 1st pass: create the nodes *) - let g = - List.fold_left - (fun g v -> match v with - | "node", List l -> - let n = B.G.V.create (L.node l) in - begin - try - let id = List.assoc "id" l in Hashtbl.add nodes id n - with Not_found -> - () - end; - B.add_vertex g n - | _ -> - g) - g l - in - (* 2nd pass: add the edges *) - List.fold_left - (fun g v -> match v with - | "edge", List l -> - begin try - let source = List.assoc "source" l in - let target = List.assoc "target" l in - let nsource = Hashtbl.find nodes source in - let ntarget = Hashtbl.find nodes target in - let e = B.G.E.create nsource (L.edge l) ntarget in - B.add_edge_e g e - with Not_found -> - g - end - | _ -> - g) - g l - - let parse f = - match parse f with - | ["graph", List l] -> create_graph l - | _ -> invalid_arg "Gml.Parse.parse: not a graph file" - - end - - module Print - (G : sig - module V : sig - type t - val hash : t -> int - val equal : t -> t -> bool - type label - val label : t -> label - end - module E : sig - type t - type label - val src : t -> V.t - val dst : t -> V.t - val label : t -> label - end - type t - val iter_vertex : (V.t -> unit) -> t -> unit - val iter_edges_e : (E.t -> unit) -> t -> unit - end) - (L : sig - val node : G.V.label -> value_list - val edge : G.E.label -> value_list - end) = - struct - - open Format - - module H = Hashtbl.Make(G.V) - - let print fmt g = - let nodes = H.create 97 in - let cpt = ref 0 in - let id n = - try H.find nodes n - with Not_found -> incr cpt; let id = !cpt in H.add nodes n id; id - in - fprintf fmt "@[graph [@\n"; - let rec value fmt = function - | Int n -> fprintf fmt "%d" n - | Float f -> fprintf fmt "%f" f - | String s -> fprintf fmt "\"%s\"" s - | List l -> fprintf fmt "[@\n @[%a@]@\n]" value_list l - and value_list fmt = function - | [] -> () - | [s,v] -> fprintf fmt "%s %a" s value v - | (s,v) :: l -> fprintf fmt "%s %a@\n" s value v; value_list fmt l - in - G.iter_vertex - (fun v -> - fprintf fmt " @[node [@\n id %d@\n @[%a@]@\n]@]@\n" - (id v) value_list (L.node (G.V.label v))) - g; - G.iter_edges_e - (fun e -> - fprintf fmt - " @[edge [@\n source %d@\n target %d@\n @[%a@]@\n]@]@\n" - (id (G.E.src e)) (id (G.E.dst e)) - value_list (L.edge (G.E.label e))) - g; - fprintf fmt "]@\n" - - end - - -# 671 "src/gml.ml" diff --git a/external/ocamlgraph/src/gml.mli b/external/ocamlgraph/src/gml.mli deleted file mode 100644 --- a/external/ocamlgraph/src/gml.mli +++ /dev/null @@ -1,76 +0,0 @@ -(**************************************************************************) -(* *) -(* Ocamlgraph: a generic graph library for OCaml *) -(* Copyright (C) 2004-2007 *) -(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) -(* *) -(* This software is free software; you can redistribute it and/or *) -(* modify it under the terms of the GNU Library General Public *) -(* License version 2, with the special exception on linking *) -(* described in file LICENSE. *) -(* *) -(* This software is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) -(* *) -(**************************************************************************) - -(* $Id: gml.mli,v 1.3 2005-07-06 13:20:31 conchon Exp $ *) - -(** Parser for GML file format *) - -type value = - | Int of int - | Float of float - | String of string - | List of value_list - -and value_list = (string * value) list - -module Parse - (B : Builder.S) - (L : sig - val node : value_list -> B.G.V.label - (** how to build the node label out of the set of GML attributes; -for example {v node [ id 12 label "foo" ] v} -will call this function with [["id", Int 12; "label", String "foo"]] *) - val edge : value_list -> B.G.E.label - (** how to build the edge label out of the set of GML attributes *) - end) : -sig - - val parse : string -> B.G.t - -end - -module Print - (G : sig - module V : sig - type t - val hash : t -> int - val equal : t -> t -> bool - type label - val label : t -> label - end - module E : sig - type t - type label - val src : t -> V.t - val dst : t -> V.t - val label : t -> label - end - type t - val iter_vertex : (V.t -> unit) -> t -> unit - val iter_edges_e : (E.t -> unit) -> t -> unit - end) - (L : sig - val node : G.V.label -> value_list - val edge : G.E.label -> value_list - end) : -sig - - val print : Format.formatter -> G.t -> unit - -end - - diff --git a/external/ocamlgraph/src/gml.mll b/external/ocamlgraph/src/gml.mll deleted file mode 100644 --- a/external/ocamlgraph/src/gml.mll +++ /dev/null @@ -1,202 +0,0 @@ -(**************************************************************************) -(* *) -(* Ocamlgraph: a generic graph library for OCaml *) -(* Copyright (C) 2004-2007 *) -(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) -(* *) -(* This software is free software; you can redistribute it and/or *) -(* modify it under the terms of the GNU Library General Public *) -(* License version 2, with the special exception on linking *) -(* described in file LICENSE. *) -(* *) -(* This software is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) -(* *) -(**************************************************************************) - -(* $Id: gml.mll,v 1.3 2005-07-06 13:20:31 conchon Exp $ *) - -{ - - open Lexing - - type value = - | Int of int - | Float of float - | String of string - | List of value_list - - and value_list = (string * value) list - -} - -let space = [' ' '\t' '\r' '\n']+ -let ident = ['a'-'z' 'A'-'Z'] ['a'-'z' 'A'-'Z' '0'-'9']* -let digit = ['0'-'9'] -let sign = '-' | '+' -let integer = sign? digit+ -let mantissa = 'E' sign? digit+ -let real = sign? digit* '.' digit* mantissa? -let in_string = [^ '"']* - -rule file = parse - | space - { file lexbuf } - | (ident as key) space - { let v = value lexbuf in - (key, v) :: file lexbuf } - | eof - { [] } - | _ as c - { failwith ("Gml: invalid character " ^ String.make 1 c) } - -and value_list = parse - | space - { value_list lexbuf } - | (ident as key) space - { let v = value lexbuf in - (key, v) :: value_list lexbuf } - | ']' - { [] } - | _ as c - { failwith ("Gml: invalid character " ^ String.make 1 c) } - -and value = parse - | integer as i - { Int (int_of_string i) } - | real as r - { Float (float_of_string r) } - | '"' (in_string as s) '"' - { String s } - | '[' - { let l = value_list lexbuf in List l } - | _ as c - { failwith ("Gml: invalid character " ^ String.make 1 c) } - -{ - - let parse f = - let c = open_in f in - let lb = from_channel c in - let v = file lb in - close_in c; - v - - module Parse - (B : Builder.S) - (L : sig val node : value_list -> B.G.V.label - val edge : value_list -> B.G.E.label end) = - struct - - let create_graph l = - let nodes = Hashtbl.create 97 in - let g = B.empty () in - (* 1st pass: create the nodes *) - let g = - List.fold_left - (fun g v -> match v with - | "node", List l -> - let n = B.G.V.create (L.node l) in - begin - try - let id = List.assoc "id" l in Hashtbl.add nodes id n - with Not_found -> - () - end; - B.add_vertex g n - | _ -> - g) - g l - in - (* 2nd pass: add the edges *) - List.fold_left - (fun g v -> match v with - | "edge", List l -> - begin try - let source = List.assoc "source" l in - let target = List.assoc "target" l in - let nsource = Hashtbl.find nodes source in - let ntarget = Hashtbl.find nodes target in - let e = B.G.E.create nsource (L.edge l) ntarget in - B.add_edge_e g e - with Not_found -> - g - end - | _ -> - g) - g l - - let parse f = - match parse f with - | ["graph", List l] -> create_graph l - | _ -> invalid_arg "Gml.Parse.parse: not a graph file" - - end - - module Print - (G : sig - module V : sig - type t - val hash : t -> int - val equal : t -> t -> bool - type label - val label : t -> label - end - module E : sig - type t - type label - val src : t -> V.t - val dst : t -> V.t - val label : t -> label - end - type t - val iter_vertex : (V.t -> unit) -> t -> unit - val iter_edges_e : (E.t -> unit) -> t -> unit - end) - (L : sig - val node : G.V.label -> value_list - val edge : G.E.label -> value_list - end) = - struct - - open Format - - module H = Hashtbl.Make(G.V) - - let print fmt g = - let nodes = H.create 97 in - let cpt = ref 0 in - let id n = - try H.find nodes n - with Not_found -> incr cpt; let id = !cpt in H.add nodes n id; id - in - fprintf fmt "@[graph [@\n"; - let rec value fmt = function - | Int n -> fprintf fmt "%d" n - | Float f -> fprintf fmt "%f" f - | String s -> fprintf fmt "\"%s\"" s - | List l -> fprintf fmt "[@\n @[%a@]@\n]" value_list l - and value_list fmt = function - | [] -> () - | [s,v] -> fprintf fmt "%s %a" s value v - | (s,v) :: l -> fprintf fmt "%s %a@\n" s value v; value_list fmt l - in - G.iter_vertex - (fun v -> - fprintf fmt " @[node [@\n id %d@\n @[%a@]@\n]@]@\n" - (id v) value_list (L.node (G.V.label v))) - g; - G.iter_edges_e - (fun e -> - fprintf fmt - " @[edge [@\n source %d@\n target %d@\n @[%a@]@\n]@]@\n" - (id (G.E.src e)) (id (G.E.dst e)) - value_list (L.edge (G.E.label e))) - g; - fprintf fmt "]@\n" - - end - -} - diff --git a/external/ocamlgraph/src/gpath.ml b/external/ocamlgraph/src/gpath.ml deleted file mode 100644 --- a/external/ocamlgraph/src/gpath.ml +++ /dev/null @@ -1,132 +0,0 @@ -(**************************************************************************) -(* *) -(* Ocamlgraph: a generic graph library for OCaml *) -(* Copyright (C) 2004-2007 *) -(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) -(* *) -(* This software is free software; you can redistribute it and/or *) -(* modify it under the terms of the GNU Library General Public *) -(* License version 2, with the special exception on linking *) -(* described in file LICENSE. *) -(* *) -(* This software is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) -(* *) -(**************************************************************************) - -(* $Id: path.ml,v 1.6 2005-07-18 07:10:35 filliatr Exp $ *) - -module type WEIGHT = sig - type label - type t - val weight : label -> t - val zero : t - val add : t -> t -> t - val compare : t -> t -> int -end - -module type G = sig - type t - module V : Sig.COMPARABLE - module E : sig - type t - type label - val label : t -> label - val dst : t -> V.t - end - val iter_succ_e : (E.t -> unit) -> t -> V.t -> unit -end - -module Dijkstra - (G: G) - (W: WEIGHT with type label = G.E.label) = -struct - - open G.E - - module H = Hashtbl.Make(G.V) - - module Elt = struct - type t = W.t * G.V.t * G.E.t list - - (* weights are compared first, and minimal weights come first in the - queue *) - let compare (w1,v1,_) (w2,v2,_) = - let cw = W.compare w2 w1 in - if cw != 0 then cw else G.V.compare v1 v2 - end - - module PQ = Heap.Imperative(Elt) - - let shortest_path g v1 v2 = - let visited = H.create 97 in - let q = PQ.create 17 in - let rec loop () = - if PQ.is_empty q then raise Not_found; - let (w,v,p) = PQ.pop_maximum q in - if G.V.compare v v2 = 0 then - List.rev p, w - else begin - if not (H.mem visited v) then begin - H.add visited v (); - G.iter_succ_e - (fun e -> PQ.add q (W.add w (W.weight (label e)), dst e, e :: p)) - g v - end; - loop () - end - in - PQ.add q (W.zero, v1, []); - loop () - -end - - - -module Check - (G : - sig - type t - module V : Sig.COMPARABLE - val iter_succ : (V.t -> unit) -> t -> V.t -> unit - end) = -struct - - module HV = Hashtbl.Make(G.V) - module HVV = Hashtbl.Make(Util.HTProduct(G.V)(G.V)) - - (* the cache contains the path tests already computed *) - type path_checker = { cache : bool HVV.t; graph : G.t } - - let create g = { cache = HVV.create 97; graph = g } - - let check_path pc v1 v2 = - try - HVV.find pc.cache (v1, v2) - with Not_found -> - (* the path is not in cache; we check it with Dijkstra *) - let visited = HV.create 97 in - let q = Queue.create () in - let rec loop () = - if Queue.is_empty q then begin - HVV.add pc.cache (v1, v2) false; - false - end else begin - let v = Queue.pop q in - HVV.add pc.cache (v1, v) true; - if G.V.compare v v2 = 0 then - true - else begin - if not (HV.mem visited v) then begin - HV.add visited v (); - G.iter_succ (fun v' -> Queue.add v' q) pc.graph v - end; - loop () - end - end - in - Queue.add v1 q; - loop () - -end diff --git a/external/ocamlgraph/src/gpath.mli b/external/ocamlgraph/src/gpath.mli deleted file mode 100644 --- a/external/ocamlgraph/src/gpath.mli +++ /dev/null @@ -1,96 +0,0 @@ -(**************************************************************************) -(* *) -(* Ocamlgraph: a generic graph library for OCaml *) -(* Copyright (C) 2004-2007 *) -(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) -(* *) -(* This software is free software; you can redistribute it and/or *) -(* modify it under the terms of the GNU Library General Public *) -(* License version 2, with the special exception on linking *) -(* described in file LICENSE. *) -(* *) -(* This software is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) -(* *) -(**************************************************************************) - -(* $Id: path.mli,v 1.9 2005-07-18 07:10:35 filliatr Exp $ *) - -(** Paths *) - -(** Minimal graph signature for Dijkstra's algorithm *) -module type G = sig - type t - module V : Sig.COMPARABLE - module E : sig - type t - type label - val label : t -> label - val dst : t -> V.t - end - val iter_succ_e : (E.t -> unit) -> t -> V.t -> unit -end - -(** Signature for edges' weights *) -module type WEIGHT = sig - type label - type t - val weight : label -> t - val zero : t - val add : t -> t -> t - val compare : t -> t -> int -end - -module Dijkstra - (G: G) - (W: WEIGHT with type label = G.E.label) : -sig - - val shortest_path : G.t -> G.V.t -> G.V.t -> G.E.t list * W.t - (** [shortest_path g v1 v2] computes the shortest path from vertex [v1] - to vertex [v2] in graph [g]. The path is returned as the list of - followed edges, together with the total length of the path. - raise [Not_found] if the path from [v1] to [v2] does not exist. - - Complexity: at most O((V+E)log(V)) *) - -end - - -(** Check for a path *) - -module Check - (G : - sig - type t - module V : Sig.COMPARABLE - val iter_succ : (V.t -> unit) -> t -> V.t -> unit - end) : -sig - - type path_checker - (** the abstract data type of a path checker; this is a mutable data - structure *) - - val create : G.t -> path_checker - (** [create g] builds a new path checker for the graph [g]; - if the graph is mutable, it must not be mutated while this path - checker is in use (through the function [check_path] below). *) - - val check_path : path_checker -> G.V.t -> G.V.t -> bool - (** [check_path pc v1 v2] checks whether there is a path from [v1] to - [v2] in the graph associated to the path checker [pc]. - - Complexity: The path checker contains a cache of all results computed - so far. This cache is implemented with a hash table so access in this - cache is usually O(1). When the result is not in the cache, Dijkstra's - algorithm is run to check for the path, and all intermediate results - are cached. - - Note: if checks are to be done for almost all pairs of vertices, it - may be more efficient to compute the transitive closure of the graph - (see module [Oper]). - *) - -end diff --git a/external/ocamlgraph/src/graphviz.ml b/external/ocamlgraph/src/graphviz.ml deleted file mode 100644 --- a/external/ocamlgraph/src/graphviz.ml +++ /dev/null @@ -1,779 +0,0 @@ -(**************************************************************************) -(* *) -(* Ocamlgraph: a generic graph library for OCaml *) -(* Copyright (C) 2004-2007 *) -(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) -(* *) -(* This software is free software; you can redistribute it and/or *) -(* modify it under the terms of the GNU Library General Public *) -(* License version 2, with the special exception on linking *) -(* described in file LICENSE. *) -(* *) -(* This software is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) -(* *) -(**************************************************************************) - -(* $Id: graphviz.ml,v 1.4 2006-05-09 10:19:37 conchon Exp $ *) - -(** Interface with {i GraphViz} - - This module provides a basic interface with dot and neato, - two programs of the GraphViz toolbox. - These tools are available at the following URLs: - http://www.graphviz.org/ - http://www.research.att.com/sw/tools/graphviz/ - - *) - -open Format - -(***************************************************************************) -(** {2 Common stuff} *) - -(** Because the neato and dot engines present a lot of common points - - in particular in the graph description language, large parts of - the code is shared. First, the [!CommonAttributes] module defines - attributes of graphs, nodes and edges that are understood by the - two engines. Second, given a module (of type [!ENGINE]) - describing an engine the [!MakeEngine] functor provides suitable - interface function for it. *) - -(*-------------------------------------------------------------------------*) -(** {3 Common attributes} *) - -type color = int - -let fprint_color ppf color = - fprintf ppf "\"#%06X\"" color - -let fprint_string ppf s = fprintf ppf "\"%s\"" s -(* let s' = String.escaped s in - if s' = s && s <> "" - then fprintf ppf "%s" s - else fprintf ppf "\"%s\"" s'*) - -let fprint_string_user ppf s = -(* let s = String.escaped s in*) - fprintf ppf "\"%s\"" s - -type arrow_style = - [ `None | `Normal | `Inv | `Dot | `Odot | `Invdot | `Invodot ] - -let fprint_arrow_style ppf = function - `None -> fprintf ppf "none" - | `Normal -> fprintf ppf "normal" - | `Inv -> fprintf ppf "inv" - | `Dot -> fprintf ppf "dot" - | `Odot -> fprintf ppf "odot" - | `Invdot -> fprintf ppf "invdot" - | `Invodot -> fprintf ppf "invodot" - -let fprint_dir ppf = function - `TopToBottom -> fprintf ppf "TB" - | `LeftToRight -> fprintf ppf "LR" - -(** The [ATTRIBUTES] module type defines the interface for the engines. *) -module type ATTRIBUTES = sig - - type graph (** Attributes of graphs. *) - - type vertex (** Attributes of vertices. *) - - type edge (** Attributes of edges. *) - - (** Attributes of (optional) boxes around vertices. *) - type subgraph = { - sg_name : string; (** Box name. *) - sg_attributes : vertex list; (** Box attributes. *) - } - -end - -(** The [CommonAttributes] module defines attributes for graphs, nodes and - edges that are available in the two engines, dot and neato. *) -module CommonAttributes = struct - - (** Attributes of graphs. *) - type graph = - [ `Center of bool - (** Centers the drawing on the page. Default value is [false]. *) - | `Fontcolor of color - (** Sets the font color. Default value is [black]. *) - | `Fontname of string - (** Sets the font family name. Default value is ["Times-Roman"]. *) - | `Fontsize of int - (** Sets the type size (in points). Default value is [14]. *) - | `Label of string - (** Caption for graph drawing. *) - | `Orientation of [ `Portrait | `Landscape ] - (** Sets the page orientation. Default value is [`Portrait]. *) - | `Page of float * float - (** Sets the PostScript pagination unit, e.g [8.5, 11.0]. *) - | `Pagedir of [ `TopToBottom | `LeftToRight ] - (** Traversal order of pages. Default value is [`TopToBottom]. *) - | `Size of float * float - (** Sets the bounding box of drawing (in inches). *) - | `OrderingOut - (** Constrains order of out-edges in a subgraph according to - their file sequence *) - ] - - (** Attributes of nodes. *) - type vertex = - [ `Color of color - (** Sets the color of the border of the node. Default value is [black] - *) - | `Fontcolor of color - (** Sets the label font color. Default value is [black]. *) - | `Fontname of string - (** Sets the label font family name. Default value is - ["Times-Roman"]. *) - | `Fontsize of int - (** Sets the label type size (in points). Default value is [14]. *) - | `Height of float - (** Sets the minimum height. Default value is [0.5]. *) - | `Label of string - (** Sets the label printed in the node. The string may include escaped - newlines [\n], [\l], or [\r] for center, left, and right justified - lines. - Record labels may contain recursive box lists delimited by { | }. - *) - | `Orientation of float - (** Node rotation angle, in degrees. Default value is [0.0]. *) - | `Peripheries of int - (** Sets the number of periphery lines drawn around the polygon. *) - | `Regular of bool - (** If [true], then the polygon is made regular, i.e. symmetric about - the x and y axis, otherwise the polygon takes on the aspect - ratio of the label. Default value is [false]. *) - | `Shape of - [`Ellipse | `Box | `Circle | `Doublecircle | `Diamond - | `Plaintext | `Record | `Polygon of int * float] - (** Sets the shape of the node. Default value is [`Ellipse]. - [`Polygon (i, f)] draws a polygon with [n] sides and a skewing - of [f]. *) - | `Style of [ `Filled | `Solid | `Dashed | `Dotted | `Bold | `Invis ] - (** Sets the layout style of the node. Several styles may be combined - simultaneously. *) - | `Width of float - (** Sets the minimum width. Default value is [0.75]. *) - ] - - (** Attributes of edges. *) - type edge = - [ `Color of color - (** Sets the edge stroke color. Default value is [black]. *) - | `Decorate of bool - (** If [true], draws a line connecting labels with their edges. *) - | `Dir of [ `Forward | `Back | `Both | `None ] - (** Sets arrow direction. Default value is [`Forward]. *) - | `Fontcolor of color - (** Sets the label font color. Default value is [black]. *) - | `Fontname of string - (** Sets the label font family name. Default value is - ["Times-Roman"]. *) - | `Fontsize of int - (** Sets the label type size (in points). Default value is [14]. *) - | `Label of string - (** Sets the label to be attached to the edge. The string may include - escaped newlines [\n], [\l], or [\r] for centered, left, or right - justified lines. *) - | `Labelfontcolor of color - (** Sets the font color for head and tail labels. Default value is - [black]. *) - | `Labelfontname of string - (** Sets the font family name for head and tail labels. Default - value is ["Times-Roman"]. *) - | `Labelfontsize of int - (** Sets the font size for head and tail labels (in points). - Default value is [14]. *) - | `Style of [ `Solid | `Dashed | `Dotted | `Bold | `Invis ] - (** Sets the layout style of the edge. Several styles may be combined - simultaneously. *) - ] - - (** Pretty-print. *) - - let fprint_orientation ppf = function - `Portrait -> fprintf ppf "portrait" - | `Landscape -> fprintf ppf "landscape" - - let fprint_graph ppf = function - `Center b -> fprintf ppf "center=%i" (if b then 1 else 0) - | `Fontcolor a -> fprintf ppf "fontcolor=%a" fprint_color a - | `Fontname s -> fprintf ppf "fontname=%a" fprint_string s - | `Fontsize i -> fprintf ppf "fontsize=%i" i - | `Label s -> fprintf ppf "label=%a" fprint_string_user s - | `Orientation a -> fprintf ppf "orientation=%a" fprint_orientation a - | `Page (x, y) -> fprintf ppf "page=\"%f,%f\"" x y - | `Pagedir a -> fprintf ppf "pagedir=%a" fprint_dir a - | `Size (x, y) -> fprintf ppf "size=\"%f,%f\"" x y - | `OrderingOut -> fprintf ppf "ordering=out" - - let fprint_shape ppf = function - | `Ellipse -> fprintf ppf "ellipse" - | `Box -> fprintf ppf "box" - | `Circle -> fprintf ppf "circle" - | `Doublecircle -> fprintf ppf "doublecircle" - | `Diamond -> fprintf ppf "diamond" - | `Plaintext -> fprintf ppf "plaintext" - | `Record -> fprintf ppf "record" - | `Polygon (i, f) -> fprintf ppf "polygon, sides=%i, skew=%f" i f - - let fprint_node_style ppf = function - `Filled -> fprintf ppf "filled" - | `Solid -> fprintf ppf "solid" - | `Dashed -> fprintf ppf "dashed" - | `Dotted -> fprintf ppf "dotted" - | `Bold -> fprintf ppf "bold" - | `Invis -> fprintf ppf "invis" - - let fprint_vertex ppf = function - `Color a -> fprintf ppf "color=%a" fprint_color a - | `Fontcolor a -> fprintf ppf "fontcolor=%a" fprint_color a - | `Fontname s -> fprintf ppf "fontname=%a" fprint_string s - | `Fontsize i -> fprintf ppf "fontsize=%i" i - | `Height f -> fprintf ppf "height=%f" f - | `Label s -> fprintf ppf "label=%a" fprint_string_user s - | `Orientation f -> fprintf ppf "orientation=%f" f - | `Peripheries i -> fprintf ppf "peripheries=%i" i - | `Regular b -> fprintf ppf "regular=%b" b - | `Shape a -> fprintf ppf "shape=%a" fprint_shape a - | `Style a -> fprintf ppf "style=%a" fprint_node_style a - | `Width f -> fprintf ppf "width=%f" f - - let fprint_edge_style = - fprint_node_style - - let fprint_arrow_direction ppf = function - `Forward -> fprintf ppf "forward" - | `Back -> fprintf ppf "back" - | `Both -> fprintf ppf "both" - | `None -> fprintf ppf "none" - - let fprint_edge ppf = function - `Color a -> fprintf ppf "color=%a" fprint_color a - | `Decorate b -> fprintf ppf "decorate=%b" b - | `Dir a -> fprintf ppf "dir=%a" fprint_arrow_direction a - | `Fontcolor a -> fprintf ppf "fontcolor=%a" fprint_color a - | `Fontname s -> fprintf ppf "fontname=%a" fprint_string s - | `Fontsize i -> fprintf ppf "fontsize=%i" i - | `Label s -> fprintf ppf "label=%a" fprint_string_user s - | `Labelfontcolor a -> fprintf ppf "labelfontcolor=%a" fprint_color a - | `Labelfontname s -> fprintf ppf "labelfontname=\"%s\"" s - (* (String.escaped s) *) - | `Labelfontsize i -> fprintf ppf "labelfontsize=%i" i - | `Style a -> fprintf ppf "style=%a" fprint_edge_style a - -end - - -(*-------------------------------------------------------------------------*) -(** {3 The [MakeEngine] functor} *) - -(** An engine is described by a module of the following signature. *) -module type ENGINE = sig - - module Attributes : sig - include ATTRIBUTES - val fprint_graph:formatter -> graph -> unit - val fprint_vertex: formatter -> vertex -> unit - val fprint_edge: formatter -> edge -> unit - end - - (** The litteral name of the engine. *) - val name: string - - (** The keyword for graphs ("digraph" for dot, "graph" for neato) *) - val opening: string - - (** The litteral for edge arrows ("->" for dot, "--" for neato) *) - val edge_arrow: string - -end - -module type GRAPH = sig - -end - -module MakeEngine - (EN: ENGINE) - (X : sig - type t - module V : sig type t end - module E : sig type t val src : t -> V.t val dst : t -> V.t end - - val iter_vertex : (V.t -> unit) -> t -> unit - val iter_edges_e : (E.t -> unit) -> t -> unit - - val graph_attributes: t -> EN.Attributes.graph list - - val default_vertex_attributes: t -> EN.Attributes.vertex list - val vertex_name : V.t -> string - val vertex_attributes: V.t -> EN.Attributes.vertex list - - val default_edge_attributes: t -> EN.Attributes.edge list - val edge_attributes: E.t -> EN.Attributes.edge list - val get_subgraph : V.t -> EN.Attributes.subgraph option - end) = -struct - - let command = ref EN.name - let set_command cmd = - command := cmd - - exception Error of string - - let handle_error f arg = - try - f arg - with - Error msg -> - Printf.eprintf "%s: %s failure\n %s\n" - Sys.argv.(0) EN.name msg; - flush stderr; - exit 2 - - (** [fprint_graph_attributes ppf list] pretty prints a list of - graph attributes on the formatter [ppf]. Attributes are separated - by a ";". *) - let fprint_graph_attributes ppf list = - List.iter (function att -> - fprintf ppf "%a;@ " EN.Attributes.fprint_graph att - ) list - - (** [fprint_graph_attribute printer ppf list] pretty prints a list of - attributes on the formatter [ppf], using the printer [printer] for - each attribute. The list appears between brackets and attributes - are speparated by ",". If the list is empty, nothing is printed. *) - let fprint_attributes fprint_attribute ppf = function - [] -> () - | hd :: tl -> - let rec fprint_attributes_rec ppf = function - [] -> () - | hd' :: tl' -> - fprintf ppf ",@ %a%a" - fprint_attribute hd' - fprint_attributes_rec tl' - in - fprintf ppf " [@[%a%a@]]" - fprint_attribute hd - fprint_attributes_rec tl - - (** [fprint_graph_attributes ppf list] pretty prints a list of - node attributes using the format of [fprint_attributes]. *) - let fprint_node_attributes ppf list = - fprint_attributes EN.Attributes.fprint_vertex ppf list - - (** [fprint_graph_attributes ppf list] pretty prints a list of - edge attributes using the format of [fprint_attributes]. *) - let fprint_edge_attributes ppf list = - fprint_attributes EN.Attributes.fprint_edge ppf list - - (** [fprint_graph ppf graph] pretty prints the graph [graph] in - the CGL language on the formatter [ppf]. *) - let fprint_graph ppf graph = - let subgraphs = Hashtbl.create 7 in - - (* Printing nodes. *) - - let print_nodes ppf = - - let default_node_attributes = X.default_vertex_attributes graph in - if default_node_attributes <> [] then - fprintf ppf "node%a;@ " - fprint_node_attributes default_node_attributes; - - X.iter_vertex - (function node -> - begin match X.get_subgraph node with - | None -> () - | Some sg -> - try - let (sg,nodes) = - Hashtbl.find subgraphs sg.EN.Attributes.sg_name - in - Hashtbl.replace subgraphs - sg.EN.Attributes.sg_name (sg,node::nodes) - with Not_found -> - Hashtbl.add subgraphs sg.EN.Attributes.sg_name (sg,[node]) - end; - fprintf ppf "%s%a;@ " - (X.vertex_name node) - fprint_node_attributes (X.vertex_attributes node)) - graph - - in - - (* Printing subgraphs *) - - let print_subgraphs ppf = - - Hashtbl.iter - (fun name (sg,nodes) -> - fprintf ppf "@[subgraph cluster_%s { %t%t };@]@\n" - name - - (fun ppf -> - (List.iter - (fun n -> - fprintf ppf "%a;@\n" EN.Attributes.fprint_vertex n) - sg.EN.Attributes.sg_attributes)) - - (fun ppf -> - (List.iter - (fun n -> fprintf ppf "%s;" (X.vertex_name n)) - nodes)) - ) - subgraphs - - in - - (* Printing edges *) - - let print_edges ppf = - - let default_edge_attributes = X.default_edge_attributes graph in - if default_edge_attributes <> [] then - fprintf ppf "edge%a;@ " - fprint_edge_attributes default_edge_attributes; - - X.iter_edges_e (function edge -> - fprintf ppf "%s %s %s%a;@ " - (X.vertex_name (X.E.src edge)) - EN.edge_arrow - (X.vertex_name (X.E.dst edge)) - fprint_edge_attributes (X.edge_attributes edge) - ) graph - - in - - fprintf ppf "@[%s G {@ @[ %a" - EN.opening - fprint_graph_attributes (X.graph_attributes graph); - fprintf ppf "%t@ " print_nodes; - fprintf ppf "%t@ " print_subgraphs; - fprintf ppf "%t@ " print_edges; - fprintf ppf "@]}@]" - - (** [output_graph oc graph] pretty prints the graph [graph] in the dot - language on the channel [oc]. *) - let output_graph oc graph = - - let ppf = formatter_of_out_channel oc in - fprint_graph ppf graph; - pp_print_flush ppf () - - end - -(***************************************************************************) -(** {2 Interface with the dot engine} *) - -(** The [DotAttributes] module defines attributes for graphs, nodes and edges - that are available in the dot engine. *) -module DotAttributes = struct - - (** Attributes of graphs. They include all common graph attributes and - several specific ones. All attributes described in the "dot User's - Manual, February 4, 2002" are handled, excepted: clusterank, color, - compound, labeljust, labelloc, ordering, rank, remincross, rotate, - searchsize and style. - *) - type graph = - [ CommonAttributes.graph - | `Bgcolor of color - (** Sets the background color and the inital fill color. *) - | `Comment of string - (** Comment string. *) - | `Concentrate of bool - (** If [true], enables edge concentrators. Default value is [false]. *) - | `Fontpath of string - (** List of directories for fonts. *) - | `Layers of string list - (** List of layers. *) - | `Margin of float - (** Sets the page margin (included in the page size). Default value is - [0.5]. *) - | `Mclimit of float - (** Scale factor for mincross iterations. Default value is [1.0]. *) - | `Nodesep of float - (** Sets the minimum separation between nodes, in inches. Default - value is [0.25]. *) - | `Nslimit of int - (** If set of [f], bounds network simplex iterations by [f * - ] when ranking nodes. *) - | `Nslimit1 of int - (** If set of [f], bounds network simplex iterations by [f * - ] when setting x-coordinates. *) - | `Ranksep of float - (** Sets the minimum separation between ranks. *) - | `Quantum of float - (** If not [0.0], node label dimensions will be rounded to integral - multiples of it. Default value is [0.0]. *) - | `Rankdir of [ `TopToBottom | `LeftToRight ] - (** Direction of rank ordering. Default value is [`TopToBottom]. *) - | `Ratio of [ `Float of float | `Fill | `Compress| `Auto ] - (** Sets the aspect ratio. *) - | `Samplepoints of int - (** Number of points used to represent ellipses and circles on output. - Default value is [8]. *) - | `Url of string - (** URL associated with graph (format-dependent). *) - ] - - (** Attributes of nodes. They include all common node attributes and - several specific ones. All attributes described in the "dot User's - Manual, February 4, 2002" are handled, excepted: bottomlabel, group, - shapefile and toplabel. - *) - type vertex = - [ CommonAttributes.vertex - | `Comment of string - (** Comment string. *) - | `Distortion of float - (* TEMPORARY *) - | `Fillcolor of color - (** Sets the fill color (used when `Style filled). Default value - is [lightgrey]. *) - | `Fixedsize of bool - (** If [true], forces the given dimensions to be the actual ones. - Default value is [false]. *) - | `Layer of string - (** Overlay. *) - | `Url of string - (** The default url for image map files; in PostScript files, - the base URL for all relative URLs, as recognized by Acrobat - Distiller 3.0 and up. *) - | `Z of float - (** z coordinate for VRML output. *) - ] - - (** Attributes of edges. They include all common edge attributes and - several specific ones. All attributes described in the "dot User's - Manual, February 4, 2002" are handled, excepted: lhead and ltail. - *) - type edge = - [ CommonAttributes.edge - | `Arrowhead of arrow_style - (** Sets the style of the head arrow. Default value is [`Normal]. *) - | `Arrowsize of float - (** Sets the scaling factor of arrowheads. Default value is [1.0]. *) - | `Arrowtail of arrow_style - (** Sets the style of the tail arrow. Default value is [`Normal]. *) - | `Comment of string - (** Comment string. *) - | `Constraints of bool - (** If [false], causes an edge to be ignored for rank assignment. - Default value is [true]. *) - | `Headlabel of string - (** Sets the label attached to the head arrow. *) - | `Headport of [ `N | `NE | `E | `SE | `S | `SW | `W | `NW ] - (* TEMPORARY *) - | `Headurl of string - (** Url attached to head label if output format is ismap. *) - | `Labelangle of float - (** Angle in degrees which head or tail label is rotated off edge. - Default value is [-25.0]. *) - | `Labeldistance of float - (** Scaling factor for distance of head or tail label from node. - Default value is [1.0]. *) - | `Labelfloat of bool - (** If [true], lessen constraints on edge label placement. - Default value is [false]. *) - | `Layer of string - (** Overlay. *) - | `Minlen of int - (** Minimum rank distance between head an tail. Default value is [1]. *) - | `Samehead of string - (** Tag for head node; edge heads with the same tag are merged onto the - same port. *) - | `Sametail of string - (** Tag for tail node; edge tails with the same tag are merged onto the - same port. *) - | `Taillabel of string - (** Sets the label attached to the tail arrow. *) - | `Tailport of [ `N | `NE | `E | `SE | `S | `SW | `W | `NW ] - (* TEMPORARY *) - | `Tailurl of string - (** Url attached to tail label if output format is ismap. *) - | `Weight of int - (** Sets the integer cost of stretching the edge. Default value is - [1]. *) - ] - - type subgraph = { - sg_name : string; - sg_attributes : vertex list; - } - - (** {4 Pretty-print of attributes} *) - - let rec fprint_string_list ppf = function - [] -> () - | [hd] -> fprintf ppf "%s" hd - | hd :: tl -> fprintf ppf "%s,%a" hd fprint_string_list tl - - let fprint_ratio ppf = function - `Float f -> fprintf ppf "%f" f - | `Fill -> fprintf ppf "fill" - | `Compress -> fprintf ppf "compress" - | `Auto -> fprintf ppf "auto" - - let fprint_graph ppf = function - #CommonAttributes.graph as att -> CommonAttributes.fprint_graph ppf att - | `Bgcolor a -> fprintf ppf "bgcolor=%a" fprint_color a - | `Comment s -> fprintf ppf "comment=%a" fprint_string s - | `Concentrate b -> fprintf ppf "concentrate=%b" b - | `Fontpath s -> fprintf ppf "fontpath=%a" fprint_string s - | `Layers s -> fprintf ppf "layers=%a" fprint_string_list s - | `Margin f -> fprintf ppf "margin=%f" f - | `Mclimit f -> fprintf ppf "mclimit=%f" f - | `Nodesep f -> fprintf ppf "nodesep=%f" f - | `Nslimit i -> fprintf ppf "nslimit=%i" i - | `Nslimit1 i -> fprintf ppf "nslimit1=%i" i - | `Ranksep f -> fprintf ppf "ranksep=%f" f - | `Quantum f -> fprintf ppf "quantum=%f" f - | `Rankdir a -> fprintf ppf "rankdir=%a" fprint_dir a - | `Ratio a -> fprintf ppf "ratio=%a" fprint_ratio a - | `Samplepoints i -> fprintf ppf "samplepoints=%i" i - | `Url s -> fprintf ppf "URL=\"%s\"" s (*(String.escaped s)*) - - let fprint_vertex ppf = function - #CommonAttributes.vertex as att -> - CommonAttributes.fprint_vertex ppf att - | `Comment s -> fprintf ppf "comment=%a" fprint_string s - | `Distortion f -> fprintf ppf "distortion=%f" f - | `Fillcolor a -> fprintf ppf "fillcolor=%a" fprint_color a - | `Fixedsize b -> fprintf ppf "fixedsize=%b" b - | `Layer s -> fprintf ppf "layer=%a" fprint_string s - | `Url s -> fprintf ppf "URL=\"%s\"" s (*(String.escaped s)*) - | `Z f -> fprintf ppf "z=%f" f - - let fprint_port ppf = function - `N -> fprintf ppf "n" - | `NE -> fprintf ppf "ne" - | `E -> fprintf ppf "e" - | `SE -> fprintf ppf "se" - | `S -> fprintf ppf "s" - | `SW -> fprintf ppf "sw" - | `W -> fprintf ppf "w" - | `NW -> fprintf ppf "nw" - - let fprint_edge ppf = function - #CommonAttributes.edge as att -> CommonAttributes.fprint_edge ppf att - | `Arrowhead a -> fprintf ppf "arrowhead=%a" fprint_arrow_style a - | `Arrowsize f -> fprintf ppf "arrowsize=%f" f - | `Arrowtail a -> fprintf ppf "arrowtail=%a" fprint_arrow_style a - | `Comment s -> fprintf ppf "comment=%a" fprint_string s - | `Constraints b -> fprintf ppf "constraints=%b" b - | `Headlabel s -> fprintf ppf "headlabel=%a" fprint_string s - | `Headport a -> fprintf ppf "headport=%a" fprint_port a - | `Headurl s -> fprintf ppf "headURL=%a" fprint_string s - | `Labelangle f -> fprintf ppf "labelangle=%f" f - | `Labeldistance f -> fprintf ppf "labeldistance=%f" f - | `Labelfloat b -> fprintf ppf "labelfloat=%b" b - | `Layer s -> fprintf ppf "layer=%a" fprint_string s - | `Minlen i -> fprintf ppf "minlen=%i" i - | `Samehead s -> fprintf ppf "samehead=%a" fprint_string s - | `Sametail s -> fprintf ppf "sametail=%a" fprint_string s - | `Taillabel s -> fprintf ppf "taillabel=%a" fprint_string s - | `Tailport a -> fprintf ppf "tailport=%a" fprint_port a - | `Tailurl s -> fprintf ppf "tailURL=%a" fprint_string s - | `Weight i -> fprintf ppf "weight=%i" i - -end - -module Dot = - MakeEngine (struct - module Attributes = DotAttributes - let name = "dot" - let opening = "digraph" - let edge_arrow = "->" - end) - -(***************************************************************************) -(** {2 Interface with the neato engine} *) - -(** The [NeatoAttributes] module defines attributes for graphs, nodes and edges - that are available in the neato engine. *) -module NeatoAttributes = struct - - (** Attributes of graphs. They include all common graph attributes and - several specific ones. All attributes described in the "Neato User's - manual, April 10, 2002" are handled. *) - type graph = - [ CommonAttributes.graph - | `Margin of float * float - (** Sets the page margin (included in the page size). Default value is - [0.5, 0.5]. *) - | `Start of int - (** Seed for random number generator. *) - | `Overlap of bool - (** Default value is [true]. *) - | `Spline of bool - (** [true] makes edge splines if nodes don't overlap. - Default value is [false]. *) - | `Sep of float - (** Edge spline separation factor from nodes. Default value - is [0.0]. *) - ] - - (** Attributes of nodes. They include all common node attributes and - several specific ones. All attributes described in the "Neato User's - manual, April 10, 2002" are handled. *) - type vertex = - [ CommonAttributes.vertex - | `Pos of float * float - (** Initial coordinates of the node. *) - ] - - (** Attributes of edges. They include all common edge attributes and - several specific ones. All attributes described in the "Neato User's - manual, April 10, 2002" are handled. *) - type edge = - [ CommonAttributes.edge - | `Id of string - (** Optional value to distinguish multiple edges. *) - | `Len of float - (** Preferred length of edge. Default value is [1.0]. *) - | `Weight of float - (** Strength of edge spring. Default value is [1.0]. *) - ] - - type subgraph = { - sg_name : string; - sg_attributes : vertex list; - } - - (** {4 Pretty-print of attributes} *) - - let fprint_graph ppf = function - #CommonAttributes.graph as att -> CommonAttributes.fprint_graph ppf att - | `Margin (f1, f2) -> fprintf ppf "margin=\"%f,%f\"" f1 f2 - | `Start i -> fprintf ppf "start=%i" i - | `Overlap b -> fprintf ppf "overlap=%b" b - | `Spline b -> fprintf ppf "spline=%b" b - | `Sep f -> fprintf ppf "sep=%f" f - - let fprint_vertex ppf = function - #CommonAttributes.vertex as att -> - CommonAttributes.fprint_vertex ppf att - | `Pos (f1, f2) -> fprintf ppf "pos=\"%f,%f\"" f1 f2 - - let fprint_edge ppf = function - #CommonAttributes.edge as att -> CommonAttributes.fprint_edge ppf att - | `Id s -> fprintf ppf "id=%a" fprint_string s - | `Len f -> fprintf ppf "len=%f" f - | `Weight f -> fprintf ppf "weight=%f" f - -end - -module Neato = - MakeEngine (struct - module Attributes = NeatoAttributes - let name = "neato" - let opening = "graph" - let edge_arrow = "--" - end) diff --git a/external/ocamlgraph/src/graphviz.mli b/external/ocamlgraph/src/graphviz.mli deleted file mode 100644 --- a/external/ocamlgraph/src/graphviz.mli +++ /dev/null @@ -1,469 +0,0 @@ -(**************************************************************************) -(* *) -(* Ocamlgraph: a generic graph library for OCaml *) -(* Copyright (C) 2004-2007 *) -(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) -(* *) -(* This software is free software; you can redistribute it and/or *) -(* modify it under the terms of the GNU Library General Public *) -(* License version 2, with the special exception on linking *) -(* described in file LICENSE. *) -(* *) -(* This software is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) -(* *) -(**************************************************************************) - -(* $Id: graphviz.mli,v 1.4 2005-01-18 09:17:49 filliatr Exp $ *) - -(** Interface with {i GraphViz} - - This module provides a basic interface with dot and neato, - two programs of the GraphViz toolbox. - These tools are available at the following URLs: - - {v http://www.graphviz.org/ v} - - {v http://www.research.att.com/sw/tools/graphviz/ v} - - *) - -open Format - -(***************************************************************************) -(** {2 Common stuff} *) - -(** Because the neato and dot engines present a lot of common points - - in particular in the graph description language, large parts of - the code is shared. The [CommonAttributes] module defines - attributes of graphs, vertices and edges that are understood by the - two engines. Then module [DotAttributes] and [NeatoAttributes] - define attributes specific to dot and neato respectively. *) - -(*-------------------------------------------------------------------------*) -(** {3 Common types and signatures} *) - -type color = int - -type arrow_style = - [ `None | `Normal | `Inv | `Dot | `Odot | `Invdot | `Invodot ] - -(** The [ATTRIBUTES] module type defines the interface for the engines. *) -module type ATTRIBUTES = sig - - type graph (** Attributes of graphs. *) - - type vertex (** Attributes of vertices. *) - - type edge (** Attributes of edges. *) - - (** Attributes of (optional) boxes around vertices. *) - type subgraph = { - sg_name : string; (** Box name. *) - sg_attributes : vertex list; (** Box attributes. *) - } - -end - -(*-------------------------------------------------------------------------*) -(** {3 Common attributes} *) - -(** The [CommonAttributes] module defines attributes for graphs, vertices and - edges that are available in the two engines, dot and neato. *) -module CommonAttributes : sig - - (** Attributes of graphs. *) - type graph = - [ `Center of bool - (** Centers the drawing on the page. Default value is [false]. *) - | `Fontcolor of color - (** Sets the font color. Default value is [black]. *) - | `Fontname of string - (** Sets the font family name. Default value is ["Times-Roman"]. *) - | `Fontsize of int - (** Sets the type size (in points). Default value is [14]. *) - | `Label of string - (** Caption for graph drawing. *) - | `Orientation of [ `Portrait | `Landscape ] - (** Sets the page orientation. Default value is [`Portrait]. *) - | `Page of float * float - (** Sets the PostScript pagination unit, e.g [8.5, 11.0]. *) - | `Pagedir of [ `TopToBottom | `LeftToRight ] - (** Traversal order of pages. Default value is [`TopToBottom]. *) - | `Size of float * float - (** Sets the bounding box of drawing (in inches). *) - | `OrderingOut - (** Constrains order of out-edges in a subgraph according to - their file sequence *) - ] - - (** Attributes of vertices. - *) - type vertex = - [ `Color of color - (** Sets the color of the border of the vertex. - Default value is [black] *) - | `Fontcolor of color - (** Sets the label font color. Default value is [black]. *) - | `Fontname of string - (** Sets the label font family name. Default value is - ["Times-Roman"]. *) - | `Fontsize of int - (** Sets the label type size (in points). Default value is [14]. - *) - | `Height of float - (** Sets the minimum height. Default value is [0.5]. *) - | `Label of string - (** Sets the label printed in the vertex. - The string may include escaped - newlines [\n], [\l], or [\r] for center, left, and right justified - lines. - Record labels may contain recursive box lists delimited by { | }. - *) - | `Orientation of float - (** Vertex rotation angle, in degrees. Default value is [0.0]. *) - | `Peripheries of int - (** Sets the number of periphery lines drawn around the polygon. *) - | `Regular of bool - (** If [true], then the polygon is made regular, i.e. symmetric about - the x and y axis, otherwise the polygon takes on the aspect - ratio of the label. Default value is [false]. *) - | `Shape of - [`Ellipse | `Box | `Circle | `Doublecircle | `Diamond - | `Plaintext | `Record | `Polygon of int * float] - (** Sets the shape of the vertex. Default value is [`Ellipse]. - [`Polygon (i, f)] draws a polygon with [n] sides and a skewing - of [f]. *) - | `Style of [ `Filled | `Solid | `Dashed | `Dotted | `Bold | `Invis ] - (** Sets the layout style of the vertex. - Several styles may be combined simultaneously. *) - | `Width of float - (** Sets the minimum width. Default value is [0.75]. *) - ] - - (** Attributes of edges. - *) - type edge = - [ `Color of color - (** Sets the edge stroke color. Default value is [black]. *) - | `Decorate of bool - (** If [true], draws a line connecting labels with their edges. *) - | `Dir of [ `Forward | `Back | `Both | `None ] - (** Sets arrow direction. Default value is [`Forward]. *) - | `Fontcolor of color - (** Sets the label font color. Default value is [black]. *) - | `Fontname of string - (** Sets the label font family name. Default value is - ["Times-Roman"]. *) - | `Fontsize of int - (** Sets the label type size (in points). Default value is [14]. *) - | `Label of string - (** Sets the label to be attached to the edge. The string may include - escaped newlines [\n], [\l], or [\r] for centered, left, or right - justified lines. *) - | `Labelfontcolor of color - (** Sets the font color for head and tail labels. Default value is - [black]. *) - | `Labelfontname of string - (** Sets the font family name for head and tail labels. Default - value is ["Times-Roman"]. *) - | `Labelfontsize of int - (** Sets the font size for head and tail labels (in points). - Default value is [14]. *) - | `Style of [ `Solid | `Dashed | `Dotted | `Bold | `Invis ] - (** Sets the layout style of the edge. Several styles may be combined - simultaneously. *) - ] - -end - -(***************************************************************************) -(** {2 Interface with the dot engine} *) - -(** [DotAttributes] extends [CommonAttributes] and implements [ATTRIBUTES]. *) -module DotAttributes : sig - - (** Attributes of graphs. They include all common graph attributes and - several specific ones. All attributes described in the "dot User's - Manual, February 4, 2002" are handled, excepted: clusterank, color, - compound, labeljust, labelloc, ordering, rank, remincross, rotate, - searchsize and style. - *) - type graph = - [ CommonAttributes.graph - | `Bgcolor of color - (** Sets the background color and the inital fill color. *) - | `Comment of string - (** Comment string. *) - | `Concentrate of bool - (** If [true], enables edge concentrators. Default value is [false]. *) - | `Fontpath of string - (** List of directories for fonts. *) - | `Layers of string list - (** List of layers. *) - | `Margin of float - (** Sets the page margin (included in the page size). Default value is - [0.5]. *) - | `Mclimit of float - (** Scale factor for mincross iterations. Default value is [1.0]. *) - | `Nodesep of float - (** Sets the minimum separation between nodes, in inches. Default - value is [0.25]. *) - | `Nslimit of int - (** If set of [f], bounds network simplex iterations by [f * - ] when ranking nodes. *) - | `Nslimit1 of int - (** If set of [f], bounds network simplex iterations by [f * - ] when setting x-coordinates. *) - | `Ranksep of float - (** Sets the minimum separation between ranks. *) - | `Quantum of float - (** If not [0.0], node label dimensions will be rounded to integral - multiples of it. Default value is [0.0]. *) - | `Rankdir of [ `TopToBottom | `LeftToRight ] - (** Direction of rank ordering. Default value is [`TopToBottom]. *) - | `Ratio of [ `Float of float | `Fill | `Compress| `Auto ] - (** Sets the aspect ratio. *) - | `Samplepoints of int - (** Number of points used to represent ellipses and circles on output. - Default value is [8]. *) - | `Url of string - (** URL associated with graph (format-dependent). *) - ] - - (** Attributes of nodes. They include all common node attributes and - several specific ones. All attributes described in the "dot User's - Manual, February 4, 2002" are handled, excepted: bottomlabel, group, - shapefile and toplabel. - *) - type vertex = - [ CommonAttributes.vertex - | `Comment of string - (** Comment string. *) - | `Distortion of float - (* TEMPORARY *) - | `Fillcolor of color - (** Sets the fill color (used when `Style filled). Default value - is [lightgrey]. *) - | `Fixedsize of bool - (** If [true], forces the given dimensions to be the actual ones. - Default value is [false]. *) - | `Layer of string - (** Overlay. *) - | `Url of string - (** The default url for image map files; in PostScript files, - the base URL for all relative URLs, as recognized by Acrobat - Distiller 3.0 and up. *) - | `Z of float - (** z coordinate for VRML output. *) - ] - - (** Attributes of edges. They include all common edge attributes and - several specific ones. All attributes described in the "dot User's - Manual, February 4, 2002" are handled, excepted: lhead and ltail. - *) - type edge = - [ CommonAttributes.edge - | `Arrowhead of arrow_style - (** Sets the style of the head arrow. Default value is [`Normal]. *) - | `Arrowsize of float - (** Sets the scaling factor of arrowheads. Default value is [1.0]. *) - | `Arrowtail of arrow_style - (** Sets the style of the tail arrow. Default value is [`Normal]. *) - | `Comment of string - (** Comment string. *) - | `Constraints of bool - (** If [false], causes an edge to be ignored for rank assignment. - Default value is [true]. *) - | `Headlabel of string - (** Sets the label attached to the head arrow. *) - | `Headport of [ `N | `NE | `E | `SE | `S | `SW | `W | `NW ] - (* TEMPORARY *) - | `Headurl of string - (** Url attached to head label if output format is ismap. *) - | `Labelangle of float - (** Angle in degrees which head or tail label is rotated off edge. - Default value is [-25.0]. *) - | `Labeldistance of float - (** Scaling factor for distance of head or tail label from node. - Default value is [1.0]. *) - | `Labelfloat of bool - (** If [true], lessen constraints on edge label placement. - Default value is [false]. *) - | `Layer of string - (** Overlay. *) - | `Minlen of int - (** Minimum rank distance between head an tail. - Default value is [1]. *) - | `Samehead of string - (** Tag for head node; edge heads with the same tag are merged onto the - same port. *) - | `Sametail of string - (** Tag for tail node; edge tails with the same tag are merged onto the - same port. *) - | `Taillabel of string - (** Sets the label attached to the tail arrow. *) - | `Tailport of [ `N | `NE | `E | `SE | `S | `SW | `W | `NW ] - (* TEMPORARY *) - | `Tailurl of string - (** Url attached to tail label if output format is ismap. *) - | `Weight of int - (** Sets the integer cost of stretching the edge. Default value is - [1]. *) - ] - - type subgraph = { - sg_name : string; - sg_attributes : vertex list; - } - -end - -module Dot - (X : sig - - (** Graph implementation. *) - - type t - module V : sig type t end - module E : sig type t val src : t -> V.t val dst : t -> V.t end - - val iter_vertex : (V.t -> unit) -> t -> unit - val iter_edges_e : (E.t -> unit) -> t -> unit - - (** Graph, vertex and edge attributes. *) - - val graph_attributes: t -> DotAttributes.graph list - - val default_vertex_attributes: t -> DotAttributes.vertex list - val vertex_name : V.t -> string - val vertex_attributes: V.t -> DotAttributes.vertex list - - val get_subgraph : V.t -> DotAttributes.subgraph option - (** The box (if exists) which the vertex belongs to. Boxes with same - names are not distinguished and so they should have the same - attributes. *) - - val default_edge_attributes: t -> DotAttributes.edge list - val edge_attributes: E.t -> DotAttributes.edge list - - end) : -sig - - (** [fprint_graph ppf graph] pretty prints the graph [graph] in - the CGL language on the formatter [ppf]. *) - val fprint_graph: formatter -> X.t -> unit - - (** [output_graph oc graph] pretty prints the graph [graph] in the dot - language on the channel [oc]. *) - val output_graph: out_channel -> X.t -> unit - -end - -(***************************************************************************) -(** {2 The neato engine} *) - -module NeatoAttributes : sig - - (** Attributes of graphs. They include all common graph attributes and - several specific ones. All attributes described in the "Neato User's - manual, April 10, 2002" are handled. - *) - type graph = - [ CommonAttributes.graph - | `Margin of float * float - (** Sets the page margin (included in the page size). Default value is - [0.5, 0.5]. *) - | `Start of int - (** Seed for random number generator. *) - | `Overlap of bool - (** Default value is [true]. *) - | `Spline of bool - (** [true] makes edge splines if nodes don't overlap. - Default value is [false]. *) - | `Sep of float - (** Edge spline separation factor from nodes. Default value - is [0.0]. *) - ] - - (** Attributes of nodes. They include all common node attributes and - several specific ones. All attributes described in the "Neato User's - manual, April 10, 2002" are handled. - *) - type vertex = - [ CommonAttributes.vertex - | `Pos of float * float - (** Initial coordinates of the vertex. *) - ] - - (** Attributes of edges. They include all common edge attributes and - several specific ones. All attributes described in the "Neato User's - manual, April 10, 2002" are handled. - *) - type edge = - [ CommonAttributes.edge - | `Id of string - (** Optional value to distinguish multiple edges. *) - | `Len of float - (** Preferred length of edge. Default value is [1.0]. *) - | `Weight of float - (** Strength of edge spring. Default value is [1.0]. *) - ] - - type subgraph = { - sg_name : string; - sg_attributes : vertex list; - } - -end - -module Neato - (X : sig - - (** Graph implementation. *) - - type t - module V : sig type t end - module E : sig type t val src : t -> V.t val dst : t -> V.t end - - val iter_vertex : (V.t -> unit) -> t -> unit - val iter_edges_e : (E.t -> unit) -> t -> unit - - (** Graph, vertex and edge attributes. *) - - val graph_attributes: t -> NeatoAttributes.graph list - - val default_vertex_attributes: t -> NeatoAttributes.vertex list - val vertex_name : V.t -> string - val vertex_attributes: V.t -> NeatoAttributes.vertex list - - val get_subgraph : V.t -> NeatoAttributes.subgraph option - (** The box (if exists) which the vertex belongs to. Boxes with same - names are not distinguished and so they should have the same - attributes. *) - - val default_edge_attributes: t -> NeatoAttributes.edge list - val edge_attributes: E.t -> NeatoAttributes.edge list - - end) : -sig - - (** Several functions provided by this module run the external program - {i neato}. By default, this command is supposed to be in the default - path and is invoked by {i neato}. The function - [set_command] allows to set an alternative path at run time. *) - val set_command: string -> unit - - exception Error of string - val handle_error: ('a -> 'b) -> 'a -> 'b - - (** [fprint_graph ppf graph] pretty prints the graph [graph] in - the CGL language on the formatter [ppf]. *) - val fprint_graph: formatter -> X.t -> unit - - (** [output_graph oc graph] pretty prints the graph [graph] in the dot - language on the channel [oc]. *) - val output_graph: out_channel -> X.t -> unit - -end diff --git a/external/ocamlgraph/src/imperative.ml b/external/ocamlgraph/src/imperative.ml deleted file mode 100644 --- a/external/ocamlgraph/src/imperative.ml +++ /dev/null @@ -1,618 +0,0 @@ -(**************************************************************************) -(* *) -(* Ocamlgraph: a generic graph library for OCaml *) -(* Copyright (C) 2004-2007 *) -(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) -(* *) -(* This software is free software; you can redistribute it and/or *) -(* modify it under the terms of the GNU Library General Public *) -(* License version 2, with the special exception on linking *) -(* described in file LICENSE. *) -(* *) -(* This software is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) -(* *) -(**************************************************************************) - -(* $Id: imperative.ml,v 1.27 2006-05-12 14:07:16 filliatr Exp $ *) - -open Sig -open Blocks - -module type S = sig - - (** Imperative Unlabeled Graphs *) - module Concrete (V: COMPARABLE) : - Sig.I with type V.t = V.t and type V.label = V.t and type E.t = V.t * V.t - - (** Abstract Imperative Unlabeled Graphs *) - module Abstract(V: sig type t end) : - Sig.IM with type V.label = V.t and type E.label = unit - - (** Imperative Labeled Graphs *) - module ConcreteLabeled (V: COMPARABLE)(E: ORDERED_TYPE_DFT) : - Sig.I with type V.t = V.t and type V.label = V.t - and type E.t = V.t * E.t * V.t and type E.label = E.t - - (** Abstract Imperative Labeled Graphs *) - module AbstractLabeled (V: sig type t end)(E: ORDERED_TYPE_DFT) : - Sig.IM with type V.label = V.t and type E.label = E.t - -end - -module I = Make(Make_Hashtbl) - -type 'a abstract_vertex = { tag : int; label : 'a; mutable mark : int } - -(* Implement the module [Mark]. *) -module Make_Mark - (X: sig - type graph - type label - val iter_vertex : (label abstract_vertex -> unit) -> graph -> unit - end) = -struct - type vertex = X.label abstract_vertex - type graph = X.graph - let get v = v.mark - let set v m = v.mark <- m - let clear g = X.iter_vertex (fun v -> set v 0) g -end - -(* Vertex for the abstract imperative graphs. *) -module AbstractVertex(V: sig type t end) = struct - - type label = V.t - type t = label abstract_vertex - - let compare x y = compare x.tag y.tag - let hash x = Hashtbl.hash x.tag - let equal x y = x.tag = y.tag - let label x = x.label - - let create l = - assert (!cpt_vertex < max_int); - incr cpt_vertex; - { tag = !cpt_vertex; label = l; mark = 0 } - -end - -module Digraph = struct - - module Concrete (V: COMPARABLE) = struct - - include I.Digraph.Concrete(V) - - let create ?(size=997) () = create size - - let add_vertex g v = ignore (add_vertex g v) - let remove_vertex g v = ignore (remove_vertex g v) - let remove_edge g v1 v2 = ignore (remove_edge g v1 v2) - let remove_edge_e g e = ignore (remove_edge_e g e) - - let add_edge g v1 v2 = - add_vertex g v1; - add_vertex g v2; - ignore (unsafe_add_edge g v1 v2) - - let add_edge_e g (v1, v2) = add_edge g v1 v2 - - let copy = HM.copy - - end - - module ConcreteBidirectional (V: COMPARABLE) = struct - - include I.Digraph.ConcreteBidirectional(V) - - let create ?(size=997) () = create size - - let add_vertex g v = - if not (HM.mem v g) then ignore (unsafe_add_vertex g v) - - let add_edge g v1 v2 = - add_vertex g v1; - add_vertex g v2; - ignore (unsafe_add_edge g v1 v2) - - let add_edge_e g (v1, v2) = add_edge g v1 v2 - - let remove_vertex g v = - if HM.mem v g then begin - iter_pred_e (fun e -> ignore (remove_edge_e g e)) g v; - iter_succ_e (fun e -> ignore (remove_edge_e g e)) g v; - ignore (HM.remove v g) - end - - let copy = HM.copy - - let remove_edge g v1 v2 = ignore (remove_edge g v1 v2) - let remove_edge_e g e = ignore (remove_edge_e g e) - - end - - module ConcreteLabeled(V: COMPARABLE)(E: ORDERED_TYPE_DFT) = struct - - let default = E.default - - include I.Digraph.ConcreteLabeled(V)(E) - - let create ?(size=997) () = create size - - let add_vertex g v = ignore (add_vertex g v) - let remove_edge g v1 v2 = ignore (remove_edge g v1 v2) - let remove_edge_e g e = ignore (remove_edge_e g e) - - let add_edge_e g (v1, l, v2) = - add_vertex g v1; - add_vertex g v2; - ignore (unsafe_add_edge g v1 (v2, l)) - - let add_edge g v1 v2 = add_edge_e g (v1, default, v2) - - let remove_vertex g v = - if HM.mem v g then - let remove s = - S.fold - (fun (v2, _ as e) s -> if not (V.equal v v2) then S.add e s else s) - s S.empty - in - ignore (HM.remove v g); - HM.iter (fun k s -> ignore (HM.add k (remove s) g)) g - - let copy = HM.copy - - end - - module Abstract(V: sig type t end) = struct - - include I.Digraph.Abstract(AbstractVertex(V)) - - let create ?(size=997) () = { edges = G.create size; size = 0 } - - let add_vertex g v = - if not (HM.mem v g.edges) then begin - g.size <- Pervasives.succ g.size; - ignore (G.unsafe_add_vertex g.edges v) - end - - let add_edge g v1 v2 = - add_vertex g v1; - add_vertex g v2; - ignore (unsafe_add_edge g.edges v1 v2) - - let add_edge_e g (v1, v2) = add_edge g v1 v2 - - let remove_vertex g v = - if HM.mem v g.edges then - let e = g.edges in - ignore (HM.remove v e); - HM.iter (fun k s -> ignore (HM.add k (S.remove v s) e)) e; - g.size <- Pervasives.pred g.size - - module Mark = Make_Mark(struct - type graph = t - type label = V.label - let iter_vertex = iter_vertex - end) - - let copy g = - let h = HM.create 997 in - let vertex v = - try - HM.find v h - with Not_found -> - let v' = V.create (V.label v) in - ignore (HM.add v v' h); - v' - in - map_vertex vertex g - - let remove_edge g v1 v2 = ignore (remove_edge g v1 v2) - let remove_edge_e g e = ignore (remove_edge_e g e) - - end - - module AbstractLabeled(V: sig type t end)(Edge: ORDERED_TYPE_DFT) = struct - - include I.Digraph.AbstractLabeled(AbstractVertex(V))(Edge) - - let create ?(size=997) () = { edges = G.create size; size = 0 } - - let add_vertex g v = - if not (HM.mem v g.edges) then begin - g.size <- Pervasives.succ g.size; - ignore (G.unsafe_add_vertex g.edges v) - end - - let add_edge_e g (v1, l, v2) = - add_vertex g v1; - add_vertex g v2; - ignore (unsafe_add_edge g.edges v1 (v2, l)) - - let add_edge g v1 v2 = add_edge_e g (v1, Edge.default, v2) - - let remove_vertex g v = - if HM.mem v g.edges then - let remove s = - S.fold - (fun (v2, _ as e) s -> if not (V.equal v v2) then S.add e s else s) - s S.empty - in - let e = g.edges in - ignore (HM.remove v e); - HM.iter (fun k s -> ignore (HM.add k (remove s) e)) e; - g.size <- Pervasives.pred g.size - - module Mark = Make_Mark(struct - type graph = t - type label = V.label - let iter_vertex = iter_vertex - end) - - let copy g = - let h = HM.create 997 in - let vertex v = - try - HM.find v h - with Not_found -> - let v' = V.create (V.label v) in - ignore (HM.add v v' h); - v' - in - map_vertex vertex g - - let remove_edge g v1 v2 = ignore (remove_edge g v1 v2) - let remove_edge_e g e = ignore (remove_edge_e g e) - - end - -end - -module Graph = struct - - module Concrete(V: COMPARABLE) = struct - - module G = Digraph.Concrete(V) - - include Graph(G) - - (* Export some definitions of [G] *) - - let create = G.create - let copy = G.copy - let add_vertex = G.add_vertex - let remove_vertex = G.remove_vertex - - (* Redefine the [add_edge] and [remove_edge] operations *) - - let add_edge g v1 v2 = - G.add_edge g v1 v2; - assert (G.HM.mem v1 g && G.HM.mem v2 g); - ignore (G.unsafe_add_edge g v2 v1) - - let add_edge_e g (v1, v2) = add_edge g v1 v2 - - let remove_edge g v1 v2 = - G.remove_edge g v1 v2; - assert (G.HM.mem v1 g && G.HM.mem v2 g); - ignore (G.unsafe_remove_edge g v2 v1) - - let remove_edge_e g (v1, v2) = remove_edge g v1 v2 - - end - - module ConcreteLabeled (V: COMPARABLE)(E: ORDERED_TYPE_DFT) = struct - - module G = Digraph.ConcreteLabeled(V)(E) - - include Graph(G) - - (* Export some definitions of [G] *) - - let create = G.create - let copy = G.copy - let add_vertex = G.add_vertex - let remove_vertex = G.remove_vertex - - (* Redefine the [add_edge] and [remove_edge] operations *) - - let add_edge_e g (v1, l, v2 as e) = - G.add_edge_e g e; - assert (G.HM.mem v1 g && G.HM.mem v2 g); - ignore (G.unsafe_add_edge g v2 (v1, l)) - - let add_edge g v1 v2 = add_edge_e g (v1, G.default, v2) - - let remove_edge g v1 v2 = - G.remove_edge g v1 v2; - assert (G.HM.mem v1 g && G.HM.mem v2 g); - ignore (G.unsafe_remove_edge g v2 v1) - - let remove_edge_e g (v1, l, v2 as e) = - G.remove_edge_e g e; - assert (G.HM.mem v1 g && G.HM.mem v2 g); - ignore (G.unsafe_remove_edge_e g (v2, l, v1)) - - end - - module Abstract(V: sig type t end) = struct - - module G = Digraph.Abstract(V) - - include Graph(G) - - (* Export some definitions of [G] *) - - module Mark = G.Mark - let create = G.create - let copy = G.copy - let add_vertex = G.add_vertex - let remove_vertex = G.remove_vertex - - (* Redefine the [add_edge] and [remove_edge] operations *) - - let add_edge g v1 v2 = - G.add_edge g v1 v2; - assert (G.HM.mem v1 g.G.edges && G.HM.mem v2 g.G.edges); - ignore (G.unsafe_add_edge g.G.edges v2 v1) - - let add_edge_e g (v1, v2) = add_edge g v1 v2 - - let remove_edge g v1 v2 = - G.remove_edge g v1 v2; - assert (G.HM.mem v1 g.G.edges && G.HM.mem v2 g.G.edges); - ignore (G.unsafe_remove_edge g.G.edges v2 v1) - - let remove_edge_e g (v1, v2) = remove_edge g v1 v2 - - end - - module AbstractLabeled (V: sig type t end)(Edge: ORDERED_TYPE_DFT) = struct - - module G = Digraph.AbstractLabeled(V)(Edge) - - include Graph(G) - - (* Export some definitions of [G] *) - - module Mark = G.Mark - let create = G.create - let copy = G.copy - let add_vertex = G.add_vertex - let remove_vertex = G.remove_vertex - - (* Redefine the [add_edge] and [remove_edge] operations *) - - let add_edge_e g (v1, l, v2 as e) = - G.add_edge_e g e; - assert (G.HM.mem v1 g.G.edges && G.HM.mem v2 g.G.edges); - ignore (G.unsafe_add_edge g.G.edges v2 (v1, l)) - - let add_edge g v1 v2 = add_edge_e g (v1, Edge.default, v2) - - let remove_edge g v1 v2 = - G.remove_edge g v1 v2; - assert (G.HM.mem v1 g.G.edges && G.HM.mem v2 g.G.edges); - ignore (G.unsafe_remove_edge g.G.edges v2 v1) - - let remove_edge_e g (v1, l, v2 as e) = - ignore (G.remove_edge_e g e); - assert (G.HM.mem v1 g.G.edges && G.HM.mem v2 g.G.edges); - ignore (G.unsafe_remove_edge_e g.G.edges (v2, l, v1)) - - end - -end - -module Matrix = struct - - module type S = sig - include Sig.I with type V.t = int and type V.label = int - and type E.t = int * int - val make : int -> t - end - - module Digraph = struct - - module V = struct - type t = int - type label = int - let compare = Pervasives.compare - let hash = Hashtbl.hash - let equal = (==) - let create i = i - let label i = i - end - - module E = struct - type t = V.t * V.t - type vertex = V.t - let compare = Pervasives.compare - type label = unit - let create v1 _ v2 = (v1, v2) - let src = fst - let dst = snd - let label _ = () - end - - type t = Bitv.t array - type vertex = V.t - type edge = E.t - - let create ?size () = - failwith "do not use Matrix.create; please use Matrix.make instead" - - let make n = - if n < 0 then invalid_arg "Matrix.make"; - Array.init n (fun _ -> Bitv.create n false) - - let is_directed = true - - let nb_vertex = Array.length - let is_empty g = nb_vertex g = 0 - let nb_edges = - Array.fold_left (Bitv.fold_left (fun n b -> if b then n+1 else n)) 0 - - let mem_vertex g v = 0 <= v && v < nb_vertex g - let mem_edge g i j = Bitv.get g.(i) j - let mem_edge_e g (i,j) = Bitv.get g.(i) j - let find_edge g i j = if mem_edge g i j then i, j else raise Not_found - - (* constructors *) - let add_edge g i j = Bitv.set g.(i) j true - let add_edge_e g (i,j) = Bitv.set g.(i) j true - - let remove_edge g i j = Bitv.set g.(i) j false - let remove_edge_e g (i,j) = Bitv.set g.(i) j false - - let unsafe_add_edge g i j = - Bitv.unsafe_set (Array.unsafe_get g i) j true - let unsafe_remove_edge g i j = - Bitv.unsafe_set (Array.unsafe_get g i) j false - - let remove_vertex g _ = () - let add_vertex g _ = () - - let copy g = Array.init (nb_vertex g) (fun i -> Bitv.copy g.(i)) - - (* iter/fold on all vertices/edges of a graph *) - let iter_vertex f g = - for i = 0 to nb_vertex g - 1 do f i done - - let iter_edges f g = - for i = 0 to nb_vertex g - 1 do - Bitv.iteri (fun j b -> if b then f i j) g.(i) - done - - let fold_vertex f g a = - let n = nb_vertex g in - let rec fold i a = if i = n then a else fold (i+1) (f i a) in fold 0 a - - let fold_edges f g a = - fold_vertex - (fun i a -> - Bitv.foldi_right (fun j b a -> if b then f i j a else a) g.(i) a) - g a - - (* successors and predecessors of a vertex *) - let succ g i = - Bitv.foldi_left (fun l j b -> if b then j::l else l) [] g.(i) - - let pred g i = - fold_vertex - (fun j a -> if Bitv.unsafe_get g.(j) i then j :: a else a) - g [] - - (* iter/fold on all successor/predecessor of a vertex. *) - let iter_succ f g i = - let si = g.(i) in - for j = 0 to nb_vertex g - 1 do if Bitv.unsafe_get si j then f j done - (* optimization w.r.t. - [Bitv.iteri (fun j b -> if b then f j) g.(i)] - *) - - let iter_pred f g i = - for j = 0 to nb_vertex g - 1 do if Bitv.unsafe_get g.(j) i then f j done - - let fold_succ f g i a = - Bitv.foldi_right (fun j b a -> if b then f j a else a) g.(i) a - - let fold_pred f g i a = - fold_vertex - (fun j a -> if Bitv.unsafe_get g.(j) i then f j a else a) - g a - - (* degree *) - let out_degree g i = fold_succ (fun _ n -> n + 1) g i 0 - - let in_degree g i = fold_pred (fun _ n -> n + 1) g i 0 - - (* map iterator on vertex *) - let map_vertex f g = - let n = nb_vertex g in - let g' = make n in - iter_edges - (fun i j -> - let fi = f i in - let fj = f j in - if fi < 0 || fi >= n || fj < 0 || fj >= n then - invalid_arg "map_vertex"; - Bitv.unsafe_set g'.(fi) fj true) - g; - g' - - (* labeled edges going from/to a vertex *) - (* successors and predecessors of a vertex *) - let succ_e g i = - Bitv.foldi_left (fun l j b -> if b then (i,j)::l else l) [] g.(i) - - let pred_e g i = - fold_vertex - (fun j a -> if Bitv.unsafe_get g.(j) i then (j,i) :: a else a) - g [] - - (* iter/fold on all labeled edges of a graph *) - let iter_edges_e f g = - for i = 0 to nb_vertex g - 1 do - Bitv.iteri (fun j b -> if b then f (i,j)) g.(i) - done - - let fold_edges_e f g a = - fold_vertex - (fun i a -> - Bitv.foldi_right (fun j b a -> if b then f (i,j) a else a) g.(i) a) - g a - - (* iter/fold on all edges going from/to a vertex *) - let iter_succ_e f g i = - let si = g.(i) in - for j = 0 to nb_vertex g - 1 do if Bitv.unsafe_get si j then f (i,j) done - - let iter_pred_e f g i = - for j = 0 to nb_vertex g - 1 do - if Bitv.unsafe_get g.(j) i then f (j,i) - done - - let fold_succ_e f g i a = - Bitv.foldi_right (fun j b a -> if b then f (i,j) a else a) g.(i) a - - let fold_pred_e f g i a = - fold_vertex - (fun j a -> if Bitv.unsafe_get g.(j) i then f (j,i) a else a) - g a - - end - - module Graph = struct - - module G = Digraph - - include Blocks.Graph(G) - (* Export some definitions of [G] *) - - let create = G.create - let make = G.make - let copy = G.copy - let add_vertex = G.add_vertex - let remove_vertex = G.remove_vertex - - (* Redefine the [add_edge] and [remove_edge] operations *) - - let add_edge g v1 v2 = - G.add_edge g v1 v2; - ignore (G.unsafe_add_edge g v2 v1) - - let add_edge_e g (v1, v2) = add_edge g v1 v2 - - let remove_edge g v1 v2 = - G.remove_edge g v1 v2; - ignore (G.unsafe_remove_edge g v2 v1) - - let remove_edge_e g (v1, v2) = remove_edge g v1 v2 - - end - -end - diff --git a/external/ocamlgraph/src/imperative.mli b/external/ocamlgraph/src/imperative.mli deleted file mode 100644 --- a/external/ocamlgraph/src/imperative.mli +++ /dev/null @@ -1,87 +0,0 @@ -(**************************************************************************) -(* *) -(* Ocamlgraph: a generic graph library for OCaml *) -(* Copyright (C) 2004-2007 *) -(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) -(* *) -(* This software is free software; you can redistribute it and/or *) -(* modify it under the terms of the GNU Library General Public *) -(* License version 2, with the special exception on linking *) -(* described in file LICENSE. *) -(* *) -(* This software is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) -(* *) -(**************************************************************************) - -(* $Id: imperative.mli,v 1.18 2006-05-12 14:07:16 filliatr Exp $ *) - -(** Imperative Implementations *) - -open Sig - -(** Signature of imperative graphs *) -module type S = sig - - (** Imperative Unlabeled Graphs *) - module Concrete (V: COMPARABLE) : - Sig.I with type V.t = V.t and type V.label = V.t and type E.t = V.t * V.t - - (** Abstract Imperative Unlabeled Graphs *) - module Abstract(V: ANY_TYPE) : - Sig.IM with type V.label = V.t and type E.label = unit - - (** Imperative Labeled Graphs *) - module ConcreteLabeled (V: COMPARABLE)(E: ORDERED_TYPE_DFT) : - Sig.I with type V.t = V.t and type V.label = V.t - and type E.t = V.t * E.t * V.t and type E.label = E.t - - (** Abstract Imperative Labeled Graphs *) - module AbstractLabeled (V: ANY_TYPE)(E: ORDERED_TYPE_DFT) : - Sig.IM with type V.label = V.t and type E.label = E.t - -end - -(** Imperative Directed Graphs *) - -module Digraph : sig - include S - - (** Imperative Unlabeled, bidirectional graph (gives predecessors in - constant time) *) - module ConcreteBidirectional (V: COMPARABLE) : - Sig.I with type V.t = V.t and type V.label = V.t and type E.t = V.t * V.t -end - -(** Imperative Undirected Graphs *) -module Graph : S - -(** Imperative graphs implemented as adjacency matrices *) -module Matrix : sig - - module type S = sig - - (** Vertices are integers in [0..n-1]. - A vertex label is the vertex itself. - Edges are unlabeled. *) - - include Sig.I with type V.t = int and type V.label = int - and type E.t = int * int - - (** Creation. graphs are not resizeable: size is given at creation time. - Thus [make] must be used instead of [create] *) - val make : int -> t - - (** Note: [add_vertex] and [remove_vertex] have no effect *) - - end - - module Digraph : S - (** Imperative Directed Graphs implemented with adjacency matrices *) - - module Graph : S - (** Imperative Undirected Graphs implemented with adjacency matrices *) - -end - diff --git a/external/ocamlgraph/src/kruskal.ml b/external/ocamlgraph/src/kruskal.ml deleted file mode 100644 --- a/external/ocamlgraph/src/kruskal.ml +++ /dev/null @@ -1,74 +0,0 @@ -(**************************************************************************) -(* *) -(* Ocamlgraph: a generic graph library for OCaml *) -(* Copyright (C) 2004-2007 *) -(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) -(* *) -(* This software is free software; you can redistribute it and/or *) -(* modify it under the terms of the GNU Library General Public *) -(* License version 2, with the special exception on linking *) -(* described in file LICENSE. *) -(* *) -(* This software is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) -(* *) -(**************************************************************************) - -(* $Id: kruskal.ml,v 1.5 2005-06-30 10:48:55 filliatr Exp $ *) - -open Util - -module type UNIONFIND = sig - type elt - type t - - val init : elt list -> t - val find : elt -> t -> elt - val union : elt -> elt -> t -> unit -end - -module type G = sig - type t - module V : Sig.COMPARABLE - module E : sig - type t - type label - val label : t -> label - val dst : t -> V.t - val src : t -> V.t - end - val fold_vertex : (V.t -> 'a -> 'a) -> t -> 'a -> 'a - val iter_edges_e : (E.t -> unit) -> t -> unit -end - -module Generic - (G: G) - (W : Sig.ORDERED_TYPE with type t=G.E.label) - (UF: UNIONFIND with type elt=G.V.t) = -struct - - let spanningtree g = - let vertices = G.fold_vertex (fun v a -> v :: a) g [] in - let uf = UF.init vertices in - let edges = - let l = ref [] in - G.iter_edges_e (fun e -> l:=e::!l) g; - List.sort (fun e e'-> W.compare (G.E.label e) (G.E.label e')) !l - in - let s = ref [] in - let cover e = - let u,v = G.E.src e , G.E.dst e in - if G.V.compare (UF.find u uf) (UF.find v uf) <> 0 then - (UF.union u v uf; s:=e::!s) - in - List.iter cover edges;!s - -end - -module Make - (G: G) - (W : Sig.ORDERED_TYPE with type t=G.E.label) - = - Generic(G)(W)(Unionfind.Make(G.V)) - diff --git a/external/ocamlgraph/src/kruskal.mli b/external/ocamlgraph/src/kruskal.mli deleted file mode 100644 --- a/external/ocamlgraph/src/kruskal.mli +++ /dev/null @@ -1,65 +0,0 @@ -(**************************************************************************) -(* *) -(* Ocamlgraph: a generic graph library for OCaml *) -(* Copyright (C) 2004-2007 *) -(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) -(* *) -(* This software is free software; you can redistribute it and/or *) -(* modify it under the terms of the GNU Library General Public *) -(* License version 2, with the special exception on linking *) -(* described in file LICENSE. *) -(* *) -(* This software is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) -(* *) -(**************************************************************************) - -(* $Id: kruskal.mli,v 1.5 2005-06-30 10:48:55 filliatr Exp $ *) - -(** Kruskal's algorithm *) - -(** Minimal graph signature for Kruskal *) -module type G = sig - type t - module V : Sig.COMPARABLE - module E : sig - type t - type label - val label : t -> label - val dst : t -> V.t - val src : t -> V.t - end - val fold_vertex : (V.t -> 'a -> 'a) -> t -> 'a -> 'a - val iter_edges_e : (E.t -> unit) -> t -> unit -end - -module Make - (G: G) - (W: Sig.ORDERED_TYPE with type t = G.E.label) : -sig - - val spanningtree : G.t -> G.E.t list - -end - -(** Generic version where union-find implementation is provided *) - -module type UNIONFIND = sig - type elt - type t - - val init : elt list -> t - val find : elt -> t -> elt - val union : elt -> elt -> t -> unit -end - -module Generic - (G: G) - (W: Sig.ORDERED_TYPE with type t=G.E.label) - (UF: UNIONFIND with type elt=G.V.t) : -sig - - val spanningtree : G.t -> G.E.t list - -end diff --git a/external/ocamlgraph/src/mcs_m.ml b/external/ocamlgraph/src/mcs_m.ml deleted file mode 100644 --- a/external/ocamlgraph/src/mcs_m.ml +++ /dev/null @@ -1,203 +0,0 @@ -(**************************************************************************) -(* *) -(* Ocamlgraph: a generic graph library for OCaml *) -(* Copyright (C) 2004-2007 *) -(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) -(* *) -(* This software is free software; you can redistribute it and/or *) -(* modify it under the terms of the GNU Library General Public *) -(* License version 2, with the special exception on linking *) -(* described in file LICENSE. *) -(* *) -(* This software is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) -(* *) -(**************************************************************************) - -(** - Maximal Cardinality Search (MCS-M). - - Based on the article: - Maximal Cardinality Search for Computing Minimal Triangulations of Graphs. - by A. Berry, Jean R. S. Blair, Pinar Heggernes & Barry W. Peyton. - - @author Matthieu Sozeau - @author Pierre-Loic Garoche - - $Id: mcs_m.ml,v 1.5 2005-11-02 13:43:35 filliatr Exp $ -*) - -module MaximalCardinalitySearch = struct - - module WeightedV(V : Sig.COMPARABLE) = struct - include Util.DataV(struct type t = int end)(V) - let weight = data - let set_weight = set_data - end - - module P(Gr : Sig.P) = struct - type edgelist = (Gr.V.t * Gr.V.t) list - - module NewV = WeightedV(Gr.V) - module G = Persistent.Graph.Concrete(NewV) - module EdgeSet = Set.Make(G.E) - module VerticesSet = Set.Make(NewV) - module Choose = Oper.Choose(G) - module H = Hashtbl.Make(NewV) - - exception Found - - let check_path g u v = - let h = H.create 97 in - let maxw = NewV.weight u in - let rec aux x : bool = - if H.mem h x then - false - else - if x = v then true - else - if NewV.weight x < maxw || x = u then - begin - H.add h x (); - G.fold_succ - (fun x found -> - if not found then aux x - else found) - g x false - end - else (H.add h x (); false) - in aux u - - module Copy = Gmap.Vertex(Gr)(struct include G include Builder.P(G) end) - - let fold f d = - let rec aux = function - (true, a) -> aux (f a) - | (false, a) -> a - in aux d - - let mcsm g = - let g' = Copy.map (NewV.create 0) g in - let (_, _, ord, triang) = - fold - (fun ((i, g', a, f) as x)-> - if i = 0 then (false, x) - else - let v = - G.fold_vertex - (fun x max -> - if NewV.weight x > NewV.weight max then x else max) - g' (ref 0, snd (Choose.choose_vertex g')) - in - let s = - G.fold_vertex - (fun x s -> - if x = v then s - else - if check_path g' x v then - VerticesSet.add x s - else s) - g' VerticesSet.empty - in - let f' = - VerticesSet.fold - (fun x f -> - NewV.set_weight x (succ (NewV.weight x)); - if not (G.mem_edge g' x v) then - EdgeSet.add (x,v) f - else f) - s f - in - let g' = G.remove_vertex g' v in - let a' = (i, NewV.label v) :: a in - (true, (i - 1, g', a', f'))) - (true, (Gr.nb_vertex g, g', [], EdgeSet.empty)) - in - (List.rev ord, - EdgeSet.fold - (fun (x, y) e -> (NewV.label x, NewV.label y) :: e) - triang []) - - let triangulate g = - let (_, triang) = mcsm g in - List.fold_left (fun g (x, y) -> Gr.add_edge g x y) g triang - end - - module I(Gr : Sig.I) = struct - type edgelist = (Gr.V.t * Gr.V.t) list - - module NewV = WeightedV(Gr.V) - module G = Imperative.Graph.Concrete(NewV) - module EdgeSet = Set.Make(G.E) - module VerticesSet = Set.Make(NewV) - module Choose = Oper.Choose(G) - module H = Hashtbl.Make(NewV) - - exception Found - - let check_path g u v = - let h = H.create 97 in - let maxw = NewV.weight u in - let rec aux x : bool = - if H.mem h x then - false - else - if x = v then true - else - if NewV.weight x < maxw || x = u then begin - H.add h x (); - G.fold_succ - (fun x found -> - if not found then aux x - else found) - g x false - end else (H.add h x (); false) - in aux u - - module Copy = Gmap.Vertex(Gr)(struct include G include Builder.I(G) end) - - let mcsm g = - let f = ref EdgeSet.empty - and a = ref [] - and g' = Copy.map (NewV.create 0) g in - for i = Gr.nb_vertex g downto 1 do - let v = - G.fold_vertex - (fun x max -> - if NewV.weight x > NewV.weight max then x else max) - g' (ref 0, snd (Choose.choose_vertex g')) - in - let s = - G.fold_vertex - (fun x s -> - if x = v then s - else - if check_path g' x v then - VerticesSet.add x s - else s) - g' VerticesSet.empty - in - let f' = - VerticesSet.fold - (fun x f -> - NewV.set_weight x (succ (NewV.weight x)); - if not (G.mem_edge g' x v) then - EdgeSet.add (x,v) f - else f) - s !f - in - f := f'; - G.remove_vertex g' v; - a := (i, NewV.label v) :: !a; - done; - (List.rev !a, - EdgeSet.fold - (fun (x, y) e -> (NewV.label x, NewV.label y) :: e) - !f []) - - let triangulate g = - let (_, triang) = mcsm g in - List.iter (fun (x, y) -> Gr.add_edge g x y) triang - end -end diff --git a/external/ocamlgraph/src/mcs_m.mli b/external/ocamlgraph/src/mcs_m.mli deleted file mode 100644 --- a/external/ocamlgraph/src/mcs_m.mli +++ /dev/null @@ -1,53 +0,0 @@ -(**************************************************************************) -(* *) -(* Ocamlgraph: a generic graph library for OCaml *) -(* Copyright (C) 2004-2007 *) -(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) -(* *) -(* This software is free software; you can redistribute it and/or *) -(* modify it under the terms of the GNU Library General Public *) -(* License version 2, with the special exception on linking *) -(* described in file LICENSE. *) -(* *) -(* This software is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) -(* *) -(**************************************************************************) - -(** - Maximal Cardinality Search (MCS-M) algorithm - - Based on the article: - Maximal Cardinality Search for Computing Minimal Triangulations of Graphs. - by A. Berry, Jean R. S. Blair, Pinar Heggernes & Barry W. Peyton. - - @author Matthieu Sozeau - @author Pierre-Loic Garoche - - $Id: mcs_m.mli,v 1.2 2004-10-19 15:21:44 signoles Exp $ -*) - -module MaximalCardinalitySearch : sig - module P(G : Sig.P) : sig - type edgelist = (G.V.t * G.V.t) list - - (** [mcsm g] returns a tuple [(o, e)] where [o] is a perfect elimination - order of [g'] where [g'] is the triangulation [e] applied to [g]. *) - val mcsm : G.t -> (int * G.V.t) list * edgelist - - (** [triangulate g] computes a triangulation of [g] - using the MCS-M algorithm *) - val triangulate : G.t -> G.t - end - module I(Gr : Sig.I) : sig - type edgelist = (Gr.V.t * Gr.V.t) list - - (** [mcsm g] return a tuple [(o, e)] where o is a perfect elimination order - of [g'] where [g'] is the triangulation [e] applied to [g]. *) - val mcsm : Gr.t -> (int * Gr.V.t) list * edgelist - - (** [triangulate g] triangulates [g] using the MCS-M algorithm *) - val triangulate : Gr.t -> unit - end -end diff --git a/external/ocamlgraph/src/md.ml b/external/ocamlgraph/src/md.ml deleted file mode 100644 --- a/external/ocamlgraph/src/md.ml +++ /dev/null @@ -1,163 +0,0 @@ -(**************************************************************************) -(* *) -(* Ocamlgraph: a generic graph library for OCaml *) -(* Copyright (C) 2004-2007 *) -(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) -(* *) -(* This software is free software; you can redistribute it and/or *) -(* modify it under the terms of the GNU Library General Public *) -(* License version 2, with the special exception on linking *) -(* described in file LICENSE. *) -(* *) -(* This software is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) -(* *) -(**************************************************************************) - -(* $Id: md.ml,v 1.6 2004-10-22 14:42:06 signoles Exp $ *) - -(** Minimum Degree. - - Based on the article: - The Minimum Degree Heuristic and the Minimal Triangulation Process - by A. Berry, Pinar Heggernes & Geneviève Simonet. - - @author Matthieu Sozeau - @author Pierre-Loic Garoche *) - -module P(G : Sig.P) = struct - - module VertexSet = Set.Make(G.V) - module CT = Cliquetree.CliqueTree(G) - - module Choose = Oper.Choose(G) -(* module NG = Neighborhood.Graph(G)*) - - type edgeset = (G.V.t * G.V.t) list - - let md g = - let gref = ref g in - let gtri = ref g in - let n = G.nb_vertex g in - let tri = ref [] in - let ord = ref [] in - let i = ref 0 in - while not (CT.is_chordal !gtri) && !i < n do - let v = - let x = - G.fold_vertex - (fun v' x -> - let deg' = G.out_degree !gref v' in - match x with - Some (v,deg) when deg' > deg -> x - | _ -> Some (v', deg')) - !gref None - in match x with - Some (v,_) -> v - | None -> failwith "Expecting some vertex" - in - let ng = G.succ !gref v in - let g', tri' = - List.fold_left - (fun (g, tri) v -> - let tri' = - List.fold_left - (fun tri v' -> - if v <> v' && not (G.mem_edge g v v') then - (v, v') :: tri - else tri) - tri ng - in - let g' = - List.fold_left - (fun g v' -> - if v <> v' then - G.add_edge g v v' - else g) - g ng - in - (g', tri')) - (!gref, []) ng - in - ord := v :: !ord; - gtri := List.fold_left - (fun g (x,y) -> G.add_edge g x y) - !gtri tri'; - gref := G.remove_vertex g' v; - tri := tri' @ !tri; - incr i; - done; - (!gtri, !tri, !ord) - - let triangulate g = - let gtri, _, _ = md g in - gtri - -end - -module I(G : Sig.I) = struct - - module VertexSet = Set.Make(G.V) - module CT = Cliquetree.CliqueTree(G) - - module Choose = Oper.Choose(G) -(* module NG = Neighborhood.Graph(G)*) - - type edgeset = (G.V.t * G.V.t) list - - module Copy = Gmap.Vertex(G)(struct include G include Builder.I(G) end) - - let md g = - let gtri = Copy.map (fun x -> x) g in - let gcur = Copy.map (fun x -> x) g in - let n = G.nb_vertex g in - let tri = ref [] in - let ord = ref [] in - let i = ref 0 in - while not (CT.is_chordal gtri) && !i < n do - let v = - let x = - G.fold_vertex - (fun v' x -> - let deg' = G.out_degree gcur v' in - match x with - Some (v,deg) when deg' > deg -> x - | _ -> Some (v', deg')) - gcur None - in match x with - Some (v,_) -> v - | None -> failwith "Expecting some vertex" - in - let ng = G.succ gcur v in - let tri' = - List.fold_left - (fun tri v -> - List.fold_left - (fun tri v' -> - let tri' = - if v <> v' && not (G.mem_edge g v v') then - (v, v') :: tri - else - tri - in - List.iter (fun v' -> if v <> v' then G.add_edge gcur v v') ng; - tri') - tri ng) - [] ng - in - ord := v :: !ord; - List.iter - (fun (x,y) -> G.add_edge gtri x y) - tri'; - G.remove_vertex gcur v; - tri := tri' @ !tri; - incr i; - done; - (gtri, !tri, !ord) - - let triangulate g = - let gtri, _, _ = md g in - gtri - -end diff --git a/external/ocamlgraph/src/md.mli b/external/ocamlgraph/src/md.mli deleted file mode 100644 --- a/external/ocamlgraph/src/md.mli +++ /dev/null @@ -1,57 +0,0 @@ -(**************************************************************************) -(* *) -(* Ocamlgraph: a generic graph library for OCaml *) -(* Copyright (C) 2004-2007 *) -(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) -(* *) -(* This software is free software; you can redistribute it and/or *) -(* modify it under the terms of the GNU Library General Public *) -(* License version 2, with the special exception on linking *) -(* described in file LICENSE. *) -(* *) -(* This software is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) -(* *) -(**************************************************************************) - -(* $Id: md.mli,v 1.2 2004-06-28 13:48:25 signoles Exp $ *) - -(** Minimum Degree algorithm - - Based on the article: - The Minimum Degree Heuristic and the Minimal Triangulation Process - by A. Berry, Pinar Heggernes & Geneviève Simonet. - - @author Matthieu Sozeau - @author Pierre-Loic Garoche *) - -module P(G : Sig.P) : sig - - type edgeset = (G.V.t * G.V.t) list - - val md : G.t -> G.t * edgeset * G.V.t list - (** [md g] return a tuple [(g', e, o)] where [g'] is - a triangulated graph, [e] is the triangulation of [g] and - [o] is a perfect elimination order of [g'] *) - - val triangulate : G.t -> G.t - (** [triangulate g] return the graph [g'] produced by applying - miminum degree to [g]. *) - -end - -module I(G : Sig.I) : sig - - type edgeset = (G.V.t * G.V.t) list - - val md : G.t -> G.t * edgeset * G.V.t list - (** [md g] return a tuple [(g', e, o)] where [g'] is - a triangulated graph, [e] is the triangulation of [g] and - [o] is a perfect elimination order of [g'] *) - - val triangulate : G.t -> G.t - (** [triangulate g] return the graph [g'] produced by applying - miminum degree to [g]. *) - -end diff --git a/external/ocamlgraph/src/minsep.ml b/external/ocamlgraph/src/minsep.ml deleted file mode 100644 --- a/external/ocamlgraph/src/minsep.ml +++ /dev/null @@ -1,131 +0,0 @@ -(**************************************************************************) -(* *) -(* Ocamlgraph: a generic graph library for OCaml *) -(* Copyright (C) 2004-2007 *) -(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) -(* *) -(* This software is free software; you can redistribute it and/or *) -(* modify it under the terms of the GNU Library General Public *) -(* License version 2, with the special exception on linking *) -(* described in file LICENSE. *) -(* *) -(* This software is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) -(* *) -(**************************************************************************) - -(*i $Id: minsep.ml,v 1.7 2004-10-25 15:46:16 signoles Exp $ i*) - -module type G = sig - type t - module V : Sig.COMPARABLE - val succ: t -> V.t -> V.t list - val iter_succ: (V.t -> unit) -> t -> V.t -> unit - val fold_succ: (V.t -> 'a -> 'a) -> t -> V.t -> 'a -> 'a - val iter_vertex: (V.t -> unit) -> t -> unit - val fold_vertex: (V.t -> 'a -> 'a) -> t -> 'a -> 'a -end - -module type MINSEP = sig - module G : G - module Vertex_Set : Set.S with type elt = G.V.t - module VSetset : Set.S with type elt = Vertex_Set.t - val allminsep : G.t -> Vertex_Set.t list - val list_of_allminsep : G.t -> G.V.t list list - val set_of_allminsep : G.t -> VSetset.t -end - -module Make - (G : sig - include G - val cc: t -> V.t list -> V.t list list - (** compute the set of connected components of G(V \ l) *) - end) = -struct - - module N = Oper.Neighbourhood(G) - module Vertex_Set = N.Vertex_Set - module VSetset = Set.Make(Vertex_Set) - - let initialisation g = - let cc = G.cc g in - let neighbourhood = N.list_from_vertex g in - let neighbourhoods = N.set_from_vertices g in - G.fold_vertex - (fun v s -> - List.fold_left - (fun s l -> neighbourhoods l :: s) - s (cc (v :: neighbourhood v))) - g [] - - let generation g = - let neighbourhood = N.list_from_vertex g in - let neighbourhoods = N.set_from_vertices g in - let cc = G.cc g in - let rec gen_aux seen bigs = function - | [] -> bigs - | s :: tl -> - let l = Vertex_Set.elements s in - let seen = VSetset.add s seen in - let bigs, tl = - Vertex_Set.fold - (fun v c -> - let add_neighbourhoods (bigs, tl) l = - let s = neighbourhoods l in - s :: bigs, if VSetset.mem s seen then tl else s :: tl - in - List.fold_left - add_neighbourhoods - (bigs, tl) (cc (l @ neighbourhood v))) - s (bigs, tl) - in - gen_aux seen bigs tl - in - fun bigs -> gen_aux VSetset.empty bigs bigs - - let allminsep g = generation g (initialisation g) - - let set_of_allminsep g = - List.fold_left - (fun bigs s -> VSetset.add s bigs) VSetset.empty (allminsep g) - - let list_of_allminsep g = List.map Vertex_Set.elements (allminsep g) - -end - -module P(G : sig include G val remove_vertex : t -> V.t -> t end) = struct - module G = G - include Make(struct - include G - let cc = - let module CC = Components.Make(G) in - fun g l -> - let g = List.fold_left remove_vertex g l in - CC.scc_list g - end) -end - -module I(G : sig - include G - module Mark : Sig.MARK with type graph = t and type vertex = V.t - end) = -struct - module G = G - include Make(struct - include G - let cc = - let module CC = - Components.Make - (struct - include G - let iter_vertex f = - iter_vertex (fun v -> if Mark.get v=0 then f v) - end) - in - fun g l -> - G.Mark.clear g; - List.iter (fun v -> G.Mark.set v 1) l; - CC.scc_list g - end) -end diff --git a/external/ocamlgraph/src/minsep.mli b/external/ocamlgraph/src/minsep.mli deleted file mode 100644 --- a/external/ocamlgraph/src/minsep.mli +++ /dev/null @@ -1,70 +0,0 @@ -(**************************************************************************) -(* *) -(* Ocamlgraph: a generic graph library for OCaml *) -(* Copyright (C) 2004-2007 *) -(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) -(* *) -(* This software is free software; you can redistribute it and/or *) -(* modify it under the terms of the GNU Library General Public *) -(* License version 2, with the special exception on linking *) -(* described in file LICENSE. *) -(* *) -(* This software is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) -(* *) -(**************************************************************************) - -(*i $Id: minsep.mli,v 1.4 2004-10-22 16:31:03 conchon Exp $ i*) - -(** - Minimal separators of a graph - - Based on the article: - Generating all the minimal separators of a graph. - by A. Berry, J.-P. Bordat and O.Cogis - http://www.isima.fr/berry/generating.html - - A set [S] of vertices is a minimal separator if it exists 2 distinct - connected components [C] and [D] in [G \ S] such that each vertex of [S] has - a successor in [C] and [D]. *) - -(** Minimal signature for computing the minimal separators *) -module type G = sig - type t - module V : Sig.COMPARABLE - val succ: t -> V.t -> V.t list - val iter_succ: (V.t -> unit) -> t -> V.t -> unit - val fold_succ: (V.t -> 'a -> 'a) -> t -> V.t -> 'a -> 'a - val iter_vertex: (V.t -> unit) -> t -> unit - val fold_vertex: (V.t -> 'a -> 'a) -> t -> 'a -> 'a -end - -module type MINSEP = sig - module G : G - (** Implementation of a graph *) - module Vertex_Set : Set.S with type elt = G.V.t - (** Implementation of a set of vertex *) - module VSetset : Set.S with type elt = Vertex_Set.t - (** Implementation of a set of [Vertex_Set] *) - - val allminsep : G.t -> Vertex_Set.t list - (** [allminsep g] computes the list of all minimal separators of g. *) - val list_of_allminsep : G.t -> G.V.t list list - (** Less efficient that [allminsep] *) - val set_of_allminsep : G.t -> VSetset.t - (** Less efficient that [allminsep] *) -end - -(** Implementation for a persistent graph *) -module P(G : sig include G val remove_vertex : t -> V.t -> t end) : - MINSEP with module G = G - -(** Implementation for an imperative graph. - Less efficient that the implementation for a persistent graph *) -module I(G : sig - include G - module Mark : Sig.MARK with type graph = t and type vertex = V.t - end) : - MINSEP with module G = G - diff --git a/external/ocamlgraph/src/oper.ml b/external/ocamlgraph/src/oper.ml deleted file mode 100644 --- a/external/ocamlgraph/src/oper.ml +++ /dev/null @@ -1,171 +0,0 @@ -(**************************************************************************) -(* *) -(* Ocamlgraph: a generic graph library for OCaml *) -(* Copyright (C) 2004-2007 *) -(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) -(* *) -(* This software is free software; you can redistribute it and/or *) -(* modify it under the terms of the GNU Library General Public *) -(* License version 2, with the special exception on linking *) -(* described in file LICENSE. *) -(* *) -(* This software is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) -(* *) -(**************************************************************************) - -(* $Id: oper.ml,v 1.13 2005-06-30 10:48:55 filliatr Exp $ *) - -(* Basic operations over graphs *) - -module type S = sig - type g - val transitive_closure : ?reflexive:bool -> g -> g - val add_transitive_closure : ?reflexive:bool -> g -> g - val mirror : g -> g - val complement : g -> g - val intersect : g -> g -> g - val union : g -> g -> g -end - -module Make(B : Builder.S) = struct - - open B - - (* Roy-Warshall's algorithm *) - - type g = G.t - - let add_transitive_closure ?(reflexive=false) g0 = - let phi v g = - let g = if reflexive then B.add_edge g v v else g in - G.fold_succ - (fun sv g -> G.fold_pred (fun pv g -> B.add_edge g pv sv) g v g) - g v g - in - G.fold_vertex phi g0 g0 - - let transitive_closure ?(reflexive=false) g0 = - add_transitive_closure ~reflexive (B.copy g0) - - module H = Hashtbl.Make(G.V) - - let mirror g = - if G.is_directed then begin - let g' = B.empty () in - G.fold_edges_e - (fun e g' -> - let v1 = (G.E.src e) in - let v2 = (G.E.dst e) in - B.add_edge_e g' (G.E.create v2 (G.E.label e) v1)) - g g' - end else - B.copy g - - let complement g = - G.fold_vertex - (fun v g' -> - G.fold_vertex - (fun w g' -> - if G.mem_edge g v w then g' - else B.add_edge g' v w) - g g') - g (B.empty ()) - - let intersect g1 g2 = - G.fold_vertex - (fun v g -> - try - let succ = G.succ_e g2 v in - G.fold_succ_e - (fun e g -> - if List.mem e succ - then B.add_edge_e g e - else B.add_vertex g (G.E.dst e)) - g1 v (B.add_vertex g v) - with Invalid_argument _ -> - (* $v \notin g2$ *) - g) - g1 (B.empty ()) - - let union g1 g2 = - let add g1 g2 = - (* add the graph [g1] in [g2] *) - G.fold_vertex - (fun v g -> - G.fold_succ_e (fun e g -> B.add_edge_e g e) g1 v (B.add_vertex g v)) - g1 g2 - in - add g1 (B.copy g2) - -end - -module P(G : Sig.P) = Make(Builder.P(G)) -module I(G : Sig.I) = Make(Builder.I(G)) - -module Choose(G : sig - type t - type vertex - type edge - val iter_vertex : (vertex -> unit) -> t -> unit - val iter_edges_e : (edge -> unit) -> t -> unit - end) = -struct - - exception Found_Vertex of G.vertex - let choose_vertex g = - try - G.iter_vertex (fun v -> raise (Found_Vertex v)) g; - invalid_arg "choose_vertex" - with Found_Vertex v -> - v - - exception Found_Edge of G.edge - let choose_edge g = - try - G.iter_edges_e (fun v -> raise (Found_Edge v)) g; - invalid_arg "choose_vertex" - with Found_Edge v -> - v - -end - -module Neighbourhood(G : sig - type t - module V : Sig.COMPARABLE - val fold_succ: (V.t -> 'a -> 'a) -> t -> V.t -> 'a -> 'a - val succ: t -> V.t -> V.t list - end) = -struct - - module Vertex_Set = Set.Make(G.V) - - let set_from_vertex g v = - G.fold_succ - (fun v' s -> if G.V.equal v v' then s else Vertex_Set.add v' s) - g v Vertex_Set.empty - - let list_from_vertex g v = - let rec aux = function - | [] -> [] - | v' :: l -> - if G.V.equal v v' then begin - assert (not (List.exists (G.V.equal v) l)); - l - end else - v' :: aux l - in - aux (G.succ g v) - - let set_from_vertices g l = - let fold_left f = List.fold_left f Vertex_Set.empty l in - let env_init = fold_left (fun s v -> Vertex_Set.add v s) in - let add x s = - if Vertex_Set.mem x env_init then s else Vertex_Set.add x s - in - fold_left (fun s v -> G.fold_succ add g v s) - - let list_from_vertices g l = Vertex_Set.elements (set_from_vertices g l) - -end diff --git a/external/ocamlgraph/src/oper.mli b/external/ocamlgraph/src/oper.mli deleted file mode 100644 --- a/external/ocamlgraph/src/oper.mli +++ /dev/null @@ -1,124 +0,0 @@ -(**************************************************************************) -(* *) -(* Ocamlgraph: a generic graph library for OCaml *) -(* Copyright (C) 2004-2007 *) -(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) -(* *) -(* This software is free software; you can redistribute it and/or *) -(* modify it under the terms of the GNU Library General Public *) -(* License version 2, with the special exception on linking *) -(* described in file LICENSE. *) -(* *) -(* This software is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) -(* *) -(**************************************************************************) - -(* $Id: oper.mli,v 1.15 2005-01-18 16:40:14 signoles Exp $ *) - -(** Basic operations over graphs *) - -(** {1 Basic operations over graphs} *) - -module type S = sig - - type g - - val transitive_closure : ?reflexive:bool -> g -> g - (** [transitive_closure ?reflexive g] returns the transitive closure - of [g] (as a new graph). Loops (i.e. edges from a vertex to itself) - are added only if [reflexive] is [true] (default is [false]). *) - - val add_transitive_closure : ?reflexive:bool -> g -> g - (** [add_transitive_closure ?reflexive g] replaces [g] by its - transitive closure. Meaningless for persistent implementations - (then acts as [transitive_closure]). *) - - val mirror : g -> g - (** [mirror g] returns a new graph which is the mirror image of [g]: - each edge from [u] to [v] has been replaced by an edge from [v] to [u]. - For undirected graphs, it simply returns a copy of [g]. *) - - val complement : g -> g - (** [complement g] returns a new graph which is the complement of [g]: - each edge present in [g] is not present in the resulting graph and - vice-versa. Edges of the returned graph are unlabeled. *) - - val intersect : g -> g -> g - (** [intersect g1 g2] returns a new graph which is the intersection of [g1] - and [g2]: each vertex and edge present in [g1] *and* [g2] is present - in the resulting graph. *) - - val union : g -> g -> g - (** [union g1 g2] returns a new graph which is the union of [g1] and [g2]: - each vertex and edge present in [g1] *or* [g2] is present in the - resulting graph. *) - -end - -module Make(B : Builder.S) : S with type g = B.G.t - (** Basic operations over graphs *) - -module P(G : Sig.P) : S with type g = G.t - (** Basic operations over persistent graphs *) - -module I(G : Sig.I) : S with type g = G.t - (** Basic operations over imperative graphs *) - -(** {1 Choose} *) - -(** Choose an element in a graph *) -module Choose(G : sig - type t - type vertex - type edge - val iter_vertex : (vertex -> unit) -> t -> unit - val iter_edges_e : (edge -> unit) -> t -> unit - end) : -sig - - val choose_vertex : G.t -> G.vertex - (** [choose_vertex g] returns a vertex from the graph. - @raise Invalid_argument if the graph is empty. *) - - val choose_edge : G.t -> G.edge - (** [choose_edge g] returns an edge from the graph. - @raise Invalid_argument if the graph has no edge. *) - -end - -(** {1 Neighbourhood } *) - -(** Neighbourhood of vertex / vertices *) -module Neighbourhood(G : sig - type t - module V : Sig.COMPARABLE - val fold_succ: (V.t -> 'a -> 'a) -> t -> V.t -> 'a -> 'a - val succ: t -> V.t -> V.t list - end) : -sig - - module Vertex_Set : Set.S with type elt = G.V.t - - (** The neighbourhood of a vertex [v] is - \{ v' | (succ g v) and (v <> v') \} *) - - val list_from_vertex : G.t -> G.V.t -> G.V.t list - (** Neighbourhood of a vertex as a list. *) - - val set_from_vertex : G.t -> G.V.t -> Vertex_Set.t - (** Neighbourhood of a vertex as a set. - Less efficient that [list_from_vertex]. *) - - (** The neighbourhood of a set [S] of vertices is [U \ S] where - [U] is the union of neighbourhoods of each vertex of [S]. *) - - val list_from_vertices : G.t -> G.V.t list -> G.V.t list - (** Neighbourhood of a list of vertices as a list. *) - - val set_from_vertices : G.t -> G.V.t list -> Vertex_Set.t - (** Neighbourhood of a list of vertices as a set. - More efficient that [list_from_vertices]. *) - -end diff --git a/external/ocamlgraph/src/pack.ml b/external/ocamlgraph/src/pack.ml deleted file mode 100644 --- a/external/ocamlgraph/src/pack.ml +++ /dev/null @@ -1,180 +0,0 @@ -(**************************************************************************) -(* *) -(* Ocamlgraph: a generic graph library for OCaml *) -(* Copyright (C) 2004-2007 *) -(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) -(* *) -(* This software is free software; you can redistribute it and/or *) -(* modify it under the terms of the GNU Library General Public *) -(* License version 2, with the special exception on linking *) -(* described in file LICENSE. *) -(* *) -(* This software is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) -(* *) -(**************************************************************************) - -(* $Id: pack.ml,v 1.13 2006-05-12 14:07:16 filliatr Exp $ *) - -module Generic(G : Sig.IM with type V.label = int and type E.label = int) = -struct - - include G - - exception Found of V.t - let find_vertex g i = - try - iter_vertex (fun v -> if V.label v = i then raise (Found v)) g; - raise Not_found - with Found v -> - v - - module Builder = Builder.I(G) - - module Dfs = Traverse.Dfs(G) - module Bfs = Traverse.Bfs(G) - module Marking = Traverse.Mark(G) - - module Classic = Classic.I(G) - - module Rand = Rand.I(G) - - module Components = Components.Make(G) - - module W = struct - type label = int - type t = int - let weight x = x - let zero = 0 - let add = (+) - let compare = compare - end - - include Gpath.Dijkstra(G)(W) - - module F = struct - type label = int - type t = int - let max_capacity x = x - let min_capacity _ = 0 - let flow _ = 0 - let add = (+) - let sub = (-) - let compare = compare - let max = max_int - let min = 0 - let zero = 0 - end - - module FF = Flow.Ford_Fulkerson(G)(F) - let ford_fulkerson g = - if not G.is_directed then - invalid_arg "ford_fulkerson: not a directed graph"; - FF.maxflow g - - module Goldberg = Flow.Goldberg(G)(F) - let goldberg g = - if not G.is_directed then invalid_arg "goldberg: not a directed graph"; - Goldberg.maxflow g - - include Oper.Make(Builder) - - module PathCheck = Gpath.Check(G) - - module Topological = Topological.Make(G) - - module Int = struct - type t = int - let compare = Pervasives.compare - end - - include Kruskal.Make(G)(Int) - - module Display = struct - include G - let vertex_name v = string_of_int (V.label v) - let graph_attributes _ = [] - let default_vertex_attributes _ = [] - let vertex_attributes _ = [] - let default_edge_attributes _ = [] - let edge_attributes _ = [] - let get_subgraph _ = None - end - module Dot_ = Graphviz.Dot(Display) - module Neato = Graphviz.Neato(Display) - - let dot_output g f = - let oc = open_out f in - if is_directed then Dot_.output_graph oc g else Neato.output_graph oc g; - close_out oc - - let display_with_gv g = - let tmp = Filename.temp_file "graph" ".dot" in - dot_output g tmp; - ignore (Sys.command ("dot -Tps " ^ tmp ^ " | gv -")); - Sys.remove tmp - - module GmlParser = - Gml.Parse - (Builder) - (struct - let node l = - try match List.assoc "id" l with Gml.Int n -> n | _ -> -1 - with Not_found -> -1 - let edge _ = - 0 - end) - - let parse_gml_file = GmlParser.parse - - module DotParser = - Dot.Parse - (Builder) - (struct - let nodes = Hashtbl.create 97 - let new_node = ref 0 - let node (id,_) _ = - try - Hashtbl.find nodes id - with Not_found -> - incr new_node; - Hashtbl.add nodes id !new_node; - !new_node - let edge _ = - 0 - end) - - let parse_dot_file = DotParser.parse - - open Format - - module GmlPrinter = - Gml.Print - (G) - (struct - let node n = ["label", Gml.Int n] - let edge n = ["label", Gml.Int n] - end) - - let print_gml_file g f = - let c = open_out f in - let fmt = formatter_of_out_channel c in - fprintf fmt "%a@." GmlPrinter.print g; - close_out c - -end - -module I = struct - type t = int - let compare = compare - let hash = Hashtbl.hash - let equal = (=) - let default = 0 -end - -module Digraph = Generic(Imperative.Digraph.AbstractLabeled(I)(I)) - -module Graph = Generic(Imperative.Graph.AbstractLabeled(I)(I)) - - diff --git a/external/ocamlgraph/src/pack.mli b/external/ocamlgraph/src/pack.mli deleted file mode 100644 --- a/external/ocamlgraph/src/pack.mli +++ /dev/null @@ -1,28 +0,0 @@ -(**************************************************************************) -(* *) -(* Ocamlgraph: a generic graph library for OCaml *) -(* Copyright (C) 2004-2007 *) -(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) -(* *) -(* This software is free software; you can redistribute it and/or *) -(* modify it under the terms of the GNU Library General Public *) -(* License version 2, with the special exception on linking *) -(* described in file LICENSE. *) -(* *) -(* This software is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) -(* *) -(**************************************************************************) - -(* $Id: pack.mli,v 1.1 2004-02-04 11:52:02 filliatr Exp $ *) - -(** Immediate access to the library. *) - -module Digraph : Sig_pack.S - (** Directed graphs *) - -module Graph : Sig_pack.S - (** Undirected graphs *) - - diff --git a/external/ocamlgraph/src/persistent.ml b/external/ocamlgraph/src/persistent.ml deleted file mode 100644 --- a/external/ocamlgraph/src/persistent.ml +++ /dev/null @@ -1,297 +0,0 @@ -(**************************************************************************) -(* *) -(* Ocamlgraph: a generic graph library for OCaml *) -(* Copyright (C) 2004-2007 *) -(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) -(* *) -(* This software is free software; you can redistribute it and/or *) -(* modify it under the terms of the GNU Library General Public *) -(* License version 2, with the special exception on linking *) -(* described in file LICENSE. *) -(* *) -(* This software is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) -(* *) -(**************************************************************************) - -(* $Id: persistent.ml,v 1.18 2005-01-17 15:22:03 signoles Exp $ *) - -open Sig -open Util -open Blocks - -module type S = sig - - (** Persistent Unlabeled Graphs *) - module Concrete (V: COMPARABLE) : - Sig.P with type V.t = V.t and type V.label = V.t and type E.t = V.t * V.t - - (** Abstract Persistent Unlabeled Graphs *) - module Abstract(V: sig type t end) : Sig.P with type V.label = V.t - - (** Persistent Labeled Graphs *) - module ConcreteLabeled (V: COMPARABLE)(E: ORDERED_TYPE_DFT) : - Sig.P with type V.t = V.t and type V.label = V.t - and type E.t = V.t * E.t * V.t and type E.label = E.t - - (** Abstract Persistent Labeled Graphs *) - module AbstractLabeled (V: sig type t end)(E: ORDERED_TYPE_DFT) : - Sig.P with type V.label = V.t and type E.label = E.t - -end - -module P = Make(Make_Map) - -type 'a abstract_vertex = { tag : int; label : 'a } - -(* Vertex for the abstract persistent graphs. *) -module AbstractVertex(V: sig type t end) = struct - - type label = V.t - type t = label abstract_vertex - - let compare x y = compare x.tag y.tag - let hash x = Hashtbl.hash x.tag - let equal x y = x.tag = y.tag - let label x = x.label - - let create l = - assert (!cpt_vertex < max_int); - incr cpt_vertex; - { tag = !cpt_vertex; label = l } - -end - -module Digraph = struct - - module Concrete = P.Digraph.Concrete - - module ConcreteLabeled(V: COMPARABLE)(Edge: ORDERED_TYPE_DFT) = struct - - include P.Digraph.ConcreteLabeled(V)(Edge) - - let add_edge_e g (v1, l, v2) = - let g = add_vertex g v1 in - let g = add_vertex g v2 in - unsafe_add_edge g v1 (v2, l) - - let add_edge g v1 v2 = add_edge_e g (v1, Edge.default, v2) - - let remove_vertex g v = - if HM.mem v g then - let remove v s = - S.fold - (fun (v2, _ as e) s -> if not (V.equal v v2) then S.add e s else s) - s S.empty - in - let g = HM.remove v g in - HM.fold (fun k s g -> HM.add k (remove v s) g) g HM.empty - else - g - - end - - module Abstract(V: sig type t end) = struct - - include P.Digraph.Abstract(AbstractVertex(V)) - - let empty = { edges = G.empty; size = 0 } - - let add_vertex g v = - if mem_vertex g v then - g - else - { edges = G.unsafe_add_vertex g.edges v; - size = Pervasives.succ g.size } - - let add_edge g v1 v2 = - let g = add_vertex g v1 in - let g = add_vertex g v2 in - { g with edges = G.unsafe_add_edge g.edges v1 v2 } - - let add_edge_e g (v1, v2) = add_edge g v1 v2 - - let remove_vertex g v = - if HM.mem v g.edges then - let e = HM.remove v g.edges in - let e = HM.fold (fun k s g -> HM.add k (S.remove v s) g) e HM.empty in - { edges = e; size = Pervasives.pred g.size } - else - g - - let remove_edge g v1 v2 = { g with edges = remove_edge g v1 v2 } - let remove_edge_e g e = { g with edges = remove_edge_e g e } - - end - - module AbstractLabeled(V: sig type t end)(Edge: ORDERED_TYPE_DFT) = struct - - include P.Digraph.AbstractLabeled(AbstractVertex(V))(Edge) - - let empty = { edges = G.empty; size = 0 } - - let add_vertex g v = - if mem_vertex g v then - g - else - { edges = G.unsafe_add_vertex g.edges v; - size = Pervasives.succ g.size } - - let add_edge_e g (v1, l, v2) = - let g = add_vertex g v1 in - let g = add_vertex g v2 in - { g with edges = G.unsafe_add_edge g.edges v1 (v2, l) } - - let add_edge g v1 v2 = add_edge_e g (v1, Edge.default, v2) - - let remove_vertex g v = - if HM.mem v g.edges then - let remove v s = - S.fold - (fun (v2, _ as e) s -> if not (V.equal v v2) then S.add e s else s) - s S.empty - in - let edges = HM.remove v g.edges in - { edges = - HM.fold (fun k s g -> HM.add k (remove v s) g) edges HM.empty; - size = Pervasives.pred g.size } - else - g - - let remove_edge g v1 v2 = { g with edges = remove_edge g v1 v2 } - let remove_edge_e g e = { g with edges = remove_edge_e g e } - - end - -end - -module Graph = struct - - module Concrete(V: COMPARABLE) = struct - - module G = Digraph.Concrete(V) - - include Graph(G) - - (* Export some definitions of [G] *) - - let empty = G.empty - let add_vertex = G.add_vertex - let remove_vertex = G.remove_vertex - - (* Redefine the [add_edge] and [remove_edge] operations *) - - let add_edge g v1 v2 = - let g = G.add_edge g v1 v2 in - assert (G.HM.mem v1 g && G.HM.mem v2 g); - G.unsafe_add_edge g v2 v1 - - let add_edge_e g (v1, v2) = add_edge g v1 v2 - - let remove_edge g v1 v2 = - let g = G.remove_edge g v1 v2 in - assert (G.HM.mem v1 g && G.HM.mem v2 g); - G.unsafe_remove_edge g v2 v1 - - let remove_edge_e g (v1, v2) = remove_edge g v1 v2 - - end - - module ConcreteLabeled(V: COMPARABLE)(Edge: ORDERED_TYPE_DFT) = struct - - module G = Digraph.ConcreteLabeled(V)(Edge) - - include Graph(G) - - (* Export some definitions of [G] *) - - let empty = G.empty - let add_vertex = G.add_vertex - let remove_vertex = G.remove_vertex - - (* Redefine the [add_edge] and [remove_edge] operations *) - - let add_edge_e g (v1, l, v2 as e) = - let g = G.add_edge_e g e in - assert (G.HM.mem v1 g && G.HM.mem v2 g); - G.unsafe_add_edge g v2 (v1, l) - - let add_edge g v1 v2 = add_edge_e g (v1, Edge.default, v2) - - let remove_edge g v1 v2 = - let g = G.remove_edge g v1 v2 in - assert (G.HM.mem v1 g && G.HM.mem v2 g); - G.unsafe_remove_edge g v2 v1 - - let remove_edge_e g (v1, l, v2 as e) = - let g = G.remove_edge_e g e in - assert (G.HM.mem v1 g && G.HM.mem v2 g); - G.unsafe_remove_edge_e g (v2, l, v1) - - end - - module Abstract(V: sig type t end) = struct - - module G = Digraph.Abstract(V) - - include Graph(G) - - (* Export some definitions of [G] *) - - let empty = G.empty - let add_vertex = G.add_vertex - let remove_vertex = G.remove_vertex - - (* Redefine the [add_edge] and [remove_edge] operations *) - - let add_edge g v1 v2 = - let g = G.add_edge g v1 v2 in - assert (G.HM.mem v1 g.G.edges && G.HM.mem v2 g.G.edges); - { g with G.edges = G.unsafe_add_edge g.G.edges v2 v1 } - - let add_edge_e g (v1, v2) = add_edge g v1 v2 - - let remove_edge g v1 v2 = - let g = G.remove_edge g v1 v2 in - assert (G.HM.mem v1 g.G.edges && G.HM.mem v2 g.G.edges); - { g with G.edges = G.unsafe_remove_edge g.G.edges v2 v1 } - - let remove_edge_e g (v1, v2) = remove_edge g v1 v2 - - end - - module AbstractLabeled (V: sig type t end)(Edge: ORDERED_TYPE_DFT) = struct - - module G = Digraph.AbstractLabeled(V)(Edge) - - include Graph(G) - - (* Export some definitions of [G] *) - - let empty = G.empty - let add_vertex = G.add_vertex - let remove_vertex = G.remove_vertex - - (* Redefine the [add_edge] and [remove_edge] operations *) - - let add_edge_e g (v1, l, v2 as e) = - let g = G.add_edge_e g e in - assert (G.HM.mem v1 g.G.edges && G.HM.mem v2 g.G.edges); - { g with G.edges = G.unsafe_add_edge g.G.edges v2 (v1, l) } - - let add_edge g v1 v2 = add_edge_e g (v1, Edge.default, v2) - - let remove_edge g v1 v2 = - let g = G.remove_edge g v1 v2 in - assert (G.HM.mem v1 g.G.edges && G.HM.mem v2 g.G.edges); - { g with G.edges = G.unsafe_remove_edge g.G.edges v2 v1 } - - let remove_edge_e g (v1, l, v2 as e) = - let g = G.remove_edge_e g e in - assert (G.HM.mem v1 g.G.edges && G.HM.mem v2 g.G.edges); - { g with G.edges = G.unsafe_remove_edge_e g.G.edges (v2, l, v1) } - - end - -end diff --git a/external/ocamlgraph/src/persistent.mli b/external/ocamlgraph/src/persistent.mli deleted file mode 100644 --- a/external/ocamlgraph/src/persistent.mli +++ /dev/null @@ -1,50 +0,0 @@ -(**************************************************************************) -(* *) -(* Ocamlgraph: a generic graph library for OCaml *) -(* Copyright (C) 2004-2007 *) -(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) -(* *) -(* This software is free software; you can redistribute it and/or *) -(* modify it under the terms of the GNU Library General Public *) -(* License version 2, with the special exception on linking *) -(* described in file LICENSE. *) -(* *) -(* This software is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) -(* *) -(**************************************************************************) - -(* $Id: persistent.mli,v 1.13 2006-05-12 14:07:16 filliatr Exp $ *) - -(** Persistent Implementations *) - -open Sig - -(** Signature of persistent graphs *) -module type S = sig - - (** Persistent Unlabeled Graphs *) - module Concrete (V: COMPARABLE) : - Sig.P with type V.t = V.t and type V.label = V.t and type E.t = V.t * V.t - - (** Abstract Persistent Unlabeled Graphs *) - module Abstract(V: ANY_TYPE) : Sig.P with type V.label = V.t - - (** Persistent Labeled Graphs *) - module ConcreteLabeled (V: COMPARABLE)(E: ORDERED_TYPE_DFT) : - Sig.P with type V.t = V.t and type V.label = V.t - and type E.t = V.t * E.t * V.t and type E.label = E.t - - (** Abstract Persistent Labeled Graphs *) - module AbstractLabeled (V: ANY_TYPE)(E: ORDERED_TYPE_DFT) : - Sig.P with type V.label = V.t and type E.label = E.t - -end - -(** Persistent Directed Graphs *) -module Digraph : S - -(** Persistent Undirected Graphs *) -module Graph : S - diff --git a/external/ocamlgraph/src/rand.ml b/external/ocamlgraph/src/rand.ml deleted file mode 100644 --- a/external/ocamlgraph/src/rand.ml +++ /dev/null @@ -1,207 +0,0 @@ -(**************************************************************************) -(* *) -(* Ocamlgraph: a generic graph library for OCaml *) -(* Copyright (C) 2004-2007 *) -(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) -(* *) -(* This software is free software; you can redistribute it and/or *) -(* modify it under the terms of the GNU Library General Public *) -(* License version 2, with the special exception on linking *) -(* described in file LICENSE. *) -(* *) -(* This software is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) -(* *) -(**************************************************************************) - -(* $Id: rand.ml,v 1.18 2005-03-31 13:32:51 filliatr Exp $ *) - -module type S = sig - type graph - type vertex - type edge_label - val graph : ?loops:bool -> v:int -> e:int -> unit -> graph - val labeled : - (vertex -> vertex -> edge_label) -> - ?loops:bool -> v:int -> e:int -> unit -> graph - (* DEBUG *) - val random_few_edges : loops:bool -> v:int -> e:int -> graph - val random_many_edges : loops:bool -> v:int -> e:int -> graph -end - -module Make(B : Builder.INT) = struct - - open B - type graph = G.t - type vertex = G.V.t - type edge_label = G.E.label - - open Int64 - - let max_edges ~loops ~v ~e = - if v <= 0 || e < 0 then invalid_arg "random"; - let v64 = of_int v in - let max_e = mul v64 (pred v64) in - let max_e = if G.is_directed then max_e else div max_e (of_int 2) in - let max_e = if loops then add max_e v64 else max_e in - if of_int e > max_e then invalid_arg "random: too many edges"; - max_e - - let fold_for i0 i1 f = - let rec loop i v = if i > i1 then v else loop (i + 1) (f v i) in - loop i0 - - (* naive implementation: we randomly chose edges up to [e] different edges *) - let random_few_edges add_edge ~loops ~v ~e = - let _ = max_edges ~loops ~v ~e in - let a = Array.init v G.V.create in - let g = Array.fold_left add_vertex (empty ()) a in - let rec random_edge g = - let i = Random.int v in - let j = Random.int v in - if (i = j && not loops) || G.mem_edge g a.(i) a.(j) then - random_edge g - else - add_edge g a.(i) a.(j) - in - fold_for 1 e (fun g _ -> random_edge g) g - - (* other implementation in O(v * v); faster when [e] is large *) - let random_many_edges add_edge ~loops ~v ~e = - let v64 = of_int v in - let max_e = max_edges ~loops ~v ~e in - let a = Array.init v G.V.create in - let g = Array.fold_left add_vertex (empty ()) a in - let rec add_edges i j max nb g = - assert - (max >= 0L && - max_e = - add max (add (mul (of_int i) v64) - (of_int - (j - - (match G.is_directed, loops with - | true, true -> 0 - | true, false -> if j > i then i + 1 else i - | false, true -> i * (i - 1) / 2 + if j > i then i else j - | false, false -> i*(i+1)/2 + if j > i then i+1 else j))))); - if nb = 0 then - g - else - let add_edges = - let i, j = if j = v - 1 then i + 1, 0 else i, j + 1 in - add_edges i j - in - if (i = j && not loops) || (not G.is_directed && i > j) then - add_edges max nb g - else - let add_edges = add_edges (pred max) in - if Random.int64 max < of_int nb then - add_edges (nb - 1) (add_edge g a.(i) a.(j)) - else - add_edges nb g - in - add_edges 0 0 max_e e g - - let random ~loops ~v ~e = - let r = float e /. (float v *. float v) in - (if r < 0.4 then random_few_edges else random_many_edges) ~loops ~v ~e - - let graph ?(loops=false) ~v ~e () = random B.add_edge ~loops ~v ~e - - let labeled f ?(loops=false) ~v ~e () = - random - (fun g v1 v2 -> B.add_edge_e g (G.E.create v1 (f v1 v2) v2)) - ~loops ~v ~e - - (* DEBUG *) - let random_few_edges = random_few_edges B.add_edge - let random_many_edges = random_many_edges B.add_edge - -end - -module P (G : Sig.P with type V.label = int) = Make(Builder.P(G)) - -module I (G : Sig.I with type V.label = int) = Make(Builder.I(G)) - - -(** Random planar graphs *) - -module Planar = struct - - module type S = sig - type graph - val graph : - ?loops:bool -> xrange:int*int -> yrange:int*int -> - prob:float -> int -> graph - end - - module Make - (B : Builder.S with type G.V.label = int * int and type G.E.label = int) = - struct - - type graph = B.G.t - open B.G - - module Point = struct - type point = V.t - let ccw v1 v2 v3 = - Delaunay.IntPoints.ccw (V.label v1) (V.label v2) (V.label v3) - let in_circle v1 v2 v3 v4 = - Delaunay.IntPoints.in_circle - (V.label v1) (V.label v2) (V.label v3) (V.label v4) - let distance v1 v2 = - let x1,y1 = V.label v1 in - let x2,y2 = V.label v2 in - let sqr x = let x = float x in x *. x in - truncate (sqrt (sqr (x1 - x2) +. sqr (y1 - y2))) - end - - module Triangulation = Delaunay.Make(Point) - - let graph ?(loops=false) ~xrange:(xmin,xmax) ~yrange:(ymin,ymax) ~prob v = - if not (0.0 <= prob && prob <= 1.0) then invalid_arg "Planar.graph"; - if v < 2 then invalid_arg "Planar.graph"; - (* [v] random points and their Delaunay triangulation *) - let random_point () = - xmin + Random.int (1 + xmax - xmin), - ymin + Random.int (1 + ymax - ymin) - in - let vertices = Array.init v (fun _ -> V.create (random_point ())) in - let t = Triangulation.triangulate vertices in - (* a graph with [v] vertices and random loops if any *) - let g = Array.fold_left B.add_vertex (B.empty ()) vertices in - let g = - if loops then - Array.fold_left - (fun g v -> - if Random.float 1.0 < prob then - g - else - let e = E.create v 0 v in B.add_edge_e g e) - g vertices - else - g - in - (* we keep some edges from the triangulation according to [prob] *) - let add_edge v1 v2 g = - if Random.float 1.0 < prob then - g - else - let e = E.create v1 (Point.distance v1 v2) v2 in B.add_edge_e g e - in - Triangulation.fold - (fun v1 v2 g -> - let g = add_edge v1 v2 g in - if is_directed then add_edge v2 v1 g else g) - t g - - end - - module P (G : Sig.P with type V.label = int * int and type E.label = int) = - Make(Builder.P(G)) - - module I (G : Sig.I with type V.label = int * int and type E.label = int) = - Make(Builder.I(G)) - -end diff --git a/external/ocamlgraph/src/rand.mli b/external/ocamlgraph/src/rand.mli deleted file mode 100644 --- a/external/ocamlgraph/src/rand.mli +++ /dev/null @@ -1,111 +0,0 @@ -(**************************************************************************) -(* *) -(* Ocamlgraph: a generic graph library for OCaml *) -(* Copyright (C) 2004-2007 *) -(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) -(* *) -(* This software is free software; you can redistribute it and/or *) -(* modify it under the terms of the GNU Library General Public *) -(* License version 2, with the special exception on linking *) -(* described in file LICENSE. *) -(* *) -(* This software is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) -(* *) -(**************************************************************************) - -(* $Id: rand.mli,v 1.12 2005-03-31 13:32:51 filliatr Exp $ *) - -(** Random graph generation *) - -(** {1 Random graphs} *) - -module type S = sig - - type graph - type vertex - type edge_label - - val graph : ?loops:bool -> v:int -> e:int -> unit -> graph - (** [graph v e] generates a random graph with exactly [v] vertices - and [e] edges. Vertices are labeled with [0] ... [v-1]. - The boolean [loops] indicates whether loops are allowed; - default value is no loop ([false]). - @raise Invalid_argument if [e] exceeds the maximal number of edges. *) - - val labeled : - (vertex -> vertex -> edge_label) -> - ?loops:bool -> v:int -> e:int -> unit -> graph - (** [labeled f] is similar to [graph] except that edges are labeled - using function [f]. - @raise Invalid_argument if there are too many edges. *) - - (** The two functions above actually make a choice between two - different implementations according to the ratio e/(v*v). - When this ratio is small, [random_few_edges] is selected; - otherwise [random_many_edges] is selected. *) - - val random_few_edges : loops:bool -> v:int -> e:int -> graph - val random_many_edges : loops:bool -> v:int -> e:int -> graph - -end - -module Make(B: Builder.INT) : - S with type graph = B.G.t - and type vertex = B.G.V.t - and type edge_label = B.G.E.label - (** Random graphs *) - -module P (G : Sig.P with type V.label = int) : - S with type graph = G.t - and type vertex = G.V.t - and type edge_label = G.E.label - (** Random persistent graphs *) - -module I (G : Sig.I with type V.label = int) : - S with type graph = G.t - and type vertex = G.V.t - and type edge_label = G.E.label - (** Random imperative graphs *) - -(** {1 Random planar graphs} *) - -module Planar : sig - - module type S = sig - - type graph - - val graph : - ?loops:bool -> xrange:int*int -> yrange:int*int -> - prob:float -> int -> graph - (** [graph xrange yrange prob v] - generates a random planar graph with exactly [v] vertices. - Vertices are labeled with integer coordinates, randomly distributed - according to [xrange] and [yrange]. - Edges are built as follows: the full Delaunay triangulation is - constructed and then each edge is discarded with probabiblity [prob] - (which should lie in [0..1]). In particular [prob = 0.0] gives the - full triangulation. - Edges are labeled with the (rounded) Euclidean distance between - the two vertices. - The boolean [loops] indicates whether loops are allowed; - default value is no loop ([false]). *) - - end - - module Make - (B : Builder.S with type G.V.label = int * int and type G.E.label = int) : - S with type graph = B.G.t - (** Random planar graphs *) - - module P (G : Sig.P with type V.label = int * int and type E.label = int) : - S with type graph = G.t - (** Random persistent planar graphs *) - - module I (G : Sig.I with type V.label = int * int and type E.label = int) : - S with type graph = G.t - (** Random imperative planar graphs *) - -end diff --git a/external/ocamlgraph/src/sig.mli b/external/ocamlgraph/src/sig.mli deleted file mode 100644 --- a/external/ocamlgraph/src/sig.mli +++ /dev/null @@ -1,309 +0,0 @@ -(**************************************************************************) -(* *) -(* Ocamlgraph: a generic graph library for OCaml *) -(* Copyright (C) 2004-2007 *) -(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) -(* *) -(* This software is free software; you can redistribute it and/or *) -(* modify it under the terms of the GNU Library General Public *) -(* License version 2, with the special exception on linking *) -(* described in file LICENSE. *) -(* *) -(* This software is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) -(* *) -(**************************************************************************) - -(* $Id: sig.mli,v 1.21 2006-05-12 14:07:16 filliatr Exp $ *) - -(** Signatures for graph implementations *) - -(** {2 Signatures for graph implementations} *) - -(** Interface for vertices *) - -module type VERTEX = sig - - (** Vertices are [COMPARABLE] *) - - type t - val compare : t -> t -> int - val hash : t -> int - val equal : t -> t -> bool - - (** Vertices are labeled. *) - - type label - val create : label -> t - val label : t -> label - -end - -(** Interface for edges *) - -module type EDGE = sig - - (** Edges are [ORDERED]. *) - - type t - val compare : t -> t -> int - - (** Edges are directed. *) - - type vertex - val src : t -> vertex - val dst : t -> vertex - - (** Edges are labeled. *) - - type label - val create : vertex -> label -> vertex -> t - (** [create v1 l v2] creates an edge from [v1] to [v2] with label [l] *) - val label : t -> label - -end - -(** Common interface for all graph implementations *) - -module type G = sig - - (** {2 Graph structure} *) - - (** Abstract type of graphs *) - type t - - (** Vertices have type [V.t] and are labeled with type [V.label] - (note that an implementation may identify the vertex with its - label) *) - module V : VERTEX - - type vertex = V.t - - (** Edges have type [E.t] and are labeled with type [E.label]. - [src] (resp. [dst]) returns the origin (resp. the destination) of a - given edge. *) - module E : EDGE with type vertex = vertex - - type edge = E.t - - (** Is this an implementation of directed graphs? *) - val is_directed : bool - - (** {2 Size functions} *) - - val is_empty : t -> bool - val nb_vertex : t -> int - val nb_edges : t -> int - - (** Degree of a vertex *) - - val out_degree : t -> vertex -> int - (** [out_degree g v] returns the out-degree of [v] in [g]. - @raise Invalid_argument if [v] is not in [g]. *) - - val in_degree : t -> vertex -> int - (** [in_degree g v] returns the in-degree of [v] in [g]. - @raise Invalid_argument if [v] is not in [g]. *) - - (** {2 Membership functions} *) - - val mem_vertex : t -> vertex -> bool - val mem_edge : t -> vertex -> vertex -> bool - val mem_edge_e : t -> edge -> bool - - val find_edge : t -> vertex -> vertex -> edge - (** [find_edge g v1 v2] returns the edge from [v1] to [v2] if it exists. - The behaviour is unspecified if [g] has several edges from [v1] to [v2]. - @raise Not_found if no such edge exists. *) - - (** {2 Successors and predecessors} *) - - val succ : t -> vertex -> vertex list - (** [succ g v] returns the successors of [v] in [g]. - @raise Invalid_argument if [v] is not in [g]. *) - - val pred : t -> vertex -> vertex list - (** [pred g v] returns the predecessors of [v] in [g]. - @raise Invalid_argument if [v] is not in [g]. *) - - (** Labeled edges going from/to a vertex *) - - val succ_e : t -> vertex -> edge list - (** [succ_e g v] returns the edges going from [v] in [g]. - @raise Invalid_argument if [v] is not in [g]. *) - - val pred_e : t -> vertex -> edge list - (** [pred_e g v] returns the edges going to [v] in [g]. - @raise Invalid_argument if [v] is not in [g]. *) - - (** {2 Graph iterators} *) - - (** iter/fold on all vertices/edges of a graph *) - - val iter_vertex : (vertex -> unit) -> t -> unit - val iter_edges : (vertex -> vertex -> unit) -> t -> unit - val fold_vertex : (vertex -> 'a -> 'a) -> t -> 'a -> 'a - val fold_edges : (vertex -> vertex -> 'a -> 'a) -> t -> 'a -> 'a - - (** map iterator on vertex *) - val map_vertex : (vertex -> vertex) -> t -> t - - (** iter/fold on all labeled edges of a graph *) - - val iter_edges_e : (edge -> unit) -> t -> unit - val fold_edges_e : (edge -> 'a -> 'a) -> t -> 'a -> 'a - - (** {2 Vertex iterators} - - Each iterator [iterator f v g] iters [f] to the successors/predecessors - of [v] in the graph [g] and raises [Invalid_argument] if [v] is not in - [g]. *) - - (** iter/fold on all successors/predecessors of a vertex. *) - - val iter_succ : (vertex -> unit) -> t -> vertex -> unit - val iter_pred : (vertex -> unit) -> t -> vertex -> unit - val fold_succ : (vertex -> 'a -> 'a) -> t -> vertex -> 'a -> 'a - val fold_pred : (vertex -> 'a -> 'a) -> t -> vertex -> 'a -> 'a - - (** iter/fold on all edges going from/to a vertex. *) - - val iter_succ_e : (edge -> unit) -> t -> vertex -> unit - val fold_succ_e : (edge -> 'a -> 'a) -> t -> vertex -> 'a -> 'a - val iter_pred_e : (edge -> unit) -> t -> vertex -> unit - val fold_pred_e : (edge -> 'a -> 'a) -> t -> vertex -> 'a -> 'a - -end - -(** Persistent (i.e. immutable) implementation *) - -module type P = sig - include G - - val empty : t - (** The empty graph. *) - - val add_vertex : t -> vertex -> t - (** [add_vertex g v] adds the vertex [v] from the graph [g]. - Just return [g] if [v] is already in [g]. *) - - val remove_vertex : t -> vertex -> t - (** [remove g v] removes the vertex [v] from the graph [g] - (and all the edges going from [v] in [g]). - Just return [g] if [v] is not in [g]. *) - - val add_edge : t -> vertex -> vertex -> t - (** [add_edge g v1 v2] adds an edge from the vertex [v1] to the vertex [v2] - in the graph [g]. - Add also [v1] (resp. [v2]) in [g] if [v1] (resp. [v2]) is not in [g]. - Just return [g] if this edge is already in [g]. *) - - val add_edge_e : t -> edge -> t - (** [add_edge_e g e] adds the edge [e] in the graph [g]. - Add also [E.src e] (resp. [E.dst e]) in [g] if [E.src e] (resp. [E.dst - e]) is not in [g]. - Just return [g] if [e] is already in [g]. *) - - val remove_edge : t -> vertex -> vertex -> t - (** [remove_edge g v1 v2] removes the edge going from [v1] to [v2] from the - graph [g]. If the graph is labelled, all the edges going from [v1] to - [v2] are removed from [g]. - Just return [g] if this edge is not in [g]. - @raise Invalid_argument if [v1] or [v2] are not in [g]. *) - - val remove_edge_e : t -> edge -> t - (** [remove_edge_e g e] removes the edge [e] from the graph [g]. - Just return [g] if [e] is not in [g]. - @raise Invalid_argument if [E.src e] or [E.dst e] are not in [g]. *) - -end - -(** Imperative (i.e. mutable) implementation *) - -module type I = sig - include G - - val create : ?size:int -> unit -> t - (** [create ()] returns an empty graph. Optionally, a size can be - given, which should be on the order of the expected number of - vertices that will be in the graph (for hash tables-based - implementations). The graph grows as needed, so [size] is - just an initial guess. *) - - val copy : t -> t - (** [copy g] returns a copy of [g]. Vertices and edges (and eventually - marks, see module [Mark]) are duplicated. *) - - val add_vertex : t -> vertex -> unit - (** [add_vertex g v] adds the vertex [v] from the graph [g]. - Do nothing if [v] is already in [g]. *) - - val remove_vertex : t -> vertex -> unit - (** [remove g v] removes the vertex [v] from the graph [g] - (and all the edges going from [v] in [g]). - Do nothing if [v] is not in [g]. *) - - val add_edge : t -> vertex -> vertex -> unit - (** [add_edge g v1 v2] adds an edge from the vertex [v1] to the vertex [v2] - in the graph [g]. - Add also [v1] (resp. [v2]) in [g] if [v1] (resp. [v2]) is not in [g]. - Do nothing if this edge is already in [g]. *) - - val add_edge_e : t -> edge -> unit - (** [add_edge_e g e] adds the edge [e] in the graph [g]. - Add also [E.src e] (resp. [E.dst e]) in [g] if [E.src e] (resp. [E.dst - e]) is not in [g]. - Do nothing if [e] is already in [g]. *) - - val remove_edge : t -> vertex -> vertex -> unit - (** [remove_edge g v1 v2] removes the edge going from [v1] to [v2] from the - graph [g]. If the graph is labelled, all the edges going from [v1] to - [v2] are removed from [g]. - Do nothing if this edge is not in [g]. - @raise Invalid_argument if [v1] or [v2] are not in [g]. *) - - val remove_edge_e : t -> edge -> unit - (** [remove_edge_e g e] removes the edge [e] from the graph [g]. - Do nothing if [e] is not in [g]. - @raise Invalid_argument if [E.src e] or [E.dst e] are not in [g]. *) - -end - -(** Imperative implementation with marks *) - -module type MARK = sig - type graph - type vertex - val clear : graph -> unit - (** [clear g] sets all the marks to 0 for all the vertices of [g]. *) - val get : vertex -> int - val set : vertex -> int -> unit -end - -module type IM = sig - include I - module Mark : MARK with type graph = t and type vertex = vertex -end - -(** {2 Signature for ordered and hashable types} *) - -module type ANY_TYPE = sig type t end - -module type ORDERED_TYPE = sig type t val compare : t -> t -> int end - -module type ORDERED_TYPE_DFT = sig include ORDERED_TYPE val default : t end - -module type HASHABLE = sig - type t - val hash : t -> int - val equal : t -> t -> bool -end - -(** Comparable = Ordered + Hashable *) -module type COMPARABLE = sig - type t - val compare : t -> t -> int - val hash : t -> int - val equal : t -> t -> bool -end diff --git a/external/ocamlgraph/src/sig_pack.mli b/external/ocamlgraph/src/sig_pack.mli deleted file mode 100644 --- a/external/ocamlgraph/src/sig_pack.mli +++ /dev/null @@ -1,376 +0,0 @@ -(**************************************************************************) -(* *) -(* Ocamlgraph: a generic graph library for OCaml *) -(* Copyright (C) 2004-2007 *) -(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) -(* *) -(* This software is free software; you can redistribute it and/or *) -(* modify it under the terms of the GNU Library General Public *) -(* License version 2, with the special exception on linking *) -(* described in file LICENSE. *) -(* *) -(* This software is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) -(* *) -(**************************************************************************) - -(* $Id: sig_pack.mli,v 1.23 2005-07-18 07:10:35 filliatr Exp $ *) - -(** Immediate access to the library. - Signature [S] gathers an imperative implementation and all algorithms into - a single module. - Vertices and edges are labeled with integers. *) - -module type S = sig - - (** {2 Graph structure} *) - - (** abstract type of graphs *) - type t - - (** Vertices *) - module V : sig - (** Vertices are [COMPARABLE] *) - - type t - val compare : t -> t -> int - val hash : t -> int - val equal : t -> t -> bool - - (** vertices are labeled with integers *) - - type label = int - val create : label -> t - val label : t -> label - end - - type vertex = V.t - - (** Edges *) - module E : sig - (** Edges are [ORDERED]. *) - - type t - val compare : t -> t -> int - - (** Edges are directed. *) - - val src : t -> V.t - val dst : t -> V.t - - (** Edges are labeled with integers. *) - - type label = int - val create : V.t -> label -> V.t -> t - (** [create v1 l v2] creates an edge from [v1] to [v2] with label [l] *) - val label : t -> label - - type vertex = V.t - end - - type edge = E.t - - (** is this an implementation of directed graphs? *) - val is_directed : bool - - (** {2 Graph constructors and destructors} *) - - val create : ?size:int -> unit -> t - (** Return an empty graph. Optionally, a size can be - given, which should be on the order of the expected number of - vertices that will be in the graph (for hash tables-based - implementations). The graph grows as needed, so [size] is - just an initial guess. *) - - val copy : t -> t - (** [copy g] returns a copy of [g]. Vertices and edges (and eventually - marks, see module [Mark]) are duplicated. *) - - val add_vertex : t -> V.t -> unit - (** [add_vertex g v] adds the vertex [v] from the graph [g]. - Do nothing if [v] is already in [g]. *) - - val remove_vertex : t -> V.t -> unit - (** [remove g v] removes the vertex [v] from the graph [g] - (and all the edges going from [v] in [g]). - Do nothing if [v] is not in [g]. *) - - val add_edge : t -> V.t -> V.t -> unit - (** [add_edge g v1 v2] adds an edge from the vertex [v1] to the vertex [v2] - in the graph [g]. - Add also [v1] (resp. [v2]) in [g] if [v1] (resp. [v2]) is not in [g]. - Do nothing if this edge is already in [g]. *) - - val add_edge_e : t -> E.t -> unit - (** [add_edge_e g e] adds the edge [e] in the graph [g]. - Add also [E.src e] (resp. [E.dst e]) in [g] if [E.src e] (resp. [E.dst - e]) is not in [g]. - Do nothing if [e] is already in [g]. *) - - val remove_edge : t -> V.t -> V.t -> unit - (** [remove_edge g v1 v2] removes the edge going from [v1] to [v2] from the - graph [g]. - Do nothing if this edge is not in [g]. - @raise Invalid_argument if [v1] or [v2] are not in [g]. *) - - val remove_edge_e : t -> E.t -> unit - (** [remove_edge_e g e] removes the edge [e] from the graph [g]. - Do nothing if [e] is not in [g]. - @raise Invalid_argument if [E.src e] or [E.dst e] are not in [g]. *) - - (** Vertices contains integers marks, which can be set or used by some - algorithms (see for instance module [Marking] below) *) - module Mark : sig - type graph = t - type vertex = V.t - val clear : t -> unit - (** [clear g] sets all marks to 0 from all the vertives of [g]. *) - val get : V.t -> int - val set : V.t -> int -> unit - end - - (** {2 Size functions} *) - - val is_empty : t -> bool - val nb_vertex : t -> int - val nb_edges : t -> int - - (** Degree of a vertex *) - - val out_degree : t -> V.t -> int - (** [out_degree g v] returns the out-degree of [v] in [g]. - @raise Invalid_argument if [v] is not in [g]. *) - - val in_degree : t -> V.t -> int - (** [in_degree g v] returns the in-degree of [v] in [g]. - @raise Invalid_argument if [v] is not in [g]. *) - - (** {2 Membership functions} *) - - val mem_vertex : t -> V.t -> bool - val mem_edge : t -> V.t -> V.t -> bool - val mem_edge_e : t -> E.t -> bool - val find_edge : t -> V.t -> V.t -> E.t - - (** {2 Successors and predecessors of a vertex} *) - - val succ : t -> V.t -> V.t list - (** [succ g v] returns the successors of [v] in [g]. - @raise Invalid_argument if [v] is not in [g]. *) - - val pred : t -> V.t -> V.t list - (** [pred g v] returns the predecessors of [v] in [g]. - @raise Invalid_argument if [v] is not in [g]. *) - - (** Labeled edges going from/to a vertex *) - - val succ_e : t -> V.t -> E.t list - (** [succ_e g v] returns the edges going from [v] in [g]. - @raise Invalid_argument if [v] is not in [g]. *) - - val pred_e : t -> V.t -> E.t list - (** [pred_e g v] returns the edges going to [v] in [g]. - @raise Invalid_argument if [v] is not in [g]. *) - - (** {2 Graph iterators} *) - - (** iter/fold on all vertices/edges of a graph *) - - val iter_vertex : (V.t -> unit) -> t -> unit - val iter_edges : (V.t -> V.t -> unit) -> t -> unit - val fold_vertex : (V.t -> 'a -> 'a) -> t -> 'a -> 'a - val fold_edges : (V.t -> V.t -> 'a -> 'a) -> t -> 'a -> 'a - - (** map iterator on vertex *) - val map_vertex : (V.t -> V.t) -> t -> t - - (** iter/fold on all labeled edges of a graph *) - - val iter_edges_e : (E.t -> unit) -> t -> unit - val fold_edges_e : (E.t -> 'a -> 'a) -> t -> 'a -> 'a - - (** {2 Vertex iterators} - - Each iterator [iterator f v g] iters [f] to the successors/predecessors - of [v] in the graph [g] and raises [Invalid_argument] if [v] is not in - [g]. *) - - (** iter/fold on all successors/predecessors of a vertex. *) - - val iter_succ : (V.t -> unit) -> t -> V.t -> unit - val iter_pred : (V.t -> unit) -> t -> V.t -> unit - val fold_succ : (V.t -> 'a -> 'a) -> t -> V.t -> 'a -> 'a - val fold_pred : (V.t -> 'a -> 'a) -> t -> V.t -> 'a -> 'a - - (** iter/fold on all edges going from/to a vertex. *) - - val iter_succ_e : (E.t -> unit) -> t -> V.t -> unit - val fold_succ_e : (E.t -> 'a -> 'a) -> t -> V.t -> 'a -> 'a - val iter_pred_e : (E.t -> unit) -> t -> V.t -> unit - val fold_pred_e : (E.t -> 'a -> 'a) -> t -> V.t -> 'a -> 'a - - (** {2 Basic operations} *) - - val find_vertex : t -> int -> V.t - (** [vertex g i] returns a vertex of label [i] in [g]. The behaviour is - unspecified if [g] has several vertices with label [i]. - Note: this function is inefficient (linear in the number of vertices); - you should better keep the vertices as long as you create them. *) - - val transitive_closure : ?reflexive:bool -> t -> t - (** [transitive_closure ?reflexive g] returns the transitive closure - of [g] (as a new graph). Loops (i.e. edges from a vertex to itself) - are added only if [reflexive] is [true] (default is [false]). *) - - val add_transitive_closure : ?reflexive:bool -> t -> t - (** [add_transitive_closure ?reflexive g] replaces [g] by its - transitive closure. Meaningless for persistent implementations - (then acts as [transitive_closure]). *) - - val mirror : t -> t - (** [mirror g] returns a new graph which is the mirror image of [g]: - each edge from [u] to [v] has been replaced by an edge from [v] to [u]. - For undirected graphs, it simply returns a copy of [g]. *) - - val complement : t -> t - (** [complement g] builds a new graph which is the complement of [g]: - each edge present in [g] is not present in the resulting graph and - vice-versa. Edges of the returned graph are unlabeled. *) - - val intersect : t -> t -> t - (** [intersect g1 g2] returns a new graph which is the intersection of [g1] - and [g2]: each vertex and edge present in [g1] *and* [g2] is present - in the resulting graph. *) - - val union : t -> t -> t - (** [union g1 g2] returns a new graph which is the union of [g1] and [g2]: - each vertex and edge present in [g1] *or* [g2] is present in the - resulting graph. *) - - (** {2 Traversal} *) - - (** Depth-first search *) - module Dfs : sig - val iter : ?pre:(V.t -> unit) -> - ?post:(V.t -> unit) -> t -> unit - (** [iter pre post g] visits all nodes of [g] in depth-first search, - applying [pre] to each visited node before its successors, - and [post] after them. Each node is visited exactly once. *) - val prefix : (V.t -> unit) -> t -> unit - (** applies only a prefix function *) - val postfix : (V.t -> unit) -> t -> unit - (** applies only a postfix function *) - - (** Same thing, but for a single connected component *) - - val iter_component : - ?pre:(V.t -> unit) -> - ?post:(V.t -> unit) -> t -> V.t -> unit - val prefix_component : (V.t -> unit) -> t -> V.t -> unit - val postfix_component : (V.t -> unit) -> t -> V.t -> unit - - val has_cycle : t -> bool - end - - (** Breadth-first search *) - module Bfs : sig - val iter : (V.t -> unit) -> t -> unit - val iter_component : (V.t -> unit) -> t -> V.t -> unit - end - - (** Graph traversal with marking *) - module Marking : sig - val dfs : t -> unit - val has_cycle : t -> bool - end - - (** {2 Graph generators} *) - - (** Classic graphs *) - module Classic : sig - val divisors : int -> t - (** [divisors n] builds the graph of divisors. - Vertices are integers from [2] to [n]. [i] is connected to [j] if - and only if [i] divides [j]. - @raise Invalid_argument is [n < 2]. *) - - val de_bruijn : int -> t - (** [de_bruijn n] builds the de Bruijn graph of order [n]. - Vertices are bit sequences of length [n] (encoded as their - interpretation as binary integers). The sequence [xw] is connected - to the sequence [wy] for any bits [x] and [y] and any bit sequence - [w] of length [n-1]. - @raise Invalid_argument is [n < 1] or [n > Sys.word_size-1]. *) - - val vertex_only : int -> t - (** [vertex_only n] builds a graph with [n] vertices and no edge. *) - - val full : ?self:bool -> int -> t - (** [full n] builds a graph with [n] vertices and all possible edges. - The optional argument [self] indicates if loop edges should be added - (default value is [true]). *) - end - - (** Random graphs *) - module Rand : sig - val graph : ?loops:bool -> v:int -> e:int -> unit -> t - (** [random v e] generates a random with [v] vertices and [e] edges. *) - - val labeled : - (V.t -> V.t -> E.label) -> - ?loops:bool -> v:int -> e:int -> unit -> t - (** [random_labeled f] is similar to [random] except that edges are - labeled using function [f] *) - end - - (** Strongly connected components *) - module Components : sig - val scc : t -> int*(V.t -> int) - (** strongly connected components *) - val scc_array : t -> V.t list array - val scc_list : t -> V.t list list - end - - (** {2 Classical algorithms} *) - - val shortest_path : t -> V.t -> V.t -> E.t list * int - (** Dijkstra's shortest path algorithm. Weights are the labels. *) - - val ford_fulkerson : t -> V.t -> V.t -> (E.t -> int) * int - (** Ford Fulkerson maximum flow algorithm *) - - val goldberg : t -> V.t -> V.t -> (E.t -> int) * int - (** Goldberg maximum flow algorithm *) - - (** Path checking *) - module PathCheck : sig - type path_checker - val create : t -> path_checker - val check_path : path_checker -> V.t -> V.t -> bool - end - - (** Topological order *) - module Topological : sig - val fold : (V.t -> 'a -> 'a) -> t -> 'a -> 'a - val iter : (V.t -> unit) -> t -> unit - end - - val spanningtree : t -> E.t list - (** Kruskal algorithm *) - - (** {2 Input / Output} *) - - val dot_output : t -> string -> unit - (** DOT output *) - - val display_with_gv : t -> unit - (** Displays the given graph using the external tools "dot" and "gv" - and returns when gv's window is closed *) - - val parse_gml_file : string -> t - val parse_dot_file : string -> t - - val print_gml_file : t -> string -> unit - -end diff --git a/external/ocamlgraph/src/strat.ml b/external/ocamlgraph/src/strat.ml deleted file mode 100644 --- a/external/ocamlgraph/src/strat.ml +++ /dev/null @@ -1,233 +0,0 @@ -(**************************************************************************) -(* *) -(* Ocamlgraph: a generic graph library for OCaml *) -(* Copyright (C) 2004-2007 *) -(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) -(* *) -(* This software is free software; you can redistribute it and/or *) -(* modify it under the terms of the GNU Library General Public *) -(* License version 2, with the special exception on linking *) -(* described in file LICENSE. *) -(* *) -(* This software is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) -(* *) -(**************************************************************************) - -(* $Id:$ *) - -(* Signature for graphs *) -module type G = sig - - type t - - module V : Sig.ORDERED_TYPE - - type vertex = V.t - - val mem_vertex : t -> vertex -> bool - - val succ : t -> vertex -> vertex list - - val fold_vertex : (vertex -> 'a -> 'a) -> t -> 'a -> 'a - val fold_succ : (vertex -> 'a -> 'a) -> t -> vertex -> 'a -> 'a -end - - -(* Signature for graph add-ons: an initial vertex, final vertices - and membership of vertices to either true or false, - i.e. first or second player *) -module type PLAYER = sig - - type t - type vertex - - val get_initial : t -> vertex - val is_final : t -> vertex -> bool - - val turn : t -> vertex -> bool - -end - - -(* Signature for strategies : for a given state, the strategy tells - which state to go to *) -module type STRAT = sig - - type t - type vertex - - val empty : t - val add : t -> vertex -> vertex -> t - - val next : t -> vertex -> vertex - (* Raises Invalid_argument if vertex's image is not defined *) - -end - - -(* Implements strategy algorithms on graphs *) -module Algo (G : G) (P : PLAYER with type vertex = G.vertex) - (S : STRAT with type vertex = G.vertex) : -sig - - (* coherent_player g p returns true iff - the completion p is coherent w.r.t. - the graph g *) - val coherent_player : G.t -> P.t -> bool - - (* coherent_strat g s returns true iff - the strategy s is coherent w.r.t. - the graph g *) - val coherent_strat : G.t -> S.t -> bool - - (* game g p a b returns true iff a wins in g - given the completion p (i.e. the game - goes through a final state). *) - val game : G.t -> P.t -> S.t -> S.t -> bool - - (* strategy g p s returns true iff s wins in g - given the completion p, whatever strategy - plays the other player. *) - val strategy : G.t -> P.t -> S.t -> bool - - (* strategyA g p returns true iff there - exists a winning stragegy for the true - player. In this case, the winning - strategy is provided. *) - val strategyA : G.t -> P.t -> (bool * S.t) -end = struct - - module SetV = Set.Make (G.V) - - - let rec eq l1 l2 = match l1, l2 with - [], [] -> true - | e1 :: l1', e2 :: l2' -> - (e1 = e2) && (eq l1' l2') - | _ -> false - - let rec eq_mem i l1 l2 = match l1, l2 with - [], [] -> (true, false) - | e1 :: l1', e2 :: l2' -> - if e1 = e2 then - if e1 = i then (eq l1' l2', true) - else eq_mem i l1' l2' - else (false, false) - | _ -> (false, false) - - let puit g v = match G.succ g v with - [] -> true - | _ -> false - - - let get_finals g p = - let f a l = - if P.is_final p a then a :: l - else l - in G.fold_vertex f g [] - - - let coherent_player g p = - G.mem_vertex g (P.get_initial p) - - - let coherent_strat g s = - let f v b = - try - let v' = S.next s v in - b && (G.mem_vertex g v') - with Invalid_argument _ -> true - in - G.fold_vertex f g true - - - let game g p a b = - - let rec game_aux l pi = - let continue x = - try - game_aux (SetV.add pi l) (S.next x pi) - with Invalid_argument _ -> false - in - (P.is_final p pi) || - (if SetV.mem pi l then false - else - if P.turn p pi then continue a - else continue b) - - in - game_aux SetV.empty (P.get_initial p) - - - let rec attract1 g p s l = - let f v l1 = - if not (List.mem v l1) then - if P.turn p v then - try - if List.mem (S.next s v) l1 then v :: l1 - else l1 - with Invalid_argument _ -> l1 - else - if puit g v then l1 - else - if G.fold_succ (fun v' b -> b && (List.mem v' l1)) g v true - then v :: l1 - else l1 - else l1 - in - G.fold_vertex f g l - - - let rec strategy g p s = - - let rec strategy_aux l1 l2 = - let (b1, b2) = eq_mem (P.get_initial p) l1 l2 in - if b1 then b2 - else strategy_aux (attract1 g p s l1) l1 - - in - let finaux = get_finals g p in - strategy_aux (attract1 g p s finaux) finaux - - - let rec attract g p (l, l') = - let f v (l1, l1') = - if not (List.mem v l1) then - if P.turn p v then - let f' v' l2 = - (match l2 with - [] -> - if List.mem v' l1 then [v'] - else [] - | _ -> l2) in - (match G.fold_succ f' g v [] with - [] -> (l1, l1') - | v' :: _ -> (v :: l1, S.add l1' v v' )) - else - if puit g v then (l1, l1') - else - if G.fold_succ (fun v' b -> b && (List.mem v' l1)) g v true - then (v :: l1, l1') - else (l1, l1') - else (l1, l1') - in - G.fold_vertex f g (l, l') - - - let rec strategyA g p = - - let rec strategyA_aux l1 l2 f = - let (b1, b2) = eq_mem (P.get_initial p) l1 l2 in - if b1 then (b2, f) - else - let (new_l1, new_f) = attract g p (l1, f) in - strategyA_aux new_l1 l1 new_f - - in - let finaux = get_finals g p in - let (l, r) = attract g p (finaux, S.empty) in - strategyA_aux l finaux r;; - - end diff --git a/external/ocamlgraph/src/strat.mli b/external/ocamlgraph/src/strat.mli deleted file mode 100644 --- a/external/ocamlgraph/src/strat.mli +++ /dev/null @@ -1,103 +0,0 @@ -(**************************************************************************) -(* *) -(* Ocamlgraph: a generic graph library for OCaml *) -(* Copyright (C) 2004-2007 *) -(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) -(* *) -(* This software is free software; you can redistribute it and/or *) -(* modify it under the terms of the GNU Library General Public *) -(* License version 2, with the special exception on linking *) -(* described in file LICENSE. *) -(* *) -(* This software is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) -(* *) -(**************************************************************************) - -(* $Id:$ *) - -(** Strategies - - Implementation of a winning strategy of a graph: the graph - represents a two players game, each vertex belongs to either player - (whose turn it is to play) and describes a configuration of the - game. The algorithm computes the winning strategy of a player, if any; - i.e. the moves to play (which vertex to go to) so that for all - possible moves of the other player, the game goes through a final - state. - - @author Nicolas Ayache *) - -(** Signature for graphs *) -module type G = sig - type t - module V : Sig.ORDERED_TYPE - type vertex = V.t - val mem_vertex : t -> vertex -> bool - val succ : t -> vertex -> vertex list - val fold_vertex : (vertex -> 'a -> 'a) -> t -> 'a -> 'a - val fold_succ : (vertex -> 'a -> 'a) -> t -> vertex -> 'a -> 'a -end - -(** Signature for graph add-ons: an initial vertex, final vertices - and membership of vertices to either true or false, - i.e. first or second player *) -module type PLAYER = sig - - type t - type vertex - - val get_initial : t -> vertex - val is_final : t -> vertex -> bool - - val turn : t -> vertex -> bool - -end - -(** Signature for strategies: for a given state, the strategy tells - which state to go to *) -module type STRAT = sig - - type t - type vertex - - val empty : t - val add : t -> vertex -> vertex -> t - - val next : t -> vertex -> vertex - (* Raises [Invalid_argument] if vertex's image is not defined *) - -end - -(** Implements strategy algorithms on graphs *) -module Algo (G : G) (P : PLAYER with type vertex = G.vertex) - (S : STRAT with type vertex = G.vertex) : -sig - - (** [coherent_player g p] returns [true] iff - the completion [p] is coherent w.r.t. - the graph g *) - val coherent_player : G.t -> P.t -> bool - - (** [coherent_strat g s] returns [true] iff - the strategy [s] is coherent w.r.t. - the graph [g] *) - val coherent_strat : G.t -> S.t -> bool - - (** [game g p a b] returns [true] iff [a] wins in [g] - given the completion [p] (i.e. the game - goes through a final state). *) - val game : G.t -> P.t -> S.t -> S.t -> bool - - (** [strategy g p s] returns [true] iff [s] wins in [g] - given the completion [p], whatever strategy - plays the other player. *) - val strategy : G.t -> P.t -> S.t -> bool - - (** [strategyA g p] returns [true] iff there - exists [a] winning stragegy for the true - player. In this case, the winning - strategy is provided. *) - val strategyA : G.t -> P.t -> (bool * S.t) -end diff --git a/external/ocamlgraph/src/topological.ml b/external/ocamlgraph/src/topological.ml deleted file mode 100644 --- a/external/ocamlgraph/src/topological.ml +++ /dev/null @@ -1,57 +0,0 @@ -(**************************************************************************) -(* *) -(* Ocamlgraph: a generic graph library for OCaml *) -(* Copyright (C) 2004-2007 *) -(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) -(* *) -(* This software is free software; you can redistribute it and/or *) -(* modify it under the terms of the GNU Library General Public *) -(* License version 2, with the special exception on linking *) -(* described in file LICENSE. *) -(* *) -(* This software is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) -(* *) -(**************************************************************************) - -(*i $Id: topological.ml,v 1.5 2004-02-20 14:37:41 signoles Exp $ i*) - -module type G = sig - type t - module V : Sig.HASHABLE - val iter_vertex : (V.t -> unit) -> t -> unit - val iter_succ : (V.t -> unit) -> t -> V.t -> unit - val in_degree : t -> V.t -> int -end - -module Make(G: G) = struct - - module H = Hashtbl.Make(G.V) - - let fold f g acc = - let degree = H.create 997 in - let todo = Queue.create () in - let rec walk acc = - try - let v = Queue.pop todo in - let acc = f v acc in - G.iter_succ - (fun x-> let d = H.find degree x in - if d=1 then Queue.push x todo - else H.replace degree x (d-1)) - g v; - walk acc - with Queue.Empty -> acc - in - G.iter_vertex - (fun v -> - let d = G.in_degree g v in - if d = 0 then Queue.push v todo - else H.add degree v d) - g; - walk acc - - let iter f g = fold (fun v () -> f v) g () - -end diff --git a/external/ocamlgraph/src/topological.mli b/external/ocamlgraph/src/topological.mli deleted file mode 100644 --- a/external/ocamlgraph/src/topological.mli +++ /dev/null @@ -1,48 +0,0 @@ -(**************************************************************************) -(* *) -(* Ocamlgraph: a generic graph library for OCaml *) -(* Copyright (C) 2004-2007 *) -(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) -(* *) -(* This software is free software; you can redistribute it and/or *) -(* modify it under the terms of the GNU Library General Public *) -(* License version 2, with the special exception on linking *) -(* described in file LICENSE. *) -(* *) -(* This software is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) -(* *) -(**************************************************************************) - -(* $Id: topological.mli,v 1.7 2004-12-20 13:35:42 filliatr Exp $ *) - -(** Topological order. - - This functor provides functions which allow iterating over a - directed graph in topological order *) - -(** Minimal graph signature to provide *) -module type G = sig - type t - module V : Sig.HASHABLE - val iter_vertex : (V.t -> unit) -> t -> unit - val iter_succ : (V.t -> unit) -> t -> V.t -> unit - val in_degree : t -> V.t -> int -end - -module Make(G: G) : sig - - val fold : (G.V.t -> 'a -> 'a) -> G.t -> 'a -> 'a - (** [fold action g seed] allows iterating over the graph [g] - in topological order. [action node accu] is called repeatedly, - where [node] is the node being visited, and [accu] is the result of - the [action]'s previous invocation, if any, and [seed] otherwise. *) - - val iter : (G.V.t -> unit) -> G.t -> unit - (** [iter action] calls [action node] repeatedly. Nodes are (again) - presented to [action] in topological order. *) - -end - - diff --git a/external/ocamlgraph/src/traverse.ml b/external/ocamlgraph/src/traverse.ml deleted file mode 100644 --- a/external/ocamlgraph/src/traverse.ml +++ /dev/null @@ -1,284 +0,0 @@ -(**************************************************************************) -(* *) -(* Ocamlgraph: a generic graph library for OCaml *) -(* Copyright (C) 2004-2007 *) -(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) -(* *) -(* This software is free software; you can redistribute it and/or *) -(* modify it under the terms of the GNU Library General Public *) -(* License version 2, with the special exception on linking *) -(* described in file LICENSE. *) -(* *) -(* This software is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) -(* *) -(**************************************************************************) - -(* $Id: traverse.ml,v 1.17 2004-11-04 13:10:28 filliatr Exp $ *) - -(* Graph traversal *) - -module type G = sig - type t - module V : Sig.COMPARABLE - val iter_vertex : (V.t -> unit) -> t -> unit - val fold_vertex : (V.t -> 'a -> 'a) -> t -> 'a -> 'a - val iter_succ : (V.t -> unit) -> t -> V.t -> unit - val fold_succ : (V.t -> 'a -> 'a) -> t -> V.t -> 'a -> 'a -end - -(* depth-first search *) -module Dfs(G : G) = struct - module H = Hashtbl.Make(G.V) - - let iter ?(pre=fun _ -> ()) ?(post=fun _ -> ()) g = - let h = H.create 65537 in - let rec visit v = - if not (H.mem h v) then begin - H.add h v (); - pre v; - G.iter_succ visit g v; - post v - end - in - G.iter_vertex visit g - - let postfix post g = iter ~post g - - let iter_component ?(pre=fun _ -> ()) ?(post=fun _ -> ()) g v = - let h = H.create 65537 in - let rec visit v = - H.add h v (); - pre v; - G.iter_succ (fun w -> if not (H.mem h w) then visit w) g v; - post v - in - visit v - - let prefix_component pre g = iter_component ~pre g - let postfix_component post g = iter_component ~post g - - (* invariant: not in [h] means not visited at all; [h v = true] means - already visited in the current component; [h v = false] means - already visited in another tree *) - let has_cycle g = - let h = H.create 65537 in - let rec visit v = - H.add h v true; - G.iter_succ - (fun w -> try if H.find h w then raise Exit with Not_found -> visit w) - g v; - H.replace h v false - in - try G.iter_vertex (fun v -> if not (H.mem h v) then visit v) g; false - with Exit -> true - - module Tail = struct - - let iter f g = - let h = H.create 65537 in - let stack = Stack.create () in - (* invariant: [h] contains exactly the vertices which have been pushed *) - let push v = - if not (H.mem h v) then begin H.add h v (); Stack.push v stack end - in - let loop () = - while not (Stack.is_empty stack) do - let v = Stack.pop stack in - f v; - G.iter_succ push g v - done - in - G.iter_vertex (fun v -> push v; loop ()) g - - let iter_component f g v0 = - let h = H.create 65537 in - let stack = Stack.create () in - (* invariant: [h] contains exactly the vertices which have been pushed *) - let push v = - if not (H.mem h v) then begin H.add h v (); Stack.push v stack end - in - push v0; - while not (Stack.is_empty stack) do - let v = Stack.pop stack in - f v; - G.iter_succ push g v - done - - end - - let prefix = Tail.iter - let prefix_component = Tail.iter_component - - (* step-by-step iterator *) - module S = Set.Make(G.V) - - (* state is [(s,st,g)] : [s] contains elements never been pushed in [st] *) - type iterator = S.t * G.V.t list * G.t - - let start g = - let s = G.fold_vertex S.add g S.empty in - s, [], g - - let get (s,st,_) = match st with - | [] -> if S.is_empty s then raise Exit else S.choose s - | v :: _ -> v - - let step (s,st,g) = - let push v (s,st as acc) = - if S.mem v s then - S.remove v s, v :: st - else - acc - in - let v,s',st' = match st with - | [] -> - if S.is_empty s then raise Exit; - let v = S.choose s in - (v, S.remove v s, []) - | v :: st' -> - (v, s, st') - in - let s'',st'' = G.fold_succ push g v (s',st') in - (s'',st'',g) - -end - -(* breadth-first search *) -module Bfs(G : G) = struct - module H = Hashtbl.Make(G.V) - - let iter f g = - let h = H.create 65537 in - let q = Queue.create () in - (* invariant: [h] contains exactly the vertices which have been pushed *) - let push v = - if not (H.mem h v) then begin H.add h v (); Queue.add v q end - in - let loop () = - while not (Queue.is_empty q) do - let v = Queue.pop q in - f v; - G.iter_succ push g v - done - in - G.iter_vertex (fun v -> push v; loop ()) g - - let iter_component f g v0 = - let h = H.create 65537 in - let q = Queue.create () in - (* invariant: [h] contains exactly the vertices which have been pushed *) - let push v = - if not (H.mem h v) then begin H.add h v (); Queue.add v q end - in - push v0; - while not (Queue.is_empty q) do - let v = Queue.pop q in - f v; - G.iter_succ push g v - done - - (* step-by-step iterator *) - - (* simple, yet O(1)-amortized, persistent queues *) - module Q = struct - type 'a t = 'a list * 'a list - exception Empty - let empty = [], [] - let is_empty = function [], [] -> true | _ -> false - let push x (i,o) = (x :: i, o) - let pop = function - | i, y :: o -> y, (i,o) - | [], [] -> raise Empty - | i, [] -> match List.rev i with - | x :: o -> x, ([], o) - | [] -> assert false - let peek q = fst (pop q) - end - - module S = Set.Make(G.V) - - (* state is [(s,q,g)] : [s] contains elements never been pushed in [q] *) - type iterator = S.t * G.V.t Q.t * G.t - - let start g = - let s = G.fold_vertex S.add g S.empty in - s, Q.empty, g - - let get (s,q,g) = - if Q.is_empty q then - if S.is_empty s then raise Exit else S.choose s - else - Q.peek q - - let step (s,q,g) = - let push v (s,q as acc) = - if S.mem v s then - S.remove v s, Q.push v q - else - acc - in - let v,s',q' = - if Q.is_empty q then begin - if S.is_empty s then raise Exit; - let v = S.choose s in - v, S.remove v s, q - end else - let v,q' = Q.pop q in - v, s, q' - in - let s'',q'' = G.fold_succ push g v (s',q') in - (s'',q'',g) - -end - - -(* Graph traversal with marking. *) - -module type GM = sig - type t - module V : sig type t end - val iter_vertex : (V.t -> unit) -> t -> unit - val iter_succ : (V.t -> unit) -> t -> V.t -> unit - module Mark : sig - val clear : t -> unit - val get : V.t -> int - val set : V.t -> int -> unit - end -end - -module Mark(G : GM) = struct - - let dfs g = - G.Mark.clear g; - let n = ref 0 in - let rec visit v = - if G.Mark.get v = 0 then begin - incr n; - G.Mark.set v !n; - G.iter_succ visit g v - end - in - G.iter_vertex visit g - - (* invariant: [h v = 0] means not visited at all; [h v = 1] means - already visited in the current component; [h v = 2] means - already visited in another tree *) - let has_cycle g = - G.Mark.clear g; - let rec visit v = - G.Mark.set v 1; - G.iter_succ - (fun w -> - let m = G.Mark.get w in - if m = 1 then raise Exit; - if m = 0 then visit w) - g v; - G.Mark.set v 2 - in - try G.iter_vertex (fun v -> if G.Mark.get v = 0 then visit v) g; false - with Exit -> true - -end - diff --git a/external/ocamlgraph/src/traverse.mli b/external/ocamlgraph/src/traverse.mli deleted file mode 100644 --- a/external/ocamlgraph/src/traverse.mli +++ /dev/null @@ -1,127 +0,0 @@ -(**************************************************************************) -(* *) -(* Ocamlgraph: a generic graph library for OCaml *) -(* Copyright (C) 2004-2007 *) -(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) -(* *) -(* This software is free software; you can redistribute it and/or *) -(* modify it under the terms of the GNU Library General Public *) -(* License version 2, with the special exception on linking *) -(* described in file LICENSE. *) -(* *) -(* This software is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) -(* *) -(**************************************************************************) - -(* $Id: traverse.mli,v 1.14 2005-04-01 07:13:24 filliatr Exp $ *) - -(** Graph traversal *) - -(** {1 Dfs and Bfs} *) - -(** Minimal graph signature for [Dfs] or [Bfs] *) -module type G = sig - type t - module V : Sig.COMPARABLE - val iter_vertex : (V.t -> unit) -> t -> unit - val fold_vertex : (V.t -> 'a -> 'a) -> t -> 'a -> 'a - val iter_succ : (V.t -> unit) -> t -> V.t -> unit - val fold_succ : (V.t -> 'a -> 'a) -> t -> V.t -> 'a -> 'a -end - -(** Depth-first search *) -module Dfs(G : G) : sig - (** {2 Classical big-step iterators} *) - - val iter : ?pre:(G.V.t -> unit) -> - ?post:(G.V.t -> unit) -> G.t -> unit - (** [iter pre post g] visits all nodes of [g] in depth-first search, - applying [pre] to each visited node before its successors, - and [post] after them. Each node is visited exactly once. - Not tail-recursive. *) - - val prefix : (G.V.t -> unit) -> G.t -> unit - (** applies only a prefix function; note that this function is more - efficient than [iter] and is tail-recursive. *) - - val postfix : (G.V.t -> unit) -> G.t -> unit - (** applies only a postfix function. Not tail-recursive. *) - - (** Same thing, but for a single connected component - (only [prefix_component] is tail-recursive) *) - - val iter_component : ?pre:(G.V.t -> unit) -> - ?post:(G.V.t -> unit) -> G.t -> G.V.t -> unit - val prefix_component : (G.V.t -> unit) -> G.t -> G.V.t -> unit - val postfix_component : (G.V.t -> unit) -> G.t -> G.V.t -> unit - - (** {2 Step-by-step iterator} - - This is a variant of the iterators above where you can move on - step by step. The abstract type [iterator] represents the current - state of the iteration. The [step] function returns the next state. - In each state, function [get] returns the currently visited vertex. - On the final state both [get] and [step] raises exception [Exit]. - - Note: the iterator type is persistent (i.e. is not modified by the - [step] function) and thus can be used in backtracking algorithms. *) - - type iterator - val start : G.t -> iterator - val step : iterator -> iterator - val get : iterator -> G.V.t - - (** {2 Cycle detection} *) - - val has_cycle : G.t -> bool - (** [has_cycle g] checks for a cycle in [g]. Linear in time and space. *) - -end - -(** Breadth-first search *) -module Bfs(G : G) : sig - (** {2 Classical big-step iterators} *) - - val iter : (G.V.t -> unit) -> G.t -> unit - val iter_component : (G.V.t -> unit) -> G.t -> G.V.t -> unit - - (** {2 Step-by-step iterator} - See module [Dfs] *) - - type iterator - val start : G.t -> iterator - val step : iterator -> iterator - val get : iterator -> G.V.t - -end - -(** {1 Traversal with marking} *) - -(** Minimal graph signature for graph traversal with marking. *) -module type GM = sig - type t - module V : sig type t end - val iter_vertex : (V.t -> unit) -> t -> unit - val iter_succ : (V.t -> unit) -> t -> V.t -> unit - module Mark : sig - val clear : t -> unit - val get : V.t -> int - val set : V.t -> int -> unit - end -end - -(** Graph traversal with marking. - Only applies to imperative graphs with marks. *) -module Mark(G : GM) : sig - - val dfs : G.t -> unit - (** [dfs g] traverses [g] in depth-first search, marking all nodes. *) - - val has_cycle : G.t -> bool - (** [has_cycle g] checks for a cycle in [g]. Modifies the marks. - Linear time, constant space. *) - -end - diff --git a/external/ocamlgraph/src/util.ml b/external/ocamlgraph/src/util.ml deleted file mode 100644 --- a/external/ocamlgraph/src/util.ml +++ /dev/null @@ -1,67 +0,0 @@ -(**************************************************************************) -(* *) -(* Ocamlgraph: a generic graph library for OCaml *) -(* Copyright (C) 2004-2007 *) -(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) -(* *) -(* This software is free software; you can redistribute it and/or *) -(* modify it under the terms of the GNU Library General Public *) -(* License version 2, with the special exception on linking *) -(* described in file LICENSE. *) -(* *) -(* This software is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) -(* *) -(**************************************************************************) - -(* $Id: util.ml,v 1.14 2004-10-19 15:21:45 signoles Exp $ *) - -open Sig - -module OTProduct(X: ORDERED_TYPE)(Y: ORDERED_TYPE) = struct - - type t = X.t * Y.t - - let compare (x1, y1) (x2, y2) = - let cv = X.compare x1 x2 in - if cv != 0 then cv else Y.compare y1 y2 - -end - -module HTProduct(X: HASHABLE)(Y: HASHABLE) = struct - - type t = X.t * Y.t - - let equal (x1, y1) (x2, y2) = - X.equal x1 x2 && Y.equal y1 y2 - - let hash (x, y) = - Hashtbl.hash (X.hash x, Y.hash y) - -end - -module CMPProduct(X: COMPARABLE)(Y: COMPARABLE) = struct - include HTProduct(X)(Y) - include (OTProduct(X)(Y): sig val compare : t -> t -> int end) -end - -module DataV(L : sig type t end)(V : Sig.COMPARABLE) = -struct - type data = L.t - type label = V.t - type t = data ref * V.t - - let compare ((_, x) : t) ((_, x') : t) = - V.compare x x' - - let hash ((_, x) : t) = V.hash x - - let equal ((_, x) : t) ((_, x') : t) = V.equal x x' - - let create y lbl = (ref y, lbl) - let label (_, z) = z - let data (y, _) = !y - let set_data (y, _) = (:=) y -end - diff --git a/external/ocamlgraph/src/util.mli b/external/ocamlgraph/src/util.mli deleted file mode 100644 --- a/external/ocamlgraph/src/util.mli +++ /dev/null @@ -1,47 +0,0 @@ -(**************************************************************************) -(* *) -(* Ocamlgraph: a generic graph library for OCaml *) -(* Copyright (C) 2004-2007 *) -(* Sylvain Conchon, Jean-Christophe Filliatre and Julien Signoles *) -(* *) -(* This software is free software; you can redistribute it and/or *) -(* modify it under the terms of the GNU Library General Public *) -(* License version 2, with the special exception on linking *) -(* described in file LICENSE. *) -(* *) -(* This software is distributed in the hope that it will be useful, *) -(* but WITHOUT ANY WARRANTY; without even the implied warranty of *) -(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *) -(* *) -(**************************************************************************) - -(* $Id: util.mli,v 1.12 2005-03-31 13:32:51 filliatr Exp $ *) - -open Sig - -module OTProduct(X: ORDERED_TYPE)(Y: ORDERED_TYPE) : - ORDERED_TYPE with type t = X.t * Y.t - -module HTProduct(X: HASHABLE)(Y: HASHABLE) : - HASHABLE with type t = X.t * Y.t - -module CMPProduct(X: COMPARABLE)(Y: COMPARABLE) : - COMPARABLE with type t = X.t * Y.t - -(** Create a vertex type with some data attached to it *) -module DataV - (L : sig type t end) - (V : Sig.COMPARABLE) : -sig - type data = L.t - and label = V.t - and t = data ref * V.t - val compare : t -> t -> int - val hash : t -> int - val equal : t -> t -> bool - val create : data -> V.t -> t - val label : t -> V.t - val data : t -> data - val set_data : t -> data -> unit -end - diff --git a/external/ocamlgraph/src/version.ml b/external/ocamlgraph/src/version.ml deleted file mode 100644 --- a/external/ocamlgraph/src/version.ml +++ /dev/null @@ -1,2 +0,0 @@ -let version = "0.99b" -let date = "Wed Aug 12 18:13:31 UTC 2015" diff --git a/external/z3/include/z3.h b/external/z3/include/z3.h deleted file mode 100644 --- a/external/z3/include/z3.h +++ /dev/null @@ -1,70 +0,0 @@ -/*++ -Copyright (c) 2007 Microsoft Corporation - -Module Name: - - msmt.h - -Abstract: - - Z3 API. - -Author: - - Nikolaj Bjorner (nbjorner) - Leonardo de Moura (leonardo) 2007-06-8 - -Notes: - ---*/ - -#ifndef _Z3__H_ -#define _Z3__H_ - -#include - -#ifndef __in -#define __in -#endif - -#ifndef __in_z -#define __in_z __in -#endif - -#ifndef __out -#define __out -#endif - -#ifndef __out_z -#define __out_z -#endif - -#ifndef __ecount -#define __ecount(num_args) -#endif - -#ifndef __in_ecount -#define __in_ecount(num_args) __in __ecount(num_args) -#endif - -#ifndef __out_ecount -#define __out_ecount(num_args) __out __ecount(num_args) -#endif - -#ifndef __inout_ecount -#define __inout_ecount(num_args) __in __out __ecount(num_args) -#endif - -#ifndef __inout -#define __inout __in __out -#endif - -#define Z3_API - -#define DEFINE_TYPE(T) typedef struct _ ## T *T -#define DEFINE_VOID(T) typedef void* T - -#include"z3_api.h" - -#endif - diff --git a/external/z3/include/z3_api.h b/external/z3/include/z3_api.h deleted file mode 100644 --- a/external/z3/include/z3_api.h +++ /dev/null @@ -1,4824 +0,0 @@ -DEFINE_TYPE(Z3_config); -DEFINE_TYPE(Z3_context); -DEFINE_TYPE(Z3_sort); -DEFINE_TYPE(Z3_func_decl); -DEFINE_TYPE(Z3_ast); -DEFINE_TYPE(Z3_app); -DEFINE_TYPE(Z3_pattern); -DEFINE_TYPE(Z3_symbol); -DEFINE_TYPE(Z3_parameter); -DEFINE_TYPE(Z3_model); -DEFINE_TYPE(Z3_literals); -DEFINE_TYPE(Z3_constructor); -DEFINE_TYPE(Z3_constructor_list); -DEFINE_TYPE(Z3_theory); -DEFINE_VOID(Z3_theory_data); - - -#ifndef __int64 -#define __int64 long long -#endif - -#ifndef __uint64 -#define __uint64 unsigned long long -#endif - -// Backwards compatibility -#define Z3_type_ast Z3_sort -#define Z3_const_decl_ast Z3_func_decl -#define Z3_const Z3_app -#define Z3_pattern_ast Z3_pattern -#define Z3_UNINTERPRETED_TYPE Z3_UNINTERPRETED_SORT -#define Z3_BOOL_TYPE Z3_BOOL_SORT -#define Z3_INT_TYPE Z3_INT_SORT -#define Z3_REAL_TYPE Z3_REAL_SORT -#define Z3_BV_TYPE Z3_BV_SORT -#define Z3_ARRAY_TYPE Z3_ARRAY_SORT -#define Z3_TUPLE_TYPE Z3_DATATYPE_SORT -#define Z3_UNKNOWN_TYPE Z3_UNKNOWN_SORT -#define Z3_CONST_DECL_AST Z3_FUNC_DECL_AST -#define Z3_TYPE_AST Z3_SORT_AST -#define Z3_SORT_ERROR Z3_TYPE_ERROR -#define Z3_mk_uninterpreted_type Z3_mk_uninterpreted_sort -#define Z3_mk_bool_type Z3_mk_bool_sort -#define Z3_mk_int_type Z3_mk_int_sort -#define Z3_mk_real_type Z3_mk_real_sort -#define Z3_mk_bv_type Z3_mk_bv_sort -#define Z3_mk_array_type Z3_mk_array_sort -#define Z3_mk_tuple_type Z3_mk_tuple_sort -#define Z3_get_type Z3_get_sort -#define Z3_get_pattern_ast Z3_get_pattern -#define Z3_get_type_kind Z3_get_sort_kind -#define Z3_get_type_name Z3_get_sort_name -#define Z3_get_bv_type_size Z3_get_bv_sort_size -#define Z3_get_array_type_domain Z3_get_array_sort_domain -#define Z3_get_array_type_range Z3_get_array_sort_range -#define Z3_get_tuple_type_num_fields Z3_get_tuple_sort_num_fields -#define Z3_get_tuple_type_field_decl Z3_get_tuple_sort_field_decl -#define Z3_get_tuple_type_mk_decl Z3_get_tuple_sort_mk_decl -#define Z3_to_const_ast Z3_to_app -#define Z3_get_numeral_value_string Z3_get_numeral_string -#define Z3_get_const_ast_decl Z3_get_app_decl -#define Z3_get_value Z3_eval_func_decl - -/** - \defgroup capi C API - -*/ -/*@{*/ - -/** - \conly @name Types - - \conly Most of the types in the C API are opaque pointers. - - \conly - \c Z3_config: a configuration object used to initialize logical contexts. - \conly - \c Z3_context: logical context. This is the main Z3 data-structure. - \conly - \c Z3_symbol: a Lisp-link symbol. It is used to name types, constants, and functions. A symbol can be created using - \conly string or integers. - \conly - \c Z3_ast: abstract syntax tree node. That is, the data-structure used in Z3 to represent terms, formulas and types. - \conly - \c Z3_sort: a kind of AST used to represent types. - \conly - \c Z3_app: a kind of AST used to represent constant and function declarations. - \conly - \c Z3_pattern: a kind of AST used to represent pattern and multi-patterns used to guide quantifier instantiation. - \conly - \c Z3_model: a model for the constraints asserted into the logical context. -*/ - -#ifndef CAMLIDL -/** - \conly \brief Z3 Boolean type. It is just an alias for \c int. -*/ -typedef int Z3_bool; -#else -/** - \conly \brief Z3 Boolean type. It is just an alias for \c Boolean. -*/ -#define Z3_bool boolean -#endif // CAMLIDL - -#ifndef CAMLIDL -/** - \conly \brief Z3 string type. It is just an alias for const char *. -*/ -typedef const char * Z3_string; -typedef Z3_string * Z3_string_ptr; -#else -/** - \conly \brief Z3 string type. It is just an alias for [string] const char *. -*/ -#define Z3_string [string] const char * -/* hack to make the IDL compiler happy */ -#define Z3_string_ptr const char * * -#endif // CAMLIDL - -#ifndef CAMLIDL -/** - \conly \brief True value. It is just an alias for \c 1. -*/ -#define Z3_TRUE 1 - -/** - \conly \brief False value. It is just an alias for \c 0. -*/ -#define Z3_FALSE 0 - -#endif // CAMLIDL - -/** - \conly \brief Lifted Boolean type: \c false, \c undefined, \c true. -*/ -typedef enum -{ - Z3_L_FALSE = -1, - Z3_L_UNDEF, - Z3_L_TRUE -} Z3_lbool; - -/** - \conly \brief In Z3, a symbol can be represented using integers and strings (See #Z3_get_symbol_kind). - - \conly \sa Z3_mk_int_symbol - \conly \sa Z3_mk_string_symbol -*/ -typedef enum -{ - Z3_INT_SYMBOL, - Z3_STRING_SYMBOL -} Z3_symbol_kind; - - -/** - \conly \brief The different kinds of parameters that can be associated with function symbols. - \conly \sa Z3_get_decl_num_parameters - \conly \sa Z3_get_decl_parameter_kind - - \conly - Z3_PARAMETER_INT is used for integer parameters. - \conly - Z3_PARAMETER_DOUBLE is used for double parameters. - \conly - Z3_PARAMETER_RATIONAL is used for parameters that are rational numbers. - \conly - Z3_PARAMETER_SORT is used for sort parameters. - \conly - Z3_PARAMETER_AST is used for expression parameters. - \conly - Z3_PARAMETER_FUNC_DECL is used for function declaration parameters. -*/ -typedef enum -{ - Z3_PARAMETER_INT, - Z3_PARAMETER_DOUBLE, - Z3_PARAMETER_RATIONAL, - Z3_PARAMETER_SYMBOL, - Z3_PARAMETER_SORT, - Z3_PARAMETER_AST, - Z3_PARAMETER_FUNC_DECL, -} Z3_parameter_kind; - -/** - \conly \brief The different kinds of Z3 types (See #Z3_get_sort_kind). -*/ -typedef enum -{ - Z3_UNINTERPRETED_SORT, - Z3_BOOL_SORT, - Z3_INT_SORT, - Z3_REAL_SORT, - Z3_BV_SORT, - Z3_ARRAY_SORT, - Z3_DATATYPE_SORT, - Z3_RELATION_SORT, - Z3_FINITE_DOMAIN_SORT, - Z3_UNKNOWN_SORT = 1000 -} Z3_sort_kind; - -/** - \conly \brief The different kinds of Z3 AST (abstract syntax trees). That is, terms, formulas and types. - - \conly - Z3_APP_AST: constant and applications - \conly - Z3_NUMERAL_AST: numeral constants - \conly - Z3_VAR_AST: bound variables - \conly - Z3_QUANTIFIER_AST: quantifiers - \conly - Z3_UNKNOWN_AST: internal -*/ -typedef enum -{ - Z3_NUMERAL_AST, - Z3_APP_AST, - Z3_VAR_AST, - Z3_QUANTIFIER_AST, - Z3_UNKNOWN_AST = 1000 -} Z3_ast_kind; - -/** - \conly \brief The different kinds of interpreted function kinds. - - (* - - Z3_OP_TRUE The constant true. - - - Z3_OP_FALSE The constant false. - - - Z3_OP_EQ The equality predicate. - - - Z3_OP_DISTINCT The n-ary distinct predicate (every argument is mutually distinct). - - - Z3_OP_ITE The ternary if-then-else term. - - - Z3_OP_AND n-ary conjunction. - - - Z3_OP_OR n-ary disjunction. - - - Z3_OP_IFF equivalence (binary). - - - Z3_OP_XOR Exclusive or. - - - Z3_OP_NOT Negation. - - - Z3_OP_IMPLIES Implication. - - - Z3_OP_OEQ Binary equivalence modulo namings. This binary predicate is used in proof terms. - It captures equisatisfiability and equivalence modulo renamings. - - - Z3_OP_ANUM Arithmetic numeral. - - - Z3_OP_LE <=. - - - Z3_OP_GE >=. - - - Z3_OP_LT <. - - - Z3_OP_GT >. - - - Z3_OP_ADD Addition - Binary. - - - Z3_OP_SUB Binary subtraction. - - - Z3_OP_UMINUS Unary minus. - - - Z3_OP_MUL Multiplication - Binary. - - - Z3_OP_DIV Division - Binary. - - - Z3_OP_IDIV Integer division - Binary. - - - Z3_OP_REM Remainder - Binary. - - - Z3_OP_MOD Modulus - Binary. - - - Z3_OP_TO_REAL Coercion of integer to real - Unary. - - - Z3_OP_TO_INT Coercion of real to integer - Unary. - - - Z3_OP_IS_INT Check if real is also an integer - Unary. - - - Z3_OP_STORE Array store. It satisfies select(store(a,i,v),j) = if i = j then v else select(a,j). - Array store takes at least 3 arguments. - - - Z3_OP_SELECT Array select. - - - Z3_OP_CONST_ARRAY The constant array. For example, select(const(v),i) = v holds for every v and i. The function is unary. - - - Z3_OP_ARRAY_DEFAULT Default value of arrays. For example default(const(v)) = v. The function is unary. - - - Z3_OP_ARRAY_MAP Array map operator. - It satisfies map[f](a1,..,a_n)[i] = f(a1[i],...,a_n[i]) for every i. - - - Z3_OP_SET_UNION Set union between two Booelan arrays (two arrays whose range type is Boolean). The function is binary. - - - Z3_OP_SET_INTERSECT Set intersection between two Boolean arrays. The function is binary. - - - Z3_OP_SET_DIFFERENCE Set difference between two Boolean arrays. The function is binary. - - - Z3_OP_SET_COMPLEMENT Set complement of a Boolean array. The function is unary. - - - Z3_OP_SET_SUBSET Subset predicate between two Boolean arrays. The relation is binary. - - - Z3_OP_AS_ARRAY An array value that behaves as the function graph of the - function passed as parameter. - - - Z3_OP_BNUM Bit-vector numeral. - - - Z3_OP_BIT1 One bit bit-vector. - - - Z3_OP_BIT0 Zero bit bit-vector. - - - Z3_OP_BNEG Unary minus. - - - Z3_OP_BADD Binary addition. - - - Z3_OP_BSUB Binary subtraction. - - - Z3_OP_BMUL Binary multiplication. - - - Z3_OP_BSDIV Binary signed division. - - - Z3_OP_BUDIV Binary unsigned division. - - - Z3_OP_BSREM Binary signed remainder. - - - Z3_OP_BUREM Binary unsigned remainder. - - - Z3_OP_BSMOD Binary signed modulus. - - - Z3_OP_BSDIV0 Unary function. bsdiv(x,0) is congruent to bsdiv0(x). - - - Z3_OP_BUDIV0 Unary function. budiv(x,0) is congruent to budiv0(x). - - - Z3_OP_BSREM0 Unary function. bsrem(x,0) is congruent to bsrem0(x). - - - Z3_OP_BUREM0 Unary function. burem(x,0) is congruent to burem0(x). - - - Z3_OP_BSMOD0 Unary function. bsmod(x,0) is congruent to bsmod0(x). - - - Z3_OP_ULEQ Unsigned bit-vector <= - Binary relation. - - - Z3_OP_SLEQ Signed bit-vector <= - Binary relation. - - - Z3_OP_UGEQ Unsigned bit-vector >= - Binary relation. - - - Z3_OP_SGEQ Signed bit-vector >= - Binary relation. - - - Z3_OP_ULT Unsigned bit-vector < - Binary relation. - - - Z3_OP_SLT Signed bit-vector < - Binary relation. - - - Z3_OP_UGT Unsigned bit-vector > - Binary relation. - - - Z3_OP_SGT Signed bit-vector > - Binary relation. - - - Z3_OP_BAND Bit-wise and - Binary. - - - Z3_OP_BOR Bit-wise or - Binary. - - - Z3_OP_BNOT Bit-wise not - Unary. - - - Z3_OP_BXOR Bit-wise xor - Binary. - - - Z3_OP_BNAND Bit-wise nand - Binary. - - - Z3_OP_BNOR Bit-wise nor - Binary. - - - Z3_OP_BXNOR Bit-wise xnor - Binary. - - - Z3_OP_CONCAT Bit-vector concatenation - Binary. - - - Z3_OP_SIGN_EXT Bit-vector sign extension. - - - Z3_OP_ZERO_EXT Bit-vector zero extension. - - - Z3_OP_EXTRACT Bit-vector extraction. - - - Z3_OP_REPEAT Repeat bit-vector n times. - - - Z3_OP_BREDOR Bit-vector reduce or - Unary. - - - Z3_OP_BREDAND Bit-vector reduce and - Unary. - - - Z3_OP_BCOMP . - - - Z3_OP_BSHL Shift left. - - - Z3_OP_BLSHR Logical shift right. - - - Z3_OP_BASHR Arithmetical shift right. - - - Z3_OP_ROTATE_LEFT Left rotation. - - - Z3_OP_ROTATE_RIGHT Right rotation. - - - Z3_OP_EXT_ROTATE_LEFT (extended) Left rotation. Similar to Z3_OP_ROTATE_LEFT, but it is a binary operator instead of a parametric one. - - - Z3_OP_EXT_ROTATE_RIGHT (extended) Right rotation. Similar to Z3_OP_ROTATE_RIGHT, but it is a binary operator instead of a parametric one. - - - Z3_OP_INT2BV Coerce integer to bit-vector. NB. This function - is not supported by the decision procedures. Only the most - rudimentary simplification rules are applied to this function. - - - Z3_OP_BV2INT Coerce bit-vector to integer. NB. This function - is not supported by the decision procedures. Only the most - rudimentary simplification rules are applied to this function. - - - Z3_OP_CARRY Compute the carry bit in a full-adder. - The meaning is given by the equivalence - (carry l1 l2 l3) <=> (or (and l1 l2) (and l1 l3) (and l2 l3))) - - - Z3_OP_XOR3 Compute ternary XOR. - The meaning is given by the equivalence - (xor3 l1 l2 l3) <=> (xor (xor l1 l2) l3) - - - Z3_OP_PR_TRUE: Proof for the expression 'true'. - - - Z3_OP_PR_ASSERTED: Proof for a fact asserted by the user. - - - Z3_OP_PR_GOAL: Proof for a fact (tagged as goal) asserted by the user. - - - Z3_OP_PR_MODUS_PONENS: Given a proof for p and a proof for (implies p q), produces a proof for q. - \nicebox{ - T1: p - T2: (implies p q) - [mp T1 T2]: q - } - The second antecedents may also be a proof for (iff p q). - - - Z3_OP_PR_REFLEXIVITY: A proof for (R t t), where R is a reflexive relation. This proof object has no antecedents. - The only reflexive relations that are used are - equivalence modulo namings, equality and equivalence. - That is, R is either '~', '=' or 'iff'. - - - Z3_OP_PR_SYMMETRY: Given an symmetric relation R and a proof for (R t s), produces a proof for (R s t). - \nicebox{ - T1: (R t s) - [symmetry T1]: (R s t) - } - T1 is the antecedent of this proof object. - - - Z3_OP_PR_TRANSITIVITY: Given a transitive relation R, and proofs for (R t s) and (R s u), produces a proof - for (R t u). - \nicebox{ - T1: (R t s) - T2: (R s u) - [trans T1 T2]: (R t u) - } - - - Z3_OP_PR_TRANSITIVITY_STAR: Condensed transitivity proof. This proof object is only used if the parameter PROOF_MODE is 1. - It combines several symmetry and transitivity proofs. - - Example: - \nicebox{ - T1: (R a b) - T2: (R c b) - T3: (R c d) - [trans* T1 T2 T3]: (R a d) - } - R must be a symmetric and transitive relation. - - Assuming that this proof object is a proof for (R s t), then - a proof checker must check if it is possible to prove (R s t) - using the antecedents, symmetry and transitivity. That is, - if there is a path from s to t, if we view every - antecedent (R a b) as an edge between a and b. - - - Z3_OP_PR_MONOTONICITY: Monotonicity proof object. - \nicebox{ - T1: (R t_1 s_1) - ... - Tn: (R t_n s_n) - [monotonicity T1 ... Tn]: (R (f t_1 ... t_n) (f s_1 ... s_n)) - } - Remark: if t_i == s_i, then the antecedent Ti is suppressed. - That is, reflexivity proofs are supressed to save space. - - - Z3_OP_PR_QUANT_INTRO: Given a proof for (~ p q), produces a proof for (~ (forall (x) p) (forall (x) q)). - - T1: (~ p q) - [quant-intro T1]: (~ (forall (x) p) (forall (x) q)) - - - Z3_OP_PR_DISTRIBUTIVITY: Distributivity proof object. - Given that f (= or) distributes over g (= and), produces a proof for - - (= (f a (g c d)) - (g (f a c) (f a d))) - - If f and g are associative, this proof also justifies the following equality: - - (= (f (g a b) (g c d)) - (g (f a c) (f a d) (f b c) (f b d))) - - where each f and g can have arbitrary number of arguments. - - This proof object has no antecedents. - Remark. This rule is used by the CNF conversion pass and - instantiated by f = or, and g = and. - - - Z3_OP_PR_AND_ELIM: Given a proof for (and l_1 ... l_n), produces a proof for l_i - - \nicebox{ - T1: (and l_1 ... l_n) - [and-elim T1]: l_i - } - - Z3_OP_PR_NOT_OR_ELIM: Given a proof for (not (or l_1 ... l_n)), produces a proof for (not l_i). - - \nicebox{ - T1: (not (or l_1 ... l_n)) - [not-or-elim T1]: (not l_i) - } - - - Z3_OP_PR_REWRITE: A proof for a local rewriting step (= t s). - The head function symbol of t is interpreted. - - This proof object has no antecedents. - The conclusion of a rewrite rule is either an equality (= t s), - an equivalence (iff t s), or equi-satisfiability (~ t s). - Remark: if f is bool, then = is iff. - - - Examples: - \nicebox{ - (= (+ x 0) x) - (= (+ x 1 2) (+ 3 x)) - (iff (or x false) x) - } - - - Z3_OP_PR_REWRITE_STAR: A proof for rewriting an expression t into an expression s. - This proof object is used if the parameter PROOF_MODE is 1. - This proof object can have n antecedents. - The antecedents are proofs for equalities used as substitution rules. - The object is also used in a few cases if the parameter PROOF_MODE is 2. - The cases are: - - When applying contextual simplification (CONTEXT_SIMPLIFIER=true) - - When converting bit-vectors to Booleans (BIT2BOOL=true) - - When pulling ite expression up (PULL_CHEAP_ITE_TREES=true) - - - Z3_OP_PR_PULL_QUANT: A proof for (iff (f (forall (x) q(x)) r) (forall (x) (f (q x) r))). This proof object has no antecedents. - - - Z3_OP_PR_PULL_QUANT_STAR: A proof for (iff P Q) where Q is in prenex normal form. - This proof object is only used if the parameter PROOF_MODE is 1. - This proof object has no antecedents. - - - Z3_OP_PR_PUSH_QUANT: A proof for: - - \nicebox{ - (iff (forall (x_1 ... x_m) (and p_1[x_1 ... x_m] ... p_n[x_1 ... x_m])) - (and (forall (x_1 ... x_m) p_1[x_1 ... x_m]) - ... - (forall (x_1 ... x_m) p_n[x_1 ... x_m]))) - } - This proof object has no antecedents. - - - Z3_OP_PR_ELIM_UNUSED_VARS: - A proof for (iff (forall (x_1 ... x_n y_1 ... y_m) p[x_1 ... x_n]) - (forall (x_1 ... x_n) p[x_1 ... x_n])) - - It is used to justify the elimination of unused variables. - This proof object has no antecedents. - - - Z3_OP_PR_DER: A proof for destructive equality resolution: - (iff (forall (x) (or (not (= x t)) P[x])) P[t]) - if x does not occur in t. - - This proof object has no antecedents. - - Several variables can be eliminated simultaneously. - - - Z3_OP_PR_QUANT_INST: A proof of (or (not (forall (x) (P x))) (P a)) - - - Z3_OP_PR_HYPOTHESIS: Mark a hypothesis in a natural deduction style proof. - - - Z3_OP_PR_LEMMA: - - \nicebox{ - T1: false - [lemma T1]: (or (not l_1) ... (not l_n)) - } - This proof object has one antecedent: a hypothetical proof for false. - It converts the proof in a proof for (or (not l_1) ... (not l_n)), - when T1 contains the hypotheses: l_1, ..., l_n. - - - Z3_OP_PR_UNIT_RESOLUTION: - \nicebox{ - T1: (or l_1 ... l_n l_1' ... l_m') - T2: (not l_1) - ... - T(n+1): (not l_n) - [unit-resolution T1 ... T(n+1)]: (or l_1' ... l_m') - } - - - Z3_OP_PR_IFF_TRUE: - \nicebox{ - T1: p - [iff-true T1]: (iff p true) - } - - - Z3_OP_PR_IFF_FALSE: - \nicebox{ - T1: (not p) - [iff-false T1]: (iff p false) - } - - - Z3_OP_PR_COMMUTATIVITY: - - [comm]: (= (f a b) (f b a)) - - f is a commutative operator. - - This proof object has no antecedents. - Remark: if f is bool, then = is iff. - - - Z3_OP_PR_DEF_AXIOM: Proof object used to justify Tseitin's like axioms: - - \nicebox{ - (or (not (and p q)) p) - (or (not (and p q)) q) - (or (not (and p q r)) p) - (or (not (and p q r)) q) - (or (not (and p q r)) r) - ... - (or (and p q) (not p) (not q)) - (or (not (or p q)) p q) - (or (or p q) (not p)) - (or (or p q) (not q)) - (or (not (iff p q)) (not p) q) - (or (not (iff p q)) p (not q)) - (or (iff p q) (not p) (not q)) - (or (iff p q) p q) - (or (not (ite a b c)) (not a) b) - (or (not (ite a b c)) a c) - (or (ite a b c) (not a) (not b)) - (or (ite a b c) a (not c)) - (or (not (not a)) (not a)) - (or (not a) a) - } - This proof object has no antecedents. - Note: all axioms are propositional tautologies. - Note also that 'and' and 'or' can take multiple arguments. - You can recover the propositional tautologies by - unfolding the Boolean connectives in the axioms a small - bounded number of steps (=3). - - - Z3_OP_PR_DEF_INTRO: Introduces a name for a formula/term. - Suppose e is an expression with free variables x, and def-intro - introduces the name n(x). The possible cases are: - - When e is of Boolean type: - [def-intro]: (and (or n (not e)) (or (not n) e)) - - or: - [def-intro]: (or (not n) e) - when e only occurs positively. - - When e is of the form (ite cond th el): - [def-intro]: (and (or (not cond) (= n th)) (or cond (= n el))) - - Otherwise: - [def-intro]: (= n e) - - - Z3_OP_PR_APPLY_DEF: - [apply-def T1]: F ~ n - F is 'equivalent' to n, given that T1 is a proof that - n is a name for F. - - - Z3_OP_PR_IFF_OEQ: - T1: (iff p q) - [iff~ T1]: (~ p q) - - - Z3_OP_PR_NNF_POS: Proof for a (positive) NNF step. Example: - \nicebox{ - T1: (not s_1) ~ r_1 - T2: (not s_2) ~ r_2 - T3: s_1 ~ r_1' - T4: s_2 ~ r_2' - [nnf-pos T1 T2 T3 T4]: (~ (iff s_1 s_2) - (and (or r_1 r_2') (or r_1' r_2))) - } - The negation normal form steps NNF_POS and NNF_NEG are used in the following cases: - (a) When creating the NNF of a positive force quantifier. - The quantifier is retained (unless the bound variables are eliminated). - Example - \nicebox{ - T1: q ~ q_new - [nnf-pos T1]: (~ (forall (x T) q) (forall (x T) q_new)) - } - (b) When recursively creating NNF over Boolean formulas, where the top-level - connective is changed during NNF conversion. The relevant Boolean connectives - for NNF_POS are 'implies', 'iff', 'xor', 'ite'. - NNF_NEG furthermore handles the case where negation is pushed - over Boolean connectives 'and' and 'or'. - - - - Z3_OP_PR_NFF_NEG: Proof for a (negative) NNF step. Examples: - \nicebox{ - T1: (not s_1) ~ r_1 - ... - Tn: (not s_n) ~ r_n - [nnf-neg T1 ... Tn]: (not (and s_1 ... s_n)) ~ (or r_1 ... r_n) - and - T1: (not s_1) ~ r_1 - ... - Tn: (not s_n) ~ r_n - [nnf-neg T1 ... Tn]: (not (or s_1 ... s_n)) ~ (and r_1 ... r_n) - and - T1: (not s_1) ~ r_1 - T2: (not s_2) ~ r_2 - T3: s_1 ~ r_1' - T4: s_2 ~ r_2' - [nnf-neg T1 T2 T3 T4]: (~ (not (iff s_1 s_2)) - (and (or r_1 r_2) (or r_1' r_2'))) - } - - Z3_OP_PR_NNF_STAR: A proof for (~ P Q) where Q is in negation normal form. - - This proof object is only used if the parameter PROOF_MODE is 1. - - This proof object may have n antecedents. Each antecedent is a PR_DEF_INTRO. - - - Z3_OP_PR_CNF_STAR: A proof for (~ P Q) where Q is in conjunctive normal form. - This proof object is only used if the parameter PROOF_MODE is 1. - This proof object may have n antecedents. Each antecedent is a PR_DEF_INTRO. - - - Z3_OP_PR_SKOLEMIZE: Proof for: - - \nicebox{ - [sk]: (~ (not (forall x (p x y))) (not (p (sk y) y))) - [sk]: (~ (exists x (p x y)) (p (sk y) y)) - } - - This proof object has no antecedents. - - - Z3_OP_PR_MODUS_PONENS_OEQ: Modus ponens style rule for equi-satisfiability. - \nicebox{ - T1: p - T2: (~ p q) - [mp~ T1 T2]: q - } - - - Z3_OP_PR_TH_LEMMA: Generic proof for theory lemmas. - - The theory lemma function comes with one or more parameters. - The first parameter indicates the name of the theory. - For the theory of arithmetic, additional parameters provide hints for - checking the theory lemma. - The hints for arithmetic are: - - - farkas - followed by rational coefficients. Multiply the coefficients to the - inequalities in the lemma, add the (negated) inequalities and obtain a contradiction. - - - triangle-eq - Indicates a lemma related to the equivalence: - \nicebox{ - (iff (= t1 t2) (and (<= t1 t2) (<= t2 t1))) - } - - - gcd-test - Indicates an integer linear arithmetic lemma that uses a gcd test. - - - - Z3_OP_RA_STORE: Insert a record into a relation. - The function takes \c n+1 arguments, where the first argument is the relation and the remaining \c n elements - correspond to the \c n columns of the relation. - - - Z3_OP_RA_EMPTY: Creates the empty relation. - - - Z3_OP_RA_IS_EMPTY: Tests if the relation is empty. - - - Z3_OP_RA_JOIN: Create the relational join. - - - Z3_OP_RA_UNION: Create the union or convex hull of two relations. - The function takes two arguments. - - - Z3_OP_RA_WIDEN: Widen two relations. - The function takes two arguments. - - - Z3_OP_RA_PROJECT: Project the columns (provided as numbers in the parameters). - The function takes one argument. - - - Z3_OP_RA_FILTER: Filter (restrict) a relation with respect to a predicate. - The first argument is a relation. - The second argument is a predicate with free de-Brujin indices - corresponding to the columns of the relation. - So the first column in the relation has index 0. - - - Z3_OP_RA_NEGATION_FILTER: Intersect the first relation with respect to negation - of the second relation (the function takes two arguments). - Logically, the specification can be described by a function - - target = filter_by_negation(pos, neg, columns) - - where columns are pairs c1, d1, .., cN, dN of columns from pos and neg, such that - target are elements in x in pos, such that there is no y in neg that agrees with - x on the columns c1, d1, .., cN, dN. - - - - Z3_OP_RA_RENAME: rename columns in the relation. - The function takes one argument. - The parameters contain the renaming as a cycle. - - - Z3_OP_RA_COMPLEMENT: Complement the relation. - - - Z3_OP_RA_SELECT: Check if a record is an element of the relation. - The function takes \c n+1 arguments, where the first argument is a relation, - and the remaining \c n arguments correspond to a record. - - - Z3_OP_RA_CLONE: Create a fresh copy (clone) of a relation. - \conly The function is logically the identity, but - \conly in the context of a register machine allows - \conly for #Z3_OP_RA_UNION to perform destructive updates to the first argument. - - - - Z3_OP_FD_LT: A less than predicate over the finite domain Z3_FINITE_DOMAIN_SORT. - - *) - -*/ -typedef enum { - Z3_OP_TRUE = 0x100, - Z3_OP_FALSE, - Z3_OP_EQ, - Z3_OP_DISTINCT, - Z3_OP_ITE, - Z3_OP_AND, - Z3_OP_OR, - Z3_OP_IFF, - Z3_OP_XOR, - Z3_OP_NOT, - Z3_OP_IMPLIES, - Z3_OP_OEQ, - - - Z3_OP_ANUM = 0x200, - Z3_OP_LE, - Z3_OP_GE, - Z3_OP_LT, - Z3_OP_GT, - Z3_OP_ADD, - Z3_OP_SUB, - Z3_OP_UMINUS, - Z3_OP_MUL, - Z3_OP_DIV, - Z3_OP_IDIV, - Z3_OP_REM, - Z3_OP_MOD, - Z3_OP_TO_REAL, - Z3_OP_TO_INT, - Z3_OP_IS_INT, - - Z3_OP_STORE = 0x300, - Z3_OP_SELECT, - Z3_OP_CONST_ARRAY, - Z3_OP_ARRAY_MAP, - Z3_OP_ARRAY_DEFAULT, - Z3_OP_SET_UNION, - Z3_OP_SET_INTERSECT, - Z3_OP_SET_DIFFERENCE, - Z3_OP_SET_COMPLEMENT, - Z3_OP_SET_SUBSET, - Z3_OP_AS_ARRAY, - - Z3_OP_BNUM = 0x400, - Z3_OP_BIT1, - Z3_OP_BIT0, - Z3_OP_BNEG, - Z3_OP_BADD, - Z3_OP_BSUB, - Z3_OP_BMUL, - - Z3_OP_BSDIV, - Z3_OP_BUDIV, - Z3_OP_BSREM, - Z3_OP_BUREM, - Z3_OP_BSMOD, - - // special functions to record the division by 0 cases - // these are internal functions - Z3_OP_BSDIV0, - Z3_OP_BUDIV0, - Z3_OP_BSREM0, - Z3_OP_BUREM0, - Z3_OP_BSMOD0, - - Z3_OP_ULEQ, - Z3_OP_SLEQ, - Z3_OP_UGEQ, - Z3_OP_SGEQ, - Z3_OP_ULT, - Z3_OP_SLT, - Z3_OP_UGT, - Z3_OP_SGT, - - Z3_OP_BAND, - Z3_OP_BOR, - Z3_OP_BNOT, - Z3_OP_BXOR, - Z3_OP_BNAND, - Z3_OP_BNOR, - Z3_OP_BXNOR, - - Z3_OP_CONCAT, - Z3_OP_SIGN_EXT, - Z3_OP_ZERO_EXT, - Z3_OP_EXTRACT, - Z3_OP_REPEAT, - - Z3_OP_BREDOR, - Z3_OP_BREDAND, - Z3_OP_BCOMP, - - Z3_OP_BSHL, - Z3_OP_BLSHR, - Z3_OP_BASHR, - Z3_OP_ROTATE_LEFT, - Z3_OP_ROTATE_RIGHT, - Z3_OP_EXT_ROTATE_LEFT, - Z3_OP_EXT_ROTATE_RIGHT, - - Z3_OP_INT2BV, - Z3_OP_BV2INT, - Z3_OP_CARRY, - Z3_OP_XOR3, - - Z3_OP_PR_UNDEF = 0x500, - Z3_OP_PR_TRUE, - Z3_OP_PR_ASSERTED, - Z3_OP_PR_GOAL, - Z3_OP_PR_MODUS_PONENS, - Z3_OP_PR_REFLEXIVITY, - Z3_OP_PR_SYMMETRY, - Z3_OP_PR_TRANSITIVITY, - Z3_OP_PR_TRANSITIVITY_STAR, - Z3_OP_PR_MONOTONICITY, - Z3_OP_PR_QUANT_INTRO, - Z3_OP_PR_DISTRIBUTIVITY, - Z3_OP_PR_AND_ELIM, - Z3_OP_PR_NOT_OR_ELIM, - Z3_OP_PR_REWRITE, - Z3_OP_PR_REWRITE_STAR, - Z3_OP_PR_PULL_QUANT, - Z3_OP_PR_PULL_QUANT_STAR, - Z3_OP_PR_PUSH_QUANT, - Z3_OP_PR_ELIM_UNUSED_VARS, - Z3_OP_PR_DER, - Z3_OP_PR_QUANT_INST, - Z3_OP_PR_HYPOTHESIS, - Z3_OP_PR_LEMMA, - Z3_OP_PR_UNIT_RESOLUTION, - Z3_OP_PR_IFF_TRUE, - Z3_OP_PR_IFF_FALSE, - Z3_OP_PR_COMMUTATIVITY, - Z3_OP_PR_DEF_AXIOM, - Z3_OP_PR_DEF_INTRO, - Z3_OP_PR_APPLY_DEF, - Z3_OP_PR_IFF_OEQ, - Z3_OP_PR_NNF_POS, - Z3_OP_PR_NNF_NEG, - Z3_OP_PR_NNF_STAR, - Z3_OP_PR_CNF_STAR, - Z3_OP_PR_SKOLEMIZE, - Z3_OP_PR_MODUS_PONENS_OEQ, - Z3_OP_PR_TH_LEMMA, - - Z3_OP_RA_STORE = 0x600, - Z3_OP_RA_EMPTY, - Z3_OP_RA_IS_EMPTY, - Z3_OP_RA_JOIN, - Z3_OP_RA_UNION, - Z3_OP_RA_WIDEN, - Z3_OP_RA_PROJECT, - Z3_OP_RA_FILTER, - Z3_OP_RA_NEGATION_FILTER, - Z3_OP_RA_RENAME, - Z3_OP_RA_COMPLEMENT, - Z3_OP_RA_SELECT, - Z3_OP_RA_CLONE, - Z3_OP_FD_LT, - - - Z3_OP_UNINTERPRETED -} Z3_decl_kind; - - - -/** - \conly \brief The different kinds of search failure types. - - \conly - Z3_NO_FAILURE: The last search was successful - \conly - Z3_UNKNOWN: Undocumented failure reason - \conly - Z3_TIMEOUT: Timeout - \conly - Z3_MEMOUT_WATERMAK: Search hit a memory high-watermak limit - \conly - Z3_CANCELED: External cancel flag was set - \conly - Z3_NUM_CONFLICTS: Maximum number of conflicts was reached - \conly - Z3_THEORY: Theory is incomplete - \conly - Z3_QUANTIFIERS: Logical context contains universal quantifiers -*/ -typedef enum { - Z3_NO_FAILURE, - Z3_UNKNOWN, - Z3_TIMEOUT, - Z3_MEMOUT_WATERMARK, - Z3_CANCELED, - Z3_NUM_CONFLICTS, - Z3_THEORY, - Z3_QUANTIFIERS -} Z3_search_failure; - -/** - \conly \brief Z3 pretty printing modes (See #Z3_set_ast_print_mode). - - \conly - Z3_PRINT_SMTLIB_FULL: Print AST nodes in SMTLIB verbose format. - \conly - Z3_PRINT_LOW_LEVEL: Print AST nodes using a low-level format. - \conly - Z3_PRINT_SMTLIB_COMPLIANT: Print AST nodes in SMTLIB 1.x compliant format. - \conly - Z3_PRINT_SMTLIB2_COMPLIANT: Print AST nodes in SMTLIB 2.x compliant format. -*/ -typedef enum { - Z3_PRINT_SMTLIB_FULL, - Z3_PRINT_LOW_LEVEL, - Z3_PRINT_SMTLIB_COMPLIANT, - Z3_PRINT_SMTLIB2_COMPLIANT -} Z3_ast_print_mode; - -#ifndef CAMLIDL - -/** - \conly \brief Z3 error codes (See #Z3_get_error_code). - - \conly - Z3_OK, - \conly - Z3_SORT_ERROR: User tried to build an invalid (type incorrect) AST. - \conly - Z3_IOB: Index out of bounds - \conly - Z3_INVALID_ARG: Invalid argument was provided - \conly - Z3_PARSER_ERROR: An error occurred when parsing a string or file. - \conly - Z3_NO_PARSER: Parser output is not available, that is, user didn't invoke Z3_parse_smtlib_string or Z3_parse_smtlib_file. - \conly - Z3_INVALID_PATTERN: Invalid pattern was used to build a quantifier. - \conly - Z3_MEMOUT_FAIL: A memory allocation failure was encountered. - \conly - Z3_FILE_ACCESS_ERRROR: A file could not be accessed. - \conly - Z3_INVALID_USAGE: API call is invalid in the current state. - \conly - Z3_INTERNAL_FATAL: An error internal to Z3 occurred. - \conly - Z3_DEC_REF_ERROR: Trying decrement the reference counter of an AST that was deleted or the reference counter was not initialized with #Z3_inc_ref. -*/ -typedef enum -{ - Z3_OK, - Z3_SORT_ERROR, - Z3_IOB, - Z3_INVALID_ARG, - Z3_PARSER_ERROR, - Z3_NO_PARSER, - Z3_INVALID_PATTERN, - Z3_MEMOUT_FAIL, - Z3_FILE_ACCESS_ERROR, - Z3_INTERNAL_FATAL, - Z3_INVALID_USAGE, - Z3_DEC_REF_ERROR -} Z3_error_code; - - - -/** - \conly \brief Z3 custom error handler (See #Z3_set_error_handler). -*/ -typedef void Z3_error_handler(Z3_error_code e); - - -#endif // CAMLIDL - -/*@}*/ - -#ifndef CAMLIDL -#ifdef __cplusplus -extern "C" { -#endif // __cplusplus -#else -[pointer_default(ref)] interface Z3 { -#endif // CAMLIDL - - /** - @name Create configuration - */ - /*@{*/ - - /** - \brief Create a configuration. - - Configurations are created in order to assign parameters prior to creating - contexts for Z3 interaction. For example, if the users whishes to use model - generation, then call: - - \ccode{Z3_set_param_value(cfg\, "MODEL"\, "true")} - - \mlonly \remark Consider using {!Z3.mk_context_x} instead of using - explicit configuration objects. The function {!Z3.mk_context_x} - receives an array of string pairs. This array represents the - configuration options. \endmlonly - - \sa Z3_set_param_value - \sa Z3_del_config - */ - Z3_config Z3_API Z3_mk_config(); - - /** - \brief Delete the given configuration object. - - \sa Z3_mk_config - */ - void Z3_API Z3_del_config(__in Z3_config c); - - /** - \brief Set a configuration parameter. - - The list of all configuration parameters can be obtained using the Z3 executable: - - \verbatim - z3.exe -ini? - \endverbatim - - \sa Z3_mk_config - */ - void Z3_API Z3_set_param_value(__in Z3_config c, __in_z Z3_string param_id, __in_z Z3_string param_value); - - - /*@}*/ - - /** - @name Create context - */ - /*@{*/ - - /** - \brief Create a context using the given configuration. - - After a context is created, the configuration cannot be changed. - All main interaction with Z3 happens in the context of a \c Z3_context. - - \mlonly \remark Consider using {!Z3.mk_context_x} instead of using - explicit configuration objects. The function {!Z3.mk_context_x} - receives an array of string pairs. This array represents the - configuration options. \endmlonly - - \sa Z3_del_context - */ - Z3_context Z3_API Z3_mk_context(__in Z3_config c); - - /** - \brief Create a context using the given configuration. - This function is similar to #Z3_mk_context. However, - in the context returned by this function, the user - is responsible for managing Z3_ast reference counters. - Managing reference counters is a burden and error-prone, - but allows the user to use the memory more efficiently. - The user must invoke #Z3_inc_ref for any Z3_ast returned - by Z3, and #Z3_dec_ref whenever the Z3_ast is not needed - anymore. This idiom is similar to the one used in - BDD (binary decision diagrams) packages such as CUDD. - - Remark: Z3_sort, Z3_func_decl, Z3_app, Z3_pattern are - Z3_ast's. - - After a context is created, the configuration cannot be changed. - All main interaction with Z3 happens in the context of a \c Z3_context. - */ - Z3_context Z3_API Z3_mk_context_rc(__in Z3_config c); - - /** - \brief Set the SMTLIB logic to be used in the given logical context. - It is incorrect to invoke this function after invoking - #Z3_check, #Z3_check_and_get_model, #Z3_check_assumptions and #Z3_push. - Return \c Z3_TRUE if the logic was changed successfully, and \c Z3_FALSE otherwise. - */ - Z3_bool Z3_API Z3_set_logic(__in Z3_context c, __in_z Z3_string logic); - - /** - \brief Delete the given logical context. - - \sa Z3_mk_config - */ - void Z3_API Z3_del_context(__in Z3_context c); - - /** - \brief Increment the reference counter of the given AST. - The context \c c should have been created using #Z3_mk_context_rc. - This function is a NOOP if \c c was created using #Z3_mk_context. - */ - void Z3_API Z3_inc_ref(__in Z3_context c, __in Z3_ast a); - - /** - \brief Decrement the reference counter of the given AST. - The context \c c should have been created using #Z3_mk_context_rc. - This function is a NOOP if \c c was created using #Z3_mk_context. - */ - void Z3_API Z3_dec_ref(__in Z3_context c, __in Z3_ast a); - - /** - \brief Enable trace messages to a file - - When trace messages are enabled, Z3 will record the operations performed on a context in the given file file. - Return \c Z3_TRUE if the file was opened successfully, and \c Z3_FALSE otherwise. - - \sa Z3_trace_off - */ - Z3_bool Z3_API Z3_trace_to_file(__in Z3_context c, __in_z Z3_string trace_file); - - /** - \brief Enable trace messages to a standard error. - - \sa Z3_trace_off - */ - void Z3_API Z3_trace_to_stderr(__in Z3_context c); - - /** - \brief Enable trace messages to a standard output. - - \sa Z3_trace_off - */ - void Z3_API Z3_trace_to_stdout(__in Z3_context c); - - /** - \brief Disable trace messages. - - \sa Z3_trace_to_file - \sa Z3_trace_to_stdout - \sa Z3_trace_to_stderr - */ - void Z3_API Z3_trace_off(__in Z3_context c); - - /** - \brief Enable/disable printing warning messages to the console. - - Warnings are printed after passing \c true, warning messages are - suppressed after calling this method with \c false. - */ - void Z3_API Z3_toggle_warning_messages(__in Z3_bool enabled); - - /** - \brief Update a mutable configuration parameter. - - The list of all configuration parameters can be obtained using the Z3 executable: - - \verbatim - z3.exe -ini? - \endverbatim - - Only a few configuration parameters are mutable once the context is created. - The error handler is invoked when trying to modify an immutable parameter. - - \sa Z3_set_param_value - */ - void Z3_API Z3_update_param_value(__in Z3_context c, __in_z Z3_string param_id, __in_z Z3_string param_value); - - /** - \brief Get a configuration parameter. - - Returns false if the parameter value does not exist. - - \sa Z3_mk_config - \sa Z3_set_param_value - */ - -#ifndef CAMLIDL - Z3_bool Z3_API Z3_get_param_value(__in Z3_context c, __in_z Z3_string param_id, __out_z Z3_string_ptr param_value); -#endif - - /*@}*/ - - /** - @name Symbols - */ - /*@{*/ - /** - \brief Create a Z3 symbol using an integer. - - Symbols are used to name several term and type constructors. - - NB. Not all integers can be passed to this function. - The legal range of unsigned integers is 0 to 2^30-1. - - \sa Z3_mk_string_symbol - */ - Z3_symbol Z3_API Z3_mk_int_symbol(__in Z3_context c, __in int i); - - /** - \brief Create a Z3 symbol using a C string. - - Symbols are used to name several term and type constructors. - - \sa Z3_mk_int_symbol - */ - Z3_symbol Z3_API Z3_mk_string_symbol(__in Z3_context c, __in_z Z3_string s); - /*@}*/ - - - /** - @name Sorts - */ - /*@{*/ - - /** - \brief compare sorts. - */ - Z3_bool Z3_API Z3_is_eq_sort(__in Z3_context c, __in Z3_sort s1, __in Z3_sort s2); - - /** - \brief Create a free (uninterpreted) type using the given name (symbol). - - Two free types are considered the same iff the have the same name. - */ - Z3_sort Z3_API Z3_mk_uninterpreted_sort(__in Z3_context c, __in Z3_symbol s); - - - /** - \brief Create the Boolean type. - - This type is used to create propositional variables and predicates. - */ - Z3_sort Z3_API Z3_mk_bool_sort(__in Z3_context c); - - /** - \brief Create an integer type. - - This type is not the int type found in programming languages. - A machine integer can be represented using bit-vectors. The function - #Z3_mk_bv_sort creates a bit-vector type. - - \sa Z3_mk_bv_sort - */ - Z3_sort Z3_API Z3_mk_int_sort(__in Z3_context c); - - /** - \brief Create a real type. - - This type is not a floating point number. - Z3 does not have support for floating point numbers yet. - */ - Z3_sort Z3_API Z3_mk_real_sort(__in Z3_context c); - - /** - \brief Create a bit-vector type of the given size. - - This type can also be seen as a machine integer. - - \remark The size of the bitvector type must be greater than zero. - */ - Z3_sort Z3_API Z3_mk_bv_sort(__in Z3_context c, __in unsigned sz); - - /** - \brief Create an array type. - - We usually represent the array type as: [domain -> range]. - Arrays are usually used to model the heap/memory in software verification. - - \sa Z3_mk_select - \sa Z3_mk_store - */ - Z3_sort Z3_API Z3_mk_array_sort(__in Z3_context c, __in Z3_sort domain, __in Z3_sort range); - - /** - \brief Create a tuple type. - - \mlonly [mk_tuple_sort c name field_names field_sorts] creates a tuple with a constructor named [name], - a [n] fields, where [n] is the size of the arrays [field_names] and [field_sorts]. - \endmlonly - - \conly A tuple with \c n fields has a constructor and \c n projections. - \conly This function will also declare the constructor and projection functions. - - \param c logical context - \param mk_tuple_name name of the constructor function associated with the tuple type. - \param num_fields number of fields in the tuple type. - \param field_names name of the projection functions. - \param field_sorts type of the tuple fields. - \param mk_tuple_decl output parameter that will contain the constructor declaration. - \param proj_decl output parameter that will contain the projection function declarations. This field must be a buffer of size \c num_fields allocated by the user. - */ - Z3_sort Z3_API Z3_mk_tuple_sort(__in Z3_context c, - __in Z3_symbol mk_tuple_name, - __in unsigned num_fields, - __in_ecount(num_fields) Z3_symbol const field_names[], - __in_ecount(num_fields) Z3_sort const field_sorts[], - __out Z3_func_decl * mk_tuple_decl, - __out_ecount(num_fields) Z3_func_decl proj_decl[]); - - /** - \brief Create a enumeration sort. - - \mlonly [mk_enumeration_sort c enums] creates an enumeration sort with enumeration names [enums], - it also returns [n] predicates, where [n] is the number of [enums] corresponding - to testing whether an element is one of the enumerants. - \endmlonly - - \conly An enumeration sort with \c n elements. - \conly This function will also declare the functions corresponding to the enumerations. - - \param c logical context - \param name name of the enumeration sort. - \param n number of elemenets in enumeration sort. - \param enum_names names of the enumerated elements. - \param enum_consts constants corresponding to the enumerated elements. - \param enum_testers predicates testing if terms of the enumeration sort correspond to an enumeration. - */ - Z3_sort Z3_API Z3_mk_enumeration_sort(__in Z3_context c, - __in Z3_symbol name, - __in unsigned n, - __in_ecount(n) Z3_symbol const enum_names[], - __out_ecount(n) Z3_func_decl enum_consts[], - __out_ecount(n) Z3_func_decl enum_testers[]); - - /** - \brief Create a list sort - - \mlonly [mk_list_sort c name elem_sort] creates a list sort of [name], over elements of sort [elem_sort]. - \endmlonly - - \conly A list sort over \c elem_sort - \conly This function declares the corresponding constructors and testers for lists. - - \param c logical context - \param name name of the list sort. - \param elem_sort sort of list elements. - \param nil_decl declaration for the empty list. - \param is_nil_decl test for the empty list. - \param cons_decl declaration for a cons cell. - \param is_cons_decl cons cell test. - \param head_decl list head. - \param tail_decl list tail. - */ - - Z3_sort Z3_API Z3_mk_list_sort(__in Z3_context c, - __in Z3_symbol name, - __in Z3_sort elem_sort, - __out Z3_func_decl* nil_decl, - __out Z3_func_decl* is_nil_decl, - __out Z3_func_decl* cons_decl, - __out Z3_func_decl* is_cons_decl, - __out Z3_func_decl* head_decl, - __out Z3_func_decl* tail_decl - ); - - /** - \brief Create a constructor. - - \param c logical context. - \param name constructor name. - \param recognizer name of recognizer function. - \param num_fields number of fields in constructor. - \param field_names names of the constructor fields. - \param sorts field sorts, 0 if the field sort refers to a recursive sort. - \param sort_refs reference to datatype sort that is an argument to the constructor; if the corresponding - sort reference is 0, then the value in sort_refs should be an index referring to - one of the recursive datatypes that is declared. - */ - - Z3_constructor Z3_API Z3_mk_constructor(__in Z3_context c, - __in Z3_symbol name, - __in Z3_symbol recognizer, - __in unsigned num_fields, - __in_ecount(num_fields) Z3_symbol const field_names[], - __in_ecount(num_fields) Z3_sort const sorts[], - __in_ecount(num_fields) unsigned sort_refs[] - ); - - /** - \brief Query constructor for declared funcions. - - \param c logical context. - \param constr constructor container. The container must have been passed in to a #Z3_mk_datatype call. - \param num_fields number of accessor fields in the constructor. - \param constructor constructor function declaration. - \param tester constructor test function declaration. - \param accessors array of accessor function declarations. - */ - - void Z3_API Z3_query_constructor(__in Z3_context c, - __in Z3_constructor constr, - __in unsigned num_fields, - __out Z3_func_decl* constructor, - __out Z3_func_decl* tester, - __out_ecount(num_fields) Z3_func_decl accessors[]); - - /** - \brief Reclaim memory allocated to constructor. - - \param c logical context. - \param constr constructor. - */ - - void Z3_API Z3_del_constructor(__in Z3_context c, __in Z3_constructor constr); - - /** - \brief Create recursive datatype. Return the datatype sort. - - \param c logical context. - \param name name of datatype. - \param num_constructors number of constructors passed in. - \param constructors array of constructor containers. - */ - - Z3_sort Z3_API Z3_mk_datatype(__in Z3_context c, - __in Z3_symbol name, - __in unsigned num_constructors, - __inout_ecount(num_constructors) Z3_constructor constructors[]); - - - /** - \brief Create list of constructors. - - \param c logical context. - \param num_constructors number of constructors in list. - \param constructors list of constructors. - */ - - Z3_constructor_list Z3_API Z3_mk_constructor_list(__in Z3_context c, - __in unsigned num_constructors, - __in_ecount(num_constructors) Z3_constructor constructors[]); - - /** - \brief reclaim memory allocated for constructor list. - - Each constructor inside the constructor list must be independently reclaimed using #Z3_del_constructor. - - \param c logical context. - \param clist constructor list container. - - */ - - void Z3_API Z3_del_constructor_list(__in Z3_context c, __in Z3_constructor_list clist); - - /** - \brief Create mutually recursive datatypes. - - \param c logical context. - \param num_sorts number of datatype sorts. - \param sort_names names of datatype sorts. - \param sorts array of datattype sorts. - \param constructor_lists list of constructors, one list per sort. - */ - - void Z3_API Z3_mk_datatypes(__in Z3_context c, - __in unsigned num_sorts, - __in_ecount(num_sorts) Z3_symbol sort_names[], - __out_ecount(num_sorts) Z3_sort sorts[], - __inout_ecount(num_sorts) Z3_constructor_list constructor_lists[]); - - /*@}*/ - - - - - /** - @name Injective functions - */ - /*@{*/ - - - /** - \brief Create injective function declaration - */ - Z3_func_decl Z3_API Z3_mk_injective_function( - __in Z3_context c, - __in Z3_symbol s, - unsigned domain_size, __in_ecount(domain_size) Z3_sort const domain[], - __in Z3_sort range - ); - - /*@}*/ - - /** - @name Constants and Applications - */ - /*@{*/ - - /** - \brief compare terms. - */ - Z3_bool Z3_API Z3_is_eq_ast(__in Z3_context c, __in Z3_ast t1, Z3_ast t2); - - - /** - \brief compare terms. - */ - Z3_bool Z3_API Z3_is_eq_func_decl(__in Z3_context c, __in Z3_func_decl f1, Z3_func_decl f2); - - - /** - \brief Declare a constant or function. - - \mlonly [mk_func_decl c n d r] creates a function with name [n], domain [d], and range [r]. - The arity of the function is the size of the array [d]. \endmlonly - - \param c logical context. - \param s name of the constant or function. - \param domain_size number of arguments. It is 0 when declaring a constant. - \param domain array containing the sort of each argument. The array must contain domain_size elements. It is 0 whe declaring a constant. - \param range sort of the constant or the return sort of the function. - - After declaring a constant or function, the function - #Z3_mk_app can be used to create a constant or function - application. - - \sa Z3_mk_app - */ - Z3_func_decl Z3_API Z3_mk_func_decl(__in Z3_context c, __in Z3_symbol s, - __in unsigned domain_size, __in_ecount(domain_size) Z3_sort const domain[], - __in Z3_sort range); - - - /** - \brief Create a constant or function application. - - \sa Z3_mk_func_decl - */ - Z3_ast Z3_API Z3_mk_app( - __in Z3_context c, - __in Z3_func_decl d, - __in unsigned num_args, - __in_ecount(num_args) Z3_ast const args[]); - - /** - \brief Declare and create a constant. - - \conly This function is a shorthand for: - \conly \code - \conly Z3_func_decl d = Z3_mk_func_decl(c, s, 0, 0, ty); - \conly Z3_ast n = Z3_mk_app(c, d, 0, 0); - \conly \endcode - - \mlonly [mk_const c s t] is a shorthand for [mk_app c (mk_func_decl c s [||] t) [||]] \endmlonly - - \sa Z3_mk_func_decl - \sa Z3_mk_app - */ - Z3_ast Z3_API Z3_mk_const(__in Z3_context c, __in Z3_symbol s, __in Z3_sort ty); - - /** - \brief Create a labeled formula. - - \param c logical context. - \param s name of the label. - \param is_pos label polarity. - \param f formula being labeled. - - A label behaves as an identity function, so the truth value of the - labeled formula is unchanged. Labels are used for identifying - useful sub-formulas when generating counter-examples. - */ - Z3_ast Z3_API Z3_mk_label(__in Z3_context c, __in Z3_symbol s, Z3_bool is_pos, Z3_ast f); - - /** - \brief Declare a fresh constant or function. - - Z3 will generate an unique name for this function declaration. - \conly If prefix is different from \c NULL, then the name generate by Z3 will start with \c prefix. - - \conly \remark If \c prefix is NULL, then it is assumed to be the empty string. - - \sa Z3_mk_func_decl - */ - Z3_func_decl Z3_API Z3_mk_fresh_func_decl(__in Z3_context c, __in_z Z3_string prefix, - __in unsigned domain_size, __in_ecount(domain_size) Z3_sort const domain[], - __in Z3_sort range); - - /** - \brief Declare and create a fresh constant. - - \conly This function is a shorthand for: - \conly \code Z3_func_decl d = Z3_mk_fresh_func_decl(c, prefix, 0, 0, ty); Z3_ast n = Z3_mk_app(c, d, 0, 0); \endcode - - \mlonly [mk_fresh_const c p t] is a shorthand for [mk_app c (mk_fresh_func_decl c p [||] t) [||]]. \endmlonly - - \conly \remark If \c prefix is NULL, then it is assumed to be the empty string. - - \sa Z3_mk_func_decl - \sa Z3_mk_app - */ - Z3_ast Z3_API Z3_mk_fresh_const(__in Z3_context c, __in_z Z3_string prefix, __in Z3_sort ty); - - - /** - \brief Create an AST node representing \c true. - */ - Z3_ast Z3_API Z3_mk_true(__in Z3_context c); - - /** - \brief Create an AST node representing \c false. - */ - Z3_ast Z3_API Z3_mk_false(__in Z3_context c); - - /** - \brief \mlh mk_eq c l r \endmlh - Create an AST node representing l = r. - - The nodes \c l and \c r must have the same type. - */ - Z3_ast Z3_API Z3_mk_eq(__in Z3_context c, __in Z3_ast l, __in Z3_ast r); - - /** - \conly \brief Create an AST node representing distinct(args[0], ..., args[num_args-1]). - \mlonly \brief \[ [mk_distinct c [| t_1; ...; t_n |]] \] Create an AST - node represeting a distinct construct. It is used for declaring - the arguments t_i pairwise distinct. \endmlonly - - \conly The \c distinct construct is used for declaring the arguments pairwise distinct. - \conly That is, Forall 0 <= i < j < num_args. not args[i] = args[j]. - - All arguments must have the same sort. - - \remark The number of arguments of a distinct construct must be greater than one. - */ - Z3_ast Z3_API Z3_mk_distinct(__in Z3_context c, __in unsigned num_args, __in_ecount(num_args) Z3_ast const args[]); - - /** - \brief \mlh mk_not c a \endmlh - Create an AST node representing not(a). - - The node \c a must have Boolean sort. - */ - Z3_ast Z3_API Z3_mk_not(__in Z3_context c, __in Z3_ast a); - - /** - \brief \mlh mk_ite c t1 t2 t2 \endmlh - Create an AST node representing an if-then-else: ite(t1, t2, - t3). - - The node \c t1 must have Boolean sort, \c t2 and \c t3 must have the same sort. - The sort of the new node is equal to the sort of \c t2 and \c t3. - */ - Z3_ast Z3_API Z3_mk_ite(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2, __in Z3_ast t3); - - /** - \brief \mlh mk_iff c t1 t2 \endmlh - Create an AST node representing t1 iff t2. - - The nodes \c t1 and \c t2 must have Boolean sort. - */ - Z3_ast Z3_API Z3_mk_iff(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); - - /** - \brief \mlh mk_implies c t1 t2 \endmlh - Create an AST node representing t1 implies t2. - - The nodes \c t1 and \c t2 must have Boolean sort. - */ - Z3_ast Z3_API Z3_mk_implies(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); - - /** - \brief \mlh mk_xor c t1 t2 \endmlh - Create an AST node representing t1 xor t2. - - The nodes \c t1 and \c t2 must have Boolean sort. - */ - Z3_ast Z3_API Z3_mk_xor(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); - - /** - \conly \brief Create an AST node representing args[0] and ... and args[num_args-1]. - \mlonly \brief \[ [mk_and c [| t_1; ...; t_n |]] \] Create the conjunction: {e t_1 and ... and t_n}. \endmlonly - - \conly The array \c args must have \c num_args elements. - All arguments must have Boolean sort. - - \remark The number of arguments must be greater than zero. - */ - Z3_ast Z3_API Z3_mk_and(__in Z3_context c, __in unsigned num_args, __in_ecount(num_args) Z3_ast const args[]); - - /** - \conly \brief Create an AST node representing args[0] or ... or args[num_args-1]. - \mlonly \brief \[ [mk_or c [| t_1; ...; t_n |]] \] Create the disjunction: {e t_1 or ... or t_n}. \endmlonly - - \conly The array \c args must have \c num_args elements. - All arguments must have Boolean sort. - - \remark The number of arguments must be greater than zero. - */ - Z3_ast Z3_API Z3_mk_or(__in Z3_context c, __in unsigned num_args, __in_ecount(num_args) Z3_ast const args[]); - - /** - \conly \brief Create an AST node representing args[0] + ... + args[num_args-1]. - \mlonly \brief \[ [mk_add c [| t_1; ...; t_n |]] \] Create the term: {e t_1 + ... + t_n}. \endmlonly - - \conly The array \c args must have \c num_args elements. - All arguments must have int or real sort. - - \remark The number of arguments must be greater than zero. - */ - Z3_ast Z3_API Z3_mk_add(__in Z3_context c, __in unsigned num_args, __in_ecount(num_args) Z3_ast const args[]); - - /** - \conly \brief Create an AST node representing args[0] * ... * args[num_args-1]. - \mlonly \brief \[ [mk_mul c [| t_1; ...; t_n |]] \] Create the term: {e t_1 * ... * t_n}. \endmlonly - - \conly The array \c args must have \c num_args elements. - All arguments must have int or real sort. - - \remark Z3 has limited support for non-linear arithmetic. - \remark The number of arguments must be greater than zero. - */ - Z3_ast Z3_API Z3_mk_mul(__in Z3_context c, __in unsigned num_args, __in_ecount(num_args) Z3_ast const args[]); - - /** - \conly \brief Create an AST node representing args[0] - ... - args[num_args - 1]. - \mlonly \brief \[ [mk_sub c [| t_1; ...; t_n |]] \] Create the term: {e t_1 - ... - t_n}. \endmlonly - - \conly The array \c args must have \c num_args elements. - All arguments must have int or real sort. - - \remark The number of arguments must be greater than zero. - */ - Z3_ast Z3_API Z3_mk_sub(__in Z3_context c, __in unsigned num_args, __in_ecount(num_args) Z3_ast const args[]); - - /** - \conly \brief Create an AST node representing -arg. - \mlonly \brief \[ [mk_unary_minus c arg] \] Create the term: {e - arg}. \endmlonly - - The argument must have int or real type. - - */ - Z3_ast Z3_API Z3_mk_unary_minus(__in Z3_context c, __in Z3_ast arg); - - - /** - \conly \brief Create an AST node representing arg1 div arg2. - \mlonly \brief \[ [mk_div c t_1 t_2] \] Create the term: {e t_1 div t_2}. \endmlonly - - The arguments must either both have int type or both have real type. - If the arguments have int type, then the result type is an int type, otherwise the - the result type is real. - - */ - Z3_ast Z3_API Z3_mk_div(__in Z3_context c, __in Z3_ast arg1, __in Z3_ast arg2); - - - /** - \conly \brief Create an AST node representing arg1 mod arg2. - \mlonly \brief \[ [mk_mod c t_1 t_2] \] Create the term: {e t_1 mod t_2}. \endmlonly - - The arguments must have int type. - - */ - Z3_ast Z3_API Z3_mk_mod(__in Z3_context c, __in Z3_ast arg1, __in Z3_ast arg2); - - /** - \conly \brief Create an AST node representing arg1 rem arg2. - \mlonly \brief \[ [mk_rem c t_1 t_2] \] Create the term: {e t_1 rem t_2}. \endmlonly - - The arguments must have int type. - - */ - Z3_ast Z3_API Z3_mk_rem(__in Z3_context c, __in Z3_ast arg1, __in Z3_ast arg2); - - /** - \brief \mlh mk_lt c t1 t2 \endmlh - Create less than. - - The nodes \c t1 and \c t2 must have the same sort, and must be int or real. - */ - Z3_ast Z3_API Z3_mk_lt(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); - - /** - \brief \mlh mk_le c t1 t2 \endmlh - Create less than or equal to. - - The nodes \c t1 and \c t2 must have the same sort, and must be int or real. - */ - Z3_ast Z3_API Z3_mk_le(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); - - /** - \brief \mlh mk_gt c t1 t2 \endmlh - Create greater than. - - The nodes \c t1 and \c t2 must have the same sort, and must be int or real. - */ - Z3_ast Z3_API Z3_mk_gt(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); - - /** - \brief \mlh mk_ge c t1 t2 \endmlh - Create greater than or equal to. - - The nodes \c t1 and \c t2 must have the same sort, and must be int or real. - */ - Z3_ast Z3_API Z3_mk_ge(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); - - /** - \brief \mlh mk_int2real c t1 \endmlh - Coerce an integer to a real. - - There is also a converse operation exposed. - It follows the semantics prescribed by the SMT-LIB standard. - - You can take the floor of a real by - creating an auxiliary integer constant \c k and - and asserting mk_int2real(k) <= t1 < mk_int2real(k)+1. - - The node \c t1 must have sort integer. - - \sa Z3_mk_real2int - \sa Z3_mk_is_int - */ - Z3_ast Z3_API Z3_mk_int2real(__in Z3_context c, __in Z3_ast t1); - - /** - \brief \mlh mk_real2int c t1 \endmlh - Coerce a real to an integer. - - The semantics of this function follows the SMT-LIB standard - for the function to_int - - \sa Z3_mk_int2real - \sa Z3_mk_is_int - */ - Z3_ast Z3_API Z3_mk_real2int(__in Z3_context c, __in Z3_ast t1); - - /** - \brief \mlh mk_is_int c t1 \endmlh - Check if a real number is an integer. - - \sa Z3_mk_int2real - \sa Z3_mk_real2int - */ - Z3_ast Z3_API Z3_mk_is_int(__in Z3_context c, __in Z3_ast t1); - - /** - \brief \mlh mk_bvnot c t1 \endmlh - Bitwise negation. - - The node \c t1 must have a bit-vector sort. - */ - Z3_ast Z3_API Z3_mk_bvnot(__in Z3_context c, __in Z3_ast t1); - - /** - \brief \mlh mk_bvredand c t1 \endmlh - Take conjunction of bits in vector, return vector of length 1. - - The node \c t1 must have a bit-vector sort. - */ - Z3_ast Z3_API Z3_mk_bvredand(__in Z3_context c, __in Z3_ast t1); - - /** - \brief \mlh mk_bvredor c t1 \endmlh - Take disjunction of bits in vector, return vector of length 1. - - The node \c t1 must have a bit-vector sort. - */ - Z3_ast Z3_API Z3_mk_bvredor(__in Z3_context c, __in Z3_ast t1); - - /** - \brief \mlh mk_bvand c t1 t2 \endmlh - Bitwise and. - - The nodes \c t1 and \c t2 must have the same bit-vector sort. - */ - Z3_ast Z3_API Z3_mk_bvand(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); - - /** - \brief \mlh mk_bvor c t1 t2 \endmlh - Bitwise or. - - The nodes \c t1 and \c t2 must have the same bit-vector sort. - */ - Z3_ast Z3_API Z3_mk_bvor(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); - - /** - \brief \mlh mk_bvxor c t1 t2 \endmlh - Bitwise exclusive-or. - - The nodes \c t1 and \c t2 must have the same bit-vector sort. - */ - Z3_ast Z3_API Z3_mk_bvxor(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); - - /** - \brief \mlh mk_bvnand c t1 t2 \endmlh - Bitwise nand. - - The nodes \c t1 and \c t2 must have the same bit-vector sort. - */ - Z3_ast Z3_API Z3_mk_bvnand(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); - - /** - \brief \mlh mk_bvnor c t1 t2 \endmlh - Bitwise nor. - - The nodes \c t1 and \c t2 must have the same bit-vector sort. - */ - Z3_ast Z3_API Z3_mk_bvnor(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); - - /** - \brief \mlh mk_bvxnor c t1 t2 \endmlh - Bitwise xnor. - - The nodes \c t1 and \c t2 must have the same bit-vector sort. - */ - Z3_ast Z3_API Z3_mk_bvxnor(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); - - /** - \brief \mlh mk_bvneg c t1 \endmlh - Standard two's complement unary minus. - - The node \c t1 must have bit-vector sort. - */ - Z3_ast Z3_API Z3_mk_bvneg(__in Z3_context c, __in Z3_ast t1); - - /** - \brief \mlh mk_bvadd c t1 t2 \endmlh - Standard two's complement addition. - - The nodes \c t1 and \c t2 must have the same bit-vector sort. - */ - Z3_ast Z3_API Z3_mk_bvadd(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); - - /** - \brief \mlh mk_bvsub c t1 t2 \endmlh - Standard two's complement subtraction. - - The nodes \c t1 and \c t2 must have the same bit-vector sort. - */ - Z3_ast Z3_API Z3_mk_bvsub(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); - - /** - \brief \mlh mk_bvmul c t1 t2 \endmlh - Standard two's complement multiplication. - - The nodes \c t1 and \c t2 must have the same bit-vector sort. - */ - Z3_ast Z3_API Z3_mk_bvmul(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); - - /** - \brief \mlh mk_bvudiv c t1 t2 \endmlh - Unsigned division. - - It is defined as the \c floor of t1/t2 if \c t2 is - different from zero. If t2 is zero, then the result - is undefined. - - The nodes \c t1 and \c t2 must have the same bit-vector sort. - */ - Z3_ast Z3_API Z3_mk_bvudiv(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); - - /** - \brief \mlh mk_bvsdiv c t1 t2 \endmlh - Two's complement signed division. - - It is defined in the following way: - - - The \c floor of t1/t2 if \c t2 is different from zero, and t1*t2 >= 0. - - - The \c ceiling of t1/t2 if \c t2 is different from zero, and t1*t2 < 0. - - If t2 is zero, then the result is undefined. - - The nodes \c t1 and \c t2 must have the same bit-vector sort. - */ - Z3_ast Z3_API Z3_mk_bvsdiv(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); - - /** - \brief \mlh mk_bvurem c t1 t2 \endmlh - Unsigned remainder. - - It is defined as t1 - (t1 /u t2) * t2, where /u represents unsigned division. - - If t2 is zero, then the result is undefined. - - The nodes \c t1 and \c t2 must have the same bit-vector sort. - */ - Z3_ast Z3_API Z3_mk_bvurem(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); - - /** - \brief \mlh mk_bvsrem c t1 t2 \endmlh - Two's complement signed remainder (sign follows dividend). - - It is defined as t1 - (t1 /s t2) * t2, where /s represents signed division. - The most significant bit (sign) of the result is equal to the most significant bit of \c t1. - - If t2 is zero, then the result is undefined. - - The nodes \c t1 and \c t2 must have the same bit-vector sort. - - \sa Z3_mk_bvsmod - */ - Z3_ast Z3_API Z3_mk_bvsrem(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); - - /** - \brief \mlh mk_bvsmod c t1 t2 \endmlh - Two's complement signed remainder (sign follows divisor). - - If t2 is zero, then the result is undefined. - - The nodes \c t1 and \c t2 must have the same bit-vector sort. - - \sa Z3_mk_bvsrem - */ - Z3_ast Z3_API Z3_mk_bvsmod(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); - - /** - \brief \mlh mk_bvult c t1 t2 \endmlh - Unsigned less than. - - The nodes \c t1 and \c t2 must have the same bit-vector sort. - */ - Z3_ast Z3_API Z3_mk_bvult(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); - - /** - \brief \mlh mk_bvslt c t1 t2 \endmlh - Two's complement signed less than. - - It abbreviates: - \code - (or (and (= (extract[|m-1|:|m-1|] t1) bit1) - (= (extract[|m-1|:|m-1|] t2) bit0)) - (and (= (extract[|m-1|:|m-1|] t1) (extract[|m-1|:|m-1|] t2)) - (bvult t1 t2))) - \endcode - - The nodes \c t1 and \c t2 must have the same bit-vector sort. - */ - Z3_ast Z3_API Z3_mk_bvslt(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); - - /** - \brief \mlh mk_bvule c t1 t2 \endmlh - Unsigned less than or equal to. - - The nodes \c t1 and \c t2 must have the same bit-vector sort. - */ - Z3_ast Z3_API Z3_mk_bvule(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); - - /** - \brief \mlh mk_bvsle c t1 t2 \endmlh - Two's complement signed less than or equal to. - - The nodes \c t1 and \c t2 must have the same bit-vector sort. - */ - Z3_ast Z3_API Z3_mk_bvsle(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); - - /** - \brief \mlh mk_bvuge c t1 t2 \endmlh - Unsigned greater than or equal to. - - The nodes \c t1 and \c t2 must have the same bit-vector sort. - */ - Z3_ast Z3_API Z3_mk_bvuge(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); - - /** - \brief \mlh mk_bvsge c t1 t2 \endmlh - Two's complement signed greater than or equal to. - - The nodes \c t1 and \c t2 must have the same bit-vector sort. - */ - Z3_ast Z3_API Z3_mk_bvsge(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); - - /** - \brief \mlh mk_bvugt c t1 t2 \endmlh - Unsigned greater than. - - The nodes \c t1 and \c t2 must have the same bit-vector sort. - */ - Z3_ast Z3_API Z3_mk_bvugt(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); - - /** - \brief \mlh mk_bvsgt c t1 t2 \endmlh - Two's complement signed greater than. - - The nodes \c t1 and \c t2 must have the same bit-vector sort. - */ - Z3_ast Z3_API Z3_mk_bvsgt(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); - - /** - \brief \mlh mk_concat c t1 t2 \endmlh - Concatenate the given bit-vectors. - - The nodes \c t1 and \c t2 must have (possibly different) bit-vector sorts - - The result is a bit-vector of size n1+n2, where \c n1 (\c n2) is the size - of \c t1 (\c t2). - */ - Z3_ast Z3_API Z3_mk_concat(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); - - /** - \brief \mlh mk_extract c high low t1 \endmlh - Extract the bits \c high down to \c low from a bitvector of - size \c m to yield a new bitvector of size \c n, where n = - high - low + 1. - - The node \c t1 must have a bit-vector sort. - */ - Z3_ast Z3_API Z3_mk_extract(__in Z3_context c, __in unsigned high, __in unsigned low, __in Z3_ast t1); - - /** - \brief \mlh mk_sign_ext c i t1 \endmlh - Sign-extend of the given bit-vector to the (signed) equivalent bitvector of - size m+i, where \c m is the size of the given - bit-vector. - - The node \c t1 must have a bit-vector sort. - */ - Z3_ast Z3_API Z3_mk_sign_ext(__in Z3_context c, __in unsigned i, __in Z3_ast t1); - - /** - \brief \mlh mk_zero_ext c i t1 \endmlh - Extend the given bit-vector with zeros to the (unsigned) equivalent - bitvector of size m+i, where \c m is the size of the - given bit-vector. - - The node \c t1 must have a bit-vector sort. - */ - Z3_ast Z3_API Z3_mk_zero_ext(__in Z3_context c, __in unsigned i, __in Z3_ast t1); - - /** - \brief \mlh mk_repeat c i t1 \endmlh - Repeat the given bit-vector up length i. - - The node \c t1 must have a bit-vector sort. - */ - Z3_ast Z3_API Z3_mk_repeat(__in Z3_context c, __in unsigned i, __in Z3_ast t1); - - /** - \brief \mlh mk_bvshl c t1 t2 \endmlh - Shift left. - - It is equivalent to multiplication by 2^x where \c x is the value of the - third argument. - - NB. The semantics of shift operations varies between environments. This - definition does not necessarily capture directly the semantics of the - programming language or assembly architecture you are modeling. - - The nodes \c t1 and \c t2 must have the same bit-vector sort. - */ - Z3_ast Z3_API Z3_mk_bvshl(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); - - /** - \brief \mlh mk_bvlshr c t1 t2 \endmlh - Logical shift right. - - It is equivalent to unsigned division by 2^x where \c x is the - value of the third argument. - - NB. The semantics of shift operations varies between environments. This - definition does not necessarily capture directly the semantics of the - programming language or assembly architecture you are modeling. - - The nodes \c t1 and \c t2 must have the same bit-vector sort. - */ - Z3_ast Z3_API Z3_mk_bvlshr(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); - - /** - \brief \mlh mk_bvashr c t1 t2 \endmlh - Arithmetic shift right. - - It is like logical shift right except that the most significant - bits of the result always copy the most significant bit of the - second argument. - - NB. The semantics of shift operations varies between environments. This - definition does not necessarily capture directly the semantics of the - programming language or assembly architecture you are modeling. - - The nodes \c t1 and \c t2 must have the same bit-vector sort. - */ - Z3_ast Z3_API Z3_mk_bvashr(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); - - /** - \brief \mlh mk_rotate_left c i t1 \endmlh - Rotate bits of \c t1 to the left \c i times. - - The node \c t1 must have a bit-vector sort. - */ - Z3_ast Z3_API Z3_mk_rotate_left(__in Z3_context c, __in unsigned i, __in Z3_ast t1); - - /** - \brief \mlh mk_rotate_right c i t1 \endmlh - Rotate bits of \c t1 to the right \c i times. - - The node \c t1 must have a bit-vector sort. - */ - Z3_ast Z3_API Z3_mk_rotate_right(__in Z3_context c, __in unsigned i, __in Z3_ast t1); - - /** - \brief \mlh mk_ext_rotate_left c t1 t2 \endmlh - Rotate bits of \c t1 to the left \c t2 times. - - The nodes \c t1 and \c t2 must have the same bit-vector sort. - */ - Z3_ast Z3_API Z3_mk_ext_rotate_left(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); - - /** - \brief \mlh mk_ext_rotate_right c t1 t2 \endmlh - Rotate bits of \c t1 to the right \c t2 times. - - The nodes \c t1 and \c t2 must have the same bit-vector sort. - */ - Z3_ast Z3_API Z3_mk_ext_rotate_right(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); - - /** - \brief \mlh mk_int2bv c n t1 \endmlh - Create an \c n bit bit-vector from the integer argument \c t1. - - NB. This function is essentially treated as uninterpreted. - So you cannot expect Z3 to precisely reflect the semantics of this function - when solving constraints with this function. - - The node \c t1 must have integer sort. - */ - Z3_ast Z3_API Z3_mk_int2bv(__in Z3_context c, __in unsigned n, __in Z3_ast t1); - - /** - \brief \mlh mk_bv2int c t1 is_signed \endmlh - Create an integer from the bit-vector argument \c t1. - If \c is_signed is false, then the bit-vector \c t1 is treated as unsigned. - So the result is non-negative - and in the range [0..2^N-1], where N are the number of bits in \c t1. - If \c is_signed is true, \c t1 is treated as a signed bit-vector. - - NB. This function is essentially treated as uninterpreted. - So you cannot expect Z3 to precisely reflect the semantics of this function - when solving constraints with this function. - - The node \c t1 must have a bit-vector sort. - */ - Z3_ast Z3_API Z3_mk_bv2int(__in Z3_context c,__in Z3_ast t1, Z3_bool is_signed); - - /** - \brief \mlh mk_bvadd_no_overflow c t1 t2 is_signed \endmlh - Create a predicate that checks that the bit-wise addition - of \c t1 and \c t2 does not overflow. - - The nodes \c t1 and \c t2 must have the same bit-vector sort. - */ - Z3_ast Z3_API Z3_mk_bvadd_no_overflow(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2, Z3_bool is_signed); - - /** - \brief \mlh mk_bvadd_no_underflow c t1 t2 \endmlh - Create a predicate that checks that the bit-wise signed addition - of \c t1 and \c t2 does not underflow. - - The nodes \c t1 and \c t2 must have the same bit-vector sort. - */ - Z3_ast Z3_API Z3_mk_bvadd_no_underflow(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); - - /** - \brief \mlh mk_bvsub_no_overflow c t1 t2 \endmlh - Create a predicate that checks that the bit-wise signed subtraction - of \c t1 and \c t2 does not overflow. - - The nodes \c t1 and \c t2 must have the same bit-vector sort. - */ - Z3_ast Z3_API Z3_mk_bvsub_no_overflow(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); - - /** - \brief \mlh mk_bvsub_no_underflow c t1 t2 is_signed \endmlh - Create a predicate that checks that the bit-wise subtraction - of \c t1 and \c t2 does not underflow. - - The nodes \c t1 and \c t2 must have the same bit-vector sort. - */ - Z3_ast Z3_API Z3_mk_bvsub_no_underflow(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2, Z3_bool is_signed); - - /** - \brief \mlh mk_bvsdiv_no_overflow c t1 t2 \endmlh - Create a predicate that checks that the bit-wise signed division - of \c t1 and \c t2 does not overflow. - - The nodes \c t1 and \c t2 must have the same bit-vector sort. - */ - Z3_ast Z3_API Z3_mk_bvsdiv_no_overflow(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); - - /** - \brief \mlh mk_bvneg_no_overflow c t1 \endmlh - Check that bit-wise negation does not overflow when - \c t1 is interpreted as a signed bit-vector. - - The node \c t1 must have bit-vector sort. - */ - Z3_ast Z3_API Z3_mk_bvneg_no_overflow(__in Z3_context c, __in Z3_ast t1); - - /** - \brief \mlh mk_bvmul_no_overflow c t1 t2 is_signed \endmlh - Create a predicate that checks that the bit-wise multiplication - of \c t1 and \c t2 does not overflow. - - The nodes \c t1 and \c t2 must have the same bit-vector sort. - */ - Z3_ast Z3_API Z3_mk_bvmul_no_overflow(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2, Z3_bool is_signed); - - /** - \brief \mlh mk_bvmul_no_underflow c t1 t2 \endmlh - Create a predicate that checks that the bit-wise signed multiplication - of \c t1 and \c t2 does not underflow. - - The nodes \c t1 and \c t2 must have the same bit-vector sort. - */ - Z3_ast Z3_API Z3_mk_bvmul_no_underflow(__in Z3_context c, __in Z3_ast t1, __in Z3_ast t2); - - /** - \brief \mlh mk_select c a i \endmlh - Array read. - - The node \c a must have an array sort [domain -> range], and \c i must have the sort \c domain. - The sort of the result is \c range. - - \sa Z3_mk_array_sort - \sa Z3_mk_store - */ - Z3_ast Z3_API Z3_mk_select(__in Z3_context c, __in Z3_ast a, __in Z3_ast i); - - /** - \brief \mlh mk_store c a i v \endmlh - Array update. - - The node \c a must have an array sort [domain -> range], \c i must have sort \c domain, - \c v must have sort range. The sort of the result is [domain -> range]. - - \sa Z3_mk_array_sort - \sa Z3_mk_select - */ - Z3_ast Z3_API Z3_mk_store(__in Z3_context c, __in Z3_ast a, __in Z3_ast i, __in Z3_ast v); - - /** - \brief Create the constant array. - - \param c logical context. - \param domain domain sort for the array. - \param v value that the array maps to. - */ - Z3_ast Z3_API Z3_mk_const_array(__in Z3_context c, __in Z3_sort domain, __in Z3_ast v); - - /** - \brief \mlh mk_map f n args \endmlh - map f on the the argument arrays. - - The \c n nodes \c args must be of array sorts [domain_i -> range_i]. - The function declaration \c f must have type range_1 .. range_n -> range. - \c v must have sort range. The sort of the result is [domain_i -> range]. - - \sa Z3_mk_array_sort - \sa Z3_mk_store - \sa Z3_mk_select - */ - Z3_ast Z3_API Z3_mk_map(__in Z3_context c, __in Z3_func_decl f, unsigned n, __in Z3_ast const* args); - - /** - \brief Access the array default value. - Produces the default range value, for arrays that can be represented as - finite maps with a default range value. - - \param c logical context. - \param array array value whose default range value is accessed. - - */ - Z3_ast Z3_API Z3_mk_array_default(__in Z3_context c, __in Z3_ast array); - - - /*@}*/ - - /** - @name Sets - */ - /*@{*/ - - /** - \brief Create Set type. - */ - Z3_sort Z3_API Z3_mk_set_sort(__in Z3_context c, __in Z3_sort ty); - - /** - \brief Create the empty set. - */ - Z3_ast Z3_API Z3_mk_empty_set(__in Z3_context c, __in Z3_sort domain); - - /** - \brief Create the full set. - */ - Z3_ast Z3_API Z3_mk_full_set(__in Z3_context c, __in Z3_sort domain); - - /** - \brief Add an element to a set. - - The first argument must be a set, the second an element. - */ - Z3_ast Z3_API Z3_mk_set_add(__in Z3_context c, __in Z3_ast set, __in Z3_ast elem); - - /** - \brief Remove an element to a set. - - The first argument must be a set, the second an element. - */ - Z3_ast Z3_API Z3_mk_set_del(__in Z3_context c, __in Z3_ast set, __in Z3_ast elem); - - /** - \brief Take the union of a list of sets. - */ - Z3_ast Z3_API Z3_mk_set_union(__in Z3_context c, __in unsigned num_args, __in_ecount(num_args) Z3_ast const args[]); - - /** - \brief Take the intersection of a list of sets. - */ - Z3_ast Z3_API Z3_mk_set_intersect(__in Z3_context c, __in unsigned num_args, __in_ecount(num_args) Z3_ast const args[]); - - /** - \brief Take the set difference between two sets. - */ - Z3_ast Z3_API Z3_mk_set_difference(__in Z3_context c, __in Z3_ast arg1, __in Z3_ast arg2); - - /** - \brief Take the complement of a set. - */ - Z3_ast Z3_API Z3_mk_set_complement(__in Z3_context c, __in Z3_ast arg); - - - /** - \brief Check for set membership. - - The first argument should be an element type of the set. - */ - Z3_ast Z3_API Z3_mk_set_member(__in Z3_context c, __in Z3_ast elem, __in Z3_ast set); - - /** - \brief Check for subsetness of sets. - */ - Z3_ast Z3_API Z3_mk_set_subset(__in Z3_context c, __in Z3_ast arg1, __in Z3_ast arg2); - /*@}*/ - - /** - @name Numerals - */ - /*@{*/ - - /** - \brief Create a numeral of a given sort. - - \param c logical context. - \param numeral A string representing the numeral value in decimal notation. If the given sort is a real, then the numeral can be a rational, that is, a string of the form [num]* / [num]*. - \param ty The sort of the numeral. In the current implementation, the given sort can be an int, real, or bit-vectors of arbitrary size. - - \sa Z3_mk_int - \sa Z3_mk_unsigned_int - */ - Z3_ast Z3_API Z3_mk_numeral(__in Z3_context c, __in_z Z3_string numeral, __in Z3_sort ty); - - /** - \brief Create a real from a fraction. - - \param c logical context. - \param num numerator of rational. - \param den denomerator of rational. - - \pre den != 0 - - \sa Z3_mk_numeral - \sa Z3_mk_int - \sa Z3_mk_unsigned_int - */ - Z3_ast Z3_API Z3_mk_real(__in Z3_context c, __in_z int num, __in_z int den); - - /** - \brief Create a numeral of a given sort. - - This function can be use to create numerals that fit in a machine integer. - It is slightly faster than #Z3_mk_numeral since it is not necessary to parse a string. - - \sa Z3_mk_numeral - */ - Z3_ast Z3_API Z3_mk_int(__in Z3_context c, __in int v, __in Z3_sort ty); - - /** - \brief Create a numeral of a given sort. - - This function can be use to create numerals that fit in a machine unsinged integer. - It is slightly faster than #Z3_mk_numeral since it is not necessary to parse a string. - - \sa Z3_mk_numeral - */ - Z3_ast Z3_API Z3_mk_unsigned_int(__in Z3_context c, __in unsigned v, __in Z3_sort ty); - -#ifndef CAMLIDL - /** - \brief Create a numeral of a given sort. - - This function can be use to create numerals that fit in a machine __int64 integer. - It is slightly faster than #Z3_mk_numeral since it is not necessary to parse a string. - - \sa Z3_mk_numeral - */ - Z3_ast Z3_API Z3_mk_int64(__in Z3_context c, __in __int64 v, __in Z3_sort ty); -#endif // CAMLIDL - -#ifndef CAMLIDL - /** - \brief Create a numeral of a given sort. - - This function can be use to create numerals that fit in a machine unsigned __int64 integer. - It is slightly faster than #Z3_mk_numeral since it is not necessary to parse a string. - - \sa Z3_mk_numeral - */ - Z3_ast Z3_API Z3_mk_unsigned_int64(__in Z3_context c, __in unsigned __int64 v, __in Z3_sort ty); -#endif // CAMLIDL - - /*@}*/ - - /** - @name Quantifiers - */ - /*@{*/ - - /** - \brief Create a pattern for quantifier instantiation. - - Z3 uses pattern matching to instantiate quantifiers. If a - pattern is not provided for a quantifier, then Z3 will - automatically compute a set of patterns for it. However, for - optimal performance, the user should provide the patterns. - - Patterns comprise a list of terms. The list should be - non-empty. If the list comprises of more than one term, it is - a called a multi-pattern. - - In general, one can pass in a list of (multi-)patterns in the - quantifier constructor. - - - \sa Z3_mk_forall - \sa Z3_mk_exists - */ - Z3_pattern Z3_API Z3_mk_pattern( - __in Z3_context c, - __in unsigned num_patterns, __in_ecount(num_patterns) Z3_ast const terms[]); - - /** - \brief Create a bound variable. - - Bound variables are indexed by de-Bruijn indices. It is perhaps easiest to explain - the meaning of de-Bruijn indices by indicating the compilation process from - non-de-Bruijn formulas to de-Bruijn format. - - \verbatim - abs(forall (x1) phi) = forall (x1) abs1(phi, x1, 0) - abs(forall (x1, x2) phi) = abs(forall (x1) abs(forall (x2) phi)) - abs1(x, x, n) = b_n - abs1(y, x, n) = y - abs1(f(t1,...,tn), x, n) = f(abs1(t1,x,n), ..., abs1(tn,x,n)) - abs1(forall (x1) phi, x, n) = forall (x1) (abs1(phi, x, n+1)) - \endverbatim - - The last line is significant: the index of a bound variable is different depending - on the scope in which it appears. The deeper x appears, the higher is its - index. - - \param c logical context - \param index de-Bruijn index - \param ty sort of the bound variable - - \sa Z3_mk_forall - \sa Z3_mk_exists - */ - Z3_ast Z3_API Z3_mk_bound(__in Z3_context c, __in unsigned index, __in Z3_sort ty); - - /** - \brief Create a forall formula. - - \mlonly [mk_forall c w p t n b] creates a forall formula, where - [w] is the weight, [p] is an array of patterns, [t] is an array - with the sorts of the bound variables, [n] is an array with the - 'names' of the bound variables, and [b] is the body of the - quantifier. Quantifiers are associated with weights indicating - the importance of using the quantifier during - instantiation. \endmlonly - - \param c logical context. - \param weight quantifiers are associated with weights indicating the importance of using the quantifier during instantiation. By default, pass the weight 0. - \param num_patterns number of patterns. - \param patterns array containing the patterns created using #Z3_mk_pattern. - \param num_decls number of variables to be bound. - \param sorts the sorts of the bound variables. - \param decl_names names of the bound variables - \param body the body of the quantifier. - - \sa Z3_mk_pattern - \sa Z3_mk_bound - \sa Z3_mk_exists - */ - Z3_ast Z3_API Z3_mk_forall(__in Z3_context c, __in unsigned weight, - __in unsigned num_patterns, __in_ecount(num_patterns) Z3_pattern const patterns[], - __in unsigned num_decls, __in_ecount(num_decls) Z3_sort const sorts[], - __in_ecount(num_decls) Z3_symbol const decl_names[], - __in Z3_ast body); - - /** - \brief Create an exists formula. Similar to #Z3_mk_forall. - - \sa Z3_mk_pattern - \sa Z3_mk_bound - \sa Z3_mk_forall - */ - Z3_ast Z3_API Z3_mk_exists(__in Z3_context c, __in unsigned weight, - __in unsigned num_patterns, __in_ecount(num_patterns) Z3_pattern const patterns[], - __in unsigned num_decls, __in_ecount(num_decls) Z3_sort const sorts[], - __in_ecount(num_decls) Z3_symbol const decl_names[], - __in Z3_ast body); - - /** - \brief Create a quantifier - universal or existential, with pattern hints. - - \param c logical context. - \param is_forall flag to indicate if this is a universal or existential quantifier. - \param weight quantifiers are associated with weights indicating the importance of using the quantifier during instantiation. By default, pass the weight 0. - \param num_patterns number of patterns. - \param patterns array containing the patterns created using #Z3_mk_pattern. - \param num_decls number of variables to be bound. - \param sorts array of sorts of the bound variables. - \param decl_names names of the bound variables. - \param body the body of the quantifier. - - \sa Z3_mk_pattern - \sa Z3_mk_bound - \sa Z3_mk_forall - \sa Z3_mk_exists - */ - - Z3_ast Z3_API Z3_mk_quantifier( - __in Z3_context c, - __in Z3_bool is_forall, - __in unsigned weight, - __in unsigned num_patterns, __in_ecount(num_patterns) Z3_pattern const* patterns, - __in unsigned num_decls, __in_ecount(num_decls) Z3_sort const* sorts, - __in_ecount(num_decls) Z3_symbol const* decl_names, - __in Z3_ast body); - - - /** - \brief Create a quantifier - universal or existential, with pattern hints, no patterns, and attributes - - \param c logical context. - \param is_forall flag to indicate if this is a universal or existential quantifier. - \param quantifier_id identifier to identify quantifier - \param skolem_id identifier to identify skolem constants introduced by quantifier. - \param weight quantifiers are associated with weights indicating the importance of using the quantifier during instantiation. By default, pass the weight 0. - \param num_patterns number of patterns. - \param patterns array containing the patterns created using #Z3_mk_pattern. - \param num_no_patterns number of patterns. - \param no_patterns array containing the patterns created using #Z3_mk_pattern. - \param num_decls number of variables to be bound. - \param sorts array of sorts of the bound variables. - \param decl_names names of the bound variables. - \param body the body of the quantifier. - - \sa Z3_mk_pattern - \sa Z3_mk_bound - \sa Z3_mk_forall - \sa Z3_mk_exists - */ - - Z3_ast Z3_API Z3_mk_quantifier_ex( - __in Z3_context c, - __in Z3_bool is_forall, - __in unsigned weight, - __in Z3_symbol quantifier_id, - __in Z3_symbol skolem_id, - __in unsigned num_patterns, __in_ecount(num_patterns) Z3_pattern const* patterns, - __in unsigned num_no_patterns, __in_ecount(num_no_patterns) Z3_ast const* no_patterns, - __in unsigned num_decls, __in_ecount(num_decls) Z3_sort const* sorts, - __in_ecount(num_decls) Z3_symbol const* decl_names, - __in Z3_ast body); - - /** - \brief Create a universal quantifier using a list of constants that - will form the set of bound variables. - - \param c logical context. - \param weight quantifiers are associated with weights indicating the importance of using - the quantifier during instantiation. By default, pass the weight 0. - \param num_bound number of constants to be abstracted into bound variables. - \param bound array of constants to be abstracted into bound variables. - \param num_patterns number of patterns. - \param patterns array containing the patterns created using #Z3_mk_pattern. - \param body the body of the quantifier. - - \sa Z3_mk_pattern - \sa Z3_mk_exists_const - - */ - - Z3_ast Z3_API Z3_mk_forall_const( - __in Z3_context c, - unsigned weight, - unsigned num_bound, - __in_ecount(num_bound) Z3_app const* bound, - unsigned num_patterns, - __in_ecount(num_patterns) Z3_pattern const* patterns, - __in Z3_ast body - ); - - /** - \brief Similar to #Z3_mk_forall_const. - - \brief Create an existential quantifier using a list of constants that - will form the set of bound variables. - - \param c logical context. - \param weight quantifiers are associated with weights indicating the importance of using - the quantifier during instantiation. By default, pass the weight 0. - \param num_bound number of constants to be abstracted into bound variables. - \param bound array of constants to be abstracted into bound variables. - \param num_patterns number of patterns. - \param patterns array containing the patterns created using #Z3_mk_pattern. - \param body the body of the quantifier. - - \sa Z3_mk_pattern - \sa Z3_mk_forall_const - */ - - Z3_ast Z3_API Z3_mk_exists_const( - __in Z3_context c, - unsigned weight, - unsigned num_bound, - __in_ecount(num_bound) Z3_app const* bound, - unsigned num_patterns, - __in_ecount(num_patterns) Z3_pattern const* patterns, - __in Z3_ast body - ); - - /** - \brief Create a universal or existential - quantifier using a list of constants that - will form the set of bound variables. - */ - - Z3_ast Z3_API Z3_mk_quantifier_const( - __in Z3_context c, - Z3_bool is_forall, - unsigned weight, - unsigned num_bound, __in_ecount(num_bound) Z3_app const* bound, - unsigned num_patterns, __in_ecount(num_patterns) Z3_pattern const* patterns, - __in Z3_ast body - ); - - - - /** - \brief Create a universal or existential - quantifier using a list of constants that - will form the set of bound variables. - */ - - Z3_ast Z3_API Z3_mk_quantifier_const_ex( - __in Z3_context c, - Z3_bool is_forall, - unsigned weight, - __in Z3_symbol quantifier_id, - __in Z3_symbol skolem_id, - unsigned num_bound, __in_ecount(num_bound) Z3_app const* bound, - unsigned num_patterns, __in_ecount(num_patterns) Z3_pattern const* patterns, - unsigned num_no_patterns, __in_ecount(num_no_patterns) Z3_ast const* no_patterns, - __in Z3_ast body - ); - - - - - /*@}*/ - - - /** - @name Accessors - */ - /*@{*/ - - /** - \brief Return a unique identifier for \c t. - */ - unsigned Z3_API Z3_get_ast_id(__in Z3_context c, Z3_ast t); - - /** - \brief Return a unique identifier for \c f. - */ - unsigned Z3_API Z3_get_func_decl_id(__in Z3_context c, Z3_func_decl f); - - /** - \brief Return a unique identifier for \c s. - */ - unsigned Z3_API Z3_get_sort_id(__in Z3_context c, Z3_sort s); - - - - /** - \brief Return true if the given expression \c t is well sorted. - */ - Z3_bool Z3_API Z3_is_well_sorted(__in Z3_context c, __in Z3_ast t); - - /** - \brief Return \c Z3_INT_SYMBOL if the symbol was constructed - using #Z3_mk_int_symbol, and \c Z3_STRING_SYMBOL if the symbol - was constructed using #Z3_mk_string_symbol. - */ - Z3_symbol_kind Z3_API Z3_get_symbol_kind(__in Z3_context c, __in Z3_symbol s); - - /** - \brief \mlh get_symbol_int c s \endmlh - Return the symbol int value. - - \pre Z3_get_symbol_kind(s) == Z3_INT_SYMBOL - - \sa Z3_mk_int_symbol - */ - int Z3_API Z3_get_symbol_int(__in Z3_context c, __in Z3_symbol s); - - /** - \brief \mlh get_symbol_string c s \endmlh - Return the symbol name. - - \pre Z3_get_symbol_string(s) == Z3_STRING_SYMBOL - - \conly \warning The returned buffer is statically allocated by Z3. It will - \conly be automatically deallocated when #Z3_del_context is invoked. - \conly So, the buffer is invalidated in the next call to \c Z3_get_symbol_string. - - \sa Z3_mk_string_symbol - */ - Z3_string Z3_API Z3_get_symbol_string(__in Z3_context c, __in Z3_symbol s); - - - /** - \brief Return the kind of the given AST. - */ - Z3_ast_kind Z3_API Z3_get_ast_kind(__in Z3_context c, __in Z3_ast a); - - - /** - \brief Return numeral value, as a string of a numeric constant term - - \pre Z3_get_ast_kind(c, a) == Z3_NUMERAL_AST - */ - Z3_string Z3_API Z3_get_numeral_string(__in Z3_context c, __in Z3_ast a); - - - /** - \brief Return numeral value, as a pair of 64 bit numbers if the representation fits. - - \param c logical context. - \param a term. - \param num numerator. - \param den denominator. - - Preturn \c Z3_TRUE if the numeral value fits in 64 bit numerals, \c Z3_FALSE otherwise. - - \pre Z3_get_ast_kind(a) == Z3_NUMERAL_AST - */ - Z3_bool Z3_API Z3_get_numeral_small(__in Z3_context c, __in Z3_ast a, __out __int64* num, __out __int64* den); - - - /** - \brief \mlh get_numeral_int c v \endmlh - Similar to #Z3_get_numeral_string, but only succeeds if - the value can fit in a machine int. Return Z3_TRUE if the call succeeded. - - \pre Z3_get_ast_kind(c, v) == Z3_NUMERAL_AST - - \sa Z3_get_numeral_string - */ - Z3_bool Z3_API Z3_get_numeral_int(__in Z3_context c, __in Z3_ast v, __out int* i); - - /** - \brief \mlh get_numeral_uint c v \endmlh - Similar to #Z3_get_numeral_string, but only succeeds if - the value can fit in a machine unsigned int. Return Z3_TRUE if the call succeeded. - - \pre Z3_get_ast_kind(c, v) == Z3_NUMERAL_AST - - \sa Z3_get_numeral_string - */ - Z3_bool Z3_API Z3_get_numeral_uint(__in Z3_context c, __in Z3_ast v, __out unsigned* u); - -#ifndef CAMLIDL - /** - \brief \mlh get_numeral_uint64 c v \endmlh - Similar to #Z3_get_numeral_string, but only succeeds if - the value can fit in a machine unsigned __int64 int. Return Z3_TRUE if the call succeeded. - - \pre Z3_get_ast_kind(c, v) == Z3_NUMERAL_AST - - \sa Z3_get_numeral_string - */ - Z3_bool Z3_API Z3_get_numeral_uint64(__in Z3_context c, __in Z3_ast v, __out unsigned __int64* u); -#endif // CAMLIDL - -#ifndef CAMLIDL - /** - \brief \mlh get_numeral_int64 c v \endmlh - Similar to #Z3_get_numeral_string, but only succeeds if - the value can fit in a machine __int64 int. Return Z3_TRUE if the call succeeded. - - \pre Z3_get_ast_kind(c, v) == Z3_NUMERAL_AST - - \sa Z3_get_numeral_string - */ - Z3_bool Z3_API Z3_get_numeral_int64(__in Z3_context c, __in Z3_ast v, __out __int64* i); -#endif // CAMLIDL - -#ifndef CAMLIDL - /** - \brief \mlh get_numeral_rational_int64 c x y\endmlh - Similar to #Z3_get_numeral_string, but only succeeds if - the value can fit as a reational number as machine __int64 int. Return Z3_TRUE if the call succeeded. - - \pre Z3_get_ast_kind(c, v) == Z3_NUMERAL_AST - - \sa Z3_get_numeral_string - */ - Z3_bool Z3_API Z3_get_numeral_rational_int64(__in Z3_context c, __in Z3_ast v, __out __int64* num, __out __int64* den); -#endif // CAMLIDL - - /** - \brief Return Z3_L_TRUE if \c a is true, Z3_L_FALSE if it is false, and Z3_L_UNDEF otherwise. - */ - Z3_lbool Z3_API Z3_get_bool_value(__in Z3_context c, __in Z3_ast a); - - /** - \brief Return the declaration of a constant or function application. - */ - Z3_func_decl Z3_API Z3_get_app_decl(__in Z3_context c, __in Z3_app a); - - /** - \brief \mlh get_app_num_args c a \endmlh - Return the number of argument of an application. If \c t - is an constant, then the number of arguments is 0. - */ - unsigned Z3_API Z3_get_app_num_args(__in Z3_context c, __in Z3_app a); - - /** - \brief \mlh get_app_arg c a i \endmlh - Return the i-th argument of the given application. - - \pre i < Z3_get_num_args(c, a) - */ - Z3_ast Z3_API Z3_get_app_arg(__in Z3_context c, __in Z3_app a, __in unsigned i); - - /** - \brief Return index of de-Brujin bound variable. - - \pre Z3_get_ast_kind(a) == Z3_VAR_AST - */ - unsigned Z3_API Z3_get_index_value(__in Z3_context c, __in Z3_ast a); - - /** - \brief Determine if quantifier is universal. - - \pre Z3_get_ast_kind(a) == Z3_QUANTIFIER_AST - */ - Z3_bool Z3_API Z3_is_quantifier_forall(__in Z3_context c, __in Z3_ast a); - - /** - \brief Obtain weight of quantifier. - - \pre Z3_get_ast_kind(a) == Z3_QUANTIFIER_AST - */ - unsigned Z3_API Z3_get_quantifier_weight(__in Z3_context c, __in Z3_ast a); - - /** - \brief Return number of patterns used in quantifier. - - \pre Z3_get_ast_kind(a) == Z3_QUANTIFIER_AST - */ - unsigned Z3_API Z3_get_quantifier_num_patterns(__in Z3_context c, __in Z3_ast a); - - /** - \brief Return i'th pattern. - - \pre Z3_get_ast_kind(a) == Z3_QUANTIFIER_AST - */ - Z3_pattern Z3_API Z3_get_quantifier_pattern_ast(__in Z3_context c, __in Z3_ast a, unsigned i); - - /** - \brief Return number of no_patterns used in quantifier. - - \pre Z3_get_ast_kind(a) == Z3_QUANTIFIER_AST - */ - unsigned Z3_API Z3_get_quantifier_num_no_patterns(__in Z3_context c, __in Z3_ast a); - - /** - \brief Return i'th no_pattern. - - \pre Z3_get_ast_kind(a) == Z3_QUANTIFIER_AST - */ - Z3_ast Z3_API Z3_get_quantifier_no_pattern_ast(__in Z3_context c, __in Z3_ast a, unsigned i); - - /** - \brief Return symbol of the i'th bound variable. - - \pre Z3_get_ast_kind(a) == Z3_QUANTIFIER_AST - */ - Z3_symbol Z3_API Z3_get_quantifier_bound_name(__in Z3_context c, __in Z3_ast a, unsigned i); - - /** - \brief Return sort of the i'th bound variable. - - \pre Z3_get_ast_kind(a) == Z3_QUANTIFIER_AST - */ - Z3_sort Z3_API Z3_get_quantifier_bound_sort(__in Z3_context c, __in Z3_ast a, unsigned i); - - /** - \brief Return body of quantifier. - - \pre Z3_get_ast_kind(a) == Z3_QUANTIFIER_AST - */ - Z3_ast Z3_API Z3_get_quantifier_body(__in Z3_context c, __in Z3_ast a); - - - - /** - \brief Return number of bound variables of quantifier. - - \pre Z3_get_ast_kind(a) == Z3_QUANTIFIER_AST - */ - unsigned Z3_API Z3_get_quantifier_num_bound(__in Z3_context c, __in Z3_ast a); - - /** - \brief Return the constant declaration name as a symbol. - */ - Z3_symbol Z3_API Z3_get_decl_name(__in Z3_context c, __in Z3_func_decl d); - - /** - \brief Return the number of parameters associated with a declaration. - */ - unsigned Z3_API Z3_get_decl_num_parameters(__in Z3_context c, __in Z3_func_decl d); - - /** - \brief Return the parameter type associated with a declaration. - - \param c the context - \param d the function declaration - \param idx is the index of the named parameter it should be between 0 and the number of parameters. - */ - Z3_parameter_kind Z3_API Z3_get_decl_parameter_kind(__in Z3_context c, __in Z3_func_decl d, unsigned idx); - - /** - \brief Return the integer value associated with an integer parameter. - - \pre Z3_get_decl_parameter_kind(c, d, idx) == Z3_PARAMETER_INT - */ - int Z3_API Z3_get_decl_int_parameter(__in Z3_context c, __in Z3_func_decl d, unsigned idx); - - /** - \brief Return the double value associated with an double parameter. - - \pre Z3_get_decl_parameter_kind(c, d, idx) == Z3_PARAMETER_DOUBLE - */ - double Z3_API Z3_get_decl_double_parameter(__in Z3_context c, __in Z3_func_decl d, unsigned idx); - - /** - \brief Return the double value associated with an double parameter. - - \pre Z3_get_decl_parameter_kind(c, d, idx) == Z3_PARAMETER_SYMBOL - */ - Z3_symbol Z3_API Z3_get_decl_symbol_parameter(__in Z3_context c, __in Z3_func_decl d, unsigned idx); - /** - \brief Return the sort value associated with a sort parameter. - - \pre Z3_get_decl_parameter_kind(c, d, idx) == Z3_PARAMETER_SORT - */ - Z3_sort Z3_API Z3_get_decl_sort_parameter(__in Z3_context c, __in Z3_func_decl d, unsigned idx); - - /** - \brief Return the expresson value associated with an expression parameter. - - \pre Z3_get_decl_parameter_kind(c, d, idx) == Z3_PARAMETER_AST - */ - Z3_ast Z3_API Z3_get_decl_ast_parameter(__in Z3_context c, __in Z3_func_decl d, unsigned idx); - - /** - \brief Return the expresson value associated with an expression parameter. - - \pre Z3_get_decl_parameter_kind(c, d, idx) == Z3_PARAMETER_FUNC_DECL - */ - Z3_func_decl Z3_API Z3_get_decl_func_decl_parameter(__in Z3_context c, __in Z3_func_decl d, unsigned idx); - - /** - \brief Return the rational value, as a string, associated with a rational parameter. - - \pre Z3_get_decl_parameter_kind(c, d, idx) == Z3_PARAMETER_RATIONAL - */ - Z3_string Z3_API Z3_get_decl_rational_parameter(__in Z3_context c, __in Z3_func_decl d, unsigned idx); - - /** - \brief Return the sort name as a symbol. - */ - Z3_symbol Z3_API Z3_get_sort_name(__in Z3_context c, __in Z3_sort d); - - /** - \brief Return the sort of an AST node. - - The AST node must be a constant, application, numeral, bound variable, or quantifier. - - */ - Z3_sort Z3_API Z3_get_sort(__in Z3_context c, __in Z3_ast a); - - /** - \brief Return the number of parameters of the given declaration. - - \sa Z3_get_domain_size - */ - unsigned Z3_API Z3_get_domain_size(__in Z3_context c, __in Z3_func_decl d); - - /** - \brief \mlh get_domain c d i \endmlh - Return the sort of the i-th parameter of the given function declaration. - - \pre i < Z3_get_domain_size(d) - - \sa Z3_get_domain_size - */ - Z3_sort Z3_API Z3_get_domain(__in Z3_context c, __in Z3_func_decl d, __in unsigned i); - - /** - \brief \mlh get_range c d \endmlh - Return the range of the given declaration. - - If \c d is a constant (i.e., has zero arguments), then this - function returns the sort of the constant. - */ - Z3_sort Z3_API Z3_get_range(__in Z3_context c, __in Z3_func_decl d); - - /** - \brief Return the sort kind (e.g., array, tuple, int, bool, etc). - - \sa Z3_sort_kind - */ - Z3_sort_kind Z3_API Z3_get_sort_kind(__in Z3_context c, __in Z3_sort t); - - /** - \brief \mlh get_bv_sort_size c t \endmlh - Return the size of the given bit-vector sort. - - \pre Z3_get_sort_kind(c, t) == Z3_BV_SORT - - \sa Z3_mk_bv_sort - \sa Z3_get_sort_kind - */ - unsigned Z3_API Z3_get_bv_sort_size(__in Z3_context c, __in Z3_sort t); - - /** - \brief \mlh get_array_sort_domain c t \endmlh - Return the domain of the given array sort. - - \pre Z3_get_sort_kind(c, t) == Z3_ARRAY_SORT - - \sa Z3_mk_array_sort - \sa Z3_get_sort_kind - */ - Z3_sort Z3_API Z3_get_array_sort_domain(__in Z3_context c, __in Z3_sort t); - - /** - \brief \mlh get_array_sort_range c t \endmlh - Return the range of the given array sort. - - \pre Z3_get_sort_kind(c, t) == Z3_ARRAY_SORT - - \sa Z3_mk_array_sort - \sa Z3_get_sort_kind - */ - Z3_sort Z3_API Z3_get_array_sort_range(__in Z3_context c, __in Z3_sort t); - - /** - \brief \mlh get_tuple_sort_mk_decl c t \endmlh - Return the constructor declaration of the given tuple - sort. - - \pre Z3_get_sort_kind(c, t) == Z3_DATATYPE_SORT - - \sa Z3_mk_tuple_sort - \sa Z3_get_sort_kind - */ - Z3_func_decl Z3_API Z3_get_tuple_sort_mk_decl(__in Z3_context c, __in Z3_sort t); - - /** - \brief Return declaration kind corresponding to declaration. - */ - Z3_decl_kind Z3_API Z3_get_decl_kind(__in Z3_context c, __in Z3_func_decl d); - - /** - \brief \mlh get_tuple_sort_num_fields c t \endmlh - Return the number of fields of the given tuple sort. - - \pre Z3_get_sort_kind(c, t) == Z3_DATATYPE_SORT - - \mlonly \remark Consider using the function {!Z3.get_tuple_sort}, which - returns a tuple: tuple constructor, and an array of the tuple sort fields. \endmlonly - - \sa Z3_mk_tuple_sort - \sa Z3_get_sort_kind - */ - unsigned Z3_API Z3_get_tuple_sort_num_fields(__in Z3_context c, __in Z3_sort t); - - /** - \brief \mlh get_tuple_sort_field_decl c t i \endmlh - Return the i-th field declaration (i.e., projection function declaration) - of the given tuple sort. - - \mlonly \remark Consider using the function {!Z3.get_tuple_sort}, which - returns a tuple: tuple constructor, and an array of the tuple sort fields. \endmlonly - - \pre Z3_get_sort_kind(t) == Z3_DATATYPE_SORT - \pre i < Z3_get_tuple_sort_num_fields(c, t) - - \sa Z3_mk_tuple_sort - \sa Z3_get_sort_kind - */ - Z3_func_decl Z3_API Z3_get_tuple_sort_field_decl(__in Z3_context c, __in Z3_sort t, __in unsigned i); - - /** - \brief Return number of constructors for datatype. - - \pre Z3_get_sort_kind(t) == Z3_DATATYPE_SORT - - \sa Z3_get_datatype_sort_constructor - \sa Z3_get_datatype_sort_recognizer - \sa Z3_get_datatype_sort_constructor_accessor - - */ - unsigned Z3_API Z3_get_datatype_sort_num_constructors( - __in Z3_context c, __in Z3_sort t); - - /** - \brief Return idx'th constructor. - - \pre Z3_get_sort_kind(t) == Z3_DATATYPE_SORT - \pre idx < Z3_get_datatype_sort_num_constructors(c, t) - - \sa Z3_get_datatype_sort_num_constructors - \sa Z3_get_datatype_sort_recognizer - \sa Z3_get_datatype_sort_constructor_accessor - - */ - Z3_func_decl Z3_API Z3_get_datatype_sort_constructor( - __in Z3_context c, __in Z3_sort t, unsigned idx); - - /** - \brief Return idx'th recognizer. - - \pre Z3_get_sort_kind(t) == Z3_DATATYPE_SORT - \pre idx < Z3_get_datatype_sort_num_constructors(c, t) - - \sa Z3_get_datatype_sort_num_constructors - \sa Z3_get_datatype_sort_constructor - \sa Z3_get_datatype_sort_constructor_accessor - - */ - Z3_func_decl Z3_API Z3_get_datatype_sort_recognizer( - __in Z3_context c, __in Z3_sort t, unsigned idx); - - /** - \brief Return idx_a'th accessor for the idx_c'th constructor. - - \pre Z3_get_sort_kind(t) == Z3_DATATYPE_SORT - \pre idx_c < Z3_get_datatype_sort_num_constructors(c, t) - \pre idx_a < Z3_get_domain_size(c, Z3_get_datatype_sort_constructor(c, idx_c)) - - \sa Z3_get_datatype_sort_num_constructors - \sa Z3_get_datatype_sort_constructor - \sa Z3_get_datatype_sort_recognizer - */ - Z3_func_decl Z3_API Z3_get_datatype_sort_constructor_accessor( - __in Z3_context c, __in Z3_sort t, unsigned idx_c, unsigned idx_a); - - - /** - \brief Return arity of relation. - - \pre Z3_get_sort_kind(s) == Z3_RELATION_SORT - - \sa Z3_get_relation_column - */ - - unsigned Z3_API Z3_get_relation_arity(__in Z3_context c, __in Z3_sort s); - - /** - \brief Return sort at i'th column of relation sort. - - \pre Z3_get_sort_kind(c, s) == Z3_RELATION_SORT - \pre col < Z3_get_relation_arity(c, s) - - \sa Z3_get_relation_arity - */ - Z3_sort Z3_API Z3_get_relation_column(__in Z3_context c, __in Z3_sort s, unsigned col); - - -#ifndef CAMLIDL - /** - \brief Store the size of the sort in \c r. Return Z3_TRUE if the call succeeded. - That is, Z3_get_sort_kind(s) == Z3_FINITE_DOMAIN_SORT - */ - Z3_bool Z3_API Z3_get_finite_domain_sort_size(__in Z3_context c, __in Z3_sort s, __out unsigned __int64* r); -#endif - - /** - \brief Return number of terms in pattern. - */ - unsigned Z3_API Z3_get_pattern_num_terms(__in Z3_context c, __in Z3_pattern p); - - /** - \brief Return i'th ast in pattern. - */ - Z3_ast Z3_API Z3_get_pattern(__in Z3_context c, __in Z3_pattern p, __in unsigned idx); - - - - /** - \brief Interface to simplifier. - - Provides an interface to the AST simplifier used by Z3. - It allows clients to piggyback on top of the AST simplifier - for their own term manipulation. - */ - Z3_ast Z3_API Z3_simplify(__in Z3_context c, __in Z3_ast a); - - /*@}*/ - - /** - @name Modifiers - */ - /*@{*/ - - /** - \brief Update the arguments of term \c a using the arguments \c args. - The number of arguments \c num_args should coincide - with the number of arguments to \c a. - If \c a is a quantifier, then num_args has to be 1. - */ - Z3_ast Z3_API Z3_update_term(__in Z3_context c, __in Z3_ast a, __in unsigned num_args, __in_ecount(num_args) Z3_ast args[]); - - /** - \brief Substitute every occurrence of from[i] in \c a with to[i], for \c i smaller than \c num_exprs. - The result is the new AST. The arrays \c from and \c to must have size \c num_exprs. - For every \c i smaller than \c num_exprs, we must have that sort of from[i] must be equal to sort of to[i]. - */ - Z3_ast Z3_API Z3_substitute(__in Z3_context c, - __in Z3_ast a, - __in unsigned num_exprs, - __in_ecount(num_exprs) Z3_ast from[], - __in_ecount(num_exprs) Z3_ast to[]); - - /** - \brief Substitute the free variables in \c a with the expressions in \c to. - For every \c i smaller than \c num_exprs, the variable with de-Bruijn index \c i is replaced with term to[i]. - */ - Z3_ast Z3_API Z3_substitute_vars(__in Z3_context c, - __in Z3_ast a, - __in unsigned num_exprs, - __in_ecount(num_exprs) Z3_ast to[]); - - /*@}*/ - - - - /** - @name Coercions - */ - /*@{*/ - - /** - \brief Convert a Z3_sort into Z3_ast. This is just type casting. - */ - Z3_ast Z3_API Z3_sort_to_ast(__in Z3_context c, __in Z3_sort s); - - /** - \brief Convert a Z3_func_decl into Z3_ast. This is just type casting. - */ - Z3_ast Z3_API Z3_func_decl_to_ast(__in Z3_context c, __in Z3_func_decl f); - - /** - \brief Convert a Z3_pattern into Z3_ast. This is just type casting. - */ - Z3_ast Z3_API Z3_pattern_to_ast(__in Z3_context c, __in Z3_pattern p); - - /** - \brief Convert a APP_AST into an AST. This is just type casting. - */ - Z3_ast Z3_API Z3_app_to_ast(__in Z3_context c, __in Z3_app a); - - /** - \brief Convert an AST into a APP_AST. This is just type casting. - - \warning This conversion is only safe if #Z3_get_ast_kind returns \c Z3_app. - */ - Z3_app Z3_API Z3_to_app(__in Z3_context c, __in Z3_ast a); - - /*@}*/ - - /** - @name Constraints - */ - /*@{*/ - - /** - \brief Create a backtracking point. - - The logical context can be viewed as a stack of contexts. The - scope level is the number of elements on this stack. The stack - of contexts is simulated using trail (undo) stacks. - - \sa Z3_pop - */ - void Z3_API Z3_push(__in Z3_context c); - - /** - \brief Backtrack. - - Restores the context from the top of the stack, and pops it off the - stack. Any changes to the logical context (by #Z3_assert_cnstr or - other functions) between the matching #Z3_push and \c Z3_pop - operators are flushed, and the context is completely restored to - what it was right before the #Z3_push. - - \sa Z3_push - */ - void Z3_API Z3_pop(__in Z3_context c, __in unsigned num_scopes); - - - /** - \brief Retrieve the current scope level. - - It retrieves the number of scopes that have been pushed, but not yet popped. - - \sa Z3_push - \sa Z3_pop - */ - unsigned Z3_API Z3_get_num_scopes(__in Z3_context c); - - /** - \brief Persist AST through num_scopes pops. - This function is only relevant if \c c was created using #Z3_mk_context. - If \c c was created using #Z3_mk_context_rc, this function is a NOOP. - - Normally, for contexts created using #Z3_mk_context, - references to terms are no longer valid when - popping scopes beyond the level where the terms are created. - If you want to reference a term below the scope where it - was created, use this method to specify how many pops - the term should survive. - The num_scopes should be at most equal to the number of - calls to Z3_push subtracted with the calls to Z3_pop. - */ - void Z3_API Z3_persist_ast(__in Z3_context c, __in Z3_ast a, __in unsigned num_scopes); - - - /** - \brief Assert a constraing into the logical context. - - After one assertion, the logical context may become - inconsistent. - - The functions #Z3_check or #Z3_check_and_get_model should be - used to check whether the logical context is consistent or not. - - \sa Z3_check - \sa Z3_check_and_get_model - */ - void Z3_API Z3_assert_cnstr(__in Z3_context c, __in Z3_ast a); - - /** - \brief Check whether the given logical context is consistent or not. - - If the logical context is not unsatisfiable (i.e., the return value is different from \c Z3_L_FALSE) - and model construction is enabled (see #Z3_mk_config), then a model is stored in \c m. Otherwise, - the value \c 0 is stored in \c m. - The caller is responsible for deleting the model using the function #Z3_del_model. - - \remark Model construction must be enabled using configuration - parameters (See, #Z3_mk_config). - - \sa Z3_check - \sa Z3_del_model - */ - Z3_lbool Z3_API Z3_check_and_get_model(__in Z3_context c, __out Z3_model * m); - - /** - \brief Check whether the given logical context is consistent or not. - - The function #Z3_check_and_get_model should be used when models are needed. - - \sa Z3_check_and_get_model - */ - Z3_lbool Z3_API Z3_check(__in Z3_context c); - - /** - \brief Check whether the given logical context and optional assumptions is consistent or not. - - If the logical context is not unsatisfiable (i.e., the return value is different from \c Z3_L_FALSE), - a non-0 model argument is passed in, - and model construction is enabled (see #Z3_mk_config), then a model is stored in \c m. - Otherwise, \c m is left unchanged. - The caller is responsible for deleting the model using the function #Z3_del_model. - - \remark If the model argument is non-0, then model construction must be enabled using configuration - parameters (See, #Z3_mk_config). - - \param c logical context. - \param num_assumptions number of auxiliary assumptions. - \param assumptions array of auxiliary assumptions - \param m optional pointer to a model. - \param proof optional pointer to a proof term. - \param core_size size of unsatisfiable core. - \param core pointer to an array receiveing unsatisfiable core. - The unsatisfiable core is a subset of the assumptions, so the array has the same size as the assumptions. - The \c core array is not populated if \c core_size is set to 0. - - \pre assumptions comprises of propositional literals. - In other words, you cannot use compound formulas for assumptions, - but should use propositional variables or negations of propositional variables. - - \sa Z3_check - \sa Z3_del_model - */ - Z3_lbool Z3_API Z3_check_assumptions( - __in Z3_context c, - __in unsigned num_assumptions, __in_ecount(num_assumptions) Z3_ast assumptions[], - __out Z3_model * m, __out Z3_ast* proof, - __inout unsigned* core_size, __inout_ecount(num_assumptions) Z3_ast core[] - ); - - /** - \brief Retrieve congruence class representatives for terms. - - The function can be used for relying on Z3 to identify equal terms under the current - set of assumptions. The array of terms and array of class identifiers should have - the same length. The class identifiers are numerals that are assigned to the same - value for their corresponding terms if the current context forces the terms to be - equal. You cannot deduce that terms corresponding to different numerals must be all different, - (especially when using non-convex theories). - All implied equalities are returned by this call. - This means that two terms map to the same class identifier if and only if - the current context implies that they are equal. - - A side-effect of the function is a satisfiability check. - The function return Z3_L_FALSE if the current assertions are not satisfiable. - - \sa Z3_check_and_get_model - \sa Z3_check - */ - - Z3_lbool Z3_API Z3_get_implied_equalities( - __in Z3_context c, - __in unsigned num_terms, - __in_ecount(num_terms) Z3_ast terms[], - __out_ecount(num_terms) unsigned class_ids[] - ); - - - /** - \brief Delete a model object. - - \sa Z3_check_and_get_model - */ - void Z3_API Z3_del_model(__in Z3_context c, __in Z3_model m); - - /** - @name Search control. - */ - /*@{*/ - /** - \brief Cancel an ongoing check. - - Notifies the current check to abort and return. - This method should be called from a different thread - than the one performing the check. - */ - - void Z3_API Z3_soft_check_cancel(__in Z3_context c); - /*@}*/ - - /*@{*/ - - /** - \brief Retrieve reason for search failure. - - If a call to #Z3_check or #Z3_check_and_get_model returns Z3_L_UNDEF, - use this facility to determine the more detailed cause of search failure. - */ - Z3_search_failure Z3_API Z3_get_search_failure(__in Z3_context c); - - /*@}*/ - - - /** - @name Labels. - */ - /*@{*/ - /** - \brief Retrieve the set of labels that were relevant in - the context of the current satisfied context. - - \sa Z3_del_literals - \sa Z3_get_num_literals - \sa Z3_get_label_symbol - \sa Z3_get_literal - */ - Z3_literals Z3_API Z3_get_relevant_labels(__in Z3_context c); - - /** - \brief Retrieve the set of literals that satisfy the current context. - - \sa Z3_del_literals - \sa Z3_get_num_literals - \sa Z3_get_label_symbol - \sa Z3_get_literal - */ - Z3_literals Z3_API Z3_get_relevant_literals(__in Z3_context c); - - /** - \brief Retrieve the set of literals that whose assignment were - guess, but not propagated during the search. - - \sa Z3_del_literals - \sa Z3_get_num_literals - \sa Z3_get_label_symbol - \sa Z3_get_literal - */ - Z3_literals Z3_API Z3_get_guessed_literals(__in Z3_context c); - - - /** - \brief Delete a labels context. - - \sa Z3_get_relevant_labels - */ - void Z3_API Z3_del_literals(__in Z3_context c, __in Z3_literals lbls); - - /** - \brief Retrieve the number of label symbols that were returned. - - \sa Z3_get_relevant_labels - */ - unsigned Z3_API Z3_get_num_literals(__in Z3_context c, __in Z3_literals lbls); - - /** - \brief Retrieve label symbol at idx. - */ - Z3_symbol Z3_API Z3_get_label_symbol(__in Z3_context c, __in Z3_literals lbls, __in unsigned idx); - - /** - \brief Retrieve literal expression at idx. - */ - Z3_ast Z3_API Z3_get_literal(__in Z3_context c, __in Z3_literals lbls, __in unsigned idx); - - /** - \brief Disable label. - - The disabled label is not going to be used when blocking the subsequent search. - - \sa Z3_block_literals - */ - void Z3_API Z3_disable_literal(__in Z3_context c, __in Z3_literals lbls, __in unsigned idx); - - /** - \brief Block subsequent checks using the remaining enabled labels. - */ - void Z3_API Z3_block_literals(__in Z3_context c, __in Z3_literals lbls); - - /*@}*/ - - - - /** - @name Model navigation - */ - /*@{*/ - - /** - \brief Return the number of constants assigned by the given model. - - \mlonly \remark Consider using {!Z3.get_model_constants}. \endmlonly - - \sa Z3_get_model_constant - */ - unsigned Z3_API Z3_get_model_num_constants(__in Z3_context c, __in Z3_model m); - - /** - \brief \mlh get_model_constant c m i \endmlh - Return the i-th constant in the given model. - - \mlonly \remark Consider using {!Z3.get_model_constants}. \endmlonly - - \pre i < Z3_get_model_num_constants(c, m) - - \sa Z3_eval - */ - Z3_func_decl Z3_API Z3_get_model_constant(__in Z3_context c, __in Z3_model m, __in unsigned i); - - /** - \brief Return the value of the given constant or function - in the given model. - - */ - Z3_bool Z3_API Z3_eval_func_decl(__in Z3_context c, __in Z3_model m, __in Z3_func_decl decl, __out Z3_ast* v); - - - /** - \brief \mlh is_array_value c v \endmlh - Determine whether the term encodes an array value. - Return the number of entries mapping to non-default values of the array. - */ - Z3_bool Z3_API Z3_is_array_value(__in Z3_context c, __in Z3_model m, __in Z3_ast v, __out unsigned* num_entries); - - - /** - \brief \mlh get_array_value c v \endmlh - An array values is represented as a dictionary plus a - default (else) value. This function returns the array graph. - - \pre Z3_TRUE == Z3_is_array_value(c, v, &num_entries) - */ - void Z3_API Z3_get_array_value(__in Z3_context c, - __in Z3_model m, - __in Z3_ast v, - __in unsigned num_entries, - __inout_ecount(num_entries) Z3_ast indices[], - __inout_ecount(num_entries) Z3_ast values[], - __out Z3_ast* else_value - ); - - - /** - \brief Return the number of function interpretations in the given model. - - A function interpretation is represented as a finite map and an 'else' value. - Each entry in the finite map represents the value of a function given a set of arguments. - - \mlonly \remark Consider using {!Z3.get_model_funcs}. \endmlonly - - \sa Z3_get_model_func_decl - \sa Z3_get_model_func_else - \sa Z3_get_model_func_num_entries - \sa Z3_get_model_func_entry_num_args - \sa Z3_get_model_func_entry_arg - */ - unsigned Z3_API Z3_get_model_num_funcs(__in Z3_context c, __in Z3_model m); - - - /** - \brief \mlh get_model_func_decl c m i \endmlh - Return the declaration of the i-th function in the given model. - - \mlonly \remark Consider using {!Z3.get_model_funcs}. \endmlonly - - \pre i < Z3_get_model_num_funcs(c, m) - - \sa Z3_get_model_num_funcs - */ - Z3_func_decl Z3_API Z3_get_model_func_decl(__in Z3_context c, __in Z3_model m, __in unsigned i); - - /** - \brief \mlh get_model_func_else c m i \endmlh - Return the 'else' value of the i-th function interpretation in the given model. - - A function interpretation is represented as a finite map and an 'else' value. - - \mlonly \remark Consider using {!Z3.get_model_funcs}. \endmlonly - - \pre i < Z3_get_model_num_funcs(c, m) - - \sa Z3_get_model_num_funcs - \sa Z3_get_model_func_num_entries - \sa Z3_get_model_func_entry_num_args - \sa Z3_get_model_func_entry_arg - */ - Z3_ast Z3_API Z3_get_model_func_else(__in Z3_context c, __in Z3_model m, __in unsigned i); - - /** - \brief \mlh get_model_func_num_entries c m i \endmlh - Return the number of entries of the i-th function interpretation in the given model. - - A function interpretation is represented as a finite map and an 'else' value. - - \mlonly \remark Consider using {!Z3.get_model_funcs}. \endmlonly - - \pre i < Z3_get_model_num_funcs(c, m) - - \sa Z3_get_model_num_funcs - \sa Z3_get_model_func_else - \sa Z3_get_model_func_entry_num_args - \sa Z3_get_model_func_entry_arg - */ - unsigned Z3_API Z3_get_model_func_num_entries(__in Z3_context c, __in Z3_model m, __in unsigned i); - - - /** - \brief \mlh get_model_func_entry_num_args c m i j \endmlh - Return the number of arguments of the j-th entry of the i-th function interpretation in the given - model. - - A function interpretation is represented as a finite map and an 'else' value. - This function returns the j-th entry of this map. - - An entry represents the value of a function given a set of arguments. - \conly That is: it has the following format f(args[0],...,args[num_args - 1]) = val. - - \mlonly \remark Consider using {!Z3.get_model_funcs}. \endmlonly - - \pre i < Z3_get_model_num_funcs(c, m) - \pre j < Z3_get_model_func_num_entries(c, m, i) - - \sa Z3_get_model_num_funcs - \sa Z3_get_model_func_num_entries - \sa Z3_get_model_func_entry_arg - */ - unsigned Z3_API Z3_get_model_func_entry_num_args(__in Z3_context c, - __in Z3_model m, - __in unsigned i, - __in unsigned j); - - /** - \brief \mlh get_model_func_entry_arg c m i j k \endmlh - Return the k-th argument of the j-th entry of the i-th function interpretation in the given - model. - - A function interpretation is represented as a finite map and an 'else' value. - This function returns the j-th entry of this map. - - An entry represents the value of a function given a set of arguments. - \conly That is: it has the following format f(args[0],...,args[num_args - 1]) = val. - - \mlonly \remark Consider using {!Z3.get_model_funcs}. \endmlonly - - \pre i < Z3_get_model_num_funcs(c, m) - \pre j < Z3_get_model_func_num_entries(c, m, i) - \pre k < Z3_get_model_func_entry_num_args(c, m, i, j) - - \sa Z3_get_model_num_funcs - \sa Z3_get_model_func_num_entries - \sa Z3_get_model_func_entry_num_args - */ - Z3_ast Z3_API Z3_get_model_func_entry_arg(__in Z3_context c, - __in Z3_model m, - __in unsigned i, - __in unsigned j, - __in unsigned k); - - /** - \brief \mlh get_model_func_entry_value c m i j \endmlh - Return the return value of the j-th entry of the i-th function interpretation in the given - model. - - A function interpretation is represented as a finite map and an 'else' value. - This function returns the j-th entry of this map. - - An entry represents the value of a function given a set of arguments. - \conly That is: it has the following format f(args[0],...,args[num_args - 1]) = val. - - \mlonly \remark Consider using {!Z3.get_model_funcs}. \endmlonly - - \pre i < Z3_get_model_num_funcs(c, m) - \pre j < Z3_get_model_func_num_entries(c, m, i) - - \sa Z3_get_model_num_funcs - \sa Z3_get_model_func_num_entries - */ - Z3_ast Z3_API Z3_get_model_func_entry_value(__in Z3_context c, - __in Z3_model m, - __in unsigned i, - __in unsigned j); - - /** - \brief \mlh eval c m t \endmlh - Evaluate the AST node \c t in the given model. - \conly Return \c Z3_TRUE if succeeded, and store the result in \c v. - \mlonly Return a pair: Boolean and value. The Boolean is true if the term was successfully evaluated. \endmlonly - - The evaluation may fail for the following reasons: - - - \c t contains a quantifier. - - - the model \c m is partial, that is, it doesn't have a complete interpretation for uninterpreted functions. - That is, the option MODEL_PARTIAL=true was used. - - - \c t is type incorrect. - */ - Z3_bool Z3_API Z3_eval(__in Z3_context c, __in Z3_model m, __in Z3_ast t, __out Z3_ast * v); - - /** - \brief Evaluate declaration given values. - - Provides direct way to evaluate declarations - without going over terms. - */ - Z3_bool Z3_API Z3_eval_decl(__in Z3_context c, __in Z3_model m, - __in Z3_func_decl d, - __in unsigned num_args, - __in_ecount(num_args) Z3_ast args[], - __out Z3_ast* v); - - - - - /*@}*/ - - /** - @name Interaction logging. - */ - /*@{*/ - - /** - \brief Log interaction to a file. - */ - Z3_bool Z3_API Z3_open_log(__in Z3_context c, __in_z Z3_string filename); - - /** - \brief Append user-defined string to interaction log. - - The interaction log is opened using Z3_open_log. - It contains the formulas that are checked using Z3. - You can use this command to append comments, for instance. - */ - void Z3_API Z3_append_log(__in Z3_context c, __in_z Z3_string string); - - - /** - \brief Close interaction log. - */ - void Z3_API Z3_close_log(__in Z3_context c); - /*@}*/ - - - /** - @name String conversion - */ - /*@{*/ - - /** - \brief Select mode for the format used for pretty-printing AST nodes. - - The default mode for pretty printing AST nodes is to produce - SMT-LIB style output where common subexpressions are printed - at each occurrence. The mode is called Z3_PRINT_SMTLIB_FULL. - To print shared common subexpressions only once, - use the Z3_PRINT_LOW_LEVEL mode. - To print in way that conforms to SMT-LIB standards and uses let - expressions to share common sub-expressions use Z3_PRINT_SMTLIB_COMPLIANT. - - \sa Z3_ast_to_string - \sa Z3_pattern_to_string - \sa Z3_func_decl_to_string - - */ - void Z3_API Z3_set_ast_print_mode(__in Z3_context c, __in Z3_ast_print_mode mode); - - /** - \brief Convert the given AST node into a string. - - \conly \warning The result buffer is statically allocated by Z3. It will - \conly be automatically deallocated when #Z3_del_context is invoked. - \conly So, the buffer is invalidated in the next call to \c Z3_ast_to_string. - \sa Z3_pattern_to_string - \sa Z3_sort_to_string - */ - Z3_string Z3_API Z3_ast_to_string(__in Z3_context c, __in Z3_ast a); - Z3_string Z3_API Z3_pattern_to_string(__in Z3_context c, __in Z3_pattern p); - Z3_string Z3_API Z3_sort_to_string(__in Z3_context c, __in Z3_sort s); - Z3_string Z3_API Z3_func_decl_to_string(__in Z3_context c, __in Z3_func_decl d); - - /** - \brief Convert the given model into a string. - - \conly \warning The result buffer is statically allocated by Z3. It will - \conly be automatically deallocated when #Z3_del_context is invoked. - \conly So, the buffer is invalidated in the next call to \c Z3_model_to_string. - */ - Z3_string Z3_API Z3_model_to_string(__in Z3_context c, __in Z3_model m); - - /** - \brief Convert the given benchmark into SMT-LIB formatted string. - - \conly \warning The result buffer is statically allocated by Z3. It will - \conly be automatically deallocated when #Z3_del_context is invoked. - \conly So, the buffer is invalidated in the next call to \c Z3_benchmark_to_smtlib_string. - - \param c - context. - \param name - name of benchmark. The argument is optional. - \param logic - the benchmark logic. - \param status - the status string (sat, unsat, or unknown) - \param attributes - other attributes, such as source, difficulty or category. - \param num_assumptions - number of assumptions. - \param assumptions - auxiliary assumptions. - \param formula - formula to be checked for consistency in conjunction with assumptions. - */ - Z3_string Z3_API Z3_benchmark_to_smtlib_string(__in Z3_context c, - __in_z Z3_string name, - __in_z Z3_string logic, - __in_z Z3_string status, - __in_z Z3_string attributes, - __in unsigned num_assumptions, - __in_ecount(num_assumptions) Z3_ast assumptions[], - __in Z3_ast formula); - - - /** - \brief Convert the given logical context into a string. - - This function is mainly used for debugging purposes. It displays - the internal structure of a logical context. - - \conly \warning The result buffer is statically allocated by Z3. It will - \conly be automatically deallocated when #Z3_del_context is invoked. - \conly So, the buffer is invalidated in the next call to \c Z3_context_to_string. - */ - Z3_string Z3_API Z3_context_to_string(__in Z3_context c); - - - /** - \brief Return runtime statistics as a string. - - This function is mainly used for debugging purposes. It displays - statistics of the search activity. - - \conly \warning The result buffer is statically allocated by Z3. It will - \conly be automatically deallocated when #Z3_del_context is invoked. - \conly So, the buffer is invalidated in the next call to \c Z3_context_to_string. - */ - Z3_string Z3_API Z3_statistics_to_string(__in Z3_context c); - - - /** - \brief Extract satisfying assignment from context as a conjunction. - - This function can be used for debugging purposes. It returns a conjunction - of formulas that are assigned to true in the current context. - This conjunction will contain not only the assertions that are set to true - under the current assignment, but will also include additional literals - if there has been a call to #Z3_check or #Z3_check_and_get_model. - */ - Z3_ast Z3_API Z3_get_context_assignment(__in Z3_context c); - - /*@}*/ - - /** - @name Parser interface - */ - /*@{*/ - /** - \brief \mlh parse_smtlib_string c str sort_names sorts decl_names decls \endmlh - Parse the given string using the SMT-LIB parser. - - The symbol table of the parser can be initialized using the given sorts and declarations. - The symbols in the arrays \c sort_names and \c decl_names don't need to match the names - of the sorts and declarations in the arrays \c sorts and \c decls. This is an useful feature - since we can use arbitrary names to reference sorts and declarations defined using the C API. - - The formulas, assumptions and declarations defined in \c str can be extracted using the functions: - #Z3_get_smtlib_num_formulas, #Z3_get_smtlib_formula, #Z3_get_smtlib_num_assumptions, #Z3_get_smtlib_assumption, - #Z3_get_smtlib_num_decls, and #Z3_get_smtlib_decl. - */ - void Z3_API Z3_parse_smtlib_string(__in Z3_context c, - __in_z Z3_string str, - __in unsigned num_sorts, - __in_ecount(num_sorts) Z3_symbol sort_names[], - __in_ecount(num_sorts) Z3_sort sorts[], - __in unsigned num_decls, - __in_ecount(num_decls) Z3_symbol decl_names[], - __in_ecount(num_decls) Z3_func_decl decls[] - ); - - /** - \brief Similar to #Z3_parse_smtlib_string, but reads the benchmark from a file. - */ - void Z3_API Z3_parse_smtlib_file(__in Z3_context c, - __in_z Z3_string file_name, - __in unsigned num_sorts, - __in_ecount(num_sorts) Z3_symbol sort_names[], - __in_ecount(num_sorts) Z3_sort sorts[], - __in unsigned num_decls, - __in_ecount(num_decls) Z3_symbol decl_names[], - __in_ecount(num_decls) Z3_func_decl decls[] - ); - - /** - \brief Return the number of SMTLIB formulas parsed by the last call to #Z3_parse_smtlib_string or #Z3_parse_smtlib_file. - */ - unsigned Z3_API Z3_get_smtlib_num_formulas(__in Z3_context c); - - /** - \brief \mlh get_smtlib_formula c i \endmlh - Return the i-th formula parsed by the last call to #Z3_parse_smtlib_string or #Z3_parse_smtlib_file. - - \pre i < Z3_get_smtlib_num_formulas(c) - */ - Z3_ast Z3_API Z3_get_smtlib_formula(__in Z3_context c, __in unsigned i); - - /** - \brief Return the number of SMTLIB assumptions parsed by #Z3_parse_smtlib_string or #Z3_parse_smtlib_file. - */ - unsigned Z3_API Z3_get_smtlib_num_assumptions(__in Z3_context c); - - /** - \brief \mlh get_smtlib_assumption c i \endmlh - Return the i-th assumption parsed by the last call to #Z3_parse_smtlib_string or #Z3_parse_smtlib_file. - - \pre i < Z3_get_smtlib_num_assumptions(c) - */ - Z3_ast Z3_API Z3_get_smtlib_assumption(__in Z3_context c, __in unsigned i); - - /** - \brief Return the number of declarations parsed by #Z3_parse_smtlib_string or #Z3_parse_smtlib_file. - */ - unsigned Z3_API Z3_get_smtlib_num_decls(__in Z3_context c); - - /** - \brief \mlh get_smtlib_decl c i \endmlh - Return the i-th declaration parsed by the last call to #Z3_parse_smtlib_string or #Z3_parse_smtlib_file. - - \pre i < Z3_get_smtlib_num_decls(c) - */ - Z3_func_decl Z3_API Z3_get_smtlib_decl(__in Z3_context c, __in unsigned i); - - /** - \brief Return the number of sorts parsed by #Z3_parse_smtlib_string or #Z3_parse_smtlib_file. - */ - unsigned Z3_API Z3_get_smtlib_num_sorts(__in Z3_context c); - - /** - \brief \mlh get_smtlib_sort c i \endmlh - Return the i-th sort parsed by the last call to #Z3_parse_smtlib_string or #Z3_parse_smtlib_file. - - \pre i < Z3_get_smtlib_num_sorts(c) - */ - Z3_sort Z3_API Z3_get_smtlib_sort(__in Z3_context c, __in unsigned i); - - /** - \brief \mlh get_smtlib_error c \endmlh - Retrieve that last error message information generated from parsing. - */ - Z3_string Z3_API Z3_get_smtlib_error(__in Z3_context c); - - /** - \brief \mlh parse_z3_string c str \endmlh - Parse the given string using the Z3 native parser. - - Return the conjunction of asserts made in the input. - */ - Z3_ast Z3_API Z3_parse_z3_string(__in Z3_context c, __in_z Z3_string str); - - /** - \brief Similar to #Z3_parse_z3_string, but reads the benchmark from a file. - */ - Z3_ast Z3_API Z3_parse_z3_file(__in Z3_context c, __in_z Z3_string file_name); - - /** - \brief \mlh parse_smtlib2_string c str \endmlh - Parse the given string using the SMT-LIB2 parser. - - It returns a formula comprising of the conjunction of assertions in the scope - (up to push/pop) at the end of the string. - */ - Z3_ast Z3_API Z3_parse_smtlib2_string(__in Z3_context c, - __in_z Z3_string str, - __in unsigned num_sorts, - __in_ecount(num_sorts) Z3_symbol sort_names[], - __in_ecount(num_sorts) Z3_sort sorts[], - __in unsigned num_decls, - __in_ecount(num_decls) Z3_symbol decl_names[], - __in_ecount(num_decls) Z3_func_decl decls[] - ); - - /** - \brief Similar to #Z3_parse_smtlib2_string, but reads the benchmark from a file. - */ - Z3_ast Z3_API Z3_parse_smtlib2_file(__in Z3_context c, - __in_z Z3_string file_name, - __in unsigned num_sorts, - __in_ecount(num_sorts) Z3_symbol sort_names[], - __in_ecount(num_sorts) Z3_sort sorts[], - __in unsigned num_decls, - __in_ecount(num_decls) Z3_symbol decl_names[], - __in_ecount(num_decls) Z3_func_decl decls[] - ); - - -#ifndef CAMLIDL - /** - \brief \mlh parse_simplify_string c str \endmlh - Parse the given string using the Simplify parser. - - Return the conjunction of asserts made in the input. - */ - Z3_ast Z3_API Z3_parse_simplify_string(__in Z3_context c, __in_z Z3_string str, __out Z3_string* parser_output); - - /** - \brief Similar to #Z3_parse_simplify_string, but reads the benchmark from a file. - */ - Z3_ast Z3_API Z3_parse_simplify_file(__in Z3_context c, __in_z Z3_string file_name, __out Z3_string* parser_output); -#endif // CAMLIDL - - /*@}*/ - -#ifndef CAMLIDL - /** - @name Error Handling - */ - /*@{*/ - - /** - \brief Return the error code for the last API call. - - A call to a Z3 function may return a non Z3_OK error code, - when it is not used correctly. - - \sa Z3_set_error_handler - */ - Z3_error_code Z3_API Z3_get_error_code(__in Z3_context c); - - /** - \brief Register a Z3 error handler. - - A call to a Z3 function may return a non Z3_OK error code, when - it is not used correctly. An error handler can be registered - and will be called in this case. To disable the use of the - error handler, simply register with h=NULL. - - \sa Z3_get_error_code - */ - void Z3_API Z3_set_error_handler(__in Z3_context c, __in Z3_error_handler h); - - /** - \brief Set an error. - */ - void Z3_API Z3_set_error(__in Z3_context c, __in Z3_error_code e); - - /** - \brief Return a string describing the given error code. - */ - Z3_string Z3_API Z3_get_error_msg(__in Z3_error_code err); - /*@}*/ - -#endif // CAMLIDL - - /** - @name Miscellaneous - */ - /*@{*/ - - /** - \brief Return Z3 version number information. - */ - void Z3_API Z3_get_version(__out unsigned * major, - __out unsigned * minor, - __out unsigned * build_number, - __out unsigned * revision_number); - - - /** - \brief Reset all allocated resources. - - Use this facility on out-of memory errors. - It allows discharging the previous state and resuming afresh. - Any pointers previously returned by the API - become invalid. - */ - void Z3_API Z3_reset_memory(void); - - /*@}*/ - - /** - @name External Theory Plugins - */ - /*@{*/ - -#ifndef CAMLIDL - - // - // callbacks and void* don't work with CAMLIDL. - // - typedef Z3_bool Z3_reduce_eq_callback_fptr(__in Z3_theory t, __in Z3_ast a, __in Z3_ast b, __out Z3_ast * r); - - typedef Z3_bool Z3_reduce_app_callback_fptr(__in Z3_theory, __in Z3_func_decl, __in unsigned, __in Z3_ast const [], __out Z3_ast *); - - - typedef Z3_bool Z3_reduce_distinct_callback_fptr(__in Z3_theory, __in unsigned, __in Z3_ast const [], __out Z3_ast *); - - typedef void Z3_theory_callback_fptr(__in Z3_theory t); - - typedef Z3_bool Z3_theory_final_check_callback_fptr(__in Z3_theory); - - typedef void Z3_theory_ast_callback_fptr(__in Z3_theory, __in Z3_ast); - - typedef void Z3_theory_ast_bool_callback_fptr(__in Z3_theory, __in Z3_ast, __in Z3_bool); - - typedef void Z3_theory_ast_ast_callback_fptr(__in Z3_theory, __in Z3_ast, __in Z3_ast); - - - /** - \brief Create a new user defined theory. The new theory will be identified by the name \c th_name. - A theory must be created before asserting any assertion to the given context. - Return NULL in case of failure. - - \c data is a pointer to an external data-structure that may be used to store - theory specific additional data. - */ - Z3_theory Z3_API Z3_mk_theory(__in Z3_context c, __in_z Z3_string th_name, __in Z3_theory_data data); - - /** - \brief Return a pointer to the external data-structure supplied to the function #Z3_mk_theory. - - \see Z3_mk_theory - */ - Z3_theory_data Z3_API Z3_theory_get_ext_data(__in Z3_theory t); - -#endif - - /** - \brief Create an interpreted theory sort. - */ - Z3_sort Z3_API Z3_theory_mk_sort(__in Z3_context c, __in Z3_theory t, __in Z3_symbol s); - - /** - \brief Create an interpreted theory constant value. Values are assumed to be different from each other. - */ - Z3_ast Z3_API Z3_theory_mk_value(__in Z3_context c, __in Z3_theory t, __in Z3_symbol n, __in Z3_sort s); - - /** - \brief Create an interpreted constant for the given theory. - */ - Z3_ast Z3_API Z3_theory_mk_constant(__in Z3_context c, __in Z3_theory t, __in Z3_symbol n, __in Z3_sort s); - - /** - \brief Create an interpreted function declaration for the given theory. - */ - Z3_func_decl Z3_API Z3_theory_mk_func_decl(__in Z3_context c, __in Z3_theory t, __in Z3_symbol n, - __in unsigned domain_size, __in_ecount(domain_size) Z3_sort const domain[], - __in Z3_sort range); - - /** - \brief Return the context where the given theory is installed. - */ - Z3_context Z3_API Z3_theory_get_context(__in Z3_theory t); - - - -#ifndef CAMLIDL - /** - \brief Set a callback that is invoked when theory \c t is deleted. - This callback should be used to delete external data-structures associated with the given theory. - - The callback has the form f(t), where - - \c t is the given theory - - \see Z3_mk_theory - \see Z3_theory_get_ext_data - */ - void Z3_API Z3_set_delete_callback(__in Z3_theory t, __in Z3_theory_callback_fptr f); - - /** - \brief Set a callback for simplifying operators of the given theory. - The callback \c f is invoked by Z3's simplifier. - - It is of the form f(t, d, n, args, r), where: - - \c t is the given theory - - \c d is the declaration of the theory operator - - \c n is the number of arguments in the array \c args - - \c args are arguments for the theory operator - - \c r should contain the result: an expression equivalent to d(args[0], ..., args[n-1]). - - If f(t, d, n, args, r) returns false, then \c r is ignored, and Z3 assumes that no simplification was performed. - */ - void Z3_API Z3_set_reduce_app_callback(__in Z3_theory t, __in Z3_reduce_app_callback_fptr f); - - /** - \brief Set a callback for simplifying the atom s_1 = s_2, when the - sort of \c s_1 and \c s_2 is an interpreted sort of the given theory. - The callback \c f is invoked by Z3's simplifier. - - It has the form f(t, s_1, s_2, r), where: - - \c t is the given theory - - \c s_1 is the left-hand-side - - \c s_2 is the right-hand-side - - \c r should contain the result: an expression equivalent to s_1 = s_2. - - If f(t, s_1, s_2, r) returns false, then \c r is ignored, and Z3 assumes that no simplification was performed. - */ - void Z3_API Z3_set_reduce_eq_callback(__in Z3_theory t, __in Z3_reduce_eq_callback_fptr f); - - /** - \brief Set a callback for simplifying the atom distinct(s_1, ..., s_n), when the - sort of \c s_1, ..., \c s_n is an interpreted sort of the given theory. - The callback \c f is invoked by Z3's simplifier. - - It has the form f(t, n, args, r), where: - - \c t is the given theory - - \c n is the number of arguments in the array \c args - - \c args are arguments for distinct. - - \c r should contain the result: an expression equivalent to distinct(s_1, ..., s_n). - - If f(t, n, args, r) returns false, then \c r is ignored, and Z3 assumes that no simplification was performed. - */ - void Z3_API Z3_set_reduce_distinct_callback(__in Z3_theory t, __in Z3_reduce_distinct_callback_fptr f); - - /** - \brief Set a callback that is invoked when a theory application - is finally added into the logical context. Note that, not every - application contained in an asserted expression is actually - added into the logical context because it may be simplified - during a preprocessing step. - - The callback has the form f(t, n), where - - \c t is the given theory - - - \c n is a theory application, that is, an expression of the form g(...) where \c g is a theory operator. - - \remark An expression \c n added to the logical context at search level \c n, - will remain in the logical context until this level is backtracked. - */ - void Z3_API Z3_set_new_app_callback(__in Z3_theory t, __in Z3_theory_ast_callback_fptr f); - - /** - \brief Set a callback that is invoked when an expression of - sort \c s, where \c s is an interpreted sort of the theory \c - t, is finally added into the logical context. Note that, not - every expression contained in an asserted expression is - actually added into the logical context because it may be - simplified during a preprocessing step. - - The callback has the form f(t, n), where - - \c t is the given theory - - - \c n is an expression of sort \c s, where \c s is an interpreted sort of \c t. - - \remark An expression \c n added to the logical context at search level \c n, - will remain in the logical context until this level is backtracked. - */ - void Z3_API Z3_set_new_elem_callback(__in Z3_theory t, __in Z3_theory_ast_callback_fptr f); - - /** - \brief Set a callback that is invoked when Z3 starts searching for a - satisfying assignment. - - The callback has the form f(t), where - - \c t is the given theory - */ - void Z3_API Z3_set_init_search_callback(__in Z3_theory t, __in Z3_theory_callback_fptr f); - - /** - \brief Set a callback that is invoked when Z3 creates a - case-split (aka backtracking point). - - When a case-split is created we say the search level is increased. - - The callback has the form f(t), where - - \c t is the given theory - */ - void Z3_API Z3_set_push_callback(__in Z3_theory t, __in Z3_theory_callback_fptr f); - - /** - \brief Set a callback that is invoked when Z3 backtracks a - case-split. - - When a case-split is backtracked we say the search level is decreased. - - The callback has the form f(t), where - - \c t is the given theory - */ - void Z3_API Z3_set_pop_callback(__in Z3_theory t, __in Z3_theory_callback_fptr f); - - /** - \brief Set a callback that is invoked when Z3 restarts the - search for a satisfying assignment. - - The callback has the form f(t), where - - \c t is the given theory - */ - void Z3_API Z3_set_restart_callback(__in Z3_theory t, __in Z3_theory_callback_fptr f); - - /** - \brief Set a callback that is invoked when the logical context - is reset by the user. This callback is useful for reseting any - data-structure maintained by the user theory solver. - - The callback has the form f(t), where - - \c t is the given theory - */ - void Z3_API Z3_set_reset_callback(__in Z3_theory t, __in Z3_theory_callback_fptr f); - - /** - \brief Set a callback that is invoked before Z3 starts building a model. - A theory may use this callback to perform expensive operations. - - The callback has the form f(t), where - - \c t is the given theory - - If the theory return \c Z3_false, Z3 will assume that theory is giving up, - and it will assume that it was not possible to decide if the asserted constraints - are satisfiable or not. - */ - void Z3_API Z3_set_final_check_callback(__in Z3_theory t, __in Z3_theory_final_check_callback_fptr f); - - /** - \brief Set a callback that is invoked when an equality s_1 = s_2 - is found by the logical context. - - The callback has the form f(t, s_1, s_2), where: - - \c t is the given theory - - \c s_1 is the left-hand-side - - \c s_2 is the right-hand-side - */ - void Z3_API Z3_set_new_eq_callback(__in Z3_theory t, __in Z3_theory_ast_ast_callback_fptr f); - - /** - \brief Set a callback that is invoked when a disequality s_1 != s_2 - is found by the logical context. - - The callback has the form f(t, s_1, s_2), where: - - \c t is the given theory - - \c s_1 is the left-hand-side - - \c s_2 is the right-hand-side - */ - void Z3_API Z3_set_new_diseq_callback(__in Z3_theory t, __in Z3_theory_ast_ast_callback_fptr f); - - /** - \brief Set a callback that is invoked when a theory predicate is assigned to true/false by Z3. - - The callback has the form f(t, p, v), where: - - \c t is the given theory - - \c p is the assigned predicate. - - \c v is the value (true/false) assigned to \c p. - */ - void Z3_API Z3_set_new_assignment_callback(__in Z3_theory t, __in Z3_theory_ast_bool_callback_fptr f); - - /** - \brief Set a callback that is invoked when an expression is - marked as relevant during the search. This callback is only - invoked when relevancy propagation is enabled. - - The callback has the form f(t, n), where: - - \c t is the given theory - - \c n is the relevant expression - */ - void Z3_API Z3_set_new_relevant_callback(__in Z3_theory t, __in Z3_theory_ast_callback_fptr f); - -#endif // CAMLIDL - /** - \brief Assert a theory axiom/lemmas during the search. - - An axiom added at search level \c n will remain in the logical context until - level \c n is backtracked. - - The callbacks for push (#Z3_set_push_callback) and pop - (#Z3_set_pop_callback) can be used to track when the search - level is increased (i.e., new case-split) and decreased (i.e., - case-split is backtracked). - - Z3 tracks the theory axioms asserted. So, multiple assertions of the same axiom are - ignored. - */ - void Z3_API Z3_theory_assert_axiom(__in Z3_theory t, __in Z3_ast ax); - - /** - \brief Inform to the logical context that \c lhs and \c rhs have the same interpretation - in the model being built by theory \c t. If lhs = rhs is inconsistent with other theories, - then the logical context will backtrack. - - For more information, see the paper "Model-Based Theory Combination" in the Z3 website. - */ - void Z3_API Z3_theory_assume_eq(__in Z3_theory t, __in Z3_ast lhs, __in Z3_ast rhs); - - /** - \brief Enable/disable the simplification of theory axioms asserted using #Z3_theory_assert_axiom. - By default, the simplification of theory specific operators is disabled. - That is, the reduce theory callbacks are not invoked for theory axioms. - The default behavior is useful when asserting axioms stating properties of theory operators. - */ - void Z3_API Z3_theory_enable_axiom_simplification(__in Z3_theory t, __in Z3_bool flag); - - /** - \brief Return the root of the equivalence class containing \c n. - */ - Z3_ast Z3_API Z3_theory_get_eqc_root(__in Z3_theory t, __in Z3_ast n); - - /** - \brief Return the next element in the equivalence class containing \c n. - - The elements in an equivalence class are organized in a circular list. - You can traverse the list by calling this function multiple times - using the result from the previous call. This is illustrated in the - code snippet below. - \code - Z3_ast curr = n; - do - curr = Z3_theory_get_eqc_next(theory, curr); - while (curr != n); - \endcode - */ - Z3_ast Z3_API Z3_theory_get_eqc_next(__in Z3_theory t, __in Z3_ast n); - - /** - \brief Return the number of parents of \c n that are operators of the given theory. - */ - unsigned Z3_API Z3_theory_get_num_parents(__in Z3_theory t, __in Z3_ast n); - - /** - \brief Return the i-th parent of \c n. - See #Z3_theory_get_num_parents. - */ - Z3_ast Z3_API Z3_theory_get_parent(__in Z3_theory t, __in Z3_ast n, __in unsigned i); - - /** - \brief Return \c Z3_TRUE if \c n is an interpreted theory value. - */ - Z3_bool Z3_API Z3_theory_is_value(__in Z3_theory t, __in Z3_ast n); - - /** - \brief Return \c Z3_TRUE if \c d is an interpreted theory declaration. - */ - Z3_bool Z3_API Z3_theory_is_decl(__in Z3_theory t, __in Z3_func_decl d); - - /** - \brief Return the number of expressions of the given theory in - the logical context. These are the expressions notified using the - callback #Z3_set_new_elem_callback. - */ - unsigned Z3_API Z3_theory_get_num_elems(__in Z3_theory t); - - /** - \brief Return the i-th elem of the given theory in the logical context. - - \see Z3_theory_get_num_elems - */ - Z3_ast Z3_API Z3_theory_get_elem(__in Z3_theory t, __in unsigned i); - - /** - \brief Return the number of theory applications in the logical - context. These are the expressions notified using the callback - #Z3_set_new_app_callback. - */ - unsigned Z3_API Z3_theory_get_num_apps(__in Z3_theory t); - - /** - \brief Return the i-th application of the given theory in the logical context. - - \see Z3_theory_get_num_apps - */ - Z3_ast Z3_API Z3_theory_get_app(__in Z3_theory t, __in unsigned i); - - /*@}*/ - - - /** - @name Fixedpoint and Datalog facilities - */ - /*@{*/ - /** - \brief Add a universal Horn clause as a named rule. - The \c horn_rule should be of the form: - - \code - horn_rule ::= (forall (bound-vars) horn_rule) - | (=> atoms horn_rule) - | atom - \endcode - */ - void Z3_API Z3_datalog_add_rule(__in Z3_context c, __in Z3_ast horn_rule, __in Z3_symbol name); - - /** - \brief Pose a query against the asserted rules. - - The query returns a formula that encodes the set of - satisfying instances for the query. - - \code - query ::= (exists (bound-vars) query) - | literals - \endcode - - */ - Z3_ast Z3_API Z3_datalog_query(__in Z3_context c, __in Z3_ast q); - - /** - \brief Configure the predicate representation. - - It sets the predicate to use a set of domains given by the list of symbols. - The domains given by the list of symbols must belong to a set - of built-in domains. - */ - - void Z3_API Z3_datalog_set_predicate_representation( - __in Z3_context c, __in Z3_func_decl f, - __in unsigned num_relations, - __in_ecount(num_relations) Z3_symbol const relation_kinds[]); - - /** - \brief Parse a file in Datalog format and process the queries in it. - */ - void Z3_API Z3_datalog_parse_file(__in Z3_context c, Z3_string filename); - - /** - \brief The following utilities allows adding user-defined domains. - */ - -#ifndef CAMLIDL - typedef void Z3_datalog_reduce_assign_callback_fptr( - __in Z3_context, __in Z3_func_decl, - __in unsigned, __in Z3_ast const [], - __in unsigned, __in Z3_ast const []); - - typedef void Z3_datalog_reduce_app_callback_fptr( - __in Z3_context, __in Z3_func_decl, - __in unsigned, __in Z3_ast const [], - __out Z3_ast*); - - - /** - \brief Initialize the context with a user-defined state. - - */ - void Z3_API Z3_datalog_init(__in Z3_context c, __in void* state); - - /** - \brief Retrieve the user-define state. - */ - void* Z3_API Z3_datalog_get_context(__in Z3_context c); - - - /** - \brief Register a callback to destructive updates. - - Registers are identified with terms encoded as fresh constants, - */ - void Z3_API Z3_datalog_set_reduce_assign_callback( - __in Z3_context c, __in Z3_datalog_reduce_assign_callback_fptr cb); - - /** - \brief Register a callback for buildling terms based on - the relational operators. - */ - void Z3_API Z3_datalog_set_reduce_app_callback( - __in Z3_context c, __in Z3_datalog_reduce_app_callback_fptr cb); - -#endif - - /*@}*/ - -#ifndef CAMLIDL -#ifdef __cplusplus -}; -#endif // __cplusplus -#else -} -#endif // CAMLIDL - -/*@}*/ diff --git a/external/z3/lib/libz3-a-32b b/external/z3/lib/libz3-a-32b deleted file mode 100644 # file too large to diff: external/z3/lib/libz3-a-32b diff --git a/external/z3/lib/libz3-a-64b b/external/z3/lib/libz3-a-64b deleted file mode 100644 # file too large to diff: external/z3/lib/libz3-a-64b diff --git a/external/z3/lib/libz3-so-32b b/external/z3/lib/libz3-so-32b deleted file mode 100644 # file too large to diff: external/z3/lib/libz3-so-32b diff --git a/external/z3/lib/libz3-so-64b b/external/z3/lib/libz3-so-64b deleted file mode 100644 # file too large to diff: external/z3/lib/libz3-so-64b diff --git a/external/z3/ocaml/build-lib.sh b/external/z3/ocaml/build-lib.sh deleted file mode 100644 --- a/external/z3/ocaml/build-lib.sh +++ /dev/null @@ -1,8 +0,0 @@ -#!/bin/bash - -gcc -I../include -I`ocamlc -where` -c z3_stubs.c -c z3_theory_stubs.c -ocamlopt -c z3.mli -ocamlopt -c z3.ml -ar rcs libz3stubs.a z3_stubs.o z3_theory_stubs.o -ranlib libz3stubs.a -ocamlopt -a -o z3.cmxa -cclib -lz3stubs z3.cmx diff --git a/external/z3/ocaml/z3.ml b/external/z3/ocaml/z3.ml deleted file mode 100644 --- a/external/z3/ocaml/z3.ml +++ /dev/null @@ -1,1499 +0,0 @@ -(* File generated from z3.idl *) - -type config -and context -and sort -and func_decl -and ast -and app -and pattern -and symbol -and parameter -and model -and literals -and constructor -and constructor_list -and theory -and theory_data -and enum_1 = - | L_FALSE - | L_UNDEF - | L_TRUE -and lbool = enum_1 -and enum_2 = - | INT_SYMBOL - | STRING_SYMBOL -and symbol_kind = enum_2 -and enum_3 = - | PARAMETER_INT - | PARAMETER_DOUBLE - | PARAMETER_RATIONAL - | PARAMETER_SYMBOL - | PARAMETER_SORT - | PARAMETER_AST - | PARAMETER_FUNC_DECL -and parameter_kind = enum_3 -and enum_4 = - | UNINTERPRETED_SORT - | BOOL_SORT - | INT_SORT - | REAL_SORT - | BV_SORT - | ARRAY_SORT - | DATATYPE_SORT - | RELATION_SORT - | FINITE_DOMAIN_SORT - | UNKNOWN_SORT -and sort_kind = enum_4 -and enum_5 = - | NUMERAL_AST - | APP_AST - | VAR_AST - | QUANTIFIER_AST - | UNKNOWN_AST -and ast_kind = enum_5 -and enum_6 = - | OP_TRUE - | OP_FALSE - | OP_EQ - | OP_DISTINCT - | OP_ITE - | OP_AND - | OP_OR - | OP_IFF - | OP_XOR - | OP_NOT - | OP_IMPLIES - | OP_OEQ - | OP_ANUM - | OP_LE - | OP_GE - | OP_LT - | OP_GT - | OP_ADD - | OP_SUB - | OP_UMINUS - | OP_MUL - | OP_DIV - | OP_IDIV - | OP_REM - | OP_MOD - | OP_TO_REAL - | OP_TO_INT - | OP_IS_INT - | OP_STORE - | OP_SELECT - | OP_CONST_ARRAY - | OP_ARRAY_MAP - | OP_ARRAY_DEFAULT - | OP_SET_UNION - | OP_SET_INTERSECT - | OP_SET_DIFFERENCE - | OP_SET_COMPLEMENT - | OP_SET_SUBSET - | OP_AS_ARRAY - | OP_BNUM - | OP_BIT1 - | OP_BIT0 - | OP_BNEG - | OP_BADD - | OP_BSUB - | OP_BMUL - | OP_BSDIV - | OP_BUDIV - | OP_BSREM - | OP_BUREM - | OP_BSMOD - | OP_BSDIV0 - | OP_BUDIV0 - | OP_BSREM0 - | OP_BUREM0 - | OP_BSMOD0 - | OP_ULEQ - | OP_SLEQ - | OP_UGEQ - | OP_SGEQ - | OP_ULT - | OP_SLT - | OP_UGT - | OP_SGT - | OP_BAND - | OP_BOR - | OP_BNOT - | OP_BXOR - | OP_BNAND - | OP_BNOR - | OP_BXNOR - | OP_CONCAT - | OP_SIGN_EXT - | OP_ZERO_EXT - | OP_EXTRACT - | OP_REPEAT - | OP_BREDOR - | OP_BREDAND - | OP_BCOMP - | OP_BSHL - | OP_BLSHR - | OP_BASHR - | OP_ROTATE_LEFT - | OP_ROTATE_RIGHT - | OP_EXT_ROTATE_LEFT - | OP_EXT_ROTATE_RIGHT - | OP_INT2BV - | OP_BV2INT - | OP_CARRY - | OP_XOR3 - | OP_PR_UNDEF - | OP_PR_TRUE - | OP_PR_ASSERTED - | OP_PR_GOAL - | OP_PR_MODUS_PONENS - | OP_PR_REFLEXIVITY - | OP_PR_SYMMETRY - | OP_PR_TRANSITIVITY - | OP_PR_TRANSITIVITY_STAR - | OP_PR_MONOTONICITY - | OP_PR_QUANT_INTRO - | OP_PR_DISTRIBUTIVITY - | OP_PR_AND_ELIM - | OP_PR_NOT_OR_ELIM - | OP_PR_REWRITE - | OP_PR_REWRITE_STAR - | OP_PR_PULL_QUANT - | OP_PR_PULL_QUANT_STAR - | OP_PR_PUSH_QUANT - | OP_PR_ELIM_UNUSED_VARS - | OP_PR_DER - | OP_PR_QUANT_INST - | OP_PR_HYPOTHESIS - | OP_PR_LEMMA - | OP_PR_UNIT_RESOLUTION - | OP_PR_IFF_TRUE - | OP_PR_IFF_FALSE - | OP_PR_COMMUTATIVITY - | OP_PR_DEF_AXIOM - | OP_PR_DEF_INTRO - | OP_PR_APPLY_DEF - | OP_PR_IFF_OEQ - | OP_PR_NNF_POS - | OP_PR_NNF_NEG - | OP_PR_NNF_STAR - | OP_PR_CNF_STAR - | OP_PR_SKOLEMIZE - | OP_PR_MODUS_PONENS_OEQ - | OP_PR_TH_LEMMA - | OP_RA_STORE - | OP_RA_EMPTY - | OP_RA_IS_EMPTY - | OP_RA_JOIN - | OP_RA_UNION - | OP_RA_WIDEN - | OP_RA_PROJECT - | OP_RA_FILTER - | OP_RA_NEGATION_FILTER - | OP_RA_RENAME - | OP_RA_COMPLEMENT - | OP_RA_SELECT - | OP_RA_CLONE - | OP_FD_LT - | OP_UNINTERPRETED -and decl_kind = enum_6 -and enum_7 = - | NO_FAILURE - | UNKNOWN - | TIMEOUT - | MEMOUT_WATERMARK - | CANCELED - | NUM_CONFLICTS - | THEORY - | QUANTIFIERS -and search_failure = enum_7 -and enum_8 = - | PRINT_SMTLIB_FULL - | PRINT_LOW_LEVEL - | PRINT_SMTLIB_COMPLIANT - | PRINT_SMTLIB2_COMPLIANT -and ast_print_mode = enum_8 - -external mk_config : unit -> config - = "camlidl_z3_Z3_mk_config" - -external del_config : config -> unit - = "camlidl_z3_Z3_del_config" - -external set_param_value : config -> string -> string -> unit - = "camlidl_z3_Z3_set_param_value" - -external mk_context : config -> context - = "camlidl_z3_Z3_mk_context" - -external mk_context_rc : config -> context - = "camlidl_z3_Z3_mk_context_rc" - -external set_logic : context -> string -> bool - = "camlidl_z3_Z3_set_logic" - -external del_context : context -> unit - = "camlidl_z3_Z3_del_context" - -external inc_ref : context -> ast -> unit - = "camlidl_z3_Z3_inc_ref" - -external dec_ref : context -> ast -> unit - = "camlidl_z3_Z3_dec_ref" - -external trace_to_file : context -> string -> bool - = "camlidl_z3_Z3_trace_to_file" - -external trace_to_stderr : context -> unit - = "camlidl_z3_Z3_trace_to_stderr" - -external trace_to_stdout : context -> unit - = "camlidl_z3_Z3_trace_to_stdout" - -external trace_off : context -> unit - = "camlidl_z3_Z3_trace_off" - -external toggle_warning_messages : bool -> unit - = "camlidl_z3_Z3_toggle_warning_messages" - -external update_param_value : context -> string -> string -> unit - = "camlidl_z3_Z3_update_param_value" - -external mk_int_symbol : context -> int -> symbol - = "camlidl_z3_Z3_mk_int_symbol" - -external mk_string_symbol : context -> string -> symbol - = "camlidl_z3_Z3_mk_string_symbol" - -external is_eq_sort : context -> sort -> sort -> bool - = "camlidl_z3_Z3_is_eq_sort" - -external mk_uninterpreted_sort : context -> symbol -> sort - = "camlidl_z3_Z3_mk_uninterpreted_sort" - -external mk_bool_sort : context -> sort - = "camlidl_z3_Z3_mk_bool_sort" - -external mk_int_sort : context -> sort - = "camlidl_z3_Z3_mk_int_sort" - -external mk_real_sort : context -> sort - = "camlidl_z3_Z3_mk_real_sort" - -external mk_bv_sort : context -> int -> sort - = "camlidl_z3_Z3_mk_bv_sort" - -external mk_array_sort : context -> sort -> sort -> sort - = "camlidl_z3_Z3_mk_array_sort" - -external mk_tuple_sort : context -> symbol -> symbol array -> sort array -> sort * func_decl * func_decl array - = "camlidl_z3_Z3_mk_tuple_sort" - -external mk_enumeration_sort : context -> symbol -> symbol array -> sort * func_decl array * func_decl array - = "camlidl_z3_Z3_mk_enumeration_sort" - -external mk_list_sort : context -> symbol -> sort -> sort * func_decl * func_decl * func_decl * func_decl * func_decl * func_decl - = "camlidl_z3_Z3_mk_list_sort" - -external mk_constructor : context -> symbol -> symbol -> symbol array -> sort array -> int array -> constructor - = "camlidl_z3_Z3_mk_constructor_bytecode" "camlidl_z3_Z3_mk_constructor" - -external query_constructor : context -> constructor -> int -> func_decl * func_decl * func_decl array - = "camlidl_z3_Z3_query_constructor" - -external del_constructor : context -> constructor -> unit - = "camlidl_z3_Z3_del_constructor" - -external mk_datatype : context -> symbol -> constructor array -> sort * constructor array - = "camlidl_z3_Z3_mk_datatype" - -external mk_constructor_list : context -> constructor array -> constructor_list - = "camlidl_z3_Z3_mk_constructor_list" - -external del_constructor_list : context -> constructor_list -> unit - = "camlidl_z3_Z3_del_constructor_list" - -external mk_datatypes : context -> symbol array -> constructor_list array -> sort array * constructor_list array - = "camlidl_z3_Z3_mk_datatypes" - -external mk_injective_function : context -> symbol -> sort array -> sort -> func_decl - = "camlidl_z3_Z3_mk_injective_function" - -external is_eq_ast : context -> ast -> ast -> bool - = "camlidl_z3_Z3_is_eq_ast" - -external is_eq_func_decl : context -> func_decl -> func_decl -> bool - = "camlidl_z3_Z3_is_eq_func_decl" - -external mk_func_decl : context -> symbol -> sort array -> sort -> func_decl - = "camlidl_z3_Z3_mk_func_decl" - -external mk_app : context -> func_decl -> ast array -> ast - = "camlidl_z3_Z3_mk_app" - -external mk_const : context -> symbol -> sort -> ast - = "camlidl_z3_Z3_mk_const" - -external mk_label : context -> symbol -> bool -> ast -> ast - = "camlidl_z3_Z3_mk_label" - -external mk_fresh_func_decl : context -> string -> sort array -> sort -> func_decl - = "camlidl_z3_Z3_mk_fresh_func_decl" - -external mk_fresh_const : context -> string -> sort -> ast - = "camlidl_z3_Z3_mk_fresh_const" - -external mk_true : context -> ast - = "camlidl_z3_Z3_mk_true" - -external mk_false : context -> ast - = "camlidl_z3_Z3_mk_false" - -external mk_eq : context -> ast -> ast -> ast - = "camlidl_z3_Z3_mk_eq" - -external mk_distinct : context -> ast array -> ast - = "camlidl_z3_Z3_mk_distinct" - -external mk_not : context -> ast -> ast - = "camlidl_z3_Z3_mk_not" - -external mk_ite : context -> ast -> ast -> ast -> ast - = "camlidl_z3_Z3_mk_ite" - -external mk_iff : context -> ast -> ast -> ast - = "camlidl_z3_Z3_mk_iff" - -external mk_implies : context -> ast -> ast -> ast - = "camlidl_z3_Z3_mk_implies" - -external mk_xor : context -> ast -> ast -> ast - = "camlidl_z3_Z3_mk_xor" - -external mk_and : context -> ast array -> ast - = "camlidl_z3_Z3_mk_and" - -external mk_or : context -> ast array -> ast - = "camlidl_z3_Z3_mk_or" - -external mk_add : context -> ast array -> ast - = "camlidl_z3_Z3_mk_add" - -external mk_mul : context -> ast array -> ast - = "camlidl_z3_Z3_mk_mul" - -external mk_sub : context -> ast array -> ast - = "camlidl_z3_Z3_mk_sub" - -external mk_unary_minus : context -> ast -> ast - = "camlidl_z3_Z3_mk_unary_minus" - -external mk_div : context -> ast -> ast -> ast - = "camlidl_z3_Z3_mk_div" - -external mk_mod : context -> ast -> ast -> ast - = "camlidl_z3_Z3_mk_mod" - -external mk_rem : context -> ast -> ast -> ast - = "camlidl_z3_Z3_mk_rem" - -external mk_lt : context -> ast -> ast -> ast - = "camlidl_z3_Z3_mk_lt" - -external mk_le : context -> ast -> ast -> ast - = "camlidl_z3_Z3_mk_le" - -external mk_gt : context -> ast -> ast -> ast - = "camlidl_z3_Z3_mk_gt" - -external mk_ge : context -> ast -> ast -> ast - = "camlidl_z3_Z3_mk_ge" - -external mk_int2real : context -> ast -> ast - = "camlidl_z3_Z3_mk_int2real" - -external mk_real2int : context -> ast -> ast - = "camlidl_z3_Z3_mk_real2int" - -external mk_is_int : context -> ast -> ast - = "camlidl_z3_Z3_mk_is_int" - -external mk_bvnot : context -> ast -> ast - = "camlidl_z3_Z3_mk_bvnot" - -external mk_bvredand : context -> ast -> ast - = "camlidl_z3_Z3_mk_bvredand" - -external mk_bvredor : context -> ast -> ast - = "camlidl_z3_Z3_mk_bvredor" - -external mk_bvand : context -> ast -> ast -> ast - = "camlidl_z3_Z3_mk_bvand" - -external mk_bvor : context -> ast -> ast -> ast - = "camlidl_z3_Z3_mk_bvor" - -external mk_bvxor : context -> ast -> ast -> ast - = "camlidl_z3_Z3_mk_bvxor" - -external mk_bvnand : context -> ast -> ast -> ast - = "camlidl_z3_Z3_mk_bvnand" - -external mk_bvnor : context -> ast -> ast -> ast - = "camlidl_z3_Z3_mk_bvnor" - -external mk_bvxnor : context -> ast -> ast -> ast - = "camlidl_z3_Z3_mk_bvxnor" - -external mk_bvneg : context -> ast -> ast - = "camlidl_z3_Z3_mk_bvneg" - -external mk_bvadd : context -> ast -> ast -> ast - = "camlidl_z3_Z3_mk_bvadd" - -external mk_bvsub : context -> ast -> ast -> ast - = "camlidl_z3_Z3_mk_bvsub" - -external mk_bvmul : context -> ast -> ast -> ast - = "camlidl_z3_Z3_mk_bvmul" - -external mk_bvudiv : context -> ast -> ast -> ast - = "camlidl_z3_Z3_mk_bvudiv" - -external mk_bvsdiv : context -> ast -> ast -> ast - = "camlidl_z3_Z3_mk_bvsdiv" - -external mk_bvurem : context -> ast -> ast -> ast - = "camlidl_z3_Z3_mk_bvurem" - -external mk_bvsrem : context -> ast -> ast -> ast - = "camlidl_z3_Z3_mk_bvsrem" - -external mk_bvsmod : context -> ast -> ast -> ast - = "camlidl_z3_Z3_mk_bvsmod" - -external mk_bvult : context -> ast -> ast -> ast - = "camlidl_z3_Z3_mk_bvult" - -external mk_bvslt : context -> ast -> ast -> ast - = "camlidl_z3_Z3_mk_bvslt" - -external mk_bvule : context -> ast -> ast -> ast - = "camlidl_z3_Z3_mk_bvule" - -external mk_bvsle : context -> ast -> ast -> ast - = "camlidl_z3_Z3_mk_bvsle" - -external mk_bvuge : context -> ast -> ast -> ast - = "camlidl_z3_Z3_mk_bvuge" - -external mk_bvsge : context -> ast -> ast -> ast - = "camlidl_z3_Z3_mk_bvsge" - -external mk_bvugt : context -> ast -> ast -> ast - = "camlidl_z3_Z3_mk_bvugt" - -external mk_bvsgt : context -> ast -> ast -> ast - = "camlidl_z3_Z3_mk_bvsgt" - -external mk_concat : context -> ast -> ast -> ast - = "camlidl_z3_Z3_mk_concat" - -external mk_extract : context -> int -> int -> ast -> ast - = "camlidl_z3_Z3_mk_extract" - -external mk_sign_ext : context -> int -> ast -> ast - = "camlidl_z3_Z3_mk_sign_ext" - -external mk_zero_ext : context -> int -> ast -> ast - = "camlidl_z3_Z3_mk_zero_ext" - -external mk_repeat : context -> int -> ast -> ast - = "camlidl_z3_Z3_mk_repeat" - -external mk_bvshl : context -> ast -> ast -> ast - = "camlidl_z3_Z3_mk_bvshl" - -external mk_bvlshr : context -> ast -> ast -> ast - = "camlidl_z3_Z3_mk_bvlshr" - -external mk_bvashr : context -> ast -> ast -> ast - = "camlidl_z3_Z3_mk_bvashr" - -external mk_rotate_left : context -> int -> ast -> ast - = "camlidl_z3_Z3_mk_rotate_left" - -external mk_rotate_right : context -> int -> ast -> ast - = "camlidl_z3_Z3_mk_rotate_right" - -external mk_ext_rotate_left : context -> ast -> ast -> ast - = "camlidl_z3_Z3_mk_ext_rotate_left" - -external mk_ext_rotate_right : context -> ast -> ast -> ast - = "camlidl_z3_Z3_mk_ext_rotate_right" - -external mk_int2bv : context -> int -> ast -> ast - = "camlidl_z3_Z3_mk_int2bv" - -external mk_bv2int : context -> ast -> bool -> ast - = "camlidl_z3_Z3_mk_bv2int" - -external mk_bvadd_no_overflow : context -> ast -> ast -> bool -> ast - = "camlidl_z3_Z3_mk_bvadd_no_overflow" - -external mk_bvadd_no_underflow : context -> ast -> ast -> ast - = "camlidl_z3_Z3_mk_bvadd_no_underflow" - -external mk_bvsub_no_overflow : context -> ast -> ast -> ast - = "camlidl_z3_Z3_mk_bvsub_no_overflow" - -external mk_bvsub_no_underflow : context -> ast -> ast -> bool -> ast - = "camlidl_z3_Z3_mk_bvsub_no_underflow" - -external mk_bvsdiv_no_overflow : context -> ast -> ast -> ast - = "camlidl_z3_Z3_mk_bvsdiv_no_overflow" - -external mk_bvneg_no_overflow : context -> ast -> ast - = "camlidl_z3_Z3_mk_bvneg_no_overflow" - -external mk_bvmul_no_overflow : context -> ast -> ast -> bool -> ast - = "camlidl_z3_Z3_mk_bvmul_no_overflow" - -external mk_bvmul_no_underflow : context -> ast -> ast -> ast - = "camlidl_z3_Z3_mk_bvmul_no_underflow" - -external mk_select : context -> ast -> ast -> ast - = "camlidl_z3_Z3_mk_select" - -external mk_store : context -> ast -> ast -> ast -> ast - = "camlidl_z3_Z3_mk_store" - -external mk_const_array : context -> sort -> ast -> ast - = "camlidl_z3_Z3_mk_const_array" - -external mk_map : context -> func_decl -> int -> ast -> ast - = "camlidl_z3_Z3_mk_map" - -external mk_array_default : context -> ast -> ast - = "camlidl_z3_Z3_mk_array_default" - -external mk_set_sort : context -> sort -> sort - = "camlidl_z3_Z3_mk_set_sort" - -external mk_empty_set : context -> sort -> ast - = "camlidl_z3_Z3_mk_empty_set" - -external mk_full_set : context -> sort -> ast - = "camlidl_z3_Z3_mk_full_set" - -external mk_set_add : context -> ast -> ast -> ast - = "camlidl_z3_Z3_mk_set_add" - -external mk_set_del : context -> ast -> ast -> ast - = "camlidl_z3_Z3_mk_set_del" - -external mk_set_union : context -> ast array -> ast - = "camlidl_z3_Z3_mk_set_union" - -external mk_set_intersect : context -> ast array -> ast - = "camlidl_z3_Z3_mk_set_intersect" - -external mk_set_difference : context -> ast -> ast -> ast - = "camlidl_z3_Z3_mk_set_difference" - -external mk_set_complement : context -> ast -> ast - = "camlidl_z3_Z3_mk_set_complement" - -external mk_set_member : context -> ast -> ast -> ast - = "camlidl_z3_Z3_mk_set_member" - -external mk_set_subset : context -> ast -> ast -> ast - = "camlidl_z3_Z3_mk_set_subset" - -external mk_numeral : context -> string -> sort -> ast - = "camlidl_z3_Z3_mk_numeral" - -external mk_real : context -> int -> int -> ast - = "camlidl_z3_Z3_mk_real" - -external mk_int : context -> int -> sort -> ast - = "camlidl_z3_Z3_mk_int" - -external mk_unsigned_int : context -> int -> sort -> ast - = "camlidl_z3_Z3_mk_unsigned_int" - -external mk_pattern : context -> ast array -> pattern - = "camlidl_z3_Z3_mk_pattern" - -external mk_bound : context -> int -> sort -> ast - = "camlidl_z3_Z3_mk_bound" - -external mk_forall : context -> int -> pattern array -> sort array -> symbol array -> ast -> ast - = "camlidl_z3_Z3_mk_forall_bytecode" "camlidl_z3_Z3_mk_forall" - -external mk_exists : context -> int -> pattern array -> sort array -> symbol array -> ast -> ast - = "camlidl_z3_Z3_mk_exists_bytecode" "camlidl_z3_Z3_mk_exists" - -external mk_quantifier : context -> bool -> int -> pattern array -> sort array -> symbol array -> ast -> ast - = "camlidl_z3_Z3_mk_quantifier_bytecode" "camlidl_z3_Z3_mk_quantifier" - -external mk_quantifier_ex : context -> bool -> int -> symbol -> symbol -> pattern array -> ast array -> sort array -> symbol array -> ast -> ast - = "camlidl_z3_Z3_mk_quantifier_ex_bytecode" "camlidl_z3_Z3_mk_quantifier_ex" - -external mk_forall_const : context -> int -> app array -> pattern array -> ast -> ast - = "camlidl_z3_Z3_mk_forall_const" - -external mk_exists_const : context -> int -> app array -> pattern array -> ast -> ast - = "camlidl_z3_Z3_mk_exists_const" - -external mk_quantifier_const : context -> bool -> int -> app array -> pattern array -> ast -> ast - = "camlidl_z3_Z3_mk_quantifier_const_bytecode" "camlidl_z3_Z3_mk_quantifier_const" - -external mk_quantifier_const_ex : context -> bool -> int -> symbol -> symbol -> app array -> pattern array -> ast array -> ast -> ast - = "camlidl_z3_Z3_mk_quantifier_const_ex_bytecode" "camlidl_z3_Z3_mk_quantifier_const_ex" - -external get_ast_id : context -> ast -> int - = "camlidl_z3_Z3_get_ast_id" - -external get_func_decl_id : context -> func_decl -> int - = "camlidl_z3_Z3_get_func_decl_id" - -external get_sort_id : context -> sort -> int - = "camlidl_z3_Z3_get_sort_id" - -external is_well_sorted : context -> ast -> bool - = "camlidl_z3_Z3_is_well_sorted" - -external get_symbol_kind : context -> symbol -> symbol_kind - = "camlidl_z3_Z3_get_symbol_kind" - -external get_symbol_int : context -> symbol -> int - = "camlidl_z3_Z3_get_symbol_int" - -external get_symbol_string : context -> symbol -> string - = "camlidl_z3_Z3_get_symbol_string" - -external get_ast_kind : context -> ast -> ast_kind - = "camlidl_z3_Z3_get_ast_kind" - -external get_numeral_string : context -> ast -> string - = "camlidl_z3_Z3_get_numeral_string" - -external get_numeral_small : context -> ast -> bool * int64 * int64 - = "camlidl_z3_Z3_get_numeral_small" - -external get_numeral_int : context -> ast -> bool * int - = "camlidl_z3_Z3_get_numeral_int" - -external get_numeral_uint : context -> ast -> bool * int - = "camlidl_z3_Z3_get_numeral_uint" - -external get_bool_value : context -> ast -> lbool - = "camlidl_z3_Z3_get_bool_value" - -external get_app_decl : context -> app -> func_decl - = "camlidl_z3_Z3_get_app_decl" - -external get_app_num_args : context -> app -> int - = "camlidl_z3_Z3_get_app_num_args" - -external get_app_arg : context -> app -> int -> ast - = "camlidl_z3_Z3_get_app_arg" - -external get_index_value : context -> ast -> int - = "camlidl_z3_Z3_get_index_value" - -external is_quantifier_forall : context -> ast -> bool - = "camlidl_z3_Z3_is_quantifier_forall" - -external get_quantifier_weight : context -> ast -> int - = "camlidl_z3_Z3_get_quantifier_weight" - -external get_quantifier_num_patterns : context -> ast -> int - = "camlidl_z3_Z3_get_quantifier_num_patterns" - -external get_quantifier_pattern_ast : context -> ast -> int -> pattern - = "camlidl_z3_Z3_get_quantifier_pattern_ast" - -external get_quantifier_num_no_patterns : context -> ast -> int - = "camlidl_z3_Z3_get_quantifier_num_no_patterns" - -external get_quantifier_no_pattern_ast : context -> ast -> int -> ast - = "camlidl_z3_Z3_get_quantifier_no_pattern_ast" - -external get_quantifier_bound_name : context -> ast -> int -> symbol - = "camlidl_z3_Z3_get_quantifier_bound_name" - -external get_quantifier_bound_sort : context -> ast -> int -> sort - = "camlidl_z3_Z3_get_quantifier_bound_sort" - -external get_quantifier_body : context -> ast -> ast - = "camlidl_z3_Z3_get_quantifier_body" - -external get_quantifier_num_bound : context -> ast -> int - = "camlidl_z3_Z3_get_quantifier_num_bound" - -external get_decl_name : context -> func_decl -> symbol - = "camlidl_z3_Z3_get_decl_name" - -external get_decl_num_parameters : context -> func_decl -> int - = "camlidl_z3_Z3_get_decl_num_parameters" - -external get_decl_parameter_kind : context -> func_decl -> int -> parameter_kind - = "camlidl_z3_Z3_get_decl_parameter_kind" - -external get_decl_int_parameter : context -> func_decl -> int -> int - = "camlidl_z3_Z3_get_decl_int_parameter" - -external get_decl_double_parameter : context -> func_decl -> int -> float - = "camlidl_z3_Z3_get_decl_double_parameter" - -external get_decl_symbol_parameter : context -> func_decl -> int -> symbol - = "camlidl_z3_Z3_get_decl_symbol_parameter" - -external get_decl_sort_parameter : context -> func_decl -> int -> sort - = "camlidl_z3_Z3_get_decl_sort_parameter" - -external get_decl_ast_parameter : context -> func_decl -> int -> ast - = "camlidl_z3_Z3_get_decl_ast_parameter" - -external get_decl_func_decl_parameter : context -> func_decl -> int -> func_decl - = "camlidl_z3_Z3_get_decl_func_decl_parameter" - -external get_decl_rational_parameter : context -> func_decl -> int -> string - = "camlidl_z3_Z3_get_decl_rational_parameter" - -external get_sort_name : context -> sort -> symbol - = "camlidl_z3_Z3_get_sort_name" - -external get_sort : context -> ast -> sort - = "camlidl_z3_Z3_get_sort" - -external get_domain_size : context -> func_decl -> int - = "camlidl_z3_Z3_get_domain_size" - -external get_domain : context -> func_decl -> int -> sort - = "camlidl_z3_Z3_get_domain" - -external get_range : context -> func_decl -> sort - = "camlidl_z3_Z3_get_range" - -external get_sort_kind : context -> sort -> sort_kind - = "camlidl_z3_Z3_get_sort_kind" - -external get_bv_sort_size : context -> sort -> int - = "camlidl_z3_Z3_get_bv_sort_size" - -external get_array_sort_domain : context -> sort -> sort - = "camlidl_z3_Z3_get_array_sort_domain" - -external get_array_sort_range : context -> sort -> sort - = "camlidl_z3_Z3_get_array_sort_range" - -external get_tuple_sort_mk_decl : context -> sort -> func_decl - = "camlidl_z3_Z3_get_tuple_sort_mk_decl" - -external get_decl_kind : context -> func_decl -> decl_kind - = "camlidl_z3_Z3_get_decl_kind" - -external get_tuple_sort_num_fields : context -> sort -> int - = "camlidl_z3_Z3_get_tuple_sort_num_fields" - -external get_tuple_sort_field_decl : context -> sort -> int -> func_decl - = "camlidl_z3_Z3_get_tuple_sort_field_decl" - -external get_datatype_sort_num_constructors : context -> sort -> int - = "camlidl_z3_Z3_get_datatype_sort_num_constructors" - -external get_datatype_sort_constructor : context -> sort -> int -> func_decl - = "camlidl_z3_Z3_get_datatype_sort_constructor" - -external get_datatype_sort_recognizer : context -> sort -> int -> func_decl - = "camlidl_z3_Z3_get_datatype_sort_recognizer" - -external get_datatype_sort_constructor_accessor : context -> sort -> int -> int -> func_decl - = "camlidl_z3_Z3_get_datatype_sort_constructor_accessor" - -external get_relation_arity : context -> sort -> int - = "camlidl_z3_Z3_get_relation_arity" - -external get_relation_column : context -> sort -> int -> sort - = "camlidl_z3_Z3_get_relation_column" - -external get_pattern_num_terms : context -> pattern -> int - = "camlidl_z3_Z3_get_pattern_num_terms" - -external get_pattern : context -> pattern -> int -> ast - = "camlidl_z3_Z3_get_pattern" - -external simplify : context -> ast -> ast - = "camlidl_z3_Z3_simplify" - -external update_term : context -> ast -> ast array -> ast - = "camlidl_z3_Z3_update_term" - -external substitute : context -> ast -> ast array -> ast array -> ast - = "camlidl_z3_Z3_substitute" - -external substitute_vars : context -> ast -> ast array -> ast - = "camlidl_z3_Z3_substitute_vars" - -external sort_to_ast : context -> sort -> ast - = "camlidl_z3_Z3_sort_to_ast" - -external func_decl_to_ast : context -> func_decl -> ast - = "camlidl_z3_Z3_func_decl_to_ast" - -external pattern_to_ast : context -> pattern -> ast - = "camlidl_z3_Z3_pattern_to_ast" - -external app_to_ast : context -> app -> ast - = "camlidl_z3_Z3_app_to_ast" - -external to_app : context -> ast -> app - = "camlidl_z3_Z3_to_app" - -external push : context -> unit - = "camlidl_z3_Z3_push" - -external pop : context -> int -> unit - = "camlidl_z3_Z3_pop" - -external get_num_scopes : context -> int - = "camlidl_z3_Z3_get_num_scopes" - -external persist_ast : context -> ast -> int -> unit - = "camlidl_z3_Z3_persist_ast" - -external assert_cnstr : context -> ast -> unit - = "camlidl_z3_Z3_assert_cnstr" - -external check_and_get_model : context -> lbool * model - = "camlidl_z3_Z3_check_and_get_model" - -external check : context -> lbool - = "camlidl_z3_Z3_check" - -external check_assumptions : context -> ast array -> int -> ast array -> lbool * model * ast * int * ast array - = "camlidl_z3_Z3_check_assumptions" - -external get_implied_equalities : context -> ast array -> lbool * int array - = "camlidl_z3_Z3_get_implied_equalities" - -external del_model : context -> model -> unit - = "camlidl_z3_Z3_del_model" - -external soft_check_cancel : context -> unit - = "camlidl_z3_Z3_soft_check_cancel" - -external get_search_failure : context -> search_failure - = "camlidl_z3_Z3_get_search_failure" - -external get_relevant_labels : context -> literals - = "camlidl_z3_Z3_get_relevant_labels" - -external get_relevant_literals : context -> literals - = "camlidl_z3_Z3_get_relevant_literals" - -external get_guessed_literals : context -> literals - = "camlidl_z3_Z3_get_guessed_literals" - -external del_literals : context -> literals -> unit - = "camlidl_z3_Z3_del_literals" - -external get_num_literals : context -> literals -> int - = "camlidl_z3_Z3_get_num_literals" - -external get_label_symbol : context -> literals -> int -> symbol - = "camlidl_z3_Z3_get_label_symbol" - -external get_literal : context -> literals -> int -> ast - = "camlidl_z3_Z3_get_literal" - -external disable_literal : context -> literals -> int -> unit - = "camlidl_z3_Z3_disable_literal" - -external block_literals : context -> literals -> unit - = "camlidl_z3_Z3_block_literals" - -external get_model_num_constants : context -> model -> int - = "camlidl_z3_Z3_get_model_num_constants" - -external get_model_constant : context -> model -> int -> func_decl - = "camlidl_z3_Z3_get_model_constant" - -external eval_func_decl : context -> model -> func_decl -> bool * ast - = "camlidl_z3_Z3_eval_func_decl" - -external is_array_value : context -> model -> ast -> bool * int - = "camlidl_z3_Z3_is_array_value" - -external get_array_value : context -> model -> ast -> ast array -> ast array -> ast array * ast array * ast - = "camlidl_z3_Z3_get_array_value" - -external get_model_num_funcs : context -> model -> int - = "camlidl_z3_Z3_get_model_num_funcs" - -external get_model_func_decl : context -> model -> int -> func_decl - = "camlidl_z3_Z3_get_model_func_decl" - -external get_model_func_else : context -> model -> int -> ast - = "camlidl_z3_Z3_get_model_func_else" - -external get_model_func_num_entries : context -> model -> int -> int - = "camlidl_z3_Z3_get_model_func_num_entries" - -external get_model_func_entry_num_args : context -> model -> int -> int -> int - = "camlidl_z3_Z3_get_model_func_entry_num_args" - -external get_model_func_entry_arg : context -> model -> int -> int -> int -> ast - = "camlidl_z3_Z3_get_model_func_entry_arg" - -external get_model_func_entry_value : context -> model -> int -> int -> ast - = "camlidl_z3_Z3_get_model_func_entry_value" - -external eval : context -> model -> ast -> bool * ast - = "camlidl_z3_Z3_eval" - -external eval_decl : context -> model -> func_decl -> ast array -> bool * ast - = "camlidl_z3_Z3_eval_decl" - -external open_log : context -> string -> bool - = "camlidl_z3_Z3_open_log" - -external append_log : context -> string -> unit - = "camlidl_z3_Z3_append_log" - -external close_log : context -> unit - = "camlidl_z3_Z3_close_log" - -external set_ast_print_mode : context -> ast_print_mode -> unit - = "camlidl_z3_Z3_set_ast_print_mode" - -external ast_to_string : context -> ast -> string - = "camlidl_z3_Z3_ast_to_string" - -external pattern_to_string : context -> pattern -> string - = "camlidl_z3_Z3_pattern_to_string" - -external sort_to_string : context -> sort -> string - = "camlidl_z3_Z3_sort_to_string" - -external func_decl_to_string : context -> func_decl -> string - = "camlidl_z3_Z3_func_decl_to_string" - -external model_to_string : context -> model -> string - = "camlidl_z3_Z3_model_to_string" - -external benchmark_to_smtlib_string : context -> string -> string -> string -> string -> ast array -> ast -> string - = "camlidl_z3_Z3_benchmark_to_smtlib_string_bytecode" "camlidl_z3_Z3_benchmark_to_smtlib_string" - -external context_to_string : context -> string - = "camlidl_z3_Z3_context_to_string" - -external statistics_to_string : context -> string - = "camlidl_z3_Z3_statistics_to_string" - -external get_context_assignment : context -> ast - = "camlidl_z3_Z3_get_context_assignment" - -external parse_smtlib_string : context -> string -> symbol array -> sort array -> symbol array -> func_decl array -> unit - = "camlidl_z3_Z3_parse_smtlib_string_bytecode" "camlidl_z3_Z3_parse_smtlib_string" - -external parse_smtlib_file : context -> string -> symbol array -> sort array -> symbol array -> func_decl array -> unit - = "camlidl_z3_Z3_parse_smtlib_file_bytecode" "camlidl_z3_Z3_parse_smtlib_file" - -external get_smtlib_num_formulas : context -> int - = "camlidl_z3_Z3_get_smtlib_num_formulas" - -external get_smtlib_formula : context -> int -> ast - = "camlidl_z3_Z3_get_smtlib_formula" - -external get_smtlib_num_assumptions : context -> int - = "camlidl_z3_Z3_get_smtlib_num_assumptions" - -external get_smtlib_assumption : context -> int -> ast - = "camlidl_z3_Z3_get_smtlib_assumption" - -external get_smtlib_num_decls : context -> int - = "camlidl_z3_Z3_get_smtlib_num_decls" - -external get_smtlib_decl : context -> int -> func_decl - = "camlidl_z3_Z3_get_smtlib_decl" - -external get_smtlib_num_sorts : context -> int - = "camlidl_z3_Z3_get_smtlib_num_sorts" - -external get_smtlib_sort : context -> int -> sort - = "camlidl_z3_Z3_get_smtlib_sort" - -external get_smtlib_error : context -> string - = "camlidl_z3_Z3_get_smtlib_error" - -external parse_z3_string : context -> string -> ast - = "camlidl_z3_Z3_parse_z3_string" - -external parse_z3_file : context -> string -> ast - = "camlidl_z3_Z3_parse_z3_file" - -external parse_smtlib2_string : context -> string -> symbol array -> sort array -> symbol array -> func_decl array -> ast - = "camlidl_z3_Z3_parse_smtlib2_string_bytecode" "camlidl_z3_Z3_parse_smtlib2_string" - -external parse_smtlib2_file : context -> string -> symbol array -> sort array -> symbol array -> func_decl array -> ast - = "camlidl_z3_Z3_parse_smtlib2_file_bytecode" "camlidl_z3_Z3_parse_smtlib2_file" - -external get_version : unit -> int * int * int * int - = "camlidl_z3_Z3_get_version" - -external reset_memory : unit -> unit - = "camlidl_z3_Z3_reset_memory" - -external theory_mk_sort : context -> theory -> symbol -> sort - = "camlidl_z3_Z3_theory_mk_sort" - -external theory_mk_value : context -> theory -> symbol -> sort -> ast - = "camlidl_z3_Z3_theory_mk_value" - -external theory_mk_constant : context -> theory -> symbol -> sort -> ast - = "camlidl_z3_Z3_theory_mk_constant" - -external theory_mk_func_decl : context -> theory -> symbol -> sort array -> sort -> func_decl - = "camlidl_z3_Z3_theory_mk_func_decl" - -external theory_get_context : theory -> context - = "camlidl_z3_Z3_theory_get_context" - -external theory_assert_axiom : theory -> ast -> unit - = "camlidl_z3_Z3_theory_assert_axiom" - -external theory_assume_eq : theory -> ast -> ast -> unit - = "camlidl_z3_Z3_theory_assume_eq" - -external theory_enable_axiom_simplification : theory -> bool -> unit - = "camlidl_z3_Z3_theory_enable_axiom_simplification" - -external theory_get_eqc_root : theory -> ast -> ast - = "camlidl_z3_Z3_theory_get_eqc_root" - -external theory_get_eqc_next : theory -> ast -> ast - = "camlidl_z3_Z3_theory_get_eqc_next" - -external theory_get_num_parents : theory -> ast -> int - = "camlidl_z3_Z3_theory_get_num_parents" - -external theory_get_parent : theory -> ast -> int -> ast - = "camlidl_z3_Z3_theory_get_parent" - -external theory_is_value : theory -> ast -> bool - = "camlidl_z3_Z3_theory_is_value" - -external theory_is_decl : theory -> func_decl -> bool - = "camlidl_z3_Z3_theory_is_decl" - -external theory_get_num_elems : theory -> int - = "camlidl_z3_Z3_theory_get_num_elems" - -external theory_get_elem : theory -> int -> ast - = "camlidl_z3_Z3_theory_get_elem" - -external theory_get_num_apps : theory -> int - = "camlidl_z3_Z3_theory_get_num_apps" - -external theory_get_app : theory -> int -> ast - = "camlidl_z3_Z3_theory_get_app" - -external datalog_add_rule : context -> ast -> symbol -> unit - = "camlidl_z3_Z3_datalog_add_rule" - -external datalog_query : context -> ast -> ast - = "camlidl_z3_Z3_datalog_query" - -external datalog_set_predicate_representation : context -> func_decl -> symbol array -> unit - = "camlidl_z3_Z3_datalog_set_predicate_representation" - -external datalog_parse_file : context -> string -> unit - = "camlidl_z3_Z3_datalog_parse_file" - - - - -(* Internal auxillary functions: *) - -(* Transform a pair of arrays into an array of pairs *) -let array_combine a b = - if Array.length a <> Array.length b then raise (Invalid_argument "array_combine"); - Array.init (Array.length a) (fun i->(a.(i),b.(i)));; - -(* [a |> b] is the pipeline operator for [b(a)] *) -let ( |> ) x f = f x;; - - -(* Extensions, except for refinement: *) -let mk_context_x configs = - let config = mk_config() in - let f(param_id,param_value) = set_param_value config param_id param_value in - Array.iter f configs; - let context = mk_context config in - del_config config; - context;; - -let get_app_args c a = - Array.init (get_app_num_args c a) (get_app_arg c a);; - -let get_domains c d = - Array.init (get_domain_size c d) (get_domain c d);; - -let get_array_sort c t = (get_array_sort_domain c t, get_array_sort_range c t);; - -let get_tuple_sort c ty = - (get_tuple_sort_mk_decl c ty, - Array.init (get_tuple_sort_num_fields c ty) (get_tuple_sort_field_decl c ty));; - -type datatype_constructor_refined = { - constructor : func_decl; - recognizer : func_decl; - accessors : func_decl array -} - -let get_datatype_sort c ty = - Array.init (get_datatype_sort_num_constructors c ty) - (fun idx_c -> - let constr = get_datatype_sort_constructor c ty idx_c in - let recog = get_datatype_sort_recognizer c ty idx_c in - let num_acc = get_domain_size c constr in - { constructor = constr; - recognizer = recog; - accessors = Array.init num_acc (get_datatype_sort_constructor_accessor c ty idx_c); - }) - -let get_model_constants c m = - Array.init (get_model_num_constants c m) (get_model_constant c m);; - - -let get_model_func_entry c m i j = - (Array.init - (get_model_func_entry_num_args c m i j) - (get_model_func_entry_arg c m i j), - get_model_func_entry_value c m i j);; - -let get_model_func_entries c m i = - Array.init (get_model_func_num_entries c m i) (get_model_func_entry c m i);; - -let get_model_funcs c m = - Array.init (get_model_num_funcs c m) - (fun i->(get_model_func_decl c m i |> get_decl_name c, - get_model_func_entries c m i, - get_model_func_else c m i));; - -let get_smtlib_formulas c = - Array.init (get_smtlib_num_formulas c) (get_smtlib_formula c);; - -let get_smtlib_assumptions c = - Array.init (get_smtlib_num_assumptions c) (get_smtlib_assumption c);; - -let get_smtlib_decls c = - Array.init (get_smtlib_num_decls c) (get_smtlib_decl c);; - -let get_smtlib_parse_results c = - (get_smtlib_formulas c, get_smtlib_assumptions c, get_smtlib_decls c);; - -let parse_smtlib_string_formula c a1 a2 a3 a4 a5 = - (parse_smtlib_string c a1 a2 a3 a4 a5; - match get_smtlib_formulas c with [|f|] -> f | _ -> failwith "Z3: parse_smtlib_string_formula");; - -let parse_smtlib_file_formula c a1 a2 a3 a4 a5 = - (parse_smtlib_file c a1 a2 a3 a4 a5; - match get_smtlib_formulas c with [|f|] -> f | _ -> failwith "Z3: parse_smtlib_file_formula");; - -let parse_smtlib_string_x c a1 a2 a3 a4 a5 = - (parse_smtlib_string c a1 a2 a3 a4 a5; get_smtlib_parse_results c);; - -let parse_smtlib_file_x c a1 a2 a3 a4 a5 = - (parse_smtlib_file c a1 a2 a3 a4 a5; get_smtlib_parse_results c);; - -(* Refinement: *) - -type symbol_refined = - | Symbol_int of int - | Symbol_string of string - | Symbol_unknown;; - -let symbol_refine c s = - match get_symbol_kind c s with - | INT_SYMBOL -> Symbol_int (get_symbol_int c s) - | STRING_SYMBOL -> Symbol_string (get_symbol_string c s);; - -type sort_refined = - | Sort_uninterpreted of symbol - | Sort_bool - | Sort_int - | Sort_real - | Sort_bv of int - | Sort_array of (sort * sort) - | Sort_datatype of datatype_constructor_refined array - | Sort_relation - | Sort_finite_domain - | Sort_unknown of symbol;; - -let sort_refine c ty = - match get_sort_kind c ty with - | UNINTERPRETED_SORT -> Sort_uninterpreted (get_sort_name c ty) - | BOOL_SORT -> Sort_bool - | INT_SORT -> Sort_int - | REAL_SORT -> Sort_real - | BV_SORT -> Sort_bv (get_bv_sort_size c ty) - | ARRAY_SORT -> Sort_array (get_array_sort_domain c ty, get_array_sort_range c ty) - | DATATYPE_SORT -> Sort_datatype (get_datatype_sort c ty) - | RELATION_SORT -> Sort_relation - | FINITE_DOMAIN_SORT -> Sort_finite_domain - | UNKNOWN_SORT -> Sort_unknown (get_sort_name c ty);; - -let get_pattern_terms c p = - Array.init (get_pattern_num_terms c p) (get_pattern c p) - -type binder_type = | Forall | Exists - -type numeral_refined = - | Numeral_small of int64 * int64 - | Numeral_large of string - -type term_refined = - | Term_app of decl_kind * func_decl * ast array - | Term_quantifier of binder_type * int * ast array array * (symbol *sort) array * ast - | Term_numeral of numeral_refined * sort - | Term_var of int * sort - -let term_refine c t = - match get_ast_kind c t with - | NUMERAL_AST -> - let (is_small, n, d) = get_numeral_small c t in - if is_small then - Term_numeral(Numeral_small(n,d), get_sort c t) - else - Term_numeral(Numeral_large(get_numeral_string c t), get_sort c t) - | APP_AST -> - let t' = to_app c t in - let f = get_app_decl c t' in - let num_args = get_app_num_args c t' in - let args = Array.init num_args (get_app_arg c t') in - let k = get_decl_kind c f in - Term_app (k, f, args) - | QUANTIFIER_AST -> - let bt = if is_quantifier_forall c t then Forall else Exists in - let w = get_quantifier_weight c t in - let np = get_quantifier_num_patterns c t in - let pats = Array.init np (get_quantifier_pattern_ast c t) in - let pats = Array.map (get_pattern_terms c) pats in - let nb = get_quantifier_num_bound c t in - let bound = Array.init nb - (fun i -> (get_quantifier_bound_name c t i, get_quantifier_bound_sort c t i)) in - let body = get_quantifier_body c t in - Term_quantifier(bt, w, pats, bound, body) - | VAR_AST -> - Term_var(get_index_value c t, get_sort c t) - | _ -> assert false - - -type theory_callbacks = - { - mutable delete_theory : unit -> unit; - mutable reduce_eq : ast -> ast -> ast option; - mutable reduce_app : func_decl -> ast array -> ast option; - mutable reduce_distinct : ast array -> ast option; - mutable final_check : unit -> bool; - mutable new_app : ast -> unit; - mutable new_elem : ast -> unit; - mutable init_search: unit -> unit; - mutable push: unit -> unit; - mutable pop: unit -> unit; - mutable restart : unit -> unit; - mutable reset: unit -> unit; - mutable new_eq : ast -> ast -> unit; - mutable new_diseq : ast -> ast -> unit; - mutable new_assignment: ast -> bool -> unit; - mutable new_relevant : ast -> unit; - } - -let mk_theory_callbacks() = - { - delete_theory = (fun () -> ()); - reduce_eq = (fun _ _ -> None); - reduce_app = (fun _ _ -> None); - reduce_distinct = (fun _ -> None); - final_check = (fun _ -> true); - new_app = (fun _ -> ()); - new_elem = (fun _ -> ()); - init_search= (fun () -> ()); - push= (fun () -> ()); - pop= (fun () -> ()); - restart = (fun () -> ()); - reset= (fun () -> ()); - new_eq = (fun _ _ -> ()); - new_diseq = (fun _ _ -> ()); - new_assignment = (fun _ _ -> ()); - new_relevant = (fun _ -> ()); - } - - -external get_theory_callbacks : theory -> theory_callbacks = "get_theory_callbacks" -external mk_theory_register : context -> string -> theory_callbacks -> theory = "mk_theory_register" -external set_delete_callback_register : theory -> unit = "set_delete_callback_register" -external set_reduce_app_callback_register : theory -> unit = "set_reduce_app_callback_register" -external set_reduce_eq_callback_register : theory -> unit = "set_reduce_eq_callback_register" -external set_reduce_distinct_callback_register : theory -> unit = "set_reduce_distinct_callback_register" -external set_new_app_callback_register : theory -> unit = "set_new_app_callback_register" -external set_new_elem_callback_register : theory -> unit = "set_new_elem_callback_register" -external set_init_search_callback_register : theory -> unit = "set_init_search_callback_register" -external set_push_callback_register : theory -> unit = "set_push_callback_register" -external set_pop_callback_register : theory -> unit = "set_pop_callback_register" -external set_restart_callback_register : theory -> unit = "set_restart_callback_register" -external set_reset_callback_register : theory -> unit = "set_reset_callback_register" -external set_final_check_callback_register : theory -> unit = "set_final_check_callback_register" -external set_new_eq_callback_register : theory -> unit = "set_new_eq_callback_register" -external set_new_diseq_callback_register : theory -> unit = "set_new_diseq_callback_register" -external set_new_assignment_callback_register : theory -> unit = "set_new_assignment_callback_register" -external set_new_relevant_callback_register : theory -> unit = "set_new_relevant_callback_register" - -let is_some opt = - match opt with - | Some v -> true - | None -> false - -let get_some opt = - match opt with - | Some v -> v - | None -> failwith "None unexpected" - - - - -let apply_delete (th:theory_callbacks) = th.delete_theory () -let set_delete_callback th cb = - let cbs = get_theory_callbacks th in - cbs.delete_theory <- cb; - set_delete_callback_register th - -let mk_theory context name = - Callback.register "is_some" is_some; - Callback.register "get_some" get_some; - Callback.register "apply_delete" apply_delete; - let cbs = mk_theory_callbacks() in - mk_theory_register context name cbs - - -let apply_reduce_app (th:theory_callbacks) f args = th.reduce_app f args -let set_reduce_app_callback th cb = - Callback.register "apply_reduce_app" apply_reduce_app; - let cbs = get_theory_callbacks th in - cbs.reduce_app <- cb; - set_reduce_app_callback_register th - -let apply_reduce_eq (th:theory_callbacks) a b = th.reduce_eq a b -let set_reduce_eq_callback th cb = - Callback.register "apply_reduce_eq" apply_reduce_eq; - let cbs = get_theory_callbacks th in - cbs.reduce_eq <- cb; - set_reduce_eq_callback_register th - -let apply_reduce_distinct (th:theory_callbacks) args = th.reduce_distinct args -let set_reduce_distinct_callback th cb = - Callback.register "apply_reduce_distinct" apply_reduce_distinct; - let cbs = get_theory_callbacks th in - cbs.reduce_distinct <- cb; - set_reduce_distinct_callback_register th - - -let apply_new_app (th:theory_callbacks) a = th.new_app a -let set_new_app_callback th cb = - Callback.register "apply_new_app" apply_new_app; - let cbs = get_theory_callbacks th in - cbs.new_app <- cb; - set_new_app_callback_register th - -let apply_new_elem (th:theory_callbacks) a = th.new_elem a -let set_new_elem_callback th cb = - Callback.register "apply_new_elem" apply_new_elem; - let cbs = get_theory_callbacks th in - cbs.new_elem <- cb; - set_new_elem_callback_register th - - -let apply_init_search (th:theory_callbacks) = th.init_search() -let set_init_search_callback th cb = - Callback.register "apply_init_search" apply_init_search; - let cbs = get_theory_callbacks th in - cbs.init_search <- cb; - set_init_search_callback_register th - - -let apply_push (th:theory_callbacks) = th.push() -let set_push_callback th cb = - Callback.register "apply_push" apply_push; - let cbs = get_theory_callbacks th in - cbs.push <- cb; - set_push_callback_register th - -let apply_pop (th:theory_callbacks) = th.pop() -let set_pop_callback th cb = - Callback.register "apply_pop" apply_pop; - let cbs = get_theory_callbacks th in - cbs.pop <- cb; - set_pop_callback_register th - - -let apply_restart (th:theory_callbacks) = th.restart() -let set_restart_callback th cb = - Callback.register "apply_restart" apply_restart; - let cbs = get_theory_callbacks th in - cbs.restart <- cb; - set_restart_callback_register th - - -let apply_reset (th:theory_callbacks) = th.reset() -let set_reset_callback th cb = - Callback.register "apply_reset" apply_reset; - let cbs = get_theory_callbacks th in - cbs.reset <- cb; - set_reset_callback_register th - -let apply_final_check (th:theory_callbacks) = th.final_check() -let set_final_check_callback th cb = - Callback.register "apply_final_check" apply_final_check; - let cbs = get_theory_callbacks th in - cbs.final_check <- cb; - set_final_check_callback_register th - -let apply_new_eq (th:theory_callbacks) a b = th.new_eq a b -let set_new_eq_callback th cb = - Callback.register "apply_new_eq" apply_new_eq; - let cbs = get_theory_callbacks th in - cbs.new_eq <- cb; - set_new_eq_callback_register th - - -let apply_new_diseq (th:theory_callbacks) a b = th.new_diseq a b -let set_new_diseq_callback th cb = - Callback.register "apply_new_diseq" apply_new_diseq; - let cbs = get_theory_callbacks th in - cbs.new_diseq <- cb; - set_new_diseq_callback_register th - -let apply_new_assignment (th:theory_callbacks) a b = th.new_assignment a b -let set_new_assignment_callback th cb = - Callback.register "apply_new_assignment" apply_new_assignment; - let cbs = get_theory_callbacks th in - cbs.new_assignment <- cb; - set_new_assignment_callback_register th - -let apply_new_relevant (th:theory_callbacks) a = th.new_relevant a -let set_new_relevant_callback th cb = - Callback.register "apply_new_relevant" apply_new_relevant; - let cbs = get_theory_callbacks th in - cbs.new_relevant <- cb; - set_new_relevant_callback_register th - - - - - diff --git a/external/z3/ocaml/z3_stubs.c b/external/z3/ocaml/z3_stubs.c deleted file mode 100644 --- a/external/z3/ocaml/z3_stubs.c +++ /dev/null @@ -1,7761 +0,0 @@ -/* File generated from z3.idl */ - -#include -#include -#include -#include -#include -#include -#include -#ifdef Custom_tag -#include -#include -#endif -#include - - -#include "z3.h" - -#pragma warning(disable:4090) -#ifndef __int64 -#define __int64 long long -#endif -Z3_error_handler caml_z3_error_handler; -void caml_z3_error_handler(Z3_error_code e) { static char buffer[128]; char * msg = Z3_get_error_msg(e); if (strlen(msg) > 100) { failwith("Z3: error message is too big"); } else { sprintf(buffer, "Z3: %s", msg); failwith(buffer); } } -void camlidl_ml2c_z3_Z3_config(value _v1, Z3_config * _c2, camlidl_ctx _ctx) -{ - *_c2 = *((Z3_config *) Bp_val(_v1)); -} - -value camlidl_c2ml_z3_Z3_config(Z3_config * _c2, camlidl_ctx _ctx) -{ -value _v1; - _v1 = camlidl_alloc((sizeof(Z3_config) + sizeof(value) - 1) / sizeof(value), Abstract_tag); - *((Z3_config *) Bp_val(_v1)) = *_c2; - return _v1; -} - -void camlidl_ml2c_z3_Z3_context(value _v1, Z3_context * _c2, camlidl_ctx _ctx) -{ - *_c2 = *((Z3_context *) Bp_val(_v1)); -} - -value camlidl_c2ml_z3_Z3_context(Z3_context * _c2, camlidl_ctx _ctx) -{ -value _v1; - _v1 = camlidl_alloc((sizeof(Z3_context) + sizeof(value) - 1) / sizeof(value), Abstract_tag); - *((Z3_context *) Bp_val(_v1)) = *_c2; - return _v1; -} - -void camlidl_ml2c_z3_Z3_sort(value _v1, Z3_sort * _c2, camlidl_ctx _ctx) -{ - *_c2 = *((Z3_sort *) Bp_val(_v1)); -} - -value camlidl_c2ml_z3_Z3_sort(Z3_sort * _c2, camlidl_ctx _ctx) -{ -value _v1; - _v1 = camlidl_alloc((sizeof(Z3_sort) + sizeof(value) - 1) / sizeof(value), Abstract_tag); - *((Z3_sort *) Bp_val(_v1)) = *_c2; - return _v1; -} - -void camlidl_ml2c_z3_Z3_func_decl(value _v1, Z3_func_decl * _c2, camlidl_ctx _ctx) -{ - *_c2 = *((Z3_func_decl *) Bp_val(_v1)); -} - -value camlidl_c2ml_z3_Z3_func_decl(Z3_func_decl * _c2, camlidl_ctx _ctx) -{ -value _v1; - _v1 = camlidl_alloc((sizeof(Z3_func_decl) + sizeof(value) - 1) / sizeof(value), Abstract_tag); - *((Z3_func_decl *) Bp_val(_v1)) = *_c2; - return _v1; -} - -void camlidl_ml2c_z3_Z3_ast(value _v1, Z3_ast * _c2, camlidl_ctx _ctx) -{ - *_c2 = *((Z3_ast *) Bp_val(_v1)); -} - -value camlidl_c2ml_z3_Z3_ast(Z3_ast * _c2, camlidl_ctx _ctx) -{ -value _v1; - _v1 = camlidl_alloc((sizeof(Z3_ast) + sizeof(value) - 1) / sizeof(value), Abstract_tag); - *((Z3_ast *) Bp_val(_v1)) = *_c2; - return _v1; -} - -void camlidl_ml2c_z3_Z3_app(value _v1, Z3_app * _c2, camlidl_ctx _ctx) -{ - *_c2 = *((Z3_app *) Bp_val(_v1)); -} - -value camlidl_c2ml_z3_Z3_app(Z3_app * _c2, camlidl_ctx _ctx) -{ -value _v1; - _v1 = camlidl_alloc((sizeof(Z3_app) + sizeof(value) - 1) / sizeof(value), Abstract_tag); - *((Z3_app *) Bp_val(_v1)) = *_c2; - return _v1; -} - -void camlidl_ml2c_z3_Z3_pattern(value _v1, Z3_pattern * _c2, camlidl_ctx _ctx) -{ - *_c2 = *((Z3_pattern *) Bp_val(_v1)); -} - -value camlidl_c2ml_z3_Z3_pattern(Z3_pattern * _c2, camlidl_ctx _ctx) -{ -value _v1; - _v1 = camlidl_alloc((sizeof(Z3_pattern) + sizeof(value) - 1) / sizeof(value), Abstract_tag); - *((Z3_pattern *) Bp_val(_v1)) = *_c2; - return _v1; -} - -void camlidl_ml2c_z3_Z3_symbol(value _v1, Z3_symbol * _c2, camlidl_ctx _ctx) -{ - *_c2 = *((Z3_symbol *) Bp_val(_v1)); -} - -value camlidl_c2ml_z3_Z3_symbol(Z3_symbol * _c2, camlidl_ctx _ctx) -{ -value _v1; - _v1 = camlidl_alloc((sizeof(Z3_symbol) + sizeof(value) - 1) / sizeof(value), Abstract_tag); - *((Z3_symbol *) Bp_val(_v1)) = *_c2; - return _v1; -} - -void camlidl_ml2c_z3_Z3_parameter(value _v1, Z3_parameter * _c2, camlidl_ctx _ctx) -{ - *_c2 = *((Z3_parameter *) Bp_val(_v1)); -} - -value camlidl_c2ml_z3_Z3_parameter(Z3_parameter * _c2, camlidl_ctx _ctx) -{ -value _v1; - _v1 = camlidl_alloc((sizeof(Z3_parameter) + sizeof(value) - 1) / sizeof(value), Abstract_tag); - *((Z3_parameter *) Bp_val(_v1)) = *_c2; - return _v1; -} - -void camlidl_ml2c_z3_Z3_model(value _v1, Z3_model * _c2, camlidl_ctx _ctx) -{ - *_c2 = *((Z3_model *) Bp_val(_v1)); -} - -value camlidl_c2ml_z3_Z3_model(Z3_model * _c2, camlidl_ctx _ctx) -{ -value _v1; - _v1 = camlidl_alloc((sizeof(Z3_model) + sizeof(value) - 1) / sizeof(value), Abstract_tag); - *((Z3_model *) Bp_val(_v1)) = *_c2; - return _v1; -} - -void camlidl_ml2c_z3_Z3_literals(value _v1, Z3_literals * _c2, camlidl_ctx _ctx) -{ - *_c2 = *((Z3_literals *) Bp_val(_v1)); -} - -value camlidl_c2ml_z3_Z3_literals(Z3_literals * _c2, camlidl_ctx _ctx) -{ -value _v1; - _v1 = camlidl_alloc((sizeof(Z3_literals) + sizeof(value) - 1) / sizeof(value), Abstract_tag); - *((Z3_literals *) Bp_val(_v1)) = *_c2; - return _v1; -} - -void camlidl_ml2c_z3_Z3_constructor(value _v1, Z3_constructor * _c2, camlidl_ctx _ctx) -{ - *_c2 = *((Z3_constructor *) Bp_val(_v1)); -} - -value camlidl_c2ml_z3_Z3_constructor(Z3_constructor * _c2, camlidl_ctx _ctx) -{ -value _v1; - _v1 = camlidl_alloc((sizeof(Z3_constructor) + sizeof(value) - 1) / sizeof(value), Abstract_tag); - *((Z3_constructor *) Bp_val(_v1)) = *_c2; - return _v1; -} - -void camlidl_ml2c_z3_Z3_constructor_list(value _v1, Z3_constructor_list * _c2, camlidl_ctx _ctx) -{ - *_c2 = *((Z3_constructor_list *) Bp_val(_v1)); -} - -value camlidl_c2ml_z3_Z3_constructor_list(Z3_constructor_list * _c2, camlidl_ctx _ctx) -{ -value _v1; - _v1 = camlidl_alloc((sizeof(Z3_constructor_list) + sizeof(value) - 1) / sizeof(value), Abstract_tag); - *((Z3_constructor_list *) Bp_val(_v1)) = *_c2; - return _v1; -} - -void camlidl_ml2c_z3_Z3_theory(value _v1, Z3_theory * _c2, camlidl_ctx _ctx) -{ - *_c2 = *((Z3_theory *) Bp_val(_v1)); -} - -value camlidl_c2ml_z3_Z3_theory(Z3_theory * _c2, camlidl_ctx _ctx) -{ -value _v1; - _v1 = camlidl_alloc((sizeof(Z3_theory) + sizeof(value) - 1) / sizeof(value), Abstract_tag); - *((Z3_theory *) Bp_val(_v1)) = *_c2; - return _v1; -} - -void camlidl_ml2c_z3_Z3_theory_data(value _v1, Z3_theory_data * _c2, camlidl_ctx _ctx) -{ - *_c2 = *((Z3_theory_data *) Bp_val(_v1)); -} - -value camlidl_c2ml_z3_Z3_theory_data(Z3_theory_data * _c2, camlidl_ctx _ctx) -{ -value _v1; - _v1 = camlidl_alloc((sizeof(Z3_theory_data) + sizeof(value) - 1) / sizeof(value), Abstract_tag); - *((Z3_theory_data *) Bp_val(_v1)) = *_c2; - return _v1; -} - -int camlidl_transl_table_z3_enum_1[3] = { - Z3_L_FALSE, - Z3_L_UNDEF, - Z3_L_TRUE, -}; - -void camlidl_ml2c_z3_Z3_lbool(value _v1, Z3_lbool * _c2, camlidl_ctx _ctx) -{ - (*_c2) = camlidl_transl_table_z3_enum_1[Int_val(_v1)]; -} - -value camlidl_c2ml_z3_Z3_lbool(Z3_lbool * _c2, camlidl_ctx _ctx) -{ -value _v1; - switch((*_c2)) { - case Z3_L_FALSE: _v1 = Val_int(0); break; - case Z3_L_UNDEF: _v1 = Val_int(1); break; - case Z3_L_TRUE: _v1 = Val_int(2); break; - default: invalid_argument("typedef Z3_lbool: bad enum value"); - } - return _v1; -} - -int camlidl_transl_table_z3_enum_2[2] = { - Z3_INT_SYMBOL, - Z3_STRING_SYMBOL, -}; - -void camlidl_ml2c_z3_Z3_symbol_kind(value _v1, Z3_symbol_kind * _c2, camlidl_ctx _ctx) -{ - (*_c2) = camlidl_transl_table_z3_enum_2[Int_val(_v1)]; -} - -value camlidl_c2ml_z3_Z3_symbol_kind(Z3_symbol_kind * _c2, camlidl_ctx _ctx) -{ -value _v1; - switch((*_c2)) { - case Z3_INT_SYMBOL: _v1 = Val_int(0); break; - case Z3_STRING_SYMBOL: _v1 = Val_int(1); break; - default: invalid_argument("typedef Z3_symbol_kind: bad enum value"); - } - return _v1; -} - -int camlidl_transl_table_z3_enum_3[7] = { - Z3_PARAMETER_INT, - Z3_PARAMETER_DOUBLE, - Z3_PARAMETER_RATIONAL, - Z3_PARAMETER_SYMBOL, - Z3_PARAMETER_SORT, - Z3_PARAMETER_AST, - Z3_PARAMETER_FUNC_DECL, -}; - -void camlidl_ml2c_z3_Z3_parameter_kind(value _v1, Z3_parameter_kind * _c2, camlidl_ctx _ctx) -{ - (*_c2) = camlidl_transl_table_z3_enum_3[Int_val(_v1)]; -} - -value camlidl_c2ml_z3_Z3_parameter_kind(Z3_parameter_kind * _c2, camlidl_ctx _ctx) -{ -value _v1; - _v1 = camlidl_find_enum((*_c2), camlidl_transl_table_z3_enum_3, 7, "typedef Z3_parameter_kind: bad enum value"); - return _v1; -} - -int camlidl_transl_table_z3_enum_4[10] = { - Z3_UNINTERPRETED_SORT, - Z3_BOOL_SORT, - Z3_INT_SORT, - Z3_REAL_SORT, - Z3_BV_SORT, - Z3_ARRAY_SORT, - Z3_DATATYPE_SORT, - Z3_RELATION_SORT, - Z3_FINITE_DOMAIN_SORT, - Z3_UNKNOWN_SORT, -}; - -void camlidl_ml2c_z3_Z3_sort_kind(value _v1, Z3_sort_kind * _c2, camlidl_ctx _ctx) -{ - (*_c2) = camlidl_transl_table_z3_enum_4[Int_val(_v1)]; -} - -value camlidl_c2ml_z3_Z3_sort_kind(Z3_sort_kind * _c2, camlidl_ctx _ctx) -{ -value _v1; - _v1 = camlidl_find_enum((*_c2), camlidl_transl_table_z3_enum_4, 10, "typedef Z3_sort_kind: bad enum value"); - return _v1; -} - -int camlidl_transl_table_z3_enum_5[5] = { - Z3_NUMERAL_AST, - Z3_APP_AST, - Z3_VAR_AST, - Z3_QUANTIFIER_AST, - Z3_UNKNOWN_AST, -}; - -void camlidl_ml2c_z3_Z3_ast_kind(value _v1, Z3_ast_kind * _c2, camlidl_ctx _ctx) -{ - (*_c2) = camlidl_transl_table_z3_enum_5[Int_val(_v1)]; -} - -value camlidl_c2ml_z3_Z3_ast_kind(Z3_ast_kind * _c2, camlidl_ctx _ctx) -{ -value _v1; - _v1 = camlidl_find_enum((*_c2), camlidl_transl_table_z3_enum_5, 5, "typedef Z3_ast_kind: bad enum value"); - return _v1; -} - -int camlidl_transl_table_z3_enum_6[144] = { - Z3_OP_TRUE, - Z3_OP_FALSE, - Z3_OP_EQ, - Z3_OP_DISTINCT, - Z3_OP_ITE, - Z3_OP_AND, - Z3_OP_OR, - Z3_OP_IFF, - Z3_OP_XOR, - Z3_OP_NOT, - Z3_OP_IMPLIES, - Z3_OP_OEQ, - Z3_OP_ANUM, - Z3_OP_LE, - Z3_OP_GE, - Z3_OP_LT, - Z3_OP_GT, - Z3_OP_ADD, - Z3_OP_SUB, - Z3_OP_UMINUS, - Z3_OP_MUL, - Z3_OP_DIV, - Z3_OP_IDIV, - Z3_OP_REM, - Z3_OP_MOD, - Z3_OP_TO_REAL, - Z3_OP_TO_INT, - Z3_OP_IS_INT, - Z3_OP_STORE, - Z3_OP_SELECT, - Z3_OP_CONST_ARRAY, - Z3_OP_ARRAY_MAP, - Z3_OP_ARRAY_DEFAULT, - Z3_OP_SET_UNION, - Z3_OP_SET_INTERSECT, - Z3_OP_SET_DIFFERENCE, - Z3_OP_SET_COMPLEMENT, - Z3_OP_SET_SUBSET, - Z3_OP_AS_ARRAY, - Z3_OP_BNUM, - Z3_OP_BIT1, - Z3_OP_BIT0, - Z3_OP_BNEG, - Z3_OP_BADD, - Z3_OP_BSUB, - Z3_OP_BMUL, - Z3_OP_BSDIV, - Z3_OP_BUDIV, - Z3_OP_BSREM, - Z3_OP_BUREM, - Z3_OP_BSMOD, - Z3_OP_BSDIV0, - Z3_OP_BUDIV0, - Z3_OP_BSREM0, - Z3_OP_BUREM0, - Z3_OP_BSMOD0, - Z3_OP_ULEQ, - Z3_OP_SLEQ, - Z3_OP_UGEQ, - Z3_OP_SGEQ, - Z3_OP_ULT, - Z3_OP_SLT, - Z3_OP_UGT, - Z3_OP_SGT, - Z3_OP_BAND, - Z3_OP_BOR, - Z3_OP_BNOT, - Z3_OP_BXOR, - Z3_OP_BNAND, - Z3_OP_BNOR, - Z3_OP_BXNOR, - Z3_OP_CONCAT, - Z3_OP_SIGN_EXT, - Z3_OP_ZERO_EXT, - Z3_OP_EXTRACT, - Z3_OP_REPEAT, - Z3_OP_BREDOR, - Z3_OP_BREDAND, - Z3_OP_BCOMP, - Z3_OP_BSHL, - Z3_OP_BLSHR, - Z3_OP_BASHR, - Z3_OP_ROTATE_LEFT, - Z3_OP_ROTATE_RIGHT, - Z3_OP_EXT_ROTATE_LEFT, - Z3_OP_EXT_ROTATE_RIGHT, - Z3_OP_INT2BV, - Z3_OP_BV2INT, - Z3_OP_CARRY, - Z3_OP_XOR3, - Z3_OP_PR_UNDEF, - Z3_OP_PR_TRUE, - Z3_OP_PR_ASSERTED, - Z3_OP_PR_GOAL, - Z3_OP_PR_MODUS_PONENS, - Z3_OP_PR_REFLEXIVITY, - Z3_OP_PR_SYMMETRY, - Z3_OP_PR_TRANSITIVITY, - Z3_OP_PR_TRANSITIVITY_STAR, - Z3_OP_PR_MONOTONICITY, - Z3_OP_PR_QUANT_INTRO, - Z3_OP_PR_DISTRIBUTIVITY, - Z3_OP_PR_AND_ELIM, - Z3_OP_PR_NOT_OR_ELIM, - Z3_OP_PR_REWRITE, - Z3_OP_PR_REWRITE_STAR, - Z3_OP_PR_PULL_QUANT, - Z3_OP_PR_PULL_QUANT_STAR, - Z3_OP_PR_PUSH_QUANT, - Z3_OP_PR_ELIM_UNUSED_VARS, - Z3_OP_PR_DER, - Z3_OP_PR_QUANT_INST, - Z3_OP_PR_HYPOTHESIS, - Z3_OP_PR_LEMMA, - Z3_OP_PR_UNIT_RESOLUTION, - Z3_OP_PR_IFF_TRUE, - Z3_OP_PR_IFF_FALSE, - Z3_OP_PR_COMMUTATIVITY, - Z3_OP_PR_DEF_AXIOM, - Z3_OP_PR_DEF_INTRO, - Z3_OP_PR_APPLY_DEF, - Z3_OP_PR_IFF_OEQ, - Z3_OP_PR_NNF_POS, - Z3_OP_PR_NNF_NEG, - Z3_OP_PR_NNF_STAR, - Z3_OP_PR_CNF_STAR, - Z3_OP_PR_SKOLEMIZE, - Z3_OP_PR_MODUS_PONENS_OEQ, - Z3_OP_PR_TH_LEMMA, - Z3_OP_RA_STORE, - Z3_OP_RA_EMPTY, - Z3_OP_RA_IS_EMPTY, - Z3_OP_RA_JOIN, - Z3_OP_RA_UNION, - Z3_OP_RA_WIDEN, - Z3_OP_RA_PROJECT, - Z3_OP_RA_FILTER, - Z3_OP_RA_NEGATION_FILTER, - Z3_OP_RA_RENAME, - Z3_OP_RA_COMPLEMENT, - Z3_OP_RA_SELECT, - Z3_OP_RA_CLONE, - Z3_OP_FD_LT, - Z3_OP_UNINTERPRETED, -}; - -void camlidl_ml2c_z3_Z3_decl_kind(value _v1, Z3_decl_kind * _c2, camlidl_ctx _ctx) -{ - (*_c2) = camlidl_transl_table_z3_enum_6[Int_val(_v1)]; -} - -value camlidl_c2ml_z3_Z3_decl_kind(Z3_decl_kind * _c2, camlidl_ctx _ctx) -{ -value _v1; - _v1 = camlidl_find_enum((*_c2), camlidl_transl_table_z3_enum_6, 144, "typedef Z3_decl_kind: bad enum value"); - return _v1; -} - -int camlidl_transl_table_z3_enum_7[8] = { - Z3_NO_FAILURE, - Z3_UNKNOWN, - Z3_TIMEOUT, - Z3_MEMOUT_WATERMARK, - Z3_CANCELED, - Z3_NUM_CONFLICTS, - Z3_THEORY, - Z3_QUANTIFIERS, -}; - -void camlidl_ml2c_z3_Z3_search_failure(value _v1, Z3_search_failure * _c2, camlidl_ctx _ctx) -{ - (*_c2) = camlidl_transl_table_z3_enum_7[Int_val(_v1)]; -} - -value camlidl_c2ml_z3_Z3_search_failure(Z3_search_failure * _c2, camlidl_ctx _ctx) -{ -value _v1; - _v1 = camlidl_find_enum((*_c2), camlidl_transl_table_z3_enum_7, 8, "typedef Z3_search_failure: bad enum value"); - return _v1; -} - -int camlidl_transl_table_z3_enum_8[4] = { - Z3_PRINT_SMTLIB_FULL, - Z3_PRINT_LOW_LEVEL, - Z3_PRINT_SMTLIB_COMPLIANT, - Z3_PRINT_SMTLIB2_COMPLIANT, -}; - -void camlidl_ml2c_z3_Z3_ast_print_mode(value _v1, Z3_ast_print_mode * _c2, camlidl_ctx _ctx) -{ - (*_c2) = camlidl_transl_table_z3_enum_8[Int_val(_v1)]; -} - -value camlidl_c2ml_z3_Z3_ast_print_mode(Z3_ast_print_mode * _c2, camlidl_ctx _ctx) -{ -value _v1; - switch((*_c2)) { - case Z3_PRINT_SMTLIB_FULL: _v1 = Val_int(0); break; - case Z3_PRINT_LOW_LEVEL: _v1 = Val_int(1); break; - case Z3_PRINT_SMTLIB_COMPLIANT: _v1 = Val_int(2); break; - case Z3_PRINT_SMTLIB2_COMPLIANT: _v1 = Val_int(3); break; - default: invalid_argument("typedef Z3_ast_print_mode: bad enum value"); - } - return _v1; -} - -value camlidl_z3_Z3_mk_config(value _unit) -{ - Z3_config _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - _res = Z3_mk_config(); - _vres = camlidl_c2ml_z3_Z3_config(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_del_config( - value _v_c) -{ - Z3_config c; /*in*/ - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_config(_v_c, &c, _ctx); - Z3_del_config(c); - camlidl_free(_ctx); - return Val_unit; -} - -value camlidl_z3_Z3_set_param_value( - value _v_c, - value _v_param_id, - value _v_param_value) -{ - Z3_config c; /*in*/ - char const *param_id; /*in*/ - char const *param_value; /*in*/ - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_config(_v_c, &c, _ctx); - param_id = String_val(_v_param_id); - param_value = String_val(_v_param_value); - Z3_set_param_value(c, param_id, param_value); - camlidl_free(_ctx); - return Val_unit; -} - -value camlidl_z3_Z3_mk_context( - value _v_c) -{ - Z3_config c; /*in*/ - Z3_context _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_config(_v_c, &c, _ctx); - _res = Z3_mk_context(c); - _vres = camlidl_c2ml_z3_Z3_context(&_res, _ctx); - camlidl_free(_ctx); - /* begin user-supplied deallocation sequence */ -Z3_set_error_handler(_res, caml_z3_error_handler); - /* end user-supplied deallocation sequence */ - return _vres; -} - -value camlidl_z3_Z3_mk_context_rc( - value _v_c) -{ - Z3_config c; /*in*/ - Z3_context _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_config(_v_c, &c, _ctx); - _res = Z3_mk_context_rc(c); - _vres = camlidl_c2ml_z3_Z3_context(&_res, _ctx); - camlidl_free(_ctx); - /* begin user-supplied deallocation sequence */ -Z3_set_error_handler(_res, caml_z3_error_handler); - /* end user-supplied deallocation sequence */ - return _vres; -} - -value camlidl_z3_Z3_set_logic( - value _v_c, - value _v_logic) -{ - Z3_context c; /*in*/ - char const *logic; /*in*/ - int _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - logic = String_val(_v_logic); - _res = Z3_set_logic(c, logic); - _vres = Val_int(_res); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_del_context( - value _v_c) -{ - Z3_context c; /*in*/ - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - Z3_del_context(c); - camlidl_free(_ctx); - return Val_unit; -} - -value camlidl_z3_Z3_inc_ref( - value _v_c, - value _v_a) -{ - Z3_context c; /*in*/ - Z3_ast a; /*in*/ - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_a, &a, _ctx); - Z3_inc_ref(c, a); - camlidl_free(_ctx); - return Val_unit; -} - -value camlidl_z3_Z3_dec_ref( - value _v_c, - value _v_a) -{ - Z3_context c; /*in*/ - Z3_ast a; /*in*/ - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_a, &a, _ctx); - Z3_dec_ref(c, a); - camlidl_free(_ctx); - return Val_unit; -} - -value camlidl_z3_Z3_trace_to_file( - value _v_c, - value _v_trace_file) -{ - Z3_context c; /*in*/ - char const *trace_file; /*in*/ - int _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - trace_file = String_val(_v_trace_file); - _res = Z3_trace_to_file(c, trace_file); - _vres = Val_int(_res); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_trace_to_stderr( - value _v_c) -{ - Z3_context c; /*in*/ - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - Z3_trace_to_stderr(c); - camlidl_free(_ctx); - return Val_unit; -} - -value camlidl_z3_Z3_trace_to_stdout( - value _v_c) -{ - Z3_context c; /*in*/ - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - Z3_trace_to_stdout(c); - camlidl_free(_ctx); - return Val_unit; -} - -value camlidl_z3_Z3_trace_off( - value _v_c) -{ - Z3_context c; /*in*/ - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - Z3_trace_off(c); - camlidl_free(_ctx); - return Val_unit; -} - -value camlidl_z3_Z3_toggle_warning_messages( - value _v_enabled) -{ - int enabled; /*in*/ - enabled = Int_val(_v_enabled); - Z3_toggle_warning_messages(enabled); - return Val_unit; -} - -value camlidl_z3_Z3_update_param_value( - value _v_c, - value _v_param_id, - value _v_param_value) -{ - Z3_context c; /*in*/ - char const *param_id; /*in*/ - char const *param_value; /*in*/ - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - param_id = String_val(_v_param_id); - param_value = String_val(_v_param_value); - Z3_update_param_value(c, param_id, param_value); - camlidl_free(_ctx); - return Val_unit; -} - -value camlidl_z3_Z3_mk_int_symbol( - value _v_c, - value _v_i) -{ - Z3_context c; /*in*/ - int i; /*in*/ - Z3_symbol _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - i = Int_val(_v_i); - _res = Z3_mk_int_symbol(c, i); - _vres = camlidl_c2ml_z3_Z3_symbol(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_string_symbol( - value _v_c, - value _v_s) -{ - Z3_context c; /*in*/ - char const *s; /*in*/ - Z3_symbol _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - s = String_val(_v_s); - _res = Z3_mk_string_symbol(c, s); - _vres = camlidl_c2ml_z3_Z3_symbol(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_is_eq_sort( - value _v_c, - value _v_s1, - value _v_s2) -{ - Z3_context c; /*in*/ - Z3_sort s1; /*in*/ - Z3_sort s2; /*in*/ - int _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_sort(_v_s1, &s1, _ctx); - camlidl_ml2c_z3_Z3_sort(_v_s2, &s2, _ctx); - _res = Z3_is_eq_sort(c, s1, s2); - _vres = Val_int(_res); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_uninterpreted_sort( - value _v_c, - value _v_s) -{ - Z3_context c; /*in*/ - Z3_symbol s; /*in*/ - Z3_sort _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_symbol(_v_s, &s, _ctx); - _res = Z3_mk_uninterpreted_sort(c, s); - _vres = camlidl_c2ml_z3_Z3_sort(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_bool_sort( - value _v_c) -{ - Z3_context c; /*in*/ - Z3_sort _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - _res = Z3_mk_bool_sort(c); - _vres = camlidl_c2ml_z3_Z3_sort(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_int_sort( - value _v_c) -{ - Z3_context c; /*in*/ - Z3_sort _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - _res = Z3_mk_int_sort(c); - _vres = camlidl_c2ml_z3_Z3_sort(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_real_sort( - value _v_c) -{ - Z3_context c; /*in*/ - Z3_sort _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - _res = Z3_mk_real_sort(c); - _vres = camlidl_c2ml_z3_Z3_sort(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_bv_sort( - value _v_c, - value _v_sz) -{ - Z3_context c; /*in*/ - unsigned int sz; /*in*/ - Z3_sort _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - sz = Int_val(_v_sz); - _res = Z3_mk_bv_sort(c, sz); - _vres = camlidl_c2ml_z3_Z3_sort(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_array_sort( - value _v_c, - value _v_domain, - value _v_range) -{ - Z3_context c; /*in*/ - Z3_sort domain; /*in*/ - Z3_sort range; /*in*/ - Z3_sort _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_sort(_v_domain, &domain, _ctx); - camlidl_ml2c_z3_Z3_sort(_v_range, &range, _ctx); - _res = Z3_mk_array_sort(c, domain, range); - _vres = camlidl_c2ml_z3_Z3_sort(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_tuple_sort( - value _v_c, - value _v_mk_tuple_name, - value _v_field_names, - value _v_field_sorts) -{ - Z3_context c; /*in*/ - Z3_symbol mk_tuple_name; /*in*/ - unsigned int num_fields; /*in*/ - Z3_symbol const *field_names; /*in*/ - Z3_sort const *field_sorts; /*in*/ - Z3_func_decl *mk_tuple_decl; /*out*/ - Z3_func_decl *proj_decl; /*out*/ - Z3_sort _res; - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - mlsize_t _c1; - mlsize_t _c2; - value _v3; - mlsize_t _c4; - mlsize_t _c5; - value _v6; - Z3_func_decl _c7; - mlsize_t _c8; - value _v9; - value _vresult; - value _vres[3] = { 0, 0, 0, }; - - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_symbol(_v_mk_tuple_name, &mk_tuple_name, _ctx); - _c1 = Wosize_val(_v_field_names); - field_names = camlidl_malloc(_c1 * sizeof(Z3_symbol const ), _ctx); - for (_c2 = 0; _c2 < _c1; _c2++) { - _v3 = Field(_v_field_names, _c2); - camlidl_ml2c_z3_Z3_symbol(_v3, &field_names[_c2], _ctx); - } - num_fields = _c1; - _c4 = Wosize_val(_v_field_sorts); - field_sorts = camlidl_malloc(_c4 * sizeof(Z3_sort const ), _ctx); - for (_c5 = 0; _c5 < _c4; _c5++) { - _v6 = Field(_v_field_sorts, _c5); - camlidl_ml2c_z3_Z3_sort(_v6, &field_sorts[_c5], _ctx); - } - num_fields = _c4; - mk_tuple_decl = &_c7; - proj_decl = camlidl_malloc(num_fields * sizeof(Z3_func_decl ), _ctx); - _res = Z3_mk_tuple_sort(c, mk_tuple_name, num_fields, field_names, field_sorts, mk_tuple_decl, proj_decl); - Begin_roots_block(_vres, 3) - _vres[0] = camlidl_c2ml_z3_Z3_sort(&_res, _ctx); - _vres[1] = camlidl_c2ml_z3_Z3_func_decl(&*mk_tuple_decl, _ctx); - _vres[2] = camlidl_alloc(num_fields, 0); - Begin_root(_vres[2]) - for (_c8 = 0; _c8 < num_fields; _c8++) { - _v9 = camlidl_c2ml_z3_Z3_func_decl(&proj_decl[_c8], _ctx); - modify(&Field(_vres[2], _c8), _v9); - } - End_roots() - _vresult = camlidl_alloc_small(3, 0); - Field(_vresult, 0) = _vres[0]; - Field(_vresult, 1) = _vres[1]; - Field(_vresult, 2) = _vres[2]; - End_roots() - camlidl_free(_ctx); - return _vresult; -} - -value camlidl_z3_Z3_mk_enumeration_sort( - value _v_c, - value _v_name, - value _v_enum_names) -{ - Z3_context c; /*in*/ - Z3_symbol name; /*in*/ - unsigned int n; /*in*/ - Z3_symbol const *enum_names; /*in*/ - Z3_func_decl *enum_consts; /*out*/ - Z3_func_decl *enum_testers; /*out*/ - Z3_sort _res; - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - mlsize_t _c1; - mlsize_t _c2; - value _v3; - mlsize_t _c4; - value _v5; - mlsize_t _c6; - value _v7; - value _vresult; - value _vres[3] = { 0, 0, 0, }; - - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_symbol(_v_name, &name, _ctx); - _c1 = Wosize_val(_v_enum_names); - enum_names = camlidl_malloc(_c1 * sizeof(Z3_symbol const ), _ctx); - for (_c2 = 0; _c2 < _c1; _c2++) { - _v3 = Field(_v_enum_names, _c2); - camlidl_ml2c_z3_Z3_symbol(_v3, &enum_names[_c2], _ctx); - } - n = _c1; - enum_consts = camlidl_malloc(n * sizeof(Z3_func_decl ), _ctx); - enum_testers = camlidl_malloc(n * sizeof(Z3_func_decl ), _ctx); - _res = Z3_mk_enumeration_sort(c, name, n, enum_names, enum_consts, enum_testers); - Begin_roots_block(_vres, 3) - _vres[0] = camlidl_c2ml_z3_Z3_sort(&_res, _ctx); - _vres[1] = camlidl_alloc(n, 0); - Begin_root(_vres[1]) - for (_c4 = 0; _c4 < n; _c4++) { - _v5 = camlidl_c2ml_z3_Z3_func_decl(&enum_consts[_c4], _ctx); - modify(&Field(_vres[1], _c4), _v5); - } - End_roots() - _vres[2] = camlidl_alloc(n, 0); - Begin_root(_vres[2]) - for (_c6 = 0; _c6 < n; _c6++) { - _v7 = camlidl_c2ml_z3_Z3_func_decl(&enum_testers[_c6], _ctx); - modify(&Field(_vres[2], _c6), _v7); - } - End_roots() - _vresult = camlidl_alloc_small(3, 0); - Field(_vresult, 0) = _vres[0]; - Field(_vresult, 1) = _vres[1]; - Field(_vresult, 2) = _vres[2]; - End_roots() - camlidl_free(_ctx); - return _vresult; -} - -value camlidl_z3_Z3_mk_list_sort( - value _v_c, - value _v_name, - value _v_elem_sort) -{ - Z3_context c; /*in*/ - Z3_symbol name; /*in*/ - Z3_sort elem_sort; /*in*/ - Z3_func_decl *nil_decl; /*out*/ - Z3_func_decl *is_nil_decl; /*out*/ - Z3_func_decl *cons_decl; /*out*/ - Z3_func_decl *is_cons_decl; /*out*/ - Z3_func_decl *head_decl; /*out*/ - Z3_func_decl *tail_decl; /*out*/ - Z3_sort _res; - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - Z3_func_decl _c1; - Z3_func_decl _c2; - Z3_func_decl _c3; - Z3_func_decl _c4; - Z3_func_decl _c5; - Z3_func_decl _c6; - value _vresult; - value _vres[7] = { 0, 0, 0, 0, 0, 0, 0, }; - - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_symbol(_v_name, &name, _ctx); - camlidl_ml2c_z3_Z3_sort(_v_elem_sort, &elem_sort, _ctx); - nil_decl = &_c1; - is_nil_decl = &_c2; - cons_decl = &_c3; - is_cons_decl = &_c4; - head_decl = &_c5; - tail_decl = &_c6; - _res = Z3_mk_list_sort(c, name, elem_sort, nil_decl, is_nil_decl, cons_decl, is_cons_decl, head_decl, tail_decl); - Begin_roots_block(_vres, 7) - _vres[0] = camlidl_c2ml_z3_Z3_sort(&_res, _ctx); - _vres[1] = camlidl_c2ml_z3_Z3_func_decl(&*nil_decl, _ctx); - _vres[2] = camlidl_c2ml_z3_Z3_func_decl(&*is_nil_decl, _ctx); - _vres[3] = camlidl_c2ml_z3_Z3_func_decl(&*cons_decl, _ctx); - _vres[4] = camlidl_c2ml_z3_Z3_func_decl(&*is_cons_decl, _ctx); - _vres[5] = camlidl_c2ml_z3_Z3_func_decl(&*head_decl, _ctx); - _vres[6] = camlidl_c2ml_z3_Z3_func_decl(&*tail_decl, _ctx); - _vresult = camlidl_alloc_small(7, 0); - { mlsize_t _c7; - for (_c7 = 0; _c7 < 7; _c7++) Field(_vresult, _c7) = _vres[_c7]; - } - End_roots() - camlidl_free(_ctx); - return _vresult; -} - -value camlidl_z3_Z3_mk_constructor( - value _v_c, - value _v_name, - value _v_recognizer, - value _v_field_names, - value _v_sorts, - value _v_sort_refs) -{ - Z3_context c; /*in*/ - Z3_symbol name; /*in*/ - Z3_symbol recognizer; /*in*/ - unsigned int num_fields; /*in*/ - Z3_symbol const *field_names; /*in*/ - Z3_sort const *sorts; /*in*/ - unsigned int *sort_refs; /*in*/ - Z3_constructor _res; - mlsize_t _c1; - mlsize_t _c2; - value _v3; - mlsize_t _c4; - mlsize_t _c5; - value _v6; - mlsize_t _c7; - mlsize_t _c8; - value _v9; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_symbol(_v_name, &name, _ctx); - camlidl_ml2c_z3_Z3_symbol(_v_recognizer, &recognizer, _ctx); - _c1 = Wosize_val(_v_field_names); - field_names = camlidl_malloc(_c1 * sizeof(Z3_symbol const ), _ctx); - for (_c2 = 0; _c2 < _c1; _c2++) { - _v3 = Field(_v_field_names, _c2); - camlidl_ml2c_z3_Z3_symbol(_v3, &field_names[_c2], _ctx); - } - num_fields = _c1; - _c4 = Wosize_val(_v_sorts); - sorts = camlidl_malloc(_c4 * sizeof(Z3_sort const ), _ctx); - for (_c5 = 0; _c5 < _c4; _c5++) { - _v6 = Field(_v_sorts, _c5); - camlidl_ml2c_z3_Z3_sort(_v6, &sorts[_c5], _ctx); - } - num_fields = _c4; - _c7 = Wosize_val(_v_sort_refs); - sort_refs = camlidl_malloc(_c7 * sizeof(unsigned int ), _ctx); - for (_c8 = 0; _c8 < _c7; _c8++) { - _v9 = Field(_v_sort_refs, _c8); - sort_refs[_c8] = Int_val(_v9); - } - num_fields = _c7; - _res = Z3_mk_constructor(c, name, recognizer, num_fields, field_names, sorts, sort_refs); - _vres = camlidl_c2ml_z3_Z3_constructor(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_constructor_bytecode(value * argv, int argn) -{ - return camlidl_z3_Z3_mk_constructor(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]); -} - -value camlidl_z3_Z3_query_constructor( - value _v_c, - value _v_constr, - value _v_num_fields) -{ - Z3_context c; /*in*/ - Z3_constructor constr; /*in*/ - unsigned int num_fields; /*in*/ - Z3_func_decl *constructor; /*out*/ - Z3_func_decl *tester; /*out*/ - Z3_func_decl *accessors; /*out*/ - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - Z3_func_decl _c1; - Z3_func_decl _c2; - mlsize_t _c3; - value _v4; - value _vresult; - value _vres[3] = { 0, 0, 0, }; - - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_constructor(_v_constr, &constr, _ctx); - num_fields = Int_val(_v_num_fields); - constructor = &_c1; - tester = &_c2; - accessors = camlidl_malloc(num_fields * sizeof(Z3_func_decl ), _ctx); - Z3_query_constructor(c, constr, num_fields, constructor, tester, accessors); - Begin_roots_block(_vres, 3) - _vres[0] = camlidl_c2ml_z3_Z3_func_decl(&*constructor, _ctx); - _vres[1] = camlidl_c2ml_z3_Z3_func_decl(&*tester, _ctx); - _vres[2] = camlidl_alloc(num_fields, 0); - Begin_root(_vres[2]) - for (_c3 = 0; _c3 < num_fields; _c3++) { - _v4 = camlidl_c2ml_z3_Z3_func_decl(&accessors[_c3], _ctx); - modify(&Field(_vres[2], _c3), _v4); - } - End_roots() - _vresult = camlidl_alloc_small(3, 0); - Field(_vresult, 0) = _vres[0]; - Field(_vresult, 1) = _vres[1]; - Field(_vresult, 2) = _vres[2]; - End_roots() - camlidl_free(_ctx); - return _vresult; -} - -value camlidl_z3_Z3_del_constructor( - value _v_c, - value _v_constr) -{ - Z3_context c; /*in*/ - Z3_constructor constr; /*in*/ - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_constructor(_v_constr, &constr, _ctx); - Z3_del_constructor(c, constr); - camlidl_free(_ctx); - return Val_unit; -} - -value camlidl_z3_Z3_mk_datatype( - value _v_c, - value _v_name, - value _v_constructors) -{ - Z3_context c; /*in*/ - Z3_symbol name; /*in*/ - unsigned int num_constructors; /*in*/ - Z3_constructor *constructors; /*in,out*/ - Z3_sort _res; - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - mlsize_t _c1; - mlsize_t _c2; - value _v3; - mlsize_t _c4; - value _v5; - value _vresult; - value _vres[2] = { 0, 0, }; - - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_symbol(_v_name, &name, _ctx); - _c1 = Wosize_val(_v_constructors); - constructors = camlidl_malloc(_c1 * sizeof(Z3_constructor ), _ctx); - for (_c2 = 0; _c2 < _c1; _c2++) { - _v3 = Field(_v_constructors, _c2); - camlidl_ml2c_z3_Z3_constructor(_v3, &constructors[_c2], _ctx); - } - num_constructors = _c1; - _res = Z3_mk_datatype(c, name, num_constructors, constructors); - Begin_roots_block(_vres, 2) - _vres[0] = camlidl_c2ml_z3_Z3_sort(&_res, _ctx); - _vres[1] = camlidl_alloc(num_constructors, 0); - Begin_root(_vres[1]) - for (_c4 = 0; _c4 < num_constructors; _c4++) { - _v5 = camlidl_c2ml_z3_Z3_constructor(&constructors[_c4], _ctx); - modify(&Field(_vres[1], _c4), _v5); - } - End_roots() - _vresult = camlidl_alloc_small(2, 0); - Field(_vresult, 0) = _vres[0]; - Field(_vresult, 1) = _vres[1]; - End_roots() - camlidl_free(_ctx); - return _vresult; -} - -value camlidl_z3_Z3_mk_constructor_list( - value _v_c, - value _v_constructors) -{ - Z3_context c; /*in*/ - unsigned int num_constructors; /*in*/ - Z3_constructor *constructors; /*in*/ - Z3_constructor_list _res; - mlsize_t _c1; - mlsize_t _c2; - value _v3; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - _c1 = Wosize_val(_v_constructors); - constructors = camlidl_malloc(_c1 * sizeof(Z3_constructor ), _ctx); - for (_c2 = 0; _c2 < _c1; _c2++) { - _v3 = Field(_v_constructors, _c2); - camlidl_ml2c_z3_Z3_constructor(_v3, &constructors[_c2], _ctx); - } - num_constructors = _c1; - _res = Z3_mk_constructor_list(c, num_constructors, constructors); - _vres = camlidl_c2ml_z3_Z3_constructor_list(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_del_constructor_list( - value _v_c, - value _v_clist) -{ - Z3_context c; /*in*/ - Z3_constructor_list clist; /*in*/ - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_constructor_list(_v_clist, &clist, _ctx); - Z3_del_constructor_list(c, clist); - camlidl_free(_ctx); - return Val_unit; -} - -value camlidl_z3_Z3_mk_datatypes( - value _v_c, - value _v_sort_names, - value _v_constructor_lists) -{ - Z3_context c; /*in*/ - unsigned int num_sorts; /*in*/ - Z3_symbol *sort_names; /*in*/ - Z3_sort *sorts; /*out*/ - Z3_constructor_list *constructor_lists; /*in,out*/ - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - mlsize_t _c1; - mlsize_t _c2; - value _v3; - mlsize_t _c4; - mlsize_t _c5; - value _v6; - mlsize_t _c7; - value _v8; - mlsize_t _c9; - value _v10; - value _vresult; - value _vres[2] = { 0, 0, }; - - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - _c1 = Wosize_val(_v_sort_names); - sort_names = camlidl_malloc(_c1 * sizeof(Z3_symbol ), _ctx); - for (_c2 = 0; _c2 < _c1; _c2++) { - _v3 = Field(_v_sort_names, _c2); - camlidl_ml2c_z3_Z3_symbol(_v3, &sort_names[_c2], _ctx); - } - num_sorts = _c1; - _c4 = Wosize_val(_v_constructor_lists); - constructor_lists = camlidl_malloc(_c4 * sizeof(Z3_constructor_list ), _ctx); - for (_c5 = 0; _c5 < _c4; _c5++) { - _v6 = Field(_v_constructor_lists, _c5); - camlidl_ml2c_z3_Z3_constructor_list(_v6, &constructor_lists[_c5], _ctx); - } - num_sorts = _c4; - sorts = camlidl_malloc(num_sorts * sizeof(Z3_sort ), _ctx); - Z3_mk_datatypes(c, num_sorts, sort_names, sorts, constructor_lists); - Begin_roots_block(_vres, 2) - _vres[0] = camlidl_alloc(num_sorts, 0); - Begin_root(_vres[0]) - for (_c7 = 0; _c7 < num_sorts; _c7++) { - _v8 = camlidl_c2ml_z3_Z3_sort(&sorts[_c7], _ctx); - modify(&Field(_vres[0], _c7), _v8); - } - End_roots() - _vres[1] = camlidl_alloc(num_sorts, 0); - Begin_root(_vres[1]) - for (_c9 = 0; _c9 < num_sorts; _c9++) { - _v10 = camlidl_c2ml_z3_Z3_constructor_list(&constructor_lists[_c9], _ctx); - modify(&Field(_vres[1], _c9), _v10); - } - End_roots() - _vresult = camlidl_alloc_small(2, 0); - Field(_vresult, 0) = _vres[0]; - Field(_vresult, 1) = _vres[1]; - End_roots() - camlidl_free(_ctx); - return _vresult; -} - -value camlidl_z3_Z3_mk_injective_function( - value _v_c, - value _v_s, - value _v_domain, - value _v_range) -{ - Z3_context c; /*in*/ - Z3_symbol s; /*in*/ - unsigned int domain_size; /*in*/ - Z3_sort const *domain; /*in*/ - Z3_sort range; /*in*/ - Z3_func_decl _res; - mlsize_t _c1; - mlsize_t _c2; - value _v3; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_symbol(_v_s, &s, _ctx); - _c1 = Wosize_val(_v_domain); - domain = camlidl_malloc(_c1 * sizeof(Z3_sort const ), _ctx); - for (_c2 = 0; _c2 < _c1; _c2++) { - _v3 = Field(_v_domain, _c2); - camlidl_ml2c_z3_Z3_sort(_v3, &domain[_c2], _ctx); - } - domain_size = _c1; - camlidl_ml2c_z3_Z3_sort(_v_range, &range, _ctx); - _res = Z3_mk_injective_function(c, s, domain_size, domain, range); - _vres = camlidl_c2ml_z3_Z3_func_decl(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_is_eq_ast( - value _v_c, - value _v_t1, - value _v_t2) -{ - Z3_context c; /*in*/ - Z3_ast t1; /*in*/ - Z3_ast t2; /*in*/ - int _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); - _res = Z3_is_eq_ast(c, t1, t2); - _vres = Val_int(_res); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_is_eq_func_decl( - value _v_c, - value _v_f1, - value _v_f2) -{ - Z3_context c; /*in*/ - Z3_func_decl f1; /*in*/ - Z3_func_decl f2; /*in*/ - int _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_func_decl(_v_f1, &f1, _ctx); - camlidl_ml2c_z3_Z3_func_decl(_v_f2, &f2, _ctx); - _res = Z3_is_eq_func_decl(c, f1, f2); - _vres = Val_int(_res); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_func_decl( - value _v_c, - value _v_s, - value _v_domain, - value _v_range) -{ - Z3_context c; /*in*/ - Z3_symbol s; /*in*/ - unsigned int domain_size; /*in*/ - Z3_sort const *domain; /*in*/ - Z3_sort range; /*in*/ - Z3_func_decl _res; - mlsize_t _c1; - mlsize_t _c2; - value _v3; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_symbol(_v_s, &s, _ctx); - _c1 = Wosize_val(_v_domain); - domain = camlidl_malloc(_c1 * sizeof(Z3_sort const ), _ctx); - for (_c2 = 0; _c2 < _c1; _c2++) { - _v3 = Field(_v_domain, _c2); - camlidl_ml2c_z3_Z3_sort(_v3, &domain[_c2], _ctx); - } - domain_size = _c1; - camlidl_ml2c_z3_Z3_sort(_v_range, &range, _ctx); - _res = Z3_mk_func_decl(c, s, domain_size, domain, range); - _vres = camlidl_c2ml_z3_Z3_func_decl(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_app( - value _v_c, - value _v_d, - value _v_args) -{ - Z3_context c; /*in*/ - Z3_func_decl d; /*in*/ - unsigned int num_args; /*in*/ - Z3_ast const *args; /*in*/ - Z3_ast _res; - mlsize_t _c1; - mlsize_t _c2; - value _v3; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_func_decl(_v_d, &d, _ctx); - _c1 = Wosize_val(_v_args); - args = camlidl_malloc(_c1 * sizeof(Z3_ast const ), _ctx); - for (_c2 = 0; _c2 < _c1; _c2++) { - _v3 = Field(_v_args, _c2); - camlidl_ml2c_z3_Z3_ast(_v3, &args[_c2], _ctx); - } - num_args = _c1; - _res = Z3_mk_app(c, d, num_args, args); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_const( - value _v_c, - value _v_s, - value _v_ty) -{ - Z3_context c; /*in*/ - Z3_symbol s; /*in*/ - Z3_sort ty; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_symbol(_v_s, &s, _ctx); - camlidl_ml2c_z3_Z3_sort(_v_ty, &ty, _ctx); - _res = Z3_mk_const(c, s, ty); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_label( - value _v_c, - value _v_s, - value _v_is_pos, - value _v_f) -{ - Z3_context c; /*in*/ - Z3_symbol s; /*in*/ - int is_pos; /*in*/ - Z3_ast f; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_symbol(_v_s, &s, _ctx); - is_pos = Int_val(_v_is_pos); - camlidl_ml2c_z3_Z3_ast(_v_f, &f, _ctx); - _res = Z3_mk_label(c, s, is_pos, f); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_fresh_func_decl( - value _v_c, - value _v_prefix, - value _v_domain, - value _v_range) -{ - Z3_context c; /*in*/ - char const *prefix; /*in*/ - unsigned int domain_size; /*in*/ - Z3_sort const *domain; /*in*/ - Z3_sort range; /*in*/ - Z3_func_decl _res; - mlsize_t _c1; - mlsize_t _c2; - value _v3; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - prefix = String_val(_v_prefix); - _c1 = Wosize_val(_v_domain); - domain = camlidl_malloc(_c1 * sizeof(Z3_sort const ), _ctx); - for (_c2 = 0; _c2 < _c1; _c2++) { - _v3 = Field(_v_domain, _c2); - camlidl_ml2c_z3_Z3_sort(_v3, &domain[_c2], _ctx); - } - domain_size = _c1; - camlidl_ml2c_z3_Z3_sort(_v_range, &range, _ctx); - _res = Z3_mk_fresh_func_decl(c, prefix, domain_size, domain, range); - _vres = camlidl_c2ml_z3_Z3_func_decl(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_fresh_const( - value _v_c, - value _v_prefix, - value _v_ty) -{ - Z3_context c; /*in*/ - char const *prefix; /*in*/ - Z3_sort ty; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - prefix = String_val(_v_prefix); - camlidl_ml2c_z3_Z3_sort(_v_ty, &ty, _ctx); - _res = Z3_mk_fresh_const(c, prefix, ty); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_true( - value _v_c) -{ - Z3_context c; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - _res = Z3_mk_true(c); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_false( - value _v_c) -{ - Z3_context c; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - _res = Z3_mk_false(c); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_eq( - value _v_c, - value _v_l, - value _v_r) -{ - Z3_context c; /*in*/ - Z3_ast l; /*in*/ - Z3_ast r; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_l, &l, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_r, &r, _ctx); - _res = Z3_mk_eq(c, l, r); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_distinct( - value _v_c, - value _v_args) -{ - Z3_context c; /*in*/ - unsigned int num_args; /*in*/ - Z3_ast const *args; /*in*/ - Z3_ast _res; - mlsize_t _c1; - mlsize_t _c2; - value _v3; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - _c1 = Wosize_val(_v_args); - args = camlidl_malloc(_c1 * sizeof(Z3_ast const ), _ctx); - for (_c2 = 0; _c2 < _c1; _c2++) { - _v3 = Field(_v_args, _c2); - camlidl_ml2c_z3_Z3_ast(_v3, &args[_c2], _ctx); - } - num_args = _c1; - _res = Z3_mk_distinct(c, num_args, args); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_not( - value _v_c, - value _v_a) -{ - Z3_context c; /*in*/ - Z3_ast a; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_a, &a, _ctx); - _res = Z3_mk_not(c, a); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_ite( - value _v_c, - value _v_t1, - value _v_t2, - value _v_t3) -{ - Z3_context c; /*in*/ - Z3_ast t1; /*in*/ - Z3_ast t2; /*in*/ - Z3_ast t3; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t3, &t3, _ctx); - _res = Z3_mk_ite(c, t1, t2, t3); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_iff( - value _v_c, - value _v_t1, - value _v_t2) -{ - Z3_context c; /*in*/ - Z3_ast t1; /*in*/ - Z3_ast t2; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); - _res = Z3_mk_iff(c, t1, t2); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_implies( - value _v_c, - value _v_t1, - value _v_t2) -{ - Z3_context c; /*in*/ - Z3_ast t1; /*in*/ - Z3_ast t2; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); - _res = Z3_mk_implies(c, t1, t2); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_xor( - value _v_c, - value _v_t1, - value _v_t2) -{ - Z3_context c; /*in*/ - Z3_ast t1; /*in*/ - Z3_ast t2; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); - _res = Z3_mk_xor(c, t1, t2); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_and( - value _v_c, - value _v_args) -{ - Z3_context c; /*in*/ - unsigned int num_args; /*in*/ - Z3_ast const *args; /*in*/ - Z3_ast _res; - mlsize_t _c1; - mlsize_t _c2; - value _v3; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - _c1 = Wosize_val(_v_args); - args = camlidl_malloc(_c1 * sizeof(Z3_ast const ), _ctx); - for (_c2 = 0; _c2 < _c1; _c2++) { - _v3 = Field(_v_args, _c2); - camlidl_ml2c_z3_Z3_ast(_v3, &args[_c2], _ctx); - } - num_args = _c1; - _res = Z3_mk_and(c, num_args, args); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_or( - value _v_c, - value _v_args) -{ - Z3_context c; /*in*/ - unsigned int num_args; /*in*/ - Z3_ast const *args; /*in*/ - Z3_ast _res; - mlsize_t _c1; - mlsize_t _c2; - value _v3; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - _c1 = Wosize_val(_v_args); - args = camlidl_malloc(_c1 * sizeof(Z3_ast const ), _ctx); - for (_c2 = 0; _c2 < _c1; _c2++) { - _v3 = Field(_v_args, _c2); - camlidl_ml2c_z3_Z3_ast(_v3, &args[_c2], _ctx); - } - num_args = _c1; - _res = Z3_mk_or(c, num_args, args); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_add( - value _v_c, - value _v_args) -{ - Z3_context c; /*in*/ - unsigned int num_args; /*in*/ - Z3_ast const *args; /*in*/ - Z3_ast _res; - mlsize_t _c1; - mlsize_t _c2; - value _v3; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - _c1 = Wosize_val(_v_args); - args = camlidl_malloc(_c1 * sizeof(Z3_ast const ), _ctx); - for (_c2 = 0; _c2 < _c1; _c2++) { - _v3 = Field(_v_args, _c2); - camlidl_ml2c_z3_Z3_ast(_v3, &args[_c2], _ctx); - } - num_args = _c1; - _res = Z3_mk_add(c, num_args, args); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_mul( - value _v_c, - value _v_args) -{ - Z3_context c; /*in*/ - unsigned int num_args; /*in*/ - Z3_ast const *args; /*in*/ - Z3_ast _res; - mlsize_t _c1; - mlsize_t _c2; - value _v3; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - _c1 = Wosize_val(_v_args); - args = camlidl_malloc(_c1 * sizeof(Z3_ast const ), _ctx); - for (_c2 = 0; _c2 < _c1; _c2++) { - _v3 = Field(_v_args, _c2); - camlidl_ml2c_z3_Z3_ast(_v3, &args[_c2], _ctx); - } - num_args = _c1; - _res = Z3_mk_mul(c, num_args, args); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_sub( - value _v_c, - value _v_args) -{ - Z3_context c; /*in*/ - unsigned int num_args; /*in*/ - Z3_ast const *args; /*in*/ - Z3_ast _res; - mlsize_t _c1; - mlsize_t _c2; - value _v3; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - _c1 = Wosize_val(_v_args); - args = camlidl_malloc(_c1 * sizeof(Z3_ast const ), _ctx); - for (_c2 = 0; _c2 < _c1; _c2++) { - _v3 = Field(_v_args, _c2); - camlidl_ml2c_z3_Z3_ast(_v3, &args[_c2], _ctx); - } - num_args = _c1; - _res = Z3_mk_sub(c, num_args, args); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_unary_minus( - value _v_c, - value _v_arg) -{ - Z3_context c; /*in*/ - Z3_ast arg; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_arg, &arg, _ctx); - _res = Z3_mk_unary_minus(c, arg); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_div( - value _v_c, - value _v_arg1, - value _v_arg2) -{ - Z3_context c; /*in*/ - Z3_ast arg1; /*in*/ - Z3_ast arg2; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_arg1, &arg1, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_arg2, &arg2, _ctx); - _res = Z3_mk_div(c, arg1, arg2); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_mod( - value _v_c, - value _v_arg1, - value _v_arg2) -{ - Z3_context c; /*in*/ - Z3_ast arg1; /*in*/ - Z3_ast arg2; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_arg1, &arg1, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_arg2, &arg2, _ctx); - _res = Z3_mk_mod(c, arg1, arg2); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_rem( - value _v_c, - value _v_arg1, - value _v_arg2) -{ - Z3_context c; /*in*/ - Z3_ast arg1; /*in*/ - Z3_ast arg2; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_arg1, &arg1, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_arg2, &arg2, _ctx); - _res = Z3_mk_rem(c, arg1, arg2); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_lt( - value _v_c, - value _v_t1, - value _v_t2) -{ - Z3_context c; /*in*/ - Z3_ast t1; /*in*/ - Z3_ast t2; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); - _res = Z3_mk_lt(c, t1, t2); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_le( - value _v_c, - value _v_t1, - value _v_t2) -{ - Z3_context c; /*in*/ - Z3_ast t1; /*in*/ - Z3_ast t2; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); - _res = Z3_mk_le(c, t1, t2); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_gt( - value _v_c, - value _v_t1, - value _v_t2) -{ - Z3_context c; /*in*/ - Z3_ast t1; /*in*/ - Z3_ast t2; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); - _res = Z3_mk_gt(c, t1, t2); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_ge( - value _v_c, - value _v_t1, - value _v_t2) -{ - Z3_context c; /*in*/ - Z3_ast t1; /*in*/ - Z3_ast t2; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); - _res = Z3_mk_ge(c, t1, t2); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_int2real( - value _v_c, - value _v_t1) -{ - Z3_context c; /*in*/ - Z3_ast t1; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); - _res = Z3_mk_int2real(c, t1); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_real2int( - value _v_c, - value _v_t1) -{ - Z3_context c; /*in*/ - Z3_ast t1; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); - _res = Z3_mk_real2int(c, t1); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_is_int( - value _v_c, - value _v_t1) -{ - Z3_context c; /*in*/ - Z3_ast t1; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); - _res = Z3_mk_is_int(c, t1); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_bvnot( - value _v_c, - value _v_t1) -{ - Z3_context c; /*in*/ - Z3_ast t1; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); - _res = Z3_mk_bvnot(c, t1); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_bvredand( - value _v_c, - value _v_t1) -{ - Z3_context c; /*in*/ - Z3_ast t1; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); - _res = Z3_mk_bvredand(c, t1); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_bvredor( - value _v_c, - value _v_t1) -{ - Z3_context c; /*in*/ - Z3_ast t1; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); - _res = Z3_mk_bvredor(c, t1); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_bvand( - value _v_c, - value _v_t1, - value _v_t2) -{ - Z3_context c; /*in*/ - Z3_ast t1; /*in*/ - Z3_ast t2; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); - _res = Z3_mk_bvand(c, t1, t2); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_bvor( - value _v_c, - value _v_t1, - value _v_t2) -{ - Z3_context c; /*in*/ - Z3_ast t1; /*in*/ - Z3_ast t2; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); - _res = Z3_mk_bvor(c, t1, t2); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_bvxor( - value _v_c, - value _v_t1, - value _v_t2) -{ - Z3_context c; /*in*/ - Z3_ast t1; /*in*/ - Z3_ast t2; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); - _res = Z3_mk_bvxor(c, t1, t2); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_bvnand( - value _v_c, - value _v_t1, - value _v_t2) -{ - Z3_context c; /*in*/ - Z3_ast t1; /*in*/ - Z3_ast t2; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); - _res = Z3_mk_bvnand(c, t1, t2); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_bvnor( - value _v_c, - value _v_t1, - value _v_t2) -{ - Z3_context c; /*in*/ - Z3_ast t1; /*in*/ - Z3_ast t2; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); - _res = Z3_mk_bvnor(c, t1, t2); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_bvxnor( - value _v_c, - value _v_t1, - value _v_t2) -{ - Z3_context c; /*in*/ - Z3_ast t1; /*in*/ - Z3_ast t2; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); - _res = Z3_mk_bvxnor(c, t1, t2); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_bvneg( - value _v_c, - value _v_t1) -{ - Z3_context c; /*in*/ - Z3_ast t1; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); - _res = Z3_mk_bvneg(c, t1); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_bvadd( - value _v_c, - value _v_t1, - value _v_t2) -{ - Z3_context c; /*in*/ - Z3_ast t1; /*in*/ - Z3_ast t2; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); - _res = Z3_mk_bvadd(c, t1, t2); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_bvsub( - value _v_c, - value _v_t1, - value _v_t2) -{ - Z3_context c; /*in*/ - Z3_ast t1; /*in*/ - Z3_ast t2; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); - _res = Z3_mk_bvsub(c, t1, t2); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_bvmul( - value _v_c, - value _v_t1, - value _v_t2) -{ - Z3_context c; /*in*/ - Z3_ast t1; /*in*/ - Z3_ast t2; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); - _res = Z3_mk_bvmul(c, t1, t2); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_bvudiv( - value _v_c, - value _v_t1, - value _v_t2) -{ - Z3_context c; /*in*/ - Z3_ast t1; /*in*/ - Z3_ast t2; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); - _res = Z3_mk_bvudiv(c, t1, t2); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_bvsdiv( - value _v_c, - value _v_t1, - value _v_t2) -{ - Z3_context c; /*in*/ - Z3_ast t1; /*in*/ - Z3_ast t2; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); - _res = Z3_mk_bvsdiv(c, t1, t2); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_bvurem( - value _v_c, - value _v_t1, - value _v_t2) -{ - Z3_context c; /*in*/ - Z3_ast t1; /*in*/ - Z3_ast t2; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); - _res = Z3_mk_bvurem(c, t1, t2); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_bvsrem( - value _v_c, - value _v_t1, - value _v_t2) -{ - Z3_context c; /*in*/ - Z3_ast t1; /*in*/ - Z3_ast t2; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); - _res = Z3_mk_bvsrem(c, t1, t2); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_bvsmod( - value _v_c, - value _v_t1, - value _v_t2) -{ - Z3_context c; /*in*/ - Z3_ast t1; /*in*/ - Z3_ast t2; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); - _res = Z3_mk_bvsmod(c, t1, t2); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_bvult( - value _v_c, - value _v_t1, - value _v_t2) -{ - Z3_context c; /*in*/ - Z3_ast t1; /*in*/ - Z3_ast t2; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); - _res = Z3_mk_bvult(c, t1, t2); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_bvslt( - value _v_c, - value _v_t1, - value _v_t2) -{ - Z3_context c; /*in*/ - Z3_ast t1; /*in*/ - Z3_ast t2; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); - _res = Z3_mk_bvslt(c, t1, t2); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_bvule( - value _v_c, - value _v_t1, - value _v_t2) -{ - Z3_context c; /*in*/ - Z3_ast t1; /*in*/ - Z3_ast t2; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); - _res = Z3_mk_bvule(c, t1, t2); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_bvsle( - value _v_c, - value _v_t1, - value _v_t2) -{ - Z3_context c; /*in*/ - Z3_ast t1; /*in*/ - Z3_ast t2; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); - _res = Z3_mk_bvsle(c, t1, t2); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_bvuge( - value _v_c, - value _v_t1, - value _v_t2) -{ - Z3_context c; /*in*/ - Z3_ast t1; /*in*/ - Z3_ast t2; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); - _res = Z3_mk_bvuge(c, t1, t2); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_bvsge( - value _v_c, - value _v_t1, - value _v_t2) -{ - Z3_context c; /*in*/ - Z3_ast t1; /*in*/ - Z3_ast t2; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); - _res = Z3_mk_bvsge(c, t1, t2); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_bvugt( - value _v_c, - value _v_t1, - value _v_t2) -{ - Z3_context c; /*in*/ - Z3_ast t1; /*in*/ - Z3_ast t2; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); - _res = Z3_mk_bvugt(c, t1, t2); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_bvsgt( - value _v_c, - value _v_t1, - value _v_t2) -{ - Z3_context c; /*in*/ - Z3_ast t1; /*in*/ - Z3_ast t2; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); - _res = Z3_mk_bvsgt(c, t1, t2); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_concat( - value _v_c, - value _v_t1, - value _v_t2) -{ - Z3_context c; /*in*/ - Z3_ast t1; /*in*/ - Z3_ast t2; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); - _res = Z3_mk_concat(c, t1, t2); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_extract( - value _v_c, - value _v_high, - value _v_low, - value _v_t1) -{ - Z3_context c; /*in*/ - unsigned int high; /*in*/ - unsigned int low; /*in*/ - Z3_ast t1; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - high = Int_val(_v_high); - low = Int_val(_v_low); - camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); - _res = Z3_mk_extract(c, high, low, t1); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_sign_ext( - value _v_c, - value _v_i, - value _v_t1) -{ - Z3_context c; /*in*/ - unsigned int i; /*in*/ - Z3_ast t1; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - i = Int_val(_v_i); - camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); - _res = Z3_mk_sign_ext(c, i, t1); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_zero_ext( - value _v_c, - value _v_i, - value _v_t1) -{ - Z3_context c; /*in*/ - unsigned int i; /*in*/ - Z3_ast t1; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - i = Int_val(_v_i); - camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); - _res = Z3_mk_zero_ext(c, i, t1); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_repeat( - value _v_c, - value _v_i, - value _v_t1) -{ - Z3_context c; /*in*/ - unsigned int i; /*in*/ - Z3_ast t1; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - i = Int_val(_v_i); - camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); - _res = Z3_mk_repeat(c, i, t1); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_bvshl( - value _v_c, - value _v_t1, - value _v_t2) -{ - Z3_context c; /*in*/ - Z3_ast t1; /*in*/ - Z3_ast t2; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); - _res = Z3_mk_bvshl(c, t1, t2); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_bvlshr( - value _v_c, - value _v_t1, - value _v_t2) -{ - Z3_context c; /*in*/ - Z3_ast t1; /*in*/ - Z3_ast t2; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); - _res = Z3_mk_bvlshr(c, t1, t2); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_bvashr( - value _v_c, - value _v_t1, - value _v_t2) -{ - Z3_context c; /*in*/ - Z3_ast t1; /*in*/ - Z3_ast t2; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); - _res = Z3_mk_bvashr(c, t1, t2); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_rotate_left( - value _v_c, - value _v_i, - value _v_t1) -{ - Z3_context c; /*in*/ - unsigned int i; /*in*/ - Z3_ast t1; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - i = Int_val(_v_i); - camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); - _res = Z3_mk_rotate_left(c, i, t1); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_rotate_right( - value _v_c, - value _v_i, - value _v_t1) -{ - Z3_context c; /*in*/ - unsigned int i; /*in*/ - Z3_ast t1; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - i = Int_val(_v_i); - camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); - _res = Z3_mk_rotate_right(c, i, t1); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_ext_rotate_left( - value _v_c, - value _v_t1, - value _v_t2) -{ - Z3_context c; /*in*/ - Z3_ast t1; /*in*/ - Z3_ast t2; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); - _res = Z3_mk_ext_rotate_left(c, t1, t2); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_ext_rotate_right( - value _v_c, - value _v_t1, - value _v_t2) -{ - Z3_context c; /*in*/ - Z3_ast t1; /*in*/ - Z3_ast t2; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); - _res = Z3_mk_ext_rotate_right(c, t1, t2); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_int2bv( - value _v_c, - value _v_n, - value _v_t1) -{ - Z3_context c; /*in*/ - unsigned int n; /*in*/ - Z3_ast t1; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - n = Int_val(_v_n); - camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); - _res = Z3_mk_int2bv(c, n, t1); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_bv2int( - value _v_c, - value _v_t1, - value _v_is_signed) -{ - Z3_context c; /*in*/ - Z3_ast t1; /*in*/ - int is_signed; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); - is_signed = Int_val(_v_is_signed); - _res = Z3_mk_bv2int(c, t1, is_signed); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_bvadd_no_overflow( - value _v_c, - value _v_t1, - value _v_t2, - value _v_is_signed) -{ - Z3_context c; /*in*/ - Z3_ast t1; /*in*/ - Z3_ast t2; /*in*/ - int is_signed; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); - is_signed = Int_val(_v_is_signed); - _res = Z3_mk_bvadd_no_overflow(c, t1, t2, is_signed); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_bvadd_no_underflow( - value _v_c, - value _v_t1, - value _v_t2) -{ - Z3_context c; /*in*/ - Z3_ast t1; /*in*/ - Z3_ast t2; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); - _res = Z3_mk_bvadd_no_underflow(c, t1, t2); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_bvsub_no_overflow( - value _v_c, - value _v_t1, - value _v_t2) -{ - Z3_context c; /*in*/ - Z3_ast t1; /*in*/ - Z3_ast t2; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); - _res = Z3_mk_bvsub_no_overflow(c, t1, t2); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_bvsub_no_underflow( - value _v_c, - value _v_t1, - value _v_t2, - value _v_is_signed) -{ - Z3_context c; /*in*/ - Z3_ast t1; /*in*/ - Z3_ast t2; /*in*/ - int is_signed; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); - is_signed = Int_val(_v_is_signed); - _res = Z3_mk_bvsub_no_underflow(c, t1, t2, is_signed); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_bvsdiv_no_overflow( - value _v_c, - value _v_t1, - value _v_t2) -{ - Z3_context c; /*in*/ - Z3_ast t1; /*in*/ - Z3_ast t2; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); - _res = Z3_mk_bvsdiv_no_overflow(c, t1, t2); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_bvneg_no_overflow( - value _v_c, - value _v_t1) -{ - Z3_context c; /*in*/ - Z3_ast t1; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); - _res = Z3_mk_bvneg_no_overflow(c, t1); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_bvmul_no_overflow( - value _v_c, - value _v_t1, - value _v_t2, - value _v_is_signed) -{ - Z3_context c; /*in*/ - Z3_ast t1; /*in*/ - Z3_ast t2; /*in*/ - int is_signed; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); - is_signed = Int_val(_v_is_signed); - _res = Z3_mk_bvmul_no_overflow(c, t1, t2, is_signed); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_bvmul_no_underflow( - value _v_c, - value _v_t1, - value _v_t2) -{ - Z3_context c; /*in*/ - Z3_ast t1; /*in*/ - Z3_ast t2; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t1, &t1, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t2, &t2, _ctx); - _res = Z3_mk_bvmul_no_underflow(c, t1, t2); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_select( - value _v_c, - value _v_a, - value _v_i) -{ - Z3_context c; /*in*/ - Z3_ast a; /*in*/ - Z3_ast i; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_a, &a, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_i, &i, _ctx); - _res = Z3_mk_select(c, a, i); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_store( - value _v_c, - value _v_a, - value _v_i, - value _v_v) -{ - Z3_context c; /*in*/ - Z3_ast a; /*in*/ - Z3_ast i; /*in*/ - Z3_ast v; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_a, &a, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_i, &i, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_v, &v, _ctx); - _res = Z3_mk_store(c, a, i, v); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_const_array( - value _v_c, - value _v_domain, - value _v_v) -{ - Z3_context c; /*in*/ - Z3_sort domain; /*in*/ - Z3_ast v; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_sort(_v_domain, &domain, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_v, &v, _ctx); - _res = Z3_mk_const_array(c, domain, v); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_map( - value _v_c, - value _v_f, - value _v_n, - value _v_args) -{ - Z3_context c; /*in*/ - Z3_func_decl f; /*in*/ - unsigned int n; /*in*/ - Z3_ast const *args; /*in*/ - Z3_ast _res; - Z3_ast _c1; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_func_decl(_v_f, &f, _ctx); - n = Int_val(_v_n); - args = &_c1; - camlidl_ml2c_z3_Z3_ast(_v_args, &_c1, _ctx); - _res = Z3_mk_map(c, f, n, args); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_array_default( - value _v_c, - value _v_array) -{ - Z3_context c; /*in*/ - Z3_ast array; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_array, &array, _ctx); - _res = Z3_mk_array_default(c, array); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_set_sort( - value _v_c, - value _v_ty) -{ - Z3_context c; /*in*/ - Z3_sort ty; /*in*/ - Z3_sort _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_sort(_v_ty, &ty, _ctx); - _res = Z3_mk_set_sort(c, ty); - _vres = camlidl_c2ml_z3_Z3_sort(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_empty_set( - value _v_c, - value _v_domain) -{ - Z3_context c; /*in*/ - Z3_sort domain; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_sort(_v_domain, &domain, _ctx); - _res = Z3_mk_empty_set(c, domain); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_full_set( - value _v_c, - value _v_domain) -{ - Z3_context c; /*in*/ - Z3_sort domain; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_sort(_v_domain, &domain, _ctx); - _res = Z3_mk_full_set(c, domain); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_set_add( - value _v_c, - value _v_set, - value _v_elem) -{ - Z3_context c; /*in*/ - Z3_ast set; /*in*/ - Z3_ast elem; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_set, &set, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_elem, &elem, _ctx); - _res = Z3_mk_set_add(c, set, elem); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_set_del( - value _v_c, - value _v_set, - value _v_elem) -{ - Z3_context c; /*in*/ - Z3_ast set; /*in*/ - Z3_ast elem; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_set, &set, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_elem, &elem, _ctx); - _res = Z3_mk_set_del(c, set, elem); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_set_union( - value _v_c, - value _v_args) -{ - Z3_context c; /*in*/ - unsigned int num_args; /*in*/ - Z3_ast const *args; /*in*/ - Z3_ast _res; - mlsize_t _c1; - mlsize_t _c2; - value _v3; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - _c1 = Wosize_val(_v_args); - args = camlidl_malloc(_c1 * sizeof(Z3_ast const ), _ctx); - for (_c2 = 0; _c2 < _c1; _c2++) { - _v3 = Field(_v_args, _c2); - camlidl_ml2c_z3_Z3_ast(_v3, &args[_c2], _ctx); - } - num_args = _c1; - _res = Z3_mk_set_union(c, num_args, args); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_set_intersect( - value _v_c, - value _v_args) -{ - Z3_context c; /*in*/ - unsigned int num_args; /*in*/ - Z3_ast const *args; /*in*/ - Z3_ast _res; - mlsize_t _c1; - mlsize_t _c2; - value _v3; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - _c1 = Wosize_val(_v_args); - args = camlidl_malloc(_c1 * sizeof(Z3_ast const ), _ctx); - for (_c2 = 0; _c2 < _c1; _c2++) { - _v3 = Field(_v_args, _c2); - camlidl_ml2c_z3_Z3_ast(_v3, &args[_c2], _ctx); - } - num_args = _c1; - _res = Z3_mk_set_intersect(c, num_args, args); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_set_difference( - value _v_c, - value _v_arg1, - value _v_arg2) -{ - Z3_context c; /*in*/ - Z3_ast arg1; /*in*/ - Z3_ast arg2; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_arg1, &arg1, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_arg2, &arg2, _ctx); - _res = Z3_mk_set_difference(c, arg1, arg2); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_set_complement( - value _v_c, - value _v_arg) -{ - Z3_context c; /*in*/ - Z3_ast arg; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_arg, &arg, _ctx); - _res = Z3_mk_set_complement(c, arg); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_set_member( - value _v_c, - value _v_elem, - value _v_set) -{ - Z3_context c; /*in*/ - Z3_ast elem; /*in*/ - Z3_ast set; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_elem, &elem, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_set, &set, _ctx); - _res = Z3_mk_set_member(c, elem, set); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_set_subset( - value _v_c, - value _v_arg1, - value _v_arg2) -{ - Z3_context c; /*in*/ - Z3_ast arg1; /*in*/ - Z3_ast arg2; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_arg1, &arg1, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_arg2, &arg2, _ctx); - _res = Z3_mk_set_subset(c, arg1, arg2); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_numeral( - value _v_c, - value _v_numeral, - value _v_ty) -{ - Z3_context c; /*in*/ - char const *numeral; /*in*/ - Z3_sort ty; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - numeral = String_val(_v_numeral); - camlidl_ml2c_z3_Z3_sort(_v_ty, &ty, _ctx); - _res = Z3_mk_numeral(c, numeral, ty); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_real( - value _v_c, - value _v_num, - value _v_den) -{ - Z3_context c; /*in*/ - int num; /*in*/ - int den; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - num = Int_val(_v_num); - den = Int_val(_v_den); - _res = Z3_mk_real(c, num, den); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_int( - value _v_c, - value _v_v, - value _v_ty) -{ - Z3_context c; /*in*/ - int v; /*in*/ - Z3_sort ty; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - v = Int_val(_v_v); - camlidl_ml2c_z3_Z3_sort(_v_ty, &ty, _ctx); - _res = Z3_mk_int(c, v, ty); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_unsigned_int( - value _v_c, - value _v_v, - value _v_ty) -{ - Z3_context c; /*in*/ - unsigned int v; /*in*/ - Z3_sort ty; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - v = Int_val(_v_v); - camlidl_ml2c_z3_Z3_sort(_v_ty, &ty, _ctx); - _res = Z3_mk_unsigned_int(c, v, ty); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_pattern( - value _v_c, - value _v_terms) -{ - Z3_context c; /*in*/ - unsigned int num_patterns; /*in*/ - Z3_ast const *terms; /*in*/ - Z3_pattern _res; - mlsize_t _c1; - mlsize_t _c2; - value _v3; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - _c1 = Wosize_val(_v_terms); - terms = camlidl_malloc(_c1 * sizeof(Z3_ast const ), _ctx); - for (_c2 = 0; _c2 < _c1; _c2++) { - _v3 = Field(_v_terms, _c2); - camlidl_ml2c_z3_Z3_ast(_v3, &terms[_c2], _ctx); - } - num_patterns = _c1; - _res = Z3_mk_pattern(c, num_patterns, terms); - _vres = camlidl_c2ml_z3_Z3_pattern(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_bound( - value _v_c, - value _v_index, - value _v_ty) -{ - Z3_context c; /*in*/ - unsigned int index; /*in*/ - Z3_sort ty; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - index = Int_val(_v_index); - camlidl_ml2c_z3_Z3_sort(_v_ty, &ty, _ctx); - _res = Z3_mk_bound(c, index, ty); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_forall( - value _v_c, - value _v_weight, - value _v_patterns, - value _v_sorts, - value _v_decl_names, - value _v_body) -{ - Z3_context c; /*in*/ - unsigned int weight; /*in*/ - unsigned int num_patterns; /*in*/ - Z3_pattern const *patterns; /*in*/ - unsigned int num_decls; /*in*/ - Z3_sort const *sorts; /*in*/ - Z3_symbol const *decl_names; /*in*/ - Z3_ast body; /*in*/ - Z3_ast _res; - mlsize_t _c1; - mlsize_t _c2; - value _v3; - mlsize_t _c4; - mlsize_t _c5; - value _v6; - mlsize_t _c7; - mlsize_t _c8; - value _v9; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - weight = Int_val(_v_weight); - _c1 = Wosize_val(_v_patterns); - patterns = camlidl_malloc(_c1 * sizeof(Z3_pattern const ), _ctx); - for (_c2 = 0; _c2 < _c1; _c2++) { - _v3 = Field(_v_patterns, _c2); - camlidl_ml2c_z3_Z3_pattern(_v3, &patterns[_c2], _ctx); - } - num_patterns = _c1; - _c4 = Wosize_val(_v_sorts); - sorts = camlidl_malloc(_c4 * sizeof(Z3_sort const ), _ctx); - for (_c5 = 0; _c5 < _c4; _c5++) { - _v6 = Field(_v_sorts, _c5); - camlidl_ml2c_z3_Z3_sort(_v6, &sorts[_c5], _ctx); - } - num_decls = _c4; - _c7 = Wosize_val(_v_decl_names); - decl_names = camlidl_malloc(_c7 * sizeof(Z3_symbol const ), _ctx); - for (_c8 = 0; _c8 < _c7; _c8++) { - _v9 = Field(_v_decl_names, _c8); - camlidl_ml2c_z3_Z3_symbol(_v9, &decl_names[_c8], _ctx); - } - num_decls = _c7; - camlidl_ml2c_z3_Z3_ast(_v_body, &body, _ctx); - _res = Z3_mk_forall(c, weight, num_patterns, patterns, num_decls, sorts, decl_names, body); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_forall_bytecode(value * argv, int argn) -{ - return camlidl_z3_Z3_mk_forall(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]); -} - -value camlidl_z3_Z3_mk_exists( - value _v_c, - value _v_weight, - value _v_patterns, - value _v_sorts, - value _v_decl_names, - value _v_body) -{ - Z3_context c; /*in*/ - unsigned int weight; /*in*/ - unsigned int num_patterns; /*in*/ - Z3_pattern const *patterns; /*in*/ - unsigned int num_decls; /*in*/ - Z3_sort const *sorts; /*in*/ - Z3_symbol const *decl_names; /*in*/ - Z3_ast body; /*in*/ - Z3_ast _res; - mlsize_t _c1; - mlsize_t _c2; - value _v3; - mlsize_t _c4; - mlsize_t _c5; - value _v6; - mlsize_t _c7; - mlsize_t _c8; - value _v9; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - weight = Int_val(_v_weight); - _c1 = Wosize_val(_v_patterns); - patterns = camlidl_malloc(_c1 * sizeof(Z3_pattern const ), _ctx); - for (_c2 = 0; _c2 < _c1; _c2++) { - _v3 = Field(_v_patterns, _c2); - camlidl_ml2c_z3_Z3_pattern(_v3, &patterns[_c2], _ctx); - } - num_patterns = _c1; - _c4 = Wosize_val(_v_sorts); - sorts = camlidl_malloc(_c4 * sizeof(Z3_sort const ), _ctx); - for (_c5 = 0; _c5 < _c4; _c5++) { - _v6 = Field(_v_sorts, _c5); - camlidl_ml2c_z3_Z3_sort(_v6, &sorts[_c5], _ctx); - } - num_decls = _c4; - _c7 = Wosize_val(_v_decl_names); - decl_names = camlidl_malloc(_c7 * sizeof(Z3_symbol const ), _ctx); - for (_c8 = 0; _c8 < _c7; _c8++) { - _v9 = Field(_v_decl_names, _c8); - camlidl_ml2c_z3_Z3_symbol(_v9, &decl_names[_c8], _ctx); - } - num_decls = _c7; - camlidl_ml2c_z3_Z3_ast(_v_body, &body, _ctx); - _res = Z3_mk_exists(c, weight, num_patterns, patterns, num_decls, sorts, decl_names, body); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_exists_bytecode(value * argv, int argn) -{ - return camlidl_z3_Z3_mk_exists(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]); -} - -value camlidl_z3_Z3_mk_quantifier( - value _v_c, - value _v_is_forall, - value _v_weight, - value _v_patterns, - value _v_sorts, - value _v_decl_names, - value _v_body) -{ - Z3_context c; /*in*/ - int is_forall; /*in*/ - unsigned int weight; /*in*/ - unsigned int num_patterns; /*in*/ - Z3_pattern const *patterns; /*in*/ - unsigned int num_decls; /*in*/ - Z3_sort const *sorts; /*in*/ - Z3_symbol const *decl_names; /*in*/ - Z3_ast body; /*in*/ - Z3_ast _res; - mlsize_t _c1; - mlsize_t _c2; - value _v3; - mlsize_t _c4; - mlsize_t _c5; - value _v6; - mlsize_t _c7; - mlsize_t _c8; - value _v9; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - is_forall = Int_val(_v_is_forall); - weight = Int_val(_v_weight); - _c1 = Wosize_val(_v_patterns); - patterns = camlidl_malloc(_c1 * sizeof(Z3_pattern const ), _ctx); - for (_c2 = 0; _c2 < _c1; _c2++) { - _v3 = Field(_v_patterns, _c2); - camlidl_ml2c_z3_Z3_pattern(_v3, &patterns[_c2], _ctx); - } - num_patterns = _c1; - _c4 = Wosize_val(_v_sorts); - sorts = camlidl_malloc(_c4 * sizeof(Z3_sort const ), _ctx); - for (_c5 = 0; _c5 < _c4; _c5++) { - _v6 = Field(_v_sorts, _c5); - camlidl_ml2c_z3_Z3_sort(_v6, &sorts[_c5], _ctx); - } - num_decls = _c4; - _c7 = Wosize_val(_v_decl_names); - decl_names = camlidl_malloc(_c7 * sizeof(Z3_symbol const ), _ctx); - for (_c8 = 0; _c8 < _c7; _c8++) { - _v9 = Field(_v_decl_names, _c8); - camlidl_ml2c_z3_Z3_symbol(_v9, &decl_names[_c8], _ctx); - } - num_decls = _c7; - camlidl_ml2c_z3_Z3_ast(_v_body, &body, _ctx); - _res = Z3_mk_quantifier(c, is_forall, weight, num_patterns, patterns, num_decls, sorts, decl_names, body); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_quantifier_bytecode(value * argv, int argn) -{ - return camlidl_z3_Z3_mk_quantifier(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5], argv[6]); -} - -value camlidl_z3_Z3_mk_quantifier_ex( - value _v_c, - value _v_is_forall, - value _v_weight, - value _v_quantifier_id, - value _v_skolem_id, - value _v_patterns, - value _v_no_patterns, - value _v_sorts, - value _v_decl_names, - value _v_body) -{ - Z3_context c; /*in*/ - int is_forall; /*in*/ - unsigned int weight; /*in*/ - Z3_symbol quantifier_id; /*in*/ - Z3_symbol skolem_id; /*in*/ - unsigned int num_patterns; /*in*/ - Z3_pattern const *patterns; /*in*/ - unsigned int num_no_patterns; /*in*/ - Z3_ast const *no_patterns; /*in*/ - unsigned int num_decls; /*in*/ - Z3_sort const *sorts; /*in*/ - Z3_symbol const *decl_names; /*in*/ - Z3_ast body; /*in*/ - Z3_ast _res; - mlsize_t _c1; - mlsize_t _c2; - value _v3; - mlsize_t _c4; - mlsize_t _c5; - value _v6; - mlsize_t _c7; - mlsize_t _c8; - value _v9; - mlsize_t _c10; - mlsize_t _c11; - value _v12; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - is_forall = Int_val(_v_is_forall); - weight = Int_val(_v_weight); - camlidl_ml2c_z3_Z3_symbol(_v_quantifier_id, &quantifier_id, _ctx); - camlidl_ml2c_z3_Z3_symbol(_v_skolem_id, &skolem_id, _ctx); - _c1 = Wosize_val(_v_patterns); - patterns = camlidl_malloc(_c1 * sizeof(Z3_pattern const ), _ctx); - for (_c2 = 0; _c2 < _c1; _c2++) { - _v3 = Field(_v_patterns, _c2); - camlidl_ml2c_z3_Z3_pattern(_v3, &patterns[_c2], _ctx); - } - num_patterns = _c1; - _c4 = Wosize_val(_v_no_patterns); - no_patterns = camlidl_malloc(_c4 * sizeof(Z3_ast const ), _ctx); - for (_c5 = 0; _c5 < _c4; _c5++) { - _v6 = Field(_v_no_patterns, _c5); - camlidl_ml2c_z3_Z3_ast(_v6, &no_patterns[_c5], _ctx); - } - num_no_patterns = _c4; - _c7 = Wosize_val(_v_sorts); - sorts = camlidl_malloc(_c7 * sizeof(Z3_sort const ), _ctx); - for (_c8 = 0; _c8 < _c7; _c8++) { - _v9 = Field(_v_sorts, _c8); - camlidl_ml2c_z3_Z3_sort(_v9, &sorts[_c8], _ctx); - } - num_decls = _c7; - _c10 = Wosize_val(_v_decl_names); - decl_names = camlidl_malloc(_c10 * sizeof(Z3_symbol const ), _ctx); - for (_c11 = 0; _c11 < _c10; _c11++) { - _v12 = Field(_v_decl_names, _c11); - camlidl_ml2c_z3_Z3_symbol(_v12, &decl_names[_c11], _ctx); - } - num_decls = _c10; - camlidl_ml2c_z3_Z3_ast(_v_body, &body, _ctx); - _res = Z3_mk_quantifier_ex(c, is_forall, weight, quantifier_id, skolem_id, num_patterns, patterns, num_no_patterns, no_patterns, num_decls, sorts, decl_names, body); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_quantifier_ex_bytecode(value * argv, int argn) -{ - return camlidl_z3_Z3_mk_quantifier_ex(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5], argv[6], argv[7], argv[8], argv[9]); -} - -value camlidl_z3_Z3_mk_forall_const( - value _v_c, - value _v_weight, - value _v_bound, - value _v_patterns, - value _v_body) -{ - Z3_context c; /*in*/ - unsigned int weight; /*in*/ - unsigned int num_bound; /*in*/ - Z3_app const *bound; /*in*/ - unsigned int num_patterns; /*in*/ - Z3_pattern const *patterns; /*in*/ - Z3_ast body; /*in*/ - Z3_ast _res; - mlsize_t _c1; - mlsize_t _c2; - value _v3; - mlsize_t _c4; - mlsize_t _c5; - value _v6; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - weight = Int_val(_v_weight); - _c1 = Wosize_val(_v_bound); - bound = camlidl_malloc(_c1 * sizeof(Z3_app const ), _ctx); - for (_c2 = 0; _c2 < _c1; _c2++) { - _v3 = Field(_v_bound, _c2); - camlidl_ml2c_z3_Z3_app(_v3, &bound[_c2], _ctx); - } - num_bound = _c1; - _c4 = Wosize_val(_v_patterns); - patterns = camlidl_malloc(_c4 * sizeof(Z3_pattern const ), _ctx); - for (_c5 = 0; _c5 < _c4; _c5++) { - _v6 = Field(_v_patterns, _c5); - camlidl_ml2c_z3_Z3_pattern(_v6, &patterns[_c5], _ctx); - } - num_patterns = _c4; - camlidl_ml2c_z3_Z3_ast(_v_body, &body, _ctx); - _res = Z3_mk_forall_const(c, weight, num_bound, bound, num_patterns, patterns, body); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_exists_const( - value _v_c, - value _v_weight, - value _v_bound, - value _v_patterns, - value _v_body) -{ - Z3_context c; /*in*/ - unsigned int weight; /*in*/ - unsigned int num_bound; /*in*/ - Z3_app const *bound; /*in*/ - unsigned int num_patterns; /*in*/ - Z3_pattern const *patterns; /*in*/ - Z3_ast body; /*in*/ - Z3_ast _res; - mlsize_t _c1; - mlsize_t _c2; - value _v3; - mlsize_t _c4; - mlsize_t _c5; - value _v6; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - weight = Int_val(_v_weight); - _c1 = Wosize_val(_v_bound); - bound = camlidl_malloc(_c1 * sizeof(Z3_app const ), _ctx); - for (_c2 = 0; _c2 < _c1; _c2++) { - _v3 = Field(_v_bound, _c2); - camlidl_ml2c_z3_Z3_app(_v3, &bound[_c2], _ctx); - } - num_bound = _c1; - _c4 = Wosize_val(_v_patterns); - patterns = camlidl_malloc(_c4 * sizeof(Z3_pattern const ), _ctx); - for (_c5 = 0; _c5 < _c4; _c5++) { - _v6 = Field(_v_patterns, _c5); - camlidl_ml2c_z3_Z3_pattern(_v6, &patterns[_c5], _ctx); - } - num_patterns = _c4; - camlidl_ml2c_z3_Z3_ast(_v_body, &body, _ctx); - _res = Z3_mk_exists_const(c, weight, num_bound, bound, num_patterns, patterns, body); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_quantifier_const( - value _v_c, - value _v_is_forall, - value _v_weight, - value _v_bound, - value _v_patterns, - value _v_body) -{ - Z3_context c; /*in*/ - int is_forall; /*in*/ - unsigned int weight; /*in*/ - unsigned int num_bound; /*in*/ - Z3_app const *bound; /*in*/ - unsigned int num_patterns; /*in*/ - Z3_pattern const *patterns; /*in*/ - Z3_ast body; /*in*/ - Z3_ast _res; - mlsize_t _c1; - mlsize_t _c2; - value _v3; - mlsize_t _c4; - mlsize_t _c5; - value _v6; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - is_forall = Int_val(_v_is_forall); - weight = Int_val(_v_weight); - _c1 = Wosize_val(_v_bound); - bound = camlidl_malloc(_c1 * sizeof(Z3_app const ), _ctx); - for (_c2 = 0; _c2 < _c1; _c2++) { - _v3 = Field(_v_bound, _c2); - camlidl_ml2c_z3_Z3_app(_v3, &bound[_c2], _ctx); - } - num_bound = _c1; - _c4 = Wosize_val(_v_patterns); - patterns = camlidl_malloc(_c4 * sizeof(Z3_pattern const ), _ctx); - for (_c5 = 0; _c5 < _c4; _c5++) { - _v6 = Field(_v_patterns, _c5); - camlidl_ml2c_z3_Z3_pattern(_v6, &patterns[_c5], _ctx); - } - num_patterns = _c4; - camlidl_ml2c_z3_Z3_ast(_v_body, &body, _ctx); - _res = Z3_mk_quantifier_const(c, is_forall, weight, num_bound, bound, num_patterns, patterns, body); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_quantifier_const_bytecode(value * argv, int argn) -{ - return camlidl_z3_Z3_mk_quantifier_const(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]); -} - -value camlidl_z3_Z3_mk_quantifier_const_ex( - value _v_c, - value _v_is_forall, - value _v_weight, - value _v_quantifier_id, - value _v_skolem_id, - value _v_bound, - value _v_patterns, - value _v_no_patterns, - value _v_body) -{ - Z3_context c; /*in*/ - int is_forall; /*in*/ - unsigned int weight; /*in*/ - Z3_symbol quantifier_id; /*in*/ - Z3_symbol skolem_id; /*in*/ - unsigned int num_bound; /*in*/ - Z3_app const *bound; /*in*/ - unsigned int num_patterns; /*in*/ - Z3_pattern const *patterns; /*in*/ - unsigned int num_no_patterns; /*in*/ - Z3_ast const *no_patterns; /*in*/ - Z3_ast body; /*in*/ - Z3_ast _res; - mlsize_t _c1; - mlsize_t _c2; - value _v3; - mlsize_t _c4; - mlsize_t _c5; - value _v6; - mlsize_t _c7; - mlsize_t _c8; - value _v9; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - is_forall = Int_val(_v_is_forall); - weight = Int_val(_v_weight); - camlidl_ml2c_z3_Z3_symbol(_v_quantifier_id, &quantifier_id, _ctx); - camlidl_ml2c_z3_Z3_symbol(_v_skolem_id, &skolem_id, _ctx); - _c1 = Wosize_val(_v_bound); - bound = camlidl_malloc(_c1 * sizeof(Z3_app const ), _ctx); - for (_c2 = 0; _c2 < _c1; _c2++) { - _v3 = Field(_v_bound, _c2); - camlidl_ml2c_z3_Z3_app(_v3, &bound[_c2], _ctx); - } - num_bound = _c1; - _c4 = Wosize_val(_v_patterns); - patterns = camlidl_malloc(_c4 * sizeof(Z3_pattern const ), _ctx); - for (_c5 = 0; _c5 < _c4; _c5++) { - _v6 = Field(_v_patterns, _c5); - camlidl_ml2c_z3_Z3_pattern(_v6, &patterns[_c5], _ctx); - } - num_patterns = _c4; - _c7 = Wosize_val(_v_no_patterns); - no_patterns = camlidl_malloc(_c7 * sizeof(Z3_ast const ), _ctx); - for (_c8 = 0; _c8 < _c7; _c8++) { - _v9 = Field(_v_no_patterns, _c8); - camlidl_ml2c_z3_Z3_ast(_v9, &no_patterns[_c8], _ctx); - } - num_no_patterns = _c7; - camlidl_ml2c_z3_Z3_ast(_v_body, &body, _ctx); - _res = Z3_mk_quantifier_const_ex(c, is_forall, weight, quantifier_id, skolem_id, num_bound, bound, num_patterns, patterns, num_no_patterns, no_patterns, body); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_mk_quantifier_const_ex_bytecode(value * argv, int argn) -{ - return camlidl_z3_Z3_mk_quantifier_const_ex(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5], argv[6], argv[7], argv[8]); -} - -value camlidl_z3_Z3_get_ast_id( - value _v_c, - value _v_t) -{ - Z3_context c; /*in*/ - Z3_ast t; /*in*/ - unsigned int _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t, &t, _ctx); - _res = Z3_get_ast_id(c, t); - _vres = Val_int(_res); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_func_decl_id( - value _v_c, - value _v_f) -{ - Z3_context c; /*in*/ - Z3_func_decl f; /*in*/ - unsigned int _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_func_decl(_v_f, &f, _ctx); - _res = Z3_get_func_decl_id(c, f); - _vres = Val_int(_res); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_sort_id( - value _v_c, - value _v_s) -{ - Z3_context c; /*in*/ - Z3_sort s; /*in*/ - unsigned int _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_sort(_v_s, &s, _ctx); - _res = Z3_get_sort_id(c, s); - _vres = Val_int(_res); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_is_well_sorted( - value _v_c, - value _v_t) -{ - Z3_context c; /*in*/ - Z3_ast t; /*in*/ - int _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t, &t, _ctx); - _res = Z3_is_well_sorted(c, t); - _vres = Val_int(_res); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_symbol_kind( - value _v_c, - value _v_s) -{ - Z3_context c; /*in*/ - Z3_symbol s; /*in*/ - Z3_symbol_kind _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_symbol(_v_s, &s, _ctx); - _res = Z3_get_symbol_kind(c, s); - _vres = camlidl_c2ml_z3_Z3_symbol_kind(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_symbol_int( - value _v_c, - value _v_s) -{ - Z3_context c; /*in*/ - Z3_symbol s; /*in*/ - int _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_symbol(_v_s, &s, _ctx); - _res = Z3_get_symbol_int(c, s); - _vres = Val_int(_res); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_symbol_string( - value _v_c, - value _v_s) -{ - Z3_context c; /*in*/ - Z3_symbol s; /*in*/ - char const *_res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_symbol(_v_s, &s, _ctx); - _res = Z3_get_symbol_string(c, s); - _vres = copy_string(_res); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_ast_kind( - value _v_c, - value _v_a) -{ - Z3_context c; /*in*/ - Z3_ast a; /*in*/ - Z3_ast_kind _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_a, &a, _ctx); - _res = Z3_get_ast_kind(c, a); - _vres = camlidl_c2ml_z3_Z3_ast_kind(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_numeral_string( - value _v_c, - value _v_a) -{ - Z3_context c; /*in*/ - Z3_ast a; /*in*/ - char const *_res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_a, &a, _ctx); - _res = Z3_get_numeral_string(c, a); - _vres = copy_string(_res); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_numeral_small( - value _v_c, - value _v_a) -{ - Z3_context c; /*in*/ - Z3_ast a; /*in*/ - __int64 *num; /*out*/ - __int64 *den; /*out*/ - int _res; - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - __int64 _c1; - __int64 _c2; - value _vresult; - value _vres[3] = { 0, 0, 0, }; - - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_a, &a, _ctx); - num = &_c1; - den = &_c2; - _res = Z3_get_numeral_small(c, a, num, den); - Begin_roots_block(_vres, 3) - _vres[0] = Val_int(_res); - _vres[1] = copy_int64(*num); - _vres[2] = copy_int64(*den); - _vresult = camlidl_alloc_small(3, 0); - Field(_vresult, 0) = _vres[0]; - Field(_vresult, 1) = _vres[1]; - Field(_vresult, 2) = _vres[2]; - End_roots() - camlidl_free(_ctx); - return _vresult; -} - -value camlidl_z3_Z3_get_numeral_int( - value _v_c, - value _v_v) -{ - Z3_context c; /*in*/ - Z3_ast v; /*in*/ - int *i; /*out*/ - int _res; - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - int _c1; - value _vresult; - value _vres[2] = { 0, 0, }; - - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_v, &v, _ctx); - i = &_c1; - _res = Z3_get_numeral_int(c, v, i); - Begin_roots_block(_vres, 2) - _vres[0] = Val_int(_res); - _vres[1] = Val_int(*i); - _vresult = camlidl_alloc_small(2, 0); - Field(_vresult, 0) = _vres[0]; - Field(_vresult, 1) = _vres[1]; - End_roots() - camlidl_free(_ctx); - return _vresult; -} - -value camlidl_z3_Z3_get_numeral_uint( - value _v_c, - value _v_v) -{ - Z3_context c; /*in*/ - Z3_ast v; /*in*/ - unsigned int *u; /*out*/ - int _res; - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - unsigned int _c1; - value _vresult; - value _vres[2] = { 0, 0, }; - - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_v, &v, _ctx); - u = &_c1; - _res = Z3_get_numeral_uint(c, v, u); - Begin_roots_block(_vres, 2) - _vres[0] = Val_int(_res); - _vres[1] = Val_int(*u); - _vresult = camlidl_alloc_small(2, 0); - Field(_vresult, 0) = _vres[0]; - Field(_vresult, 1) = _vres[1]; - End_roots() - camlidl_free(_ctx); - return _vresult; -} - -value camlidl_z3_Z3_get_bool_value( - value _v_c, - value _v_a) -{ - Z3_context c; /*in*/ - Z3_ast a; /*in*/ - Z3_lbool _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_a, &a, _ctx); - _res = Z3_get_bool_value(c, a); - _vres = camlidl_c2ml_z3_Z3_lbool(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_app_decl( - value _v_c, - value _v_a) -{ - Z3_context c; /*in*/ - Z3_app a; /*in*/ - Z3_func_decl _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_app(_v_a, &a, _ctx); - _res = Z3_get_app_decl(c, a); - _vres = camlidl_c2ml_z3_Z3_func_decl(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_app_num_args( - value _v_c, - value _v_a) -{ - Z3_context c; /*in*/ - Z3_app a; /*in*/ - unsigned int _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_app(_v_a, &a, _ctx); - _res = Z3_get_app_num_args(c, a); - _vres = Val_int(_res); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_app_arg( - value _v_c, - value _v_a, - value _v_i) -{ - Z3_context c; /*in*/ - Z3_app a; /*in*/ - unsigned int i; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_app(_v_a, &a, _ctx); - i = Int_val(_v_i); - _res = Z3_get_app_arg(c, a, i); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_index_value( - value _v_c, - value _v_a) -{ - Z3_context c; /*in*/ - Z3_ast a; /*in*/ - unsigned int _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_a, &a, _ctx); - _res = Z3_get_index_value(c, a); - _vres = Val_int(_res); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_is_quantifier_forall( - value _v_c, - value _v_a) -{ - Z3_context c; /*in*/ - Z3_ast a; /*in*/ - int _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_a, &a, _ctx); - _res = Z3_is_quantifier_forall(c, a); - _vres = Val_int(_res); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_quantifier_weight( - value _v_c, - value _v_a) -{ - Z3_context c; /*in*/ - Z3_ast a; /*in*/ - unsigned int _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_a, &a, _ctx); - _res = Z3_get_quantifier_weight(c, a); - _vres = Val_int(_res); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_quantifier_num_patterns( - value _v_c, - value _v_a) -{ - Z3_context c; /*in*/ - Z3_ast a; /*in*/ - unsigned int _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_a, &a, _ctx); - _res = Z3_get_quantifier_num_patterns(c, a); - _vres = Val_int(_res); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_quantifier_pattern_ast( - value _v_c, - value _v_a, - value _v_i) -{ - Z3_context c; /*in*/ - Z3_ast a; /*in*/ - unsigned int i; /*in*/ - Z3_pattern _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_a, &a, _ctx); - i = Int_val(_v_i); - _res = Z3_get_quantifier_pattern_ast(c, a, i); - _vres = camlidl_c2ml_z3_Z3_pattern(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_quantifier_num_no_patterns( - value _v_c, - value _v_a) -{ - Z3_context c; /*in*/ - Z3_ast a; /*in*/ - unsigned int _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_a, &a, _ctx); - _res = Z3_get_quantifier_num_no_patterns(c, a); - _vres = Val_int(_res); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_quantifier_no_pattern_ast( - value _v_c, - value _v_a, - value _v_i) -{ - Z3_context c; /*in*/ - Z3_ast a; /*in*/ - unsigned int i; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_a, &a, _ctx); - i = Int_val(_v_i); - _res = Z3_get_quantifier_no_pattern_ast(c, a, i); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_quantifier_bound_name( - value _v_c, - value _v_a, - value _v_i) -{ - Z3_context c; /*in*/ - Z3_ast a; /*in*/ - unsigned int i; /*in*/ - Z3_symbol _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_a, &a, _ctx); - i = Int_val(_v_i); - _res = Z3_get_quantifier_bound_name(c, a, i); - _vres = camlidl_c2ml_z3_Z3_symbol(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_quantifier_bound_sort( - value _v_c, - value _v_a, - value _v_i) -{ - Z3_context c; /*in*/ - Z3_ast a; /*in*/ - unsigned int i; /*in*/ - Z3_sort _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_a, &a, _ctx); - i = Int_val(_v_i); - _res = Z3_get_quantifier_bound_sort(c, a, i); - _vres = camlidl_c2ml_z3_Z3_sort(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_quantifier_body( - value _v_c, - value _v_a) -{ - Z3_context c; /*in*/ - Z3_ast a; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_a, &a, _ctx); - _res = Z3_get_quantifier_body(c, a); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_quantifier_num_bound( - value _v_c, - value _v_a) -{ - Z3_context c; /*in*/ - Z3_ast a; /*in*/ - unsigned int _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_a, &a, _ctx); - _res = Z3_get_quantifier_num_bound(c, a); - _vres = Val_int(_res); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_decl_name( - value _v_c, - value _v_d) -{ - Z3_context c; /*in*/ - Z3_func_decl d; /*in*/ - Z3_symbol _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_func_decl(_v_d, &d, _ctx); - _res = Z3_get_decl_name(c, d); - _vres = camlidl_c2ml_z3_Z3_symbol(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_decl_num_parameters( - value _v_c, - value _v_d) -{ - Z3_context c; /*in*/ - Z3_func_decl d; /*in*/ - unsigned int _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_func_decl(_v_d, &d, _ctx); - _res = Z3_get_decl_num_parameters(c, d); - _vres = Val_int(_res); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_decl_parameter_kind( - value _v_c, - value _v_d, - value _v_idx) -{ - Z3_context c; /*in*/ - Z3_func_decl d; /*in*/ - unsigned int idx; /*in*/ - Z3_parameter_kind _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_func_decl(_v_d, &d, _ctx); - idx = Int_val(_v_idx); - _res = Z3_get_decl_parameter_kind(c, d, idx); - _vres = camlidl_c2ml_z3_Z3_parameter_kind(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_decl_int_parameter( - value _v_c, - value _v_d, - value _v_idx) -{ - Z3_context c; /*in*/ - Z3_func_decl d; /*in*/ - unsigned int idx; /*in*/ - int _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_func_decl(_v_d, &d, _ctx); - idx = Int_val(_v_idx); - _res = Z3_get_decl_int_parameter(c, d, idx); - _vres = Val_int(_res); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_decl_double_parameter( - value _v_c, - value _v_d, - value _v_idx) -{ - Z3_context c; /*in*/ - Z3_func_decl d; /*in*/ - unsigned int idx; /*in*/ - double _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_func_decl(_v_d, &d, _ctx); - idx = Int_val(_v_idx); - _res = Z3_get_decl_double_parameter(c, d, idx); - _vres = copy_double(_res); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_decl_symbol_parameter( - value _v_c, - value _v_d, - value _v_idx) -{ - Z3_context c; /*in*/ - Z3_func_decl d; /*in*/ - unsigned int idx; /*in*/ - Z3_symbol _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_func_decl(_v_d, &d, _ctx); - idx = Int_val(_v_idx); - _res = Z3_get_decl_symbol_parameter(c, d, idx); - _vres = camlidl_c2ml_z3_Z3_symbol(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_decl_sort_parameter( - value _v_c, - value _v_d, - value _v_idx) -{ - Z3_context c; /*in*/ - Z3_func_decl d; /*in*/ - unsigned int idx; /*in*/ - Z3_sort _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_func_decl(_v_d, &d, _ctx); - idx = Int_val(_v_idx); - _res = Z3_get_decl_sort_parameter(c, d, idx); - _vres = camlidl_c2ml_z3_Z3_sort(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_decl_ast_parameter( - value _v_c, - value _v_d, - value _v_idx) -{ - Z3_context c; /*in*/ - Z3_func_decl d; /*in*/ - unsigned int idx; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_func_decl(_v_d, &d, _ctx); - idx = Int_val(_v_idx); - _res = Z3_get_decl_ast_parameter(c, d, idx); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_decl_func_decl_parameter( - value _v_c, - value _v_d, - value _v_idx) -{ - Z3_context c; /*in*/ - Z3_func_decl d; /*in*/ - unsigned int idx; /*in*/ - Z3_func_decl _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_func_decl(_v_d, &d, _ctx); - idx = Int_val(_v_idx); - _res = Z3_get_decl_func_decl_parameter(c, d, idx); - _vres = camlidl_c2ml_z3_Z3_func_decl(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_decl_rational_parameter( - value _v_c, - value _v_d, - value _v_idx) -{ - Z3_context c; /*in*/ - Z3_func_decl d; /*in*/ - unsigned int idx; /*in*/ - char const *_res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_func_decl(_v_d, &d, _ctx); - idx = Int_val(_v_idx); - _res = Z3_get_decl_rational_parameter(c, d, idx); - _vres = copy_string(_res); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_sort_name( - value _v_c, - value _v_d) -{ - Z3_context c; /*in*/ - Z3_sort d; /*in*/ - Z3_symbol _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_sort(_v_d, &d, _ctx); - _res = Z3_get_sort_name(c, d); - _vres = camlidl_c2ml_z3_Z3_symbol(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_sort( - value _v_c, - value _v_a) -{ - Z3_context c; /*in*/ - Z3_ast a; /*in*/ - Z3_sort _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_a, &a, _ctx); - _res = Z3_get_sort(c, a); - _vres = camlidl_c2ml_z3_Z3_sort(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_domain_size( - value _v_c, - value _v_d) -{ - Z3_context c; /*in*/ - Z3_func_decl d; /*in*/ - unsigned int _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_func_decl(_v_d, &d, _ctx); - _res = Z3_get_domain_size(c, d); - _vres = Val_int(_res); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_domain( - value _v_c, - value _v_d, - value _v_i) -{ - Z3_context c; /*in*/ - Z3_func_decl d; /*in*/ - unsigned int i; /*in*/ - Z3_sort _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_func_decl(_v_d, &d, _ctx); - i = Int_val(_v_i); - _res = Z3_get_domain(c, d, i); - _vres = camlidl_c2ml_z3_Z3_sort(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_range( - value _v_c, - value _v_d) -{ - Z3_context c; /*in*/ - Z3_func_decl d; /*in*/ - Z3_sort _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_func_decl(_v_d, &d, _ctx); - _res = Z3_get_range(c, d); - _vres = camlidl_c2ml_z3_Z3_sort(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_sort_kind( - value _v_c, - value _v_t) -{ - Z3_context c; /*in*/ - Z3_sort t; /*in*/ - Z3_sort_kind _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_sort(_v_t, &t, _ctx); - _res = Z3_get_sort_kind(c, t); - _vres = camlidl_c2ml_z3_Z3_sort_kind(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_bv_sort_size( - value _v_c, - value _v_t) -{ - Z3_context c; /*in*/ - Z3_sort t; /*in*/ - unsigned int _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_sort(_v_t, &t, _ctx); - _res = Z3_get_bv_sort_size(c, t); - _vres = Val_int(_res); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_array_sort_domain( - value _v_c, - value _v_t) -{ - Z3_context c; /*in*/ - Z3_sort t; /*in*/ - Z3_sort _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_sort(_v_t, &t, _ctx); - _res = Z3_get_array_sort_domain(c, t); - _vres = camlidl_c2ml_z3_Z3_sort(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_array_sort_range( - value _v_c, - value _v_t) -{ - Z3_context c; /*in*/ - Z3_sort t; /*in*/ - Z3_sort _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_sort(_v_t, &t, _ctx); - _res = Z3_get_array_sort_range(c, t); - _vres = camlidl_c2ml_z3_Z3_sort(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_tuple_sort_mk_decl( - value _v_c, - value _v_t) -{ - Z3_context c; /*in*/ - Z3_sort t; /*in*/ - Z3_func_decl _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_sort(_v_t, &t, _ctx); - _res = Z3_get_tuple_sort_mk_decl(c, t); - _vres = camlidl_c2ml_z3_Z3_func_decl(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_decl_kind( - value _v_c, - value _v_d) -{ - Z3_context c; /*in*/ - Z3_func_decl d; /*in*/ - Z3_decl_kind _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_func_decl(_v_d, &d, _ctx); - _res = Z3_get_decl_kind(c, d); - _vres = camlidl_c2ml_z3_Z3_decl_kind(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_tuple_sort_num_fields( - value _v_c, - value _v_t) -{ - Z3_context c; /*in*/ - Z3_sort t; /*in*/ - unsigned int _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_sort(_v_t, &t, _ctx); - _res = Z3_get_tuple_sort_num_fields(c, t); - _vres = Val_int(_res); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_tuple_sort_field_decl( - value _v_c, - value _v_t, - value _v_i) -{ - Z3_context c; /*in*/ - Z3_sort t; /*in*/ - unsigned int i; /*in*/ - Z3_func_decl _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_sort(_v_t, &t, _ctx); - i = Int_val(_v_i); - _res = Z3_get_tuple_sort_field_decl(c, t, i); - _vres = camlidl_c2ml_z3_Z3_func_decl(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_datatype_sort_num_constructors( - value _v_c, - value _v_t) -{ - Z3_context c; /*in*/ - Z3_sort t; /*in*/ - unsigned int _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_sort(_v_t, &t, _ctx); - _res = Z3_get_datatype_sort_num_constructors(c, t); - _vres = Val_int(_res); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_datatype_sort_constructor( - value _v_c, - value _v_t, - value _v_idx) -{ - Z3_context c; /*in*/ - Z3_sort t; /*in*/ - unsigned int idx; /*in*/ - Z3_func_decl _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_sort(_v_t, &t, _ctx); - idx = Int_val(_v_idx); - _res = Z3_get_datatype_sort_constructor(c, t, idx); - _vres = camlidl_c2ml_z3_Z3_func_decl(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_datatype_sort_recognizer( - value _v_c, - value _v_t, - value _v_idx) -{ - Z3_context c; /*in*/ - Z3_sort t; /*in*/ - unsigned int idx; /*in*/ - Z3_func_decl _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_sort(_v_t, &t, _ctx); - idx = Int_val(_v_idx); - _res = Z3_get_datatype_sort_recognizer(c, t, idx); - _vres = camlidl_c2ml_z3_Z3_func_decl(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_datatype_sort_constructor_accessor( - value _v_c, - value _v_t, - value _v_idx_c, - value _v_idx_a) -{ - Z3_context c; /*in*/ - Z3_sort t; /*in*/ - unsigned int idx_c; /*in*/ - unsigned int idx_a; /*in*/ - Z3_func_decl _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_sort(_v_t, &t, _ctx); - idx_c = Int_val(_v_idx_c); - idx_a = Int_val(_v_idx_a); - _res = Z3_get_datatype_sort_constructor_accessor(c, t, idx_c, idx_a); - _vres = camlidl_c2ml_z3_Z3_func_decl(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_relation_arity( - value _v_c, - value _v_s) -{ - Z3_context c; /*in*/ - Z3_sort s; /*in*/ - unsigned int _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_sort(_v_s, &s, _ctx); - _res = Z3_get_relation_arity(c, s); - _vres = Val_int(_res); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_relation_column( - value _v_c, - value _v_s, - value _v_col) -{ - Z3_context c; /*in*/ - Z3_sort s; /*in*/ - unsigned int col; /*in*/ - Z3_sort _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_sort(_v_s, &s, _ctx); - col = Int_val(_v_col); - _res = Z3_get_relation_column(c, s, col); - _vres = camlidl_c2ml_z3_Z3_sort(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_pattern_num_terms( - value _v_c, - value _v_p) -{ - Z3_context c; /*in*/ - Z3_pattern p; /*in*/ - unsigned int _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_pattern(_v_p, &p, _ctx); - _res = Z3_get_pattern_num_terms(c, p); - _vres = Val_int(_res); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_pattern( - value _v_c, - value _v_p, - value _v_idx) -{ - Z3_context c; /*in*/ - Z3_pattern p; /*in*/ - unsigned int idx; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_pattern(_v_p, &p, _ctx); - idx = Int_val(_v_idx); - _res = Z3_get_pattern(c, p, idx); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_simplify( - value _v_c, - value _v_a) -{ - Z3_context c; /*in*/ - Z3_ast a; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_a, &a, _ctx); - _res = Z3_simplify(c, a); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_update_term( - value _v_c, - value _v_a, - value _v_args) -{ - Z3_context c; /*in*/ - Z3_ast a; /*in*/ - unsigned int num_args; /*in*/ - Z3_ast *args; /*in*/ - Z3_ast _res; - mlsize_t _c1; - mlsize_t _c2; - value _v3; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_a, &a, _ctx); - _c1 = Wosize_val(_v_args); - args = camlidl_malloc(_c1 * sizeof(Z3_ast ), _ctx); - for (_c2 = 0; _c2 < _c1; _c2++) { - _v3 = Field(_v_args, _c2); - camlidl_ml2c_z3_Z3_ast(_v3, &args[_c2], _ctx); - } - num_args = _c1; - _res = Z3_update_term(c, a, num_args, args); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_substitute( - value _v_c, - value _v_a, - value _v_from, - value _v_to) -{ - Z3_context c; /*in*/ - Z3_ast a; /*in*/ - unsigned int num_exprs; /*in*/ - Z3_ast *from; /*in*/ - Z3_ast *to; /*in*/ - Z3_ast _res; - mlsize_t _c1; - mlsize_t _c2; - value _v3; - mlsize_t _c4; - mlsize_t _c5; - value _v6; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_a, &a, _ctx); - _c1 = Wosize_val(_v_from); - from = camlidl_malloc(_c1 * sizeof(Z3_ast ), _ctx); - for (_c2 = 0; _c2 < _c1; _c2++) { - _v3 = Field(_v_from, _c2); - camlidl_ml2c_z3_Z3_ast(_v3, &from[_c2], _ctx); - } - num_exprs = _c1; - _c4 = Wosize_val(_v_to); - to = camlidl_malloc(_c4 * sizeof(Z3_ast ), _ctx); - for (_c5 = 0; _c5 < _c4; _c5++) { - _v6 = Field(_v_to, _c5); - camlidl_ml2c_z3_Z3_ast(_v6, &to[_c5], _ctx); - } - num_exprs = _c4; - _res = Z3_substitute(c, a, num_exprs, from, to); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_substitute_vars( - value _v_c, - value _v_a, - value _v_to) -{ - Z3_context c; /*in*/ - Z3_ast a; /*in*/ - unsigned int num_exprs; /*in*/ - Z3_ast *to; /*in*/ - Z3_ast _res; - mlsize_t _c1; - mlsize_t _c2; - value _v3; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_a, &a, _ctx); - _c1 = Wosize_val(_v_to); - to = camlidl_malloc(_c1 * sizeof(Z3_ast ), _ctx); - for (_c2 = 0; _c2 < _c1; _c2++) { - _v3 = Field(_v_to, _c2); - camlidl_ml2c_z3_Z3_ast(_v3, &to[_c2], _ctx); - } - num_exprs = _c1; - _res = Z3_substitute_vars(c, a, num_exprs, to); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_sort_to_ast( - value _v_c, - value _v_s) -{ - Z3_context c; /*in*/ - Z3_sort s; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_sort(_v_s, &s, _ctx); - _res = Z3_sort_to_ast(c, s); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_func_decl_to_ast( - value _v_c, - value _v_f) -{ - Z3_context c; /*in*/ - Z3_func_decl f; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_func_decl(_v_f, &f, _ctx); - _res = Z3_func_decl_to_ast(c, f); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_pattern_to_ast( - value _v_c, - value _v_p) -{ - Z3_context c; /*in*/ - Z3_pattern p; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_pattern(_v_p, &p, _ctx); - _res = Z3_pattern_to_ast(c, p); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_app_to_ast( - value _v_c, - value _v_a) -{ - Z3_context c; /*in*/ - Z3_app a; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_app(_v_a, &a, _ctx); - _res = Z3_app_to_ast(c, a); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_to_app( - value _v_c, - value _v_a) -{ - Z3_context c; /*in*/ - Z3_ast a; /*in*/ - Z3_app _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_a, &a, _ctx); - _res = Z3_to_app(c, a); - _vres = camlidl_c2ml_z3_Z3_app(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_push( - value _v_c) -{ - Z3_context c; /*in*/ - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - Z3_push(c); - camlidl_free(_ctx); - return Val_unit; -} - -value camlidl_z3_Z3_pop( - value _v_c, - value _v_num_scopes) -{ - Z3_context c; /*in*/ - unsigned int num_scopes; /*in*/ - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - num_scopes = Int_val(_v_num_scopes); - Z3_pop(c, num_scopes); - camlidl_free(_ctx); - return Val_unit; -} - -value camlidl_z3_Z3_get_num_scopes( - value _v_c) -{ - Z3_context c; /*in*/ - unsigned int _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - _res = Z3_get_num_scopes(c); - _vres = Val_int(_res); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_persist_ast( - value _v_c, - value _v_a, - value _v_num_scopes) -{ - Z3_context c; /*in*/ - Z3_ast a; /*in*/ - unsigned int num_scopes; /*in*/ - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_a, &a, _ctx); - num_scopes = Int_val(_v_num_scopes); - Z3_persist_ast(c, a, num_scopes); - camlidl_free(_ctx); - return Val_unit; -} - -value camlidl_z3_Z3_assert_cnstr( - value _v_c, - value _v_a) -{ - Z3_context c; /*in*/ - Z3_ast a; /*in*/ - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_a, &a, _ctx); - Z3_assert_cnstr(c, a); - camlidl_free(_ctx); - return Val_unit; -} - -value camlidl_z3_Z3_check_and_get_model( - value _v_c) -{ - Z3_context c; /*in*/ - Z3_model *m; /*out*/ - Z3_lbool _res; - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - Z3_model _c1; - value _vresult; - value _vres[2] = { 0, 0, }; - - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - m = &_c1; - _res = Z3_check_and_get_model(c, m); - Begin_roots_block(_vres, 2) - _vres[0] = camlidl_c2ml_z3_Z3_lbool(&_res, _ctx); - _vres[1] = camlidl_c2ml_z3_Z3_model(&*m, _ctx); - _vresult = camlidl_alloc_small(2, 0); - Field(_vresult, 0) = _vres[0]; - Field(_vresult, 1) = _vres[1]; - End_roots() - camlidl_free(_ctx); - return _vresult; -} - -value camlidl_z3_Z3_check( - value _v_c) -{ - Z3_context c; /*in*/ - Z3_lbool _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - _res = Z3_check(c); - _vres = camlidl_c2ml_z3_Z3_lbool(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_check_assumptions( - value _v_c, - value _v_assumptions, - value _v_core_size, - value _v_core) -{ - Z3_context c; /*in*/ - unsigned int num_assumptions; /*in*/ - Z3_ast *assumptions; /*in*/ - Z3_model *m; /*out*/ - Z3_ast *proof; /*out*/ - unsigned int *core_size; /*in,out*/ - Z3_ast *core; /*in,out*/ - Z3_lbool _res; - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - mlsize_t _c1; - mlsize_t _c2; - value _v3; - unsigned int _c4; - mlsize_t _c5; - mlsize_t _c6; - value _v7; - Z3_model _c8; - Z3_ast _c9; - mlsize_t _c10; - value _v11; - value _vresult; - value _vres[5] = { 0, 0, 0, 0, 0, }; - - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - _c1 = Wosize_val(_v_assumptions); - assumptions = camlidl_malloc(_c1 * sizeof(Z3_ast ), _ctx); - for (_c2 = 0; _c2 < _c1; _c2++) { - _v3 = Field(_v_assumptions, _c2); - camlidl_ml2c_z3_Z3_ast(_v3, &assumptions[_c2], _ctx); - } - num_assumptions = _c1; - core_size = &_c4; - _c4 = Int_val(_v_core_size); - _c5 = Wosize_val(_v_core); - core = camlidl_malloc(_c5 * sizeof(Z3_ast ), _ctx); - for (_c6 = 0; _c6 < _c5; _c6++) { - _v7 = Field(_v_core, _c6); - camlidl_ml2c_z3_Z3_ast(_v7, &core[_c6], _ctx); - } - num_assumptions = _c5; - m = &_c8; - proof = &_c9; - _res = Z3_check_assumptions(c, num_assumptions, assumptions, m, proof, core_size, core); - Begin_roots_block(_vres, 5) - _vres[0] = camlidl_c2ml_z3_Z3_lbool(&_res, _ctx); - _vres[1] = camlidl_c2ml_z3_Z3_model(&*m, _ctx); - _vres[2] = camlidl_c2ml_z3_Z3_ast(&*proof, _ctx); - _vres[3] = Val_int(*core_size); - _vres[4] = camlidl_alloc(num_assumptions, 0); - Begin_root(_vres[4]) - for (_c10 = 0; _c10 < num_assumptions; _c10++) { - _v11 = camlidl_c2ml_z3_Z3_ast(&core[_c10], _ctx); - modify(&Field(_vres[4], _c10), _v11); - } - End_roots() - _vresult = camlidl_alloc_small(5, 0); - { mlsize_t _c12; - for (_c12 = 0; _c12 < 5; _c12++) Field(_vresult, _c12) = _vres[_c12]; - } - End_roots() - camlidl_free(_ctx); - return _vresult; -} - -value camlidl_z3_Z3_get_implied_equalities( - value _v_c, - value _v_terms) -{ - Z3_context c; /*in*/ - unsigned int num_terms; /*in*/ - Z3_ast *terms; /*in*/ - unsigned int *class_ids; /*out*/ - Z3_lbool _res; - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - mlsize_t _c1; - mlsize_t _c2; - value _v3; - mlsize_t _c4; - value _v5; - value _vresult; - value _vres[2] = { 0, 0, }; - - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - _c1 = Wosize_val(_v_terms); - terms = camlidl_malloc(_c1 * sizeof(Z3_ast ), _ctx); - for (_c2 = 0; _c2 < _c1; _c2++) { - _v3 = Field(_v_terms, _c2); - camlidl_ml2c_z3_Z3_ast(_v3, &terms[_c2], _ctx); - } - num_terms = _c1; - class_ids = camlidl_malloc(num_terms * sizeof(unsigned int ), _ctx); - _res = Z3_get_implied_equalities(c, num_terms, terms, class_ids); - Begin_roots_block(_vres, 2) - _vres[0] = camlidl_c2ml_z3_Z3_lbool(&_res, _ctx); - _vres[1] = camlidl_alloc(num_terms, 0); - for (_c4 = 0; _c4 < num_terms; _c4++) { - _v5 = Val_int(class_ids[_c4]); - modify(&Field(_vres[1], _c4), _v5); - } - _vresult = camlidl_alloc_small(2, 0); - Field(_vresult, 0) = _vres[0]; - Field(_vresult, 1) = _vres[1]; - End_roots() - camlidl_free(_ctx); - return _vresult; -} - -value camlidl_z3_Z3_del_model( - value _v_c, - value _v_m) -{ - Z3_context c; /*in*/ - Z3_model m; /*in*/ - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_model(_v_m, &m, _ctx); - Z3_del_model(c, m); - camlidl_free(_ctx); - return Val_unit; -} - -value camlidl_z3_Z3_soft_check_cancel( - value _v_c) -{ - Z3_context c; /*in*/ - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - Z3_soft_check_cancel(c); - camlidl_free(_ctx); - return Val_unit; -} - -value camlidl_z3_Z3_get_search_failure( - value _v_c) -{ - Z3_context c; /*in*/ - Z3_search_failure _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - _res = Z3_get_search_failure(c); - _vres = camlidl_c2ml_z3_Z3_search_failure(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_relevant_labels( - value _v_c) -{ - Z3_context c; /*in*/ - Z3_literals _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - _res = Z3_get_relevant_labels(c); - _vres = camlidl_c2ml_z3_Z3_literals(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_relevant_literals( - value _v_c) -{ - Z3_context c; /*in*/ - Z3_literals _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - _res = Z3_get_relevant_literals(c); - _vres = camlidl_c2ml_z3_Z3_literals(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_guessed_literals( - value _v_c) -{ - Z3_context c; /*in*/ - Z3_literals _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - _res = Z3_get_guessed_literals(c); - _vres = camlidl_c2ml_z3_Z3_literals(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_del_literals( - value _v_c, - value _v_lbls) -{ - Z3_context c; /*in*/ - Z3_literals lbls; /*in*/ - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_literals(_v_lbls, &lbls, _ctx); - Z3_del_literals(c, lbls); - camlidl_free(_ctx); - return Val_unit; -} - -value camlidl_z3_Z3_get_num_literals( - value _v_c, - value _v_lbls) -{ - Z3_context c; /*in*/ - Z3_literals lbls; /*in*/ - unsigned int _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_literals(_v_lbls, &lbls, _ctx); - _res = Z3_get_num_literals(c, lbls); - _vres = Val_int(_res); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_label_symbol( - value _v_c, - value _v_lbls, - value _v_idx) -{ - Z3_context c; /*in*/ - Z3_literals lbls; /*in*/ - unsigned int idx; /*in*/ - Z3_symbol _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_literals(_v_lbls, &lbls, _ctx); - idx = Int_val(_v_idx); - _res = Z3_get_label_symbol(c, lbls, idx); - _vres = camlidl_c2ml_z3_Z3_symbol(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_literal( - value _v_c, - value _v_lbls, - value _v_idx) -{ - Z3_context c; /*in*/ - Z3_literals lbls; /*in*/ - unsigned int idx; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_literals(_v_lbls, &lbls, _ctx); - idx = Int_val(_v_idx); - _res = Z3_get_literal(c, lbls, idx); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_disable_literal( - value _v_c, - value _v_lbls, - value _v_idx) -{ - Z3_context c; /*in*/ - Z3_literals lbls; /*in*/ - unsigned int idx; /*in*/ - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_literals(_v_lbls, &lbls, _ctx); - idx = Int_val(_v_idx); - Z3_disable_literal(c, lbls, idx); - camlidl_free(_ctx); - return Val_unit; -} - -value camlidl_z3_Z3_block_literals( - value _v_c, - value _v_lbls) -{ - Z3_context c; /*in*/ - Z3_literals lbls; /*in*/ - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_literals(_v_lbls, &lbls, _ctx); - Z3_block_literals(c, lbls); - camlidl_free(_ctx); - return Val_unit; -} - -value camlidl_z3_Z3_get_model_num_constants( - value _v_c, - value _v_m) -{ - Z3_context c; /*in*/ - Z3_model m; /*in*/ - unsigned int _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_model(_v_m, &m, _ctx); - _res = Z3_get_model_num_constants(c, m); - _vres = Val_int(_res); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_model_constant( - value _v_c, - value _v_m, - value _v_i) -{ - Z3_context c; /*in*/ - Z3_model m; /*in*/ - unsigned int i; /*in*/ - Z3_func_decl _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_model(_v_m, &m, _ctx); - i = Int_val(_v_i); - _res = Z3_get_model_constant(c, m, i); - _vres = camlidl_c2ml_z3_Z3_func_decl(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_eval_func_decl( - value _v_c, - value _v_m, - value _v_decl) -{ - Z3_context c; /*in*/ - Z3_model m; /*in*/ - Z3_func_decl decl; /*in*/ - Z3_ast *v; /*out*/ - int _res; - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - Z3_ast _c1; - value _vresult; - value _vres[2] = { 0, 0, }; - - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_model(_v_m, &m, _ctx); - camlidl_ml2c_z3_Z3_func_decl(_v_decl, &decl, _ctx); - v = &_c1; - _res = Z3_eval_func_decl(c, m, decl, v); - Begin_roots_block(_vres, 2) - _vres[0] = Val_int(_res); - _vres[1] = camlidl_c2ml_z3_Z3_ast(&*v, _ctx); - _vresult = camlidl_alloc_small(2, 0); - Field(_vresult, 0) = _vres[0]; - Field(_vresult, 1) = _vres[1]; - End_roots() - camlidl_free(_ctx); - return _vresult; -} - -value camlidl_z3_Z3_is_array_value( - value _v_c, - value _v_m, - value _v_v) -{ - Z3_context c; /*in*/ - Z3_model m; /*in*/ - Z3_ast v; /*in*/ - unsigned int *num_entries; /*out*/ - int _res; - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - unsigned int _c1; - value _vresult; - value _vres[2] = { 0, 0, }; - - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_model(_v_m, &m, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_v, &v, _ctx); - num_entries = &_c1; - _res = Z3_is_array_value(c, m, v, num_entries); - Begin_roots_block(_vres, 2) - _vres[0] = Val_int(_res); - _vres[1] = Val_int(*num_entries); - _vresult = camlidl_alloc_small(2, 0); - Field(_vresult, 0) = _vres[0]; - Field(_vresult, 1) = _vres[1]; - End_roots() - camlidl_free(_ctx); - return _vresult; -} - -value camlidl_z3_Z3_get_array_value( - value _v_c, - value _v_m, - value _v_v, - value _v_indices, - value _v_values) -{ - Z3_context c; /*in*/ - Z3_model m; /*in*/ - Z3_ast v; /*in*/ - unsigned int num_entries; /*in*/ - Z3_ast *indices; /*in,out*/ - Z3_ast *values; /*in,out*/ - Z3_ast *else_value; /*out*/ - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - mlsize_t _c1; - mlsize_t _c2; - value _v3; - mlsize_t _c4; - mlsize_t _c5; - value _v6; - Z3_ast _c7; - mlsize_t _c8; - value _v9; - mlsize_t _c10; - value _v11; - value _vresult; - value _vres[3] = { 0, 0, 0, }; - - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_model(_v_m, &m, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_v, &v, _ctx); - _c1 = Wosize_val(_v_indices); - indices = camlidl_malloc(_c1 * sizeof(Z3_ast ), _ctx); - for (_c2 = 0; _c2 < _c1; _c2++) { - _v3 = Field(_v_indices, _c2); - camlidl_ml2c_z3_Z3_ast(_v3, &indices[_c2], _ctx); - } - num_entries = _c1; - _c4 = Wosize_val(_v_values); - values = camlidl_malloc(_c4 * sizeof(Z3_ast ), _ctx); - for (_c5 = 0; _c5 < _c4; _c5++) { - _v6 = Field(_v_values, _c5); - camlidl_ml2c_z3_Z3_ast(_v6, &values[_c5], _ctx); - } - num_entries = _c4; - else_value = &_c7; - Z3_get_array_value(c, m, v, num_entries, indices, values, else_value); - Begin_roots_block(_vres, 3) - _vres[0] = camlidl_alloc(num_entries, 0); - Begin_root(_vres[0]) - for (_c8 = 0; _c8 < num_entries; _c8++) { - _v9 = camlidl_c2ml_z3_Z3_ast(&indices[_c8], _ctx); - modify(&Field(_vres[0], _c8), _v9); - } - End_roots() - _vres[1] = camlidl_alloc(num_entries, 0); - Begin_root(_vres[1]) - for (_c10 = 0; _c10 < num_entries; _c10++) { - _v11 = camlidl_c2ml_z3_Z3_ast(&values[_c10], _ctx); - modify(&Field(_vres[1], _c10), _v11); - } - End_roots() - _vres[2] = camlidl_c2ml_z3_Z3_ast(&*else_value, _ctx); - _vresult = camlidl_alloc_small(3, 0); - Field(_vresult, 0) = _vres[0]; - Field(_vresult, 1) = _vres[1]; - Field(_vresult, 2) = _vres[2]; - End_roots() - camlidl_free(_ctx); - return _vresult; -} - -value camlidl_z3_Z3_get_model_num_funcs( - value _v_c, - value _v_m) -{ - Z3_context c; /*in*/ - Z3_model m; /*in*/ - unsigned int _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_model(_v_m, &m, _ctx); - _res = Z3_get_model_num_funcs(c, m); - _vres = Val_int(_res); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_model_func_decl( - value _v_c, - value _v_m, - value _v_i) -{ - Z3_context c; /*in*/ - Z3_model m; /*in*/ - unsigned int i; /*in*/ - Z3_func_decl _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_model(_v_m, &m, _ctx); - i = Int_val(_v_i); - _res = Z3_get_model_func_decl(c, m, i); - _vres = camlidl_c2ml_z3_Z3_func_decl(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_model_func_else( - value _v_c, - value _v_m, - value _v_i) -{ - Z3_context c; /*in*/ - Z3_model m; /*in*/ - unsigned int i; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_model(_v_m, &m, _ctx); - i = Int_val(_v_i); - _res = Z3_get_model_func_else(c, m, i); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_model_func_num_entries( - value _v_c, - value _v_m, - value _v_i) -{ - Z3_context c; /*in*/ - Z3_model m; /*in*/ - unsigned int i; /*in*/ - unsigned int _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_model(_v_m, &m, _ctx); - i = Int_val(_v_i); - _res = Z3_get_model_func_num_entries(c, m, i); - _vres = Val_int(_res); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_model_func_entry_num_args( - value _v_c, - value _v_m, - value _v_i, - value _v_j) -{ - Z3_context c; /*in*/ - Z3_model m; /*in*/ - unsigned int i; /*in*/ - unsigned int j; /*in*/ - unsigned int _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_model(_v_m, &m, _ctx); - i = Int_val(_v_i); - j = Int_val(_v_j); - _res = Z3_get_model_func_entry_num_args(c, m, i, j); - _vres = Val_int(_res); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_model_func_entry_arg( - value _v_c, - value _v_m, - value _v_i, - value _v_j, - value _v_k) -{ - Z3_context c; /*in*/ - Z3_model m; /*in*/ - unsigned int i; /*in*/ - unsigned int j; /*in*/ - unsigned int k; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_model(_v_m, &m, _ctx); - i = Int_val(_v_i); - j = Int_val(_v_j); - k = Int_val(_v_k); - _res = Z3_get_model_func_entry_arg(c, m, i, j, k); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_model_func_entry_value( - value _v_c, - value _v_m, - value _v_i, - value _v_j) -{ - Z3_context c; /*in*/ - Z3_model m; /*in*/ - unsigned int i; /*in*/ - unsigned int j; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_model(_v_m, &m, _ctx); - i = Int_val(_v_i); - j = Int_val(_v_j); - _res = Z3_get_model_func_entry_value(c, m, i, j); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_eval( - value _v_c, - value _v_m, - value _v_t) -{ - Z3_context c; /*in*/ - Z3_model m; /*in*/ - Z3_ast t; /*in*/ - Z3_ast *v; /*out*/ - int _res; - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - Z3_ast _c1; - value _vresult; - value _vres[2] = { 0, 0, }; - - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_model(_v_m, &m, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_t, &t, _ctx); - v = &_c1; - _res = Z3_eval(c, m, t, v); - Begin_roots_block(_vres, 2) - _vres[0] = Val_int(_res); - _vres[1] = camlidl_c2ml_z3_Z3_ast(&*v, _ctx); - _vresult = camlidl_alloc_small(2, 0); - Field(_vresult, 0) = _vres[0]; - Field(_vresult, 1) = _vres[1]; - End_roots() - camlidl_free(_ctx); - return _vresult; -} - -value camlidl_z3_Z3_eval_decl( - value _v_c, - value _v_m, - value _v_d, - value _v_args) -{ - Z3_context c; /*in*/ - Z3_model m; /*in*/ - Z3_func_decl d; /*in*/ - unsigned int num_args; /*in*/ - Z3_ast *args; /*in*/ - Z3_ast *v; /*out*/ - int _res; - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - mlsize_t _c1; - mlsize_t _c2; - value _v3; - Z3_ast _c4; - value _vresult; - value _vres[2] = { 0, 0, }; - - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_model(_v_m, &m, _ctx); - camlidl_ml2c_z3_Z3_func_decl(_v_d, &d, _ctx); - _c1 = Wosize_val(_v_args); - args = camlidl_malloc(_c1 * sizeof(Z3_ast ), _ctx); - for (_c2 = 0; _c2 < _c1; _c2++) { - _v3 = Field(_v_args, _c2); - camlidl_ml2c_z3_Z3_ast(_v3, &args[_c2], _ctx); - } - num_args = _c1; - v = &_c4; - _res = Z3_eval_decl(c, m, d, num_args, args, v); - Begin_roots_block(_vres, 2) - _vres[0] = Val_int(_res); - _vres[1] = camlidl_c2ml_z3_Z3_ast(&*v, _ctx); - _vresult = camlidl_alloc_small(2, 0); - Field(_vresult, 0) = _vres[0]; - Field(_vresult, 1) = _vres[1]; - End_roots() - camlidl_free(_ctx); - return _vresult; -} - -value camlidl_z3_Z3_open_log( - value _v_c, - value _v_filename) -{ - Z3_context c; /*in*/ - char const *filename; /*in*/ - int _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - filename = String_val(_v_filename); - _res = Z3_open_log(c, filename); - _vres = Val_int(_res); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_append_log( - value _v_c, - value _v_string) -{ - Z3_context c; /*in*/ - char const *string; /*in*/ - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - string = String_val(_v_string); - Z3_append_log(c, string); - camlidl_free(_ctx); - return Val_unit; -} - -value camlidl_z3_Z3_close_log( - value _v_c) -{ - Z3_context c; /*in*/ - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - Z3_close_log(c); - camlidl_free(_ctx); - return Val_unit; -} - -value camlidl_z3_Z3_set_ast_print_mode( - value _v_c, - value _v_mode) -{ - Z3_context c; /*in*/ - Z3_ast_print_mode mode; /*in*/ - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast_print_mode(_v_mode, &mode, _ctx); - Z3_set_ast_print_mode(c, mode); - camlidl_free(_ctx); - return Val_unit; -} - -value camlidl_z3_Z3_ast_to_string( - value _v_c, - value _v_a) -{ - Z3_context c; /*in*/ - Z3_ast a; /*in*/ - char const *_res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_a, &a, _ctx); - _res = Z3_ast_to_string(c, a); - _vres = copy_string(_res); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_pattern_to_string( - value _v_c, - value _v_p) -{ - Z3_context c; /*in*/ - Z3_pattern p; /*in*/ - char const *_res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_pattern(_v_p, &p, _ctx); - _res = Z3_pattern_to_string(c, p); - _vres = copy_string(_res); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_sort_to_string( - value _v_c, - value _v_s) -{ - Z3_context c; /*in*/ - Z3_sort s; /*in*/ - char const *_res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_sort(_v_s, &s, _ctx); - _res = Z3_sort_to_string(c, s); - _vres = copy_string(_res); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_func_decl_to_string( - value _v_c, - value _v_d) -{ - Z3_context c; /*in*/ - Z3_func_decl d; /*in*/ - char const *_res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_func_decl(_v_d, &d, _ctx); - _res = Z3_func_decl_to_string(c, d); - _vres = copy_string(_res); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_model_to_string( - value _v_c, - value _v_m) -{ - Z3_context c; /*in*/ - Z3_model m; /*in*/ - char const *_res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_model(_v_m, &m, _ctx); - _res = Z3_model_to_string(c, m); - _vres = copy_string(_res); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_benchmark_to_smtlib_string( - value _v_c, - value _v_name, - value _v_logic, - value _v_status, - value _v_attributes, - value _v_assumptions, - value _v_formula) -{ - Z3_context c; /*in*/ - char const *name; /*in*/ - char const *logic; /*in*/ - char const *status; /*in*/ - char const *attributes; /*in*/ - unsigned int num_assumptions; /*in*/ - Z3_ast *assumptions; /*in*/ - Z3_ast formula; /*in*/ - char const *_res; - mlsize_t _c1; - mlsize_t _c2; - value _v3; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - name = String_val(_v_name); - logic = String_val(_v_logic); - status = String_val(_v_status); - attributes = String_val(_v_attributes); - _c1 = Wosize_val(_v_assumptions); - assumptions = camlidl_malloc(_c1 * sizeof(Z3_ast ), _ctx); - for (_c2 = 0; _c2 < _c1; _c2++) { - _v3 = Field(_v_assumptions, _c2); - camlidl_ml2c_z3_Z3_ast(_v3, &assumptions[_c2], _ctx); - } - num_assumptions = _c1; - camlidl_ml2c_z3_Z3_ast(_v_formula, &formula, _ctx); - _res = Z3_benchmark_to_smtlib_string(c, name, logic, status, attributes, num_assumptions, assumptions, formula); - _vres = copy_string(_res); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_benchmark_to_smtlib_string_bytecode(value * argv, int argn) -{ - return camlidl_z3_Z3_benchmark_to_smtlib_string(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5], argv[6]); -} - -value camlidl_z3_Z3_context_to_string( - value _v_c) -{ - Z3_context c; /*in*/ - char const *_res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - _res = Z3_context_to_string(c); - _vres = copy_string(_res); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_statistics_to_string( - value _v_c) -{ - Z3_context c; /*in*/ - char const *_res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - _res = Z3_statistics_to_string(c); - _vres = copy_string(_res); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_context_assignment( - value _v_c) -{ - Z3_context c; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - _res = Z3_get_context_assignment(c); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_parse_smtlib_string( - value _v_c, - value _v_str, - value _v_sort_names, - value _v_sorts, - value _v_decl_names, - value _v_decls) -{ - Z3_context c; /*in*/ - char const *str; /*in*/ - unsigned int num_sorts; /*in*/ - Z3_symbol *sort_names; /*in*/ - Z3_sort *sorts; /*in*/ - unsigned int num_decls; /*in*/ - Z3_symbol *decl_names; /*in*/ - Z3_func_decl *decls; /*in*/ - mlsize_t _c1; - mlsize_t _c2; - value _v3; - mlsize_t _c4; - mlsize_t _c5; - value _v6; - mlsize_t _c7; - mlsize_t _c8; - value _v9; - mlsize_t _c10; - mlsize_t _c11; - value _v12; - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - str = String_val(_v_str); - _c1 = Wosize_val(_v_sort_names); - sort_names = camlidl_malloc(_c1 * sizeof(Z3_symbol ), _ctx); - for (_c2 = 0; _c2 < _c1; _c2++) { - _v3 = Field(_v_sort_names, _c2); - camlidl_ml2c_z3_Z3_symbol(_v3, &sort_names[_c2], _ctx); - } - num_sorts = _c1; - _c4 = Wosize_val(_v_sorts); - sorts = camlidl_malloc(_c4 * sizeof(Z3_sort ), _ctx); - for (_c5 = 0; _c5 < _c4; _c5++) { - _v6 = Field(_v_sorts, _c5); - camlidl_ml2c_z3_Z3_sort(_v6, &sorts[_c5], _ctx); - } - num_sorts = _c4; - _c7 = Wosize_val(_v_decl_names); - decl_names = camlidl_malloc(_c7 * sizeof(Z3_symbol ), _ctx); - for (_c8 = 0; _c8 < _c7; _c8++) { - _v9 = Field(_v_decl_names, _c8); - camlidl_ml2c_z3_Z3_symbol(_v9, &decl_names[_c8], _ctx); - } - num_decls = _c7; - _c10 = Wosize_val(_v_decls); - decls = camlidl_malloc(_c10 * sizeof(Z3_func_decl ), _ctx); - for (_c11 = 0; _c11 < _c10; _c11++) { - _v12 = Field(_v_decls, _c11); - camlidl_ml2c_z3_Z3_func_decl(_v12, &decls[_c11], _ctx); - } - num_decls = _c10; - Z3_parse_smtlib_string(c, str, num_sorts, sort_names, sorts, num_decls, decl_names, decls); - camlidl_free(_ctx); - return Val_unit; -} - -value camlidl_z3_Z3_parse_smtlib_string_bytecode(value * argv, int argn) -{ - return camlidl_z3_Z3_parse_smtlib_string(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]); -} - -value camlidl_z3_Z3_parse_smtlib_file( - value _v_c, - value _v_file_name, - value _v_sort_names, - value _v_sorts, - value _v_decl_names, - value _v_decls) -{ - Z3_context c; /*in*/ - char const *file_name; /*in*/ - unsigned int num_sorts; /*in*/ - Z3_symbol *sort_names; /*in*/ - Z3_sort *sorts; /*in*/ - unsigned int num_decls; /*in*/ - Z3_symbol *decl_names; /*in*/ - Z3_func_decl *decls; /*in*/ - mlsize_t _c1; - mlsize_t _c2; - value _v3; - mlsize_t _c4; - mlsize_t _c5; - value _v6; - mlsize_t _c7; - mlsize_t _c8; - value _v9; - mlsize_t _c10; - mlsize_t _c11; - value _v12; - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - file_name = String_val(_v_file_name); - _c1 = Wosize_val(_v_sort_names); - sort_names = camlidl_malloc(_c1 * sizeof(Z3_symbol ), _ctx); - for (_c2 = 0; _c2 < _c1; _c2++) { - _v3 = Field(_v_sort_names, _c2); - camlidl_ml2c_z3_Z3_symbol(_v3, &sort_names[_c2], _ctx); - } - num_sorts = _c1; - _c4 = Wosize_val(_v_sorts); - sorts = camlidl_malloc(_c4 * sizeof(Z3_sort ), _ctx); - for (_c5 = 0; _c5 < _c4; _c5++) { - _v6 = Field(_v_sorts, _c5); - camlidl_ml2c_z3_Z3_sort(_v6, &sorts[_c5], _ctx); - } - num_sorts = _c4; - _c7 = Wosize_val(_v_decl_names); - decl_names = camlidl_malloc(_c7 * sizeof(Z3_symbol ), _ctx); - for (_c8 = 0; _c8 < _c7; _c8++) { - _v9 = Field(_v_decl_names, _c8); - camlidl_ml2c_z3_Z3_symbol(_v9, &decl_names[_c8], _ctx); - } - num_decls = _c7; - _c10 = Wosize_val(_v_decls); - decls = camlidl_malloc(_c10 * sizeof(Z3_func_decl ), _ctx); - for (_c11 = 0; _c11 < _c10; _c11++) { - _v12 = Field(_v_decls, _c11); - camlidl_ml2c_z3_Z3_func_decl(_v12, &decls[_c11], _ctx); - } - num_decls = _c10; - Z3_parse_smtlib_file(c, file_name, num_sorts, sort_names, sorts, num_decls, decl_names, decls); - camlidl_free(_ctx); - return Val_unit; -} - -value camlidl_z3_Z3_parse_smtlib_file_bytecode(value * argv, int argn) -{ - return camlidl_z3_Z3_parse_smtlib_file(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]); -} - -value camlidl_z3_Z3_get_smtlib_num_formulas( - value _v_c) -{ - Z3_context c; /*in*/ - unsigned int _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - _res = Z3_get_smtlib_num_formulas(c); - _vres = Val_int(_res); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_smtlib_formula( - value _v_c, - value _v_i) -{ - Z3_context c; /*in*/ - unsigned int i; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - i = Int_val(_v_i); - _res = Z3_get_smtlib_formula(c, i); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_smtlib_num_assumptions( - value _v_c) -{ - Z3_context c; /*in*/ - unsigned int _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - _res = Z3_get_smtlib_num_assumptions(c); - _vres = Val_int(_res); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_smtlib_assumption( - value _v_c, - value _v_i) -{ - Z3_context c; /*in*/ - unsigned int i; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - i = Int_val(_v_i); - _res = Z3_get_smtlib_assumption(c, i); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_smtlib_num_decls( - value _v_c) -{ - Z3_context c; /*in*/ - unsigned int _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - _res = Z3_get_smtlib_num_decls(c); - _vres = Val_int(_res); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_smtlib_decl( - value _v_c, - value _v_i) -{ - Z3_context c; /*in*/ - unsigned int i; /*in*/ - Z3_func_decl _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - i = Int_val(_v_i); - _res = Z3_get_smtlib_decl(c, i); - _vres = camlidl_c2ml_z3_Z3_func_decl(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_smtlib_num_sorts( - value _v_c) -{ - Z3_context c; /*in*/ - unsigned int _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - _res = Z3_get_smtlib_num_sorts(c); - _vres = Val_int(_res); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_smtlib_sort( - value _v_c, - value _v_i) -{ - Z3_context c; /*in*/ - unsigned int i; /*in*/ - Z3_sort _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - i = Int_val(_v_i); - _res = Z3_get_smtlib_sort(c, i); - _vres = camlidl_c2ml_z3_Z3_sort(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_get_smtlib_error( - value _v_c) -{ - Z3_context c; /*in*/ - char const *_res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - _res = Z3_get_smtlib_error(c); - _vres = copy_string(_res); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_parse_z3_string( - value _v_c, - value _v_str) -{ - Z3_context c; /*in*/ - char const *str; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - str = String_val(_v_str); - _res = Z3_parse_z3_string(c, str); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_parse_z3_file( - value _v_c, - value _v_file_name) -{ - Z3_context c; /*in*/ - char const *file_name; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - file_name = String_val(_v_file_name); - _res = Z3_parse_z3_file(c, file_name); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_parse_smtlib2_string( - value _v_c, - value _v_str, - value _v_sort_names, - value _v_sorts, - value _v_decl_names, - value _v_decls) -{ - Z3_context c; /*in*/ - char const *str; /*in*/ - unsigned int num_sorts; /*in*/ - Z3_symbol *sort_names; /*in*/ - Z3_sort *sorts; /*in*/ - unsigned int num_decls; /*in*/ - Z3_symbol *decl_names; /*in*/ - Z3_func_decl *decls; /*in*/ - Z3_ast _res; - mlsize_t _c1; - mlsize_t _c2; - value _v3; - mlsize_t _c4; - mlsize_t _c5; - value _v6; - mlsize_t _c7; - mlsize_t _c8; - value _v9; - mlsize_t _c10; - mlsize_t _c11; - value _v12; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - str = String_val(_v_str); - _c1 = Wosize_val(_v_sort_names); - sort_names = camlidl_malloc(_c1 * sizeof(Z3_symbol ), _ctx); - for (_c2 = 0; _c2 < _c1; _c2++) { - _v3 = Field(_v_sort_names, _c2); - camlidl_ml2c_z3_Z3_symbol(_v3, &sort_names[_c2], _ctx); - } - num_sorts = _c1; - _c4 = Wosize_val(_v_sorts); - sorts = camlidl_malloc(_c4 * sizeof(Z3_sort ), _ctx); - for (_c5 = 0; _c5 < _c4; _c5++) { - _v6 = Field(_v_sorts, _c5); - camlidl_ml2c_z3_Z3_sort(_v6, &sorts[_c5], _ctx); - } - num_sorts = _c4; - _c7 = Wosize_val(_v_decl_names); - decl_names = camlidl_malloc(_c7 * sizeof(Z3_symbol ), _ctx); - for (_c8 = 0; _c8 < _c7; _c8++) { - _v9 = Field(_v_decl_names, _c8); - camlidl_ml2c_z3_Z3_symbol(_v9, &decl_names[_c8], _ctx); - } - num_decls = _c7; - _c10 = Wosize_val(_v_decls); - decls = camlidl_malloc(_c10 * sizeof(Z3_func_decl ), _ctx); - for (_c11 = 0; _c11 < _c10; _c11++) { - _v12 = Field(_v_decls, _c11); - camlidl_ml2c_z3_Z3_func_decl(_v12, &decls[_c11], _ctx); - } - num_decls = _c10; - _res = Z3_parse_smtlib2_string(c, str, num_sorts, sort_names, sorts, num_decls, decl_names, decls); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_parse_smtlib2_string_bytecode(value * argv, int argn) -{ - return camlidl_z3_Z3_parse_smtlib2_string(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]); -} - -value camlidl_z3_Z3_parse_smtlib2_file( - value _v_c, - value _v_file_name, - value _v_sort_names, - value _v_sorts, - value _v_decl_names, - value _v_decls) -{ - Z3_context c; /*in*/ - char const *file_name; /*in*/ - unsigned int num_sorts; /*in*/ - Z3_symbol *sort_names; /*in*/ - Z3_sort *sorts; /*in*/ - unsigned int num_decls; /*in*/ - Z3_symbol *decl_names; /*in*/ - Z3_func_decl *decls; /*in*/ - Z3_ast _res; - mlsize_t _c1; - mlsize_t _c2; - value _v3; - mlsize_t _c4; - mlsize_t _c5; - value _v6; - mlsize_t _c7; - mlsize_t _c8; - value _v9; - mlsize_t _c10; - mlsize_t _c11; - value _v12; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - file_name = String_val(_v_file_name); - _c1 = Wosize_val(_v_sort_names); - sort_names = camlidl_malloc(_c1 * sizeof(Z3_symbol ), _ctx); - for (_c2 = 0; _c2 < _c1; _c2++) { - _v3 = Field(_v_sort_names, _c2); - camlidl_ml2c_z3_Z3_symbol(_v3, &sort_names[_c2], _ctx); - } - num_sorts = _c1; - _c4 = Wosize_val(_v_sorts); - sorts = camlidl_malloc(_c4 * sizeof(Z3_sort ), _ctx); - for (_c5 = 0; _c5 < _c4; _c5++) { - _v6 = Field(_v_sorts, _c5); - camlidl_ml2c_z3_Z3_sort(_v6, &sorts[_c5], _ctx); - } - num_sorts = _c4; - _c7 = Wosize_val(_v_decl_names); - decl_names = camlidl_malloc(_c7 * sizeof(Z3_symbol ), _ctx); - for (_c8 = 0; _c8 < _c7; _c8++) { - _v9 = Field(_v_decl_names, _c8); - camlidl_ml2c_z3_Z3_symbol(_v9, &decl_names[_c8], _ctx); - } - num_decls = _c7; - _c10 = Wosize_val(_v_decls); - decls = camlidl_malloc(_c10 * sizeof(Z3_func_decl ), _ctx); - for (_c11 = 0; _c11 < _c10; _c11++) { - _v12 = Field(_v_decls, _c11); - camlidl_ml2c_z3_Z3_func_decl(_v12, &decls[_c11], _ctx); - } - num_decls = _c10; - _res = Z3_parse_smtlib2_file(c, file_name, num_sorts, sort_names, sorts, num_decls, decl_names, decls); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_parse_smtlib2_file_bytecode(value * argv, int argn) -{ - return camlidl_z3_Z3_parse_smtlib2_file(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]); -} - -value camlidl_z3_Z3_get_version(value _unit) -{ - unsigned int *major; /*out*/ - unsigned int *minor; /*out*/ - unsigned int *build_number; /*out*/ - unsigned int *revision_number; /*out*/ - unsigned int _c1; - unsigned int _c2; - unsigned int _c3; - unsigned int _c4; - value _vresult; - value _vres[4] = { 0, 0, 0, 0, }; - - major = &_c1; - minor = &_c2; - build_number = &_c3; - revision_number = &_c4; - Z3_get_version(major, minor, build_number, revision_number); - Begin_roots_block(_vres, 4) - _vres[0] = Val_int(*major); - _vres[1] = Val_int(*minor); - _vres[2] = Val_int(*build_number); - _vres[3] = Val_int(*revision_number); - _vresult = camlidl_alloc_small(4, 0); - Field(_vresult, 0) = _vres[0]; - Field(_vresult, 1) = _vres[1]; - Field(_vresult, 2) = _vres[2]; - Field(_vresult, 3) = _vres[3]; - End_roots() - return _vresult; -} - -value camlidl_z3_Z3_reset_memory(value _unit) -{ - Z3_reset_memory(); - return Val_unit; -} - -value camlidl_z3_Z3_theory_mk_sort( - value _v_c, - value _v_t, - value _v_s) -{ - Z3_context c; /*in*/ - Z3_theory t; /*in*/ - Z3_symbol s; /*in*/ - Z3_sort _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_theory(_v_t, &t, _ctx); - camlidl_ml2c_z3_Z3_symbol(_v_s, &s, _ctx); - _res = Z3_theory_mk_sort(c, t, s); - _vres = camlidl_c2ml_z3_Z3_sort(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_theory_mk_value( - value _v_c, - value _v_t, - value _v_n, - value _v_s) -{ - Z3_context c; /*in*/ - Z3_theory t; /*in*/ - Z3_symbol n; /*in*/ - Z3_sort s; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_theory(_v_t, &t, _ctx); - camlidl_ml2c_z3_Z3_symbol(_v_n, &n, _ctx); - camlidl_ml2c_z3_Z3_sort(_v_s, &s, _ctx); - _res = Z3_theory_mk_value(c, t, n, s); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_theory_mk_constant( - value _v_c, - value _v_t, - value _v_n, - value _v_s) -{ - Z3_context c; /*in*/ - Z3_theory t; /*in*/ - Z3_symbol n; /*in*/ - Z3_sort s; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_theory(_v_t, &t, _ctx); - camlidl_ml2c_z3_Z3_symbol(_v_n, &n, _ctx); - camlidl_ml2c_z3_Z3_sort(_v_s, &s, _ctx); - _res = Z3_theory_mk_constant(c, t, n, s); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_theory_mk_func_decl( - value _v_c, - value _v_t, - value _v_n, - value _v_domain, - value _v_range) -{ - Z3_context c; /*in*/ - Z3_theory t; /*in*/ - Z3_symbol n; /*in*/ - unsigned int domain_size; /*in*/ - Z3_sort const *domain; /*in*/ - Z3_sort range; /*in*/ - Z3_func_decl _res; - mlsize_t _c1; - mlsize_t _c2; - value _v3; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_theory(_v_t, &t, _ctx); - camlidl_ml2c_z3_Z3_symbol(_v_n, &n, _ctx); - _c1 = Wosize_val(_v_domain); - domain = camlidl_malloc(_c1 * sizeof(Z3_sort const ), _ctx); - for (_c2 = 0; _c2 < _c1; _c2++) { - _v3 = Field(_v_domain, _c2); - camlidl_ml2c_z3_Z3_sort(_v3, &domain[_c2], _ctx); - } - domain_size = _c1; - camlidl_ml2c_z3_Z3_sort(_v_range, &range, _ctx); - _res = Z3_theory_mk_func_decl(c, t, n, domain_size, domain, range); - _vres = camlidl_c2ml_z3_Z3_func_decl(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_theory_get_context( - value _v_t) -{ - Z3_theory t; /*in*/ - Z3_context _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_theory(_v_t, &t, _ctx); - _res = Z3_theory_get_context(t); - _vres = camlidl_c2ml_z3_Z3_context(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_theory_assert_axiom( - value _v_t, - value _v_ax) -{ - Z3_theory t; /*in*/ - Z3_ast ax; /*in*/ - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_theory(_v_t, &t, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_ax, &ax, _ctx); - Z3_theory_assert_axiom(t, ax); - camlidl_free(_ctx); - return Val_unit; -} - -value camlidl_z3_Z3_theory_assume_eq( - value _v_t, - value _v_lhs, - value _v_rhs) -{ - Z3_theory t; /*in*/ - Z3_ast lhs; /*in*/ - Z3_ast rhs; /*in*/ - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_theory(_v_t, &t, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_lhs, &lhs, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_rhs, &rhs, _ctx); - Z3_theory_assume_eq(t, lhs, rhs); - camlidl_free(_ctx); - return Val_unit; -} - -value camlidl_z3_Z3_theory_enable_axiom_simplification( - value _v_t, - value _v_flag) -{ - Z3_theory t; /*in*/ - int flag; /*in*/ - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_theory(_v_t, &t, _ctx); - flag = Int_val(_v_flag); - Z3_theory_enable_axiom_simplification(t, flag); - camlidl_free(_ctx); - return Val_unit; -} - -value camlidl_z3_Z3_theory_get_eqc_root( - value _v_t, - value _v_n) -{ - Z3_theory t; /*in*/ - Z3_ast n; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_theory(_v_t, &t, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_n, &n, _ctx); - _res = Z3_theory_get_eqc_root(t, n); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_theory_get_eqc_next( - value _v_t, - value _v_n) -{ - Z3_theory t; /*in*/ - Z3_ast n; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_theory(_v_t, &t, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_n, &n, _ctx); - _res = Z3_theory_get_eqc_next(t, n); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_theory_get_num_parents( - value _v_t, - value _v_n) -{ - Z3_theory t; /*in*/ - Z3_ast n; /*in*/ - unsigned int _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_theory(_v_t, &t, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_n, &n, _ctx); - _res = Z3_theory_get_num_parents(t, n); - _vres = Val_int(_res); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_theory_get_parent( - value _v_t, - value _v_n, - value _v_i) -{ - Z3_theory t; /*in*/ - Z3_ast n; /*in*/ - unsigned int i; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_theory(_v_t, &t, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_n, &n, _ctx); - i = Int_val(_v_i); - _res = Z3_theory_get_parent(t, n, i); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_theory_is_value( - value _v_t, - value _v_n) -{ - Z3_theory t; /*in*/ - Z3_ast n; /*in*/ - int _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_theory(_v_t, &t, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_n, &n, _ctx); - _res = Z3_theory_is_value(t, n); - _vres = Val_int(_res); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_theory_is_decl( - value _v_t, - value _v_d) -{ - Z3_theory t; /*in*/ - Z3_func_decl d; /*in*/ - int _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_theory(_v_t, &t, _ctx); - camlidl_ml2c_z3_Z3_func_decl(_v_d, &d, _ctx); - _res = Z3_theory_is_decl(t, d); - _vres = Val_int(_res); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_theory_get_num_elems( - value _v_t) -{ - Z3_theory t; /*in*/ - unsigned int _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_theory(_v_t, &t, _ctx); - _res = Z3_theory_get_num_elems(t); - _vres = Val_int(_res); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_theory_get_elem( - value _v_t, - value _v_i) -{ - Z3_theory t; /*in*/ - unsigned int i; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_theory(_v_t, &t, _ctx); - i = Int_val(_v_i); - _res = Z3_theory_get_elem(t, i); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_theory_get_num_apps( - value _v_t) -{ - Z3_theory t; /*in*/ - unsigned int _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_theory(_v_t, &t, _ctx); - _res = Z3_theory_get_num_apps(t); - _vres = Val_int(_res); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_theory_get_app( - value _v_t, - value _v_i) -{ - Z3_theory t; /*in*/ - unsigned int i; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_theory(_v_t, &t, _ctx); - i = Int_val(_v_i); - _res = Z3_theory_get_app(t, i); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_datalog_add_rule( - value _v_c, - value _v_horn_rule, - value _v_name) -{ - Z3_context c; /*in*/ - Z3_ast horn_rule; /*in*/ - Z3_symbol name; /*in*/ - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_horn_rule, &horn_rule, _ctx); - camlidl_ml2c_z3_Z3_symbol(_v_name, &name, _ctx); - Z3_datalog_add_rule(c, horn_rule, name); - camlidl_free(_ctx); - return Val_unit; -} - -value camlidl_z3_Z3_datalog_query( - value _v_c, - value _v_q) -{ - Z3_context c; /*in*/ - Z3_ast q; /*in*/ - Z3_ast _res; - value _vres; - - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_ast(_v_q, &q, _ctx); - _res = Z3_datalog_query(c, q); - _vres = camlidl_c2ml_z3_Z3_ast(&_res, _ctx); - camlidl_free(_ctx); - return _vres; -} - -value camlidl_z3_Z3_datalog_set_predicate_representation( - value _v_c, - value _v_f, - value _v_relation_kinds) -{ - Z3_context c; /*in*/ - Z3_func_decl f; /*in*/ - unsigned int num_relations; /*in*/ - Z3_symbol const *relation_kinds; /*in*/ - mlsize_t _c1; - mlsize_t _c2; - value _v3; - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - camlidl_ml2c_z3_Z3_func_decl(_v_f, &f, _ctx); - _c1 = Wosize_val(_v_relation_kinds); - relation_kinds = camlidl_malloc(_c1 * sizeof(Z3_symbol const ), _ctx); - for (_c2 = 0; _c2 < _c1; _c2++) { - _v3 = Field(_v_relation_kinds, _c2); - camlidl_ml2c_z3_Z3_symbol(_v3, &relation_kinds[_c2], _ctx); - } - num_relations = _c1; - Z3_datalog_set_predicate_representation(c, f, num_relations, relation_kinds); - camlidl_free(_ctx); - return Val_unit; -} - -value camlidl_z3_Z3_datalog_parse_file( - value _v_c, - value _v_filename) -{ - Z3_context c; /*in*/ - char const *filename; /*in*/ - struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; - camlidl_ctx _ctx = &_ctxs; - camlidl_ml2c_z3_Z3_context(_v_c, &c, _ctx); - filename = String_val(_v_filename); - Z3_datalog_parse_file(c, filename); - camlidl_free(_ctx); - return Val_unit; -} - diff --git a/external/z3/ocaml/z3_theory_stubs.c b/external/z3/ocaml/z3_theory_stubs.c deleted file mode 100644 --- a/external/z3/ocaml/z3_theory_stubs.c +++ /dev/null @@ -1,337 +0,0 @@ -/*++ -Copyright (c) 2010 Microsoft Corporation - -Module Name: - - z3_theory_stubs.c - -Abstract: - - OCaml C bindings for callbacks between OCaml and C for - theory plugins. - The API for theory plugins require associating a set of - callbacks as C function pointers. - We use the following strategy: - - - store in the user_ext_data blob that theory constructors allow - a record of callback functions. - - - define catch-all static callback functions that access the - ML record with the callbacks. It then invokes these through user-registered - application functions that apply the callback stored in the record to the - actual parameters. - It is tempting to avoid this user-registered callback and directly access - the record of callback functions and apply the proper field. - However, the layout of records appears to be opaque, or at least we assume it is - so, from the C runtime. - -Author: - - -Revision History: ---*/ - -#include -#include -#include -#include -#include -#include -#include -#ifdef Custom_tag -#include -#include -#endif - -#include "z3.h" - -#define ML_SIZE(_ty) ((sizeof(_ty) + sizeof(value) - 1)/ sizeof(value)) - -static value mk_func_decl(Z3_func_decl f) { - value _f = alloc(ML_SIZE(Z3_func_decl), Abstract_tag); - *((Z3_func_decl*) Bp_val(_f)) = f; - return _f; -} - -static value Val_ast(Z3_ast a) { - value _a = alloc(ML_SIZE(Z3_ast), Abstract_tag); - *((Z3_ast*) Bp_val(_a)) = a; - return _a; -} - - -static value Val_ast_array(unsigned int sz, Z3_ast const args[]) { - value res; - Z3_ast* args1; - unsigned int i; - args1 = malloc((sz+1)*sizeof(Z3_ast)); - for (i = 0; i < sz; ++i) { - args1[i] = args[i]; - } - args1[sz] = 0; - res = alloc_array((value (*)(char const*))Val_ast, (const char**)args1); - free(args1); - return res; -} - -// ------------------ -// get_theory_callbacks -// - -value get_theory_callbacks(value th) -{ - Z3_theory _th = *((Z3_theory*) Bp_val(th)); - return (value) Z3_theory_get_ext_data(_th); -} - -// ------------------ -// delete_theory -// -static void delete_callback_static(Z3_theory th) -{ - CAMLparam0(); - CAMLlocal1(f); - value user_data = (value) Z3_theory_get_ext_data(th); - f = *(caml_named_value("apply_delete")) ; - callback(f, user_data); - remove_global_root(&user_data); - CAMLreturn0; -} - -#define SET_CALLBACK(_cb_name) \ - value set_ ## _cb_name ## _callback_register(value th) \ - { \ - CAMLparam1(th); \ - Z3_theory _th = *((Z3_theory*) Bp_val(th)); \ - Z3_set_ ## _cb_name ## _callback(_th, _cb_name ## _callback_static); \ - CAMLreturn(Val_unit); \ - } \ - -SET_CALLBACK(delete); - - -// ------------------ -// mk_theory -// - -value mk_theory_register(value context, value name, value user_data) -{ - CAMLparam3(context, name, user_data); - Z3_context _context = *((Z3_context *) Bp_val(context)); - value _th; - Z3_theory th; - register_global_root(&user_data); - th = Z3_mk_theory(_context, String_val(name), (void*)user_data); - Z3_set_delete_callback(th, delete_callback_static); - _th = alloc(ML_SIZE(Z3_context), Abstract_tag); - *((Z3_theory*) Bp_val(_th)) = th; - CAMLreturn(_th); -} - - -// ------------------- -// reduce_app_callback - -static Z3_bool reduce_app_callback_static(Z3_theory th, Z3_func_decl f, unsigned num_args, Z3_ast const args[], Z3_ast* r) { - CAMLparam0(); - CAMLlocal4(cb, _r, _v, _args); - value user_data; - Z3_bool result; - - _args = Val_ast_array(num_args, args); - - user_data = (value) Z3_theory_get_ext_data(th); - - cb = *(caml_named_value("apply_reduce_app")); - _r = callback3(cb, user_data, mk_func_decl(f), _args); - - cb = *(caml_named_value("is_some")); - _v = callback(cb, _r); - result = 0 != Bool_val(_v); - - if (result && r) { - cb = *(caml_named_value("get_some")); - _v = callback(cb, _r); - *r = *((Z3_ast*) Bp_val(_v)); - } - - CAMLreturn (result); -} - -SET_CALLBACK(reduce_app); - -// ------------------- -// reduce_eq_callback - -static Z3_bool reduce_eq_callback_static(Z3_theory th, Z3_ast a, Z3_ast b, Z3_ast * r) -{ - CAMLparam0(); - CAMLlocal5(cb, _r, _a, _b, _v); - value user_data; - Z3_bool result; - - _a = Val_ast(a); - _b = Val_ast(b); - - user_data = (value) Z3_theory_get_ext_data(th); - - cb = *(caml_named_value("apply_reduce_eq")); - _r = callback3(cb, user_data, _a, _b); - - cb = *(caml_named_value("is_some")); - _v = callback(cb, _r); - result = 0 != Bool_val(_v); - - if (result && r) { - cb = *(caml_named_value("get_some")); - _v = callback(cb, _r); - *r = *((Z3_ast*) Bp_val(_v)); - } - - CAMLreturn (result); -} - -SET_CALLBACK(reduce_eq); - - -// ------------------- -// reduce_distinct - -static Z3_bool reduce_distinct_callback_static(Z3_theory th, unsigned n, Z3_ast const args[], Z3_ast * r) -{ - CAMLparam0(); - CAMLlocal4(cb, _r, _args, _v); - value user_data; - Z3_bool result; - - _args = Val_ast_array(n, args); - - user_data = (value) Z3_theory_get_ext_data(th); - - cb = *(caml_named_value("apply_reduce_distinct")); - _r = callback2(cb, user_data, _args); - - cb = *(caml_named_value("is_some")); - _v = callback(cb, _r); - result = 0 != Bool_val(_v); - - if (result && r) { - cb = *(caml_named_value("get_some")); - _v = callback(cb, _r); - *r = *((Z3_ast*) Bp_val(_v)); - } - - CAMLreturn (result); -} - -SET_CALLBACK(reduce_distinct); - -// ------------------- -// new_app - -#define AST_CALLBACK(_cb_name) \ -static void _cb_name##_callback_static(Z3_theory th, Z3_ast a) \ -{ \ - CAMLparam0(); \ - CAMLlocal3(cb, _a, user_data); \ - _a = Val_ast(a); \ - user_data = (value) Z3_theory_get_ext_data(th); \ - cb = *(caml_named_value("apply_" #_cb_name)); \ - callback2(cb, user_data, _a); \ - CAMLreturn0; \ -} \ - -AST_CALLBACK(new_app); -SET_CALLBACK(new_app); - -// ------------------- -// new_elem - -AST_CALLBACK(new_elem); -SET_CALLBACK(new_elem); - -// ------------------- -// init_search - -#define TH_CALLBACK(_cb_name) \ -static void _cb_name##_callback_static(Z3_theory th) \ -{ \ - CAMLparam0(); \ - CAMLlocal2(cb, user_data); \ - user_data = (value) Z3_theory_get_ext_data(th); \ - cb = *(caml_named_value("apply_" #_cb_name)); \ - callback(cb, user_data); \ - CAMLreturn0; \ -} \ - -TH_CALLBACK(init_search); -SET_CALLBACK(init_search); - -// ------------------- -// push - -TH_CALLBACK(push); -SET_CALLBACK(push); - -TH_CALLBACK(pop); -SET_CALLBACK(pop); - -TH_CALLBACK(restart); -SET_CALLBACK(restart); - -TH_CALLBACK(reset); -SET_CALLBACK(reset); - - -#define FC_CALLBACK(_cb_name) \ - static Z3_bool _cb_name##_callback_static(Z3_theory th) \ - { \ - CAMLparam0(); \ - CAMLlocal3(cb, r, user_data); \ - user_data = (value) Z3_theory_get_ext_data(th); \ - cb = *(caml_named_value("apply_" #_cb_name)); \ - r = callback(cb, user_data); \ - CAMLreturn (Bool_val(r) != 0); \ - } \ - -FC_CALLBACK(final_check); -SET_CALLBACK(final_check); - -#define AST_AST_CALLBACK(_cb_name) \ - static void _cb_name##_callback_static(Z3_theory th, Z3_ast a, Z3_ast b) \ - { \ - CAMLparam0(); \ - CAMLlocal4(cb, _a, _b, user_data); \ - _a = Val_ast(a); \ - _b = Val_ast(b); \ - user_data = (value) Z3_theory_get_ext_data(th); \ - cb = *(caml_named_value("apply_" #_cb_name)); \ - callback3(cb, user_data, _a, _b); \ - CAMLreturn0; \ - } \ - -AST_AST_CALLBACK(new_eq); -SET_CALLBACK(new_eq); - -AST_AST_CALLBACK(new_diseq); -SET_CALLBACK(new_diseq); - -#define AST_BOOL_CALLBACK(_cb_name) \ - static void _cb_name##_callback_static(Z3_theory th, Z3_ast a, Z3_bool b) \ - { \ - CAMLparam0(); \ - CAMLlocal4(cb, _a, _b, user_data); \ - _a = Val_ast(a); \ - _b = Val_bool(b); \ - user_data = (value) Z3_theory_get_ext_data(th); \ - cb = *(caml_named_value("apply_" #_cb_name)); \ - callback3(cb, user_data, _a, _b); \ - CAMLreturn0; \ - } \ - - -AST_BOOL_CALLBACK(new_assignment); -SET_CALLBACK(new_assignment); - -AST_CALLBACK(new_relevant); -SET_CALLBACK(new_relevant); diff --git a/liquid-fixpoint.cabal b/liquid-fixpoint.cabal --- a/liquid-fixpoint.cabal +++ b/liquid-fixpoint.cabal @@ -1,5 +1,5 @@ name: liquid-fixpoint -version: 0.4.0.0 +version: 0.5.0.0 Copyright: 2010-15 Ranjit Jhala, University of California, San Diego. synopsis: Predicate Abstraction-based Horn-Clause/Implication Constraint Solver homepage: https://github.com/ucsd-progsys/liquid-fixpoint @@ -8,178 +8,93 @@ author: Ranjit Jhala, Niki Vazou, Eric Seidel maintainer: jhala@cs.ucsd.edu category: Language -build-type: Custom +build-type: Simple cabal-version: >=1.10 description: This package is a Haskell wrapper to the SMTLIB-based Horn-Clause/Logical Implication constraint solver used for Liquid Types. . - The solver itself is written in Ocaml. - . The package includes: . 1. Types for Expressions, Predicates, Constraints, Solutions . - 2. Code for serializing the above - . - 3. Code for parsing the results from the fixpoint.native binary - . - 4. The Ocaml fixpoint code and pre-compiled binaries - . - 5. (Deprecated) Z3 binaries if you want to link against the API. + 2. Code for solving constraints . Requirements . In addition to the .cabal dependencies you require . - A Z3 () or CVC4 () binary. - If on Windows, please make sure to place the binary and any associated DLLs - in your "cabal/bin" folder, right next to the fixpoint.native.exe binary. - . - - An ocaml compiler (if installing with -fbuild-external). -Extra-Source-Files: configure - , external/fixpoint/Makefile - , external/fixpoint/*.ml - , external/fixpoint/smtZ3.mem.ml - , external/fixpoint/smtZ3.nomem.ml - , external/fixpoint/*.mli - , external/fixpoint/*.mll - , external/fixpoint/*.mly - , external/misc/*.ml - , external/misc/*.mli - , external/ocamlgraph/Makefile.in - , external/ocamlgraph/META.in - , external/ocamlgraph/configure - , external/ocamlgraph/configure.in - , external/ocamlgraph/lib/*.ml - , external/ocamlgraph/lib/*.mli - , external/ocamlgraph/src/*.ml - , external/ocamlgraph/src/*.mli - , external/ocamlgraph/src/*.mll - , external/ocamlgraph/src/*.mly - , external/z3/include/*.h - , external/z3/lib/libz3-a-32b - , external/z3/lib/libz3-a-64b - , external/z3/lib/libz3-so-32b - , external/z3/lib/libz3-so-64b - , external/z3/ocaml/build-lib.sh - , external/z3/ocaml/z3.ml - , external/z3/ocaml/*.c - , external/fixpoint/fixpoint.native-i386-linux - , external/fixpoint/fixpoint.native-i686-w64-mingw32 - , external/fixpoint/fixpoint.native-x86_64-darwin - , external/fixpoint/fixpoint.native-x86_64-linux - , tests/neg/*.fq +Extra-Source-Files: tests/neg/*.fq , tests/pos/*.fq -Flag z3mem - Description: Link to Z3 - Default: False - -Flag build-external - Description: Build fixpoint.native binary from source (requires ocaml) - Default: False - Source-Repository head Type: git Location: https://github.com/ucsd-progsys/liquid-fixpoint/ --- FIXME: This is a terrible hack. We build Fixpoint.hs *twice*, once --- targeting fixpoint.native so we can then *clobber* it with the --- OCaml fixpoint.native. This is required for cabal-install to detect --- fixpoint.native as an executable, and properly symlink it when --- asked. -Executable fixpoint.native - default-language: Haskell98 - Main-is: Fixpoint.hs - Build-Depends: base >= 4.7 && < 5 - , array - , syb - , cmdargs - , ansi-terminal - , bifunctors - , bytestring - , containers - , deepseq - , directory - , filepath - , mtl - , parsec - , pretty - , process - , syb - , text - , hashable - , unordered-containers - , text-format - , liquid-fixpoint - - Executable fixpoint default-language: Haskell98 Main-is: Fixpoint.hs + ghc-options: -threaded -W -fno-warn-missing-methods + hs-source-dirs: bin Build-Depends: base >= 4.7 && < 5 - , array - , syb - , cmdargs - , ansi-terminal - , bifunctors - , bytestring - , containers - , deepseq - , directory - -- , filemanip - , filepath - , mtl - , parsec - , pretty - , process - , syb - , text - , hashable - , unordered-containers - , text-format , liquid-fixpoint Library default-language: Haskell98 + ghc-options: -W -fno-warn-missing-methods hs-source-dirs: src - Exposed-Modules: Language.Fixpoint.Names, - Language.Fixpoint.Files, - Language.Fixpoint.Errors, - Language.Fixpoint.Config, + Exposed-Modules: Language.Fixpoint.Types.Names, + Language.Fixpoint.Types.Errors, + Language.Fixpoint.Types.Config, + Language.Fixpoint.Types.Visitor, + Language.Fixpoint.Types.PrettyPrint, + Language.Fixpoint.Types.Spans, + Language.Fixpoint.Types.Sorts, + Language.Fixpoint.Types.Refinements, + Language.Fixpoint.Types.Substitutions, + Language.Fixpoint.Types.Environments, + Language.Fixpoint.Types.Constraints, + Language.Fixpoint.Types.Graphs, + Language.Fixpoint.Types.Utils, Language.Fixpoint.Types, - Language.Fixpoint.Bitvector, - Language.Fixpoint.Visitor, - Language.Fixpoint.Sort, - Language.Fixpoint.Interface, - Language.Fixpoint.Parse, - Language.Fixpoint.PrettyPrint, Language.Fixpoint.Smt.Types, + Language.Fixpoint.Smt.Bitvector, Language.Fixpoint.Smt.Theories, Language.Fixpoint.Smt.Serialize, Language.Fixpoint.Smt.Interface, + Language.Fixpoint.Partition, + Language.Fixpoint.Minimize, + Language.Fixpoint.Solver, + Language.Fixpoint.Parse, + Language.Fixpoint.SortCheck, Language.Fixpoint.Misc, + Language.Fixpoint.Utils.Progress, + Language.Fixpoint.Utils.Files, + Language.Fixpoint.Solver.Types, + Language.Fixpoint.Solver.Graph, Language.Fixpoint.Solver.Solution, Language.Fixpoint.Solver.Worklist, Language.Fixpoint.Solver.Monad, - Language.Fixpoint.Solver.Deps, - Language.Fixpoint.Solver.Uniqify, + Language.Fixpoint.Solver.TrivialSort, + Language.Fixpoint.Solver.UniqifyKVars, + Language.Fixpoint.Solver.UniqifyBinds, Language.Fixpoint.Solver.Eliminate, Language.Fixpoint.Solver.Validate, - Language.Fixpoint.Partition, - Language.Fixpoint.Statistics, + Language.Fixpoint.Utils.Statistics, Language.Fixpoint.Solver.Solve Build-Depends: base >= 4.7 && < 5 , array + , async , attoparsec , syb , cmdargs , ansi-terminal , bifunctors + , binary , bytestring , containers , deepseq @@ -191,13 +106,25 @@ , mtl , parsec , pretty + , boxes + , parallel , process , syb , text , transformers , hashable , unordered-containers + , cereal , text-format + , fgl + , fgl-visualize + , dotgen + if impl(ghc >= 7.10.2) + Build-Depends: located-base + if !os(windows) + Build-Depends: ascii-progress >= 0.3 + if os(windows) + hs-source-dirs: win test-suite test default-language: Haskell98 @@ -209,11 +136,7 @@ directory, filepath, process, - -- tagged, - liquid-fixpoint, - -- optparse-applicative == 0.11.*, tasty >= 0.10, - -- tasty-quickcheck, tasty-hunit, tasty-rerun >= 1.1, text diff --git a/src/Language/Fixpoint/Bitvector.hs b/src/Language/Fixpoint/Bitvector.hs deleted file mode 100644 --- a/src/Language/Fixpoint/Bitvector.hs +++ /dev/null @@ -1,70 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} - -module Language.Fixpoint.Bitvector - ( -- * Constructor - Bv (..) - - -- * Sizes - , BvSize (..) - - -- * Operators - , BvOp (..) - - -- * BitVector Sort Constructor - , mkSort - - -- * BitVector Expression Constructor - , eOp - - -- * BitVector Type Constructor - , bvTyCon - - ) where - -import Data.Generics (Data) -import qualified Data.Text as T -import Data.Typeable (Typeable) -import GHC.Generics (Generic) -import Language.Fixpoint.Names -import Language.Fixpoint.Types - -data Bv = Bv BvSize String - -data BvSize = S32 | S64 - deriving (Eq, Ord, Show, Data, Typeable, Generic) - -data BvOp = BvAnd | BvOr - deriving (Eq, Ord, Show, Data, Typeable, Generic) - --- | Construct the bitvector `Sort` from its `BvSize` - -mkSort :: BvSize -> Sort -mkSort _ = fApp (Left $ symbolFTycon $ dummyLoc bitVecName) - [FApp (symbolFTycon $ dummyLoc size32Name) [fObj $ dummyLoc $ symbol "obj"]] - --- | Construct an `Expr` using a raw string, e.g. (Bv S32 "#x02000000") -instance Expression Bv where - expr (Bv sz v) = ECon $ L (T.pack v) (mkSort sz) - --- | Apply some bitvector operator to a list of arguments - -eOp :: BvOp -> [Expr] -> Expr -eOp o es = EApp (opName o) es - - --------------------------------------------------------------------- - -opName :: BvOp -> LocSymbol -opName BvAnd = dummyLoc bvAndName -opName BvOr = dummyLoc bvOrName - -sizeSort = (`FApp` [fObj $ dummyLoc $ symbol "obj"]) . sizeTC -sizeTC = symbolFTycon . dummyLoc . sizeName -sizeName S32 = size32Name -sizeName S64 = size64Name - -bvTyCon = symbolFTycon $ dummyLoc bitVecName - --- s32TyCon = symbolFTycon $ dummyLoc size32Name --- s64TyCon = symbolFTycon $ dummyLoc size64Name diff --git a/src/Language/Fixpoint/Config.hs b/src/Language/Fixpoint/Config.hs deleted file mode 100644 --- a/src/Language/Fixpoint/Config.hs +++ /dev/null @@ -1,147 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE UndecidableInstances #-} - -module Language.Fixpoint.Config ( - Config (..) - , getOpts - , Command (..) - , SMTSolver (..) - , GenQualifierSort (..) - , UeqAllSorts (..) - , withTarget -) where - -import System.Console.CmdArgs -import Language.Fixpoint.Files - - -class Command a where - command :: a -> String - ------------------------------------------------------------------------- --- Configuration Options ----------------------------------------------- ------------------------------------------------------------------------- - -withTarget :: Config -> FilePath -> Config -withTarget cfg fq = cfg { inFile = fq } { outFile = fq `withExt` Out } - - - -data Config - = Config { - inFile :: FilePath -- ^ target fq-file - , outFile :: FilePath -- ^ output file - , srcFile :: FilePath -- ^ src file (*.hs, *.ts, *.c) - , solver :: SMTSolver -- ^ which SMT solver to use - , genSorts :: GenQualifierSort -- ^ generalize qualifier sorts - , ueqAllSorts :: UeqAllSorts -- ^ use UEq on all sorts - , native :: Bool -- ^ use haskell solver - , real :: Bool -- ^ interpret div and mul in SMT - , eliminate :: Bool -- ^ eliminate non-cut KVars - , metadata :: Bool -- ^ print meta-data associated with constraints - , stats :: Bool -- ^ compute constraint statistics - , parts :: Bool -- ^ partition FInfo into separate fq files - } deriving (Eq,Data,Typeable,Show) - -instance Default Config where - def = Config "" def def def def def def def def def def def - -instance Command Config where - command c = command (genSorts c) - ++ command (ueqAllSorts c) - ++ command (solver c) - ++ " -out " - ++ outFile c ++ " " ++ inFile c - ---------------------------------------------------------------------------------------- --- newtype OFilePath = O FilePath --- deriving (Eq, Data,Typeable,Show) --- --- instance Default OFilePath where --- def = O "out" --- --- instance Command OFilePath where --- command (O s) = " -out " ++ s - -newtype GenQualifierSort = GQS Bool - deriving (Eq, Data,Typeable,Show) - -instance Default GenQualifierSort where - def = GQS False - -instance Command GenQualifierSort where - command (GQS True) = "" - command (GQS False) = "-no-gen-qual-sorts" - -newtype UeqAllSorts = UAS Bool - deriving (Eq, Data,Typeable,Show) - -instance Default UeqAllSorts where - def = UAS False - -instance Command UeqAllSorts where - command (UAS True) = " -ueq-all-sorts " - command (UAS False) = "" - - ---------------------------------------------------------------------------------------- - -data SMTSolver = Z3 | Cvc4 | Mathsat | Z3mem - deriving (Eq,Data,Typeable) - -instance Command SMTSolver where - command s = " -smtsolver " ++ show s - -instance Default SMTSolver where - def = Z3 - -instance Show SMTSolver where - show Z3 = "z3" - show Cvc4 = "cvc4" - show Mathsat = "mathsat" - show Z3mem = "z3mem" - -smtSolver "z3" = Z3 -smtSolver "cvc4" = Cvc4 -smtSolver "mathsat" = Mathsat -smtSolver "z3mem" = Z3mem -smtSolver other = error $ "ERROR: unsupported SMT Solver = " ++ other - --- defaultSolver :: Maybe SMTSolver -> SMTSolver --- defaultSolver = fromMaybe Z3 - -config :: Config -config = Config { - inFile = def &= typ "TARGET" &= args &= typFile - , outFile = "out" &= help "Output file" - , srcFile = def &= help "Source File from which FQ is generated" - , solver = def &= help "Name of SMT Solver" - , genSorts = def &= help "Generalize qualifier sorts" - , ueqAllSorts = def &= help "Use UEq on all sorts" - , native = False &= help "(alpha) Haskell Solver" - , real = False &= help "(alpha) Theory of real numbers" - , eliminate = False &= help "(alpha) Eliminate non-cut KVars" - , metadata = False &= help "Print meta-data associated with constraints" - , stats = False &= help "Compute constraint statistics" - , parts = False &= help "Partition constraints into indepdendent .fq files" - } - &= verbosity - &= program "fixpoint" - &= help "Predicate Abstraction Based Horn-Clause Solver" - &= summary "fixpoint Copyright 2009-15 Regents of the University of California." - &= details [ "Predicate Abstraction Based Horn-Clause Solver" - , "" - , "To check a file foo.fq type:" - , " fixpoint foo.fq" - ] - -getOpts :: IO Config -getOpts = do md <- cmdArgs config - putStrLn banner - return md - -banner :: String -banner = "Liquid-Fixpoint Copyright 2009-13 Regents of the University of California.\n" - ++ "All Rights Reserved.\n" diff --git a/src/Language/Fixpoint/Errors.hs b/src/Language/Fixpoint/Errors.hs deleted file mode 100644 --- a/src/Language/Fixpoint/Errors.hs +++ /dev/null @@ -1,135 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Language.Fixpoint.Errors ( - -- * Concrete Location Type - SrcSpan (..) - , dummySpan - , sourcePosElts - - -- * Abstract Error Type - , Error - - -- * Constructor - , err - - -- * Accessors - , errLoc - , errMsg - - -- * Adding Insult to Injury - , catMessage - , catError - - -- * Fatal Exit - , die - , exit - - ) where - -import Control.Exception -import qualified Control.Monad.Error as E -import Data.Generics (Data) -import Data.Hashable -import Data.Typeable -import GHC.Generics (Generic) -import Language.Fixpoint.PrettyPrint -import Language.Fixpoint.Types -import Text.Parsec.Pos -import Text.PrettyPrint.HughesPJ -import Text.Printf - ------------------------------------------------------------------------ --- | A Reusable SrcSpan Type ------------------------------------------ ------------------------------------------------------------------------ - -data SrcSpan = SS { sp_start :: !SourcePos, sp_stop :: !SourcePos} - deriving (Eq, Ord, Show, Data, Typeable, Generic) - -instance PPrint SrcSpan where - pprint = ppSrcSpan - --- ppSrcSpan_short z = parens --- $ text (printf "file %s: (%d, %d) - (%d, %d)" (takeFileName f) l c l' c') --- where --- (f,l ,c ) = sourcePosElts $ sp_start z --- (_,l',c') = sourcePosElts $ sp_stop z - - -ppSrcSpan z = text (printf "%s:%d:%d-%d:%d" f l c l' c') - -- parens $ text (printf "file %s: (%d, %d) - (%d, %d)" (takeFileName f) l c l' c') - where - (f,l ,c ) = sourcePosElts $ sp_start z - (_,l',c') = sourcePosElts $ sp_stop z - -sourcePosElts s = (src, line, col) - where - src = sourceName s - line = sourceLine s - col = sourceColumn s - -instance Hashable SourcePos where - hashWithSalt i = hashWithSalt i . sourcePosElts - -instance Hashable SrcSpan where - hashWithSalt i z = hashWithSalt i (sp_start z, sp_stop z) - - - ---------------------------------------------------------------------------- --- errorInfo :: Error -> (SrcSpan, String) --- ------------------------------------------------------------------------ --- errorInfo (Error l msg) = (l, msg) - - ------------------------------------------------------------------------ --- | A BareBones Error Type ------------------------------------------- ------------------------------------------------------------------------ - -data Error = Error { errLoc :: SrcSpan, errMsg :: String } - deriving (Eq, Ord, Show, Data, Typeable, Generic) - -instance PPrint Error where - pprint (Error l msg) = ppSrcSpan l <> text (": Error: " ++ msg) - -- text $ printf "%s\n %s\n" (showpp l) msg - -instance Fixpoint Error where - toFix = pprint - -instance Exception Error - -instance E.Error Error where - strMsg = Error dummySpan - -dummySpan = SS l l - where l = initialPos "" - - ---------------------------------------------------------------------- -catMessage :: Error -> String -> Error ---------------------------------------------------------------------- -catMessage e msg = e {errMsg = msg ++ errMsg e} - ---------------------------------------------------------------------- -catError :: Error -> Error -> Error ---------------------------------------------------------------------- -catError e1 e2 = catMessage e1 $ show e2 - ---------------------------------------------------------------------- -err :: SrcSpan -> String -> Error ---------------------------------------------------------------------- -err = Error - ---------------------------------------------------------------------- -die :: Error -> a ---------------------------------------------------------------------- -die = throw - ---------------------------------------------------------------------- -exit :: a -> IO a -> IO a ---------------------------------------------------------------------- -exit def act = catch act $ \(e :: Error) -> do - putStrLn $ "Unexpected Error: " ++ showpp e - return def diff --git a/src/Language/Fixpoint/Files.hs b/src/Language/Fixpoint/Files.hs deleted file mode 100644 --- a/src/Language/Fixpoint/Files.hs +++ /dev/null @@ -1,178 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} - --- | This module contains Haskell variables representing globally visible --- names for files, paths, extensions. --- --- Rather than have strings floating around the system, all constant names --- should be defined here, and the (exported) variables should be used and --- manipulated elsewhere. - -module Language.Fixpoint.Files ( - - -- * Hardwired file extension names - Ext (..) - , extFileName - , extFileNameR - , tempDirectory - , extModuleName - , withExt - , isExtFile - - -- * Hardwired paths - , getFixpointPath - , getZ3LibPath - - -- * Various generic utility functions for finding and removing files - , getFileInDirs - , copyFiles - -) where - -import qualified Control.Exception as Ex -import Control.Monad -import Data.Functor ((<$>)) -import Data.List hiding (find) -import Data.Maybe (fromMaybe) -import System.Directory -import System.FilePath -import Language.Fixpoint.Misc - ------------------------------------------------------------- --- | Hardwired Paths and Files ----------------------------- ------------------------------------------------------------- - -getFixpointPath = fromMaybe msg . msum <$> - sequence [ findExecutable "fixpoint.native" - , findExecutable "fixpoint.native.exe" - -- fallback for developing in-tree... - , findFile ["external/fixpoint"] "fixpoint.native" - ] - where - msg = errorstar "Cannot find fixpoint binary [fixpoint.native]" - -getZ3LibPath = dropFileName <$> getFixpointPath - - -checkM f msg p - = do ex <- f p - if ex then return p else errorstar $ "Cannot find " ++ msg ++ " at :" ++ p - - - ----------------------------------------------------------------------------------- - -data Ext = Cgi -- ^ Constraint Generation Information - | Fq -- ^ Input to constraint solving (fixpoint) - | Out -- ^ Output from constraint solving (fixpoint) - | Html -- ^ HTML file with inferred type annotations - | Annot -- ^ Text file with inferred types - | Vim -- ^ Vim annotation file - | Hs -- ^ Haskell source - | LHs -- ^ Literate Haskell source - | Js -- ^ JavaScript source - | Ts -- ^ Typescript source - | Spec -- ^ Spec file (e.g. include/Prelude.spec) - | Hquals -- ^ Qualifiers file (e.g. include/Prelude.hquals) - | Result -- ^ Final result: SAFE/UNSAFE - | Cst -- ^ HTML file with templates? - | Mkdn -- ^ Markdown file (temporarily generated from .Lhs + annots) - | Json -- ^ JSON file containing result (annots + errors) - | Saved -- ^ Previous source (for incremental checking) - | Cache -- ^ Previous output (for incremental checking) - | Dot -- ^ Constraint Graph - | Part Int -- ^ Partition - | Pred - | PAss - | Dat - | Smt2 -- ^ SMTLIB2 query file - deriving (Eq, Ord, Show) - -extMap e = go e - where - go Cgi = ".cgi" - go Pred = ".pred" - go PAss = ".pass" - go Dat = ".dat" - go Out = ".fqout" - go Fq = ".fq" - go Html = ".html" - go Cst = ".cst" - go Annot = ".annot" - go Vim = ".vim.annot" - go Hs = ".hs" - go LHs = ".lhs" - go Js = ".js" - go Ts = ".ts" - go Mkdn = ".markdown" - go Json = ".json" - go Spec = ".spec" - go Hquals = ".hquals" - go Result = ".out" - go Saved = ".bak" - go Cache = ".err" - go Smt2 = ".smt2" - go Dot = ".dot" - go (Part n) = "." ++ show n - -- go _ = errorstar $ "extMap: Unknown extension " ++ show e - -withExt :: FilePath -> Ext -> FilePath -withExt f ext = replaceExtension f (extMap ext) - -extFileName :: Ext -> FilePath -> FilePath -extFileName e f = path addExtension file ext - where - path = tempDirectory f - file = takeFileName f - ext = extMap e - -tempDirectory :: FilePath -> FilePath -tempDirectory f - | isTmp dir = dir - | otherwise = dir tmpDirName - where - dir = takeDirectory f - isTmp = (tmpDirName `isSuffixOf`) - -tmpDirName = ".liquid" - -extFileNameR :: Ext -> FilePath -> FilePath -extFileNameR ext = (`addExtension` extMap ext) - -isExtFile :: Ext -> FilePath -> Bool -isExtFile ext = (extMap ext ==) . takeExtension - -extModuleName :: String -> Ext -> FilePath -extModuleName modName ext = - case explode modName of - [] -> errorstar $ "malformed module name: " ++ modName - ws -> extFileNameR ext $ foldr1 () ws - where - explode = words . map (\c -> if c == '.' then ' ' else c) - -copyFiles :: [FilePath] -> FilePath -> IO () -copyFiles srcs tgt - = do Ex.catch (removeFile tgt) $ \(_ :: Ex.IOException) -> return () - forM_ srcs (readFile >=> appendFile tgt) - - ----------------------------------------------------------------------------------- - --- getHsTargets p = mapM canonicalizePath =<< files --- where --- files --- | hasTrailingPathSeparator p = getHsSourceFiles p --- | otherwise = return [p] - --- getHsSourceFiles = find dirs hs --- where hs = extension ==? ".hs" ||? extension ==? ".lhs" --- dirs = liftM (not . ("dist" `isSuffixOf`)) directory - ---------------------------------------------------------------------------- - - -getFileInDirs :: FilePath -> [FilePath] -> IO (Maybe FilePath) -getFileInDirs name = findFirst (testM doesFileExist . ( name)) - --- findFileInDirs :: FilePath -> [FilePath] -> IO FilePath --- findFileInDirs file dirs --- = liftM (fromMaybe err) (findFirst (find always (fileName ==? file)) dirs) --- where err = errorstar $ "findFileInDirs: cannot find " ++ file ++ " in " ++ show dirs diff --git a/src/Language/Fixpoint/Interface.hs b/src/Language/Fixpoint/Interface.hs deleted file mode 100644 --- a/src/Language/Fixpoint/Interface.hs +++ /dev/null @@ -1,192 +0,0 @@ --- | This module implements the top-level API for interfacing with Fixpoint --- In particular it exports the functions that solve constraints supplied --- either as .fq files or as FInfo. -{-# LANGUAGE CPP #-} - -module Language.Fixpoint.Interface ( - - -- * Containing Constraints - FInfo (..) - - -- * Invoke Solver on an FInfo - , solve - - -- * Invoke Solver on a .fq file - , solveFQ - - -- * Function to determine outcome - , resultExit - - -- * Parse Qualifiers from File - , parseFInfo -) where - -import Control.Monad (when) -import qualified Data.HashMap.Strict as M -import Data.List hiding (partition) - -#if __GLASGOW_HASKELL__ < 710 -import Data.Functor -import Data.Monoid (mconcat, mempty) -import Data.Hashable -import System.Directory (getTemporaryDirectory) -import System.FilePath (()) -#endif - - -import System.Exit -import System.IO (IOMode (..), hPutStr, withFile) -import Text.Printf - -import Language.Fixpoint.Solver.Eliminate (eliminateAll) -import Language.Fixpoint.Solver.Uniqify (renameAll) -import qualified Language.Fixpoint.Solver.Solve as S -import Language.Fixpoint.Config hiding (solver) -import Language.Fixpoint.Files hiding (Result) -import Language.Fixpoint.Misc -import Language.Fixpoint.Statistics (statistics) -import Language.Fixpoint.Partition (partition) -import Language.Fixpoint.Parse (rr, rr') -import Language.Fixpoint.Types hiding (kuts, lits) -import Language.Fixpoint.Errors (exit) -import Language.Fixpoint.PrettyPrint (showpp) -import System.Console.CmdArgs.Verbosity hiding (Loud) -import Text.PrettyPrint.HughesPJ - ---------------------------------------------------------------------------- --- | Solve .fq File ------------------------------------------------------- ---------------------------------------------------------------------------- -solveFQ :: Config -> IO ExitCode ---------------------------------------------------------------------------- -solveFQ cfg - | native cfg = solveNative cfg (solve cfg) - | otherwise = solveFile cfg - ---------------------------------------------------------------------------- --- | Solve FInfo system of horn-clause constraints ------------------------ ---------------------------------------------------------------------------- - -- parts cfg = partition cfg x - -- stats cfg = statistics cfg x - -- native cfg = solveNativeWithFInfo cfg x - -- otherwise = solveExt cfg x - -solve :: (Fixpoint a) => Config -> FInfo a -> IO (Result a) -solve cfg - | parts cfg = partition cfg - | stats cfg = statistics cfg - | native cfg = solveNativeWithFInfo cfg - | otherwise = solveExt cfg - ---------------------------------------------------------------------------- --- | Native Haskell Solver ---------------------------------------------------------------------------- -solveNative :: Config -> (FInfo () -> IO (Result ())) -> IO ExitCode -solveNative cfg s = exit (ExitFailure 2) $ do - let file = inFile cfg - str <- readFile file - let fi = rr' file str :: FInfo () - res <- s fi - return $ resultExit (resStatus res) - -solveNativeWithFInfo :: (Fixpoint a) => Config -> FInfo a -> IO (Result a) -solveNativeWithFInfo cfg fi = do - whenLoud $ putStrLn $ "fq file in: \n" ++ render (toFixpoint cfg fi) - donePhase Loud "Read Constraints" - let fi' = renameAll fi - whenLoud $ putStrLn $ "fq file after uniqify: \n" ++ render (toFixpoint cfg fi') - donePhase Loud "Uniqify" - fi'' <- elim cfg fi' - donePhase Loud "Eliminate" - whenLoud $ putStrLn $ "fq file after eliminate: \n" ++ render (toFixpoint cfg fi') - Result stat soln <- S.solve cfg fi'' - donePhase Loud "Solve" - let stat' = sid <$> stat - putStrLn $ "Solution:\n" ++ showpp soln - putStrLn $ "Result: " ++ show stat' - return $ Result stat soln - - -elim :: (Fixpoint a) => Config -> FInfo a -> IO (FInfo a) -elim cfg fi - | eliminate cfg = do let fi' = eliminateAll fi - whenLoud $ putStrLn $ "fq file after eliminate: \n" ++ render (toFixpoint cfg fi') - return fi' - | otherwise = return fi - ---------------------------------------------------------------------------- --- | External Ocaml Solver ---------------------------------------------------------------------------- -solveExt :: (Fixpoint a) => Config -> FInfo a -> IO (Result a) -solveExt cfg fi = {-# SCC "Solve" #-} execFq cfg fn fi - >>= {-# SCC "exitFq" #-} exitFq fn (cm fi) - where - fn = srcFile cfg - -execFq :: (Fixpoint a) => Config -> FilePath -> FInfo a -> IO ExitCode -execFq cfg fn fi - = do writeFile fq qstr - withFile fq AppendMode (\h -> {-# SCC "HPrintDump" #-} hPutStr h (render d)) - solveFile $ cfg `withTarget` fq - where - fq = extFileName Fq fn - d = {-# SCC "FixPointify" #-} toFixpoint cfg fi - qstr = render (vcat (toFix <$> quals fi) $$ text "\n") - -solveFile :: Config -> IO ExitCode -solveFile cfg - = do fp <- getFixpointPath - z3 <- getZ3LibPath - v <- (\b -> if b then "-v 1" else "") <$> isLoud - {-# SCC "sysCall:Fixpoint" #-} executeShellCommand "fixpoint" $ fixCommand fp z3 v - where - fixCommand fp z3 verbosity - = printf "LD_LIBRARY_PATH=%s %s %s %s -notruekvars -refinesort -nosimple -strictsortcheck -sortedquals %s" - z3 fp verbosity rf (command cfg) - where - rf = if real cfg then realFlags else "" - -realFlags :: String -realFlags = "-no-uif-multiply " - ++ "-no-uif-divide " - - -exitFq :: FilePath -> M.HashMap Integer (SubC a) -> ExitCode -> IO (Result a) -exitFq _ _ (ExitFailure n) | n /= 1 - = return $ Result (Crash [] "Unknown Error") M.empty -exitFq fn z _ - = do str <- {-# SCC "readOut" #-} readFile (extFileName Out fn) - let (x, y) = parseFixpointOutput str - let x' = fmap (mlookup z) x - return $ Result x' y - -parseFixpointOutput :: String -> (FixResult Integer, FixSolution) -parseFixpointOutput str = {-# SCC "parseFixOut" #-} rr ({-# SCC "sanitizeFixpointOutput" #-} sanitizeFixpointOutput str) - -sanitizeFixpointOutput :: String -> String -sanitizeFixpointOutput - = unlines - . filter (not . ("//" `isPrefixOf`)) - . chopAfter ("//QUALIFIERS" `isPrefixOf`) - . lines - ---------------------------------------------------------------------------- -resultExit :: FixResult a -> ExitCode ---------------------------------------------------------------------------- -resultExit Safe = ExitSuccess -resultExit (Unsafe _) = ExitFailure 1 -resultExit _ = ExitFailure 2 - - ---------------------------------------------------------------------------- --- | Parse External Qualifiers -------------------------------------------- ---------------------------------------------------------------------------- -parseFInfo :: [FilePath] -> IO (FInfo a) -- [Qualifier] ---------------------------------------------------------------------------- -parseFInfo fs = mconcat <$> mapM parseFI fs - -parseFI :: FilePath -> IO (FInfo a) --[Qualifier] -parseFI f = do - str <- readFile f - let fi = rr' f str :: FInfo () - return $ mempty { quals = quals fi - , gs = gs fi } diff --git a/src/Language/Fixpoint/Minimize.hs b/src/Language/Fixpoint/Minimize.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fixpoint/Minimize.hs @@ -0,0 +1,74 @@ +-- | This module implements a "delta-debugging" based query minimizer +-- that attempts to shrink UNSAT queries down to a minimal subset +-- of constraints. + +{-# LANGUAGE ScopedTypeVariables #-} + +module Language.Fixpoint.Minimize ( minQuery ) where + +import qualified Data.HashMap.Strict as M +import Control.Monad (filterM) +import Language.Fixpoint.Types.Config (Config (..)) +import Language.Fixpoint.Types.Errors +import Language.Fixpoint.Utils.Files hiding (Result) +import Language.Fixpoint.Partition -- (mcInfo, partition, partition') +import Language.Fixpoint.Types +import Control.DeepSeq + +concatMapM :: (Monad m) => (a -> m [b]) -> [a] -> m [b] +concatMapM f = fmap concat . mapM f + +--------------------------------------------------------------------------- +minQuery :: (NFData a, Fixpoint a) => Config -> Solver a -> FInfo a + -> IO (Result (Integer, a)) +--------------------------------------------------------------------------- +minQuery cfg solve fi = do + let cfg' = cfg { minimize = False } + let (_, fis) = partition' Nothing fi + failFis <- filterM (fmap isUnsafe . solve cfg') fis + failCs <- concatMapM (getMinFailingCons cfg' solve) failFis + let minFi = fi { cm = M.fromList failCs, fileName = minFileName fi } + saveQuery cfg' minFi + putStrLn $ "Minimized Constraints: " ++ show (fst <$> failCs) + return mempty + +minFileName :: FInfo a -> FilePath +minFileName = extFileName Min . fileName + +isUnsafe :: Result a -> Bool +isUnsafe (Result Safe _) = False +isUnsafe _ = True + +type ConsList a = [(Integer, SubC a)] +type Oracle a c = (Config -> Solver a -> FInfo a -> [c] -> IO Bool) + +-- polymorphic delta debugging implementation +deltaDebug :: Oracle a c -> Config -> Solver a -> FInfo a -> [c] -> [c] -> IO [c] +deltaDebug testSet cfg solve finfo set r = do + let (s1, s2) = splitAt (length set `div` 2) set + if length set == 1 + then return set + else do + test1 <- testSet cfg solve finfo (s1 ++ r) + if test1 + then deltaDebug testSet cfg solve finfo s1 r + else do + test2 <- testSet cfg solve finfo (s2 ++ r) + if test2 + then deltaDebug testSet cfg solve finfo s2 r + else do + d1 <- deltaDebug testSet cfg solve finfo s1 (s2 ++ r) + d2 <- deltaDebug testSet cfg solve finfo s2 (s1 ++ r) + return (d1 ++ d2) + +testConstraints :: (NFData a, Fixpoint a) => Config -> Solver a -> FInfo a -> ConsList a -> IO Bool +testConstraints cfg solve fi cons = do + let fi' = fi { cm = M.fromList cons } + res <- solve cfg fi' + return $ isUnsafe res + +-- run delta debugging on a failing partition to find minimal set of failing constraints +getMinFailingCons :: (NFData a, Fixpoint a) => Config -> Solver a -> FInfo a -> IO (ConsList a) +getMinFailingCons cfg solve fi = do + let cons = M.toList $ cm fi + deltaDebug testConstraints cfg solve fi cons [] diff --git a/src/Language/Fixpoint/Misc.hs b/src/Language/Fixpoint/Misc.hs --- a/src/Language/Fixpoint/Misc.hs +++ b/src/Language/Fixpoint/Misc.hs @@ -1,35 +1,74 @@ -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE ImplicitParams #-} -- ignore hlint module Language.Fixpoint.Misc where -import qualified Control.Exception as Ex +-- import System.IO.Unsafe (unsafePerformIO) +import Control.Exception (bracket_) import Data.Hashable -import Data.Traversable (traverse) -import qualified Data.HashSet as S -import Control.Applicative ((<$>)) -import Control.Monad (forM_, (>=>)) -import qualified Data.ByteString as B -import Data.ByteString.Char8 (pack, unpack) +-- import Data.IORef +import Control.Arrow (second) +import Control.Monad (forM_) import qualified Data.HashMap.Strict as M import qualified Data.List as L import Data.Tuple (swap) -import Data.Maybe (fromJust, catMaybes, fromMaybe) -import qualified Data.Text as T - -import Data.Data +import Data.Maybe +import Data.Array hiding (indices) +import Data.Function (on) import Debug.Trace (trace) import System.Console.ANSI import System.Console.CmdArgs.Verbosity (whenLoud) -import System.Exit import System.Process (system) +import System.Directory (createDirectoryIfMissing) +import System.FilePath (takeDirectory) +import Text.PrettyPrint.HughesPJ hiding (first) +import System.IO (stdout, hFlush ) +import Control.Concurrent.Async -import Text.PrettyPrint.HughesPJ +#ifdef MIN_VERSION_located_base +import Prelude hiding (error, undefined) +import GHC.Err.Located +import GHC.Stack +#endif +firstMaybe :: (a -> Maybe b) -> [a] -> Maybe b +firstMaybe f = listToMaybe . mapMaybe f + + +asyncMapM :: (a -> IO b) -> [a] -> IO [b] +asyncMapM f xs = mapM (async . f) xs >>= mapM wait + +traceShow :: Show a => String -> a -> a +traceShow s x = trace ("\nTrace: [" ++ s ++ "] : " ++ show x) x + +hashMapToAscList :: Ord a => M.HashMap a b -> [(a, b)] +hashMapToAscList = L.sortBy (compare `on` fst) . M.toList + +--------------------------------------------------------------- +-- | Edit Distance -------------------------------------------- +--------------------------------------------------------------- + +editDistance :: Eq a => [a] -> [a] -> Int +editDistance xs ys = table ! (m, n) + where + (m,n) = (length xs, length ys) + x = array (1,m) (zip [1..] xs) + y = array (1,n) (zip [1..] ys) + + table :: Array (Int,Int) Int + table = array bnds [(ij, dist ij) | ij <- range bnds] + bnds = ((0,0),(m,n)) + + dist (0,j) = j + dist (i,0) = i + dist (i,j) = minimum [table ! (i-1,j) + 1, table ! (i,j-1) + 1, + if x ! i == y ! j then table ! (i-1,j-1) else 1 + table ! (i-1,j-1)] + ----------------------------------------------------------------------------------- ------------ Support for Colored Logging ------------------------------------------ ----------------------------------------------------------------------------------- @@ -44,9 +83,6 @@ wrapStars msg = "\n**** " ++ msg ++ " " ++ replicate (74 - length msg) '*' -wrapStarsWithOptStars True msg = "\n**** " ++ msg ++ " " ++ replicate (74 - length msg) '*' -wrapStarsWithOptStars False msg = wrapStars msg - -- withColor _ act = act withColor c act = do setSGR [ SetConsoleIntensity BoldIntensity, SetColor Foreground Vivid c] @@ -58,51 +94,26 @@ startPhase c msg = colorPhaseLn c "START: " msg >> colorStrLn Ok " " doneLine c msg = colorPhaseLn c "DONE: " msg >> colorStrLn Ok " " -colorPhaseLnWithOptStars v c msg = colorStrLn c . wrapStarsWithOptStars v . (msg ++) -startPhaseWithOptStars v c msg = colorPhaseLnWithOptStars v c "START: " msg >> colorStrLn Ok " " -doneLineWithOptStars v c msg = colorPhaseLnWithOptStars v c "DONE: " msg >> colorStrLn Ok " " - donePhase c str = case lines str of - (l:ls) -> doneLine c l >> forM_ ls (colorPhaseLn c "") - _ -> return () - -donePhaseWithOptStars v c str - = case lines str of - (l:ls) -> doneLineWithOptStars v c l >> forM_ ls (colorPhaseLnWithOptStars v c "") + (l:ls) -> doneLine c l >> forM_ ls (colorPhaseLn c "") >> hFlush stdout _ -> return () +putBlankLn = putStrLn "" >> hFlush stdout ----------------------------------------------------------------------------------- - -data Empty = Emp deriving (Data, Typeable, Eq, Show) - -unIntersperse x ys - = case L.elemIndex x ys of - Nothing -> [ys] - Just i -> let (y, _:ys') = splitAt i ys - in (y : unIntersperse x ys') - -(=>>) m f = m >>= (\x -> f x >> return x) - wrap l r s = l ++ s ++ r repeats n = concat . replicate n +#ifdef MIN_VERSION_located_base +errorstar :: (?callStack :: CallStack) => String -> a +#endif + errorstar = error . wrap (stars ++ "\n") (stars ++ "\n") where stars = repeats 3 $ wrapStars "ERROR" -errortext = errorstar . render - -putDocLn :: Doc -> IO () -putDocLn = putStrLn . render - -assertstar _ True x = x -assertstar msg False x = errorstar msg - -findWithDefaultL f ls d = fromMaybe d (L.find f ls) - fst3 :: (a, b, c) -> a fst3 (x,_,_) = x @@ -112,68 +123,40 @@ thd3 :: (a, b, c) -> c thd3 (_,_,x) = x -single :: a -> [a] -single x = [x] - -mapFst f (x, y) = (f x, y) -mapSnd f (x, y) = (x, f y) - -mapFst3 f (x, y, z) = (f x, y, z) -mapSnd3 f (x, y, z) = (x, f y, z) -mapThd3 f (x, y, z) = (x, y, f z) - -expandSnd = concatMap (\(xs, y) -> (, y) <$> xs) - -mapPair :: (a -> b) -> (a, a) -> (b, b) -mapPair f (x, y) = (f x, f y) +#ifdef MIN_VERSION_located_base +mlookup :: (?callStack :: CallStack, Eq k, Show k, Hashable k) => M.HashMap k v -> k -> v +safeLookup :: (?callStack :: CallStack, Eq k, Hashable k) => String -> k -> M.HashMap k v -> v +mfromJust :: (?callStack :: CallStack) => String -> Maybe a -> a +#else +mlookup :: (Eq k, Show k, Hashable k) => M.HashMap k v -> k -> v +safeLookup :: (Eq k, Hashable k) => String -> k -> M.HashMap k v -> v +mfromJust :: String -> Maybe a -> a +#endif -mlookup :: (Eq k, Show k, Hashable k) => M.HashMap k v -> k -> v -mlookup m k = case M.lookup k m of - Just v -> v - Nothing -> errorstar $ "mlookup: unknown key " ++ show k +mlookup m k = fromMaybe err $ M.lookup k m + where + err = errorstar $ "mlookup: unknown key " ++ show k -safeLookup :: (Eq k, Hashable k) => String -> k -> M.HashMap k v -> v safeLookup msg k m = fromMaybe (errorstar msg) (M.lookup k m) -mfromJust :: String -> Maybe a -> a mfromJust _ (Just x) = x mfromJust s Nothing = errorstar $ "mfromJust: Nothing " ++ s -boxStrCat :: String -> [String] -> String -boxStrCat sep = ("[" ++) . (++ "]") . L.intercalate sep - -tryIgnore :: String -> IO () -> IO () -tryIgnore s a = Ex.catch a $ \e -> - do let err = show (e :: Ex.IOException) - whenLoud $ putStrLn ("Warning: Couldn't do " ++ s ++ ": " ++ err) - return () - -traceShow :: Show a => String -> a -> a -traceShow s x = trace ("\nTrace: [" ++ s ++ "] : " ++ show x) $ x - -warnShow :: Show a => String -> a -> a -warnShow s x = trace ("\nWarning: [" ++ s ++ "] : " ++ show x) $ x - -- inserts :: Hashable k => k -> v -> M.HashMap k [v] -> M.HashMap k [v] inserts k v m = M.insert k (v : M.lookupDefault [] k m) m -concatMaps = fmap sortNub . L.foldl' (M.unionWith (++)) M.empty +count :: (Eq k, Hashable k) => [k] -> [(k, Int)] +count = M.toList . fmap sum . group . fmap (, 1) --- group :: Hashable k => [(k, v)] -> M.HashMap k [v] +group :: (Eq k, Hashable k) => [(k, v)] -> M.HashMap k [v] group = groupBase M.empty + groupBase = L.foldl' (\m (k, v) -> inserts k v m) groupList = M.toList . group -groupFun :: (Eq k, Hashable k) => M.HashMap k Int -> k -> Int -groupFun m k = safeLookup "groupFun" k m - -mkGraph :: (Eq a, Eq b, Hashable a, Hashable b) => [(a, b)] -> M.HashMap a (S.HashSet b) -mkGraph = fmap S.fromList . group - - -- groupMap :: Hashable k => (a -> k) -> [a] -> M.HashMap k [a] -groupMap f xs = L.foldl' (\m x -> inserts (f x) x m) M.empty xs +groupMap f = L.foldl' (\m x -> inserts (f x) x m) M.empty sortNub :: (Ord a) => [a] -> [a] sortNub = nubOrd . L.sort @@ -183,35 +166,10 @@ nubOrd xs = xs -sortDiff :: (Ord a) => [a] -> [a] -> [a] -sortDiff x1s x2s = go (sortNub x1s) (sortNub x2s) - where - go xs@(x:xs') ys@(y:ys') - | x < y = x : go xs' ys - | x == y = go xs' ys' - | otherwise = go xs ys' - go xs [] = xs - go [] _ = [] - - - -folds :: (a -> b -> (c, a)) -> a -> [b] -> ([c], a) -folds f b = L.foldl' step ([], b) - where - step (cs, acc) x = (c:cs, x') - where - (c, x') = f acc x - - - -distinct :: Ord a => [a] -> Bool -distinct xs = length xs == length (sortNub xs) - -tr_reverse :: [a] -> [a] -tr_reverse = L.foldl' (flip (:)) [] - -tr_foldr' :: (a -> b -> b) -> b -> [a] -> b -tr_foldr' f b = L.foldl' (flip f) b . tr_reverse +#ifdef MIN_VERSION_located_base +safeZip :: (?callStack :: CallStack) => String -> [a] -> [b] -> [(a,b)] +safeZipWith :: (?callStack :: CallStack) => String -> (a -> b -> c) -> [a] -> [b] -> [c] +#endif safeZip msg xs ys | nxs == nys @@ -221,8 +179,6 @@ where nxs = length xs nys = length ys --- eqLen = on (==) length - safeZipWith msg f xs ys | nxs == nys = zipWith f xs ys @@ -231,197 +187,68 @@ where nxs = length xs nys = length ys --- safe0ZipWith msg f xs ys --- | length xs == length ys --- = zipWith f xs ys --- safe0ZipWith _ _ [] _ --- = [] --- safe0ZipWith _ _ _ [] --- = [] --- safe0ZipWith msg _ xs ys --- = errorstar $ "safeZipWith called on non-eq-sized lists (nxs = " ++ show nxs ++ ", nys = " ++ show nys ++ ") : " ++ msg --- where nxs = length xs --- nys = length ys - --- safeFromList :: (Hashable k, Show k, Show a) => String -> [(k, a)] -> M.HashMap k a -safeFromList msg = L.foldl' safeAdd M.empty - where safeAdd m (k, v) - | k `M.member` m = errorstar $ msg ++ "Duplicate key " ++ show k ++ "maps to: \n" ++ (show v) ++ "\n and \n" ++ show (m M.! k) - | otherwise = M.insert k v m - -safeUnion msg m1 m2 = - case L.find (`M.member` m1) (M.keys m2) of - Just k -> errorstar $ "safeUnion with common key = " ++ show k ++ " " ++ msg - Nothing -> M.union m1 m2 - {-@ type ListNE a = {v:[a] | 0 < len v} @-} type ListNE a = [a] -safeHead :: String -> ListNE a -> a +#ifdef MIN_VERSION_located_base +safeHead :: (?callStack :: CallStack) => String -> ListNE a -> a +safeLast :: (?callStack :: CallStack) => String -> ListNE a -> a +safeInit :: (?callStack :: CallStack) => String -> ListNE a -> [a] +safeUncons :: (?callStack :: CallStack) => String -> ListNE a -> (a, [a]) +safeUnsnoc :: (?callStack :: CallStack) => String -> ListNE a -> ([a], a) +#else +safeHead :: String -> ListNE a -> a +safeLast :: String -> ListNE a -> a +safeInit :: String -> ListNE a -> [a] +safeUncons :: String -> ListNE a -> (a, [a]) +safeUnsnoc :: String -> ListNE a -> ([a], a) +#endif + safeHead _ (x:_) = x safeHead msg _ = errorstar $ "safeHead with empty list " ++ msg -safeLast :: String -> ListNE a -> a safeLast _ xs@(_:_) = last xs safeLast msg _ = errorstar $ "safeLast with empty list " ++ msg - -safeInit :: String -> ListNE a -> [a] safeInit _ xs@(_:_) = init xs safeInit msg _ = errorstar $ "safeInit with empty list " ++ msg -safeUncons :: String -> ListNE a -> (a, [a]) safeUncons _ (x:xs) = (x, xs) safeUncons msg _ = errorstar $ "safeUncons with empty list " ++ msg -safeUnsnoc :: String -> ListNE a -> ([a], a) -safeUnsnoc msg = swap . mapSnd reverse . safeUncons msg . reverse - - - --- memoIndex :: (Hashable b) => (a -> Maybe b) -> [a] -> [Maybe Int] -memoIndex f = snd . L.mapAccumL foo M.empty - where - foo memo z = - case f z of - Nothing -> (memo, Nothing) - Just k -> case k `M.lookup` memo of - Just i -> (memo, Just i) - Nothing -> (M.insert k (M.size memo) memo, Just (M.size memo)) - -checkFail :: [Char] -> (a -> Bool) -> a -> a -checkFail msg f x - | f x - = x - | otherwise - = errorstar $ "Check-Failure: " ++ msg - -chopAfter :: (a -> Bool) -> [a] -> [a] -chopAfter f xs - = case L.findIndex f xs of - Just n -> take n xs - Nothing -> xs - -chopPrefix :: (Eq a) => [a] -> [a] -> Maybe [a] -chopPrefix p xs - | p `L.isPrefixOf` xs - = Just $ drop (length p) xs - | otherwise - = Nothing - -firstElem :: (Eq a) => [(a, t)] -> [a] -> Maybe Int -firstElem seps str - = case catMaybes [ L.elemIndex c str | (c, _) <- seps ] of - [] -> Nothing - is -> Just $ minimum is - -chopAlt :: (Eq a) => [(a, a)] -> [a] -> [[a]] -chopAlt seps = go - where go s = maybe [s] (go' s) (firstElem seps s) - go' s i = let (s0, s1@(c:_)) = splitAt i s - (Just c') = lookup c seps - in case L.elemIndex c' s1 of - Nothing -> [s1] - Just i' -> let (s2, s3) = splitAt (i' + 1) s1 in - s0 : s2 : go s3 - -firstElems :: [(B.ByteString, B.ByteString)] -> B.ByteString -> Maybe (Int, B.ByteString, (B.ByteString, B.ByteString)) -firstElems seps str - = case splitters seps str of - [] -> Nothing - is -> Just $ L.minimumBy (\x y -> compare (fst3 x) (fst3 y)) is - -splitters seps str - = [(i, c', z) | (c, c') <- seps - , let z = B.breakSubstring c str - , let i = B.length (fst z) - , i < B.length str ] +safeUnsnoc msg = swap . second reverse . safeUncons msg . reverse -bchopAlts :: [(B.ByteString, B.ByteString)] -> B.ByteString -> [B.ByteString] -bchopAlts seps = go - where - go s = maybe [s] (go' s) (firstElems seps s) - go' s (i,c',(s0, s1)) = if (B.length s2 == B.length s1) then [B.concat [s0,s1]] else (s0 : s2' : go s3') - where (s2, s3) = B.breakSubstring c' s1 - s2' = B.append s2 c' - s3' = B.drop (B.length c') s3 - -chopAlts seps str = unpack <$> bchopAlts [(pack c, pack c') | (c, c') <- seps] (pack str) - -findFirst :: Monad m => (t -> m [a]) -> [t] -> m (Maybe a) -findFirst _ [] = return Nothing -findFirst f (x:xs) = do r <- f x - case r of - y:_ -> return (Just y) - [] -> findFirst f xs - -testM f x = do b <- f x - return $ if b then [x] else [] - --- unions :: (Hashable a) => [S.HashSet a] -> S.HashSet a --- unions = foldl' S.union S.empty --- Just S.unions! - -stripParens :: T.Text -> T.Text -stripParens t = fromMaybe t (strip t) - where - strip = T.stripPrefix "(" >=> T.stripSuffix ")" - -ifM :: (Monad m) => m Bool -> m a -> m a -> m a -ifM bm xm ym - = do b <- bm - if b then xm else ym - executeShellCommand phase cmd - = do whenLoud $ putStrLn $ "EXEC: " ++ cmd - Ex.bracket_ (startPhase Loud phase) (donePhase Loud phase) $ system cmd - -executeShellCommandWithOptStars v phase cmd - = do whenLoud $ putStrLn $ "EXEC: " ++ cmd - Ex.bracket_ (startPhaseWithOptStars v Loud phase) (donePhaseWithOptStars v Loud phase) $ system cmd - -checkExitCode _ (ExitSuccess) = return () -checkExitCode cmd (ExitFailure n) = errorstar $ "cmd: " ++ cmd ++ " failure code " ++ show n - -hashMapToAscList :: Ord a => M.HashMap a b -> [(a, b)] -hashMapToAscList = L.sortBy (\x y -> compare (fst x) (fst y)) . M.toList - -hashMapMapWithKey :: (k -> v1 -> v2) -> M.HashMap k v1 -> M.HashMap k v2 -hashMapMapWithKey f = fromJust . M.traverseWithKey (\k v -> Just (f k v)) - -hashMapMapKeys :: (Eq k, Hashable k) => (t -> k) -> M.HashMap t v -> M.HashMap k v -hashMapMapKeys f = M.fromList . fmap (mapFst f) . M.toList - + = do writeLoud $ "EXEC: " ++ cmd + bracket_ (startPhase Loud phase) (donePhase Loud phase) $ system cmd applyNonNull def _ [] = def applyNonNull _ f xs = f xs -concatMapM f = fmap concat . mapM f - - -angleBrackets p = char '<' <> p <> char '>' -dot = char '.' arrow = text "->" dcolon = colon <> colon intersperse d ds = hsep $ punctuate d ds tshow = text . show -foldlMap :: (a -> b -> (c, a)) -> a -> [b] -> ([c], a) -foldlMap f b xs = (reverse zs, res) - where - (zs, res) = L.foldl' ff ([], b) xs - ff (ys, acc) x = let (y, acc') = f acc x in (y:ys, acc') +-- | if loud, write a string to stdout +writeLoud :: String -> IO () +writeLoud s = whenLoud $ putStrLn s >> hFlush stdout -mapEither :: (a -> Either b c) -> [a] -> ([b], [c]) -mapEither f = go [] [] - where - go ls rs [] = (reverse ls, reverse rs) - go ls rs (x:xs) = case f x of - Left l -> go (l:ls) rs xs - Right r -> go ls (r:rs) xs -f <$$> x = traverse f x +ensurePath :: FilePath -> IO () +ensurePath = createDirectoryIfMissing True . takeDirectory + +fM :: (Monad m) => (a -> b) -> a -> m b +fM f = return . f + +{- +exitColorStrLn :: Moods -> String -> IO () +exitColorStrLn c s = do + writeIORef pbRef Nothing --(Just pr) + putStrLn "\n" + colorStrLn c s +-} diff --git a/src/Language/Fixpoint/Names.hs b/src/Language/Fixpoint/Names.hs deleted file mode 100644 --- a/src/Language/Fixpoint/Names.hs +++ /dev/null @@ -1,333 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE ViewPatterns #-} - --- | This module contains Haskell variables representing globally visible names. --- Rather than have strings floating around the system, all constant names --- should be defined here, and the (exported) variables should be used and --- manipulated elsewhere. - -module Language.Fixpoint.Names ( - - -- * Symbols - Symbol - , Symbolic (..) - , anfPrefix, tempPrefix, vv, isPrefixOfSym, isSuffixOfSym, stripParensSym - , consSym, unconsSym, dropSym, singletonSym, headSym, takeWhileSym, lengthSym - , symChars, isNonSymbol, nonSymbol - , isNontrivialVV - , symbolText, symbolString - , encode, vvCon - , dropModuleNames - , dropModuleUnique - , takeModuleNames - - -- * Creating Symbols - , dummySymbol, intSymbol, tempSymbol, existSymbol, renameSymbol - , qualifySymbol - , suffixSymbol - - -- * Hardwired global names - , dummyName - , preludeName - , boolConName - , funConName - , listConName - , tupConName - , propConName - , hpropConName - , strConName - , nilName - , consName - , vvName - , symSepName - , size32Name, size64Name, bitVecName, bvAndName, bvOrName - , prims -) where - -import Control.Applicative -import Control.DeepSeq -import Data.Char -import Data.Generics (Data) -import Data.Hashable -import qualified Data.HashSet as S -import Data.Interned -import Data.Interned.Internal.Text -import Data.Monoid -import Data.String -import Data.Text (Text) -import qualified Data.Text as T -import Data.Typeable (Typeable) -import GHC.Generics (Generic) - -import Language.Fixpoint.Misc (errorstar, mapSnd, stripParens) - - ---------------------------------------------------------------- ----------------------------- Symbols -------------------------- ---------------------------------------------------------------- - -symChars - = ['a' .. 'z'] - ++ ['A' .. 'Z'] - ++ ['0' .. '9'] - ++ ['_', '%', '.', '#'] - -deriving instance Data InternedText -deriving instance Typeable InternedText -deriving instance Generic InternedText - -newtype Symbol = S InternedText deriving (Eq, Ord, Data, Typeable, Generic, IsString) - -instance Monoid Symbol where - mempty = "" - mappend x y = S . intern $ mappend (symbolText x) (symbolText y) - -instance Hashable InternedText where - hashWithSalt s (InternedText i t) = hashWithSalt s i - -instance NFData InternedText where - rnf (InternedText id t) = rnf id `seq` rnf t `seq` () - -instance Show Symbol where - show (S x) = show x - -instance NFData Symbol where - rnf (S x) = rnf x - -instance Hashable Symbol where - hashWithSalt i (S s) = hashWithSalt i s - -symbolString :: Symbol -> String -symbolString = T.unpack . symbolText - ---------------------------------------------------------------------------- ------- Converting Strings To Fixpoint ------------------------------------- ---------------------------------------------------------------------------- - --- stringSymbolRaw :: String -> Symbol --- stringSymbolRaw = S - -encode :: String -> String -encode s - | isFixKey s = encodeSym s - | isFixSym' s = s - | otherwise = encodeSym s -- S $ fixSymPrefix ++ concatMap encodeChar s - -encodeSym s = fixSymPrefix ++ concatMap encodeChar s - -symbolText :: Symbol -> Text -symbolText (S s) = unintern s - --- symbolString :: Symbol -> String --- symbolString (S str) --- = case chopPrefix fixSymPrefix str of --- Just s -> concat $ zipWith tx indices $ chunks s --- Nothing -> str --- where --- chunks = unIntersperse symSepName --- tx i s = if even i then s else [decodeStr s] - -indices :: [Integer] -indices = [0..] - -okSymChars - = S.fromList - $ ['a' .. 'z'] - ++ ['A' .. 'Z'] - ++ ['0' .. '9'] - ++ ['_', '.' ] - -fixSymPrefix = "fix" ++ [symSepName] - -isPrefixOfSym (symbolText -> p) (symbolText -> x) = p `T.isPrefixOf` x -isSuffixOfSym (symbolText -> p) (symbolText -> x) = p `T.isSuffixOf` x -takeWhileSym p (symbolText -> t) = symbol $ T.takeWhile p t - -headSym (symbolText -> t) = T.head t -consSym c (symbolText -> s) = symbol $ T.cons c s -singletonSym = (`consSym` "") - -lengthSym (symbolText -> t) = T.length t - -unconsSym :: Symbol -> Maybe (Char, Symbol) -unconsSym (symbolText -> s) = mapSnd symbol <$> T.uncons s - -dropSym :: Int -> Symbol -> Symbol -dropSym n (symbolText -> t) = symbol $ T.drop n t - -stripParensSym (symbolText -> t) = symbol $ stripParens t - -suffixSymbol (S s) suf = symbol $ (unintern s) `mappend` suf - -isFixSym' (c:chs) = isAlpha c && all (`S.member` (symSepName `S.insert` okSymChars)) chs -isFixSym' _ = False - -isFixKey x = S.member x keywords -keywords = S.fromList ["env", "id", "tag", "qualif", "constant", "cut", "bind", "constraint", "grd", "lhs", "rhs"] - -encodeChar c - | c `S.member` okSymChars - = [c] - | otherwise - = [symSepName] ++ (show $ ord c) ++ [symSepName] - -decodeStr s - = chr ((read s) :: Int) - -qualifySymbol :: Symbol -> Symbol -> Symbol -qualifySymbol m'@(symbolText -> m) x'@(symbolText -> x) - | isQualified x = x' - | isParened x = symbol (wrapParens (m `mappend` "." `mappend` stripParens x)) - | otherwise = symbol (m `mappend` "." `mappend` x) - -isQualified y = "." `T.isInfixOf` y -wrapParens x = "(" `mappend` x `mappend` ")" -isParened xs = xs /= stripParens xs - ---------------------------------------------------------------------- - -vv :: Maybe Integer -> Symbol -vv (Just i) = symbol $ symbolText vvName `T.snoc` symSepName `mappend` T.pack (show i) -- S (vvName ++ [symSepName] ++ show i) -vv Nothing = vvName - -vvCon = symbol $ symbolText vvName `T.snoc` symSepName `mappend` "F" -- S (vvName ++ [symSepName] ++ "F") - -isNontrivialVV = not . (vv Nothing ==) - - -dummySymbol = dummyName - -intSymbol :: (Show a) => Symbol -> a -> Symbol -intSymbol x i = x `mappend` symbol ('_' : show i) - -tempSymbol, existSymbol :: Symbol -> Integer -> Symbol -tempSymbol prefix n = intSymbol (tempPrefix `mappend` prefix) n -existSymbol prefix n = intSymbol (existPrefix `mappend` prefix) n - -renameSymbol :: Symbol -> Int -> Symbol -renameSymbol prefix n = intSymbol (renamePrefix `mappend` prefix) n - -tempPrefix, anfPrefix, existPrefix :: Symbol -tempPrefix = "lq_tmp_" -anfPrefix = "lq_anf_" -existPrefix = "lq_ext_" -renamePrefix = "lq_rnm_" - -nonSymbol :: Symbol -nonSymbol = "" -isNonSymbol = (== nonSymbol) - --- | Values that can be viewed as Symbols - -class Symbolic a where - symbol :: a -> Symbol - -instance Symbolic String where - symbol = symbol . T.pack - -instance Symbolic Text where - symbol = S . intern - -instance Symbolic InternedText where - symbol = S - -instance Symbolic Symbol where - symbol = id - - ----------------------------------------------------------------------------- ---------------- Global Name Definitions ------------------------------------ ----------------------------------------------------------------------------- - -preludeName, dummyName, boolConName, funConName, listConName, tupConName, propConName, strConName, vvName :: Symbol -preludeName = "Prelude" -dummyName = "_LIQUID_dummy" -boolConName = "Bool" -funConName = "->" -listConName = "[]" -- "List" -tupConName = "Tuple" -propConName = "Prop" -hpropConName = "HProp" -strConName = "Str" -vvName = "VV" -symSepName = '#' - -nilName = "nil" :: Symbol -consName = "cons" :: Symbol - -size32Name = "Size32" :: Symbol -size64Name = "Size64" :: Symbol -bitVecName = "BitVec" :: Symbol -bvOrName = "bvor" :: Symbol -bvAndName = "bvAnd" :: Symbol - -prims :: [Symbol] -prims = [ propConName - , hpropConName - , vvName - , "Pred" - , "List" - , "Set_Set" - , "Set_sng" - , "Set_cup" - , "Set_cap" - , "Set_dif" - , "Set_emp" - , "Set_empty" - , "Set_mem" - , "Set_sub" - , "Map_t" - , "Map_select" - , "Map_store" - , size32Name - , size64Name - , bitVecName - , bvOrName - , bvAndName - , "FAppTy" - , nilName - , consName - ] - --- dropModuleNames [] = [] --- dropModuleNames s --- | s == tupConName = tupConName --- | otherwise = safeLast msg $ words $ dotWhite `fmap` stripParens s --- where --- msg = "dropModuleNames: " ++ s --- dotWhite '.' = ' ' --- dotWhite c = c - -sepModNames = "." -sepUnique = "#" - -dropModuleNames = mungeNames safeLast sepModNames "dropModuleNames: " -takeModuleNames = mungeNames safeInit sepModNames "takeModuleNames: " - -dropModuleUnique = mungeNames safeHead sepUnique "dropModuleUnique: " - -safeHead :: String -> [T.Text] -> Symbol -safeHead msg [] = errorstar $ "safeHead with empty list" ++ msg -safeHead _ (x:_) = symbol x - -safeInit :: String -> [T.Text] -> Symbol -safeInit _ xs@(_:_) = symbol $ T.intercalate "." $ init xs -safeInit msg _ = errorstar $ "safeInit with empty list " ++ msg - -safeLast :: String -> [T.Text] -> Symbol -safeLast _ xs@(_:_) = symbol $ last xs -safeLast msg _ = errorstar $ "safeLast with empty list " ++ msg - -mungeNames :: (String -> [T.Text] -> Symbol) -> T.Text -> String -> Symbol -> Symbol -mungeNames _ _ _ "" = "" -mungeNames f d msg s'@(symbolText -> s) - | s' == tupConName - = tupConName - | otherwise = f (msg ++ T.unpack s) $ T.splitOn d $ stripParens s diff --git a/src/Language/Fixpoint/Parse.hs b/src/Language/Fixpoint/Parse.hs --- a/src/Language/Fixpoint/Parse.hs +++ b/src/Language/Fixpoint/Parse.hs @@ -5,6 +5,8 @@ {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE OverloadedStrings #-} module Language.Fixpoint.Parse ( @@ -24,6 +26,7 @@ , colon , dcolon , whiteSpace , blanks + , pairP -- * Parsing basic entities @@ -34,6 +37,7 @@ , constantP -- (Integer) Constants , integer -- Integer , bindP -- Binder (lowerIdP <* colon) + , sortP -- Sort , mkQual -- constructing qualifiers -- * Parsing recursive entities @@ -62,32 +66,31 @@ , doParse' , parseFromFile , remainderP + + -- * Utilities + , isSmall ) where -import Control.Applicative ((<$>), (<*), (*>), (<*>)) import qualified Data.HashMap.Strict as M import qualified Data.HashSet as S import qualified Data.Text as T +import Data.Maybe (fromJust) import Text.Parsec import Text.Parsec.Expr -import Text.Parsec.Language +import Text.Parsec.Language (emptyDef) import qualified Text.Parsec.Token as Token -import Text.Printf (printf) +-- import Text.Printf (printf) import GHC.Generics (Generic) -import Data.Char (isLower, toUpper) -import Language.Fixpoint.Bitvector -import Language.Fixpoint.Errors -import Language.Fixpoint.Misc hiding (dcolon) +import Data.Char (isLower) +import Language.Fixpoint.Smt.Bitvector +import Language.Fixpoint.Types.Errors +import Language.Fixpoint.Misc (tshow, sortNub, thd3) import Language.Fixpoint.Smt.Types - -import Language.Fixpoint.Types -import Language.Fixpoint.Visitor (foldSort, mapSort) - -import Data.Maybe (fromJust, fromMaybe, maybe) - -import Data.Monoid (mempty,mconcat) - +--import Language.Fixpoint.Types.Names (headSym) +import Language.Fixpoint.Types.Visitor (foldSort, mapSort) +import Language.Fixpoint.Types hiding (mapSort) +import Text.PrettyPrint.HughesPJ (text, nest, vcat, (<+>)) type Parser = Parsec String Integer -------------------------------------------------------------------- @@ -96,8 +99,8 @@ emptyDef { Token.commentStart = "/* " , Token.commentEnd = " */" , Token.commentLine = "//" - , Token.identStart = satisfy (\_ -> False) - , Token.identLetter = satisfy (\_ -> False) + , Token.identStart = satisfy (const False) + , Token.identLetter = satisfy (const False) , Token.reservedNames = [ "SAT" , "UNSAT" , "true" @@ -172,21 +175,25 @@ l2 <- getPosition return $ Loc l1 l2 x + -- FIXME: we (LH) rely on this parser being dumb and *not* consuming trailing -- whitespace, in order to avoid some parsers spanning multiple lines.. -condIdP :: [Char] -> (String -> Bool) -> Parser Symbol +condIdP :: S.HashSet Char -> (String -> Bool) -> Parser Symbol condIdP chars f - = do c <- letter - cs <- many (satisfy (`elem` chars)) + = do c <- letter <|> char '_' + cs <- many (satisfy (`S.member` chars)) blanks - if f (c:cs) then return (symbol $ T.pack $ c:cs) else parserZero + if f (c:cs) then return (symbol $ c:cs) else parserZero upperIdP :: Parser Symbol -upperIdP = condIdP symChars (not . isLower . head) +upperIdP = condIdP symChars (not . isSmall . head) lowerIdP :: Parser Symbol -lowerIdP = condIdP symChars (isLower . head) +lowerIdP = condIdP symChars (isSmall . head) +isSmall :: Char -> Bool +isSmall c = isLower c || c == '_' + symCharsP :: Parser Symbol symCharsP = condIdP symChars (`notElem` keyWordSyms) @@ -209,15 +216,14 @@ <|> (ESym <$> symconstP) <|> (ECon <$> constantP) <|> (reserved "_|_" >> return EBot) + <|> lamP <|> try (parens exprP) <|> try (parens exprCastP) <|> (charsExpr <$> symCharsP) charsExpr cs - | isLower (T.head t) = expr cs - | otherwise = EVar cs - where t = symbolText cs --- <|> try (parens $ condP EIte exprP) + | isSmall (headSym cs) = expr cs + | otherwise = EVar cs fastIfP f bodyP = do reserved "if" @@ -228,6 +234,7 @@ b2 <- bodyP return $ f p b1 b2 +{- qmIfP f bodyP = parens $ do p <- predP @@ -236,7 +243,7 @@ colon b2 <- bodyP return $ f p b1 b2 - +-} expr1P :: Parser Expr expr1P @@ -246,11 +253,12 @@ exprP :: Parser Expr exprP = buildExpressionParser bops expr1P -funAppP = (try litP) <|> (try exprFunSpacesP) <|> (try exprFunSemisP) <|> exprFunCommasP +funAppP = (try litP) <|> (try exprFunSpacesP) <|> (try exprFunSemisP) <|> exprFunCommasP <|> simpleAppP where - exprFunSpacesP = EApp <$> funSymbolP <*> sepBy1 expr0P blanks - exprFunCommasP = EApp <$> funSymbolP <*> parens (sepBy exprP comma) - exprFunSemisP = EApp <$> funSymbolP <*> parenBrackets (sepBy exprP semi) + exprFunSpacesP = mkEApp <$> funSymbolP <*> sepBy1 expr0P blanks + exprFunCommasP = mkEApp <$> funSymbolP <*> parens (sepBy exprP comma) + exprFunSemisP = mkEApp <$> funSymbolP <*> parenBrackets (sepBy exprP semi) + simpleAppP = EApp <$> (parens exprP) <*> (parens exprP) funSymbolP = locParserP symbolP @@ -272,32 +280,64 @@ , [ Infix (reservedOp "mod" >> return (EBin Mod )) AssocLeft] ] -eMinus = EBin Minus (expr (0 :: Integer)) +-- eMinus = EBin Minus (expr (0 :: Integer)) -- eCons x xs = EApp (dummyLoc consName) [x, xs] -- eNil = EVar nilName exprCastP = do e <- exprP - ((try dcolon) <|> colon) + (try dcolon) <|> colon so <- sortP return $ ECst e so + +lamP + = do reserved "\\" + x <- symbolP + colon + t <- sortP + reserved "->" + e <- exprP + return $ ELam (x, t) e + + dcolon = string "::" <* spaces varSortP = FVar <$> parens intP -funcSortP = parens $ FFunc <$> intP <* comma <*> sortsP +funcSortP = parens $ mkFFunc <$> intP <* comma <*> sortsP sortsP = brackets $ sepBy sortP semi -sortP - = try (parens $ sortP) - <|> try (string "@" >> varSortP) +sortP :: Parser Sort +sortP = sortP' (sepBy sortArgP blanks) + +sortArgP :: Parser Sort +sortArgP = sortP' (return []) + +{- +sortFunP :: Parser Sort +sortFunP + = try (string "@" >> varSortP) + <|> (fTyconSort <$> fTyConP) +-} + +sortP' :: Parser [Sort] -> Parser Sort +sortP' appArgsP + = try (parens sortP) <|> try (string "func" >> funcSortP) - <|> try (fApp (Left listFTyCon) . single <$> brackets sortP) + <|> try (fAppTC listFTyCon . single <$> brackets sortP) <|> try bvSortP - <|> try (fApp <$> (Left <$> fTyConP) <*> sepBy sortP blanks) + <|> try (fAppTC <$> fTyConP <*> appArgsP) + <|> try (fApp <$> tvarP <*> appArgsP) + +single x = [x] + +tvarP :: Parser Sort +tvarP + = try (string "@" >> varSortP) <|> (FObj . symbol <$> lowerIdP) + fTyConP :: Parser FTycon fTyConP = (reserved "int" >> return intFTyCon) @@ -306,41 +346,42 @@ <|> (reserved "int" >> return intFTyCon) <|> (reserved "real" >> return realFTyCon) <|> (reserved "bool" >> return boolFTyCon) + <|> (reserved "num" >> return numFTyCon) <|> (symbolFTycon <$> locUpperIdP) bvSortP = mkSort <$> (bvSizeP "Size32" S32 <|> bvSizeP "Size64" S64) bvSizeP ss s = do - parens (reserved "BitVec" >> parens (reserved ss >> reserved "obj")) + parens (reserved "BitVec" >> reserved ss) return s keyWordSyms = ["if", "then", "else", "mod"] ---------------------------------------------------------------------- --------------------------- Predicates ------------------------------- ---------------------------------------------------------------------- - +-------------------------------------------------------------------------------- +-- | Predicates ---------------------------------------------------------------- +-------------------------------------------------------------------------------- -pred0P :: Parser Pred +pred0P :: Parser Expr pred0P = trueP <|> falseP + <|> try (reserved "??" >> return PGrad) <|> try kvarPredP <|> try (fastIfP pIte predP) <|> try predrP <|> try (parens predP) - <|> try (PBexp <$> (reserved "?" *> exprP)) - <|> try (PBexp <$> funAppP) + <|> try (reserved "?" *> exprP) + <|> try funAppP <|> try (reservedOp "&&" >> PAnd <$> predsP) <|> try (reservedOp "||" >> POr <$> predsP) -- qmP = reserved "?" <|> reserved "Bexp" -trueP, falseP :: Parser Pred +trueP, falseP :: Parser Expr trueP = reserved "true" >> return PTrue falseP = reserved "false" >> return PFalse -kvarPredP :: Parser Pred +kvarPredP :: Parser Expr kvarPredP = PKVar <$> kvarP <*> substP kvarP :: Parser KVar @@ -351,7 +392,7 @@ where aP = reserved ":=" -predP :: Parser Pred +predP :: Parser Expr predP = buildExpressionParser lops pred0P @@ -371,7 +412,7 @@ e2 <- exprP return $ r e1 e2 -brelP :: Parser (Expr -> Expr -> Pred) +brelP :: Parser (Expr -> Expr -> Expr) brelP = (reservedOp "==" >> return (PAtom Eq)) <|> (reservedOp "=" >> return (PAtom Eq)) <|> (reservedOp "~~" >> return (PAtom Ueq)) @@ -387,13 +428,13 @@ ------------------------------------ BareTypes ----------------------------------- ---------------------------------------------------------------------------------- -refaP :: Parser Refa -refaP = try (refa <$> brackets (sepBy predP semi)) - <|> (Refa <$> predP) +refaP :: Parser Expr +refaP = try (pAnd <$> brackets (sepBy predP semi)) + <|> predP -refBindP :: Parser Symbol -> Parser Refa -> Parser (Reft -> a) -> Parser a +refBindP :: Parser Symbol -> Parser Expr -> Parser (Reft -> a) -> Parser a refBindP bp rp kindP = braces $ do x <- bp @@ -421,22 +462,28 @@ body <- predP return $ mkQual n params body pos -sortBindP tP = (,) <$> symbolP <* colon <*> tP +sortBindP = pairP symbolP colon pairP :: Parser a -> Parser z -> Parser b -> Parser (a, b) pairP xP sepP yP = (,) <$> xP <* sepP <*> yP - -mkQual n xts p = Q n ((vv, t) : yts) (subst su p) +mkQual :: Symbol -> [(Symbol, Sort)] -> Expr -> SourcePos -> Qualifier +mkQual n xts p = Q n ((v, t) : yts) (subst su p) where - (vv,t):zts = gSorts xts - yts = mapFst mkParam <$> zts + (v, t):zts = gSorts xts + -- yts = first mkParam <$> zts + yts = zts su = mkSubst $ zipWith (\(z,_) (y,_) -> (z, eVar y)) zts yts +-- mkParam :: Symbol -> Symbol +-- mkParam s = unsafeTextSymbol ('~' `T.cons` toUpper c `T.cons` cs) +-- where +-- Just (c,cs) = T.uncons $ symbolSafeText s + gSorts :: [(a, Sort)] -> [(a, Sort)] gSorts xts = [(x, substVars su t) | (x, t) <- xts] where - su = (`zip` [0..]) . sortNub . concatMap sortVars . map snd $ xts + su = (`zip` [0..]) . sortNub . concatMap (sortVars . snd) $ xts substVars :: [(Symbol, Int)] -> Sort -> Sort substVars su = mapSort tx @@ -452,10 +499,6 @@ go b _ = b -mkParam s = symbol ('~' `T.cons` toUpper c `T.cons` cs) - where - Just (c,cs)= T.uncons $ symbolText s - --------------------------------------------------------------------- -- | Parsing Constraints (.fq files) -------------------------------- --------------------------------------------------------------------- @@ -463,7 +506,7 @@ -- Entities in Query File data Def a = Srt Sort - | Axm Pred + | Axm Expr | Cst (SubC a) | Wfc (WfC a) | Con Symbol Sort @@ -475,17 +518,17 @@ -- Dep of FixConstraint.dep fInfoP :: Parser (FInfo ()) -fInfoP = defsFInfo <$> many defP +fInfoP = defsFInfo <$> {-# SCC "many-defP" #-} many defP defP :: Parser (Def ()) defP = Srt <$> (reserved "sort" >> colon >> sortP) <|> Axm <$> (reserved "axiom" >> colon >> predP) - <|> Cst <$> (reserved "constraint" >> colon >> subCP) - <|> Wfc <$> (reserved "wf" >> colon >> wfCP) + <|> Cst <$> (reserved "constraint" >> colon >> {-# SCC "subCP" #-} subCP) + <|> Wfc <$> (reserved "wf" >> colon >> {-# SCC "wfCP" #-} wfCP) <|> Con <$> (reserved "constant" >> symbolP) <*> (colon >> sortP) <|> Qul <$> (reserved "qualif" >> qualifierP sortP) <|> Kut <$> (reserved "cut" >> kvarP) - <|> IBind <$> (reserved "bind" >> intP) <*> symbolP <*> (colon >> sortedReftP) + <|> IBind <$> (reserved "bind" >> intP) <*> symbolP <*> (colon >> {-# SCC "sortedReftP" #-} sortedReftP) sortedReftP :: Parser SortedReft sortedReftP = refP (RR <$> (sortP <* spaces)) @@ -495,13 +538,13 @@ env <- envP reserved "reft" r <- sortedReftP - return $ wfC env r Nothing () + let [w] = wfC env r () + return w subCP :: Parser (SubC ()) -subCP = do reserved "env" +subCP = do pos <- getPosition + reserved "env" env <- envP - reserved "grd" - grd <- predP reserved "lhs" lhs <- sortedReftP reserved "rhs" @@ -509,19 +552,20 @@ reserved "id" i <- integer <* spaces tag <- tagP - return $ safeHead "subCP" $ subC env grd lhs rhs (Just i) tag () + pos' <- getPosition + return $ subC' env lhs rhs i tag pos pos' --- idVV :: Integer -> SortedReft -> SortedReft --- idVV i sr = sr {sr_reft = ri } --- where --- ri = shiftVV r vvi --- r = sr_reft sr --- vvi = vv $ Just i +subC' env lhs rhs i tag l l' + = case cs of + [c] -> c + _ -> die $ err sp $ "RHS without single conjunct at" <+> pprint l' + where + cs = subC env lhs rhs (Just i) tag () + sp = SS l l' tagP :: Parser [Int] -tagP = try (reserved "tag" >> spaces >> (brackets $ sepBy intP semi)) - <|> (return []) +tagP = reserved "tag" >> spaces >> brackets (sepBy intP semi) envP :: Parser IBindEnv envP = do binds <- brackets $ sepBy (intP <* spaces) semi @@ -531,17 +575,17 @@ intP = fromInteger <$> integer defsFInfo :: [Def a] -> FInfo a -defsFInfo defs = FI cm ws bs gs lts kts qs mempty +defsFInfo defs = {-# SCC "defsFI" #-} FI cm ws bs lts kts qs mempty mempty False where cm = M.fromList [(cid c, c) | Cst c <- defs] - ws = [w | Wfc w <- defs] + ws = M.fromList [(thd3 $ wrft w, w) | Wfc w <- defs] bs = bindEnvFromList [(n, x, r) | IBind n x r <- defs] - gs = fromListSEnv [(x, RR t mempty) | Con x t <- defs] - lts = [(x, t) | Con x t <- defs, notFun t] + lts = fromListSEnv [(x, t) | Con x t <- defs] kts = KS $ S.fromList [k | Kut k <- defs] qs = [q | Qul q <- defs] cid = fromJust . sid - notFun = not . isFunctionSortedReft . (`RR` trueReft) + -- msg = show $ "#Lits = " ++ (show $ length consts) + --------------------------------------------------------------------- -- | Interacting with Fixpoint -------------------------------------- --------------------------------------------------------------------- @@ -549,7 +593,7 @@ fixResultP :: Parser a -> Parser (FixResult a) fixResultP pp = (reserved "SAT" >> return Safe) - <|> (reserved "UNSAT" >> Unsafe <$> (brackets $ sepBy pp comma)) + <|> (reserved "UNSAT" >> Unsafe <$> brackets (sepBy pp comma)) <|> (reserved "CRASH" >> crashP pp) crashP pp @@ -558,11 +602,11 @@ return $ Crash [i] msg predSolP - = parens $ (predP <* (comma >> iQualP)) + = parens (predP <* (comma >> iQualP)) iQualP - = upperIdP >> (parens $ sepBy symbolP comma) + = upperIdP >> parens (sepBy symbolP comma) solution1P = do reserved "solution:" @@ -573,7 +617,7 @@ where kvP = try kvarP <|> (KV <$> symbolP) -solutionP :: Parser (M.HashMap KVar Pred) +solutionP :: Parser (M.HashMap KVar Expr) solutionP = M.fromList <$> sepBy solution1P whiteSpace @@ -590,10 +634,15 @@ doParse' parser f s = case runParser (remainderP (whiteSpace >> parser)) 0 f s of - Left e -> die $ err (errorSpan e) $ printf "parseError %s\n when parsing from %s\n" (show e) f + Left e -> die $ err (errorSpan e) (dErr e) Right (r, "", _) -> r - Right (_, rem, l) -> die $ err (SS l l) - $ printf "doParse has leftover when parsing: %s\nfrom file %s\n" rem f + Right (_, r, l) -> die $ err (SS l l) (dRem r) + where + dErr e = vcat [ "parseError" <+> tshow e + , "when parsing from" <+> text f ] + dRem r = vcat [ "doParse has leftover" + , nest 4 (text r) + , "when parsing from" <+> text f ] errorSpan e = SS l l where l = errorPos e @@ -617,7 +666,7 @@ <|> (reserved "pop" >> return Pop) <|> (reserved "check" >> return CheckSat) <|> (reserved "assert" >> (Assert Nothing <$> predP)) - <|> (reserved "distinct" >> (Distinct <$> (brackets $ sepBy exprP comma))) + <|> (reserved "distinct" >> (Distinct <$> brackets (sepBy exprP comma))) cmdVarP = do x <- bindP @@ -641,15 +690,9 @@ instance Inputable Constant where rr' = doParse' constantP -instance Inputable Pred where - rr' = doParse' predP - instance Inputable Expr where rr' = doParse' exprP -instance Inputable Refa where - rr' = doParse' refaP - instance Inputable (FixResult Integer) where rr' = doParse' $ fixResultP integer @@ -657,7 +700,7 @@ rr' = doParse' solutionFileP instance Inputable (FInfo ()) where - rr' = doParse' fInfoP + rr' = {-# SCC "fInfoP" #-} doParse' fInfoP instance Inputable Command where rr' = doParse' commandP diff --git a/src/Language/Fixpoint/Partition.hs b/src/Language/Fixpoint/Partition.hs --- a/src/Language/Fixpoint/Partition.hs +++ b/src/Language/Fixpoint/Partition.hs @@ -1,89 +1,202 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} --- | This module implements functions that print out --- statistics about the constraints. +-- | This module implements functions to build constraint / kvar +-- dependency graphs, partition them and print statistics about +-- their structure. -module Language.Fixpoint.Partition (partition, partition') where +module Language.Fixpoint.Partition ( -import Control.Monad (forM_) -import GHC.Generics (Generic) -import Language.Fixpoint.Misc hiding (group)-- (fst3, safeLookup, mlookup, groupList) -import Language.Fixpoint.Solver.Deps -import Language.Fixpoint.Files -import Language.Fixpoint.Config -import Language.Fixpoint.PrettyPrint -import qualified Language.Fixpoint.Visitor as V -import qualified Language.Fixpoint.Types as F -import qualified Data.HashMap.Strict as M -import qualified Data.Graph as G -import qualified Data.Tree as T + -- * Split constraints + CPart (..) + , partition, partition', partitionN + + -- * Information about cores + , MCInfo (..) + , mcInfo + + -- * Queries over dependencies + , graphStatistics + , GDeps (..) + , deps + -- , isReducible + + -- * Debug + , elimSolGraph + ) where + +import GHC.Conc (getNumProcessors) +import Control.Monad (when, forM_) +-- import GHC.Generics (Generic) +import Language.Fixpoint.Misc -- hiding (group) +import Language.Fixpoint.Utils.Files +import Language.Fixpoint.Types.Config +import Language.Fixpoint.Types.PrettyPrint +import qualified Language.Fixpoint.Types.Visitor as V +import qualified Language.Fixpoint.Solver.Solution as So +import qualified Language.Fixpoint.Types as F +import Language.Fixpoint.Types.Graphs +import qualified Data.HashMap.Strict as M +import qualified Data.Graph as G +import qualified Data.Tree as T +import Data.Function (on) +import Data.Maybe (mapMaybe, fromMaybe) import Data.Hashable import Text.PrettyPrint.HughesPJ -import Debug.Trace +import Data.List (sortBy) +import qualified Data.HashSet as S -#if __GLASGOW_HASKELL__ < 710 -import Data.Monoid (mempty) -import System.Console.CmdArgs.Verbosity (whenLoud) -import Control.Applicative ((<$>)) -import Control.Arrow ((&&&)) -import Data.List (sort,group) -import Data.Maybe (mapMaybe) -import System.FilePath -- (dropExtension) -#endif +import Data.Graph.Inductive -partition :: (F.Fixpoint a) => Config -> F.FInfo a -> IO (F.Result a) + + +-------------------------------------------------------------------------------- +-- | Constraint Partition Container -------------------------------------------- +-------------------------------------------------------------------------------- + +data CPart a = CPart { pws :: M.HashMap F.KVar (F.WfC a) + , pcm :: M.HashMap Integer (F.SubC a) + , cFileName :: FilePath + } + +instance Monoid (CPart a) where + mempty = CPart mempty mempty mempty + mappend l r = CPart { pws = pws l `mappend` pws r + , pcm = pcm l `mappend` pcm r + , cFileName = cFileName l + } + +-------------------------------------------------------------------------------- +-- | Multicore info ------------------------------------------------------------ +-------------------------------------------------------------------------------- + +data MCInfo = MCInfo { mcCores :: Int + , mcMinPartSize :: Int + , mcMaxPartSize :: Int + } deriving (Show) + +mcInfo :: Config -> IO MCInfo +mcInfo c = do + np <- getNumProcessors + let nc = fromMaybe np (cores c) + return MCInfo { mcCores = nc + , mcMinPartSize = minPartSize c + , mcMaxPartSize = maxPartSize c + } + +partition :: (F.Fixpoint a) => Config -> F.FInfo a -> IO (F.Result (Integer, a)) partition cfg fi = do dumpPartitions cfg fis - dumpEdges cfg es - -- whenLoud $ putStrLn $ render $ ppGraph es + writeGraph f g return mempty where - (es, fis) = partition' fi + f = queryFile Dot cfg + (g, fis) = partition' Nothing fi -partition' :: F.FInfo a -> (KVGraph, [F.FInfo a]) -partition' fi = (g, partitionByConstraints fi css) +------------------------------------------------------------------------------ +-- | Partition an FInfo into multiple disjoint FInfos +------------------------------------------------------------------------------ +partition' :: Maybe MCInfo -- ^ Nothing to produce the maximum possible + -- number of partitions. Or a MultiCore Info + -- to control the partitioning + -> F.FInfo a -> (KVGraph, [F.FInfo a]) +------------------------------------------------------------------------------ +partition' mn fi = case mn of + Nothing -> (g, fis mkPartition id) + Just mi -> (g, partitionN mi fi $ fis mkPartition' finfoToCpart) where - es = kvEdges fi - g = kvGraph es - css = decompose g + g = kvGraph fi + css = decompose g + fis partF ctor = applyNonNull [ctor fi] (pbc partF) css + pbc partF = partitionByConstraints partF fi -------------------------------------------------------------------------------------- -dumpPartitions :: (F.Fixpoint a) => Config -> [F.FInfo a ] -> IO () -------------------------------------------------------------------------------------- -dumpPartitions cfg fis = - forM_ (zip [1..] fis) $ \(j, fi) -> - writeFile (partFile cfg j) (render $ F.toFixpoint cfg fi) -partFile :: Config -> Int -> FilePath -partFile cfg j = {- trace ("partFile: " ++ fjq) -} fjq - where - fjq = extFileName (Part j) (inFile cfg) +-- | Partition an FInfo into a specific number of partitions of roughly equal +-- amounts of work +partitionN :: MCInfo -- ^ describes thresholds and partiton amounts + -> F.FInfo a -- ^ The originial FInfo + -> [CPart a] -- ^ A list of the smallest possible CParts + -> [F.FInfo a] -- ^ At most N partitions of at least thresh work +partitionN mi fi cp + | cpartSize (finfoToCpart fi) <= minThresh = [fi] + | otherwise = map (cpartToFinfo fi) $ toNParts sortedParts + where + toNParts p + | isDone p = p + | otherwise = toNParts $ insertSorted firstTwo rest + where (firstTwo, rest) = unionFirstTwo p + isDone [] = True + isDone [_] = True + isDone fi'@(a:b:_) = length fi' <= prts + && (cpartSize a >= minThresh + || cpartSize a + cpartSize b >= maxThresh) + sortedParts = sortBy sortPredicate cp + unionFirstTwo (a:b:xs) = (a `mappend` b, xs) + unionFirstTwo _ = errorstar "Partition.partitionN.unionFirstTwo called on bad arguments" + sortPredicate lhs rhs + | cpartSize lhs < cpartSize rhs = GT + | cpartSize lhs > cpartSize rhs = LT + | otherwise = EQ + insertSorted a [] = [a] + insertSorted a (x:xs) = if sortPredicate a x == LT + then x : insertSorted a xs + else a : x : xs + prts = mcCores mi + minThresh = mcMinPartSize mi + maxThresh = mcMaxPartSize mi -------------------------------------------------------------------------------------- -dumpEdges :: Config -> KVGraph -> IO () -------------------------------------------------------------------------------------- -dumpEdges cfg = writeFile f . render . ppGraph - where - f = extFileName Dot (inFile cfg) -ppGraph :: KVGraph -> Doc -ppGraph g = ppEdges [ (v, v') | (v,_,vs) <- g, v' <- vs] +-- | Return the "size" of a CPart. Used to determine if it's +-- substantial enough to be worth parallelizing. +cpartSize :: CPart a -> Int +cpartSize c = (M.size . pcm) c + (length . pws) c -ppEdges :: [CEdge] -> Doc -ppEdges es = vcat [pprint v <+> text "-->" <+> pprint v' | (v, v') <- es] +-- | Convert a CPart to an FInfo +cpartToFinfo :: F.FInfo a -> CPart a -> F.FInfo a +cpartToFinfo fi p = fi { F.cm = pcm p + , F.ws = pws p + , F.fileName = cFileName p + } +-- | Convert an FInfo to a CPart +finfoToCpart :: F.FInfo a -> CPart a +finfoToCpart fi = CPart { pcm = F.cm fi + , pws = F.ws fi + , cFileName = F.fileName fi + } + ------------------------------------------------------------------------------------- -partitionByConstraints :: F.FInfo a -> KVComps -> [F.FInfo a] +dumpPartitions :: (F.Fixpoint a) => Config -> [F.FInfo a] -> IO () ------------------------------------------------------------------------------------- -partitionByConstraints fi kvss = mkPartition fi icM iwM <$> js +dumpPartitions cfg fis = + forM_ (zip [0..] fis) $ \(i, fi) -> + writeFile (partFile fi i) (render $ F.toFixpoint cfg fi) + +partFile :: F.FInfo a -> Int -> FilePath +partFile fi j = extFileName (Part j) (F.fileName fi) + + +-- | Type alias for a function to construct a partition. mkPartition and +-- mkPartition' are the two primary functions that conform to this interface +type PartitionCtor a b = F.FInfo a + -> M.HashMap Int [(Integer, F.SubC a)] + -> M.HashMap Int [(F.KVar, F.WfC a)] + -> Int + -> b -- ^ typically a F.FInfo a or F.CPart a + +partitionByConstraints :: PartitionCtor a b -- ^ mkPartition or mkPartition' + -> F.FInfo a + -> KVComps + -> ListNE b -- ^ [F.FInfo a] or [F.CPart a] +partitionByConstraints f fi kvss = f fi icM iwM <$> js where js = fst <$> jkvs -- groups gc = groupFun cM -- (i, ci) |-> j gk = groupFun kM -- k |-> j - iwM = groupMap (wfGroup gk) (F.ws fi) -- j |-> [w] - icM = groupMap (gc . fst) (M.toList (F.cm fi)) -- j |-> [(i, ci)] + iwM = groupMap (gk . fst) (M.toList (F.ws fi)) -- j |-> [w] + icM = groupMap (gc . fst) (M.toList (F.cm fi)) -- j |-> [(i, ci)] jkvs = zip [1..] kvss kvI = [ (x, j) | (j, kvs) <- jkvs, x <- kvs ] @@ -91,57 +204,260 @@ cM = M.fromList [ (c, i) | (Cstr c, i) <- kvI ] mkPartition fi icM iwM j - = fi { F.cm = M.fromList $ M.lookupDefault [] j icM - , F.ws = M.lookupDefault [] j iwM } + = fi { F.cm = M.fromList $ M.lookupDefault [] j icM + , F.ws = M.fromList $ M.lookupDefault [] j iwM + , F.fileName = partFile fi j + } -wfGroup gk w = case sortNub [gk k | k <- wfKvars w ] of - [i] -> i - _ -> errorstar $ "PARTITION: wfGroup" ++ show (F.wid w) +mkPartition' fi icM iwM j + = CPart { pcm = M.fromList $ M.lookupDefault [] j icM + , pws = M.fromList $ M.lookupDefault [] j iwM + , cFileName = partFile fi j + } -wfKvars :: F.WfC a -> [F.KVar] -wfKvars = V.kvars . F.sr_reft . F.wrft +groupFun :: (Show k, Eq k, Hashable k) => M.HashMap k Int -> k -> Int +groupFun m k = safeLookup ("groupFun: " ++ show k) k m -------------------------------------------------------------------------------------- -------------------------------------------------------------------------------------- -------------------------------------------------------------------------------------- -data CVertex = KVar F.KVar - | Cstr Integer - deriving (Eq, Ord, Show, Generic) - -instance PPrint CVertex where - pprint (KVar k) = pprint k - pprint (Cstr i) = text "id:" <+> pprint i - -instance Hashable CVertex - -type CEdge = (CVertex, CVertex) -type KVGraph = [(CVertex, CVertex, [CVertex])] - -type Comps a = [[a]] -type KVComps = Comps CVertex - -------------------------------------------------------------------------------------- -------------------------------------------------------------------------------------- +------------------------------------------------------------------------------- decompose :: KVGraph -> KVComps -------------------------------------------------------------------------------------- -decompose kg = {- tracepp "flattened" $ -} map (fst3 . f) <$> vss +------------------------------------------------------------------------------- +decompose kg = map (fst3 . f) <$> vss where (g,f,_) = G.graphFromEdges kg vss = T.flatten <$> G.components g -kvGraph :: [CEdge] -> KVGraph -kvGraph es = [(v,v,vs) | (v, vs) <- groupList es ] +------------------------------------------------------------------------------- +kvGraph :: (F.TaggedC c a) => F.GInfo c a -> KVGraph +------------------------------------------------------------------------------- +kvGraph = edgeGraph . kvEdges -kvEdges :: F.FInfo a -> [CEdge] +edgeGraph :: [CEdge] -> KVGraph +edgeGraph es = [(v,v,vs) | (v, vs) <- groupList es ] + +kvEdges :: (F.TaggedC c a) => F.GInfo c a -> [CEdge] kvEdges fi = selfes ++ concatMap (subcEdges bs) cs where bs = F.bs fi cs = M.elems (F.cm fi) - selfes = [(Cstr i, Cstr i) | c <- cs, let i = F.subcId c] + ks = fiKVars fi + selfes = [(Cstr i, Cstr i) | c <- cs, let i = F.subcId c] + ++ [(KVar k, DKVar k) | k <- ks] + ++ [(DKVar k, DKVar k) | k <- ks] -subcEdges :: F.BindEnv -> F.SubC a -> [CEdge] -subcEdges bs c = [(KVar k, Cstr i ) | k <- lhsKVars bs c] - ++ [(Cstr i, KVar k') | k' <- rhsKVars c ] + +fiKVars :: F.GInfo c a -> [F.KVar] +fiKVars = M.keys . F.ws + +subcEdges :: (F.TaggedC c a) => F.BindEnv -> c a -> [CEdge] +subcEdges bs c = [(KVar k, Cstr i ) | k <- V.envKVars bs c] + ++ [(Cstr i, KVar k') | k' <- V.rhsKVars c ] where i = F.subcId c + +-------------------------------------------------------------------------------- +-- | Generic Dependencies ------------------------------------------------------ +-------------------------------------------------------------------------------- +data GDeps a + = Deps { depCuts :: !(S.HashSet a) + , depNonCuts :: !(S.HashSet a) + } + deriving (Show) + +instance (Eq a, Hashable a) => Monoid (GDeps a) where + mempty = Deps S.empty S.empty + mappend (Deps d1 n1) (Deps d2 n2) = Deps (S.union d1 d2) (S.union n1 n2) + +dCut, dNonCut :: (Hashable a) => a -> GDeps a +dNonCut v = Deps S.empty (S.singleton v) +dCut v = Deps (S.singleton v) S.empty + +-------------------------------------------------------------------------------- +-- | Compute Dependencies and Cuts --------------------------------------------- +-------------------------------------------------------------------------------- +deps :: (F.TaggedC c a) => F.GInfo c a -> GDeps F.KVar +-------------------------------------------------------------------------------- +deps si = Deps (takeK cs) (takeK ns) + where + Deps cs ns = gDeps cutF (edgeGraph es) + es = kvEdges si + -- ORIG cutF = chooseCut isK (cuts si) + cutF = edgeRankCut (edgeRank es) + takeK = sMapMaybe tx + tx (KVar z) = Just z + tx _ = Nothing + +-- crash _ = undefined +-- cutter :: F.TaggedC c a => F.GInfo c a -> Cutter CVertex +-- cutter si = chooseCut isK (cuts si) + +-- ORIG isK :: CVertex -> Bool +-- ORIG isK (KVar _) = True +-- ORIG isK _ = False +-- ORIG cuts :: (F.TaggedC c a) => F.GInfo c a -> S.HashSet CVertex +-- ORIG cuts = S.map KVar . F.ksVars . F.kuts + + +sMapMaybe :: (Hashable b, Eq b) => (a -> Maybe b) -> S.HashSet a -> S.HashSet b +sMapMaybe f = S.fromList . mapMaybe f . S.toList + +-------------------------------------------------------------------------------- +type EdgeRank = M.HashMap F.KVar Integer +-------------------------------------------------------------------------------- +edgeRank :: [CEdge] -> EdgeRank +edgeRank es = minimum . (n :) <$> kiM + where + n = 1 + maximum [ i | (Cstr i, _) <- es ] + kiM = group [ (k, i) | (KVar k, Cstr i) <- es ] + +edgeRankCut :: EdgeRank -> Cutter CVertex +edgeRankCut km vs = case ks of + [] -> Nothing + k:_ -> Just (KVar k, [x | x@(u,_,_) <- vs, u /= KVar k]) + where + ks = orderBy [k | (KVar k, _ ,_) <- vs] + rank = (km M.!) + orderBy = sortBy (compare `on` rank) + +-------------------------------------------------------------------------------- +type Cutter a = [(a, a, [a])] -> Maybe (a, [(a, a, [a])]) +-------------------------------------------------------------------------------- +-- ORIG chooseCut :: (Cutable a) => (a -> Bool) -> S.HashSet a -> Cutter a +-- ORIG -------------------------------------------------------------------------------- +-- ORIG chooseCut f ks vs = case vs'' of + -- ORIG [] -> Nothing + -- ORIG v:_ -> Just (v, [x | x@(u,_,_) <- vs, u /= v]) + -- ORIG where + -- ORIG vs' = [x | (x,_,_) <- vs, f x] + -- ORIG is = S.intersection (S.fromList vs') ks + -- ORIG vs'' = if S.null is then vs' else S.toList is + -- ORIG -- ^ -- we select a RANDOM element, + -- ORIG ------- instead pick the "first" element. + + + +-------------------------------------------------------------------------------- +type Cutable a = (Eq a, Ord a, Hashable a, Show a) +-------------------------------------------------------------------------------- +gDeps :: (Cutable a) => Cutter a -> [(a, a, [a])] -> GDeps a +-------------------------------------------------------------------------------- +gDeps f g = sccsToDeps f (G.stronglyConnCompR g) + + +sccsToDeps :: (Cutable a) => Cutter a -> [G.SCC (a, a, [a])] -> GDeps a +sccsToDeps f xs = mconcat $ sccDep f <$> xs + +sccDep :: (Cutable a) => Cutter a -> G.SCC (a, a, [a]) -> GDeps a +sccDep _ (G.AcyclicSCC (v,_,_)) = dNonCut v +sccDep f (G.CyclicSCC vs) = cycleDep f vs + + +cycleDep :: (Cutable a) => Cutter a -> [(a,a,[a])] -> GDeps a +cycleDep _ [] = mempty +cycleDep f vs = addCut f (f vs) + +addCut _ Nothing = mempty +addCut f (Just (v, vs')) = mconcat $ dCut v : (sccDep f <$> sccs) + where + sccs = G.stronglyConnCompR vs' + +-------------------------------------------------------------------------------- +isReducible :: F.SInfo a -> Bool +-------------------------------------------------------------------------------- +isReducible fi = all (isReducibleWithStart g) vs + where + g = convertToGraph fi + vs = {- trace (showDot $ fglToDotGeneric g show (const "") id) -} nodes g + +isReducibleWithStart :: Gr a b -> Node -> Bool +isReducibleWithStart g x = all (isBackEdge domList) rEdges + where + dfsTree = head $ dff [x] g --head because only care about nodes reachable from 'start node'? + rEdges = [e | e@(a,b) <- edges g, isDescendant a b dfsTree] + domList = dom g x + +convertToGraph :: F.SInfo a -> Gr Int () +convertToGraph fi = mkGraph vs es + where + subCs = M.elems (F.cm fi) + es = lUEdge <$> concatMap (subcEdges' kvI $ F.bs fi) subCs + ks = M.keys (F.ws fi) + kiM = M.fromList $ zip ks [0..] + kvI k = safeLookup ("convertToGraph: " ++ show k) k kiM + vs = lNode . kvI <$> M.keys (F.ws fi) + lNode i = (i, i) + lUEdge (i,j) = (i, j, ()) + +isDescendant :: Node -> Node -> T.Tree Node -> Bool +isDescendant x y (T.Node z f) | z == y = f `contains` x + | z == x = False + | otherwise = any (isDescendant x y) f + +contains :: [T.Tree Node] -> Node -> Bool +contains t x = x `elem` concatMap T.flatten t + +isBackEdge :: [(Node, [Node])] -> Edge -> Bool +isBackEdge t (u,v) = v `elem` xs + where + (Just xs) = lookup u t + +subcEdges' :: (F.KVar -> Node) -> F.BindEnv -> F.SimpC a -> [(Node, Node)] +subcEdges' kvI be c = [(kvI k1, kvI k2) | k1 <- V.envKVars be c + , k2 <- V.kvars $ F.crhs c] + +-------------------------------------------------------------------------------- +graphStatistics :: Config -> F.SInfo a -> IO () +-------------------------------------------------------------------------------- +graphStatistics cfg si = when (elimStats cfg) $ do + writeGraph f (kvGraph si) + appendFile f . ppc . ptable $ graphStats si + where + f = queryFile Dot cfg + ppc d = showpp $ vcat [" ", " ", "/*", pprint d, "*/"] + +data Stats = Stats { + stNumKVCuts :: !Int -- ^ number of kvars whose removal makes deps acyclic + , stNumKVNonLin :: !Int -- ^ number of kvars that appear >= 2 in some LHS + , stNumKVTotal :: !Int -- ^ number of kvars + , stIsReducible :: !Bool -- ^ is dep-graph reducible + , stSetKVNonLin :: S.HashSet F.KVar -- ^ set of non-linear kvars + } + +instance PTable Stats where + ptable (Stats {..}) = DocTable [ + ("# KVars [Cut]" , pprint stNumKVCuts) + , ("# KVars [NonLin]" , pprint stNumKVNonLin) + , ("# KVars [All]" , pprint stNumKVTotal) + , ("# Reducible" , pprint stIsReducible) + , ("KVars NonLin" , pprint stSetKVNonLin) + ] + +graphStats :: F.SInfo a -> Stats +graphStats si = Stats { + stNumKVCuts = S.size (depCuts d) + , stNumKVNonLin = S.size nlks + , stNumKVTotal = S.size (depCuts d) + S.size (depNonCuts d) + , stIsReducible = isReducible si + , stSetKVNonLin = nlks + } + where + nlks = nlKVars si + d = deps si + +nlKVars :: (F.TaggedC c a) => F.GInfo c a -> S.HashSet F.KVar +nlKVars fi = S.unions $ nlKVarsC bs <$> cs + where + bs = F.bs fi + cs = M.elems (F.cm fi) + +nlKVarsC :: (F.TaggedC c a) => F.BindEnv -> c a -> S.HashSet F.KVar +nlKVarsC bs c = S.fromList [ k | (k, n) <- V.envKVarsN bs c, n >= 2] + +-------------------------------------------------------------------------------- +-- | Build and print the graph of post eliminate solution, which has an edge +-- from k -> k' if k' appears directly inside the "solution" for k +-------------------------------------------------------------------------------- +elimSolGraph :: Config -> F.Solution -> IO () +elimSolGraph cfg s = writeGraph f (So.solutionGraph s) + where + f = queryFile Dot cfg diff --git a/src/Language/Fixpoint/PrettyPrint.hs b/src/Language/Fixpoint/PrettyPrint.hs deleted file mode 100644 --- a/src/Language/Fixpoint/PrettyPrint.hs +++ /dev/null @@ -1,204 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} - - -module Language.Fixpoint.PrettyPrint where - -import Debug.Trace (trace) -import Control.Applicative ((<$>)) -import qualified Data.Text as T -import Language.Fixpoint.Misc -import Language.Fixpoint.Types -import Text.Parsec -import Text.PrettyPrint.HughesPJ -import qualified Data.HashMap.Strict as M - -class PPrint a where - pprint :: a -> Doc - pprint = pprintPrec 0 - - -- | Pretty-print something with a specific precedence. - pprintPrec :: Int -> a -> Doc - pprintPrec _ = pprint - -showpp :: (PPrint a) => a -> String -showpp = render . pprint - -tracepp :: (PPrint a) => String -> a -> a -tracepp s x = trace ("\nTrace: [" ++ s ++ "] : " ++ showpp x) x - -instance PPrint a => PPrint (Maybe a) where - pprint = maybe (text "Nothing") ((text "Just" <+>) . pprint) - -instance PPrint a => PPrint [a] where - pprint = brackets . intersperse comma . map pprint - -instance (PPrint a, PPrint b) => PPrint (M.HashMap a b) where - pprint = vcat . punctuate (text "\n") . map pp1 . M.toList - where - pp1 (x, y) = pprint x <+> text ":=" <+> pprint y - - -instance (PPrint a, PPrint b, PPrint c) => PPrint (a, b, c) where - pprint (x, y, z) = parens $ pprint x <> text "," <> pprint y <> text "," <> pprint z - - -instance (PPrint a, PPrint b) => PPrint (a,b) where - pprint (x, y) = pprint x <+> text ":" <+> pprint y - -instance PPrint SourcePos where - pprint = text . show - -instance PPrint Bool where - pprint = text . show - -instance PPrint Float where - pprint = text . show - -instance PPrint () where - pprint = text . show - -instance PPrint String where - pprint = text - -instance PPrint Int where - pprint = toFix - -instance PPrint Integer where - pprint = toFix - -instance PPrint Constant where - pprint = toFix - -instance PPrint Brel where - pprint Eq = text "==" - pprint Ne = text "/=" - pprint r = toFix r - -instance PPrint Bop where - pprint = toFix - -instance PPrint Sort where - pprint = toFix - -instance PPrint Symbol where - pprint = text . symbolString - -instance PPrint KVar where - pprint (KV x) = text "$" <> pprint x - -instance PPrint SymConst where - pprint (SL x) = doubleQuotes $ text $ T.unpack x - --- | Wrap the enclosed 'Doc' in parentheses only if the condition holds. -parensIf True = parens -parensIf False = id - --- NOTE: The following Expr and Pred printers use pprintPrec to print --- expressions with minimal parenthesization. The precedence rules are somewhat --- fragile, and it would be nice to have them directly tied to the parser, but --- the general idea is (from lowest to highest precedence): --- --- 1 - if-then-else --- 2 - => and <=> --- 3 - && and || --- 4 - ==, !=, <, <=, >, >= --- 5 - mod --- 6 - + and - --- 7 - * and / --- 8 - function application --- --- Each printer `p` checks whether the precedence of the context is greater than --- its own precedence. If so, the printer wraps itself in parentheses. Then it --- sets the contextual precedence for recursive printer invocations to --- (prec p + 1). - -opPrec Mod = 5 -opPrec Plus = 6 -opPrec Minus = 6 -opPrec Times = 7 -opPrec Div = 7 - -instance PPrint Expr where - pprintPrec _ (ESym c) = pprint c - pprintPrec _ (ECon c) = pprint c - pprintPrec _ (EVar s) = pprint s - pprintPrec _ (ELit s _) = pprint s - pprintPrec _ (EBot) = text "_|_" - pprintPrec z (ENeg e) = parensIf (z > zn) $ - text "-" <> pprintPrec (zn+1) e - where zn = 2 - pprintPrec z (EApp f es) = parensIf (z > za) $ - intersperse empty $ - pprint f : (pprintPrec (za+1) <$> es) - where za = 8 - pprintPrec z (EBin o e1 e2) = parensIf (z > zo) $ - pprintPrec (zo+1) e1 <+> - pprint o <+> - pprintPrec (zo+1) e2 - where zo = opPrec o - pprintPrec z (EIte p e1 e2) = parensIf (z > zi) $ - text "if" <+> pprintPrec (zi+1) p <+> - text "then" <+> pprintPrec (zi+1) e1 <+> - text "else" <+> pprintPrec (zi+1) e2 - where zi = 1 - pprintPrec _ (ECst e so) = parens $ pprint e <+> text ":" <+> pprint so - -instance PPrint Pred where - pprintPrec _ PTop = text "???" - pprintPrec _ PTrue = trueD - pprintPrec _ PFalse = falseD - pprintPrec z (PBexp e) = pprintPrec z e - pprintPrec z (PNot p) = parensIf (z > zn) $ - text "not" <+> pprintPrec (zn+1) p - where zn = 8 - pprintPrec z (PImp p1 p2) = parensIf (z > zi) $ - (pprintPrec (zi+1) p1) <+> - text "=>" <+> - (pprintPrec (zi+1) p2) - where zi = 2 - pprintPrec z (PIff p1 p2) = parensIf (z > zi) $ - (pprintPrec (zi+1) p1) <+> - text "<=>" <+> - (pprintPrec (zi+1) p2) - where zi = 2 - pprintPrec z (PAnd ps) = parensIf (z > za) $ - pprintBin (za+1) trueD andD ps - where za = 3 - pprintPrec z (POr ps) = parensIf (z > zo) $ - pprintBin (zo+1) falseD orD ps - where zo = 3 - pprintPrec z (PAtom r e1 e2) = parensIf (z > za) $ - pprintPrec (za+1) e1 <+> - pprint r <+> - pprintPrec (za+1) e2 - where za = 4 - pprintPrec _ (PAll xts p) = text "forall" <+> toFix xts <+> text "." <+> pprint p - pprintPrec _ p@(PKVar {}) = toFix p - -trueD = text "true" -falseD = text "false" -andD = text " &&" -orD = text " ||" - -pprintBin _ b _ [] = b -pprintBin z _ o xs = intersperse o $ pprintPrec z <$> xs - -instance PPrint Refa where - pprintPrec z (Refa p) = pprintPrec z p - -instance PPrint Reft where - pprint r@(Reft (_,ra)) - | isTauto r = text "true" - | otherwise = {- intersperse comma -} pprintBin z trueD andD flat - where - flat = flattenRefas [ra] - z = if length flat > 1 then 3 else 0 - -instance PPrint SortedReft where - pprint (RR so (Reft (v, ras))) - = braces - $ (pprint v) <+> (text ":") <+> (toFix so) <+> (text "|") <+> pprint ras - -instance PPrint a => PPrint (Located a) where - pprint (Loc _ _ x) = pprint x diff --git a/src/Language/Fixpoint/Smt/Bitvector.hs b/src/Language/Fixpoint/Smt/Bitvector.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fixpoint/Smt/Bitvector.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} + +module Language.Fixpoint.Smt.Bitvector + ( -- * Constructor + Bv (..) + + -- * Sizes + , BvSize (..) + + -- * Operators + , BvOp (..) + + -- * BitVector Sort Constructor + , mkSort + + -- * BitVector Expression Constructor + , eOp + + -- * BitVector Type Constructor + , bvTyCon + + ) where + +import Data.Generics (Data) +import qualified Data.Text as T +import Data.Typeable (Typeable) +import GHC.Generics (Generic) +import Language.Fixpoint.Types.Names +import Language.Fixpoint.Types + +data Bv = Bv BvSize String + +data BvSize = S32 | S64 + deriving (Eq, Ord, Show, Data, Typeable, Generic) + +data BvOp = BvAnd | BvOr + deriving (Eq, Ord, Show, Data, Typeable, Generic) + +-- | Construct the bitvector `Sort` from its `BvSize` +mkSort :: BvSize -> Sort +mkSort s = fApp (fTyconSort bvTyCon) [ fTyconSort (sizeTyCon s) ] + +bvTyCon :: FTycon +bvTyCon = symbolFTycon $ dummyLoc bitVecName + +sizeTyCon :: BvSize -> FTycon +sizeTyCon = symbolFTycon . dummyLoc . sizeName + +sizeName :: BvSize -> Symbol +sizeName S32 = size32Name +sizeName S64 = size64Name + +-- | Construct an `Expr` using a raw string, e.g. (Bv S32 "#x02000000") +instance Expression Bv where + expr (Bv sz v) = ECon $ L (T.pack v) (mkSort sz) + +-- | Apply some bitvector operator to a list of arguments +eOp :: BvOp -> [Expr] -> Expr +eOp b es = foldl EApp (EVar $ opName b) es + +opName :: BvOp -> Symbol +opName BvAnd = bvAndName +opName BvOr = bvOrName + + +-- sizeSort = (`FApp` [fObj $ dummyLoc $ symbol "obj"]) . sizeTC +-- s32TyCon = symbolFTycon $ dummyLoc size32Name +-- s64TyCon = symbolFTycon $ dummyLoc size64Name diff --git a/src/Language/Fixpoint/Smt/Interface.hs b/src/Language/Fixpoint/Smt/Interface.hs --- a/src/Language/Fixpoint/Smt/Interface.hs +++ b/src/Language/Fixpoint/Smt/Interface.hs @@ -2,7 +2,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternGuards #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE UndecidableInstances #-} @@ -29,6 +28,7 @@ , Context (..) , makeContext , makeContextNoLog + , makeContextWithSEnv , cleanupContext -- * Execute Queries @@ -39,45 +39,50 @@ , smtDecl , smtAssert , smtCheckUnsat + , smtCheckSat , smtBracket , smtDistinct -- * Theory Symbols - , theorySymbols + -- , theorySymbols -- smt_set_funs + -- * Check Validity + , checkValid, checkValidWithContext + , checkValids + , makeZ3Context + ) where -import Language.Fixpoint.Config (SMTSolver (..)) -import Language.Fixpoint.Errors -import Language.Fixpoint.Files +import Language.Fixpoint.Types.Config (SMTSolver (..)) +import Language.Fixpoint.Misc (errorstar) +import Language.Fixpoint.Types.Errors +import Language.Fixpoint.Utils.Files import Language.Fixpoint.Types import Language.Fixpoint.Smt.Types -import Language.Fixpoint.Smt.Theories -import Language.Fixpoint.Smt.Serialize +import Language.Fixpoint.Smt.Theories (preamble) +import Language.Fixpoint.Smt.Serialize (initSMTEnv) -import Control.Applicative ((*>), (<$>), (<*), (<|>)) +import Control.Applicative ((<|>)) import Control.Monad import Data.Char -import qualified Data.HashMap.Strict as M -import qualified Data.List as L import Data.Monoid import qualified Data.Text as T -import Data.Text.Format +import Data.Text.Format hiding (format) import qualified Data.Text.IO as TIO -import qualified Data.Text.Lazy as LT -import qualified Data.Text.Lazy.IO as LTIO +-- import qualified Data.Text.Lazy as LT +-- import qualified Data.Text.Lazy.IO as LTIO import System.Directory +import System.Console.CmdArgs.Verbosity import System.Exit hiding (die) import System.FilePath -import System.IO (Handle, IOMode (..), hClose, hFlush, - openFile) +import System.IO (IOMode (..), hClose, hFlush, openFile) import System.Process import qualified Data.Attoparsec.Text as A - -{- Usage: +import Text.PrettyPrint.HughesPJ (text) +{- runFile f = readFile f >>= runString @@ -91,23 +96,63 @@ return zs -} + +-- TODO take makeContext's Bool from caller instead of always using False? +makeZ3Context :: FilePath -> [(Symbol, Sort)] -> IO Context +makeZ3Context f xts + = do me <- makeContextWithSEnv False Z3 f $ fromListSEnv xts + smtDecls me (toListSEnv initSMTEnv) + smtDecls me xts + return me + +checkValidWithContext :: Context -> [(Symbol, Sort)] -> Expr -> Expr -> IO Bool +checkValidWithContext me xts p q + = smtBracket me $ do smtDecls me xts + smtAssert me $ pAnd [p, PNot q] + smtCheckUnsat me + + +-- | type ClosedPred E = {v:Pred | subset (vars v) (keys E) } +-- checkValid :: e:Env -> ClosedPred e -> ClosedPred e -> IO Bool +checkValid :: Bool -> FilePath -> [(Symbol, Sort)] -> Expr -> Expr -> IO Bool +checkValid u f xts p q + = do me <- makeContext u Z3 f + smtDecls me xts + smtAssert me $ pAnd [p, PNot q] + smtCheckUnsat me + +-- | If you already HAVE a context, where all the variables have declared types +-- (e.g. if you want to make MANY repeated Queries) + +-- checkValid :: e:Env -> [ClosedPred e] -> IO [Bool] +checkValids :: Bool -> FilePath -> [(Symbol, Sort)] -> [Expr] -> IO [Bool] +checkValids u f xts ps + = do me <- makeContext u Z3 f + smtDecls me xts + forM ps $ \p -> + smtBracket me $ + smtAssert me (PNot p) >> smtCheckUnsat me + +-- debugFile :: FilePath +-- debugFile = "DEBUG.smt2" + -------------------------------------------------------------------------- -- | SMT IO -------------------------------------------------------------- -------------------------------------------------------------------------- + -------------------------------------------------------------------------- command :: Context -> Command -> IO Response -------------------------------------------------------------------------- -command me !cmd = {-# SCC "command" #-} say me cmd >> hear me cmd +command me !cmd = {-# SCC "command" #-} say cmd >> hear cmd where - say me = smtWrite me . smt2 - hear me CheckSat = smtRead me - hear me (GetValue _) = smtRead me - hear me _ = return Ok - + say = smtWrite me . runSmt2 (smtenv me) + hear CheckSat = smtRead me + hear (GetValue _) = smtRead me + hear _ = return Ok -smtWrite :: Context -> LT.Text -> IO () +smtWrite :: Context -> T.Text -> IO () smtWrite me !s = smtWriteRaw me s smtRead :: Context -> IO Response @@ -115,11 +160,10 @@ do ln <- smtReadRaw me res <- A.parseWith (smtReadRaw me) responseP ln case A.eitherResult res of - Left e -> error e + Left e -> errorstar $ "SMTREAD:" ++ e Right r -> do maybe (return ()) (\h -> hPutStrLnNow h $ format "; SMT Says: {}" (Only $ show r)) (cLog me) - when (verbose me) $ - LTIO.putStrLn $ format "SMT Says: {}" (Only $ show r) + -- when (verbose me) $ TIO.putStrLn $ format "SMT Says: {}" (Only $ show r) return r responseP = {-# SCC "responseP" #-} A.char '(' *> sexpP @@ -132,7 +176,7 @@ errorP = A.skipSpace *> A.char '"' *> A.takeWhile1 (/='"') <* A.string "\")" -valuesP = A.many1' pairP <* (A.char ')') +valuesP = A.many1' pairP <* A.char ')' pairP = {-# SCC "pairP" #-} do A.skipSpace @@ -152,61 +196,72 @@ = do v <- A.char '(' *> A.takeWhile1 (/=')') <* A.char ')' return $ "(" <> v <> ")" -{-@ pairs :: {v:[a] | (len v) mod 2 = 0} -> [(a,a)] @-} -pairs :: [a] -> [(a,a)] -pairs !xs = case L.splitAt 2 xs of - ([],b) -> [] - ([x,y], zs) -> (x,y) : pairs zs +-- {- pairs :: {v:[a] | (len v) mod 2 = 0} -> [(a,a)] -} +-- pairs :: [a] -> [(a,a)] +-- pairs !xs = case L.splitAt 2 xs of +-- ([],_) -> [] +-- ([x,y], zs) -> (x,y) : pairs zs -smtWriteRaw :: Context -> LT.Text -> IO () +smtWriteRaw :: Context -> T.Text -> IO () smtWriteRaw me !s = {-# SCC "smtWriteRaw" #-} do hPutStrLnNow (cOut me) s + -- whenLoud $ TIO.appendFile debugFile (s <> "\n") maybe (return ()) (`hPutStrLnNow` s) (cLog me) smtReadRaw :: Context -> IO Raw smtReadRaw me = {-# SCC "smtReadRaw" #-} TIO.hGetLine (cIn me) -hPutStrLnNow h !s = LTIO.hPutStrLn h s >> hFlush h +hPutStrLnNow h !s = TIO.hPutStrLn h s >> hFlush h -------------------------------------------------------------------------- -- | SMT Context --------------------------------------------------------- -------------------------------------------------------------------------- -------------------------------------------------------------------------- -makeContext :: SMTSolver -> FilePath -> IO Context +makeContext :: Bool -> SMTSolver -> FilePath -> IO Context -------------------------------------------------------------------------- -makeContext s f - = do me <- makeProcess s - pre <- smtPreamble s me +makeContext u s f + = do me <- makeProcess s + pre <- smtPreamble u s me createDirectoryIfMissing True $ takeDirectory smtFile - hLog <- openFile smtFile WriteMode + hLog <- openFile smtFile WriteMode let me' = me { cLog = Just hLog } mapM_ (smtWrite me') pre return me' where smtFile = extFileName Smt2 f +makeContextWithSEnv :: Bool -> SMTSolver -> FilePath -> SMTEnv -> IO Context +makeContextWithSEnv u s f env + = (\cxt -> cxt {smtenv = env}) <$> makeContext u s f -makeContextNoLog s +makeContextNoLog :: Bool -> SMTSolver -> IO Context +makeContextNoLog u s = do me <- makeProcess s - pre <- smtPreamble s me + pre <- smtPreamble u s me mapM_ (smtWrite me) pre return me +makeProcess :: SMTSolver -> IO Context makeProcess s = do (hOut, hIn, _ ,pid) <- runInteractiveCommand $ smtCmd s - return $ Ctx pid hIn hOut Nothing False + loud <- isLoud + return Ctx { pId = pid + , cIn = hIn + , cOut = hOut + , cLog = Nothing + , verbose = loud + , smtenv = initSMTEnv + } -------------------------------------------------------------------------- cleanupContext :: Context -> IO ExitCode -------------------------------------------------------------------------- -cleanupContext me@(Ctx {..}) - = do smtWrite me "(exit)" - code <- waitForProcess pId - hClose cIn +cleanupContext (Ctx {..}) + = do hClose cIn hClose cOut maybe (return ()) hClose cLog - return code + waitForProcess pId {- "z3 -smt2 -in" -} {- "z3 -smtc SOFT_TIMEOUT=1000 -in" -} @@ -217,21 +272,22 @@ smtCmd Cvc4 = "cvc4 --incremental -L smtlib2" -- DON'T REMOVE THIS! z3 changed the names of options between 4.3.1 and 4.3.2... -smtPreamble Z3 me +smtPreamble u Z3 me = do smtWrite me "(get-info :version)" v:_ <- T.words . (!!1) . T.splitOn "\"" <$> smtReadRaw me if T.splitOn "." v `versionGreater` ["4", "3", "2"] - then return $ z3_432_options ++ z3Preamble - else return $ z3_options ++ z3Preamble -smtPreamble _ _ - = return smtlibPreamble + then return $ z3_432_options ++ preamble u Z3 + else return $ z3_options ++ preamble u Z3 +smtPreamble u s _ + = return $ preamble u s versionGreater (x:xs) (y:ys) | x > y = True | x == y = versionGreater xs ys | x < y = False -versionGreater xs [] = True -versionGreater [] ys = False +versionGreater _ [] = True +versionGreater [] _ = False +versionGreater _ _ = errorstar "Interface.versionGreater called with bad arguments" ----------------------------------------------------------------------------- -- | SMT Commands ----------------------------------------------------------- @@ -242,6 +298,9 @@ smtPop me = interact' me Pop +smtDecls :: Context -> [(Symbol, Sort)] -> IO () +smtDecls me xts = forM_ xts (\(x,t) -> smtDecl me x t) + smtDecl :: Context -> Symbol -> Sort -> IO () smtDecl me x t = interact' me (Declare x ins out) where @@ -252,7 +311,15 @@ Just (_, ins, out) -> (ins, out) Nothing -> ([] , t ) -smtAssert :: Context -> Pred -> IO () +smtCheckSat :: Context -> Expr -> IO Bool +smtCheckSat me p +-- hack now this is used only for checking gradual condition. + = smtAssert me p >> (ans <$> command me CheckSat) + where + ans Sat = True + ans _ = False + +smtAssert :: Context -> Expr -> IO () smtAssert me p = interact' me (Assert Nothing p) smtDistinct :: Context -> [Expr] -> IO () @@ -270,7 +337,7 @@ respSat Unsat = True respSat Sat = False respSat Unknown = False -respSat r = die $ err dummySpan $ "crash: SMTLIB2 respSat = " ++ show r +respSat r = die $ err dummySpan $ text ("crash: SMTLIB2 respSat = " ++ show r) interact' me cmd = void $ command me cmd @@ -286,4 +353,3 @@ , "(set-option :model true)" , "(set-option :model-partial false)" , "(set-option :mbqi false)" ] - diff --git a/src/Language/Fixpoint/Smt/Serialize.hs b/src/Language/Fixpoint/Smt/Serialize.hs --- a/src/Language/Fixpoint/Smt/Serialize.hs +++ b/src/Language/Fixpoint/Smt/Serialize.hs @@ -1,6 +1,8 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE FlexibleContexts #-} -- | This module contains the code for serializing Haskell values -- into SMTLIB2 format, that is, the instances for the @SMTLIB2@ @@ -10,53 +12,91 @@ module Language.Fixpoint.Smt.Serialize where import Language.Fixpoint.Types +--import Language.Fixpoint.Types.Names (mulFuncName, divFuncName) import Language.Fixpoint.Smt.Types -import Language.Fixpoint.Smt.Theories -import qualified Data.Text as T -import Data.Text.Format -import qualified Data.Text.Lazy as LT +import qualified Language.Fixpoint.Smt.Theories as Thy +import qualified Data.Text as T +import Data.Text.Format hiding (format) +import Language.Fixpoint.Misc (errorstar) -- , traceShow) +import Language.Fixpoint.SortCheck (elaborate) + +import Control.Monad.State + +import Data.Maybe (fromMaybe) + + +{- + (* (L t1 t2 t3) is now encoded as + ---> (((L @ t1) @ t2) @ t3) + ---> App(@, [App(@, [App(@, [L[]; t1]); t2]); t3]) + The following decodes the above as + *) + let rec app_args_of_t acc = function + | App (c, [t1; t2]) when c = tc_app -> app_args_of_t (t2 :: acc) t1 + | App (c, []) -> (c, acc) + | t -> (tc_app, t :: acc) + + (* + | Ptr (Loc s) -> (tycon s, acc) + | t -> assertf "app_args_of_t: unexpected t1 = %s" (to_string t) + *) + + let app_of_t = function + | App (c, _) as t when c = tc_app -> Some (app_args_of_t [] t) + | App (c, ts) -> Some (c, ts) + | _ -> None + +-} + instance SMTLIB2 Sort where - smt2 FInt = "Int" + smt2 s@(FFunc _ _) = errorstar $ "smt2 FFunc: " ++ show s + smt2 FInt = "Int" + smt2 FReal = "Real" smt2 t - | t == boolSort = "Bool" - -- smt2 (FApp t []) | t == intFTyCon = "Int" - -- smt2 (FApp t []) | t == boolFTyCon = "Bool" - smt2 (FApp t [FApp ts _,_]) | t == appFTyCon && fTyconSymbol ts == "Set_Set" = "Set" - -- smt2 (FObj s) = smt2 s - smt2 s@(FFunc _ _) = error $ "smt2 FFunc: " ++ show s - smt2 _ = "Int" + | t == boolSort = "Bool" + smt2 t + | Just d <- Thy.smt2Sort t = d + smt2 _ = "Int" + defunc (FAbs _ t) = defunc t + defunc (FFunc _ _) = return $ intSort + defunc t | isSMTSort t = return t + defunc _ = return intSort + instance SMTLIB2 Symbol where - smt2 s | Just t <- smt2Theory s -- M.lookup s smt_set_funs - = LT.fromStrict t - smt2 s = LT.fromStrict . encode . symbolText $ s + smt2 s + | Just t <- Thy.smt2Symbol s = t + smt2 s = symbolSafeText s --- FIXME: this is probably too slow -encode :: T.Text -> T.Text -encode t = {-# SCC "encode" #-} - foldr (\(x,y) -> T.replace x y) t [("[", "ZM"), ("]", "ZN"), (":", "ZC") - ,("(", "ZL"), (")", "ZR"), (",", "ZT") - ,("|", "zb"), ("#", "zh"), ("\\","zr") - ,("z", "zz"), ("Z", "ZZ"), ("%","zv")] +instance SMTLIB2 (Symbol, Sort) where + smt2 (sym, t) = format "({} {})" (smt2 sym, smt2 t) + defunc (sym, t) = do bx <- defunc sym + bt <- defunc t + return $ (bx, bt) + + instance SMTLIB2 SymConst where - smt2 (SL s) = LT.fromStrict s + smt2 = smt2 . symbol + instance SMTLIB2 Constant where smt2 (I n) = format "{}" (Only n) smt2 (R d) = format "{}" (Only d) - -- smt2 (L t _) = t + smt2 (L t _) = format "{}" (Only t) -- errorstar $ "Horrors, how to translate: " ++ show c instance SMTLIB2 LocSymbol where smt2 = smt2 . val instance SMTLIB2 Bop where - smt2 Plus = "+" - smt2 Minus = "-" - smt2 Times = "*" - smt2 Div = "/" - smt2 Mod = "mod" + smt2 Plus = "+" + smt2 Minus = "-" + smt2 Times = symbolSafeText mulFuncName + smt2 Div = symbolSafeText divFuncName + smt2 RTimes = "*" + smt2 RDiv = "/" + smt2 Mod = "mod" instance SMTLIB2 Brel where smt2 Eq = "=" @@ -65,63 +105,195 @@ smt2 Ge = ">=" smt2 Lt = "<" smt2 Le = "<=" - smt2 _ = error "SMTLIB2 Brel" + smt2 _ = errorstar "SMTLIB2 Brel" +-- NV TODO: change the way EApp is printed instance SMTLIB2 Expr where - smt2 (ESym z) = smt2 z + smt2 (ESym z) = smt2 (symbol z) smt2 (ECon c) = smt2 c smt2 (EVar x) = smt2 x - smt2 (ELit x _) = smt2 x - smt2 (EApp f es) = smt2App f es - smt2 (ENeg e) = format "(- {})" (Only $ smt2 e) - smt2 (EBin o e1 e2) = format "({} {} {})" (smt2 o, smt2 e1, smt2 e2) + smt2 e@(EApp _ _) = smt2App e + smt2 (ENeg e) = format "(- {})" (Only $ smt2 e) + smt2 (EBin o e1 e2) = format "({} {} {})" (smt2 o, smt2 e1, smt2 e2) smt2 (EIte e1 e2 e3) = format "(ite {} {} {})" (smt2 e1, smt2 e2, smt2 e3) smt2 (ECst e _) = smt2 e - smt2 e = error $ "TODO: SMTLIB2 Expr: " ++ show e - -smt2App :: LocSymbol -> [Expr] -> LT.Text -smt2App f [] = smt2 f -smt2App f [e] - | val f == setEmp = format "(= {} {})" (emp, smt2 e) - | val f == setSng = format "({} {} {})" (add, emp, smt2 e) -smt2App f es = format "({} {})" (smt2 f, smt2s es) - - -instance SMTLIB2 Pred where smt2 (PTrue) = "true" smt2 (PFalse) = "false" smt2 (PAnd []) = "true" - smt2 (PAnd ps) = format "(and {})" (Only $ smt2s ps) + smt2 (PAnd ps) = format "(and {})" (Only $ smt2s ps) smt2 (POr []) = "false" - smt2 (POr ps) = format "(or {})" (Only $ smt2s ps) - smt2 (PNot p) = format "(not {})" (Only $ smt2 p) - smt2 (PImp p q) = format "(=> {} {})" (smt2 p, smt2 q) - smt2 (PIff p q) = format "(= {} {})" (smt2 p, smt2 q) - smt2 (PBexp e) = smt2 e + smt2 (POr ps) = format "(or {})" (Only $ smt2s ps) + smt2 (PNot p) = format "(not {})" (Only $ smt2 p) + smt2 (PImp p q) = format "(=> {} {})" (smt2 p, smt2 q) + smt2 (PIff p q) = format "(= {} {})" (smt2 p, smt2 q) + smt2 (PExist bs p) = format "(exists ({}) {})" (smt2s bs, smt2 p) + smt2 (PAll bs p) = format "(forall ({}) {})" (smt2s bs, smt2 p) + smt2 (PAtom r e1 e2) = mkRel r e1 e2 - smt2 _ = error "smtlib2 Pred" + smt2 PGrad = "true" + smt2 e = errorstar ("smtlib2 Pred " ++ show e) +-- new version + defunc e@(ESym _) = return e + defunc e@(ECon _) = return e + defunc e@(EVar _) = return e + defunc e@(EApp _ _) = defuncApp e + defunc (ENeg e) = ENeg <$> defunc e + defunc (EBin o e1 e2) = defuncBop o e1 e2 + defunc (EIte e1 e2 e3) = do e1' <- defunc e1 + e2' <- defunc e2 + e3' <- defunc e3 + return $ EIte e1' e2' e3' + defunc (ECst e t) = (`ECst` t) <$> defunc e + defunc (PTrue) = return PTrue + defunc (PFalse) = return PFalse + defunc (PAnd []) = return PTrue + defunc (PAnd ps) = PAnd <$> mapM defunc ps + defunc (POr []) = return PFalse + defunc (POr ps) = POr <$> mapM defunc ps + defunc (PNot p) = PNot <$> defunc p + defunc (PImp p q) = PImp <$> defunc p <*> defunc q + defunc (PIff p q) = PIff <$> defunc p <*> defunc q + defunc (PExist bs p) = do bs' <- mapM defunc bs + p' <- withExtendedEnv bs $ defunc p + return $ PExist bs' p' + defunc (PAll bs p) = do bs' <- mapM defunc bs + p' <- withExtendedEnv bs $ defunc p + return $ PAll bs' p' + defunc (PAtom r e1 e2) = PAtom r <$> defunc e1 <*> defunc e2 + defunc PGrad = return PGrad + defunc e = errorstar ("smtlib2 Pred " ++ show e) + +defuncBop o e1 e2 + | o == Times, s1 == FReal, s2 == FReal + = do e1' <- defunc e1 + e2' <- defunc e2 + return $ EBin RTimes e1' e2' + | o == Div, s1 == FReal, s2 == FReal + = do e1' <- defunc e1 + e2' <- defunc e2 + return $ EBin RDiv e1' e2' + | otherwise + = do e1' <- defunc e1 + e2' <- defunc e2 + return $ EBin o e1' e2' + where + s1 = exprSort e1 + s2 = exprSort e2 + + +smt2App :: Expr -> T.Text +smt2App e = fromMaybe (format "({} {})" (smt2 f, smt2many (smt2 <$> es))) (Thy.smt2App (eliminate f) $ (smt2 <$> es)) + where + (f, es) = splitEApp e + + +defuncApp :: Expr -> SMT2 Expr +defuncApp e = case Thy.smt2App (eliminate f) $ (smt2 <$> es) of + Just _ -> eApps f <$> mapM defunc es + _ -> defuncApp' f es + where + (f, es) = splitEApp e + +eliminate (ECst e _) = e +eliminate e = e + +defuncApp' :: Expr -> [Expr] -> SMT2 Expr +defuncApp' f [] = defunc f +defuncApp' f es = makeApplication f es +-- smt2App' env f es = format "({} {})" (smt2 env f, smt2many (smt2 env <$> es)) -- makeApplication env f es + + + mkRel Ne e1 e2 = mkNe e1 e2 mkRel Une e1 e2 = mkNe e1 e2 -mkRel r e1 e2 = format "({} {} {})" (smt2 r, smt2 e1, smt2 e2) +mkRel r e1 e2 = format "({} {} {})" (smt2 r, smt2 e1, smt2 e2) mkNe e1 e2 = format "(not (= {} {}))" (smt2 e1, smt2 e2) instance SMTLIB2 Command where - smt2 (Declare x ts t) = format "(declare-fun {} ({}) {})" (smt2 x, smt2s ts, smt2 t) - smt2 (Define t) = format "(declare-sort {})" (Only $ smt2 t) - smt2 (Assert Nothing p) = format "(assert {})" (Only $ smt2 p) + -- NIKI TODO: formalize this transformation + smt2 (Declare x ts t) = format "(declare-fun {} ({}) {})" (smt2 x, smt2s ts, smt2 t) + smt2 (Define t) = format "(declare-sort {})" (Only $ smt2 t) + smt2 (Assert Nothing p) = format "(assert {})" (Only $ smt2 p) smt2 (Assert (Just i) p) = format "(assert (! {} :named p-{}))" (smt2 p, i) - smt2 (Distinct az) = format "(assert (distinct {}))" (Only $ smt2s az) + smt2 (Distinct az) + -- Distinct must have at least 2 arguments + | length az < 2 = "" + | otherwise = format "(assert (distinct {}))" (Only $ smt2s az) smt2 (Push) = "(push 1)" smt2 (Pop) = "(pop 1)" smt2 (CheckSat) = "(check-sat)" - smt2 (GetValue xs) = LT.unwords $ ["(get-value ("] ++ fmap smt2 xs ++ ["))"] + smt2 (GetValue xs) = T.unwords $ ["(get-value ("] ++ fmap smt2 xs ++ ["))"] + smt2 (CMany cmds) = smt2many (smt2 <$> cmds) -smt2s :: SMTLIB2 a => [a] -> LT.Text -smt2s = LT.intercalate " " . fmap smt2 + defunc (Declare x ts t) + | isSMTSymbol x + = do dx <- defunc x + dts <- mapM defunc ts + dt <- defunc t + return $ Declare dx dts dt + | null ts && isSMTSort t + = do dx <- defunc x + dt <- defunc t + return $ Declare dx [] dt + | otherwise + = do dx <- defunc x + return $ Declare dx [] intSort + defunc (Define t) = return $ Define t + defunc (Assert Nothing p) + = do env <- smt2env <$> get + (p', fs) <- grapLambdas $ elaborate env p + dfs <- mapM defineFun fs + p'' <- defunc p' + return $ CMany (concat dfs ++ [Assert Nothing p'']) + + defunc (Assert (Just i) p) + = do env <- smt2env <$> get + (p', fs) <- grapLambdas $ elaborate env p + dfs <- mapM defineFun fs + p'' <- defunc p' + return $ CMany (concat dfs ++ [Assert (Just i) p'']) +-- smt2 env (Assert (Just i) p) = format "(assert (! {} :named p-{}))" (smt2 env $ elaborate env p, i) + defunc (Distinct az) = Distinct <$> mapM defunc az + defunc (Push) = return Push + defunc (Pop) = return Pop + defunc (CheckSat) = return CheckSat + defunc (GetValue xs) = return $ GetValue xs + defunc (CMany cmds) = CMany <$> mapM defunc cmds + +smt2s :: SMTLIB2 a => [a] -> T.Text +smt2s as = smt2many (smt2 <$> as) + +smt2many :: [T.Text] -> T.Text +smt2many = T.intercalate " " + + +defineFun :: (Symbol, Expr) -> SMT2 [Command] +defineFun (f, ELam (x, t) (ECst e tr)) + = do decl <- defunc $ Declare f (t:(snd <$> xts)) tr + assert <- withExtendedEnv [(f, FFunc t tr)] $ + defunc $ Assert Nothing (PAll ((x,t):xts) + (PAtom Eq (mkApp (EApp (EVar f) (EVar x)) (fst <$> xts)) bd)) + return $ [decl, assert] + where + go acc (ELam (x, t) e) = go ((x,t):acc) e + go acc (ECst e _) = go acc e + go acc e = (acc, e) + + (xts, bd) = go [] e + + mkApp e' [] = e' + mkApp e' (x:xs) = mkApp (EApp e' (EVar x)) xs + +defineFun _ + = errorstar "die" + + +isSMTSymbol x = Thy.isTheorySymbol x || memberSEnv x initSMTEnv + {- (declare-fun x () Int) (declare-fun y () Int) @@ -137,3 +309,166 @@ (pop 1) -} + + +------------------------------------------------------------------------------------- +---------------- Defunctionalizaion ------------------------------------------------ +------------------------------------------------------------------------------------- + +grapLambdas e = go [] e + where + go acc e@(ELam _ _) = do f <- freshSym + return (EVar f, (f, e):acc) + go acc e@(ESym _) = return (e, acc) + go acc e@(ECon _) = return (e, acc) + go acc e@(EVar _) = return (e, acc) + go acc (EApp e1 e2) = do (e1', fs1) <- go [] e1 + (e2', fs2) <- go [] e2 + return (EApp e1' e2', fs1 ++ fs2 ++ acc) + go acc (ENeg e) = do (e', fs) <- go acc e + return (ENeg e', fs) + go acc (PNot e) = do (e', fs) <- go acc e + return (PNot e', fs) + go acc (EBin b e1 e2) = do (e1', fs1) <- go [] e1 + (e2', fs2) <- go [] e2 + return (EBin b e1' e2', fs1 ++ fs2 ++ acc) + go acc (PAtom b e1 e2) = do (e1', fs1) <- go [] e1 + (e2', fs2) <- go [] e2 + return (PAtom b e1' e2', fs1 ++ fs2 ++ acc) + go acc (EIte e e1 e2) = do (e' , fs) <- go [] e + (e1', fs1) <- go [] e1 + (e2', fs2) <- go [] e2 + return (EIte e' e1' e2', fs ++ fs1 ++ fs2 ++ acc) + go acc (ECst e s) = do (e', fs) <- go acc e + return (ECst e' s, fs) + go acc (ETAbs e s) = do (e', fs) <- go acc e + return (ETAbs e' s, fs) + go acc (ETApp e s) = do (e', fs) <- go acc e + return (ETApp e' s, fs) + go acc (PAnd es) = do es' <- mapM (go []) es + return (PAnd (fst <$> es'), concat (acc:(snd <$> es'))) + go acc (POr es) = do es' <- mapM (go []) es + return (POr (fst <$> es'), concat (acc:(snd <$> es'))) + go acc (PImp e1 e2) = do (e1', fs1) <- go [] e1 + (e2', fs2) <- go [] e2 + return (PImp e1' e2', fs1 ++ fs2 ++ acc) + go acc (PIff e1 e2) = do (e1', fs1) <- go [] e1 + (e2', fs2) <- go [] e2 + return (PIff e1' e2', fs1 ++ fs2 ++ acc) + go acc (PAll bs e) = do (e', fs) <- go acc e + return (PAll bs e', fs) + go acc (PExist bs e) = do (e', fs) <- go acc e + return (PExist bs e', fs) + go acc e@PGrad = return (e, acc) + go acc e@(PKVar _ _) = return (e, acc) + +-- NIKI: This is new code, check and formalize! + + +-- make Application is called on uninterpreted functions +-- +-- makeApplication e [e1, ..., en] = apply^n_s (e, toInt e1, ..., toInt en) +-- where +-- applyn :: (Int, Int, ..., Int) -> s +-- e :: (Int, ..., Int) -> s +-- toInt e = e, if e :: s, s is smt uninterpeted +-- toInt e = s_to_Int (e), otherwise + +-- s_to_Int :: s -> Int + +makeApplication :: Expr -> [Expr] -> SMT2 Expr +makeApplication e es + = do df <- defunc f + de <- defunc e + des <- mapM toInt es + return $ eApps (EVar df) (de:des) + where + f = makeFunSymbol e $ length es + + +makeFunSymbol :: Expr -> Int -> Symbol +makeFunSymbol e i + | (FApp (FTC c) _) <- s, fTyconSymbol c == "Set_Set" + = setApplyName i + | (FApp (FApp (FTC c) _) _) <- s, fTyconSymbol c == "Map_t" + = mapApplyName i + | (FApp (FTC bv) (FTC s)) <- s, Thy.isBv bv, Just _ <- Thy.sizeBv s + = bitVecApplyName i + | FTC c <- s, c == boolFTyCon + = boolApplyName i + | s == FReal + = realApplyName i + | otherwise + = intApplyName i + where + s = dropArgs i $ exprSort e + + dropArgs 0 t = t + dropArgs i (FAbs _ t) = dropArgs i t + dropArgs i (FFunc _ t) = dropArgs (i-1) t + dropArgs _ _ = die $ err dummySpan "dropArgs: the impossible happened" + +toInt :: Expr -> SMT2 Expr +toInt e + | (FApp (FTC c) _) <- s, fTyconSymbol c == "Set_Set" + = castWith setToIntName e + | (FApp (FApp (FTC c) _) _) <- s, fTyconSymbol c == "Map_t" + = castWith mapToIntName e + | (FApp (FTC bv) (FTC s)) <- s, Thy.isBv bv, Just _ <- Thy.sizeBv s + = castWith bitVecToIntName e + | FTC c <- s, c == boolFTyCon + = castWith boolToIntName e + | FTC c <- s, c == realFTyCon + = castWith realToIntName e + | otherwise + = defunc e + where + s = exprSort e + +isSMTSort :: Sort -> Bool +isSMTSort s + | (FApp (FTC c) _) <- s, fTyconSymbol c == "Set_Set" + = True + | (FApp (FApp (FTC c) _) _) <- s, fTyconSymbol c == "Map_t" + = True + | (FApp (FTC bv) (FTC s)) <- s, Thy.isBv bv, Just _ <- Thy.sizeBv s + = True + | FTC c <- s, c == boolFTyCon + = True + | s == FReal + = True + | otherwise + = False + + +castWith :: Symbol -> Expr -> SMT2 Expr +castWith s e = + do bs <- defunc s + be <- defunc e + return $ EApp (EVar bs) be + +initSMTEnv = fromListSEnv $ + [ (setToIntName, FFunc (setSort intSort) intSort) + , (bitVecToIntName, FFunc bitVecSort intSort) + , (mapToIntName, FFunc (mapSort intSort intSort) intSort) + , (boolToIntName, FFunc boolSort intSort) + , (realToIntName, FFunc realSort intSort) + ] + ++ concatMap makeApplies [1..7] + +makeApplies i = + [ (intApplyName i, go i intSort) + , (setApplyName i, go i (setSort intSort)) + , (bitVecApplyName i, go i bitVecSort) + , (mapApplyName i, go i $ mapSort intSort intSort) + , (realApplyName i, go i realSort) + , (boolApplyName i, go i boolSort) + ] + where + go 0 s = FFunc intSort s + go i s = FFunc intSort $ go (i-1) s + + +exprSort :: Expr -> Sort +exprSort (ECst _ s) = s +exprSort e = errorstar ("\nexprSort on unexpected expressions" ++ show e) diff --git a/src/Language/Fixpoint/Smt/Theories.hs b/src/Language/Fixpoint/Smt/Theories.hs --- a/src/Language/Fixpoint/Smt/Theories.hs +++ b/src/Language/Fixpoint/Smt/Theories.hs @@ -2,47 +2,56 @@ {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE PatternGuards #-} -module Language.Fixpoint.Smt.Theories where +module Language.Fixpoint.Smt.Theories + ( + -- * Convert theory applications TODO: merge with smt2symbol + smt2App + -- * Convert theory sorts + , smt2Sort + -- * Convert theory symbols + , smt2Symbol + -- * Preamble to initialize SMT + , preamble + -- * Bit Vector Operations + , isBv, sizeBv + + , isTheorySymbol + , theoryEnv + + -- * Theories + , theorySymbols + , setEmpty, setEmp, setCap, setSub, setAdd, setMem + , setCom, setCup, setDif, setSng, mapSel, mapSto + ) where + +import Prelude hiding (map) +import Language.Fixpoint.Types.Config import Language.Fixpoint.Types import Language.Fixpoint.Smt.Types import qualified Data.HashMap.Strict as M --- import qualified Data.List as L import qualified Data.Text as T -import Data.Text.Format --- import Data.Monoid - - ---import Language.Fixpoint.Errors ---import Language.Fixpoint.Files -import Control.Applicative ((<$>)) ---import Control.Monad ---import Data.Char ---import qualified Data.Text.IO as TIO -import qualified Data.Text.Lazy as LT ---import qualified Data.Text.Lazy.IO as LTIO ---import System.Directory ---import System.Exit hiding (die) ---import System.FilePath ---import System.IO (Handle, IOMode (..), hClose, hFlush, openFile) ---import System.Process ---import qualified Data.Attoparsec.Text as A - +import Data.Text.Format hiding (format) -------------------------------------------------------------------------- -- | Set Theory ---------------------------------------------------------- -------------------------------------------------------------------------- -elt, set, map, bit, sz32, sz64 :: Raw +elt, set, map :: Raw elt = "Elt" set = "Set" map = "Map" -bit = "BitVec" -sz32 = "Size32" -sz64 = "Size64" + +-- bit, sz32, sz64 :: Raw +-- bit = symbolText bitVecName -- "BitVec" +-- sz32 = symbolText size32Name -- "Size32" +-- sz64 = symbolText size64Name -- "Size64" + + emp, add, cup, cap, mem, dif, sub, com, sel, sto :: Raw emp = "smt_set_emp" add = "smt_set_add" @@ -56,19 +65,22 @@ sto = "smt_map_sto" -setEmp, setCap, setSub, setAdd, setMem, setCom, setCup, setDif, setSng :: Symbol -setEmp = "Set_emp" -setCap = "Set_cap" -setSub = "Set_sub" -setAdd = "Set_add" -setMem = "Set_mem" -setCom = "Set_com" -setCup = "Set_cup" -setDif = "Set_dif" -setSng = "Set_sng" +setEmpty, setEmp, setCap, setSub, setAdd, setMem, setCom, setCup, setDif, setSng, mapSel, mapSto :: Symbol +setEmpty = "Set_empty" +setEmp = "Set_emp" +setCap = "Set_cap" +setSub = "Set_sub" +setAdd = "Set_add" +setMem = "Set_mem" +setCom = "Set_com" +setCup = "Set_cup" +setDif = "Set_dif" +setSng = "Set_sng" +mapSel = "Map_select" +mapSto = "Map_store" -z3Preamble :: [LT.Text] -z3Preamble +z3Preamble :: Bool -> [T.Text] +z3Preamble u = [ format "(define-sort {} () Int)" (Only elt) , format "(define-sort {} () (Array {} Bool))" @@ -89,11 +101,24 @@ (dif, set, set, set, cap, com) , format "(define-fun {} ((s1 {}) (s2 {})) Bool (= {} ({} s1 s2)))" (sub, set, set, emp, dif) + , format "(define-sort {} () (Array {} {}))" + (map, elt, elt) + , format "(define-fun {} ((m {}) (k {})) {} (select m k))" + (sel, map, elt, elt) + , format "(define-fun {} ((m {}) (k {}) (v {})) {} (store m k v))" + (sto, map, elt, elt, map) + , uifDef u (symbolText mulFuncName) ("*"::T.Text) + , uifDef u (symbolText divFuncName) ("div"::T.Text) ] -smtlibPreamble :: [LT.Text] -smtlibPreamble - = [ "(set-logic QF_UFLIA)" +-- RJ: Am changing this to `Int` not `Real` as (1) we usually want `Int` and +-- (2) have very different semantics. TODO: proper overloading, post genEApp +uifDef u f op | u = format "(declare-fun {} (Int Int) Int)" (Only f) + | otherwise = format "(define-fun {} ((x Int) (y Int)) Int ({} x y))" (f, op) + +cvc4Preamble :: Bool -> [T.Text] +cvc4Preamble _ --TODO use uif flag u (see z3Preamble) + = [ "(set-logic ALL_SUPPORTED)" , format "(define-sort {} () Int)" (Only elt) , format "(define-sort {} () Int)" (Only set) , format "(declare-fun {} () {})" (emp, set) @@ -103,8 +128,32 @@ , format "(declare-fun {} ({} {}) {})" (dif, set, set, set) , format "(declare-fun {} ({} {}) Bool)" (sub, set, set) , format "(declare-fun {} ({} {}) Bool)" (mem, elt, set) + , format "(define-sort {} () (Array {} {}))" + (map, elt, elt) + , format "(define-fun {} ((m {}) (k {})) {} (select m k))" + (sel, map, elt, elt) + , format "(define-fun {} ((m {}) (k {}) (v {})) {} (store m k v))" + (sto, map, elt, elt, map) ] +smtlibPreamble :: Bool -> [T.Text] +smtlibPreamble _ --TODO use uif flag u (see z3Preamble) + = [ -- "(set-logic QF_AUFRIA)", + format "(define-sort {} () Int)" (Only elt) + , format "(define-sort {} () Int)" (Only set) + , format "(declare-fun {} () {})" (emp, set) + , format "(declare-fun {} ({} {}) {})" (add, set, elt, set) + , format "(declare-fun {} ({} {}) {})" (cup, set, set, set) + , format "(declare-fun {} ({} {}) {})" (cap, set, set, set) + , format "(declare-fun {} ({} {}) {})" (dif, set, set, set) + , format "(declare-fun {} ({} {}) Bool)" (sub, set, set) + , format "(declare-fun {} ({} {}) Bool)" (mem, elt, set) + , format "(define-sort {} () Int)" (Only map) + , format "(declare-fun {} ({} {}) {})" (sel, map, elt, elt) + , format "(declare-fun {} ({} {} {}) {})" (sto, map, elt, elt, map) + ] + +{- mkSetSort _ _ = set mkEmptySet _ _ = emp mkSetAdd _ s x = format "({} {} {})" (add, s, x) @@ -113,27 +162,92 @@ mkSetCap _ s t = format "({} {} {})" (cap, s, t) mkSetDif _ s t = format "({} {} {})" (dif, s, t) mkSetSub _ s t = format "({} {} {})" (sub, s, t) - +-} -- smt_set_funs :: M.HashMap Symbol Raw -- smt_set_funs = M.fromList [ (setEmp, emp), (setAdd, add), (setCup, cup) -- , (setCap, cap), (setMem, mem), (setDif, dif) -- , (setSub, sub), (setCom, com)] + +isTheorySymbol :: Symbol -> Bool +isTheorySymbol x = M.member x theorySymbols + +theoryEnv = M.map tsSort theorySymbols + theorySymbols :: M.HashMap Symbol TheorySymbol theorySymbols = M.fromList - [ tSym setEmp emp undefined - , tSym setAdd add undefined - , tSym setCup cup undefined - , tSym setCap cap undefined - , tSym setMem mem undefined - , tSym setDif dif undefined - , tSym setSub sub undefined - , tSym setCom com undefined + [ tSym setEmp emp (FAbs 0 $ FFunc (setSort $ FVar 0) boolSort) + , tSym setEmpty emp (FAbs 0 $ FFunc intSort (setSort $ FVar 0)) + , tSym setAdd add setbopSort + , tSym setCup cup setbopSort + , tSym setCap cap setbopSort + , tSym setMem mem setmemSort + , tSym setDif dif setbopSort + , tSym setSub sub setcmpSort + , tSym setCom com setcmpSort + , tSym mapSel sel mapselSort + , tSym mapSto sto mapstoSort + , tSym bvOrName "bvor" bvbopSort + , tSym bvAndName "bvand" bvbopSort ] + where + setbopSort = FAbs 0 $ FFunc (setSort $ FVar 0) $ FFunc (setSort $ FVar 0) (setSort $ FVar 0) + setmemSort = FAbs 0 $ FFunc (FVar 0) $ FFunc (setSort $ FVar 0) boolSort + setcmpSort = FAbs 0 $ FFunc (setSort $ FVar 0) $ FFunc (setSort $ FVar 0) boolSort + mapselSort = FAbs 0 $ FAbs 1 $ FFunc (mapSort (FVar 0) (FVar 1)) $ FFunc (FVar 0) (FVar 0) + mapstoSort = FAbs 0 $ FAbs 1 $ FFunc (mapSort (FVar 0) (FVar 1)) + $ FFunc (FVar 0) + $ FFunc (FVar 1) + (mapSort (FVar 0) (FVar 1)) + bvbopSort = FFunc bitVecSort $ FFunc bitVecSort bitVecSort + tSym :: Symbol -> Raw -> Sort -> (Symbol, TheorySymbol) tSym x n t = (x, Thy x n t) -smt2Theory :: Symbol -> Maybe T.Text -smt2Theory x = tsRaw <$> M.lookup x theorySymbols + +isBv :: FTycon -> Bool +isBv = (bitVecName ==) . val . fTyconSymbol + +sizeBv :: FTycon -> Maybe Int +sizeBv tc + | s == size32Name = Just 32 + | s == size64Name = Just 64 + | otherwise = Nothing + where + s = val $ fTyconSymbol tc + + +------------------------------------------------------------------------------- +-- | Exported API ------------------------------------------------------------- +------------------------------------------------------------------------------- + +smt2Symbol :: Symbol -> Maybe T.Text +smt2Symbol x = tsRaw <$> M.lookup x theorySymbols + +smt2Sort :: Sort -> Maybe T.Text +smt2Sort (FApp (FTC c) _) + | fTyconSymbol c == "Set_Set" = Just $ format "{}" (Only set) +smt2Sort (FApp (FApp (FTC c) _) _) + | fTyconSymbol c == "Map_t" = Just $ format "{}" (Only map) +smt2Sort (FApp (FTC bv) (FTC s)) + | isBv bv + , Just n <- sizeBv s = Just $ format "(_ BitVec {})" (Only n) +smt2Sort _ = Nothing + +smt2App :: Expr -> [T.Text] -> Maybe T.Text +smt2App (EVar f) [d] + | f == setEmpty = Just $ format "{}" (Only emp) + | f == setEmp = Just $ format "(= {} {})" (emp, d) + | f == setSng = Just $ format "({} {} {})" (add, emp, d) +smt2App (EVar f) ds + | Just s <- M.lookup f theorySymbols + = Just $ format "({} {})" (tsRaw s, T.intercalate " " ds) +smt2App _ _ = Nothing + + +preamble :: Bool -> SMTSolver -> [T.Text] +preamble u Z3 = z3Preamble u +preamble u Cvc4 = cvc4Preamble u +preamble u _ = smtlibPreamble u diff --git a/src/Language/Fixpoint/Smt/Types.hs b/src/Language/Fixpoint/Smt/Types.hs --- a/src/Language/Fixpoint/Smt/Types.hs +++ b/src/Language/Fixpoint/Smt/Types.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE UndecidableInstances #-} @@ -22,34 +23,25 @@ -- * SMTLIB2 Process Context , Context (..) + -- * SMTLIB2 symbol environment + , SMTEnv, emptySMTEnv, SMTSt(..), withExtendedEnv, SMT2, freshSym + -- * Theory Symbol , TheorySymbol (..) + -- * Strict Formatter + , format + ) where -import Language.Fixpoint.Config (SMTSolver (..)) -import Language.Fixpoint.Errors -import Language.Fixpoint.Files import Language.Fixpoint.Types - -import Control.Applicative ((*>), (<$>), (<*), (<|>)) -import Control.Monad -import Data.Char -import qualified Data.HashMap.Strict as M -import qualified Data.List as L -import Data.Monoid +import qualified Data.Text.Format as DTF +import Data.Text.Format.Params (Params) import qualified Data.Text as T -import Data.Text.Format -import qualified Data.Text.IO as TIO import qualified Data.Text.Lazy as LT -import qualified Data.Text.Lazy.IO as LTIO -import System.Directory -import System.Exit hiding (die) -import System.FilePath -import System.IO (Handle, IOMode (..), hClose, hFlush, - openFile) +import System.IO (Handle) import System.Process -import qualified Data.Attoparsec.Text as A +import Control.Monad.State -------------------------------------------------------------------------- -- | Types --------------------------------------------------------------- @@ -63,9 +55,10 @@ | CheckSat | Declare Symbol [Sort] Sort | Define Sort - | Assert (Maybe Int) Pred + | Assert (Maybe Int) Expr | Distinct [Expr] -- {v:[Expr] | 2 <= len v} | GetValue [Symbol] + | CMany [Command] deriving (Eq, Show) -- | Responses received from SMT engine @@ -83,6 +76,7 @@ , cOut :: Handle , cLog :: Maybe Handle , verbose :: Bool + , smtenv :: SMTEnv } -- | Theory Symbol @@ -96,7 +90,35 @@ -- | AST Conversion: Types that can be serialized --------------------- ----------------------------------------------------------------------- +format :: Params ps => DTF.Format -> ps -> T.Text +format f x = LT.toStrict $ DTF.format f x + +type SMTEnv = SEnv Sort +data SMTSt = SMTSt {fresh :: Int , smt2env :: SMTEnv} + +type SMT2 = State SMTSt + +emptySMTEnv = emptySEnv + +withExtendedEnv bs act = do + env <- smt2env <$> get + let env' = foldl (\env (x, t) -> insertSEnv x t env) env bs + modify $ \s -> s{smt2env = env'} + r <- act + modify $ \s -> s{smt2env = env} + return r + +freshSym = do + n <- fresh <$> get + modify $ \s -> s{fresh = n + 1} + return $ intSymbol "lambda_fun_" n + -- | Types that can be serialized class SMTLIB2 a where - smt2 :: a -> LT.Text + defunc :: a -> SMT2 a + defunc = return + smt2 :: a -> T.Text + + runSmt2 :: SMTEnv -> a -> T.Text + runSmt2 env a = smt2 $ evalState (defunc a) (SMTSt 0 env) diff --git a/src/Language/Fixpoint/Solver.hs b/src/Language/Fixpoint/Solver.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fixpoint/Solver.hs @@ -0,0 +1,250 @@ +-- | This module implements the top-level API for interfacing with Fixpoint +-- In particular it exports the functions that solve constraints supplied +-- either as .fq files or as FInfo. +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Language.Fixpoint.Solver ( + -- * Invoke Solver on an FInfo + solve, Solver + + -- * Invoke Solver on a .fq file + , solveFQ + + -- * Function to determine outcome + , resultExit + + -- * Parse Qualifiers from File + , parseFInfo +) where + + +import Control.Concurrent +import Data.Binary +-- import Data.Maybe (fromMaybe) +-- import Data.List hiding (partition) +-- import qualified Data.HashSet as S +import System.Exit (ExitCode (..)) + +-- import System.Console.CmdArgs.Verbosity hiding (Loud) +import Text.PrettyPrint.HughesPJ (render) +-- import Text.Printf (printf) +import Control.Monad (when) +import Control.Exception (catch) + +import Language.Fixpoint.Solver.Graph -- (slice) +import Language.Fixpoint.Solver.Validate (sanitize) +import qualified Language.Fixpoint.Solver.Eliminate as E +-- import Language.Fixpoint.Solver.Deps -- (deps, GDeps (..)) +import Language.Fixpoint.Solver.UniqifyBinds (renameAll) +import Language.Fixpoint.Solver.UniqifyKVars (wfcUniqify) +import qualified Language.Fixpoint.Solver.Solve as Sol +-- import Language.Fixpoint.Solver.Solution (Solution) + +import Language.Fixpoint.Types.Config (queryFile, multicore, Config (..)) +import Language.Fixpoint.Types.Errors +import Language.Fixpoint.Utils.Files hiding (Result) +import Language.Fixpoint.Misc +import Language.Fixpoint.Utils.Progress +import Language.Fixpoint.Utils.Statistics (statistics) +import Language.Fixpoint.Partition -- (mcInfo, partition, partition') +import Language.Fixpoint.Parse (rr', mkQual) +import Language.Fixpoint.Types +import Language.Fixpoint.Minimize (minQuery) +import Control.DeepSeq + + +--------------------------------------------------------------------------- +-- | Solve an .fq file ---------------------------------------------------- +--------------------------------------------------------------------------- +solveFQ :: Config -> IO ExitCode +--------------------------------------------------------------------------- +solveFQ cfg = do + fi <- readFInfo file + r <- solve cfg fi + let stat = resStatus $!! r + -- let str = render $ resultDoc $!! (const () <$> stat) + -- putStrLn "\n" + colorStrLn (colorResult stat) (statStr $!! stat) + return $ eCode r + where + file = inFile cfg + eCode = resultExit . resStatus + statStr = render . resultDoc . fmap fst + +--------------------------------------------------------------------------- +-- | Solve FInfo system of horn-clause constraints ------------------------ +--------------------------------------------------------------------------- +solve :: (NFData a, Fixpoint a) => Solver a +--------------------------------------------------------------------------- +solve cfg q + | parts cfg = partition cfg $!! q + | stats cfg = statistics cfg $!! q + | minimize cfg = minQuery cfg solve' $!! q + | otherwise = solve' cfg $!! q + +solve' :: (NFData a, Fixpoint a) => Solver a +solve' cfg q = do + when (save cfg) $ saveQuery cfg q + configSW cfg solveNative cfg q + +configSW :: (NFData a, Fixpoint a) => Config -> Solver a -> Solver a +configSW cfg + | multicore cfg = solveParWith + | otherwise = solveSeqWith + +--------------------------------------------------------------------------- +readFInfo :: FilePath -> IO (FInfo ()) +--------------------------------------------------------------------------- +readFInfo f = fixFileName <$> act + where + fixFileName q = q {fileName = f} + act + | isBinary f = readBinFq f + | otherwise = readFq f + +readFq :: FilePath -> IO (FInfo ()) +readFq file = do + str <- readFile file + let q = {-# SCC "parsefq" #-} rr' file str :: FInfo () + return q + +readBinFq :: FilePath -> IO (FInfo ()) +readBinFq file = {-# SCC "parseBFq" #-} decodeFile file + +--------------------------------------------------------------------------- +-- | Solve in parallel after partitioning an FInfo to indepdendant parts +--------------------------------------------------------------------------- +solveSeqWith :: (Fixpoint a) => Solver a -> Solver a +solveSeqWith s c fi0 = withProgressFI fi $ s c fi + where + fi = slice fi0 + + +--------------------------------------------------------------------------- +-- | Solve in parallel after partitioning an FInfo to indepdendant parts +--------------------------------------------------------------------------- +solveParWith :: (Fixpoint a) => Solver a -> Solver a +--------------------------------------------------------------------------- +solveParWith s c fi0 = do + -- putStrLn "Using Parallel Solver \n" + let fi = slice fi0 + withProgressFI fi $ do + mci <- mcInfo c + let (_, fis) = partition' (Just mci) fi + writeLoud $ "Number of partitions : " ++ show (length fis) + writeLoud $ "number of cores : " ++ show (cores c) + writeLoud $ "minimum part size : " ++ show (minPartSize c) + writeLoud $ "maximum part size : " ++ show (maxPartSize c) + case fis of + [] -> errorstar "partiton' returned empty list!" + [onePart] -> s c onePart + _ -> inParallelUsing (s c) fis + +------------------------------------------------------------------------------- +-- | Solve a list of FInfos using the provided solver function in parallel +------------------------------------------------------------------------------- +inParallelUsing :: (a -> IO (Result b)) -> [a] -> IO (Result b) +------------------------------------------------------------------------------- +inParallelUsing f xs = do + setNumCapabilities (length xs) + rs <- asyncMapM f xs + return $ mconcat rs + +--------------------------------------------------------------------------- +-- | Native Haskell Solver ------------------------------------------------ +--------------------------------------------------------------------------- +solveNative, solveNative' :: (NFData a, Fixpoint a) => Solver a +--------------------------------------------------------------------------- +solveNative !cfg !fi0 = (solveNative' cfg fi0) + `catch` + (return . result) + +result :: Error -> Result a +result e = Result (Crash [] msg) mempty + where + msg = showpp e + +solveNative' !cfg !fi0 = do + -- writeLoud $ "fq file in: \n" ++ render (toFixpoint cfg fi) + -- rnf fi0 `seq` donePhase Loud "Read Constraints" + -- let qs = quals fi0 + -- whenLoud $ print qs + let fi1 = fi0 { quals = remakeQual <$> quals fi0 } + -- whenLoud $ putStrLn $ showFix (quals fi1) + let si0 = {-# SCC "convertFormat" #-} convertFormat fi1 + -- writeLoud $ "fq file after format convert: \n" ++ render (toFixpoint cfg si0) + -- rnf si0 `seq` donePhase Loud "Format Conversion" + let si1 = either die id $ {-# SCC "validate" #-} sanitize $!! si0 + -- writeLoud $ "fq file after validate: \n" ++ render (toFixpoint cfg si1) + -- rnf si1 `seq` donePhase Loud "Validated Constraints" + graphStatistics cfg si1 + let si2 = {-# SCC "wfcUniqify" #-} wfcUniqify $!! si1 + let si3 = {-# SCC "renameAll" #-} renameAll $!! si2 + -- rnf si2 `seq` donePhase Loud "Uniqify" + (s0, si4) <- {-# SCC "elim" #-} elim cfg $!! si3 + -- writeLoud $ "About to solve: \n" ++ render (toFixpoint cfg si4) + res <- {-# SCC "Sol.solve" #-} Sol.solve cfg s0 $!! si4 + -- rnf soln `seq` donePhase Loud "Solve2" + --let stat = resStatus res + saveSolution cfg res + -- when (save cfg) $ saveSolution cfg + -- writeLoud $ "\nSolution:\n" ++ showpp (resSolution res) + -- colorStrLn (colorResult stat) (show stat) + return res + + +elim :: (Fixpoint a) => Config -> SInfo a -> IO (Solution, SInfo a) +elim cfg fi + | eliminate cfg = do + let (s0, fi') = E.eliminate fi + writeLoud $ "fq file after eliminate: \n" ++ render (toFixpoint cfg fi') + -- elimSolGraph cfg s0 + donePhase Loud "Eliminate" + writeLoud $ "Solution after eliminate: \n" ++ showpp s0 -- toFixpoint cfg fi') + -- donePhase Loud "DonePrint" + return (s0, fi') + | otherwise = + return (mempty, fi) + +remakeQual :: Qualifier -> Qualifier +remakeQual q = {- traceShow msg $ -} mkQual (q_name q) (q_params q) (q_body q) (q_pos q) +-- where +-- msg = "REMAKEQUAL: " ++ show q + +--------------------------------------------------------------------------- +-- | Extract ExitCode from Solver Result ---------------------------------- +--------------------------------------------------------------------------- +resultExit :: FixResult a -> ExitCode +--------------------------------------------------------------------------- +resultExit Safe = ExitSuccess +resultExit (Unsafe _) = ExitFailure 1 +resultExit _ = ExitFailure 2 + +--------------------------------------------------------------------------- +-- | Parse External Qualifiers -------------------------------------------- +--------------------------------------------------------------------------- +parseFInfo :: [FilePath] -> IO (FInfo a) -- [Qualifier] +--------------------------------------------------------------------------- +parseFInfo fs = mconcat <$> mapM parseFI fs + +parseFI :: FilePath -> IO (FInfo a) --[Qualifier] +parseFI f = do + str <- readFile f + let fi = rr' f str :: FInfo () + return $ mempty { quals = quals fi + , lits = lits fi } + +saveSolution :: Config -> Result a -> IO () +saveSolution cfg res = when (save cfg) $ do + let f = queryFile Out cfg + putStrLn $ "Saving Solution: " ++ f ++ "\n" + ensurePath f + writeFile f $ "\nSolution:\n" ++ showpp (resSolution res) + +--------------------------------------------------------------------------- +-- | Initialize Progress Bar +--------------------------------------------------------------------------- +withProgressFI :: FInfo a -> IO b -> IO b +--------------------------------------------------------------------------- +withProgressFI = withProgress . fromIntegral . gSccs . cGraph diff --git a/src/Language/Fixpoint/Solver/Deps.hs b/src/Language/Fixpoint/Solver/Deps.hs deleted file mode 100644 --- a/src/Language/Fixpoint/Solver/Deps.hs +++ /dev/null @@ -1,96 +0,0 @@ -module Language.Fixpoint.Solver.Deps - ( -- * Dummy Solver for Debugging Kuts - solve - - -- * KV-Dependencies - , deps - , Deps (..) - - -- * Reads and Writes of Constraints - , lhsKVars - , rhsKVars - ) where - -import Language.Fixpoint.Config -import Language.Fixpoint.Misc (groupList) -import Language.Fixpoint.Names (nonSymbol) -import qualified Language.Fixpoint.Types as F - -import qualified Language.Fixpoint.Visitor as V -import qualified Data.HashMap.Strict as M -import qualified Data.HashSet as S -import qualified Data.Graph as G - -import Control.Monad.State - -data Deps = Deps { depCuts :: ![F.KVar] - , depNonCuts :: ![F.KVar] - } - deriving (Eq, Ord, Show) - - --------------------------------------------------------------- --- | Dummy just for debugging -------------------------------- --------------------------------------------------------------- -solve :: Config -> F.FInfo a -> IO (F.FixResult a) --------------------------------------------------------------- -solve _ fi = do - let d = deps fi - print "(begin cuts debug)" - print "Cuts:" - print (depCuts d) - print "Non-cuts:" - print (depNonCuts d) - print "(end cuts debug)" - return F.Safe - - --------------------------------------------------------------- --- | Compute Dependencies and Cuts --------------------------- --------------------------------------------------------------- - -deps :: F.FInfo a -> Deps -deps finfo = sccsToDeps sccs (F.kuts finfo) - where - bs = F.bs finfo - subCs = M.elems (F.cm finfo) - edges = concatMap (subcEdges bs) subCs - graph = [(k,k,ks) | (k, ks) <- groupList edges] - sccs = G.stronglyConnCompR graph - -sccsToDeps :: [G.SCC (F.KVar, F.KVar, [F.KVar])] -> F.Kuts -> Deps -sccsToDeps xs ks = execState (mapM_ (bar ks) xs) (Deps [] []) - where - bar :: F.Kuts -> G.SCC (F.KVar, F.KVar,[F.KVar]) -> State Deps () - bar _ (G.AcyclicSCC (v,_,_)) = do ds <- get - put ds {depNonCuts = v : depNonCuts ds} - bar ks (G.CyclicSCC vs) = do let (v,vs') = chooseCut vs ks - ds <- get - put ds {depCuts = v : depCuts ds} - mapM_ (bar ks) (G.stronglyConnCompR vs') - -chooseCut :: [(F.KVar, F.KVar, [F.KVar])] -> F.Kuts -> (F.KVar, [(F.KVar, F.KVar,[F.KVar])]) -chooseCut vs (F.KS ks) = (v, [x | x@(u,_,_) <- vs, u /= v]) - where - vs' = [x | (x,_,_) <- vs] - is = S.intersection (S.fromList vs') ks - v = head $ if S.null is then vs' else S.toList is - -subcEdges :: F.BindEnv -> F.SubC a -> [(F.KVar, F.KVar)] -subcEdges bs c = [(k1, k2) | k1 <- lhsKVars bs c - , k2 <- rhsKVars c ] - ++ [(k2, F.KV nonSymbol) | k2 <- rhsKVars c] --- this nonSymbol hack is one way to prevent nodes with potential --- outdegree 0 from getting pruned by stronglyConnCompR - -lhsKVars :: F.BindEnv -> F.SubC a -> [F.KVar] -lhsKVars bs c = envKVs ++ lhsKVs - where - envKVs = V.envKVars bs c - lhsKVs = V.kvars $ F.lhsCs c - -rhsKVars :: F.SubC a -> [F.KVar] -rhsKVars = V.kvars . F.rhsCs - - ---------------------------------------------------------------- diff --git a/src/Language/Fixpoint/Solver/Eliminate.hs b/src/Language/Fixpoint/Solver/Eliminate.hs --- a/src/Language/Fixpoint/Solver/Eliminate.hs +++ b/src/Language/Fixpoint/Solver/Eliminate.hs @@ -1,113 +1,131 @@ -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE BangPatterns #-} -module Language.Fixpoint.Solver.Eliminate - (eliminateAll, elimKVar, findWfC) where +module Language.Fixpoint.Solver.Eliminate (eliminate) where -import Language.Fixpoint.Types -import qualified Language.Fixpoint.Solver.Deps as D -import Language.Fixpoint.Visitor (kvars, mapKVars') -import Language.Fixpoint.Names (existSymbol) -import Language.Fixpoint.Misc (errorstar) +import qualified Data.HashSet as S +import qualified Data.HashMap.Strict as M -import qualified Data.HashMap.Strict as M -import Data.List (partition, (\\)) -import Data.Foldable (foldlM) -import Control.Monad.State (get, put, runState, evalState, State) +import Language.Fixpoint.Types +import Language.Fixpoint.Types.Visitor (kvars, isConcC) +import Language.Fixpoint.Partition (depCuts, depNonCuts, deps) +import Language.Fixpoint.Misc (safeLookup, group, errorstar) +-------------------------------------------------------------------------------- +eliminate :: SInfo a -> (Solution, SInfo a) +-------------------------------------------------------------------------------- +eliminate si = ( sHyp, si' ) + where + sHyp = solFromList [] kHyps + si' = cutSInfo kI cKs si + kHyps = nonCutHyps kI nKs si + kI = kIndex si + (cKs,nKs) = kutVars si --------------------------------------------------------------- -eliminateAll :: FInfo a -> FInfo a -eliminateAll fi = evalState (foldlM eliminate fi nonCuts) 0 +kutVars :: SInfo a -> (S.HashSet KVar, S.HashSet KVar) +kutVars si = (depCuts ds, depNonCuts ds) where - nonCuts = D.depNonCuts $ D.deps fi --------------------------------------------------------------- + ds = deps si +-------------------------------------------------------------------------------- +-- | Map each `KVar` to the list of constraints on which it appears on RHS +-------------------------------------------------------------------------------- +type KIndex = M.HashMap KVar [Integer] -class Elimable a where - elimKVar :: ((KVar, Subst) -> Maybe Pred) -> a -> a +-------------------------------------------------------------------------------- +kIndex :: SInfo a -> KIndex +-------------------------------------------------------------------------------- +kIndex si = group [(k, i) | (i, c) <- iCs, k <- rkvars c] + where + iCs = M.toList (cm si) + rkvars = kvars . crhs -instance Elimable (SubC a) where - elimKVar f x = x { slhs = elimKVar f (slhs x) - , srhs = elimKVar f (srhs x) - } +cutSInfo :: KIndex -> S.HashSet KVar -> SInfo a -> SInfo a +cutSInfo kI cKs si = si { ws = ws', cm = cm' } + where + ws' = M.filterWithKey (\k _ -> S.member k cKs) (ws si) + cm' = M.filterWithKey (\i c -> S.member i cs || isConcC c) (cm si) + cs = S.fromList (concatMap kCs cKs) + kCs k = M.lookupDefault [] k kI -instance Elimable SortedReft where - elimKVar f x = x { sr_reft = mapKVars' f (sr_reft x) } +nonCutHyps :: KIndex -> S.HashSet KVar -> SInfo a -> [(KVar, Hyp)] +nonCutHyps kI nKs si = [ (k, nonCutHyp kI si k) | k <- S.toList nKs ] -instance Elimable (FInfo a) where - elimKVar f x = x { cm = M.map (elimKVar f) (cm x) - , bs = elimKVar f (bs x) - } +nonCutHyp :: KIndex -> SInfo a -> KVar -> Hyp +nonCutHyp kI si k = nonCutCube <$> cs + where + cs = getSubC si <$> M.lookupDefault [] k kI -instance Elimable BindEnv where - elimKVar f = mapBindEnv (\(sym, sr) -> (sym, elimKVar f sr)) +nonCutCube :: SimpC a -> Cube +nonCutCube c = Cube (senv c) (rhsSubst c) +rhsSubst :: SimpC a -> Subst +rhsSubst = rsu . crhs + where + rsu (PKVar _ su) = su + rsu _ = errorstar "Eliminate.rhsSubst called on bad input" -eliminate :: FInfo a -> KVar -> State Integer (FInfo a) -eliminate fi kv = do - let relevantSubCs = M.filter ( elem kv . D.rhsKVars) (cm fi) - let remainingSubCs = M.filter (notElem kv . D.rhsKVars) (cm fi) - let (kvWfC, remainingWs) = findWfC kv (ws fi) - foo <- mapM (extractPred kvWfC (bs fi)) (M.elems relevantSubCs) - let orPred = POr $ map fst foo - let symSrtList = concatMap snd foo - let symSReftList = [(sym, trueSortedReft srt) | (sym, srt) <- symSrtList] - let (ids, be) = insertsBindEnv symSReftList $ bs fi - let newSubCs = M.map (\s -> s { senv = insertsIBindEnv ids (senv s)}) remainingSubCs - let go (k, _) = if kv == k then Just orPred else Nothing - return $ elimKVar go (fi { cm = newSubCs , ws = remainingWs , bs = be }) +getSubC :: SInfo a -> Integer -> SimpC a +getSubC si i = safeLookup msg i (cm si) + where + msg = "getSubC: " ++ show i -insertsBindEnv :: [(Symbol, SortedReft)] -> BindEnv -> ([BindId], BindEnv) -insertsBindEnv = runState . mapM go +-------------------------------------------------------------------------------- +{- +eliminateAll :: SInfo a -> (Solution, SInfo a) +eliminateAll !si = foldl' eliminate (mempty, si) nonCuts where - go (sym, srft) = do be <- get - let (id, be') = insertBindEnv sym srft be - put be' - return id + nonCuts = depNonCuts $ deps si -findWfC :: KVar -> [WfC a] -> (WfC a, [WfC a]) -findWfC kv ws = (w', ws') +eliminate :: (Solution, SInfo a) -> KVar -> (Solution, SInfo a) +eliminate (!s, !si) k = (solInsert k (mkJVar orPred) s, si') where - (w, ws') = partition (elem kv . kvars . sr_reft . wrft) ws - w' | [x] <- w = x - | otherwise = errorstar $ (show kv) ++ " needs exactly one wf constraint" + si' = si { cm = nokCs , ws = M.delete k $ ws si } + kCs = M.filter ( elem k . kvars . crhs) (cm si) -- with k in RHS (SLOW!) + nokCs = M.filter (notElem k . kvars . crhs) (cm si) -- without k in RHS (SLOW!) + kW = (ws si) M.! k + kDom = domain (bs si) kW + orPred = POr $!! extractPred kDom (bs si) <$> M.elems kCs -extractPred :: WfC a -> BindEnv -> SubC a -> State Integer (Pred, [(Symbol, Sort)]) -extractPred wfc be subC = do foo <- mapM renameVar vars - let (bs, subs) = unzip foo - return (subst (mkSubst subs) finalPred, bs) +extractPred :: [Symbol] -> BindEnv -> SimpC a -> Expr +extractPred kDom be sc = renameQuantified (subcId sc) kSol where - wfcIBinds = elemsIBindEnv $ wenv wfc - subcIBinds = elemsIBindEnv $ senv subC - unmatchedIBinds = subcIBinds \\ wfcIBinds - unmatchedIBindEnv = insertsIBindEnv unmatchedIBinds emptyIBindEnv - unmatchedBindings = envCs be unmatchedIBindEnv - lhs = slhs subC - (vars, prList) = baz $ (reftBind $ sr_reft lhs, lhs) : unmatchedBindings + kSol = PExist xts $ PAnd (lhsPreds ++ suPreds) + xts = filter (nonFunction be . fst) yts + yts = second sr_sort <$> env + env = clhs be sc + lhsPreds = bindPred <$> env + suPreds = substPreds kDom $ crhs sc - suPreds = substPreds (domain be wfc) $ reftPred $ sr_reft $ srhs subC - finalPred = PAnd $ prList ++ suPreds +-- x:{v:int|v=10} -> (x=10) +bindPred :: (Symbol, SortedReft) -> Expr +bindPred (x, sr) = p `subst1`(v, eVar x) + where + v = reftBind r + r = sr_reft sr + p = reftPred r --- on rhs, $k0[v:=e1][x:=e2] -> [v = e1, x = e2] -substPreds :: [Symbol] -> Pred -> [Pred] -substPreds dom (PKVar _ (Su subs)) = [PAtom Eq (eVar sym) expr | (sym, expr) <- subs , sym `elem` dom] +-- k0[v:=e1][x:=e2] -> [v = e1, x = e2] +substPreds :: [Symbol] -> Expr -> [Expr] +substPreds dom (PKVar _ (Su subs)) = [PAtom Eq (eVar x) e | (x, e) <- M.toList subs , x `elem` dom] +substPreds _ _ = errorstar "Eliminate.substPreds called on bad input" -domain :: BindEnv -> WfC a -> [Symbol] -domain be wfc = (reftBind $ sr_reft $ wrft wfc) : (map fst $ envCs be $ wenv wfc) +-- SLOW! +nonFunction :: BindEnv -> Symbol -> Bool +nonFunction be sym = sym `notElem` funcs + where + funcs = [x | (_, x, sr) <- bindEnvToList be + , isFunctionSortedReft sr] -renameVar :: (Symbol, Sort) -> State Integer ((Symbol, Sort), (Symbol, Expr)) -renameVar (sym, srt) = do n <- get - let sym' = existSymbol sym n - put (n+1) - return ((sym', srt), (sym, eVar sym')) +renameQuantified :: Integer -> Expr -> Expr +renameQuantified i (PExist bs p) = PExist bs' p' + where + su = substFromQBinds i bs + bs' = first (subst su) <$> bs + p' = subst su p +renameQuantified _ _ = errorstar "Eliminate.renameQuantified called on bad input" --- [ x:{v:int|v=10} , y:{v:int|v=20} ] -> [x:int, y:int], [(x=10), (y=20)] -baz :: [(Symbol, SortedReft)] -> ([(Symbol,Sort)],[Pred]) -baz = unzip . map blah +substFromQBinds :: Integer -> [(Symbol, Sort)] -> Subst +substFromQBinds i bs = Su $ M.fromList [(s, EVar $ existSymbol s i) | s <- fst <$> bs] -blah :: (Symbol, SortedReft) -> ((Symbol,Sort), Pred) -blah (sym, sr) = ((sym, sr_sort sr), subst1 (reftPred reft) sub) - where - reft = sr_reft sr - sub = ((reftBind reft), (eVar sym)) +-} diff --git a/src/Language/Fixpoint/Solver/Graph.hs b/src/Language/Fixpoint/Solver/Graph.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fixpoint/Solver/Graph.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE OverloadedStrings #-} + +module Language.Fixpoint.Solver.Graph ( + -- * Remove Constraints that don't affect Targets + slice + + -- * Predicate describing Targets + , isTarget + + -- * Compute Ranks / SCCs + , graphRanks + + -- * Compute Kvar dependencies + , cGraph, gSccs + + -- * Kvars written and read by a constraint + , kvWriteBy, kvReadBy + ) where + + +-- import Debug.Trace (trace) +import Prelude hiding (init) +import Language.Fixpoint.Types.Visitor (rhsKVars, envKVars, kvars, isConcC) +import Language.Fixpoint.Misc (errorstar, fst3, sortNub, group) +import qualified Language.Fixpoint.Types as F +import Language.Fixpoint.Solver.Types +import qualified Data.HashMap.Strict as M +import qualified Data.List as L +import Data.Maybe (fromMaybe) +import qualified Data.HashSet as S +import Data.Graph (transposeG, graphFromEdges, dfs, scc, Graph, Vertex) +import Data.Tree (flatten) + +--------------------------------------------------------------------------- +-- | Compute constraints that transitively affect target constraints, +-- and delete everything else from F.SInfo a +--------------------------------------------------------------------------- +slice :: (F.TaggedC c a) => F.GInfo c a -> F.GInfo c a +--------------------------------------------------------------------------- +slice fi = fi { F.cm = cm' + , F.ws = ws' } + where + cm' = M.filterWithKey inC (F.cm fi) + ws' = M.filterWithKey inW (F.ws fi) + ks = sliceKVars fi sl + is = S.fromList (slKVarCs sl ++ slConcCs sl) + sl = mkSlice fi + inC i _ = S.member i is + inW k _ = S.member k ks + +sliceKVars :: (F.TaggedC c a) => F.GInfo c a -> Slice -> S.HashSet F.KVar +sliceKVars fi sl = S.fromList $ concatMap (subcKVars be) cs + where + cs = lookupCMap cm <$> slKVarCs sl ++ slConcCs sl + be = F.bs fi + cm = F.cm fi + +subcKVars :: (F.TaggedC c a) => F.BindEnv -> c a -> [F.KVar] +subcKVars be c = envKVars be c ++ rhsKVars c + +--------------------------------------------------------------------------- +mkSlice :: (F.TaggedC c a) => F.GInfo c a -> Slice +--------------------------------------------------------------------------- +mkSlice fi = mkSlice_ (F.cm fi) g' es v2i i2v + where + g' = transposeG g -- "inverse" of g (reverse the dep-edges) + (g, vf, cf) = graphFromEdges es + es = gEdges $ cGraph fi + v2i = fst3 . vf + i2v i = fromMaybe (errU i) $ cf i + errU i = errorstar $ "graphSlice: nknown constraint " ++ show i + + +mkSlice_ cm g' es v2i i2v = Slice { slKVarCs = kvarCs + , slConcCs = concCs + , slEdges = sliceEdges kvarCs es + } + where + -- n = length kvarCs + concCs = [ i | (i, c) <- M.toList cm, isTarget c ] + kvarCs = v2i <$> reachVs + rootVs = i2v <$> concCs + reachVs = concatMap flatten $ dfs g' rootVs + +sliceEdges :: [CId] -> [DepEdge] -> [DepEdge] +sliceEdges is es = [ (i, i, filter inSlice js) | (i, _, js) <- es, inSlice i ] + where + inSlice i = M.member i im + im = M.fromList $ (, ()) <$> is + +-- | DO NOT DELETE! +-- sliceCSucc :: Slice -> CSucc +-- sliceCSucc sl = \i -> M.lookupDefault [] i im + -- where + -- im = M.fromList [(i, is) | (i,_,is) <- slEdges sl] + +--------------------------------------------------------------------------- +-- | Dependencies --------------------------------------------------------- +--------------------------------------------------------------------------- +kvSucc :: (F.TaggedC c a) => F.GInfo c a -> CSucc +--------------------------------------------------------------------------- +kvSucc fi = succs cm rdBy + where + rdBy = kvReadBy fi + cm = F.cm fi + +succs :: (F.TaggedC c a) => CMap (c a) -> KVRead -> CSucc +succs cm rdBy i = sortNub $ concatMap kvReads iKs + where + iKs = kvWriteBy cm i + kvReads k = M.lookupDefault [] k rdBy + +--------------------------------------------------------------------------- +kvWriteBy :: (F.TaggedC c a) => CMap (c a) -> CId -> [F.KVar] +--------------------------------------------------------------------------- +kvWriteBy cm = kvars . F.crhs . lookupCMap cm + +--------------------------------------------------------------------------- +kvReadBy :: (F.TaggedC c a) => F.GInfo c a -> KVRead +--------------------------------------------------------------------------- +kvReadBy fi = group [ (k, i) | (i, ci) <- M.toList cm + , k <- envKVars bs ci] + where + cm = F.cm fi + bs = F.bs fi + +--------------------------------------------------------------------------- +isTarget :: (F.TaggedC c a) => c a -> Bool +--------------------------------------------------------------------------- +isTarget c = isConcC c && isNonTriv c + where + isNonTriv = not . F.isTautoPred . F.crhs + + +--------------------------------------------------------------------------- +-- | Constraint Graph ----------------------------------------------------- +--------------------------------------------------------------------------- +cGraph :: (F.TaggedC c a) => F.GInfo c a -> CGraph +--------------------------------------------------------------------------- +cGraph fi = CGraph { gEdges = es + , gRanks = outRs + , gSucc = next + , gSccs = length sccs } + where + es = [(i, i, next i) | i <- M.keys $ F.cm fi] + next = kvSucc fi + (g, vf, _) = graphFromEdges es + (outRs, sccs) = graphRanks g vf + +--------------------------------------------------------------------------- +-- | Ranks from Graph ----------------------------------------------------- +--------------------------------------------------------------------------- +graphRanks :: Graph -> (Vertex -> DepEdge) -> (CMap Int, [[Vertex]]) +--------------------------------------------------------------------------- +graphRanks g vf = (M.fromList irs, sccs) + where + irs = [(v2i v, r) | (r, vs) <- rvss, v <- vs ] + rvss = zip [0..] sccs + sccs = L.reverse $ map flatten $ scc g + v2i = fst3 . vf diff --git a/src/Language/Fixpoint/Solver/Monad.hs b/src/Language/Fixpoint/Solver/Monad.hs --- a/src/Language/Fixpoint/Solver/Monad.hs +++ b/src/Language/Fixpoint/Solver/Monad.hs @@ -1,3 +1,7 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} + -- | This is a wrapper around IO that permits SMT queries module Language.Fixpoint.Solver.Monad @@ -12,43 +16,90 @@ -- * SMT Query , filterValid + , checkSat, smtEnablrmbqi -- * Debug + , Stats , tickIter - + , stats + , numIter ) where -import Language.Fixpoint.Config (Config, inFile, solver) +import Control.DeepSeq +import GHC.Generics +import Language.Fixpoint.Utils.Progress +import Language.Fixpoint.Misc (groupList) +import qualified Language.Fixpoint.Types.Config as C +import Language.Fixpoint.Types.Config (Config, solver, linear, SMTSolver(Z3)) import qualified Language.Fixpoint.Types as F -import qualified Language.Fixpoint.Errors as E +import Language.Fixpoint.Types (pprint) +import qualified Language.Fixpoint.Types.Errors as E +import qualified Language.Fixpoint.Smt.Theories as Thy +import Language.Fixpoint.Smt.Serialize (initSMTEnv) +import Language.Fixpoint.Types.PrettyPrint () import Language.Fixpoint.Smt.Interface import Language.Fixpoint.Solver.Validate -import Language.Fixpoint.Solver.Solution -import Data.Maybe (catMaybes) -import qualified Data.HashMap.Strict as M -import Control.Applicative ((<$>)) +-- import Language.Fixpoint.Solver.Solution +import Data.Maybe (isJust, catMaybes) +import Text.PrettyPrint.HughesPJ (text) import Control.Monad.State.Strict +import qualified Data.HashMap.Strict as M +import Control.Exception.Base (bracket) + --------------------------------------------------------------------------- -- | Solver Monadic API --------------------------------------------------- --------------------------------------------------------------------------- type SolveM = StateT SolverState IO -data SolverState = SS { ssCtx :: !Context - , ssBinds :: !F.BindEnv - , ssIter :: !Int +data SolverState = SS { ssCtx :: !Context -- ^ SMT Solver Context + , ssBinds :: !F.BindEnv -- ^ All variables and types + , ssStats :: !Stats -- ^ Solver Statistics } +data Stats = Stats { numCstr :: !Int -- ^ # Horn Constraints + , numIter :: !Int -- ^ # Refine Iterations + , numBrkt :: !Int -- ^ # smtBracket calls (push/pop) + , numChck :: !Int -- ^ # smtCheckUnsat calls + , numVald :: !Int -- ^ # times SMT said RHS Valid + } deriving (Show, Generic) + +instance NFData Stats + +stats0 :: F.GInfo c b -> Stats +stats0 fi = Stats nCs 0 0 0 0 + where + nCs = M.size $ F.cm fi + +instance F.PTable Stats where + ptable s = F.DocTable [ (text "# Constraints" , pprint (numCstr s)) + , (text "# Refine Iterations" , pprint (numIter s)) + , (text "# SMT Brackets" , pprint (numBrkt s)) + , (text "# SMT Queries (Valid)" , pprint (numVald s)) + , (text "# SMT Queries (Total)" , pprint (numChck s)) + ] + --------------------------------------------------------------------------- -runSolverM :: Config -> F.FInfo b -> SolveM a -> IO a +runSolverM :: Config -> F.GInfo c b -> Int -> SolveM a -> IO a --------------------------------------------------------------------------- -runSolverM cfg fi act = do - ctx <- makeContext (solver cfg) (inFile cfg) - fst <$> runStateT (declare fi >> act) (SS ctx be 0) +runSolverM cfg fi' _ act = do + bracket acquire release $ \ctx -> do + res <- runStateT (declareInitEnv >> declare fi >> act) (SS ctx be $ stats0 fi) + smtWrite ctx "(exit)" + return $ fst res + where - be = F.bs fi + acquire = makeContextWithSEnv lar (solver cfg) file env + release = cleanupContext + be = F.bs fi + file = F.fileName fi -- (inFile cfg) + env = F.fromListSEnv ((F.toListSEnv $ F.lits fi) ++ binds) + binds = [(x, F.sr_sort t) | (_, x, t) <- F.bindEnvToList $ F.bs fi] + -- only linear arithmentic when: linear flag is on or solver /= Z3 + lar = linear cfg || Z3 /= solver cfg + fi = fi' {F.allowHO = C.allowHO cfg} --------------------------------------------------------------------------- getBinds :: SolveM F.BindEnv @@ -58,17 +109,19 @@ --------------------------------------------------------------------------- getIter :: SolveM Int --------------------------------------------------------------------------- -getIter = ssIter <$> get +getIter = numIter . ssStats <$> get --------------------------------------------------------------------------- -incIter :: SolveM () +incIter, incBrkt :: SolveM () --------------------------------------------------------------------------- -incIter = modify $ \s -> s {ssIter = 1 + ssIter s} +incIter = modifyStats $ \s -> s {numIter = 1 + numIter s} +incBrkt = modifyStats $ \s -> s {numBrkt = 1 + numBrkt s} --------------------------------------------------------------------------- -tickIter :: SolveM Int +incChck, incVald :: Int -> SolveM () --------------------------------------------------------------------------- -tickIter = incIter >> getIter +incChck n = modifyStats $ \s -> s {numChck = n + numChck s} +incVald n = modifyStats $ \s -> s {numVald = n + numVald s} withContext :: (Context -> IO a) -> SolveM a withContext k = (lift . k) =<< getContext @@ -76,18 +129,25 @@ getContext :: SolveM Context getContext = ssCtx <$> get +modifyStats :: (Stats -> Stats) -> SolveM () +modifyStats f = modify $ \s -> s { ssStats = f (ssStats s) } --------------------------------------------------------------------------- -- | SMT Interface -------------------------------------------------------- --------------------------------------------------------------------------- -filterValid :: F.Pred -> Cand a -> SolveM [a] +filterValid :: F.Expr -> F.Cand a -> SolveM [a] --------------------------------------------------------------------------- -filterValid p qs = - withContext $ \me -> - smtBracket me $ - filterValid_ p qs me +filterValid p qs = do + qs' <- withContext $ \me -> + smtBracket me $ + filterValid_ p qs me + -- stats + incBrkt + incChck (length qs) + incVald (length qs') + return qs' -filterValid_ :: F.Pred -> Cand a -> Context -> IO [a] +filterValid_ :: F.Expr -> F.Cand a -> Context -> IO [a] filterValid_ p qs me = catMaybes <$> do smtAssert me p forM qs $ \(q, x) -> @@ -96,16 +156,59 @@ valid <- smtCheckUnsat me return $ if valid then Just x else Nothing + +smtEnablrmbqi + = withContext $ \me -> + smtWrite me "(set-option :smt.mbqi true)" + + +checkSat :: F.Expr -> SolveM Bool +checkSat p + = withContext $ \me -> + smtBracket me $ + smtCheckSat me p + --------------------------------------------------------------------------- -declare :: F.FInfo a -> SolveM () +declare :: F.GInfo c a -> SolveM () --------------------------------------------------------------------------- -declare fi = withContext $ \me -> do - xts <- either E.die return $ declSymbols fi - forM_ xts $ uncurry $ smtDecl me +declareInitEnv :: SolveM () +declareInitEnv = withContext $ \me -> + forM_ (F.toListSEnv initSMTEnv) $ uncurry $ smtDecl me -declSymbols :: F.FInfo a -> Either E.Error [(F.Symbol, F.Sort)] +declare fi = withContext $ \me -> do + xts <- either E.die return $ declSymbols fi + let ess = declLiterals fi + forM_ xts $ uncurry $ smtDecl me + forM_ ess $ smtDistinct me + +declLiterals :: F.GInfo c a -> [[F.Expr]] +declLiterals fi | F.allowHO fi + = [es | (_, es) <- tess ] + where + tess = groupList [(t, F.expr x) | (x, t) <- F.toListSEnv $ F.lits fi, not (isThy x)] + isThy = isJust . Thy.smt2Symbol + +declLiterals fi + = [es | (_, es) <- tess ] + where + notFun = not . F.isFunctionSortedReft . (`F.RR` F.trueReft) + tess = groupList [(t, F.expr x) | (x, t) <- F.toListSEnv $ F.lits fi, notFun t] + +declSymbols :: F.GInfo c a -> Either E.Error [(F.Symbol, F.Sort)] declSymbols = fmap dropThy . symbolSorts where dropThy = filter (not . isThy . fst) - isThy = (`M.member` theorySymbols) + isThy = isJust . Thy.smt2Symbol +--------------------------------------------------------------------------- +stats :: SolveM Stats +--------------------------------------------------------------------------- +stats = ssStats <$> get + +--------------------------------------------------------------------------- +tickIter :: Bool -> SolveM Int +--------------------------------------------------------------------------- +tickIter newScc = progIter newScc >> incIter >> getIter + +progIter :: Bool -> SolveM () +progIter newScc = lift $ when newScc progressTick diff --git a/src/Language/Fixpoint/Solver/Solution.hs b/src/Language/Fixpoint/Solver/Solution.hs --- a/src/Language/Fixpoint/Solver/Solution.hs +++ b/src/Language/Fixpoint/Solver/Solution.hs @@ -1,77 +1,54 @@ -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE PatternGuards #-} module Language.Fixpoint.Solver.Solution - ( -- * Solutions and Results - Solution, Cand, EQual (..) - - -- * Types with Template/KVars - , Solvable (..) - - -- * Initial Solution - , init - - -- * Update Solution - , update + ( -- * Create and Update Solution + init, update -- * Lookup Solution - , lookup + , lhsPred + , noKvars + + -- * Debug + , solutionGraph ) where -import Control.Applicative ((<$>)) +import Control.Parallel.Strategies +import Control.Arrow (second) +import qualified Data.HashSet as S import qualified Data.HashMap.Strict as M import qualified Data.List as L -import Data.Maybe (maybeToList, isNothing) -- , fromMaybe) -import Language.Fixpoint.PrettyPrint -import Language.Fixpoint.Config -import Language.Fixpoint.Visitor as V -import qualified Language.Fixpoint.Sort as So +import Data.Maybe (maybeToList, isNothing) +import Data.Monoid ((<>)) +import Language.Fixpoint.Types.PrettyPrint () +import Language.Fixpoint.Types.Visitor as V +import qualified Language.Fixpoint.SortCheck as So import Language.Fixpoint.Misc -import qualified Language.Fixpoint.Types as F +import qualified Language.Fixpoint.Types as F +import Language.Fixpoint.Types.Constraints hiding (ws, bs) +import Language.Fixpoint.Types.Graphs import Prelude hiding (init, lookup) --- import Text.Printf (printf) ---------------------------------------------------------------------- --- | Types ---------------------------------------------------------- ---------------------------------------------------------------------- - -type Solution = Sol KBind -type Sol a = M.HashMap F.KVar a -type KBind = [EQual] -type Cand a = [(F.Pred, a)] - -lookup :: Solution -> F.KVar -> KBind -lookup s k = M.lookupDefault [] k s - ---------------------------------------------------------------------- --- | Expanded or Instantiated Qualifier ----------------------------- ---------------------------------------------------------------------- - -data EQual = EQL { eqQual :: !F.Qualifier - , eqPred :: !F.Pred - , eqArgs :: ![F.Expr] - } - deriving (Eq, Ord, Show) +-- DEBUG +-- import Text.Printf (printf) +-- import Debug.Trace (trace) -instance PPrint EQual where - pprint = pprint . eqPred +-------------------------------------------------------------------------------- +-- | Expanded or Instantiated Qualifier ---------------------------------------- +-------------------------------------------------------------------------------- -{- EQL :: q:_ -> p:_ -> ListX F.Expr {q_params q} -> _ @-} +-- mkJVar :: F.Expr -> QBind +-- mkJVar p = [F.EQL dummyQual p []] -eQual :: F.Qualifier -> [F.Symbol] -> EQual -eQual q xs = EQL q p es - where - p = F.subst su $ F.q_body q - su = F.mkSubst $ safeZip "eQual" qxs es - es = F.eVar <$> xs - qxs = fst <$> F.q_params q +-- dummyQual :: F.Qualifier +-- dummyQual = F.Q F.nonSymbol [] F.PFalse (F.dummyPos "") ------------------------------------------------------------------------- --- | Update Solution --------------------------------------------------- ------------------------------------------------------------------------- -update :: Solution -> [F.KVar] -> [(F.KVar, EQual)] -> (Bool, Solution) +-------------------------------------------------------------------------------- +-- | Update Solution ----------------------------------------------------------- +-------------------------------------------------------------------------------- +update :: Solution -> [F.KVar] -> [(F.KVar, F.EQual)] -> (Bool, Solution) ------------------------------------------------------------------------- update s ks kqs = {- tracepp msg -} (or bs, s') where @@ -79,151 +56,223 @@ (bs, s') = folds update1 s kqss -- msg = printf "ks = %s, s = %s" (showpp ks) (showpp s) +folds :: (a -> b -> (c, a)) -> a -> [b] -> ([c], a) +folds f b = L.foldl' step ([], b) + where + step (cs, acc) x = (c:cs, x') + where + (c, x') = f acc x -groupKs :: [F.KVar] -> [(F.KVar, EQual)] -> [(F.KVar, [EQual])] +groupKs :: [F.KVar] -> [(F.KVar, F.EQual)] -> [(F.KVar, QBind)] groupKs ks kqs = M.toList $ groupBase m0 kqs where m0 = M.fromList $ (,[]) <$> ks -update1 :: Solution -> (F.KVar, KBind) -> (Bool, Solution) -update1 s (k, qs) = (change, M.insert k qs s) +update1 :: Solution -> (F.KVar, QBind) -> (Bool, Solution) +update1 s (k, qs) = (change, solInsert k qs s) where - oldQs = lookup s k + oldQs = solLookup s k change = length oldQs /= length qs - -------------------------------------------------------------------- -- | Initial Solution (from Qualifiers and WF constraints) --------- -------------------------------------------------------------------- -init :: Config -> F.FInfo a -> Solution +init :: F.SInfo a -> Solution -------------------------------------------------------------------- -init _ fi = {- tracepp "init solution" -} s +init si = F.solFromList keqs [] -- (fromList keqs) M.empty where - s = L.foldl' (refine fi qs) s0 ws - s0 = M.empty - qs = F.quals fi - ws = F.ws fi + keqs = map (refine si qs) ws `using` parList rdeepseq + qs = F.quals si + ws = M.elems $ F.ws si -------------------------------------------------------------------- -refine :: F.FInfo a +refine :: F.SInfo a -> [F.Qualifier] - -> Solution -> F.WfC a - -> Solution + -> (F.KVar, QBind) -------------------------------------------------------------------- -refine fi qs s w = refineK env qs s (wfKvar w) +refine fi qs w = refineK env qs $ F.wrft w where - env = F.fromListSEnv $ F.envCs (F.bs fi) (F.wenv w) - + env = wenv <> genv + wenv = F.sr_sort <$> F.fromListSEnv (F.envCs (F.bs fi) (F.wenv w)) + genv = F.lits fi -refineK :: F.SEnv F.SortedReft - -> [F.Qualifier] - -> Solution - -> (F.Symbol, F.Sort, F.KVar) - -> Solution -refineK env qs s (v, t, k) = M.insert k eqs' s - where - eqs' = case M.lookup k s of - Nothing -> instK env v t qs - Just eqs -> [eq | eq <- eqs, okInst env v t eq] +refineK :: F.SEnv F.Sort -> [F.Qualifier] -> (F.Symbol, F.Sort, F.KVar) -> (F.KVar, QBind) +refineK env qs (v, t, k) = {- tracepp msg -} (k, eqs') + where + eqs = instK env v t qs + eqs' = filter (okInst env v t) eqs + -- msg = printf "refineK: k = %s, eqs = %s" (showpp k) (showpp eqs) -------------------------------------------------------------------- -instK :: F.SEnv F.SortedReft +instK :: F.SEnv F.Sort -> F.Symbol -> F.Sort -> [F.Qualifier] - -> [EQual] + -> QBind -------------------------------------------------------------------- instK env v t = unique . concatMap (instKQ env v t) where - unique qs = M.elems $ M.fromList [(eqPred q, q) | q <- qs ] + unique = L.nubBy ((. F.eqPred) . (==) . F.eqPred) -instKQ :: F.SEnv F.SortedReft +instKQ :: F.SEnv F.Sort -> F.Symbol -> F.Sort -> F.Qualifier - -> [EQual] + -> QBind instKQ env v t q - = do (su0, v0) <- candidates [(v, t)] qt - xs <- match xts [v0] (So.apply su0 <$> qts) - return $ eQual q (reverse xs) + = do (su0, v0) <- candidates senv [(t, [v])] qt + xs <- match senv tyss [v0] (So.apply su0 <$> qts) + return $ F.eQual q (reverse xs) where qt : qts = snd <$> F.q_params q - xts = instCands env + tyss = instCands env + senv = (`F.lookupSEnvWithDistance` env) -instCands :: F.SEnv F.SortedReft -> [(F.Symbol, F.Sort)] -instCands = filter isOk . F.toListSEnv . fmap F.sr_sort +instCands :: F.SEnv F.Sort -> [(F.Sort, [F.Symbol])] +instCands env = filter isOk tyss where - isOk = isNothing . F.functionSort . snd + tyss = groupList [(t, x) | (x, t) <- xts] + isOk = isNothing . F.functionSort . fst + xts = F.toListSEnv env -match :: [(F.Symbol, F.Sort)] -> [F.Symbol] -> [F.Sort] -> [[F.Symbol]] -match xts xs (t : ts) - = do (su, x) <- candidates xts t - match xts (x : xs) (So.apply su <$> ts) -match _ xs [] +match :: So.Env -> [(F.Sort, [F.Symbol])] -> [F.Symbol] -> [F.Sort] -> [[F.Symbol]] +match env tyss xs (t : ts) + = do (su, x) <- candidates env tyss t + match env tyss (x : xs) (So.apply su <$> ts) +match _ _ xs [] = return xs +-------------------------------------------------------------------------------- +candidates :: So.Env -> [(F.Sort, [F.Symbol])] -> F.Sort -> [(So.TVSubst, F.Symbol)] +-------------------------------------------------------------------------------- +candidates env tyss tx + = [(su, y) | (t, ys) <- tyss + , su <- maybeToList $ So.unifyFast mono env tx t + , y <- ys ] + where + mono = So.isMono tx ----------------------------------------------------------------------- -candidates :: [(F.Symbol, F.Sort)] -> F.Sort -> [(So.TVSubst, F.Symbol)] +okInst :: F.SEnv F.Sort -> F.Symbol -> F.Sort -> F.EQual -> Bool ----------------------------------------------------------------------- -candidates xts t' - = [(su, x) | (x, t) <- xts, su <- maybeToList $ So.unify t' t] +okInst env v t eq = isNothing tc + where + sr = F.RR t (F.Reft (v, p)) + p = F.eqPred eq + tc = So.checkSorted env sr ------------------------------------------------------------------------ -wfKvar :: F.WfC a -> (F.Symbol, F.Sort, F.KVar) ------------------------------------------------------------------------ -wfKvar w@(F.WfC {F.wrft = sr}) - | F.Reft (v, F.Refa (F.PKVar k su)) <- F.sr_reft sr - , F.isEmptySubst su = (v, F.sr_sort sr, k) - | otherwise = errorstar $ "wfKvar: malformed wfC " ++ show (F.wid w) ------------------------------------------------------------------------ -okInst :: F.SEnv F.SortedReft -> F.Symbol -> F.Sort -> EQual -> Bool ------------------------------------------------------------------------ -okInst env v t eq = isNothing $ So.checkSortedReftFull env sr +-------------------------------------------------------------------------------- +-- | Predicate corresponding to LHS of constraint in current solution +-------------------------------------------------------------------------------- +lhsPred :: F.BindEnv -> F.Solution -> F.SimpC a -> F.Expr +-------------------------------------------------------------------------------- +lhsPred be s c = {- F.tracepp msg $ -} apply g s bs where - sr = F.RR t (F.Reft (v, F.Refa (eqPred eq))) + g = (ci, be, bs) + bs = F.senv c + ci = sid c + -- msg = "LhsPred for id = " ++ show (sid c) ---------------------------------------------------------------------- --- | Apply Solution ------------------------------------------------- ---------------------------------------------------------------------- +type Cid = Maybe Integer +type CombinedEnv = (Cid, F.BindEnv, F.IBindEnv) -class Solvable a where - apply :: Solution -> a -> F.Pred +apply :: CombinedEnv -> Solution -> F.IBindEnv -> F.Expr +apply g s bs = F.pAnd (apply1 g s <$> F.elemsIBindEnv bs) -instance Solvable EQual where - apply _ = eqPred -instance Solvable F.KVar where - apply s k = apply s $ safeLookup err k s - where - err = "apply: Unknown KVar " ++ show k +apply1 :: CombinedEnv -> Solution -> F.BindId -> F.Expr +apply1 g s i = {- F.tracepp msg $ -} F.pAnd $ applyExpr g s <$> bindExprs g i + -- where + -- msg = "apply1 bind = " ++ show i -instance Solvable (F.KVar, F.Subst) where - apply s (k, su) = F.subst su (apply s k) +bindExprs :: CombinedEnv -> F.BindId -> [F.Expr] +bindExprs (_,be,_) i = [p `F.subst1` (v, F.eVar x) | F.Reft (v, p) <- rs ] + where + (x, sr) = F.lookupBindEnv i be + rs = F.reftConjuncts $ F.sr_reft sr -instance Solvable F.Pred where - apply s = V.trans (V.defaultVisitor {V.txPred = tx}) () () - where - tx _ (F.PKVar k su) = apply s (k, su) - tx _ p = p +applyExpr :: CombinedEnv -> Solution -> F.Expr -> F.Expr +applyExpr g s (F.PKVar k su) = applyKVar g s k su +applyExpr _ _ p = p -instance Solvable F.Refa where - apply s = apply s . F.raPred +applyKVar :: CombinedEnv -> Solution -> F.KVar -> F.Subst -> F.Expr +applyKVar g s k su + | Just eqs <- M.lookup k (F.sMap s) + = qBindPred su eqs + | Just cs <- M.lookup k (F.sHyp s) + = hypPred g s k su cs + | otherwise + = errorstar $ "Unknown kvar: " ++ show k -instance Solvable F.Reft where - apply s = apply s . F.reftPred +hypPred :: CombinedEnv -> Solution -> F.KVar -> F.Subst -> F.Hyp -> F.Expr +hypPred g s k su = F.pOr . fmap (cubePred g s k su) -instance Solvable F.SortedReft where - apply s = apply s . F.sr_reft +cubePred :: CombinedEnv -> Solution -> F.KVar -> F.Subst -> F.Cube -> F.Expr +cubePred g s k su c = F.PExist xts + $ F.pAnd [ psu + , F.PExist yts' $ F.pAnd [p', psu'] ] + where + yts' = symSorts g bs' + g' = addCEnv g bs + p' = apply g' s bs' + bs' = delCEnv bs g + F.Cube bs su' = c + (_ , psu') = substElim g' k su' + (xts, psu) = substElim g k su -instance Solvable (F.Symbol, F.SortedReft) where - apply s (x, sr) = p `F.subst1` (v, F.eVar x) - where - p = apply s r - F.Reft (v, r) = F.sr_reft sr +-- TODO: SUPER SLOW! Decorate all substitutions with Sorts in a SINGLE pass. +substElim :: CombinedEnv -> F.KVar -> F.Subst -> ([(F.Symbol, F.Sort)], F.Pred) +substElim g _ (F.Su m) = (xts, p) + where + p = F.pAnd [ F.PAtom F.Eq (F.eVar x) e | (x, e, _) <- xets ] + xts = [ (x, t) | (x, _, t) <- xets, not (S.member x frees) ] + xets = [ (x, e, t) | (x, e) <- xes, t <- sortOf e ] + xes = M.toList m + env = combinedSEnv g + frees = S.fromList (concatMap (F.syms . snd) xes) + sortOf = maybeToList . So.checkSortExpr env + -- sortOf e = fromMaybe (badExpr g k e) $ So.checkSortExpr env e -instance Solvable a => Solvable [a] where - apply s = F.pAnd . fmap (apply s) +--badExpr :: CombinedEnv -> F.KVar -> F.Expr -> a +--badExpr g@(i,_,_) k e + -- = errorstar $ "substSorts has a badExpr: " + -- ++ show e + -- ++ " in cid = " + -- ++ show i + -- ++ " for kvar " ++ show k + -- ++ " in env \n" + -- ++ show (combinedSEnv g) +-- substPred :: F.Subst -> F.Pred +-- substPred (F.Su m) = F.pAnd [ F.PAtom F.Eq (F.eVar x) e | (x, e) <- M.toList m] + +combinedSEnv :: CombinedEnv -> F.SEnv F.Sort +combinedSEnv (_, be, bs) = F.sr_sort <$> F.fromListSEnv (F.envCs be bs) + +addCEnv :: CombinedEnv -> F.IBindEnv -> CombinedEnv +addCEnv (x, be, bs) bs' = (x, be, F.unionIBindEnv bs bs') + +delCEnv :: F.IBindEnv -> CombinedEnv -> F.IBindEnv +delCEnv bs (_, _, bs') = F.diffIBindEnv bs bs' + +symSorts :: CombinedEnv -> F.IBindEnv -> [(F.Symbol, F.Sort)] +symSorts (_, be, _) bs = second F.sr_sort <$> F.envCs be bs + +noKvars :: F.Expr -> Bool +noKvars = null . V.kvars + +-------------------------------------------------------------------------------- +qBindPred :: F.Subst -> QBind -> F.Expr +-------------------------------------------------------------------------------- +qBindPred su eqs = F.subst su $ F.pAnd $ F.eqPred <$> eqs + + +-------------------------------------------------------------------------------- +solutionGraph :: Solution -> KVGraph +-------------------------------------------------------------------------------- +solutionGraph s = [ (KVar k, KVar k, KVar <$> eqKvars eqs) | (k, eqs) <- kEqs ] + where + eqKvars = sortNub . concatMap (V.kvars . F.eqPred) + kEqs = M.toList (F.sMap s) diff --git a/src/Language/Fixpoint/Solver/Solve.hs b/src/Language/Fixpoint/Solver/Solve.hs --- a/src/Language/Fixpoint/Solver/Solve.hs +++ b/src/Language/Fixpoint/Solver/Solve.hs @@ -1,85 +1,120 @@ -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} --- | Solve a system of horn-clause constraints ---------------------------- +-------------------------------------------------------------------------------- +-- | Solve a system of horn-clause constraints --------------------------------- +-------------------------------------------------------------------------------- -module Language.Fixpoint.Solver.Solve (solve) where +module Language.Fixpoint.Solver.Solve (solve, gradualSolve ) where -import Control.Monad (filterM) -import Control.Applicative ((<$>)) -import qualified Data.HashMap.Strict as M +import Control.Monad (when, filterM) +import Control.Monad.State.Strict (lift) +import Language.Fixpoint.Misc import qualified Language.Fixpoint.Types as F -import Language.Fixpoint.Config -import Language.Fixpoint.Solver.Validate +import Language.Fixpoint.Types.PrettyPrint +import Language.Fixpoint.Types.Config hiding (stats) import qualified Language.Fixpoint.Solver.Solution as S import qualified Language.Fixpoint.Solver.Worklist as W import Language.Fixpoint.Solver.Monad +import Language.Fixpoint.Solver.Graph (isTarget) +import Text.PrettyPrint.HughesPJ -- DEBUG import Text.Printf -import Language.Fixpoint.PrettyPrint -import Debug.Trace +import System.Console.CmdArgs.Verbosity (whenLoud) +import Control.DeepSeq ---------------------------------------------------------------------------- -solve :: Config -> F.FInfo a -> IO (F.Result a) ---------------------------------------------------------------------------- -solve cfg fi = runSolverM cfg fi' $ solve_ cfg fi' +import Data.List (sort) +import Data.Maybe (catMaybes) +-- import Debug.Trace (trace) + +-------------------------------------------------------------------------------- +solve :: (NFData a, F.Fixpoint a) => Config -> F.Solution -> F.SInfo a -> IO (F.Result (Integer, a)) +-------------------------------------------------------------------------------- +solve cfg s0 fi = do + -- donePhase Loud "Worklist Initialize" + (res, stat) <- runSolverM cfg fi n act + when (solverStats cfg) $ printStats fi wkl stat + -- print (numIter stat) + return res where - Right fi' = validate cfg fi + wkl = W.init fi + n = fromIntegral $ W.wRanks wkl + act = solve_ cfg fi s0 wkl ---------------------------------------------------------------------------- -solve_ :: Config -> F.FInfo a -> SolveM (F.Result a) ---------------------------------------------------------------------------- -solve_ cfg fi = refine s0 wkl >>= result fi +printStats :: F.SInfo a -> W.Worklist a -> Stats -> IO () +printStats fi w s = putStrLn "\n" >> ppTs [ ptable fi, ptable s, ptable w ] where - s0 = trace "DONE: S.init" $ S.init cfg fi - wkl = trace "DONE: W.init" $ W.init cfg fi + ppTs = putStrLn . showpp . mconcat ---------------------------------------------------------------------------- -refine :: S.Solution -> W.Worklist a -> SolveM S.Solution ---------------------------------------------------------------------------- + +-------------------------------------------------------------------------------- +solve_ :: (NFData a, F.Fixpoint a) + => Config -> F.SInfo a -> F.Solution -> W.Worklist a + -> SolveM (F.Result (Integer, a), Stats) +-------------------------------------------------------------------------------- +solve_ cfg fi s0 wkl = do + let s0' = mappend s0 $ {-# SCC "sol-init" #-} S.init fi + s <- {-# SCC "sol-refine" #-} refine s0' wkl + res <- {-# SCC "sol-result" #-} result cfg wkl s + st <- stats + let res' = {-# SCC "sol-tidy" #-} tidyResult res + return $!! (res', st) + +-- | tidyResult ensures we replace the temporary kVarArg names +-- introduced to ensure uniqueness with the original names +-- appearing in the supplied WF constraints. + +tidyResult :: F.Result a -> F.Result a +tidyResult r = r { F.resSolution = tidySolution (F.resSolution r) } + +tidySolution :: F.FixSolution -> F.FixSolution +tidySolution = fmap tidyPred + +tidyPred :: F.Expr -> F.Expr +tidyPred = F.substf (F.eVar . F.tidySymbol) + +-------------------------------------------------------------------------------- +refine :: F.Solution -> W.Worklist a -> SolveM F.Solution +-------------------------------------------------------------------------------- refine s w - | Just (c, w') <- W.pop w = do i <- tickIter - (b, s') <- refineC i s c - let w'' = if b then W.push c w' else w' - refine s' $ trace (refineMsg i c b w'') - $ w'' - | otherwise = return s + | Just (c, w', newScc, rnk) <- W.pop w = do + i <- tickIter newScc + (b, s') <- refineC i s c + lift $ writeLoud $ refineMsg i c b rnk + let w'' = if b then W.push c w' else w' + refine s' w'' + | otherwise = return s -- DEBUG -refineMsg i c b w = printf "REFINE: iter = %d cid = %s change = %s wkl = %s" - i (show $ F.sid c) (show b) (showpp w) +refineMsg i c b rnk = printf "\niter=%d id=%d change=%s rank=%d\n" + i (F.subcId c) (show b) rnk --------------------------------------------------------------------------- -- | Single Step Refinement ----------------------------------------------- --------------------------------------------------------------------------- -refineC :: Int -> S.Solution -> F.SubC a -> SolveM (Bool, S.Solution) +refineC :: Int -> F.Solution -> F.SimpC a -> SolveM (Bool, F.Solution) --------------------------------------------------------------------------- -refineC i s c +refineC _i s c | null rhs = return (False, s) - | otherwise = do lhs <- lhsPred s c <$> getBinds - kqs <- filterValid lhs rhs - return $ S.update s ks {- $ tracepp (msg ks rhs kqs) -} kqs + | otherwise = do be <- getBinds + let lhs = S.lhsPred be s c + kqs <- filterValid lhs rhs + return $ S.update s ks {- tracepp (msg ks rhs kqs) -} kqs where (ks, rhs) = rhsCands s c - -- msg ks xs ys = printf "refineC: iter = %d, ks = %s, rhs = %d, rhs' = %d \n" i (showpp ks) (length xs) (length ys) - -lhsPred :: S.Solution -> F.SubC a -> F.BindEnv -> F.Pred -lhsPred s c be = F.pAnd $ pGrd : pLhs : pBinds - where - pGrd = F.sgrd c - pLhs = S.apply s $ F.lhsCs c - pBinds = S.apply s <$> xts - xts = F.envCs be $ F.senv c + -- msg ks xs ys = printf "refineC: iter = %d, ks = %s, rhs = %d, rhs' = %d \n" _i (showpp ks) (length xs) (length ys) -rhsCands :: S.Solution -> F.SubC a -> ([F.KVar], S.Cand (F.KVar, S.EQual)) +rhsCands :: F.Solution -> F.SimpC a -> ([F.KVar], F.Cand (F.KVar, F.EQual)) rhsCands s c = (fst <$> ks, kqs) where - kqs = [ cnd k su q | (k, su) <- ks, q <- S.lookup s k] - ks = predKs . F.reftPred . F.rhsCs $ c - cnd k su q = (F.subst su (S.eqPred q), (k, q)) + kqs = [ cnd k su q | (k, su) <- ks, q <- F.solLookup s k] + ks = predKs . F.crhs $ c + cnd k su q = (F.subst su (F.eqPred q), (k, q)) -predKs :: F.Pred -> [(F.KVar, F.Subst)] +predKs :: F.Expr -> [(F.KVar, F.Subst)] predKs (F.PAnd ps) = concatMap predKs ps predKs (F.PKVar k su) = [(k, su)] predKs _ = [] @@ -87,30 +122,121 @@ --------------------------------------------------------------------------- -- | Convert Solution into Result ----------------------------------------- --------------------------------------------------------------------------- -result :: F.FInfo a -> S.Solution -> SolveM (F.Result a) +result :: (F.Fixpoint a) => Config -> W.Worklist a -> F.Solution -> SolveM (F.Result (Integer, a)) --------------------------------------------------------------------------- -result fi s = do - let sol = M.map (F.pAnd . fmap S.eqPred) s - stat <- result_ fi s - return $ F.Result stat sol +result _ wkl s = do + lift $ writeLoud "Computing Result" + stat <- result_ wkl s + -- stat' <- gradualSolve cfg stat + lift $ print (F.sid <$> stat) + return $ F.Result (ci <$> stat) (F.solResult s) + where + ci c = (F.subcId c, F.sinfo c) -result_ :: F.FInfo a -> S.Solution -> SolveM (F.FixResult (F.SubC a)) -result_ fi s = res <$> filterM (isUnsat s) cs + +result_ :: W.Worklist a -> F.Solution -> SolveM (F.FixResult (F.SimpC a)) +result_ w s = res <$> filterM (isUnsat s) cs where - cs = M.elems $ F.cm fi + cs = W.unsatCandidates w res [] = F.Safe res cs' = F.Unsafe cs' --------------------------------------------------------------------------- -isUnsat :: S.Solution -> F.SubC a -> SolveM Bool +isUnsat :: F.Solution -> F.SimpC a -> SolveM Bool --------------------------------------------------------------------------- isUnsat s c = do - lp <- lhsPred s c <$> getBinds - let rp = rhsPred s c - not <$> isValid lp rp + be <- getBinds + let lp = S.lhsPred be s c + let rp = rhsPred c + res <- not <$> isValid lp rp + lift $ whenLoud $ showUnsat res (F.subcId c) lp rp + return res -isValid :: F.Pred -> F.Pred -> SolveM Bool +showUnsat :: Bool -> Integer -> F.Pred -> F.Pred -> IO () +showUnsat u i lP rP = {- when u $ -} do + putStrLn $ printf "UNSAT id %s %s" (show i) (show u) + putStrLn $ showpp $ "LHS:" <+> pprint lP + putStrLn $ showpp $ "RHS:" <+> pprint rP + + + +-------------------------------------------------------------------------------- +-- | Predicate corresponding to RHS of constraint in current solution +-------------------------------------------------------------------------------- +rhsPred :: F.SimpC a -> F.Expr +-------------------------------------------------------------------------------- +rhsPred c + | isTarget c = F.crhs c + | otherwise = errorstar $ "rhsPred on non-target: " ++ show (F.sid c) + +isValid :: F.Expr -> F.Expr -> SolveM Bool isValid p q = (not . null) <$> filterValid p [(q, ())] -rhsPred :: S.Solution -> F.SubC a -> F.Pred -rhsPred s c = S.apply s $ F.rhsCs c + +-------------------------------------------------------------------------------- +-- | RJ: @nikivazou please add some description here of what this does. +-------------------------------------------------------------------------------- +gradualSolve :: (Fixpoint a) + => Config + -> F.FixResult (F.SimpC a) + -> SolveM (F.FixResult (F.SimpC a)) +gradualSolve cfg (F.Unsafe cs) + | gradual cfg = go cs + where + go cs = smtEnablrmbqi >> (makeResult . catMaybes <$> mapM gradualSolveOne cs) + makeResult = applyNonNull F.Safe F.Unsafe +gradualSolve _ r = return r + +gradualSolveOne :: (F.Fixpoint a) => F.SimpC a -> SolveM (Maybe (F.SimpC a)) +gradualSolveOne c = + do γ0 <- makeEnvironment c + let (γ, γ', hasGradual) = splitLastGradual γ0 + if hasGradual + then do let vc = makeGradualExpression γ γ' (F.crhs c) + s <- checkSat vc + return {- traceShow ("DEBUG" ++ show (γ, γ', F.crhs c) ++ "\nVC = \n" ++ show (vc, s) ) -} + $ if s then Nothing else Just c + else return $ Just c + +makeGradualExpression γ γ' p + = F.PAnd [F.PAll bs (F.PImp gs p), gs] + where + bs = [ (x, s) | (x, F.RR s _) <- γ'] + gs = F.pAnd (bindToLogic <$> (γ ++ γ')) + bindToLogic (x, F.RR _ (F.Reft (v, e))) = e `F.subst1` (v, F.EVar x) + +makeEnvironment c + = do lp <- getBinds + return [ F.lookupBindEnv i lp | i <- bs ] + where + bs = sort $ F.elemsIBindEnv $ F.senv c + +splitLastGradual = go [] . reverse + where + go acc (xe@(x, F.RR s (F.Reft (v, e))) : xss) + | Just es <- removePGrads e + = (reverse ((x, F.RR s (F.Reft (v, F.pAnd es))):xss), reverse acc, True) + | otherwise + = go (xe:acc) xss + go acc [] + = ([], reverse acc, False) + +removePGrads (F.PAnd es) + | F.PGrad `elem` es + = Just $ filter (/= F.PGrad) es + | otherwise + = Nothing +removePGrads F.PGrad + = Just [] +removePGrads _ + = Nothing + +{- +--------------------------------------------------------------------------- +donePhase' :: String -> SolveM () +--------------------------------------------------------------------------- +donePhase' msg = lift $ do + threadDelay 25000 + putBlankLn + donePhase Loud msg +-} diff --git a/src/Language/Fixpoint/Solver/TrivialSort.hs b/src/Language/Fixpoint/Solver/TrivialSort.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fixpoint/Solver/TrivialSort.hs @@ -0,0 +1,176 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Language.Fixpoint.Solver.TrivialSort (nontrivsorts) where + +import GHC.Generics (Generic) +import Control.Arrow (second) +import Language.Fixpoint.Types.PrettyPrint +import Language.Fixpoint.Types.Visitor +import Language.Fixpoint.Types.Config +import Language.Fixpoint.Types hiding (simplify) +import Language.Fixpoint.Utils.Files +import Language.Fixpoint.Misc +import qualified Data.HashSet as S +import Data.Hashable +import qualified Data.HashMap.Strict as M +import Data.List (foldl') +import qualified Data.Graph as G +import Data.Maybe +import Text.Printf +import Debug.Trace + +------------------------------------------------------------------------- +nontrivsorts :: (Fixpoint a) => Config -> FInfo a -> IO (Result a) +------------------------------------------------------------------------- +nontrivsorts cfg fi = do + let fi' = simplify' cfg fi + writeFInfo cfg fi' $ extFileName Out (inFile cfg) + return mempty + +simplify' :: Config -> FInfo a -> FInfo a +simplify' _ fi = simplifyFInfo (mkNonTrivSorts fi) fi + +-------------------------------------------------------------------- +-- | The main data types +-------------------------------------------------------------------- +type NonTrivSorts = S.HashSet Sort +type KVarMap = M.HashMap KVar [Sort] +data Polarity = Lhs | Rhs +type TrivInfo = (NonTrivSorts, KVarMap) +-------------------------------------------------------------------- + +-------------------------------------------------------------------- +mkNonTrivSorts :: FInfo a -> NonTrivSorts +-------------------------------------------------------------------- +mkNonTrivSorts = tracepp "mkNonTrivSorts: " + . nonTrivSorts . trivInfo + +-------------------------------------------------------------------- +nonTrivSorts :: TrivInfo -> NonTrivSorts +-------------------------------------------------------------------- +nonTrivSorts ti = S.fromList [s | S s <- ntvs] + where + ntvs = [fst3 (f v) | v <- G.reachable g root] + (g, f, fv) = G.graphFromEdges $ ntGraph ti + root = fromMaybe err $ fv NTV + err = errorstar "nonTrivSorts: cannot find root!" + +ntGraph :: TrivInfo -> NTG +ntGraph ti = [(v,v,vs) | (v, vs) <- groupList $ ntEdges ti] + +ntEdges :: TrivInfo -> [(NTV, NTV)] +ntEdges (nts, kvm) = es ++ [(v, u) | (u, v) <- es] + where + es = [(NTV, S s) | s <- S.toList nts ] + ++ [(K k, S s) | (k, ss) <- M.toList kvm, s <- ss] + +type NTG = [(NTV, NTV, [NTV])] + +data NTV = NTV + | K KVar + | S Sort + deriving (Eq, Ord, Show, Generic) + +instance Hashable NTV + +-------------------------------------------------------------------- +trivInfo :: FInfo a -> TrivInfo +-------------------------------------------------------------------- +trivInfo fi = updTISubCs (M.elems $ cm fi) + . updTIBinds (bs fi) + $ (S.empty, M.empty) + +updTISubCs :: [SubC a] -> TrivInfo -> TrivInfo +updTISubCs cs ti = foldl' (flip updTISubC) ti cs + +updTISubC :: SubC a -> TrivInfo -> TrivInfo +updTISubC c = updTI Lhs (slhs c) . updTI Rhs (srhs c) + +updTIBinds :: BindEnv -> TrivInfo -> TrivInfo +updTIBinds be ti = foldl' (flip (updTI Lhs)) ti ts + where + ts = [t | (_,_,t) <- bindEnvToList be] + +-------------------------------------------------------------------- +updTI :: Polarity -> SortedReft -> TrivInfo -> TrivInfo +-------------------------------------------------------------------- +updTI p (RR t r) = addKVs t (kvars r) . addNTS p r t + +addNTS :: Polarity -> Reft -> Sort -> TrivInfo -> TrivInfo +addNTS p r t ti + | isNTR p r = addSort t ti + | otherwise = ti + +addKVs :: Sort -> [KVar] -> TrivInfo -> TrivInfo +addKVs t ks ti = foldl' addK ti ks + where + addK (ts, m) k = (ts, inserts k t m) + +addSort :: Sort -> TrivInfo -> TrivInfo +addSort t (ts, m) = (S.insert t ts, m) + +-------------------------------------------------------------------- +isNTR :: Polarity -> Reft -> Bool +-------------------------------------------------------------------- +isNTR Rhs = not . trivR +isNTR Lhs = not . trivOrSingR + +trivR :: Reft -> Bool +trivR = all trivP . conjuncts . reftPred + +trivOrSingR :: Reft -> Bool +trivOrSingR (Reft (v, p)) = all trivOrSingP $ conjuncts p + where + trivOrSingP p = trivP p || singP v p + +trivP :: Expr -> Bool +trivP (PKVar {}) = True +trivP p = isTautoPred p + +singP :: Symbol -> Expr -> Bool +singP v (PAtom Eq (EVar x) _) + | v == x = True +singP v (PAtom Eq _ (EVar x)) + | v == x = True +singP _ _ = False + +------------------------------------------------------------------------- +simplifyFInfo :: NonTrivSorts -> FInfo a -> FInfo a +------------------------------------------------------------------------- +simplifyFInfo tm fi = fi { + cm = simplifySubCs tm $ cm fi + , ws = simplifyWfCs tm $ ws fi + , bs = simplifyBindEnv tm $ bs fi +} + +simplifyBindEnv :: NonTrivSorts -> BindEnv -> BindEnv +simplifyBindEnv = mapBindEnv . second . simplifySortedReft + +simplifyWfCs :: NonTrivSorts -> M.HashMap KVar (WfC a) -> M.HashMap KVar (WfC a) +simplifyWfCs tm = M.filter (isNonTrivialSort tm . snd3 . wrft) + +simplifySubCs ti cm = trace msg cm' + where + cm' = tx cm + tx = M.fromList . mapMaybe (simplifySubC ti) . M.toList + msg = printf "simplifySUBC: before = %d, after = %d \n" n n' + n = M.size cm + n' = M.size cm' + +simplifySubC :: NonTrivSorts -> (b, SubC a) -> Maybe (b, SubC a) +simplifySubC tm (i, c) + | isNonTrivial srhs' = Just (i, c { slhs = slhs' , srhs = srhs' }) + | otherwise = Nothing + where + slhs' = simplifySortedReft tm (slhs c) + srhs' = simplifySortedReft tm (srhs c) + +simplifySortedReft :: NonTrivSorts -> SortedReft -> SortedReft +simplifySortedReft tm sr + | nonTrivial = sr + | otherwise = sr { sr_reft = mempty } + where + nonTrivial = isNonTrivialSort tm (sr_sort sr) + +isNonTrivialSort :: NonTrivSorts -> Sort -> Bool +isNonTrivialSort tm t = S.member t tm diff --git a/src/Language/Fixpoint/Solver/Types.hs b/src/Language/Fixpoint/Solver/Types.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fixpoint/Solver/Types.hs @@ -0,0 +1,39 @@ + +{-# LANGUAGE ImplicitParams #-} + +module Language.Fixpoint.Solver.Types where + + +import Language.Fixpoint.Misc (safeLookup) +import qualified Language.Fixpoint.Types as F +import qualified Data.HashMap.Strict as M +import GHC.Stack +--------------------------------------------------------------------------- +-- | Dramatis Personae +--------------------------------------------------------------------------- + +type CId = Integer +type CSucc = CId -> [CId] +type CMap a = M.HashMap CId a +type KVRead = M.HashMap F.KVar [CId] +type DepEdge = (CId, CId, [CId]) + +data Slice = Slice { slKVarCs :: [CId] -- ^ CIds that transitively "reach" below + , slConcCs :: [CId] -- ^ CIds with Concrete RHS + , slEdges :: [DepEdge] -- ^ Dependencies between slKVarCs + } deriving (Eq, Show) + +data CGraph = CGraph { gEdges :: [DepEdge] + , gRanks :: CMap Int + , gSucc :: CSucc + , gSccs :: Int + } + +--------------------------------------------------------------------------- +-- | CMap API ------------------------------------------------------------- +--------------------------------------------------------------------------- + +lookupCMap :: (?callStack :: CallStack) => CMap a -> CId -> a +lookupCMap rm i = safeLookup err i rm + where + err = "lookupCMap: cannot find info for " ++ show i diff --git a/src/Language/Fixpoint/Solver/Uniqify.hs b/src/Language/Fixpoint/Solver/Uniqify.hs deleted file mode 100644 --- a/src/Language/Fixpoint/Solver/Uniqify.hs +++ /dev/null @@ -1,117 +0,0 @@ - -module Language.Fixpoint.Solver.Uniqify - (renameAll) where - -import Language.Fixpoint.Types -import Language.Fixpoint.Names (renameSymbol) -import Language.Fixpoint.Misc (errorstar) -import Language.Fixpoint.Solver.Eliminate (elimKVar, findWfC) - -import qualified Data.HashMap.Strict as M -import qualified Data.HashSet as S -import Data.List ((\\), sort) -import Data.Maybe (catMaybes) -import Data.Foldable (foldlM) -import Control.Monad.State (get, put, evalState, State) - - - - --------------------------------------------------------------- -renameAll :: FInfo a -> FInfo a -renameAll fi = fi' - where - idMap = mkIdMap fi - fi' = renameVars fi (M.toList idMap) --------------------------------------------------------------- - - -type IdMap = M.HashMap BindId (S.HashSet BindId, S.HashSet Integer) -type NameMap = M.HashMap Symbol BindId - -mkIdMap :: FInfo a -> IdMap -mkIdMap fi = M.foldlWithKey' (updateIdMap benv) (emptyIdMap benv) (cm fi) - where benv = bs fi - -emptyIdMap :: BindEnv -> IdMap -emptyIdMap benv = foldl go M.empty (M.keys $ beBinds benv) - where go m b = M.insert b (S.empty, S.empty) m - -updateIdMap :: BindEnv -> IdMap -> Integer -> SubC a -> IdMap -updateIdMap benv m subcId s = foldl (bar' subcId) m' refList - where - ids = sort $ elemsIBindEnv $ senv s - nameMap = mkNameMap benv ids - m' = foldl (bongo benv nameMap) m ids - - symList = (freeVars $ sr_reft $ slhs s) ++ (freeVars $ sr_reft $ srhs s) - refList = baz nameMap symList - -bongo :: BindEnv -> NameMap -> IdMap -> BindId -> IdMap -bongo benv nameMap idMap id = foldl (bar id) idMap refList - where - (_, sr) = lookupBindEnv id benv - symList = freeVars $ sr_reft sr - refList = baz nameMap symList - -bar :: BindId -> IdMap -> BindId -> IdMap -bar idOfReft m referencedId = M.insert referencedId (S.insert idOfReft bs, is) m - where (bs, is) = M.lookupDefault (errorstar "wat") referencedId m - -bar' :: Integer -> IdMap -> BindId -> IdMap -bar' idOfSubc m referencedId = M.insert referencedId (bs, S.insert idOfSubc is) m - where (bs, is) = M.lookupDefault (errorstar "wat") referencedId m - -baz :: NameMap -> [Symbol] -> [BindId] -baz m syms = catMaybes [M.lookup sym m | sym <- syms] --TODO why any Nothings? - -freeVars :: Reft -> [Symbol] -freeVars reft@(Reft (v, _)) = syms reft \\ [v] - -mkNameMap :: BindEnv -> [BindId] -> NameMap -mkNameMap benv ids = foldl (insertInverse benv) M.empty ids - -insertInverse :: BindEnv -> NameMap -> BindId -> NameMap -insertInverse benv m id = M.insert sym id m - where (sym, _) = lookupBindEnv id benv - - -renameVars :: FInfo a -> [(BindId, (S.HashSet BindId, S.HashSet Integer))] -> FInfo a -renameVars fi xs = evalState (foldlM potentiallyRenameVar fi xs) S.empty - ---lookupBindEnv :: BindId -> BindEnv -> (Symbol, SortedReft) - -potentiallyRenameVar :: FInfo a -> (BindId, (S.HashSet BindId, S.HashSet Integer)) -> State (S.HashSet Symbol) (FInfo a) -potentiallyRenameVar fi x@(id, _) = - do s <- get - let (sym, _) = lookupBindEnv id (bs fi) - let seen = sym `S.member` s - put (if seen then s else (S.insert sym s)) - return (if seen then (renameVar fi x) else fi) - -renameVar :: FInfo a -> (BindId, (S.HashSet BindId, S.HashSet Integer)) -> FInfo a -renameVar fi (id, stuff) = elimKVar (blarg fi id sym sym') fi''' --TODO: optimize? (elimKVar separately on every rename is expensive) - where - (sym, _) = lookupBindEnv id (bs fi) - sym' = renameSymbol sym id - sub = (sym, eVar sym') - go subst x = subst1 x subst - fi' = fi { bs = adjustBindEnv (go sub) id (bs fi) } - fi'' = S.foldl' (foo sub) fi' (fst stuff) - fi''' = S.foldl' (foo' sub) fi'' (snd stuff) - -foo :: (Symbol, Expr) -> FInfo a -> BindId -> FInfo a -foo sub fi id = fi { bs = adjustBindEnv (go sub) id (bs fi) } - where go sub (sym, sr) = (sym, subst1 sr sub) - -foo' :: (Symbol, Expr) -> FInfo a -> Integer -> FInfo a -foo' sub fi id = fi { cm = M.adjust (go sub) id (cm fi) } - where go sub c = c { slhs = subst1 (slhs c) sub , - srhs = subst1 (srhs c) sub } - -blarg :: FInfo a -> BindId -> Symbol -> Symbol -> (KVar, Subst) -> Maybe Pred -blarg fi id oldSym newSym (k, Su su) = if relevant then Just $ PKVar k $ mkSubst [(newSym, eVar oldSym)] else Nothing - where - wfc = fst $ findWfC k (ws fi) - relevant = (id `elem` (elemsIBindEnv $ wenv wfc)) && (oldSym `elem` (map fst su)) - diff --git a/src/Language/Fixpoint/Solver/UniqifyBinds.hs b/src/Language/Fixpoint/Solver/UniqifyBinds.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fixpoint/Solver/UniqifyBinds.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE PatternGuards #-} + +-- This module makes it so no binds with different sorts have the same name. + +module Language.Fixpoint.Solver.UniqifyBinds (renameAll) where + +import Language.Fixpoint.Types +import Language.Fixpoint.Solver.Types (CId) +import Language.Fixpoint.Misc (fst3, mlookup) + +import qualified Data.HashMap.Strict as M +import qualified Data.HashSet as S +import qualified Data.List as L +import Data.Foldable (foldl') +import Data.Maybe (catMaybes, fromJust, isJust) +import Data.Hashable (Hashable) +import GHC.Generics (Generic) +import Control.Arrow (second) +import Control.DeepSeq (NFData, ($!!)) + +-------------------------------------------------------------- +renameAll :: SInfo a -> SInfo a +renameAll fi2 = fi4 + where + fi4 = {-# SCC "renameBinds" #-} renameBinds fi3 $!! rnm + fi3 = {-# SCC "renameVars" #-} renameVars fi2 rnm $!! idm + rnm = {-# SCC "mkRenameMap" #-} mkRenameMap $!! bs fi2 + idm = {-# SCC "mkIdMap" #-} mkIdMap fi2 +-------------------------------------------------------------- + +data Ref = RB BindId | RI CId deriving (Eq, Generic) + +instance NFData Ref +instance Hashable Ref + +-- stores for each constraint and BindId the set of other BindIds that it +-- references, i.e. those where it needs to know when their names gets changed +type IdMap = M.HashMap Ref (S.HashSet BindId) + +-- map from old name and sort to new name, represented by a hashmap containing +-- association lists. Nothing as new name means same as old +type RenameMap = M.HashMap Symbol [(Sort, Maybe Symbol)] + +-------------------------------------------------------------- +mkIdMap :: SInfo a -> IdMap +-------------------------------------------------------------- +mkIdMap fi = M.foldlWithKey' (updateIdMap $ bs fi) M.empty $ cm fi + +updateIdMap :: BindEnv -> IdMap -> CId -> SimpC a -> IdMap +updateIdMap be m scId s = M.insertWith S.union (RI scId) refSet m' + where + ids = elemsIBindEnv $ senv s + nameMap = M.fromList [(fst $ lookupBindEnv i be, i) | i <- ids] + m' = foldl' (insertIdIdLinks be nameMap) m ids + + symSet = S.fromList $ syms $ crhs s + refSet = namesToIds symSet nameMap + +insertIdIdLinks :: BindEnv -> M.HashMap Symbol BindId -> IdMap -> BindId -> IdMap +insertIdIdLinks be nameMap m i = M.insertWith S.union (RB i) refSet m + where + sr = snd $ lookupBindEnv i be + symSet = reftFreeVars $ sr_reft sr + refSet = namesToIds symSet nameMap + +namesToIds :: S.HashSet Symbol -> M.HashMap Symbol BindId -> S.HashSet BindId +namesToIds xs m = S.fromList $ catMaybes [M.lookup x m | x <- S.toList xs] --TODO why any Nothings? + +-------------------------------------------------------------- +mkRenameMap :: BindEnv -> RenameMap +-------------------------------------------------------------- +mkRenameMap be = foldl' (addId be) M.empty ids + where + ids = fst3 <$> bindEnvToList be + +addId :: BindEnv -> RenameMap -> BindId -> RenameMap +addId be m i + | M.member sym m = addDupId m sym t i + | otherwise = M.insert sym [(t, Nothing)] m + where + (sym, t) = second sr_sort $ lookupBindEnv i be + +addDupId :: RenameMap -> Symbol -> Sort -> BindId -> RenameMap +addDupId m sym t i + | isJust $ L.lookup t mapping = m + | otherwise = M.insert sym ((t, Just $ renameSymbol sym i) : mapping) m + where + mapping = fromJust $ M.lookup sym m +-------------------------------------------------------------- + +-------------------------------------------------------------- +renameVars :: SInfo a -> RenameMap -> IdMap -> SInfo a +-------------------------------------------------------------- +renameVars fi rnMap idMap = M.foldlWithKey' (updateRef rnMap) fi idMap + +updateRef :: RenameMap -> SInfo a -> Ref -> S.HashSet BindId -> SInfo a +updateRef rnMap fi rf bset = applySub (mkSubst subs) fi rf + where + symTList = [second sr_sort $ lookupBindEnv i $ bs fi | i <- S.toList bset] + subs = catMaybes $ mkSubUsing rnMap <$> symTList + +mkSubUsing :: RenameMap -> (Symbol, Sort) -> Maybe (Symbol, Expr) +mkSubUsing m (sym, t) = do + newName <- fromJust $ L.lookup t $ mlookup m sym + return (sym, eVar newName) + +applySub :: Subst -> SInfo a -> Ref -> SInfo a +applySub sub fi (RB i) = fi { bs = adjustBindEnv go i (bs fi) } + where + go (sym, sr) = (sym, subst sub sr) + +applySub sub fi (RI i) = fi { cm = M.adjust go i (cm fi) } + where + go c = c { _crhs = subst sub (_crhs c) } +-------------------------------------------------------------- + +-------------------------------------------------------------- +renameBinds :: SInfo a -> RenameMap -> SInfo a +-------------------------------------------------------------- +renameBinds fi m = fi { bs = bindEnvFromList $ renameBind m <$> beList } + where + beList = bindEnvToList $ bs fi + +renameBind :: RenameMap -> (BindId, Symbol, SortedReft) -> (BindId, Symbol, SortedReft) +renameBind m (i, sym, sr) + | (Just newSym) <- mnewSym = (i, newSym, sr) + | otherwise = (i, sym, sr) + where + t = sr_sort sr + mnewSym = fromJust $ L.lookup t $ mlookup m sym +-------------------------------------------------------------- diff --git a/src/Language/Fixpoint/Solver/UniqifyKVars.hs b/src/Language/Fixpoint/Solver/UniqifyKVars.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fixpoint/Solver/UniqifyKVars.hs @@ -0,0 +1,104 @@ +{- +This module creates new bindings for each argument of each kvar. +It also makes sure that all arguments to each kvar are explicit. +For example, + +''' +bind 0 x +bind 1 v +constraint: + env [0; 1] + rhs $k_42 // implicit substitutions [x:=x], [v:=v] +wf: + env [0] + reft {v : int | [$k_42]} +''' + +becomes + +''' +bind 0 x +bind 1 v +bind 2 lq_karg$x$k_42 +constraint: + env [0; 1] + rhs $k_42[lq_karg$x$k_42:=x][lq_karg$v$k_42:=v] + +wf: + env [2] + reft {lq_karg$v$k_42 : int | [$k_42]} +''' +-} + +module Language.Fixpoint.Solver.UniqifyKVars (wfcUniqify) where + +import Language.Fixpoint.Types +import Language.Fixpoint.Types.Visitor (mapKVarSubsts) +-- import Language.Fixpoint.Solver.Validate (getDomain) +import qualified Data.HashMap.Strict as M +import Data.Foldable (foldl') + +-------------------------------------------------------------- +wfcUniqify :: SInfo a -> SInfo a +wfcUniqify fi = updateWfcs $ remakeSubsts fi +-------------------------------------------------------------- + +-------------------------------------------------------------- +remakeSubsts :: SInfo a -> SInfo a +-------------------------------------------------------------- +remakeSubsts fi = mapKVarSubsts (remakeSubst fi) fi + +remakeSubst :: SInfo a -> KVar -> Subst -> Subst +remakeSubst fi k su = foldl' (updateSubst k) su kDom + where + kDom = kvarDomain fi k + +updateSubst :: KVar -> Subst -> Symbol -> Subst +updateSubst k (Su su) sym + | sym `M.member` su = Su $ M.delete sym $ M.insert (kArgSymbol sym kx) (su M.! sym) su + | otherwise = Su $ M.insert (kArgSymbol sym kx) (eVar sym) su + where + kx = kv k + +-------------------------------------------------------------- +updateWfcs :: SInfo a -> SInfo a +-------------------------------------------------------------- +updateWfcs fi = M.foldl' updateWfc fi (ws fi) + +updateWfc :: SInfo a -> WfC a -> SInfo a +updateWfc fi w = fi' { ws = M.insert k w' (ws fi) } + where + (v, t, k) = wrft w + (fi', newIds) = insertNewBinds w fi k + env' = insertsIBindEnv newIds emptyIBindEnv + w' = w { wenv = env', wrft = (kArgSymbol v (kv k), t, k) } + +insertNewBinds :: WfC a -> SInfo a -> KVar -> (SInfo a, [BindId]) +insertNewBinds w fi k = foldl' (accumBindsIfValid k) (fi, []) (elemsIBindEnv $ wenv w) + +accumBindsIfValid :: KVar -> (SInfo a, [BindId]) -> BindId -> (SInfo a, [BindId]) +accumBindsIfValid k (fi, ids) i = if renamable then accumBinds k (fi, ids) i else (fi, i : ids) + where + (_, sr) = lookupBindEnv i (bs fi) + renamable = isValidInRefinements $ sr_sort sr + +accumBinds :: KVar -> (SInfo a, [BindId]) -> BindId -> (SInfo a, [BindId]) +accumBinds k (fi, ids) i = (fi {bs = be'}, i' : ids) + where + --TODO: could we ignore the old SortedReft? what would it mean if it were non-trivial in a wf environment? + (oldSym, sr) = lookupBindEnv i (bs fi) + newSym = {- tracepp "kArgSymbol" $ -} kArgSymbol oldSym (kv k) + (i', be') = insertBindEnv newSym sr (bs fi) +-------------------------------------------------------------- + +isValidInRefinements :: Sort -> Bool +isValidInRefinements FInt = True +isValidInRefinements FReal = True +isValidInRefinements FNum = False +isValidInRefinements FFrac = False +isValidInRefinements (FObj _) = True +isValidInRefinements (FVar _) = True +isValidInRefinements (FFunc _ _) = False +isValidInRefinements (FAbs _ t) = isValidInRefinements t +isValidInRefinements (FTC _) = True --TODO is this true? seems to be required for e.g. ResolvePred.hs +isValidInRefinements (FApp _ _) = True diff --git a/src/Language/Fixpoint/Solver/Validate.hs b/src/Language/Fixpoint/Solver/Validate.hs --- a/src/Language/Fixpoint/Solver/Validate.hs +++ b/src/Language/Fixpoint/Solver/Validate.hs @@ -1,73 +1,192 @@ -- | Validate and Transform Constraints to Ensure various Invariants ------------------------- --- 1. Each binder must be unique +-- 1. Each binder must be associated with a UNIQUE sort +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE OverloadedStrings #-} module Language.Fixpoint.Solver.Validate - ( -- * Validate and Transform FInfo to enforce invariants - validate + ( -- * Transform FInfo to enforce invariants + sanitize -- * Sorts for each Symbol , symbolSorts + ) where -import Language.Fixpoint.Visitor (foldSort) -import Language.Fixpoint.Config -import Language.Fixpoint.PrettyPrint +import Language.Fixpoint.Types.PrettyPrint +import Language.Fixpoint.Types.Visitor (isConcC, isKvarC, mapKVars, mapKVarSubsts) +import Language.Fixpoint.SortCheck (isFirstOrder) import qualified Language.Fixpoint.Misc as Misc +import Language.Fixpoint.Misc (fM) import qualified Language.Fixpoint.Types as F -import qualified Language.Fixpoint.Errors as E +import qualified Language.Fixpoint.Types.Errors as E import qualified Data.HashMap.Strict as M +import qualified Data.HashSet as S import qualified Data.List as L --- import Control.Monad (filterM) --- import Control.Applicative ((<$>)) ---import Debug.Trace (trace) -import Text.Printf +import Data.Maybe (isNothing) +import Control.Monad ((>=>)) +import Text.PrettyPrint.HughesPJ +type ValidateM a = Either E.Error a ---------------------------------------------------------------------------- -validate :: Config -> F.FInfo a -> Either E.Error (F.FInfo a) ---------------------------------------------------------------------------- -validate _ = Right . dropHigherOrderBinders . renameVV +-------------------------------------------------------------------------------- +sanitize :: F.SInfo a -> ValidateM (F.SInfo a) +-------------------------------------------------------------------------------- +sanitize = fM dropFuncSortedShadowedBinders + >=> fM dropWfcFunctions + >=> fM replaceDeadKvars + >=> fM dropBogusSubstitutions + >=> banMixedRhs + >=> banQualifFreeVars + >=> banConstraintFreeVars +-------------------------------------------------------------------------------- +-- | remove substitutions `K[x := e]` where `x` is not in the domain of K +-------------------------------------------------------------------------------- +dropBogusSubstitutions :: F.SInfo a -> F.SInfo a +dropBogusSubstitutions si0 = mapKVarSubsts (F.filterSubst . keepSubst) si0 + where + kvM = kvarDomainM si0 + kvXs k = M.lookupDefault S.empty k kvM + keepSubst k x _ = x `S.member` kvXs k + +kvarDomainM :: F.SInfo a -> M.HashMap F.KVar (S.HashSet F.Symbol) +kvarDomainM si = M.fromList [ (k, dom k) | k <- ks ] + where + ks = M.keys (F.ws si) + dom = S.fromList . F.kvarDomain si + --------------------------------------------------------------------------- +-- filterBogusSubstitutions :: F.SInfo a -> F.SInfo a +-- --------------------------------------------------------------------------- +-- filterBogusSubstitutions fi = mapKVarSubsts (filterByDomain fi) fi +-- +-- filterByDomain :: F.SInfo a -> F.KVar -> F.Subst -> F.Subst +-- filterByDomain si k su = F.filterSubst (go kDom) su + -- where + -- kDom = getDomain si k + -- go dom sym _ = sym `elem` dom + +-------------------------------------------------------------------------------- +-- | check that no constraint has free variables (ignores kvars) +-------------------------------------------------------------------------------- +banConstraintFreeVars :: F.SInfo a -> ValidateM (F.SInfo a) +banConstraintFreeVars fi0 = Misc.applyNonNull (Right fi0) (Left . badCs) bads + where + fi = mapKVars (const $ Just F.PTrue) fi0 + bads = [c | c <- M.elems $ F.cm fi, not $ cNoFreeVars fi c] + +cNoFreeVars :: F.SInfo a -> F.SimpC a -> Bool +cNoFreeVars fi c = S.null $ cRng `nubDiff` (lits ++ cDom ++ F.prims) + where + be = F.bs fi + lits = fst <$> F.toListSEnv (F.lits fi) + ids = F.elemsIBindEnv $ F.senv c + cDom = [fst $ F.lookupBindEnv i be | i <- ids] + cRng = concat [S.toList . F.reftFreeVars . F.sr_reft . snd $ F.lookupBindEnv i be | i <- ids] + +badCs :: Misc.ListNE (F.SimpC a) -> E.Error +badCs = E.catErrors . map (E.errFreeVarInConstraint . F.subcId) + + +-------------------------------------------------------------------------------- +-- | check that no qualifier has free variables +-------------------------------------------------------------------------------- +banQualifFreeVars :: F.SInfo a -> ValidateM (F.SInfo a) +-------------------------------------------------------------------------------- +banQualifFreeVars fi = Misc.applyNonNull (Right fi) (Left . badQuals) bads + where + bads = [ (q, xs) | q <- F.quals fi, let xs = free q, not (null xs) ] + lits = fst <$> F.toListSEnv (F.lits fi) + free q = S.toList $ F.syms (F.q_body q) `nubDiff` (lits ++ F.prims ++ F.syms (fst <$> F.q_params q)) + + +badQuals :: Misc.ListNE (F.Qualifier, Misc.ListNE F.Symbol) -> E.Error +badQuals bqs = E.catErrors [ E.errFreeVarInQual q xs | (q, xs) <- bqs] + +-- Null if first is a subset of second +nubDiff :: [F.Symbol] -> [F.Symbol] -> S.HashSet F.Symbol +nubDiff a b = a' `S.difference` b' + where + a' = S.fromList a + b' = S.fromList b + +-------------------------------------------------------------------------------- +-- | check that each constraint has RHS of form [k1,...,kn] or [p] +-------------------------------------------------------------------------------- +banMixedRhs :: F.SInfo a -> ValidateM (F.SInfo a) +-------------------------------------------------------------------------------- +banMixedRhs fi = Misc.applyNonNull (Right fi) (Left . badRhs) bads + where + ics = M.toList $ F.cm fi + bads = [(i, c) | (i, c) <- ics, not $ isOk c] + isOk c = isKvarC c || isConcC c + +badRhs :: Misc.ListNE (Integer, F.SimpC a) -> E.Error +badRhs = E.catErrors . map badRhs1 + +badRhs1 :: (Integer, F.SimpC a) -> E.Error +badRhs1 (i, c) = E.err E.dummySpan $ vcat [ "Malformed RHS for constraint id" <+> pprint i + , nest 4 (pprint (F.crhs c)) ] + +-- | Conservative check that KVars appear at "top-level" in pred +-- isOkRhs :: F.Pred -> Bool +-- isOkRhs p = all isKvar ps || all isConc ps +-- where +-- ps = F.conjuncts p +-------------------------------------------------------------------------------- -- | symbol |-> sort for EVERY variable in the FInfo ---------------------------------------------------------------------------- -symbolSorts :: F.FInfo a -> Either E.Error [(F.Symbol, F.Sort)] ---------------------------------------------------------------------------- -symbolSorts fi = compact . (\z -> lits ++ consts ++ z) =<< bindSorts fi +-------------------------------------------------------------------------------- +symbolSorts :: F.GInfo c a -> ValidateM [(F.Symbol, F.Sort)] +-------------------------------------------------------------------------------- +symbolSorts fi = (normalize . compact . (defs ++)) =<< bindSorts fi where - lits = F.lits fi - consts = [(x, t) | (x, F.RR t _) <- F.toListSEnv $ F.gs fi] + normalize = fmap (map (unShadow dm)) + dm = M.fromList defs + defs = F.toListSEnv $ F.lits fi +unShadow :: M.HashMap F.Symbol a -> (F.Symbol, F.Sort) -> (F.Symbol, F.Sort) +unShadow dm (x, t) + | M.member x dm = (x, t) + | otherwise = (x, defuncSort t) + +defuncSort :: F.Sort -> F.Sort +defuncSort (F.FFunc {}) = F.funcSort +defuncSort t = t + compact :: [(F.Symbol, F.Sort)] -> Either E.Error [(F.Symbol, F.Sort)] compact xts | null bad = Right [(x, t) | (x, [t]) <- ok ] - | otherwise = Left $ dupBindErrors bad + | otherwise = Left $ dupBindErrors bad' where + bad' = [(x, (, []) <$> ts) | (x, ts) <- bad] (bad, ok) = L.partition multiSorted . binds $ xts binds = M.toList . M.map Misc.sortNub . Misc.group ---------------------------------------------------------------------------- -bindSorts :: F.FInfo a -> Either E.Error [(F.Symbol, F.Sort)] ---------------------------------------------------------------------------- +-------------------------------------------------------------------------------- +bindSorts :: F.GInfo c a -> Either E.Error [(F.Symbol, F.Sort)] +-------------------------------------------------------------------------------- bindSorts fi | null bad = Right [ (x, t) | (x, [(t, _)]) <- ok ] - | otherwise = Left $ dupBindErrors [ (x, map fst ts) | (x, ts) <- bad] + | otherwise = Left $ dupBindErrors [ (x, ts) | (x, ts) <- bad] where (bad, ok) = L.partition multiSorted . binds $ fi binds = symBinds . F.bs + multiSorted :: (x, [t]) -> Bool multiSorted = (1 <) . length . snd -dupBindErrors :: [(F.Symbol, [F.Sort])] -> E.Error +dupBindErrors :: [(F.Symbol, [(F.Sort, [F.BindId] )])] -> E.Error dupBindErrors = foldr1 E.catError . map dbe where - dbe (x, y) = E.err E.dummySpan $ printf "Multiple sorts for %s : %s \n" (showpp x) (showpp y) + dbe (x, y) = E.err E.dummySpan $ vcat [ "Multiple sorts for" <+> pprint x + , nest 4 (pprint y) ] ---------------------------------------------------------------------------- +-------------------------------------------------------------------------------- symBinds :: F.BindEnv -> [SymBinds] ---------------------------------------------------------------------------- -symBinds = M.toList +-------------------------------------------------------------------------------- +symBinds = {- THIS KILLS ELEM: tracepp "symBinds" . -} + M.toList . M.map Misc.groupList . Misc.group . binders @@ -78,54 +197,80 @@ binders be = [(x, (F.sr_sort t, i)) | (i, x, t) <- F.bindEnvToList be] ---------------------------------------------------------------------------- --- | Alpha Rename bindings to ensure each var appears in unique binder ---------------------------------------------------------------------------- -renameVV :: F.FInfo a -> F.FInfo a ---------------------------------------------------------------------------- -renameVV fi = fi {F.bs = be'} +-------------------------------------------------------------------------------- +-- | Drop func-sorted `bind` that are shadowed by `constant` (if same type, else error) +-------------------------------------------------------------------------------- +dropFuncSortedShadowedBinders :: F.SInfo a -> F.SInfo a +-------------------------------------------------------------------------------- +dropFuncSortedShadowedBinders fi = dropBinders f (const True) fi where - vts = map subcVV $ M.elems $ F.cm fi - be' = L.foldl' addVV be vts - be = F.bs fi - -addVV :: F.BindEnv -> (F.Symbol, F.SortedReft) -> F.BindEnv -addVV b (x, t) = snd $ F.insertBindEnv x t b + f x t = not (M.member x defs) || F.allowHO fi || isFirstOrder t + defs = M.fromList $ F.toListSEnv $ F.lits fi -subcVV :: F.SubC a -> (F.Symbol, F.SortedReft) -subcVV c = (x, sr) +-------------------------------------------------------------------------------- +-- | Drop functions from WfC environments +-------------------------------------------------------------------------------- +dropWfcFunctions :: F.SInfo a -> F.SInfo a +-------------------------------------------------------------------------------- +dropWfcFunctions fi | F.allowHO fi = fi +dropWfcFunctions fi = fi { F.ws = ws' } where - sr = F.slhs c - x = F.reftBind $ F.sr_reft sr + nonFunction = isNothing . F.functionSort + (_, discards) = filterBindEnv (const nonFunction) $ F.bs fi + ws' = deleteWfCBinds discards <$> F.ws fi ---------------------------------------------------------------------------- --- | Drop Higher-Order Binders and Constants from Environment ---------------------------------------------------------------------------- -dropHigherOrderBinders :: F.FInfo a -> F.FInfo a ---------------------------------------------------------------------------- -dropHigherOrderBinders fi = fi { F.bs = bs' , F.cm = cm' , F.ws = ws' , F.gs = gs' } +-------------------------------------------------------------------------------- +-- | Generic API for Deleting Binders from FInfo +-------------------------------------------------------------------------------- +dropBinders :: KeepBindF -> KeepSortF -> F.SInfo a -> F.SInfo a +-------------------------------------------------------------------------------- +dropBinders f g fi = fi { F.bs = bs' , F.cm = cm' , F.ws = ws' , F.lits = lits' } where - (bs', discards) = dropHOBinders (F.bs fi) - cm' = M.map (foo discards) (F.cm fi) - ws' = map (bar discards) (F.ws fi) - gs' = F.filterSEnv (isFirstOrder . F.sr_sort) (F.gs fi) + discards = {- tracepp "DISCARDING" -} diss + (bs', diss) = filterBindEnv f $ F.bs fi + cm' = deleteSubCBinds discards <$> F.cm fi + ws' = deleteWfCBinds discards <$> F.ws fi + lits' = F.filterSEnv g (F.lits fi) -foo :: [F.BindId] -> F.SubC a -> F.SubC a -foo discards sc = sc { F.senv = foldr F.deleteIBindEnv (F.senv sc) discards } -bar :: [F.BindId] -> F.WfC a -> F.WfC a -bar discards wf = wf { F.wenv = foldr F.deleteIBindEnv (F.wenv wf) discards } +type KeepBindF = F.Symbol -> F.Sort -> Bool +type KeepSortF = F.Sort -> Bool -dropHOBinders :: F.BindEnv -> (F.BindEnv, [F.BindId]) -dropHOBinders = filterBindEnv (isFirstOrder . F.sr_sort . Misc.thd3) +deleteSubCBinds :: [F.BindId] -> F.SimpC a -> F.SimpC a +deleteSubCBinds bs sc = sc { F._cenv = foldr F.deleteIBindEnv (F.senv sc) bs } -filterBindEnv f be = (F.bindEnvFromList keep, discard') +deleteWfCBinds :: [F.BindId] -> F.WfC a -> F.WfC a +deleteWfCBinds bs wf = wf { F.wenv = foldr F.deleteIBindEnv (F.wenv wf) bs } + +filterBindEnv :: KeepBindF -> F.BindEnv -> (F.BindEnv, [F.BindId]) +filterBindEnv f be = (F.bindEnvFromList keep, discard') where - (keep, discard) = L.partition f $ F.bindEnvToList be - discard' = map Misc.fst3 discard + (keep, discard) = L.partition f' $ F.bindEnvToList be + discard' = Misc.fst3 <$> discard + f' (_, x, t) = f x (F.sr_sort t) -isFirstOrder :: F.Sort -> Bool -isFirstOrder t = {- F.traceFix ("isFO: " ++ F.showFix t) -} (foldSort f 0 t <= 1) + +--------------------------------------------------------------------------- +-- | Replace KVars that do not have a WfC with PFalse +--------------------------------------------------------------------------- +replaceDeadKvars :: F.SInfo a -> F.SInfo a +--------------------------------------------------------------------------- +replaceDeadKvars fi = mapKVars go fi where - f n (F.FFunc _ _) = n + 1 - f n _ = n + go k | k `M.member` F.ws fi = Nothing + | otherwise = Just F.PFalse + +--------------------------------------------------------------------------- +-- | General helper functions +--------------------------------------------------------------------------- +-- domain :: F.BindEnv -> F.WfC a -> [F.Symbol] +-- domain be wfc = Misc.fst3 (F.wrft wfc) : map fst (F.envCs be $ F.wenv wfc) +-- +-- getDomain :: F.SInfo a -> F.KVar -> [F.Symbol] +-- getDomain si k = domain (F.bs si) (getWfC si k) +-- +-- getWfC :: F.SInfo a -> F.KVar -> F.WfC a +-- getWfC si k = Misc.mlookup (F.ws si) k +-- +-- freeVars :: F.Reft -> S.HashSet F.Symbol +-- freeVars rft@(F.Reft (v, _)) = S.delete v $ S.fromList $ F.syms rft diff --git a/src/Language/Fixpoint/Solver/Worklist.hs b/src/Language/Fixpoint/Solver/Worklist.hs --- a/src/Language/Fixpoint/Solver/Worklist.hs +++ b/src/Language/Fixpoint/Solver/Worklist.hs @@ -1,6 +1,10 @@ +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TupleSections #-} + module Language.Fixpoint.Solver.Worklist ( -- * Worklist type is opaque - Worklist + Worklist, Stats -- * Initialize , init @@ -11,118 +15,244 @@ -- * Add a constraint and all its dependencies , push + -- * Constraints with Concrete RHS + , unsatCandidates + + -- * Statistics + , wRanks ) where import Prelude hiding (init) -import Language.Fixpoint.Solver.Deps -import Language.Fixpoint.PrettyPrint -import Language.Fixpoint.Misc -import Language.Fixpoint.Config +import Language.Fixpoint.Types.PrettyPrint -- (PTable (..), PPrint (..)) import qualified Language.Fixpoint.Types as F +import Language.Fixpoint.Solver.Types +import Language.Fixpoint.Solver.Graph +import Control.Arrow (first) import qualified Data.HashMap.Strict as M import qualified Data.Set as S import qualified Data.List as L -import Data.Maybe (fromMaybe) +import Data.Graph (graphFromEdges) +import Text.PrettyPrint.HughesPJ (text) ---------------------------------------------------------------------------- -- | Worklist ------------------------------------------------------------- ---------------------------------------------------------------------------- +data Worklist a = WL { wCs :: !WorkSet + , wPend :: !(CMap ()) + , wDeps :: CSucc + , wCm :: !(CMap (F.SimpC a)) + , wRankm :: !(CMap Rank) + , wLast :: !(Maybe CId) + , wRanks :: !Int + , wTime :: !Int + , wConcCs :: ![CId] + } + +data Stats = Stats { numKvarCs :: !Int + , numConcCs :: !Int + , _numSccs :: !Int + } deriving (Eq, Show) + + +instance PPrint (Worklist a) where + pprintTidy k = pprintTidy k . S.toList . wCs + +instance PTable Stats where + ptable s = DocTable [ (text "# Sliced Constraints", pprint (numKvarCs s)) + , (text "# Target Constraints", pprint (numConcCs s)) + ] + +instance PTable (Worklist a) where + ptable = ptable . stats + + +-- | WorkItems ------------------------------------------------------------ + +type WorkSet = S.Set WorkItem + +data WorkItem = WorkItem { wiCId :: !CId -- ^ Constraint Id + , wiTime :: !Int -- ^ Time at which inserted + , wiRank :: !Rank -- ^ Rank of constraint + } deriving (Eq, Show) + +instance PPrint WorkItem where + pprintTidy _ = text . show + +instance Ord WorkItem where + compare (WorkItem i1 t1 r1) (WorkItem i2 t2 r2) + = mconcat [ compare (rScc r1) (rScc r2) -- SCC + , compare t1 t2 -- TimeStamp + , compare (rIcc r1) (rIcc r2) -- Inner SCC + , compare (rTag r1) (rTag r2) -- Tag + , compare i1 i2 -- Otherwise Set drops items + ] + +-- | Ranks --------------------------------------------------------------------- + +data Rank = Rank { rScc :: !Int -- ^ SCC number with ALL dependencies + , rIcc :: !Int -- ^ SCC number without CUT dependencies + , rTag :: !F.Tag -- ^ The constraint's Tag + } deriving (Eq, Show) + +-------------------------------------------------------------------------------- +-- | Initialize worklist and slice out irrelevant constraints ------------------ +-------------------------------------------------------------------------------- +init :: F.SInfo a -> Worklist a +-------------------------------------------------------------------------------- +init fi = WL { wCs = items + , wPend = addPends M.empty kvarCs + , wDeps = cSucc cd + , wCm = cm + , wRankm = rankm + , wLast = Nothing + , wRanks = cNumScc cd + , wTime = 0 + , wConcCs = concCs + } + where + cm = F.cm fi + cd = cDeps fi + rankm = cRank cd + items = S.fromList $ workItemsAt rankm 0 <$> kvarCs + concCs = fst <$> ics + kvarCs = fst <$> iks + (ics,iks) = L.partition (isTarget . snd) (M.toList cm) + --------------------------------------------------------------------------- -init :: Config -> F.FInfo a -> Worklist a +-- | Candidate Constraints to be checked AFTER computing Fixpoint --------- --------------------------------------------------------------------------- -init _ fi = WL roots (cSucc cd) (F.cm fi) - where - cd = cDeps fi - roots = S.fromList $ cRoots cd +unsatCandidates :: Worklist a -> [F.SimpC a] +--------------------------------------------------------------------------- +unsatCandidates w = [ lookupCMap (wCm w) i | i <- wConcCs w ] + --------------------------------------------------------------------------- -pop :: Worklist a -> Maybe (F.SubC a, Worklist a) +pop :: Worklist a -> Maybe (F.SimpC a, Worklist a, Bool, Int) --------------------------------------------------------------------------- pop w = do (i, is) <- sPop $ wCs w - Just (getC (wCm w) i, w {wCs = is}) + Just ( lookupCMap (wCm w) i + , popW w i is + , newSCC w i + , rank w i + ) -getC :: M.HashMap CId a -> CId -> a -getC cm i = fromMaybe err $ M.lookup i cm - where - err = errorstar "getC: bad CId i" +popW :: Worklist a -> CId -> WorkSet -> Worklist a +popW w i is = w { wCs = is + , wLast = Just i + , wPend = remPend (wPend w) i } ---------------------------------------------------------------------------- -push :: F.SubC a -> Worklist a -> Worklist a ---------------------------------------------------------------------------- -push c w = w {wCs = sAdds (wCs w) js} - where - i = sid' c - js = {- tracepp ("PUSH: id = " ++ show i) $ -} wDeps w i -sid' :: F.SubC a -> Integer -sid' c = fromMaybe err $ F.sid c +newSCC :: Worklist a -> CId -> Bool +newSCC oldW i = (rScc <$> oldRank) /= (rScc <$> newRank) where - err = errorstar "sid': SubC without id" + oldRank = lookupCMap rankm <$> wLast oldW + newRank = Just $ lookupCMap rankm i + rankm = wRankm oldW +rank :: Worklist a -> CId -> Int +rank w i = rScc $ lookupCMap (wRankm w) i + --------------------------------------------------------------------------- --- | Worklist ------------------------------------------------------------- +push :: F.SimpC a -> Worklist a -> Worklist a --------------------------------------------------------------------------- - -type CId = Integer -type CSucc = CId -> [CId] -type KVRead = M.HashMap F.KVar [CId] - -data Worklist a = WL { wCs :: S.Set CId - , wDeps :: CSucc - , wCm :: M.HashMap CId (F.SubC a) - } +push c w = w { wCs = sAdds (wCs w) wis' + , wTime = 1 + t + , wPend = addPends wp is' + } + where + i = F.subcId c + is' = filter (not . isPend wp) $ wDeps w i + wis' = workItemsAt (wRankm w) t <$> is' + t = wTime w + wp = wPend w -instance PPrint (Worklist a) where - pprint = pprint . S.toList . wCs +workItemsAt :: CMap Rank -> Int -> CId -> WorkItem +workItemsAt !r !t !i = WorkItem { wiCId = i + , wiTime = t + , wiRank = lookupCMap r i } --------------------------------------------------------------------------- -- | Constraint Dependencies ---------------------------------------------- --------------------------------------------------------------------------- -data CDeps = CDs { cRoots :: ![CId] - , cSucc :: CId -> [CId] +data CDeps = CDs { cSucc :: CSucc + , cRank :: CMap Rank + , cNumScc :: Int } -cDeps :: F.FInfo a -> CDeps -cDeps fi = CDs rs next +--------------------------------------------------------------------------- +cDeps :: F.SInfo a -> CDeps +--------------------------------------------------------------------------- +cDeps fi = CDs { cSucc = gSucc cg + , cNumScc = gSccs cg + , cRank = M.fromList [(i, rf i) | i <- is ] + } where - next = kvSucc fi - is = M.keys $ F.cm fi - is' = concatMap next is - rs = sortDiff is is' + rf = rankF (F.cm fi) outRs inRs + inRs = inRanks fi es outRs + outRs = gRanks cg + es = gEdges cg + cg = cGraph fi + cm = F.cm fi + is = M.keys cm -kvSucc :: F.FInfo a -> CSucc -kvSucc fi = succs cm rdBy +rankF :: CMap (F.SimpC a) -> CMap Int -> CMap Int -> CId -> Rank +rankF cm outR inR = \i -> Rank (outScc i) (inScc i) (tag i) where - rdBy = kvReadBy fi - cm = F.cm fi + outScc = lookupCMap outR + inScc = lookupCMap inR + tag = F._ctag . lookupCMap cm -succs :: M.HashMap CId (F.SubC a) -> KVRead -> CSucc -succs cm rdBy i = sortNub $ concatMap kvReads iKs + + +--------------------------------------------------------------------------- +inRanks :: F.SInfo a -> [DepEdge] -> CMap Int -> CMap Int +--------------------------------------------------------------------------- +inRanks fi es outR + | ks == mempty = outR + | otherwise = fst $ graphRanks g' vf' where - ci = getC cm i - iKs = rhsKVars ci - kvReads k = M.lookupDefault [] k rdBy + ks = F.kuts fi + cm = F.cm fi + (g', vf', _) = graphFromEdges es' + es' = [(i, i, filter (not . isCut i) js) | (i,_,js) <- es ] + isCut i j = S.member i cutCIds && isEqOutRank i j + isEqOutRank i j = lookupCMap outR i == lookupCMap outR j + cutCIds = S.fromList [i | i <- M.keys cm, isKutWrite i ] + isKutWrite = any (`F.ksMember` ks) . kvWriteBy cm -kvReadBy :: F.FInfo a -> KVRead -kvReadBy fi = group [ (k, i) | (i, ci) <- M.toList cm - , k <- {- tracepp ("lhsKVS: " ++ show i) $ -} - lhsKVars bs ci] + +--------------------------------------------------------------------------- +stats :: Worklist a -> Stats +--------------------------------------------------------------------------- +stats w = Stats (kn w) (cn w) (wRanks w) where - cm = F.cm fi - bs = F.bs fi + kn = M.size . wCm + cn = length . wConcCs +--------------------------------------------------------------------------- +-- | Pending API +--------------------------------------------------------------------------- +addPends :: CMap () -> [CId] -> CMap () +addPends = L.foldl' addPend + +addPend :: CMap () -> CId -> CMap () +addPend m i = M.insert i () m + +remPend :: CMap () -> CId -> CMap () +remPend m i = M.delete i m + +isPend :: CMap () -> CId -> Bool +isPend w i = M.member i w + --------------------------------------------------------------------------- -- | Set API -------------------------------------------------------------- --------------------------------------------------------------------------- -sAdds :: (Ord a) => S.Set a -> [a] -> S.Set a +sAdds :: WorkSet -> [WorkItem] -> WorkSet sAdds = L.foldl' (flip S.insert) -sPop :: S.Set a -> Maybe (a, S.Set a) -sPop = S.minView - +sPop :: WorkSet -> Maybe (CId, WorkSet) +sPop = fmap (first wiCId) . S.minView diff --git a/src/Language/Fixpoint/Sort.hs b/src/Language/Fixpoint/Sort.hs deleted file mode 100644 --- a/src/Language/Fixpoint/Sort.hs +++ /dev/null @@ -1,425 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - --- | This module has the functions that perform sort-checking, and related --- operations on Fixpoint expressions and predicates. - -module Language.Fixpoint.Sort ( - -- * Sort Substitutions - TVSubst - - -- * Checking Well-Formedness - , checkSorted - , checkSortedReft - , checkSortedReftFull - , checkSortFull - , pruneUnsortedReft - - -- * Unify - , unify - - -- * Apply Substitution - , apply - - -- * Exported Sorts - , boolSort - , strSort - ) where - - -import Control.Applicative -import Control.Monad -import Control.Monad.Error (catchError, throwError) -import qualified Data.HashMap.Strict as M -import Data.Maybe (catMaybes, fromMaybe) -import Language.Fixpoint.Misc -import Language.Fixpoint.Types -import Text.PrettyPrint.HughesPJ -import Text.Printf - - -------------------------------------------------------------------------- --- | Checking Refinements ----------------------------------------------- -------------------------------------------------------------------------- - --- | Types used throughout checker - -type CheckM a = Either String a -type Env = Symbol -> SESearch Sort - - -------------------------------------------------------------------------- --- | Checking Refinements ----------------------------------------------- -------------------------------------------------------------------------- - -checkSortedReft :: SEnv SortedReft -> [Symbol] -> SortedReft -> Maybe Doc -checkSortedReft env xs sr = applyNonNull Nothing error unknowns - where - error = Just . (text "Unknown symbols:" <+>) . toFix - unknowns = [ x | x <- syms sr, x `notElem` v : xs, not (x `memberSEnv` env)] - Reft (v,_) = sr_reft sr - -checkSortedReftFull :: Checkable a => SEnv SortedReft -> a -> Maybe Doc -checkSortedReftFull γ t - = case check γ' t of - Left err -> Just (text err) - Right _ -> Nothing - where - γ' = sr_sort <$> γ - -checkSortFull :: Checkable a => SEnv SortedReft -> Sort -> a -> Maybe Doc -checkSortFull γ s t - = case checkSort γ' s t of - Left err -> Just (text err) - Right _ -> Nothing - where - γ' = sr_sort <$> γ - -checkSorted :: Checkable a => SEnv Sort -> a -> Maybe Doc -checkSorted γ t - = case check γ t of - Left err -> Just (text err) - Right _ -> Nothing - -pruneUnsortedReft :: SEnv Sort -> SortedReft -> SortedReft -pruneUnsortedReft γ (RR s (Reft (v, Refa p))) = RR s (Reft (v, tx p)) - where - tx = refa . catMaybes . map (checkPred' f) . conjuncts - f = (`lookupSEnvWithDistance` γ') - γ' = insertSEnv v s γ - -- wmsg t r = "WARNING: prune unsorted reft:\n" ++ showFix r ++ "\n" ++ t - -checkPred' f p = res -- traceFix ("checkPred: p = " ++ showFix p) $ res - where - res = case checkPred f p of - Left war -> {- trace (wmsg war p) -} Nothing - Right _ -> Just p - -class Checkable a where - check :: SEnv Sort -> a -> CheckM () - checkSort :: SEnv Sort -> Sort -> a -> CheckM () - - checkSort γ _ = check γ - -instance Checkable Refa where - check γ = checkRefa (`lookupSEnvWithDistance` γ) - -checkRefa f (Refa p) = checkPred f p - -instance Checkable Expr where - check γ e = do {checkExpr f e; return ()} - where f = (`lookupSEnvWithDistance` γ) - - checkSort γ s e = void $ checkExpr f (ECst e s) - where - f = (`lookupSEnvWithDistance` γ) - -checkEqSort s t - | s == t = return () - | otherwise = throwError $ "Couldn't match expected type '" - ++ show s ++ "'" - ++ "\n\t\t with actual type '" - ++ show t ++ "'" - -instance Checkable Pred where - check γ = checkPred f - where f = (`lookupSEnvWithDistance` γ) - -instance Checkable SortedReft where - check γ (RR s (Reft (v, ra))) = check γ' ra - where - γ' = insertSEnv v s γ - -------------------------------------------------------------------------- --- | Checking Expressions ----------------------------------------------- -------------------------------------------------------------------------- - -checkExpr :: Env -> Expr -> CheckM Sort - -checkExpr _ EBot = throwError "Type Error: Bot" -checkExpr _ (ESym _) = return strSort -checkExpr _ (ECon (I _)) = return FInt -checkExpr _ (ECon (R _)) = return FReal -checkExpr _ (ECon (L _ s)) = return s -checkExpr f (EVar x) = checkSym f x -checkExpr f (ENeg e) = checkNeg f e -checkExpr f (EBin o e1 e2) = checkOp f e1 o e2 -checkExpr f (EIte p e1 e2) = checkIte f p e1 e2 -checkExpr f (ECst e t) = checkCst f t e -checkExpr f (EApp g es) = checkApp f Nothing g es -checkExpr f (ELit _ t) = return t - --- | Helper for checking symbol occurrences - -checkSym f x - = case f x of - Found s -> return s - Alts xs -> throwError $ errUnboundAlts x xs --- $ traceFix ("checkSym: x = " ++ showFix x) (f x) - -checkLocSym f x = checkSym f (val x) - --- | Helper for checking if-then-else expressions - -checkIte f p e1 e2 - = do tp <- checkPred f p - t1 <- checkExpr f e1 - t2 <- checkExpr f e2 - ((`apply` t1) <$> unifys [t1] [t2]) `catchError` (\_ -> throwError $ errIte e1 e2 t1 t2) - --- | Helper for checking cast expressions - -checkCst f t (EApp g es) - = checkApp f (Just t) g es -checkCst f t e - = do t' <- checkExpr f e - ((`apply` t) <$> unifys [t] [t']) `catchError` (\_ -> throwError $ errCast e t' t) - -checkApp f to g es - = snd <$> checkApp' f to g es - --- | Helper for checking uninterpreted function applications -checkApp' f to g es - = do gt <- checkLocSym f g - (n, its, ot) <- sortFunction gt - unless (length its == length es) $ throwError (errArgArity g its es) - ets <- mapM (checkExpr f) es - θ <- unifys its ets - let t = apply θ ot - case to of - Nothing -> return (θ, t) - Just t' -> do θ' <- unifyMany θ [t] [t'] - return (θ', apply θ' t) - - --- | Helper for checking binary (numeric) operations - -checkNeg f e = do - t <- checkExpr f e - case t of - FReal -> return FReal - FInt -> return FInt - (FObj l) -> checkNumeric f l >> return t - _ -> throwError $ printf "Operand has non-numeric type %s in %s" - (showFix t) (showFix e) - -checkOp f e1 o e2 - = do t1 <- checkExpr f e1 - t2 <- checkExpr f e2 - checkOpTy f (EBin o e1 e2) t1 t2 - -checkOpTy f _ FReal FReal - = return FReal - -checkOpTy f _ FInt FInt - = return FInt - -checkOpTy f e t@(FObj l) t'@(FObj l') - | l == l' - = checkNumeric f l >> return t - -checkOpTy f e t t' - = throwError $ errOp e t t' - -checkFractional f l - = do t <- checkSym f l - unless (t == FFrac) (throwError $ errNonFractional l) - return () - -checkNumeric f l - = do t <- checkSym f l - unless (t == FNum) (throwError $ errNonNumeric l) - return () - -------------------------------------------------------------------------- --- | Checking Predicates ------------------------------------------------ -------------------------------------------------------------------------- - -checkPred :: Env -> Pred -> CheckM () -checkPred _ PTrue = return () -checkPred _ PFalse = return () -checkPred f (PBexp e) = checkPredBExp f e -checkPred f (PNot p) = checkPred f p -checkPred f (PImp p p') = mapM_ (checkPred f) [p, p'] -checkPred f (PIff p p') = mapM_ (checkPred f) [p, p'] -checkPred f (PAnd ps) = mapM_ (checkPred f) ps -checkPred f (POr ps) = mapM_ (checkPred f) ps -checkPred f (PAtom r e e') = checkRel f r e e' -checkPred _ (PKVar {}) = return () -checkPred _ p = throwError $ errUnexpectedPred p - -checkPredBExp :: Env -> Expr -> CheckM () -checkPredBExp f e = do t <- checkExpr f e - unless (t == boolSort) (throwError $ errBExp e t) - return () - - --- | Checking Relations -checkRel :: (Symbol -> SESearch Sort) -> Brel -> Expr -> Expr -> CheckM () -checkRel f Eq (EVar x) (EApp g es) = checkRelEqVar f x g es -checkRel f Eq (EApp g es) (EVar x) = checkRelEqVar f x g es -checkRel f r e1 e2 = do t1 <- checkExpr f e1 - t2 <- checkExpr f e2 - checkRelTy f (PAtom r e1 e2) r t1 t2 - -checkRelTy :: (Fixpoint a) => Env -> a -> Brel -> Sort -> Sort -> CheckM () -checkRelTy f _ _ (FObj l) (FObj l') | l /= l' - = (checkNumeric f l >> checkNumeric f l') `catchError` (\_ -> throwError $ errNonNumerics l l') -checkRelTy f _ _ FInt (FObj l) = checkNumeric f l `catchError` (\_ -> throwError $ errNonNumeric l) -checkRelTy f _ _ (FObj l) FInt = checkNumeric f l `catchError` (\_ -> throwError $ errNonNumeric l) -checkRelTy _ _ _ FReal FReal = return () -checkRelTy f _ _ FReal (FObj l) = checkFractional f l `catchError` (\_ -> throwError $ errNonFractional l) -checkRelTy f _ _ (FObj l) FReal = checkFractional f l `catchError` (\_ -> throwError $ errNonFractional l) - -checkRelTy _ e Eq t1 t2 - | t1 == boolSort || - t2 == boolSort = throwError $ errRel e t1 t2 -checkRelTy _ e Ne t1 t2 - | t1 == boolSort || - t2 == boolSort = throwError $ errRel e t1 t2 -checkRelTy _ e Eq t1 t2 = unifys [t1] [t2] >> return () -checkRelTy _ e Ne t1 t2 = unifys [t1] [t2] >> return () - -checkRelTy _ e Ueq t1 t2 = return () -checkRelTy _ e Une t1 t2 = return () -checkRelTy _ e _ t1 t2 = unless (t1 == t2) (throwError $ errRel e t1 t2) - - --- | Special case for polymorphic singleton variable equality e.g. (x = Set_emp) - -checkRelEqVar f x g es = do tx <- checkSym f x - _ <- checkApp f (Just tx) g es - return () - --- | Special case for Unsorted Dis/Equality -isAppTy :: Sort -> Bool -isAppTy (FApp _ _) = True -isAppTy _ = False - - --- isPoly :: Sort -> Bool --- isPoly = not . null . fVars - -fVars (FVar i) = [i] -fVars (FFunc _ ts) = concatMap fVars ts -fVars (FApp _ ts) = concatMap fVars ts -fVars _ = [] - - -------------------------------------------------------------------------- --- | Unification of Sorts -------------------------------------------------------------------------- -unify :: Sort -> Sort -> Maybe TVSubst -------------------------------------------------------------------------- -unify t1 t2 = case unify1 emptySubst t1 t2 of - Left _ -> Nothing - Right su -> Just su - -------------------------------------------------------------------------- -unifys :: [Sort] -> [Sort] -> CheckM TVSubst -------------------------------------------------------------------------- -unifys = unifyMany emptySubst - -unifyMany :: TVSubst -> [Sort] -> [Sort] -> CheckM TVSubst -unifyMany θ ts ts' - | length ts == length ts' = foldM (uncurry . unify1) θ $ zip ts ts' - | otherwise = throwError $ errUnifyMany ts ts' - -unify1 :: TVSubst -> Sort -> Sort -> CheckM TVSubst -unify1 θ (FVar i) t = unifyVar θ i t -unify1 θ t (FVar i) = unifyVar θ i t -unify1 θ (FApp c ts) (FApp c' ts') - | c == c' = unifyMany θ ts ts' -unify1 θ t1 t2 - | t1 == t2 = return θ - | otherwise = throwError $ errUnify t1 t2 --- unify1 _ FNum _ = Nothing - -unifyVar :: TVSubst -> Int -> Sort -> CheckM TVSubst -unifyVar θ i t@(FVar j) - = case lookupVar i θ of - Just t' -> if t == t' then return θ else return $ updateVar j t' θ - Nothing -> return $ updateVar i t θ - -unifyVar θ i t - = case lookupVar i θ of - Just t' -> if t == t' then return θ else throwError (errUnify t t') - Nothing -> return $ updateVar i t θ - -------------------------------------------------------------------------- --- | Applying a Type Substitution --------------------------------------- -------------------------------------------------------------------------- -apply :: TVSubst -> Sort -> Sort -------------------------------------------------------------------------- -apply θ = sortMap f - where - f t@(FVar i) = fromMaybe t (lookupVar i θ) - f t = t - -------------------------------------------------------------------------- -sortMap :: (Sort -> Sort) -> Sort -> Sort -------------------------------------------------------------------------- -sortMap f (FFunc n ts) = FFunc n (sortMap f <$> ts) -sortMap f (FApp c ts) = FApp c (sortMap f <$> ts) -sortMap f t = f t - ------------------------------------------------------------------------- --- | Deconstruct a function-sort --------------------------------------- ------------------------------------------------------------------------- - -sortFunction :: Sort -> CheckM (Int, [Sort], Sort) -sortFunction (FFunc n ts') = return (n, ts, t) - where - ts = take numArgs ts' - t = last ts' - numArgs = length ts' - 1 - -sortFunction t = throwError $ errNonFunction t - - ------------------------------------------------------------------------- --- | API for manipulating Sort Substitutions --------------------------- ------------------------------------------------------------------------- - -newtype TVSubst = Th (M.HashMap Int Sort) - -lookupVar :: Int -> TVSubst -> Maybe Sort -lookupVar i (Th m) = M.lookup i m - -updateVar :: Int -> Sort -> TVSubst -> TVSubst -updateVar i t (Th m) = Th (M.insert i t m) - -emptySubst :: TVSubst -emptySubst = Th M.empty - -------------------------------------------------------------------------- --- | Error messages ----------------------------------------------------- -------------------------------------------------------------------------- - -errUnify t1 t2 = printf "Cannot unify %s with %s" (showFix t1) (showFix t2) - -errUnifyMany ts ts' = printf "Cannot unify types with different cardinalities %s and %s" - (showFix ts) (showFix ts') -errRel e t1 t2 = printf "Invalid Relation %s with operand types %s and %s" - (showFix e) (showFix t1) (showFix t2) -errBExp e t = printf "BExp %s with non-propositional type %s" (showFix e) (showFix t) -errOp e t t' - | t == t' = printf "Operands have non-numeric types %s in %s" - (showFix t) (showFix e) - | otherwise = printf "Operands have different types %s and %s in %s" - (showFix t) (showFix t') (showFix e) -errArgArity g its es = printf "Measure %s expects %d args but gets %d in %s" - (showFix g) (length its) (length es) (showFix (EApp g es)) -errIte e1 e2 t1 t2 = printf "Mismatched branches in Ite: then %s : %s, else %s : %s" - (showFix e1) (showFix t1) (showFix e2) (showFix t2) -errCast e t' t = printf "Cannot cast %s of sort %s to incompatible sort %s" - (showFix e) (showFix t') (showFix t) -errUnbound x = printf "Unbound Symbol %s" (showFix x) -errUnboundAlts x xs = printf "Unbound Symbol %s\n Perhaps you meant: %s" - (showFix x) - (foldr1 (\w s -> w ++ ", " ++ s) (showFix <$> xs)) -errNonFunction t = printf "Sort %s is not a function" (showFix t) -errNonNumeric l = printf "FObj sort %s is not numeric" (showFix l) -errNonNumerics l l' = printf "FObj sort %s and %s are different and not numeric" (showFix l) (showFix l') -errNonFractional l = printf "FObj sort %s is not fractional" (showFix l) -errUnexpectedPred p = printf "Sort Checking: Unexpected Predicate %s" (showFix p) - diff --git a/src/Language/Fixpoint/SortCheck.hs b/src/Language/Fixpoint/SortCheck.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fixpoint/SortCheck.hs @@ -0,0 +1,750 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | This module has the functions that perform sort-checking, and related +-- operations on Fixpoint expressions and predicates. + +module Language.Fixpoint.SortCheck ( + -- * Sort Substitutions + TVSubst + , Env + + -- * Checking Well-Formedness + , checkSorted + , checkSortedReft + , checkSortedReftFull + , checkSortFull + , pruneUnsortedReft + + -- * Sort inference + , sortExpr, checkSortExpr + + -- * Unify + , unifyFast + , unify + + -- * Apply Substitution + , apply + + -- * Exported Sorts + , boolSort + , strSort + , elaborate + + -- * Predicates on Sorts + , isFirstOrder + , isMono + ) where + + +import Control.Monad +import Control.Monad.Except (MonadError(..)) +import qualified Data.HashMap.Strict as M +import qualified Data.List as L +import Data.Maybe (mapMaybe, fromMaybe) + +import Language.Fixpoint.Types.PrettyPrint +import Language.Fixpoint.Misc +import Language.Fixpoint.Types hiding (subst) +import Language.Fixpoint.Types.Visitor (foldSort) +import Language.Fixpoint.Smt.Theories (theoryEnv) +import Text.PrettyPrint.HughesPJ +import Text.Printf + +-- import Debug.Trace + +------------------------------------------------------------------------- +-- | Predicates on Sorts ------------------------------------------------ +------------------------------------------------------------------------- + +------------------------------------------------------------------------- +isFirstOrder :: Sort -> Bool +------------------------------------------------------------------------- +isFirstOrder (FAbs _ t) = isFirstOrder t +isFirstOrder (FFunc s1 s2) = noFun s1 && isFirstOrder s2 +isFirstOrder _ = True + +noFun (FFunc _ _) = False +noFun (FAbs _ _) = False +noFun _ = True + +------------------------------------------------------------------------- +isMono :: Sort -> Bool +------------------------------------------------------------------------- +isMono = null . foldSort fv [] + where + fv vs (FVar i) = i : vs + fv vs _ = vs + +------------------------------------------------------------------------- +-- | Sort Inference ----------------------------------------------- +------------------------------------------------------------------------- + +sortExpr :: SrcSpan -> SEnv Sort -> Expr -> Sort +sortExpr l γ e = case runCM0 $ checkExpr f e of + Left msg -> die $ err l (d msg) + Right s -> s + where + f = (`lookupSEnvWithDistance` γ) + d m = vcat [ "sortExpr failed on expression:" + , nest 4 (pprint e) + , "with error:" + , nest 4 (text m)] + +checkSortExpr :: SEnv Sort -> Expr -> Maybe Sort +checkSortExpr γ e = case runCM0 $ checkExpr f e of + Left _ -> Nothing + Right s -> Just s + where + f x = case lookupSEnv x γ of + Just z -> Found z + Nothing -> Alts [] + + +elaborate :: SEnv Sort -> Expr -> Expr +elaborate γ e + = case runCM0 $ elab f e of + Left msg -> die $ err dummySpan (d msg) + Right s -> fst s + where + f = (`lookupSEnvWithDistance` γ') + γ' = unionSEnv γ theoryEnv + d m = vcat [ "elaborate failed on:" + , nest 4 (pprint e) + , "with error" + , nest 4 (text m) ] + +------------------------------------------------------------------------- +-- | Checking Refinements ----------------------------------------------- +------------------------------------------------------------------------- + +-- | Types used throughout checker + +type StateM = Int + +newtype CheckM a = CM {runCM :: StateM -> (StateM, Either String a)} + +type Env = Symbol -> SESearch Sort + +instance Monad CheckM where + return x = CM $ \i -> (i, Right x) + (CM m) >>= f = CM $ \i -> case m i of + (j, Left s) -> (j, Left s) + (j, Right x) -> runCM (f x) j + + +instance MonadError String CheckM where + throwError s = CM $ \i -> (i, Left s) + (CM m) `catchError` f = CM $ \i -> case m i of + (j, Left s) -> runCM (f s) j + (j, Right x) -> (j, Right x) + +instance Functor CheckM where + fmap f (CM m) = CM $ \i -> case m i of {(j, Left s) -> (j, Left s); (j, Right x) -> (j, Right $ f x)} + +instance Applicative CheckM where + pure x = CM $ \i -> (i, Right x) + (CM f) <*> (CM m) = CM $ \i -> case m i of + (j, Left s) -> (j, Left s) + (_, Right x) -> case f i of + (k, Left s) -> (k, Left s) + (k, Right g) -> (k, Right $ g x) + +initCM = 42 +runCM0 act = snd $ runCM act initCM + +class Freshable a where + fresh :: CheckM a + refresh :: a -> CheckM a + refresh _ = fresh + +instance Freshable Int where + fresh = CM (\n -> (n+1, Right n)) + +instance Freshable [Int] where + fresh = mapM (const fresh) [0..] + refresh = mapM refresh + +------------------------------------------------------------------------- +-- | Checking Refinements ----------------------------------------------- +------------------------------------------------------------------------- + +checkSortedReft :: SEnv SortedReft -> [Symbol] -> SortedReft -> Maybe Doc +checkSortedReft env xs sr = applyNonNull Nothing oops unknowns + where + oops = Just . (text "Unknown symbols:" <+>) . toFix + unknowns = [ x | x <- syms sr, x `notElem` v : xs, not (x `memberSEnv` env)] + Reft (v,_) = sr_reft sr + +checkSortedReftFull :: Checkable a => SEnv SortedReft -> a -> Maybe Doc +checkSortedReftFull γ t + = case runCM0 $ check γ' t of + Left e -> Just (text e) + Right _ -> Nothing + where + γ' = sr_sort <$> γ + +checkSortFull :: Checkable a => SEnv SortedReft -> Sort -> a -> Maybe Doc +checkSortFull γ s t + = case runCM0 $ checkSort γ' s t of + Left e -> Just (text e) + Right _ -> Nothing + where + γ' = sr_sort <$> γ + +checkSorted :: Checkable a => SEnv Sort -> a -> Maybe Doc +checkSorted γ t + = case runCM0 $ check γ t of + Left e -> Just (text e) + Right _ -> Nothing + +pruneUnsortedReft :: SEnv Sort -> SortedReft -> SortedReft +pruneUnsortedReft γ (RR s (Reft (v, p))) = RR s (Reft (v, tx p)) + where + tx = pAnd . mapMaybe (checkPred' f) . conjuncts + f = (`lookupSEnvWithDistance` γ') + γ' = insertSEnv v s γ + -- wmsg t r = "WARNING: prune unsorted reft:\n" ++ showFix r ++ "\n" ++ t + +checkPred' f p = res -- traceFix ("checkPred: p = " ++ showFix p) $ res + where + res = case runCM0 $ checkPred f p of + Left _err -> {- trace (_wmsg _err p) -} Nothing + Right _ -> Just p + +class Checkable a where + check :: SEnv Sort -> a -> CheckM () + checkSort :: SEnv Sort -> Sort -> a -> CheckM () + + checkSort γ _ = check γ + +instance Checkable Expr where + check γ e = void $ checkExpr f e + where f = (`lookupSEnvWithDistance` γ) + + checkSort γ s e = void $ checkExpr f (ECst e s) + where + f = (`lookupSEnvWithDistance` γ) + +instance Checkable SortedReft where + check γ (RR s (Reft (v, ra))) = check γ' ra + where + γ' = insertSEnv v s γ + +------------------------------------------------------------------------- +-- | Checking Expressions ----------------------------------------------- +------------------------------------------------------------------------- + +checkExpr :: Env -> Expr -> CheckM Sort + +checkExpr _ (ESym _) = return strSort +checkExpr _ (ECon (I _)) = return FInt +checkExpr _ (ECon (R _)) = return FReal +checkExpr _ (ECon (L _ s)) = return s +checkExpr f (EVar x) = checkSym f x +checkExpr f (ENeg e) = checkNeg f e +checkExpr f (EBin o e1 e2) = checkOp f e1 o e2 +checkExpr f (EIte p e1 e2) = checkIte f p e1 e2 +checkExpr f (ECst e t) = checkCst f t e +checkExpr f (EApp g e) = checkApp f Nothing g e +checkExpr f (PNot p) = checkPred f p >> return boolSort +checkExpr f (PImp p p') = mapM_ (checkPred f) [p, p'] >> return boolSort +checkExpr f (PIff p p') = mapM_ (checkPred f) [p, p'] >> return boolSort +checkExpr f (PAnd ps) = mapM_ (checkPred f) ps >> return boolSort +checkExpr f (POr ps) = mapM_ (checkPred f) ps >> return boolSort +checkExpr f (PAtom r e e') = checkRel f r e e' >> return boolSort +checkExpr _ (PKVar {}) = return boolSort +checkExpr _ PGrad = return boolSort + +checkExpr f (PAll bs e ) = checkExpr (addEnv f bs) e +checkExpr f (PExist bs e) = checkExpr (addEnv f bs) e +checkExpr f (ELam (x,t) e) = FFunc t <$> checkExpr (addEnv f [(x,t)]) e +checkExpr _ (ETApp _ _) = error "SortCheck.checkExpr: TODO: implement ETApp" +checkExpr _ (ETAbs _ _) = error "SortCheck.checkExpr: TODO: implement ETAbs" + +addEnv :: Eq a => (a -> SESearch b) -> [(a, b)] -> a -> SESearch b +addEnv f bs x + = case L.lookup x bs of + Just s -> Found s + Nothing -> f x + +-------------------------------------------------------------------------------- +-- | Elaborate expressions with types to make polymorphic instantiation explicit. +-------------------------------------------------------------------------------- +elab :: Env -> Expr -> CheckM (Expr, Sort) +-------------------------------------------------------------------------------- +elab f e@(EBin o e1 e2) = do + (e1', s1) <- elab f e1 + (e2', s2) <- elab f e2 + s <- checkExpr f e + return (EBin o (ECst e1' s1) (ECst e2' s2), s) + +elab f (EApp e1@(EApp _ _) e2) = do + (e1', _, e2', s2, s) <- elabEApp f e1 e2 + return (EApp e1' (ECst e2' s2), s) + +elab f (EApp e1 e2) = do + (e1', s1, e2', s2, s) <- elabEApp f e1 e2 + return (EApp (ECst e1' s1) (ECst e2' s2), s) + +elab _ e@(ESym _) = + return (e, strSort) + +elab _ e@(ECon (I _)) = + return (e, FInt) + +elab _ e@(ECon (R _)) = + return (e, FReal) + +elab _ e@(ECon (L _ s)) = + return (e, s) + +elab _ e@(PKVar _ _) = + return (e, boolSort) + +elab _ e@PGrad = + return (e, boolSort) + +elab f e@(EVar x) = + (e,) <$> checkSym f x + +elab f (ENeg e) = do + (e', s) <- elab f e + return (ENeg e', s) + +elab f (EIte p e1 e2) = do + (p', _) <- elab f p + (e1', _) <- elab f e1 + (e2', _) <- elab f e2 + s <- checkIte f p e1 e2 + return (EIte p' e1' e2', s) + +elab f (ECst e t) = do + (e', _) <- elab f e + return (ECst e' t, t) + +elab f (PNot p) = do + (e', _) <- elab f p + return (PNot e', boolSort) + +elab f (PImp p1 p2) = do + (p1', _) <- elab f p1 + (p2', _) <- elab f p2 + return (PImp p1' p2', boolSort) + +elab f (PIff p1 p2) = do + (p1', _) <- elab f p1 + (p2', _) <- elab f p2 + return (PIff p1' p2', boolSort) + +elab f (PAnd ps) = do + ps' <- mapM (elab f) ps + return (PAnd (fst <$> ps'), boolSort) + +elab f (POr ps) = do + ps' <- mapM (elab f) ps + return (POr (fst <$> ps'), boolSort) + +elab f (PAtom Eq e1 e2) = do + t1 <- checkExpr f e1 + t2 <- checkExpr f e2 + (t1',t2') <- unite f t1 t2 + e1' <- elabAs f t1' e1 + e2' <- elabAs f t2' e2 + return (PAtom Eq e1' e2', boolSort) + +elab f (PAtom r e1 e2) = do + (e1', _) <- elab f e1 + (e2', _) <- elab f e2 + return (PAtom r e1' e2', boolSort) + +elab f (PExist bs e) = do + (e', s) <- elab (addEnv f bs) e + return (PExist bs e', s) + +elab f (PAll bs e) = do + (e', s) <- elab (addEnv f bs) e + return (PAll bs e', s) + +elab f (ELam (x,t) e) = do + (e', s) <- elab (addEnv f [(x,t)]) e + return (ELam (x,t) (ECst e' s), FFunc t s) + +elab _ (ETApp _ _) = + error "SortCheck.elab: TODO: implement ETApp" +elab _ (ETAbs _ _) = + error "SortCheck.elab: TODO: implement ETAbs" + +elabAs :: Env -> Sort -> Expr -> CheckM Expr +elabAs f t e@(EApp {}) = elabAppAs f t g es where (g, es) = splitEApp e +elabAs f _ e = fst <$> elab f e + +elabAppAs :: Env -> Sort -> Expr -> [Expr] -> CheckM Expr +elabAppAs f t g es = do + gT <- generalize =<< checkExpr f g + eTs <- mapM (checkExpr f) es + gTios <- sortFunction (length es) gT + su <- unifys f (snd gTios:fst gTios) (t:eTs) + let tg = apply su gT + g' <- elabAs f tg g + let ts = apply su <$> eTs + es' <- zipWithM (elabAs f) ts es + return $ eApps (ECst g' tg) (zipWith ECst es' ts) + +elabEApp :: Env -> Expr -> Expr -> CheckM (Expr, Sort, Expr, Sort, Sort) +elabEApp f e1 e2 = do + (e1', s1) <- elab f e1 + (e2', s2) <- elab f e2 + s <- elabAppSort f s1 s2 + return (e1', s1, e2', s2, s) + +unite :: Env -> Sort -> Sort -> CheckM (Sort, Sort) +-- unite' f t1@(FObj l) t2@FInt = do + -- checkNumeric f l + -- return (t1, t2) +-- unite' f t1@FInt t2@(FObj l) = do + -- checkNumeric f l + -- return (t1, t2) +unite f t1 t2 = do + su <- unifys f [t1] [t2] + return (apply su t1, apply su t2) + +-- | Helper for checking symbol occurrences +checkSym :: Env -> Symbol -> CheckM Sort +checkSym f x + = case f x of + Found s -> return s + Alts xs -> throwError $ errUnboundAlts x xs + +-- | Helper for checking if-then-else expressions +checkIte :: Env -> Expr -> Expr -> Expr -> CheckM Sort +checkIte f p e1 e2 + = do checkPred f p + t1 <- checkExpr f e1 + t2 <- checkExpr f e2 + ((`apply` t1) <$> unifys f [t1] [t2]) `catchError` (\_ -> throwError $ errIte e1 e2 t1 t2) + +-- | Helper for checking cast expressions +checkCst :: Env -> Sort -> Expr -> CheckM Sort +checkCst f t (EApp g e) + = checkApp f (Just t) g e +checkCst f t e + = do t' <- checkExpr f e + ((`apply` t) <$> unifys f [t] [t']) `catchError` (\_ -> throwError $ errCast e t' t) + +elabAppSort :: Env -> Sort -> Sort -> CheckM Sort +elabAppSort f s1 s2 = + do s1' <- generalize s1 + case s1' of + FFunc sx s -> do θ <- unifys f [sx] [s2] + return $ apply θ s + _ -> errorstar "Foo" + +checkApp :: Env -> Maybe Sort -> Expr -> Expr -> CheckM Sort +checkApp f to g es + = snd <$> checkApp' f to g es + +checkExprAs :: Env -> Sort -> Expr -> CheckM Sort +checkExprAs f t (EApp g e) + = checkApp f (Just t) g e +checkExprAs f t e + = do t' <- checkExpr f e + θ <- unifys f [t'] [t] + return $ apply θ t + +-- | Helper for checking uninterpreted function applications +checkApp' :: Env -> Maybe Sort -> Expr -> Expr -> CheckM (TVSubst, Sort) +checkApp' f to g' e + = do gt <- checkExpr f g + gt' <- generalize gt + (its, ot) <- sortFunction (length es) gt' + ets <- mapM (checkExpr f) es + θ <- unifys f its ets + let t = apply θ ot + case to of + Nothing -> return (θ, t) + Just t' -> do θ' <- unifyMany f θ [t] [t'] + let ts = apply θ' <$> ets + _ <- zipWithM (checkExprAs f) ts es + return (θ', apply θ' t) + where + (g, es) = splitEApp $ EApp g' e + +-- | Helper for checking binary (numeric) operations +checkNeg :: Env -> Expr -> CheckM Sort +checkNeg f e = do + t <- checkExpr f e + case t of + FReal -> return FReal + FInt -> return FInt + (FObj l) -> checkNumeric f l >> return t + _ -> throwError $ printf "Operand has non-numeric type %s in %s" + (showFix t) (showFix e) + +checkOp :: Env -> Expr -> Bop -> Expr -> CheckM Sort +checkOp f e1 o e2 + = do t1 <- checkExpr f e1 + t2 <- checkExpr f e2 + checkOpTy f (EBin o e1 e2) t1 t2 + +checkOpTy :: PPrint a => Env -> a -> Sort -> Sort -> CheckM Sort +checkOpTy _ _ FInt FInt + = return FInt + +checkOpTy _ _ FReal FReal + = return FReal +-- Coercing int to real is somewhat suspicious, but z3 seems +-- to be ok with it +checkOpTy _ _ FInt FReal + = return FReal +checkOpTy _ _ FReal FInt + = return FReal + +checkOpTy f _ t@(FObj l) (FObj l') + | l == l' + = checkNumeric f l >> return t + +checkOpTy _ e t t' + = throwError $ errOp e t t' + +checkFractional :: Env -> Symbol -> CheckM () +checkFractional f l + = do t <- checkSym f l + unless (t == FFrac) (throwError $ errNonFractional l) + return () + +checkNumeric :: Env -> Symbol -> CheckM () +checkNumeric f l + = do t <- checkSym f l + unless (t == FNum || t == FFrac) (throwError $ errNonNumeric l) + return () + +------------------------------------------------------------------------- +-- | Checking Predicates ------------------------------------------------ +------------------------------------------------------------------------- + +checkPred :: Env -> Expr -> CheckM () +checkPred f e = checkExpr f e >>= checkBoolSort e + +checkBoolSort :: Expr -> Sort -> CheckM () +checkBoolSort e s + | s == boolSort = return () + | otherwise = throwError $ errBoolSort e s + +-- | Checking Relations +checkRel :: Env -> Brel -> Expr -> Expr -> CheckM () +checkRel f Eq e1 e2 = do t1 <- checkExpr f e1 + t2 <- checkExpr f e2 + su <- unifys f [t1] [t2] + checkExprAs f (apply su t1) e1 + checkExprAs f (apply su t2) e2 + checkRelTy f (PAtom Eq e1 e2) Eq t1 t2 +checkRel f r e1 e2 = do t1 <- checkExpr f e1 + t2 <- checkExpr f e2 + checkRelTy f (PAtom r e1 e2) r t1 t2 + +checkRelTy :: (Fixpoint a, PPrint a) => Env -> a -> Brel -> Sort -> Sort -> CheckM () +checkRelTy f _ _ (FObj l) (FObj l') | l /= l' + = (checkNumeric f l >> checkNumeric f l') `catchError` (\_ -> throwError $ errNonNumerics l l') +checkRelTy f _ _ FInt (FObj l) = checkNumeric f l `catchError` (\_ -> throwError $ errNonNumeric l) +checkRelTy f _ _ (FObj l) FInt = checkNumeric f l `catchError` (\_ -> throwError $ errNonNumeric l) +checkRelTy _ _ _ FReal FReal = return () +checkRelTy _ _ _ FInt FReal = return () +checkRelTy _ _ _ FReal FInt = return () +checkRelTy f _ _ FReal (FObj l) = checkFractional f l `catchError` (\_ -> throwError $ errNonFractional l) +checkRelTy f _ _ (FObj l) FReal = checkFractional f l `catchError` (\_ -> throwError $ errNonFractional l) + +checkRelTy _ e Eq t1 t2 + | t1 == boolSort || + t2 == boolSort = throwError $ errRel e t1 t2 +checkRelTy _ e Ne t1 t2 + | t1 == boolSort || + t2 == boolSort = throwError $ errRel e t1 t2 +checkRelTy f _ Eq t1 t2 = void $ unifys f [t1] [t2] +checkRelTy f _ Ne t1 t2 = void $ unifys f [t1] [t2] + +checkRelTy _ _ Ueq _ _ = return () +checkRelTy _ _ Une _ _ = return () +checkRelTy _ e _ t1 t2 = unless (t1 == t2) (throwError $ errRel e t1 t2) + +------------------------------------------------------------------------- +-- | Sort Unification +------------------------------------------------------------------------- +unify :: Env -> Sort -> Sort -> Maybe TVSubst +------------------------------------------------------------------------- +unify f t1 t2 + = case runCM0 $ unify1 f emptySubst t1 t2 of + Left _ -> Nothing + Right su -> Just su + + +------------------------------------------------------------------------- +-- | Fast Unification; `unifyFast True` is just equality +------------------------------------------------------------------------- +unifyFast :: Bool -> Env -> Sort -> Sort -> Maybe TVSubst +------------------------------------------------------------------------- +unifyFast False f = unify f +unifyFast True _ = uMono + where + uMono t1 t2 + | t1 == t2 = Just emptySubst + | otherwise = Nothing + +------------------------------------------------------------------------- +unifys :: Env -> [Sort] -> [Sort] -> CheckM TVSubst +------------------------------------------------------------------------- +unifys f = unifyMany f emptySubst + +unifyMany :: Env -> TVSubst -> [Sort] -> [Sort] -> CheckM TVSubst +unifyMany f θ ts ts' + | length ts == length ts' = foldM (uncurry . unify1 f) θ $ zip ts ts' + | otherwise = throwError $ errUnifyMany ts ts' + + +unify1 :: Env -> TVSubst -> Sort -> Sort -> CheckM TVSubst +unify1 f θ (FVar i) t + = unifyVar f θ i t +unify1 f θ t (FVar i) + = unifyVar f θ i t +unify1 f θ (FApp t1 t2) (FApp t1' t2') + = unifyMany f θ [t1, t2] [t1', t2'] +unify1 _ θ (FTC l1) (FTC l2) + | isListTC l1 && isListTC l2 + = return θ +unify1 f θ t1@(FAbs _ _) t2 = do + t1'<- generalize t1 + unifyMany f θ [t1'] [t2] +unify1 f θ t1 t2@(FAbs _ _) = do + t2' <- generalize t2 + unifyMany f θ [t1] [t2'] + +unify1 f θ (FObj l) FInt = do + checkNumeric f l + return θ + +unify1 f θ FInt (FObj l) = do + checkNumeric f l + return θ + +unify1 _ θ FInt FReal = return θ +unify1 _ θ FReal FInt = return θ + +unify1 f θ (FFunc t1 t2) (FFunc t1' t2') = do + unifyMany f θ [t1, t2] [t1', t2'] + +unify1 _ θ t1 t2 + | t1 == t2 + = return θ + | otherwise + = throwError $ errUnify t1 t2 + +subst :: (Int, Sort) -> Sort -> Sort +subst (j,tj) t@(FVar i) + | i == j = tj + | otherwise = t +subst su (FApp t1 t2) = FApp (subst su t1) (subst su t2) +subst _ (FTC l) = FTC l +subst su (FFunc t1 t2) = FFunc (subst su t1) (subst su t2) +subst (j,tj) (FAbs i t) + | i == j = FAbs i t + | otherwise = FAbs i $ subst (j,tj) t +subst _ s = s + + +generalize :: Sort -> CheckM Sort +generalize (FAbs i t) = do + v <- refresh 0 + let sub = (i, FVar v) + subst sub <$> generalize t +generalize t = + return t + +unifyVar :: Env -> TVSubst -> Int -> Sort -> CheckM TVSubst +unifyVar _ θ i t@(FVar j) + = case lookupVar i θ of + Just t' -> if t == t' then return θ else return $ updateVar j t' θ + Nothing -> return $ updateVar i t θ + +unifyVar f θ i t + = case lookupVar i θ of + Just (FVar j) -> return $ updateVar i t $ updateVar j t θ + Just t' -> if t == t' then return θ else unify1 f θ t t' + Nothing -> return $ updateVar i t θ + +------------------------------------------------------------------------- +-- | Applying a Type Substitution --------------------------------------- +------------------------------------------------------------------------- +apply :: TVSubst -> Sort -> Sort +------------------------------------------------------------------------- +apply θ = sortMap f + where + f t@(FVar i) = fromMaybe t (lookupVar i θ) + f t = t + +------------------------------------------------------------------------- +sortMap :: (Sort -> Sort) -> Sort -> Sort +------------------------------------------------------------------------- +sortMap f (FAbs i t) = FAbs i (sortMap f t) +sortMap f (FFunc t1 t2) = FFunc (sortMap f t1) (sortMap f t2) +sortMap f (FApp t1 t2) = FApp (sortMap f t1) (sortMap f t2) +sortMap f t = f t + +------------------------------------------------------------------------ +-- | Deconstruct a function-sort --------------------------------------- +------------------------------------------------------------------------ + +sortFunction :: Int -> Sort -> CheckM ([Sort], Sort) +sortFunction i t + = case functionSort t of + Nothing -> throwError $ errNonFunction i t + Just (_, ts, t') -> if length ts < i + then throwError $ errNonFunction i t + else let (its, ots) = splitAt i ts + in return (its, foldl FFunc t' ots) + +------------------------------------------------------------------------ +-- | API for manipulating Sort Substitutions --------------------------- +------------------------------------------------------------------------ + +newtype TVSubst = Th (M.HashMap Int Sort) deriving (Show) + +lookupVar :: Int -> TVSubst -> Maybe Sort +lookupVar i (Th m) = M.lookup i m + +updateVar :: Int -> Sort -> TVSubst -> TVSubst +updateVar i t (Th m) = Th (M.insert i t m) + +emptySubst :: TVSubst +emptySubst = Th M.empty + +------------------------------------------------------------------------- +-- | Error messages ----------------------------------------------------- +------------------------------------------------------------------------- + +errUnify t1 t2 = printf "Cannot unify %s with %s" (showpp t1) (showpp t2) + +errUnifyMany ts ts' = printf "Cannot unify types with different cardinalities %s and %s" + (showpp ts) (showpp ts') +errRel e t1 t2 = printf "Invalid Relation %s with operand types %s and %s" + (showpp e) (showpp t1) (showpp t2) +errOp e t t' + | t == t' = printf "Operands have non-numeric types %s in %s" + (showpp t) (showpp e) + | otherwise = printf "Operands have different types %s and %s in %s" + (showpp t) (showpp t') (showpp e) +errIte e1 e2 t1 t2 = printf "Mismatched branches in Ite: then %s : %s, else %s : %s" + (showpp e1) (showpp t1) (showpp e2) (showpp t2) +errCast e t' t = printf "Cannot cast %s of sort %s to incompatible sort %s" + (showpp e) (showpp t') (showpp t) +errUnboundAlts x xs = printf "Unbound Symbol %s\n Perhaps you meant: %s" + (showpp x) + (foldr1 (\w s -> w ++ ", " ++ s) (showpp <$> xs)) +errNonFunction i t = printf "Sort %s is not a function with at least %s arguments" (showpp t) (showpp i) +errNonNumeric l = printf "FObj sort %s is not numeric" (showpp l) +errNonNumerics l l' = printf "FObj sort %s and %s are different and not numeric" (showpp l) (showpp l') +errNonFractional l = printf "FObj sort %s is not fractional" (showpp l) +errBoolSort e s = printf "Expressions %s should have bool sort, but has %s" (showpp e) (showpp s) diff --git a/src/Language/Fixpoint/Statistics.hs b/src/Language/Fixpoint/Statistics.hs deleted file mode 100644 --- a/src/Language/Fixpoint/Statistics.hs +++ /dev/null @@ -1,81 +0,0 @@ --- | This module implements functions that print out --- statistics about the constraints. -{-# LANGUAGE CPP #-} - -module Language.Fixpoint.Statistics (statistics) where - -import Control.Arrow ((&&&)) - -#if __GLASGOW_HASKELL__ < 710 -import Data.Monoid (mempty) -import Control.Applicative ((<$>)) -import GHC.Generics (Generic) -#endif - -import Language.Fixpoint.Misc (donePhase, Moods(..), applyNonNull) -import Language.Fixpoint.Config -import Language.Fixpoint.PrettyPrint -import Language.Fixpoint.Partition (partition') -import qualified Language.Fixpoint.Types as F -import qualified Data.HashMap.Strict as M -import Data.List (sort,group) -import Text.PrettyPrint.HughesPJ - -statistics :: Config -> F.FInfo a -> IO (F.Result a) -statistics _ fi = do - let (_, fis) = partition' fi - putStrLn $ render $ pprint $ partitionStats fis - donePhase Loud "Statistics" - return mempty - -partitionStats :: [F.FInfo a] -> Maybe Stats -partitionStats fis = info - where - css = [M.keys $ F.cm fi | fi <- fis] - sizes = fromIntegral . length <$> css - info = applyNonNull Nothing (Just . mkStats) sizes - -------------------------------------------------------------------------------------- -------------------------------------------------------------------------------------- -------------------------------------------------------------------------------------- - -data Stats = Stats { cSizes :: [Float] - , cFreq :: [(Float, Int)] - , cTotal :: Float - , cMean :: Float - , cMax :: Float - , cSpeed :: Float - } deriving (Show) - -instance PPrint Stats where - pprint s = vcat [ text "STAT: max/total = " <+> pprint (cMax s) <+> text "/" <+> pprint (cTotal s) - , text "STAT: freqs = " <+> pprint (cFreq s) - , text "STAT: average = " <+> pprint (cMean s) - , text "STAT: speed = " <+> pprint (cSpeed s) - ] - -mkStats :: [Float] -> Stats -mkStats ns = Stats { - cSizes = ns - , cFreq = frequency ns - , cTotal = total - , cMean = avg - , cMax = maxx - , cSpeed = total / maxx - } - where - maxx = maximum ns - total = sum ns - avg = mean ns - -frequency :: (Ord a) => [a] -> [(a, Int)] -frequency = map (head &&& length) . group . sort - -stdDev :: [Float] -> Float -stdDev xs = sqrt (sum [(x - μ)^2 | x <- xs] / n) - where - μ = mean xs - n = fromIntegral $ length xs - -mean :: [Float] -> Float -mean ns = sum ns / fromIntegral (length ns) diff --git a/src/Language/Fixpoint/Types.hs b/src/Language/Fixpoint/Types.hs --- a/src/Language/Fixpoint/Types.hs +++ b/src/Language/Fixpoint/Types.hs @@ -1,1802 +1,30 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE UndecidableInstances #-} - --- | This module contains the data types, operations and --- serialization functions for representing Fixpoint's --- implication (i.e. subtyping) and well-formedness --- constraints in Haskell. The actual constraint --- solving is done by the `fixpoint.native` which --- is written in Ocaml. - -module Language.Fixpoint.Types ( - - -- * Top level serialization - Fixpoint (..) - , toFixpoint - , FInfo (..) - - -- * Rendering - , showFix - , traceFix - , resultDoc - - -- * Symbols - , Symbol - , KVar (..) - , anfPrefix, tempPrefix, vv, vv_, intKvar - , symChars, isNonSymbol, nonSymbol - , isNontrivialVV - , symbolText, symbolString - - -- * Creating Symbols - , dummySymbol - , intSymbol - , tempSymbol - , qualifySymbol - , suffixSymbol - - -- * Embedding to Fixpoint Types - , Sort (..), FTycon, TCEmb - , sortFTycon - , intFTyCon, boolFTyCon, realFTyCon -- TODO: hide these - -- , strFTyCon - -- , propFTyCon - - , intSort, realSort, propSort, boolSort, strSort - , listFTyCon, appFTyCon - , isListTC, isFAppTyTC - , fTyconSymbol, symbolFTycon, fTyconSort - , fApp - , fObj - - -- * Expressions and Predicates - , SymConst (..) - , Constant (..) - , Bop (..), Brel (..) - , Expr (..), Pred (..) - , eVar - , eProp - , pAnd, pOr, pIte - , isTautoPred - , symConstLits - - -- * Generalizing Embedding with Typeclasses - , Symbolic (..) - , Expression (..) - , Predicate (..) - - -- * Constraints - , WfC (..) - , SubC, subcId, sid, sgrd, senv, slhs, srhs, subC, lhsCs, rhsCs, wfC - , Tag - - -- * Accessing Constraints - , envCs - , addIds, sinfo - , trueSubCKvar - , removeLhsKvars - - -- * Solutions - , Result (..) - , FixResult (..) - , FixSolution - - -- * Environments - , SEnv, SESearch(..) - , emptySEnv, toListSEnv, fromListSEnv - , mapSEnvWithKey - , insertSEnv, deleteSEnv, memberSEnv, lookupSEnv - , intersectWithSEnv - , filterSEnv - , lookupSEnvWithDistance - - , FEnv, insertFEnv - , IBindEnv, BindId, BindMap - , emptyIBindEnv, insertsIBindEnv, deleteIBindEnv, elemsIBindEnv - - , BindEnv, beBinds - , insertBindEnv, emptyBindEnv, lookupBindEnv, mapBindEnv, adjustBindEnv - , bindEnvFromList, bindEnvToList - , unionIBindEnv - - -- * Refinements - , Refa (..), SortedReft (..), Reft(..), Reftable(..) - , raConjuncts - - -- * Constructing Refinements - , refa - , reft -- "smart - , trueSortedReft -- trivial reft - , trueRefa -- trivial reft - , trueReft -- trivial reft - , exprReft -- singleton: v == e - , notExprReft -- singleton: v /= e - , uexprReft -- singleton: v ~~ e - , symbolReft -- singleton: v == x - , usymbolReft -- singleton: v ~~ x - , propReft -- singleton: Prop(v) <=> p - , predReft -- any pred : p - , reftPred, reftBind - , isFunctionSortedReft, functionSort - , isNonTrivial - , isSingletonReft - , isEVar - , isFalse - , flattenRefas, squishRefas, conjuncts - , shiftVV - , mapPredReft - - -- * Substitutions - , Subst (..) - , Subable (..) - , mkSubst - , isEmptySubst - -- , emptySubst - -- , catSubst - , substExcept - , substfExcept - , subst1Except - , sortSubst - , targetSubstSyms - - -- * Functions on @Result@ - , colorResult - - -- * Cut KVars - , Kuts (..) - , ksEmpty - , ksUnion - - -- * Qualifiers - , Qualifier (..) - - -- * Located Values - , Located (..) - , LocSymbol, LocText - , locAt, dummyLoc, dummyPos, dummyName, isDummy - ) where - -import Debug.Trace (trace) - -import Data.Generics (Data) -import Data.Typeable (Typeable) -import GHC.Generics (Generic) - -import Data.Char (toLower) -import qualified Data.Foldable as F -import Data.Functor -import Data.Hashable --- import Data.Interned -import Data.List (foldl', intersect, nub, sort) -import Data.Monoid hiding ((<>)) -import Data.String -import Data.Text (Text) -import qualified Data.Text as T -import Data.Traversable -import Control.DeepSeq -import Control.Exception (assert) -import Data.Maybe (isJust, mapMaybe, listToMaybe, fromMaybe) -import Text.Printf (printf) - -import Language.Fixpoint.Config -import Language.Fixpoint.Misc -import Text.Parsec.Pos -import Text.PrettyPrint.HughesPJ - -import Data.Array hiding (indices) -import qualified Data.HashMap.Strict as M -import qualified Data.HashSet as S -import Language.Fixpoint.Names - - -class Fixpoint a where - toFix :: a -> Doc - - simplify :: a -> a - simplify = id - -showFix :: (Fixpoint a) => a -> String -showFix = render . toFix - -traceFix :: (Fixpoint a) => String -> a -> a -traceFix s x = trace ("\nTrace: [" ++ s ++ "] : " ++ showFix x) x - -type TCEmb a = M.HashMap a FTycon - -exprSymbols :: Expr -> [Symbol] -exprSymbols = go - where - go (EVar x) = [x] - go (ELit x _) = [val x] - go (EApp f es) = val f : concatMap go es - go (ENeg e) = go e - go (EBin _ e1 e2) = go e1 ++ go e2 - go (EIte p e1 e2) = predSymbols p ++ go e1 ++ go e2 - go (ECst e _) = go e - go _ = [] - -predSymbols :: Pred -> [Symbol] -predSymbols = go - where - go (PAnd ps) = concatMap go ps - go (POr ps) = concatMap go ps - go (PNot p) = go p - go (PIff p1 p2) = go p1 ++ go p2 - go (PImp p1 p2) = go p1 ++ go p2 - go (PBexp e) = exprSymbols e - go (PAtom _ e1 e2) = exprSymbols e1 ++ exprSymbols e2 - go (PKVar _ (Su su')) = {- CUTSOLVER k : -} concatMap syms su' - go (PAll xts p) = (fst <$> xts) ++ go p - go _ = [] - ---------------------------------------------------------------- ----------- (Kut) Sets of Kvars -------------------------------- ---------------------------------------------------------------- -newtype KVar = KV {kv :: Symbol } deriving (Eq, Ord, Data, Typeable, Generic, IsString) - -intKvar :: Integer -> KVar -intKvar = KV . intSymbol "k_" - -instance Show KVar where - show (KV x) = "$" ++ show x - -instance Hashable KVar - -newtype Kuts = KS { ksVars :: S.HashSet KVar } deriving (Show) - -instance NFData Kuts where - rnf (KS _) = () -- rnf s - -instance Fixpoint Kuts where - toFix (KS s) = vcat $ ((text "cut " <>) . toFix) <$> S.toList s - -ksEmpty :: Kuts -ksEmpty = KS S.empty - -ksUnion :: [KVar] -> Kuts -> Kuts -ksUnion kvs (KS s') = KS (S.union (S.fromList kvs) s') - ---------------------------------------------------------------- ----------- Converting Constraints to Fixpoint Input ----------- ---------------------------------------------------------------- - -instance (Eq a, Hashable a, Fixpoint a) => Fixpoint (S.HashSet a) where - toFix xs = brackets $ sep $ punctuate (text ";") (toFix <$> S.toList xs) - simplify = S.fromList . map simplify . S.toList - -instance Fixpoint a => Fixpoint (Maybe a) where - toFix = maybe (text "Nothing") ((text "Just" <+>) . toFix) - simplify = fmap simplify - -instance Fixpoint a => Fixpoint [a] where - toFix xs = brackets $ sep $ punctuate (text ";") (fmap toFix xs) - simplify = map simplify - -instance (Fixpoint a, Fixpoint b) => Fixpoint (a,b) where - toFix (x,y) = toFix x <+> text ":" <+> toFix y - simplify (x,y) = (simplify x, simplify y) - -instance (Fixpoint a, Fixpoint b, Fixpoint c) => Fixpoint (a,b,c) where - toFix (x,y,z) = toFix x <+> text ":" <+> toFix y <+> text ":" <+> toFix z - simplify (x,y,z) = (simplify x, simplify y,simplify z) - -instance Fixpoint Bool where - toFix True = text "True" - toFix False = text "False" - simplify z = z - - -toFixGs :: SEnv SortedReft -> Doc -toFixGs (SE e) = vcat $ map (toFixConstant . mapSnd sr_sort) $ hashMapToAscList e - -toFixConstant (c, so) - = text "constant" <+> toFix c <+> text ":" <+> parens (toFix so) - ----------------------------------------------------------------------- ------------------------- Type Constructors --------------------------- ----------------------------------------------------------------------- - -newtype FTycon = TC LocSymbol deriving (Eq, Ord, Show, Data, Typeable, Generic) - -intFTyCon, boolFTyCon, realFTyCon, strFTyCon, propFTyCon, appFTyCon, listFTyCon :: FTycon -intFTyCon = TC $ dummyLoc "int" -boolFTyCon = TC $ dummyLoc "bool" -realFTyCon = TC $ dummyLoc "real" -strFTyCon = TC $ dummyLoc strConName -propFTyCon = TC $ dummyLoc propConName -listFTyCon = TC $ dummyLoc listConName -appFTyCon = TC $ dummyLoc "FAppTy" - -isListTC, isFAppTyTC :: FTycon -> Bool -isListTC (TC (Loc _ _ c)) = c == listConName -isTupTC (TC (Loc _ _ c)) = c == tupConName -isFAppTyTC = (== appFTyCon) - -fTyconSymbol :: FTycon -> Located Symbol -fTyconSymbol (TC s) = s - -symbolFTycon :: LocSymbol -> FTycon -symbolFTycon c - | val c == listConName - = TC $ fmap (const listConName) c - | otherwise - = TC c - --- stringSort :: String -> Sort --- stringSort s = FApp (stringFTycon s) [] --- -- ALTERNATIVEL = FObj . stringSymbol - -fApp :: Either FTycon Sort -> [Sort] -> Sort -fApp (Left c) ts - | c == intFTyCon = FInt - | c == realFTyCon = FReal - | otherwise = fAppSorts (fTyconSort c) ts -fApp (Right t) ts = fAppSorts t ts - -fAppSorts :: Sort -> [Sort] -> Sort -fAppSorts = foldl' (\t1 t2 -> FApp appFTyCon [t1, t2]) - -fTyconSort :: FTycon -> Sort -fTyconSort = (`FApp` []) - -fObj :: LocSymbol -> Sort -fObj = fTyconSort . TC - -sortFTycon :: Sort -> Maybe FTycon -sortFTycon FInt = Just intFTyCon -sortFTycon FReal = Just realFTyCon -sortFTycon (FApp c _) = Just c -sortFTycon _ = Nothing - ----------------------------------------------------------------------- -------------------------------- Sorts -------------------------------- ----------------------------------------------------------------------- - -data Sort = FInt - | FReal - | FNum -- ^ numeric kind for Num tyvars - | FFrac -- ^ numeric kind for Fractional tyvars - | FObj Symbol -- ^ uninterpreted type - | FVar !Int -- ^ fixpoint type variable - | FFunc !Int ![Sort] -- ^ type-var arity, in-ts ++ [out-t] - | FApp FTycon [Sort] -- ^ constructed type - deriving (Eq, Ord, Show, Data, Typeable, Generic) - -{-@ FFunc :: Nat -> ListNE Sort -> Sort @-} - -instance Hashable Sort - -newtype Sub = Sub [(Int, Sort)] - -instance Fixpoint Sort where - toFix = toFixSort - -toFixSort :: Sort -> Doc -toFixSort (FVar i) = text "@" <> parens (toFix i) -toFixSort FInt = text "int" -toFixSort FReal = text "real" -toFixSort FFrac = text "frac" -toFixSort (FObj x) = toFix x -toFixSort FNum = text "num" -toFixSort (FFunc n ts) = text "func" <> parens (toFix n <> text ", " <> toFix ts) -toFixSort (FApp c [t]) - | isListTC c = brackets $ toFixSort t -toFixSort (FApp c [FApp c' [],t]) - | isFAppTyTC c && - isListTC c' = brackets $ toFixSort t -toFixSort (FApp c ts) = toFix c <+> intersperse space (fp <$> ts) - where - fp s@(FApp _ (_:_)) = parens $ toFixSort s - fp s = toFixSort s - - -instance Fixpoint FTycon where - toFix (TC s) = toFix s - - ------------------------------------------------------------------------- -sortSubst :: M.HashMap Symbol Sort -> Sort -> Sort ------------------------------------------------------------------------- -sortSubst θ t@(FObj x) = fromMaybe t (M.lookup x θ) -sortSubst θ (FFunc n ts) = FFunc n (sortSubst θ <$> ts) -sortSubst θ (FApp c ts) = FApp c (sortSubst θ <$> ts) -sortSubst _ t = t - - -instance Show Subst where - show = showFix - -instance Fixpoint Subst where - toFix (Su m) = case {- hashMapToAscList -} m of - [] -> empty - xys -> hcat $ map (\(x,y) -> brackets $ toFix x <> text ":=" <> toFix y) xys - -targetSubstSyms :: Subst -> [Symbol] -targetSubstSyms (Su ms) = syms $ snd <$> ms - - ---------------------------------------------------------------- -------------------------- Expressions ------------------------- ---------------------------------------------------------------- - --- | Uninterpreted constants that are embedded as "constant symbol : Str" - -data SymConst = SL !Text - deriving (Eq, Ord, Show, Data, Typeable, Generic) - -data Constant = I !Integer - | R !Double - | L !Text !Sort - deriving (Eq, Ord, Show, Data, Typeable, Generic) - -data Brel = Eq | Ne | Gt | Ge | Lt | Le | Ueq | Une - deriving (Eq, Ord, Show, Data, Typeable, Generic) - -data Bop = Plus | Minus | Times | Div | Mod - deriving (Eq, Ord, Show, Data, Typeable, Generic) - -- NOTE: For "Mod" 2nd expr should be a constant or a var *) - -data Expr = ESym !SymConst - | ECon !Constant - | EVar !Symbol - | ELit !LocSymbol !Sort - | EApp !LocSymbol ![Expr] - | ENeg !Expr - | EBin !Bop !Expr !Expr - | EIte !Pred !Expr !Expr - | ECst !Expr !Sort - | EBot - deriving (Eq, Ord, Show, Data, Typeable, Generic) - -instance Fixpoint Integer where - toFix = integer - -instance Fixpoint Double where - toFix = double - -instance Fixpoint Constant where - toFix (I i) = toFix i - toFix (R i) = toFix i - toFix (L s t) = parens $ text "lit" <+> text "\"" <> toFix s <> text "\"" <+> toFix t - -instance Fixpoint SymConst where - toFix = toFix . encodeSymConst - -instance Fixpoint Symbol where - toFix = text . encode . T.unpack . symbolText - -instance Fixpoint KVar where - toFix (KV k) = text "$" <> toFix k - -instance Fixpoint Text where - toFix = text . T.unpack - - -instance Fixpoint Brel where - toFix Eq = text "=" - toFix Ne = text "!=" - toFix Ueq = text "~~" - toFix Une = text "!~" - toFix Gt = text ">" - toFix Ge = text ">=" - toFix Lt = text "<" - toFix Le = text "<=" - -instance Fixpoint Bop where - toFix Plus = text "+" - toFix Minus = text "-" - toFix Times = text "*" - toFix Div = text "/" - toFix Mod = text "mod" - -instance Fixpoint Expr where - toFix (ESym c) = toFix $ encodeSymConst c - toFix (ECon c) = toFix c - toFix (EVar s) = toFix s - toFix (ELit s _) = toFix s - toFix (EApp f es) = toFix f <> parens (toFix es) - toFix (ENeg e) = parens $ text "-" <+> parens (toFix e) - toFix (EBin o e1 e2) = parens $ toFix e1 <+> toFix o <+> toFix e2 - toFix (EIte p e1 e2) = parens $ text "if" <+> toFix p <+> text "then" <+> toFix e1 <+> text "else" <+> toFix e2 - toFix (ECst e so) = parens $ toFix e <+> text " : " <+> toFix so - toFix (EBot) = text "_|_" - ----------------------------------------------------------- ---------------------- Predicates ------------------------- ----------------------------------------------------------- - - -data Pred = PTrue - | PFalse - | PAnd !(ListNE Pred) -- [Pred] - | POr ![Pred] - | PNot !Pred - | PImp !Pred !Pred - | PIff !Pred !Pred - | PBexp !Expr - | PAtom !Brel !Expr !Expr - | PKVar !KVar !Subst - | PAll ![(Symbol, Sort)] !Pred - | PTop - deriving (Eq, Ord, Show, Data, Typeable, Generic) - -{-@ PAnd :: ListNE Pred -> Pred @-} - -instance Hashable Brel -instance Hashable Bop -instance Hashable SymConst -instance Hashable Constant -instance Hashable Subst -instance Hashable Expr -instance Hashable Pred - -instance Fixpoint Pred where - toFix PTop = text "???" - toFix PTrue = text "true" - toFix PFalse = text "false" - toFix (PBexp e) = parens $ text "?" <+> toFix e - toFix (PNot p) = parens $ text "~" <+> parens (toFix p) - toFix (PImp p1 p2) = parens $ toFix p1 <+> text "=>" <+> toFix p2 - toFix (PIff p1 p2) = parens $ toFix p1 <+> text "<=>" <+> toFix p2 - toFix (PAnd ps) = text "&&" <+> toFix ps - toFix (POr ps) = text "||" <+> toFix ps - toFix (PAtom r e1 e2) = parens $ toFix e1 <+> toFix r <+> toFix e2 - toFix (PKVar k su) = toFix k <> toFix su - toFix (PAll xts p) = text "forall" <+> toFix xts <+> text "." <+> toFix p - - simplify (PAnd []) = PTrue - simplify (POr []) = PFalse - simplify (PAnd [p]) = simplify p - simplify (POr [p]) = simplify p - - simplify (PAnd ps) - | any isContraPred ps = PFalse - | otherwise = PAnd $ filter (not . isTautoPred) $ map simplify ps - - simplify (POr ps) - | any isTautoPred ps = PTrue - | otherwise = POr $ filter (not . isContraPred) $ map simplify ps - - simplify p - | isContraPred p = PFalse - | isTautoPred p = PTrue - | otherwise = p - -isContraPred :: Pred -> Bool -isContraPred z = eqC z || (z `elem` contras) - where - contras = [PFalse] - - eqC (PAtom Eq (ECon x) (ECon y)) - = x /= y - eqC (PAtom Ueq (ECon x) (ECon y)) - = x /= y - eqC (PAtom Ne x y) - = x == y - eqC (PAtom Une x y) - = x == y - eqC _ = False - -isTautoPred :: Pred -> Bool -isTautoPred z = z == PTop || z == PTrue || eqT z - where - eqT (PAtom Le x y) - = x == y - eqT (PAtom Ge x y) - = x == y - eqT (PAtom Eq x y) - = x == y - eqT (PAtom Ueq x y) - = x == y - eqT (PAtom Ne (ECon x) (ECon y)) - = x /= y - eqT (PAtom Une (ECon x) (ECon y)) - = x /= y - eqT _ = False - -isEVar :: Expr -> Bool -isEVar (EVar _) = True -isEVar _ = False - -isEq :: Brel -> Bool -isEq r = r == Eq || r == Ueq - -isSingletonReft :: Reft -> Maybe Expr -isSingletonReft (Reft (v, ra)) = firstMaybe (isSingletonExpr v) $ raConjuncts ra - -raConjuncts :: Refa -> [Pred] -raConjuncts = conjuncts . raPred - -firstMaybe :: (a -> Maybe b) -> [a] -> Maybe b -firstMaybe f = listToMaybe . mapMaybe f - --- where --- go (PAtom r e1 e2) | e1 == EVar v && isEq r = Just e2 --- | e2 == EVar v && isEq r = Just e1 --- go _ = Nothing - -isSingletonExpr :: Symbol -> Pred -> Maybe Expr -isSingletonExpr v (PAtom r e1 e2) - | e1 == EVar v && isEq r = Just e2 - | e2 == EVar v && isEq r = Just e1 -isSingletonExpr _ _ = Nothing - -pAnd = simplify . PAnd -pOr = simplify . POr -pIte p1 p2 p3 = pAnd [p1 `PImp` p2, (PNot p1) `PImp` p3] - -mkProp = PBexp . EApp (dummyLoc propConName) . (: []) - -pprReft (Reft (v, Refa p)) d - | isTautoPred p - = d - | otherwise - = braces (toFix v <+> colon <+> d <+> text "|" <+> ppRas [Refa p]) - -pprReftPred (Reft (_, Refa p)) - | isTautoPred p - = text "true" - | otherwise - = ppRas [Refa p] - -ppRas = cat . punctuate comma . map toFix . flattenRefas - ------------------------------------------------------------------------- --- | Generalizing Symbol, Expression, Predicate into Classes ----------- ------------------------------------------------------------------------- - --- | Values that can be viewed as Constants - --- | Values that can be viewed as Expressions - -class Expression a where - expr :: a -> Expr - --- | Values that can be viewed as Predicates - -class Predicate a where - prop :: a -> Pred - -instance Expression Expr where - expr = id - --- | The symbol may be an encoding of a SymConst. - -instance Expression Symbol where - expr s = maybe (eVar s) ESym (decodeSymConst s) - -- expr = eVar - -instance Expression Text where - expr = ESym . SL - -instance Expression Integer where - expr = ECon . I - -instance Expression Int where - expr = expr . toInteger - -instance Predicate Symbol where - prop = eProp - -instance Predicate Pred where - prop = id - -instance Predicate Bool where - prop True = PTrue - prop False = PFalse - -eVar :: Symbolic a => a -> Expr -eVar = EVar . symbol - -eProp :: Symbolic a => a -> Pred -eProp = mkProp . eVar - -relReft :: (Expression a) => Brel -> a -> Reft -relReft r e = Reft (vv_, Refa $ PAtom r (eVar vv_) (expr e)) - -exprReft, notExprReft, uexprReft :: (Expression a) => a -> Reft -exprReft = relReft Eq -notExprReft = relReft Ne -uexprReft = relReft Ueq - -propReft :: (Predicate a) => a -> Reft -propReft p = Reft (vv_, Refa $ PIff (eProp vv_) (prop p)) - -predReft :: (Predicate a) => a -> Reft -predReft p = Reft (vv_, Refa $ prop p) - -reft :: Symbol -> Pred -> Reft -reft v p = Reft (v, Refa p) - -mapPredReft :: (Pred -> Pred) -> Reft -> Reft -mapPredReft f (Reft (v, Refa p)) = Reft (v, Refa (f p)) - - ---------------------------------------------------------------- ------------------ Refinements --------------------------------- ---------------------------------------------------------------- - -newtype Refa = Refa { raPred :: Pred } - deriving (Eq, Ord, Show, Data, Typeable, Generic) - -newtype Reft = Reft (Symbol, Refa) - deriving (Eq, Ord, Data, Typeable, Generic) - -instance Show Reft where - show (Reft x) = render $ toFix x - -data SortedReft = RR { sr_sort :: !Sort, sr_reft :: !Reft } - deriving (Eq, Show, Data, Typeable, Generic) - -isFunctionSortedReft :: SortedReft -> Bool -isFunctionSortedReft = isJust . functionSort . sr_sort - -functionSort :: Sort -> Maybe (Int, [Sort], Sort) -functionSort (FFunc n ts) = Just (n, its, t) - where - (its, t) = safeUnsnoc "functionSort" ts -functionSort _ = Nothing - - - - -isNonTrivial :: Reftable r => r -> Bool -isNonTrivial = not .isTauto - --- sortedReftValueVariable (RR _ (Reft (v,_))) = v - -reftPred :: Reft -> Pred -reftPred (Reft (_, Refa p)) = p - -reftBind :: Reft -> Symbol -reftBind (Reft (x, _)) = x - -refa :: [Pred] -> Refa -refa = Refa . pAnd - - ---------------------------------------------------------------- --- | Environments --------------------------------------------- ---------------------------------------------------------------- - - -toListSEnv :: SEnv a -> [(Symbol, a)] -toListSEnv (SE env) = M.toList env -fromListSEnv :: [(Symbol, a)] -> SEnv a -fromListSEnv = SE . M.fromList - -mapSEnv f (SE env) = SE (fmap f env) -mapSEnvWithKey f = fromListSEnv . fmap f . toListSEnv -deleteSEnv x (SE env) = SE (M.delete x env) -insertSEnv x y (SE env) = SE (M.insert x y env) -lookupSEnv x (SE env) = M.lookup x env -emptySEnv = SE M.empty -memberSEnv x (SE env) = M.member x env -intersectWithSEnv f (SE m1) (SE m2) = SE (M.intersectionWith f m1 m2) -filterSEnv f (SE m) = SE (M.filter f m) -lookupSEnvWithDistance x (SE env) - = case M.lookup x env of - Just z -> Found z - Nothing -> Alts $ symbol . T.pack <$> alts - where - alts = takeMin $ zip (editDistance x' <$> ss) ss - ss = T.unpack . symbolText <$> fst <$> M.toList env - x' = T.unpack $ symbolText x - takeMin xs = [z | (d, z) <- xs, d == getMin xs] - getMin = minimum . (fst <$>) - -data SESearch a = Found a | Alts [Symbol] - --- | Functions for Indexed Bind Environment - -emptyIBindEnv :: IBindEnv -emptyIBindEnv = FB S.empty - -deleteIBindEnv :: BindId -> IBindEnv -> IBindEnv -deleteIBindEnv i (FB s) = FB (S.delete i s) - -insertsIBindEnv :: [BindId] -> IBindEnv -> IBindEnv -insertsIBindEnv is (FB s) = FB (foldr S.insert s is) - -elemsIBindEnv :: IBindEnv -> [BindId] -elemsIBindEnv (FB s) = S.toList s - - --- | Functions for Global Binder Environment -insertBindEnv :: Symbol -> SortedReft -> BindEnv -> (BindId, BindEnv) -insertBindEnv x r (BE n m) = (n, BE (n + 1) (M.insert n (x, r) m)) - -emptyBindEnv :: BindEnv -emptyBindEnv = BE 0 M.empty - -bindEnvFromList :: [(BindId, Symbol, SortedReft)] -> BindEnv -bindEnvFromList bs = BE (1 + nbs) be' - where - nbs = length bs - be = M.fromList [(n, (x, r)) | (n, x, r) <- bs] - be' = assert (M.size be == nbs) be - -bindEnvToList :: BindEnv -> [(BindId, Symbol, SortedReft)] -bindEnvToList (BE _ be) = [(n, x, r) | (n, (x, r)) <- M.toList be] - -mapBindEnv :: ((Symbol, SortedReft) -> (Symbol, SortedReft)) -> BindEnv -> BindEnv -mapBindEnv f (BE n m) = BE n $ M.map f m - -lookupBindEnv :: BindId -> BindEnv -> (Symbol, SortedReft) -lookupBindEnv k (BE _ m) = fromMaybe err (M.lookup k m) - where - err = errorstar $ "lookupBindEnv: cannot find binder" ++ show k - -unionIBindEnv :: IBindEnv -> IBindEnv -> IBindEnv -unionIBindEnv (FB m1) (FB m2) = FB $ m1 `S.union` m2 - -adjustBindEnv :: ((Symbol, SortedReft) -> (Symbol, SortedReft)) -> BindId -> BindEnv -> BindEnv -adjustBindEnv f id (BE n m) = BE n $ M.adjust f id m - -instance Functor SEnv where - fmap = mapSEnv - -instance Fixpoint Refa where - toFix (Refa p) = toFix $ conjuncts p - -- toFix (RPvar p) = toFix p - -instance Fixpoint Reft where - toFix = pprReftPred - -instance Fixpoint SortedReft where - toFix (RR so (Reft (v, ra))) - = braces - $ toFix v <+> text ":" <+> toFix so <+> text "|" <+> toFix ra - -instance Fixpoint BindEnv where - toFix (BE _ m) = vcat $ map toFixBind $ hashMapToAscList m - -toFixBind (i, (x, r)) = text "bind" <+> toFix i <+> toFix x <+> text ":" <+> toFix r - -insertFEnv = insertSEnv . lower - where lower s = case unconsSym s of - Nothing -> s - Just (c,s') -> consSym (toLower c) s' - --- instance (Fixpoint a) => Fixpoint (SEnv a) where --- toFix (SE e) = vcat $ map pprxt $ hashMapToAscList e --- where --- pprxt (x,t) = toFix x <+> colon <> colon <+> toFix t - -instance (Fixpoint a) => Fixpoint (SEnv a) where - toFix (SE m) = toFix (hashMapToAscList m) - -instance Fixpoint (SEnv a) => Show (SEnv a) where - show = render . toFix - ------------------------------------------------------------------------------ -------------------- Constraints --------------------------------------------- ------------------------------------------------------------------------------ - -{-@ type Tag = { v : [Int] | len(v) = 1 } @-} -type Tag = [Int] - -type BindId = Int -type FEnv = SEnv SortedReft -type BindMap a = M.HashMap BindId a -- (Symbol, SortedReft) - -newtype IBindEnv = FB (S.HashSet BindId) deriving (Data, Typeable) -newtype SEnv a = SE { seBinds :: M.HashMap Symbol a } - deriving (Eq, Data, Typeable, Generic, F.Foldable, Traversable) - - -data BindEnv = BE { beSize :: Int - , beBinds :: BindMap (Symbol, SortedReft) - } - deriving (Show) - -data SubC a = SubC { senv :: !IBindEnv - , sgrd :: !Pred - , slhs :: !SortedReft - , srhs :: !SortedReft - , sid :: !(Maybe Integer) - , stag :: !Tag - , sinfo :: !a - } - deriving (Generic) - -data WfC a = WfC { wenv :: !IBindEnv - , wrft :: !SortedReft - , wid :: !(Maybe Integer) - , winfo :: !a - } - deriving (Generic) - -subcId :: SubC a -> Integer -subcId = mfromJust "subCId" . sid - ---------------------------------------------------------------------------- --- | The output of the Solver ---------------------------------------------------------------------------- -data Result a = Result { resStatus :: FixResult (SubC a) - , resSolution :: M.HashMap KVar Pred } - deriving (Show) ---------------------------------------------------------------------------- - -instance Monoid (Result a) where - mempty = Result mempty mempty - mappend r1 r2 = Result stat soln - where - stat = mappend (resStatus r1) (resStatus r2) - soln = mappend (resSolution r1) (resSolution r2) - --- instance Functor Result where --- fmap f (Result x y) = Result (fmap (fmap f) x) y - -data FixResult a = Crash [a] String - | Safe - | Unsafe ![a] - | UnknownError !String - deriving (Show, Generic) - -type FixSolution = M.HashMap KVar Pred - -instance Eq a => Eq (FixResult a) where - Crash xs _ == Crash ys _ = xs == ys - Unsafe xs == Unsafe ys = xs == ys - Safe == Safe = True - _ == _ = False - -instance Monoid (FixResult a) where - mempty = Safe - mappend Safe x = x - mappend x Safe = x - mappend _ c@(Crash _ _) = c - mappend c@(Crash _ _) _ = c - mappend (Unsafe xs) (Unsafe ys) = Unsafe (xs ++ ys) - mappend u@(UnknownError _) _ = u - mappend _ u@(UnknownError _) = u - -instance Functor FixResult where - fmap f (Crash xs msg) = Crash (f <$> xs) msg - fmap f (Unsafe xs) = Unsafe (f <$> xs) - fmap _ Safe = Safe - fmap _ (UnknownError d) = UnknownError d - -instance (Ord a, Fixpoint a) => Fixpoint (FixResult (SubC a)) where - toFix Safe = text "Safe" - toFix (UnknownError d) = text $ "Unknown Error: " ++ d - toFix (Crash xs msg) = vcat $ [ text "Crash!" ] ++ pprSinfos "CRASH: " xs ++ [parens (text msg)] - toFix (Unsafe xs) = vcat $ text "Unsafe:" : pprSinfos "WARNING: " xs - -pprSinfos :: (Ord a, Fixpoint a) => String -> [SubC a] -> [Doc] -pprSinfos msg = map ((text msg <>) . toFix) . sort . fmap sinfo - - -resultDoc :: (Ord a, Fixpoint a) => FixResult a -> Doc -resultDoc Safe = text "Safe" -resultDoc (UnknownError d) = text $ "Unknown Error: " ++ d -resultDoc (Crash xs msg) = vcat $ text ("Crash!: " ++ msg) : (((text "CRASH:" <+>) . toFix) <$> xs) -resultDoc (Unsafe xs) = vcat $ text "Unsafe:" : (((text "WARNING:" <+>) . toFix) <$> xs) - -colorResult :: FixResult a -> Moods -colorResult (Safe) = Happy -colorResult (Unsafe _) = Angry -colorResult (_) = Sad - -instance Fixpoint a => Show (WfC a) where - show = showFix - -instance Fixpoint a => Show (SubC a) where - show = showFix - -instance Fixpoint (IBindEnv) where - toFix (FB ids) = text "env" <+> toFix ids - -instance Fixpoint a => Fixpoint (SubC a) where - toFix c = hang (text "\n\nconstraint:") 2 bd - where bd = -- text "env" <+> toFix (senv c) - toFix (senv c) - $+$ text "grd" <+> toFix (sgrd c) - $+$ text "lhs" <+> toFix (slhs c) - $+$ text "rhs" <+> toFix (srhs c) - $+$ (pprId (sid c) <+> pprTag (stag c)) - $+$ toFixMeta (text "constraint" <+> pprId (sid c)) (toFix (sinfo c)) - - -instance Fixpoint a => Fixpoint (WfC a) where - toFix w = hang (text "\n\nwf:") 2 bd - where bd = -- text "env" <+> toFix (wenv w) - toFix (wenv w) - $+$ text "reft" <+> toFix (wrft w) - $+$ pprId (wid w) - $+$ toFixMeta (text "wf" <+> pprId (wid w)) (toFix (winfo w)) - -toFixMeta :: Doc -> Doc -> Doc -toFixMeta k v = text "// META" <+> k <+> text ":" <+> v - -- $+$ text "\n" - -pprId (Just i) = text "id" <+> tshow i -pprId _ = text "" - -pprTag [] = text "" -pprTag is = text "tag" <+> toFix is - -instance Fixpoint Int where - toFix = tshow - -------------------------------------------------------- -------------------- Substitutions --------------------- -------------------------------------------------------- - -class Subable a where - syms :: a -> [Symbol] - substa :: (Symbol -> Symbol) -> a -> a - -- substa f = substf (EVar . f) - - substf :: (Symbol -> Expr) -> a -> a - subst :: Subst -> a -> a - subst1 :: a -> (Symbol, Expr) -> a - -- subst1 y (x, e) = subst (Su $ M.singleton x e) y - subst1 y (x, e) = subst (Su [(x,e)]) y - -subst1Except :: (Subable a) => [Symbol] -> a -> (Symbol, Expr) -> a -subst1Except xs z su@(x, _) - | x `elem` xs = z - | otherwise = subst1 z su - -substfExcept :: (Symbol -> Expr) -> [Symbol] -> Symbol -> Expr -substfExcept f xs y = if y `elem` xs then EVar y else f y - -substExcept :: Subst -> [Symbol] -> Subst --- substExcept (Su m) xs = Su (foldr M.delete m xs) -substExcept (Su xes) xs = Su $ filter (not . (`elem` xs) . fst) xes - -instance Subable Symbol where - substa f = f - substf f x = subSymbol (Just (f x)) x - subst su x = subSymbol (Just $ appSubst su x) x -- subSymbol (M.lookup x s) x - syms x = [x] - -subSymbol (Just (EVar y)) _ = y -subSymbol Nothing x = x -subSymbol a b = errorstar (printf "Cannot substitute symbol %s with expression %s" (showFix b) (showFix a)) - -instance Subable Expr where - syms = exprSymbols - substa f = substf (EVar . f) - substf f (EApp s es) = EApp (substf f s) $ map (substf f) es - substf f (ENeg e) = ENeg (substf f e) - substf f (EBin op e1 e2) = EBin op (substf f e1) (substf f e2) - substf f (EIte p e1 e2) = EIte (substf f p) (substf f e1) (substf f e2) - substf f (ECst e so) = ECst (substf f e) so - substf f e@(EVar x) = f x - substf _ e = e - - subst su (EApp f es) = EApp (subst su f) $ map (subst su) es - subst su (ENeg e) = ENeg (subst su e) - subst su (EBin op e1 e2) = EBin op (subst su e1) (subst su e2) - subst su (EIte p e1 e2) = EIte (subst su p) (subst su e1) (subst su e2) - subst su (ECst e so) = ECst (subst su e) so - subst su (EVar x) = appSubst su x - subst _ e = e - - -instance Subable Pred where - syms = predSymbols - substa f = substf (EVar . f) - substf f (PAnd ps) = PAnd $ map (substf f) ps - substf f (POr ps) = POr $ map (substf f) ps - substf f (PNot p) = PNot $ substf f p - substf f (PImp p1 p2) = PImp (substf f p1) (substf f p2) - substf f (PIff p1 p2) = PIff (substf f p1) (substf f p2) - substf f (PBexp e) = PBexp $ substf f e - substf f (PAtom r e1 e2) = PAtom r (substf f e1) (substf f e2) - substf _ p@(PKVar _ _) = p - substf _ (PAll _ _) = errorstar "substf: FORALL" - substf _ p = p - - subst su (PAnd ps) = PAnd $ map (subst su) ps - subst su (POr ps) = POr $ map (subst su) ps - subst su (PNot p) = PNot $ subst su p - subst su (PImp p1 p2) = PImp (subst su p1) (subst su p2) - subst su (PIff p1 p2) = PIff (subst su p1) (subst su p2) - subst su (PBexp e) = PBexp $ subst su e - subst su (PAtom r e1 e2) = PAtom r (subst su e1) (subst su e2) - subst su (PKVar k su') = PKVar k $ su' `catSubst` su - subst _ (PAll _ _) = errorstar "subst: FORALL" - subst _ p = p - -instance Subable Refa where - syms (Refa p) = syms p - -- syms (RKvar k (Su su')) = k : concatMap syms ({- M.elems -} su') - subst su (Refa p) = Refa $ subst su p - substa f = substf (EVar . f) - substf f (Refa p) = Refa (substf f p) - -instance (Subable a, Subable b) => Subable (a,b) where - syms (x, y) = syms x ++ syms y - subst su (x,y) = (subst su x, subst su y) - substf f (x,y) = (substf f x, substf f y) - substa f (x,y) = (substa f x, substa f y) - -instance Subable a => Subable [a] where - syms = concatMap syms - subst = map . subst - substf = map . substf - substa = map . substa - -instance Subable a => Subable (M.HashMap k a) where - syms = syms . M.elems - subst = M.map . subst - substf = M.map . substf - substa = M.map . substa - -instance Subable Reft where - syms (Reft (v, ras)) = v : syms ras - substa f (Reft (v, ras)) = Reft (f v, substa f ras) - subst su (Reft (v, ras)) = Reft (v, subst (substExcept su [v]) ras) - substf f (Reft (v, ras)) = Reft (v, substf (substfExcept f [v]) ras) - subst1 (Reft (v, ras)) su = Reft (v, subst1Except [v] ras su) - - -instance Subable SortedReft where - syms = syms . sr_reft - subst su (RR so r) = RR so $ subst su r - substf f (RR so r) = RR so $ substf f r - substa f (RR so r) = RR so $ substa f r - -newtype Subst = Su [(Symbol, Expr)] - deriving (Eq, Ord, Data, Typeable, Generic) - -appSubst :: Subst -> Symbol -> Expr -appSubst (Su s) x = fromMaybe (EVar x) (lookup x s) - -emptySubst :: Subst -emptySubst = Su [] -- M.empty - -catSubst :: Subst -> Subst -> Subst -catSubst = unsafeCatSubst - -mkSubst :: [(Symbol, Expr)] -> Subst -mkSubst = unsafeMkSubst - -isEmptySubst :: Subst -> Bool -isEmptySubst (Su xes) = null xes - -unsafeMkSubst = Su - -unsafeCatSubst (Su s1) θ2@(Su s2) = Su $ s1' ++ s2 - where - s1' = mapSnd (subst θ2) <$> s1 - --- TODO: this is **not used**, because of degenerate substitutions. --- e.g. consider: s1 = [v := v], s2 = [v := x]. --- We want s1 `cat` s2 to be [v := x] and not [v := v] ... - -unsafeCatSubstIgnoringDead (Su s1) (Su s2) = Su $ s1' ++ s2' - where - s1' = mapSnd (subst (Su s2')) <$> s1 - s2' = filter (\(x,_) -> (x `notElem` (fst <$> s1))) s2 - --- TODO: nano-js throws all sorts of issues, will look into this later... --- but also, the check is too conservative, because of degenerate substitutions, --- see above. -safeCatSubst θ1@(Su s1) θ2@(Su s2) - | null $ intersect xs1 xs2 - = unsafeCatSubst θ1 θ2 - | otherwise - = errorstar msg - where - s1' = mapSnd (subst (Su s2)) <$> s1 - xs1 = fst <$> s1 - xs2 = fst <$> s2 - msg = printf "Fixpoint.Types catSubst on overlapping substitutions θ1 = %s, θ2 = %s" (showFix θ1) (showFix θ2) - - -safeMkSubst θ - | nub θ == θ - = Su θ - | otherwise - = errorstar msg - where - msg = printf "Fixpoint.Types mkSubst on overlapping substitution θ = %s" (showFix θ) - -instance Monoid Subst where - mempty = emptySubst - mappend = catSubst - ------------------------------------------------------------- -------------- Generally Useful Refinements ----------------- ------------------------------------------------------------- - -symbolReft :: (Symbolic a) => a -> Reft -symbolReft = exprReft . eVar - -usymbolReft :: (Symbolic a) => a -> Reft -usymbolReft = uexprReft . eVar - -vv_ :: Symbol -vv_ = vv Nothing - -trueSortedReft :: Sort -> SortedReft -trueSortedReft = (`RR` trueReft) - -trueReft = Reft (vv_, trueRefa) -falseReft = Reft (vv_, Refa PFalse) - -trueRefa :: Refa -trueRefa = Refa PTrue - -flattenRefas :: [Refa] -> [Refa] -flattenRefas = concatMap flatRa - where - flatRa (Refa p) = Refa <$> flatP p - flatP (PAnd ps) = concatMap flatP ps - flatP p = [p] - -squishRefas :: [Refa] -> [Refa] -squishRefas ras = [squish (raPred <$> ras)] - where - squish = Refa . pAnd . sortNub . filter (not . isTautoPred) . concatMap conjuncts - -conjuncts (PAnd ps) = concatMap conjuncts ps -conjuncts p - | isTautoPred p = [] - | otherwise = [p] - ----------------------------------------------------------------- ----------------------- Strictness ------------------------------ ----------------------------------------------------------------- - -instance NFData FTycon where - rnf (TC c) = rnf c - -instance NFData Sort where - rnf (FVar x) = rnf x - rnf (FFunc n ts) = rnf n `seq` (rnf <$> ts) `seq` () - rnf (FApp c ts) = rnf c `seq` (rnf <$> ts) `seq` () - rnf (z) = z `seq` () - -instance NFData Sub where - rnf (Sub x) = rnf x - -instance NFData Subst where - rnf (Su x) = rnf x - -instance NFData FEnv where - rnf (SE x) = rnf x - -instance NFData IBindEnv where - rnf (FB x) = rnf x - -instance NFData BindEnv where - rnf (BE x m) = rnf x `seq` rnf m - -instance NFData Constant where - rnf (I x) = rnf x - rnf (R x) = rnf x - rnf (L s t) = rnf s `seq` rnf t - -instance NFData SymConst where - rnf (SL x) = rnf x - -instance NFData Brel -instance NFData Bop - -instance NFData Expr where - rnf (ESym x) = rnf x - rnf (ECon x) = rnf x - rnf (EVar x) = rnf x - -- rnf (EDat x1 x2) = rnf x1 `seq` rnf x2 - rnf (ELit x1 x2) = rnf x1 `seq` rnf x2 - rnf (EApp x1 x2) = rnf x1 `seq` rnf x2 - rnf (ENeg x1) = rnf x1 - rnf (EBin x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 - rnf (EIte x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 - rnf (ECst x1 x2) = rnf x1 `seq` rnf x2 - rnf (_) = () - -instance NFData Pred where - rnf (PAnd x) = rnf x - rnf (POr x) = rnf x - rnf (PNot x) = rnf x - rnf (PBexp x) = rnf x - rnf (PImp x1 x2) = rnf x1 `seq` rnf x2 - rnf (PIff x1 x2) = rnf x1 `seq` rnf x2 - rnf (PAll x1 x2) = rnf x1 `seq` rnf x2 - rnf (PAtom x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 - rnf (_) = () - -instance NFData Refa where - rnf (Refa x) = rnf x - -- rnf (RKvar x1 x2) = rnf x1 `seq` rnf x2 - -- rnf (RPvar _) = () -- rnf x - -instance NFData Reft where - rnf (Reft (v, ras)) = rnf v `seq` rnf ras - -instance NFData SortedReft where - rnf (RR so r) = rnf so `seq` rnf r - -instance (NFData a) => NFData (SubC a) where - rnf (SubC x1 x2 x3 x4 x5 x6 x7) - = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` rnf x7 - -instance (NFData a) => NFData (WfC a) where - rnf (WfC x1 x2 x3 x4) - = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 - ----------------------------------------------------------------------------- --------------- Hashable Instances ----------------------------------------- ---------------------------------------------------------------------------- - -instance Hashable FTycon where - hashWithSalt i (TC s) = hashWithSalt i s - ---------------------------------------------------------------------------- --------- Constraint Constructor Wrappers ---------------------------------- ---------------------------------------------------------------------------- - -wfC :: IBindEnv -> SortedReft -> Maybe Integer -> a -> WfC a -wfC = WfC - --- subC :: IBindEnv -> Pred -> SortedReft -> SortedReft -> Maybe Integer -> Tag -> a -> [SubC a] --- subC γ p (RR t1 r1) (RR t2 (Reft (v2, ra2s))) i y z --- = error "TODO:subC" -- NEW [subC' r2' | r2' <- [r2P], not $ isTauto r2'] --- where --- subC' r2' = SubC γ p (RR t1 (shiftVV r1 vv')) (RR t2 (shiftVV r2' vv')) i y z --- r2P = Reft (v2, ra2s) -- ORIG [ra | ra@(Refa _ ) <- ra2s]) --- -- ORIG r2K = Reft (v2, [ra | ra@(RKvar _ _) <- ra2s]) --- vv' = mkVV i - - --- ORIG subC γ p (RR t1 r1) (RR t2 (Reft (v2, ra2s))) x y z --- ORIG = [subC' r2' | r2' <- [r2K, r2P], not $ isTauto r2'] --- ORIG where --- ORIG subC' r2' = SubC γ p (RR t1 (shiftVV r1 vvCon)) (RR t2 (shiftVV r2' vvCon)) x y z --- ORIG r2K = Reft (v2, [ra | ra@(RKvar _ _) <- ra2s]) --- ORIG r2P = Reft (v2, [ra | ra@(RConc _ ) <- ra2s]) - - -subC :: IBindEnv -> Pred -> SortedReft -> SortedReft -> Maybe Integer -> Tag -> a -> [SubC a] --- subC γ p (RR t1 r1) (RR t2 r2) i y z -subC γ p sr1 sr2 i y z = [SubC γ p sr1' (sr2' r2') i y z | r2' <- reftConjuncts r2] - where - RR t1 r1 = sr1 - RR t2 r2 = sr2 - sr1' = RR t1 $ shiftVV r1 vv' - sr2' r2' = RR t2 $ shiftVV r2' vv' - vv' = mkVV i - -reftConjuncts :: Reft -> [Reft] -reftConjuncts (Reft (v, ra)) = [Reft (v, ra') | ra' <- refaConjuncts ra] - -refaConjuncts :: Refa -> [Refa] -refaConjuncts (Refa p) = [Refa p' | p' <- conjuncts p, not $ isTautoPred p'] - -mkVV :: Maybe Integer -> Symbol -mkVV (Just i) = vv $ Just i -mkVV Nothing = vvCon - -lhsCs, rhsCs :: SubC a -> Reft -lhsCs = sr_reft . slhs -rhsCs = sr_reft . srhs - -envCs :: BindEnv -> IBindEnv -> [(Symbol, SortedReft)] -envCs be env = [lookupBindEnv i be | i <- elemsIBindEnv env] - --- mkFEnv :: BindEnv -> IBindEnv -> FEnv --- mkFEnv be env = fromListSEnv $ envCs be env - - - -removeLhsKvars cs vs - = error "TODO:cutsolver: removeLhsKvars (why is this function needed?)" - --- CUTSOLVER = cs {slhs = goRR (slhs cs)} --- CUTSOLVER where goRR rr = rr{sr_reft = goReft (sr_reft rr)} --- CUTSOLVER goReft (Reft(v, rs)) = Reft(v, filter f rs) --- CUTSOLVER f (RKvar v _) | v `elem` vs = False --- CUTSOLVER f r = True - -trueSubCKvar k = subC emptyIBindEnv PTrue mempty rhs Nothing [0] - where - rhs = RR mempty (Reft (vv_, Refa $ PKVar k mempty)) - -shiftVV :: Reft -> Symbol -> Reft -shiftVV r@(Reft (v, ras)) v' - | v == v' = r - | otherwise = Reft (v', subst1 ras (v, EVar v')) - - -addIds = zipWith (\i c -> (i, shiftId i $ c {sid = Just i})) [1..] - where -- Adding shiftId to have distinct VV for SMT conversion - shiftId i c = c { slhs = shiftSR i $ slhs c } - { srhs = shiftSR i $ srhs c } - shiftSR i sr = sr { sr_reft = shiftR i $ sr_reft sr } - shiftR i r@(Reft (v, _)) = shiftVV r (v `mappend` symbol (show i)) - - ------------------------------------------------------------------------- ------------------ Qualifiers ------------------------------------------- ------------------------------------------------------------------------- - - -data Qualifier = Q { q_name :: Symbol -- ^ Name - , q_params :: [(Symbol, Sort)] -- ^ Parameters - , q_body :: Pred -- ^ Predicate - , q_pos :: !SourcePos -- ^ Source Location - } - deriving (Eq, Ord, Show, Data, Typeable, Generic) - -instance Fixpoint Qualifier where - toFix = pprQual - -instance Fixpoint () where - toFix _ = text "()" - -instance NFData Qualifier where - rnf (Q x1 x2 x3 _) = rnf x1 `seq` rnf x2 `seq` rnf x3 - -pprQual (Q n xts p l) = text "qualif" <+> text (symbolString n) <> parens args <> colon <+> toFix p <+> text "//" <+> toFix l - where - args = intersperse comma (toFix <$> xts) - ------------------------------------------------------------------------- ------------------ Top-Level Constraint System -------------------------- ------------------------------------------------------------------------- - -data FInfo a = FI { cm :: M.HashMap Integer (SubC a) - , ws :: ![WfC a] - , bs :: !BindEnv - , gs :: !FEnv - , lits :: ![(Symbol, Sort)] - , kuts :: Kuts - , quals :: ![Qualifier] - , bindInfo :: M.HashMap BindId a - } - deriving (Show) - -instance Monoid Kuts where - mempty = KS S.empty - mappend k1 k2 = KS $ S.union (ksVars k1) (ksVars k2) - -instance Monoid (SEnv a) where - mempty = SE M.empty - mappend s1 s2 = SE $ M.union (seBinds s1) (seBinds s2) - -instance Monoid BindEnv where - mempty = BE 0 M.empty - mappend (BE 0 _) b = b - mappend b (BE 0 _) = b - mappend _ _ = errorstar "mappend on non-trivial BindEnvs" - -instance Monoid (FInfo a) where - mempty = FI M.empty mempty mempty mempty mempty mempty mempty mempty - mappend i1 i2 = FI { cm = mappend (cm i1) (cm i2) - , ws = mappend (ws i1) (ws i2) - , bs = mappend (bs i1) (bs i2) - , gs = mappend (gs i1) (gs i2) - , lits = mappend (lits i1) (lits i2) - , kuts = mappend (kuts i1) (kuts i2) - , quals = mappend (quals i1) (quals i2) - , bindInfo = mappend (bindInfo i1) (bindInfo i2) - } - -($++$) :: Doc -> Doc -> Doc -x $++$ y = x $+$ text "\n" $+$ y - -toFixpoint :: (Fixpoint a) => Config -> FInfo a -> Doc -toFixpoint cfg x' = qualsDoc x' - $++$ kutsDoc x' - $++$ gsDoc x' - $++$ conDoc x' - $++$ bindsDoc x' - $++$ csDoc x' - $++$ wsDoc x' - $++$ binfoDoc x' - $++$ text "\n" - where - conDoc = vcat . map toFixConstant . lits - csDoc = vcat . map toFix . M.elems . cm - wsDoc = vcat . map toFix . ws - kutsDoc = toFix . kuts - bindsDoc = toFix . bs - gsDoc = toFixGs . gs - qualsDoc = vcat . map toFix . quals - metaDoc (i,d) = toFixMeta (text "bind" <+> toFix i) (toFix d) - mdata = metadata cfg - binfoDoc - | mdata = vcat . map metaDoc . M.toList . bindInfo - | otherwise = \_ -> text "\n" - -------------------------------------------------------------------------- --- | A Class Predicates for Valid Refinements Types --------------------- -------------------------------------------------------------------------- - -class (Monoid r, Subable r) => Reftable r where - isTauto :: r -> Bool - ppTy :: r -> Doc -> Doc - - top :: r -> r - top _ = mempty - - bot :: r -> r - - meet :: r -> r -> r - meet = mappend - - toReft :: r -> Reft - ofReft :: Reft -> r - params :: r -> [Symbol] -- ^ parameters for Reft, vv + others - -instance Monoid Pred where - mempty = PTrue - mappend p q = pAnd [p, q] - mconcat = pAnd - -instance Monoid Refa where - mempty = Refa mempty - mappend ra1 ra2 = Refa $ mappend (raPred ra1) (raPred ra2) - -instance Monoid Reft where - mempty = trueReft - mappend = meetReft - -meetReft (Reft (v, ra)) (Reft (v', ra')) - | v == v' = Reft (v , ra `mappend` ra') - | v == dummySymbol = Reft (v', ra' `mappend` (ra `subst1` (v , EVar v'))) - | otherwise = Reft (v , ra `mappend` (ra' `subst1` (v', EVar v ))) - -instance Subable () where - syms _ = [] - subst _ () = () - substf _ () = () - substa _ () = () - -instance Reftable () where - isTauto _ = True - ppTy _ d = d - top _ = () - bot _ = () - meet _ _ = () - toReft _ = mempty - ofReft _ = mempty - params _ = [] - --- NUKE isTautoReft :: Reft -> Bool --- NUKE isTautoReft (Reft (_, ra)) = isTautoRa ra --- NUKE --- NUKE isTautoRa :: Refa -> Bool --- NUKE isTautoRa = isTautoPred . raPred - - -instance Reftable Reft where - isTauto = all isTautoPred . conjuncts . reftPred - ppTy = pprReft - toReft = id - ofReft = id - params _ = [] - - bot _ = falseReft - top (Reft(v,_)) = Reft (v, mempty) - -instance Monoid Sort where - mempty = FObj "any" - mappend t1 t2 - | t1 == mempty = t2 - | t2 == mempty = t1 - | t1 == t2 = t1 - | otherwise = errorstar $ "mappend-sort: conflicting sorts t1 =" ++ show t1 ++ " t2 = " ++ show t2 - -instance Monoid SortedReft where - mempty = RR mempty mempty - mappend t1 t2 = RR (mappend (sr_sort t1) (sr_sort t2)) (mappend (sr_reft t1) (sr_reft t2)) - -instance Reftable SortedReft where - isTauto = isTauto . toReft - ppTy = ppTy . toReft - toReft = sr_reft - ofReft = error "No instance of ofReft for SortedReft" - params _ = [] - bot s = s { sr_reft = falseReft } - -class Falseable a where - isFalse :: a -> Bool - -instance Falseable Pred where - isFalse (PFalse) = True - isFalse _ = False - -instance Falseable Refa where - isFalse (Refa p) = isFalse p - -instance Falseable Reft where - isFalse (Reft (_, ra)) = isFalse $ raPred ra - ---------------------------------------------------------------- --- | String Constants ----------------------------------------- ---------------------------------------------------------------- - -symConstLits :: FInfo a -> [(Symbol, Sort)] -symConstLits fi = [(encodeSymConst c, sortSymConst c) | c <- symConsts fi] - --- | Replace all symbol-representations-of-string-literals with string-literal --- Used to transform parsed output from fixpoint back into fq. - - -instance Symbolic SymConst where - symbol = encodeSymConst - -encodeSymConst :: SymConst -> Symbol -encodeSymConst (SL s) = symbol $ litPrefix `mappend` s - -sortSymConst :: SymConst -> Sort -sortSymConst (SL _) = strSort - -decodeSymConst :: Symbol -> Maybe SymConst -decodeSymConst = fmap SL . T.stripPrefix litPrefix . symbolText - -litPrefix :: Text -litPrefix = "lit" `T.snoc` symSepName - -class SymConsts a where - symConsts :: a -> [SymConst] - -instance SymConsts (FInfo a) where - symConsts fi = sortNub $ csLits ++ bsLits ++ gsLits ++ qsLits - where - csLits = concatMap symConsts $ M.elems $ cm fi - bsLits = concatMap symConsts $ map snd $ M.elems $ beBinds $ bs fi - gsLits = concatMap symConsts $ M.elems $ seBinds $ gs fi - qsLits = concatMap symConsts $ q_body <$> quals fi - -instance SymConsts (SubC a) where - symConsts c = symConsts (sgrd c) ++ - symConsts (slhs c) ++ - symConsts (srhs c) - -instance SymConsts SortedReft where - symConsts = symConsts . sr_reft - -instance SymConsts Reft where - symConsts (Reft (_, ra)) = symConsts ra - -instance SymConsts Refa where - symConsts (Refa p) = symConsts p - -instance SymConsts Expr where - symConsts (ESym c) = [c] - symConsts (EApp _ es) = concatMap symConsts es - symConsts (ENeg e) = symConsts e - symConsts (EBin _ e e') = concatMap symConsts [e, e'] - symConsts (EIte p e e') = symConsts p ++ concatMap symConsts [e, e'] - symConsts (ECst e _) = symConsts e - symConsts _ = [] - -instance SymConsts Pred where - symConsts (PNot p) = symConsts p - symConsts (PAnd ps) = concatMap symConsts ps - symConsts (POr ps) = concatMap symConsts ps - symConsts (PImp p q) = concatMap symConsts [p, q] - symConsts (PIff p q) = concatMap symConsts [p, q] - symConsts (PAll _ p) = symConsts p - symConsts (PBexp e) = symConsts e - symConsts (PAtom _ e e') = concatMap symConsts [e, e'] - symConsts (PKVar _ (Su xes)) = concatMap symConsts $ snd <$> xes - symConsts _ = [] - ---------------------------------------------------------------- --- | Edit Distance -------------------------------------------- ---------------------------------------------------------------- - - -editDistance :: Eq a => [a] -> [a] -> Int -editDistance xs ys = table ! (m,n) - where - (m,n) = (length xs, length ys) - x = array (1,m) (zip [1..] xs) - y = array (1,n) (zip [1..] ys) - - table :: Array (Int,Int) Int - table = array bnds [(ij, dist ij) | ij <- range bnds] - bnds = ((0,0),(m,n)) - - dist (0,j) = j - dist (i,0) = i - dist (i,j) = minimum [table ! (i-1,j) + 1, table ! (i,j-1) + 1, - if x ! i == y ! j then table ! (i-1,j-1) else 1 + table ! (i-1,j-1)] - - ------------------------------------------------------------------------------ --- | Located Values --------------------------------------------------------- ------------------------------------------------------------------------------ - -data Located a = Loc { loc :: !SourcePos -- ^ Start Position - , locE :: !SourcePos -- ^ End Position - , val :: a - } deriving (Data, Typeable, Generic) - -instance (IsString a) => IsString (Located a) where - fromString = dummyLoc . fromString - -type LocSymbol = Located Symbol -type LocText = Located Text - - -locAt :: String -> a -> Located a -locAt s = Loc l l - where - l = dummyPos s - -dummyLoc :: a -> Located a -dummyLoc = Loc l l - where - l = dummyPos "Fixpoint.Types.dummyLoc" - -dummyPos :: String -> SourcePos -dummyPos s = newPos s 0 0 - -isDummy :: (Symbolic a) => a -> Bool -isDummy a = symbol a == symbol dummyName - -instance Fixpoint SourcePos where - toFix = text . show - -instance Fixpoint a => Fixpoint (Located a) where - toFix = toFix . val - -instance Symbolic a => Symbolic (Located a) where - symbol = symbol . val - -instance Expression a => Expression (Located a) where - expr = expr . val - -instance Functor Located where - fmap f (Loc l l' x) = Loc l l' (f x) - -instance F.Foldable Located where - foldMap f (Loc _ _ x) = f x - -instance Traversable Located where - traverse f (Loc l l' x) = Loc l l' <$> f x - -instance Show a => Show (Located a) where - show (Loc l l' x) = show x ++ " defined from: " ++ show l ++ " to: " ++ show l' - -instance Eq a => Eq (Located a) where - (Loc _ _ x) == (Loc _ _ y) = x == y - -instance Ord a => Ord (Located a) where - compare x y = compare (val x) (val y) - -instance Subable a => Subable (Located a) where - syms (Loc _ _ x) = syms x - substa f (Loc l l' x) = Loc l l' (substa f x) - substf f (Loc l l' x) = Loc l l' (substf f x) - subst su (Loc l l' x) = Loc l l' (subst su x) - -instance Hashable a => Hashable (Located a) where - hashWithSalt i = hashWithSalt i . val - -instance (NFData a) => NFData (Located a) where - -- FIXME: no instance NFData SrcSpan - rnf (Loc _ _ x) = rnf x - -------------------------------------------------------------------------- --- | Exported Basic Sorts ----------------------------------------------- -------------------------------------------------------------------------- - -boolSort, intSort, propSort, realSort, strSort :: Sort -boolSort = fTyconSort boolFTyCon -strSort = fTyconSort strFTyCon -intSort = fTyconSort intFTyCon -realSort = fTyconSort realFTyCon -propSort = fTyconSort propFTyCon - -fTyConSort :: FTycon -> Sort -fTyConSort c = fApp (Left c) [] +-- | This module re-exports the data types, operations and +-- serialization functions for representing Fixpoint's +-- implication (i.e. subtyping) and well-formedness +-- constraints. + +module Language.Fixpoint.Types ( + module Language.Fixpoint.Types.PrettyPrint + , module Language.Fixpoint.Types.Spans + , module Language.Fixpoint.Types.Errors + , module Language.Fixpoint.Types.Names + , module Language.Fixpoint.Types.Sorts + , module Language.Fixpoint.Types.Refinements + , module Language.Fixpoint.Types.Substitutions + , module Language.Fixpoint.Types.Environments + , module Language.Fixpoint.Types.Constraints + , module Language.Fixpoint.Types.Graphs + , module Language.Fixpoint.Types.Utils + ) where + +import Language.Fixpoint.Types.PrettyPrint +import Language.Fixpoint.Types.Names +import Language.Fixpoint.Types.Errors +import Language.Fixpoint.Types.Spans +import Language.Fixpoint.Types.Sorts +import Language.Fixpoint.Types.Refinements +import Language.Fixpoint.Types.Substitutions +import Language.Fixpoint.Types.Environments +import Language.Fixpoint.Types.Constraints +import Language.Fixpoint.Types.Graphs +import Language.Fixpoint.Types.Utils diff --git a/src/Language/Fixpoint/Types/Config.hs b/src/Language/Fixpoint/Types/Config.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fixpoint/Types/Config.hs @@ -0,0 +1,194 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DeriveGeneric #-} + +module Language.Fixpoint.Types.Config ( + Config (..) + , getOpts + , Command (..) + , SMTSolver (..) + , GenQualifierSort (..) + , UeqAllSorts (..) + , withTarget + , defaultMinPartSize + , defaultMaxPartSize + , multicore + , queryFile +) where + +import Data.Maybe (fromMaybe) +import Data.List (find) +import GHC.Generics +import System.Console.CmdArgs +import Language.Fixpoint.Utils.Files + +class Command a where + command :: a -> String + +------------------------------------------------------------------------ +-- Configuration Options ----------------------------------------------- +------------------------------------------------------------------------ + +withTarget :: Config -> FilePath -> Config +withTarget cfg fq = cfg { inFile = fq } { outFile = fq `withExt` Out } + +defaultMinPartSize :: Int +defaultMinPartSize = 500 + +defaultMaxPartSize :: Int +defaultMaxPartSize = 700 + +data Config + = Config { + inFile :: FilePath -- ^ target fq-file + , outFile :: FilePath -- ^ output file + , srcFile :: FilePath -- ^ src file (*.hs, *.ts, *.c) + , cores :: Maybe Int -- ^ number of cores used to solve constraints + , minPartSize :: Int -- ^ Minimum size of a partition + , maxPartSize :: Int -- ^ Maximum size of a partition. Overrides minPartSize + , solver :: SMTSolver -- ^ which SMT solver to use + , genSorts :: GenQualifierSort -- ^ generalize qualifier sorts + , ueqAllSorts :: UeqAllSorts -- ^ use UEq on all sorts + , linear :: Bool -- ^ not interpret div and mul in SMT + , allowHO :: Bool -- ^ not interpret div and mul in SMT + , newcheck :: Bool -- ^ new fixpoint sort check + , eliminate :: Bool -- ^ eliminate non-cut KVars + , elimStats :: Bool -- ^ print eliminate stats + , solverStats :: Bool -- ^ print solver stats + , metadata :: Bool -- ^ print meta-data associated with constraints + , stats :: Bool -- ^ compute constraint statistics + , parts :: Bool -- ^ partition FInfo into separate fq files + , save :: Bool -- ^ save FInfo as .bfq and .fq file + , minimize :: Bool -- ^ use delta debug to min fq file + -- , nontriv :: Bool -- ^ simplify using non-trivial sorts + , gradual :: Bool -- ^ solve "gradual" constraints + } deriving (Eq,Data,Typeable,Show) + + +instance Default Config where + def = Config { inFile = "" + , outFile = def + , srcFile = def + , cores = def + , minPartSize = defaultMinPartSize + , maxPartSize = defaultMaxPartSize + , solver = def + , genSorts = def + , ueqAllSorts = def + , linear = def + , allowHO = False + , newcheck = False + , eliminate = def + , elimStats = def + , solverStats = False + , metadata = def + , stats = def + , parts = def + , save = def + , minimize = def + , gradual = False + } + +instance Command Config where + command c = command (genSorts c) + ++ command (ueqAllSorts c) + ++ command (solver c) + ++ " -out " + ++ outFile c ++ " " + ++ inFile c + +--------------------------------------------------------------------------------------- +newtype GenQualifierSort = GQS Bool + deriving (Eq, Data,Typeable,Show) + +instance Default GenQualifierSort where + def = GQS False + +instance Command GenQualifierSort where + command (GQS True) = "" + command (GQS False) = "-no-gen-qual-sorts" + +newtype UeqAllSorts = UAS Bool + deriving (Eq, Data,Typeable,Show) + +instance Default UeqAllSorts where + def = UAS False + +instance Command UeqAllSorts where + command (UAS True) = " -ueq-all-sorts " + command (UAS False) = "" + +-- instance Command Cores where +-- command (C n) = " --cores=" ++ show n + + +--------------------------------------------------------------------------------------- + +data SMTSolver = Z3 | Cvc4 | Mathsat + deriving (Eq, Data, Typeable, Generic) + +instance Command SMTSolver where + command s = " -smtsolver " ++ show s + +instance Default SMTSolver where + def = Z3 + +instance Show SMTSolver where + show Z3 = "z3" + show Cvc4 = "cvc4" + show Mathsat = "mathsat" + +--------------------------------------------------------------------------------------- + +config :: Config +config = Config { + inFile = def &= typ "TARGET" &= args &= typFile + , outFile = "out" &= help "Output file" + , srcFile = def &= help "Source File from which FQ is generated" + , solver = def &= help "Name of SMT Solver" + , genSorts = def &= help "Generalize qualifier sorts" + , ueqAllSorts = def &= help "Use UEq on all sorts" + , newcheck = False &= help "(alpha) New liquid-fixpoint sort checking " + , linear = False &= help "Use uninterpreted integer multiplication and division" + , allowHO = False &= help "Allow higher order binders into fixpoint environment" + , eliminate = False &= help "(alpha) Eliminate non-cut KVars" + , elimStats = False &= help "(alpha) Print eliminate stats" + , solverStats = False &= help "Print solver stats" + , save = False &= help "Save Query as .fq and .bfq files" + , metadata = False &= help "Print meta-data associated with constraints" + , stats = False &= help "Compute constraint statistics" + , parts = False &= help "Partition constraints into indepdendent .fq files" + , cores = def &= help "(numeric) Number of threads to use" + , minPartSize = defaultMinPartSize &= help "(numeric) Minimum partition size when solving in parallel" + , maxPartSize = defaultMaxPartSize &= help "(numeric) Maximum partiton size when solving in parallel." + , minimize = False &= help "Use delta debug to minimize fq file" + , gradual = False &= help "Solve gradual-refinement typing constraints" + } + &= verbosity + &= program "fixpoint" + &= help "Predicate Abstraction Based Horn-Clause Solver" + &= summary "fixpoint Copyright 2009-15 Regents of the University of California." + &= details [ "Predicate Abstraction Based Horn-Clause Solver" + , "" + , "To check a file foo.fq type:" + , " fixpoint foo.fq" + ] + +getOpts :: IO Config +getOpts = do md <- cmdArgs config + putStrLn banner + return md + +banner :: String +banner = "\n\nLiquid-Fixpoint Copyright 2013-15 Regents of the University of California.\n" + ++ "All Rights Reserved.\n" + +multicore :: Config -> Bool +multicore cfg = cores cfg /= Just 1 + +queryFile :: Ext -> Config -> FilePath +queryFile e cfg = extFileName e f + where + f = fromMaybe "out" $ find (not . null) [srcFile cfg, inFile cfg] diff --git a/src/Language/Fixpoint/Types/Constraints.hs b/src/Language/Fixpoint/Types/Constraints.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fixpoint/Types/Constraints.hs @@ -0,0 +1,577 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternGuards #-} + +-- | This module contains the top-level query data types and elements, +-- including (Horn) implication & well-formedness constraints and sets. + +module Language.Fixpoint.Types.Constraints ( + + -- * Top-level Queries + FInfo, SInfo, GInfo (..) + , convertFormat + , Solver + + -- * Serializing + , toFixpoint + , writeFInfo + , saveQuery + + -- * Constructing Queries + , fi + + -- * Constraints + , WfC (..) + , SubC, mkSubC, subcId, sid, senv, slhs, srhs, stag, subC, wfC + , SimpC (..) + , Tag + , TaggedC, clhs, crhs + + -- * Accessing Constraints + , addIds + , sinfo + , shiftVV + + -- * Qualifiers + , Qualifier (..) + , qualifier + , EQual (..) + , eQual + + -- * Results + , FixSolution + , Result (..) + + -- * Solutions + , Hyp + , Cube (..) + , QBind + , Cand + , Sol (..) + , Solution + , solFromList, solInsert, solLookup, solResult + + -- * Cut KVars + , Kuts (..) + , ksMember + + + + ) where + +import qualified Data.Binary as B +import Data.Generics (Data) +import Data.Typeable (Typeable) +import GHC.Generics (Generic) +import Data.List (sort, nub, delete) +import Data.Maybe (catMaybes) +import Control.DeepSeq +import Control.Monad (void) +import Language.Fixpoint.Types.PrettyPrint +import Language.Fixpoint.Types.Config hiding (allowHO) +import Language.Fixpoint.Types.Names +import Language.Fixpoint.Types.Errors +import Language.Fixpoint.Types.Spans +import Language.Fixpoint.Types.Sorts +import Language.Fixpoint.Types.Refinements +import Language.Fixpoint.Types.Substitutions +import Language.Fixpoint.Types.Environments +import qualified Language.Fixpoint.Utils.Files as Files + +import Language.Fixpoint.Misc +import Text.PrettyPrint.HughesPJ +import qualified Data.HashMap.Strict as M +import qualified Data.HashSet as S + +-------------------------------------------------------------------------------- +-- | Constraints --------------------------------------------------------------- +-------------------------------------------------------------------------------- + +{-@ type Tag = { v : [Int] | len(v) = 1 } @-} +type Tag = [Int] + +data WfC a = WfC { wenv :: !IBindEnv + , wrft :: (Symbol, Sort, KVar) + , winfo :: !a + } + deriving (Eq, Generic, Functor) + +data SubC a = SubC { _senv :: !IBindEnv + , slhs :: !SortedReft + , srhs :: !SortedReft + , _sid :: !(Maybe Integer) + , _stag :: !Tag + , _sinfo :: !a + } + deriving (Eq, Generic, Functor) + +data SimpC a = SimpC { _cenv :: !IBindEnv + , _crhs :: !Expr + , _cid :: !(Maybe Integer) + , _ctag :: !Tag + , _cinfo :: !a + } + deriving (Generic, Functor) + +class TaggedC c a where + senv :: c a -> IBindEnv + sid :: c a -> Maybe Integer + stag :: c a -> Tag + sinfo :: c a -> a + clhs :: BindEnv -> c a -> [(Symbol, SortedReft)] + crhs :: c a -> Expr + +instance TaggedC SimpC a where + senv = _cenv + sid = _cid + stag = _ctag + sinfo = _cinfo + crhs = _crhs + clhs be c = envCs be (senv c) + +instance TaggedC SubC a where + senv = _senv + sid = _sid + stag = _stag + sinfo = _sinfo + crhs = reftPred . sr_reft . srhs + clhs be c = sortedReftBind (slhs c) : envCs be (senv c) + +sortedReftBind :: SortedReft -> (Symbol, SortedReft) +sortedReftBind sr = (x, sr) + where + Reft (x, _) = sr_reft sr + +subcId :: (TaggedC c a) => c a -> Integer +subcId = mfromJust "subCId" . sid + +--------------------------------------------------------------------------- +-- | Solutions and Results +--------------------------------------------------------------------------- + +type FixSolution = M.HashMap KVar Expr + +data Result a = Result { resStatus :: FixResult a + , resSolution :: FixSolution } + deriving (Generic, Show) + +instance Monoid (Result a) where + mempty = Result mempty mempty + mappend r1 r2 = Result stat soln + where + stat = mappend (resStatus r1) (resStatus r2) + soln = mappend (resSolution r1) (resSolution r2) + +instance (Ord a, Fixpoint a) => Fixpoint (FixResult (SubC a)) where + toFix Safe = text "Safe" + -- toFix (UnknownError d) = text $ "Unknown Error: " ++ d + toFix (Crash xs msg) = vcat $ [ text "Crash!" ] ++ pprSinfos "CRASH: " xs ++ [parens (text msg)] + toFix (Unsafe xs) = vcat $ text "Unsafe:" : pprSinfos "WARNING: " xs + +pprSinfos :: (Ord a, Fixpoint a) => String -> [SubC a] -> [Doc] +pprSinfos msg = map ((text msg <>) . toFix) . sort . fmap sinfo + +instance Fixpoint a => Show (WfC a) where + show = showFix + +instance Fixpoint a => Show (SubC a) where + show = showFix + +instance Fixpoint a => Show (SimpC a) where + show = showFix + +instance Fixpoint a => PPrint (SubC a) where + pprintTidy _ = toFix + +instance Fixpoint a => PPrint (SimpC a) where + pprintTidy _ = toFix + +instance Fixpoint a => PPrint (WfC a) where + pprintTidy _ = toFix + +instance Fixpoint a => Fixpoint (SubC a) where + toFix c = hang (text "\n\nconstraint:") 2 bd + where bd = toFix (senv c) + $+$ text "lhs" <+> toFix (slhs c) + $+$ text "rhs" <+> toFix (srhs c) + $+$ (pprId (sid c) <+> text "tag" <+> toFix (stag c)) + $+$ toFixMeta (text "constraint" <+> pprId (sid c)) (toFix (sinfo c)) + +instance Fixpoint a => Fixpoint (SimpC a) where + toFix c = hang (text "\n\nsimpleConstraint:") 2 bd + where bd = toFix (senv c) + $+$ text "rhs" <+> toFix (crhs c) + $+$ (pprId (sid c) <+> text "tag" <+> toFix (stag c)) + $+$ toFixMeta (text "simpleConstraint" <+> pprId (sid c)) (toFix (sinfo c)) + +instance Fixpoint a => Fixpoint (WfC a) where + toFix w = hang (text "\n\nwf:") 2 bd + where bd = toFix (wenv w) + -- NOTE: this next line is printed this way for compatability with the OCAML solver + $+$ text "reft" <+> toFix (RR t (Reft (v, PKVar k mempty))) + $+$ toFixMeta (text "wf") (toFix (winfo w)) + (v, t, k) = wrft w + +toFixMeta :: Doc -> Doc -> Doc +toFixMeta k v = text "// META" <+> k <+> text ":" <+> v + +pprId (Just i) = text "id" <+> tshow i +pprId _ = text "" + +---------------------------------------------------------------- +instance B.Binary Qualifier +instance B.Binary Kuts +instance (B.Binary a) => B.Binary (SubC a) +instance (B.Binary a) => B.Binary (WfC a) +instance (B.Binary a) => B.Binary (SimpC a) +instance (B.Binary (c a), B.Binary a) => B.Binary (GInfo c a) + +instance NFData Qualifier +instance NFData Kuts + +instance (NFData a) => NFData (SubC a) +instance (NFData a) => NFData (WfC a) +instance (NFData a) => NFData (SimpC a) +instance (NFData (c a), NFData a) => NFData (GInfo c a) +instance (NFData a) => NFData (Result a) + +--------------------------------------------------------------------------- +-- | "Smart Constructors" for Constraints --------------------------------- +--------------------------------------------------------------------------- + +wfC :: (Fixpoint a) => IBindEnv -> SortedReft -> a -> [WfC a] +wfC be sr x = if all isEmptySubst sus + then [WfC be (v, sr_sort sr, k) x | k <- ks] + else errorstar msg + where + msg = "wfKvar: malformed wfC " ++ show sr + Reft (v, ras) = sr_reft sr + (ks, sus) = unzip $ go ras + + go (PKVar k su) = [(k, su)] + go (PAnd es) = [(k, su) | PKVar k su <- es] + go _ = [] + +mkSubC = SubC + +subC :: IBindEnv -> SortedReft -> SortedReft -> Maybe Integer -> Tag -> a -> [SubC a] +subC γ sr1 sr2 i y z = [SubC γ sr1' (sr2' r2') i y z | r2' <- reftConjuncts r2] + where + RR t1 r1 = sr1 + RR t2 r2 = sr2 + sr1' = RR t1 $ shiftVV r1 vv' + sr2' r2' = RR t2 $ shiftVV r2' vv' + vv' = mkVV i + +mkVV :: Maybe Integer -> Symbol +mkVV (Just i) = vv $ Just i +mkVV Nothing = vvCon + +shiftVV :: Reft -> Symbol -> Reft +shiftVV r@(Reft (v, ras)) v' + | v == v' = r + | otherwise = Reft (v', subst1 ras (v, EVar v')) + +addIds = zipWith (\i c -> (i, shiftId i $ c {_sid = Just i})) [1..] + where -- Adding shiftId to have distinct VV for SMT conversion + shiftId i c = c { slhs = shiftSR i $ slhs c } + { srhs = shiftSR i $ srhs c } + shiftSR i sr = sr { sr_reft = shiftR i $ sr_reft sr } + shiftR i r@(Reft (v, _)) = shiftVV r (intSymbol v i) + +-------------------------------------------------------------------------------- +-- | Qualifiers ---------------------------------------------------------------- +-------------------------------------------------------------------------------- + +data Qualifier = Q { q_name :: Symbol -- ^ Name + , q_params :: [(Symbol, Sort)] -- ^ Parameters + , q_body :: Expr -- ^ Predicate + , q_pos :: !SourcePos -- ^ Source Location + } + deriving (Eq, Show, Data, Typeable, Generic) + +instance Loc Qualifier where + srcSpan q = SS l l + where + l = q_pos q + +instance Fixpoint Qualifier where + toFix = pprQual + +instance PPrint Qualifier where + pprintTidy k q = hcat [ "qualif" + , pprintTidy k (q_name q) + , "defined at" + , pprintTidy k (q_pos q) ] + +pprQual (Q n xts p l) = text "qualif" <+> text (symbolString n) <> parens args <> colon <+> parens (toFix p) <+> text "//" <+> toFix l + where + args = intersperse comma (toFix <$> xts) + +qualifier :: SEnv Sort -> SourcePos -> SEnv Sort -> Symbol -> Sort -> Expr -> Qualifier +qualifier lEnv l γ v so p = Q "Auto" ((v, so) : xts) p l + where + xs = delete v $ nub $ syms p + xts = catMaybes $ zipWith (envSort l lEnv γ) xs [0..] + +envSort :: SourcePos -> SEnv Sort -> SEnv Sort -> Symbol -> Integer -> Maybe (Symbol, Sort) +envSort l lEnv tEnv x i + | Just t <- lookupSEnv x tEnv = Just (x, t) + | Just _ <- lookupSEnv x lEnv = Nothing + | otherwise = Just (x, ai) + where + ai = {- trace msg $ -} fObj $ Loc l l $ tempSymbol "LHTV" i + -- msg = "unknown symbol in qualifier: " ++ show x + +-------------------------------------------------------------------------------- +-- | Constraint Cut Sets ------------------------------------------------------- +-------------------------------------------------------------------------------- + +newtype Kuts = KS { ksVars :: S.HashSet KVar } + deriving (Eq, Show, Generic) + +instance Fixpoint Kuts where + toFix (KS s) = vcat $ ((text "cut " <>) . toFix) <$> S.toList s + +ksMember :: KVar -> Kuts -> Bool +ksMember k (KS s) = S.member k s + +instance Monoid Kuts where + mempty = KS S.empty + mappend k1 k2 = KS $ S.union (ksVars k1) (ksVars k2) + +------------------------------------------------------------------------ +-- | Constructing Queries +------------------------------------------------------------------------ +fi cs ws binds ls ks qs bi fn aHO + = FI { cm = M.fromList $ addIds cs + , ws = M.fromListWith err [(k, w) | w <- ws, let (_, _, k) = wrft w] + , bs = binds + , lits = ls + , kuts = ks + , quals = qs + , bindInfo = bi + , fileName = fn + , allowHO = aHO + } + where + --TODO handle duplicates gracefully instead (merge envs by intersect?) + err = errorstar "multiple WfCs with same kvar" + +------------------------------------------------------------------------ +-- | Top-level Queries +------------------------------------------------------------------------ + +type FInfo a = GInfo SubC a +type SInfo a = GInfo SimpC a +data GInfo c a = + FI { cm :: M.HashMap Integer (c a) + , ws :: M.HashMap KVar (WfC a) + , bs :: !BindEnv + , lits :: !(SEnv Sort) + , kuts :: Kuts + , quals :: ![Qualifier] + , bindInfo :: M.HashMap BindId a + , fileName :: FilePath + , allowHO :: !Bool + } + deriving (Eq, Show, Functor, Generic) + + +instance Monoid (GInfo c a) where + mempty = FI M.empty mempty mempty mempty mempty mempty mempty mempty False + mappend i1 i2 = FI { cm = mappend (cm i1) (cm i2) + , ws = mappend (ws i1) (ws i2) + , bs = mappend (bs i1) (bs i2) + , lits = mappend (lits i1) (lits i2) + , kuts = mappend (kuts i1) (kuts i2) + , quals = mappend (quals i1) (quals i2) + , bindInfo = mappend (bindInfo i1) (bindInfo i2) + , fileName = fileName i1 + , allowHO = allowHO i1 || allowHO i2 + } + +instance PTable (SInfo a) where + ptable z = DocTable [ (text "# Sub Constraints", pprint $ length $ cm z) + , (text "# WF Constraints", pprint $ length $ ws z) + ] + +-------------------------------------------------------------------------- +-- | Rendering Queries +-------------------------------------------------------------------------- +toFixpoint :: (Fixpoint a, Fixpoint (c a)) => Config -> GInfo c a -> Doc +-------------------------------------------------------------------------- +toFixpoint cfg x' = qualsDoc x' + $++$ kutsDoc x' + $++$ conDoc x' + $++$ bindsDoc x' + $++$ csDoc x' + $++$ wsDoc x' + $++$ binfoDoc x' + $++$ text "\n" + where + conDoc = vcat . map toFixConstant . toListSEnv . lits + csDoc = vcat . map toFix . M.elems . cm + wsDoc = vcat . map toFix . M.elems . ws + kutsDoc = toFix . kuts + bindsDoc = toFix . bs + qualsDoc = vcat . map toFix . quals + metaDoc (i,d) = toFixMeta (text "bind" <+> toFix i) (toFix d) + mdata = metadata cfg + binfoDoc + | mdata = vcat . map metaDoc . M.toList . bindInfo + | otherwise = \_ -> text "\n" + +($++$) :: Doc -> Doc -> Doc +x $++$ y = x $+$ text "\n" $+$ y + +toFixConstant (c, so) + = text "constant" <+> toFix c <+> text ":" <+> parens (toFix so) + +writeFInfo :: (Fixpoint a, Fixpoint (c a)) => Config -> GInfo c a -> FilePath -> IO () +writeFInfo cfg fq f = writeFile f (render $ toFixpoint cfg fq) + +-------------------------------------------------------------------------- +-- | Query Conversions: FInfo to SInfo +--------------------------------------------------------------------------- +convertFormat :: (Fixpoint a) => FInfo a -> SInfo a +--------------------------------------------------------------------------- +convertFormat fi = fi' { cm = subcToSimpc <$> cm fi' } + where + fi' = M.foldlWithKey' blowOutVV fi $ cm fi + +subcToSimpc :: SubC a -> SimpC a +subcToSimpc s = SimpC + { _cenv = senv s + , _crhs = reftPred $ sr_reft $ srhs s + , _cid = sid s + , _ctag = stag s + , _cinfo = sinfo s + } + +blowOutVV :: FInfo a -> Integer -> SubC a -> FInfo a +blowOutVV fi i subc = fi { bs = be', cm = cm' } + where + sr = slhs subc + x = reftBind $ sr_reft sr + (bindId, be') = insertBindEnv x sr $ bs fi + subc' = subc { _senv = insertsIBindEnv [bindId] $ senv subc } + cm' = M.insert i subc' $ cm fi + + + +-------------------------------------------------------------------------------- +-- | Solutions (Instantiated Qualfiers )---------------------------------------- +-------------------------------------------------------------------------------- + +data EQual = EQL { eqQual :: !Qualifier + , eqPred :: !Expr + , eqArgs :: ![Expr] + } + deriving (Eq, Show, Data, Typeable, Generic) + +instance PPrint EQual where + pprintTidy k = pprintTidy k . eqPred + +instance NFData EQual + +{- EQL :: q:_ -> p:_ -> ListX F.Expr {q_params q} -> _ @-} +eQual :: Qualifier -> [Symbol] -> EQual +eQual q xs = EQL q p es + where + p = subst su $ q_body q + su = mkSubst $ safeZip "eQual" qxs es + es = eVar <$> xs + qxs = fst <$> q_params q + + +-------------------------------------------------------------------------------- +-- | Types --------------------------------------------------------------------- +-------------------------------------------------------------------------------- + +type Solution = Sol QBind + +data Sol a = Sol { sMap :: M.HashMap KVar a + , sHyp :: M.HashMap KVar Hyp + } + +data Cube = Cube + { cuBinds :: IBindEnv + , cuSubst :: Subst + } + +type Hyp = ListNE Cube + +type QBind = [EQual] + +type Cand a = [(Expr, a)] + +instance Monoid (Sol a) where + mempty = Sol mempty mempty + mappend s1 s2 = Sol { sMap = mappend (sMap s1) (sMap s2) + , sHyp = mappend (sHyp s1) (sHyp s2) + } + +instance Functor Sol where + fmap f (Sol s h) = Sol (f <$> s) h + +instance PPrint a => PPrint (Sol a) where + pprintTidy k = pprintTidy k . sMap + +-------------------------------------------------------------------------------- +solResult :: Solution -> M.HashMap KVar Expr +-------------------------------------------------------------------------------- +solResult s = sMap $ (pAnd . fmap eqPred) <$> s + + +-------------------------------------------------------------------------------- +-- | Create a Solution --------------------------------------------------------- +-------------------------------------------------------------------------------- +solFromList :: [(KVar, a)] -> [(KVar, Hyp)] -> Sol a +solFromList kXs kYs = Sol (M.fromList kXs) (M.fromList kYs) + +-------------------------------------------------------------------------------- +-- | Read / Write Solution at KVar --------------------------------------------- +-------------------------------------------------------------------------------- +solLookup :: Solution -> KVar -> QBind +-------------------------------------------------------------------------------- +solLookup s k = M.lookupDefault [] k (sMap s) + +-------------------------------------------------------------------------------- +solInsert :: KVar -> a -> Sol a -> Sol a +-------------------------------------------------------------------------------- +solInsert k qs s = s { sMap = M.insert k qs (sMap s) } + +--------------------------------------------------------------------------- +-- | Top level Solvers ---------------------------------------------------- +--------------------------------------------------------------------------- +type Solver a = Config -> FInfo a -> IO (Result (Integer, a)) + +-------------------------------------------------------------------------------- +saveQuery :: Config -> FInfo a -> IO () +-------------------------------------------------------------------------------- +saveQuery cfg fi = {- when (save cfg) $ -} do + let fi' = void fi + saveBinaryQuery cfg fi' + saveTextQuery cfg fi' + +saveBinaryQuery cfg fi = do + let bfq = queryFile Files.BinFq cfg + putStrLn $ "Saving Binary Query: " ++ bfq ++ "\n" + ensurePath bfq + B.encodeFile bfq fi + +saveTextQuery cfg fi = do + let fq = queryFile Files.Fq cfg + putStrLn $ "Saving Text Query: " ++ fq ++ "\n" + ensurePath fq + writeFile fq $ render (toFixpoint cfg fi) diff --git a/src/Language/Fixpoint/Types/Environments.hs b/src/Language/Fixpoint/Types/Environments.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fixpoint/Types/Environments.hs @@ -0,0 +1,195 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternGuards #-} + +module Language.Fixpoint.Types.Environments ( + + -- * Environments + SEnv, SESearch(..) + , emptySEnv, toListSEnv, fromListSEnv + , mapSEnvWithKey, mapSEnv + , insertSEnv, deleteSEnv, memberSEnv, lookupSEnv, unionSEnv + , intersectWithSEnv + , differenceSEnv + , filterSEnv + , lookupSEnvWithDistance + , envCs + + , IBindEnv, BindId, BindMap + , emptyIBindEnv, insertsIBindEnv, deleteIBindEnv, elemsIBindEnv + + , BindEnv, beBinds + , insertBindEnv, emptyBindEnv, lookupBindEnv, mapBindEnv, adjustBindEnv + , bindEnvFromList, bindEnvToList + , unionIBindEnv, diffIBindEnv + ) where + +-- import qualified Data.Binary as B +import qualified Data.Binary as B +import Data.Generics (Data) +import Data.Typeable (Typeable) +import GHC.Generics (Generic) +import Data.Hashable +import qualified Data.HashMap.Strict as M +import qualified Data.HashSet as S +import Data.Maybe +import Text.PrettyPrint.HughesPJ +import Control.DeepSeq + +import Language.Fixpoint.Types.PrettyPrint +import Language.Fixpoint.Types.Names +import Language.Fixpoint.Types.Refinements +import Language.Fixpoint.Types.Substitutions () +import Language.Fixpoint.Misc + +type BindId = Int +type BindMap a = M.HashMap BindId a + +newtype IBindEnv = FB (S.HashSet BindId) deriving (Eq, Data, Typeable, Generic) + +newtype SEnv a = SE { seBinds :: M.HashMap Symbol a } + deriving (Eq, Data, Typeable, Generic, Foldable, Traversable) + +data SizedEnv a = BE { _beSize :: Int + , beBinds :: BindMap a + } deriving (Eq, Show, Functor, Foldable, Generic, Traversable) + +type BindEnv = SizedEnv (Symbol, SortedReft) +-- Invariant: All BindIds in the map are less than beSize + + +toListSEnv :: SEnv a -> [(Symbol, a)] +toListSEnv (SE env) = M.toList env + +fromListSEnv :: [(Symbol, a)] -> SEnv a +fromListSEnv = SE . M.fromList + +mapSEnv f (SE env) = SE (fmap f env) +mapSEnvWithKey f = fromListSEnv . fmap f . toListSEnv +deleteSEnv x (SE env) = SE (M.delete x env) +insertSEnv x y (SE env) = SE (M.insert x y env) +lookupSEnv x (SE env) = M.lookup x env +emptySEnv = SE M.empty +memberSEnv x (SE env) = M.member x env +intersectWithSEnv f (SE m1) (SE m2) = SE (M.intersectionWith f m1 m2) +differenceSEnv (SE m1) (SE m2) = SE (M.difference m1 m2) +filterSEnv f (SE m) = SE (M.filter f m) +unionSEnv (SE m1) m2 = SE (M.union m1 m2) + +lookupSEnvWithDistance x (SE env) + = case M.lookup x env of + Just z -> Found z + Nothing -> Alts $ symbol <$> alts + where + alts = takeMin $ zip (editDistance x' <$> ss) ss + ss = symbolString <$> fst <$> M.toList env + x' = symbolString x + takeMin xs = [z | (d, z) <- xs, d == getMin xs] + getMin = minimum . (fst <$>) + + +data SESearch a = Found a | Alts [Symbol] + +-- | Functions for Indexed Bind Environment + +emptyIBindEnv :: IBindEnv +emptyIBindEnv = FB S.empty + +deleteIBindEnv :: BindId -> IBindEnv -> IBindEnv +deleteIBindEnv i (FB s) = FB (S.delete i s) + +insertsIBindEnv :: [BindId] -> IBindEnv -> IBindEnv +insertsIBindEnv is (FB s) = FB (foldr S.insert s is) + +elemsIBindEnv :: IBindEnv -> [BindId] +elemsIBindEnv (FB s) = S.toList s + + +-- | Functions for Global Binder Environment +insertBindEnv :: Symbol -> SortedReft -> BindEnv -> (BindId, BindEnv) +insertBindEnv x r (BE n m) = (n, BE (n + 1) (M.insert n (x, r) m)) + +emptyBindEnv :: BindEnv +emptyBindEnv = BE 0 M.empty + +bindEnvFromList :: [(BindId, Symbol, SortedReft)] -> BindEnv +bindEnvFromList [] = emptyBindEnv +bindEnvFromList bs = BE (1 + maxId) be + where + maxId = maximum $ fst3 <$> bs + be = M.fromList [(n, (x, r)) | (n, x, r) <- bs] + +bindEnvToList :: BindEnv -> [(BindId, Symbol, SortedReft)] +bindEnvToList (BE _ be) = [(n, x, r) | (n, (x, r)) <- M.toList be] + +mapBindEnv :: ((Symbol, SortedReft) -> (Symbol, SortedReft)) -> BindEnv -> BindEnv +mapBindEnv f (BE n m) = BE n $ M.map f m + +lookupBindEnv :: BindId -> BindEnv -> (Symbol, SortedReft) +lookupBindEnv k (BE _ m) = fromMaybe err (M.lookup k m) + where + err = errorstar $ "lookupBindEnv: cannot find binder" ++ show k + +unionIBindEnv :: IBindEnv -> IBindEnv -> IBindEnv +unionIBindEnv (FB m1) (FB m2) = FB $ m1 `S.union` m2 + +diffIBindEnv :: IBindEnv -> IBindEnv -> IBindEnv +diffIBindEnv (FB m1) (FB m2) = FB $ m1 `S.difference` m2 + + +adjustBindEnv :: ((Symbol, SortedReft) -> (Symbol, SortedReft)) -> BindId -> BindEnv -> BindEnv +adjustBindEnv f i (BE n m) = BE n $ M.adjust f i m + +instance Functor SEnv where + fmap = mapSEnv + +instance Fixpoint BindEnv where + toFix (BE _ m) = vcat $ map toFixBind $ hashMapToAscList m + +toFixBind (i, (x, r)) = text "bind" <+> toFix i <+> toFix x <+> text ":" <+> toFix r + +instance (Fixpoint a) => Fixpoint (SEnv a) where + toFix (SE m) = toFix (hashMapToAscList m) + +instance Fixpoint (SEnv a) => Show (SEnv a) where + show = render . toFix + +instance Monoid (SEnv a) where + mempty = SE M.empty + mappend s1 s2 = SE $ M.union (seBinds s1) (seBinds s2) + +instance Monoid BindEnv where + mempty = BE 0 M.empty + mappend (BE 0 _) b = b + mappend b (BE 0 _) = b + mappend _ _ = errorstar "mappend on non-trivial BindEnvs" + +envCs :: BindEnv -> IBindEnv -> [(Symbol, SortedReft)] +envCs be env = [lookupBindEnv i be | i <- elemsIBindEnv env] + +instance Fixpoint (IBindEnv) where + toFix (FB ids) = text "env" <+> toFix ids + +-------------------------------------------------------------------------------- + +instance NFData IBindEnv +instance NFData BindEnv +instance (NFData a) => NFData (SEnv a) + +instance B.Binary IBindEnv +instance B.Binary BindEnv +instance (B.Binary a) => B.Binary (SEnv a) +instance (Hashable a, Eq a, B.Binary a) => B.Binary (S.HashSet a) where + put = B.put . S.toList + get = S.fromList <$> B.get diff --git a/src/Language/Fixpoint/Types/Errors.hs b/src/Language/Fixpoint/Types/Errors.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fixpoint/Types/Errors.hs @@ -0,0 +1,184 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Language.Fixpoint.Types.Errors ( + -- * Concrete Location Type + SrcSpan (..) + , dummySpan + , sourcePosElts + + -- * Result + + , FixResult (..) + , colorResult + , resultDoc + + -- * Abstract Error Type + , Error + + -- * Constructor + , err + + -- * Accessors + , errLoc + , errMsg + + -- * Adding Insult to Injury + , catError + , catErrors + + -- * Fatal Exit + , die + , exit + + -- * Some popular errors + , errFreeVarInQual + , errFreeVarInConstraint + ) where + +import Control.Exception +-- import qualified Control.Monad.Error as E +import Data.Serialize (Serialize (..)) +import Data.Generics (Data) +import Data.Typeable +import Control.DeepSeq +-- import Data.Hashable +import qualified Data.Binary as B +import GHC.Generics (Generic) +import Language.Fixpoint.Types.PrettyPrint +import Language.Fixpoint.Types.Spans +import Language.Fixpoint.Misc +import Text.PrettyPrint.HughesPJ +-- import Text.Printf +import Data.Function (on) + +-- import Debug.Trace + +instance Serialize Error1 +instance Serialize TextDetails +instance Serialize Doc +instance Serialize Error +instance Serialize (FixResult Error) + +instance (B.Binary a) => B.Binary (FixResult a) + +-------------------------------------------------------------------------------- +-- | A BareBones Error Type ---------------------------------------------------- +-------------------------------------------------------------------------------- + +newtype Error = Error [Error1] + deriving (Eq, Ord, Show, Typeable, Generic) + +data Error1 = Error1 + { errLoc :: SrcSpan + , errMsg :: Doc + } deriving (Eq, Show, Typeable, Generic) + +instance Ord Error1 where + compare = compare `on` errLoc + +instance PPrint Error1 where + pprintTidy k (Error1 l msg) = (pprintTidy k l <> ": Error") + $+$ nest 2 msg + +instance PPrint Error where + pprintTidy k (Error es) = vcat $ pprintTidy k <$> es + +instance Fixpoint Error1 where + toFix = pprint + +instance Exception Error +instance Exception (FixResult Error) + + +--------------------------------------------------------------------- +catError :: Error -> Error -> Error +--------------------------------------------------------------------- +catError (Error e1) (Error e2) = Error (e1 ++ e2) + +--------------------------------------------------------------------- +catErrors :: ListNE Error -> Error +--------------------------------------------------------------------- +catErrors = foldr1 catError + +--------------------------------------------------------------------- +err :: SrcSpan -> Doc -> Error +--------------------------------------------------------------------- +err sp d = Error [Error1 sp d] + +--------------------------------------------------------------------- +die :: Error -> a +--------------------------------------------------------------------- +die = throw + +--------------------------------------------------------------------- +exit :: a -> IO a -> IO a +--------------------------------------------------------------------- +exit def act = catch act $ \(e :: Error) -> do + putDocLn $ vcat ["Unexpected Errors!", pprint e] + return def + +putDocLn :: Doc -> IO () +putDocLn = putStrLn . render +--------------------------------------------------------------------- +-- | Result --------------------------------------------------------- +--------------------------------------------------------------------- + +data FixResult a = Crash [a] String + | Safe + | Unsafe ![a] + deriving (Data, Typeable, Foldable, Traversable, Show, Generic) + +instance (NFData a) => NFData (FixResult a) + +instance Eq a => Eq (FixResult a) where + Crash xs _ == Crash ys _ = xs == ys + Unsafe xs == Unsafe ys = xs == ys + Safe == Safe = True + _ == _ = False + +instance Monoid (FixResult a) where + mempty = Safe + mappend Safe x = x + mappend x Safe = x + mappend _ c@(Crash _ _) = c + mappend c@(Crash _ _) _ = c + mappend (Unsafe xs) (Unsafe ys) = Unsafe (xs ++ ys) + +instance Functor FixResult where + fmap f (Crash xs msg) = Crash (f <$> xs) msg + fmap f (Unsafe xs) = Unsafe (f <$> xs) + fmap _ Safe = Safe + +resultDoc :: (Fixpoint a) => FixResult a -> Doc +resultDoc Safe = text "Safe" +resultDoc (Crash xs msg) = vcat $ text ("Crash!: " ++ msg) : ((("CRASH:" <+>) . toFix) <$> xs) +resultDoc (Unsafe xs) = vcat $ text "Unsafe:" : ((("WARNING:" <+>) . toFix) <$> xs) + +colorResult :: FixResult a -> Moods +colorResult (Safe) = Happy +colorResult (Unsafe _) = Angry +colorResult (_) = Sad + +--------------------------------------------------------------------- +-- | Catalogue of Errors -------------------------------------------- +--------------------------------------------------------------------- + +errFreeVarInQual :: (PPrint q, Loc q, PPrint x) => q -> x -> Error +errFreeVarInQual q x = err sp $ vcat [ "Qualifier with free vars" + , pprint q + , pprint x ] + where + sp = srcSpan q + +errFreeVarInConstraint :: Integer -> Error +errFreeVarInConstraint i = err dummySpan $ vcat [ "Constraint with free vars" + , pprint i ] diff --git a/src/Language/Fixpoint/Types/Graphs.hs b/src/Language/Fixpoint/Types/Graphs.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fixpoint/Types/Graphs.hs @@ -0,0 +1,70 @@ + +-- | This module contains the types for representing dependency +-- graphs between kvars and constraints. + +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +module Language.Fixpoint.Types.Graphs ( + -- * Graphs + CVertex (..) + , CEdge + , KVGraph + + -- * Components + , Comps + , KVComps + + -- * Printing + , writeGraph + ) + where + +import GHC.Generics (Generic) +import Data.Hashable +import Text.PrettyPrint.HughesPJ + +import Language.Fixpoint.Misc -- hiding (group) +import Language.Fixpoint.Types.PrettyPrint +import Language.Fixpoint.Types.Refinements -- Constraints + +-------------------------------------------------------------------------------- + +data CVertex = KVar KVar -- ^ real kvar vertex + | DKVar KVar -- ^ dummy to ensure each kvar has a successor + | Cstr Integer -- ^ constraint-id which creates a dependency + deriving (Eq, Ord, Show, Generic) + +instance PPrint CVertex where + pprintTidy _ (KVar k) = doubleQuotes $ pprint $ kv k + pprintTidy _ (Cstr i) = text "id_" <> pprint i + pprintTidy _ (DKVar k) = pprint k <> text "*" + + +instance Hashable CVertex + +type CEdge = (CVertex, CVertex) +type KVGraph = [(CVertex, CVertex, [CVertex])] +type Comps a = [[a]] +type KVComps = Comps CVertex + +-------------------------------------------------------------------------------- +writeGraph :: FilePath -> KVGraph -> IO () +-------------------------------------------------------------------------------- +writeGraph f = writeFile f . render . ppGraph + +ppGraph :: KVGraph -> Doc +ppGraph g = ppEdges [ (v, v') | (v,_,vs) <- g, v' <- vs] + +ppEdges :: [CEdge] -> Doc +ppEdges = vcat . wrap ["digraph Deps {"] ["}"] + . map ppE + . filter (not . isJunkEdge) + where + ppE (v, v') = pprint v <+> "->" <+> pprint v' + +isJunkEdge :: CEdge -> Bool +isJunkEdge (DKVar _, _) = True +isJunkEdge (_, DKVar _) = True +isJunkEdge (Cstr _, Cstr _) = True +isJunkEdge _ = False diff --git a/src/Language/Fixpoint/Types/Names.hs b/src/Language/Fixpoint/Types/Names.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fixpoint/Types/Names.hs @@ -0,0 +1,563 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE PatternGuards #-} + + +-- | This module contains Haskell variables representing globally visible names. +-- Rather than have strings floating around the system, all constant names +-- should be defined here, and the (exported) variables should be used and +-- manipulated elsewhere. + +module Language.Fixpoint.Types.Names ( + + -- * Symbols + Symbol + , Symbolic (..) + , LocSymbol + , LocText + + -- * Conversion to/from Text + , symbolSafeText + , symbolSafeString + , symbolText + , symbolString + + -- Predicates + , isPrefixOfSym + , isSuffixOfSym + , isNonSymbol + , isNontrivialVV + , isDummy + + -- * Destructors + , stripPrefix + , consSym + , unconsSym + , dropSym + , headSym + , lengthSym + + -- * Transforms + , nonSymbol + , vvCon + , tidySymbol + + -- * Widely used prefixes + , anfPrefix + , tempPrefix + , vv + , symChars + + -- * Creating Symbols + , dummySymbol + , intSymbol + , tempSymbol + + -- * Wrapping Symbols + , litSymbol + , renameSymbol + , kArgSymbol + , existSymbol + , suffixSymbol + + -- * Unwrapping Symbols + , unLitSymbol + + -- * Hardwired global names + , dummyName + , preludeName + , boolConName + , funConName + , listConName + , listLConName + , tupConName + , propConName + , hpropConName + , strConName + , nilName + , consName + , vvName + , size32Name + , size64Name + , bitVecName + , bvAndName + , bvOrName + , prims + , mulFuncName + , divFuncName + + -- * Casting function names + , setToIntName, bitVecToIntName, mapToIntName, boolToIntName, realToIntName + , setApplyName, bitVecApplyName, mapApplyName, boolApplyName, realApplyName, intApplyName + +) where + +import Control.DeepSeq (NFData (..)) +import Control.Arrow (second) +import Data.Char (ord) +import Data.Maybe (fromMaybe) +import Data.Generics (Data) +import Data.Hashable (Hashable (..)) +import qualified Data.HashSet as S +import Data.Interned +import Data.Interned.Internal.Text +import Data.String (IsString(..)) +import qualified Data.Text as T +import Data.Binary (Binary (..)) +import Data.Typeable (Typeable) +import GHC.Generics (Generic) + +import Text.PrettyPrint.HughesPJ (text) +import Language.Fixpoint.Types.PrettyPrint +import Language.Fixpoint.Types.Spans + +--------------------------------------------------------------- +-- | Symbols -------------------------------------------------- +--------------------------------------------------------------- + +deriving instance Data InternedText +deriving instance Typeable InternedText +deriving instance Generic InternedText + +{- type SafeText = {v: T.Text | IsSafe v} @-} +type SafeText = T.Text + +-- | Invariant: a `SafeText` is made up of: +-- +-- ['0'..'9'] ++ ['a'...'z'] ++ ['A'..'Z'] ++ '$' +-- +-- If the original text has ANY other chars, it is represented as: +-- +-- lq$i +-- +-- where i is a unique integer (for each text) + + + +data Symbol + = S { _symbolId :: !Id + , symbolRaw :: !T.Text + , symbolEncoded :: !T.Text + } deriving (Data, Typeable, Generic) + +instance Eq Symbol where + S i _ _ == S j _ _ = i == j + +instance Ord Symbol where + compare (S i _ _) (S j _ _) = compare i j + +instance Interned Symbol where + type Uninterned Symbol = T.Text + newtype Description Symbol = DT T.Text deriving (Eq) + describe = DT + identify i t = S i t (encode t) + cache = sCache + +instance Uninternable Symbol where + unintern (S _ t _) = t + +instance Hashable (Description Symbol) where + hashWithSalt s (DT t) = hashWithSalt s t + +instance Hashable Symbol where + hashWithSalt _ (S i _ _) = i + +instance NFData Symbol where + rnf (S {}) = () + +instance Binary Symbol where + get = textSymbol <$> get + put = put . symbolText + +sCache :: Cache Symbol +sCache = mkCache +{-# NOINLINE sCache #-} + +instance IsString Symbol where + fromString = textSymbol . T.pack + +instance Show Symbol where + show = show . symbolRaw + +mappendSym :: Symbol -> Symbol -> Symbol +mappendSym s1 s2 = textSymbol $ mappend s1' s2' + where + s1' = symbolText s1 + s2' = symbolText s2 + +instance PPrint Symbol where + pprintTidy _ = text . symbolString + +instance Fixpoint T.Text where + toFix = text . T.unpack + +-- RJ: Use `symbolSafeText` if you want it to machine-readable, +-- but `symbolText` if you want it to be human-readable. + +instance Fixpoint Symbol where + toFix = toFix . checkedText -- symbolSafeText + +checkedText :: Symbol -> T.Text +checkedText x + | Just (c, t') <- T.uncons t + , okHd c && T.all okChr t' = t + | otherwise = symbolSafeText x + where + t = symbolText x + okHd = (`S.member` alphaChars) + okChr = (`S.member` symChars) + +--------------------------------------------------------------------------- +-- | Located Symbols ----------------------------------------------------- +--------------------------------------------------------------------------- + +type LocSymbol = Located Symbol +type LocText = Located T.Text + +isDummy :: (Symbolic a) => a -> Bool +isDummy a = symbol a == symbol dummyName + +instance Symbolic a => Symbolic (Located a) where + symbol = symbol . val + +--------------------------------------------------------------------------- +-- | Decoding Symbols ----------------------------------------------------- +--------------------------------------------------------------------------- + +symbolText :: Symbol -> T.Text +symbolText = symbolRaw + +symbolString :: Symbol -> String +symbolString = T.unpack . symbolText + +symbolSafeText :: Symbol -> SafeText +symbolSafeText = symbolEncoded + +symbolSafeString :: Symbol -> String +symbolSafeString = T.unpack . symbolSafeText + +--------------------------------------------------------------------------- +-- | Encoding Symbols ----------------------------------------------------- +--------------------------------------------------------------------------- + +-- INVARIANT: All strings *must* be built from here + +textSymbol :: T.Text -> Symbol +textSymbol = intern + +encode :: T.Text -> SafeText +encode t + | isFixKey t = T.append "key$" t + | otherwise = encodeUnsafe t + +isFixKey :: T.Text -> Bool +isFixKey x = S.member x keywords + +encodeUnsafe :: T.Text -> T.Text +encodeUnsafe = joinChunks . splitChunks . prefixAlpha + +prefixAlpha :: T.Text -> T.Text +prefixAlpha t + | isAlpha0 t = t + | otherwise = T.append "fix$" t + +isAlpha0 :: T.Text -> Bool +isAlpha0 t = case T.uncons t of + Just (c, _) -> S.member c alphaChars + Nothing -> False + +joinChunks :: (T.Text, [(Char, SafeText)]) -> SafeText +joinChunks (t, [] ) = t +joinChunks (t, cts) = T.concat $ padNull t : (tx <$> cts) + where + tx (c, ct) = mconcat ["$", c2t c, "$", ct] + c2t = T.pack . show . ord + +padNull :: T.Text -> T.Text +padNull t + | T.null t = "z$" + | otherwise = t + +splitChunks :: T.Text -> (T.Text, [(Char, SafeText)]) +splitChunks t = (h, go tl) + where + (h, tl) = T.break isUnsafeChar t + go !ut = case T.uncons ut of + Nothing -> [] + Just (c, ut') -> let (ct, utl) = T.break isUnsafeChar ut' + in (c, ct) : go utl + +isUnsafeChar :: Char -> Bool +isUnsafeChar = not . (`S.member` okSymChars) + + +keywords :: S.HashSet T.Text +keywords = S.fromList [ "env" + , "id" + , "tag" + , "qualif" + , "constant" + , "cut" + , "bind" + , "constraint" + , "lhs" + , "rhs" + , "NaN" + , "min" + , "map" + ] + +-- | RJ: We allow the extra 'unsafeChars' to allow parsing encoded symbols. +-- e.g. the raw string "This#is%$inval!d" may get encoded as "enc%12" +-- and serialized as such in the fq/bfq file. We want to allow the parser +-- to then be able to read the above back in. + +alphaChars :: S.HashSet Char +alphaChars = S.fromList $ ['a' .. 'z'] ++ ['A' .. 'Z'] + +numChars :: S.HashSet Char +numChars = S.fromList ['0' .. '9'] + +safeChars :: S.HashSet Char +safeChars = alphaChars `mappend` + numChars `mappend` + S.fromList ['_', '.' ] + +symChars :: S.HashSet Char +symChars = safeChars `mappend` + S.fromList ['%', '#', '$'] + +okSymChars :: S.HashSet Char +okSymChars = safeChars + +isPrefixOfSym :: Symbol -> Symbol -> Bool +isPrefixOfSym (symbolText -> p) (symbolText -> x) = p `T.isPrefixOf` x + +isSuffixOfSym :: Symbol -> Symbol -> Bool +isSuffixOfSym (symbolText -> p) (symbolText -> x) = p `T.isSuffixOf` x + + +headSym :: Symbol -> Char +headSym (symbolText -> t) = T.head t + +consSym :: Char -> Symbol -> Symbol +consSym c (symbolText -> s) = symbol $ T.cons c s + +unconsSym :: Symbol -> Maybe (Char, Symbol) +unconsSym (symbolText -> s) = second symbol <$> T.uncons s + +-- singletonSym :: Char -> Symbol -- Yuck +-- singletonSym = (`consSym` "") + +lengthSym :: Symbol -> Int +lengthSym (symbolText -> t) = T.length t + +dropSym :: Int -> Symbol -> Symbol +dropSym n (symbolText -> t) = symbol $ T.drop n t + +stripPrefix :: Symbol -> Symbol -> Maybe Symbol +stripPrefix p x = symbol <$> T.stripPrefix (symbolText p) (symbolText x) + + +-------------------------------------------------------------------------------- +-- | Use this **EXCLUSIVELY** when you want to add stuff in front of a Symbol +-------------------------------------------------------------------------------- +suffixSymbol :: Symbol -> Symbol -> Symbol +suffixSymbol x y = x `mappendSym` symSepName `mappendSym` y + +vv :: Maybe Integer -> Symbol +-- vv (Just i) = symbol $ symbolSafeText vvName `T.snoc` symSepName `mappend` T.pack (show i) +vv (Just i) = intSymbol vvName i +vv Nothing = vvName + +isNontrivialVV :: Symbol -> Bool +isNontrivialVV = not . (vv Nothing ==) + +vvCon, dummySymbol :: Symbol +vvCon = vvName `suffixSymbol` "F" +dummySymbol = dummyName + +litSymbol :: Symbol -> Symbol +litSymbol s = litPrefix `mappendSym` s + +unLitSymbol :: Symbol -> Maybe Symbol +unLitSymbol = stripPrefix litPrefix + +intSymbol :: (Show a) => Symbol -> a -> Symbol +intSymbol x i = x `suffixSymbol` (symbol $ show i) + +tempSymbol :: Symbol -> Integer -> Symbol +tempSymbol prefix = intSymbol (tempPrefix `mappendSym` prefix) + +renameSymbol :: Symbol -> Int -> Symbol +renameSymbol prefix = intSymbol (renamePrefix `mappendSym` prefix) + +kArgSymbol :: Symbol -> Symbol -> Symbol +kArgSymbol x k = (kArgPrefix `mappendSym` x) `suffixSymbol` k + +existSymbol :: Symbol -> Integer -> Symbol +existSymbol prefix = intSymbol (existPrefix `mappendSym` prefix) + +tempPrefix, anfPrefix, renamePrefix, litPrefix, kArgPrefix, existPrefix :: Symbol +tempPrefix = "lq_tmp$" +anfPrefix = "lq_anf$" +renamePrefix = "lq_rnm$" +litPrefix = "lit$" +kArgPrefix = "lq_karg$" +existPrefix = "lq_ext$" + +------------------------------------------------------------------------- +tidySymbol :: Symbol -> Symbol +------------------------------------------------------------------------- +tidySymbol = unSuffixSymbol . unSuffixSymbol . unPrefixSymbol kArgPrefix + +unPrefixSymbol :: Symbol -> Symbol -> Symbol +unPrefixSymbol p s = fromMaybe s (stripPrefix p s) + +unSuffixSymbol :: Symbol -> Symbol +unSuffixSymbol s@(symbolText -> t) + = maybe s symbol $ T.stripSuffix symSepName $ fst $ T.breakOnEnd symSepName t + +-- takeWhileSym :: (Char -> Bool) -> Symbol -> Symbol +-- takeWhileSym p (symbolText -> t) = symbol $ T.takeWhile p t + + +nonSymbol :: Symbol +nonSymbol = "" + +isNonSymbol :: Symbol -> Bool +isNonSymbol = (== nonSymbol) + +------------------------------------------------------------------------------ +-- | Values that can be viewed as Symbols +------------------------------------------------------------------------------ + +class Symbolic a where + symbol :: a -> Symbol + +instance Symbolic T.Text where + symbol = textSymbol + +instance Symbolic String where + symbol = symbol . T.pack + +instance Symbolic Symbol where + symbol = id + +---------------------------------------------------------------------------- +--------------- Global Name Definitions ------------------------------------ +---------------------------------------------------------------------------- + +setToIntName, bitVecToIntName, mapToIntName, boolToIntName , realToIntName:: Symbol +setToIntName = "set_to_int" +bitVecToIntName = "bitvec_to_int" +mapToIntName = "map_to_int" +boolToIntName = "bool_to_int" +realToIntName = "real_to_int" + + +setApplyName, bitVecApplyName, mapApplyName, boolApplyName, realApplyName, intApplyName :: Int -> Symbol +setApplyName = intSymbol "set_apply_" +bitVecApplyName = intSymbol "bitvec_apply" +mapApplyName = intSymbol "map_apply_" +boolApplyName = intSymbol "bool_apply_" +realApplyName = intSymbol "real_apply_" +intApplyName = intSymbol "int_apply_" + + +preludeName, dummyName, boolConName, funConName :: Symbol +preludeName = "Prelude" +dummyName = "LIQUID$dummy" +boolConName = "Bool" +funConName = "->" + +listConName, listLConName, tupConName, propConName, hpropConName, strConName, vvName :: Symbol +listConName = "[]" +listLConName = "List" +tupConName = "Tuple" +propConName = "Prop" +hpropConName = "HProp" +strConName = "Str" +vvName = "VV" + +-- symSepName :: Char +-- symSepName = '#' -- DO NOT EVER CHANGE THIS + +symSepName :: (IsString a) => a -- Symbol +symSepName = "##" + +nilName, consName, size32Name, size64Name, bitVecName, bvOrName, bvAndName :: Symbol +nilName = "nil" +consName = "cons" +size32Name = "Size32" +size64Name = "Size64" +bitVecName = "BitVec" +bvOrName = "bvor" +bvAndName = "bvand" + +mulFuncName, divFuncName :: Symbol +mulFuncName = "Z3_OP_MUL" +divFuncName = "Z3_OP_DIV" + +prims :: [Symbol] +prims = [ propConName + , hpropConName + , vvName + , "Pred" + , "List" + , "[]" + , "Set_Set" + , "Set_sng" + , "Set_cup" + , "Set_cap" + , "Set_dif" + , "Set_emp" + , "Set_empty" + , "Set_mem" + , "Set_sub" + , "Map_t" + , "Map_select" + , "Map_store" + , size32Name + , size64Name + , bitVecName + , bvOrName + , bvAndName + , "FAppTy" + , nilName + , consName + ] + +{- +------------------------------------------------------------------------------- +-- | Memoized Decoding +------------------------------------------------------------------------------- + +{-# NOINLINE symbolMemo #-} +symbolMemo :: IORef (M.HashMap Int T.Text) +symbolMemo = unsafePerformIO (newIORef M.empty) + +{-# NOINLINE memoEncode #-} +memoEncode :: T.Text -> Int +memoEncode t = unsafePerformIO $ + atomicModifyIORef symbolMemo $ \m -> + (M.insert i t m, i) + where + i = internedTextId $ intern t + +{-# NOINLINE memoDecode #-} +memoDecode :: Int -> T.Text +memoDecode i = unsafePerformIO $ + safeLookup msg i <$> readIORef symbolMemo + where + msg = "Symbol Decode Error: " ++ show i + +-} diff --git a/src/Language/Fixpoint/Types/PrettyPrint.hs b/src/Language/Fixpoint/Types/PrettyPrint.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fixpoint/Types/PrettyPrint.hs @@ -0,0 +1,176 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} + +module Language.Fixpoint.Types.PrettyPrint where + +import Debug.Trace (trace) +import Text.PrettyPrint.HughesPJ +import qualified Text.PrettyPrint.Boxes as B +import qualified Data.HashMap.Strict as M +import qualified Data.HashSet as S +import qualified Data.List as L +import Language.Fixpoint.Misc +import Data.Hashable +import qualified Data.Text as T + + +traceFix :: (Fixpoint a) => String -> a -> a +traceFix s x = trace ("\nTrace: [" ++ s ++ "] : " ++ showFix x) x + +------------------------------------------------------------------ +class Fixpoint a where + toFix :: a -> Doc + simplify :: a -> a + simplify = id + +showFix :: (Fixpoint a) => a -> String +showFix = render . toFix + +instance (Ord a, Hashable a, Fixpoint a) => Fixpoint (S.HashSet a) where + toFix xs = brackets $ sep $ punctuate (text ";") (toFix <$> L.sort (S.toList xs)) + simplify = S.fromList . map simplify . S.toList + +instance Fixpoint () where + toFix _ = text "()" + +instance Fixpoint a => Fixpoint (Maybe a) where + toFix = maybe (text "Nothing") ((text "Just" <+>) . toFix) + simplify = fmap simplify + +instance Fixpoint a => Fixpoint [a] where + toFix xs = brackets $ sep $ punctuate (text ";") (fmap toFix xs) + simplify = map simplify + +instance (Fixpoint a, Fixpoint b) => Fixpoint (a,b) where + toFix (x,y) = toFix x <+> text ":" <+> toFix y + simplify (x,y) = (simplify x, simplify y) + +instance (Fixpoint a, Fixpoint b, Fixpoint c) => Fixpoint (a,b,c) where + toFix (x,y,z) = toFix x <+> text ":" <+> toFix y <+> text ":" <+> toFix z + simplify (x,y,z) = (simplify x, simplify y,simplify z) + +instance Fixpoint Bool where + toFix True = text "True" + toFix False = text "False" + simplify z = z + +instance Fixpoint Int where + toFix = tshow + +instance Fixpoint Integer where + toFix = integer + +instance Fixpoint Double where + toFix = double + +------------------------------------------------------------------ + +data Tidy = Lossy | Full deriving (Eq, Ord) + +-- | Implement either `pprintTidy` or `pprintPrec` +class PPrint a where + + pprintTidy :: Tidy -> a -> Doc + pprintTidy = pprintPrec 0 + + pprintPrec :: Int -> Tidy -> a -> Doc + pprintPrec _ = pprintTidy + +-- | Top-level pretty printer +pprint :: (PPrint a) => a -> Doc +pprint = pprintPrec 0 Full + +showpp :: (PPrint a) => a -> String +showpp = render . pprint + +tracepp :: (PPrint a) => String -> a -> a +tracepp s x = trace ("\nTrace: [" ++ s ++ "] : " ++ showpp x) x + +instance PPrint Doc where + pprintTidy _ = id + +instance PPrint a => PPrint (Maybe a) where + pprintTidy k = maybe (text "Nothing") ((text "Just" <+>) . pprintTidy k) + +instance PPrint a => PPrint [a] where + pprintTidy k = brackets . intersperse comma . map (pprintTidy k) + +instance PPrint a => PPrint (S.HashSet a) where + pprintTidy k = pprintTidy k . S.toList + +instance (PPrint a, PPrint b) => PPrint (M.HashMap a b) where + pprintTidy k = pprintKVs k . M.toList + +-- pprintKVs :: (PPrint k, PPrint v) => [(k, v)] -> Doc +-- pprintKVs = pprintKVsTidy Full + +-- vcat . punctuate (text "\n") . map pp1 +-- where +-- pp1 (x,y) = pprint x <+> text ":=" <+> pprint y + +pprintKVs :: (PPrint k, PPrint v) => Tidy -> [(k, v)] -> Doc +pprintKVs t = vcat . punctuate (text "\n") . map pp1 + where + pp1 (x,y) = pprintTidy t x <+> text ":=" <+> pprintTidy t y + + + + + +instance (PPrint a, PPrint b, PPrint c) => PPrint (a, b, c) where + pprintTidy k (x, y, z) = parens $ pprintTidy k x <> "," <+> + pprintTidy k y <> "," <+> + pprintTidy k z + + +instance (PPrint a, PPrint b) => PPrint (a,b) where + pprintTidy k (x, y) = pprintTidy k x <+> ":" <+> pprintTidy k y + +instance PPrint Bool where + pprintTidy _ = text . show + +instance PPrint Float where + pprintTidy _ = text . show + +instance PPrint () where + pprintTidy _ = text . show + +instance PPrint String where + pprintTidy _ = text + +instance PPrint Int where + pprintTidy _ = tshow + +instance PPrint Integer where + pprintTidy _ = integer + +instance PPrint T.Text where + pprintTidy _ = text . T.unpack + +newtype DocTable = DocTable [(Doc, Doc)] + +instance Monoid DocTable where + mempty = DocTable [] + mappend (DocTable t1) (DocTable t2) = DocTable (t1 ++ t2) + +class PTable a where + ptable :: a -> DocTable + +instance PPrint DocTable where + pprintTidy _ (DocTable kvs) = boxDoc $ B.hsep 1 B.left [ks', cs', vs'] + where + (ks, vs) = unzip kvs + n = length kvs + ks' = B.vcat B.left $ docBox <$> ks + vs' = B.vcat B.right $ docBox <$> vs + cs' = B.vcat B.left $ replicate n $ B.text ":" + +boxHSep :: Doc -> Doc -> Doc +boxHSep d1 d2 = boxDoc $ B.hcat B.top [docBox d1, docBox d2] + +boxDoc :: B.Box -> Doc +boxDoc = text . B.render + +docBox :: Doc -> B.Box +docBox = B.text . render diff --git a/src/Language/Fixpoint/Types/Refinements.hs b/src/Language/Fixpoint/Types/Refinements.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fixpoint/Types/Refinements.hs @@ -0,0 +1,712 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE PatternSynonyms #-} + +-- | This module contains the data types for representing terms in the +-- refinement logic; currently split into @Expr@ and @Pred@ but which +-- will be unified. + +module Language.Fixpoint.Types.Refinements ( + + -- * Representing Terms + SymConst (..) + , Constant (..) + , Bop (..) + , Brel (..) + , Expr (..), Pred + , pattern PTrue, pattern PTop, pattern PFalse, pattern EBot + , KVar (..) + , Subst (..) + , Reft (..) + , SortedReft (..) + + -- * Constructing Terms + , eVar, elit + , eProp + , pAnd, pOr, pIte + , mkEApp + , intKvar + , vv_ + + -- * Generalizing Embedding with Typeclasses + , Expression (..) + , Predicate (..) + , Subable (..) + , Reftable (..) + + -- * Constructors + , reft -- "smart + , trueSortedReft -- trivial reft + , trueReft, falseReft -- trivial reft + , exprReft -- singleton: v == e + , notExprReft -- singleton: v /= e + , uexprReft -- singleton: v ~~ e + , symbolReft -- singleton: v == x + , usymbolReft -- singleton: v ~~ x + , propReft -- singleton: Prop(v) <=> p + , predReft -- any pred : p + , reftPred + , reftBind + + -- * Predicates + , isFunctionSortedReft, functionSort + , isNonTrivial + , isTautoPred + , isSingletonReft + , isEVar + , isFalse + + -- * Destructing + , flattenRefas + , conjuncts + , eApps + , splitEApp + , reftConjuncts + + -- * Transforming + , mapPredReft + , pprintReft + ) where + +import qualified Data.Binary as B +import Data.Generics (Data) +import Data.Typeable (Typeable) +import Data.Hashable +import GHC.Generics (Generic) +import Data.List (partition) -- , foldl', sort, sortBy) +import Data.String +import Data.Text (Text) +import qualified Data.Text as T +import Control.DeepSeq +import Data.Maybe (isJust) +-- import Text.Printf (printf) +-- import Language.Fixpoint.Types.Config +import Language.Fixpoint.Types.Names +import Language.Fixpoint.Types.PrettyPrint +-- import Language.Fixpoint.Types.Errors +import Language.Fixpoint.Types.Spans +import Language.Fixpoint.Types.Sorts +import Language.Fixpoint.Misc +-- import Text.Parsec.Pos +import Text.PrettyPrint.HughesPJ +-- import Data.Array hiding (indices) +import qualified Data.HashMap.Strict as M +-- import qualified Data.HashSet as S + +instance NFData KVar +instance NFData Subst +instance NFData Constant +instance NFData SymConst +instance NFData Brel +instance NFData Bop +instance NFData Expr +instance NFData Reft +instance NFData SortedReft + +instance (Hashable k, Eq k, B.Binary k, B.Binary v) => B.Binary (M.HashMap k v) where + put = B.put . M.toList + get = M.fromList <$> B.get + +instance B.Binary KVar +instance B.Binary Subst +instance B.Binary Constant +instance B.Binary SymConst +instance B.Binary Brel +instance B.Binary Bop +instance B.Binary Expr +instance B.Binary Reft +instance B.Binary SortedReft + + +reftConjuncts :: Reft -> [Reft] +reftConjuncts (Reft (v, ra)) = [Reft (v, ra') | ra' <- ras'] + where + ras' = if null ps then ks else ((pAnd ps) : ks) + (ks, ps) = partition isKvar $ refaConjuncts ra + +isKvar :: Expr -> Bool +isKvar (PKVar _ _) = True +isKvar _ = False + +refaConjuncts :: Expr -> [Expr] +refaConjuncts p = [p' | p' <- conjuncts p, not $ isTautoPred p'] + + +-------------------------------------------------------------------------------- +-- | Kvars --------------------------------------------------------------------- +-------------------------------------------------------------------------------- + +newtype KVar = KV { kv :: Symbol } + deriving (Eq, Ord, Data, Typeable, Generic, IsString) + + +intKvar :: Integer -> KVar +intKvar = KV . intSymbol "k_" + +instance Show KVar where + show (KV x) = "$" ++ show x + +instance Hashable KVar +instance Hashable Brel +instance Hashable Bop +instance Hashable SymConst +instance Hashable Constant + +-------------------------------------------------------------------------------- +-- | Substitutions ------------------------------------------------------------- +-------------------------------------------------------------------------------- + +newtype Subst = Su (M.HashMap Symbol Expr) + deriving (Eq, Data, Typeable, Generic) + +instance Show Subst where + show = showFix + +instance Fixpoint Subst where + toFix (Su m) = case hashMapToAscList m of + [] -> empty + xys -> hcat $ map (\(x,y) -> brackets $ toFix x <> text ":=" <> toFix y) xys + +-------------------------------------------------------------------------------- +-- | Expressions --------------------------------------------------------------- +-------------------------------------------------------------------------------- + +-- | Uninterpreted constants that are embedded as "constant symbol : Str" + +data SymConst = SL !Text + deriving (Eq, Ord, Show, Data, Typeable, Generic) + +data Constant = I !Integer + | R !Double + | L !Text !Sort + deriving (Eq, Ord, Show, Data, Typeable, Generic) + +data Brel = Eq | Ne | Gt | Ge | Lt | Le | Ueq | Une + deriving (Eq, Ord, Show, Data, Typeable, Generic) + +data Bop = Plus | Minus | Times | Div | Mod | RTimes | RDiv + deriving (Eq, Ord, Show, Data, Typeable, Generic) + -- NOTE: For "Mod" 2nd expr should be a constant or a var *) + +data Expr = ESym !SymConst + | ECon !Constant + | EVar !Symbol + -- NV TODO: change this to `EApp !Expr !Expr` + | EApp !Expr !Expr + | ENeg !Expr + | EBin !Bop !Expr !Expr + | EIte !Expr !Expr !Expr + | ECst !Expr !Sort + | ELam !(Symbol, Sort) !Expr + | ETApp !Expr !Sort + | ETAbs !Expr !Symbol + +--- Used to be predicates + | PAnd ![Expr] + | POr ![Expr] + | PNot !Expr + | PImp !Expr !Expr + | PIff !Expr !Expr + | PAtom !Brel !Expr !Expr + | PKVar !KVar !Subst + | PAll ![(Symbol, Sort)] !Expr + | PExist ![(Symbol, Sort)] !Expr + | PGrad + deriving (Eq, Show, Data, Typeable, Generic) + +type Pred = Expr + +pattern PTrue = PAnd [] +pattern PTop = PAnd [] +pattern PFalse = POr [] +pattern EBot = POr [] + +mkEApp :: LocSymbol -> [Expr] -> Expr +mkEApp f = eApps (EVar $ val f) + +eApps :: Expr -> [Expr] -> Expr +eApps f es = foldl EApp f es + +splitEApp :: Expr -> (Expr, [Expr]) +splitEApp = go [] + where + go acc (EApp f e) = go (e:acc) f + go acc e = (e, acc) + + +newtype Reft = Reft (Symbol, Expr) + deriving (Eq, Data, Typeable, Generic) + +data SortedReft = RR { sr_sort :: !Sort, sr_reft :: !Reft } + deriving (Eq, Data, Typeable, Generic) + +elit :: Located Symbol -> Sort -> Expr +elit l s = ECon $ L (symbolText $ val l) s + +instance Fixpoint Constant where + toFix (I i) = toFix i + toFix (R i) = toFix i + toFix (L s t) = parens $ text "lit" <+> text "\"" <> toFix s <> text "\"" <+> toFix t + +--------------------------------------------------------------- +-- | String Constants ----------------------------------------- +--------------------------------------------------------------- + +-- | Replace all symbol-representations-of-string-literals with string-literal +-- Used to transform parsed output from fixpoint back into fq. + +instance Symbolic SymConst where + symbol = encodeSymConst + +encodeSymConst :: SymConst -> Symbol +encodeSymConst (SL s) = litSymbol $ symbol s + +decodeSymConst :: Symbol -> Maybe SymConst +decodeSymConst = fmap (SL . symbolText) . unLitSymbol + +instance Fixpoint SymConst where + toFix = toFix . encodeSymConst + +instance Fixpoint KVar where + toFix (KV k) = text "$" <> toFix k + +instance Fixpoint Brel where + toFix Eq = text "=" + toFix Ne = text "!=" + toFix Ueq = text "~~" + toFix Une = text "!~" + toFix Gt = text ">" + toFix Ge = text ">=" + toFix Lt = text "<" + toFix Le = text "<=" + +instance Fixpoint Bop where + toFix Plus = text "+" + toFix Minus = text "-" + toFix RTimes = text "*." + toFix Times = text "*" + toFix Div = text "/" + toFix RDiv = text "/." + toFix Mod = text "mod" + +instance Fixpoint Expr where + toFix (ESym c) = toFix $ encodeSymConst c + toFix (ECon c) = toFix c + toFix (EVar s) = toFix s + toFix e@(EApp _ _) = parens $ hcat $ punctuate " " $ toFix <$> (f:es) where (f, es) = splitEApp e + toFix (ENeg e) = parens $ text "-" <+> parens (toFix e) + toFix (EBin o e1 e2) = parens $ toFix e1 <+> toFix o <+> toFix e2 + toFix (EIte p e1 e2) = parens $ text "if" <+> toFix p <+> text "then" <+> toFix e1 <+> text "else" <+> toFix e2 + toFix (ECst e so) = parens $ toFix e <+> text " : " <+> toFix so + -- toFix (EBot) = text "_|_" + -- toFix PTop = text "???" + toFix PTrue = text "true" + toFix PFalse = text "false" + toFix (PNot p) = parens $ text "~" <+> parens (toFix p) + toFix (PImp p1 p2) = parens $ toFix p1 <+> text "=>" <+> toFix p2 + toFix (PIff p1 p2) = parens $ toFix p1 <+> text "<=>" <+> toFix p2 + toFix (PAnd ps) = text "&&" <+> toFix ps + toFix (POr ps) = text "||" <+> toFix ps + toFix (PAtom r e1 e2) = parens $ toFix e1 <+> toFix r <+> toFix e2 + toFix (PKVar k su) = toFix k <> toFix su + toFix (PAll xts p) = "forall" <+> (toFix xts + $+$ ("." <+> toFix p)) + toFix (PExist xts p) = "exists" <+> (toFix xts + $+$ ("." <+> toFix p)) + toFix (ETApp e s) = text "tapp" <+> toFix e <+> toFix s + toFix (ETAbs e s) = text "tabs" <+> toFix e <+> toFix s + toFix PGrad = text "??" + toFix (ELam (x,s) e) = text "lam" <+> toFix x <+> ":" <+> toFix s <+> "." <+> toFix e + + simplify (PAnd []) = PTrue + simplify (POr []) = PFalse + simplify (PAnd [p]) = simplify p + simplify (POr [p]) = simplify p + + simplify (PAnd ps) + | any isContraPred ps = PFalse + | otherwise = PAnd $ filter (not . isTautoPred) $ map simplify ps + + simplify (POr ps) + | any isTautoPred ps = PTrue + | otherwise = POr $ filter (not . isContraPred) $ map simplify ps + + simplify p + | isContraPred p = PFalse + | isTautoPred p = PTrue + | otherwise = p + +isContraPred :: Expr -> Bool +isContraPred z = eqC z || (z `elem` contras) + where + contras = [PFalse] + + eqC (PAtom Eq (ECon x) (ECon y)) + = x /= y + eqC (PAtom Ueq (ECon x) (ECon y)) + = x /= y + eqC (PAtom Ne x y) + = x == y + eqC (PAtom Une x y) + = x == y + eqC _ = False + +isTautoPred :: Expr -> Bool +isTautoPred z = z == PTop || z == PTrue || eqT z + where + eqT (PAnd []) + = True + eqT (PAtom Le x y) + = x == y + eqT (PAtom Ge x y) + = x == y + eqT (PAtom Eq x y) + = x == y + eqT (PAtom Ueq x y) + = x == y + eqT (PAtom Ne (ECon x) (ECon y)) + = x /= y + eqT (PAtom Une (ECon x) (ECon y)) + = x /= y + eqT _ = False + +isEVar :: Expr -> Bool +isEVar (EVar _) = True +isEVar _ = False + +isEq :: Brel -> Bool +isEq r = r == Eq || r == Ueq + +instance PPrint Constant where + pprintTidy _ = toFix + +instance PPrint Brel where + pprintTidy _ Eq = "==" + pprintTidy _ Ne = "/=" + pprintTidy _ r = toFix r + +instance PPrint Bop where + pprintTidy _ = toFix + +instance PPrint Sort where + pprintTidy _ = toFix + +instance PPrint KVar where + pprintTidy _ (KV x) = text "$" <> pprint x + +instance PPrint SymConst where + pprintTidy _ (SL x) = doubleQuotes $ text $ T.unpack x + +-- | Wrap the enclosed 'Doc' in parentheses only if the condition holds. +parensIf True = parens +parensIf False = id + +-- NOTE: The following Expr and Pred printers use pprintPrec to print +-- expressions with minimal parenthesization. The precedence rules are somewhat +-- fragile, and it would be nice to have them directly tied to the parser, but +-- the general idea is (from lowest to highest precedence): +-- +-- 1 - if-then-else +-- 2 - => and <=> +-- 3 - && and || +-- 4 - ==, !=, <, <=, >, >= +-- 5 - mod +-- 6 - + and - +-- 7 - * and / +-- 8 - function application +-- +-- Each printer `p` checks whether the precedence of the context is greater than +-- its own precedence. If so, the printer wraps itself in parentheses. Then it +-- sets the contextual precedence for recursive printer invocations to +-- (prec p + 1). + +opPrec Mod = 5 +opPrec Plus = 6 +opPrec Minus = 6 +opPrec Times = 7 +opPrec RTimes = 7 +opPrec Div = 7 +opPrec RDiv = 7 + +instance PPrint Expr where + pprintPrec _ k (ESym c) = pprintTidy k c + pprintPrec _ k (ECon c) = pprintTidy k c + pprintPrec _ k (EVar s) = pprintTidy k s + -- pprintPrec _ (EBot) = text "_|_" + pprintPrec z k (ENeg e) = parensIf (z > zn) $ + "-" <> pprintPrec (zn + 1) k e + where zn = 2 + pprintPrec z k (EApp f es) = parensIf (z > za) $ + pprintPrec za k f <+> pprintPrec (za+1) k es + where za = 8 + pprintPrec z k (EBin o e1 e2) = parensIf (z > zo) $ + pprintPrec (zo+1) k e1 <+> + pprintTidy k o <+> + pprintPrec (zo+1) k e2 + where zo = opPrec o + pprintPrec z k (EIte p e1 e2) = parensIf (z > zi) $ + "if" <+> pprintPrec (zi+1) k p <+> + "then" <+> pprintPrec (zi+1) k e1 <+> + "else" <+> pprintPrec (zi+1) k e2 + where zi = 1 + pprintPrec _ k (ECst e so) = parens $ pprint e <+> ":" <+> pprintTidy k so + + pprintPrec _ _ PTrue = trueD + pprintPrec _ _ PFalse = falseD + pprintPrec z k (PNot p) = parensIf (z > zn) $ + "not" <+> pprintPrec (zn+1) k p + where zn = 8 + pprintPrec z k (PImp p1 p2) = parensIf (z > zi) $ + (pprintPrec (zi+1) k p1) <+> + "=>" <+> + (pprintPrec (zi+1) k p2) + where zi = 2 + pprintPrec z k (PIff p1 p2) = parensIf (z > zi) $ + (pprintPrec (zi+1) k p1) <+> + "<=>" <+> + (pprintPrec (zi+1) k p2) + where zi = 2 + pprintPrec z k (PAnd ps) = parensIf (z > za) $ + pprintBin (za + 1) k trueD andD ps + where za = 3 + pprintPrec z k (POr ps) = parensIf (z > zo) $ + pprintBin (zo + 1) k falseD orD ps + where zo = 3 + pprintPrec z k (PAtom r e1 e2) = parensIf (z > za) $ + pprintPrec (za+1) k e1 <+> + pprintTidy k r <+> + pprintPrec (za+1) k e2 + where za = 4 + pprintPrec _ k (PAll xts p) = pprintQuant k "forall" xts p + pprintPrec _ k (PExist xts p) = pprintQuant k "exists" xts p + pprintPrec _ k (ELam (x,t) e) = "lam" <+> toFix x <+> ":" <+> toFix t <+> text "." <+> pprintTidy k e + pprintPrec _ _ p@(PKVar {}) = toFix p + pprintPrec _ _ (ETApp e s) = "ETApp" <+> toFix e <+> toFix s + pprintPrec _ _ (ETAbs e s) = "ETAbs" <+> toFix e <+> toFix s + pprintPrec _ _ PGrad = "?" + +pprintQuant k d xts p = (d <+> toFix xts) + $+$ + (" ." <+> pprintTidy k p) + +trueD = "true" +falseD = "false" +andD = "&&" +orD = "||" + +pprintBin _ _ b _ [] = b +pprintBin z k _ o xs = vIntersperse o $ pprintPrec z k <$> xs + +vIntersperse _ [] = empty +vIntersperse _ [d] = d +vIntersperse s (d:ds) = vcat (d : ((s <+>) <$> ds)) + +pprintReft :: Tidy -> Reft -> Doc +pprintReft k (Reft (_,ra)) = pprintBin z k trueD andD flat + where + flat = flattenRefas [ra] + z = if length flat > 1 then 3 else 0 + +------------------------------------------------------------------------ +-- | Generalizing Symbol, Expression, Predicate into Classes ----------- +------------------------------------------------------------------------ + +-- | Values that can be viewed as Constants + +-- | Values that can be viewed as Expressions + +class Expression a where + expr :: a -> Expr + +-- | Values that can be viewed as Predicates + +class Predicate a where + prop :: a -> Expr + +instance Expression Expr where + expr = id + +-- | The symbol may be an encoding of a SymConst. + +instance Expression Symbol where + expr s = maybe (eVar s) ESym (decodeSymConst s) + -- expr = eVar + +instance Expression Text where + expr = ESym . SL + +instance Expression Integer where + expr = ECon . I + +instance Expression Int where + expr = expr . toInteger + +instance Predicate Symbol where + prop = eProp + +instance Predicate Expr where + prop = id + +instance Predicate Bool where + prop True = PTrue + prop False = PFalse + +instance Expression a => Expression (Located a) where + expr = expr . val + +eVar :: Symbolic a => a -> Expr +eVar = EVar . symbol + +eProp :: Symbolic a => a -> Expr +eProp = mkProp . eVar + +isSingletonExpr :: Symbol -> Expr -> Maybe Expr +isSingletonExpr v (PAtom r e1 e2) + | e1 == EVar v && isEq r = Just e2 + | e2 == EVar v && isEq r = Just e1 +isSingletonExpr _ _ = Nothing + +pAnd, pOr :: ListNE Expr -> Expr +pAnd = simplify . PAnd +pOr = simplify . POr +pIte p1 p2 p3 = pAnd [p1 `PImp` p2, (PNot p1) `PImp` p3] +mkProp = EApp (EVar propConName) + + +-------------------------------------------------------------------------------- +-- | Predicates ---------------------------------------------------------------- +-------------------------------------------------------------------------------- + +isSingletonReft :: Reft -> Maybe Expr +isSingletonReft (Reft (v, ra)) = firstMaybe (isSingletonExpr v) $ conjuncts ra + +relReft :: (Expression a) => Brel -> a -> Reft +relReft r e = Reft (vv_, PAtom r (eVar vv_) (expr e)) + +exprReft, notExprReft, uexprReft :: (Expression a) => a -> Reft +exprReft = relReft Eq +notExprReft = relReft Ne +uexprReft = relReft Ueq + +propReft :: (Predicate a) => a -> Reft +propReft p = Reft (vv_, PIff (eProp vv_) (prop p)) + +predReft :: (Predicate a) => a -> Reft +predReft p = Reft (vv_, prop p) + +reft :: Symbol -> Expr -> Reft +reft v p = Reft (v, p) + +mapPredReft :: (Expr -> Expr) -> Reft -> Reft +mapPredReft f (Reft (v, p)) = Reft (v, f p) + +--------------------------------------------------------------- +-- | Refinements ---------------------------------------------- +--------------------------------------------------------------- + +isFunctionSortedReft :: SortedReft -> Bool +isFunctionSortedReft = isJust . functionSort . sr_sort + +isNonTrivial :: Reftable r => r -> Bool +isNonTrivial = not . isTauto + +reftPred :: Reft -> Expr +reftPred (Reft (_, p)) = p + +reftBind :: Reft -> Symbol +reftBind (Reft (x, _)) = x + +------------------------------------------------------------ +-- | Generally Useful Refinements -------------------------- +------------------------------------------------------------ + +symbolReft :: (Symbolic a) => a -> Reft +symbolReft = exprReft . eVar + +usymbolReft :: (Symbolic a) => a -> Reft +usymbolReft = uexprReft . eVar + +vv_ :: Symbol +vv_ = vv Nothing + +trueSortedReft :: Sort -> SortedReft +trueSortedReft = (`RR` trueReft) + +trueReft, falseReft :: Reft +trueReft = Reft (vv_, PTrue) +falseReft = Reft (vv_, PFalse) + +flattenRefas :: [Expr] -> [Expr] +flattenRefas = concatMap flatP + where + flatP (PAnd ps) = concatMap flatP ps + flatP p = [p] + +conjuncts :: Expr -> [Expr] +conjuncts (PAnd ps) = concatMap conjuncts ps +conjuncts p + | isTautoPred p = [] + | otherwise = [p] + +------------------------------------------------------------------------- +-- | TODO: This doesn't seem to merit a TC ------------------------------ +------------------------------------------------------------------------- + +class Falseable a where + isFalse :: a -> Bool + +instance Falseable Expr where + isFalse (PFalse) = True + isFalse _ = False + +instance Falseable Reft where + isFalse (Reft (_, ra)) = isFalse ra + +------------------------------------------------------------------------- +-- | Class Predicates for Valid Refinements ----------------------------- +------------------------------------------------------------------------- + +class Subable a where + syms :: a -> [Symbol] + substa :: (Symbol -> Symbol) -> a -> a + -- substa f = substf (EVar . f) + + substf :: (Symbol -> Expr) -> a -> a + subst :: Subst -> a -> a + subst1 :: a -> (Symbol, Expr) -> a + subst1 y (x, e) = subst (Su $ M.fromList [(x,e)]) y + +instance Subable a => Subable (Located a) where + syms (Loc _ _ x) = syms x + substa f (Loc l l' x) = Loc l l' (substa f x) + substf f (Loc l l' x) = Loc l l' (substf f x) + subst su (Loc l l' x) = Loc l l' (subst su x) + + +class (Monoid r, Subable r) => Reftable r where + isTauto :: r -> Bool + ppTy :: r -> Doc -> Doc + + top :: r -> r + top _ = mempty + + bot :: r -> r + + meet :: r -> r -> r + meet = mappend + + toReft :: r -> Reft + ofReft :: Reft -> r + params :: r -> [Symbol] -- ^ parameters for Reft, vv + others diff --git a/src/Language/Fixpoint/Types/Sorts.hs b/src/Language/Fixpoint/Types/Sorts.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fixpoint/Types/Sorts.hs @@ -0,0 +1,266 @@ +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternGuards #-} + +-- | This module contains the data types, operations and +-- serialization functions for representing Fixpoint's +-- implication (i.e. subtyping) and well-formedness +-- constraints in Haskell. The actual constraint +-- solving is done by the `fixpoint.native` which +-- is written in Ocaml. + +module Language.Fixpoint.Types.Sorts ( + + -- * Embedding to Fixpoint Types + Sort (..) + , Sub (..) + , FTycon, TCEmb + , sortFTycon + , intFTyCon, boolFTyCon, realFTyCon, numFTyCon -- TODO: hide these + + , intSort, realSort, boolSort, strSort, funcSort + , setSort, bitVecSort, mapSort + , listFTyCon + , isListTC + , fTyconSymbol, symbolFTycon, fTyconSort + , fApp, fApp', fAppTC + , fObj + + , sortSubst + , functionSort + , mkFFunc + , bkFFunc + ) where + +import qualified Data.Binary as B +import Data.Generics (Data) +import Data.Typeable (Typeable) +import GHC.Generics (Generic) + +import Data.Hashable +import Data.List (foldl') +import Control.DeepSeq +import Data.Maybe (fromMaybe) +import Language.Fixpoint.Types.Names +import Language.Fixpoint.Types.PrettyPrint +import Language.Fixpoint.Types.Spans +import Language.Fixpoint.Misc +import Text.PrettyPrint.HughesPJ +import qualified Data.HashMap.Strict as M + + +newtype FTycon = TC LocSymbol deriving (Eq, Ord, Show, Data, Typeable, Generic) +type TCEmb a = M.HashMap a FTycon + +intFTyCon, boolFTyCon, realFTyCon, funcFTyCon, numFTyCon, strFTyCon, listFTyCon :: FTycon +intFTyCon = TC $ dummyLoc "int" +boolFTyCon = TC $ dummyLoc "bool" +realFTyCon = TC $ dummyLoc "real" +numFTyCon = TC $ dummyLoc "num" +funcFTyCon = TC $ dummyLoc "function" +strFTyCon = TC $ dummyLoc strConName +listFTyCon = TC $ dummyLoc listConName + +isListConName :: LocSymbol -> Bool +isListConName x = c == listConName || c == listLConName --"List" + where + c = val x + +isListTC :: FTycon -> Bool +isListTC (TC z) = isListConName z + +fTyconSymbol :: FTycon -> Located Symbol +fTyconSymbol (TC s) = s + +symbolFTycon :: LocSymbol -> FTycon +symbolFTycon c + | isListConName c + = TC $ fmap (const listConName) c + | otherwise + = TC c + +fApp :: Sort -> [Sort] -> Sort +fApp = foldl' FApp + +fAppTC :: FTycon -> [Sort] -> Sort +fAppTC = fApp . fTyconSort + +fApp' :: Sort -> ListNE Sort +fApp' = go [] + where + go acc (FApp t1 t2) = go (t2 : acc) t1 + go acc t = t : acc + +fObj :: LocSymbol -> Sort +fObj = fTyconSort . TC + +sortFTycon :: Sort -> Maybe FTycon +sortFTycon FInt = Just intFTyCon +sortFTycon FReal = Just realFTyCon +sortFTycon FNum = Just numFTyCon +sortFTycon (FTC c) = Just c +sortFTycon _ = Nothing + +functionSort :: Sort -> Maybe ([Int], [Sort], Sort) +functionSort s + | null is && null ss + = Nothing + | otherwise + = Just (is, ss, r) + where + (is, ss, r) = go [] [] s + go vs ss (FAbs i t) = go (i:vs) ss t + go vs ss (FFunc s1 s2) = go vs (s1:ss) s2 + go vs ss t = (reverse vs, reverse ss, t) + +---------------------------------------------------------------------- +------------------------------- Sorts -------------------------------- +---------------------------------------------------------------------- + +data Sort = FInt + | FReal + | FNum -- ^ numeric kind for Num tyvars + | FFrac -- ^ numeric kind for Fractional tyvars + | FObj Symbol -- ^ uninterpreted type + | FVar !Int -- ^ fixpoint type variable + | FFunc !Sort !Sort -- ^ function + | FAbs !Int !Sort -- ^ type-abstraction + | FTC FTycon + | FApp Sort Sort -- ^ constructed type + deriving (Eq, Ord, Show, Data, Typeable, Generic) + +{-@ FFunc :: Nat -> ListNE Sort -> Sort @-} + +mkFFunc :: Int -> [Sort] -> Sort +mkFFunc i ss = go [0..i-1] ss + where + go [] [s] = s + go [] (s:ss) = FFunc s $ go [] ss + go (i:is) ss = FAbs i $ go is ss + go _ _ = error "cannot happen" + + -- foldl (flip FAbs) (foldl1 (flip FFunc) ss) [0..i-1] + +bkFFunc :: Sort -> Maybe (Int, [Sort]) +bkFFunc t = (maximum (0 : as),) <$> bkFun t' + where + (as, t') = bkAbs t + +bkAbs :: Sort -> ([Int], Sort) +bkAbs (FAbs i t) = (i:is, t') where (is, t') = bkAbs t +bkAbs t = ([], t) + +bkFun :: Sort -> Maybe [Sort] +bkFun z@(FFunc _ _) = Just (go z) + where + go (FFunc t1 t2) = t1 : go t2 + go t = [t] +bkFun _ = Nothing + + +instance Hashable FTycon where + hashWithSalt i (TC s) = hashWithSalt i s + +instance Hashable Sort + +newtype Sub = Sub [(Int, Sort)] deriving (Generic) + +instance Fixpoint Sort where + toFix = toFixSort + +toFixSort :: Sort -> Doc +toFixSort (FVar i) = text "@" <> parens (toFix i) +toFixSort FInt = text "int" +toFixSort FReal = text "real" +toFixSort FFrac = text "frac" +toFixSort (FObj x) = toFix x +toFixSort FNum = text "num" +toFixSort t@(FAbs _ _) = toFixAbsApp t +toFixSort t@(FFunc _ _)= toFixAbsApp t +toFixSort (FTC c) = toFix c +toFixSort t@(FApp _ _) = toFixFApp (fApp' t) + + +toFixAbsApp t = text "func" <> parens (toFix n <> text ", " <> toFix ts) + where + Just (vs, ss, s) = functionSort t + n = length vs + ts = ss ++ [s] + +toFixFApp :: ListNE Sort -> Doc +toFixFApp [t] = toFixSort t +toFixFApp [FTC c, t] + | isListTC c = brackets $ toFixSort t +toFixFApp ts = parens $ intersperse space (toFixSort <$> ts) + +instance Fixpoint FTycon where + toFix (TC s) = toFix s + +------------------------------------------------------------------------- +-- | Exported Basic Sorts ----------------------------------------------- +------------------------------------------------------------------------- + +boolSort, intSort, realSort, strSort, funcSort :: Sort +boolSort = fTyconSort boolFTyCon +strSort = fTyconSort strFTyCon +intSort = fTyconSort intFTyCon +realSort = fTyconSort realFTyCon +funcSort = fTyconSort funcFTyCon + +bitVecSort :: Sort +mapSort :: Sort -> Sort -> Sort + +setSort :: Sort -> Sort +setSort = FApp (FTC $ symbolFTycon' "Set_Set") + +bitVecSort = FApp (FTC $ symbolFTycon' bitVecName) (FTC $ symbolFTycon' size32Name) +mapSort k v = FApp (FApp (FTC $ symbolFTycon' "Map_t") k) v + +symbolFTycon' = symbolFTycon . dummyLoc + + +fTyconSort :: FTycon -> Sort +fTyconSort c + | c == intFTyCon = FInt + | c == realFTyCon = FReal + | c == numFTyCon = FNum + | otherwise = FTC c + +------------------------------------------------------------------------ +sortSubst :: M.HashMap Symbol Sort -> Sort -> Sort +------------------------------------------------------------------------ +sortSubst θ t@(FObj x) = fromMaybe t (M.lookup x θ) +sortSubst θ (FFunc t1 t2) = FFunc (sortSubst θ t1) (sortSubst θ t2) +sortSubst θ (FApp t1 t2) = FApp (sortSubst θ t1) (sortSubst θ t2) +sortSubst θ (FAbs i t) = FAbs i (sortSubst θ t) +sortSubst _ t = t + + +instance B.Binary FTycon +instance B.Binary Sort +instance B.Binary Sub + +instance NFData FTycon +instance NFData Sort +instance NFData Sub + + +instance Monoid Sort where + mempty = FObj "any" + mappend t1 t2 + | t1 == mempty = t2 + | t2 == mempty = t1 + | t1 == t2 = t1 + | otherwise = errorstar $ "mappend-sort: conflicting sorts t1 =" ++ show t1 ++ " t2 = " ++ show t2 diff --git a/src/Language/Fixpoint/Types/Spans.hs b/src/Language/Fixpoint/Types/Spans.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fixpoint/Types/Spans.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Language.Fixpoint.Types.Spans ( + + -- * Concrete Location Type + SourcePos + , SrcSpan (..) + + -- * Located Values + , Loc (..) + , Located (..) + + -- * Constructing spans + , dummySpan + , locAt + , dummyLoc + , dummyPos + , atLoc + + -- * Destructing spans + , sourcePosElts + ) where + +-- import Control.Exception +import Control.DeepSeq +-- import qualified Control.Monad.Error as E +import Data.Serialize (Serialize (..)) +import Data.Generics (Data) +import Data.Hashable +import Data.Typeable +import Data.String +import qualified Data.Binary as B +import GHC.Generics (Generic) +import Language.Fixpoint.Types.PrettyPrint +-- import Language.Fixpoint.Misc +import Text.Parsec.Pos +import Text.PrettyPrint.HughesPJ +import Text.Printf +-- import Debug.Trace + +----------------------------------------------------------------------- +-- | Located Values --------------------------------------------------- +----------------------------------------------------------------------- + +class Loc a where + srcSpan :: a -> SrcSpan + +----------------------------------------------------------------------- +-- | Retrofitting instances to SourcePos ------------------------------ +----------------------------------------------------------------------- + +instance NFData SourcePos where + rnf = rnf . ofSourcePos + +instance B.Binary SourcePos where + put = B.put . ofSourcePos + get = toSourcePos <$> B.get + +instance Serialize SourcePos where + put = put . ofSourcePos + get = toSourcePos <$> get + +instance PPrint SourcePos where + pprintTidy _ = text . show + +instance Hashable SourcePos where + hashWithSalt i = hashWithSalt i . sourcePosElts + +ofSourcePos :: SourcePos -> (SourceName, Line, Column) +ofSourcePos p = (f, l, c) + where + f = sourceName p + l = sourceLine p + c = sourceColumn p + +toSourcePos :: (SourceName, Line, Column) -> SourcePos +toSourcePos (f, l, c) = newPos f l c + +sourcePosElts s = (src, line, col) + where + src = sourceName s + line = sourceLine s + col = sourceColumn s + +instance Fixpoint SourcePos where + toFix = text . show + + +data Located a = Loc { loc :: !SourcePos -- ^ Start Position + , locE :: !SourcePos -- ^ End Position + , val :: a + } deriving (Data, Typeable, Generic) + +instance Loc (Located a) where + srcSpan (Loc l l' _) = SS l l' + + +instance (NFData a) => NFData (Located a) + +instance Fixpoint a => Fixpoint (Located a) where + toFix = toFix . val + +instance Functor Located where + fmap f (Loc l l' x) = Loc l l' (f x) + + +instance Foldable Located where + foldMap f (Loc _ _ x) = f x + +instance Traversable Located where + traverse f (Loc l l' x) = Loc l l' <$> f x + +instance Show a => Show (Located a) where + show (Loc l l' x) = show x ++ " defined from: " ++ show l ++ " to: " ++ show l' + +instance PPrint a => PPrint (Located a) where + pprintTidy k (Loc _ _ x) = pprintTidy k x + +instance Eq a => Eq (Located a) where + (Loc _ _ x) == (Loc _ _ y) = x == y + +instance Ord a => Ord (Located a) where + compare x y = compare (val x) (val y) + +instance (B.Binary a) => B.Binary (Located a) + +instance Hashable a => Hashable (Located a) where + hashWithSalt i = hashWithSalt i . val + +instance (IsString a) => IsString (Located a) where + fromString = dummyLoc . fromString + + +----------------------------------------------------------------------- +-- | A Reusable SrcSpan Type ------------------------------------------ +----------------------------------------------------------------------- + +data SrcSpan = SS { sp_start :: !SourcePos + , sp_stop :: !SourcePos} + deriving (Eq, Ord, Show, Data, Typeable, Generic) + +instance Serialize SrcSpan + +instance PPrint SrcSpan where + pprintTidy _ = ppSrcSpan + +-- ppSrcSpan_short z = parens +-- $ text (printf "file %s: (%d, %d) - (%d, %d)" (takeFileName f) l c l' c') +-- where +-- (f,l ,c ) = sourcePosElts $ sp_start z +-- (_,l',c') = sourcePosElts $ sp_stop z + + +ppSrcSpan z = text (printf "%s:%d:%d-%d:%d" f l c l' c') + -- parens $ text (printf "file %s: (%d, %d) - (%d, %d)" (takeFileName f) l c l' c') + where + (f,l ,c ) = sourcePosElts $ sp_start z + (_,l',c') = sourcePosElts $ sp_stop z + + +instance Hashable SrcSpan where + hashWithSalt i z = hashWithSalt i (sp_start z, sp_stop z) + +dummySpan = SS l l + where l = initialPos "" + +atLoc :: Located a -> b -> Located b +atLoc (Loc l l' _) = Loc l l' + +locAt :: String -> a -> Located a +locAt s = Loc l l + where + l = dummyPos s + +dummyLoc :: a -> Located a +dummyLoc = Loc l l + where + l = dummyPos "Fixpoint.Types.dummyLoc" + +dummyPos :: String -> SourcePos +dummyPos s = newPos s 0 0 diff --git a/src/Language/Fixpoint/Types/Substitutions.hs b/src/Language/Fixpoint/Types/Substitutions.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fixpoint/Types/Substitutions.hs @@ -0,0 +1,263 @@ +-- | This module contains the various instances for Subable, +-- which (should) depend on the visitors, and hence cannot +-- be in the same place as the @Term@ definitions. + +module Language.Fixpoint.Types.Substitutions ( + mkSubst + , isEmptySubst + , substExcept + , substfExcept + , subst1Except + , targetSubstSyms + , filterSubst + ) where + +import Data.Maybe +import qualified Data.HashMap.Strict as M +import qualified Data.HashSet as S +import Language.Fixpoint.Types.PrettyPrint +import Language.Fixpoint.Types.Names +import Language.Fixpoint.Types.Sorts +import Language.Fixpoint.Types.Refinements +import Language.Fixpoint.Misc +import Text.PrettyPrint.HughesPJ +import Text.Printf (printf) + +instance Monoid Subst where + mempty = emptySubst + mappend = catSubst + +filterSubst :: (Symbol -> Expr -> Bool) -> Subst -> Subst +filterSubst f (Su m) = Su (M.filterWithKey f m) + +emptySubst :: Subst +emptySubst = Su M.empty + +catSubst :: Subst -> Subst -> Subst +catSubst (Su s1) θ2@(Su s2) = Su $ M.union s1' s2 + where + s1' = subst θ2 <$> s1 + +mkSubst :: [(Symbol, Expr)] -> Subst +mkSubst = Su . M.fromList . reverse + +isEmptySubst :: Subst -> Bool +isEmptySubst (Su xes) = M.null xes + +targetSubstSyms :: Subst -> [Symbol] +targetSubstSyms (Su ms) = syms $ M.elems ms + +instance Subable () where + syms _ = [] + subst _ () = () + substf _ () = () + substa _ () = () + +instance (Subable a, Subable b) => Subable (a,b) where + syms (x, y) = syms x ++ syms y + subst su (x,y) = (subst su x, subst su y) + substf f (x,y) = (substf f x, substf f y) + substa f (x,y) = (substa f x, substa f y) + +instance Subable a => Subable [a] where + syms = concatMap syms + subst = map . subst + substf = map . substf + substa = map . substa + +instance Subable a => Subable (M.HashMap k a) where + syms = syms . M.elems + subst = M.map . subst + substf = M.map . substf + substa = M.map . substa + +subst1Except :: (Subable a) => [Symbol] -> a -> (Symbol, Expr) -> a +subst1Except xs z su@(x, _) + | x `elem` xs = z + | otherwise = subst1 z su + +substfExcept :: (Symbol -> Expr) -> [Symbol] -> Symbol -> Expr +substfExcept f xs y = if y `elem` xs then EVar y else f y + +substExcept :: Subst -> [Symbol] -> Subst +-- substExcept (Su m) xs = Su (foldr M.delete m xs) +substExcept (Su xes) xs = Su $ M.filterWithKey (const . not . (`elem` xs)) xes + +instance Subable Symbol where + substa f = f + substf f x = subSymbol (Just (f x)) x + subst su x = subSymbol (Just $ appSubst su x) x -- subSymbol (M.lookup x s) x + syms x = [x] + +appSubst :: Subst -> Symbol -> Expr +appSubst (Su s) x = fromMaybe (EVar x) (M.lookup x s) + +subSymbol (Just (EVar y)) _ = y +subSymbol Nothing x = x +subSymbol a b = errorstar (printf "Cannot substitute symbol %s with expression %s" (showFix b) (showFix a)) + +instance Subable Expr where + syms = exprSymbols + substa f = substf (EVar . f) + substf f (EApp s e) = EApp (substf f s) (substf f e) + substf f (ENeg e) = ENeg (substf f e) + substf f (EBin op e1 e2) = EBin op (substf f e1) (substf f e2) + substf f (EIte p e1 e2) = EIte (substf f p) (substf f e1) (substf f e2) + substf f (ECst e so) = ECst (substf f e) so + substf f (EVar x) = f x + substf f (PAnd ps) = PAnd $ map (substf f) ps + substf f (POr ps) = POr $ map (substf f) ps + substf f (PNot p) = PNot $ substf f p + substf f (PImp p1 p2) = PImp (substf f p1) (substf f p2) + substf f (PIff p1 p2) = PIff (substf f p1) (substf f p2) + substf f (PAtom r e1 e2) = PAtom r (substf f e1) (substf f e2) + substf _ p@(PKVar _ _) = p + substf _ (PAll _ _) = errorstar "substf: FORALL" + substf _ p = p + + + subst su (EApp f e) = EApp (subst su f) (subst su e) + subst su (ENeg e) = ENeg (subst su e) + subst su (EBin op e1 e2) = EBin op (subst su e1) (subst su e2) + subst su (EIte p e1 e2) = EIte (subst su p) (subst su e1) (subst su e2) + subst su (ECst e so) = ECst (subst su e) so + subst su (EVar x) = appSubst su x + subst su (PAnd ps) = PAnd $ map (subst su) ps + subst su (POr ps) = POr $ map (subst su) ps + subst su (PNot p) = PNot $ subst su p + subst su (PImp p1 p2) = PImp (subst su p1) (subst su p2) + subst su (PIff p1 p2) = PIff (subst su p1) (subst su p2) + subst su (PAtom r e1 e2) = PAtom r (subst su e1) (subst su e2) + subst su (PKVar k su') = PKVar k $ su' `catSubst` su + subst _ (PAll _ _) = errorstar "subst: FORALL" + subst su (PExist bs p) + | disjoint su bs = PExist bs $ subst su p --(substExcept su (fst <$> bs)) p + | otherwise = errorstar "subst: EXISTS (without disjoint binds)" + subst _ p = p + +disjoint :: Subst -> [(Symbol, Sort)] -> Bool +disjoint (Su su) bs = S.null $ suSyms `S.intersection` bsSyms + where + suSyms = S.fromList $ syms (M.elems su) ++ syms (M.keys su) + bsSyms = S.fromList $ syms $ fst <$> bs + +instance Monoid Expr where + mempty = PTrue + mappend p q = pAnd [p, q] + mconcat = pAnd + +instance Monoid Reft where + mempty = trueReft + mappend = meetReft + +meetReft :: Reft -> Reft -> Reft +meetReft (Reft (v, ra)) (Reft (v', ra')) + | v == v' = Reft (v , ra `mappend` ra') + | v == dummySymbol = Reft (v', ra' `mappend` (ra `subst1` (v , EVar v'))) + | otherwise = Reft (v , ra `mappend` (ra' `subst1` (v', EVar v ))) + +instance Monoid SortedReft where + mempty = RR mempty mempty + mappend t1 t2 = RR (mappend (sr_sort t1) (sr_sort t2)) (mappend (sr_reft t1) (sr_reft t2)) + +instance Subable Reft where + syms (Reft (v, ras)) = v : syms ras + substa f (Reft (v, ras)) = Reft (f v, substa f ras) + subst su (Reft (v, ras)) = Reft (v, subst (substExcept su [v]) ras) + substf f (Reft (v, ras)) = Reft (v, substf (substfExcept f [v]) ras) + subst1 (Reft (v, ras)) su = Reft (v, subst1Except [v] ras su) + +instance Subable SortedReft where + syms = syms . sr_reft + subst su (RR so r) = RR so $ subst su r + substf f (RR so r) = RR so $ substf f r + substa f (RR so r) = RR so $ substa f r + +instance Reftable () where + isTauto _ = True + ppTy _ d = d + top _ = () + bot _ = () + meet _ _ = () + toReft _ = mempty + ofReft _ = mempty + params _ = [] + +instance Reftable Reft where + isTauto = all isTautoPred . conjuncts . reftPred + ppTy = pprReft + toReft = id + ofReft = id + params _ = [] + bot _ = falseReft + top (Reft(v,_)) = Reft (v, mempty) + +pprReft (Reft (v, p)) d + | isTautoPred p + = d + | otherwise + = braces (toFix v <+> colon <+> d <+> text "|" <+> ppRas [p]) + +instance Reftable SortedReft where + isTauto = isTauto . toReft + ppTy = ppTy . toReft + toReft = sr_reft + ofReft = errorstar "No instance of ofReft for SortedReft" + params _ = [] + bot s = s { sr_reft = falseReft } + +-- RJ: this depends on `isTauto` hence, here. +instance PPrint Reft where + pprintTidy k r + | isTauto r = text "true" + | otherwise = pprintReft k r + +instance PPrint SortedReft where + pprintTidy k (RR so (Reft (v, ras))) + = braces + $ pprintTidy k v <+> text ":" <+> toFix so <+> text "|" <+> pprintTidy k ras + +instance Fixpoint Reft where + toFix = pprReftPred + +instance Fixpoint SortedReft where + toFix (RR so (Reft (v, ra))) + = braces + $ toFix v <+> text ":" <+> toFix so <+> text "|" <+> toFix (conjuncts ra) + +instance Show Reft where + show = showFix + +instance Show SortedReft where + show = showFix + +pprReftPred (Reft (_, p)) + | isTautoPred p + = text "true" + | otherwise + = ppRas [p] + +ppRas = cat . punctuate comma . map toFix . flattenRefas + +-------------------------------------------------------------------------------- +-- | TODO: Rewrite using visitor ----------------------------------------------- +-------------------------------------------------------------------------------- + +exprSymbols :: Expr -> [Symbol] +exprSymbols = go + where + go (EVar x) = [x] + go (EApp f e) = go f ++ go e + go (ENeg e) = go e + go (EBin _ e1 e2) = go e1 ++ go e2 + go (EIte p e1 e2) = exprSymbols p ++ go e1 ++ go e2 + go (ECst e _) = go e + go (PAnd ps) = concatMap go ps + go (POr ps) = concatMap go ps + go (PNot p) = go p + go (PIff p1 p2) = go p1 ++ go p2 + go (PImp p1 p2) = go p1 ++ go p2 + go (PAtom _ e1 e2) = exprSymbols e1 ++ exprSymbols e2 + go (PKVar _ (Su su)) = {- CUTSOLVER k : -} syms (M.elems su) + go (PAll xts p) = (fst <$> xts) ++ go p + go _ = [] diff --git a/src/Language/Fixpoint/Types/Utils.hs b/src/Language/Fixpoint/Types/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fixpoint/Types/Utils.hs @@ -0,0 +1,46 @@ +-- | This module has various utility functions for accessing queries. +-- TODO: move the "clients" in Visitors into this module. + +module Language.Fixpoint.Types.Utils ( + -- * Domain of a kvar + kvarDomain + + -- * Free variables in a refinement + , reftFreeVars + ) where + +-- import Language.Fixpoint.Types.PrettyPrint +import Language.Fixpoint.Types.Names +-- import Language.Fixpoint.Types.Errors +-- import Language.Fixpoint.Types.Spans +-- import Language.Fixpoint.Types.Sorts +import Language.Fixpoint.Types.Refinements +-- import Language.Fixpoint.Types.Substitutions +import Language.Fixpoint.Types.Environments +import Language.Fixpoint.Types.Constraints +-- import Language.Fixpoint.Types.Graphs + +import Language.Fixpoint.Misc (fst3) +import qualified Data.HashMap.Strict as M +import qualified Data.HashSet as S + + +-------------------------------------------------------------------------------- +-- | Compute the domain of a kvar +-------------------------------------------------------------------------------- +kvarDomain :: SInfo a -> KVar -> [Symbol] +-------------------------------------------------------------------------------- +kvarDomain si k = domain (bs si) (getWfC si k) + +domain :: BindEnv -> WfC a -> [Symbol] +domain be wfc = fst3 (wrft wfc) : map fst (envCs be $ wenv wfc) + +getWfC :: SInfo a -> KVar -> WfC a +getWfC si k = ws si M.! k + +-------------------------------------------------------------------------------- +-- | Free variables of a refinement +-------------------------------------------------------------------------------- +--TODO deduplicate (also in Solver/UniqifyBinds) +reftFreeVars :: Reft -> S.HashSet Symbol +reftFreeVars r@(Reft (v, _)) = S.delete v $ S.fromList $ syms r diff --git a/src/Language/Fixpoint/Types/Visitor.hs b/src/Language/Fixpoint/Types/Visitor.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fixpoint/Types/Visitor.hs @@ -0,0 +1,282 @@ +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} + +module Language.Fixpoint.Types.Visitor ( + -- * Visitor + Visitor (..) + + -- * Extracting Symbolic Constants (String Literals) + , SymConsts (..) + + -- * Default Visitor + , defaultVisitor + + -- * Transformers + , trans + + -- * Accumulators + , fold + + -- * Clients + , kvars + , size + , envKVars + , envKVarsN + , rhsKVars + , mapKVars, mapKVars', mapKVarSubsts + + -- * Predicates on Constraints + , isConcC , isKvarC + + -- * Sorts + , foldSort, mapSort + + + ) where + +import Control.Monad.Trans.State (State, modify, runState) +import qualified Data.HashSet as S +import qualified Data.HashMap.Strict as M +import qualified Data.List as L +import Language.Fixpoint.Types hiding (mapSort) +import Language.Fixpoint.Misc (count, sortNub) + +data Visitor acc ctx = Visitor { + -- | Context @ctx@ is built in a "top-down" fashion; not "across" siblings + ctxExpr :: ctx -> Expr -> ctx + + -- | Transforms can access current @ctx@ + , txExpr :: ctx -> Expr -> Expr + + -- | Accumulations can access current @ctx@; @acc@ value is monoidal + , accExpr :: ctx -> Expr -> acc + } + +--------------------------------------------------------------------------------- +defaultVisitor :: Monoid acc => Visitor acc ctx +--------------------------------------------------------------------------------- +defaultVisitor = Visitor { + ctxExpr = const -- \c _ -> c + , txExpr = \_ x -> x + , accExpr = \_ _ -> mempty + } + +------------------------------------------------------------------------ + +fold :: (Visitable t, Monoid a) => Visitor a ctx -> ctx -> a -> t -> a +fold v c a t = snd $ execVisitM v c a visit t + +trans :: (Visitable t, Monoid a) => Visitor a ctx -> ctx -> a -> t -> t +trans v c _ z = fst $ execVisitM v c mempty visit z + +execVisitM :: Visitor a ctx -> ctx -> a -> (Visitor a ctx -> ctx -> t -> State a t) -> t -> (t, a) +execVisitM v c a f x = runState (f v c x) a + +type VisitM acc = State acc + +accum :: (Monoid a) => a -> VisitM a () +accum = modify . mappend + +(<$$>) :: (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b) +f <$$> x = traverse f x + +------------------------------------------------------------------------------ +class Visitable t where + visit :: (Monoid a) => Visitor a c -> c -> t -> VisitM a t + +instance Visitable Expr where + visit = visitExpr + +instance Visitable Reft where + visit v c (Reft (x, ra)) = (Reft . (x, )) <$> visit v c ra + +instance Visitable SortedReft where + visit v c (RR t r) = RR t <$> visit v c r + +instance Visitable (Symbol, SortedReft) where + visit v c (sym, sr) = (sym, ) <$> visit v c sr + +instance Visitable BindEnv where + visit v c = mapM (visit v c) + +--------------------------------------------------------------------------------- +-- Warning: these instances were written for mapKVars over SInfos only; +-- check that they behave as expected before using with other clients. +instance Visitable (SimpC a) where + visit v c x = do + rhs' <- visit v c (_crhs x) + return x { _crhs = rhs' } + +instance Visitable (SInfo a) where + visit v c x = do + cm' <- mapM (visit v c) (cm x) + bs' <- visit v c (bs x) + return x { cm = cm', bs = bs' } +--------------------------------------------------------------------------------- + +visitExpr :: (Monoid a) => Visitor a ctx -> ctx -> Expr -> VisitM a Expr +visitExpr v = vE + where + vE c e = accum acc >> step c' e' where c' = ctxExpr v c e + e' = txExpr v c' e + acc = accExpr v c' e + step _ e@(ESym _) = return e + step _ e@(ECon _) = return e + step _ e@(EVar _) = return e + step c (EApp f e) = EApp <$> vE c f <*> vE c e + step c (ENeg e) = ENeg <$> vE c e + step c (EBin o e1 e2) = EBin o <$> vE c e1 <*> vE c e2 + step c (EIte p e1 e2) = EIte <$> vE c p <*> vE c e1 <*> vE c e2 + step c (ECst e t) = (`ECst` t) <$> vE c e + step c (PAnd ps) = PAnd <$> (vE c <$$> ps) + step c (POr ps) = POr <$> (vE c <$$> ps) + step c (PNot p) = PNot <$> vE c p + step c (PImp p1 p2) = PImp <$> vE c p1 <*> vE c p2 + step c (PIff p1 p2) = PIff <$> vE c p1 <*> vE c p2 + step c (PAtom r e1 e2) = PAtom r <$> vE c e1 <*> vE c e2 + step c (PAll xts p) = PAll xts <$> vE c p + step c (ELam (x,t) e) = ELam (x,t) <$> vE c e + step c (PExist xts p) = PExist xts <$> vE c p + step c (ETApp e s) = (`ETApp` s) <$> vE c e + step c (ETAbs e s) = (`ETAbs` s) <$> vE c e + step _ p@(PKVar _ _) = return p + step _ PGrad = return PGrad + +mapKVars :: Visitable t => (KVar -> Maybe Expr) -> t -> t +mapKVars f = mapKVars' f' + where + f' (kv', _) = f kv' + +mapKVars' :: Visitable t => ((KVar, Subst) -> Maybe Expr) -> t -> t +mapKVars' f = trans kvVis () [] + where + kvVis = defaultVisitor { txExpr = txK } + txK _ (PKVar k su) + | Just p' <- f (k, su) = subst su p' + txK _ p = p + +mapKVarSubsts :: Visitable t => (KVar -> Subst -> Subst) -> t -> t +mapKVarSubsts f = trans kvVis () [] + where + kvVis = defaultVisitor { txExpr = txK } + txK _ (PKVar k su) = PKVar k $ f k su + txK _ p = p + +newtype MInt = MInt Integer + +instance Monoid MInt where + mempty = MInt 0 + mappend (MInt m) (MInt n) = MInt (m + n) + +size :: Visitable t => t -> Integer +size t = n + where + MInt n = fold szV () mempty t + szV = (defaultVisitor :: Visitor MInt t) { accExpr = \ _ _ -> MInt 1 } + +kvars :: Visitable t => t -> [KVar] +kvars = fold kvVis () [] + where + kvVis = (defaultVisitor :: Visitor [KVar] t) { accExpr = kv' } + kv' _ (PKVar k _) = [k] + kv' _ _ = [] + +envKVars :: (TaggedC c a) => BindEnv -> c a -> [KVar] +envKVars be c = squish [ kvs sr | (_, sr) <- clhs be c] + where + squish = S.toList . S.fromList . concat + kvs = kvars . sr_reft + +envKVarsN :: (TaggedC c a) => BindEnv -> c a -> [(KVar, Int)] +envKVarsN be c = tally [ kvs sr | (_, sr) <- clhs be c] + where + tally = count . concat + kvs = kvars . sr_reft + +rhsKVars :: (TaggedC c a) => c a -> [KVar] +rhsKVars = kvars . crhs -- rhsCs + +isKvarC :: (TaggedC c a) => c a -> Bool +isKvarC = all isKvar . conjuncts . crhs + +isConcC :: (TaggedC c a) => c a -> Bool +isConcC = all isConc . conjuncts . crhs + +isKvar :: Expr -> Bool +isKvar (PKVar {}) = True +isKvar _ = False + +isConc :: Expr -> Bool +isConc = null . kvars + +--------------------------------------------------------------------------------- +-- | Visitors over @Sort@ +--------------------------------------------------------------------------------- +foldSort :: (a -> Sort -> a) -> a -> Sort -> a +foldSort f = step + where + step b t = go (f b t) t + go b (FFunc t1 t2) = L.foldl' step b [t1, t2] + go b (FApp t1 t2) = L.foldl' step b [t1, t2] + go b (FAbs _ t) = go b t + go b _ = b + +mapSort :: (Sort -> Sort) -> Sort -> Sort +mapSort f = step + where + step = go . f + go (FFunc t1 t2) = FFunc (step t1) (step t2) + go (FApp t1 t2) = FApp (step t1) (step t2) + go (FAbs i t) = FAbs i (step t) + go t = t + +--------------------------------------------------------------- +-- | String Constants ----------------------------------------- +--------------------------------------------------------------- + +-- symConstLits :: FInfo a -> [(Symbol, Sort)] +-- symConstLits fi = [(symbol c, strSort) | c <- symConsts fi] + +class SymConsts a where + symConsts :: a -> [SymConst] + +instance SymConsts (FInfo a) where + symConsts fi = sortNub $ csLits ++ bsLits ++ qsLits + where + csLits = concatMap symConsts $ M.elems $ cm fi + bsLits = symConsts $ bs fi + qsLits = concatMap symConsts $ q_body <$> quals fi + +instance SymConsts BindEnv where + symConsts = concatMap (symConsts . snd) . M.elems . beBinds + +instance SymConsts (SubC a) where + symConsts c = symConsts (slhs c) ++ + symConsts (srhs c) + +instance SymConsts SortedReft where + symConsts = symConsts . sr_reft + +instance SymConsts Reft where + symConsts (Reft (_, ra)) = getSymConsts ra + + +instance SymConsts Expr where + symConsts = getSymConsts + +getSymConsts :: Visitable t => t -> [SymConst] +getSymConsts = fold scVis () [] + where + scVis = (defaultVisitor :: Visitor [SymConst] t) { accExpr = sc } + sc _ (ESym c) = [c] + sc _ _ = [] + + +{- + +instance SymConsts (SimpC a) where + symConsts c = symConsts (crhs c) + +-} diff --git a/src/Language/Fixpoint/Utils/Files.hs b/src/Language/Fixpoint/Utils/Files.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fixpoint/Utils/Files.hs @@ -0,0 +1,199 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +-- | This module contains Haskell variables representing globally visible +-- names for files, paths, extensions. +-- +-- Rather than have strings floating around the system, all constant names +-- should be defined here, and the (exported) variables should be used and +-- manipulated elsewhere. + +module Language.Fixpoint.Utils.Files ( + + -- * Hardwired file extension names + Ext (..) + , extFileName + , extFileNameR + , tempDirectory + , extModuleName + , withExt + , isExtFile + , isBinary + + -- * Hardwired paths + , getFixpointPath + , getZ3LibPath + + -- * Various generic utility functions for finding and removing files + , getFileInDirs + , copyFiles + +) where + +import qualified Control.Exception as Ex +import Control.Monad +import Data.List hiding (find) +import Data.Maybe (fromMaybe) +import System.Directory +import System.FilePath +import Language.Fixpoint.Misc (errorstar) + +------------------------------------------------------------ +-- | Hardwired Paths and Files ----------------------------- +------------------------------------------------------------ + +getFixpointPath = fromMaybe msg . msum <$> + sequence [ findExecutable "fixpoint.native" + , findExecutable "fixpoint.native.exe" + -- fallback for developing in-tree... + , findFile ["external/fixpoint"] "fixpoint.native" + ] + where + msg = errorstar "Cannot find fixpoint binary [fixpoint.native]" + +getZ3LibPath = dropFileName <$> getFixpointPath + + +--checkM f msg p +-- = do ex <- f p +-- if ex then return p else errorstar $ "Cannot find " ++ msg ++ " at :" ++ p + + + ----------------------------------------------------------------------------------- + +data Ext = Cgi -- ^ Constraint Generation Information + | Fq -- ^ Input to constraint solving (fixpoint) + | Out -- ^ Output from constraint solving (fixpoint) + | Html -- ^ HTML file with inferred type annotations + | Annot -- ^ Text file with inferred types + | Vim -- ^ Vim annotation file + | Hs -- ^ Haskell source + | HsBoot -- ^ Haskell source + | LHs -- ^ Literate Haskell source + | Js -- ^ JavaScript source + | Ts -- ^ Typescript source + | Spec -- ^ Spec file (e.g. include/Prelude.spec) + | Hquals -- ^ Qualifiers file (e.g. include/Prelude.hquals) + | Result -- ^ Final result: SAFE/UNSAFE + | Cst -- ^ HTML file with templates? + | Mkdn -- ^ Markdown file (temporarily generated from .Lhs + annots) + | Json -- ^ JSON file containing result (annots + errors) + | Saved -- ^ Previous source (for incremental checking) + | Cache -- ^ Previous output (for incremental checking) + | Dot -- ^ Constraint Graph + | Part Int -- ^ Partition + | Auto Int -- ^ SMTLIB2 queries for automatically created proofs + | Pred + | PAss + | Dat + | BinFq -- ^ Binary representation of .fq / FInfo + | Smt2 -- ^ SMTLIB2 query file + | Min -- ^ filter constraints with delta debug + deriving (Eq, Ord, Show) + +extMap = go + where + go Cgi = ".cgi" + go Pred = ".pred" + go PAss = ".pass" + go Dat = ".dat" + go Out = ".fqout" + go Fq = ".fq" + go Html = ".html" + go Cst = ".cst" + go Annot = ".annot" + go Vim = ".vim.annot" + go Hs = ".hs" + go LHs = ".lhs" + go HsBoot = ".hs-boot" + go Js = ".js" + go Ts = ".ts" + go Mkdn = ".markdown" + go Json = ".json" + go Spec = ".spec" + go Hquals = ".hquals" + go Result = ".out" + go Saved = ".bak" + go Cache = ".err" + go Smt2 = ".smt2" + go (Auto n) = ".auto." ++ show n + go Dot = ".dot" + go BinFq = ".bfq" + go (Part n) = "." ++ show n + go Min = ".minfq" + -- go _ = errorstar $ "extMap: Unknown extension " ++ show e + +withExt :: FilePath -> Ext -> FilePath +withExt f ext = replaceExtension f (extMap ext) + +extFileName :: Ext -> FilePath -> FilePath +extFileName e f = path addExtension file ext + where + path = tempDirectory f + file = takeFileName f + ext = extMap e + +tempDirectory :: FilePath -> FilePath +tempDirectory f + | isTmp dir = dir + | otherwise = dir tmpDirName + where + dir = takeDirectory f + isTmp = (tmpDirName `isSuffixOf`) + +tmpDirName = ".liquid" + +extFileNameR :: Ext -> FilePath -> FilePath +extFileNameR ext = (`addExtension` extMap ext) + +isExtFile :: Ext -> FilePath -> Bool +isExtFile ext = (extMap ext ==) . takeExtension + +extModuleName :: String -> Ext -> FilePath +extModuleName modName ext = + case explode modName of + [] -> errorstar $ "malformed module name: " ++ modName + ws -> extFileNameR ext $ foldr1 () ws + where + explode = words . map (\c -> if c == '.' then ' ' else c) + +copyFiles :: [FilePath] -> FilePath -> IO () +copyFiles srcs tgt + = do Ex.catch (removeFile tgt) $ \(_ :: Ex.IOException) -> return () + forM_ srcs (readFile >=> appendFile tgt) + + +---------------------------------------------------------------------------------- + +-- getHsTargets p = mapM canonicalizePath =<< files +-- where +-- files +-- | hasTrailingPathSeparator p = getHsSourceFiles p +-- | otherwise = return [p] + +-- getHsSourceFiles = find dirs hs +-- where hs = extension ==? ".hs" ||? extension ==? ".lhs" +-- dirs = liftM (not . ("dist" `isSuffixOf`)) directory + +--------------------------------------------------------------------------- + + +getFileInDirs :: FilePath -> [FilePath] -> IO (Maybe FilePath) +getFileInDirs name = findFirst (testM doesFileExist . ( name)) + +testM f x = do b <- f x + return $ if b then [x] else [] + +findFirst :: Monad m => (t -> m [a]) -> [t] -> m (Maybe a) +findFirst _ [] = return Nothing +findFirst f (x:xs) = do r <- f x + case r of + y:_ -> return (Just y) + [] -> findFirst f xs + +-- findFileInDirs :: FilePath -> [FilePath] -> IO FilePath +-- findFileInDirs file dirs +-- = liftM (fromMaybe err) (findFirst (find always (fileName ==? file)) dirs) +-- where err = errorstar $ "findFileInDirs: cannot find " ++ file ++ " in " ++ show dirs + +isBinary :: FilePath -> Bool +isBinary = isExtFile BinFq diff --git a/src/Language/Fixpoint/Utils/Progress.hs b/src/Language/Fixpoint/Utils/Progress.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fixpoint/Utils/Progress.hs @@ -0,0 +1,55 @@ +-- | Progress Bar API +module Language.Fixpoint.Utils.Progress ( + withProgress + , progressInit + , progressTick + , progressClose + ) where + +import Control.Monad (unless) +import System.IO.Unsafe (unsafePerformIO) +import System.Console.CmdArgs.Verbosity (isLoud) +import Data.IORef + + +import System.Console.AsciiProgress + +{-# NOINLINE pbRef #-} +pbRef :: IORef (Maybe ProgressBar) +pbRef = unsafePerformIO (newIORef Nothing) + +withProgress :: Int -> IO a -> IO a +withProgress n act = displayConsoleRegions $ do + -- putStrLn $ "withProgress: " ++ show n + progressInit n + r <- act + progressClose + return r + +progressInit :: Int -> IO () +progressInit n = do + loud <- isLoud + unless loud $ do + pr <- mkPB n + writeIORef pbRef (Just pr) + +mkPB :: Int -> IO ProgressBar + +mkPB n = newProgressBar def { pgWidth = 80 + , pgTotal = toInteger n + , pgFormat = "Working :percent [:bar]" + , pgPendingChar = '.' + , pgOnCompletion = Just "Done solving." -- :percent." + } + +progressTick :: IO () +progressTick = go =<< readIORef pbRef + where + go (Just pr) = tick pr + go _ = return () + +progressClose :: IO () +progressClose = go =<< readIORef pbRef + where + go (Just p) = complete p + go _ = return () diff --git a/src/Language/Fixpoint/Utils/Statistics.hs b/src/Language/Fixpoint/Utils/Statistics.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fixpoint/Utils/Statistics.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | This module implements functions that print out +-- statistics about the constraints. +module Language.Fixpoint.Utils.Statistics (statistics) where + +import Control.DeepSeq +import GHC.Generics +import Control.Arrow ((&&&)) + +import Language.Fixpoint.Misc (donePhase, Moods(..), applyNonNull) +import Language.Fixpoint.Types.Config +import Language.Fixpoint.Types.PrettyPrint +import Language.Fixpoint.Partition (partition') +import qualified Language.Fixpoint.Types as F +import qualified Data.HashMap.Strict as M +import Data.List (sort,group) +import Text.PrettyPrint.HughesPJ + +statistics :: Config -> F.FInfo a -> IO (F.Result (Integer, a)) +statistics _ fi = do + let (_, fis) = partition' Nothing fi + putStrLn $ render $ pprint $ partitionStats fis + donePhase Loud "Statistics" + return mempty + +partitionStats :: [F.FInfo a] -> Maybe Stats +partitionStats fis = info + where + css = [M.keys $ F.cm fi | fi <- fis] + sizes = fromIntegral . length <$> css + info = applyNonNull Nothing (Just . mkStats) sizes + +------------------------------------------------------------------------------------- +------------------------------------------------------------------------------------- +------------------------------------------------------------------------------------- + +data Stats = Stats { cSizes :: [Float] + , cFreq :: [(Float, Int)] + , cTotal :: Float + , cMean :: Float + , cMax :: Float + , cSpeed :: Float + } deriving (Show, Generic) + +instance NFData Stats + +instance PPrint Stats where + pprintTidy _ s = + vcat [ "STAT: max/total =" <+> pprint (cMax s) <+> "/" <+> pprint (cTotal s) + , "STAT: freqs =" <+> pprint (cFreq s) + , "STAT: average =" <+> pprint (cMean s) + , "STAT: speed =" <+> pprint (cSpeed s) + ] + +mkStats :: [Float] -> Stats +mkStats ns = Stats { + cSizes = ns + , cFreq = frequency ns + , cTotal = total + , cMean = avg + , cMax = maxx + , cSpeed = total / maxx + } + where + maxx = maximum ns + total = sum ns + avg = mean ns + +frequency :: (Ord a) => [a] -> [(a, Int)] +frequency = map (head &&& length) . group . sort + +mean :: [Float] -> Float +mean ns = sum ns / fromIntegral (length ns) diff --git a/src/Language/Fixpoint/Visitor.hs b/src/Language/Fixpoint/Visitor.hs deleted file mode 100644 --- a/src/Language/Fixpoint/Visitor.hs +++ /dev/null @@ -1,200 +0,0 @@ -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE CPP #-} - -module Language.Fixpoint.Visitor ( - -- * Visitor - Visitor (..) - - -- * Default Visitor - , defaultVisitor - - -- * Transformers - , trans - - -- * Accumulators - , fold - - -- * Clients - , kvars - , envKVars - , mapKVars, mapKVars' - - -- * Sorts - , foldSort, mapSort - ) where - -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative (Applicative, (<$>), (<*>)) -import Data.Monoid -import Data.Traversable (Traversable, traverse) -#endif - -import Control.Monad.Trans.State (State, modify, runState) -import Language.Fixpoint.Types -import qualified Data.HashSet as S -import qualified Data.List as L - -data Visitor acc ctx = Visitor { - -- | Context @ctx@ is built in a "top-down" fashion; not "across" siblings - ctxExpr :: ctx -> Expr -> ctx - , ctxPred :: ctx -> Pred -> ctx - - -- | Transforms can access current @ctx@ - , txExpr :: ctx -> Expr -> Expr - , txPred :: ctx -> Pred -> Pred - - -- | Accumulations can access current @ctx@; @acc@ value is monoidal - , accExpr :: ctx -> Expr -> acc - , accPred :: ctx -> Pred -> acc - } - ---------------------------------------------------------------------------------- -defaultVisitor :: Monoid acc => Visitor acc ctx ---------------------------------------------------------------------------------- -defaultVisitor = Visitor { - ctxExpr = const -- \c _ -> c - , ctxPred = const -- \c _ -> c - , txExpr = \_ x -> x - , txPred = \_ x -> x - , accExpr = \_ _ -> mempty - , accPred = \_ _ -> mempty - } - ------------------------------------------------------------------------- - -fold :: (Visitable t, Monoid a) => Visitor a ctx -> ctx -> a -> t -> a -fold v c a t = snd $ execVisitM v c a visit t - -trans :: (Visitable t, Monoid a) => Visitor a ctx -> ctx -> a -> t -> t -trans v c _ z = fst $ execVisitM v c mempty visit z - -execVisitM :: Visitor a ctx -> ctx -> a -> (Visitor a ctx -> ctx -> t -> State a t) -> t -> (t, a) -execVisitM v c a f x = runState (f v c x) a - -type VisitM acc = State acc - -accum :: (Monoid a) => a -> VisitM a () -accum = modify . mappend - -(<$$>) :: (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b) -f <$$> x = traverse f x - ------------------------------------------------------------------------------- -class Visitable t where - visit :: (Monoid a) => Visitor a c -> c -> t -> VisitM a t - -instance Visitable Expr where - visit = visitExpr - -instance Visitable Pred where - visit = visitPred - -instance Visitable Refa where - visit v c (Refa p) = Refa <$> visit v c p - -instance Visitable Reft where - visit v c (Reft (x, ra)) = (Reft . (x, )) <$> visit v c ra - -visitMany :: (Monoid a, Visitable t) => Visitor a ctx -> ctx -> [t] -> VisitM a [t] -visitMany v c xs = visit v c <$$> xs - -visitExpr :: (Monoid a) => Visitor a ctx -> ctx -> Expr -> VisitM a Expr -visitExpr v = vE - where - vP = visitPred v - vE c e = accum acc >> step c' e' where c' = ctxExpr v c e - e' = txExpr v c' e - acc = accExpr v c' e - step _ e@EBot = return e - step _ e@(ESym _) = return e - step _ e@(ECon _) = return e - step _ e@(ELit _ _) = return e - step _ e@(EVar _) = return e - step c (EApp f es) = EApp f <$> (vE c <$$> es) - step c (ENeg e) = ENeg <$> vE c e - step c (EBin o e1 e2) = EBin o <$> vE c e1 <*> vE c e2 - step c (EIte p e1 e2) = EIte <$> vP c p <*> vE c e1 <*> vE c e2 - step c (ECst e t) = (`ECst` t) <$> vE c e - -visitPred :: (Monoid a) => Visitor a ctx -> ctx -> Pred -> VisitM a Pred -visitPred v = vP - where - -- vS1 c (x, e) = (x,) <$> vE c e - -- vS c (Su xes) = Su <$> vS1 c <$$> xes - vE = visitExpr v - vP c p = accum acc >> step c' p' where c' = ctxPred v c p - p' = txPred v c' p - acc = accPred v c' p - step c (PAnd ps) = PAnd <$> (vP c <$$> ps) - step c (POr ps) = POr <$> (vP c <$$> ps) - step c (PNot p) = PNot <$> vP c p - step c (PImp p1 p2) = PImp <$> vP c p1 <*> vP c p2 - step c (PIff p1 p2) = PIff <$> vP c p1 <*> vP c p2 - step c (PBexp e) = PBexp <$> vE c e - step c (PAtom r e1 e2) = PAtom r <$> vE c e1 <*> vE c e2 - step c (PAll xts p) = PAll xts <$> vP c p - step _ p@(PKVar _ _) = return p -- PAtom r <$> vE c e1 <*> vE c e2 - step _ p@PTrue = return p - step _ p@PFalse = return p - step _ p@PTop = return p - - ---------------------------------------------------------------------------------- --- reftKVars :: Reft -> [KVar] ---------------------------------------------------------------------------------- - --- reftKVars (Reft (_, ra)) = predKVars $ raPred ra --- predKVars :: Pred -> [Symbol] - -mapKVars :: Visitable t => (KVar -> Maybe Pred) -> t -> t -mapKVars f = mapKVars' f' - where - f' (kv, _) = f kv - -mapKVars' :: Visitable t => ((KVar, Subst) -> Maybe Pred) -> t -> t -mapKVars' f = trans kvVis () [] - where - kvVis = defaultVisitor { txPred = txK } - txK _ (PKVar k su) - | Just p' <- f (k, su) = subst su p' - txK _ p = p - -kvars :: Visitable t => t -> [KVar] -kvars = fold kvVis () [] - where - kvVis = defaultVisitor { accPred = kv } - kv _ (PKVar k _) = [k] - kv _ _ = [] - - -envKVars :: BindEnv -> SubC a -> [KVar] -envKVars be c = squish [ kvs sr | (_, sr) <- envCs be (senv c)] - where - squish = S.toList . S.fromList . concat - kvs = kvars . sr_reft - - - ---------------------------------------------------------------------------------- --- | Visitors over @Sort@ ---------------------------------------------------------------------------------- -foldSort :: (a -> Sort -> a) -> a -> Sort -> a ---------------------------------------------------------------------------------- -foldSort f = step - where - step b t = go (f b t) t - go b (FFunc _ ts) = L.foldl' step b ts - go b (FApp _ ts) = L.foldl' step b ts - go b _ = b - - ---------------------------------------------------------------------------------- -mapSort :: (Sort -> Sort) -> Sort -> Sort ---------------------------------------------------------------------------------- -mapSort f = step - where - step = go . f - go (FFunc n ts) = FFunc n $ step <$> ts - go (FApp c ts) = FApp c $ step <$> ts - go t = t diff --git a/tests/neg/conj-rhs.fq b/tests/neg/conj-rhs.fq new file mode 100644 --- /dev/null +++ b/tests/neg/conj-rhs.fq @@ -0,0 +1,6 @@ +constraint: + env [] + lhs {v:int | true } + rhs {v:int | (0 = 1) && (1 = 0) } + id 1 + tag [1] diff --git a/tests/neg/float-literal.fq b/tests/neg/float-literal.fq --- a/tests/neg/float-literal.fq +++ b/tests/neg/float-literal.fq @@ -1,7 +1,6 @@ constraint: env [] - grd true lhs {VV#F2 : a_aZU | []} rhs {VV#F2 : a_aZU | [(VV#F2 >= 1.0)]} id 2 tag [2] diff --git a/tests/neg/float.fq b/tests/neg/float.fq new file mode 100644 --- /dev/null +++ b/tests/neg/float.fq @@ -0,0 +1,11 @@ +// adapted from LH test Propability.hs + +bind 50 x : {v1 : real | [(v1 = 0.2)]} +bind 56 y : {v2 : real | [(v2 = 0.9 + x)]} + +constraint: + env [50; + 56] + lhs {VV#F3 : real | []} + rhs {VV#F3 : real | [(y = 1.0)]} + id 3 tag [1] diff --git a/tests/neg/literals.fq b/tests/neg/literals.fq new file mode 100644 --- /dev/null +++ b/tests/neg/literals.fq @@ -0,0 +1,10 @@ +//adapted from LH test Strings.hs + +constant lit#bar : (Str) +constant lit#foo : (Str) + +constraint: + env [] + lhs {VV#F1 : int | []} + rhs {VV#F1 : int | [(lit#bar = lit#foo)]} + id 1 tag [6] diff --git a/tests/neg/num00.fq b/tests/neg/num00.fq new file mode 100644 --- /dev/null +++ b/tests/neg/num00.fq @@ -0,0 +1,28 @@ +// This qualifier saves the day; solve constraints WITHOUT IT + +qualif Zog(v:a) : (0 <= v) + +bind 0 zog : {v : int | true} + +constraint: + env [0] + lhs {v : alpha | (v = 10)} + rhs {v : alpha | $k0} + id 1 tag [] + +constraint: + env [0] + lhs {v : alpha | $k0} + rhs {v : alpha | $k0} + id 2 tag [] + +constraint: + env [0] + lhs {v : alpha | $k0} + rhs {v : alpha | 0 <= v} + id 3 tag [] + +wf: + env [0] + reft {v: alpha | $k0} + diff --git a/tests/neg/poly0.fq b/tests/neg/poly0.fq new file mode 100644 --- /dev/null +++ b/tests/neg/poly0.fq @@ -0,0 +1,14 @@ + +// This definition works fine ... +// constant offset : (func(0, [int ; int ; (BitVec Size32) ])) + +// But this crashes as 'offset 0' is embedded as int not bv... +constant offset : (func(1, [int; int; @(0)])) + +bind 0 x : {VV : (BitVec Size32) | [ VV = offset 0 0 ]} + +constraint: + env [0] + lhs {VV : (BitVec Size32) | [ VV = x ] } + rhs {VV : (BitVec Size32) | [ VV != x ] } + id 1 tag [1] diff --git a/tests/neg/poly1.fq b/tests/neg/poly1.fq new file mode 100644 --- /dev/null +++ b/tests/neg/poly1.fq @@ -0,0 +1,16 @@ + +// This definition works fine ... +// constant offset : (func(2, [int ; (BitVec Size32) ])) + +// But this crashes as 'offset 0' is embedded as int not bv... +constant offset : (func(2, [int; @(0)])) + +bind 0 x : {VV : (BitVec Size32) | [ VV = offset 0 ]} + +constraint: + env [0] + lhs {VV : (BitVec Size32) | [ VV = x ] } + rhs {VV : (BitVec Size32) | [ VV != x ] } + id 1 tag [1] + + diff --git a/tests/neg/poly2.fq b/tests/neg/poly2.fq new file mode 100644 --- /dev/null +++ b/tests/neg/poly2.fq @@ -0,0 +1,14 @@ + +// This definition works fine ... +// constant offset : (func(0, [int ; int ; (BitVec Size32) ])) + +// But this crashes as 'offset 0' is embedded as int not bv... +constant offset : (func(2, [@(0); int; int; @(0); @(1)])) + +bind 0 x : {VV : (BitVec Size32) | [ VV = offset 0 0 0 0 ]} + +constraint: + env [0] + lhs {VV : (BitVec Size32) | [ VV = x ] } + rhs {VV : (BitVec Size32) | [ VV != x ] } + id 1 tag [1] diff --git a/tests/neg/test00.fq b/tests/neg/test00.fq --- a/tests/neg/test00.fq +++ b/tests/neg/test00.fq @@ -6,25 +6,22 @@ constraint: env [ ] - grd true lhs {v : int | (v = 9)} rhs {v : int | $k0} - id 1 + id 1 tag [] constraint: env [ ] - grd true lhs {v : int | v = 20} rhs {v : int | $k0} - id 2 + id 2 tag [] constraint: env [ 0 ] - grd true lhs {v : int | v = a} rhs {v : int | 10 <= v} - id 3 + id 3 tag [] wf: env [ ] diff --git a/tests/neg/test00a.fq b/tests/neg/test00a.fq --- a/tests/neg/test00a.fq +++ b/tests/neg/test00a.fq @@ -8,24 +8,21 @@ constraint: env [0] - grd true lhs {v : int | (x = 9)} rhs {v : int | $k0[v:=x]} - id 1 + id 1 tag [] constraint: env [1] - grd true lhs {v : int | y = 20} rhs {v : int | $k0[v:=y]} - id 2 + id 2 tag [] constraint: env [2] - grd true lhs {v : int | $k0[v:=z]} rhs {v : int | 10 <= z} - id 3 + id 3 tag [] wf: env [ ] diff --git a/tests/neg/test1.fq b/tests/neg/test1.fq --- a/tests/neg/test1.fq +++ b/tests/neg/test1.fq @@ -8,24 +8,21 @@ constraint: env [0] - grd true lhs {v : int | v = x} rhs {v : int | $k0 } - id 1 + id 1 tag [] constraint: env [1] - grd true lhs {v : int | v = y} rhs {v : int | $k0 } - id 2 + id 2 tag [] constraint: env [2] - grd true lhs {v : int | v = a } rhs {v : int | 10 <= v} - id 3 + id 3 tag [] wf: env [ ] diff --git a/tests/neg/test2.fq b/tests/neg/test2.fq --- a/tests/neg/test2.fq +++ b/tests/neg/test2.fq @@ -13,39 +13,34 @@ constraint: env [ ] - grd true lhs {v : int | v = 0} rhs {v : int | $k1 } - id 0 + id 0 tag [] constraint: env [ 0; 1] - grd true lhs {v : int | v = x + a} rhs {v : int | $k0} - id 1 + id 1 tag [] constraint: env [2; 3] - grd true lhs {v : int | v = y + b} rhs {v : int | $k0} - id 2 + id 2 tag [] constraint: env [ ] - grd true lhs {v : int | $k0} rhs {v : int | $k1} - id 3 + id 3 tag [] constraint: env [4] - grd true lhs {v : int | v = c } rhs {v : int | 10 <= v} - id 4 + id 4 tag [] wf: env [ ] diff --git a/tests/neg/test3.fq b/tests/neg/test3.fq --- a/tests/neg/test3.fq +++ b/tests/neg/test3.fq @@ -7,17 +7,15 @@ constraint: env [1] - grd true lhs {v : int | v = q} rhs {v : int | $k0[x:=q] } - id 1 + id 1 tag [] constraint: env [2] - grd true lhs {v : int | $k0[x:=y]} rhs {v : int | v = 10} - id 2 + id 2 tag [] wf: env [0] diff --git a/tests/pos/bad-subst00.fq b/tests/pos/bad-subst00.fq new file mode 100644 --- /dev/null +++ b/tests/pos/bad-subst00.fq @@ -0,0 +1,26 @@ +qualif Zog(v:a) : (10 <= v) +qualif Bog(v:a, x:a) : (x <= v) + +bind 0 a : {v: int | $k0[zogbert := pikachu] } + +constraint: + env [ ] + lhs {v : int | v = 10} + rhs {v : int | $k0} + id 1 tag [] + +constraint: + env [ ] + lhs {v : int | v = 20} + rhs {v : int | $k0} + id 2 tag [] + +constraint: + env [ 0 ] + lhs {v : int | v = a} + rhs {v : int | 10 <= v} + id 3 tag [] + +wf: + env [ ] + reft {v: int | $k0} diff --git a/tests/pos/bad-subst01.fq b/tests/pos/bad-subst01.fq new file mode 100644 --- /dev/null +++ b/tests/pos/bad-subst01.fq @@ -0,0 +1,31 @@ +qualif Zog(v:a) : (10 <= v) +qualif Bog(v:a, x:a) : (x <= v) + +bind 0 a : {v: int | $k0 } + +// this is a junk binder that adds a bogus [param := zogbert] substitution +// at each USE of k0 causing eliminate to crash. + +bind 10 zogbert : {v : int | [] } + +constraint: + env [ ] + lhs {v : int | v = 10} + rhs {v : int | $k0} + id 1 tag [] + +constraint: + env [ ] + lhs {v : int | v = 20} + rhs {v : int | $k0} + id 2 tag [] + +constraint: + env [ 0 ] + lhs {v : int | v = a} + rhs {v : int | 10 <= v} + id 3 tag [] + +wf: + env [ 10 ] + reft {v: int | $k0} diff --git a/tests/pos/conj-rhs.fq b/tests/pos/conj-rhs.fq new file mode 100644 --- /dev/null +++ b/tests/pos/conj-rhs.fq @@ -0,0 +1,6 @@ +constraint: + env [] + lhs {v:int | true } + rhs {v:int | (0 < 1) && (1 > 0) } + id 1 + tag [1] diff --git a/tests/pos/elim00.fq b/tests/pos/elim00.fq new file mode 100644 --- /dev/null +++ b/tests/pos/elim00.fq @@ -0,0 +1,1493 @@ +// trick is to do it without these +qualif Cmp(v : @(0), x : @(0)): ((v > x)) // "tests/todo/elim00.hs.fq" (line 1, column 8) +qualif Cmp(v : @(0), x : @(0)): ((v = x)) // "tests/todo/elim00.hs.fq" (line 2, column 8) + + +constant Control.Exception.Base.irrefutPatError##09 : (func(1, [int; + @(0)])) +constant GHC.Base..##r2C : (func(3, [func(0, [@(0); @(1)]); + func(0, [@(2); @(0)]); + @(2); + @(1)])) +constant runFun : (func(2, [(Arrow @(0) @(1)); @(0); @(1)])) +constant GHC.Tuple.$40$$44$$44$$41$$35$$35$76 : (func(3, [@(0); + @(1); + @(2); + (Tuple @(0) @(1) @(2))])) +constant GHC.Real.D$58$Integral$35$$35$rWH : (func(1, [func(0, [@(0); + @(0); + @(0)]); + func(0, [@(0); @(0); @(0)]); + func(0, [@(0); @(0); @(0)]); + func(0, [@(0); @(0); @(0)]); + func(0, [@(0); @(0); (Tuple @(0) @(0))]); + func(0, [@(0); @(0); (Tuple @(0) @(0))]); + func(0, [@(0); int]); + (GHC.Real.Integral @(0))])) +constant addrLen : (func(0, [int; int])) +constant papp5 : (func(10, [(Pred @(0) @(1) @(2) @(3) @(4)); + @(5); + @(6); + @(7); + @(8); + @(9); + bool])) +constant xsListSelector : (func(1, [[@(0)]; [@(0)]])) +constant x_Tuple21 : (func(2, [(Tuple @(0) @(1)); @(0)])) +constant x_Tuple65 : (func(6, [(Tuple @(0) @(1) @(2) @(3) @(4) @(5)); + @(4)])) +constant Elim.foo##rlD : (func(0, [Elim.Foo; Elim.Foo])) +constant x_Tuple55 : (func(5, [(Tuple @(0) @(1) @(2) @(3) @(4)); + @(4)])) +constant GHC.Integer.Type.smallInteger##0Z : (func(0, [int; int])) +constant x_Tuple33 : (func(3, [(Tuple @(0) @(1) @(2)); @(2)])) +constant x_Tuple77 : (func(7, [(Tuple @(0) @(1) @(2) @(3) @(4) @(5) @(6)); + @(6)])) +constant GHC.Base.Just##r1e : (func(1, [@(0); + (GHC.Base.Maybe @(0))])) +constant Elim.xx##rlB : (func(0, [Elim.Foo; int])) +constant papp3 : (func(6, [(Pred @(0) @(1) @(2)); + @(3); + @(4); + @(5); + bool])) +constant GHC.Prim.$43$$35$$35$$35$98 : (func(0, [int; int; int])) +constant x_Tuple63 : (func(6, [(Tuple @(0) @(1) @(2) @(3) @(4) @(5)); + @(2)])) +constant x_Tuple41 : (func(4, [(Tuple @(0) @(1) @(2) @(3)); + @(0)])) +constant GHC.Types.LT##6S : (GHC.Types.Ordering) +constant GHC.Prim.$60$$35$$35$$35$9q : (func(0, [int; int; int])) +constant papp4 : (func(8, [(Pred @(0) @(1) @(2) @(3)); + @(4); + @(5); + @(6); + @(7); + bool])) +constant Elim.PP##rlx : (func(2, [@(0); + @(1); + (Elim.Pair @(0) @(1))])) +constant x_Tuple64 : (func(6, [(Tuple @(0) @(1) @(2) @(3) @(4) @(5)); + @(3)])) +constant GHC.Types.GT##6W : (GHC.Types.Ordering) +constant GHC.Prim.$45$$35$$35$$35$99 : (func(0, [int; int; int])) +constant GHC.Types.$58$$35$$35$64 : (func(1, [@(0); + [@(0)]; + [@(0)]])) +constant autolen : (func(1, [@(0); int])) +constant GHC.Types.I###6c : (func(0, [int; int])) +constant x_Tuple52 : (func(5, [(Tuple @(0) @(1) @(2) @(3) @(4)); + @(1)])) +constant xx : (func(0, [Elim.Foo; int])) +constant null : (func(1, [[@(0)]; bool])) +constant GHC.Num.$43$$35$$35$rt : (func(1, [@(0); @(0); @(0)])) +constant GHC.Tuple.$40$$44$$44$$44$$44$$41$$35$$35$7a : (func(5, [@(0); + @(1); + @(2); + @(3); + @(4); + (Tuple @(0) @(1) @(2) @(3) @(4))])) +constant papp2 : (func(4, [(Pred @(0) @(1)); @(2); @(3); bool])) +constant x_Tuple62 : (func(6, [(Tuple @(0) @(1) @(2) @(3) @(4) @(5)); + @(1)])) +constant GHC.Tuple.$40$$44$$41$$35$$35$74 : (func(2, [@(0); + @(1); + (Tuple @(0) @(1))])) +constant Elim.yy##rlC : (func(0, [Elim.Foo; int])) +constant fromJust : (func(1, [(GHC.Base.Maybe @(0)); @(0)])) +constant papp7 : (func(14, [(Pred @(0) @(1) @(2) @(3) @(4) @(5) @(6)); + @(7); + @(8); + @(9); + @(10); + @(11); + @(12); + @(13); + bool])) +constant x_Tuple53 : (func(5, [(Tuple @(0) @(1) @(2) @(3) @(4)); + @(2)])) +constant x_Tuple71 : (func(7, [(Tuple @(0) @(1) @(2) @(3) @(4) @(5) @(6)); + @(0)])) +constant GHC.Prim.$62$$35$$35$$35$9m : (func(0, [int; int; int])) +constant x_Tuple74 : (func(7, [(Tuple @(0) @(1) @(2) @(3) @(4) @(5) @(6)); + @(3)])) +constant Elim.Emp##rly : (func(2, [(Elim.Pair @(0) @(1))])) +constant len : (func(2, [(@(0) @(1)); int])) +constant GHC.Tuple.$40$$44$$44$$44$$44$$44$$44$$41$$35$$35$7e : (func(7, [@(0); + @(1); + @(2); + @(3); + @(4); + @(5); + @(6); + (Tuple @(0) @(1) @(2) @(3) @(4) @(5) @(6))])) +constant papp6 : (func(12, [(Pred @(0) @(1) @(2) @(3) @(4) @(5)); + @(6); + @(7); + @(8); + @(9); + @(10); + @(11); + bool])) +constant x_Tuple22 : (func(2, [(Tuple @(0) @(1)); @(1)])) +constant Data.Foldable.length##r1s : (func(2, [(@(0) @(0)); int])) +constant x_Tuple66 : (func(6, [(Tuple @(0) @(1) @(2) @(3) @(4) @(5)); + @(5)])) +constant x_Tuple44 : (func(4, [(Tuple @(0) @(1) @(2) @(3)); + @(3)])) +constant xListSelector : (func(1, [[@(0)]; @(0)])) +constant strLen : (func(0, [int; int])) +constant x_Tuple72 : (func(7, [(Tuple @(0) @(1) @(2) @(3) @(4) @(5) @(6)); + @(1)])) +constant GHC.Tuple.$40$$44$$44$$44$$41$$35$$35$78 : (func(4, [@(0); + @(1); + @(2); + @(3); + (Tuple @(0) @(1) @(2) @(3))])) +constant isJust : (func(1, [(GHC.Base.Maybe @(0)); bool])) +constant GHC.Prim.$61$$61$$35$$35$$35$9o : (func(0, [int; + int; + int])) +constant Elim.Foo##rlA : (func(0, [int; int; Elim.Foo])) +constant Prop : (func(0, [GHC.Types.Bool; bool])) +constant x_Tuple31 : (func(3, [(Tuple @(0) @(1) @(2)); @(0)])) +constant x_Tuple75 : (func(7, [(Tuple @(0) @(1) @(2) @(3) @(4) @(5) @(6)); + @(4)])) +constant papp1 : (func(2, [(Pred @(0)); @(1); bool])) +constant yy : (func(0, [Elim.Foo; int])) +constant x_Tuple61 : (func(6, [(Tuple @(0) @(1) @(2) @(3) @(4) @(5)); + @(0)])) +constant GHC.Prim.$62$$61$$35$$35$$35$9n : (func(0, [int; + int; + int])) +constant lit$36$tests$47$pos$47$elim00.hs$58$14$58$5$45$30$124$PP$32$wink$32$cow : (Str) +constant x_Tuple43 : (func(4, [(Tuple @(0) @(1) @(2) @(3)); + @(2)])) +constant GHC.Types.EQ##6U : (GHC.Types.Ordering) +constant x_Tuple51 : (func(5, [(Tuple @(0) @(1) @(2) @(3) @(4)); + @(0)])) +constant GHC.Base.Nothing##r1d : (func(1, [(GHC.Base.Maybe @(0))])) +constant GHC.Num.$45$$35$$35$02B : (func(1, [@(0); @(0); @(0)])) +constant GHC.Num.$42$$35$$35$ru : (func(1, [@(0); @(0); @(0)])) +constant x_Tuple73 : (func(7, [(Tuple @(0) @(1) @(2) @(3) @(4) @(5) @(6)); + @(2)])) +constant GHC.Types.$91$$93$$35$$35$6m : (func(1, [[@(0)]])) +constant x_Tuple54 : (func(5, [(Tuple @(0) @(1) @(2) @(3) @(4)); + @(3)])) +constant cmp : (func(0, [GHC.Types.Ordering; GHC.Types.Ordering])) +constant x_Tuple32 : (func(3, [(Tuple @(0) @(1) @(2)); @(1)])) +constant x_Tuple76 : (func(7, [(Tuple @(0) @(1) @(2) @(3) @(4) @(5) @(6)); + @(5)])) +constant GHC.Prim.$60$$61$$35$$35$$35$9r : (func(0, [int; + int; + int])) +constant GHC.Real.D$58$Fractional$35$$35$rVU : (func(1, [func(0, [@(0); + @(0); + @(0)]); + func(0, [@(0); @(0)]); + func(0, [(GHC.Real.Ratio int); @(0)]); + (GHC.Real.Fractional @(0))])) +constant fst : (func(2, [(Tuple @(0) @(1)); @(0)])) +constant snd : (func(2, [(Tuple @(0) @(1)); @(1)])) +constant GHC.Tuple.$40$$44$$44$$44$$44$$44$$41$$35$$35$7c : (func(6, [@(0); + @(1); + @(2); + @(3); + @(4); + @(5); + (Tuple @(0) @(1) @(2) @(3) @(4) @(5))])) +constant x_Tuple42 : (func(4, [(Tuple @(0) @(1) @(2) @(3)); + @(1)])) +constant GHC.Prim.void###0l : (GHC.Prim.Void#) + + +bind 0 GHC.Prim.void###0l : {VV##180 : GHC.Prim.Void# | []} +bind 1 Elim.Emp##rly : {VV : func(2, [(Elim.Pair @(0) @(1))]) | []} +bind 2 GHC.Types.EQ##6U : {VV##185 : GHC.Types.Ordering | [(VV##185 = GHC.Types.EQ##6U)]} +bind 3 GHC.Types.LT##6S : {VV##186 : GHC.Types.Ordering | [(VV##186 = GHC.Types.LT##6S)]} +bind 4 GHC.Types.GT##6W : {VV##187 : GHC.Types.Ordering | [(VV##187 = GHC.Types.GT##6W)]} +bind 5 Elim.Emp##rly : {VV : func(2, [(Elim.Pair @(0) @(1))]) | []} +bind 6 GHC.Types.$91$$93$$35$$35$6m : {VV : func(1, [[@(0)]]) | []} +bind 7 GHC.Types.GT##6W : {VV##213 : GHC.Types.Ordering | [((cmp VV##213) = GHC.Types.GT##6W)]} +bind 8 GHC.Types.LT##6S : {VV##214 : GHC.Types.Ordering | [((cmp VV##214) = GHC.Types.LT##6S)]} +bind 9 GHC.Types.EQ##6U : {VV##215 : GHC.Types.Ordering | [((cmp VV##215) = GHC.Types.EQ##6U)]} +bind 10 GHC.Base.Nothing##r1d : {VV : func(1, [(GHC.Base.Maybe @(0))]) | []} +bind 11 ds_dxd : {VV##222 : Elim.Foo | []} +bind 12 lq_anf$##dxr : {lq_tmp$x##223 : Elim.Foo | [(lq_tmp$x##223 = ds_dxd)]} +bind 13 lq_anf$##dxr : {lq_tmp$x##225 : Elim.Foo | [(lq_tmp$x##225 = ds_dxd)]} +bind 14 xig##awy : {lq_tmp$x##233 : int | []} +bind 15 yog##awz : {lq_tmp$x##234 : int | [(xig##awy < lq_tmp$x##234)]} +bind 16 lq_anf$##dxr : {lq_tmp$x##225 : Elim.Foo | [(lq_tmp$x##225 = ds_dxd); + ((yy lq_tmp$x##225) = yog##awz); + ((xx lq_tmp$x##225) = xig##awy); + (lq_tmp$x##225 = (Elim.Foo##rlA xig##awy yog##awz)); + ((yy lq_tmp$x##225) = yog##awz); + ((xx lq_tmp$x##225) = xig##awy)]} +bind 17 lq_anf$##dxs : {lq_tmp$x##242 : (Elim.Pair int int) | [(lq_tmp$x##242 = (Elim.PP##rlx xig##awy yog##awz))]} +bind 18 lq_anf$##dxt : {lq_tmp$x##273 : (Elim.Pair int int) | [(lq_tmp$x##273 = lq_anf$##dxs)]} +bind 19 lq_anf$##dxt : {lq_tmp$x##277 : (Elim.Pair int int) | [(lq_tmp$x##277 = lq_anf$##dxs)]} +bind 20 wink##ax3 : {lq_tmp$x##275 : int | [$k_##248[lq_tmp$x##277:=lq_anf$##dxt][VV##247:=lq_tmp$x##275][lq_tmp$x##242:=lq_anf$##dxt][lq_tmp$x##271:=lq_tmp$x##275][lq_tmp$x##273:=lq_anf$##dxt][lq_tmp$x##245:=xig##awy][lq_tmp$x##246:=yog##awz][lq_tmp$x##250:=lq_tmp$x##275]]} +bind 21 cow##ax4 : {lq_tmp$x##276 : int | [$k_##252[lq_tmp$x##277:=lq_anf$##dxt][lq_tmp$x##281:=wink##ax3][VV##251:=lq_tmp$x##276][lq_tmp$x##242:=lq_anf$##dxt][lq_tmp$x##254:=lq_tmp$x##276][lq_tmp$x##273:=lq_anf$##dxt][lq_tmp$x##245:=xig##awy][lq_tmp$x##246:=yog##awz][lq_tmp$x##272:=lq_tmp$x##276]]} +bind 22 lq_anf$##dxt : {lq_tmp$x##277 : (Elim.Pair int int) | [(lq_tmp$x##277 = lq_anf$##dxs); + (lq_tmp$x##277 = (Elim.PP##rlx wink##ax3 cow##ax4)); + (lq_tmp$x##277 = (Elim.PP##rlx wink##ax3 cow##ax4)); + (lq_tmp$x##277 = (Elim.PP##rlx wink##ax3 cow##ax4))]} +bind 23 lq_tmp$x##307 : {VV##308 : int | []} +bind 24 lq_anf$##dxt : {lq_tmp$x##313 : (Elim.Pair int int) | [(lq_tmp$x##313 = lq_anf$##dxs)]} +bind 25 lq_anf$##dxt : {lq_tmp$x##313 : (Elim.Pair int int) | [(lq_tmp$x##313 = lq_anf$##dxs); + (lq_tmp$x##313 = Elim.Emp##rly); + (lq_tmp$x##313 = Elim.Emp##rly); + (lq_tmp$x##313 = Elim.Emp##rly)]} +bind 26 ds_dxg : {VV##318 : GHC.Prim.Void# | [$k_##319]} +bind 27 lq_anf$##dxu : {lq_tmp$x##335 : int | [(lq_tmp$x##335 ~~ lit$36$tests$47$pos$47$elim00.hs$58$14$58$5$45$30$124$PP$32$wink$32$cow); + ((strLen lq_tmp$x##335) = 39)]} +bind 28 ds_dxh : {VV##268 : (Tuple int int) | [$k_##269]} +bind 29 lq_anf$##dxw : {lq_tmp$x##368 : (Tuple int int) | [(lq_tmp$x##368 = ds_dxh)]} +bind 30 lq_anf$##dxw : {lq_tmp$x##374 : (Tuple int int) | [(lq_tmp$x##374 = ds_dxh)]} +bind 31 wink##ax3 : {lq_tmp$x##370 : int | [$k_##259[lq_tmp$x##368:=lq_anf$##dxw][VV##268:=lq_anf$##dxw][lq_tmp$x##364:=lq_tmp$x##370][VV##258:=lq_tmp$x##370][lq_tmp$x##374:=lq_anf$##dxw]]} +bind 32 cow##Xxd : {lq_tmp$x##371 : int | [$k_##262[lq_tmp$x##368:=lq_anf$##dxw][VV##268:=lq_anf$##dxw][VV##261:=lq_tmp$x##371][lq_tmp$x##365:=lq_tmp$x##371][lq_tmp$x##379:=wink##ax3][lq_tmp$x##374:=lq_anf$##dxw]; + $k_##266[lq_tmp$x##368:=lq_anf$##dxw][lq_tmp$x##373:=lq_tmp$x##371][VV##265:=lq_tmp$x##371][lq_tmp$x##264:=wink##ax3][lq_tmp$x##367:=lq_tmp$x##371][VV##268:=lq_anf$##dxw][lq_tmp$x##372:=wink##ax3][lq_tmp$x##366:=wink##ax3][lq_tmp$x##379:=wink##ax3][lq_tmp$x##374:=lq_anf$##dxw]]} +bind 33 lq_anf$##dxw : {lq_tmp$x##374 : (Tuple int int) | [(lq_tmp$x##374 = ds_dxh); + ((snd lq_tmp$x##374) = cow##Xxd); + ((fst lq_tmp$x##374) = wink##ax3); + ((x_Tuple22 lq_tmp$x##374) = cow##Xxd); + ((x_Tuple21 lq_tmp$x##374) = wink##ax3); + (lq_tmp$x##374 = (GHC.Tuple.$40$$44$$41$$35$$35$74 wink##ax3 cow##Xxd)); + ((snd lq_tmp$x##374) = cow##Xxd); + ((fst lq_tmp$x##374) = wink##ax3); + ((x_Tuple22 lq_tmp$x##374) = cow##Xxd); + ((x_Tuple21 lq_tmp$x##374) = wink##ax3)]} +bind 34 wink##ax3 : {VV##361 : int | [$k_##362]} +// bind 45 wink##ax3 : {lq_tmp$x##452 : int | [$k_##428[lq_tmp$x##425:=wink##ax3][lq_tmp$x##456:=lq_anf$##dxy][VV##427:=lq_tmp$x##452][lq_tmp$x##426:=cow##ax4][lq_tmp$x##450:=lq_anf$##dxy][lq_tmp$x##430:=lq_tmp$x##452][lq_tmp$x##446:=lq_tmp$x##452][lq_tmp$x##422:=lq_anf$##dxy]]} + +bind 35 lq_anf$##dxv : {lq_tmp$x##398 : (Tuple int int) | [(lq_tmp$x##398 = ds_dxh)]} +bind 36 lq_anf$##dxv : {lq_tmp$x##404 : (Tuple int int) | [(lq_tmp$x##404 = ds_dxh)]} +bind 37 wink##ax3 : {lq_tmp$x##400 : int | [$k_##259[VV##268:=lq_anf$##dxv][lq_tmp$x##394:=lq_tmp$x##400][VV##258:=lq_tmp$x##400][lq_tmp$x##398:=lq_anf$##dxv][lq_tmp$x##404:=lq_anf$##dxv]]} +bind 38 cow##ax4 : {lq_tmp$x##401 : int | [$k_##262[VV##268:=lq_anf$##dxv][VV##261:=lq_tmp$x##401][lq_tmp$x##409:=wink##ax3][lq_tmp$x##398:=lq_anf$##dxv][lq_tmp$x##395:=lq_tmp$x##401][lq_tmp$x##404:=lq_anf$##dxv]; + $k_##266[lq_tmp$x##396:=wink##ax3][VV##265:=lq_tmp$x##401][lq_tmp$x##264:=wink##ax3][VV##268:=lq_anf$##dxv][lq_tmp$x##397:=lq_tmp$x##401][lq_tmp$x##409:=wink##ax3][lq_tmp$x##403:=lq_tmp$x##401][lq_tmp$x##398:=lq_anf$##dxv][lq_tmp$x##402:=wink##ax3][lq_tmp$x##404:=lq_anf$##dxv]]} +bind 39 lq_anf$##dxv : {lq_tmp$x##404 : (Tuple int int) | [(lq_tmp$x##404 = ds_dxh); + ((snd lq_tmp$x##404) = cow##ax4); + ((fst lq_tmp$x##404) = wink##ax3); + ((x_Tuple22 lq_tmp$x##404) = cow##ax4); + ((x_Tuple21 lq_tmp$x##404) = wink##ax3); + (lq_tmp$x##404 = (GHC.Tuple.$40$$44$$41$$35$$35$74 wink##ax3 cow##ax4)); + ((snd lq_tmp$x##404) = cow##ax4); + ((fst lq_tmp$x##404) = wink##ax3); + ((x_Tuple22 lq_tmp$x##404) = cow##ax4); + ((x_Tuple21 lq_tmp$x##404) = wink##ax3)]} +bind 40 cow##ax4 : {VV##391 : int | [$k_##392]} +bind 41 lq_tmp$x##438 : {VV##439 : int | []} +bind 42 ds_dxi : {lq_tmp$x##422 : (Tuple int int) | [((snd lq_tmp$x##422) = cow##ax4); + ((fst lq_tmp$x##422) = wink##ax3); + ((x_Tuple22 lq_tmp$x##422) = cow##ax4); + ((x_Tuple21 lq_tmp$x##422) = wink##ax3)]} +bind 43 lq_anf$##dxy : {lq_tmp$x##450 : (Tuple int int) | [(lq_tmp$x##450 = ds_dxi)]} +bind 44 lq_anf$##dxy : {lq_tmp$x##456 : (Tuple int int) | [(lq_tmp$x##456 = ds_dxi)]} +bind 45 wink##ax3 : {lq_tmp$x##452 : int | [$k_##428[lq_tmp$x##425:=wink##ax3][lq_tmp$x##456:=lq_anf$##dxy][VV##427:=lq_tmp$x##452][lq_tmp$x##426:=cow##ax4][lq_tmp$x##450:=lq_anf$##dxy][lq_tmp$x##430:=lq_tmp$x##452][lq_tmp$x##446:=lq_tmp$x##452][lq_tmp$x##422:=lq_anf$##dxy]]} +bind 46 cow##ax4 : {lq_tmp$x##453 : int | [$k_##432[lq_tmp$x##425:=wink##ax3][lq_tmp$x##456:=lq_anf$##dxy][lq_tmp$x##426:=cow##ax4][VV##431:=lq_tmp$x##453][lq_tmp$x##450:=lq_anf$##dxy][lq_tmp$x##447:=lq_tmp$x##453][lq_tmp$x##461:=wink##ax3][lq_tmp$x##422:=lq_anf$##dxy][lq_tmp$x##434:=lq_tmp$x##453]; + $k_##436[lq_tmp$x##425:=wink##ax3][lq_tmp$x##456:=lq_anf$##dxy][lq_tmp$x##426:=cow##ax4][lq_tmp$x##455:=lq_tmp$x##453][lq_tmp$x##450:=lq_anf$##dxy][lq_tmp$x##461:=wink##ax3][lq_tmp$x##438:=wink##ax3][lq_tmp$x##421:=wink##ax3][lq_tmp$x##422:=lq_anf$##dxy][lq_tmp$x##434:=lq_tmp$x##453][lq_tmp$x##448:=wink##ax3][lq_tmp$x##449:=lq_tmp$x##453][VV##435:=lq_tmp$x##453][lq_tmp$x##454:=wink##ax3]]} +bind 47 lq_anf$##dxy : {lq_tmp$x##456 : (Tuple int int) | [(lq_tmp$x##456 = ds_dxi); + ((snd lq_tmp$x##456) = cow##ax4); + ((fst lq_tmp$x##456) = wink##ax3); + ((x_Tuple22 lq_tmp$x##456) = cow##ax4); + ((x_Tuple21 lq_tmp$x##456) = wink##ax3); + (lq_tmp$x##456 = (GHC.Tuple.$40$$44$$41$$35$$35$74 wink##ax3 cow##ax4)); + ((snd lq_tmp$x##456) = cow##ax4); + ((fst lq_tmp$x##456) = wink##ax3); + ((x_Tuple22 lq_tmp$x##456) = cow##ax4); + ((x_Tuple21 lq_tmp$x##456) = wink##ax3)]} +bind 48 wink##awA : {VV##443 : int | [$k_##444]} + +bind 49 lq_anf$##dxx : {lq_tmp$x##480 : (Tuple int int) | [(lq_tmp$x##480 = ds_dxi)]} +bind 50 lq_anf$##dxx : {lq_tmp$x##486 : (Tuple int int) | [(lq_tmp$x##486 = ds_dxi)]} +bind 51 wink##ax3 : {lq_tmp$x##482 : int | [$k_##428[lq_tmp$x##425:=wink##ax3][VV##427:=lq_tmp$x##482][lq_tmp$x##426:=cow##ax4][lq_tmp$x##476:=lq_tmp$x##482][lq_tmp$x##430:=lq_tmp$x##482][lq_tmp$x##480:=lq_anf$##dxx][lq_tmp$x##422:=lq_anf$##dxx][lq_tmp$x##486:=lq_anf$##dxx]]} +bind 52 cow##ax4 : {lq_tmp$x##483 : int | [$k_##432[lq_tmp$x##425:=wink##ax3][lq_tmp$x##426:=cow##ax4][VV##431:=lq_tmp$x##483][lq_tmp$x##491:=wink##ax3][lq_tmp$x##480:=lq_anf$##dxx][lq_tmp$x##477:=lq_tmp$x##483][lq_tmp$x##422:=lq_anf$##dxx][lq_tmp$x##434:=lq_tmp$x##483][lq_tmp$x##486:=lq_anf$##dxx]; + $k_##436[lq_tmp$x##425:=wink##ax3][lq_tmp$x##426:=cow##ax4][lq_tmp$x##491:=wink##ax3][lq_tmp$x##480:=lq_anf$##dxx][lq_tmp$x##479:=lq_tmp$x##483][lq_tmp$x##485:=lq_tmp$x##483][lq_tmp$x##438:=wink##ax3][lq_tmp$x##421:=wink##ax3][lq_tmp$x##422:=lq_anf$##dxx][lq_tmp$x##434:=lq_tmp$x##483][lq_tmp$x##484:=wink##ax3][lq_tmp$x##478:=wink##ax3][lq_tmp$x##486:=lq_anf$##dxx][VV##435:=lq_tmp$x##483]]} +bind 53 lq_anf$##dxx : {lq_tmp$x##486 : (Tuple int int) | [(lq_tmp$x##486 = ds_dxi); + ((snd lq_tmp$x##486) = cow##ax4); + ((fst lq_tmp$x##486) = wink##ax3); + ((x_Tuple22 lq_tmp$x##486) = cow##ax4); + ((x_Tuple21 lq_tmp$x##486) = wink##ax3); + (lq_tmp$x##486 = (GHC.Tuple.$40$$44$$41$$35$$35$74 wink##ax3 cow##ax4)); + ((snd lq_tmp$x##486) = cow##ax4); + ((fst lq_tmp$x##486) = wink##ax3); + ((x_Tuple22 lq_tmp$x##486) = cow##ax4); + ((x_Tuple21 lq_tmp$x##486) = wink##ax3)]} +bind 54 cow##awB : {VV##473 : int | [$k_##474]} +bind 55 ds_dxo : {VV##514 : Elim.Foo | []} +bind 56 lq_anf$##dxz : {lq_tmp$x##515 : Elim.Foo | [(lq_tmp$x##515 = ds_dxo)]} +bind 57 lq_anf$##dxz : {lq_tmp$x##517 : Elim.Foo | [(lq_tmp$x##517 = ds_dxo)]} +bind 58 ds_dxp : {lq_tmp$x##525 : int | []} +bind 59 ds_dxq : {lq_tmp$x##526 : int | [(ds_dxp < lq_tmp$x##526)]} +bind 60 lq_anf$##dxz : {lq_tmp$x##517 : Elim.Foo | [(lq_tmp$x##517 = ds_dxo); + ((yy lq_tmp$x##517) = ds_dxq); + ((xx lq_tmp$x##517) = ds_dxp); + (lq_tmp$x##517 = (Elim.Foo##rlA ds_dxp ds_dxq)); + ((yy lq_tmp$x##517) = ds_dxq); + ((xx lq_tmp$x##517) = ds_dxp)]} +bind 61 ds_dxl : {VV##537 : Elim.Foo | []} +bind 62 lq_anf$##dxA : {lq_tmp$x##538 : Elim.Foo | [(lq_tmp$x##538 = ds_dxl)]} +bind 63 lq_anf$##dxA : {lq_tmp$x##540 : Elim.Foo | [(lq_tmp$x##540 = ds_dxl)]} +bind 64 ds_dxm : {lq_tmp$x##548 : int | []} +bind 65 ds_dxn : {lq_tmp$x##549 : int | [(ds_dxm < lq_tmp$x##549)]} +bind 66 lq_anf$##dxA : {lq_tmp$x##540 : Elim.Foo | [(lq_tmp$x##540 = ds_dxl); + ((yy lq_tmp$x##540) = ds_dxn); + ((xx lq_tmp$x##540) = ds_dxm); + (lq_tmp$x##540 = (Elim.Foo##rlA ds_dxm ds_dxn)); + ((yy lq_tmp$x##540) = ds_dxn); + ((xx lq_tmp$x##540) = ds_dxm)]} +bind 67 VV##559 : {VV##559 : int | [(VV##559 = ds_dxm)]} +bind 68 VV##561 : {VV##561 : int | [(VV##561 = ds_dxq)]} +bind 69 VV##563 : {VV##563 : Elim.Foo | [((yy VV##563) = cow##awB); + ((xx VV##563) = wink##awA)]} +bind 70 VV##565 : {VV##565 : int | [(VV##565 = cow##awB)]} +bind 71 VV##567 : {VV##567 : int | [(VV##567 = wink##awA)]} +bind 72 VV##569 : {VV##569 : int | [(VV##569 = cow##ax4)]} +bind 73 VV##571 : {VV##571 : int | [(VV##571 = wink##ax3)]} +bind 74 VV##573 : {VV##573 : int | [(VV##573 = cow##ax4)]} +bind 75 VV##575 : {VV##575 : int | [(VV##575 = wink##ax3)]} +bind 76 VV##577 : {VV##577 : int | [(VV##577 = cow##ax4)]} +bind 77 VV##579 : {VV##579 : int | [(VV##579 = wink##ax3)]} +bind 78 VV##581 : {VV##581 : (Tuple int int) | [$k_##333[VV##332:=VV##581][ds_dxg:=GHC.Prim.void###0l]]} +bind 79 VV##583 : {VV##583 : int | [$k_##323[VV##322:=VV##583][VV##332:=VV##581][ds_dxg:=GHC.Prim.void###0l]]} +bind 80 VV##585 : {VV##585 : int | [$k_##326[VV##325:=VV##585][VV##332:=VV##581][ds_dxg:=GHC.Prim.void###0l]]} +bind 81 lq_tmp$x##264 : {VV##587 : int | []} +bind 82 VV##588 : {VV##588 : int | [$k_##330[VV##332:=VV##581][VV##329:=VV##588][ds_dxg:=GHC.Prim.void###0l][lq_tmp$x##328:=lq_tmp$x##264]]} +bind 83 VV##590 : {VV##590 : GHC.Prim.Void# | [(VV##590 = GHC.Prim.void###0l)]} +bind 84 VV##592 : {VV##592 : (Tuple int int) | [$k_##351[lq_tmp$x##339:=lq_anf$##dxu][lq_tmp$x##357:=VV##592][VV##350:=VV##592]]} +bind 85 VV##594 : {VV##594 : int | [$k_##341[lq_tmp$x##353:=VV##594][lq_tmp$x##339:=lq_anf$##dxu][lq_tmp$x##357:=VV##592][VV##340:=VV##594][VV##350:=VV##592]]} +bind 86 VV##596 : {VV##596 : int | [$k_##344[lq_tmp$x##339:=lq_anf$##dxu][lq_tmp$x##357:=VV##592][VV##343:=VV##596][lq_tmp$x##354:=VV##596][VV##350:=VV##592]]} +bind 87 lq_tmp$x##328 : {VV##598 : int | []} +bind 88 VV##599 : {VV##599 : int | [$k_##348[lq_tmp$x##355:=lq_tmp$x##328][lq_tmp$x##356:=VV##599][VV##347:=VV##599][lq_tmp$x##339:=lq_anf$##dxu][lq_tmp$x##346:=lq_tmp$x##328][lq_tmp$x##357:=VV##592][VV##350:=VV##592]]} +bind 89 VV##601 : {VV##601 : int | [(VV##601 = lq_anf$##dxu)]} +bind 90 VV##603 : {VV##603 : (Tuple int int) | [((snd VV##603) = cow##ax4); + ((fst VV##603) = wink##ax3); + ((x_Tuple22 VV##603) = cow##ax4); + ((x_Tuple21 VV##603) = wink##ax3)]} +bind 91 VV##605 : {VV##605 : int | [$k_##297[lq_tmp$x##295:=cow##ax4][lq_tmp$x##299:=VV##605][lq_tmp$x##291:=VV##603][lq_tmp$x##294:=wink##ax3][VV##296:=VV##605]]} +bind 92 VV##607 : {VV##607 : int | [$k_##301[lq_tmp$x##295:=cow##ax4][lq_tmp$x##291:=VV##603][lq_tmp$x##294:=wink##ax3][VV##300:=VV##607][lq_tmp$x##303:=VV##607]]} +bind 93 lq_tmp$x##264 : {VV##609 : int | []} +bind 94 VV##610 : {VV##610 : int | [$k_##305[lq_tmp$x##295:=cow##ax4][lq_tmp$x##290:=lq_tmp$x##264][VV##304:=VV##610][lq_tmp$x##307:=lq_tmp$x##264][lq_tmp$x##291:=VV##603][lq_tmp$x##294:=wink##ax3][lq_tmp$x##303:=VV##610]]} +bind 95 VV##612 : {VV##612 : int | [(VV##612 = cow##ax4)]} +bind 96 VV##614 : {VV##614 : int | [(VV##614 = wink##ax3)]} +bind 97 VV##616 : {VV##616 : int | [(VV##616 = yog##awz)]} +bind 98 VV##618 : {VV##618 : int | [(VV##618 = xig##awy)]} +bind 99 VV##473 : {VV##473 : int | [$k_##474]} +bind 100 VV##443 : {VV##443 : int | [$k_##444]} +bind 101 VV##435 : {VV##435 : int | [$k_##436]} +bind 102 VV##431 : {VV##431 : int | [$k_##432]} +bind 103 VV##427 : {VV##427 : int | [$k_##428]} +bind 104 VV##391 : {VV##391 : int | [$k_##392]} +bind 105 VV##361 : {VV##361 : int | [$k_##362]} +bind 106 VV##318 : {VV##318 : GHC.Prim.Void# | [$k_##319]} +bind 107 VV##350 : {VV##350 : (Tuple int int) | [$k_##351]} +bind 108 VV##340 : {VV##340 : int | [$k_##341]} +bind 109 VV##343 : {VV##343 : int | [$k_##344]} +bind 110 lq_tmp$x##346 : {VV##631 : int | []} +bind 111 VV##347 : {VV##347 : int | [$k_##348]} +bind 112 VV##332 : {VV##332 : (Tuple int int) | [$k_##333]} +bind 113 VV##322 : {VV##322 : int | [$k_##323]} +bind 114 VV##325 : {VV##325 : int | [$k_##326]} +bind 115 lq_tmp$x##328 : {VV##636 : int | []} +bind 116 VV##329 : {VV##329 : int | [$k_##330]} +bind 117 VV##304 : {VV##304 : int | [$k_##305]} +bind 118 VV##300 : {VV##300 : int | [$k_##301]} +bind 119 VV##296 : {VV##296 : int | [$k_##297]} +bind 120 VV##268 : {VV##268 : (Tuple int int) | [$k_##269]} +bind 121 VV##258 : {VV##258 : int | [$k_##259]} +bind 122 VV##261 : {VV##261 : int | [$k_##262]} +bind 123 lq_tmp$x##264 : {VV##644 : int | []} +bind 124 VV##265 : {VV##265 : int | [$k_##266]} +bind 125 VV##251 : {VV##251 : int | [$k_##252]} +bind 126 VV##247 : {VV##247 : int | [$k_##248]} + +constraint: + env [0; + 1; + 2; + 3; + 4; + 5; + 6; + 7; + 8; + 9; + 10; + 11; + 12; + 13; + 14; + 15; + 16; + 17; + 28; + 34; + 40; + 42; + 48; + 54 ] + lhs {VV##1 : int | [(VV##1 = cow##awB)]} + rhs {VV##1 : int | [(wink##awA < VV##1)]} + id 1 tag [1] + // META constraint id 1 : () + + +constraint: + env [0; + 1; + 2; + 3; + 4; + 5; + 6; + 7; + 8; + 9; + 10; + 11; + 12; + 13; + 14; + 15; + 16; + 17; + 28; + 34; + 40; + 42; + 48; + 49; + 50; + 51; + 52; + 53] + lhs {VV##2 : int | [(VV##2 = cow##ax4)]} + rhs {VV##2 : int | [$k_##474[VV##569:=VV##2][VV##F##2:=VV##2][VV##F:=VV##2][VV##473:=VV##2]]} + id 2 tag [1] + // META constraint id 2 : () + + +constraint: + env [0; + 1; + 2; + 3; + 4; + 5; + 6; + 7; + 8; + 9; + 10; + 11; + 12; + 13; + 14; + 15; + 16; + 17; + 18; + 19; + 20; + 21; + 22] + lhs {VV##18 : (Tuple int int) | [((snd VV##18) = cow##ax4); + ((fst VV##18) = wink##ax3); + ((x_Tuple22 VV##18) = cow##ax4); + ((x_Tuple21 VV##18) = wink##ax3)]} + rhs {VV##18 : (Tuple int int) | [$k_##269[VV##F##18:=VV##18][VV##268:=VV##18][VV##603:=VV##18][VV##F:=VV##18]]} + id 18 tag [1] + // META constraint id 18 : () + + +constraint: + env [0; + 1; + 2; + 3; + 4; + 5; + 6; + 7; + 8; + 9; + 10; + 11; + 12; + 13; + 14; + 15; + 16; + 17; + 28; + 34; + 40; + 42; + 43; + 44; + 45; + 46; + 47] + lhs {VV##3 : int | [(VV##3 = wink##ax3)]} + rhs {VV##3 : int | [$k_##444[VV##571:=VV##3][VV##F:=VV##3][VV##F##3:=VV##3][VV##443:=VV##3]]} + id 3 tag [1] + // META constraint id 3 : () + + +constraint: + env [0; + 1; + 2; + 3; + 4; + 5; + 6; + 7; + 8; + 9; + 10; + 11; + 12; + 13; + 14; + 15; + 16; + 17; + 18; + 19; + 20; + 21; + 22; + 90] + lhs {VV##19 : int | [$k_##297[lq_tmp$x##295:=cow##ax4][VV##605:=VV##19][lq_tmp$x##299:=VV##19][lq_tmp$x##291:=VV##603][VV##F##19:=VV##19][lq_tmp$x##294:=wink##ax3][VV##F:=VV##19][VV##296:=VV##19]]} + rhs {VV##19 : int | [$k_##259[VV##605:=VV##19][VV##268:=VV##603][VV##258:=VV##19][VV##F##19:=VV##19][VV##F:=VV##19]]} + id 19 tag [1] + // META constraint id 19 : () + + +constraint: + env [0; + 1; + 2; + 3; + 4; + 5; + 6; + 7; + 8; + 9; + 10; + 11; + 12; + 13; + 14; + 15; + 16; + 17; + 28; + 34; + 40] + lhs {VV##4 : int | [(VV##4 = cow##ax4)]} + rhs {VV##4 : int | [$k_##432[lq_tmp$x##425:=wink##ax3][VV##431:=VV##4][VV##573:=VV##4][lq_tmp$x##434:=VV##4][VV##F:=VV##4][VV##F##4:=VV##4]]} + id 4 tag [1] + // META constraint id 4 : () + + +constraint: + env [0; + 1; + 2; + 3; + 4; + 5; + 6; + 7; + 8; + 9; + 10; + 11; + 12; + 13; + 14; + 15; + 16; + 17; + 18; + 19; + 20; + 21; + 22; + 90] + lhs {VV##20 : int | [$k_##301[lq_tmp$x##295:=cow##ax4][VV##607:=VV##20][VV##F##20:=VV##20][lq_tmp$x##291:=VV##603][lq_tmp$x##294:=wink##ax3][VV##300:=VV##20][lq_tmp$x##303:=VV##20][VV##F:=VV##20]]} + rhs {VV##20 : int | [$k_##262[VV##268:=VV##603][VV##607:=VV##20][VV##F##20:=VV##20][VV##261:=VV##20][VV##F:=VV##20]]} + id 20 tag [1] + // META constraint id 20 : () + + +constraint: + env [0; + 1; + 2; + 3; + 4; + 5; + 6; + 7; + 8; + 9; + 10; + 11; + 12; + 13; + 14; + 15; + 16; + 17; + 28; + 34; + 40] + lhs {VV##5 : int | [(VV##5 = cow##ax4)]} + rhs {VV##5 : int | [$k_##436[lq_tmp$x##425:=wink##ax3][VV##F##5:=VV##5][VV##573:=VV##5][lq_tmp$x##438:=wink##ax3][lq_tmp$x##434:=VV##5][VV##F:=VV##5][VV##435:=VV##5]]} + id 5 tag [1] + // META constraint id 5 : () + + +constraint: + env [0; + 1; + 2; + 3; + 4; + 5; + 6; + 7; + 8; + 9; + 10; + 11; + 12; + 13; + 14; + 15; + 16; + 17; + 18; + 19; + 20; + 21; + 22; + 90; + 93] + lhs {VV##21 : int | [$k_##305[lq_tmp$x##295:=cow##ax4][lq_tmp$x##290:=lq_tmp$x##264][VV##304:=VV##21][VV##610:=VV##21][lq_tmp$x##307:=lq_tmp$x##264][lq_tmp$x##291:=VV##603][lq_tmp$x##294:=wink##ax3][lq_tmp$x##303:=VV##21][VV##F##21:=VV##21][VV##F:=VV##21]]} + rhs {VV##21 : int | [$k_##266[VV##265:=VV##21][VV##610:=VV##21][VV##268:=VV##603][VV##F##21:=VV##21][VV##F:=VV##21]]} + id 21 tag [1] + // META constraint id 21 : () + + +constraint: + env [0; + 1; + 2; + 3; + 4; + 5; + 6; + 7; + 8; + 9; + 10; + 11; + 12; + 13; + 14; + 15; + 16; + 17; + 28; + 34; + 40] + lhs {VV##6 : int | [(VV##6 = wink##ax3)]} + rhs {VV##6 : int | [$k_##428[VV##F##6:=VV##6][VV##427:=VV##6][lq_tmp$x##430:=VV##6][VV##F:=VV##6][VV##575:=VV##6]]} + id 6 tag [1] + // META constraint id 6 : () + + +constraint: + env [0; + 1; + 2; + 3; + 4; + 5; + 6; + 7; + 8; + 9; + 10; + 11; + 12; + 13; + 14; + 15; + 16; + 17; + 18; + 19; + 20; + 21; + 22] + lhs {VV##22 : int | [(VV##22 = cow##ax4)]} + rhs {VV##22 : int | [$k_##301[VV##F##22:=VV##22][VV##612:=VV##22][lq_tmp$x##294:=wink##ax3][VV##300:=VV##22][lq_tmp$x##303:=VV##22][VV##F:=VV##22]]} + id 22 tag [1] + // META constraint id 22 : () + + +constraint: + env [0; + 1; + 2; + 3; + 4; + 5; + 6; + 7; + 8; + 9; + 10; + 11; + 12; + 13; + 14; + 15; + 16; + 17; + 28; + 34; + 35; + 36; + 37; + 38; + 39] + lhs {VV##7 : int | [(VV##7 = cow##ax4)]} + rhs {VV##7 : int | [$k_##392[VV##391:=VV##7][VV##F##7:=VV##7][VV##F:=VV##7][VV##577:=VV##7]]} + id 7 tag [1] + // META constraint id 7 : () + + +constraint: + env [0; + 1; + 2; + 3; + 4; + 5; + 6; + 7; + 8; + 9; + 10; + 11; + 12; + 13; + 14; + 15; + 16; + 17; + 18; + 19; + 20; + 21; + 22] + lhs {VV##23 : int | [(VV##23 = cow##ax4)]} + rhs {VV##23 : int | [$k_##305[VV##304:=VV##23][lq_tmp$x##307:=wink##ax3][VV##612:=VV##23][lq_tmp$x##294:=wink##ax3][lq_tmp$x##303:=VV##23][VV##F:=VV##23][VV##F##23:=VV##23]]} + id 23 tag [1] + // META constraint id 23 : () + + +constraint: + env [0; + 1; + 2; + 3; + 4; + 5; + 6; + 7; + 8; + 9; + 10; + 11; + 12; + 13; + 14; + 15; + 16; + 17; + 28; + 29; + 30; + 31; + 32; + 33] + lhs {VV##8 : int | [(VV##8 = wink##ax3)]} + rhs {VV##8 : int | [$k_##362[VV##579:=VV##8][VV##F##8:=VV##8][VV##361:=VV##8][VV##F:=VV##8]]} + id 8 tag [1] + // META constraint id 8 : () + + +constraint: + env [0; + 1; + 2; + 3; + 4; + 5; + 6; + 7; + 8; + 9; + 10; + 11; + 12; + 13; + 14; + 15; + 16; + 17; + 18; + 19; + 20; + 21; + 22] + lhs {VV##24 : int | [(VV##24 = wink##ax3)]} + rhs {VV##24 : int | [$k_##297[lq_tmp$x##299:=VV##24][VV##614:=VV##24][VV##F:=VV##24][VV##296:=VV##24][VV##F##24:=VV##24]]} + id 24 tag [1] + // META constraint id 24 : () + + +constraint: + env [0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 13; 14; 15; 16] + lhs {VV##25 : int | [(VV##25 = yog##awz)]} + rhs {VV##25 : int | [$k_##252[VV##251:=VV##25][lq_tmp$x##254:=VV##25][lq_tmp$x##245:=xig##awy][VV##F:=VV##25][VV##616:=VV##25][VV##F##25:=VV##25]]} + id 25 tag [1] + // META constraint id 25 : () + + +constraint: + env [0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 13; 14; 15; 16] + lhs {VV##26 : int | [(VV##26 = xig##awy)]} + rhs {VV##26 : int | [$k_##248[VV##618:=VV##26][VV##247:=VV##26][VV##F##26:=VV##26][VV##F:=VV##26][lq_tmp$x##250:=VV##26]]} + id 26 tag [1] + // META constraint id 26 : () + + + + +wf: + env [0; + 1; + 2; + 3; + 4; + 5; + 6; + 7; + 8; + 9; + 10; + 11; + 12; + 13; + 14; + 15; + 16; + 17; + 18; + 24; + 25; + 26; + 115] + reft {VV##329 : int | [$k_##330]} + // META wf : () + + +wf: + env [0; + 1; + 2; + 3; + 4; + 5; + 6; + 7; + 8; + 9; + 10; + 11; + 12; + 13; + 14; + 15; + 16; + 17; + 18; + 24; + 25] + reft {VV##318 : GHC.Prim.Void# | [$k_##319]} + // META wf : () + + +wf: + env [0; + 1; + 2; + 3; + 4; + 5; + 6; + 7; + 8; + 9; + 10; + 11; + 12; + 13; + 14; + 15; + 16; + 17; + 18; + 24; + 25; + 26; + 27; + 107] + reft {VV##343 : int | [$k_##344]} + // META wf : () + + +wf: + env [0; + 1; + 2; + 3; + 4; + 5; + 6; + 7; + 8; + 9; + 10; + 11; + 12; + 13; + 14; + 15; + 16; + 17; + 28; + 34; + 40] + reft {VV##427 : int | [$k_##428]} + // META wf : () + + +wf: + env [0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 13; 14; 15; 16] + reft {VV##247 : int | [$k_##248]} + // META wf : () + + +wf: + env [0; + 1; + 2; + 3; + 4; + 5; + 6; + 7; + 8; + 9; + 10; + 11; + 12; + 13; + 14; + 15; + 16; + 17; + 28; + 34; + 40; + 41] + reft {VV##435 : int | [$k_##436]} + // META wf : () + + +wf: + env [0; + 1; + 2; + 3; + 4; + 5; + 6; + 7; + 8; + 9; + 10; + 11; + 12; + 13; + 14; + 15; + 16; + 17; + 28; + 34; + 40; + 42] + reft {VV##443 : int | [$k_##444]} + // META wf : () + + +wf: + env [0; + 1; + 2; + 3; + 4; + 5; + 6; + 7; + 8; + 9; + 10; + 11; + 12; + 13; + 14; + 15; + 16; + 17; + 18; + 19; + 20; + 21; + 22] + reft {VV##296 : int | [$k_##297]} + // META wf : () + + +wf: + env [0; + 1; + 2; + 3; + 4; + 5; + 6; + 7; + 8; + 9; + 10; + 11; + 12; + 13; + 14; + 15; + 16; + 17; + 18; + 24; + 25; + 26; + 27; + 110] + reft {VV##347 : int | [$k_##348]} + // META wf : () + + +wf: + env [0; + 1; + 2; + 3; + 4; + 5; + 6; + 7; + 8; + 9; + 10; + 11; + 12; + 13; + 14; + 15; + 16; + 17; + 28; + 34; + 40; + 42; + 48] + reft {VV##473 : int | [$k_##474]} + // META wf : () + + +wf: + env [0; + 1; + 2; + 3; + 4; + 5; + 6; + 7; + 8; + 9; + 10; + 11; + 12; + 13; + 14; + 15; + 16; + 17; + 18; + 24; + 25; + 26; + 27] + reft {VV##350 : (Tuple int int) | [$k_##351]} + // META wf : () + + +wf: + env [0; + 1; + 2; + 3; + 4; + 5; + 6; + 7; + 8; + 9; + 10; + 11; + 12; + 13; + 14; + 15; + 16; + 17; + 28; + 34] + reft {VV##391 : int | [$k_##392]} + // META wf : () + + +wf: + env [0; + 1; + 2; + 3; + 4; + 5; + 6; + 7; + 8; + 9; + 10; + 11; + 12; + 13; + 14; + 15; + 16; + 17; + 18; + 24; + 25; + 26] + reft {VV##332 : (Tuple int int) | [$k_##333]} + // META wf : () + + +wf: + env [0; + 1; + 2; + 3; + 4; + 5; + 6; + 7; + 8; + 9; + 10; + 11; + 12; + 13; + 14; + 15; + 16; + 17; + 120] + reft {VV##258 : int | [$k_##259]} + // META wf : () + + +wf: + env [0; + 1; + 2; + 3; + 4; + 5; + 6; + 7; + 8; + 9; + 10; + 11; + 12; + 13; + 14; + 15; + 16; + 17; + 120] + reft {VV##261 : int | [$k_##262]} + // META wf : () + + +wf: + env [0; + 1; + 2; + 3; + 4; + 5; + 6; + 7; + 8; + 9; + 10; + 11; + 12; + 13; + 14; + 15; + 16; + 17; + 18; + 24; + 25; + 26; + 27; + 107] + reft {VV##340 : int | [$k_##341]} + // META wf : () + + +wf: + env [0; + 1; + 2; + 3; + 4; + 5; + 6; + 7; + 8; + 9; + 10; + 11; + 12; + 13; + 14; + 15; + 16; + 17; + 18; + 19; + 20; + 21; + 22; + 23] + reft {VV##304 : int | [$k_##305]} + // META wf : () + + +wf: + env [0; + 1; + 2; + 3; + 4; + 5; + 6; + 7; + 8; + 9; + 10; + 11; + 12; + 13; + 14; + 15; + 16; + 17; + 18; + 24; + 25; + 26; + 112] + reft {VV##325 : int | [$k_##326]} + // META wf : () + + +wf: + env [0; + 1; + 2; + 3; + 4; + 5; + 6; + 7; + 8; + 9; + 10; + 11; + 12; + 13; + 14; + 15; + 16; + 17; + 28] + reft {VV##361 : int | [$k_##362]} + // META wf : () + + +wf: + env [0; + 1; + 2; + 3; + 4; + 5; + 6; + 7; + 8; + 9; + 10; + 11; + 12; + 13; + 14; + 15; + 16; + 17; + 123] + reft {VV##265 : int | [$k_##266]} + // META wf : () + + +wf: + env [0; + 1; + 2; + 3; + 4; + 5; + 6; + 7; + 8; + 9; + 10; + 11; + 12; + 13; + 14; + 15; + 16; + 17; + 18; + 24; + 25; + 26; + 112] + reft {VV##322 : int | [$k_##323]} + // META wf : () + + +wf: + env [0; + 1; + 2; + 3; + 4; + 5; + 6; + 7; + 8; + 9; + 10; + 11; + 12; + 13; + 14; + 15; + 16; + 17; + 18; + 19; + 20; + 21; + 22] + reft {VV##300 : int | [$k_##301]} + // META wf : () + + +wf: + env [0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 13; 14; 15; 16; 17] + reft {VV##268 : (Tuple int int) | [$k_##269]} + // META wf : () + + +wf: + env [0; + 1; + 2; + 3; + 4; + 5; + 6; + 7; + 8; + 9; + 10; + 11; + 12; + 13; + 14; + 15; + 16; + 17; + 28; + 34; + 40] + reft {VV##431 : int | [$k_##432]} + // META wf : () + + +wf: + env [0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 13; 14; 15; 16] + reft {VV##251 : int | [$k_##252]} + // META wf : () diff --git a/tests/pos/float.fq b/tests/pos/float.fq new file mode 100644 --- /dev/null +++ b/tests/pos/float.fq @@ -0,0 +1,11 @@ +// adapted from LH test Propability.hs + +bind 50 x : {v1 : real | [(v1 = 0.2)]} +bind 56 y : {v2 : real | [(v2 = 0.8 + x)]} + +constraint: + env [50; + 56] + lhs {VV#F3 : int | []} + rhs {VV#F3 : int | [(y = 1.0)]} + id 3 tag [1] diff --git a/tests/pos/func00.fq b/tests/pos/func00.fq new file mode 100644 --- /dev/null +++ b/tests/pos/func00.fq @@ -0,0 +1,9 @@ + +bind 0 f : {v: func(0, [int; int]) | []} + +constraint: + env [ ] + lhs {v : int | [f = f]} + rhs {v : int | [0 < 7]} + id 1 tag [] + diff --git a/tests/pos/len00-rename.fq b/tests/pos/len00-rename.fq new file mode 100644 --- /dev/null +++ b/tests/pos/len00-rename.fq @@ -0,0 +1,24 @@ + +// This qualifier saves the day; solve constraints WITHOUT IT + +qualif ListZ(v : [@(0)]): (len v >= 0) + +constant len : (func(2, [(@(0) @(1)); int])) + +bind 0 y : {v : [(Tuple int a)] | [len v >= 0]} + +constraint: + env [0] + lhs {v1 : [(Tuple int a)] | [v1 = y] } + rhs {v1 : [(Tuple int a)] | [$k0[v0 := v1]] } + id 1 tag [] + +constraint: + env [] + lhs {v2 : [(Tuple int a)] | [$k0[v0 := v2]] } + rhs {v2 : [(Tuple int a)] | [len v2 >= 0] } + id 2 tag [] + +wf: + env [ ] + reft {v0 : [(Tuple int a)] | [$k0] } diff --git a/tests/pos/len00.fq b/tests/pos/len00.fq new file mode 100644 --- /dev/null +++ b/tests/pos/len00.fq @@ -0,0 +1,24 @@ + +// This qualifier saves the day; solve constraints WITHOUT IT + +qualif ListZ(v : [@(0)]): (len v >= 0) + +constant len : (func(2, [(@(0) @(1)); int])) + +bind 0 y : {v : [(Tuple int a)] | [len v >= 0]} + +constraint: + env [0] + lhs {v : [(Tuple int a)] | [v = y] } + rhs {v : [(Tuple int a)] | [$k0] } + id 1 tag [] + +constraint: + env [] + lhs {v : [(Tuple int a)] | [$k0] } + rhs {v : [(Tuple int a)] | [len v >= 0] } + id 2 tag [] + +wf: + env [ ] + reft {v : [(Tuple int a)] | [$k0] } diff --git a/tests/pos/literals.fq b/tests/pos/literals.fq new file mode 100644 --- /dev/null +++ b/tests/pos/literals.fq @@ -0,0 +1,10 @@ +//adapted from LH test Strings.hs + +constant lit#bar : (Str) +constant lit#foo : (Str) + +constraint: + env [] + lhs {VV#F1 : int | []} + rhs {VV#F1 : int | [(lit#bar != lit#foo)]} + id 1 tag [6] diff --git a/tests/pos/multiple-func-sorts.fq b/tests/pos/multiple-func-sorts.fq new file mode 100644 --- /dev/null +++ b/tests/pos/multiple-func-sorts.fq @@ -0,0 +1,5 @@ +// adapted from LH test vector2.hs + +constant foo : (func(1, [@(0); @(0)])) + +bind 6 foo : {VV : func(1, [@(0); @(0)]) | []} diff --git a/tests/pos/num00.fq b/tests/pos/num00.fq new file mode 100644 --- /dev/null +++ b/tests/pos/num00.fq @@ -0,0 +1,22 @@ +// This qualifier saves the day; solve constraints WITHOUT IT + +qualif Zog(v:a) : (0 <= v) + +bind 0 alpha : {v : num | true} + +constraint: + env [0] + lhs {v : alpha | (v = 10)} + rhs {v : alpha | $k0} + id 1 tag [] + +constraint: + env [0] + lhs {v : alpha | $k0} + rhs {v : alpha | 0 <= v} + id 2 tag [] + +wf: + env [0] + reft {v: alpha | $k0} + diff --git a/tests/pos/overwrite-names.fq b/tests/pos/overwrite-names.fq --- a/tests/pos/overwrite-names.fq +++ b/tests/pos/overwrite-names.fq @@ -2,7 +2,6 @@ constraint: env [] - grd true lhs {VV#F1 : int | [(VV#F1 > 10)]} rhs {VV#F1 : int | [(VV#F1 > 10)]} id 1 tag [1] diff --git a/tests/pos/poly0.fq b/tests/pos/poly0.fq new file mode 100644 --- /dev/null +++ b/tests/pos/poly0.fq @@ -0,0 +1,14 @@ + +// This definition works fine ... +// constant offset : (func(0, [int ; int ; (BitVec Size32) ])) + +// But this crashes as 'offset 0' is embedded as int not bv... +constant offset : (func(1, [int; int; @(0)])) + +bind 0 x : {VV : (BitVec Size32) | [ VV = offset 0 0 ]} + +constraint: + env [0] + lhs {VV : (BitVec Size32) | [ VV = x ] } + rhs {VV : (BitVec Size32) | [ VV = x ] } + id 1 tag [1] diff --git a/tests/pos/poly1.fq b/tests/pos/poly1.fq new file mode 100644 --- /dev/null +++ b/tests/pos/poly1.fq @@ -0,0 +1,16 @@ + +// This definition works fine ... +// constant offset : (func(2, [int ; (BitVec Size32) ])) + +// But this crashes as 'offset 0' is embedded as int not bv... +constant offset : (func(2, [int; @(0)])) + +bind 0 x : {VV : (BitVec Size32) | [ VV = offset 0 ]} + +constraint: + env [0] + lhs {VV : (BitVec Size32) | [ VV = x ] } + rhs {VV : (BitVec Size32) | [ VV = x ] } + id 1 tag [1] + + diff --git a/tests/pos/poly2.fq b/tests/pos/poly2.fq new file mode 100644 --- /dev/null +++ b/tests/pos/poly2.fq @@ -0,0 +1,14 @@ + +// This definition works fine ... +// constant offset : (func(0, [int ; int ; (BitVec Size32) ])) + +// But this crashes as 'offset 0' is embedded as int not bv... +constant offset : (func(2, [@(0); int; int; @(0); @(1)])) + +bind 0 x : {VV : (BitVec Size32) | [ VV = offset 0 0 0 0 ]} + +constraint: + env [0] + lhs {VV : (BitVec Size32) | [ VV = x ] } + rhs {VV : (BitVec Size32) | [ VV = x ] } + id 1 tag [1] diff --git a/tests/pos/qualif-inst.fq b/tests/pos/qualif-inst.fq new file mode 100644 --- /dev/null +++ b/tests/pos/qualif-inst.fq @@ -0,0 +1,17 @@ +// adapted from LH test eqelems.hs + +qualif Cmp(v : @(0), fix##126#X : @(0)): (v >= fix##126#X) + +constant elems : (func(1, [(Goo.T @(0)); (Set_Set @(0))])) + +bind 48 lq_anf__d14V : {lq_tmp_x_197 : (Set_Set a_a14x) | [(lq_tmp_x_197 = elems([s#a149]))]} + +constraint: + env [] + lhs {VV#F4 : (Set_Set a_a14x) | []} + rhs {VV#F4 : (Set_Set a_a14x) | [$k__226[VV#225:=VV#F4]]} + id 4 tag [2] + +wf: + env [48] + reft {VV#225 : (Set_Set a_a14x) | [$k__226]} diff --git a/tests/pos/sets.fq b/tests/pos/sets.fq new file mode 100644 --- /dev/null +++ b/tests/pos/sets.fq @@ -0,0 +1,7 @@ +// constant Set_empty : (func(1, [int; Set_Set @(0)])) + +constraint: + env [] + lhs {v : Set_Set a_aTp | [(? Set_emp([v]))]} + rhs {v : Set_Set a_aTp | [(v = Set_empty([0]))]} + id 3 tag [2] diff --git a/tests/pos/test00-par.fq b/tests/pos/test00-par.fq new file mode 100644 --- /dev/null +++ b/tests/pos/test00-par.fq @@ -0,0 +1,37 @@ + +constraint: + env [ ] + lhs {v : int | [v = 10]} + rhs {v : int | [v > 0]} + id 1 tag [] + +constraint: + env [ ] + lhs {v : int | [v = 20]} + rhs {v : int | [v > 0]} + id 2 tag [] + +constraint: + env [ ] + lhs {v : int | [v = 20]} + rhs {v : int | [v > 0]} + id 3 tag [] + +constraint: + env [ ] + lhs {v : int | [v = 10]} + rhs {v : int | [v > 0]} + id 4 tag [] + +constraint: + env [ ] + lhs {v : int | [v = 20]} + rhs {v : int | [v > 0]} + id 5 tag [] + +constraint: + env [ ] + lhs {v : int | [v = 20]} + rhs {v : int | [v > 0]} + id 6 tag [] + diff --git a/tests/pos/test00.fq b/tests/pos/test00.fq --- a/tests/pos/test00.fq +++ b/tests/pos/test00.fq @@ -1,31 +1,26 @@ - qualif Zog(v:a) : (10 <= v) qualif Bog(v:a, x:a) : (x <= v) -bind 0 a : {v: int | [$k0]} +bind 0 a : {v: int | $k0} constraint: env [ ] - grd true - lhs {v : int | [v = 10]} - rhs {v : int | [$k0]} - id 1 + lhs {v : int | v = 10} + rhs {v : int | $k0} + id 1 tag [] constraint: env [ ] - grd true - lhs {v : int | [v = 20]} - rhs {v : int | [$k0]} - id 2 + lhs {v : int | v = 20} + rhs {v : int | $k0} + id 2 tag [] constraint: - env [ 0 - ] - grd true - lhs {v : int | [v = a]} - rhs {v : int | [10 <= v]} - id 3 + env [ 0 ] + lhs {v : int | v = a} + rhs {v : int | 10 <= v} + id 3 tag [] wf: env [ ] - reft {v: int | [$k0]} + reft {v: int | $k0} diff --git a/tests/pos/test00a.fq b/tests/pos/test00a.fq --- a/tests/pos/test00a.fq +++ b/tests/pos/test00a.fq @@ -1,5 +1,4 @@ // This qualifier saves the day; solve constraints WITHOUT IT - qualif Zog(v:a) : (10 <= v) bind 0 x : {v : int | true} @@ -8,26 +7,22 @@ constraint: env [0] - grd true lhs {v : int | (x = 10)} rhs {v : int | $k0[v:=x]} - id 1 + id 1 tag [] constraint: env [1] - grd true lhs {v : int | y = 20} rhs {v : int | $k0[v:=y]} - id 2 + id 2 tag [] constraint: env [2] - grd true lhs {v : int | $k0[v:=z]} rhs {v : int | 10 <= z} - id 3 + id 3 tag [] wf: env [ ] reft {v: int | $k0} - diff --git a/tests/pos/test1.fq b/tests/pos/test1.fq --- a/tests/pos/test1.fq +++ b/tests/pos/test1.fq @@ -8,24 +8,21 @@ constraint: env [0] - grd true lhs {v : int | v = x} rhs {v : int | $k0 } - id 1 + id 1 tag [] constraint: env [1] - grd true lhs {v : int | v = y} rhs {v : int | $k0 } - id 2 + id 2 tag [] constraint: env [2] - grd true lhs {v : int | v = a } rhs {v : int | 10 <= v} - id 3 + id 3 tag [] wf: env [ ] diff --git a/tests/pos/test2.fq b/tests/pos/test2.fq --- a/tests/pos/test2.fq +++ b/tests/pos/test2.fq @@ -13,39 +13,34 @@ constraint: env [ ] - grd true lhs {v : int | v = 0} rhs {v : int | $k1 } - id 0 + id 0 tag [] constraint: - env [ 0; 1] - grd true + env [0; 1] lhs {v : int | v = x + a} rhs {v : int | $k0} - id 1 + id 1 tag [] constraint: env [2; 3] - grd true lhs {v : int | v = y + b} rhs {v : int | $k0} - id 2 + id 2 tag [] constraint: env [ ] - grd true lhs {v : int | $k0} rhs {v : int | $k1} - id 3 + id 3 tag [] constraint: env [4] - grd true lhs {v : int | v = c } rhs {v : int | 10 <= v} - id 4 + id 4 tag [] wf: env [ ] diff --git a/tests/pos/test3.fq b/tests/pos/test3.fq --- a/tests/pos/test3.fq +++ b/tests/pos/test3.fq @@ -7,17 +7,15 @@ constraint: env [1] - grd true lhs {v : int | v = q} rhs {v : int | $k0[x:=q] } - id 1 + id 1 tag [] constraint: env [2] - grd true lhs {v : int | $k0[x:=y]} rhs {v : int | v = 10} - id 2 + id 2 tag [] wf: env [0] diff --git a/tests/pos/test4.fq b/tests/pos/test4.fq new file mode 100644 --- /dev/null +++ b/tests/pos/test4.fq @@ -0,0 +1,19 @@ +qualif Auto(v_2 : a_ax6, A0 : a_ax6): (v_2 = A0) + +bind 20 ds_dxx : {VV263 : a_ax6 | []} + +constraint: + env [20] + lhs {VVF4 : a_ax6 | [$k__511[VV510:=VVF4]]} + rhs {VVF4 : a_ax6 | [(VVF4 = ds_dxx)]} + id 4 tag [3] + +constraint: + env [20] + lhs {VVF9 : a_ax6 | [(VVF9 = ds_dxx)]} + rhs {VVF9 : a_ax6 | [$k__511[VV510:=VVF9]]} + id 9 tag [3] + +wf: + env [20] + reft {VV510 : a_ax6 | [$k__511]} diff --git a/tests/pos/wl00.fq b/tests/pos/wl00.fq new file mode 100644 --- /dev/null +++ b/tests/pos/wl00.fq @@ -0,0 +1,50 @@ +qualif Nat(v:int) : (0 <= v) +qualif N10(v:int) : (10 = v) +qualif N20(v:int) : (20 = v) + +bind 0 x0 : {v: int | [$k0]} + +bind 1 x1 : {v: int | [$k1]} + +cut $k0 + +constraint: + env [ ] + lhs {v : int | [v = 10]} + rhs {v : int | [$k0]} + id 1 tag [0] + +constraint: + env [ ] + lhs {v : int | [v = 20]} + rhs {v : int | [$k0]} + id 2 tag [0] + +constraint: + env [ 0 ] + lhs {v : int | [v = x0 + 7]} + rhs {v : int | [$k1]} + id 3 tag [0] + + +constraint: + env [ 1 ] + lhs {v : int | [v = x1 + 9]} + rhs {v : int | [$k0]} + id 4 tag [0] + + +constraint: + env [ 1 ] + lhs {v : int | [v = x1]} + rhs {v : int | [0 <= v]} + id 5 tag [0] + +wf: + env [ ] + reft {v: int | [$k0]} + + +wf: + env [ ] + reft {v: int | [$k1]} diff --git a/tests/pos/wl01.fq b/tests/pos/wl01.fq new file mode 100644 --- /dev/null +++ b/tests/pos/wl01.fq @@ -0,0 +1,39 @@ +qualif Nat(v:int) : (0 <= v) + +bind 0 x : {v: int | [$k0]} +bind 1 y : {v: int | [$k0]} +bind 2 z : {v: int | [$k1]} + +constraint: + env [ ] + lhs {v : int | [v = 10]} + rhs {v : int | [$k0]} + id 1 tag [0] + +constraint: + env [ 0 ] + lhs {v : int | [v = x + x]} + rhs {v : int | [$k0]} + id 2 tag [0] + +constraint: + env [ 0; 1 ] + lhs {v : int | [v = x + y ]} + rhs {v : int | [$k1]} + id 3 tag [0] + + +constraint: + env [ 2 ] + lhs {v : int | [v = z]} + rhs {v : int | [0 <= v]} + id 4 tag [0] + +wf: + env [ ] + reft {v: int | [$k0]} + + +wf: + env [ ] + reft {v: int | [$k1]} diff --git a/tests/pos/wrong-arity.fq b/tests/pos/wrong-arity.fq new file mode 100644 --- /dev/null +++ b/tests/pos/wrong-arity.fq @@ -0,0 +1,16 @@ +// adapted from LH test vector2.hs + +constant foo : func(0, [int; int]) + +// UNCOMMENT THIS FOR CRASH +bind 1 foo : {v: func(0, [int; int]) | true } + +bind 2 foo : {v: func(0, [int; int]) | true } + +bind 3 z : {v : int | [ v = foo 42 ]} + +constraint: + env [3] + lhs {VV : int | [(VV >= 0)]} + rhs {VV : int | [(VV >= 0)]} + id 107 tag [1] diff --git a/tests/test.hs b/tests/test.hs --- a/tests/test.hs +++ b/tests/test.hs @@ -7,6 +7,7 @@ import System.Directory import System.Exit import System.FilePath +import System.Environment import System.IO import System.IO.Error import System.Process @@ -48,7 +49,7 @@ assertEqual "" True True else do createDirectoryIfMissing True $ takeDirectory log - bin <- canonicalizePath "dist/build/fixpoint/fixpoint" + bin <- binPath "fixpoint" withFile log WriteMode $ \h -> do let cmd = testCmd bin dir file (_,_,_,ph) <- createProcess $ (shell cmd) {std_out = UseHandle h, std_err = UseHandle h} @@ -58,15 +59,19 @@ test = dir file log = let (d,f) = splitFileName file in dir d ".liquid" f <.> "log" +binPath pkgName = do + testPath <- getExecutablePath + return $ (takeDirectory $ takeDirectory testPath) pkgName pkgName + knownToFail = [] --------------------------------------------------------------------------- type TestCmd = FilePath -> FilePath -> FilePath -> String nativeCmd :: TestCmd -nativeCmd bin dir file = printf "cd %s && %s -n %s" dir bin file +nativeCmd bin dir file = printf "cd %s && %s %s" dir bin file elimCmd :: TestCmd -elimCmd bin dir file = printf "cd %s && %s -n -e %s" dir bin file +elimCmd bin dir file = printf "cd %s && %s --eliminate %s" dir bin file