camfort 0.905 → 0.906
raw patch · 73 files changed
+3174/−756 lines, 73 filesdep +paralleldep +prettydep +strictdep −partial-orderdep ~containersdep ~fgldep ~fortran-srcnew-uploader
Dependencies added: parallel, pretty, strict, writer-cps-morph, writer-cps-mtl, writer-cps-transformers
Dependencies removed: partial-order
Dependency ranges changed: containers, fgl, fortran-src, hmatrix, temporary, transformers
Files
- CHANGELOG.md +13/−1
- LICENSE +11/−198
- camfort.cabal +277/−196
- src/Camfort/Analysis.hs +23/−4
- src/Camfort/Analysis/Logger.hs +41/−12
- src/Camfort/Analysis/ModFile.hs +22/−14
- src/Camfort/Analysis/Simple.hs +364/−5
- src/Camfort/Functionality.hs +152/−16
- src/Camfort/Helpers.hs +1/−1
- src/Camfort/Helpers/Syntax.hs +13/−9
- src/Camfort/Input.hs +20/−19
- src/Camfort/Output.hs +23/−20
- src/Camfort/Reprint.hs +2/−2
- src/Camfort/Specification/DerivedDataType.hs +772/−0
- src/Camfort/Specification/DerivedDataType/Parser.y +140/−0
- src/Camfort/Specification/Hoare.hs +2/−1
- src/Camfort/Specification/Hoare/CheckBackend.hs +15/−4
- src/Camfort/Specification/Hoare/CheckFrontend.hs +1/−1
- src/Camfort/Specification/Hoare/Translate.hs +3/−2
- src/Camfort/Specification/Stencils.hs +2/−1
- src/Camfort/Specification/Stencils/CheckFrontend.hs +4/−4
- src/Camfort/Specification/Stencils/Generate.hs +23/−3
- src/Camfort/Specification/Stencils/InferenceFrontend.hs +3/−3
- src/Camfort/Specification/Stencils/Model.hs +1/−1
- src/Camfort/Specification/Stencils/PartialOrd.hs +136/−0
- src/Camfort/Specification/Stencils/Synthesis.hs +1/−1
- src/Camfort/Specification/Units/Analysis.hs +130/−31
- src/Camfort/Specification/Units/Analysis/Consistent.hs +1/−1
- src/Camfort/Specification/Units/Analysis/Infer.hs +1/−1
- src/Camfort/Specification/Units/Environment.hs +6/−0
- src/Camfort/Specification/Units/InferenceBackend.hs +249/−45
- src/Camfort/Specification/Units/InferenceBackendFlint.hs +3/−1
- src/Camfort/Specification/Units/ModFile.hs +58/−9
- src/Camfort/Specification/Units/MonadTypes.hs +1/−1
- src/Camfort/Transformation/CommonBlockElim.hs +63/−50
- src/Camfort/Transformation/EquivalenceElim.hs +2/−2
- src/Language/Fortran/Model/Translate.hs +19/−16
- src/Language/Fortran/Model/Vars.hs +4/−4
- src/Main.hs +108/−16
- tests/Camfort/Analysis/CommentAnnotatorSpec.hs +1/−1
- tests/Camfort/Analysis/TestUtils.hs +2/−2
- tests/Camfort/ReprintSpec.hs +6/−6
- tests/Camfort/Specification/DerivedDataTypeSpec.hs +78/−0
- tests/Camfort/Specification/Hoare/ParserSpec.hs +1/−1
- tests/Camfort/Specification/StencilsSpec.hs +9/−2
- tests/Camfort/Specification/Units/Analysis/ConsistentSpec.hs +20/−30
- tests/Camfort/Specification/Units/Analysis/CriticalsSpec.hs +1/−1
- tests/Camfort/Specification/Units/Analysis/InferSpec.hs +42/−8
- tests/Camfort/Transformation/CommonSpec.hs +2/−0
- tests/Camfort/Transformation/EquivalenceElimSpec.hs +4/−2
- tests/fixtures/Specification/Stencils/example10.expected.f +15/−0
- tests/fixtures/Specification/Stencils/example11.expected.f +15/−0
- tests/fixtures/Specification/Stencils/example13.expected.f +15/−0
- tests/fixtures/Specification/Stencils/example14.expected.f +15/−0
- tests/fixtures/Specification/Stencils/example15.expected.f +13/−0
- tests/fixtures/Specification/Stencils/example5.expected.f +14/−0
- tests/fixtures/Specification/Stencils/example5a.expected.f +14/−0
- tests/fixtures/Specification/Stencils/example5a.f +12/−0
- tests/fixtures/Specification/Stencils/example6.expected.f +14/−0
- tests/fixtures/Specification/Stencils/example7.expected.f +14/−0
- tests/fixtures/Specification/Stencils/example8.expected.f +14/−0
- tests/fixtures/Specification/Stencils/example9.expected.f +13/−0
- tests/fixtures/Specification/Units/exp.ex1.f90 +29/−0
- tests/fixtures/Specification/Units/exp.ex2.f90 +12/−0
- tests/fixtures/Specification/Units/exp.ex3.f90 +17/−0
- tests/fixtures/Specification/Units/exp.param.f90 +12/−0
- tests/fixtures/Specification/Units/literal-nonzero-inconsist2.f90 +4/−2
- tests/fixtures/Specification/Units/literal-nonzero-inconsist3.f90 +4/−3
- tests/fixtures/Specification/Units/literal-nonzero-inconsist5.f90 +2/−3
- tests/fixtures/Specification/Units/literal-nonzero2.f90 +15/−0
- tests/fixtures/Transformation/cmn.expected.f90 +5/−0
- tests/fixtures/Transformation/common.expected.f90 +9/−0
- tests/fixtures/Transformation/equiv.expected.f90 +21/−0
CHANGELOG.md view
@@ -1,4 +1,16 @@-## 0.905 (18 May, 2018)+## 0.906 (June 13, 2019)++* Update to new fortran-src version 0.3.0.+* Add array-check, alloc-check, use-check, fp-check and implicit-none features.+ * A collection of sanity checks on Fortran code looking for common issues, possible problems or potential inefficiencies.+* Introduce a divide-and-conquer methodology for solving units-inference problems, reducing the size of the matrices and taking advantage of SMP where available.+* Treat constant-expressions and parameter variables as literals, for units-inference purposes, making it easier to retrofit units annotations onto existing programs.+* Add 'units-infer --show-ast' feature, which decorates the displayed AST (internal data structure) with units information on each expression.+* Made assorted efficiency improvements to the units solver and other features, especially for large projects with many files.+* Add 'units-check --dump-mod-file' feature that lets you view an 'fsmod' file's contents with regard to units info.+* Allow override of Fortran version used by parser using -F option.++## 0.905 (May 18, 2018) * Greatly improved units-of-measure support * Separate verification of modules
LICENSE view
@@ -1,202 +1,15 @@-- Apache License- Version 2.0, January 2004- http://www.apache.org/licenses/-- TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION-- 1. Definitions.-- "License" shall mean the terms and conditions for use, reproduction,- and distribution as defined by Sections 1 through 9 of this document.-- "Licensor" shall mean the copyright owner or entity authorized by- the copyright owner that is granting the License.-- "Legal Entity" shall mean the union of the acting entity and all- other entities that control, are controlled by, or are under common- control with that entity. For the purposes of this definition,- "control" means (i) the power, direct or indirect, to cause the- direction or management of such entity, whether by contract or- otherwise, or (ii) ownership of fifty percent (50%) or more of the- outstanding shares, or (iii) beneficial ownership of such entity.-- "You" (or "Your") shall mean an individual or Legal Entity- exercising permissions granted by this License.-- "Source" form shall mean the preferred form for making modifications,- including but not limited to software source code, documentation- source, and configuration files.-- "Object" form shall mean any form resulting from mechanical- transformation or translation of a Source form, including but- not limited to compiled object code, generated documentation,- and conversions to other media types.-- "Work" shall mean the work of authorship, whether in Source or- Object form, made available under the License, as indicated by a- copyright notice that is included in or attached to the work- (an example is provided in the Appendix below).-- "Derivative Works" shall mean any work, whether in Source or Object- form, that is based on (or derived from) the Work and for which the- editorial revisions, annotations, elaborations, or other modifications- represent, as a whole, an original work of authorship. For the purposes- of this License, Derivative Works shall not include works that remain- separable from, or merely link (or bind by name) to the interfaces of,- the Work and Derivative Works thereof.-- "Contribution" shall mean any work of authorship, including- the original version of the Work and any modifications or additions- to that Work or Derivative Works thereof, that is intentionally- submitted to Licensor for inclusion in the Work by the copyright owner- or by an individual or Legal Entity authorized to submit on behalf of- the copyright owner. For the purposes of this definition, "submitted"- means any form of electronic, verbal, or written communication sent- to the Licensor or its representatives, including but not limited to- communication on electronic mailing lists, source code control systems,- and issue tracking systems that are managed by, or on behalf of, the- Licensor for the purpose of discussing and improving the Work, but- excluding communication that is conspicuously marked or otherwise- designated in writing by the copyright owner as "Not a Contribution."-- "Contributor" shall mean Licensor and any individual or Legal Entity- on behalf of whom a Contribution has been received by Licensor and- subsequently incorporated within the Work.-- 2. Grant of Copyright License. Subject to the terms and conditions of- this License, each Contributor hereby grants to You a perpetual,- worldwide, non-exclusive, no-charge, royalty-free, irrevocable- copyright license to reproduce, prepare Derivative Works of,- publicly display, publicly perform, sublicense, and distribute the- Work and such Derivative Works in Source or Object form.-- 3. Grant of Patent License. Subject to the terms and conditions of- this License, each Contributor hereby grants to You a perpetual,- worldwide, non-exclusive, no-charge, royalty-free, irrevocable- (except as stated in this section) patent license to make, have made,- use, offer to sell, sell, import, and otherwise transfer the Work,- where such license applies only to those patent claims licensable- by such Contributor that are necessarily infringed by their- Contribution(s) alone or by combination of their Contribution(s)- with the Work to which such Contribution(s) was submitted. If You- institute patent litigation against any entity (including a- cross-claim or counterclaim in a lawsuit) alleging that the Work- or a Contribution incorporated within the Work constitutes direct- or contributory patent infringement, then any patent licenses- granted to You under this License for that Work shall terminate- as of the date such litigation is filed.-- 4. Redistribution. You may reproduce and distribute copies of the- Work or Derivative Works thereof in any medium, with or without- modifications, and in Source or Object form, provided that You- meet the following conditions:-- (a) You must give any other recipients of the Work or- Derivative Works a copy of this License; and-- (b) You must cause any modified files to carry prominent notices- stating that You changed the files; and-- (c) You must retain, in the Source form of any Derivative Works- that You distribute, all copyright, patent, trademark, and- attribution notices from the Source form of the Work,- excluding those notices that do not pertain to any part of- the Derivative Works; and-- (d) If the Work includes a "NOTICE" text file as part of its- distribution, then any Derivative Works that You distribute must- include a readable copy of the attribution notices contained- within such NOTICE file, excluding those notices that do not- pertain to any part of the Derivative Works, in at least one- of the following places: within a NOTICE text file distributed- as part of the Derivative Works; within the Source form or- documentation, if provided along with the Derivative Works; or,- within a display generated by the Derivative Works, if and- wherever such third-party notices normally appear. The contents- of the NOTICE file are for informational purposes only and- do not modify the License. You may add Your own attribution- notices within Derivative Works that You distribute, alongside- or as an addendum to the NOTICE text from the Work, provided- that such additional attribution notices cannot be construed- as modifying the License.-- You may add Your own copyright statement to Your modifications and- may provide additional or different license terms and conditions- for use, reproduction, or distribution of Your modifications, or- for any such Derivative Works as a whole, provided Your use,- reproduction, and distribution of the Work otherwise complies with- the conditions stated in this License.-- 5. Submission of Contributions. Unless You explicitly state otherwise,- any Contribution intentionally submitted for inclusion in the Work- by You to the Licensor shall be under the terms and conditions of- this License, without any additional terms or conditions.- Notwithstanding the above, nothing herein shall supersede or modify- the terms of any separate license agreement you may have executed- with Licensor regarding such Contributions.-- 6. Trademarks. This License does not grant permission to use the trade- names, trademarks, service marks, or product names of the Licensor,- except as required for reasonable and customary use in describing the- origin of the Work and reproducing the content of the NOTICE file.-- 7. Disclaimer of Warranty. Unless required by applicable law or- agreed to in writing, Licensor provides the Work (and each- Contributor provides its Contributions) on an "AS IS" BASIS,- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or- implied, including, without limitation, any warranties or conditions- of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A- PARTICULAR PURPOSE. You are solely responsible for determining the- appropriateness of using or redistributing the Work and assume any- risks associated with Your exercise of permissions under this License.-- 8. Limitation of Liability. In no event and under no legal theory,- whether in tort (including negligence), contract, or otherwise,- unless required by applicable law (such as deliberate and grossly- negligent acts) or agreed to in writing, shall any Contributor be- liable to You for damages, including any direct, indirect, special,- incidental, or consequential damages of any character arising as a- result of this License or out of the use or inability to use the- Work (including but not limited to damages for loss of goodwill,- work stoppage, computer failure or malfunction, or any and all- other commercial damages or losses), even if such Contributor- has been advised of the possibility of such damages.-- 9. Accepting Warranty or Additional Liability. While redistributing- the Work or Derivative Works thereof, You may choose to offer,- and charge a fee for, acceptance of support, warranty, indemnity,- or other liability obligations and/or rights consistent with this- License. However, in accepting such obligations, You may act only- on Your own behalf and on Your sole responsibility, not on behalf- of any other Contributor, and only if You agree to indemnify,- defend, and hold each Contributor harmless for any liability- incurred by, or claims asserted against, such Contributor by reason- of your accepting any such warranty or additional liability.-- END OF TERMS AND CONDITIONS-- APPENDIX: How to apply the Apache License to your work.-- To apply the Apache License to your work, attach the following- boilerplate notice, with the fields enclosed by brackets "[]"- replaced with your own identifying information. (Don't include- the brackets!) The text should be enclosed in the appropriate- comment syntax for the file format. We also recommend that a- file or class name and description of purpose be included on the- same "printed page" as the copyright notice for easier- identification within third-party archives.+Copyright (c) 2015-2019: Matthew Danish, Mistral Contrastin, Dominic Orchard and Andrew Rice - Copyright [yyyy] [name of copyright owner]+Additional thanks for contributions from: Ben Moon, Bradley Hardy, Oleg Oshmyan and Vilem Liepelt - Licensed under the Apache License, Version 2.0 (the "License");- you may not use this file except in compliance with the License.- You may obtain a copy of the License at+Licensed under the Apache License, Version 2.0 (the "License");+you may not use this file except in compliance with the License.+You may obtain a copy of the License at - http://www.apache.org/licenses/LICENSE-2.0+ http://www.apache.org/licenses/LICENSE-2.0 - Unless required by applicable law or agreed to in writing, software- distributed under the License is distributed on an "AS IS" BASIS,- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.- See the License for the specific language governing permissions and- limitations under the License.+Unless required by applicable law or agreed to in writing, software+distributed under the License is distributed on an "AS IS" BASIS,+WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+See the License for the specific language governing permissions and+limitations under the License.
camfort.cabal view
@@ -1,209 +1,290 @@-name: camfort-version: 0.905-synopsis: CamFort - Cambridge Fortran infrastructure-description: CamFort is a tool for the analysis, transformation, verification of Fortran code.-homepage: https://camfort.github.io-bug-reports: https://github.com/camfort/camfort/issues--copyright: 2012-2018 University of Cambridge-author: Dominic Orchard, Matthew Danish, Mistral Contrastin, Andrew Rice, Oleg Oshmyan-maintainer: dom.orchard@gmail.com--license: Apache-2.0-license-file: LICENSE--stability: experimental-build-type: Simple-category: Language+cabal-version: 1.12 -cabal-version: 1.18-tested-with: GHC >= 8.2+-- This file has been generated from package.yaml by hpack version 0.31.1.+--+-- see: https://github.com/sol/hpack+--+-- hash: d90f27e0fcefd6d71f89123fef96fef2ec2cb33a5f7c7c99da877dd1734efa95 -extra-source-files: tests/fixtures/Specification/Stencils/*.f- tests/fixtures/Specification/Units/*.f90- tests/fixtures/Transformation/*.f90- CHANGELOG.md+name: camfort+version: 0.906+synopsis: CamFort - Cambridge Fortran infrastructure+description: CamFort is a tool for the analysis, transformation, verification of Fortran code.+category: Language+stability: experimental+homepage: https://camfort.github.io+bug-reports: https://github.com/camfort/camfort/issues+author: Matthew Danish, Mistral Contrastin, Andrew Rice, Dominic Orchard+maintainer: Matthew Danish+copyright: 2012-2019 University of Cambridge+license: Apache-2.0+license-file: LICENSE+tested-with: GHC >= 8.6+build-type: Simple+extra-source-files:+ tests/fixtures/Specification/Stencils/example10.expected.f+ tests/fixtures/Specification/Stencils/example10.f+ tests/fixtures/Specification/Stencils/example11.expected.f+ tests/fixtures/Specification/Stencils/example11.f+ tests/fixtures/Specification/Stencils/example12.f+ tests/fixtures/Specification/Stencils/example13.expected.f+ tests/fixtures/Specification/Stencils/example13.f+ tests/fixtures/Specification/Stencils/example14.expected.f+ tests/fixtures/Specification/Stencils/example14.f+ tests/fixtures/Specification/Stencils/example15.expected.f+ tests/fixtures/Specification/Stencils/example15.f+ tests/fixtures/Specification/Stencils/example16.f+ tests/fixtures/Specification/Stencils/example17.f+ tests/fixtures/Specification/Stencils/example2.f+ tests/fixtures/Specification/Stencils/example3.f+ tests/fixtures/Specification/Stencils/example4.f+ tests/fixtures/Specification/Stencils/example5.expected.f+ tests/fixtures/Specification/Stencils/example5.f+ tests/fixtures/Specification/Stencils/example5a.expected.f+ tests/fixtures/Specification/Stencils/example5a.f+ tests/fixtures/Specification/Stencils/example6.expected.f+ tests/fixtures/Specification/Stencils/example6.f+ tests/fixtures/Specification/Stencils/example7.expected.f+ tests/fixtures/Specification/Stencils/example7.f+ tests/fixtures/Specification/Stencils/example8.expected.f+ tests/fixtures/Specification/Stencils/example8.f+ tests/fixtures/Specification/Stencils/example9.expected.f+ tests/fixtures/Specification/Stencils/example9.f+ tests/fixtures/Specification/Units/do-loop1.f90+ tests/fixtures/Specification/Units/do-loop2.f90+ tests/fixtures/Specification/Units/eapVarApp.f90+ tests/fixtures/Specification/Units/eapVarScope.f90+ tests/fixtures/Specification/Units/ex1.f90+ tests/fixtures/Specification/Units/ex2.f90+ tests/fixtures/Specification/Units/ex3.f90+ tests/fixtures/Specification/Units/example-criticals-1.f90+ tests/fixtures/Specification/Units/example-criticals-2.f90+ tests/fixtures/Specification/Units/example-inconsist-1.f90+ tests/fixtures/Specification/Units/example-simple-1.f90+ tests/fixtures/Specification/Units/exp.ex1.f90+ tests/fixtures/Specification/Units/exp.ex2.f90+ tests/fixtures/Specification/Units/exp.ex3.f90+ tests/fixtures/Specification/Units/exp.param.f90+ tests/fixtures/Specification/Units/gcd1.f90+ tests/fixtures/Specification/Units/inconsist3.f90+ tests/fixtures/Specification/Units/inconsistLitInPolyFun.f90+ tests/fixtures/Specification/Units/inconsistRecMult.f90+ tests/fixtures/Specification/Units/inferPoly1.f90+ tests/fixtures/Specification/Units/insideOutside.f90+ tests/fixtures/Specification/Units/literal-nonzero-inconsist1.f90+ tests/fixtures/Specification/Units/literal-nonzero-inconsist2.f90+ tests/fixtures/Specification/Units/literal-nonzero-inconsist3.f90+ tests/fixtures/Specification/Units/literal-nonzero-inconsist4.f90+ tests/fixtures/Specification/Units/literal-nonzero-inconsist5.f90+ tests/fixtures/Specification/Units/literal-nonzero.f90+ tests/fixtures/Specification/Units/literal-nonzero2.f90+ tests/fixtures/Specification/Units/literal-zero.f90+ tests/fixtures/Specification/Units/param.f90+ tests/fixtures/Specification/Units/recursive1.f90+ tests/fixtures/Specification/Units/sqrtPoly.f90+ tests/fixtures/Specification/Units/squarePoly1.f90+ tests/fixtures/Specification/Units/transfer.f90+ tests/fixtures/Transformation/cmn.expected.f90+ tests/fixtures/Transformation/common.expected.f90+ tests/fixtures/Transformation/common.f90+ tests/fixtures/Transformation/equiv.expected.f90+ tests/fixtures/Transformation/equiv.f90+ CHANGELOG.md source-repository head type: git location: https://github.com/camfort/camfort -executable camfort- main-is: src/Main.hs- build-depends: base >= 4.6 && < 5,- directory >= 1.2 && < 2,- optparse-applicative >= 0.14 && < 0.15,- camfort- default-language: Haskell2010- library- hs-source-dirs: src- build-tools: alex >= 3.1, happy >= 1.19- extra-libraries: flint- exposed-modules: Camfort.Analysis- Camfort.Analysis.Logger- Camfort.Analysis.Annotations- Camfort.Analysis.CommentAnnotator- Camfort.Analysis.ModFile- Camfort.Analysis.Simple- Camfort.Specification.Parser-- Camfort.Specification.Stencils.Analysis- Camfort.Specification.Stencils.Annotation- Camfort.Specification.Stencils.CheckBackend- Camfort.Specification.Stencils.CheckFrontend- Camfort.Specification.Stencils.Consistency- Camfort.Specification.Stencils.DenotationalSemantics- Camfort.Specification.Stencils.InferenceBackend- Camfort.Specification.Stencils.InferenceFrontend- Camfort.Specification.Stencils.Model- Camfort.Specification.Stencils.Syntax- Camfort.Specification.Stencils.Generate- Camfort.Specification.Stencils.Parser- Camfort.Specification.Stencils.Parser.Types- Camfort.Specification.Stencils.Synthesis- Camfort.Specification.Stencils-- Camfort.Specification.Units- Camfort.Specification.Units.Analysis- Camfort.Specification.Units.Analysis.Consistent- Camfort.Specification.Units.Analysis.Criticals- Camfort.Specification.Units.Analysis.Infer- Camfort.Specification.Units.Annotation- Camfort.Specification.Units.InferenceBackend- Camfort.Specification.Units.InferenceBackendFlint- Camfort.Specification.Units.InferenceBackendSBV- Camfort.Specification.Units.BackendTypes- Camfort.Specification.Units.Environment- Camfort.Specification.Units.ModFile- Camfort.Specification.Units.Monad- Camfort.Specification.Units.MonadTypes- Camfort.Specification.Units.Parser- Camfort.Specification.Units.Parser.Types- Camfort.Specification.Units.Synthesis-- Camfort.Specification.Hoare- Camfort.Specification.Hoare.Annotation- Camfort.Specification.Hoare.Parser- Camfort.Specification.Hoare.Parser.Types- Camfort.Specification.Hoare.Lexer- Camfort.Specification.Hoare.Syntax- Camfort.Specification.Hoare.Translate- Camfort.Specification.Hoare.CheckFrontend- Camfort.Specification.Hoare.CheckBackend-- Camfort.Transformation.CommonBlockElim- Camfort.Transformation.DeadCode- Camfort.Transformation.EquivalenceElim-- Camfort.Helpers- Camfort.Helpers.Syntax- Camfort.Helpers.Vec- Camfort.Helpers.TypeLevel- Camfort.Functionality- Camfort.Input- Camfort.Output- Camfort.Reprint-- Language.Fortran.Model- Language.Fortran.Model.Singletons- Language.Fortran.Model.Types- Language.Fortran.Model.Types.Match- Language.Fortran.Model.Translate- Language.Fortran.Model.Repr- Language.Fortran.Model.Repr.Prim- Language.Fortran.Model.Vars- Language.Fortran.Model.Op- Language.Fortran.Model.Op.Eval- Language.Fortran.Model.Op.Core- Language.Fortran.Model.Op.Core.Match- Language.Fortran.Model.Op.Core.Core- Language.Fortran.Model.Op.Core.Eval- Language.Fortran.Model.Op.Meta- Language.Fortran.Model.Op.High- Language.Fortran.Model.Util-- build-depends: base >= 4.6 && < 5,- ghc-prim >= 0.3.1.0 && < 0.6,- containers >= 0.5.0.0 && < 0.6,- uniplate >= 1.6.10 && < 1.7,- syz >= 0.2 && < 0.3,- syb >= 0.4 && < 0.8,- matrix >= 0.2.2 && < 0.4,- hmatrix >= 0.15 && < 0.19,- mtl >= 2.1 && < 2.3,- text >= 0.11.2.3 && < 1.3,- array >= 0.4 && < 0.6,- directory >= 1.2 && < 1.4,- transformers >= 0.4 && < 0.6,- vector >= 0.1 && < 0.13,- GenericPretty >= 1.2.2 && < 1.3,- fortran-src >= 0.2.1.1 && < 0.3,- filepath >= 1.4 && < 1.5,- bytestring >= 0.10 && < 0.11,- fgl >= 5.6 && < 5.7,- binary >= 0.8.3.0 && < 0.9,- lattices >= 1.7.1 && < 1.8,- sbv >= 7.0 && < 8,- partial-order >= 0.1.2.1 && < 0.1.3,- lens >= 4.15.1 && < 5,- mmorph >= 1.0.9 && < 2,- singletons >= 2.2 && < 3,- template-haskell >= 2.11 && < 3,- vinyl >= 0.6 && < 1.0,- verifiable-expressions >= 0.4+ exposed-modules:+ Camfort.Analysis+ Camfort.Analysis.Logger+ Camfort.Analysis.Annotations+ Camfort.Analysis.CommentAnnotator+ Camfort.Analysis.ModFile+ Camfort.Analysis.Simple+ Camfort.Specification.Parser+ Camfort.Specification.DerivedDataType+ Camfort.Specification.DerivedDataType.Parser+ Camfort.Specification.Stencils.Analysis+ Camfort.Specification.Stencils.Annotation+ Camfort.Specification.Stencils.CheckBackend+ Camfort.Specification.Stencils.CheckFrontend+ Camfort.Specification.Stencils.Consistency+ Camfort.Specification.Stencils.DenotationalSemantics+ Camfort.Specification.Stencils.InferenceBackend+ Camfort.Specification.Stencils.InferenceFrontend+ Camfort.Specification.Stencils.PartialOrd+ Camfort.Specification.Stencils.Model+ Camfort.Specification.Stencils.Syntax+ Camfort.Specification.Stencils.Generate+ Camfort.Specification.Stencils.Parser+ Camfort.Specification.Stencils.Parser.Types+ Camfort.Specification.Stencils.Synthesis+ Camfort.Specification.Stencils+ Camfort.Specification.Units+ Camfort.Specification.Units.Analysis+ Camfort.Specification.Units.Analysis.Consistent+ Camfort.Specification.Units.Analysis.Criticals+ Camfort.Specification.Units.Analysis.Infer+ Camfort.Specification.Units.Annotation+ Camfort.Specification.Units.InferenceBackend+ Camfort.Specification.Units.InferenceBackendFlint+ Camfort.Specification.Units.InferenceBackendSBV+ Camfort.Specification.Units.BackendTypes+ Camfort.Specification.Units.Environment+ Camfort.Specification.Units.ModFile+ Camfort.Specification.Units.Monad+ Camfort.Specification.Units.MonadTypes+ Camfort.Specification.Units.Parser+ Camfort.Specification.Units.Parser.Types+ Camfort.Specification.Units.Synthesis+ Camfort.Specification.Hoare+ Camfort.Specification.Hoare.Annotation+ Camfort.Specification.Hoare.Parser+ Camfort.Specification.Hoare.Parser.Types+ Camfort.Specification.Hoare.Lexer+ Camfort.Specification.Hoare.Syntax+ Camfort.Specification.Hoare.Translate+ Camfort.Specification.Hoare.CheckFrontend+ Camfort.Specification.Hoare.CheckBackend+ Camfort.Transformation.CommonBlockElim+ Camfort.Transformation.DeadCode+ Camfort.Transformation.EquivalenceElim+ Camfort.Helpers+ Camfort.Helpers.Syntax+ Camfort.Helpers.Vec+ Camfort.Helpers.TypeLevel+ Camfort.Functionality+ Camfort.Input+ Camfort.Output+ Camfort.Reprint+ Language.Fortran.Model+ Language.Fortran.Model.Singletons+ Language.Fortran.Model.Types+ Language.Fortran.Model.Types.Match+ Language.Fortran.Model.Translate+ Language.Fortran.Model.Repr+ Language.Fortran.Model.Repr.Prim+ Language.Fortran.Model.Vars+ Language.Fortran.Model.Op+ Language.Fortran.Model.Op.Eval+ Language.Fortran.Model.Op.Core+ Language.Fortran.Model.Op.Core.Match+ Language.Fortran.Model.Op.Core.Core+ Language.Fortran.Model.Op.Core.Eval+ Language.Fortran.Model.Op.Meta+ Language.Fortran.Model.Op.High+ Language.Fortran.Model.Util+ hs-source-dirs:+ src+ extra-libraries:+ flint+ build-tools:+ alex ==3.2.*+ , happy ==1.19.*+ build-depends:+ GenericPretty >=1.2.2 && <1.3+ , array >=0.4 && <0.6+ , base >=4.6 && <5+ , binary >=0.8.3.0 && <0.9+ , bytestring >=0.10 && <0.11+ , containers >=0.5.0.0 && <0.7+ , directory >=1.2 && <1.4+ , fgl >=5.6 && <5.8+ , filepath >=1.4 && <1.5+ , fortran-src >=0.3 && <0.4+ , ghc-prim >=0.3.1.0 && <0.6+ , hmatrix >=0.15 && <0.20+ , lattices >=1.7.1 && <1.8+ , lens >=4.15.1 && <5+ , matrix >=0.2.2 && <0.4+ , mmorph >=1.0.9 && <2+ , mtl >=2.1 && <2.3+ , parallel+ , pretty >=1.1 && <2+ , sbv >=7.0 && <8+ , singletons >=2.2 && <3+ , strict >=0.3.2 && <1+ , syb >=0.4 && <0.8+ , syz >=0.2 && <0.3+ , template-haskell >=2.11 && <3+ , text >=0.11.2.3 && <1.3+ , transformers >=0.5.5.0 && <0.6+ , uniplate >=1.6.10 && <1.7+ , vector >=0.1 && <0.13+ , verifiable-expressions >=0.4+ , vinyl >=0.6 && <1.0+ , writer-cps-morph >=0.1.0.2+ , writer-cps-mtl >=0.1.1.5+ , writer-cps-transformers >=0.1.1.2+ default-language: Haskell2010 +executable camfort+ main-is: src/Main.hs+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ base >=4.6 && <5+ , camfort+ , directory >=1.2 && <2+ , fortran-src >=0.3 && <0.4+ , optparse-applicative >=0.14 && <0.15 default-language: Haskell2010 test-suite spec- type: exitcode-stdio-1.0- main-is: Spec.hs- hs-source-dirs: tests- other-modules: Camfort.Analysis.TestUtils- Camfort.Analysis.CommentAnnotatorSpec- Camfort.Analysis.ModFileSpec- Camfort.Analysis.ImplicitNoneSpec- Camfort.FunctionalitySpec- Camfort.ReprintSpec- Camfort.Specification.ParserSpec- Camfort.Specification.Stencils.CheckSpec- Camfort.Specification.Stencils.ConsistencySpec- Camfort.Specification.Stencils.DenotationalSemanticsSpec- Camfort.Specification.Stencils.ParserSpec- Camfort.Specification.Stencils.InferenceBackendSpec- Camfort.Specification.Stencils.ModelSpec- Camfort.Specification.StencilsSpec- Camfort.Specification.Units.Analysis.ConsistentSpec- Camfort.Specification.Units.Analysis.CriticalsSpec- Camfort.Specification.Units.Analysis.InferSpec- Camfort.Specification.Units.InferenceBackendSpec- Camfort.Specification.Units.ParserSpec- Camfort.Specification.Hoare.ParserSpec- Camfort.Transformation.CommonSpec- Camfort.Transformation.EquivalenceElimSpec-- build-depends: base >= 4.6 && < 5,- containers >= 0.5.0.0 && < 0.6,- filepath >= 1.4 && < 1.5,- directory >= 1.2 && < 2,- hspec >= 2.2 && < 3,- QuickCheck >= 2.8 && < 3,- fgl >= 5.6 && < 5.7,- fortran-src >= 0.2.1.1 && < 0.3,- uniplate >= 1.6.10 && < 1.7,- mtl >= 2.1 && < 2.3,- bytestring >= 0.10 && < 0.11,- array >= 0.4 && < 0.6,- hmatrix >= 0.15 && < 0.19,- text >= 0.11.2.3 && < 1.3,- binary >= 0.8.3.0 && < 0.9,- lattices >= 1.7.1 && < 1.8,- sbv >= 7.0 && < 8,- partial-order >= 0.1.2.1 && < 0.1.3,- silently == 1.2.*,- temporary >= 1.2.0.4 && < 1.3,- lens >= 4.15.1 && < 5,- time,- verifiable-expressions >= 0.4,- camfort+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Camfort.Analysis.CommentAnnotatorSpec+ Camfort.Analysis.ImplicitNoneSpec+ Camfort.Analysis.ModFileSpec+ Camfort.Analysis.TestUtils+ Camfort.FunctionalitySpec+ Camfort.ReprintSpec+ Camfort.Specification.DerivedDataTypeSpec+ Camfort.Specification.Hoare.ParserSpec+ Camfort.Specification.ParserSpec+ Camfort.Specification.Stencils.CheckSpec+ Camfort.Specification.Stencils.ConsistencySpec+ Camfort.Specification.Stencils.DenotationalSemanticsSpec+ Camfort.Specification.Stencils.InferenceBackendSpec+ Camfort.Specification.Stencils.ModelSpec+ Camfort.Specification.Stencils.ParserSpec+ Camfort.Specification.StencilsSpec+ Camfort.Specification.Units.Analysis.ConsistentSpec+ Camfort.Specification.Units.Analysis.CriticalsSpec+ Camfort.Specification.Units.Analysis.InferSpec+ Camfort.Specification.Units.InferenceBackendSpec+ Camfort.Specification.Units.ParserSpec+ Camfort.Transformation.CommonSpec+ Camfort.Transformation.EquivalenceElimSpec+ Paths_camfort+ hs-source-dirs:+ tests+ build-tool-depends:+ hspec-discover:hspec-discover+ build-depends:+ QuickCheck >=2.8 && <3+ , array >=0.4 && <0.6+ , base >=4.6 && <5+ , binary >=0.8.3.0 && <0.9+ , bytestring >=0.10 && <0.11+ , camfort+ , containers >=0.5.0.0 && <0.7+ , directory >=1.2 && <2+ , fgl >=5.6 && <5.8+ , filepath >=1.4 && <1.5+ , fortran-src >=0.3 && <0.4+ , hmatrix >=0.15 && <0.20+ , hspec >=2.2 && <3+ , lattices >=1.7.1 && <1.8+ , lens >=4.15.1 && <5+ , mtl >=2.1 && <2.3+ , sbv >=7.0 && <8+ , silently ==1.2.*+ , temporary >=1.2.0.4 && <1.4+ , text >=0.11.2.3 && <1.3+ , time+ , uniplate >=1.6.10 && <1.7+ , verifiable-expressions >=0.4 default-language: Haskell2010
src/Camfort/Analysis.hs view
@@ -91,11 +91,12 @@ import Control.Monad.Morph import Control.Monad.Reader import qualified Control.Monad.RWS as Lazy-import Control.Monad.RWS.Strict+import Control.Monad.RWS.CPS import qualified Control.Monad.State as Lazy import Control.Monad.State.Strict import qualified Control.Monad.Writer as Lazy-import Control.Monad.Writer.Strict+import Control.Monad.Writer.CPS+import Control.Monad.Fail import Control.Lens @@ -131,6 +132,7 @@ , MonadState s , MonadWriter w' , MonadLogger e w+ , MonadFail ) -- | A pure analysis computation which cannot do any 'IO'.@@ -330,9 +332,26 @@ putDescribeReport :: (Describe e, Describe w, Describe r, MonadIO m)- => Text -> Maybe LogLevel -> AnalysisReport e w r -> m ()-putDescribeReport analysisName level = liftIO . Lazy.putStrLn . describeReport analysisName level+ => Text -> Maybe LogLevel -> Bool -> AnalysisReport e w r -> m ()+putDescribeReport analysisName level snippets report = do+ let output = describeReport analysisName level report+ output' <- if not snippets then return output else insertSnippets output+ liftIO . Lazy.putStrLn $ output' +-- Insert snippets of code where source spans are referenced.+insertSnippets :: MonadIO m => Lazy.Text -> m Lazy.Text+insertSnippets output = do+ let findLines n cnt str+ | n > 0, ls <- Lazy.lines str, ls'@(_:_) <- drop (n-1) ls = Just (take cnt ls')+ | otherwise = Nothing+ let doLine l+ | Just (ParsedOrigin fn (l1, _) (l2, _)) <- parseOrigin (Lazy.unpack l) = do+ f <- liftIO $ Lazy.readFile fn+ case findLines l1 (l2 - l1 + 1) f of+ Just fLines -> return $ [l, Lazy.empty] ++ fLines ++ [Lazy.empty]+ Nothing -> return [l]+ | otherwise = return [l]+ Lazy.unlines <$> concat <$> mapM doLine (Lazy.lines output) -------------------------------------------------------------------------------- -- Running Analyses
src/Camfort/Analysis/Logger.hs view
@@ -51,6 +51,8 @@ , (<>) -- * Messages , Origin(..)+ , ParsedOrigin(..)+ , parseOrigin , oFile , oSpan , LogLevel(..)@@ -84,11 +86,15 @@ import Control.Monad.Morph import Control.Monad.Reader import qualified Control.Monad.RWS as Lazy-import Control.Monad.RWS.Strict+import Control.Monad.RWS.CPS+import Control.Monad.Trans.RWS.CPS.Morph ()+import Control.Monad.Trans.RWS.CPS.Internal (RWST(..)) import qualified Control.Monad.State as Lazy import Control.Monad.State.Strict import qualified Control.Monad.Writer as Lazy-import Control.Monad.Writer.Strict+import Control.Monad.Writer.CPS+import Control.Monad.Trans.Writer.CPS.Morph ()+import Control.Monad.Fail import Data.Text (Text) import qualified Data.Text.IO as Text@@ -96,6 +102,7 @@ import Data.Text.Lazy.Builder (Builder) import qualified Data.Text.Lazy.Builder as Builder +import Text.Read (readMaybe) import qualified Language.Fortran.Util.Position as F --------------------------------------------------------------------------------@@ -156,7 +163,7 @@ { _oFile :: FilePath , _oSpan :: F.SrcSpan }- deriving (Show, Eq)+ deriving (Show, Eq, Ord) makeLenses ''Origin @@ -165,6 +172,30 @@ "at [" <> Builder.fromString (origin ^. oFile) <> ", " <> describeBuilder (origin ^. oSpan) <> "]" +data ParsedOrigin = ParsedOrigin FilePath (Int, Int) (Int, Int)+ deriving (Show, Eq, Ord)++-- | Extract information about filename and source span from a string.+parseOrigin :: String -> Maybe ParsedOrigin+parseOrigin str+ | not (null filename)+ , Just (pos1, rest) <- parsePos comma+ , Just (pos2, _) <- parsePos rest = Just (ParsedOrigin filename pos1 pos2)+ | otherwise = Nothing+ where+ lbrack = dropWhile (/= '[') str+ (filename, comma) = break (==',') (drop 1 lbrack)++parsePos :: String -> Maybe ((Int, Int), String)+parsePos str+ | Just l <- readMaybe line+ , Just c <- readMaybe col = Just ((l, c), rest)+ | otherwise = Nothing+ where+ lparen = dropWhile (/= '(') str+ (line, colon) = break (== ':') (drop 1 lparen)+ (col, rest) = span (/= ')') (drop 1 colon)+ -- | A logging level. At each logging level, only produce output at that level or lower. data LogLevel = LogError@@ -382,6 +413,7 @@ , Monad , MonadIO , MonadError e'+ , MonadFail ) instance MonadTrans (LoggerT e w) where@@ -394,16 +426,15 @@ instance (MonadReader r m) => MonadReader r (LoggerT e w m) where ask = lift ask- local f (LoggerT (RWST k)) = LoggerT $ RWST $ \e -> local f . k e+ local f (LoggerT m) | k <- runRWST m = LoggerT $ rwsT $ \e -> local f . k e instance (MonadWriter w' m) => MonadWriter w' (LoggerT e w m) where tell = lift . tell-- listen (LoggerT (RWST k)) = LoggerT $ RWST $ \e s -> do+ listen (LoggerT m) | k <- runRWST m = LoggerT $ rwsT $ \e s -> do ((x, w, s'), w') <- listen (k e s) return ((x, w'), w, s') - pass (LoggerT (RWST k)) = LoggerT $ RWST $ \e s ->+ pass (LoggerT m) | k <- runRWST m = LoggerT $ rwsT $ \e s -> pass $ (\((x, f), w, s') -> ((x, w, s'), f)) <$> k e s instance (Monad m, Describe e, Describe w) =>@@ -420,10 +451,9 @@ -- the resulting 'LoggerT' cannot output as it goes. It still collects logs to -- be inspected when it finishes. instance MFunctor (LoggerT e w) where- hoist f (LoggerT (RWST k)) = LoggerT $ RWST $ \e s ->+ hoist f (LoggerT (RWST k)) = LoggerT ( RWST ( \e s w -> let e' = hoistEnv (const (return ())) e- in f (k e' s)-+ in f (k e' s w) ) ) -- | A function to output logs in a particular monad @m@. data LogOutput m = LogOutput@@ -490,7 +520,7 @@ -- | Change the error and warning types in a logger computation. To change the -- underlying monad use 'hoist'. mapLoggerT- :: (Functor m)+ :: (Monad m) => (e -> e') -> (w -> w') -> LoggerT e w m a -> LoggerT e' w' m a mapLoggerT mapErr mapWarn (LoggerT x) = LoggerT (mapRWST mapInner x)@@ -551,4 +581,3 @@ logLevel <- LoggerT $ use lsLogLevel lift $ logFunc repeatedOrigin logLevel msgLevel originText msgText-
src/Camfort/Analysis/ModFile.hs view
@@ -26,6 +26,7 @@ import Control.Monad (forM) import Control.Monad.IO.Class import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as LB import Data.Char (toLower) import Data.Data (Data) import Data.List ((\\))@@ -44,6 +45,7 @@ import qualified Language.Fortran.AST as F import qualified Language.Fortran.Parser.Any as FP import qualified Language.Fortran.Util.ModFile as FM+import Language.Fortran.ParserMonad (FortranVersion(..)) import Camfort.Analysis.Annotations (A, unitAnnotation) import Camfort.Helpers@@ -67,9 +69,9 @@ -- | Generate a mode file based on the given mod file compiler genModFiles :: (MonadIO m)- => FM.ModFiles -> MFCompiler r m -> r -> FilePath -> [Filename] -> m FM.ModFiles-genModFiles mfs mfc env fp excludes = do- fortranFiles <- liftIO $ fmap fst <$> readParseSrcDir mfs fp excludes+ => Maybe FortranVersion -> FM.ModFiles -> MFCompiler r m -> r -> FilePath -> [Filename] -> m FM.ModFiles+genModFiles mv mfs mfc env fp excludes = do+ fortranFiles <- liftIO $ fmap fst <$> readParseSrcDir mv mfs fp excludes traverse (genCModFile mfc env mfs) fortranFiles -- | Retrieve the ModFiles under a given path.@@ -78,16 +80,18 @@ -- Figure out the camfort mod files and parse them. modFileNames <- (filter isModFile . map (dir </>)) <$> listDirectory dir mods <- forM modFileNames $ \modFileName -> do- modData <- B.readFile modFileName+ modData <- LB.readFile modFileName let eResult = FM.decodeModFile modData case eResult of Left msg -> do putStrLn $ modFileName ++ ": Error: " ++ show msg pure Nothing Right modFile -> do- putStrLn $ modFileName ++ ": successfully parsed precompiled file." pure . pure $ modFile- pure . catMaybes $ mods+ let mods' = catMaybes mods+ putStrLn $ "Successfully parsed " ++ show (length mods) ++ " precompiled file(s)."+ pure mods'+ where isModFile :: String -> Bool isModFile = (== FM.modFileSuffix) . takeExtension@@ -105,11 +109,12 @@ concat <$> mapM (listDirectoryRec fullPath) conts else pure [fullPath] -readParseSrcDir :: FM.ModFiles+readParseSrcDir :: Maybe FortranVersion+ -> FM.ModFiles -> FileOrDir -> [Filename] -> IO [(F.ProgramFile A, SourceText)]-readParseSrcDir mods inp excludes = do+readParseSrcDir mv mods inp excludes = do isdir <- isDirectory inp files <- if isdir@@ -120,15 +125,17 @@ let excludes' = excludes ++ map (\x -> inp </> x) excludes pure $ files \\ excludes' else pure [inp]- mapMaybeM (readParseSrcFile mods) files+ mapMaybeM (readParseSrcFile mv mods) files where mapMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b] mapMaybeM f = fmap catMaybes . mapM f -readParseSrcFile :: FM.ModFiles -> Filename -> IO (Maybe (F.ProgramFile A, SourceText))-readParseSrcFile mods f = do+readParseSrcFile :: Maybe FortranVersion -> FM.ModFiles -> Filename -> IO (Maybe (F.ProgramFile A, SourceText))+readParseSrcFile mv mods f = do inp <- flexReadFile f- let result = FP.fortranParserWithModFiles mods inp f+ let result = case mv of+ Nothing -> FP.fortranParserWithModFiles mods inp f+ Just v -> FP.fortranParserWithModFilesAndVersion v mods inp f case result of Right ast -> pure $ Just (fmap (const unitAnnotation) ast, inp) Left err -> print err >> pure Nothing@@ -173,8 +180,9 @@ => FM.ModFiles -> F.ProgramFile a -> (F.ProgramFile (FA.Analysis a), FAR.ModuleMap, FAT.TypeEnv) withCombinedEnvironment mfs pf = let (pfRenamed, mmap) = withCombinedModuleMap mfs (FA.initAnalysis pf)- tenv = FM.combinedTypeEnv mfs- in (fst . FAT.analyseTypesWithEnv tenv $ pfRenamed, mmap, tenv)+ moduleTEnv = FM.combinedTypeEnv mfs+ (pf', tenv) = FAT.analyseTypesWithEnv moduleTEnv $ pfRenamed+ in (pf', mmap, tenv) -- | From a module map, look up the unique name associated with a given source -- name in the given program unit. Also returns the name type, which tells you
src/Camfort/Analysis/Simple.hs view
@@ -16,28 +16,52 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-} {- Simple syntactic analysis on Fortran programs -} module Camfort.Analysis.Simple- (countVariableDeclarations, checkImplicitNone, ImplicitNoneReport(..)) where+ ( countVariableDeclarations+ , checkImplicitNone+ , ImplicitNoneReport(..)+ , checkAllocateStatements+ , checkFloatingPointUse+ , checkModuleUse+ , checkArrayUse )+where+ import Prelude hiding (unlines) import Control.Monad+import Control.Arrow (first) import Data.Data-import Data.Text (Text, unlines)+import Data.Function (on)+import Data.Maybe (catMaybes, fromMaybe, maybeToList, listToMaybe, mapMaybe)+import qualified Data.Set as S+import qualified Data.IntSet as IS+import qualified Data.Map.Strict as M+import qualified Data.IntMap.Strict as IM import qualified Data.Semigroup as SG import Data.Monoid ((<>)) import Data.Generics.Uniplate.Operations-import Data.Text.Lazy.Builder (Builder) import qualified Data.Text.Lazy.Builder as Builder+import Data.Text (Text, unlines, intercalate, pack)+import Data.List ((\\), sort, nub, nubBy, tails) +import Data.Graph.Inductive import qualified Language.Fortran.AST as F import qualified Language.Fortran.Util.Position as F+import qualified Language.Fortran.Analysis as F+import qualified Language.Fortran.Analysis.Types as F+import qualified Language.Fortran.Analysis.DataFlow as F+import qualified Language.Fortran.Analysis.BBlocks as F+import Language.Fortran.Util.ModFile -import Camfort.Analysis ( ExitCodeOfReport(..), atSpanned, Origin, failAnalysis'- , logError', logError, describe, describeBuilder+import Camfort.Analysis (describeShow, analysisModFiles, ExitCodeOfReport(..), atSpanned, atSpannedInFile, Origin+ , logError, describe, describeBuilder , PureAnalysis, Describe )+import Camfort.Analysis.ModFile (withCombinedEnvironment) {-| Counts the number of declarations (of variables) in a whole program -} @@ -118,3 +142,338 @@ instance ExitCodeOfReport ImplicitNoneReport where exitCodeOf (ImplicitNoneReport []) = 0 exitCodeOf (ImplicitNoneReport _) = 1++--------------------------------------------------++data CheckAllocReport+ = CheckAllocReport { unbalancedAllocs :: [(F.Name, PULoc)]+ , outOfOrder :: [(F.Name, PULoc)]}++instance SG.Semigroup CheckAllocReport where+ CheckAllocReport a1 b1 <> CheckAllocReport a2 b2 = CheckAllocReport (a1 ++ a2) (b1 ++ b2)++instance Monoid CheckAllocReport where+ mempty = CheckAllocReport [] []+ mappend = (SG.<>)++checkAllocateStatements :: forall a. Data a => F.ProgramFile a -> PureAnalysis String () CheckAllocReport+checkAllocateStatements pf = do+ let F.ProgramFile F.MetaInfo { F.miFilename = file } _ = pf++ let checkPU :: F.ProgramUnit a -> CheckAllocReport+ checkPU pu = CheckAllocReport {..}+ where+ allocs =+ [ (v, (F.getName pu, atSpannedInFile file e))+ | F.StAllocate _ _ _ (F.AList _ _ es) _ <- universeBi (F.programUnitBody pu) :: [F.Statement a]+ , e <- es+ , v <- take 1 [ v | F.ExpValue _ _ (F.ValVariable v) <- universeBi e :: [F.Expression a] ]+ ]+ deallocs =+ [ (v, (F.getName pu, atSpannedInFile file e))+ | F.StDeallocate _ _ (F.AList _ _ es) _ <- universeBi (F.programUnitBody pu) :: [F.Statement a]+ , e <- es+ , v <- take 1 [ v | F.ExpValue _ _ (F.ValVariable v) <- universeBi e :: [F.Expression a] ]+ ]+ isDealloced v = not . null $ filter ((==v) . fst) deallocs+ unbalancedAllocs = filter (not . isDealloced . fst) allocs+ outOfOrder = concat $ zipWith (\ v1 v2 -> if fst v1 == fst v2 then [] else [v1, v2]) (nubBy ((==) `on` fst) allocs) (nubBy ((==) `on` fst) $ reverse deallocs)++ let reports = map checkPU (universeBi pf)++ return $ mconcat reports+++instance Describe CheckAllocReport where+ describeBuilder (CheckAllocReport {..})+ | null (unbalancedAllocs ++ outOfOrder) = "no cases detected"+ | otherwise = Builder.fromText . unlines $+ [ describe orig <> " unbalanced allocation or deallocation for " <> pack name+ | (name, (_, orig)) <- unbalancedAllocs ] +++ [ describe orig <> " out-of-order (de)allocation " <> pack name+ | (name, (_, orig)) <- outOfOrder ]++instance ExitCodeOfReport CheckAllocReport where+ exitCodeOf (CheckAllocReport {..})+ | null (unbalancedAllocs ++ outOfOrder) = 0+ | otherwise = 1++--------------------------------------------------++data CheckFPReport+ = CheckFPReport { badEquality :: [PULoc] }++instance SG.Semigroup CheckFPReport where+ CheckFPReport a1 <> CheckFPReport a2 = CheckFPReport (a1 ++ a2)++instance Monoid CheckFPReport where+ mempty = CheckFPReport []+ mappend = (SG.<>)++checkFloatingPointUse :: forall a. Data a => F.ProgramFile a -> PureAnalysis String () CheckFPReport+checkFloatingPointUse pf = do+ let F.ProgramFile F.MetaInfo { F.miFilename = file } _ = pf+ mfs <- analysisModFiles+ let (pf', _, _) = withCombinedEnvironment mfs pf+ let pvm = combinedParamVarMap mfs+ let pf'' = F.analyseConstExps . F.analyseParameterVars pvm . F.analyseBBlocks $ pf'++ let checkPU :: F.ProgramUnit (F.Analysis a) -> CheckFPReport+ checkPU pu = CheckFPReport {..}+ where+ candidates :: [F.Expression (F.Analysis a)]+ candidates = [ e | e@(F.ExpBinary _ _ op x y) <- universeBi (F.programUnitBody pu)+ , op `elem` [F.EQ, F.NE]+ , Just (F.IDType (Just bt) _) <- [F.idType (F.getAnnotation x), F.idType (F.getAnnotation y)]+ , bt `elem` floatingPointTypes ]+ badEquality = nub [ (F.getName pu, atSpannedInFile file e) | e <- candidates ]++ let reports = map checkPU (universeBi pf'')++ return $ mconcat reports++floatingPointTypes :: [F.BaseType]+floatingPointTypes = [F.TypeReal, F.TypeDoubleComplex, F.TypeComplex, F.TypeDoublePrecision]++instance Describe CheckFPReport where+ describeBuilder (CheckFPReport {..})+ | null (badEquality) = "no cases detected"+ | otherwise = Builder.fromText . unlines $+ [ describe orig <> " equality operation used on floating-point numbers."+ | (_, orig) <- badEquality ]++instance ExitCodeOfReport CheckFPReport where+ exitCodeOf (CheckFPReport {..})+ | null (badEquality) = 0+ | otherwise = 1++--------------------------------------------------++data CheckUseReport+ = CheckUseReport { missingOnly :: [PULoc]+ , duppedOnly :: [(String, PULoc)]+ , unusedNames :: [(String, PULoc)]+ }++instance SG.Semigroup CheckUseReport where+ CheckUseReport a1 b1 c1 <> CheckUseReport a2 b2 c2 = CheckUseReport (a1 ++ a2) (b1 ++ b2) (c1 ++ c2)++instance Monoid CheckUseReport where+ mempty = CheckUseReport [] [] []+ mappend = (SG.<>)++checkModuleUse :: forall a. Data a => F.ProgramFile a -> PureAnalysis String () CheckUseReport+checkModuleUse pf = do+ let F.ProgramFile F.MetaInfo { F.miFilename = file } _ = pf+ mfs <- analysisModFiles+ let (pf', _, _) = withCombinedEnvironment mfs pf++ let checkPU :: F.ProgramUnit (F.Analysis a) -> CheckUseReport+ checkPU pu = CheckUseReport {..}+ where+ statements :: [F.Statement (F.Analysis a)]+ statements = universeBi (F.programUnitBody pu)+ expressions :: [F.Expression (F.Analysis a)]+ expressions = universeBi pu+ missingOnly = nub [ (F.getName pu, atSpannedInFile file s)+ | s <- [ s | s@(F.StUse _ _ _ _ F.Permissive _) <- statements ] ]+ duppedOnly = [ (n, (F.getName pu, atSpannedInFile file $ F.getSpan (ss, ss')))+ | F.StUse _ ss (F.ExpValue _ _ (F.ValVariable n)) _ _ _:rest <- tails statements+ , F.StUse _ ss' (F.ExpValue _ _ (F.ValVariable n')) _ _ _ <- rest+ , n == n' ]+ extractUseName (F.UseID _ ss (F.ExpValue _ _ (F.ValVariable n))) = (n, ss)+ extractUseName (F.UseRename _ ss (F.ExpValue _ _ (F.ValVariable n)) _) = (n, ss)+ unusedNames = [ (n, (F.getName pu, atSpannedInFile file ss))+ | F.StUse _ _ _ _ _ (Just (F.AList _ _ uses)) <- statements+ , (n, ss) <- map extractUseName uses+ , length [ () | F.ExpValue _ _ (F.ValVariable n') <- expressions, n == n' ] < 2 ]++ let reports = map checkPU (universeBi pf')++ return $ mconcat reports++instance Describe CheckUseReport where+ describeBuilder (CheckUseReport {..})+ | null missingOnly && null duppedOnly && null unusedNames = "no cases detected"+ | otherwise = Builder.fromText . unlines $+ [ describe orig <> " USE statement missing ONLY attribute."+ | (_, orig) <- missingOnly ] +++ [ describe orig <> " multiple USE statements for same module '" <> describe name <> "'"+ | (name, (_, orig)) <- duppedOnly ] +++ [ describe orig <> " local name '" <> describe name <> "' imported but unused in program unit."+ | (name, (_, orig)) <- unusedNames ]++instance ExitCodeOfReport CheckUseReport where+ exitCodeOf (CheckUseReport {..})+ | null missingOnly && null duppedOnly && null unusedNames = 0+ | otherwise = 1++--------------------------------------------------++data CheckArrayReport+ = CheckArrayReport { nestedIdx, missingIdx :: [([String], PULoc)] }++instance SG.Semigroup CheckArrayReport where+ CheckArrayReport a1 b1 <> CheckArrayReport a2 b2 = CheckArrayReport (a1 ++ a2) (b1 ++ b2)++instance Monoid CheckArrayReport where+ mempty = CheckArrayReport [] []+ mappend = (SG.<>)++-- Look at array subscripting, especially with regard to order of+-- indices and perhaps whether there is a missing data dependency on+-- an index variable (e.g. due to copy/paste error).+checkArrayUse :: forall a. Data a => F.ProgramFile a -> PureAnalysis String () CheckArrayReport+checkArrayUse pf = do+ let F.ProgramFile F.MetaInfo { F.miFilename = file } _ = pf+ mfs <- analysisModFiles+ let (pf', _, _) = withCombinedEnvironment mfs pf+ let pvm = combinedParamVarMap mfs+ let pf'' = F.analyseConstExps . F.analyseParameterVars pvm . F.analyseBBlocks $ pf'+ let bm = F.genBlockMap pf''+ let dm = F.genDefMap bm+ let cm = F.genCallMap pf''++ let checkPU :: F.ProgramUnit (F.Analysis a) -> CheckArrayReport+ checkPU pu | F.Analysis { F.bBlocks = Just _ } <- F.getAnnotation pu = CheckArrayReport {..}+ where+ F.Analysis { F.bBlocks = Just gr } = F.getAnnotation pu+ bedges = F.genBackEdgeMap (F.dominators gr) $ F.bbgrGr gr+ ivmap = F.genInductionVarMapByASTBlock bedges gr+ divmap = F.genDerivedInductionMap bedges gr+ rdmap = F.reachingDefinitions dm gr+ flFrom = tc . grev $ F.genFlowsToGraph bm dm gr rdmap++ blocks :: [F.Block (F.Analysis a)]+ blocks = F.programUnitBody pu++ nestedIdx = [ (ivars, (F.getName pu, atSpannedInFile file ss)) | (ivars, ss) <- getNestedIdx [] blocks ]++ -- find subscripts where the order of indices doesn't match+ -- the order of introduction of induction variables by+ -- nested do-loops.+ getNestedIdx :: [F.Name] -> [F.Block (F.Analysis a)] -> [([String], F.SrcSpan)]+ getNestedIdx _ [] = []+ getNestedIdx vs (b@(F.BlDo _ _ _ _ _ _ body _):bs)+ | v:_ <- F.blockVarDefs b = getNestedIdx (v:vs) body ++ getNestedIdx vs bs+ | otherwise = getNestedIdx vs bs+ getNestedIdx vs (b:bs) = bad ++ getNestedIdx vs bs+ where+ vset = S.fromList vs+ vmap = zip vs [0..]+ subs = [ (ivars, ss)+ | F.ExpSubscript _ ss _ (F.AList _ _ is) <- universeBi b :: [F.Expression (F.Analysis a)]+ , let ivars = [ (F.varName e, F.srcName e)+ | i <- is+ , e@(F.ExpValue _ _ F.ValVariable{}) <- universeBi i :: [F.Expression (F.Analysis a)]+ , F.varName e `S.member` vset ] ]+ -- 'bad' subscripts are where the ordering doesn't match the nesting.+ bad = [ (map snd ivars, ss)+ | (ivars, ss) <- subs, let nums = mapMaybe (flip lookup vmap . fst) ivars, nums /= sort nums ]++ missingIdx = [ (missing, (F.getName pu, atSpannedInFile file ss)) | b <- blocks+ , (missing, ss) <- getMissingUse [] b ]++ -- Seek any possible missing uses of an induction variable+ -- within subscript expressions, looking through nested+ -- blocks. We can exclude variables for which If/Case+ -- control-flow depends on it instead of needing it to be+ -- directly used by a subscript expression.+ getMissingUse :: forall a. Data a => [String] -> F.Block (F.Analysis a) -> [([String], F.SrcSpan)]+ getMissingUse excls (F.BlDo _ _ _ _ _ _ bs _) = concatMap (getMissingUse excls) bs+ getMissingUse excls (F.BlDoWhile _ _ _ _ _ _ bs _) = concatMap (getMissingUse excls) bs+ getMissingUse excls (F.BlForall _ _ _ _ _ bs _) = concatMap (getMissingUse excls) bs+ getMissingUse excls b@(F.BlIf F.Analysis{F.insLabel = Just i} _ _ _ mes bss _)+ -- check If statement conditions+ | any (eligible i (length excls)) es = bads ++ rest+ | otherwise = rest+ where+ es = catMaybes mes+ -- find any induction variables that are referenced by If-Elseif expressions+ excl' = concatMap getExcludes (universeBi es :: [F.Expression (F.Analysis a)])+ rest = concatMap (getMissingUse (excls ++ excl')) $ concat bss+ bads = getMissingUse' excls b+ getMissingUse excls b@(F.BlCase F.Analysis{F.insLabel = Just i} _ _ _ e _ bss _)+ -- check Case statement scrutinee+ | eligible i (length excls) e = bads ++ rest+ | otherwise = rest+ where+ rest = concatMap (getMissingUse (excls ++ getExcludes e)) $ concat bss+ bads = map (fmap (const (F.getSpan e))) $ getMissingUse' excls b+ getMissingUse excls b@(F.BlStatement F.Analysis{F.insLabel = Just i} _ _ st)+ | eligible i (length excls) st = getMissingUse' excls b+ | otherwise = []+ getMissingUse _ F.BlInterface{} = []+ getMissingUse _ F.BlComment{} = []++ getMissingUse' :: forall a. Data a => [F.Name] -> F.Block (F.Analysis a) -> [([F.Name], F.SrcSpan)]+ getMissingUse' excls b+ | Just i <- F.insLabel (F.getAnnotation b)+ -- obtain the live induction variables at this program point+ , Just ivarSet <- IM.lookup i ivmap+ -- find the definitions that flowed into this program point+ , flFroms <- suc flFrom i+ -- get their AST Blocks+ , Just flFromBlocks <- sequence $ map (flip IM.lookup bm) flFroms+ -- find out what variables they define+ , flFromBlockDefSet <- S.fromList $ concatMap F.blockVarDefs flFromBlocks+ -- subtract the excludes and the defined variables from+ -- the live induction variables in order to find out the+ -- 'missing' or unaccounted-for induction vars.+ , missingIVars <- ivarSet `S.difference` S.fromList excls `S.difference` flFromBlockDefSet+ -- Try to look up source-names for the missing ivars in+ -- each of the flow-from blocks.+ , missingIVars' <- S.map (\ v -> "unk" `fromMaybe` findSrcNameInDefMap v) missingIVars+ , not (S.null missingIVars) = [(S.toList missingIVars', F.getSpan b)]+ getMissingUse' _ _ = []++ -- eligible bits of AST are those that contain subscripting+ -- expressions with a length equivalent to the number of+ -- currently live induction variables.+ eligible :: forall a b. (Data a, Data (b (F.Analysis a))) => Int -> Int -> b (F.Analysis a) -> Bool+ eligible i numExcls x+ | Just ivars <- IM.lookup i ivmap =+ not $ null [ () | F.ExpSubscript _ _ _ (F.AList _ _ idxs) <- universeBi x :: [F.Expression (F.Analysis a)]+ , length idxs == S.size ivars - numExcls ]+ | otherwise = False++ -- check the derived induction maps to find out if a given+ -- expression depends on any induction variable and+ -- therefore can be used to exclude that induction variable+ -- from the 'missing' list.+ getExcludes e+ | Just ei <- F.insLabel (F.getAnnotation e)+ , Just (F.IELinear n _ _) <- IM.lookup ei divmap = [n]+ getExcludes _ = []++ -- look through the DefMap and BlockMap for instances of+ -- variable v in order to retrieve its 'source name'.+ findSrcNameInDefMap v = do+ defSet <- M.lookup v dm+ bs <- mapM (flip IM.lookup bm) $ IS.toList defSet+ msum (map (findSrcName v) bs)++ checkPU _ = mempty+ let reports = map checkPU (universeBi pf'')++ return $ mconcat reports++-- Look through a piece of AST for the source name of a given var name.+findSrcName :: forall a. Data a => F.Name -> F.Block (F.Analysis a) -> Maybe F.Name+findSrcName v b = listToMaybe+ [ F.srcName e | e@(F.ExpValue _ _ F.ValVariable{}) <- universeBi b :: [F.Expression (F.Analysis a)]+ , F.varName e == v ]++instance Describe CheckArrayReport where+ describeBuilder (CheckArrayReport {..})+ | null nestedIdx && null missingIdx = "no cases detected"+ | otherwise = Builder.fromText . unlines $+ [ describe orig <> " possibly less efficient order of subscript indices: " <> intercalate ", " (map describe ivars)+ | (ivars, (_, orig)) <- nestedIdx ] +++ [ describe orig <> " possibly missing use of variable(s) in array subscript: " <> intercalate ", " (map describe ivars)+ | (ivars, (_, orig)) <- missingIdx ]++instance ExitCodeOfReport CheckArrayReport where+ exitCodeOf (CheckArrayReport {..})+ | null nestedIdx = 0+ | otherwise = 1
src/Camfort/Functionality.hs view
@@ -33,6 +33,10 @@ , ast , countVarDecls , implicitNone+ , allocCheck+ , fpCheck+ , useCheck+ , arrayCheck -- ** Stencil Analysis , stencilsCheck , stencilsInfer@@ -40,6 +44,7 @@ -- ** Unit Analysis , unitsCriticals , unitsCheck+ , unitsDump , unitsInfer , unitsCompile , unitsSynth@@ -49,25 +54,39 @@ , common , dead , equivalences+ , ddtRefactor+ , ddtInfer+ , ddtCheck+ , ddtSynth+ , ddtCompile -- ** Project Management , camfortInitialize ) where import Control.Arrow (first, second) import Data.List (intersperse)+import Data.Maybe (fromMaybe) import Data.Void (Void)-import qualified Data.ByteString as B+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as LB import System.Directory (doesDirectoryExist, createDirectoryIfMissing, getCurrentDirectory) import System.FilePath (takeDirectory, (</>), replaceExtension) +import Text.PrettyPrint.GenericPretty (pp, pretty, Out)+ import Control.Lens import Control.Monad.Reader.Class-import Control.Monad (forM_)+import Control.Monad+import Control.Monad.IO.Class import qualified Language.Fortran.AST as F+import qualified Language.Fortran.Analysis.Renaming as FA+import qualified Language.Fortran.Analysis as FA import qualified Language.Fortran.Util.ModFile as FM+import Language.Fortran.ParserMonad (FortranVersion(..))+import Language.Fortran.PrettyPrint import Camfort.Analysis import Camfort.Analysis.Annotations (Annotation)@@ -79,15 +98,18 @@ simpleCompiler) import Camfort.Analysis.Simple import Camfort.Input+import qualified Camfort.Specification.DerivedDataType as DDT import qualified Camfort.Specification.Stencils as Stencils import Camfort.Specification.Stencils.Analysis (compileStencils) import qualified Camfort.Specification.Units as LU import Camfort.Specification.Units.Analysis (compileUnits)+import Camfort.Specification.Units.Annotation (unitInfo) import Camfort.Specification.Units.Analysis.Consistent (checkUnits) import Camfort.Specification.Units.Analysis.Criticals (inferCriticalVariables)-import Camfort.Specification.Units.Analysis.Infer (inferUnits)+import Camfort.Specification.Units.Analysis.Infer (InferenceResult(..), InferenceReport(..), inferUnits) import Camfort.Specification.Units.Monad (runUnitAnalysis, unitOpts0)+import Camfort.Specification.Units.ModFile (dumpModFileCompiledUnits) import Camfort.Specification.Units.MonadTypes (LiteralsOpt, UnitAnalysis, UnitEnv (..),@@ -112,10 +134,12 @@ data CamfortEnv = CamfortEnv- { ceInputSources :: FileOrDir- , ceIncludeDir :: Maybe FileOrDir- , ceExcludeFiles :: [Filename]- , ceLogLevel :: LogLevel+ { ceInputSources :: FileOrDir+ , ceIncludeDir :: Maybe FileOrDir+ , ceExcludeFiles :: [Filename]+ , ceLogLevel :: LogLevel+ , ceSourceSnippets :: Bool+ , ceFortranVersion :: Maybe FortranVersion } --------------------------------------------------------------------------------@@ -166,8 +190,8 @@ -- ...instead for now, just get the mod files modFiles <- getModFiles incDir- pfsTexts <- readParseSrcDir modFiles (ceInputSources env) (ceExcludeFiles env)- runner program (logOutputStd True) (ceLogLevel env) modFiles pfsTexts+ pfsTexts <- readParseSrcDir (ceFortranVersion env) modFiles (ceInputSources env) (ceExcludeFiles env)+ runner program (logOutputStd True) (ceLogLevel env) (ceSourceSnippets env) modFiles pfsTexts @@ -178,7 +202,7 @@ ast env = do incDir' <- maybe getCurrentDirectory pure (ceIncludeDir env) modFiles <- getModFiles incDir'- xs <- readParseSrcDir modFiles (ceInputSources env) (ceExcludeFiles env)+ xs <- readParseSrcDir (ceFortranVersion env) modFiles (ceInputSources env) (ceExcludeFiles env) print . fmap fst $ xs @@ -225,6 +249,88 @@ (describePerFileAnalysis "check 'implicit none'") simpleCompiler () +allocCheck :: CamfortEnv -> IO Int+allocCheck =+ runFunctionality+ "Checking allocate / deallocate usage"+ (generalizePureAnalysis . checkAllocateStatements)+ (describePerFileAnalysis "check allocate / deallocate")+ simpleCompiler ()++fpCheck :: CamfortEnv -> IO Int+fpCheck =+ runFunctionality+ "Checking usage of floating point"+ (generalizePureAnalysis . checkFloatingPointUse)+ (describePerFileAnalysis "check floating point")+ simpleCompiler ()++useCheck :: CamfortEnv -> IO Int+useCheck =+ runFunctionality+ "Checking usage of USE statements"+ (generalizePureAnalysis . checkModuleUse)+ (describePerFileAnalysis "check module USE")+ simpleCompiler ()++arrayCheck :: CamfortEnv -> IO Int+arrayCheck =+ runFunctionality+ "Checking array usage"+ (generalizePureAnalysis . checkArrayUse)+ (describePerFileAnalysis "check array usage")+ simpleCompiler ()++ddtRefactor :: FileOrDir -> CamfortEnv -> IO Int+ddtRefactor =+ runWithOutput+ "Refactoring derived datatypes"+ (generalizePureAnalysis . DDT.refactor)+ (doRefactor "infer derived data types")+ simpleCompiler ()++ddtSynth :: AnnotationType -> FileOrDir -> CamfortEnv -> IO Int+ddtSynth annType =+ runWithOutput+ "Synthesising derived datatypes"+ (generalizePureAnalysis . DDT.synth (markerChar annType))+ (doRefactor "synth derived data types")+ simpleCompiler ()++ddtCheck :: CamfortEnv -> IO Int+ddtCheck =+ runFunctionality+ "Checking derived datatype annotations"+ (generalizePureAnalysis . DDT.check)+ (describePerFileAnalysis "check derived datatypes")+ simpleCompiler ()++ddtInfer :: CamfortEnv -> IO Int+ddtInfer =+ runFunctionality+ "Inferring derived datatypes"+ (generalizePureAnalysis . DDT.infer)+ (describePerFileAnalysis "infer derived datatypes")+ simpleCompiler ()++ddtCompile :: CamfortEnv -> IO Int+ddtCompile env = do+ let description = "Compiling derived datatypes for"+ putStrLn $ description ++ " '" ++ ceInputSources env ++ "'"+ incDir' <- maybe getCurrentDirectory pure (ceIncludeDir env)+ isDir <- doesDirectoryExist incDir'+ let incDir | isDir = incDir'+ | otherwise = takeDirectory incDir'+ modFiles <- getModFiles incDir++ -- Run the gen mod file routine directly on the input source+ modFiles <- genModFiles (ceFortranVersion env) modFiles DDT.compile () (ceInputSources env) (ceExcludeFiles env)+ -- Write the mod files out+ forM_ modFiles $ \ modFile -> do+ let mfname = replaceExtension (FM.moduleFilename modFile) FM.modFileSuffix+ LB.writeFile mfname (FM.encodeModFile modFile)+ return 0+ {- Units feature -} runUnitsFunctionality@@ -284,6 +390,20 @@ return (rs', ps) +unitsDump :: LiteralsOpt -> CamfortEnv -> IO Int+unitsDump _ env = do+ let modFileName = ceInputSources env+ modData <- LB.readFile modFileName+ let eResult = FM.decodeModFile modData+ case eResult of+ Left msg -> do+ putStrLn $ modFileName ++ ": Error: " ++ show msg+ pure 1+ Right modFile -> do+ putStrLn $ modFileName ++ ": successfully parsed precompiled file."+ putStrLn . fromMaybe "unable to find units info" $ dumpModFileCompiledUnits modFile+ pure 0+ unitsCheck :: LiteralsOpt -> CamfortEnv -> IO Int unitsCheck = runUnitsFunctionality@@ -292,13 +412,30 @@ (describePerFileAnalysis "unit checking") -unitsInfer :: LiteralsOpt -> CamfortEnv -> IO Int-unitsInfer =+unitsInfer :: Bool -> LiteralsOpt -> CamfortEnv -> IO Int+unitsInfer showAST = runUnitsFunctionality "Inferring units for" (singlePfUnits inferUnits)- (describePerFileAnalysis "unit inference")+ (if showAST+ then describePerFileAnalysisShowASTUnitInfo+ else describePerFileAnalysis "unit inference") +-- | Given an analysis program for a single file, run it over every input file+-- and collect the reports, then print those reports to standard output.+describePerFileAnalysisShowASTUnitInfo+ :: (MonadIO m, Describe w, Describe e)+ => AnalysisRunner e w m ProgramFile InferenceResult Int+describePerFileAnalysisShowASTUnitInfo program logOutput logLevel snippets modFiles pfsTexts = do+ reports <- runPerFileAnalysis program logOutput logLevel snippets modFiles pfsTexts+ flip mapM_ reports $ \ r -> do+ case r of+ AnalysisReport _ _ (ARSuccess (Inferred (InferenceReport pfUA eVars))) ->+ liftIO . pp . fmap (unitInfo . FA.prevAnnotation) . FA.rename $ pfUA+ _ -> pure ()+ putDescribeReport "unit inference" (Just logLevel) snippets r+ return $ exitCodeOfSet reports+ {- TODO: remove if not needed unitsCompile :: FileOrDir -> LiteralsOpt -> CamfortEnv -> IO () unitsCompile outSrc opts env =@@ -325,11 +462,11 @@ modFiles <- getModFiles incDir -- Run the gen mod file routine directly on the input source- modFiles <- genModFiles modFiles compileUnits uo (ceInputSources env) (ceExcludeFiles env)+ modFiles <- genModFiles (ceFortranVersion env) modFiles compileUnits uo (ceInputSources env) (ceExcludeFiles env) -- Write the mod files out forM_ modFiles $ \modFile -> do let mfname = replaceExtension (FM.moduleFilename modFile) FM.modFileSuffix- B.writeFile mfname (FM.encodeModFile modFile)+ LB.writeFile mfname (FM.encodeModFile modFile) return 0 unitsSynth :: AnnotationType -> FileOrDir -> LiteralsOpt -> CamfortEnv -> IO Int@@ -400,4 +537,3 @@ camfortInitialize :: FilePath -> IO () camfortInitialize projectDir = createDirectoryIfMissing False (projectDir </> ".camfort")-
src/Camfort/Helpers.hs view
@@ -43,7 +43,7 @@ import qualified Data.ByteString.Char8 as B import System.Directory import qualified Data.Map.Lazy as Map hiding (map, (\\))-import Control.Monad.Writer.Strict+import Control.Monad.Writer.CPS -- collect: from an association list to a map with list-based bins for matching keys collect :: (Eq a, Ord k) => [(k, a)] -> Map.Map k [a]
src/Camfort/Helpers/Syntax.hs view
@@ -51,6 +51,7 @@ import Data.Generics.Uniplate.Data import qualified Language.Fortran.AST as F+import qualified Language.Fortran.Analysis as FA import qualified Language.Fortran.Util.Position as FU -- * Comparison and ordering@@ -88,11 +89,14 @@ x'' = transformBi setSpanConst x' setSpanConst :: FU.SrcSpan -> FU.SrcSpan setSpanConst (FU.SrcSpan _ _) = FU.SrcSpan pos0 pos0- where pos0 = FU.Position 0 0 0+ where pos0 = FU.Position 0 0 0 "" Nothing instance Eq (AnnotationFree F.BaseType) where (AnnotationFree x) == (AnnotationFree y) = x == y +instance Eq (AnnotationFree FA.ConstructType) where+ (AnnotationFree x) == (AnnotationFree y) = x == y+ -- * Accessor functions for extracting various pieces of information -- out of syntax trees {-| Extracts a string of the (root) variable name from an expression,@@ -114,18 +118,18 @@ -- SrcSpan helpers dropLine :: FU.SrcSpan -> FU.SrcSpan-dropLine (FU.SrcSpan s1 (FU.Position o _ l)) =- FU.SrcSpan s1 (FU.Position o 1 (l+1))+dropLine (FU.SrcSpan s1 (FU.Position o _ l f Nothing)) =+ FU.SrcSpan s1 (FU.Position o 1 (l+1) f Nothing) deleteLine :: FU.SrcSpan -> FU.SrcSpan-deleteLine (FU.SrcSpan (FU.Position ol cl ll) (FU.Position ou _ lu)) =- FU.SrcSpan (FU.Position ol (cl-1) ll) (FU.Position ou 1 (lu+1))+deleteLine (FU.SrcSpan (FU.Position ol cl ll fl pl) (FU.Position ou _ lu fu pu)) =+ FU.SrcSpan (FU.Position ol (cl-1) ll fl pl) (FU.Position ou 1 (lu+1) fu pu) linesCovered :: FU.Position -> FU.Position -> Int-linesCovered (FU.Position _ _ l1) (FU.Position _ _ l2) = l2 - l1 + 1+linesCovered (FU.Position _ _ l1 _ _) (FU.Position _ _ l2 _ _) = l2 - l1 + 1 -toCol0 (FU.Position o _ l) = FU.Position o 1 l+toCol0 (FU.Position o _ l f p) = FU.Position o 1 l f p afterAligned :: FU.SrcSpan -> FU.Position-afterAligned (FU.SrcSpan (FU.Position o cA _) (FU.Position _ _ lB)) =- FU.Position o cA (lB+1)+afterAligned (FU.SrcSpan (FU.Position o cA _ f p) (FU.Position _ _ lB _ _)) =+ FU.Position o cA (lB+1) f p
src/Camfort/Input.hs view
@@ -38,6 +38,7 @@ import qualified Language.Fortran.AST as F import Language.Fortran.Util.ModFile (ModFiles, emptyModFiles)+import Language.Fortran.ParserMonad (FortranVersion(..)) import Camfort.Analysis import Camfort.Analysis.Annotations@@ -56,7 +57,7 @@ -- | An 'AnalysisRunner' is a function to run an 'AnalysisProgram' in a -- particular way. Produces a final result of type @r@. type AnalysisRunner e w m a b r =- AnalysisProgram e w m a b -> LogOutput m -> LogLevel -> ModFiles -> [(ProgramFile, SourceText)] -> m r+ AnalysisProgram e w m a b -> LogOutput m -> LogLevel -> Bool -> ModFiles -> [(ProgramFile, SourceText)] -> m r -------------------------------------------------------------------------------- -- Simple runners@@ -67,7 +68,7 @@ runPerFileAnalysis :: (Monad m, Describe e, Describe w) => AnalysisRunner e w m ProgramFile b [AnalysisReport e w b]-runPerFileAnalysis program logOutput logLevel modFiles =+runPerFileAnalysis program logOutput logLevel snippets modFiles = traverse (\pf -> runAnalysisT (F.pfGetFilename pf)@@ -81,7 +82,7 @@ runMultiFileAnalysis :: (Monad m, Describe e, Describe w) => AnalysisRunner e w m [ProgramFile] b (AnalysisReport e w b)-runMultiFileAnalysis program logOutput logLevel modFiles+runMultiFileAnalysis program logOutput logLevel snippets modFiles = runAnalysisT "<unknown>" logOutput logLevel modFiles . program . map fst --------------------------------------------------------------------------------@@ -119,9 +120,9 @@ describePerFileAnalysis :: (MonadIO m, Describe r, ExitCodeOfReport r, Describe w, Describe e) => Text -> AnalysisRunner e w m ProgramFile r Int-describePerFileAnalysis analysisName program logOutput logLevel modFiles pfsTexts = do- reports <- runPerFileAnalysis program logOutput logLevel modFiles pfsTexts- mapM_ (putDescribeReport analysisName (Just logLevel)) reports+describePerFileAnalysis analysisName program logOutput logLevel snippets modFiles pfsTexts = do+ reports <- runPerFileAnalysis program logOutput logLevel snippets modFiles pfsTexts+ mapM_ (putDescribeReport analysisName (Just logLevel) snippets) reports return $ exitCodeOfSet reports -- | Accepts an analysis program for multiple input files which produces a@@ -132,8 +133,8 @@ => Text -> FileOrDir -> FilePath -> AnalysisRunner e w IO [ProgramFile] (r, [Either e' ProgramFile]) Int-doRefactor analysisName inSrc outSrc program logOutput logLevel modFiles pfsTexts = do- report <- runMultiFileAnalysis program logOutput logLevel modFiles pfsTexts+doRefactor analysisName inSrc outSrc program logOutput logLevel snippets modFiles pfsTexts = do+ report <- runMultiFileAnalysis program logOutput logLevel snippets modFiles pfsTexts let -- Get the user-facing output from the report@@ -141,7 +142,7 @@ -- Get the refactoring result form the report resultFiles = report ^? arResult . _ARSuccess . _2 - putDescribeReport analysisName (Just logLevel) report'+ putDescribeReport analysisName (Just logLevel) snippets report' -- If the refactoring succeeded, change the files case resultFiles of@@ -156,8 +157,8 @@ => Text -> FileOrDir -> FilePath -> AnalysisRunner e w IO [ProgramFile] ([ProgramFile], [ProgramFile]) Int-doRefactorAndCreate analysisName inSrc outSrc program logOutput logLevel modFiles pfsTexts = do- report <- runMultiFileAnalysis program logOutput logLevel modFiles pfsTexts+doRefactorAndCreate analysisName inSrc outSrc program logOutput logLevel snippets modFiles pfsTexts = do+ report <- runMultiFileAnalysis program logOutput logLevel snippets modFiles pfsTexts let -- Get the user-facing output from the report@@ -165,7 +166,7 @@ -- Get the refactoring result form the report resultFiles = report ^? arResult . _ARSuccess - putDescribeReport analysisName (Just logLevel) report'+ putDescribeReport analysisName (Just logLevel) snippets report' case resultFiles of -- If the refactoring succeeded, change the files@@ -225,8 +226,8 @@ :: (Monad m) => AnalysisRunner e w m a b r -> (r -> m r') -> AnalysisRunner e w m a b r'-runThen runner withResult program output level modFiles programFiles =- runner program output level modFiles programFiles >>= withResult+runThen runner withResult program output level snippets modFiles programFiles =+ runner program output level snippets modFiles programFiles >>= withResult -------------------------------------------------------------------------------- -- Misc@@ -257,14 +258,14 @@ loadModAndProgramFiles :: (MonadIO m)- => MFCompiler r m -> r+ => Maybe FortranVersion+ -> MFCompiler r m -> r -> FileOrDir -- ^ Input source file or directory -> FileOrDir -- ^ Include path -> [Filename] -- ^ Excluded files -> m (ModFiles, [(ProgramFile, SourceText)])-loadModAndProgramFiles mfc env inSrc incDir excludes = do+loadModAndProgramFiles mv mfc env inSrc incDir excludes = do liftIO $ printExcludes inSrc excludes- modFiles <- genModFiles emptyModFiles mfc env incDir excludes- ps <- liftIO $ readParseSrcDir modFiles inSrc excludes+ modFiles <- genModFiles mv emptyModFiles mfc env incDir excludes+ ps <- liftIO $ readParseSrcDir mv modFiles inSrc excludes pure (modFiles, ps)-
src/Camfort/Output.hs view
@@ -166,18 +166,22 @@ -- Output comments refactorBlocks _ inp (F.BlComment ann span (F.Comment comment)) = do cursor <- get+ let FU.SrcSpan lb ub = span+ lb' | deleteNode ann = lb { FU.posColumn = 0 }+ | otherwise = lb+ (p0, _) = takeBounds (cursor, lb') inp+ nl | null comment ||+ deleteNode ann = B.empty+ | otherwise = B.pack "\n" if pRefactored ann- then let (FU.SrcSpan lb ub) = span- (p0, _) = takeBounds (cursor, lb) inp- nl = if null comment then B.empty else B.pack "\n"- in put ub >> return (B.concat [p0, B.pack comment, nl], True)- else return (B.empty, False)+ then put ub >> return (B.concat [p0, B.pack comment, nl], True)+ else return (B.empty, False) -- Refactor use statements refactorBlocks v inp b@(F.BlStatement _ _ _ u@F.StUse{}) = do cursor <- get case refactored $ F.getAnnotation u of- Just (FU.Position _ rCol _) -> do+ Just (FU.Position _ rCol _ _ _) -> do let (FU.SrcSpan lb _) = FU.getSpan u let (p0, _) = takeBounds (cursor, lb) inp let out = B.pack $ PP.pprintAndRender v b (Just (rCol -1))@@ -194,8 +198,6 @@ refactorStatements v inp s refactorBlocks v inp (F.BlStatement _ _ _ s@F.StCommon{}) = refactorStatements v inp s-refactorBlocks v inp (F.BlStatement _ _ _ s@F.StDeclaration{}) =- refactorStatements v inp s -- Arbitrary statements can be refactored *as blocks* (in order to -- get good indenting) refactorBlocks v inp b@F.BlStatement {} = refactorSyntax v inp b@@ -215,12 +217,15 @@ let a = F.getAnnotation e case refactored a of Nothing -> return (B.empty, False)- Just (FU.Position _ rCol _) -> do- let (FU.SrcSpan lb ub) = FU.getSpan e- let (pre, _) = takeBounds (cursor, lb) inp- let indent = if newNode a then Just (rCol - 1) else Nothing- let output = if deleteNode a then B.empty- else B.pack $ PP.pprintAndRender v e indent+ Just (FU.Position _ rCol _ _ _) -> do+ let FU.SrcSpan lb ub = FU.getSpan e+ lb' | deleteNode a = lb { FU.posColumn = 0 }+ | otherwise = lb+ (pre, _) = takeBounds (cursor, lb') inp+ let indent | newNode a = Just (rCol - 1)+ | otherwise = Nothing+ let output | deleteNode a = B.empty+ | otherwise = B.pack $ PP.pprintAndRender v e indent out <- if newNode a then do -- If a new node is begin created then numAdded <- lift get@@ -232,14 +237,12 @@ lift $ put (numAdded - numRemoved) return out else return output- put ub+ put $ if FU.posColumn ub == 1+ then ub else ub { FU.posLine = FU.posLine ub + 1, FU.posColumn = 1 } return (B.concat [pre, out], True) -countLines xs =- case B.uncons xs of- Nothing -> 0- Just ('\n', xs) -> 1 + countLines xs- Just (_, xs) -> countLines xs+countLines :: B.ByteString -> Int+countLines = B.count '\n' {- 'removeNewLines xs n' removes at most 'n' new lines characters from the input string xs, returning the new string and the number of new
src/Camfort/Reprint.hs view
@@ -133,8 +133,8 @@ -- incoming SourceText based on the distanceF between the FU.Position pairs takeBounds :: (FU.Position, FU.Position) -> SourceText -> (SourceText, SourceText) takeBounds (l, u) = subtext (ll, lc) (ll, lc) (ul, uc)- where (FU.Position _ lc ll) = l- (FU.Position _ uc ul) = u+ where (FU.Position _ lc ll _ _) = l+ (FU.Position _ uc ul _ _) = u {-| Split a text.
+ src/Camfort/Specification/DerivedDataType.hs view
@@ -0,0 +1,772 @@+{-+ Copyright 2018, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish++ Licensed under the Apache License, Version 2.0 (the "License");+ you may not use this file except in compliance with the License.+ You may obtain a copy of the License at++ http://www.apache.org/licenses/LICENSE-2.0++ Unless required by applicable law or agreed to in writing, software+ distributed under the License is distributed on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+ See the License for the specific language governing permissions and+ limitations under the License.+-}++{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE RecordWildCards #-}++module Camfort.Specification.DerivedDataType+ ( infer, refactor, check, synth, compile+ , DerivedDataTypeReport(..), successful )+where++import Camfort.Analysis+import Camfort.Analysis.Annotations (onPrev, buildCommentText, A, Annotation(..))+import Camfort.Analysis.CommentAnnotator (annotateComments, ASTEmbeddable(..), Linkable(..))+import Camfort.Analysis.ModFile+import Camfort.Helpers (Filename)+import Camfort.Helpers.Syntax (afterAligned, toCol0, deleteLine)+import Camfort.Specification.DerivedDataType.Parser (ddtParser, DDTStatement(..))+import Control.Applicative+import Control.Arrow ((***), (|||), first, second, (&&&))+import Control.Lens+import Control.Monad+import Control.Monad.RWS.CPS+import Control.Monad.Writer.CPS+import Data.Binary (Binary, decodeOrFail, encode)+import qualified Data.ByteString.Lazy.Char8 as LB+import Data.Data+import Data.Function (on)+import Data.Generics.Uniplate.Operations+import qualified Data.IntMap.Strict as IM+import Data.List (sort, foldl', groupBy)+import qualified Data.List as List+import qualified Data.Map.Strict as M+import Data.Maybe (mapMaybe, fromMaybe, fromJust, maybeToList, isJust)+import Data.Monoid ((<>))+import qualified Data.Semigroup as SG+import qualified Data.Set as S+import qualified Data.Strict.Either as SE+import Data.Text (Text, unlines, intercalate, pack)+import Data.Text.Lazy.Builder (Builder)+import qualified Data.Text.Lazy.Builder as Builder+import GHC.Generics (Generic)+import qualified Language.Fortran.AST as F+import qualified Language.Fortran.Analysis as FA+import qualified Language.Fortran.Analysis.BBlocks as FAB+import qualified Language.Fortran.Analysis.DataFlow as FAD+import qualified Language.Fortran.Analysis.Renaming as FAR+import qualified Language.Fortran.Analysis.Types as FAT+import Language.Fortran.Util.ModFile+import qualified Language.Fortran.Util.Position as FU+import Prelude hiding (unlines)++ddtShort :: String+ddtShort = "ddt"++--------------------------------------------------+-- Linking DDT specifications with associated AST-blocks.++-- | Annotation used for derived-datatype info.+data DDTAnnotation = DDTAnnotation {+ prevAnnotation :: A,+ ddtSpec :: Maybe DDTStatement, -- ^ parsed spec on comments, if any+ ddtBlock :: Maybe (F.Block DA) -- ^ linked variable declaration, if any+ } deriving (Data, Typeable, Show)+-- | Initialize DDTAnnotation+ddtAnnotation0 :: A -> DDTAnnotation+ddtAnnotation0 a = DDTAnnotation a Nothing Nothing++-- | Annotation used by most analysis in this file.+type DA = FA.Analysis DDTAnnotation++-- | Modify top-level annotation.+onOrigAnnotation :: (A -> A) -> DA -> DA+onOrigAnnotation f = onPrev $ \ a -> a { prevAnnotation = f (prevAnnotation a) }++-- | Strip annotations used by this file.+stripAnnotations :: Functor f => f DA -> f A+stripAnnotations = fmap (prevAnnotation . FA.prevAnnotation)++-- Instances for embedding parsed specifications into the AST+instance ASTEmbeddable DA DDTStatement where+ annotateWithAST ann ast = onPrev (\ ann' -> ann' { ddtSpec = Just ast }) ann++-- Link annotation comments to declaration statements+instance Linkable DA where+ link ann b@(F.BlStatement _ _ _ F.StDeclaration{}) = onPrev (\ ann' -> ann' { ddtBlock = Just b }) ann+ link ann _ = ann+ linkPU ann _ = ann -- annotation on PU not needed/supported++--------------------------------------------------+-- Reporting data structures.++-- | Map of information about constants used to index arrays. Nothing+-- implies a non-constant is used to index the array at the given+-- dimension.+--+-- Variable name (unique name) => (dim => maybe constants)+type AMap = M.Map F.Name (IM.IntMap (S.Set (Maybe Int)))++-- | Map of info about vars (unique name).+type VMap = M.Map F.Name (S.Set VInfo)++-- | Map of specification essences connected to var-unique-name(dim)s.+type SMap = M.Map (F.Name, Int) (S.Set Essence)++-- | Info about a variable: source name, source filename, source span.+data VInfo = VInfo { vSrcName :: F.Name, vFileName :: String, vSrcSpan :: FU.SrcSpan }+ deriving (Generic, Show, Eq)+instance Binary VInfo++-- special ord instance compares by filename, source span and then name.+instance Ord VInfo where+ VInfo s1 f1 ss1 `compare` VInfo s2 f2 ss2 = (f1, ss1, s1) `compare` (f2, ss2, s2)++-- | The 'essence' of a specification, in comparable form.+data Essence = Essence { essTypeName :: String -- ^ specified type name+ , essLabelMap :: IM.IntMap String -- ^ specified index => label map+ , essVInfoSet :: S.Set VInfo -- ^ location of specified vars+ , essStarred :: Bool -- ^ is this essence 'starred'?+ }+ deriving (Show, Generic)+instance Binary Essence++-- special eq instance: only compare type-name and labels+instance Eq Essence where+ Essence ty1 l1 _ _ == Essence ty2 l2 _ _ = (ty1, l1) == (ty2, l2)++-- special ord instance: only compare type-name and labels+instance Ord Essence where+ Essence ty1 l1 _ _ `compare` Essence ty2 l2 _ _ = (ty1, l1) `compare` (ty2, l2)++-- given type name, (source name, span), dupped labels+data IndexError = IndexDupError String VInfo [Int]+ | IndexOOBError String VInfo [Int]+ deriving (Show, Eq, Ord, Generic)+instance Binary IndexError++-- | Variable(dim)s and any conflicting spec essences.+type ConflictErrors = M.Map (F.Name, Int) (S.Set Essence)++-- | Variable(dim)s where the specification has a bad (e.g. duplicated) label name+type BadLabelErrors = M.Map (F.Name, Int) (S.Set (String, VInfo))++-- | Variable(dim)s where the specification has a bad (e.g. duplicated) index+type BadDimErrors = M.Map (F.Name, Int) (S.Set (Int, VInfo))++-- | Collection of information comprising a 'derived datatype' report+-- for CamFort output purposes.+data DerivedDataTypeReport+ = DerivedDataTypeReport { ddtrAMap :: AMap+ , ddtrVMap :: VMap+ , ddtrSMap :: SMap+ , ddtrSpecs :: [DDTStatement]+ , ddtrIDE :: (S.Set IndexError)+ , ddtrCE :: ConflictErrors+ , ddtrBLE :: BadLabelErrors+ , ddtrBDE :: BadDimErrors+ , ddtrCheck :: Bool }+ deriving Generic+instance Binary DerivedDataTypeReport++-- | These reports can be combined, e.g. from multiple files, and the+-- key part is that the problem reports are also combined, and new+-- problems can be identified from the combination of the SMaps.+instance SG.Semigroup DerivedDataTypeReport where+ DerivedDataTypeReport m1 v1 s1 sp1 ide1 ce1 ble1 bde1 ch1 <> DerivedDataTypeReport m2 v2 s2 sp2 ide2 ce2 ble2 bde2 ch2 =+ DerivedDataTypeReport (M.unionWith (IM.unionWith S.union) m1 m2) (M.unionWith S.union v1 v2) newSMap+ (sp1 ++ sp2)+ (S.union ide1 ide2) (M.unionsWith S.union [ce1, ce2, newCE])+ (M.unionWith S.union ble1 ble2)+ (M.unionWith S.union bde1 bde2)+ (ch1 && ch2)+ where+ -- new conflicts found, if any+ newCE = M.map SE.fromLeft $ M.filter SE.isLeft e_smap+ -- combined SMaps+ newSMap = M.map (S.singleton . SE.fromRight) $ M.filter SE.isRight e_smap++ -- | Combine the SMaps while looking for new conflicts.+ e_smap = M.fromListWith combine [ (v, SE.Right e) | (v, eSet) <- M.toList s1 ++ M.toList s2, e <- S.toList eSet ]++ combine (SE.Left e1) _ = SE.Left e1+ combine _ (SE.Left e2) = SE.Left e2+ combine (SE.Right e1) (SE.Right e2) = combineEssences e1 e2++-- | Combine compatible essences (SE.Right) or else indicate conflict (SE.Left)+combineEssences :: Essence -> Essence -> SE.Either (S.Set Essence) Essence+combineEssences e1 e2+ | Essence ty1 labMap1 vinfoSet1 s1 <- e1+ , Essence ty2 labMap2 vinfoSet2 s2 <- e2 =+ fromMaybe (SE.Left $ S.fromList [e1, e2]) $ do+ -- In case of conflict, starred essence info overwrites unstarred essence info.+ --+ -- Compatible type name:+ ty <- case () of _ | ty1 == ty2 -> pure ty1+ | s1 && not s2 -> pure ty1+ | not s1 && s2 -> pure ty2+ | otherwise -> mzero+ -- Compatible label names:+ let labelStarCombine l1 l2 | l1 == l2 = l1+ | s1 && not s2 = l1+ | not s1 && s2 = l2+ | otherwise = mzero+ -- Combined label map:+ labMap <- sequenceIntMap $ IM.unionWith labelStarCombine (IM.map pure labMap1) (IM.map pure labMap2)+ pure . SE.Right $ Essence ty labMap (S.union vinfoSet1 vinfoSet2) (s1 || s2)++instance Monoid DerivedDataTypeReport where+ mempty = DerivedDataTypeReport M.empty M.empty M.empty [] S.empty M.empty M.empty M.empty False+ mappend = (SG.<>)++-- | True iff no errors are reported.+successful :: DerivedDataTypeReport -> Bool+successful r = and [S.null (ddtrIDE r), M.null (ddtrCE r), M.null (ddtrBLE r), M.null (ddtrBDE r)]++instance ExitCodeOfReport DerivedDataTypeReport where exitCodeOf r | successful r = 0 | otherwise = 1++instance Describe DerivedDataTypeReport where+ describeBuilder r@DerivedDataTypeReport{..}+ | not (successful r) = Builder.fromText errorReport+ | M.null ddtrSMap = "no cases detected"+ | ddtrCheck && num == 1 = "1 specification checked."+ | ddtrCheck = Builder.fromText $ describe num <> " specifications checked."+ | otherwise = Builder.fromText specReport+ where+ num = length ddtrSpecs+ specReport = linesByFile specLines+ specLines = [ (vinfo, [pack $ genCommentText r (var, vSrcName)])+ | ((var, dim), essenceSet) <- M.toList ddtrSMap+ , Essence{..} <- S.toList essenceSet+ , vinfo@VInfo{..} <- S.toList essVInfoSet ]++ ideLines = [ (vinfo, [pack ty <> " has duplicated indice(s) [" <>+ intercalate ", " (map describe ints) <> "] for variable: " <> pack (vSrcName vinfo)])+ | IndexDupError ty vinfo ints <- S.toList ddtrIDE ]+ oobLines = [ (vinfo, [pack ty <> " has out-of-bounds indice(s) [" <>+ intercalate ", " (map describe ints) <> "] for variable: " <> pack (vSrcName vinfo)])+ | IndexOOBError ty vinfo ints <- S.toList ddtrIDE ]+ ceLines = [ (vinfo, [pack ty0 <> "(" <> describeLabels l0 <> ") :: " <> pack (vSrcName vinfo) <> "(dim=" <>+ describe dim <> ")\nconflicts with\n" <>+ unlines [ pack fn <> ": " <> describe ss <> " " <> pack ty <> "(" <> describeLabels labs <> ")"+ | Essence ty labs vinfoSet _ <- essences+ , VInfo src fn ss <- S.toList vinfoSet ]])+ | ((_, dim), essenceSet) <- M.toList ddtrCE+ , not (S.null essenceSet)+ , let Essence ty0 l0 vinfoSet0 _:essences = S.toList essenceSet+ , vinfo <- take 1 (S.toList vinfoSet0) ]+ bleLines = [ (vinfo, ["duplicated label '" <> pack lab <> "', associated with variable " <>+ pack (vSrcName vinfo) <> "(dim=" <> describe dim <> ")"])+ | ((_, dim), badSet) <- M.toList ddtrBLE+ , (lab, vinfo) <- S.toList badSet ]+ bdeLines = [ (vinfo, [pack (vSrcName vinfo) <> ": bad dim " <> describe dim <>+ if maxDim == 0 then " less than 1"+ else " not in range 1.." <> describe maxDim])+ | ((_, dim), badSet) <- M.toList ddtrBDE+ , (maxDim, vinfo) <- S.toList badSet ]++ errorReport = linesByFile $ ideLines ++ oobLines ++ ceLines ++ bleLines ++ bdeLines+ describeLabels labs = intercalate ", " [describe i <> "=>" <> pack l | (i,l) <- IM.toList labs]++-- | Return combined text where entries are grouped and sorted by filename, source span+linesByFile :: [(VInfo, [Text])] -> Text+linesByFile vinfoTexts = unlines $ concat [ ("\n"<>pack fileName<>":\n") : [ describe ss <> " " <> text+ | (ss, text) <- sort sstexts ]+ | (fileName, sstexts) <- M.toList mapByFile ]+ where+ mapByFile = M.fromListWith (++) [ (vFileName vinfo, map (vSrcSpan vinfo,) texts) | (vinfo, texts) <- vinfoTexts ]++--------------------------------------------------+-- External Functionality Interface++-- | Generate report about derived datatypes in given program file+infer :: F.ProgramFile A -> PureAnalysis String () DerivedDataTypeReport+infer pf = do+ mfs <- analysisModFiles+ return . fst $ genProgramFileReport mfs pf++-- | Check annotations relating to derived datatypes in given program file+check :: F.ProgramFile A -> PureAnalysis String () DerivedDataTypeReport+check pf = do+ mfs <- analysisModFiles+ return (fst $ genProgramFileReport mfs pf) { ddtrCheck = True }+ -- FIXME: check that a user-supplied spec doesn't conflict with something disqualifying in the code++-- | Generate and insert comments about derived datatypes+synth :: Char -> [F.ProgramFile A] -> PureAnalysis String () (DerivedDataTypeReport, [Either String (F.ProgramFile A)])+synth marker pfs = do+ mfs <- analysisModFiles+ forEachProgramFile pfs $ \ pf -> do+ let (report, pf'@(F.ProgramFile mi _)) = genProgramFileReport mfs pf+ let synthedPF = descendBi (synthBlocks (mi, marker) report) pf'+ let strippedPF | successful report = Right (stripAnnotations synthedPF)+ | otherwise = Left "error"+ return $ (report, strippedPF)++-- | Refactor derived datatypes based on marked comments+refactor :: [F.ProgramFile A] -> PureAnalysis String () (DerivedDataTypeReport, [Either String (F.ProgramFile A)])+refactor pfs = do+ mfs <- analysisModFiles+ forEachProgramFile pfs $ \ pf -> do+ let (report, pf') = genProgramFileReport mfs pf+ let smap = M.filter (not . S.null) . M.map (S.filter essStarred) $ ddtrSMap report+ let amap = M.filter (not . IM.null) . M.mapWithKey cullDims $ ddtrAMap report+ where cullDims var = IM.filterWithKey (\ dim _ -> M.member (var, dim) smap)+ let report' = report { ddtrSMap = smap, ddtrAMap = amap }+ if M.null smap+ then return (report', Left "nothing to do")+ else return (report', Right . stripAnnotations $ refactorPF report' pf')++-- | Compile a program to a 'ModFile' containing derived datatype information.+compile :: () -> ModFiles -> F.ProgramFile A -> IO ModFile+compile _ mfs pf = do+ let (report, pf') = genProgramFileReport mfs pf+ return $ genDDTModFile pf' report++--------------------------------------------------+-- Analysis helpers++-- | Perform monadic action on each, which returns a pair. The fst+-- elements of the pairs is combined with (<>) and the second elements+-- of the pairs are returned in a list.+forEachProgramFile :: (Monad m, Monoid r) => [a] -> (a -> m (r, b)) -> m (r, [b])+forEachProgramFile pfs f = do+ results <- mapM f pfs+ return (foldl' (<>) mempty (map fst results), map snd results)++-- | Performs analysis about a single program file and returns a+-- report containing the essences and problems detected, as well as an+-- annotated program file for further usage.+genProgramFileReport :: ModFiles -> F.ProgramFile A -> (DerivedDataTypeReport, F.ProgramFile DA)+genProgramFileReport mfs (pf@(F.ProgramFile F.MetaInfo{ F.miFilename = srcFile } _)) = (report, pf')+ where+ (amap, pf', tenv) = analysis mfs pf+ vars = S.fromList $ M.keys amap+ vls1 = [ (v, S.singleton $ VInfo (FA.srcName e) srcFile ss)+ | F.DeclArray _ ss e _ _ _ <- universeBi pf' :: [F.Declarator DA]+ , let v = FA.varName e+ , v `S.member` vars ]+ vls2 = [ (v, S.singleton $ VInfo (FA.srcName e) srcFile ss)+ | F.DeclVariable _ ss e _ _ <- universeBi pf' :: [F.Declarator DA]+ , let v = FA.varName e+ , v `S.member` vars ]+ vmap = M.fromListWith S.union $ vls1 ++ vls2++ specs = [ (spec, b) | DDTAnnotation { ddtSpec = Just spec, ddtBlock = Just b } <- universeBi pf' ]++ -- Boil down the specs parsed from the comments.+ e_essences = [ essMapping | (spec@DDTSt{..}, b) <- specs+ , (var, dim) <- ddtStVarDims+ , (declVarName, vinfo) <- declaredVars srcFile b+ , vSrcName vinfo == var+ , let essMapping = ((declVarName, dim), distil spec vinfo) ]+ (l_errors, r_essences) = List.partition (SE.isLeft . snd) e_essences++ -- Dupped indices:+ dupIndices = S.fromList $ map (SE.fromLeft . snd) l_errors++ essences :: M.Map (F.Name, Int) (S.Set Essence)+ essences = M.fromListWith S.union $ map (second (S.singleton . SE.fromRight)) r_essences++ -- Conflicting specs:+ conflicts = M.filter ((>1) . S.size) essences+ findDupLabels Essence{..} = [ (lab, vinfo) | lab <- labs, vinfo <- vinfos ]+ where+ vinfos = S.toList essVInfoSet+ -- Labels that appear more than once in the label map:+ labs = M.keys . M.filter (>1) . M.fromListWith (+) . map (,1) $ IM.elems essLabelMap++ -- Dupped labels:+ badLabels = M.filter (not . null) $ M.map (setConcatMap findDupLabels) essences++ -- Badly specified 'dim' attributes (e.g. out of bounds):+ badDims = [ ((declVarName, dim), S.singleton (maxDim, vinfo))+ | (spec@DDTSt{..} , b) <- specs+ , (srcName, dim) <- ddtStVarDims+ , (declVarName, vinfo) <- declaredVars srcFile b+ , vSrcName vinfo == srcName+ , Just maxDim <- [ do guard (dim < 1)+ return 0 -- Stand-in number for 'dim violates the lower bound' case.+ <|>+ do FA.IDType { FA.idCType = Just (FA.CTArray dims) } <- M.lookup declVarName tenv+ let maxDim = length dims+ guard $ not (null dims || dim <= maxDim)+ -- There is a known upper-bound and dim violates it.+ return maxDim ] ]++ -- Index out-of-bounds of statically-known array dimensions:+ oobIndices = [ IndexOOBError tyname vinfo indices+ | (spec@DDTSt{..} , b) <- specs+ , (srcName, dim) <- ddtStVarDims+ , (declVarName, vinfo) <- declaredVars srcFile b+ , let indices = [], let tyname = ""+ , vSrcName vinfo == srcName+ , Just indices <- [ do FA.IDType { FA.idCType = Just (FA.CTArray dims) } <- M.lookup declVarName tenv+ let maxDim = length dims+ guard $ dim >= 1 && dim <= maxDim+ let (mminBound, mmaxBound) = dims !! (dim - 1)+ let minBound = 1 `fromMaybe` mminBound+ maxBound <- mmaxBound+ let indices = [ read i | (i, _) <- ddtStLabels ]+ let oob = filter (uncurry (||) . ((< minBound) &&& (> maxBound))) indices+ guard . not . null $ oob+ -- oob is the list of indices out-of-bounds+ return oob ] ]++ -- Distil specs from the inferred AMap:+ smapFromAMap = M.fromList [ ((v, dim), essenceSet) | (v, aminfoMap) <- M.toList amap+ , (dim, aminfo) <- IM.toList aminfoMap+ , all isJust (S.toList aminfo)+ , Just vinfoSet <- [M.lookup v vmap]+ , let e = distilArrayInfo v vinfoSet (S.map fromJust aminfo)+ , let essenceSet = S.singleton e ]+ -- Specs in the file override inferred specs:+ smap = M.unionWith (curry fst) essences smapFromAMap++ ide = dupIndices `S.union` S.fromList oobIndices+ ce = conflicts+ ble = badLabels+ bde = M.fromList badDims+ -- Combine this report with those reports read from modfiles:+ report = DerivedDataTypeReport amap vmap smap (map fst specs) ide ce ble bde False <> combinedDerivedDataTypeReport mfs++-- | Analyse and return an AMap, a spec-linked ProgramFile and a type+-- environment (convenience). The AMap contains derived information+-- about array accesses that appear to be in a 'category 1' pattern,+-- namely whether the array is accessed at the particular dimension+-- only by constants.+analysis :: ModFiles -> F.ProgramFile A -> (AMap, F.ProgramFile DA, FAT.TypeEnv)+analysis mfs pf = (amap', linkedPF, tenv)+ -- FIXME: check for violations of the 'only one array deref in a path' rule+ where+ (pf', _, tenv) = withCombinedEnvironment mfs (fmap ddtAnnotation0 pf)+ pf'' = FAD.analyseConstExps $ FAB.analyseBBlocks pf'++ -- Link specifications (in comments) to associated AST-blocks:+ (linkedPF, _) = runWriter $ annotateComments ddtParser+ (\ srcSpan err -> tell $ "Error " ++ show srcSpan ++ ": " ++ show err) pf''++ -- Attempt to gather any constant-expression information from indices.+ perArray :: [F.Index DA] -> [(Int, Maybe Int)]+ perArray is = [ (n, do F.IxSingle _ _ Nothing e <- Just ix+ FAD.ConstInt i <- FA.constExp (F.getAnnotation e)+ return (fromIntegral i))+ | (n, ix) <- zip [1..] is ]++ -- Gathered array information for each observed array access:+ accessInfo :: [(F.Name, IM.IntMap (S.Set (Maybe Int)))]+ accessInfo = [ (FA.varName a, makeIntMapSet observation)+ | F.ExpSubscript _ _ a@(F.ExpValue _ _ (F.ValVariable _)) is <- universeBi pf''+ , let observation = perArray $ F.aStrip is ]++ -- Convert access info into a map of information about the+ -- constants used to index arrays.+ amap :: M.Map F.Name (IM.IntMap (S.Set (Maybe Int)))+ amap = M.fromListWith (IM.unionWith S.union) accessInfo++ -- Filter only the interesting ones: at least one of the+ -- parameters was populated only by a range of constants where+ -- each constant is no more than 3 away from the adjacent ones.+ amap' = M.filter (not . IM.null . IM.filter valid) amap -- accept if at least one valid parameter+ where+ diffs = uncurry (zipWith subtract) . (id &&& drop 1) . sort -- compute differences between consecutive numbers+ -- valid set if...+ valid = and . sequence [ not . null -- (1) non-empty list+ , all isJust -- (2) of constants only, no wildcards+ , all (< 3) . diffs . map fromJust -- (3) no more than 3 away from adjacent constants+ ] . S.toList+--------------------------------------------------+-- Refactoring helpers++type RefactorM = RWS DerivedDataTypeReport [Essence] Bool++refactorPF :: DerivedDataTypeReport -> F.ProgramFile DA -> F.ProgramFile DA+refactorPF r pf = pf'+ where+ -- FIXME: possibly use the 'essences' writer slot to instead+ -- gather derived-type declarations and put them somewhere+ -- central.+ (pf', _, essences) = runRWS (descendBiM refactorBlocks pf) r False++refactorBlocks :: [F.Block DA] -> RefactorM [F.Block DA]+refactorBlocks = fmap concat . mapM refactorBlock++refactorBlock :: F.Block DA -> RefactorM [F.Block DA]+refactorBlock b = ask >>= \ DerivedDataTypeReport{..} -> case b of+ -- Rewrite a type declaration of the variable to be converted into the new form.+ -- FIXME: handle references to other converted variables that are found in initialisation expressions+ F.BlStatement a ss lab (F.StDeclaration stA stSS ty attrs (F.AList alA alSS decls)) -> do+ let declNames = map ((FA.varName . declExp) &&& id) decls+ -- Partition declared variables into 'refactor' and 'remain' sets.+ let (declsRef, declsRem) = List.partition ((`M.member` ddtrAMap) . fst) declNames+ let a' | null declsRef = a+ | otherwise = flip onOrigAnnotation a $ \ orig -> orig { refactored = Just (afterAligned ss) }++ -- Process a variable (and its corresponding declaration).+ let eachVar (var, decl)+ | Just dimMap <- M.lookup var ddtrAMap+ -- find the DimDecls for the array we are working on+ , dimDeclALists <- universeBi b :: [F.AList F.DimensionDeclarator DA]+ , not (null dimDeclALists)+ -- if DimDecls are specified twice, take the last one:+ , F.AList alDDA alDDSS dimList <- last dimDeclALists+ , dims <- IM.keys dimMap+ , minDim <- minimum dims+ , maxDim <- maximum dims+ , dimDeclAList' <- F.AList alDDA alDDSS (take (minDim - 1) dimList)+ , dimEssences <- sort $ mapMaybe (\ dim -> (dim,) <$> M.lookup (var, dim) ddtrSMap) dims+ , (_, esset1):_ <- dimEssences+ , ess1:_ <- S.toList esset1 =+ let+ F.TypeSpec tyA tySS _ msel = ty+ ty' = F.TypeSpec tyA tySS (F.TypeCustom $ essTypeName ess1) msel+ a'' = flip onOrigAnnotation a' $ \ orig -> orig { newNode = True }+ ss' = FU.SrcSpan (toCol0 lp) lp where lp = afterAligned ss+ -- FIXME: character length, what to do+ decl' ddAList+ | dds <- F.aStrip ddAList+ , null dds = F.DeclVariable (F.getAnnotation decl) (FU.getSpan decl) (declExp decl) Nothing Nothing+ | otherwise = F.DeclArray (F.getAnnotation decl) (FU.getSpan decl) (declExp decl) ddAList Nothing Nothing++ -- The list of attributes minus any dimension attributes.+ attrs' = descendBi (List.filter (not . isAttrDimension)) attrs+ attrs'' | Just (F.AList _ _ []) <- attrs' = Nothing+ | otherwise = attrs'++ -- Each dimension index number along with its associated type-name.+ dimTypes = flip map dimEssences . second $ \ esset -> case S.toList esset of+ Essence{..}:_ -> F.TypeSpec tyA tySS (F.TypeCustom $ essTypeName) Nothing+ _ -> error "dimTypes: something broken badly: no essences in set"++ -- Process each dimension and return the AST-blocks that define the derived type.+ eachDim :: [F.DimensionDeclarator DA] -> Int -> [(Int, F.TypeSpec DA)] -> [F.Block DA]+ eachDim dimList maxDim ((dim, F.TypeSpec _ _ (F.TypeCustom tyName) _):(_, nextTy):rest)+ | Just (Essence{..}:_) <- fmap S.toList $ M.lookup (var, dim) ddtrSMap = let+ mInit | null rest = declInitialiser decl+ | otherwise = Nothing+ dimDeclAList = F.AList a ss $ drop dim dimList+ eachLabel (n, lab)+ | maxDim == dim &&+ dim < length dimList = F.DeclArray a ss (FA.genVar a ss lab) dimDeclAList Nothing mInit+ | otherwise = F.DeclVariable a ss (FA.genVar a ss lab) Nothing mInit+ labelDecls = map eachLabel . sort $ IM.toList essLabelMap+ in [ F.BlStatement a'' ss' Nothing (F.StType stA stSS Nothing tyName)+ , F.BlStatement a'' ss' Nothing (F.StDeclaration stA stSS nextTy attrs'' (F.AList alA alSS labelDecls))+ , F.BlStatement a'' ss' Nothing (F.StEndType stA stSS Nothing) ]+ eachDim _ _ _ = []++ in (concat . reverse $ map (eachDim dimList maxDim) (List.tails $ dimTypes ++ [(0, ty)])) +++ -- The declaration of the variable under the new derived type:+ [F.BlStatement a'' ss' lab (F.StDeclaration stA stSS ty' attrs'' (F.AList alA alSS [decl' dimDeclAList']))]+ let aRem = onOrigAnnotation (\ orig -> orig { deleteNode = null declsRem }) a'+ return $ -- Reinsert any other variables, with the refactored ones removed from the list.+ [F.BlStatement aRem ss lab (F.StDeclaration stA stSS ty attrs (F.AList alA alSS (map snd declsRem)))] +++ -- Followed by the new set of declarations and derived types.+ concatMap eachVar declsRef++ -- Eliminate comments that were processed.+ F.BlComment a ss _+ | Just spec <- ddtSpec (FA.prevAnnotation a)+ , ddtStStarred spec -> do+ let FU.SrcSpan lp _ = ss+ ss' = deleteLine ss+ a' = flip onOrigAnnotation a $ \ orig -> orig { refactored = Just lp, deleteNode = True }+ return $ if spec `List.elem` ddtrSpecs+ then [F.BlComment a' ss' $ F.Comment ""]+ else [b]+ -- Rewrite references to the converted variable+ F.BlStatement _ _ _ _ -> do+ put False+ b' <- transformBiM refactorExp b+ flag <- get+ let FU.SrcSpan lb _ = FU.getSpan b'+ if flag+ then return [F.modifyAnnotation (onOrigAnnotation $ \ a -> a { refactored = Just lb }) b']+ else return [b]+ -- FIXME: handle BlDo, etc+ _ -> (:[]) <$> descendBiM refactorBlocks b++isAttrDimension :: F.Attribute DA -> Bool+isAttrDimension F.AttrDimension{} = True; isAttrDimension _ = False++-- | Convert references such as @x(1,2,3)@ into @x % label1 % label2(3)@.+refactorExp :: F.Expression DA -> RefactorM (F.Expression DA)+refactorExp e = do+ smap <- asks ddtrSMap+ case e of+ F.ExpSubscript a s e1 ixAList+ | ixs <- F.aStrip ixAList+ , list <- zipWith ixLookup [1..] ixs+ , any SE.isRight list+ , list' <- groupBy ((==) `on` SE.isLeft) list+ , e' <- foldl' rewrite e1 list' -> put True >> return e'+ where+ ixLookup dim ix@(F.IxSingle ixA ixS Nothing e)+ | Just (FAD.ConstInt i) <- FA.constExp (F.getAnnotation e)+ , Just (Essence{..}:_) <- fmap S.toList $ M.lookup (FA.varName e1, dim) smap+ , Just label <- IM.lookup (fromIntegral i) essLabelMap = SE.Right (ixA, ixS, label)+ ixLookup _ ix = SE.Left ix++ rewrite e l@(SE.Left _:_) = F.ExpSubscript a s e (F.AList a s $ map SE.fromLeft l)+ rewrite e (SE.Right (ixA, ixS, label):l) = rewrite (F.ExpDataRef a s e (F.ExpValue a s (F.ValVariable label))) l+ rewrite e [] = e+ -- FIXME: either convert array slices, or regard that as a disqualifying effect+ _ -> return e++--------------------------------------------------+-- Synthesis helpers++-- Operate on [Block], handling insertion or deletion of blocks+synthBlocks :: (F.MetaInfo, Char) -> DerivedDataTypeReport -> [F.Block DA] -> [F.Block DA]+synthBlocks marker report = concatMap (synthBlock marker report)++-- Synthesise comments where needed, strip existing comment annotations.+synthBlock :: (F.MetaInfo, Char) -> DerivedDataTypeReport -> F.Block DA -> [F.Block DA]+synthBlock (mi, marker) r@DerivedDataTypeReport { ddtrAMap = amap } b = case b of+ -- check if this declaration has variables of interest+ F.BlStatement a ss _ F.StDeclaration{} | vars <- ofInterest b -> genComment vars ++ [b]+ where+ ofInterest b = filter (flip M.member amap . fst) $+ [ (FA.varName e, FA.srcName e) | F.DeclVariable _ _ e _ _ <- universeBi b :: [F.Declarator DA] ] +++ [ (FA.varName e, FA.srcName e) | F.DeclArray _ _ e _ _ _ <- universeBi b :: [F.Declarator DA] ]++ genComment = map $ \ var ->+ F.BlComment newA newSS . F.Comment . buildCommentText mi space $ marker:genCommentText r var++ -- Set the refactored flag for the reprinter.+ newA = onOrigAnnotation (\ orig -> orig { refactored = Just lp } ) a++ newSS = FU.SrcSpan (lp {FU.posColumn = 0}) (lp {FU.posColumn = 0})+ FU.SrcSpan lp _ = ss+ space = FU.posColumn lp - 1+ -- strip existing comment annotations+ F.BlComment a ss c | isJust . ddtSpec . FA.prevAnnotation $ a -> [F.BlComment a' ss' $ F.Comment ""]+ where+ FU.SrcSpan lp _ = ss+ ss' = deleteLine ss+ a' = flip onOrigAnnotation a $ \ orig -> orig { refactored = Just lp, deleteNode = True }+ -- otherwise leave the Block untouched+ _ -> [descendBi (synthBlocks (mi, marker) r) b]++-- Generate the text that goes into the specification.+genCommentText :: DerivedDataTypeReport -> (F.Name, F.Name) -> String+genCommentText DerivedDataTypeReport{..} (varName, srcName)+ | Just pmap <- M.lookup varName ddtrAMap+ , (dim, set):_ <- IM.toList $ IM.filter (all isJust . S.toList) pmap =+ case M.lookup (varName, dim) ddtrSMap of+ -- generate new comment from scratch+ Nothing+ | nums <- map fromJust $ S.toList set+ , ty <- varName ++ "_type"+ , labs <- List.intercalate ", " [ str ++ "=>" ++ "label" ++ str | num <- nums, let str = show num ] ->+ " ddt " ++ ty ++ "(" ++ labs ++ ") :: " ++ srcName ++ "(dim=" ++ show dim ++ ")"+ -- generate comment from pre-existing info+ Just essenceSet+ | Essence{..}:_ <- S.toList essenceSet+ , labs <- List.intercalate ", " [ show i ++ "=>" ++ lab | (i, lab) <- IM.toList essLabelMap ]+ , starStr <- if essStarred then "* " else " " ->+ " " ++ ddtShort ++ starStr ++ essTypeName ++ "(" ++ labs ++ ") :: " ++ srcName ++ "(dim=" ++ show dim ++ ")"+ _ -> error $ "genCommentText: unable to generate text for " ++ srcName++--------------------------------------------------+-- Check helpers++-- | From the given piece of AST, returns a list of declared variables+-- (unique form) paired with location.+declaredVars :: Data (f DA) => String -> f DA -> [(F.Name, VInfo)]+declaredVars srcFile x = [ (FA.varName e, VInfo (FA.srcName e) srcFile (FU.getSpan e)) | e <- declaredExps x ]+++-- | From the given piece of AST, returns a list of expressions+-- associated with the declarators.+declaredExps :: Data (f DA) => f DA -> [F.Expression DA]+declaredExps x = [ e | d <- universeBi x :: [F.Declarator DA]+ , e@(F.ExpValue _ _ (F.ValVariable _)) <- [declExp d] ]+++-- | Pattern matches the expression from the declarator+declExp :: F.Declarator a -> F.Expression a+declExp (F.DeclVariable _ _ e _ _) = e+declExp (F.DeclArray _ _ e _ _ _) = e++-- | Pattern matches the initialiser from the declarator+declInitialiser :: F.Declarator a -> Maybe (F.Expression a)+declInitialiser (F.DeclVariable _ _ _ _ me) = me+declInitialiser (F.DeclArray _ _ _ _ _ me) = me++-- | Given a parsed specification and variable information, attempts+-- to 'distil' the essence of the specification. If there is a problem+-- with the spec then it returns SE.Left, otherwise SE.Right.+distil :: DDTStatement -> VInfo -> SE.Either IndexError Essence+distil (DDTSt { ddtStStarred = star, ddtStTypeName = tyname, ddtStLabels = labels }) vinfo+ -- if no duplicated indices+ | noDups nums = SE.Right $ Essence { essTypeName = tyname+ , essLabelMap = IM.fromList [ (n, lname) | (n, lname) <- labels' ]+ , essVInfoSet = S.singleton vinfo+ , essStarred = star }+ -- if there's a problem+ | otherwise = SE.Left $ IndexDupError tyname vinfo (nums List.\\ List.nub nums)+ where+ labels' = map (first read) labels+ nums = map fst labels'+ noDups nums = length (List.nub nums) == length nums++-- | Create an essence from array access information derived in a+-- file, assuming some default names and labels.+distilArrayInfo :: F.Name -> S.Set VInfo -> S.Set Int -> Essence+distilArrayInfo var essVInfoSet dimSet = Essence{..}+ where+ essTypeName = var ++ "_type"+ essLabelMap = IM.fromList [ (n, lname) | n <- S.toList dimSet, let lname = "label" ++ show n ]+ essStarred = False++-- | Like concatMap, over Sets+setConcatMap :: (Ord a, Ord b) => (a -> [b]) -> S.Set a -> S.Set b+setConcatMap f = S.fromList . concatMap f . S.toList++-- | Turn a list of indexed pairs into an IntMap combining values into sets.+makeIntMapSet :: Ord b => [(Int, b)] -> IM.IntMap (S.Set b)+makeIntMapSet = IM.fromListWith S.union . map (second S.singleton)++-- | Operates like 'sequence' but on an IntMap.+sequenceIntMap :: Monad m => IM.IntMap (m a) -> m (IM.IntMap a)+sequenceIntMap = fmap IM.fromList . sequence . map mstrength . IM.toList++-- | Lifts the monad from the second half of the pair.+mstrength :: Functor f => (a, f b) -> f (a, b)+mstrength (x, my) = fmap (x,) my++--------------------------------------------------+-- Compilation helpers++-- | Generate a new ModFile containing derived datatype information.+genDDTModFile :: Data a => F.ProgramFile (FA.Analysis a) -> DerivedDataTypeReport -> ModFile+genDDTModFile pf ddtr = alterModFileData f ddtCompiledDataLabel $ genModFile pf+ where+ f _ = Just $ encode ddtr++-- | Decode a DerivedDataTypeReport from a ModFile.+mfDerivedDataTypeReport :: ModFile -> DerivedDataTypeReport+mfDerivedDataTypeReport mf = case lookupModFileData ddtCompiledDataLabel mf of+ Nothing -> mempty+ Just bs -> case decodeOrFail bs of+ Left _ -> mempty+ Right (_, _, ddtr) -> ddtr++-- | Combine all reports from ModFiles using (<>)+combinedDerivedDataTypeReport :: ModFiles -> DerivedDataTypeReport+combinedDerivedDataTypeReport = foldMap mfDerivedDataTypeReport++-- | Section name for derived datatype info inside a ModFile.+ddtCompiledDataLabel :: String+ddtCompiledDataLabel = "derived-datatypes-compiled-data"
+ src/Camfort/Specification/DerivedDataType/Parser.y view
@@ -0,0 +1,140 @@+{ -- -*- Mode: Haskell -*-+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}++module Camfort.Specification.DerivedDataType.Parser+ ( ddtParser+ , DDTParseError+ , DDTStatement(..)+ ) where++import Camfort.Specification.Parser (mkParser, SpecParser)+import Control.Monad.Except (throwError)+import Data.Binary (Binary)+import Data.Char (isLetter, isNumber, isAlphaNum, toLower)+import Data.Data (Data)+import GHC.Generics (Generic)++}++%monad { DDTSpecParser } { >>= } { return }+%name parseDDT DDT+%tokentype { Token }++%token+ ddt { TId "ddt" }+ dim { TId "dim" }+ id { TId $$ }+ num { TNum $$ }+ ',' { TComma }+ '::' { TDoubleColon }+ '=' { TEqual }+ '=>' { TArrow }+ '(' { TLeftPar }+ ')' { TRightPar }+ '*' { TStar }++%%++DDT :: { DDTStatement }+: ddt OPTSTAR id '(' LABELS ')' '::' VARDIMS { DDTSt $2 $3 $5 $8 }++OPTSTAR :: { Bool }+: '*' { True }+| { False }++VARDIMS :: { [(String, Int)] }+: VARDIM ',' VARDIMS { $1 : $3 }+| VARDIM { [$1] }++VARDIM :: { (String, Int) }+: id '(' dim '=' num ')' { ($1, read $5) }++LABELS :: { [(String, String)] }+: LABEL ',' LABELS { $1 : $3 }+| LABEL { [$1] }++LABEL :: { (String, String) }+: num '=>' id { ($1, $3) }++{++data DDTStatement+ = DDTSt { ddtStStarred :: Bool+ , ddtStTypeName :: String+ , ddtStLabels :: [(String, String)]+ , ddtStVarDims :: [(String, Int)] }+ deriving (Data, Eq, Show, Generic)+instance Binary DDTStatement++data DDTParseError+ -- | Not a valid identifier character.+ = NotAnIdentifier Char+ -- | Tokens do not represent a syntactically valid specification.+ | CouldNotParseSpecification [Token]+ deriving (Eq)++instance Show DDTParseError where+ show (CouldNotParseSpecification ts) =+ "Could not parse specification at: \"" ++ show ts ++ "\"\n"+ show (NotAnIdentifier c) = "Invalid character in identifier: " ++ show c++notAnIdentifier :: Char -> DDTParseError+notAnIdentifier = NotAnIdentifier++couldNotParseSpecification :: [Token] -> DDTParseError+couldNotParseSpecification = CouldNotParseSpecification++type DDTSpecParser a = Either DDTParseError a++data Token =+ TComma+ | TDoubleColon+ | TArrow+ | TEqual+ | TStar+ | TLeftPar+ | TRightPar+ | TId String+ | TNum String+ deriving (Show, Eq)++addToTokens :: Token -> String -> DDTSpecParser [ Token ]+addToTokens tok rest = do+ tokens <- lexer rest+ return $ tok : tokens++lexer :: String -> DDTSpecParser [ Token ]+lexer [] = Right []+lexer ['\n'] = Right []+lexer ['\r', '\n'] = Right []+lexer ['\r'] = Right [] -- windows+lexer (' ':xs) = lexer xs+lexer ('\t':xs) = lexer xs+lexer (':':':':xs) = addToTokens TDoubleColon xs+lexer ('=':'>':xs) = addToTokens TArrow xs+lexer (',':xs) = addToTokens TComma xs+lexer ('=':xs) = addToTokens TEqual xs+lexer ('*':xs) = addToTokens TStar xs+lexer ('(':xs) = addToTokens TLeftPar xs+lexer (')':xs) = addToTokens TRightPar xs+lexer (x:xs)+ | isLetter x || x == '\'' = aux (\ c -> isAlphaNum c || c `elem` ['\'','_','-'])+ TId+ | isNumber x = aux isNumber TNum+ | otherwise+ = throwError $ notAnIdentifier x+ where+ aux p cons =+ let (target, rest) = span p xs+ in lexer rest >>= (\tokens -> return $ cons (x:target) : tokens)++ddtParser :: SpecParser DDTParseError DDTStatement+ddtParser = mkParser (\src -> do+ tokens <- lexer $ map toLower src+ parseDDT tokens) ["ddt"]++happyError :: [ Token ] -> DDTSpecParser a+happyError = throwError . couldNotParseSpecification++}
src/Camfort/Specification/Hoare.hs view
@@ -199,12 +199,13 @@ testOn :: FilePath -> IO () testOn fp = do- (mfs, pfsSources) <- loadModAndProgramFiles simpleCompiler () fp fp []+ (mfs, pfsSources) <- loadModAndProgramFiles Nothing simpleCompiler () fp fp [] describePerFileAnalysis "invariant checking" (check PROIdealized) (logOutputStd True) LogDebug+ False mfs pfsSources return ()
src/Camfort/Specification/Hoare/CheckBackend.hs view
@@ -25,8 +25,9 @@ import Control.Exception (Exception (..)) import Control.Lens import Control.Monad.Reader+import Control.Monad.Fail import Control.Monad.State.Strict-import Control.Monad.Writer.Strict+import Control.Monad.Writer.CPS import Control.Monad.Trans.Maybe import Data.Data (Data) import Data.Foldable (foldlM)@@ -495,6 +496,7 @@ , MonadWriter [MetaFormula Bool] , MonadLogger HoareBackendError HoareBackendWarning , MonadAnalysis HoareBackendError HoareBackendWarning+ , MonadFail ) @@ -593,6 +595,7 @@ tryBlockToAssignment :: ( MonadReader CheckHoareEnv m , MonadAnalysis HoareBackendError HoareBackendWarning m+ , MonadFail m ) => F.Block HA -> m (Maybe FortranAssignment) tryBlockToAssignment bl = do@@ -624,6 +627,7 @@ :: ( ReportAnn (F.Analysis ann) , MonadReader CheckHoareEnv m , MonadAnalysis HoareBackendError HoareBackendWarning m+ , MonadFail m ) => NamePair -> F.Expression (F.Analysis ann)@@ -644,6 +648,7 @@ :: ( ReportAnn (F.Analysis ann) , MonadReader CheckHoareEnv m , MonadAnalysis HoareBackendError HoareBackendWarning m+ , MonadFail m ) => NamePair -> F.Expression (F.Analysis ann)@@ -675,6 +680,7 @@ :: ( F.Spanned a , MonadReader CheckHoareEnv m , MonadAnalysis HoareBackendError HoareBackendWarning m+ , MonadFail m ) => a -> NamePair -> m SomeVar varFromScope loc np = do@@ -696,7 +702,7 @@ doTranslate- :: (MonadReader CheckHoareEnv m, ReportAnn ann)+ :: (MonadReader CheckHoareEnv m, ReportAnn ann, MonadFail m) => (HoareBackendError -> m a) -> (f ann -> TranslateT m a) -> f ann -> m a doTranslate handle trans ast = do env <- asks toTranslateEnv@@ -720,6 +726,7 @@ :: ( ReportAnn (F.Analysis ann) , MonadReader CheckHoareEnv m , MonadAnalysis HoareBackendError w m+ , MonadFail m ) => D a -> F.Expression (F.Analysis ann) -> m (FortranExpr a) tryTranslateExpr d e = doTranslate (failAnalysis' e) (translateExpression' d) e@@ -728,6 +735,7 @@ :: ( ReportAnn (F.Analysis ann) , MonadReader CheckHoareEnv m , MonadAnalysis HoareBackendError w m+ , MonadFail m ) => D a -> F.Expression (F.Analysis ann) -> m (MetaExpr FortranVar a) tryTranslateCoerceExpr d e =@@ -738,6 +746,7 @@ :: ( ReportAnn (F.Analysis ann) , MonadReader CheckHoareEnv m , MonadAnalysis HoareBackendError w m+ , MonadFail m ) => TypeInfo (F.Analysis ann) -> m SomeType tryTranslateTypeInfo ti = doTranslate (failAnalysis' ti) translateTypeInfo ti@@ -746,6 +755,7 @@ :: ( ReportAnn (F.Analysis ann) , MonadReader CheckHoareEnv m , MonadAnalysis HoareBackendError w m+ , MonadFail m ) => F.Expression (F.Analysis ann) -> m (MetaExpr FortranVar Bool) tryTranslateBoolExpr e = doTranslate (failAnalysis' e) translateBoolExpression e@@ -756,6 +766,7 @@ , Data ann , MonadReader CheckHoareEnv m , MonadAnalysis HoareBackendError w m+ , MonadFail m ) => o -> PrimFormula (F.Analysis ann) -> m (MetaFormula Bool) tryTranslateFormula loc formula = do@@ -774,7 +785,7 @@ -- Utility functions -------------------------------------------------------------------------------- -dropWhileM :: (Monad m) => (a -> m Bool) -> [a] -> m [a]+dropWhileM :: (Monad m, MonadFail m) => (a -> m Bool) -> [a] -> m [a] dropWhileM _ [] = return [] dropWhileM f (x : xs) = do continue <- f x@@ -783,7 +794,7 @@ else return (x : xs) -fromMaybeM :: (Monad m) => m a -> Maybe a -> m a+fromMaybeM :: (Monad m, MonadFail m) => m a -> Maybe a -> m a fromMaybeM e = maybe e return
src/Camfort/Specification/Hoare/CheckFrontend.hs view
@@ -27,7 +27,7 @@ import Control.Applicative (liftA2) import Control.Exception import Control.Lens-import Control.Monad.Writer.Strict hiding (Product)+import Control.Monad.Writer.CPS hiding (Product) import Data.Generics.Uniplate.Operations import Data.Map (Map) import qualified Data.Map as Map
src/Camfort/Specification/Hoare/Translate.hs view
@@ -35,6 +35,7 @@ import Control.Lens import Control.Monad.Except (MonadError (..))+import Control.Monad.Fail import qualified Language.Fortran.Analysis as F import qualified Language.Fortran.AST as F@@ -65,7 +66,7 @@ -------------------------------------------------------------------------------- -- | Translate an untyped logical formula into a strongly typed 'MetaFormula'.-translateFormula :: (Monad m) => PrimFormula (F.Analysis ann) -> TranslateT m (MetaFormula Bool)+translateFormula :: (Monad m, MonadFail m) => PrimFormula (F.Analysis ann) -> TranslateT m (MetaFormula Bool) translateFormula = \case PFExpr e -> do e' <- translateBoolExpression e@@ -76,7 +77,7 @@ -- | Translate a boolean-valued untyped Fortran expression into a strongly typed 'MetaExpr'. translateBoolExpression- :: (Monad m)+ :: (Monad m, MonadFail m) => F.Expression (F.Analysis ann) -> TranslateT m (MetaExpr FortranVar Bool) translateBoolExpression e = do
src/Camfort/Specification/Stencils.hs view
@@ -35,12 +35,13 @@ import qualified Language.Fortran.Util.ModFile as MF import qualified Language.Fortran.Analysis.Renaming as FAR import qualified Language.Fortran.Analysis.BBlocks as FAB+import qualified Language.Fortran.Analysis.DataFlow as FAD import Data.List -- | Helper for retrieving analysed blocks.-getBlocks = FAB.analyseBBlocks . FAR.analyseRenames . FA.initAnalysis . fmap SA.mkStencilAnnotation+getBlocks = FAD.analyseConstExps . FAB.analyseBBlocks . FAR.analyseRenames . FA.initAnalysis . fmap SA.mkStencilAnnotation -------------------------------------------------- -- Stencil specification inference --
src/Camfort/Specification/Stencils/CheckFrontend.hs view
@@ -32,7 +32,7 @@ import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Reader (MonadReader, ReaderT, asks, runReaderT) import Control.Monad.State.Strict-import Control.Monad.Writer.Strict hiding (Product)+import Control.Monad.Writer.CPS hiding (Product) import Data.Function (on) import Data.Generics.Uniplate.Operations import Data.List (intercalate, sort, union)@@ -184,7 +184,7 @@ unusedRegion srcSpan var = SCWarn $ UnusedRegion srcSpan var specOkay :: FU.SrcSpan -> Specification -> Variable -> FU.SrcSpan -> StencilResult-specOkay spanSpec@(FU.SrcSpan (FU.Position o1 _ _) (FU.Position o2 _ _)) spec var spanBody@(FU.SrcSpan (FU.Position o1' _ _) (FU.Position o2' _ _)) =+specOkay spanSpec@(FU.SrcSpan (FU.Position o1 _ _ _ _) (FU.Position o2 _ _ _ _)) spec var spanBody@(FU.SrcSpan (FU.Position o1' _ _ _ _) (FU.Position o2' _ _ _ _)) = SCOkay { scSpan = spanSpec , scSpec = spec , scBodySpan = spanBody@@ -252,7 +252,7 @@ -- create graph of definition "flows" flowsGraph = FAD.genFlowsToGraph bm dm gr rd -- identify every loop by its back-edge- beMap = FAD.genBackEdgeMap (FAD.dominators gr) gr+ beMap = FAD.genBackEdgeMap (FAD.dominators gr) $ FA.bbgrGr gr ivmap = FAD.genInductionVarMapByASTBlock beMap gr -- results :: Checker (F.ProgramFile (F.ProgramFile (FA.Analysis A))) results = descendBiM perProgramUnitCheck pf'@@ -288,7 +288,7 @@ -- | Start tracking a region. addRegionToTracked :: FU.SrcSpan -> Variable -> Checker ()-addRegionToTracked srcSpan@(FU.SrcSpan (FU.Position o1 _ _) (FU.Position o2 _ _)) r =+addRegionToTracked srcSpan@(FU.SrcSpan (FU.Position o1 _ _ _ _) (FU.Position o2 _ _ _ _)) r = modify (\s -> s { regions = (srcSpan, r) : regions s }) -- | True if the region name is already tracked.
src/Camfort/Specification/Stencils/Generate.hs view
@@ -17,11 +17,9 @@ ( EvalLog , Neighbour(..)- , convIxToNeighbour , extractRelevantIVS , genOffsets , genSpecifications- , indicesToSpec , isArraySubscript , neighbourIndex , runStencilInferer@@ -37,7 +35,7 @@ import Control.Monad (void, when, zipWithM) import Control.Monad.State.Strict (State, get, put, runState)-import Control.Monad.Writer.Strict (WriterT, runWriterT, tell)+import Control.Monad.Writer.CPS (WriterT, runWriterT, tell) import Control.Monad.Reader (ReaderT, runReaderT, asks) import Data.Data (Data) import Data.Foldable (foldrM)@@ -310,15 +308,37 @@ expToNeighbour _ (F.ExpValue _ _ val) = Constant (void val) +-- use constant-expression analysis if available expToNeighbour ivs (F.ExpBinary _ _ F.Addition+ e1@(F.ExpValue _ _ (F.ValVariable _))+ e2)+ | FA.varName e1 `elem` ivs+ , Just (FAD.ConstInt offs) <- FA.constExp (F.getAnnotation e2) = Neighbour (FA.varName e1) (fromIntegral offs)++expToNeighbour ivs (F.ExpBinary _ _ F.Addition e@(F.ExpValue _ _ (F.ValVariable _)) (F.ExpValue _ _ (F.ValInteger offs))) | FA.varName e `elem` ivs = Neighbour (FA.varName e) (read offs) +-- use constant-expression analysis if available expToNeighbour ivs (F.ExpBinary _ _ F.Addition+ e1@(F.ExpValue _ _ (F.ValVariable _))+ e2)+ | FA.varName e1 `elem` ivs+ , Just (FAD.ConstInt offs) <- FA.constExp (F.getAnnotation e2) = Neighbour (FA.varName e1) (fromIntegral offs)++expToNeighbour ivs (F.ExpBinary _ _ F.Addition (F.ExpValue _ _ (F.ValInteger offs)) e@(F.ExpValue _ _ (F.ValVariable _))) | FA.varName e `elem` ivs = Neighbour (FA.varName e) (read offs)++-- use constant-expression analysis if available+expToNeighbour ivs (F.ExpBinary _ _ F.Subtraction+ e1@(F.ExpValue _ _ (F.ValVariable _))+ e2)+ | FA.varName e1 `elem` ivs+ , Just (FAD.ConstInt offs) <- FA.constExp (F.getAnnotation e2)+ , offs' <- if offs < 0 then abs offs else (- offs) = Neighbour (FA.varName e1) (fromIntegral offs') expToNeighbour ivs (F.ExpBinary _ _ F.Subtraction e@(F.ExpValue _ _ (F.ValVariable _))
src/Camfort/Specification/Stencils/InferenceFrontend.hs view
@@ -29,8 +29,8 @@ , StencilsReport(..) ) where -import Control.Monad.RWS.Strict-import Control.Monad.Writer.Strict+import Control.Monad.RWS.CPS+import Control.Monad.Writer.CPS import Camfort.Analysis import Camfort.Analysis.Annotations@@ -209,7 +209,7 @@ flTo = FAD.genFlowsToGraph bm dm gr rd -- induction variable map- beMap = FAD.genBackEdgeMap (FAD.dominators gr) gr+ beMap = FAD.genBackEdgeMap (FAD.dominators gr) $ FA.bbgrGr gr -- identify every loop by its back-edge ivMap = FAD.genInductionVarMapByASTBlock beMap gr
src/Camfort/Specification/Stencils/Model.hs view
@@ -61,7 +61,7 @@ import Data.Data import Data.List (sortBy, nub) import Data.Maybe (fromJust)-import qualified Data.PartialOrd as PO+import qualified Camfort.Specification.Stencils.PartialOrd as PO import qualified Camfort.Helpers.Vec as V import System.IO.Unsafe
+ src/Camfort/Specification/Stencils/PartialOrd.hs view
@@ -0,0 +1,136 @@+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NoImplicitPrelude #-}++{-|+Module : Data.PartialOrd+Description : Provides the PartialOrd Typeclass.+Copyright : (c) 2016 Moritz Schulte+License : BSD3+Maintainer : mtesseract@silverratio.net+Stability : experimental+Portability : POSIX++This module provides the `PartialOrd' typeclass suitable for types+admitting a partial order.++Along with the `PartialOrd' typeclass and some utility functions for+working with partially ordered types, it exports implementations for+the numeric types several numeric types, lists and sets.+-}++-- Code imported into camfort to avoid build-dependency hell with+-- unmaintained upstream package.++module Camfort.Specification.Stencils.PartialOrd+ ( PartialOrd(..)+ , maxima, minima+ , elem, notElem+ , nub ) where++import Data.Bool+import Data.Maybe+import Prelude (Int, Integer, Float, Double, ($), Integral)+import qualified Data.Ord as Ord+import qualified Data.Eq as Eq+import qualified Data.List as List+import qualified Data.Set as Set+import qualified Data.Foldable as Foldable++class PartialOrd a where++ -- | Less-than-or-equal relation.+ (<=) :: a -> a -> Bool++ -- | Bigger-than-or-equal relation. Defined in terms of `<='.+ (>=) :: a -> a -> Bool+ a >= a' = a' <= a++ -- | Equality relation. Defined in terms of `<='.+ (==) :: a -> a -> Bool+ a == a' = a <= a' && a' <= a++ -- | Inequality relation. Defined in terms of `=='.+ (/=) :: a -> a -> Bool+ a /= a' = not (a == a')++ -- | Less-than relation relation. Defined in terms of `<=' and `/='.+ (<) :: a -> a -> Bool+ a < a' = a <= a' && (a /= a')++ -- | Bigger-than relation. Defined in terms of `<=` and `/='.+ (>) :: a -> a -> Bool+ a > a' = a' <= a && (a /= a')++ -- | Compare function, returning either `Just' an `Ordering' or+ -- `Nothing'.+ compare :: a -> a -> Maybe Ord.Ordering+ compare a a' = if | a == a' -> Just Ord.EQ+ | a <= a' -> Just Ord.LT+ | a >= a' -> Just Ord.GT+ | otherwise -> Nothing++ {-# MINIMAL (<=) #-}++-- | Derive the partial order from the total order for the following+-- types:+instance PartialOrd Int where+ (<=) = (Ord.<=)++instance PartialOrd Integer where+ (<=) = (Ord.<=)++instance PartialOrd Double where+ (<=) = (Ord.<=)++instance PartialOrd Float where+ (<=) = (Ord.<=)++-- | Define the partial order in terms of the subset relation.+instance (Ord.Ord a) => PartialOrd (Set.Set a) where+ (<=) = Set.isSubsetOf++-- | Define the partial order in terms of the sublist relation.+instance PartialOrd a => PartialOrd [a] where+ (<=) = isSublistOf++-- | Return True if the first list is a sublist of the second list.+isSublistOf :: PartialOrd a => [a] -> [a] -> Bool+isSublistOf [] _ = True+isSublistOf (a:as) a' = a `elem` a' && as `isSublistOf` a'++-- | Compute the list of all elements that are not less than any other+-- element in the list.+maxima :: PartialOrd a => [a] -> [a]+maxima as = nub $ extrema (<=) as++-- | Compute the list of all elements that are not bigger than any+-- other element in the list.+minima :: PartialOrd a => [a] -> [a]+minima as = nub $ extrema (>=) as++extrema :: PartialOrd a => (a -> a -> Bool) -> [a] -> [a]+extrema f as = List.filter isExtremal as+ where isExtremal a =+ -- Return true if there exists no a' in as \ {a} such that+ -- a `f` a'.+ let as' = List.filter (/= a) as+ in not (Foldable.any (a `f`) as')++-- | Version of the traditional elem function using the PartialOrd+-- notion of equality.+elem :: (PartialOrd a, Foldable.Foldable t) => a -> t a -> Bool+elem x xs = Foldable.any (x ==) xs++-- | Version of the traditional notElem function using the PartialOrd+-- notion of equality.+notElem :: (PartialOrd a, Foldable.Foldable t) => a -> t a -> Bool+notElem x xs = not $ elem x xs++-- | Version of the traditional nub function using the PartialOrd+-- notion of equality.+nub :: PartialOrd a => [a] -> [a]+nub as = List.reverse $ Foldable.foldl' collect [] as+ where collect uniques a =+ if a `elem` uniques+ then uniques+ else a : uniques
src/Camfort/Specification/Stencils/Synthesis.hs view
@@ -74,7 +74,7 @@ ------------------------ a = (head $ FA.initAnalysis [unitAnnotation]) { FA.insLabel = Just 0 }-s = SrcSpan (Position 0 0 0) (Position 0 0 0)+s = SrcSpan (Position 0 0 0 "" Nothing) (Position 0 0 0 "" Nothing) -- Make indexing expression for variable 'v' from an offset. -- essentially inverse to `ixToOffset` in StencilSpecification
src/Camfort/Specification/Units/Analysis.hs view
@@ -23,7 +23,7 @@ import Control.Monad import Control.Monad.State.Strict-import Control.Monad.Writer.Strict+import Control.Monad.Writer.CPS import Control.Monad.Reader import Data.Data (Data) import qualified Data.IntMap.Strict as IM@@ -31,16 +31,17 @@ import Data.List (nub, intercalate) import qualified Data.Array as A import qualified Data.Map.Strict as M-import Data.Maybe (isJust, fromMaybe)+import Data.Maybe (isJust, fromMaybe, mapMaybe) import qualified Data.Set as S import qualified Numeric.LinearAlgebra as H -- for debugging import Data.Text (Text) import Control.Lens ((^?), _1)-import qualified Debug.Trace as D import qualified Language.Fortran.AST as F import qualified Language.Fortran.Analysis as FA-import Language.Fortran.Analysis (varName, srcName)+import qualified Language.Fortran.Analysis.DataFlow as FAD+import qualified Language.Fortran.Analysis.BBlocks as FAB+import Language.Fortran.Analysis (constExp, varName, srcName) import Language.Fortran.Parser.Utils (readReal, readInteger) import Language.Fortran.Util.ModFile import Language.Fortran.Util.Position (getSpan)@@ -133,8 +134,9 @@ mfs <- lift analysisModFiles let (pf', _, _) = withCombinedEnvironment mfs . fmap UA.mkUnitAnnotation $ pf-- runUnitSolver pf' $ do+ let pvm = combinedParamVarMap mfs+ let pf'' = FAD.analyseConstExps . FAD.analyseParameterVars pvm . FAB.analyseBBlocks $ pf'+ runUnitSolver pf'' $ do initializeModFiles initInference solver@@ -183,7 +185,9 @@ -- Specifically handle variables insertUndeterminedUnitVar :: DeclMap -> F.Expression UA -> UnitSolver (F.Expression UA)-insertUndeterminedUnitVar dmap v@(F.ExpValue _ _ (F.ValVariable _)) = do+insertUndeterminedUnitVar dmap v@(F.ExpValue _ _ (F.ValVariable _))+ | Just (FA.IDType { FA.idVType = Just bty }) <- FA.idType (F.getAnnotation v)+ , bty `elem` acceptableTypes = do let vname = varName v let sname = srcName v let unit = toUnitVar dmap (vname, sname)@@ -200,6 +204,10 @@ Just (DCSubroutine (F.Named fvname, F.Named fsname)) -> UnitParamVarAbs ((fvname, fsname), (vname, sname)) _ -> UnitVar (vname, sname) +-- Insert undetermined units annotations on the following types of variables.+acceptableTypes :: [F.BaseType]+acceptableTypes = [F.TypeReal, F.TypeDoublePrecision, F.TypeComplex, F.TypeDoubleComplex, F.TypeInteger]+ -------------------------------------------------- -- | Convert explicit polymorphic annotations such as (UnitName "'a")@@ -286,8 +294,11 @@ annotateAllVariables :: UnitSolver () annotateAllVariables = modifyProgramFileM $ \ pf -> do varUnitMap <- getVarUnitMap+ importedVariables <- getImportedVariables+ let varUnitMap' = M.unionWith (curry snd) varUnitMap importedVariables+ let annotateExp e@(F.ExpValue _ _ (F.ValVariable _))- | Just info <- M.lookup (varName e, srcName e) varUnitMap = UA.setUnitInfo info e+ | Just info <- M.lookup (varName e, srcName e) varUnitMap' = UA.setUnitInfo info e -- may need to annotate intrinsics separately annotateExp e = e pure $ transformBi annotateExp pf@@ -314,13 +325,33 @@ -- Follow the LitMixed rules. expMixed e = case e of F.ExpValue _ _ (F.ValInteger i) | readInteger i == Just 0 -> withLiterals genParamLit e- | isPolyCtxt -> expUnitless e | otherwise -> withLiterals genUnitLiteral e F.ExpValue _ _ (F.ValReal i) | readReal i == Just 0 -> withLiterals genParamLit e- | isPolyCtxt -> expUnitless e | otherwise -> withLiterals genUnitLiteral e- _ -> pure e + F.ExpBinary a s op e1 e2+ | op `elem` [F.Multiplication, F.Division] -> case () of+ -- leave it alone if they're both constants+ _ | Just c1 <- constExp (F.getAnnotation e1)+ , Just c2 <- constExp (F.getAnnotation e2) -> pure e+ -- a constant multiplier is unitless+ _ | Just c1 <- constExp (F.getAnnotation e1)+ , Just UnitLiteral{} <- UA.getUnitInfo e1 ->+ pure $ F.ExpBinary a s op (UA.setUnitInfo UnitlessLit e1) e2+ -- a constant multiplier is unitless+ | Just c2 <- constExp (F.getAnnotation e2)+ , Just UnitLiteral{} <- UA.getUnitInfo e2 ->+ pure $ F.ExpBinary a s op e1 (UA.setUnitInfo UnitlessLit e2)+ _ -> pure e++ _ | Just _ <- constExp (F.getAnnotation e) -> case UA.getUnitInfo e of+ -- Treat constant expressions as if they were fresh+ -- literals, unless assigned units already.+ Just UnitLiteral{} -> genLit e+ Just UnitVar{} -> genLit e+ _ -> pure e+ | otherwise -> pure e+ -- Set all literals to unitless. expUnitless e | isLiteral e = pure $ UA.setUnitInfo UnitlessLit e@@ -333,22 +364,40 @@ isPolyCtxt = case pu of F.PUFunction {} -> True; F.PUSubroutine {} -> True; _ -> False + genLit e+ | isLiteralZero e = withLiterals genParamLit e+ | otherwise = withLiterals genUnitLiteral e+ -- | Is it a literal, literally? isLiteral :: F.Expression UA -> Bool isLiteral (F.ExpValue _ _ (F.ValReal _)) = True isLiteral (F.ExpValue _ _ (F.ValInteger _)) = True-isLiteral _ = False+-- allow propagated constants to be interpreted as literals+isLiteral e = isJust (constExp (F.getAnnotation e)) --- | Is expression a literal and is it zero?+-- | Is expression a literal and is it non-zero? isLiteralNonZero :: F.Expression UA -> Bool isLiteralNonZero (F.ExpValue _ _ (F.ValInteger i)) = readInteger i /= Just 0 isLiteralNonZero (F.ExpValue _ _ (F.ValReal i)) = readReal i /= Just 0-isLiteralNonZero _ = False+-- allow propagated constants to be interpreted as literals+isLiteralNonZero e = case constExp (F.getAnnotation e) of+ Just (FA.ConstInt i) -> i /= 0+ Just (FA.ConstUninterpInt s) -> readInteger s /= Just 0+ Just (FA.ConstUninterpReal s) -> readReal s /= Just 0+ _ -> False -isLiteralZero = not . isLiteralNonZero+isLiteralZero x = isLiteral x && not (isLiteralNonZero x) -------------------------------------------------- +-- | Filter out redundant constraints.+cullRedundant :: Constraints -> Constraints+cullRedundant = nub . mapMaybe ( \ con -> case con of+ ConEq u1 u2 | u1 /= u2 -> Just con+ ConConj cs | cs' <- cullRedundant cs, not (null cs) -> Just (ConConj cs')+ _ -> Nothing+ )+ -- | Convert all parametric templates into actual uses, via substitution. applyTemplates :: Constraints -> UnitSolver Constraints -- postcondition: returned constraints lack all Parametric constructors@@ -369,9 +418,15 @@ logDebug' pf $ ("instances: " <> describeShow instances) logDebug' pf $ ("dummies: " <> describeShow dummies) + importedVariables <- getImportedVariables++ -- Prepare constraints for all variables imported via StUse.+ let importedCons = [ ConEq (UnitVar vv) units | (vv, units) <- M.toList importedVariables ]+ -- Work through the instances, expanding their templates, and -- substituting the callId into the abstract parameters.- concreteCons <- liftM2 (++) (foldM (substInstance False []) [] instances)+ concreteCons <- cullRedundant <$>+ liftM2 (++) (foldM (substInstance False []) importedCons instances) (foldM (substInstance True []) [] dummies) dumpConsM "applyTemplates: concreteCons" concreteCons @@ -384,7 +439,7 @@ transAlias u = u dumpConsM "aliases" aliases- pure . transformBi transAlias $ cons ++ concreteCons ++ aliases+ pure . transformBi transAlias . cullRedundant $ cons ++ concreteCons ++ aliases -- | Look up the Parametric templates for a given function or -- subroutine, and do the substitutions. Process any additional@@ -424,11 +479,6 @@ dumpConsM ("instantiating " ++ show (name, callId) ++ ": (output ++ template) is") (output ++ template) dumpConsM ("instantiating " ++ show (name, callId) ++ ": (template') is") template' - -- Get constraints for any imported variables- let filterForVars (NPKVariable _) _ = True; filterForVars _ _ = False- nmap <- M.filterWithKey filterForVars <$> getNameParamMap- let importedVariables = [ ConEq (UnitVar vv) (foldUnits units) | (NPKVariable vv, units) <- M.toList nmap ]- -- Convert abstract parametric units into concrete ones. let output' = -- Do not instantiate explicitly annotated polymorphic@@ -438,10 +488,7 @@ -- Only instantiate explicitly annotated polymorphic -- variables from nested function/subroutine calls.- instantiate callId template' ++-- -- any imported variables- importedVariables+ instantiate callId template' dumpConsM ("final output for " ++ show (name, callId)) output' @@ -527,7 +574,8 @@ -- that variables have all been annotated. propagateUnits :: UnitSolver () -- precondition: all variables have already been annotated-propagateUnits = modifyProgramFileM $ transformBiM propagatePU <=<+propagateUnits = modifyProgramFileM $ transformBiM propagateInterface <=<+ transformBiM propagatePU <=< transformBiM propagateDoSpec <=< transformBiM propagateStatement <=< transformBiM propagateExp@@ -543,6 +591,7 @@ F.ExpFunctionCall {} -> propagateFunctionCall e F.ExpSubscript _ _ e1 _ -> pure $ UA.maybeSetUnitInfo (UA.getUnitInfo e1) e F.ExpUnary _ _ _ e1 -> pure $ UA.maybeSetUnitInfo (UA.getUnitInfo e1) e+ F.ExpInitialisation{} -> pure e _ -> do logDebug' e $ "progagateExp: unhandled " <> describeShow e pure e@@ -576,6 +625,11 @@ , do u1 <- UA.getUnitInfo e1 u3 <- (UA.getUnitInfo =<< m_e3) `mplus` if isMonomorphic u1 then mzero else pure UnitlessVar pure [ConEq u1 u3]++ -- units(e2) ~ units(e3) or if e3 not specified then units(e2) ~ 1 in a polymorphic context+ , do u2 <- UA.getUnitInfo e1+ u3 <- (UA.getUnitInfo =<< m_e3) `mplus` if isMonomorphic u2 then mzero else pure UnitlessVar+ pure [ConEq u2 u3] ] propagateStatement :: F.Statement UA -> UnitSolver (F.Statement UA)@@ -600,13 +654,30 @@ => F.Expression UA -> F.Expression UA -> f UA -> UnitSolver (f UA) literalAssignmentSpecialCase e1 e2 ast+ | isLiteralZero e2 = pure ast | isLiteral e2- , Just u1 <- UA.getUnitInfo e1- , Just u2 <- UA.getUnitInfo e2- , isMonomorphic u1 || isLiteralZero e2 = pure ast+ , Just u1 <- UA.getUnitInfo e1+ , Just UnitLiteral{} <- UA.getUnitInfo e2+ , isMonomorphic u1 = pure ast -- otherwise express the constraint between LHS and RHS of assignment. | otherwise = pure $ UA.maybeSetUnitConstraintF2 ConEq (UA.getUnitInfo e1) (UA.getUnitInfo e2) ast +-- Generic Interface template mapping will be same as first module procedure.+propagateInterface :: F.Block UA -> UnitSolver (F.Block UA)+propagateInterface b@(F.BlInterface _ _ (Just e) _ _ bs) = do+ let iname = varName e+ case [ varName e1 | F.StModuleProcedure _ _ (F.AList _ _ (e1:_)) <- universeBi bs :: [F.Statement UA] ] of+ mpname:_ -> do+ -- translate any instance of mpname into iname within the template+ let trans = transformBi (\ x -> if x == mpname then iname else x)+ -- copy (translated) template from first module procedure to interface+ modifyTemplateMap $ \ m -> fromMaybe m ((\ t -> M.insert iname (trans t) m) <$> M.lookup mpname m)+ _ ->+ pure ()+ pure b++propagateInterface b = pure b+ propagatePU :: F.ProgramUnit UA -> UnitSolver (F.ProgramUnit UA) propagatePU pu = do let name = puName pu@@ -768,6 +839,31 @@ binOpKind F.NotEquivalent = RelOp binOpKind (F.BinCustom _) = RelOp +-- | Get information about imported variables coming from mod files.+getImportedVariables :: UnitSolver (M.Map VV UnitInfo)+getImportedVariables = do+ pf <- getProgramFile+ nmap <- getNameParamMap+ -- Translate a Use AST node into a pair mapping unique name to 'local' source name in this program file.+ let useToPair (F.UseID _ _ e) = (varName e, srcName e)+ useToPair (F.UseRename _ _ e1 e2) = (varName e1, srcName e1) -- (unique name, 'local' source name)+ -- A map of modules -> (maps of variables -> their unit info).+ let modnmaps = [ M.fromList (mapMaybe f (M.toList npkmap))+ -- find all StUse statements and identify variables that need to be imported from nmap+ | F.StUse _ _ e _ only alist <- universeBi pf :: [ F.Statement UA ]+ , let mod = srcName e+ , let uses = map useToPair (fromMaybe [] (F.aStrip <$> alist))+ , Just npkmap <- [M.lookup (F.Named mod) nmap]+ , let f (npk, ui) = case npk of+ (NPKVariable (var, src))+ -- import all variables from module -- apply any renames from uses+ | only == F.Permissive -> Just (NPKVariable (var, src `fromMaybe` lookup var uses), ui)+ -- only import variable mentioned in uses+ | Just src' <- lookup var uses -> Just (NPKVariable (var, src'), ui)+ _ -> Nothing+ ]+ pure $ M.fromList [ (vv, foldUnits units) | (NPKVariable vv, units) <- M.toList (M.unions modnmaps) ]+ -------------------------------------------------- logDebugNoOrigin :: Text -> UnitSolver ()@@ -838,7 +934,10 @@ logDebugNoOrigin "--------------------------------------------------" let unitAssignments = BackendSBV.genUnitAssignments cons logDebugNoOrigin . describe . unlines $ map (\ (u1s, u2) -> " ***UnitAssignmentSBV: " ++ show u1s ++ " === " ++ show (flattenUnits u2)) unitAssignments- logDebugNoOrigin "--------------------------------------------------"+ logDebugNoOrigin "--------------------------------------------------\nProvenance:"+ let (augM', p) = provenance augM+ logDebugNoOrigin . describeShow $ augM'+ logDebugNoOrigin . describeShow $ p --------------------------------------------------
src/Camfort/Specification/Units/Analysis/Consistent.hs view
@@ -30,7 +30,7 @@ import Camfort.Specification.Units.Analysis (UnitAnalysis, runInference) import qualified Camfort.Specification.Units.Annotation as UA import Camfort.Specification.Units.Environment-import Camfort.Specification.Units.InferenceBackendSBV (inconsistentConstraints)+import Camfort.Specification.Units.InferenceBackend (inconsistentConstraints) import qualified Camfort.Specification.Units.InferenceBackend as MatrixBackend import Camfort.Specification.Units.Monad import Camfort.Specification.Units.MonadTypes
src/Camfort/Specification/Units/Analysis/Infer.hs view
@@ -12,7 +12,7 @@ {-# LANGUAGE DeriveGeneric #-} module Camfort.Specification.Units.Analysis.Infer- ( InferenceReport+ ( InferenceReport(..) , InferenceResult(..) , getInferred , inferUnits
src/Camfort/Specification/Units/Environment.hs view
@@ -49,6 +49,8 @@ import GHC.Generics (Generic) import Text.Printf import Control.Arrow (first, second)+import Text.PrettyPrint.GenericPretty (pp, pretty, Out, doc, docPrec)+import Text.PrettyPrint (text) import qualified Language.Fortran.AST as F import qualified Camfort.Specification.Units.Parser.Types as P@@ -196,6 +198,10 @@ | otherwise = "(" ++ s ++ ")" where s = show x isUnitMulOk c = isSpace c || isAlphaNum c || c `elem` "*."++instance Out UnitInfo where+ doc = text . show+ docPrec _ = text . show -- Converts doubles to a rational that can be expressed -- as a rational with denominator at most 10
src/Camfort/Specification/Units/InferenceBackend.hs view
@@ -35,23 +35,29 @@ , rref , genUnitAssignments , genUnitAssignments'+ , provenance+ , splitNormHNF ) where- import Prelude hiding ((<>))+import Control.Arrow (first, second, (***)) import Control.Monad import Control.Monad.ST+import Control.Parallel+import Control.Parallel.Strategies import qualified Data.Array as A import Data.Generics.Uniplate.Operations (transformBi, universeBi) import Data.List- ((\\), findIndex, inits, nub, partition, sortBy, group, tails)+ ((\\), findIndex, inits, nub, partition, sort, sortBy, group, tails, foldl') import Data.Ord import qualified Data.Map.Strict as M+import qualified Data.IntMap as IM+import qualified Data.IntSet as IS import Data.Maybe (fromMaybe, mapMaybe) import Data.Tuple (swap) import Numeric.LinearAlgebra ( atIndex, (<>), (><)- , rank, (?)+ , rank, (?), (¿) , rows, cols , subMatrix, diag , fromBlocks, ident@@ -62,6 +68,7 @@ , writeMatrix, runSTMatrix , freezeMatrix, STMatrix )+import Data.Graph.Inductive hiding ((><)) import Camfort.Specification.Units.Environment import qualified Camfort.Specification.Units.InferenceBackendFlint as Flint@@ -77,24 +84,79 @@ [ (var, units) | ([UnitPow (UnitVar var) k], units) <- unitAssignments, k `approxEq` 1 ] ++ [ (var, units) | ([UnitPow (UnitParamVarAbs (_, var)) k], units) <- unitAssignments, k `approxEq` 1 ] --- detect inconsistency if concrete units are assigned an implicit--- abstract unit variable with coefficients not equal-detectInconsistency :: [([UnitInfo], UnitInfo)] -> [([UnitInfo], UnitInfo)]-detectInconsistency unitAssignments = [ fmap foldUnits a | a@([UnitPow (UnitParamImpAbs _) k1], rhs) <- ua'- , UnitPow _ k2 <- rhs- , k1 /= k2 ]+-- Detect inconsistency if concrete units are assigned an implicit+-- abstract unit variable with coefficients not equal, or there are+-- monomorphic literals being given parametric polymorphic units.+detectInconsistency :: [([UnitInfo], UnitInfo)] -> Constraints+detectInconsistency unitAssignments = inconsist where ua' = map (shiftTerms . fmap flattenUnits) unitAssignments+ badImplicits = [ fmap foldUnits a | a@([UnitPow (UnitParamImpAbs _) k1], rhs) <- ua'+ , UnitPow _ k2 <- rhs+ , k1 /= k2 ]+ inconsist = unitAssignmentsToConstraints badImplicits ++ mustBeUnitless unitAssignments +-- Must be unitless: any assignments of parametric abstract units to+-- monomorphic literals.+mustBeUnitless :: [([UnitInfo], UnitInfo)] -> Constraints+mustBeUnitless unitAssignments = mbu+ where+ mbu = [ ConEq UnitlessLit (UnitPow (UnitLiteral l) k)+ | a@(UnitPow (UnitLiteral l) k:_, rhs) <- ua''+ , any isParametric (universeBi rhs :: [UnitInfo]) ]+ ua' = map (shiftTerms . fmap flattenUnits) unitAssignments+ ua'' = map (shiftTermsBy isLiteral . fmap flattenUnits) unitAssignments++ isLiteral UnitLiteral{} = True+ isLiteral (UnitPow UnitLiteral{} _) = True+ isLiteral _ = False++ isParametric UnitParamVarAbs{} = True+ isParametric UnitParamPosAbs{} = True+ isParametric UnitParamEAPAbs{} = True+ isParametric UnitParamLitAbs{} = True+ isParametric UnitParamImpAbs{} = True+ isParametric (UnitPow u _) = isParametric u+ isParametric _ = False+++-- convert the assignment format back into constraints+unitAssignmentsToConstraints :: [([UnitInfo], UnitInfo)] -> Constraints+unitAssignmentsToConstraints = map (uncurry ConEq . first foldUnits)+ -- | Raw units-assignment pairs.-genUnitAssignments :: [Constraint] -> [([UnitInfo], UnitInfo)]+genUnitAssignments :: Constraints -> [([UnitInfo], UnitInfo)] genUnitAssignments cons- | null (detectInconsistency ua) = ua- | otherwise = []+ -- if the results include any mappings that must be forced to be unitless...+ | mbu <- mustBeUnitless ua, not (null mbu) = genUnitAssignments (mbu ++ unitAssignmentsToConstraints ua)+ | null (detectInconsistency ua) = ua+ | otherwise = [] where ua = genUnitAssignments' colSort cons -genUnitAssignments' :: SortFn -> [Constraint] -> [([UnitInfo], UnitInfo)]+-- | Break up the problem of solving normHNF on each group of related+-- columns, then bring it all back together.+splitNormHNF :: H.Matrix Double -> (H.Matrix Double, [Int])+splitNormHNF unsolvedM = (combinedMat, allNewColIndices)+ where+ combinedMat = joinMat (map (first fst) solvedMs)+ allNewColIndices = concatMap (snd . fst) solvedMs++ inParallel = (`using` parTuple2 (parList rseq) rseq)+ (solvedMs, _) = inParallel . foldl' eachResult ([], cols unsolvedM) $ map (first Flint.normHNF) (splitMat unsolvedM)++ -- for each result re-number the generated columns & add mappings for each.+ eachResult (ms, startI) ((m, newColIndices), origCols) = (((m, newColIndices'), origCols'):ms, endI)+ where+ -- produce (length newColIndices) number of mappings+ endI = startI + length newColIndices+ -- re-number the newColIndices according to the lookup list+ newColIndices' = map (origCols !!) newColIndices+ -- add columns in the (combined) matrix for the newly+ -- generated columns from running normHNF on m.+ origCols' = origCols ++ [startI .. endI-1]++genUnitAssignments' :: SortFn -> Constraints -> [([UnitInfo], UnitInfo)] genUnitAssignments' _ [] = [] genUnitAssignments' sortfn cons | null colList = []@@ -105,8 +167,7 @@ unsolvedM | rows rhsM == 0 || cols rhsM == 0 = lhsM | rows lhsM == 0 || cols lhsM == 0 = rhsM | otherwise = fromBlocks [[lhsM, rhsM]]-- (solvedM, newColIndices) = Flint.normHNF unsolvedM+ (solvedM, newColIndices) = splitNormHNF unsolvedM -- solvedM can have additional columns and rows from normHNF; -- cosolvedM corresponds to the original lhsM. cosolvedM = subMatrix (0, 0) (rows solvedM, cols lhsM) solvedM@@ -148,10 +209,109 @@ -------------------------------------------------- approxEq a b = abs (b - a) < epsilon+notApproxEq a b = not (approxEq a b) epsilon = 0.001 -- arbitrary -------------------------------------------------- +type RowNum = Int -- ^ 'row number' of matrix+type ColNum = Int -- ^ 'column number' of matrix+-- | Represents a subproblem of AX=B where the row numbers and column+-- numbers help you re-map back to the original problem.+type Subproblem = ([RowNum], (H.Matrix Double, H.Matrix Double), [ColNum])++-- | Divide up the AX=B problem into smaller problems based on the+-- 'related columns' and their corresponding rows in the+-- right-hand-side of the equation. Where lhsM = A and rhsM = B. The+-- resulting list of subproblems contains the new, smaller As and Bs+-- as well as a list of original row numbers and column numbers to+-- aide re-mapping back to the original lhsM and rhsM.+splitMatWithRHS :: H.Matrix Double -> H.Matrix Double -> [Subproblem]+splitMatWithRHS lhsM rhsM | cols lhsM > 0 = map (eachComponent . sort) $ scc (relatedColumnsGraph lhsM)+ | otherwise = []+ where+ -- Gets called on every strongly-connected component / related set of columns.+ eachComponent cs = (rs, mats, cs)+ where+ -- Selected columns+ lhsSelCols :: H.Matrix Double+ lhsSelCols = lhsM ¿ cs++ csLen = cols lhsSelCols++ -- Find the row numbers of the 'all zero' rows in lhsM.+ lhsAllZeroRows :: [RowNum]+ lhsAllZeroRows = map fst . filter (all (approxEq 0) . snd) . zip [0..] $ H.toLists lhsM++ -- Find the row numbers that correspond to the non-zero co-efficients in the selected columns.+ lhsNonZeroColRows :: [(RowNum, [Double])]+ lhsNonZeroColRows = filter (any (notApproxEq 0) . snd) . zip [0..] . H.toLists $ lhsSelCols++ -- List of all the row numbers and row values combined from the two above variables.+ lhsNumberedRows :: [(RowNum, [Double])]+ lhsNumberedRows = sortBy (comparing fst) $ lhsNonZeroColRows ++ zip lhsAllZeroRows (repeat (replicate csLen 0))++ -- For each of the above LHS rows find a corresponding RHS row.+ rhsSelRows :: [[Double]]+ rhsSelRows | rows rhsM > 0 = H.toLists (rhsM ? map fst lhsNumberedRows)+ | otherwise = []++ reassoc (a, b) c = (a, (b, c))++ notAllZero (_, (lhs, rhs)) = any (notApproxEq 0) (lhs ++ rhs)++ -- Zip the selected LHS, RHS rows together, filter out any that are all zeroes.+ numberedRows :: ([RowNum], [([Double], [Double])])+ numberedRows = unzip . filter notAllZero $ zipWith reassoc lhsNumberedRows rhsSelRows++ rs :: [RowNum] -- list of row numbers in the subproblem+ mats :: (H.Matrix Double, H.Matrix Double) -- LHS/RHS subproblem matrices+ (rs, mats) = second ((H.fromLists *** H.fromLists) . unzip) numberedRows++-- | Split the lhsM/rhsM problem into subproblems and then look for+-- inconsistent rows in each subproblem, concatenating all of the+-- inconsistent row numbers found (in terms of the rows of the+-- original lhsM).+splitFindInconsistentRows :: H.Matrix Double -> H.Matrix Double -> [RowNum]+splitFindInconsistentRows lhsM rhsM = concatMap eachComponent $ splitMatWithRHS lhsM rhsM+ where+ eachComponent (rs, (lhsM, rhsM), _) = map (rs !!) $ findInconsistentRows lhsM augM+ where+ -- Augmented matrix is defined as the combined LHS/RHS matrices.+ augM+ | rows rhsM == 0 || cols rhsM == 0 = lhsM+ | rows lhsM == 0 || cols lhsM == 0 = rhsM+ | otherwise = fromBlocks [[lhsM, rhsM]]++-- | Break out the 'unrelated' columns in a single matrix into+-- separate matrices, along with a list of their original column+-- positions.+splitMat :: H.Matrix Double -> [(H.Matrix Double, [ColNum])]+splitMat m = map (eachComponent . sort) $ scc (relatedColumnsGraph m)+ where+ eachComponent cs = (H.fromLists . filter (any (/= 0)) . H.toLists $ m ¿ cs, cs)++-- | Bring together the split matrices and put the columns back in+-- their original order. Rows may not be in the same order as the+-- original, but the constraints should be equivalent.+joinMat :: [(H.Matrix Double, [Int])] -> H.Matrix Double+joinMat ms = sortedM+ where+ disorderedM = H.diagBlock (map fst ms)+ colsWithIdx = zip (concatMap snd ms) . H.toColumns $ disorderedM+ sortedM = H.fromColumns . map snd . sortBy (comparing fst) $ colsWithIdx++-- | Turn a matrix into a graph where each node represents a column+-- and each edge represents two columns that have non-zero+-- co-efficients in some row. Basically, 'related columns'. Also+-- includes self-refs for each node..+relatedColumnsGraph :: H.Matrix Double -> Gr () ()+relatedColumnsGraph m = mkGraph (map (,()) ns) (map (\ (a,b) -> (a,b,())) es)+ where+ nonZeroCols = [ [ j | j <- [0..cols m - 1], not (m `atIndex` (i, j) `approxEq` 0) ] | i <- [0..rows m - 1] ]+ ns = nub $ concat nonZeroCols+ es = [ (i, j) | cs <- nonZeroCols, [i, j] <- sequence [cs, cs] ]+ -- Convert a set of constraints into a matrix of co-efficients, and a -- reverse mapping of column numbers to units. constraintsToMatrix :: Constraints -> (H.Matrix Double, [Int], A.Array Int UnitInfo)@@ -169,7 +329,7 @@ (rhsM, rhsCols) = flattenedToMatrix colSort rhs colElems = A.elems lhsCols ++ A.elems rhsCols augM = if rows rhsM == 0 || cols rhsM == 0 then lhsM else if rows lhsM == 0 || cols lhsM == 0 then rhsM else fromBlocks [[lhsM, rhsM]]- inconsists = findInconsistentRows lhsM augM+ inconsists = splitFindInconsistentRows lhsM rhsM constraintsToMatrices :: Constraints -> (H.Matrix Double, H.Matrix Double, [Int], A.Array Int UnitInfo, A.Array Int UnitInfo) constraintsToMatrices cons = constraintsToMatrices' colSort cons@@ -188,7 +348,7 @@ (lhsM, lhsCols) = flattenedToMatrix sortfn lhs (rhsM, rhsCols) = flattenedToMatrix sortfn rhs augM = if rows rhsM == 0 || cols rhsM == 0 then lhsM else if rows lhsM == 0 || cols lhsM == 0 then rhsM else fromBlocks [[lhsM, rhsM]]- inconsists = findInconsistentRows lhsM augM+ inconsists = splitFindInconsistentRows lhsM rhsM -- [[UnitInfo]] is a list of flattened constraints flattenedToMatrix :: SortFn -> [[UnitInfo]] -> (H.Matrix Double, A.Array Int UnitInfo)@@ -231,6 +391,14 @@ (lhsOk, lhsShift) = partition (not . isUnitRHS) lhs (rhsOk, rhsShift) = partition isUnitRHS rhs +-- | Shift terms based on function f (<- True, False ->).+shiftTermsBy :: (UnitInfo -> Bool) -> ([UnitInfo], [UnitInfo]) -> ([UnitInfo], [UnitInfo])+shiftTermsBy f (lhs, rhs) = (lhsOk ++ negateCons rhsShift, rhsOk ++ negateCons lhsShift)+ where+ (lhsOk, lhsShift) = partition f lhs+ (rhsOk, rhsShift) = partition (not . f) rhs++ -- | Translate all constraints into a LHS, RHS side of units. flattenConstraints :: Constraints -> [([UnitInfo], [UnitInfo])] flattenConstraints = map (\ (ConEq u1 u2) -> (flattenUnits u1, flattenUnits u2))@@ -244,19 +412,28 @@ where -- (a', den, r) = Flint.rref a +-- Provenance of matrices.+data RRefOp+ = ElemRowSwap Int Int -- ^ swapped row with row+ | ElemRowMult Int Double -- ^ scaled row by constant+ | ElemRowAdds [(Int, Int)] -- ^ set of added row onto row ops+ deriving (Show, Eq, Ord)+ -- worker function -- invariant: the matrix a is in rref except within the submatrix (j-k,j) to (n,n)+rrefMatrices' :: H.Matrix Double -> Int -> Int -> [(H.Matrix Double, RRefOp)] ->+ ([(H.Matrix Double, RRefOp)], H.Matrix Double) rrefMatrices' a j k mats -- Base cases: | j - k == n = (mats, a) | j == m = (mats, a) -- When we haven't yet found the first non-zero number in the row, but we really need one:- | a @@> (j - k, j) == 0 = case findIndex (/= 0) below of+ | a `atIndex` (j - k, j) == 0 = case findIndex (/= 0) below of -- this column is all 0s below current row, must move onto the next column Nothing -> rrefMatrices' a (j + 1) (k + 1) mats -- we've found a row that has a non-zero element that can be swapped into this row- Just i' -> rrefMatrices' (swapMat <> a) j k (swapMat:mats)+ Just i' -> rrefMatrices' (swapMat <> a) j k ((swapMat, ElemRowSwap i (j - k)):mats) where i = j - k + i' swapMat = elemRowSwap n i (j - k) @@ -269,12 +446,12 @@ n = rows a m = cols a below = getColumnBelow a (j - k, j)-- erm = elemRowMult n (j - k) (recip (a @@> (j - k, j)))+ scale = recip (a `atIndex` (j - k, j))+ erm = elemRowMult n (j - k) scale -- scale the row if the cell is not already equal to 1- (a1, mats1) | a @@> (j - k, j) /= 1 = (erm <> a, erm:mats)- | otherwise = (a, mats)+ (a1, mats1) | a `atIndex` (j - k, j) /= 1 = (erm <> a, (erm, ElemRowMult (j - k) scale):mats)+ | otherwise = (a, mats) -- Locate any non-zero values in the same column as (j - k, j) and -- cancel them out. Optimisation: instead of constructing a@@ -282,19 +459,19 @@ -- multiplied together, simply build a single matrix that cancels -- all of them out at the same time, using the ST Monad. findAdds _ m ms- | isWritten = (new <> m, new:ms)+ | isWritten = (new <> m, (new, ElemRowAdds ops):ms) | otherwise = (m, ms) where- (isWritten, new) = runST $ do+ (isWritten, ops, new) = runST $ do new <- newMatrix 0 n n :: ST s (STMatrix s Double) sequence [ writeMatrix new i' i' 1 | i' <- [0 .. (n - 1)] ]- let f w i | i >= n = return w- | i == j - k = f w (i + 1)- | a @@> (i, j) == 0 = f w (i + 1)- | otherwise = writeMatrix new i (j - k) (- (a @@> (i, j)))- >> f True (i + 1)- isWritten <- f False 0- (isWritten,) `fmap` freezeMatrix new+ let f w o i | i >= n = return (w, o)+ | i == j - k = f w o (i + 1)+ | a `atIndex` (i, j) == 0 = f w o (i + 1)+ | otherwise = writeMatrix new i (j - k) (- (a `atIndex` (i, j)))+ >> f True ((i, j - k):o) (i + 1)+ (isWritten, ops) <- f False [] 0+ (isWritten, ops,) `fmap` freezeMatrix new (a2, mats2) = findAdds 0 a1 mats1 @@ -310,29 +487,54 @@ elemRowSwap n i j | i == j = ident n | i > j = elemRowSwap n j i- | otherwise = extractRows ([0..i-1] ++ [j] ++ [i+1..j-1] ++ [i] ++ [j+1..n-1]) $ ident n-+ | otherwise = ident n ? ([0..i-1] ++ [j] ++ [i+1..j-1] ++ [i] ++ [j+1..n-1]) -------------------------------------------------- +type GraphCol = IM.IntMap IS.IntSet -- graph from origin to dest.+type Provenance = IM.IntMap IS.IntSet -- graph from dest. to origin++opToGraphCol :: RRefOp -> GraphCol+opToGraphCol ElemRowMult{} = IM.empty+opToGraphCol (ElemRowSwap i j) = IM.fromList [ (i, IS.singleton j), (j, IS.singleton i) ]+opToGraphCol (ElemRowAdds l) = IM.fromList $ concat [ [(i, IS.fromList [i,j]), (j, IS.singleton j)] | (i, j) <- l ]++graphColCombine :: GraphCol -> GraphCol -> GraphCol+graphColCombine g1 g2 = IM.unionWith (curry snd) g1 $ IM.map (IS.fromList . trans . IS.toList) g2+ where+ trans = concatMap (\ i -> [i] `fromMaybe` (IS.toList <$> IM.lookup i g1))++invertGraphCol g = IM.fromListWith IS.union [ (i, IS.singleton j) | (j, jset) <- IM.toList g, i <- IS.toList jset ]++provenance :: H.Matrix Double -> (H.Matrix Double, Provenance)+provenance m = (m', p)+ where+ (matOps, m') = rrefMatrices' m 0 0 []+ p = invertGraphCol . foldl' graphColCombine IM.empty . map opToGraphCol $ map snd matOps+ -- Worker functions: findInconsistentRows :: H.Matrix Double -> H.Matrix Double -> [Int]-findInconsistentRows coA augA = [0..(rows augA - 1)] \\ consistent+findInconsistentRows coA augA | rows augA < 2 = []+ | otherwise = inconsistent where- consistent = head (filter (tryRows coA augA) (tails ( [0..(rows augA - 1)])) ++ [[]])+ inconsistent = [0..(rows augA - 1)] \\ consistent + consistent+ -- if the space is relatively small, try it all+ | rows augA < 16 = head (filter tryRows (powerset $ reverse [0..(rows augA - 1)]))+ | otherwise = head (filter tryRows (tails ( [0..(rows augA - 1)])) ++ [[]])++ powerset = filterM (const [True, False])+ -- Rouché–Capelli theorem is that if the rank of the coefficient -- matrix is not equal to the rank of the augmented matrix then -- the system of linear equations is inconsistent.- tryRows _ _ [] = True- tryRows coA augA ns = (rank coA' == rank augA')+ tryRows [] = True+ tryRows ns = (rank coA' == rank augA') where- coA' = extractRows ns coA- augA' = extractRows ns augA--extractRows = flip (?) -- hmatrix 0.17 changed interface-m @@> i = m `atIndex` i+ coA' = coA ? ns+ augA' = augA ? ns -- | Create unique names for all of the inferred implicit polymorphic -- unit variables.@@ -373,7 +575,9 @@ inconsistentConstraints :: Constraints -> Maybe Constraints inconsistentConstraints [] = Nothing inconsistentConstraints cons- | null inconsists = Nothing- | otherwise = Just [ con | (con, i) <- zip cons [0..], i `elem` inconsists ]+ | not (null direct) = Just direct+ | null inconsists = Nothing+ | otherwise = Just [ con | (con, i) <- zip cons [0..], i `elem` inconsists ] where (_, _, inconsists, _, _) = constraintsToMatrices cons+ direct = detectInconsistency $ genUnitAssignments' colSort cons
src/Camfort/Specification/Units/InferenceBackendFlint.hs view
@@ -309,7 +309,9 @@ -- divide them out sometimes. normHNF :: H.Matrix Double -> (H.Matrix Double, [Int])-normHNF m = (m', indices)+normHNF m+ | (rows m, cols m) == (1, 1) = (H.ident (if H.atIndex m (0, 0) /= 0 then 1 else 0), [])+ | otherwise = (m', indices) where numCols = cols m indexLookup j | j < numCols = j
src/Camfort/Specification/Units/ModFile.hs view
@@ -10,12 +10,14 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TupleSections #-} module Camfort.Specification.Units.ModFile ( genUnitsModFile , initializeModFiles , runCompileUnits+ , dumpModFileCompiledUnits ) where import Control.Monad.State (get, gets, lift)@@ -24,16 +26,19 @@ import Data.Data (Data) import Data.Generics.Uniplate.Operations (universeBi) import Data.List (partition)-import qualified Data.Map.Strict as M+import Data.Maybe (mapMaybe, catMaybes)+import qualified Data.Map as M+import qualified Data.Set as S import Data.Typeable (Typeable) import GHC.Generics (Generic) import qualified Language.Fortran.AST as F+import qualified Language.Fortran.Analysis as FA import Language.Fortran.Util.ModFile import Camfort.Analysis (analysisModFiles) import Camfort.Specification.Units.Annotation (UA)-import Camfort.Specification.Units.Environment (Constraint(..), foldUnits, UnitInfo(..), colSort)+import Camfort.Specification.Units.Environment (Constraint(..), foldUnits, UnitInfo(..), colSort, Constraints) import Camfort.Specification.Units.InferenceBackend (flattenConstraints, flattenUnits, genUnitAssignments, genUnitAssignments') import Camfort.Specification.Units.Monad @@ -63,7 +68,7 @@ mfCompiledUnits :: ModFile -> CompiledUnits mfCompiledUnits mf = case lookupModFileData unitsCompiledDataLabel mf of Nothing -> emptyCompiledUnits- Just bs -> case decodeOrFail (LB.fromStrict bs) of+ Just bs -> case decodeOrFail bs of Left _ -> emptyCompiledUnits Right (_, _, cu) -> cu @@ -79,6 +84,7 @@ runCompileUnits :: UnitSolver CompiledUnits runCompileUnits = do cons <- usConstraints `fmap` get+ pf <- usProgramFile `fmap` get let unitAssigns = flattenConstraints cons let epsilon = 0.001 -- arbitrary@@ -87,13 +93,36 @@ let variables = M.fromList [ (NPKVariable var, units) | ([UnitPow (UnitVar var) k], units) <- unitAssigns , k `approxEq` 1 ] - tmap <- M.map optimiseTemplate `fmap` gets usTemplateMap- let npm = variables+ -- Create sets of relevant program-unit and variable names.+ let getName pu | F.Named n <- FA.puName pu = Just n | otherwise = Nothing+ let puNameSet = S.fromList $ catMaybes [ getName pu | pu <- universeBi pf :: [F.ProgramUnit UA] ] +++ [ FA.varName e | F.BlInterface _ _ (Just e) _ _ _ <- universeBi pf :: [F.Block UA] ] - -- D.traceM $ "npm = " ++ unlines (map show (M.toList npm))- -- D.traceM $ "tmap = \n" ++ unlines [ f ++ "\n" ++ unlines (map show cons) | (f, cons) <- M.toList tmap ]- pure CompiledUnits { cuTemplateMap = tmap, cuNameParamMap = variables }+ let puVarNameSet pu = S.fromList $+ [ (FA.varName v, FA.srcName v) | F.DeclVariable _ _ v _ _ <- universeBi pu :: [F.Declarator UA] ] +++ [ (FA.varName v, FA.srcName v) | F.DeclArray _ _ v _ _ _ <- universeBi pu :: [F.Declarator UA] ] + -- Map of modules -> associated declared variables+ let puVarNameMap :: M.Map F.ProgramUnitName (S.Set VV)+ puVarNameMap = M.fromListWith S.union [ (F.getName pu, puVarNameSet pu)+ | pu@F.PUModule {} <- universeBi pf :: [F.ProgramUnit UA] ]++ -- Filter functions that cut out any information not having to do+ -- with the current modules being compiled.+ let filterPUs = M.filterWithKey (const . (`S.member` puNameSet))+ -- FIXME: investigate whether we should include vars that are linked+ -- transitively to current pf vars should also be included.+ tmap <- (filterPUs . M.map optimiseTemplate) `fmap` gets usTemplateMap++ let findNPK vv = ( (NPKVariable vv), ) <$> M.lookup (NPKVariable vv) variables++ -- 'Name Param Map': module names -> (variables -> unit info)+ let npm = M.filter (not . M.null) $ flip M.map puVarNameMap (M.fromList . mapMaybe findNPK . S.toList)++ pure CompiledUnits { cuTemplateMap = tmap, cuNameParamMap = npm }++-- | Cut out unnecessary constraints in the template using the solver.+optimiseTemplate :: Constraints -> Constraints optimiseTemplate cons = map (\ (l, r) -> ConEq (foldUnits l) r) optimised where unitAssigns = genUnitAssignments' (compileColSort) cons@@ -122,4 +151,24 @@ genUnitsModFile :: F.ProgramFile UA -> CompiledUnits -> ModFile genUnitsModFile pf cu = alterModFileData f unitsCompiledDataLabel $ genModFile pf where- f _ = Just . LB.toStrict $ encode cu+ f _ = Just $ encode cu++-- | Return information about compiled units for debugging purposes+dumpModFileCompiledUnits :: ModFile -> Maybe String+dumpModFileCompiledUnits mf = do+ bs <- lookupModFileData unitsCompiledDataLabel mf+ cu <- case decodeOrFail bs of+ Left _ -> Nothing+ Right (_, _, cu) -> Just cu+ pure . unlines $ [ "Template Map (size=" ++ show (M.size (cuTemplateMap cu)) ++ "):"+ , concat [ unlines (i 2 fname':map (i 4 . show) temp)+ | (fname, temp) <- M.toList (cuTemplateMap cu)+ , let fname' = "Template for " ++ show fname ]+ , "NameParam Map (size=" ++ show (M.size (cuNameParamMap cu)) ++ "):"+ , concat [ unlines (i 2 mod':[ i 4 (show ui ++ " :: " ++ show v)+ | (NPKVariable (v,_), ui) <- M.toList npkmap ])+ | (mod, npkmap) <- M.toList (cuNameParamMap cu)+ , let mod' = "Module " ++ show mod ]+ ]+ where+ i n s = replicate n ' ' ++ s
src/Camfort/Specification/Units/MonadTypes.hs view
@@ -72,7 +72,7 @@ instance Binary NameParamKey -- | mapped to a list of units (to be multiplied together)-type NameParamMap = M.Map NameParamKey [UnitInfo]+type NameParamMap = M.Map F.ProgramUnitName (M.Map NameParamKey [UnitInfo]) -- | Variable => unit type VarUnitMap = M.Map VV UnitInfo
src/Camfort/Transformation/CommonBlockElim.hs view
@@ -17,6 +17,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE MonoLocalBinds #-} module Camfort.Transformation.CommonBlockElim ( commonElimToModules@@ -24,7 +25,7 @@ import Control.Monad import Control.Monad.State.Lazy-import Control.Monad.Writer.Strict (execWriter, tell)+import Control.Monad.Writer.CPS (execWriter, tell) import Data.Data import Data.Void@@ -36,6 +37,7 @@ import qualified Language.Fortran.AST as F import qualified Language.Fortran.Analysis as FA import qualified Language.Fortran.Analysis.Types as FAT+import qualified Language.Fortran.Analysis.Renaming as FAR import qualified Language.Fortran.Util.Position as FU import qualified Language.Fortran.ParserMonad as PM import qualified Language.Fortran.PrettyPrint as PP@@ -49,7 +51,8 @@ -- Tuple of: -- * a (possible) common block name -- * map from names to their types-type TCommon p = (Maybe F.Name, [(F.Name, F.BaseType)])+type TypeInfo = (F.BaseType, FA.ConstructType)+type TCommon p = (Maybe F.Name, [(F.Name, TypeInfo)]) -- Typed and "located" common block representation -- Right associated pairs tuple of:@@ -87,7 +90,7 @@ analysePerPF :: F.ProgramFile A -> CommonState (F.ProgramFile A) analysePerPF pf = do- let pf' = FA.initAnalysis pf+ let pf' = FAR.analyseRenames . FA.initAnalysis $ pf let (pf'', tenv) = FAT.analyseTypes pf' pf''' <- transformBiM (analysePerPU tenv (F.pfGetFilename pf)) pf'' return (fmap FA.prevAnnotation pf''')@@ -119,15 +122,17 @@ let info = (fname, (punitName pname, (commonNameFromAST cname, tcommon))) modify (\(r, infos) -> (r ++ r', info : infos)) - typeCommonExprs :: F.Expression A1 -> (F.Name, F.BaseType)- typeCommonExprs (F.ExpValue _ sp (F.ValVariable v)) =- case M.lookup v tenv of- Just (FA.IDType (Just t) (Just FA.CTVariable)) -> (v, t)- Just (FA.IDType (Just t) (Just FA.CTArray)) -> (v, t)- _ -> error $ "Variable '" ++ show v- ++ "' is of an unknown or higher-order type at: " ++ show sp- ++ show (M.lookup v tenv)-+ typeCommonExprs :: F.Expression A1 -> (F.Name, TypeInfo)+ typeCommonExprs e@(F.ExpValue _ sp (F.ValVariable _)) =+ case M.lookup var tenv of+ Just (FA.IDType (Just t) (Just ct@FA.CTVariable)) -> (src, (t, ct))+ Just (FA.IDType (Just t) (Just ct@FA.CTArray{})) -> (src, (t, ct))+ _ -> error $ "Variable '" ++ src+ ++ "' is of an unknown or higher-order type at: " ++ show sp ++ " "+ ++ show (M.lookup var tenv)+ where+ var = FA.varName e+ src = FA.srcName e typeCommonExprs e = error $ "Not expecting a non-variable expression \ \in expression at: " ++ show (FU.getSpan e) @@ -175,7 +180,7 @@ let mkRenamerAndCommon (r, tc) (v, t) = let v' = caml (commonName cname) ++ "_" ++ v in (M.insert v (Just v', Nothing) r, (v', t) : tc)- (r, fields') = foldl mkRenamerAndCommon (M.empty, []) fields+ (r, fields') = foldl' mkRenamerAndCommon (M.empty, []) fields in ((fname, (pname, (cname, fields'))), Just r) -- From a list of typed and located common blocks group by the common@@ -212,7 +217,7 @@ -- a Nothing for a variable represent a variable-level (renamer) identity -- a Nothing for a type represents a type-level (coercer) identity type RenamerCoercer =- Maybe (M.Map F.Name (Maybe F.Name, Maybe (F.BaseType, F.BaseType)))+ Maybe (M.Map F.Name (Maybe F.Name, Maybe (TypeInfo, TypeInfo))) class Renaming r where hasRenaming :: F.Name -> r -> Bool@@ -240,7 +245,7 @@ importIncludeCommons :: PM.FortranVersion -> F.ProgramUnit A -> F.ProgramUnit A importIncludeCommons v p =- foldl (flip (matchPUnit v)) p (reduceCollect inames p)+ foldl' (flip (matchPUnit v)) p (reduceCollect inames p) -- Data-type generic reduce traversal reduceCollect :: (Data s, Data t, Uniplate t, Biplate t s) => (s -> Maybe a) -> t -> [a]@@ -285,37 +290,39 @@ -- declaration time (which then need to be turned into separate assignment -- statements) removeDecl :: [RenamerCoercer]- -> F.Statement A -> State [F.Statement A] (F.Statement A)- removeDecl rcs (F.StDeclaration a s@(FU.SrcSpan p1 _) typ attr decls) = do+ -> F.Block A -> State [F.Statement A] (F.Block A)+ removeDecl rcs (F.BlStatement a s@(FU.SrcSpan p1 _) mlab (F.StDeclaration stA stS typ attr decls)) = do modify (++ assgns)- return $ F.StDeclaration a' (deleteLine s) typ attr decls'+ return . F.BlStatement a' s' mlab $ F.StDeclaration stA stS typ attr decls' where (F.AList al sl declsA) = decls decls' = F.AList al' sl declsA'- (assgns, declsA') = foldl matchVar ([],[]) declsA+ (assgns, declsA') = foldl' matchVar ([],[]) declsA -- Update annotation if declarations are being added- (a', al') = if length declsA == length declsA'- then (a, al)- else (a {refactored = Just p1, deleteNode = True}- , al {refactored = Just pl1})- where (FU.SrcSpan pl1 _ ) = sl+ ((a', s'), al')+ | null declsA' = ((a {refactored = Just p1, deleteNode = True}, deleteLine s),+ al {refactored = Just pl1})+ | length declsA' /= length declsA = ((a {refactored = Just p1}, s), al {refactored = Just pl1})+ | otherwise = ((a, s), al)+ where FU.SrcSpan pl1 _ = sl matchVar :: ([F.Statement A], [F.Declarator A]) -> F.Declarator A -> ([F.Statement A], [F.Declarator A])- matchVar (assgns, decls)- dec@(F.DeclVariable _ s- lvar@(F.ExpValue _ _ (F.ValVariable v)) _ init) =- if hasRenaming v rcs- then case init of- -- Renaming exists and no default, then remove- Nothing -> (assgns, decls)- -- Renaming exists but has default, so create an- -- assignment for this- Just initExpr ->- ((F.StExpressionAssign a' s lvar initExpr) : assgns, decls)- else -- no renaming, preserve declaration- (assgns, dec : decls)- matchVar (assgns, decls) _ = (assgns, decls)+ -- match on variable or array declaration+ matchVar (assgns, decls) dec = case dec of+ F.DeclVariable _ _ lvar@(F.ExpValue _ _ (F.ValVariable v)) _ init -> doMatchVar lvar v init+ F.DeclArray _ _ lvar@(F.ExpValue _ _ (F.ValVariable v)) _ _ init -> doMatchVar lvar v init+ _ -> (assgns, decls)+ where+ doMatchVar lvar v init+ | hasRenaming v rcs = case init of+ -- Renaming exists and no default, then remove+ Nothing -> (assgns, decls)+ -- Renaming exists but has default, so create an+ -- assignment for this+ Just initExpr -> ((F.StExpressionAssign a' (FU.getSpan dec) lvar initExpr) : assgns, decls)+ | otherwise = (assgns, dec : decls) -- no renaming, preserve declaration+ removeDecl _ d = return d @@ -356,7 +363,7 @@ renamerToUse Nothing = [] renamerToUse (Just m) = let entryToPair _ (Nothing, _) = [] entryToPair v (Just v', _) = [(v, v')]- in M.foldlWithKey (\xs v e -> entryToPair v e ++ xs) [] m+ in M.foldlWithKey' (\xs v e -> entryToPair v e ++ xs) [] m -- make the use statements for a particular program unit's common blocks mkUseStatementBlocks :: FU.SrcSpan -> [(TCommon A, RenamerCoercer)] -> [F.Block A]@@ -366,7 +373,7 @@ (FU.SrcSpan pos pos') = s s' = FU.SrcSpan (toCol0 pos) pos' mkUseStmnt x@((name, _), _) = F.BlStatement a s' Nothing $- F.StUse a s' useName F.Permissive useListA+ F.StUse a s' useName Nothing F.Permissive useListA where useName = F.ExpValue a s' (F.ValVariable (caml (commonName name))) useListA = case useList of [] -> Nothing us -> Just (F.AList a s' (reverse us))@@ -384,9 +391,8 @@ mkRenamerCoercer :: TCommon A :? source -> TCommon A :? target -> RenamerCoercer mkRenamerCoercer (name1, vtys1) (name2, vtys2)- | name1 == name2 =- if vtys1 == vtys2 then Nothing- else Just $ generate vtys1 vtys2 M.empty+ | name1 == name2 = if vtys1 == vtys2 then Nothing+ else Just $ generate vtys1 vtys2 M.empty | otherwise = error "Can't generate renamer between different common blocks\n" where@@ -416,16 +422,16 @@ else error $ "Trying to compare differently named common blocks: " ++ show n1 ++ " and " ++ show n2 ++ "\n" -coherentCommons' :: [(F.Name, F.BaseType)] -> [(F.Name, F.BaseType)] -> (String, Bool)+coherentCommons' :: [(F.Name, TypeInfo)] -> [(F.Name, TypeInfo)] -> (String, Bool) coherentCommons' [] [] = ("", True) coherentCommons' ((var1, ty1):xs) ((var2, ty2):ys) | af ty1 == af ty2 = let (r', c) = coherentCommons' xs ys in (r', c && True) | otherwise = let r = var1 ++ ":"- ++ PP.pprintAndRender PM.Fortran90 ty1 Nothing+ ++ PP.pprintAndRender PM.Fortran90 (fst ty1) Nothing ++ "(" ++ show (af ty1) ++ ")" ++ " differs from " ++ var2- ++ ":" ++ PP.pprintAndRender PM.Fortran90 ty2 Nothing+ ++ ":" ++ PP.pprintAndRender PM.Fortran90 (fst ty2) Nothing ++ "(" ++ show (af ty2) ++ ")" ++ "\n" (r', _) = coherentCommons' xs ys in (r ++ r', False)@@ -449,17 +455,24 @@ r = "Creating module " ++ modname ++ " at " ++ path ++ "\n" mod = mkModule modname varTys modname -mkModule :: String -> [(F.Name, F.BaseType)] -> String -> F.ProgramUnit A+mkModule :: String -> [(F.Name, TypeInfo)] -> String -> F.ProgramUnit A mkModule name vtys fname = F.PUModule a sp (caml fname) decls Nothing where a = unitAnnotation { refactored = Just loc, newNode = True }- loc = FU.Position 0 0 0+ loc = FU.Position 0 0 0 "" Nothing sp = FU.SrcSpan loc loc toDeclBlock (v, t) = F.BlStatement a sp Nothing (toStmt (v, t))- toStmt (v, t) = F.StDeclaration a sp (toTypeSpec t) Nothing (toDeclarator v)+ toStmt (v, (bt, ct)) = F.StDeclaration a sp (toTypeSpec bt) attrs (toDeclarator (v, ct))+ attrs = Just $ F.AList a sp [F.AttrSave a sp] toTypeSpec t = F.TypeSpec a sp t Nothing- toDeclarator v = F.AList a sp+ toDeclarator (v, FA.CTVariable) = F.AList a sp [F.DeclVariable a sp (F.ExpValue a sp (F.ValVariable (caml name ++ "_" ++ v))) Nothing Nothing]+ toDeclarator (v, FA.CTArray dims) = F.AList a sp+ [F.DeclArray a sp+ (F.ExpValue a sp (F.ValVariable (caml name ++ "_" ++ v))) dimDecls Nothing Nothing]+ where+ dimDecls = F.AList a sp . flip map dims $ \ (lb, ub) -> F.DimensionDeclarator a sp (fmap exp lb) (fmap exp ub)+ exp = F.ExpValue a sp . F.ValInteger . show decls = map toDeclBlock vtys
src/Camfort/Transformation/EquivalenceElim.hs view
@@ -97,9 +97,9 @@ let pos = afterAligned sp let copies = map (mkCopy tenv pos dstE) eqs' - let (FU.Position ao c l) = s1+ let (FU.Position ao c l f p) = s1 reportSpan i =- let pos = FU.Position (ao + i) c (l + i)+ let pos = FU.Position (ao + i) c (l + i) f p in (FU.SrcSpan pos pos) forM_ [n..(n + length copies - 1)] $ \i -> do
src/Language/Fortran/Model/Translate.hs view
@@ -16,6 +16,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE PolyKinds #-} -- TODO: Implement translation for more unsupported language parts @@ -97,6 +98,7 @@ indices, op, rmap, (.>)) import Control.Monad.Except import Control.Monad.Reader+import Control.Monad.Fail hiding (fail) import Data.Map (Map) import Data.Singletons@@ -238,10 +240,11 @@ , MonadError TranslateError , MonadReader TranslateEnv , MonadLogger e w+ , MonadFail ) runTranslateT- :: (Monad m)+ :: (Monad m, MonadFail m) => TranslateT m a -> TranslateEnv -> m (Either TranslateError a)@@ -359,7 +362,7 @@ -- | Convert a 'TypeInfo' to its corresponding strong type. translateTypeInfo- :: (Monad m, Show ann)+ :: (Monad m, MonadFail m, Show ann) => TypeInfo ann -> TranslateT m SomeType translateTypeInfo ti = do@@ -406,7 +409,7 @@ SomePrimD :: D (PrimS a) -> SomePrimD translateBaseType- :: (Monad m)+ :: (Monad m, MonadFail m) => F.BaseType -> Maybe (F.Expression ann) -- ^ Kind -> TranslateT m SomePrimD@@ -428,10 +431,10 @@ -- Get value-level representations of the type's basic type and precision (basicType, prec) <- case bt of- F.TypeInteger -> (BTInt ,) <$> getKindPrec "integer" fsIntegerKinds- F.TypeReal -> (BTReal ,) <$> getKindPrec "real" fsRealKinds- F.TypeCharacter -> (BTChar ,) <$> getKindPrec "character" fsCharacterKinds- F.TypeLogical -> (BTLogical ,) <$> getKindPrec "logical" fsLogicalKinds+ F.TypeInteger -> (BTInt ,) <$> getKindPrec "integer" fsIntegerKinds+ F.TypeReal -> (BTReal ,) <$> getKindPrec "real" fsRealKinds+ F.TypeCharacter{} -> (BTChar ,) <$> getKindPrec "character" fsCharacterKinds+ F.TypeLogical -> (BTLogical ,) <$> getKindPrec "logical" fsLogicalKinds -- Double precision is special because it's not always supported as its own -- basic type, being subsumed by the `REAL` basic type. F.TypeDoublePrecision ->@@ -451,7 +454,7 @@ -- | Translate an expression with an unknown type. The return value -- existentially captures the type of the result.-translateExpression :: (Monad m) => F.Expression (F.Analysis ann) -> TranslateT m SomeExpr+translateExpression :: (Monad m, MonadFail m) => F.Expression (F.Analysis ann) -> TranslateT m SomeExpr translateExpression = \case e@(F.ExpValue ann span val) -> translateValue e F.ExpBinary ann span bop e1 e2 -> translateOp2App e1 e2 bop@@ -469,7 +472,7 @@ -- | Translate an expression with a known type. Fails if the actual type does -- not match. translateExpression'- :: (Monad m) => D a -> F.Expression (F.Analysis ann)+ :: (Monad m, MonadFail m) => D a -> F.Expression (F.Analysis ann) -> TranslateT m (FortranExpr a) translateExpression' targetD ast = do SomePair sourceD expr <- translateExpression ast@@ -482,7 +485,7 @@ -- | Translate an expression and try to coerce it to a particular type. Fails if -- the actual type cannot be coerced to the given type. translateCoerceExpression- :: (Monad m) => D a -> F.Expression (F.Analysis ann)+ :: (Monad m, MonadFail m) => D a -> F.Expression (F.Analysis ann) -> TranslateT m (HFree MetaOp FortranExpr a) translateCoerceExpression targetD ast = do SomePair sourceD expr <- translateExpression ast@@ -497,7 +500,7 @@ translateSubscript- :: (Monad m)+ :: (Monad m, MonadFail m) => F.Expression (F.Analysis ann) -> [F.Index (F.Analysis ann)] -> TranslateT m SomeExpr translateSubscript arrAst [F.IxSingle _ _ _ ixAst] = do SomePair arrD arrExp <- translateExpression arrAst@@ -532,7 +535,7 @@ -- annotations of its own. -- -- Do not call on an expression that you don't know to be an 'F.ExpValue'!-translateValue :: (Monad m) => F.Expression (F.Analysis ann) -> TranslateT m SomeExpr+translateValue :: (Monad m, MonadFail m) => F.Expression (F.Analysis ann) -> TranslateT m SomeExpr translateValue e = case e of F.ExpValue _ _ v -> case v of F.ValInteger s -> translateLiteral v PInt64 (fmap fromIntegral . readLitInteger) s@@ -562,7 +565,7 @@ translateLiteral- :: (Monad m)+ :: (Monad m, MonadFail m) => F.Value ann -> Prim p k a -> (s -> Maybe a) -> s -> TranslateT m SomeExpr@@ -621,7 +624,7 @@ -- This is way too general for its own good but it was fun to write. translateOpApp- :: (Monad m)+ :: (Monad m, MonadFail m) => (Length xs ~ n) => Op n ok -> Rec (Const (F.Expression (F.Analysis ann))) xs -> TranslateT m SomeExpr@@ -641,7 +644,7 @@ translateOp2App- :: (Monad m)+ :: (Monad m, MonadFail m) => F.Expression (F.Analysis ann) -> F.Expression (F.Analysis ann) -> F.BinaryOp -> TranslateT m SomeExpr translateOp2App e1 e2 bop = do@@ -652,7 +655,7 @@ translateOp1App- :: (Monad m)+ :: (Monad m, MonadFail m) => F.Expression (F.Analysis ann) -> F.UnaryOp -> TranslateT m SomeExpr translateOp1App e uop = do
src/Language/Fortran/Model/Vars.hs view
@@ -136,10 +136,10 @@ return $ ARData valReprs arraySymbolicPrim :: (HasPrimReprHandlers r) => Prim p1 k1 i -> Prim p2 k2 a -> String -> r -> Symbolic SArr-arraySymbolicPrim ixPrim valPrim nm = do- k1 <- primSBVKind ixPrim- k2 <- primSBVKind valPrim- return $ newSArr (k1, k2) (\i -> nm ++ "_" ++ show i)+arraySymbolicPrim ixPrim valPrim nm = error "arraySymbolicPrim: bit-rotted in new SBV 8.0 version" -- do+ -- k1 <- primSBVKind ixPrim+ -- k2 <- primSBVKind valPrim+ -- return $ newSArr (k1, k2) (\i -> nm ++ "_" ++ show i) -- pairProxy :: p1 a -> p2 b -> Proxy '(a, b) -- pairProxy _ _ = Proxy
src/Main.hs view
@@ -23,6 +23,8 @@ import Camfort.Specification.Units.Monad (LiteralsOpt(LitMixed)) import Camfort.Specification.Hoare (PrimReprOption(..)) +import Language.Fortran.ParserMonad (FortranVersion(..), selectFortranVersion)+ import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) import System.Directory (getCurrentDirectory)@@ -39,10 +41,12 @@ else exitWith $ ExitFailure code where env ro lo = CamfortEnv- { ceInputSources = inputSource ro- , ceIncludeDir = includeDir ro- , ceExcludeFiles = getExcludes ro- , ceLogLevel = logLevel lo+ { ceInputSources = inputSource ro+ , ceIncludeDir = includeDir ro+ , ceExcludeFiles = getExcludes ro+ , ceLogLevel = logLevel lo+ , ceSourceSnippets = snippets lo+ , ceFortranVersion = fortranVersion ro } getExcludes = fromMaybe [] . exclude@@ -64,6 +68,13 @@ lo = ssoLogOptions sso inFile = inputSource ro in runRO ro lo (f (annotationType ao) (getOutputFile inFile wo))+ runDSO dso f =+ let ao = dsoAnnotationOptions dso+ wo = dsoWriteOptions dso+ ro = dsoReadOptions dso+ lo = dsoLogOptions dso+ inFile = inputSource ro+ in runRO ro lo (f (annotationType ao) (getOutputFile inFile wo)) runUO uo f = let ro = uoReadOptions uo lo = uoLogOptions uo@@ -97,16 +108,27 @@ runCommand (CmdStencilsInfer so) = runSIO so stencilsInfer runCommand (CmdStencilsSynth sso) = runSSO sso stencilsSynth runCommand (CmdUnitsSuggest uo) = runUO uo unitsCriticals- runCommand (CmdUnitsCheck uo) = runUO uo unitsCheck- runCommand (CmdUnitsInfer uo) = runUO uo unitsInfer+ runCommand (CmdUnitsCheck uo)+ | uoDumpMode uo = runUO uo unitsDump+ | otherwise = runUO uo unitsCheck+ runCommand (CmdUnitsInfer uo) = runUO uo $ unitsInfer (uoShowAST uo) runCommand (CmdUnitsSynth uso) = runUSO uso unitsSynth runCommand (CmdUnitsCompile uo) = runUO uo unitsCompile runCommand (CmdInvariantsCheck io) = runIO io invariantsCheck runCommand (CmdRefactCommon rfo) = runRFO rfo common runCommand (CmdRefactDead rfo) = runRFO rfo dead runCommand (CmdRefactEquivalence rfo) = runRFO rfo equivalences+ runCommand (CmdInferDDT ro lo) = runRO ro lo ddtInfer+ runCommand (CmdSynthDDT dso) = runDSO dso ddtSynth+ runCommand (CmdCheckDDT ro lo) = runRO ro lo ddtCheck+ runCommand (CmdRefactDDT rfo) = runRFO rfo ddtRefactor+ runCommand (CmdCompileDDT ro lo) = runRO ro lo ddtCompile runCommand (CmdImplicitNone ro lo) = runRO ro lo (implicitNone False) runCommand (CmdImplicitNoneAll ro lo) = runRO ro lo (implicitNone True)+ runCommand (CmdAllocCheck ro lo) = runRO ro lo allocCheck+ runCommand (CmdFPCheck ro lo) = runRO ro lo fpCheck+ runCommand (CmdUseCheck ro lo) = runRO ro lo useCheck+ runCommand (CmdArrayCheck ro lo) = runRO ro lo arrayCheck runCommand (CmdInit dir) = camfortInitialize dir >> return 0 runCommand CmdTopVersion = displayVersion >> return 0 @@ -126,8 +148,17 @@ | CmdRefactCommon RefactOptions | CmdRefactDead RefactOptions | CmdRefactEquivalence RefactOptions+ | CmdInferDDT ReadOptions LogOptions+ | CmdSynthDDT DDTSynthOptions+ | CmdCheckDDT ReadOptions LogOptions+ | CmdRefactDDT RefactOptions+ | CmdCompileDDT ReadOptions LogOptions | CmdImplicitNone ReadOptions LogOptions | CmdImplicitNoneAll ReadOptions LogOptions+ | CmdAllocCheck ReadOptions LogOptions+ | CmdFPCheck ReadOptions LogOptions+ | CmdUseCheck ReadOptions LogOptions+ | CmdArrayCheck ReadOptions LogOptions | CmdInit FilePath | CmdTopVersion @@ -137,11 +168,13 @@ { inputSource :: String , includeDir :: Maybe String , exclude :: Maybe [String]+ , fortranVersion :: Maybe FortranVersion } data LogOptions = LogOptions { logLevel :: LogLevel+ , snippets :: Bool } @@ -158,6 +191,8 @@ { uoReadOptions :: ReadOptions , uoLogOptions :: LogOptions , literals :: LiteralsOpt+ , uoDumpMode :: Bool+ , uoShowAST :: Bool } @@ -191,6 +226,12 @@ , ssoAnnotationOptions :: AnnotationOptions } +data DDTSynthOptions = DDTSynthOptions+ { dsoReadOptions :: ReadOptions+ , dsoLogOptions :: LogOptions+ , dsoWriteOptions :: WriteOptions+ , dsoAnnotationOptions :: AnnotationOptions+ } data InvariantsOptions = InvariantsOptions { ioReadOptions :: ReadOptions@@ -228,19 +269,30 @@ (xs', _:cs) -> xs' : splitBy c cs -excludeOption :: Parser (Maybe [String])-excludeOption = optional $ multiFileOption $+excludeOption :: Parser [String]+excludeOption = multiFileOption $ long "exclude" <> short 'e' <> help "files to exclude (comma separated list, no spaces)" +fortranVersionOption :: Parser FortranVersion+fortranVersionOption = option parseFortranVersion $+ long "fortranVersion"+ <> short 'F'+ <> metavar "VERSION"+ <> help "version of Fortran to parse"+ where+ parseFortranVersion = eitherReader $ \ s -> case selectFortranVersion s of+ Just v -> Right v+ Nothing -> Left "unable to parse the supplied Fortran version string" -- | Parse options for 'ReadOptions'. readOptions :: Parser ReadOptions readOptions = fmap ReadOptions (fileArgument $ help "input file") <*> optional includeDirOption- <*> excludeOption+ <*> optional excludeOption+ <*> optional fortranVersionOption where dirOption m = strOption (metavar "DIR" <> action "directory" <> m) includeDirOption = dirOption@@ -250,11 +302,12 @@ logOptions :: Parser LogOptions-logOptions = LogOptions <$> logLevelOption+logOptions = LogOptions <$> logLevelOption <*> snippetsOption where logLevelOption = let toLogLevel debug = if debug then LogDebug else LogInfo in toLogLevel <$> switch (long "debug" <> help "enable debug output")+ snippetsOption = switch (long "snippets" <> help "show code snippets") -- | User must specify either an ouput file, or say that the file@@ -287,6 +340,8 @@ readOptions <*> logOptions <*> literalsOption+ <*> dumpModFileOption+ <*> showASTOption where literalsOption = option parseLiterals $ long "units-literals"@@ -295,6 +350,8 @@ <> completeWith ["Unitless", "Poly", "Mixed"] <> value LitMixed <> help "units-of-measure literals mode. ID = Unitless, Poly, or Mixed"+ dumpModFileOption = switch (long "dump-mod-file" <> help "show contents of fsmod file")+ showASTOption = switch (long "show-ast" <> help "show units at each AST node") parseLiterals = fmap read str @@ -335,6 +392,9 @@ refactOptions = fmap RefactOptions readOptions <*> logOptions <*> writeOptions +ddtSynthOptions :: Parser DDTSynthOptions+ddtSynthOptions = fmap DDTSynthOptions+ readOptions <*> logOptions <*> writeOptions <*> annotationOptions cmdCount, cmdAST :: Parser Command cmdCount = fmap CmdCount readOptions <*> logOptions@@ -355,17 +415,27 @@ cmdUnitsSynth = fmap CmdUnitsSynth unitsSynthOptions -cmdImplicitNone, cmdImplicitNoneAll, cmdInvariantsCheck :: Parser Command+cmdImplicitNone, cmdImplicitNoneAll, cmdInvariantsCheck, cmdAllocCheck, cmdFPCheck :: Parser Command cmdInvariantsCheck = fmap CmdInvariantsCheck invariantsOptions cmdImplicitNone = fmap CmdImplicitNone readOptions <*> logOptions cmdImplicitNoneAll = fmap CmdImplicitNoneAll readOptions <*> logOptions-+cmdAllocCheck = fmap CmdAllocCheck readOptions <*> logOptions+cmdFPCheck = fmap CmdFPCheck readOptions <*> logOptions+cmdUseCheck = fmap CmdUseCheck readOptions <*> logOptions+cmdArrayCheck = fmap CmdArrayCheck readOptions <*> logOptions cmdRefactCommon, cmdRefactDead, cmdRefactEquivalence :: Parser Command cmdRefactCommon = fmap CmdRefactCommon refactOptions cmdRefactDead = fmap CmdRefactDead refactOptions cmdRefactEquivalence = fmap CmdRefactEquivalence refactOptions +cmdInferDDT, cmdSynthDDT, cmdCheckDDT, cmdRefactDDT, cmdCompileDDT :: Parser Command+cmdInferDDT = fmap CmdInferDDT readOptions <*> logOptions+cmdSynthDDT = fmap CmdSynthDDT ddtSynthOptions+cmdCheckDDT = fmap CmdCheckDDT readOptions <*> logOptions+cmdRefactDDT = fmap CmdRefactDDT refactOptions+cmdCompileDDT = fmap CmdCompileDDT readOptions <*> logOptions+ -- | Helper for building a command alias. -- -- Command aliases will not show up in the help text, nor be subject to completion.@@ -431,6 +501,18 @@ , ("invariants-check", ["invariants-check","check-invariants", "check-hoare", "hoare-check"], cmdInvariantsCheck, "hoare logic invariant checking")+ , ("alloc-check",+ [],+ cmdAllocCheck, "check allocate/deallocate statement usage")+ , ("fp-check",+ [],+ cmdFPCheck, "check floating point usage")+ , ("use-check",+ [],+ cmdUseCheck, "check usage of module USE")+ , ("array-check",+ [],+ cmdArrayCheck, "check usage of arrays") ] @@ -438,10 +520,19 @@ refactoringsParser = commandsParser "Refactoring Commands" refactoringsCommands where refactoringsCommands =- [ ("common", [], cmdRefactCommon, "common block elimination")- , ("equivalence", [], cmdRefactEquivalence, "equivalence elimination")- , ("dead", [], cmdRefactDead, "dead-code elimination") ]+ [ ("common", [], cmdRefactCommon, "common block elimination")+ , ("equivalence", [], cmdRefactEquivalence, "equivalence elimination")+ , ("dead", [], cmdRefactDead, "dead-code elimination") ] +derivedDatatypeParser :: Parser Command+derivedDatatypeParser = commandsParser "Derived Datatype Commands" derivedDatatypeCommands+ where+ derivedDatatypeCommands =+ [ ("ddt-infer", ["infer-ddt"], cmdInferDDT, "infer derived datatypes")+ , ("ddt-synth", ["synth-ddt"], cmdSynthDDT, "synthesise comments for derived datatypes")+ , ("ddt-check", ["check-ddt"], cmdCheckDDT, "check comments for derived datatypes")+ , ("ddt-refactor", ["refactor-ddt"], cmdRefactDDT, "refactor marked derived datatypes from comments")+ , ("ddt-compile", ["compile-ddt"], cmdCompileDDT, "compile derived datatypes info")] topLevelCommands :: Parser Command topLevelCommands = versionOption@@ -467,11 +558,12 @@ helper <*> ( projectParser currDir <|> analysesParser <|> refactoringsParser+ <|> derivedDatatypeParser <|> topLevelCommands) -- | Current CamFort version.-version = "0.905"+version = "0.906" -- | Full CamFort version string.
tests/Camfort/Analysis/CommentAnnotatorSpec.hs view
@@ -18,7 +18,7 @@ import Camfort.Analysis.CommentAnnotator import Camfort.Specification.Parser (mkParser, parseError, SpecParser) -p = SrcSpan (Position 0 1 1) (Position 0 1 1)+p = SrcSpan (Position 0 1 1 "" Nothing) (Position 0 1 1 "" Nothing) annotateWith :: (String -> String) -> ProgramFile A -> ProgramFile A annotateWith s = runIdentity . annotateComments trivialParser ignore
tests/Camfort/Analysis/TestUtils.hs view
@@ -54,8 +54,8 @@ Just x -> return x Nothing -> getCurrentDirectory - modFiles <- genModFiles emptyModFiles simpleCompiler () incDir (input ^. tiExcludeFiles)- pfsTexts <- readParseSrcDir modFiles (input ^. tiInputSources) (input ^. tiExcludeFiles)+ modFiles <- getModFiles incDir+ pfsTexts <- readParseSrcDir Nothing modFiles (input ^. tiInputSources) (input ^. tiExcludeFiles) return (modFiles, pfsTexts)
tests/Camfort/ReprintSpec.hs view
@@ -58,15 +58,15 @@ -} it "takeBounds test 1" $- (fst $ takeBounds (FU.Position 0 2 2, FU.Position 0 5 2) btext)+ (fst $ takeBounds (FU.Position 0 2 2 "" Nothing, FU.Position 0 5 2 "" Nothing) btext) `shouldBe` (B.pack "A B") it "takeBounds test 2" $- (fst $ takeBounds (FU.Position 0 2 2, FU.Position 0 1 3) btext)+ (fst $ takeBounds (FU.Position 0 2 2 "" Nothing, FU.Position 0 1 3 "" Nothing) btext) `shouldBe` (B.pack "A B C D\n") it "takeBound test 3" $- (fst $ takeBounds (FU.Position 1 1 1, FU.Position 1 5 3) btext2)+ (fst $ takeBounds (FU.Position 1 1 1 "" Nothing, FU.Position 1 5 3 "" Nothing) btext2) `shouldBe` (B.pack $ unlines $ take 3 text2) -- TODO: Fix this@@ -88,16 +88,16 @@ instance Arbitrary (PlusOne FU.Position) where arbitrary = do- FU.Position offset col line <- arbitrary+ FU.Position offset col line f p <- arbitrary let col' = if line == 1 then col+1 else col- return $ PlusOne $ FU.Position offset col' (line + 1)+ return $ PlusOne $ FU.Position offset col' (line + 1) f p instance Arbitrary FU.Position where arbitrary = do offset <- arbitrary `suchThat` (>0) line <- arbitrary `suchThat` (\x -> x >= 1 && x <= (length text)) col <- choose (1, orOne $ length (text !! (line - 1)))- return $ FU.Position offset col line+ return $ FU.Position offset col line "<generated>" Nothing orOne x | x == 0 = 1 | otherwise = x
+ tests/Camfort/Specification/DerivedDataTypeSpec.hs view
@@ -0,0 +1,78 @@+module Camfort.Specification.DerivedDataTypeSpec (spec) where++import System.FilePath ((</>))++import Control.Lens++import Test.Hspec hiding (Spec)+import qualified Test.Hspec as Test++import qualified Language.Fortran.AST as F+import Language.Fortran.Util.ModFile (ModFile, emptyModFiles)++import Camfort.Analysis hiding (describe)+import Camfort.Analysis.ModFile (genModFiles)+import Camfort.Input (readParseSrcDir)+import Camfort.Specification.DerivedDataType++import qualified Data.Map.Strict as M+import qualified Data.Set as S++fixturesDir :: String+fixturesDir = "tests" </> "fixtures" </> "Specification" </> "DerivedDataType"++ddtInferReport :: [String] -> String -> IO DerivedDataTypeReport+ddtInferReport modNames fileName = do+ let file = fixturesDir </> fileName+ modPaths = fmap (fixturesDir </>) modNames+ modFiles <- mapM mkTestModFile modPaths+ [(pf,_)] <- readParseSrcDir Nothing modFiles file []++ let r = runIdentity $ runAnalysisT file (logOutputNone True) LogError modFiles (infer pf)+ return $ r ^?! arResult . _ARSuccess++-- | Helper for producing a basic ModFile from a (terminal) module file.+mkTestModFile :: String -> IO ModFile+mkTestModFile file = head <$> genModFiles Nothing emptyModFiles compile () file []++spec :: Test.Spec+spec = do+ describe "consistent" $ do+ describe "across modfiles" $ do+ it "consistent where labels overlap" $ do+ r <- ddtInferReport ["consistSpec1b.f90"] "consistSpec1a.f90"+ successful r `shouldBe` True+ it "starred spec overrides unstarred spec" $ do+ r <- ddtInferReport ["consistSpec2b.f90"] "consistSpec2a.f90"+ successful r `shouldBe` True+ describe "error-finding" $ do+ describe "bad dimensions" $ do+ it "dim violates min bound" $ do+ r <- ddtInferReport [] "badDim1.f90"+ map (fmap (fst . head . S.toList)) (M.toList (ddtrBDE r)) `shouldBe` [(("example_d_common", 0), 0)]+ it "dim violates max bound" $ do+ r <- ddtInferReport [] "badDim2.f90"+ map (fmap (fst . head . S.toList)) (M.toList (ddtrBDE r)) `shouldBe` [(("example_d_common", 3), 2)]+ describe "bad labelling" $ do+ it "dupped index" $ do+ r <- ddtInferReport [] "dupIndex1.f90"+ S.size (ddtrIDE r) `shouldBe` 1+ it "out-of-bounds index" $ do+ r <- ddtInferReport [] "oobIndex1.f90"+ S.size (ddtrIDE r) `shouldBe` 1+ it "dupped label" $ do+ r <- ddtInferReport [] "badLabel1.f90"+ map (fmap (fst . head . S.toList)) (M.toList (ddtrBLE r)) `shouldBe` [(("example_d_common", 2), "label1")]+ describe "inconsistent specs" $ do+ it "differing type names" $ do+ r <- ddtInferReport ["inconsistSpec1b.f90"] "inconsistSpec1a.f90"+ map (fmap S.size) (M.toList (ddtrCE r)) `shouldBe` [(("inconsist1_d_common", 2), 2)]+ it "clashing label names" $ do+ r <- ddtInferReport ["inconsistSpec2b.f90"] "inconsistSpec2a.f90"+ map (fmap S.size) (M.toList (ddtrCE r)) `shouldBe` [(("inconsist2_d_common", 2), 2)]+ it "disagreeing on label names" $ do+ r <- ddtInferReport ["inconsistSpec3b.f90"] "inconsistSpec3a.f90"+ map (fmap S.size) (M.toList (ddtrCE r)) `shouldBe` [(("inconsist3_d_common", 2), 2)]+ it "when starred specs disagree" $ do+ r <- ddtInferReport ["inconsistSpec4b.f90"] "inconsistSpec4a.f90"+ map (fmap S.size) (M.toList (ddtrCE r)) `shouldBe` [(("inconsist4_d_common", 2), 2)]
tests/Camfort/Specification/Hoare/ParserSpec.hs view
@@ -114,7 +114,7 @@ matches a b = stripSpans a == stripSpans b -defSpan = F.SrcSpan (F.Position 0 0 0) (F.Position 0 0 0)+defSpan = F.SrcSpan (F.Position 0 0 0 "" Nothing) (F.Position 0 0 0 "" Nothing) parse :: String -> Either (Parser.SpecParseError HoareParseError) (SpecOrDecl ()) parse = runParser hoareParser
tests/Camfort/Specification/StencilsSpec.hs view
@@ -284,6 +284,13 @@ assertStencilSynthNoWarn "example5.f90" "inserts correct comment types for modern fortran" + describe "integration test on inference for example5a (with constant-prop.)" $+ describe "stencil synth" $ do+ assertStencilSynthNoWarn "example5a.f"+ "inserts correct comment types for old fortran"+ assertStencilSynthNoWarn "example5a.f90"+ "inserts correct comment types for modern fortran"+ describe "synth on files already containing stencils" $ do assertStencilSynthNoWarn "example6.f" "complements existing stencils (when second missing)"@@ -455,7 +462,7 @@ modPaths = fmap (fixturesDir </>) modNames modFiles <- mapM mkTestModFile modPaths- [(pf, _)] <- readParseSrcDir modFiles file []+ [(pf, _)] <- readParseSrcDir Nothing modFiles file [] let report = runIdentity $ runAnalysisT (F.pfGetFilename pf) (logOutputNone True) LogError modFiles (infer False '=' pf) @@ -463,7 +470,7 @@ -- | Helper for producing a basic ModFile from a (terminal) module file. mkTestModFile :: String -> IO ModFile-mkTestModFile file = head <$> genModFiles emptyModFiles compileStencils () file []+mkTestModFile file = head <$> genModFiles Nothing emptyModFiles compileStencils () file [] crossModuleAUserReport :: [L.Text] crossModuleAUserReport =
tests/Camfort/Specification/Units/Analysis/ConsistentSpec.hs view
@@ -60,7 +60,7 @@ let file = fixturesDir </> fileName modPaths = fmap (fixturesDir </>) modNames modFiles <- mapM mkTestModFile modPaths- [(pf,_)] <- readParseSrcDir modFiles file []+ [(pf,_)] <- readParseSrcDir Nothing modFiles file [] let uEnv = UnitEnv { unitOpts = uOpts, unitProgramFile = pf } @@ -82,7 +82,7 @@ -- | Helper for producing a basic ModFile from a (terminal) module file. mkTestModFile :: String -> IO ModFile-mkTestModFile file = head <$> genModFiles emptyModFiles compileUnits unitOpts0 file []+mkTestModFile file = head <$> genModFiles Nothing emptyModFiles compileUnits unitOpts0 file [] exampleInconsist1CheckReport :: String exampleInconsist1CheckReport =@@ -90,62 +90,54 @@ \ - at 7:7: Units 's' and 'm' should be equal\n" inconsist3LitMixedReport :: String-inconsist3LitMixedReport = inconsist3LitPolyReport+inconsist3LitMixedReport =+ "\ntests/fixtures/Specification/Units/inconsist3.f90: Inconsistent:\n\+ \ - at 6:3: 'j**2' should have the same units as 'k'\n" inconsist3LitPolyReport :: String inconsist3LitPolyReport = "\ntests/fixtures/Specification/Units/inconsist3.f90: Inconsistent:\n\- \ - at 6:3: 'j**2' should have the same units as 'k'\n\- \ - at 7:7: 'k' should have unit 'a'\n\- \ - at 8:3: 'j' should have unit '1'\n"+ \ - at 6:3: 'j**2' should have the same units as 'k'\n" inconsist3LitUnitlessReport :: String inconsist3LitUnitlessReport = "\ntests/fixtures/Specification/Units/inconsist3.f90: Inconsistent:\n\- \ - at 5:3: 'j' should have unit '1'\n\- \ - at 6:3: 'j**2' should have the same units as 'k'\n\- \ - at 7:7: 'k' should have unit 'a'\n"+ \ - at 6:3: 'j**2' should have the same units as 'k'\n" inconsistLitInPolyFunReport :: String inconsistLitInPolyFunReport = "\ntests/fixtures/Specification/Units/inconsistLitInPolyFun.f90: Inconsistent:\n\- \ - at 10:11: 'parameter 1 to sqr' should have unit 'm'\n\- \ - at 15:13: 'z' should have unit '1'\n\- \ - at 16:11: '(parameter 1 to sqr)**2' should have the same units as 'z'\n"+ \ - at 10:3: 'a' should have the same units as 'result of sqr'\n\+ \ - at 10:11: 'parameter 1 to sqr' should have unit 'm'\n" inconsistRecMultReport :: String inconsistRecMultReport = "\ntests/fixtures/Specification/Units/inconsistRecMult.f90: Inconsistent:\n\- \'parameter 2 to recur' should have the same units as 'parameter 2 to recur'\n\- \'result of recur * parameter 2 to recur' should have the same units as 'result of recur'\n\- \ - at 4:15: 'parameter 2 to recur' should have unit 'm'\n\- \ - at 10:8: 'parameter 2 to recur' should have the same units as 'result of recur'\n"+ \ - at 4:15: 'parameter 2 to recur' should have unit 'm'\n" crossModuleInconsistBasicReport :: String crossModuleInconsistBasicReport = "\ntests/fixtures/Specification/Units/cross-module-a/crossmoduleuser.f90: Inconsistent:\n\- \'add' should have the same units as 'parameter 1 to add'\n\- \'add' should have the same units as 'parameter 2 to add'\n\- \ - at 9:11: 'parameter 1 to add' should have unit 'm'\n\- \ - at 9:14: 'parameter 2 to add' should have unit 's'\n"+ \ - at 9:11: 'parameter 1 to add' should have unit 'm'\n" literalNonZeroInconsist1Report :: String literalNonZeroInconsist1Report = "\ntests/fixtures/Specification/Units/literal-nonzero-inconsist1.f90: Inconsistent:\n\- \ - at 11:5: 'f_'a' should have unit '1'\n"+ \'literal number' should have unit '1'\n" literalNonZeroInconsist2Report :: String literalNonZeroInconsist2Report = "\ntests/fixtures/Specification/Units/literal-nonzero-inconsist2.f90: Inconsistent:\n\- \ - at 5:9: 'parameter 1 to f' should have unit 'm'\n\- \ - at 10:5: 'parameter 1 to f' should have unit '1'\n"+ \ - at 6:3: 'b' should have the same units as 'result of f'\n\+ \ - at 6:9: 'parameter 1 to f' should have unit 'm'\n" literalNonZeroInconsist3Report :: String literalNonZeroInconsist3Report = "\ntests/fixtures/Specification/Units/literal-nonzero-inconsist3.f90: Inconsistent:\n\- \ - at 7:11: 'parameter 1 to sqr' should have unit 's'\n\- \ - at 12:3: 'i' should have the same units as 'parameter 1 to sqr'\n\- \ - at 15:8: 'i' should have unit '1'\n"+ \ - at 6:3: 'result of sqr' should have unit 'm'\n\+ \ - at 6:11: 'parameter 1 to sqr' should have unit 'm'\n\+ \ - at 7:3: 'result of sqr' should have unit 's'\n\+ \ - at 7:11: 'parameter 1 to sqr' should have unit 's'\n" literalNonZeroInconsist4Report :: String -- fixme literalNonZeroInconsist4Report =@@ -157,7 +149,5 @@ literalNonZeroInconsist5Report :: String literalNonZeroInconsist5Report = "\ntests/fixtures/Specification/Units/literal-nonzero-inconsist5.f90: Inconsistent:\n\- \ - at 7:11: 'parameter 1 to sqr' should have unit 's'\n\- \ - at 13:23: 'j' should have unit '1'\n\- \ - at 15:9: 'i' should have the same units as 'parameter 1 to sqr'\n\- \ - at 17:12: 'j' should have the same units as 'i'\n"+ \ - at 6:3: 'result of sqr' should have unit 'm'\n\+ \ - at 6:11: 'parameter 1 to sqr' should have unit 'm'\n"
tests/Camfort/Specification/Units/Analysis/CriticalsSpec.hs view
@@ -32,7 +32,7 @@ unitsCriticalsReportIs fileName expectedReport = do let file = fixturesDir </> fileName modFiles = emptyModFiles- [(pf,_)] <- readParseSrcDir modFiles file []+ [(pf,_)] <- readParseSrcDir Nothing modFiles file [] let uEnv = UnitEnv { unitOpts = uOpts, unitProgramFile = pf }
tests/Camfort/Specification/Units/Analysis/InferSpec.hs view
@@ -7,10 +7,11 @@ import Test.Hspec hiding (Spec) import qualified Test.Hspec as Test -import Language.Fortran.Util.ModFile (emptyModFiles)+import Language.Fortran.Util.ModFile (ModFile, emptyModFiles) import Camfort.Analysis hiding (describe)-import Camfort.Analysis.ModFile (readParseSrcDir)+import Camfort.Analysis.ModFile (genModFiles, readParseSrcDir)+import Camfort.Specification.Units.Analysis (compileUnits) import Camfort.Specification.Units.Analysis.Infer (inferUnits) import Camfort.Specification.Units.Monad (LiteralsOpt(..), unitOpts0, uoLiterals, runUnitAnalysis, UnitEnv(..))@@ -50,21 +51,34 @@ "literal-zero.f90" `unitsInferReportIs` literalZeroReport it "literal-nonzero" $ "literal-nonzero.f90" `unitsInferReportIs` literalNonZeroReport+ it "literal-nonzero" $+ "literal-nonzero2.f90" `unitsInferReportIs` literalNonZero2Report it "do-loop1" $ "do-loop1.f90" `unitsInferReportIs` doLoop1Report it "do-loop2" $ "do-loop2.f90" `unitsInferReportIs` doLoop2Report+ describe "cross module analysis" $ do+ it "with literals" $+ unitsInferReportWithMod ["cross-module-b/cross-module-b1.f90"] "cross-module-b/cross-module-b2.f90"+ crossModuleBReport + fixturesDir :: String fixturesDir = "tests" </> "fixtures" </> "Specification" </> "Units" -- | Assert that the report of performing units inference on a file is as expected. unitsInferReportIs :: String -> String -> Expectation unitsInferReportIs fileName expectedReport = do+ unitsInferReportWithMod [] fileName expectedReport++-- | Assert that the report of performing units inference on a file is as expected (with mod files).+unitsInferReportWithMod :: [String] -> String -> String -> Expectation+unitsInferReportWithMod modNames fileName expectedReport = do let file = fixturesDir </> fileName- modFiles = emptyModFiles- [(pf,_)] <- readParseSrcDir modFiles file []+ modPaths = fmap (fixturesDir </>) modNames+ modFiles <- mapM mkTestModFile modPaths+ [(pf,_)] <- readParseSrcDir Nothing modFiles file [] let uEnv = UnitEnv { unitOpts = uOpts, unitProgramFile = pf } @@ -74,6 +88,10 @@ show res `shouldBe` expectedReport where uOpts = unitOpts0 { uoLiterals = LitMixed } +-- | Helper for producing a basic ModFile from a (terminal) module file.+mkTestModFile :: String -> IO ModFile+mkTestModFile file = head <$> genModFiles Nothing emptyModFiles compileUnits unitOpts0 file []+ exampleInferSimple1Report :: String exampleInferSimple1Report = "\ntests/fixtures/Specification/Units/example-simple-1.f90:\n\@@ -89,10 +107,10 @@ \ 5:11 unit s**2 :: y\n\ \ 7:11 unit m :: a\n\ \ 9:11 unit s :: b\n\- \ 13:3 unit ('a)**2 :: square\n\- \ 14:13 unit 'a :: n\n\- \ 17:3 unit ('b)**2 :: squarep\n\- \ 18:13 unit 'b :: m\n"+ \ 13:3 unit ('b)**2 :: square\n\+ \ 14:13 unit 'b :: n\n\+ \ 17:3 unit ('a)**2 :: squarep\n\+ \ 18:13 unit 'a :: m\n" recursive1Report :: String recursive1Report = inferReport "recursive1.f90"@@ -185,6 +203,15 @@ \ 8:3 unit m s :: f\n\ \ 10:13 unit m s :: x\n" +literalNonZero2Report :: String+literalNonZero2Report = inferReport "literal-nonzero2.f90"+ " 3:11 unit m :: a\n\+ \ 3:14 unit m :: b\n\+ \ 3:17 unit m :: c\n\+ \ 3:20 unit m :: d\n\+ \ 10:3 unit m :: f\n\+ \ 11:13 unit m :: x\n"+ doLoop1Report :: String doLoop1Report = inferReport "do-loop1.f90" " 3:11 unit m :: x\n\@@ -212,3 +239,10 @@ \ 29:13 unit 'a :: x\n\ \ 29:16 unit 'a :: y\n\ \ 30:16 unit 'a :: i\n"++crossModuleBReport :: String+crossModuleBReport =+ "\ntests/fixtures/Specification/Units/cross-module-b/cross-module-b2.f90:\n\+ \ 6:24 unit c :: foo\n\+ \ 9:13 unit c :: tc\n\+ \ 9:17 unit k :: t\n"
tests/Camfort/Transformation/CommonSpec.hs view
@@ -37,6 +37,8 @@ , ceIncludeDir = Just (takeDirectory commonFile) , ceExcludeFiles = [] , ceLogLevel = LogDebug+ , ceSourceSnippets = False+ , ceFortranVersion = Nothing } runIO $ common outFile env
tests/Camfort/Transformation/EquivalenceElimSpec.hs view
@@ -59,6 +59,8 @@ , ceIncludeDir = Nothing , ceExcludeFiles = [] , ceLogLevel = LogInfo+ , ceSourceSnippets = False+ , ceFortranVersion = Nothing } equivalences outFile env@@ -76,7 +78,7 @@ let infile = samplesBase </> "equiv.f90" - input = testInputSources infile & tiIncludeDir .~ Just infile+ input = testInputSources infile it "log is as expected" $ testSingleFileAnalysis input (generalizePureAnalysis . refactorEquivalences) $ \report -> do@@ -91,7 +93,7 @@ , ((15, 3), addCopyMsg) ] - spanMatches (pl, pc) (FU.SrcSpan (FU.Position _ pc1 pl1) (FU.Position _ pc2 pl2)) =+ spanMatches (pl, pc) (FU.SrcSpan (FU.Position _ pc1 pl1 _ _) (FU.Position _ pc2 pl2 _ _)) = pl == pl1 && pl == pl2 && pc == pc1 && pc == pc2
+ tests/fixtures/Specification/Stencils/example10.expected.f view
@@ -0,0 +1,15 @@+ program example10++ integer i, imax+ parameter (imax = 3)++ real a(0:imax), b(0:imax)++ do 1 i = 1, (imax-1)+ if (.true.) then+c= stencil readOnce, (pointed(dim=1)) :: b+ a(i) = b(i)+ end if+ 1 continue++ end
+ tests/fixtures/Specification/Stencils/example11.expected.f view
@@ -0,0 +1,15 @@+ program example11++ integer i, imax+ parameter (imax = 3)++ real a(0:imax), b(0:imax), x++ do 1 i = 1, (imax-1)+ if (.true.) then+c= access readOnce, pointed(dim=1) :: b+ x = b(i)+ end if+ 1 continue++ end
+ tests/fixtures/Specification/Stencils/example13.expected.f view
@@ -0,0 +1,15 @@+ program example13+ implicit none++ integer i, imax+ parameter (imax = 3)+ real a(0:imax)++c= region :: r1 = pointed(dim=1)+ do i = 0, imax+c= stencil readOnce, atLeast, r1 :: a+c= stencil readOnce, atMost, forward(depth=2, dim=1) :: a+ a(i) = a(i) + a(i+2)+ end do++ end
+ tests/fixtures/Specification/Stencils/example14.expected.f view
@@ -0,0 +1,15 @@+ program example14+ implicit none++ integer i, imax+ parameter (imax = 3)+ real a(0:imax)++ do i = 0, imax+c= stencil readOnce, atLeast, pointed(dim=1) :: a+c= stencil readOnce, atLeast, pointed(dim=1) :: a+c= stencil readOnce, atMost, forward(depth=2, dim=1) :: a+ a(i) = a(i) + a(i+2)+ end do++ end
+ tests/fixtures/Specification/Stencils/example15.expected.f view
@@ -0,0 +1,13 @@+ program example15+ implicit none++ integer i+ real a(0:10)++ do i = 0, 10+c= stencil readOnce, forward(depth=1, dim=1) :: a+c= stencil readOnce, forward(depth=1, dim=1) :: a+ a(i) = a(i) + a(i+1)+ end do++ end
+ tests/fixtures/Specification/Stencils/example5.expected.f view
@@ -0,0 +1,14 @@+ program example5+ implicit none++ integer i, imax+ parameter (imax = 3)+ real a(0:imax)++ do i = 0, imax+c= stencil readOnce, atLeast, pointed(dim=1) :: a+c= stencil readOnce, atMost, forward(depth=2, dim=1) :: a+ a(i) = a(i) + a(i+2)+ end do++ end
+ tests/fixtures/Specification/Stencils/example5a.expected.f view
@@ -0,0 +1,14 @@+ program example5+ implicit none++ integer i, imax, x+ parameter (imax = 3, x = (1+1)*imax-2*(1+1))+ real a(0:imax)++ do i = 0, imax+c= stencil readOnce, atLeast, pointed(dim=1) :: a+c= stencil readOnce, atMost, forward(depth=2, dim=1) :: a+ a(i) = a(i) + a(i+x)+ end do++ end
+ tests/fixtures/Specification/Stencils/example5a.f view
@@ -0,0 +1,12 @@+ program example5+ implicit none++ integer i, imax, x+ parameter (imax = 3, x = (1+1)*imax-2*(1+1))+ real a(0:imax)++ do i = 0, imax+ a(i) = a(i) + a(i+x)+ end do++ end
+ tests/fixtures/Specification/Stencils/example6.expected.f view
@@ -0,0 +1,14 @@+ program example6+ implicit none++ integer i, imax+ parameter (imax = 3)+ real a(0:imax)++ do i = 0, imax+c= stencil readOnce, atLeast, pointed(dim=1) :: a+c= stencil readOnce, atMost, forward(depth=2, dim=1) :: a+ a(i) = a(i) + a(i+2)+ end do++ end
+ tests/fixtures/Specification/Stencils/example7.expected.f view
@@ -0,0 +1,14 @@+ program example7+ implicit none++ integer i, imax+ parameter (imax = 3)+ real a(0:imax)++ do i = 0, imax+c= stencil readOnce, atLeast, pointed(dim=1) :: a+c= stencil readOnce, atMost, forward(depth=2, dim=1) :: a+ a(i) = a(i) + a(i+2)+ end do++ end
+ tests/fixtures/Specification/Stencils/example8.expected.f view
@@ -0,0 +1,14 @@+ program example8+ implicit none++ integer i, imax+ parameter (imax = 3)+ real a(0:imax)++ do i = 0, imax+c= stencil readOnce, atMost, forward(depth=2, dim=1) :: a+c= stencil readOnce, atLeast, pointed(dim=1) :: a+ a(i) = a(i) + a(i+2)+ end do++ end
+ tests/fixtures/Specification/Stencils/example9.expected.f view
@@ -0,0 +1,13 @@+ program example9++ integer i, imax+ parameter (imax = 3)++ real a(0:imax), b(0:imax)++ do 1 i = 1, (imax-1)+c= stencil readOnce, pointed(dim=1) :: b+ a(i) = b(i)+ 1 continue++ end
+ tests/fixtures/Specification/Units/exp.ex1.f90 view
@@ -0,0 +1,29 @@+program energy+ != unit :: speed = m/s++ != unit (m / s** (2)) :: gravity+ != unit (m) :: height+ != unit (kg) :: mass+ real, parameter :: mass = 3.00, gravity = 9.81, height = 4.20+ != unit (kg m** (2) / s** (2)) :: potential_energy+ real :: potential_energy++ != unit (1) :: half+ != unit (speed) :: velocity+ real, parameter :: half = 0.5, velocity = 4.00+ != unit (kg m** (2) / s** (2)) :: kinetic_energy+ != unit (kg m** (2) / s** (2)) :: total_energy+ real :: kinetic_energy, total_energy++ potential_energy = mass * gravity * height+ kinetic_energy = half * mass * square(velocity)++ total_energy = potential_energy + kinetic_energy++ contains++ real function square(x)+ real x+ square = x * x+ end function square+end program energy
+ tests/fixtures/Specification/Units/exp.ex2.f90 view
@@ -0,0 +1,12 @@+program energy++ != unit (m) :: height+ != unit (kg) :: mass+ != unit (m / s**2) :: gravity+ real, parameter :: mass = 3.00, gravity = .81, height = 4.20++ != unit (kg m** (2) / s** (2)) :: potential_energy+ real :: potential_energy+ + potential_energy = mass * gravity * height+end program energy
+ tests/fixtures/Specification/Units/exp.ex3.f90 view
@@ -0,0 +1,17 @@+program energy++ != unit (m) :: height+ != unit (kg) :: mass+ != unit (m / s**2) :: gravity+ real, parameter :: mass = 3.00, gravity = .81, height = 4.20++ != unit (1) :: i+ integer :: i = 0+ != unit (1) :: j+ integer :: j = i+ + != unit (kg m**2 / s**2) :: potential_energy+ real :: potential_energy+ + potential_energy = mass * gravity * height+end program energy
+ tests/fixtures/Specification/Units/exp.param.f90 view
@@ -0,0 +1,12 @@+ program param+ implicit none+ != unit(m) :: x, y+ real, parameter :: x = 4, y = 5+ != unit(s) :: t+ real, parameter :: t = 2+ != unit (m / s) :: v1+ != unit (m / s) :: v2+ real :: v1, v2+ v1 = x / t+ v2 = y / t+ end program
tests/fixtures/Specification/Units/literal-nonzero-inconsist2.f90 view
@@ -1,9 +1,11 @@ program literalnonzero != unit m :: a- real :: a, b+ != unit s :: c+ real :: a, b, c, d a = 2 b = f(a)-+ c = 3+ d = f(c) contains real function f(x) real :: x
tests/fixtures/Specification/Units/literal-nonzero-inconsist3.f90 view
@@ -31,6 +31,7 @@ ! ! with it enabled (normal): ! tests/fixtures/Specification/Units/literal-nonzero-inconsist3.f90: Inconsistent:-! - at 7:11: 'parameter 1 to sqr' should have unit 's'-! - at 12:3: 'i' should have the same units as 'parameter 1 to sqr'-! - at 15:8: 'i' should have unit '1'+! - at 6:3: 'result of sqr' should have unit 'm'+! - at 6:11: 'parameter 1 to sqr' should have unit 'm'+! - at 7:3: 'result of sqr' should have unit 's'+! - at 7:11: 'parameter 1 to sqr' should have unit 's'
tests/fixtures/Specification/Units/literal-nonzero-inconsist5.f90 view
@@ -34,6 +34,5 @@ ! ! with it enabled (normal): ! tests/fixtures/Specification/Units/literal-nonzero-inconsist5.f90: Inconsistent:-! - at 7:11: 'parameter 1 to sqr' should have unit 's'-! - at 15:9: 'i' should have the same units as 'parameter 1 to sqr'-! - at 17:12: 'i' should have unit '1'+! - at 6:3: 'result of sqr' should have unit 'm'+! - at 6:11: 'parameter 1 to sqr' should have unit 'm'
+ tests/fixtures/Specification/Units/literal-nonzero2.f90 view
@@ -0,0 +1,15 @@+program literalnonzero+ != unit m :: a, c+ real :: a, b, c, d+ real, parameter :: n = 1.0+ a = 2.0+ b = f(a)+ c = 3.0+ d = f(c)+contains+ real function f(x)+ real :: x+ x = n+ f = x+ end function f+end program literalnonzero
+ tests/fixtures/Transformation/cmn.expected.f90 view
@@ -0,0 +1,5 @@+module Cmn+ integer, save :: Cmn_c1+ integer, save :: Cmn_c2+ integer, save :: Cmn_c3+end module Cmn
+ tests/fixtures/Transformation/common.expected.f90 view
@@ -0,0 +1,9 @@+subroutine test(a,b, c)++use Cmn, c1 => Cmn_c1, c2 => Cmn_c2, c3 => Cmn_c3++real :: a, b, c++print *, a, b, c++end subroutine test
+ tests/fixtures/Transformation/equiv.expected.f90 view
@@ -0,0 +1,21 @@+program wrt + implicit none+ integer :: x = 97+ character :: y+ character :: z(20)++ z(1) = "c"++ write (*,'(i8,A)') x, y+++ write (*,'(i8,A,A,A)') x, y, z(1), z(2)++ x = 97 + 98 * (2**8)+ y = transfer(x, y)+ z(2) = transfer(x, z(2))++ write (*,'(i8,A,A,A,A)') x, y, z(1), z(2), z(3)+++end program wrt