├── src ├── Guard │ ├── dune-project │ └── dune ├── ADT.v ├── Examples │ ├── ignoreFail.ml │ ├── QueryStructure │ │ ├── GithubSample │ │ │ └── package.json │ │ └── bench_bookstore.sh │ ├── printCode.ml │ ├── FacadeTest.v │ ├── bedrock_driver.s │ ├── Ics │ │ ├── client.ml │ │ └── WaterTankExtract.v │ ├── DnsServer │ │ └── TODO.txt │ ├── bedrock_main.c │ ├── CacheADT │ │ └── CacheSpec.v │ └── Tutorial │ │ └── NotInList_template.v ├── Narcissus │ ├── OCamlExtraction │ │ ├── OCamlNativeInt.ml │ │ ├── ListVector.ml │ │ └── StackVector.ml │ ├── Examples │ │ ├── NetworkStack │ │ │ ├── .merlin │ │ │ ├── test.ml │ │ │ ├── bench.sh │ │ │ └── benchmarks │ │ │ │ └── microbenchmarks.sh │ │ └── Guard │ │ │ ├── IPTablesGuard.v │ │ │ └── Guard.v │ ├── Stores │ │ ├── EmptyStore.v │ │ └── Cache.v │ ├── Common │ │ ├── Sig.v │ │ ├── Notations.v │ │ └── WordFacts.v │ ├── Formats.v │ ├── Formats │ │ ├── Base │ │ │ ├── LaxTerminalFormat.v │ │ │ └── StrictTerminalFormat.v │ │ └── Bool.v │ └── Automation │ │ └── CacheEncoders.v ├── Fiat4Monitors │ ├── paintball │ │ ├── radl__msg4.msg │ │ └── radl__msg5.msg │ ├── RADL_Topics.v │ └── MonitorRepInv.v ├── Common │ ├── Tactics │ │ ├── HintDbExtra.v.v810 │ │ ├── HintDbExtra.v.v811 │ │ ├── HintDbExtra.v.v812 │ │ ├── HintDbExtra.v.v813 │ │ ├── HintDbExtra.v.v814 │ │ ├── HintDbExtra.v.v815 │ │ ├── HintDbExtra.v.v84 │ │ ├── HintDbExtra.v.v85 │ │ ├── HintDbExtra.v.v86 │ │ ├── HintDbExtra.v.v87 │ │ ├── HintDbExtra.v.v88 │ │ ├── HintDbExtra.v.v89 │ │ ├── TransparentAbstract.v.v810 │ │ ├── TransparentAbstract.v.v811 │ │ ├── TransparentAbstract.v.v812 │ │ ├── TransparentAbstract.v.v813 │ │ ├── TransparentAbstract.v.v814 │ │ ├── TransparentAbstract.v.v815 │ │ ├── TransparentAbstract.v.v84 │ │ ├── TransparentAbstract.v.v85 │ │ ├── TransparentAbstract.v.v86 │ │ ├── TransparentAbstract.v.v87 │ │ ├── TransparentAbstract.v.v88 │ │ ├── TransparentAbstract.v.v89 │ │ ├── hint_db_extra_plugin.mllib │ │ ├── HintDbExtra.v.v816 │ │ ├── HintDbExtra.v.v817 │ │ ├── HintDbExtra.v.v818 │ │ ├── HintDbExtra.v.v819 │ │ ├── HintDbExtra.v.v820 │ │ ├── HintDbExtra.v.v90 │ │ ├── HintDbExtra.v.v91 │ │ ├── HintDbExtra.v.v92 │ │ ├── TransparentAbstract.v.v816 │ │ ├── TransparentAbstract.v.v817 │ │ ├── TransparentAbstract.v.v818 │ │ ├── TransparentAbstract.v.v819 │ │ ├── TransparentAbstract.v.v820 │ │ ├── TransparentAbstract.v.v90 │ │ ├── TransparentAbstract.v.v91 │ │ ├── TransparentAbstract.v.v92 │ │ ├── transparent_abstract_plugin.mllib │ │ ├── GetGoal.v │ │ ├── IsClosed.v │ │ ├── FreeIn.v │ │ ├── Head.v │ │ ├── hint_db_extra_plugin.ml4.v84 │ │ ├── FoldIsTrue.v │ │ ├── DestructSig.v │ │ ├── Combinators.v │ │ ├── hint_db_extra_plugin.ml4.v85 │ │ ├── hint_db_extra_plugin.ml4.v86 │ │ ├── hint_db_extra_plugin.ml4.v87 │ │ ├── hint_db_extra_plugin.ml4.v88 │ │ ├── hint_db_extra_plugin.ml4.v89 │ │ ├── hint_db_extra_plugin.mlg.v90 │ │ ├── hint_db_extra_plugin.mlg.v91 │ │ ├── hint_db_extra_plugin.mlg.v92 │ │ ├── hint_db_extra_plugin.mlg.v819 │ │ ├── hint_db_extra_plugin.mlg.v820 │ │ ├── hint_db_extra_plugin.mlg.v813 │ │ ├── hint_db_extra_plugin.mlg.v814 │ │ ├── hint_db_extra_plugin.mlg.v815 │ │ ├── PrintContext.v │ │ ├── hint_db_extra_plugin.mlg.v810 │ │ ├── hint_db_extra_plugin.mlg.v811 │ │ ├── hint_db_extra_plugin.mlg.v812 │ │ ├── hint_db_extra_plugin.mlg.v816 │ │ ├── hint_db_extra_plugin.mlg.v817 │ │ ├── hint_db_extra_plugin.mlg.v818 │ │ ├── transparent_abstract_plugin.ml4.v84 │ │ ├── transparent_abstract_plugin.ml4.v87 │ │ ├── transparent_abstract_plugin.ml4.v88 │ │ ├── transparent_abstract_plugin.ml4.v89 │ │ ├── transparent_abstract_plugin.mlg.v810 │ │ ├── transparent_abstract_plugin.mlg.v811 │ │ ├── transparent_abstract_plugin.mlg.v812 │ │ ├── transparent_abstract_plugin.mlg.v813 │ │ ├── transparent_abstract_plugin.mlg.v814 │ │ ├── transparent_abstract_plugin.mlg.v815 │ │ ├── transparent_abstract_plugin.mlg.v816 │ │ ├── transparent_abstract_plugin.mlg.v817 │ │ ├── transparent_abstract_plugin.mlg.v818 │ │ ├── transparent_abstract_plugin.mlg.v819 │ │ ├── transparent_abstract_plugin.mlg.v820 │ │ ├── transparent_abstract_plugin.mlg.v90 │ │ ├── transparent_abstract_plugin.mlg.v91 │ │ ├── transparent_abstract_plugin.mlg.v92 │ │ ├── transparent_abstract_plugin.ml4.v86 │ │ ├── transparent_abstract_tactics.ml.v815 │ │ ├── transparent_abstract_tactics.ml.v816 │ │ ├── transparent_abstract_tactics.ml.v817 │ │ ├── transparent_abstract_tactics.ml.v818 │ │ ├── transparent_abstract_tactics.ml.v819 │ │ ├── transparent_abstract_tactics.ml.v820 │ │ ├── transparent_abstract_tactics.ml.v90 │ │ ├── transparent_abstract_tactics.ml.v91 │ │ ├── transparent_abstract_tactics.ml.v92 │ │ ├── transparent_abstract_tactics.ml.v810 │ │ ├── transparent_abstract_tactics.ml.v811 │ │ ├── transparent_abstract_tactics.ml.v812 │ │ ├── transparent_abstract_tactics.ml.v813 │ │ ├── transparent_abstract_tactics.ml.v814 │ │ ├── SplitInContext.v │ │ ├── DestructHead.v │ │ ├── SpecializeBy.v │ │ ├── transparent_abstract_plugin.ml4.v85 │ │ ├── transparent_abstract_tactics.ml.v89 │ │ ├── hint_db_extra_tactics.ml.v815 │ │ ├── hint_db_extra_tactics.ml.v816 │ │ ├── hint_db_extra_tactics.ml.v817 │ │ ├── hint_db_extra_tactics.ml.v818 │ │ ├── hint_db_extra_tactics.ml.v813 │ │ ├── hint_db_extra_tactics.ml.v814 │ │ ├── hint_db_extra_tactics.ml.v810 │ │ └── hint_db_extra_tactics.ml.v811 │ ├── Ensembles.v │ ├── Ensembles │ │ ├── Notations.v │ │ ├── Equivalence.v │ │ ├── Cardinal.v │ │ ├── Morphisms.v │ │ └── Tactics.v │ ├── ReservedNotations.v │ ├── StringOperations.v │ ├── EnumType.v │ └── VectorFacts.v ├── Parsers │ ├── BooleanRecognizerMin.v │ ├── AbstractInterpretation │ │ └── NonTerminalMapWf.v │ ├── ContextFreeGrammar │ │ ├── Fix │ │ │ ├── Interface.v │ │ │ ├── Inject.v │ │ │ └── PreInterface.v │ │ └── Valid.v │ ├── Refinement │ │ ├── ExtractSharpenedABStar.v │ │ ├── DisjointLemmasEarlyDeclarations.v │ │ ├── Testing │ │ │ └── Makefile │ │ ├── DisjointRulesCommon.v │ │ ├── SharpenedExpressionParen.v │ │ ├── Makefile │ │ ├── SharpenedABStarParseTree.v │ │ └── SharpenedExpressionPlusParenParseTree.v │ ├── Grammars │ │ ├── ExpressionParen.v │ │ ├── ExpressionNumPlus.v │ │ ├── JSComment.v │ │ ├── FlatComments.v │ │ ├── StringLiteral.v │ │ ├── ABStar.v │ │ ├── Trivial.v │ │ └── ExpressionNumPlusParen.v │ ├── StringLike.v │ ├── Specification.v │ ├── Reflective │ │ ├── ParserPartialUnfold.v │ │ ├── ParserSyntax.v │ │ ├── ParserSyntaxEquivalence.v │ │ ├── SemanticsOptimized.v │ │ ├── ParserSoundness.v │ │ ├── ParserSemanticsOptimized.v │ │ └── ParserSoundnessOptimized.v │ ├── ParserInterfaceReflective.v │ ├── NOTES.md │ ├── GenericBaseTypes.v │ └── Reachable │ │ ├── MaybeEmpty │ │ ├── Core.v │ │ └── WellFounded.v │ │ ├── All │ │ ├── ReachableWellFounded.v │ │ └── Reachable.v │ │ ├── OnlyFirst │ │ └── ReachableWellFounded.v │ │ └── OnlyLast │ │ └── ReachableWellFounded.v ├── CertifiedExtraction │ ├── HintDBs.v │ ├── .dir-locals.el │ ├── Extraction │ │ ├── Internal.v │ │ ├── BinEncoders │ │ │ └── CallRules │ │ │ │ └── CallRules.v │ │ ├── ConditionalTactics.v │ │ ├── External │ │ │ ├── GenericMethods.v │ │ │ ├── External.v │ │ │ └── ScalarMethods.v │ │ └── QueryStructures │ │ │ ├── CallRules │ │ │ └── CallRules.v │ │ │ ├── BinNatUtils.v │ │ │ ├── WrappersAreConsistent.v │ │ │ ├── Basics.v │ │ │ └── AllOfLength.v │ ├── Benchmarks │ │ └── Any.v │ ├── StringMapUtils.v │ └── Utils.v ├── ComputationalEnsembles.v ├── ADTRefinement │ ├── Refinements.v │ ├── BuildADTRefinements.v │ └── Refinements │ │ └── RefineHideADT.v ├── QueryStructure │ ├── Implementation │ │ ├── ListImplementation.v │ │ ├── BagImplementation.v │ │ ├── Operations.v │ │ ├── DataStructures │ │ │ └── Bags │ │ │ │ ├── Bags.v │ │ │ │ └── NatCompare_Facts.v │ │ └── Constraints │ │ │ └── ConstraintChecksUnfoldings.v │ └── Specification │ │ ├── Constraints │ │ ├── DuplicateFree.v │ │ └── tupleAgree.v │ │ ├── Operations │ │ ├── Delete.v │ │ └── Update.v │ │ └── Representation │ │ └── Heading2.v ├── Computation.v ├── ADTRefinement.v ├── ADTNotation.v ├── FiniteSetADTs.v ├── Computation │ ├── SetoidEqMorphisms.v │ ├── Notations.v │ └── Refinements │ │ └── Tactics.v ├── ADT │ ├── Core.v │ ├── ADTHide.v │ └── ADTSig.v ├── FiniteSetADTs │ └── WordInterface.v └── ComputationalEnsembles │ ├── Laws.v │ └── Core.v ├── .github └── dependabot.yml ├── META.coq-fiat-parsers ├── README.md ├── .mailmap ├── Bedrock └── Memory.v └── LICENSE /src/Guard/dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 1.6) 2 | -------------------------------------------------------------------------------- /src/ADT.v: -------------------------------------------------------------------------------- 1 | Require Export Fiat.ADT.ADTSig Fiat.ADT.Core. 2 | -------------------------------------------------------------------------------- /src/Examples/ignoreFail.ml: -------------------------------------------------------------------------------- 1 | let failwith _ = Obj.magic 0 2 | 3 | -------------------------------------------------------------------------------- /src/Narcissus/OCamlExtraction/OCamlNativeInt.ml: -------------------------------------------------------------------------------- 1 | type t = int 2 | -------------------------------------------------------------------------------- /src/Fiat4Monitors/paintball/radl__msg4.msg: -------------------------------------------------------------------------------- 1 | uint8 data 2 | uint8 radl__flags -------------------------------------------------------------------------------- /src/Fiat4Monitors/paintball/radl__msg5.msg: -------------------------------------------------------------------------------- 1 | float64 data 2 | uint8 radl__flags -------------------------------------------------------------------------------- /src/Common/Tactics/HintDbExtra.v.v810: -------------------------------------------------------------------------------- 1 | Declare ML Module "hint_db_extra_plugin". 2 | -------------------------------------------------------------------------------- /src/Common/Tactics/HintDbExtra.v.v811: -------------------------------------------------------------------------------- 1 | Declare ML Module "hint_db_extra_plugin". 2 | -------------------------------------------------------------------------------- /src/Common/Tactics/HintDbExtra.v.v812: -------------------------------------------------------------------------------- 1 | Declare ML Module "hint_db_extra_plugin". 2 | -------------------------------------------------------------------------------- /src/Common/Tactics/HintDbExtra.v.v813: -------------------------------------------------------------------------------- 1 | Declare ML Module "hint_db_extra_plugin". 2 | -------------------------------------------------------------------------------- /src/Common/Tactics/HintDbExtra.v.v814: -------------------------------------------------------------------------------- 1 | Declare ML Module "hint_db_extra_plugin". 2 | -------------------------------------------------------------------------------- /src/Common/Tactics/HintDbExtra.v.v815: -------------------------------------------------------------------------------- 1 | Declare ML Module "hint_db_extra_plugin". 2 | -------------------------------------------------------------------------------- /src/Common/Tactics/HintDbExtra.v.v84: -------------------------------------------------------------------------------- 1 | Declare ML Module "hint_db_extra_plugin". 2 | -------------------------------------------------------------------------------- /src/Common/Tactics/HintDbExtra.v.v85: -------------------------------------------------------------------------------- 1 | Declare ML Module "hint_db_extra_plugin". 2 | -------------------------------------------------------------------------------- /src/Common/Tactics/HintDbExtra.v.v86: -------------------------------------------------------------------------------- 1 | Declare ML Module "hint_db_extra_plugin". 2 | -------------------------------------------------------------------------------- /src/Common/Tactics/HintDbExtra.v.v87: -------------------------------------------------------------------------------- 1 | Declare ML Module "hint_db_extra_plugin". 2 | -------------------------------------------------------------------------------- /src/Common/Tactics/HintDbExtra.v.v88: -------------------------------------------------------------------------------- 1 | Declare ML Module "hint_db_extra_plugin". 2 | -------------------------------------------------------------------------------- /src/Common/Tactics/HintDbExtra.v.v89: -------------------------------------------------------------------------------- 1 | Declare ML Module "hint_db_extra_plugin". 2 | -------------------------------------------------------------------------------- /src/Parsers/BooleanRecognizerMin.v: -------------------------------------------------------------------------------- 1 | Require Export Fiat.Common.Coq__8_4__8_5__Compat. 2 | -------------------------------------------------------------------------------- /src/Narcissus/Examples/NetworkStack/.merlin: -------------------------------------------------------------------------------- 1 | PKG core 2 | PKG core_bench 3 | PKG cstruct 4 | -------------------------------------------------------------------------------- /src/Common/Tactics/TransparentAbstract.v.v810: -------------------------------------------------------------------------------- 1 | Declare ML Module "transparent_abstract_plugin". 2 | -------------------------------------------------------------------------------- /src/Common/Tactics/TransparentAbstract.v.v811: -------------------------------------------------------------------------------- 1 | Declare ML Module "transparent_abstract_plugin". 2 | -------------------------------------------------------------------------------- /src/Common/Tactics/TransparentAbstract.v.v812: -------------------------------------------------------------------------------- 1 | Declare ML Module "transparent_abstract_plugin". 2 | -------------------------------------------------------------------------------- /src/Common/Tactics/TransparentAbstract.v.v813: -------------------------------------------------------------------------------- 1 | Declare ML Module "transparent_abstract_plugin". 2 | -------------------------------------------------------------------------------- /src/Common/Tactics/TransparentAbstract.v.v814: -------------------------------------------------------------------------------- 1 | Declare ML Module "transparent_abstract_plugin". 2 | -------------------------------------------------------------------------------- /src/Common/Tactics/TransparentAbstract.v.v815: -------------------------------------------------------------------------------- 1 | Declare ML Module "transparent_abstract_plugin". 2 | -------------------------------------------------------------------------------- /src/Common/Tactics/TransparentAbstract.v.v84: -------------------------------------------------------------------------------- 1 | Declare ML Module "transparent_abstract_plugin". 2 | -------------------------------------------------------------------------------- /src/Common/Tactics/TransparentAbstract.v.v85: -------------------------------------------------------------------------------- 1 | Declare ML Module "transparent_abstract_plugin". 2 | -------------------------------------------------------------------------------- /src/Common/Tactics/TransparentAbstract.v.v86: -------------------------------------------------------------------------------- 1 | Declare ML Module "transparent_abstract_plugin". 2 | -------------------------------------------------------------------------------- /src/Common/Tactics/TransparentAbstract.v.v87: -------------------------------------------------------------------------------- 1 | Declare ML Module "transparent_abstract_plugin". 2 | -------------------------------------------------------------------------------- /src/Common/Tactics/TransparentAbstract.v.v88: -------------------------------------------------------------------------------- 1 | Declare ML Module "transparent_abstract_plugin". 2 | -------------------------------------------------------------------------------- /src/Common/Tactics/TransparentAbstract.v.v89: -------------------------------------------------------------------------------- 1 | Declare ML Module "transparent_abstract_plugin". 2 | -------------------------------------------------------------------------------- /src/Common/Tactics/hint_db_extra_plugin.mllib: -------------------------------------------------------------------------------- 1 | Hint_db_extra_tactics 2 | Hint_db_extra_plugin 3 | -------------------------------------------------------------------------------- /src/Common/Tactics/HintDbExtra.v.v816: -------------------------------------------------------------------------------- 1 | Declare ML Module "coq-fiat-parsers.hint_db_extra_plugin". 2 | -------------------------------------------------------------------------------- /src/Common/Tactics/HintDbExtra.v.v817: -------------------------------------------------------------------------------- 1 | Declare ML Module "coq-fiat-parsers.hint_db_extra_plugin". 2 | -------------------------------------------------------------------------------- /src/Common/Tactics/HintDbExtra.v.v818: -------------------------------------------------------------------------------- 1 | Declare ML Module "coq-fiat-parsers.hint_db_extra_plugin". 2 | -------------------------------------------------------------------------------- /src/Common/Tactics/HintDbExtra.v.v819: -------------------------------------------------------------------------------- 1 | Declare ML Module "coq-fiat-parsers.hint_db_extra_plugin". 2 | -------------------------------------------------------------------------------- /src/Common/Tactics/HintDbExtra.v.v820: -------------------------------------------------------------------------------- 1 | Declare ML Module "coq-fiat-parsers.hint_db_extra_plugin". 2 | -------------------------------------------------------------------------------- /src/Common/Tactics/HintDbExtra.v.v90: -------------------------------------------------------------------------------- 1 | Declare ML Module "coq-fiat-parsers.hint_db_extra_plugin". 2 | -------------------------------------------------------------------------------- /src/Common/Tactics/HintDbExtra.v.v91: -------------------------------------------------------------------------------- 1 | Declare ML Module "coq-fiat-parsers.hint_db_extra_plugin". 2 | -------------------------------------------------------------------------------- /src/Common/Tactics/HintDbExtra.v.v92: -------------------------------------------------------------------------------- 1 | Declare ML Module "coq-fiat-parsers.hint_db_extra_plugin". 2 | -------------------------------------------------------------------------------- /src/Guard/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name guard) 3 | (modes exe) 4 | (libraries cstruct core_bench)) 5 | -------------------------------------------------------------------------------- /src/Common/Tactics/TransparentAbstract.v.v816: -------------------------------------------------------------------------------- 1 | Declare ML Module "coq-fiat-parsers.transparent_abstract_plugin". 2 | -------------------------------------------------------------------------------- /src/Common/Tactics/TransparentAbstract.v.v817: -------------------------------------------------------------------------------- 1 | Declare ML Module "coq-fiat-parsers.transparent_abstract_plugin". 2 | -------------------------------------------------------------------------------- /src/Common/Tactics/TransparentAbstract.v.v818: -------------------------------------------------------------------------------- 1 | Declare ML Module "coq-fiat-parsers.transparent_abstract_plugin". 2 | -------------------------------------------------------------------------------- /src/Common/Tactics/TransparentAbstract.v.v819: -------------------------------------------------------------------------------- 1 | Declare ML Module "coq-fiat-parsers.transparent_abstract_plugin". 2 | -------------------------------------------------------------------------------- /src/Common/Tactics/TransparentAbstract.v.v820: -------------------------------------------------------------------------------- 1 | Declare ML Module "coq-fiat-parsers.transparent_abstract_plugin". 2 | -------------------------------------------------------------------------------- /src/Common/Tactics/TransparentAbstract.v.v90: -------------------------------------------------------------------------------- 1 | Declare ML Module "coq-fiat-parsers.transparent_abstract_plugin". 2 | -------------------------------------------------------------------------------- /src/Common/Tactics/TransparentAbstract.v.v91: -------------------------------------------------------------------------------- 1 | Declare ML Module "coq-fiat-parsers.transparent_abstract_plugin". 2 | -------------------------------------------------------------------------------- /src/Common/Tactics/TransparentAbstract.v.v92: -------------------------------------------------------------------------------- 1 | Declare ML Module "coq-fiat-parsers.transparent_abstract_plugin". 2 | -------------------------------------------------------------------------------- /src/Common/Tactics/transparent_abstract_plugin.mllib: -------------------------------------------------------------------------------- 1 | Transparent_abstract_tactics 2 | Transparent_abstract_plugin 3 | -------------------------------------------------------------------------------- /src/CertifiedExtraction/HintDBs.v: -------------------------------------------------------------------------------- 1 | Create HintDb SameValues_Fiat_db discriminated. 2 | Create HintDb SameValues discriminated. 3 | -------------------------------------------------------------------------------- /src/Common/Tactics/GetGoal.v: -------------------------------------------------------------------------------- 1 | Require Export Fiat.Common.Coq__8_4__8_5__Compat. 2 | Ltac get_goal := 3 | match goal with |- ?G => G end. 4 | -------------------------------------------------------------------------------- /src/Examples/QueryStructure/GithubSample/package.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "fiat-github", 3 | "main": "main.js", 4 | "dependencies": { 5 | "octonode": "^0.7.1" 6 | } 7 | } 8 | -------------------------------------------------------------------------------- /src/Common/Tactics/IsClosed.v: -------------------------------------------------------------------------------- 1 | Require Export Fiat.Common.Coq__8_4__8_5__Compat. 2 | (** Test that a term is ground/closed *) 3 | Ltac is_closed x := let test := constr:(x) in idtac. 4 | -------------------------------------------------------------------------------- /src/ComputationalEnsembles.v: -------------------------------------------------------------------------------- 1 | Require Export Fiat.ComputationalEnsembles.Core. 2 | Require Export Fiat.ComputationalEnsembles.Laws. 3 | Require Export Fiat.ComputationalEnsembles.Morphisms. 4 | -------------------------------------------------------------------------------- /src/Common/Tactics/FreeIn.v: -------------------------------------------------------------------------------- 1 | Require Export Fiat.Common.Coq__8_4__8_5__Compat. 2 | Ltac free_in x y := 3 | idtac; 4 | match y with 5 | | context[x] => fail 1 x "appears in" y 6 | | _ => idtac 7 | end. 8 | -------------------------------------------------------------------------------- /src/ADTRefinement/Refinements.v: -------------------------------------------------------------------------------- 1 | Require Export Fiat.ADTRefinement.Refinements.HoneRepresentation 2 | Fiat.ADTRefinement.Refinements.SimplifyRep 3 | Fiat.ADTRefinement.Refinements.DelegateMethods. 4 | -------------------------------------------------------------------------------- /src/QueryStructure/Implementation/ListImplementation.v: -------------------------------------------------------------------------------- 1 | Require Export Fiat.QueryStructure.Implementation.Operations.List.ListInsertRefinements 2 | Fiat.QueryStructure.Implementation.Operations.List.ListQueryRefinements. 3 | -------------------------------------------------------------------------------- /src/Parsers/AbstractInterpretation/NonTerminalMapWf.v: -------------------------------------------------------------------------------- 1 | Require Import Fiat.Parsers.AbstractInterpretation.NonTerminalMap. 2 | Require Import Fiat.Common.FMapExtensions.Wf. 3 | 4 | Module NonTerminalMapExtensions := FMapExtensionsWf NonTerminalMap. 5 | -------------------------------------------------------------------------------- /src/Examples/printCode.ml: -------------------------------------------------------------------------------- 1 | let rec printTree = function 2 | | LabelMap.Raw.Leaf -> () 3 | | LabelMap.Raw.Node (t1, _, s, t2, _) -> 4 | printTree t1; 5 | List.iter print_char s; 6 | printTree t2 7 | 8 | let _ = printTree compiled 9 | -------------------------------------------------------------------------------- /src/Parsers/ContextFreeGrammar/Fix/Interface.v: -------------------------------------------------------------------------------- 1 | Require Export Fiat.Parsers.ContextFreeGrammar.Fix.PreInterface. 2 | Require Import Fiat.Parsers.ContextFreeGrammar.Fix.ProdAbstractInterpretationDefinitions. 3 | (*Require Import Fiat.Parsers.ContextFreeGrammar.Fix.AsciiLattice. 4 | *) 5 | -------------------------------------------------------------------------------- /src/Computation.v: -------------------------------------------------------------------------------- 1 | Require Export Fiat.Computation.Core. 2 | Require Export Fiat.Computation.Monad. 3 | Require Export Fiat.Computation.SetoidMorphisms. 4 | Require Export Fiat.Computation.ApplyMonad. 5 | Require Export Fiat.Computation.Refinements.General. 6 | 7 | Open Scope comp_scope. 8 | -------------------------------------------------------------------------------- /src/ADTRefinement.v: -------------------------------------------------------------------------------- 1 | Require Export Fiat.ADTRefinement.Core 2 | Fiat.ADTRefinement.SetoidMorphisms 3 | Fiat.ADTRefinement.GeneralRefinements 4 | Fiat.ADTRefinement.Refinements. 5 | 6 | Arguments refineMethod / _ _ _ _ _ _ _. 7 | Arguments refineConstructor / _ _ _ _ _ _. 8 | -------------------------------------------------------------------------------- /src/Parsers/Refinement/ExtractSharpenedABStar.v: -------------------------------------------------------------------------------- 1 | Require Import Fiat.Parsers.Refinement.SharpenedABStar. 2 | 3 | Extraction "src/Parsers/Refinement/Testing/test_ab_star.ml" main_ab_star_ocaml. 4 | Extraction "src/Parsers/Refinement/Testing/test_ab_star_reference.ml" main_ab_star_reference_ocaml. 5 | -------------------------------------------------------------------------------- /src/Common/Tactics/Head.v: -------------------------------------------------------------------------------- 1 | Require Export Fiat.Common.Coq__8_4__8_5__Compat. 2 | (** find the head of the given expression *) 3 | Ltac head expr := 4 | match expr with 5 | | ?f _ => head f 6 | | _ => expr 7 | end. 8 | 9 | Ltac head_hnf expr := let expr' := eval hnf in expr in head expr'. 10 | -------------------------------------------------------------------------------- /src/Parsers/Refinement/DisjointLemmasEarlyDeclarations.v: -------------------------------------------------------------------------------- 1 | Require Export Fiat.Common.Coq__8_4__8_5__Compat. 2 | (** We declare this tactic here so we can overwrite it in 3 | DisjointLemmas, but also run it in Refinement/Tactics.v without 4 | importing DisjointLemmas. *) 5 | Ltac do_disjoint_precomputations _ := idtac. 6 | -------------------------------------------------------------------------------- /src/CertifiedExtraction/.dir-locals.el: -------------------------------------------------------------------------------- 1 | ;;; Directory Local Variables 2 | ;;; For more information see (info "(emacs) Directory Variables") 3 | 4 | ((coq-mode 5 | (company-coq-dir-local-symbols 6 | ("->>" . ?↦) ("~~>" . ?⇝) ("|>" . ?▹) 7 | ("{{" . ?\❴) ("}}" . ?\❵) 8 | ;; ("[[" . ?\⟦) ("]]" . ?\⟧) 9 | ))) 10 | -------------------------------------------------------------------------------- /src/Parsers/Grammars/ExpressionParen.v: -------------------------------------------------------------------------------- 1 | (** * Definition of grammar for expressions involving parentheses *) 2 | Require Import Fiat.Parsers.ContextFreeGrammar.Notations. 3 | 4 | Definition paren_expr_grammar : grammar Ascii.ascii := 5 | [[[ "expr" ::== "number" || "(" "expr" ")";; 6 | "number" ::== [0-9] || [0-9] "number" 7 | ]]]. 8 | -------------------------------------------------------------------------------- /src/ADTNotation.v: -------------------------------------------------------------------------------- 1 | Require Export Fiat.Common.ilist Fiat.Common.BoundedLookup 2 | Fiat.ADTNotation.BuildADTSig 3 | Fiat.ADTNotation.BuildADT 4 | Fiat.ADTNotation.BuildADTReplaceMethods 5 | Fiat.ADTNotation.BuildComputationalADT. 6 | 7 | Open Scope ADT_scope. 8 | Open Scope ADTParsing_scope. 9 | Open Scope ADTSig_scope. 10 | -------------------------------------------------------------------------------- /src/Examples/QueryStructure/bench_bookstore.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env sh 2 | cp ../../../bookstore.ml* ./ 3 | ocamlfind ocamlopt -linkpkg -package unix -package core_bench -thread -w -8 -package str -o bookstore_repl bookstore.mli bookstore.ml bookstore_repl.ml 4 | # echo "benchmark 1000 10000 1000 1000 1000" | ./bookstore_repl 5 | ./bookstore_repl 100 1000 100 100 100 "$@" 6 | -------------------------------------------------------------------------------- /src/CertifiedExtraction/Extraction/Internal.v: -------------------------------------------------------------------------------- 1 | Require Export 2 | CertifiedExtraction.Extraction.Core 3 | CertifiedExtraction.Extraction.Basics 4 | CertifiedExtraction.Extraction.BinExpr 5 | CertifiedExtraction.Extraction.Conditionals 6 | CertifiedExtraction.Extraction.DeallocSCA 7 | CertifiedExtraction.Extraction.PreconditionSets. 8 | -------------------------------------------------------------------------------- /src/CertifiedExtraction/Extraction/BinEncoders/CallRules/CallRules.v: -------------------------------------------------------------------------------- 1 | Require Export 2 | Fiat.CertifiedExtraction.Extraction.BinEncoders.CallRules.Misc 3 | Fiat.CertifiedExtraction.Extraction.BinEncoders.CallRules.Compose 4 | Fiat.CertifiedExtraction.Extraction.BinEncoders.CallRules.ByteString 5 | Fiat.CertifiedExtraction.Extraction.BinEncoders.CallRules.WordLists. 6 | -------------------------------------------------------------------------------- /src/Parsers/StringLike.v: -------------------------------------------------------------------------------- 1 | (** * The string-like type *) 2 | (** ** Definitions *) 3 | 4 | (** ** Various string-like types *)Require Fiat.Parsers.StringLike.String. 5 | (** ** Various theorems about string-like types *) 6 | Require Fiat.Parsers.StringLike.Properties. 7 | 8 | Export Parsers.StringLike.Core. 9 | Export Parsers.StringLike.String. 10 | Export Parsers.StringLike.Properties. 11 | -------------------------------------------------------------------------------- /src/Common/Ensembles.v: -------------------------------------------------------------------------------- 1 | Require Export Fiat.Common.Ensembles.Notations. 2 | Require Export Fiat.Common.Ensembles.Equivalence. 3 | Require Export Fiat.Common.Ensembles.Morphisms. 4 | Require Export Fiat.Common.Ensembles.CombinatorLaws. 5 | Require Export Fiat.Common.Ensembles.EnsembleListEquivalence. 6 | Require Export Fiat.Common.Ensembles.Cardinal. 7 | Require Export Fiat.Common.Ensembles.IndexedEnsembles. 8 | -------------------------------------------------------------------------------- /src/Narcissus/Stores/EmptyStore.v: -------------------------------------------------------------------------------- 1 | Require Import Fiat.Narcissus.Stores.Cache. 2 | 3 | Instance test_cache : Cache := 4 | {| CacheFormat := unit; 5 | CacheDecode := unit; 6 | Equiv := fun _ _ => True |}. 7 | 8 | Instance test_cache_add_nat : CacheAdd test_cache nat := 9 | {| addE := fun ce _ => ce; 10 | addD := fun cd _ => cd; 11 | add_correct := fun _ _ _ eqv => eqv |}. 12 | -------------------------------------------------------------------------------- /src/ADTRefinement/BuildADTRefinements.v: -------------------------------------------------------------------------------- 1 | Require Export Fiat.ADTRefinement.BuildADTRefinements.HoneRepresentation 2 | Fiat.ADTRefinement.BuildADTRefinements.SimplifyRep 3 | Fiat.ADTRefinement.BuildADTRefinements.AddCache 4 | Fiat.ADTRefinement.GeneralBuildADTRefinements. 5 | 6 | (* Notation-friendly complements of the refinements for working 7 | with ADTs built from [BuildADT]. *) 8 | -------------------------------------------------------------------------------- /src/Common/Tactics/hint_db_extra_plugin.ml4.v84: -------------------------------------------------------------------------------- 1 | open Hint_db_extra_tactics 2 | 3 | TACTIC EXTEND foreach_db 4 | | [ "foreach" "[" ne_preident_list(l) "]" "run" tactic(k) ] -> 5 | [ fun gl -> WITH_DB.with_hint_db l k gl ] 6 | END 7 | 8 | TACTIC EXTEND addto_db 9 | | [ "add" constr(name_op) "to" ne_preident_list(l) ] -> 10 | [ fun gl -> WITH_DB.add_resolve_to_db name_op l gl] 11 | END;; 12 | -------------------------------------------------------------------------------- /src/Parsers/Specification.v: -------------------------------------------------------------------------------- 1 | (** * Definition of a [comp]-based specification of a CFG parser-recognizer *) 2 | Require Import Fiat.Computation.Core Fiat.Parsers.ContextFreeGrammar.Core. 3 | 4 | Set Implicit Arguments. 5 | 6 | Definition parser_spec `{StringLike Char} 7 | (G : grammar Char) 8 | : String -> Comp bool 9 | := fun str => { b : bool | b = true <-> inhabited (parse_of_grammar str G) }%comp. 10 | -------------------------------------------------------------------------------- /src/Parsers/Grammars/ExpressionNumPlus.v: -------------------------------------------------------------------------------- 1 | (** * Definition of grammar for expressions involving plus *) 2 | Require Import Fiat.Parsers.ContextFreeGrammar.Notations. 3 | 4 | Definition plus_expr_pregrammar : pregrammar ascii := 5 | [[[ "expr" ::== "number" || "number" "+" "expr";; 6 | "number" ::== [0-9] || [0-9] "number" 7 | ]]]. 8 | 9 | Definition plus_expr_grammar : grammar ascii := plus_expr_pregrammar. 10 | -------------------------------------------------------------------------------- /.github/dependabot.yml: -------------------------------------------------------------------------------- 1 | # Set update schedule for GitHub Actions 2 | 3 | version: 2 4 | updates: 5 | 6 | - package-ecosystem: "github-actions" 7 | directory: "/" 8 | schedule: 9 | # Check for updates to GitHub Actions every weekday 10 | interval: "daily" 11 | 12 | - package-ecosystem: "gitsubmodule" 13 | directory: "/" 14 | schedule: 15 | interval: "daily" 16 | labels: 17 | - "submodules" 18 | -------------------------------------------------------------------------------- /src/CertifiedExtraction/Extraction/ConditionalTactics.v: -------------------------------------------------------------------------------- 1 | Require Import 2 | CertifiedExtraction.Extraction.Core 3 | CertifiedExtraction.Extraction.Conditionals. 4 | 5 | Ltac is_comp c := 6 | match type of c with 7 | | @Comp _ => idtac 8 | | _ => fail 1 9 | end. 10 | 11 | Ltac compile_if t tp fp := 12 | is_comp tp; is_comp fp; 13 | let test_var := gensym "test" in 14 | apply (CompileIf _ (tmp := test_var)). 15 | -------------------------------------------------------------------------------- /src/CertifiedExtraction/Extraction/External/GenericMethods.v: -------------------------------------------------------------------------------- 1 | Require Import 2 | Coq.Lists.List 3 | CertifiedExtraction.Extraction.External.Core. 4 | 5 | Definition FacadeImplementationWW av (fWW: W -> W) : AxiomaticSpec av. 6 | refine {| 7 | PreCond := fun args => exists x: W, args = (wrap x) :: nil; 8 | PostCond := fun args ret => exists x: W, args = (wrap x, None) :: nil /\ ret = wrap (fWW x) 9 | |}; spec_t. 10 | Defined. 11 | -------------------------------------------------------------------------------- /src/CertifiedExtraction/Extraction/QueryStructures/CallRules/CallRules.v: -------------------------------------------------------------------------------- 1 | Require Export 2 | CertifiedExtraction.Extraction.QueryStructures.CallRules.Tuple 3 | CertifiedExtraction.Extraction.QueryStructures.CallRules.WordList 4 | CertifiedExtraction.Extraction.QueryStructures.CallRules.TupleList 5 | CertifiedExtraction.Extraction.QueryStructures.CallRules.Tuples0 6 | CertifiedExtraction.Extraction.QueryStructures.CallRules.Tuples2. 7 | -------------------------------------------------------------------------------- /src/Common/Tactics/FoldIsTrue.v: -------------------------------------------------------------------------------- 1 | Require Export Fiat.Common.Coq__8_4__8_5__Compat. 2 | (* These tactics do [change (?x = true) with (is_true x) in *], but get around anomalies in older versions of 8.4 *) 3 | Ltac fold_is_true' x := 4 | change (x = true) with (is_true x) in *. 5 | Ltac fold_is_true := 6 | repeat match goal with 7 | | [ H : context[?x = true] |- _ ] => fold_is_true' x 8 | | [ |- context[?x = true] ] => fold_is_true' x 9 | end. 10 | -------------------------------------------------------------------------------- /src/Parsers/Refinement/Testing/Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: all test-ab-star-pretty test-ab-star test-ab-star-profile test-ab-star-profile-graph 2 | 3 | all: test-ab-star-pretty 4 | 5 | test-ab-star:: 6 | $(MAKE) -f Makefile.ab_star test 7 | 8 | test-ab-star-pretty:: 9 | $(MAKE) -f Makefile.ab_star test-pretty 10 | 11 | test-ab-star-profile:: 12 | $(MAKE) -f Makefile.ab_star test-profile 13 | 14 | test-ab-star-profile-graph:: 15 | $(MAKE) -f Makefile.ab_star test-profile-graph 16 | -------------------------------------------------------------------------------- /src/Narcissus/Common/Sig.v: -------------------------------------------------------------------------------- 1 | Require Import 2 | Fiat.Narcissus.Common.Specs. 3 | 4 | Notation "[ n ]" := (exist _ n _) : format. 5 | 6 | Lemma sig_equivalence : 7 | forall (A : Type) (P : A -> Prop) (n m : A) (n_pf : P n) (m_pf : P m), 8 | n = m <-> exist P n n_pf = exist P m m_pf. 9 | Proof. 10 | intros A P n m n_pf m_pf. split. 11 | intro nm_pf. subst. 12 | pose proof (proof_irrelevance _ n_pf m_pf). 13 | subst. reflexivity. 14 | inversion 1. eauto. 15 | Qed. 16 | -------------------------------------------------------------------------------- /src/Narcissus/Common/Notations.v: -------------------------------------------------------------------------------- 1 | Reserved Notation "'Either' t 'Or' e " (at level 100, right associativity). 2 | Reserved Notation "x 'ThenC' y" (at level 100, right associativity). 3 | Reserved Notation "x 'DoneC'" (at level 99, right associativity). 4 | Reserved Notation "format1 'ThenChecksum' c 'OfSize' sz 'ThenCarryOn' format2" 5 | (format2 at next level, at level 98, right associativity). 6 | Reserved Notation "| ls |" (at level 200). 7 | 8 | Delimit Scope format_scope with format. 9 | -------------------------------------------------------------------------------- /src/Common/Tactics/DestructSig.v: -------------------------------------------------------------------------------- 1 | Require Import Fiat.Common.Tactics.DestructHyps. 2 | Ltac destruct_sig_matcher HT := 3 | match eval hnf in HT with 4 | | ex _ => idtac 5 | | ex2 _ _ => idtac 6 | | sig _ => idtac 7 | | sig2 _ _ => idtac 8 | | sigT _ => idtac 9 | | sigT2 _ _ => idtac 10 | | and _ _ => idtac 11 | | prod _ _ => idtac 12 | end. 13 | Ltac destruct_sig := destruct_all_matches destruct_sig_matcher. 14 | Ltac destruct_sig' := destruct_all_matches' destruct_sig_matcher. 15 | -------------------------------------------------------------------------------- /src/Common/Tactics/Combinators.v: -------------------------------------------------------------------------------- 1 | Require Export Fiat.Common.Coq__8_4__8_5__Compat. 2 | (** Test if a tactic succeeds, but always roll-back the results *) 3 | Tactic Notation "test" tactic3(tac) := 4 | try (first [ tac | fail 2 tac "does not succeed" ]; fail 0 tac "succeeds"; [](* test for [t] solved all goals *)). 5 | 6 | (** [not tac] is equivalent to [fail tac "succeeds"] if [tac] succeeds, and is equivalent to [idtac] if [tac] fails *) 7 | Tactic Notation "not" tactic3(tac) := try ((test tac); fail 1 tac "succeeds"). 8 | -------------------------------------------------------------------------------- /src/Common/Tactics/hint_db_extra_plugin.ml4.v85: -------------------------------------------------------------------------------- 1 | open Hint_db_extra_tactics 2 | open Stdarg 3 | open Constrarg 4 | 5 | DECLARE PLUGIN "hint_db_extra_plugin" 6 | 7 | TACTIC EXTEND foreach_db 8 | | [ "foreach" "[" ne_preident_list(l) "]" "run" tactic(k) ] -> 9 | [ WITH_DB.with_hint_db l k ] 10 | END 11 | 12 | TACTIC EXTEND addto_db 13 | | [ "add" constr(name) "to" ne_preident_list(l) ] -> 14 | [ WITH_DB.add_resolve_to_db (Hints.IsConstr (name, Univ.ContextSet.empty)) l] 15 | END;; 16 | -------------------------------------------------------------------------------- /src/Common/Tactics/hint_db_extra_plugin.ml4.v86: -------------------------------------------------------------------------------- 1 | open Hint_db_extra_tactics 2 | open Stdarg 3 | open Constrarg 4 | 5 | DECLARE PLUGIN "hint_db_extra_plugin" 6 | 7 | TACTIC EXTEND foreach_db 8 | | [ "foreach" "[" ne_preident_list(l) "]" "run" tactic(k) ] -> 9 | [ WITH_DB.with_hint_db l k ] 10 | END 11 | 12 | TACTIC EXTEND addto_db 13 | | [ "add" constr(name) "to" ne_preident_list(l) ] -> 14 | [ WITH_DB.add_resolve_to_db (Hints.IsConstr (name, Univ.ContextSet.empty)) l] 15 | END;; 16 | -------------------------------------------------------------------------------- /src/QueryStructure/Implementation/BagImplementation.v: -------------------------------------------------------------------------------- 1 | Require Export Fiat.QueryStructure.Implementation.DataStructures.Bags.BagsInterface 2 | Fiat.QueryStructure.Implementation.DataStructures.Bags.BagsProperties 3 | Fiat.QueryStructure.Implementation.DataStructures.Bags.ListBags 4 | Fiat.QueryStructure.Implementation.DataStructures.Bags.TreeBags 5 | Fiat.QueryStructure.Implementation.DataStructures.Bags.CachingBags 6 | Fiat.QueryStructure.Implementation.DataStructures.Bags.BagsTactics. 7 | -------------------------------------------------------------------------------- /src/QueryStructure/Implementation/Operations.v: -------------------------------------------------------------------------------- 1 | Require Export Fiat.QueryStructure.Implementation.Operations.General.InsertRefinements Fiat.QueryStructure.Implementation.Operations.General.QueryRefinements 2 | Fiat.QueryStructure.Implementation.Operations.General.QueryStructureRefinements Fiat.QueryStructure.Implementation.Constraints.ConstraintChecksRefinements 3 | Fiat.QueryStructure.Implementation.Constraints.ConstraintChecksUnfoldings Fiat.QueryStructure.Implementation.Operations.General.DeleteRefinements. 4 | -------------------------------------------------------------------------------- /src/QueryStructure/Implementation/DataStructures/Bags/Bags.v: -------------------------------------------------------------------------------- 1 | Require Export Fiat.QueryStructure.Implementation.DataStructures.Bags.BagsInterface 2 | Fiat.QueryStructure.Implementation.DataStructures.Bags.BagsProperties 3 | Fiat.QueryStructure.Implementation.DataStructures.Bags.ListBags 4 | Fiat.QueryStructure.Implementation.DataStructures.Bags.TreeBags 5 | Fiat.QueryStructure.Implementation.DataStructures.Bags.CachingBags 6 | Fiat.QueryStructure.Implementation.DataStructures.Bags.BagsTactics. 7 | -------------------------------------------------------------------------------- /src/Common/Tactics/hint_db_extra_plugin.ml4.v87: -------------------------------------------------------------------------------- 1 | open Hint_db_extra_tactics 2 | open Stdarg 3 | open Ltac_plugin 4 | open Tacarg 5 | 6 | DECLARE PLUGIN "hint_db_extra_plugin" 7 | 8 | TACTIC EXTEND foreach_db 9 | | [ "foreach" "[" ne_preident_list(l) "]" "run" tactic(k) ] -> 10 | [ WITH_DB.with_hint_db l k ] 11 | END 12 | 13 | TACTIC EXTEND addto_db 14 | | [ "add" constr(name) "to" ne_preident_list(l) ] -> 15 | [ WITH_DB.add_resolve_to_db (Hints.IsConstr (name, Univ.ContextSet.empty)) l] 16 | END;; 17 | -------------------------------------------------------------------------------- /src/Common/Tactics/hint_db_extra_plugin.ml4.v88: -------------------------------------------------------------------------------- 1 | open Hint_db_extra_tactics 2 | open Stdarg 3 | open Ltac_plugin 4 | open Tacarg 5 | 6 | DECLARE PLUGIN "hint_db_extra_plugin" 7 | 8 | TACTIC EXTEND foreach_db 9 | | [ "foreach" "[" ne_preident_list(l) "]" "run" tactic(k) ] -> 10 | [ WITH_DB.with_hint_db l k ] 11 | END 12 | 13 | TACTIC EXTEND addto_db 14 | | [ "add" constr(name) "to" ne_preident_list(l) ] -> 15 | [ WITH_DB.add_resolve_to_db (Hints.IsConstr (name, Univ.ContextSet.empty)) l] 16 | END;; 17 | -------------------------------------------------------------------------------- /src/Common/Tactics/hint_db_extra_plugin.ml4.v89: -------------------------------------------------------------------------------- 1 | open Hint_db_extra_tactics 2 | open Stdarg 3 | open Ltac_plugin 4 | open Tacarg 5 | 6 | DECLARE PLUGIN "hint_db_extra_plugin" 7 | 8 | TACTIC EXTEND foreach_db 9 | | [ "foreach" "[" ne_preident_list(l) "]" "run" tactic(k) ] -> 10 | [ WITH_DB.with_hint_db l k ] 11 | END 12 | 13 | TACTIC EXTEND addto_db 14 | | [ "add" constr(name) "to" ne_preident_list(l) ] -> 15 | [ WITH_DB.add_resolve_to_db (Hints.IsConstr (name, Univ.ContextSet.empty)) l] 16 | END;; 17 | -------------------------------------------------------------------------------- /src/Common/Tactics/hint_db_extra_plugin.mlg.v90: -------------------------------------------------------------------------------- 1 | { 2 | 3 | open Hint_db_extra_tactics 4 | open Stdarg 5 | open Ltac_plugin 6 | open Tacarg 7 | 8 | } 9 | 10 | DECLARE PLUGIN "coq-fiat-parsers.hint_db_extra_plugin" 11 | 12 | TACTIC EXTEND foreach_db 13 | | [ "foreach" "[" ne_preident_list(l) "]" "run" tactic(k) ] -> 14 | { WITH_DB.with_hint_db l k } 15 | END 16 | 17 | TACTIC EXTEND addto_db 18 | | [ "add" constr(name) "to" ne_preident_list(l) ] -> 19 | { WITH_DB.add_resolve_to_db name l } 20 | END 21 | -------------------------------------------------------------------------------- /src/Common/Tactics/hint_db_extra_plugin.mlg.v91: -------------------------------------------------------------------------------- 1 | { 2 | 3 | open Hint_db_extra_tactics 4 | open Stdarg 5 | open Ltac_plugin 6 | open Tacarg 7 | 8 | } 9 | 10 | DECLARE PLUGIN "coq-fiat-parsers.hint_db_extra_plugin" 11 | 12 | TACTIC EXTEND foreach_db 13 | | [ "foreach" "[" ne_preident_list(l) "]" "run" tactic(k) ] -> 14 | { WITH_DB.with_hint_db l k } 15 | END 16 | 17 | TACTIC EXTEND addto_db 18 | | [ "add" constr(name) "to" ne_preident_list(l) ] -> 19 | { WITH_DB.add_resolve_to_db name l } 20 | END 21 | -------------------------------------------------------------------------------- /src/Common/Tactics/hint_db_extra_plugin.mlg.v92: -------------------------------------------------------------------------------- 1 | { 2 | 3 | open Hint_db_extra_tactics 4 | open Stdarg 5 | open Ltac_plugin 6 | open Tacarg 7 | 8 | } 9 | 10 | DECLARE PLUGIN "coq-fiat-parsers.hint_db_extra_plugin" 11 | 12 | TACTIC EXTEND foreach_db 13 | | [ "foreach" "[" ne_preident_list(l) "]" "run" tactic(k) ] -> 14 | { WITH_DB.with_hint_db l k } 15 | END 16 | 17 | TACTIC EXTEND addto_db 18 | | [ "add" constr(name) "to" ne_preident_list(l) ] -> 19 | { WITH_DB.add_resolve_to_db name l } 20 | END 21 | -------------------------------------------------------------------------------- /src/Common/Tactics/hint_db_extra_plugin.mlg.v819: -------------------------------------------------------------------------------- 1 | { 2 | 3 | open Hint_db_extra_tactics 4 | open Stdarg 5 | open Ltac_plugin 6 | open Tacarg 7 | 8 | } 9 | 10 | DECLARE PLUGIN "coq-fiat-parsers.hint_db_extra_plugin" 11 | 12 | TACTIC EXTEND foreach_db 13 | | [ "foreach" "[" ne_preident_list(l) "]" "run" tactic(k) ] -> 14 | { WITH_DB.with_hint_db l k } 15 | END 16 | 17 | TACTIC EXTEND addto_db 18 | | [ "add" constr(name) "to" ne_preident_list(l) ] -> 19 | { WITH_DB.add_resolve_to_db name l } 20 | END 21 | -------------------------------------------------------------------------------- /src/Common/Tactics/hint_db_extra_plugin.mlg.v820: -------------------------------------------------------------------------------- 1 | { 2 | 3 | open Hint_db_extra_tactics 4 | open Stdarg 5 | open Ltac_plugin 6 | open Tacarg 7 | 8 | } 9 | 10 | DECLARE PLUGIN "coq-fiat-parsers.hint_db_extra_plugin" 11 | 12 | TACTIC EXTEND foreach_db 13 | | [ "foreach" "[" ne_preident_list(l) "]" "run" tactic(k) ] -> 14 | { WITH_DB.with_hint_db l k } 15 | END 16 | 17 | TACTIC EXTEND addto_db 18 | | [ "add" constr(name) "to" ne_preident_list(l) ] -> 19 | { WITH_DB.add_resolve_to_db name l } 20 | END 21 | -------------------------------------------------------------------------------- /src/Parsers/Grammars/JSComment.v: -------------------------------------------------------------------------------- 1 | (** * Definition of grammar for JavaScript comments *) 2 | Require Import Fiat.Parsers.ContextFreeGrammar.Notations. 3 | 4 | Definition js_comment_grammar : grammar ascii := 5 | [[[ ("comment" ::== "'//'" "single_line" \n || "'/*'" "inner_comment" "'*/'");; 6 | ("single_line" ::== "" || (¬\n) "single_line");; 7 | ("inner_comment" ::== "" 8 | || "*" (* ends the comment, e.g., /***/ *) 9 | || "*" (¬"/") "inner_comment" 10 | || (¬"*") "inner_comment") 11 | ]]]%grammar. 12 | -------------------------------------------------------------------------------- /src/Common/Tactics/hint_db_extra_plugin.mlg.v813: -------------------------------------------------------------------------------- 1 | { 2 | 3 | open Hint_db_extra_tactics 4 | open Stdarg 5 | open Ltac_plugin 6 | open Tacarg 7 | 8 | } 9 | 10 | DECLARE PLUGIN "hint_db_extra_plugin" 11 | 12 | TACTIC EXTEND foreach_db 13 | | [ "foreach" "[" ne_preident_list(l) "]" "run" tactic(k) ] -> 14 | { WITH_DB.with_hint_db l k } 15 | END 16 | 17 | TACTIC EXTEND addto_db 18 | | [ "add" constr(name) "to" ne_preident_list(l) ] -> 19 | { WITH_DB.add_resolve_to_db (Hints.hint_constr (name, None)) l } 20 | END 21 | -------------------------------------------------------------------------------- /src/Common/Tactics/hint_db_extra_plugin.mlg.v814: -------------------------------------------------------------------------------- 1 | { 2 | 3 | open Hint_db_extra_tactics 4 | open Stdarg 5 | open Ltac_plugin 6 | open Tacarg 7 | 8 | } 9 | 10 | DECLARE PLUGIN "hint_db_extra_plugin" 11 | 12 | TACTIC EXTEND foreach_db 13 | | [ "foreach" "[" ne_preident_list(l) "]" "run" tactic(k) ] -> 14 | { WITH_DB.with_hint_db l k } 15 | END 16 | 17 | TACTIC EXTEND addto_db 18 | | [ "add" constr(name) "to" ne_preident_list(l) ] -> 19 | { WITH_DB.add_resolve_to_db (Hints.hint_constr (name, None)) l } 20 | END 21 | -------------------------------------------------------------------------------- /src/Common/Tactics/hint_db_extra_plugin.mlg.v815: -------------------------------------------------------------------------------- 1 | { 2 | 3 | open Hint_db_extra_tactics 4 | open Stdarg 5 | open Ltac_plugin 6 | open Tacarg 7 | 8 | } 9 | 10 | DECLARE PLUGIN "hint_db_extra_plugin" 11 | 12 | TACTIC EXTEND foreach_db 13 | | [ "foreach" "[" ne_preident_list(l) "]" "run" tactic(k) ] -> 14 | { WITH_DB.with_hint_db l k } 15 | END 16 | 17 | TACTIC EXTEND addto_db 18 | | [ "add" constr(name) "to" ne_preident_list(l) ] -> 19 | { WITH_DB.add_resolve_to_db (Hints.hint_constr (name, None)) l } 20 | END 21 | -------------------------------------------------------------------------------- /src/Common/Tactics/PrintContext.v: -------------------------------------------------------------------------------- 1 | Require Export Fiat.Common.Coq__8_4__8_5__Compat. 2 | Ltac print_context _ := 3 | lazymatch goal with 4 | | [ H : ?T |- False ] 5 | => try ((clear H || fail 10000 "Anomaly in print_context: could not clear" H); print_context (); fail); 6 | match goal with 7 | | _ => let body := (eval cbv delta [H] in H) in 8 | idtac H ":=" body ":" T 9 | | _ => idtac H ":" T 10 | end 11 | | [ |- False ] => idtac 12 | | [ |- _ ] => try (exfalso; print_context (); fail) 13 | end. 14 | -------------------------------------------------------------------------------- /src/Parsers/Grammars/FlatComments.v: -------------------------------------------------------------------------------- 1 | (** * Definition of grammar for comments that don't nest, which start with two characters and end with another two characters *) 2 | Require Import Fiat.Parsers.ContextFreeGrammar.Notations. 3 | 4 | Definition flat_comment_grammar (ch1_start ch2_start ch1_end ch2_end : ascii) : grammar ascii := 5 | [[[ ("comment" ::== ch1_start ch2_start "inner_comment" ch1_end ch2_end);; 6 | ("inner_comment" ::== "" 7 | || ch1_end (¬ch2_end) "inner_comment" 8 | || (¬ch1_end) "inner_comment") 9 | ]]]%grammar. 10 | -------------------------------------------------------------------------------- /src/Common/Tactics/hint_db_extra_plugin.mlg.v810: -------------------------------------------------------------------------------- 1 | { 2 | 3 | open Hint_db_extra_tactics 4 | open Stdarg 5 | open Ltac_plugin 6 | open Tacarg 7 | 8 | } 9 | 10 | DECLARE PLUGIN "hint_db_extra_plugin" 11 | 12 | TACTIC EXTEND foreach_db 13 | | [ "foreach" "[" ne_preident_list(l) "]" "run" tactic(k) ] -> 14 | { WITH_DB.with_hint_db l k } 15 | END 16 | 17 | TACTIC EXTEND addto_db 18 | | [ "add" constr(name) "to" ne_preident_list(l) ] -> 19 | { WITH_DB.add_resolve_to_db (Hints.IsConstr (name, Univ.ContextSet.empty)) l } 20 | END 21 | -------------------------------------------------------------------------------- /src/Common/Tactics/hint_db_extra_plugin.mlg.v811: -------------------------------------------------------------------------------- 1 | { 2 | 3 | open Hint_db_extra_tactics 4 | open Stdarg 5 | open Ltac_plugin 6 | open Tacarg 7 | 8 | } 9 | 10 | DECLARE PLUGIN "hint_db_extra_plugin" 11 | 12 | TACTIC EXTEND foreach_db 13 | | [ "foreach" "[" ne_preident_list(l) "]" "run" tactic(k) ] -> 14 | { WITH_DB.with_hint_db l k } 15 | END 16 | 17 | TACTIC EXTEND addto_db 18 | | [ "add" constr(name) "to" ne_preident_list(l) ] -> 19 | { WITH_DB.add_resolve_to_db (Hints.IsConstr (name, Univ.ContextSet.empty)) l } 20 | END 21 | -------------------------------------------------------------------------------- /src/Common/Tactics/hint_db_extra_plugin.mlg.v812: -------------------------------------------------------------------------------- 1 | { 2 | 3 | open Hint_db_extra_tactics 4 | open Stdarg 5 | open Ltac_plugin 6 | open Tacarg 7 | 8 | } 9 | 10 | DECLARE PLUGIN "hint_db_extra_plugin" 11 | 12 | TACTIC EXTEND foreach_db 13 | | [ "foreach" "[" ne_preident_list(l) "]" "run" tactic(k) ] -> 14 | { WITH_DB.with_hint_db l k } 15 | END 16 | 17 | TACTIC EXTEND addto_db 18 | | [ "add" constr(name) "to" ne_preident_list(l) ] -> 19 | { WITH_DB.add_resolve_to_db (Hints.IsConstr (name, Univ.ContextSet.empty)) l } 20 | END 21 | -------------------------------------------------------------------------------- /src/Common/Tactics/hint_db_extra_plugin.mlg.v816: -------------------------------------------------------------------------------- 1 | { 2 | 3 | open Hint_db_extra_tactics 4 | open Stdarg 5 | open Ltac_plugin 6 | open Tacarg 7 | 8 | } 9 | 10 | DECLARE PLUGIN "coq-fiat-parsers.hint_db_extra_plugin" 11 | 12 | TACTIC EXTEND foreach_db 13 | | [ "foreach" "[" ne_preident_list(l) "]" "run" tactic(k) ] -> 14 | { WITH_DB.with_hint_db l k } 15 | END 16 | 17 | TACTIC EXTEND addto_db 18 | | [ "add" constr(name) "to" ne_preident_list(l) ] -> 19 | { WITH_DB.add_resolve_to_db (Hints.hint_constr (name, None)) l } 20 | END 21 | -------------------------------------------------------------------------------- /src/Common/Tactics/hint_db_extra_plugin.mlg.v817: -------------------------------------------------------------------------------- 1 | { 2 | 3 | open Hint_db_extra_tactics 4 | open Stdarg 5 | open Ltac_plugin 6 | open Tacarg 7 | 8 | } 9 | 10 | DECLARE PLUGIN "coq-fiat-parsers.hint_db_extra_plugin" 11 | 12 | TACTIC EXTEND foreach_db 13 | | [ "foreach" "[" ne_preident_list(l) "]" "run" tactic(k) ] -> 14 | { WITH_DB.with_hint_db l k } 15 | END 16 | 17 | TACTIC EXTEND addto_db 18 | | [ "add" constr(name) "to" ne_preident_list(l) ] -> 19 | { WITH_DB.add_resolve_to_db (Hints.hint_constr (name, None)) l } 20 | END 21 | -------------------------------------------------------------------------------- /src/Common/Tactics/hint_db_extra_plugin.mlg.v818: -------------------------------------------------------------------------------- 1 | { 2 | 3 | open Hint_db_extra_tactics 4 | open Stdarg 5 | open Ltac_plugin 6 | open Tacarg 7 | 8 | } 9 | 10 | DECLARE PLUGIN "coq-fiat-parsers.hint_db_extra_plugin" 11 | 12 | TACTIC EXTEND foreach_db 13 | | [ "foreach" "[" ne_preident_list(l) "]" "run" tactic(k) ] -> 14 | { WITH_DB.with_hint_db l k } 15 | END 16 | 17 | TACTIC EXTEND addto_db 18 | | [ "add" constr(name) "to" ne_preident_list(l) ] -> 19 | { WITH_DB.add_resolve_to_db (Hints.hint_constr (name, None)) l } 20 | END 21 | -------------------------------------------------------------------------------- /src/Narcissus/Formats.v: -------------------------------------------------------------------------------- 1 | Require Export 2 | Fiat.Narcissus.Formats.Empty 3 | Fiat.Narcissus.Formats.Sequence 4 | Fiat.Narcissus.Formats.FixListOpt 5 | Fiat.Narcissus.Formats.Bool 6 | Fiat.Narcissus.Formats.NatOpt 7 | Fiat.Narcissus.Formats.Vector 8 | Fiat.Narcissus.Formats.EnumOpt 9 | Fiat.Narcissus.Formats.SumTypeOpt 10 | Fiat.Narcissus.Formats.IPChecksum 11 | Fiat.Narcissus.Formats.WordOpt 12 | Fiat.Narcissus.Formats.NatOpt 13 | Fiat.Narcissus.Formats.Option. 14 | -------------------------------------------------------------------------------- /src/CertifiedExtraction/Extraction/External/External.v: -------------------------------------------------------------------------------- 1 | Require Export 2 | CertifiedExtraction.Extraction.External.Core 3 | CertifiedExtraction.Extraction.External.Lists 4 | CertifiedExtraction.Extraction.External.Loops 5 | CertifiedExtraction.Extraction.External.FacadeLoops 6 | CertifiedExtraction.Extraction.External.ScalarMethods 7 | CertifiedExtraction.Extraction.External.GenericMethods 8 | CertifiedExtraction.Extraction.External.GenericADTMethods 9 | CertifiedExtraction.Extraction.External.FacadeADTs. 10 | -------------------------------------------------------------------------------- /src/FiniteSetADTs.v: -------------------------------------------------------------------------------- 1 | Require Export Fiat.FiniteSetADTs.FiniteSetADT Fiat.FiniteSetADTs.FiniteSetRefinement. 2 | (** Files to make examples more plesant *) 3 | Require Export Fiat.Computation.Core Fiat.Computation.Notations Fiat.ADTRefinement.GeneralRefinements Fiat.ADTNotation Fiat.ComputationalEnsembles. 4 | (** Re-export this one last, so we get the right [cardinal]. *) 5 | Require Export Fiat.FiniteSetADTs.FiniteSetADT. 6 | 7 | (** We don't care about displaying the implementation argument *) 8 | Arguments FiniteSetOfList {_} _. 9 | 10 | Global Open Scope comp_scope. 11 | -------------------------------------------------------------------------------- /src/Common/Ensembles/Notations.v: -------------------------------------------------------------------------------- 1 | Require Export Coq.Sets.Ensembles. 2 | Require Export Fiat.Common.ReservedNotations. 3 | 4 | Delimit Scope Ensemble_scope with ensemble. 5 | Bind Scope Ensemble_scope with Ensemble. 6 | 7 | Infix "∪" := (Union _) : Ensemble_scope. 8 | Infix "∩" := (Intersection _) : Ensemble_scope. 9 | Infix "\" := (Setminus _) : Ensemble_scope. 10 | Infix "≅" := (Same_set _) : Ensemble_scope. 11 | Notation "x ∈ S" := (In _ S x) : Ensemble_scope. 12 | Notation "{{ x }}" := (Singleton _ x) : Ensemble_scope. 13 | Notation "∅" := (Empty_set _) : Ensemble_scope. 14 | -------------------------------------------------------------------------------- /src/Parsers/Grammars/StringLiteral.v: -------------------------------------------------------------------------------- 1 | (** * Definition of grammar for string literals with backslash (\) escaping double quotes ("") and backslashes *) 2 | Require Import Fiat.Parsers.ContextFreeGrammar.Notations. 3 | 4 | Definition string_grammar : grammar ascii := 5 | [[[ ("string" ::== """" "inner_string" """");; 6 | ("inner_string" ::== "" 7 | || "\" "special_character" "inner_string" 8 | || "unspecial_character" "inner_string");; 9 | ("special_character" ::== ("""" || "\")%char);; 10 | ("unspecial_character" ::== ¬("""" || "\")) 11 | ]]]%grammar. 12 | -------------------------------------------------------------------------------- /src/Parsers/Refinement/DisjointRulesCommon.v: -------------------------------------------------------------------------------- 1 | Require Import Fiat.Common.Tactics.PrintContext. 2 | 3 | Ltac get_hyp_of_shape shape := 4 | lazymatch goal with 5 | | [ H' : shape |- _ ] => H' 6 | | _ => let dummy := match goal with 7 | | _ => idtac "In context:"; 8 | print_context (); 9 | fail 1 "Could not find a hypothesis of shape" shape 10 | "Maybe you forgot to run do_disjoint_precomputations" 11 | end in 12 | constr:(I : I) 13 | end. 14 | -------------------------------------------------------------------------------- /src/Common/ReservedNotations.v: -------------------------------------------------------------------------------- 1 | (** Depend on the compatibility file, so when we switch versions of Coq, all the relevant notations files get rebuilt. *) 2 | Require Export Fiat.Common.Coq__8_4__8_5__Compat. 3 | Global Set Asymmetric Patterns. 4 | 5 | Reserved Infix "∪" (at level 60, right associativity). 6 | Reserved Infix "∩" (at level 60, right associativity). 7 | Reserved Infix "\" (at level 50, left associativity). 8 | Reserved Infix "≅" (at level 70, right associativity). 9 | Reserved Infix "∈" (at level 40, no associativity). 10 | Reserved Notation "{{ x }}". 11 | Reserved Notation "∅". 12 | -------------------------------------------------------------------------------- /src/Examples/FacadeTest.v: -------------------------------------------------------------------------------- 1 | Require Import Bedrock.Platform.Facade. 2 | Require Import AutoDB. 3 | 4 | Definition bedrock_test := 5 | (ret (@Word.wmult 32 6 | (Word.wplus (IL.natToW 3) (IL.natToW 4)) 7 | (Word.wminus (IL.natToW 5) (IL.natToW 6)))). 8 | 9 | Definition facade_test := 10 | ret (SyntaxExpr.Binop 11 | IL.Times 12 | (SyntaxExpr.Var "$1") 13 | (SyntaxExpr.Var "$2")). 14 | 15 | Eval compute in (eval (StringMap.StringMap.empty (Value nat)) (SyntaxExpr.Binop IL.Plus (SyntaxExpr.Const (IL.natToW 3)) (SyntaxExpr.Const (IL.natToW 3)))). 16 | -------------------------------------------------------------------------------- /src/Narcissus/OCamlExtraction/ListVector.ml: -------------------------------------------------------------------------------- 1 | type 'a t = ('a * int) list 2 | let empty () = [] 3 | let cons (hd, n, tl) = (hd, n) :: tl 4 | let destruct fNil fCons = function 5 | | [] -> fNil () 6 | | (h, n) :: t -> fCons h n t 7 | let nth _ ls idx = fst (List.nth ls idx) 8 | let nth_opt _ ls idx = try Some (fst (List.nth ls idx)) with Not_found -> None 9 | let rec ith_loop ils idx = 10 | if idx = 0 then 11 | fst (Obj.magic ils) 12 | else 13 | ith_loop (snd (Obj.magic ils)) (pred idx) 14 | let ith _m _As ils idx = 15 | ith_loop ils idx 16 | let ith2 _m _As ils idx = 17 | ith_loop ils idx 18 | -------------------------------------------------------------------------------- /src/Examples/bedrock_driver.s: -------------------------------------------------------------------------------- 1 | .equ HEAP_SIZE, 100*1024*1024 2 | .equ STACK_OFFSET, 4*HEAP_SIZE 3 | .equ STACK_START, bedrock_heap+STACK_OFFSET 4 | .equ LIST_START, 4 5 | 6 | .globl bedrock_main 7 | bedrock_main: 8 | # Initialize Bedrock stack pointer 9 | movl $STACK_OFFSET, %ebx 10 | 11 | # Set up parameters to entry point 12 | movl $LIST_START, STACK_START+4 13 | movl $0, STACK_START+8 14 | 15 | movl $ret, %esi 16 | jmp export_dffun 17 | ret: 18 | movl %edi, %eax 19 | ret 20 | -------------------------------------------------------------------------------- /src/Narcissus/Examples/NetworkStack/test.ml: -------------------------------------------------------------------------------- 1 | Printexc.record_backtrace true;; 2 | 3 | #thread;; 4 | #require "core.top";; 5 | #require "async";; 6 | #require "core_bench";; 7 | 8 | #load "ArrayVector.cmo";; 9 | #load "Int64Word.cmo";; 10 | #load "OcamlNativeInt.cmo";; 11 | #use "debug.ml";; 12 | 13 | (* open Core.Std;; 14 | * open Core_bench.Std;; 15 | * 16 | * let () = 17 | * Command.run (Bench.make_command [ 18 | * Bench.Test.create ~name:"id" 19 | * (fun () -> ()); 20 | * Bench.Test.create ~name:"fiat_ipv4_decode" 21 | * (fun () -> ignore (fiat_ipv4_decode (Array.length bin_pkt) bin_pkt)); 22 | * ]);; *) 23 | -------------------------------------------------------------------------------- /src/Common/Tactics/transparent_abstract_plugin.ml4.v84: -------------------------------------------------------------------------------- 1 | open Transparent_abstract_tactics 2 | 3 | TACTIC EXTEND abstracttermas 4 | | [ "cache_term" constr(term) "as" ident(name) "run" tactic(tacK)] -> 5 | [ fun gl -> TRANSPARENT_ABSTRACT.tclABSTRACTTERM (Some name) term tacK gl ] 6 | END 7 | 8 | TACTIC EXTEND abstractterm 9 | | [ "cache_term" constr(term) "run" tactic(tacK) ] -> 10 | [ fun gl -> TRANSPARENT_ABSTRACT.tclABSTRACTTERM None term tacK gl ] 11 | END 12 | 13 | TACTIC EXTEND transparentabstract 14 | | [ "cache" tactic(tac) "as" ident(name)] -> 15 | [ fun gl -> TRANSPARENT_ABSTRACT.tclABSTRACT2 (Some name) tac gl ] 16 | END;; 17 | -------------------------------------------------------------------------------- /src/Parsers/Grammars/ABStar.v: -------------------------------------------------------------------------------- 1 | (** * Definition of grammar for regular expression [(ab)*] *) 2 | Require Import Fiat.Parsers.ContextFreeGrammar.Notations. 3 | 4 | Definition ab_star_pregrammar : pregrammar ascii := 5 | [[[ "(ab)*" ::== "" || "a" "b" "(ab)*" ]]]%grammar. 6 | 7 | Definition ab_star_grammar : grammar ascii := Eval cbv [ab_star_pregrammar] in ab_star_pregrammar. 8 | 9 | Local Open Scope list_scope. 10 | 11 | Definition ab_star_grammar' : grammar ascii := 12 | {| Start_symbol := "(ab)*"; 13 | Lookup := fun _ => nil::((Terminal (Equality.ascii_beq "a"%char))::(Terminal (Equality.ascii_beq "b"%char))::(NonTerminal "(ab)*"%string)::nil)::nil; 14 | Valid_nonterminals := ("(ab)*"::nil)%string |}. 15 | -------------------------------------------------------------------------------- /src/Computation/SetoidEqMorphisms.v: -------------------------------------------------------------------------------- 1 | Require Import Coq.Classes.Morphisms. 2 | Require Import Fiat.Computation.Core. 3 | 4 | Global Instance ret_Proper_eq {A} 5 | : Proper (eq ==> eq) (ret (A:=A)). 6 | Proof. repeat intro; subst; reflexivity. Qed. 7 | Global Instance refine_Proper_eq_iff {A} 8 | : Proper (eq ==> eq ==> iff) (@refine A). 9 | Proof. repeat intro; subst; reflexivity. Qed. 10 | Global Instance refine_Proper_eq_impl {A} 11 | : Proper (eq ==> eq ==> Basics.impl) (@refine A) | 1. 12 | Proof. repeat (assumption || subst || intro). Qed. 13 | Global Instance refine_Proper_eq_flip_impl {A} 14 | : Proper (eq ==> eq ==> Basics.flip Basics.impl) (@refine A) | 1. 15 | Proof. repeat (assumption || subst || intro). Qed. 16 | -------------------------------------------------------------------------------- /src/Common/Tactics/transparent_abstract_plugin.ml4.v87: -------------------------------------------------------------------------------- 1 | open Transparent_abstract_tactics 2 | open Stdarg 3 | open Ltac_plugin 4 | open Tacarg 5 | 6 | DECLARE PLUGIN "transparent_abstract_plugin" 7 | 8 | TACTIC EXTEND transparentabstract 9 | | [ "cache" tactic(tac) "as" ident(name)] 10 | -> [ TRANSPARENT_ABSTRACT.tclTRABSTRACT (Some name) (Tacinterp.tactic_of_value ist tac) ] 11 | END 12 | 13 | TACTIC EXTEND abstracttermas 14 | | [ "cache_term" constr(term) "as" ident(name) "run" tactic(tacK)] -> 15 | [ TRANSPARENT_ABSTRACT.tclABSTRACTTERM (Some name) term tacK ] 16 | END 17 | 18 | TACTIC EXTEND abstractterm 19 | | [ "cache_term" constr(term) "run" tactic(tacK) ] -> 20 | [ TRANSPARENT_ABSTRACT.tclABSTRACTTERM None term tacK ] 21 | END;; 22 | -------------------------------------------------------------------------------- /src/Common/Tactics/transparent_abstract_plugin.ml4.v88: -------------------------------------------------------------------------------- 1 | open Transparent_abstract_tactics 2 | open Stdarg 3 | open Ltac_plugin 4 | open Tacarg 5 | 6 | DECLARE PLUGIN "transparent_abstract_plugin" 7 | 8 | TACTIC EXTEND transparentabstract 9 | | [ "cache" tactic(tac) "as" ident(name)] 10 | -> [ TRANSPARENT_ABSTRACT.tclTRABSTRACT (Some name) (Tacinterp.tactic_of_value ist tac) ] 11 | END 12 | 13 | TACTIC EXTEND abstracttermas 14 | | [ "cache_term" constr(term) "as" ident(name) "run" tactic(tacK)] -> 15 | [ TRANSPARENT_ABSTRACT.tclABSTRACTTERM (Some name) term tacK ] 16 | END 17 | 18 | TACTIC EXTEND abstractterm 19 | | [ "cache_term" constr(term) "run" tactic(tacK) ] -> 20 | [ TRANSPARENT_ABSTRACT.tclABSTRACTTERM None term tacK ] 21 | END;; 22 | -------------------------------------------------------------------------------- /src/Common/Tactics/transparent_abstract_plugin.ml4.v89: -------------------------------------------------------------------------------- 1 | open Transparent_abstract_tactics 2 | open Stdarg 3 | open Ltac_plugin 4 | open Tacarg 5 | 6 | DECLARE PLUGIN "transparent_abstract_plugin" 7 | 8 | TACTIC EXTEND transparentabstract 9 | | [ "cache" tactic(tac) "as" ident(name)] 10 | -> [ TRANSPARENT_ABSTRACT.tclTRABSTRACT (Some name) (Tacinterp.tactic_of_value ist tac) ] 11 | END 12 | 13 | TACTIC EXTEND abstracttermas 14 | | [ "cache_term" constr(term) "as" ident(name) "run" tactic(tacK)] -> 15 | [ TRANSPARENT_ABSTRACT.tclABSTRACTTERM (Some name) term tacK ] 16 | END 17 | 18 | TACTIC EXTEND abstractterm 19 | | [ "cache_term" constr(term) "run" tactic(tacK) ] -> 20 | [ TRANSPARENT_ABSTRACT.tclABSTRACTTERM None term tacK ] 21 | END;; 22 | -------------------------------------------------------------------------------- /src/Common/Tactics/transparent_abstract_plugin.mlg.v810: -------------------------------------------------------------------------------- 1 | { 2 | 3 | open Transparent_abstract_tactics 4 | open Stdarg 5 | open Ltac_plugin 6 | open Tacarg 7 | 8 | } 9 | 10 | DECLARE PLUGIN "transparent_abstract_plugin" 11 | 12 | TACTIC EXTEND transparentabstract 13 | | [ "cache" tactic(tac) "as" ident(name)] 14 | -> { TRANSPARENT_ABSTRACT.tclTRABSTRACT (Some name) (Tacinterp.tactic_of_value ist tac) } 15 | END 16 | 17 | TACTIC EXTEND abstracttermas 18 | | [ "cache_term" constr(term) "as" ident(name) "run" tactic(tacK)] -> 19 | { TRANSPARENT_ABSTRACT.tclABSTRACTTERM (Some name) term tacK } 20 | END 21 | 22 | TACTIC EXTEND abstractterm 23 | | [ "cache_term" constr(term) "run" tactic(tacK) ] -> 24 | { TRANSPARENT_ABSTRACT.tclABSTRACTTERM None term tacK } 25 | END 26 | -------------------------------------------------------------------------------- /src/Common/Tactics/transparent_abstract_plugin.mlg.v811: -------------------------------------------------------------------------------- 1 | { 2 | 3 | open Transparent_abstract_tactics 4 | open Stdarg 5 | open Ltac_plugin 6 | open Tacarg 7 | 8 | } 9 | 10 | DECLARE PLUGIN "transparent_abstract_plugin" 11 | 12 | TACTIC EXTEND transparentabstract 13 | | [ "cache" tactic(tac) "as" ident(name)] 14 | -> { TRANSPARENT_ABSTRACT.tclTRABSTRACT (Some name) (Tacinterp.tactic_of_value ist tac) } 15 | END 16 | 17 | TACTIC EXTEND abstracttermas 18 | | [ "cache_term" constr(term) "as" ident(name) "run" tactic(tacK)] -> 19 | { TRANSPARENT_ABSTRACT.tclABSTRACTTERM (Some name) term tacK } 20 | END 21 | 22 | TACTIC EXTEND abstractterm 23 | | [ "cache_term" constr(term) "run" tactic(tacK) ] -> 24 | { TRANSPARENT_ABSTRACT.tclABSTRACTTERM None term tacK } 25 | END 26 | -------------------------------------------------------------------------------- /src/Common/Tactics/transparent_abstract_plugin.mlg.v812: -------------------------------------------------------------------------------- 1 | { 2 | 3 | open Transparent_abstract_tactics 4 | open Stdarg 5 | open Ltac_plugin 6 | open Tacarg 7 | 8 | } 9 | 10 | DECLARE PLUGIN "transparent_abstract_plugin" 11 | 12 | TACTIC EXTEND transparentabstract 13 | | [ "cache" tactic(tac) "as" ident(name)] 14 | -> { TRANSPARENT_ABSTRACT.tclTRABSTRACT (Some name) (Tacinterp.tactic_of_value ist tac) } 15 | END 16 | 17 | TACTIC EXTEND abstracttermas 18 | | [ "cache_term" constr(term) "as" ident(name) "run" tactic(tacK)] -> 19 | { TRANSPARENT_ABSTRACT.tclABSTRACTTERM (Some name) term tacK } 20 | END 21 | 22 | TACTIC EXTEND abstractterm 23 | | [ "cache_term" constr(term) "run" tactic(tacK) ] -> 24 | { TRANSPARENT_ABSTRACT.tclABSTRACTTERM None term tacK } 25 | END 26 | -------------------------------------------------------------------------------- /src/Common/Tactics/transparent_abstract_plugin.mlg.v813: -------------------------------------------------------------------------------- 1 | { 2 | 3 | open Transparent_abstract_tactics 4 | open Stdarg 5 | open Ltac_plugin 6 | open Tacarg 7 | 8 | } 9 | 10 | DECLARE PLUGIN "transparent_abstract_plugin" 11 | 12 | TACTIC EXTEND transparentabstract 13 | | [ "cache" tactic(tac) "as" ident(name)] 14 | -> { TRANSPARENT_ABSTRACT.tclTRABSTRACT (Some name) (Tacinterp.tactic_of_value ist tac) } 15 | END 16 | 17 | TACTIC EXTEND abstracttermas 18 | | [ "cache_term" constr(term) "as" ident(name) "run" tactic(tacK)] -> 19 | { TRANSPARENT_ABSTRACT.tclABSTRACTTERM (Some name) term tacK } 20 | END 21 | 22 | TACTIC EXTEND abstractterm 23 | | [ "cache_term" constr(term) "run" tactic(tacK) ] -> 24 | { TRANSPARENT_ABSTRACT.tclABSTRACTTERM None term tacK } 25 | END 26 | -------------------------------------------------------------------------------- /src/Common/Tactics/transparent_abstract_plugin.mlg.v814: -------------------------------------------------------------------------------- 1 | { 2 | 3 | open Transparent_abstract_tactics 4 | open Stdarg 5 | open Ltac_plugin 6 | open Tacarg 7 | 8 | } 9 | 10 | DECLARE PLUGIN "transparent_abstract_plugin" 11 | 12 | TACTIC EXTEND transparentabstract 13 | | [ "cache" tactic(tac) "as" ident(name)] 14 | -> { TRANSPARENT_ABSTRACT.tclTRABSTRACT (Some name) (Tacinterp.tactic_of_value ist tac) } 15 | END 16 | 17 | TACTIC EXTEND abstracttermas 18 | | [ "cache_term" constr(term) "as" ident(name) "run" tactic(tacK)] -> 19 | { TRANSPARENT_ABSTRACT.tclABSTRACTTERM (Some name) term tacK } 20 | END 21 | 22 | TACTIC EXTEND abstractterm 23 | | [ "cache_term" constr(term) "run" tactic(tacK) ] -> 24 | { TRANSPARENT_ABSTRACT.tclABSTRACTTERM None term tacK } 25 | END 26 | -------------------------------------------------------------------------------- /src/Common/Tactics/transparent_abstract_plugin.mlg.v815: -------------------------------------------------------------------------------- 1 | { 2 | 3 | open Transparent_abstract_tactics 4 | open Stdarg 5 | open Ltac_plugin 6 | open Tacarg 7 | 8 | } 9 | 10 | DECLARE PLUGIN "transparent_abstract_plugin" 11 | 12 | TACTIC EXTEND transparentabstract 13 | | [ "cache" tactic(tac) "as" ident(name)] 14 | -> { TRANSPARENT_ABSTRACT.tclTRABSTRACT (Some name) (Tacinterp.tactic_of_value ist tac) } 15 | END 16 | 17 | TACTIC EXTEND abstracttermas 18 | | [ "cache_term" constr(term) "as" ident(name) "run" tactic(tacK)] -> 19 | { TRANSPARENT_ABSTRACT.tclABSTRACTTERM (Some name) term tacK } 20 | END 21 | 22 | TACTIC EXTEND abstractterm 23 | | [ "cache_term" constr(term) "run" tactic(tacK) ] -> 24 | { TRANSPARENT_ABSTRACT.tclABSTRACTTERM None term tacK } 25 | END 26 | -------------------------------------------------------------------------------- /src/ADT/Core.v: -------------------------------------------------------------------------------- 1 | Require Export Fiat.Common Fiat.Computation Fiat.ADT.ADTSig. 2 | Require Import Coq.Sets.Ensembles. 3 | 4 | Generalizable All Variables. 5 | Set Implicit Arguments. 6 | 7 | (** Basic ADT definitions *) 8 | 9 | (** Interface of an ADT *) 10 | Record ADT (Sig : ADTSig) := 11 | { 12 | (** The representation type of the ADT **) 13 | Rep : Type; 14 | 15 | (** Constructor implementations *) 16 | Constructors : 17 | forall idx : ConstructorIndex Sig, 18 | constructorType Rep (ConstructorDom Sig idx); 19 | 20 | (** Method implementations *) 21 | Methods : 22 | forall idx : MethodIndex Sig, 23 | methodType Rep (fst (MethodDomCod Sig idx)) 24 | (snd (MethodDomCod Sig idx)) 25 | 26 | }. 27 | -------------------------------------------------------------------------------- /src/Narcissus/Examples/NetworkStack/bench.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env sh 2 | ocamlopt -config 3 | cp ../../../../Fiat4Mirage.ml ./ || exit 1 4 | rm -f Fiat4Mirage.mli 5 | ocamlfind ocamlopt -g -p -linkpkg -thread -package cstruct -package core -package core_bench \ 6 | -I ../../OCamlExtraction/ \ 7 | ../../OCamlExtraction/Int64Word.ml \ 8 | ../../OCamlExtraction/ArrayVector.ml \ 9 | ../../OCamlExtraction/StackVector.ml \ 10 | ../../OCamlExtraction/CstructBytestring.ml \ 11 | ../../OCamlExtraction/OCamlNativeInt.ml \ 12 | Fiat4Mirage.ml \ 13 | bench.ml \ 14 | -o fiat4mirage-bench || exit 1 15 | time ./fiat4mirage-bench -width 2000 -quota 5 -ci-absolute +time 16 | #short, tall, line, blank or column 17 | -------------------------------------------------------------------------------- /src/Common/Tactics/transparent_abstract_plugin.mlg.v816: -------------------------------------------------------------------------------- 1 | { 2 | 3 | open Transparent_abstract_tactics 4 | open Stdarg 5 | open Ltac_plugin 6 | open Tacarg 7 | 8 | } 9 | 10 | DECLARE PLUGIN "coq-fiat-parsers.transparent_abstract_plugin" 11 | 12 | TACTIC EXTEND transparentabstract 13 | | [ "cache" tactic(tac) "as" ident(name)] 14 | -> { TRANSPARENT_ABSTRACT.tclTRABSTRACT (Some name) (Tacinterp.tactic_of_value ist tac) } 15 | END 16 | 17 | TACTIC EXTEND abstracttermas 18 | | [ "cache_term" constr(term) "as" ident(name) "run" tactic(tacK)] -> 19 | { TRANSPARENT_ABSTRACT.tclABSTRACTTERM (Some name) term tacK } 20 | END 21 | 22 | TACTIC EXTEND abstractterm 23 | | [ "cache_term" constr(term) "run" tactic(tacK) ] -> 24 | { TRANSPARENT_ABSTRACT.tclABSTRACTTERM None term tacK } 25 | END 26 | -------------------------------------------------------------------------------- /src/Common/Tactics/transparent_abstract_plugin.mlg.v817: -------------------------------------------------------------------------------- 1 | { 2 | 3 | open Transparent_abstract_tactics 4 | open Stdarg 5 | open Ltac_plugin 6 | open Tacarg 7 | 8 | } 9 | 10 | DECLARE PLUGIN "coq-fiat-parsers.transparent_abstract_plugin" 11 | 12 | TACTIC EXTEND transparentabstract 13 | | [ "cache" tactic(tac) "as" ident(name)] 14 | -> { TRANSPARENT_ABSTRACT.tclTRABSTRACT (Some name) (Tacinterp.tactic_of_value ist tac) } 15 | END 16 | 17 | TACTIC EXTEND abstracttermas 18 | | [ "cache_term" constr(term) "as" ident(name) "run" tactic(tacK)] -> 19 | { TRANSPARENT_ABSTRACT.tclABSTRACTTERM (Some name) term tacK } 20 | END 21 | 22 | TACTIC EXTEND abstractterm 23 | | [ "cache_term" constr(term) "run" tactic(tacK) ] -> 24 | { TRANSPARENT_ABSTRACT.tclABSTRACTTERM None term tacK } 25 | END 26 | -------------------------------------------------------------------------------- /src/Common/Tactics/transparent_abstract_plugin.mlg.v818: -------------------------------------------------------------------------------- 1 | { 2 | 3 | open Transparent_abstract_tactics 4 | open Stdarg 5 | open Ltac_plugin 6 | open Tacarg 7 | 8 | } 9 | 10 | DECLARE PLUGIN "coq-fiat-parsers.transparent_abstract_plugin" 11 | 12 | TACTIC EXTEND transparentabstract 13 | | [ "cache" tactic(tac) "as" ident(name)] 14 | -> { TRANSPARENT_ABSTRACT.tclTRABSTRACT (Some name) (Tacinterp.tactic_of_value ist tac) } 15 | END 16 | 17 | TACTIC EXTEND abstracttermas 18 | | [ "cache_term" constr(term) "as" ident(name) "run" tactic(tacK)] -> 19 | { TRANSPARENT_ABSTRACT.tclABSTRACTTERM (Some name) term tacK } 20 | END 21 | 22 | TACTIC EXTEND abstractterm 23 | | [ "cache_term" constr(term) "run" tactic(tacK) ] -> 24 | { TRANSPARENT_ABSTRACT.tclABSTRACTTERM None term tacK } 25 | END 26 | -------------------------------------------------------------------------------- /src/Common/Tactics/transparent_abstract_plugin.mlg.v819: -------------------------------------------------------------------------------- 1 | { 2 | 3 | open Transparent_abstract_tactics 4 | open Stdarg 5 | open Ltac_plugin 6 | open Tacarg 7 | 8 | } 9 | 10 | DECLARE PLUGIN "coq-fiat-parsers.transparent_abstract_plugin" 11 | 12 | TACTIC EXTEND transparentabstract 13 | | [ "cache" tactic(tac) "as" ident(name)] 14 | -> { TRANSPARENT_ABSTRACT.tclTRABSTRACT (Some name) (Tacinterp.tactic_of_value ist tac) } 15 | END 16 | 17 | TACTIC EXTEND abstracttermas 18 | | [ "cache_term" constr(term) "as" ident(name) "run" tactic(tacK)] -> 19 | { TRANSPARENT_ABSTRACT.tclABSTRACTTERM (Some name) term tacK } 20 | END 21 | 22 | TACTIC EXTEND abstractterm 23 | | [ "cache_term" constr(term) "run" tactic(tacK) ] -> 24 | { TRANSPARENT_ABSTRACT.tclABSTRACTTERM None term tacK } 25 | END 26 | -------------------------------------------------------------------------------- /src/Common/Tactics/transparent_abstract_plugin.mlg.v820: -------------------------------------------------------------------------------- 1 | { 2 | 3 | open Transparent_abstract_tactics 4 | open Stdarg 5 | open Ltac_plugin 6 | open Tacarg 7 | 8 | } 9 | 10 | DECLARE PLUGIN "coq-fiat-parsers.transparent_abstract_plugin" 11 | 12 | TACTIC EXTEND transparentabstract 13 | | [ "cache" tactic(tac) "as" ident(name)] 14 | -> { TRANSPARENT_ABSTRACT.tclTRABSTRACT (Some name) (Tacinterp.tactic_of_value ist tac) } 15 | END 16 | 17 | TACTIC EXTEND abstracttermas 18 | | [ "cache_term" constr(term) "as" ident(name) "run" tactic(tacK)] -> 19 | { TRANSPARENT_ABSTRACT.tclABSTRACTTERM (Some name) term tacK } 20 | END 21 | 22 | TACTIC EXTEND abstractterm 23 | | [ "cache_term" constr(term) "run" tactic(tacK) ] -> 24 | { TRANSPARENT_ABSTRACT.tclABSTRACTTERM None term tacK } 25 | END 26 | -------------------------------------------------------------------------------- /src/Common/Tactics/transparent_abstract_plugin.mlg.v90: -------------------------------------------------------------------------------- 1 | { 2 | 3 | open Transparent_abstract_tactics 4 | open Stdarg 5 | open Ltac_plugin 6 | open Tacarg 7 | 8 | } 9 | 10 | DECLARE PLUGIN "coq-fiat-parsers.transparent_abstract_plugin" 11 | 12 | TACTIC EXTEND transparentabstract 13 | | [ "cache" tactic(tac) "as" ident(name)] 14 | -> { TRANSPARENT_ABSTRACT.tclTRABSTRACT (Some name) (Tacinterp.tactic_of_value ist tac) } 15 | END 16 | 17 | TACTIC EXTEND abstracttermas 18 | | [ "cache_term" constr(term) "as" ident(name) "run" tactic(tacK)] -> 19 | { TRANSPARENT_ABSTRACT.tclABSTRACTTERM (Some name) term tacK } 20 | END 21 | 22 | TACTIC EXTEND abstractterm 23 | | [ "cache_term" constr(term) "run" tactic(tacK) ] -> 24 | { TRANSPARENT_ABSTRACT.tclABSTRACTTERM None term tacK } 25 | END 26 | -------------------------------------------------------------------------------- /src/Common/Tactics/transparent_abstract_plugin.mlg.v91: -------------------------------------------------------------------------------- 1 | { 2 | 3 | open Transparent_abstract_tactics 4 | open Stdarg 5 | open Ltac_plugin 6 | open Tacarg 7 | 8 | } 9 | 10 | DECLARE PLUGIN "coq-fiat-parsers.transparent_abstract_plugin" 11 | 12 | TACTIC EXTEND transparentabstract 13 | | [ "cache" tactic(tac) "as" ident(name)] 14 | -> { TRANSPARENT_ABSTRACT.tclTRABSTRACT (Some name) (Tacinterp.tactic_of_value ist tac) } 15 | END 16 | 17 | TACTIC EXTEND abstracttermas 18 | | [ "cache_term" constr(term) "as" ident(name) "run" tactic(tacK)] -> 19 | { TRANSPARENT_ABSTRACT.tclABSTRACTTERM (Some name) term tacK } 20 | END 21 | 22 | TACTIC EXTEND abstractterm 23 | | [ "cache_term" constr(term) "run" tactic(tacK) ] -> 24 | { TRANSPARENT_ABSTRACT.tclABSTRACTTERM None term tacK } 25 | END 26 | -------------------------------------------------------------------------------- /src/Common/Tactics/transparent_abstract_plugin.mlg.v92: -------------------------------------------------------------------------------- 1 | { 2 | 3 | open Transparent_abstract_tactics 4 | open Stdarg 5 | open Ltac_plugin 6 | open Tacarg 7 | 8 | } 9 | 10 | DECLARE PLUGIN "coq-fiat-parsers.transparent_abstract_plugin" 11 | 12 | TACTIC EXTEND transparentabstract 13 | | [ "cache" tactic(tac) "as" ident(name)] 14 | -> { TRANSPARENT_ABSTRACT.tclTRABSTRACT (Some name) (Tacinterp.tactic_of_value ist tac) } 15 | END 16 | 17 | TACTIC EXTEND abstracttermas 18 | | [ "cache_term" constr(term) "as" ident(name) "run" tactic(tacK)] -> 19 | { TRANSPARENT_ABSTRACT.tclABSTRACTTERM (Some name) term tacK } 20 | END 21 | 22 | TACTIC EXTEND abstractterm 23 | | [ "cache_term" constr(term) "run" tactic(tacK) ] -> 24 | { TRANSPARENT_ABSTRACT.tclABSTRACTTERM None term tacK } 25 | END 26 | -------------------------------------------------------------------------------- /src/Common/StringOperations.v: -------------------------------------------------------------------------------- 1 | Require Import Coq.Strings.String Coq.Lists.List. 2 | Require Export Fiat.Common.Coq__8_4__8_5__Compat. 3 | 4 | Set Implicit Arguments. 5 | 6 | Local Open Scope list_scope. 7 | Local Open Scope string_scope. 8 | 9 | Fixpoint list_of_string (s : string) : list Ascii.ascii 10 | := match s with 11 | | "" => nil 12 | | String ch s' => ch :: list_of_string s' 13 | end. 14 | 15 | Fixpoint string_of_list (ls : list Ascii.ascii) : string 16 | := match ls with 17 | | nil => "" 18 | | ch :: ls' => String ch (string_of_list ls') 19 | end. 20 | 21 | Fixpoint string_copy (n : nat) (ch : Ascii.ascii) 22 | := match n with 23 | | 0 => EmptyString 24 | | S n' => String.String ch (string_copy n' ch) 25 | end. 26 | -------------------------------------------------------------------------------- /META.coq-fiat-parsers: -------------------------------------------------------------------------------- 1 | package "hint_db_extra_plugin" ( 2 | description = "Coq Hint Db Extra Plugin" 3 | requires = "coq-core.plugins.ltac" 4 | archive(byte) = "hint_db_extra_plugin.cma" 5 | archive(native) = "hint_db_extra_plugin.cmxa" 6 | plugin(byte) = "hint_db_extra_plugin.cma" 7 | plugin(native) = "hint_db_extra_plugin.cmxs" 8 | directory = "src/Common/Tactics" 9 | ) 10 | package "transparent_abstract_plugin" ( 11 | description = "Coq Transparent Abstract Plugin" 12 | requires = "coq-core.plugins.ltac" 13 | archive(byte) = "transparent_abstract_plugin.cma" 14 | archive(native) = "transparent_abstract_plugin.cmxa" 15 | plugin(byte) = "transparent_abstract_plugin.cma" 16 | plugin(native) = "transparent_abstract_plugin.cmxs" 17 | directory = "src/Common/Tactics" 18 | ) 19 | directory = "." -------------------------------------------------------------------------------- /src/Parsers/Reflective/ParserPartialUnfold.v: -------------------------------------------------------------------------------- 1 | Require Import Fiat.Parsers.Reflective.Syntax Fiat.Parsers.Reflective.ParserSyntax. 2 | Require Import Fiat.Parsers.Reflective.PartialUnfold. 3 | 4 | Section normalization_by_evaluation. 5 | Context (var : TypeCode -> Type). 6 | 7 | Definition pnormalize {T} (term : has_parse_term (normalized_of var) T) : has_parse_term var T 8 | := match term with 9 | | RFix2 G_length up_to_G_length f default valid_len valids nt_idx 10 | => RFix2 G_length up_to_G_length 11 | (normalize f) 12 | (normalize default) 13 | valid_len valids nt_idx 14 | end. 15 | End normalization_by_evaluation. 16 | 17 | Definition polypnormalize {T} (term : polyhas_parse_term T) : polyhas_parse_term T 18 | := fun var => pnormalize (term _). 19 | -------------------------------------------------------------------------------- /src/Common/Ensembles/Equivalence.v: -------------------------------------------------------------------------------- 1 | Require Export Coq.Sets.Ensembles. 2 | Require Import Fiat.Common. 3 | 4 | Set Implicit Arguments. 5 | 6 | Global Instance Same_set_refl {T} : Reflexive (Same_set T). 7 | Proof. 8 | repeat (intro || split); auto. 9 | Qed. 10 | 11 | Global Instance Same_set_sym {T} : Symmetric (Same_set T). 12 | Proof. 13 | repeat (intro || split); destruct_head_hnf and; eauto. 14 | Qed. 15 | 16 | Global Instance Same_set_trans {T} : Transitive (Same_set T). 17 | Proof. 18 | repeat (intro || split); destruct_head_hnf and; eauto. 19 | Qed. 20 | 21 | Global Instance Included_refl {T} : Reflexive (Included T). 22 | Proof. 23 | repeat (intro || split); auto. 24 | Qed. 25 | 26 | Global Instance Included_trans {T} : Transitive (Included T). 27 | Proof. 28 | repeat (intro || split); destruct_head_hnf and; eauto. 29 | Qed. 30 | -------------------------------------------------------------------------------- /src/Parsers/ContextFreeGrammar/Fix/Inject.v: -------------------------------------------------------------------------------- 1 | Require Import Fiat.Parsers.ContextFreeGrammar.Fix.Definitions. 2 | 3 | Set Implicit Arguments. 4 | 5 | Global Instance inject_fixedpoint_lattice {prestate} {fpldata : grammar_fixedpoint_lattice_data prestate} 6 | : grammar_fixedpoint_lattice_data state 7 | := { prestate_lt := state_lt; 8 | prestate_beq := state_beq; 9 | prestate_beq_Equivalence := state_beq_Equivalence; 10 | preleast_upper_bound x y := constant (least_upper_bound x y); 11 | preleast_upper_bound_correct_l := least_upper_bound_correct_l; 12 | preleast_upper_bound_correct_r := least_upper_bound_correct_r; 13 | prestate_gt_wf := state_gt_wf; 14 | preleast_upper_bound_Proper := least_upper_bound_Proper; 15 | prestate_lt_Proper := state_lt_Proper; 16 | prestate_lt_Transitive := state_lt_Transitive }. 17 | -------------------------------------------------------------------------------- /src/Computation/Notations.v: -------------------------------------------------------------------------------- 1 | Require Export Fiat.Common.Coq__8_4__8_5__Compat. 2 | Reserved Notation "x >>= y" (at level 42, right associativity). 3 | (*Reserved Notation "x <- y ; z" (at level 42, right associativity). 4 | Reserved Notation "x ;; z" (at level 42, right associativity).*) 5 | Reserved Infix "↝" (at level 70). 6 | Reserved Notation "⟦ x 'in' xs | P ⟧" (at level 70). 7 | 8 | Reserved Notation "x <- y ; z" 9 | (at level 81, right associativity, 10 | format "'[v' x <- y ; '/' z ']'"). 11 | 12 | Reserved Notation "`( a , b ) <- c ; k" 13 | (at level 81, right associativity, 14 | format "'[v' `( a , b ) <- c ; '/' k ']'"). 15 | 16 | Reserved Notation "`( a , b , c ) <- d ; k" 17 | (at level 81, right associativity, 18 | format "'[v' `( a , b , c ) <- d ; '/' k ']'"). 19 | 20 | Delimit Scope comp_scope with comp. 21 | -------------------------------------------------------------------------------- /src/Narcissus/Examples/NetworkStack/benchmarks/microbenchmarks.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env sh 2 | date 3 | ocamlopt -config 4 | ./gen.py 5 | cd .. 6 | cp ../../../../Fiat4Mirage* ./ 7 | rm -f Fiat4Mirage.mli 8 | ocamlfind ocamlopt -linkpkg -thread -package cstruct -package core -package core_bench \ 9 | -I ../../OCamlExtraction \ 10 | ../../OCamlExtraction/Int64Word.ml \ 11 | ../../OCamlExtraction/ArrayVector.ml \ 12 | ../../OCamlExtraction/StackVector.ml \ 13 | ../../OCamlExtraction/CstructBytestring.ml \ 14 | ../../OCamlExtraction/OCamlNativeInt.ml \ 15 | Fiat4Mirage.ml \ 16 | benchmarks/microbenchmarks.ml \ 17 | -o microbenchmarks || exit 1 18 | ./microbenchmarks -sexp -save -quota 60 -width 2000 -ci-absolute +time | tee microbenchmarks.out 19 | mkdir -p benchmarks/outputs 20 | mv ./*.txt benchmarks/outputs 21 | -------------------------------------------------------------------------------- /src/Computation/Refinements/Tactics.v: -------------------------------------------------------------------------------- 1 | Require Import Fiat.Common. 2 | Require Import Fiat.Computation.Core. 3 | 4 | Ltac t_refine' := 5 | first [ progress simpl in * 6 | | progress unfold impl in * 7 | | progress eauto 8 | | eassumption 9 | | solve [ apply reflexivity ] (* [reflexivity] is broken in the presence of a [Reflexive pointwise_relation] instance.... see https://coq.inria.fr/bugs/show_bug.cgi?id=3257. Also https://coq.inria.fr/bugs/show_bug.cgi?id=3265 *) 10 | | progress split_iff 11 | | progress computes_to_inv 12 | | progress subst 13 | | intro 14 | | progress destruct_head_hnf prod 15 | | progress destruct_head_hnf and 16 | | progress destruct_head_hnf sig 17 | | econstructor 18 | | computes_to_econstructor 19 | | progress specialize_all_ways ]. 20 | 21 | Ltac t_refine := repeat t_refine'. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Fiat − Deductive Synthesis of Abstract Data Types in a Proof Assistant 2 | ====================================================================== 3 | 4 | This repository holds the source code of Fiat, a Coq ADT synthesis 5 | library. 6 | 7 | This library is now mostly unmaintained; only targets `fiat-core parsers 8 | parsers-examples` are maintained for Coq's CI. 9 | 10 | ## Dependencies: 11 | * To build the library: Coq 8.4pl6 (use branch [v8.4](https://github.com/mit-plv/fiat/tree/v8.4)), Coq >= 8.16 (only `fiat-core parsers parsers-examples`) 12 | * To step through the examples: GNU Emacs 24.3+, Proof General 4.4+ 13 | * To extract and run OCaml code: OCaml 4.02.0+ 14 | 15 | ## Compiling and running the code 16 | * To build the core library: `make fiat-core` 17 | * To build the SQL-like libary: `make querystructures` (no longer builds) 18 | * To build the parsers libary: `make parsers` 19 | -------------------------------------------------------------------------------- /src/Fiat4Monitors/RADL_Topics.v: -------------------------------------------------------------------------------- 1 | Require Import 2 | Coq.Strings.String 3 | Coq.Bool.Bool 4 | Coq.Lists.List 5 | Coq.Arith.Arith 6 | Coq.Program.Program 7 | Fiat.ADT 8 | Fiat.ADT.ComputationalADT 9 | Fiat.ADTNotation 10 | Fiat.ADTRefinement 11 | Fiat.ADTRefinement.BuildADTRefinements. 12 | 13 | Section Topics. 14 | 15 | Record RADL_Topic := 16 | { Topic_Name : string; 17 | Topic_Type : Type }. 18 | 19 | Context {n : nat}. 20 | Variable TopicTypes : Vector.t Type n. (* List of Topics in the Network. *) 21 | Variable TopicNames : Vector.t string n. (* List of Topics IDs in the Network. *) 22 | Definition TopicID := Fin.t n. 23 | 24 | Definition GetTopicName (topic : TopicID) : string := Vector.nth TopicNames topic. 25 | 26 | Definition GetTopicType (topic : TopicID) : Type := Vector.nth TopicTypes topic. 27 | 28 | End Topics. 29 | -------------------------------------------------------------------------------- /src/Parsers/ParserInterfaceReflective.v: -------------------------------------------------------------------------------- 1 | (** * Simply-typed reflective interface of the parser *) 2 | Require Import Fiat.Parsers.BooleanRecognizerOptimizedReflective. 3 | Require Import Fiat.Parsers.ContextFreeGrammar.Core. 4 | Require Import Fiat.Parsers.ContextFreeGrammar.PreNotations. 5 | Require Import Fiat.Parsers.Reflective.Syntax. 6 | Require Import Fiat.Parsers.Reflective.ParserSyntax. 7 | Require Import Fiat.Parsers.Reflective.ParserPartialUnfold. 8 | 9 | Record ParserReflective (G : pregrammar Ascii.ascii) := 10 | { 11 | rhas_parse : polyhas_parse_term cbool; 12 | 13 | rhas_parse_correct : rhas_parse = polypnormalize (parse_nonterminal_reified G (Start_symbol G)) 14 | }. 15 | 16 | Definition default_ParserReflective G : ParserReflective G 17 | := {| rhas_parse_correct := eq_refl |}. 18 | 19 | Ltac make_ParserReflective G := 20 | let p := constr:(default_ParserReflective G) in 21 | eval vm_compute in p. 22 | -------------------------------------------------------------------------------- /src/FiniteSetADTs/WordInterface.v: -------------------------------------------------------------------------------- 1 | Require Export Fiat.Common.Coq__8_4__8_5__Compat. 2 | (** Before we integrated bedrock, we used a dummy implementation of 3 | this module using [nat]; see NatWord.v. *) 4 | Require Import Coq.Classes.Morphisms. 5 | 6 | Set Implicit Arguments. 7 | Global Set Asymmetric Patterns. 8 | 9 | Module Type BedrockWordT. 10 | Axiom W : Type. 11 | Axiom wzero : W. 12 | Axiom wplus : W -> W -> W. 13 | Axiom wminus : W -> W -> W. 14 | Axiom weq : W -> W -> bool. 15 | Axiom wlt : W -> W -> bool. 16 | Axiom weq_iff : forall x y, x = y <-> weq x y = true. 17 | Axiom wlt_irrefl : forall x, wlt x x = false. 18 | Axiom wlt_trans : forall x y z, wlt x y = true -> wlt y z = true -> wlt x z = true. 19 | Axiom wle_antisym : forall x y, wlt x y = false -> wlt y x = false -> x = y. 20 | Axiom wle_asym : forall x y, wlt x y = true -> wlt y x = false. 21 | Axiom from_nat : nat -> W. 22 | End BedrockWordT. 23 | -------------------------------------------------------------------------------- /src/Parsers/Reflective/ParserSyntax.v: -------------------------------------------------------------------------------- 1 | Require Import Fiat.Parsers.Reflective.Syntax. 2 | 3 | Local Notation rcStepT cbool retT := 4 | ((*Rchar_at_matches_interp*) 5 | (cnat --> crchar_expr_ascii --> cbool) 6 | --> (*Rsplit_string_for_production*) 7 | (cnat * (cnat * cnat) --> cnat --> cnat --> (clist cnat)) 8 | --> cnat --> cnat --> (cnat --> cnat --> cnat --> retT) --> clist cnat --> cnat --> cnat --> cnat --> retT)%typecode 9 | (only parsing). 10 | 11 | Inductive has_parse_term var (T : SimpleTypeCode) : Type := 12 | | RFix2 13 | (G_length : nat) (up_to_G_length : list nat) 14 | (f : Term var (rcStepT cbool T)) 15 | (default : Term var T) 16 | (valid_len : nat) 17 | (valids : list nat) 18 | (nt_idx : nat). 19 | 20 | Definition polyhas_parse_term T := forall var, has_parse_term var T. 21 | -------------------------------------------------------------------------------- /src/Parsers/Reflective/ParserSyntaxEquivalence.v: -------------------------------------------------------------------------------- 1 | (** * Equivalence on syntax *) 2 | Require Import Fiat.Parsers.Reflective.Syntax Fiat.Parsers.Reflective.ParserSyntax. 3 | Require Import Fiat.Parsers.Reflective.SyntaxEquivalence. 4 | 5 | Section has_parse_term_equiv. 6 | Context (var1 var2 : TypeCode -> Type). 7 | 8 | Inductive has_parse_term_equiv {T} : ctxt var1 var2 -> has_parse_term var1 T -> has_parse_term var2 T -> Prop := 9 | | EqFix2 10 | (G_length : nat) (up_to_G_length : list nat) 11 | (valid_len : nat) 12 | (valids : list nat) 13 | (nt_idx : nat) 14 | : forall G f1 f2 default1 default2, 15 | Term_equiv G f1 f2 16 | -> Term_equiv G default1 default2 17 | -> has_parse_term_equiv 18 | G 19 | (RFix2 G_length up_to_G_length f1 default1 valid_len valids nt_idx) 20 | (RFix2 G_length up_to_G_length f2 default2 valid_len valids nt_idx). 21 | End has_parse_term_equiv. 22 | -------------------------------------------------------------------------------- /src/Common/EnumType.v: -------------------------------------------------------------------------------- 1 | Require Import 2 | Coq.Vectors.Vector 3 | Coq.Vectors.Vector. 4 | 5 | Require Import 6 | Fiat.Common.BoundedLookup. 7 | 8 | Import Vectors.Vector.VectorNotations. 9 | Local Open Scope vector_scope. 10 | Local Open Scope string_scope. 11 | 12 | Definition EnumType 13 | {len : nat} 14 | {A : Type} 15 | (ta : t A (S len)) := Fin.t (S len). 16 | 17 | Definition EnumType_inj_BoundedIndex {len} {A} {ta} 18 | (e : @EnumType len A ta) : BoundedIndex ta := 19 | {| indexb := {| ibound := e; boundi := eq_refl |} |}. 20 | 21 | Definition BoundedIndex_inj_EnumType {len} {A} {ta} 22 | (idx : BoundedIndex ta) : @EnumType len A ta := 23 | idx.(indexb).(ibound). 24 | 25 | Coercion EnumType_inj_BoundedIndex : EnumType >-> BoundedIndex. 26 | 27 | Notation "``` idx" := (BoundedIndex_inj_EnumType ``idx) (at level 0). 28 | 29 | Global Arguments EnumType {len} {A} ta%vector_scope. 30 | -------------------------------------------------------------------------------- /src/ADTRefinement/Refinements/RefineHideADT.v: -------------------------------------------------------------------------------- 1 | Require Import Fiat.Common 2 | Fiat.ADT.ADTSig 3 | Fiat.ADT.Core 4 | Fiat.ADT.ADTHide 5 | Fiat.ADTRefinement.Core 6 | Fiat.ADTRefinement.SetoidMorphisms. 7 | 8 | Lemma RefineHideADT 9 | extSig' 10 | oldConstructorIndex oldMethodIndex 11 | (ConstructorMap : oldConstructorIndex -> ConstructorIndex extSig') 12 | (MethodMap : oldMethodIndex -> MethodIndex extSig') 13 | oldADT 14 | : forall newADT newADT', 15 | refineADT newADT newADT' 16 | -> arrow (refineADT oldADT (HideADT ConstructorMap MethodMap newADT)) 17 | (refineADT oldADT (HideADT ConstructorMap MethodMap newADT')). 18 | Proof. 19 | unfold arrow. 20 | intros ? ? [AbsR ? ?] [AbsR' ? ?]. 21 | destruct_head ADT. 22 | exists (fun r_o r_n => exists r_n', AbsR' r_o r_n' /\ AbsR r_n' r_n); 23 | simpl; intros. 24 | - eauto using refineConstructor_trans. 25 | - eauto using refineMethod_trans. 26 | Qed. 27 | -------------------------------------------------------------------------------- /src/Parsers/NOTES.md: -------------------------------------------------------------------------------- 1 | Notes for an eventual parsers paper 2 | =================================== 3 | 4 | ## Things done in Coq to speed up synthesis 5 | - Preoptimize the parser, before we know the grammar 6 | . By refinement, with tactics (good? bad? not sure?) 7 | . Tag things as fully reducible on the nth iteration of reduction, tactic that propogates information 8 | - Use explicit reduction lists, not `simpl` 9 | - `vm_compute in` is broken 10 | - `abstract` in TC resolution to not retypecheck things so much 11 | - split up refinement to not rewrite over the whole term 12 | . iterated `impl` rather than iterated `and` 13 | - split reduction into fully-reducible (compute/vm_compute) by reflection, 14 | 15 | ## Things done for OCaml speed 16 | - Fewer allocations 17 | . flatten product types for well-founded Fix data 18 | . n-ary Fix equality lemmas 19 | - make things tail-recursive 20 | - eliminate string comparison tests 21 | - OCaml strings 22 | - only pass around indexes for substrings 23 | -------------------------------------------------------------------------------- /src/Narcissus/Common/WordFacts.v: -------------------------------------------------------------------------------- 1 | Require Export Bedrock.Word. 2 | Require Import Fiat.Common.DecideableEnsembles. 3 | 4 | Lemma wordToNat_lt sz 5 | : forall w w' : word sz, 6 | wlt w w' -> 7 | lt (wordToNat w) (wordToNat w'). 8 | Proof. 9 | intros. 10 | unfold wlt, BinNat.N.lt in H. 11 | rewrite !wordToN_nat, <- Nnat.Nat2N.inj_compare, 12 | <- Compare_dec.nat_compare_lt in H. 13 | eassumption. 14 | Qed. 15 | 16 | Lemma natToWord_wlt sz 17 | : forall n n' : nat, 18 | BinNat.N.lt (BinNat.N.of_nat n) (Npow2 sz) 19 | -> BinNat.N.lt (BinNat.N.of_nat n') (Npow2 sz) 20 | -> lt n n' 21 | -> wlt (natToWord sz n) (natToWord sz n'). 22 | Proof. 23 | unfold wlt; intros. 24 | rewrite !wordToN_nat. 25 | rewrite !wordToNat_natToWord_idempotent; eauto. 26 | unfold BinNat.N.lt; rewrite <- Nnat.Nat2N.inj_compare. 27 | eapply Compare_dec.nat_compare_lt; eassumption. 28 | Qed. 29 | 30 | Instance Query_eq_word {n} : Query_eq (Word.word n) := 31 | {| A_eq_dec := @Word.weq n |}. 32 | -------------------------------------------------------------------------------- /.mailmap: -------------------------------------------------------------------------------- 1 | Jason Gross Jason Gross 2 | Ben Delaware Bendy 3 | Ben Delaware Bendy 4 | Adam Chlipala Adam Chlipala 5 | Clément Pit--Claudel Clément Pit--Claudel 6 | Clément Pit--Claudel Clément Pit--Claudel 7 | Katherine Ye katherineye 8 | Sorawit Suriyakarn Sorawit Suriyakarn 9 | -------------------------------------------------------------------------------- /src/CertifiedExtraction/Benchmarks/Any.v: -------------------------------------------------------------------------------- 1 | Require Import 2 | CertifiedExtraction.Extraction.Extraction. 3 | 4 | Definition Any := { x: W | True }%comp. 5 | 6 | Definition FAny {av} : AxiomaticSpec av. 7 | Proof. refine {| 8 | PreCond := fun args => args = nil; 9 | PostCond := fun args ret => args = nil /\ exists w, ret = SCA av w 10 | |}; spec_t. Defined. 11 | 12 | Lemma Any_characterization: 13 | forall x : W, Any ↝ x. 14 | Proof. constructor. Qed. 15 | 16 | Hint Immediate Any_characterization : call_helpers_db. 17 | 18 | Lemma CompileCallAny: 19 | forall {av} (env : GLabelMap.t (FuncSpec av)), 20 | forall fpointer tenv, 21 | GLabelMap.MapsTo fpointer (Axiomatic FAny) env -> 22 | forall var ext, 23 | var ∉ ext -> 24 | NotInTelescope var tenv -> 25 | {{ tenv }} 26 | (DFacade.Call var fpointer nil) 27 | {{ [[ ` var ~~> Any as _]] :: tenv }} ∪ {{ ext }} // env. 28 | Proof. 29 | repeat (SameValues_Facade_t_step || facade_cleanup_call); facade_eauto. 30 | Qed. 31 | -------------------------------------------------------------------------------- /src/CertifiedExtraction/Extraction/QueryStructures/BinNatUtils.v: -------------------------------------------------------------------------------- 1 | Require Export Fiat.Common.Coq__8_4__8_5__Compat. 2 | Require Import Bedrock.Memory. 3 | 4 | Lemma lt_BinNat_lt: 5 | forall (p p' : nat), 6 | lt p p' -> 7 | BinNat.N.lt (BinNat.N.of_nat p) (BinNat.N.of_nat p'). 8 | Proof. 9 | intros; Nomega.nomega. 10 | Qed. 11 | 12 | Lemma BinNat_lt_S: 13 | forall (p p' : nat), 14 | BinNat.N.lt (BinNat.N.of_nat p) (BinNat.N.of_nat p') -> 15 | BinNat.N.lt (BinNat.N.of_nat (S p)) (BinNat.N.of_nat (S p')). 16 | Proof. 17 | intros; Nomega.nomega. 18 | Qed. 19 | 20 | Lemma BinNat_lt_of_nat_S: 21 | forall (p : nat) (q : BinNums.N), 22 | BinNat.N.lt (BinNat.N.of_nat (S p)) q -> 23 | BinNat.N.lt (BinNat.N.of_nat p) q. 24 | Proof. 25 | intros; Nomega.nomega. 26 | Qed. 27 | 28 | Lemma BinNat_lt_Fin_to_nat: 29 | forall (N : nat) (idx : Fin.t N), 30 | BinNat.N.lt (BinNat.N.of_nat (projT1 (Fin.to_nat idx))) (BinNat.N.of_nat N). 31 | Proof. 32 | intros. 33 | pose proof (projT2 (Fin.to_nat idx)). 34 | Nomega.nomega. 35 | Qed. 36 | -------------------------------------------------------------------------------- /src/Parsers/Refinement/SharpenedExpressionParen.v: -------------------------------------------------------------------------------- 1 | (** Sharpened ADT for an expression grammar with parentheses *) 2 | Require Import Fiat.Parsers.Refinement.Tactics. 3 | Require Import Fiat.Parsers.Grammars.ExpressionParen. 4 | 5 | Section IndexedImpl. 6 | 7 | Lemma ComputationalSplitter' 8 | : FullySharpened (string_spec paren_expr_grammar string_stringlike). 9 | Proof. 10 | splitter_start; splitter_finish. 11 | Defined. 12 | 13 | Lemma ComputationalSplitter 14 | : FullySharpened (string_spec paren_expr_grammar string_stringlike). 15 | Proof. 16 | make_simplified_splitter ComputationalSplitter'. 17 | Defined. 18 | 19 | End IndexedImpl. 20 | 21 | Require Import Fiat.Parsers.ParserFromParserADT. 22 | Require Import Fiat.Parsers.ExtrOcamlParsers. 23 | Import Fiat.Parsers.ExtrOcamlParsers.HideProofs. 24 | 25 | Definition paren_expr_parser (str : String.string) : bool. 26 | Proof. 27 | Time make_parser ComputationalSplitter. (* 13 s *) 28 | Defined. 29 | 30 | Print paren_expr_parser. 31 | 32 | Recursive Extraction paren_expr_parser. 33 | -------------------------------------------------------------------------------- /src/Narcissus/Examples/Guard/IPTablesGuard.v: -------------------------------------------------------------------------------- 1 | Require Import Fiat.ADT Fiat.ADTNotation. 2 | 3 | Require Import Fiat.Narcissus.Examples.Guard.Core. 4 | Require Export Fiat.Narcissus.Examples.Guard.IPTables. 5 | Require Export Fiat.Narcissus.Examples.Guard.Ports. 6 | 7 | Definition protected_let {A B} (a: A) (k: A -> B) : B := 8 | k a. 9 | 10 | Notation "'IPGuard' {{ inv1 ; .. ; invn }}" := 11 | (Def ADT { 12 | rep := unit, 13 | 14 | Def Constructor0 "Init" : rep := ret tt,, 15 | 16 | Def Method1 "ProcessPacket" (db : rep) (bs : bytes) : rep * result := 17 | let invocations := (List.cons inv1%iptables .. (List.cons invn%iptables List.nil) ..) in 18 | let rule := rule_of_invocations invocations in 19 | let policy := policy_of_invocations FORWARD invocations DROP in 20 | ret (protected_let (input_of_bytes FORWARD bs) (fun input => 21 | (db, match rule input with 22 | | Some res => res 23 | | None => policy 24 | end))) 25 | }%methDefParsing). 26 | -------------------------------------------------------------------------------- /src/Parsers/ContextFreeGrammar/Valid.v: -------------------------------------------------------------------------------- 1 | (** * Definition of Context Free Grammars *) 2 | Require Export Fiat.Parsers.StringLike.Core. 3 | Require Import Fiat.Parsers.ContextFreeGrammar.Core. 4 | Require Import Fiat.Parsers.BaseTypes. 5 | 6 | Set Implicit Arguments. 7 | 8 | Local Open Scope string_like_scope. 9 | Local Open Scope type_scope. 10 | 11 | Section cfg. 12 | Context {Char : Type} {HSL : StringLikeMin Char} (G : grammar Char) 13 | {predata : @parser_computational_predataT Char}. 14 | 15 | Definition item_valid (it : item Char) 16 | := match it with 17 | | Terminal _ => True 18 | | NonTerminal nt' => is_true (is_valid_nonterminal initial_nonterminals_data (of_nonterminal nt')) 19 | end. 20 | 21 | Definition production_valid pat 22 | := List.Forall item_valid pat. 23 | 24 | Definition productions_valid pats 25 | := List.Forall production_valid pats. 26 | 27 | Definition grammar_valid 28 | := forall nt, 29 | List.In nt (Valid_nonterminals G) 30 | -> productions_valid (Lookup G nt). 31 | End cfg. 32 | -------------------------------------------------------------------------------- /src/QueryStructure/Implementation/DataStructures/Bags/NatCompare_Facts.v: -------------------------------------------------------------------------------- 1 | Require Import Coq.ZArith.ZArith. 2 | Require Export Fiat.Common.Coq__8_4__8_5__Compat. 3 | 4 | #[global] 5 | Hint Rewrite <- nat_compare_lt : hints. 6 | #[global] 7 | Hint Rewrite <- nat_compare_gt : hints. 8 | #[global] 9 | Hint Rewrite Nat.compare_eq_iff : hints. 10 | #[global] 11 | Hint Rewrite <- Nat.compare_eq_iff : hints. 12 | 13 | Ltac autorewrite_nat_compare := 14 | autorewrite with hints. 15 | 16 | Lemma nat_compare_eq_refl : forall x, Nat.compare x x = Eq. 17 | intros; apply Nat.compare_eq_iff; trivial. 18 | Qed. 19 | 20 | Lemma nat_compare_consistent : 21 | forall n0 n1, 22 | { Nat.compare n0 n1 = Lt /\ Nat.compare n1 n0 = Gt } 23 | + { Nat.compare n0 n1 = Eq /\ Nat.compare n1 n0 = Eq } 24 | + { Nat.compare n0 n1 = Gt /\ Nat.compare n1 n0 = Lt }. 25 | Proof. 26 | intros n0 n1; 27 | destruct (lt_eq_lt_dec n0 n1) as [ [_lt | _eq] | _lt ]; 28 | [ constructor 1; constructor 1 | constructor 1; constructor 2 | constructor 2 ]; 29 | split; 30 | autorewrite_nat_compare; 31 | intuition. 32 | Qed. 33 | -------------------------------------------------------------------------------- /src/Parsers/Refinement/Makefile: -------------------------------------------------------------------------------- 1 | CFLAGS ?= -std=c99 -O3 -Wall -Wpedantic 2 | 3 | .PHONY: all test 4 | 5 | all: test_ab_star test_ab_star_reference 6 | 7 | test_ab_star test_ab_star_reference: % : %.ml 8 | ocamlopt -o $@ $< 9 | 10 | ab10: 11 | echo -n "abababababababababab" > $@ 12 | 13 | ab10.0 ab10.0.0 ab10.0.0.0 ab10.0.0.0.0 ab10.0.0.0.0.0 ab10.0.0.0.0.0.0 ab10.0.0.0.0.0.0.0 ab10.0.0.0.0.0.0.0.0 : %.0 : % 14 | @cp -f $< $@ 15 | @cat $< >> $@ 16 | @cat $< >> $@ 17 | @cat $< >> $@ 18 | @cat $< >> $@ 19 | @cat $< >> $@ 20 | @cat $< >> $@ 21 | @cat $< >> $@ 22 | @cat $< >> $@ 23 | @cat $< >> $@ 24 | 25 | make_fmt = $$(echo "$1 (real: %e, user: %U, sys: %S, mem: %M ko)" | sed s'/\.//g') 26 | 27 | test: ab10.0.0.0.0.0 test_ab_star test_ab_star_reference 28 | for F in ab10 ab10.0 ab10.0.0 ab10.0.0.0 ab10.0.0.0.0 ab10.0.0.0.0.0; do \ 29 | FMT="$(call make_fmt, $$F)"; \ 30 | $(shell which time) -f "cat $$FMT" cat $$F>/dev/null; \ 31 | echo $$?; \ 32 | $(shell which time) -f "reference $$FMT" ./test_ab_star_reference $$F; \ 33 | echo $$?; \ 34 | $(shell which time) -f "coq $$FMT" ./test_ab_star $$F; \ 35 | echo $$?; \ 36 | done 37 | -------------------------------------------------------------------------------- /src/QueryStructure/Specification/Constraints/DuplicateFree.v: -------------------------------------------------------------------------------- 1 | Require Import 2 | Coq.Lists.List 3 | Fiat.QueryStructure.Specification.Representation.Heading 4 | Fiat.QueryStructure.Specification.Representation.Tuple 5 | Fiat.QueryStructure.Specification.Representation.QueryStructure. 6 | 7 | Definition DuplicateFree {heading} (tup1 tup2 : @RawTuple heading) := tup1 <> tup2. 8 | 9 | Fixpoint BuildFinUpTo (n : nat) {struct n} : list (Fin.t n) := 10 | match n return list (Fin.t n) with 11 | | 0 => nil 12 | | S n' => cons (@Fin.F1 _) (map (@Fin.FS _) (BuildFinUpTo n')) 13 | end. 14 | 15 | Definition allAttributes heading 16 | : list (Attributes heading) := 17 | BuildFinUpTo (NumAttr heading). 18 | 19 | Fixpoint tupleAgree_computational' 20 | {h} 21 | (tup1 tup2 : @RawTuple h) 22 | (attrlist : list (Attributes h)) 23 | {struct attrlist} := 24 | match attrlist with 25 | | nil => True 26 | | cons attr nil => GetAttributeRaw tup1 attr = GetAttributeRaw tup2 attr 27 | | attr :: more => GetAttributeRaw tup1 attr = GetAttributeRaw tup2 attr /\ tupleAgree_computational' tup1 tup2 more 28 | end. 29 | -------------------------------------------------------------------------------- /src/Examples/Ics/client.ml: -------------------------------------------------------------------------------- 1 | let rec nat_of_int = function 2 | | 0 -> O 3 | | n -> S (nat_of_int (n - 1)) 4 | 5 | let num n = Z.of_nat (nat_of_int n) 6 | 7 | module DetInterp = struct 8 | let state = ref (num 0) 9 | 10 | let init n = state := Det.coq_new (num n) 11 | let update n = 12 | let Pair (state', Tt) = Det.update !state (num n) in 13 | state := state' 14 | let timestep n = 15 | let Pair (state', act) = Det.timestep !state (num n) in 16 | state := state'; 17 | act 18 | end 19 | 20 | type req = {targetLevel : int; 21 | fillRate : int; 22 | emptyRate : int} 23 | 24 | module NondetInterp = struct 25 | let state = ref { Coq_N.coq_Min = num 0; Coq_N.coq_Max = num 0 } 26 | 27 | let init n = state := Nondet.coq_new (num n) 28 | let update n = 29 | let Pair (state', Tt) = Nondet.update !state (num n) in 30 | state := state' 31 | let timestep r = 32 | let Pair (state', act) = Nondet.timestep !state 33 | {Coq_N.coq_TargetLevel = num r.targetLevel; 34 | Coq_N.coq_FillRate = num r.fillRate; 35 | Coq_N.coq_EmptyRate = num r.emptyRate} in 36 | state := state'; 37 | act 38 | end 39 | -------------------------------------------------------------------------------- /src/Common/Tactics/transparent_abstract_plugin.ml4.v86: -------------------------------------------------------------------------------- 1 | open Transparent_abstract_tactics 2 | open Constrarg 3 | 4 | (* 5 | 6 | TACTIC EXTEND abstracttermas 7 | | [ "cache_term" constr(term) "as" ident(name) "run" tactic(tacK)] -> 8 | [ fun gl -> TRANSPARENT_ABSTRACT.tclABSTRACTTERM (Some name) term tacK gl ] 9 | END 10 | 11 | TACTIC EXTEND abstractterm 12 | | [ "cache_term" constr(term) "run" tactic(tacK) ] -> 13 | [ fun gl -> TRANSPARENT_ABSTRACT.tclABSTRACTTERM None term tacK gl ] 14 | END *) 15 | 16 | DECLARE PLUGIN "transparent_abstract_plugin" 17 | 18 | TACTIC EXTEND transparentabstract 19 | | [ "cache" tactic(tac) "as" ident(name)] 20 | -> [ TRANSPARENT_ABSTRACT.tclTRABSTRACT (Some name) (Tacinterp.tactic_of_value ist tac) ] 21 | END 22 | 23 | TACTIC EXTEND abstracttermas 24 | | [ "cache_term" constr(term) "as" ident(name) "run" tactic(tacK)] -> 25 | [ TRANSPARENT_ABSTRACT.tclABSTRACTTERM (Some name) term tacK ] 26 | END 27 | 28 | TACTIC EXTEND abstractterm 29 | | [ "cache_term" constr(term) "run" tactic(tacK) ] -> 30 | [ TRANSPARENT_ABSTRACT.tclABSTRACTTERM None term tacK ] 31 | END;; 32 | -------------------------------------------------------------------------------- /src/Common/Tactics/transparent_abstract_tactics.ml.v815: -------------------------------------------------------------------------------- 1 | module TRANSPARENT_ABSTRACT = 2 | struct 3 | open Names 4 | open Ltac_plugin 5 | 6 | (* Lift a constr to an ltac value. *) 7 | let to_ltac_val c = Tacinterp.Value.of_constr c 8 | 9 | (* Build a new definition for [term] with identifier [id] and call *) 10 | (* the [tacK] tactic with the result. *) 11 | let transparent_abstract_term ~name_op (term : EConstr.constr) tacK = 12 | Proofview.Goal.enter begin 13 | fun gl -> 14 | let termType = Tacmach.pf_get_type_of gl term in 15 | Abstract.cache_term_by_tactic_then ~opaque:false ~name_op 16 | ~goal_type:(Some termType) 17 | (Eauto.e_give_exact term) 18 | (fun lem args -> Tacinterp.Value.apply tacK [to_ltac_val (EConstr.applist (lem, args))]) 19 | end 20 | 21 | (* Default identifier *) 22 | let anon_id = Id.of_string "anonymous" 23 | 24 | let tclTRABSTRACT name_op tac = Abstract.tclABSTRACT ~opaque:false name_op tac 25 | 26 | let tclABSTRACTTERM name_op term tacK = 27 | (* What's the right default goal kind?*) 28 | transparent_abstract_term ~name_op term tacK 29 | 30 | end 31 | -------------------------------------------------------------------------------- /src/Common/Tactics/transparent_abstract_tactics.ml.v816: -------------------------------------------------------------------------------- 1 | module TRANSPARENT_ABSTRACT = 2 | struct 3 | open Names 4 | open Ltac_plugin 5 | 6 | (* Lift a constr to an ltac value. *) 7 | let to_ltac_val c = Tacinterp.Value.of_constr c 8 | 9 | (* Build a new definition for [term] with identifier [id] and call *) 10 | (* the [tacK] tactic with the result. *) 11 | let transparent_abstract_term ~name_op (term : EConstr.constr) tacK = 12 | Proofview.Goal.enter begin 13 | fun gl -> 14 | let termType = Tacmach.pf_get_type_of gl term in 15 | Abstract.cache_term_by_tactic_then ~opaque:false ~name_op 16 | ~goal_type:(Some termType) 17 | (Eauto.e_give_exact term) 18 | (fun lem args -> Tacinterp.Value.apply tacK [to_ltac_val (EConstr.applist (lem, args))]) 19 | end 20 | 21 | (* Default identifier *) 22 | let anon_id = Id.of_string "anonymous" 23 | 24 | let tclTRABSTRACT name_op tac = Abstract.tclABSTRACT ~opaque:false name_op tac 25 | 26 | let tclABSTRACTTERM name_op term tacK = 27 | (* What's the right default goal kind?*) 28 | transparent_abstract_term ~name_op term tacK 29 | 30 | end 31 | -------------------------------------------------------------------------------- /src/Common/Tactics/transparent_abstract_tactics.ml.v817: -------------------------------------------------------------------------------- 1 | module TRANSPARENT_ABSTRACT = 2 | struct 3 | open Names 4 | open Ltac_plugin 5 | 6 | (* Lift a constr to an ltac value. *) 7 | let to_ltac_val c = Tacinterp.Value.of_constr c 8 | 9 | (* Build a new definition for [term] with identifier [id] and call *) 10 | (* the [tacK] tactic with the result. *) 11 | let transparent_abstract_term ~name_op (term : EConstr.constr) tacK = 12 | Proofview.Goal.enter begin 13 | fun gl -> 14 | let termType = Tacmach.pf_get_type_of gl term in 15 | Abstract.cache_term_by_tactic_then ~opaque:false ~name_op 16 | ~goal_type:(Some termType) 17 | (Eauto.e_give_exact term) 18 | (fun lem args -> Tacinterp.Value.apply tacK [to_ltac_val (EConstr.applist (lem, args))]) 19 | end 20 | 21 | (* Default identifier *) 22 | let anon_id = Id.of_string "anonymous" 23 | 24 | let tclTRABSTRACT name_op tac = Abstract.tclABSTRACT ~opaque:false name_op tac 25 | 26 | let tclABSTRACTTERM name_op term tacK = 27 | (* What's the right default goal kind?*) 28 | transparent_abstract_term ~name_op term tacK 29 | 30 | end 31 | -------------------------------------------------------------------------------- /src/Common/Tactics/transparent_abstract_tactics.ml.v818: -------------------------------------------------------------------------------- 1 | module TRANSPARENT_ABSTRACT = 2 | struct 3 | open Names 4 | open Ltac_plugin 5 | 6 | (* Lift a constr to an ltac value. *) 7 | let to_ltac_val c = Tacinterp.Value.of_constr c 8 | 9 | (* Build a new definition for [term] with identifier [id] and call *) 10 | (* the [tacK] tactic with the result. *) 11 | let transparent_abstract_term ~name_op (term : EConstr.constr) tacK = 12 | Proofview.Goal.enter begin 13 | fun gl -> 14 | let termType = Tacmach.pf_get_type_of gl term in 15 | Abstract.cache_term_by_tactic_then ~opaque:false ~name_op 16 | ~goal_type:(Some termType) 17 | (Eauto.e_give_exact term) 18 | (fun lem args -> Tacinterp.Value.apply tacK [to_ltac_val (EConstr.applist (lem, args))]) 19 | end 20 | 21 | (* Default identifier *) 22 | let anon_id = Id.of_string "anonymous" 23 | 24 | let tclTRABSTRACT name_op tac = Abstract.tclABSTRACT ~opaque:false name_op tac 25 | 26 | let tclABSTRACTTERM name_op term tacK = 27 | (* What's the right default goal kind?*) 28 | transparent_abstract_term ~name_op term tacK 29 | 30 | end 31 | -------------------------------------------------------------------------------- /src/Common/Tactics/transparent_abstract_tactics.ml.v819: -------------------------------------------------------------------------------- 1 | module TRANSPARENT_ABSTRACT = 2 | struct 3 | open Names 4 | open Ltac_plugin 5 | 6 | (* Lift a constr to an ltac value. *) 7 | let to_ltac_val c = Tacinterp.Value.of_constr c 8 | 9 | (* Build a new definition for [term] with identifier [id] and call *) 10 | (* the [tacK] tactic with the result. *) 11 | let transparent_abstract_term ~name_op (term : EConstr.constr) tacK = 12 | Proofview.Goal.enter begin 13 | fun gl -> 14 | let termType = Tacmach.pf_get_type_of gl term in 15 | Abstract.cache_term_by_tactic_then ~opaque:false ~name_op 16 | ~goal_type:(Some termType) 17 | (Eauto.e_give_exact term) 18 | (fun lem args -> Tacinterp.Value.apply tacK [to_ltac_val (EConstr.applist (lem, args))]) 19 | end 20 | 21 | (* Default identifier *) 22 | let anon_id = Id.of_string "anonymous" 23 | 24 | let tclTRABSTRACT name_op tac = Abstract.tclABSTRACT ~opaque:false name_op tac 25 | 26 | let tclABSTRACTTERM name_op term tacK = 27 | (* What's the right default goal kind?*) 28 | transparent_abstract_term ~name_op term tacK 29 | 30 | end 31 | -------------------------------------------------------------------------------- /src/Common/Tactics/transparent_abstract_tactics.ml.v820: -------------------------------------------------------------------------------- 1 | module TRANSPARENT_ABSTRACT = 2 | struct 3 | open Names 4 | open Ltac_plugin 5 | 6 | (* Lift a constr to an ltac value. *) 7 | let to_ltac_val c = Tacinterp.Value.of_constr c 8 | 9 | (* Build a new definition for [term] with identifier [id] and call *) 10 | (* the [tacK] tactic with the result. *) 11 | let transparent_abstract_term ~name_op (term : EConstr.constr) tacK = 12 | Proofview.Goal.enter begin 13 | fun gl -> 14 | let termType = Tacmach.pf_get_type_of gl term in 15 | Abstract.cache_term_by_tactic_then ~opaque:false ~name_op 16 | ~goal_type:(Some termType) 17 | (Eauto.e_give_exact term) 18 | (fun lem args -> Tacinterp.Value.apply tacK [to_ltac_val (EConstr.applist (lem, args))]) 19 | end 20 | 21 | (* Default identifier *) 22 | let anon_id = Id.of_string "anonymous" 23 | 24 | let tclTRABSTRACT name_op tac = Abstract.tclABSTRACT ~opaque:false name_op tac 25 | 26 | let tclABSTRACTTERM name_op term tacK = 27 | (* What's the right default goal kind?*) 28 | transparent_abstract_term ~name_op term tacK 29 | 30 | end 31 | -------------------------------------------------------------------------------- /src/Common/Tactics/transparent_abstract_tactics.ml.v90: -------------------------------------------------------------------------------- 1 | module TRANSPARENT_ABSTRACT = 2 | struct 3 | open Names 4 | open Ltac_plugin 5 | 6 | (* Lift a constr to an ltac value. *) 7 | let to_ltac_val c = Tacinterp.Value.of_constr c 8 | 9 | (* Build a new definition for [term] with identifier [id] and call *) 10 | (* the [tacK] tactic with the result. *) 11 | let transparent_abstract_term ~name_op (term : EConstr.constr) tacK = 12 | Proofview.Goal.enter begin 13 | fun gl -> 14 | let termType = Tacmach.pf_get_type_of gl term in 15 | Abstract.cache_term_by_tactic_then ~opaque:false ~name_op 16 | ~goal_type:(Some termType) 17 | (Eauto.e_give_exact term) 18 | (fun lem args -> Tacinterp.Value.apply tacK [to_ltac_val (EConstr.applist (lem, args))]) 19 | end 20 | 21 | (* Default identifier *) 22 | let anon_id = Id.of_string "anonymous" 23 | 24 | let tclTRABSTRACT name_op tac = Abstract.tclABSTRACT ~opaque:false name_op tac 25 | 26 | let tclABSTRACTTERM name_op term tacK = 27 | (* What's the right default goal kind?*) 28 | transparent_abstract_term ~name_op term tacK 29 | 30 | end 31 | -------------------------------------------------------------------------------- /src/Common/Tactics/transparent_abstract_tactics.ml.v91: -------------------------------------------------------------------------------- 1 | module TRANSPARENT_ABSTRACT = 2 | struct 3 | open Names 4 | open Ltac_plugin 5 | 6 | (* Lift a constr to an ltac value. *) 7 | let to_ltac_val c = Tacinterp.Value.of_constr c 8 | 9 | (* Build a new definition for [term] with identifier [id] and call *) 10 | (* the [tacK] tactic with the result. *) 11 | let transparent_abstract_term ~name_op (term : EConstr.constr) tacK = 12 | Proofview.Goal.enter begin 13 | fun gl -> 14 | let termType = Tacmach.pf_get_type_of gl term in 15 | Abstract.cache_term_by_tactic_then ~opaque:false ~name_op 16 | ~goal_type:(Some termType) 17 | (Eauto.e_give_exact term) 18 | (fun lem args -> Tacinterp.Value.apply tacK [to_ltac_val (EConstr.applist (lem, args))]) 19 | end 20 | 21 | (* Default identifier *) 22 | let anon_id = Id.of_string "anonymous" 23 | 24 | let tclTRABSTRACT name_op tac = Abstract.tclABSTRACT ~opaque:false name_op tac 25 | 26 | let tclABSTRACTTERM name_op term tacK = 27 | (* What's the right default goal kind?*) 28 | transparent_abstract_term ~name_op term tacK 29 | 30 | end 31 | -------------------------------------------------------------------------------- /src/Common/Tactics/transparent_abstract_tactics.ml.v92: -------------------------------------------------------------------------------- 1 | module TRANSPARENT_ABSTRACT = 2 | struct 3 | open Names 4 | open Ltac_plugin 5 | 6 | (* Lift a constr to an ltac value. *) 7 | let to_ltac_val c = Tacinterp.Value.of_constr c 8 | 9 | (* Build a new definition for [term] with identifier [id] and call *) 10 | (* the [tacK] tactic with the result. *) 11 | let transparent_abstract_term ~name_op (term : EConstr.constr) tacK = 12 | Proofview.Goal.enter begin 13 | fun gl -> 14 | let termType = Tacmach.pf_get_type_of gl term in 15 | Abstract.cache_term_by_tactic_then ~opaque:false ~name_op 16 | ~goal_type:(Some termType) 17 | (Eauto.e_give_exact term) 18 | (fun lem args -> Tacinterp.Value.apply tacK [to_ltac_val (EConstr.applist (lem, args))]) 19 | end 20 | 21 | (* Default identifier *) 22 | let anon_id = Id.of_string "anonymous" 23 | 24 | let tclTRABSTRACT name_op tac = Abstract.tclABSTRACT ~opaque:false name_op tac 25 | 26 | let tclABSTRACTTERM name_op term tacK = 27 | (* What's the right default goal kind?*) 28 | transparent_abstract_term ~name_op term tacK 29 | 30 | end 31 | -------------------------------------------------------------------------------- /src/Common/Tactics/transparent_abstract_tactics.ml.v810: -------------------------------------------------------------------------------- 1 | module TRANSPARENT_ABSTRACT = 2 | struct 3 | open Names 4 | open Ltac_plugin 5 | 6 | (* Lift a constr to an ltac value. *) 7 | let to_ltac_val c = Tacinterp.Value.of_constr c 8 | 9 | (* Build a new definition for [term] with identifier [id] and call *) 10 | (* the [tacK] tactic with the result. *) 11 | let transparent_abstract_term ~name_op (term : EConstr.constr) tacK = 12 | Proofview.Goal.enter begin 13 | fun gl -> 14 | let termType = Tacmach.New.pf_get_type_of gl term in 15 | Abstract.cache_term_by_tactic_then ~opaque:false ~name_op 16 | ~goal_type:(Some termType) 17 | (Eauto.e_give_exact term) 18 | (fun lem args -> Tacinterp.Value.apply tacK [to_ltac_val (EConstr.applist (lem, args))]) 19 | end 20 | 21 | (* Default identifier *) 22 | let anon_id = Id.of_string "anonymous" 23 | 24 | let tclTRABSTRACT name_op tac = Abstract.tclABSTRACT ~opaque:false name_op tac 25 | 26 | let tclABSTRACTTERM name_op term tacK = 27 | (* What's the right default goal kind?*) 28 | transparent_abstract_term ~name_op term tacK 29 | 30 | end 31 | -------------------------------------------------------------------------------- /src/Common/Tactics/transparent_abstract_tactics.ml.v811: -------------------------------------------------------------------------------- 1 | module TRANSPARENT_ABSTRACT = 2 | struct 3 | open Names 4 | open Ltac_plugin 5 | 6 | (* Lift a constr to an ltac value. *) 7 | let to_ltac_val c = Tacinterp.Value.of_constr c 8 | 9 | (* Build a new definition for [term] with identifier [id] and call *) 10 | (* the [tacK] tactic with the result. *) 11 | let transparent_abstract_term ~name_op (term : EConstr.constr) tacK = 12 | Proofview.Goal.enter begin 13 | fun gl -> 14 | let termType = Tacmach.New.pf_get_type_of gl term in 15 | Abstract.cache_term_by_tactic_then ~opaque:false ~name_op 16 | ~goal_type:(Some termType) 17 | (Eauto.e_give_exact term) 18 | (fun lem args -> Tacinterp.Value.apply tacK [to_ltac_val (EConstr.applist (lem, args))]) 19 | end 20 | 21 | (* Default identifier *) 22 | let anon_id = Id.of_string "anonymous" 23 | 24 | let tclTRABSTRACT name_op tac = Abstract.tclABSTRACT ~opaque:false name_op tac 25 | 26 | let tclABSTRACTTERM name_op term tacK = 27 | (* What's the right default goal kind?*) 28 | transparent_abstract_term ~name_op term tacK 29 | 30 | end 31 | -------------------------------------------------------------------------------- /src/Common/Tactics/transparent_abstract_tactics.ml.v812: -------------------------------------------------------------------------------- 1 | module TRANSPARENT_ABSTRACT = 2 | struct 3 | open Names 4 | open Ltac_plugin 5 | 6 | (* Lift a constr to an ltac value. *) 7 | let to_ltac_val c = Tacinterp.Value.of_constr c 8 | 9 | (* Build a new definition for [term] with identifier [id] and call *) 10 | (* the [tacK] tactic with the result. *) 11 | let transparent_abstract_term ~name_op (term : EConstr.constr) tacK = 12 | Proofview.Goal.enter begin 13 | fun gl -> 14 | let termType = Tacmach.New.pf_get_type_of gl term in 15 | Abstract.cache_term_by_tactic_then ~opaque:false ~name_op 16 | ~goal_type:(Some termType) 17 | (Eauto.e_give_exact term) 18 | (fun lem args -> Tacinterp.Value.apply tacK [to_ltac_val (EConstr.applist (lem, args))]) 19 | end 20 | 21 | (* Default identifier *) 22 | let anon_id = Id.of_string "anonymous" 23 | 24 | let tclTRABSTRACT name_op tac = Abstract.tclABSTRACT ~opaque:false name_op tac 25 | 26 | let tclABSTRACTTERM name_op term tacK = 27 | (* What's the right default goal kind?*) 28 | transparent_abstract_term ~name_op term tacK 29 | 30 | end 31 | -------------------------------------------------------------------------------- /src/Common/Tactics/transparent_abstract_tactics.ml.v813: -------------------------------------------------------------------------------- 1 | module TRANSPARENT_ABSTRACT = 2 | struct 3 | open Names 4 | open Ltac_plugin 5 | 6 | (* Lift a constr to an ltac value. *) 7 | let to_ltac_val c = Tacinterp.Value.of_constr c 8 | 9 | (* Build a new definition for [term] with identifier [id] and call *) 10 | (* the [tacK] tactic with the result. *) 11 | let transparent_abstract_term ~name_op (term : EConstr.constr) tacK = 12 | Proofview.Goal.enter begin 13 | fun gl -> 14 | let termType = Tacmach.New.pf_get_type_of gl term in 15 | Abstract.cache_term_by_tactic_then ~opaque:false ~name_op 16 | ~goal_type:(Some termType) 17 | (Eauto.e_give_exact term) 18 | (fun lem args -> Tacinterp.Value.apply tacK [to_ltac_val (EConstr.applist (lem, args))]) 19 | end 20 | 21 | (* Default identifier *) 22 | let anon_id = Id.of_string "anonymous" 23 | 24 | let tclTRABSTRACT name_op tac = Abstract.tclABSTRACT ~opaque:false name_op tac 25 | 26 | let tclABSTRACTTERM name_op term tacK = 27 | (* What's the right default goal kind?*) 28 | transparent_abstract_term ~name_op term tacK 29 | 30 | end 31 | -------------------------------------------------------------------------------- /src/Common/Tactics/transparent_abstract_tactics.ml.v814: -------------------------------------------------------------------------------- 1 | module TRANSPARENT_ABSTRACT = 2 | struct 3 | open Names 4 | open Ltac_plugin 5 | 6 | (* Lift a constr to an ltac value. *) 7 | let to_ltac_val c = Tacinterp.Value.of_constr c 8 | 9 | (* Build a new definition for [term] with identifier [id] and call *) 10 | (* the [tacK] tactic with the result. *) 11 | let transparent_abstract_term ~name_op (term : EConstr.constr) tacK = 12 | Proofview.Goal.enter begin 13 | fun gl -> 14 | let termType = Tacmach.New.pf_get_type_of gl term in 15 | Abstract.cache_term_by_tactic_then ~opaque:false ~name_op 16 | ~goal_type:(Some termType) 17 | (Eauto.e_give_exact term) 18 | (fun lem args -> Tacinterp.Value.apply tacK [to_ltac_val (EConstr.applist (lem, args))]) 19 | end 20 | 21 | (* Default identifier *) 22 | let anon_id = Id.of_string "anonymous" 23 | 24 | let tclTRABSTRACT name_op tac = Abstract.tclABSTRACT ~opaque:false name_op tac 25 | 26 | let tclABSTRACTTERM name_op term tacK = 27 | (* What's the right default goal kind?*) 28 | transparent_abstract_term ~name_op term tacK 29 | 30 | end 31 | -------------------------------------------------------------------------------- /src/Parsers/Reflective/SemanticsOptimized.v: -------------------------------------------------------------------------------- 1 | Require Import Fiat.Parsers.Reflective.Syntax. 2 | Require Import Fiat.Parsers.Reflective.Semantics. 3 | Require Import Fiat.Common.List.Operations. 4 | Set Implicit Arguments. 5 | 6 | Local Open Scope list_scope. 7 | 8 | Module opt. 9 | Definition map {A B} := Eval cbv [List.map] in @List.map A B. 10 | Definition fold_left {A B} := Eval cbv [List.fold_left] in @List.fold_left A B. 11 | Definition nth' {A} := Eval cbv [nth'] in @List.nth' A. 12 | 13 | Definition interp_RLiteralTerm {T} (t : RLiteralTerm T) : interp_TypeCode T 14 | := Eval cbv [interp_RLiteralTerm] in 15 | match t with 16 | | RLC t' 17 | => interp_RLiteralTerm (RLC t') 18 | | RLNC t' 19 | => match t' in (RLiteralNonConstructor T') return interp_TypeCode T' with 20 | | Rnth' _ => nth' 21 | | Rmap _ _ => @map _ _ 22 | | Rfold_left _ _ => @fold_left _ _ 23 | | t'' => interp_RLiteralTerm (RLNC t'') 24 | end 25 | end. 26 | 27 | Definition interp_Term {T} (t : Term interp_TypeCode T) : interp_TypeCode T 28 | := interp_Term_gen (@interp_RLiteralTerm) t. 29 | End opt. 30 | -------------------------------------------------------------------------------- /src/Examples/DnsServer/TODO.txt: -------------------------------------------------------------------------------- 1 | General TODO 2 | 8/28/15 3 | 4 | - move generic DNS lemmas to QueryStructures 5 | - pull out big ideas from tuples_in_relation_satisfy_constraint_specific 6 | - Comp in predicate: relation-building query notation 7 | - Fiat wishlist (tuples, monads, etc.) 8 | - authoritative server needs to be patched for packet changes 9 | (in progress, honeDns fails) 10 | - fill in stubs 11 | - pass rep around properly in process 12 | - Filter rows by record type and class 13 | - Bounded amount of work (delete a referral in SLIST when queried too many times) 14 | - Returning all answer/authority/additional instead of just one (re-hierarchizing rows into packet) 15 | - Proper SBELT IP 16 | - Dealing with CNAME; requires FueledFix 17 | - CNAME in answers and having that as the answer for the domain and the aliases (see RFC 1034, 6.2.7) 18 | - Inverse queries 19 | - variant types for cache pointers 20 | - caching opportunity with SLIST_ORDER (remove table, compute order whenever needed -> generate table) 21 | - TTL optimization? 22 | - put constraints back on tables 23 | - wrapper: time monad 24 | - Fiat schema/tuple autocomplete (Emacs hacking) 25 | - Parallelism (long term research goal) 26 | - Coq clippy thing 27 | -------------------------------------------------------------------------------- /src/Common/Tactics/SplitInContext.v: -------------------------------------------------------------------------------- 1 | Require Export Fiat.Common.Coq__8_4__8_5__Compat. 2 | (* Coq's build in tactics don't work so well with things like [iff] 3 | so split them up into multiple hypotheses *) 4 | Ltac split_in_context_by ident funl funr tac := 5 | repeat match goal with 6 | | [ H : context p [ident] |- _ ] => 7 | let H0 := context p[funl] in let H0' := eval simpl in H0 in assert H0' by (tac H); 8 | let H1 := context p[funr] in let H1' := eval simpl in H1 in assert H1' by (tac H); 9 | clear H 10 | end. 11 | Ltac split_in_context ident funl funr := 12 | split_in_context_by ident funl funr ltac:(fun H => apply H). 13 | 14 | Ltac split_iff := split_in_context iff (fun a b : Prop => a -> b) (fun a b : Prop => b -> a). 15 | 16 | Ltac split_and' := 17 | repeat match goal with 18 | | [ H : ?a /\ ?b |- _ ] => let H0 := fresh in let H1 := fresh in 19 | assert (H0 := fst H); assert (H1 := snd H); clear H 20 | end. 21 | Ltac split_and := split_and'; split_in_context and (fun a b : Type => a) (fun a b : Type => b). 22 | -------------------------------------------------------------------------------- /src/Examples/bedrock_main.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | #define HEAP_SIZE (100*1024*1024) 5 | #define STACK_SIZE 1000 6 | #define MAX_LEN ((HEAP_SIZE-1) / 2 - 2) 7 | 8 | unsigned bedrock_heap[HEAP_SIZE+STACK_SIZE]; 9 | 10 | unsigned bedrock_main(); 11 | 12 | int main(int argc, char *argv[]) { 13 | if (argc < 2) { 14 | puts("Please run me with the desired list size as a command-line argument."); 15 | return 1; 16 | } 17 | 18 | unsigned size = atoi(argv[1]); 19 | 20 | if (size >= MAX_LEN) { 21 | printf("Length must be < %u.\n", MAX_LEN); 22 | return 1; 23 | } 24 | 25 | bedrock_heap[0] = 4 * (2*size + 3); 26 | bedrock_heap[1] = (size == 0 ? 0 : 3*4); 27 | bedrock_heap[2*size + 3] = HEAP_SIZE - 5 - 2*size; 28 | bedrock_heap[2*size + 4] = 0; 29 | unsigned sum = 0, i; 30 | 31 | for (i = 0; i < size; ++i) { 32 | int n = rand(); 33 | sum += n; 34 | bedrock_heap[2*i + 3] = n; 35 | bedrock_heap[2*i + 4] = (i == size-1 ? 0 : 4 * (2 * i + 5)); 36 | } 37 | 38 | printf("EXPECTING: %u\n", sum); 39 | printf(" ANSWER: %u\n", bedrock_main()); 40 | return 0; 41 | } 42 | 43 | __attribute__((noreturn)) void sys_abort() { 44 | puts("Bedrock program terminated."); 45 | exit(0); 46 | } 47 | -------------------------------------------------------------------------------- /src/Parsers/Reflective/ParserSoundness.v: -------------------------------------------------------------------------------- 1 | 2 | Require Import Fiat.Parsers.Reflective.Semantics. 3 | Require Import Fiat.Parsers.Reflective.ParserSyntax. 4 | Require Import Fiat.Parsers.Reflective.ParserSemantics. 5 | Require Import Fiat.Parsers.Reflective.PartialUnfold. 6 | Require Import Fiat.Parsers.Reflective.ParserPartialUnfold. 7 | Require Import Fiat.Parsers.Reflective.ParserLogicalRelations. 8 | Set Implicit Arguments. 9 | 10 | Section polypnormalize. 11 | Context (is_valid_nonterminal : list nat -> nat -> bool) 12 | (strlen : nat) 13 | (char_at_matches_interp : nat -> Reflective.RCharExpr Ascii.ascii -> bool) 14 | (split_string_for_production : nat * (nat * nat) -> nat -> nat -> list nat). 15 | 16 | Let interp {T} := interp_has_parse_term (T := T) is_valid_nonterminal strlen char_at_matches_interp split_string_for_production. 17 | 18 | Lemma polypnormalize_correct {T} (term : polyhas_parse_term T) 19 | : ParserSyntaxEquivalence.has_parse_term_equiv 20 | nil 21 | (term interp_TypeCode) (term (normalized_of interp_TypeCode)) 22 | -> interp (term _) = interp (polypnormalize term _). 23 | Proof. 24 | subst interp. 25 | apply polypnormalize_correct; assumption. 26 | Qed. 27 | End polypnormalize. 28 | -------------------------------------------------------------------------------- /src/Parsers/Reflective/ParserSemanticsOptimized.v: -------------------------------------------------------------------------------- 1 | 2 | Require Import Fiat.Parsers.Reflective.Semantics. 3 | Require Import Fiat.Parsers.Reflective.ParserSemantics. 4 | Require Import Fiat.Parsers.Reflective.SemanticsOptimized. 5 | Set Implicit Arguments. 6 | 7 | Module opt. 8 | Definition interp_has_parse_term {T} 9 | := Eval cbv [step_option_rec interp_has_parse_term'] in 10 | @interp_has_parse_term' T (@opt.interp_Term). 11 | End opt. 12 | Declare Reduction propt_red := cbv [opt.map opt.fold_left opt.nth' opt.interp_RLiteralTerm opt.interp_Term interp_TypeCode interp_SimpleTypeCode interp_SimpleTypeCode_step Reflective.interp_RCharExpr Reflective.irbeq Reflective.ascii_interp_RCharExpr_data opt.interp_has_parse_term]. 13 | Ltac propt_red := cbv [opt.map opt.fold_left opt.nth' opt.interp_RLiteralTerm opt.interp_Term interp_TypeCode interp_SimpleTypeCode interp_SimpleTypeCode_step Reflective.interp_RCharExpr Reflective.irbeq Reflective.ascii_interp_RCharExpr_data opt.interp_has_parse_term]. 14 | Ltac propt_red_in H := cbv [opt.map opt.fold_left opt.nth' opt.interp_RLiteralTerm opt.interp_Term interp_TypeCode interp_SimpleTypeCode interp_SimpleTypeCode_step Reflective.interp_RCharExpr Reflective.irbeq Reflective.ascii_interp_RCharExpr_data opt.interp_has_parse_term] in H. 15 | -------------------------------------------------------------------------------- /src/Parsers/Grammars/Trivial.v: -------------------------------------------------------------------------------- 1 | (** * Definition of ε, the CFG accepting only "" *) 2 | Require Import Coq.Strings.String Coq.Lists.List. 3 | Require Import Fiat.Parsers.ContextFreeGrammar.Core. 4 | Require Import Fiat.Parsers.ContextFreeGrammar.PreNotations. 5 | 6 | Set Implicit Arguments. 7 | 8 | Section generic. 9 | Context {Char} {HSLM : StringLikeMin Char} {HSL : StringLike Char}. 10 | 11 | Definition trivial_pregrammar : pregrammar' Char := 12 | {| pregrammar_productions := (""%string, nil::nil)::nil |}. 13 | 14 | Definition trivial_grammar : grammar Char := trivial_pregrammar. 15 | 16 | Definition trivial_grammar_parses_empty_string {s} (H : length s = 0) 17 | : parse_of_grammar s trivial_grammar. 18 | Proof. 19 | hnf; simpl. 20 | apply ParseHead. 21 | constructor; assumption. 22 | Defined. 23 | 24 | Lemma trivial_grammar_parses_only_empty_string s : parse_of_grammar s trivial_grammar -> length s = 0. 25 | Proof. 26 | intro H; hnf in H; simpl in H. 27 | repeat match goal with 28 | | _ => reflexivity 29 | | _ => assumption 30 | | [ H : parse_of _ _ _ |- _ ] => inversion_clear H 31 | | [ H : parse_of_production _ _ _ |- _ ] => inversion_clear H 32 | end. 33 | Qed. 34 | End generic. 35 | -------------------------------------------------------------------------------- /src/CertifiedExtraction/Extraction/QueryStructures/WrappersAreConsistent.v: -------------------------------------------------------------------------------- 1 | Require Import Fiat.CertifiedExtraction.Extraction.QueryStructures.Wrappers. 2 | Require Import Fiat.CertifiedExtraction.ADT2CompileUnit. 3 | Require Import CertifiedExtraction.FacadeWrappers. 4 | Require Import CertifiedExtraction.Core. 5 | Require Import Bedrock.Memory. 6 | 7 | (* FIXME: Just embed the definition of ‘Good’ into the ‘FacadeWrapper’ typeclass *) 8 | 9 | Definition Good_bool {av} 10 | : GoodWrapper av bool. 11 | Proof. 12 | refine {| gWrap := _; 13 | gWrapTag := false |}; simpl; eauto. 14 | Defined. 15 | 16 | Definition Good_listW 17 | : GoodWrapper QsADTs.ADTValue (list W). 18 | Proof. 19 | refine {| gWrap := WrapInstance (H := QS_WrapWordList); 20 | gWrapTag := true |}; 21 | simpl; eauto. 22 | Defined. 23 | 24 | Definition Good_BedrockWTuple 25 | : GoodWrapper QsADTs.ADTValue (TuplesF.GenericTuple W). 26 | Proof. 27 | refine {| gWrap := WrapInstance (H := QS_WrapBedrockWTuple); 28 | gWrapTag := true 29 | |}; intros; unfold wrap; simpl; eauto. 30 | Defined. 31 | 32 | Definition Good_W {av} 33 | : GoodWrapper av W. 34 | Proof. 35 | refine {| gWrap := _; 36 | gWrapTag := false 37 | |}; intros; unfold wrap; simpl; eauto. 38 | Defined. 39 | -------------------------------------------------------------------------------- /src/Fiat4Monitors/MonitorRepInv.v: -------------------------------------------------------------------------------- 1 | Require Import Coq.Lists.List 2 | Coq.Program.Program 3 | Coq.Arith.Arith. 4 | Require Import 5 | Fiat.ADT 6 | Fiat.ADT.ComputationalADT 7 | Fiat.ADTNotation 8 | Fiat.ADTRefinement 9 | Fiat.ADTRefinement.BuildADTRefinements 10 | Fiat.Fiat4Monitors.RADL_Topics 11 | Fiat.Fiat4Monitors.RADL_Messages 12 | Fiat.Fiat4Monitors.RADL_Flags 13 | Fiat.Fiat4Monitors.RADL_Nodes 14 | Fiat.Fiat4Monitors.MonitorADTs. 15 | 16 | Require Import Bedrock.Platform.Facade.DFacade 17 | Bedrock.Platform.Facade.Notations 18 | Bedrock.Platform.Cito.ADT 19 | Bedrock.Platform.Cito.RepInv. 20 | 21 | Import Adt. 22 | 23 | (* This is a placeholder for a legitimate description of the memory layout. *) 24 | Definition Monitors_rep_inv p (adtvalue : ADTValue) : HProp := 25 | match adtvalue with 26 | | _ => p =?> 1 27 | end%Sep. 28 | 29 | Module Ri <: RepInv Adt. 30 | 31 | Definition RepInv := W -> ADTValue -> HProp. 32 | 33 | Definition rep_inv := Monitors_rep_inv. 34 | 35 | Lemma rep_inv_ptr : forall p a, rep_inv p a ===> p =?> 1 * any. 36 | destruct a; 37 | unfold rep_inv, Monitors_rep_inv; simpl; 38 | sepLemma; apply any_easy. 39 | Qed. 40 | 41 | End Ri. 42 | -------------------------------------------------------------------------------- /src/QueryStructure/Specification/Operations/Delete.v: -------------------------------------------------------------------------------- 1 | Require Import Coq.Lists.List 2 | Coq.Strings.String 3 | Coq.Sets.Ensembles 4 | Coq.Arith.Arith 5 | Fiat.Computation.Core 6 | Fiat.ADT.ADTSig 7 | Fiat.ADT.Core 8 | Fiat.Common.ilist 9 | Fiat.Common.StringBound 10 | Fiat.Common.Ensembles.IndexedEnsembles 11 | Fiat.ADTNotation.BuildADT 12 | Fiat.ADTNotation.BuildADTSig 13 | Fiat.QueryStructure.Specification.Representation.QueryStructureSchema 14 | Fiat.QueryStructure.Specification.Representation.QueryStructure 15 | Fiat.QueryStructure.Specification.Operations.Mutate. 16 | (* We augment [QSDeleteSpec] so that delete also returns a list of the 17 | deleted Tuples. *) 18 | 19 | Definition QSDelete {qs_schema} 20 | (qs : QueryStructure qs_schema) 21 | (Ridx : Fin.t _) 22 | (DeletedTuples : @Ensemble (@RawTuple (GetNRelSchemaHeading _ Ridx))) := 23 | QSMutate qs Ridx (EnsembleDelete (GetRelation qs Ridx) DeletedTuples). 24 | 25 | Opaque QSDelete. 26 | 27 | Notation "'Delete' b 'from' r '!' Ridx 'where' Ens" := 28 | (QSDelete r (ibound (indexb (@Build_BoundedIndex _ _ (QSschemaNames _) Ridx%string _))) (fun b => Ens)) 29 | (r at level 0, at level 80) : QuerySpec_scope. 30 | -------------------------------------------------------------------------------- /src/Narcissus/Formats/Base/LaxTerminalFormat.v: -------------------------------------------------------------------------------- 1 | Require Import 2 | Coq.ZArith.ZArith 3 | Coq.Strings.String 4 | Coq.Vectors.Vector. 5 | 6 | Require Import 7 | Fiat.Computation 8 | Fiat.Narcissus.Common.Specs. 9 | 10 | Section LaxTerminalFormat. 11 | 12 | Context {S : Type}. (* Source type *) 13 | Context {T : Type}. (* Target type *) 14 | Context {cache : Cache}. (* State type *) 15 | Context {monoid : Monoid T}. (* Target type is a monoid *) 16 | 17 | Definition LaxTerminal_Format 18 | : FormatM (S * T) T := 19 | fun st env => ret (snd st, env). 20 | 21 | Definition LaxTerminal_Decode 22 | (s : S) 23 | : DecodeM (S * T) T := 24 | fun t env => Some (s, t, env). 25 | 26 | Definition LaxTerminal_Encode 27 | : EncodeM (S * T) T := 28 | fun st env => Some (snd st, env). 29 | 30 | Lemma CorrectEncoder_LaxTerminal 31 | : CorrectEncoder LaxTerminal_Format LaxTerminal_Encode. 32 | Proof. 33 | unfold CorrectEncoder, LaxTerminal_Format, LaxTerminal_Encode; 34 | split; intros. 35 | - injections; 36 | repeat computes_to_econstructor; eauto using measure_mempty. 37 | - discriminate. 38 | Qed. 39 | 40 | End LaxTerminalFormat. 41 | 42 | Notation "'?*'" := (LaxTerminal_Format) (at level 99) : format_scope. 43 | -------------------------------------------------------------------------------- /src/Parsers/Reflective/ParserSoundnessOptimized.v: -------------------------------------------------------------------------------- 1 | 2 | Require Import Fiat.Parsers.Reflective.Semantics. 3 | Require Import Fiat.Parsers.Reflective.ParserSyntax. 4 | Require Import Fiat.Parsers.Reflective.ParserSemanticsOptimized. 5 | Require Import Fiat.Parsers.Reflective.ParserSoundness. 6 | Require Import Fiat.Parsers.Reflective.PartialUnfold. 7 | Require Import Fiat.Parsers.Reflective.ParserPartialUnfold. 8 | Set Implicit Arguments. 9 | 10 | Module opt. 11 | Section polypnormalize. 12 | Context (is_valid_nonterminal : list nat -> nat -> bool) 13 | (strlen : nat) 14 | (char_at_matches_interp : nat -> Reflective.RCharExpr Ascii.ascii -> bool) 15 | (split_string_for_production : nat * (nat * nat) -> nat -> nat -> list nat). 16 | 17 | Let interp {T} := opt.interp_has_parse_term (T := T) is_valid_nonterminal strlen char_at_matches_interp split_string_for_production. 18 | 19 | Lemma polypnormalize_correct {T} (term : polyhas_parse_term T) 20 | : ParserSyntaxEquivalence.has_parse_term_equiv 21 | nil 22 | (term interp_TypeCode) (term (normalized_of interp_TypeCode)) 23 | -> interp (term _) = interp (polypnormalize term _). 24 | Proof. 25 | apply polypnormalize_correct; assumption. 26 | Qed. 27 | End polypnormalize. 28 | End opt. 29 | -------------------------------------------------------------------------------- /src/CertifiedExtraction/StringMapUtils.v: -------------------------------------------------------------------------------- 1 | Require Import CertifiedExtraction.FMapUtils. 2 | Require Export Bedrock.Memory Bedrock.Platform.Facade.DFacade. 3 | Require Export Bedrock.Platform.Cito.StringMap Bedrock.Platform.Cito.StringMapFacts. 4 | 5 | Module Export MoreStringMapFacts := WMoreFacts_fun (StringMap.E) (StringMap). 6 | 7 | Global Open Scope map_scope. 8 | 9 | Lemma urgh : (subrelation eq (Basics.flip Basics.impl)). 10 | Proof. 11 | repeat red; intros; subst; assumption. 12 | Qed. 13 | 14 | (* NOTE: Why is this needed? *) 15 | Hint Resolve urgh : typeclass_instances. 16 | 17 | (* Lemma Bug: *) 18 | (* forall k1 k2 (st: StringMap.t nat) (x : nat), *) 19 | (* StringMap.MapsTo k1 x st -> *) 20 | (* match StringMap.find k2 (StringMap.add k2 x (StringMap.add k1 x st)) with *) 21 | (* | Some _ => True *) 22 | (* | None => True *) 23 | (* end. *) 24 | (* Proof. *) 25 | (* intros ** H. *) 26 | (* setoid_rewrite <- (StringMapUtils.add_redundant_cancel H). *) 27 | (* (* Inifinite loop unless `urgh' is added as a hint *) *) 28 | (* Abort. *) 29 | 30 | Require Import Coq.Setoids.Setoid. 31 | 32 | Add Parametric Morphism {av} : (@StringMap.find av) 33 | with signature (eq ==> StringMap.Equal ==> eq) 34 | as find_Morphism. 35 | Proof. 36 | intros; erewrite find_m; intuition. 37 | Qed. 38 | -------------------------------------------------------------------------------- /src/Common/Tactics/DestructHead.v: -------------------------------------------------------------------------------- 1 | Require Import Fiat.Common.Tactics.Head. 2 | Require Import Fiat.Common.Tactics.DestructHyps. 3 | 4 | Ltac destruct_head_matcher T HT := 5 | match head HT with 6 | | T => idtac 7 | end. 8 | Ltac destruct_head T := destruct_all_matches ltac:(destruct_head_matcher T). 9 | Ltac destruct_one_head T := destruct_one_match ltac:(destruct_head_matcher T). 10 | Ltac destruct_head' T := destruct_all_matches' ltac:(destruct_head_matcher T). 11 | 12 | Ltac inversion_head T := inversion_all_matches ltac:(destruct_head_matcher T). 13 | Ltac inversion_one_head T := inversion_one_match ltac:(destruct_head_matcher T). 14 | Ltac inversion_head' T := inversion_all_matches' ltac:(destruct_head_matcher T). 15 | 16 | 17 | Ltac head_hnf_matcher T HT := 18 | match head_hnf HT with 19 | | T => idtac 20 | end. 21 | Ltac destruct_head_hnf T := destruct_all_matches ltac:(head_hnf_matcher T). 22 | Ltac destruct_one_head_hnf T := destruct_one_match ltac:(head_hnf_matcher T). 23 | Ltac destruct_head_hnf' T := destruct_all_matches' ltac:(head_hnf_matcher T). 24 | 25 | Ltac inversion_head_hnf T := inversion_all_matches ltac:(head_hnf_matcher T). 26 | Ltac inversion_one_head_hnf T := inversion_one_match ltac:(head_hnf_matcher T). 27 | Ltac inversion_head_hnf' T := inversion_all_matches' ltac:(head_hnf_matcher T). 28 | -------------------------------------------------------------------------------- /src/CertifiedExtraction/Extraction/QueryStructures/Basics.v: -------------------------------------------------------------------------------- 1 | Require Export Fiat.Computation.Notations. 2 | Require Export Fiat.ADT.Core Fiat.Computation.Core. 3 | Require Export Fiat.QueryStructure.Implementation.DataStructures.BagADT.QueryStructureImplementation. 4 | 5 | Require Export Bedrock.Platform.Facade.examples.TuplesF. 6 | Require Export CertifiedExtraction.Utils. 7 | Require Export Bedrock.Memory. 8 | 9 | Notation BedrockWElement := (@TuplesF.IndexedElement (GenericTuple W)). 10 | Notation BedrockWBag := (@TuplesF.IndexedEnsemble (GenericTuple W)). 11 | 12 | Fixpoint MakeVectorOfW N : Vector.t Type N := 13 | match N with 14 | | O => Vector.nil Type 15 | | S x => Vector.cons Type W x (MakeVectorOfW x) 16 | end. 17 | 18 | Definition MakeWordHeading (N: nat) := 19 | {| NumAttr := N; 20 | AttrList := MakeVectorOfW N |}. 21 | 22 | Notation FiatWTuple N := (@RawTuple (MakeWordHeading N)). 23 | Notation FiatWElement N := (@IndexedEnsembles.IndexedElement (FiatWTuple N)). 24 | Notation FiatWBag N := (@IndexedEnsembles.IndexedEnsemble (FiatWTuple N)). 25 | 26 | Lemma MakeWordHeading_allWords : 27 | forall {N} (idx: Fin.t N), 28 | Domain (MakeWordHeading N) idx = W. 29 | Proof. 30 | unfold MakeWordHeading; induction idx. 31 | - reflexivity. 32 | - unfold Domain in *; simpl in *; assumption. 33 | Defined. 34 | -------------------------------------------------------------------------------- /Bedrock/Memory.v: -------------------------------------------------------------------------------- 1 | Require Import Bedrock.Word. 2 | 3 | Definition B := word 8. 4 | Definition W := word 32. 5 | 6 | Section mem_ops. 7 | Variable addr mem : Type. 8 | Variable footprint_w : addr -> addr * addr * addr * addr. 9 | 10 | Variable mem_get : mem -> addr -> option B. 11 | 12 | Definition mem_get_word (implode : B * B * B * B -> W) (p : addr) (m : mem) 13 | : option W := 14 | let '(a,b,c,d) := footprint_w p in 15 | match mem_get m a , mem_get m b , mem_get m c , mem_get m d with 16 | | Some a , Some b , Some c , Some d => 17 | Some (implode (a,b,c,d)) 18 | | _ , _ , _ , _ => None 19 | end. 20 | 21 | Variable mem_set : mem -> addr -> B -> option mem. 22 | 23 | Definition mem_set_word (explode : W -> B * B * B * B) (p : addr) (v : W) 24 | (m : mem) : option mem := 25 | let '(a,b,c,d) := footprint_w p in 26 | let '(av,bv,cv,dv) := explode v in 27 | match mem_set m d dv with 28 | | Some m => match mem_set m c cv with 29 | | Some m => match mem_set m b bv with 30 | | Some m => mem_set m a av 31 | | None => None 32 | end 33 | | None => None 34 | end 35 | | None => None 36 | end. 37 | 38 | End mem_ops. 39 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014, Massachusetts Institute of Technology 2 | 3 | Authors: Benjamin Delaware 4 | Clément Pit--Claudel 5 | Jason Gross 6 | Adam Chlipala 7 | 8 | 9 | Permission is hereby granted, free of charge, to any person obtaining a copy 10 | of this software and associated documentation files (the "Software"), to deal 11 | in the Software without restriction, including without limitation the rights 12 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 13 | copies of the Software, and to permit persons to whom the Software is 14 | furnished to do so, subject to the following conditions: 15 | 16 | The above copyright notice and this permission notice shall be included in 17 | all copies or substantial portions of the Software. 18 | 19 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 20 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 21 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 22 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 23 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 24 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 25 | THE SOFTWARE. -------------------------------------------------------------------------------- /src/Narcissus/Stores/Cache.v: -------------------------------------------------------------------------------- 1 | Require Import Coq.Lists.List 2 | Fiat.Computation. 3 | 4 | Set Implicit Arguments. 5 | 6 | Class Cache := 7 | { CacheFormat : Type; 8 | CacheDecode : Type; 9 | Equiv : CacheFormat -> CacheDecode -> Prop }. 10 | 11 | Class CacheAdd (cache : Cache) (T : Type) := 12 | { addE : CacheFormat -> T -> CacheFormat; 13 | addD : CacheDecode -> T -> CacheDecode; 14 | add_correct : forall ce cd t, Equiv ce cd -> Equiv (addE ce t) (addD cd t) }. 15 | 16 | Class CacheAdd_Guarded (cache : Cache) 17 | (T : Type) 18 | (T_OK : T -> CacheFormat -> CacheDecode -> Prop) := 19 | { addE_G : CacheFormat -> T -> CacheFormat; 20 | addD_G : CacheDecode -> T -> CacheDecode; 21 | add_correct_G : forall ce cd t, 22 | Equiv ce cd 23 | -> T_OK t ce cd 24 | -> Equiv (addE_G ce t) (addD_G cd t) }. 25 | 26 | Class CachePeek (cache : Cache) (T : Type):= 27 | { peekE : CacheFormat -> T; 28 | peekD : CacheDecode -> T; 29 | peek_correct : forall ce cd, Equiv ce cd -> peekE ce = peekD cd }. 30 | 31 | Class CacheGet (cache : Cache) (P Q : Type) := 32 | { getE : CacheFormat -> P -> list Q; 33 | getD : CacheDecode -> Q -> option P; 34 | get_correct : forall ce cd p q, 35 | Equiv ce cd 36 | -> (getD cd q = Some p <-> In q (getE ce p)) 37 | }. 38 | -------------------------------------------------------------------------------- /src/CertifiedExtraction/Utils.v: -------------------------------------------------------------------------------- 1 | Require Import 2 | Computation.Core. 3 | Require Export 4 | CertifiedExtraction.Core 5 | CertifiedExtraction.PureUtils 6 | CertifiedExtraction.FacadeUtils. 7 | 8 | Ltac cleanup := 9 | match goal with 10 | | _ => cleanup_pure 11 | | _ => cleanup_facade_pure 12 | | _ => progress computes_to_inv 13 | | [ H: wrap _ = wrap _ |- _ ] => apply wrap_inj in H 14 | | [ H: NTSome _ = NTSome _ |- _ ] => inversion H; unfold_and_subst; clear H 15 | | [ |- context[NameTagAsStringOption NTNone] ] => cbv [NameTagAsStringOption] 16 | | [ H: context[NameTagAsStringOption NTNone] |- _ ] => may_touch H; cbv [NameTagAsStringOption] in H 17 | | [ |- context[NameTagAsStringOption (NTSome _)] ] => cbv [NameTagAsStringOption] 18 | | [ H: context[NameTagAsStringOption (NTSome _)] |- _ ] => may_touch H; cbv [NameTagAsStringOption] in H 19 | end. 20 | 21 | Ltac wipe := 22 | repeat match goal with 23 | | [ H: ?a = ?a |- _ ] => clear dependent H 24 | | [ H: forall _: State _, _ |- _ ] => clear dependent H 25 | | [ H: ?h |- _ ] => 26 | let hd := head_constant h in 27 | match hd with 28 | | @Learnt => clear dependent H 29 | | @Safe => clear dependent H 30 | | @ProgOk => clear dependent H 31 | end 32 | end. 33 | -------------------------------------------------------------------------------- /src/Common/Tactics/SpecializeBy.v: -------------------------------------------------------------------------------- 1 | Require Export Fiat.Common.Coq__8_4__8_5__Compat. 2 | Ltac transparent_specialize_one H arg := 3 | first [ let test := eval unfold H in H in idtac; 4 | let H' := fresh in rename H into H'; pose (H' arg) as H; subst H' 5 | | specialize (H arg) ]. 6 | 7 | (** try to specialize all non-dependent hypotheses using [tac], maintaining transparency *) 8 | Ltac guarded_specialize_by' tac guard_tac := 9 | idtac; 10 | match goal with 11 | | [ H : ?A -> ?B |- _ ] 12 | => guard_tac H; 13 | let H' := fresh in 14 | assert (H' : A) by tac; 15 | transparent_specialize_one H H'; 16 | try clear H' (* if [H] was transparent, [H'] will remain *) 17 | end. 18 | Ltac specialize_by' tac := guarded_specialize_by' tac ltac:(fun _ => idtac). 19 | 20 | Ltac specialize_by tac := repeat specialize_by' tac. 21 | 22 | (** [specialize_by auto] should not mean [specialize_by ( auto 23 | with * )]!!!!!!! (see 24 | https://coq.inria.fr/bugs/show_bug.cgi?id=4966) We fix this design 25 | flaw. *) 26 | Tactic Notation "specialize_by" tactic3(tac) := specialize_by tac. 27 | 28 | (** A marginally faster version of [specialize_by assumption] *) 29 | Ltac specialize_by_assumption := 30 | repeat match goal with 31 | | [ H : ?T, H' : (?T -> ?U)%type |- _ ] => specialize (H' H) 32 | end. 33 | -------------------------------------------------------------------------------- /src/Common/Tactics/transparent_abstract_plugin.ml4.v85: -------------------------------------------------------------------------------- 1 | open Transparent_abstract_tactics 2 | open Constrarg 3 | 4 | (*let tclABSTRACT2 name_op tac gl = 5 | let s = match name_op with 6 | | Some s -> s 7 | | None -> Nameops.add_suffix (Pfedit.get_current_proof_name ()) "_term" 8 | in *) 9 | 10 | 11 | (* 12 | 13 | TACTIC EXTEND abstracttermas 14 | | [ "cache_term" constr(term) "as" ident(name) "run" tactic(tacK)] -> 15 | [ fun gl -> TRANSPARENT_ABSTRACT.tclABSTRACTTERM (Some name) term tacK gl ] 16 | END 17 | 18 | TACTIC EXTEND abstractterm 19 | | [ "cache_term" constr(term) "run" tactic(tacK) ] -> 20 | [ fun gl -> TRANSPARENT_ABSTRACT.tclABSTRACTTERM None term tacK gl ] 21 | END *) 22 | 23 | DECLARE PLUGIN "transparent_abstract_plugin" 24 | 25 | TACTIC EXTEND transparentabstract 26 | | [ "cache" tactic(tac) "as" ident(name)] 27 | -> [ TRANSPARENT_ABSTRACT.tclTRABSTRACT (Some name) (Tacinterp.eval_tactic tac) ] 28 | END 29 | 30 | TACTIC EXTEND abstracttermas 31 | | [ "cache_term" constr(term) "as" ident(name) "run" tactic(tacK)] -> 32 | [ TRANSPARENT_ABSTRACT.tclABSTRACTTERM (Some name) term tacK ] 33 | END 34 | 35 | TACTIC EXTEND abstractterm 36 | | [ "cache_term" constr(term) "run" tactic(tacK) ] -> 37 | [ TRANSPARENT_ABSTRACT.tclABSTRACTTERM None term tacK ] 38 | END;; 39 | -------------------------------------------------------------------------------- /src/Parsers/Refinement/SharpenedABStarParseTree.v: -------------------------------------------------------------------------------- 1 | (** Sharpened ADT for (ab)* *) 2 | Require Import Fiat.Parsers.Grammars.ABStar. 3 | Require Import Fiat.Parsers.Refinement.Tactics. 4 | Require Import Fiat.Parsers.Refinement.SharpenedABStar. 5 | 6 | Definition parser : ParserInterface.Parser ab_star_grammar String.string_stringlike. 7 | Proof. 8 | let b := make_Parser (@ComputationalSplitter _ String.string_stringlike _ _) in 9 | exact b. 10 | Defined. 11 | 12 | Definition ab_star_parser_informative_opaque (str : Coq.Strings.String.string) 13 | : option (parse_of_item ab_star_grammar str (NonTerminal (Start_symbol ab_star_grammar))). 14 | Proof. 15 | Time make_parser_informative_opaque (@ComputationalSplitter _ String.string_stringlike _ _). (* 0.82 s *) 16 | Defined. 17 | 18 | Goal forall b, ab_star_parser_informative_opaque "" = b. 19 | Proof. 20 | intro. 21 | let LHS := match goal with |- ?LHS = _ => LHS end in 22 | let LHS := (eval hnf in LHS) in 23 | change (LHS = b). 24 | Abort. 25 | 26 | Definition ab_star_parser_informative (str : Coq.Strings.String.string) 27 | : option (@simple_parse_of_item Ascii.ascii). 28 | Proof. 29 | Time make_parser_informative (@ComputationalSplitter _ String.string_stringlike _ _). (* 0.124 s *) 30 | Defined. 31 | 32 | Goal exists s, ab_star_parser_informative "" = Some s. 33 | Proof. 34 | eexists. 35 | compute. 36 | reflexivity. 37 | Qed. 38 | -------------------------------------------------------------------------------- /src/ComputationalEnsembles/Laws.v: -------------------------------------------------------------------------------- 1 | Require Import Coq.Classes.Morphisms Coq.Lists.List. 2 | Require Import Fiat.ComputationalEnsembles.Core Fiat.Computation. 3 | Require Import Fiat.Common.Ensembles.Tactics Fiat.Common.Ensembles. 4 | 5 | Set Implicit Arguments. 6 | 7 | Lemma Ensemble_fold_right_simpl {A B} (f : A -> B -> B) b S 8 | : refineEquiv (@fold_right A B (fun a b' => ret (f a b')) (ret b) S) 9 | (ls <- to_list S; 10 | ret (List.fold_right f b ls)). 11 | Proof. 12 | unfold fold_right. 13 | f_equiv; intro ls; simpl. 14 | induction ls; simpl; try reflexivity. 15 | rewrite IHls. 16 | autorewrite with refine_monad. 17 | reflexivity. 18 | Qed. 19 | 20 | Lemma Ensemble_fold_right_simpl' {A B} f b S 21 | : refineEquiv (@Ensemble_fold_right A B f b S) 22 | (ls <- to_list S; 23 | ret (List.fold_right f b ls)). 24 | Proof. 25 | exact (Ensemble_fold_right_simpl f b S). 26 | Qed. 27 | 28 | Lemma Same_set__elements__Union {A} xs 29 | : Same_set A (elements xs) (List.fold_right (Union _) (Empty_set _) (map (Singleton _) xs)). 30 | Proof. 31 | induction xs; [ | simpl; rewrite <- IHxs; clear IHxs ]; 32 | Ensembles_t. 33 | Qed. 34 | 35 | Lemma Same_set__elements_cons__Union {A} x xs 36 | : Same_set A (elements (x::xs)) (Union A (Singleton _ x) (elements xs)). 37 | Proof. 38 | rewrite !Same_set__elements__Union; simpl; reflexivity. 39 | Qed. 40 | -------------------------------------------------------------------------------- /src/Parsers/ContextFreeGrammar/Fix/PreInterface.v: -------------------------------------------------------------------------------- 1 | Require Import Fiat.Parsers.ContextFreeGrammar.Core. 2 | Require Import Fiat.Parsers.ContextFreeGrammar.PreNotations. 3 | Require Import Fiat.Parsers.ContextFreeGrammar.Fix.FromAbstractInterpretationDefinitions. 4 | Require Import Fiat.Parsers.ContextFreeGrammar.Fix.Fix. 5 | Require Import Fiat.Parsers.ContextFreeGrammar.Fix.FromAbstractInterpretation. 6 | 7 | Module DataflowInput. 8 | Section input_data. 9 | Context {Char : Type}. 10 | 11 | Record t := 12 | { T : Type; 13 | fpdata : grammar_fixedpoint_lattice_data T; 14 | aidata : AbstractInterpretation (Char:=Char) }. 15 | End input_data. 16 | Global Arguments t : clear implicits. 17 | End DataflowInput. 18 | 19 | Module DataflowOutput. 20 | Definition t {Char} d G 21 | := @fold_grammar_data Char (DataflowInput.T d) (DataflowInput.fpdata d) (DataflowInput.aidata d) G. 22 | 23 | Section output_data. 24 | Context {Char : Type} 25 | {d : DataflowInput.t Char} 26 | {G : pregrammar' Char} 27 | (v : t d G). 28 | 29 | Definition t_data := Eval hnf in @fgd_fold_grammar _ _ _ _ _ v. 30 | Definition t_correct : Morphisms.pointwise_relation _ eq (lookup_state t_data) (lookup_state (fold_grammar G _)) 31 | := fgd_fold_grammar_correct. 32 | End output_data. 33 | Coercion t_data : t >-> aggregate_state. 34 | End DataflowOutput. 35 | -------------------------------------------------------------------------------- /src/Parsers/GenericBaseTypes.v: -------------------------------------------------------------------------------- 1 | (** * Definition of the generic part of the interface of the CFG parser *) 2 | Require Import Coq.Strings.String. 3 | Require Export Fiat.Common.Coq__8_4__8_5__Compat. 4 | 5 | Set Implicit Arguments. 6 | 7 | Section recursive_descent_parser. 8 | Context {Char : Type}. 9 | 10 | Class generic_parser_dataT := 11 | { parse_nt_T : Type; 12 | parse_item_T : Type; 13 | parse_production_T : Type; 14 | parse_productions_T : Type; 15 | ret_Terminal_false : Char -> parse_item_T; 16 | ret_Terminal_true : Char -> parse_item_T; 17 | ret_NonTerminal_false : String.string -> parse_item_T; 18 | ret_NonTerminal_true : String.string -> parse_nt_T -> parse_item_T; 19 | ret_production_cons : parse_item_T -> parse_production_T -> parse_production_T; 20 | ret_orb_production : parse_production_T -> parse_production_T -> parse_production_T; 21 | ret_orb_production_base : parse_production_T; 22 | ret_production_nil_true : parse_production_T; 23 | ret_production_nil_false : parse_production_T; 24 | ret_orb_productions : parse_production_T -> parse_productions_T -> parse_productions_T; 25 | ret_orb_productions_base : parse_productions_T; 26 | ret_nt : String.string -> parse_productions_T -> parse_nt_T; 27 | ret_nt_invalid : parse_nt_T }. 28 | End recursive_descent_parser. 29 | 30 | Arguments generic_parser_dataT : clear implicits. 31 | -------------------------------------------------------------------------------- /src/Narcissus/Automation/CacheEncoders.v: -------------------------------------------------------------------------------- 1 | Require Import 2 | Fiat.Common.ilist 3 | Fiat.Common.Tactics.HintDbExtra 4 | Fiat.Common.Tactics.TransparentAbstract 5 | Fiat.Common.Tactics.CacheStringConstant 6 | Fiat.Narcissus.BinLib.AlignedDecoders 7 | Fiat.Narcissus.BinLib.AlignedList. 8 | 9 | (* Tactics for caching intermediate encoder definitions. *) 10 | (* The current use case is for the various encoders for sums. *) 11 | 12 | Create HintDb formatCache. 13 | 14 | Ltac fold_encoders := 15 | (repeat foreach [ formatCache ] run (fun id => progress fold id in *)). 16 | 17 | Ltac cache_encoders := 18 | repeat match goal with 19 | | |- context [icons (fun (a : ?z) => @?f a) _] => 20 | let p' := fresh "encoder" in 21 | let H'' := fresh in 22 | assert True as H'' by 23 | (clear; 24 | (cache_term (fun a : z => f a) as p' run (fun id => fold id in *; add id to formatCache)) ; exact I); 25 | fold_encoders; clear H'' 26 | | |- context [align_format_list (fun (a : ?z) => @?f a) _ _] => 27 | let p' := fresh "encoder" in 28 | let H'' := fresh in 29 | assert True as H'' by 30 | (clear; 31 | (cache_term (fun a : z => f a) as p' run (fun id => fold id in *; add id to formatCache)) ; exact I); 32 | fold_encoders; clear H'' 33 | end. 34 | -------------------------------------------------------------------------------- /src/ADT/ADTHide.v: -------------------------------------------------------------------------------- 1 | Require Import Fiat.Common Fiat.Computation.Core Fiat.ADT.Core Coq.Sets.Ensembles. 2 | 3 | Section HideADT. 4 | 5 | Context {extSig : ADTSig}. 6 | (* The extended signature *) 7 | 8 | Context {resConstructorIndex : Type}. 9 | (* The restricted set of constructor indices *) 10 | 11 | Context {resMethodIndex : Type}. 12 | (* The restricted set of method indices *) 13 | 14 | Variable constructorMap : resConstructorIndex -> ConstructorIndex extSig. 15 | (* Map from restricted to extended constructor indices *) 16 | 17 | Variable methodMap : resMethodIndex -> MethodIndex extSig. 18 | (* Map from restricted to extended method indices *) 19 | 20 | Definition resSig := 21 | {| ConstructorIndex := resConstructorIndex; 22 | MethodIndex := resMethodIndex; 23 | ConstructorDom idx := ConstructorDom extSig (constructorMap idx); 24 | MethodDomCod idx := MethodDomCod extSig (methodMap idx) 25 | |}. 26 | (* The signature of the ADT with restricted constructor and method indices *) 27 | 28 | Definition HideADT (extADT : ADT extSig) : ADT resSig := 29 | match extADT with 30 | {| Rep := rep; 31 | Constructors := extConstructors; 32 | Methods := extMethods 33 | |} => 34 | Build_ADT resSig 35 | (fun idx => extConstructors (constructorMap idx)) 36 | (fun idx => extMethods (methodMap idx)) 37 | end. 38 | 39 | End HideADT. 40 | -------------------------------------------------------------------------------- /src/Narcissus/Formats/Base/StrictTerminalFormat.v: -------------------------------------------------------------------------------- 1 | Require Import 2 | Coq.ZArith.ZArith 3 | Coq.Strings.String 4 | Coq.Vectors.Vector. 5 | 6 | Require Import 7 | Fiat.Computation 8 | Fiat.Narcissus.Common.Specs. 9 | 10 | Section StrictTerminalFormat. 11 | 12 | Context {S : Type}. (* Source type *) 13 | Context {T : Type}. (* Target type *) 14 | Context {cache : Cache}. (* State type *) 15 | Context {monoid : Monoid T}. (* Target type is a monoid *) 16 | 17 | Definition StrictTerminal_Format 18 | : FormatM S T := 19 | fun a env => 20 | t <- {t | bin_measure t = 0}; 21 | ret (t, env). 22 | 23 | Definition StrictTerminal_Decode 24 | (s : S) 25 | : DecodeM S T := 26 | fun t env => 27 | If (beq_nat (bin_measure t) 0) 28 | Then Some (s, env) 29 | Else None. 30 | 31 | Definition StrictTerminal_Encode 32 | : EncodeM S T := 33 | fun a env => Some (mempty, env). 34 | 35 | Lemma CorrectEncoder_StrictTerminal 36 | : CorrectEncoder StrictTerminal_Format StrictTerminal_Encode. 37 | Proof. 38 | unfold CorrectEncoder, StrictTerminal_Format, StrictTerminal_Encode; 39 | split; intros. 40 | - injections; 41 | repeat computes_to_econstructor; eauto using measure_mempty. 42 | - discriminate. 43 | Qed. 44 | 45 | End StrictTerminalFormat. 46 | 47 | Notation "'ϵ'" := (StrictTerminal_Format) (at level 99) : format_scope. 48 | -------------------------------------------------------------------------------- /src/ADT/ADTSig.v: -------------------------------------------------------------------------------- 1 | Require Export Fiat.Common Fiat.Computation. 2 | 3 | (** Type of a constructor. *) 4 | Fixpoint constructorType (rep : Type) 5 | (dom : list Type) : Type := 6 | match dom with 7 | | nil => 8 | Comp rep (* Freshly constructed model *) 9 | | cons d dom' => 10 | d -> constructorType rep dom' (* Initialization arguments *) 11 | end. 12 | 13 | (** Type of a method. *) 14 | Fixpoint methodType' (rep : Type) 15 | (dom : list Type) 16 | (cod : option Type) : Type := 17 | match dom with 18 | | nil => 19 | match cod with 20 | | Some cod' => Comp (rep * cod') (* Final model and a return value *) 21 | | _ => Comp rep 22 | end 23 | | cons d dom' => 24 | d -> methodType' rep dom' cod (* Method arguments *) 25 | end. 26 | Definition methodType (rep : Type) 27 | (dom : list Type) 28 | (cod : option Type) : Type := 29 | rep -> methodType' rep dom cod. 30 | 31 | (* Signatures of ADT operations *) 32 | Record ADTSig := 33 | { 34 | (** The index set of constructors *) 35 | ConstructorIndex : Type; 36 | 37 | (** The index set of methods *) 38 | MethodIndex : Type; 39 | 40 | (** The representation-independent domain of constructors. *) 41 | ConstructorDom : ConstructorIndex -> list Type; 42 | 43 | (** The representation-independent domain and codomain of methods. *) 44 | MethodDomCod : MethodIndex -> (list Type) * (option Type) 45 | 46 | }. 47 | -------------------------------------------------------------------------------- /src/QueryStructure/Implementation/Constraints/ConstraintChecksUnfoldings.v: -------------------------------------------------------------------------------- 1 | Require Import Coq.Lists.List Coq.Strings.String Coq.Sets.Ensembles Coq.Arith.Arith 2 | Fiat.Common.ilist Fiat.Common.StringBound 3 | Fiat.Computation.Refinements.Iterate_Decide_Comp 4 | Fiat.QueryStructure.Specification.Representation.QueryStructureSchema 5 | Fiat.QueryStructure.Specification.Representation.QueryStructure 6 | Fiat.QueryStructure.Implementation.Constraints.ConstraintChecksRefinements 7 | Fiat.Common.IterateBoundedIndex 8 | Fiat.Common.DecideableEnsembles. 9 | 10 | (* We put all these simplification hints into a distinct file 11 | so we're not unfolding things all willy-nilly. *) 12 | Arguments Iterate_Decide_Comp _ _ / _ . 13 | Arguments SatisfiesCrossRelationConstraints _ _ _ _ _ / . 14 | Arguments BuildQueryStructureConstraints _ _ _ / . 15 | Arguments BuildQueryStructureConstraints' _ _ _ _ _ / . 16 | Arguments BuildQueryStructureConstraints_cons / . 17 | Arguments GetNRelSchemaHeading _ _ _ / . 18 | Arguments id _ _ / . 19 | 20 | Create HintDb refine_keyconstraints discriminated. 21 | (*Hint Rewrite refine_Any_DecideableSB_True : refine_keyconstraints.*) 22 | 23 | Arguments ith_Bounded _ _ _ _ _ _ / . 24 | Arguments SatisfiesAttributeConstraints _ _ _ / . 25 | Arguments SatisfiesTupleConstraints _ _ _ _ / . 26 | Arguments GetUnConstrRelation : simpl never. 27 | Arguments UpdateUnConstrRelation : simpl never. 28 | Arguments replace_BoundedIndex : simpl never. 29 | -------------------------------------------------------------------------------- /src/QueryStructure/Specification/Constraints/tupleAgree.v: -------------------------------------------------------------------------------- 1 | Require Import Coq.Lists.List 2 | Coq.Program.Program 3 | Fiat.QueryStructure.Specification.Representation.Heading 4 | Fiat.QueryStructure.Specification.Representation.Tuple 5 | Fiat.QueryStructure.Specification.Representation.Schema. 6 | 7 | Lemma tupleAgree_empty : 8 | forall {heading} (tup1 tup2: @RawTuple heading), 9 | tupleAgree tup1 tup2 nil <-> True. 10 | Proof. 11 | unfold tupleAgree; intuition. 12 | Qed. 13 | 14 | Lemma tupleAgree_unfold : 15 | forall {heading} (tup1 tup2: @RawTuple heading) attr more, 16 | tupleAgree tup1 tup2 (attr :: more) <-> 17 | (GetAttributeRaw tup1 attr = GetAttributeRaw tup2 attr) /\ tupleAgree tup1 tup2 more. 18 | Proof. 19 | unfold tupleAgree; simpl; split; intros; intuition; subst; intuition. 20 | Qed. 21 | 22 | Fixpoint tupleAgree_computational 23 | {h} 24 | (tup1 tup2 : @RawTuple h) 25 | (attrlist : list (Attributes h)) := 26 | match attrlist with 27 | | nil => True 28 | | attr :: more => GetAttributeRaw tup1 attr = GetAttributeRaw tup2 attr /\ tupleAgree_computational tup1 tup2 more 29 | end. 30 | 31 | Lemma tupleAgree_equivalence : 32 | forall {h} tup1 tup2 attrlist, 33 | @tupleAgree h tup1 tup2 attrlist <-> 34 | @tupleAgree_computational h tup1 tup2 attrlist. 35 | Proof. 36 | induction attrlist; simpl; intros. 37 | apply tupleAgree_empty. 38 | rewrite tupleAgree_unfold, IHattrlist. 39 | reflexivity. 40 | Qed. 41 | -------------------------------------------------------------------------------- /src/QueryStructure/Specification/Representation/Heading2.v: -------------------------------------------------------------------------------- 1 | Require Import Coq.Lists.List Coq.Strings.String Coq.Logic.FunctionalExtensionality Coq.Sets.Ensembles 2 | Fiat.Common.ilist Fiat.Common.StringBound Coq.Program.Program 3 | Fiat.QueryStructure.Specification.Representation.Notations. 4 | 5 | (* Notations for attributes. *) 6 | 7 | Record Attribute2 := 8 | { attrName2 : string; 9 | attrType2 : Type }. 10 | 11 | Infix "::" := Build_Attribute2 : Attribute_scope. 12 | 13 | Definition attrName_eq (cs : Attribute2) (idx : string) := 14 | if (string_dec (attrName2 cs) idx) then true else false . 15 | 16 | (* A heading describes a tuple as a set of Attributes 17 | and types. *) 18 | Record RawHeading2 := 19 | { NumAttr2 : nat; 20 | AttrList2 : Vector.t Type NumAttr2 }. 21 | 22 | Definition Attributes2 (heading : RawHeading2) : Set := Fin.t (NumAttr2 heading). 23 | 24 | Definition Domain2 (heading : RawHeading2) (idx : Attributes2 heading) : Type := 25 | Vector.nth (AttrList2 heading) idx. 26 | Arguments Domain2 : clear implicits. 27 | 28 | (* Notations for schemas. *) 29 | 30 | Record Heading2 := 31 | { HeadingRaw2 :> RawHeading2; 32 | HeadingNames2 : Vector.t string (NumAttr2 HeadingRaw2) }. 33 | 34 | Definition BuildHeading2 35 | {n} 36 | (attrs : Vector.t Attribute2 n) 37 | : Heading2 := 38 | {| HeadingRaw2 := {| NumAttr2 := n; 39 | AttrList2 := Vector.map attrType2 attrs |}; 40 | HeadingNames2 := Vector.map attrName2 attrs |}. 41 | -------------------------------------------------------------------------------- /src/Narcissus/OCamlExtraction/StackVector.ml: -------------------------------------------------------------------------------- 1 | (* This is mostly needed because extraction of vectors is broken by mixing VectorDef and Vector *) 2 | 3 | type 'a t = 4 | { len: int; 5 | arr: 'a ArrayVector.storage_t } 6 | 7 | let empty () = 8 | { len = 0; 9 | arr = ArrayVector.of_array [| |] } 10 | 11 | let of_rev_array arr = 12 | { len = Array.length arr; 13 | arr = ArrayVector.of_array arr } 14 | 15 | let full v = 16 | v.len = ArrayVector.length v.arr 17 | 18 | let dup_push v x = 19 | (* Printf.printf "Growing from size %d\n" v.len; *) 20 | let data = Array.make (2 * v.len + 6) x in 21 | Array.blit v.arr.ArrayVector.data 0 data 0 v.len; 22 | { len = v.len + 1; arr = ArrayVector.of_array data } 23 | 24 | let cons ((hd, _, tl): ('a * 'b * 'a t)) : 'a t = 25 | if full tl then 26 | dup_push tl hd 27 | else 28 | { len = tl.len + 1; 29 | arr = ArrayVector.set_nth' tl.arr tl.len hd } 30 | 31 | let nth' (v: 'a t) (idx: ArrayVector.idx_t) : 'a = 32 | ArrayVector.nth' v.arr (v.len - idx - 1) 33 | 34 | let nth _ (v: 'a t) (idx: ArrayVector.idx_t) : 'a = 35 | nth' v idx 36 | 37 | let nth_opt' (v: 'a t) (idx: ArrayVector.idx_t) : 'a option = 38 | if idx < v.len then Some (nth' v idx) else None 39 | 40 | let nth_opt _ (v: 'a t) (idx: ArrayVector.idx_t) : 'a option = 41 | nth_opt' v idx 42 | 43 | let index (_: int) (_: int) (x: 'a) (v: 'a t) : ArrayVector.idx_t option = 44 | match ArrayVector.index' x v.arr.ArrayVector.data 0 v.len with 45 | | Some idx -> Some (v.len - idx - 1) 46 | | None -> None 47 | -------------------------------------------------------------------------------- /src/Narcissus/Examples/Guard/Guard.v: -------------------------------------------------------------------------------- 1 | Require Export Fiat.ADT Fiat.ADTNotation Fiat.ADTRefinement Fiat.ADTRefinement.BuildADTRefinements. 2 | 3 | Require Export Fiat.Narcissus.Examples.Guard.Core. 4 | Require Export Fiat.Narcissus.Examples.Guard.IPTablesGuard. 5 | 6 | Definition GuardSig : ADTSig := ADTsignature { 7 | Constructor "Init" : rep, 8 | Method "ProcessPacket" : rep * bytes -> rep * result 9 | }. 10 | 11 | Definition GuardSpec : ADT GuardSig := IPGuard {{ 12 | iptables -P FORWARD DROP; 13 | iptables -A FORWARD --protocol "UDP" --source-port bootps --not --source 192*168*0*1 -j DROP; 14 | iptables -A FORWARD --protocol "UDP" --source-port bootpc --not --destination 255*255*255*255 -j DROP 15 | }}. 16 | 17 | Arguments andb : simpl nomatch. 18 | Arguments Word.NToWord : simpl never. 19 | Arguments Word.wones : simpl never. 20 | Arguments Word.wzero : simpl never. 21 | Arguments Word.zext : simpl never. 22 | Hint Rewrite Bool.andb_true_l : iptables. 23 | 24 | Ltac t_ := 25 | match goal with 26 | | _ => progress (subst || cbn) 27 | | _ => progress (autounfold with iptables || autorewrite with iptables) 28 | | _ => simplify with monad laws 29 | | _ => refine pick eq 30 | end. 31 | 32 | Ltac t := repeat t_. 33 | 34 | Ltac guardc := 35 | start sharpening ADT; 36 | hone representation using eq; t; 37 | [ finish honing.. | finish_SharpeningADT_WithoutDelegation ]. 38 | 39 | Theorem SharpenedGuard : 40 | FullySharpened GuardSpec. 41 | Proof. guardc. Defined. 42 | 43 | Definition GuardImpl := 44 | Eval cbn in projT1 SharpenedGuard. 45 | -------------------------------------------------------------------------------- /src/Parsers/Refinement/SharpenedExpressionPlusParenParseTree.v: -------------------------------------------------------------------------------- 1 | (** Sharpened ADT for #, +, () *) 2 | Require Import Fiat.Parsers.Grammars.ExpressionNumPlusParen. 3 | Require Import Fiat.Parsers.Refinement.Tactics. 4 | Require Import Fiat.Parsers.ActionEvaluator. 5 | Require Import Fiat.Parsers.Refinement.SharpenedExpressionPlusParen. 6 | Require Import Fiat.Parsers.Grammars.EvalGrammarTactics. 7 | 8 | Definition parser_informative_opaque (str : Coq.Strings.String.string) 9 | : option (parse_of_item plus_expr_grammar str (NonTerminal (Start_symbol plus_expr_grammar))). 10 | Proof. 11 | Time make_parser_informative_opaque ComputationalSplitter. 12 | Defined. 13 | 14 | Definition parser_informative (str : Coq.Strings.String.string) 15 | : option (@simple_parse_of_item Ascii.ascii). 16 | Proof. 17 | Time make_parser_informative ComputationalSplitter. 18 | Defined. 19 | 20 | Definition parser_eval (str : Coq.Strings.String.string) 21 | : option nat. 22 | Proof. 23 | refine match parser_informative str with 24 | | Some (SimpleParseNonTerminal nt pt) 25 | => option_map (fun d : digits => d : nat) 26 | (evaluate_item plus_expr_pregrammar_with_actions (SimpleParseNonTerminal nt pt)) 27 | | Some (SimpleParseTerminal _) => None 28 | | None => None 29 | end. 30 | Defined. 31 | 32 | Check let n := 3 in eq_refl (Some n) <: parser_eval "(1+1)+1" = Some n. 33 | Check let n := 5 in eq_refl (Some n) <: parser_eval "((1+1)+(1+1))+1" = Some n. 34 | Check let n := 55 in eq_refl (Some n) <: parser_eval "(((((55)))))" = Some n. 35 | -------------------------------------------------------------------------------- /src/Common/Ensembles/Cardinal.v: -------------------------------------------------------------------------------- 1 | (** * Miscellaneous definitions about ensembles *) 2 | Require Import Coq.Lists.List. 3 | Require Export Coq.Sets.Ensembles. 4 | Require Import Fiat.Common Fiat.Common.List.PermutationFacts 5 | Fiat.Common.Ensembles.EnsembleListEquivalence. 6 | (** Coq's [cardinal] is stupid, and not total. For example, it 7 | requires [Extensionality_Ensembles] to prove [cardinal _ (fun _ => 8 | False) 0]. So we define a better one. *) 9 | Definition cardinal U (A : Ensemble U) (n : nat) : Prop := 10 | exists ls, EnsembleListEquivalence A ls /\ Datatypes.length ls = n. 11 | (** To mimic the arguments of the built-in [cardinal]. *) 12 | Arguments cardinal : clear implicits. 13 | 14 | Lemma cardinal_Same_set {U} (A B : Ensemble U) x 15 | (H : Same_set _ A B) 16 | (H' : cardinal _ A x) 17 | : cardinal _ B x. 18 | Proof. 19 | destruct H' as [ls H']. 20 | exists ls. 21 | destruct_head and; split; auto. 22 | eapply EnsembleListEquivalence_Same_set; eassumption. 23 | Qed. 24 | 25 | Global Add Parametric Morphism {U} : (cardinal U) 26 | with signature Same_set _ ==> eq ==> iff 27 | as Same_set_cardinal. 28 | Proof. 29 | intros; split; intros; eapply cardinal_Same_set; 30 | try eassumption; 31 | split; destruct_head_hnf and; assumption. 32 | Qed. 33 | 34 | Lemma cardinal_unique {U} (A : Ensemble U) x y 35 | (H : cardinal _ A x) (H' : cardinal _ A y) 36 | : x = y. 37 | Proof. 38 | destruct_head_hnf ex. 39 | destruct_head and. 40 | subst. 41 | apply Permutation_length. 42 | eapply EnsembleListEquivalence_Permutation; eassumption. 43 | Qed. 44 | -------------------------------------------------------------------------------- /src/Common/VectorFacts.v: -------------------------------------------------------------------------------- 1 | Require Export Fiat.Common.Coq__8_4__8_5__Compat. 2 | Require Coq.Vectors.Vector. 3 | Import Vectors.Vector.VectorNotations. 4 | 5 | Set Implicit Arguments. 6 | 7 | Definition Vector_caseS' 8 | {A'} (Q : nat -> Type) 9 | (P : forall {n} (v : Vector.t A' (S n)), Q n -> Type) 10 | (H : forall h {n} t q, @P n (h :: t) q) {n} (v: Vector.t A' (S n)) 11 | (q : Q n) 12 | : P v q. 13 | Proof. 14 | specialize (fun h t => H h _ t q). 15 | change n with (pred (S n)) in H, q |- *. 16 | set (Sn := S n) in *. 17 | pose (fun Sn (v : Vector.t A' Sn) (q : Q (pred Sn)) => 18 | match Sn return Vector.t A' Sn -> Q (pred Sn) -> Type with 19 | | S n' => P n' 20 | | 0 => fun _ _ => True 21 | end v q) as P'. 22 | change (match Sn return Type with 23 | | 0 => True 24 | | _ => P' Sn v q 25 | end). 26 | change (forall h (t : match Sn with 27 | | S n' => Vector.t A' n' 28 | | 0 => Vector.t A' Sn 29 | end), 30 | P' Sn (match Sn return match Sn with 31 | | S n' => Vector.t A' n' 32 | | 0 => Vector.t A' Sn 33 | end -> Vector.t A' Sn 34 | with 35 | | S _ => fun t => h :: t 36 | | 0 => fun t => t 37 | end t) q) in H. 38 | clearbody P'; clear P. 39 | clearbody Sn. 40 | destruct v as [|h ? t]. 41 | { constructor. } 42 | { apply H. } 43 | Defined. 44 | -------------------------------------------------------------------------------- /src/Narcissus/Formats/Bool.v: -------------------------------------------------------------------------------- 1 | Require Import 2 | Fiat.Common 3 | Fiat.Computation.Notations 4 | Fiat.Narcissus.Common.Specs 5 | Fiat.Narcissus.Common.WordFacts 6 | Fiat.Narcissus.Formats.WordOpt 7 | Fiat.Narcissus.BaseFormats. 8 | 9 | Unset Implicit Arguments. 10 | 11 | Section Bool. 12 | 13 | Context {B : Type}. 14 | Context {cache : Cache}. 15 | Context {cacheAddNat : CacheAdd cache nat}. 16 | Context {monoid : Monoid B}. 17 | Context {monoidUnit : QueueMonoidOpt monoid bool}. 18 | 19 | Definition format_bool (b : bool) (ctx : CacheFormat) := 20 | ret (enqueue_opt b mempty, addE ctx 1). 21 | 22 | Definition decode_bool (b : B) (ctx : CacheDecode) : option (bool * B * CacheDecode) := 23 | Ifopt dequeue_opt b as decoded Then Some (decoded, addD ctx 1) Else None. 24 | 25 | Theorem bool_decode_correct 26 | {P : CacheDecode -> Prop} 27 | (P_OK : cache_inv_Property P (fun P => forall b cd, P cd -> P (addD cd b))) 28 | : 29 | CorrectDecoder monoid (fun _ => True) 30 | (fun _ => True) 31 | eq 32 | format_bool decode_bool P format_bool. 33 | Proof. 34 | eapply format_decode_correct_EquivFormatAndView with (fun b => format_word (WS b WO)). 35 | unfold flip, EquivFormat. reflexivity. 36 | 37 | apply_bijection_rule with (whd (sz:=_)); 38 | intuition eauto using Word_decode_correct. 39 | rewrite <- (natToWord_wordToNat v). 40 | destruct (wordToNat v) eqn:?; reflexivity. 41 | 42 | unfold decode_word, decode_word'; derive_decoder_equiv. 43 | Qed. 44 | 45 | End Bool. 46 | -------------------------------------------------------------------------------- /src/Parsers/Reachable/MaybeEmpty/Core.v: -------------------------------------------------------------------------------- 1 | (** * Definition of Context Free Grammars *) 2 | Require Import Coq.Strings.String Coq.Lists.List. 3 | Require Import Fiat.Parsers.ContextFreeGrammar.Core. 4 | Require Import Fiat.Parsers.BaseTypes. 5 | Require Import Fiat.Common. 6 | 7 | Set Implicit Arguments. 8 | 9 | Local Open Scope string_like_scope. 10 | Local Open Scope type_scope. 11 | 12 | Section cfg. 13 | Context {Char} {HSL : StringLikeMin Char} {predata : @parser_computational_predataT Char} (G : grammar Char). 14 | 15 | Context (valid : nonterminals_listT). 16 | 17 | (** Relation defining if a productions is maybe empty *) 18 | Inductive maybe_empty_productions : productions Char -> Type := 19 | | MaybeEmptyHead : forall pat pats, maybe_empty_production pat 20 | -> maybe_empty_productions (pat::pats) 21 | | MaybeEmptyTail : forall pat pats, maybe_empty_productions pats 22 | -> maybe_empty_productions (pat::pats) 23 | with maybe_empty_production : production Char -> Type := 24 | | MaybeEmptyProductionNil : maybe_empty_production nil 25 | | MaybeEmptyProductionCons : forall it its, maybe_empty_item it 26 | -> maybe_empty_production its 27 | -> maybe_empty_production (it::its) 28 | with maybe_empty_item : item Char -> Type := 29 | | MaybeEmptyNonTerminal : forall nt, is_valid_nonterminal valid (of_nonterminal nt) 30 | -> maybe_empty_productions (Lookup G nt) 31 | -> maybe_empty_item (NonTerminal nt). 32 | End cfg. 33 | -------------------------------------------------------------------------------- /src/Parsers/Grammars/ExpressionNumPlusParen.v: -------------------------------------------------------------------------------- 1 | (** * Definition of grammar for expressions involving parentheses and plus *) 2 | Require Import Fiat.Parsers.ContextFreeGrammar.Notations. 3 | 4 | Definition plus_expr_pregrammar : pregrammar Ascii.ascii := 5 | [[[ "expr" ::== "pexpr" || "pexpr" "+" "expr";; 6 | "pexpr" ::== "number" || "(" "expr" ")";; 7 | "number" ::== [0-9] || [0-9] "number" 8 | ]]]. 9 | 10 | Definition plus_expr_grammar : grammar Ascii.ascii := plus_expr_pregrammar. 11 | 12 | Local Open Scope grammar_with_actions_scope. 13 | 14 | Inductive digits := zero | digit (v : nat) (_ : digits). 15 | Bind Scope digits_scope with digits. 16 | Delimit Scope digits_scope with digits. 17 | Fixpoint digits_to_nat' (v : digits) (cur : nat) : nat 18 | := match v with 19 | | zero => cur 20 | | digit v rest => digits_to_nat' rest (cur * 10 + v) 21 | end. 22 | Coercion digits_to_nat (v : digits) : nat 23 | := digits_to_nat' v 0. 24 | Coercion nat_as_fake_digits (n : nat) : digits 25 | := digit n zero. 26 | Definition plus (x y : digits) : digits := x + y. 27 | Infix "+" := plus : digits_scope. 28 | Local Open Scope digits_scope. 29 | Definition parseAscii_as_digits : ascii -> digits := parseAscii_as_nat. 30 | 31 | Definition plus_expr_pregrammar_with_actions : pregrammar_with_actions Ascii.ascii digits 32 | := [[[ "expr" ::== "pexpr" <{< id >}> || "pexpr" "+" "expr" <{< fun x _ y => x + y >}>;; 33 | "pexpr" ::== "number" <{< id >}> || "(" "expr" ")" <{< fun _ e _ => e >}>;; 34 | "number" ::== [0-9] <{< parseAscii_as_digits >}> || [0-9] "number" <{< fun x y => digit (parseAscii_as_nat x) y >}> 35 | ]]]%grammar_with_actions. 36 | -------------------------------------------------------------------------------- /src/ComputationalEnsembles/Core.v: -------------------------------------------------------------------------------- 1 | Require Import Coq.Lists.List Coq.Sets.Ensembles. 2 | Require Import Fiat.Computation.Core Fiat.Computation.Notations 3 | Fiat.Common.Ensembles.EnsembleListEquivalence 4 | Fiat.Common.Ensembles.Cardinal. 5 | 6 | Set Implicit Arguments. 7 | 8 | Local Open Scope comp_scope. 9 | 10 | Definition elements {A} (ls : list A) : Ensemble A := fun x => List.In x ls. 11 | 12 | Definition cardinal {A} (ls : list A) : Comp nat 13 | := Pick (cardinal _ (elements ls)). 14 | 15 | Definition to_list {A} (S : Ensemble A) : Comp (list A) := 16 | { ls : list _ | EnsembleListEquivalence S ls }. 17 | 18 | (** QUESTION: Should I switch [fold_right] and [Ensemble_fold_right]? 19 | Which is more common? *) 20 | Definition fold_right {A B} 21 | (f : A -> B -> Comp B) (b : Comp B) (S : Ensemble A) 22 | : Comp B 23 | := (ls <- to_list S; 24 | List.fold_right (fun a b' => Bind b' (f a)) b ls). 25 | 26 | Definition Ensemble_fold_right {A B} 27 | (f : A -> B -> B) (b : B) (S : Ensemble A) 28 | : Comp B 29 | := fold_right (fun a b => ret (f a b)) (ret b) S. 30 | 31 | Definition list_filter_pred {T} (P : T -> Prop) (ls : list T) 32 | := List.fold_right 33 | (fun (a : T) (xs : Comp (list T)) => 34 | (xs' <- xs; 35 | b <- { b : bool | b = true <-> P a }; 36 | ret (if b then a::xs' else xs'))) 37 | (ret nil) 38 | ls. 39 | 40 | Definition filter_pred {T} (P : T -> Prop) (S : Ensemble T) 41 | := fold_right 42 | (fun (a : T) (xs : list T) => 43 | (b <- { b : bool | b = true <-> P a }; 44 | ret (if b then a::xs else xs))) 45 | (ret nil) 46 | S. 47 | -------------------------------------------------------------------------------- /src/Parsers/Reachable/MaybeEmpty/WellFounded.v: -------------------------------------------------------------------------------- 1 | (** * Well-founded relation on [reachable] *) 2 | Require Import Fiat.Parsers.ContextFreeGrammar.Core Fiat.Parsers.Reachable.MaybeEmpty.Core. 3 | Require Import Fiat.Parsers.BaseTypes. 4 | 5 | Section rel. 6 | Context {Char} {HSLM : StringLikeMin Char} {predata : @parser_computational_predataT Char} {G : grammar Char}. 7 | 8 | Section size. 9 | Context {ch : Char} {valid : nonterminals_listT}. 10 | Definition size_of_maybe_empty_item' 11 | (size_of_maybe_empty_productions : forall {pats}, maybe_empty_productions G valid pats -> nat) 12 | {it} (p : maybe_empty_item G valid it) : nat 13 | := match p with 14 | | MaybeEmptyNonTerminal _ _ p' => S (size_of_maybe_empty_productions p') 15 | end. 16 | 17 | 18 | Fixpoint size_of_maybe_empty_productions {pats} (p : maybe_empty_productions G valid pats) : nat 19 | := match p with 20 | | MaybeEmptyHead _ _ p' => S (size_of_maybe_empty_production p') 21 | | MaybeEmptyTail _ _ p' => S (size_of_maybe_empty_productions p') 22 | end 23 | with size_of_maybe_empty_production {pat} (p : maybe_empty_production G valid pat) : nat 24 | := match p with 25 | | MaybeEmptyProductionNil => 0 26 | | MaybeEmptyProductionCons _ _ p0 p1 => S (size_of_maybe_empty_item' (@size_of_maybe_empty_productions) p0 + size_of_maybe_empty_production p1) 27 | end. 28 | 29 | Definition size_of_maybe_empty_item 30 | {it} (p : maybe_empty_item G valid it) : nat 31 | := @size_of_maybe_empty_item' (@size_of_maybe_empty_productions) it p. 32 | End size. 33 | End rel. 34 | -------------------------------------------------------------------------------- /src/Common/Ensembles/Morphisms.v: -------------------------------------------------------------------------------- 1 | Require Export Coq.Sets.Ensembles. 2 | Require Import Fiat.Common.Ensembles.Equivalence. 3 | Require Import Fiat.Common.Ensembles.Tactics. 4 | Require Import Coq.Classes.RelationClasses. 5 | 6 | Set Implicit Arguments. 7 | Require Import Fiat.Common. 8 | 9 | Add Parametric Morphism {T} : (@Union T) 10 | with signature eq ==> Included T ==> Included T 11 | as Union_Included2_mor. 12 | Proof. Ensembles_t. Qed. 13 | 14 | Add Parametric Morphism {T} : (@Union T) 15 | with signature Included T ==> eq ==> Included T 16 | as Union_Included1_mor. 17 | Proof. Ensembles_t. Qed. 18 | 19 | Add Parametric Morphism {T} : (@Union T) 20 | with signature Same_set T ==> eq ==> Same_set T 21 | as Union_Same_set1_mor. 22 | Proof. Ensembles_t. Qed. 23 | 24 | Add Parametric Morphism {T} : (@Union T) 25 | with signature eq ==> Same_set T ==> Same_set T 26 | as Union_Same_set2_mor. 27 | Proof. Ensembles_t. Qed. 28 | 29 | 30 | 31 | Add Parametric Morphism {T} : (@Intersection T) 32 | with signature eq ==> Included T ==> Included T 33 | as Intersection_Included2_mor. 34 | Proof. Ensembles_t. Qed. 35 | 36 | Add Parametric Morphism {T} : (@Intersection T) 37 | with signature Included T ==> eq ==> Included T 38 | as Intersection_Included1_mor. 39 | Proof. Ensembles_t. Qed. 40 | 41 | Add Parametric Morphism {T} : (@Intersection T) 42 | with signature Same_set T ==> eq ==> Same_set T 43 | as Intersection_Same_set1_mor. 44 | Proof. Ensembles_t. Qed. 45 | 46 | Add Parametric Morphism {T} : (@Intersection T) 47 | with signature eq ==> Same_set T ==> Same_set T 48 | as Intersection_Same_set2_mor. 49 | Proof. Ensembles_t. Qed. 50 | -------------------------------------------------------------------------------- /src/Examples/CacheADT/CacheSpec.v: -------------------------------------------------------------------------------- 1 | Require Import Coq.Strings.String Coq.ZArith.ZArith Coq.Lists.List Coq.Logic.FunctionalExtensionality Coq.Sets.Ensembles 2 | Fiat.Computation Fiat.ADT Fiat.ADTRefinement Fiat.ADTNotation Fiat.ADTRefinement.BuildADTRefinements 3 | Examples.CacheADT.KVEnsembles. 4 | 5 | Open Scope string_scope. 6 | 7 | Section CacheSpec. 8 | 9 | Variable Key : Type. 10 | Variable Value : Type. 11 | 12 | Definition CacheSig : ADTSig := 13 | ADTsignature { 14 | Constructor "EmptyCache" : unit -> rep, 15 | Method "AddKey" : rep x (Key * Value) -> rep x bool, 16 | Method "UpdateKey" : rep x (Key * (Value -> Value)) -> rep x bool, 17 | Method "LookupKey" : rep x Key -> rep x (option Value) 18 | }. 19 | 20 | Definition CacheSpec : ADT CacheSig := 21 | ADTRep (Ensemble (Key * Value)) { 22 | Def Constructor "EmptyCache" (_ : unit) : rep := 23 | ret (fun _ => False), 24 | meth "AddKey" (r : rep, kv : Key * Value) : bool := 25 | { r' | (SubEnsembleInsert kv r (fst r')) /\ 26 | ((usedKey r (fst kv) /\ snd r' = false) \/ 27 | (~ usedKey r (fst kv) /\ snd r' = true))}, 28 | meth "UpdateKey" (r : rep, kv : Key * (Value -> Value)) : bool := 29 | { r' | 30 | (Same_set _ (fst r') (EnsembleUpdateKey (fst kv) r (snd kv))) 31 | /\ ((usedKey r (fst kv) /\ snd r' = true) \/ 32 | (~ usedKey r (fst kv) -> snd r' = false))}, 33 | meth "LookupKey" (r : rep, k : Key) : option Value := 34 | v <- {v | ValidLookup r k v}; 35 | ret (r, v) 36 | }. 37 | 38 | End CacheSpec. 39 | -------------------------------------------------------------------------------- /src/CertifiedExtraction/Extraction/External/ScalarMethods.v: -------------------------------------------------------------------------------- 1 | Require Import 2 | CertifiedExtraction.Extraction.External.Core 3 | CertifiedExtraction.Extraction.External.GenericMethods. 4 | 5 | Require Import Coq.Lists.List. 6 | 7 | Lemma CompileCallFacadeImplementationWW: 8 | forall {av} {env} fWW, 9 | forall fpointer varg (arg: W) tenv, 10 | GLabelMap.MapsTo fpointer (Axiomatic (FacadeImplementationWW av fWW)) env -> 11 | forall vret ext, 12 | vret ∉ ext -> 13 | NotInTelescope vret tenv -> 14 | StringMap.MapsTo varg (wrap arg) ext -> 15 | {{ tenv }} 16 | Call vret fpointer (varg :: nil) 17 | {{ [[ `vret ->> (fWW arg) as _]]:: tenv }} ∪ {{ ext }} // env. 18 | Proof. 19 | repeat match goal with 20 | | _ => SameValues_Facade_t_step 21 | | _ => facade_cleanup_call 22 | end; facade_eauto. 23 | Qed. 24 | 25 | Lemma CompileCallFacadeImplementationWW_full: 26 | forall {av} {env} fWW, 27 | forall fpointer varg (arg: W) tenv, 28 | GLabelMap.MapsTo fpointer (Axiomatic (FacadeImplementationWW av fWW)) env -> 29 | forall vret ext p, 30 | vret ∉ ext -> 31 | varg ∉ ext -> 32 | NotInTelescope vret tenv -> 33 | NotInTelescope varg tenv -> 34 | vret <> varg -> 35 | {{ tenv }} 36 | p 37 | {{ [[ `varg ->> arg as _]]:: tenv }} ∪ {{ ext }} // env -> 38 | {{ tenv }} 39 | Seq p (Call vret fpointer (varg :: nil)) 40 | {{ [[ `vret ->> (fWW arg) as _]]:: tenv }} ∪ {{ ext }} // env. 41 | Proof. 42 | repeat hoare. 43 | repeat match goal with 44 | | _ => SameValues_Facade_t_step 45 | | _ => facade_cleanup_call 46 | end; facade_eauto. 47 | Qed. 48 | -------------------------------------------------------------------------------- /src/Common/Ensembles/Tactics.v: -------------------------------------------------------------------------------- 1 | Require Import Coq.Sets.Ensembles. 2 | Require Import Fiat.Common. 3 | 4 | Create HintDb ensembles discriminated. 5 | 6 | #[global] 7 | Hint Constructors Singleton Union Intersection : ensembles. 8 | 9 | Ltac finish_union_with t := 10 | solve [ t 11 | | left; finish_union_with t 12 | | right; finish_union_with t ]. 13 | 14 | Ltac Ensembles_t_step := 15 | idtac; 16 | match goal with 17 | | _ => intro 18 | | _ => progress destruct_head_hnf and 19 | | _ => progress destruct_head_hnf or 20 | | _ => progress destruct_head_hnf False 21 | | _ => progress destruct_head_hnf Union 22 | | _ => progress destruct_head_hnf Intersection 23 | | _ => progress destruct_head_hnf Singleton 24 | | _ => progress destruct_head_hnf Ensembles.Empty_set 25 | | _ => progress subst 26 | | _ => progress unfold Same_set, Included, Ensembles.In, Ensembles.Setminus in * 27 | | [ |- Singleton _ _ _ ] => constructor 28 | | [ |- Intersection _ _ _ _ ] => constructor 29 | | [ |- _ /\ _ ] => split 30 | | [ H : ~~(@eq bool _ _) |- _ ] => apply dn_eqb in H 31 | | [ H : ~(@eq bool _ _) |- _ ] => apply neq_to_eq_negb in H 32 | | [ H : context[negb (negb _)] |- _ ] => rewrite Bool.negb_involutive in H 33 | | [ H : ?x = negb ?x |- _ ] => symmetry in H; apply Bool.no_fixpoint_negb in H 34 | | [ H : negb ?x = ?x |- _ ] => apply Bool.no_fixpoint_negb in H 35 | (** slower tactics *) 36 | | _ => progress simplify_hyps 37 | | _ => solve [ eauto with ensembles ] 38 | | _ => finish_union_with ltac:(eauto with ensembles) 39 | | _ => finish_union_with ltac:(hnf in *; eauto with ensembles) 40 | end. 41 | 42 | Ltac Ensembles_t := 43 | repeat Ensembles_t_step. 44 | -------------------------------------------------------------------------------- /src/Common/Tactics/transparent_abstract_tactics.ml.v89: -------------------------------------------------------------------------------- 1 | module TRANSPARENT_ABSTRACT = 2 | struct 3 | open Decl_kinds 4 | open Pfedit 5 | open Names 6 | open Nameops 7 | open Ltac_plugin 8 | open Proof_global 9 | 10 | (* Lift a constr to an ltac value. *) 11 | let to_ltac_val c = Tacinterp.Value.of_constr c 12 | 13 | (* Build a new definition for [term] with identifier [id] and call *) 14 | (* the [tacK] tactic with the result. *) 15 | let transparent_abstract_term id (term : EConstr.constr) tacK gk = 16 | Proofview.Goal.enter begin 17 | fun gl -> 18 | let termType = Tacmach.New.pf_get_type_of gl term in 19 | Tactics.cache_term_by_tactic_then ~opaque:false 20 | ~goal_type:(Some termType) id 21 | gk 22 | (Eauto.e_give_exact term) 23 | (fun lem args -> Tacinterp.Value.apply tacK [to_ltac_val (EConstr.applist (lem, args))]) 24 | end 25 | 26 | (* Default identifier *) 27 | let anon_id = Id.of_string "anonymous" 28 | 29 | let tclTRABSTRACT name_op tac = Tactics.tclABSTRACT ~opaque:false name_op tac 30 | 31 | let tclABSTRACTTERM name_op term tacK = 32 | (* What's the right default goal kind?*) 33 | let default_gk = (Global, false, Proof Theorem) in 34 | let s, gk = match name_op with 35 | | Some s -> 36 | (try let _, gk, _ = current_proof_statement () in s, gk 37 | with NoCurrentProof -> s, default_gk) 38 | | None -> 39 | let name, gk = 40 | try let name, gk, _ = current_proof_statement () in name, gk 41 | with NoCurrentProof -> anon_id, default_gk in 42 | add_suffix name "_term", gk 43 | in 44 | transparent_abstract_term s term tacK gk 45 | 46 | end 47 | -------------------------------------------------------------------------------- /src/Parsers/Reachable/All/ReachableWellFounded.v: -------------------------------------------------------------------------------- 1 | (** * Well-founded relation on [reachable] *) 2 | Require Import Fiat.Parsers.ContextFreeGrammar.Core Fiat.Parsers.Reachable.All.Reachable. 3 | Require Import Fiat.Parsers.BaseTypes. 4 | 5 | Section rel. 6 | Context {Char} {HSLM : StringLikeMin Char} {predata : @parser_computational_predataT Char} {G : grammar Char}. 7 | 8 | Section size. 9 | Context {ch : Char} {valid : nonterminals_listT}. 10 | Definition size_of_reachable_from_item' 11 | (size_of_reachable_from_productions : forall {pats}, reachable_from_productions G ch valid pats -> nat) 12 | {it} (p : reachable_from_item G ch valid it) : nat 13 | := match p with 14 | | ReachableTerminal _ _ => 0 15 | | ReachableNonTerminal _ _ p' => S (size_of_reachable_from_productions p') 16 | end. 17 | 18 | Fixpoint size_of_reachable_from_productions {pats} (p : reachable_from_productions G ch valid pats) : nat 19 | := match p with 20 | | ReachableHead _ _ p' => S (size_of_reachable_from_production p') 21 | | ReachableTail _ _ p' => S (size_of_reachable_from_productions p') 22 | end 23 | with size_of_reachable_from_production {pat} (p : reachable_from_production G ch valid pat) : nat 24 | := match p with 25 | | ReachableProductionHead _ _ p' => S (size_of_reachable_from_item' (@size_of_reachable_from_productions) p') 26 | | ReachableProductionTail _ _ p' => S (size_of_reachable_from_production p') 27 | end. 28 | 29 | Definition size_of_reachable_from_item 30 | {it} (p : reachable_from_item G ch valid it) : nat 31 | := @size_of_reachable_from_item' (@size_of_reachable_from_productions) it p. 32 | End size. 33 | End rel. 34 | -------------------------------------------------------------------------------- /src/Common/Tactics/hint_db_extra_tactics.ml.v815: -------------------------------------------------------------------------------- 1 | module WITH_DB = 2 | struct 3 | open Tacticals 4 | open Ltac_plugin 5 | 6 | (* Lift a constructor to an ltac value. *) 7 | let to_ltac_val c = Tacinterp.Value.of_constr c 8 | 9 | let with_hint_db dbs tacK = 10 | (* [dbs] : list of hint databases *) 11 | (* [tacK] : tactic to run on a hint *) 12 | Proofview.Goal.enter begin 13 | fun gl -> 14 | let syms = ref [] in 15 | let _ = 16 | List.iter (fun l -> 17 | (* Fetch the searchtable from the database*) 18 | let db = Hints.searchtable_map l in 19 | (* iterate over the hint database, pulling the hint *) 20 | (* list out for each. *) 21 | Hints.Hint_db.iter (fun _ _ hintlist -> 22 | syms := hintlist::!syms) db) dbs in 23 | (* Now iterate over the list of list of hints, *) 24 | List.fold_left 25 | (fun tac hints -> 26 | List.fold_left 27 | (fun tac hint1 -> 28 | Hints.FullHint.run hint1 29 | (fun hint2 -> 30 | (* match the type of the hint to pull out the lemma *) 31 | match hint2 with 32 | Hints.Give_exact h 33 | | Hints.Res_pf h 34 | | Hints.ERes_pf h -> 35 | let _, lem = Hints.hint_as_term h in 36 | let this_tac = Tacinterp.Value.apply tacK [Tacinterp.Value.of_constr lem] in 37 | tclORELSE this_tac tac 38 | | _ -> tac)) 39 | tac hints) 40 | (tclFAIL 0 (Pp.str "No applicable tactic!")) !syms 41 | end 42 | 43 | let add_resolve_to_db lem db = 44 | Proofview.Goal.enter begin 45 | fun gl -> 46 | let _ = Hints.add_hints ~locality:Hints.Local db (Hints.HintsResolveEntry [({ Typeclasses.hint_priority = Some 1 ; Typeclasses.hint_pattern = None },true,Hints.PathAny,lem)]) in 47 | tclIDTAC 48 | end 49 | 50 | end 51 | -------------------------------------------------------------------------------- /src/Common/Tactics/hint_db_extra_tactics.ml.v816: -------------------------------------------------------------------------------- 1 | module WITH_DB = 2 | struct 3 | open Tacticals 4 | open Ltac_plugin 5 | 6 | (* Lift a constructor to an ltac value. *) 7 | let to_ltac_val c = Tacinterp.Value.of_constr c 8 | 9 | let with_hint_db dbs tacK = 10 | (* [dbs] : list of hint databases *) 11 | (* [tacK] : tactic to run on a hint *) 12 | Proofview.Goal.enter begin 13 | fun gl -> 14 | let syms = ref [] in 15 | let _ = 16 | List.iter (fun l -> 17 | (* Fetch the searchtable from the database*) 18 | let db = Hints.searchtable_map l in 19 | (* iterate over the hint database, pulling the hint *) 20 | (* list out for each. *) 21 | Hints.Hint_db.iter (fun _ _ hintlist -> 22 | syms := hintlist::!syms) db) dbs in 23 | (* Now iterate over the list of list of hints, *) 24 | List.fold_left 25 | (fun tac hints -> 26 | List.fold_left 27 | (fun tac hint1 -> 28 | Hints.FullHint.run hint1 29 | (fun hint2 -> 30 | (* match the type of the hint to pull out the lemma *) 31 | match hint2 with 32 | Hints.Give_exact h 33 | | Hints.Res_pf h 34 | | Hints.ERes_pf h -> 35 | let _, lem = Hints.hint_as_term h in 36 | let this_tac = Tacinterp.Value.apply tacK [Tacinterp.Value.of_constr lem] in 37 | tclORELSE this_tac tac 38 | | _ -> tac)) 39 | tac hints) 40 | (tclFAIL (Pp.str "No applicable tactic!")) !syms 41 | end 42 | 43 | let add_resolve_to_db lem db = 44 | Proofview.Goal.enter begin 45 | fun gl -> 46 | let _ = Hints.add_hints ~locality:Hints.Local db (Hints.HintsResolveEntry [({ Typeclasses.hint_priority = Some 1 ; Typeclasses.hint_pattern = None },true,Hints.PathAny,lem)]) in 47 | tclIDTAC 48 | end 49 | 50 | end 51 | -------------------------------------------------------------------------------- /src/Common/Tactics/hint_db_extra_tactics.ml.v817: -------------------------------------------------------------------------------- 1 | module WITH_DB = 2 | struct 3 | open Tacticals 4 | open Ltac_plugin 5 | 6 | (* Lift a constructor to an ltac value. *) 7 | let to_ltac_val c = Tacinterp.Value.of_constr c 8 | 9 | let with_hint_db dbs tacK = 10 | (* [dbs] : list of hint databases *) 11 | (* [tacK] : tactic to run on a hint *) 12 | Proofview.Goal.enter begin 13 | fun gl -> 14 | let syms = ref [] in 15 | let _ = 16 | List.iter (fun l -> 17 | (* Fetch the searchtable from the database*) 18 | let db = Hints.searchtable_map l in 19 | (* iterate over the hint database, pulling the hint *) 20 | (* list out for each. *) 21 | Hints.Hint_db.iter (fun _ _ hintlist -> 22 | syms := hintlist::!syms) db) dbs in 23 | (* Now iterate over the list of list of hints, *) 24 | List.fold_left 25 | (fun tac hints -> 26 | List.fold_left 27 | (fun tac hint1 -> 28 | Hints.FullHint.run hint1 29 | (fun hint2 -> 30 | (* match the type of the hint to pull out the lemma *) 31 | match hint2 with 32 | Hints.Give_exact h 33 | | Hints.Res_pf h 34 | | Hints.ERes_pf h -> 35 | let _, lem = Hints.hint_as_term h in 36 | let this_tac = Tacinterp.Value.apply tacK [Tacinterp.Value.of_constr lem] in 37 | tclORELSE this_tac tac 38 | | _ -> tac)) 39 | tac hints) 40 | (tclFAIL (Pp.str "No applicable tactic!")) !syms 41 | end 42 | 43 | let add_resolve_to_db lem db = 44 | Proofview.Goal.enter begin 45 | fun gl -> 46 | let _ = Hints.add_hints ~locality:Hints.Local db (Hints.HintsResolveEntry [({ Typeclasses.hint_priority = Some 1 ; Typeclasses.hint_pattern = None },true,Hints.PathAny,lem)]) in 47 | tclIDTAC 48 | end 49 | 50 | end 51 | -------------------------------------------------------------------------------- /src/Common/Tactics/hint_db_extra_tactics.ml.v818: -------------------------------------------------------------------------------- 1 | module WITH_DB = 2 | struct 3 | open Tacticals 4 | open Ltac_plugin 5 | 6 | (* Lift a constructor to an ltac value. *) 7 | let to_ltac_val c = Tacinterp.Value.of_constr c 8 | 9 | let with_hint_db dbs tacK = 10 | (* [dbs] : list of hint databases *) 11 | (* [tacK] : tactic to run on a hint *) 12 | Proofview.Goal.enter begin 13 | fun gl -> 14 | let syms = ref [] in 15 | let _ = 16 | List.iter (fun l -> 17 | (* Fetch the searchtable from the database*) 18 | let db = Hints.searchtable_map l in 19 | (* iterate over the hint database, pulling the hint *) 20 | (* list out for each. *) 21 | Hints.Hint_db.iter (fun _ _ hintlist -> 22 | syms := hintlist::!syms) db) dbs in 23 | (* Now iterate over the list of list of hints, *) 24 | List.fold_left 25 | (fun tac hints -> 26 | List.fold_left 27 | (fun tac hint1 -> 28 | Hints.FullHint.run hint1 29 | (fun hint2 -> 30 | (* match the type of the hint to pull out the lemma *) 31 | match hint2 with 32 | Hints.Give_exact h 33 | | Hints.Res_pf h 34 | | Hints.ERes_pf h -> 35 | let _, lem = Hints.hint_as_term h in 36 | let this_tac = Tacinterp.Value.apply tacK [Tacinterp.Value.of_constr lem] in 37 | tclORELSE this_tac tac 38 | | _ -> tac)) 39 | tac hints) 40 | (tclFAIL (Pp.str "No applicable tactic!")) !syms 41 | end 42 | 43 | let add_resolve_to_db lem db = 44 | Proofview.Goal.enter begin 45 | fun gl -> 46 | let _ = Hints.add_hints ~locality:Hints.Local db (Hints.HintsResolveEntry [({ Typeclasses.hint_priority = Some 1 ; Typeclasses.hint_pattern = None },true,Hints.PathAny,lem)]) in 47 | tclIDTAC 48 | end 49 | 50 | end 51 | -------------------------------------------------------------------------------- /src/Parsers/Reachable/OnlyFirst/ReachableWellFounded.v: -------------------------------------------------------------------------------- 1 | (** * Well-founded relation on [reachable] *) 2 | Require Import Fiat.Parsers.ContextFreeGrammar.Core Fiat.Parsers.Reachable.OnlyFirst.Reachable. 3 | Require Import Fiat.Parsers.BaseTypes. 4 | 5 | Section rel. 6 | Context {Char} {HSLM : StringLikeMin Char} {predata : @parser_computational_predataT Char} {G : grammar Char}. 7 | 8 | Section size. 9 | Context {ch : Char} {valid : nonterminals_listT}. 10 | Definition size_of_reachable_from_item' 11 | (size_of_reachable_from_productions : forall {pats}, reachable_from_productions G ch valid pats -> nat) 12 | {it} (p : reachable_from_item G ch valid it) : nat 13 | := match p with 14 | | ReachableTerminal _ _ => 0 15 | | ReachableNonTerminal _ _ p' => S (size_of_reachable_from_productions p') 16 | end. 17 | 18 | Fixpoint size_of_reachable_from_productions {pats} (p : reachable_from_productions G ch valid pats) : nat 19 | := match p with 20 | | ReachableHead _ _ p' => S (size_of_reachable_from_production p') 21 | | ReachableTail _ _ p' => S (size_of_reachable_from_productions p') 22 | end 23 | with size_of_reachable_from_production {pat} (p : reachable_from_production G ch valid pat) : nat 24 | := match p with 25 | | ReachableProductionHead _ _ p' => S (size_of_reachable_from_item' (@size_of_reachable_from_productions) p') 26 | | ReachableProductionTail _ _ _ p' => S (size_of_reachable_from_production p') 27 | end. 28 | 29 | Definition size_of_reachable_from_item 30 | {it} (p : reachable_from_item G ch valid it) : nat 31 | := @size_of_reachable_from_item' (@size_of_reachable_from_productions) it p. 32 | End size. 33 | End rel. 34 | -------------------------------------------------------------------------------- /src/Parsers/Reachable/OnlyLast/ReachableWellFounded.v: -------------------------------------------------------------------------------- 1 | (** * Well-founded relation on [reachable] *) 2 | Require Import Fiat.Parsers.ContextFreeGrammar.Core Fiat.Parsers.Reachable.OnlyLast.Reachable. 3 | Require Import Fiat.Parsers.BaseTypes. 4 | 5 | Section rel. 6 | Context {Char} {HSLM : StringLikeMin Char} {predata : @parser_computational_predataT Char} {G : grammar Char}. 7 | 8 | Section size. 9 | Context {ch : Char} {valid : nonterminals_listT}. 10 | Definition size_of_reachable_from_item' 11 | (size_of_reachable_from_productions : forall {pats}, reachable_from_productions G ch valid pats -> nat) 12 | {it} (p : reachable_from_item G ch valid it) : nat 13 | := match p with 14 | | ReachableTerminal _ _ => 0 15 | | ReachableNonTerminal _ _ p' => S (size_of_reachable_from_productions p') 16 | end. 17 | 18 | Fixpoint size_of_reachable_from_productions {pats} (p : reachable_from_productions G ch valid pats) : nat 19 | := match p with 20 | | ReachableHead _ _ p' => S (size_of_reachable_from_production p') 21 | | ReachableTail _ _ p' => S (size_of_reachable_from_productions p') 22 | end 23 | with size_of_reachable_from_production {pat} (p : reachable_from_production G ch valid pat) : nat 24 | := match p with 25 | | ReachableProductionHead _ _ _ p' => S (size_of_reachable_from_item' (@size_of_reachable_from_productions) p') 26 | | ReachableProductionTail _ _ p' => S (size_of_reachable_from_production p') 27 | end. 28 | 29 | Definition size_of_reachable_from_item 30 | {it} (p : reachable_from_item G ch valid it) : nat 31 | := @size_of_reachable_from_item' (@size_of_reachable_from_productions) it p. 32 | End size. 33 | End rel. 34 | -------------------------------------------------------------------------------- /src/Common/Tactics/hint_db_extra_tactics.ml.v813: -------------------------------------------------------------------------------- 1 | module WITH_DB = 2 | struct 3 | open Tacticals.New 4 | open Ltac_plugin 5 | 6 | (* Lift a constructor to an ltac value. *) 7 | let to_ltac_val c = Tacinterp.Value.of_constr c 8 | 9 | let with_hint_db dbs tacK = 10 | (* [dbs] : list of hint databases *) 11 | (* [tacK] : tactic to run on a hint *) 12 | Proofview.Goal.enter begin 13 | fun gl -> 14 | let syms = ref [] in 15 | let _ = 16 | List.iter (fun l -> 17 | (* Fetch the searchtable from the database*) 18 | let db = Hints.searchtable_map l in 19 | (* iterate over the hint database, pulling the hint *) 20 | (* list out for each. *) 21 | Hints.Hint_db.iter (fun _ _ hintlist -> 22 | syms := hintlist::!syms) db) dbs in 23 | (* Now iterate over the list of list of hints, *) 24 | List.fold_left 25 | (fun tac hints -> 26 | List.fold_left 27 | (fun tac hint1 -> 28 | Hints.FullHint.run hint1 29 | (fun hint2 -> 30 | (* match the type of the hint to pull out the lemma *) 31 | match hint2 with 32 | Hints.Give_exact h 33 | | Hints.Res_pf h 34 | | Hints.ERes_pf h -> 35 | let lem = h.Hints.hint_term in 36 | let this_tac = Tacinterp.Value.apply tacK [Tacinterp.Value.of_constr lem] in 37 | tclORELSE this_tac tac 38 | | _ -> tac)) 39 | tac hints) 40 | (tclFAIL 0 (Pp.str "No applicable tactic!")) !syms 41 | end 42 | 43 | let add_resolve_to_db lem db = 44 | Proofview.Goal.enter begin 45 | fun gl -> 46 | let _ = Hints.add_hints ~locality:Goptions.OptLocal db (Hints.HintsResolveEntry [({ Typeclasses.hint_priority = Some 1 ; Typeclasses.hint_pattern = None },true,Hints.PathAny,lem)]) in 47 | tclIDTAC 48 | end 49 | 50 | end 51 | -------------------------------------------------------------------------------- /src/Common/Tactics/hint_db_extra_tactics.ml.v814: -------------------------------------------------------------------------------- 1 | module WITH_DB = 2 | struct 3 | open Tacticals.New 4 | open Ltac_plugin 5 | 6 | (* Lift a constructor to an ltac value. *) 7 | let to_ltac_val c = Tacinterp.Value.of_constr c 8 | 9 | let with_hint_db dbs tacK = 10 | (* [dbs] : list of hint databases *) 11 | (* [tacK] : tactic to run on a hint *) 12 | Proofview.Goal.enter begin 13 | fun gl -> 14 | let syms = ref [] in 15 | let _ = 16 | List.iter (fun l -> 17 | (* Fetch the searchtable from the database*) 18 | let db = Hints.searchtable_map l in 19 | (* iterate over the hint database, pulling the hint *) 20 | (* list out for each. *) 21 | Hints.Hint_db.iter (fun _ _ hintlist -> 22 | syms := hintlist::!syms) db) dbs in 23 | (* Now iterate over the list of list of hints, *) 24 | List.fold_left 25 | (fun tac hints -> 26 | List.fold_left 27 | (fun tac hint1 -> 28 | Hints.FullHint.run hint1 29 | (fun hint2 -> 30 | (* match the type of the hint to pull out the lemma *) 31 | match hint2 with 32 | Hints.Give_exact h 33 | | Hints.Res_pf h 34 | | Hints.ERes_pf h -> 35 | let lem = h.Hints.hint_term in 36 | let this_tac = Tacinterp.Value.apply tacK [Tacinterp.Value.of_constr lem] in 37 | tclORELSE this_tac tac 38 | | _ -> tac)) 39 | tac hints) 40 | (tclFAIL 0 (Pp.str "No applicable tactic!")) !syms 41 | end 42 | 43 | let add_resolve_to_db lem db = 44 | Proofview.Goal.enter begin 45 | fun gl -> 46 | let _ = Hints.add_hints ~locality:Goptions.OptLocal db (Hints.HintsResolveEntry [({ Typeclasses.hint_priority = Some 1 ; Typeclasses.hint_pattern = None },true,Hints.PathAny,lem)]) in 47 | tclIDTAC 48 | end 49 | 50 | end 51 | -------------------------------------------------------------------------------- /src/Parsers/Reachable/All/Reachable.v: -------------------------------------------------------------------------------- 1 | (** * Definition of Context Free Grammars *) 2 | Require Import Coq.Strings.String Coq.Lists.List. 3 | Require Import Fiat.Parsers.ContextFreeGrammar.Core. 4 | Require Import Fiat.Parsers.BaseTypes. 5 | Require Import Fiat.Common. 6 | 7 | Set Implicit Arguments. 8 | 9 | Local Open Scope string_like_scope. 10 | Local Open Scope type_scope. 11 | 12 | Section cfg. 13 | Context {Char} {HSLM : StringLikeMin Char} {predata : @parser_computational_predataT Char} (G : grammar Char). 14 | 15 | Context (ch : Char) (valid : nonterminals_listT). 16 | 17 | (** Relation defining if a character is reachable *) 18 | Inductive reachable_from_productions : productions Char -> Type := 19 | | ReachableHead : forall pat pats, reachable_from_production pat 20 | -> reachable_from_productions (pat::pats) 21 | | ReachableTail : forall pat pats, reachable_from_productions pats 22 | -> reachable_from_productions (pat::pats) 23 | with reachable_from_production : production Char -> Type := 24 | | ReachableProductionHead : forall it its, reachable_from_item it 25 | -> reachable_from_production (it::its) 26 | | ReachableProductionTail : forall it its, reachable_from_production its 27 | -> reachable_from_production (it::its) 28 | with reachable_from_item : item Char -> Type := 29 | | ReachableTerminal : forall P, is_true (P ch) -> reachable_from_item (Terminal P) 30 | | ReachableNonTerminal : forall nt, is_valid_nonterminal valid (of_nonterminal nt) 31 | -> reachable_from_productions (Lookup G nt) 32 | -> reachable_from_item (NonTerminal nt). 33 | End cfg. 34 | -------------------------------------------------------------------------------- /src/CertifiedExtraction/Extraction/QueryStructures/AllOfLength.v: -------------------------------------------------------------------------------- 1 | Require Import CertifiedExtraction.Utils. 2 | Require Bedrock.Platform.Facade.examples.TuplesF. 3 | Require Import List. 4 | 5 | Require Import CertifiedExtraction.Extraction.QueryStructures.Basics. 6 | 7 | Definition AllOfLength_set {A} N ens := 8 | forall x, Ensembles.In _ ens x -> @List.length A (TuplesF.indexedElement x) = N. 9 | 10 | Definition AllOfLength_list {A} N seq := 11 | forall x, List.In x seq -> @List.length A x = N. 12 | 13 | Lemma UnIndexedEnsembleListEquivalence_AllOfLength: 14 | forall (N : nat) A ens seq, 15 | @TuplesF.UnIndexedEnsembleListEquivalence (list A) ens seq -> 16 | AllOfLength_set N ens -> 17 | AllOfLength_list N seq. 18 | Proof. 19 | repeat match goal with 20 | | _ => cleanup 21 | | [ H: _ /\ _ |- _ ] => destruct H 22 | | [ H: exists _, _ |- _ ] => destruct H 23 | | [ H: In _ (map _ _) |- _ ] => rewrite in_map_iff in H 24 | | _ => progress unfold TuplesF.UnIndexedEnsembleListEquivalence, 25 | AllOfLength_set, AllOfLength_list in * 26 | end; firstorder. 27 | Qed. 28 | 29 | Lemma EnsembleIndexedListEquivalence_AllOfLength: 30 | forall (N : nat) A ens seq, 31 | @TuplesF.EnsembleIndexedListEquivalence (list A) ens seq -> 32 | AllOfLength_set N ens -> 33 | AllOfLength_list N seq. 34 | Proof. 35 | unfold TuplesF.EnsembleIndexedListEquivalence; cleanup. 36 | intuition eauto using UnIndexedEnsembleListEquivalence_AllOfLength. 37 | Qed. 38 | 39 | Lemma keepEq_length {A B}: 40 | forall (N : nat) ens key k default (EQ: A -> B -> Prop), 41 | AllOfLength_set N ens -> 42 | AllOfLength_set N (TuplesF.keepEq EQ default ens key k). 43 | Proof. 44 | unfold AllOfLength_set, TuplesF.keepEq, Ensembles.In; cleanup; intuition. 45 | Qed. 46 | -------------------------------------------------------------------------------- /src/QueryStructure/Specification/Operations/Update.v: -------------------------------------------------------------------------------- 1 | Require Import Coq.Lists.List 2 | Coq.Strings.String 3 | Coq.Sets.Ensembles 4 | Coq.Arith.Arith 5 | Fiat.Computation.Core 6 | Fiat.ADT.ADTSig 7 | Fiat.ADT.Core 8 | Fiat.Common.ilist 9 | Fiat.Common.StringBound 10 | Fiat.Common.Ensembles.IndexedEnsembles 11 | Fiat.ADTNotation.BuildADT 12 | Fiat.ADTNotation.BuildADTSig 13 | Fiat.QueryStructure.Specification.Representation.QueryStructureSchema 14 | Fiat.QueryStructure.Specification.Representation.QueryStructure 15 | Fiat.QueryStructure.Specification.Operations.Mutate. 16 | 17 | (* Definitions for updating query structures. *) 18 | 19 | (* This update is fairly constrained: 20 | If the update is consistent with the constraints, it is 21 | applied to the table, 22 | OTHERWISE 23 | No tables are changed. *) 24 | Definition QSUpdate 25 | qs_schema 26 | (qs : QueryStructure qs_schema) 27 | (Ridx : _) 28 | (UpdatedTuples : @Ensemble (@RawTuple (GetNRelSchemaHeading _ Ridx))) 29 | (UpdateFunction : Relation_Definitions.relation (@RawTuple (GetNRelSchemaHeading _ Ridx))) 30 | : Comp (QueryStructure qs_schema * list RawTuple) := 31 | QSMutate qs Ridx (IndexedEnsembleUpdate (GetRelation qs Ridx) UpdatedTuples UpdateFunction). 32 | 33 | Notation "'Update' b 'from' r '!' Ridx 'as' c 'making' Trans 'where' Ens" := 34 | (let qs_schema := _ in 35 | let r' : QueryStructure qs_schema := r in 36 | let Ridx' := ibound (indexb (@Build_BoundedIndex _ _ (QSschemaNames qs_schema) Ridx%string _)) in 37 | (QSUpdate r' Ridx' 38 | (fun b => Ens) (fun b c => Trans))) 39 | (r at level 0, Ridx at level 0, Ens at level 0, Trans at level 0, at level 80). 40 | -------------------------------------------------------------------------------- /src/Examples/Tutorial/NotInList_template.v: -------------------------------------------------------------------------------- 1 | Require Import Tutorial. 2 | 3 | 4 | (* A specification of what it means to choose a number that is not in a particular list *) 5 | Definition notInList (ls : list nat) := 6 | {n : nat | ~In n ls}%comp. 7 | 8 | Theorem notInList_decompose : forall ls, 9 | refine (notInList ls) (upper <- {upper | forall n, In n ls -> upper >= n}; 10 | {beyond | beyond > upper}). 11 | Proof. 12 | refines. 13 | firstorder. 14 | Qed. 15 | 16 | (* A simple traversal will find the maximum list element, which is a good upper bound. *) 17 | Definition listMax := fold_right max 0. 18 | 19 | (* ...and we can prove it! *) 20 | Theorem listMax_upperBound : forall init ls, 21 | forall n, In n ls -> fold_right max init ls >= n. 22 | Proof. 23 | induction ls; simpl; intuition. 24 | arithmetic. 25 | apply IHls in H0. 26 | arithmetic. 27 | Qed. 28 | 29 | Theorem listMax_refines : forall ls, 30 | refine {upper | forall n, In n ls -> upper >= n} (ret (listMax ls)). 31 | Proof. 32 | refines. 33 | apply listMax_upperBound. 34 | Qed. 35 | 36 | Theorem increment_refines : forall n, 37 | refine {higher | higher > n} (ret (n + 1)). 38 | Proof. 39 | refines. 40 | arithmetic. 41 | Qed. 42 | 43 | (* Let's derive an efficient implementation. *) 44 | Theorem implementation : { f : list nat -> Comp nat | forall ls, refine (notInList ls) (f ls) }. 45 | Proof. 46 | begin. 47 | rewrite notInList_decompose. 48 | rewrite listMax_refines. 49 | setoid_rewrite increment_refines. 50 | monad_simpl. 51 | finish honing. 52 | Defined. 53 | 54 | (* We can extract the program that we found as a standlone, executable Gallina term. *) 55 | Definition impl := Eval simpl in proj1_sig implementation. 56 | Print impl. 57 | 58 | Eval compute in impl (1 :: 7 :: 8 :: 2 :: 13 :: 6 :: nil). 59 | -------------------------------------------------------------------------------- /src/Examples/Ics/WaterTankExtract.v: -------------------------------------------------------------------------------- 1 | Require Export Fiat.Common.Coq__8_4__8_5__Compat. 2 | Require Import Ics WaterTank. 3 | 4 | Module Parameters. 5 | Definition tankMax := 100. 6 | Definition sensorAccuracy := 5. 7 | 8 | Theorem sensorAccuracy_positive : 0 <= sensorAccuracy. 9 | Proof. 10 | unfold sensorAccuracy; omega. 11 | Qed. 12 | 13 | Definition fillRate := 3. 14 | Definition emptyRate := 2. 15 | 16 | Definition minFill := 1. 17 | Definition maxFill := 3. 18 | Definition minEmpty := 1. 19 | Definition maxEmpty := 2. 20 | 21 | Theorem fillBounds : minFill <= maxFill. 22 | Proof. 23 | unfold minFill, maxFill; omega. 24 | Qed. 25 | 26 | Theorem emptyBounds : minEmpty <= maxEmpty. 27 | Proof. 28 | unfold minEmpty, maxEmpty; omega. 29 | Qed. 30 | End Parameters. 31 | 32 | Module D := Deterministic(Parameters). 33 | Module N := Nondeterministic(Parameters). 34 | 35 | (** Let's take the extra step to OCaml code via extraction. *) 36 | 37 | Module Det. 38 | Import D. 39 | 40 | Definition new : Z -> cRep impl'. 41 | extractConstructor impl' "new". 42 | Defined. 43 | 44 | Definition update : cRep impl' -> Z -> cRep impl' * unit. 45 | extractMethod impl' "update". 46 | Defined. 47 | 48 | Definition timestep : cRep impl' -> Z -> cRep impl' * action. 49 | extractMethod impl' "timestep". 50 | Defined. 51 | End Det. 52 | 53 | Module Nondet. 54 | Import N. 55 | 56 | Definition new : Z -> cRep impl'. 57 | extractConstructor impl' "new". 58 | Defined. 59 | 60 | Definition update : cRep impl' -> Z -> cRep impl' * unit. 61 | extractMethod impl' "update". 62 | Defined. 63 | 64 | Definition timestep : cRep impl' -> request -> cRep impl' * action. 65 | extractMethod impl' "timestep". 66 | Defined. 67 | End Nondet. 68 | 69 | Recursive Extraction Det Nondet. 70 | -------------------------------------------------------------------------------- /src/Common/Tactics/hint_db_extra_tactics.ml.v810: -------------------------------------------------------------------------------- 1 | module WITH_DB = 2 | struct 3 | open Tacticals.New 4 | open Ltac_plugin 5 | 6 | (* Lift a constructor to an ltac value. *) 7 | let to_ltac_val c = Tacinterp.Value.of_constr c 8 | 9 | let with_hint_db dbs tacK = 10 | (* [dbs] : list of hint databases *) 11 | (* [tacK] : tactic to run on a hint *) 12 | Proofview.Goal.enter begin 13 | fun gl -> 14 | let syms = ref [] in 15 | let _ = 16 | List.iter (fun l -> 17 | (* Fetch the searchtable from the database*) 18 | let db = Hints.searchtable_map l in 19 | (* iterate over the hint database, pulling the hint *) 20 | (* list out for each. *) 21 | Hints.Hint_db.iter (fun _ _ hintlist -> 22 | syms := hintlist::!syms) db) dbs in 23 | (* Now iterate over the list of list of hints, *) 24 | List.fold_left 25 | (fun tac hints -> 26 | List.fold_left 27 | (fun tac (hint : Hints.full_hint) -> 28 | let hint1 = hint.Hints.code in 29 | Hints.run_hint hint1 30 | (fun hint2 -> 31 | (* match the type of the hint to pull out the lemma *) 32 | match hint2 with 33 | Hints.Give_exact ((lem, _, _) , _) 34 | | Hints.Res_pf ((lem, _, _) , _) 35 | | Hints.ERes_pf ((lem, _, _) , _) -> 36 | let this_tac = Tacinterp.Value.apply tacK [Tacinterp.Value.of_constr lem] in 37 | tclORELSE this_tac tac 38 | | _ -> tac)) 39 | tac hints) 40 | (tclFAIL 0 (Pp.str "No applicable tactic!")) !syms 41 | end 42 | 43 | let add_resolve_to_db lem db = 44 | Proofview.Goal.enter begin 45 | fun gl -> 46 | let _ = Hints.add_hints ~local:true db (Hints.HintsResolveEntry [({ Typeclasses.hint_priority = Some 1 ; Typeclasses.hint_pattern = None },false,true,Hints.PathAny,lem)]) in 47 | tclIDTAC 48 | end 49 | 50 | end 51 | -------------------------------------------------------------------------------- /src/Common/Tactics/hint_db_extra_tactics.ml.v811: -------------------------------------------------------------------------------- 1 | module WITH_DB = 2 | struct 3 | open Tacticals.New 4 | open Ltac_plugin 5 | 6 | (* Lift a constructor to an ltac value. *) 7 | let to_ltac_val c = Tacinterp.Value.of_constr c 8 | 9 | let with_hint_db dbs tacK = 10 | (* [dbs] : list of hint databases *) 11 | (* [tacK] : tactic to run on a hint *) 12 | Proofview.Goal.enter begin 13 | fun gl -> 14 | let syms = ref [] in 15 | let _ = 16 | List.iter (fun l -> 17 | (* Fetch the searchtable from the database*) 18 | let db = Hints.searchtable_map l in 19 | (* iterate over the hint database, pulling the hint *) 20 | (* list out for each. *) 21 | Hints.Hint_db.iter (fun _ _ hintlist -> 22 | syms := hintlist::!syms) db) dbs in 23 | (* Now iterate over the list of list of hints, *) 24 | List.fold_left 25 | (fun tac hints -> 26 | List.fold_left 27 | (fun tac (hint : Hints.full_hint) -> 28 | let hint1 = hint.Hints.code in 29 | Hints.run_hint hint1 30 | (fun hint2 -> 31 | (* match the type of the hint to pull out the lemma *) 32 | match hint2 with 33 | Hints.Give_exact ((lem, _, _) , _) 34 | | Hints.Res_pf ((lem, _, _) , _) 35 | | Hints.ERes_pf ((lem, _, _) , _) -> 36 | let this_tac = Tacinterp.Value.apply tacK [Tacinterp.Value.of_constr lem] in 37 | tclORELSE this_tac tac 38 | | _ -> tac)) 39 | tac hints) 40 | (tclFAIL 0 (Pp.str "No applicable tactic!")) !syms 41 | end 42 | 43 | let add_resolve_to_db lem db = 44 | Proofview.Goal.enter begin 45 | fun gl -> 46 | let _ = Hints.add_hints ~local:true db (Hints.HintsResolveEntry [({ Typeclasses.hint_priority = Some 1 ; Typeclasses.hint_pattern = None },false,true,Hints.PathAny,lem)]) in 47 | tclIDTAC 48 | end 49 | 50 | end 51 | --------------------------------------------------------------------------------