liquid-fixpoint 0.4.0.0 → 0.5.0.0
raw patch · 253 files changed
+10371/−52639 lines, 253 filesdep +ascii-progressdep +asyncdep +binarysetup-changedPVP ok
version bump matches the API change (PVP)
Dependencies added: ascii-progress, async, binary, boxes, cereal, dotgen, fgl, fgl-visualize, located-base, parallel
API changes (from Hackage documentation)
- Language.Fixpoint.Bitvector: Bv :: BvSize -> String -> Bv
- Language.Fixpoint.Bitvector: BvAnd :: BvOp
- Language.Fixpoint.Bitvector: BvOr :: BvOp
- Language.Fixpoint.Bitvector: S32 :: BvSize
- Language.Fixpoint.Bitvector: S64 :: BvSize
- Language.Fixpoint.Bitvector: bvTyCon :: FTycon
- Language.Fixpoint.Bitvector: data Bv
- Language.Fixpoint.Bitvector: data BvOp
- Language.Fixpoint.Bitvector: data BvSize
- Language.Fixpoint.Bitvector: eOp :: BvOp -> [Expr] -> Expr
- Language.Fixpoint.Bitvector: instance Constructor C1_0BvOp
- Language.Fixpoint.Bitvector: instance Constructor C1_0BvSize
- Language.Fixpoint.Bitvector: instance Constructor C1_1BvOp
- Language.Fixpoint.Bitvector: instance Constructor C1_1BvSize
- Language.Fixpoint.Bitvector: instance Data BvOp
- Language.Fixpoint.Bitvector: instance Data BvSize
- Language.Fixpoint.Bitvector: instance Datatype D1BvOp
- Language.Fixpoint.Bitvector: instance Datatype D1BvSize
- Language.Fixpoint.Bitvector: instance Eq BvOp
- Language.Fixpoint.Bitvector: instance Eq BvSize
- Language.Fixpoint.Bitvector: instance Expression Bv
- Language.Fixpoint.Bitvector: instance Generic BvOp
- Language.Fixpoint.Bitvector: instance Generic BvSize
- Language.Fixpoint.Bitvector: instance Ord BvOp
- Language.Fixpoint.Bitvector: instance Ord BvSize
- Language.Fixpoint.Bitvector: instance Show BvOp
- Language.Fixpoint.Bitvector: instance Show BvSize
- Language.Fixpoint.Bitvector: instance Typeable BvOp
- Language.Fixpoint.Bitvector: instance Typeable BvSize
- Language.Fixpoint.Bitvector: mkSort :: BvSize -> Sort
- Language.Fixpoint.Config: Config :: FilePath -> FilePath -> FilePath -> SMTSolver -> GenQualifierSort -> UeqAllSorts -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Config
- Language.Fixpoint.Config: Cvc4 :: SMTSolver
- Language.Fixpoint.Config: GQS :: Bool -> GenQualifierSort
- Language.Fixpoint.Config: Mathsat :: SMTSolver
- Language.Fixpoint.Config: UAS :: Bool -> UeqAllSorts
- Language.Fixpoint.Config: Z3 :: SMTSolver
- Language.Fixpoint.Config: Z3mem :: SMTSolver
- Language.Fixpoint.Config: class Command a
- Language.Fixpoint.Config: command :: Command a => a -> String
- Language.Fixpoint.Config: data Config
- Language.Fixpoint.Config: data SMTSolver
- Language.Fixpoint.Config: eliminate :: Config -> Bool
- Language.Fixpoint.Config: genSorts :: Config -> GenQualifierSort
- Language.Fixpoint.Config: getOpts :: IO Config
- Language.Fixpoint.Config: inFile :: Config -> FilePath
- Language.Fixpoint.Config: instance Command Config
- Language.Fixpoint.Config: instance Command GenQualifierSort
- Language.Fixpoint.Config: instance Command SMTSolver
- Language.Fixpoint.Config: instance Command UeqAllSorts
- Language.Fixpoint.Config: instance Data Config
- Language.Fixpoint.Config: instance Data GenQualifierSort
- Language.Fixpoint.Config: instance Data SMTSolver
- Language.Fixpoint.Config: instance Data UeqAllSorts
- Language.Fixpoint.Config: instance Default Config
- Language.Fixpoint.Config: instance Default GenQualifierSort
- Language.Fixpoint.Config: instance Default SMTSolver
- Language.Fixpoint.Config: instance Default UeqAllSorts
- Language.Fixpoint.Config: instance Eq Config
- Language.Fixpoint.Config: instance Eq GenQualifierSort
- Language.Fixpoint.Config: instance Eq SMTSolver
- Language.Fixpoint.Config: instance Eq UeqAllSorts
- Language.Fixpoint.Config: instance Show Config
- Language.Fixpoint.Config: instance Show GenQualifierSort
- Language.Fixpoint.Config: instance Show SMTSolver
- Language.Fixpoint.Config: instance Show UeqAllSorts
- Language.Fixpoint.Config: instance Typeable Config
- Language.Fixpoint.Config: instance Typeable GenQualifierSort
- Language.Fixpoint.Config: instance Typeable SMTSolver
- Language.Fixpoint.Config: instance Typeable UeqAllSorts
- Language.Fixpoint.Config: metadata :: Config -> Bool
- Language.Fixpoint.Config: native :: Config -> Bool
- Language.Fixpoint.Config: newtype GenQualifierSort
- Language.Fixpoint.Config: newtype UeqAllSorts
- Language.Fixpoint.Config: outFile :: Config -> FilePath
- Language.Fixpoint.Config: parts :: Config -> Bool
- Language.Fixpoint.Config: real :: Config -> Bool
- Language.Fixpoint.Config: solver :: Config -> SMTSolver
- Language.Fixpoint.Config: srcFile :: Config -> FilePath
- Language.Fixpoint.Config: stats :: Config -> Bool
- Language.Fixpoint.Config: ueqAllSorts :: Config -> UeqAllSorts
- Language.Fixpoint.Config: withTarget :: Config -> FilePath -> Config
- Language.Fixpoint.Errors: SS :: !SourcePos -> !SourcePos -> SrcSpan
- Language.Fixpoint.Errors: catError :: Error -> Error -> Error
- Language.Fixpoint.Errors: catMessage :: Error -> String -> Error
- Language.Fixpoint.Errors: data Error
- Language.Fixpoint.Errors: data SrcSpan
- Language.Fixpoint.Errors: die :: Error -> a
- Language.Fixpoint.Errors: dummySpan :: SrcSpan
- Language.Fixpoint.Errors: err :: SrcSpan -> String -> Error
- Language.Fixpoint.Errors: errLoc :: Error -> SrcSpan
- Language.Fixpoint.Errors: errMsg :: Error -> String
- Language.Fixpoint.Errors: exit :: a -> IO a -> IO a
- Language.Fixpoint.Errors: instance Constructor C1_0Error
- Language.Fixpoint.Errors: instance Constructor C1_0SrcSpan
- Language.Fixpoint.Errors: instance Data Error
- Language.Fixpoint.Errors: instance Data SrcSpan
- Language.Fixpoint.Errors: instance Datatype D1Error
- Language.Fixpoint.Errors: instance Datatype D1SrcSpan
- Language.Fixpoint.Errors: instance Eq Error
- Language.Fixpoint.Errors: instance Eq SrcSpan
- Language.Fixpoint.Errors: instance Error Error
- Language.Fixpoint.Errors: instance Exception Error
- Language.Fixpoint.Errors: instance Fixpoint Error
- Language.Fixpoint.Errors: instance Generic Error
- Language.Fixpoint.Errors: instance Generic SrcSpan
- Language.Fixpoint.Errors: instance Hashable SourcePos
- Language.Fixpoint.Errors: instance Hashable SrcSpan
- Language.Fixpoint.Errors: instance Ord Error
- Language.Fixpoint.Errors: instance Ord SrcSpan
- Language.Fixpoint.Errors: instance PPrint Error
- Language.Fixpoint.Errors: instance PPrint SrcSpan
- Language.Fixpoint.Errors: instance Selector S1_0_0Error
- Language.Fixpoint.Errors: instance Selector S1_0_0SrcSpan
- Language.Fixpoint.Errors: instance Selector S1_0_1Error
- Language.Fixpoint.Errors: instance Selector S1_0_1SrcSpan
- Language.Fixpoint.Errors: instance Show Error
- Language.Fixpoint.Errors: instance Show SrcSpan
- Language.Fixpoint.Errors: instance Typeable Error
- Language.Fixpoint.Errors: instance Typeable SrcSpan
- Language.Fixpoint.Errors: sourcePosElts :: SourcePos -> (SourceName, Line, Column)
- Language.Fixpoint.Errors: sp_start :: SrcSpan -> !SourcePos
- Language.Fixpoint.Errors: sp_stop :: SrcSpan -> !SourcePos
- Language.Fixpoint.Files: Annot :: Ext
- Language.Fixpoint.Files: Cache :: Ext
- Language.Fixpoint.Files: Cgi :: Ext
- Language.Fixpoint.Files: Cst :: Ext
- Language.Fixpoint.Files: Dat :: Ext
- Language.Fixpoint.Files: Dot :: Ext
- Language.Fixpoint.Files: Fq :: Ext
- Language.Fixpoint.Files: Hquals :: Ext
- Language.Fixpoint.Files: Hs :: Ext
- Language.Fixpoint.Files: Html :: Ext
- Language.Fixpoint.Files: Js :: Ext
- Language.Fixpoint.Files: Json :: Ext
- Language.Fixpoint.Files: LHs :: Ext
- Language.Fixpoint.Files: Mkdn :: Ext
- Language.Fixpoint.Files: Out :: Ext
- Language.Fixpoint.Files: PAss :: Ext
- Language.Fixpoint.Files: Part :: Int -> Ext
- Language.Fixpoint.Files: Pred :: Ext
- Language.Fixpoint.Files: Result :: Ext
- Language.Fixpoint.Files: Saved :: Ext
- Language.Fixpoint.Files: Smt2 :: Ext
- Language.Fixpoint.Files: Spec :: Ext
- Language.Fixpoint.Files: Ts :: Ext
- Language.Fixpoint.Files: Vim :: Ext
- Language.Fixpoint.Files: copyFiles :: [FilePath] -> FilePath -> IO ()
- Language.Fixpoint.Files: data Ext
- Language.Fixpoint.Files: extFileName :: Ext -> FilePath -> FilePath
- Language.Fixpoint.Files: extFileNameR :: Ext -> FilePath -> FilePath
- Language.Fixpoint.Files: extModuleName :: String -> Ext -> FilePath
- Language.Fixpoint.Files: getFileInDirs :: FilePath -> [FilePath] -> IO (Maybe FilePath)
- Language.Fixpoint.Files: getFixpointPath :: IO FilePath
- Language.Fixpoint.Files: getZ3LibPath :: IO FilePath
- Language.Fixpoint.Files: instance Eq Ext
- Language.Fixpoint.Files: instance Ord Ext
- Language.Fixpoint.Files: instance Show Ext
- Language.Fixpoint.Files: isExtFile :: Ext -> FilePath -> Bool
- Language.Fixpoint.Files: tempDirectory :: FilePath -> FilePath
- Language.Fixpoint.Files: withExt :: FilePath -> Ext -> FilePath
- Language.Fixpoint.Interface: FI :: HashMap Integer (SubC a) -> ![WfC a] -> !BindEnv -> !FEnv -> ![(Symbol, Sort)] -> Kuts -> ![Qualifier] -> HashMap BindId a -> FInfo a
- Language.Fixpoint.Interface: data FInfo a
- Language.Fixpoint.Interface: parseFInfo :: [FilePath] -> IO (FInfo a)
- Language.Fixpoint.Interface: resultExit :: FixResult a -> ExitCode
- Language.Fixpoint.Interface: solve :: Fixpoint a => Config -> FInfo a -> IO (Result a)
- Language.Fixpoint.Interface: solveFQ :: Config -> IO ExitCode
- Language.Fixpoint.Misc: (<$$>) :: (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b)
- Language.Fixpoint.Misc: (=>>) :: Monad m => m b -> (b -> m a) -> m b
- Language.Fixpoint.Misc: Emp :: Empty
- Language.Fixpoint.Misc: angleBrackets :: Doc -> Doc
- Language.Fixpoint.Misc: assertstar :: [Char] -> Bool -> c -> c
- Language.Fixpoint.Misc: bchopAlts :: [(ByteString, ByteString)] -> ByteString -> [ByteString]
- Language.Fixpoint.Misc: boxStrCat :: String -> [String] -> String
- Language.Fixpoint.Misc: checkExitCode :: Monad m => [Char] -> ExitCode -> m ()
- Language.Fixpoint.Misc: checkFail :: [Char] -> (a -> Bool) -> a -> a
- Language.Fixpoint.Misc: chopAfter :: (a -> Bool) -> [a] -> [a]
- Language.Fixpoint.Misc: chopAlt :: Eq a => [(a, a)] -> [a] -> [[a]]
- Language.Fixpoint.Misc: chopAlts :: [(String, String)] -> String -> [[Char]]
- Language.Fixpoint.Misc: chopPrefix :: Eq a => [a] -> [a] -> Maybe [a]
- Language.Fixpoint.Misc: colorPhaseLnWithOptStars :: Bool -> Moods -> [Char] -> [Char] -> IO ()
- Language.Fixpoint.Misc: concatMapM :: (Functor f, Monad f) => (a1 -> f [a]) -> [a1] -> f [a]
- Language.Fixpoint.Misc: concatMaps :: (Hashable k, Ord a, Eq k) => [HashMap k [a]] -> HashMap k [a]
- Language.Fixpoint.Misc: data Empty
- Language.Fixpoint.Misc: distinct :: Ord a => [a] -> Bool
- Language.Fixpoint.Misc: doneLineWithOptStars :: Bool -> Moods -> [Char] -> IO ()
- Language.Fixpoint.Misc: donePhaseWithOptStars :: Bool -> Moods -> String -> IO ()
- Language.Fixpoint.Misc: dot :: Doc
- Language.Fixpoint.Misc: errortext :: Doc -> c
- Language.Fixpoint.Misc: executeShellCommandWithOptStars :: Bool -> [Char] -> [Char] -> IO ExitCode
- Language.Fixpoint.Misc: expandSnd :: [([a], t)] -> [(a, t)]
- Language.Fixpoint.Misc: findFirst :: Monad m => (t -> m [a]) -> [t] -> m (Maybe a)
- Language.Fixpoint.Misc: findWithDefaultL :: (a -> Bool) -> [a] -> a -> a
- Language.Fixpoint.Misc: firstElem :: Eq a => [(a, t)] -> [a] -> Maybe Int
- Language.Fixpoint.Misc: firstElems :: [(ByteString, ByteString)] -> ByteString -> Maybe (Int, ByteString, (ByteString, ByteString))
- Language.Fixpoint.Misc: foldlMap :: (a -> b -> (c, a)) -> a -> [b] -> ([c], a)
- Language.Fixpoint.Misc: folds :: (a -> b -> (c, a)) -> a -> [b] -> ([c], a)
- Language.Fixpoint.Misc: groupFun :: (Eq k, Hashable k) => HashMap k Int -> k -> Int
- Language.Fixpoint.Misc: hashMapMapKeys :: (Eq k, Hashable k) => (t -> k) -> HashMap t v -> HashMap k v
- Language.Fixpoint.Misc: hashMapMapWithKey :: (k -> v1 -> v2) -> HashMap k v1 -> HashMap k v2
- Language.Fixpoint.Misc: ifM :: Monad m => m Bool -> m a -> m a -> m a
- Language.Fixpoint.Misc: instance Data Empty
- Language.Fixpoint.Misc: instance Eq Empty
- Language.Fixpoint.Misc: instance Show Empty
- Language.Fixpoint.Misc: instance Typeable Empty
- Language.Fixpoint.Misc: mapEither :: (a -> Either b c) -> [a] -> ([b], [c])
- Language.Fixpoint.Misc: mapFst :: (t -> t1) -> (t, t2) -> (t1, t2)
- Language.Fixpoint.Misc: mapFst3 :: (t -> t1) -> (t, t2, t3) -> (t1, t2, t3)
- Language.Fixpoint.Misc: mapPair :: (a -> b) -> (a, a) -> (b, b)
- Language.Fixpoint.Misc: mapSnd :: (t -> t2) -> (t1, t) -> (t1, t2)
- Language.Fixpoint.Misc: mapSnd3 :: (t -> t2) -> (t1, t, t3) -> (t1, t2, t3)
- Language.Fixpoint.Misc: mapThd3 :: (t -> t3) -> (t1, t2, t) -> (t1, t2, t3)
- Language.Fixpoint.Misc: memoIndex :: (Hashable k, Eq k) => (x -> Maybe k) -> [x] -> [Maybe Int]
- Language.Fixpoint.Misc: mkGraph :: (Eq a, Eq b, Hashable a, Hashable b) => [(a, b)] -> HashMap a (HashSet b)
- Language.Fixpoint.Misc: putDocLn :: Doc -> IO ()
- Language.Fixpoint.Misc: safeFromList :: (Hashable k, Show v, Show k, Eq k) => [Char] -> [(k, v)] -> HashMap k v
- Language.Fixpoint.Misc: safeUnion :: (Hashable k, Show k, Eq k) => [Char] -> HashMap k v -> HashMap k v -> HashMap k v
- Language.Fixpoint.Misc: single :: a -> [a]
- Language.Fixpoint.Misc: sortDiff :: Ord a => [a] -> [a] -> [a]
- Language.Fixpoint.Misc: splitters :: [(ByteString, t)] -> ByteString -> [(Int, t, (ByteString, ByteString))]
- Language.Fixpoint.Misc: startPhaseWithOptStars :: Bool -> Moods -> [Char] -> IO ()
- Language.Fixpoint.Misc: stripParens :: Text -> Text
- Language.Fixpoint.Misc: testM :: Monad m => (t -> m Bool) -> t -> m [t]
- Language.Fixpoint.Misc: tr_foldr' :: (a -> b -> b) -> b -> [a] -> b
- Language.Fixpoint.Misc: tr_reverse :: [a] -> [a]
- Language.Fixpoint.Misc: tryIgnore :: String -> IO () -> IO ()
- Language.Fixpoint.Misc: unIntersperse :: Eq t => t -> [t] -> [[t]]
- Language.Fixpoint.Misc: warnShow :: Show a => String -> a -> a
- Language.Fixpoint.Misc: wrapStarsWithOptStars :: Bool -> [Char] -> [Char]
- Language.Fixpoint.Names: anfPrefix :: Symbol
- Language.Fixpoint.Names: bitVecName :: Symbol
- Language.Fixpoint.Names: boolConName :: Symbol
- Language.Fixpoint.Names: bvAndName :: Symbol
- Language.Fixpoint.Names: bvOrName :: Symbol
- Language.Fixpoint.Names: class Symbolic a
- Language.Fixpoint.Names: consName :: Symbol
- Language.Fixpoint.Names: consSym :: Char -> Symbol -> Symbol
- Language.Fixpoint.Names: data Symbol
- Language.Fixpoint.Names: dropModuleNames :: Symbol -> Symbol
- Language.Fixpoint.Names: dropModuleUnique :: Symbol -> Symbol
- Language.Fixpoint.Names: dropSym :: Int -> Symbol -> Symbol
- Language.Fixpoint.Names: dummyName :: Symbol
- Language.Fixpoint.Names: dummySymbol :: Symbol
- Language.Fixpoint.Names: encode :: String -> String
- Language.Fixpoint.Names: existSymbol :: Symbol -> Integer -> Symbol
- Language.Fixpoint.Names: funConName :: Symbol
- Language.Fixpoint.Names: headSym :: Symbol -> Char
- Language.Fixpoint.Names: hpropConName :: Symbol
- Language.Fixpoint.Names: instance Constructor C1_0InternedText
- Language.Fixpoint.Names: instance Constructor C1_0Symbol
- Language.Fixpoint.Names: instance Data InternedText
- Language.Fixpoint.Names: instance Data Symbol
- Language.Fixpoint.Names: instance Datatype D1InternedText
- Language.Fixpoint.Names: instance Datatype D1Symbol
- Language.Fixpoint.Names: instance Eq Symbol
- Language.Fixpoint.Names: instance Generic InternedText
- Language.Fixpoint.Names: instance Generic Symbol
- Language.Fixpoint.Names: instance Hashable InternedText
- Language.Fixpoint.Names: instance Hashable Symbol
- Language.Fixpoint.Names: instance IsString Symbol
- Language.Fixpoint.Names: instance Monoid Symbol
- Language.Fixpoint.Names: instance NFData InternedText
- Language.Fixpoint.Names: instance NFData Symbol
- Language.Fixpoint.Names: instance Ord Symbol
- Language.Fixpoint.Names: instance Selector S1_0_0InternedText
- Language.Fixpoint.Names: instance Selector S1_0_1InternedText
- Language.Fixpoint.Names: instance Show Symbol
- Language.Fixpoint.Names: instance Symbolic InternedText
- Language.Fixpoint.Names: instance Symbolic String
- Language.Fixpoint.Names: instance Symbolic Symbol
- Language.Fixpoint.Names: instance Symbolic Text
- Language.Fixpoint.Names: instance Typeable InternedText
- Language.Fixpoint.Names: instance Typeable Symbol
- Language.Fixpoint.Names: intSymbol :: Show a => Symbol -> a -> Symbol
- Language.Fixpoint.Names: isNonSymbol :: Symbol -> Bool
- Language.Fixpoint.Names: isNontrivialVV :: Symbol -> Bool
- Language.Fixpoint.Names: isPrefixOfSym :: Symbol -> Symbol -> Bool
- Language.Fixpoint.Names: isSuffixOfSym :: Symbol -> Symbol -> Bool
- Language.Fixpoint.Names: lengthSym :: Symbol -> Int
- Language.Fixpoint.Names: listConName :: Symbol
- Language.Fixpoint.Names: nilName :: Symbol
- Language.Fixpoint.Names: nonSymbol :: Symbol
- Language.Fixpoint.Names: preludeName :: Symbol
- Language.Fixpoint.Names: prims :: [Symbol]
- Language.Fixpoint.Names: propConName :: Symbol
- Language.Fixpoint.Names: qualifySymbol :: Symbol -> Symbol -> Symbol
- Language.Fixpoint.Names: renameSymbol :: Symbol -> Int -> Symbol
- Language.Fixpoint.Names: singletonSym :: Char -> Symbol
- Language.Fixpoint.Names: size32Name :: Symbol
- Language.Fixpoint.Names: size64Name :: Symbol
- Language.Fixpoint.Names: strConName :: Symbol
- Language.Fixpoint.Names: stripParensSym :: Symbol -> Symbol
- Language.Fixpoint.Names: suffixSymbol :: Symbol -> Text -> Symbol
- Language.Fixpoint.Names: symChars :: [Char]
- Language.Fixpoint.Names: symSepName :: Char
- Language.Fixpoint.Names: symbol :: Symbolic a => a -> Symbol
- Language.Fixpoint.Names: symbolString :: Symbol -> String
- Language.Fixpoint.Names: symbolText :: Symbol -> Text
- Language.Fixpoint.Names: takeModuleNames :: Symbol -> Symbol
- Language.Fixpoint.Names: takeWhileSym :: (Char -> Bool) -> Symbol -> Symbol
- Language.Fixpoint.Names: tempPrefix :: Symbol
- Language.Fixpoint.Names: tempSymbol :: Symbol -> Integer -> Symbol
- Language.Fixpoint.Names: tupConName :: Symbol
- Language.Fixpoint.Names: unconsSym :: Symbol -> Maybe (Char, Symbol)
- Language.Fixpoint.Names: vv :: Maybe Integer -> Symbol
- Language.Fixpoint.Names: vvCon :: Symbol
- Language.Fixpoint.Names: vvName :: Symbol
- Language.Fixpoint.Parse: instance Constructor C1_0Def
- Language.Fixpoint.Parse: instance Constructor C1_1Def
- Language.Fixpoint.Parse: instance Constructor C1_2Def
- Language.Fixpoint.Parse: instance Constructor C1_3Def
- Language.Fixpoint.Parse: instance Constructor C1_4Def
- Language.Fixpoint.Parse: instance Constructor C1_5Def
- Language.Fixpoint.Parse: instance Constructor C1_6Def
- Language.Fixpoint.Parse: instance Constructor C1_7Def
- Language.Fixpoint.Parse: instance Datatype D1Def
- Language.Fixpoint.Parse: instance Fixpoint a => Show (Def a)
- Language.Fixpoint.Parse: instance Generic (Def a)
- Language.Fixpoint.Parse: instance Inputable (FInfo ())
- Language.Fixpoint.Parse: instance Inputable (FixResult Integer)
- Language.Fixpoint.Parse: instance Inputable (FixResult Integer, FixSolution)
- Language.Fixpoint.Parse: instance Inputable Command
- Language.Fixpoint.Parse: instance Inputable Constant
- Language.Fixpoint.Parse: instance Inputable Expr
- Language.Fixpoint.Parse: instance Inputable Pred
- Language.Fixpoint.Parse: instance Inputable Refa
- Language.Fixpoint.Parse: instance Inputable Symbol
- Language.Fixpoint.Parse: instance Inputable [Command]
- Language.Fixpoint.Partition: instance Constructor C1_0CVertex
- Language.Fixpoint.Partition: instance Constructor C1_1CVertex
- Language.Fixpoint.Partition: instance Datatype D1CVertex
- Language.Fixpoint.Partition: instance Eq CVertex
- Language.Fixpoint.Partition: instance Generic CVertex
- Language.Fixpoint.Partition: instance Hashable CVertex
- Language.Fixpoint.Partition: instance Ord CVertex
- Language.Fixpoint.Partition: instance PPrint CVertex
- Language.Fixpoint.Partition: instance Show CVertex
- Language.Fixpoint.PrettyPrint: andD :: Doc
- Language.Fixpoint.PrettyPrint: class PPrint a where pprint = pprintPrec 0 pprintPrec _ = pprint
- Language.Fixpoint.PrettyPrint: falseD :: Doc
- Language.Fixpoint.PrettyPrint: instance (PPrint a, PPrint b) => PPrint (HashMap a b)
- Language.Fixpoint.PrettyPrint: instance (PPrint a, PPrint b) => PPrint (a, b)
- Language.Fixpoint.PrettyPrint: instance (PPrint a, PPrint b, PPrint c) => PPrint (a, b, c)
- Language.Fixpoint.PrettyPrint: instance PPrint ()
- Language.Fixpoint.PrettyPrint: instance PPrint Bool
- Language.Fixpoint.PrettyPrint: instance PPrint Bop
- Language.Fixpoint.PrettyPrint: instance PPrint Brel
- Language.Fixpoint.PrettyPrint: instance PPrint Constant
- Language.Fixpoint.PrettyPrint: instance PPrint Expr
- Language.Fixpoint.PrettyPrint: instance PPrint Float
- Language.Fixpoint.PrettyPrint: instance PPrint Int
- Language.Fixpoint.PrettyPrint: instance PPrint Integer
- Language.Fixpoint.PrettyPrint: instance PPrint KVar
- Language.Fixpoint.PrettyPrint: instance PPrint Pred
- Language.Fixpoint.PrettyPrint: instance PPrint Refa
- Language.Fixpoint.PrettyPrint: instance PPrint Reft
- Language.Fixpoint.PrettyPrint: instance PPrint Sort
- Language.Fixpoint.PrettyPrint: instance PPrint SortedReft
- Language.Fixpoint.PrettyPrint: instance PPrint SourcePos
- Language.Fixpoint.PrettyPrint: instance PPrint String
- Language.Fixpoint.PrettyPrint: instance PPrint SymConst
- Language.Fixpoint.PrettyPrint: instance PPrint Symbol
- Language.Fixpoint.PrettyPrint: instance PPrint a => PPrint (Located a)
- Language.Fixpoint.PrettyPrint: instance PPrint a => PPrint (Maybe a)
- Language.Fixpoint.PrettyPrint: instance PPrint a => PPrint [a]
- Language.Fixpoint.PrettyPrint: opPrec :: Num a => Bop -> a
- Language.Fixpoint.PrettyPrint: orD :: Doc
- Language.Fixpoint.PrettyPrint: parensIf :: Bool -> Doc -> Doc
- Language.Fixpoint.PrettyPrint: pprint :: PPrint a => a -> Doc
- Language.Fixpoint.PrettyPrint: pprintBin :: PPrint a => Int -> Doc -> Doc -> [a] -> Doc
- Language.Fixpoint.PrettyPrint: pprintPrec :: PPrint a => Int -> a -> Doc
- Language.Fixpoint.PrettyPrint: showpp :: PPrint a => a -> String
- Language.Fixpoint.PrettyPrint: tracepp :: PPrint a => String -> a -> a
- Language.Fixpoint.PrettyPrint: trueD :: Doc
- Language.Fixpoint.Smt.Interface: cIn :: Context -> Handle
- Language.Fixpoint.Smt.Interface: cLog :: Context -> Maybe Handle
- Language.Fixpoint.Smt.Interface: cOut :: Context -> Handle
- Language.Fixpoint.Smt.Interface: pId :: Context -> ProcessHandle
- Language.Fixpoint.Smt.Interface: theorySymbols :: HashMap Symbol TheorySymbol
- Language.Fixpoint.Smt.Interface: verbose :: Context -> Bool
- Language.Fixpoint.Smt.Serialize: encode :: Text -> Text
- Language.Fixpoint.Smt.Serialize: instance SMTLIB2 Bop
- Language.Fixpoint.Smt.Serialize: instance SMTLIB2 Brel
- Language.Fixpoint.Smt.Serialize: instance SMTLIB2 Command
- Language.Fixpoint.Smt.Serialize: instance SMTLIB2 Constant
- Language.Fixpoint.Smt.Serialize: instance SMTLIB2 Expr
- Language.Fixpoint.Smt.Serialize: instance SMTLIB2 LocSymbol
- Language.Fixpoint.Smt.Serialize: instance SMTLIB2 Pred
- Language.Fixpoint.Smt.Serialize: instance SMTLIB2 Sort
- Language.Fixpoint.Smt.Serialize: instance SMTLIB2 SymConst
- Language.Fixpoint.Smt.Serialize: instance SMTLIB2 Symbol
- Language.Fixpoint.Smt.Theories: add :: Raw
- Language.Fixpoint.Smt.Theories: bit :: Raw
- Language.Fixpoint.Smt.Theories: cap :: Raw
- Language.Fixpoint.Smt.Theories: com :: Raw
- Language.Fixpoint.Smt.Theories: cup :: Raw
- Language.Fixpoint.Smt.Theories: dif :: Raw
- Language.Fixpoint.Smt.Theories: elt :: Raw
- Language.Fixpoint.Smt.Theories: emp :: Raw
- Language.Fixpoint.Smt.Theories: map :: Raw
- Language.Fixpoint.Smt.Theories: mem :: Raw
- Language.Fixpoint.Smt.Theories: mkEmptySet :: t -> t1 -> Raw
- Language.Fixpoint.Smt.Theories: mkSetAdd :: (Buildable t2, Buildable t1) => t -> t1 -> t2 -> Text
- Language.Fixpoint.Smt.Theories: mkSetCap :: (Buildable t2, Buildable t1) => t -> t1 -> t2 -> Text
- Language.Fixpoint.Smt.Theories: mkSetCup :: (Buildable t2, Buildable t1) => t -> t1 -> t2 -> Text
- Language.Fixpoint.Smt.Theories: mkSetDif :: (Buildable t2, Buildable t1) => t -> t1 -> t2 -> Text
- Language.Fixpoint.Smt.Theories: mkSetMem :: (Buildable t2, Buildable t1) => t -> t1 -> t2 -> Text
- Language.Fixpoint.Smt.Theories: mkSetSort :: t -> t1 -> Raw
- Language.Fixpoint.Smt.Theories: mkSetSub :: (Buildable t2, Buildable t1) => t -> t1 -> t2 -> Text
- Language.Fixpoint.Smt.Theories: sel :: Raw
- Language.Fixpoint.Smt.Theories: set :: Raw
- Language.Fixpoint.Smt.Theories: smt2Theory :: Symbol -> Maybe Text
- Language.Fixpoint.Smt.Theories: smtlibPreamble :: [Text]
- Language.Fixpoint.Smt.Theories: sto :: Raw
- Language.Fixpoint.Smt.Theories: sub :: Raw
- Language.Fixpoint.Smt.Theories: sz32 :: Raw
- Language.Fixpoint.Smt.Theories: sz64 :: Raw
- Language.Fixpoint.Smt.Theories: tSym :: Symbol -> Raw -> Sort -> (Symbol, TheorySymbol)
- Language.Fixpoint.Smt.Theories: z3Preamble :: [Text]
- Language.Fixpoint.Smt.Types: cIn :: Context -> Handle
- Language.Fixpoint.Smt.Types: cLog :: Context -> Maybe Handle
- Language.Fixpoint.Smt.Types: cOut :: Context -> Handle
- Language.Fixpoint.Smt.Types: instance Eq Command
- Language.Fixpoint.Smt.Types: instance Eq Response
- Language.Fixpoint.Smt.Types: instance Eq TheorySymbol
- Language.Fixpoint.Smt.Types: instance Ord TheorySymbol
- Language.Fixpoint.Smt.Types: instance Show Command
- Language.Fixpoint.Smt.Types: instance Show Response
- Language.Fixpoint.Smt.Types: instance Show TheorySymbol
- Language.Fixpoint.Smt.Types: pId :: Context -> ProcessHandle
- Language.Fixpoint.Smt.Types: tsRaw :: TheorySymbol -> Raw
- Language.Fixpoint.Smt.Types: tsSort :: TheorySymbol -> Sort
- Language.Fixpoint.Smt.Types: tsSym :: TheorySymbol -> Symbol
- Language.Fixpoint.Smt.Types: verbose :: Context -> Bool
- Language.Fixpoint.Solver.Deps: Deps :: ![KVar] -> ![KVar] -> Deps
- Language.Fixpoint.Solver.Deps: data Deps
- Language.Fixpoint.Solver.Deps: depCuts :: Deps -> ![KVar]
- Language.Fixpoint.Solver.Deps: depNonCuts :: Deps -> ![KVar]
- Language.Fixpoint.Solver.Deps: deps :: FInfo a -> Deps
- Language.Fixpoint.Solver.Deps: instance Eq Deps
- Language.Fixpoint.Solver.Deps: instance Ord Deps
- Language.Fixpoint.Solver.Deps: instance Show Deps
- Language.Fixpoint.Solver.Deps: lhsKVars :: BindEnv -> SubC a -> [KVar]
- Language.Fixpoint.Solver.Deps: rhsKVars :: SubC a -> [KVar]
- Language.Fixpoint.Solver.Deps: solve :: Config -> FInfo a -> IO (FixResult a)
- Language.Fixpoint.Solver.Eliminate: elimKVar :: Elimable a => ((KVar, Subst) -> Maybe Pred) -> a -> a
- Language.Fixpoint.Solver.Eliminate: eliminateAll :: FInfo a -> FInfo a
- Language.Fixpoint.Solver.Eliminate: findWfC :: KVar -> [WfC a] -> (WfC a, [WfC a])
- Language.Fixpoint.Solver.Eliminate: instance Elimable (FInfo a)
- Language.Fixpoint.Solver.Eliminate: instance Elimable (SubC a)
- Language.Fixpoint.Solver.Eliminate: instance Elimable BindEnv
- Language.Fixpoint.Solver.Eliminate: instance Elimable SortedReft
- Language.Fixpoint.Solver.Solution: EQL :: !Qualifier -> !Pred -> ![Expr] -> EQual
- Language.Fixpoint.Solver.Solution: apply :: Solvable a => Solution -> a -> Pred
- Language.Fixpoint.Solver.Solution: class Solvable a
- Language.Fixpoint.Solver.Solution: data EQual
- Language.Fixpoint.Solver.Solution: eqArgs :: EQual -> ![Expr]
- Language.Fixpoint.Solver.Solution: eqPred :: EQual -> !Pred
- Language.Fixpoint.Solver.Solution: eqQual :: EQual -> !Qualifier
- Language.Fixpoint.Solver.Solution: instance Eq EQual
- Language.Fixpoint.Solver.Solution: instance Ord EQual
- Language.Fixpoint.Solver.Solution: instance PPrint EQual
- Language.Fixpoint.Solver.Solution: instance Show EQual
- Language.Fixpoint.Solver.Solution: instance Solvable (KVar, Subst)
- Language.Fixpoint.Solver.Solution: instance Solvable (Symbol, SortedReft)
- Language.Fixpoint.Solver.Solution: instance Solvable EQual
- Language.Fixpoint.Solver.Solution: instance Solvable KVar
- Language.Fixpoint.Solver.Solution: instance Solvable Pred
- Language.Fixpoint.Solver.Solution: instance Solvable Refa
- Language.Fixpoint.Solver.Solution: instance Solvable Reft
- Language.Fixpoint.Solver.Solution: instance Solvable SortedReft
- Language.Fixpoint.Solver.Solution: instance Solvable a => Solvable [a]
- Language.Fixpoint.Solver.Solution: lookup :: Solution -> KVar -> KBind
- Language.Fixpoint.Solver.Solution: type Cand a = [(Pred, a)]
- Language.Fixpoint.Solver.Solution: type Solution = Sol KBind
- Language.Fixpoint.Solver.Uniqify: renameAll :: FInfo a -> FInfo a
- Language.Fixpoint.Solver.Validate: validate :: Config -> FInfo a -> Either Error (FInfo a)
- Language.Fixpoint.Solver.Worklist: instance PPrint (Worklist a)
- Language.Fixpoint.Sort: apply :: TVSubst -> Sort -> Sort
- Language.Fixpoint.Sort: boolSort :: Sort
- Language.Fixpoint.Sort: checkSortFull :: Checkable a => SEnv SortedReft -> Sort -> a -> Maybe Doc
- Language.Fixpoint.Sort: checkSorted :: Checkable a => SEnv Sort -> a -> Maybe Doc
- Language.Fixpoint.Sort: checkSortedReft :: SEnv SortedReft -> [Symbol] -> SortedReft -> Maybe Doc
- Language.Fixpoint.Sort: checkSortedReftFull :: Checkable a => SEnv SortedReft -> a -> Maybe Doc
- Language.Fixpoint.Sort: data TVSubst
- Language.Fixpoint.Sort: instance Checkable Expr
- Language.Fixpoint.Sort: instance Checkable Pred
- Language.Fixpoint.Sort: instance Checkable Refa
- Language.Fixpoint.Sort: instance Checkable SortedReft
- Language.Fixpoint.Sort: pruneUnsortedReft :: SEnv Sort -> SortedReft -> SortedReft
- Language.Fixpoint.Sort: strSort :: Sort
- Language.Fixpoint.Sort: unify :: Sort -> Sort -> Maybe TVSubst
- Language.Fixpoint.Statistics: instance PPrint Stats
- Language.Fixpoint.Statistics: instance Show Stats
- Language.Fixpoint.Statistics: statistics :: Config -> FInfo a -> IO (Result a)
- Language.Fixpoint.Types: Alts :: [Symbol] -> SESearch a
- Language.Fixpoint.Types: Crash :: [a] -> String -> FixResult a
- Language.Fixpoint.Types: Div :: Bop
- Language.Fixpoint.Types: EApp :: !LocSymbol -> ![Expr] -> Expr
- Language.Fixpoint.Types: EBin :: !Bop -> !Expr -> !Expr -> Expr
- Language.Fixpoint.Types: EBot :: Expr
- Language.Fixpoint.Types: ECon :: !Constant -> Expr
- Language.Fixpoint.Types: ECst :: !Expr -> !Sort -> Expr
- Language.Fixpoint.Types: EIte :: !Pred -> !Expr -> !Expr -> Expr
- Language.Fixpoint.Types: ELit :: !LocSymbol -> !Sort -> Expr
- Language.Fixpoint.Types: ENeg :: !Expr -> Expr
- Language.Fixpoint.Types: ESym :: !SymConst -> Expr
- Language.Fixpoint.Types: EVar :: !Symbol -> Expr
- Language.Fixpoint.Types: Eq :: Brel
- Language.Fixpoint.Types: FApp :: FTycon -> [Sort] -> Sort
- Language.Fixpoint.Types: FFrac :: Sort
- Language.Fixpoint.Types: FFunc :: !Int -> ![Sort] -> Sort
- Language.Fixpoint.Types: FI :: HashMap Integer (SubC a) -> ![WfC a] -> !BindEnv -> !FEnv -> ![(Symbol, Sort)] -> Kuts -> ![Qualifier] -> HashMap BindId a -> FInfo a
- Language.Fixpoint.Types: FInt :: Sort
- Language.Fixpoint.Types: FNum :: Sort
- Language.Fixpoint.Types: FObj :: Symbol -> Sort
- Language.Fixpoint.Types: FReal :: Sort
- Language.Fixpoint.Types: FVar :: !Int -> Sort
- Language.Fixpoint.Types: Found :: a -> SESearch a
- Language.Fixpoint.Types: Ge :: Brel
- Language.Fixpoint.Types: Gt :: Brel
- Language.Fixpoint.Types: I :: !Integer -> Constant
- Language.Fixpoint.Types: KS :: HashSet KVar -> Kuts
- Language.Fixpoint.Types: KV :: Symbol -> KVar
- Language.Fixpoint.Types: L :: !Text -> !Sort -> Constant
- Language.Fixpoint.Types: Le :: Brel
- Language.Fixpoint.Types: Loc :: !SourcePos -> !SourcePos -> a -> Located a
- Language.Fixpoint.Types: Lt :: Brel
- Language.Fixpoint.Types: Minus :: Bop
- Language.Fixpoint.Types: Mod :: Bop
- Language.Fixpoint.Types: Ne :: Brel
- Language.Fixpoint.Types: PAll :: ![(Symbol, Sort)] -> !Pred -> Pred
- Language.Fixpoint.Types: PAnd :: !(ListNE Pred) -> Pred
- Language.Fixpoint.Types: PAtom :: !Brel -> !Expr -> !Expr -> Pred
- Language.Fixpoint.Types: PBexp :: !Expr -> Pred
- Language.Fixpoint.Types: PFalse :: Pred
- Language.Fixpoint.Types: PIff :: !Pred -> !Pred -> Pred
- Language.Fixpoint.Types: PImp :: !Pred -> !Pred -> Pred
- Language.Fixpoint.Types: PKVar :: !KVar -> !Subst -> Pred
- Language.Fixpoint.Types: PNot :: !Pred -> Pred
- Language.Fixpoint.Types: POr :: ![Pred] -> Pred
- Language.Fixpoint.Types: PTop :: Pred
- Language.Fixpoint.Types: PTrue :: Pred
- Language.Fixpoint.Types: Plus :: Bop
- Language.Fixpoint.Types: Q :: Symbol -> [(Symbol, Sort)] -> Pred -> !SourcePos -> Qualifier
- Language.Fixpoint.Types: R :: !Double -> Constant
- Language.Fixpoint.Types: RR :: !Sort -> !Reft -> SortedReft
- Language.Fixpoint.Types: Refa :: Pred -> Refa
- Language.Fixpoint.Types: Reft :: (Symbol, Refa) -> Reft
- Language.Fixpoint.Types: Result :: FixResult (SubC a) -> HashMap KVar Pred -> Result a
- Language.Fixpoint.Types: SL :: !Text -> SymConst
- Language.Fixpoint.Types: Safe :: FixResult a
- Language.Fixpoint.Types: Su :: [(Symbol, Expr)] -> Subst
- Language.Fixpoint.Types: Times :: Bop
- Language.Fixpoint.Types: Ueq :: Brel
- Language.Fixpoint.Types: Une :: Brel
- Language.Fixpoint.Types: UnknownError :: !String -> FixResult a
- Language.Fixpoint.Types: Unsafe :: ![a] -> FixResult a
- Language.Fixpoint.Types: WfC :: !IBindEnv -> !SortedReft -> !(Maybe Integer) -> !a -> WfC a
- Language.Fixpoint.Types: addIds :: [SubC a] -> [(Integer, SubC a)]
- Language.Fixpoint.Types: adjustBindEnv :: ((Symbol, SortedReft) -> (Symbol, SortedReft)) -> BindId -> BindEnv -> BindEnv
- Language.Fixpoint.Types: anfPrefix :: Symbol
- Language.Fixpoint.Types: appFTyCon :: FTycon
- Language.Fixpoint.Types: beBinds :: BindEnv -> BindMap (Symbol, SortedReft)
- Language.Fixpoint.Types: bindEnvFromList :: [(BindId, Symbol, SortedReft)] -> BindEnv
- Language.Fixpoint.Types: bindEnvToList :: BindEnv -> [(BindId, Symbol, SortedReft)]
- Language.Fixpoint.Types: bindInfo :: FInfo a -> HashMap BindId a
- Language.Fixpoint.Types: boolFTyCon :: FTycon
- Language.Fixpoint.Types: boolSort :: Sort
- Language.Fixpoint.Types: bot :: Reftable r => r -> r
- Language.Fixpoint.Types: bs :: FInfo a -> !BindEnv
- Language.Fixpoint.Types: class Expression a
- Language.Fixpoint.Types: class Fixpoint a where simplify = id
- Language.Fixpoint.Types: class Predicate a
- Language.Fixpoint.Types: class (Monoid r, Subable r) => Reftable r where top _ = mempty meet = mappend
- Language.Fixpoint.Types: class Subable a where subst1 y (x, e) = subst (Su [(x, e)]) y
- Language.Fixpoint.Types: class Symbolic a
- Language.Fixpoint.Types: cm :: FInfo a -> HashMap Integer (SubC a)
- Language.Fixpoint.Types: colorResult :: FixResult a -> Moods
- Language.Fixpoint.Types: conjuncts :: Pred -> [Pred]
- Language.Fixpoint.Types: data BindEnv
- Language.Fixpoint.Types: data Bop
- Language.Fixpoint.Types: data Brel
- Language.Fixpoint.Types: data Constant
- Language.Fixpoint.Types: data Expr
- Language.Fixpoint.Types: data FInfo a
- Language.Fixpoint.Types: data FTycon
- Language.Fixpoint.Types: data FixResult a
- Language.Fixpoint.Types: data IBindEnv
- Language.Fixpoint.Types: data Located a
- Language.Fixpoint.Types: data Pred
- Language.Fixpoint.Types: data Qualifier
- Language.Fixpoint.Types: data Result a
- Language.Fixpoint.Types: data SESearch a
- Language.Fixpoint.Types: data SEnv a
- Language.Fixpoint.Types: data Sort
- Language.Fixpoint.Types: data SortedReft
- Language.Fixpoint.Types: data SubC a
- Language.Fixpoint.Types: data SymConst
- Language.Fixpoint.Types: data Symbol
- Language.Fixpoint.Types: data WfC a
- Language.Fixpoint.Types: deleteIBindEnv :: BindId -> IBindEnv -> IBindEnv
- Language.Fixpoint.Types: deleteSEnv :: Symbol -> SEnv a -> SEnv a
- Language.Fixpoint.Types: dummyLoc :: a -> Located a
- Language.Fixpoint.Types: dummyName :: Symbol
- Language.Fixpoint.Types: dummyPos :: String -> SourcePos
- Language.Fixpoint.Types: dummySymbol :: Symbol
- Language.Fixpoint.Types: eProp :: Symbolic a => a -> Pred
- Language.Fixpoint.Types: eVar :: Symbolic a => a -> Expr
- Language.Fixpoint.Types: elemsIBindEnv :: IBindEnv -> [BindId]
- Language.Fixpoint.Types: emptyBindEnv :: BindEnv
- Language.Fixpoint.Types: emptyIBindEnv :: IBindEnv
- Language.Fixpoint.Types: emptySEnv :: SEnv a
- Language.Fixpoint.Types: envCs :: BindEnv -> IBindEnv -> [(Symbol, SortedReft)]
- Language.Fixpoint.Types: expr :: Expression a => a -> Expr
- Language.Fixpoint.Types: exprReft :: Expression a => a -> Reft
- Language.Fixpoint.Types: fApp :: Either FTycon Sort -> [Sort] -> Sort
- Language.Fixpoint.Types: fObj :: LocSymbol -> Sort
- Language.Fixpoint.Types: fTyconSort :: FTycon -> Sort
- Language.Fixpoint.Types: fTyconSymbol :: FTycon -> Located Symbol
- Language.Fixpoint.Types: filterSEnv :: (a -> Bool) -> SEnv a -> SEnv a
- Language.Fixpoint.Types: flattenRefas :: [Refa] -> [Refa]
- Language.Fixpoint.Types: fromListSEnv :: [(Symbol, a)] -> SEnv a
- Language.Fixpoint.Types: functionSort :: Sort -> Maybe (Int, [Sort], Sort)
- Language.Fixpoint.Types: gs :: FInfo a -> !FEnv
- Language.Fixpoint.Types: insertBindEnv :: Symbol -> SortedReft -> BindEnv -> (BindId, BindEnv)
- Language.Fixpoint.Types: insertFEnv :: Symbol -> a -> SEnv a -> SEnv a
- Language.Fixpoint.Types: insertSEnv :: Symbol -> a -> SEnv a -> SEnv a
- Language.Fixpoint.Types: insertsIBindEnv :: [BindId] -> IBindEnv -> IBindEnv
- Language.Fixpoint.Types: instance (Eq a, Hashable a, Fixpoint a) => Fixpoint (HashSet a)
- Language.Fixpoint.Types: instance (Fixpoint a, Fixpoint b) => Fixpoint (a, b)
- Language.Fixpoint.Types: instance (Fixpoint a, Fixpoint b, Fixpoint c) => Fixpoint (a, b, c)
- Language.Fixpoint.Types: instance (Ord a, Fixpoint a) => Fixpoint (FixResult (SubC a))
- Language.Fixpoint.Types: instance (Show a, Fixpoint a) => Show (FInfo a)
- Language.Fixpoint.Types: instance (Subable a, Subable b) => Subable (a, b)
- Language.Fixpoint.Types: instance Constructor C1_0Bop
- Language.Fixpoint.Types: instance Constructor C1_0Brel
- Language.Fixpoint.Types: instance Constructor C1_0Constant
- Language.Fixpoint.Types: instance Constructor C1_0Expr
- Language.Fixpoint.Types: instance Constructor C1_0FTycon
- Language.Fixpoint.Types: instance Constructor C1_0FixResult
- Language.Fixpoint.Types: instance Constructor C1_0KVar
- Language.Fixpoint.Types: instance Constructor C1_0Located
- Language.Fixpoint.Types: instance Constructor C1_0Pred
- Language.Fixpoint.Types: instance Constructor C1_0Qualifier
- Language.Fixpoint.Types: instance Constructor C1_0Refa
- Language.Fixpoint.Types: instance Constructor C1_0Reft
- Language.Fixpoint.Types: instance Constructor C1_0SEnv
- Language.Fixpoint.Types: instance Constructor C1_0Sort
- Language.Fixpoint.Types: instance Constructor C1_0SortedReft
- Language.Fixpoint.Types: instance Constructor C1_0SubC
- Language.Fixpoint.Types: instance Constructor C1_0Subst
- Language.Fixpoint.Types: instance Constructor C1_0SymConst
- Language.Fixpoint.Types: instance Constructor C1_0WfC
- Language.Fixpoint.Types: instance Constructor C1_10Pred
- Language.Fixpoint.Types: instance Constructor C1_11Pred
- Language.Fixpoint.Types: instance Constructor C1_1Bop
- Language.Fixpoint.Types: instance Constructor C1_1Brel
- Language.Fixpoint.Types: instance Constructor C1_1Constant
- Language.Fixpoint.Types: instance Constructor C1_1Expr
- Language.Fixpoint.Types: instance Constructor C1_1FixResult
- Language.Fixpoint.Types: instance Constructor C1_1Pred
- Language.Fixpoint.Types: instance Constructor C1_1Sort
- Language.Fixpoint.Types: instance Constructor C1_2Bop
- Language.Fixpoint.Types: instance Constructor C1_2Brel
- Language.Fixpoint.Types: instance Constructor C1_2Constant
- Language.Fixpoint.Types: instance Constructor C1_2Expr
- Language.Fixpoint.Types: instance Constructor C1_2FixResult
- Language.Fixpoint.Types: instance Constructor C1_2Pred
- Language.Fixpoint.Types: instance Constructor C1_2Sort
- Language.Fixpoint.Types: instance Constructor C1_3Bop
- Language.Fixpoint.Types: instance Constructor C1_3Brel
- Language.Fixpoint.Types: instance Constructor C1_3Expr
- Language.Fixpoint.Types: instance Constructor C1_3FixResult
- Language.Fixpoint.Types: instance Constructor C1_3Pred
- Language.Fixpoint.Types: instance Constructor C1_3Sort
- Language.Fixpoint.Types: instance Constructor C1_4Bop
- Language.Fixpoint.Types: instance Constructor C1_4Brel
- Language.Fixpoint.Types: instance Constructor C1_4Expr
- Language.Fixpoint.Types: instance Constructor C1_4Pred
- Language.Fixpoint.Types: instance Constructor C1_4Sort
- Language.Fixpoint.Types: instance Constructor C1_5Brel
- Language.Fixpoint.Types: instance Constructor C1_5Expr
- Language.Fixpoint.Types: instance Constructor C1_5Pred
- Language.Fixpoint.Types: instance Constructor C1_5Sort
- Language.Fixpoint.Types: instance Constructor C1_6Brel
- Language.Fixpoint.Types: instance Constructor C1_6Expr
- Language.Fixpoint.Types: instance Constructor C1_6Pred
- Language.Fixpoint.Types: instance Constructor C1_6Sort
- Language.Fixpoint.Types: instance Constructor C1_7Brel
- Language.Fixpoint.Types: instance Constructor C1_7Expr
- Language.Fixpoint.Types: instance Constructor C1_7Pred
- Language.Fixpoint.Types: instance Constructor C1_7Sort
- Language.Fixpoint.Types: instance Constructor C1_8Expr
- Language.Fixpoint.Types: instance Constructor C1_8Pred
- Language.Fixpoint.Types: instance Constructor C1_9Expr
- Language.Fixpoint.Types: instance Constructor C1_9Pred
- Language.Fixpoint.Types: instance Data Bop
- Language.Fixpoint.Types: instance Data Brel
- Language.Fixpoint.Types: instance Data Constant
- Language.Fixpoint.Types: instance Data Expr
- Language.Fixpoint.Types: instance Data FTycon
- Language.Fixpoint.Types: instance Data IBindEnv
- Language.Fixpoint.Types: instance Data KVar
- Language.Fixpoint.Types: instance Data Pred
- Language.Fixpoint.Types: instance Data Qualifier
- Language.Fixpoint.Types: instance Data Refa
- Language.Fixpoint.Types: instance Data Reft
- Language.Fixpoint.Types: instance Data Sort
- Language.Fixpoint.Types: instance Data SortedReft
- Language.Fixpoint.Types: instance Data Subst
- Language.Fixpoint.Types: instance Data SymConst
- Language.Fixpoint.Types: instance Data a => Data (Located a)
- Language.Fixpoint.Types: instance Data a => Data (SEnv a)
- Language.Fixpoint.Types: instance Datatype D1Bop
- Language.Fixpoint.Types: instance Datatype D1Brel
- Language.Fixpoint.Types: instance Datatype D1Constant
- Language.Fixpoint.Types: instance Datatype D1Expr
- Language.Fixpoint.Types: instance Datatype D1FTycon
- Language.Fixpoint.Types: instance Datatype D1FixResult
- Language.Fixpoint.Types: instance Datatype D1KVar
- Language.Fixpoint.Types: instance Datatype D1Located
- Language.Fixpoint.Types: instance Datatype D1Pred
- Language.Fixpoint.Types: instance Datatype D1Qualifier
- Language.Fixpoint.Types: instance Datatype D1Refa
- Language.Fixpoint.Types: instance Datatype D1Reft
- Language.Fixpoint.Types: instance Datatype D1SEnv
- Language.Fixpoint.Types: instance Datatype D1Sort
- Language.Fixpoint.Types: instance Datatype D1SortedReft
- Language.Fixpoint.Types: instance Datatype D1SubC
- Language.Fixpoint.Types: instance Datatype D1Subst
- Language.Fixpoint.Types: instance Datatype D1SymConst
- Language.Fixpoint.Types: instance Datatype D1WfC
- Language.Fixpoint.Types: instance Eq Bop
- Language.Fixpoint.Types: instance Eq Brel
- Language.Fixpoint.Types: instance Eq Constant
- Language.Fixpoint.Types: instance Eq Expr
- Language.Fixpoint.Types: instance Eq FTycon
- Language.Fixpoint.Types: instance Eq KVar
- Language.Fixpoint.Types: instance Eq Pred
- Language.Fixpoint.Types: instance Eq Qualifier
- Language.Fixpoint.Types: instance Eq Refa
- Language.Fixpoint.Types: instance Eq Reft
- Language.Fixpoint.Types: instance Eq Sort
- Language.Fixpoint.Types: instance Eq SortedReft
- Language.Fixpoint.Types: instance Eq Subst
- Language.Fixpoint.Types: instance Eq SymConst
- Language.Fixpoint.Types: instance Eq a => Eq (FixResult a)
- Language.Fixpoint.Types: instance Eq a => Eq (Located a)
- Language.Fixpoint.Types: instance Eq a => Eq (SEnv a)
- Language.Fixpoint.Types: instance Expression Expr
- Language.Fixpoint.Types: instance Expression Int
- Language.Fixpoint.Types: instance Expression Integer
- Language.Fixpoint.Types: instance Expression Symbol
- Language.Fixpoint.Types: instance Expression Text
- Language.Fixpoint.Types: instance Expression a => Expression (Located a)
- Language.Fixpoint.Types: instance Falseable Pred
- Language.Fixpoint.Types: instance Falseable Refa
- Language.Fixpoint.Types: instance Falseable Reft
- Language.Fixpoint.Types: instance Fixpoint ()
- Language.Fixpoint.Types: instance Fixpoint (SEnv a) => Show (SEnv a)
- Language.Fixpoint.Types: instance Fixpoint BindEnv
- Language.Fixpoint.Types: instance Fixpoint Bool
- Language.Fixpoint.Types: instance Fixpoint Bop
- Language.Fixpoint.Types: instance Fixpoint Brel
- Language.Fixpoint.Types: instance Fixpoint Constant
- Language.Fixpoint.Types: instance Fixpoint Double
- Language.Fixpoint.Types: instance Fixpoint Expr
- Language.Fixpoint.Types: instance Fixpoint FTycon
- Language.Fixpoint.Types: instance Fixpoint IBindEnv
- Language.Fixpoint.Types: instance Fixpoint Int
- Language.Fixpoint.Types: instance Fixpoint Integer
- Language.Fixpoint.Types: instance Fixpoint KVar
- Language.Fixpoint.Types: instance Fixpoint Kuts
- Language.Fixpoint.Types: instance Fixpoint Pred
- Language.Fixpoint.Types: instance Fixpoint Qualifier
- Language.Fixpoint.Types: instance Fixpoint Refa
- Language.Fixpoint.Types: instance Fixpoint Reft
- Language.Fixpoint.Types: instance Fixpoint Sort
- Language.Fixpoint.Types: instance Fixpoint SortedReft
- Language.Fixpoint.Types: instance Fixpoint SourcePos
- Language.Fixpoint.Types: instance Fixpoint Subst
- Language.Fixpoint.Types: instance Fixpoint SymConst
- Language.Fixpoint.Types: instance Fixpoint Symbol
- Language.Fixpoint.Types: instance Fixpoint Text
- Language.Fixpoint.Types: instance Fixpoint a => Fixpoint (Located a)
- Language.Fixpoint.Types: instance Fixpoint a => Fixpoint (Maybe a)
- Language.Fixpoint.Types: instance Fixpoint a => Fixpoint (SEnv a)
- Language.Fixpoint.Types: instance Fixpoint a => Fixpoint (SubC a)
- Language.Fixpoint.Types: instance Fixpoint a => Fixpoint (WfC a)
- Language.Fixpoint.Types: instance Fixpoint a => Fixpoint [a]
- Language.Fixpoint.Types: instance Fixpoint a => Show (Result a)
- Language.Fixpoint.Types: instance Fixpoint a => Show (SubC a)
- Language.Fixpoint.Types: instance Fixpoint a => Show (WfC a)
- Language.Fixpoint.Types: instance Foldable Located
- Language.Fixpoint.Types: instance Foldable SEnv
- Language.Fixpoint.Types: instance Functor FixResult
- Language.Fixpoint.Types: instance Functor Located
- Language.Fixpoint.Types: instance Functor SEnv
- Language.Fixpoint.Types: instance Generic (FixResult a)
- Language.Fixpoint.Types: instance Generic (Located a)
- Language.Fixpoint.Types: instance Generic (SEnv a)
- Language.Fixpoint.Types: instance Generic (SubC a)
- Language.Fixpoint.Types: instance Generic (WfC a)
- Language.Fixpoint.Types: instance Generic Bop
- Language.Fixpoint.Types: instance Generic Brel
- Language.Fixpoint.Types: instance Generic Constant
- Language.Fixpoint.Types: instance Generic Expr
- Language.Fixpoint.Types: instance Generic FTycon
- Language.Fixpoint.Types: instance Generic KVar
- Language.Fixpoint.Types: instance Generic Pred
- Language.Fixpoint.Types: instance Generic Qualifier
- Language.Fixpoint.Types: instance Generic Refa
- Language.Fixpoint.Types: instance Generic Reft
- Language.Fixpoint.Types: instance Generic Sort
- Language.Fixpoint.Types: instance Generic SortedReft
- Language.Fixpoint.Types: instance Generic Subst
- Language.Fixpoint.Types: instance Generic SymConst
- Language.Fixpoint.Types: instance Hashable Bop
- Language.Fixpoint.Types: instance Hashable Brel
- Language.Fixpoint.Types: instance Hashable Constant
- Language.Fixpoint.Types: instance Hashable Expr
- Language.Fixpoint.Types: instance Hashable FTycon
- Language.Fixpoint.Types: instance Hashable KVar
- Language.Fixpoint.Types: instance Hashable Pred
- Language.Fixpoint.Types: instance Hashable Sort
- Language.Fixpoint.Types: instance Hashable Subst
- Language.Fixpoint.Types: instance Hashable SymConst
- Language.Fixpoint.Types: instance Hashable a => Hashable (Located a)
- Language.Fixpoint.Types: instance IsString KVar
- Language.Fixpoint.Types: instance IsString a => IsString (Located a)
- Language.Fixpoint.Types: instance Monoid (FInfo a)
- Language.Fixpoint.Types: instance Monoid (FixResult a)
- Language.Fixpoint.Types: instance Monoid (Result a)
- Language.Fixpoint.Types: instance Monoid (SEnv a)
- Language.Fixpoint.Types: instance Monoid BindEnv
- Language.Fixpoint.Types: instance Monoid Kuts
- Language.Fixpoint.Types: instance Monoid Pred
- Language.Fixpoint.Types: instance Monoid Refa
- Language.Fixpoint.Types: instance Monoid Reft
- Language.Fixpoint.Types: instance Monoid Sort
- Language.Fixpoint.Types: instance Monoid SortedReft
- Language.Fixpoint.Types: instance Monoid Subst
- Language.Fixpoint.Types: instance NFData BindEnv
- Language.Fixpoint.Types: instance NFData Bop
- Language.Fixpoint.Types: instance NFData Brel
- Language.Fixpoint.Types: instance NFData Constant
- Language.Fixpoint.Types: instance NFData Expr
- Language.Fixpoint.Types: instance NFData FEnv
- Language.Fixpoint.Types: instance NFData FTycon
- Language.Fixpoint.Types: instance NFData IBindEnv
- Language.Fixpoint.Types: instance NFData Kuts
- Language.Fixpoint.Types: instance NFData Pred
- Language.Fixpoint.Types: instance NFData Qualifier
- Language.Fixpoint.Types: instance NFData Refa
- Language.Fixpoint.Types: instance NFData Reft
- Language.Fixpoint.Types: instance NFData Sort
- Language.Fixpoint.Types: instance NFData SortedReft
- Language.Fixpoint.Types: instance NFData Sub
- Language.Fixpoint.Types: instance NFData Subst
- Language.Fixpoint.Types: instance NFData SymConst
- Language.Fixpoint.Types: instance NFData a => NFData (Located a)
- Language.Fixpoint.Types: instance NFData a => NFData (SubC a)
- Language.Fixpoint.Types: instance NFData a => NFData (WfC a)
- Language.Fixpoint.Types: instance Ord Bop
- Language.Fixpoint.Types: instance Ord Brel
- Language.Fixpoint.Types: instance Ord Constant
- Language.Fixpoint.Types: instance Ord Expr
- Language.Fixpoint.Types: instance Ord FTycon
- Language.Fixpoint.Types: instance Ord KVar
- Language.Fixpoint.Types: instance Ord Pred
- Language.Fixpoint.Types: instance Ord Qualifier
- Language.Fixpoint.Types: instance Ord Refa
- Language.Fixpoint.Types: instance Ord Reft
- Language.Fixpoint.Types: instance Ord Sort
- Language.Fixpoint.Types: instance Ord Subst
- Language.Fixpoint.Types: instance Ord SymConst
- Language.Fixpoint.Types: instance Ord a => Ord (Located a)
- Language.Fixpoint.Types: instance Predicate Bool
- Language.Fixpoint.Types: instance Predicate Pred
- Language.Fixpoint.Types: instance Predicate Symbol
- Language.Fixpoint.Types: instance Reftable ()
- Language.Fixpoint.Types: instance Reftable Reft
- Language.Fixpoint.Types: instance Reftable SortedReft
- Language.Fixpoint.Types: instance Selector S1_0_0KVar
- Language.Fixpoint.Types: instance Selector S1_0_0Located
- Language.Fixpoint.Types: instance Selector S1_0_0Qualifier
- Language.Fixpoint.Types: instance Selector S1_0_0Refa
- Language.Fixpoint.Types: instance Selector S1_0_0SEnv
- Language.Fixpoint.Types: instance Selector S1_0_0SortedReft
- Language.Fixpoint.Types: instance Selector S1_0_0SubC
- Language.Fixpoint.Types: instance Selector S1_0_0WfC
- Language.Fixpoint.Types: instance Selector S1_0_1Located
- Language.Fixpoint.Types: instance Selector S1_0_1Qualifier
- Language.Fixpoint.Types: instance Selector S1_0_1SortedReft
- Language.Fixpoint.Types: instance Selector S1_0_1SubC
- Language.Fixpoint.Types: instance Selector S1_0_1WfC
- Language.Fixpoint.Types: instance Selector S1_0_2Located
- Language.Fixpoint.Types: instance Selector S1_0_2Qualifier
- Language.Fixpoint.Types: instance Selector S1_0_2SubC
- Language.Fixpoint.Types: instance Selector S1_0_2WfC
- Language.Fixpoint.Types: instance Selector S1_0_3Qualifier
- Language.Fixpoint.Types: instance Selector S1_0_3SubC
- Language.Fixpoint.Types: instance Selector S1_0_3WfC
- Language.Fixpoint.Types: instance Selector S1_0_4SubC
- Language.Fixpoint.Types: instance Selector S1_0_5SubC
- Language.Fixpoint.Types: instance Selector S1_0_6SubC
- Language.Fixpoint.Types: instance Show BindEnv
- Language.Fixpoint.Types: instance Show Bop
- Language.Fixpoint.Types: instance Show Brel
- Language.Fixpoint.Types: instance Show Constant
- Language.Fixpoint.Types: instance Show Expr
- Language.Fixpoint.Types: instance Show FTycon
- Language.Fixpoint.Types: instance Show KVar
- Language.Fixpoint.Types: instance Show Kuts
- Language.Fixpoint.Types: instance Show Pred
- Language.Fixpoint.Types: instance Show Qualifier
- Language.Fixpoint.Types: instance Show Refa
- Language.Fixpoint.Types: instance Show Reft
- Language.Fixpoint.Types: instance Show Sort
- Language.Fixpoint.Types: instance Show SortedReft
- Language.Fixpoint.Types: instance Show Subst
- Language.Fixpoint.Types: instance Show SymConst
- Language.Fixpoint.Types: instance Show a => Show (FixResult a)
- Language.Fixpoint.Types: instance Show a => Show (Located a)
- Language.Fixpoint.Types: instance Subable ()
- Language.Fixpoint.Types: instance Subable Expr
- Language.Fixpoint.Types: instance Subable Pred
- Language.Fixpoint.Types: instance Subable Refa
- Language.Fixpoint.Types: instance Subable Reft
- Language.Fixpoint.Types: instance Subable SortedReft
- Language.Fixpoint.Types: instance Subable Symbol
- Language.Fixpoint.Types: instance Subable a => Subable (HashMap k a)
- Language.Fixpoint.Types: instance Subable a => Subable (Located a)
- Language.Fixpoint.Types: instance Subable a => Subable [a]
- Language.Fixpoint.Types: instance SymConsts (FInfo a)
- Language.Fixpoint.Types: instance SymConsts (SubC a)
- Language.Fixpoint.Types: instance SymConsts Expr
- Language.Fixpoint.Types: instance SymConsts Pred
- Language.Fixpoint.Types: instance SymConsts Refa
- Language.Fixpoint.Types: instance SymConsts Reft
- Language.Fixpoint.Types: instance SymConsts SortedReft
- Language.Fixpoint.Types: instance Symbolic SymConst
- Language.Fixpoint.Types: instance Symbolic a => Symbolic (Located a)
- Language.Fixpoint.Types: instance Traversable Located
- Language.Fixpoint.Types: instance Traversable SEnv
- Language.Fixpoint.Types: instance Typeable Bop
- Language.Fixpoint.Types: instance Typeable Brel
- Language.Fixpoint.Types: instance Typeable Constant
- Language.Fixpoint.Types: instance Typeable Expr
- Language.Fixpoint.Types: instance Typeable FTycon
- Language.Fixpoint.Types: instance Typeable IBindEnv
- Language.Fixpoint.Types: instance Typeable KVar
- Language.Fixpoint.Types: instance Typeable Located
- Language.Fixpoint.Types: instance Typeable Pred
- Language.Fixpoint.Types: instance Typeable Qualifier
- Language.Fixpoint.Types: instance Typeable Refa
- Language.Fixpoint.Types: instance Typeable Reft
- Language.Fixpoint.Types: instance Typeable SEnv
- Language.Fixpoint.Types: instance Typeable Sort
- Language.Fixpoint.Types: instance Typeable SortedReft
- Language.Fixpoint.Types: instance Typeable Subst
- Language.Fixpoint.Types: instance Typeable SymConst
- Language.Fixpoint.Types: intFTyCon :: FTycon
- Language.Fixpoint.Types: intKvar :: Integer -> KVar
- Language.Fixpoint.Types: intSort :: Sort
- Language.Fixpoint.Types: intSymbol :: Show a => Symbol -> a -> Symbol
- Language.Fixpoint.Types: intersectWithSEnv :: (v1 -> v2 -> a) -> SEnv v1 -> SEnv v2 -> SEnv a
- Language.Fixpoint.Types: isDummy :: Symbolic a => a -> Bool
- Language.Fixpoint.Types: isEVar :: Expr -> Bool
- Language.Fixpoint.Types: isEmptySubst :: Subst -> Bool
- Language.Fixpoint.Types: isFAppTyTC :: FTycon -> Bool
- Language.Fixpoint.Types: isFalse :: Falseable a => a -> Bool
- Language.Fixpoint.Types: isFunctionSortedReft :: SortedReft -> Bool
- Language.Fixpoint.Types: isListTC :: FTycon -> Bool
- Language.Fixpoint.Types: isNonSymbol :: Symbol -> Bool
- Language.Fixpoint.Types: isNonTrivial :: Reftable r => r -> Bool
- Language.Fixpoint.Types: isNontrivialVV :: Symbol -> Bool
- Language.Fixpoint.Types: isSingletonReft :: Reft -> Maybe Expr
- Language.Fixpoint.Types: isTauto :: Reftable r => r -> Bool
- Language.Fixpoint.Types: isTautoPred :: Pred -> Bool
- Language.Fixpoint.Types: ksEmpty :: Kuts
- Language.Fixpoint.Types: ksUnion :: [KVar] -> Kuts -> Kuts
- Language.Fixpoint.Types: ksVars :: Kuts -> HashSet KVar
- Language.Fixpoint.Types: kuts :: FInfo a -> Kuts
- Language.Fixpoint.Types: kv :: KVar -> Symbol
- Language.Fixpoint.Types: lhsCs :: SubC a -> Reft
- Language.Fixpoint.Types: listFTyCon :: FTycon
- Language.Fixpoint.Types: lits :: FInfo a -> ![(Symbol, Sort)]
- Language.Fixpoint.Types: loc :: Located a -> !SourcePos
- Language.Fixpoint.Types: locAt :: String -> a -> Located a
- Language.Fixpoint.Types: locE :: Located a -> !SourcePos
- Language.Fixpoint.Types: lookupBindEnv :: BindId -> BindEnv -> (Symbol, SortedReft)
- Language.Fixpoint.Types: lookupSEnv :: Symbol -> SEnv v -> Maybe v
- Language.Fixpoint.Types: lookupSEnvWithDistance :: Symbol -> SEnv a -> SESearch a
- Language.Fixpoint.Types: mapBindEnv :: ((Symbol, SortedReft) -> (Symbol, SortedReft)) -> BindEnv -> BindEnv
- Language.Fixpoint.Types: mapPredReft :: (Pred -> Pred) -> Reft -> Reft
- Language.Fixpoint.Types: mapSEnvWithKey :: ((Symbol, a1) -> (Symbol, a)) -> SEnv a1 -> SEnv a
- Language.Fixpoint.Types: meet :: Reftable r => r -> r -> r
- Language.Fixpoint.Types: memberSEnv :: Symbol -> SEnv a -> Bool
- Language.Fixpoint.Types: mkSubst :: [(Symbol, Expr)] -> Subst
- Language.Fixpoint.Types: newtype KVar
- Language.Fixpoint.Types: newtype Kuts
- Language.Fixpoint.Types: newtype Refa
- Language.Fixpoint.Types: newtype Reft
- Language.Fixpoint.Types: newtype Subst
- Language.Fixpoint.Types: nonSymbol :: Symbol
- Language.Fixpoint.Types: notExprReft :: Expression a => a -> Reft
- Language.Fixpoint.Types: ofReft :: Reftable r => Reft -> r
- Language.Fixpoint.Types: pAnd :: ListNE Pred -> Pred
- Language.Fixpoint.Types: pIte :: Pred -> Pred -> Pred -> Pred
- Language.Fixpoint.Types: pOr :: [Pred] -> Pred
- Language.Fixpoint.Types: params :: Reftable r => r -> [Symbol]
- Language.Fixpoint.Types: ppTy :: Reftable r => r -> Doc -> Doc
- Language.Fixpoint.Types: predReft :: Predicate a => a -> Reft
- Language.Fixpoint.Types: prop :: Predicate a => a -> Pred
- Language.Fixpoint.Types: propReft :: Predicate a => a -> Reft
- Language.Fixpoint.Types: propSort :: Sort
- Language.Fixpoint.Types: q_body :: Qualifier -> Pred
- Language.Fixpoint.Types: q_name :: Qualifier -> Symbol
- Language.Fixpoint.Types: q_params :: Qualifier -> [(Symbol, Sort)]
- Language.Fixpoint.Types: q_pos :: Qualifier -> !SourcePos
- Language.Fixpoint.Types: qualifySymbol :: Symbol -> Symbol -> Symbol
- Language.Fixpoint.Types: quals :: FInfo a -> ![Qualifier]
- Language.Fixpoint.Types: raConjuncts :: Refa -> [Pred]
- Language.Fixpoint.Types: raPred :: Refa -> Pred
- Language.Fixpoint.Types: realFTyCon :: FTycon
- Language.Fixpoint.Types: realSort :: Sort
- Language.Fixpoint.Types: refa :: [Pred] -> Refa
- Language.Fixpoint.Types: reft :: Symbol -> Pred -> Reft
- Language.Fixpoint.Types: reftBind :: Reft -> Symbol
- Language.Fixpoint.Types: reftPred :: Reft -> Pred
- Language.Fixpoint.Types: removeLhsKvars :: t -> t1 -> t2
- Language.Fixpoint.Types: resSolution :: Result a -> HashMap KVar Pred
- Language.Fixpoint.Types: resStatus :: Result a -> FixResult (SubC a)
- Language.Fixpoint.Types: resultDoc :: (Ord a, Fixpoint a) => FixResult a -> Doc
- Language.Fixpoint.Types: rhsCs :: SubC a -> Reft
- Language.Fixpoint.Types: senv :: SubC a -> IBindEnv
- Language.Fixpoint.Types: sgrd :: SubC a -> Pred
- Language.Fixpoint.Types: shiftVV :: Reft -> Symbol -> Reft
- Language.Fixpoint.Types: showFix :: Fixpoint a => a -> String
- Language.Fixpoint.Types: sid :: SubC a -> (Maybe Integer)
- Language.Fixpoint.Types: simplify :: Fixpoint a => a -> a
- Language.Fixpoint.Types: sinfo :: SubC a -> a
- Language.Fixpoint.Types: slhs :: SubC a -> SortedReft
- Language.Fixpoint.Types: sortFTycon :: Sort -> Maybe FTycon
- Language.Fixpoint.Types: sortSubst :: HashMap Symbol Sort -> Sort -> Sort
- Language.Fixpoint.Types: squishRefas :: [Refa] -> [Refa]
- Language.Fixpoint.Types: sr_reft :: SortedReft -> !Reft
- Language.Fixpoint.Types: sr_sort :: SortedReft -> !Sort
- Language.Fixpoint.Types: srhs :: SubC a -> SortedReft
- Language.Fixpoint.Types: strSort :: Sort
- Language.Fixpoint.Types: subC :: IBindEnv -> Pred -> SortedReft -> SortedReft -> Maybe Integer -> Tag -> a -> [SubC a]
- Language.Fixpoint.Types: subcId :: SubC a -> Integer
- Language.Fixpoint.Types: subst :: Subable a => Subst -> a -> a
- Language.Fixpoint.Types: subst1 :: Subable a => a -> (Symbol, Expr) -> a
- Language.Fixpoint.Types: subst1Except :: Subable a => [Symbol] -> a -> (Symbol, Expr) -> a
- Language.Fixpoint.Types: substExcept :: Subst -> [Symbol] -> Subst
- Language.Fixpoint.Types: substa :: Subable a => (Symbol -> Symbol) -> a -> a
- Language.Fixpoint.Types: substf :: Subable a => (Symbol -> Expr) -> a -> a
- Language.Fixpoint.Types: substfExcept :: (Symbol -> Expr) -> [Symbol] -> Symbol -> Expr
- Language.Fixpoint.Types: suffixSymbol :: Symbol -> Text -> Symbol
- Language.Fixpoint.Types: symChars :: [Char]
- Language.Fixpoint.Types: symConstLits :: FInfo a -> [(Symbol, Sort)]
- Language.Fixpoint.Types: symbol :: Symbolic a => a -> Symbol
- Language.Fixpoint.Types: symbolFTycon :: LocSymbol -> FTycon
- Language.Fixpoint.Types: symbolReft :: Symbolic a => a -> Reft
- Language.Fixpoint.Types: symbolString :: Symbol -> String
- Language.Fixpoint.Types: symbolText :: Symbol -> Text
- Language.Fixpoint.Types: syms :: Subable a => a -> [Symbol]
- Language.Fixpoint.Types: targetSubstSyms :: Subst -> [Symbol]
- Language.Fixpoint.Types: tempPrefix :: Symbol
- Language.Fixpoint.Types: tempSymbol :: Symbol -> Integer -> Symbol
- Language.Fixpoint.Types: toFix :: Fixpoint a => a -> Doc
- Language.Fixpoint.Types: toFixpoint :: Fixpoint a => Config -> FInfo a -> Doc
- Language.Fixpoint.Types: toListSEnv :: SEnv a -> [(Symbol, a)]
- Language.Fixpoint.Types: toReft :: Reftable r => r -> Reft
- Language.Fixpoint.Types: top :: Reftable r => r -> r
- Language.Fixpoint.Types: traceFix :: Fixpoint a => String -> a -> a
- Language.Fixpoint.Types: trueRefa :: Refa
- Language.Fixpoint.Types: trueReft :: Reft
- Language.Fixpoint.Types: trueSortedReft :: Sort -> SortedReft
- Language.Fixpoint.Types: trueSubCKvar :: KVar -> a -> [SubC a]
- Language.Fixpoint.Types: type BindId = Int
- Language.Fixpoint.Types: type BindMap a = HashMap BindId a
- Language.Fixpoint.Types: type FEnv = SEnv SortedReft
- Language.Fixpoint.Types: type FixSolution = HashMap KVar Pred
- Language.Fixpoint.Types: type LocSymbol = Located Symbol
- Language.Fixpoint.Types: type LocText = Located Text
- Language.Fixpoint.Types: type TCEmb a = HashMap a FTycon
- Language.Fixpoint.Types: type Tag = [Int]
- Language.Fixpoint.Types: uexprReft :: Expression a => a -> Reft
- Language.Fixpoint.Types: unionIBindEnv :: IBindEnv -> IBindEnv -> IBindEnv
- Language.Fixpoint.Types: usymbolReft :: Symbolic a => a -> Reft
- Language.Fixpoint.Types: val :: Located a -> a
- Language.Fixpoint.Types: vv :: Maybe Integer -> Symbol
- Language.Fixpoint.Types: vv_ :: Symbol
- Language.Fixpoint.Types: wenv :: WfC a -> !IBindEnv
- Language.Fixpoint.Types: wfC :: IBindEnv -> SortedReft -> Maybe Integer -> a -> WfC a
- Language.Fixpoint.Types: wid :: WfC a -> !(Maybe Integer)
- Language.Fixpoint.Types: winfo :: WfC a -> !a
- Language.Fixpoint.Types: wrft :: WfC a -> !SortedReft
- Language.Fixpoint.Types: ws :: FInfo a -> ![WfC a]
- Language.Fixpoint.Visitor: Visitor :: (ctx -> Expr -> ctx) -> (ctx -> Pred -> ctx) -> (ctx -> Expr -> Expr) -> (ctx -> Pred -> Pred) -> (ctx -> Expr -> acc) -> (ctx -> Pred -> acc) -> Visitor acc ctx
- Language.Fixpoint.Visitor: accExpr :: Visitor acc ctx -> ctx -> Expr -> acc
- Language.Fixpoint.Visitor: accPred :: Visitor acc ctx -> ctx -> Pred -> acc
- Language.Fixpoint.Visitor: ctxExpr :: Visitor acc ctx -> ctx -> Expr -> ctx
- Language.Fixpoint.Visitor: ctxPred :: Visitor acc ctx -> ctx -> Pred -> ctx
- Language.Fixpoint.Visitor: data Visitor acc ctx
- Language.Fixpoint.Visitor: defaultVisitor :: Monoid acc => Visitor acc ctx
- Language.Fixpoint.Visitor: envKVars :: BindEnv -> SubC a -> [KVar]
- Language.Fixpoint.Visitor: fold :: (Visitable t, Monoid a) => Visitor a ctx -> ctx -> a -> t -> a
- Language.Fixpoint.Visitor: foldSort :: (a -> Sort -> a) -> a -> Sort -> a
- Language.Fixpoint.Visitor: instance Visitable Expr
- Language.Fixpoint.Visitor: instance Visitable Pred
- Language.Fixpoint.Visitor: instance Visitable Refa
- Language.Fixpoint.Visitor: instance Visitable Reft
- Language.Fixpoint.Visitor: kvars :: Visitable t => t -> [KVar]
- Language.Fixpoint.Visitor: mapKVars :: Visitable t => (KVar -> Maybe Pred) -> t -> t
- Language.Fixpoint.Visitor: mapKVars' :: Visitable t => ((KVar, Subst) -> Maybe Pred) -> t -> t
- Language.Fixpoint.Visitor: mapSort :: (Sort -> Sort) -> Sort -> Sort
- Language.Fixpoint.Visitor: trans :: (Visitable t, Monoid a) => Visitor a ctx -> ctx -> a -> t -> t
- Language.Fixpoint.Visitor: txExpr :: Visitor acc ctx -> ctx -> Expr -> Expr
- Language.Fixpoint.Visitor: txPred :: Visitor acc ctx -> ctx -> Pred -> Pred
+ Language.Fixpoint.Minimize: minQuery :: (NFData a, Fixpoint a) => Config -> Solver a -> FInfo a -> IO (Result (Integer, a))
+ Language.Fixpoint.Misc: asyncMapM :: (a -> IO b) -> [a] -> IO [b]
+ Language.Fixpoint.Misc: count :: (Eq k, Hashable k) => [k] -> [(k, Int)]
+ Language.Fixpoint.Misc: editDistance :: Eq a => [a] -> [a] -> Int
+ Language.Fixpoint.Misc: ensurePath :: FilePath -> IO ()
+ Language.Fixpoint.Misc: fM :: (Monad m) => (a -> b) -> a -> m b
+ Language.Fixpoint.Misc: firstMaybe :: (a -> Maybe b) -> [a] -> Maybe b
+ Language.Fixpoint.Misc: putBlankLn :: IO ()
+ Language.Fixpoint.Misc: writeLoud :: String -> IO ()
+ Language.Fixpoint.Parse: instance GHC.Generics.Constructor Language.Fixpoint.Parse.C1_0Def
+ Language.Fixpoint.Parse: instance GHC.Generics.Constructor Language.Fixpoint.Parse.C1_1Def
+ Language.Fixpoint.Parse: instance GHC.Generics.Constructor Language.Fixpoint.Parse.C1_2Def
+ Language.Fixpoint.Parse: instance GHC.Generics.Constructor Language.Fixpoint.Parse.C1_3Def
+ Language.Fixpoint.Parse: instance GHC.Generics.Constructor Language.Fixpoint.Parse.C1_4Def
+ Language.Fixpoint.Parse: instance GHC.Generics.Constructor Language.Fixpoint.Parse.C1_5Def
+ Language.Fixpoint.Parse: instance GHC.Generics.Constructor Language.Fixpoint.Parse.C1_6Def
+ Language.Fixpoint.Parse: instance GHC.Generics.Constructor Language.Fixpoint.Parse.C1_7Def
+ Language.Fixpoint.Parse: instance GHC.Generics.Datatype Language.Fixpoint.Parse.D1Def
+ Language.Fixpoint.Parse: instance GHC.Generics.Generic (Language.Fixpoint.Parse.Def a)
+ Language.Fixpoint.Parse: instance Language.Fixpoint.Parse.Inputable (Language.Fixpoint.Types.Constraints.FInfo ())
+ Language.Fixpoint.Parse: instance Language.Fixpoint.Parse.Inputable (Language.Fixpoint.Types.Errors.FixResult GHC.Integer.Type.Integer)
+ Language.Fixpoint.Parse: instance Language.Fixpoint.Parse.Inputable (Language.Fixpoint.Types.Errors.FixResult GHC.Integer.Type.Integer, Language.Fixpoint.Types.Constraints.FixSolution)
+ Language.Fixpoint.Parse: instance Language.Fixpoint.Parse.Inputable Language.Fixpoint.Smt.Types.Command
+ Language.Fixpoint.Parse: instance Language.Fixpoint.Parse.Inputable Language.Fixpoint.Types.Names.Symbol
+ Language.Fixpoint.Parse: instance Language.Fixpoint.Parse.Inputable Language.Fixpoint.Types.Refinements.Constant
+ Language.Fixpoint.Parse: instance Language.Fixpoint.Parse.Inputable Language.Fixpoint.Types.Refinements.Expr
+ Language.Fixpoint.Parse: instance Language.Fixpoint.Parse.Inputable [Language.Fixpoint.Smt.Types.Command]
+ Language.Fixpoint.Parse: instance Language.Fixpoint.Types.PrettyPrint.Fixpoint a => GHC.Show.Show (Language.Fixpoint.Parse.Def a)
+ Language.Fixpoint.Parse: isSmall :: Char -> Bool
+ Language.Fixpoint.Parse: pairP :: Parser a -> Parser z -> Parser b -> Parser (a, b)
+ Language.Fixpoint.Parse: sortP :: Parser Sort
+ Language.Fixpoint.Partition: CPart :: HashMap KVar (WfC a) -> HashMap Integer (SubC a) -> FilePath -> CPart a
+ Language.Fixpoint.Partition: Deps :: !(HashSet a) -> !(HashSet a) -> GDeps a
+ Language.Fixpoint.Partition: MCInfo :: Int -> Int -> Int -> MCInfo
+ Language.Fixpoint.Partition: [cFileName] :: CPart a -> FilePath
+ Language.Fixpoint.Partition: [depCuts] :: GDeps a -> !(HashSet a)
+ Language.Fixpoint.Partition: [depNonCuts] :: GDeps a -> !(HashSet a)
+ Language.Fixpoint.Partition: [mcCores] :: MCInfo -> Int
+ Language.Fixpoint.Partition: [mcMaxPartSize] :: MCInfo -> Int
+ Language.Fixpoint.Partition: [mcMinPartSize] :: MCInfo -> Int
+ Language.Fixpoint.Partition: [pcm] :: CPart a -> HashMap Integer (SubC a)
+ Language.Fixpoint.Partition: [pws] :: CPart a -> HashMap KVar (WfC a)
+ Language.Fixpoint.Partition: data CPart a
+ Language.Fixpoint.Partition: data GDeps a
+ Language.Fixpoint.Partition: data MCInfo
+ Language.Fixpoint.Partition: deps :: (TaggedC c a) => GInfo c a -> GDeps KVar
+ Language.Fixpoint.Partition: elimSolGraph :: Config -> Solution -> IO ()
+ Language.Fixpoint.Partition: graphStatistics :: Config -> SInfo a -> IO ()
+ Language.Fixpoint.Partition: instance (GHC.Classes.Eq a, Data.Hashable.Class.Hashable a) => GHC.Base.Monoid (Language.Fixpoint.Partition.GDeps a)
+ Language.Fixpoint.Partition: instance GHC.Base.Monoid (Language.Fixpoint.Partition.CPart a)
+ Language.Fixpoint.Partition: instance GHC.Show.Show Language.Fixpoint.Partition.MCInfo
+ Language.Fixpoint.Partition: instance GHC.Show.Show a => GHC.Show.Show (Language.Fixpoint.Partition.GDeps a)
+ Language.Fixpoint.Partition: instance Language.Fixpoint.Types.PrettyPrint.PTable Language.Fixpoint.Partition.Stats
+ Language.Fixpoint.Partition: mcInfo :: Config -> IO MCInfo
+ Language.Fixpoint.Partition: partitionN :: MCInfo -> FInfo a -> [CPart a] -> [FInfo a]
+ Language.Fixpoint.Smt.Bitvector: Bv :: BvSize -> String -> Bv
+ Language.Fixpoint.Smt.Bitvector: BvAnd :: BvOp
+ Language.Fixpoint.Smt.Bitvector: BvOr :: BvOp
+ Language.Fixpoint.Smt.Bitvector: S32 :: BvSize
+ Language.Fixpoint.Smt.Bitvector: S64 :: BvSize
+ Language.Fixpoint.Smt.Bitvector: bvTyCon :: FTycon
+ Language.Fixpoint.Smt.Bitvector: data Bv
+ Language.Fixpoint.Smt.Bitvector: data BvOp
+ Language.Fixpoint.Smt.Bitvector: data BvSize
+ Language.Fixpoint.Smt.Bitvector: eOp :: BvOp -> [Expr] -> Expr
+ Language.Fixpoint.Smt.Bitvector: instance Data.Data.Data Language.Fixpoint.Smt.Bitvector.BvOp
+ Language.Fixpoint.Smt.Bitvector: instance Data.Data.Data Language.Fixpoint.Smt.Bitvector.BvSize
+ Language.Fixpoint.Smt.Bitvector: instance GHC.Classes.Eq Language.Fixpoint.Smt.Bitvector.BvOp
+ Language.Fixpoint.Smt.Bitvector: instance GHC.Classes.Eq Language.Fixpoint.Smt.Bitvector.BvSize
+ Language.Fixpoint.Smt.Bitvector: instance GHC.Classes.Ord Language.Fixpoint.Smt.Bitvector.BvOp
+ Language.Fixpoint.Smt.Bitvector: instance GHC.Classes.Ord Language.Fixpoint.Smt.Bitvector.BvSize
+ Language.Fixpoint.Smt.Bitvector: instance GHC.Generics.Constructor Language.Fixpoint.Smt.Bitvector.C1_0BvOp
+ Language.Fixpoint.Smt.Bitvector: instance GHC.Generics.Constructor Language.Fixpoint.Smt.Bitvector.C1_0BvSize
+ Language.Fixpoint.Smt.Bitvector: instance GHC.Generics.Constructor Language.Fixpoint.Smt.Bitvector.C1_1BvOp
+ Language.Fixpoint.Smt.Bitvector: instance GHC.Generics.Constructor Language.Fixpoint.Smt.Bitvector.C1_1BvSize
+ Language.Fixpoint.Smt.Bitvector: instance GHC.Generics.Datatype Language.Fixpoint.Smt.Bitvector.D1BvOp
+ Language.Fixpoint.Smt.Bitvector: instance GHC.Generics.Datatype Language.Fixpoint.Smt.Bitvector.D1BvSize
+ Language.Fixpoint.Smt.Bitvector: instance GHC.Generics.Generic Language.Fixpoint.Smt.Bitvector.BvOp
+ Language.Fixpoint.Smt.Bitvector: instance GHC.Generics.Generic Language.Fixpoint.Smt.Bitvector.BvSize
+ Language.Fixpoint.Smt.Bitvector: instance GHC.Show.Show Language.Fixpoint.Smt.Bitvector.BvOp
+ Language.Fixpoint.Smt.Bitvector: instance GHC.Show.Show Language.Fixpoint.Smt.Bitvector.BvSize
+ Language.Fixpoint.Smt.Bitvector: instance Language.Fixpoint.Types.Refinements.Expression Language.Fixpoint.Smt.Bitvector.Bv
+ Language.Fixpoint.Smt.Bitvector: mkSort :: BvSize -> Sort
+ Language.Fixpoint.Smt.Interface: CMany :: [Command] -> Command
+ Language.Fixpoint.Smt.Interface: [cIn] :: Context -> Handle
+ Language.Fixpoint.Smt.Interface: [cLog] :: Context -> Maybe Handle
+ Language.Fixpoint.Smt.Interface: [cOut] :: Context -> Handle
+ Language.Fixpoint.Smt.Interface: [pId] :: Context -> ProcessHandle
+ Language.Fixpoint.Smt.Interface: [smtenv] :: Context -> SMTEnv
+ Language.Fixpoint.Smt.Interface: [verbose] :: Context -> Bool
+ Language.Fixpoint.Smt.Interface: checkValid :: Bool -> FilePath -> [(Symbol, Sort)] -> Expr -> Expr -> IO Bool
+ Language.Fixpoint.Smt.Interface: checkValidWithContext :: Context -> [(Symbol, Sort)] -> Expr -> Expr -> IO Bool
+ Language.Fixpoint.Smt.Interface: checkValids :: Bool -> FilePath -> [(Symbol, Sort)] -> [Expr] -> IO [Bool]
+ Language.Fixpoint.Smt.Interface: defunc :: SMTLIB2 a => a -> SMT2 a
+ Language.Fixpoint.Smt.Interface: makeContextWithSEnv :: Bool -> SMTSolver -> FilePath -> SMTEnv -> IO Context
+ Language.Fixpoint.Smt.Interface: makeZ3Context :: FilePath -> [(Symbol, Sort)] -> IO Context
+ Language.Fixpoint.Smt.Interface: runSmt2 :: SMTLIB2 a => SMTEnv -> a -> Text
+ Language.Fixpoint.Smt.Interface: smtCheckSat :: Context -> Expr -> IO Bool
+ Language.Fixpoint.Smt.Serialize: castWith :: Symbol -> Expr -> SMT2 Expr
+ Language.Fixpoint.Smt.Serialize: defineFun :: (Symbol, Expr) -> SMT2 [Command]
+ Language.Fixpoint.Smt.Serialize: defuncApp :: Expr -> SMT2 Expr
+ Language.Fixpoint.Smt.Serialize: defuncApp' :: Expr -> [Expr] -> SMT2 Expr
+ Language.Fixpoint.Smt.Serialize: defuncBop :: Bop -> Expr -> Expr -> StateT SMTSt Identity Expr
+ Language.Fixpoint.Smt.Serialize: eliminate :: Expr -> Expr
+ Language.Fixpoint.Smt.Serialize: exprSort :: Expr -> Sort
+ Language.Fixpoint.Smt.Serialize: grapLambdas :: MonadState SMTSt m => Expr -> m (Expr, [(Symbol, Expr)])
+ Language.Fixpoint.Smt.Serialize: initSMTEnv :: SEnv Sort
+ Language.Fixpoint.Smt.Serialize: instance Language.Fixpoint.Smt.Types.SMTLIB2 (Language.Fixpoint.Types.Names.Symbol, Language.Fixpoint.Types.Sorts.Sort)
+ Language.Fixpoint.Smt.Serialize: instance Language.Fixpoint.Smt.Types.SMTLIB2 Language.Fixpoint.Smt.Types.Command
+ Language.Fixpoint.Smt.Serialize: instance Language.Fixpoint.Smt.Types.SMTLIB2 Language.Fixpoint.Types.Names.LocSymbol
+ Language.Fixpoint.Smt.Serialize: instance Language.Fixpoint.Smt.Types.SMTLIB2 Language.Fixpoint.Types.Names.Symbol
+ Language.Fixpoint.Smt.Serialize: instance Language.Fixpoint.Smt.Types.SMTLIB2 Language.Fixpoint.Types.Refinements.Bop
+ Language.Fixpoint.Smt.Serialize: instance Language.Fixpoint.Smt.Types.SMTLIB2 Language.Fixpoint.Types.Refinements.Brel
+ Language.Fixpoint.Smt.Serialize: instance Language.Fixpoint.Smt.Types.SMTLIB2 Language.Fixpoint.Types.Refinements.Constant
+ Language.Fixpoint.Smt.Serialize: instance Language.Fixpoint.Smt.Types.SMTLIB2 Language.Fixpoint.Types.Refinements.Expr
+ Language.Fixpoint.Smt.Serialize: instance Language.Fixpoint.Smt.Types.SMTLIB2 Language.Fixpoint.Types.Refinements.SymConst
+ Language.Fixpoint.Smt.Serialize: instance Language.Fixpoint.Smt.Types.SMTLIB2 Language.Fixpoint.Types.Sorts.Sort
+ Language.Fixpoint.Smt.Serialize: isSMTSort :: Sort -> Bool
+ Language.Fixpoint.Smt.Serialize: isSMTSymbol :: Symbol -> Bool
+ Language.Fixpoint.Smt.Serialize: makeApplication :: Expr -> [Expr] -> SMT2 Expr
+ Language.Fixpoint.Smt.Serialize: makeApplies :: Int -> [(Symbol, Sort)]
+ Language.Fixpoint.Smt.Serialize: makeFunSymbol :: Expr -> Int -> Symbol
+ Language.Fixpoint.Smt.Serialize: smt2many :: [Text] -> Text
+ Language.Fixpoint.Smt.Serialize: toInt :: Expr -> SMT2 Expr
+ Language.Fixpoint.Smt.Theories: isBv :: FTycon -> Bool
+ Language.Fixpoint.Smt.Theories: isTheorySymbol :: Symbol -> Bool
+ Language.Fixpoint.Smt.Theories: mapSel :: Symbol
+ Language.Fixpoint.Smt.Theories: mapSto :: Symbol
+ Language.Fixpoint.Smt.Theories: preamble :: Bool -> SMTSolver -> [Text]
+ Language.Fixpoint.Smt.Theories: setEmpty :: Symbol
+ Language.Fixpoint.Smt.Theories: sizeBv :: FTycon -> Maybe Int
+ Language.Fixpoint.Smt.Theories: smt2App :: Expr -> [Text] -> Maybe Text
+ Language.Fixpoint.Smt.Theories: smt2Sort :: Sort -> Maybe Text
+ Language.Fixpoint.Smt.Theories: smt2Symbol :: Symbol -> Maybe Text
+ Language.Fixpoint.Smt.Theories: theoryEnv :: HashMap Symbol Sort
+ Language.Fixpoint.Smt.Types: CMany :: [Command] -> Command
+ Language.Fixpoint.Smt.Types: SMTSt :: Int -> SMTEnv -> SMTSt
+ Language.Fixpoint.Smt.Types: [cIn] :: Context -> Handle
+ Language.Fixpoint.Smt.Types: [cLog] :: Context -> Maybe Handle
+ Language.Fixpoint.Smt.Types: [cOut] :: Context -> Handle
+ Language.Fixpoint.Smt.Types: [fresh] :: SMTSt -> Int
+ Language.Fixpoint.Smt.Types: [pId] :: Context -> ProcessHandle
+ Language.Fixpoint.Smt.Types: [smt2env] :: SMTSt -> SMTEnv
+ Language.Fixpoint.Smt.Types: [smtenv] :: Context -> SMTEnv
+ Language.Fixpoint.Smt.Types: [tsRaw] :: TheorySymbol -> Raw
+ Language.Fixpoint.Smt.Types: [tsSort] :: TheorySymbol -> Sort
+ Language.Fixpoint.Smt.Types: [tsSym] :: TheorySymbol -> Symbol
+ Language.Fixpoint.Smt.Types: [verbose] :: Context -> Bool
+ Language.Fixpoint.Smt.Types: data SMTSt
+ Language.Fixpoint.Smt.Types: defunc :: SMTLIB2 a => a -> SMT2 a
+ Language.Fixpoint.Smt.Types: emptySMTEnv :: SEnv a
+ Language.Fixpoint.Smt.Types: format :: Params ps => Format -> ps -> Text
+ Language.Fixpoint.Smt.Types: freshSym :: MonadState SMTSt m => m Symbol
+ Language.Fixpoint.Smt.Types: instance GHC.Classes.Eq Language.Fixpoint.Smt.Types.Command
+ Language.Fixpoint.Smt.Types: instance GHC.Classes.Eq Language.Fixpoint.Smt.Types.Response
+ Language.Fixpoint.Smt.Types: instance GHC.Classes.Eq Language.Fixpoint.Smt.Types.TheorySymbol
+ Language.Fixpoint.Smt.Types: instance GHC.Classes.Ord Language.Fixpoint.Smt.Types.TheorySymbol
+ Language.Fixpoint.Smt.Types: instance GHC.Show.Show Language.Fixpoint.Smt.Types.Command
+ Language.Fixpoint.Smt.Types: instance GHC.Show.Show Language.Fixpoint.Smt.Types.Response
+ Language.Fixpoint.Smt.Types: instance GHC.Show.Show Language.Fixpoint.Smt.Types.TheorySymbol
+ Language.Fixpoint.Smt.Types: runSmt2 :: SMTLIB2 a => SMTEnv -> a -> Text
+ Language.Fixpoint.Smt.Types: type SMT2 = State SMTSt
+ Language.Fixpoint.Smt.Types: type SMTEnv = SEnv Sort
+ Language.Fixpoint.Smt.Types: withExtendedEnv :: (Foldable t, MonadState SMTSt m) => t (Symbol, Sort) -> m b -> m b
+ Language.Fixpoint.Solver: parseFInfo :: [FilePath] -> IO (FInfo a)
+ Language.Fixpoint.Solver: resultExit :: FixResult a -> ExitCode
+ Language.Fixpoint.Solver: solve :: (NFData a, Fixpoint a) => Solver a
+ Language.Fixpoint.Solver: solveFQ :: Config -> IO ExitCode
+ Language.Fixpoint.Solver: type Solver a = Config -> FInfo a -> IO (Result (Integer, a))
+ Language.Fixpoint.Solver.Eliminate: eliminate :: SInfo a -> (Solution, SInfo a)
+ Language.Fixpoint.Solver.Graph: cGraph :: (TaggedC c a) => GInfo c a -> CGraph
+ Language.Fixpoint.Solver.Graph: gSccs :: CGraph -> Int
+ Language.Fixpoint.Solver.Graph: graphRanks :: Graph -> (Vertex -> DepEdge) -> (CMap Int, [[Vertex]])
+ Language.Fixpoint.Solver.Graph: isTarget :: (TaggedC c a) => c a -> Bool
+ Language.Fixpoint.Solver.Graph: kvReadBy :: (TaggedC c a) => GInfo c a -> KVRead
+ Language.Fixpoint.Solver.Graph: kvWriteBy :: (TaggedC c a) => CMap (c a) -> CId -> [KVar]
+ Language.Fixpoint.Solver.Graph: slice :: (TaggedC c a) => GInfo c a -> GInfo c a
+ Language.Fixpoint.Solver.Monad: checkSat :: Expr -> SolveM Bool
+ Language.Fixpoint.Solver.Monad: data Stats
+ Language.Fixpoint.Solver.Monad: instance Control.DeepSeq.NFData Language.Fixpoint.Solver.Monad.Stats
+ Language.Fixpoint.Solver.Monad: instance GHC.Generics.Constructor Language.Fixpoint.Solver.Monad.C1_0Stats
+ Language.Fixpoint.Solver.Monad: instance GHC.Generics.Datatype Language.Fixpoint.Solver.Monad.D1Stats
+ Language.Fixpoint.Solver.Monad: instance GHC.Generics.Generic Language.Fixpoint.Solver.Monad.Stats
+ Language.Fixpoint.Solver.Monad: instance GHC.Generics.Selector Language.Fixpoint.Solver.Monad.S1_0_0Stats
+ Language.Fixpoint.Solver.Monad: instance GHC.Generics.Selector Language.Fixpoint.Solver.Monad.S1_0_1Stats
+ Language.Fixpoint.Solver.Monad: instance GHC.Generics.Selector Language.Fixpoint.Solver.Monad.S1_0_2Stats
+ Language.Fixpoint.Solver.Monad: instance GHC.Generics.Selector Language.Fixpoint.Solver.Monad.S1_0_3Stats
+ Language.Fixpoint.Solver.Monad: instance GHC.Generics.Selector Language.Fixpoint.Solver.Monad.S1_0_4Stats
+ Language.Fixpoint.Solver.Monad: instance GHC.Show.Show Language.Fixpoint.Solver.Monad.Stats
+ Language.Fixpoint.Solver.Monad: instance Language.Fixpoint.Types.PrettyPrint.PTable Language.Fixpoint.Solver.Monad.Stats
+ Language.Fixpoint.Solver.Monad: numIter :: Stats -> Int
+ Language.Fixpoint.Solver.Monad: smtEnablrmbqi :: SolveM ()
+ Language.Fixpoint.Solver.Monad: stats :: SolveM Stats
+ Language.Fixpoint.Solver.Solution: lhsPred :: BindEnv -> Solution -> SimpC a -> Expr
+ Language.Fixpoint.Solver.Solution: noKvars :: Expr -> Bool
+ Language.Fixpoint.Solver.Solution: solutionGraph :: Solution -> KVGraph
+ Language.Fixpoint.Solver.Solve: gradualSolve :: (Fixpoint a) => Config -> FixResult (SimpC a) -> SolveM (FixResult (SimpC a))
+ Language.Fixpoint.Solver.TrivialSort: instance Data.Hashable.Class.Hashable Language.Fixpoint.Solver.TrivialSort.NTV
+ Language.Fixpoint.Solver.TrivialSort: instance GHC.Classes.Eq Language.Fixpoint.Solver.TrivialSort.NTV
+ Language.Fixpoint.Solver.TrivialSort: instance GHC.Classes.Ord Language.Fixpoint.Solver.TrivialSort.NTV
+ Language.Fixpoint.Solver.TrivialSort: instance GHC.Generics.Constructor Language.Fixpoint.Solver.TrivialSort.C1_0NTV
+ Language.Fixpoint.Solver.TrivialSort: instance GHC.Generics.Constructor Language.Fixpoint.Solver.TrivialSort.C1_1NTV
+ Language.Fixpoint.Solver.TrivialSort: instance GHC.Generics.Constructor Language.Fixpoint.Solver.TrivialSort.C1_2NTV
+ Language.Fixpoint.Solver.TrivialSort: instance GHC.Generics.Datatype Language.Fixpoint.Solver.TrivialSort.D1NTV
+ Language.Fixpoint.Solver.TrivialSort: instance GHC.Generics.Generic Language.Fixpoint.Solver.TrivialSort.NTV
+ Language.Fixpoint.Solver.TrivialSort: instance GHC.Show.Show Language.Fixpoint.Solver.TrivialSort.NTV
+ Language.Fixpoint.Solver.TrivialSort: nontrivsorts :: (Fixpoint a) => Config -> FInfo a -> IO (Result a)
+ Language.Fixpoint.Solver.Types: CGraph :: [DepEdge] -> CMap Int -> CSucc -> Int -> CGraph
+ Language.Fixpoint.Solver.Types: Slice :: [CId] -> [CId] -> [DepEdge] -> Slice
+ Language.Fixpoint.Solver.Types: [gEdges] :: CGraph -> [DepEdge]
+ Language.Fixpoint.Solver.Types: [gRanks] :: CGraph -> CMap Int
+ Language.Fixpoint.Solver.Types: [gSccs] :: CGraph -> Int
+ Language.Fixpoint.Solver.Types: [gSucc] :: CGraph -> CSucc
+ Language.Fixpoint.Solver.Types: [slConcCs] :: Slice -> [CId]
+ Language.Fixpoint.Solver.Types: [slEdges] :: Slice -> [DepEdge]
+ Language.Fixpoint.Solver.Types: [slKVarCs] :: Slice -> [CId]
+ Language.Fixpoint.Solver.Types: data CGraph
+ Language.Fixpoint.Solver.Types: data Slice
+ Language.Fixpoint.Solver.Types: instance GHC.Classes.Eq Language.Fixpoint.Solver.Types.Slice
+ Language.Fixpoint.Solver.Types: instance GHC.Show.Show Language.Fixpoint.Solver.Types.Slice
+ Language.Fixpoint.Solver.Types: lookupCMap :: (?callStack :: CallStack) => CMap a -> CId -> a
+ Language.Fixpoint.Solver.Types: type CId = Integer
+ Language.Fixpoint.Solver.Types: type CMap a = HashMap CId a
+ Language.Fixpoint.Solver.Types: type CSucc = CId -> [CId]
+ Language.Fixpoint.Solver.Types: type DepEdge = (CId, CId, [CId])
+ Language.Fixpoint.Solver.Types: type KVRead = HashMap KVar [CId]
+ Language.Fixpoint.Solver.UniqifyBinds: instance Control.DeepSeq.NFData Language.Fixpoint.Solver.UniqifyBinds.Ref
+ Language.Fixpoint.Solver.UniqifyBinds: instance Data.Hashable.Class.Hashable Language.Fixpoint.Solver.UniqifyBinds.Ref
+ Language.Fixpoint.Solver.UniqifyBinds: instance GHC.Classes.Eq Language.Fixpoint.Solver.UniqifyBinds.Ref
+ Language.Fixpoint.Solver.UniqifyBinds: instance GHC.Generics.Constructor Language.Fixpoint.Solver.UniqifyBinds.C1_0Ref
+ Language.Fixpoint.Solver.UniqifyBinds: instance GHC.Generics.Constructor Language.Fixpoint.Solver.UniqifyBinds.C1_1Ref
+ Language.Fixpoint.Solver.UniqifyBinds: instance GHC.Generics.Datatype Language.Fixpoint.Solver.UniqifyBinds.D1Ref
+ Language.Fixpoint.Solver.UniqifyBinds: instance GHC.Generics.Generic Language.Fixpoint.Solver.UniqifyBinds.Ref
+ Language.Fixpoint.Solver.UniqifyBinds: renameAll :: SInfo a -> SInfo a
+ Language.Fixpoint.Solver.UniqifyKVars: wfcUniqify :: SInfo a -> SInfo a
+ Language.Fixpoint.Solver.Validate: sanitize :: SInfo a -> ValidateM (SInfo a)
+ Language.Fixpoint.Solver.Worklist: data Stats
+ Language.Fixpoint.Solver.Worklist: instance GHC.Classes.Eq Language.Fixpoint.Solver.Worklist.Rank
+ Language.Fixpoint.Solver.Worklist: instance GHC.Classes.Eq Language.Fixpoint.Solver.Worklist.Stats
+ Language.Fixpoint.Solver.Worklist: instance GHC.Classes.Eq Language.Fixpoint.Solver.Worklist.WorkItem
+ Language.Fixpoint.Solver.Worklist: instance GHC.Classes.Ord Language.Fixpoint.Solver.Worklist.WorkItem
+ Language.Fixpoint.Solver.Worklist: instance GHC.Show.Show Language.Fixpoint.Solver.Worklist.Rank
+ Language.Fixpoint.Solver.Worklist: instance GHC.Show.Show Language.Fixpoint.Solver.Worklist.Stats
+ Language.Fixpoint.Solver.Worklist: instance GHC.Show.Show Language.Fixpoint.Solver.Worklist.WorkItem
+ Language.Fixpoint.Solver.Worklist: instance Language.Fixpoint.Types.PrettyPrint.PPrint (Language.Fixpoint.Solver.Worklist.Worklist a)
+ Language.Fixpoint.Solver.Worklist: instance Language.Fixpoint.Types.PrettyPrint.PPrint Language.Fixpoint.Solver.Worklist.WorkItem
+ Language.Fixpoint.Solver.Worklist: instance Language.Fixpoint.Types.PrettyPrint.PTable (Language.Fixpoint.Solver.Worklist.Worklist a)
+ Language.Fixpoint.Solver.Worklist: instance Language.Fixpoint.Types.PrettyPrint.PTable Language.Fixpoint.Solver.Worklist.Stats
+ Language.Fixpoint.Solver.Worklist: unsatCandidates :: Worklist a -> [SimpC a]
+ Language.Fixpoint.Solver.Worklist: wRanks :: Worklist a -> Int
+ Language.Fixpoint.SortCheck: apply :: TVSubst -> Sort -> Sort
+ Language.Fixpoint.SortCheck: boolSort :: Sort
+ Language.Fixpoint.SortCheck: checkSortExpr :: SEnv Sort -> Expr -> Maybe Sort
+ Language.Fixpoint.SortCheck: checkSortFull :: Checkable a => SEnv SortedReft -> Sort -> a -> Maybe Doc
+ Language.Fixpoint.SortCheck: checkSorted :: Checkable a => SEnv Sort -> a -> Maybe Doc
+ Language.Fixpoint.SortCheck: checkSortedReft :: SEnv SortedReft -> [Symbol] -> SortedReft -> Maybe Doc
+ Language.Fixpoint.SortCheck: checkSortedReftFull :: Checkable a => SEnv SortedReft -> a -> Maybe Doc
+ Language.Fixpoint.SortCheck: data TVSubst
+ Language.Fixpoint.SortCheck: elaborate :: SEnv Sort -> Expr -> Expr
+ Language.Fixpoint.SortCheck: instance Control.Monad.Error.Class.MonadError GHC.Base.String Language.Fixpoint.SortCheck.CheckM
+ Language.Fixpoint.SortCheck: instance GHC.Base.Applicative Language.Fixpoint.SortCheck.CheckM
+ Language.Fixpoint.SortCheck: instance GHC.Base.Functor Language.Fixpoint.SortCheck.CheckM
+ Language.Fixpoint.SortCheck: instance GHC.Base.Monad Language.Fixpoint.SortCheck.CheckM
+ Language.Fixpoint.SortCheck: instance GHC.Show.Show Language.Fixpoint.SortCheck.TVSubst
+ Language.Fixpoint.SortCheck: instance Language.Fixpoint.SortCheck.Checkable Language.Fixpoint.Types.Refinements.Expr
+ Language.Fixpoint.SortCheck: instance Language.Fixpoint.SortCheck.Checkable Language.Fixpoint.Types.Refinements.SortedReft
+ Language.Fixpoint.SortCheck: instance Language.Fixpoint.SortCheck.Freshable GHC.Types.Int
+ Language.Fixpoint.SortCheck: instance Language.Fixpoint.SortCheck.Freshable [GHC.Types.Int]
+ Language.Fixpoint.SortCheck: isFirstOrder :: Sort -> Bool
+ Language.Fixpoint.SortCheck: isMono :: Sort -> Bool
+ Language.Fixpoint.SortCheck: pruneUnsortedReft :: SEnv Sort -> SortedReft -> SortedReft
+ Language.Fixpoint.SortCheck: sortExpr :: SrcSpan -> SEnv Sort -> Expr -> Sort
+ Language.Fixpoint.SortCheck: strSort :: Sort
+ Language.Fixpoint.SortCheck: type Env = Symbol -> SESearch Sort
+ Language.Fixpoint.SortCheck: unify :: Env -> Sort -> Sort -> Maybe TVSubst
+ Language.Fixpoint.SortCheck: unifyFast :: Bool -> Env -> Sort -> Sort -> Maybe TVSubst
+ Language.Fixpoint.Types.Config: Config :: FilePath -> FilePath -> FilePath -> Maybe Int -> Int -> Int -> SMTSolver -> GenQualifierSort -> UeqAllSorts -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Config
+ Language.Fixpoint.Types.Config: Cvc4 :: SMTSolver
+ Language.Fixpoint.Types.Config: GQS :: Bool -> GenQualifierSort
+ Language.Fixpoint.Types.Config: Mathsat :: SMTSolver
+ Language.Fixpoint.Types.Config: UAS :: Bool -> UeqAllSorts
+ Language.Fixpoint.Types.Config: Z3 :: SMTSolver
+ Language.Fixpoint.Types.Config: [allowHO] :: Config -> Bool
+ Language.Fixpoint.Types.Config: [cores] :: Config -> Maybe Int
+ Language.Fixpoint.Types.Config: [elimStats] :: Config -> Bool
+ Language.Fixpoint.Types.Config: [eliminate] :: Config -> Bool
+ Language.Fixpoint.Types.Config: [genSorts] :: Config -> GenQualifierSort
+ Language.Fixpoint.Types.Config: [gradual] :: Config -> Bool
+ Language.Fixpoint.Types.Config: [inFile] :: Config -> FilePath
+ Language.Fixpoint.Types.Config: [linear] :: Config -> Bool
+ Language.Fixpoint.Types.Config: [maxPartSize] :: Config -> Int
+ Language.Fixpoint.Types.Config: [metadata] :: Config -> Bool
+ Language.Fixpoint.Types.Config: [minPartSize] :: Config -> Int
+ Language.Fixpoint.Types.Config: [minimize] :: Config -> Bool
+ Language.Fixpoint.Types.Config: [newcheck] :: Config -> Bool
+ Language.Fixpoint.Types.Config: [outFile] :: Config -> FilePath
+ Language.Fixpoint.Types.Config: [parts] :: Config -> Bool
+ Language.Fixpoint.Types.Config: [save] :: Config -> Bool
+ Language.Fixpoint.Types.Config: [solverStats] :: Config -> Bool
+ Language.Fixpoint.Types.Config: [solver] :: Config -> SMTSolver
+ Language.Fixpoint.Types.Config: [srcFile] :: Config -> FilePath
+ Language.Fixpoint.Types.Config: [stats] :: Config -> Bool
+ Language.Fixpoint.Types.Config: [ueqAllSorts] :: Config -> UeqAllSorts
+ Language.Fixpoint.Types.Config: class Command a
+ Language.Fixpoint.Types.Config: command :: Command a => a -> String
+ Language.Fixpoint.Types.Config: data Config
+ Language.Fixpoint.Types.Config: data SMTSolver
+ Language.Fixpoint.Types.Config: defaultMaxPartSize :: Int
+ Language.Fixpoint.Types.Config: defaultMinPartSize :: Int
+ Language.Fixpoint.Types.Config: getOpts :: IO Config
+ Language.Fixpoint.Types.Config: instance Data.Data.Data Language.Fixpoint.Types.Config.Config
+ Language.Fixpoint.Types.Config: instance Data.Data.Data Language.Fixpoint.Types.Config.GenQualifierSort
+ Language.Fixpoint.Types.Config: instance Data.Data.Data Language.Fixpoint.Types.Config.SMTSolver
+ Language.Fixpoint.Types.Config: instance Data.Data.Data Language.Fixpoint.Types.Config.UeqAllSorts
+ Language.Fixpoint.Types.Config: instance GHC.Classes.Eq Language.Fixpoint.Types.Config.Config
+ Language.Fixpoint.Types.Config: instance GHC.Classes.Eq Language.Fixpoint.Types.Config.GenQualifierSort
+ Language.Fixpoint.Types.Config: instance GHC.Classes.Eq Language.Fixpoint.Types.Config.SMTSolver
+ Language.Fixpoint.Types.Config: instance GHC.Classes.Eq Language.Fixpoint.Types.Config.UeqAllSorts
+ Language.Fixpoint.Types.Config: instance GHC.Generics.Constructor Language.Fixpoint.Types.Config.C1_0SMTSolver
+ Language.Fixpoint.Types.Config: instance GHC.Generics.Constructor Language.Fixpoint.Types.Config.C1_1SMTSolver
+ Language.Fixpoint.Types.Config: instance GHC.Generics.Constructor Language.Fixpoint.Types.Config.C1_2SMTSolver
+ Language.Fixpoint.Types.Config: instance GHC.Generics.Datatype Language.Fixpoint.Types.Config.D1SMTSolver
+ Language.Fixpoint.Types.Config: instance GHC.Generics.Generic Language.Fixpoint.Types.Config.SMTSolver
+ Language.Fixpoint.Types.Config: instance GHC.Show.Show Language.Fixpoint.Types.Config.Config
+ Language.Fixpoint.Types.Config: instance GHC.Show.Show Language.Fixpoint.Types.Config.GenQualifierSort
+ Language.Fixpoint.Types.Config: instance GHC.Show.Show Language.Fixpoint.Types.Config.SMTSolver
+ Language.Fixpoint.Types.Config: instance GHC.Show.Show Language.Fixpoint.Types.Config.UeqAllSorts
+ Language.Fixpoint.Types.Config: instance Language.Fixpoint.Types.Config.Command Language.Fixpoint.Types.Config.Config
+ Language.Fixpoint.Types.Config: instance Language.Fixpoint.Types.Config.Command Language.Fixpoint.Types.Config.GenQualifierSort
+ Language.Fixpoint.Types.Config: instance Language.Fixpoint.Types.Config.Command Language.Fixpoint.Types.Config.SMTSolver
+ Language.Fixpoint.Types.Config: instance Language.Fixpoint.Types.Config.Command Language.Fixpoint.Types.Config.UeqAllSorts
+ Language.Fixpoint.Types.Config: instance System.Console.CmdArgs.Default.Default Language.Fixpoint.Types.Config.Config
+ Language.Fixpoint.Types.Config: instance System.Console.CmdArgs.Default.Default Language.Fixpoint.Types.Config.GenQualifierSort
+ Language.Fixpoint.Types.Config: instance System.Console.CmdArgs.Default.Default Language.Fixpoint.Types.Config.SMTSolver
+ Language.Fixpoint.Types.Config: instance System.Console.CmdArgs.Default.Default Language.Fixpoint.Types.Config.UeqAllSorts
+ Language.Fixpoint.Types.Config: multicore :: Config -> Bool
+ Language.Fixpoint.Types.Config: newtype GenQualifierSort
+ Language.Fixpoint.Types.Config: newtype UeqAllSorts
+ Language.Fixpoint.Types.Config: queryFile :: Ext -> Config -> FilePath
+ Language.Fixpoint.Types.Config: withTarget :: Config -> FilePath -> Config
+ Language.Fixpoint.Types.Constraints: Cube :: IBindEnv -> Subst -> Cube
+ Language.Fixpoint.Types.Constraints: EQL :: !Qualifier -> !Expr -> ![Expr] -> EQual
+ Language.Fixpoint.Types.Constraints: FI :: HashMap Integer (c a) -> HashMap KVar (WfC a) -> !BindEnv -> !(SEnv Sort) -> Kuts -> ![Qualifier] -> HashMap BindId a -> FilePath -> !Bool -> GInfo c a
+ Language.Fixpoint.Types.Constraints: KS :: HashSet KVar -> Kuts
+ Language.Fixpoint.Types.Constraints: Q :: Symbol -> [(Symbol, Sort)] -> Expr -> !SourcePos -> Qualifier
+ Language.Fixpoint.Types.Constraints: Result :: FixResult a -> FixSolution -> Result a
+ Language.Fixpoint.Types.Constraints: SimpC :: !IBindEnv -> !Expr -> !(Maybe Integer) -> !Tag -> !a -> SimpC a
+ Language.Fixpoint.Types.Constraints: Sol :: HashMap KVar a -> HashMap KVar Hyp -> Sol a
+ Language.Fixpoint.Types.Constraints: WfC :: !IBindEnv -> (Symbol, Sort, KVar) -> !a -> WfC a
+ Language.Fixpoint.Types.Constraints: [_cenv] :: SimpC a -> !IBindEnv
+ Language.Fixpoint.Types.Constraints: [_cid] :: SimpC a -> !(Maybe Integer)
+ Language.Fixpoint.Types.Constraints: [_cinfo] :: SimpC a -> !a
+ Language.Fixpoint.Types.Constraints: [_crhs] :: SimpC a -> !Expr
+ Language.Fixpoint.Types.Constraints: [_ctag] :: SimpC a -> !Tag
+ Language.Fixpoint.Types.Constraints: [allowHO] :: GInfo c a -> !Bool
+ Language.Fixpoint.Types.Constraints: [bindInfo] :: GInfo c a -> HashMap BindId a
+ Language.Fixpoint.Types.Constraints: [bs] :: GInfo c a -> !BindEnv
+ Language.Fixpoint.Types.Constraints: [cm] :: GInfo c a -> HashMap Integer (c a)
+ Language.Fixpoint.Types.Constraints: [cuBinds] :: Cube -> IBindEnv
+ Language.Fixpoint.Types.Constraints: [cuSubst] :: Cube -> Subst
+ Language.Fixpoint.Types.Constraints: [eqArgs] :: EQual -> ![Expr]
+ Language.Fixpoint.Types.Constraints: [eqPred] :: EQual -> !Expr
+ Language.Fixpoint.Types.Constraints: [eqQual] :: EQual -> !Qualifier
+ Language.Fixpoint.Types.Constraints: [fileName] :: GInfo c a -> FilePath
+ Language.Fixpoint.Types.Constraints: [ksVars] :: Kuts -> HashSet KVar
+ Language.Fixpoint.Types.Constraints: [kuts] :: GInfo c a -> Kuts
+ Language.Fixpoint.Types.Constraints: [lits] :: GInfo c a -> !(SEnv Sort)
+ Language.Fixpoint.Types.Constraints: [q_body] :: Qualifier -> Expr
+ Language.Fixpoint.Types.Constraints: [q_name] :: Qualifier -> Symbol
+ Language.Fixpoint.Types.Constraints: [q_params] :: Qualifier -> [(Symbol, Sort)]
+ Language.Fixpoint.Types.Constraints: [q_pos] :: Qualifier -> !SourcePos
+ Language.Fixpoint.Types.Constraints: [quals] :: GInfo c a -> ![Qualifier]
+ Language.Fixpoint.Types.Constraints: [resSolution] :: Result a -> FixSolution
+ Language.Fixpoint.Types.Constraints: [resStatus] :: Result a -> FixResult a
+ Language.Fixpoint.Types.Constraints: [sHyp] :: Sol a -> HashMap KVar Hyp
+ Language.Fixpoint.Types.Constraints: [sMap] :: Sol a -> HashMap KVar a
+ Language.Fixpoint.Types.Constraints: [wenv] :: WfC a -> !IBindEnv
+ Language.Fixpoint.Types.Constraints: [winfo] :: WfC a -> !a
+ Language.Fixpoint.Types.Constraints: [wrft] :: WfC a -> (Symbol, Sort, KVar)
+ Language.Fixpoint.Types.Constraints: [ws] :: GInfo c a -> HashMap KVar (WfC a)
+ Language.Fixpoint.Types.Constraints: addIds :: [SubC a] -> [(Integer, SubC a)]
+ Language.Fixpoint.Types.Constraints: class TaggedC c a
+ Language.Fixpoint.Types.Constraints: clhs :: TaggedC c a => BindEnv -> c a -> [(Symbol, SortedReft)]
+ Language.Fixpoint.Types.Constraints: convertFormat :: (Fixpoint a) => FInfo a -> SInfo a
+ Language.Fixpoint.Types.Constraints: crhs :: TaggedC c a => c a -> Expr
+ Language.Fixpoint.Types.Constraints: data Cube
+ Language.Fixpoint.Types.Constraints: data EQual
+ Language.Fixpoint.Types.Constraints: data GInfo c a
+ Language.Fixpoint.Types.Constraints: data Qualifier
+ Language.Fixpoint.Types.Constraints: data Result a
+ Language.Fixpoint.Types.Constraints: data SimpC a
+ Language.Fixpoint.Types.Constraints: data Sol a
+ Language.Fixpoint.Types.Constraints: data SubC a
+ Language.Fixpoint.Types.Constraints: data WfC a
+ Language.Fixpoint.Types.Constraints: eQual :: Qualifier -> [Symbol] -> EQual
+ Language.Fixpoint.Types.Constraints: fi :: [SubC a] -> [WfC a] -> BindEnv -> SEnv Sort -> Kuts -> [Qualifier] -> HashMap BindId a -> FilePath -> Bool -> GInfo SubC a
+ Language.Fixpoint.Types.Constraints: instance (Control.DeepSeq.NFData (c a), Control.DeepSeq.NFData a) => Control.DeepSeq.NFData (Language.Fixpoint.Types.Constraints.GInfo c a)
+ Language.Fixpoint.Types.Constraints: instance (Data.Binary.Class.Binary (c a), Data.Binary.Class.Binary a) => Data.Binary.Class.Binary (Language.Fixpoint.Types.Constraints.GInfo c a)
+ Language.Fixpoint.Types.Constraints: instance (GHC.Classes.Eq a, GHC.Classes.Eq (c a)) => GHC.Classes.Eq (Language.Fixpoint.Types.Constraints.GInfo c a)
+ Language.Fixpoint.Types.Constraints: instance (GHC.Classes.Ord a, Language.Fixpoint.Types.PrettyPrint.Fixpoint a) => Language.Fixpoint.Types.PrettyPrint.Fixpoint (Language.Fixpoint.Types.Errors.FixResult (Language.Fixpoint.Types.Constraints.SubC a))
+ Language.Fixpoint.Types.Constraints: instance (GHC.Show.Show a, GHC.Show.Show (c a), Language.Fixpoint.Types.PrettyPrint.Fixpoint a) => GHC.Show.Show (Language.Fixpoint.Types.Constraints.GInfo c a)
+ Language.Fixpoint.Types.Constraints: instance Control.DeepSeq.NFData Language.Fixpoint.Types.Constraints.EQual
+ Language.Fixpoint.Types.Constraints: instance Control.DeepSeq.NFData Language.Fixpoint.Types.Constraints.Kuts
+ Language.Fixpoint.Types.Constraints: instance Control.DeepSeq.NFData Language.Fixpoint.Types.Constraints.Qualifier
+ Language.Fixpoint.Types.Constraints: instance Control.DeepSeq.NFData a => Control.DeepSeq.NFData (Language.Fixpoint.Types.Constraints.Result a)
+ Language.Fixpoint.Types.Constraints: instance Control.DeepSeq.NFData a => Control.DeepSeq.NFData (Language.Fixpoint.Types.Constraints.SimpC a)
+ Language.Fixpoint.Types.Constraints: instance Control.DeepSeq.NFData a => Control.DeepSeq.NFData (Language.Fixpoint.Types.Constraints.SubC a)
+ Language.Fixpoint.Types.Constraints: instance Control.DeepSeq.NFData a => Control.DeepSeq.NFData (Language.Fixpoint.Types.Constraints.WfC a)
+ Language.Fixpoint.Types.Constraints: instance Data.Binary.Class.Binary Language.Fixpoint.Types.Constraints.Kuts
+ Language.Fixpoint.Types.Constraints: instance Data.Binary.Class.Binary Language.Fixpoint.Types.Constraints.Qualifier
+ Language.Fixpoint.Types.Constraints: instance Data.Binary.Class.Binary a => Data.Binary.Class.Binary (Language.Fixpoint.Types.Constraints.SimpC a)
+ Language.Fixpoint.Types.Constraints: instance Data.Binary.Class.Binary a => Data.Binary.Class.Binary (Language.Fixpoint.Types.Constraints.SubC a)
+ Language.Fixpoint.Types.Constraints: instance Data.Binary.Class.Binary a => Data.Binary.Class.Binary (Language.Fixpoint.Types.Constraints.WfC a)
+ Language.Fixpoint.Types.Constraints: instance Data.Data.Data Language.Fixpoint.Types.Constraints.EQual
+ Language.Fixpoint.Types.Constraints: instance Data.Data.Data Language.Fixpoint.Types.Constraints.Qualifier
+ Language.Fixpoint.Types.Constraints: instance GHC.Base.Functor Language.Fixpoint.Types.Constraints.SimpC
+ Language.Fixpoint.Types.Constraints: instance GHC.Base.Functor Language.Fixpoint.Types.Constraints.Sol
+ Language.Fixpoint.Types.Constraints: instance GHC.Base.Functor Language.Fixpoint.Types.Constraints.SubC
+ Language.Fixpoint.Types.Constraints: instance GHC.Base.Functor Language.Fixpoint.Types.Constraints.WfC
+ Language.Fixpoint.Types.Constraints: instance GHC.Base.Functor c => GHC.Base.Functor (Language.Fixpoint.Types.Constraints.GInfo c)
+ Language.Fixpoint.Types.Constraints: instance GHC.Base.Monoid (Language.Fixpoint.Types.Constraints.GInfo c a)
+ Language.Fixpoint.Types.Constraints: instance GHC.Base.Monoid (Language.Fixpoint.Types.Constraints.Result a)
+ Language.Fixpoint.Types.Constraints: instance GHC.Base.Monoid (Language.Fixpoint.Types.Constraints.Sol a)
+ Language.Fixpoint.Types.Constraints: instance GHC.Base.Monoid Language.Fixpoint.Types.Constraints.Kuts
+ Language.Fixpoint.Types.Constraints: instance GHC.Classes.Eq Language.Fixpoint.Types.Constraints.EQual
+ Language.Fixpoint.Types.Constraints: instance GHC.Classes.Eq Language.Fixpoint.Types.Constraints.Kuts
+ Language.Fixpoint.Types.Constraints: instance GHC.Classes.Eq Language.Fixpoint.Types.Constraints.Qualifier
+ Language.Fixpoint.Types.Constraints: instance GHC.Classes.Eq a => GHC.Classes.Eq (Language.Fixpoint.Types.Constraints.SubC a)
+ Language.Fixpoint.Types.Constraints: instance GHC.Classes.Eq a => GHC.Classes.Eq (Language.Fixpoint.Types.Constraints.WfC a)
+ Language.Fixpoint.Types.Constraints: instance GHC.Generics.Constructor Language.Fixpoint.Types.Constraints.C1_0EQual
+ Language.Fixpoint.Types.Constraints: instance GHC.Generics.Constructor Language.Fixpoint.Types.Constraints.C1_0GInfo
+ Language.Fixpoint.Types.Constraints: instance GHC.Generics.Constructor Language.Fixpoint.Types.Constraints.C1_0Kuts
+ Language.Fixpoint.Types.Constraints: instance GHC.Generics.Constructor Language.Fixpoint.Types.Constraints.C1_0Qualifier
+ Language.Fixpoint.Types.Constraints: instance GHC.Generics.Constructor Language.Fixpoint.Types.Constraints.C1_0Result
+ Language.Fixpoint.Types.Constraints: instance GHC.Generics.Constructor Language.Fixpoint.Types.Constraints.C1_0SimpC
+ Language.Fixpoint.Types.Constraints: instance GHC.Generics.Constructor Language.Fixpoint.Types.Constraints.C1_0SubC
+ Language.Fixpoint.Types.Constraints: instance GHC.Generics.Constructor Language.Fixpoint.Types.Constraints.C1_0WfC
+ Language.Fixpoint.Types.Constraints: instance GHC.Generics.Datatype Language.Fixpoint.Types.Constraints.D1EQual
+ Language.Fixpoint.Types.Constraints: instance GHC.Generics.Datatype Language.Fixpoint.Types.Constraints.D1GInfo
+ Language.Fixpoint.Types.Constraints: instance GHC.Generics.Datatype Language.Fixpoint.Types.Constraints.D1Kuts
+ Language.Fixpoint.Types.Constraints: instance GHC.Generics.Datatype Language.Fixpoint.Types.Constraints.D1Qualifier
+ Language.Fixpoint.Types.Constraints: instance GHC.Generics.Datatype Language.Fixpoint.Types.Constraints.D1Result
+ Language.Fixpoint.Types.Constraints: instance GHC.Generics.Datatype Language.Fixpoint.Types.Constraints.D1SimpC
+ Language.Fixpoint.Types.Constraints: instance GHC.Generics.Datatype Language.Fixpoint.Types.Constraints.D1SubC
+ Language.Fixpoint.Types.Constraints: instance GHC.Generics.Datatype Language.Fixpoint.Types.Constraints.D1WfC
+ Language.Fixpoint.Types.Constraints: instance GHC.Generics.Generic (Language.Fixpoint.Types.Constraints.GInfo c a)
+ Language.Fixpoint.Types.Constraints: instance GHC.Generics.Generic (Language.Fixpoint.Types.Constraints.Result a)
+ Language.Fixpoint.Types.Constraints: instance GHC.Generics.Generic (Language.Fixpoint.Types.Constraints.SimpC a)
+ Language.Fixpoint.Types.Constraints: instance GHC.Generics.Generic (Language.Fixpoint.Types.Constraints.SubC a)
+ Language.Fixpoint.Types.Constraints: instance GHC.Generics.Generic (Language.Fixpoint.Types.Constraints.WfC a)
+ Language.Fixpoint.Types.Constraints: instance GHC.Generics.Generic Language.Fixpoint.Types.Constraints.EQual
+ Language.Fixpoint.Types.Constraints: instance GHC.Generics.Generic Language.Fixpoint.Types.Constraints.Kuts
+ Language.Fixpoint.Types.Constraints: instance GHC.Generics.Generic Language.Fixpoint.Types.Constraints.Qualifier
+ Language.Fixpoint.Types.Constraints: instance GHC.Generics.Selector Language.Fixpoint.Types.Constraints.S1_0_0EQual
+ Language.Fixpoint.Types.Constraints: instance GHC.Generics.Selector Language.Fixpoint.Types.Constraints.S1_0_0GInfo
+ Language.Fixpoint.Types.Constraints: instance GHC.Generics.Selector Language.Fixpoint.Types.Constraints.S1_0_0Kuts
+ Language.Fixpoint.Types.Constraints: instance GHC.Generics.Selector Language.Fixpoint.Types.Constraints.S1_0_0Qualifier
+ Language.Fixpoint.Types.Constraints: instance GHC.Generics.Selector Language.Fixpoint.Types.Constraints.S1_0_0Result
+ Language.Fixpoint.Types.Constraints: instance GHC.Generics.Selector Language.Fixpoint.Types.Constraints.S1_0_0SimpC
+ Language.Fixpoint.Types.Constraints: instance GHC.Generics.Selector Language.Fixpoint.Types.Constraints.S1_0_0SubC
+ Language.Fixpoint.Types.Constraints: instance GHC.Generics.Selector Language.Fixpoint.Types.Constraints.S1_0_0WfC
+ Language.Fixpoint.Types.Constraints: instance GHC.Generics.Selector Language.Fixpoint.Types.Constraints.S1_0_1EQual
+ Language.Fixpoint.Types.Constraints: instance GHC.Generics.Selector Language.Fixpoint.Types.Constraints.S1_0_1GInfo
+ Language.Fixpoint.Types.Constraints: instance GHC.Generics.Selector Language.Fixpoint.Types.Constraints.S1_0_1Qualifier
+ Language.Fixpoint.Types.Constraints: instance GHC.Generics.Selector Language.Fixpoint.Types.Constraints.S1_0_1Result
+ Language.Fixpoint.Types.Constraints: instance GHC.Generics.Selector Language.Fixpoint.Types.Constraints.S1_0_1SimpC
+ Language.Fixpoint.Types.Constraints: instance GHC.Generics.Selector Language.Fixpoint.Types.Constraints.S1_0_1SubC
+ Language.Fixpoint.Types.Constraints: instance GHC.Generics.Selector Language.Fixpoint.Types.Constraints.S1_0_1WfC
+ Language.Fixpoint.Types.Constraints: instance GHC.Generics.Selector Language.Fixpoint.Types.Constraints.S1_0_2EQual
+ Language.Fixpoint.Types.Constraints: instance GHC.Generics.Selector Language.Fixpoint.Types.Constraints.S1_0_2GInfo
+ Language.Fixpoint.Types.Constraints: instance GHC.Generics.Selector Language.Fixpoint.Types.Constraints.S1_0_2Qualifier
+ Language.Fixpoint.Types.Constraints: instance GHC.Generics.Selector Language.Fixpoint.Types.Constraints.S1_0_2SimpC
+ Language.Fixpoint.Types.Constraints: instance GHC.Generics.Selector Language.Fixpoint.Types.Constraints.S1_0_2SubC
+ Language.Fixpoint.Types.Constraints: instance GHC.Generics.Selector Language.Fixpoint.Types.Constraints.S1_0_2WfC
+ Language.Fixpoint.Types.Constraints: instance GHC.Generics.Selector Language.Fixpoint.Types.Constraints.S1_0_3GInfo
+ Language.Fixpoint.Types.Constraints: instance GHC.Generics.Selector Language.Fixpoint.Types.Constraints.S1_0_3Qualifier
+ Language.Fixpoint.Types.Constraints: instance GHC.Generics.Selector Language.Fixpoint.Types.Constraints.S1_0_3SimpC
+ Language.Fixpoint.Types.Constraints: instance GHC.Generics.Selector Language.Fixpoint.Types.Constraints.S1_0_3SubC
+ Language.Fixpoint.Types.Constraints: instance GHC.Generics.Selector Language.Fixpoint.Types.Constraints.S1_0_4GInfo
+ Language.Fixpoint.Types.Constraints: instance GHC.Generics.Selector Language.Fixpoint.Types.Constraints.S1_0_4SimpC
+ Language.Fixpoint.Types.Constraints: instance GHC.Generics.Selector Language.Fixpoint.Types.Constraints.S1_0_4SubC
+ Language.Fixpoint.Types.Constraints: instance GHC.Generics.Selector Language.Fixpoint.Types.Constraints.S1_0_5GInfo
+ Language.Fixpoint.Types.Constraints: instance GHC.Generics.Selector Language.Fixpoint.Types.Constraints.S1_0_5SubC
+ Language.Fixpoint.Types.Constraints: instance GHC.Generics.Selector Language.Fixpoint.Types.Constraints.S1_0_6GInfo
+ Language.Fixpoint.Types.Constraints: instance GHC.Generics.Selector Language.Fixpoint.Types.Constraints.S1_0_7GInfo
+ Language.Fixpoint.Types.Constraints: instance GHC.Generics.Selector Language.Fixpoint.Types.Constraints.S1_0_8GInfo
+ Language.Fixpoint.Types.Constraints: instance GHC.Show.Show Language.Fixpoint.Types.Constraints.EQual
+ Language.Fixpoint.Types.Constraints: instance GHC.Show.Show Language.Fixpoint.Types.Constraints.Kuts
+ Language.Fixpoint.Types.Constraints: instance GHC.Show.Show Language.Fixpoint.Types.Constraints.Qualifier
+ Language.Fixpoint.Types.Constraints: instance GHC.Show.Show a => GHC.Show.Show (Language.Fixpoint.Types.Constraints.Result a)
+ Language.Fixpoint.Types.Constraints: instance Language.Fixpoint.Types.Constraints.TaggedC Language.Fixpoint.Types.Constraints.SimpC a
+ Language.Fixpoint.Types.Constraints: instance Language.Fixpoint.Types.Constraints.TaggedC Language.Fixpoint.Types.Constraints.SubC a
+ Language.Fixpoint.Types.Constraints: instance Language.Fixpoint.Types.PrettyPrint.Fixpoint Language.Fixpoint.Types.Constraints.Kuts
+ Language.Fixpoint.Types.Constraints: instance Language.Fixpoint.Types.PrettyPrint.Fixpoint Language.Fixpoint.Types.Constraints.Qualifier
+ Language.Fixpoint.Types.Constraints: instance Language.Fixpoint.Types.PrettyPrint.Fixpoint a => GHC.Show.Show (Language.Fixpoint.Types.Constraints.SimpC a)
+ Language.Fixpoint.Types.Constraints: instance Language.Fixpoint.Types.PrettyPrint.Fixpoint a => GHC.Show.Show (Language.Fixpoint.Types.Constraints.SubC a)
+ Language.Fixpoint.Types.Constraints: instance Language.Fixpoint.Types.PrettyPrint.Fixpoint a => GHC.Show.Show (Language.Fixpoint.Types.Constraints.WfC a)
+ Language.Fixpoint.Types.Constraints: instance Language.Fixpoint.Types.PrettyPrint.Fixpoint a => Language.Fixpoint.Types.PrettyPrint.Fixpoint (Language.Fixpoint.Types.Constraints.SimpC a)
+ Language.Fixpoint.Types.Constraints: instance Language.Fixpoint.Types.PrettyPrint.Fixpoint a => Language.Fixpoint.Types.PrettyPrint.Fixpoint (Language.Fixpoint.Types.Constraints.SubC a)
+ Language.Fixpoint.Types.Constraints: instance Language.Fixpoint.Types.PrettyPrint.Fixpoint a => Language.Fixpoint.Types.PrettyPrint.Fixpoint (Language.Fixpoint.Types.Constraints.WfC a)
+ Language.Fixpoint.Types.Constraints: instance Language.Fixpoint.Types.PrettyPrint.Fixpoint a => Language.Fixpoint.Types.PrettyPrint.PPrint (Language.Fixpoint.Types.Constraints.SimpC a)
+ Language.Fixpoint.Types.Constraints: instance Language.Fixpoint.Types.PrettyPrint.Fixpoint a => Language.Fixpoint.Types.PrettyPrint.PPrint (Language.Fixpoint.Types.Constraints.SubC a)
+ Language.Fixpoint.Types.Constraints: instance Language.Fixpoint.Types.PrettyPrint.Fixpoint a => Language.Fixpoint.Types.PrettyPrint.PPrint (Language.Fixpoint.Types.Constraints.WfC a)
+ Language.Fixpoint.Types.Constraints: instance Language.Fixpoint.Types.PrettyPrint.PPrint Language.Fixpoint.Types.Constraints.EQual
+ Language.Fixpoint.Types.Constraints: instance Language.Fixpoint.Types.PrettyPrint.PPrint Language.Fixpoint.Types.Constraints.Qualifier
+ Language.Fixpoint.Types.Constraints: instance Language.Fixpoint.Types.PrettyPrint.PPrint a => Language.Fixpoint.Types.PrettyPrint.PPrint (Language.Fixpoint.Types.Constraints.Sol a)
+ Language.Fixpoint.Types.Constraints: instance Language.Fixpoint.Types.PrettyPrint.PTable (Language.Fixpoint.Types.Constraints.SInfo a)
+ Language.Fixpoint.Types.Constraints: instance Language.Fixpoint.Types.Spans.Loc Language.Fixpoint.Types.Constraints.Qualifier
+ Language.Fixpoint.Types.Constraints: ksMember :: KVar -> Kuts -> Bool
+ Language.Fixpoint.Types.Constraints: mkSubC :: IBindEnv -> SortedReft -> SortedReft -> Maybe Integer -> Tag -> a -> SubC a
+ Language.Fixpoint.Types.Constraints: newtype Kuts
+ Language.Fixpoint.Types.Constraints: qualifier :: SEnv Sort -> SourcePos -> SEnv Sort -> Symbol -> Sort -> Expr -> Qualifier
+ Language.Fixpoint.Types.Constraints: saveQuery :: Config -> FInfo a -> IO ()
+ Language.Fixpoint.Types.Constraints: senv :: TaggedC c a => c a -> IBindEnv
+ Language.Fixpoint.Types.Constraints: shiftVV :: Reft -> Symbol -> Reft
+ Language.Fixpoint.Types.Constraints: sid :: TaggedC c a => c a -> Maybe Integer
+ Language.Fixpoint.Types.Constraints: sinfo :: TaggedC c a => c a -> a
+ Language.Fixpoint.Types.Constraints: slhs :: SubC a -> SortedReft
+ Language.Fixpoint.Types.Constraints: solFromList :: [(KVar, a)] -> [(KVar, Hyp)] -> Sol a
+ Language.Fixpoint.Types.Constraints: solInsert :: KVar -> a -> Sol a -> Sol a
+ Language.Fixpoint.Types.Constraints: solLookup :: Solution -> KVar -> QBind
+ Language.Fixpoint.Types.Constraints: solResult :: Solution -> HashMap KVar Expr
+ Language.Fixpoint.Types.Constraints: srhs :: SubC a -> SortedReft
+ Language.Fixpoint.Types.Constraints: stag :: TaggedC c a => c a -> Tag
+ Language.Fixpoint.Types.Constraints: subC :: IBindEnv -> SortedReft -> SortedReft -> Maybe Integer -> Tag -> a -> [SubC a]
+ Language.Fixpoint.Types.Constraints: subcId :: (TaggedC c a) => c a -> Integer
+ Language.Fixpoint.Types.Constraints: toFixpoint :: (Fixpoint a, Fixpoint (c a)) => Config -> GInfo c a -> Doc
+ Language.Fixpoint.Types.Constraints: type Cand a = [(Expr, a)]
+ Language.Fixpoint.Types.Constraints: type FInfo a = GInfo SubC a
+ Language.Fixpoint.Types.Constraints: type FixSolution = HashMap KVar Expr
+ Language.Fixpoint.Types.Constraints: type Hyp = ListNE Cube
+ Language.Fixpoint.Types.Constraints: type QBind = [EQual]
+ Language.Fixpoint.Types.Constraints: type SInfo a = GInfo SimpC a
+ Language.Fixpoint.Types.Constraints: type Solution = Sol QBind
+ Language.Fixpoint.Types.Constraints: type Solver a = Config -> FInfo a -> IO (Result (Integer, a))
+ Language.Fixpoint.Types.Constraints: type Tag = [Int]
+ Language.Fixpoint.Types.Constraints: wfC :: (Fixpoint a) => IBindEnv -> SortedReft -> a -> [WfC a]
+ Language.Fixpoint.Types.Constraints: writeFInfo :: (Fixpoint a, Fixpoint (c a)) => Config -> GInfo c a -> FilePath -> IO ()
+ Language.Fixpoint.Types.Environments: Alts :: [Symbol] -> SESearch a
+ Language.Fixpoint.Types.Environments: Found :: a -> SESearch a
+ Language.Fixpoint.Types.Environments: adjustBindEnv :: ((Symbol, SortedReft) -> (Symbol, SortedReft)) -> BindId -> BindEnv -> BindEnv
+ Language.Fixpoint.Types.Environments: beBinds :: SizedEnv a -> BindMap a
+ Language.Fixpoint.Types.Environments: bindEnvFromList :: [(BindId, Symbol, SortedReft)] -> BindEnv
+ Language.Fixpoint.Types.Environments: bindEnvToList :: BindEnv -> [(BindId, Symbol, SortedReft)]
+ Language.Fixpoint.Types.Environments: data IBindEnv
+ Language.Fixpoint.Types.Environments: data SESearch a
+ Language.Fixpoint.Types.Environments: data SEnv a
+ Language.Fixpoint.Types.Environments: deleteIBindEnv :: BindId -> IBindEnv -> IBindEnv
+ Language.Fixpoint.Types.Environments: deleteSEnv :: Symbol -> SEnv a -> SEnv a
+ Language.Fixpoint.Types.Environments: diffIBindEnv :: IBindEnv -> IBindEnv -> IBindEnv
+ Language.Fixpoint.Types.Environments: differenceSEnv :: SEnv a -> SEnv w -> SEnv a
+ Language.Fixpoint.Types.Environments: elemsIBindEnv :: IBindEnv -> [BindId]
+ Language.Fixpoint.Types.Environments: emptyBindEnv :: BindEnv
+ Language.Fixpoint.Types.Environments: emptyIBindEnv :: IBindEnv
+ Language.Fixpoint.Types.Environments: emptySEnv :: SEnv a
+ Language.Fixpoint.Types.Environments: envCs :: BindEnv -> IBindEnv -> [(Symbol, SortedReft)]
+ Language.Fixpoint.Types.Environments: filterSEnv :: (a -> Bool) -> SEnv a -> SEnv a
+ Language.Fixpoint.Types.Environments: fromListSEnv :: [(Symbol, a)] -> SEnv a
+ Language.Fixpoint.Types.Environments: insertBindEnv :: Symbol -> SortedReft -> BindEnv -> (BindId, BindEnv)
+ Language.Fixpoint.Types.Environments: insertSEnv :: Symbol -> a -> SEnv a -> SEnv a
+ Language.Fixpoint.Types.Environments: insertsIBindEnv :: [BindId] -> IBindEnv -> IBindEnv
+ Language.Fixpoint.Types.Environments: instance (Data.Hashable.Class.Hashable a, GHC.Classes.Eq a, Data.Binary.Class.Binary a) => Data.Binary.Class.Binary (Data.HashSet.HashSet a)
+ Language.Fixpoint.Types.Environments: instance Control.DeepSeq.NFData Language.Fixpoint.Types.Environments.BindEnv
+ Language.Fixpoint.Types.Environments: instance Control.DeepSeq.NFData Language.Fixpoint.Types.Environments.IBindEnv
+ Language.Fixpoint.Types.Environments: instance Control.DeepSeq.NFData a => Control.DeepSeq.NFData (Language.Fixpoint.Types.Environments.SEnv a)
+ Language.Fixpoint.Types.Environments: instance Data.Binary.Class.Binary Language.Fixpoint.Types.Environments.BindEnv
+ Language.Fixpoint.Types.Environments: instance Data.Binary.Class.Binary Language.Fixpoint.Types.Environments.IBindEnv
+ Language.Fixpoint.Types.Environments: instance Data.Binary.Class.Binary a => Data.Binary.Class.Binary (Language.Fixpoint.Types.Environments.SEnv a)
+ Language.Fixpoint.Types.Environments: instance Data.Data.Data Language.Fixpoint.Types.Environments.IBindEnv
+ Language.Fixpoint.Types.Environments: instance Data.Data.Data a => Data.Data.Data (Language.Fixpoint.Types.Environments.SEnv a)
+ Language.Fixpoint.Types.Environments: instance Data.Foldable.Foldable Language.Fixpoint.Types.Environments.SEnv
+ Language.Fixpoint.Types.Environments: instance Data.Foldable.Foldable Language.Fixpoint.Types.Environments.SizedEnv
+ Language.Fixpoint.Types.Environments: instance Data.Traversable.Traversable Language.Fixpoint.Types.Environments.SEnv
+ Language.Fixpoint.Types.Environments: instance Data.Traversable.Traversable Language.Fixpoint.Types.Environments.SizedEnv
+ Language.Fixpoint.Types.Environments: instance GHC.Base.Functor Language.Fixpoint.Types.Environments.SEnv
+ Language.Fixpoint.Types.Environments: instance GHC.Base.Functor Language.Fixpoint.Types.Environments.SizedEnv
+ Language.Fixpoint.Types.Environments: instance GHC.Base.Monoid (Language.Fixpoint.Types.Environments.SEnv a)
+ Language.Fixpoint.Types.Environments: instance GHC.Base.Monoid Language.Fixpoint.Types.Environments.BindEnv
+ Language.Fixpoint.Types.Environments: instance GHC.Classes.Eq Language.Fixpoint.Types.Environments.IBindEnv
+ Language.Fixpoint.Types.Environments: instance GHC.Classes.Eq a => GHC.Classes.Eq (Language.Fixpoint.Types.Environments.SEnv a)
+ Language.Fixpoint.Types.Environments: instance GHC.Classes.Eq a => GHC.Classes.Eq (Language.Fixpoint.Types.Environments.SizedEnv a)
+ Language.Fixpoint.Types.Environments: instance GHC.Generics.Constructor Language.Fixpoint.Types.Environments.C1_0IBindEnv
+ Language.Fixpoint.Types.Environments: instance GHC.Generics.Constructor Language.Fixpoint.Types.Environments.C1_0SEnv
+ Language.Fixpoint.Types.Environments: instance GHC.Generics.Constructor Language.Fixpoint.Types.Environments.C1_0SizedEnv
+ Language.Fixpoint.Types.Environments: instance GHC.Generics.Datatype Language.Fixpoint.Types.Environments.D1IBindEnv
+ Language.Fixpoint.Types.Environments: instance GHC.Generics.Datatype Language.Fixpoint.Types.Environments.D1SEnv
+ Language.Fixpoint.Types.Environments: instance GHC.Generics.Datatype Language.Fixpoint.Types.Environments.D1SizedEnv
+ Language.Fixpoint.Types.Environments: instance GHC.Generics.Generic (Language.Fixpoint.Types.Environments.SEnv a)
+ Language.Fixpoint.Types.Environments: instance GHC.Generics.Generic (Language.Fixpoint.Types.Environments.SizedEnv a)
+ Language.Fixpoint.Types.Environments: instance GHC.Generics.Generic Language.Fixpoint.Types.Environments.IBindEnv
+ Language.Fixpoint.Types.Environments: instance GHC.Generics.Selector Language.Fixpoint.Types.Environments.S1_0_0SEnv
+ Language.Fixpoint.Types.Environments: instance GHC.Generics.Selector Language.Fixpoint.Types.Environments.S1_0_0SizedEnv
+ Language.Fixpoint.Types.Environments: instance GHC.Generics.Selector Language.Fixpoint.Types.Environments.S1_0_1SizedEnv
+ Language.Fixpoint.Types.Environments: instance GHC.Show.Show a => GHC.Show.Show (Language.Fixpoint.Types.Environments.SizedEnv a)
+ Language.Fixpoint.Types.Environments: instance Language.Fixpoint.Types.PrettyPrint.Fixpoint (Language.Fixpoint.Types.Environments.SEnv a) => GHC.Show.Show (Language.Fixpoint.Types.Environments.SEnv a)
+ Language.Fixpoint.Types.Environments: instance Language.Fixpoint.Types.PrettyPrint.Fixpoint Language.Fixpoint.Types.Environments.BindEnv
+ Language.Fixpoint.Types.Environments: instance Language.Fixpoint.Types.PrettyPrint.Fixpoint Language.Fixpoint.Types.Environments.IBindEnv
+ Language.Fixpoint.Types.Environments: instance Language.Fixpoint.Types.PrettyPrint.Fixpoint a => Language.Fixpoint.Types.PrettyPrint.Fixpoint (Language.Fixpoint.Types.Environments.SEnv a)
+ Language.Fixpoint.Types.Environments: intersectWithSEnv :: (v1 -> v2 -> a) -> SEnv v1 -> SEnv v2 -> SEnv a
+ Language.Fixpoint.Types.Environments: lookupBindEnv :: BindId -> BindEnv -> (Symbol, SortedReft)
+ Language.Fixpoint.Types.Environments: lookupSEnv :: Symbol -> SEnv v -> Maybe v
+ Language.Fixpoint.Types.Environments: lookupSEnvWithDistance :: Symbol -> SEnv a -> SESearch a
+ Language.Fixpoint.Types.Environments: mapBindEnv :: ((Symbol, SortedReft) -> (Symbol, SortedReft)) -> BindEnv -> BindEnv
+ Language.Fixpoint.Types.Environments: mapSEnv :: (a1 -> a) -> SEnv a1 -> SEnv a
+ Language.Fixpoint.Types.Environments: mapSEnvWithKey :: ((Symbol, a1) -> (Symbol, a)) -> SEnv a1 -> SEnv a
+ Language.Fixpoint.Types.Environments: memberSEnv :: Symbol -> SEnv a -> Bool
+ Language.Fixpoint.Types.Environments: toListSEnv :: SEnv a -> [(Symbol, a)]
+ Language.Fixpoint.Types.Environments: type BindEnv = SizedEnv (Symbol, SortedReft)
+ Language.Fixpoint.Types.Environments: type BindId = Int
+ Language.Fixpoint.Types.Environments: type BindMap a = HashMap BindId a
+ Language.Fixpoint.Types.Environments: unionIBindEnv :: IBindEnv -> IBindEnv -> IBindEnv
+ Language.Fixpoint.Types.Environments: unionSEnv :: SEnv a -> HashMap Symbol a -> SEnv a
+ Language.Fixpoint.Types.Errors: Crash :: [a] -> String -> FixResult a
+ Language.Fixpoint.Types.Errors: SS :: !SourcePos -> !SourcePos -> SrcSpan
+ Language.Fixpoint.Types.Errors: Safe :: FixResult a
+ Language.Fixpoint.Types.Errors: Unsafe :: ![a] -> FixResult a
+ Language.Fixpoint.Types.Errors: [sp_start] :: SrcSpan -> !SourcePos
+ Language.Fixpoint.Types.Errors: [sp_stop] :: SrcSpan -> !SourcePos
+ Language.Fixpoint.Types.Errors: catError :: Error -> Error -> Error
+ Language.Fixpoint.Types.Errors: catErrors :: ListNE Error -> Error
+ Language.Fixpoint.Types.Errors: colorResult :: FixResult a -> Moods
+ Language.Fixpoint.Types.Errors: data Error
+ Language.Fixpoint.Types.Errors: data FixResult a
+ Language.Fixpoint.Types.Errors: data SrcSpan
+ Language.Fixpoint.Types.Errors: die :: Error -> a
+ Language.Fixpoint.Types.Errors: dummySpan :: SrcSpan
+ Language.Fixpoint.Types.Errors: err :: SrcSpan -> Doc -> Error
+ Language.Fixpoint.Types.Errors: errFreeVarInConstraint :: Integer -> Error
+ Language.Fixpoint.Types.Errors: errFreeVarInQual :: (PPrint q, Loc q, PPrint x) => q -> x -> Error
+ Language.Fixpoint.Types.Errors: errLoc :: Error1 -> SrcSpan
+ Language.Fixpoint.Types.Errors: errMsg :: Error1 -> Doc
+ Language.Fixpoint.Types.Errors: exit :: a -> IO a -> IO a
+ Language.Fixpoint.Types.Errors: instance Control.DeepSeq.NFData a => Control.DeepSeq.NFData (Language.Fixpoint.Types.Errors.FixResult a)
+ Language.Fixpoint.Types.Errors: instance Data.Binary.Class.Binary a => Data.Binary.Class.Binary (Language.Fixpoint.Types.Errors.FixResult a)
+ Language.Fixpoint.Types.Errors: instance Data.Data.Data a => Data.Data.Data (Language.Fixpoint.Types.Errors.FixResult a)
+ Language.Fixpoint.Types.Errors: instance Data.Foldable.Foldable Language.Fixpoint.Types.Errors.FixResult
+ Language.Fixpoint.Types.Errors: instance Data.Serialize.Serialize (Language.Fixpoint.Types.Errors.FixResult Language.Fixpoint.Types.Errors.Error)
+ Language.Fixpoint.Types.Errors: instance Data.Serialize.Serialize Language.Fixpoint.Types.Errors.Error
+ Language.Fixpoint.Types.Errors: instance Data.Serialize.Serialize Language.Fixpoint.Types.Errors.Error1
+ Language.Fixpoint.Types.Errors: instance Data.Serialize.Serialize Text.PrettyPrint.HughesPJ.Doc
+ Language.Fixpoint.Types.Errors: instance Data.Serialize.Serialize Text.PrettyPrint.HughesPJ.TextDetails
+ Language.Fixpoint.Types.Errors: instance Data.Traversable.Traversable Language.Fixpoint.Types.Errors.FixResult
+ Language.Fixpoint.Types.Errors: instance GHC.Base.Functor Language.Fixpoint.Types.Errors.FixResult
+ Language.Fixpoint.Types.Errors: instance GHC.Base.Monoid (Language.Fixpoint.Types.Errors.FixResult a)
+ Language.Fixpoint.Types.Errors: instance GHC.Classes.Eq Language.Fixpoint.Types.Errors.Error
+ Language.Fixpoint.Types.Errors: instance GHC.Classes.Eq Language.Fixpoint.Types.Errors.Error1
+ Language.Fixpoint.Types.Errors: instance GHC.Classes.Eq a => GHC.Classes.Eq (Language.Fixpoint.Types.Errors.FixResult a)
+ Language.Fixpoint.Types.Errors: instance GHC.Classes.Ord Language.Fixpoint.Types.Errors.Error
+ Language.Fixpoint.Types.Errors: instance GHC.Classes.Ord Language.Fixpoint.Types.Errors.Error1
+ Language.Fixpoint.Types.Errors: instance GHC.Exception.Exception (Language.Fixpoint.Types.Errors.FixResult Language.Fixpoint.Types.Errors.Error)
+ Language.Fixpoint.Types.Errors: instance GHC.Exception.Exception Language.Fixpoint.Types.Errors.Error
+ Language.Fixpoint.Types.Errors: instance GHC.Generics.Constructor Language.Fixpoint.Types.Errors.C1_0Error
+ Language.Fixpoint.Types.Errors: instance GHC.Generics.Constructor Language.Fixpoint.Types.Errors.C1_0Error1
+ Language.Fixpoint.Types.Errors: instance GHC.Generics.Constructor Language.Fixpoint.Types.Errors.C1_0FixResult
+ Language.Fixpoint.Types.Errors: instance GHC.Generics.Constructor Language.Fixpoint.Types.Errors.C1_1FixResult
+ Language.Fixpoint.Types.Errors: instance GHC.Generics.Constructor Language.Fixpoint.Types.Errors.C1_2FixResult
+ Language.Fixpoint.Types.Errors: instance GHC.Generics.Datatype Language.Fixpoint.Types.Errors.D1Error
+ Language.Fixpoint.Types.Errors: instance GHC.Generics.Datatype Language.Fixpoint.Types.Errors.D1Error1
+ Language.Fixpoint.Types.Errors: instance GHC.Generics.Datatype Language.Fixpoint.Types.Errors.D1FixResult
+ Language.Fixpoint.Types.Errors: instance GHC.Generics.Generic (Language.Fixpoint.Types.Errors.FixResult a)
+ Language.Fixpoint.Types.Errors: instance GHC.Generics.Generic Language.Fixpoint.Types.Errors.Error
+ Language.Fixpoint.Types.Errors: instance GHC.Generics.Generic Language.Fixpoint.Types.Errors.Error1
+ Language.Fixpoint.Types.Errors: instance GHC.Generics.Selector Language.Fixpoint.Types.Errors.S1_0_0Error1
+ Language.Fixpoint.Types.Errors: instance GHC.Generics.Selector Language.Fixpoint.Types.Errors.S1_0_1Error1
+ Language.Fixpoint.Types.Errors: instance GHC.Show.Show Language.Fixpoint.Types.Errors.Error
+ Language.Fixpoint.Types.Errors: instance GHC.Show.Show Language.Fixpoint.Types.Errors.Error1
+ Language.Fixpoint.Types.Errors: instance GHC.Show.Show a => GHC.Show.Show (Language.Fixpoint.Types.Errors.FixResult a)
+ Language.Fixpoint.Types.Errors: instance Language.Fixpoint.Types.PrettyPrint.Fixpoint Language.Fixpoint.Types.Errors.Error1
+ Language.Fixpoint.Types.Errors: instance Language.Fixpoint.Types.PrettyPrint.PPrint Language.Fixpoint.Types.Errors.Error
+ Language.Fixpoint.Types.Errors: instance Language.Fixpoint.Types.PrettyPrint.PPrint Language.Fixpoint.Types.Errors.Error1
+ Language.Fixpoint.Types.Errors: resultDoc :: (Fixpoint a) => FixResult a -> Doc
+ Language.Fixpoint.Types.Errors: sourcePosElts :: SourcePos -> (SourceName, Line, Column)
+ Language.Fixpoint.Types.Graphs: Cstr :: Integer -> CVertex
+ Language.Fixpoint.Types.Graphs: DKVar :: KVar -> CVertex
+ Language.Fixpoint.Types.Graphs: KVar :: KVar -> CVertex
+ Language.Fixpoint.Types.Graphs: data CVertex
+ Language.Fixpoint.Types.Graphs: instance Data.Hashable.Class.Hashable Language.Fixpoint.Types.Graphs.CVertex
+ Language.Fixpoint.Types.Graphs: instance GHC.Classes.Eq Language.Fixpoint.Types.Graphs.CVertex
+ Language.Fixpoint.Types.Graphs: instance GHC.Classes.Ord Language.Fixpoint.Types.Graphs.CVertex
+ Language.Fixpoint.Types.Graphs: instance GHC.Generics.Constructor Language.Fixpoint.Types.Graphs.C1_0CVertex
+ Language.Fixpoint.Types.Graphs: instance GHC.Generics.Constructor Language.Fixpoint.Types.Graphs.C1_1CVertex
+ Language.Fixpoint.Types.Graphs: instance GHC.Generics.Constructor Language.Fixpoint.Types.Graphs.C1_2CVertex
+ Language.Fixpoint.Types.Graphs: instance GHC.Generics.Datatype Language.Fixpoint.Types.Graphs.D1CVertex
+ Language.Fixpoint.Types.Graphs: instance GHC.Generics.Generic Language.Fixpoint.Types.Graphs.CVertex
+ Language.Fixpoint.Types.Graphs: instance GHC.Show.Show Language.Fixpoint.Types.Graphs.CVertex
+ Language.Fixpoint.Types.Graphs: instance Language.Fixpoint.Types.PrettyPrint.PPrint Language.Fixpoint.Types.Graphs.CVertex
+ Language.Fixpoint.Types.Graphs: type CEdge = (CVertex, CVertex)
+ Language.Fixpoint.Types.Graphs: type Comps a = [[a]]
+ Language.Fixpoint.Types.Graphs: type KVComps = Comps CVertex
+ Language.Fixpoint.Types.Graphs: type KVGraph = [(CVertex, CVertex, [CVertex])]
+ Language.Fixpoint.Types.Graphs: writeGraph :: FilePath -> KVGraph -> IO ()
+ Language.Fixpoint.Types.Names: anfPrefix :: Symbol
+ Language.Fixpoint.Types.Names: bitVecApplyName :: Int -> Symbol
+ Language.Fixpoint.Types.Names: bitVecName :: Symbol
+ Language.Fixpoint.Types.Names: bitVecToIntName :: Symbol
+ Language.Fixpoint.Types.Names: boolApplyName :: Int -> Symbol
+ Language.Fixpoint.Types.Names: boolConName :: Symbol
+ Language.Fixpoint.Types.Names: boolToIntName :: Symbol
+ Language.Fixpoint.Types.Names: bvAndName :: Symbol
+ Language.Fixpoint.Types.Names: bvOrName :: Symbol
+ Language.Fixpoint.Types.Names: class Symbolic a
+ Language.Fixpoint.Types.Names: consName :: Symbol
+ Language.Fixpoint.Types.Names: consSym :: Char -> Symbol -> Symbol
+ Language.Fixpoint.Types.Names: data Symbol
+ Language.Fixpoint.Types.Names: divFuncName :: Symbol
+ Language.Fixpoint.Types.Names: dropSym :: Int -> Symbol -> Symbol
+ Language.Fixpoint.Types.Names: dummyName :: Symbol
+ Language.Fixpoint.Types.Names: dummySymbol :: Symbol
+ Language.Fixpoint.Types.Names: existSymbol :: Symbol -> Integer -> Symbol
+ Language.Fixpoint.Types.Names: funConName :: Symbol
+ Language.Fixpoint.Types.Names: headSym :: Symbol -> Char
+ Language.Fixpoint.Types.Names: hpropConName :: Symbol
+ Language.Fixpoint.Types.Names: instance Control.DeepSeq.NFData Language.Fixpoint.Types.Names.Symbol
+ Language.Fixpoint.Types.Names: instance Data.Binary.Class.Binary Language.Fixpoint.Types.Names.Symbol
+ Language.Fixpoint.Types.Names: instance Data.Data.Data Data.Interned.Internal.Text.InternedText
+ Language.Fixpoint.Types.Names: instance Data.Data.Data Language.Fixpoint.Types.Names.Symbol
+ Language.Fixpoint.Types.Names: instance Data.Hashable.Class.Hashable (Data.Interned.Internal.Description Language.Fixpoint.Types.Names.Symbol)
+ Language.Fixpoint.Types.Names: instance Data.Hashable.Class.Hashable Language.Fixpoint.Types.Names.Symbol
+ Language.Fixpoint.Types.Names: instance Data.Interned.Internal.Interned Language.Fixpoint.Types.Names.Symbol
+ Language.Fixpoint.Types.Names: instance Data.Interned.Internal.Uninternable Language.Fixpoint.Types.Names.Symbol
+ Language.Fixpoint.Types.Names: instance Data.String.IsString Language.Fixpoint.Types.Names.Symbol
+ Language.Fixpoint.Types.Names: instance GHC.Classes.Eq (Data.Interned.Internal.Description Language.Fixpoint.Types.Names.Symbol)
+ Language.Fixpoint.Types.Names: instance GHC.Classes.Eq Language.Fixpoint.Types.Names.Symbol
+ Language.Fixpoint.Types.Names: instance GHC.Classes.Ord Language.Fixpoint.Types.Names.Symbol
+ Language.Fixpoint.Types.Names: instance GHC.Generics.Constructor Language.Fixpoint.Types.Names.C1_0InternedText
+ Language.Fixpoint.Types.Names: instance GHC.Generics.Constructor Language.Fixpoint.Types.Names.C1_0Symbol
+ Language.Fixpoint.Types.Names: instance GHC.Generics.Datatype Language.Fixpoint.Types.Names.D1InternedText
+ Language.Fixpoint.Types.Names: instance GHC.Generics.Datatype Language.Fixpoint.Types.Names.D1Symbol
+ Language.Fixpoint.Types.Names: instance GHC.Generics.Generic Data.Interned.Internal.Text.InternedText
+ Language.Fixpoint.Types.Names: instance GHC.Generics.Generic Language.Fixpoint.Types.Names.Symbol
+ Language.Fixpoint.Types.Names: instance GHC.Generics.Selector Language.Fixpoint.Types.Names.S1_0_0InternedText
+ Language.Fixpoint.Types.Names: instance GHC.Generics.Selector Language.Fixpoint.Types.Names.S1_0_0Symbol
+ Language.Fixpoint.Types.Names: instance GHC.Generics.Selector Language.Fixpoint.Types.Names.S1_0_1InternedText
+ Language.Fixpoint.Types.Names: instance GHC.Generics.Selector Language.Fixpoint.Types.Names.S1_0_1Symbol
+ Language.Fixpoint.Types.Names: instance GHC.Generics.Selector Language.Fixpoint.Types.Names.S1_0_2Symbol
+ Language.Fixpoint.Types.Names: instance GHC.Show.Show Language.Fixpoint.Types.Names.Symbol
+ Language.Fixpoint.Types.Names: instance Language.Fixpoint.Types.Names.Symbolic Data.Text.Internal.Text
+ Language.Fixpoint.Types.Names: instance Language.Fixpoint.Types.Names.Symbolic GHC.Base.String
+ Language.Fixpoint.Types.Names: instance Language.Fixpoint.Types.Names.Symbolic Language.Fixpoint.Types.Names.Symbol
+ Language.Fixpoint.Types.Names: instance Language.Fixpoint.Types.Names.Symbolic a => Language.Fixpoint.Types.Names.Symbolic (Language.Fixpoint.Types.Spans.Located a)
+ Language.Fixpoint.Types.Names: instance Language.Fixpoint.Types.PrettyPrint.Fixpoint Data.Text.Internal.Text
+ Language.Fixpoint.Types.Names: instance Language.Fixpoint.Types.PrettyPrint.Fixpoint Language.Fixpoint.Types.Names.Symbol
+ Language.Fixpoint.Types.Names: instance Language.Fixpoint.Types.PrettyPrint.PPrint Language.Fixpoint.Types.Names.Symbol
+ Language.Fixpoint.Types.Names: intApplyName :: Int -> Symbol
+ Language.Fixpoint.Types.Names: intSymbol :: (Show a) => Symbol -> a -> Symbol
+ Language.Fixpoint.Types.Names: isDummy :: (Symbolic a) => a -> Bool
+ Language.Fixpoint.Types.Names: isNonSymbol :: Symbol -> Bool
+ Language.Fixpoint.Types.Names: isNontrivialVV :: Symbol -> Bool
+ Language.Fixpoint.Types.Names: isPrefixOfSym :: Symbol -> Symbol -> Bool
+ Language.Fixpoint.Types.Names: isSuffixOfSym :: Symbol -> Symbol -> Bool
+ Language.Fixpoint.Types.Names: kArgSymbol :: Symbol -> Symbol -> Symbol
+ Language.Fixpoint.Types.Names: lengthSym :: Symbol -> Int
+ Language.Fixpoint.Types.Names: listConName :: Symbol
+ Language.Fixpoint.Types.Names: listLConName :: Symbol
+ Language.Fixpoint.Types.Names: litSymbol :: Symbol -> Symbol
+ Language.Fixpoint.Types.Names: mapApplyName :: Int -> Symbol
+ Language.Fixpoint.Types.Names: mapToIntName :: Symbol
+ Language.Fixpoint.Types.Names: mulFuncName :: Symbol
+ Language.Fixpoint.Types.Names: nilName :: Symbol
+ Language.Fixpoint.Types.Names: nonSymbol :: Symbol
+ Language.Fixpoint.Types.Names: preludeName :: Symbol
+ Language.Fixpoint.Types.Names: prims :: [Symbol]
+ Language.Fixpoint.Types.Names: propConName :: Symbol
+ Language.Fixpoint.Types.Names: realApplyName :: Int -> Symbol
+ Language.Fixpoint.Types.Names: realToIntName :: Symbol
+ Language.Fixpoint.Types.Names: renameSymbol :: Symbol -> Int -> Symbol
+ Language.Fixpoint.Types.Names: setApplyName :: Int -> Symbol
+ Language.Fixpoint.Types.Names: setToIntName :: Symbol
+ Language.Fixpoint.Types.Names: size32Name :: Symbol
+ Language.Fixpoint.Types.Names: size64Name :: Symbol
+ Language.Fixpoint.Types.Names: strConName :: Symbol
+ Language.Fixpoint.Types.Names: stripPrefix :: Symbol -> Symbol -> Maybe Symbol
+ Language.Fixpoint.Types.Names: suffixSymbol :: Symbol -> Symbol -> Symbol
+ Language.Fixpoint.Types.Names: symChars :: HashSet Char
+ Language.Fixpoint.Types.Names: symbol :: Symbolic a => a -> Symbol
+ Language.Fixpoint.Types.Names: symbolSafeString :: Symbol -> String
+ Language.Fixpoint.Types.Names: symbolSafeText :: Symbol -> SafeText
+ Language.Fixpoint.Types.Names: symbolString :: Symbol -> String
+ Language.Fixpoint.Types.Names: symbolText :: Symbol -> Text
+ Language.Fixpoint.Types.Names: tempPrefix :: Symbol
+ Language.Fixpoint.Types.Names: tempSymbol :: Symbol -> Integer -> Symbol
+ Language.Fixpoint.Types.Names: tidySymbol :: Symbol -> Symbol
+ Language.Fixpoint.Types.Names: tupConName :: Symbol
+ Language.Fixpoint.Types.Names: type LocSymbol = Located Symbol
+ Language.Fixpoint.Types.Names: type LocText = Located Text
+ Language.Fixpoint.Types.Names: unLitSymbol :: Symbol -> Maybe Symbol
+ Language.Fixpoint.Types.Names: unconsSym :: Symbol -> Maybe (Char, Symbol)
+ Language.Fixpoint.Types.Names: vv :: Maybe Integer -> Symbol
+ Language.Fixpoint.Types.Names: vvCon :: Symbol
+ Language.Fixpoint.Types.Names: vvName :: Symbol
+ Language.Fixpoint.Types.PrettyPrint: DocTable :: [(Doc, Doc)] -> DocTable
+ Language.Fixpoint.Types.PrettyPrint: Full :: Tidy
+ Language.Fixpoint.Types.PrettyPrint: Lossy :: Tidy
+ Language.Fixpoint.Types.PrettyPrint: boxDoc :: Box -> Doc
+ Language.Fixpoint.Types.PrettyPrint: boxHSep :: Doc -> Doc -> Doc
+ Language.Fixpoint.Types.PrettyPrint: class Fixpoint a where simplify = id
+ Language.Fixpoint.Types.PrettyPrint: class PPrint a where pprintTidy = pprintPrec 0 pprintPrec _ = pprintTidy
+ Language.Fixpoint.Types.PrettyPrint: class PTable a
+ Language.Fixpoint.Types.PrettyPrint: data Tidy
+ Language.Fixpoint.Types.PrettyPrint: docBox :: Doc -> Box
+ Language.Fixpoint.Types.PrettyPrint: instance (GHC.Classes.Ord a, Data.Hashable.Class.Hashable a, Language.Fixpoint.Types.PrettyPrint.Fixpoint a) => Language.Fixpoint.Types.PrettyPrint.Fixpoint (Data.HashSet.HashSet a)
+ Language.Fixpoint.Types.PrettyPrint: instance (Language.Fixpoint.Types.PrettyPrint.Fixpoint a, Language.Fixpoint.Types.PrettyPrint.Fixpoint b) => Language.Fixpoint.Types.PrettyPrint.Fixpoint (a, b)
+ Language.Fixpoint.Types.PrettyPrint: instance (Language.Fixpoint.Types.PrettyPrint.Fixpoint a, Language.Fixpoint.Types.PrettyPrint.Fixpoint b, Language.Fixpoint.Types.PrettyPrint.Fixpoint c) => Language.Fixpoint.Types.PrettyPrint.Fixpoint (a, b, c)
+ Language.Fixpoint.Types.PrettyPrint: instance (Language.Fixpoint.Types.PrettyPrint.PPrint a, Language.Fixpoint.Types.PrettyPrint.PPrint b) => Language.Fixpoint.Types.PrettyPrint.PPrint (Data.HashMap.Base.HashMap a b)
+ Language.Fixpoint.Types.PrettyPrint: instance (Language.Fixpoint.Types.PrettyPrint.PPrint a, Language.Fixpoint.Types.PrettyPrint.PPrint b) => Language.Fixpoint.Types.PrettyPrint.PPrint (a, b)
+ Language.Fixpoint.Types.PrettyPrint: instance (Language.Fixpoint.Types.PrettyPrint.PPrint a, Language.Fixpoint.Types.PrettyPrint.PPrint b, Language.Fixpoint.Types.PrettyPrint.PPrint c) => Language.Fixpoint.Types.PrettyPrint.PPrint (a, b, c)
+ Language.Fixpoint.Types.PrettyPrint: instance GHC.Base.Monoid Language.Fixpoint.Types.PrettyPrint.DocTable
+ Language.Fixpoint.Types.PrettyPrint: instance GHC.Classes.Eq Language.Fixpoint.Types.PrettyPrint.Tidy
+ Language.Fixpoint.Types.PrettyPrint: instance GHC.Classes.Ord Language.Fixpoint.Types.PrettyPrint.Tidy
+ Language.Fixpoint.Types.PrettyPrint: instance Language.Fixpoint.Types.PrettyPrint.Fixpoint ()
+ Language.Fixpoint.Types.PrettyPrint: instance Language.Fixpoint.Types.PrettyPrint.Fixpoint GHC.Integer.Type.Integer
+ Language.Fixpoint.Types.PrettyPrint: instance Language.Fixpoint.Types.PrettyPrint.Fixpoint GHC.Types.Bool
+ Language.Fixpoint.Types.PrettyPrint: instance Language.Fixpoint.Types.PrettyPrint.Fixpoint GHC.Types.Double
+ Language.Fixpoint.Types.PrettyPrint: instance Language.Fixpoint.Types.PrettyPrint.Fixpoint GHC.Types.Int
+ Language.Fixpoint.Types.PrettyPrint: instance Language.Fixpoint.Types.PrettyPrint.Fixpoint a => Language.Fixpoint.Types.PrettyPrint.Fixpoint (GHC.Base.Maybe a)
+ Language.Fixpoint.Types.PrettyPrint: instance Language.Fixpoint.Types.PrettyPrint.Fixpoint a => Language.Fixpoint.Types.PrettyPrint.Fixpoint [a]
+ Language.Fixpoint.Types.PrettyPrint: instance Language.Fixpoint.Types.PrettyPrint.PPrint ()
+ Language.Fixpoint.Types.PrettyPrint: instance Language.Fixpoint.Types.PrettyPrint.PPrint Data.Text.Internal.Text
+ Language.Fixpoint.Types.PrettyPrint: instance Language.Fixpoint.Types.PrettyPrint.PPrint GHC.Base.String
+ Language.Fixpoint.Types.PrettyPrint: instance Language.Fixpoint.Types.PrettyPrint.PPrint GHC.Integer.Type.Integer
+ Language.Fixpoint.Types.PrettyPrint: instance Language.Fixpoint.Types.PrettyPrint.PPrint GHC.Types.Bool
+ Language.Fixpoint.Types.PrettyPrint: instance Language.Fixpoint.Types.PrettyPrint.PPrint GHC.Types.Float
+ Language.Fixpoint.Types.PrettyPrint: instance Language.Fixpoint.Types.PrettyPrint.PPrint GHC.Types.Int
+ Language.Fixpoint.Types.PrettyPrint: instance Language.Fixpoint.Types.PrettyPrint.PPrint Language.Fixpoint.Types.PrettyPrint.DocTable
+ Language.Fixpoint.Types.PrettyPrint: instance Language.Fixpoint.Types.PrettyPrint.PPrint Text.PrettyPrint.HughesPJ.Doc
+ Language.Fixpoint.Types.PrettyPrint: instance Language.Fixpoint.Types.PrettyPrint.PPrint a => Language.Fixpoint.Types.PrettyPrint.PPrint (Data.HashSet.HashSet a)
+ Language.Fixpoint.Types.PrettyPrint: instance Language.Fixpoint.Types.PrettyPrint.PPrint a => Language.Fixpoint.Types.PrettyPrint.PPrint (GHC.Base.Maybe a)
+ Language.Fixpoint.Types.PrettyPrint: instance Language.Fixpoint.Types.PrettyPrint.PPrint a => Language.Fixpoint.Types.PrettyPrint.PPrint [a]
+ Language.Fixpoint.Types.PrettyPrint: newtype DocTable
+ Language.Fixpoint.Types.PrettyPrint: pprint :: (PPrint a) => a -> Doc
+ Language.Fixpoint.Types.PrettyPrint: pprintKVs :: (PPrint k, PPrint v) => Tidy -> [(k, v)] -> Doc
+ Language.Fixpoint.Types.PrettyPrint: pprintPrec :: PPrint a => Int -> Tidy -> a -> Doc
+ Language.Fixpoint.Types.PrettyPrint: pprintTidy :: PPrint a => Tidy -> a -> Doc
+ Language.Fixpoint.Types.PrettyPrint: ptable :: PTable a => a -> DocTable
+ Language.Fixpoint.Types.PrettyPrint: showFix :: (Fixpoint a) => a -> String
+ Language.Fixpoint.Types.PrettyPrint: showpp :: (PPrint a) => a -> String
+ Language.Fixpoint.Types.PrettyPrint: simplify :: Fixpoint a => a -> a
+ Language.Fixpoint.Types.PrettyPrint: toFix :: Fixpoint a => a -> Doc
+ Language.Fixpoint.Types.PrettyPrint: traceFix :: (Fixpoint a) => String -> a -> a
+ Language.Fixpoint.Types.PrettyPrint: tracepp :: (PPrint a) => String -> a -> a
+ Language.Fixpoint.Types.Refinements: Div :: Bop
+ Language.Fixpoint.Types.Refinements: EApp :: !Expr -> !Expr -> Expr
+ Language.Fixpoint.Types.Refinements: EBin :: !Bop -> !Expr -> !Expr -> Expr
+ Language.Fixpoint.Types.Refinements: ECon :: !Constant -> Expr
+ Language.Fixpoint.Types.Refinements: ECst :: !Expr -> !Sort -> Expr
+ Language.Fixpoint.Types.Refinements: EIte :: !Expr -> !Expr -> !Expr -> Expr
+ Language.Fixpoint.Types.Refinements: ELam :: !(Symbol, Sort) -> !Expr -> Expr
+ Language.Fixpoint.Types.Refinements: ENeg :: !Expr -> Expr
+ Language.Fixpoint.Types.Refinements: ESym :: !SymConst -> Expr
+ Language.Fixpoint.Types.Refinements: ETAbs :: !Expr -> !Symbol -> Expr
+ Language.Fixpoint.Types.Refinements: ETApp :: !Expr -> !Sort -> Expr
+ Language.Fixpoint.Types.Refinements: EVar :: !Symbol -> Expr
+ Language.Fixpoint.Types.Refinements: Eq :: Brel
+ Language.Fixpoint.Types.Refinements: Ge :: Brel
+ Language.Fixpoint.Types.Refinements: Gt :: Brel
+ Language.Fixpoint.Types.Refinements: I :: !Integer -> Constant
+ Language.Fixpoint.Types.Refinements: KV :: Symbol -> KVar
+ Language.Fixpoint.Types.Refinements: L :: !Text -> !Sort -> Constant
+ Language.Fixpoint.Types.Refinements: Le :: Brel
+ Language.Fixpoint.Types.Refinements: Lt :: Brel
+ Language.Fixpoint.Types.Refinements: Minus :: Bop
+ Language.Fixpoint.Types.Refinements: Mod :: Bop
+ Language.Fixpoint.Types.Refinements: Ne :: Brel
+ Language.Fixpoint.Types.Refinements: PAll :: ![(Symbol, Sort)] -> !Expr -> Expr
+ Language.Fixpoint.Types.Refinements: PAnd :: ![Expr] -> Expr
+ Language.Fixpoint.Types.Refinements: PAtom :: !Brel -> !Expr -> !Expr -> Expr
+ Language.Fixpoint.Types.Refinements: PExist :: ![(Symbol, Sort)] -> !Expr -> Expr
+ Language.Fixpoint.Types.Refinements: PGrad :: Expr
+ Language.Fixpoint.Types.Refinements: PIff :: !Expr -> !Expr -> Expr
+ Language.Fixpoint.Types.Refinements: PImp :: !Expr -> !Expr -> Expr
+ Language.Fixpoint.Types.Refinements: PKVar :: !KVar -> !Subst -> Expr
+ Language.Fixpoint.Types.Refinements: PNot :: !Expr -> Expr
+ Language.Fixpoint.Types.Refinements: POr :: ![Expr] -> Expr
+ Language.Fixpoint.Types.Refinements: Plus :: Bop
+ Language.Fixpoint.Types.Refinements: R :: !Double -> Constant
+ Language.Fixpoint.Types.Refinements: RDiv :: Bop
+ Language.Fixpoint.Types.Refinements: RR :: !Sort -> !Reft -> SortedReft
+ Language.Fixpoint.Types.Refinements: RTimes :: Bop
+ Language.Fixpoint.Types.Refinements: Reft :: (Symbol, Expr) -> Reft
+ Language.Fixpoint.Types.Refinements: SL :: !Text -> SymConst
+ Language.Fixpoint.Types.Refinements: Su :: (HashMap Symbol Expr) -> Subst
+ Language.Fixpoint.Types.Refinements: Times :: Bop
+ Language.Fixpoint.Types.Refinements: Ueq :: Brel
+ Language.Fixpoint.Types.Refinements: Une :: Brel
+ Language.Fixpoint.Types.Refinements: [kv] :: KVar -> Symbol
+ Language.Fixpoint.Types.Refinements: [sr_reft] :: SortedReft -> !Reft
+ Language.Fixpoint.Types.Refinements: [sr_sort] :: SortedReft -> !Sort
+ Language.Fixpoint.Types.Refinements: bot :: Reftable r => r -> r
+ Language.Fixpoint.Types.Refinements: class Expression a
+ Language.Fixpoint.Types.Refinements: class Predicate a
+ Language.Fixpoint.Types.Refinements: class (Monoid r, Subable r) => Reftable r where top _ = mempty meet = mappend
+ Language.Fixpoint.Types.Refinements: class Subable a where subst1 y (x, e) = subst (Su $ fromList [(x, e)]) y
+ Language.Fixpoint.Types.Refinements: conjuncts :: Expr -> [Expr]
+ Language.Fixpoint.Types.Refinements: data Bop
+ Language.Fixpoint.Types.Refinements: data Brel
+ Language.Fixpoint.Types.Refinements: data Constant
+ Language.Fixpoint.Types.Refinements: data Expr
+ Language.Fixpoint.Types.Refinements: data SortedReft
+ Language.Fixpoint.Types.Refinements: data SymConst
+ Language.Fixpoint.Types.Refinements: eApps :: Expr -> [Expr] -> Expr
+ Language.Fixpoint.Types.Refinements: eProp :: Symbolic a => a -> Expr
+ Language.Fixpoint.Types.Refinements: eVar :: Symbolic a => a -> Expr
+ Language.Fixpoint.Types.Refinements: elit :: Located Symbol -> Sort -> Expr
+ Language.Fixpoint.Types.Refinements: expr :: Expression a => a -> Expr
+ Language.Fixpoint.Types.Refinements: exprReft :: (Expression a) => a -> Reft
+ Language.Fixpoint.Types.Refinements: falseReft :: Reft
+ Language.Fixpoint.Types.Refinements: flattenRefas :: [Expr] -> [Expr]
+ Language.Fixpoint.Types.Refinements: functionSort :: Sort -> Maybe ([Int], [Sort], Sort)
+ Language.Fixpoint.Types.Refinements: instance (Data.Hashable.Class.Hashable k, GHC.Classes.Eq k, Data.Binary.Class.Binary k, Data.Binary.Class.Binary v) => Data.Binary.Class.Binary (Data.HashMap.Base.HashMap k v)
+ Language.Fixpoint.Types.Refinements: instance Control.DeepSeq.NFData Language.Fixpoint.Types.Refinements.Bop
+ Language.Fixpoint.Types.Refinements: instance Control.DeepSeq.NFData Language.Fixpoint.Types.Refinements.Brel
+ Language.Fixpoint.Types.Refinements: instance Control.DeepSeq.NFData Language.Fixpoint.Types.Refinements.Constant
+ Language.Fixpoint.Types.Refinements: instance Control.DeepSeq.NFData Language.Fixpoint.Types.Refinements.Expr
+ Language.Fixpoint.Types.Refinements: instance Control.DeepSeq.NFData Language.Fixpoint.Types.Refinements.KVar
+ Language.Fixpoint.Types.Refinements: instance Control.DeepSeq.NFData Language.Fixpoint.Types.Refinements.Reft
+ Language.Fixpoint.Types.Refinements: instance Control.DeepSeq.NFData Language.Fixpoint.Types.Refinements.SortedReft
+ Language.Fixpoint.Types.Refinements: instance Control.DeepSeq.NFData Language.Fixpoint.Types.Refinements.Subst
+ Language.Fixpoint.Types.Refinements: instance Control.DeepSeq.NFData Language.Fixpoint.Types.Refinements.SymConst
+ Language.Fixpoint.Types.Refinements: instance Data.Binary.Class.Binary Language.Fixpoint.Types.Refinements.Bop
+ Language.Fixpoint.Types.Refinements: instance Data.Binary.Class.Binary Language.Fixpoint.Types.Refinements.Brel
+ Language.Fixpoint.Types.Refinements: instance Data.Binary.Class.Binary Language.Fixpoint.Types.Refinements.Constant
+ Language.Fixpoint.Types.Refinements: instance Data.Binary.Class.Binary Language.Fixpoint.Types.Refinements.Expr
+ Language.Fixpoint.Types.Refinements: instance Data.Binary.Class.Binary Language.Fixpoint.Types.Refinements.KVar
+ Language.Fixpoint.Types.Refinements: instance Data.Binary.Class.Binary Language.Fixpoint.Types.Refinements.Reft
+ Language.Fixpoint.Types.Refinements: instance Data.Binary.Class.Binary Language.Fixpoint.Types.Refinements.SortedReft
+ Language.Fixpoint.Types.Refinements: instance Data.Binary.Class.Binary Language.Fixpoint.Types.Refinements.Subst
+ Language.Fixpoint.Types.Refinements: instance Data.Binary.Class.Binary Language.Fixpoint.Types.Refinements.SymConst
+ Language.Fixpoint.Types.Refinements: instance Data.Data.Data Language.Fixpoint.Types.Refinements.Bop
+ Language.Fixpoint.Types.Refinements: instance Data.Data.Data Language.Fixpoint.Types.Refinements.Brel
+ Language.Fixpoint.Types.Refinements: instance Data.Data.Data Language.Fixpoint.Types.Refinements.Constant
+ Language.Fixpoint.Types.Refinements: instance Data.Data.Data Language.Fixpoint.Types.Refinements.Expr
+ Language.Fixpoint.Types.Refinements: instance Data.Data.Data Language.Fixpoint.Types.Refinements.KVar
+ Language.Fixpoint.Types.Refinements: instance Data.Data.Data Language.Fixpoint.Types.Refinements.Reft
+ Language.Fixpoint.Types.Refinements: instance Data.Data.Data Language.Fixpoint.Types.Refinements.SortedReft
+ Language.Fixpoint.Types.Refinements: instance Data.Data.Data Language.Fixpoint.Types.Refinements.Subst
+ Language.Fixpoint.Types.Refinements: instance Data.Data.Data Language.Fixpoint.Types.Refinements.SymConst
+ Language.Fixpoint.Types.Refinements: instance Data.Hashable.Class.Hashable Language.Fixpoint.Types.Refinements.Bop
+ Language.Fixpoint.Types.Refinements: instance Data.Hashable.Class.Hashable Language.Fixpoint.Types.Refinements.Brel
+ Language.Fixpoint.Types.Refinements: instance Data.Hashable.Class.Hashable Language.Fixpoint.Types.Refinements.Constant
+ Language.Fixpoint.Types.Refinements: instance Data.Hashable.Class.Hashable Language.Fixpoint.Types.Refinements.KVar
+ Language.Fixpoint.Types.Refinements: instance Data.Hashable.Class.Hashable Language.Fixpoint.Types.Refinements.SymConst
+ Language.Fixpoint.Types.Refinements: instance Data.String.IsString Language.Fixpoint.Types.Refinements.KVar
+ Language.Fixpoint.Types.Refinements: instance GHC.Classes.Eq Language.Fixpoint.Types.Refinements.Bop
+ Language.Fixpoint.Types.Refinements: instance GHC.Classes.Eq Language.Fixpoint.Types.Refinements.Brel
+ Language.Fixpoint.Types.Refinements: instance GHC.Classes.Eq Language.Fixpoint.Types.Refinements.Constant
+ Language.Fixpoint.Types.Refinements: instance GHC.Classes.Eq Language.Fixpoint.Types.Refinements.Expr
+ Language.Fixpoint.Types.Refinements: instance GHC.Classes.Eq Language.Fixpoint.Types.Refinements.KVar
+ Language.Fixpoint.Types.Refinements: instance GHC.Classes.Eq Language.Fixpoint.Types.Refinements.Reft
+ Language.Fixpoint.Types.Refinements: instance GHC.Classes.Eq Language.Fixpoint.Types.Refinements.SortedReft
+ Language.Fixpoint.Types.Refinements: instance GHC.Classes.Eq Language.Fixpoint.Types.Refinements.Subst
+ Language.Fixpoint.Types.Refinements: instance GHC.Classes.Eq Language.Fixpoint.Types.Refinements.SymConst
+ Language.Fixpoint.Types.Refinements: instance GHC.Classes.Ord Language.Fixpoint.Types.Refinements.Bop
+ Language.Fixpoint.Types.Refinements: instance GHC.Classes.Ord Language.Fixpoint.Types.Refinements.Brel
+ Language.Fixpoint.Types.Refinements: instance GHC.Classes.Ord Language.Fixpoint.Types.Refinements.Constant
+ Language.Fixpoint.Types.Refinements: instance GHC.Classes.Ord Language.Fixpoint.Types.Refinements.KVar
+ Language.Fixpoint.Types.Refinements: instance GHC.Classes.Ord Language.Fixpoint.Types.Refinements.SymConst
+ Language.Fixpoint.Types.Refinements: instance GHC.Generics.Constructor Language.Fixpoint.Types.Refinements.C1_0Bop
+ Language.Fixpoint.Types.Refinements: instance GHC.Generics.Constructor Language.Fixpoint.Types.Refinements.C1_0Brel
+ Language.Fixpoint.Types.Refinements: instance GHC.Generics.Constructor Language.Fixpoint.Types.Refinements.C1_0Constant
+ Language.Fixpoint.Types.Refinements: instance GHC.Generics.Constructor Language.Fixpoint.Types.Refinements.C1_0Expr
+ Language.Fixpoint.Types.Refinements: instance GHC.Generics.Constructor Language.Fixpoint.Types.Refinements.C1_0KVar
+ Language.Fixpoint.Types.Refinements: instance GHC.Generics.Constructor Language.Fixpoint.Types.Refinements.C1_0Reft
+ Language.Fixpoint.Types.Refinements: instance GHC.Generics.Constructor Language.Fixpoint.Types.Refinements.C1_0SortedReft
+ Language.Fixpoint.Types.Refinements: instance GHC.Generics.Constructor Language.Fixpoint.Types.Refinements.C1_0Subst
+ Language.Fixpoint.Types.Refinements: instance GHC.Generics.Constructor Language.Fixpoint.Types.Refinements.C1_0SymConst
+ Language.Fixpoint.Types.Refinements: instance GHC.Generics.Constructor Language.Fixpoint.Types.Refinements.C1_10Expr
+ Language.Fixpoint.Types.Refinements: instance GHC.Generics.Constructor Language.Fixpoint.Types.Refinements.C1_11Expr
+ Language.Fixpoint.Types.Refinements: instance GHC.Generics.Constructor Language.Fixpoint.Types.Refinements.C1_12Expr
+ Language.Fixpoint.Types.Refinements: instance GHC.Generics.Constructor Language.Fixpoint.Types.Refinements.C1_13Expr
+ Language.Fixpoint.Types.Refinements: instance GHC.Generics.Constructor Language.Fixpoint.Types.Refinements.C1_14Expr
+ Language.Fixpoint.Types.Refinements: instance GHC.Generics.Constructor Language.Fixpoint.Types.Refinements.C1_15Expr
+ Language.Fixpoint.Types.Refinements: instance GHC.Generics.Constructor Language.Fixpoint.Types.Refinements.C1_16Expr
+ Language.Fixpoint.Types.Refinements: instance GHC.Generics.Constructor Language.Fixpoint.Types.Refinements.C1_17Expr
+ Language.Fixpoint.Types.Refinements: instance GHC.Generics.Constructor Language.Fixpoint.Types.Refinements.C1_18Expr
+ Language.Fixpoint.Types.Refinements: instance GHC.Generics.Constructor Language.Fixpoint.Types.Refinements.C1_19Expr
+ Language.Fixpoint.Types.Refinements: instance GHC.Generics.Constructor Language.Fixpoint.Types.Refinements.C1_1Bop
+ Language.Fixpoint.Types.Refinements: instance GHC.Generics.Constructor Language.Fixpoint.Types.Refinements.C1_1Brel
+ Language.Fixpoint.Types.Refinements: instance GHC.Generics.Constructor Language.Fixpoint.Types.Refinements.C1_1Constant
+ Language.Fixpoint.Types.Refinements: instance GHC.Generics.Constructor Language.Fixpoint.Types.Refinements.C1_1Expr
+ Language.Fixpoint.Types.Refinements: instance GHC.Generics.Constructor Language.Fixpoint.Types.Refinements.C1_20Expr
+ Language.Fixpoint.Types.Refinements: instance GHC.Generics.Constructor Language.Fixpoint.Types.Refinements.C1_2Bop
+ Language.Fixpoint.Types.Refinements: instance GHC.Generics.Constructor Language.Fixpoint.Types.Refinements.C1_2Brel
+ Language.Fixpoint.Types.Refinements: instance GHC.Generics.Constructor Language.Fixpoint.Types.Refinements.C1_2Constant
+ Language.Fixpoint.Types.Refinements: instance GHC.Generics.Constructor Language.Fixpoint.Types.Refinements.C1_2Expr
+ Language.Fixpoint.Types.Refinements: instance GHC.Generics.Constructor Language.Fixpoint.Types.Refinements.C1_3Bop
+ Language.Fixpoint.Types.Refinements: instance GHC.Generics.Constructor Language.Fixpoint.Types.Refinements.C1_3Brel
+ Language.Fixpoint.Types.Refinements: instance GHC.Generics.Constructor Language.Fixpoint.Types.Refinements.C1_3Expr
+ Language.Fixpoint.Types.Refinements: instance GHC.Generics.Constructor Language.Fixpoint.Types.Refinements.C1_4Bop
+ Language.Fixpoint.Types.Refinements: instance GHC.Generics.Constructor Language.Fixpoint.Types.Refinements.C1_4Brel
+ Language.Fixpoint.Types.Refinements: instance GHC.Generics.Constructor Language.Fixpoint.Types.Refinements.C1_4Expr
+ Language.Fixpoint.Types.Refinements: instance GHC.Generics.Constructor Language.Fixpoint.Types.Refinements.C1_5Bop
+ Language.Fixpoint.Types.Refinements: instance GHC.Generics.Constructor Language.Fixpoint.Types.Refinements.C1_5Brel
+ Language.Fixpoint.Types.Refinements: instance GHC.Generics.Constructor Language.Fixpoint.Types.Refinements.C1_5Expr
+ Language.Fixpoint.Types.Refinements: instance GHC.Generics.Constructor Language.Fixpoint.Types.Refinements.C1_6Bop
+ Language.Fixpoint.Types.Refinements: instance GHC.Generics.Constructor Language.Fixpoint.Types.Refinements.C1_6Brel
+ Language.Fixpoint.Types.Refinements: instance GHC.Generics.Constructor Language.Fixpoint.Types.Refinements.C1_6Expr
+ Language.Fixpoint.Types.Refinements: instance GHC.Generics.Constructor Language.Fixpoint.Types.Refinements.C1_7Brel
+ Language.Fixpoint.Types.Refinements: instance GHC.Generics.Constructor Language.Fixpoint.Types.Refinements.C1_7Expr
+ Language.Fixpoint.Types.Refinements: instance GHC.Generics.Constructor Language.Fixpoint.Types.Refinements.C1_8Expr
+ Language.Fixpoint.Types.Refinements: instance GHC.Generics.Constructor Language.Fixpoint.Types.Refinements.C1_9Expr
+ Language.Fixpoint.Types.Refinements: instance GHC.Generics.Datatype Language.Fixpoint.Types.Refinements.D1Bop
+ Language.Fixpoint.Types.Refinements: instance GHC.Generics.Datatype Language.Fixpoint.Types.Refinements.D1Brel
+ Language.Fixpoint.Types.Refinements: instance GHC.Generics.Datatype Language.Fixpoint.Types.Refinements.D1Constant
+ Language.Fixpoint.Types.Refinements: instance GHC.Generics.Datatype Language.Fixpoint.Types.Refinements.D1Expr
+ Language.Fixpoint.Types.Refinements: instance GHC.Generics.Datatype Language.Fixpoint.Types.Refinements.D1KVar
+ Language.Fixpoint.Types.Refinements: instance GHC.Generics.Datatype Language.Fixpoint.Types.Refinements.D1Reft
+ Language.Fixpoint.Types.Refinements: instance GHC.Generics.Datatype Language.Fixpoint.Types.Refinements.D1SortedReft
+ Language.Fixpoint.Types.Refinements: instance GHC.Generics.Datatype Language.Fixpoint.Types.Refinements.D1Subst
+ Language.Fixpoint.Types.Refinements: instance GHC.Generics.Datatype Language.Fixpoint.Types.Refinements.D1SymConst
+ Language.Fixpoint.Types.Refinements: instance GHC.Generics.Generic Language.Fixpoint.Types.Refinements.Bop
+ Language.Fixpoint.Types.Refinements: instance GHC.Generics.Generic Language.Fixpoint.Types.Refinements.Brel
+ Language.Fixpoint.Types.Refinements: instance GHC.Generics.Generic Language.Fixpoint.Types.Refinements.Constant
+ Language.Fixpoint.Types.Refinements: instance GHC.Generics.Generic Language.Fixpoint.Types.Refinements.Expr
+ Language.Fixpoint.Types.Refinements: instance GHC.Generics.Generic Language.Fixpoint.Types.Refinements.KVar
+ Language.Fixpoint.Types.Refinements: instance GHC.Generics.Generic Language.Fixpoint.Types.Refinements.Reft
+ Language.Fixpoint.Types.Refinements: instance GHC.Generics.Generic Language.Fixpoint.Types.Refinements.SortedReft
+ Language.Fixpoint.Types.Refinements: instance GHC.Generics.Generic Language.Fixpoint.Types.Refinements.Subst
+ Language.Fixpoint.Types.Refinements: instance GHC.Generics.Generic Language.Fixpoint.Types.Refinements.SymConst
+ Language.Fixpoint.Types.Refinements: instance GHC.Generics.Selector Language.Fixpoint.Types.Refinements.S1_0_0KVar
+ Language.Fixpoint.Types.Refinements: instance GHC.Generics.Selector Language.Fixpoint.Types.Refinements.S1_0_0SortedReft
+ Language.Fixpoint.Types.Refinements: instance GHC.Generics.Selector Language.Fixpoint.Types.Refinements.S1_0_1SortedReft
+ Language.Fixpoint.Types.Refinements: instance GHC.Show.Show Language.Fixpoint.Types.Refinements.Bop
+ Language.Fixpoint.Types.Refinements: instance GHC.Show.Show Language.Fixpoint.Types.Refinements.Brel
+ Language.Fixpoint.Types.Refinements: instance GHC.Show.Show Language.Fixpoint.Types.Refinements.Constant
+ Language.Fixpoint.Types.Refinements: instance GHC.Show.Show Language.Fixpoint.Types.Refinements.Expr
+ Language.Fixpoint.Types.Refinements: instance GHC.Show.Show Language.Fixpoint.Types.Refinements.KVar
+ Language.Fixpoint.Types.Refinements: instance GHC.Show.Show Language.Fixpoint.Types.Refinements.Subst
+ Language.Fixpoint.Types.Refinements: instance GHC.Show.Show Language.Fixpoint.Types.Refinements.SymConst
+ Language.Fixpoint.Types.Refinements: instance Language.Fixpoint.Types.Names.Symbolic Language.Fixpoint.Types.Refinements.SymConst
+ Language.Fixpoint.Types.Refinements: instance Language.Fixpoint.Types.PrettyPrint.Fixpoint Language.Fixpoint.Types.Refinements.Bop
+ Language.Fixpoint.Types.Refinements: instance Language.Fixpoint.Types.PrettyPrint.Fixpoint Language.Fixpoint.Types.Refinements.Brel
+ Language.Fixpoint.Types.Refinements: instance Language.Fixpoint.Types.PrettyPrint.Fixpoint Language.Fixpoint.Types.Refinements.Constant
+ Language.Fixpoint.Types.Refinements: instance Language.Fixpoint.Types.PrettyPrint.Fixpoint Language.Fixpoint.Types.Refinements.Expr
+ Language.Fixpoint.Types.Refinements: instance Language.Fixpoint.Types.PrettyPrint.Fixpoint Language.Fixpoint.Types.Refinements.KVar
+ Language.Fixpoint.Types.Refinements: instance Language.Fixpoint.Types.PrettyPrint.Fixpoint Language.Fixpoint.Types.Refinements.Subst
+ Language.Fixpoint.Types.Refinements: instance Language.Fixpoint.Types.PrettyPrint.Fixpoint Language.Fixpoint.Types.Refinements.SymConst
+ Language.Fixpoint.Types.Refinements: instance Language.Fixpoint.Types.PrettyPrint.PPrint Language.Fixpoint.Types.Refinements.Bop
+ Language.Fixpoint.Types.Refinements: instance Language.Fixpoint.Types.PrettyPrint.PPrint Language.Fixpoint.Types.Refinements.Brel
+ Language.Fixpoint.Types.Refinements: instance Language.Fixpoint.Types.PrettyPrint.PPrint Language.Fixpoint.Types.Refinements.Constant
+ Language.Fixpoint.Types.Refinements: instance Language.Fixpoint.Types.PrettyPrint.PPrint Language.Fixpoint.Types.Refinements.Expr
+ Language.Fixpoint.Types.Refinements: instance Language.Fixpoint.Types.PrettyPrint.PPrint Language.Fixpoint.Types.Refinements.KVar
+ Language.Fixpoint.Types.Refinements: instance Language.Fixpoint.Types.PrettyPrint.PPrint Language.Fixpoint.Types.Refinements.SymConst
+ Language.Fixpoint.Types.Refinements: instance Language.Fixpoint.Types.PrettyPrint.PPrint Language.Fixpoint.Types.Sorts.Sort
+ Language.Fixpoint.Types.Refinements: instance Language.Fixpoint.Types.Refinements.Expression Data.Text.Internal.Text
+ Language.Fixpoint.Types.Refinements: instance Language.Fixpoint.Types.Refinements.Expression GHC.Integer.Type.Integer
+ Language.Fixpoint.Types.Refinements: instance Language.Fixpoint.Types.Refinements.Expression GHC.Types.Int
+ Language.Fixpoint.Types.Refinements: instance Language.Fixpoint.Types.Refinements.Expression Language.Fixpoint.Types.Names.Symbol
+ Language.Fixpoint.Types.Refinements: instance Language.Fixpoint.Types.Refinements.Expression Language.Fixpoint.Types.Refinements.Expr
+ Language.Fixpoint.Types.Refinements: instance Language.Fixpoint.Types.Refinements.Expression a => Language.Fixpoint.Types.Refinements.Expression (Language.Fixpoint.Types.Spans.Located a)
+ Language.Fixpoint.Types.Refinements: instance Language.Fixpoint.Types.Refinements.Falseable Language.Fixpoint.Types.Refinements.Expr
+ Language.Fixpoint.Types.Refinements: instance Language.Fixpoint.Types.Refinements.Falseable Language.Fixpoint.Types.Refinements.Reft
+ Language.Fixpoint.Types.Refinements: instance Language.Fixpoint.Types.Refinements.Predicate GHC.Types.Bool
+ Language.Fixpoint.Types.Refinements: instance Language.Fixpoint.Types.Refinements.Predicate Language.Fixpoint.Types.Names.Symbol
+ Language.Fixpoint.Types.Refinements: instance Language.Fixpoint.Types.Refinements.Predicate Language.Fixpoint.Types.Refinements.Expr
+ Language.Fixpoint.Types.Refinements: instance Language.Fixpoint.Types.Refinements.Subable a => Language.Fixpoint.Types.Refinements.Subable (Language.Fixpoint.Types.Spans.Located a)
+ Language.Fixpoint.Types.Refinements: intKvar :: Integer -> KVar
+ Language.Fixpoint.Types.Refinements: isEVar :: Expr -> Bool
+ Language.Fixpoint.Types.Refinements: isFalse :: Falseable a => a -> Bool
+ Language.Fixpoint.Types.Refinements: isFunctionSortedReft :: SortedReft -> Bool
+ Language.Fixpoint.Types.Refinements: isNonTrivial :: Reftable r => r -> Bool
+ Language.Fixpoint.Types.Refinements: isSingletonReft :: Reft -> Maybe Expr
+ Language.Fixpoint.Types.Refinements: isTauto :: Reftable r => r -> Bool
+ Language.Fixpoint.Types.Refinements: isTautoPred :: Expr -> Bool
+ Language.Fixpoint.Types.Refinements: mapPredReft :: (Expr -> Expr) -> Reft -> Reft
+ Language.Fixpoint.Types.Refinements: meet :: Reftable r => r -> r -> r
+ Language.Fixpoint.Types.Refinements: mkEApp :: LocSymbol -> [Expr] -> Expr
+ Language.Fixpoint.Types.Refinements: newtype KVar
+ Language.Fixpoint.Types.Refinements: newtype Reft
+ Language.Fixpoint.Types.Refinements: newtype Subst
+ Language.Fixpoint.Types.Refinements: notExprReft :: (Expression a) => a -> Reft
+ Language.Fixpoint.Types.Refinements: ofReft :: Reftable r => Reft -> r
+ Language.Fixpoint.Types.Refinements: pAnd :: ListNE Expr -> Expr
+ Language.Fixpoint.Types.Refinements: pIte :: Expr -> Expr -> Expr -> Expr
+ Language.Fixpoint.Types.Refinements: pOr :: ListNE Expr -> Expr
+ Language.Fixpoint.Types.Refinements: params :: Reftable r => r -> [Symbol]
+ Language.Fixpoint.Types.Refinements: ppTy :: Reftable r => r -> Doc -> Doc
+ Language.Fixpoint.Types.Refinements: pprintReft :: Tidy -> Reft -> Doc
+ Language.Fixpoint.Types.Refinements: predReft :: (Predicate a) => a -> Reft
+ Language.Fixpoint.Types.Refinements: prop :: Predicate a => a -> Expr
+ Language.Fixpoint.Types.Refinements: propReft :: (Predicate a) => a -> Reft
+ Language.Fixpoint.Types.Refinements: reft :: Symbol -> Expr -> Reft
+ Language.Fixpoint.Types.Refinements: reftBind :: Reft -> Symbol
+ Language.Fixpoint.Types.Refinements: reftConjuncts :: Reft -> [Reft]
+ Language.Fixpoint.Types.Refinements: reftPred :: Reft -> Expr
+ Language.Fixpoint.Types.Refinements: splitEApp :: Expr -> (Expr, [Expr])
+ Language.Fixpoint.Types.Refinements: subst :: Subable a => Subst -> a -> a
+ Language.Fixpoint.Types.Refinements: subst1 :: Subable a => a -> (Symbol, Expr) -> a
+ Language.Fixpoint.Types.Refinements: substa :: Subable a => (Symbol -> Symbol) -> a -> a
+ Language.Fixpoint.Types.Refinements: substf :: Subable a => (Symbol -> Expr) -> a -> a
+ Language.Fixpoint.Types.Refinements: symbolReft :: (Symbolic a) => a -> Reft
+ Language.Fixpoint.Types.Refinements: syms :: Subable a => a -> [Symbol]
+ Language.Fixpoint.Types.Refinements: toReft :: Reftable r => r -> Reft
+ Language.Fixpoint.Types.Refinements: top :: Reftable r => r -> r
+ Language.Fixpoint.Types.Refinements: trueReft :: Reft
+ Language.Fixpoint.Types.Refinements: trueSortedReft :: Sort -> SortedReft
+ Language.Fixpoint.Types.Refinements: type Pred = Expr
+ Language.Fixpoint.Types.Refinements: uexprReft :: (Expression a) => a -> Reft
+ Language.Fixpoint.Types.Refinements: usymbolReft :: (Symbolic a) => a -> Reft
+ Language.Fixpoint.Types.Refinements: vv_ :: Symbol
+ Language.Fixpoint.Types.Sorts: FAbs :: !Int -> !Sort -> Sort
+ Language.Fixpoint.Types.Sorts: FApp :: Sort -> Sort -> Sort
+ Language.Fixpoint.Types.Sorts: FFrac :: Sort
+ Language.Fixpoint.Types.Sorts: FFunc :: !Sort -> !Sort -> Sort
+ Language.Fixpoint.Types.Sorts: FInt :: Sort
+ Language.Fixpoint.Types.Sorts: FNum :: Sort
+ Language.Fixpoint.Types.Sorts: FObj :: Symbol -> Sort
+ Language.Fixpoint.Types.Sorts: FReal :: Sort
+ Language.Fixpoint.Types.Sorts: FTC :: FTycon -> Sort
+ Language.Fixpoint.Types.Sorts: FVar :: !Int -> Sort
+ Language.Fixpoint.Types.Sorts: Sub :: [(Int, Sort)] -> Sub
+ Language.Fixpoint.Types.Sorts: bitVecSort :: Sort
+ Language.Fixpoint.Types.Sorts: bkFFunc :: Sort -> Maybe (Int, [Sort])
+ Language.Fixpoint.Types.Sorts: boolFTyCon :: FTycon
+ Language.Fixpoint.Types.Sorts: boolSort :: Sort
+ Language.Fixpoint.Types.Sorts: data FTycon
+ Language.Fixpoint.Types.Sorts: data Sort
+ Language.Fixpoint.Types.Sorts: fApp :: Sort -> [Sort] -> Sort
+ Language.Fixpoint.Types.Sorts: fApp' :: Sort -> ListNE Sort
+ Language.Fixpoint.Types.Sorts: fAppTC :: FTycon -> [Sort] -> Sort
+ Language.Fixpoint.Types.Sorts: fObj :: LocSymbol -> Sort
+ Language.Fixpoint.Types.Sorts: fTyconSort :: FTycon -> Sort
+ Language.Fixpoint.Types.Sorts: fTyconSymbol :: FTycon -> Located Symbol
+ Language.Fixpoint.Types.Sorts: funcSort :: Sort
+ Language.Fixpoint.Types.Sorts: functionSort :: Sort -> Maybe ([Int], [Sort], Sort)
+ Language.Fixpoint.Types.Sorts: instance Control.DeepSeq.NFData Language.Fixpoint.Types.Sorts.FTycon
+ Language.Fixpoint.Types.Sorts: instance Control.DeepSeq.NFData Language.Fixpoint.Types.Sorts.Sort
+ Language.Fixpoint.Types.Sorts: instance Control.DeepSeq.NFData Language.Fixpoint.Types.Sorts.Sub
+ Language.Fixpoint.Types.Sorts: instance Data.Binary.Class.Binary Language.Fixpoint.Types.Sorts.FTycon
+ Language.Fixpoint.Types.Sorts: instance Data.Binary.Class.Binary Language.Fixpoint.Types.Sorts.Sort
+ Language.Fixpoint.Types.Sorts: instance Data.Binary.Class.Binary Language.Fixpoint.Types.Sorts.Sub
+ Language.Fixpoint.Types.Sorts: instance Data.Data.Data Language.Fixpoint.Types.Sorts.FTycon
+ Language.Fixpoint.Types.Sorts: instance Data.Data.Data Language.Fixpoint.Types.Sorts.Sort
+ Language.Fixpoint.Types.Sorts: instance Data.Hashable.Class.Hashable Language.Fixpoint.Types.Sorts.FTycon
+ Language.Fixpoint.Types.Sorts: instance Data.Hashable.Class.Hashable Language.Fixpoint.Types.Sorts.Sort
+ Language.Fixpoint.Types.Sorts: instance GHC.Base.Monoid Language.Fixpoint.Types.Sorts.Sort
+ Language.Fixpoint.Types.Sorts: instance GHC.Classes.Eq Language.Fixpoint.Types.Sorts.FTycon
+ Language.Fixpoint.Types.Sorts: instance GHC.Classes.Eq Language.Fixpoint.Types.Sorts.Sort
+ Language.Fixpoint.Types.Sorts: instance GHC.Classes.Ord Language.Fixpoint.Types.Sorts.FTycon
+ Language.Fixpoint.Types.Sorts: instance GHC.Classes.Ord Language.Fixpoint.Types.Sorts.Sort
+ Language.Fixpoint.Types.Sorts: instance GHC.Generics.Constructor Language.Fixpoint.Types.Sorts.C1_0FTycon
+ Language.Fixpoint.Types.Sorts: instance GHC.Generics.Constructor Language.Fixpoint.Types.Sorts.C1_0Sort
+ Language.Fixpoint.Types.Sorts: instance GHC.Generics.Constructor Language.Fixpoint.Types.Sorts.C1_0Sub
+ Language.Fixpoint.Types.Sorts: instance GHC.Generics.Constructor Language.Fixpoint.Types.Sorts.C1_1Sort
+ Language.Fixpoint.Types.Sorts: instance GHC.Generics.Constructor Language.Fixpoint.Types.Sorts.C1_2Sort
+ Language.Fixpoint.Types.Sorts: instance GHC.Generics.Constructor Language.Fixpoint.Types.Sorts.C1_3Sort
+ Language.Fixpoint.Types.Sorts: instance GHC.Generics.Constructor Language.Fixpoint.Types.Sorts.C1_4Sort
+ Language.Fixpoint.Types.Sorts: instance GHC.Generics.Constructor Language.Fixpoint.Types.Sorts.C1_5Sort
+ Language.Fixpoint.Types.Sorts: instance GHC.Generics.Constructor Language.Fixpoint.Types.Sorts.C1_6Sort
+ Language.Fixpoint.Types.Sorts: instance GHC.Generics.Constructor Language.Fixpoint.Types.Sorts.C1_7Sort
+ Language.Fixpoint.Types.Sorts: instance GHC.Generics.Constructor Language.Fixpoint.Types.Sorts.C1_8Sort
+ Language.Fixpoint.Types.Sorts: instance GHC.Generics.Constructor Language.Fixpoint.Types.Sorts.C1_9Sort
+ Language.Fixpoint.Types.Sorts: instance GHC.Generics.Datatype Language.Fixpoint.Types.Sorts.D1FTycon
+ Language.Fixpoint.Types.Sorts: instance GHC.Generics.Datatype Language.Fixpoint.Types.Sorts.D1Sort
+ Language.Fixpoint.Types.Sorts: instance GHC.Generics.Datatype Language.Fixpoint.Types.Sorts.D1Sub
+ Language.Fixpoint.Types.Sorts: instance GHC.Generics.Generic Language.Fixpoint.Types.Sorts.FTycon
+ Language.Fixpoint.Types.Sorts: instance GHC.Generics.Generic Language.Fixpoint.Types.Sorts.Sort
+ Language.Fixpoint.Types.Sorts: instance GHC.Generics.Generic Language.Fixpoint.Types.Sorts.Sub
+ Language.Fixpoint.Types.Sorts: instance GHC.Show.Show Language.Fixpoint.Types.Sorts.FTycon
+ Language.Fixpoint.Types.Sorts: instance GHC.Show.Show Language.Fixpoint.Types.Sorts.Sort
+ Language.Fixpoint.Types.Sorts: instance Language.Fixpoint.Types.PrettyPrint.Fixpoint Language.Fixpoint.Types.Sorts.FTycon
+ Language.Fixpoint.Types.Sorts: instance Language.Fixpoint.Types.PrettyPrint.Fixpoint Language.Fixpoint.Types.Sorts.Sort
+ Language.Fixpoint.Types.Sorts: intFTyCon :: FTycon
+ Language.Fixpoint.Types.Sorts: intSort :: Sort
+ Language.Fixpoint.Types.Sorts: isListTC :: FTycon -> Bool
+ Language.Fixpoint.Types.Sorts: listFTyCon :: FTycon
+ Language.Fixpoint.Types.Sorts: mapSort :: Sort -> Sort -> Sort
+ Language.Fixpoint.Types.Sorts: mkFFunc :: Int -> [Sort] -> Sort
+ Language.Fixpoint.Types.Sorts: newtype Sub
+ Language.Fixpoint.Types.Sorts: numFTyCon :: FTycon
+ Language.Fixpoint.Types.Sorts: realFTyCon :: FTycon
+ Language.Fixpoint.Types.Sorts: realSort :: Sort
+ Language.Fixpoint.Types.Sorts: setSort :: Sort -> Sort
+ Language.Fixpoint.Types.Sorts: sortFTycon :: Sort -> Maybe FTycon
+ Language.Fixpoint.Types.Sorts: sortSubst :: HashMap Symbol Sort -> Sort -> Sort
+ Language.Fixpoint.Types.Sorts: strSort :: Sort
+ Language.Fixpoint.Types.Sorts: symbolFTycon :: LocSymbol -> FTycon
+ Language.Fixpoint.Types.Sorts: type TCEmb a = HashMap a FTycon
+ Language.Fixpoint.Types.Spans: Loc :: !SourcePos -> !SourcePos -> a -> Located a
+ Language.Fixpoint.Types.Spans: SS :: !SourcePos -> !SourcePos -> SrcSpan
+ Language.Fixpoint.Types.Spans: [locE] :: Located a -> !SourcePos
+ Language.Fixpoint.Types.Spans: [loc] :: Located a -> !SourcePos
+ Language.Fixpoint.Types.Spans: [sp_start] :: SrcSpan -> !SourcePos
+ Language.Fixpoint.Types.Spans: [sp_stop] :: SrcSpan -> !SourcePos
+ Language.Fixpoint.Types.Spans: [val] :: Located a -> a
+ Language.Fixpoint.Types.Spans: atLoc :: Located a -> b -> Located b
+ Language.Fixpoint.Types.Spans: class Loc a
+ Language.Fixpoint.Types.Spans: data Located a
+ Language.Fixpoint.Types.Spans: data SourcePos :: *
+ Language.Fixpoint.Types.Spans: data SrcSpan
+ Language.Fixpoint.Types.Spans: dummyLoc :: a -> Located a
+ Language.Fixpoint.Types.Spans: dummyPos :: String -> SourcePos
+ Language.Fixpoint.Types.Spans: dummySpan :: SrcSpan
+ Language.Fixpoint.Types.Spans: instance Control.DeepSeq.NFData Text.Parsec.Pos.SourcePos
+ Language.Fixpoint.Types.Spans: instance Control.DeepSeq.NFData a => Control.DeepSeq.NFData (Language.Fixpoint.Types.Spans.Located a)
+ Language.Fixpoint.Types.Spans: instance Data.Binary.Class.Binary Text.Parsec.Pos.SourcePos
+ Language.Fixpoint.Types.Spans: instance Data.Binary.Class.Binary a => Data.Binary.Class.Binary (Language.Fixpoint.Types.Spans.Located a)
+ Language.Fixpoint.Types.Spans: instance Data.Data.Data Language.Fixpoint.Types.Spans.SrcSpan
+ Language.Fixpoint.Types.Spans: instance Data.Data.Data a => Data.Data.Data (Language.Fixpoint.Types.Spans.Located a)
+ Language.Fixpoint.Types.Spans: instance Data.Foldable.Foldable Language.Fixpoint.Types.Spans.Located
+ Language.Fixpoint.Types.Spans: instance Data.Hashable.Class.Hashable Language.Fixpoint.Types.Spans.SrcSpan
+ Language.Fixpoint.Types.Spans: instance Data.Hashable.Class.Hashable Text.Parsec.Pos.SourcePos
+ Language.Fixpoint.Types.Spans: instance Data.Hashable.Class.Hashable a => Data.Hashable.Class.Hashable (Language.Fixpoint.Types.Spans.Located a)
+ Language.Fixpoint.Types.Spans: instance Data.Serialize.Serialize Language.Fixpoint.Types.Spans.SrcSpan
+ Language.Fixpoint.Types.Spans: instance Data.Serialize.Serialize Text.Parsec.Pos.SourcePos
+ Language.Fixpoint.Types.Spans: instance Data.String.IsString a => Data.String.IsString (Language.Fixpoint.Types.Spans.Located a)
+ Language.Fixpoint.Types.Spans: instance Data.Traversable.Traversable Language.Fixpoint.Types.Spans.Located
+ Language.Fixpoint.Types.Spans: instance GHC.Base.Functor Language.Fixpoint.Types.Spans.Located
+ Language.Fixpoint.Types.Spans: instance GHC.Classes.Eq Language.Fixpoint.Types.Spans.SrcSpan
+ Language.Fixpoint.Types.Spans: instance GHC.Classes.Eq a => GHC.Classes.Eq (Language.Fixpoint.Types.Spans.Located a)
+ Language.Fixpoint.Types.Spans: instance GHC.Classes.Ord Language.Fixpoint.Types.Spans.SrcSpan
+ Language.Fixpoint.Types.Spans: instance GHC.Classes.Ord a => GHC.Classes.Ord (Language.Fixpoint.Types.Spans.Located a)
+ Language.Fixpoint.Types.Spans: instance GHC.Generics.Constructor Language.Fixpoint.Types.Spans.C1_0Located
+ Language.Fixpoint.Types.Spans: instance GHC.Generics.Constructor Language.Fixpoint.Types.Spans.C1_0SrcSpan
+ Language.Fixpoint.Types.Spans: instance GHC.Generics.Datatype Language.Fixpoint.Types.Spans.D1Located
+ Language.Fixpoint.Types.Spans: instance GHC.Generics.Datatype Language.Fixpoint.Types.Spans.D1SrcSpan
+ Language.Fixpoint.Types.Spans: instance GHC.Generics.Generic (Language.Fixpoint.Types.Spans.Located a)
+ Language.Fixpoint.Types.Spans: instance GHC.Generics.Generic Language.Fixpoint.Types.Spans.SrcSpan
+ Language.Fixpoint.Types.Spans: instance GHC.Generics.Selector Language.Fixpoint.Types.Spans.S1_0_0Located
+ Language.Fixpoint.Types.Spans: instance GHC.Generics.Selector Language.Fixpoint.Types.Spans.S1_0_0SrcSpan
+ Language.Fixpoint.Types.Spans: instance GHC.Generics.Selector Language.Fixpoint.Types.Spans.S1_0_1Located
+ Language.Fixpoint.Types.Spans: instance GHC.Generics.Selector Language.Fixpoint.Types.Spans.S1_0_1SrcSpan
+ Language.Fixpoint.Types.Spans: instance GHC.Generics.Selector Language.Fixpoint.Types.Spans.S1_0_2Located
+ Language.Fixpoint.Types.Spans: instance GHC.Show.Show Language.Fixpoint.Types.Spans.SrcSpan
+ Language.Fixpoint.Types.Spans: instance GHC.Show.Show a => GHC.Show.Show (Language.Fixpoint.Types.Spans.Located a)
+ Language.Fixpoint.Types.Spans: instance Language.Fixpoint.Types.PrettyPrint.Fixpoint Text.Parsec.Pos.SourcePos
+ Language.Fixpoint.Types.Spans: instance Language.Fixpoint.Types.PrettyPrint.Fixpoint a => Language.Fixpoint.Types.PrettyPrint.Fixpoint (Language.Fixpoint.Types.Spans.Located a)
+ Language.Fixpoint.Types.Spans: instance Language.Fixpoint.Types.PrettyPrint.PPrint Language.Fixpoint.Types.Spans.SrcSpan
+ Language.Fixpoint.Types.Spans: instance Language.Fixpoint.Types.PrettyPrint.PPrint Text.Parsec.Pos.SourcePos
+ Language.Fixpoint.Types.Spans: instance Language.Fixpoint.Types.PrettyPrint.PPrint a => Language.Fixpoint.Types.PrettyPrint.PPrint (Language.Fixpoint.Types.Spans.Located a)
+ Language.Fixpoint.Types.Spans: instance Language.Fixpoint.Types.Spans.Loc (Language.Fixpoint.Types.Spans.Located a)
+ Language.Fixpoint.Types.Spans: locAt :: String -> a -> Located a
+ Language.Fixpoint.Types.Spans: sourcePosElts :: SourcePos -> (SourceName, Line, Column)
+ Language.Fixpoint.Types.Spans: srcSpan :: Loc a => a -> SrcSpan
+ Language.Fixpoint.Types.Substitutions: filterSubst :: (Symbol -> Expr -> Bool) -> Subst -> Subst
+ Language.Fixpoint.Types.Substitutions: instance (Language.Fixpoint.Types.Refinements.Subable a, Language.Fixpoint.Types.Refinements.Subable b) => Language.Fixpoint.Types.Refinements.Subable (a, b)
+ Language.Fixpoint.Types.Substitutions: instance GHC.Base.Monoid Language.Fixpoint.Types.Refinements.Expr
+ Language.Fixpoint.Types.Substitutions: instance GHC.Base.Monoid Language.Fixpoint.Types.Refinements.Reft
+ Language.Fixpoint.Types.Substitutions: instance GHC.Base.Monoid Language.Fixpoint.Types.Refinements.SortedReft
+ Language.Fixpoint.Types.Substitutions: instance GHC.Base.Monoid Language.Fixpoint.Types.Refinements.Subst
+ Language.Fixpoint.Types.Substitutions: instance GHC.Show.Show Language.Fixpoint.Types.Refinements.Reft
+ Language.Fixpoint.Types.Substitutions: instance GHC.Show.Show Language.Fixpoint.Types.Refinements.SortedReft
+ Language.Fixpoint.Types.Substitutions: instance Language.Fixpoint.Types.PrettyPrint.Fixpoint Language.Fixpoint.Types.Refinements.Reft
+ Language.Fixpoint.Types.Substitutions: instance Language.Fixpoint.Types.PrettyPrint.Fixpoint Language.Fixpoint.Types.Refinements.SortedReft
+ Language.Fixpoint.Types.Substitutions: instance Language.Fixpoint.Types.PrettyPrint.PPrint Language.Fixpoint.Types.Refinements.Reft
+ Language.Fixpoint.Types.Substitutions: instance Language.Fixpoint.Types.PrettyPrint.PPrint Language.Fixpoint.Types.Refinements.SortedReft
+ Language.Fixpoint.Types.Substitutions: instance Language.Fixpoint.Types.Refinements.Reftable ()
+ Language.Fixpoint.Types.Substitutions: instance Language.Fixpoint.Types.Refinements.Reftable Language.Fixpoint.Types.Refinements.Reft
+ Language.Fixpoint.Types.Substitutions: instance Language.Fixpoint.Types.Refinements.Reftable Language.Fixpoint.Types.Refinements.SortedReft
+ Language.Fixpoint.Types.Substitutions: instance Language.Fixpoint.Types.Refinements.Subable ()
+ Language.Fixpoint.Types.Substitutions: instance Language.Fixpoint.Types.Refinements.Subable Language.Fixpoint.Types.Names.Symbol
+ Language.Fixpoint.Types.Substitutions: instance Language.Fixpoint.Types.Refinements.Subable Language.Fixpoint.Types.Refinements.Expr
+ Language.Fixpoint.Types.Substitutions: instance Language.Fixpoint.Types.Refinements.Subable Language.Fixpoint.Types.Refinements.Reft
+ Language.Fixpoint.Types.Substitutions: instance Language.Fixpoint.Types.Refinements.Subable Language.Fixpoint.Types.Refinements.SortedReft
+ Language.Fixpoint.Types.Substitutions: instance Language.Fixpoint.Types.Refinements.Subable a => Language.Fixpoint.Types.Refinements.Subable (Data.HashMap.Base.HashMap k a)
+ Language.Fixpoint.Types.Substitutions: instance Language.Fixpoint.Types.Refinements.Subable a => Language.Fixpoint.Types.Refinements.Subable [a]
+ Language.Fixpoint.Types.Substitutions: isEmptySubst :: Subst -> Bool
+ Language.Fixpoint.Types.Substitutions: mkSubst :: [(Symbol, Expr)] -> Subst
+ Language.Fixpoint.Types.Substitutions: subst1Except :: (Subable a) => [Symbol] -> a -> (Symbol, Expr) -> a
+ Language.Fixpoint.Types.Substitutions: substExcept :: Subst -> [Symbol] -> Subst
+ Language.Fixpoint.Types.Substitutions: substfExcept :: (Symbol -> Expr) -> [Symbol] -> Symbol -> Expr
+ Language.Fixpoint.Types.Substitutions: targetSubstSyms :: Subst -> [Symbol]
+ Language.Fixpoint.Types.Utils: kvarDomain :: SInfo a -> KVar -> [Symbol]
+ Language.Fixpoint.Types.Utils: reftFreeVars :: Reft -> HashSet Symbol
+ Language.Fixpoint.Types.Visitor: Visitor :: (ctx -> Expr -> ctx) -> (ctx -> Expr -> Expr) -> (ctx -> Expr -> acc) -> Visitor acc ctx
+ Language.Fixpoint.Types.Visitor: [accExpr] :: Visitor acc ctx -> ctx -> Expr -> acc
+ Language.Fixpoint.Types.Visitor: [ctxExpr] :: Visitor acc ctx -> ctx -> Expr -> ctx
+ Language.Fixpoint.Types.Visitor: [txExpr] :: Visitor acc ctx -> ctx -> Expr -> Expr
+ Language.Fixpoint.Types.Visitor: class SymConsts a
+ Language.Fixpoint.Types.Visitor: data Visitor acc ctx
+ Language.Fixpoint.Types.Visitor: defaultVisitor :: Monoid acc => Visitor acc ctx
+ Language.Fixpoint.Types.Visitor: envKVars :: (TaggedC c a) => BindEnv -> c a -> [KVar]
+ Language.Fixpoint.Types.Visitor: envKVarsN :: (TaggedC c a) => BindEnv -> c a -> [(KVar, Int)]
+ Language.Fixpoint.Types.Visitor: fold :: (Visitable t, Monoid a) => Visitor a ctx -> ctx -> a -> t -> a
+ Language.Fixpoint.Types.Visitor: foldSort :: (a -> Sort -> a) -> a -> Sort -> a
+ Language.Fixpoint.Types.Visitor: instance GHC.Base.Monoid Language.Fixpoint.Types.Visitor.MInt
+ Language.Fixpoint.Types.Visitor: instance Language.Fixpoint.Types.Visitor.SymConsts (Language.Fixpoint.Types.Constraints.FInfo a)
+ Language.Fixpoint.Types.Visitor: instance Language.Fixpoint.Types.Visitor.SymConsts (Language.Fixpoint.Types.Constraints.SubC a)
+ Language.Fixpoint.Types.Visitor: instance Language.Fixpoint.Types.Visitor.SymConsts Language.Fixpoint.Types.Environments.BindEnv
+ Language.Fixpoint.Types.Visitor: instance Language.Fixpoint.Types.Visitor.SymConsts Language.Fixpoint.Types.Refinements.Expr
+ Language.Fixpoint.Types.Visitor: instance Language.Fixpoint.Types.Visitor.SymConsts Language.Fixpoint.Types.Refinements.Reft
+ Language.Fixpoint.Types.Visitor: instance Language.Fixpoint.Types.Visitor.SymConsts Language.Fixpoint.Types.Refinements.SortedReft
+ Language.Fixpoint.Types.Visitor: instance Language.Fixpoint.Types.Visitor.Visitable (Language.Fixpoint.Types.Constraints.SInfo a)
+ Language.Fixpoint.Types.Visitor: instance Language.Fixpoint.Types.Visitor.Visitable (Language.Fixpoint.Types.Constraints.SimpC a)
+ Language.Fixpoint.Types.Visitor: instance Language.Fixpoint.Types.Visitor.Visitable (Language.Fixpoint.Types.Names.Symbol, Language.Fixpoint.Types.Refinements.SortedReft)
+ Language.Fixpoint.Types.Visitor: instance Language.Fixpoint.Types.Visitor.Visitable Language.Fixpoint.Types.Environments.BindEnv
+ Language.Fixpoint.Types.Visitor: instance Language.Fixpoint.Types.Visitor.Visitable Language.Fixpoint.Types.Refinements.Expr
+ Language.Fixpoint.Types.Visitor: instance Language.Fixpoint.Types.Visitor.Visitable Language.Fixpoint.Types.Refinements.Reft
+ Language.Fixpoint.Types.Visitor: instance Language.Fixpoint.Types.Visitor.Visitable Language.Fixpoint.Types.Refinements.SortedReft
+ Language.Fixpoint.Types.Visitor: isConcC :: (TaggedC c a) => c a -> Bool
+ Language.Fixpoint.Types.Visitor: isKvarC :: (TaggedC c a) => c a -> Bool
+ Language.Fixpoint.Types.Visitor: kvars :: Visitable t => t -> [KVar]
+ Language.Fixpoint.Types.Visitor: mapKVarSubsts :: Visitable t => (KVar -> Subst -> Subst) -> t -> t
+ Language.Fixpoint.Types.Visitor: mapKVars :: Visitable t => (KVar -> Maybe Expr) -> t -> t
+ Language.Fixpoint.Types.Visitor: mapKVars' :: Visitable t => ((KVar, Subst) -> Maybe Expr) -> t -> t
+ Language.Fixpoint.Types.Visitor: mapSort :: (Sort -> Sort) -> Sort -> Sort
+ Language.Fixpoint.Types.Visitor: rhsKVars :: (TaggedC c a) => c a -> [KVar]
+ Language.Fixpoint.Types.Visitor: size :: Visitable t => t -> Integer
+ Language.Fixpoint.Types.Visitor: symConsts :: SymConsts a => a -> [SymConst]
+ Language.Fixpoint.Types.Visitor: trans :: (Visitable t, Monoid a) => Visitor a ctx -> ctx -> a -> t -> t
+ Language.Fixpoint.Utils.Files: Annot :: Ext
+ Language.Fixpoint.Utils.Files: Auto :: Int -> Ext
+ Language.Fixpoint.Utils.Files: BinFq :: Ext
+ Language.Fixpoint.Utils.Files: Cache :: Ext
+ Language.Fixpoint.Utils.Files: Cgi :: Ext
+ Language.Fixpoint.Utils.Files: Cst :: Ext
+ Language.Fixpoint.Utils.Files: Dat :: Ext
+ Language.Fixpoint.Utils.Files: Dot :: Ext
+ Language.Fixpoint.Utils.Files: Fq :: Ext
+ Language.Fixpoint.Utils.Files: Hquals :: Ext
+ Language.Fixpoint.Utils.Files: Hs :: Ext
+ Language.Fixpoint.Utils.Files: HsBoot :: Ext
+ Language.Fixpoint.Utils.Files: Html :: Ext
+ Language.Fixpoint.Utils.Files: Js :: Ext
+ Language.Fixpoint.Utils.Files: Json :: Ext
+ Language.Fixpoint.Utils.Files: LHs :: Ext
+ Language.Fixpoint.Utils.Files: Min :: Ext
+ Language.Fixpoint.Utils.Files: Mkdn :: Ext
+ Language.Fixpoint.Utils.Files: Out :: Ext
+ Language.Fixpoint.Utils.Files: PAss :: Ext
+ Language.Fixpoint.Utils.Files: Part :: Int -> Ext
+ Language.Fixpoint.Utils.Files: Pred :: Ext
+ Language.Fixpoint.Utils.Files: Result :: Ext
+ Language.Fixpoint.Utils.Files: Saved :: Ext
+ Language.Fixpoint.Utils.Files: Smt2 :: Ext
+ Language.Fixpoint.Utils.Files: Spec :: Ext
+ Language.Fixpoint.Utils.Files: Ts :: Ext
+ Language.Fixpoint.Utils.Files: Vim :: Ext
+ Language.Fixpoint.Utils.Files: copyFiles :: [FilePath] -> FilePath -> IO ()
+ Language.Fixpoint.Utils.Files: data Ext
+ Language.Fixpoint.Utils.Files: extFileName :: Ext -> FilePath -> FilePath
+ Language.Fixpoint.Utils.Files: extFileNameR :: Ext -> FilePath -> FilePath
+ Language.Fixpoint.Utils.Files: extModuleName :: String -> Ext -> FilePath
+ Language.Fixpoint.Utils.Files: getFileInDirs :: FilePath -> [FilePath] -> IO (Maybe FilePath)
+ Language.Fixpoint.Utils.Files: getFixpointPath :: IO FilePath
+ Language.Fixpoint.Utils.Files: getZ3LibPath :: IO FilePath
+ Language.Fixpoint.Utils.Files: instance GHC.Classes.Eq Language.Fixpoint.Utils.Files.Ext
+ Language.Fixpoint.Utils.Files: instance GHC.Classes.Ord Language.Fixpoint.Utils.Files.Ext
+ Language.Fixpoint.Utils.Files: instance GHC.Show.Show Language.Fixpoint.Utils.Files.Ext
+ Language.Fixpoint.Utils.Files: isBinary :: FilePath -> Bool
+ Language.Fixpoint.Utils.Files: isExtFile :: Ext -> FilePath -> Bool
+ Language.Fixpoint.Utils.Files: tempDirectory :: FilePath -> FilePath
+ Language.Fixpoint.Utils.Files: withExt :: FilePath -> Ext -> FilePath
+ Language.Fixpoint.Utils.Progress: progressClose :: IO ()
+ Language.Fixpoint.Utils.Progress: progressInit :: Int -> IO ()
+ Language.Fixpoint.Utils.Progress: progressTick :: IO ()
+ Language.Fixpoint.Utils.Progress: withProgress :: Int -> IO a -> IO a
+ Language.Fixpoint.Utils.Statistics: instance Control.DeepSeq.NFData Language.Fixpoint.Utils.Statistics.Stats
+ Language.Fixpoint.Utils.Statistics: instance GHC.Generics.Constructor Language.Fixpoint.Utils.Statistics.C1_0Stats
+ Language.Fixpoint.Utils.Statistics: instance GHC.Generics.Datatype Language.Fixpoint.Utils.Statistics.D1Stats
+ Language.Fixpoint.Utils.Statistics: instance GHC.Generics.Generic Language.Fixpoint.Utils.Statistics.Stats
+ Language.Fixpoint.Utils.Statistics: instance GHC.Generics.Selector Language.Fixpoint.Utils.Statistics.S1_0_0Stats
+ Language.Fixpoint.Utils.Statistics: instance GHC.Generics.Selector Language.Fixpoint.Utils.Statistics.S1_0_1Stats
+ Language.Fixpoint.Utils.Statistics: instance GHC.Generics.Selector Language.Fixpoint.Utils.Statistics.S1_0_2Stats
+ Language.Fixpoint.Utils.Statistics: instance GHC.Generics.Selector Language.Fixpoint.Utils.Statistics.S1_0_3Stats
+ Language.Fixpoint.Utils.Statistics: instance GHC.Generics.Selector Language.Fixpoint.Utils.Statistics.S1_0_4Stats
+ Language.Fixpoint.Utils.Statistics: instance GHC.Generics.Selector Language.Fixpoint.Utils.Statistics.S1_0_5Stats
+ Language.Fixpoint.Utils.Statistics: instance GHC.Show.Show Language.Fixpoint.Utils.Statistics.Stats
+ Language.Fixpoint.Utils.Statistics: instance Language.Fixpoint.Types.PrettyPrint.PPrint Language.Fixpoint.Utils.Statistics.Stats
+ Language.Fixpoint.Utils.Statistics: statistics :: Config -> FInfo a -> IO (Result (Integer, a))
- Language.Fixpoint.Misc: errorstar :: [Char] -> c
+ Language.Fixpoint.Misc: errorstar :: (?callStack :: CallStack) => String -> a
- Language.Fixpoint.Misc: group :: (Hashable k, Eq k) => [(k, a)] -> HashMap k [a]
+ Language.Fixpoint.Misc: group :: (Eq k, Hashable k) => [(k, v)] -> HashMap k [v]
- Language.Fixpoint.Misc: groupBase :: (Hashable k, Eq k) => HashMap k [a] -> [(k, a)] -> HashMap k [a]
+ Language.Fixpoint.Misc: groupBase :: (Eq k, Foldable t, Hashable k) => HashMap k [a] -> t (k, a) -> HashMap k [a]
- Language.Fixpoint.Misc: groupList :: (Hashable k, Eq k) => [(k, a)] -> [(k, [a])]
+ Language.Fixpoint.Misc: groupList :: (Eq k, Hashable k) => [(k, v)] -> [(k, [v])]
- Language.Fixpoint.Misc: groupMap :: (Hashable k, Eq k) => (a -> k) -> [a] -> HashMap k [a]
+ Language.Fixpoint.Misc: groupMap :: (Eq k, Foldable t, Hashable k) => (a -> k) -> t a -> HashMap k [a]
- Language.Fixpoint.Misc: inserts :: (Hashable k, Eq k) => k -> a -> HashMap k [a] -> HashMap k [a]
+ Language.Fixpoint.Misc: inserts :: (Eq k, Hashable k) => k -> a -> HashMap k [a] -> HashMap k [a]
- Language.Fixpoint.Misc: mfromJust :: String -> Maybe a -> a
+ Language.Fixpoint.Misc: mfromJust :: (?callStack :: CallStack) => String -> Maybe a -> a
- Language.Fixpoint.Misc: mlookup :: (Eq k, Show k, Hashable k) => HashMap k v -> k -> v
+ Language.Fixpoint.Misc: mlookup :: (?callStack :: CallStack, Eq k, Show k, Hashable k) => HashMap k v -> k -> v
- Language.Fixpoint.Misc: safeHead :: String -> ListNE a -> a
+ Language.Fixpoint.Misc: safeHead :: (?callStack :: CallStack) => String -> ListNE a -> a
- Language.Fixpoint.Misc: safeInit :: String -> ListNE a -> [a]
+ Language.Fixpoint.Misc: safeInit :: (?callStack :: CallStack) => String -> ListNE a -> [a]
- Language.Fixpoint.Misc: safeLast :: String -> ListNE a -> a
+ Language.Fixpoint.Misc: safeLast :: (?callStack :: CallStack) => String -> ListNE a -> a
- Language.Fixpoint.Misc: safeLookup :: (Eq k, Hashable k) => String -> k -> HashMap k v -> v
+ Language.Fixpoint.Misc: safeLookup :: (?callStack :: CallStack, Eq k, Hashable k) => String -> k -> HashMap k v -> v
- Language.Fixpoint.Misc: safeUncons :: String -> ListNE a -> (a, [a])
+ Language.Fixpoint.Misc: safeUncons :: (?callStack :: CallStack) => String -> ListNE a -> (a, [a])
- Language.Fixpoint.Misc: safeUnsnoc :: String -> ListNE a -> ([a], a)
+ Language.Fixpoint.Misc: safeUnsnoc :: (?callStack :: CallStack) => String -> ListNE a -> ([a], a)
- Language.Fixpoint.Misc: safeZip :: [Char] -> [a] -> [b] -> [(a, b)]
+ Language.Fixpoint.Misc: safeZip :: (?callStack :: CallStack) => String -> [a] -> [b] -> [(a, b)]
- Language.Fixpoint.Misc: safeZipWith :: [Char] -> (a -> b -> c) -> [a] -> [b] -> [c]
+ Language.Fixpoint.Misc: safeZipWith :: (?callStack :: CallStack) => String -> (a -> b -> c) -> [a] -> [b] -> [c]
- Language.Fixpoint.Misc: sortNub :: Ord a => [a] -> [a]
+ Language.Fixpoint.Misc: sortNub :: (Ord a) => [a] -> [a]
- Language.Fixpoint.Parse: condIdP :: [Char] -> (String -> Bool) -> Parser Symbol
+ Language.Fixpoint.Parse: condIdP :: HashSet Char -> (String -> Bool) -> Parser Symbol
- Language.Fixpoint.Parse: mkQual :: Symbol -> [(Symbol, Sort)] -> Pred -> SourcePos -> Qualifier
+ Language.Fixpoint.Parse: mkQual :: Symbol -> [(Symbol, Sort)] -> Expr -> SourcePos -> Qualifier
- Language.Fixpoint.Parse: predP :: Parser Pred
+ Language.Fixpoint.Parse: predP :: Parser Expr
- Language.Fixpoint.Parse: qualifierP :: ParsecT String Integer Identity Sort -> ParsecT String Integer Identity Qualifier
+ Language.Fixpoint.Parse: qualifierP :: Parser Sort -> ParsecT String Integer Identity Qualifier
- Language.Fixpoint.Parse: refBindP :: Parser Symbol -> Parser Refa -> Parser (Reft -> a) -> Parser a
+ Language.Fixpoint.Parse: refBindP :: Parser Symbol -> Parser Expr -> Parser (Reft -> a) -> Parser a
- Language.Fixpoint.Parse: refDefP :: Symbol -> Parser Refa -> Parser (Reft -> a) -> Parser a
+ Language.Fixpoint.Parse: refDefP :: Symbol -> Parser Expr -> Parser (Reft -> a) -> Parser a
- Language.Fixpoint.Parse: refaP :: Parser Refa
+ Language.Fixpoint.Parse: refaP :: Parser Expr
- Language.Fixpoint.Partition: partition :: Fixpoint a => Config -> FInfo a -> IO (Result a)
+ Language.Fixpoint.Partition: partition :: (Fixpoint a) => Config -> FInfo a -> IO (Result (Integer, a))
- Language.Fixpoint.Partition: partition' :: FInfo a -> (KVGraph, [FInfo a])
+ Language.Fixpoint.Partition: partition' :: Maybe MCInfo -> FInfo a -> (KVGraph, [FInfo a])
- Language.Fixpoint.Smt.Interface: Assert :: (Maybe Int) -> Pred -> Command
+ Language.Fixpoint.Smt.Interface: Assert :: (Maybe Int) -> Expr -> Command
- Language.Fixpoint.Smt.Interface: Ctx :: ProcessHandle -> Handle -> Handle -> Maybe Handle -> Bool -> Context
+ Language.Fixpoint.Smt.Interface: Ctx :: ProcessHandle -> Handle -> Handle -> Maybe Handle -> Bool -> SMTEnv -> Context
- Language.Fixpoint.Smt.Interface: class SMTLIB2 a
+ Language.Fixpoint.Smt.Interface: class SMTLIB2 a where defunc = return runSmt2 env a = smt2 $ evalState (defunc a) (SMTSt 0 env)
- Language.Fixpoint.Smt.Interface: makeContext :: SMTSolver -> FilePath -> IO Context
+ Language.Fixpoint.Smt.Interface: makeContext :: Bool -> SMTSolver -> FilePath -> IO Context
- Language.Fixpoint.Smt.Interface: makeContextNoLog :: SMTSolver -> IO Context
+ Language.Fixpoint.Smt.Interface: makeContextNoLog :: Bool -> SMTSolver -> IO Context
- Language.Fixpoint.Smt.Interface: smtAssert :: Context -> Pred -> IO ()
+ Language.Fixpoint.Smt.Interface: smtAssert :: Context -> Expr -> IO ()
- Language.Fixpoint.Smt.Serialize: mkNe :: (SMTLIB2 a1, SMTLIB2 a) => a -> a1 -> Text
+ Language.Fixpoint.Smt.Serialize: mkNe :: (SMTLIB2 a, SMTLIB2 a1) => a -> a1 -> Text
- Language.Fixpoint.Smt.Serialize: mkRel :: (SMTLIB2 a1, SMTLIB2 a) => Brel -> a -> a1 -> Text
+ Language.Fixpoint.Smt.Serialize: mkRel :: (SMTLIB2 a, SMTLIB2 a1) => Brel -> a -> a1 -> Text
- Language.Fixpoint.Smt.Serialize: smt2App :: LocSymbol -> [Expr] -> Text
+ Language.Fixpoint.Smt.Serialize: smt2App :: Expr -> Text
- Language.Fixpoint.Smt.Types: Assert :: (Maybe Int) -> Pred -> Command
+ Language.Fixpoint.Smt.Types: Assert :: (Maybe Int) -> Expr -> Command
- Language.Fixpoint.Smt.Types: Ctx :: ProcessHandle -> Handle -> Handle -> Maybe Handle -> Bool -> Context
+ Language.Fixpoint.Smt.Types: Ctx :: ProcessHandle -> Handle -> Handle -> Maybe Handle -> Bool -> SMTEnv -> Context
- Language.Fixpoint.Smt.Types: class SMTLIB2 a
+ Language.Fixpoint.Smt.Types: class SMTLIB2 a where defunc = return runSmt2 env a = smt2 $ evalState (defunc a) (SMTSt 0 env)
- Language.Fixpoint.Solver.Monad: filterValid :: Pred -> Cand a -> SolveM [a]
+ Language.Fixpoint.Solver.Monad: filterValid :: Expr -> Cand a -> SolveM [a]
- Language.Fixpoint.Solver.Monad: runSolverM :: Config -> FInfo b -> SolveM a -> IO a
+ Language.Fixpoint.Solver.Monad: runSolverM :: Config -> GInfo c b -> Int -> SolveM a -> IO a
- Language.Fixpoint.Solver.Monad: tickIter :: SolveM Int
+ Language.Fixpoint.Solver.Monad: tickIter :: Bool -> SolveM Int
- Language.Fixpoint.Solver.Solution: init :: Config -> FInfo a -> Solution
+ Language.Fixpoint.Solver.Solution: init :: SInfo a -> Solution
- Language.Fixpoint.Solver.Solve: solve :: Config -> FInfo a -> IO (Result a)
+ Language.Fixpoint.Solver.Solve: solve :: (NFData a, Fixpoint a) => Config -> Solution -> SInfo a -> IO (Result (Integer, a))
- Language.Fixpoint.Solver.Validate: symbolSorts :: FInfo a -> Either Error [(Symbol, Sort)]
+ Language.Fixpoint.Solver.Validate: symbolSorts :: GInfo c a -> ValidateM [(Symbol, Sort)]
- Language.Fixpoint.Solver.Worklist: init :: Config -> FInfo a -> Worklist a
+ Language.Fixpoint.Solver.Worklist: init :: SInfo a -> Worklist a
- Language.Fixpoint.Solver.Worklist: pop :: Worklist a -> Maybe (SubC a, Worklist a)
+ Language.Fixpoint.Solver.Worklist: pop :: Worklist a -> Maybe (SimpC a, Worklist a, Bool, Int)
- Language.Fixpoint.Solver.Worklist: push :: SubC a -> Worklist a -> Worklist a
+ Language.Fixpoint.Solver.Worklist: push :: SimpC a -> Worklist a -> Worklist a
Files
- Fixpoint.hs +0/−12
- Setup.hs +1/−54
- bin/Fixpoint.hs +11/−0
- configure +0/−45
- external/fixpoint/Makefile +0/−72
- external/fixpoint/Simplification.ml +0/−197
- external/fixpoint/Simplification.mli +0/−5
- external/fixpoint/ast.ml +0/−1882
- external/fixpoint/ast.mli +0/−255
- external/fixpoint/cindex.ml +0/−427
- external/fixpoint/cindex.mli +0/−54
- external/fixpoint/counterexample.ml +0/−323
- external/fixpoint/counterexample.mli +0/−51
- external/fixpoint/fix.ml +0/−36
- external/fixpoint/fixConfig.ml +0/−162
- external/fixpoint/fixConfig.mli +0/−54
- external/fixpoint/fixConstraint.ml +0/−559
- external/fixpoint/fixConstraint.mli +0/−142
- external/fixpoint/fixLex.mll +0/−177
- external/fixpoint/fixParse.mly +0/−435
- external/fixpoint/fixSimplify.ml +0/−455
- external/fixpoint/fixSimplify.mli +0/−28
- external/fixpoint/fixpoint.ml +0/−148
- external/fixpoint/fixpoint.native-i386-linux binary
- external/fixpoint/fixpoint.native-i686-w64-mingw32 too large to diff
- external/fixpoint/fixpoint.native-x86_64-darwin too large to diff
- external/fixpoint/fixpoint.native-x86_64-linux too large to diff
- external/fixpoint/fixtop.ml +0/−123
- external/fixpoint/hornLex.mll +0/−99
- external/fixpoint/hornParse.mly +0/−147
- external/fixpoint/hornToInterproc.ml +0/−154
- external/fixpoint/kvgraph.ml +0/−211
- external/fixpoint/kvgraph.mli +0/−37
- external/fixpoint/predAbs.ml +0/−1048
- external/fixpoint/predAbs.mli +0/−16
- external/fixpoint/prepass.ml +0/−238
- external/fixpoint/prepass.mli +0/−31
- external/fixpoint/proverArch.ml +0/−221
- external/fixpoint/qualifier.ml +0/−365
- external/fixpoint/qualifier.mli +0/−53
- external/fixpoint/smtLIB2.ml +0/−513
- external/fixpoint/smtZ3.mem.ml +0/−180
- external/fixpoint/smtZ3.ml +0/−93
- external/fixpoint/smtZ3.nomem.ml +0/−93
- external/fixpoint/solve.ml +0/−271
- external/fixpoint/solve.mli +0/−34
- external/fixpoint/solverArch.ml +0/−44
- external/fixpoint/theories.ml +0/−347
- external/fixpoint/theories.mli +0/−27
- external/fixpoint/timeout.ml +0/−30
- external/fixpoint/timeout.mli +0/−4
- external/fixpoint/toARMC.ml +0/−333
- external/fixpoint/toDot.ml +0/−173
- external/fixpoint/toHC.ml +0/−613
- external/fixpoint/toImp.ml +0/−380
- external/fixpoint/toImp.mli +0/−26
- external/fixpoint/toLatex.ml +0/−149
- external/fixpoint/toQARMC.ml +0/−721
- external/fixpoint/toRawHorn.ml +0/−200
- external/fixpoint/toSmtLib.ml +0/−504
- external/fixpoint/toSmtLib.mli +0/−86
- external/fixpoint/toplevel.ml +0/−48
- external/fixpoint/toplevel.mli +0/−25
- external/fixpoint/tpGen.ml +0/−574
- external/fixpoint/tpNull.ml +0/−39
- external/misc/bNstats.ml +0/−118
- external/misc/bNstats.mli +0/−48
- external/misc/constants.ml +0/−441
- external/misc/errorline.ml +0/−31
- external/misc/fcommon.ml +0/−148
- external/misc/fcommon.mli +0/−24
- external/misc/fixMisc.ml +0/−1365
- external/misc/heaps.ml +0/−223
- external/misc/heaps.mli +0/−98
- external/misc/tagtime.ml +0/−125
- external/misc/tagtime.mli +0/−37
- external/misc/timer.ml +0/−59
- external/misc/timer.mli +0/−28
- external/misc/timetest.ml +0/−29
- external/ocamlgraph/META.in +0/−5
- external/ocamlgraph/Makefile.in +0/−386
- external/ocamlgraph/configure +0/−3485
- external/ocamlgraph/configure.in +0/−193
- external/ocamlgraph/lib/bitv.ml +0/−610
- external/ocamlgraph/lib/bitv.mli +0/−195
- external/ocamlgraph/lib/heap.ml +0/−236
- external/ocamlgraph/lib/heap.mli +0/−99
- external/ocamlgraph/lib/unionfind.ml +0/−117
- external/ocamlgraph/lib/unionfind.mli +0/−49
- external/ocamlgraph/src/blocks.ml +0/−650
- external/ocamlgraph/src/builder.ml +0/−49
- external/ocamlgraph/src/builder.mli +0/−47
- external/ocamlgraph/src/classic.ml +0/−85
- external/ocamlgraph/src/classic.mli +0/−54
- external/ocamlgraph/src/cliquetree.ml +0/−343
- external/ocamlgraph/src/cliquetree.mli +0/−90
- external/ocamlgraph/src/components.ml +0/−90
- external/ocamlgraph/src/components.mli +0/−53
- external/ocamlgraph/src/delaunay.ml +0/−344
- external/ocamlgraph/src/delaunay.mli +0/−76
- external/ocamlgraph/src/dot.ml +0/−78
- external/ocamlgraph/src/dot.mli +0/−34
- external/ocamlgraph/src/dot_ast.mli +0/−57
- external/ocamlgraph/src/dot_lexer.ml +0/−386
- external/ocamlgraph/src/dot_lexer.mll +0/−122
- external/ocamlgraph/src/dot_parser.ml +0/−551
- external/ocamlgraph/src/dot_parser.mli +0/−21
- external/ocamlgraph/src/dot_parser.mly +0/−168
- external/ocamlgraph/src/flow.ml +0/−329
- external/ocamlgraph/src/flow.mli +0/−107
- external/ocamlgraph/src/gcoloring.ml +0/−123
- external/ocamlgraph/src/gcoloring.mli +0/−79
- external/ocamlgraph/src/gmap.ml +0/−68
- external/ocamlgraph/src/gmap.mli +0/−60
- external/ocamlgraph/src/gml.ml +0/−670
- external/ocamlgraph/src/gml.mli +0/−76
- external/ocamlgraph/src/gml.mll +0/−202
- external/ocamlgraph/src/gpath.ml +0/−132
- external/ocamlgraph/src/gpath.mli +0/−96
- external/ocamlgraph/src/graphviz.ml +0/−779
- external/ocamlgraph/src/graphviz.mli +0/−469
- external/ocamlgraph/src/imperative.ml +0/−618
- external/ocamlgraph/src/imperative.mli +0/−87
- external/ocamlgraph/src/kruskal.ml +0/−74
- external/ocamlgraph/src/kruskal.mli +0/−65
- external/ocamlgraph/src/mcs_m.ml +0/−203
- external/ocamlgraph/src/mcs_m.mli +0/−53
- external/ocamlgraph/src/md.ml +0/−163
- external/ocamlgraph/src/md.mli +0/−57
- external/ocamlgraph/src/minsep.ml +0/−131
- external/ocamlgraph/src/minsep.mli +0/−70
- external/ocamlgraph/src/oper.ml +0/−171
- external/ocamlgraph/src/oper.mli +0/−124
- external/ocamlgraph/src/pack.ml +0/−180
- external/ocamlgraph/src/pack.mli +0/−28
- external/ocamlgraph/src/persistent.ml +0/−297
- external/ocamlgraph/src/persistent.mli +0/−50
- external/ocamlgraph/src/rand.ml +0/−207
- external/ocamlgraph/src/rand.mli +0/−111
- external/ocamlgraph/src/sig.mli +0/−309
- external/ocamlgraph/src/sig_pack.mli +0/−376
- external/ocamlgraph/src/strat.ml +0/−233
- external/ocamlgraph/src/strat.mli +0/−103
- external/ocamlgraph/src/topological.ml +0/−57
- external/ocamlgraph/src/topological.mli +0/−48
- external/ocamlgraph/src/traverse.ml +0/−284
- external/ocamlgraph/src/traverse.mli +0/−127
- external/ocamlgraph/src/util.ml +0/−67
- external/ocamlgraph/src/util.mli +0/−47
- external/ocamlgraph/src/version.ml +0/−2
- external/z3/include/z3.h +0/−70
- external/z3/include/z3_api.h +0/−4824
- external/z3/lib/libz3-a-32b too large to diff
- external/z3/lib/libz3-a-64b too large to diff
- external/z3/lib/libz3-so-32b too large to diff
- external/z3/lib/libz3-so-64b too large to diff
- external/z3/ocaml/build-lib.sh +0/−8
- external/z3/ocaml/z3.ml +0/−1499
- external/z3/ocaml/z3_stubs.c +0/−7761
- external/z3/ocaml/z3_theory_stubs.c +0/−337
- liquid-fixpoint.cabal +48/−125
- src/Language/Fixpoint/Bitvector.hs +0/−70
- src/Language/Fixpoint/Config.hs +0/−147
- src/Language/Fixpoint/Errors.hs +0/−135
- src/Language/Fixpoint/Files.hs +0/−178
- src/Language/Fixpoint/Interface.hs +0/−192
- src/Language/Fixpoint/Minimize.hs +74/−0
- src/Language/Fixpoint/Misc.hs +113/−286
- src/Language/Fixpoint/Names.hs +0/−333
- src/Language/Fixpoint/Parse.hs +147/−104
- src/Language/Fixpoint/Partition.hs +413/−97
- src/Language/Fixpoint/PrettyPrint.hs +0/−204
- src/Language/Fixpoint/Smt/Bitvector.hs +69/−0
- src/Language/Fixpoint/Smt/Interface.hs +124/−58
- src/Language/Fixpoint/Smt/Serialize.hs +396/−61
- src/Language/Fixpoint/Smt/Theories.hs +165/−51
- src/Language/Fixpoint/Smt/Types.hs +43/−21
- src/Language/Fixpoint/Solver.hs +250/−0
- src/Language/Fixpoint/Solver/Deps.hs +0/−96
- src/Language/Fixpoint/Solver/Eliminate.hs +105/−87
- src/Language/Fixpoint/Solver/Graph.hs +162/−0
- src/Language/Fixpoint/Solver/Monad.hs +135/−32
- src/Language/Fixpoint/Solver/Solution.hs +197/−148
- src/Language/Fixpoint/Solver/Solve.hs +193/−67
- src/Language/Fixpoint/Solver/TrivialSort.hs +176/−0
- src/Language/Fixpoint/Solver/Types.hs +39/−0
- src/Language/Fixpoint/Solver/Uniqify.hs +0/−117
- src/Language/Fixpoint/Solver/UniqifyBinds.hs +132/−0
- src/Language/Fixpoint/Solver/UniqifyKVars.hs +104/−0
- src/Language/Fixpoint/Solver/Validate.hs +215/−70
- src/Language/Fixpoint/Solver/Worklist.hs +198/−68
- src/Language/Fixpoint/Sort.hs +0/−425
- src/Language/Fixpoint/SortCheck.hs +750/−0
- src/Language/Fixpoint/Statistics.hs +0/−81
- src/Language/Fixpoint/Types.hs +30/−1802
- src/Language/Fixpoint/Types/Config.hs +194/−0
- src/Language/Fixpoint/Types/Constraints.hs +577/−0
- src/Language/Fixpoint/Types/Environments.hs +195/−0
- src/Language/Fixpoint/Types/Errors.hs +184/−0
- src/Language/Fixpoint/Types/Graphs.hs +70/−0
- src/Language/Fixpoint/Types/Names.hs +563/−0
- src/Language/Fixpoint/Types/PrettyPrint.hs +176/−0
- src/Language/Fixpoint/Types/Refinements.hs +712/−0
- src/Language/Fixpoint/Types/Sorts.hs +266/−0
- src/Language/Fixpoint/Types/Spans.hs +185/−0
- src/Language/Fixpoint/Types/Substitutions.hs +263/−0
- src/Language/Fixpoint/Types/Utils.hs +46/−0
- src/Language/Fixpoint/Types/Visitor.hs +282/−0
- src/Language/Fixpoint/Utils/Files.hs +199/−0
- src/Language/Fixpoint/Utils/Progress.hs +55/−0
- src/Language/Fixpoint/Utils/Statistics.hs +75/−0
- src/Language/Fixpoint/Visitor.hs +0/−200
- tests/neg/conj-rhs.fq +6/−0
- tests/neg/float-literal.fq +0/−1
- tests/neg/float.fq +11/−0
- tests/neg/literals.fq +10/−0
- tests/neg/num00.fq +28/−0
- tests/neg/poly0.fq +14/−0
- tests/neg/poly1.fq +16/−0
- tests/neg/poly2.fq +14/−0
- tests/neg/test00.fq +3/−6
- tests/neg/test00a.fq +3/−6
- tests/neg/test1.fq +3/−6
- tests/neg/test2.fq +5/−10
- tests/neg/test3.fq +2/−4
- tests/pos/bad-subst00.fq +26/−0
- tests/pos/bad-subst01.fq +31/−0
- tests/pos/conj-rhs.fq +6/−0
- tests/pos/elim00.fq +1493/−0
- tests/pos/float.fq +11/−0
- tests/pos/func00.fq +9/−0
- tests/pos/len00-rename.fq +24/−0
- tests/pos/len00.fq +24/−0
- tests/pos/literals.fq +10/−0
- tests/pos/multiple-func-sorts.fq +5/−0
- tests/pos/num00.fq +22/−0
- tests/pos/overwrite-names.fq +0/−1
- tests/pos/poly0.fq +14/−0
- tests/pos/poly1.fq +16/−0
- tests/pos/poly2.fq +14/−0
- tests/pos/qualif-inst.fq +17/−0
- tests/pos/sets.fq +7/−0
- tests/pos/test00-par.fq +37/−0
- tests/pos/test00.fq +12/−17
- tests/pos/test00a.fq +3/−8
- tests/pos/test1.fq +3/−6
- tests/pos/test2.fq +6/−11
- tests/pos/test3.fq +2/−4
- tests/pos/test4.fq +19/−0
- tests/pos/wl00.fq +50/−0
- tests/pos/wl01.fq +39/−0
- tests/pos/wrong-arity.fq +16/−0
- tests/test.hs +8/−3
− Fixpoint.hs
@@ -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
Setup.hs view
@@ -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
+ bin/Fixpoint.hs view
@@ -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+
− configure
@@ -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 <<EOF-OCAMLGRAPHHOME=$ROOTHOME/external/ocamlgraph-OCAMLLIB=$OCAMLLIB-Z3HOME=$Z3HOME-EOF--cat - > build.sh <<EOF-#!`which bash`--set -e--if [[ '$Z3MEM' = 'True' ]]-then- if [[ \`uname -m\` = 'x86_64' ]]- then- echo Found 64-bit kernel. Moving z3 into place.- cp external/z3/lib/libz3-so-64b external/z3/lib/libz3.so- cp external/z3/lib/libz3-a-64b external/z3/lib/libz3.a- else- echo Assuming 32-bit kernel. Moving z3 into place.- cp external/z3/lib/libz3-so-32b external/z3/lib/libz3.so- cp external/z3/lib/libz3-a-32b external/z3/lib/libz3.a- fi- cd external/z3/ocaml; ./build-lib.sh; cd ../../../-fi--cd external/ocamlgraph/; ./configure; make; cd ../../-cd external/fixpoint; make; cd ../../-EOF--chmod a+x build.sh
− external/fixpoint/Makefile
@@ -1,72 +0,0 @@-include config.make--DIRS=-I misc-OFLAGS=$(DIRS) $(IFLAGS) $(LFLAGS) $(CFLAGS)--OCAMLC=ocamlc-OCAMLOPT=ocamlopt-OCAMLBUILD=ocamlbuild -ocamlc $(OCAMLC) -ocamlopt $(OCAMLOPT)--LIBS_=-libs unix,str,graph,nums-IFLAGS_=-lflags -I,$(OCAMLGRAPHHOME)-LFLAGS_=-lflags -cclib,-L$(OCAMLLIB)--CFLAGS_=-cflags -dtypes,-annot \- -cflags -I,$(OCAMLGRAPHHOME) \- -cflags -thread--SMTZ3=smtZ3.ml--ifdef Z3HOME- LIBS=$(LIBS_),z3- IFLAGS=$(IFLAGS_) \- -lflags -I,$(Z3HOME)/lib \- -lflags -I,$(Z3HOME)/ocaml- LFLAGS=$(LFLAGS_) \- -lflags -cc,g++ \- -lflags -cclib,-lstdc++ \- -lflags -cclib,-lcamlidl \- -lflags -cclib,-L$(Z3HOME)/lib \- -lflags -cclib,-lz3 \- -lflags -cclib,-lz3stubs \- -lflags -cclib,-fopenmp\- -lflags -cclib,-lrt- CFLAGS=$(CFLAGS_) \- -cflags -I,$(Z3HOME)/ocaml- SMTZ3SRC=smtZ3.mem.ml-else- LIBS=$(LIBS_)- IFLAGS=$(IFLAGS_)- LFLAGS=$(LFLAGS_)- CFLAGS=$(CFLAGS_)- SMTZ3SRC=smtZ3.nomem.ml-endif--ifdef CCOPT- CFLAGS+= -cflags -ccopt,-m32-endif--all: smtz3- ln -sf ../misc- $(OCAMLBUILD) -r $(LIBS) $(OFLAGS) -tags thread fixpoint.native- $(OCAMLBUILD) -r $(OFLAGS) fix.cmxa- rm -f fixpoint.native- cp _build/fixpoint.native .--smtz3: $(SMTZ3SRC)- cp $(SMTZ3SRC) $(SMTZ3)--clean:- rm -rf *.byte *.native _build _log--fixtop:- ocamlbuild -r $(LIBS) $(OFLAGS) fixtop.native--horn:- ocamlbuild -r $(LIBS) $(OFLAGS) hornToInterproc.native--MLITARGET=toSmtLib.ml-mli:- ocamlc -I _build/ -I _build/misc/ -I $(Z3HOME)/lib -I $(Z3HOME)/ocaml -i $(MLITARGET)--
− external/fixpoint/Simplification.ml
@@ -1,197 +0,0 @@-module C = FixConstraint-module P = Ast.Predicate-module E = Ast.Expression-module Sy = Ast.Symbol-module Su = Ast.Subst--module Misc = FixMisc open Misc.Ops--let rec defs_of_pred (edefs, pdefs) ((p, _) as pred) = - match p with- | Ast.Atom ((Ast.Var v, _), Ast.Eq, e) when not(P.is_tauto pred) -> 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--
− external/fixpoint/Simplification.mli
@@ -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-
− external/fixpoint/ast.ml
@@ -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 -> "<fun>"-- 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))- }}} *)
− external/fixpoint/ast.mli
@@ -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-
− external/fixpoint/cindex.ml
@@ -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
− external/fixpoint/cindex.mli
@@ -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-
− external/fixpoint/counterexample.ml
@@ -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)
− external/fixpoint/counterexample.mli
@@ -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
− external/fixpoint/fix.ml
@@ -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---
− external/fixpoint/fixConfig.ml
@@ -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)-
− external/fixpoint/fixConfig.mli
@@ -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
− external/fixpoint/fixConstraint.ml
@@ -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))
− external/fixpoint/fixConstraint.mli
@@ -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
− external/fixpoint/fixLex.mll
@@ -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 }- | "<fun>" { 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 }-
− external/fixpoint/fixParse.mly
@@ -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 <string> 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 <string> Id-%token <int> Num-%token <float> Real-%token <string> 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 <FixConfig.deft list> defs-%type <FixConfig.deft> def-%type <FixConfig.solbind list> sols-%type <So.t list> sorts, sortsne -%type <So.t> sort-%type <(Sy.t * So.t) list> binds, bindsne -%type <A.pred list> preds, predsne-%type <A.pred> pred-%type <A.expr list> exprs, exprsne-%type <A.expr> expr-%type <C.t> cstr-%type <C.envt> env-%type <FixConstraint.reft> reft-%type <C.refa list> refas, refasne-%type <C.refa> refa-%type <Su.t> 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 }-
− external/fixpoint/fixSimplify.ml
@@ -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)
− external/fixpoint/fixSimplify.mli
@@ -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 *)
− external/fixpoint/fixpoint.ml
@@ -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 <options> [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 ()
− external/fixpoint/fixpoint.native-i386-linux
binary file changed (1699479 → absent bytes)
− external/fixpoint/fixpoint.native-i686-w64-mingw32
file too large to diff
− external/fixpoint/fixpoint.native-x86_64-darwin
file too large to diff
− external/fixpoint/fixpoint.native-x86_64-linux
file too large to diff
− external/fixpoint/fixtop.ml
@@ -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 <options> [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 ()
− external/fixpoint/hornLex.mll
@@ -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 }-
− external/fixpoint/hornParse.mly
@@ -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 <string> Var-%token <string> Id-%token <int> 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 <A.pred list> preds, predsne-%type <A.pred> pred-%type <A.expr list> exprs, exprsne-%type <A.expr> expr-%type <A.brel> brel -%type <A.bop> bop --%type <H.pr> pr-%type <H.gd> guard-%type <H.gd list> guards, guardsne-%type <Ast.Horn.t> hc-%type <Ast.Horn.t list> 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 } -
− external/fixpoint/hornToInterproc.ml
@@ -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
− external/fixpoint/kvgraph.ml
@@ -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
− external/fixpoint/kvgraph.mli
@@ -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
− external/fixpoint/predAbs.ml
@@ -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
− external/fixpoint/predAbs.mli
@@ -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
− external/fixpoint/prepass.ml
@@ -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 -
− external/fixpoint/prepass.mli
@@ -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
− external/fixpoint/proverArch.ml
@@ -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--
− external/fixpoint/qualifier.ml
@@ -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)
− external/fixpoint/qualifier.mli
@@ -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--
− external/fixpoint/smtLIB2.ml
@@ -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
− external/fixpoint/smtZ3.mem.ml
@@ -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
− external/fixpoint/smtZ3.ml
@@ -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
− external/fixpoint/smtZ3.nomem.ml
@@ -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
− external/fixpoint/solve.ml
@@ -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
− external/fixpoint/solve.mli
@@ -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
− external/fixpoint/solverArch.ml
@@ -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
− external/fixpoint/theories.ml
@@ -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
− external/fixpoint/theories.mli
@@ -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) -
− external/fixpoint/timeout.ml
@@ -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-
− external/fixpoint/timeout.mli
@@ -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
− external/fixpoint/toARMC.ml
@@ -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--*)
− external/fixpoint/toDot.ml
@@ -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
− external/fixpoint/toHC.ml
@@ -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"
− external/fixpoint/toImp.ml
@@ -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
− external/fixpoint/toImp.mli
@@ -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--
− external/fixpoint/toLatex.ml
@@ -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: -"
− external/fixpoint/toQARMC.ml
@@ -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
− external/fixpoint/toRawHorn.ml
@@ -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
− external/fixpoint/toSmtLib.ml
@@ -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-
− external/fixpoint/toSmtLib.mli
@@ -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-
− external/fixpoint/toplevel.ml
@@ -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)
− external/fixpoint/toplevel.mli
@@ -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)-
− external/fixpoint/tpGen.ml
@@ -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
− external/fixpoint/tpNull.ml
@@ -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-
− external/misc/bNstats.ml
@@ -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 ()----------------
− external/misc/bNstats.mli
@@ -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-
− external/misc/constants.ml
@@ -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), - " <level> 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- *)
− external/misc/errorline.ml
@@ -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)-
− external/misc/fcommon.ml
@@ -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)-*)-
− external/misc/fcommon.mli
@@ -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
− external/misc/fixMisc.ml
@@ -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)- | _ -> []
− external/misc/heaps.ml
@@ -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
− external/misc/heaps.mli
@@ -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
− external/misc/tagtime.ml
@@ -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
− external/misc/tagtime.mli
@@ -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
− external/misc/timer.ml
@@ -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) --
− external/misc/timer.mli
@@ -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 -
− external/misc/timetest.ml
@@ -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"
− external/ocamlgraph/META.in
@@ -1,5 +0,0 @@-version = "VERSION"-description = "Generic Graph Library"-requires=""-archive(byte) = "CMA"-archive(native) = "CMXA"
− external/ocamlgraph/Makefile.in
@@ -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)</#def>" > 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
− external/ocamlgraph/configure
@@ -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 </dev/null-exec 6>&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 2>/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-' <conf$$subs.awk | sed '-/^[^""]/{- N- s/\n//-}-' >>$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
− external/ocamlgraph/configure.in
@@ -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
− external/ocamlgraph/lib/bitv.ml
@@ -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--
− external/ocamlgraph/lib/bitv.mli
@@ -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
− external/ocamlgraph/lib/heap.ml
@@ -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
− external/ocamlgraph/lib/heap.mli
@@ -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
− external/ocamlgraph/lib/unionfind.ml
@@ -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--***)
− external/ocamlgraph/lib/unionfind.mli
@@ -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--
− external/ocamlgraph/src/blocks.ml
@@ -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
− external/ocamlgraph/src/builder.ml
@@ -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
− external/ocamlgraph/src/builder.mli
@@ -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 *)
− external/ocamlgraph/src/classic.ml
@@ -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))
− external/ocamlgraph/src/classic.mli
@@ -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 *)
− external/ocamlgraph/src/cliquetree.ml
@@ -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
− external/ocamlgraph/src/cliquetree.mli
@@ -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
− external/ocamlgraph/src/components.ml
@@ -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
− external/ocamlgraph/src/components.mli
@@ -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
− external/ocamlgraph/src/delaunay.ml
@@ -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)-
− external/ocamlgraph/src/delaunay.mli
@@ -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
− external/ocamlgraph/src/dot.ml
@@ -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
− external/ocamlgraph/src/dot.mli
@@ -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
− external/ocamlgraph/src/dot_ast.mli
@@ -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 }
− external/ocamlgraph/src/dot_lexer.ml
@@ -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--;;-
− external/ocamlgraph/src/dot_lexer.mll
@@ -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" }
− external/ocamlgraph/src/dot_parser.ml
@@ -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)
− external/ocamlgraph/src/dot_parser.mli
@@ -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
− external/ocamlgraph/src/dot_parser.mly
@@ -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 <Dot_ast.id> ID-%token COLON COMMA EQUAL SEMICOLON EDGEOP-%token STRICT GRAPH DIGRAPH LBRA RBRA LSQ RSQ NODE EDGE SUBGRAPH EOF--%type <Dot_ast.file> 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) }-;
− external/ocamlgraph/src/flow.ml
@@ -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
− external/ocamlgraph/src/flow.mli
@@ -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
− external/ocamlgraph/src/gcoloring.ml
@@ -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
− external/ocamlgraph/src/gcoloring.mli
@@ -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
− external/ocamlgraph/src/gmap.ml
@@ -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)
− external/ocamlgraph/src/gmap.mli
@@ -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
− external/ocamlgraph/src/gml.ml
@@ -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"
− external/ocamlgraph/src/gml.mli
@@ -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--
− external/ocamlgraph/src/gml.mll
@@ -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--}-
− external/ocamlgraph/src/gpath.ml
@@ -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
− external/ocamlgraph/src/gpath.mli
@@ -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
− external/ocamlgraph/src/graphviz.ml
@@ -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 " [@[<hov>%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 "@[<v 2>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 "@[<v>%s G {@ @[<v 2> %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 *- <number of nodes>] when ranking nodes. *)- | `Nslimit1 of int- (** If set of [f], bounds network simplex iterations by [f *- <number of nodes>] 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)
− external/ocamlgraph/src/graphviz.mli
@@ -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 *- <number of nodes>] when ranking nodes. *)- | `Nslimit1 of int- (** If set of [f], bounds network simplex iterations by [f *- <number of nodes>] 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
− external/ocamlgraph/src/imperative.ml
@@ -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-
− external/ocamlgraph/src/imperative.mli
@@ -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-
− external/ocamlgraph/src/kruskal.ml
@@ -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))-
− external/ocamlgraph/src/kruskal.mli
@@ -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
− external/ocamlgraph/src/mcs_m.ml
@@ -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 <mattam\@mattam.org>- @author Pierre-Loic Garoche <ploc\@garoche.net>- - $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
− external/ocamlgraph/src/mcs_m.mli
@@ -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
− external/ocamlgraph/src/md.ml
@@ -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
− external/ocamlgraph/src/md.mli
@@ -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
− external/ocamlgraph/src/minsep.ml
@@ -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
− external/ocamlgraph/src/minsep.mli
@@ -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-
− external/ocamlgraph/src/oper.ml
@@ -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
− external/ocamlgraph/src/oper.mli
@@ -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
− external/ocamlgraph/src/pack.ml
@@ -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))--
− external/ocamlgraph/src/pack.mli
@@ -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 *)--
− external/ocamlgraph/src/persistent.ml
@@ -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
− external/ocamlgraph/src/persistent.mli
@@ -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-
− external/ocamlgraph/src/rand.ml
@@ -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
− external/ocamlgraph/src/rand.mli
@@ -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
− external/ocamlgraph/src/sig.mli
@@ -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
− external/ocamlgraph/src/sig_pack.mli
@@ -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
− external/ocamlgraph/src/strat.ml
@@ -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
− external/ocamlgraph/src/strat.mli
@@ -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
− external/ocamlgraph/src/topological.ml
@@ -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
− external/ocamlgraph/src/topological.mli
@@ -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--
− external/ocamlgraph/src/traverse.ml
@@ -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-
− external/ocamlgraph/src/traverse.mli
@@ -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-
− external/ocamlgraph/src/util.ml
@@ -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-
− external/ocamlgraph/src/util.mli
@@ -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-
− external/ocamlgraph/src/version.ml
@@ -1,2 +0,0 @@-let version = "0.99b"-let date = "Wed Aug 12 18:13:31 UTC 2015"
− external/z3/include/z3.h
@@ -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 <stdio.h>--#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-
− external/z3/include/z3_api.h
@@ -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 <tt>const char *</tt>.-*/-typedef const char * Z3_string;-typedef Z3_string * Z3_string_ptr;-#else-/**- \conly \brief Z3 string type. It is just an alias for <tt>[string] const char *</tt>.-*/-#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: <tt>[domain -> range]</tt>.- 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 <tt>l = r</tt>.- - 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 <tt>distinct(args[0], ..., args[num_args-1])</tt>.- \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, <tt>Forall 0 <= i < j < num_args. not args[i] = args[j]</tt>.- - 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 <tt>not(a)</tt>.- - 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: <tt>ite(t1, t2,- t3)</tt>.-- 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 <tt>t1 iff t2</tt>.-- 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 <tt>t1 implies t2</tt>.-- 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 <tt>t1 xor t2</tt>.-- 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 <tt>args[0] and ... and args[num_args-1]</tt>.- \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 <tt>args[0] or ... or args[num_args-1]</tt>.- \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 <tt>args[0] + ... + args[num_args-1]</tt>.- \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 <tt>args[0] * ... * args[num_args-1]</tt>.- \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 <tt>args[0] - ... - args[num_args - 1]</tt>.- \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 <tt>-arg</tt>.- \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 <tt>arg1 div arg2</tt>.- \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 <tt>arg1 mod arg2</tt>.- \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 <tt>arg1 rem arg2</tt>.- \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 <tt> mk_int2real(k) <= t1 < mk_int2real(k)+1</tt>.- - 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 <tt>t1/t2</tt> if \c t2 is- different from zero. If <tt>t2</tt> 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 <tt>t1/t2</tt> if \c t2 is different from zero, and <tt>t1*t2 >= 0</tt>.-- - The \c ceiling of <tt>t1/t2</tt> if \c t2 is different from zero, and <tt>t1*t2 < 0</tt>.- - If <tt>t2</tt> 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 <tt>t1 - (t1 /u t2) * t2</tt>, where <tt>/u</tt> represents unsigned division.- - If <tt>t2</tt> 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 <tt>t1 - (t1 /s t2) * t2</tt>, where <tt>/s</tt> represents signed division.- The most significant bit (sign) of the result is equal to the most significant bit of \c t1.-- If <tt>t2</tt> 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 <tt>t2</tt> 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 <tt>n1+n2</tt>, 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 <tt>n =- high - low + 1</tt>.-- 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 <tt>m+i</tt>, 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 <tt>m+i</tt>, 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 <tt>i</tt>.- - 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 <tt>2^x</tt> 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 <tt>2^x</tt> 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 <tt>[0..2^N-1]</tt>, 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 <tt>[domain -> range]</tt>, 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 <tt>[domain -> range]</tt>, \c i must have sort \c domain,- \c v must have sort range. The sort of the result is <tt>[domain -> range]</tt>.- - \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 <tt>[domain_i -> range_i]</tt>.- The function declaration \c f must have type <tt> range_1 .. range_n -> range</tt>.- \c v must have sort range. The sort of the result is <tt>[domain_i -> range]</tt>.- - \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 <tt>[num]* / [num]*</tt>.- \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 <tt>from[i]</tt> in \c a with <tt>to[i]</tt>, 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 <tt>from[i]</tt> must be equal to sort of <tt>to[i]</tt>.- */- 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 <tt>to[i]</tt>.- */- 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 <tt>f(args[0],...,args[num_args - 1]) = val</tt>.-- \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 <tt>f(args[0],...,args[num_args - 1]) = val</tt>.-- \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 <tt>f(args[0],...,args[num_args - 1]) = val</tt>.-- \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 <tt>MODEL_PARTIAL=true</tt> 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 <tt>f(t)</tt>, 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 <tt>f(t, d, n, args, r)</tt>, 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 <tt>d(args[0], ..., args[n-1])</tt>.-- If <tt>f(t, d, n, args, r)</tt> 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 <tt>s_1 = s_2</tt>, 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 <tt>f(t, s_1, s_2, r)</tt>, 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 <tt>s_1 = s_2</tt>.- - If <tt>f(t, s_1, s_2, r)</tt> 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 <tt>distinct(s_1, ..., s_n)</tt>, 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 <tt>f(t, n, args, r)</tt>, 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 <tt>distinct(s_1, ..., s_n)</tt>.- - If <tt>f(t, n, args, r)</tt> 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 <tt>f(t, n)</tt>, where- - \c t is the given theory- - - \c n is a theory application, that is, an expression of the form <tt>g(...)</tt> 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 <tt>f(t, n)</tt>, 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 <tt>f(t)</tt>, 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 <tt>f(t)</tt>, 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 <tt>f(t)</tt>, 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 <tt>f(t)</tt>, 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 <tt>f(t)</tt>, 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 <tt>f(t)</tt>, 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 <tt>s_1 = s_2</tt>- is found by the logical context.-- The callback has the form <tt>f(t, s_1, s_2)</tt>, 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 <tt>s_1 != s_2</tt>- is found by the logical context.-- The callback has the form <tt>f(t, s_1, s_2)</tt>, 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 <tt>f(t, p, v)</tt>, 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 <tt>f(t, n)</tt>, 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--/*@}*/
− external/z3/lib/libz3-a-32b
file too large to diff
− external/z3/lib/libz3-a-64b
file too large to diff
− external/z3/lib/libz3-so-32b
file too large to diff
− external/z3/lib/libz3-so-64b
file too large to diff
− external/z3/ocaml/build-lib.sh
@@ -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
− external/z3/ocaml/z3.ml
@@ -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 - - - - -
− external/z3/ocaml/z3_stubs.c
@@ -1,7761 +0,0 @@-/* File generated from z3.idl */ - -#include <stddef.h> -#include <string.h> -#include <caml/mlvalues.h> -#include <caml/memory.h> -#include <caml/alloc.h> -#include <caml/fail.h> -#include <caml/callback.h> -#ifdef Custom_tag -#include <caml/custom.h> -#include <caml/bigarray.h> -#endif -#include <caml/camlidlruntime.h> - - -#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; -} -
− external/z3/ocaml/z3_theory_stubs.c
@@ -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 <stddef.h> -#include <string.h> -#include <caml/mlvalues.h> -#include <caml/memory.h> -#include <caml/alloc.h> -#include <caml/fail.h> -#include <caml/callback.h> -#ifdef Custom_tag -#include <caml/custom.h> -#include <caml/bigarray.h> -#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);
liquid-fixpoint.cabal view
@@ -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 (<http://z3.codeplex.com>) or CVC4 (<http://cvc4.cs.nyu.edu>) 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
− src/Language/Fixpoint/Bitvector.hs
@@ -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
− src/Language/Fixpoint/Config.hs
@@ -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"
− src/Language/Fixpoint/Errors.hs
@@ -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
− src/Language/Fixpoint/Files.hs
@@ -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
− src/Language/Fixpoint/Interface.hs
@@ -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 }
+ src/Language/Fixpoint/Minimize.hs view
@@ -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 []
src/Language/Fixpoint/Misc.hs view
@@ -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+-}
− src/Language/Fixpoint/Names.hs
@@ -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
src/Language/Fixpoint/Parse.hs view
@@ -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
src/Language/Fixpoint/Partition.hs view
@@ -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
− src/Language/Fixpoint/PrettyPrint.hs
@@ -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
+ src/Language/Fixpoint/Smt/Bitvector.hs view
@@ -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
src/Language/Fixpoint/Smt/Interface.hs view
@@ -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)" ]-
src/Language/Fixpoint/Smt/Serialize.hs view
@@ -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)
src/Language/Fixpoint/Smt/Theories.hs view
@@ -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
src/Language/Fixpoint/Smt/Types.hs view
@@ -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)
+ src/Language/Fixpoint/Solver.hs view
@@ -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
− src/Language/Fixpoint/Solver/Deps.hs
@@ -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------------------------------------------------------------------
src/Language/Fixpoint/Solver/Eliminate.hs view
@@ -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))+-}
+ src/Language/Fixpoint/Solver/Graph.hs view
@@ -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
src/Language/Fixpoint/Solver/Monad.hs view
@@ -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
src/Language/Fixpoint/Solver/Solution.hs view
@@ -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)
src/Language/Fixpoint/Solver/Solve.hs view
@@ -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+-}
+ src/Language/Fixpoint/Solver/TrivialSort.hs view
@@ -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
+ src/Language/Fixpoint/Solver/Types.hs view
@@ -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
− src/Language/Fixpoint/Solver/Uniqify.hs
@@ -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))-
+ src/Language/Fixpoint/Solver/UniqifyBinds.hs view
@@ -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+--------------------------------------------------------------
+ src/Language/Fixpoint/Solver/UniqifyKVars.hs view
@@ -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
src/Language/Fixpoint/Solver/Validate.hs view
@@ -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
src/Language/Fixpoint/Solver/Worklist.hs view
@@ -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
− src/Language/Fixpoint/Sort.hs
@@ -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)-
+ src/Language/Fixpoint/SortCheck.hs view
@@ -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)
− src/Language/Fixpoint/Statistics.hs
@@ -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)
src/Language/Fixpoint/Types.hs view
@@ -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
+ src/Language/Fixpoint/Types/Config.hs view
@@ -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]
+ src/Language/Fixpoint/Types/Constraints.hs view
@@ -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)
+ src/Language/Fixpoint/Types/Environments.hs view
@@ -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
+ src/Language/Fixpoint/Types/Errors.hs view
@@ -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 ]
+ src/Language/Fixpoint/Types/Graphs.hs view
@@ -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
+ src/Language/Fixpoint/Types/Names.hs view
@@ -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++-}
+ src/Language/Fixpoint/Types/PrettyPrint.hs view
@@ -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
+ src/Language/Fixpoint/Types/Refinements.hs view
@@ -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
+ src/Language/Fixpoint/Types/Sorts.hs view
@@ -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
+ src/Language/Fixpoint/Types/Spans.hs view
@@ -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
+ src/Language/Fixpoint/Types/Substitutions.hs view
@@ -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 _ = []
+ src/Language/Fixpoint/Types/Utils.hs view
@@ -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
+ src/Language/Fixpoint/Types/Visitor.hs view
@@ -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)++-}
+ src/Language/Fixpoint/Utils/Files.hs view
@@ -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
+ src/Language/Fixpoint/Utils/Progress.hs view
@@ -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 ()
+ src/Language/Fixpoint/Utils/Statistics.hs view
@@ -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)
− src/Language/Fixpoint/Visitor.hs
@@ -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
+ tests/neg/conj-rhs.fq view
@@ -0,0 +1,6 @@+constraint:+ env []+ lhs {v:int | true }+ rhs {v:int | (0 = 1) && (1 = 0) }+ id 1+ tag [1]
tests/neg/float-literal.fq view
@@ -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]
+ tests/neg/float.fq view
@@ -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]
+ tests/neg/literals.fq view
@@ -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]
+ tests/neg/num00.fq view
@@ -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}+
+ tests/neg/poly0.fq view
@@ -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]
+ tests/neg/poly1.fq view
@@ -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]++
+ tests/neg/poly2.fq view
@@ -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]
tests/neg/test00.fq view
@@ -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 [ ]
tests/neg/test00a.fq view
@@ -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 [ ]
tests/neg/test1.fq view
@@ -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 [ ]
tests/neg/test2.fq view
@@ -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 [ ]
tests/neg/test3.fq view
@@ -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]
+ tests/pos/bad-subst00.fq view
@@ -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}
+ tests/pos/bad-subst01.fq view
@@ -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}
+ tests/pos/conj-rhs.fq view
@@ -0,0 +1,6 @@+constraint:+ env []+ lhs {v:int | true }+ rhs {v:int | (0 < 1) && (1 > 0) }+ id 1+ tag [1]
+ tests/pos/elim00.fq view
@@ -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 : ()
+ tests/pos/float.fq view
@@ -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]
+ tests/pos/func00.fq view
@@ -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 []+
+ tests/pos/len00-rename.fq view
@@ -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] }
+ tests/pos/len00.fq view
@@ -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] }
+ tests/pos/literals.fq view
@@ -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]
+ tests/pos/multiple-func-sorts.fq view
@@ -0,0 +1,5 @@+// adapted from LH test vector2.hs++constant foo : (func(1, [@(0); @(0)]))++bind 6 foo : {VV : func(1, [@(0); @(0)]) | []}
+ tests/pos/num00.fq view
@@ -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}+
tests/pos/overwrite-names.fq view
@@ -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]
+ tests/pos/poly0.fq view
@@ -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]
+ tests/pos/poly1.fq view
@@ -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]++
+ tests/pos/poly2.fq view
@@ -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]
+ tests/pos/qualif-inst.fq view
@@ -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]}
+ tests/pos/sets.fq view
@@ -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]
+ tests/pos/test00-par.fq view
@@ -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 []+
tests/pos/test00.fq view
@@ -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}
tests/pos/test00a.fq view
@@ -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}-
tests/pos/test1.fq view
@@ -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 [ ]
tests/pos/test2.fq view
@@ -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 [ ]
tests/pos/test3.fq view
@@ -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]
+ tests/pos/test4.fq view
@@ -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]}
+ tests/pos/wl00.fq view
@@ -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]}
+ tests/pos/wl01.fq view
@@ -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]}
+ tests/pos/wrong-arity.fq view
@@ -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]
tests/test.hs view
@@ -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