packages feed

fortran-vars (empty) → 0.1.0

raw patch · 40 files changed

+6098/−0 lines, 40 filesdep +HUnitdep +aesondep +basesetup-changed

Dependencies added: HUnit, aeson, base, bytestring, containers, deepseq, fgl, fortran-src, fortran-src-extras, fortran-vars, hspec, text, uniplate

Files

+ CHANGELOG.md view
@@ -0,0 +1,6 @@+## 0.1.0 (6 Sep 2021)+Initial release.++### Major changes from original package+  * Using public Stack resolver.+  * Some of the underlying types are migrated to fortran-src 0.5.0.
+ LICENSE view
@@ -0,0 +1,202 @@++                                 Apache License+                           Version 2.0, January 2004+                        http://www.apache.org/licenses/++   TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION++   1. Definitions.++      "License" shall mean the terms and conditions for use, reproduction,+      and distribution as defined by Sections 1 through 9 of this document.++      "Licensor" shall mean the copyright owner or entity authorized by+      the copyright owner that is granting the License.++      "Legal Entity" shall mean the union of the acting entity and all+      other entities that control, are controlled by, or are under common+      control with that entity. For the purposes of this definition,+      "control" means (i) the power, direct or indirect, to cause the+      direction or management of such entity, whether by contract or+      otherwise, or (ii) ownership of fifty percent (50%) or more of the+      outstanding shares, or (iii) beneficial ownership of such entity.++      "You" (or "Your") shall mean an individual or Legal Entity+      exercising permissions granted by this License.++      "Source" form shall mean the preferred form for making modifications,+      including but not limited to software source code, documentation+      source, and configuration files.++      "Object" form shall mean any form resulting from mechanical+      transformation or translation of a Source form, including but+      not limited to compiled object code, generated documentation,+      and conversions to other media types.++      "Work" shall mean the work of authorship, whether in Source or+      Object form, made available under the License, as indicated by a+      copyright notice that is included in or attached to the work+      (an example is provided in the Appendix below).++      "Derivative Works" shall mean any work, whether in Source or Object+      form, that is based on (or derived from) the Work and for which the+      editorial revisions, annotations, elaborations, or other modifications+      represent, as a whole, an original work of authorship. For the purposes+      of this License, Derivative Works shall not include works that remain+      separable from, or merely link (or bind by name) to the interfaces of,+      the Work and Derivative Works thereof.++      "Contribution" shall mean any work of authorship, including+      the original version of the Work and any modifications or additions+      to that Work or Derivative Works thereof, that is intentionally+      submitted to Licensor for inclusion in the Work by the copyright owner+      or by an individual or Legal Entity authorized to submit on behalf of+      the copyright owner. For the purposes of this definition, "submitted"+      means any form of electronic, verbal, or written communication sent+      to the Licensor or its representatives, including but not limited to+      communication on electronic mailing lists, source code control systems,+      and issue tracking systems that are managed by, or on behalf of, the+      Licensor for the purpose of discussing and improving the Work, but+      excluding communication that is conspicuously marked or otherwise+      designated in writing by the copyright owner as "Not a Contribution."++      "Contributor" shall mean Licensor and any individual or Legal Entity+      on behalf of whom a Contribution has been received by Licensor and+      subsequently incorporated within the Work.++   2. Grant of Copyright License. Subject to the terms and conditions of+      this License, each Contributor hereby grants to You a perpetual,+      worldwide, non-exclusive, no-charge, royalty-free, irrevocable+      copyright license to reproduce, prepare Derivative Works of,+      publicly display, publicly perform, sublicense, and distribute the+      Work and such Derivative Works in Source or Object form.++   3. Grant of Patent License. Subject to the terms and conditions of+      this License, each Contributor hereby grants to You a perpetual,+      worldwide, non-exclusive, no-charge, royalty-free, irrevocable+      (except as stated in this section) patent license to make, have made,+      use, offer to sell, sell, import, and otherwise transfer the Work,+      where such license applies only to those patent claims licensable+      by such Contributor that are necessarily infringed by their+      Contribution(s) alone or by combination of their Contribution(s)+      with the Work to which such Contribution(s) was submitted. If You+      institute patent litigation against any entity (including a+      cross-claim or counterclaim in a lawsuit) alleging that the Work+      or a Contribution incorporated within the Work constitutes direct+      or contributory patent infringement, then any patent licenses+      granted to You under this License for that Work shall terminate+      as of the date such litigation is filed.++   4. Redistribution. You may reproduce and distribute copies of the+      Work or Derivative Works thereof in any medium, with or without+      modifications, and in Source or Object form, provided that You+      meet the following conditions:++      (a) You must give any other recipients of the Work or+          Derivative Works a copy of this License; and++      (b) You must cause any modified files to carry prominent notices+          stating that You changed the files; and++      (c) You must retain, in the Source form of any Derivative Works+          that You distribute, all copyright, patent, trademark, and+          attribution notices from the Source form of the Work,+          excluding those notices that do not pertain to any part of+          the Derivative Works; and++      (d) If the Work includes a "NOTICE" text file as part of its+          distribution, then any Derivative Works that You distribute must+          include a readable copy of the attribution notices contained+          within such NOTICE file, excluding those notices that do not+          pertain to any part of the Derivative Works, in at least one+          of the following places: within a NOTICE text file distributed+          as part of the Derivative Works; within the Source form or+          documentation, if provided along with the Derivative Works; or,+          within a display generated by the Derivative Works, if and+          wherever such third-party notices normally appear. The contents+          of the NOTICE file are for informational purposes only and+          do not modify the License. You may add Your own attribution+          notices within Derivative Works that You distribute, alongside+          or as an addendum to the NOTICE text from the Work, provided+          that such additional attribution notices cannot be construed+          as modifying the License.++      You may add Your own copyright statement to Your modifications and+      may provide additional or different license terms and conditions+      for use, reproduction, or distribution of Your modifications, or+      for any such Derivative Works as a whole, provided Your use,+      reproduction, and distribution of the Work otherwise complies with+      the conditions stated in this License.++   5. Submission of Contributions. Unless You explicitly state otherwise,+      any Contribution intentionally submitted for inclusion in the Work+      by You to the Licensor shall be under the terms and conditions of+      this License, without any additional terms or conditions.+      Notwithstanding the above, nothing herein shall supersede or modify+      the terms of any separate license agreement you may have executed+      with Licensor regarding such Contributions.++   6. Trademarks. This License does not grant permission to use the trade+      names, trademarks, service marks, or product names of the Licensor,+      except as required for reasonable and customary use in describing the+      origin of the Work and reproducing the content of the NOTICE file.++   7. Disclaimer of Warranty. Unless required by applicable law or+      agreed to in writing, Licensor provides the Work (and each+      Contributor provides its Contributions) on an "AS IS" BASIS,+      WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or+      implied, including, without limitation, any warranties or conditions+      of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A+      PARTICULAR PURPOSE. You are solely responsible for determining the+      appropriateness of using or redistributing the Work and assume any+      risks associated with Your exercise of permissions under this License.++   8. Limitation of Liability. In no event and under no legal theory,+      whether in tort (including negligence), contract, or otherwise,+      unless required by applicable law (such as deliberate and grossly+      negligent acts) or agreed to in writing, shall any Contributor be+      liable to You for damages, including any direct, indirect, special,+      incidental, or consequential damages of any character arising as a+      result of this License or out of the use or inability to use the+      Work (including but not limited to damages for loss of goodwill,+      work stoppage, computer failure or malfunction, or any and all+      other commercial damages or losses), even if such Contributor+      has been advised of the possibility of such damages.++   9. Accepting Warranty or Additional Liability. While redistributing+      the Work or Derivative Works thereof, You may choose to offer,+      and charge a fee for, acceptance of support, warranty, indemnity,+      or other liability obligations and/or rights consistent with this+      License. However, in accepting such obligations, You may act only+      on Your own behalf and on Your sole responsibility, not on behalf+      of any other Contributor, and only if You agree to indemnify,+      defend, and hold each Contributor harmless for any liability+      incurred by, or claims asserted against, such Contributor by reason+      of your accepting any such warranty or additional liability.++   END OF TERMS AND CONDITIONS++   APPENDIX: How to apply the Apache License to your work.++      To apply the Apache License to your work, attach the following+      boilerplate notice, with the fields enclosed by brackets "[]"+      replaced with your own identifying information. (Don't include+      the brackets!)  The text should be enclosed in the appropriate+      comment syntax for the file format. We also recommend that a+      file or class name and description of purpose be included on the+      same "printed page" as the copyright notice for easier+      identification within third-party archives.++   Copyright 2019 Bloomberg Finance L.P.++   Licensed under the Apache License, Version 2.0 (the "License");+   you may not use this file except in compliance with the License.+   You may obtain a copy of the License at++       http://www.apache.org/licenses/LICENSE-2.0++   Unless required by applicable law or agreed to in writing, software+   distributed under the License is distributed on an "AS IS" BASIS,+   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+   See the License for the specific language governing permissions and+   limitations under the License.
+ README.md view
@@ -0,0 +1,54 @@+# fortran-vars++`fortran-vars` is a static analysis library for Fortran code. It is built on top of the open source project [`fortran-src`](https://github.com/camfort/fortran-src) which provides lexing, parsing and basic analyses of Fortran code. `fortran-vars` focuses on supporting the Fortran 77 standard and extensions. It provides a Fortran memory model with a symbol table and storage table, constant expressions evaluation, constant propagation analysis++## Fortran Memory Model+`fortran-vars` provides a memory model that specifies the allocation arrangement of variables and arrays.++An accurate memory model is fundamental to Fortran static analysis especially for Fortran 77 code. The equivalence statement in Fortran establishes memory association among different symbols. Therefore symbols that refer to the same memory location shall be treated as the same entity in the static analysis, this is especially true for data-flow analysis that tracks the state of variables and arrays.++The usage of equivalence is prevalent in Fortran 77 code. The Fortran 77 standard does not have struct type. A common design pattern that emerged in Fortran 77 code is to mimic a struct type by declaring a large character array and variables of various types, and establishing equivalences among the variables and the character array elements. In effect the character array defines the raw buffer of a struct and the variables become the struct members.++`fortran-vars` assigns each variable or array a memory location. A memory location comprises of a memory block and the offset within that memory block. A memory block is a contiguous block of bytes, and can host multiple variables or arrays provided that they are associated via equivalence. An algorithm inspired by union-find is designed to accurately lay out the offsets of variables and arrays inside a memory block. Each memory block is identified by a unique name, which is conventionally set to the name of the first variable, whose offset is 0, in the memory block. If the memory block contains common variables then the name of the memory block is set to the name of the common area.++The memory model is described with two data structures: symbol table and storage table.++### Symbol Table+Four kinds of symbols are collected in the symbol table. They are parameters, variables, arrays and dummy arguments. The symbol entry contains the data type of the symbol and specific information related to the kind.++* Parameter is named constant whose value is known at compile time. `fortran-vars` evaluates the value of parameter and stores the value in the parameter entry.++* Variable is allocated to a piece of memory based on the memroy model described above. The memory location -- comprised of the name of memory block and the offset -- is recorded in the entry of variable.++* Array is allocated to a piece of memory as well. The memory location of the first element of array is recorded in the array entry.++* Dummy arguments are the arguments used in the definition of a function or subroutine. As Fortran 77 is pass-by-reference for function and subroutine calls, the dummy arguments point to the actual arguments from caller at run time. Therefore, there is no fixed memory location for dummy argument at compile time.++### Storage Table+The storage table contains the metadata of memory blocks. The metadata specifies the size of the memory block, its storage class, and the list of variables and arrays located in the block.++## Constant Expression Evaluation+The `Eval` module provides an interpreter for Fortran constant expressions. Arithmetic, logical, relational, and character expressions are supported. When `fortran-vars` constructs the symbol table, it uses the interpreter to calculate the values of parameters and saves the values in the parameter entries. For a constant expression with parameters, the interpreter looks up the parameter values in the symbol table. Array dimensions are commonly specified with parameters in which case they are determined using the interpreter.++## Constant Propagation Analysis+The constant expression interpreter cannot evaluate expressions with variables or array elements, whose values change at run time. Constant propagation analysis is a data flow analysis that discovers constant values by examining all possible execution paths in the control flow graph of a program and propagating the constants further. The `ConstantPropagation` module provides an expression evaluator based on the constant propagation analysis. For any expression in a program unit, the evaluator determines whether it is a constant, unknown (`Bot`), or uninitialized (`Top`).++The three kinds of values form a three-level lattice with `Top` being the highest of the lattice, `Bot` being the lowest, and all the constant values being in the middle, with no constant value being higher or lower than any other constant.++Variables and array elements are resolved to range of memory by referencing the symbol table and storage table, therefore the states of the constant propagation are represented by mapping from memory ranges to three-level lattice values.++## Usage+`fortran-vars` is mainly designed as a library of static analysis and refactoring of Fortran code. It also comes with a+command-line tool that dumps the symbol table and storage table of the input program in JSON format.++```+ fortran-vars (-v|--fortranVersion VERSION) [-I|--include DIRECTORY] FILE+```++## Build+`fortran-vars` uses [`stack`](https://docs.haskellstack.org) for development. To build and test, run:++```+stack build+stack test+```
+ Setup.hs view
@@ -0,0 +1,2 @@+import           Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,24 @@+module Main where++import           Language.Fortran.Extras.Encoding+                                                ( commonEncode )+import           Language.Fortran.Extras+                                                ( withProgramAnalysis )+import           Language.Fortran.Vars          ( programFileModel )++import qualified Data.ByteString.Lazy.Char8    as LB++import           Control.Monad                  ( unless )+import qualified Data.Map                      as M+                                                ( null )++programDesc, programHeader :: String+programDesc =+  "Generate symbol table and storage table from the AST of FORTRAN source"+programHeader = programDesc++main :: IO ()+main = withProgramAnalysis programDesc programHeader $ \pf -> do+    -- <String, (<String, Entry>,<String, MemoryBlock>)>+  let pfm = programFileModel pf+  unless (M.null pfm) $ LB.putStrLn $ commonEncode pfm
+ fortran-vars.cabal view
@@ -0,0 +1,123 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.34.4.+--+-- see: https://github.com/sol/hpack++name:           fortran-vars+version:        0.1.0+synopsis:       Fortran memory model and other static analysis tools.+description:    Various Fortran static analysis tools focusing on a memory model for Fortran types. Uses fortran-src for the syntax representation.+category:       Language+homepage:       https://github.com/camfort/fortran-vars#readme+bug-reports:    https://github.com/camfort/fortran-vars/issues+maintainer:     thefirstmuffinman@gmail.com+license:        Apache-2.0+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    CHANGELOG.md++source-repository head+  type: git+  location: https://github.com/camfort/fortran-vars++library+  exposed-modules:+      Language.Fortran.Vars+      Language.Fortran.Vars.Assignments+      Language.Fortran.Vars.BozConstant+      Language.Fortran.Vars.Call+      Language.Fortran.Vars.CommonLayout+      Language.Fortran.Vars.ConstantPropagation+      Language.Fortran.Vars.CPValue+      Language.Fortran.Vars.Dummy+      Language.Fortran.Vars.Equivalence+      Language.Fortran.Vars.Errors+      Language.Fortran.Vars.Eval+      Language.Fortran.Vars.Kind+      Language.Fortran.Vars.Memory+      Language.Fortran.Vars.MemoryLocation+      Language.Fortran.Vars.Operation+      Language.Fortran.Vars.PureExpression+      Language.Fortran.Vars.Range+      Language.Fortran.Vars.StorageClass+      Language.Fortran.Vars.StructureTable+      Language.Fortran.Vars.SymbolTable+      Language.Fortran.Vars.TypeCheck+      Language.Fortran.Vars.Types+      Language.Fortran.Vars.Union+      Language.Fortran.Vars.Utils+  other-modules:+      Paths_fortran_vars+  hs-source-dirs:+      src+  build-depends:+      aeson >=1.2.3.0+    , base >=4.7 && <5+    , bytestring >=0.10.8.1+    , containers >=0.5.7.1+    , deepseq >=1.4.4.0+    , fgl >=5+    , fortran-src >=0.5.0 && <0.6.0+    , fortran-src-extras >=0.2.0+    , text >=1.2.2.2+    , uniplate >=1.6.10+  default-language: Haskell2010++executable fortran-vars+  main-is: Main.hs+  other-modules:+      Paths_fortran_vars+  hs-source-dirs:+      app+  ghc-options: -threaded -rtsopts+  build-depends:+      aeson >=1.2.3.0+    , base >=4.7 && <5+    , bytestring >=0.10.8.1+    , containers >=0.5.7.1+    , deepseq >=1.4.4.0+    , fgl >=5+    , fortran-src >=0.5.0 && <0.6.0+    , fortran-src-extras >=0.2.0+    , fortran-vars+    , text >=1.2.2.2+    , uniplate >=1.6.10+  default-language: Haskell2010++test-suite spec+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      AssignmentsSpec+      BozConstantSpec+      ConstantPropagationSpec+      EvalSpec+      PureExpressionSpec+      StorageTableSpec+      StructureTableSpec+      SymbolTableSpec+      TypeCheckSpec+      Paths_fortran_vars+  hs-source-dirs:+      test+  ghc-options: -threaded -rtsopts+  build-tool-depends:+      hspec-discover:hspec-discover+  build-depends:+      HUnit+    , aeson >=1.2.3.0+    , base >=4.7 && <5+    , bytestring >=0.10.8.1+    , containers >=0.5.7.1+    , deepseq >=1.4.4.0+    , fgl >=5+    , fortran-src >=0.5.0 && <0.6.0+    , fortran-src-extras >=0.2.0+    , fortran-vars+    , hspec+    , text >=1.2.2.2+    , uniplate >=1.6.10+  default-language: Haskell2010
+ src/Language/Fortran/Vars.hs view
@@ -0,0 +1,57 @@+module Language.Fortran.Vars+  ( programUnitModel+  , programFileModel+  )+where++import           Language.Fortran.Extras+                                                ( allPUS )+import           Data.Data                      ( Data )+import           Data.Function                  ( (&) )+import           Data.List                      ( foldl' )+import qualified Data.Map                      as M+import           Language.Fortran.Analysis      ( Analysis+                                                , puName+                                                )+import           Language.Fortran.AST           ( ProgramFile(..)+                                                , ProgramUnit(..)+                                                )++import           Language.Fortran.Vars.Dummy+                                                ( undefineDummyArguments )+import           Language.Fortran.Vars.Equivalence+                                                ( processEquivalence )+import           Language.Fortran.Vars.Memory+                                                ( allocateMemoryBlocks+                                                , processCommon+                                                )+import           Language.Fortran.Vars.StorageClass+                                                ( processStorageClass )+import           Language.Fortran.Vars.SymbolTable+                                                ( collectSymbols )+import           Language.Fortran.Vars.Types+                                                ( ProgramFileModel+                                                , ProgramUnitModel+                                                )++-- | Given a 'ProgramUnit', generate a 'ProgramUnitModel' that contains not only a+-- 'SymbolTable' for the non-intrinsic symbols in the unit, but also a+-- 'Language.Fortran.Vars.Types.StorageTable' that determines the locations+-- that non-constant, non-parameter variables will be allocated+programUnitModel :: Data a => ProgramUnit (Analysis a) -> ProgramUnitModel+programUnitModel pu =+  let stmts     = allPUS pu+      symTable1 = undefineDummyArguments pu . collectSymbols $ pu+      mbs1      = allocateMemoryBlocks symTable1+  in  (symTable1, mbs1)+        & processStorageClass stmts+        & processCommon pu+        & processEquivalence stmts++-- | Given a 'ProgramFile', generate a 'ProgramFileModel' for each 'ProgramUnit' in+-- the file that contains not only a 'SymbolTable' for the non-intrinsic symbols in+-- the unit, but also a 'Language.Fortran.Vars.Types.StorageTable' that+-- determines the locations that non-constant, non-parameter variables will be allocated+programFileModel :: Data a => ProgramFile (Analysis a) -> ProgramFileModel+programFileModel (ProgramFile _ pus) = foldl' handler M.empty pus+  where handler m pu = M.insert (puName pu) (programUnitModel pu) m
+ src/Language/Fortran/Vars/Assignments.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Language.Fortran.Vars.Assignments+  ( allAssignStmts+  )+where++import           Data.Data                      ( Data )+import           Data.List                      ( foldl' )+import qualified Data.Map                      as M+import           Data.Generics.Uniplate.Data    ( universeBi )++import           Language.Fortran.Analysis      ( Analysis )+import           Language.Fortran.AST           ( ProgramUnit+                                                , Statement(..)+                                                , DataGroup(..)+                                                , Expression(..)+                                                , Declarator(..)+                                                , Value(..)+                                                , aStrip+                                                )+import           Language.Fortran.Util.Position ( Spanned(..) )++import           Language.Fortran.Extras.Encoding+                                                ( pprint77l )+import           Language.Fortran.Vars.StructureTable+                                                ( collectStructures )+import           Language.Fortran.Vars.SymbolTable+                                                ( collectSymbols )+import           Language.Fortran.Vars.Types+                                                ( SymbolTable+                                                , StructureTable+                                                , SymbolTableEntry(..)+                                                , Dimensions+                                                , Type(..)+                                                , SemType(..)+                                                , TypeError(..)+                                                , typeError+                                                )+import           Language.Fortran.Vars.TypeCheck+                                                ( typeOf )++-- | Method to retrieve the type of the lhs and expression on the rhs of all+-- assign like statements: expression assign, parameter, data and declarations+-- It returns the type of the lhs due to the expansion of array types to scalar+-- types in datagroups and declarations and returns TypeError's for the+-- expressions it can't calculate.+allAssignStmts+  :: forall a+   . Data a+  => ProgramUnit (Analysis a)+  -> [Either TypeError (Type, Expression (Analysis a))]+allAssignStmts pu =+  let+    symt = collectSymbols pu+    strt = collectStructures symt pu+  in+    [ (, e) <$> ty+    | StExpressionAssign _ _ v e <- universeBi pu :: [Statement (Analysis a)]+    , let ty = typeOf strt symt v+    ]+    <> [ (, e) <$> ty+       | StParameter _ _ decls <- universeBi pu :: [Statement (Analysis a)]+       , DeclVariable _ _ v _ (Just e) <- aStrip decls+       , let ty = typeOf strt symt v+       ]+    <> [ res+       | StData _ _ groups <- universeBi pu :: [Statement (Analysis a)]+       , res               <- dataGroups strt symt (aStrip groups)+       ]+    <> [ res+       | StDeclaration _ _ _ _ decls <-+         universeBi pu :: [Statement (Analysis a)]+       , res <- declarators strt symt $ aStrip decls+       ]++-- | Deal with data groups+dataGroups+  :: StructureTable+  -> SymbolTable+  -> [DataGroup (Analysis a)]+  -> [Either TypeError (Type, Expression (Analysis a))]+dataGroups strt symt = concatMap f+ where+  f (DataGroup _ _ vas eas) =+    let vs         = aStrip vas+        es         = aStrip eas+        expandedVs = concatMap (expandArrays strt symt) vs+        g (Left  err) _ = Left err+        g (Right ty ) e = Right (ty, e)+    in  zipWith g expandedVs es++-- | Expands declarators to lhs type and rhs expression+declarators+  :: StructureTable+  -> SymbolTable+  -> [Declarator (Analysis a)]+  -> [Either TypeError (Type, Expression (Analysis a))]+declarators strt symt = concatMap f where+  f (DeclVariable _ _ v _ (Just e)) = pure $ (, e) <$> typeOf strt symt v+  f d@(DeclArray _ _ (ExpValue _ s (ValVariable v)) _ _ (Just (ExpInitialisation _ _ vals)))+    = case M.lookup v symt of+      Just (SVariable (TArray ty (Just dims)) _) ->+        let tys   = expandDimensions dims ty+            vals' = aStrip vals+        in  if length tys /= length vals'+              then+                pure+                . Left+                . typeError s+                . mconcat+                $ [ "Length of lhs and rhs in declarator do not match: "+                  , ": "+                  , pprint77l d+                  ]+              else fmap Right $ zip (expandDimensions dims ty) $ aStrip vals+      _ ->+        pure+          .  Left+          .  typeError s+          $  "Unexpected lhs in array declaration at: "+          <> pprint77l d+  f _ = []  -- All other cases have no initial values++-- | Expands arrays to give a list of types given the length of an array+expandArrays+  :: StructureTable+  -> SymbolTable+  -> Expression (Analysis a)+  -> [Either TypeError Type]+expandArrays strt symt e = case e of+  ExpValue _ _ (ValVariable var) -> case M.lookup var symt of+    Just (SVariable (TArray ty (Just dims)) _) ->+      expandDimensions dims (Right ty)+    Just (SVariable ty _) -> [Right ty]+    _ ->+      pure+        .  Left+        .  typeError (getSpan e)+        $  "Got unexpected lhs type: "+        <> pprint77l e+  _ -> pure $ typeOf strt symt e++-- | Function to expand dimensions into appropriate number of types for use in+-- other expand functions+expandDimensions :: Dimensions -> a -> [a]+expandDimensions dims =+  replicate (foldl' (\acc (x, y) -> abs (y - x + 1) * acc) 1 dims)
+ src/Language/Fortran/Vars/BozConstant.hs view
@@ -0,0 +1,140 @@+module Language.Fortran.Vars.BozConstant+  ( resolveBozConstant+  , bozToInt+  , bozToInt2+  , bozToInt4+  , bozToInt8+  )+where++import           Data.Char                      ( digitToInt+                                                , intToDigit+                                                , toLower+                                                )+import qualified Data.Map                      as M+import           Numeric                        ( readInt+                                                , showIntAtBase+                                                )+import           Text.Read                      ( ReadS )++import           Language.Fortran.Vars.Types+                                                ( SymbolTableEntry(..)+                                                , Type(..)+                                                , SemType(..)+                                                , Kind+                                                , ExpVal(..)+                                                , SymbolTable+                                                )++-- | BozDecomposed is constructed with:+--   - String that represents the BOZ constant as it is in code, e.g. "'1111'x"+--   - String that represents digits without number system and lowercased, i.e. "ff1e" in "'Ff1E'x"+--   - Char that represents number system, i.e. 'x' in "'1111'x"+--   - Integer that represents number system, i.e. 16 in "'1111'x"+--   - String that represents binary translation of BOZ constant as it is.+--     It doesn't take into account any truncations nor overflows+data BozDecomposed = BozDecomposed String String Char Int String+  deriving Show++parseBozDecomposed :: ExpVal -> BozDecomposed+parseBozDecomposed (Boz bozStr) = BozDecomposed bozStr+                                                digits+                                                numsysChar+                                                numsysInt+                                                binary+ where+  digits     = getDigits bozStr+  numsysChar = if head bozStr `elem` "boxz" then head bozStr else last bozStr+  numsysInt  = case numsysChar of+    'b' -> 2+    'o' -> 8+    'x' -> 16+    'z' -> 16+    _   -> error+      (numsysChar+      : " is not supported BOZ specifier.\+                                                \ Invalid fortran syntax"+      )+  binary = toBinaryString digits numsysInt+parseBozDecomposed _ = error "ExpVal is not a BOZ constant"++resolveBozConstant' :: SymbolTable -> String -> BozDecomposed -> ExpVal+resolveBozConstant' symTable assignSymbol bozDecomposed =+  let entry = M.lookup assignSymbol symTable+  in+    case entry of+      Just (SVariable (TInteger kind) _) ->+        resolveBozConstantInContext bozDecomposed kind+      Just (SVariable ty _) ->+        error+          $  assignSymbol+          <> " is a "+          <> show ty+          <> "\nBOZ constants can only be resolved in an INTEGER context"+      Just _ -> error+        (assignSymbol+        ++ " is not a scalar variable. \+                                          \Invalid fortran sytax"+        )+      Nothing -> error+        (assignSymbol+        ++ " could not be found. \+                                          \Invalid fortran syntax"+        )++resolveBozConstantInContext :: BozDecomposed -> Kind -> ExpVal+resolveBozConstantInContext (BozDecomposed _ _ _ _ binary) kind =+  let allowedBinaryLength = kind * 8+      maxBinaryValue      = 2 ^ (allowedBinaryLength - 1) - 1+      minBinaryValue      = (-1) * 2 ^ (allowedBinaryLength - 1)+      truncatedBinary = reverse . take allowedBinaryLength . reverse $ binary+      decimal             = numsysStringToDecimal truncatedBinary 2+      overflow            = decimal - maxBinaryValue+  in  if overflow > 0 then Int (minBinaryValue + overflow - 1) else Int decimal++getDigits :: String -> String+getDigits bozStr = [ toLower c | c <- digits ]+ where+  digits =+    foldr (\l acc -> if l `elem` "'boxz" then acc else l : acc) [] bozStr++toBinaryString :: String -> Int -> String+toBinaryString digits fromNumsys = decimalToBinaryString decimal+  where decimal = numsysStringToDecimal digits fromNumsys++numsysStringToDecimal :: String -> Int -> Int+numsysStringToDecimal digits numsys = decimal+ where+  numsysValidFunction = (`elem` map intToDigit [0 .. (numsys - 1)])+  numsysReader = readInt numsys numsysValidFunction digitToInt :: ReadS Int+  ((decimal, _) : _) = numsysReader digits++decimalToBinaryString :: Int -> String+decimalToBinaryString decimal = showIntAtBase 2 intToDigit decimal ""++-- | Given 'SymbolTable', contextual symbol name and BOZ Constant+-- ('ExpVal' constructed with Boz String), resolve BOZ Constant considering+-- contextual symbol.+--+-- Currently, it only resolves BOZ Constants in context of INTEGER.+resolveBozConstant :: SymbolTable -> String -> ExpVal -> ExpVal+resolveBozConstant symTable assignSymbol boz@(Boz _) =+  resolveBozConstant' symTable assignSymbol (parseBozDecomposed boz)+resolveBozConstant _ _ _ = error "Can only resolve ExpVal Boz"+++-- Convert BOZ string to integer of specific kind+bozToInt :: Int -> ExpVal -> ExpVal+bozToInt kind boz = resolveBozConstantInContext (parseBozDecomposed boz) kind++-- Convert BOZ string to integer*2+bozToInt2 :: ExpVal -> ExpVal+bozToInt2 = bozToInt 2++-- Convert BOZ string to integer*4+bozToInt4 :: ExpVal -> ExpVal+bozToInt4 = bozToInt 4++-- Convert BOZ string to integer*8+bozToInt8 :: ExpVal -> ExpVal+bozToInt8 = bozToInt 8
+ src/Language/Fortran/Vars/CPValue.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Language.Fortran.Vars.CPValue+  ( CPValue(..)+  , meet+  , unaryOper+  , binaryOper+  , isTop+  , isBot+  , isConstInt+  )+where++import           Language.Fortran.Vars.Types+                                                ( ExpVal(..) )+import           Language.Fortran.Vars.Operation+                                                ( unaryOp+                                                , binaryOp+                                                )++import           Language.Fortran.AST           ( UnaryOp(..)+                                                , BinaryOp(..)+                                                )++import           Data.Data                      ( Data )+import           Data.Typeable                  ( Typeable )+import           GHC.Generics                   ( Generic )+import           Control.DeepSeq                ( NFData )++-- | CPValue (Constant Propagation Value) represnts the value of an expression+-- determined by constant propagation analysis.+-- The value can be uninitialized, a constant, or unknown due to conflict.+-- The data type is represented with 'ExpVal' together with two special values:+-- Top represents uninitialized value and is the least upper bound+-- Bot represents unknown and is the greatest lower bound+-- Top, Const, and Bot forms a lattice strucutre with meet operation defined below+data CPValue+  = Top           -- ^ represents uninitialized value+  | Const ExpVal  -- ^ represents a constant value+  | Bot           -- ^ short for bottom, represents unknown value+  deriving (Eq, Ord, Show, Data, Typeable, Generic, NFData)+++-- | meet operation for CPValue lattice with user defined function to handle+-- two Const values+meetWith :: (ExpVal -> ExpVal -> CPValue) -> CPValue -> CPValue -> CPValue+meetWith f v1 v2 = case (v1, v2) of+  (Bot     , _       ) -> Bot+  (_       , Bot     ) -> Bot+  (Top     , v       ) -> v+  (v       , Top     ) -> v+  (Const c1, Const c2) -> f c1 c2++-- | meet operation for CPValue lattice.+-- meet of two different constant value indicates conflict, therefore yields Bot.+meet :: CPValue -> CPValue -> CPValue+meet = meetWith (\c1 c2 -> if c1 == c2 then Const c1 else Bot)+++unaryOper :: UnaryOp -> CPValue -> CPValue+unaryOper op v = case v of+  Top          -> Top+  Bot          -> Bot+  Const expVal -> Const (unaryOp op expVal)++binaryOper :: BinaryOp -> CPValue -> CPValue -> CPValue+binaryOper op v1 v2 = case (op, v1, v2) of+  (Multiplication, Const (Int 0), _) -> Const (Int 0)+  (Multiplication, _, Const (Int 0)) -> Const (Int 0)+  (Multiplication, Const (Real 0.0), _) -> Const (Real 0.0)+  (Multiplication, _, Const (Real 0.0)) -> Const (Real 0.0)+  (Exponentiation, Const (Real 1.0), _) -> Const (Real 1.0)+  (Exponentiation, Const (Int 1), _) -> Const (Real 1.0)+  (Exponentiation, _, Const (Real 0.0)) -> Const (Real 1.0)+  (Exponentiation, _, Const (Int 0)) -> Const (Real 1.0)+  (And, Const (Logical False), _) -> Const (Logical False)+  (And, _, Const (Logical False)) -> Const (Logical False)+  (Or, Const (Logical True), _) -> Const (Logical True)+  (Or, _, Const (Logical True)) -> Const (Logical True)+  (_, Bot, _) -> Bot+  (_, _, Bot) -> Bot+  (_, Top, _) -> Top+  (_, _, Top) -> Top+  (_, Const x, Const y) -> Const (binaryOp op x y)+++isTop :: CPValue -> Bool+isTop Top = True+isTop _   = False++isBot :: CPValue -> Bool+isBot Bot = True+isBot _   = False++isConstInt :: CPValue -> Bool+isConstInt (Const Int{}) = True+isConstInt _             = False
+ src/Language/Fortran/Vars/Call.hs view
@@ -0,0 +1,62 @@+module Language.Fortran.Vars.Call+  ( functionCalls+  , subroutineCalls+  , functionArguments+  , subroutineArguments+  )+where+import           Data.Generics.Uniplate.Data    ( universeBi )+import           Data.Data                      ( Data )+import           Data.Char                      ( toUpper )++import           Language.Fortran.AST           ( Statement(..)+                                                , Expression(..)+                                                , Argument(..)+                                                , aStrip+                                                )+import           Language.Fortran.Analysis      ( Analysis+                                                , srcName+                                                )+import           Language.Fortran.Util.Position ( getSpan )++-- | Utility to get all call expressions of the specified function+functionCalls+  :: (Data a, Data (b (Analysis a)))+  => b (Analysis a)+  -> String+  -> [Expression (Analysis a)]+functionCalls x funcName =+  [ e+  | e@(ExpFunctionCall _ _ v _) <- universeBi x+  , caseInsensitiveEqual (srcName v) funcName+  ]++-- | Utility to get all call statements of the specified subroutine+subroutineCalls+  :: (Data a, Data (b (Analysis a)))+  => b (Analysis a)+  -> String+  -> [Statement (Analysis a)]+subroutineCalls x subName =+  [ e | e@(StCall _ _ v _) <- universeBi x, srcName v == subName ]++-- | Given a function call 'Expression', return the list of argument 'Expression'+functionArguments :: Expression a -> [Expression a]+functionArguments (ExpFunctionCall _ _ _ args) = case args of+  Just args' -> map (\(Argument _ _ _ e) -> e) (aStrip args')+  Nothing    -> []+functionArguments e =+  error $ "Expression at " ++ show (getSpan e) ++ " is not a function call"+++-- | Given a subroutine call 'Statement', return the list of argument 'Expression'+subroutineArguments :: Statement a -> [Expression a]+subroutineArguments (StCall _ _ _ args) = case args of+  Just args' -> map (\(Argument _ _ _ e) -> e) (aStrip args')+  Nothing    -> []+subroutineArguments s =+  error $ "Statement at " ++ show (getSpan s) ++ " is not a subroutine call"++-- | case-insenstive string equality+caseInsensitiveEqual :: String -> String -> Bool+caseInsensitiveEqual s1 s2 = map toUpper s1 == map toUpper s2
+ src/Language/Fortran/Vars/CommonLayout.hs view
@@ -0,0 +1,71 @@+module Language.Fortran.Vars.CommonLayout+  ( getCommonLayout+  , getFlagType+  )+where++import qualified Data.Map                      as M+import           Language.Fortran.AST           ( Name )+import           Language.Fortran.Vars.Types+                                                ( SymbolTableEntry(..)+                                                , MemoryBlock(..)+                                                , ProgramUnitModel+                                                , StorageClass(..)+                                                , Offset+                                                , Type(..)+                                                , SemType(..)+                                                , CharacterLen(..)+                                                )++data FlagType =+  Default+  | AlignCommons+  | NoAlignCommons++getFlagType :: String -> FlagType+getFlagType ""                  = Default+getFlagType "falign-commons"    = AlignCommons+getFlagType "fno-align-commons" = NoAlignCommons+getFlagType _                   = Default++getCommonLayout+  :: ProgramUnitModel -> String -> FlagType -> [(Name, Offset, Type)]+getCommonLayout (symbolTable, storageTable) commonArea flagOptions =+  generateOffset annotatedVariables+ where+  annotatedVariables =+    map (\x -> (x, getOffset x, getType x)) (getVariables commonArea)+  generateOffset list = case flagOptions of+    Default        -> list+    NoAlignCommons -> list+    AlignCommons   -> getPaddedOffset list 0+  getPaddedOffset [] _ = []+  getPaddedOffset ((name, offset, variableType) : xs) cumm =+    (name, offset + newCumm, variableType) : getPaddedOffset xs newCumm+   where+    newCumm = if diff > 0 then cumm + size - diff else cumm+    diff    = (offset + cumm) `mod` size+    size    = getSize variableType+  getSize variable = case variable of+    TInteger   size        -> size+    TReal      size        -> size+    TComplex   size        -> size+    TLogical   size        -> size+    TByte      size        -> size+    TCharacter (CharLenInt i) k -> i*k+    TCharacter _ _ ->+      error "Cannot handle dynamic length TCharacter in common area"+    TArray innerType _ -> getSize innerType+    TCustom _          -> error "Cannot handle TCustom in common area"+  getVariables cmn =+    let cmnStorageName = "/" ++ cmn ++ "/"+    in  case M.lookup cmnStorageName storageTable of+          Just memoryBlock | storageClass memoryBlock == Common ->+            variables memoryBlock+          _ -> []+  getOffset variableName = case M.lookup variableName symbolTable of+    Just (SVariable _ (_, offset)) -> offset+    _                              -> error "variable not found in symbolTable"+  getType variableName = case M.lookup variableName symbolTable of+    Just (SVariable variableType _) -> variableType+    _                               -> error "variable not found in symbolTable"
+ src/Language/Fortran/Vars/ConstantPropagation.hs view
@@ -0,0 +1,564 @@+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Language.Fortran.Vars.ConstantPropagation+  ( constantPropagationValue+  , ValueOf+  )+where++import           Language.Fortran.Vars ( programFileModel )+import           Language.Fortran.Vars.Types+import           Language.Fortran.Vars.Kind+                                                ( getTypeKind )+import           Language.Fortran.Vars.Range+                                                ( Range+                                                , overlap+                                                , anyOverlap+                                                )+import           Language.Fortran.Vars.Operation+                                                ( valueToExpVal )+import           Language.Fortran.Vars.MemoryLocation+                                                ( generateLinearizedIndexRange )+import           Language.Fortran.Vars.CPValue+                                                ( CPValue(..)+                                                , meet+                                                , unaryOper+                                                , binaryOper+                                                , isTop+                                                , isBot+                                                , isConstInt+                                                )++import           Language.Fortran.AST+import           Language.Fortran.Analysis      ( BBGr(..)+                                                , Analysis(..)+                                                , srcName+                                                )+import           Language.Fortran.Util.Position ( SrcSpan+                                                , getSpan+                                                )+import           Language.Fortran.Analysis.BBlocks+                                                ( BBlockMap+                                                , genBBlockMap+                                                , analyseBBlocks+                                                )+import           Language.Fortran.Analysis.DataFlow+                                                ( InOutMap+                                                , dataFlowSolver+                                                , revPostOrder+                                                )+import qualified Data.Map                      as M+import qualified Data.IntMap                   as IM+import           Data.List                      ( foldl' )+import           Data.Graph.Inductive.Graph     ( Node+                                                , lab+                                                , pre+                                                , labNodes+                                                )+import           Data.Data                      ( Data )+import           Data.Generics.Uniplate.Data+import           Data.Maybe                     ( maybeToList+                                                , fromMaybe+                                                , fromJust+                                                )++-- | ValueOf is a closure that takes an 'Expression' and deduces its 'CPValue'+type ValueOf a = Expression (Analysis a) -> CPValue++-- | MemoryTable represents the determined memory state of a particular memory+-- block. It contains the mappings between a piece of memory and its 'CPValue'.+-- The piece of memory is represented by an inclusive range inside a 'MemoryBlock'+type MemoryTable = M.Map Range CPValue++-- | MemoryTables contains 'MemoryTable's for all 'MemoryBlock's+type MemoryTables = M.Map MemoryBlockName MemoryTable++-- | Collection of output of constant propagation analysis ('InOutMap' 'MemoryTables')+-- for each ProgramUnit+type MemoryTablesMap = M.Map ProgramUnitName (InOutMap MemoryTables)++-- | Given a 'SymbolTable', 'MemoryTables', a possible specification of the+-- beginning of the substring as well as one for the end, and the length of+-- the original string, generate the bounds that should be used for the+-- substring. If the bounds cannot be determined the extraction will return+-- 'Nothing'.+extractSubstringBounds+  :: SymbolTable+  -> MemoryTables+  -> Maybe (Expression (Analysis a))+  -> Maybe (Expression (Analysis a))+  -> Int+  -> Maybe (Int, Int)+extractSubstringBounds symTable memTables mb me l =+  let f d m = case m >>= \v -> Just $ cpValue symTable memTables v of+        Nothing              -> Just d+        Just (Const (Int v)) -> Just v+        Just _               -> Nothing+  in  case (f 1 mb, f l me) of+        (Just b, Just e) -> Just (b, e)+        _                -> Nothing++-- | Given a 'SymbolTable', 'MemoryTables', the base 'Expression' of the substring,+-- any 'Index's that accompany the base, and possible the specifications for+-- the beginning and end of the substring, return the 'CPValue' of the substring.+substringCPValue+  :: SymbolTable+  -> MemoryTables+  -> Expression (Analysis a)+  -> [Index (Analysis a)]+  -> Maybe (Expression (Analysis a))+  -> Maybe (Expression (Analysis a))+  -> CPValue+substringCPValue symTable memTables e is mb me =+  let errStr         = "Array sections are not allowed in FORTRAN 77"+      name           = srcName e+      isArraySection = case fromJust $ M.lookup name symTable of+        (SVariable (TArray _ dims) _) -> length is < length dims+        _                             -> False+  in  if isArraySection+        then error errStr+        else case lookupArray symTable memTables name is of+          Top -> Top+          Bot -> Bot+          Const (Str s) ->+            case extractSubstringBounds symTable memTables mb me $ length s of+              Just (b', e') ->+                Const . Str $ take (e' - b' + 1) $ drop (b' - 1) s+              Nothing -> Bot+          _ -> error errStr++-- | Given 'SymbolTable', 'MemoryTables' and an 'Expression', determine the 'CPValue'+-- of the 'Expression'+cpValue :: SymbolTable -> MemoryTables -> Expression (Analysis a) -> CPValue+cpValue symTable memTables expr = case expr of+  ExpValue _ _ ValVariable{} -> lookupName symTable memTables $ srcName expr+  ExpValue _ s val -> Const (valueToExpVal s val)+  ExpUnary _ _ op e -> let v = cpValue symTable memTables e in unaryOper op v+  ExpBinary _ _ op e1 e2 ->+    let v1 = cpValue symTable memTables e1+        v2 = cpValue symTable memTables e2+    in  binaryOper op v1 v2+  ExpSubscript _ _ e@ExpValue{} (AList _ _ [IxRange _ _ mb me _]) ->+    substringCPValue symTable memTables e [] mb me+  ExpSubscript _ _ e@ExpValue{} is ->+    lookupArray symTable memTables (srcName e) $ aStrip is+  ExpSubscript _ _ (ExpSubscript _ _ e@ExpValue{} is) (AList _ _ [IxRange _ _ mb me _])+    -> substringCPValue symTable memTables e (aStrip is) mb me+  ExpFunctionCall{} -> Bot+  _ -> error $ "Evaluation of the expression is not implemented - " ++ show+    (getSpan expr)++-- | A piece of memory is represented as inclusive range indicating the start and+-- end offset of the memory within a memory block. This function is used for scalar+-- variable.+getVariableMemory :: SymbolTable -> Name -> Maybe (MemoryBlockName, Range)+getVariableMemory symTable name = case M.lookup name symTable of+  -- Array pointer passed to subroutine/function (thus treated as 'ValVariable')+  Just (SVariable (TArray ty dims) (memBlockName, offset)) -> do+    kind  <- getTypeKind ty+    dims' <- dims+    Just (memBlockName, (offset, offset + sizeOfArray kind dims' - 1))+  Just (SVariable ty (memBlockName, offset)) -> do+    kind <- getTypeKind ty+    Just (memBlockName, (offset, offset + kind - 1))+  Just SParameter{} -> Nothing+  Just SDummy{}     -> Nothing+  Nothing           -> Nothing+  _                 -> error $ "getVariableMemory -  not a variable : " ++ name++-- | Given a 'CPValue' without any present 'Bot' or 'Top'+-- 'CPValue's, convert to an 'Int'+unsafeStripIndexCP :: CPValue -> Int+unsafeStripIndexCP (Const (Int i)) = i+unsafeStripIndexCP _ = error "Expected no Top, Bot, nor non Int values"++-- | This data type describes the memory layout of an array's memory with+-- some additional qualification.+--+-- If any of the indices is unknown then the range of the array expression is+-- unknown. In this case 'UnknownIndices' variant is used with the range set+-- as the whole range of the array.+--+-- On the other hand, if indices are known constant, then the exact+-- range for the indices is used with the 'ConstantIndices' variant.+--+-- If the variable is a string declared as a scalar, the 'UnknownIndices' variant is+-- used with the range set to the size of the variable.+data ArrayMemory+  = UnknownIndices (MemoryBlockName, Range)+  | ConstantIndices (MemoryBlockName, Range)++-- | This function is used for array variable. It returns the range of the+-- specified element.+getArrayMemory+  :: SymbolTable+  -> MemoryTables+  -> Name+  -> [Index (Analysis a)]+  -> Maybe ArrayMemory+getArrayMemory symTable memTables name indices =+  let Just entry  = M.lookup name symTable+      idxCPValues = cpValueOfIndices symTable memTables indices+  in  case entry of+        SVariable (TArray ty dims) (memBlockName, start)+          | any isBot idxCPValues+          -> UnknownIndices . (memBlockName, ) <$> arrayRange+          | any isTop idxCPValues+          -> UnknownIndices . (memBlockName, ) <$> arrayRange+          | not (all isConstInt idxCPValues)+          -> UnknownIndices . (memBlockName, ) <$> arrayRange+          | otherwise+          -> do+            let is = map unsafeStripIndexCP idxCPValues+            range <- generateLinearizedIndexRange is start <$> dims <*> kind+            Just $ ConstantIndices (memBlockName, range)+         where+          kind       = getTypeKind ty+          size       = sizeOfArray <$> kind <*> dims+          arrayRange = (\x -> (start, start + x - 1)) <$> size+        SVariable ty (memBlockName, start)+          | null indices -> ConstantIndices . (memBlockName, ) <$> range+          | otherwise    -> UnknownIndices . (memBlockName, ) <$> range+         where+          kind  = getTypeKind ty+          range = (\x -> (start, start + x - 1)) <$> kind+        _ -> Nothing++-- | Internal function to find 'CPValue' of a symbol+lookupName :: SymbolTable -> MemoryTables -> Name -> CPValue+lookupName symTable memTables name = case M.lookup name symTable of+  Just (SParameter _  val) -> Const val+  Just (SVariable  ty loc) -> lookupScalarVariable memTables ty loc+  Just SDummy{}            -> Bot+  Just SExternal{}         -> Bot+  Nothing                  -> Bot++-- | Internal function to find 'CPValue' of a scalar variable+lookupScalarVariable :: MemoryTables -> Type -> Location -> CPValue+lookupScalarVariable memTables ty loc =+  let (memBlockName, start) = loc+      mkind                 = getTypeKind ty+      mrange                = (\x -> (start, start + x - 1)) <$> mkind+  in  case mrange of+        Just range -> case M.lookup memBlockName memTables of+          Just memTbl -> lookupRange range memTbl+          Nothing     -> Top+        Nothing -> Bot++-- | Internal fucntion to find 'CPValue' of an array element+lookupArray+  :: SymbolTable -> MemoryTables -> Name -> [Index (Analysis a)] -> CPValue+lookupArray symTable memTables name indices =+  case getArrayMemory symTable memTables name indices of+    Nothing                 -> Bot+    Just (UnknownIndices _) -> Bot+    Just (ConstantIndices (memBlockName, range)) ->+      case M.lookup memBlockName memTables of+        Just memTbl -> lookupRange range memTbl+        Nothing     -> Top++-- | Internal function to resovle the 'CPValue's of array indices+cpValueOfIndices+  :: SymbolTable -> MemoryTables -> [Index (Analysis a)] -> [CPValue]+cpValueOfIndices symTable memTables = map cpValueOfIndex+ where+  cpValueOfIndex :: Index (Analysis a) -> CPValue+  cpValueOfIndex (IxSingle _ _ _ e) = cpValue symTable memTables e+  cpValueOfIndex _ = error "Array sections are not allowed in FORTRAN 77"+++-- | Internal function to look up the 'CPValue' of a 'Range'+lookupRange :: Range -> MemoryTable -> CPValue+lookupRange range memTable = case M.lookup range memTable of+  Just val -> val+  Nothing | anyOverlap range (M.keys memTable) -> Bot+  _        -> Top+++-- | Constant Propagation Analysis+-- Given a 'ProgramUnitModel' and a control flow graph (basic blocks graph) of a+-- 'ProgramUnit', returns the In and Out 'MemoryTables' for each node in the graph+constantPropagationAnalysis+  :: ProgramUnitModel -> BBGr (Analysis a) -> InOutMap MemoryTables+constantPropagationAnalysis puModel gr = dataFlowSolver+  gr+  (const (M.empty, M.empty))+  revPostOrder+  inn+  out+ where+  inn outF b =+    M.unionsWith (M.unionWith meet) [ outF s | s <- pre (bbgrGr gr) b ]+  out innF b = foldl' (varDefine puModel)+                      (innF b)+                      (fromJustMsg "constantPropagation" $ lab (bbgrGr gr) b)++-- | Given 'MemoryTables', a 'MemoryBlockName', and a 'Range',+-- update that 'Range' to contain the specified 'CPValue'. If+-- the boolean argument is set to true, delete any values in+-- overlapping ranges+updateRangeValue+  :: MemoryTables -> MemoryBlockName -> Range -> CPValue -> Bool -> MemoryTables+updateRangeValue memTables' memBlockName range val filt =+  let rangeMap  = fromMaybe M.empty $ M.lookup memBlockName memTables'+      rangeMap' = if filt+        then M.filterWithKey (\k _ -> not (overlap k range)) rangeMap+        else rangeMap+      newRangeMap = M.insert range val rangeMap'+  in  M.insert memBlockName newRangeMap memTables'++-- | Process the definition of a substring in a block and update+-- the substring's 'CPValue' in the corresponding 'MemoryTable'.+--+-- Aside from the 'SymbolTable' and 'MemoryTable', this+-- function requires the base 'Expression' of the substring+-- as well as any 'Index's that go along with that base,+-- possibly a specification of the beginning and end of the+-- array, and finally the 'Expression' that is being assigned.+substringDefine+  :: SymbolTable+  -> MemoryTables+  -> Expression (Analysis a)+  -> [Index (Analysis a)]+  -> Maybe (Expression (Analysis a))+  -> Maybe (Expression (Analysis a))+  -> Expression (Analysis a)+  -> MemoryTables+substringDefine symTable memTables e is mb me rhs =+  case getArrayMemory symTable memTables (srcName e) is of+    Nothing -> memTables+    Just (UnknownIndices (memBlockName, wholeArrayRange)) ->+      let val = Bot+      in  updateRangeValue memTables memBlockName wholeArrayRange val True+    Just (ConstantIndices (memBlockName, range)) ->+      let val = cpValue symTable memTables rhs+          str = case M.lookup memBlockName memTables of+            Just memTbl -> lookupRange range memTbl+            Nothing     -> Top+          val' = case val of+            Const (Str s) -> case str of+              Const (Str o) ->+                case+                    extractSubstringBounds symTable memTables mb me $ length o+                  of+                    Just (b', e') ->+                      let s' = s ++ replicate (e' - b' + 1 - length s) ' '+                      in  Const . Str $ take (b' - 1) o ++ s' ++ drop e' o+                    Nothing -> Bot+              _ -> Bot+            _ -> Bot+      in  updateRangeValue memTables memBlockName range val' True++-- | Process the definition of a variable in a block and update the+-- variable's 'CPValue' in the corresponding 'MemoryTable'.+varDefine+  :: ProgramUnitModel -> MemoryTables -> Block (Analysis a) -> MemoryTables+varDefine (symTable, storageTable) memTables (BlStatement _ _ _ (StExpressionAssign _ _ lhs rhs))+  | expr@(ExpValue _ _ ValVariable{}) <- lhs+  , not $ inCommon expr+  = let name = srcName expr+    in+      case getVariableMemory symTable name of+        Just (memBlockName, range@(b, e)) ->+          let val = cpValue symTable memTables rhs+          in+            case fromJust $ M.lookup name symTable of+              SVariable (TArray ty _) _ ->+                let+                  kind =+                    fromMaybe (error $ "Couldn't get kind of type " <> show ty)+                      $ getTypeKind ty+                  val' = case val of+                    Const (Str s) -> Const . Str . replicate kind $ if null s+                      then ' '+                      else head s+                    _ -> val+                  handler mt range' =+                    updateRangeValue mt memBlockName range' val' True+                in+                  foldl' handler+                         memTables+                         [ (b', b' + kind - 1) | b' <- [b, b + kind .. e] ]+              _ -> updateRangeValue memTables memBlockName range val True+        Nothing -> memTables+  | ExpSubscript _ _ e@ExpValue{} (AList _ _ [IxRange _ _ mb me _]) <- lhs+  , not $ inCommon e+  = substringDefine symTable memTables e [] mb me rhs+  | ExpSubscript _ _ e@ExpValue{} indices <- lhs+  , not $ inCommon e+  = case getArrayMemory symTable memTables (srcName e) (aStrip indices) of+    Nothing -> memTables+    Just (UnknownIndices (memBlockName, wholeArrayRange)) ->+      let val = Bot+      in  updateRangeValue memTables memBlockName wholeArrayRange val True+    Just (ConstantIndices (memBlockName, range)) ->+      let val = cpValue symTable memTables rhs+      in  updateRangeValue memTables memBlockName range val False+  | ExpSubscript _ _ (ExpSubscript _ _ e@ExpValue{} is) (AList _ _ [IxRange _ _ mb me _]) <-+    lhs+  , not $ inCommon e+  = substringDefine symTable memTables e (aStrip is) mb me rhs+  | otherwise+  = memTables+ where+  inCommon :: Expression (Analysis a) -> Bool+  inCommon e = case M.lookup (srcName e) symTable of+    Just (SVariable _ (memBlockName, _)) ->+      case M.lookup memBlockName storageTable of+        Just memBlock -> storageClass memBlock == Common+        _             -> False+    _ -> False++varDefine _ memTables _ = memTables+++-- | ExpressionContext represents the block, basic block and 'ProgramUnit'+-- in which an expression is located+type ExpressionContext = (Node, Node, ProgramUnitName)++-- | Mapping from expression source span to 'ExpressionContext'+type ExpressionContextMap = M.Map SrcSpan ExpressionContext+++-- | Look up the 'ExpressionContext' of an 'Expression'+lookupExpressionContext+  :: Data a => Expression a -> ExpressionContextMap -> ExpressionContext+lookupExpressionContext expr exprCxtMap =+  let s   = getSpan expr+      err = "Lookup Expression Context at " ++ show s+  in  fromJustMsg err $ M.lookup s exprCxtMap++-- | Given 'BBlockMap', generates 'ExpressionContextMap'+genExpressionContextMap+  :: Data a => BBlockMap (Analysis a) -> ExpressionContextMap+genExpressionContextMap bblockMap =+  M.fromList+    . reverse+    $ [ (getSpan expr, (bl, bbl, pu))+      | (pu , gr        ) <- M.toList bblockMap+      , (bbl, basicBlock) <- labNodes (bbgrGr gr)+      , block             <- basicBlock+      , bl                <- maybeToList . label $ block+      , expr              <- allExp block+      ]+ where+  allExp :: Data a => Block (Analysis a) -> [Expression (Analysis a)]+  allExp = universeBi+++-- | Determine the 'CPValue' of an expression in a 'ProgramUnit' using constant+-- propagation analysis+--+-- Input:+--+--   * 'ProgramUnitModel'+--   * 'BBGr' -  Control Flow Graph of Basic Blocks+--   * 'InOutMap' 'MemoryTables' - generated by constantPropagationAnalysis+--   * 'ExpressionContextMap' - to identify the block and basic block of the input expression+--   * 'Expression'+--+-- Output:+--+--   * 'CPValue'+--+-- Description:+--+--   The control flow graph and the associated In and Out 'MemoryTables' are at the+--   level of Basic Block, which is coarse-grained with regard to Expression.+--   The memory state at the beginning of basic block may not represent+--   the memory state at the site of the expression. To get more precise determination+--   of value, the 'MemoryTables' is updated by processing each blocks preceding+--   the enclosing block of input expression.+--+--   The updated 'MemoryTables' is then used to determine the value of the 'Expression'.+constantPropagationValuePU+  :: Data a+  => ProgramUnitModel+  -> BBGr (Analysis a)+  -> InOutMap MemoryTables+  -> ExpressionContext+  -> Expression (Analysis a)+  -> CPValue+constantPropagationValuePU puModel@(symTable, _) gr memTables exprCxt expr =+  let+    (expBlock, expBBlock, _) = exprCxt+    bblock = fromJustMsg "Basic Block" $ lab (bbgrGr gr) expBBlock+    precedingBlocks = takeWhile (\b -> fromJust (label b) /= expBlock) bblock+    inBBMemoryTables = fst . fromJustMsg "Cannot find MemoryTables" $ IM.lookup+      expBBlock+      memTables+    inBlockMemoryTables =+      foldl' (varDefine puModel) inBBMemoryTables precedingBlocks+  in+    cpValue symTable inBlockMemoryTables expr++-- | Internal function to determine the 'CPValue' of an expression in a 'ProgramFile'+-- using constantpropagation analysis+constantPropagationValuePF+  :: Data a+  => ProgramFileModel+  -> BBlockMap (Analysis a)+  -> MemoryTablesMap+  -> ExpressionContextMap+  -> Expression (Analysis a)+  -> CPValue+constantPropagationValuePF pfModel bbgraphs memTablesMap exprCtxMap expr =+  let exprCtx@(_, _, unitName) = lookupExpressionContext expr exprCtxMap+      puModel = fromJustMsg "Find SymbolTable" $ M.lookup unitName pfModel+      controlFlowGraph =+          fromJustMsg "Find basic block graph" $ M.lookup unitName bbgraphs+      memTables = fromJustMsg "Find MemTables" $ M.lookup unitName memTablesMap+  in  constantPropagationValuePU puModel controlFlowGraph memTables exprCtx expr+++-- | Given a 'ProgramFile', return 'ValueOf' closure, which determines+-- whether given 'Expression' can be evaluated statically to a constant value using+-- constant propagation analysis.+--+-- Usage:+--   The best approach is to create a closure first as illustrated in the following+--   code example, so only one run of constant propragation analysis is performed+--   for a 'ProgramFile'.+--+--   @+--   let cpValueOf = constantPropagationValue pf+--   ...+--   in+--       ...+--       cpVauleOf e1+--       cpValueOf e2+--   @+constantPropagationValue :: Data a => ProgramFile (Analysis a) -> ValueOf a+constantPropagationValue pf =+  let pfb      = analyseBBlocks pf+      pfModel  = programFileModel pfb+      bbgraphs = genBBlockMap pfb+      mapFunc puName controlFlowGraph =+          let puModel =+                  fromJustMsg "Find ProgramUnitModel" $ M.lookup puName pfModel+          in  constantPropagationAnalysis puModel controlFlowGraph+      memTablesMap = M.mapWithKey mapFunc bbgraphs+      exprCtxMap   = genExpressionContextMap bbgraphs+  in  constantPropagationValuePF pfModel bbgraphs memTablesMap exprCtxMap++-- Utility functions+fromJustMsg :: String -> Maybe a -> a+fromJustMsg _   (Just x) = x+fromJustMsg msg _        = error msg++-- | 'Language.Fortran.Analysis.BBlocks.analyseBBlocks' annotates the 'Block'+-- and 'Expression' AST node with unique integer label. This function retrieves+-- the label from an AST node if the label exsits.+label+  :: forall a b+   . (Data a, Data (b (Analysis a)), Annotated b)+  => b (Analysis a)+  -> Maybe Int+label = insLabel . getAnnotation++-- | Given kind and dimensions, calculate the size of an array+sizeOfArray :: Int -> [(Int, Int)] -> Int+sizeOfArray kind dimension =+  let arraySize = foldl (\acc (l, h) -> acc * (h - l + 1)) 1 dimension+  in  kind * arraySize
+ src/Language/Fortran/Vars/Dummy.hs view
@@ -0,0 +1,72 @@+module Language.Fortran.Vars.Dummy+  ( undefineDummyArguments+  )+where++import           Language.Fortran.Extras+                                                ( allPUS )+import           Data.Data                      ( Data )+import           Data.List                      ( foldl' )+import qualified Data.Map                      as M+import           Language.Fortran.Analysis      ( Analysis+                                                , srcName+                                                )+import           Language.Fortran.AST           ( AList+                                                , aStrip+                                                , Value(..)+                                                , Expression(..)+                                                , ProgramUnit(..)+                                                , Statement(..)+                                                )++import           Language.Fortran.Vars.Types+                                                ( SymbolTableEntry(..)+                                                , SymbolTable+                                                )++dummyArgInProcedure+  :: Data a => SymbolTable -> ProgramUnit (Analysis a) -> SymbolTable+dummyArgInProcedure symt (PUSubroutine _ _ _ _ args _ _) = dummyArgs symt args+dummyArgInProcedure symt (PUFunction _ _ _ _ _ args _ _ _) =+  dummyArgs symt args+dummyArgInProcedure symt _ = symt++dummyArgInStmtFunction+  :: Data a => SymbolTable -> Statement (Analysis a) -> SymbolTable+dummyArgInStmtFunction symt (StFunction _ _ _ args _) =+  dummyArgs symt (Just args)+dummyArgInStmtFunction symt _ = symt++dummyArgs+  :: Data a+  => SymbolTable+  -> Maybe (AList Expression (Analysis a))+  -> SymbolTable+dummyArgs symt maybeArgs = case maybeArgs of+  Just args -> foldl' undefineDummyArg symt (aStrip args)+  Nothing   -> symt++undefineDummyArg+  :: Data a => SymbolTable -> Expression (Analysis a) -> SymbolTable+undefineDummyArg symt (ExpValue _ _ ValStar) = symt+undefineDummyArg symt varExp =+  let symbol = srcName varExp+  in  case M.lookup symbol symt of+        Just ve@SVariable{} -> M.insert symbol (variableToDummy ve) symt+        Just SParameter{} ->+          error (symbol ++ "is a parameter, invalid fortran syntax.")+        _ -> symt++variableToDummy :: SymbolTableEntry -> SymbolTableEntry+variableToDummy (SVariable ty _) = SDummy ty+variableToDummy _ =+  error "Only VariableEntry might be transformed to DummyEntry."++-- | Since FORTRAN parameters to functions can only have their memory allocation determined+-- at runtime, given a 'ProgramUnit' and a 'SymbolTable', return a new 'SymbolTable' where+-- all of the parameters have their 'DenotedVal' set to 'Undefined'+undefineDummyArguments+  :: Data a => ProgramUnit (Analysis a) -> SymbolTable -> SymbolTable+undefineDummyArguments pu symTable =+  let symTable1 = dummyArgInProcedure symTable pu+  in  foldl' dummyArgInStmtFunction symTable1 $ allPUS pu
+ src/Language/Fortran/Vars/Equivalence.hs view
@@ -0,0 +1,54 @@+module Language.Fortran.Vars.Equivalence+  ( processEquivalence+  )+where++import           Data.Data                      ( Data )+import           Data.List                      ( foldl' )+import           Language.Fortran.Analysis      ( Analysis )+import           Language.Fortran.AST           ( AList+                                                , aStrip+                                                , Expression+                                                , Statement(..)+                                                )++import           Language.Fortran.Vars.MemoryLocation+                                                ( getLocation )+import           Language.Fortran.Vars.Types+                                                ( Location+                                                , ProgramUnitModel+                                                )+import           Language.Fortran.Vars.Union+                                                ( union )++associate :: ProgramUnitModel -> [Location] -> ProgramUnitModel+associate puModel locations =+  let firstLoc : restLocs = locations+      f (model, loc) = union model loc+      (puModel', _) = foldl' f (puModel, firstLoc) restLocs+  in  puModel'++equivalence+  :: Data a => ProgramUnitModel -> Statement (Analysis a) -> ProgramUnitModel+equivalence puModel0 (StEquivalence _ _ equivsList) = foldl'+  f+  puModel0+  (aStrip equivsList)+ where+  f+    :: Data a+    => ProgramUnitModel+    -> AList Expression (Analysis a)+    -> ProgramUnitModel+  f model@(symTable, _) equivs =+    let locations = map (getLocation symTable) (aStrip equivs)+    in  associate model locations+equivalence model _ = model++-- | Given a list of all the 'Statement's in the program and a 'ProgramUnitModel', produce a new+-- 'ProgramUnitModel' that accounts for any of the FORTRAN equivalences that were found in the+-- 'Language.Fortran.AST.ProgramUnit'+processEquivalence+  :: Data a => [Statement (Analysis a)] -> ProgramUnitModel -> ProgramUnitModel+processEquivalence stmts puModel = foldl' equivalence puModel eqvStmts+  where eqvStmts = [ s | s@StEquivalence{} <- stmts ]
+ src/Language/Fortran/Vars/Errors.hs view
@@ -0,0 +1,28 @@+module Language.Fortran.Vars.Errors+  ( invalidArg'+  , invalidArg+  )+where++import           Data.List                      ( foldl' )++-- | Given a function name and arguments, generate an+-- error message for invalid arguments+genError :: Show a => String -> [a] -> String+genError funcName args =+  let+    argMsg = case args of+      []     -> ""+      [ x ]  -> " - " ++ show x+      x : xs -> "s - " ++ foldl' (\acc y -> acc ++ ", " ++ show y) (show x) xs+  in  funcName ++ " : invalid argument" ++ argMsg++-- | Function to return an error case when an unappropriate arguemnt is+-- passed to some function or when some pattern match issue occurs+invalidArg' :: Show a => String -> [a] -> Either String b+invalidArg' funcName args = Left $ genError funcName args++-- | Function to throw an error when an unappropriate arguemnt is+-- passed to some function or when some pattern match issue occurs+invalidArg :: Show a => String -> [a] -> b+invalidArg funcName args = error $ genError funcName args
+ src/Language/Fortran/Vars/Eval.hs view
@@ -0,0 +1,98 @@+module Language.Fortran.Vars.Eval+  ( eval+  , eval'+  , evalWithShortcircuit+  )+where++import           Prelude                 hiding ( fail )+import qualified Data.Map                      as M+import           Language.Fortran.AST           ( BinaryOp(..)+                                                , Expression(..)+                                                , Value(..)+                                                , AList(..)+                                                , Argument(..)+                                                )+import           Language.Fortran.Util.Position ( getSpan )++import           Language.Fortran.Vars.Operation+                                                ( binaryOp'+                                                , binaryTransformEither+                                                , nonLogicalToLogical+                                                , transformEither+                                                , transformEitherList+                                                , unaryOp'+                                                , valueToExpVal'+                                                , intrinsicFunctionCall+                                                )+import           Language.Fortran.Vars.Types+                                                ( SymbolTableEntry(..)+                                                , ExpVal(..)+                                                , SymbolTable+                                                )++-- | Given a 'SymbolTable' and some 'Expression', evaluate that expression+-- into a basic type and return it as an 'ExpVal' or a 'String' describing+-- the issue that prevented the evaluation+eval' :: SymbolTable -> Expression a -> Either String ExpVal+eval' symTable expr = case expr of+  ExpValue _ _ (ValVariable name) -> case M.lookup name symTable of+    Just (SParameter _ expVal) -> Right expVal+    Just _ -> Left $ "Cannot be evaluated: " ++ name ++ " is not a parameter."+    Nothing -> Left $ "Cannot find parameter : " ++ name+  ExpValue _ s val  -> valueToExpVal' s val+  ExpUnary _ _ op e -> transformEither (unaryOp' op) $ eval' symTable e+  ExpBinary _ _ op e1 e2 ->+    binaryTransformEither (binaryOp' op) (eval' symTable e1) (eval' symTable e2)+  ExpFunctionCall _ _ (ExpValue _ _ function) (Just (AList _ _ args)) ->+    transformEitherList intrinsicFunctionCall' $ evalArgs args+   where+    intrinsicFunctionCall' = intrinsicFunctionCall $ functionName function+    functionName (ValVariable  name) = name+    functionName (ValIntrinsic name) = name+    functionName _                   = ""+    evalArgs :: [Argument a] -> [Either String ExpVal]+    evalArgs []                           = []+    evalArgs [Argument _ _ _ arg        ] = [eval' symTable arg]+    evalArgs (Argument _ _ _ arg : args') = eval' symTable arg : evalArgs args'+  _ -> Left $ "Unsupported expression at: " ++ show (getSpan expr)++-- | Given a 'SymbolTable' and some 'Expression', evaluate that expression+-- into a basic type and return it as an 'ExpVal'+eval :: SymbolTable -> Expression a -> ExpVal+eval symTable expr = case eval' symTable expr of+  Left  err -> error (err ++ show (getSpan expr))+  Right r   -> r++-- | Given a 'SymbolTable' and some 'Expression', evaluate that expression+-- into a basic type and return it as an 'ExpVal' or a 'String' describing+-- the issue that prevented the evaluation. In the case of expressions like+--+-- @+--       foobar .AND. .FALSE.+--       .TRUE. .OR. .foobar+-- @+--+-- the expressions will be shortcircuited to produce+--+-- @+--       .FALSE.+--       .TRUE.+-- @+evalWithShortcircuit :: SymbolTable -> Expression a -> Either String ExpVal+evalWithShortcircuit symTable expr = case expr of+  ExpUnary _ _ op e ->+    transformEither (unaryOp' op) $ evalWithShortcircuit symTable e+  ExpBinary _ _ op e1 e2 ->+    let e1' = evalWithShortcircuit symTable e1+        e2' = evalWithShortcircuit symTable e2+        t   = transformEither nonLogicalToLogical+    in  case (op, t e1', t e2') of+          (And, Right r    , Right l    ) -> Right . Logical $ r && l+          (And, Right False, _          ) -> Right $ Logical False+          (And, _          , Right False) -> Right $ Logical False+          (Or , Right r    , Right l    ) -> Right . Logical $ r || l+          (Or , Right True , _          ) -> Right $ Logical True+          (Or , _          , Right True ) -> Right $ Logical True+          _ -> binaryTransformEither (binaryOp' op) e1' e2'+  _ -> eval' symTable expr
+ src/Language/Fortran/Vars/Kind.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE LambdaCase #-}++module Language.Fortran.Vars.Kind+  ( module Language.Fortran.Vars.Kind+  , kindOfBaseType+  , getTypeSize+  , setTypeSize+  , deriveSemTypeFromBaseType+  ) where++import           Data.Either                    ( either )+import           Data.Maybe                     ( fromJust )+import           Language.Fortran.Analysis      ( Analysis )+import           Language.Fortran.Analysis.Types+                                                ( deriveSemTypeFromBaseType )+import           Language.Fortran.AST           ( BaseType(..)+                                                , Expression(..)+                                                , Selector(..)+                                                , TypeSpec(..)+                                                , Value(..)+                                                )+import           Language.Fortran.Analysis.SemanticTypes+                                                ( kindOfBaseType+                                                , getTypeSize+                                                , setTypeSize+                                                )++import           Language.Fortran.Vars.Errors+                                                ( invalidArg )+import           Language.Fortran.Vars.Eval+                                                ( eval' )+import           Language.Fortran.Vars.Types+                                                ( ExpVal(..)+                                                , Type(..)+                                                , SemType(..)+                                                , CharacterLen(..)+                                                , SymbolTable+                                                )++baseToType :: BaseType -> Type+baseToType = deriveSemTypeFromBaseType++getTypeKind :: Type -> Maybe Int+getTypeKind = getTypeSize++setTypeKind :: Type -> Maybe Int -> Type+setTypeKind = setTypeSize++-- | Given an 'ExpVal', return the 'Type' of that value+typeOfExpVal :: ExpVal -> Type+typeOfExpVal = \case+  Int     _ -> TInteger 4+  Real    _ -> TReal 4+  Logical _ -> TLogical 4+  Str     _ -> TCharacter (CharLenInt 1) 1+  Boz     _ -> error "BOZ constant is type-less"++-- | Given an 'ExpVal', return true if it is a 'Str', else false+isStr :: ExpVal -> Bool+isStr e = case e of+  Str _ -> True+  _     -> False++-- | Given an 'ExpVal' determine the kind of it+getKindOfExpVal :: ExpVal -> Int+getKindOfExpVal (Str s) = length s+getKindOfExpVal ev      = fromJust . getTypeSize . typeOfExpVal $ ev++-- | Convert an 'ExpVal' to an 'Int'. This will fail if the+-- 'ExpVal' is not already known to be an 'Int'+toInt :: ExpVal -> Int+toInt (Int i) = i+toInt e       = invalidArg "toInt" [e]++-- | Given a 'SymbolTable', a 'TypeSpec' for a variable, and possibly an 'Expression'+-- for the length of a character array, determine the kind of that variable+-- The charLength also works for nonstandard kind+getKind+  :: SymbolTable+  -> TypeSpec (Analysis a)+  -> Maybe (Expression (Analysis a))+  -> Maybe Int+getKind symTable (TypeSpec _ _ bt selector) charLength =+  let evalMaybeKind kind =+          either (const Nothing) (Just . toInt) $ eval' symTable kind+  in  case charLength of+        Just charLen -> evalMaybeKind charLen+        Nothing      -> case selector of+          Just (Selector _ _ _ (Just kindExp)) ->+            let k' = kindExp+            in  case k' of+                  ExpValue _ _ ValStar -> Nothing+                  _                    -> evalMaybeKind kindExp+          Just (Selector _ _ (Just lengthExp) _) ->+            let l' = lengthExp+            in  case l' of+                  ExpValue _ _ ValStar -> Nothing+                  _                    -> evalMaybeKind lengthExp+          _ -> Just $ kindOfBaseType bt
+ src/Language/Fortran/Vars/Memory.hs view
@@ -0,0 +1,123 @@+{-# LANGUAGE TupleSections #-}++module Language.Fortran.Vars.Memory+  ( allocateMemoryBlocks+  , processCommon+  )+where++import           Language.Fortran.Extras+                                                ( allPUS )+import           Data.Data                      ( Data )+import           Data.List                      ( foldl' )+import           Data.Maybe                     ( fromMaybe )+import qualified Data.Map                      as M+import           Language.Fortran.Analysis      ( Analysis+                                                , srcName+                                                )+import           Language.Fortran.AST           ( AList(..)+                                                , aStrip+                                                , CommonGroup(..)+                                                , Expression(..)+                                                , Name+                                                , ProgramUnit+                                                , Statement(..)+                                                )++import           Language.Fortran.Vars.MemoryLocation+                                                ( getStartLocation )+import           Language.Fortran.Vars.Types+                                                ( SymbolTableEntry(..)+                                                , MemoryBlock(..)+                                                , ProgramUnitModel+                                                , SymbolTable+                                                , StorageClass(..)+                                                , StorageTable+                                                , Type(..)+                                                , SemType(..)+                                                )+import           Language.Fortran.Vars.Kind+                                                ( getTypeKind )+import           Language.Fortran.Vars.Union+                                                ( union )++-- | Given a 'SymbolTable' and an 'Expression', return the size of+-- the variable represented by the expression+getSize :: Data a => SymbolTable -> Expression (Analysis a) -> Int+getSize symTable expr =+  let symbol = case expr of+        ExpValue{} -> srcName expr+        ExpFunctionCall _ _ e@ExpValue{} _ -> srcName e+        ExpSubscript _ _ e@ExpValue{} _ -> srcName e+        _          -> error "Unsupported expression"+      Just entity = M.lookup symbol symTable+  in  case entity of+        SVariable (TArray ty dims) _ ->+          fromMaybe (error "Can't calculate size of dynamic array")+            $   sizeOfStaticArray+            <$> getTypeKind ty+            <*> dims+        SVariable ty _ ->+          fromMaybe (error "Can't get size of dynamic variable")+            $ getTypeKind ty+        _ -> error (symbol ++ " is not a VariableEntry.")++-- | Given a static array's 'kind' and 'dimension', calculate its size+sizeOfStaticArray :: Int -> [(Int, Int)] -> Int+sizeOfStaticArray kind' dimension' =+  let arraySize = foldl (\acc (l, h) -> acc * (h - l + 1)) 1 dimension'+  in  kind' * arraySize++-- | Given a 'SymbolTable', generate a 'StorageTable' for the 'SymbolTable' where+-- each symbol has been assinged to a 'MemoryBlock' within the 'StorageTable' so+-- long as it is not constant+allocateMemoryBlocks :: SymbolTable -> StorageTable+allocateMemoryBlocks = M.foldlWithKey f M.empty+ where+  f :: StorageTable -> Name -> SymbolTableEntry -> StorageTable+  f storageTable symbol entry = case entry of+    SVariable ty _ ->+      let size = case ty of+            TArray ty' dims -> sizeOfStaticArray <$> getTypeKind ty' <*> dims+            _               -> getTypeKind ty+          block = MemoryBlock+            { blockSize    = size+            , storageClass = case size of+                               Nothing -> Automatic+                               _       -> Unspecified+            , variables    = [symbol]+            }+      in  M.insert symbol block storageTable+    _ -> storageTable++-- | Given a 'ProgramUnit' and a 'ProgramUnitModel', resolve any commonly defined global+-- variables in the 'ProgramUnit's to be the same in both memory and within the 'SymbolTable'+processCommon+  :: Data a => ProgramUnit (Analysis a) -> ProgramUnitModel -> ProgramUnitModel+processCommon pu puModel =+  let commonGrps =+          [ commGrps | (StCommon _ _ (AList _ _ commGrps)) <- allPUS pu ]+      mergeCommonVariables mapping (CommonGroup _ _ commName varList) =+          let commonName = case commName of+                Just e  -> "/" ++ srcName e ++ "/"+                Nothing -> "*blank_common*"+              vars          = aStrip varList+              precedingVars = fromMaybe [] (M.lookup commonName mapping)+          in  M.insert commonName (precedingVars ++ vars) mapping+      commons = foldl' mergeCommonVariables M.empty (concat commonGrps)+      processComm commonName varExps (symTable, mbs) =+          let varLocations       = map (getStartLocation symTable) varExps+              varSizes           = map (getSize symTable) varExps+              varAccumSizes      = scanl1 (+) varSizes+              commBlockLocations = map (commonName, ) (0 : varAccumSizes)+              mbs'               = case M.lookup commonName mbs of+                Just _ -> mbs+                Nothing ->+                  let newBlock = MemoryBlock { blockSize = Just $ sum varSizes+                                             , storageClass = Common+                                             , variables = []+                                             }+                  in  M.insert commonName newBlock mbs+              f model (l1, l2) = let (model', _) = union model l1 l2 in model'+          in  foldl' f (symTable, mbs') (zip commBlockLocations varLocations)+  in  M.foldrWithKey processComm puModel commons
+ src/Language/Fortran/Vars/MemoryLocation.hs view
@@ -0,0 +1,143 @@+module Language.Fortran.Vars.MemoryLocation+  ( getLocation+  , generateLinearizedIndexRange+  , getStartLocation+  )+where++import           Data.Data                      ( Data )+import           Data.List                      ( foldl' )+import qualified Data.Map                      as M+import           Language.Fortran.Analysis      ( Analysis+                                                , srcName+                                                )+import           Language.Fortran.AST           ( AList(..)+                                                , Expression(..)+                                                , Index(..)+                                                , Name+                                                , Value(..)+                                                )++import           Language.Fortran.Vars.Eval+                                                ( eval )+import           Language.Fortran.Vars.Kind+                                                ( toInt+                                                , getTypeKind+                                                )+import           Language.Fortran.Vars.Range+                                                ( Range )+import           Language.Fortran.Vars.Types+                                                ( SymbolTableEntry(..)+                                                , Type(..)+                                                , SemType(..)+                                                , Location+                                                , Offset+                                                , SymbolTable+                                                )+++isIxSingle :: Index a -> Bool+isIxSingle IxSingle{} = True+isIxSingle IxRange{}  = False++linearizedIndex :: [Int] -> [(Int, Int)] -> Int+linearizedIndex indices dimensions =+  -- The normalized index starts at 0+  let normalizedIndices =+          zipWith (curry (\(i, (lower, _)) -> i - lower)) indices dimensions+      dimSizes    = map (\(lower, upper) -> upper - lower + 1) dimensions+      leadingDims = calcLeadingDimensions dimSizes+  in  foldl' (\acc (i, ld) -> acc + i * ld)+             0+             (zip normalizedIndices leadingDims)+ where+  calcLeadingDimensions :: [Int] -> [Int]+  calcLeadingDimensions []       = []+  calcLeadingDimensions dimSizes = calc [1] dimSizes+   where+    calc _   []      = []+    calc acc [_    ] = reverse acc+    calc acc (h : t) = calc ((head acc * h) : acc) t++-- | Given only single indices return the 'Range' in memory that+-- these indices point to.+generateLinearizedIndexRange :: [Int] -> Int -> [(Int, Int)] -> Int -> Range+generateLinearizedIndexRange intIndices start dims kind =+  let offset = linearizedIndex intIndices dims * kind+  in  (start + offset, start + offset + kind - 1)++findBlockOffset :: SymbolTable -> Name -> Offset -> Location+findBlockOffset symTable symbol offset = case M.lookup symbol symTable of+  Just (SVariable _ (blockName, start)) -> (blockName, start + offset)+  Just entry -> error $ symbol ++ " is not a variable - " ++ show entry+  Nothing ->+    error+      $  "Unable to find location for symbol "+      ++ symbol+      ++ " at offset "+      ++ show offset++calculateOffset :: Data a => SymbolTable -> Name -> [Index (Analysis a)] -> Int+-- array index c(2,4)+calculateOffset symTable symbol indices@(IxSingle{} : _) =+  let Just entry = M.lookup symbol symTable+  in  case entry of+        SVariable (TArray ty (Just dims)) _ ->+          let ixSingles    = takeWhile isIxSingle indices+              Just kind    = getTypeKind ty+              arrayIndices = map toIndices ixSingles+                 where+                  toIndices (IxSingle _ _ _ expr) = toInt $ eval symTable expr+                  toIndices _ = error "toIndices: unexpected input"+          in  linearizedIndex arrayIndices dims * kind+        _ ->+          error "Only array-typed VariableEntries are expected at this point"+-- substring c(:5)+calculateOffset _ _ (IxRange _ _ Nothing _ _ : _) = 0+-- substring c(5:)+calculateOffset symTable _ (IxRange _ _ (Just lowerIndex) _ _ : _) =+  toInt (eval symTable lowerIndex) - 1+calculateOffset _ _ _ = error "calculateOffset: invalid index"++-- | Given a 'SymbolTable' and some 'Expression' (which is assumed to have been predetermined+-- to be of some variable type), return the 'Location' that the variable in question will be+-- located in memory+getLocation :: Data a => SymbolTable -> Expression (Analysis a) -> Location+-- variable+getLocation symTable e@(ExpValue _ _ (ValVariable _)) =+  findBlockOffset symTable (srcName e) 0+-- array index c(2,4)+-- substring c(5:10)+getLocation symTable (ExpSubscript _ _ e@ExpValue{} (AList _ _ indices)) =+  let symbol = srcName e+      offset = calculateOffset symTable symbol indices+  in  findBlockOffset symTable symbol offset+-- array index and substring c(2,4)(1:20)+getLocation symTable (ExpSubscript _ _ (ExpSubscript _ _ e@ExpValue{} (AList _ _ indices)) (AList _ _ subs))+  = let symbol = srcName e+        offset =+            calculateOffset symTable symbol indices+              + calculateOffset symTable symbol subs+    in  findBlockOffset symTable symbol offset+-- array within common block with dimensions declaration: common /block/ a, b(10)+getLocation symTable (ExpFunctionCall _ _ e@ExpValue{} _) =+  findBlockOffset symTable (srcName e) 0+getLocation _ _ = error "getLocation : Not a variable expression"++-- | Given a 'SymbolTable' and some 'Expression' (which is assumed to have been+-- predetermined to be of some variable type), return the start 'Location' that+-- the variable in question will be located in memory.+-- Start 'Location' is the begining of greater data structure that a variable+-- belongs to e.g. start 'Location' of c(20) is 'Location' of c+getStartLocation :: Data a => SymbolTable -> Expression (Analysis a) -> Location+-- variable+getStartLocation symTable e@(ExpValue _ _ (ValVariable _)) =+  findBlockOffset symTable (srcName e) 0+-- dimensions specification within COMMON c(10,20)+getStartLocation symTable (ExpSubscript _ _ e@ExpValue{} _) =+  findBlockOffset symTable (srcName e) 0+-- dimensions specification within COMMON c(10,20)+--   (vars with nonstandard kind declared after COMMON block)+getStartLocation symTable (ExpFunctionCall _ _ e@ExpValue{} _) =+  findBlockOffset symTable (srcName e) 0+getStartLocation _ _ = error "getStartLocation : Not a variable expression"
+ src/Language/Fortran/Vars/Operation.hs view
@@ -0,0 +1,300 @@+module Language.Fortran.Vars.Operation+  ( valueToExpVal'+  , valueToExpVal+  , transformEither+  , transformEitherList+  , binaryTransformEither+  , unaryOp'+  , unaryOp+  , binaryOp'+  , binaryOp+  , intrinsicFunctionCall+  , nonLogicalToLogical+  )+where++import           Prelude                 hiding ( GT+                                                , EQ+                                                , LT+                                                )+import           Data.Char                      ( toUpper+                                                , chr+                                                )+import           Data.Either                    ( either )+import           Text.Read                      ( readMaybe )++import           Language.Fortran.AST           ( BinaryOp(..)+                                                , UnaryOp(..)+                                                , Value(..)+                                                )+import           Language.Fortran.Util.Position ( SrcSpan )+++import           Language.Fortran.Vars.BozConstant+                                                ( bozToInt8+                                                , bozToInt+                                                )+import           Language.Fortran.Vars.Errors+                                                ( invalidArg' )+import           Language.Fortran.Vars.Types+                                                ( ExpVal(..) )++import           Data.Bits                      ( (.|.)+                                                , complement+                                                )++-- | Given a 'SrcSpan' and the 'String' string at that span,+-- return either a string describing the error encountered, or+-- the double held by that string.+readReal :: SrcSpan -> String -> Either String Double+readReal s r =+  let r' = transform r+  in  maybe+          (Left $ "Expected a real value at " ++ show s ++ " got '" ++ r' ++ "'"+          )+          Right+        $ readMaybe r'+ where+  uniformPrecision 'D' = 'E'+  uniformPrecision 'Q' = 'E'+  uniformPrecision c   = c+  transform' []             = []+  transform' ['.'         ] = []+  transform' ('.' : y : ys) = case uniformPrecision (toUpper y) of+    'E' -> 'E' : transform' ys+    _   -> '.' : y : transform' ys+  transform' (x : xs) = uniformPrecision (toUpper x) : transform' xs+  transform xs@('.' : _) = transform' $ '0' : xs+  transform xs           = transform' xs+++-- | Given a 'String', return either a 'String' describing the+-- issue that prevented the read or the 'Bool' value contained+-- in the string+readLogical :: String -> Either String Bool+readLogical s = case map toUpper s of+  ".TRUE."  -> Right True+  ".FALSE." -> Right False+  _         -> invalidArg' "readLogical" [s]++-- | Given a function that returns an 'Either' and an 'Either' with+-- the 'Right' case as the same type input to the function, return+-- an either by possibly applying the function to the 'Right' value or+-- propagating the 'Left' case+transformEither :: (a -> Either String b) -> Either String a -> Either String b+transformEither = either Left+{-# INLINABLE transformEither #-}++-- | Given a function that takes two arguments of the same type and returns an+-- 'Either' as well as two 'Either's whose 'Right' cases hold the inputs to the+-- function, apply the function if possible. Otherwise propagate the 'Left' cases+binaryTransformEither+  :: (a -> a -> Either String b)+  -> Either String a+  -> Either String a+  -> Either String b+binaryTransformEither _ (Left e)   _          = Left e+binaryTransformEither _ _          (Left  e ) = Left e+binaryTransformEither t (Right v1) (Right v2) = t v1 v2++-- | Given a function that takes a list of arguments of the same type and returns an+-- 'Either' as well as a list of 'Either's whose 'Right' cases hold the inputs to the+-- function, apply the function if possible. Otherwise propagate the 'Left' cases+transformEitherList+  :: ([a] -> Either String b) -> [Either String a] -> Either String b+transformEitherList t el = case eitherListToList el of+  Left  l  -> Left l+  Right rs -> t rs+ where+  eitherListToList :: [Either String a] -> Either String [a]+  eitherListToList []             = Right []+  eitherListToList (Left  l : _ ) = Left l+  eitherListToList (Right r : rs) = case eitherListToList rs of+    Left  l   -> Left l+    Right rs' -> Right (r : rs')++-- | Given a 'SrcSpan' and the 'Value' in that span either+-- return a 'String' describing the issue or the 'ExpVal' held+-- by that 'Value'.+valueToExpVal' :: SrcSpan -> Value a -> Either String ExpVal+valueToExpVal' s val = case val of+  ValInteger i ->+    let i' = readMaybe i :: Maybe Int+    in  case i' of+          Just valInt -> Right $ Int valInt+          Nothing     -> Right $ Boz i+  ValReal      r  -> transformEither (Right . Real) $ readReal s r+  ValString    s' -> Right $ Str s'+  ValLogical   l  -> transformEither (Right . Logical) $ readLogical l+  ValHollerith h  -> Right $ Str h+  _               -> Left ("toExpVal: unsupported value at " ++ show s)++-- | Given a 'SrcSpan' and the 'Value' returnthe 'ExpVal' held+-- by that 'Value' or throw an error.+valueToExpVal :: SrcSpan -> Value a -> ExpVal+valueToExpVal s val = case valueToExpVal' s val of+  Left  err  -> error err+  Right expr -> expr++-- | Given a non-logical 'ExpVal', convert that value to a logical+-- one or return a 'String' describing why this was impossible.+nonLogicalToLogical :: ExpVal -> Either String Bool+nonLogicalToLogical (Int  i) = Right $ i /= 0+nonLogicalToLogical (Real r) = Right $ r /= 0.0+nonLogicalToLogical (Str _) =+  Left "Cannot transform a string value to a logical value"+nonLogicalToLogical (  Logical l) = Right l+nonLogicalToLogical b@(Boz     _) = nonLogicalToLogical $ bozToInt8 b++-- | Given a string representing a function call and a list of ExpVal+-- values holding inputs to the function, evaluate the function call+-- and return the result in a Right, or propagate the Left case if any+-- of the list elements are 'Lefts'.+intrinsicFunctionCall :: String -> [ExpVal] -> Either String ExpVal+intrinsicFunctionCall function es = case function of+  "ior"  -> ior' es+  "max"  -> max' es+  "char" -> char' es+  "not"  -> not' es+  "int"  -> int' es+  "int2" -> int' es+  _      -> invalidArg' ("intrinsicFunctionCall " ++ show function) es++ior' :: [ExpVal] -> Either String ExpVal+ior' [val1, val2] = case (val1, val2) of+  (Int a, Int b) -> Right $ Int $ (.|.) a b+  _              -> invalidArg' "ior" [val1, val2]+ior' vs = invalidArg' "ior" vs++max' :: [ExpVal] -> Either String ExpVal+max' [val1] = case val1 of+  Real a -> Right $ Real a+  Int  a -> Right $ Int a+  _      -> invalidArg' "max" [val1]+max' (v : vs) =+  let maxVs = max' vs+  in  case (v, maxVs) of+        (_      , Left l        ) -> Left l+        (Real r', Right (Int r) ) -> Right $ Real $ max r' (fromIntegral r)+        (Int  r', Right (Real r)) -> Right $ Real $ max (fromIntegral r') r+        (Real r', Right (Real r)) -> Right $ Real $ max r' r+        (Int  r', Right (Int r) ) -> Right $ Int $ max r' r+        _                         -> invalidArg' "max" (v : vs)+max' vs = invalidArg' "max" vs++char' :: [ExpVal] -> Either String ExpVal+char' [Int i] = Right $ Str [chr i]+char' vs      = invalidArg' "char" vs++-- https://docs.oracle.com/cd/E19957-01/805-4939/6j4m0vnc8/index.html+not' :: [ExpVal] -> Either String ExpVal+not' [Int i] = Right $ Int (complement i)+not' vs      = invalidArg' "not" vs++int' :: [ExpVal] -> Either String ExpVal+int' [Int  i] = Right $ Int i+int' [Real r] = Right $ Int (truncate r)+int' v@[boz@(Boz _), Int k] =+  if k `elem` [2, 4, 8] then Right $ bozToInt k boz else invalidArg' "int" v+int' vs = invalidArg' "int" vs++-- | Given a 'UnaryOp' and an 'ExpVal', either return the resulting+-- 'ExpVal' after applying the operation or a 'String' describing+-- why this couldn't be done+unaryOp' :: UnaryOp -> ExpVal -> Either String ExpVal+unaryOp' op v = case (op, v) of+  (Plus , Int a ) -> Right $ Int a+  (Plus , Real a) -> Right $ Real a+  (Minus, Int a ) -> Right $ Int (negate a)+  (Minus, Real a) -> Right $ Real (negate a)+  (Not, a) -> transformEither (Right . Logical . not) $ nonLogicalToLogical a+  _               -> invalidArg' (show op) [v]++-- | Given a 'UnaryOp' and an 'ExpVal', either return the resulting+-- 'ExpVal' after applying the operation or throw an error+unaryOp :: UnaryOp -> ExpVal -> ExpVal+unaryOp op v = case unaryOp' op v of+  Left  err  -> error err+  Right expr -> expr++-- | Given a 'BinaryOp' and two 'ExpVal's, either return the resulting+-- 'ExpVal' after applying the operation or a 'String' describing+-- why this couldn't be done+binaryOp' :: BinaryOp -> ExpVal -> ExpVal -> Either String ExpVal+binaryOp' op val1 val2 = case (op, val1, val2) of+  (Addition, Int a, Int b) -> Right $ Int (a + b)+  (Addition, Real a, Real b) -> Right $ Real (a + b)+  (Addition, Int a, Real b) -> Right $ Real (fromIntegral a + b)+  (Addition, Real a, Int b) -> Right $ Real (a + fromIntegral b)++  (Subtraction, Int a, Int b) -> Right $ Int (a - b)+  (Subtraction, Real a, Real b) -> Right $ Real (a - b)+  (Subtraction, Int a, Real b) -> Right $ Real (fromIntegral a - b)+  (Subtraction, Real a, Int b) -> Right $ Real (a - fromIntegral b)++  (Multiplication, Int a, Int b) -> Right $ Int (a * b)+  (Multiplication, Real a, Real b) -> Right $ Real (a * b)+  (Multiplication, Int a, Real b) -> Right $ Real (fromIntegral a * b)+  (Multiplication, Real a, Int b) -> Right $ Real (a * fromIntegral b)++  (Division, Int a, Int b) -> Right $ Int (div a b)+  (Division, Real a, Real b) -> Right $ Real (a / b)+  (Division, Int a, Real b) -> Right $ Real (fromIntegral a / b)+  (Division, Real a, Int b) -> Right $ Real (a / fromIntegral b)++  (Exponentiation, Int a, Int b) -> Right $ Int (a ^ b)+  (Exponentiation, Real a, Real b) -> Right $ Real (a ** b)+  (Exponentiation, Int a, Real b) -> Right $ Real (fromIntegral a ** b)+  (Exponentiation, Real a, Int b) -> Right $ Real (a ** fromIntegral b)++  (Concatenation, Str a, Str b) -> Right $ Str (a ++ b)++  (LT, Int a, Int b) -> Right $ Logical (a < b)+  (LT, Real a, Real b) -> Right $ Logical (a < b)+  (LT, Int a, Real b) -> Right $ Logical (fromIntegral a < b)+  (LT, Real a, Int b) -> Right $ Logical (a < fromIntegral b)+  (LT, a@(Boz _), b) -> binaryOp' LT (bozToInt8 a) b+  (LT, a, b@(Boz _)) -> binaryOp' LT a (bozToInt8 b)++  (EQ, Int a, Real b) -> Right $ Logical (fromIntegral a == b)+  (EQ, Real a, Int b) -> Right $ Logical (a == fromIntegral b)+  (EQ, a@(Boz _), b) -> binaryOp' EQ (bozToInt8 a) b+  (EQ, a, b@(Boz _)) -> binaryOp' EQ a (bozToInt8 b)+  (EQ, Logical True, Int b) -> Right $ Logical (1 == b)+  (EQ, Logical False, Int b) -> Right $ Logical (0 == b)+  (EQ, Int a, Logical True) -> Right $ Logical (a == 1)+  (EQ, Int a, Logical False) -> Right $ Logical (a == 0)+  (EQ, Logical True, Real b) -> Right $ Logical (1.0 == b)+  (EQ, Logical False, Real b) -> Right $ Logical (0.0 == b)+  (EQ, Real a, Logical True) -> Right $ Logical (a == 1.0)+  (EQ, Real a, Logical False) -> Right $ Logical (a == 0.0)+  (EQ, v1, v2) -> Right $ Logical (v1 == v2)+++  (GT, v1, v2) -> binaryOp' LT v2 v1+  (GTE, v1, v2) -> transformEither (unaryOp' Not) $ binaryOp' LT v2 v1+  (LTE, v1, v2) -> transformEither (unaryOp' Not) $ binaryOp' GT v2 v1++  (NE, v1, v2) -> transformEither (unaryOp' Not) $ binaryOp' EQ v1 v2++  (And, v1, v2) ->+    binaryTransformEither (\x -> Right . Logical . (x &&))+                          (nonLogicalToLogical v1)+      $ nonLogicalToLogical v2++  (Or, v1, v2) ->+    binaryTransformEither (\x -> Right . Logical . (x ||))+                          (nonLogicalToLogical v1)+      $ nonLogicalToLogical v2++  (XOr, Logical a, Logical b) -> Right $ Logical (a /= b)+  (Equivalent, Logical a, Logical b) -> Right $ Logical (a == b)+  (NotEquivalent, Logical a, Logical b) -> Right $ Logical (a /= b)+  _ -> invalidArg' (show op) [val1, val2]++-- | Given a 'BinaryOp' and two 'ExpVal's, either return the resulting+-- 'ExpVal' after applying the operation or throw an error+binaryOp :: BinaryOp -> ExpVal -> ExpVal -> ExpVal+binaryOp op val1 val2 = case binaryOp' op val1 val2 of+  Left  err  -> error err+  Right expr -> expr
+ src/Language/Fortran/Vars/PureExpression.hs view
@@ -0,0 +1,58 @@+module Language.Fortran.Vars.PureExpression+  ( isPureExpression+  )+where+import           Data.Maybe                     ( catMaybes )++import           Language.Fortran.AST           ( Expression(..)+                                                , Index(..)+                                                , Value(..)+                                                , aStrip+                                                )+import           Language.Fortran.Vars.Call+                                                ( functionArguments )++-- | Given an 'Expression', determine whether it is a pure expression. +-- A pure expression does not have side effect.+-- return true if the expression is guaranteed to be pure,+-- return false if the expression can not be guaranteed to be pure. +isPureExpression :: Expression a -> Bool+isPureExpression (ExpValue _ _ v) = isPureValue v+isPureExpression (ExpBinary _ _ _ e1 e2) =+  isPureExpression e1 && isPureExpression e2+isPureExpression (ExpUnary _ _ _ e) = isPureExpression e+isPureExpression (ExpSubscript _ _ _ indices) =+  all isPureIndex (aStrip indices)+isPureExpression e@ExpFunctionCall{} =+  isIntrinsicFunctionCall e && all isPureExpression (functionArguments e)+isPureExpression (ExpInitialisation _ _ exprs) =+  all isPureExpression (aStrip exprs)+isPureExpression ExpReturnSpec{} = False+isPureExpression ExpImpliedDo{}  = False+isPureExpression ExpDataRef{}    = False+++-- | Given a 'Value', determine whether it is pure+isPureValue :: Value a -> Bool+isPureValue ValInteger{}       = True+isPureValue ValReal{}          = True+isPureValue (ValComplex e1 e2) = isPureExpression e1 && isPureExpression e2+isPureValue ValString{}        = True+isPureValue ValHollerith{}     = True+isPureValue ValVariable{}      = True+isPureValue ValIntrinsic{}     = True+isPureValue ValLogical{}       = True+isPureValue ValStar            = True+isPureValue _                  = False++-- | Given an 'Index', determine whether it is pure+isPureIndex :: Index a -> Bool+isPureIndex (IxSingle _ _ _ e) = isPureExpression e+isPureIndex (IxRange _ _ me1 me2 me3) =+  all isPureExpression $ catMaybes [me1, me2, me3]++-- | Given an expression determine whether it is intrinsic function call+isIntrinsicFunctionCall :: Expression a -> Bool+isIntrinsicFunctionCall (ExpFunctionCall _ _ (ExpValue _ _ (ValIntrinsic _)) _)+  = True+isIntrinsicFunctionCall _ = False
+ src/Language/Fortran/Vars/Range.hs view
@@ -0,0 +1,18 @@+module Language.Fortran.Vars.Range+  ( Range+  , overlap+  , anyOverlap+  )+where++-- | Inclusive range used to represent a piece of memory+type Range = (Int, Int)   -- ^ (start, end)++-- | Return True if two ranges have overlap+overlap :: Range -> Range -> Bool+overlap (s1, e1) (s2, e2) = s1 <= e2 && s2 <= e1++-- | Return True if a given 'Range' overlaps any 'Range' in the+-- provided list+anyOverlap :: Range -> [Range] -> Bool+anyOverlap range = any (overlap range)
+ src/Language/Fortran/Vars/StorageClass.hs view
@@ -0,0 +1,62 @@+module Language.Fortran.Vars.StorageClass+  ( processStorageClass+  )+where++import           Data.Data                      ( Data )+import           Data.List                      ( foldl' )+import qualified Data.Map                      as M+import           Language.Fortran.Analysis      ( Analysis+                                                , srcName+                                                )+import           Language.Fortran.AST           ( aStrip+                                                , Declarator(..)+                                                , Expression(..)+                                                , Name+                                                , Statement(..)+                                                , Value(..)+                                                )++import           Language.Fortran.Vars.Types+                                                ( SymbolTableEntry(..)+                                                , MemoryBlock(..)+                                                , ProgramUnitModel+                                                , StorageClass(..)+                                                )++storageClassStmt+  :: Data a => ProgramUnitModel -> Statement (Analysis a) -> ProgramUnitModel+storageClassStmt puModel (StAutomatic _ _ decls) = foldl' f+                                                          puModel+                                                          (aStrip decls)+ where+  f m (DeclVariable _ _ varExp _ _) =+    updateStorageClass (srcName varExp) Automatic m+  f m (DeclArray _ _ varExp _ _ _) =+    updateStorageClass (srcName varExp) Automatic m+storageClassStmt puModel (StSave _ _ (Just exps)) = foldl' f+                                                           puModel+                                                           (aStrip exps)+ where+  f m e@(ExpValue _ _ (ValVariable _)) =+    updateStorageClass (srcName e) Static m+  f m _ = m+storageClassStmt puModel _ = puModel++updateStorageClass+  :: Name -> StorageClass -> ProgramUnitModel -> ProgramUnitModel+updateStorageClass symbol stClass m@(symTable, storageTable) =+  case M.lookup symbol symTable of+    Just (SVariable _ (blockName, _)) ->+      case M.lookup blockName storageTable of+        Just block | storageClass block /= stClass ->+          let blk = block { storageClass = stClass }+          in  (symTable, M.insert blockName blk storageTable)+        _ -> m+    _ -> m++-- | Given all of the 'Statement's in a program as well as a 'ProgramUnitModel', produce a new+-- 'ProgramUnitModel' where the 'StorageClass's of each symbol have been determined+processStorageClass+  :: Data a => [Statement (Analysis a)] -> ProgramUnitModel -> ProgramUnitModel+processStorageClass stmts puModel0 = foldl' storageClassStmt puModel0 stmts
+ src/Language/Fortran/Vars/StructureTable.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Language.Fortran.Vars.StructureTable+  ( StructureTable+  , StructureTableEntry(..)+  , collectStructures+  , lookupField+  , hasEntry+  , programStructureTables+  )+where++import           Data.Data                      ( Data )+import           Data.Maybe                     ( mapMaybe )+import qualified Data.Map                      as M+import           Data.List                      ( foldl' )++import           Language.Fortran.Analysis      ( Analysis+                                                , puName+                                                )+import           Language.Fortran.AST           ( Statement(..)+                                                , StructureItem(..)+                                                , UnionMap(..)+                                                , Expression(..)+                                                , Value(..)+                                                , ProgramUnit(..)+                                                , ProgramFile+                                                , TypeSpec(..)+                                                , Declarator(..)+                                                , aStrip+                                                )+import           Language.Fortran.Extras+                                                ( allPUS+                                                , allPU+                                                )++import           Language.Fortran.Vars.SymbolTable+                                                ( collectSymbols )+import           Language.Fortran.Vars.Types+                                                ( SymbolTable+                                                , StructureTableEntry(..)+                                                , Structure+                                                , StructureTable+                                                , ProgramStructureTables+                                                , Type(..)+                                                , SemType(..)+                                                , TypeError(..)+                                                )+import           Language.Fortran.Vars.Utils+                                                ( typeSpecToArrayType+                                                , typeSpecToScalarType+                                                )++-- | Given a `SymbolTable` transform `StructureItem`s found in the AST into a list of+-- `StructureTableEntry`s+itemToEntry+  :: SymbolTable -> StructureItem (Analysis a) -> [StructureTableEntry]+itemToEntry st (StructFields _ _ ty _ decls) =+  mapMaybe (handleDeclarator st ty) (aStrip decls)+itemToEntry st (StructUnion _ _ l) = [UnionEntry $ handleUnion st <$> aStrip l]+itemToEntry _  StructStructure{}   = []++-- TODO take into account length, should override default typespecs+-- | Given the `TypeSpec` and `Declerator` found in a field entry create a+-- `StructureTableEntry`+handleDeclarator+  :: SymbolTable+  -> TypeSpec (Analysis a)+  -> Declarator (Analysis a)+  -> Maybe StructureTableEntry+handleDeclarator st ty (DeclVariable _ _ expr _ _) =+  let scalarTy = typeSpecToScalarType st ty+  in  expToName expr >>= \name -> Just $ FieldEntry name scalarTy+handleDeclarator st ty (DeclArray _ _ expr dims _ _) =+  let arrayty = typeSpecToArrayType st (aStrip dims) ty+  in  expToName expr >>= \name -> Just $ FieldEntry name arrayty++-- | Transform a `UnionMap` in an AST to `StructureTableEntry`s+handleUnion :: SymbolTable -> UnionMap (Analysis a) -> [StructureTableEntry]+handleUnion st (UnionMap _ _ si) = concatMap (itemToEntry st) $ aStrip si++-- | Given an `Expression` maybe get the name+expToName :: Expression a -> Maybe String+expToName (ExpValue _ _ (ValVariable name)) = Just name+expToName _ = Nothing++-- | Collect structures defined in a `ProgramUnit` and return a `StructureTable`+collectStructures+  :: Data a => SymbolTable -> ProgramUnit (Analysis a) -> StructureTable+collectStructures st pu =+  M.foldlWithKey' handler M.empty+    . M.fromList+    $ [ (n, aStrip s) | (StStructure _ _ (Just n) s) <- allPUS pu ]+ where+  handler structTable name entry =+    M.insert name (concatMap (itemToEntry st) entry) structTable++-- | Look up reference on a type to return another `Type`+lookupField :: StructureTable -> Type -> String -> Either TypeError Type+lookupField structTable ty ref = case ty of+  TCustom tyName -> case M.lookup tyName structTable of+    Just struct -> hasEntry ref struct+    Nothing     -> Left . UnknownField $ ref <> " not a field of " <> tyName+  ty' -> Left . UnknownField $ "No fields for data type (" <> show ty' <> ")"++-- | Given a name, check that a `Structure` contains it once and return its+-- corresponding `Type`+hasEntry :: String -> Structure -> Either TypeError Type+hasEntry name struct =+  let unionStructs = concat [ concat structs | (UnionEntry structs) <- struct ]+  in+    case+      [ ty | (FieldEntry fname ty) <- struct <> unionStructs, fname == name ]+    of+      [ty] -> Right ty+      []   -> Left . UnknownField $ name <> " is not a field"+      _ ->+        Left+          .  UnknownField+          $  "Field "+          <> name+          <> " define multiple times for structure"++-- | Given a 'ProgramFile', generate a 'StructureTable' for each 'ProgramUnit'.+-- This can be used to check types in data reference expressions+programStructureTables+  :: Data a => ProgramFile (Analysis a) -> ProgramStructureTables+programStructureTables pf = foldl' handler M.empty $ allPU pf+ where+  handler m pu = M.insert (puName pu) (puStructure pu) m+  puStructure pu = let st = collectSymbols pu in collectStructures st pu
+ src/Language/Fortran/Vars/SymbolTable.hs view
@@ -0,0 +1,408 @@+module Language.Fortran.Vars.SymbolTable+  ( collectSymbols+  )+where++import           Data.Data                      ( Data+                                                , toConstr+                                                )+import           Data.List                      ( foldl' )+import qualified Data.Map                      as M+import           Language.Fortran.Analysis      ( Analysis+                                                , srcName+                                                )+import           Language.Fortran.AST           ( AList+                                                , Argument(..)+                                                , aStrip+                                                , BaseType(..)+                                                , Block(..)+                                                , CommonGroup(..)+                                                , Declarator(..)+                                                , DimensionDeclarator(..)+                                                , Expression(..)+                                                , Index(..)+                                                , Name+                                                , ProgramUnit(..)+                                                , programUnitBody+                                                , Statement(..)+                                                , Selector(..)+                                                , TypeSpec(..)+                                                , Value(..)+                                                )++import           Language.Fortran.Vars.Eval+                                                ( eval+                                                , eval'+                                                )+import           Language.Fortran.Vars.BozConstant+                                                ( resolveBozConstant )+import           Language.Fortran.Vars.Types+                                                ( ExpVal(..)+                                                , SymbolTableEntry(..)+                                                , Type(..)+                                                , SemType(..)+                                                , CharacterLen(..)+                                                , SymbolTable+                                                )+import           Language.Fortran.Vars.Utils+                                                ( typeSpecToScalarType+                                                , typeSpecToArrayType+                                                )+import           Language.Fortran.Vars.Kind+                                                ( getKind+                                                , getTypeKind+                                                , setTypeKind+                                                , getKindOfExpVal+                                                , toInt+                                                , typeOfExpVal+                                                , baseToType+                                                , isStr+                                                )++-- | Given a 'SymbolTable' and a 'DimensionDeclarator', return a pair of+-- resolved 'DynamicDimensionElement's representing lower- and upper- bound+resolveDimensionDimensionDeclarator+  :: SymbolTable -> DimensionDeclarator (Analysis a) -> Maybe (Int, Int)+resolveDimensionDimensionDeclarator symTable (DimensionDeclarator _ _ lowerbound upperbound)+  = do+    lb <- valueOf lowerbound+    ub <- valueOf upperbound+    pure (lb, ub)+ where+  valueOf (Just (ExpValue _ _ ValStar)) = Nothing+  valueOf (Just (ExpValue _ _ (ValVariable name))) =+    case M.lookup name symTable of+      Just (SParameter _ (Int i)) -> Just i+      _                           -> Nothing+  valueOf (Just expr) = case eval' symTable expr of+    Right (Int i) -> Just i+    _             -> Nothing+  valueOf Nothing = Just 1++-- | Given a 'SymbolTable' and an 'Index', return a pair of+-- resolved 'DynamicDimensionElement's representing lower- and upper- bound+resolveDimensionExpSubscript+  :: SymbolTable -> Index (Analysis a) -> Maybe (Int, Int)+resolveDimensionExpSubscript symTable index = case index of+  IxSingle _ _ _ upperbound -> do+    ub <- valueOf upperbound+    pure (1, ub)+  IxRange _ _ lowerbound upperbound _ -> do+    lb <- lowerbound >>= valueOf+    ub <- upperbound >>= valueOf+    pure (lb, ub)+ where+  valueOf expr = case eval' symTable expr of+    Right (Int i) -> Just i+    _             -> Nothing++-- | Given a 'SymbolTable' and an 'Argument', return a maybe pair of Ints+-- representing lower- and upper- bound+resolveDimensionExpFunctionCall+  :: SymbolTable -> Argument (Analysis a) -> Maybe (Int, Int)+resolveDimensionExpFunctionCall symTable (Argument _ _ _ upperbound) =+  let ub = toInt (eval symTable upperbound) in Just (1, ub)++-- Parameter declarations+-- A parameter may or may not have a type declaration. If it does have one,+-- the declaration statement can go before or after the parameter statement.+handleParameter+  :: Data a => SymbolTable -> AList Declarator (Analysis a) -> SymbolTable+handleParameter symTable alist = foldl' f symTable (aStrip alist)+ where+  f symt (DeclVariable _ _ varExp _ (Just valExp)) =+    let symbol = srcName varExp+        val'   = case eval symt valExp of+          boz@(Boz _) -> resolveBozConstant symTable symbol boz+          v           -> v+        kind' = getKindOfExpVal val'   -- infer kind from value+        pd'   = SParameter (setTypeKind (typeOfExpVal val') (Just kind')) val'+        entry = case M.lookup symbol symt of+                 -- Entry found implies there is a preceding declaration+                 -- of the name. +                 -- If that is variable declaration, keep the accurate type+                 -- and kind informatio from the declaration.+                 -- Else if it is dummy variable, keep the accurate type +                 -- and update kind+                 -- Else raise error for conflicting parameter attribute+                 -- Parameter name does not necessarily have a type+                 -- declaration or a kind is assumed. In that case type+                 -- and kind are inferred from the value of parameter.+          Nothing               -> pd'+          Just (SVariable ty _) -> case ty of+            -- TODO previously TCharacter Nothing+            TCharacter CharLenStar _ -> pd'+            _                        -> SParameter ty val'+          Just SDummy{} | isStr val' -> pd'+          Just _ ->+            let errStr t =+                    "Invalid PARAMETER statement for symbol \'" ++ t ++ "\'"+            in  error $ errStr symbol+    in  M.insert symbol entry symt+  f symt _ = symt++handleDeclaration+  :: Data a+  => SymbolTable+  -> TypeSpec (Analysis a)+  -> AList Declarator (Analysis a)+  -> SymbolTable+handleDeclaration symTable typespec decls = foldl' f symTable (aStrip decls)+ where+  (TypeSpec _ _ bt selector) = typespec+  handleVarStar symbol symt ty' =+    let+      entry = case M.lookup symbol symt of+        -- Entry found implies the name also appears in a+        -- preceding parameter statement. In case of ValStar+        -- selector, only type is updated.+        Just (SParameter _ val) -> SParameter ty' val+        Just _                  -> error+          (symbol+          ++ "is not a parameter. \+               \Only ParameterEntries are expected at this point."+          )+        Nothing -> SVariable (TCharacter CharLenStar 1) (symbol, 0)+    in  M.insert symbol entry symt+  -- don't care initial value at this moment+  f symt (DeclVariable _ s varExp charLength _) =+    let+      symbol = srcName varExp+      ty'    = baseToType bt+    in+      case (selector, charLength) of+        (Just (Selector _ _ (Just (ExpValue _ _ ValStar)) _), Nothing) ->+          handleVarStar symbol symt ty'+        (_, Just (ExpValue _ _ ValStar)) -> handleVarStar symbol symt ty'+        _ ->+          let+            kind' = getKind symt typespec charLength+            ty''  = setTypeKind ty' kind'+            entry = case M.lookup symbol symt of+              -- Entry found implies the name also appears in a+              -- preceding parameter statement or that the entry+              -- has already been defined. In the case of parameter+              -- only type and kind are updated, and the type and+              -- kind are checked in the case of already defined.+              Just (SParameter _ val) -> SParameter ty'' val+              Just (SVariable (TArray _ dims) loc) ->+                SVariable (TArray ty' dims) loc+              Just v@(SVariable ty loc) ->+                let errStr =+                        "The second declaration of '"+                          ++ symbol+                          ++ "' at line "+                          ++ show s+                          ++ " does not have the same type as the first"+                in  if toConstr ty' /= toConstr ty+                      then error errStr+                      else+                        let mk = getTypeKind ty'+                        in  if mk /= getTypeKind ty+                              then SVariable ty'' loc+                              else v+              Just _ -> error+                (symbol+                ++ " is not a parameter nor array-type variable.\+                                         \ Invalid Fortran syntax at "+                ++ show s+                )+              Nothing -> SVariable ty'' (symbol, 0)+          in+            M.insert symbol entry symt+  f symt (DeclArray _ _ varExp dimDecls charLength _) =+    let+      symbol = srcName varExp+      entry  = case charLength of+        Just (ExpValue _ _ ValStar) ->+          SVariable (TArray (TCharacter CharLenStar 1) Nothing) (symbol, 0)+        _ ->+          let+            kd   = getKind symt typespec charLength+            dims = traverse (resolveDimensionDimensionDeclarator symt)+                            (aStrip dimDecls)+            ty = setTypeKind (baseToType bt) kd+          in+            SVariable (TArray ty dims) (symbol, 0)+    in+      M.insert symbol entry symt++updateDimensionDimensionDeclarator+  :: Name+  -> AList DimensionDeclarator (Analysis a)+  -> SymbolTable+  -> SymbolTable+updateDimensionDimensionDeclarator symbol dimDecls symTable =+  case M.lookup symbol symTable of+    Just (SVariable TArray{} _) -> error+      (symbol+      ++ "is array-typed Varible. \+                 \Invalid fortran syntax (Duplicate DIMENSION attribute)"+      )+    Just (SVariable ty loc) ->+      let mdims = traverse (resolveDimensionDimensionDeclarator symTable)+                           (aStrip dimDecls)+          entry = SVariable (TArray ty mdims) loc+      in  M.insert symbol entry symTable+    _ -> symTable++handleDimension+  :: Data a => SymbolTable -> AList Declarator (Analysis a) -> SymbolTable+handleDimension symTable decls = foldl' f symTable (aStrip decls)+ where+  f symt (DeclArray _ _ varExp dimDecls _ _) =+    updateDimensionDimensionDeclarator (srcName varExp) dimDecls symt+  f symt _ = symt++-- | Given symbol, list of Arguments and SymbolTable, it updates the relevant+-- variable in the SymbolTable to become an array with dimensions described by+-- the list of Arguments.+--+-- This function is needed to handle dimensions specifications within COMMONs,+-- because fortran-src doesn't support 'DimensionDeclarator's within COMMON blocks.+updateDimensionExpFunctionCall+  :: Name -> AList Argument (Analysis a) -> SymbolTable -> SymbolTable+updateDimensionExpFunctionCall symbol args symTable =+  case M.lookup symbol symTable of+    Just (SVariable TArray{} _) -> error+      (symbol+      ++ " is array-typed VaribleEntry. \+                 \Invalid fortran syntax (Duplicate DIMENSION attribute)"+      )+    Just (SVariable std loc) ->+      let dims =+              traverse (resolveDimensionExpFunctionCall symTable) (aStrip args)+          entry = SVariable (TArray std dims) loc+      in  M.insert symbol entry symTable+    Just (SDummy _) -> error+      (symbol+      ++ " is DummyVariableEntry. \+                 \Invalid fortran syntax (Dummy in COMMON dimension declaration)"+      )+    Nothing ->+      let dims =+              traverse (resolveDimensionExpFunctionCall symTable) (aStrip args)+          -- Set default kind; there is no way to know it at this point+          entry = SVariable (TArray (TInteger 4) dims) (symbol, 0)+      in  M.insert symbol entry symTable+    _ -> error+      (symbol+      ++ " was found in SymbolTable. This case is not possible, \+                 \because ExpFunctionCall as dimension declarator can only occur for \+                 \variables that occur after COMMON block in the code"+      )++-- | Given symbol, list of Indices and SymbolTable, it updates the relevant+-- variable in the SymbolTable to become an array with dimensions described by+-- the list of Indices.+--+-- This function is needed to handle dimensions specifications within COMMONs,+-- because fortran-src doesn't support 'DimensionDeclarator's within COMMON blocks.+updateDimensionExpSubscript+  :: Name -> AList Index (Analysis a) -> SymbolTable -> SymbolTable+updateDimensionExpSubscript symbol indices symTable =+  case M.lookup symbol symTable of+    Just (SVariable TArray{} _) -> error+      (symbol+      ++ " is array-typed VaribleEntry. \+                 \Invalid fortran syntax (Duplicate DIMENSION attribute)"+      )+    Just (SVariable std loc) ->+      let dims =+              traverse (resolveDimensionExpSubscript symTable) (aStrip indices)+          entry = SVariable (TArray std dims) loc+      in  M.insert symbol entry symTable+    Just (SDummy _) -> error+      (symbol+      ++ " is DummyVariableEntry. \+                 \Invalid fortran syntax (Dummy in COMMON dimension declaration)"+      )+    Nothing ->+      let dims =+              traverse (resolveDimensionExpSubscript symTable) (aStrip indices)+          -- Set default kind; there is no way to know it at this point+          entry = SVariable (TArray (TInteger 4) dims) (symbol, 0)+      in  M.insert symbol entry symTable+    _ -> error "Invalid fortran syntax"++handleCommon+  :: Data a => SymbolTable -> AList CommonGroup (Analysis a) -> SymbolTable+handleCommon symTable alist = foldl' f symTable (aStrip alist)+ where+  f symt (CommonGroup _ _ _ alist2) = foldl' f2 symt (aStrip alist2)+   where+    f2 symt2 (ExpFunctionCall _ _ varExp (Just alist3)) =+      updateDimensionExpFunctionCall (srcName varExp) alist3 symt2+    f2 symt2 (ExpSubscript _ _ varExp alist3) =+      updateDimensionExpSubscript (srcName varExp) alist3 symt2+    f2 symt2 _ = symt2++-- | Given a 'SymbolTable' and a 'Statement' found in a 'ProgramUnit', return a new 'SymbolTable'+-- with any newly defined symbols+stSymbols :: Data a => SymbolTable -> Statement (Analysis a) -> SymbolTable+stSymbols symTable (StParameter _ _ alist) = handleParameter symTable alist+stSymbols symTable (StDeclaration _ _ typespec _ decls) =+  handleDeclaration symTable typespec decls+stSymbols symTable (StDimension _ _ decls     ) = handleDimension symTable decls+stSymbols symTable (StCommon    _ _ alist     ) = handleCommon symTable alist+stSymbols symTable (StInclude _ _ _ (Just bls)) = foldl' blSymbols symTable bls+stSymbols symTable _                            = symTable++-- | Given a 'Bool', 'SymbolTable' and a 'ProgramUnit', return an updated+-- 'SymbolTable' containing symbols defined in 'ProgramUnit' signature, e.g.+--   integer function fname() -> symbol table containing 'fname'+-- The first argument flags whether to traverse declarations for the function return+-- type, allowing us to avoid traversing the top level program unit twice+puSymbols+  :: Data a => Bool -> SymbolTable -> ProgramUnit (Analysis a) -> SymbolTable+puSymbols _ symt (PUFunction _ _ (Just typespec) _ symbol _ _ _ _) =+  let entryType = typeSpecToScalarType symt typespec+      entryLoc  = (symbol, 0)+      entry     = SVariable entryType entryLoc+  in  M.insert symbol entry symt+puSymbols getDecls symt (PUFunction _ _ Nothing _ symbol _ _ bls _) =+  if getDecls then foldl' handler symt bls else symt+ where+  handler symt' (BlStatement _ _ _ (StDeclaration _ _ typespec _ decls)) =+    let mty = declToType symt' symbol typespec $ aStrip decls+    in  case mty of+          Just ty ->+            let entryLoc = (symbol, 0)+                entry    = SVariable ty entryLoc+            in  M.insert symbol entry symt'+          Nothing -> symt'+  handler symt' _ = symt'+puSymbols _ symt _ = symt++-- | Given a TypeSpec and list of Declarators, search for a name in that list+-- and return the resolved type if there+declToType+  :: SymbolTable+  -> Name+  -> TypeSpec (Analysis a)+  -> [Declarator (Analysis a)]+  -> Maybe Type+declToType symt name tyspec (d : ds) = if name == getName d+  then Just $ toType d+  else declToType symt name tyspec ds+ where+  getName (DeclArray _ _ (ExpValue _ _ (ValVariable str)) _ _ _) = str+  getName (DeclVariable _ _ (ExpValue _ _ (ValVariable str)) _ _) = str+  getName _ = error "Unexpected declaration expression"+  toType (DeclArray _ _ _ dims _ _) =+    typeSpecToArrayType symt (aStrip dims) tyspec+  toType DeclVariable{} = typeSpecToScalarType symt tyspec+declToType _ _ _ [] = Nothing++-- | Update SymbolTable for a given block, traverse statements to get+-- declarations and interfaces to get function signatures.+blSymbols :: Data a => SymbolTable -> Block (Analysis a) -> SymbolTable+blSymbols symt (BlStatement _ _ _ st     ) = stSymbols symt st+blSymbols symt (BlInterface _ _ _ _ pus _) = foldl' (puSymbols True) symt pus+blSymbols symt _                           = symt++-- | Given a 'ProgramUnit', generate a 'SymbolTable' for all of the non-intrisic symbols+collectSymbols :: Data a => ProgramUnit (Analysis a) -> SymbolTable+collectSymbols pu =+  let puSignatureSymbols = puSymbols False M.empty pu+  in  foldl' blSymbols puSignatureSymbols $ programUnitBody pu
+ src/Language/Fortran/Vars/TypeCheck.hs view
@@ -0,0 +1,334 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TypeApplications #-}++module Language.Fortran.Vars.TypeCheck+  ( Kind+  , TypeError(..)+  , TypeOf+  , typeOf+  )+where+import           Prelude                 hiding ( GT+                                                , EQ+                                                , LT+                                                )+import qualified Data.Map                      as M+import           Data.Char                      ( toUpper )+import           Data.Data                      ( toConstr )+import           Data.Maybe                     ( fromJust )+import           Text.Read                      ( readMaybe )+import           Language.Fortran.AST           ( Expression(..)+                                                , Value(..)+                                                , AList(..)+                                                , aStrip+                                                , aStrip'+                                                , Argument(..)+                                                , DoSpecification(..)+                                                , Statement(..)+                                                , Name+                                                , BinaryOp(..)+                                                , Index(..)+                                                )+import           Language.Fortran.Intrinsics    ( getVersionIntrinsics+                                                , getIntrinsicReturnType+                                                , IntrinsicType(..)+                                                )+import           Language.Fortran.ParserMonad   ( FortranVersion(..) )++import           Language.Fortran.Util.Position ( SrcSpan+                                                , getSpan+                                                )+import           Language.Fortran.Vars.Types+                                                ( SymbolTableEntry(..)+                                                , ExpVal(..)+                                                , SymbolTable+                                                , StructureTable+                                                , Kind+                                                , Type(..)+                                                , SemType(..)+                                                , CharacterLen(..)+                                                , TypeError(..)+                                                , TypeOf+                                                , typeError+                                                )+import           Language.Fortran.Vars.Kind+                                                ( getTypeKind+                                                , setTypeKind+                                                )+import           Language.Fortran.Vars.Eval+                                                ( eval' )+import           Language.Fortran.Vars.StructureTable+                                                ( lookupField )++import           Language.Fortran.Analysis.SemanticTypes+                                                ( charLenConcat )+++-- | Given 'SymbolTable' of a 'ProgramUnit', and an 'Expression' within+-- the 'ProgramUnit', determines the 'Type' of the 'Exression'+typeOf :: StructureTable -> SymbolTable -> Expression a -> Either TypeError Type+typeOf strTable symTable expr = case expr of+  ExpValue _ _ (ValVariable name) -> typeOfSymbol symTable name+  ExpValue _ s val                -> typeOfValue s strTable symTable val+  ExpUnary _ _ _ e                -> typeOf strTable symTable e+  ExpBinary _ s op e1 e2 -> typeOfBinaryExp s strTable symTable op e1 e2+  ExpFunctionCall _ _ (ExpValue _ s (ValVariable name)) margs ->+    typeOfFunctionCall s strTable symTable name (aStrip' margs)+  ExpFunctionCall _ _ (ExpValue _ s (ValIntrinsic name)) margs ->+    typeOfFunctionCall s strTable symTable name (aStrip' margs)+  ExpSubscript _ s arr (AList _ _ args@(IxSingle{} : _)) ->+    let isIxRange = \case+          IxRange{} -> True+          _         -> False+    in  if any isIxRange args+          then Left . typeError s $ "Unexpected array range"+          else case typeOf strTable symTable arr of+            Right (TArray ty _) -> Right ty+            Right _ ->+              Left . typeError s $ "Tried to access elements of scalar"+            err -> err+  ExpSubscript _ s arr (AList _ _ (r@IxRange{} : _)) -> do+    ty <- typeOf strTable symTable arr+    case ty of+      TCharacter _ _ -> typeOfSubString s symTable strTable ty r+      _              -> Right ty+  ExpImpliedDo _ _ es doSpec -> do+    dim <- specToDim symTable doSpec+    ty  <- typeOf strTable symTable . head $ aStrip es+    pure $ case ty of+      TArray ty' (Just [(1, dim')]) -> TArray ty' (Just [(1, dim * dim')])+      TArray _ _ -> error "Unexpected array type in implied do"+      _ -> TArray ty (Just [(1, dim)])++  ExpDataRef _ _ es (ExpValue _ _ (ValVariable name)) -> do+    ty <- typeOf strTable symTable es+    lookupField strTable ty name+  _ -> Left . UnknownType $ getSpan expr++-- | Internal function to get array size out of a DoSpecification+specToDim :: SymbolTable -> DoSpecification a -> Either TypeError Int+specToDim symt (DoSpecification _ s (StExpressionAssign _ _ _ start) end step)+  = let evalInt x = case eval' symt x of+          Right (Int y) -> Right y+          Right _ -> Left . typeError s $ "non int value in do spec " <> show s+          Left err -> Left . typeError s $ err+    in  do+          start' <- evalInt start+          end'   <- evalInt end+          case step of+            Just x -> do+              step' <- evalInt x+              pure $ ((end' - start') `div` step') + 1+            Nothing -> pure $ (end' - start') + 1+specToDim _ _ = error "Unexpected do specification structure"++-- | Internal function to determine the 'Type' of a symbol+typeOfSymbol :: SymbolTable -> Name -> Either TypeError Type+typeOfSymbol symTable name = case M.lookup name symTable of+  Just entry -> case entry of+    SParameter t _ -> Right t+    SVariable  t _ -> Right t+    SDummy    t    -> Right t+    SExternal t    -> Right t+  Nothing -> Left $ UnboundVariable name++-- | Internal function to determine the 'Type' of a constant+typeOfValue+  :: SrcSpan+  -> StructureTable+  -> SymbolTable+  -> Value a+  -> Either TypeError Type+typeOfValue sp strTable symTable v = case v of+  ValInteger i -> case readMaybe @Int i of+    Just _  -> Right $ TInteger 4+    Nothing -> Right $ TByte 4+  ValReal r | 'D' `elem` map toUpper r -> Right (TReal 8)+            | otherwise                -> Right (TReal 4)+  ValComplex real imaginary -> do+    tr <- typeOf strTable symTable real+    ti <- typeOf strTable symTable imaginary+    if tr == TReal 8 || ti == TReal 8+      then return (TComplex 16)+      else return (TComplex 8)+  ValString    s -> Right $ TCharacter (CharLenInt (length s)) 1+  ValHollerith s -> Right . TByte $ length s+  ValLogical   _ -> Right $ TLogical 4+  _              -> Left $ UnknownType sp+++promote :: Type -> Type -> Type+promote t1 t2+  | toConstr t1 == toConstr t2 = case+      max <$> getTypeKind t1 <*> getTypeKind t2+    of+      Just k -> setTypeKind t1 $ Just k+      Nothing ->+        error+          $  "dynamic type in promotion between: "+          <> show t1+          <> " and "+          <> show t2+  | otherwise = case (t1, t2) of+    (TComplex k , _          ) -> TComplex k+    (_          , TComplex k ) -> TComplex k+    (TReal k    , _          ) -> TReal k+    (_          , TReal k    ) -> TReal k+    (TLogical k1, TInteger k2) -> TInteger $ max k1 k2+    (TInteger k1, TLogical k2) -> TInteger $ max k1 k2+    (TInteger k , _          ) -> TInteger k+    (_          , TInteger k ) -> TInteger k+    (TLogical k , _          ) -> TLogical k+    (_          , TLogical k ) -> TLogical k+    _ -> error $ "Incompatible types: " <> show t1 <> " " <> show t2++-- | Internal function fo determine type of binary expression+typeOfBinaryExp+  :: SrcSpan+  -> StructureTable+  -> SymbolTable+  -> BinaryOp+  -> Expression a+  -> Expression a+  -> Either TypeError Type+typeOfBinaryExp sp strTable symTable op e1 e2+  |+  -- Relational+    op `elem` [GT, GTE, LT, LTE, EQ, NE] = Right (TLogical 4)+  | otherwise = do+    st1 <- typeOf strTable symTable e1+    st2 <- typeOf strTable symTable e2+    typeOfBinaryExp' sp op st1 st2++-- | Internal funciton for determining type of binary expression.+typeOfBinaryExp' :: SrcSpan -> BinaryOp -> Type -> Type -> Either TypeError Type+typeOfBinaryExp' sp op t1 t2+  |+  -- Character+    op == Concatenation+  -- TODO+  -- = Right . TCharacter $ (+) <$> k1 <*> k2+  = case t1 of+      TCharacter l1 k1 ->+        case t2 of+          TCharacter l2 k2 -> Right $ TCharacter (charLenConcat l1 l2) k1+          _ -> error "shit 1"+      _ -> error "shit 2"+  |+  -- Logical+    op `elem` [And, Or, Equivalent, NotEquivalent, XOr]+  = Right . TLogical . fromJust $ max <$> k1 <*> k2+  |+  -- Arithmetic+    op `elem` [Addition, Subtraction, Multiplication, Division, Exponentiation]+  = Right $ promote t1 t2+  | otherwise+  = Left $ UnknownType sp+ where+  k1 = getTypeKind t1+  k2 = getTypeKind t2+++-- | Internal function to determine the type of a substring+-- If either of the indexes cannot be evaluated then we return a dynamically+-- sized character type+-- TODO this is the worst one+typeOfSubString+  :: SrcSpan+  -> SymbolTable+  -> StructureTable+  -> Type+  -> Index a+  -> Either TypeError Type+typeOfSubString sp symt strt ty (IxRange _ _ lower upper _) = do+  isInteger $ traverse (typeOf strt symt) lower+  isInteger $ traverse (typeOf strt symt) upper+  pure $ TCharacter calcLen 1+ where+  calcLen =+      case (\x y -> y - x + 1) <$> lowerIndex <*> upperIndex of+        Nothing  -> CharLenStar+        Just len -> CharLenInt len+  isInteger = \case+    Right (Just (TInteger _)) -> Right ()+    Right Nothing -> Right ()+    _ -> Left . typeError sp $ "Index  wasn't an integer type"+  upperIndex = let Just k = getTypeKind ty in getIndex k upper+  lowerIndex = getIndex 1 lower+  getIndex :: Int -> Maybe (Expression a) -> Maybe Int+  getIndex dflt Nothing  = Just dflt+  getIndex _    (Just e) = case eval' symt e of+    Right (Int i) -> Just i+    _             -> Nothing++typeOfSubString _ _ _ _ idx = Left $ UnknownType (getSpan idx)++-- | determine the return type of a function call+typeOfFunctionCall+  :: SrcSpan+  -> StructureTable+  -> SymbolTable+  -> Name+  -> [Argument a]+  -> Either TypeError Type+typeOfFunctionCall sp strT symT name argList =+  checkIntrinsicFunction <> checkF77IntrinsicFunction <> checkExternalFunction+ where+  args = [ e | Argument _ _ _ e <- argList ]+  -- If the function is any of the intrinsics below, determine its return type+  -- accordingly+  checkIntrinsicFunction :: Either TypeError Type+  checkIntrinsicFunction+    | name `elem` ["int", "nint"], length args == 1 = Right (TInteger 4)+    | name `elem` ["int", "nint"], length args == 2 = case+        eval' symT (args !! 1)+      of+        Right (Int k) -> Right (TInteger k)+        _             -> Left $ typeError+          sp+          (  "Unable to determine the second argument value of "+          <> name+          <> " function"+          )+    | name == "int2" = Right (TInteger 2)+    | name `elem` ["loc", "sizeof", "iachar"] = Right (TInteger 4)+    | name == "dfloat" = Right (TReal 8)+    | name `elem` ["ishft", "rshift", "ibset", "ibits"], not (null args) = typeOf+      strT+      symT+      (head args)+    | name `elem` ["iand", "ior", "ieor", "and"], length args == 2 = do+      t1 <- typeOf strT symT (head args)+      t2 <- typeOf strT symT (args !! 1)+      return $ promote t1 t2+    | name == "btest", length args == 2 = return $ TLogical 4+    | name == "not", length args == 1 = typeOf strT symT (head args)+    | otherwise = Left $ typeError+      sp+      (name <> " is not in the extra list of intrinsic functions")++  -- Otherwise, if the function is listed in fortran-src's Fortran77 intrinsic+  -- table, get return type from the intrinsic table.+  checkF77IntrinsicFunction :: Either TypeError Type+  checkF77IntrinsicFunction =+    let f77intrinsics = getVersionIntrinsics Fortran77+    in+      case getIntrinsicReturnType name f77intrinsics of+        Just ITReal      -> Right (TReal 4)+        Just ITInteger   -> Right (TInteger 4)+        Just ITComplex   -> Right (TComplex 8)+        Just ITDouble    -> Right (TReal 8)+        Just ITLogical   -> Right (TLogical 4)+        Just ITCharacter -> Right (TCharacter (CharLenInt 1) 1)+        Just (ITParam i)+          | length args >= i -> typeOf strT symT (args !! (i - 1))+          | otherwise -> Left $ typeError+            sp+            ("Wrong number of arguments for intrinsic function " <> name)+        Nothing ->+          Left $ typeError sp (name <> " is not in Fortran 77 intrinsic table")++  -- If the function is an external function, its type should have been captured+  -- in the symbol table.+  checkExternalFunction :: Either TypeError Type+  checkExternalFunction = typeOfSymbol symT name
+ src/Language/Fortran/Vars/Types.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Language.Fortran.Vars.Types+  ( module Language.Fortran.Vars.Types+  , SemType(..)+  , CharacterLen(..)+  , Kind+  ) where++import           Language.Fortran.Extras.Encoding+                                                ( )+import           Data.Aeson                     ( FromJSON+                                                , ToJSON+                                                , ToJSONKey+                                                , FromJSONKey+                                                )+import           Data.Data                      ( Data )+import           Data.Map                       ( Map )+import           Data.Typeable                  ( Typeable )+import           GHC.Generics                   ( Generic )+import           Control.DeepSeq                ( NFData )+import           Language.Fortran.AST           ( Name+                                                , ProgramUnitName+                                                , Expression+                                                , Kind+                                                )+import           Language.Fortran.Util.Position ( SrcSpan(..)+                                                , Position(..)+                                                )+import           Language.Fortran.Analysis.SemanticTypes+                                                ( SemType(..)+                                                , CharacterLen(..) )++type Type = SemType++-- | The evaluated value of a FORTRAN expression+data ExpVal+  = Int     Int+  | Real    Double+  | Str     String+  | Logical Bool+  | Boz     String+  deriving (Eq, Ord, Show, Data, Typeable, Generic, NFData)++instance FromJSON ExpVal+instance ToJSON ExpVal++-- | Memory offset given to a variable in memory+type Offset = Int++-- | The name of block of memory+type MemoryBlockName = Name++-- | The location of a variable, i.e. the 'MemoryBlockName' that+-- contains it as well as the 'Offset' to its location in memory+type Location = (MemoryBlockName, Offset)++-- | The declared lifetimes of the variables in memory+data StorageClass+  = Static+  | Automatic+  | Constant+  | Common+  | Unspecified+  deriving (Eq, Ord, Show, Data, Typeable, Generic)++instance FromJSON StorageClass+instance ToJSON StorageClass++-- | The declared dimensions of a staticically typed array variable+-- type is of the form [(dim1_lower, dim1_upper), (dim2_lower, dim2_upper)]+type Dimensions = [(Int, Int)]++-- | An entry in the 'SymbolTable' for some variable+data SymbolTableEntry+  = SParameter { parType :: Type , parVal :: ExpVal }+  | SVariable { varType :: Type , varLoc :: Location }+  | SDummy { dumType :: Type }+  | SExternal {extType :: Type }+  deriving (Eq, Ord, Show, Data, Typeable, Generic)++instance FromJSON SymbolTableEntry+instance ToJSON SymbolTableEntry++-- | Symbol table containing all non-intrisic symbols declared in a program+type SymbolTable = Map Name SymbolTableEntry++-- | Structure to hold information about the named blocks of memory+-- in the program+data MemoryBlock = MemoryBlock+  { blockSize    :: Maybe Int -- ^ Nothing for when block is dynamically sized+  , storageClass :: StorageClass+  , variables    :: [Name]+  } deriving (Eq, Ord, Show, Data, Typeable, Generic)++instance FromJSON MemoryBlock+instance ToJSON MemoryBlock++-- | Map from a structure name to its internal structure, specifying members+-- and their corresponding type. This can then be used to check the type of a+-- data reference expression.+type StructureTable = Map String Structure++-- List of structure fields forming a structure+type Structure = [StructureTableEntry]++-- | Data structurue for a single field of a structure+data StructureTableEntry+  = FieldEntry String Type+  | UnionEntry [Structure]+  deriving (Eq, Show, Data)++-- | Mapping from the name of a memory block to the information about it+type StorageTable = Map MemoryBlockName MemoryBlock++-- | The model to represent an individual 'Language.Fortran.AST.ProgramUnit'+type ProgramUnitModel = (SymbolTable, StorageTable)++-- | Mapping from the name of a 'Language.Fortran.AST.ProgramUnit' to+-- its 'ProgramUnitModel'+type ProgramFileModel = Map ProgramUnitName ProgramUnitModel++-- | Mapping from name of a program unit to relevant structure table+type ProgramStructureTables = Map ProgramUnitName StructureTable++-- move these to common+instance ToJSON ProgramUnitName+instance ToJSONKey ProgramUnitName+instance FromJSON ProgramUnitName+instance FromJSONKey ProgramUnitName++data TypeError+  = TypeError FilePath SrcSpan String+  | UnknownType SrcSpan+  | UnboundVariable Name+  | UnknownField String+  deriving (Eq, Ord, Show, Generic)++-- | Helper method for getting the FilePath out of SrcSpan+typeError :: SrcSpan -> String -> TypeError+typeError sp = let SrcSpan p _ = sp in TypeError (filePath p) sp++instance ToJSON TypeError+instance FromJSON TypeError++type TypeOf a = Expression a -> Either TypeError Type
+ src/Language/Fortran/Vars/Union.hs view
@@ -0,0 +1,85 @@+module Language.Fortran.Vars.Union+  ( union+  )+where++import qualified Data.Map                      as M+import           Language.Fortran.AST           ( Name )++import           Language.Fortran.Vars.Types+                                                ( SymbolTableEntry(..)+                                                , Location+                                                , MemoryBlock(..)+                                                , MemoryBlockName+                                                , ProgramUnitModel+                                                , StorageClass(..)+                                                , SymbolTable+                                                )++updateVal :: MemoryBlockName -> Int -> Name -> SymbolTable -> SymbolTable+updateVal blockName diff symbol symt = case M.lookup symbol symt of+  Just (SVariable ty (_, offset)) ->+    let entry = SVariable ty (blockName, offset + diff)+    in  M.insert symbol entry symt+  Just _  -> error (symbol ++ "is not a variable.")+  Nothing -> symt++mergeStClass :: StorageClass -> StorageClass -> StorageClass+mergeStClass Unspecified c2          = c2+mergeStClass c1          Unspecified = c1+mergeStClass c1 c2 | c1 == c2        = c1+mergeStClass c1 c2 =+  error ("Try to merge StorageClass " ++ show c1 ++ " with " ++ show c2)++-- | Given a 'ProgramUnitModel' and two different 'Location's,+-- produce a new 'ProgramUnitModel' and 'Location' that represents+-- the union of the inputs+union+  :: ProgramUnitModel -> Location -> Location -> (ProgramUnitModel, Location)+union puModel loc1 loc2 | loc1 == loc2 = (puModel, loc1)+union (symTable, storageTable) location1 location2 =+  let (blockName1, offset1) = location1+      (blockName2, offset2) = location2+      Just block1           = case M.lookup blockName1 storageTable of+        Just block -> Just block+        Nothing    -> error ("Block doesn't exist: " ++ blockName1)+      Just block2 = case M.lookup blockName2 storageTable of+        Just block -> Just block+        Nothing    -> error ("Block doesn't exist: " ++ blockName2)+  in  case compare offset1 offset2 of+        Prelude.GT -> mergeTo location1 location2+        Prelude.LT -> mergeTo location2 location1+        Prelude.EQ -> case (storageClass block1, storageClass block2) of+          (Common, _     ) -> mergeTo location1 location2+          (_     , Common) -> mergeTo location2 location1+          _                -> if blockSize block1 >= blockSize block2+            then mergeTo location1 location2+            else mergeTo location2 location1+ where+  mergeTo :: Location -> Location -> (ProgramUnitModel, Location)+  mergeTo toLocation@(toBlockName, toOffset) (fromBlockName, fromOffset) =+    let+      diff           = toOffset - fromOffset+      Just fromBlock = M.lookup fromBlockName storageTable+      Just toBlock   = M.lookup toBlockName storageTable+      -- update toBlock variables by appending the variables of fromBlock+      newVarList     = variables toBlock ++ variables fromBlock+      -- update toBlock size+      newSize        = do+        to   <- blockSize toBlock+        from <- blockSize fromBlock+        pure $ max to (from + diff)+      newStClass = mergeStClass (storageClass fromBlock) (storageClass toBlock)+      newBlock   = MemoryBlock { blockSize    = newSize+                               , storageClass = newStClass+                               , variables    = newVarList+                               }+      mbs  = M.insert toBlockName newBlock storageTable+      -- remove the fromBlock+      mbs' = M.delete fromBlockName mbs+      -- update the symbolTable for variables of fromBlock with+      -- toBlock name and updated offset+      symTable' =+        foldr (updateVal toBlockName diff) symTable (variables fromBlock)+    in+      ((symTable', mbs'), toLocation)
+ src/Language/Fortran/Vars/Utils.hs view
@@ -0,0 +1,51 @@+module Language.Fortran.Vars.Utils where++import           Language.Fortran.Analysis      ( Analysis )+import           Language.Fortran.AST+import           Language.Fortran.Vars.Types+                                                ( SymbolTable+                                                , ExpVal(..)+                                                , Type(..)+                                                , SemType(..)+                                                )+import           Language.Fortran.Vars.Eval+                                                ( eval+                                                , eval'+                                                )+import           Language.Fortran.Vars.Kind+                                                ( setTypeKind+                                                , kindOfBaseType+                                                , baseToType+                                                )++-- | Given dimenion declarators and the typespec, give ArrayTypeData evaluating+-- valid expressions for the upper and lower bound+typeSpecToArrayType+  :: SymbolTable+  -> [DimensionDeclarator (Analysis a)]+  -> TypeSpec (Analysis a)+  -> Type+typeSpecToArrayType st dims tySpec = TArray scalarTy $ Just $ map dimStrip dims+ where+  scalarTy = typeSpecToScalarType st tySpec+  dimStrip (DimensionDeclarator _ _ (Just lb) (Just ub)) =+    (constInt lb, constInt ub)+  dimStrip (DimensionDeclarator _ _ Nothing (Just ub)) = (1, constInt ub)+  dimStrip _ = error "Invalid dimension declarator"+  constInt x = case eval st x of+    Int y -> y+    _     -> error "Invalid array spec"++-- | Given the typespec of a scalar get the StaticType+typeSpecToScalarType :: SymbolTable -> TypeSpec (Analysis a) -> Type+typeSpecToScalarType st (TypeSpec _ _ ty selector) =+  let ty' = baseToType ty+  in  case selector of+        Just (Selector _ _ _        (Just k)) -> setTypeKind ty' (constInt k)+        Just (Selector _ _ (Just l) _       ) -> setTypeKind ty' (constInt l)+        Nothing -> setTypeKind ty' (Just $ kindOfBaseType ty)+        _                                     -> error "Invalid type spec"+ where+  constInt x = case eval' st x of+    Right (Int y) -> Just y+    _             -> Nothing
+ test/AssignmentsSpec.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE LambdaCase #-}++module AssignmentsSpec where++import           Test.Hspec+import           Test.HUnit++import           Data.Either                    ( rights+                                                , partitionEithers+                                                )+import           Language.Fortran.AST           ( Expression(..)+                                                , Value(..)+                                                )+import           Language.Fortran.Extras+                                                ( allPU )+import           Language.Fortran.Extras.Test+                                                ( getTestProgramAnalysis )+import           Language.Fortran.Vars.Assignments+import           Language.Fortran.Vars.Types+                                                ( Type(..)+                                                , SemType(..)+                                                , CharacterLen(..)+                                                )++spec :: Spec+spec = describe "Grab assignment exprs" $ do+  it "All types of assignment" $ do+    pf <- getTestProgramAnalysis "test/assignment/all-assignments.f"+    let stmts = rights . concatMap allAssignStmts $ allPU pf+    length stmts `shouldBe` 4+    map fst stmts `shouldBe` [TInteger 2, TInteger 4, TInteger 8, TLogical 1]+  it "Array assignment" $ do+    pf <- getTestProgramAnalysis "test/assignment/array-assignment.f"+    let (errs, stmts) = partitionEithers . concatMap allAssignStmts $ allPU pf+    length errs `shouldBe` 0+    length stmts `shouldBe` 9+    map fst stmts `shouldBe` replicate 9 (TReal 4)+    let getVal = \case+          ExpValue _ _ (ValInteger s) -> s+          _                           -> error "Not value"+    map (getVal . snd) stmts+      `shouldBe` ["1", "0", "0", "0", "1", "0", "0", "0", "1"]++  it "Dummy character" $ do+    pf <- getTestProgramAnalysis "test/assignment/dummy-character.f"+    let (errs, stmts) = partitionEithers . concatMap allAssignStmts $ allPU pf+    length errs `shouldBe` 0+    length stmts `shouldBe` 1+    case head stmts of+      (TCharacter CharLenStar _, ExpValue _ _ (ValString "ABCDEFGHI")) -> pure ()+      _ -> assertFailure "Wrong statement matched"
+ test/BozConstantSpec.hs view
@@ -0,0 +1,49 @@+module BozConstantSpec where++import           Test.Hspec++import           Language.Fortran.Vars.BozConstant+                                                ( bozToInt2+                                                , bozToInt4+                                                , bozToInt8+                                                )+import           Language.Fortran.Vars.Types+                                                ( ExpVal(..) )+++spec :: Spec+spec = describe "Boz Constant Conversion" $ do+  it "Mixed case BOZ constant conversions" $ do+    bozToInt2 (Boz "'ffff'x") `shouldBe` Int (-1)+    bozToInt2 (Boz "'FfFf'x") `shouldBe` Int (-1)+    bozToInt4 (Boz "'FFFFFFFF'x") `shouldBe` Int (-1)++  it "BOZ constant to Integer*2" $ do+    bozToInt2 (Boz "'1'x") `shouldBe` Int 1+    bozToInt2 (Boz "'10'x") `shouldBe` Int 16+    bozToInt2 (Boz "'7fff'x") `shouldBe` Int 32767+    bozToInt2 (Boz "'8000'x") `shouldBe` Int (-32768)+    bozToInt2 (Boz "'ffff'x") `shouldBe` Int (-1)++  it "BOZ constant to Integer*4" $ do+    bozToInt4 (Boz "'1'x") `shouldBe` Int 1+    bozToInt4 (Boz "'10'x") `shouldBe` Int 16+    bozToInt4 (Boz "'7fff'x") `shouldBe` Int 32767+    bozToInt4 (Boz "'8000'x") `shouldBe` Int 32768+    bozToInt4 (Boz "'ffff'x") `shouldBe` Int 65535+    bozToInt4 (Boz "'7fffffff'x") `shouldBe` Int 2147483647+    bozToInt4 (Boz "'80000000'x") `shouldBe` Int (-2147483648)+    bozToInt4 (Boz "'ffffffff'x") `shouldBe` Int (-1)++  it "BOZ constant to Integer*8" $ do+    bozToInt8 (Boz "'1'x") `shouldBe` Int 1+    bozToInt8 (Boz "'10'x") `shouldBe` Int 16+    bozToInt8 (Boz "'7fff'x") `shouldBe` Int 32767+    bozToInt8 (Boz "'8000'x") `shouldBe` Int 32768+    bozToInt8 (Boz "'ffff'x") `shouldBe` Int 65535+    bozToInt8 (Boz "'7fffffff'x") `shouldBe` Int 2147483647+    bozToInt8 (Boz "'80000000'x") `shouldBe` Int 2147483648+    bozToInt8 (Boz "'ffffffff'x") `shouldBe` Int 4294967295+    bozToInt8 (Boz "'7fffffffffffffff'x") `shouldBe` Int 9223372036854775807+    --bozToInt8 (Boz "'8000000000000000'x") `shouldBe` Int (-9223372036854775808)+    --bozToInt8 (Boz "'ffffffffffffffff'x") `shouldBe` Int (-1)
+ test/ConstantPropagationSpec.hs view
@@ -0,0 +1,385 @@+module ConstantPropagationSpec where++import           Test.Hspec++import           Language.Fortran.Extras+                                                ( allS )+import           Language.Fortran.Extras.Test+                                                ( getTestProgramAnalysis )+import           Language.Fortran.AST+import           Language.Fortran.Analysis      ( Analysis+                                                , srcName+                                                )++import           Language.Fortran.Vars.Types+import           Language.Fortran.Vars.ConstantPropagation+                                                ( constantPropagationValue+                                                , ValueOf+                                                )+import           Language.Fortran.Vars.CPValue+                                                ( CPValue(..) )+import           Language.Fortran.Vars.Call+                                                ( functionCalls+                                                , subroutineCalls+                                                , functionArguments+                                                , subroutineArguments+                                                )++-- | getRHSFunc provide a check point in the program file to test+-- the value of an expression.+-- It grab the right-hand side expression from an assignment statement.+-- For code like `lhsName = rhs`+-- `getRHSFunc pf "lhsName"` will return expression `rhs`+-- The lhsName shall be unique in the Program File+getRHSFunc :: ProgramFile (Analysis A0) -> Name -> Expression (Analysis A0)+getRHSFunc pf lhs = head+  [ rhs+  | (StExpressionAssign _ _ e@(ExpValue _ _ ValVariable{}) rhs) <- allS pf+  , srcName e == lhs+  ]++helper :: String -> IO (ValueOf A0, Name -> Expression (Analysis A0))+helper path = do+  pf <- getTestProgramAnalysis path+  let valueOf = constantPropagationValue pf+      getRHS  = getRHSFunc pf+  return (valueOf, getRHS)++spec :: Spec+spec = do++  describe "Variable" $ do++    let path = "test/constant_propagation/variable.f"+    it "Branch" $ do+      (valueOf, getRHS) <- helper path++      valueOf (getRHS "checka") `shouldBe` Const (Int 1)+      valueOf (getRHS "checkc") `shouldBe` Top+      valueOf (getRHS "checkb") `shouldBe` Bot++    it "Equivalence" $ do+      (valueOf, getRHS) <- helper path++      valueOf (getRHS "checkd") `shouldBe` Const (Int 123)+++  describe "Short Circuit" $ do+    let path = "test/constant_propagation/short_circuit.f"+    it "Logical Operation" $ do+      (valueOf, getRHS) <- helper path++      valueOf (getRHS "logical1") `shouldBe` Const (Logical False)+      valueOf (getRHS "logical2") `shouldBe` Const (Logical False)+      valueOf (getRHS "logical3") `shouldBe` Const (Logical True)+      valueOf (getRHS "logical4") `shouldBe` Const (Logical True)++    it "Multiplication" $ do+      (valueOf, getRHS) <- helper path++      valueOf (getRHS "int1") `shouldBe` Const (Int 0)+      valueOf (getRHS "int2") `shouldBe` Const (Int 0)+      valueOf (getRHS "real1") `shouldBe` Const (Real 0.0)+      valueOf (getRHS "real2") `shouldBe` Const (Real 0.0)++    it "Real exponentiation" $ do+      (valueOf, getRHS) <- helper path++      valueOf (getRHS "real3") `shouldBe` Const (Real 1.0)+      valueOf (getRHS "real4") `shouldBe` Const (Real 1.0)+      valueOf (getRHS "real5") `shouldBe` Const (Real 1.0)+      valueOf (getRHS "real6") `shouldBe` Const (Real 1.0)++    it "Integer exponentiation" $ do+      (valueOf, getRHS) <- helper "test/constant_propagation/integer_exponent.f"+      valueOf (getRHS "a") `shouldBe` Const (Int 2)+      valueOf (getRHS "b") `shouldBe` Const (Int 2)+      valueOf (getRHS "c") `shouldBe` Const (Int 4)++  describe "Strings" $ do++    it "string scalar" $ do+      (valueOf, getRHS) <- helper "test/constant_propagation/string_scalar.f"++      valueOf (getRHS "s1") `shouldBe` Const (Str "A")+      valueOf (getRHS "s4") `shouldBe` Const (Str "4")++    it "string array" $ do+      (valueOf, getRHS) <- helper "test/constant_propagation/string_array.f"++      valueOf (getRHS "a1") `shouldBe` Const (Str "A")+      valueOf (getRHS "a4") `shouldBe` Const (Str "A")++  describe "Array" $ do+    let path = "test/constant_propagation/array.f"++    it "Branch" $ do+      (valueOf, getRHS) <- helper path++      valueOf (getRHS "a1") `shouldBe` Const (Int 1)+      valueOf (getRHS "a2") `shouldBe` Bot+      valueOf (getRHS "a3") `shouldBe` Top++    it "Equivalence" $ do+      (valueOf, getRHS) <- helper path++      valueOf (getRHS "a4") `shouldBe` Const (Int 123)++    it "Unknown index on RHS" $ do+      (valueOf, getRHS) <- helper path++      valueOf (getRHS "a5") `shouldBe` Bot++    it "Unknown index on LHS" $ do+      (valueOf, getRHS) <- helper path++      valueOf (getRHS "a6") `shouldBe` Bot+      valueOf (getRHS "a7") `shouldBe` Bot+      valueOf (getRHS "a8") `shouldBe` Bot+      valueOf (getRHS "a9") `shouldBe` Bot++    it "Update array after processing unknown index on LHS" $ do+      (valueOf, getRHS) <- helper path++      valueOf (getRHS "a10") `shouldBe` Const (Int 456)+      valueOf (getRHS "a11") `shouldBe` Bot+++  describe "Loop" $ do+    let path = "test/constant_propagation/loop.f"++    it "Loop" $ do+      (valueOf, getRHS) <- helper path++      valueOf (getRHS "a1") `shouldBe` Bot+      valueOf (getRHS "a2") `shouldBe` Const (Int 123)+      valueOf (getRHS "a3") `shouldBe` Const (Int 456)++    it "Do Loop" $ do+      (valueOf, getRHS) <- helper path++      valueOf (getRHS "b1") `shouldBe` Bot+      valueOf (getRHS "b2") `shouldBe` Bot+      valueOf (getRHS "b3") `shouldBe` Const (Int 123)+      valueOf (getRHS "b4") `shouldBe` Const (Int 456)+++  describe "Arithmetic If" $ do+    let path = "test/constant_propagation/arithif.f"++    it "Arithmetic If" $ do+      (valueOf, getRHS) <- helper path++      valueOf (getRHS "a1") `shouldBe` Top+      valueOf (getRHS "a2") `shouldBe` Bot+      valueOf (getRHS "a3") `shouldBe` Const (Int 123)++  describe "Subroutine" $ do+    let path = "test/constant_propagation/subroutine.f"++    it "Calling unary subroutine" $ do+      (valueOf, getRHS) <- helper path++      valueOf (getRHS "a1") `shouldBe` Const (Int 1)+      valueOf (getRHS "a2") `shouldBe` Const (Int 1)+      valueOf (getRHS "a3") `shouldBe` Bot+      valueOf (getRHS "a4") `shouldBe` Bot++    it "Calling binary subroutine" $ do+      (valueOf, getRHS) <- helper path++      valueOf (getRHS "b1") `shouldBe` Const (Int 1)+      valueOf (getRHS "b2") `shouldBe` Const (Int 2)+      valueOf (getRHS "b3") `shouldBe` Bot+      valueOf (getRHS "b4") `shouldBe` Bot++    it "Calling array subroutine" $ do+      (valueOf, getRHS) <- helper path++      valueOf (getRHS "c1") `shouldBe` Const (Int 1)+      valueOf (getRHS "c2") `shouldBe` Const (Int 2)+      valueOf (getRHS "c3") `shouldBe` Bot+      valueOf (getRHS "c4") `shouldBe` Bot++  describe "Function" $ do+    let path = "test/constant_propagation/function.f"+    it "Calling unary function" $ do+      (valueOf, getRHS) <- helper path++      valueOf (getRHS "a1") `shouldBe` Const (Int 2)+      valueOf (getRHS "a2") `shouldBe` Const (Int 2)+      valueOf (getRHS "a3") `shouldBe` Bot+      valueOf (getRHS "a4") `shouldBe` Bot+      valueOf (getRHS "a5") `shouldBe` Bot++    it "Calling binary function" $ do+      (valueOf, getRHS) <- helper path++      valueOf (getRHS "b1") `shouldBe` Const (Int 3)+      valueOf (getRHS "b2") `shouldBe` Const (Int 4)+      valueOf (getRHS "b3") `shouldBe` Bot+      valueOf (getRHS "b4") `shouldBe` Bot+      valueOf (getRHS "b5") `shouldBe` Bot++    it "Calling array subroutine" $ do+      (valueOf, getRHS) <- helper path++      valueOf (getRHS "e1") `shouldBe` Const (Int 1)+      valueOf (getRHS "e2") `shouldBe` Const (Int 2)+      valueOf (getRHS "e3") `shouldBe` Bot+      valueOf (getRHS "e4") `shouldBe` Bot+      valueOf (getRHS "e5") `shouldBe` Bot++    it "Dummy in unary function" $ do+      (valueOf, getRHS) <- helper path++      valueOf (getRHS "c1") `shouldBe` Bot+      valueOf (getRHS "c2") `shouldBe` Bot++    it "Dummies in binary function" $ do+      (valueOf, getRHS) <- helper path++      valueOf (getRHS "d1") `shouldBe` Bot+      valueOf (getRHS "d2") `shouldBe` Bot+      valueOf (getRHS "d3") `shouldBe` Bot++  describe "Check Function Arguments" $ do+    let path = "test/constant_propagation/function_arguments.f"+    it "Function Arguments" $ do+      pf <- getTestProgramAnalysis path+      let valueOf = constantPropagationValue pf+          bars    = functionCalls pf "bar"+          bar1    = head bars+          bar2    = bars !! 1+          bar3    = bars !! 2+      map valueOf (functionArguments bar1)+        `shouldBe` [Const (Int 1), Const (Int 2)]+      map valueOf (functionArguments bar2) `shouldBe` [Bot, Bot]+      map valueOf (functionArguments bar3) `shouldBe` [Const (Int 3), Bot]++  describe "Check Subroutine Arguments" $ do+    let path = "test/constant_propagation/subroutine_arguments.f"+    it "Subroutine Arguments" $ do+      pf <- getTestProgramAnalysis path+      let valueOf = constantPropagationValue pf+          bars    = subroutineCalls pf "bar"+          call1   = head bars+          call2   = bars !! 1+          call3   = bars !! 2+          call4   = bars !! 3+      map valueOf (subroutineArguments call1)+        `shouldBe` [Const (Int 1), Const (Int 2)]+      map valueOf (subroutineArguments call2) `shouldBe` [Bot, Bot]+      map valueOf (subroutineArguments call3)+        `shouldBe` [Const (Int 3), Const (Int 7)]+      map valueOf (subroutineArguments call4)+        `shouldBe` [Const (Int 0), Const (Int 1)]++  describe "Commmon Variables" $ do+    let path = "test/constant_propagation/common.f"+    it "Skip common variable" $ do+      (valueOf, getRHS) <- helper path+      valueOf (getRHS "before1") `shouldBe` Top+      valueOf (getRHS "before2") `shouldBe` Top+      valueOf (getRHS "after1") `shouldBe` Top+      valueOf (getRHS "after2") `shouldBe` Top++  describe "Arrays as Parameters" $ do+    let path = "test/constant_propagation/array_params.f"+    it "Marks arrays passed as parameters as Bot" $ do+      (valueOf, getRHS) <- helper path+      valueOf (getRHS "b") `shouldBe` Bot+      valueOf (getRHS "c") `shouldBe` Bot++  describe "Lattice operation of CPValue" $ do+    let path = "test/constant_propagation/cpvalue.f"+    it "cpvalue" $ do+      (valueOf, getRHS) <- helper path+      valueOf (getRHS "c1") `shouldBe` Top+      valueOf (getRHS "c2") `shouldBe` Top+      valueOf (getRHS "c3") `shouldBe` Top+      valueOf (getRHS "c4") `shouldBe` Bot+      valueOf (getRHS "c5") `shouldBe` Bot+      valueOf (getRHS "c6") `shouldBe` Const (Int 3)+      valueOf (getRHS "c7") `shouldBe` Bot+      valueOf (getRHS "c8") `shouldBe` Bot+      valueOf (getRHS "c9") `shouldBe` Bot++  describe "Multiple ExpSubscripts" $ do+    let path = "test/constant_propagation/multi_subscript.f"+    it "Can handle multiple chained subscripts" $ do+      (valueOf, getRHS) <- helper path+      valueOf (getRHS "p") `shouldBe` Top+      valueOf (getRHS "q") `shouldBe` Top++  describe "Subscripts" $ do+    it "Can correctly determine a simple substring" $ do+      (valueOf, getRHS) <- helper+        "test/constant_propagation/simple_subscripts.f"+      valueOf (getRHS "a") `shouldBe` Const (Str "0123456789")+      valueOf (getRHS "b") `shouldBe` Const (Str "01234")++    it "Can correctly determine values of strings after subscripting" $ do+      (valueOf, getRHS) <- helper "test/constant_propagation/subscripts.f"+      valueOf (getRHS "bottom") `shouldBe` Bot+      valueOf (getRHS "top") `shouldBe` Top+      valueOf (getRHS "c") `shouldBe` Const (Str "&&&&&&&&&&")+      valueOf (getRHS "d") `shouldBe` Const (Str "0123456789")+      valueOf (getRHS "const1") `shouldBe` Const (Str "0123456789")+      valueOf (getRHS "const2") `shouldBe` Const (Str "01234")+      valueOf (getRHS "const3") `shouldBe` Const (Str "56789")++  describe "Array Truncation" $ do+    it "Can handle integer array truncation" $ do+      (valueOf, getRHS) <- helper+        "test/constant_propagation/array_truncation_integer.f"+      valueOf (getRHS "a1") `shouldBe` Const (Int 8)+      valueOf (getRHS "a2") `shouldBe` Const (Int 8)+      valueOf (getRHS "a3") `shouldBe` Const (Int 8)+      valueOf (getRHS "a4") `shouldBe` Const (Int 8)++    it "Can handle string array truncation" $ do+      (valueOf, getRHS) <- helper+        "test/constant_propagation/array_truncation_string.f"+      valueOf (getRHS "a1") `shouldBe` Const (Str "A")+      valueOf (getRHS "a2") `shouldBe` Const (Str "A")+      valueOf (getRHS "a3") `shouldBe` Const (Str "A")+      valueOf (getRHS "a4") `shouldBe` Const (Str "A")++  describe "Null strings"+    $ it "Should treat empty string as a space in assignments and comparisons"+    $ do+        (valueOf, getRHS) <- helper "test/constant_propagation/null_string.f"+        valueOf (getRHS "b") `shouldBe` Const (Str "12 45")+        valueOf (getRHS "c") `shouldBe` Const (Str "A")+        valueOf (getRHS "d") `shouldBe` Const (Str "B")++  describe "Array sections" $ do+    let errStr = "Array sections are not allowed in FORTRAN 77"++    it "Should not allow assignment to string array sections" $ do+      (valueOf, getRHS) <- helper+        "test/constant_propagation/string_array_sections.f"+      print (valueOf $ getRHS "b") `shouldThrow` errorCall errStr++    it "Should not allow assignment to integer array sections" $ do+      (valueOf, getRHS) <- helper+        "test/constant_propagation/integer_array_sections.f"+      print (valueOf $ getRHS "b") `shouldThrow` errorCall errStr++    it "Should not allow assignment from string array sections" $ do+      (valueOf, getRHS) <- helper+        "test/constant_propagation/array_section_assignment.f"+      print (valueOf $ getRHS "b") `shouldThrow` errorCall errStr++  describe "Expressions in substrings"+    $ it "Should correctly evaluate various substrings indexed with expressions"+    $ do+        (valueOf, getRHS) <- helper+          "test/constant_propagation/substring_index_expressions.f"+        valueOf (getRHS "a") `shouldBe` Const (Str "12345")+        valueOf (getRHS "j") `shouldBe` Const (Int 3)+        valueOf (getRHS "b") `shouldBe` Const (Str "45")+        valueOf (getRHS "c") `shouldBe` Const (Str "4")+        valueOf (getRHS "d") `shouldBe` Bot+        valueOf (getRHS "e") `shouldBe` Bot
+ test/EvalSpec.hs view
@@ -0,0 +1,89 @@+module EvalSpec where++import           Test.Hspec++import           Prelude                 hiding ( EQ )+import qualified Data.Map                      as M+import           Language.Fortran.AST           ( A0+                                                , BinaryOp(..)+                                                , Expression(..)+                                                , UnaryOp(..)+                                                , Value(..)+                                                )+import           Language.Fortran.Util.Position ( SrcSpan(..)+                                                , Position(..)+                                                )++import           Language.Fortran.Vars.Eval+                                                ( evalWithShortcircuit )+import           Language.Fortran.Vars.Types+                                                ( ExpVal(..)+                                                , SymbolTable+                                                )++dSpan :: SrcSpan+dSpan = let p = Position 0 0 0 "" Nothing in SrcSpan p p++dSym :: SymbolTable+dSym = M.empty++true, false :: Expression A0+true = ExpValue () dSpan $ ValLogical ".TRUE."+false = ExpValue () dSpan $ ValLogical ".FALSE."++foobar :: Expression A0+foobar = ExpValue () dSpan $ ValVariable "foobar"++spec :: Spec+spec = describe "Boolean constant folding" $ do+  it "Can handle Not" $ do+    let ex1 = ExpUnary () dSpan Not true+        ex2 = ExpUnary () dSpan Not false+    evalWithShortcircuit dSym ex1 `shouldBe` Right (Logical False)+    evalWithShortcircuit dSym ex2 `shouldBe` Right (Logical True)+  it "Can handle simple Or" $ do+    let ex1 = ExpBinary () dSpan Or true true+        ex2 = ExpBinary () dSpan Or true false+        ex3 = ExpBinary () dSpan Or false true+        ex4 = ExpBinary () dSpan Or false false+    evalWithShortcircuit dSym ex1 `shouldBe` Right (Logical True)+    evalWithShortcircuit dSym ex2 `shouldBe` Right (Logical True)+    evalWithShortcircuit dSym ex3 `shouldBe` Right (Logical True)+    evalWithShortcircuit dSym ex4 `shouldBe` Right (Logical False)+  it "Can handle simple And" $ do+    let ex1 = ExpBinary () dSpan And true true+        ex2 = ExpBinary () dSpan And true false+        ex3 = ExpBinary () dSpan And false true+        ex4 = ExpBinary () dSpan And false false+    evalWithShortcircuit dSym ex1 `shouldBe` Right (Logical True)+    evalWithShortcircuit dSym ex2 `shouldBe` Right (Logical False)+    evalWithShortcircuit dSym ex3 `shouldBe` Right (Logical False)+    evalWithShortcircuit dSym ex4 `shouldBe` Right (Logical False)+  it "Can handle Or with variable" $ do+    let ex1 = ExpBinary () dSpan Or true foobar+        ex2 = ExpBinary () dSpan Or foobar true+    evalWithShortcircuit dSym ex1 `shouldBe` Right (Logical True)+    evalWithShortcircuit dSym ex2 `shouldBe` Right (Logical True)+  it "Can handle And with variable" $ do+    let ex1 = ExpBinary () dSpan And false foobar+        ex2 = ExpBinary () dSpan And foobar false+    evalWithShortcircuit dSym ex1 `shouldBe` Right (Logical False)+    evalWithShortcircuit dSym ex2 `shouldBe` Right (Logical False)+  it "Can handle more complicated trees" $ do+    -- (foobar .AND. .TRUE.) .AND.+    --    (foobar .AND. (.FALSE. .OR. (foobar .AND. .FALSE.)))+    let lhs = ExpBinary () dSpan And foobar true+        ex1 = ExpBinary () dSpan And foobar false+        ex2 = ExpBinary () dSpan Or false ex1+        rhs = ExpBinary () dSpan And foobar ex2+        ex  = ExpBinary () dSpan And lhs rhs+    evalWithShortcircuit dSym ex `shouldBe` Right (Logical False)+  it "Can handle .NOT. (foobar .AND. .FALSE.)" $ do+    let ex1 = ExpBinary () dSpan And foobar false+        ex  = ExpUnary () dSpan Not ex1+    evalWithShortcircuit dSym ex `shouldBe` Right (Logical True)+  it "Can handle conditions with non-logical logic" $ do+    -- .TRUE. .EQ. 1+    let vx = ExpValue () dSpan $ ValInteger "1"+        ex = ExpBinary () dSpan EQ true vx+    evalWithShortcircuit dSym ex `shouldBe` Right (Logical True)
+ test/PureExpressionSpec.hs view
@@ -0,0 +1,69 @@+module PureExpressionSpec where++import           Test.Hspec++import           Language.Fortran.Extras+                                                ( allS )+import           Language.Fortran.Extras.Test+                                                ( getTestProgramAnalysis )+import           Language.Fortran.AST+import           Language.Fortran.Analysis      ( Analysis+                                                , srcName+                                                )++import           Language.Fortran.Vars.PureExpression+                                                ( isPureExpression )++-- | getRHSFunc provides a check point to test the property of an expression.+-- It grabs the right-hand side expression from an assignment statement.+-- For code like `lhsName = rhs`+-- `getRHSFunc pf "lhsName"` will return expression `rhs`+-- The lhsName shall be unique across the Program File+getRHSFunc :: ProgramFile (Analysis A0) -> Name -> Expression (Analysis A0)+getRHSFunc pf lhs = head+  [ rhs+  | (StExpressionAssign _ _ e@(ExpValue _ _ ValVariable{}) rhs) <- allS pf+  , srcName e == lhs+  ]++helper :: String -> IO (Name -> Expression (Analysis A0))+helper path = do+  pf <- getTestProgramAnalysis path+  let getRHS = getRHSFunc pf+  return getRHS++spec :: Spec+spec = describe "Pure Expression" $ do++  let path = "test/pure_expression.f"+  it "Constant and Vairable" $ do+    getRHS <- helper path++    isPureExpression (getRHS "i1") `shouldBe` True+    isPureExpression (getRHS "i2") `shouldBe` True++  it "Unary/Binary Operations" $ do+    getRHS <- helper path+    isPureExpression (getRHS "i3") `shouldBe` True+    isPureExpression (getRHS "i4") `shouldBe` True+    isPureExpression (getRHS "b1") `shouldBe` True+    isPureExpression (getRHS "b2") `shouldBe` True++  it "Array" $ do+    getRHS <- helper path+    isPureExpression (getRHS "i4") `shouldBe` True+    isPureExpression (getRHS "i5") `shouldBe` True++  it "Exnternal Function" $ do+    getRHS <- helper path+    isPureExpression (getRHS "i6") `shouldBe` False+    isPureExpression (getRHS "i7") `shouldBe` False+    isPureExpression (getRHS "i8") `shouldBe` False+    isPureExpression (getRHS "i9") `shouldBe` False+    isPureExpression (getRHS "b3") `shouldBe` False++  it "Intrinsic Function" $ do+    getRHS <- helper path+    isPureExpression (getRHS "r1") `shouldBe` True+    isPureExpression (getRHS "i10") `shouldBe` True+    isPureExpression (getRHS "i11") `shouldBe` False
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/StorageTableSpec.hs view
@@ -0,0 +1,482 @@+module StorageTableSpec where++import           Test.Hspec++import           Language.Fortran.Util.Files+                                                ( flexReadFile )+import           Language.Fortran.Extras.ProgramFile+                                                ( versionedProgramFile )+import           Data.ByteString.Char8          ( ByteString )+import qualified Data.Map                      as M+import           Data.Maybe                     ( fromJust+                                                , fromMaybe+                                                )++import           Language.Fortran.AST           ( Name+                                                , ProgramUnitName(..)+                                                )+import           Language.Fortran.ParserMonad   ( FortranVersion(..) )+import           Language.Fortran.Analysis      ( initAnalysis )++import           Language.Fortran.Vars ( programFileModel )+import           Language.Fortran.Vars.Types+                                                ( SymbolTableEntry(..)+                                                , Location+                                                , MemoryBlock(..)+                                                , MemoryBlockName+                                                , ProgramUnitModel+                                                , StorageClass(..)+                                                , StorageTable+                                                , SymbolTable+                                                , Type(..)+                                                , SemType(..)+                                                , CharacterLen(..)+                                                )+import           Language.Fortran.Vars.CommonLayout+                                                ( getCommonLayout+                                                , getFlagType+                                                )++getModel :: String -> ByteString -> String -> ProgramUnitModel+getModel p c n =+  let pf  = initAnalysis $ versionedProgramFile Fortran77Legacy p c+      pfm = programFileModel pf+  in  fromMaybe (error $ "Failed to lookup unit: " ++ n)+        $ M.lookup (Named n) pfm++blockSizeOf :: MemoryBlockName -> StorageTable -> Int+blockSizeOf name storageTable =+  fromJust $ M.lookup name storageTable >>= blockSize++locationOf :: Name -> SymbolTable -> Location+locationOf name symTable = case M.lookup name symTable of+  Just (SVariable _ loc) -> loc+  _                      -> error (show name ++ " is not a VariableEntry")++blockNameOf :: Name -> SymbolTable -> MemoryBlockName+blockNameOf name symTable =+  let (blockName, _) = locationOf name symTable in blockName++offsetOf :: Name -> SymbolTable -> Int+offsetOf name symTable = let (_, offset) = locationOf name symTable in offset++storageClassOf :: MemoryBlockName -> StorageTable -> StorageClass+storageClassOf name storageTable =+  storageClass . fromJust $ M.lookup name storageTable++storageClassOfVar :: Name -> ProgramUnitModel -> StorageClass+storageClassOfVar name (symTable, storageTable) =+  storageClassOf (blockNameOf name symTable) storageTable++variablesOf :: MemoryBlockName -> StorageTable -> [Name]+variablesOf name storageTable =+  variables . fromJust $ M.lookup name storageTable++spec :: Spec+spec = do++  describe "StorageTable: default " $ do++    let path     = "test/memory_block.f"+        unitName = "foo"++    it "Single Variable" $ do+      contents <- flexReadFile path+      let (symTable, storageTable) = getModel path contents unitName+      let var                      = "a1"+      -- use the name of the variable as the default block name+      blockNameOf var symTable `shouldBe` "a1"+      offsetOf var symTable `shouldBe` 0+      blockSizeOf var storageTable `shouldBe` 4+      -- default storage class is Unspecified+      storageClassOf "a1" storageTable `shouldBe` Unspecified++    it "Array Variable" $ do+      contents <- flexReadFile path+      let (symTable, storageTable) = getModel path contents unitName+      let var                      = "a2"+      -- use the name of the variable as the default block name+      blockNameOf var symTable `shouldBe` "a2"+      offsetOf var symTable `shouldBe` 0+      blockSizeOf var storageTable `shouldBe` (3 * 4 * 4)+      -- default storage class is Unspecified+      storageClassOf "a2" storageTable `shouldBe` Unspecified++  describe "Storage Class" $ do++    let path     = "test/storage_class.f"+        unitName = "foo"++    it "Default Unspecified" $ do+      contents <- flexReadFile path+      let st  = getModel path contents unitName+      let var = "a"+      storageClassOfVar var st `shouldBe` Unspecified++    it "Static" $ do+      contents <- flexReadFile path+      let st = getModel path contents unitName+      storageClassOfVar "b1" st `shouldBe` Static+      storageClassOfVar "b2" st `shouldBe` Static++    it "Automatic" $ do+      contents <- flexReadFile path+      let st = getModel path contents unitName+      storageClassOfVar "c1" st `shouldBe` Automatic+      storageClassOfVar "c2" st `shouldBe` Automatic++    it "Common" $ do+      contents <- flexReadFile path+      let st = getModel path contents unitName+      storageClassOfVar "d1" st `shouldBe` Common+      storageClassOfVar "d2" st `shouldBe` Common++  describe "Equivalence" $ do++    let path     = "test/equivalence.f"+        unitName = "foo"++    it "Variable and single dimensional array" $ do+      contents <- flexReadFile path+      let (symTable, storageTable) = getModel path contents unitName++      blockNameOf "var" symTable `shouldBe` "array"+      blockNameOf "array" symTable `shouldBe` "array"++      offsetOf "array" symTable `shouldBe` 0+      offsetOf "var" symTable `shouldBe` 56++      variablesOf "array" storageTable `shouldBe` ["array", "var"]++    it "Memory block merging:  equal sizes, different offsets" $ do+      contents <- flexReadFile path+      let (symt, storageTable) = getModel path contents unitName++      blockNameOf "b" symt `shouldBe` "b"+      blockNameOf "c" symt `shouldBe` "b"++      offsetOf "b" symt `shouldBe` 0+      offsetOf "c" symt `shouldBe` (4 * 5)++      variablesOf "b" storageTable `shouldBe` ["b", "c"]++    it "Memory block merging:  equal offsets, different sizes" $ do+      contents <- flexReadFile path+      let (symt, storageTable) = getModel path contents unitName++      blockNameOf "d" symt `shouldBe` "d"+      blockNameOf "e" symt `shouldBe` "d"++      offsetOf "d" symt `shouldBe` 0+      offsetOf "e" symt `shouldBe` 0++      variablesOf "d" storageTable `shouldBe` ["d", "e"]++    it "Three way equivalence - 1" $ do+      contents <- flexReadFile path+      let (symt, storaget) = getModel path contents unitName+      blockNameOf "aa" symt `shouldBe` "cc"+      blockNameOf "bb" symt `shouldBe` "cc"+      blockNameOf "cc" symt `shouldBe` "cc"++      offsetOf "aa" symt `shouldBe` 0+      offsetOf "bb" symt `shouldBe` 3+      offsetOf "cc" symt `shouldBe` 0++      variablesOf "cc" storaget `shouldBe` ["cc", "aa", "bb"]++    it "Three way equivalence - 2" $ do+      contents <- flexReadFile path+      let (symt, storaget) = getModel path contents unitName+      blockNameOf "sndbuff" symt `shouldBe` "sndbuff"+      blockNameOf "sndbbid1" symt `shouldBe` "sndbuff"+      blockNameOf "sndbbid2" symt `shouldBe` "sndbuff"++      offsetOf "sndbuff" symt `shouldBe` 0+      offsetOf "sndbbid1" symt `shouldBe` 2+      offsetOf "sndbbid2" symt `shouldBe` 6++      variablesOf "sndbuff" storaget+        `shouldBe` ["sndbuff", "sndbbid1", "sndbbid2"]+++    it "List of equivalences" $ do+      contents <- flexReadFile path+      let (symt, storaget) = getModel path contents unitName+      blockNameOf "r1" symt `shouldBe` "r1"+      blockNameOf "r2" symt `shouldBe` "r1"+      blockNameOf "r3" symt `shouldBe` "r1"+      variablesOf "r1" storaget `shouldBe` ["r1", "r2", "r3"]+      blockNameOf "i1" symt `shouldBe` "i1"+      blockNameOf "i2" symt `shouldBe` "i1"+      blockNameOf "i3" symt `shouldBe` "i1"+      variablesOf "i1" storaget `shouldBe` ["i1", "i2", "i3"]++    it "Multidimensional array" $ do+      contents <- flexReadFile path+      let (symt, storaget) = getModel path contents unitName+      blockNameOf "threedim" symt `shouldBe` "threedim"+      blockNameOf "twodim" symt `shouldBe` "threedim"+      offsetOf "threedim" symt `shouldBe` 0+      offsetOf "twodim" symt `shouldBe` 400+      variablesOf "threedim" storaget `shouldBe` ["threedim", "twodim"]++      blockNameOf "fivedim" symt `shouldBe` "sevendim"+      blockNameOf "sevendim" symt `shouldBe` "sevendim"+      offsetOf "sevendim" symt `shouldBe` 0+      offsetOf "fivedim" symt `shouldBe` 4444444+      variablesOf "sevendim" storaget `shouldBe` ["sevendim", "fivedim"]+++    it "Substring" $ do+      contents <- flexReadFile path+      let (symt, storaget) = getModel path contents unitName+      blockNameOf "exchange_code" symt `shouldBe` "inbuf"+      blockNameOf "price" symt `shouldBe` "inbuf"+      offsetOf "exchange_code" symt `shouldBe` 9+      offsetOf "price" symt `shouldBe` 22+      variablesOf "inbuf" storaget+        `shouldBe` ["inbuf", "exchange_code", "price"]+++    it "Array and substring" $ do+      contents <- flexReadFile path+      let (symt, storaget) = getModel path contents unitName+      blockNameOf "tick" symt `shouldBe` "control_switches"+      blockNameOf "control_switches" symt `shouldBe` "control_switches"+      offsetOf "tick" symt `shouldBe` 7+      offsetOf "control_switches" symt `shouldBe` 0+      variablesOf "control_switches" storaget+        `shouldBe` ["control_switches", "tick"]++    it "Repeated equivalences" $ do+      contents <- flexReadFile path+      let (symTable, storageTable) = getModel path contents unitName++      blockNameOf "p6buf" symTable `shouldBe` "p6buf"+      blockNameOf "p6buf2" symTable `shouldBe` "p6buf"+      blockNameOf "p6uuid" symTable `shouldBe` "p6buf"++      offsetOf "p6buf" symTable `shouldBe` 0+      offsetOf "p6buf2" symTable `shouldBe` 0+      offsetOf "p6uuid" symTable `shouldBe` 0++      variablesOf "p6buf" storageTable `shouldBe` ["p6buf", "p6buf2", "p6uuid"]++  describe "Common" $ do++    let path      = "test/common.f"+        unitName1 = "suba"+        unitName2 = "subb"+        unitName3 = "subc"+        unitName4 = "subd"++    it "Basic common" $ do+      contents <- flexReadFile path+      let (symTable, storageTable) = getModel path contents unitName1+          commonName               = "reqnamecomn"+          commonNameEncoding       = "/" ++ commonName ++ "/"++      blockNameOf "reqname_a" symTable `shouldBe` commonNameEncoding+      blockNameOf "rcode_a" symTable `shouldBe` commonNameEncoding++      offsetOf "reqname_a" symTable `shouldBe` 0+      offsetOf "rcode_a" symTable `shouldBe` 448++      variablesOf commonNameEncoding storageTable+        `shouldBe` ["reqname_a", "rcode_a"]+      storageClassOf commonNameEncoding storageTable `shouldBe` Common++    it "Common and equivalance" $ do+      contents <- flexReadFile path+      let (symTable, storageTable) = getModel path contents unitName2+          commonName               = "reqnamecomn"+          commonNameEncoding       = "/" ++ commonName ++ "/"++      blockNameOf "reqname_b" symTable `shouldBe` commonNameEncoding+      blockNameOf "rcode_b" symTable `shouldBe` commonNameEncoding+      blockNameOf "ext" symTable `shouldBe` commonNameEncoding++      offsetOf "reqname_b" symTable `shouldBe` 0+      offsetOf "rcode_b" symTable `shouldBe` 448+      offsetOf "ext" symTable `shouldBe` 448++      variablesOf commonNameEncoding storageTable+        `shouldBe` ["reqname_b", "rcode_b", "ext"]+      storageClassOf commonNameEncoding storageTable `shouldBe` Common++    it "Common and variable with the same name" $ do+      contents <- flexReadFile path+      let (symTable, storageTable) = getModel path contents unitName3+          variableName             = "common_block_name"+          commonNameEncoding       = "/" ++ variableName ++ "/"++      blockNameOf "a" symTable `shouldBe` commonNameEncoding+      blockNameOf variableName symTable `shouldBe` commonNameEncoding+      blockNameOf "b" symTable `shouldBe` commonNameEncoding++      offsetOf "a" symTable `shouldBe` 0+      offsetOf variableName symTable `shouldBe` 4+      offsetOf "b" symTable `shouldBe` 8++      variablesOf commonNameEncoding storageTable+        `shouldBe` ["a", variableName, "b"]++    it "Common with dimension specifiers" $ do+      contents <- flexReadFile path+      let (symTable, storageTable) = getModel path contents unitName4+          commonName_1             = "common_block_1"+          commonNameEncoding_1     = "/" ++ commonName_1 ++ "/"+          commonName_2             = "common_block_2"+          commonNameEncoding_2     = "/" ++ commonName_2 ++ "/"++      blockNameOf "a" symTable `shouldBe` commonNameEncoding_1+      blockNameOf "b" symTable `shouldBe` commonNameEncoding_1+      blockNameOf "c" symTable `shouldBe` commonNameEncoding_1++      blockNameOf "d" symTable `shouldBe` commonNameEncoding_2+      blockNameOf "e" symTable `shouldBe` commonNameEncoding_2+      blockNameOf "f" symTable `shouldBe` commonNameEncoding_2++      -- TODO: Run those tests when nonstandard kind specifiers+      --       handling is implemented+      --offsetOf "a" symTable `shouldBe` 0+      --offsetOf "b" symTable `shouldBe` 80+      --offsetOf "c" symTable `shouldBe` 320++      --offsetOf "d" symTable `shouldBe` 0+      --offsetOf "e" symTable `shouldBe` 72+      --offsetOf "f" symTable `shouldBe` 152++      variablesOf commonNameEncoding_1 storageTable `shouldBe` ["a", "b", "c"]+      variablesOf commonNameEncoding_2 storageTable `shouldBe` ["d", "e", "f"]+++    it "Comman area with Structures" $ do+      contents <- flexReadFile "test/common_structs.f"+      let (symTable, storageTable) = getModel path contents "main"+          blankCommon              = "*blank_common*"+      blockNameOf "my_foo" symTable `shouldBe` blankCommon+      blockNameOf "my_foo_2" symTable `shouldBe` blankCommon+      blockNameOf "qux" symTable `shouldBe` blankCommon++      offsetOf "my_foo" symTable `shouldBe` 0+      offsetOf "my_foo_2" symTable `shouldBe` 1+      offsetOf "qux" symTable `shouldBe` 2++      variablesOf blankCommon storageTable+        `shouldBe` ["my_foo", "my_foo_2", "qux"]++    it "Common Layout" $ do+      let clPath = "test/common_layout.f"+      contents <- flexReadFile clPath+      let pumA            = getModel clPath contents "suba"+      let pumB            = getModel clPath contents "subb"+      let pumC            = getModel clPath contents "subc"++      let commonNameD     = "does_not_exist"+      let commonNameA     = "cname_a"+      let commonNameB     = "cname_b"+      let commonNameC     = "cname_c"+      let commonNameCc    = "cname_cc"+      let fflag           = getFlagType "falign-commons"+      let nflag           = getFlagType "fno-align-commons"+      let dflag           = getFlagType ""++      let commonLayoutDNE = getCommonLayout pumA commonNameD fflag+      let commonLayoutAf  = getCommonLayout pumA commonNameA fflag+      let commonLayoutAn  = getCommonLayout pumA commonNameA nflag+      let commonLayoutBf  = getCommonLayout pumB commonNameB fflag+      let commonLayoutBn  = getCommonLayout pumB commonNameB nflag+      let commonLayoutCf  = getCommonLayout pumC commonNameC fflag+      let commonLayoutCn  = getCommonLayout pumC commonNameC nflag+      let commonLayoutCc  = getCommonLayout pumC commonNameCc nflag++        -- only so long as default is fno-align-commons+      getCommonLayout pumA commonNameA nflag+        `shouldBe` getCommonLayout pumA commonNameA dflag+      getCommonLayout pumB commonNameB nflag+        `shouldBe` getCommonLayout pumB commonNameB dflag+      getCommonLayout pumC commonNameC nflag+        `shouldBe` getCommonLayout pumC commonNameC dflag+++      commonLayoutDNE `shouldBe` []+      commonLayoutAf+        `shouldBe` [ ("char_a", 0, TCharacter (CharLenInt 1) 1)+                   , ("int_b" , 4, TInteger 4)+                   , ("char_c", 8, TCharacter (CharLenInt 1) 1)+                   ]+      commonLayoutAn+        `shouldBe` [ ("char_a", 0, TCharacter (CharLenInt 1) 1)+                   , ("int_b" , 1, TInteger 4)+                   , ("char_c", 5, TCharacter (CharLenInt 1) 1)+                   ]+      commonLayoutBf+        `shouldBe` [ ( "char_array_a"+                     , 0+                     , TArray (TCharacter (CharLenInt 7) 1) (Just [(1, 65)])+                     )+                   , ("int_b"      , 456, TInteger 4)+                   , ("int_array_c", 456, TArray (TInteger 4) (Just [(1, 10)]))+                   ]+      commonLayoutBn+        `shouldBe` [ ( "char_array_a"+                     , 0+                     , TArray (TCharacter (CharLenInt 7) 1) (Just [(1, 65)])+                     )+                   , ("int_b"      , 455, TInteger 4)+                   , ("int_array_c", 455, TArray (TInteger 4) (Just [(1, 10)]))+                   ]+      commonLayoutCf+        `shouldBe` [ ("int_a", 0, TInteger 4)+                   , ("int_c", 4, TInteger 4)+                   , ("int_b", 8, TInteger 4)+                   ]+      commonLayoutCn+        `shouldBe` [ ("int_a", 0, TInteger 4)+                   , ("int_c", 4, TInteger 4)+                   , ("int_b", 8, TInteger 4)+                   ]+      commonLayoutCc `shouldBe` [("int_d", 0, TInteger 4)]++  describe "Dummy Argument" $ do++    let path     = "test/dummy_argument_storage.f"+        unitName = "state"++    it "Dummy variables are not in storage" $ do+      contents <- flexReadFile path+      let (_, storageTable) = getModel path contents unitName++      let varList           = variablesOf "c" storageTable+      "temp" `elem` varList `shouldBe` False+      "f" `elem` varList `shouldBe` False+      "c" `elem` varList `shouldBe` True++  describe "Common Area with Equivalence" $ do++    let path = "test/common_equivalence.f"+        run_test unitName commonName size = do+          contents <- flexReadFile path+          let (symTable, storageTable) = getModel path contents unitName+              varList                  = variablesOf commonName storageTable++          blockSizeOf commonName storageTable `shouldBe` size++          blockNameOf "var1" symTable `shouldBe` commonName+          blockNameOf "var2" symTable `shouldBe` commonName+          blockNameOf "var3" symTable `shouldBe` commonName++          "var1" `elem` varList `shouldBe` True+          "var2" `elem` varList `shouldBe` True+          "var3" `elem` varList `shouldBe` True+          storageClassOf commonName storageTable `shouldBe` Common+++    it "Variables are in the common area eq1" $ run_test "eq1" "/common1/" 12+    it "Variables are in the common area eq2" $ run_test "eq2" "/common2/" 12+    it "Variables are in the common area eq3" $ run_test "eq3" "/common3/" 12+    it "Variables are in the common area eq4" $ run_test "eq4" "/common4/" 12+    it "Variables are in the common area eq5" $ run_test "eq5" "/common5/" 16+
+ test/StructureTableSpec.hs view
@@ -0,0 +1,228 @@+module StructureTableSpec where++import qualified Data.Map                      as M+import           Data.Generics.Uniplate.Data++import           Test.Hspec++import           Language.Fortran.Analysis      ( Analysis )+import           Language.Fortran.AST           ( ProgramUnit+                                                , Statement(..)+                                                , Expression(..)+                                                )+import           Language.Fortran.Extras+                                                ( allPU )+import           Language.Fortran.Extras.Test+                                                ( getTestProgramAnalysis )++import           Language.Fortran.Vars.StructureTable+                                                ( StructureTable+                                                , collectStructures+                                                , StructureTableEntry(..)+                                                , hasEntry+                                                )+import           Language.Fortran.Vars.SymbolTable+                                                ( collectSymbols )+import           Language.Fortran.Vars.Types+                                                ( SymbolTable+                                                , Type(..)+                                                , SemType(..)+                                                , CharacterLen(..)+                                                )+import           Language.Fortran.Vars.TypeCheck+                                                ( typeOf )++getStructureTable :: String -> IO StructureTable+getStructureTable file =+  testStructureTable file $ \_ structTable _ -> return structTable++testStructureTable+  :: String+  -> (ProgramUnit (Analysis ()) -> StructureTable -> SymbolTable -> IO a)+  -> IO a+testStructureTable fp logic = do+  pf <- getTestProgramAnalysis fp+  let pu = head $ allPU pf+  testStructureTablePU pu logic++testStructureTablePU+  :: ProgramUnit (Analysis ())+  -> (ProgramUnit (Analysis ()) -> StructureTable -> SymbolTable -> IO a)+  -> IO a+testStructureTablePU pu logic = do+  let symbolTable = collectSymbols pu+      structTable = collectStructures symbolTable pu+  logic pu structTable symbolTable++spec :: Spec+spec = do+  describe "Field tests" $ do+    it "test single field" $ do+      structTable <- getStructureTable "test/structure_table/basic_structure.f"+      let expStruct = M.fromList [("foo", [FieldEntry "bar" (TInteger 2)])]+      structTable `shouldBe` expStruct++    it "test structure referenced in structure" $ do+      structTable <- getStructureTable "test/structure_table/structure2.f"+      let expStruct = M.fromList+            [ ("foo", [FieldEntry "bar" (TInteger 8)])+            , ( "baz"+              , [ FieldEntry "qux"  (TCustom "foo")+                , FieldEntry "quux" (TCharacter (CharLenInt 10) 1)+                ]+              )+            ]+      structTable `shouldBe` expStruct++    it "multiple layer structures" $ do+      structTable <- getStructureTable "test/structure_table/structure3.f"+      let+        graultEntries = [FieldEntry "garply" (TCustom "quuz")]+        quuzEntries =+          [FieldEntry "corge" (TCustom "baz"), FieldEntry "foobar" (TInteger 2)]+        fooEntries = [FieldEntry "bar" (TInteger 8)]+        bazEntries =+          [ FieldEntry "qux"  (TCustom "foo")+          , FieldEntry "quux" (TCharacter (CharLenInt 10) 1)+          ]+      structTable `shouldBe` M.fromList+        [ ("grault", graultEntries)+        , ("quuz"  , quuzEntries)+        , ("foo"   , fooEntries)+        , ("baz"   , bazEntries)+        ]++    it "structures and subscripts" $ do+      pending+    {- TODO: 2021-09-06: fails with fortran-src ErrorCall: Use of varName on+        non-variable+      pf <- getTestProgramAnalysis "test/structure_table/structure4.f"+      let pus         = allPU pf+          sts         = map collectSymbols pus+          strctTables = zipWith collectStructures sts pus+      head strctTables `shouldBe` M.fromList+        [ ( "str_inner"+          , [FieldEntry "inner_arr" (TArray (TInteger 1) (Just [(1, 5)]))]+          )+        ]+      (strctTables !! 1) `shouldBe` M.fromList+        [ ( "str_inner"+          , [FieldEntry "inner_arr" (TArray (TInteger 2) (Just [(1, 5)]))]+          )+        ]+      (strctTables !! 2) `shouldBe` M.fromList+        [ ( "str_inner"+          , [FieldEntry "inner_arr" (TArray (TInteger 1) (Just [(1, 3)]))]+          )+        , ( "str_outer"+          , [ FieldEntry "outer_arr"+                         (TArray (TCustom "str_inner") (Just [(1, 5)]))+            ]+          )+        ]+      -}+++  describe "Union tests" $ do+    it "test unions in a structure" $ do+      structTable <- getStructureTable "test/structure_table/union_struct.f"+      let expStruct = M.fromList+            [ ( "foo"+              , [ UnionEntry+                    [ [FieldEntry "bar" (TInteger 4)]+                    , [ FieldEntry "baz" (TInteger 2)+                      , FieldEntry "qux" (TInteger 8)+                      ]+                    ]+                ]+              )+            ]+      structTable `shouldBe` expStruct++    it "test size of union fields" $ do+      structTable <- getStructureTable "test/structure_table/union_struct2.f"+      let expStruct =+            M.fromList [("quux", [FieldEntry "quuz" (TCustom "foo")])]+      M.lookup "quux" structTable `shouldBe` M.lookup "quux" expStruct++  describe "Check look ups" $ do+    it "test hasEntry"+      $ testStructureTable "test/structure_table/structure3.f"+      $ \_ structTable _ -> do+          let Just test = M.lookup "foo" structTable+          hasEntry "bar" test `shouldBe` Right (TInteger 8)+          let Just grault = M.lookup "grault" structTable+          hasEntry "garply" grault `shouldBe` Right (TCustom "quuz")++    it "Union data ref"+      $ testStructureTable "test/structure_table/union_struct2.f"+      $ \_ structTable _ -> do+          let Just test = M.lookup "quux" structTable+          hasEntry "quuz" test `shouldBe` Right (TCustom "foo")+          let Just foo = M.lookup "foo" structTable+          hasEntry "baz" foo `shouldBe` Right (TInteger 2)+          hasEntry "bar" foo `shouldBe` Right (TInteger 4)++    it "Get type of nested data reference expression"+      $ testStructureTable "test/structure_table/structure3.f"+      $ \pf structTable st -> do+          let expr =+                head+                  [ e+                  | e@ExpDataRef{} <-+                    universeBi pf :: [Expression (Analysis ())]+                  ]+          -- check looking up the expression succeeds and gives the correct type+          typeOf structTable st expr `shouldBe` Right (TCharacter (CharLenInt 10) 1)++    it "Get type of union data reference expression"+      $ testStructureTable "test/structure_table/union_struct3.f"+      $ \pf structTable st -> do+          let expr =+                head+                  [ e+                  | e@ExpDataRef{} <-+                    universeBi pf :: [Expression (Analysis ())]+                  ]+          typeOf structTable st expr `shouldBe` Right (TCharacter (CharLenInt 13) 1)++    it "Get combination of data references and subscripts" $ do+      pending+    {- TODO: 2021-09-06: fails with fortran-src ErrorCall: Use of varName on+        non-variable+      pf <- getTestProgramAnalysis "test/structure_table/structure4.f"+      let pus = allPU pf+          logics+            :: [  ProgramUnit (Analysis ())+               -> StructureTable+               -> SymbolTable+               -> IO ()+               ]+          logics = map+            (\x pu structTable st -> do+              let expr = head+                    [ e+                    | (StExpressionAssign _ _ e _) <-+                      universeBi pu :: [Statement (Analysis ())]+                    ]+              typeOf structTable st expr `shouldBe` x+            )+            [ Right (TInteger 1)+            , Right (TInteger 2)+            , Right (TArray (TInteger 1) (Just [(1, 3)]))+            ]+      mapM_ (uncurry testStructureTablePU) $ zip pus logics+      -}++    it "Character substrings" $ do+      pf <- getTestProgramAnalysis "test/structure_table/structure5.f"+      let pus     = allPU pf+          results = [Right (TCharacter (CharLenInt 1) 1), Right (TLogical 2)]+          logic res pu strt symt = do+            let expr = head+                  [ e+                  | (StExpressionAssign _ _ e _) <-+                    universeBi pu :: [Statement (Analysis ())]+                  ]+            typeOf strt symt expr `shouldBe` res+      mapM_ (uncurry testStructureTablePU) $ zip pus (map logic results)
+ test/SymbolTableSpec.hs view
@@ -0,0 +1,602 @@+module SymbolTableSpec where++import           Control.Exception              ( evaluate )+import           Language.Fortran.Extras.Analysis+                                                ( versionedExpandedProgramAnalysis+                                                )+import           Language.Fortran.Util.Files+                                                ( flexReadFile )+import           Language.Fortran.Extras.ProgramFile+                                                ( versionedProgramFile )+import           Data.ByteString.Char8          ( ByteString )+import qualified Data.Map                      as M+import           Language.Fortran.AST           ( ProgramUnitName(..) )+import           Language.Fortran.ParserMonad   ( FortranVersion(..) )+import           Language.Fortran.Analysis      ( initAnalysis )+import           Test.Hspec++import           Language.Fortran.Vars ( programFileModel )+import           Language.Fortran.Vars.Types+                                                ( SymbolTableEntry(..)+                                                , Type(..)+                                                , SemType(..)+                                                , CharacterLen(..)+                                                , ExpVal(..)+                                                , SymbolTable+                                                )++getSymTable :: String -> ByteString -> String -> SymbolTable+getSymTable p c n =+  let pf  = initAnalysis $ versionedProgramFile Fortran77Legacy p c+      pfm = programFileModel pf+  in  case M.lookup (Named n) pfm of+        Just (st, _) -> st+        Nothing      -> error $ "Failed to lookup unit: " ++ n++getSymTableIO :: String -> ByteString -> String -> IO SymbolTable+getSymTableIO p c n = do+  let incls = ["test"]+  pa <- versionedExpandedProgramAnalysis Fortran77Legacy incls p c+  let pfm = programFileModel pa+  case M.lookup (Named n) pfm of+    Just (st, _) -> return st+    Nothing      -> error $ "Failed to lookup unit: " ++ n++valueOf :: String -> SymbolTable -> ExpVal+valueOf name symTable =+  let Just entry = M.lookup name symTable+  in  case entry of+        SParameter _ pv -> pv+        _               -> error (name ++ " is not a parameter.")++typeOf :: String -> SymbolTable -> Type+typeOf name symTable =+  let Just entry = M.lookup name symTable+  in  case entry of+        SParameter ty _ -> ty+        SVariable  ty _ -> ty+        SDummy ty       -> ty+        _               -> error (name ++ " is not an Entry that has type")++dimensionOf :: String -> SymbolTable -> Maybe [(Int, Int)]+dimensionOf name symTable =+  let Just entry = M.lookup name symTable+  in  case entry of+        SVariable (TArray _ dims) _ -> dims+        SDummy (TArray _ dims) -> dims+        _ -> error (name ++ " is not an Entry that has static dimension")++dummyOf :: String -> M.Map String SymbolTableEntry -> String+dummyOf name symTable =+  let Just entry = M.lookup name symTable+  in  case entry of+        SDummy (TArray (TCharacter CharLenStar _) Nothing) ->+          "DummyArrayDynamicCharacter"+        SDummy (TCharacter CharLenStar _) -> "DummyDynamicCharacter"+        SDummy (TArray _ Nothing  ) -> "DummyDynamicArray"+        SDummy (TArray _ (Just _) ) -> "DummyStaticArray"+        SDummy _                    -> "DummyStaticScalar"+        v -> error (name ++ " is not a DummyVariableEntry it is a " ++ show v)++isDummy :: String -> SymbolTable -> Bool+isDummy name symTable = case M.lookup name symTable of+  Just SDummy{} -> True+  _             -> False++isDynamic :: String -> SymbolTable -> Bool+isDynamic name symTable = case M.lookup name symTable of+  Just (SVariable ty _) -> case ty of+    TArray (TCharacter CharLenStar _) _ -> True+    TArray _ Nothing   -> True+    TCharacter CharLenStar _ -> True+    _                  -> False+  _ -> False++spec :: Spec+spec = do++  describe "Constant expression evaluation: " $ do++    let path     = "test/symbol_table/constant_expression.f"+        unitName = "foo"++    it "Only parameter statement, no declaration" $ do+      contents <- flexReadFile path+      let symTable = getSymTable path contents unitName+      valueOf "a" symTable `shouldBe` Int 10++    it "declaration after parameter statement" $ do+      contents <- flexReadFile path+      let symTable = getSymTable path contents unitName+      valueOf "b" symTable `shouldBe` Int 10++    it "declaration before parameter statement" $ do+      contents <- flexReadFile path+      let symTable = getSymTable path contents unitName+      valueOf "r" symTable `shouldBe` Real 3.14++    it "Integer arithmetics with variable" $ do+      contents <- flexReadFile path+      let symTable = getSymTable path contents unitName+      mapM_+        (\(var, val) -> valueOf var symTable `shouldBe` Int val)+        [("d1", 12), ("d2", 8), ("d3", 20), ("d4", 3), ("d5", -10), ("d6", 10)]++    it "Float arithmetics with variable" $ do+      contents <- flexReadFile path+      let symTable = getSymTable path contents unitName+      mapM_+        (\(var, val) -> valueOf var symTable `shouldBe` Real val)+        [ ("pi", 3.14)+        , ("e1", 6.28)+        , ("e2", 0.0)+        , ("e3", 6.28)+        , ("e4", 1.57)+        , ("e5", -3.14)+        , ("e6", 3.14)+        ]++    it "Double precision constant" $ do+      contents <- flexReadFile path+      let symTable = getSymTable path contents unitName+      valueOf "eps" symTable `shouldBe` Real 1.0e-12++    it "Logical expression" $ do+      contents <- flexReadFile path+      let symTable = getSymTable path contents unitName+      valueOf "f" symTable `shouldBe` Logical True+      valueOf "f1" symTable `shouldBe` Logical False++    it "String expression" $ do+      contents <- flexReadFile path+      let symTable = getSymTable path contents unitName+      valueOf "rcsid" symTable `shouldBe` Str "DEADBEEF"++    it "Intrinsics" $ do+      contents <- flexReadFile path+      let symTable = getSymTable path contents unitName+      valueOf "d7" symTable `shouldBe` Int 9+      valueOf "d8" symTable `shouldBe` Int 60+      valueOf "d9" symTable `shouldBe` Int 70+      valueOf "e7" symTable `shouldBe` Real 1.2+      valueOf "e8" symTable `shouldBe` Real 2+      valueOf "c1" symTable `shouldBe` Str "A"+      valueOf "eol" symTable `shouldBe` Str "\r\n"+      valueOf "i1" symTable `shouldBe` Int (-2)+      valueOf "i2" symTable `shouldBe` Int 42+      valueOf "i3" symTable `shouldBe` Int (-42)+      valueOf "i4" symTable `shouldBe` Int 0+      valueOf "i5" symTable `shouldBe` Int 1+      valueOf "i6" symTable `shouldBe` Int 1+      valueOf "i7" symTable `shouldBe` Int (-1)+      valueOf "i8" symTable `shouldBe` Int (-1)+      valueOf "i9" symTable `shouldBe` Int 16+++  describe "Type and Kind: " $ do++    let path     = "test/symbol_table/type_and_kind.f"+        unitName = "foo"++    it "Byte" $ do+      contents <- flexReadFile path+      let symTable = getSymTable path contents unitName+      typeOf "b" symTable `shouldBe` TByte 1++    it "Character" $ do+      contents <- flexReadFile path+      let symTable = getSymTable path contents unitName+      typeOf "c" symTable `shouldBe` TCharacter (CharLenInt 1) 1+      typeOf "c1" symTable `shouldBe` TCharacter (CharLenInt 7) 1+      typeOf "c2" symTable `shouldBe` TCharacter (CharLenInt 7) 1+      typeOf "c3" symTable `shouldBe` TCharacter (CharLenInt 11) 1+      typeOf "c4" symTable `shouldBe` TCharacter (CharLenInt 23) 1+      valueOf "c4" symTable `shouldBe` Str "Hello right back at you"+++    it "Integer" $ do+      contents <- flexReadFile path+      let symTable = getSymTable path contents unitName+      mapM_ (\(v, k) -> typeOf v symTable `shouldBe` TInteger k)+            [("i", 4), ("i2", 2), ("i4", 4), ("i8", 8)]++    it "Logical" $ do+      contents <- flexReadFile path+      let symTable = getSymTable path contents unitName+      mapM_ (\(v, k) -> typeOf v symTable `shouldBe` TLogical k)+            [("l", 4), ("l1", 1), ("l2", 2), ("l4", 4), ("l8", 8)]++    it "Real and Double Precision" $ do+      contents <- flexReadFile path+      let symTable = getSymTable path contents unitName+      typeOf "r" symTable `shouldBe` TReal 4+      typeOf "r4" symTable `shouldBe` TReal 4+      typeOf "r8" symTable `shouldBe` TReal 8++    it "Double Precision" $ do+      contents <- flexReadFile path+      let symTable = getSymTable path contents unitName+      typeOf "dp" symTable `shouldBe` TReal 8++    it "Complex" $ do+      contents <- flexReadFile path+      let symTable = getSymTable path contents unitName+      typeOf "comp" symTable `shouldBe` TComplex 8+      typeOf "comp8" symTable `shouldBe` TComplex 8+      typeOf "comp16" symTable `shouldBe` TComplex 16++    it "Double Complex" $ do+      contents <- flexReadFile path+      let symTable = getSymTable path contents unitName+      typeOf "dcomp" symTable `shouldBe` TComplex 16++--    TODO: Uncomment this test when implementing nonstandard kind handling+    it "Nonstandard kind" $ do+      contents <- flexReadFile path+      let symTable = getSymTable path contents unitName+      typeOf "i2_ns" symTable `shouldBe` TInteger 2+      typeOf "i4_ns" symTable `shouldBe` TInteger 4+      typeOf "i8_ns" symTable `shouldBe` TInteger 8+      typeOf "r2_ns" symTable `shouldBe` TReal 2+      typeOf "r8_ns" symTable `shouldBe` TReal 8+      typeOf "l2_ns" symTable `shouldBe` TLogical 2+      typeOf "l8_ns" symTable `shouldBe` TLogical 8++    it "Nonstandard kind array" $ do+      contents <- flexReadFile path+      let symTable = getSymTable path contents unitName+      typeOf "i2_arr" symTable+        `shouldBe` TArray (TInteger 2) (Just [(1, 3), (1, 4)])+      typeOf "i8_arr" symTable+        `shouldBe` TArray (TInteger 8) (Just [(1, 3), (1, 4)])++  describe "Dimension: " $ do++    let path     = "test/symbol_table/dimension.f"+        unitName = "foo"++    it "Single dimension" $ do+      contents <- flexReadFile path+      let symTable = getSymTable path contents unitName+      dimensionOf "a" symTable `shouldBe` Just [(1, 10)]+      dimensionOf "b" symTable `shouldBe` Just [(-3, 5)]+      dimensionOf "c" symTable `shouldBe` Just [(1, 45)]++    it "Multi-dimension" $ do+      contents <- flexReadFile path+      let symTable = getSymTable path contents unitName+      dimensionOf "a2" symTable `shouldBe` Just [(1, 5), (1, 5)]+      dimensionOf "a3" symTable `shouldBe` Just [(1, 5), (1, 5), (1, 5)]+      dimensionOf "a4" symTable `shouldBe` Just [(1, 5), (1, 5), (1, 5), (1, 5)]+      dimensionOf "a5" symTable+        `shouldBe` Just [(1, 5), (1, 5), (1, 5), (1, 5), (1, 5)]+      dimensionOf "a6" symTable+        `shouldBe` Just [(1, 5), (1, 5), (1, 5), (1, 5), (1, 5), (1, 5)]+      dimensionOf "a7" symTable `shouldBe` Just+        [(1, 5), (1, 5), (1, 5), (1, 5), (1, 5), (1, 5), (1, 5)]++    it "Dimension statement" $ do+      contents <- flexReadFile path+      let symTable = getSymTable path contents unitName+      dimensionOf "d" symTable `shouldBe` Just [(1, 10)]+      dimensionOf "m" symTable `shouldBe` Just [(1, 10), (1, 20)]++    it "String array" $ do+      contents <- flexReadFile path+      let symTable = getSymTable path contents unitName+      dimensionOf "reqname" symTable `shouldBe` Just [(1, 64)]+      dimensionOf "test" symTable `shouldBe` Just [(1, 3), (1, 4)]++    it "Integer array" $ do+      contents <- flexReadFile path+      let symTable = getSymTable path contents unitName+      dimensionOf "itest1" symTable `shouldBe` Just [(1, 3), (1, 4)]+      dimensionOf "itest2" symTable `shouldBe` Just [(1, 3), (1, 4)]+++    it "Dimension declaration within COMMON - as ExpSubscript" $ do+      contents <- flexReadFile path+      let symTable = getSymTable path contents unitName++      dimensionOf "arr_before_range" symTable `shouldBe` Just [(8, 10)]+      dimensionOf "arr_before_multi" symTable+        `shouldBe` Just [(1, 12), (14, 16)]++      dimensionOf "arr_after_range" symTable `shouldBe` Just [(22, 24)]+      dimensionOf "arr_after_multi" symTable `shouldBe` Just [(1, 26), (28, 30)]++    it "Dimension declaration within COMMON - as ExpFunctionCall" $ do+      contents <- flexReadFile path+      let symTable = getSymTable path contents unitName++      dimensionOf "arr_before_standard_kind" symTable `shouldBe` Just [(1, 2)]+      dimensionOf "arr_before_simple" symTable `shouldBe` Just [(1, 4)]+      dimensionOf "arr_before_nonstandard_kind" symTable+        `shouldBe` Just [(1, 6)]++      dimensionOf "arr_after_standard_kind" symTable `shouldBe` Just [(1, 18)]+      dimensionOf "arr_after_simple" symTable `shouldBe` Just [(1, 20)]+      dimensionOf "arr_after_nonstandard_kind" symTable `shouldBe` Just [(1, 2)]++  describe "Dummy Argument: " $ do++    let path     = "test/symbol_table/dummy_argument_symbol.f"+        unitName = "sub"++    it "Dummy variables - static" $ do+      contents <- flexReadFile path+      let symTable = getSymTable path contents unitName++      dummyOf "stscalar1" symTable `shouldBe` "DummyStaticScalar"+      typeOf "stscalar1" symTable `shouldBe` TInteger 4++      dummyOf "starr1" symTable `shouldBe` "DummyStaticArray"+      typeOf "starr1" symTable `shouldBe` TArray (TInteger 4) (Just [(1, 5)])++    it "Dummy variables - dynamic" $ do+      contents <- flexReadFile path+      let symTable = getSymTable path contents unitName++      dummyOf "dynscalar1" symTable `shouldBe` "DummyDynamicCharacter"++      dummyOf "dynarr1" symTable `shouldBe` "DummyDynamicArray"+      typeOf "dynarr1" symTable `shouldBe` TArray (TInteger 4) Nothing++      dummyOf "dynarr2" symTable `shouldBe` "DummyDynamicArray"+      typeOf "dynarr2" symTable `shouldBe` TArray (TInteger 4) Nothing++      dummyOf "dynarr3" symTable `shouldBe` "DummyDynamicArray"+      typeOf "dynarr3" symTable `shouldBe` TArray (TInteger 4) Nothing++      dummyOf "dynarr4" symTable `shouldBe` "DummyDynamicArray"+      typeOf "dynarr4" symTable `shouldBe` TArray (TInteger 4) Nothing++      evaluate (dummyOf "dynarr5" symTable) `shouldThrow` anyErrorCall+      typeOf "dynarr5" symTable `shouldBe` TArray (TInteger 4) Nothing++  describe "Dummy array of dynamically-sized strings" $ do+    let path     = "test/symbol_table/dummy_array_dynamic_strings.f"+        unitName = "sub"++    it "Statically-sized dummy array" $ do+      contents <- flexReadFile path+      let symTable = getSymTable path contents unitName++      dummyOf "starrdynstring" symTable `shouldBe` "DummyArrayDynamicCharacter"++    it "Dynamically-sized dummy array" $ do+      contents <- flexReadFile path+      let symTable = getSymTable path contents unitName++      dummyOf "dynarrdynstring" symTable `shouldBe` "DummyArrayDynamicCharacter"++  describe "Include: " $ do++    let path           = "test/symbol_table/include.f"+        path_interface = "test/symbol_table/interface-include.f"+        unitName       = "main"++    it "Simple include" $ do+      contents <- flexReadFile path+      symTable <- getSymTableIO path contents unitName++      valueOf "var_from_includee" symTable `shouldBe` Str "includee"++    it "Interface include" $ do+      pending+    {- TODO: 2021-09-06: fails with fortran-src ParseError: interface.inc:+        lexing failed+      contents <- flexReadFile path_interface+      symTable <- getSymTableIO path_interface contents unitName++      typeOf "sespit_get_psetdt" symTable+        `shouldBe` TArray (TInteger 2) (Just [(1, 3)])+      typeOf "sespit_get_psetdt2_e" symTable `shouldBe` TInteger 2+      -- Check we don't pick up subroutines or arguments+      M.member "index" symTable `shouldBe` False+      M.member "sespit_set_trdnum" symTable `shouldBe` False+    -}++  describe "BOZ constants: " $ do++    let path_general = "test/boz_constants/boz_general.f"+        path_integer = "test/boz_constants/boz_integer.f"+        unitName     = "main"++    it "Suffix notation" $ do+      contents <- flexReadFile path_general+      let symTable = getSymTable path_general contents unitName++      valueOf "boz_suffix_binary" symTable `shouldBe` Int 1+      valueOf "boz_suffix_octal" symTable `shouldBe` Int 1+      valueOf "boz_suffix_hex_x" symTable `shouldBe` Int 1+      valueOf "boz_suffix_hex_z" symTable `shouldBe` Int 1++    it "Prefix notation" $ do+      contents <- flexReadFile path_general+      let symTable = getSymTable path_general contents unitName++      valueOf "boz_prefix_binary" symTable `shouldBe` Int 1+      valueOf "boz_prefix_octal" symTable `shouldBe` Int 1+      valueOf "boz_prefix_hex_x" symTable `shouldBe` Int 1+      valueOf "boz_prefix_hex_z" symTable `shouldBe` Int 1++    it "Supported types" $ do+      contents <- flexReadFile path_general+      let symTable = getSymTable path_general contents unitName++      valueOf "boz_integer" symTable `shouldBe` Int 1++    it "Type Integer" $ do+      contents <- flexReadFile path_integer+      let symTable = getSymTable path_integer contents unitName++      valueOf "i2_1" symTable `shouldBe` Int 1+      valueOf "i2_2" symTable `shouldBe` Int 16+      valueOf "i2_3" symTable `shouldBe` Int 256+      valueOf "i2_4" symTable `shouldBe` Int 4096+      valueOf "i2_5" symTable `shouldBe` Int 32767+      valueOf "i2_6" symTable `shouldBe` Int (-32768)+      valueOf "i2_7" symTable `shouldBe` Int (-32767)+      valueOf "i2_8" symTable `shouldBe` Int 0+      valueOf "i2_9" symTable `shouldBe` Int 16+      valueOf "i2_10" symTable `shouldBe` Int 16++  describe "Floating point types" $ do+    it "Can parse all floating point types" $ do+      let path     = "test/symbol_table/floating_points.f"+          unitName = "floating_points"+      contents <- flexReadFile path+      let symTable = getSymTable path contents unitName+      valueOf "a" symTable `shouldBe` Real 1.0+      valueOf "b" symTable `shouldBe` Real 2.0+      valueOf "c" symTable `shouldBe` Real 3.0+      valueOf "d" symTable `shouldBe` Real 4.0+      valueOf "e" symTable `shouldBe` Real 0.5+      valueOf "f" symTable `shouldBe` Real 6.0+      valueOf "g" symTable `shouldBe` Real 0.7++    it "Doesn't accept bad formats" $ do+      let path     = "test/symbol_table/bad_floating_point.f"+          unitName = "bad_floating_point"+      contents <- flexReadFile path+      let symTable = getSymTable path contents unitName+      print (valueOf "a" symTable) `shouldThrow` anyException++  describe "Parameter statement" $ do+    let errStr t = "Invalid PARAMETER statement for symbol \'" ++ t ++ "\'"+    it "Throws on conflicting PARAMETER attribute" $ do+      let path     = "test/symbol_table/multi_parameter_defs.f"+          unitName = "multi_parameter_defs"+      contents <- flexReadFile path+      let symTable = getSymTable path contents unitName+      print (typeOf "a" symTable) `shouldThrow` errorCall (errStr "a")++    it "Can handle declarations and parameter statements" $ do+      let path     = "test/symbol_table/parameter_stmt.f"+          unitName = "parameter_stmt"+      contents <- flexReadFile path+      let symTable = getSymTable path contents unitName+      typeOf "c1" symTable `shouldBe` TCharacter (CharLenInt 7) 1+      typeOf "c2" symTable `shouldBe` TCharacter (CharLenInt 11) 1++      typeOf "i" symTable `shouldBe` TInteger 4+      typeOf "i2" symTable `shouldBe` TInteger 2+      typeOf "i4" symTable `shouldBe` TInteger 4+      typeOf "i8" symTable `shouldBe` TInteger 8++      typeOf "r" symTable `shouldBe` TReal 4+      typeOf "r2" symTable `shouldBe` TReal 2+      typeOf "r4" symTable `shouldBe` TReal 4+      typeOf "r8" symTable `shouldBe` TReal 8++  describe "Multiple declarations" $ do+    it "Can handle multiple declarations of the same type and kind" $ do+      let path     = "test/symbol_table/multi_declarations.f"+          unitName = "barfoo"+      contents <- flexReadFile path+      let symTable = getSymTable path contents unitName+      typeOf "foobar" symTable `shouldBe` TLogical 4+      typeOf "str" symTable `shouldBe` TCharacter (CharLenInt 5) 1++    let+      errStr t =+        "The second declaration of 'a' at line (3:19)-(3:19) does not have the same "+          ++ t+          ++ " as the first"+    it "Throws on conflicting types" $ do+      let path     = "test/symbol_table/conflicting_type_defs.f"+          unitName = "conflicting_type_defs"+      contents <- flexReadFile path+      let symTable = getSymTable path contents unitName+      print (typeOf "a" symTable) `shouldThrow` errorCall (errStr "type")+    it "Overriding kinds" $ do+      let path     = "test/symbol_table/overriding_kind_defs.f"+          unitName = "overriding_kind_defs"+      contents <- flexReadFile path+      let symTable = getSymTable path contents unitName+      typeOf "a" symTable `shouldBe` TInteger 4+      typeOf "b" symTable `shouldBe` TCharacter (CharLenInt 10) 1+      typeOf "c" symTable `shouldBe` TInteger 4+      typeOf "d" symTable `shouldBe` TCharacter (CharLenInt 10) 1+      typeOf "e" symTable `shouldBe` TCharacter (CharLenInt 5) 1++  describe "Function variables" $ do+    let path = "test/symbol_table/function_variable.f"+    it "Can handle variable from siganture-typed function (default kind)" $ do+      contents <- flexReadFile path+      let unitName = "f1"+          symTable = getSymTable path contents unitName+      typeOf "f1" symTable `shouldBe` TLogical 4+    it "Can handle variable from siganture-typed function (specified kind)" $ do+      contents <- flexReadFile path+      let unitName = "f2"+          symTable = getSymTable path contents unitName+      typeOf "f2" symTable `shouldBe` TLogical 2+    it "Can handle variable from siganture-typed function (character type)" $ do+      contents <- flexReadFile path+      let unitName = "f3"+          symTable = getSymTable path contents unitName+      typeOf "f3" symTable `shouldBe` TCharacter (CharLenInt 5) 1+    it "Can handle variable from body-typed function" $ do+      contents <- flexReadFile path+      let unitName = "f4"+          symTable = getSymTable path contents unitName+      typeOf "f4" symTable `shouldBe` TLogical 4+    it "Can handle duplicate declarations in signature and function body" $ do+      contents <- flexReadFile path+      let unitName = "f5"+          symTable = getSymTable path contents unitName+      typeOf "f5" symTable `shouldBe` TInteger 4+    it+        "Can handle duplicate declarations in signature and function body - String"+      $ do+          contents <- flexReadFile path+          let unitName = "f6"+              symTable = getSymTable path contents unitName+          typeOf "f6" symTable `shouldBe` TCharacter (CharLenInt 6) 1+    it "Can handle dynamic character function signature" $ do+      contents <- flexReadFile path+      let unitName = "f7"+          symTable = getSymTable path contents unitName+      typeOf "f7" symTable `shouldBe` TCharacter CharLenStar 1++  describe "Dynamic variables" $ do+    let path = "test/symbol_table/dynamic_variables.f"++    it "Dynamic character" $ do+      contents <- flexReadFile path+      let symTable = getSymTable path contents "f1"+      typeOf "c" symTable `shouldBe` TCharacter CharLenStar 1+      isDynamic "c" symTable `shouldBe` True++    it "Dynamic array" $ do+      contents <- flexReadFile path+      let symTable = getSymTable path contents "f2"+      typeOf "arr" symTable `shouldBe` TArray (TInteger 4) Nothing+      isDynamic "arr" symTable `shouldBe` True++    it "Dynamic character Dynamic array" $ do+      contents <- flexReadFile path+      let st = getSymTable path contents "f3"+      typeOf "arr" st `shouldBe` TArray (TCharacter CharLenStar 1) Nothing+      isDynamic "arr" st `shouldBe` True++    it "Dynamic character static array" $ do+      contents <- flexReadFile path+      let st = getSymTable path contents "f4"+      typeOf "arr" st `shouldBe` TArray (TCharacter CharLenStar 1) (Just [(1, 5)])+      isDynamic "arr" st `shouldBe` True++    it "Static character dynamic array" $ do+      contents <- flexReadFile path+      let st = getSymTable path contents "f5"+      typeOf "arr" st `shouldBe` TArray (TCharacter (CharLenInt 5) 1) Nothing+      isDynamic "arr" st `shouldBe` True++    it "Dummy not dynamic" $ do+      contents <- flexReadFile path+      let st = getSymTable path contents "f6"+      typeOf "arr" st `shouldBe` TArray (TCharacter CharLenStar 1) Nothing+      isDynamic "arr" st `shouldBe` False+      isDummy "arr" st `shouldBe` True
+ test/TypeCheckSpec.hs view
@@ -0,0 +1,376 @@+module TypeCheckSpec where++import           Test.Hspec+import           Control.Monad                  ( zipWithM_ )+import           Data.Either                    ( isLeft )+import           Data.List                      ( find )+import qualified Data.Map                      as M+import           Data.Data                      ( Data )+import           Language.Fortran.Extras+                                                ( allPUS+                                                , allPU+                                                )+import           Language.Fortran.Extras.Test+                                                ( getTestProgramAnalysis )+import           Language.Fortran.AST+import           Language.Fortran.Analysis      ( stripAnalysis )+import           Language.Fortran.Vars ( programFileModel )+import           Language.Fortran.Vars.Types+                                                ( Type(..)+                                                , SemType(..)+                                                , CharacterLen(..) )+import           Language.Fortran.Vars.TypeCheck+                                                ( typeOf+                                                , TypeOf+                                                , TypeError(..)+                                                )+import           Language.Fortran.Vars.SymbolTable+                                                ( collectSymbols )+import           Language.Fortran.Vars.StructureTable+                                                ( collectStructures )++-- | Given a varaible name, 'RHSFunc' search assignment statements within a program+-- unit and returns the RHS of first assignment statement whose LHS matches the+-- input variable name.+type RHSFunc a = Name -> Expression a++-- | Given a 'ProgramUnit', returns a 'RHSFunc' function that can be used to+-- search the 'ProgramFile' and return the RHS of an assignment.+getRhsFunc :: Data a => ProgramUnit a -> RHSFunc a+getRhsFunc pu lhs = head+  [ rhs+  | (StExpressionAssign _ _ (ExpValue _ _ (ValVariable name)) rhs) <- allPUS pu+  , name == lhs+  ]+++helper :: String -> Name -> IO (TypeOf A0, RHSFunc A0)+helper path unit = do+  pf <- getTestProgramAnalysis path+  let pfm                = programFileModel pf+      Just (symTable, _) = M.lookup (Named unit) pfm+      strTable           = collectStructures symTable pu+      typeof             = typeOf strTable symTable+      Just pu            = find (\x -> getName x == Named unit) (allPU pf)+      rhs                = getRhsFunc (stripAnalysis pu)+  return (typeof, rhs)++unknownType :: Either TypeError Type -> Bool+unknownType (Left (UnknownType _)) = True+unknownType _                      = False++typeError :: Either TypeError Type -> Bool+typeError (Left TypeError{}) = True+typeError _                  = False++unboundVariable :: Either TypeError Type -> Bool+unboundVariable (Left (UnboundVariable _)) = True+unboundVariable _                          = False++spec :: Spec+spec = do++  describe "Constants" $ do++    let path   = "test/type_check/constants.f"+    let puName = "constants"+    it "Integer Constant" $ do+      (typeof, rhs) <- helper path puName+      typeof (rhs "i1") `shouldBe` Right (TInteger 4)+      typeof (rhs "i2") `shouldBe` Right (TInteger 4)+      typeof (rhs "i3") `shouldBe` Right (TInteger 4)+      typeof (rhs "i4") `shouldBe` Right (TInteger 4)+++    it "Logical Constant" $ do+      (typeof, rhs) <- helper path puName+      typeof (rhs "l1") `shouldBe` Right (TLogical 4)+      typeof (rhs "l2") `shouldBe` Right (TLogical 4)++    it "Real Constant" $ do+      (typeof, rhs) <- helper path puName+      typeof (rhs "r1") `shouldBe` Right (TReal 4)+      typeof (rhs "r2") `shouldBe` Right (TReal 4)+      typeof (rhs "r3") `shouldBe` Right (TReal 4)+      typeof (rhs "r4") `shouldBe` Right (TReal 4)+      typeof (rhs "r5") `shouldBe` Right (TReal 4)++      typeof (rhs "r6") `shouldBe` Right (TReal 8)+      typeof (rhs "r7") `shouldBe` Right (TReal 8)++    it "Complex Constant" $ do+      (typeof, rhs) <- helper path puName+      typeof (rhs "c1") `shouldBe` Right (TComplex 8)+      typeof (rhs "c2") `shouldBe` Right (TComplex 8)+      typeof (rhs "c3") `shouldBe` Right (TComplex 8)+      typeof (rhs "c4") `shouldBe` Right (TComplex 8)++      typeof (rhs "c5") `shouldBe` Right (TComplex 16)+      typeof (rhs "c6") `shouldBe` Right (TComplex 16)+      typeof (rhs "c7") `shouldBe` Right (TComplex 16)++    it "Character Constant" $ do+      (typeof, rhs) <- helper path puName+      typeof (rhs "s1") `shouldBe` Right (TCharacter (CharLenInt 8) 1)++    it "BOZ Constant" $ do+      (typeof, rhs) <- helper path puName+      mapM_ (\v -> typeof (rhs v) `shouldBe` Right (TByte 4))+            ["b1", "b2", "b3", "b4"]++    it "Hollerith Constant" $ do+      (typeof, rhs) <- helper path puName+      typeof (rhs "h1") `shouldBe` Right (TByte 2)+      typeof (rhs "h2") `shouldBe` Right (TByte 8)++  describe "Variables" $ do+    let path   = "test/type_check/variables.f"+        puName = "variables"++    it "Byte" $ do+      (typeof, rhs) <- helper path puName+      typeof (rhs "b") `shouldBe` Right (TByte 1)++    it "Character" $ do+      (typeof, rhs) <- helper path puName+      typeof (rhs "c") `shouldBe` Right (TCharacter (CharLenInt 1) 1)+      typeof (rhs "c1") `shouldBe` Right (TCharacter (CharLenInt 7) 1)+      typeof (rhs "c2") `shouldBe` Right (TCharacter (CharLenInt 7) 1)+      typeof (rhs "c3") `shouldBe` Right (TCharacter (CharLenInt 4) 1)+      typeof (rhs "c4") `shouldBe` Right (TCharacter (CharLenInt 8) 1)++    it "Integer" $ do+      (typeof, rhs) <- helper path puName+      typeof (rhs "i") `shouldBe` Right (TInteger 4)+      typeof (rhs "i2") `shouldBe` Right (TInteger 2)+      typeof (rhs "i4") `shouldBe` Right (TInteger 4)+      typeof (rhs "i8") `shouldBe` Right (TInteger 8)+      typeof (rhs "i2ns") `shouldBe` Right (TInteger 2)+      typeof (rhs "i4ns") `shouldBe` Right (TInteger 4)+      typeof (rhs "i8ns") `shouldBe` Right (TInteger 8)++    it "Real" $ do+      (typeof, rhs) <- helper path puName+      typeof (rhs "r") `shouldBe` Right (TReal 4)+      typeof (rhs "r4") `shouldBe` Right (TReal 4)+      typeof (rhs "r8") `shouldBe` Right (TReal 8)+      typeof (rhs "r4ns") `shouldBe` Right (TReal 4)+      typeof (rhs "r8ns") `shouldBe` Right (TReal 8)+      typeof (rhs "dp") `shouldBe` Right (TReal 8)++  describe "Array" $ do+    let path   = "test/type_check/array_and_substring.f"+        puName = "array"++    it "Array" $ do+      (typeof, rhs) <- helper path puName+      typeof (rhs "arr1") `shouldBe` Right (TInteger 4)+      typeof (rhs "arr2") `shouldBe` Right (TInteger 4)++    it "Adjustable Array" $ do+      (typeof, rhs) <- helper path puName+      typeof (rhs "arr3") `shouldBe` Right (TInteger 4)++    it "Assumed-size Array" $ do+      (typeof, rhs) <- helper path puName+      typeof (rhs "arr4") `shouldBe` Right (TInteger 4)++    it "Array partial access" $ do+      -- implicit lower bound arrays+      (typeof, rhs) <- helper path puName+      typeof (rhs "arr5") `shouldBe` Right (TInteger 4)++    it "Index ranges" $ do+      (typeof, rhs) <- helper path puName+      typeof (rhs "i1") `shouldBe` Right (TArray (TInteger 4) (Just [(1, 10)]))+      typeof (rhs "i2") `shouldBe` Right (TArray (TInteger 4) (Just [(1, 10)]))+      typeof (rhs "i3") `shouldBe` Right (TArray (TInteger 4) Nothing)++    it "Erroneous expressions" $ do+      -- These expressions aren't valid but any subscript can be assumed to+      -- access a scalar element from it+      (typeof, rhs) <- helper path puName+      typeof (rhs "err1") `shouldBe` Right (TInteger 4)+      typeof (rhs "err2") `shouldBe` Right (TInteger 4)+      typeof (rhs "err3") `shouldBe` Right (TInteger 4)+      -- Can't deal with array sections+      isLeft (typeof (rhs "err4")) `shouldBe` True++  describe "String" $ do+    let path   = "test/type_check/array_and_substring.f"+        puName = "string"++    it "Assumed-size string" $ do+      -- TODO all Nothings, unsure though what assumed-size means+      (typeof, rhs) <- helper path puName+      typeof (rhs "s1") `shouldBe` Right (TCharacter CharLenStar 1)+      typeof (rhs "s2") `shouldBe` Right (TCharacter CharLenStar 1)+      typeof (rhs "s3") `shouldBe` Right (TCharacter CharLenStar 1)++    it "substring" $ do+      (typeof, rhs) <- helper path puName+      typeof (rhs "s4") `shouldBe` Right (TCharacter (CharLenInt 5) 1)+      typeof (rhs "s5") `shouldBe` Right (TCharacter (CharLenInt 6) 1)+      typeof (rhs "s6") `shouldBe` Right (TCharacter (CharLenInt 10) 1)+      typeof (rhs "s7") `shouldBe` Right (TCharacter (CharLenInt 3) 1)+      -- Dynamic arrays+      typeof (rhs "s8") `shouldBe` Right (TCharacter CharLenStar 1)+      typeof (rhs "s9") `shouldBe` Right (TCharacter CharLenStar 1)+      typeof (rhs "s10") `shouldBe` Right (TCharacter CharLenStar 1)++  describe "Expression" $ do+    let path   = "test/type_check/expression.f"+        puName = "expression"++    it "Unary Expression" $ do+      (typeof, rhs) <- helper path puName+      typeof (rhs "u1") `shouldBe` Right (TInteger 4)+      typeof (rhs "u2") `shouldBe` Right (TInteger 4)+      typeof (rhs "u3") `shouldBe` Right (TReal 4)+      typeof (rhs "u4") `shouldBe` Right (TReal 4)+      typeof (rhs "u5") `shouldBe` Right (TLogical 4)+      typeof (rhs "u6") `shouldBe` Right (TLogical 4)++    it "Arithmetic Expression with Type Promotion" $ do+      (typeof, rhs) <- helper path puName+      typeof (rhs "a1") `shouldBe` Right (TInteger 4)+      typeof (rhs "a2") `shouldBe` Right (TInteger 4)+      typeof (rhs "a3") `shouldBe` Right (TInteger 8)+      typeof (rhs "a4") `shouldBe` Right (TInteger 8)+      typeof (rhs "a5") `shouldBe` Right (TInteger 8)++      typeof (rhs "a6") `shouldBe` Right (TInteger 4)+      typeof (rhs "a7") `shouldBe` Right (TInteger 4)+      typeof (rhs "a8") `shouldBe` Right (TInteger 4)+      typeof (rhs "a9") `shouldBe` Right (TInteger 8)++      typeof (rhs "a10") `shouldBe` Right (TReal 4)+      typeof (rhs "a11") `shouldBe` Right (TReal 8)+      typeof (rhs "a12") `shouldBe` Right (TReal 8)+      typeof (rhs "a13") `shouldBe` Right (TReal 8)+      typeof (rhs "a14") `shouldBe` Right (TReal 8)+      typeof (rhs "a15") `shouldBe` Right (TReal 8)+      typeof (rhs "a16") `shouldBe` Right (TReal 8)+      typeof (rhs "a17") `shouldBe` Right (TReal 4)++      typeof (rhs "a18") `shouldBe` Right (TComplex 8)+      typeof (rhs "a19") `shouldBe` Right (TComplex 8)+      typeof (rhs "a20") `shouldBe` Right (TComplex 16)+      typeof (rhs "a21") `shouldBe` Right (TComplex 16)++    it "Character Concatenation" $ do+      (typeof, rhs) <- helper path puName+      typeof (rhs "s1") `shouldBe` Right (TCharacter (CharLenInt 8) 1)+      typeof (rhs "s1") `shouldBe` Right (TCharacter (CharLenInt 8) 1)++    it "Relational Expression" $ do+      (typeof, rhs) <- helper path puName+      typeof (rhs "re1") `shouldBe` Right (TLogical 4)+      typeof (rhs "re2") `shouldBe` Right (TLogical 4)+      typeof (rhs "re3") `shouldBe` Right (TLogical 4)+      typeof (rhs "re4") `shouldBe` Right (TLogical 4)+      typeof (rhs "re5") `shouldBe` Right (TLogical 4)+      typeof (rhs "re6") `shouldBe` Right (TLogical 4)++    it "Logical Expression" $ do+      (typeof, rhs) <- helper path puName+      typeof (rhs "le1") `shouldBe` Right (TLogical 4)+      typeof (rhs "le2") `shouldBe` Right (TLogical 8)+      typeof (rhs "le3") `shouldBe` Right (TLogical 2)+      typeof (rhs "le4") `shouldBe` Right (TLogical 2)+      typeof (rhs "le5") `shouldBe` Right (TLogical 4)++    it "More expressions" $ do+      (typeof, rhs) <- helper path puName+      typeof (rhs "e1") `shouldBe` Right (TInteger 8)+      typeof (rhs "e2") `shouldBe` Right (TInteger 4)+      typeof (rhs "e3") `shouldBe` Right (TComplex 8)+      typeof (rhs "e4") `shouldBe` Right (TLogical 4)+      typeof (rhs "e5") `shouldBe` Right (TInteger 4)++  describe "Intrinsics" $ do+    let path   = "test/type_check/intrinsic.f"+        puName = "intrinsictest"++    it "Integer intrinsic" $ do+      (typeof, rhs) <- helper path puName+      typeof (rhs "b1") `shouldBe` Right (TInteger 4)+      typeof (rhs "b2") `shouldBe` Right (TInteger 4)++    it "Real intrinsic" $ do+      (typeof, rhs) <- helper path puName+      typeof (rhs "b3") `shouldBe` Right (TReal 4)+      typeof (rhs "b4") `shouldBe` Right (TReal 4)++    it "Character intrinsic" $ do+      (typeof, rhs) <- helper path puName+      typeof (rhs "b5") `shouldBe` Right (TCharacter (CharLenInt 1) 1)++    it "Generic intrinsic" $ do+      (typeof, rhs) <- helper path puName+      typeof (rhs "b6") `shouldBe` Right (TInteger 4)+      typeof (rhs "b7") `shouldBe` Right (TReal 4)+      typeof (rhs "b8") `shouldBe` Right (TInteger 8)+      typeof (rhs "b9") `shouldBe` Right (TReal 8)++    it "INT(e), INT(e, k), and INT2" $ do+      (typeof, rhs) <- helper path puName+      typeof (rhs "b10") `shouldBe` Right (TInteger 4)+      typeof (rhs "b11") `shouldBe` Right (TInteger 2)+      typeof (rhs "b12") `shouldBe` Right (TInteger 4)+      typeof (rhs "b13") `shouldBe` Right (TInteger 8)+      typeof (rhs "b14") `shouldBe` Right (TInteger 8)+      typeof (rhs "b15") `shouldBe` Right (TInteger 2)+      typeof (rhs "b16") `shouldBe` Right (TInteger 2)+      typeof (rhs "b17") `shouldBe` Right (TInteger 2)++    it "iand, ior, ishft" $ do+      (typeof, rhs) <- helper path puName+      typeof (rhs "b18") `shouldBe` Right (TInteger 4)+      typeof (rhs "b19") `shouldBe` Right (TInteger 4)+      typeof (rhs "b20") `shouldBe` Right (TInteger 8)+      typeof (rhs "b21") `shouldBe` Right (TInteger 4)+      typeof (rhs "b22") `shouldBe` Right (TInteger 4)+      typeof (rhs "b23") `shouldBe` Right (TInteger 8)+      typeof (rhs "b24") `shouldBe` Right (TInteger 4)+      typeof (rhs "b25") `shouldBe` Right (TInteger 8)+      typeof (rhs "b26") `shouldBe` Right (TInteger 2)++    it "Misc intrinsics" $ do+      (typeof, rhs) <- helper path puName+      typeof (rhs "b27") `shouldBe` Right (TReal 8)+      typeof (rhs "b28") `shouldBe` Right (TInteger 4)+      typeof (rhs "b29") `shouldBe` Right (TInteger 4)+      typeof (rhs "b30") `shouldBe` Right (TInteger 4)+      typeof (rhs "b31") `shouldBe` Right (TInteger 4)+      typeof (rhs "b32") `shouldBe` Right (TInteger 4)+      typeof (rhs "b33") `shouldBe` Right (TInteger 4)+      typeof (rhs "b34") `shouldBe` Right (TInteger 8)+      typeof (rhs "b35") `shouldBe` Right (TInteger 4)+      typeof (rhs "b36") `shouldBe` Right (TInteger 4)+      typeof (rhs "b37") `shouldBe` Right (TInteger 8)+      typeof (rhs "b38") `shouldBe` Right (TLogical 4)++  describe "Implied Do" $ it "data statements" $ do+    ProgramFile _ (pu : _) <- getTestProgramAnalysis+      "test/type_check/implied_do.f"+    let+      symt = collectSymbols pu+      strt = collectStructures symt pu+      dgs  = [ aStrip dgs' | StData _ _ dgs' <- allPUS pu ]+      test (DataGroup _ _ es _ : _) dims = typeOf strt symt (head $ aStrip es)+        `shouldBe` Right (TArray (TInteger 2) (Just dims))+      test _ _ = error "Shouldn't reach this"+    let res =+          [ [(1, 5)]+          , [(1, 3)]+          , [(1, 3)]+          , [(1, 9)]+          , [(1, 2)]+          , [(1, 6)]+          , [(1, 3)]+          , [(1, 2)]+          , [(1, 2)]+          ]+    length dgs `shouldBe` length res+    zipWithM_ test dgs res