├── .envrc ├── .github └── workflows │ ├── ci.yml │ ├── disabled │ └── hackage.yml │ └── nix.yml ├── .gitignore ├── .travis.yml ├── ACKNOWLEDGMENTS.md ├── CHANGELOG.md ├── CITATION.cff ├── LICENSE ├── README.md ├── Setup.hs ├── TODO.md ├── app └── Main.hs ├── flake.lock ├── flake.nix ├── fortran-src.cabal ├── haskell-flake-ghc92.nix ├── haskell-flake-ghc94.nix ├── package.yaml ├── src ├── Language │ └── Fortran │ │ ├── AST.hs │ │ ├── AST │ │ ├── AList.hs │ │ ├── Annotated.hs │ │ ├── Common.hs │ │ ├── Literal.hs │ │ └── Literal │ │ │ ├── Boz.hs │ │ │ ├── Complex.hs │ │ │ └── Real.hs │ │ ├── Analysis.hs │ │ ├── Analysis │ │ ├── BBlocks.hs │ │ ├── DataFlow.hs │ │ ├── ModGraph.hs │ │ ├── Renaming.hs │ │ ├── SemanticTypes.hs │ │ └── Types.hs │ │ ├── Common │ │ └── Array.hs │ │ ├── Intrinsics.hs │ │ ├── LValue.hs │ │ ├── Parser.hs │ │ ├── Parser │ │ ├── Fixed │ │ │ ├── Fortran66.y │ │ │ ├── Fortran77.y │ │ │ ├── Lexer.x │ │ │ └── Utils.hs │ │ ├── Free │ │ │ ├── Fortran2003.y │ │ │ ├── Fortran90.y │ │ │ ├── Fortran95.y │ │ │ ├── Lexer.x │ │ │ └── Utils.hs │ │ ├── LexerUtils.hs │ │ ├── Monad.hs │ │ └── ParserUtils.hs │ │ ├── PrettyPrint.hs │ │ ├── Repr.hs │ │ ├── Repr │ │ ├── Compat │ │ │ └── Natural.hs │ │ ├── Eval │ │ │ ├── Common.hs │ │ │ ├── Type.hs │ │ │ ├── Value.hs │ │ │ └── Value │ │ │ │ └── Op.hs │ │ ├── Tmp.hs │ │ ├── Type.hs │ │ ├── Type │ │ │ ├── Array.hs │ │ │ ├── Scalar.hs │ │ │ └── Scalar │ │ │ │ ├── Common.hs │ │ │ │ ├── Complex.hs │ │ │ │ ├── Int.hs │ │ │ │ ├── Real.hs │ │ │ │ └── String.hs │ │ ├── Util.hs │ │ ├── Value.hs │ │ └── Value │ │ │ ├── Common.hs │ │ │ ├── Machine.hs │ │ │ ├── Scalar.hs │ │ │ └── Scalar │ │ │ ├── Common.hs │ │ │ ├── Complex.hs │ │ │ ├── Int.hs │ │ │ ├── Int │ │ │ ├── Idealized.hs │ │ │ └── Machine.hs │ │ │ ├── Logical.hs │ │ │ ├── Logical │ │ │ ├── Idealized.hs │ │ │ └── Machine.hs │ │ │ ├── Machine.hs │ │ │ ├── Real.hs │ │ │ └── String.hs │ │ ├── Rewriter.hs │ │ ├── Rewriter │ │ └── Internal.hs │ │ ├── Transformation │ │ ├── Disambiguation │ │ │ ├── Function.hs │ │ │ └── Intrinsic.hs │ │ ├── Grouping.hs │ │ └── Monad.hs │ │ ├── Util │ │ ├── Files.hs │ │ ├── FirstParameter.hs │ │ ├── ModFile.hs │ │ ├── Position.hs │ │ └── SecondParameter.hs │ │ └── Version.hs └── Text │ └── PrettyPrint │ └── GenericPretty │ ├── Orphans.hs │ └── ViaShow.hs ├── stack.yaml ├── stack.yaml.lock ├── test-data ├── f77-include │ ├── foo.f │ └── no-newline │ │ └── foo.f ├── module │ ├── leaf.f90 │ ├── mid1.f90 │ ├── mid2.f90 │ └── top.f90 └── rewriter │ ├── replacementsmap-columnlimit │ ├── 001_foo.f │ ├── 001_foo.f.expected │ ├── 002_other.f │ ├── 002_other.f.expected │ ├── 003_multiline.f │ ├── 003_multiline.f.expected │ ├── 004_comment.f │ ├── 004_comment.f.expected │ ├── 005_removals.f │ ├── 005_removals.f.expected │ ├── 006_linewrap_heuristic.f │ └── 006_linewrap_heuristic.f.expected │ ├── replacementsmap-insertion │ ├── 001_foo.f │ └── 001_foo.f.expected │ ├── replacementsmap-overlapping-filtered │ ├── 001_foo.f │ └── 001_foo.f.expected │ ├── replacementsmap-overlapping │ ├── 001_foo.f │ └── 001_foo.f.expected │ ├── replacementsmap-padimplicitcomment │ ├── 001_foo.f │ └── 001_foo.f.expected │ ├── replacementsmap-simple │ ├── 001_foo.f │ ├── 001_foo.f.expected │ ├── 002_foo.f │ ├── 002_foo.f.expected │ ├── 003_foo.f │ ├── 003_foo.f.expected │ ├── 004_unicode.f │ ├── 004_unicode.f.expected │ ├── 005_unicode.f │ └── 005_unicode.f.expected │ └── temp-failure │ └── fail.f ├── test ├── Language │ └── Fortran │ │ ├── AST │ │ └── Literal │ │ │ ├── BozSpec.hs │ │ │ └── RealSpec.hs │ │ ├── Analysis │ │ ├── BBlocksSpec.hs │ │ ├── DataFlowSpec.hs │ │ ├── ModFileSpec.hs │ │ ├── ModGraphSpec.hs │ │ ├── RenamingSpec.hs │ │ ├── SemanticTypesSpec.hs │ │ └── TypesSpec.hs │ │ ├── AnalysisSpec.hs │ │ ├── Parser │ │ ├── Fixed │ │ │ ├── Fortran66Spec.hs │ │ │ ├── Fortran77 │ │ │ │ ├── IncludeSpec.hs │ │ │ │ └── ParserSpec.hs │ │ │ └── LexerSpec.hs │ │ ├── Free │ │ │ ├── Common.hs │ │ │ ├── Fortran2003Spec.hs │ │ │ ├── Fortran2008Spec.hs │ │ │ ├── Fortran90Spec.hs │ │ │ ├── Fortran95Spec.hs │ │ │ └── LexerSpec.hs │ │ └── MonadSpec.hs │ │ ├── PrettyPrintSpec.hs │ │ ├── Repr │ │ └── EvalSpec.hs │ │ ├── Rewriter │ │ └── InternalSpec.hs │ │ ├── RewriterSpec.hs │ │ ├── Transformation │ │ ├── Disambiguation │ │ │ └── FunctionSpec.hs │ │ └── GroupingSpec.hs │ │ └── Util │ │ ├── FirstParameterSpec.hs │ │ └── SecondParameterSpec.hs ├── Spec.hs └── TestUtil.hs └── upgrade-guide.md /.envrc: -------------------------------------------------------------------------------- 1 | use flake 2 | -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | on: 4 | push: 5 | branches: 6 | - master 7 | pull_request: 8 | types: 9 | - opened 10 | - synchronize 11 | 12 | env: 13 | EXE_NAME: fortran-src 14 | 15 | jobs: 16 | ubuntu-stack-test: 17 | runs-on: ubuntu-latest 18 | name: Ubuntu / Stack / test 19 | steps: 20 | - uses: actions/checkout@v2 21 | 22 | # relative paths are relative to the project directory 23 | - name: Cache Stack build artifacts (user + project) 24 | uses: actions/cache@v2 25 | with: 26 | path: | 27 | ~/.stack 28 | .stack-work 29 | # best effort for cache: tie it to Stack resolver and package config 30 | key: ${{ runner.os }}-stack-${{ hashFiles('stack.yaml.lock', 'package.yaml') }} 31 | restore-keys: | 32 | ${{ runner.os }}-stack 33 | 34 | - name: Install project dependencies 35 | run: stack --no-terminal test --only-dependencies 36 | 37 | - name: Build and run tests 38 | run: stack --no-terminal haddock --test --no-haddock-deps 39 | 40 | - name: Install (to place executable at a known location) 41 | run: stack --no-terminal install 42 | 43 | - name: Upload executable 44 | uses: actions/upload-artifact@v4 45 | with: 46 | path: ~/.local/bin/${{ env.EXE_NAME }} 47 | name: ${{ env.EXE_NAME }}-ubuntu-stack-${{ github.sha }} 48 | if-no-files-found: error 49 | 50 | ubuntu-cabal-test: 51 | runs-on: ubuntu-latest 52 | name: Ubuntu / GHC ${{ matrix.ghc }}, Cabal / test 53 | 54 | strategy: 55 | fail-fast: false # don't stop if one job (= GHC version) fails 56 | matrix: 57 | cabal: [latest] 58 | ghc: 59 | - "9.0" 60 | - "9.2" 61 | - "9.4" 62 | 63 | steps: 64 | 65 | # TODO: GHC decides to recompile based on timestamp, so cache isn't used 66 | # Preferably GHC would work via hashes instead. Stack had this feature 67 | # merged in Aug 2020. 68 | # Upstream GHC issue: https://gitlab.haskell.org/ghc/ghc/-/issues/16495 69 | # My issue on haskell/actions: https://github.com/haskell/actions/issues/41 70 | # This also requires us to do a deep fetch, else we don't get the Git commit 71 | # history we need to rewrite mod times. 72 | - uses: actions/checkout@v2 73 | with: 74 | fetch-depth: 0 75 | - name: Set all tracked file modification times to the time of their last commit 76 | run: | 77 | rev=HEAD 78 | for f in $(git ls-tree -r -t --full-name --name-only "$rev") ; do 79 | touch -d $(git log --pretty=format:%cI -1 "$rev" -- "$f") "$f"; 80 | done 81 | 82 | - name: Setup Haskell build environment 83 | id: setup-haskell-build-env 84 | uses: haskell/actions/setup@v2 85 | with: 86 | ghc-version: ${{ matrix.ghc }} 87 | cabal-version: ${{ matrix.cabal }} 88 | 89 | - run: cabal freeze 90 | 91 | - name: Cache Cabal build artifacts 92 | uses: actions/cache@v2 93 | with: 94 | path: | 95 | ${{ steps.setup-haskell-build-env.outputs.cabal-store }} 96 | dist-newstyle 97 | key: ${{ runner.os }}-cabal-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }} 98 | restore-keys: | 99 | ${{ runner.os }}-cabal-${{ matrix.ghc }} 100 | 101 | - name: Test 102 | run: cabal test --test-show-details=streaming 103 | env: 104 | HSPEC_OPTIONS: --color 105 | 106 | mac-cabal-test: 107 | runs-on: macos-latest 108 | name: Mac / GHC ${{ matrix.ghc }}, Cabal / test 109 | strategy: 110 | fail-fast: false # don't stop if one job (= GHC version) fails 111 | matrix: 112 | cabal: [latest] 113 | ghc: ["9.2"] 114 | steps: 115 | 116 | # TODO figure out timestamp fixer on Mac (no Mac available to test) 117 | - uses: actions/checkout@v2 118 | 119 | - name: Setup Haskell build environment 120 | id: setup-haskell-build-env 121 | uses: haskell/actions/setup@v2 122 | with: 123 | ghc-version: ${{ matrix.ghc }} 124 | cabal-version: ${{ matrix.cabal }} 125 | 126 | - run: cabal freeze 127 | 128 | - name: Cache Cabal build artifacts 129 | uses: actions/cache@v2 130 | with: 131 | path: | 132 | ${{ steps.setup-haskell-build-env.outputs.cabal-store }} 133 | dist-newstyle 134 | key: ${{ runner.os }}-cabal-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }} 135 | restore-keys: | 136 | ${{ runner.os }}-cabal-${{ matrix.ghc }} 137 | 138 | - name: Build 139 | run: cabal install 140 | 141 | - name: Test 142 | run: cabal test --test-show-details=streaming 143 | env: 144 | HSPEC_OPTIONS: --color 145 | 146 | # note that Cabal uses symlinks -- actions/upload-artifact@v4 apparently 147 | # dereferences for us 148 | - name: Upload executable 149 | uses: actions/upload-artifact@v4 150 | with: 151 | path: ~/.cabal/bin/${{ env.EXE_NAME }} 152 | name: ${{ env.EXE_NAME }}-macos-ghc-${{ matrix.ghc }}-cabal-${{ github.sha }} 153 | if-no-files-found: error 154 | 155 | windows-cabal-test: 156 | runs-on: windows-latest 157 | name: Windows / GHC ${{ matrix.ghc }}, Cabal / test 158 | strategy: 159 | fail-fast: false # don't stop if one job (= GHC version) fails 160 | matrix: 161 | cabal: [latest] 162 | ghc: ["9.2"] 163 | steps: 164 | # TODO figure out timestamp fixer on Windows (need Bash) 165 | - uses: actions/checkout@v2 166 | 167 | - name: Setup Haskell build environment 168 | id: setup-haskell-build-env 169 | uses: haskell/actions/setup@v2 170 | with: 171 | ghc-version: ${{ matrix.ghc }} 172 | cabal-version: ${{ matrix.cabal }} 173 | 174 | - run: cabal freeze 175 | 176 | - name: Cache Cabal build artifacts 177 | uses: actions/cache@v2 178 | with: 179 | path: | 180 | ${{ steps.setup-haskell-build-env.outputs.cabal-store }} 181 | dist-newstyle 182 | key: ${{ runner.os }}-cabal-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }} 183 | restore-keys: | 184 | ${{ runner.os }}-cabal-${{ matrix.ghc }} 185 | 186 | - name: Build 187 | run: cabal install 188 | 189 | - name: Test 190 | run: cabal test --test-show-details=streaming 191 | env: 192 | HSPEC_OPTIONS: --color 193 | 194 | - name: Upload executable 195 | uses: actions/upload-artifact@v4 196 | with: 197 | path: "C:/cabal/bin/${{ env.EXE_NAME }}.exe" 198 | name: ${{ env.EXE_NAME }}-windows-ghc-${{ matrix.ghc }}-cabal-${{ github.sha }}.exe 199 | if-no-files-found: error 200 | -------------------------------------------------------------------------------- /.github/workflows/disabled/hackage.yml: -------------------------------------------------------------------------------- 1 | # GitHub Actions worflow to build Hackage artifacts for a project: an sdist 2 | # archive, and Haddock docs for uploading to Hackage. 3 | # 4 | # I would love to do this in the same testing workflows, so we're not wasting 5 | # GitHub's resources, but workflow syntax is debilitating and they strip docs in 6 | # their provided GHCs, so there's too much complexity to handle it in one place. 7 | # 8 | # This workflow is based on the expectation that GitHub's runners install GHC 9 | # using ghcup with default settings (installs GHCs to `~/.ghcup/ghc/$VERSION`). 10 | 11 | name: Hackage artifacts 12 | 13 | on: 14 | push: 15 | branches: 16 | - master 17 | 18 | env: 19 | # ghcup needs full version string (e.g. 9.0.1, not 9.0) 20 | ghc: "9.2.4" 21 | package_name: fortran-src 22 | 23 | jobs: 24 | hackage: 25 | runs-on: ubuntu-latest 26 | name: Hackage artifacts 27 | 28 | steps: 29 | 30 | # TODO: GHC decides to recompile based on timestamp, so cache isn't used 31 | # Preferably GHC would work via hashes instead. Stack had this feature 32 | # merged in Aug 2020. 33 | # Upstream GHC issue: https://gitlab.haskell.org/ghc/ghc/-/issues/16495 34 | # My issue on haskell/actions: https://github.com/haskell/actions/issues/41 35 | # This also requires us to do a deep fetch, else we don't get the Git commit 36 | # history we need to rewrite mod times. 37 | - uses: actions/checkout@v2 38 | with: 39 | fetch-depth: 0 40 | - name: Set all tracked file modification times to the time of their last commit 41 | run: | 42 | rev=HEAD 43 | for f in $(git ls-tree -r -t --full-name --name-only "$rev") ; do 44 | touch -d $(git log --pretty=format:%cI -1 "$rev" -- "$f") "$f"; 45 | done 46 | 47 | - name: Delete preinstalled docs-stripped GHC ${{ env.ghc }} 48 | run: ghcup rm ghc ${{ env.ghc }} 49 | if: always() 50 | 51 | - name: Install GHC ${{ env.ghc }} 52 | run: ghcup install ghc --set ${{ env.ghc }} 53 | 54 | - run: cabal update 55 | 56 | - run: cabal freeze 57 | 58 | - name: Cache global Cabal store 59 | uses: actions/cache@v2 60 | with: 61 | path: ~/.cabal/store 62 | key: hackage-deps-${{ runner.os }}-ghc_${{ env.ghc }} 63 | 64 | # TODO 2022-04-22: --haddock-options=--quickjump fixes a bug with not 65 | # propagating --haddock-quickjump to building dependency Haddocks 66 | - run: cabal build --enable-documentation --haddock-for-hackage --haddock-options=--quickjump 67 | 68 | - run: cabal sdist 69 | 70 | - name: Upload Hackage sdist 71 | uses: actions/upload-artifact@v4 72 | with: 73 | path: dist-newstyle/sdist/${{ env.package_name }}-*.tar.gz 74 | name: ${{ env.package_name }}-sdist-${{ github.sha }}.tar.gz 75 | if-no-files-found: error 76 | 77 | - name: Upload Hackage Haddock docs 78 | uses: actions/upload-artifact@v4 79 | with: 80 | path: dist-newstyle/${{ env.package_name }}-*-docs.tar.gz 81 | name: ${{ env.package_name }}-hackage-haddocks-${{ github.sha }}.tar.gz 82 | if-no-files-found: error 83 | 84 | - name: Delete prepared tarballs (else can't extract just newest next time) 85 | run: | 86 | rm dist-newstyle/${{ env.package_name }}-*-docs.tar.gz 87 | rm dist-newstyle/sdist/${{ env.package_name }}-*.tar.gz 88 | -------------------------------------------------------------------------------- /.github/workflows/nix.yml: -------------------------------------------------------------------------------- 1 | name: nix 2 | 3 | on: 4 | # run on every push to every branch (visibility doesn't matter) 5 | push: 6 | # don't want pull_request config, since it would run twice 7 | 8 | jobs: 9 | nix-flake-build: 10 | runs-on: ubuntu-latest 11 | name: build (flake) 12 | steps: 13 | - uses: actions/checkout@v3 14 | - uses: cachix/install-nix-action@v20 15 | with: 16 | nix_path: nixpkgs=channel:nixos-unstable 17 | - uses: cachix/cachix-action@v12 18 | with: 19 | name: camfort 20 | authToken: '${{ secrets.CACHIX_AUTH_TOKEN }}' 21 | - run: nix build 22 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Stack, Cabal 2 | # note that it's considered correct practice to store generated cabal files as 3 | # of early 2020: https://www.fpcomplete.com/blog/storing-generated-cabal-files/ 4 | /.stack-work 5 | /cabal.sandbox.config 6 | /.cabal-sandbox 7 | /cabal.project.freeze 8 | /dist-newstyle 9 | 10 | # Files generated by tests 11 | /test/rewriter-test-output 12 | 13 | # Editor tmp files 14 | .*.swp 15 | .*.swo 16 | *~ 17 | 18 | # Other 19 | /dist 20 | /Gemfile 21 | /Gemfile.lock 22 | /Guardfile 23 | /forpar 24 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | cache: 2 | directories: 3 | - $HOME/.stack 4 | 5 | # https://docs.haskellstack.org/en/stable/install_and_upgrade/ 6 | before_install: 7 | - mkdir -p ~/.local/bin 8 | - export PATH=$HOME/.local/bin:$PATH 9 | - curl -sSL https://get.haskellstack.org/ | sh 10 | - stack --version 11 | 12 | install: 13 | - stack --no-terminal test --only-dependencies 14 | 15 | script: 16 | - echo $TRAVIS_TAG 17 | - "GHC_OPTIONS=\"--ghc-options=\"$(ruby -e 'print (ENV[%q|TRAVIS_TAG|] =~ /v/ ? %q|-O3| : %q|-O0|)')\"\"" 18 | - echo $GHC_OPTIONS 19 | - stack --no-terminal haddock --test --no-haddock-deps --pedantic -j 4 $GHC_OPTIONS 20 | 21 | deploy: 22 | - provider: releases 23 | api_key: 24 | secure: "qL3CEhSjjNz+vxayyCxQKFmLlHqSlafZLf3M1kqpA0DF0vX4iAKBZi3LUX+Ir6tUA06EBfbFP/YaogSNk4k7vNYC247csM7673zta8sJYMKPecCWibEM4JHK+f9VrLyEKYETNBCC0nkntCJnWVVL9Nk1hzI7KnvO1XrLkSkVPMhrUsygLZZlNmOkbiCTC49s1wGKBhcsEmZAcq2PvE7nRF/eh+0KWUJJqwBSrOXVDnkPQIfOOC91EZoXEgmk2X/P4gV6k6fRtSIedZwGAbmvM7/iMhFDGPuWgMh4I4ccAkNJKmtKFqqloWlwfB23wUMNDCPmU1Su9YEYyIqv6mWMZ1/DaE88Yxc9Kb6QFLaFfSVs8NS2Uxka4XIVtvywD7p9e3asjkCRE/nJbJ0AJCdmVEqIsYJUsZn7Y4Bge7/wu0AY9GXrihX7bVo7fNdJu0IC/Ad0jtR+PHlClITkQxiNkmLBI0ZUzTeqBVO4dAzHiYrqp6LwmrLDBcd0wPoaCIZHoZqyQCUm5mqhvhGpMH2twFUHikyTeIW1zW4OREuhFv4OwisvVkRAHXIttyEivGZ3H6TmlKtBSV8eOi7nTABA48gN6VVKIhjwXsGPAW0Sqi8M/zw1g6pCtoI85mTqvu6sW9Nc8hKefBUBzvUkLugMyvNGPp6EmkK6wRLSxa0W+bM=" 25 | on: 26 | repo: camfort/fortran-src 27 | tags: true 28 | - provider: hackage 29 | username: madgen 30 | file: 31 | password: 32 | secure: "rPHxI/rLJZ2FeIXfu9Ul/xpDcktS2r85Fb8YH+huM9gJAlYjUYoLmxC4+NVo8AnkU3vn4CyhLSJjGCXW39Ajfz4vr1CQ7V/fieQlKl7J93O+MCrasgl6cn/X2AfZZX59fp3Xrv5K+ldKzuNETUCZqpfpF9KxvSijG1+GEAW8YQDVOssdgA1BMJRR9tVpGZvMkqaRE1jRjYOGsEArEA7OK0lNxwn1hb8ey3MW6bq1K+RkIzhy4uXudfyXu0Z4vw57y+yN+v1Yk71IXQuGhMprXMMXWxMN2NRPsEskkSgATJylUYIZ3q+Z9VWIHdt0a3cYEy6095UeMe/NbNVER4HqAV5RX0ZWPynbQW38bdUF3yhICtl6gm4/4rZ+GiUpkaDXebqcngRA7B7i3v98k9OqfFFTTDtMRwrmETIXrZs/E1DHVSEqvxNI9/kiAmD9lXtYiLeKfdTQr+Lk7gtPl0Fw6NzOSA0N+ZVGRjJlYZbSfoHnWAlJIF8pD3Wh01UDGylqmRAYI0fnGwKPK2nGsOq1CM6fkrKAD7JGHIRsyBQ7JLixOL+12jXHZD0JODsQQAgAavD4eCZgFI2HbjfXgBHhdwQPbscE0wqsUdTsluKmvECIhy3b+tmZPfEURR7JPj5bsrpxh9o6ne6PCcLle30ImLwTz80M8GnmShQOPuQHS+M=" 33 | on: 34 | repo: camfort/fortran-src 35 | tags: true 36 | -------------------------------------------------------------------------------- /ACKNOWLEDGMENTS.md: -------------------------------------------------------------------------------- 1 | Additional thanks for contributions from: 2 | 3 | * Anthony Burzillo 4 | * Azeem Bande-Ali 5 | * Raoul Hidalgo Charman 6 | * Harry Clarke 7 | * Bradley Hardy 8 | * Aiden Jeffrey 9 | * Lukasz Kolodziejczyk 10 | * Vilem-Benjamin Liepelt 11 | * Ben Moon 12 | * Ben Orchard 13 | * Eric Seidel 14 | * Poppy Singleton-Hoare 15 | * TravelTissues 16 | * Jason Xu 17 | * Vaibhav Yenamandra 18 | -------------------------------------------------------------------------------- /CITATION.cff: -------------------------------------------------------------------------------- 1 | cff-version: "1.2.0" 2 | authors: 3 | - family-names: Contrastin 4 | given-names: Mistral 5 | orcid: "https://orcid.org/0000-0002-5409-7122" 6 | - family-names: Charman 7 | given-names: Raoul Hidalgo 8 | orcid: "https://orcid.org/0000-0002-8401-7672" 9 | - family-names: Danish 10 | given-names: Matthew 11 | orcid: "https://orcid.org/0000-0002-7186-387X" 12 | - family-names: Orchard 13 | given-names: Benjamin 14 | orcid: "https://orcid.org/0000-0002-7543-7675" 15 | - family-names: Orchard 16 | given-names: Dominic 17 | orcid: "https://orcid.org/0000-0002-7058-7842" 18 | - family-names: Rice 19 | given-names: Andrew 20 | orcid: "https://orcid.org/0000-0002-4677-8032" 21 | - family-names: Xu 22 | given-names: Jason 23 | orcid: "https://orcid.org/0000-0003-3310-0756" 24 | doi: 10.5281/zenodo.14831853 25 | message: If you use this software, please cite our article in the 26 | Journal of Open Source Software. 27 | preferred-citation: 28 | authors: 29 | - family-names: Contrastin 30 | given-names: Mistral 31 | orcid: "https://orcid.org/0000-0002-5409-7122" 32 | - family-names: Charman 33 | given-names: Raoul Hidalgo 34 | orcid: "https://orcid.org/0000-0002-8401-7672" 35 | - family-names: Danish 36 | given-names: Matthew 37 | orcid: "https://orcid.org/0000-0002-7186-387X" 38 | - family-names: Orchard 39 | given-names: Benjamin 40 | orcid: "https://orcid.org/0000-0002-7543-7675" 41 | - family-names: Orchard 42 | given-names: Dominic 43 | orcid: "https://orcid.org/0000-0002-7058-7842" 44 | - family-names: Rice 45 | given-names: Andrew 46 | orcid: "https://orcid.org/0000-0002-4677-8032" 47 | - family-names: Xu 48 | given-names: Jason 49 | orcid: "https://orcid.org/0000-0003-3310-0756" 50 | date-published: 2025-02-07 51 | doi: 10.21105/joss.07571 52 | issn: 2475-9066 53 | issue: 106 54 | journal: Journal of Open Source Software 55 | publisher: 56 | name: Open Journals 57 | start: 7571 58 | title: "fortran-src: Fortran static analysis infrastructure" 59 | type: article 60 | url: "https://joss.theoj.org/papers/10.21105/joss.07571" 61 | volume: 10 62 | title: "fortran-src: Fortran static analysis infrastructure" 63 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015-2021: Mistral Contrastin, Matthew Danish, Dominic Orchard and Andrew Rice 2 | 3 | Licensed under the Apache License, Version 2.0 (the "License"); 4 | you may not use this file except in compliance with the License. 5 | You may obtain a copy of the License at 6 | 7 | http://www.apache.org/licenses/LICENSE-2.0 8 | 9 | Unless required by applicable law or agreed to in writing, software 10 | distributed under the License is distributed on an "AS IS" BASIS, 11 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | See the License for the specific language governing permissions and 13 | limitations under the License. 14 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /TODO.md: -------------------------------------------------------------------------------- 1 | ## Repr 2 | * without a value repr for BOZs, we're forced to delay evaluating function & 3 | operation arguments until we know the function. since we need to implement 4 | the special BOZ case 5 | 6 | ## Small refactorings 7 | * Many AST nodes could be upgraded to use `NonEmpty` - some appear to be 8 | nonsensical for the empty list case (e.g. `Declarator` with `ArrayDecl`) 9 | * May need another newtype to work with `AList` 10 | * How to handle empty `AList`s 11 | * Empty `AList`s are hard to give `SrcSpan`s to (but probably OK to do so) 12 | * Some syntax allows omitting brackets for empty lists 13 | * `Maybe AList` fixes the problem, but now we have `Just []` and `Nothing` 14 | * Ideal solution is probably more `AList`-likes that encode some extra 15 | syntactic info while storing a regular list. Large scale change 16 | * For now, moved `ExpFunctionCall` and `StCall` from `Maybe AList` to 17 | `AList`, with notes on problematic spans 18 | -------------------------------------------------------------------------------- /flake.lock: -------------------------------------------------------------------------------- 1 | { 2 | "nodes": { 3 | "flake-parts": { 4 | "inputs": { 5 | "nixpkgs-lib": "nixpkgs-lib" 6 | }, 7 | "locked": { 8 | "lastModified": 1726153070, 9 | "narHash": "sha256-HO4zgY0ekfwO5bX0QH/3kJ/h4KvUDFZg8YpkNwIbg1U=", 10 | "owner": "hercules-ci", 11 | "repo": "flake-parts", 12 | "rev": "bcef6817a8b2aa20a5a6dbb19b43e63c5bf8619a", 13 | "type": "github" 14 | }, 15 | "original": { 16 | "owner": "hercules-ci", 17 | "repo": "flake-parts", 18 | "type": "github" 19 | } 20 | }, 21 | "haskell-flake": { 22 | "locked": { 23 | "lastModified": 1725811060, 24 | "narHash": "sha256-lmPoWYNT8kI8LSTa0Z3id38SoR05+05IEZ3fxeIwOzE=", 25 | "owner": "srid", 26 | "repo": "haskell-flake", 27 | "rev": "9b490fe01ec8f6858f43d3cc81bfbbd0000eb29e", 28 | "type": "github" 29 | }, 30 | "original": { 31 | "owner": "srid", 32 | "repo": "haskell-flake", 33 | "type": "github" 34 | } 35 | }, 36 | "nixpkgs": { 37 | "locked": { 38 | "lastModified": 1726042813, 39 | "narHash": "sha256-LnNKCCxnwgF+575y0pxUdlGZBO/ru1CtGHIqQVfvjlA=", 40 | "owner": "nixos", 41 | "repo": "nixpkgs", 42 | "rev": "159be5db480d1df880a0135ca0bfed84c2f88353", 43 | "type": "github" 44 | }, 45 | "original": { 46 | "owner": "nixos", 47 | "ref": "nixpkgs-unstable", 48 | "repo": "nixpkgs", 49 | "type": "github" 50 | } 51 | }, 52 | "nixpkgs-lib": { 53 | "locked": { 54 | "lastModified": 1725233747, 55 | "narHash": "sha256-Ss8QWLXdr2JCBPcYChJhz4xJm+h/xjl4G0c0XlP6a74=", 56 | "type": "tarball", 57 | "url": "https://github.com/NixOS/nixpkgs/archive/356624c12086a18f2ea2825fed34523d60ccc4e3.tar.gz" 58 | }, 59 | "original": { 60 | "type": "tarball", 61 | "url": "https://github.com/NixOS/nixpkgs/archive/356624c12086a18f2ea2825fed34523d60ccc4e3.tar.gz" 62 | } 63 | }, 64 | "root": { 65 | "inputs": { 66 | "flake-parts": "flake-parts", 67 | "haskell-flake": "haskell-flake", 68 | "nixpkgs": "nixpkgs" 69 | } 70 | } 71 | }, 72 | "root": "root", 73 | "version": 7 74 | } 75 | -------------------------------------------------------------------------------- /flake.nix: -------------------------------------------------------------------------------- 1 | { 2 | inputs = { 3 | nixpkgs.url = "github:nixos/nixpkgs/nixpkgs-unstable"; 4 | flake-parts.url = "github:hercules-ci/flake-parts"; 5 | haskell-flake.url = "github:srid/haskell-flake"; 6 | }; 7 | outputs = inputs: 8 | inputs.flake-parts.lib.mkFlake { inherit inputs; } { 9 | systems = inputs.nixpkgs.lib.systems.flakeExposed; 10 | imports = [ inputs.haskell-flake.flakeModule ]; 11 | perSystem = { self', pkgs, config, ... }: { 12 | packages.default = self'.packages.fortran-src-ghc92-fortran-src; 13 | devShells.default = self'.devShells.fortran-src-ghc92; 14 | 15 | haskellProjects.ghc92 = import ./haskell-flake-ghc92.nix pkgs; 16 | haskellProjects.fortran-src-ghc92 = { 17 | basePackages = config.haskellProjects.ghc92.outputs.finalPackages; 18 | devShell = { 19 | tools = hp: { 20 | # use nixpkgs cabal-install 21 | cabal-install = pkgs.cabal-install; 22 | 23 | # disable these while unused (often slow/annoying to build) 24 | haskell-language-server = null; 25 | ghcid = null; 26 | hlint = null; 27 | }; 28 | }; 29 | }; 30 | 31 | haskellProjects.ghc94 = import ./haskell-flake-ghc94.nix pkgs; 32 | haskellProjects.fortran-src-ghc94 = { 33 | basePackages = config.haskellProjects.ghc94.outputs.finalPackages; 34 | devShell = { 35 | tools = hp: { 36 | # use nixpkgs cabal-install 37 | cabal-install = pkgs.cabal-install; 38 | 39 | # disable these while unused (often slow/annoying to build) 40 | haskell-language-server = null; 41 | ghcid = null; 42 | hlint = null; 43 | }; 44 | }; 45 | }; 46 | 47 | haskellProjects.ghc96 = { 48 | basePackages = pkgs.haskell.packages.ghc96; 49 | devShell = { 50 | tools = hp: { 51 | # disable these while unused (often slow/annoying to build) 52 | haskell-language-server = null; 53 | ghcid = null; 54 | hlint = null; 55 | }; 56 | }; 57 | }; 58 | 59 | haskellProjects.ghc98 = { 60 | basePackages = pkgs.haskell.packages.ghc98; 61 | devShell = { 62 | tools = hp: { 63 | # disable these while unused (often slow/annoying to build) 64 | haskell-language-server = null; 65 | ghcid = null; 66 | hlint = null; 67 | }; 68 | }; 69 | }; 70 | 71 | }; 72 | }; 73 | } 74 | -------------------------------------------------------------------------------- /haskell-flake-ghc92.nix: -------------------------------------------------------------------------------- 1 | pkgs: { 2 | # disable local project options (always do this for package sets) 3 | defaults.packages = {}; 4 | devShell.enable = false; 5 | autoWire = []; 6 | 7 | basePackages = pkgs.haskell.packages.ghc92; 8 | packages = { 9 | # GHC 9.2 libraries 10 | singletons-th.source = "3.1"; 11 | singletons-base.source = "3.1"; 12 | singletons.source = "3.0.1"; # req because singletons-th-3.1 had bad bounds 13 | th-desugar.source = "1.13.1"; 14 | th-abstraction.source = "0.4.5.0"; 15 | }; 16 | 17 | # (note this is actually unused/we have to duplicate because it doesn't get 18 | # packed into basePackages or any key we can use... but nice to document here) 19 | devShell = { 20 | tools = hp: { 21 | # by default, haskell-flake uses the Haskell packages versions of these 22 | # tools (from hp). be warned, these can be a pain to build alternatively, 23 | # you may use nixpkgs versions via pkgs 24 | 25 | # as of 2024-09-13 nixpkgs-unstable can't build cabal-install on GHC 9.2. 26 | # no problem, use nixpkgs version (shouldn't really matter how built) 27 | cabal-install = pkgs.cabal-install; 28 | }; 29 | }; 30 | } 31 | -------------------------------------------------------------------------------- /haskell-flake-ghc94.nix: -------------------------------------------------------------------------------- 1 | pkgs: { 2 | # disable local project options (always do this for package sets) 3 | defaults.packages = {}; 4 | devShell.enable = false; 5 | autoWire = []; 6 | 7 | basePackages = pkgs.haskell.packages.ghc94; 8 | packages = { 9 | # GHC 9.4 libraries 10 | singletons-th.source = "3.1.1"; 11 | singletons-base.source = "3.1.1"; 12 | #singletons.source = "3.0.1"; 13 | th-desugar.source = "1.14"; 14 | th-abstraction.source = "0.4.5.0"; 15 | }; 16 | 17 | # (note this is actually unused/we have to duplicate because it doesn't get 18 | # packed into basePackages or any key we can use... but nice to document here) 19 | devShell = { 20 | tools = hp: { 21 | # by default, haskell-flake uses the Haskell packages versions of these 22 | # tools (from hp). be warned, these can be a pain to build alternatively, 23 | # you may use nixpkgs versions via pkgs 24 | 25 | # as of 2024-09-13 nixpkgs-unstable can't build cabal-install on GHC 9.4. 26 | # no problem, use nixpkgs version (shouldn't really matter how built) 27 | cabal-install = pkgs.cabal-install; 28 | }; 29 | }; 30 | } 31 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: fortran-src 2 | version: '0.16.5' 3 | synopsis: Parsers and analyses for Fortran standards 66, 77, 90, 95 and 2003 (partial). 4 | description: >- 5 | Provides lexing, parsing, and basic analyses of Fortran code covering 6 | standards: FORTRAN 66, FORTRAN 77, Fortran 90, Fortran 95, Fortran 2003 7 | (partial) and some legacy extensions. Includes data flow and basic block 8 | analysis, a renamer, and type analysis. For example usage, see the 9 | @@ project, which uses 10 | fortran-src as its front end. 11 | tested-with: GHC >= 9.0 12 | github: camfort/fortran-src 13 | bug-reports: https://github.com/camfort/fortran-src/issues 14 | author: [Mistral Contrastin, Matthew Danish, Dominic Orchard, Andrew Rice] 15 | maintainer: [Dominic Orchard] 16 | category: Language 17 | license: Apache-2.0 18 | license-file: LICENSE 19 | 20 | extra-source-files: 21 | - README.md 22 | - CHANGELOG.md 23 | - test-data/**/* 24 | 25 | # raehik's extensions (GHC 9.2; last updated: 2022-08-17) 26 | default-extensions: 27 | # project-specific 28 | - TupleSections 29 | 30 | # syntax that should be default 31 | - EmptyCase 32 | - LambdaCase 33 | - InstanceSigs 34 | - BangPatterns 35 | - ExplicitNamespaces # 7.6 36 | 37 | ## deriving-related 38 | - DerivingStrategies # 8.2 39 | #- DerivingVia # 8.6 40 | - StandaloneDeriving 41 | - DeriveAnyClass 42 | - DeriveGeneric 43 | - DeriveDataTypeable 44 | - DeriveFunctor 45 | - DeriveFoldable 46 | - DeriveTraversable 47 | - DeriveLift 48 | 49 | # features that should be default 50 | - FlexibleContexts 51 | - FlexibleInstances 52 | - MultiParamTypeClasses 53 | - GADTs 54 | - PolyKinds 55 | - RoleAnnotations # 7.8 56 | - RankNTypes 57 | 58 | # other features 59 | - TypeApplications # 8.0 60 | - DefaultSignatures 61 | - TypeFamilies 62 | - DataKinds 63 | 64 | # other syntax 65 | - MagicHash 66 | #- ImportQualifiedPost # 8.10 67 | #- StandaloneKindSignatures # 8.10 68 | - BinaryLiterals # 7.10 69 | 70 | # essential, but can break things, so be wary 71 | - ScopedTypeVariables # changes type var scoping quite dramatically 72 | - TypeOperators # interferes with the old `*` type 73 | 74 | # useful extensions to know about, but which must be specified on-demand 75 | #- UndecidableInstances 76 | 77 | # --pedantic for building (not used for stack ghci) 78 | ghc-options: 79 | - -Wall 80 | #- -Werror # appears bad to do in distribution, can be useful for development 81 | 82 | dependencies: 83 | - base >=4.6 && <5 84 | - mtl >=2.2 && <3 85 | - array >=0.5 && <0.6 86 | - uniplate >=1.6 && <2 87 | - GenericPretty >=1.2.2 && <2 88 | - pretty >=1.1 && <2 89 | - containers >=0.5 && <0.7 90 | - text >=1.2 && <2.2 91 | - bytestring >=0.10 && <0.13 92 | - binary >=0.8.3.0 && <0.11 93 | - filepath >=1.4 && <2 94 | - directory >=1.2 && <2 95 | - fgl >=5 && <6 96 | - deepseq >=1.4 && <1.6 97 | - filepath >=1.4 && <1.5 98 | - temporary >=1.2 && <1.4 99 | - either ^>=5.0.1.1 100 | - process >= 1.2.0.0 101 | 102 | - singletons >= 3.0 && < 3.1 103 | 104 | # 3.0 = GHC 9.0, 3.1 = GHC 9.2, 3.1.1 = GHC 9.4, 3.2 = GHC 9.6, 3.3 = GHC 9.8 105 | - singletons-th >= 3.0 && < 3.4 106 | - singletons-base >= 3.0 && < 3.4 107 | 108 | library: 109 | source-dirs: src 110 | ghc-options: -fno-warn-tabs 111 | build-tools: 112 | - alex >=3.1 113 | - happy >=1.19 114 | 115 | executables: 116 | fortran-src: 117 | source-dirs: app 118 | main: Main.hs 119 | ghc-options: -fno-warn-tabs 120 | dependencies: 121 | - fortran-src 122 | 123 | tests: 124 | spec: 125 | main: Spec.hs 126 | source-dirs: test 127 | build-tools: 128 | - hspec-discover 129 | dependencies: 130 | - fortran-src 131 | - deepseq >=1.4 && <1.6 132 | - hspec >=2.2 && <3 133 | - QuickCheck >=2.10 && <2.15 134 | 135 | when: 136 | - condition: os(windows) 137 | cpp-options: 138 | - -DFS_DISABLE_WIN_BROKEN_TESTS 139 | -------------------------------------------------------------------------------- /src/Language/Fortran/AST/AList.hs: -------------------------------------------------------------------------------- 1 | module Language.Fortran.AST.AList where 2 | 3 | import Language.Fortran.Util.FirstParameter 4 | import Language.Fortran.Util.SecondParameter 5 | import Language.Fortran.Util.Position (Spanned, SrcSpan(..), getSpan) 6 | import Language.Fortran.AST.Annotated ( Annotated ) 7 | 8 | import Data.Data (Data) 9 | import GHC.Generics (Generic) 10 | import Control.DeepSeq (NFData) 11 | import Text.PrettyPrint.GenericPretty (Out) 12 | 13 | -- | A location-tagged list of @t a@s (@t@ decorated with an @a@ annotation). 14 | -- 15 | -- The AST is polymorphic on some type @a@, which is used for arbitrary 16 | -- annotations. Since many AST nodes use lists (e.g. executable statements, 17 | -- declarations), we define a dedicated annotated list type to reuse. 18 | -- 19 | -- Note that the list itself also holds an @a@ annotation. 20 | data AList t a = AList 21 | { alistAnno :: a 22 | , alistSpan :: SrcSpan 23 | , alistList :: [t a] 24 | } deriving stock (Eq, Ord, Show, Data, Generic) 25 | 26 | instance Functor t => Functor (AList t) where 27 | fmap f (AList a s xs) = AList (f a) s (map (fmap f) xs) 28 | 29 | instance FirstParameter (AList t a) a 30 | instance SecondParameter (AList t a) SrcSpan 31 | instance Annotated (AList t) 32 | instance Spanned (AList t a) 33 | instance (Out a, Out (t a)) => Out (AList t a) 34 | instance (NFData a, NFData (t a)) => NFData (AList t a) 35 | 36 | -- | Convert a non-empty list to an 'AList'. 37 | fromList :: Spanned (t a) => a -> [ t a ] -> AList t a 38 | fromList a xs = AList a (getSpan xs) xs 39 | 40 | -- | Convert a list to an 'AList', returning Nothing iff the list is empty. 41 | fromList' :: Spanned (t a) => a -> [ t a ] -> Maybe (AList t a) 42 | fromList' _ [] = Nothing 43 | fromList' a xs = Just $ fromList a xs 44 | 45 | fromReverseList :: Spanned (t ()) => [ t () ] -> AList t () 46 | fromReverseList = fromList () . reverse 47 | 48 | fromReverseList' :: Spanned (t ()) => [ t () ] -> Maybe (AList t ()) 49 | fromReverseList' = fromList' () . reverse 50 | 51 | aCons :: t a -> AList t a -> AList t a 52 | aCons x (AList a s xs) = AList a s $ x:xs 53 | 54 | infixr 5 `aCons` 55 | 56 | aEmpty :: a -> SrcSpan -> AList t a 57 | aEmpty a s = AList a s [] 58 | 59 | aReverse :: AList t a -> AList t a 60 | aReverse (AList a s xs) = AList a s $ reverse xs 61 | 62 | aStrip :: AList t a -> [t a] 63 | aStrip (AList _ _ l) = l 64 | 65 | aStrip' :: Maybe (AList t a) -> [t a] 66 | aStrip' Nothing = [] 67 | aStrip' (Just a) = aStrip a 68 | 69 | aMap :: (t a -> r a) -> AList t a -> AList r a 70 | aMap f (AList a s xs) = AList a s (map f xs) 71 | 72 | -------------------------------------------------------------------------------- 73 | 74 | data ATuple t1 t2 a = ATuple 75 | { atupleAnno :: a 76 | , atupleSpan :: SrcSpan 77 | , atupleFst :: t1 a 78 | , atupleSnd :: t2 a 79 | } deriving stock (Eq, Ord, Show, Data, Generic, Functor) 80 | 81 | instance FirstParameter (ATuple t1 t2 a) a 82 | instance SecondParameter (ATuple t1 t2 a) SrcSpan 83 | instance Spanned (ATuple t1 t2 a) 84 | instance (Out a, Out (t1 a), Out (t2 a)) => Out (ATuple t1 t2 a) 85 | instance (NFData a, NFData (t1 a), NFData (t2 a)) => NFData (ATuple t1 t2 a) 86 | 87 | -------------------------------------------------------------------------------- 88 | 89 | {- 90 | 91 | see issue #231 92 | 93 | data AListX ext t a = AListX 94 | { alistxAnno :: a 95 | , alistxSpan :: SrcSpan 96 | , alistxList :: [t a] 97 | , alistxExt :: ext 98 | } deriving stock (Eq, Show, Data, Generic) 99 | 100 | instance Functor t => Functor (AListX ext t) where 101 | fmap f (AListX a s xs ext) = AListX (f a) s (map (fmap f) xs) ext 102 | 103 | instance FirstParameter (AListX ext t a) a 104 | instance SecondParameter (AListX ext t a) SrcSpan 105 | instance Annotated (AListX ext t) 106 | instance Spanned (AListX ext t a) 107 | instance (Out a, Out (t a), Out ext) => Out (AListX ext t a) 108 | instance (NFData a, NFData (t a), NFData ext) => NFData (AListX ext t a) 109 | 110 | data Brackets = Brackets | OmitBrackets 111 | deriving stock (Eq, Show, Data, Generic) 112 | deriving anyclass (NFData, Out) 113 | 114 | -} 115 | -------------------------------------------------------------------------------- /src/Language/Fortran/AST/Annotated.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DefaultSignatures #-} 2 | 3 | module Language.Fortran.AST.Annotated where 4 | 5 | import Language.Fortran.Util.FirstParameter 6 | 7 | -- Retrieving SrcSpan and Annotation from nodes 8 | class Annotated f where 9 | getAnnotation :: f a -> a 10 | setAnnotation :: a -> f a -> f a 11 | modifyAnnotation :: (a -> a) -> f a -> f a 12 | default getAnnotation :: (FirstParameter (f a) a) => f a -> a 13 | getAnnotation = getFirstParameter 14 | 15 | default setAnnotation :: (FirstParameter (f a) a) => a -> f a -> f a 16 | setAnnotation = setFirstParameter 17 | 18 | modifyAnnotation f x = setAnnotation (f (getAnnotation x)) x 19 | -------------------------------------------------------------------------------- /src/Language/Fortran/AST/Common.hs: -------------------------------------------------------------------------------- 1 | module Language.Fortran.AST.Common where 2 | 3 | type Name = String 4 | -------------------------------------------------------------------------------- /src/Language/Fortran/AST/Literal.hs: -------------------------------------------------------------------------------- 1 | module Language.Fortran.AST.Literal where 2 | 3 | import Language.Fortran.AST.Common ( Name ) 4 | import Language.Fortran.Util.Position ( SrcSpan, Spanned ) 5 | import Language.Fortran.Util.FirstParameter ( FirstParameter ) 6 | import Language.Fortran.Util.SecondParameter ( SecondParameter ) 7 | import Language.Fortran.AST.Annotated ( Annotated ) 8 | 9 | import GHC.Generics ( Generic ) 10 | import Data.Data ( Data, Typeable ) 11 | import Control.DeepSeq ( NFData ) 12 | import Text.PrettyPrint.GenericPretty ( Out ) 13 | 14 | data KindParam a 15 | = KindParamInt a SrcSpan String -- ^ @[0-9]+@ 16 | | KindParamVar a SrcSpan Name -- ^ @[a-z][a-z0-9]+@ (case insensitive) 17 | deriving stock (Eq, Ord, Show, Data, Typeable, Generic, Functor) 18 | deriving anyclass (NFData, Out) 19 | 20 | instance FirstParameter (KindParam a) a 21 | instance Annotated KindParam 22 | instance SecondParameter (KindParam a) SrcSpan 23 | instance Spanned (KindParam a) 24 | -------------------------------------------------------------------------------- /src/Language/Fortran/AST/Literal/Boz.hs: -------------------------------------------------------------------------------- 1 | {- | Supporting code for handling Fortran BOZ literal constants. 2 | 3 | Using the definition from the latest Fortran standards (F2003, F2008), BOZ 4 | constants are bitstrings (untyped!) which have basically no implicit rules. How 5 | they're interpreted depends on context (they are generally limited to DATA 6 | statements and a small handful of intrinsic functions). 7 | 8 | Note that currently, we don't store BOZ constants as bitstrings. Storing them in 9 | their string representation is easy and in that form, they're easy to safely 10 | resolve to an integer. An alternate option would be to store them as the 11 | bitstring "B" of BOZ, and only implement functions on that. For simple uses 12 | (integer), I'm doubtful that would provide extra utility or performance, but it 13 | may be more sensible in the future. For now, you may retrieve a bitstring by 14 | converting to a numeric type and using something like 'showIntAtBase', or a 15 | 'Bits' instance. 16 | 17 | This type carries _some_ syntactic information that doesn't change meaning. The 18 | expectation is that most users won't want to inspect 'Boz' values, usually just 19 | convert them, so we do it for convenience for checking syntax conformance. Note 20 | that not all info is retained -- which of single or double quotes were used is 21 | not recorded, for example. 22 | -} 23 | 24 | module Language.Fortran.AST.Literal.Boz where 25 | 26 | import GHC.Generics 27 | import Data.Data 28 | import Control.DeepSeq ( NFData ) 29 | import Text.PrettyPrint.GenericPretty ( Out ) 30 | 31 | import qualified Data.List as List 32 | import qualified Data.Char as Char 33 | import qualified Numeric as Num 34 | 35 | import Data.Bits 36 | 37 | -- | A Fortran BOZ literal constant. 38 | -- 39 | -- The prefix defines the characters allowed in the string: 40 | -- 41 | -- * @B@: @[01]@ 42 | -- * @O@: @[0-7]@ 43 | -- * @Z@: @[0-9 a-f A-F]@ 44 | data Boz = Boz 45 | { bozPrefix :: BozPrefix 46 | , bozString :: String 47 | 48 | , bozPrefixWasPostfix :: Conforming 49 | -- ^ Was the prefix actually postfix i.e. @'123'z@? This is non-standard 50 | -- syntax, disabled by default in gfortran. Syntactic info. 51 | } deriving stock (Show, Generic, Data, Typeable, Ord) 52 | deriving anyclass (NFData, Out) 53 | 54 | -- | Tests prefix & strings match, ignoring conforming/nonconforming flags. 55 | instance Eq Boz where 56 | b1 == b2 = bozPrefix b1 == bozPrefix b2 57 | && bozString b1 == bozString b2 58 | 59 | data BozPrefix 60 | = BozPrefixB -- ^ binary (bitstring) 61 | | BozPrefixO -- ^ octal 62 | | BozPrefixZ Conforming -- ^ hex, including nonstandard @x@ 63 | deriving stock (Show, Generic, Data, Typeable, Ord) 64 | deriving anyclass (NFData, Out) 65 | 66 | -- | Ignores conforming/nonconforming flags. 67 | instance Eq BozPrefix where 68 | p1 == p2 = case (p1, p2) of (BozPrefixB, BozPrefixB) -> True 69 | (BozPrefixO, BozPrefixO) -> True 70 | (BozPrefixZ{}, BozPrefixZ{}) -> True 71 | _ -> False 72 | 73 | data Conforming = Conforming | Nonconforming 74 | deriving stock (Eq, Ord, Show, Generic, Data, Typeable) 75 | deriving anyclass (NFData, Out) 76 | 77 | -- | UNSAFE. Parses a BOZ literal constant string. 78 | -- 79 | -- Looks for prefix or postfix. Strips the quotes from the string (single quotes 80 | -- only). 81 | parseBoz :: String -> Boz 82 | parseBoz s = 83 | case List.uncons s of 84 | Nothing -> errInvalid 85 | Just (pc, ps) -> case parsePrefix pc of 86 | Just p -> Boz p (shave ps) Conforming 87 | Nothing -> case parsePrefix (List.last s) of 88 | Just p -> Boz p (shave (init s)) Nonconforming 89 | Nothing -> errInvalid 90 | where 91 | parsePrefix p 92 | | p' == 'b' = Just $ BozPrefixB 93 | | p' == 'o' = Just $ BozPrefixO 94 | | p' == 'z' = Just $ BozPrefixZ Conforming 95 | | p' == 'x' = Just $ BozPrefixZ Nonconforming 96 | | otherwise = Nothing 97 | where p' = Char.toLower p 98 | errInvalid = error ("Language.Fortran.AST.BOZ.parseBoz: invalid BOZ string: " <> show s) 99 | -- | Remove the first and last elements in a list. 100 | shave = tail . init 101 | 102 | -- | Pretty print a BOZ constant. Uses prefix style (ignores the postfix field), 103 | -- and @z@ over nonstandard @x@ for hexadecimal. 104 | prettyBoz :: Boz -> String 105 | prettyBoz b = prettyBozPrefix (bozPrefix b) : '\'' : bozString b <> "'" 106 | where prettyBozPrefix = \case BozPrefixB -> 'b' 107 | BozPrefixO -> 'o' 108 | BozPrefixZ{} -> 'z' 109 | 110 | -- | Resolve a BOZ constant as a natural (positive integer). 111 | -- 112 | -- Is actually polymorphic over the output type, but you probably want to 113 | -- resolve to 'Integer' or 'Natural' usually. 114 | -- 115 | -- We assume the 'Boz' is well-formed, thus don't bother with digit predicates. 116 | bozAsNatural :: (Num a, Eq a) => Boz -> a 117 | bozAsNatural (Boz pfx str _) = runReadS $ parser str 118 | where 119 | runReadS = fst . head 120 | parser = case pfx of BozPrefixB -> Num.readInt 2 (const True) binDigitVal 121 | -- (on GHC >=9.2, 'Num.readBin') 122 | BozPrefixO -> Num.readOct 123 | BozPrefixZ{} -> Num.readHex 124 | binDigitVal = \case '0' -> 0 125 | '1' -> 1 126 | _ -> error "Language.Fortran.AST.BOZ.bozAsNatural: invalid BOZ string" 127 | 128 | -- | Resolve a BOZ constant as a two's complement integer. 129 | -- 130 | -- Note that the value will depend on the size of the output type. 131 | bozAsTwosComp :: (Num a, Eq a, FiniteBits a) => Boz -> a 132 | bozAsTwosComp boz = 133 | if msbIsSet 134 | then asNat - (2 ^ bitCount) 135 | else asNat 136 | where 137 | msbIsSet = testBit asNat (bitCount - 1) 138 | asNat = bozAsNatural boz 139 | bitCount = finiteBitSize asNat 140 | -------------------------------------------------------------------------------- /src/Language/Fortran/AST/Literal/Complex.hs: -------------------------------------------------------------------------------- 1 | -- | Supporting definitions for COMPLEX literals. 2 | 3 | module Language.Fortran.AST.Literal.Complex where 4 | 5 | import Language.Fortran.AST.Common ( Name ) 6 | import Language.Fortran.AST.Literal ( KindParam ) 7 | import Language.Fortran.AST.Literal.Real 8 | import Language.Fortran.Util.Position ( SrcSpan, Spanned ) 9 | 10 | import GHC.Generics ( Generic ) 11 | import Data.Data ( Data, Typeable ) 12 | import Control.DeepSeq ( NFData ) 13 | import Text.PrettyPrint.GenericPretty ( Out ) 14 | import Language.Fortran.Util.FirstParameter ( FirstParameter ) 15 | import Language.Fortran.Util.SecondParameter ( SecondParameter ) 16 | import Language.Fortran.AST.Annotated ( Annotated ) 17 | 18 | -- | A COMPLEX literal, composed of a real part and an imaginary part. 19 | -- 20 | -- Fortran has lots of rules on how COMPLEX literals are defined and used in 21 | -- various contexts. To support all that, we define the syntactic structure 22 | -- 'ComplexLit' to wrap all the parsing rules. Then during a analysis pass, you 23 | -- may (attempt to) convert these into a more regular type, like a Haskell 24 | -- @(Double, Double)@ tuple. 25 | data ComplexLit a = ComplexLit 26 | { complexLitAnno :: a 27 | , complexLitPos :: SrcSpan 28 | , complexLitRealPart :: ComplexPart a 29 | , complexLitImagPart :: ComplexPart a 30 | } deriving stock (Eq, Ord, Show, Data, Typeable, Generic, Functor) 31 | deriving anyclass (NFData, Out) 32 | 33 | instance FirstParameter (ComplexLit a) a 34 | instance Annotated ComplexLit 35 | instance SecondParameter (ComplexLit a) SrcSpan 36 | instance Spanned (ComplexLit a) 37 | 38 | -- | A part (either real or imaginary) of a complex literal. 39 | -- 40 | -- Since Fortran 2003, complex literal parts support named constants, which must 41 | -- be resolved in context at compile time (R422, R423). 42 | -- 43 | -- Some compilers also allow constant expressions for the parts, and must 44 | -- evaluate at compile time. That's not allowed in any standard. Apparently, 45 | -- gfortran and ifort don't allow it, while nvfortran does. See: 46 | -- https://fortran-lang.discourse.group/t/complex-constants-and-variables/2909/3 47 | -- 48 | -- We specifically avoid supporting that by defining complex parts without being 49 | -- mutually recursive with 'Expression'. 50 | data ComplexPart a 51 | = ComplexPartReal a SrcSpan RealLit (Maybe (KindParam a)) -- ^ signed real lit 52 | | ComplexPartInt a SrcSpan String (Maybe (KindParam a)) -- ^ signed int lit 53 | | ComplexPartNamed a SrcSpan Name -- ^ named constant 54 | deriving stock (Eq, Ord, Show, Data, Typeable, Generic, Functor) 55 | deriving anyclass (NFData, Out) 56 | 57 | instance FirstParameter (ComplexPart a) a 58 | instance Annotated ComplexPart 59 | instance SecondParameter (ComplexPart a) SrcSpan 60 | instance Spanned (ComplexPart a) 61 | 62 | -- | Is the given COMPLEX literal "pure", i.e. does it have no named constant 63 | -- components? 64 | complexLitIsPure :: ComplexLit a -> Bool 65 | complexLitIsPure c = 66 | check (complexLitRealPart c) && check (complexLitImagPart c) 67 | where check = \case ComplexPartNamed{} -> False 68 | _ -> True 69 | -------------------------------------------------------------------------------- /src/Language/Fortran/AST/Literal/Real.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Supporting code for handling Fortran REAL literals. 3 | 4 | Fortran REAL literals have some idiosyncrasies that prevent them from lining up 5 | with Haskell's reals immediately. So, we parse into an intermediate data type 6 | that can be easily exported with full precision later. Things we do: 7 | 8 | * Strip explicit positive signs so that signed values either begin with the 9 | minus sign @-@ or no sign. ('Read' doesn't allow explicit positive signs.) 10 | * Make exponent explicit by adding the default exponent @E0@ if not present. 11 | * Make implicit zeroes explicit. @.123 -> 0.123@, @123. -> 123.0@. (Again, 12 | Haskell literals do not support this.) 13 | 14 | For example, the Fortran REAL literal @1D0@ will be parsed into @1.0D0@. 15 | -} 16 | 17 | {-# LANGUAGE RecordWildCards #-} 18 | 19 | module Language.Fortran.AST.Literal.Real where 20 | 21 | import qualified Data.Char as Char 22 | import GHC.Generics 23 | import Data.Data 24 | import Control.DeepSeq ( NFData ) 25 | import Text.PrettyPrint.GenericPretty ( Out ) 26 | 27 | -- | A Fortran real literal. (Does not include the optional kind parameter.) 28 | -- 29 | -- A real literal is formed of a signed rational significand, and an 'Exponent'. 30 | -- 31 | -- See F90 ISO spec pg.27 / R412-416. 32 | -- 33 | -- Note that we support signed real literals, even though the F90 spec indicates 34 | -- non-signed real literals are the "default" (signed are only used in a "spare" 35 | -- rule). Our parsers should parse explicit signs as unary operators. There's no 36 | -- harm in supporting signed literals though, especially since the exponent *is* 37 | -- signed. 38 | data RealLit = RealLit 39 | { realLitSignificand :: String 40 | -- ^ A string representing a signed decimal. 41 | -- ^ Approximate regex: @-? ( [0-9]+ \. [0-9]* | \. [0-9]+ )@ 42 | , realLitExponent :: Exponent 43 | } deriving stock (Eq, Ord, Show, Data, Typeable, Generic) 44 | deriving anyclass (NFData, Out) 45 | 46 | -- | An exponent is an exponent letter (E, D) and a signed integer. 47 | data Exponent = Exponent 48 | { exponentLetter :: ExponentLetter 49 | , exponentNum :: String 50 | } deriving stock (Eq, Ord, Show, Data, Typeable, Generic) 51 | deriving anyclass (NFData, Out) 52 | 53 | -- Note: Some Fortran language references include extensions here. HP's F90 54 | -- reference provides a Q exponent letter which sets kind to 16. 55 | data ExponentLetter 56 | = ExpLetterE -- ^ KIND=4 (float) 57 | | ExpLetterD -- ^ KIND=8 (double) 58 | | ExpLetterQ -- ^ KIND=16 ("quad", rare? extension) 59 | deriving stock (Eq, Ord, Show, Data, Typeable, Generic) 60 | deriving anyclass (NFData, Out) 61 | 62 | -- | Prettify a 'RealLit' in a Haskell-compatible way. 63 | prettyHsRealLit :: RealLit -> String 64 | prettyHsRealLit r = realLitSignificand r <> "e" <> exponentNum (realLitExponent r) 65 | 66 | readRealLit :: (Fractional a, Read a) => RealLit -> a 67 | readRealLit = read . prettyHsRealLit 68 | 69 | -- UNSAFE. Expects a valid Fortran REAL literal. 70 | parseRealLit :: String -> RealLit 71 | parseRealLit r = 72 | let (significandStr, exponentStr) = span isSignificand r 73 | realLitExponent = parseExponent exponentStr 74 | realLitSignificand = normalizeSignificand (stripPositiveSign significandStr) 75 | in RealLit{..} 76 | where 77 | -- | Ensure that the given decimal string is in form @x.y@. 78 | normalizeSignificand str = case span (/= '.') str of 79 | ([], d) -> '0':d -- .456 80 | (i, ".") -> i<>".0" -- 123. 81 | (i, "") -> i<>".0" -- 123 82 | _ -> str -- 123.456 83 | parseExponent "" = Exponent { exponentLetter = ExpLetterE, exponentNum = "0" } 84 | parseExponent (l:str) = 85 | let exponentLetter = parseExponentLetter l 86 | exponentNum = stripPositiveSign str 87 | in Exponent{..} 88 | stripPositiveSign = \case 89 | [] -> [] 90 | c:s -> case c of 91 | '+' -> s 92 | _ -> c:s 93 | isSignificand ch | Char.isDigit ch = True 94 | | ch `elem` ['.', '-', '+'] = True 95 | | otherwise = False 96 | parseExponentLetter ch = case Char.toLower ch of 97 | 'e' -> ExpLetterE 98 | 'd' -> ExpLetterD 99 | 'q' -> ExpLetterQ 100 | _ -> error $ "Language.Fortran.AST.Literal.Real.parseRealLit: invalid exponent letter: " <> [ch] 101 | -------------------------------------------------------------------------------- /src/Language/Fortran/Analysis/ModGraph.hs: -------------------------------------------------------------------------------- 1 | -- | Generate a module use-graph. 2 | module Language.Fortran.Analysis.ModGraph 3 | (genModGraph, ModGraph(..), ModOrigin(..), modGraphToList, modGraphToDOT, takeNextMods, delModNodes) 4 | where 5 | 6 | import Language.Fortran.AST hiding (setName) 7 | import qualified Language.Fortran.Parser as Parser 8 | import Language.Fortran.Version 9 | import Language.Fortran.Util.ModFile 10 | import Language.Fortran.Util.Files 11 | 12 | import Prelude hiding (mod) 13 | import Control.Monad.State.Strict 14 | import Control.Monad ( forM_ ) -- required for mtl-2.3 (GHC 9.6) 15 | import Data.Data 16 | import Data.Generics.Uniplate.Data 17 | import Data.Graph.Inductive hiding (version) 18 | import Data.Maybe 19 | import qualified Data.Map as M 20 | 21 | -------------------------------------------------- 22 | 23 | data ModOrigin = MOFile FilePath | MOFSMod FilePath 24 | deriving (Eq, Data, Show) 25 | 26 | instance Ord ModOrigin where 27 | MOFSMod _ <= MOFSMod _ = True 28 | a <= b = a == b 29 | 30 | data ModGraph = ModGraph { mgModNodeMap :: M.Map String (Node, Maybe ModOrigin) 31 | , mgGraph :: Gr String () 32 | , mgNumNodes :: Int } 33 | deriving (Eq, Data) 34 | 35 | modGraph0 :: ModGraph 36 | modGraph0 = ModGraph M.empty empty 0 37 | 38 | type ModGrapher a = StateT ModGraph IO a 39 | 40 | maybeAddModName :: String -> Maybe ModOrigin -> ModGrapher Node 41 | maybeAddModName modName org = do 42 | mg@ModGraph { mgModNodeMap = mnmap, mgGraph = gr, mgNumNodes = numNodes } <- get 43 | case M.lookup modName mnmap of 44 | Just (i, org') | org <= org' -> pure i 45 | | otherwise -> do 46 | let mnmap' = M.insert modName (i, org) mnmap 47 | put $ mg { mgModNodeMap = mnmap' } 48 | pure i 49 | Nothing -> do 50 | let i = numNodes + 1 51 | let mnmap' = M.insert modName (i, org) mnmap 52 | let gr' = insNode (i, modName) gr 53 | put $ mg { mgModNodeMap = mnmap', mgGraph = gr', mgNumNodes = i } 54 | pure i 55 | 56 | addModDep :: String -> String -> ModGrapher () 57 | addModDep modName depName = do 58 | i <- maybeAddModName modName Nothing 59 | j <- maybeAddModName depName Nothing 60 | mg@ModGraph { mgGraph = gr } <- get 61 | put $ mg { mgGraph = insEdge (i, j, ()) gr } 62 | 63 | genModGraph :: Maybe FortranVersion -> [FilePath] -> Maybe String -> [FilePath] -> IO ModGraph 64 | genModGraph mversion includeDirs cppOpts paths = do 65 | let perModule path pu@(PUModule _ _ modName _ _) = do 66 | _ <- maybeAddModName modName (Just $ MOFile path) 67 | let uses = [ usedName | StUse _ _ (ExpValue _ _ (ValVariable usedName)) _ _ _ <- 68 | universeBi pu :: [Statement ()] ] 69 | forM_ uses $ \ usedName -> do 70 | _ <- maybeAddModName usedName Nothing 71 | addModDep modName usedName 72 | perModule path pu | Named puName <- getName pu = do 73 | _ <- maybeAddModName puName (Just $ MOFile path) 74 | let uses = [ usedName | StUse _ _ (ExpValue _ _ (ValVariable usedName)) _ _ _ <- 75 | universeBi pu :: [Statement ()] ] 76 | forM_ uses $ \ usedName -> do 77 | _ <- maybeAddModName usedName Nothing 78 | addModDep puName usedName 79 | perModule _ _ = pure () 80 | let iter :: FilePath -> ModGrapher () 81 | iter path = do 82 | contents <- liftIO $ runCPP cppOpts path 83 | fileMods <- liftIO $ decodeModFiles includeDirs 84 | let version = fromMaybe (deduceFortranVersion path) mversion 85 | mods = map snd fileMods 86 | parserF0 = Parser.byVerWithMods mods version 87 | parserF fn bs = 88 | case parserF0 fn bs of 89 | Right x -> return x 90 | Left err -> do 91 | error $ show err 92 | forM_ fileMods $ \ (fileName, mod) -> do 93 | forM_ [ name | Named name <- M.keys (combinedModuleMap [mod]) ] $ \ name -> do 94 | _ <- maybeAddModName name . Just $ MOFSMod fileName 95 | pure () 96 | pf <- parserF path contents 97 | mapM_ (perModule path) (childrenBi pf :: [ProgramUnit ()]) 98 | pure () 99 | execStateT (mapM_ iter paths) modGraph0 100 | 101 | -- Remove duplicates from a list preserving the left most occurrence. 102 | removeDuplicates :: Eq a => [a] -> [a] 103 | removeDuplicates [] = [] 104 | removeDuplicates (x:xs) = 105 | if x `elem` xs 106 | then x : removeDuplicates (filter (/= x) xs) 107 | else x : removeDuplicates xs 108 | 109 | modGraphToDOT :: ModGraph -> String 110 | modGraphToDOT ModGraph { mgGraph = gr } = unlines dot 111 | where 112 | dot = [ "strict digraph {\n" 113 | , "node [shape=box,fontname=\"Courier New\"]\n" ] ++ 114 | concatMap (\ (i, name) -> 115 | [ "n" ++ show i ++ "[label=\"" ++ name ++ "\"]\n" 116 | , "n" ++ show i ++ " -> {" ] ++ 117 | [ " n" ++ show j | j <- suc gr i ] ++ 118 | ["}\n"]) 119 | (labNodes gr) ++ 120 | [ "}\n" ] 121 | 122 | -- Provides a topological sort of the graph, giving a list of filenames 123 | modGraphToList :: ModGraph -> [String] 124 | modGraphToList m = removeDuplicates $ modGraphToList' m 125 | where 126 | modGraphToList' mg 127 | | nxt <- takeNextMods mg 128 | , not (null nxt) = 129 | let mg' = delModNodes (map fst nxt) mg 130 | in [ fn | (_, Just (MOFile fn)) <- nxt ] ++ modGraphToList' mg' 131 | modGraphToList' _ = [] 132 | 133 | 134 | takeNextMods :: ModGraph -> [(Node, Maybe ModOrigin)] 135 | takeNextMods ModGraph { mgModNodeMap = mnmap, mgGraph = gr } = noDepFiles 136 | where 137 | noDeps = [ (i, modName) | (i, modName) <- labNodes gr, null (suc gr i) ] 138 | noDepFiles = [ (i, mo) | (i, modName) <- noDeps 139 | , (_, mo) <- maybeToList (M.lookup modName mnmap) ] 140 | 141 | delModNodes :: [Node] -> ModGraph -> ModGraph 142 | delModNodes ns mg@ModGraph { mgGraph = gr } = mg' 143 | where 144 | mg' = mg { mgGraph = delNodes ns gr } 145 | -------------------------------------------------------------------------------- /src/Language/Fortran/Common/Array.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} -- required due to instance design 2 | 3 | module Language.Fortran.Common.Array where 4 | 5 | import Control.DeepSeq ( NFData ) 6 | import GHC.Generics ( Generic ) 7 | import Data.Data ( Data, Typeable ) 8 | import Data.Binary ( Binary ) 9 | import Text.PrettyPrint.GenericPretty ( Out(..) ) 10 | 11 | import qualified Text.PrettyPrint as Pretty 12 | 13 | import qualified Language.Fortran.PrettyPrint as F 14 | 15 | -- | A single array dimension with bounds of type @a@. 16 | -- 17 | -- * @'Num' a => 'Dim' a@ is a static, known-size dimension. 18 | -- * @'Dim' ('Language.Fortran.AST.Expression' '()')@ is a dimension with 19 | -- unevaluated bounds expressions. Note that these bounds may be constant 20 | -- expressions, or refer to dummy variables, or be invalid. 21 | -- * @'Num' a => 'Dim' ('Maybe' a)@ is a dimension where some bounds are 22 | -- known, and others are not. This may be useful to record some information 23 | -- about dynamic explicit-shape arrays. 24 | data Dim a = Dim 25 | { dimLower :: a -- ^ Dimension lower bound. 26 | , dimUpper :: a -- ^ Dimension upper bound. 27 | } deriving stock (Show, Generic, Data, Eq) 28 | deriving stock (Functor, Foldable, Traversable) 29 | deriving anyclass (NFData, Binary) 30 | 31 | -- | This instance is purely for convenience. No definition of ordering is 32 | -- provided, and the implementation may change at any time. 33 | deriving stock Ord 34 | 35 | -- | Fortran syntax uses @lower:upper@, so only provide an 'Out' instance for 36 | -- that style. 37 | instance Out a => Out (Dim a) where 38 | doc (Dim lb ub) = doc lb <> Pretty.char ':' <> doc ub 39 | 40 | instance Out (Dim a) => F.Pretty (Dim a) where 41 | pprint' _ = doc 42 | 43 | -- | Fortran array dimensions, defined by a list of 'Dim's storing lower and 44 | -- upper bounds. 45 | -- 46 | -- You select the list type @t@ (which should be 'Functor', 'Foldable' and 47 | -- 'Traversable') and the bound type @a@ (e.g. 'Int'). 48 | -- 49 | -- Using a non-empty list type such as 'Data.List.NonEmpty.NonEmpty' will 50 | -- disallow representing zero-dimension arrays, providing extra soundness. 51 | -- 52 | -- Note the following excerpt from the F2018 standard (8.5.8.2 Explicit-shape 53 | -- array): 54 | -- 55 | -- > If the upper bound is less than the lower bound, the range is empty, the 56 | -- > extent in that dimension is zero, and the array is of zero size. 57 | -- 58 | -- Note that the 'Foldable' instance does not provide "dimension-like" access to 59 | -- this type. That is, @'length' (a :: 'Dims' t a)@ will _not_ tell you how many 60 | -- dimensions 'a' represents. Use 'dimsLength' for that. 61 | data Dims t a 62 | -- | Explicit-shape array. All dimensions are known. 63 | = DimsExplicitShape 64 | (t (Dim a)) -- ^ list of all dimensions 65 | 66 | -- | Assumed-size array. The final dimension has no upper bound (it is 67 | -- obtained from its effective argument). Earlier dimensions may be defined 68 | -- like explicit-shape arrays. 69 | | DimsAssumedSize 70 | (Maybe (t (Dim a))) -- ^ list of all dimensions except last 71 | a -- ^ lower bound of last dimension 72 | 73 | -- | Assumed-shape array. Shape is taken from effective argument. We store the 74 | -- lower bound for each dimension, and thus also the rank (via list length). 75 | | DimsAssumedShape 76 | (t a) -- ^ list of lower bounds 77 | 78 | deriving stock (Generic) 79 | deriving stock (Functor, Foldable, Traversable) 80 | 81 | -- We have to standalone derive most instances due to the @t@ list-like. 82 | deriving stock instance (Show a, Show (t a), Show (t (Dim a))) 83 | => Show (Dims t a) 84 | deriving anyclass instance (NFData a, NFData (t a), NFData (t (Dim a))) 85 | => NFData (Dims t a) 86 | deriving stock instance (Data a, Data (t a), Data (t (Dim a)), Typeable t) 87 | => Data (Dims t a) 88 | deriving stock instance (Eq a, Eq (t a), Eq (t (Dim a))) 89 | => Eq (Dims t a) 90 | deriving anyclass instance (Binary a, Binary (t a), Binary (t (Dim a))) 91 | => Binary (Dims t a) 92 | 93 | -- | This instance is purely for convenience. No definition of ordering is 94 | -- provided, and the implementation may change at any time. 95 | deriving stock instance (Ord a, Ord (t a), Ord (t (Dim a))) 96 | => Ord (Dims t a) 97 | 98 | instance (Foldable t, Functor t, Out (Dim a), Out a) 99 | => Out (Dims t a) where 100 | docPrec _ = doc 101 | doc = Pretty.parens . \case 102 | DimsExplicitShape ds -> 103 | prettyIntersperse dimSep $ fmap doc ds 104 | DimsAssumedShape ss -> 105 | prettyIntersperse dimSep $ fmap go ss 106 | where 107 | go s = doc s <> Pretty.char ':' 108 | DimsAssumedSize mds d -> 109 | -- A bit fragile, but hopefully won't explode on empty 'Just's. 110 | case mds of 111 | Nothing -> prettyLast 112 | Just ds -> prettyAfter dimSep (fmap doc ds) <> prettyLast 113 | where 114 | prettyLast = doc d <> Pretty.text ":*" 115 | where 116 | dimSep = Pretty.text ", " 117 | 118 | instance Out (Dims t a) => F.Pretty (Dims t a) where 119 | pprint' _ = doc 120 | 121 | -- Faster is possible for non @[]@ list-likes, but this is OK for the general 122 | -- case. 123 | prettyIntersperse :: Foldable t => Pretty.Doc -> t Pretty.Doc -> Pretty.Doc 124 | prettyIntersperse dBetween ds = 125 | case foldMap (\d -> [dBetween, d]) ds of 126 | [] -> mempty 127 | _:ds' -> mconcat ds' 128 | 129 | prettyAfter :: Foldable t => Pretty.Doc -> t Pretty.Doc -> Pretty.Doc 130 | prettyAfter dAfter = foldMap (\d -> d <> dAfter) 131 | 132 | -- | Traverse over the functor in a 'Dims' value with a functor bound type. 133 | -- 134 | -- For example, to turn a @'Dims' t ('Maybe' a)@ into a @'Maybe' ('Dims' t a)@. 135 | dimsTraverse :: (Traversable t, Applicative f) => Dims t (f a) -> f (Dims t a) 136 | dimsTraverse = traverse id 137 | -- TODO provide a SPECIALIZE clause for the above Maybe case. performance! :) 138 | 139 | -- | How many dimensions does the given 'Dims' represent? 140 | dimsLength :: Foldable t => Dims t a -> Int 141 | dimsLength = \case 142 | DimsExplicitShape ds -> length ds 143 | DimsAssumedShape ss -> length ss 144 | DimsAssumedSize mds _d -> 145 | case mds of 146 | Nothing -> 1 147 | Just ds -> length ds + 1 148 | -------------------------------------------------------------------------------- /src/Language/Fortran/LValue.hs: -------------------------------------------------------------------------------- 1 | module Language.Fortran.LValue where 2 | 3 | import Prelude hiding (exp) 4 | import Data.Data 5 | import GHC.Generics (Generic) 6 | 7 | import Language.Fortran.AST 8 | import Language.Fortran.Util.FirstParameter 9 | import Language.Fortran.Util.Position 10 | import Language.Fortran.Util.SecondParameter 11 | 12 | -- | A subset of 'Expression' which can only contain values that can be assigned 13 | -- to. 14 | data LValue a 15 | = LvSimpleVar a SrcSpan Name 16 | | LvSubscript a SrcSpan (LValue a) (AList Index a) 17 | | LvDataRef a SrcSpan (LValue a) (LValue a) 18 | deriving (Eq, Show, Data, Typeable, Generic, Functor) 19 | 20 | 21 | -- | If the expression can be seen as an lvalue, convert it to an 'LValue'. 22 | toLValue :: Expression a -> Maybe (LValue a) 23 | toLValue (ExpValue ann sp (ValVariable nm)) = Just (LvSimpleVar ann sp nm) 24 | toLValue (ExpSubscript ann sp exp ixs) = LvSubscript ann sp <$> toLValue exp <*> pure ixs 25 | toLValue (ExpDataRef ann sp lhs rhs) = LvDataRef ann sp <$> toLValue lhs <*> toLValue rhs 26 | toLValue _ = Nothing 27 | 28 | instance FirstParameter (LValue a) a 29 | instance SecondParameter (LValue a) SrcSpan 30 | 31 | instance Annotated LValue 32 | instance Spanned (LValue a) 33 | -------------------------------------------------------------------------------- /src/Language/Fortran/Parser/Fixed/Utils.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Language.Fortran.Parser.Fixed.Utils where 3 | 4 | import Language.Fortran.Parser.Fixed.Lexer 5 | import Language.Fortran.AST 6 | import Language.Fortran.AST.Literal.Real 7 | import Language.Fortran.Util.Position 8 | import Language.Fortran.Parser.Monad 9 | import Control.Monad.State 10 | 11 | -- | UNSAFE. Must be called with expected token types (see usage sites). Will 12 | -- cause a runtime exception if it doesn't form a valid REAL literal. 13 | makeRealLit 14 | :: Maybe Token -> Maybe Token -> Maybe Token -> Maybe (SrcSpan, String) 15 | -> Expression A0 16 | makeRealLit i1 dot i2 expr = 17 | let span1 = getSpan (i1, dot, i2) 18 | span2 = case expr of 19 | Just e -> getTransSpan span1 (fst e) 20 | Nothing -> span1 21 | i1Str = case i1 of { Just (TInt _ s) -> s ; _ -> "" } 22 | dotStr = case dot of { Just (TDot _) -> "." ; _ -> "" } 23 | i2Str = case i2 of { Just (TInt _ s) -> s ; _ -> "" } 24 | exprStr = case expr of { Just (_, s) -> s ; _ -> "" } 25 | litStr = i1Str ++ dotStr ++ i2Str ++ exprStr 26 | in ExpValue () span2 $ ValReal (parseRealLit litStr) Nothing 27 | 28 | parseError :: Token -> LexAction a 29 | parseError _ = do 30 | parseState <- get 31 | #ifdef DEBUG 32 | tokens <- reverse <$> aiPreviousTokensInLine <$> getAlex 33 | #endif 34 | fail $ psFilename parseState ++ ": parsing failed. " 35 | #ifdef DEBUG 36 | ++ '\n' : show tokens 37 | #endif 38 | 39 | convCmts :: [Block a] -> [ProgramUnit a] 40 | convCmts = map convCmt 41 | where convCmt (BlComment a s c) = PUComment a s c 42 | convCmt _ = error "convCmt applied to something that is not a comment" 43 | -------------------------------------------------------------------------------- /src/Language/Fortran/Parser/Free/Utils.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Language.Fortran.Parser.Free.Utils where 3 | 4 | import Language.Fortran.Parser.Free.Lexer 5 | import Language.Fortran.Parser.Monad 6 | import Control.Monad.State 7 | 8 | unitNameCheck :: Token -> String -> Parse AlexInput Token () 9 | unitNameCheck (TId _ name1) name2 10 | | name1 == name2 = return () 11 | | otherwise = fail "Unit name does not match the corresponding END statement." 12 | unitNameCheck _ _ = return () 13 | 14 | parseError :: Token -> LexAction a 15 | parseError _ = do 16 | parseState <- get 17 | #ifdef DEBUG 18 | tokens <- reverse <$> aiPreviousTokensInLine <$> getAlex 19 | #endif 20 | fail $ psFilename parseState ++ ": parsing failed. " 21 | #ifdef DEBUG 22 | ++ '\n' : show tokens 23 | #endif 24 | -------------------------------------------------------------------------------- /src/Language/Fortran/Parser/LexerUtils.hs: -------------------------------------------------------------------------------- 1 | {-| Utils for both lexers. -} 2 | module Language.Fortran.Parser.LexerUtils ( readIntOrBoz, unescapeSpecialChars) where 3 | 4 | import Language.Fortran.AST.Literal.Boz 5 | import Numeric 6 | 7 | -- | Read a string as either a signed integer, or a BOZ constant (positive). 8 | -- 9 | -- Useful in manual lexing. 10 | readIntOrBoz :: String -> Integer 11 | readIntOrBoz s = do 12 | case readSToMaybe $ readSigned readDec s of 13 | Just int -> int 14 | Nothing -> bozAsNatural $ parseBoz s 15 | 16 | readSToMaybe :: [(a, b)] -> Maybe a 17 | readSToMaybe = \case (x, _):_ -> Just x 18 | _ -> Nothing 19 | 20 | 21 | -- | Pretty prints exception message that contains things like carriage return, indents, etc. 22 | unescapeSpecialChars :: String -> String 23 | unescapeSpecialChars [] = [] 24 | unescapeSpecialChars ('\\' : c : rest) = 25 | case c of 26 | 'n' -> '\n' : unescapeSpecialChars rest 27 | 't' -> '\t' : unescapeSpecialChars rest 28 | 'r' -> '\r' : unescapeSpecialChars rest 29 | '\\' -> '\\' : unescapeSpecialChars rest 30 | _ -> '\\' : c : unescapeSpecialChars rest 31 | unescapeSpecialChars (c : rest) = 32 | c : unescapeSpecialChars rest 33 | -------------------------------------------------------------------------------- /src/Language/Fortran/Parser/Monad.hs: -------------------------------------------------------------------------------- 1 | {-| Parser/lexer monad, plus common functionality and definitions. -} 2 | 3 | {-# LANGUAGE UndecidableInstances #-} 4 | {-# LANGUAGE FunctionalDependencies #-} 5 | {-# LANGUAGE CPP #-} 6 | 7 | module Language.Fortran.Parser.Monad where 8 | 9 | #if !MIN_VERSION_base(4,13,0) 10 | -- Control.Monad.Fail import is redundant since GHC 8.8.1 11 | import qualified Control.Monad.Fail as Fail 12 | import Control.Monad.Fail (MonadFail) 13 | #endif 14 | 15 | import Language.Fortran.Version 16 | import Language.Fortran.Util.Position 17 | 18 | import Control.Exception 19 | import GHC.IO.Exception ( IOException(..), IOErrorType(..) ) 20 | import Control.Monad.State hiding (state) 21 | import Control.Monad.Except 22 | import Data.Typeable 23 | 24 | ------------------------------------------------------------------------------- 25 | -- Helper datatype definitions 26 | ------------------------------------------------------------------------------- 27 | 28 | data ParanthesesCount = ParanthesesCount 29 | { pcActual :: Integer 30 | , pcHasReached0 :: Bool } 31 | deriving (Show, Eq) 32 | 33 | data Context = 34 | ConStart 35 | | ConData 36 | | ConImplicit 37 | | ConNamelist 38 | | ConCommon 39 | deriving (Show, Eq) 40 | 41 | data ParseState a = ParseState 42 | { psAlexInput :: a 43 | , psParanthesesCount :: ParanthesesCount 44 | , psVersion :: FortranVersion -- To differentiate lexing behaviour 45 | , psFilename :: String -- To save correct source location in AST 46 | , psContext :: [ Context ] 47 | } 48 | deriving (Show) 49 | 50 | data ParseError a b = ParseError 51 | { errPos :: Position 52 | , errLastToken :: Maybe b 53 | , errFilename :: String 54 | , errMsg :: String } 55 | 56 | instance Show b => Show (ParseError a b) where 57 | show err = show (errPos err) ++ ": " ++ errMsg err ++ lastTokenMsg 58 | where lastTokenMsg = tokenMsg (errLastToken err) 59 | 60 | tokenMsg :: Show a => Maybe a -> String 61 | tokenMsg (Just a) = "Last parsed token: " ++ show a ++ "." 62 | tokenMsg Nothing = "No token had been lexed." 63 | 64 | data ParseResult b c a = ParseOk a (ParseState b) | ParseFailed (ParseError b c) 65 | deriving stock (Functor) 66 | 67 | instance (Typeable a, Typeable b, Show a, Show b) => Exception (ParseError a b) 68 | 69 | class LastToken a b | a -> b where 70 | getLastToken :: (Show b) => a -> Maybe b 71 | 72 | class Tok a where 73 | eofToken :: a -> Bool 74 | 75 | ------------------------------------------------------------------------------- 76 | -- Parser Monad definition 77 | ------------------------------------------------------------------------------- 78 | 79 | newtype Parse b c a = Parse { unParse :: ParseState b -> ParseResult b c a } 80 | 81 | instance (Loc b, LastToken b c, Show c) => Functor (Parse b c) where 82 | fmap f (Parse p) = Parse $ \s -> case p s of 83 | ParseOk a s' -> ParseOk (f a) s' 84 | ParseFailed e -> ParseFailed e 85 | 86 | instance (Loc b, LastToken b c, Show c) => Applicative (Parse b c) where 87 | pure a = Parse $ \s -> ParseOk a s 88 | (Parse pl) <*> (Parse pr) = Parse $ \s -> 89 | case pl s of 90 | ParseFailed e -> ParseFailed e 91 | ParseOk ab s' -> 92 | case pr s' of 93 | ParseFailed e -> ParseFailed e 94 | ParseOk a s'' -> ParseOk (ab a) s'' 95 | 96 | instance (Loc b, LastToken b c, Show c) => Monad (Parse b c) where 97 | (Parse m) >>= f = Parse $ \s -> 98 | case m s of 99 | ParseOk a s' -> unParse (f a) s' 100 | ParseFailed e -> ParseFailed e 101 | 102 | #if !MIN_VERSION_base(4,13,0) 103 | -- Monad(fail) was removed in GHC 8.8.1 104 | fail = Fail.fail 105 | #endif 106 | 107 | instance (Loc b, LastToken b c, Show c) => MonadFail (Parse b c) where 108 | fail msg = Parse $ \s -> ParseFailed ParseError 109 | { errPos = (getPos . psAlexInput) s 110 | , errLastToken = (getLastToken . psAlexInput) s 111 | , errFilename = psFilename s 112 | , errMsg = msg } 113 | 114 | instance (Loc b, LastToken b c, Show c) => MonadState (ParseState b) (Parse b c) where 115 | get = Parse $ \s -> ParseOk s s 116 | put s = Parse $ \_ -> ParseOk () s 117 | 118 | instance (Loc b, LastToken b c, Show c) => MonadError (ParseError b c) (Parse b c) where 119 | throwError e = Parse $ \_ -> ParseFailed e 120 | 121 | (Parse m) `catchError` f = Parse $ \s -> 122 | case m s of 123 | ParseFailed e -> unParse (f e) s 124 | m' -> m' 125 | 126 | 127 | runParse 128 | :: (Loc b, LastToken b c, Show c) 129 | => Parse b c a -> ParseState b -> ParseResult b c a 130 | runParse = unParse 131 | 132 | runParseUnsafe 133 | :: (Loc b, LastToken b c, Show c) 134 | => Parse b c a -> ParseState b -> (a, ParseState b) 135 | runParseUnsafe lexer initState = 136 | case unParse lexer initState of 137 | ParseOk a s -> (a, s) 138 | ParseFailed e -> throwIOError $ show e 139 | 140 | throwIOError :: String -> a 141 | throwIOError s = throw 142 | IOError { ioe_handle = Nothing 143 | , ioe_type = UserError 144 | , ioe_location = "fortran-src" 145 | , ioe_description = s 146 | , ioe_errno = Nothing 147 | , ioe_filename = Nothing } 148 | 149 | evalParse 150 | :: (Loc b, LastToken b c, Show c) 151 | => Parse b c a -> ParseState b -> a 152 | evalParse m s = fst (runParseUnsafe m s) 153 | 154 | execParse 155 | :: (Loc b, LastToken b c, Show c) 156 | => Parse b c a -> ParseState b -> ParseState b 157 | execParse m s = snd (runParseUnsafe m s) 158 | 159 | ------------------------------------------------------------------------------- 160 | -- Parser helper functions 161 | ------------------------------------------------------------------------------- 162 | 163 | getVersion :: (Loc a, LastToken a b, Show b) => Parse a b FortranVersion 164 | getVersion = do 165 | s <- get 166 | return (psVersion s) 167 | 168 | putAlex :: (Loc a, LastToken a b, Show b) => a -> Parse a b () 169 | putAlex ai = do 170 | s <- get 171 | put (s { psAlexInput = ai }) 172 | 173 | getAlex :: (Loc a, LastToken a b, Show b) => Parse a b a 174 | getAlex = do 175 | s <- get 176 | return (psAlexInput s) 177 | 178 | topContext :: (Loc a, LastToken a b, Show b) => Parse a b Context 179 | topContext = head . psContext <$> get 180 | 181 | popContext :: (Loc a, LastToken a b, Show b) => Parse a b () 182 | popContext = modify $ \ps -> ps { psContext = tail $ psContext ps } 183 | 184 | pushContext :: (Loc a, LastToken a b, Show b) => Context -> Parse a b () 185 | pushContext context = modify $ \ps -> ps { psContext = context : psContext ps } 186 | 187 | getPosition :: (Loc a, LastToken a b, Show b) => Parse a b Position 188 | getPosition = do 189 | parseState <- get 190 | return $ getPos $ psAlexInput parseState 191 | 192 | getSrcSpan :: (Loc a, LastToken a b, Show b) => Position -> Parse a b SrcSpan 193 | getSrcSpan loc1 = do 194 | loc2 <- getPosition 195 | return $ SrcSpan loc1 loc2 196 | 197 | getParanthesesCount :: (Loc a, LastToken a b, Show b) => Parse a b ParanthesesCount 198 | getParanthesesCount = psParanthesesCount <$> get 199 | 200 | resetPar :: (Loc a, LastToken a b, Show b) => Parse a b () 201 | resetPar = do 202 | ps <- get 203 | put $ ps { psParanthesesCount = ParanthesesCount 0 False } 204 | 205 | incPar :: (Loc a, LastToken a b, Show b) => Parse a b () 206 | incPar = do 207 | ps <- get 208 | let pc = psParanthesesCount ps 209 | let count = pcActual pc 210 | put $ ps { psParanthesesCount = pc { pcActual = count + 1 } } 211 | 212 | decPar :: (Loc a, LastToken a b, Show b) => Parse a b () 213 | decPar = do 214 | ps <- get 215 | let pc = psParanthesesCount ps 216 | let newCount = pcActual pc - 1 217 | let reached0 = pcHasReached0 pc || newCount == 0 218 | put $ ps { psParanthesesCount = ParanthesesCount newCount reached0 } 219 | -------------------------------------------------------------------------------- /src/Language/Fortran/Parser/ParserUtils.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | {-| Utils for various parsers (beyond token level). 4 | 5 | We can sometimes work around there being free-form and fixed-form versions of 6 | the @LexAction@ monad by requesting the underlying instances instances. We place 7 | such utilities that match that form here. 8 | 9 | -} 10 | module Language.Fortran.Parser.ParserUtils where 11 | 12 | import Language.Fortran.AST 13 | import Language.Fortran.AST.Literal.Real 14 | import Language.Fortran.AST.Literal.Complex 15 | import Language.Fortran.Util.Position 16 | 17 | #if !MIN_VERSION_base(4,13,0) 18 | -- Control.Monad.Fail import is redundant since GHC 8.8.1 19 | import Control.Monad.Fail ( MonadFail ) 20 | #endif 21 | 22 | {- $complex-lit-parsing 23 | 24 | Parsing complex literal parts unambiguously is a pain, so instead, we parse any 25 | expression, then case on it to determine if it's valid for a complex literal 26 | part -- and if so, push it into a 'ComplexPart' constructor. This may cause 27 | unexpected behaviour if more bracketing/tuple rules are added! 28 | -} 29 | 30 | -- | Try to validate an expression as a COMPLEX literal part. 31 | -- 32 | -- $complex-lit-parsing 33 | exprToComplexLitPart :: MonadFail m => Expression a -> m (ComplexPart a) 34 | exprToComplexLitPart e = 35 | case e' of 36 | ExpValue a ss val -> 37 | case val of 38 | ValReal r mkp -> 39 | let r' = r { realLitSignificand = sign <> realLitSignificand r } 40 | in return $ ComplexPartReal a ss r' mkp 41 | ValInteger i mkp -> return $ ComplexPartInt a ss (sign<>i) mkp 42 | ValVariable var -> return $ ComplexPartNamed a ss var 43 | _ -> fail $ "Invalid COMPLEX literal @ " <> show ss 44 | _ -> fail $ "Invalid COMPLEX literal @ " <> show (getSpan e') 45 | where 46 | (sign, e') = case e of ExpUnary _ _ Minus e'' -> ("-", e'') 47 | ExpUnary _ _ Plus e'' -> ("", e'') 48 | _ -> ("", e) 49 | 50 | -- | Helper for forming COMPLEX literals. 51 | complexLit 52 | :: MonadFail m => SrcSpan -> Expression A0 -> Expression A0 53 | -> m (Expression A0) 54 | complexLit ss e1 e2 = do 55 | compReal <- exprToComplexLitPart e1 56 | compImag <- exprToComplexLitPart e2 57 | return $ ExpValue () ss $ ValComplex $ ComplexLit () ss compReal compImag 58 | -------------------------------------------------------------------------------- /src/Language/Fortran/Repr.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Precise Fortran type & value model. 3 | 4 | Due to Fortran syntax design and the fortran-src definitions handling multiple 5 | evolutions of the language, the syntactic constructs in 'Language.Fortran.AST' 6 | for Fortran types and values are clunky and awkward to use for modelling safe 7 | operations. The representations in this sub-package enable performing efficient 8 | operations with explicit, documented semantics (usually the de facto behaviour, 9 | or adopted from gfortran). 10 | 11 | The aims for this representation are _correctness_ and _efficiency_. All values 12 | store enough information on the type level to recover their precise Fortran type 13 | via inspection. 14 | 15 | TODO 16 | 17 | * Data (SYB) doesn't play nice with GADTs. They *are* entirely possible 18 | together with singletons, but remain extremely finicky. It was a source of 19 | issues during development. So no nice GADTs :( 20 | 21 | -} 22 | 23 | module Language.Fortran.Repr 24 | ( 25 | -- * Assorted notes 26 | -- ** Kind semantics 27 | -- $kind-semantics 28 | 29 | -- ** Exceptional behaviour 30 | -- $exceptional-behaviour 31 | 32 | -- ** Naming conventions 33 | -- $naming-conventions 34 | 35 | -- * Re-exports 36 | -- ** Fortran types 37 | module Language.Fortran.Repr.Type 38 | , module Language.Fortran.Repr.Type.Scalar 39 | , module Language.Fortran.Repr.Type.Scalar.Common 40 | , module Language.Fortran.Repr.Type.Scalar.Int 41 | , module Language.Fortran.Repr.Type.Scalar.Real 42 | , module Language.Fortran.Repr.Type.Scalar.Complex 43 | , module Language.Fortran.Repr.Type.Scalar.String 44 | 45 | -- ** Fortran values 46 | , module Language.Fortran.Repr.Value 47 | , module Language.Fortran.Repr.Value.Scalar 48 | , module Language.Fortran.Repr.Value.Scalar.Common 49 | , module Language.Fortran.Repr.Value.Scalar.Int 50 | , module Language.Fortran.Repr.Value.Scalar.Real 51 | , module Language.Fortran.Repr.Value.Scalar.Complex 52 | , module Language.Fortran.Repr.Value.Scalar.Logical 53 | , module Language.Fortran.Repr.Value.Scalar.String 54 | ) where 55 | 56 | import Language.Fortran.Repr.Type 57 | import Language.Fortran.Repr.Type.Scalar 58 | import Language.Fortran.Repr.Type.Scalar.Common 59 | import Language.Fortran.Repr.Type.Scalar.Int 60 | import Language.Fortran.Repr.Type.Scalar.Real 61 | import Language.Fortran.Repr.Type.Scalar.Complex 62 | import Language.Fortran.Repr.Type.Scalar.String 63 | 64 | import Language.Fortran.Repr.Value 65 | import Language.Fortran.Repr.Value.Scalar 66 | import Language.Fortran.Repr.Value.Scalar.Common 67 | import Language.Fortran.Repr.Value.Scalar.Int 68 | import Language.Fortran.Repr.Value.Scalar.Real 69 | import Language.Fortran.Repr.Value.Scalar.Complex 70 | import Language.Fortran.Repr.Value.Scalar.Logical 71 | import Language.Fortran.Repr.Value.Scalar.String 72 | 73 | {- $kind-semantics 74 | 75 | Kinds in Fortran are natural number "tags" associated with certain intrinsic 76 | types. They enable Fortran implementations to group similar types of value 77 | together under the same Fortran type. That is, though an @INTEGER(4)@ and an 78 | @INTEGER(8)@ are both integers, most Fortran compilers will use different 79 | representations for the values. We match this in Haskell by defining a sum type 80 | for a given Fortran type, and making a constructor for each valid kind. 81 | 82 | Fortran standards do not specify full semantics for kinds, only things like 83 | interactions and precision requirements. However, average modern Fortran 84 | compilers tend to agree on certain things. So we follow gfortran's lead for 85 | semantics. The following general rules exist: 86 | 87 | * The size in bytes of a stored value is equal to its type's kind value. For 88 | example, a @REAL(4)@ takes 4 bytes. In general, for any type, only powers of 89 | 2 are ever valid kinds. 90 | * Different types have different permitted kind values. This is what prevents 91 | us from simply carrying around a type name and a kind. For example, in our 92 | representation (and most in use), @REAL(2)@ isn't a valid type, while 93 | @INTEGER(2)@ is. 94 | -} 95 | 96 | {- $exceptional-behaviour 97 | 98 | Where possible, this representation also matches common exceptional behaviours 99 | in Fortran expression evaluation - specifically using gfortran as a basis. For 100 | example: 101 | 102 | * Integers overflow predictably. 103 | * Reals should have approximately matching behaviour, since both gfortran and 104 | Haskell use IEEE floats. 105 | -} 106 | 107 | {- $naming-conventions 108 | 109 | To prevent clashes with common Haskell types and definitions, most 110 | representation types are prefixed with @F@, read as _Fortran_. 111 | -} 112 | -------------------------------------------------------------------------------- /src/Language/Fortran/Repr/Compat/Natural.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | {- | Compatibility definitions for working with term and type level natural 4 | numbers across multiple GHC versions. 5 | 6 | Prior to GHC 9.2: 7 | 8 | * Term level natural numbers: @Natural :: Type@ 9 | * Type level natural numbers: @n :: Nat@ 10 | 11 | As of GHC 9.2: 12 | 13 | * Term level natural numbers: @Natural :: Type@ 14 | * Type level natural numbers: @n :: Natural@ 15 | 16 | To avoid issues, we export a 'NaturalK' kind that will refer to the correct 17 | definition for your platform. 18 | -} 19 | module Language.Fortran.Repr.Compat.Natural ( Natural, NaturalK ) where 20 | 21 | -- exports 'Natural' >= 9.2 22 | import GHC.TypeNats 23 | 24 | #if __GLASGOW_HASKELL__ >= 902 25 | type NaturalK = Natural 26 | #else 27 | import Numeric.Natural 28 | type NaturalK = Nat 29 | #endif 30 | -------------------------------------------------------------------------------- /src/Language/Fortran/Repr/Eval/Common.hs: -------------------------------------------------------------------------------- 1 | -- | Common Fortran evaluation definitions. 2 | 3 | module Language.Fortran.Repr.Eval.Common where 4 | 5 | import qualified Language.Fortran.AST as F 6 | 7 | {- | Monads which provide functionality to evaluate Fortran expressions in some 8 | static context. 9 | 10 | Actions in this monad may 11 | 12 | * request the value of a variable (may return 'Nothing' if not in scope) 13 | * record some user-facing information concerning evaluation 14 | 15 | As usage examples, a simple pure evaluator may use a plain map of 'F.Name' to 16 | @'EvalTo' m@. A more complex type evaluator may allow "defaulting" for variables 17 | not in scope via IMPLICIT rules. 18 | 19 | The associated type family 'EvalTo' enables using this for both type and value 20 | evaluators. 21 | -} 22 | class Monad m => MonadFEval m where 23 | -- | Target type that we evaluate to. 24 | type EvalTo m 25 | 26 | -- | Request the value of a variable. 27 | -- 28 | -- Returns 'Nothing' if the variable is not in scope. 29 | lookupFVar :: F.Name -> m (Maybe (EvalTo m)) 30 | 31 | -- | Record some user-facing information concerning evaluation. 32 | -- 33 | -- For example, you may want to inform the user when you've made a 34 | -- defaulting decision. 35 | warn :: String -> m () 36 | -------------------------------------------------------------------------------- /src/Language/Fortran/Repr/Eval/Type.hs: -------------------------------------------------------------------------------- 1 | -- | Evaluate AST terms to types in the type representation. 2 | 3 | module Language.Fortran.Repr.Eval.Type where 4 | 5 | import qualified Language.Fortran.AST as F 6 | import Language.Fortran.Repr.Type 7 | import Language.Fortran.Repr.Eval.Common 8 | 9 | fromExpression 10 | :: forall m a. (MonadFEval m, EvalTo m ~ FType) 11 | => F.Expression a -> m (Either String FType) 12 | fromExpression = \case 13 | F.ExpValue _ _ (F.ValVariable name) -> 14 | lookupFVar name >>= \case 15 | Nothing -> return $ Left "no such variable found TODO" 16 | Just val -> return $ Right val 17 | 18 | -- TODO support for IMPLICIT rules 19 | -------------------------------------------------------------------------------- /src/Language/Fortran/Repr/Eval/Value/Op.hs: -------------------------------------------------------------------------------- 1 | -- | Evaluate operations between values in the value representation. 2 | 3 | module Language.Fortran.Repr.Eval.Value.Op where 4 | 5 | import Language.Fortran.Repr.Value.Scalar.Machine 6 | import Language.Fortran.Repr.Value.Scalar.Common 7 | import Language.Fortran.Repr.Value.Scalar.Int.Machine 8 | import Language.Fortran.Repr.Value.Scalar.Real 9 | import Language.Fortran.Repr.Value.Scalar.Complex 10 | import Language.Fortran.Repr.Value.Scalar.Logical.Machine 11 | import Language.Fortran.Repr.Value.Scalar.String 12 | import Language.Fortran.Repr.Type.Scalar 13 | import Language.Fortran.Repr.Type.Scalar.Real 14 | import GHC.Float ( float2Double ) 15 | import Data.Int 16 | 17 | import Data.Bits 18 | 19 | import Data.Singletons 20 | 21 | -- | Operation TODO 22 | data Error 23 | = EBadArgType1 [String] FScalarType 24 | | EBadArgType2 [String] FScalarType FScalarType 25 | | EGeneric String 26 | deriving stock (Show, Eq) 27 | 28 | -- https://gcc.gnu.org/onlinedocs/gfortran/DBLE.html#DBLE 29 | opIcDble :: FScalarValue -> Either Error FReal 30 | opIcDble = \case 31 | FSVComplex c -> case c of 32 | FComplex8 r _i -> rfr8 $ float2Double r 33 | FComplex16 r _i -> rfr8 r 34 | FSVReal r -> case r of 35 | FReal4 r' -> rfr8 $ float2Double r' 36 | FReal8 _r' -> Right r 37 | FSVInt i -> rfr8 $ withFInt i 38 | v -> eBadArgType1 ["COMPLEX", "REAL", "INT"] v 39 | where rfr8 = Right . FReal8 40 | 41 | eBadArgType1 :: [String] -> FScalarValue -> Either Error a 42 | eBadArgType1 expected = Left . EBadArgType1 expected . fScalarValueType 43 | 44 | eBadArgType2 :: [String] -> FScalarValue -> FScalarValue -> Either Error a 45 | eBadArgType2 expected l r = 46 | Left $ EBadArgType2 expected (fScalarValueType l) (fScalarValueType r) 47 | 48 | eGeneric :: String -> Either Error a 49 | eGeneric = Left . EGeneric 50 | 51 | opIcNumericBOp 52 | :: (forall a. (Num a, Ord a) => a -> a -> a) 53 | -> FScalarValue -> FScalarValue -> Either Error FScalarValue 54 | opIcNumericBOp bop = go 55 | where 56 | go (FSVInt l) (FSVInt r) = Right $ FSVInt $ fIntBOpInplace bop l r 57 | go (FSVInt l) (FSVReal r) = 58 | Right $ FSVReal $ fRealUOpInplace (\x -> withFInt l `bop` x) r 59 | -- TODO int complex 60 | go (FSVReal l) (FSVReal r) = Right $ FSVReal $ fRealBOpInplace bop l r 61 | go (FSVReal l) (FSVInt r) = go (FSVInt r) (FSVReal l) 62 | go (FSVReal l) (FSVComplex r) = 63 | Right $ FSVComplex $ fComplexBOpInplace bop (fComplexFromReal l) r 64 | 65 | opIcNumericBOpRealIntSep 66 | :: (forall a. Integral a => a -> a -> a) 67 | -> (forall a. RealFloat a => a -> a -> a) 68 | -> FScalarValue -> FScalarValue -> Either Error FScalarValue 69 | opIcNumericBOpRealIntSep bopInt bopReal = go 70 | where 71 | go (FSVInt l) (FSVInt r) = Right $ FSVInt $ fIntBOpInplace bopInt l r 72 | go (FSVInt l) (FSVReal r) = 73 | Right $ FSVReal $ fRealUOpInplace (\x -> withFInt l `bopReal` x) r 74 | -- TODO int complex 75 | go (FSVReal l) (FSVReal r) = Right $ FSVReal $ fRealBOpInplace bopReal l r 76 | go (FSVReal l) (FSVInt r) = go (FSVInt r) (FSVReal l) 77 | go (FSVReal l) (FSVComplex r) = 78 | Right $ FSVComplex $ fComplexBOpInplace bopReal (fComplexFromReal l) r 79 | 80 | opIcNumRelBOp 81 | :: (forall a. Ord a => a -> a -> r) 82 | -> FScalarValue -> FScalarValue -> Either Error r 83 | opIcNumRelBOp bop = go 84 | where 85 | go (FSVInt l) (FSVInt r) = Right $ fIntBOp bop l r 86 | go (FSVInt l) (FSVReal r) = 87 | Right $ fRealUOp (\x -> withFInt l `bop` x) r 88 | -- TODO int complex 89 | go (FSVReal l) (FSVReal r) = Right $ fRealBOp bop l r 90 | go (FSVReal l) (FSVInt r) = go (FSVInt r) (FSVReal l) 91 | -- TODO real complex 92 | go (FSVString l) (FSVString r) = Right $ l `bop` r 93 | 94 | -- plus, minus 95 | opIcNumericUOpInplace 96 | :: (forall a. Num a => a -> a) 97 | -> FScalarValue -> Either Error FScalarValue 98 | opIcNumericUOpInplace uop = \case 99 | FSVInt v -> Right $ FSVInt $ fIntUOpInplace uop v 100 | FSVReal v -> Right $ FSVReal $ fRealUOpInplace uop v 101 | v -> eBadArgType1 ["INT", "REAL"] v 102 | 103 | -- and, or, eqv, neqv 104 | opIcLogicalBOp 105 | :: (Bool -> Bool -> r) 106 | -> FScalarValue -> FScalarValue -> Either Error r 107 | opIcLogicalBOp bop = go 108 | where 109 | go (FSVLogical l) (FSVLogical r) = 110 | Right $ bop (fLogicalToBool l) (fLogicalToBool r) 111 | go l r = eBadArgType2 ["LOGICAL"] l r 112 | 113 | opEq :: FScalarValue -> FScalarValue -> Either Error Bool 114 | opEq = go 115 | where 116 | go (FSVInt l) (FSVInt r) = Right $ fIntBOp (==) l r 117 | go (FSVReal l) (FSVReal r) = Right $ fRealBOp (==) l r 118 | go (FSVInt i) (FSVReal r) = 119 | Right $ fRealUOp (\x -> withFInt i == x) r 120 | go (FSVReal r) (FSVInt i) = 121 | Right $ fRealUOp (\x -> withFInt i == x) r 122 | go (FSVString l) (FSVString r) = Right $ l == r 123 | 124 | -- | According to gfortran spec and F2010 spec, same kind required. 125 | opIor' :: FInt -> FInt -> FInt 126 | opIor' = fIntBOpInplace (.|.) 127 | 128 | opIor :: FInt -> FInt -> Either Error FInt 129 | opIor l r = 130 | case (l, r) of 131 | (FInt4{}, FInt4{}) -> Right $ opIor' l r 132 | (FInt8{}, FInt8{}) -> Right $ opIor' l r 133 | (FInt2{}, FInt2{}) -> Right $ opIor' l r 134 | (FInt1{}, FInt1{}) -> Right $ opIor' l r 135 | _ -> Left $ EGeneric "bad args to ior" 136 | -------------------------------------------------------------------------------- /src/Language/Fortran/Repr/Tmp.hs: -------------------------------------------------------------------------------- 1 | module Language.Fortran.Repr.Tmp where 2 | 3 | import qualified Data.ByteString.Builder as B 4 | import qualified Data.ByteString.Lazy as B 5 | import Data.Word 6 | import qualified Data.Text as Text 7 | import Data.Text ( Text ) 8 | import qualified Data.Char as Char 9 | import qualified Data.List as List 10 | 11 | testF :: Float -> Text 12 | testF = prettyHexByteString B.unpack . B.toLazyByteString . B.floatBE 13 | 14 | testD :: Double -> Text 15 | testD = prettyHexByteString B.unpack . B.toLazyByteString . B.doubleBE 16 | 17 | 18 | -- | Pretty print to default format @00 12 AB FF@: space between each byte, all 19 | -- caps. 20 | -- 21 | -- This format I consider most human readable. I prefer caps to draw attention 22 | -- to this being data instead of text (you don't see that many capital letters 23 | -- packed together in prose). 24 | prettyHexByteString :: (a -> [Word8]) -> a -> Text 25 | prettyHexByteString unpack = 26 | Text.concat 27 | . List.intersperse (Text.singleton ' ') 28 | . fmap (f . prettyHexByte Char.toUpper) 29 | . unpack 30 | where 31 | f :: (Char, Char) -> Text 32 | f (c1, c2) = Text.cons c1 $ Text.singleton c2 33 | 34 | prettyHexByte :: (Char -> Char) -> Word8 -> (Char, Char) 35 | prettyHexByte f w = (prettyNibble h, prettyNibble l) 36 | where 37 | (h,l) = fromIntegral w `divMod` 0x10 38 | prettyNibble = f . Char.intToDigit -- Char.intToDigit returns lower case 39 | 40 | -- | Pretty print to "compact" format @0012abff@ (often output by hashers). 41 | prettyHexByteStringCompact :: (a -> [Word8]) -> a -> Text 42 | prettyHexByteStringCompact unpack = 43 | Text.concat . fmap (f . prettyHexByte id) . unpack 44 | where 45 | f :: (Char, Char) -> Text 46 | f (c1, c2) = Text.cons c1 $ Text.singleton c2 47 | -------------------------------------------------------------------------------- /src/Language/Fortran/Repr/Type.hs: -------------------------------------------------------------------------------- 1 | module Language.Fortran.Repr.Type where 2 | 3 | import Language.Fortran.Repr.Type.Scalar 4 | import Language.Fortran.Repr.Type.Array 5 | import GHC.Generics ( Generic ) 6 | import Data.Data ( Data ) 7 | 8 | -- | A Fortran type (scalar or array). 9 | data FType = MkFScalarType FScalarType | MkFArrayType FArrayType 10 | deriving stock (Generic, Eq, Show, Data) 11 | -------------------------------------------------------------------------------- /src/Language/Fortran/Repr/Type/Array.hs: -------------------------------------------------------------------------------- 1 | module Language.Fortran.Repr.Type.Array where 2 | 3 | import Language.Fortran.Repr.Type.Scalar 4 | import Language.Fortran.Repr.Compat.Natural 5 | 6 | import GHC.Generics ( Generic ) 7 | import Data.Data ( Data ) 8 | 9 | -- | A Fortran array type. 10 | -- 11 | -- An array type is defined by a scalar type together with a shape. 12 | data FArrayType = FArrayType 13 | { fatScalar :: FScalarType 14 | , fatShape :: Shape 15 | } deriving stock (Generic, Data, Show, Eq, Ord) 16 | 17 | -- | The shape of a Fortran array is a list of extents. (The rank of the array 18 | -- is length of the list.) 19 | -- 20 | -- Note that the F90 standard limits maximum array rank to 7 (R512). 21 | -- 22 | -- TODO 23 | -- * An empty list here feels nonsensical. Perhaps this should be NonEmpty. 24 | -- * List type is inefficient here, since we don't care about pushing/popping, 25 | -- and list length is important. Use a vector type instead. 26 | newtype Shape = Shape { getShape :: [Natural] } 27 | deriving stock (Generic, Data, Show, Eq, Ord) 28 | 29 | fatSize :: FArrayType -> Natural 30 | fatSize = sum . getShape . fatShape 31 | -------------------------------------------------------------------------------- /src/Language/Fortran/Repr/Type/Scalar.hs: -------------------------------------------------------------------------------- 1 | module Language.Fortran.Repr.Type.Scalar where 2 | 3 | import Language.Fortran.Repr.Type.Scalar.Common 4 | import Language.Fortran.Repr.Type.Scalar.Int 5 | import Language.Fortran.Repr.Type.Scalar.Real 6 | import Language.Fortran.Repr.Type.Scalar.Complex 7 | import Language.Fortran.Repr.Type.Scalar.String 8 | 9 | import Language.Fortran.Repr.Compat.Natural 10 | 11 | import GHC.Generics ( Generic ) 12 | import Data.Data ( Data ) 13 | 14 | -- | A Fortran scalar type. 15 | data FScalarType 16 | = FSTInt FTInt 17 | | FSTReal FTReal 18 | | FSTComplex FTReal 19 | | FSTLogical FTInt 20 | | FSTString Natural 21 | | FSTCustom String -- ^ F77 structure, F90 DDT (non-intrinsic scalar) 22 | deriving stock (Generic, Data, Show, Eq, Ord) 23 | 24 | prettyScalarType :: FScalarType -> String 25 | prettyScalarType = \case 26 | FSTInt k -> prettyKinded k "INTEGER" 27 | FSTReal k -> prettyKinded k "REAL" 28 | FSTComplex k -> prettyKinded (FTComplexWrapper k) "COMPLEX" 29 | FSTLogical k -> prettyKinded k "LOGICAL" 30 | FSTString l -> "CHARACTER("<>prettyCharLen l<>")" 31 | FSTCustom t -> "TYPE("<>t<>")" 32 | 33 | fScalarTypeKind :: FScalarType -> Maybe FKindLit 34 | fScalarTypeKind = \case 35 | FSTInt k -> Just $ printFKind k 36 | FSTReal k -> Just $ printFKind k 37 | FSTComplex k -> Just $ printFKind (FTComplexWrapper k) 38 | FSTLogical k -> Just $ printFKind k 39 | FSTString l -> Just $ fromIntegral l 40 | FSTCustom t -> Nothing 41 | 42 | prettyKinded :: FKind a => a -> String -> String 43 | prettyKinded k name = name<>"("<>show (printFKind k)<>")" 44 | -------------------------------------------------------------------------------- /src/Language/Fortran/Repr/Type/Scalar/Common.hs: -------------------------------------------------------------------------------- 1 | module Language.Fortran.Repr.Type.Scalar.Common where 2 | 3 | import Data.Word ( Word8 ) 4 | 5 | -- | The internal type used to pass type kinds around. 6 | type FKindLit = Word8 7 | 8 | -- | Fortran types which use simple integer kinds. 9 | class FKind a where 10 | -- | Serialize the kind tag to the shared kind representation. 11 | printFKind :: a -> FKindLit 12 | 13 | -- | Parse a kind tag from the shared kind representation. 14 | parseFKind :: FKindLit -> Maybe a 15 | -------------------------------------------------------------------------------- /src/Language/Fortran/Repr/Type/Scalar/Complex.hs: -------------------------------------------------------------------------------- 1 | {- | Fortran complex data type. 2 | 3 | The complex data type is a simple layer on top of reals. We reuse the type and 4 | value representation from reals, but for convenience, we provide a newtype 5 | wrapper to enable writing a 'FKinded' instance for the complex type. 6 | 7 | TODO candidate for improving. other ways of writing, name is long & poor. 8 | alternatively, could enforce usage of this 9 | -} 10 | 11 | {-# LANGUAGE DerivingVia #-} 12 | 13 | module Language.Fortran.Repr.Type.Scalar.Complex where 14 | 15 | import Language.Fortran.Repr.Type.Scalar.Common 16 | import Language.Fortran.Repr.Type.Scalar.Real 17 | 18 | import GHC.Generics ( Generic ) 19 | import Data.Data ( Data ) 20 | import Data.Binary ( Binary ) 21 | import Text.PrettyPrint.GenericPretty ( Out ) 22 | 23 | newtype FTComplexWrapper = FTComplexWrapper { unFTComplexWrapper :: FTReal } 24 | deriving stock (Show, Generic, Data) 25 | deriving (Enum, Eq, Ord) via FTReal 26 | deriving anyclass (Binary, Out) 27 | 28 | instance FKind FTComplexWrapper where 29 | parseFKind = \case 8 -> Just $ FTComplexWrapper FTReal4 30 | 16 -> Just $ FTComplexWrapper FTReal8 31 | _ -> Nothing 32 | printFKind = \case FTComplexWrapper FTReal4 -> 8 33 | FTComplexWrapper FTReal8 -> 16 34 | -------------------------------------------------------------------------------- /src/Language/Fortran/Repr/Type/Scalar/Int.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE StandaloneKindSignatures #-} 2 | 3 | module Language.Fortran.Repr.Type.Scalar.Int where 4 | 5 | import Language.Fortran.Repr.Type.Scalar.Common 6 | 7 | import GHC.Generics ( Generic ) 8 | import Data.Data ( Data ) 9 | import Data.Binary ( Binary ) 10 | import Text.PrettyPrint.GenericPretty ( Out ) 11 | 12 | -- | The Fortran integer type. 13 | data FTInt 14 | = FTInt1 -- ^ @INTEGER(1)@ 15 | | FTInt2 -- ^ @INTEGER(2)@ 16 | | FTInt4 -- ^ @INTEGER(4)@ 17 | | FTInt8 -- ^ @INTEGER(8)@ 18 | | FTInt16 -- ^ @INTEGER(16)@ 19 | deriving stock (Show, Generic, Data, Enum, Eq, Ord) 20 | deriving anyclass (Binary, Out) 21 | 22 | instance FKind FTInt where 23 | parseFKind = \case 1 -> Just FTInt1 24 | 2 -> Just FTInt2 25 | 4 -> Just FTInt4 26 | 8 -> Just FTInt8 27 | 16 -> Just FTInt16 28 | _ -> Nothing 29 | printFKind = \case FTInt1 -> 1 30 | FTInt2 -> 2 31 | FTInt4 -> 4 32 | FTInt8 -> 8 33 | FTInt16 -> 16 34 | 35 | type FTIntCombine :: FTInt -> FTInt -> FTInt 36 | type family FTIntCombine k1 k2 where 37 | FTIntCombine k k = k 38 | FTIntCombine 'FTInt16 _ = 'FTInt16 39 | FTIntCombine _ 'FTInt16 = 'FTInt16 40 | FTIntCombine 'FTInt8 _ = 'FTInt8 41 | FTIntCombine _ 'FTInt8 = 'FTInt8 42 | FTIntCombine 'FTInt4 _ = 'FTInt4 43 | FTIntCombine _ 'FTInt4 = 'FTInt4 44 | FTIntCombine 'FTInt2 _ = 'FTInt2 45 | FTIntCombine _ 'FTInt2 = 'FTInt2 46 | -------------------------------------------------------------------------------- /src/Language/Fortran/Repr/Type/Scalar/Real.hs: -------------------------------------------------------------------------------- 1 | module Language.Fortran.Repr.Type.Scalar.Real where 2 | 3 | import Language.Fortran.Repr.Type.Scalar.Common 4 | 5 | import GHC.Generics ( Generic ) 6 | import Data.Data ( Data ) 7 | import Data.Binary ( Binary ) 8 | import Text.PrettyPrint.GenericPretty ( Out ) 9 | 10 | data FTReal 11 | = FTReal4 12 | | FTReal8 13 | deriving stock (Show, Generic, Data, Enum, Eq, Ord) 14 | deriving anyclass (Binary, Out) 15 | 16 | instance FKind FTReal where 17 | parseFKind = \case 4 -> Just FTReal4 18 | 8 -> Just FTReal8 19 | _ -> Nothing 20 | -- spurious warning on GHC 9.0 21 | printFKind = \case FTReal4 -> 4 22 | FTReal8 -> 8 23 | -------------------------------------------------------------------------------- /src/Language/Fortran/Repr/Type/Scalar/String.hs: -------------------------------------------------------------------------------- 1 | module Language.Fortran.Repr.Type.Scalar.String where 2 | 3 | import Language.Fortran.Repr.Compat.Natural 4 | 5 | import GHC.Generics ( Generic ) 6 | import Data.Data ( Data ) 7 | import Data.Binary ( Binary ) 8 | import Text.PrettyPrint.GenericPretty ( Out ) 9 | import Text.PrettyPrint.GenericPretty.Orphans() 10 | 11 | -- | The length of a CHARACTER value. 12 | -- 13 | -- IanH provides a great reference on StackOverflow: 14 | -- https://stackoverflow.com/a/25051522/2246637 15 | data CharLen 16 | = CharLen Natural 17 | -- ^ @CHARACTER(LEN=x)@ (where @x@ is a constant integer expression). Value 18 | -- has the given static length. 19 | 20 | | CharLenAssumed 21 | -- ^ @CHARACTER(LEN=*)@. F90. Value has assumed length. For a dummy argument, 22 | -- the length is assumed from the actual argument. For a PARAMETER named 23 | -- constant, the length is assumed from the length of the initializing 24 | -- expression. 25 | 26 | | CharLenDeferred 27 | -- ^ @CHARACTER(LEN=:)@. F2003. Value has deferred length. Must have the 28 | -- ALLOCATABLE or POINTER attribute. 29 | 30 | deriving stock (Show, Generic, Data, Eq, Ord) 31 | deriving anyclass (Binary, Out) 32 | 33 | prettyCharLen :: Natural -> String 34 | prettyCharLen l = "LEN="<>show l 35 | -------------------------------------------------------------------------------- /src/Language/Fortran/Repr/Util.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | 3 | module Language.Fortran.Repr.Util where 4 | 5 | import Language.Fortran.Repr.Compat.Natural 6 | 7 | import GHC.TypeNats 8 | import GHC.Exts 9 | 10 | natVal'' :: forall (a :: NaturalK). KnownNat a => Natural 11 | natVal'' = natVal' (proxy# :: Proxy# a) 12 | -------------------------------------------------------------------------------- /src/Language/Fortran/Repr/Value.hs: -------------------------------------------------------------------------------- 1 | {- | Precise Fortran value model. 2 | 3 | Note that we actually think about two different models: one storing values 4 | "machine-like" (@Machine@), one storing them "mathematically idealized" 5 | (@Idealized@). Only certain Fortran types have these split representations, 6 | namely integers and logicals. The rest have a single representation each. 7 | 8 | Both representations may be convenient in different own ways: 9 | 10 | * Machine representation is efficient, and should retain common overflow 11 | behaviours without explicitly handling them. 12 | * Idealized representation is easier to handle, and enables safe checking for 13 | overflows. 14 | 15 | The same kind algebra is performed for both, so types & kinds should match. 16 | 17 | As of 2022-08-15, idealized representation isn't properly supported -- this 18 | module simply re-exports the machine representation. 19 | -} 20 | 21 | module Language.Fortran.Repr.Value 22 | ( module Language.Fortran.Repr.Value.Machine 23 | ) where 24 | 25 | import Language.Fortran.Repr.Value.Machine 26 | -------------------------------------------------------------------------------- /src/Language/Fortran/Repr/Value/Common.hs: -------------------------------------------------------------------------------- 1 | module Language.Fortran.Repr.Value.Common where 2 | 3 | data PrimRepr 4 | = Machine 5 | -- ^ Representation behaviour intends to match Fortran's. I guess we'll target 6 | -- gfortran. 7 | 8 | | Idealized 9 | -- ^ Use "mathematically ideal" representations e.g. 'Integer' for all 10 | -- @INTEGER(x)@ types. This enables us to check for correctness issues such 11 | -- as overflow. 12 | 13 | data Check 14 | = Checked 15 | -- ^ Where relevant/possible, values will be checked for correctness (e.g. 16 | -- existence of over/underflow), and adjusted accordingly. 17 | 18 | | Unchecked 19 | -- ^ Values will not be checked for correctness. 20 | -------------------------------------------------------------------------------- /src/Language/Fortran/Repr/Value/Machine.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingVia #-} 2 | 3 | module Language.Fortran.Repr.Value.Machine where 4 | 5 | import Language.Fortran.Repr.Value.Scalar.Real 6 | import Language.Fortran.Repr.Value.Scalar.Int.Machine 7 | import Language.Fortran.Repr.Value.Scalar.Machine 8 | import Language.Fortran.Repr.Type 9 | 10 | import GHC.Generics ( Generic ) 11 | import Data.Data ( Data ) 12 | import Data.Binary ( Binary ) 13 | import Text.PrettyPrint.GenericPretty ( Out ) 14 | 15 | -- | A Fortran value (scalar only currently). 16 | data FValue = MkFScalarValue FScalarValue 17 | deriving stock (Show, Generic, Data, Eq) 18 | deriving anyclass (Binary, Out) 19 | 20 | fValueType :: FValue -> FType 21 | fValueType = \case 22 | MkFScalarValue a -> MkFScalarType $ fScalarValueType a 23 | 24 | fromConstInt :: FValue -> Maybe Integer 25 | fromConstInt (MkFScalarValue (FSVInt a)) = Just $ withFInt a 26 | fromConstInt _ = Nothing 27 | 28 | fromConstReal :: FValue -> Maybe Double 29 | fromConstReal (MkFScalarValue (FSVReal (FReal4 a))) = Just $ floatToDouble a 30 | where 31 | floatToDouble :: Float -> Double 32 | floatToDouble = realToFrac 33 | fromConstReal (MkFScalarValue (FSVReal (FReal8 a))) = Just $ a 34 | fromConstReal _ = Nothing -------------------------------------------------------------------------------- /src/Language/Fortran/Repr/Value/Scalar.hs: -------------------------------------------------------------------------------- 1 | {- | Fortran scalar value representation. 2 | 3 | For kinded Fortran types where different kinds use different representations, 4 | e.g. INTEGER, the general pattern is to export a rank-2 function each for unary 5 | and binary operations. They are restricted with a type class appropriate to the 6 | underlying values stored e.g. 'Integral', 'RealFloat'. The function is then 7 | specialized depending on the value's representation - and thus kind, since the 8 | kind informs the representation. 9 | 10 | For more details, see the 'Language.Fortran.Repr.Value.Scalar.Int.Machine' 11 | module. 12 | -} 13 | 14 | module Language.Fortran.Repr.Value.Scalar 15 | ( module Language.Fortran.Repr.Value.Scalar.Machine 16 | ) where 17 | 18 | import Language.Fortran.Repr.Value.Scalar.Machine 19 | -------------------------------------------------------------------------------- /src/Language/Fortran/Repr/Value/Scalar/Common.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingVia #-} 2 | {-# LANGUAGE QuantifiedConstraints #-} 3 | {-# LANGUAGE UndecidableInstances #-} 4 | {-# LANGUAGE AllowAmbiguousTypes #-} 5 | 6 | -- | Common definitions for Fortran scalar representations. 7 | module Language.Fortran.Repr.Value.Scalar.Common where 8 | 9 | import Language.Fortran.Repr.Type.Scalar.Common 10 | 11 | import Data.Singletons 12 | 13 | import Text.PrettyPrint.GenericPretty ( Out ) 14 | import Text.PrettyPrint.GenericPretty.ViaShow ( OutShowly(..) ) 15 | import Data.Binary 16 | import Data.Data ( Data, Typeable ) 17 | 18 | import Data.Kind 19 | 20 | {- | Convenience wrapper which multiple Fortran tag-kinded intrinsic types fit. 21 | 22 | A type @ft@ takes some type @fk@ of kind @k@, and we are permitted to move the 23 | type between the term and type levels using the included singleton instances. 24 | 25 | For example, integers are kinded with type level @FTInt@s. So we can define an 26 | integer with an existential ("unknown") kind with the type @'SomeFKinded' FTInt 27 | FInt@. By pattern matching on it, we recover the hidden kind tag (as well as 28 | obtaining the value). 29 | 30 | Note that many type classes usually derived generically (e.g. 31 | 'Data.Binary.Binary') instances should be manually derived on this wrapper type. 32 | TODO give a better explanation why? 33 | -} 34 | data SomeFKinded k ft where 35 | SomeFKinded 36 | :: forall {k} ft (fk :: k) 37 | . (SingKind k, SingI fk, Data (ft fk)) 38 | => ft fk 39 | -> SomeFKinded k ft 40 | 41 | deriving stock instance 42 | ( SingKind k 43 | , forall (fk :: k). SingI fk 44 | , forall (fk :: k). Data (ft fk) 45 | , Typeable ft 46 | , Typeable k 47 | ) => Data (SomeFKinded k ft) 48 | --instance (Typeable k, Typeable ft) => Data (SomeFKinded k ft) where 49 | 50 | -- | GHC can derive stock 'Show' instances given some @QuantifiedConstraints@ 51 | -- guarantees (wow!). 52 | deriving stock instance (forall fk. Show (ft fk)) => Show (SomeFKinded k ft) 53 | 54 | -- | Derive 'Out' instances via 'Show'. 55 | deriving via OutShowly (SomeFKinded k ft) instance (forall fk. Show (ft fk)) => Out (SomeFKinded k ft) 56 | 57 | -- | For any Fortran type @ft@ kinded with @k@, we may derive a 'Binary' 58 | -- instance by leveraging the kind tag's instance @'Binary' ('Demote' k)@ and 59 | -- the kinded value's instance @'Binary' (ft k)@. (We also have to ferry some 60 | -- singletons instances through.) 61 | -- 62 | -- WARNING: This instance is only sound for types where each kind tag value is 63 | -- used once at most (meaning if you know the fkind, you know the constructor). 64 | -- 65 | -- Note that the 'Data.Binary.Get' instance works by parsing a kind tag, 66 | -- promoting it to a singleton, then gleaning type information and using that to 67 | -- parse the inner kinded value. Dependent types! 68 | -- TODO if we pack a Data context into SomeFKinded, get can't recover it!! 69 | instance 70 | ( Binary (Demote k) 71 | , SingKind k 72 | , forall (fk :: k). SingI fk => Binary (ft fk) 73 | , forall (fk :: k). Data (ft fk) 74 | ) => Binary (SomeFKinded k ft) where 75 | put someV@(SomeFKinded v) = do 76 | put $ someFKindedKind someV 77 | put v 78 | get = get @(Demote k) >>= \case -- parse fkind tag 79 | kindTag -> 80 | withSomeSing kindTag f 81 | where 82 | f :: forall (fk :: k). Sing fk -> Get (SomeFKinded k ft) 83 | f kind = do 84 | withSingI @fk kind $ do 85 | v <- get @(ft fk) 86 | pure $ undefined -- SomeFKinded @k @ft v 87 | 88 | -- | Recover some @TYPE(x)@'s kind (the @x@). 89 | someFKindedKind :: SomeFKinded k ft -> Demote k 90 | someFKindedKind (SomeFKinded (_ :: ft fk)) = demote @fk 91 | 92 | --- 93 | 94 | -- | A kinded Fortran value. 95 | class FKinded a where 96 | -- | The Haskell type used to record this Fortran type's kind. 97 | type FKindedT a 98 | 99 | -- | For every Fortran kind of this Fortran type @a@, the underlying 100 | -- representation @b@ has the given constraints. 101 | type FKindedC a b :: Constraint 102 | 103 | -- | Obtain the kind of a Fortran value. 104 | fKind :: a -> FKindedT a 105 | -------------------------------------------------------------------------------- /src/Language/Fortran/Repr/Value/Scalar/Complex.hs: -------------------------------------------------------------------------------- 1 | {- | Fortran COMPLEX value representation. 2 | 3 | A Fortran COMPLEX is simply two REALs of the same kind. 4 | -} 5 | 6 | {-# LANGUAGE DerivingVia #-} 7 | 8 | module Language.Fortran.Repr.Value.Scalar.Complex where 9 | 10 | import Language.Fortran.Repr.Value.Scalar.Common 11 | import Language.Fortran.Repr.Type.Scalar.Real 12 | import Language.Fortran.Repr.Value.Scalar.Real 13 | import GHC.Float ( float2Double ) 14 | 15 | import GHC.Generics ( Generic ) 16 | import Data.Data ( Data ) 17 | import Data.Binary ( Binary ) 18 | import Text.PrettyPrint.GenericPretty ( Out ) 19 | 20 | data FComplex 21 | = FComplex8 {- ^ @COMPLEX(8)@ -} Float Float 22 | | FComplex16 {- ^ @COMPLEX(16)@ -} Double Double 23 | deriving stock (Show, Generic, Data) 24 | deriving anyclass (Binary, Out) 25 | 26 | instance FKinded FComplex where 27 | type FKindedT FComplex = FTReal 28 | type FKindedC FComplex a = RealFloat a 29 | fKind = \case 30 | FComplex8{} -> FTReal4 31 | FComplex16{} -> FTReal8 32 | 33 | instance Eq FComplex where (==) = fComplexBOp (==) (&&) 34 | 35 | fComplexFromReal :: FReal -> FComplex 36 | fComplexFromReal = \case FReal4 x -> FComplex8 x 0.0 37 | FReal8 x -> FComplex16 x 0.0 38 | 39 | fComplexBOp' 40 | :: (Float -> Float -> a) 41 | -> (a -> a -> r) 42 | -> (Double -> Double -> b) 43 | -> (b -> b -> r) 44 | -> FComplex -> FComplex -> r 45 | fComplexBOp' k8f k8g k16f k16g l r = 46 | case (l, r) of 47 | (FComplex8 lr li, FComplex8 rr ri) -> k8g (k8f lr rr) (k8f li ri) 48 | (FComplex16 lr li, FComplex16 rr ri) -> k16g (k16f lr rr) (k16f li ri) 49 | (FComplex8 lr li, FComplex16 rr ri) -> 50 | let lr' = float2Double lr 51 | li' = float2Double li 52 | in k16g (k16f lr' rr) (k16f li' ri) 53 | (FComplex16 lr li, FComplex8 rr ri) -> 54 | let rr' = float2Double rr 55 | ri' = float2Double ri 56 | in k16g (k16f lr rr') (k16f li ri') 57 | 58 | fComplexBOpInplace' 59 | :: (Float -> Float -> Float) 60 | -> (Double -> Double -> Double) 61 | -> FComplex -> FComplex -> FComplex 62 | fComplexBOpInplace' k8f k16f = fComplexBOp' k8f FComplex8 k16f FComplex16 63 | 64 | fComplexBOp 65 | :: (forall a. FKindedC FComplex a => a -> a -> b) 66 | -> (b -> b -> r) 67 | -> FComplex -> FComplex -> r 68 | fComplexBOp f g = fComplexBOp' f g f g 69 | 70 | fComplexBOpInplace 71 | :: (forall a. FKindedC FComplex a => a -> a -> a) 72 | -> FComplex -> FComplex -> FComplex 73 | fComplexBOpInplace f = fComplexBOpInplace' f f 74 | -------------------------------------------------------------------------------- /src/Language/Fortran/Repr/Value/Scalar/Int.hs: -------------------------------------------------------------------------------- 1 | module Language.Fortran.Repr.Value.Scalar.Int 2 | ( module Language.Fortran.Repr.Value.Scalar.Int.Machine 3 | ) where 4 | 5 | import Language.Fortran.Repr.Value.Scalar.Int.Machine 6 | -------------------------------------------------------------------------------- /src/Language/Fortran/Repr/Value/Scalar/Int/Idealized.hs: -------------------------------------------------------------------------------- 1 | {- | Idealized Fortran INTEGER values. 2 | 3 | This module stores Fortran INTEGER values in a Haskell 'Integer', together with 4 | a phantom type describing the Fortran kind. This way, we can safely check for 5 | bounds issues, and leave exact behaviour up to the user. 6 | -} 7 | 8 | {-# LANGUAGE AllowAmbiguousTypes #-} 9 | {-# LANGUAGE StandaloneKindSignatures #-} 10 | {-# LANGUAGE TypeFamilyDependencies #-} -- just for better inference (maybe) 11 | {-# LANGUAGE DerivingVia #-} 12 | 13 | module Language.Fortran.Repr.Value.Scalar.Int.Idealized where 14 | 15 | import Language.Fortran.Repr.Type.Scalar.Int 16 | import Data.Kind 17 | import Data.Int 18 | 19 | import GHC.Generics ( Generic ) 20 | import Data.Data ( Data ) 21 | import Data.Binary ( Binary ) 22 | import Text.PrettyPrint.GenericPretty ( Out ) 23 | 24 | type FIntMRep :: FTInt -> Type 25 | type family FIntMRep k = r | r -> k where 26 | FIntMRep 'FTInt1 = Int8 27 | FIntMRep 'FTInt2 = Int16 28 | FIntMRep 'FTInt4 = Int32 29 | FIntMRep 'FTInt8 = Int64 30 | 31 | newtype FIntI (k :: FTInt) = FIntI Integer 32 | deriving stock (Show, Generic, Data) 33 | deriving (Eq, Ord) via Integer 34 | deriving anyclass (Binary, Out) 35 | 36 | fIntICheckBounds 37 | :: forall k rep. (rep ~ FIntMRep k, Bounded rep, Integral rep) 38 | => FIntI k -> Maybe String 39 | fIntICheckBounds (FIntI i) = 40 | if i > fromIntegral (maxBound @rep) 41 | then Just "TODO too large" 42 | else if 　i < fromIntegral (minBound @rep) 43 | then Just "TODO too small" 44 | else Nothing 45 | 46 | data SomeFIntI = forall fk. SomeFIntI (FIntI fk) 47 | deriving stock instance Show SomeFIntI 48 | instance Eq SomeFIntI where 49 | (SomeFIntI (FIntI l)) == (SomeFIntI (FIntI r)) = l == r 50 | 51 | -- this might look silly, but it's because even if we don't do kinded 52 | -- calculations, we must still kind the output 53 | someFIntIBOpWrap 54 | :: (Integer -> Integer -> Integer) 55 | -> SomeFIntI -> SomeFIntI -> SomeFIntI 56 | someFIntIBOpWrap f (SomeFIntI (FIntI li :: FIntI lfk)) (SomeFIntI (FIntI ri :: FIntI rfk)) = 57 | SomeFIntI $ FIntI @(FTIntCombine lfk rfk) $ f li ri 58 | 59 | {- 60 | fIntIBOpWrap 61 | :: forall kl kr. (Integer -> Integer -> Integer) 62 | -> FIntI kl -> FIntI kr -> FIntI (FTIntCombine kl kr) 63 | fIntIBOpWrap f l r = 64 | case (l, r) of 65 | (FIntI il :: FIntI 'FTInt16, FIntI ir) -> FIntI @'FTInt16 $ f il ir 66 | 67 | {- 68 | (FIntI l) (FIntI r) = 69 | case (demote @kl, demote @kr) of 70 | (FTInt16, _) -> FIntI @'FTInt16 x 71 | (_, FTInt16) -> FIntI @'FTInt16 x 72 | (FTInt8, _) -> FIntI @'FTInt8 x 73 | (_, FTInt8) -> FIntI @'FTInt8 x 74 | (FTInt4, _) -> FIntI @'FTInt4 x 75 | (_, FTInt4) -> FIntI @'FTInt4 x 76 | (FTInt2, _) -> FIntI @'FTInt2 x 77 | (_, FTInt2) -> FIntI @'FTInt2 x 78 | (FTInt1, FTInt1) -> FIntI @'FTInt1 x 79 | -} 80 | -} 81 | -------------------------------------------------------------------------------- /src/Language/Fortran/Repr/Value/Scalar/Int/Machine.hs: -------------------------------------------------------------------------------- 1 | {- | Machine Fortran INTEGER values. 2 | 3 | This module stores Fortran INTEGER values in a matching Haskell machine integer 4 | type. For example, an @INT(4)@ would be stored in an 'Int32'. This way, we get 5 | both efficient operations and common overflow behaviour (which hopefully matches 6 | most Fortran compilers), and explicitly encode kinding semantics via promoting 7 | integral types. 8 | -} 9 | 10 | module Language.Fortran.Repr.Value.Scalar.Int.Machine where 11 | 12 | import Language.Fortran.Repr.Type.Scalar.Int 13 | import Language.Fortran.Repr.Value.Scalar.Common 14 | import Data.Int 15 | 16 | import Data.Bits ( Bits ) 17 | 18 | import GHC.Generics ( Generic ) 19 | import Data.Data ( Data ) 20 | import Data.Binary ( Binary ) 21 | import Text.PrettyPrint.GenericPretty ( Out ) 22 | import Text.PrettyPrint.GenericPretty.Orphans() 23 | 24 | -- | A Fortran integer value, type @INTEGER(k)@. 25 | data FInt 26 | = FInt1 {- ^ @INTEGER(1)@ -} Int8 27 | | FInt2 {- ^ @INTEGER(2)@ -} Int16 28 | | FInt4 {- ^ @INTEGER(4)@ -} Int32 29 | | FInt8 {- ^ @INTEGER(8)@ -} Int64 30 | deriving stock (Show, Generic, Data) 31 | deriving anyclass (Binary, Out) 32 | 33 | instance FKinded FInt where 34 | type FKindedT FInt = FTInt 35 | type FKindedC FInt a = (Integral a, Bits a) 36 | fKind = \case 37 | FInt1{} -> FTInt1 38 | FInt2{} -> FTInt2 39 | FInt4{} -> FTInt4 40 | FInt8{} -> FTInt8 41 | 42 | instance Eq FInt where (==) = fIntBOp (==) 43 | 44 | withFInt :: Num a => FInt -> a 45 | withFInt = fIntUOp fromIntegral 46 | 47 | -- Pattern matches are ordered to match more common ops earlier. 48 | fIntUOp' 49 | :: (Int8 -> r) 50 | -> (Int16 -> r) 51 | -> (Int32 -> r) 52 | -> (Int64 -> r) 53 | -> FInt -> r 54 | fIntUOp' k1f k2f k4f k8f = \case 55 | FInt4 i32 -> k4f i32 56 | FInt8 i64 -> k8f i64 57 | FInt2 i16 -> k2f i16 58 | FInt1 i8 -> k1f i8 59 | 60 | -- Pattern matches are ordered to match more common ops earlier. 61 | fIntBOp' 62 | :: (Int8 -> Int8 -> r) 63 | -> (Int16 -> Int16 -> r) 64 | -> (Int32 -> Int32 -> r) 65 | -> (Int64 -> Int64 -> r) 66 | -> FInt -> FInt -> r 67 | fIntBOp' k1f k2f k4f k8f il ir = case (il, ir) of 68 | (FInt4 l32, FInt4 r32) -> k4f l32 r32 69 | (FInt8 l64, FInt8 r64) -> k8f l64 r64 70 | 71 | (FInt4 l32, FInt8 r64) -> k8f (fromIntegral l32) r64 72 | (FInt8 l64, FInt4 r32) -> k8f l64 (fromIntegral r32) 73 | 74 | (FInt4 l32, FInt2 r16) -> k4f l32 (fromIntegral r16) 75 | (FInt2 l16, FInt4 r32) -> k4f (fromIntegral l16) r32 76 | 77 | (FInt4 l32, FInt1 r8) -> k4f l32 (fromIntegral r8) 78 | (FInt1 l8, FInt4 r32) -> k4f (fromIntegral l8) r32 79 | 80 | (FInt8 l64, FInt2 r16) -> k8f l64 (fromIntegral r16) 81 | (FInt2 l16, FInt8 r64) -> k8f (fromIntegral l16) r64 82 | 83 | (FInt8 l64, FInt1 r8) -> k8f l64 (fromIntegral r8) 84 | (FInt1 l8, FInt8 r64) -> k8f (fromIntegral l8) r64 85 | 86 | (FInt2 l16, FInt2 r16) -> k2f l16 r16 87 | (FInt2 l16, FInt1 r8) -> k2f l16 (fromIntegral r8) 88 | (FInt1 l8, FInt2 r16) -> k2f (fromIntegral l8) r16 89 | 90 | (FInt1 l8, FInt1 r8) -> k1f l8 r8 91 | 92 | fIntUOpInplace' 93 | :: (Int8 -> Int8) 94 | -> (Int16 -> Int16) 95 | -> (Int32 -> Int32) 96 | -> (Int64 -> Int64) 97 | -> FInt -> FInt 98 | fIntUOpInplace' k1f k2f k4f k8f = 99 | fIntUOp' (FInt1 . k1f) (FInt2 . k2f) (FInt4 . k4f) (FInt8 . k8f) 100 | 101 | fIntBOpInplace' 102 | :: (Int8 -> Int8 -> Int8) 103 | -> (Int16 -> Int16 -> Int16) 104 | -> (Int32 -> Int32 -> Int32) 105 | -> (Int64 -> Int64 -> Int64) 106 | -> FInt -> FInt -> FInt 107 | fIntBOpInplace' k1f k2f k4f k8f = 108 | fIntBOp' (f FInt1 k1f) (f FInt2 k2f) (f FInt4 k4f) (f FInt8 k8f) 109 | where f cstr bop l r = cstr $ bop l r 110 | 111 | fIntUOp :: (forall a. FKindedC FInt a => a -> r) -> FInt -> r 112 | fIntUOp f = fIntUOp' f f f f 113 | 114 | fIntUOpInplace :: (forall a. FKindedC FInt a => a -> a) -> FInt -> FInt 115 | fIntUOpInplace f = fIntUOpInplace' f f f f 116 | 117 | fIntBOp :: (forall a. FKindedC FInt a => a -> a -> r) -> FInt -> FInt -> r 118 | fIntBOp f = fIntBOp' f f f f 119 | 120 | fIntBOpInplace :: (forall a. FKindedC FInt a => a -> a -> a) -> FInt -> FInt -> FInt 121 | fIntBOpInplace f = fIntBOpInplace' f f f f 122 | 123 | {- 124 | 125 | -- TODO improve: always return answer, plus a flag indicating if there was an 126 | -- error, plus this should be in eval instead and this should be simpler 127 | -- (shouldn't be wrapping in Either) 128 | fIntCoerceChecked :: FTInt -> FInt -> Either String FInt 129 | fIntCoerceChecked ty = fIntUOp $ \n -> 130 | if fromIntegral n > fIntMax @kout then 131 | Left "too large for new size" 132 | else if fromIntegral n < fIntMin @kout then 133 | Left "too small for new size" 134 | else 135 | case ty of 136 | FTInt1 -> Right $ FInt1 $ fromIntegral n 137 | FTInt2 -> Right $ FInt2 $ fromIntegral n 138 | FTInt4 -> Right $ FInt4 $ fromIntegral n 139 | FTInt8 -> Right $ FInt8 $ fromIntegral n 140 | FTInt16 -> Left "can't represent INTEGER(16) yet, sorry" 141 | 142 | -} 143 | -------------------------------------------------------------------------------- /src/Language/Fortran/Repr/Value/Scalar/Logical.hs: -------------------------------------------------------------------------------- 1 | module Language.Fortran.Repr.Value.Scalar.Logical 2 | ( module Language.Fortran.Repr.Value.Scalar.Logical.Machine 3 | ) where 4 | 5 | import Language.Fortran.Repr.Value.Scalar.Logical.Machine 6 | -------------------------------------------------------------------------------- /src/Language/Fortran/Repr/Value/Scalar/Logical/Idealized.hs: -------------------------------------------------------------------------------- 1 | {- | Idealized Fortran LOGICAL values. 2 | 3 | In cases where you don't need the machine representation of a @LOGICAL(x)@, 4 | which is likely to be an @INTEGER(x)@, you can store all kinds with a Haskell 5 | 'Bool'. 6 | -} 7 | 8 | module Language.Fortran.Repr.Value.Scalar.Logical.Idealized where 9 | 10 | import Language.Fortran.Repr.Type.Scalar.Int 11 | 12 | newtype FLogical (k :: FTInt) = FLogical Bool 13 | deriving stock (Show, Eq, Ord) 14 | -------------------------------------------------------------------------------- /src/Language/Fortran/Repr/Value/Scalar/Logical/Machine.hs: -------------------------------------------------------------------------------- 1 | {- | Machine Fortran LOGICAL values. 2 | 3 | Fortran compilers usually store LOGICALs as INTEGERs (they former is tied to the 4 | latter in the specifications). To more accurately simulate their behaviour, we 5 | represent them directly as integers, and simply provide a handful of definitions 6 | for using them as booleans. 7 | -} 8 | 9 | module Language.Fortran.Repr.Value.Scalar.Logical.Machine where 10 | 11 | import Language.Fortran.Repr.Value.Scalar.Int.Machine 12 | 13 | -- | Retrieve the boolean value stored by a @LOGICAL(x)@. 14 | fLogicalToBool :: FInt -> Bool 15 | fLogicalToBool = fIntUOp $ consumeFLogicalNumeric True False 16 | 17 | -- | Convert a bool to its Fortran machine representation in any numeric type. 18 | fLogicalNumericFromBool :: Num a => Bool -> a 19 | fLogicalNumericFromBool = \case True -> 1; False -> 0 20 | 21 | -- | Consume some Fortran logical stored using an integer. 22 | consumeFLogicalNumeric :: (Num a, Eq a) => r -> r -> a -> r 23 | consumeFLogicalNumeric whenTrue whenFalse bi = 24 | if bi == 1 then whenTrue else whenFalse 25 | 26 | fLogicalNot :: FInt -> FInt 27 | fLogicalNot = fIntUOpInplace (consumeFLogicalNumeric 0 1) 28 | -------------------------------------------------------------------------------- /src/Language/Fortran/Repr/Value/Scalar/Machine.hs: -------------------------------------------------------------------------------- 1 | module Language.Fortran.Repr.Value.Scalar.Machine 2 | ( 3 | -- * Note on type coercion implementation 4 | -- $type-coercion-implementation 5 | 6 | FScalarValue(..) 7 | , fScalarValueType 8 | ) where 9 | 10 | import Language.Fortran.Repr.Value.Scalar.Common 11 | import Language.Fortran.Repr.Value.Scalar.Int.Machine 12 | import Language.Fortran.Repr.Value.Scalar.Real 13 | import Language.Fortran.Repr.Value.Scalar.Complex 14 | import Language.Fortran.Repr.Type.Scalar 15 | 16 | import Data.Text ( Text ) 17 | import qualified Data.Text as Text 18 | 19 | import GHC.Generics ( Generic ) 20 | import Data.Data ( Data ) 21 | import Data.Binary ( Binary ) 22 | import Text.PrettyPrint.GenericPretty ( Out ) 23 | import Text.PrettyPrint.GenericPretty.Orphans() 24 | 25 | {- $type-coercion-implementation 26 | 27 | When you run a binary operation on two Fortran values, type coercion may take 28 | place depending on the types of the values. This complicates evaluation code, 29 | because now we have to export two sets of functions for operating on values: one 30 | for returning a kinded value (e.g. addition returns the same type), and one for 31 | non-kinded values (e.g. equality returns a boolean). 32 | 33 | On the lowest level, e.g. for operating over @INTEGER(x)@ and @INTEGER(y)@, we 34 | resolve this by doing the coercion in an internal function which is polymorphic 35 | over the result type, and using that in both sets of functions. To operate 36 | kinded, we use the relevant type. To operate unkinded, we use 37 | @'Data.Functor.Const' r@, which ignores the kind and just stores a value of type 38 | 'r'. 39 | -} 40 | 41 | -- | A Fortran scalar value. 42 | data FScalarValue 43 | = FSVInt FInt 44 | | FSVReal FReal 45 | | FSVComplex FComplex 46 | | FSVLogical FInt 47 | | FSVString Text 48 | deriving stock (Show, Generic, Data, Eq) 49 | deriving anyclass (Binary, Out) 50 | 51 | -- | Recover a Fortran scalar value's type. 52 | fScalarValueType :: FScalarValue -> FScalarType 53 | fScalarValueType = \case 54 | FSVInt a -> FSTInt $ fKind a 55 | FSVReal a -> FSTReal $ fKind a 56 | FSVComplex a -> FSTComplex $ fKind a 57 | FSVLogical a -> FSTLogical $ fKind a 58 | FSVString a -> FSTString $ fromIntegral $ Text.length a -------------------------------------------------------------------------------- /src/Language/Fortran/Repr/Value/Scalar/Real.hs: -------------------------------------------------------------------------------- 1 | module Language.Fortran.Repr.Value.Scalar.Real where 2 | 3 | import Language.Fortran.Repr.Type.Scalar.Real 4 | import Language.Fortran.Repr.Value.Scalar.Common 5 | import GHC.Float ( float2Double ) 6 | 7 | import GHC.Generics ( Generic ) 8 | import Data.Data ( Data ) 9 | import Data.Binary ( Binary ) 10 | import Text.PrettyPrint.GenericPretty ( Out ) 11 | 12 | data FReal 13 | = FReal4 {- ^ @REAL(4)@ -} Float 14 | | FReal8 {- ^ @REAL(8)@ -} Double 15 | deriving stock (Show, Generic, Data) 16 | deriving anyclass (Binary, Out) 17 | 18 | instance FKinded FReal where 19 | type FKindedT FReal = FTReal 20 | type FKindedC FReal a = RealFloat a 21 | fKind = \case 22 | FReal4{} -> FTReal4 23 | FReal8{} -> FTReal8 24 | 25 | instance Eq FReal where (==) = fRealBOp (==) 26 | 27 | fRealUOp' 28 | :: (Float -> r) 29 | -> (Double -> r) 30 | -> FReal -> r 31 | fRealUOp' k4f k8f = \case 32 | FReal4 fl -> k4f fl 33 | FReal8 db -> k8f db 34 | 35 | fRealBOp' 36 | :: (Float -> Float -> r) 37 | -> (Double -> Double -> r) 38 | -> FReal -> FReal -> r 39 | fRealBOp' k4f k8f l r = case (l, r) of 40 | (FReal4 lr, FReal4 rr) -> k4f lr rr 41 | (FReal8 lr, FReal8 rr) -> k8f lr rr 42 | (FReal4 lr, FReal8 rr) -> k8f (float2Double lr) rr 43 | (FReal8 lr, FReal4 rr) -> k8f lr (float2Double rr) 44 | 45 | fRealUOpInplace' 46 | :: (Float -> Float) 47 | -> (Double -> Double) 48 | -> FReal -> FReal 49 | fRealUOpInplace' k4f k8f = fRealUOp' (FReal4 . k4f) (FReal8 . k8f) 50 | 51 | fRealBOpInplace' 52 | :: (Float -> Float -> Float) 53 | -> (Double -> Double -> Double) 54 | -> FReal -> FReal -> FReal 55 | fRealBOpInplace' k4f k8f = fRealBOp' (f FReal4 k4f) (f FReal8 k8f) 56 | where f cstr bop l r = cstr $ bop l r 57 | 58 | fRealUOp 59 | :: (forall a. FKindedC FReal a => a -> r) 60 | -> FReal -> r 61 | fRealUOp f = fRealUOp' f f 62 | 63 | fRealUOpInplace 64 | :: (forall a. FKindedC FReal a => a -> a) 65 | -> FReal -> FReal 66 | fRealUOpInplace f = fRealUOpInplace' f f 67 | 68 | fRealBOp 69 | :: (forall a. FKindedC FReal a => a -> a -> r) 70 | -> FReal -> FReal -> r 71 | fRealBOp f = fRealBOp' f f 72 | 73 | fRealBOpInplace 74 | :: (forall a. FKindedC FReal a => a -> a -> a) 75 | -> FReal -> FReal -> FReal 76 | fRealBOpInplace f = fRealBOpInplace' f f 77 | -------------------------------------------------------------------------------- /src/Language/Fortran/Repr/Value/Scalar/String.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingVia #-} 2 | {-# LANGUAGE QuantifiedConstraints #-} 3 | 4 | {- | Fortran CHAR value representation. 5 | 6 | Currently only CHARs of known length. 7 | -} 8 | 9 | module Language.Fortran.Repr.Value.Scalar.String where 10 | 11 | import GHC.TypeNats 12 | import Language.Fortran.Repr.Compat.Natural 13 | import Data.Text ( Text ) 14 | import qualified Data.Text as Text 15 | import Language.Fortran.Repr.Util ( natVal'' ) 16 | import Data.Proxy 17 | import Unsafe.Coerce 18 | 19 | import Text.PrettyPrint.GenericPretty ( Out ) 20 | import Text.PrettyPrint.GenericPretty.ViaShow ( OutShowly(..) ) 21 | import Data.Binary 22 | import Data.Data 23 | 24 | import Data.Singletons 25 | import GHC.TypeLits.Singletons 26 | 27 | -- TODO unsafe constructor do not use >:( 28 | -- need context for Reasons(TM) 29 | data FString (l :: NaturalK) = KnownNat l => FString Text 30 | deriving stock instance Show (FString l) 31 | deriving stock instance Eq (FString l) 32 | deriving stock instance Ord (FString l) -- TODO 33 | deriving stock instance KnownNat l => Data (FString l) 34 | 35 | {- 36 | instance Data (FString l) where 37 | --gunfold k z c = k (z (\x -> case someFString x of SomeFString y -> y)) 38 | gunfold k z c = k (z (FString @l)) 39 | -} 40 | 41 | eqFString :: FString l -> FString r -> Bool 42 | eqFString (FString l) (FString r) = l == r 43 | 44 | -- | This is a painful instance to define. We cheat by leveraging the instance 45 | -- of the length-hiding type 'SomeFString', then asserting length. It's CPU 46 | -- and memory inefficient and has backwards dependencies, but is comfortably 47 | -- safe. 48 | instance KnownNat l => Binary (FString l) where 49 | put t = put (SomeFString t) 50 | get = 51 | get @SomeFString >>= \case 52 | SomeFString (FString t) -> 53 | case fString @l t of 54 | Just t' -> pure t' 55 | Nothing -> fail "FString had incorrect length" 56 | 57 | -- | Attempt to a 'Text' into an 'FString' of the given length. 58 | fString :: forall l. KnownNat l => Text -> Maybe (FString l) 59 | fString s = 60 | if Text.length s == fromIntegral (natVal'' @l) 61 | then Just $ FString s 62 | else Nothing 63 | 64 | fStringLen :: forall l. KnownNat l => FString l -> Natural 65 | fStringLen _ = natVal'' @l 66 | 67 | data SomeFString = forall (l :: NaturalK). KnownNat l => SomeFString (FString l) 68 | deriving stock instance Show SomeFString 69 | deriving via (OutShowly SomeFString) instance Out SomeFString 70 | 71 | instance Eq SomeFString where 72 | (SomeFString l) == (SomeFString r) = l `eqFString` r 73 | 74 | -- TODO impossible?? 75 | instance Data SomeFString where 76 | 77 | {- 78 | dataSomeFStringT = mkDataType "TODO" [dataSomeFStringC1] 79 | dataSomeFStringC1 = mkConstr dataSomeFStringT "SomeFString" [] Prefix 80 | instance Data SomeFString where 81 | dataTypeOf _ = dataSomeFStringT 82 | toConstr = \case 83 | SomeFString{} -> dataSomeFStringC1 84 | --gunfold k z c = k (z SomeFString) 85 | gunfold k z c = k (z (\(FString fstr :: FString l) -> SomeFString @l (FString fstr))) 86 | -} 87 | 88 | instance Binary SomeFString where 89 | put (SomeFString (FString t)) = put t 90 | get = someFString <$> get @Text 91 | 92 | -- | Lift a 'Text' into 'SomeFString'. 93 | someFString :: Text -> SomeFString 94 | someFString t = 95 | case someNatVal (fromIntegral (Text.length t)) of 96 | SomeNat (_ :: Proxy l) -> SomeFString $ FString @l t 97 | 98 | someFStringLen :: SomeFString -> Natural 99 | someFStringLen (SomeFString s) = fStringLen s 100 | 101 | -- TODO dunno how to do this without unsafeCoerce because of the type-level nat 102 | -- addition >:( -- oh actually seems this is an expected usage of it. ok 103 | concatFString 104 | :: forall ll lr. (KnownNat ll, KnownNat lr) 105 | => FString ll 106 | -> FString lr 107 | -> FString (ll + lr) 108 | concatFString (FString sl) (FString sr) = 109 | unsafeCoerce $ FString @ll $ sl <> sr 110 | 111 | concatSomeFString :: SomeFString -> SomeFString -> SomeFString 112 | concatSomeFString (SomeFString l) (SomeFString r) = 113 | case concatFString l r of s@FString{} -> SomeFString s 114 | 115 | fStringBOp :: (Text -> Text -> r) -> FString ll -> FString lr -> r 116 | fStringBOp f (FString l) (FString r) = f l r 117 | 118 | someFStringBOp :: (Text -> Text -> r) -> SomeFString -> SomeFString -> r 119 | someFStringBOp f (SomeFString l) (SomeFString r) = fStringBOp f l r 120 | -------------------------------------------------------------------------------- /src/Language/Fortran/Rewriter.hs: -------------------------------------------------------------------------------- 1 | -- | This module provides an interface for rewriting textual, unparsed Fortran 2 | -- using a diff-like algorithm. 3 | -- 4 | -- Original code from Bloomberg, used with permission. 5 | -- 6 | -- Original authors: 7 | -- * Daniel Beer 8 | -- * Anthony Burzillo 9 | -- * Raoul Hidalgo Charman 10 | -- * Aiden Jeffrey 11 | -- * Jason Xu 12 | -- * Beleth Apophis 13 | -- * Lukasz Kolodziejczyk 14 | 15 | module Language.Fortran.Rewriter 16 | ( RI.SourceLocation(..) 17 | , RI.SourceRange(..) 18 | , RI.Replacement(..) 19 | , RI.ReplacementError(..) 20 | , RI.ReplacementMap 21 | , partitionOverlapping 22 | , processReplacements 23 | , spanToSourceRange 24 | , spanToSourceRange2 25 | , sourceRangeBetweenTwoSpans 26 | ) 27 | where 28 | 29 | import qualified Data.ByteString.Lazy.Char8 as BC 30 | import qualified Language.Fortran.Rewriter.Internal 31 | as RI 32 | import Control.Exception ( finally ) 33 | import Control.Monad ( when ) 34 | import Data.Bifunctor ( bimap ) 35 | import Data.List ( partition ) 36 | import qualified Data.Map as M 37 | import Language.Fortran.Util.Position ( lineCol 38 | , SrcSpan(..) 39 | ) 40 | import System.Directory ( doesFileExist 41 | , removeFile 42 | , renameFile 43 | ) 44 | 45 | -- | Remove overlapping items from a list of replacements and return a pair of 46 | -- lists containing disjoint items and overlapping items, respectively. 47 | -- 48 | -- __Important notes:__ 49 | -- 50 | -- Replacements that come first in the list will be given precedence over later 51 | -- items. 52 | partitionOverlapping :: [RI.Replacement] -> ([RI.Replacement], [RI.Replacement]) 53 | partitionOverlapping [] = ([], []) 54 | partitionOverlapping repls = 55 | let currentRepl = head repls 56 | (overlapping, remaining) = 57 | partition (not . RI.areDisjoint currentRepl) (tail repls) 58 | nextResult = partitionOverlapping remaining 59 | in Data.Bifunctor.bimap (currentRepl :) (overlapping <>) nextResult 60 | 61 | -- | Apply a list of 'Replacement's to the orginal source file. 62 | -- 63 | -- __Important notes:__ 64 | -- 65 | -- Source locations specified in replacements are 0-indexed. 66 | -- 67 | -- Rewriting applies continuation lines when lines are longer than 72 characters. 68 | -- 69 | -- __Example replacements:__ 70 | -- 71 | -- Delete the first character in a file 72 | -- 73 | -- @ Replacement (SourceRange (SourceLocation 0 0) (SourceLocation 0 1)) "" @ 74 | -- 75 | -- Prepend "a" to 1 line, 2 column character 76 | -- 77 | -- @ Replacement (SourceRange (SourceLocation 0 1) (SourceLocation 0 1)) "a" @ 78 | -- 79 | -- Replace a character located in 2 line, 4 column with "a" 80 | -- 81 | -- @ Replacement (SourceRange (SourceLocation 1 3) (SourceLocation 1 4)) "a" @ 82 | -- 83 | -- Replace string starting in 2 line, 4 column and ending in 2 line, 6 column (inclusive) with "a" 84 | -- 85 | -- @ Replacement (SourceRange (SourceLocation 1 3) (SourceLocation 1 6)) "a" @ 86 | -- 87 | -- @since 0.1.0.0 88 | processReplacements :: RI.ReplacementMap -> IO () 89 | processReplacements rm = processReplacements_ $ M.toList rm 90 | 91 | processReplacements_ :: [(String, [RI.Replacement])] -> IO () 92 | processReplacements_ [] = return () 93 | processReplacements_ ((filePath, repls) : xs) = do 94 | contents <- BC.readFile filePath 95 | let newContents = RI.applyReplacements contents repls 96 | tempFilePath = filePath ++ ".temp" 97 | maybeRm = do 98 | exists <- doesFileExist tempFilePath 99 | when exists $ removeFile tempFilePath 100 | flip finally maybeRm $ do 101 | BC.writeFile tempFilePath newContents 102 | renameFile tempFilePath filePath 103 | processReplacements_ xs 104 | 105 | -- | Utility function to convert 'SrcSpan' to 'SourceRange' 106 | -- 107 | -- @since 0.1.13.7 108 | spanToSourceRange :: SrcSpan -> RI.SourceRange 109 | spanToSourceRange (SrcSpan start end) = 110 | let (l1, c1) = lineCol start 111 | (l2, c2) = lineCol end 112 | in RI.SourceRange (RI.SourceLocation (l1 - 1) (c1 - 1)) 113 | (RI.SourceLocation (l2 - 1) c2) 114 | 115 | -- | Given two 'Span's, returns a 'SourceRange' that starts at the starting 116 | -- location of the first span, and ends at the starting location of the second 117 | -- span 118 | -- 119 | -- @since 0.1.17.2 120 | spanToSourceRange2 :: SrcSpan -> SrcSpan -> RI.SourceRange 121 | spanToSourceRange2 (SrcSpan start1 _) (SrcSpan start2 _) = 122 | let (l1, c1) = lineCol start1 123 | (l2, c2) = lineCol start2 124 | in RI.SourceRange (RI.SourceLocation (l1 - 1) (c1 - 1)) 125 | (RI.SourceLocation (l2 - 1) (c2 - 1)) 126 | 127 | -- | Given two 'Span's, returns a 'SourceRange' that starts at the ending 128 | -- location of the first span, and ends at the starting location of the second 129 | -- span 130 | -- 131 | -- @since 0.1.17.2 132 | sourceRangeBetweenTwoSpans :: SrcSpan -> SrcSpan -> RI.SourceRange 133 | sourceRangeBetweenTwoSpans (SrcSpan _ end1) (SrcSpan start2 _) = 134 | let (l1, c1) = lineCol end1 135 | (l2, c2) = lineCol start2 136 | in RI.SourceRange (RI.SourceLocation (l1 - 1) c1) 137 | (RI.SourceLocation (l2 - 1) (c2 - 1)) 138 | -------------------------------------------------------------------------------- /src/Language/Fortran/Transformation/Disambiguation/Function.hs: -------------------------------------------------------------------------------- 1 | module Language.Fortran.Transformation.Disambiguation.Function (disambiguateFunction) where 2 | 3 | import Prelude hiding (lookup) 4 | import Data.Generics.Uniplate.Data 5 | import Data.Data 6 | 7 | import Language.Fortran.Analysis 8 | import Language.Fortran.AST 9 | import Language.Fortran.Transformation.Monad 10 | 11 | 12 | disambiguateFunction :: Data a => Transform a () 13 | disambiguateFunction = do 14 | disambiguateFunctionStatements 15 | disambiguateFunctionCalls 16 | 17 | disambiguateFunctionStatements :: Data a => Transform a () 18 | disambiguateFunctionStatements = modifyProgramFile (trans statement) 19 | where 20 | trans = transformBi :: Data a => TransFunc Statement ProgramFile a 21 | statement (StExpressionAssign a1 s (ExpSubscript _ _ v@(ExpValue a _ (ValVariable _)) indicies) e2) 22 | | Just (IDType _ (Just CTFunction)) <- idType a 23 | , indiciesRangeFree indicies = StFunction a1 s v (aMap fromIndex indicies) e2 24 | -- nullary statement function 25 | statement st@(StExpressionAssign a1 s1 (ExpFunctionCall _ _ v@(ExpValue a s (ValVariable _)) args) e2) = 26 | case alistList args of 27 | [] -> StFunction a1 s1 v (AList a s []) e2 28 | _:_ -> st 29 | statement st = st 30 | 31 | disambiguateFunctionCalls :: Data a => Transform a () 32 | disambiguateFunctionCalls = modifyProgramFile (trans expression) 33 | where 34 | trans = transformBi :: Data a => TransFunc Expression ProgramFile a 35 | expression (ExpSubscript a1 s v@(ExpValue a _ (ValVariable _)) indicies) 36 | | Just (IDType _ (Just CTFunction)) <- idType a 37 | , indiciesRangeFree indicies = ExpFunctionCall a1 s v (aMap fromIndex indicies) 38 | | Just (IDType _ (Just CTExternal)) <- idType a 39 | , indiciesRangeFree indicies = ExpFunctionCall a1 s v (aMap fromIndex indicies) 40 | | Just (IDType _ (Just CTVariable)) <- idType a 41 | , indiciesRangeFree indicies = ExpFunctionCall a1 s v (aMap fromIndex indicies) 42 | | Nothing <- idType a 43 | , indiciesRangeFree indicies = ExpFunctionCall a1 s v (aMap fromIndex indicies) 44 | expression (ExpSubscript a1 s v@(ExpValue a _ (ValIntrinsic _)) indicies) 45 | | Just (IDType _ (Just CTIntrinsic)) <- idType a 46 | , indiciesRangeFree indicies = ExpFunctionCall a1 s v (aMap fromIndex indicies) 47 | expression e = e 48 | 49 | -- BEGIN: TODO STRICTLY TO BE REMOVED LATER TODO 50 | indiciesRangeFree :: AList Index a -> Bool 51 | indiciesRangeFree aIndicies = cRange $ aStrip aIndicies 52 | where 53 | cRange [] = True 54 | cRange (IxSingle{}:xs) = cRange xs 55 | cRange (IxRange{}:_) = False 56 | -- END: TODO STRICTLY TO BE REMOVED LATER TODO 57 | 58 | class Indexed a where 59 | fromIndex :: Index b -> a b 60 | 61 | instance Indexed Argument where 62 | fromIndex (IxSingle a s mKey e) = Argument a s mKey (ArgExpr e) 63 | fromIndex IxRange{} = 64 | error "Deduced a function but argument is not an expression." 65 | 66 | instance Indexed Expression where 67 | fromIndex (IxSingle _ _ _ e) = e 68 | fromIndex IxRange{} = 69 | error "Deduced a function but argument is not an expression." 70 | 71 | -------------------------------------------------- 72 | 73 | -- Local variables: 74 | -- mode: haskell 75 | -- haskell-program-name: "cabal repl" 76 | -- End: 77 | -------------------------------------------------------------------------------- /src/Language/Fortran/Transformation/Disambiguation/Intrinsic.hs: -------------------------------------------------------------------------------- 1 | module Language.Fortran.Transformation.Disambiguation.Intrinsic (disambiguateIntrinsic) where 2 | 3 | import Prelude hiding (lookup) 4 | import Data.Generics.Uniplate.Data 5 | import Data.Data 6 | 7 | import Language.Fortran.Analysis 8 | import Language.Fortran.AST 9 | import Language.Fortran.Transformation.Monad 10 | 11 | 12 | disambiguateIntrinsic :: Data a => Transform a () 13 | disambiguateIntrinsic = modifyProgramFile (trans expression) 14 | where 15 | trans = transformBi :: Data a => TransFunc Expression ProgramFile a 16 | expression (ExpValue a s (ValVariable v)) 17 | | Just (IDType _ (Just CTIntrinsic)) <- idType a = ExpValue a s (ValIntrinsic v) 18 | expression e = e 19 | 20 | -------------------------------------------------- 21 | 22 | -- Local variables: 23 | -- mode: haskell 24 | -- haskell-program-name: "cabal repl" 25 | -- End: 26 | -------------------------------------------------------------------------------- /src/Language/Fortran/Transformation/Monad.hs: -------------------------------------------------------------------------------- 1 | module Language.Fortran.Transformation.Monad 2 | ( getProgramFile 3 | , putProgramFile 4 | , modifyProgramFile 5 | , runTransform 6 | , Transform 7 | ) where 8 | 9 | import Prelude hiding (lookup) 10 | import Control.Monad.State.Lazy hiding (state) 11 | import Data.Data 12 | import qualified Data.Map as M 13 | 14 | import Language.Fortran.Analysis 15 | import Language.Fortran.Analysis.Types 16 | import Language.Fortran.Analysis.Renaming 17 | import Language.Fortran.AST (ProgramFile) 18 | 19 | data TransformationState a = TransformationState 20 | { transProgramFile :: ProgramFile (Analysis a) } 21 | 22 | type Transform a = State (TransformationState a) 23 | 24 | runTransform 25 | :: Data a 26 | => TypeEnvExtended -> ModuleMap -> Transform a () -> ProgramFile a -> ProgramFile a 27 | runTransform env mmap trans pf = 28 | stripAnalysis . transProgramFile . execState trans $ initState 29 | where 30 | (pf', _) = analyseTypesWithEnv (removeExtendedInfo env) . analyseRenamesWithModuleMap mmap . initAnalysis $ pf 31 | initState = TransformationState 32 | { transProgramFile = pf' } 33 | removeExtendedInfo = M.map (\(_, _, t) -> t) 34 | 35 | getProgramFile :: Transform a (ProgramFile (Analysis a)) 36 | getProgramFile = gets transProgramFile 37 | 38 | putProgramFile :: ProgramFile (Analysis a) -> Transform a () 39 | putProgramFile pf = do 40 | state <- get 41 | put $ state { transProgramFile = pf } 42 | 43 | modifyProgramFile :: (ProgramFile (Analysis a) -> ProgramFile (Analysis a)) -> Transform a () 44 | modifyProgramFile f = modify $ \ s -> s { transProgramFile = f (transProgramFile s) } 45 | -------------------------------------------------------------------------------- /src/Language/Fortran/Util/Files.hs: -------------------------------------------------------------------------------- 1 | module Language.Fortran.Util.Files 2 | ( flexReadFile 3 | , runCPP 4 | , getDirContents 5 | , rGetDirContents 6 | , expandDirs 7 | , listFortranFiles 8 | , listDirectoryRecursively 9 | ) where 10 | 11 | import qualified Data.Text.Encoding as T 12 | import qualified Data.Text.Encoding.Error as T 13 | import qualified Data.ByteString.Char8 as B 14 | import System.Directory (listDirectory, canonicalizePath, 15 | doesDirectoryExist, getDirectoryContents) 16 | import System.FilePath ((), takeExtension) 17 | import System.IO.Temp (withSystemTempDirectory) 18 | import System.Process (callProcess) 19 | import Data.List ((\\), foldl') 20 | import Data.Char (isNumber, toLower) 21 | -- | Obtain a UTF-8 safe 'B.ByteString' representation of a file's contents. 22 | -- 23 | -- Invalid UTF-8 is replaced with the space character. 24 | flexReadFile :: FilePath -> IO B.ByteString 25 | flexReadFile = fmap (T.encodeUtf8 . T.decodeUtf8With (T.replace ' ')) . B.readFile 26 | 27 | -- | List files in directory, with the directory prepended to each entry. 28 | getDirContents :: FilePath -> IO [FilePath] 29 | getDirContents d = do 30 | d' <- canonicalizePath d 31 | map (d' ) `fmap` listDirectory d' 32 | 33 | -- | List files in directory recursively. 34 | rGetDirContents :: FilePath -> IO [FilePath] 35 | rGetDirContents d = canonicalizePath d >>= \d' -> go [d'] d' 36 | where 37 | go seen d'' = do 38 | ds <- getDirectoryContents d'' 39 | fmap concat . mapM f $ ds \\ [".", ".."] -- remove '.' and '..' entries 40 | where 41 | f x = do 42 | path <- canonicalizePath $ d x 43 | g <- doesDirectoryExist path 44 | if g && notElem path seen then do 45 | x' <- go (path : seen) path 46 | return $ map (\ y -> x y) x' 47 | else return [x] 48 | 49 | -- | Run the C Pre Processor over the file before reading into a bytestring 50 | runCPP :: Maybe String -> FilePath -> IO B.ByteString 51 | runCPP Nothing path = flexReadFile path -- Nothing = do not run CPP 52 | runCPP (Just cppOpts) path = do 53 | -- Fold over the lines, skipping CPP pragmas and inserting blank 54 | -- lines as needed to make the line numbers match up for the current 55 | -- file. CPP pragmas for other files are just ignored. 56 | let processCPPLine :: ([B.ByteString], Int) -> B.ByteString -> ([B.ByteString], Int) 57 | processCPPLine (revLs, curLineNo) curLine 58 | | B.null curLine || B.head curLine /= '#' = (curLine:revLs, curLineNo + 1) 59 | | linePath /= path = (revLs, curLineNo) 60 | | newLineNo <= curLineNo = (revLs, curLineNo) 61 | | otherwise = (replicate (newLineNo - curLineNo) B.empty ++ revLs, 62 | newLineNo) 63 | where 64 | newLineNo = read . B.unpack . B.takeWhile isNumber . B.drop 2 $ curLine 65 | linePath = B.unpack . B.takeWhile (/='"') . B.drop 1 . B.dropWhile (/='"') $ curLine 66 | 67 | withSystemTempDirectory "fortran-src" $ \ tmpdir -> do 68 | let outfile = tmpdir "cpp.out" 69 | callProcess "cpp" $ words cppOpts ++ ["-CC", "-nostdinc", "-o", outfile, path] 70 | contents <- flexReadFile outfile 71 | let ls = B.lines contents 72 | let ls' = reverse . fst $ foldl' processCPPLine ([], 1) ls 73 | return $ B.unlines ls' 74 | 75 | -- | Expand all paths that are directories into a list of Fortran 76 | -- files from a recursive directory listing. 77 | expandDirs :: [FilePath] -> IO [FilePath] 78 | expandDirs = fmap concat . mapM each 79 | where 80 | each path = do 81 | isDir <- doesDirectoryExist path 82 | if isDir 83 | then listFortranFiles path 84 | else pure [path] 85 | 86 | -- | Get a list of Fortran files under the given directory. 87 | listFortranFiles :: FilePath -> IO [FilePath] 88 | listFortranFiles dir = filter isFortran <$> listDirectoryRecursively dir 89 | where 90 | -- | True if the file has a valid fortran extension. 91 | isFortran :: FilePath -> Bool 92 | isFortran x = map toLower (takeExtension x) `elem` exts 93 | where exts = [".f", ".f90", ".f77", ".f03"] 94 | 95 | listDirectoryRecursively :: FilePath -> IO [FilePath] 96 | listDirectoryRecursively dir = listDirectoryRec dir "" 97 | where 98 | listDirectoryRec :: FilePath -> FilePath -> IO [FilePath] 99 | listDirectoryRec d f = do 100 | let fullPath = d f 101 | isDir <- doesDirectoryExist fullPath 102 | if isDir 103 | then do 104 | conts <- listDirectory fullPath 105 | concat <$> mapM (listDirectoryRec fullPath) conts 106 | else pure [fullPath] 107 | -------------------------------------------------------------------------------- /src/Language/Fortran/Util/FirstParameter.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | A convenience class for retrieving the first field of any constructor in a 3 | datatype. 4 | 5 | The primary usage for this class is generic derivation: 6 | 7 | data D a = D a () String deriving Generic 8 | instance FirstParameter (D a) a 9 | 10 | Note that _the deriver does not check you are requesting a valid/safe instance._ 11 | Invalid instances propagate the error to runtime. Fixing this requires a lot 12 | more type-level work. (The generic-lens library has a general solution, but it's 13 | slow and memory-consuming.) 14 | -} 15 | 16 | {-# LANGUAGE DefaultSignatures #-} 17 | {-# LANGUAGE TypeOperators #-} 18 | {-# LANGUAGE FunctionalDependencies #-} 19 | 20 | module Language.Fortran.Util.FirstParameter(FirstParameter(..), GFirstParameter(..)) where 21 | 22 | import GHC.Generics 23 | 24 | class FirstParameter a e | a -> e where 25 | getFirstParameter :: a -> e 26 | setFirstParameter :: e -> a -> a 27 | 28 | default getFirstParameter :: (Generic a, GFirstParameter (Rep a) e) => a -> e 29 | getFirstParameter = getFirstParameter' . from 30 | 31 | default setFirstParameter :: (Generic a, GFirstParameter (Rep a) e) => e -> a -> a 32 | setFirstParameter e = to . setFirstParameter' e . from 33 | 34 | class GFirstParameter f e where 35 | getFirstParameter' :: f a -> e 36 | setFirstParameter' :: e -> f a -> f a 37 | 38 | instance {-# OVERLAPPING #-} GFirstParameter (K1 i e) e where 39 | getFirstParameter' (K1 a) = a 40 | setFirstParameter' e (K1 _) = K1 e 41 | 42 | instance {-# OVERLAPPABLE #-} GFirstParameter (K1 i a) e where 43 | getFirstParameter' _ = undefined 44 | setFirstParameter' _ _ = undefined 45 | 46 | instance GFirstParameter a e => GFirstParameter (M1 i c a) e where 47 | getFirstParameter' (M1 a) = getFirstParameter' a 48 | setFirstParameter' e (M1 a) = M1 $ setFirstParameter' e a 49 | 50 | instance (GFirstParameter a e, GFirstParameter b e) => GFirstParameter (a :+: b) e where 51 | getFirstParameter' (L1 a) = getFirstParameter' a 52 | getFirstParameter' (R1 a) = getFirstParameter' a 53 | 54 | setFirstParameter' e (L1 a) = L1 $ setFirstParameter' e a 55 | setFirstParameter' e (R1 a) = R1 $ setFirstParameter' e a 56 | 57 | instance (GFirstParameter a e, GFirstParameter b e) => GFirstParameter (a :*: b) e where 58 | getFirstParameter' (a :*: _) = getFirstParameter' a 59 | setFirstParameter' e (a :*: b) = setFirstParameter' e a :*: b 60 | 61 | instance (GFirstParameter U1 String) where 62 | getFirstParameter' _ = "" 63 | setFirstParameter' _ e = e 64 | -------------------------------------------------------------------------------- /src/Language/Fortran/Util/Position.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DefaultSignatures #-} 2 | 3 | module Language.Fortran.Util.Position where 4 | 5 | import Data.Data 6 | import Text.PrettyPrint.GenericPretty 7 | import Text.PrettyPrint 8 | import Data.Binary 9 | import Control.DeepSeq 10 | import Data.List.NonEmpty ( NonEmpty(..) ) 11 | 12 | import Language.Fortran.Util.SecondParameter 13 | 14 | class Loc a where 15 | getPos :: a -> Position 16 | 17 | data Position = Position 18 | { posAbsoluteOffset :: Int 19 | , posColumn :: Int 20 | , posLine :: Int 21 | , posFilePath :: String 22 | , posPragmaOffset :: Maybe (Int, String) -- ^ line-offset and filename as given by a pragma. 23 | } deriving (Eq, Ord, Data, Typeable, Generic) 24 | 25 | instance Binary Position 26 | instance NFData Position 27 | 28 | instance Show Position where 29 | -- Column number decrement by 1 as the lexer generates column numbers 30 | -- starting at position 1 31 | -- See PR https://github.com/camfort/fortran-src/pull/292 32 | show (Position _ c l _ _) = show l ++ ':' : show (c - 1) 33 | 34 | initPosition :: Position 35 | initPosition = Position 36 | { posAbsoluteOffset = 0 37 | , posColumn = 1 38 | , posLine = 1 39 | , posFilePath = "" 40 | , posPragmaOffset = Nothing 41 | } 42 | 43 | lineCol :: Position -> (Int, Int) 44 | lineCol p = (fromIntegral $ posLine p, fromIntegral $ posColumn p) 45 | 46 | -- | (line, column) number taking into account any specified line pragmas. 47 | apparentLineCol :: Position -> (Int, Int) 48 | apparentLineCol (Position _ c l _ (Just (o, _))) = (l + o, c) 49 | apparentLineCol (Position _ c l _ Nothing) = (l, c) 50 | 51 | -- | Path of file taking into account any specified line pragmas. 52 | apparentFilePath :: Position -> String 53 | apparentFilePath p | Just (_, f) <- posPragmaOffset p = f 54 | | otherwise = posFilePath p 55 | 56 | data SrcSpan = SrcSpan 57 | { ssFrom :: Position 58 | , ssTo :: Position 59 | } deriving (Eq, Ord, Typeable, Data, Generic) 60 | 61 | instance Binary SrcSpan 62 | instance NFData SrcSpan 63 | instance Show SrcSpan where 64 | show (SrcSpan s1 s2)= '(' : show s1 ++ ")-(" ++ show s2 ++ ")" 65 | 66 | instance Out SrcSpan where 67 | doc s = text $ show s 68 | docPrec _ = doc 69 | 70 | -- Difference between the column of the upper and lower positions in a span 71 | columnDistance :: SrcSpan -> Int 72 | columnDistance (SrcSpan (Position _ c1 _ _ _) (Position _ c2 _ _ _)) = c2 - c1 73 | 74 | -- Difference between the lines of the upper and lower positions in a span 75 | lineDistance :: SrcSpan -> Int 76 | lineDistance (SrcSpan (Position _ _ l1 _ _) (Position _ _ l2 _ _)) = l2 - l1 77 | 78 | -- List of lines that are spanned 79 | spannedLines :: SrcSpan -> [Int] 80 | spannedLines (SrcSpan (Position _ _ l1 _ _) (Position _ _ l2 _ _)) = [l1..l2] 81 | 82 | initSrcSpan :: SrcSpan 83 | initSrcSpan = SrcSpan initPosition initPosition 84 | 85 | -- | Return the empty span at a given position (span between itself). 86 | emptySpan :: Position -> SrcSpan 87 | emptySpan pos = SrcSpan pos pos 88 | 89 | class Spanned a where 90 | getSpan :: a -> SrcSpan 91 | setSpan :: SrcSpan -> a -> a 92 | 93 | default getSpan :: (SecondParameter a SrcSpan) => a -> SrcSpan 94 | getSpan = getSecondParameter 95 | 96 | default setSpan :: (SecondParameter a SrcSpan) => SrcSpan -> a -> a 97 | setSpan = setSecondParameter 98 | 99 | instance Spanned SrcSpan where 100 | getSpan = id 101 | setSpan = const 102 | 103 | class (Spanned a, Spanned b) => SpannedPair a b where 104 | getTransSpan :: a -> b -> SrcSpan 105 | 106 | -------------------------------------------------------------------------------- 107 | 108 | instance (Spanned a) => Spanned [a] where 109 | getSpan [] = error "Trying to find how long an empty list spans for." 110 | getSpan [x] = getSpan x 111 | getSpan (x:xs) = getTransSpan x (last xs) 112 | setSpan _ _ = error "Cannot set span to an array" 113 | 114 | instance (Spanned a) => Spanned (NonEmpty a) where 115 | getSpan (x :| []) = getSpan x 116 | getSpan (x :| (y:ys)) = getTransSpan x (last (y:ys)) 117 | setSpan _ _ = error "Cannot set span to a non-empty list" 118 | 119 | instance (Spanned a, Spanned b) => Spanned (a, Maybe b) where 120 | getSpan (x, Just y) = getTransSpan x y 121 | getSpan (x,_) = getSpan x 122 | setSpan _ = undefined 123 | 124 | instance (Spanned a, Spanned b) => Spanned (Maybe a, b) where 125 | getSpan (Just x,y) = getTransSpan x y 126 | getSpan (_,y) = getSpan y 127 | setSpan _ = undefined 128 | 129 | instance (Spanned a, Spanned b) => Spanned (Either a b) where 130 | getSpan (Left x) = getSpan x 131 | getSpan (Right x) = getSpan x 132 | setSpan _ = undefined 133 | 134 | instance {-# OVERLAPPABLE #-} (Spanned a, Spanned b) => Spanned (a, b) where 135 | getSpan (x,y) = getTransSpan x y 136 | setSpan _ = undefined 137 | 138 | instance {-# OVERLAPPING #-}(Spanned a, Spanned b, Spanned c) => Spanned (Maybe a, Maybe b, Maybe c) where 139 | getSpan (Just x,_,Just z) = getTransSpan x z 140 | getSpan (Just x,Just y,Nothing) = getTransSpan x y 141 | getSpan (Nothing,Just y,Just z) = getTransSpan y z 142 | getSpan (Just x,Nothing,Nothing) = getSpan x 143 | getSpan (Nothing,Just y,Nothing) = getSpan y 144 | getSpan (Nothing,Nothing,Just z) = getSpan z 145 | getSpan (Nothing,Nothing,Nothing) = undefined 146 | setSpan _ = undefined 147 | 148 | instance {-# OVERLAPPING #-}(Spanned a, Spanned b, Spanned c) => Spanned (a, Maybe b, Maybe c) where 149 | getSpan (x,_,Just z) = getTransSpan x z 150 | getSpan (x,Just y,Nothing) = getTransSpan x y 151 | getSpan (x,Nothing,Nothing) = getSpan x 152 | setSpan _ = undefined 153 | 154 | instance {-# OVERLAPPING #-} (Spanned a, Spanned b, Spanned c) => Spanned (Maybe a, b, c) where 155 | getSpan (Just x,_,z) = getTransSpan x z 156 | getSpan (_,y,z) = getSpan (y,z) 157 | setSpan _ = undefined 158 | 159 | instance {-# OVERLAPPABLE #-} (Spanned a, Spanned b, Spanned c) => Spanned (a, b, c) where 160 | getSpan (x,_,z) = getTransSpan x z 161 | setSpan _ = undefined 162 | 163 | instance {-# OVERLAPPABLE #-} (Spanned a, Spanned b) => SpannedPair a b where 164 | getTransSpan x y = SrcSpan l1 l2' 165 | where SrcSpan l1 _ = getSpan x 166 | SrcSpan _ l2' = getSpan y 167 | 168 | instance {-# OVERLAPS #-} (Spanned a, Spanned b) => SpannedPair a [b] where 169 | getTransSpan x [] = getSpan x 170 | getTransSpan x y = SrcSpan l1 l2' 171 | where SrcSpan l1 _ = getSpan x 172 | SrcSpan _ l2' = getSpan y 173 | 174 | instance {-# OVERLAPS #-} (Spanned a, Spanned b) => SpannedPair a [[b]] where 175 | getTransSpan x [] = getSpan x 176 | getTransSpan x y | all null y = getSpan x 177 | getTransSpan x y | any null y = getTransSpan x (filter (not . null) y) 178 | getTransSpan x y = SrcSpan l1 l2' 179 | where SrcSpan l1 _ = getSpan x 180 | SrcSpan _ l2' = getSpan y 181 | -------------------------------------------------------------------------------- /src/Language/Fortran/Util/SecondParameter.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | A convenience class for retrieving the first field of any constructor in a 3 | datatype. 4 | 5 | The primary usage for this class is generic derivation: 6 | 7 | data D a = D a () String deriving Generic 8 | instance SecondParameter (D a) () 9 | 10 | Note that _the deriver does not check you are requesting a valid/safe instance._ 11 | Invalid instances propagate the error to runtime. Fixing this requires a lot 12 | more type-level work. (The generic-lens library has a general solution, but it's 13 | slow and memory-consuming.) 14 | -} 15 | 16 | {-# LANGUAGE DefaultSignatures #-} 17 | {-# LANGUAGE TypeOperators #-} 18 | {-# LANGUAGE FunctionalDependencies #-} 19 | 20 | module Language.Fortran.Util.SecondParameter(SecondParameter(..)) where 21 | 22 | import GHC.Generics 23 | 24 | class SecondParameter a e | a -> e where 25 | getSecondParameter :: a -> e 26 | setSecondParameter :: e -> a -> a 27 | 28 | default getSecondParameter :: (Generic a, GSecondParameter (Rep a) e) => a -> e 29 | getSecondParameter = getSecondParameter' . from 30 | 31 | default setSecondParameter :: (Generic a, GSecondParameter (Rep a) e) => e -> a -> a 32 | setSecondParameter e = to . setSecondParameter' e . from 33 | 34 | class GSecondParameter f e where 35 | getSecondParameter' :: f a -> e 36 | setSecondParameter' :: e -> f a -> f a 37 | 38 | instance GSecondParameter (K1 i a) e where 39 | getSecondParameter' _ = undefined 40 | setSecondParameter' _ = undefined 41 | 42 | instance GSecondParameter a e => GSecondParameter (M1 i c a) e where 43 | getSecondParameter' (M1 x) = getSecondParameter' x 44 | setSecondParameter' e (M1 x) = M1 $ setSecondParameter' e x 45 | 46 | instance (GSecondParameter a e, GSecondParameter b e) => GSecondParameter (a :+: b) e where 47 | getSecondParameter' (L1 a) = getSecondParameter' a 48 | getSecondParameter' (R1 a) = getSecondParameter' a 49 | 50 | setSecondParameter' e (L1 a) = L1 $ setSecondParameter' e a 51 | setSecondParameter' e (R1 a) = R1 $ setSecondParameter' e a 52 | 53 | instance (ParameterLeaf a, GSecondParameter a e, GSecondParameter' b e) => GSecondParameter (a :*: b) e where 54 | getSecondParameter' (a :*: b) = 55 | if isLeaf a 56 | then getSecondParameter'' b 57 | else getSecondParameter' a 58 | 59 | setSecondParameter' e (a :*: b) = 60 | if isLeaf a 61 | then a :*: setSecondParameter'' e b 62 | else setSecondParameter' e a :*: b 63 | 64 | class GSecondParameter' f e where 65 | getSecondParameter'' :: f a -> e 66 | setSecondParameter'' :: e -> f a -> f a 67 | 68 | instance GSecondParameter' a e => GSecondParameter' (M1 i c a) e where 69 | getSecondParameter'' (M1 a) = getSecondParameter'' a 70 | setSecondParameter'' e (M1 a) = M1 $ setSecondParameter'' e a 71 | 72 | instance GSecondParameter' a e => GSecondParameter' (a :*: b) e where 73 | getSecondParameter'' (a :*: _) = getSecondParameter'' a 74 | setSecondParameter'' e (a :*: b) = setSecondParameter'' e a :*: b 75 | 76 | instance {-# OVERLAPPING #-} GSecondParameter' (K1 i e) e where 77 | getSecondParameter'' (K1 a) = a 78 | setSecondParameter'' e (K1 _) = K1 e 79 | 80 | instance {-# OVERLAPPABLE #-} GSecondParameter' (K1 i a) e where 81 | getSecondParameter'' _ = undefined 82 | setSecondParameter'' _ _ = undefined 83 | 84 | class ParameterLeaf f where 85 | isLeaf :: f a -> Bool 86 | 87 | instance ParameterLeaf (M1 i c a) where 88 | isLeaf _ = True 89 | 90 | instance ParameterLeaf (a :*: b) where 91 | isLeaf _ = False 92 | -------------------------------------------------------------------------------- /src/Language/Fortran/Version.hs: -------------------------------------------------------------------------------- 1 | -- | Fortran version enum and tools for selecting version for a given file. 2 | 3 | module Language.Fortran.Version 4 | ( FortranVersion(..) 5 | , fortranVersionAliases 6 | , selectFortranVersion 7 | , deduceFortranVersion 8 | ) where 9 | 10 | import Data.Char (toLower) 11 | import Data.List (isInfixOf, isSuffixOf, find) 12 | 13 | import Data.Data (Data, Typeable) 14 | import GHC.Generics (Generic) 15 | import Control.DeepSeq (NFData) 16 | import Text.PrettyPrint.GenericPretty (Out) 17 | 18 | -- | The Fortran specification version used (or relevant to its context). 19 | -- 20 | -- The constructor ordering is important, since it's used for the Ord instance 21 | -- (which is used extensively for pretty printing). 22 | data FortranVersion = Fortran66 23 | | Fortran77 -- ^ fairly close to FORTRAN 77 standard 24 | | Fortran77Extended -- ^ F77 with some extensions 25 | | Fortran77Legacy -- ^ F77 with most extensions 26 | | Fortran90 27 | | Fortran95 28 | | Fortran2003 29 | | Fortran2008 30 | deriving (Ord, Eq, Data, Typeable, Generic) 31 | 32 | instance Show FortranVersion where 33 | show Fortran66 = "Fortran 66" 34 | show Fortran77 = "Fortran 77" 35 | show Fortran77Extended = "Fortran 77 Extended" 36 | show Fortran77Legacy = "Fortran 77 Legacy" 37 | show Fortran90 = "Fortran 90" 38 | show Fortran95 = "Fortran 95" 39 | show Fortran2003 = "Fortran 2003" 40 | show Fortran2008 = "Fortran 2008" 41 | 42 | instance Out FortranVersion 43 | instance NFData FortranVersion 44 | 45 | fortranVersionAliases :: [(String, FortranVersion)] 46 | fortranVersionAliases = [ ("66" , Fortran66) 47 | , ("77e", Fortran77Extended) 48 | , ("77l", Fortran77Legacy) 49 | , ("77" , Fortran77) 50 | , ("90" , Fortran90) 51 | , ("95" , Fortran95) 52 | , ("03" , Fortran2003) 53 | , ("08" , Fortran2008) ] 54 | 55 | selectFortranVersion :: String -> Maybe FortranVersion 56 | selectFortranVersion alias = snd <$> find (\ entry -> fst entry `isInfixOf` map toLower alias) fortranVersionAliases 57 | 58 | -- | Deduce the 'FortranVersion' from a 'FilePath' using extension. 59 | -- 60 | -- Defaults to Fortran 90 if suffix is unrecognized. 61 | deduceFortranVersion :: FilePath -> FortranVersion 62 | deduceFortranVersion path 63 | | isExtensionOf ".f" = Fortran77Legacy 64 | | isExtensionOf ".for" = Fortran77Legacy 65 | | isExtensionOf ".fpp" = Fortran77Legacy 66 | | isExtensionOf ".ftn" = Fortran77Legacy 67 | | isExtensionOf ".f90" = Fortran90 68 | | isExtensionOf ".f95" = Fortran95 69 | | isExtensionOf ".f03" = Fortran2003 70 | | isExtensionOf ".f2003" = Fortran2003 71 | | isExtensionOf ".f08" = Fortran2008 72 | | isExtensionOf ".f2008" = Fortran2008 73 | | otherwise = Fortran90 -- unrecognized, default to F90 74 | where 75 | isExtensionOf = flip isSuffixOf $ map toLower path 76 | -------------------------------------------------------------------------------- /src/Text/PrettyPrint/GenericPretty/Orphans.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingVia #-} 2 | -- TODO orphans pragma 3 | 4 | module Text.PrettyPrint.GenericPretty.Orphans where 5 | 6 | import Text.PrettyPrint.GenericPretty 7 | import Text.PrettyPrint.GenericPretty.ViaShow ( OutShowly(..) ) 8 | 9 | import Data.Text ( Text ) 10 | import qualified Data.Text as Text 11 | import Data.Int 12 | import Numeric.Natural 13 | 14 | -- | Not particularly efficient (but neither is GenericPretty). 15 | deriving via OutShowly Text instance Out Text 16 | 17 | deriving via OutShowly Int8 instance Out Int8 18 | deriving via OutShowly Int16 instance Out Int16 19 | deriving via OutShowly Int32 instance Out Int32 20 | deriving via OutShowly Int64 instance Out Int64 21 | deriving via OutShowly Natural instance Out Natural 22 | -------------------------------------------------------------------------------- /src/Text/PrettyPrint/GenericPretty/ViaShow.hs: -------------------------------------------------------------------------------- 1 | {- | Low-boilerplate 'Text.PrettyPrint.GenericPretty.Out' instances for 2 | 'Show'ables using @DerivingVia@. 3 | 4 | Useful for integrating types that don't work nicely with 'Generic' with 5 | @GenericPretty@. (Really, there should be a class like 6 | 'Text.PrettyPrint.GenericPretty.Out' directly in @pretty@, but alas.) 7 | 8 | Use as follows: 9 | 10 | data EeGadts a where 11 | C1 :: EeGadts Bool 12 | C2 :: EeGadts String 13 | deriving stock instance Show (EeGadts a) 14 | deriving via OutShowly (EeGadts a) instance Out (EeGadts a) 15 | -} 16 | 17 | {-# LANGUAGE DerivingVia #-} 18 | 19 | module Text.PrettyPrint.GenericPretty.ViaShow 20 | ( module Text.PrettyPrint.GenericPretty.ViaShow 21 | , Text.PrettyPrint.GenericPretty.Out 22 | ) where 23 | 24 | import Text.PrettyPrint.GenericPretty ( Out(..) ) 25 | import qualified Text.PrettyPrint 26 | 27 | newtype OutShowly a = OutShowly { unOutShowly :: a } 28 | 29 | instance Show a => Out (OutShowly a) where 30 | doc (OutShowly a) = Text.PrettyPrint.text $ show a 31 | docPrec n (OutShowly a) = Text.PrettyPrint.text $ showsPrec n a "" 32 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-20.01 2 | packages: 3 | - '.' 4 | save-hackage-creds: false 5 | -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: [] 7 | snapshots: 8 | - completed: 9 | sha256: b73b2b116143aea728c70e65c3239188998bac5bc3be56465813dacd74215dc5 10 | size: 648424 11 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/1.yaml 12 | original: lts-20.1 13 | -------------------------------------------------------------------------------- /test-data/f77-include/foo.f: -------------------------------------------------------------------------------- 1 | integer a 2 | integer b 3 | -------------------------------------------------------------------------------- /test-data/f77-include/no-newline/foo.f: -------------------------------------------------------------------------------- 1 | integer a 2 | integer b -------------------------------------------------------------------------------- /test-data/module/leaf.f90: -------------------------------------------------------------------------------- 1 | module leaf 2 | implicit none 3 | real :: constant = 0.1 4 | end module -------------------------------------------------------------------------------- /test-data/module/mid1.f90: -------------------------------------------------------------------------------- 1 | module mid1 2 | implicit none 3 | use leaf 4 | end module -------------------------------------------------------------------------------- /test-data/module/mid2.f90: -------------------------------------------------------------------------------- 1 | module mid2 2 | implicit none 3 | use leaf 4 | end module -------------------------------------------------------------------------------- /test-data/module/top.f90: -------------------------------------------------------------------------------- 1 | module top 2 | implicit none 3 | use mid1 4 | use mid2 5 | end module -------------------------------------------------------------------------------- /test-data/rewriter/replacementsmap-columnlimit/001_foo.f: -------------------------------------------------------------------------------- 1 | subroutine foo 2 | integer xxxxxxxxxxxxxxxxxxxxxxxxxx 3 | xxxxxxxxxxxxxxxxxxxxxxxxxx = 10 4 | if (xxxxxxxxxxxxxxxxxxxxxxxxxx .eq. 9) call bar 5 | end 6 | -------------------------------------------------------------------------------- /test-data/rewriter/replacementsmap-columnlimit/001_foo.f.expected: -------------------------------------------------------------------------------- 1 | subroutine foo 2 | integer xxxxxxxxxxxxxxxxxxxxxxxxxx 3 | xxxxxxxxxxxxxxxxxxxxxxxxxx = 10 4 | if (xxxxxxxxxxxxxxxxxxxxxxxxxx .eq. 999999999999999999999) 5 | + call bar 6 | end 7 | -------------------------------------------------------------------------------- /test-data/rewriter/replacementsmap-columnlimit/002_other.f: -------------------------------------------------------------------------------- 1 | subroutine foo 2 | integer aaaaa = 10 3 | integer xxxxxxxxxxxxxxxxxxxxxxxxxx 4 | xxxxxxxxxxxxxxxxxxxxxxxxxx = 10 5 | if (aaaaa .eq. 0 .and. xxxxxxxxxxxxxxxxxxxxxxxxxx .eq. 9) call bar 6 | end 7 | -------------------------------------------------------------------------------- /test-data/rewriter/replacementsmap-columnlimit/002_other.f.expected: -------------------------------------------------------------------------------- 1 | subroutine foo 2 | integer aaaaa = 10 3 | integer xxxxxxxxxxxxxxxxxxxxxxxxxx 4 | xxxxxxxxxxxxxxxxxxxxxxxxxx = 10 5 | if (aaaaa .eq. 0 .and. xxxxxxxxxxxxxxxxxxxxxxxxxx .eq. 6 | +999999999999) call bar 7 | end 8 | -------------------------------------------------------------------------------- /test-data/rewriter/replacementsmap-columnlimit/003_multiline.f: -------------------------------------------------------------------------------- 1 | subroutine foo 2 | integer aaaaa = 10 3 | integer xxxxxxxxxxxxxxxxxxxxxxxxxx 4 | xxxxxxxxxxxxxxxxxxxxxxxxxx = 10 5 | if (aaaaa .eq. 0 .and. xxxxxxxxxxxxxxxxxxxxxxxxxx .eq. 9) call bar 6 | end 7 | -------------------------------------------------------------------------------- /test-data/rewriter/replacementsmap-columnlimit/003_multiline.f.expected: -------------------------------------------------------------------------------- 1 | subroutine foo 2 | integer aaaaa = 10 3 | integer xxxxxxxxxxxxxxxxxxxxxxxxxx 4 | xxxxxxxxxxxxxxxxxxxxxxxxxx = 10 5 | if (aaaaa .eq. 0 .and. xxxxxxxxxxxxxxxxxxxxxxxxxx .eq. 9 .and. 6 | + 4 .lt. 4 7 | + .or. .true.) call bar 8 | end 9 | -------------------------------------------------------------------------------- /test-data/rewriter/replacementsmap-columnlimit/004_comment.f: -------------------------------------------------------------------------------- 1 | c This is the API for foo subroutine. We take in some inputs, apply some cool things and return other things. 2 | subroutine foo 3 | integer*2 a ! This is my variable 'a' ... it stores numbers both larger and small 4 | CHARACTER*2 some_string(15) 5 | 6 | some_string = "some_string" 7 | 8 | if (foo) then 9 | IF (some_string(0).eq.'s') foo=9 Text after col 72 are comments and should remain 10 | endif 11 | end 12 | -------------------------------------------------------------------------------- /test-data/rewriter/replacementsmap-columnlimit/004_comment.f.expected: -------------------------------------------------------------------------------- 1 | c This is the API for foo subroutine. We take in some inputs, apply some cool things and return other things. 2 | subroutine foo 3 | integer*2 foobar ! This is my variable 'a' ... it stores numbers both larger and small 4 | CHARACTER*2 some_string(15) 5 | 6 | some_string = "some_string" 7 | 8 | if (foo) then 9 | IF (xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx 10 | +(0).eq.'s') foo=9 Text after col 72 are comments and should remain 11 | endif 12 | end 13 | -------------------------------------------------------------------------------- /test-data/rewriter/replacementsmap-columnlimit/005_removals.f: -------------------------------------------------------------------------------- 1 | REAL*8 FUNCTION foo_removals () 2 | 3 | real*8 sec_rate(31),cur_rate(31),day_value, 4 | . month_rec_values(5,31),in_values(5), 5 | . blank(31) 6 | 7 | integer*4 somevalue1, somevalue2 8 | 9 | if (my_fn_call(1) .or. deadcode(2) 10 | . .and. my_fn_call2(somevalue1) .and. my_fn_call3(10)) 11 | . then 12 | call process_things(1,2,3) 13 | endif 14 | 15 | foo_removals = 0 16 | 17 | return 18 | end 19 | -------------------------------------------------------------------------------- /test-data/rewriter/replacementsmap-columnlimit/005_removals.f.expected: -------------------------------------------------------------------------------- 1 | REAL*8 FUNCTION foo_removals () 2 | 3 | real*8 sec_rate(31),cur_rate(31), 4 | +month_rec_values(5,31),in_values(5), 5 | . blank(31) 6 | 7 | integer*4 somevalue1, somevalue2 8 | 9 | if (my_fn_call(1) .or. 10 | + my_fn_call2(somevalue1) .and. my_fn_call3(10)) 11 | . then 12 | call process_things(1,2,3) 13 | endif 14 | 15 | foo_removals = 0 16 | 17 | return 18 | end 19 | -------------------------------------------------------------------------------- /test-data/rewriter/replacementsmap-columnlimit/006_linewrap_heuristic.f: -------------------------------------------------------------------------------- 1 | subroutine foo 2 | integer word, wrap_after_comma, wrap_after_right_paren 3 | logical accessor, TEST, LOGICAL2VAR 4 | if (accessor(word, wrap_after_comma)) call bar 5 | if (accessor(int(word), wrap_after_comma)) call bar 6 | if (accessor(int(int2(word)), wrap_after_comma)) call bar 7 | if (accessor(int(int2(word)))) call wrap_after_right_paren 8 | if (accessor(word)) call foo(bar)!don't wrap inline comment 9 | accessor(1) = TEST!inline comment not to be wrapped 10 | 11 | if(1) then 12 | LOGICAL2VAR = l2!other comment that shouldn't be wrapped 13 | !comments after 0! char replacements don't wrap! 14 | L!comments after replacements >0 chars don't wrap 15 | endif 16 | end 17 | -------------------------------------------------------------------------------- /test-data/rewriter/replacementsmap-columnlimit/006_linewrap_heuristic.f.expected: -------------------------------------------------------------------------------- 1 | subroutine foo 2 | integer word, wrap_after_comma, wrap_after_right_paren 3 | logical accessor, TEST, LOGICAL2VAR 4 | if (accessor(xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx, 5 | + wrap_after_comma)) call bar 6 | if (accessor(int(xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx), 7 | + wrap_after_comma)) call bar 8 | if (accessor(int(int2(xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx)), 9 | + wrap_after_comma)) call bar 10 | if (accessor(int(int2(xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx)))) 11 | + call wrap_after_right_paren 12 | if (accessor(xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx)) 13 | + call foo(bar)!don't wrap inline comment 14 | call testcommons_logarray_settori_findex(logical_1_to_4(test), 1)!inline comment not to be wrapped 15 | 16 | if(1) then 17 | call testcommons_set_logical2var(logical_2_to_4(l2))!other comment that shouldn't be wrapped 18 | call testcommons_set_logical2var(logical_2_to_4(l2))!comments after 0! char replacements don't wrap! 19 | call testcommons_set_logical2var(logical_2_to_4(l2))!comments after replacements >0 chars don't wrap 20 | endif 21 | end 22 | -------------------------------------------------------------------------------- /test-data/rewriter/replacementsmap-insertion/001_foo.f: -------------------------------------------------------------------------------- 1 | subroutine aaaa() 2 | end 3 | 4 | -------------------------------------------------------------------------------- /test-data/rewriter/replacementsmap-insertion/001_foo.f.expected: -------------------------------------------------------------------------------- 1 | subroutine aaaa() 2 | call bbbb 3 | end 4 | 5 | -------------------------------------------------------------------------------- /test-data/rewriter/replacementsmap-overlapping-filtered/001_foo.f: -------------------------------------------------------------------------------- 1 | subroutine aaaa() 2 | call bbbb 3 | end 4 | -------------------------------------------------------------------------------- /test-data/rewriter/replacementsmap-overlapping-filtered/001_foo.f.expected: -------------------------------------------------------------------------------- 1 | subroutine aaaa() 2 | call cccc 3 | end 4 | -------------------------------------------------------------------------------- /test-data/rewriter/replacementsmap-overlapping/001_foo.f: -------------------------------------------------------------------------------- 1 | subroutine aaaa() 2 | call bbbb 3 | end 4 | -------------------------------------------------------------------------------- /test-data/rewriter/replacementsmap-overlapping/001_foo.f.expected: -------------------------------------------------------------------------------- 1 | subroutine aaaa() 2 | call bbbb 3 | end 4 | -------------------------------------------------------------------------------- /test-data/rewriter/replacementsmap-padimplicitcomment/001_foo.f: -------------------------------------------------------------------------------- 1 | program main 2 | integer hello*4 ! This is a long comment that goes over the 72 columns 3 | + , hello2*2 4 | end program main -------------------------------------------------------------------------------- /test-data/rewriter/replacementsmap-padimplicitcomment/001_foo.f.expected: -------------------------------------------------------------------------------- 1 | program main 2 | ! This is a long comment that goes over the 72 columns 3 | integer*4 hello 4 | integer*2 hello2 5 | end program main -------------------------------------------------------------------------------- /test-data/rewriter/replacementsmap-simple/001_foo.f: -------------------------------------------------------------------------------- 1 | subroutine aaaa() 2 | call bbbb 3 | end 4 | 5 | -------------------------------------------------------------------------------- /test-data/rewriter/replacementsmap-simple/001_foo.f.expected: -------------------------------------------------------------------------------- 1 | subroutine aaaa() 2 | call cccc 3 | end 4 | 5 | -------------------------------------------------------------------------------- /test-data/rewriter/replacementsmap-simple/002_foo.f: -------------------------------------------------------------------------------- 1 | subroutine aaaa() 2 | call bbbb 3 | end 4 | 5 | -------------------------------------------------------------------------------- /test-data/rewriter/replacementsmap-simple/002_foo.f.expected: -------------------------------------------------------------------------------- 1 | subroutine aaaa() 2 | 3 | end 4 | 5 | -------------------------------------------------------------------------------- /test-data/rewriter/replacementsmap-simple/003_foo.f: -------------------------------------------------------------------------------- 1 | subroutine aaaa() 2 | call bbbb1 3 | 4 | call bbbb2 5 | end 6 | 7 | -------------------------------------------------------------------------------- /test-data/rewriter/replacementsmap-simple/003_foo.f.expected: -------------------------------------------------------------------------------- 1 | subroutine aaaa() 2 | call cccc1 3 | 4 | call cccc2 5 | end 6 | 7 | -------------------------------------------------------------------------------- /test-data/rewriter/replacementsmap-simple/004_unicode.f: -------------------------------------------------------------------------------- 1 | program main 2 | character*(*) CH33 3 | parameter(CH33 = 'LIFFE Euro S? FUTURES ANALYSIS') 4 | print *, z'deadbeef' 5 | end program main 6 | -------------------------------------------------------------------------------- /test-data/rewriter/replacementsmap-simple/004_unicode.f.expected: -------------------------------------------------------------------------------- 1 | program main 2 | character*(*) CH33 3 | parameter(CH33 = 'LIFFE Euro S? FUTURES ANALYSIS') 4 | print *, int(z'deadbeef') 5 | end program main 6 | -------------------------------------------------------------------------------- /test-data/rewriter/replacementsmap-simple/005_unicode.f: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/camfort/fortran-src/fb2eb36a0ab01f92f3b153bb13d264f29ec3ea35/test-data/rewriter/replacementsmap-simple/005_unicode.f -------------------------------------------------------------------------------- /test-data/rewriter/replacementsmap-simple/005_unicode.f.expected: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/camfort/fortran-src/fb2eb36a0ab01f92f3b153bb13d264f29ec3ea35/test-data/rewriter/replacementsmap-simple/005_unicode.f.expected -------------------------------------------------------------------------------- /test-data/rewriter/temp-failure/fail.f: -------------------------------------------------------------------------------- 1 | subroutine foo 2 | print *, 'FAIL' 3 | end 4 | -------------------------------------------------------------------------------- /test/Language/Fortran/AST/Literal/BozSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeApplications #-} 2 | 3 | module Language.Fortran.AST.Literal.BozSpec where 4 | 5 | import Test.Hspec 6 | 7 | import Language.Fortran.AST.Literal.Boz 8 | import Numeric.Natural ( Natural ) 9 | import Data.Int ( Int8, Int16, Int32 ) 10 | 11 | spec :: Spec 12 | spec = do 13 | describe "BOZ literal constants" $ do 14 | it "parses single and double quotes identically" $ do 15 | parseBoz "o'017'" `shouldBe` parseBoz "o\"017\"" 16 | 17 | it "parses postfix BOZ constant as explicitly nonconforming" $ do 18 | parseBoz "'010'b" `shouldBe` Boz BozPrefixB "010" Nonconforming 19 | 20 | it "parses a prefix and postfix BOZ constant identically (ignoring conformance flags)" $ do 21 | parseBoz "z'123abc'" `shouldBe` parseBoz "'123abc'z" 22 | 23 | it "parses nonstandard X as Z (hex)" $ do 24 | parseBoz "x'09af'" `shouldBe` parseBoz "z'09af'" 25 | 26 | it "resolves a BOZ as a natural" $ do 27 | bozAsNatural @Natural (parseBoz "x'00'") `shouldBe` 0 28 | bozAsNatural @Natural (parseBoz "x'7F'") `shouldBe` 127 29 | bozAsNatural @Natural (parseBoz "x'80'") `shouldBe` 128 30 | bozAsNatural @Natural (parseBoz "x'FF'") `shouldBe` 255 31 | 32 | it "resolves a BOZ as a two's complement integer (INT(1))" $ do 33 | bozAsTwosComp @Int8 (parseBoz "x'00'") `shouldBe` 0 34 | bozAsTwosComp @Int8 (parseBoz "x'7F'") `shouldBe` 127 35 | bozAsTwosComp @Int8 (parseBoz "x'80'") `shouldBe` (-128) 36 | bozAsTwosComp @Int8 (parseBoz "x'FF'") `shouldBe` (-1) 37 | 38 | it "resolves a BOZ as a two's complement integer (INT(2))" $ do 39 | bozAsTwosComp @Int16 (parseBoz "x'00'") `shouldBe` 0 40 | bozAsTwosComp @Int16 (parseBoz "x'7F'") `shouldBe` 127 41 | bozAsTwosComp @Int16 (parseBoz "x'80'") `shouldBe` 128 42 | bozAsTwosComp @Int16 (parseBoz "x'FF'") `shouldBe` 255 43 | bozAsTwosComp @Int16 (parseBoz "x'7FFF'") `shouldBe` 32767 44 | bozAsTwosComp @Int16 (parseBoz "x'8000'") `shouldBe` (-32768) 45 | bozAsTwosComp @Int16 (parseBoz "x'FFFF'") `shouldBe` (-1) 46 | 47 | it "resolves a BOZ as a two's complement integer (INT(4))" $ do 48 | bozAsTwosComp @Int32 (parseBoz "x'FFFFFFFF'") `shouldBe` (-1) 49 | -------------------------------------------------------------------------------- /test/Language/Fortran/AST/Literal/RealSpec.hs: -------------------------------------------------------------------------------- 1 | module Language.Fortran.AST.Literal.RealSpec where 2 | 3 | import Prelude hiding ( exp ) 4 | 5 | import Test.Hspec 6 | 7 | import Language.Fortran.AST.Literal.Real 8 | 9 | spec :: Spec 10 | spec = do 11 | describe "Fortran real literals" $ do 12 | it "parses & normalizes various well-formed valid real literals" $ do 13 | prl "1.0" `shouldBe` rl "1.0" expDef 14 | prl "1.0e0" `shouldBe` rl "1.0" expDef 15 | prl "10e-1" `shouldBe` rl "10.0" (exp e "-1") 16 | prl "-1.e-1" `shouldBe` rl "-1.0" (exp e "-1") 17 | prl "+1.e+1" `shouldBe` rl "1.0" (exp e "1") 18 | prl "1.e1" `shouldBe` rl "1.0" (exp e "1") 19 | prl ".1" `shouldBe` rl "0.1" expDef 20 | prl "1.0d0" `shouldBe` rl "1.0" (exp d "0") 21 | prl "1.0q0" `shouldBe` rl "1.0" (exp q "0") 22 | where 23 | prl = parseRealLit 24 | rl = RealLit 25 | exp = Exponent 26 | expDef = Exponent ExpLetterE "0" 27 | e = ExpLetterE 28 | d = ExpLetterD 29 | q = ExpLetterQ 30 | -------------------------------------------------------------------------------- /test/Language/Fortran/Analysis/ModFileSpec.hs: -------------------------------------------------------------------------------- 1 | module Language.Fortran.Analysis.ModFileSpec (spec) where 2 | 3 | import Test.Hspec 4 | import TestUtil 5 | 6 | import Language.Fortran.Util.ModFile 7 | import Language.Fortran.Util.Files (expandDirs, flexReadFile) 8 | import Language.Fortran.Version 9 | import System.FilePath (()) 10 | import qualified Data.Map as M 11 | import qualified Language.Fortran.Parser as Parser 12 | import qualified Data.ByteString.Char8 as B 13 | import Language.Fortran.AST 14 | import Language.Fortran.Analysis 15 | import Language.Fortran.Analysis.Renaming 16 | import Language.Fortran.Analysis.BBlocks 17 | import Language.Fortran.Analysis.DataFlow 18 | 19 | spec :: Spec 20 | spec = 21 | describe "Modfiles" $ 22 | it "Test module maps for a small package" $ 23 | testModuleMaps 24 | 25 | pParser :: String -> IO (ProgramFile (Analysis A0)) 26 | pParser name = do 27 | contents <- flexReadFile name 28 | let pf = Parser.byVerWithMods [] Fortran90 name contents 29 | case pf of 30 | Right pf -> return $ rename . analyseBBlocks . analyseRenames . initAnalysis $ pf 31 | Left err -> error $ "Error parsing " ++ name ++ ": " ++ show err 32 | 33 | -- A simple test that checks that we correctly localise the declaration 34 | -- of the variable `constant` to the leaf module, whilst understanding 35 | -- in the `mid1` and `mid2` modules that it is an imported declaration. 36 | testModuleMaps = do 37 | let fixturePath = "test-data" "module" 38 | paths <- expandDirs [fixturePath] 39 | -- parse all files into mod files 40 | pfs <- mapM (\p -> pParser p) paths 41 | let modFiles = map genModFile pfs 42 | -- get unique name to filemap 43 | let mmap = genUniqNameToFilenameMap "" modFiles 44 | -- check that `constant` is declared in leaf.f90 45 | let Just (leaf, _) = M.lookup "leaf_constant_1" mmap 46 | leaf `shouldBe` ("test-data" "module" "leaf.f90") 47 | 48 | -------------------------------------------------------------------------------- /test/Language/Fortran/Analysis/ModGraphSpec.hs: -------------------------------------------------------------------------------- 1 | module Language.Fortran.Analysis.ModGraphSpec (spec) where 2 | 3 | import Test.Hspec 4 | import TestUtil 5 | 6 | import Language.Fortran.Analysis.ModGraph 7 | import Language.Fortran.Util.Files (expandDirs) 8 | import Language.Fortran.Version 9 | import System.FilePath (()) 10 | 11 | spec :: Spec 12 | spec = 13 | describe "Modgraph" $ 14 | it "Dependency graph and topological sort on small package" $ 15 | testDependencyList 16 | 17 | -- A simple test on a simple module structure to check that 18 | -- we are understanding this correctly (via the dependency graph 19 | -- and then its topological sort). 20 | testDependencyList = do 21 | paths' <- expandDirs ["test-data" "module"] 22 | mg <- genModGraph (Just Fortran90) ["."] Nothing paths' 23 | let list = modGraphToList mg 24 | -- we should have two possible orderings 25 | let files1 = ["leaf.f90", "mid1.f90", "mid2.f90", "top.f90"] 26 | let filesWithPaths1 = map (("test-data" "module") ) files1 27 | -- or in a different order 28 | let files2 = ["leaf.f90", "mid2.f90", "mid1.f90", "top.f90"] 29 | let filesWithPaths2 = map (("test-data" "module") ) files2 30 | shouldSatisfy list (\x -> x == filesWithPaths1 || x == filesWithPaths2) 31 | -------------------------------------------------------------------------------- /test/Language/Fortran/Analysis/SemanticTypesSpec.hs: -------------------------------------------------------------------------------- 1 | module Language.Fortran.Analysis.SemanticTypesSpec where 2 | 3 | import Test.Hspec 4 | import TestUtil 5 | 6 | import Language.Fortran.Analysis.SemanticTypes 7 | import Language.Fortran.AST 8 | import Language.Fortran.Version 9 | 10 | spec :: Spec 11 | spec = do 12 | describe "Semantic types" $ do 13 | it "recovers DOUBLE PRECISION for REAL(8) in Fortran 77" $ do 14 | let semtype = TReal 8 15 | typespec = TypeSpec () u TypeDoublePrecision Nothing 16 | in recoverSemTypeTypeSpec () u Fortran77 semtype `shouldBe` typespec 17 | 18 | it "recovers DOUBLE COMPLEX for COMPLEX(16) in Fortran 77" $ do 19 | let semtype = TComplex 16 20 | typespec = TypeSpec () u TypeDoubleComplex Nothing 21 | in recoverSemTypeTypeSpec () u Fortran77 semtype `shouldBe` typespec 22 | 23 | it "recovers REAL(8) for REAL(8) in Fortran 90" $ do 24 | let semtype = TReal 8 25 | typespec = TypeSpec () u TypeReal (Just (Selector () u Nothing (Just (intGen 8)))) 26 | in recoverSemTypeTypeSpec () u Fortran90 semtype `shouldBe` typespec 27 | 28 | it "recovers CHARACTER(*)" $ do 29 | let semtype = TCharacter CharLenStar 1 30 | typespec = TypeSpec () u TypeCharacter (Just (Selector () u (Just (ExpValue () u ValStar)) Nothing)) 31 | in recoverSemTypeTypeSpec () u Fortran90 semtype `shouldBe` typespec 32 | -------------------------------------------------------------------------------- /test/Language/Fortran/AnalysisSpec.hs: -------------------------------------------------------------------------------- 1 | module Language.Fortran.AnalysisSpec where 2 | 3 | import Test.Hspec 4 | import TestUtil 5 | 6 | import Language.Fortran.Analysis 7 | import Language.Fortran.AST 8 | import qualified Language.Fortran.Parser as Parser 9 | 10 | import qualified Data.ByteString.Char8 as B 11 | 12 | pParser :: String -> ProgramFile (Analysis A0) 13 | pParser = initAnalysis . Parser.parseUnsafe Parser.f77e . B.pack 14 | 15 | spec :: Spec 16 | spec = 17 | describe "Analysis" $ 18 | describe "anal1" $ 19 | it "lhsExprs" $ do 20 | let pf = stripAnalysis $ pParser programAnal1 21 | lhsExprs pf `shouldMatchList'` programAnal1LhsExprs 22 | 23 | programAnal1LhsExprs :: [Expression ()] 24 | programAnal1LhsExprs = 25 | [ ExpSubscript () u (ExpValue () u (ValVariable "a")) (AList () u [ ixSinGen 1 ]) 26 | , ExpSubscript () u (ExpValue () u (ValVariable "a")) 27 | (AList () u [ IxSingle () u Nothing $ 28 | ExpSubscript () u (varGen "a") 29 | (AList () u [ ixSinGen 2 ])]) 30 | , ExpSubscript () u (ExpValue () u (ValVariable "a")) (AList () u [ ixSinGen 4 ]) 31 | , ExpValue () u (ValVariable "f") 32 | , ExpSubscript () u (ExpValue () u (ValVariable "a")) (AList () u [ ixSinGen 6 ]) 33 | , ExpSubscript () u (ExpValue () u (ValVariable "a")) (AList () u [ ixSinGen 5 ]) ] 34 | 35 | programAnal1 :: String 36 | programAnal1 = unlines $ map (replicate 6 ' '++) [ 37 | "program anal1" 38 | , "integer a, f" 39 | , "dimension a(10)" 40 | , "a(1) = f(a(6))" 41 | , "a(a(2)) = a(10)" 42 | , "call s(1)" 43 | , "call s(a(4))" 44 | , "call s(f(a(5)))" 45 | , "end" 46 | , "subroutine s(x)" 47 | , "integer x" 48 | , "end" 49 | , "function f(x)" 50 | , "integer x, f" 51 | , "f = x" 52 | , "end" 53 | ] 54 | 55 | -- Local variables: 56 | -- mode: haskell 57 | -- haskell-program-name: "cabal repl test-suite:spec" 58 | -- End: 59 | -------------------------------------------------------------------------------- /test/Language/Fortran/Parser/Fixed/Fortran77/IncludeSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | module Language.Fortran.Parser.Fixed.Fortran77.IncludeSpec where 4 | 5 | import System.FilePath 6 | import Test.Hspec 7 | import TestUtil 8 | 9 | import qualified Language.Fortran.Parser as Parser 10 | import Language.Fortran.AST 11 | import Language.Fortran.Util.Position 12 | import qualified Data.ByteString.Char8 as B 13 | 14 | iParser :: [String] -> String -> IO (ProgramFile A0) 15 | iParser incs = Parser.f77lInlineIncludes incs mempty "" . B.pack 16 | 17 | makeSrcR :: (Int, Int, Int, String) -> (Int, Int, Int, String) -> SrcSpan 18 | makeSrcR (i1, i2, i3, s) (j1, j2, j3, s') = SrcSpan (Position i1 i2 i3 s Nothing) (Position j1 j2 j3 s' Nothing) 19 | 20 | spec :: SpecWith () 21 | spec = 22 | describe "Include Test" $ do 23 | let source = unlines [" program bar", 24 | " include 'foo.f'", 25 | " end" 26 | ] 27 | name = "bar" 28 | puSpan = makeSrcR (6,7,1,"") (48,9,3,"") 29 | st1Span = makeSrcR (24,7,2,"") (38,21,2,"") 30 | expSpan = makeSrcR (32,15,2,"") (38,21,2,"") 31 | pf inc = ProgramFile mi77' [pu] 32 | where 33 | -- the expansion returns the span in the included file 34 | -- it should return the span at the inclusion 35 | foo = inc "foo.f" 36 | st2Span = makeSrcR (6,7,1, foo) (14,15,1,foo) 37 | st3Span = makeSrcR (22,7,2, foo) (30,15,2,foo) 38 | -- declSpan = makeSrcR (6,7,1,foo) (14,15,1,foo) 39 | ty1Span = makeSrcR (6,7,1,foo) (12,13,1,foo) 40 | ty2Span = makeSrcR (22,7,2,foo) (28,13,2,foo) 41 | var1Span = makeSrcR (14,15,1,foo) (14,15,1,foo) 42 | var2Span = makeSrcR (30,15,2,foo) (30,15,2,foo) 43 | varGen' ss str = ExpValue () ss $ ValVariable str 44 | 45 | pu = PUMain () puSpan (Just name) blocks Nothing 46 | blocks = [bl st1Span st1] 47 | decl var = Declarator () (getSpan var) var ScalarDecl Nothing Nothing 48 | typeSpec tySpan = TypeSpec () tySpan TypeInteger Nothing 49 | st ss tySs var = StDeclaration () ss (typeSpec tySs) Nothing (AList () (getSpan var) [decl var]) 50 | bl ss = BlStatement () ss Nothing 51 | st1 = StInclude () st1Span ex (Just 52 | [ bl st2Span . st st2Span ty1Span $ varGen' var1Span "a" 53 | , bl st3Span . st st3Span ty2Span $ varGen' var2Span "b" 54 | ]) 55 | ex = ExpValue () expSpan (ValString "foo.f") 56 | #ifndef FS_DISABLE_WIN_BROKEN_TESTS 57 | -- 2022-08-18 raehik 58 | -- These tests failed on the Windows CI on GitHub with an unknown error. I'm 59 | -- assuming it's to do with 'SrcSpan's not matching -- specifically the 60 | -- absolute offsets stored inside the positions, which aren't displayed by 61 | -- their 'Show' instance. I can't reproduce locally and it's almost 62 | -- certainly not a bug, just an issue with testing, so disabling on Windows. 63 | it "includes some files and expands them" $ do 64 | let inc = "." "test-data" "f77-include" 65 | pfParsed <- iParser [inc] source 66 | pfParsed `shouldBe` pf inc 67 | it "includes without a newline behave the same" $ do 68 | let inc = "." "test-data" "f77-include" "no-newline" 69 | pfParsed <- iParser [inc] source 70 | pfParsed `shouldBe` pf inc 71 | #else 72 | pure () 73 | #endif 74 | -------------------------------------------------------------------------------- /test/Language/Fortran/Parser/Free/Fortran2008Spec.hs: -------------------------------------------------------------------------------- 1 | module Language.Fortran.Parser.Free.Fortran2008Spec ( spec ) where 2 | 3 | import Test.Hspec 4 | 5 | spec :: Spec 6 | spec = 7 | describe "Fortran 2008 Parser" $ 8 | it "TODO" pending 9 | -------------------------------------------------------------------------------- /test/Language/Fortran/Parser/MonadSpec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-orphans #-} 2 | 3 | module Language.Fortran.Parser.MonadSpec where 4 | 5 | import Test.Hspec 6 | 7 | import Language.Fortran.Parser.Monad 8 | import Language.Fortran.Version 9 | import Language.Fortran.Util.Position 10 | 11 | vanillaParseState :: ParseState String 12 | vanillaParseState = ParseState 13 | { psAlexInput = "" 14 | , psVersion = Fortran66 15 | , psFilename = "" 16 | , psParanthesesCount = ParanthesesCount 0 False 17 | , psContext = [ ConStart ] 18 | } 19 | 20 | instance Loc String where 21 | getPos = error "Never needed" 22 | 23 | instance LastToken String String where 24 | getLastToken = error "Never needed" 25 | 26 | data SomeInput = SomeInput { p :: Position } 27 | 28 | initPos :: Position 29 | initPos = Position 5 1 2 "" Nothing 30 | 31 | initSomeInput :: SomeInput 32 | initSomeInput = SomeInput { p = initPos } 33 | 34 | instance Loc SomeInput where 35 | getPos = p 36 | 37 | instance LastToken SomeInput String where 38 | getLastToken = error "Never needed" 39 | 40 | vanillaSomeInput :: ParseState SomeInput 41 | vanillaSomeInput = ParseState 42 | { psAlexInput = initSomeInput 43 | , psVersion = Fortran66 44 | , psFilename = "some.f" 45 | , psParanthesesCount = ParanthesesCount 0 False 46 | , psContext = [ ConStart ] 47 | } 48 | 49 | spec :: Spec 50 | spec = 51 | describe "ParserMonad" $ do 52 | describe "Parse" $ do 53 | it "should give out correct version" $ 54 | evalParse getVersion vanillaParseState `shouldBe` Fortran66 55 | 56 | it "satisfies read after write equals to what is written" $ 57 | let ai = evalParse (putAlex "l'enfer" >> getAlex) vanillaParseState in 58 | ai `shouldBe` "l'enfer" 59 | 60 | describe "Obtaining locations" $ do 61 | it "getPosition returns correct location" $ 62 | let _expPosition = Position 6 2 3 "some.f" Nothing 63 | _exampleM = do 64 | _ai <- getAlex 65 | putAlex $ _ai { p = _expPosition } 66 | getPosition 67 | _loc = evalParse _exampleM vanillaSomeInput in 68 | _loc `shouldBe` _expPosition 69 | 70 | it "getSrcSpan return correct location span" $ 71 | let _loc2 = Position 6 2 3 "some.f" Nothing 72 | _exampleM = do 73 | _ai <- getAlex 74 | _loc1 <- getPosition 75 | putAlex $ _ai { p = _loc2 } 76 | getSrcSpan _loc1 77 | _span = evalParse _exampleM vanillaSomeInput 78 | _expectation = SrcSpan initPos _loc2 in 79 | _span `shouldBe` _expectation 80 | 81 | describe "Lex" $ do 82 | it "reads the state correctly" $ 83 | evalParse getAlex vanillaParseState `shouldBe` "" 84 | 85 | it "overrides the state correctly" $ 86 | let ai = evalParse (putAlex "c'est" >> getAlex) vanillaParseState in 87 | ai `shouldBe` "c'est" 88 | 89 | it "mixes operations correctly" $ 90 | let ai = evalParse (putAlex "hello" >> getAlex >>= \s -> putAlex (take 4 s) >> getAlex) vanillaParseState in 91 | ai `shouldBe` "hell" 92 | -------------------------------------------------------------------------------- /test/Language/Fortran/Repr/EvalSpec.hs: -------------------------------------------------------------------------------- 1 | module Language.Fortran.Repr.EvalSpec where 2 | 3 | import Test.Hspec 4 | import Test.Hspec.QuickCheck ( prop ) 5 | import Test.QuickCheck ( NonNegative(..) ) 6 | 7 | import TestUtil ( u ) 8 | 9 | import Language.Fortran.AST 10 | import Language.Fortran.Repr 11 | import Language.Fortran.Repr.Eval.Value 12 | 13 | import Language.Fortran.Analysis 14 | 15 | import Data.Int 16 | 17 | spec :: Spec 18 | spec = 19 | describe "exponentiation" $ 20 | prop "integer exponentation (+ve exponent) (INTEGER(4))" $ 21 | \base (NonNegative (expo :: Int32)) -> 22 | let expr = expBinary Exponentiation (expValInt base) (expValInt expo) 23 | in shouldEvalTo (FSVInt (FInt4 (base^expo))) (evalExpr expr) 24 | 25 | shouldEvalTo :: FScalarValue -> FEvalValuePure FValue -> Expectation 26 | shouldEvalTo checkVal prog = 27 | case runEvalFValuePure mempty prog of 28 | Right (a, _msgs) -> 29 | case a of 30 | MkFScalarValue a' -> a' `shouldBe` checkVal 31 | -- _ -> expectationFailure "not a scalar" 32 | Left e -> expectationFailure (show e) 33 | 34 | expBinary :: BinaryOp -> Expression (Analysis ()) -> Expression (Analysis ()) -> Expression (Analysis ()) 35 | expBinary = ExpBinary (analysis0 ()) u 36 | 37 | expValue :: Value (Analysis ()) -> Expression (Analysis ()) 38 | expValue = ExpValue (analysis0 ()) u 39 | 40 | -- | default kind. take integral-like over String because nicer to write :) 41 | valInteger :: (Integral a, Show a) => a -> Value (Analysis ()) 42 | valInteger i = ValInteger (show i) Nothing 43 | 44 | expValInt :: (Integral a, Show a) => a -> Expression (Analysis ()) 45 | expValInt = expValue . valInteger 46 | -------------------------------------------------------------------------------- /test/Language/Fortran/Transformation/GroupingSpec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-orphans #-} 2 | module Language.Fortran.Transformation.GroupingSpec where 3 | 4 | import Test.Hspec hiding (Selector) 5 | import TestUtil 6 | import Control.Exception (evaluate) 7 | import Control.DeepSeq (force) 8 | import Data.ByteString.Char8 (pack) 9 | import Data.Data 10 | 11 | import Language.Fortran.Transformation.Monad 12 | import Language.Fortran.AST 13 | import Language.Fortran.Util.Position 14 | import qualified Language.Fortran.Parser as Parser 15 | import Language.Fortran.Parser ( Parser ) 16 | import Language.Fortran.Transformation.Grouping 17 | 18 | transformWith :: Data a => Transform a () -> ProgramFile a -> ProgramFile a 19 | transformWith = runTransform mempty mempty 20 | 21 | groupDo', groupForall' :: Data a => ProgramFile a -> ProgramFile a 22 | groupDo' = transformWith groupLabeledDo 23 | groupForall' = transformWith groupForall 24 | 25 | spec :: Spec 26 | spec = do 27 | let name = Just "name" 28 | let endName = Just "endName" 29 | describe "Block FORALL statements" $ do 30 | it "groups unlabelled FORALL blocks" $ 31 | groupForall' (exampleForall Nothing Nothing) `shouldBe'` expectedForall Nothing 32 | it "groups unlabelled FORALL blocks" $ 33 | groupForall' (exampleForall name name) `shouldBe'` expectedForall name 34 | it "groups unlabelled FORALL blocks" $ do 35 | let lhs = (evaluate . force) (groupForall' $ exampleForall name endName) 36 | lhs `shouldThrow` anyErrorCall 37 | 38 | describe "Block DO statements" $ do 39 | it "do group example1" $ 40 | groupDo' example1do `shouldBe` expectedExample1do 41 | 42 | it "do group example2 with common end-point" $ 43 | groupDo' example2do `shouldBe` expectedExample2do 44 | 45 | describe "Block SrcSpan's" $ do 46 | it "Spans all a BlIf" $ 47 | ifSpan `shouldBe` expectedIfSpan 48 | it "spans all a BlDo" $ 49 | doSpan `shouldBe` expectedDoSpan 50 | it "spans all a BlDoWhile" $ 51 | doWhileSpan `shouldBe` expectedDoWhileSpan 52 | 53 | describe "Inner block SrcSpan's" $ do 54 | it "Spans the inner blocks of an if including comments - 77" $ 55 | ifInnerBlockSpan getSingleParsedBlock77 `shouldBe` expectedIfInnerBlockSpan 56 | it "Spans the inner blocks of an if including comments - 77 legacy" $ 57 | ifInnerBlockSpan getSingleParsedBlock77Legacy `shouldBe` expectedIfInnerBlockSpan 58 | 59 | buildExampleProgram :: Name -> [Block ()] -> ProgramFile () 60 | buildExampleProgram name blocks = ProgramFile mi77 [ PUMain () u (Just name) blocks Nothing ] 61 | 62 | exampleComment :: Block () 63 | exampleComment = BlComment () u $ Comment "comment" 64 | exampleHeader :: ForallHeader () 65 | exampleHeader = ForallHeader () u [] Nothing 66 | exampleForall :: Maybe String -> Maybe String -> ProgramFile () 67 | exampleForall name nameEnd = buildExampleProgram "forall" 68 | [ BlStatement () u Nothing $ StForall () u name exampleHeader 69 | , exampleComment 70 | , BlStatement () u Nothing $ StEndForall () u nameEnd 71 | ] 72 | 73 | expectedForall :: Maybe String -> ProgramFile () 74 | expectedForall name = buildExampleProgram "forall" 75 | [BlForall () u Nothing name exampleHeader [exampleComment] Nothing] 76 | 77 | -- do 10 i = 0, 10 78 | -- 10 continue 79 | label10 :: Maybe (Expression ()) 80 | label10 = Just (labelGen 10) 81 | example1do :: ProgramFile () 82 | example1do = ProgramFile mi77 [ PUMain () u (Just "example1") example1doblocks Nothing ] 83 | example1doblocks :: [Block ()] 84 | example1doblocks = 85 | [ BlStatement () u Nothing (StDo () u Nothing label10 dospec) 86 | , BlStatement () u label10 (StContinue () u) ] 87 | dospec :: Maybe (DoSpecification ()) 88 | dospec = Just $ 89 | DoSpecification 90 | () 91 | u 92 | (StExpressionAssign () u (varGen "i") (intGen 0)) 93 | (intGen 10) 94 | Nothing 95 | 96 | expectedExample1do :: ProgramFile () 97 | expectedExample1do = ProgramFile mi77 [ PUMain () u (Just "example1") expectedExample1doBlocks Nothing ] 98 | expectedExample1doBlocks :: [Block ()] 99 | expectedExample1doBlocks = 100 | [ BlDo () u Nothing Nothing label10 dospec 101 | [ ] label10 ] 102 | 103 | label20 :: Maybe (Expression ()) 104 | label20 = Just (labelGen 20) 105 | -- do 10 i = 0, 10 106 | -- do 10 i = 0, 10 107 | -- 10 continue 108 | -- do 20 i = 0, 10 109 | -- 20 continue 110 | example2do :: ProgramFile () 111 | example2do = ProgramFile mi77 [ PUMain () u (Just "example2") example2doblocks Nothing ] 112 | example2doblocks :: [Block ()] 113 | example2doblocks = 114 | [ BlStatement () u Nothing (StDo () u Nothing label10 dospec) 115 | , BlStatement () u Nothing (StDo () u Nothing label10 dospec) 116 | , BlStatement () u label10 (StContinue () u) 117 | , BlStatement () u Nothing (StDo () u Nothing label20 dospec) 118 | , BlStatement () u label20 (StContinue () u) 119 | ] 120 | 121 | expectedExample2do :: ProgramFile () 122 | expectedExample2do = ProgramFile mi77 [ PUMain () u (Just "example2") expectedExample2doBlocks Nothing ] 123 | expectedExample2doBlocks :: [Block ()] 124 | expectedExample2doBlocks = 125 | [ BlDo () u Nothing Nothing label10 dospec 126 | [ BlDo () u Nothing Nothing label10 dospec 127 | [ ] label10 128 | ] label10 129 | , BlDo () u Nothing Nothing label20 dospec 130 | [ ] label20 131 | ] 132 | 133 | getSingleParsedBlock :: Parser (ProgramFile A0) -> String -> Block A0 134 | getSingleParsedBlock p c = 135 | case p "" (pack c) of 136 | Right (ProgramFile _ ((PUSubroutine _ _ _ _ _ (b:_) _):_)) -> b 137 | e -> error $ show e 138 | 139 | -- TODO Runs internal transformations, which means we aren't explicitly asking 140 | -- for a grouping transformation. Bit weird. 141 | getSingleParsedBlock95 :: String -> Block A0 142 | getSingleParsedBlock95 = getSingleParsedBlock Parser.f95 143 | 144 | -- TODO Runs internal transformations, which means we aren't explicitly asking 145 | -- for a grouping transformation. Bit weird. 146 | getSingleParsedBlock77 :: String -> Block A0 147 | getSingleParsedBlock77 = getSingleParsedBlock Parser.f77 148 | 149 | getSingleParsedBlock77Legacy :: String -> Block A0 150 | getSingleParsedBlock77Legacy = getSingleParsedBlock Parser.f77lNoTransform 151 | 152 | type SimpleSpan = (Int, Int, Int, Int) 153 | 154 | simplifySpan :: SrcSpan -> SimpleSpan 155 | simplifySpan (SrcSpan b e) = (posLine b, posColumn b, posLine e, posColumn e) 156 | 157 | ifSpanRaw :: String 158 | ifSpanRaw = unlines [ 159 | " subroutine foobar" 160 | , " if (.TRUE.) then" 161 | , " print *, 'w00t'" 162 | , " endif" 163 | , " end" ] 164 | ifSpan :: SimpleSpan 165 | ifSpan = 166 | let BlIf _ s _ _ _ _ _ = getSingleParsedBlock95 ifSpanRaw 167 | in simplifySpan s 168 | expectedIfSpan :: SimpleSpan 169 | expectedIfSpan = (2, 8, 4, 12) 170 | 171 | doSpanRaw :: String 172 | doSpanRaw = unlines [ 173 | " subroutine foobar2" 174 | , " do ii = 2, 5" 175 | , " if(ii .eq. 2) print *, ii" 176 | , " if(ii .eq. 4) print *, ii" 177 | , " end do" 178 | , " end" ] 179 | doSpan :: SimpleSpan 180 | doSpan = 181 | let BlDo _ s _ _ _ _ _ _ = getSingleParsedBlock95 doSpanRaw 182 | in simplifySpan s 183 | expectedDoSpan :: SimpleSpan 184 | expectedDoSpan = (2, 8, 5, 13) 185 | 186 | doWhileSpanRaw :: String 187 | doWhileSpanRaw = unlines [ 188 | " subroutine barfoo" 189 | , " do while (.true.)" 190 | , " print *, 'foooo'" 191 | , " enddo" 192 | , " end" ] 193 | doWhileSpan :: SimpleSpan 194 | doWhileSpan = 195 | let BlDoWhile _ s _ _ _ _ _ _ = getSingleParsedBlock95 doWhileSpanRaw 196 | in simplifySpan s 197 | expectedDoWhileSpan :: SimpleSpan 198 | expectedDoWhileSpan = (2, 8, 4, 12) 199 | 200 | ifInnerBlockSpanRaw :: String 201 | ifInnerBlockSpanRaw = unlines [ 202 | " subroutine yeet" 203 | , " if (.true.) then" 204 | , "c very important comment" 205 | , " print *, 'yeet'" 206 | , "c even more important comment" 207 | , " endif" 208 | , " end" ] 209 | ifInnerBlockSpan :: (String -> Block A0) -> SimpleSpan 210 | ifInnerBlockSpan p = 211 | let BlIf _ _ _ _ clauses elseBlock _ = p ifInnerBlockSpanRaw 212 | in simplifySpan $ getSpan (fmap snd clauses, elseBlock) 213 | expectedIfInnerBlockSpan :: SimpleSpan 214 | expectedIfInnerBlockSpan = (3, 1, 5, 35) 215 | -------------------------------------------------------------------------------- /test/Language/Fortran/Util/FirstParameterSpec.hs: -------------------------------------------------------------------------------- 1 | module Language.Fortran.Util.FirstParameterSpec(spec) where 2 | 3 | import Test.Hspec 4 | 5 | import GHC.Generics (Generic(..)) 6 | 7 | import Language.Fortran.Util.FirstParameter 8 | 9 | data A = A Int deriving (Generic, Eq, Show) 10 | data B = B Char Char Int Char deriving (Generic, Eq, Show) 11 | data C = CA [Int] Char | CB [Int] Int deriving (Generic, Eq, Show) 12 | data D = DA () | DB () | DC () | DD () | DE () deriving (Generic, Eq, Show) 13 | 14 | instance FirstParameter A Int 15 | instance FirstParameter B Char 16 | instance FirstParameter C [Int] 17 | instance FirstParameter D () 18 | 19 | spec :: Spec 20 | spec = 21 | describe "First parameter accessor type class" $ do 22 | describe "data A" $ do 23 | it "retrieves first parameter from 'A 42'" $ 24 | getFirstParameter (A 42) `shouldBe` 42 25 | 26 | it "sets first parameter in 'A 42' to 24" $ 27 | setFirstParameter 24 (A 42) `shouldBe` A 24 28 | 29 | describe "data B" $ do 30 | it "retrieves first parameter from \"B 'x' 'y' 42 'z'\"" $ 31 | getFirstParameter (B 'x' 'y' 42 'z') `shouldBe` 'x' 32 | 33 | it "sets first parameter in \"B 'x' 'y' 42 'z'\" to 'm'" $ 34 | setFirstParameter 'm' (B 'x' 'y' 42 'z') `shouldBe` B 'm' 'y' 42 'z' 35 | 36 | describe "data C" $ do 37 | it "retrieves first parameter from 'CA [1,2,3] 'a''" $ 38 | getFirstParameter (CA [1,2,3] 'a') `shouldBe` [1,2,3] 39 | 40 | it "retrieves first parameter from \"CB [1,2,3] 'a'\"" $ 41 | getFirstParameter (CB [] 42) `shouldBe` [] 42 | 43 | it "sets first parameter in \"CB [1,2,3] 'a'\" to '[]'" $ 44 | setFirstParameter [] (CA [1,2,3] 'a') `shouldBe` CA [] 'a' 45 | 46 | describe "data D" $ do 47 | it "retrieves first parameter from 'DB ()" $ 48 | getFirstParameter (DB ()) `shouldBe` () 49 | 50 | it "retrieves first parameter from 'DD ()" $ 51 | getFirstParameter (DD ()) `shouldBe` () 52 | 53 | it "retrieves first parameter from 'DE ()" $ 54 | getFirstParameter (DE ()) `shouldBe` () 55 | -------------------------------------------------------------------------------- /test/Language/Fortran/Util/SecondParameterSpec.hs: -------------------------------------------------------------------------------- 1 | module Language.Fortran.Util.SecondParameterSpec(spec) where 2 | 3 | import Test.Hspec 4 | 5 | import GHC.Generics (Generic(..)) 6 | 7 | import Language.Fortran.Util.SecondParameter 8 | 9 | data A = A Char Int deriving (Generic, Eq, Show) 10 | data B = B Int Int Int Int deriving (Generic, Eq, Show) 11 | data C = CA String String | CB Int String () deriving (Generic, Eq, Show) 12 | data D = DA () () | DB Int () Int Int Int Int Int Int Int | DC () () | DD () () Char deriving (Generic, Eq, Show) 13 | 14 | instance SecondParameter A Int 15 | instance SecondParameter B Int 16 | instance SecondParameter C String 17 | instance SecondParameter D () 18 | 19 | spec :: Spec 20 | spec = 21 | describe "Second parameter retrieving type class" $ do 22 | describe "data A" $ do 23 | it "retrieves second parameter from 'A 'a' 42'" $ 24 | getSecondParameter (A 'x' 42) `shouldBe` 42 25 | 26 | it "sets second parameter in \"A 'a' 42\" to 24" $ 27 | setSecondParameter 24 (A 'x' 42) `shouldBe` A 'x' 24 28 | 29 | describe "data B" $ do 30 | it "retrieves second parameter from 'B 41 42 43 44'" $ 31 | getSecondParameter (B 41 42 43 44) `shouldBe` 42 32 | 33 | it "sets second parameter in \"B 41 42 43 44\" to 24" $ 34 | setSecondParameter 24 (B 41 42 43 44) `shouldBe` B 41 24 43 44 35 | 36 | describe "data C" $ do 37 | it "retrieves second parameter from 'CA \"hello\" ['x', 'y']'" $ 38 | getSecondParameter (CA "hello" ['x', 'y']) `shouldBe` ['x', 'y'] 39 | 40 | it "retrieves second parameter from 'CB 42 [] ()'" $ 41 | getSecondParameter (CB 42 [] ()) `shouldBe` [] 42 | 43 | it "sets second parameter in \"CB 42 []\" to ['x','x','x']" $ 44 | setSecondParameter "xxx" (CB 42 [] ()) `shouldBe` CB 42 "xxx" () 45 | 46 | describe "data d" $ do 47 | it "retrieves second parameter from 'DB 42 () 42 42 42 42 42 42 42'" $ 48 | getSecondParameter (DB 42 () 42 42 42 42 42 42 42) `shouldBe` () 49 | 50 | it "retrieves second parameter from 'DD () () 'a'" $ 51 | getSecondParameter (DD () () 'a') `shouldBe` () 52 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /test/TestUtil.hs: -------------------------------------------------------------------------------- 1 | module TestUtil where 2 | 3 | import Test.Hspec 4 | import Data.Data 5 | import Data.Generics.Uniplate.Data 6 | 7 | import Language.Fortran.AST 8 | import Language.Fortran.AST.Literal.Real 9 | import Language.Fortran.AST.Literal.Complex 10 | import Language.Fortran.Version 11 | import Language.Fortran.Util.Position 12 | 13 | import Language.Fortran.Analysis 14 | import Language.Fortran.Analysis.Renaming 15 | import qualified Data.Map as M 16 | import Data.Maybe 17 | 18 | u :: SrcSpan 19 | u = initSrcSpan 20 | 21 | -- TODO Filename only gets set with transformations (defaults to the empty 22 | -- string). @Parser.parseUnsafe@ uses @""@. So we have to define two 23 | -- different versions. 24 | -- 25 | -- Better would be to make an equality checker that ignores 'MetaInfo'. 26 | mi77, mi77', mi90 :: MetaInfo 27 | mi77 = MetaInfo { miVersion = Fortran77, miFilename = "" } 28 | mi77' = MetaInfo { miVersion = Fortran77, miFilename = "" } 29 | mi90 = MetaInfo { miVersion = Fortran90, miFilename = "" } 30 | 31 | valTrue, valFalse :: Expression () 32 | valTrue = ExpValue () u $ ValLogical True Nothing 33 | valFalse = ExpValue () u $ ValLogical False Nothing 34 | 35 | valTrue', valFalse' :: KindParam () -> Expression () 36 | valTrue' kp = ExpValue () u $ ValLogical True (Just kp) 37 | valFalse' kp = ExpValue () u $ ValLogical False (Just kp) 38 | 39 | varGen :: String -> Expression () 40 | varGen str = ExpValue () u $ ValVariable str 41 | 42 | declVarGen :: String -> Declarator () 43 | declVarGen str = Declarator () u (varGen str) ScalarDecl Nothing Nothing 44 | 45 | intGen :: Integer -> Expression () 46 | intGen i = ExpValue () u $ ValInteger (show i) Nothing 47 | 48 | aintGen :: Integer -> ArgumentExpression () 49 | aintGen = ArgExpr . intGen 50 | 51 | initGen :: [Expression ()] -> Expression () 52 | initGen es = ExpInitialisation () u $ fromList () es 53 | 54 | realGen :: (Fractional a, Show a) => a -> Expression () 55 | realGen i = ExpValue () u $ ValReal (parseRealLit (show i)) Nothing 56 | 57 | complexGen :: ComplexPart () -> ComplexPart () -> Expression () 58 | complexGen cr ci = ExpValue () u $ ValComplex $ ComplexLit () u cr ci 59 | 60 | strGen :: String -> Expression () 61 | strGen str = ExpValue () u $ ValString str 62 | 63 | labelGen :: Integer -> Expression () 64 | labelGen = intGen 65 | 66 | starVal :: Expression () 67 | starVal = ExpValue () u ValStar 68 | 69 | opGen :: String -> Expression () 70 | opGen s = ExpValue () u (ValOperator s) 71 | 72 | assVal :: Expression () 73 | assVal = ExpValue () u ValAssignment 74 | 75 | declVariable :: a -> SrcSpan -> Expression a -> Maybe (Expression a) -> Maybe (Expression a) -> Declarator a 76 | declVariable a ss v mLen mVal = Declarator a ss v ScalarDecl mLen mVal 77 | 78 | declArray :: a -> SrcSpan -> Expression a -> AList DimensionDeclarator a -> Maybe (Expression a) -> Maybe (Expression a) -> Declarator a 79 | declArray a ss v dims mLen mVal = Declarator a ss v (ArrayDecl dims) mLen mVal 80 | 81 | ixSinGen :: Integer -> Index () 82 | ixSinGen i = IxSingle () u Nothing (intGen i) 83 | ixRanGen :: Integer -> Integer -> Index () 84 | ixRanGen i j = IxRange () u (Just $ intGen i) (Just $ intGen j) Nothing 85 | 86 | shouldBe' :: (Data a, Eq a, Show a) => a -> a -> Expectation 87 | shouldBe' a b = resetSrcSpan a `shouldBe` resetSrcSpan b 88 | 89 | shouldMatchList' :: (Data a, Eq a, Show a) => [a] -> [a] -> Expectation 90 | shouldMatchList' a b = resetSrcSpan a `shouldMatchList` resetSrcSpan b 91 | 92 | -- To be used in testing it reverts the SrcSpans in AST to dummy initial 93 | -- SrcSpan value. 94 | resetSrcSpan :: Data a => a -> a 95 | resetSrcSpan = transformBi f 96 | where 97 | f x = case cast x :: Maybe SrcSpan of 98 | Just _ -> initSrcSpan 99 | Nothing -> x 100 | 101 | -------------------------------------------------- 102 | -- These functions do not work on modules with use-renaming so are 103 | -- only for testing purposes... 104 | underRenaming :: (Data a, Data b) => (ProgramFile (Analysis a) -> b) -> ProgramFile a -> b 105 | underRenaming f pf = tryUnrename `descendBi` f pf' 106 | where 107 | pf' = rename . analyseRenames . initAnalysis $ pf 108 | renameMap = extractNameMap pf' 109 | tryUnrename n = n `fromMaybe` M.lookup n renameMap 110 | 111 | extractNameMap :: Data a => ProgramFile (Analysis a) -> M.Map String String 112 | extractNameMap pf = eMap `M.union` puMap 113 | where 114 | eMap = M.fromList [ (un, n) | ExpValue Analysis { uniqueName = Just un, sourceName = Just n } _ _ <- uniE pf ] 115 | puMap = M.fromList [ (un, n) | pu <- uniPU pf, Analysis { uniqueName = Just un, sourceName = Just n } <- [getAnnotation pu] ] 116 | uniE :: Data a => ProgramFile a -> [Expression a] 117 | uniE = universeBi 118 | uniPU :: Data a => ProgramFile a -> [ProgramUnit a] 119 | uniPU = universeBi 120 | -------------------------------------------------- 121 | -------------------------------------------------------------------------------- /upgrade-guide.md: -------------------------------------------------------------------------------- 1 | # fortran-src upgrade guide 2 | ## Unreleased 3 | ### Kind parameter change 4 | Necessitates changes, but is a new feature. Where relevant, replace 5 | 6 | * `ExpValue _ _ (ValVariable v)` with `KindParamVar _ _ v`, and 7 | * `ExpValue _ _ (ValInteger i _)` with `KindParamInt _ _ i` 8 | 9 | and you should be good. 10 | 11 | ## Release 0.9.0 12 | ### Parser restructure 13 | ***Necessitates changes.*** 14 | 15 | Instead of grabbing parsers directly from `Language.Fortran.Parser.FortranXYZ`, 16 | import `Language.Fortran.Parser` qualified and use one of the many provided 17 | functions. If you need to do more complex parser incantations, we recommend 18 | using the combinators in `Parser`. 19 | 20 | In general, `parserVersions` and the parsers exported from respective parser 21 | modules can be replaced by `Parser.byVer`, `Parser.f77e` etc. The filepath 22 | argument now comes before the contents bytestring, so you may have to swap 23 | argument order (done to match other parsing libraries and most common usage). 24 | 25 | Also, some shims have been removed, primarily the `FortranVersion` re-export 26 | from `ParserMonad`. If you need `FortranVersion`, import 27 | `Language.Fortran.Version`. 28 | 29 | ## Release 0.8.0 30 | ### Declarator constructor refactor 31 | ***Necessitates changes.*** 32 | 33 | `Declarator`s are now a single constructor. The array/scalar part is moved into 34 | a new `DeclaratorType` field. The idea is that scalar and array declarators 35 | share most fields, and this enables skipping some unwanted explicitness when 36 | pattern matching. 37 | 38 | This means you have to fix up your pattern matches. For example, the following 39 | case: 40 | 41 | ```haskell 42 | case decl of 43 | DeclArray _ _ _ dims _ _ -> Right dims 44 | _ -> Left "error, scalar" 45 | ``` 46 | 47 | could be rewritten neater: 48 | 49 | ```haskell 50 | case declaratorType decl of 51 | ArrayDecl dims -> Right dims 52 | ScalarDecl -> Left "error, scalar" 53 | ``` 54 | 55 | Regardless of context, you can always lazily replace `DeclArray _ _ _ dims _ _` 56 | with `Declarator _ _ _ (ArrayDecl dims) _ _`. 57 | 58 | ## Release 0.7.0 59 | ### BOZ value constructor 60 | ***May necessitate changes.*** 61 | 62 | Previously, BOZ constants were parsed into the `ValInteger` constructor. Now 63 | they're parsed into their own constructor, storing the new parsed BOZ type. Any 64 | code that previously had to split out BOZs by "parsing" `ValInteger` no longer 65 | needs to. For example: 66 | 67 | ```haskell 68 | case val of 69 | ValInteger i -> 70 | case maybeParseInt i of 71 | Just i' -> WrappedValInt i' 72 | Nothing -> WrappedValBoz i 73 | ``` 74 | 75 | We no longer need the parsing check: 76 | 77 | ```haskell 78 | case val of 79 | ValInteger i -> WrappedValInt (parseInt i) 80 | ValBoz b -> WrappedValBoz b 81 | ``` 82 | 83 | ### Value representation upgrade 84 | ***Necessitates changes.*** 85 | 86 | Reals and logicals are stored parsed, instead of being stored as strings (which 87 | have previously been matched against a regex). Code that touched them will need 88 | to be changed. It will likely cut out any manual parsing that you had to 89 | perform. 90 | 91 | Also, literals which permit a kind parameter now store that in a separate field. 92 | Any code which performed the re-parsing manually should be rewritten. If your 93 | code targeted fixed form Fortran, you probably never cared about kind 94 | parameters, so your changes will include rewriting `ValInteger x` to `ValInteger 95 | x _` and so on. 96 | --------------------------------------------------------------------------------